home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tcl8.0 / generic / tclProc.c < prev    next >
Encoding:
C/C++ Source or Header  |  1997-08-15  |  28.8 KB  |  1,043 lines  |  [TEXT/CWIE]
  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-1996 Sun Microsystems, Inc.
  9.  *
  10.  * See the file "license.terms" for information on usage and redistribution
  11.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12.  *
  13.  * SCCS: @(#) tclProc.c 1.115 97/08/12 13:36:11
  14.  */
  15.  
  16. #include "tclInt.h"
  17. #include "tclCompile.h"
  18.  
  19. /*
  20.  * Forward references to procedures defined later in this file:
  21.  */
  22.  
  23. static void    CleanupProc _ANSI_ARGS_((Proc *procPtr));
  24. static  int    InterpProc _ANSI_ARGS_((ClientData clientData,
  25.             Tcl_Interp *interp, int argc, char **argv));
  26. static  void    ProcDeleteProc _ANSI_ARGS_((ClientData clientData));
  27.  
  28. /*
  29.  *----------------------------------------------------------------------
  30.  *
  31.  * Tcl_ProcObjCmd --
  32.  *
  33.  *    This object-based procedure is invoked to process the "proc" Tcl 
  34.  *    command. See the user documentation for details on what it does.
  35.  *
  36.  * Results:
  37.  *    A standard Tcl object result value.
  38.  *
  39.  * Side effects:
  40.  *    A new procedure gets created.
  41.  *
  42.  *----------------------------------------------------------------------
  43.  */
  44.  
  45.     /* ARGSUSED */
  46. int
  47. Tcl_ProcObjCmd(dummy, interp, objc, objv)
  48.     ClientData dummy;        /* Not used. */
  49.     Tcl_Interp *interp;        /* Current interpreter. */
  50.     int objc;            /* Number of arguments. */
  51.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  52. {
  53.     register Interp *iPtr = (Interp *) interp;
  54.     register Proc *procPtr;
  55.     char *fullName, *procName, *args, *bytes, *p;
  56.     char **argArray = NULL;
  57.     Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
  58.     Tcl_Obj *defPtr, *bodyPtr;
  59.     Tcl_Command cmd;
  60.     Tcl_DString ds;
  61.     int numArgs, length, result, i;
  62.     register CompiledLocal *localPtr;
  63.  
  64.     if (objc != 4) {
  65.     Tcl_WrongNumArgs(interp, 1, objv, "name args body");
  66.     return TCL_ERROR;
  67.     }
  68.  
  69.     /*
  70.      * Determine the namespace where the procedure should reside. Unless
  71.      * the command name includes namespace qualifiers, this will be the
  72.      * current namespace.
  73.      */
  74.     
  75.     fullName = Tcl_GetStringFromObj(objv[1], (int *) NULL);
  76.     result = TclGetNamespaceForQualName(interp, fullName,
  77.         (Namespace *) NULL, TCL_LEAVE_ERR_MSG,
  78.             &nsPtr, &altNsPtr, &cxtNsPtr, &procName);
  79.     if (result != TCL_OK) {
  80.         return result;
  81.     }
  82.     if (nsPtr == NULL) {
  83.         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  84.         "can't create procedure \"", fullName,
  85.         "\": unknown namespace", (char *) NULL);
  86.         return TCL_ERROR;
  87.     }
  88.     if (procName == NULL) {
  89.     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  90.         "can't create procedure \"", fullName,
  91.         "\": bad procedure name", (char *) NULL);
  92.         return TCL_ERROR;
  93.     }
  94.     if ((nsPtr != iPtr->globalNsPtr)
  95.         && (procName != NULL) && (procName[0] == ':')) {
  96.     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  97.         "can't create procedure \"", procName,
  98.         "\" in non-global namespace with name starting with \":\"",
  99.             (char *) NULL);
  100.         return TCL_ERROR;
  101.     }
  102.  
  103.     /*
  104.      * If the procedure's body object is shared because its string value is
  105.      * identical to, e.g., the body of another procedure, we must create a
  106.      * private copy for this procedure to use. Such sharing of procedure
  107.      * bodies is rare but can cause problems. A procedure body is compiled
  108.      * in a context that includes the number of compiler-allocated "slots"
  109.      * for local variables. Each formal parameter is given a local variable
  110.      * slot (the "procPtr->numCompiledLocals = numArgs" assignment
  111.      * below). This means that the same code can not be shared by two
  112.      * procedures that have a different number of arguments, even if their
  113.      * bodies are identical. Note that we don't use Tcl_DuplicateObj since
  114.      * we would not want any bytecode internal representation.
  115.      */
  116.  
  117.     bodyPtr = objv[3];
  118.     if (Tcl_IsShared(bodyPtr)) {
  119.     bytes = Tcl_GetStringFromObj(bodyPtr, &length);
  120.     bodyPtr = Tcl_NewStringObj(bytes, length);
  121.     }
  122.  
  123.     /*
  124.      * Create and initialize a Proc structure for the procedure. Note that
  125.      * we initialize its cmdPtr field below after we've created the command
  126.      * for the procedure. We increment the ref count of the procedure's
  127.      * body object since there will be a reference to it in the Proc
  128.      * structure.
  129.      */
  130.     
  131.     Tcl_IncrRefCount(bodyPtr);
  132.  
  133.     procPtr = (Proc *) ckalloc(sizeof(Proc));
  134.     procPtr->iPtr = iPtr;
  135.     procPtr->refCount = 1;
  136.     procPtr->bodyPtr = bodyPtr;
  137.     procPtr->numArgs  = 0;    /* actual argument count is set below. */
  138.     procPtr->numCompiledLocals = 0;
  139.     procPtr->firstLocalPtr = NULL;
  140.     procPtr->lastLocalPtr = NULL;
  141.     
  142.     /*
  143.      * Break up the argument list into argument specifiers, then process
  144.      * each argument specifier.
  145.      * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULLS.
  146.      */
  147.  
  148.     args = Tcl_GetStringFromObj(objv[2], &length);
  149.     result = Tcl_SplitList(interp, args, &numArgs, &argArray);
  150.     if (result != TCL_OK) {
  151.     goto procError;
  152.     }
  153.     
  154.     procPtr->numArgs = numArgs;
  155.     procPtr->numCompiledLocals = numArgs;
  156.     for (i = 0;  i < numArgs;  i++) {
  157.     int fieldCount, nameLength, valueLength;
  158.     char **fieldValues;
  159.  
  160.     /*
  161.      * Now divide the specifier up into name and default.
  162.      */
  163.  
  164.     result = Tcl_SplitList(interp, argArray[i], &fieldCount,
  165.         &fieldValues);
  166.     if (result != TCL_OK) {
  167.         goto procError;
  168.     }
  169.     if (fieldCount > 2) {
  170.         ckfree((char *) fieldValues);
  171.         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  172.             "too many fields in argument specifier \"",
  173.             argArray[i], "\"", (char *) NULL);
  174.         goto procError;
  175.     }
  176.     if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
  177.         ckfree((char *) fieldValues);
  178.         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  179.             "procedure \"", fullName,
  180.             "\" has argument with no name", (char *) NULL);
  181.         goto procError;
  182.     }
  183.     
  184.     nameLength = strlen(fieldValues[0]);
  185.     if (fieldCount == 2) {
  186.         valueLength = strlen(fieldValues[1]);
  187.     } else {
  188.         valueLength = 0;
  189.     }
  190.  
  191.     /*
  192.      * Check that the formal parameter name is a scalar.
  193.      */
  194.  
  195.     p = fieldValues[0];
  196.     while (*p != '\0') {
  197.         if (*p == '(') {
  198.         char *q = p;
  199.         do {
  200.             q++;
  201.         } while (*q != '\0');
  202.         q--;
  203.         if (*q == ')') { /* we have an array element */
  204.             Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  205.                     "procedure \"", fullName,
  206.                     "\" has formal parameter \"", fieldValues[0],
  207.                 "\" that is an array element",
  208.                 (char *) NULL);
  209.             ckfree((char *) fieldValues);
  210.             goto procError;
  211.         }
  212.         }
  213.         p++;
  214.     }
  215.  
  216.     /*
  217.      * Allocate an entry in the runtime procedure frame's array of local
  218.      * variables for the argument. 
  219.      */
  220.  
  221.     localPtr = (CompiledLocal *) ckalloc((unsigned) 
  222.             (sizeof(CompiledLocal) - sizeof(localPtr->name)
  223.         + nameLength+1));
  224.     if (procPtr->firstLocalPtr == NULL) {
  225.         procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
  226.     } else {
  227.         procPtr->lastLocalPtr->nextPtr = localPtr;
  228.         procPtr->lastLocalPtr = localPtr;
  229.     }
  230.     localPtr->nextPtr = NULL;
  231.     localPtr->nameLength = nameLength;
  232.     localPtr->frameIndex = i;
  233.     localPtr->isArg  = 1;
  234.     localPtr->isTemp = 0;
  235.     localPtr->flags = VAR_SCALAR;
  236.     if (fieldCount == 2) {
  237.         localPtr->defValuePtr =
  238.             Tcl_NewStringObj(fieldValues[1], valueLength);
  239.         Tcl_IncrRefCount(localPtr->defValuePtr);
  240.     } else {
  241.         localPtr->defValuePtr = NULL;
  242.     }
  243.     strcpy(localPtr->name, fieldValues[0]);
  244.     
  245.     ckfree((char *) fieldValues);
  246.     }
  247.  
  248.     /*
  249.      * Now create a command for the procedure. This will initially be in
  250.      * the current namespace unless the procedure's name included namespace
  251.      * qualifiers. To create the new command in the right namespace, we
  252.      * generate a fully qualified name for it.
  253.      */
  254.  
  255.     Tcl_DStringInit(&ds);
  256.     if (nsPtr != iPtr->globalNsPtr) {
  257.     Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
  258.     Tcl_DStringAppend(&ds, "::", 2);
  259.     }
  260.     Tcl_DStringAppend(&ds, procName, -1);
  261.     
  262.     Tcl_CreateCommand(interp, Tcl_DStringValue(&ds), InterpProc,
  263.         (ClientData) procPtr, ProcDeleteProc);
  264.     cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds),
  265.         TclObjInterpProc, (ClientData) procPtr, ProcDeleteProc);
  266.  
  267.     /*
  268.      * Now initialize the new procedure's cmdPtr field. This will be used
  269.      * later when the procedure is called to determine what namespace the
  270.      * procedure will run in. This will be different than the current
  271.      * namespace if the proc was renamed into a different namespace.
  272.      */
  273.     
  274.     procPtr->cmdPtr = (Command *) cmd;
  275.     
  276.     ckfree((char *) argArray);
  277.     return TCL_OK;
  278.  
  279.     procError:
  280.     Tcl_DecrRefCount(bodyPtr);
  281.     while (procPtr->firstLocalPtr != NULL) {
  282.     localPtr = procPtr->firstLocalPtr;
  283.     procPtr->firstLocalPtr = localPtr->nextPtr;
  284.     
  285.     defPtr = localPtr->defValuePtr;
  286.     if (defPtr != NULL) {
  287.         Tcl_DecrRefCount(defPtr);
  288.     }
  289.     
  290.     ckfree((char *) localPtr);
  291.     }
  292.     ckfree((char *) procPtr);
  293.     if (argArray != NULL) {
  294.     ckfree((char *) argArray);
  295.     }
  296.     return TCL_ERROR;
  297. }
  298.  
  299. /*
  300.  *----------------------------------------------------------------------
  301.  *
  302.  * TclGetFrame --
  303.  *
  304.  *    Given a description of a procedure frame, such as the first
  305.  *    argument to an "uplevel" or "upvar" command, locate the
  306.  *    call frame for the appropriate level of procedure.
  307.  *
  308.  * Results:
  309.  *    The return value is -1 if an error occurred in finding the
  310.  *    frame (in this case an error message is left in interp->result).
  311.  *    1 is returned if string was either a number or a number preceded
  312.  *    by "#" and it specified a valid frame.  0 is returned if string
  313.  *    isn't one of the two things above (in this case, the lookup
  314.  *    acts as if string were "1").  The variable pointed to by
  315.  *    framePtrPtr is filled in with the address of the desired frame
  316.  *    (unless an error occurs, in which case it isn't modified).
  317.  *
  318.  * Side effects:
  319.  *    None.
  320.  *
  321.  *----------------------------------------------------------------------
  322.  */
  323.  
  324. int
  325. TclGetFrame(interp, string, framePtrPtr)
  326.     Tcl_Interp *interp;        /* Interpreter in which to find frame. */
  327.     char *string;        /* String describing frame. */
  328.     CallFrame **framePtrPtr;    /* Store pointer to frame here (or NULL
  329.                  * if global frame indicated). */
  330. {
  331.     register Interp *iPtr = (Interp *) interp;
  332.     int curLevel, level, result;
  333.     CallFrame *framePtr;
  334.  
  335.     /*
  336.      * Parse string to figure out which level number to go to.
  337.      */
  338.  
  339.     result = 1;
  340.     curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level;
  341.     if (*string == '#') {
  342.     if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) {
  343.         return -1;
  344.     }
  345.     if (level < 0) {
  346.         levelError:
  347.         Tcl_AppendResult(interp, "bad level \"", string, "\"",
  348.             (char *) NULL);
  349.         return -1;
  350.     }
  351.     } else if (isdigit(UCHAR(*string))) {
  352.     if (Tcl_GetInt(interp, string, &level) != TCL_OK) {
  353.         return -1;
  354.     }
  355.     level = curLevel - level;
  356.     } else {
  357.     level = curLevel - 1;
  358.     result = 0;
  359.     }
  360.  
  361.     /*
  362.      * Figure out which frame to use, and modify the interpreter so
  363.      * its variables come from that frame.
  364.      */
  365.  
  366.     if (level == 0) {
  367.     framePtr = NULL;
  368.     } else {
  369.     for (framePtr = iPtr->varFramePtr; framePtr != NULL;
  370.         framePtr = framePtr->callerVarPtr) {
  371.         if (framePtr->level == level) {
  372.         break;
  373.         }
  374.     }
  375.     if (framePtr == NULL) {
  376.         goto levelError;
  377.     }
  378.     }
  379.     *framePtrPtr = framePtr;
  380.     return result;
  381. }
  382.  
  383. /*
  384.  *----------------------------------------------------------------------
  385.  *
  386.  * Tcl_UplevelObjCmd --
  387.  *
  388.  *    This object procedure is invoked to process the "uplevel" Tcl
  389.  *    command. See the user documentation for details on what it does.
  390.  *
  391.  * Results:
  392.  *    A standard Tcl object result value.
  393.  *
  394.  * Side effects:
  395.  *    See the user documentation.
  396.  *
  397.  *----------------------------------------------------------------------
  398.  */
  399.  
  400.     /* ARGSUSED */
  401. int
  402. Tcl_UplevelObjCmd(dummy, interp, objc, objv)
  403.     ClientData dummy;        /* Not used. */
  404.     Tcl_Interp *interp;        /* Current interpreter. */
  405.     int objc;            /* Number of arguments. */
  406.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  407. {
  408.     register Interp *iPtr = (Interp *) interp;
  409.     char *optLevel;
  410.     int length, result;
  411.     CallFrame *savedVarFramePtr, *framePtr;
  412.  
  413.     if (objc < 2) {
  414.     uplevelSyntax:
  415.     Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?");
  416.     return TCL_ERROR;
  417.     }
  418.  
  419.     /*
  420.      * Find the level to use for executing the command.
  421.      * THIS FAILS IF THE OBJECT RESULT'S STRING REP CONTAINS A NULL.
  422.      */
  423.  
  424.     optLevel = Tcl_GetStringFromObj(objv[1], &length);
  425.     result = TclGetFrame(interp, optLevel, &framePtr);
  426.     if (result == -1) {
  427.     return TCL_ERROR;
  428.     }
  429.     objc -= (result+1);
  430.     if (objc == 0) {
  431.     goto uplevelSyntax;
  432.     }
  433.     objv += (result+1);
  434.  
  435.     /*
  436.      * Modify the interpreter state to execute in the given frame.
  437.      */
  438.  
  439.     savedVarFramePtr = iPtr->varFramePtr;
  440.     iPtr->varFramePtr = framePtr;
  441.  
  442.     /*
  443.      * Execute the residual arguments as a command.
  444.      */
  445.  
  446.     if (objc == 1) {
  447.     result = Tcl_EvalObj(interp, objv[0]);
  448.     } else {
  449.     Tcl_Obj *cmdObjPtr = Tcl_ConcatObj(objc, objv);
  450.     result = Tcl_EvalObj(interp, cmdObjPtr);
  451.     Tcl_DecrRefCount(cmdObjPtr); /* done with object */
  452.     }
  453.     if (result == TCL_ERROR) {
  454.     char msg[60];
  455.     sprintf(msg, "\n    (\"uplevel\" body line %d)", interp->errorLine);
  456.     Tcl_AddObjErrorInfo(interp, msg, -1);
  457.     }
  458.  
  459.     /*
  460.      * Restore the variable frame, and return.
  461.      */
  462.  
  463.     iPtr->varFramePtr = savedVarFramePtr;
  464.     return result;
  465. }
  466.  
  467. /*
  468.  *----------------------------------------------------------------------
  469.  *
  470.  * TclFindProc --
  471.  *
  472.  *    Given the name of a procedure, return a pointer to the
  473.  *    record describing the procedure.
  474.  *
  475.  * Results:
  476.  *    NULL is returned if the name doesn't correspond to any
  477.  *    procedure.  Otherwise the return value is a pointer to
  478.  *    the procedure's record.
  479.  *
  480.  * Side effects:
  481.  *    None.
  482.  *
  483.  *----------------------------------------------------------------------
  484.  */
  485.  
  486. Proc *
  487. TclFindProc(iPtr, procName)
  488.     Interp *iPtr;        /* Interpreter in which to look. */
  489.     char *procName;        /* Name of desired procedure. */
  490. {
  491.     Tcl_Command cmd;
  492.     Command *cmdPtr;
  493.  
  494.     cmd = Tcl_FindCommand((Tcl_Interp *) iPtr, procName,
  495.             (Tcl_Namespace *) NULL, /*flags*/ 0);
  496.     if (cmd == (Tcl_Command) NULL) {
  497.         return NULL;
  498.     }
  499.     cmdPtr = (Command *) cmd;
  500.     if (cmdPtr->proc != InterpProc) {
  501.     return NULL;
  502.     }
  503.     return (Proc *) cmdPtr->clientData;
  504. }
  505.  
  506. /*
  507.  *----------------------------------------------------------------------
  508.  *
  509.  * TclIsProc --
  510.  *
  511.  *    Tells whether a command is a Tcl procedure or not.
  512.  *
  513.  * Results:
  514.  *    If the given command is actuall a Tcl procedure, the
  515.  *    return value is the address of the record describing
  516.  *    the procedure.  Otherwise the return value is 0.
  517.  *
  518.  * Side effects:
  519.  *    None.
  520.  *
  521.  *----------------------------------------------------------------------
  522.  */
  523.  
  524. Proc *
  525. TclIsProc(cmdPtr)
  526.     Command *cmdPtr;        /* Command to test. */
  527. {
  528.     if (cmdPtr->proc == InterpProc) {
  529.     return (Proc *) cmdPtr->clientData;
  530.     }
  531.     return (Proc *) 0;
  532. }
  533.  
  534. /*
  535.  *----------------------------------------------------------------------
  536.  *
  537.  * InterpProc --
  538.  *
  539.  *    When a Tcl procedure gets invoked with an argc/argv array of
  540.  *    strings, this routine gets invoked to interpret the procedure.
  541.  *
  542.  * Results:
  543.  *    A standard Tcl result value, usually TCL_OK.
  544.  *
  545.  * Side effects:
  546.  *    Depends on the commands in the procedure.
  547.  *
  548.  *----------------------------------------------------------------------
  549.  */
  550.  
  551. static int
  552. InterpProc(clientData, interp, argc, argv)
  553.     ClientData clientData;    /* Record describing procedure to be
  554.                  * interpreted. */
  555.     Tcl_Interp *interp;        /* Interpreter in which procedure was
  556.                  * invoked. */
  557.     int argc;            /* Count of number of arguments to this
  558.                  * procedure. */
  559.     register char **argv;    /* Argument values. */
  560. {
  561.     register Tcl_Obj *objPtr;
  562.     register int i;
  563.     int result;
  564.  
  565.     /*
  566.      * This procedure generates an objv array for object arguments that hold
  567.      * the argv strings. It starts out with stack-allocated space but uses
  568.      * dynamically-allocated storage if needed.
  569.      */
  570.  
  571. #define NUM_ARGS 20
  572.     Tcl_Obj *(objStorage[NUM_ARGS]);
  573.     register Tcl_Obj **objv = objStorage;
  574.  
  575.     /*
  576.      * Create the object argument array "objv". Make sure objv is large
  577.      * enough to hold the objc arguments plus 1 extra for the zero
  578.      * end-of-objv word.
  579.      */
  580.  
  581.     if ((argc + 1) > NUM_ARGS) {
  582.     objv = (Tcl_Obj **)
  583.         ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *));
  584.     }
  585.  
  586.     for (i = 0;  i < argc;  i++) {
  587.     objv[i] = Tcl_NewStringObj(argv[i], -1);
  588.     Tcl_IncrRefCount(objv[i]);
  589.     }
  590.     objv[argc] = 0;
  591.  
  592.     /*
  593.      * Use TclObjInterpProc to actually interpret the procedure.
  594.      */
  595.  
  596.     result = TclObjInterpProc(clientData, interp, argc, objv);
  597.  
  598.     /*
  599.      * Move the interpreter's object result to the string result, 
  600.      * then reset the object result.
  601.      * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS.
  602.      */
  603.     
  604.     Tcl_SetResult(interp,
  605.         TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL),
  606.         TCL_VOLATILE);
  607.  
  608.     /*
  609.      * Decrement the ref counts on the objv elements since we are done
  610.      * with them.
  611.      */
  612.  
  613.     for (i = 0;  i < argc;  i++) {
  614.     objPtr = objv[i];
  615.     TclDecrRefCount(objPtr);
  616.     }
  617.     
  618.     /*
  619.      * Free the objv array if malloc'ed storage was used.
  620.      */
  621.  
  622.     if (objv != objStorage) {
  623.     ckfree((char *) objv);
  624.     }
  625.     return result;
  626. #undef NUM_ARGS
  627. }
  628.  
  629. /*
  630.  *----------------------------------------------------------------------
  631.  *
  632.  * TclObjInterpProc --
  633.  *
  634.  *    When a Tcl procedure gets invoked during bytecode evaluation, this 
  635.  *    object-based routine gets invoked to interpret the procedure.
  636.  *
  637.  * Results:
  638.  *    A standard Tcl object result value.
  639.  *
  640.  * Side effects:
  641.  *    Depends on the commands in the procedure.
  642.  *
  643.  *----------------------------------------------------------------------
  644.  */
  645.  
  646. int
  647. TclObjInterpProc(clientData, interp, objc, objv)
  648.     ClientData clientData;    /* Record describing procedure to be
  649.                  * interpreted. */
  650.     Tcl_Interp *interp;        /* Interpreter in which procedure was
  651.                  * invoked. */
  652.     int objc;            /* Count of number of arguments to this
  653.                  * procedure. */
  654.     Tcl_Obj *CONST objv[];    /* Argument value objects. */
  655. {
  656.     Interp *iPtr = (Interp *) interp;
  657.     Proc *procPtr = (Proc *) clientData;
  658.     Tcl_Obj *bodyPtr = procPtr->bodyPtr;
  659.     CallFrame frame;
  660.     register CallFrame *framePtr = &frame;
  661.     register Var *varPtr;
  662.     register CompiledLocal *localPtr;
  663.     Proc *saveProcPtr;
  664.     char *procName, *bytes;
  665.     int nameLen, localCt, numArgs, argCt, length, i, result;
  666.  
  667.     /*
  668.      * This procedure generates an array "compiledLocals" that holds the
  669.      * storage for local variables. It starts out with stack-allocated space
  670.      * but uses dynamically-allocated storage if needed.
  671.      */
  672.  
  673. #define NUM_LOCALS 20
  674.     Var localStorage[NUM_LOCALS];
  675.     Var *compiledLocals = localStorage;
  676.  
  677.     /*
  678.      * Get the procedure's name.
  679.      * THIS FAILS IF THE PROC NAME'S STRING REP HAS A NULL.
  680.      */
  681.     
  682.     procName = Tcl_GetStringFromObj(objv[0], &nameLen);
  683.  
  684.     /*
  685.      * If necessary, compile the procedure's body. The compiler will
  686.      * allocate frame slots for the procedure's non-argument local
  687.      * variables. If the ByteCode already exists, make sure it hasn't been
  688.      * invalidated by someone redefining a core command (this might make the
  689.      * compiled code wrong). Also, if the code was compiled in/for a
  690.      * different interpreter, we recompile it. Note that compiling the body
  691.      * might increase procPtr->numCompiledLocals if new local variables are
  692.      * found while compiling.
  693.      */
  694.  
  695.     if (bodyPtr->typePtr == &tclByteCodeType) {
  696.     ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr;
  697.     
  698.     if ((codePtr->iPtr != iPtr)
  699.             || (codePtr->compileEpoch != iPtr->compileEpoch)) {
  700.         tclByteCodeType.freeIntRepProc(bodyPtr);
  701.         bodyPtr->typePtr = (Tcl_ObjType *) NULL;
  702.     }
  703.     }
  704.     if (bodyPtr->typePtr != &tclByteCodeType) {
  705.     char buf[100];
  706.     int numChars;
  707.     char *ellipsis;
  708.     
  709.     if (tclTraceCompile >= 1) {
  710.         /*
  711.          * Display a line summarizing the top level command we
  712.          * are about to compile.
  713.          */
  714.  
  715.         numChars = nameLen;
  716.         ellipsis = "";
  717.         if (numChars > 50) {
  718.         numChars = 50;
  719.         ellipsis = "...";
  720.         }
  721.         fprintf(stdout, "Compiling body of proc \"%.*s%s\"\n",
  722.             numChars, procName, ellipsis);
  723.     }
  724.     
  725.     saveProcPtr = iPtr->compiledProcPtr;
  726.     iPtr->compiledProcPtr = procPtr;
  727.     result = tclByteCodeType.setFromAnyProc(interp, bodyPtr);
  728.     iPtr->compiledProcPtr = saveProcPtr;
  729.     
  730.     if (result != TCL_OK) {
  731.         if (result == TCL_ERROR) {
  732.         numChars = nameLen;
  733.         ellipsis = "";
  734.         if (numChars > 50) {
  735.             numChars = 50;
  736.             ellipsis = "...";
  737.         }
  738.         sprintf(buf, "\n    (compiling body of proc \"%.*s%s\", line %d)",
  739.             numChars, procName, ellipsis, interp->errorLine);
  740.         Tcl_AddObjErrorInfo(interp, buf, -1);
  741.         }
  742.         return result;
  743.     }
  744.     }
  745.  
  746.     /*
  747.      * Create the "compiledLocals" array. Make sure it is large enough to
  748.      * hold all the procedure's compiled local variables, including its
  749.      * formal parameters.
  750.      */
  751.  
  752.     localCt = procPtr->numCompiledLocals;
  753.     if (localCt > NUM_LOCALS) {
  754.     compiledLocals = (Var *) ckalloc((unsigned) localCt * sizeof(Var));
  755.     }
  756.     
  757.     /*
  758.      * Set up and push a new call frame for the new procedure invocation.
  759.      * This call frame will execute in the proc's namespace, which might
  760.      * be different than the current namespace. The proc's namespace is
  761.      * that of its command, which can change if the command is renamed
  762.      * from one namespace to another.
  763.      */
  764.  
  765.     result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr,
  766.             (Tcl_Namespace *) procPtr->cmdPtr->nsPtr,
  767.          /*isProcCallFrame*/ 1);
  768.     if (result != TCL_OK) {
  769.         return result;
  770.     }
  771.  
  772.     framePtr->objc = objc;
  773.     framePtr->objv = objv;  /* ref counts for args are incremented below */
  774.     framePtr->procPtr = procPtr;
  775.     framePtr->numCompiledLocals = localCt;
  776.     framePtr->compiledLocals = compiledLocals;
  777.  
  778.     /*
  779.      * Initialize the array of local variables stored in the call frame.
  780.      */
  781.  
  782.     varPtr = framePtr->compiledLocals;
  783.     for (localPtr = procPtr->firstLocalPtr;  localPtr != NULL;
  784.         localPtr = localPtr->nextPtr) {
  785.     varPtr->value.objPtr = NULL;
  786.     varPtr->name = localPtr->name; /* will be just '\0' if temp var */
  787.     varPtr->nsPtr = procPtr->cmdPtr->nsPtr;
  788.     varPtr->hPtr = NULL;
  789.     varPtr->refCount = 0;
  790.     varPtr->tracePtr = NULL;
  791.     varPtr->searchPtr = NULL;
  792.     varPtr->flags = (localPtr->flags | VAR_UNDEFINED);
  793.     varPtr++;
  794.     }
  795.  
  796.     /*
  797.      * Match and assign the call's actual parameters to the procedure's
  798.      * formal arguments. The formal arguments are described by the first
  799.      * numArgs entries in both the Proc structure's local variable list and
  800.      * the call frame's local variable array.
  801.      */
  802.  
  803.     numArgs = procPtr->numArgs;
  804.     varPtr = framePtr->compiledLocals;
  805.     localPtr = procPtr->firstLocalPtr;
  806.     argCt = objc;
  807.     for (i = 1, argCt -= 1;  i <= numArgs;  i++, argCt--) {
  808.     if (!localPtr->isArg) {
  809.         panic("TclObjInterpProc: local variable %s is not argument but should be",
  810.           localPtr->name);
  811.         return TCL_ERROR;
  812.     }
  813.     if (localPtr->isTemp) {
  814.         panic("TclObjInterpProc: local variable %d is temporary but should be an argument", i);
  815.         return TCL_ERROR;
  816.     }
  817.  
  818.     /*
  819.      * Handle the special case of the last formal being "args".  When
  820.      * it occurs, assign it a list consisting of all the remaining
  821.      * actual arguments.
  822.      */
  823.  
  824.     if ((i == numArgs) && ((localPtr->name[0] == 'a')
  825.             && (strcmp(localPtr->name, "args") == 0))) {
  826.         Tcl_Obj *listPtr = Tcl_NewListObj(argCt, &(objv[i]));
  827.         varPtr->value.objPtr = listPtr;
  828.         Tcl_IncrRefCount(listPtr); /* local var is a reference */
  829.         varPtr->flags &= ~VAR_UNDEFINED;
  830.         argCt = 0;
  831.         break;        /* done processing args */
  832.     } else if (argCt > 0) {
  833.         Tcl_Obj *objPtr = objv[i];
  834.         varPtr->value.objPtr = objPtr;
  835.         varPtr->flags &= ~VAR_UNDEFINED;
  836.         Tcl_IncrRefCount(objPtr);  /* since the local variable now has
  837.                     * another reference to object. */
  838.     } else if (localPtr->defValuePtr != NULL) {
  839.         Tcl_Obj *objPtr = localPtr->defValuePtr;
  840.         varPtr->value.objPtr = objPtr;
  841.         varPtr->flags &= ~VAR_UNDEFINED;
  842.         Tcl_IncrRefCount(objPtr);  /* since the local variable now has
  843.                     * another reference to object. */
  844.     } else {
  845.         Tcl_ResetResult(interp);
  846.         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  847.             "no value given for parameter \"", localPtr->name,
  848.             "\" to \"", Tcl_GetStringFromObj(objv[0], (int *) NULL),
  849.             "\"", (char *) NULL);
  850.         result = TCL_ERROR;
  851.         goto procDone;
  852.     }
  853.     varPtr++;
  854.     localPtr = localPtr->nextPtr;
  855.     }
  856.     if (argCt > 0) {
  857.     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  858.         "called \"", Tcl_GetStringFromObj(objv[0], (int *) NULL),
  859.         "\" with too many arguments", (char *) NULL);
  860.     result = TCL_ERROR;
  861.     goto procDone;
  862.     }
  863.  
  864.     /*
  865.      * Invoke the commands in the procedure's body.
  866.      */
  867.  
  868.     if (tclTraceExec >= 1) {
  869.     fprintf(stdout, "Calling proc ");
  870.     for (i = 0;  i < objc;  i++) {
  871.         bytes = Tcl_GetStringFromObj(objv[i], &length);
  872.         TclPrintSource(stdout, bytes, TclMin(length, 15));
  873.         fprintf(stdout, " ");
  874.     }
  875.     fprintf(stdout, "\n");
  876.     fflush(stdout);
  877.     }
  878.  
  879.     iPtr->returnCode = TCL_OK;
  880.     procPtr->refCount++;
  881.     result = Tcl_EvalObj(interp, procPtr->bodyPtr);
  882.     procPtr->refCount--;
  883.     if (procPtr->refCount <= 0) {
  884.     CleanupProc(procPtr);
  885.     }
  886.  
  887.     if (result != TCL_OK) {
  888.     if (result == TCL_RETURN) {
  889.         result = TclUpdateReturnInfo(iPtr);
  890.     } else if (result == TCL_ERROR) {
  891.         char msg[100];
  892.         sprintf(msg, "\n    (procedure \"%.50s\" line %d)",
  893.             procName, iPtr->errorLine);
  894.         Tcl_AddObjErrorInfo(interp, msg, -1);
  895.     } else if (result == TCL_BREAK) {
  896.         Tcl_ResetResult(interp);
  897.         Tcl_AppendToObj(Tcl_GetObjResult(interp),
  898.                 "invoked \"break\" outside of a loop", -1);
  899.         result = TCL_ERROR;
  900.     } else if (result == TCL_CONTINUE) {
  901.         Tcl_ResetResult(interp);
  902.         Tcl_AppendToObj(Tcl_GetObjResult(interp),
  903.             "invoked \"continue\" outside of a loop", -1);
  904.         result = TCL_ERROR;
  905.     }
  906.     }
  907.     
  908.     procDone:
  909.  
  910.     /*
  911.      * Pop and free the call frame for this procedure invocation.
  912.      */
  913.     
  914.     Tcl_PopCallFrame(interp);
  915.     
  916.     /*
  917.      * Free the compiledLocals array if malloc'ed storage was used.
  918.      */
  919.  
  920.     if (compiledLocals != localStorage) {
  921.     ckfree((char *) compiledLocals);
  922.     }
  923.     return result;
  924. #undef NUM_LOCALS
  925. }
  926.  
  927. /*
  928.  *----------------------------------------------------------------------
  929.  *
  930.  * ProcDeleteProc --
  931.  *
  932.  *    This procedure is invoked just before a command procedure is
  933.  *    removed from an interpreter.  Its job is to release all the
  934.  *    resources allocated to the procedure.
  935.  *
  936.  * Results:
  937.  *    None.
  938.  *
  939.  * Side effects:
  940.  *    Memory gets freed, unless the procedure is actively being
  941.  *    executed.  In this case the cleanup is delayed until the
  942.  *    last call to the current procedure completes.
  943.  *
  944.  *----------------------------------------------------------------------
  945.  */
  946.  
  947. static void
  948. ProcDeleteProc(clientData)
  949.     ClientData clientData;        /* Procedure to be deleted. */
  950. {
  951.     Proc *procPtr = (Proc *) clientData;
  952.  
  953.     procPtr->refCount--;
  954.     if (procPtr->refCount <= 0) {
  955.     CleanupProc(procPtr);
  956.     }
  957. }
  958.  
  959. /*
  960.  *----------------------------------------------------------------------
  961.  *
  962.  * CleanupProc --
  963.  *
  964.  *    This procedure does all the real work of freeing up a Proc
  965.  *    structure.  It's called only when the structure's reference
  966.  *    count becomes zero.
  967.  *
  968.  * Results:
  969.  *    None.
  970.  *
  971.  * Side effects:
  972.  *    Memory gets freed.
  973.  *
  974.  *----------------------------------------------------------------------
  975.  */
  976.  
  977. static void
  978. CleanupProc(procPtr)
  979.     register Proc *procPtr;        /* Procedure to be deleted. */
  980. {
  981.     register CompiledLocal *localPtr;
  982.     Tcl_Obj *bodyPtr = procPtr->bodyPtr;
  983.     Tcl_Obj *defPtr;
  984.  
  985.     if (bodyPtr != NULL) {
  986.     Tcl_DecrRefCount(bodyPtr);
  987.     }
  988.     for (localPtr = procPtr->firstLocalPtr;  localPtr != NULL;  ) {
  989.     CompiledLocal *nextPtr = localPtr->nextPtr;
  990.  
  991.     if (localPtr->defValuePtr != NULL) {
  992.         defPtr = localPtr->defValuePtr;
  993.         Tcl_DecrRefCount(defPtr);
  994.     }
  995.     ckfree((char *) localPtr);
  996.     localPtr = nextPtr;
  997.     }
  998.     ckfree((char *) procPtr);
  999. }
  1000.  
  1001. /*
  1002.  *----------------------------------------------------------------------
  1003.  *
  1004.  * TclUpdateReturnInfo --
  1005.  *
  1006.  *    This procedure is called when procedures return, and at other
  1007.  *    points where the TCL_RETURN code is used.  It examines fields
  1008.  *    such as iPtr->returnCode and iPtr->errorCode and modifies
  1009.  *    the real return status accordingly.
  1010.  *
  1011.  * Results:
  1012.  *    The return value is the true completion code to use for
  1013.  *    the procedure, instead of TCL_RETURN.
  1014.  *
  1015.  * Side effects:
  1016.  *    The errorInfo and errorCode variables may get modified.
  1017.  *
  1018.  *----------------------------------------------------------------------
  1019.  */
  1020.  
  1021. int
  1022. TclUpdateReturnInfo(iPtr)
  1023.     Interp *iPtr;        /* Interpreter for which TCL_RETURN
  1024.                  * exception is being processed. */
  1025. {
  1026.     int code;
  1027.  
  1028.     code = iPtr->returnCode;
  1029.     iPtr->returnCode = TCL_OK;
  1030.     if (code == TCL_ERROR) {
  1031.     Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode", (char *) NULL,
  1032.         (iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE",
  1033.         TCL_GLOBAL_ONLY);
  1034.     iPtr->flags |= ERROR_CODE_SET;
  1035.     if (iPtr->errorInfo != NULL) {
  1036.         Tcl_SetVar2((Tcl_Interp *) iPtr, "errorInfo", (char *) NULL,
  1037.             iPtr->errorInfo, TCL_GLOBAL_ONLY);
  1038.         iPtr->flags |= ERR_IN_PROGRESS;
  1039.     }
  1040.     }
  1041.     return code;
  1042. }
  1043.