tclProc.c

Go to the documentation of this file.
00001 /*
00002  * tclProc.c --
00003  *
00004  *      This file contains routines that implement Tcl procedures, including
00005  *      the "proc" and "uplevel" commands.
00006  *
00007  * Copyright (c) 1987-1993 The Regents of the University of California.
00008  * Copyright (c) 1994-1998 Sun Microsystems, Inc.
00009  * Copyright (c) 2004-2006 Miguel Sofer
00010  * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
00011  *
00012  * See the file "license.terms" for information on usage and redistribution of
00013  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
00014  *
00015  * RCS: @(#) $Id: tclProc.c,v 1.139 2007/12/13 15:23:20 dgp Exp $
00016  */
00017 
00018 #include "tclInt.h"
00019 #include "tclCompile.h"
00020 
00021 /*
00022  * Prototypes for static functions in this file
00023  */
00024 
00025 static void             DupLambdaInternalRep(Tcl_Obj *objPtr,
00026                             Tcl_Obj *copyPtr);
00027 static void             FreeLambdaInternalRep(Tcl_Obj *objPtr);
00028 static int              InitArgsAndLocals(Tcl_Interp *interp,
00029                             Tcl_Obj *procNameObj, int skip);
00030 static void             InitResolvedLocals(Tcl_Interp *interp,
00031                             ByteCode *codePtr, Var *defPtr,
00032                             Namespace *nsPtr);
00033 static void             InitLocalCache(Proc *procPtr);
00034 static int              PushProcCallFrame(ClientData clientData,
00035                             register Tcl_Interp *interp, int objc,
00036                             Tcl_Obj *CONST objv[], int isLambda);
00037 static void             ProcBodyDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr);
00038 static void             ProcBodyFree(Tcl_Obj *objPtr);
00039 static int              ProcWrongNumArgs(Tcl_Interp *interp, int skip);
00040 static void             MakeProcError(Tcl_Interp *interp,
00041                             Tcl_Obj *procNameObj);
00042 static void             MakeLambdaError(Tcl_Interp *interp,
00043                             Tcl_Obj *procNameObj);
00044 static int              SetLambdaFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
00045 static int              ProcCompileProc(Tcl_Interp *interp, Proc *procPtr,
00046                             Tcl_Obj *bodyPtr, Namespace *nsPtr,
00047                             CONST char *description, CONST char *procName,
00048                             Proc **procPtrPtr);
00049 
00050 /*
00051  * The ProcBodyObjType type
00052  */
00053 
00054 Tcl_ObjType tclProcBodyType = {
00055     "procbody",                 /* name for this type */
00056     ProcBodyFree,               /* FreeInternalRep function */
00057     ProcBodyDup,                /* DupInternalRep function */
00058     NULL,                       /* UpdateString function; Tcl_GetString and
00059                                  * Tcl_GetStringFromObj should panic
00060                                  * instead. */
00061     NULL                        /* SetFromAny function; Tcl_ConvertToType
00062                                  * should panic instead. */
00063 };
00064 
00065 /*
00066  * The [upvar]/[uplevel] level reference type. Uses the twoPtrValue field,
00067  * encoding the type of level reference in ptr1 and the actual parsed out
00068  * offset in ptr2.
00069  *
00070  * Uses the default behaviour throughout, and never disposes of the string
00071  * rep; it's just a cache type.
00072  */
00073 
00074 static Tcl_ObjType levelReferenceType = {
00075     "levelReference",
00076     NULL, NULL, NULL, NULL
00077 };
00078 
00079 /*
00080  * The type of lambdas. Note that every lambda will *always* have a string
00081  * representation.
00082  *
00083  * Internally, ptr1 is a pointer to a Proc instance that is not bound to a
00084  * command name, and ptr2 is a pointer to the namespace that the Proc instance
00085  * will execute within.
00086  */
00087 
00088 static Tcl_ObjType lambdaType = {
00089     "lambdaExpr",               /* name */
00090     FreeLambdaInternalRep,      /* freeIntRepProc */
00091     DupLambdaInternalRep,       /* dupIntRepProc */
00092     NULL,                       /* updateStringProc */
00093     SetLambdaFromAny            /* setFromAnyProc */
00094 };
00095 
00096 /*
00097  *----------------------------------------------------------------------
00098  *
00099  * Tcl_ProcObjCmd --
00100  *
00101  *      This object-based function is invoked to process the "proc" Tcl
00102  *      command. See the user documentation for details on what it does.
00103  *
00104  * Results:
00105  *      A standard Tcl object result value.
00106  *
00107  * Side effects:
00108  *      A new procedure gets created.
00109  *
00110  *----------------------------------------------------------------------
00111  */
00112 
00113         /* ARGSUSED */
00114 int
00115 Tcl_ProcObjCmd(
00116     ClientData dummy,           /* Not used. */
00117     Tcl_Interp *interp,         /* Current interpreter. */
00118     int objc,                   /* Number of arguments. */
00119     Tcl_Obj *CONST objv[])      /* Argument objects. */
00120 {
00121     register Interp *iPtr = (Interp *) interp;
00122     Proc *procPtr;
00123     char *fullName;
00124     CONST char *procName, *procArgs, *procBody;
00125     Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
00126     Tcl_Command cmd;
00127     Tcl_DString ds;
00128 
00129     if (objc != 4) {
00130         Tcl_WrongNumArgs(interp, 1, objv, "name args body");
00131         return TCL_ERROR;
00132     }
00133 
00134     /*
00135      * Determine the namespace where the procedure should reside. Unless the
00136      * command name includes namespace qualifiers, this will be the current
00137      * namespace.
00138      */
00139 
00140     fullName = TclGetString(objv[1]);
00141     TclGetNamespaceForQualName(interp, fullName, NULL, 0,
00142             &nsPtr, &altNsPtr, &cxtNsPtr, &procName);
00143 
00144     if (nsPtr == NULL) {
00145         Tcl_AppendResult(interp, "can't create procedure \"", fullName,
00146                 "\": unknown namespace", NULL);
00147         return TCL_ERROR;
00148     }
00149     if (procName == NULL) {
00150         Tcl_AppendResult(interp, "can't create procedure \"", fullName,
00151                 "\": bad procedure name", NULL);
00152         return TCL_ERROR;
00153     }
00154     if ((nsPtr != iPtr->globalNsPtr)
00155             && (procName != NULL) && (procName[0] == ':')) {
00156         Tcl_AppendResult(interp, "can't create procedure \"", procName,
00157                 "\" in non-global namespace with name starting with \":\"",
00158                 NULL);
00159         return TCL_ERROR;
00160     }
00161 
00162     /*
00163      * Create the data structure to represent the procedure.
00164      */
00165 
00166     if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3],
00167             &procPtr) != TCL_OK) {
00168         Tcl_AddErrorInfo(interp, "\n    (creating proc \"");
00169         Tcl_AddErrorInfo(interp, procName);
00170         Tcl_AddErrorInfo(interp, "\")");
00171         return TCL_ERROR;
00172     }
00173 
00174     /*
00175      * Now create a command for the procedure. This will initially be in the
00176      * current namespace unless the procedure's name included namespace
00177      * qualifiers. To create the new command in the right namespace, we
00178      * generate a fully qualified name for it.
00179      */
00180 
00181     Tcl_DStringInit(&ds);
00182     if (nsPtr != iPtr->globalNsPtr) {
00183         Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
00184         Tcl_DStringAppend(&ds, "::", 2);
00185     }
00186     Tcl_DStringAppend(&ds, procName, -1);
00187 
00188     cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds),
00189             TclObjInterpProc, (ClientData) procPtr, TclProcDeleteProc);
00190 
00191     Tcl_DStringFree(&ds);
00192 
00193     /*
00194      * Now initialize the new procedure's cmdPtr field. This will be used
00195      * later when the procedure is called to determine what namespace the
00196      * procedure will run in. This will be different than the current
00197      * namespace if the proc was renamed into a different namespace.
00198      */
00199 
00200     procPtr->cmdPtr = (Command *) cmd;
00201 
00202     /*
00203      * TIP #280: Remember the line the procedure body is starting on. In a
00204      * bytecode context we ask the engine to provide us with the necessary
00205      * information. This is for the initialization of the byte code compiler
00206      * when the body is used for the first time.
00207      *
00208      * This code is nearly identical to the #280 code in SetLambdaFromAny, see
00209      * this file. The differences are the different index of the body in the
00210      * line array of the context, and the lamdba code requires some special
00211      * processing. Find a way to factor the common elements into a single
00212      * function.
00213      */
00214 
00215     if (iPtr->cmdFramePtr) {
00216         CmdFrame *contextPtr;
00217 
00218         contextPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame));
00219         *contextPtr = *iPtr->cmdFramePtr;
00220 
00221         if (contextPtr->type == TCL_LOCATION_BC) {
00222             /*
00223              * Retrieve source information from the bytecode, if possible. If
00224              * the information is retrieved successfully, context.type will be
00225              * TCL_LOCATION_SOURCE and the reference held by
00226              * context.data.eval.path will be counted.
00227              */
00228 
00229             TclGetSrcInfoForPc(contextPtr);
00230         } else if (contextPtr->type == TCL_LOCATION_SOURCE) {
00231             /*
00232              * The copy into 'context' up above has created another reference
00233              * to 'context.data.eval.path'; account for it.
00234              */
00235 
00236             Tcl_IncrRefCount(contextPtr->data.eval.path);
00237         }
00238 
00239         if (contextPtr->type == TCL_LOCATION_SOURCE) {
00240             /*
00241              * We can account for source location within a proc only if the
00242              * proc body was not created by substitution.
00243              */
00244 
00245             if (contextPtr->line
00246                     && (contextPtr->nline >= 4) && (contextPtr->line[3] >= 0)) {
00247                 int isNew;
00248                 CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame));
00249 
00250                 cfPtr->level = -1;
00251                 cfPtr->type = contextPtr->type;
00252                 cfPtr->line = (int *) ckalloc(sizeof(int));
00253                 cfPtr->line[0] = contextPtr->line[3];
00254                 cfPtr->nline = 1;
00255                 cfPtr->framePtr = NULL;
00256                 cfPtr->nextPtr = NULL;
00257 
00258                 cfPtr->data.eval.path = contextPtr->data.eval.path;
00259                 Tcl_IncrRefCount(cfPtr->data.eval.path);
00260 
00261                 cfPtr->cmd.str.cmd = NULL;
00262                 cfPtr->cmd.str.len = 0;
00263 
00264                 Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->linePBodyPtr,
00265                         (char *) procPtr, &isNew), cfPtr);
00266             }
00267 
00268             /*
00269              * 'contextPtr' is going out of scope; account for the reference that
00270              * it's holding to the path name.
00271              */
00272 
00273             Tcl_DecrRefCount(contextPtr->data.eval.path);
00274             contextPtr->data.eval.path = NULL;
00275         }
00276         TclStackFree(interp, contextPtr);
00277     }
00278 
00279     /*
00280      * Optimize for no-op procs: if the body is not precompiled (like a TclPro
00281      * procbody), and the argument list is just "args" and the body is empty,
00282      * define a compileProc to compile a no-op.
00283      *
00284      * Notes:
00285      *   - cannot be done for any argument list without having different
00286      *     compiled/not-compiled behaviour in the "wrong argument #" case, or
00287      *     making this code much more complicated. In any case, it doesn't
00288      *     seem to make a lot of sense to verify the number of arguments we
00289      *     are about to ignore ...
00290      *   - could be enhanced to handle also non-empty bodies that contain only
00291      *     comments; however, parsing the body will slow down the compilation
00292      *     of all procs whose argument list is just _args_
00293      */
00294 
00295     if (objv[3]->typePtr == &tclProcBodyType) {
00296         goto done;
00297     }
00298 
00299     procArgs = TclGetString(objv[2]);
00300 
00301     while (*procArgs == ' ') {
00302         procArgs++;
00303     }
00304 
00305     if ((procArgs[0] == 'a') && (strncmp(procArgs, "args", 4) == 0)) {
00306         procArgs +=4;
00307         while(*procArgs != '\0') {
00308             if (*procArgs != ' ') {
00309                 goto done;
00310             }
00311             procArgs++;
00312         }
00313 
00314         /*
00315          * The argument list is just "args"; check the body
00316          */
00317 
00318         procBody = TclGetString(objv[3]);
00319         while (*procBody != '\0') {
00320             if (!isspace(UCHAR(*procBody))) {
00321                 goto done;
00322             }
00323             procBody++;
00324         }
00325 
00326         /*
00327          * The body is just spaces: link the compileProc
00328          */
00329 
00330         ((Command *) cmd)->compileProc = TclCompileNoOp;
00331     }
00332 
00333   done:
00334     return TCL_OK;
00335 }
00336 
00337 /*
00338  *----------------------------------------------------------------------
00339  *
00340  * TclCreateProc --
00341  *
00342  *      Creates the data associated with a Tcl procedure definition. This
00343  *      function knows how to handle two types of body objects: strings and
00344  *      procbody. Strings are the traditional (and common) value for bodies,
00345  *      procbody are values created by extensions that have loaded a
00346  *      previously compiled script.
00347  *
00348  * Results:
00349  *      Returns TCL_OK on success, along with a pointer to a Tcl procedure
00350  *      definition in procPtrPtr where the cmdPtr field is not initialised.
00351  *      This definition should be freed by calling TclProcCleanupProc() when
00352  *      it is no longer needed. Returns TCL_ERROR if anything goes wrong.
00353  *
00354  * Side effects:
00355  *      If anything goes wrong, this function returns an error message in the
00356  *      interpreter.
00357  *
00358  *----------------------------------------------------------------------
00359  */
00360 
00361 int
00362 TclCreateProc(
00363     Tcl_Interp *interp,         /* Interpreter containing proc. */
00364     Namespace *nsPtr,           /* Namespace containing this proc. */
00365     CONST char *procName,       /* Unqualified name of this proc. */
00366     Tcl_Obj *argsPtr,           /* Description of arguments. */
00367     Tcl_Obj *bodyPtr,           /* Command body. */
00368     Proc **procPtrPtr)          /* Returns: pointer to proc data. */
00369 {
00370     Interp *iPtr = (Interp *) interp;
00371     CONST char **argArray = NULL;
00372 
00373     register Proc *procPtr;
00374     int i, length, result, numArgs;
00375     CONST char *args, *bytes, *p;
00376     register CompiledLocal *localPtr = NULL;
00377     Tcl_Obj *defPtr;
00378     int precompiled = 0;
00379 
00380     if (bodyPtr->typePtr == &tclProcBodyType) {
00381         /*
00382          * Because the body is a TclProProcBody, the actual body is already
00383          * compiled, and it is not shared with anyone else, so it's OK not to
00384          * unshare it (as a matter of fact, it is bad to unshare it, because
00385          * there may be no source code).
00386          *
00387          * We don't create and initialize a Proc structure for the procedure;
00388          * rather, we use what is in the body object. We increment the ref
00389          * count of the Proc struct since the command (soon to be created)
00390          * will be holding a reference to it.
00391          */
00392 
00393         procPtr = bodyPtr->internalRep.otherValuePtr;
00394         procPtr->iPtr = iPtr;
00395         procPtr->refCount++;
00396         precompiled = 1;
00397     } else {
00398         /*
00399          * If the procedure's body object is shared because its string value
00400          * is identical to, e.g., the body of another procedure, we must
00401          * create a private copy for this procedure to use. Such sharing of
00402          * procedure bodies is rare but can cause problems. A procedure body
00403          * is compiled in a context that includes the number of "slots"
00404          * allocated by the compiler for local variables. There is a local
00405          * variable slot for each formal parameter (the
00406          * "procPtr->numCompiledLocals = numArgs" assignment below). This
00407          * means that the same code can not be shared by two procedures that
00408          * have a different number of arguments, even if their bodies are
00409          * identical. Note that we don't use Tcl_DuplicateObj since we would
00410          * not want any bytecode internal representation.
00411          */
00412 
00413         if (Tcl_IsShared(bodyPtr)) {
00414             bytes = TclGetStringFromObj(bodyPtr, &length);
00415             bodyPtr = Tcl_NewStringObj(bytes, length);
00416         }
00417 
00418         /*
00419          * Create and initialize a Proc structure for the procedure. We
00420          * increment the ref count of the procedure's body object since there
00421          * will be a reference to it in the Proc structure.
00422          */
00423 
00424         Tcl_IncrRefCount(bodyPtr);
00425 
00426         procPtr = (Proc *) ckalloc(sizeof(Proc));
00427         procPtr->iPtr = iPtr;
00428         procPtr->refCount = 1;
00429         procPtr->bodyPtr = bodyPtr;
00430         procPtr->numArgs = 0;   /* Actual argument count is set below. */
00431         procPtr->numCompiledLocals = 0;
00432         procPtr->firstLocalPtr = NULL;
00433         procPtr->lastLocalPtr = NULL;
00434     }
00435 
00436     /*
00437      * Break up the argument list into argument specifiers, then process each
00438      * argument specifier. If the body is precompiled, processing is limited
00439      * to checking that the parsed argument is consistent with the one stored
00440      * in the Proc.
00441      *
00442      * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULS.
00443      */
00444 
00445     args = TclGetStringFromObj(argsPtr, &length);
00446     result = Tcl_SplitList(interp, args, &numArgs, &argArray);
00447     if (result != TCL_OK) {
00448         goto procError;
00449     }
00450 
00451     if (precompiled) {
00452         if (numArgs > procPtr->numArgs) {
00453             Tcl_SetObjResult(interp, Tcl_ObjPrintf(
00454                     "procedure \"%s\": arg list contains %d entries, "
00455                     "precompiled header expects %d", procName, numArgs,
00456                     procPtr->numArgs));
00457             goto procError;
00458         }
00459         localPtr = procPtr->firstLocalPtr;
00460     } else {
00461         procPtr->numArgs = numArgs;
00462         procPtr->numCompiledLocals = numArgs;
00463     }
00464 
00465     for (i = 0; i < numArgs; i++) {
00466         int fieldCount, nameLength, valueLength;
00467         CONST char **fieldValues;
00468 
00469         /*
00470          * Now divide the specifier up into name and default.
00471          */
00472 
00473         result = Tcl_SplitList(interp, argArray[i], &fieldCount,
00474                 &fieldValues);
00475         if (result != TCL_OK) {
00476             goto procError;
00477         }
00478         if (fieldCount > 2) {
00479             ckfree((char *) fieldValues);
00480             Tcl_AppendResult(interp,
00481                     "too many fields in argument specifier \"",
00482                     argArray[i], "\"", NULL);
00483             goto procError;
00484         }
00485         if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
00486             ckfree((char *) fieldValues);
00487             Tcl_AppendResult(interp, "argument with no name", NULL);
00488             goto procError;
00489         }
00490 
00491         nameLength = strlen(fieldValues[0]);
00492         if (fieldCount == 2) {
00493             valueLength = strlen(fieldValues[1]);
00494         } else {
00495             valueLength = 0;
00496         }
00497 
00498         /*
00499          * Check that the formal parameter name is a scalar.
00500          */
00501 
00502         p = fieldValues[0];
00503         while (*p != '\0') {
00504             if (*p == '(') {
00505                 CONST char *q = p;
00506                 do {
00507                     q++;
00508                 } while (*q != '\0');
00509                 q--;
00510                 if (*q == ')') {        /* We have an array element. */
00511                     Tcl_AppendResult(interp, "formal parameter \"",
00512                             fieldValues[0],
00513                             "\" is an array element", NULL);
00514                     ckfree((char *) fieldValues);
00515                     goto procError;
00516                 }
00517             } else if ((*p == ':') && (*(p+1) == ':')) {
00518                 Tcl_AppendResult(interp, "formal parameter \"",
00519                         fieldValues[0],
00520                         "\" is not a simple name", NULL);
00521                 ckfree((char *) fieldValues);
00522                 goto procError;
00523             }
00524             p++;
00525         }
00526 
00527         if (precompiled) {
00528             /*
00529              * Compare the parsed argument with the stored one. Note that the
00530              * only flag value that makes sense at this point is VAR_ARGUMENT
00531              * (its value was kept the same as pre VarReform to simplify
00532              * tbcload's processing of older byetcodes).
00533              *
00534              * The only other flag vlaue that is important to retrieve from
00535              * precompiled procs is VAR_TEMPORARY (also unchanged). It is
00536              * needed later when retrieving the variable names.
00537              */
00538 
00539             if ((localPtr->nameLength != nameLength)
00540                     || (strcmp(localPtr->name, fieldValues[0]))
00541                     || (localPtr->frameIndex != i)
00542                     || !(localPtr->flags & VAR_ARGUMENT)
00543                     || (localPtr->defValuePtr == NULL && fieldCount == 2)
00544                     || (localPtr->defValuePtr != NULL && fieldCount != 2)) {
00545                 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
00546                         "procedure \"%s\": formal parameter %d is "
00547                         "inconsistent with precompiled body", procName, i));
00548                 ckfree((char *) fieldValues);
00549                 goto procError;
00550             }
00551 
00552             /*
00553              * Compare the default value if any.
00554              */
00555 
00556             if (localPtr->defValuePtr != NULL) {
00557                 int tmpLength;
00558                 char *tmpPtr = TclGetStringFromObj(localPtr->defValuePtr,
00559                         &tmpLength);
00560 
00561                 if ((valueLength != tmpLength) ||
00562                         strncmp(fieldValues[1], tmpPtr, (size_t) tmpLength)) {
00563                     Tcl_SetObjResult(interp, Tcl_ObjPrintf(
00564                             "procedure \"%s\": formal parameter \"%s\" has "
00565                             "default value inconsistent with precompiled body",
00566                             procName, fieldValues[0]));
00567                     ckfree((char *) fieldValues);
00568                     goto procError;
00569                 }
00570             }
00571             if ((i == numArgs - 1)
00572                     && (localPtr->nameLength == 4)
00573                     && (localPtr->name[0] == 'a')
00574                     && (strcmp(localPtr->name, "args") == 0)) {
00575                 localPtr->flags |= VAR_IS_ARGS;
00576             }
00577 
00578             localPtr = localPtr->nextPtr;
00579         } else {
00580             /*
00581              * Allocate an entry in the runtime procedure frame's array of
00582              * local variables for the argument.
00583              */
00584 
00585             localPtr = (CompiledLocal *) ckalloc((unsigned)
00586                     (sizeof(CompiledLocal) - sizeof(localPtr->name)
00587                             + nameLength + 1));
00588             if (procPtr->firstLocalPtr == NULL) {
00589                 procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
00590             } else {
00591                 procPtr->lastLocalPtr->nextPtr = localPtr;
00592                 procPtr->lastLocalPtr = localPtr;
00593             }
00594             localPtr->nextPtr = NULL;
00595             localPtr->nameLength = nameLength;
00596             localPtr->frameIndex = i;
00597             localPtr->flags = VAR_ARGUMENT;
00598             localPtr->resolveInfo = NULL;
00599 
00600             if (fieldCount == 2) {
00601                 localPtr->defValuePtr =
00602                         Tcl_NewStringObj(fieldValues[1], valueLength);
00603                 Tcl_IncrRefCount(localPtr->defValuePtr);
00604             } else {
00605                 localPtr->defValuePtr = NULL;
00606             }
00607             strcpy(localPtr->name, fieldValues[0]);
00608             if ((i == numArgs - 1)
00609                     && (localPtr->nameLength == 4)
00610                     && (localPtr->name[0] == 'a')
00611                     && (strcmp(localPtr->name, "args") == 0)) {
00612                 localPtr->flags |= VAR_IS_ARGS;
00613             }
00614         }
00615 
00616         ckfree((char *) fieldValues);
00617     }
00618 
00619     *procPtrPtr = procPtr;
00620     ckfree((char *) argArray);
00621     return TCL_OK;
00622 
00623   procError:
00624     if (precompiled) {
00625         procPtr->refCount--;
00626     } else {
00627         Tcl_DecrRefCount(bodyPtr);
00628         while (procPtr->firstLocalPtr != NULL) {
00629             localPtr = procPtr->firstLocalPtr;
00630             procPtr->firstLocalPtr = localPtr->nextPtr;
00631 
00632             defPtr = localPtr->defValuePtr;
00633             if (defPtr != NULL) {
00634                 Tcl_DecrRefCount(defPtr);
00635             }
00636 
00637             ckfree((char *) localPtr);
00638         }
00639         ckfree((char *) procPtr);
00640     }
00641     if (argArray != NULL) {
00642         ckfree((char *) argArray);
00643     }
00644     return TCL_ERROR;
00645 }
00646 
00647 /*
00648  *----------------------------------------------------------------------
00649  *
00650  * TclGetFrame --
00651  *
00652  *      Given a description of a procedure frame, such as the first argument
00653  *      to an "uplevel" or "upvar" command, locate the call frame for the
00654  *      appropriate level of procedure.
00655  *
00656  * Results:
00657  *      The return value is -1 if an error occurred in finding the frame (in
00658  *      this case an error message is left in the interp's result). 1 is
00659  *      returned if string was either a number or a number preceded by "#" and
00660  *      it specified a valid frame. 0 is returned if string isn't one of the
00661  *      two things above (in this case, the lookup acts as if string were
00662  *      "1"). The variable pointed to by framePtrPtr is filled in with the
00663  *      address of the desired frame (unless an error occurs, in which case it
00664  *      isn't modified).
00665  *
00666  * Side effects:
00667  *      None.
00668  *
00669  *----------------------------------------------------------------------
00670  */
00671 
00672 int
00673 TclGetFrame(
00674     Tcl_Interp *interp,         /* Interpreter in which to find frame. */
00675     CONST char *name,           /* String describing frame. */
00676     CallFrame **framePtrPtr)    /* Store pointer to frame here (or NULL if
00677                                  * global frame indicated). */
00678 {
00679     register Interp *iPtr = (Interp *) interp;
00680     int curLevel, level, result;
00681     CallFrame *framePtr;
00682 
00683     /*
00684      * Parse string to figure out which level number to go to.
00685      */
00686 
00687     result = 1;
00688     curLevel = iPtr->varFramePtr->level;
00689     if (*name== '#') {
00690         if (Tcl_GetInt(interp, name+1, &level) != TCL_OK || level < 0) {
00691             goto levelError;
00692         }
00693     } else if (isdigit(UCHAR(*name))) { /* INTL: digit */
00694         if (Tcl_GetInt(interp, name, &level) != TCL_OK) {
00695             goto levelError;
00696         }
00697         level = curLevel - level;
00698     } else {
00699         level = curLevel - 1;
00700         result = 0;
00701     }
00702 
00703     /*
00704      * Figure out which frame to use, and return it to the caller.
00705      */
00706 
00707     for (framePtr = iPtr->varFramePtr; framePtr != NULL;
00708             framePtr = framePtr->callerVarPtr) {
00709         if (framePtr->level == level) {
00710             break;
00711         }
00712     }
00713     if (framePtr == NULL) {
00714         goto levelError;
00715     }
00716 
00717     *framePtrPtr = framePtr;
00718     return result;
00719 
00720   levelError:
00721     Tcl_ResetResult(interp);
00722     Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL);
00723     return -1;
00724 }
00725 
00726 /*
00727  *----------------------------------------------------------------------
00728  *
00729  * TclObjGetFrame --
00730  *
00731  *      Given a description of a procedure frame, such as the first argument
00732  *      to an "uplevel" or "upvar" command, locate the call frame for the
00733  *      appropriate level of procedure.
00734  *
00735  * Results:
00736  *      The return value is -1 if an error occurred in finding the frame (in
00737  *      this case an error message is left in the interp's result). 1 is
00738  *      returned if objPtr was either a number or a number preceded by "#" and
00739  *      it specified a valid frame. 0 is returned if objPtr isn't one of the
00740  *      two things above (in this case, the lookup acts as if objPtr were
00741  *      "1"). The variable pointed to by framePtrPtr is filled in with the
00742  *      address of the desired frame (unless an error occurs, in which case it
00743  *      isn't modified).
00744  *
00745  * Side effects:
00746  *      None.
00747  *
00748  *----------------------------------------------------------------------
00749  */
00750 
00751 int
00752 TclObjGetFrame(
00753     Tcl_Interp *interp,         /* Interpreter in which to find frame. */
00754     Tcl_Obj *objPtr,            /* Object describing frame. */
00755     CallFrame **framePtrPtr)    /* Store pointer to frame here (or NULL if
00756                                  * global frame indicated). */
00757 {
00758     register Interp *iPtr = (Interp *) interp;
00759     int curLevel, level, result;
00760     CallFrame *framePtr;
00761     CONST char *name = TclGetString(objPtr);
00762 
00763     /*
00764      * Parse object to figure out which level number to go to.
00765      */
00766 
00767     result = 1;
00768     curLevel = iPtr->varFramePtr->level;
00769     if (objPtr->typePtr == &levelReferenceType) {
00770         if (PTR2INT(objPtr->internalRep.twoPtrValue.ptr1)) {
00771             level = curLevel - PTR2INT(objPtr->internalRep.twoPtrValue.ptr2);
00772         } else {
00773             level = PTR2INT(objPtr->internalRep.twoPtrValue.ptr2);
00774         }
00775         if (level < 0) {
00776             goto levelError;
00777         }
00778         /* TODO: Consider skipping the typePtr checks */
00779     } else if (objPtr->typePtr == &tclIntType
00780 #ifndef NO_WIDE_TYPE
00781             || objPtr->typePtr == &tclWideIntType
00782 #endif
00783             ) {
00784         if (TclGetIntFromObj(NULL, objPtr, &level) != TCL_OK || level < 0) {
00785             goto levelError;
00786         }
00787         level = curLevel - level;
00788     } else if (*name == '#') {
00789         if (Tcl_GetInt(interp, name+1, &level) != TCL_OK || level < 0) {
00790             goto levelError;
00791         }
00792 
00793         /*
00794          * Cache for future reference.
00795          *
00796          * TODO: Use the new ptrAndLongRep intrep
00797          */
00798 
00799         TclFreeIntRep(objPtr);
00800         objPtr->typePtr = &levelReferenceType;
00801         objPtr->internalRep.twoPtrValue.ptr1 = (void *) 0;
00802         objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(level);
00803     } else if (isdigit(UCHAR(*name))) { /* INTL: digit */
00804         if (Tcl_GetInt(interp, name, &level) != TCL_OK) {
00805             return -1;
00806         }
00807 
00808         /*
00809          * Cache for future reference.
00810          *
00811          * TODO: Use the new ptrAndLongRep intrep
00812          */
00813 
00814         TclFreeIntRep(objPtr);
00815         objPtr->typePtr = &levelReferenceType;
00816         objPtr->internalRep.twoPtrValue.ptr1 = (void *) 1;
00817         objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(level);
00818         level = curLevel - level;
00819     } else {
00820         /*
00821          * Don't cache as the object *isn't* a level reference.
00822          */
00823 
00824         level = curLevel - 1;
00825         result = 0;
00826     }
00827 
00828     /*
00829      * Figure out which frame to use, and return it to the caller.
00830      */
00831 
00832     for (framePtr = iPtr->varFramePtr; framePtr != NULL;
00833             framePtr = framePtr->callerVarPtr) {
00834         if (framePtr->level == level) {
00835             break;
00836         }
00837     }
00838     if (framePtr == NULL) {
00839         goto levelError;
00840     }
00841     *framePtrPtr = framePtr;
00842     return result;
00843 
00844   levelError:
00845     Tcl_ResetResult(interp);
00846     Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL);
00847     return -1;
00848 }
00849 
00850 /*
00851  *----------------------------------------------------------------------
00852  *
00853  * Tcl_UplevelObjCmd --
00854  *
00855  *      This object function is invoked to process the "uplevel" Tcl command.
00856  *      See the user documentation for details on what it does.
00857  *
00858  * Results:
00859  *      A standard Tcl object result value.
00860  *
00861  * Side effects:
00862  *      See the user documentation.
00863  *
00864  *----------------------------------------------------------------------
00865  */
00866 
00867         /* ARGSUSED */
00868 int
00869 Tcl_UplevelObjCmd(
00870     ClientData dummy,           /* Not used. */
00871     Tcl_Interp *interp,         /* Current interpreter. */
00872     int objc,                   /* Number of arguments. */
00873     Tcl_Obj *CONST objv[])      /* Argument objects. */
00874 {
00875     register Interp *iPtr = (Interp *) interp;
00876     int result;
00877     CallFrame *savedVarFramePtr, *framePtr;
00878 
00879     if (objc < 2) {
00880     uplevelSyntax:
00881         Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?");
00882         return TCL_ERROR;
00883     }
00884 
00885     /*
00886      * Find the level to use for executing the command.
00887      */
00888 
00889     result = TclObjGetFrame(interp, objv[1], &framePtr);
00890     if (result == -1) {
00891         return TCL_ERROR;
00892     }
00893     objc -= (result+1);
00894     if (objc == 0) {
00895         goto uplevelSyntax;
00896     }
00897     objv += (result+1);
00898 
00899     /*
00900      * Modify the interpreter state to execute in the given frame.
00901      */
00902 
00903     savedVarFramePtr = iPtr->varFramePtr;
00904     iPtr->varFramePtr = framePtr;
00905 
00906     /*
00907      * Execute the residual arguments as a command.
00908      */
00909 
00910     if (objc == 1) {
00911         result = Tcl_EvalObjEx(interp, objv[0], TCL_EVAL_DIRECT);
00912     } else {
00913         /*
00914          * More than one argument: concatenate them together with spaces
00915          * between, then evaluate the result. Tcl_EvalObjEx will delete the
00916          * object when it decrements its refcount after eval'ing it.
00917          */
00918 
00919         Tcl_Obj *objPtr;
00920 
00921         objPtr = Tcl_ConcatObj(objc, objv);
00922         result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
00923     }
00924     if (result == TCL_ERROR) {
00925         Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
00926                 "\n    (\"uplevel\" body line %d)", interp->errorLine));
00927     }
00928 
00929     /*
00930      * Restore the variable frame, and return.
00931      */
00932 
00933     iPtr->varFramePtr = savedVarFramePtr;
00934     return result;
00935 }
00936 
00937 /*
00938  *----------------------------------------------------------------------
00939  *
00940  * TclFindProc --
00941  *
00942  *      Given the name of a procedure, return a pointer to the record
00943  *      describing the procedure. The procedure will be looked up using the
00944  *      usual rules: first in the current namespace and then in the global
00945  *      namespace.
00946  *
00947  * Results:
00948  *      NULL is returned if the name doesn't correspond to any procedure.
00949  *      Otherwise, the return value is a pointer to the procedure's record. If
00950  *      the name is found but refers to an imported command that points to a
00951  *      "real" procedure defined in another namespace, a pointer to that
00952  *      "real" procedure's structure is returned.
00953  *
00954  * Side effects:
00955  *      None.
00956  *
00957  *----------------------------------------------------------------------
00958  */
00959 
00960 Proc *
00961 TclFindProc(
00962     Interp *iPtr,               /* Interpreter in which to look. */
00963     CONST char *procName)       /* Name of desired procedure. */
00964 {
00965     Tcl_Command cmd;
00966     Tcl_Command origCmd;
00967     Command *cmdPtr;
00968 
00969     cmd = Tcl_FindCommand((Tcl_Interp *) iPtr, procName, NULL, /*flags*/ 0);
00970     if (cmd == (Tcl_Command) NULL) {
00971         return NULL;
00972     }
00973     cmdPtr = (Command *) cmd;
00974 
00975     origCmd = TclGetOriginalCommand(cmd);
00976     if (origCmd != NULL) {
00977         cmdPtr = (Command *) origCmd;
00978     }
00979     if (cmdPtr->objProc != TclObjInterpProc) {
00980         return NULL;
00981     }
00982     return (Proc *) cmdPtr->objClientData;
00983 }
00984 
00985 /*
00986  *----------------------------------------------------------------------
00987  *
00988  * TclIsProc --
00989  *
00990  *      Tells whether a command is a Tcl procedure or not.
00991  *
00992  * Results:
00993  *      If the given command is actually a Tcl procedure, the return value is
00994  *      the address of the record describing the procedure. Otherwise the
00995  *      return value is 0.
00996  *
00997  * Side effects:
00998  *      None.
00999  *
01000  *----------------------------------------------------------------------
01001  */
01002 
01003 Proc *
01004 TclIsProc(
01005     Command *cmdPtr)            /* Command to test. */
01006 {
01007     Tcl_Command origCmd;
01008 
01009     origCmd = TclGetOriginalCommand((Tcl_Command) cmdPtr);
01010     if (origCmd != NULL) {
01011         cmdPtr = (Command *) origCmd;
01012     }
01013     if (cmdPtr->objProc == TclObjInterpProc) {
01014         return (Proc *) cmdPtr->objClientData;
01015     }
01016     return (Proc *) 0;
01017 }
01018 
01019 /*
01020  *----------------------------------------------------------------------
01021  *
01022  * InitArgsAndLocals --
01023  *
01024  *      This routine is invoked in order to initialize the arguments and other
01025  *      compiled locals table for a new call frame.
01026  *
01027  * Results:
01028  *      A standard Tcl result.
01029  *
01030  * Side effects:
01031  *      Allocates memory on the stack for the compiled local variables, the
01032  *      caller is responsible for freeing them. Initialises all variables. May
01033  *      invoke various name resolvers in order to determine which variables
01034  *      are being referenced at runtime.
01035  *
01036  *----------------------------------------------------------------------
01037  */
01038 
01039 static int
01040 ProcWrongNumArgs(
01041     Tcl_Interp *interp, int skip)
01042 {
01043     CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
01044     register Proc *procPtr = framePtr->procPtr;
01045     register Var *defPtr;
01046     int localCt = procPtr->numCompiledLocals, numArgs, i;
01047     Tcl_Obj **desiredObjs;
01048     const char *final = NULL;
01049     
01050     /*
01051      * Build up desired argument list for Tcl_WrongNumArgs
01052      */
01053 
01054     numArgs = framePtr->procPtr->numArgs;
01055     desiredObjs = (Tcl_Obj **) TclStackAlloc(interp,
01056             (int) sizeof(Tcl_Obj *) * (numArgs+1));
01057 
01058 #ifdef AVOID_HACKS_FOR_ITCL
01059     desiredObjs[0] = framePtr->objv[skip-1];
01060 #else
01061     desiredObjs[0] = ((framePtr->isProcCallFrame & FRAME_IS_LAMBDA)
01062             ? framePtr->objv[skip-1]
01063             : Tcl_NewListObj(skip, framePtr->objv));
01064 #endif /* AVOID_HACKS_FOR_ITCL */
01065     Tcl_IncrRefCount(desiredObjs[0]);
01066 
01067     defPtr = (Var *) (&framePtr->localCachePtr->varName0 + localCt);
01068     for (i=1 ; i<=numArgs ; i++, defPtr++) {
01069         Tcl_Obj *argObj;
01070         Tcl_Obj *namePtr = localName(framePtr, i-1);
01071 
01072         if (defPtr->value.objPtr != NULL) {
01073             TclNewObj(argObj);
01074             Tcl_AppendStringsToObj(argObj, "?", TclGetString(namePtr), "?", NULL);
01075         } else if (defPtr->flags & VAR_IS_ARGS) {
01076             numArgs--;
01077             final = "...";
01078             break;
01079         } else {
01080             argObj = namePtr;
01081             Tcl_IncrRefCount(namePtr);
01082         }
01083         desiredObjs[i] = argObj;
01084     }
01085 
01086     Tcl_ResetResult(interp);
01087     Tcl_WrongNumArgs(interp, numArgs+1, desiredObjs, final);
01088 
01089     for (i=0 ; i<=numArgs ; i++) {
01090         Tcl_DecrRefCount(desiredObjs[i]);
01091     }
01092     TclStackFree(interp, desiredObjs);
01093     return TCL_ERROR;
01094 }
01095 
01096 /*
01097  *----------------------------------------------------------------------
01098  *
01099  * TclInitCompiledLocals --
01100  *
01101  *      This routine is invoked in order to initialize the compiled locals
01102  *      table for a new call frame.
01103  *
01104  *      DEPRECATED: functionality has been inlined elsewhere; this function
01105  *      remains to insure binary compatibility with Itcl.
01106  *
01107 
01108  * Results:
01109  *      None.
01110  *
01111  * Side effects:
01112  *      May invoke various name resolvers in order to determine which
01113  *      variables are being referenced at runtime.
01114  *
01115  *----------------------------------------------------------------------
01116  */
01117 void
01118 TclInitCompiledLocals(
01119     Tcl_Interp *interp,         /* Current interpreter. */
01120     CallFrame *framePtr,        /* Call frame to initialize. */
01121     Namespace *nsPtr)           /* Pointer to current namespace. */
01122 {
01123     Var *varPtr = framePtr->compiledLocals;
01124     Tcl_Obj *bodyPtr;
01125     ByteCode *codePtr;
01126 
01127     bodyPtr = framePtr->procPtr->bodyPtr;
01128     if (bodyPtr->typePtr != &tclByteCodeType) {
01129         Tcl_Panic("body object for proc attached to frame is not a byte code type");
01130     }
01131     codePtr = bodyPtr->internalRep.otherValuePtr;
01132 
01133     if (framePtr->numCompiledLocals) {
01134         if (!codePtr->localCachePtr) {
01135             InitLocalCache(framePtr->procPtr) ;
01136         }
01137         framePtr->localCachePtr = codePtr->localCachePtr;
01138         framePtr->localCachePtr->refCount++;
01139     }    
01140 
01141     InitResolvedLocals(interp, codePtr, varPtr, nsPtr);
01142 }
01143 
01144 /*
01145  *----------------------------------------------------------------------
01146  *
01147  * InitResolvedLocals --
01148  *
01149  *      This routine is invoked in order to initialize the compiled locals
01150  *      table for a new call frame.
01151  *
01152  * Results:
01153  *      None.
01154  *
01155  * Side effects:
01156  *      May invoke various name resolvers in order to determine which
01157  *      variables are being referenced at runtime.
01158  *
01159  *----------------------------------------------------------------------
01160  */
01161 
01162 static void
01163 InitResolvedLocals(
01164     Tcl_Interp *interp,         /* Current interpreter. */
01165     ByteCode *codePtr,
01166     Var *varPtr,
01167     Namespace *nsPtr)           /* Pointer to current namespace. */
01168 {
01169     Interp *iPtr = (Interp *) interp;
01170     int haveResolvers = (nsPtr->compiledVarResProc || iPtr->resolverPtr);
01171     CompiledLocal *firstLocalPtr, *localPtr;
01172     int varNum;
01173     Tcl_ResolvedVarInfo *resVarInfo;
01174 
01175     /*
01176      * Find the localPtr corresponding to varPtr
01177      */
01178 
01179     varNum = varPtr - iPtr->framePtr->compiledLocals;
01180     localPtr = iPtr->framePtr->procPtr->firstLocalPtr;
01181     while (varNum--) {
01182         localPtr = localPtr->nextPtr;
01183     }
01184 
01185     if (!(haveResolvers && (codePtr->flags & TCL_BYTECODE_RESOLVE_VARS))) {
01186         /*
01187          * Initialize the array of local variables stored in the call frame.
01188          * Some variables may have special resolution rules. In that case, we
01189          * call their "resolver" procs to get our hands on the variable, and
01190          * we make the compiled local a link to the real variable.
01191          */
01192 
01193     doInitResolvedLocals:
01194         for (; localPtr != NULL; varPtr++, localPtr = localPtr->nextPtr) {
01195             varPtr->flags = 0;
01196             varPtr->value.objPtr = NULL;
01197             
01198             /*
01199              * Now invoke the resolvers to determine the exact variables
01200              * that should be used.
01201              */
01202             
01203             resVarInfo = localPtr->resolveInfo;
01204             if (resVarInfo && resVarInfo->fetchProc) {
01205                 Var *resolvedVarPtr = (Var *)
01206                     (*resVarInfo->fetchProc)(interp, resVarInfo);
01207                 if (resolvedVarPtr) {
01208                     if (TclIsVarInHash(resolvedVarPtr)) {
01209                         VarHashRefCount(resolvedVarPtr)++;
01210                     }
01211                     varPtr->flags = VAR_LINK;
01212                     varPtr->value.linkPtr = resolvedVarPtr;
01213                 }
01214             }
01215         }
01216         return;
01217     }
01218 
01219     /*
01220      * This is the first run after a recompile, or else the resolver epoch
01221      * has changed: update the resolver cache.
01222      */
01223     
01224     firstLocalPtr = localPtr;
01225     for (; localPtr != NULL; localPtr = localPtr->nextPtr) {
01226         if (localPtr->resolveInfo) {
01227             if (localPtr->resolveInfo->deleteProc) {
01228                 localPtr->resolveInfo->deleteProc(localPtr->resolveInfo);
01229             } else {
01230                 ckfree((char *) localPtr->resolveInfo);
01231             }
01232             localPtr->resolveInfo = NULL;
01233         }
01234         localPtr->flags &= ~VAR_RESOLVED;
01235         
01236         if (haveResolvers &&
01237                 !(localPtr->flags & (VAR_ARGUMENT|VAR_TEMPORARY))) {
01238             ResolverScheme *resPtr = iPtr->resolverPtr;
01239             Tcl_ResolvedVarInfo *vinfo;
01240             int result;
01241             
01242             if (nsPtr->compiledVarResProc) {
01243                 result = (*nsPtr->compiledVarResProc)(nsPtr->interp,
01244                         localPtr->name, localPtr->nameLength,
01245                         (Tcl_Namespace *) nsPtr, &vinfo);
01246             } else {
01247                 result = TCL_CONTINUE;
01248             }
01249 
01250             while ((result == TCL_CONTINUE) && resPtr) {
01251                 if (resPtr->compiledVarResProc) {
01252                     result = (*resPtr->compiledVarResProc)(nsPtr->interp,
01253                             localPtr->name, localPtr->nameLength,
01254                             (Tcl_Namespace *) nsPtr, &vinfo);
01255                 }
01256                 resPtr = resPtr->nextPtr;
01257             }
01258             if (result == TCL_OK) {
01259                 localPtr->resolveInfo = vinfo;
01260                 localPtr->flags |= VAR_RESOLVED;
01261             }
01262         }
01263     }
01264     localPtr = firstLocalPtr;
01265     codePtr->flags &= ~TCL_BYTECODE_RESOLVE_VARS;
01266     goto doInitResolvedLocals;
01267 }
01268 
01269 void
01270 TclFreeLocalCache(
01271     Tcl_Interp *interp,
01272     LocalCache *localCachePtr)
01273 {
01274     int i;
01275     Tcl_Obj **namePtrPtr = &localCachePtr->varName0;
01276 
01277     for (i = 0; i < localCachePtr->numVars; i++, namePtrPtr++) {
01278         Tcl_Obj *objPtr = *namePtrPtr;
01279         /*
01280          * Note that this can be called with interp==NULL, on interp 
01281          * deletion. In that case, the literal table and objects go away 
01282          * on their own.
01283          */
01284         if (objPtr) {
01285             if (interp) {
01286                 TclReleaseLiteral(interp, objPtr);
01287             } else {
01288                 Tcl_DecrRefCount(objPtr);
01289             }
01290         }
01291     }
01292     ckfree((char *) localCachePtr);
01293 }
01294 
01295 static void
01296 InitLocalCache(Proc *procPtr)
01297 {
01298     Interp *iPtr = procPtr->iPtr;
01299     ByteCode *codePtr = procPtr->bodyPtr->internalRep.otherValuePtr;
01300     int localCt = procPtr->numCompiledLocals;
01301     int numArgs = procPtr->numArgs, i = 0;
01302 
01303     Tcl_Obj **namePtr;
01304     Var *varPtr;
01305     LocalCache *localCachePtr;
01306     CompiledLocal *localPtr;
01307     int new;
01308 
01309     /*
01310      * Cache the names and initial values of local variables; store the
01311      * cache in both the framePtr for this execution and in the codePtr
01312      * for future calls.
01313      */
01314 
01315     localCachePtr = (LocalCache *) ckalloc(sizeof(LocalCache)
01316             + (localCt-1)*sizeof(Tcl_Obj *)
01317             + numArgs*sizeof(Var));
01318 
01319     namePtr = &localCachePtr->varName0;
01320     varPtr = (Var *) (namePtr + localCt);
01321     localPtr = procPtr->firstLocalPtr;
01322     while (localPtr) {
01323         if (TclIsVarTemporary(localPtr)) {
01324             *namePtr = NULL;
01325         } else {
01326             *namePtr = TclCreateLiteral(iPtr, localPtr->name,
01327                     localPtr->nameLength, /* hash */ (unsigned int) -1,
01328                     &new, /* nsPtr */ NULL, 0, NULL);
01329             Tcl_IncrRefCount(*namePtr);
01330         }
01331 
01332         if (i < numArgs) {
01333             varPtr->flags = (localPtr->flags & VAR_IS_ARGS);
01334             varPtr->value.objPtr = localPtr->defValuePtr;
01335             varPtr++;
01336             i++;
01337         }
01338         namePtr++;
01339         localPtr=localPtr->nextPtr;
01340     }
01341     codePtr->localCachePtr = localCachePtr;
01342     localCachePtr->refCount = 1;
01343     localCachePtr->numVars  = localCt;
01344 }
01345 
01346 static int
01347 InitArgsAndLocals(
01348     register Tcl_Interp *interp,/* Interpreter in which procedure was
01349                                  * invoked. */
01350     Tcl_Obj *procNameObj,       /* Procedure name for error reporting. */
01351     int skip)                   /* Number of initial arguments to be skipped,
01352                                  * i.e., words in the "command name". */
01353 {
01354     CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
01355     register Proc *procPtr = framePtr->procPtr;
01356     ByteCode *codePtr = procPtr->bodyPtr->internalRep.otherValuePtr;
01357     register Var *varPtr, *defPtr;
01358     int localCt = procPtr->numCompiledLocals, numArgs, argCt, i, imax;
01359     Tcl_Obj *const *argObjs;
01360         
01361     /*
01362      * Make sure that the local cache of variable names and initial values has
01363      * been initialised properly .
01364      */
01365 
01366     if (localCt) {
01367         if (!codePtr->localCachePtr) {
01368             InitLocalCache(procPtr) ;
01369         }
01370         framePtr->localCachePtr = codePtr->localCachePtr;
01371         framePtr->localCachePtr->refCount++;
01372         defPtr = (Var *) (&framePtr->localCachePtr->varName0 + localCt);
01373     } else {
01374         defPtr = NULL;
01375     }
01376     
01377     /*
01378      * Create the "compiledLocals" array. Make sure it is large enough to hold
01379      * all the procedure's compiled local variables, including its formal
01380      * parameters.
01381      */
01382 
01383     varPtr = (Var*) TclStackAlloc(interp, (int)(localCt*sizeof(Var)));
01384     framePtr->compiledLocals = varPtr;
01385     framePtr->numCompiledLocals = localCt;
01386 
01387     /*
01388      * Match and assign the call's actual parameters to the procedure's formal
01389      * arguments. The formal arguments are described by the first numArgs
01390      * entries in both the Proc structure's local variable list and the call
01391      * frame's local variable array.
01392      */
01393 
01394     numArgs = procPtr->numArgs;
01395     argCt = framePtr->objc - skip;      /* Set it to the number of args to the
01396                                          * procedure. */
01397     argObjs = framePtr->objv + skip;
01398     if (numArgs == 0) {
01399         if (argCt) {
01400             goto incorrectArgs;
01401         } else {
01402             goto correctArgs;
01403         }
01404     }
01405     imax = ((argCt < numArgs-1) ? argCt : numArgs-1);
01406     for (i = 0; i < imax; i++, varPtr++, defPtr++) {
01407         /*
01408          * "Normal" arguments; last formal is special, depends on it being
01409          * 'args'.
01410          */
01411 
01412         Tcl_Obj *objPtr = argObjs[i];
01413 
01414         varPtr->flags = 0;
01415         varPtr->value.objPtr = objPtr;
01416         Tcl_IncrRefCount(objPtr);       /* Local var is a reference. */
01417     }
01418     for (; i < numArgs-1; i++, varPtr++, defPtr++) {
01419         /*
01420          * This loop is entered if argCt < (numArgs-1). Set default values;
01421          * last formal is special.
01422          */
01423 
01424         Tcl_Obj *objPtr = defPtr->value.objPtr;
01425 
01426         if (objPtr) {
01427             varPtr->flags = 0;
01428             varPtr->value.objPtr = objPtr;
01429             Tcl_IncrRefCount(objPtr);   /* Local var reference. */
01430         } else {
01431             goto incorrectArgs;
01432         }
01433     }
01434 
01435     /*
01436      * When we get here, the last formal argument remains to be defined:
01437      * defPtr and varPtr point to the last argument to be initialized.
01438      */
01439 
01440 
01441     varPtr->flags = 0;
01442     if (defPtr->flags & VAR_IS_ARGS) {
01443         Tcl_Obj *listPtr = Tcl_NewListObj(argCt-i, argObjs+i);
01444 
01445         varPtr->value.objPtr = listPtr;
01446         Tcl_IncrRefCount(listPtr);      /* Local var is a reference. */
01447     } else if (argCt == numArgs) {
01448         Tcl_Obj *objPtr = argObjs[i];
01449 
01450         varPtr->value.objPtr = objPtr;
01451         Tcl_IncrRefCount(objPtr);       /* Local var is a reference. */
01452     } else if ((argCt < numArgs) && (defPtr->value.objPtr != NULL)) {
01453         Tcl_Obj *objPtr = defPtr->value.objPtr;
01454 
01455         varPtr->value.objPtr = objPtr;
01456         Tcl_IncrRefCount(objPtr);       /* Local var is a reference. */
01457     } else {
01458         goto incorrectArgs;
01459     }
01460     varPtr++;
01461 
01462     /*
01463      * Initialise and resolve the remaining compiledLocals. In the absence of
01464      * resolvers, they are undefined local vars: (flags=0, value=NULL).
01465      */
01466 
01467   correctArgs:
01468     if (numArgs < localCt) {
01469         if (!framePtr->nsPtr->compiledVarResProc && !((Interp *)interp)->resolverPtr) {
01470             memset(varPtr, 0, (localCt - numArgs)*sizeof(Var));
01471         } else {
01472             InitResolvedLocals(interp, codePtr, varPtr, framePtr->nsPtr);
01473         }
01474     }
01475 
01476     return TCL_OK;
01477 
01478 
01479     incorrectArgs:
01480     /*
01481      * Initialise all compiled locals to avoid problems at DeleteLocalVars.
01482      */
01483 
01484     memset(varPtr, 0, ((framePtr->compiledLocals + localCt)-varPtr)*sizeof(Var));
01485     return ProcWrongNumArgs(interp, skip);
01486 }
01487 
01488 /*
01489  *----------------------------------------------------------------------
01490  *
01491  * PushProcCallFrame --
01492  *
01493  *      Compiles a proc body if necessary, then pushes a CallFrame suitable
01494  *      for executing it.
01495  *
01496  * Results:
01497  *      A standard Tcl object result value.
01498  *
01499  * Side effects:
01500  *      The proc's body may be recompiled. A CallFrame is pushed, it will have
01501  *      to be popped by the caller.
01502  *
01503  *----------------------------------------------------------------------
01504  */
01505 
01506 static int
01507 PushProcCallFrame(
01508     ClientData clientData,      /* Record describing procedure to be
01509                                  * interpreted. */
01510     register Tcl_Interp *interp,/* Interpreter in which procedure was
01511                                  * invoked. */
01512     int objc,                   /* Count of number of arguments to this
01513                                  * procedure. */
01514     Tcl_Obj *CONST objv[],      /* Argument value objects. */
01515     int isLambda)               /* 1 if this is a call by ApplyObjCmd: it
01516                                  * needs special rules for error msg */
01517 {
01518     Proc *procPtr = (Proc *) clientData;
01519     Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
01520     CallFrame *framePtr, **framePtrPtr;
01521     int result;
01522     ByteCode *codePtr;
01523 
01524     /*
01525      * If necessary (i.e. if we haven't got a suitable compilation already
01526      * cached) compile the procedure's body. The compiler will allocate frame
01527      * slots for the procedure's non-argument local variables. Note that
01528      * compiling the body might increase procPtr->numCompiledLocals if new
01529      * local variables are found while compiling.
01530      */
01531 
01532     if (procPtr->bodyPtr->typePtr == &tclByteCodeType) {
01533         Interp *iPtr = (Interp *) interp;
01534 
01535         /*
01536          * When we've got bytecode, this is the check for validity. That is,
01537          * the bytecode must be for the right interpreter (no cross-leaks!),
01538          * the code must be from the current epoch (so subcommand compilation
01539          * is up-to-date), the namespace must match (so variable handling
01540          * is right) and the resolverEpoch must match (so that new shadowed
01541          * commands and/or resolver changes are considered).
01542          */
01543 
01544         codePtr = procPtr->bodyPtr->internalRep.otherValuePtr;
01545         if (((Interp *) *codePtr->interpHandle != iPtr)
01546                 || (codePtr->compileEpoch != iPtr->compileEpoch)
01547                 || (codePtr->nsPtr != nsPtr)
01548                 || (codePtr->nsEpoch != nsPtr->resolverEpoch)) {
01549             goto doCompilation;
01550         }
01551     } else {
01552     doCompilation:
01553         result = ProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr,
01554                 (isLambda ? "body of lambda term" : "body of proc"),
01555                 TclGetString(objv[isLambda]), &procPtr);
01556         if (result != TCL_OK) {
01557             return result;
01558         }
01559     }
01560 
01561     /*
01562      * Set up and push a new call frame for the new procedure invocation.
01563      * This call frame will execute in the proc's namespace, which might be
01564      * different than the current namespace. The proc's namespace is that of
01565      * its command, which can change if the command is renamed from one
01566      * namespace to another.
01567      */
01568 
01569     framePtrPtr = &framePtr;
01570     result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
01571             (Tcl_Namespace *) nsPtr,
01572             (isLambda? (FRAME_IS_PROC|FRAME_IS_LAMBDA) : FRAME_IS_PROC));
01573     if (result != TCL_OK) {
01574         return result;
01575     }
01576 
01577     framePtr->objc = objc;
01578     framePtr->objv = objv;
01579     framePtr->procPtr = procPtr;
01580 
01581     return TCL_OK;
01582 }
01583 
01584 /*
01585  *----------------------------------------------------------------------
01586  *
01587  * TclObjInterpProc --
01588  *
01589  *      When a Tcl procedure gets invoked during bytecode evaluation, this
01590  *      object-based routine gets invoked to interpret the procedure.
01591  *
01592  * Results:
01593  *      A standard Tcl object result value.
01594  *
01595  * Side effects:
01596  *      Depends on the commands in the procedure.
01597  *
01598  *----------------------------------------------------------------------
01599  */
01600 
01601 int
01602 TclObjInterpProc(
01603     ClientData clientData,      /* Record describing procedure to be
01604                                  * interpreted. */
01605     register Tcl_Interp *interp,/* Interpreter in which procedure was
01606                                  * invoked. */
01607     int objc,                   /* Count of number of arguments to this
01608                                  * procedure. */
01609     Tcl_Obj *CONST objv[])      /* Argument value objects. */
01610 {
01611     int result;
01612 
01613     result = PushProcCallFrame(clientData, interp, objc, objv, /*isLambda*/ 0);
01614     if (result == TCL_OK) {
01615         return TclObjInterpProcCore(interp, objv[0], 1, &MakeProcError);
01616     } else {
01617         return TCL_ERROR;
01618     }
01619 }
01620 
01621 /*
01622  *----------------------------------------------------------------------
01623  *
01624  * TclObjInterpProcCore --
01625  *
01626  *      When a Tcl procedure, lambda term or anything else that works like a
01627  *      procedure gets invoked during bytecode evaluation, this object-based
01628  *      routine gets invoked to interpret the body.
01629  *
01630  * Results:
01631  *      A standard Tcl object result value.
01632  *
01633  * Side effects:
01634  *      Nearly anything; depends on the commands in the procedure body.
01635  *
01636  *----------------------------------------------------------------------
01637  */
01638 
01639 int
01640 TclObjInterpProcCore(
01641     register Tcl_Interp *interp,/* Interpreter in which procedure was
01642                                  * invoked. */
01643     Tcl_Obj *procNameObj,       /* Procedure name for error reporting. */
01644     int skip,                   /* Number of initial arguments to be skipped,
01645                                  * i.e., words in the "command name". */
01646     ProcErrorProc errorProc)    /* How to convert results from the script into
01647                                  * results of the overall procedure. */
01648 {
01649     Interp *iPtr = (Interp *) interp;
01650     register Proc *procPtr = iPtr->varFramePtr->procPtr;
01651     int result;
01652     CallFrame *freePtr;
01653 
01654     result = InitArgsAndLocals(interp, procNameObj, skip);
01655     if (result != TCL_OK) {
01656         goto procDone;
01657     }
01658 
01659 #if defined(TCL_COMPILE_DEBUG)
01660     if (tclTraceExec >= 1) {
01661         register CallFrame *framePtr = iPtr->varFramePtr;
01662         register int i;
01663 
01664         if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) {
01665             fprintf(stdout, "Calling lambda ");
01666         } else {
01667             fprintf(stdout, "Calling proc ");
01668         }
01669         for (i = 0; i < framePtr->objc; i++) {
01670             TclPrintObject(stdout, framePtr->objv[i], 15);
01671             fprintf(stdout, " ");
01672         }
01673         fprintf(stdout, "\n");
01674         fflush(stdout);
01675     }
01676 #endif /*TCL_COMPILE_DEBUG*/
01677 
01678     if (TCL_DTRACE_PROC_ARGS_ENABLED()) {
01679         char *a[10];
01680         int i = 0;
01681         int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
01682 
01683         while (i < 10) {
01684             a[i] = (l < iPtr->varFramePtr->objc ? 
01685                     TclGetString(iPtr->varFramePtr->objv[l]) : NULL); i++; l++;
01686         }
01687         TCL_DTRACE_PROC_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7],
01688                 a[8], a[9]);
01689     }
01690     if (TCL_DTRACE_PROC_INFO_ENABLED() && iPtr->cmdFramePtr) {
01691         Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr);
01692         char *a[4]; int i[2];
01693         
01694         TclDTraceInfo(info, a, i);
01695         TCL_DTRACE_PROC_INFO(a[0], a[1], a[2], a[3], i[0], i[1]);
01696         TclDecrRefCount(info);
01697     }
01698 
01699     /*
01700      * Invoke the commands in the procedure's body.
01701      */
01702 
01703     procPtr->refCount++;
01704     iPtr->numLevels++;
01705 
01706     if (TclInterpReady(interp) == TCL_ERROR) {
01707         result = TCL_ERROR;
01708     } else {
01709         register ByteCode *codePtr =
01710                 procPtr->bodyPtr->internalRep.otherValuePtr;
01711 
01712         codePtr->refCount++;
01713         if (TCL_DTRACE_PROC_ENTRY_ENABLED()) {
01714             int l;
01715             
01716             l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 2 : 1;
01717             TCL_DTRACE_PROC_ENTRY(TclGetString(procNameObj),
01718                     iPtr->varFramePtr->objc - l,
01719                     (Tcl_Obj **)(iPtr->varFramePtr->objv + l));
01720         }
01721         result = TclExecuteByteCode(interp, codePtr);
01722         if (TCL_DTRACE_PROC_RETURN_ENABLED()) {
01723             TCL_DTRACE_PROC_RETURN(TclGetString(procNameObj), result);
01724         }
01725         codePtr->refCount--;
01726         if (codePtr->refCount <= 0) {
01727             TclCleanupByteCode(codePtr);
01728         }
01729     }
01730 
01731     iPtr->numLevels--;
01732     procPtr->refCount--;
01733     if (procPtr->refCount <= 0) {
01734         TclProcCleanupProc(procPtr);
01735     }
01736 
01737     /*
01738      * Process the result code.
01739      */
01740 
01741     switch (result) {
01742     case TCL_RETURN:
01743         /*
01744          * If it is a 'return', do the TIP#90 processing now.
01745          */
01746 
01747         result = TclUpdateReturnInfo((Interp *) interp);
01748         break;
01749 
01750     case TCL_CONTINUE:
01751     case TCL_BREAK:
01752         /*
01753          * It's an error to get to this point from a 'break' or 'continue', so
01754          * transform to an error now.
01755          */
01756 
01757         Tcl_ResetResult(interp);
01758         Tcl_AppendResult(interp, "invoked \"",
01759                 ((result == TCL_BREAK) ? "break" : "continue"),
01760                 "\" outside of a loop", NULL);
01761         result = TCL_ERROR;
01762 
01763         /*
01764          * Fall through to the TCL_ERROR handling code.
01765          */
01766 
01767     case TCL_ERROR:
01768         /*
01769          * Now it _must_ be an error, so we need to log it as such. This means
01770          * filling out the error trace. Luckily, we just hand this off to the
01771          * function handed to us as an argument.
01772          */
01773 
01774         (*errorProc)(interp, procNameObj);
01775 
01776     default:
01777         /*
01778          * Process other results (OK and non-standard) by doing nothing
01779          * special, skipping directly to the code afterwards that cleans up
01780          * associated memory.
01781          *
01782          * Non-standard results are processed by passing them through quickly.
01783          * This means they all work as exceptions, unwinding the stack quickly
01784          * and neatly. Who knows how well they are handled by third-party code
01785          * though...
01786          */
01787 
01788         (void) 0;               /* do nothing */
01789     }
01790 
01791     if (TCL_DTRACE_PROC_RESULT_ENABLED()) {
01792         Tcl_Obj *r;
01793 
01794         r = Tcl_GetObjResult(interp);
01795         TCL_DTRACE_PROC_RESULT(TclGetString(procNameObj), result,
01796                 TclGetString(r), r);
01797     }
01798 
01799   procDone:
01800     /*
01801      * Free the stack-allocated compiled locals and CallFrame. It is important
01802      * to pop the call frame without freeing it first: the compiledLocals
01803      * cannot be freed before the frame is popped, as the local variables must
01804      * be deleted. But the compiledLocals must be freed first, as they were
01805      * allocated later on the stack.
01806      */
01807 
01808     freePtr = iPtr->framePtr;
01809     Tcl_PopCallFrame(interp);           /* Pop but do not free. */
01810     TclStackFree(interp, freePtr->compiledLocals);
01811                                         /* Free compiledLocals. */
01812     TclStackFree(interp, freePtr);      /* Free CallFrame. */
01813     return result;
01814 }
01815 
01816 /*
01817  *----------------------------------------------------------------------
01818  *
01819  * TclProcCompileProc --
01820  *
01821  *      Called just before a procedure is executed to compile the body to byte
01822  *      codes. If the type of the body is not "byte code" or if the compile
01823  *      conditions have changed (namespace context, epoch counters, etc.) then
01824  *      the body is recompiled. Otherwise, this function does nothing.
01825  *
01826  * Results:
01827  *      None.
01828  *
01829  * Side effects:
01830  *      May change the internal representation of the body object to compiled
01831  *      code.
01832  *
01833  *----------------------------------------------------------------------
01834  */
01835 
01836 int
01837 TclProcCompileProc(
01838     Tcl_Interp *interp,         /* Interpreter containing procedure. */
01839     Proc *procPtr,              /* Data associated with procedure. */
01840     Tcl_Obj *bodyPtr,           /* Body of proc. (Usually procPtr->bodyPtr,
01841                                  * but could be any code fragment compiled in
01842                                  * the context of this procedure.) */
01843     Namespace *nsPtr,           /* Namespace containing procedure. */
01844     CONST char *description,    /* string describing this body of code. */
01845     CONST char *procName)       /* Name of this procedure. */
01846 {
01847     return ProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description,
01848             procName, NULL);
01849 }
01850 
01851 static int
01852 ProcCompileProc(
01853     Tcl_Interp *interp,         /* Interpreter containing procedure. */
01854     Proc *procPtr,              /* Data associated with procedure. */
01855     Tcl_Obj *bodyPtr,           /* Body of proc. (Usually procPtr->bodyPtr,
01856                                  * but could be any code fragment compiled in
01857                                  * the context of this procedure.) */
01858     Namespace *nsPtr,           /* Namespace containing procedure. */
01859     CONST char *description,    /* string describing this body of code. */
01860     CONST char *procName,       /* Name of this procedure. */
01861     Proc **procPtrPtr)          /* Points to storage where a replacement
01862                                  * (Proc *) value may be written. */
01863 {
01864     Interp *iPtr = (Interp *) interp;
01865     int i;
01866     Tcl_CallFrame *framePtr;
01867     Proc *saveProcPtr;
01868     ByteCode *codePtr = bodyPtr->internalRep.otherValuePtr;
01869     CompiledLocal *localPtr;
01870 
01871     /*
01872      * If necessary, compile the procedure's body. The compiler will allocate
01873      * frame slots for the procedure's non-argument local variables. If the
01874      * ByteCode already exists, make sure it hasn't been invalidated by
01875      * someone redefining a core command (this might make the compiled code
01876      * wrong). Also, if the code was compiled in/for a different interpreter,
01877      * we recompile it. Note that compiling the body might increase
01878      * procPtr->numCompiledLocals if new local variables are found while
01879      * compiling.
01880      *
01881      * Precompiled procedure bodies, however, are immutable and therefore they
01882      * are not recompiled, even if things have changed.
01883      */
01884 
01885     if (bodyPtr->typePtr == &tclByteCodeType) {
01886         if (((Interp *) *codePtr->interpHandle == iPtr)
01887                 && (codePtr->compileEpoch == iPtr->compileEpoch)
01888                 && (codePtr->nsPtr == nsPtr)
01889                 && (codePtr->nsEpoch == nsPtr->resolverEpoch)) {
01890             return TCL_OK;
01891         } else {
01892             if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
01893                 if ((Interp *) *codePtr->interpHandle != iPtr) {
01894                     Tcl_AppendResult(interp,
01895                             "a precompiled script jumped interps", NULL);
01896                     return TCL_ERROR;
01897                 }
01898                 codePtr->compileEpoch = iPtr->compileEpoch;
01899                 codePtr->nsPtr = nsPtr;
01900             } else {
01901                 bodyPtr->typePtr->freeIntRepProc(bodyPtr);
01902                 bodyPtr->typePtr = NULL;
01903             }
01904         }
01905     }
01906     if (bodyPtr->typePtr != &tclByteCodeType) {
01907         Tcl_HashEntry *hePtr;
01908 
01909 #ifdef TCL_COMPILE_DEBUG
01910         if (tclTraceCompile >= 1) {
01911             /*
01912              * Display a line summarizing the top level command we are about
01913              * to compile.
01914              */
01915 
01916             Tcl_Obj *message;
01917 
01918             TclNewLiteralStringObj(message, "Compiling ");
01919             Tcl_IncrRefCount(message);
01920             Tcl_AppendStringsToObj(message, description, " \"", NULL);
01921             Tcl_AppendLimitedToObj(message, procName, -1, 50, NULL);
01922             fprintf(stdout, "%s\"\n", TclGetString(message));
01923             Tcl_DecrRefCount(message);
01924         }
01925 #endif
01926 
01927         /*
01928          * Plug the current procPtr into the interpreter and coerce the code
01929          * body to byte codes. The interpreter needs to know which proc it's
01930          * compiling so that it can access its list of compiled locals.
01931          *
01932          * TRICKY NOTE: Be careful to push a call frame with the proper
01933          *   namespace context, so that the byte codes are compiled in the
01934          *   appropriate class context.
01935          */
01936 
01937         saveProcPtr = iPtr->compiledProcPtr;
01938 
01939         if (procPtrPtr != NULL && procPtr->refCount > 1) {
01940             Tcl_Command token;
01941             Tcl_CmdInfo info;
01942             Proc *newProc = (Proc *) ckalloc(sizeof(Proc));
01943 
01944             newProc->iPtr = procPtr->iPtr;
01945             newProc->refCount = 1;
01946             newProc->cmdPtr = procPtr->cmdPtr;
01947             token = (Tcl_Command) newProc->cmdPtr;
01948             newProc->bodyPtr = Tcl_DuplicateObj(bodyPtr);
01949             bodyPtr = newProc->bodyPtr;
01950             Tcl_IncrRefCount(bodyPtr);
01951             newProc->numArgs = procPtr->numArgs;
01952 
01953             newProc->numCompiledLocals = newProc->numArgs;
01954             newProc->firstLocalPtr = NULL;
01955             newProc->lastLocalPtr = NULL;
01956             localPtr = procPtr->firstLocalPtr;
01957             for (i=0; i<newProc->numArgs; i++, localPtr=localPtr->nextPtr) {
01958                 CompiledLocal *copy = (CompiledLocal *) ckalloc((unsigned)
01959                         (sizeof(CompiledLocal) - sizeof(localPtr->name)
01960                         + localPtr->nameLength + 1));
01961 
01962                 if (newProc->firstLocalPtr == NULL) {
01963                     newProc->firstLocalPtr = newProc->lastLocalPtr = copy;
01964                 } else {
01965                     newProc->lastLocalPtr->nextPtr = copy;
01966                     newProc->lastLocalPtr = copy;
01967                 }
01968                 copy->nextPtr = NULL;
01969                 copy->nameLength = localPtr->nameLength;
01970                 copy->frameIndex = localPtr->frameIndex;
01971                 copy->flags = localPtr->flags;
01972                 copy->defValuePtr = localPtr->defValuePtr;
01973                 if (copy->defValuePtr) {
01974                     Tcl_IncrRefCount(copy->defValuePtr);
01975                 }
01976                 copy->resolveInfo = localPtr->resolveInfo;
01977                 strcpy(copy->name, localPtr->name);
01978             }
01979 
01980             /*
01981              * Reset the ClientData
01982              */
01983 
01984             Tcl_GetCommandInfoFromToken(token, &info);
01985             if (info.objClientData == (ClientData) procPtr) {
01986                 info.objClientData = (ClientData) newProc;
01987             }
01988             if (info.clientData == (ClientData) procPtr) {
01989                 info.clientData = (ClientData) newProc;
01990             }
01991             if (info.deleteData == (ClientData) procPtr) {
01992                 info.deleteData = (ClientData) newProc;
01993             }
01994             Tcl_SetCommandInfoFromToken(token, &info);
01995 
01996             procPtr->refCount--;
01997             *procPtrPtr = procPtr = newProc;
01998         }
01999         iPtr->compiledProcPtr = procPtr;
02000 
02001         (void) TclPushStackFrame(interp, &framePtr,
02002                 (Tcl_Namespace *) nsPtr, /* isProcCallFrame */ 0);
02003 
02004         /*
02005          * TIP #280: We get the invoking context from the cmdFrame which
02006          * was saved by 'Tcl_ProcObjCmd' (using linePBodyPtr).
02007          */
02008 
02009         hePtr = Tcl_FindHashEntry(iPtr->linePBodyPtr, (char *) procPtr);
02010 
02011         /*
02012          * Constructed saved frame has body as word 0. See Tcl_ProcObjCmd.
02013          */
02014 
02015         iPtr->invokeWord = 0;
02016         iPtr->invokeCmdFramePtr =
02017                 (hePtr ? (CmdFrame *) Tcl_GetHashValue(hePtr) : NULL);
02018         (void) tclByteCodeType.setFromAnyProc(interp, bodyPtr);
02019         iPtr->invokeCmdFramePtr = NULL;
02020         TclPopStackFrame(interp);
02021         iPtr->compiledProcPtr = saveProcPtr;
02022     } else if (codePtr->nsEpoch != nsPtr->resolverEpoch) {
02023         /*
02024          * The resolver epoch has changed, but we only need to invalidate the
02025          * resolver cache.
02026          */
02027 
02028         codePtr->nsEpoch = nsPtr->resolverEpoch;
02029         codePtr->flags |= TCL_BYTECODE_RESOLVE_VARS;
02030     }
02031     return TCL_OK;
02032 }
02033 
02034 /*
02035  *----------------------------------------------------------------------
02036  *
02037  * MakeProcError --
02038  *
02039  *      Function called by TclObjInterpProc to create the stack information
02040  *      upon an error from a procedure.
02041  *
02042  * Results:
02043  *      The interpreter's error info trace is set to a value that supplements
02044  *      the error code.
02045  *
02046  * Side effects:
02047  *      none.
02048  *
02049  *----------------------------------------------------------------------
02050  */
02051 
02052 static void
02053 MakeProcError(
02054     Tcl_Interp *interp,         /* The interpreter in which the procedure was
02055                                  * called. */
02056     Tcl_Obj *procNameObj)       /* Name of the procedure. Used for error
02057                                  * messages and trace information. */
02058 {
02059     int overflow, limit = 60, nameLen;
02060     const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen);
02061 
02062     overflow = (nameLen > limit);
02063     Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
02064             "\n    (procedure \"%.*s%s\" line %d)",
02065             (overflow ? limit : nameLen), procName,
02066             (overflow ? "..." : ""), interp->errorLine));
02067 }
02068 
02069 /*
02070  *----------------------------------------------------------------------
02071  *
02072  * TclProcDeleteProc --
02073  *
02074  *      This function is invoked just before a command procedure is removed
02075  *      from an interpreter. Its job is to release all the resources allocated
02076  *      to the procedure.
02077  *
02078  * Results:
02079  *      None.
02080  *
02081  * Side effects:
02082  *      Memory gets freed, unless the procedure is actively being executed.
02083  *      In this case the cleanup is delayed until the last call to the current
02084  *      procedure completes.
02085  *
02086  *----------------------------------------------------------------------
02087  */
02088 
02089 void
02090 TclProcDeleteProc(
02091     ClientData clientData)      /* Procedure to be deleted. */
02092 {
02093     Proc *procPtr = (Proc *) clientData;
02094 
02095     procPtr->refCount--;
02096     if (procPtr->refCount <= 0) {
02097         TclProcCleanupProc(procPtr);
02098     }
02099 }
02100 
02101 /*
02102  *----------------------------------------------------------------------
02103  *
02104  * TclProcCleanupProc --
02105  *
02106  *      This function does all the real work of freeing up a Proc structure.
02107  *      It's called only when the structure's reference count becomes zero.
02108  *
02109  * Results:
02110  *      None.
02111  *
02112  * Side effects:
02113  *      Memory gets freed.
02114  *
02115  *----------------------------------------------------------------------
02116  */
02117 
02118 void
02119 TclProcCleanupProc(
02120     register Proc *procPtr)     /* Procedure to be deleted. */
02121 {
02122     register CompiledLocal *localPtr;
02123     Tcl_Obj *bodyPtr = procPtr->bodyPtr;
02124     Tcl_Obj *defPtr;
02125     Tcl_ResolvedVarInfo *resVarInfo;
02126     Tcl_HashEntry *hePtr = NULL;
02127     CmdFrame *cfPtr = NULL;
02128     Interp *iPtr = procPtr->iPtr;
02129 
02130     if (bodyPtr != NULL) {
02131         Tcl_DecrRefCount(bodyPtr);
02132     }
02133     for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; ) {
02134         CompiledLocal *nextPtr = localPtr->nextPtr;
02135 
02136         resVarInfo = localPtr->resolveInfo;
02137         if (resVarInfo) {
02138             if (resVarInfo->deleteProc) {
02139                 (*resVarInfo->deleteProc)(resVarInfo);
02140             } else {
02141                 ckfree((char *) resVarInfo);
02142             }
02143         }
02144 
02145         if (localPtr->defValuePtr != NULL) {
02146             defPtr = localPtr->defValuePtr;
02147             Tcl_DecrRefCount(defPtr);
02148         }
02149         ckfree((char *) localPtr);
02150         localPtr = nextPtr;
02151     }
02152     ckfree((char *) procPtr);
02153 
02154     /*
02155      * TIP #280: Release the location data associated with this Proc
02156      * structure, if any. The interpreter may not exist (For example for
02157      * procbody structurues created by tbcload.
02158      */
02159 
02160     if (!iPtr) {
02161         return;
02162     }
02163 
02164     hePtr = Tcl_FindHashEntry(iPtr->linePBodyPtr, (char *) procPtr);
02165     if (!hePtr) {
02166         return;
02167     }
02168 
02169     cfPtr = (CmdFrame *) Tcl_GetHashValue(hePtr);
02170 
02171     if (cfPtr->type == TCL_LOCATION_SOURCE) {
02172         Tcl_DecrRefCount(cfPtr->data.eval.path);
02173         cfPtr->data.eval.path = NULL;
02174     }
02175     ckfree((char *) cfPtr->line);
02176     cfPtr->line = NULL;
02177     ckfree((char *) cfPtr);
02178     Tcl_DeleteHashEntry(hePtr);
02179 }
02180 
02181 /*
02182  *----------------------------------------------------------------------
02183  *
02184  * TclUpdateReturnInfo --
02185  *
02186  *      This function is called when procedures return, and at other points
02187  *      where the TCL_RETURN code is used. It examines the returnLevel and
02188  *      returnCode to determine the real return status.
02189  *
02190  * Results:
02191  *      The return value is the true completion code to use for the procedure
02192  *      or script, instead of TCL_RETURN.
02193  *
02194  * Side effects:
02195  *      None.
02196  *
02197  *----------------------------------------------------------------------
02198  */
02199 
02200 int
02201 TclUpdateReturnInfo(
02202     Interp *iPtr)               /* Interpreter for which TCL_RETURN exception
02203                                  * is being processed. */
02204 {
02205     int code = TCL_RETURN;
02206 
02207     iPtr->returnLevel--;
02208     if (iPtr->returnLevel < 0) {
02209         Tcl_Panic("TclUpdateReturnInfo: negative return level");
02210     }
02211     if (iPtr->returnLevel == 0) {
02212         /*
02213          * Now we've reached the level to return the requested -code.
02214          */
02215 
02216         code = iPtr->returnCode;
02217         if (code == TCL_ERROR) {
02218             iPtr->flags |= ERR_LEGACY_COPY;
02219         }
02220     }
02221     return code;
02222 }
02223 
02224 /*
02225  *----------------------------------------------------------------------
02226  *
02227  * TclGetObjInterpProc --
02228  *
02229  *      Returns a pointer to the TclObjInterpProc function; this is different
02230  *      from the value obtained from the TclObjInterpProc reference on systems
02231  *      like Windows where import and export versions of a function exported
02232  *      by a DLL exist.
02233  *
02234  * Results:
02235  *      Returns the internal address of the TclObjInterpProc function.
02236  *
02237  * Side effects:
02238  *      None.
02239  *
02240  *----------------------------------------------------------------------
02241  */
02242 
02243 TclObjCmdProcType
02244 TclGetObjInterpProc(void)
02245 {
02246     return (TclObjCmdProcType) TclObjInterpProc;
02247 }
02248 
02249 /*
02250  *----------------------------------------------------------------------
02251  *
02252  * TclNewProcBodyObj --
02253  *
02254  *      Creates a new object, of type "procbody", whose internal
02255  *      representation is the given Proc struct. The newly created object's
02256  *      reference count is 0.
02257  *
02258  * Results:
02259  *      Returns a pointer to a newly allocated Tcl_Obj, NULL on error.
02260  *
02261  * Side effects:
02262  *      The reference count in the ByteCode attached to the Proc is bumped up
02263  *      by one, since the internal rep stores a pointer to it.
02264  *
02265  *----------------------------------------------------------------------
02266  */
02267 
02268 Tcl_Obj *
02269 TclNewProcBodyObj(
02270     Proc *procPtr)              /* the Proc struct to store as the internal
02271                                  * representation. */
02272 {
02273     Tcl_Obj *objPtr;
02274 
02275     if (!procPtr) {
02276         return NULL;
02277     }
02278 
02279     TclNewObj(objPtr);
02280     if (objPtr) {
02281         objPtr->typePtr = &tclProcBodyType;
02282         objPtr->internalRep.otherValuePtr = procPtr;
02283 
02284         procPtr->refCount++;
02285     }
02286 
02287     return objPtr;
02288 }
02289 
02290 /*
02291  *----------------------------------------------------------------------
02292  *
02293  * ProcBodyDup --
02294  *
02295  *      Tcl_ObjType's Dup function for the proc body object. Bumps the
02296  *      reference count on the Proc stored in the internal representation.
02297  *
02298  * Results:
02299  *      None.
02300  *
02301  * Side effects:
02302  *      Sets up the object in dupPtr to be a duplicate of the one in srcPtr.
02303  *
02304  *----------------------------------------------------------------------
02305  */
02306 
02307 static void
02308 ProcBodyDup(
02309     Tcl_Obj *srcPtr,            /* Object to copy. */
02310     Tcl_Obj *dupPtr)            /* Target object for the duplication. */
02311 {
02312     Proc *procPtr = srcPtr->internalRep.otherValuePtr;
02313 
02314     dupPtr->typePtr = &tclProcBodyType;
02315     dupPtr->internalRep.otherValuePtr = procPtr;
02316     procPtr->refCount++;
02317 }
02318 
02319 /*
02320  *----------------------------------------------------------------------
02321  *
02322  * ProcBodyFree --
02323  *
02324  *      Tcl_ObjType's Free function for the proc body object. The reference
02325  *      count on its Proc struct is decreased by 1; if the count reaches 0,
02326  *      the proc is freed.
02327  *
02328  * Results:
02329  *      None.
02330  *
02331  * Side effects:
02332  *      If the reference count on the Proc struct reaches 0, the struct is
02333  *      freed.
02334  *
02335  *----------------------------------------------------------------------
02336  */
02337 
02338 static void
02339 ProcBodyFree(
02340     Tcl_Obj *objPtr)            /* The object to clean up. */
02341 {
02342     Proc *procPtr = objPtr->internalRep.otherValuePtr;
02343 
02344     procPtr->refCount--;
02345     if (procPtr->refCount <= 0) {
02346         TclProcCleanupProc(procPtr);
02347     }
02348 }
02349 
02350 /*
02351  *----------------------------------------------------------------------
02352  *
02353  * DupLambdaInternalRep, FreeLambdaInternalRep, SetLambdaFromAny --
02354  *
02355  *      How to manage the internal representations of lambda term objects.
02356  *      Syntactically they look like a two- or three-element list, where the
02357  *      first element is the formal arguments, the second is the the body, and
02358  *      the (optional) third is the namespace to execute the lambda term
02359  *      within (the global namespace is assumed if it is absent).
02360  *
02361  *----------------------------------------------------------------------
02362  */
02363 
02364 static void
02365 DupLambdaInternalRep(
02366     Tcl_Obj *srcPtr,            /* Object with internal rep to copy. */
02367     register Tcl_Obj *copyPtr)  /* Object with internal rep to set. */
02368 {
02369     Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1;
02370     Tcl_Obj *nsObjPtr = srcPtr->internalRep.twoPtrValue.ptr2;
02371 
02372     copyPtr->internalRep.twoPtrValue.ptr1 = procPtr;
02373     copyPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr;
02374 
02375     procPtr->refCount++;
02376     Tcl_IncrRefCount(nsObjPtr);
02377     copyPtr->typePtr = &lambdaType;
02378 }
02379 
02380 static void
02381 FreeLambdaInternalRep(
02382     register Tcl_Obj *objPtr)   /* CmdName object with internal representation
02383                                  * to free. */
02384 {
02385     Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1;
02386     Tcl_Obj *nsObjPtr = objPtr->internalRep.twoPtrValue.ptr2;
02387 
02388     procPtr->refCount--;
02389     if (procPtr->refCount == 0) {
02390         TclProcCleanupProc(procPtr);
02391     }
02392     TclDecrRefCount(nsObjPtr);
02393 }
02394 
02395 static int
02396 SetLambdaFromAny(
02397     Tcl_Interp *interp,         /* Used for error reporting if not NULL. */
02398     register Tcl_Obj *objPtr)   /* The object to convert. */
02399 {
02400     Interp *iPtr = (Interp *) interp;
02401     char *name;
02402     Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv, *errPtr;
02403     int objc, result;
02404     Proc *procPtr;
02405 
02406     /*
02407      * Convert objPtr to list type first; if it cannot be converted, or if its
02408      * length is not 2, then it cannot be converted to lambdaType.
02409      */
02410 
02411     result = TclListObjGetElements(interp, objPtr, &objc, &objv);
02412     if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) {
02413         TclNewLiteralStringObj(errPtr, "can't interpret \"");
02414         Tcl_AppendObjToObj(errPtr, objPtr);
02415         Tcl_AppendToObj(errPtr, "\" as a lambda expression", -1);
02416         Tcl_SetObjResult(interp, errPtr);
02417         return TCL_ERROR;
02418     }
02419 
02420     argsPtr = objv[0];
02421     bodyPtr = objv[1];
02422 
02423     /*
02424      * Create and initialize the Proc struct. The cmdPtr field is set to NULL
02425      * to signal that this is an anonymous function.
02426      */
02427 
02428     name = TclGetString(objPtr);
02429 
02430     if (TclCreateProc(interp, /*ignored nsPtr*/ NULL, name, argsPtr, bodyPtr,
02431             &procPtr) != TCL_OK) {
02432         Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
02433                 "\n    (parsing lambda expression \"%s\")", name));
02434         return TCL_ERROR;
02435     }
02436 
02437     /*
02438      * CAREFUL: TclCreateProc returns refCount==1! [Bug 1578454]
02439      * procPtr->refCount = 1;
02440      */
02441 
02442     procPtr->cmdPtr = NULL;
02443 
02444     /*
02445      * TIP #280: Remember the line the apply body is starting on. In a Byte
02446      * code context we ask the engine to provide us with the necessary
02447      * information. This is for the initialization of the byte code compiler
02448      * when the body is used for the first time.
02449      *
02450      * NOTE: The body is the second word in the 'objPtr'. Its location,
02451      * accessible through 'context.line[1]' (see below) is therefore only the
02452      * first approximation of the actual line the body is on. We have to use
02453      * the string rep of the 'objPtr' to determine the exact line. This is
02454      * available already through 'name'. Use 'TclListLines', see 'switch'
02455      * (tclCmdMZ.c).
02456      *
02457      * This code is nearly identical to the #280 code in Tcl_ProcObjCmd, see
02458      * this file. The differences are the different index of the body in the
02459      * line array of the context, and the special processing mentioned in the
02460      * previous paragraph to track into the list. Find a way to factor the
02461      * common elements into a single function.
02462      */
02463 
02464     if (iPtr->cmdFramePtr) {
02465         CmdFrame *contextPtr;
02466 
02467         contextPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame));
02468         *contextPtr = *iPtr->cmdFramePtr;
02469 
02470         if (contextPtr->type == TCL_LOCATION_BC) {
02471             /*
02472              * Retrieve the source context from the bytecode. This call
02473              * accounts for the reference to the source file, if any, held in
02474              * 'context.data.eval.path'.
02475              */
02476 
02477             TclGetSrcInfoForPc(contextPtr);
02478         } else if (contextPtr->type == TCL_LOCATION_SOURCE) {
02479             /*
02480              * We created a new reference to the source file path name when we
02481              * created 'context' above. Account for the reference.
02482              */
02483 
02484             Tcl_IncrRefCount(contextPtr->data.eval.path);
02485 
02486         }
02487 
02488         if (contextPtr->type == TCL_LOCATION_SOURCE) {
02489             /*
02490              * We can record source location within a lambda only if the body
02491              * was not created by substitution.
02492              */
02493 
02494             if (contextPtr->line
02495                     && (contextPtr->nline >= 2) && (contextPtr->line[1] >= 0)) {
02496                 int isNew, buf[2];
02497                 CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame));
02498 
02499                 /*
02500                  * Move from approximation (line of list cmd word) to actual
02501                  * location (line of 2nd list element).
02502                  */
02503 
02504                 TclListLines(name, contextPtr->line[1], 2, buf);
02505 
02506                 cfPtr->level = -1;
02507                 cfPtr->type = contextPtr->type;
02508                 cfPtr->line = (int *) ckalloc(sizeof(int));
02509                 cfPtr->line[0] = buf[1];
02510                 cfPtr->nline = 1;
02511                 cfPtr->framePtr = NULL;
02512                 cfPtr->nextPtr = NULL;
02513 
02514                 cfPtr->data.eval.path = contextPtr->data.eval.path;
02515                 Tcl_IncrRefCount(cfPtr->data.eval.path);
02516 
02517                 cfPtr->cmd.str.cmd = NULL;
02518                 cfPtr->cmd.str.len = 0;
02519 
02520                 Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->linePBodyPtr,
02521                         (char *) procPtr, &isNew), cfPtr);
02522             }
02523 
02524             /*
02525              * 'contextPtr' is going out of scope. Release the reference that
02526              * it's holding to the source file path
02527              */
02528 
02529             Tcl_DecrRefCount(contextPtr->data.eval.path);
02530         }
02531         TclStackFree(interp, contextPtr);
02532     }
02533 
02534     /*
02535      * Set the namespace for this lambda: given by objv[2] understood as a
02536      * global reference, or else global per default.
02537      */
02538 
02539     if (objc == 2) {
02540         TclNewLiteralStringObj(nsObjPtr, "::");
02541     } else {
02542         char *nsName = TclGetString(objv[2]);
02543 
02544         if ((*nsName != ':') || (*(nsName+1) != ':')) {
02545             TclNewLiteralStringObj(nsObjPtr, "::");
02546             Tcl_AppendObjToObj(nsObjPtr, objv[2]);
02547         } else {
02548             nsObjPtr = objv[2];
02549         }
02550     }
02551 
02552     Tcl_IncrRefCount(nsObjPtr);
02553 
02554     /*
02555      * Free the list internalrep of objPtr - this will free argsPtr, but
02556      * bodyPtr retains a reference from the Proc structure. Then finish the
02557      * conversion to lambdaType.
02558      */
02559 
02560     objPtr->typePtr->freeIntRepProc(objPtr);
02561 
02562     objPtr->internalRep.twoPtrValue.ptr1 = procPtr;
02563     objPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr;
02564     objPtr->typePtr = &lambdaType;
02565     return TCL_OK;
02566 }
02567 
02568 /*
02569  *----------------------------------------------------------------------
02570  *
02571  * Tcl_ApplyObjCmd --
02572  *
02573  *      This object-based function is invoked to process the "apply" Tcl
02574  *      command. See the user documentation for details on what it does.
02575  *
02576  * Results:
02577  *      A standard Tcl object result value.
02578  *
02579  * Side effects:
02580  *      Depends on the content of the lambda term (i.e., objv[1]).
02581  *
02582  *----------------------------------------------------------------------
02583  */
02584 
02585 int
02586 Tcl_ApplyObjCmd(
02587     ClientData dummy,           /* Not used. */
02588     Tcl_Interp *interp,         /* Current interpreter. */
02589     int objc,                   /* Number of arguments. */
02590     Tcl_Obj *CONST objv[])      /* Argument objects. */
02591 {
02592     Interp *iPtr = (Interp *) interp;
02593     Proc *procPtr = NULL;
02594     Tcl_Obj *lambdaPtr, *nsObjPtr;
02595     int result, isRootEnsemble;
02596     Command cmd;
02597     Tcl_Namespace *nsPtr;
02598     ExtraFrameInfo efi;
02599 
02600     if (objc < 2) {
02601         Tcl_WrongNumArgs(interp, 1, objv, "lambdaExpr ?arg1 arg2 ...?");
02602         return TCL_ERROR;
02603     }
02604 
02605     /*
02606      * Set lambdaPtr, convert it to lambdaType in the current interp if
02607      * necessary.
02608      */
02609 
02610     lambdaPtr = objv[1];
02611     if (lambdaPtr->typePtr == &lambdaType) {
02612         procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1;
02613     }
02614 
02615 #define JOE_EXTENSION 0
02616 #if JOE_EXTENSION
02617     else {
02618         /*
02619          * Joe English's suggestion to allow cmdNames to function as lambdas.
02620          * Also requires making tclCmdNameType non-static in tclObj.c
02621          */
02622 
02623         Tcl_Obj *elemPtr;
02624         int numElem;
02625 
02626         if ((lambdaPtr->typePtr == &tclCmdNameType) ||
02627                 (TclListObjGetElements(interp, lambdaPtr, &numElem,
02628                 &elemPtr) == TCL_OK && numElem == 1)) {
02629             return Tcl_EvalObjv(interp, objc-1, objv+1, 0);
02630         }
02631     }
02632 #endif
02633 
02634     if ((procPtr == NULL) || (procPtr->iPtr != iPtr)) {
02635         result = SetLambdaFromAny(interp, lambdaPtr);
02636         if (result != TCL_OK) {
02637             return result;
02638         }
02639         procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1;
02640     }
02641 
02642     memset(&cmd, 0, sizeof(Command));
02643     procPtr->cmdPtr = &cmd;
02644 
02645     /*
02646      * TIP#280 (semi-)HACK!
02647      *
02648      * Using cmd.clientData to tell [info frame] how to render the
02649      * 'lambdaPtr'. The InfoFrameCmd will detect this case by testing cmd.hPtr
02650      * for NULL. This condition holds here because of the 'memset' above, and
02651      * nowhere else (in the core). Regular commands always have a valid
02652      * 'hPtr', and lambda's never.
02653      */
02654 
02655     efi.length = 1;
02656     efi.fields[0].name = "lambda";
02657     efi.fields[0].proc = NULL;
02658     efi.fields[0].clientData = lambdaPtr;
02659     cmd.clientData = &efi;
02660 
02661     /*
02662      * Find the namespace where this lambda should run, and push a call frame
02663      * for that namespace. Note that TclObjInterpProc() will pop it.
02664      */
02665 
02666     nsObjPtr = lambdaPtr->internalRep.twoPtrValue.ptr2;
02667     result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
02668     if (result != TCL_OK) {
02669         return result;
02670     }
02671 
02672     cmd.nsPtr = (Namespace *) nsPtr;
02673 
02674     isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL);
02675     if (isRootEnsemble) {
02676         iPtr->ensembleRewrite.sourceObjs = objv;
02677         iPtr->ensembleRewrite.numRemovedObjs = 1;
02678         iPtr->ensembleRewrite.numInsertedObjs = 0;
02679     } else {
02680         iPtr->ensembleRewrite.numInsertedObjs -= 1;
02681     }
02682 
02683     result = PushProcCallFrame((ClientData) procPtr, interp, objc, objv, 1);
02684     if (result == TCL_OK) {
02685         result = TclObjInterpProcCore(interp, objv[1], 2, &MakeLambdaError);
02686     }
02687 
02688     if (isRootEnsemble) {
02689         iPtr->ensembleRewrite.sourceObjs = NULL;
02690         iPtr->ensembleRewrite.numRemovedObjs = 0;
02691         iPtr->ensembleRewrite.numInsertedObjs = 0;
02692     }
02693 
02694     return result;
02695 }
02696 
02697 /*
02698  *----------------------------------------------------------------------
02699  *
02700  * MakeLambdaError --
02701  *
02702  *      Function called by TclObjInterpProc to create the stack information
02703  *      upon an error from a lambda term.
02704  *
02705  * Results:
02706  *      The interpreter's error info trace is set to a value that supplements
02707  *      the error code.
02708  *
02709  * Side effects:
02710  *      none.
02711  *
02712  *----------------------------------------------------------------------
02713  */
02714 
02715 static void
02716 MakeLambdaError(
02717     Tcl_Interp *interp,         /* The interpreter in which the procedure was
02718                                  * called. */
02719     Tcl_Obj *procNameObj)       /* Name of the procedure. Used for error
02720                                  * messages and trace information. */
02721 {
02722     int overflow, limit = 60, nameLen;
02723     const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen);
02724 
02725     overflow = (nameLen > limit);
02726     Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
02727             "\n    (lambda term \"%.*s%s\" line %d)",
02728             (overflow ? limit : nameLen), procName,
02729             (overflow ? "..." : ""), interp->errorLine));
02730 }
02731 
02732 
02733 /*
02734  *----------------------------------------------------------------------
02735  *
02736  * Tcl_DisassembleObjCmd --
02737  *
02738  *      Implementation of the "::tcl::unsupported::disassemble" command. This
02739  *      command is not documented, but will disassemble procedures, lambda
02740  *      terms and general scripts. Note that will compile terms if necessary
02741  *      in order to disassemble them.
02742  *
02743  *----------------------------------------------------------------------
02744  */
02745 
02746 int
02747 Tcl_DisassembleObjCmd(
02748     ClientData dummy,           /* Not used. */
02749     Tcl_Interp *interp,         /* Current interpreter. */
02750     int objc,                   /* Number of arguments. */
02751     Tcl_Obj *CONST objv[])      /* Argument objects. */
02752 {
02753     static const char *types[] = {
02754         "lambda", "proc", "script", NULL
02755     };
02756     enum Types {
02757         DISAS_LAMBDA, DISAS_PROC, DISAS_SCRIPT
02758     };
02759     int idx, result;
02760 
02761     if (objc != 3) {
02762         Tcl_WrongNumArgs(interp, 1, objv, "type procName|lambdaTerm|script");
02763         return TCL_ERROR;
02764     }
02765     if (Tcl_GetIndexFromObj(interp, objv[1], types, "type", 0, &idx)!=TCL_OK){
02766         return TCL_ERROR;
02767     }
02768 
02769     switch ((enum Types) idx) {
02770     case DISAS_LAMBDA: {
02771         Proc *procPtr = NULL;
02772         Command cmd;
02773         Tcl_Obj *nsObjPtr;
02774         Tcl_Namespace *nsPtr;
02775 
02776         /*
02777          * Compile (if uncompiled) and disassemble a lambda term.
02778          */
02779 
02780         if (objv[2]->typePtr == &lambdaType) {
02781             procPtr = objv[2]->internalRep.twoPtrValue.ptr1;
02782         }
02783         if (procPtr == NULL || procPtr->iPtr != (Interp *) interp) {
02784             result = SetLambdaFromAny(interp, objv[2]);
02785             if (result != TCL_OK) {
02786                 return result;
02787             }
02788             procPtr = objv[2]->internalRep.twoPtrValue.ptr1;
02789         }
02790 
02791         memset(&cmd, 0, sizeof(Command));
02792         nsObjPtr = objv[2]->internalRep.twoPtrValue.ptr2;
02793         result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
02794         if (result != TCL_OK) {
02795             return result;
02796         }
02797         cmd.nsPtr = (Namespace *) nsPtr;
02798         procPtr->cmdPtr = &cmd;
02799         result = PushProcCallFrame(procPtr, interp, objc, objv, 1);
02800         if (result != TCL_OK) {
02801             return result;
02802         }
02803         TclPopStackFrame(interp);
02804         if (((ByteCode *) procPtr->bodyPtr->internalRep.otherValuePtr)->flags
02805                 & TCL_BYTECODE_PRECOMPILED) {
02806             Tcl_AppendResult(interp, "may not disassemble prebuilt bytecode",
02807                     NULL);
02808             return TCL_ERROR;
02809         }
02810         Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(procPtr->bodyPtr));
02811         break;
02812     }
02813     case DISAS_PROC: {
02814         Proc *procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2]));
02815 
02816         if (procPtr == NULL) {
02817             Tcl_AppendResult(interp, "\"", TclGetString(objv[2]),
02818                     "\" isn't a procedure", NULL);
02819             return TCL_ERROR;
02820         }
02821 
02822         /*
02823          * Compile (if uncompiled) and disassemble a procedure.
02824          */
02825 
02826         result = PushProcCallFrame(procPtr, interp, 2, objv+1, 1);
02827         if (result != TCL_OK) {
02828             return result;
02829         }
02830         TclPopStackFrame(interp);
02831         if (((ByteCode *) procPtr->bodyPtr->internalRep.otherValuePtr)->flags
02832                 & TCL_BYTECODE_PRECOMPILED) {
02833             Tcl_AppendResult(interp, "may not disassemble prebuilt bytecode",
02834                     NULL);
02835             return TCL_ERROR;
02836         }
02837         Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(procPtr->bodyPtr));
02838         break;
02839     }
02840     case DISAS_SCRIPT:
02841         /*
02842          * Compile and disassemble a script.
02843          */
02844 
02845         if (objv[2]->typePtr != &tclByteCodeType) {
02846             if (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK){
02847                 return TCL_ERROR;
02848             }
02849         }
02850         Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(objv[2]));
02851         break;
02852     }
02853     return TCL_OK;
02854 }
02855 
02856 /*
02857  * Local Variables:
02858  * mode: c
02859  * c-basic-offset: 4
02860  * fill-column: 78
02861  * End:
02862  */



Generated on Wed Mar 12 12:18:20 2008 by  doxygen 1.5.1