开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > Windows编程 > 通讯编程 > 查看源码
tclProc.c
资源名称：ns-allinone-2.33.tar.gz　[点击查看]
上传用户：rrhhcc
上传日期：2015-12-11
资源大小：54129k
文件大小：57k
源码类别：

通讯编程

开发平台：

Visual C++

tclProc.c：源码内容
  1. /* 
  2.  * tclProc.c --
  3.  *
  4.  * This file contains routines that implement Tcl procedures,
  5.  * including the "proc" and "uplevel" commands.
  6.  *
  7.  * Copyright (c) 1987-1993 The Regents of the University of California.
  8.  * Copyright (c) 1994-1998 Sun Microsystems, Inc.
  9.  * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
  10.  *
  11.  * See the file "license.terms" for information on usage and redistribution
  12.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  13.  *
  14.  * RCS: @(#) $Id: tclProc.c,v 1.44.2.7 2007/09/13 15:28:17 das Exp $
  15.  */
  17. #include "tclInt.h"
  18. #include "tclCompile.h"
  20. /*
  21.  * Prototypes for static functions in this file
  22.  */
  24. static void ProcBodyDup _ANSI_ARGS_((Tcl_Obj *srcPtr, Tcl_Obj *dupPtr));
  25. static void ProcBodyFree _ANSI_ARGS_((Tcl_Obj *objPtr));
  26. static int ProcBodySetFromAny _ANSI_ARGS_((Tcl_Interp *interp,
  27. Tcl_Obj *objPtr));
  28. static void ProcBodyUpdateString _ANSI_ARGS_((Tcl_Obj *objPtr));
  29. static int ProcCompileProc _ANSI_ARGS_((Tcl_Interp *interp,
  30.     Proc *procPtr, Tcl_Obj *bodyPtr, Namespace *nsPtr,
  31.     CONST char *description, CONST char *procName,
  32.     Proc **procPtrPtr));
  33. static  int ProcessProcResultCode _ANSI_ARGS_((Tcl_Interp *interp,
  34.     char *procName, int nameLen, int returnCode));
  35. static int TclCompileNoOp _ANSI_ARGS_((Tcl_Interp *interp,
  36.     Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
  38. /*
  39.  * The ProcBodyObjType type
  40.  */
  42. Tcl_ObjType tclProcBodyType = {
  43.     "procbody", /* name for this type */
  44.     ProcBodyFree, /* FreeInternalRep procedure */
  45.     ProcBodyDup, /* DupInternalRep procedure */
  46.     ProcBodyUpdateString, /* UpdateString procedure */
  47.     ProcBodySetFromAny /* SetFromAny procedure */
  48. };
  50. /*
  51.  *----------------------------------------------------------------------
  52.  *
  53.  * Tcl_ProcObjCmd --
  54.  *
  55.  * This object-based procedure is invoked to process the "proc" Tcl 
  56.  * command. See the user documentation for details on what it does.
  57.  *
  58.  * Results:
  59.  * A standard Tcl object result value.
  60.  *
  61.  * Side effects:
  62.  * A new procedure gets created.
  63.  *
  64.  *----------------------------------------------------------------------
  65.  */
  67. /* ARGSUSED */
  68. int
  69. Tcl_ProcObjCmd(dummy, interp, objc, objv)
  70.     ClientData dummy; /* Not used. */
  71.     Tcl_Interp *interp; /* Current interpreter. */
  72.     int objc; /* Number of arguments. */
  73.     Tcl_Obj *CONST objv[]; /* Argument objects. */
  74. {
  75.     register Interp *iPtr = (Interp *) interp;
  76.     Proc *procPtr;
  77.     char *fullName;
  78.     CONST char *procName, *procArgs, *procBody;
  79.     Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
  80.     Tcl_Command cmd;
  81.     Tcl_DString ds;
  83.     if (objc != 4) {
  84. Tcl_WrongNumArgs(interp, 1, objv, "name args body");
  85. return TCL_ERROR;
  86.     }
  88.     /*
  89.      * Determine the namespace where the procedure should reside. Unless
  90.      * the command name includes namespace qualifiers, this will be the
  91.      * current namespace.
  92.      */
  93.     
  94.     fullName = TclGetString(objv[1]);
  95.     TclGetNamespaceForQualName(interp, fullName, (Namespace *) NULL,
  96.     0, &nsPtr, &altNsPtr, &cxtNsPtr, &procName);
  98.     if (nsPtr == NULL) {
  99.         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  100. "can't create procedure "", fullName,
  101. "": unknown namespace", (char *) NULL);
  102.         return TCL_ERROR;
  103.     }
  104.     if (procName == NULL) {
  105. Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  106. "can't create procedure "", fullName,
  107. "": bad procedure name", (char *) NULL);
  108.         return TCL_ERROR;
  109.     }
  110.     if ((nsPtr != iPtr->globalNsPtr)
  111.     && (procName != NULL) && (procName[0] == ':')) {
  112. Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  113. "can't create procedure "", procName,
  114. "" in non-global namespace with name starting with ":"",
  115.         (char *) NULL);
  116.         return TCL_ERROR;
  117.     }
  119.     /*
  120.      *  Create the data structure to represent the procedure.
  121.      */
  122.     if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3],
  123.         &procPtr) != TCL_OK) {
  124.         return TCL_ERROR;
  125.     }
  127.     /*
  128.      * Now create a command for the procedure. This will initially be in
  129.      * the current namespace unless the procedure's name included namespace
  130.      * qualifiers. To create the new command in the right namespace, we
  131.      * generate a fully qualified name for it.
  132.      */
  134.     Tcl_DStringInit(&ds);
  135.     if (nsPtr != iPtr->globalNsPtr) {
  136. Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
  137. Tcl_DStringAppend(&ds, "::", 2);
  138.     }
  139.     Tcl_DStringAppend(&ds, procName, -1);
  140.     
  141.     Tcl_CreateCommand(interp, Tcl_DStringValue(&ds), TclProcInterpProc,
  142.     (ClientData) procPtr, TclProcDeleteProc);
  143.     cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds),
  144.     TclObjInterpProc, (ClientData) procPtr, TclProcDeleteProc);
  146.     Tcl_DStringFree(&ds);
  147.     /*
  148.      * Now initialize the new procedure's cmdPtr field. This will be used
  149.      * later when the procedure is called to determine what namespace the
  150.      * procedure will run in. This will be different than the current
  151.      * namespace if the proc was renamed into a different namespace.
  152.      */
  153.     
  154.     procPtr->cmdPtr = (Command *) cmd;
  156. #ifdef TCL_TIP280
  157.     /* TIP #280 Remember the line the procedure body is starting on. In a
  158.      * Byte code context we ask the engine to provide us with the necessary
  159.      * information. This is for the initialization of the byte code compiler
  160.      * when the body is used for the first time.
  161.      */
  163.     if (iPtr->cmdFramePtr) {
  164.         CmdFrame context = *iPtr->cmdFramePtr;
  166. if (context.type == TCL_LOCATION_BC) {
  167.     TclGetSrcInfoForPc (&context);
  168.     /* May get path in context */
  169. } else if (context.type == TCL_LOCATION_SOURCE) {
  170.     /* context now holds another reference */
  171.     Tcl_IncrRefCount (context.data.eval.path);
  172. }
  174. /* type == TCL_LOCATION_PREBC implies that 'line' is NULL here!  We
  175.  * cannot assume that 'line' is valid here, we have to check. If the
  176.  * outer context is an eval (bc, prebc, eval) we do not save any
  177.  * information. Counting relative to the beginning of the proc body is
  178.  * more sensible than counting relative to the outer eval block.
  179.  */
  181. if ((context.type == TCL_LOCATION_SOURCE) &&
  182.     context.line &&
  183.     (context.nline >= 4) &&
  184.     (context.line [3] >= 0)) {
  185.     int       new;
  186.     CmdFrame* cfPtr = (CmdFrame*) ckalloc (sizeof (CmdFrame));
  188.     cfPtr->level    = -1;
  189.     cfPtr->type     = context.type;
  190.     cfPtr->line     = (int*) ckalloc (sizeof (int));
  191.     cfPtr->line [0] = context.line [3];
  192.     cfPtr->nline    = 1;
  193.     cfPtr->framePtr = NULL;
  194.     cfPtr->nextPtr  = NULL;
  196.     if (context.type == TCL_LOCATION_SOURCE) {
  197.         cfPtr->data.eval.path = context.data.eval.path;
  198. /* Transfer of reference. The reference going away (release of
  199.  * the context) is replaced by the reference in the
  200.  * constructed cmdframe */
  201.     } else {
  202.         cfPtr->type = TCL_LOCATION_EVAL;
  203. cfPtr->data.eval.path = NULL;
  204.     }
  206.     cfPtr->cmd.str.cmd = NULL;
  207.     cfPtr->cmd.str.len = 0;
  209.     Tcl_SetHashValue (Tcl_CreateHashEntry (iPtr->linePBodyPtr,
  210.    (char*) procPtr, &new),
  211.       cfPtr);
  212. }
  213.     }
  214. #endif
  216.     /*
  217.      * Optimize for noop procs: if the body is not precompiled (like a TclPro
  218.      * procbody), and the argument list is just "args" and the body is empty,
  219.      * define a compileProc to compile a noop.
  220.      *
  221.      * Notes: 
  222.      *   - cannot be done for any argument list without having different
  223.      *     compiled/not-compiled behaviour in the "wrong argument #" case, 
  224.      *     or making this code much more complicated. In any case, it doesn't 
  225.      *     seem to make a lot of sense to verify the number of arguments we 
  226.      *     are about to ignore ...
  227.      *   - could be enhanced to handle also non-empty bodies that contain 
  228.      *     only comments; however, parsing the body will slow down the 
  229.      *     compilation of all procs whose argument list is just _args_ */
  231.     if (objv[3]->typePtr == &tclProcBodyType) {
  232. goto done;
  233.     }
  235.     procArgs = Tcl_GetString(objv[2]);
  236.     
  237.     while (*procArgs == ' ') {
  238. procArgs++;
  239.     }
  240.     
  241.     if ((procArgs[0] == 'a') && (strncmp(procArgs, "args", 4) == 0)) {
  242. procArgs +=4;
  243. while(*procArgs != '') {
  244.     if (*procArgs != ' ') {
  245. goto done;
  246.     }
  247.     procArgs++;
  248. }
  250. /* 
  251.  * The argument list is just "args"; check the body
  252.  */
  254. procBody = Tcl_GetString(objv[3]);
  255. while (*procBody != '') {
  256.     if (!isspace(UCHAR(*procBody))) {
  257. goto done;
  258.     }
  259.     procBody++;
  260. }
  262. /* 
  263.  * The body is just spaces: link the compileProc
  264.  */
  266. ((Command *) cmd)->compileProc = TclCompileNoOp;
  267.     }
  269.  done:
  270.     return TCL_OK;
  271. }
  273. /*
  274.  *----------------------------------------------------------------------
  275.  *
  276.  * TclCreateProc --
  277.  *
  278.  * Creates the data associated with a Tcl procedure definition.
  279.  * This procedure knows how to handle two types of body objects:
  280.  * strings and procbody. Strings are the traditional (and common) value
  281.  * for bodies, procbody are values created by extensions that have
  282.  * loaded a previously compiled script.
  283.  *
  284.  * Results:
  285.  * Returns TCL_OK on success, along with a pointer to a Tcl
  286.  * procedure definition in procPtrPtr.  This definition should
  287.  * be freed by calling TclCleanupProc() when it is no longer
  288.  * needed.  Returns TCL_ERROR if anything goes wrong.
  289.  *
  290.  * Side effects:
  291.  * If anything goes wrong, this procedure returns an error
  292.  * message in the interpreter.
  293.  *
  294.  *----------------------------------------------------------------------
  295.  */
  296. int
  297. TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr)
  298.     Tcl_Interp *interp;         /* interpreter containing proc */
  299.     Namespace *nsPtr;           /* namespace containing this proc */
  300.     CONST char *procName;       /* unqualified name of this proc */
  301.     Tcl_Obj *argsPtr;           /* description of arguments */
  302.     Tcl_Obj *bodyPtr;           /* command body */
  303.     Proc **procPtrPtr;          /* returns:  pointer to proc data */
  304. {
  305.     Interp *iPtr = (Interp*)interp;
  306.     CONST char **argArray = NULL;
  308.     register Proc *procPtr;
  309.     int i, length, result, numArgs;
  310.     CONST char *args, *bytes, *p;
  311.     register CompiledLocal *localPtr = NULL;
  312.     Tcl_Obj *defPtr;
  313.     int precompiled = 0;
  314.     
  315.     if (bodyPtr->typePtr == &tclProcBodyType) {
  316.         /*
  317.          * Because the body is a TclProProcBody, the actual body is already
  318.          * compiled, and it is not shared with anyone else, so it's OK not to
  319.          * unshare it (as a matter of fact, it is bad to unshare it, because
  320.          * there may be no source code).
  321.          *
  322.          * We don't create and initialize a Proc structure for the procedure;
  323.          * rather, we use what is in the body object. Note that
  324.          * we initialize its cmdPtr field below after we've created the command
  325.          * for the procedure. We increment the ref count of the Proc struct
  326.          * since the command (soon to be created) will be holding a reference
  327.          * to it.
  328.          */
  329.     
  330.         procPtr = (Proc *) bodyPtr->internalRep.otherValuePtr;
  331.         procPtr->iPtr = iPtr;
  332.         procPtr->refCount++;
  333.         precompiled = 1;
  334.     } else {
  335.         /*
  336.          * If the procedure's body object is shared because its string value is
  337.          * identical to, e.g., the body of another procedure, we must create a
  338.          * private copy for this procedure to use. Such sharing of procedure
  339.          * bodies is rare but can cause problems. A procedure body is compiled
  340.          * in a context that includes the number of compiler-allocated "slots"
  341.          * for local variables. Each formal parameter is given a local variable
  342.          * slot (the "procPtr->numCompiledLocals = numArgs" assignment
  343.          * below). This means that the same code can not be shared by two
  344.          * procedures that have a different number of arguments, even if their
  345.          * bodies are identical. Note that we don't use Tcl_DuplicateObj since
  346.          * we would not want any bytecode internal representation.
  347.          */
  349.         if (Tcl_IsShared(bodyPtr)) {
  350.             bytes = Tcl_GetStringFromObj(bodyPtr, &length);
  351.             bodyPtr = Tcl_NewStringObj(bytes, length);
  352.         }
  354.         /*
  355.          * Create and initialize a Proc structure for the procedure. Note that
  356.          * we initialize its cmdPtr field below after we've created the command
  357.          * for the procedure. We increment the ref count of the procedure's
  358.          * body object since there will be a reference to it in the Proc
  359.          * structure.
  360.          */
  361.     
  362.         Tcl_IncrRefCount(bodyPtr);
  364.         procPtr = (Proc *) ckalloc(sizeof(Proc));
  365.         procPtr->iPtr = iPtr;
  366.         procPtr->refCount = 1;
  367.         procPtr->bodyPtr = bodyPtr;
  368.         procPtr->numArgs  = 0; /* actual argument count is set below. */
  369.         procPtr->numCompiledLocals = 0;
  370.         procPtr->firstLocalPtr = NULL;
  371.         procPtr->lastLocalPtr = NULL;
  372.     }
  373.     
  374.     /*
  375.      * Break up the argument list into argument specifiers, then process
  376.      * each argument specifier.
  377.      * If the body is precompiled, processing is limited to checking that
  378.      * the the parsed argument is consistent with the one stored in the
  379.      * Proc.
  380.      * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULLS.
  381.      */
  383.     args = Tcl_GetStringFromObj(argsPtr, &length);
  384.     result = Tcl_SplitList(interp, args, &numArgs, &argArray);
  385.     if (result != TCL_OK) {
  386.         goto procError;
  387.     }
  389.     if (precompiled) {
  390.         if (numArgs > procPtr->numArgs) {
  391.             char buf[64 + TCL_INTEGER_SPACE + TCL_INTEGER_SPACE];
  392.             sprintf(buf, "": arg list contains %d entries, precompiled header expects %d",
  393.                     numArgs, procPtr->numArgs);
  394.             Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  395.                     "procedure "", procName,
  396.                     buf, (char *) NULL);
  397.             goto procError;
  398.         }
  399.         localPtr = procPtr->firstLocalPtr;
  400.     } else {
  401.         procPtr->numArgs = numArgs;
  402.         procPtr->numCompiledLocals = numArgs;
  403.     }
  404.     for (i = 0;  i < numArgs;  i++) {
  405.         int fieldCount, nameLength, valueLength;
  406.         CONST char **fieldValues;
  408.         /*
  409.          * Now divide the specifier up into name and default.
  410.          */
  412.         result = Tcl_SplitList(interp, argArray[i], &fieldCount,
  413.                 &fieldValues);
  414.         if (result != TCL_OK) {
  415.             goto procError;
  416.         }
  417.         if (fieldCount > 2) {
  418.             ckfree((char *) fieldValues);
  419.             Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  420.                     "too many fields in argument specifier "",
  421.                     argArray[i], """, (char *) NULL);
  422.             goto procError;
  423.         }
  424.         if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
  425.             ckfree((char *) fieldValues);
  426.             Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  427.                     "procedure "", procName,
  428.                     "" has argument with no name", (char *) NULL);
  429.             goto procError;
  430.         }
  432.         nameLength = strlen(fieldValues[0]);
  433.         if (fieldCount == 2) {
  434.             valueLength = strlen(fieldValues[1]);
  435.         } else {
  436.             valueLength = 0;
  437.         }
  439.         /*
  440.          * Check that the formal parameter name is a scalar.
  441.          */
  443.         p = fieldValues[0];
  444.         while (*p != '') {
  445.             if (*p == '(') {
  446.                 CONST char *q = p;
  447.                 do {
  448.     q++;
  449. } while (*q != '');
  450. q--;
  451. if (*q == ')') { /* we have an array element */
  452.     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  453.             "procedure "", procName,
  454.             "" has formal parameter "", fieldValues[0],
  455.     "" that is an array element",
  456.     (char *) NULL);
  457.     ckfree((char *) fieldValues);
  458.     goto procError;
  459. }
  460.     } else if ((*p == ':') && (*(p+1) == ':')) {
  461. Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  462.         "procedure "", procName,
  463.         "" has formal parameter "", fieldValues[0],
  464. "" that is not a simple name",
  465. (char *) NULL);
  466. ckfree((char *) fieldValues);
  467. goto procError;
  468.     }
  469.     p++;
  470. }
  472. if (precompiled) {
  473.     /*
  474.      * Compare the parsed argument with the stored one.
  475.      * For the flags, we and out VAR_UNDEFINED to support bridging
  476.      * precompiled <= 8.3 code in 8.4 where this is now used as an
  477.      * optimization indicator. Yes, this is a hack. -- hobbs
  478.      */
  480.     if ((localPtr->nameLength != nameLength)
  481.     || (strcmp(localPtr->name, fieldValues[0]))
  482.     || (localPtr->frameIndex != i)
  483.     || ((localPtr->flags & ~VAR_UNDEFINED)
  484.     != (VAR_SCALAR | VAR_ARGUMENT))
  485.     || ((localPtr->defValuePtr == NULL)
  486.     && (fieldCount == 2))
  487.     || ((localPtr->defValuePtr != NULL)
  488.     && (fieldCount != 2))) {
  489. char buf[80 + TCL_INTEGER_SPACE];
  490. sprintf(buf, "": formal parameter %d is inconsistent with precompiled body",
  491. i);
  492. Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  493. "procedure "", procName,
  494. buf, (char *) NULL);
  495. ckfree((char *) fieldValues);
  496. goto procError;
  497.     }
  499.             /*
  500.              * compare the default value if any
  501.              */
  503.             if (localPtr->defValuePtr != NULL) {
  504.                 int tmpLength;
  505.                 char *tmpPtr = Tcl_GetStringFromObj(localPtr->defValuePtr,
  506.                         &tmpLength);
  507.                 if ((valueLength != tmpLength)
  508.                         || (strncmp(fieldValues[1], tmpPtr,
  509.                                 (size_t) tmpLength))) {
  510.                     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  511.                             "procedure "", procName,
  512.                             "": formal parameter "",
  513.                             fieldValues[0],
  514.                             "" has default value inconsistent with precompiled body",
  515.                             (char *) NULL);
  516.                     ckfree((char *) fieldValues);
  517.                     goto procError;
  518.                 }
  519.             }
  521.             localPtr = localPtr->nextPtr;
  522.         } else {
  523.             /*
  524.              * Allocate an entry in the runtime procedure frame's array of
  525.              * local variables for the argument. 
  526.              */
  528.             localPtr = (CompiledLocal *) ckalloc((unsigned) 
  529.                     (sizeof(CompiledLocal) - sizeof(localPtr->name)
  530.                             + nameLength+1));
  531.             if (procPtr->firstLocalPtr == NULL) {
  532.                 procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
  533.             } else {
  534.                 procPtr->lastLocalPtr->nextPtr = localPtr;
  535.                 procPtr->lastLocalPtr = localPtr;
  536.             }
  537.             localPtr->nextPtr = NULL;
  538.             localPtr->nameLength = nameLength;
  539.             localPtr->frameIndex = i;
  540.             localPtr->flags = VAR_SCALAR | VAR_ARGUMENT;
  541.             localPtr->resolveInfo = NULL;
  543.             if (fieldCount == 2) {
  544.                 localPtr->defValuePtr =
  545.     Tcl_NewStringObj(fieldValues[1], valueLength);
  546.                 Tcl_IncrRefCount(localPtr->defValuePtr);
  547.             } else {
  548.                 localPtr->defValuePtr = NULL;
  549.             }
  550.             strcpy(localPtr->name, fieldValues[0]);
  551. }
  553.         ckfree((char *) fieldValues);
  554.     }
  556.     /*
  557.      * Now initialize the new procedure's cmdPtr field. This will be used
  558.      * later when the procedure is called to determine what namespace the
  559.      * procedure will run in. This will be different than the current
  560.      * namespace if the proc was renamed into a different namespace.
  561.      */
  562.     
  563.     *procPtrPtr = procPtr;
  564.     ckfree((char *) argArray);
  565.     return TCL_OK;
  567. procError:
  568.     if (precompiled) {
  569.         procPtr->refCount--;
  570.     } else {
  571.         Tcl_DecrRefCount(bodyPtr);
  572.         while (procPtr->firstLocalPtr != NULL) {
  573.             localPtr = procPtr->firstLocalPtr;
  574.             procPtr->firstLocalPtr = localPtr->nextPtr;
  576.             defPtr = localPtr->defValuePtr;
  577.             if (defPtr != NULL) {
  578.                 Tcl_DecrRefCount(defPtr);
  579.             }
  581.             ckfree((char *) localPtr);
  582.         }
  583.         ckfree((char *) procPtr);
  584.     }
  585.     if (argArray != NULL) {
  586. ckfree((char *) argArray);
  587.     }
  588.     return TCL_ERROR;
  589. }
  591. /*
  592.  *----------------------------------------------------------------------
  593.  *
  594.  * TclGetFrame --
  595.  *
  596.  * Given a description of a procedure frame, such as the first
  597.  * argument to an "uplevel" or "upvar" command, locate the
  598.  * call frame for the appropriate level of procedure.
  599.  *
  600.  * Results:
  601.  * The return value is -1 if an error occurred in finding the frame
  602.  * (in this case an error message is left in the interp's result).
  603.  * 1 is returned if string was either a number or a number preceded
  604.  * by "#" and it specified a valid frame.  0 is returned if string
  605.  * isn't one of the two things above (in this case, the lookup
  606.  * acts as if string were "1").  The variable pointed to by
  607.  * framePtrPtr is filled in with the address of the desired frame
  608.  * (unless an error occurs, in which case it isn't modified).
  609.  *
  610.  * Side effects:
  611.  * None.
  612.  *
  613.  *----------------------------------------------------------------------
  614.  */
  616. int
  617. TclGetFrame(interp, string, framePtrPtr)
  618.     Tcl_Interp *interp; /* Interpreter in which to find frame. */
  619.     CONST char *string; /* String describing frame. */
  620.     CallFrame **framePtrPtr; /* Store pointer to frame here (or NULL
  621.  * if global frame indicated). */
  622. {
  623.     register Interp *iPtr = (Interp *) interp;
  624.     int curLevel, level, result;
  625.     CallFrame *framePtr;
  627.     /*
  628.      * Parse string to figure out which level number to go to.
  629.      */
  631.     result = 1;
  632.     curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level;
  633.     if (*string == '#') {
  634. if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) {
  635.     return -1;
  636. }
  637. if (level < 0) {
  638.     levelError:
  639.     Tcl_AppendResult(interp, "bad level "", string, """,
  640.     (char *) NULL);
  641.     return -1;
  642. }
  643.     } else if (isdigit(UCHAR(*string))) { /* INTL: digit */
  644. if (Tcl_GetInt(interp, string, &level) != TCL_OK) {
  645.     return -1;
  646. }
  647. level = curLevel - level;
  648.     } else {
  649. level = curLevel - 1;
  650. result = 0;
  651.     }
  653.     /*
  654.      * Figure out which frame to use, and modify the interpreter so
  655.      * its variables come from that frame.
  656.      */
  658.     if (level == 0) {
  659. framePtr = NULL;
  660.     } else {
  661. for (framePtr = iPtr->varFramePtr; framePtr != NULL;
  662. framePtr = framePtr->callerVarPtr) {
  663.     if (framePtr->level == level) {
  664. break;
  665.     }
  666. }
  667. if (framePtr == NULL) {
  668.     goto levelError;
  669. }
  670.     }
  671.     *framePtrPtr = framePtr;
  672.     return result;
  673. }
  675. /*
  676.  *----------------------------------------------------------------------
  677.  *
  678.  * Tcl_UplevelObjCmd --
  679.  *
  680.  * This object procedure is invoked to process the "uplevel" Tcl
  681.  * command. See the user documentation for details on what it does.
  682.  *
  683.  * Results:
  684.  * A standard Tcl object result value.
  685.  *
  686.  * Side effects:
  687.  * See the user documentation.
  688.  *
  689.  *----------------------------------------------------------------------
  690.  */
  692. /* ARGSUSED */
  693. int
  694. Tcl_UplevelObjCmd(dummy, interp, objc, objv)
  695.     ClientData dummy; /* Not used. */
  696.     Tcl_Interp *interp; /* Current interpreter. */
  697.     int objc; /* Number of arguments. */
  698.     Tcl_Obj *CONST objv[]; /* Argument objects. */
  699. {
  700.     register Interp *iPtr = (Interp *) interp;
  701.     char *optLevel;
  702.     int result;
  703.     CallFrame *savedVarFramePtr, *framePtr;
  705.     if (objc < 2) {
  706. uplevelSyntax:
  707. Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?");
  708. return TCL_ERROR;
  709.     }
  711.     /*
  712.      * Find the level to use for executing the command.
  713.      */
  715.     optLevel = TclGetString(objv[1]);
  716.     result = TclGetFrame(interp, optLevel, &framePtr);
  717.     if (result == -1) {
  718. return TCL_ERROR;
  719.     }
  720.     objc -= (result+1);
  721.     if (objc == 0) {
  722. goto uplevelSyntax;
  723.     }
  724.     objv += (result+1);
  726.     /*
  727.      * Modify the interpreter state to execute in the given frame.
  728.      */
  730.     savedVarFramePtr = iPtr->varFramePtr;
  731.     iPtr->varFramePtr = framePtr;
  733.     /*
  734.      * Execute the residual arguments as a command.
  735.      */
  737.     if (objc == 1) {
  738. result = Tcl_EvalObjEx(interp, objv[0], TCL_EVAL_DIRECT);
  739.     } else {
  740. /*
  741.  * More than one argument: concatenate them together with spaces
  742.  * between, then evaluate the result.  Tcl_EvalObjEx will delete
  743.  * the object when it decrements its refcount after eval'ing it.
  744.  */
  745. Tcl_Obj *objPtr;
  747. objPtr = Tcl_ConcatObj(objc, objv);
  748. result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
  749.     }
  750.     if (result == TCL_ERROR) {
  751. char msg[32 + TCL_INTEGER_SPACE];
  752. sprintf(msg, "n    ("uplevel" body line %d)", interp->errorLine);
  753. Tcl_AddObjErrorInfo(interp, msg, -1);
  754.     }
  756.     /*
  757.      * Restore the variable frame, and return.
  758.      */
  760.     iPtr->varFramePtr = savedVarFramePtr;
  761.     return result;
  762. }
  764. /*
  765.  *----------------------------------------------------------------------
  766.  *
  767.  * TclFindProc --
  768.  *
  769.  * Given the name of a procedure, return a pointer to the
  770.  * record describing the procedure. The procedure will be
  771.  * looked up using the usual rules: first in the current
  772.  * namespace and then in the global namespace.
  773.  *
  774.  * Results:
  775.  * NULL is returned if the name doesn't correspond to any
  776.  * procedure. Otherwise, the return value is a pointer to
  777.  * the procedure's record. If the name is found but refers
  778.  * to an imported command that points to a "real" procedure
  779.  * defined in another namespace, a pointer to that "real"
  780.  * procedure's structure is returned.
  781.  *
  782.  * Side effects:
  783.  * None.
  784.  *
  785.  *----------------------------------------------------------------------
  786.  */
  788. Proc *
  789. TclFindProc(iPtr, procName)
  790.     Interp *iPtr; /* Interpreter in which to look. */
  791.     CONST char *procName; /* Name of desired procedure. */
  792. {
  793.     Tcl_Command cmd;
  794.     Tcl_Command origCmd;
  795.     Command *cmdPtr;
  796.     
  797.     cmd = Tcl_FindCommand((Tcl_Interp *) iPtr, procName,
  798.             (Tcl_Namespace *) NULL, /*flags*/ 0);
  799.     if (cmd == (Tcl_Command) NULL) {
  800.         return NULL;
  801.     }
  802.     cmdPtr = (Command *) cmd;
  804.     origCmd = TclGetOriginalCommand(cmd);
  805.     if (origCmd != NULL) {
  806. cmdPtr = (Command *) origCmd;
  807.     }
  808.     if (cmdPtr->proc != TclProcInterpProc) {
  809. return NULL;
  810.     }
  811.     return (Proc *) cmdPtr->clientData;
  812. }
  814. /*
  815.  *----------------------------------------------------------------------
  816.  *
  817.  * TclIsProc --
  818.  *
  819.  * Tells whether a command is a Tcl procedure or not.
  820.  *
  821.  * Results:
  822.  * If the given command is actually a Tcl procedure, the
  823.  * return value is the address of the record describing
  824.  * the procedure.  Otherwise the return value is 0.
  825.  *
  826.  * Side effects:
  827.  * None.
  828.  *
  829.  *----------------------------------------------------------------------
  830.  */
  832. Proc *
  833. TclIsProc(cmdPtr)
  834.     Command *cmdPtr; /* Command to test. */
  835. {
  836.     Tcl_Command origCmd;
  838.     origCmd = TclGetOriginalCommand((Tcl_Command) cmdPtr);
  839.     if (origCmd != NULL) {
  840. cmdPtr = (Command *) origCmd;
  841.     }
  842.     if (cmdPtr->proc == TclProcInterpProc) {
  843. return (Proc *) cmdPtr->clientData;
  844.     }
  845.     return (Proc *) 0;
  846. }
  848. /*
  849.  *----------------------------------------------------------------------
  850.  *
  851.  * TclProcInterpProc --
  852.  *
  853.  * When a Tcl procedure gets invoked with an argc/argv array of
  854.  * strings, this routine gets invoked to interpret the procedure.
  855.  *
  856.  * Results:
  857.  * A standard Tcl result value, usually TCL_OK.
  858.  *
  859.  * Side effects:
  860.  * Depends on the commands in the procedure.
  861.  *
  862.  *----------------------------------------------------------------------
  863.  */
  865. int
  866. TclProcInterpProc(clientData, interp, argc, argv)
  867.     ClientData clientData; /* Record describing procedure to be
  868.  * interpreted. */
  869.     Tcl_Interp *interp; /* Interpreter in which procedure was
  870.  * invoked. */
  871.     int argc; /* Count of number of arguments to this
  872.  * procedure. */
  873.     register CONST char **argv; /* Argument values. */
  874. {
  875.     register Tcl_Obj *objPtr;
  876.     register int i;
  877.     int result;
  879.     /*
  880.      * This procedure generates an objv array for object arguments that hold
  881.      * the argv strings. It starts out with stack-allocated space but uses
  882.      * dynamically-allocated storage if needed.
  883.      */
  885. #define NUM_ARGS 20
  886.     Tcl_Obj *(objStorage[NUM_ARGS]);
  887.     register Tcl_Obj **objv = objStorage;
  889.     /*
  890.      * Create the object argument array "objv". Make sure objv is large
  891.      * enough to hold the objc arguments plus 1 extra for the zero
  892.      * end-of-objv word.
  893.      */
  895.     if ((argc + 1) > NUM_ARGS) {
  896. objv = (Tcl_Obj **)
  897.     ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *));
  898.     }
  900.     for (i = 0;  i < argc;  i++) {
  901. objv[i] = Tcl_NewStringObj(argv[i], -1);
  902. Tcl_IncrRefCount(objv[i]);
  903.     }
  904.     objv[argc] = 0;
  906.     /*
  907.      * Use TclObjInterpProc to actually interpret the procedure.
  908.      */
  910.     result = TclObjInterpProc(clientData, interp, argc, objv);
  912.     /*
  913.      * Move the interpreter's object result to the string result, 
  914.      * then reset the object result.
  915.      */
  916.     
  917.     Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
  918.     TCL_VOLATILE);
  920.     /*
  921.      * Decrement the ref counts on the objv elements since we are done
  922.      * with them.
  923.      */
  925.     for (i = 0;  i < argc;  i++) {
  926. objPtr = objv[i];
  927. TclDecrRefCount(objPtr);
  928.     }
  929.     
  930.     /*
  931.      * Free the objv array if malloc'ed storage was used.
  932.      */
  934.     if (objv != objStorage) {
  935. ckfree((char *) objv);
  936.     }
  937.     return result;
  938. #undef NUM_ARGS
  939. }
  941. /*
  942.  *----------------------------------------------------------------------
  943.  *
  944.  * TclObjInterpProc --
  945.  *
  946.  * When a Tcl procedure gets invoked during bytecode evaluation, this 
  947.  * object-based routine gets invoked to interpret the procedure.
  948.  *
  949.  * Results:
  950.  * A standard Tcl object result value.
  951.  *
  952.  * Side effects:
  953.  * Depends on the commands in the procedure.
  954.  *
  955.  *----------------------------------------------------------------------
  956.  */
  958. int
  959. TclObjInterpProc(clientData, interp, objc, objv)
  960.     ClientData clientData;   /* Record describing procedure to be
  961.   * interpreted. */
  962.     register Tcl_Interp *interp; /* Interpreter in which procedure was
  963.   * invoked. */
  964.     int objc;  /* Count of number of arguments to this
  965.   * procedure. */
  966.     Tcl_Obj *CONST objv[];  /* Argument value objects. */
  967. {
  968.     Interp *iPtr = (Interp *) interp;
  969.     Proc *procPtr = (Proc *) clientData;
  970.     Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
  971.     CallFrame frame;
  972.     register CallFrame *framePtr = &frame;
  973.     register Var *varPtr;
  974.     register CompiledLocal *localPtr;
  975.     char *procName;
  976.     int nameLen, localCt, numArgs, argCt, i, result;
  978.     /*
  979.      * This procedure generates an array "compiledLocals" that holds the
  980.      * storage for local variables. It starts out with stack-allocated space
  981.      * but uses dynamically-allocated storage if needed.
  982.      */
  984. #define NUM_LOCALS 20
  985.     Var localStorage[NUM_LOCALS];
  986.     Var *compiledLocals = localStorage;
  988.     /*
  989.      * Get the procedure's name.
  990.      */
  991.     
  992.     procName = Tcl_GetStringFromObj(objv[0], &nameLen);
  994.     /*
  995.      * If necessary, compile the procedure's body. The compiler will
  996.      * allocate frame slots for the procedure's non-argument local
  997.      * variables.  Note that compiling the body might increase
  998.      * procPtr->numCompiledLocals if new local variables are found
  999.      * while compiling.
  1000.      */
  1002.     result = ProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr,
  1003.     "body of proc", procName, &procPtr);
  1004.     
  1005.     if (result != TCL_OK) {
  1006.         return result;
  1007.     }
  1009.     /*
  1010.      * Create the "compiledLocals" array. Make sure it is large enough to
  1011.      * hold all the procedure's compiled local variables, including its
  1012.      * formal parameters.
  1013.      */
  1015.     localCt = procPtr->numCompiledLocals;
  1016.     if (localCt > NUM_LOCALS) {
  1017. compiledLocals = (Var *) ckalloc((unsigned) localCt * sizeof(Var));
  1018.     }
  1019.     
  1020.     /*
  1021.      * Set up and push a new call frame for the new procedure invocation.
  1022.      * This call frame will execute in the proc's namespace, which might
  1023.      * be different than the current namespace. The proc's namespace is
  1024.      * that of its command, which can change if the command is renamed
  1025.      * from one namespace to another.
  1026.      */
  1028.     result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr,
  1029.             (Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 1);
  1031.     if (result != TCL_OK) {
  1032.         return result;
  1033.     }
  1035.     framePtr->objc = objc;
  1036.     framePtr->objv = objv;  /* ref counts for args are incremented below */
  1038.     /*
  1039.      * Initialize and resolve compiled variable references.
  1040.      */
  1042.     framePtr->procPtr = procPtr;
  1043.     framePtr->numCompiledLocals = localCt;
  1044.     framePtr->compiledLocals = compiledLocals;
  1046.     TclInitCompiledLocals(interp, framePtr, nsPtr);
  1048.     /*
  1049.      * Match and assign the call's actual parameters to the procedure's
  1050.      * formal arguments. The formal arguments are described by the first
  1051.      * numArgs entries in both the Proc structure's local variable list and
  1052.      * the call frame's local variable array.
  1053.      */
  1055.     numArgs = procPtr->numArgs;
  1056.     varPtr = framePtr->compiledLocals;
  1057.     localPtr = procPtr->firstLocalPtr;
  1058.     argCt = objc;
  1059.     for (i = 1, argCt -= 1;  i <= numArgs;  i++, argCt--) {
  1060. if (!TclIsVarArgument(localPtr)) {
  1061.     panic("TclObjInterpProc: local variable %s is not argument but should be",
  1062.   localPtr->name);
  1063.     return TCL_ERROR;
  1064. }
  1065. if (TclIsVarTemporary(localPtr)) {
  1066.     panic("TclObjInterpProc: local variable %d is temporary but should be an argument", i);
  1067.     return TCL_ERROR;
  1068. }
  1070. /*
  1071.  * Handle the special case of the last formal being "args".  When
  1072.  * it occurs, assign it a list consisting of all the remaining
  1073.  * actual arguments.
  1074.  */
  1076. if ((i == numArgs) && ((localPtr->name[0] == 'a')
  1077.         && (strcmp(localPtr->name, "args") == 0))) {
  1078.     Tcl_Obj *listPtr = Tcl_NewListObj(argCt, &(objv[i]));
  1079.     varPtr->value.objPtr = listPtr;
  1080.     Tcl_IncrRefCount(listPtr); /* local var is a reference */
  1081.     TclClearVarUndefined(varPtr);
  1082.     argCt = 0;
  1083.     break; /* done processing args */
  1084. } else if (argCt > 0) {
  1085.     Tcl_Obj *objPtr = objv[i];
  1086.     varPtr->value.objPtr = objPtr;
  1087.     TclClearVarUndefined(varPtr);
  1088.     Tcl_IncrRefCount(objPtr);  /* since the local variable now has
  1089. * another reference to object. */
  1090. } else if (localPtr->defValuePtr != NULL) {
  1091.     Tcl_Obj *objPtr = localPtr->defValuePtr;
  1092.     varPtr->value.objPtr = objPtr;
  1093.     TclClearVarUndefined(varPtr);
  1094.     Tcl_IncrRefCount(objPtr);  /* since the local variable now has
  1095. * another reference to object. */
  1096. } else {
  1097.     goto incorrectArgs;
  1098. }
  1099. varPtr++;
  1100. localPtr = localPtr->nextPtr;
  1101.     }
  1102.     if (argCt > 0) {
  1103. Tcl_Obj *objResult;
  1104. int len, flags;
  1106. incorrectArgs:
  1107. /*
  1108.  * Build up equivalent to Tcl_WrongNumArgs message for proc
  1109.  */
  1111. Tcl_ResetResult(interp);
  1112. objResult = Tcl_GetObjResult(interp);
  1113. Tcl_AppendToObj(objResult, "wrong # args: should be "", -1);
  1115. /*
  1116.  * Quote the proc name if it contains spaces (Bug 942757).
  1117.  */
  1119. len = Tcl_ScanCountedElement(procName, nameLen, &flags);
  1120. if (len != nameLen) {
  1121.     char *procName1 = ckalloc((unsigned) len);
  1122.     len = Tcl_ConvertCountedElement(procName, nameLen, procName1, flags);
  1123.     Tcl_AppendToObj(objResult, procName1, len);
  1124.     ckfree(procName1);
  1125. } else {
  1126.     Tcl_AppendToObj(objResult, procName, len);
  1127. }
  1129. localPtr = procPtr->firstLocalPtr;
  1130. for (i = 1;  i <= numArgs;  i++) {
  1131.     if (localPtr->defValuePtr != NULL) {
  1132. Tcl_AppendStringsToObj(objResult,
  1133. " ?", localPtr->name, "?", (char *) NULL);
  1134.     } else {
  1135. Tcl_AppendStringsToObj(objResult,
  1136. " ", localPtr->name, (char *) NULL);
  1137.     }
  1138.     localPtr = localPtr->nextPtr;
  1139. }
  1140. Tcl_AppendStringsToObj(objResult, """, (char *) NULL);
  1142. result = TCL_ERROR;
  1143. goto procDone;
  1144.     }
  1146.     /*
  1147.      * Invoke the commands in the procedure's body.
  1148.      */
  1150. #ifdef TCL_COMPILE_DEBUG
  1151.     if (tclTraceExec >= 1) {
  1152. fprintf(stdout, "Calling proc ");
  1153. for (i = 0;  i < objc;  i++) {
  1154.     TclPrintObject(stdout, objv[i], 15);
  1155.     fprintf(stdout, " ");
  1156. }
  1157. fprintf(stdout, "n");
  1158. fflush(stdout);
  1159.     }
  1160. #endif /*TCL_COMPILE_DEBUG*/
  1162.     if (TCL_DTRACE_PROC_ARGS_ENABLED()) {
  1163. char *a[10];
  1164. int i = 0;
  1166. while (i < 10) {
  1167.     a[i] = i < objc ? TclGetString(objv[i]) : NULL; i++;
  1168. }
  1169. TCL_DTRACE_PROC_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7],
  1170. a[8], a[9]);
  1171.     }
  1173.     iPtr->returnCode = TCL_OK;
  1174.     procPtr->refCount++;
  1175.     if (TCL_DTRACE_PROC_ENTRY_ENABLED()) {
  1176. TCL_DTRACE_PROC_ENTRY(TclGetString(objv[0]), objc - 1,
  1177. (Tcl_Obj **)(objv + 1));
  1178.     }
  1179. #ifndef TCL_TIP280
  1180.     result = TclCompEvalObj(interp, procPtr->bodyPtr);
  1181. #else
  1182.     /* TIP #280: No need to set the invoking context here. The body has
  1183.      * already been compiled, so the part of CompEvalObj using it is bypassed.
  1184.      */
  1186.     result = TclCompEvalObj(interp, procPtr->bodyPtr, NULL, 0);
  1187. #endif
  1188.     if (TCL_DTRACE_PROC_RETURN_ENABLED()) {
  1189. TCL_DTRACE_PROC_RETURN(TclGetString(objv[0]), result);
  1190.     }
  1191.     procPtr->refCount--;
  1192.     if (procPtr->refCount <= 0) {
  1193. TclProcCleanupProc(procPtr);
  1194.     }
  1196.     if (result != TCL_OK) {
  1197. result = ProcessProcResultCode(interp, procName, nameLen, result);
  1198.     }
  1199.     
  1200.     if (TCL_DTRACE_PROC_RESULT_ENABLED()) {
  1201. Tcl_Obj *r;
  1203. r = Tcl_GetObjResult(interp);
  1204. TCL_DTRACE_PROC_RESULT(TclGetString(objv[0]), result,
  1205. TclGetString(r), r);
  1206.     }
  1208.     /*
  1209.      * Pop and free the call frame for this procedure invocation, then
  1210.      * free the compiledLocals array if malloc'ed storage was used.
  1211.      */
  1212.     
  1213.     procDone:
  1214.     Tcl_PopCallFrame(interp);
  1215.     if (compiledLocals != localStorage) {
  1216. ckfree((char *) compiledLocals);
  1217.     }
  1218.     return result;
  1219. #undef NUM_LOCALS
  1220. }
  1222. /*
  1223.  *----------------------------------------------------------------------
  1224.  *
  1225.  * TclProcCompileProc --
  1226.  *
  1227.  * Called just before a procedure is executed to compile the
  1228.  * body to byte codes.  If the type of the body is not
  1229.  * "byte code" or if the compile conditions have changed
  1230.  * (namespace context, epoch counters, etc.) then the body
  1231.  * is recompiled.  Otherwise, this procedure does nothing.
  1232.  *
  1233.  * Results:
  1234.  * None.
  1235.  *
  1236.  * Side effects:
  1237.  * May change the internal representation of the body object
  1238.  * to compiled code.
  1239.  *
  1240.  *----------------------------------------------------------------------
  1241.  */
  1242.  
  1243. int
  1244. TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName)
  1245.     Tcl_Interp *interp; /* Interpreter containing procedure. */
  1246.     Proc *procPtr; /* Data associated with procedure. */
  1247.     Tcl_Obj *bodyPtr; /* Body of proc. (Usually procPtr->bodyPtr,
  1248.    * but could be any code fragment compiled
  1249.    * in the context of this procedure.) */
  1250.     Namespace *nsPtr; /* Namespace containing procedure. */
  1251.     CONST char *description; /* string describing this body of code. */
  1252.     CONST char *procName; /* Name of this procedure. */
  1253. {
  1254.     return ProcCompileProc(interp, procPtr, bodyPtr, nsPtr,
  1255.     description, procName, NULL);
  1256. }
  1258. static int
  1259. ProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description,
  1260. procName, procPtrPtr)
  1261.     Tcl_Interp *interp; /* Interpreter containing procedure. */
  1262.     Proc *procPtr; /* Data associated with procedure. */
  1263.     Tcl_Obj *bodyPtr; /* Body of proc. (Usually procPtr->bodyPtr,
  1264.    * but could be any code fragment compiled
  1265.    * in the context of this procedure.) */
  1266.     Namespace *nsPtr; /* Namespace containing procedure. */
  1267.     CONST char *description; /* string describing this body of code. */
  1268.     CONST char *procName; /* Name of this procedure. */
  1269.     Proc **procPtrPtr; /* points to storage where a replacement
  1270.  * (Proc *) value may be written, when
  1271.  * appropriate */
  1272. {
  1273.     Interp *iPtr = (Interp*)interp;
  1274.     int i, result;
  1275.     Tcl_CallFrame frame;
  1276.     Proc *saveProcPtr;
  1277.     ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr;
  1278.     CompiledLocal *localPtr;
  1279.  
  1280.     /*
  1281.      * If necessary, compile the procedure's body. The compiler will
  1282.      * allocate frame slots for the procedure's non-argument local
  1283.      * variables. If the ByteCode already exists, make sure it hasn't been
  1284.      * invalidated by someone redefining a core command (this might make the
  1285.      * compiled code wrong). Also, if the code was compiled in/for a
  1286.      * different interpreter, we recompile it. Note that compiling the body
  1287.      * might increase procPtr->numCompiledLocals if new local variables are
  1288.      * found while compiling.
  1289.      *
  1290.      * Precompiled procedure bodies, however, are immutable and therefore
  1291.      * they are not recompiled, even if things have changed.
  1292.      */
  1293.  
  1294.     if (bodyPtr->typePtr == &tclByteCodeType) {
  1295.   if (((Interp *) *codePtr->interpHandle != iPtr)
  1296.           || (codePtr->compileEpoch != iPtr->compileEpoch)
  1297.           || (codePtr->nsPtr != nsPtr)) {
  1298.             if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
  1299.                 if ((Interp *) *codePtr->interpHandle != iPtr) {
  1300.                     Tcl_AppendResult(interp,
  1301.                             "a precompiled script jumped interps", NULL);
  1302.                     return TCL_ERROR;
  1303.                 }
  1304.         codePtr->compileEpoch = iPtr->compileEpoch;
  1305.                 codePtr->nsPtr = nsPtr;
  1306.             } else {
  1307.                 (*tclByteCodeType.freeIntRepProc)(bodyPtr);
  1308.                 bodyPtr->typePtr = (Tcl_ObjType *) NULL;
  1309.             }
  1310.   }
  1311.     }
  1312.     if (bodyPtr->typePtr != &tclByteCodeType) {
  1313.   int numChars;
  1314.   char *ellipsis;
  1315.  
  1316. #ifdef TCL_COMPILE_DEBUG
  1317.   if (tclTraceCompile >= 1) {
  1318.       /*
  1319.        * Display a line summarizing the top level command we
  1320.        * are about to compile.
  1321.        */
  1322.  
  1323.       numChars = strlen(procName);
  1324.       ellipsis = "";
  1325.       if (numChars > 50) {
  1326.   numChars = 50;
  1327.   ellipsis = "...";
  1328.       }
  1329.       fprintf(stdout, "Compiling %s "%.*s%s"n",
  1330.       description, numChars, procName, ellipsis);
  1331.   }
  1332. #endif
  1333.  
  1334.   /*
  1335.    * Plug the current procPtr into the interpreter and coerce
  1336.    * the code body to byte codes.  The interpreter needs to
  1337.    * know which proc it's compiling so that it can access its
  1338.    * list of compiled locals.
  1339.    *
  1340.    * TRICKY NOTE:  Be careful to push a call frame with the
  1341.    *   proper namespace context, so that the byte codes are
  1342.    *   compiled in the appropriate class context.
  1343.    */
  1345.   saveProcPtr = iPtr->compiledProcPtr;
  1347. if (procPtrPtr != NULL && procPtr->refCount > 1) {
  1348.     Tcl_Command token;
  1349.     Tcl_CmdInfo info;
  1350.     Proc *new = (Proc *) ckalloc(sizeof(Proc));
  1352.     new->iPtr = procPtr->iPtr;
  1353.     new->refCount = 1;
  1354.     new->cmdPtr = procPtr->cmdPtr;
  1355.     token = (Tcl_Command) new->cmdPtr;
  1356.     new->bodyPtr = Tcl_DuplicateObj(bodyPtr);
  1357.     bodyPtr = new->bodyPtr;
  1358.     Tcl_IncrRefCount(bodyPtr);
  1359.     new->numArgs = procPtr->numArgs;
  1361.     new->numCompiledLocals = new->numArgs;
  1362.     new->firstLocalPtr = NULL;
  1363.     new->lastLocalPtr = NULL;
  1364.     localPtr = procPtr->firstLocalPtr;
  1365.     for (i = 0; i < new->numArgs; i++, localPtr = localPtr->nextPtr) {
  1366. CompiledLocal *copy = (CompiledLocal *) ckalloc((unsigned)
  1367. (sizeof(CompiledLocal) -sizeof(localPtr->name)
  1368.  + localPtr->nameLength + 1));
  1369. if (new->firstLocalPtr == NULL) {
  1370.     new->firstLocalPtr = new->lastLocalPtr = copy;
  1371. } else {
  1372.     new->lastLocalPtr->nextPtr = copy;
  1373.     new->lastLocalPtr = copy;
  1374. }
  1375. copy->nextPtr = NULL;
  1376. copy->nameLength = localPtr->nameLength;
  1377. copy->frameIndex = localPtr->frameIndex;
  1378. copy->flags = localPtr->flags;
  1379. copy->defValuePtr = localPtr->defValuePtr;
  1380. if (copy->defValuePtr) {
  1381.     Tcl_IncrRefCount(copy->defValuePtr);
  1382. }
  1383. copy->resolveInfo = localPtr->resolveInfo;
  1384. strcpy(copy->name, localPtr->name);
  1385.     }
  1388.     /* Reset the ClientData */
  1389.     Tcl_GetCommandInfoFromToken(token, &info);
  1390.     if (info.objClientData == (ClientData) procPtr) {
  1391.         info.objClientData = (ClientData) new;
  1392.     }
  1393.     if (info.clientData == (ClientData) procPtr) {
  1394.         info.clientData = (ClientData) new;
  1395.     }
  1396.     if (info.deleteData == (ClientData) procPtr) {
  1397.         info.deleteData = (ClientData) new;
  1398.     }
  1399.     Tcl_SetCommandInfoFromToken(token, &info);
  1401.     procPtr->refCount--;
  1402.     *procPtrPtr = procPtr = new;
  1403. }
  1404.   iPtr->compiledProcPtr = procPtr;
  1405.  
  1406.   result = Tcl_PushCallFrame(interp, &frame,
  1407. (Tcl_Namespace*)nsPtr, /* isProcCallFrame */ 0);
  1408.  
  1409.   if (result == TCL_OK) {
  1410. #ifdef TCL_TIP280
  1411.     /* TIP #280. We get the invoking context from the cmdFrame
  1412.      * which was saved by 'Tcl_ProcObjCmd' (using linePBodyPtr).
  1413.      */
  1415.     Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->linePBodyPtr, (char *) procPtr);
  1417.     /* Constructed saved frame has body as word 0. See Tcl_ProcObjCmd.
  1418.      */
  1419.     iPtr->invokeWord        = 0;
  1420.     iPtr->invokeCmdFramePtr = (hePtr
  1421.        ? (CmdFrame*) Tcl_GetHashValue (hePtr)
  1422.        : NULL);
  1423. #endif
  1424.     result = tclByteCodeType.setFromAnyProc(interp, bodyPtr);
  1425. #ifdef TCL_TIP280
  1426.     iPtr->invokeCmdFramePtr = NULL;
  1427. #endif
  1428.     Tcl_PopCallFrame(interp);
  1429. }
  1430.  
  1431.   iPtr->compiledProcPtr = saveProcPtr;
  1432.  
  1433.   if (result != TCL_OK) {
  1434.       if (result == TCL_ERROR) {
  1435. char buf[100 + TCL_INTEGER_SPACE];
  1437. numChars = strlen(procName);
  1438.   ellipsis = "";
  1439.   if (numChars > 50) {
  1440.       numChars = 50;
  1441.       ellipsis = "...";
  1442.   }
  1443. while ( (procName[numChars] & 0xC0) == 0x80 ) {
  1444.             /*
  1445.      * Back up truncation point so that we don't truncate
  1446.      * in the middle of a multi-byte character (in UTF-8)
  1447.      */
  1448.     numChars--;
  1449.     ellipsis = "...";
  1450. }
  1451.   sprintf(buf, "n    (compiling %s "%.*s%s", line %d)",
  1452.   description, numChars, procName, ellipsis,
  1453.   interp->errorLine);
  1454.   Tcl_AddObjErrorInfo(interp, buf, -1);
  1455.       }
  1456.       return result;
  1457.   }
  1458.     } else if (codePtr->nsEpoch != nsPtr->resolverEpoch) {
  1459.  
  1460. /*
  1461.  * The resolver epoch has changed, but we only need to invalidate
  1462.  * the resolver cache.
  1463.  */
  1465. for (localPtr = procPtr->firstLocalPtr;  localPtr != NULL;
  1466.     localPtr = localPtr->nextPtr) {
  1467.     localPtr->flags &= ~(VAR_RESOLVED);
  1468.     if (localPtr->resolveInfo) {
  1469. if (localPtr->resolveInfo->deleteProc) {
  1470.     localPtr->resolveInfo->deleteProc(localPtr->resolveInfo);
  1471. } else {
  1472.     ckfree((char*)localPtr->resolveInfo);
  1473. }
  1474. localPtr->resolveInfo = NULL;
  1475.     }
  1476. }
  1477.     }
  1478.     return TCL_OK;
  1479. }
  1481. /*
  1482.  *----------------------------------------------------------------------
  1483.  *
  1484.  * ProcessProcResultCode --
  1485.  *
  1486.  * Procedure called by TclObjInterpProc to process a return code other
  1487.  * than TCL_OK returned by a Tcl procedure.
  1488.  *
  1489.  * Results:
  1490.  * Depending on the argument return code, the result returned is
  1491.  * another return code and the interpreter's result is set to a value
  1492.  * to supplement that return code.
  1493.  *
  1494.  * Side effects:
  1495.  * If the result returned is TCL_ERROR, traceback information about
  1496.  * the procedure just executed is appended to the interpreter's
  1497.  * "errorInfo" variable.
  1498.  *
  1499.  *----------------------------------------------------------------------
  1500.  */
  1502. static int
  1503. ProcessProcResultCode(interp, procName, nameLen, returnCode)
  1504.     Tcl_Interp *interp; /* The interpreter in which the procedure
  1505.  * was called and returned returnCode. */
  1506.     char *procName; /* Name of the procedure. Used for error
  1507.  * messages and trace information. */
  1508.     int nameLen; /* Number of bytes in procedure's name. */
  1509.     int returnCode; /* The unexpected result code. */
  1510. {
  1511.     Interp *iPtr = (Interp *) interp;
  1512.     char msg[100 + TCL_INTEGER_SPACE];
  1513.     char *ellipsis = "";
  1515.     if (returnCode == TCL_OK) {
  1516. return TCL_OK;
  1517.     }
  1518.     if ((returnCode > TCL_CONTINUE) || (returnCode < TCL_OK)) {
  1519. return returnCode;
  1520.     }
  1521.     if (returnCode == TCL_RETURN) {
  1522. return TclUpdateReturnInfo(iPtr);
  1523.     } 
  1524.     if (returnCode != TCL_ERROR) {
  1525. Tcl_ResetResult(interp);
  1526. Tcl_AppendToObj(Tcl_GetObjResult(interp), ((returnCode == TCL_BREAK) 
  1527. ? "invoked "break" outside of a loop"
  1528. : "invoked "continue" outside of a loop"), -1);
  1529.     }
  1530.     if (nameLen > 60) {
  1531. nameLen = 60;
  1532. ellipsis = "...";
  1533.     }
  1534.     while ( (procName[nameLen] & 0xC0) == 0x80 ) {
  1535.         /*
  1536.  * Back up truncation point so that we don't truncate in the
  1537.  * middle of a multi-byte character (in UTF-8)
  1538.  */
  1539. nameLen--;
  1540. ellipsis = "...";
  1541.     }
  1542.     sprintf(msg, "n    (procedure "%.*s%s" line %d)", nameLen, procName,
  1543.     ellipsis, iPtr->errorLine);
  1544.     Tcl_AddObjErrorInfo(interp, msg, -1);
  1545.     return TCL_ERROR;
  1546. }
  1548. /*
  1549.  *----------------------------------------------------------------------
  1550.  *
  1551.  * TclProcDeleteProc --
  1552.  *
  1553.  * This procedure is invoked just before a command procedure is
  1554.  * removed from an interpreter.  Its job is to release all the
  1555.  * resources allocated to the procedure.
  1556.  *
  1557.  * Results:
  1558.  * None.
  1559.  *
  1560.  * Side effects:
  1561.  * Memory gets freed, unless the procedure is actively being
  1562.  * executed.  In this case the cleanup is delayed until the
  1563.  * last call to the current procedure completes.
  1564.  *
  1565.  *----------------------------------------------------------------------
  1566.  */
  1568. void
  1569. TclProcDeleteProc(clientData)
  1570.     ClientData clientData; /* Procedure to be deleted. */
  1571. {
  1572.     Proc *procPtr = (Proc *) clientData;
  1574.     procPtr->refCount--;
  1575.     if (procPtr->refCount <= 0) {
  1576. TclProcCleanupProc(procPtr);
  1577.     }
  1578. }
  1580. /*
  1581.  *----------------------------------------------------------------------
  1582.  *
  1583.  * TclProcCleanupProc --
  1584.  *
  1585.  * This procedure does all the real work of freeing up a Proc
  1586.  * structure.  It's called only when the structure's reference
  1587.  * count becomes zero.
  1588.  *
  1589.  * Results:
  1590.  * None.
  1591.  *
  1592.  * Side effects:
  1593.  * Memory gets freed.
  1594.  *
  1595.  *----------------------------------------------------------------------
  1596.  */
  1598. void
  1599. TclProcCleanupProc(procPtr)
  1600.     register Proc *procPtr; /* Procedure to be deleted. */
  1601. {
  1602.     register CompiledLocal *localPtr;
  1603.     Tcl_Obj *bodyPtr = procPtr->bodyPtr;
  1604.     Tcl_Obj *defPtr;
  1605.     Tcl_ResolvedVarInfo *resVarInfo;
  1606. #ifdef TCL_TIP280
  1607.     Tcl_HashEntry* hePtr = NULL;
  1608.     CmdFrame*      cfPtr = NULL;
  1609.     Interp*        iPtr  = procPtr->iPtr;
  1610. #endif
  1612.     if (bodyPtr != NULL) {
  1613. Tcl_DecrRefCount(bodyPtr);
  1614.     }
  1615.     for (localPtr = procPtr->firstLocalPtr;  localPtr != NULL;  ) {
  1616. CompiledLocal *nextPtr = localPtr->nextPtr;
  1618.         resVarInfo = localPtr->resolveInfo;
  1619. if (resVarInfo) {
  1620.     if (resVarInfo->deleteProc) {
  1621. (*resVarInfo->deleteProc)(resVarInfo);
  1622.     } else {
  1623. ckfree((char *) resVarInfo);
  1624.     }
  1625.         }
  1627. if (localPtr->defValuePtr != NULL) {
  1628.     defPtr = localPtr->defValuePtr;
  1629.     Tcl_DecrRefCount(defPtr);
  1630. }
  1631. ckfree((char *) localPtr);
  1632. localPtr = nextPtr;
  1633.     }
  1634.     ckfree((char *) procPtr);
  1636. #ifdef TCL_TIP280
  1637.     /* TIP #280. Release the location data associated with this Proc
  1638.      * structure, if any. The interpreter may not exist (For example for
  1639.      * procbody structurues created by tbcload.
  1640.      */
  1642.     if (!iPtr) return;
  1644.     hePtr = Tcl_FindHashEntry (iPtr->linePBodyPtr, (char *) procPtr);
  1645.     if (!hePtr) return;
  1647.     cfPtr = (CmdFrame*) Tcl_GetHashValue (hePtr);
  1649.     if (cfPtr->type == TCL_LOCATION_SOURCE) {
  1650.         Tcl_DecrRefCount (cfPtr->data.eval.path);
  1651. cfPtr->data.eval.path = NULL;
  1652.     }
  1653.     ckfree ((char*) cfPtr->line); cfPtr->line = NULL;
  1654.     ckfree ((char*) cfPtr);
  1655.     Tcl_DeleteHashEntry (hePtr);
  1656. #endif
  1657. }
  1659. /*
  1660.  *----------------------------------------------------------------------
  1661.  *
  1662.  * TclUpdateReturnInfo --
  1663.  *
  1664.  * This procedure is called when procedures return, and at other
  1665.  * points where the TCL_RETURN code is used.  It examines fields
  1666.  * such as iPtr->returnCode and iPtr->errorCode and modifies
  1667.  * the real return status accordingly.
  1668.  *
  1669.  * Results:
  1670.  * The return value is the true completion code to use for
  1671.  * the procedure, instead of TCL_RETURN.
  1672.  *
  1673.  * Side effects:
  1674.  * The errorInfo and errorCode variables may get modified.
  1675.  *
  1676.  *----------------------------------------------------------------------
  1677.  */
  1679. int
  1680. TclUpdateReturnInfo(iPtr)
  1681.     Interp *iPtr; /* Interpreter for which TCL_RETURN
  1682.  * exception is being processed. */
  1683. {
  1684.     int code;
  1685.     char *errorCode;
  1686.     Tcl_Obj *objPtr;
  1688.     code = iPtr->returnCode;
  1689.     iPtr->returnCode = TCL_OK;
  1690.     if (code == TCL_ERROR) {
  1691. errorCode = ((iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE");
  1692. objPtr = Tcl_NewStringObj(errorCode, -1);
  1693. Tcl_IncrRefCount(objPtr);
  1694. Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorCode,
  1695.         NULL, objPtr, TCL_GLOBAL_ONLY);
  1696. Tcl_DecrRefCount(objPtr);
  1697. iPtr->flags |= ERROR_CODE_SET;
  1698. if (iPtr->errorInfo != NULL) {
  1699.     objPtr = Tcl_NewStringObj(iPtr->errorInfo, -1);
  1700.     Tcl_IncrRefCount(objPtr);
  1701.     Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorInfo,
  1702.     NULL, objPtr, TCL_GLOBAL_ONLY);
  1703.     Tcl_DecrRefCount(objPtr);
  1704.     iPtr->flags |= ERR_IN_PROGRESS;
  1705. }
  1706.     }
  1707.     return code;
  1708. }
  1710. /*
  1711.  *----------------------------------------------------------------------
  1712.  *
  1713.  * TclGetInterpProc --
  1714.  *
  1715.  *  Returns a pointer to the TclProcInterpProc procedure; this is different
  1716.  *  from the value obtained from the TclProcInterpProc reference on systems
  1717.  *  like Windows where import and export versions of a procedure exported
  1718.  *  by a DLL exist.
  1719.  *
  1720.  * Results:
  1721.  *  Returns the internal address of the TclProcInterpProc procedure.
  1722.  *
  1723.  * Side effects:
  1724.  *  None.
  1725.  *
  1726.  *----------------------------------------------------------------------
  1727.  */
  1729. TclCmdProcType
  1730. TclGetInterpProc()
  1731. {
  1732.     return (TclCmdProcType) TclProcInterpProc;
  1733. }
  1735. /*
  1736.  *----------------------------------------------------------------------
  1737.  *
  1738.  * TclGetObjInterpProc --
  1739.  *
  1740.  *  Returns a pointer to the TclObjInterpProc procedure; this is different
  1741.  *  from the value obtained from the TclObjInterpProc reference on systems
  1742.  *  like Windows where import and export versions of a procedure exported
  1743.  *  by a DLL exist.
  1744.  *
  1745.  * Results:
  1746.  *  Returns the internal address of the TclObjInterpProc procedure.
  1747.  *
  1748.  * Side effects:
  1749.  *  None.
  1750.  *
  1751.  *----------------------------------------------------------------------
  1752.  */
  1754. TclObjCmdProcType
  1755. TclGetObjInterpProc()
  1756. {
  1757.     return (TclObjCmdProcType) TclObjInterpProc;
  1758. }
  1760. /*
  1761.  *----------------------------------------------------------------------
  1762.  *
  1763.  * TclNewProcBodyObj --
  1764.  *
  1765.  *  Creates a new object, of type "procbody", whose internal
  1766.  *  representation is the given Proc struct.
  1767.  *  The newly created object's reference count is 0.
  1768.  *
  1769.  * Results:
  1770.  *  Returns a pointer to a newly allocated Tcl_Obj, 0 on error.
  1771.  *
  1772.  * Side effects:
  1773.  *  The reference count in the ByteCode attached to the Proc is bumped up
  1774.  *  by one, since the internal rep stores a pointer to it.
  1775.  *
  1776.  *----------------------------------------------------------------------
  1777.  */
  1779. Tcl_Obj *
  1780. TclNewProcBodyObj(procPtr)
  1781.     Proc *procPtr; /* the Proc struct to store as the internal
  1782.                          * representation. */
  1783. {
  1784.     Tcl_Obj *objPtr;
  1786.     if (!procPtr) {
  1787.         return (Tcl_Obj *) NULL;
  1788.     }
  1789.     
  1790.     objPtr = Tcl_NewStringObj("", 0);
  1792.     if (objPtr) {
  1793.         objPtr->typePtr = &tclProcBodyType;
  1794.         objPtr->internalRep.otherValuePtr = (VOID *) procPtr;
  1796.         procPtr->refCount++;
  1797.     }
  1799.     return objPtr;
  1800. }
  1802. /*
  1803.  *----------------------------------------------------------------------
  1804.  *
  1805.  * ProcBodyDup --
  1806.  *
  1807.  *  Tcl_ObjType's Dup function for the proc body object.
  1808.  *  Bumps the reference count on the Proc stored in the internal
  1809.  *  representation.
  1810.  *
  1811.  * Results:
  1812.  *  None.
  1813.  *
  1814.  * Side effects:
  1815.  *  Sets up the object in dupPtr to be a duplicate of the one in srcPtr.
  1816.  *
  1817.  *----------------------------------------------------------------------
  1818.  */
  1820. static void ProcBodyDup(srcPtr, dupPtr)
  1821.     Tcl_Obj *srcPtr; /* object to copy */
  1822.     Tcl_Obj *dupPtr; /* target object for the duplication */
  1823. {
  1824.     Proc *procPtr = (Proc *) srcPtr->internalRep.otherValuePtr;
  1825.     
  1826.     dupPtr->typePtr = &tclProcBodyType;
  1827.     dupPtr->internalRep.otherValuePtr = (VOID *) procPtr;
  1828.     procPtr->refCount++;
  1829. }
  1831. /*
  1832.  *----------------------------------------------------------------------
  1833.  *
  1834.  * ProcBodyFree --
  1835.  *
  1836.  *  Tcl_ObjType's Free function for the proc body object.
  1837.  *  The reference count on its Proc struct is decreased by 1; if the count
  1838.  *  reaches 0, the proc is freed.
  1839.  *
  1840.  * Results:
  1841.  *  None.
  1842.  *
  1843.  * Side effects:
  1844.  *  If the reference count on the Proc struct reaches 0, the struct is freed.
  1845.  *
  1846.  *----------------------------------------------------------------------
  1847.  */
  1849. static void
  1850. ProcBodyFree(objPtr)
  1851.     Tcl_Obj *objPtr; /* the object to clean up */
  1852. {
  1853.     Proc *procPtr = (Proc *) objPtr->internalRep.otherValuePtr;
  1854.     procPtr->refCount--;
  1855.     if (procPtr->refCount <= 0) {
  1856.         TclProcCleanupProc(procPtr);
  1857.     }
  1858. }
  1860. /*
  1861.  *----------------------------------------------------------------------
  1862.  *
  1863.  * ProcBodySetFromAny --
  1864.  *
  1865.  *  Tcl_ObjType's SetFromAny function for the proc body object.
  1866.  *  Calls panic.
  1867.  *
  1868.  * Results:
  1869.  *  Theoretically returns a TCL result code.
  1870.  *
  1871.  * Side effects:
  1872.  *  Calls panic, since we can't set the value of the object from a string
  1873.  *  representation (or any other internal ones).
  1874.  *
  1875.  *----------------------------------------------------------------------
  1876.  */
  1878. static int
  1879. ProcBodySetFromAny(interp, objPtr)
  1880.     Tcl_Interp *interp; /* current interpreter */
  1881.     Tcl_Obj *objPtr; /* object pointer */
  1882. {
  1883.     panic("called ProcBodySetFromAny");
  1885.     /*
  1886.      * this to keep compilers happy.
  1887.      */
  1888.     
  1889.     return TCL_OK;
  1890. }
  1892. /*
  1893.  *----------------------------------------------------------------------
  1894.  *
  1895.  * ProcBodyUpdateString --
  1896.  *
  1897.  *  Tcl_ObjType's UpdateString function for the proc body object.
  1898.  *  Calls panic.
  1899.  *
  1900.  * Results:
  1901.  *  None.
  1902.  *
  1903.  * Side effects:
  1904.  *  Calls panic, since we this type has no string representation.
  1905.  *
  1906.  *----------------------------------------------------------------------
  1907.  */
  1909. static void
  1910. ProcBodyUpdateString(objPtr)
  1911.     Tcl_Obj *objPtr; /* the object to update */
  1912. {
  1913.     panic("called ProcBodyUpdateString");
  1914. }
  1917. /*
  1918.  *----------------------------------------------------------------------
  1919.  *
  1920.  * TclCompileNoOp --
  1921.  *
  1922.  * Procedure called to compile noOp's
  1923.  *
  1924.  * Results:
  1925.  * The return value is TCL_OK, indicating successful compilation.
  1926.  *
  1927.  * Side effects:
  1928.  * Instructions are added to envPtr to execute a noOp at runtime.
  1929.  *
  1930.  *----------------------------------------------------------------------
  1931.  */
  1933. static int
  1934. TclCompileNoOp(interp, parsePtr, envPtr)
  1935.     Tcl_Interp *interp;         /* Used for error reporting. */
  1936.     Tcl_Parse *parsePtr;        /* Points to a parse structure for the
  1937.                                  * command created by Tcl_ParseCommand. */
  1938.     CompileEnv *envPtr;         /* Holds resulting instructions. */
  1939. {
  1940.     Tcl_Token *tokenPtr;
  1941.     int i, code;
  1942.     int savedStackDepth = envPtr->currStackDepth;
  1944.     tokenPtr = parsePtr->tokenPtr;
  1945.     for(i = 1; i < parsePtr->numWords; i++) {
  1946. tokenPtr = tokenPtr + tokenPtr->numComponents + 1;
  1947. envPtr->currStackDepth = savedStackDepth;
  1949. if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { 
  1950.     code = TclCompileTokens(interp, tokenPtr+1,
  1951.             tokenPtr->numComponents, envPtr);
  1952.     if (code != TCL_OK) {
  1953. return code;
  1954.     }
  1955.     TclEmitOpcode(INST_POP, envPtr);
  1956. } 
  1957.     }
  1958.     envPtr->currStackDepth = savedStackDepth;
  1959.     TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr);
  1960.     return TCL_OK;
  1961. }
  1963. /*
  1964.  * Local Variables:
  1965.  * mode: c
  1966.  * c-basic-offset: 4
  1967.  * fill-column: 78
  1968.  * End:
  1969.  */