diff options
Diffstat (limited to 'generic/tclProc.c')
| -rw-r--r-- | generic/tclProc.c | 1856 |
1 files changed, 967 insertions, 889 deletions
diff --git a/generic/tclProc.c b/generic/tclProc.c index a35fe60..d58e8da 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -4,10 +4,10 @@ * This file contains routines that implement Tcl procedures, including * the "proc" and "uplevel" commands. * - * Copyright © 1987-1993 The Regents of the University of California. - * Copyright © 1994-1998 Sun Microsystems, Inc. - * Copyright © 2004-2006 Miguel Sofer - * Copyright © 2007 Daniel A. Steffen <das@users.sourceforge.net> + * Copyright (c) 1987-1993 The Regents of the University of California. + * Copyright (c) 1994-1998 Sun Microsystems, Inc. + * Copyright (c) 2004-2006 Miguel Sofer + * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -15,17 +15,6 @@ #include "tclInt.h" #include "tclCompile.h" -#include <assert.h> - -/* - * Variables that are part of the [apply] command implementation and which - * have to be passed to the other side of the NRE call. - */ - -typedef struct { - Command cmd; - ExtraFrameInfo efi; -} ApplyExtraData; /* * Prototypes for static functions in this file @@ -34,29 +23,33 @@ typedef struct { static void DupLambdaInternalRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static void FreeLambdaInternalRep(Tcl_Obj *objPtr); -static int InitArgsAndLocals(Tcl_Interp *interp, Tcl_Size skip); +static int InitArgsAndLocals(Tcl_Interp *interp, + Tcl_Obj *procNameObj, int skip); static void InitResolvedLocals(Tcl_Interp *interp, ByteCode *codePtr, Var *defPtr, - Namespace *nsPtr); -static void InitLocalCache(Proc *procPtr); + Namespace *nsPtr); +static void InitLocalCache(Proc *procPtr); +static int PushProcCallFrame(ClientData clientData, + register Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[], int isLambda); static void ProcBodyDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr); static void ProcBodyFree(Tcl_Obj *objPtr); -static int ProcWrongNumArgs(Tcl_Interp *interp, Tcl_Size skip); +static int ProcWrongNumArgs(Tcl_Interp *interp, int skip); static void MakeProcError(Tcl_Interp *interp, Tcl_Obj *procNameObj); static void MakeLambdaError(Tcl_Interp *interp, Tcl_Obj *procNameObj); static int SetLambdaFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); - -static Tcl_NRPostProc ApplyNR2; -static Tcl_NRPostProc InterpProcNR2; -static Tcl_NRPostProc Uplevel_Callback; +static int ProcCompileProc(Tcl_Interp *interp, Proc *procPtr, + Tcl_Obj *bodyPtr, Namespace *nsPtr, + CONST char *description, CONST char *procName, + Proc **procPtrPtr); /* * The ProcBodyObjType type */ -const Tcl_ObjType tclProcBodyType = { +Tcl_ObjType tclProcBodyType = { "procbody", /* name for this type */ ProcBodyFree, /* FreeInternalRep function */ ProcBodyDup, /* DupInternalRep function */ @@ -67,31 +60,16 @@ const Tcl_ObjType tclProcBodyType = { * should panic instead. */ }; -#define ProcSetInternalRep(objPtr, procPtr) \ - do { \ - Tcl_ObjInternalRep ir; \ - (procPtr)->refCount++; \ - ir.twoPtrValue.ptr1 = (procPtr); \ - ir.twoPtrValue.ptr2 = NULL; \ - Tcl_StoreInternalRep((objPtr), &tclProcBodyType, &ir); \ - } while (0) - -#define ProcGetInternalRep(objPtr, procPtr) \ - do { \ - const Tcl_ObjInternalRep *irPtr; \ - irPtr = TclFetchInternalRep((objPtr), &tclProcBodyType); \ - (procPtr) = irPtr ? (Proc *)irPtr->twoPtrValue.ptr1 : NULL; \ - } while (0) - /* - * The [upvar]/[uplevel] level reference type. Uses the wideValue field - * to remember the integer value of a parsed #<integer> format. + * The [upvar]/[uplevel] level reference type. Uses the twoPtrValue field, + * encoding the type of level reference in ptr1 and the actual parsed out + * offset in ptr2. * * Uses the default behaviour throughout, and never disposes of the string * rep; it's just a cache type. */ -static const Tcl_ObjType levelReferenceType = { +static Tcl_ObjType levelReferenceType = { "levelReference", NULL, NULL, NULL, NULL }; @@ -102,34 +80,16 @@ static const Tcl_ObjType levelReferenceType = { * * Internally, ptr1 is a pointer to a Proc instance that is not bound to a * command name, and ptr2 is a pointer to the namespace that the Proc instance - * will execute within. IF YOU CHANGE THIS, CHECK IN tclDisassemble.c TOO. + * will execute within. */ -static const Tcl_ObjType lambdaType = { +static Tcl_ObjType lambdaType = { "lambdaExpr", /* name */ FreeLambdaInternalRep, /* freeIntRepProc */ DupLambdaInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ SetLambdaFromAny /* setFromAnyProc */ }; - -#define LambdaSetInternalRep(objPtr, procPtr, nsObjPtr) \ - do { \ - Tcl_ObjInternalRep ir; \ - ir.twoPtrValue.ptr1 = (procPtr); \ - ir.twoPtrValue.ptr2 = (nsObjPtr); \ - Tcl_IncrRefCount((nsObjPtr)); \ - Tcl_StoreInternalRep((objPtr), &lambdaType, &ir); \ - } while (0) - -#define LambdaGetInternalRep(objPtr, procPtr, nsObjPtr) \ - do { \ - const Tcl_ObjInternalRep *irPtr; \ - irPtr = TclFetchInternalRep((objPtr), &lambdaType); \ - (procPtr) = irPtr ? (Proc *)irPtr->twoPtrValue.ptr1 : NULL; \ - (nsObjPtr) = irPtr ? (Tcl_Obj *)irPtr->twoPtrValue.ptr2 : NULL; \ - } while (0) - /* *---------------------------------------------------------------------- @@ -148,20 +108,21 @@ static const Tcl_ObjType lambdaType = { *---------------------------------------------------------------------- */ -#undef TclObjInterpProc + /* ARGSUSED */ int Tcl_ProcObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Size objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { - Interp *iPtr = (Interp *) interp; + register Interp *iPtr = (Interp *) interp; Proc *procPtr; - const char *procName; - const char *simpleName, *procArgs, *procBody; + char *fullName; + CONST char *procName, *procArgs, *procBody; Namespace *nsPtr, *altNsPtr, *cxtNsPtr; Tcl_Command cmd; + Tcl_DString ds; if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "name args body"); @@ -174,22 +135,25 @@ Tcl_ProcObjCmd( * namespace. */ - procName = TclGetString(objv[1]); - TclGetNamespaceForQualName(interp, procName, NULL, 0, - &nsPtr, &altNsPtr, &cxtNsPtr, &simpleName); + fullName = TclGetString(objv[1]); + TclGetNamespaceForQualName(interp, fullName, NULL, 0, + &nsPtr, &altNsPtr, &cxtNsPtr, &procName); if (nsPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't create procedure \"%s\": unknown namespace", - procName)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", (void *)NULL); + Tcl_AppendResult(interp, "can't create procedure \"", fullName, + "\": unknown namespace", NULL); return TCL_ERROR; } - if (simpleName == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't create procedure \"%s\": bad procedure name", - procName)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", (void *)NULL); + if (procName == NULL) { + Tcl_AppendResult(interp, "can't create procedure \"", fullName, + "\": bad procedure name", 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); return TCL_ERROR; } @@ -197,16 +161,32 @@ Tcl_ProcObjCmd( * Create the data structure to represent the procedure. */ - if (TclCreateProc(interp, /*ignored nsPtr*/ NULL, simpleName, objv[2], - objv[3], &procPtr) != TCL_OK) { + if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3], + &procPtr) != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (creating proc \""); - Tcl_AddErrorInfo(interp, simpleName); + Tcl_AddErrorInfo(interp, procName); Tcl_AddErrorInfo(interp, "\")"); return TCL_ERROR; } - cmd = TclNRCreateCommandInNs(interp, simpleName, (Tcl_Namespace *) nsPtr, - TclObjInterpProc, TclNRInterpProc, procPtr, TclProcDeleteProc); + /* + * Now create a command for the procedure. This will initially be in the + * current namespace unless the procedure's name included namespace + * qualifiers. To create the new command in the right namespace, we + * generate a fully qualified name for it. + */ + + Tcl_DStringInit(&ds); + if (nsPtr != iPtr->globalNsPtr) { + Tcl_DStringAppend(&ds, nsPtr->fullName, -1); + Tcl_DStringAppend(&ds, "::", 2); + } + Tcl_DStringAppend(&ds, procName, -1); + + cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds), + TclObjInterpProc, (ClientData) procPtr, TclProcDeleteProc); + + Tcl_DStringFree(&ds); /* * Now initialize the new procedure's cmdPtr field. This will be used @@ -225,15 +205,17 @@ Tcl_ProcObjCmd( * * This code is nearly identical to the #280 code in SetLambdaFromAny, see * this file. The differences are the different index of the body in the - * line array of the context, and the lambda code requires some special + * line array of the context, and the lamdba code requires some special * processing. Find a way to factor the common elements into a single * function. */ if (iPtr->cmdFramePtr) { - CmdFrame *contextPtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame)); + CmdFrame *contextPtr; + contextPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame)); *contextPtr = *iPtr->cmdFramePtr; + if (contextPtr->type == TCL_LOCATION_BC) { /* * Retrieve source information from the bytecode, if possible. If @@ -261,12 +243,12 @@ Tcl_ProcObjCmd( if (contextPtr->line && (contextPtr->nline >= 4) && (contextPtr->line[3] >= 0)) { int isNew; - Tcl_HashEntry *hePtr; - CmdFrame *cfPtr = (CmdFrame *)ckalloc(sizeof(CmdFrame)); + Tcl_HashEntry* hePtr; + CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame)); cfPtr->level = -1; cfPtr->type = contextPtr->type; - cfPtr->line = (Tcl_Size *)ckalloc(sizeof(Tcl_Size)); + cfPtr->line = (int *) ckalloc(sizeof(int)); cfPtr->line[0] = contextPtr->line[3]; cfPtr->nline = 1; cfPtr->framePtr = NULL; @@ -275,35 +257,34 @@ Tcl_ProcObjCmd( cfPtr->data.eval.path = contextPtr->data.eval.path; Tcl_IncrRefCount(cfPtr->data.eval.path); - cfPtr->cmd = NULL; - cfPtr->len = 0; + cfPtr->cmd.str.cmd = NULL; + cfPtr->cmd.str.len = 0; - hePtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr, - procPtr, &isNew); + hePtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr, (char *) procPtr, &isNew); if (!isNew) { /* - * Get the old command frame and release it. See also + * Get the old command frame and release it. See also * TclProcCleanupProc in this file. Currently it seems as * if only the procbodytest::proc command of the testsuite * is able to trigger this situation. */ - CmdFrame *cfOldPtr = (CmdFrame *)Tcl_GetHashValue(hePtr); + CmdFrame* cfOldPtr = (CmdFrame *) Tcl_GetHashValue(hePtr); if (cfOldPtr->type == TCL_LOCATION_SOURCE) { Tcl_DecrRefCount(cfOldPtr->data.eval.path); cfOldPtr->data.eval.path = NULL; } - ckfree(cfOldPtr->line); + ckfree((char *) cfOldPtr->line); cfOldPtr->line = NULL; - ckfree(cfOldPtr); + ckfree((char *) cfOldPtr); } Tcl_SetHashValue(hePtr, cfPtr); } /* - * 'contextPtr' is going out of scope; account for the reference - * that it's holding to the path name. + * 'contextPtr' is going out of scope; account for the reference that + * it's holding to the path name. */ Tcl_DecrRefCount(contextPtr->data.eval.path); @@ -328,7 +309,7 @@ Tcl_ProcObjCmd( * of all procs whose argument list is just _args_ */ - if (TclHasInternalRep(objv[3], &tclProcBodyType)) { + if (objv[3]->typePtr == &tclProcBodyType) { goto done; } @@ -339,7 +320,7 @@ Tcl_ProcObjCmd( } if ((procArgs[0] == 'a') && (strncmp(procArgs, "args", 4) == 0)) { - Tcl_Size numBytes; + int numBytes; procArgs +=4; while (*procArgs != '\0') { @@ -353,7 +334,7 @@ Tcl_ProcObjCmd( * The argument list is just "args"; check the body */ - procBody = TclGetStringFromObj(objv[3], &numBytes); + procBody = Tcl_GetStringFromObj(objv[3], &numBytes); if (TclParseAllWhiteSpace(procBody, numBytes) < numBytes) { goto done; } @@ -396,22 +377,23 @@ Tcl_ProcObjCmd( int TclCreateProc( Tcl_Interp *interp, /* Interpreter containing proc. */ - TCL_UNUSED(Namespace *) /*nsPtr*/, - const char *procName, /* Unqualified name of this proc. */ + Namespace *nsPtr, /* Namespace containing this proc. */ + CONST char *procName, /* Unqualified name of this proc. */ Tcl_Obj *argsPtr, /* Description of arguments. */ Tcl_Obj *bodyPtr, /* Command body. */ Proc **procPtrPtr) /* Returns: pointer to proc data. */ { Interp *iPtr = (Interp *) interp; + CONST char **argArray = NULL; - Proc *procPtr = NULL; - Tcl_Size i, numArgs; - CompiledLocal *localPtr = NULL; - Tcl_Obj **argArray; - int precompiled = 0, result; + register Proc *procPtr; + int i, length, result, numArgs; + CONST char *args, *bytes, *p; + register CompiledLocal *localPtr = NULL; + Tcl_Obj *defPtr; + int precompiled = 0; - ProcGetInternalRep(bodyPtr, procPtr); - if (procPtr != NULL) { + if (bodyPtr->typePtr == &tclProcBodyType) { /* * Because the body is a TclProProcBody, the actual body is already * compiled, and it is not shared with anyone else, so it's OK not to @@ -424,6 +406,7 @@ TclCreateProc( * will be holding a reference to it. */ + procPtr = bodyPtr->internalRep.twoPtrValue.ptr1; procPtr->iPtr = iPtr; procPtr->refCount++; precompiled = 1; @@ -444,9 +427,7 @@ TclCreateProc( */ if (Tcl_IsShared(bodyPtr)) { - const char *bytes; - Tcl_Size length; - Tcl_Obj *sharedBodyPtr = bodyPtr; + Tcl_Obj* sharedBodyPtr = bodyPtr; bytes = TclGetStringFromObj(bodyPtr, &length); bodyPtr = Tcl_NewStringObj(bytes, length); @@ -457,7 +438,7 @@ TclCreateProc( * not lost and applies to the new body as well. */ - TclContinuationsCopy(bodyPtr, sharedBodyPtr); + TclContinuationsCopy (bodyPtr, sharedBodyPtr); } /* @@ -468,7 +449,7 @@ TclCreateProc( Tcl_IncrRefCount(bodyPtr); - procPtr = (Proc *)ckalloc(sizeof(Proc)); + procPtr = (Proc *) ckalloc(sizeof(Proc)); procPtr->iPtr = iPtr; procPtr->refCount = 1; procPtr->bodyPtr = bodyPtr; @@ -483,9 +464,12 @@ TclCreateProc( * argument specifier. If the body is precompiled, processing is limited * to checking that the parsed argument is consistent with the one stored * in the Proc. + * + * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULS. */ - result = TclListObjGetElements(interp, argsPtr, &numArgs, &argArray); + args = TclGetStringFromObj(argsPtr, &length); + result = Tcl_SplitList(interp, args, &numArgs, &argArray); if (result != TCL_OK) { goto procError; } @@ -493,11 +477,9 @@ TclCreateProc( if (precompiled) { if (numArgs > procPtr->numArgs) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "procedure \"%s\": arg list contains %" TCL_SIZE_MODIFIER "d entries, " - "precompiled header expects %" TCL_SIZE_MODIFIER "d", procName, numArgs, + "procedure \"%s\": arg list contains %d entries, " + "precompiled header expects %d", procName, numArgs, procPtr->numArgs)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "BYTECODELIES", (void *)NULL); goto procError; } localPtr = procPtr->firstLocalPtr; @@ -507,66 +489,65 @@ TclCreateProc( } for (i = 0; i < numArgs; i++) { - const char *argname, *argnamei, *argnamelast; - Tcl_Size fieldCount, nameLength; - Tcl_Obj **fieldValues; + int fieldCount, nameLength, valueLength; + CONST char **fieldValues; /* * Now divide the specifier up into name and default. */ - result = TclListObjGetElements(interp, argArray[i], &fieldCount, + result = Tcl_SplitList(interp, argArray[i], &fieldCount, &fieldValues); if (result != TCL_OK) { goto procError; } if (fieldCount > 2) { - Tcl_Obj *errorObj = Tcl_NewStringObj( - "too many fields in argument specifier \"", -1); - Tcl_AppendObjToObj(errorObj, argArray[i]); - Tcl_AppendToObj(errorObj, "\"", -1); - Tcl_SetObjResult(interp, errorObj); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "FORMALARGUMENTFORMAT", (void *)NULL); + ckfree((char *) fieldValues); + Tcl_AppendResult(interp, + "too many fields in argument specifier \"", + argArray[i], "\"", NULL); goto procError; } - if ((fieldCount == 0) || (TclGetCharLength(fieldValues[0]) == 0)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "argument with no name", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "FORMALARGUMENTFORMAT", (void *)NULL); + if ((fieldCount == 0) || (*fieldValues[0] == 0)) { + ckfree((char *) fieldValues); + Tcl_AppendResult(interp, "argument with no name", NULL); goto procError; } - argname = TclGetStringFromObj(fieldValues[0], &nameLength); + nameLength = strlen(fieldValues[0]); + if (fieldCount == 2) { + valueLength = strlen(fieldValues[1]); + } else { + valueLength = 0; + } /* * Check that the formal parameter name is a scalar. */ - argnamei = argname; - argnamelast = (nameLength > 0) ? (argname + nameLength - 1) : argname; - while (argnamei < argnamelast) { - if (*argnamei == '(') { - if (*argnamelast == ')') { /* We have an array element. */ - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "formal parameter \"%s\" is an array element", - Tcl_GetString(fieldValues[0]))); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "FORMALARGUMENTFORMAT", (void *)NULL); + p = fieldValues[0]; + while (*p != '\0') { + if (*p == '(') { + CONST char *q = p; + do { + q++; + } 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); goto procError; } - } else if (*argnamei == ':' && *(argnamei+1) == ':') { - Tcl_Obj *errorObj = Tcl_NewStringObj( - "formal parameter \"", -1); - Tcl_AppendObjToObj(errorObj, fieldValues[0]); - Tcl_AppendToObj(errorObj, "\" is not a simple name", -1); - Tcl_SetObjResult(interp, errorObj); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "FORMALARGUMENTFORMAT", (void *)NULL); + } else if ((*p == ':') && (*(p+1) == ':')) { + Tcl_AppendResult(interp, "formal parameter \"", + fieldValues[0], + "\" is not a simple name", NULL); + ckfree((char *) fieldValues); goto procError; } - argnamei++; + p++; } if (precompiled) { @@ -576,22 +557,21 @@ TclCreateProc( * (its value was kept the same as pre VarReform to simplify * tbcload's processing of older byetcodes). * - * The only other flag value that is important to retrieve from + * The only other flag vlaue that is important to retrieve from * precompiled procs is VAR_TEMPORARY (also unchanged). It is * needed later when retrieving the variable names. */ if ((localPtr->nameLength != nameLength) - || (memcmp(localPtr->name, argname, nameLength) != 0) + || (strcmp(localPtr->name, fieldValues[0])) || (localPtr->frameIndex != i) || !(localPtr->flags & VAR_ARGUMENT) || (localPtr->defValuePtr == NULL && fieldCount == 2) || (localPtr->defValuePtr != NULL && fieldCount != 2)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "procedure \"%s\": formal parameter %" TCL_SIZE_MODIFIER "d is " + "procedure \"%s\": formal parameter %d is " "inconsistent with precompiled body", procName, i)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "BYTECODELIES", (void *)NULL); + ckfree((char *) fieldValues); goto procError; } @@ -600,21 +580,17 @@ TclCreateProc( */ if (localPtr->defValuePtr != NULL) { - Tcl_Size tmpLength, valueLength; - const char *tmpPtr = TclGetStringFromObj(localPtr->defValuePtr, &tmpLength); - const char *value = TclGetStringFromObj(fieldValues[1], &valueLength); - - if ((valueLength != tmpLength) - || memcmp(value, tmpPtr, tmpLength) != 0 - ) { - Tcl_Obj *errorObj = Tcl_ObjPrintf( - "procedure \"%s\": formal parameter \"", procName); - Tcl_AppendObjToObj(errorObj, fieldValues[0]); - Tcl_AppendToObj(errorObj, "\" has " - "default value inconsistent with precompiled body", -1); - Tcl_SetObjResult(interp, errorObj); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "BYTECODELIES", (void *)NULL); + int tmpLength; + char *tmpPtr = TclGetStringFromObj(localPtr->defValuePtr, + &tmpLength); + + if ((valueLength != tmpLength) || + strncmp(fieldValues[1], tmpPtr, (size_t) tmpLength)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "procedure \"%s\": formal parameter \"%s\" has " + "default value inconsistent with precompiled body", + procName, fieldValues[0])); + ckfree((char *) fieldValues); goto procError; } } @@ -632,8 +608,9 @@ TclCreateProc( * local variables for the argument. */ - localPtr = (CompiledLocal *)ckalloc( - offsetof(CompiledLocal, name) + 1U + fieldValues[0]->length); + localPtr = (CompiledLocal *) ckalloc((unsigned) + (sizeof(CompiledLocal) - sizeof(localPtr->name) + + nameLength + 1)); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; } else { @@ -647,22 +624,26 @@ TclCreateProc( localPtr->resolveInfo = NULL; if (fieldCount == 2) { - localPtr->defValuePtr = fieldValues[1]; + localPtr->defValuePtr = + Tcl_NewStringObj(fieldValues[1], valueLength); Tcl_IncrRefCount(localPtr->defValuePtr); } else { localPtr->defValuePtr = NULL; } - memcpy(localPtr->name, argname, fieldValues[0]->length + 1); + memcpy(localPtr->name, fieldValues[0], nameLength + 1); if ((i == numArgs - 1) && (localPtr->nameLength == 4) && (localPtr->name[0] == 'a') - && (memcmp(localPtr->name, "args", 4) == 0)) { + && (strcmp(localPtr->name, "args") == 0)) { localPtr->flags |= VAR_IS_ARGS; } } + + ckfree((char *) fieldValues); } *procPtrPtr = procPtr; + ckfree((char *) argArray); return TCL_OK; procError: @@ -674,13 +655,17 @@ TclCreateProc( localPtr = procPtr->firstLocalPtr; procPtr->firstLocalPtr = localPtr->nextPtr; - if (localPtr->defValuePtr != NULL) { - Tcl_DecrRefCount(localPtr->defValuePtr); + defPtr = localPtr->defValuePtr; + if (defPtr != NULL) { + Tcl_DecrRefCount(defPtr); } - ckfree(localPtr); + ckfree((char *) localPtr); } - ckfree(procPtr); + ckfree((char *) procPtr); + } + if (argArray != NULL) { + ckfree((char *) argArray); } return TCL_ERROR; } @@ -713,19 +698,55 @@ TclCreateProc( int TclGetFrame( Tcl_Interp *interp, /* Interpreter in which to find frame. */ - const char *name, /* String describing frame. */ + CONST char *name, /* String describing frame. */ CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if * global frame indicated). */ { - int result; - Tcl_Obj obj; - - obj.bytes = (char *) name; - obj.length = strlen(name); - obj.typePtr = NULL; - result = TclObjGetFrame(interp, &obj, framePtrPtr); - TclFreeInternalRep(&obj); - return result; + register Interp *iPtr = (Interp *) interp; + int curLevel, level, result; + CallFrame *framePtr; + + /* + * Parse string to figure out which level number to go to. + */ + + result = 1; + curLevel = iPtr->varFramePtr->level; + if (*name== '#') { + if (Tcl_GetInt(interp, name+1, &level) != TCL_OK || level < 0) { + goto levelError; + } + } else if (isdigit(UCHAR(*name))) { /* INTL: digit */ + if (Tcl_GetInt(interp, name, &level) != TCL_OK) { + goto levelError; + } + level = curLevel - level; + } else { + level = curLevel - 1; + result = 0; + } + + /* + * Figure out which frame to use, and return it to the caller. + */ + + for (framePtr = iPtr->varFramePtr; framePtr != NULL; + framePtr = framePtr->callerVarPtr) { + if (framePtr->level == level) { + break; + } + } + if (framePtr == NULL) { + goto levelError; + } + + *framePtrPtr = framePtr; + return result; + + levelError: + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL); + return -1; } /* @@ -740,7 +761,7 @@ TclGetFrame( * Results: * The return value is -1 if an error occurred in finding the frame (in * this case an error message is left in the interp's result). 1 is - * returned if objPtr was either an int or an int preceded by "#" and + * returned if objPtr was either a number or a number preceded by "#" and * it specified a valid frame. 0 is returned if objPtr isn't one of the * two things above (in this case, the lookup acts as if objPtr were * "1"). The variable pointed to by framePtrPtr is filled in with the @@ -760,89 +781,95 @@ TclObjGetFrame( CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if * global frame indicated). */ { - Interp *iPtr = (Interp *) interp; + register Interp *iPtr = (Interp *) interp; int curLevel, level, result; - const Tcl_ObjInternalRep *irPtr; - const char *name = NULL; - Tcl_WideInt w; + CallFrame *framePtr; + CONST char *name = TclGetString(objPtr); /* * Parse object to figure out which level number to go to. */ - result = 0; + result = 1; curLevel = iPtr->varFramePtr->level; + if (objPtr->typePtr == &levelReferenceType) { + if (PTR2INT(objPtr->internalRep.twoPtrValue.ptr1)) { + level = curLevel - PTR2INT(objPtr->internalRep.twoPtrValue.ptr2); + } else { + level = PTR2INT(objPtr->internalRep.twoPtrValue.ptr2); + } + if (level < 0) { + goto levelError; + } + /* TODO: Consider skipping the typePtr checks */ + } else if (objPtr->typePtr == &tclIntType +#ifndef NO_WIDE_TYPE + || objPtr->typePtr == &tclWideIntType +#endif + ) { + if (TclGetIntFromObj(NULL, objPtr, &level) != TCL_OK || level < 0) { + goto levelError; + } + level = curLevel - level; + } else if (*name == '#') { + if (Tcl_GetInt(interp, name+1, &level) != TCL_OK || level < 0) { + goto levelError; + } - /* - * Check for integer first, since that has potential to spare us - * a generation of a stringrep. - */ + /* + * Cache for future reference. + * + * TODO: Use the new ptrAndLongRep intrep + */ - if (objPtr == NULL) { - /* Do nothing */ - } else if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &level)) { - Tcl_GetWideIntFromObj(NULL, objPtr, &w); - if (w < 0 || w > INT_MAX || curLevel > w + INT_MAX) { - result = -1; - } else { - level = curLevel - level; - result = 1; + TclFreeIntRep(objPtr); + objPtr->typePtr = &levelReferenceType; + objPtr->internalRep.twoPtrValue.ptr1 = (void *) 0; + objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(level); + } else if (isdigit(UCHAR(*name))) { /* INTL: digit */ + if (Tcl_GetInt(interp, name, &level) != TCL_OK) { + return -1; } - } else if ((irPtr = TclFetchInternalRep(objPtr, &levelReferenceType))) { - level = irPtr->wideValue; - result = 1; + + /* + * Cache for future reference. + * + * TODO: Use the new ptrAndLongRep intrep + */ + + TclFreeIntRep(objPtr); + objPtr->typePtr = &levelReferenceType; + objPtr->internalRep.twoPtrValue.ptr1 = (void *) 1; + objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(level); + level = curLevel - level; } else { - name = TclGetString(objPtr); - if (name[0] == '#') { - if (TCL_OK == Tcl_GetInt(NULL, name+1, &level)) { - if (level < 0 || (level > 0 && name[1] == '-')) { - result = -1; - } else { - Tcl_ObjInternalRep ir; + /* + * Don't cache as the object *isn't* a level reference. + */ - ir.wideValue = level; - Tcl_StoreInternalRep(objPtr, &levelReferenceType, &ir); - result = 1; - } - } else { - result = -1; - } - } else if (TclGetWideBitsFromObj(NULL, objPtr, &w) == TCL_OK) { - /* - * If this were an integer, we'd have succeeded already. - * Docs say we have to treat this as a 'bad level' error. - */ - result = -1; - } + level = curLevel - 1; + result = 0; } - if (result != -1) { - /* if relative current level */ - if (result == 0) { - if (!curLevel) { - /* we are in top-level, so simply generate bad level */ - name = "1"; - goto badLevel; - } - level = curLevel - 1; - } - if (level >= 0) { - CallFrame *framePtr; - for (framePtr = iPtr->varFramePtr; framePtr != NULL; - framePtr = framePtr->callerVarPtr) { - if (framePtr->level == level) { - *framePtrPtr = framePtr; - return result; - } - } + /* + * Figure out which frame to use, and return it to the caller. + */ + + for (framePtr = iPtr->varFramePtr; framePtr != NULL; + framePtr = framePtr->callerVarPtr) { + if (framePtr->level == level) { + break; } } -badLevel: - if (name == NULL) { - name = objPtr ? TclGetString(objPtr) : "1" ; + if (framePtr == NULL) { + goto levelError; } - Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", name, (void *)NULL); + *framePtrPtr = framePtr; + return result; + + levelError: + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL); return -1; } @@ -863,76 +890,22 @@ badLevel: *---------------------------------------------------------------------- */ -static int -Uplevel_Callback( - void *data[], - Tcl_Interp *interp, - int result) -{ - CallFrame *savedVarFramePtr = (CallFrame *)data[0]; - - if (result == TCL_ERROR) { - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"uplevel\" body line %d)", Tcl_GetErrorLine(interp))); - } - - /* - * Restore the variable frame, and return. - */ - - ((Interp *)interp)->varFramePtr = savedVarFramePtr; - return result; -} - + /* ARGSUSED */ int Tcl_UplevelObjCmd( - void *clientData, + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { - return Tcl_NRCallObjProc(interp, TclNRUplevelObjCmd, clientData, objc, objv); -} - -int -TclNRUplevelObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - - Interp *iPtr = (Interp *) interp; - CmdFrame *invoker = NULL; - int word = 0; + register Interp *iPtr = (Interp *) interp; int result; CallFrame *savedVarFramePtr, *framePtr; - Tcl_Obj *objPtr; if (objc < 2) { - /* to do - * simplify things by interpreting the argument as a command when there - * is only one argument. This requires a TIP since currently a single - * argument is interpreted as a level indicator if possible. - */ uplevelSyntax: Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?"); return TCL_ERROR; - } else if (!TclHasStringRep(objv[1]) && objc == 2) { - int status; - Tcl_Size llength; - status = TclListObjLength(interp, objv[1], &llength); - if (status == TCL_OK && llength > 1) { - /* the first argument can't interpreted as a level. Avoid - * generating a string representation of the script. */ - result = TclGetFrame(interp, "1", &framePtr); - if (result == -1) { - return TCL_ERROR; - } - objc -= 1; - objv += 1; - goto havelevel; - } } /* @@ -943,13 +916,11 @@ TclNRUplevelObjCmd( if (result == -1) { return TCL_ERROR; } - objc -= result + 1; + objc -= (result+1); if (objc == 0) { goto uplevelSyntax; } - objv += result + 1; - - havelevel: + objv += (result+1); /* * Modify the interpreter state to execute in the given frame. @@ -964,12 +935,14 @@ TclNRUplevelObjCmd( if (objc == 1) { /* - * TIP #280. Make actual argument location available to eval'd script + * TIP #280. Make argument location available to eval'd script */ - TclArgumentGet(interp, objv[0], &invoker, &word); - objPtr = objv[0]; + CmdFrame* invoker = NULL; + int word = 0; + TclArgumentGet (interp, objv[0], &invoker, &word); + result = TclEvalObjEx(interp, objv[0], 0, invoker, word); } else { /* * More than one argument: concatenate them together with spaces @@ -977,12 +950,22 @@ TclNRUplevelObjCmd( * object when it decrements its refcount after eval'ing it. */ + Tcl_Obj *objPtr; + objPtr = Tcl_ConcatObj(objc, objv); + result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); } + if (result == TCL_ERROR) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"uplevel\" body line %d)", interp->errorLine)); + } + + /* + * Restore the variable frame, and return. + */ - TclNRAddCallback(interp, Uplevel_Callback, savedVarFramePtr, NULL, NULL, - NULL); - return TclNREvalObjEx(interp, objPtr, 0, invoker, word); + iPtr->varFramePtr = savedVarFramePtr; + return result; } /* @@ -1011,9 +994,10 @@ TclNRUplevelObjCmd( Proc * TclFindProc( Interp *iPtr, /* Interpreter in which to look. */ - const char *procName) /* Name of desired procedure. */ + CONST char *procName) /* Name of desired procedure. */ { Tcl_Command cmd; + Tcl_Command origCmd; Command *cmdPtr; cmd = Tcl_FindCommand((Tcl_Interp *) iPtr, procName, NULL, /*flags*/ 0); @@ -1022,7 +1006,14 @@ TclFindProc( } cmdPtr = (Command *) cmd; - return TclIsProc(cmdPtr); + origCmd = TclGetOriginalCommand(cmd); + if (origCmd != NULL) { + cmdPtr = (Command *) origCmd; + } + if (cmdPtr->objProc != TclObjInterpProc) { + return NULL; + } + return (Proc *) cmdPtr->objClientData; } /* @@ -1047,25 +1038,46 @@ Proc * TclIsProc( Command *cmdPtr) /* Command to test. */ { - Tcl_Command origCmd = TclGetOriginalCommand((Tcl_Command) cmdPtr); + Tcl_Command origCmd; + origCmd = TclGetOriginalCommand((Tcl_Command) cmdPtr); if (origCmd != NULL) { cmdPtr = (Command *) origCmd; } - if (cmdPtr->deleteProc == TclProcDeleteProc) { - return (Proc *)cmdPtr->objClientData; + if (cmdPtr->objProc == TclObjInterpProc) { + return (Proc *) cmdPtr->objClientData; } - return NULL; + return (Proc *) 0; } +/* + *---------------------------------------------------------------------- + * + * InitArgsAndLocals -- + * + * This routine is invoked in order to initialize the arguments and other + * compiled locals table for a new call frame. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Allocates memory on the stack for the compiled local variables, the + * caller is responsible for freeing them. Initialises all variables. May + * invoke various name resolvers in order to determine which variables + * are being referenced at runtime. + * + *---------------------------------------------------------------------- + */ + static int ProcWrongNumArgs( - Tcl_Interp *interp, - Tcl_Size skip) + Tcl_Interp *interp, int skip) { CallFrame *framePtr = ((Interp *)interp)->varFramePtr; - Proc *procPtr = framePtr->procPtr; - Tcl_Size localCt = procPtr->numCompiledLocals, numArgs, i; + register Proc *procPtr = framePtr->procPtr; + register Var *defPtr; + int localCt = procPtr->numCompiledLocals, numArgs, i; Tcl_Obj **desiredObjs; const char *final = NULL; @@ -1074,40 +1086,39 @@ ProcWrongNumArgs( */ numArgs = framePtr->procPtr->numArgs; - desiredObjs = (Tcl_Obj **)TclStackAlloc(interp, - sizeof(Tcl_Obj *) * (numArgs+1)); + desiredObjs = (Tcl_Obj **) TclStackAlloc(interp, + (int) sizeof(Tcl_Obj *) * (numArgs+1)); 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 - desiredObjs[0] = Tcl_NewListObj(1, framePtr->objv + skip - 1); + desiredObjs[0] = Tcl_NewListObj(skip, framePtr->objv); #endif /* AVOID_HACKS_FOR_ITCL */ } Tcl_IncrRefCount(desiredObjs[0]); - if (localCt > 0) { - Var *defPtr = (Var *)(&framePtr->localCachePtr->varName0 + localCt); - - for (i=1 ; i<=numArgs ; i++, defPtr++) { - Tcl_Obj *argObj; - Tcl_Obj *namePtr = localName(framePtr, i-1); - - if (defPtr->value.objPtr != NULL) { - TclNewObj(argObj); - Tcl_AppendStringsToObj(argObj, "?", TclGetString(namePtr), "?", (void *)NULL); - } else if (defPtr->flags & VAR_IS_ARGS) { - numArgs--; - final = "?arg ...?"; - break; - } else { - argObj = namePtr; - Tcl_IncrRefCount(namePtr); - } - desiredObjs[i] = argObj; + defPtr = (Var *) (&framePtr->localCachePtr->varName0 + localCt); + for (i=1 ; i<=numArgs ; i++, defPtr++) { + Tcl_Obj *argObj; + Tcl_Obj *namePtr = localName(framePtr, i-1); + + if (defPtr->value.objPtr != NULL) { + TclNewObj(argObj); + Tcl_AppendStringsToObj(argObj, "?", TclGetString(namePtr), "?", NULL); + } else if (defPtr->flags & VAR_IS_ARGS) { + numArgs--; + final = "..."; + break; + } else { + argObj = namePtr; + Tcl_IncrRefCount(namePtr); } + desiredObjs[i] = argObj; } Tcl_ResetResult(interp); @@ -1131,6 +1142,7 @@ ProcWrongNumArgs( * DEPRECATED: functionality has been inlined elsewhere; this function * remains to insure binary compatibility with Itcl. * + * Results: * None. * @@ -1140,8 +1152,6 @@ ProcWrongNumArgs( * *---------------------------------------------------------------------- */ - -#ifndef TCL_NO_DEPRECATED void TclInitCompiledLocals( Tcl_Interp *interp, /* Current interpreter. */ @@ -1153,10 +1163,10 @@ TclInitCompiledLocals( ByteCode *codePtr; bodyPtr = framePtr->procPtr->bodyPtr; - ByteCodeGetInternalRep(bodyPtr, &tclByteCodeType, codePtr); - if (codePtr == NULL) { + if (bodyPtr->typePtr != &tclByteCodeType) { Tcl_Panic("body object for proc attached to frame is not a byte code type"); } + codePtr = bodyPtr->internalRep.twoPtrValue.ptr1; if (framePtr->numCompiledLocals) { if (!codePtr->localCachePtr) { @@ -1168,7 +1178,6 @@ TclInitCompiledLocals( InitResolvedLocals(interp, codePtr, varPtr, nsPtr); } -#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -1212,7 +1221,37 @@ InitResolvedLocals( } if (!(haveResolvers && (codePtr->flags & TCL_BYTECODE_RESOLVE_VARS))) { - goto doInitResolvedLocals; + /* + * Initialize the array of local variables stored in the call frame. + * Some variables may have special resolution rules. In that case, we + * call their "resolver" procs to get our hands on the variable, and + * we make the compiled local a link to the real variable. + */ + + doInitResolvedLocals: + for (; localPtr != NULL; varPtr++, localPtr = localPtr->nextPtr) { + varPtr->flags = 0; + varPtr->value.objPtr = NULL; + + /* + * Now invoke the resolvers to determine the exact variables + * that should be used. + */ + + resVarInfo = localPtr->resolveInfo; + if (resVarInfo && resVarInfo->fetchProc) { + Var *resolvedVarPtr = (Var *) + (*resVarInfo->fetchProc)(interp, resVarInfo); + if (resolvedVarPtr) { + if (TclIsVarInHash(resolvedVarPtr)) { + VarHashRefCount(resolvedVarPtr)++; + } + varPtr->flags = VAR_LINK; + varPtr->value.linkPtr = resolvedVarPtr; + } + } + } + return; } /* @@ -1226,7 +1265,7 @@ InitResolvedLocals( if (localPtr->resolveInfo->deleteProc) { localPtr->resolveInfo->deleteProc(localPtr->resolveInfo); } else { - ckfree(localPtr->resolveInfo); + ckfree((char *) localPtr->resolveInfo); } localPtr->resolveInfo = NULL; } @@ -1239,7 +1278,7 @@ InitResolvedLocals( int result; if (nsPtr->compiledVarResProc) { - result = nsPtr->compiledVarResProc(nsPtr->interp, + result = (*nsPtr->compiledVarResProc)(nsPtr->interp, localPtr->name, localPtr->nameLength, (Tcl_Namespace *) nsPtr, &vinfo); } else { @@ -1248,7 +1287,7 @@ InitResolvedLocals( while ((result == TCL_CONTINUE) && resPtr) { if (resPtr->compiledVarResProc) { - result = resPtr->compiledVarResProc(nsPtr->interp, + result = (*resPtr->compiledVarResProc)(nsPtr->interp, localPtr->name, localPtr->nameLength, (Tcl_Namespace *) nsPtr, &vinfo); } @@ -1262,75 +1301,48 @@ InitResolvedLocals( } localPtr = firstLocalPtr; codePtr->flags &= ~TCL_BYTECODE_RESOLVE_VARS; - - /* - * Initialize the array of local variables stored in the call frame. Some - * variables may have special resolution rules. In that case, we call - * their "resolver" procs to get our hands on the variable, and we make - * the compiled local a link to the real variable. - */ - - doInitResolvedLocals: - for (; localPtr != NULL; varPtr++, localPtr = localPtr->nextPtr) { - varPtr->flags = 0; - varPtr->value.objPtr = NULL; - - /* - * Now invoke the resolvers to determine the exact variables that - * should be used. - */ - - resVarInfo = localPtr->resolveInfo; - if (resVarInfo && resVarInfo->fetchProc) { - Var *resolvedVarPtr = (Var *) - resVarInfo->fetchProc(interp, resVarInfo); - - if (resolvedVarPtr) { - if (TclIsVarInHash(resolvedVarPtr)) { - VarHashRefCount(resolvedVarPtr)++; - } - varPtr->flags = VAR_LINK; - varPtr->value.linkPtr = resolvedVarPtr; - } - } - } + goto doInitResolvedLocals; } - + void TclFreeLocalCache( Tcl_Interp *interp, LocalCache *localCachePtr) { - Tcl_Size i; + int i; Tcl_Obj **namePtrPtr = &localCachePtr->varName0; for (i = 0; i < localCachePtr->numVars; i++, namePtrPtr++) { 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) { - /* TclReleaseLiteral calls Tcl_DecrRefCount for us */ - TclReleaseLiteral(interp, objPtr); + if (interp) { + TclReleaseLiteral(interp, objPtr); + } else { + Tcl_DecrRefCount(objPtr); + } } } - ckfree(localCachePtr); + ckfree((char *) localCachePtr); } - + static void -InitLocalCache( - Proc *procPtr) +InitLocalCache(Proc *procPtr) { Interp *iPtr = procPtr->iPtr; - ByteCode *codePtr; - Tcl_Size localCt = procPtr->numCompiledLocals; - Tcl_Size numArgs = procPtr->numArgs, i = 0; + ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; + int localCt = procPtr->numCompiledLocals; + int numArgs = procPtr->numArgs, i = 0; Tcl_Obj **namePtr; Var *varPtr; LocalCache *localCachePtr; CompiledLocal *localPtr; - int isNew; - - ByteCodeGetInternalRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); + int new; /* * Cache the names and initial values of local variables; store the @@ -1338,9 +1350,9 @@ InitLocalCache( * for future calls. */ - localCachePtr = (LocalCache *)ckalloc(offsetof(LocalCache, varName0) - + localCt * sizeof(Tcl_Obj *) - + numArgs * sizeof(Var)); + localCachePtr = (LocalCache *) ckalloc(sizeof(LocalCache) + + (localCt-1)*sizeof(Tcl_Obj *) + + numArgs*sizeof(Var)); namePtr = &localCachePtr->varName0; varPtr = (Var *) (namePtr + localCt); @@ -1351,7 +1363,7 @@ InitLocalCache( } else { *namePtr = TclCreateLiteral(iPtr, localPtr->name, localPtr->nameLength, /* hash */ (unsigned int) -1, - &isNew, /* nsPtr */ NULL, 0, NULL); + &new, /* nsPtr */ NULL, 0, NULL); Tcl_IncrRefCount(*namePtr); } @@ -1362,49 +1374,28 @@ InitLocalCache( i++; } namePtr++; - localPtr = localPtr->nextPtr; + localPtr=localPtr->nextPtr; } codePtr->localCachePtr = localCachePtr; localCachePtr->refCount = 1; - localCachePtr->numVars = localCt; + localCachePtr->numVars = localCt; } - -/* - *---------------------------------------------------------------------- - * - * InitArgsAndLocals -- - * - * This routine is invoked in order to initialize the arguments and other - * compiled locals table for a new call frame. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Allocates memory on the stack for the compiled local variables, the - * caller is responsible for freeing them. Initialises all variables. May - * invoke various name resolvers in order to determine which variables - * are being referenced at runtime. - * - *---------------------------------------------------------------------- - */ static int InitArgsAndLocals( - Tcl_Interp *interp,/* Interpreter in which procedure was + register Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ - Tcl_Size skip) /* Number of initial arguments to be skipped, + Tcl_Obj *procNameObj, /* Procedure name for error reporting. */ + int skip) /* Number of initial arguments to be skipped, * i.e., words in the "command name". */ { CallFrame *framePtr = ((Interp *)interp)->varFramePtr; - Proc *procPtr = framePtr->procPtr; - ByteCode *codePtr; - Var *varPtr, *defPtr; - Tcl_Size localCt = procPtr->numCompiledLocals, numArgs, argCt, i, imax; + register Proc *procPtr = framePtr->procPtr; + ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; + register Var *varPtr, *defPtr; + int localCt = procPtr->numCompiledLocals, numArgs, argCt, i, imax; Tcl_Obj *const *argObjs; - ByteCodeGetInternalRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); - /* * Make sure that the local cache of variable names and initial values has * been initialised properly . @@ -1427,7 +1418,7 @@ InitArgsAndLocals( * parameters. */ - varPtr = (Var *)TclStackAlloc(interp, localCt * sizeof(Var)); + varPtr = (Var*) TclStackAlloc(interp, (int)(localCt*sizeof(Var))); framePtr->compiledLocals = varPtr; framePtr->numCompiledLocals = localCt; @@ -1441,6 +1432,7 @@ InitArgsAndLocals( numArgs = procPtr->numArgs; argCt = framePtr->objc - skip; /* Set it to the number of args to the * procedure. */ + argObjs = framePtr->objv + skip; if (numArgs == 0) { if (argCt) { goto incorrectArgs; @@ -1448,9 +1440,8 @@ InitArgsAndLocals( goto correctArgs; } } - argObjs = framePtr->objv + skip; imax = ((argCt < numArgs-1) ? argCt : numArgs-1); - for (i = 0; i < imax; i++, varPtr++, defPtr ? defPtr++ : defPtr) { + for (i = 0; i < imax; i++, varPtr++, defPtr++) { /* * "Normal" arguments; last formal is special, depends on it being * 'args'. @@ -1462,20 +1453,21 @@ InitArgsAndLocals( varPtr->value.objPtr = objPtr; Tcl_IncrRefCount(objPtr); /* Local var is a reference. */ } - for (; i < numArgs-1; i++, varPtr++, defPtr ? defPtr++ : defPtr) { + for (; i < numArgs-1; i++, varPtr++, defPtr++) { /* * This loop is entered if argCt < (numArgs-1). Set default values; * last formal is special. */ - Tcl_Obj *objPtr = defPtr ? defPtr->value.objPtr : NULL; + Tcl_Obj *objPtr = defPtr->value.objPtr; - if (!objPtr) { + if (objPtr) { + varPtr->flags = 0; + varPtr->value.objPtr = objPtr; + Tcl_IncrRefCount(objPtr); /* Local var reference. */ + } else { goto incorrectArgs; } - varPtr->flags = 0; - varPtr->value.objPtr = objPtr; - Tcl_IncrRefCount(objPtr); /* Local var reference. */ } /* @@ -1483,9 +1475,10 @@ InitArgsAndLocals( * defPtr and varPtr point to the last argument to be initialized. */ + varPtr->flags = 0; - if (defPtr && defPtr->flags & VAR_IS_ARGS) { - Tcl_Obj *listPtr = Tcl_NewListObj((argCt>i)? argCt-i : 0, argObjs+i); + if (defPtr->flags & VAR_IS_ARGS) { + Tcl_Obj *listPtr = Tcl_NewListObj(argCt-i, argObjs+i); varPtr->value.objPtr = listPtr; Tcl_IncrRefCount(listPtr); /* Local var is a reference. */ @@ -1494,7 +1487,7 @@ InitArgsAndLocals( varPtr->value.objPtr = objPtr; Tcl_IncrRefCount(objPtr); /* Local var is a reference. */ - } else if ((argCt < numArgs) && defPtr && defPtr->value.objPtr) { + } else if ((argCt < numArgs) && (defPtr->value.objPtr != NULL)) { Tcl_Obj *objPtr = defPtr->value.objPtr; varPtr->value.objPtr = objPtr; @@ -1511,8 +1504,7 @@ InitArgsAndLocals( correctArgs: if (numArgs < localCt) { - if (!framePtr->nsPtr->compiledVarResProc - && !((Interp *)interp)->resolverPtr) { + if (!framePtr->nsPtr->compiledVarResProc && !((Interp *)interp)->resolverPtr) { memset(varPtr, 0, (localCt - numArgs)*sizeof(Var)); } else { InitResolvedLocals(interp, codePtr, varPtr, framePtr->nsPtr); @@ -1521,24 +1513,20 @@ InitArgsAndLocals( return TCL_OK; + + incorrectArgs: /* * Initialise all compiled locals to avoid problems at DeleteLocalVars. */ - incorrectArgs: - if ((skip != 1) && - TclInitRewriteEnsemble(interp, skip-1, 0, framePtr->objv)) { - TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); - } - memset(varPtr, 0, - ((framePtr->compiledLocals + localCt)-varPtr) * sizeof(Var)); + memset(varPtr, 0, ((framePtr->compiledLocals + localCt)-varPtr)*sizeof(Var)); return ProcWrongNumArgs(interp, skip); } /* *---------------------------------------------------------------------- * - * TclPushProcCallFrame -- + * PushProcCallFrame -- * * Compiles a proc body if necessary, then pushes a CallFrame suitable * for executing it. @@ -1553,19 +1541,19 @@ InitArgsAndLocals( *---------------------------------------------------------------------- */ -int -TclPushProcCallFrame( - void *clientData, /* Record describing procedure to be +static int +PushProcCallFrame( + ClientData clientData, /* Record describing procedure to be * interpreted. */ - Tcl_Interp *interp,/* Interpreter in which procedure was + register Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ - Tcl_Size objc, /* Count of number of arguments to this + int objc, /* Count of number of arguments to this * procedure. */ - Tcl_Obj *const objv[], /* Argument value objects. */ + Tcl_Obj *CONST objv[], /* Argument value objects. */ int isLambda) /* 1 if this is a call by ApplyObjCmd: it * needs special rules for error msg */ { - Proc *procPtr = (Proc *)clientData; + Proc *procPtr = (Proc *) clientData; Namespace *nsPtr = procPtr->cmdPtr->nsPtr; CallFrame *framePtr, **framePtrPtr; int result; @@ -1579,8 +1567,7 @@ TclPushProcCallFrame( * local variables are found while compiling. */ - ByteCodeGetInternalRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); - if (codePtr != NULL) { + if (procPtr->bodyPtr->typePtr == &tclByteCodeType) { Interp *iPtr = (Interp *) interp; /* @@ -1590,22 +1577,20 @@ TclPushProcCallFrame( * is up-to-date), the namespace must match (so variable handling * is right) and the resolverEpoch must match (so that new shadowed * commands and/or resolver changes are considered). - * Ensure the ByteCode's procPtr is the same (or it's precompiled). */ - if (((Interp *) *codePtr->interpHandle != iPtr) + codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; + if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != nsPtr) - || (codePtr->nsEpoch != nsPtr->resolverEpoch) - || ((codePtr->procPtr != procPtr) && procPtr->bodyPtr->bytes) - ) { + || (codePtr->nsEpoch != nsPtr->resolverEpoch)) { goto doCompilation; } } else { doCompilation: - result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr, + result = ProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr, (isLambda ? "body of lambda term" : "body of proc"), - TclGetString(objv[isLambda])); + TclGetString(objv[isLambda]), &procPtr); if (result != TCL_OK) { return result; } @@ -1620,9 +1605,12 @@ TclPushProcCallFrame( */ framePtrPtr = &framePtr; - (void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, + result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, (Tcl_Namespace *) nsPtr, (isLambda? (FRAME_IS_PROC|FRAME_IS_LAMBDA) : FRAME_IS_PROC)); + if (result != TCL_OK) { + return result; + } framePtr->objc = objc; framePtr->objv = objv; @@ -1650,44 +1638,28 @@ TclPushProcCallFrame( int TclObjInterpProc( - void *clientData, /* Record describing procedure to be + ClientData clientData, /* Record describing procedure to be * interpreted. */ - Tcl_Interp *interp,/* Interpreter in which procedure was + register Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ int objc, /* Count of number of arguments to this * procedure. */ - Tcl_Obj *const objv[]) /* Argument value objects. */ -{ - /* - * Not used much in the core; external interface for iTcl - */ - - return Tcl_NRCallObjProc(interp, TclNRInterpProc, clientData, objc, objv); -} - -int -TclNRInterpProc( - void *clientData, /* Record describing procedure to be - * interpreted. */ - Tcl_Interp *interp,/* Interpreter in which procedure was - * invoked. */ - Tcl_Size objc, /* Count of number of arguments to this - * procedure. */ - Tcl_Obj *const objv[]) /* Argument value objects. */ + Tcl_Obj *CONST objv[]) /* Argument value objects. */ { - int result = TclPushProcCallFrame(clientData, interp, objc, objv, - /*isLambda*/ 0); + int result; - if (result != TCL_OK) { + result = PushProcCallFrame(clientData, interp, objc, objv, /*isLambda*/ 0); + if (result == TCL_OK) { + return TclObjInterpProcCore(interp, objv[0], 1, &MakeProcError); + } else { return TCL_ERROR; } - return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError); } /* *---------------------------------------------------------------------- * - * TclNRInterpProcCore -- + * TclObjInterpProcCore -- * * When a Tcl procedure, lambda term or anything else that works like a * procedure gets invoked during bytecode evaluation, this object-based @@ -1703,35 +1675,29 @@ TclNRInterpProc( */ int -TclNRInterpProcCore( - Tcl_Interp *interp,/* Interpreter in which procedure was +TclObjInterpProcCore( + register Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ Tcl_Obj *procNameObj, /* Procedure name for error reporting. */ - Tcl_Size skip, /* Number of initial arguments to be skipped, + int skip, /* Number of initial arguments to be skipped, * i.e., words in the "command name". */ - ProcErrorProc *errorProc) /* How to convert results from the script into + ProcErrorProc errorProc) /* How to convert results from the script into * results of the overall procedure. */ { Interp *iPtr = (Interp *) interp; - Proc *procPtr = iPtr->varFramePtr->procPtr; + register Proc *procPtr = iPtr->varFramePtr->procPtr; int result; CallFrame *freePtr; - ByteCode *codePtr; - result = InitArgsAndLocals(interp, skip); + result = InitArgsAndLocals(interp, procNameObj, skip); if (result != TCL_OK) { - freePtr = iPtr->framePtr; - Tcl_PopCallFrame(interp); /* Pop but do not free. */ - TclStackFree(interp, freePtr->compiledLocals); - /* Free compiledLocals. */ - TclStackFree(interp, freePtr); /* Free CallFrame. */ - return TCL_ERROR; + goto procDone; } #if defined(TCL_COMPILE_DEBUG) if (tclTraceExec >= 1) { - CallFrame *framePtr = iPtr->varFramePtr; - Tcl_Size i; + register CallFrame *framePtr = iPtr->varFramePtr; + register int i; if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) { fprintf(stdout, "Calling lambda "); @@ -1749,42 +1715,25 @@ TclNRInterpProcCore( #ifdef USE_DTRACE if (TCL_DTRACE_PROC_ARGS_ENABLED()) { - Tcl_Size l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; - const char *a[10]; - Tcl_Size i; + char *a[10]; + int i = 0; + int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; - for (i = 0 ; i < 10 ; i++) { + while (i < 10) { a[i] = (l < iPtr->varFramePtr->objc ? - TclGetString(iPtr->varFramePtr->objv[l]) : NULL); - l++; + TclGetString(iPtr->varFramePtr->objv[l]) : NULL); i++; l++; } TCL_DTRACE_PROC_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8], a[9]); } if (TCL_DTRACE_PROC_INFO_ENABLED() && iPtr->cmdFramePtr) { Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr); - const char *a[6]; Tcl_Size i[2]; + char *a[4]; int i[2]; TclDTraceInfo(info, a, i); - TCL_DTRACE_PROC_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]); + TCL_DTRACE_PROC_INFO(a[0], a[1], a[2], a[3], i[0], i[1]); TclDecrRefCount(info); } - if (TCL_DTRACE_PROC_ENTRY_ENABLED()) { - Tcl_Size 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)); - } - if (TCL_DTRACE_PROC_ENTRY_ENABLED()) { - Tcl_Size 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 */ /* @@ -1792,69 +1741,45 @@ TclNRInterpProcCore( */ procPtr->refCount++; - ByteCodeGetInternalRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); - - TclNRAddCallback(interp, InterpProcNR2, procNameObj, errorProc, - NULL, NULL); - return TclNRExecuteByteCode(interp, codePtr); -} + iPtr->numLevels++; -static int -InterpProcNR2( - void *data[], - Tcl_Interp *interp, - int result) -{ - Interp *iPtr = (Interp *) interp; - Proc *procPtr = iPtr->varFramePtr->procPtr; - CallFrame *freePtr; - Tcl_Obj *procNameObj = (Tcl_Obj *)data[0]; - ProcErrorProc *errorProc = (ProcErrorProc *)data[1]; - - if (TCL_DTRACE_PROC_RETURN_ENABLED()) { - Tcl_Size l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; - - TCL_DTRACE_PROC_RETURN(l < iPtr->varFramePtr->objc ? - TclGetString(iPtr->varFramePtr->objv[l]) : NULL, result); - } - if (procPtr->refCount-- <= 1) { - TclProcCleanupProc(procPtr); - } + if (TclInterpReady(interp) == TCL_ERROR) { + result = TCL_ERROR; + } else { + register ByteCode *codePtr = + procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; - /* - * 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. - */ + codePtr->refCount++; +#ifdef USE_DTRACE + if (TCL_DTRACE_PROC_ENTRY_ENABLED()) { + int l; - if (result != TCL_OK) { - goto process; + l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 2 : 1; + TCL_DTRACE_PROC_ENTRY(TclGetString(procNameObj), + iPtr->varFramePtr->objc - l, + (Tcl_Obj **)(iPtr->varFramePtr->objv + l)); + } +#endif /* USE_DTRACE */ + result = TclExecuteByteCode(interp, codePtr); + if (TCL_DTRACE_PROC_RETURN_ENABLED()) { + TCL_DTRACE_PROC_RETURN(TclGetString(procNameObj), result); + } + codePtr->refCount--; + if (codePtr->refCount <= 0) { + TclCleanupByteCode(codePtr); + } } - done: - if (TCL_DTRACE_PROC_RESULT_ENABLED()) { - Tcl_Size 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); + iPtr->numLevels--; + procPtr->refCount--; + if (procPtr->refCount <= 0) { + TclProcCleanupProc(procPtr); } - 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 the result code. */ - process: switch (result) { case TCL_RETURN: /* @@ -1871,13 +1796,15 @@ InterpProcNR2( * transform to an error now. */ - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invoked \"%s\" outside of a loop", - ((result == TCL_BREAK) ? "break" : "continue"))); - Tcl_SetErrorCode(interp, "TCL", "RESULT", "UNEXPECTED", (void *)NULL); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "invoked \"", + ((result == TCL_BREAK) ? "break" : "continue"), + "\" outside of a loop", NULL); result = TCL_ERROR; - /* FALLTHRU */ + /* + * Fall through to the TCL_ERROR handling code. + */ case TCL_ERROR: /* @@ -1886,9 +1813,48 @@ InterpProcNR2( * function handed to us as an argument. */ - errorProc(interp, procNameObj); + (*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 */ + } + +#ifdef USE_DTRACE + if (TCL_DTRACE_PROC_RESULT_ENABLED()) { + Tcl_Obj *r; + + r = Tcl_GetObjResult(interp); + TCL_DTRACE_PROC_RESULT(TclGetString(procNameObj), result, + TclGetString(r), r); } - goto done; +#endif /* USE_DTRACE */ + + procDone: + /* + * 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; } /* @@ -1916,17 +1882,34 @@ TclProcCompileProc( Tcl_Interp *interp, /* Interpreter containing procedure. */ Proc *procPtr, /* Data associated with procedure. */ Tcl_Obj *bodyPtr, /* Body of proc. (Usually procPtr->bodyPtr, - * but could be any code fragment compiled in - * the context of this procedure.) */ + * but could be any code fragment compiled in + * the context of this procedure.) */ + Namespace *nsPtr, /* Namespace containing procedure. */ + CONST char *description, /* string describing this body of code. */ + CONST char *procName) /* Name of this procedure. */ +{ + return ProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, + procName, NULL); +} + +static int +ProcCompileProc( + Tcl_Interp *interp, /* Interpreter containing procedure. */ + Proc *procPtr, /* Data associated with procedure. */ + Tcl_Obj *bodyPtr, /* Body of proc. (Usually procPtr->bodyPtr, + * but could be any code fragment compiled in + * the context of this procedure.) */ Namespace *nsPtr, /* Namespace containing procedure. */ - const char *description, /* string describing this body of code. */ - const char *procName) /* Name of this procedure. */ + CONST char *description, /* string describing this body of code. */ + CONST char *procName, /* Name of this procedure. */ + Proc **procPtrPtr) /* Points to storage where a replacement + * (Proc *) value may be written. */ { Interp *iPtr = (Interp *) interp; + int i; Tcl_CallFrame *framePtr; - ByteCode *codePtr; - - ByteCodeGetInternalRep(bodyPtr, &tclByteCodeType, codePtr); + ByteCode *codePtr = bodyPtr->internalRep.twoPtrValue.ptr1; + CompiledLocal *localPtr; /* * If necessary, compile the procedure's body. The compiler will allocate @@ -1938,107 +1921,126 @@ TclProcCompileProc( * procPtr->numCompiledLocals if new local variables are found while * compiling. * - * Ensure the ByteCode's procPtr is the same (or it is pure precompiled). * Precompiled procedure bodies, however, are immutable and therefore they * are not recompiled, even if things have changed. */ - if (codePtr != NULL) { - if (((Interp *) *codePtr->interpHandle == iPtr) + if (bodyPtr->typePtr == &tclByteCodeType) { + if (((Interp *) *codePtr->interpHandle == iPtr) && (codePtr->compileEpoch == iPtr->compileEpoch) && (codePtr->nsPtr == nsPtr) - && (codePtr->nsEpoch == nsPtr->resolverEpoch) - && ((codePtr->procPtr == procPtr) || !bodyPtr->bytes) - ) { + && (codePtr->nsEpoch == nsPtr->resolverEpoch)) { return TCL_OK; - } - - if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { - if ((Interp *) *codePtr->interpHandle != iPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "a precompiled script jumped interps", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "CROSSINTERPBYTECODE", (void *)NULL); - return TCL_ERROR; - } - codePtr->compileEpoch = iPtr->compileEpoch; - codePtr->nsPtr = nsPtr; } else { - Tcl_StoreInternalRep(bodyPtr, &tclByteCodeType, NULL); - codePtr = NULL; - } + if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { + if ((Interp *) *codePtr->interpHandle != iPtr) { + Tcl_AppendResult(interp, + "a precompiled script jumped interps", NULL); + return TCL_ERROR; + } + codePtr->compileEpoch = iPtr->compileEpoch; + codePtr->nsPtr = nsPtr; + } else { + bodyPtr->typePtr->freeIntRepProc(bodyPtr); + bodyPtr->typePtr = NULL; + } + } } - - if (codePtr == NULL) { + if (bodyPtr->typePtr != &tclByteCodeType) { Tcl_HashEntry *hePtr; #ifdef TCL_COMPILE_DEBUG - if (tclTraceCompile >= 1) { - /* - * Display a line summarizing the top level command we are about - * to compile. - */ + if (tclTraceCompile >= 1) { + /* + * Display a line summarizing the top level command we are about + * to compile. + */ Tcl_Obj *message; TclNewLiteralStringObj(message, "Compiling "); Tcl_IncrRefCount(message); - Tcl_AppendStringsToObj(message, description, " \"", (void *)NULL); - Tcl_AppendLimitedToObj(message, procName, TCL_INDEX_NONE, 50, NULL); - fprintf(stdout, "%s\"\n", TclGetString(message)); + Tcl_AppendStringsToObj(message, description, " \"", NULL); + Tcl_AppendLimitedToObj(message, procName, -1, 50, NULL); + fprintf(stdout, "%s\"\n", TclGetString(message)); Tcl_DecrRefCount(message); - } -#else - (void)description; - (void)procName; + } #endif - /* - * Plug the current procPtr into the interpreter and coerce the code - * body to byte codes. The interpreter needs to know which proc it's - * compiling so that it can access its list of compiled locals. - * - * TRICKY NOTE: Be careful to push a call frame with the proper - * namespace context, so that the byte codes are compiled in the - * appropriate class context. - */ + /* + * Plug the current procPtr into the interpreter and coerce the code + * body to byte codes. The interpreter needs to know which proc it's + * compiling so that it can access its list of compiled locals. + * + * TRICKY NOTE: Be careful to push a call frame with the proper + * namespace context, so that the byte codes are compiled in the + * appropriate class context. + */ + + if (procPtrPtr != NULL && procPtr->refCount > 1) { + Tcl_Command token; + Tcl_CmdInfo info; + Proc *newProc = (Proc *) ckalloc(sizeof(Proc)); + + newProc->iPtr = procPtr->iPtr; + newProc->refCount = 1; + newProc->cmdPtr = procPtr->cmdPtr; + token = (Tcl_Command) newProc->cmdPtr; + newProc->bodyPtr = Tcl_DuplicateObj(bodyPtr); + bodyPtr = newProc->bodyPtr; + Tcl_IncrRefCount(bodyPtr); + newProc->numArgs = procPtr->numArgs; + + newProc->numCompiledLocals = newProc->numArgs; + newProc->firstLocalPtr = NULL; + newProc->lastLocalPtr = NULL; + localPtr = procPtr->firstLocalPtr; + for (i=0; i<newProc->numArgs; i++, localPtr=localPtr->nextPtr) { + CompiledLocal *copy = (CompiledLocal *) ckalloc((unsigned) + (sizeof(CompiledLocal) - sizeof(localPtr->name) + + localPtr->nameLength + 1)); - iPtr->compiledProcPtr = procPtr; + if (newProc->firstLocalPtr == NULL) { + newProc->firstLocalPtr = newProc->lastLocalPtr = copy; + } else { + newProc->lastLocalPtr->nextPtr = copy; + newProc->lastLocalPtr = copy; + } + copy->nextPtr = NULL; + copy->nameLength = localPtr->nameLength; + copy->frameIndex = localPtr->frameIndex; + copy->flags = localPtr->flags; + copy->defValuePtr = localPtr->defValuePtr; + if (copy->defValuePtr) { + Tcl_IncrRefCount(copy->defValuePtr); + } + copy->resolveInfo = localPtr->resolveInfo; + memcpy(copy->name, localPtr->name, localPtr->nameLength + 1); + } - if (procPtr->numCompiledLocals > procPtr->numArgs) { - CompiledLocal *clPtr = procPtr->firstLocalPtr; - CompiledLocal *lastPtr = NULL; - int i, numArgs = procPtr->numArgs; + /* + * Reset the ClientData + */ - for (i = 0; i < numArgs; i++) { - lastPtr = clPtr; - clPtr = clPtr->nextPtr; + Tcl_GetCommandInfoFromToken(token, &info); + if (info.objClientData == (ClientData) procPtr) { + info.objClientData = (ClientData) newProc; } - - if (lastPtr) { - lastPtr->nextPtr = NULL; - } else { - procPtr->firstLocalPtr = NULL; + if (info.clientData == (ClientData) procPtr) { + info.clientData = (ClientData) newProc; } - procPtr->lastLocalPtr = lastPtr; - while (clPtr) { - CompiledLocal *toFree = clPtr; - - clPtr = clPtr->nextPtr; - if (toFree->resolveInfo) { - if (toFree->resolveInfo->deleteProc) { - toFree->resolveInfo->deleteProc(toFree->resolveInfo); - } else { - ckfree(toFree->resolveInfo); - } - } - ckfree(toFree); + if (info.deleteData == (ClientData) procPtr) { + info.deleteData = (ClientData) newProc; } - procPtr->numCompiledLocals = procPtr->numArgs; + Tcl_SetCommandInfoFromToken(token, &info); + + procPtr->refCount--; + *procPtrPtr = procPtr = newProc; } + iPtr->compiledProcPtr = procPtr; - (void) TclPushStackFrame(interp, &framePtr, (Tcl_Namespace *) nsPtr, - /* isProcCallFrame */ 0); + (void) TclPushStackFrame(interp, &framePtr, + (Tcl_Namespace *) nsPtr, /* isProcCallFrame */ 0); /* * TIP #280: We get the invoking context from the cmdFrame which @@ -2052,8 +2054,9 @@ TclProcCompileProc( */ iPtr->invokeWord = 0; - iPtr->invokeCmdFramePtr = hePtr ? (CmdFrame *)Tcl_GetHashValue(hePtr) : NULL; - TclSetByteCodeFromAny(interp, bodyPtr, NULL, NULL); + iPtr->invokeCmdFramePtr = + (hePtr ? (CmdFrame *) Tcl_GetHashValue(hePtr) : NULL); + (void) tclByteCodeType.setFromAnyProc(interp, bodyPtr); iPtr->invokeCmdFramePtr = NULL; TclPopStackFrame(interp); } else if (codePtr->nsEpoch != nsPtr->resolverEpoch) { @@ -2093,15 +2096,14 @@ MakeProcError( Tcl_Obj *procNameObj) /* Name of the procedure. Used for error * messages and trace information. */ { - int overflow, limit = 60; - Tcl_Size nameLen; - const char *procName = TclGetStringFromObj(procNameObj, &nameLen); + int overflow, limit = 60, nameLen; + const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen); overflow = (nameLen > limit); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (procedure \"%.*s%s\" line %d)", - (overflow ? limit : (int)nameLen), procName, - (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); + (overflow ? limit : nameLen), procName, + (overflow ? "..." : ""), interp->errorLine)); } /* @@ -2126,11 +2128,12 @@ MakeProcError( void TclProcDeleteProc( - void *clientData) /* Procedure to be deleted. */ + ClientData clientData) /* Procedure to be deleted. */ { - Proc *procPtr = (Proc *)clientData; + Proc *procPtr = (Proc *) clientData; - if (procPtr->refCount-- <= 1) { + procPtr->refCount--; + if (procPtr->refCount <= 0) { TclProcCleanupProc(procPtr); } } @@ -2154,9 +2157,9 @@ TclProcDeleteProc( void TclProcCleanupProc( - Proc *procPtr) /* Procedure to be deleted. */ + register Proc *procPtr) /* Procedure to be deleted. */ { - CompiledLocal *localPtr; + register CompiledLocal *localPtr; Tcl_Obj *bodyPtr = procPtr->bodyPtr; Tcl_Obj *defPtr; Tcl_ResolvedVarInfo *resVarInfo; @@ -2165,13 +2168,6 @@ TclProcCleanupProc( Interp *iPtr = procPtr->iPtr; if (bodyPtr != NULL) { - /* procPtr is stored in body's ByteCode, so ensure to reset it. */ - ByteCode *codePtr; - - ByteCodeGetInternalRep(bodyPtr, &tclByteCodeType, codePtr); - if (codePtr != NULL && codePtr->procPtr == procPtr) { - codePtr->procPtr = NULL; - } Tcl_DecrRefCount(bodyPtr); } for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; ) { @@ -2180,9 +2176,9 @@ TclProcCleanupProc( resVarInfo = localPtr->resolveInfo; if (resVarInfo) { if (resVarInfo->deleteProc) { - resVarInfo->deleteProc(resVarInfo); + (*resVarInfo->deleteProc)(resVarInfo); } else { - ckfree(resVarInfo); + ckfree((char *) resVarInfo); } } @@ -2190,15 +2186,16 @@ TclProcCleanupProc( defPtr = localPtr->defValuePtr; Tcl_DecrRefCount(defPtr); } - ckfree(localPtr); + ckfree((char *) localPtr); localPtr = nextPtr; } - ckfree(procPtr); + ckfree((char *) procPtr); /* * TIP #280: Release the location data associated with this Proc * structure, if any. The interpreter may not exist (For example for - * procbody structures created by tbcload. + * procbody structures created by tbcload. See also Tcl_ProcObjCmd(), when + * the same ProcPtr is overwritten with a new CmdFrame. */ if (iPtr == NULL) { @@ -2210,16 +2207,16 @@ TclProcCleanupProc( return; } - cfPtr = (CmdFrame *)Tcl_GetHashValue(hePtr); + cfPtr = (CmdFrame *) Tcl_GetHashValue(hePtr); if (cfPtr) { if (cfPtr->type == TCL_LOCATION_SOURCE) { Tcl_DecrRefCount(cfPtr->data.eval.path); cfPtr->data.eval.path = NULL; } - ckfree(cfPtr->line); + ckfree((char *) cfPtr->line); cfPtr->line = NULL; - ckfree(cfPtr); + ckfree((char *) cfPtr); } Tcl_DeleteHashEntry(hePtr); } @@ -2277,14 +2274,13 @@ TclUpdateReturnInfo( * * TclGetObjInterpProc -- * - * Returns a pointer to the TclObjInterpProc function; - * this is different from the value obtained from the TclObjInterpProc - * reference on systems like Windows where import and export versions - * of a function exported by a DLL exist. + * Returns a pointer to the TclObjInterpProc function; this is different + * from the value obtained from the TclObjInterpProc reference on systems + * like Windows where import and export versions of a function exported + * by a DLL exist. * * Results: - * Returns the internal address of the TclObjInterpProc - * functions. + * Returns the internal address of the TclObjInterpProc function. * * Side effects: * None. @@ -2292,10 +2288,10 @@ TclUpdateReturnInfo( *---------------------------------------------------------------------- */ -Tcl_ObjCmdProc * +TclObjCmdProcType TclGetObjInterpProc(void) { - return TclObjInterpProc; + return (TclObjCmdProcType) TclObjInterpProc; } /* @@ -2330,7 +2326,10 @@ TclNewProcBodyObj( TclNewObj(objPtr); if (objPtr) { - ProcSetInternalRep(objPtr, procPtr); + objPtr->typePtr = &tclProcBodyType; + objPtr->internalRep.twoPtrValue.ptr1 = procPtr; + + procPtr->refCount++; } return objPtr; @@ -2358,10 +2357,11 @@ ProcBodyDup( Tcl_Obj *srcPtr, /* Object to copy. */ Tcl_Obj *dupPtr) /* Target object for the duplication. */ { - Proc *procPtr; - ProcGetInternalRep(srcPtr, procPtr); + Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1; - ProcSetInternalRep(dupPtr, procPtr); + dupPtr->typePtr = &tclProcBodyType; + dupPtr->internalRep.twoPtrValue.ptr1 = procPtr; + procPtr->refCount++; } /* @@ -2387,11 +2387,9 @@ static void ProcBodyFree( Tcl_Obj *objPtr) /* The object to clean up. */ { - Proc *procPtr; + Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1; - ProcGetInternalRep(objPtr, procPtr); - - if (procPtr->refCount-- <= 1) { + if (procPtr->refCount-- < 2) { TclProcCleanupProc(procPtr); } } @@ -2413,46 +2411,44 @@ ProcBodyFree( static void DupLambdaInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ - Tcl_Obj *copyPtr) /* Object with internal rep to set. */ + register Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - Proc *procPtr; - Tcl_Obj *nsObjPtr; + Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1; + Tcl_Obj *nsObjPtr = srcPtr->internalRep.twoPtrValue.ptr2; - LambdaGetInternalRep(srcPtr, procPtr, nsObjPtr); - assert(procPtr != NULL); + copyPtr->internalRep.twoPtrValue.ptr1 = procPtr; + copyPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr; procPtr->refCount++; - - LambdaSetInternalRep(copyPtr, procPtr, nsObjPtr); + Tcl_IncrRefCount(nsObjPtr); + copyPtr->typePtr = &lambdaType; } static void FreeLambdaInternalRep( - Tcl_Obj *objPtr) /* CmdName object with internal representation + register Tcl_Obj *objPtr) /* CmdName object with internal representation * to free. */ { - Proc *procPtr; - Tcl_Obj *nsObjPtr; + Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1; + Tcl_Obj *nsObjPtr = objPtr->internalRep.twoPtrValue.ptr2; - LambdaGetInternalRep(objPtr, procPtr, nsObjPtr); - assert(procPtr != NULL); - - if (procPtr->refCount-- <= 1) { + procPtr->refCount--; + if (procPtr->refCount == 0) { TclProcCleanupProc(procPtr); } TclDecrRefCount(nsObjPtr); + objPtr->typePtr = NULL; } static int SetLambdaFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr) /* The object to convert. */ + register Tcl_Obj *objPtr) /* The object to convert. */ { Interp *iPtr = (Interp *) interp; - const char *name; - Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv; - int isNew, result; - Tcl_Size objc; + char *name; + Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv, *errPtr; + int isNew, objc, result; CmdFrame *cfPtr = NULL; Proc *procPtr; @@ -2465,20 +2461,12 @@ SetLambdaFromAny( * length is not 2, then it cannot be converted to lambdaType. */ - result = TclListObjLength(NULL, objPtr, &objc); - if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't interpret \"%s\" as a lambda expression", - Tcl_GetString(objPtr))); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", (void *)NULL); - return TCL_ERROR; - } result = TclListObjGetElements(NULL, objPtr, &objc, &objv); if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't interpret \"%s\" as a lambda expression", - Tcl_GetString(objPtr))); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", (void *)NULL); + TclNewLiteralStringObj(errPtr, "can't interpret \""); + Tcl_AppendObjToObj(errPtr, objPtr); + Tcl_AppendToObj(errPtr, "\" as a lambda expression", -1); + Tcl_SetObjResult(interp, errPtr); return TCL_ERROR; } @@ -2527,9 +2515,11 @@ SetLambdaFromAny( */ if (iPtr->cmdFramePtr) { - CmdFrame *contextPtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame)); + CmdFrame *contextPtr; + contextPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame)); *contextPtr = *iPtr->cmdFramePtr; + if (contextPtr->type == TCL_LOCATION_BC) { /* * Retrieve the source context from the bytecode. This call @@ -2556,19 +2546,19 @@ SetLambdaFromAny( if (contextPtr->line && (contextPtr->nline >= 2) && (contextPtr->line[1] >= 0)) { - Tcl_Size buf[2]; + int buf[2]; /* * Move from approximation (line of list cmd word) to actual * location (line of 2nd list element). */ - cfPtr = (CmdFrame *)ckalloc(sizeof(CmdFrame)); + cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame)); TclListLines(objPtr, contextPtr->line[1], 2, buf, NULL); cfPtr->level = -1; cfPtr->type = contextPtr->type; - cfPtr->line = (Tcl_Size *)ckalloc(sizeof(Tcl_Size)); + cfPtr->line = (int *) ckalloc(sizeof(int)); cfPtr->line[0] = buf[1]; cfPtr->nline = 1; cfPtr->framePtr = NULL; @@ -2577,8 +2567,8 @@ SetLambdaFromAny( cfPtr->data.eval.path = contextPtr->data.eval.path; Tcl_IncrRefCount(cfPtr->data.eval.path); - cfPtr->cmd = NULL; - cfPtr->len = 0; + cfPtr->cmd.str.cmd = NULL; + cfPtr->cmd.str.len = 0; } /* @@ -2590,7 +2580,7 @@ SetLambdaFromAny( } TclStackFree(interp, contextPtr); } - Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->linePBodyPtr, procPtr, + Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->linePBodyPtr, (char *) procPtr, &isNew), cfPtr); /* @@ -2601,7 +2591,7 @@ SetLambdaFromAny( if (objc == 2) { TclNewLiteralStringObj(nsObjPtr, "::"); } else { - const char *nsName = TclGetString(objv[2]); + char *nsName = TclGetString(objv[2]); if ((*nsName != ':') || (*(nsName+1) != ':')) { TclNewLiteralStringObj(nsObjPtr, "::"); @@ -2611,41 +2601,20 @@ SetLambdaFromAny( } } + Tcl_IncrRefCount(nsObjPtr); + /* * Free the list internalrep of objPtr - this will free argsPtr, but * bodyPtr retains a reference from the Proc structure. Then finish the * conversion to lambdaType. */ - LambdaSetInternalRep(objPtr, procPtr, nsObjPtr); - return TCL_OK; -} - -Proc * -TclGetLambdaFromObj( - Tcl_Interp *interp, - Tcl_Obj *objPtr, - Tcl_Obj **nsObjPtrPtr) -{ - Proc *procPtr; - Tcl_Obj *nsObjPtr; - - LambdaGetInternalRep(objPtr, procPtr, nsObjPtr); - - if (procPtr == NULL) { - if (SetLambdaFromAny(interp, objPtr) != TCL_OK) { - return NULL; - } - LambdaGetInternalRep(objPtr, procPtr, nsObjPtr); - } - - assert(procPtr != NULL); - if (procPtr->iPtr != (Interp *)interp) { - return NULL; - } + objPtr->typePtr->freeIntRepProc(objPtr); - *nsObjPtrPtr = nsObjPtr; - return procPtr; + objPtr->internalRep.twoPtrValue.ptr1 = procPtr; + objPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr; + objPtr->typePtr = &lambdaType; + return TCL_OK; } /* @@ -2667,92 +2636,113 @@ TclGetLambdaFromObj( int Tcl_ApplyObjCmd( - void *clientData, + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - return Tcl_NRCallObjProc(interp, TclNRApplyObjCmd, clientData, objc, objv); -} - -int -TclNRApplyObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { + Interp *iPtr = (Interp *) interp; Proc *procPtr = NULL; Tcl_Obj *lambdaPtr, *nsObjPtr; - int result; + int result, isRootEnsemble; + Command cmd; Tcl_Namespace *nsPtr; - ApplyExtraData *extraPtr; + ExtraFrameInfo efi; if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "lambdaExpr ?arg ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "lambdaExpr ?arg1 arg2 ...?"); return TCL_ERROR; } /* - * Set lambdaPtr, convert it to tclLambdaType in the current interp if + * Set lambdaPtr, convert it to lambdaType in the current interp if * necessary. */ lambdaPtr = objv[1]; - procPtr = TclGetLambdaFromObj(interp, lambdaPtr, &nsObjPtr); - - if (procPtr == NULL) { - return TCL_ERROR; + if (lambdaPtr->typePtr == &lambdaType) { + procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1; } - /* - * Push a call frame for the lambda namespace. - * Note that TclObjInterpProc() will pop it. - */ +#define JOE_EXTENSION 0 +#if JOE_EXTENSION + else { + /* + * Joe English's suggestion to allow cmdNames to function as lambdas. + * Also requires making tclCmdNameType non-static in tclObj.c + */ - result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); - if (result != TCL_OK) { - return TCL_ERROR; + Tcl_Obj *elemPtr; + int numElem; + + if ((lambdaPtr->typePtr == &tclCmdNameType) || + (TclListObjGetElements(interp, lambdaPtr, &numElem, + &elemPtr) == TCL_OK && numElem == 1)) { + return Tcl_EvalObjv(interp, objc-1, objv+1, 0); + } + } +#endif + + if ((procPtr == NULL) || (procPtr->iPtr != iPtr)) { + result = SetLambdaFromAny(interp, lambdaPtr); + if (result != TCL_OK) { + return result; + } + procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1; } - extraPtr = (ApplyExtraData *)TclStackAlloc(interp, sizeof(ApplyExtraData)); - memset(&extraPtr->cmd, 0, sizeof(Command)); - procPtr->cmdPtr = &extraPtr->cmd; - extraPtr->cmd.nsPtr = (Namespace *) nsPtr; + memset(&cmd, 0, sizeof(Command)); + procPtr->cmdPtr = &cmd; /* * TIP#280 (semi-)HACK! * - * Using cmd.clientData to tell [info frame] how to render the lambdaPtr. - * The InfoFrameCmd will detect this case by testing cmd.hPtr for NULL. - * This condition holds here because of the memset() above, and nowhere - * else (in the core). Regular commands always have a valid hPtr, and - * lambda's never. + * Using cmd.clientData to tell [info frame] how to render the + * 'lambdaPtr'. The InfoFrameCmd will detect this case by testing cmd.hPtr + * for NULL. This condition holds here because of the 'memset' above, and + * nowhere else (in the core). Regular commands always have a valid + * 'hPtr', and lambda's never. */ - extraPtr->efi.length = 1; - extraPtr->efi.fields[0].name = "lambda"; - extraPtr->efi.fields[0].proc = NULL; - extraPtr->efi.fields[0].clientData = lambdaPtr; - extraPtr->cmd.clientData = &extraPtr->efi; + efi.length = 1; + efi.fields[0].name = "lambda"; + efi.fields[0].proc = NULL; + efi.fields[0].clientData = lambdaPtr; + cmd.clientData = &efi; + + /* + * Find the namespace where this lambda should run, and push a call frame + * for that namespace. Note that TclObjInterpProc() will pop it. + */ + + nsObjPtr = lambdaPtr->internalRep.twoPtrValue.ptr2; + result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); + if (result != TCL_OK) { + return result; + } + + cmd.nsPtr = (Namespace *) nsPtr; - result = TclPushProcCallFrame(procPtr, interp, objc, objv, 1); + isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL); + if (isRootEnsemble) { + iPtr->ensembleRewrite.sourceObjs = objv; + iPtr->ensembleRewrite.numRemovedObjs = 1; + iPtr->ensembleRewrite.numInsertedObjs = 0; + } else { + iPtr->ensembleRewrite.numInsertedObjs -= 1; + } + + result = PushProcCallFrame((ClientData) procPtr, interp, objc, objv, 1); if (result == TCL_OK) { - TclNRAddCallback(interp, ApplyNR2, extraPtr, NULL, NULL, NULL); - result = TclNRInterpProcCore(interp, objv[1], 2, &MakeLambdaError); + result = TclObjInterpProcCore(interp, objv[1], 2, &MakeLambdaError); } - return result; -} -static int -ApplyNR2( - void *data[], - Tcl_Interp *interp, - int result) -{ - ApplyExtraData *extraPtr = (ApplyExtraData *)data[0]; + if (isRootEnsemble) { + iPtr->ensembleRewrite.sourceObjs = NULL; + iPtr->ensembleRewrite.numRemovedObjs = 0; + iPtr->ensembleRewrite.numInsertedObjs = 0; + } - TclStackFree(interp, extraPtr); return result; } @@ -2781,50 +2771,138 @@ MakeLambdaError( Tcl_Obj *procNameObj) /* Name of the procedure. Used for error * messages and trace information. */ { - int overflow, limit = 60; - Tcl_Size nameLen; - const char *procName = TclGetStringFromObj(procNameObj, &nameLen); + int overflow, limit = 60, nameLen; + const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen); overflow = (nameLen > limit); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (lambda term \"%.*s%s\" line %d)", - (overflow ? limit : (int)nameLen), procName, - (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); + (overflow ? limit : nameLen), procName, + (overflow ? "..." : ""), interp->errorLine)); } + /* *---------------------------------------------------------------------- * - * TclGetCmdFrameForProcedure -- - * - * How to get the CmdFrame information for a procedure. - * - * Results: - * A pointer to the CmdFrame (only guaranteed to be valid until the next - * Tcl command is processed or the interpreter's state is otherwise - * modified) or a NULL if the information is not available. + * Tcl_DisassembleObjCmd -- * - * Side effects: - * none. + * Implementation of the "::tcl::unsupported::disassemble" command. This + * command is not documented, but will disassemble procedures, lambda + * terms and general scripts. Note that will compile terms if necessary + * in order to disassemble them. * *---------------------------------------------------------------------- */ -CmdFrame * -TclGetCmdFrameForProcedure( - Proc *procPtr) /* The procedure whose cmd-frame is to be - * looked up. */ +int +Tcl_DisassembleObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { - Tcl_HashEntry *hePtr; + static const char *types[] = { + "lambda", "proc", "script", NULL + }; + enum Types { + DISAS_LAMBDA, DISAS_PROC, DISAS_SCRIPT + }; + int idx, result; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "type procName|lambdaTerm|script"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], types, "type", 0, &idx)!=TCL_OK){ + return TCL_ERROR; + } - if (procPtr == NULL || procPtr->iPtr == NULL) { - return NULL; + switch ((enum Types) idx) { + case DISAS_LAMBDA: { + Proc *procPtr = NULL; + Command cmd; + Tcl_Obj *nsObjPtr; + Tcl_Namespace *nsPtr; + + /* + * Compile (if uncompiled) and disassemble a lambda term. + */ + + if (objv[2]->typePtr == &lambdaType) { + procPtr = objv[2]->internalRep.twoPtrValue.ptr1; + } + if (procPtr == NULL || procPtr->iPtr != (Interp *) interp) { + result = SetLambdaFromAny(interp, objv[2]); + if (result != TCL_OK) { + return result; + } + procPtr = objv[2]->internalRep.twoPtrValue.ptr1; + } + + memset(&cmd, 0, sizeof(Command)); + nsObjPtr = objv[2]->internalRep.twoPtrValue.ptr2; + result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); + if (result != TCL_OK) { + return result; + } + cmd.nsPtr = (Namespace *) nsPtr; + procPtr->cmdPtr = &cmd; + result = PushProcCallFrame(procPtr, interp, objc, objv, 1); + if (result != TCL_OK) { + return result; + } + TclPopStackFrame(interp); + if (((ByteCode *) procPtr->bodyPtr->internalRep.twoPtrValue.ptr1)->flags + & TCL_BYTECODE_PRECOMPILED) { + Tcl_AppendResult(interp, "may not disassemble prebuilt bytecode", + NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(procPtr->bodyPtr)); + break; } - hePtr = Tcl_FindHashEntry(procPtr->iPtr->linePBodyPtr, procPtr); - if (hePtr == NULL) { - return NULL; + case DISAS_PROC: { + Proc *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. + */ + + result = PushProcCallFrame(procPtr, interp, 2, objv+1, 1); + if (result != TCL_OK) { + return result; + } + TclPopStackFrame(interp); + if (((ByteCode *) procPtr->bodyPtr->internalRep.twoPtrValue.ptr1)->flags + & TCL_BYTECODE_PRECOMPILED) { + Tcl_AppendResult(interp, "may not disassemble prebuilt bytecode", + NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(procPtr->bodyPtr)); + break; } - return (CmdFrame *) Tcl_GetHashValue(hePtr); + case DISAS_SCRIPT: + /* + * Compile and disassemble a script. + */ + + if (objv[2]->typePtr != &tclByteCodeType) { + if (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK){ + return TCL_ERROR; + } + } + Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(objv[2])); + break; + } + return TCL_OK; } /* |