summaryrefslogtreecommitdiffstats
path: root/generic/tclProc.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclProc.c')
-rw-r--r--generic/tclProc.c127
1 files changed, 30 insertions, 97 deletions
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 6e21c87..833e6d7 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclProc.c,v 1.58 2004/10/06 09:56:06 dkf Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.59 2004/10/06 10:11:05 dkf Exp $
*/
#include "tclInt.h"
@@ -22,9 +22,6 @@
static void ProcBodyDup _ANSI_ARGS_((Tcl_Obj *srcPtr, Tcl_Obj *dupPtr));
static void ProcBodyFree _ANSI_ARGS_((Tcl_Obj *objPtr));
-static int ProcBodySetFromAny _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj *objPtr));
-static void ProcBodyUpdateString _ANSI_ARGS_((Tcl_Obj *objPtr));
static int ProcessProcResultCode _ANSI_ARGS_((Tcl_Interp *interp,
char *procName, int nameLen, int returnCode));
static int TclCompileNoOp _ANSI_ARGS_((Tcl_Interp *interp,
@@ -38,8 +35,11 @@ Tcl_ObjType tclProcBodyType = {
"procbody", /* name for this type */
ProcBodyFree, /* FreeInternalRep procedure */
ProcBodyDup, /* DupInternalRep procedure */
- ProcBodyUpdateString, /* UpdateString procedure */
- ProcBodySetFromAny /* SetFromAny procedure */
+ NULL, /* UpdateString procedure; Tcl_GetString
+ * and Tcl_GetStringFromObj should panic
+ * instead. */
+ NULL /* SetFromAny procedure; Tcl_ConvertToType
+ * should panic instead. */
};
/*
@@ -105,21 +105,18 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv)
0, &nsPtr, &altNsPtr, &cxtNsPtr, &procName);
if (nsPtr == NULL) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "can't create procedure \"", fullName,
+ Tcl_AppendResult(interp, "can't create procedure \"", fullName,
"\": unknown namespace", (char *) NULL);
return TCL_ERROR;
}
if (procName == NULL) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "can't create procedure \"", fullName,
+ Tcl_AppendResult(interp, "can't create procedure \"", fullName,
"\": bad procedure name", (char *) NULL);
return TCL_ERROR;
}
if ((nsPtr != iPtr->globalNsPtr)
&& (procName != NULL) && (procName[0] == ':')) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "can't create procedure \"", procName,
+ Tcl_AppendResult(interp, "can't create procedure \"", procName,
"\" in non-global namespace with name starting with \":\"",
(char *) NULL);
return TCL_ERROR;
@@ -332,12 +329,11 @@ TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr)
if (precompiled) {
if (numArgs > procPtr->numArgs) {
- char buf[64 + TCL_INTEGER_SPACE + TCL_INTEGER_SPACE];
- sprintf(buf, "\": arg list contains %d entries, precompiled header expects %d",
+ char buf[40 + TCL_INTEGER_SPACE + TCL_INTEGER_SPACE];
+ sprintf(buf, "%d entries, precompiled header expects %d",
numArgs, procPtr->numArgs);
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "procedure \"", procName,
- buf, (char *) NULL);
+ Tcl_AppendResult(interp, "procedure \"", procName,
+ "\": arg list contains ", buf, NULL);
goto procError;
}
localPtr = procPtr->firstLocalPtr;
@@ -360,15 +356,14 @@ TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr)
}
if (fieldCount > 2) {
ckfree((char *) fieldValues);
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ Tcl_AppendResult(interp,
"too many fields in argument specifier \"",
argArray[i], "\"", (char *) NULL);
goto procError;
}
if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
ckfree((char *) fieldValues);
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "procedure \"", procName,
+ Tcl_AppendResult(interp, "procedure \"", procName,
"\" has argument with no name", (char *) NULL);
goto procError;
}
@@ -393,20 +388,16 @@ TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr)
} while (*q != '\0');
q--;
if (*q == ')') { /* we have an array element */
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "procedure \"", procName,
+ Tcl_AppendResult(interp, "procedure \"", procName,
"\" has formal parameter \"", fieldValues[0],
- "\" that is an array element",
- (char *) NULL);
+ "\" that is an array element", (char *) NULL);
ckfree((char *) fieldValues);
goto procError;
}
} else if ((*p == ':') && (*(p+1) == ':')) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "procedure \"", procName,
+ Tcl_AppendResult(interp, "procedure \"", procName,
"\" has formal parameter \"", fieldValues[0],
- "\" that is not a simple name",
- (char *) NULL);
+ "\" that is not a simple name", (char *) NULL);
ckfree((char *) fieldValues);
goto procError;
}
@@ -430,13 +421,12 @@ TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr)
&& (fieldCount == 2))
|| ((localPtr->defValuePtr != NULL)
&& (fieldCount != 2))) {
- char buf[80 + TCL_INTEGER_SPACE];
- sprintf(buf, "\": formal parameter %d is inconsistent with precompiled body",
- i);
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "procedure \"", procName,
- buf, (char *) NULL);
+ char buf[40 + TCL_INTEGER_SPACE];
+
ckfree((char *) fieldValues);
+ sprintf(buf, "%d is inconsistent with precompiled body", i);
+ Tcl_AppendResult(interp, "procedure \"", procName,
+ "\": formal parameter ", buf, (char *) NULL);
goto procError;
}
@@ -451,10 +441,8 @@ TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr)
if ((valueLength != tmpLength)
|| (strncmp(fieldValues[1], tmpPtr,
(size_t) tmpLength))) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "procedure \"", procName,
- "\": formal parameter \"",
- fieldValues[0],
+ Tcl_AppendResult(interp, "procedure \"", procName,
+ "\": formal parameter \"", fieldValues[0],
"\" has default value inconsistent with precompiled body",
(char *) NULL);
ckfree((char *) fieldValues);
@@ -1064,7 +1052,7 @@ TclObjInterpProc(clientData, interp, objc, objv)
*/
Tcl_ResetResult(interp);
- objResult = Tcl_GetObjResult(interp);
+ TclNewObj(objResult);
Tcl_AppendToObj(objResult, "wrong # args: should be \"", -1);
/*
@@ -1093,6 +1081,7 @@ TclObjInterpProc(clientData, interp, objc, objv)
localPtr = localPtr->nextPtr;
}
Tcl_AppendStringsToObj(objResult, "\"", (char *) NULL);
+ Tcl_SetObjResult(interp, objResult);
result = TCL_ERROR;
goto procDone;
@@ -1334,9 +1323,9 @@ ProcessProcResultCode(interp, procName, nameLen, returnCode)
}
if (returnCode != TCL_ERROR) {
Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp), ((returnCode == TCL_BREAK)
+ Tcl_AppendResult(interp, ((returnCode == TCL_BREAK)
? "invoked \"break\" outside of a loop"
- : "invoked \"continue\" outside of a loop"), -1);
+ : "invoked \"continue\" outside of a loop"), NULL);
}
errorLine = Tcl_NewIntObj(interp->errorLine);
message = Tcl_NewStringObj("\n (procedure \"", -1);
@@ -1631,62 +1620,6 @@ ProcBodyFree(objPtr)
/*
*----------------------------------------------------------------------
*
- * ProcBodySetFromAny --
- *
- * Tcl_ObjType's SetFromAny function for the proc body object.
- * Calls Tcl_Panic.
- *
- * Results:
- * Theoretically returns a TCL result code.
- *
- * Side effects:
- * Calls Tcl_Panic, since we can't set the value of the object from a
- * string representation (or any other internal ones).
- *
- *----------------------------------------------------------------------
- */
-
-static int
-ProcBodySetFromAny(interp, objPtr)
- Tcl_Interp *interp; /* current interpreter */
- Tcl_Obj *objPtr; /* object pointer */
-{
- Tcl_Panic("called ProcBodySetFromAny");
-
- /*
- * this to keep compilers happy.
- */
-
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * ProcBodyUpdateString --
- *
- * Tcl_ObjType's UpdateString function for the proc body object.
- * Calls Tcl_Panic.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Calls Tcl_Panic, since we this type has no string representation.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-ProcBodyUpdateString(objPtr)
- Tcl_Obj *objPtr; /* the object to update */
-{
- Tcl_Panic("called ProcBodyUpdateString");
-}
-
-/*
- *----------------------------------------------------------------------
- *
* TclCompileNoOp --
*
* Procedure called to compile noOp's