summaryrefslogtreecommitdiffstats
path: root/generic/tclProc.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclProc.c')
-rw-r--r--generic/tclProc.c406
1 files changed, 221 insertions, 185 deletions
diff --git a/generic/tclProc.c b/generic/tclProc.c
index d33d063..ce1c767 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -152,20 +152,25 @@ Tcl_ProcObjCmd(
&nsPtr, &altNsPtr, &cxtNsPtr, &procName);
if (nsPtr == NULL) {
- Tcl_AppendResult(interp, "can't create procedure \"", fullName,
- "\": unknown namespace", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't create procedure \"%s\": unknown namespace",
+ fullName));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
return TCL_ERROR;
}
if (procName == NULL) {
- Tcl_AppendResult(interp, "can't create procedure \"", fullName,
- "\": bad procedure name", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't create procedure \"%s\": bad procedure name",
+ fullName));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
return TCL_ERROR;
}
if ((nsPtr != iPtr->globalNsPtr)
&& (procName != NULL) && (procName[0] == ':')) {
- Tcl_AppendResult(interp, "can't create procedure \"", procName,
- "\" in non-global namespace with name starting with \":\"",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't create procedure \"%s\" in non-global namespace with"
+ " name starting with \":\"", procName));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
return TCL_ERROR;
}
@@ -191,7 +196,7 @@ Tcl_ProcObjCmd(
Tcl_DStringInit(&ds);
if (nsPtr != iPtr->globalNsPtr) {
Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
- Tcl_DStringAppend(&ds, "::", 2);
+ TclDStringAppendLiteral(&ds, "::");
}
Tcl_DStringAppend(&ds, procName, -1);
@@ -253,11 +258,11 @@ Tcl_ProcObjCmd(
&& (contextPtr->nline >= 4) && (contextPtr->line[3] >= 0)) {
int isNew;
Tcl_HashEntry *hePtr;
- CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame));
+ CmdFrame *cfPtr = ckalloc(sizeof(CmdFrame));
cfPtr->level = -1;
cfPtr->type = contextPtr->type;
- cfPtr->line = (int *) ckalloc(sizeof(int));
+ cfPtr->line = ckalloc(sizeof(int));
cfPtr->line[0] = contextPtr->line[3];
cfPtr->nline = 1;
cfPtr->framePtr = NULL;
@@ -266,8 +271,8 @@ Tcl_ProcObjCmd(
cfPtr->data.eval.path = contextPtr->data.eval.path;
Tcl_IncrRefCount(cfPtr->data.eval.path);
- cfPtr->cmd.str.cmd = NULL;
- cfPtr->cmd.str.len = 0;
+ cfPtr->cmd = NULL;
+ cfPtr->len = 0;
hePtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr,
procPtr, &isNew);
@@ -285,9 +290,9 @@ Tcl_ProcObjCmd(
Tcl_DecrRefCount(cfOldPtr->data.eval.path);
cfOldPtr->data.eval.path = NULL;
}
- ckfree((char *) cfOldPtr->line);
+ ckfree(cfOldPtr->line);
cfOldPtr->line = NULL;
- ckfree((char *) cfOldPtr);
+ ckfree(cfOldPtr);
}
Tcl_SetHashValue(hePtr, cfPtr);
}
@@ -330,7 +335,9 @@ Tcl_ProcObjCmd(
}
if ((procArgs[0] == 'a') && (strncmp(procArgs, "args", 4) == 0)) {
- procArgs += 4;
+ int numBytes;
+
+ procArgs +=4;
while (*procArgs != '\0') {
if (*procArgs != ' ') {
goto done;
@@ -342,12 +349,9 @@ Tcl_ProcObjCmd(
* The argument list is just "args"; check the body
*/
- procBody = TclGetString(objv[3]);
- while (*procBody != '\0') {
- if (!isspace(UCHAR(*procBody))) {
- goto done;
- }
- procBody++;
+ procBody = Tcl_GetStringFromObj(objv[3], &numBytes);
+ if (TclParseAllWhiteSpace(procBody, numBytes) < numBytes) {
+ goto done;
}
/*
@@ -417,7 +421,7 @@ TclCreateProc(
* will be holding a reference to it.
*/
- procPtr = bodyPtr->internalRep.otherValuePtr;
+ procPtr = bodyPtr->internalRep.twoPtrValue.ptr1;
procPtr->iPtr = iPtr;
procPtr->refCount++;
precompiled = 1;
@@ -460,7 +464,7 @@ TclCreateProc(
Tcl_IncrRefCount(bodyPtr);
- procPtr = (Proc *) ckalloc(sizeof(Proc));
+ procPtr = ckalloc(sizeof(Proc));
procPtr->iPtr = iPtr;
procPtr->refCount = 1;
procPtr->bodyPtr = bodyPtr;
@@ -491,6 +495,8 @@ TclCreateProc(
"procedure \"%s\": arg list contains %d entries, "
"precompiled header expects %d", procName, numArgs,
procPtr->numArgs));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
+ "BYTECODELIES", NULL);
goto procError;
}
localPtr = procPtr->firstLocalPtr;
@@ -513,15 +519,20 @@ TclCreateProc(
goto procError;
}
if (fieldCount > 2) {
- ckfree((char *) fieldValues);
- Tcl_AppendResult(interp,
- "too many fields in argument specifier \"",
- argArray[i], "\"", NULL);
+ ckfree(fieldValues);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "too many fields in argument specifier \"%s\"",
+ argArray[i]));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
+ "FORMALARGUMENTFORMAT", NULL);
goto procError;
}
if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
- ckfree((char *) fieldValues);
- Tcl_AppendResult(interp, "argument with no name", NULL);
+ ckfree(fieldValues);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "argument with no name", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
+ "FORMALARGUMENTFORMAT", NULL);
goto procError;
}
@@ -545,17 +556,21 @@ TclCreateProc(
} while (*q != '\0');
q--;
if (*q == ')') { /* We have an array element. */
- Tcl_AppendResult(interp, "formal parameter \"",
- fieldValues[0],
- "\" is an array element", NULL);
- ckfree((char *) fieldValues);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "formal parameter \"%s\" is an array element",
+ fieldValues[0]));
+ ckfree(fieldValues);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
+ "FORMALARGUMENTFORMAT", NULL);
goto procError;
}
} else if ((*p == ':') && (*(p+1) == ':')) {
- Tcl_AppendResult(interp, "formal parameter \"",
- fieldValues[0],
- "\" is not a simple name", NULL);
- ckfree((char *) fieldValues);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "formal parameter \"%s\" is not a simple name",
+ fieldValues[0]));
+ ckfree(fieldValues);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
+ "FORMALARGUMENTFORMAT", NULL);
goto procError;
}
p++;
@@ -582,7 +597,9 @@ TclCreateProc(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"procedure \"%s\": formal parameter %d is "
"inconsistent with precompiled body", procName, i));
- ckfree((char *) fieldValues);
+ ckfree(fieldValues);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
+ "BYTECODELIES", NULL);
goto procError;
}
@@ -601,7 +618,9 @@ TclCreateProc(
"procedure \"%s\": formal parameter \"%s\" has "
"default value inconsistent with precompiled body",
procName, fieldValues[0]));
- ckfree((char *) fieldValues);
+ ckfree(fieldValues);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
+ "BYTECODELIES", NULL);
goto procError;
}
}
@@ -619,8 +638,7 @@ TclCreateProc(
* local variables for the argument.
*/
- localPtr = (CompiledLocal *) ckalloc((unsigned)
- (TclOffset(CompiledLocal, name) + nameLength + 1));
+ localPtr = ckalloc(TclOffset(CompiledLocal, name) + nameLength+1);
if (procPtr->firstLocalPtr == NULL) {
procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
} else {
@@ -649,11 +667,11 @@ TclCreateProc(
}
}
- ckfree((char *) fieldValues);
+ ckfree(fieldValues);
}
*procPtrPtr = procPtr;
- ckfree((char *) argArray);
+ ckfree(argArray);
return TCL_OK;
procError:
@@ -670,12 +688,12 @@ TclCreateProc(
Tcl_DecrRefCount(defPtr);
}
- ckfree((char *) localPtr);
+ ckfree(localPtr);
}
- ckfree((char *) procPtr);
+ ckfree(procPtr);
}
if (argArray != NULL) {
- ckfree((char *) argArray);
+ ckfree(argArray);
}
return TCL_ERROR;
}
@@ -754,8 +772,8 @@ TclGetFrame(
return result;
levelError:
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL);
return -1;
}
@@ -819,7 +837,7 @@ TclObjGetFrame(
}
/* TODO: Consider skipping the typePtr checks */
} else if (objPtr->typePtr == &tclIntType
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
|| objPtr->typePtr == &tclWideIntType
#endif
) {
@@ -886,9 +904,8 @@ TclObjGetFrame(
return result;
levelError:
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL);
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "LEVEL", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL);
return -1;
}
@@ -1106,6 +1123,8 @@ ProcWrongNumArgs(
if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) {
desiredObjs[0] = Tcl_NewStringObj("lambdaExpr", -1);
} else {
+ ((Interp *) interp)->ensembleRewrite.numInsertedObjs -= skip - 1;
+
#ifdef AVOID_HACKS_FOR_ITCL
desiredObjs[0] = framePtr->objv[skip-1];
#else
@@ -1178,7 +1197,7 @@ TclInitCompiledLocals(
if (bodyPtr->typePtr != &tclByteCodeType) {
Tcl_Panic("body object for proc attached to frame is not a byte code type");
}
- codePtr = bodyPtr->internalRep.otherValuePtr;
+ codePtr = bodyPtr->internalRep.twoPtrValue.ptr1;
if (framePtr->numCompiledLocals) {
if (!codePtr->localCachePtr) {
@@ -1247,7 +1266,7 @@ InitResolvedLocals(
if (localPtr->resolveInfo->deleteProc) {
localPtr->resolveInfo->deleteProc(localPtr->resolveInfo);
} else {
- ckfree((char *) localPtr->resolveInfo);
+ ckfree(localPtr->resolveInfo);
}
localPtr->resolveInfo = NULL;
}
@@ -1328,20 +1347,12 @@ TclFreeLocalCache(
for (i = 0; i < localCachePtr->numVars; i++, namePtrPtr++) {
register Tcl_Obj *objPtr = *namePtrPtr;
- /*
- * Note that this can be called with interp==NULL, on interp deletion.
- * In that case, the literal table and objects go away on their own.
- */
-
if (objPtr) {
- if (interp) {
- TclReleaseLiteral(interp, objPtr);
- } else {
- Tcl_DecrRefCount(objPtr);
- }
+ /* TclReleaseLiteral calls Tcl_DecrRefCount for us */
+ TclReleaseLiteral(interp, objPtr);
}
}
- ckfree((char *) localCachePtr);
+ ckfree(localCachePtr);
}
static void
@@ -1349,7 +1360,7 @@ InitLocalCache(
Proc *procPtr)
{
Interp *iPtr = procPtr->iPtr;
- ByteCode *codePtr = procPtr->bodyPtr->internalRep.otherValuePtr;
+ ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
int localCt = procPtr->numCompiledLocals;
int numArgs = procPtr->numArgs, i = 0;
@@ -1365,9 +1376,9 @@ InitLocalCache(
* for future calls.
*/
- localCachePtr = (LocalCache *) ckalloc(sizeof(LocalCache)
- + (localCt-1)*sizeof(Tcl_Obj *)
- + numArgs*sizeof(Var));
+ localCachePtr = ckalloc(sizeof(LocalCache)
+ + (localCt - 1) * sizeof(Tcl_Obj *)
+ + numArgs * sizeof(Var));
namePtr = &localCachePtr->varName0;
varPtr = (Var *) (namePtr + localCt);
@@ -1426,7 +1437,7 @@ InitArgsAndLocals(
{
CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
register Proc *procPtr = framePtr->procPtr;
- ByteCode *codePtr = procPtr->bodyPtr->internalRep.otherValuePtr;
+ ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
register Var *varPtr, *defPtr;
int localCt = procPtr->numCompiledLocals, numArgs, argCt, i, imax;
Tcl_Obj *const *argObjs;
@@ -1613,7 +1624,7 @@ PushProcCallFrame(
* commands and/or resolver changes are considered).
*/
- codePtr = procPtr->bodyPtr->internalRep.otherValuePtr;
+ codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != nsPtr)
@@ -1769,6 +1780,7 @@ TclNRInterpProcCore(
}
#endif /*TCL_COMPILE_DEBUG*/
+#ifdef USE_DTRACE
if (TCL_DTRACE_PROC_ARGS_ENABLED()) {
int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
const char *a[10];
@@ -1798,13 +1810,22 @@ TclNRInterpProcCore(
iPtr->varFramePtr->objc - l - 1,
(Tcl_Obj **)(iPtr->varFramePtr->objv + l + 1));
}
+ if (TCL_DTRACE_PROC_ENTRY_ENABLED()) {
+ int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
+
+ TCL_DTRACE_PROC_ENTRY(l < iPtr->varFramePtr->objc ?
+ TclGetString(iPtr->varFramePtr->objv[l]) : NULL,
+ iPtr->varFramePtr->objc - l - 1,
+ (Tcl_Obj **)(iPtr->varFramePtr->objv + l + 1));
+ }
+#endif /* USE_DTRACE */
/*
* Invoke the commands in the procedure's body.
*/
procPtr->refCount++;
- codePtr = procPtr->bodyPtr->internalRep.otherValuePtr;
+ codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
TclNRAddCallback(interp, InterpProcNR2, procNameObj, errorProc,
NULL, NULL);
@@ -1834,9 +1855,39 @@ InterpProcNR2(
}
/*
- * Process the result code.
+ * Free the stack-allocated compiled locals and CallFrame. It is important
+ * to pop the call frame without freeing it first: the compiledLocals
+ * cannot be freed before the frame is popped, as the local variables must
+ * be deleted. But the compiledLocals must be freed first, as they were
+ * allocated later on the stack.
+ */
+
+ if (result != TCL_OK) {
+ goto process;
+ }
+
+ done:
+ if (TCL_DTRACE_PROC_RESULT_ENABLED()) {
+ int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
+ Tcl_Obj *r = Tcl_GetObjResult(interp);
+
+ TCL_DTRACE_PROC_RESULT(l < iPtr->varFramePtr->objc ?
+ TclGetString(iPtr->varFramePtr->objv[l]) : NULL, result,
+ TclGetString(r), r);
+ }
+
+ freePtr = iPtr->framePtr;
+ Tcl_PopCallFrame(interp); /* Pop but do not free. */
+ TclStackFree(interp, freePtr->compiledLocals);
+ /* Free compiledLocals. */
+ TclStackFree(interp, freePtr); /* Free CallFrame. */
+ return result;
+
+ /*
+ * Process any non-TCL_OK result code.
*/
+ process:
switch (result) {
case TCL_RETURN:
/*
@@ -1853,10 +1904,10 @@ InterpProcNR2(
* transform to an error now.
*/
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "invoked \"",
- ((result == TCL_BREAK) ? "break" : "continue"),
- "\" outside of a loop", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "invoked \"%s\" outside of a loop",
+ ((result == TCL_BREAK) ? "break" : "continue")));
+ Tcl_SetErrorCode(interp, "TCL", "RESULT", "UNEXPECTED", NULL);
result = TCL_ERROR;
/*
@@ -1871,46 +1922,8 @@ InterpProcNR2(
*/
errorProc(interp, procNameObj);
-
- default:
- /*
- * Process other results (OK and non-standard) by doing nothing
- * special, skipping directly to the code afterwards that cleans up
- * associated memory.
- *
- * Non-standard results are processed by passing them through quickly.
- * This means they all work as exceptions, unwinding the stack quickly
- * and neatly. Who knows how well they are handled by third-party code
- * though...
- */
-
- (void) 0; /* do nothing */
}
-
- if (TCL_DTRACE_PROC_RESULT_ENABLED()) {
- int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
- Tcl_Obj *r = Tcl_GetObjResult(interp);
-
- TCL_DTRACE_PROC_RESULT(l < iPtr->varFramePtr->objc ?
- TclGetString(iPtr->varFramePtr->objv[l]) : NULL, result,
- TclGetString(r), r);
- }
-
- /*
- * Free the stack-allocated compiled locals and CallFrame. It is important
- * to pop the call frame without freeing it first: the compiledLocals
- * cannot be freed before the frame is popped, as the local variables must
- * be deleted. But the compiledLocals must be freed first, as they were
- * allocated later on the stack.
- */
-
- freePtr = iPtr->framePtr;
- Tcl_PopCallFrame(interp); /* Pop but do not free. */
- TclStackFree(interp, freePtr->compiledLocals);
- /* Free compiledLocals. */
- TclStackFree(interp, freePtr); /* Free CallFrame. */
-
- return result;
+ goto done;
}
/*
@@ -1946,7 +1959,7 @@ TclProcCompileProc(
{
Interp *iPtr = (Interp *) interp;
Tcl_CallFrame *framePtr;
- ByteCode *codePtr = bodyPtr->internalRep.otherValuePtr;
+ ByteCode *codePtr = bodyPtr->internalRep.twoPtrValue.ptr1;
/*
* If necessary, compile the procedure's body. The compiler will allocate
@@ -1972,15 +1985,16 @@ TclProcCompileProc(
if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
if ((Interp *) *codePtr->interpHandle != iPtr) {
- Tcl_AppendResult(interp,
- "a precompiled script jumped interps", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "a precompiled script jumped interps", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
+ "CROSSINTERPBYTECODE", NULL);
return TCL_ERROR;
}
codePtr->compileEpoch = iPtr->compileEpoch;
codePtr->nsPtr = nsPtr;
} else {
- bodyPtr->typePtr->freeIntRepProc(bodyPtr);
- bodyPtr->typePtr = NULL;
+ TclFreeIntRep(bodyPtr);
}
}
@@ -2035,8 +2049,16 @@ TclProcCompileProc(
procPtr->lastLocalPtr = lastPtr;
while (clPtr) {
CompiledLocal *toFree = clPtr;
+
clPtr = clPtr->nextPtr;
- ckfree((char *) toFree);
+ if (toFree->resolveInfo) {
+ if (toFree->resolveInfo->deleteProc) {
+ toFree->resolveInfo->deleteProc(toFree->resolveInfo);
+ } else {
+ ckfree(toFree->resolveInfo);
+ }
+ }
+ ckfree(toFree);
}
procPtr->numCompiledLocals = procPtr->numArgs;
}
@@ -2057,7 +2079,7 @@ TclProcCompileProc(
iPtr->invokeWord = 0;
iPtr->invokeCmdFramePtr = (hePtr ? Tcl_GetHashValue(hePtr) : NULL);
- tclByteCodeType.setFromAnyProc(interp, bodyPtr);
+ TclSetByteCodeFromAny(interp, bodyPtr, NULL, NULL);
iPtr->invokeCmdFramePtr = NULL;
TclPopStackFrame(interp);
} else if (codePtr->nsEpoch != nsPtr->resolverEpoch) {
@@ -2179,7 +2201,7 @@ TclProcCleanupProc(
if (resVarInfo->deleteProc) {
resVarInfo->deleteProc(resVarInfo);
} else {
- ckfree((char *) resVarInfo);
+ ckfree(resVarInfo);
}
}
@@ -2187,10 +2209,10 @@ TclProcCleanupProc(
defPtr = localPtr->defValuePtr;
Tcl_DecrRefCount(defPtr);
}
- ckfree((char *) localPtr);
+ ckfree(localPtr);
localPtr = nextPtr;
}
- ckfree((char *) procPtr);
+ ckfree(procPtr);
/*
* TIP #280: Release the location data associated with this Proc
@@ -2198,7 +2220,7 @@ TclProcCleanupProc(
* procbody structures created by tbcload.
*/
- if (!iPtr) {
+ if (iPtr == NULL) {
return;
}
@@ -2209,13 +2231,15 @@ TclProcCleanupProc(
cfPtr = Tcl_GetHashValue(hePtr);
- if (cfPtr->type == TCL_LOCATION_SOURCE) {
- Tcl_DecrRefCount(cfPtr->data.eval.path);
- cfPtr->data.eval.path = NULL;
+ if (cfPtr) {
+ if (cfPtr->type == TCL_LOCATION_SOURCE) {
+ Tcl_DecrRefCount(cfPtr->data.eval.path);
+ cfPtr->data.eval.path = NULL;
+ }
+ ckfree(cfPtr->line);
+ cfPtr->line = NULL;
+ ckfree(cfPtr);
}
- ckfree((char *) cfPtr->line);
- cfPtr->line = NULL;
- ckfree((char *) cfPtr);
Tcl_DeleteHashEntry(hePtr);
}
@@ -2325,7 +2349,7 @@ TclNewProcBodyObj(
TclNewObj(objPtr);
if (objPtr) {
objPtr->typePtr = &tclProcBodyType;
- objPtr->internalRep.otherValuePtr = procPtr;
+ objPtr->internalRep.twoPtrValue.ptr1 = procPtr;
procPtr->refCount++;
}
@@ -2355,10 +2379,10 @@ ProcBodyDup(
Tcl_Obj *srcPtr, /* Object to copy. */
Tcl_Obj *dupPtr) /* Target object for the duplication. */
{
- Proc *procPtr = srcPtr->internalRep.otherValuePtr;
+ Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1;
dupPtr->typePtr = &tclProcBodyType;
- dupPtr->internalRep.otherValuePtr = procPtr;
+ dupPtr->internalRep.twoPtrValue.ptr1 = procPtr;
procPtr->refCount++;
}
@@ -2385,10 +2409,9 @@ static void
ProcBodyFree(
Tcl_Obj *objPtr) /* The object to clean up. */
{
- Proc *procPtr = objPtr->internalRep.otherValuePtr;
+ Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1;
- procPtr->refCount--;
- if (procPtr->refCount <= 0) {
+ if (procPtr->refCount-- < 2) {
TclProcCleanupProc(procPtr);
}
}
@@ -2446,21 +2469,26 @@ SetLambdaFromAny(
{
Interp *iPtr = (Interp *) interp;
const char *name;
- Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv, *errPtr;
- int objc, result;
+ Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv;
+ int isNew, objc, result;
+ CmdFrame *cfPtr = NULL;
Proc *procPtr;
+ if (interp == NULL) {
+ return TCL_ERROR;
+ }
+
/*
* Convert objPtr to list type first; if it cannot be converted, or if its
* length is not 2, then it cannot be converted to lambdaType.
*/
- result = TclListObjGetElements(interp, objPtr, &objc, &objv);
+ result = TclListObjGetElements(NULL, objPtr, &objc, &objv);
if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) {
- TclNewLiteralStringObj(errPtr, "can't interpret \"");
- Tcl_AppendObjToObj(errPtr, objPtr);
- Tcl_AppendToObj(errPtr, "\" as a lambda expression", -1);
- Tcl_SetObjResult(interp, errPtr);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't interpret \"%s\" as a lambda expression",
+ Tcl_GetString(objPtr)));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", NULL);
return TCL_ERROR;
}
@@ -2538,19 +2566,19 @@ SetLambdaFromAny(
if (contextPtr->line
&& (contextPtr->nline >= 2) && (contextPtr->line[1] >= 0)) {
- int isNew, buf[2];
- CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame));
+ int buf[2];
/*
* Move from approximation (line of list cmd word) to actual
* location (line of 2nd list element).
*/
+ cfPtr = ckalloc(sizeof(CmdFrame));
TclListLines(objPtr, contextPtr->line[1], 2, buf, NULL);
cfPtr->level = -1;
cfPtr->type = contextPtr->type;
- cfPtr->line = (int *) ckalloc(sizeof(int));
+ cfPtr->line = ckalloc(sizeof(int));
cfPtr->line[0] = buf[1];
cfPtr->nline = 1;
cfPtr->framePtr = NULL;
@@ -2559,11 +2587,8 @@ SetLambdaFromAny(
cfPtr->data.eval.path = contextPtr->data.eval.path;
Tcl_IncrRefCount(cfPtr->data.eval.path);
- cfPtr->cmd.str.cmd = NULL;
- cfPtr->cmd.str.len = 0;
-
- Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->linePBodyPtr,
- procPtr, &isNew), cfPtr);
+ cfPtr->cmd = NULL;
+ cfPtr->len = 0;
}
/*
@@ -2575,6 +2600,8 @@ SetLambdaFromAny(
}
TclStackFree(interp, contextPtr);
}
+ Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->linePBodyPtr, procPtr,
+ &isNew), cfPtr);
/*
* Set the namespace for this lambda: given by objv[2] understood as a
@@ -2602,7 +2629,7 @@ SetLambdaFromAny(
* conversion to lambdaType.
*/
- objPtr->typePtr->freeIntRepProc(objPtr);
+ TclFreeIntRep(objPtr);
objPtr->internalRep.twoPtrValue.ptr1 = procPtr;
objPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr;
@@ -2677,7 +2704,6 @@ TclNRApplyObjCmd(
else {
/*
* Joe English's suggestion to allow cmdNames to function as lambdas.
- * Also requires making tclCmdNameType non-static in tclObj.c
*/
Tcl_Obj *elemPtr;
@@ -2886,26 +2912,28 @@ Tcl_DisassembleObjCmd(
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "procName");
return TCL_ERROR;
- } else {
- procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2]));
- if (procPtr == NULL) {
- Tcl_AppendResult(interp, "\"", TclGetString(objv[2]),
- "\" isn't a procedure", NULL);
- return TCL_ERROR;
- }
+ }
- /*
- * Compile (if uncompiled) and disassemble a procedure.
- */
+ procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2]));
+ if (procPtr == NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" isn't a procedure", TclGetString(objv[2])));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROC",
+ TclGetString(objv[2]), NULL);
+ return TCL_ERROR;
+ }
- result = PushProcCallFrame(procPtr, interp, 2, objv+1, 1);
- if (result != TCL_OK) {
- return result;
- }
- TclPopStackFrame(interp);
- codeObjPtr = procPtr->bodyPtr;
- break;
+ /*
+ * Compile (if uncompiled) and disassemble a procedure.
+ */
+
+ result = PushProcCallFrame(procPtr, interp, 2, objv+1, 1);
+ if (result != TCL_OK) {
+ return result;
}
+ TclPopStackFrame(interp);
+ codeObjPtr = procPtr->bodyPtr;
+ break;
case DISAS_SCRIPT:
/*
* Compile and disassemble a script.
@@ -2915,10 +2943,9 @@ Tcl_DisassembleObjCmd(
Tcl_WrongNumArgs(interp, 2, objv, "script");
return TCL_ERROR;
}
- if (objv[2]->typePtr != &tclByteCodeType) {
- if (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK){
- return TCL_ERROR;
- }
+ if ((objv[2]->typePtr != &tclByteCodeType)
+ && (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK)) {
+ return TCL_ERROR;
}
codeObjPtr = objv[2];
break;
@@ -2938,8 +2965,10 @@ Tcl_DisassembleObjCmd(
return TCL_ERROR;
}
if (oPtr->classPtr == NULL) {
- Tcl_AppendResult(interp, "\"", TclGetString(objv[2]),
- "\" is not a class", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" is not a class", TclGetString(objv[2])));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
+ TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods,
@@ -2971,14 +3000,18 @@ Tcl_DisassembleObjCmd(
methodBody:
if (hPtr == NULL) {
unknownMethod:
- Tcl_AppendResult(interp, "unknown method \"",
- TclGetString(objv[3]), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown method \"%s\"", TclGetString(objv[3])));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+ TclGetString(objv[3]), NULL);
return TCL_ERROR;
}
procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));
if (procPtr == NULL) {
- Tcl_AppendResult(interp,
- "body not available for this kind of method", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "body not available for this kind of method", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
+ "METHODTYPE", NULL);
return TCL_ERROR;
}
if (procPtr->bodyPtr->typePtr != &tclByteCodeType) {
@@ -3009,9 +3042,12 @@ Tcl_DisassembleObjCmd(
* Do the actual disassembly.
*/
- if (((ByteCode *) codeObjPtr->internalRep.otherValuePtr)->flags
+ if (((ByteCode *) codeObjPtr->internalRep.twoPtrValue.ptr1)->flags
& TCL_BYTECODE_PRECOMPILED) {
- Tcl_AppendResult(interp,"may not disassemble prebuilt bytecode",NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "may not disassemble prebuilt bytecode", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
+ "BYTECODE", NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(codeObjPtr));
generated by cgit v0.12 at 2025-10-23 09:51:09 (GMT)