home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / tkisrc04.zip / tcl / os2 / tclProc.c < prev    next >
C/C++ Source or Header  |  1998-08-07  |  17KB  |  659 lines
  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-1995 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.72 96/02/15 11:42:48
  14.  */
  15.  
  16. #include "tclInt.h"
  17.  
  18. /*
  19.  * Forward references to procedures defined later in this file:
  20.  */
  21.  
  22. static void    CleanupProc _ANSI_ARGS_((Proc *procPtr));
  23. static  int    InterpProc _ANSI_ARGS_((ClientData clientData,
  24.             Tcl_Interp *interp, int argc, char **argv));
  25. static  void    ProcDeleteProc _ANSI_ARGS_((ClientData clientData));
  26.  
  27. /*
  28.  *----------------------------------------------------------------------
  29.  *
  30.  * Tcl_ProcCmd --
  31.  *
  32.  *    This procedure is invoked to process the "proc" Tcl command.
  33.  *    See the user documentation for details on what it does.
  34.  *
  35.  * Results:
  36.  *    A standard Tcl result value.
  37.  *
  38.  * Side effects:
  39.  *    A new procedure gets created.
  40.  *
  41.  *----------------------------------------------------------------------
  42.  */
  43.  
  44.     /* ARGSUSED */
  45. int
  46. Tcl_ProcCmd(dummy, interp, argc, argv)
  47.     ClientData dummy;            /* Not used. */
  48.     Tcl_Interp *interp;            /* Current interpreter. */
  49.     int argc;                /* Number of arguments. */
  50.     char **argv;            /* Argument strings. */
  51. {
  52.     register Interp *iPtr = (Interp *) interp;
  53.     register Proc *procPtr;
  54.     int result, argCount, i;
  55.     char **argArray = NULL;
  56.     Arg *lastArgPtr;
  57.     register Arg *argPtr = NULL;    /* Initialization not needed, but
  58.                      * prevents compiler warning. */
  59.  
  60.     if (argc != 4) {
  61.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  62.         " name args body\"", (char *) NULL);
  63.     return TCL_ERROR;
  64.     }
  65.  
  66.     procPtr = (Proc *) ckalloc(sizeof(Proc));
  67.     procPtr->iPtr = iPtr;
  68.     procPtr->refCount = 1;
  69.     procPtr->command = (char *) ckalloc((unsigned) strlen(argv[3]) + 1);
  70.     strcpy(procPtr->command, argv[3]);
  71.     procPtr->argPtr = NULL;
  72.  
  73.     /*
  74.      * Break up the argument list into argument specifiers, then process
  75.      * each argument specifier.
  76.      */
  77.  
  78.     result = Tcl_SplitList(interp, argv[2], &argCount, &argArray);
  79.     if (result != TCL_OK) {
  80.     goto procError;
  81.     }
  82.     lastArgPtr = NULL;
  83.     for (i = 0; i < argCount; i++) {
  84.     int fieldCount, nameLength, valueLength;
  85.     char **fieldValues;
  86.  
  87.     /*
  88.      * Now divide the specifier up into name and default.
  89.      */
  90.  
  91.     result = Tcl_SplitList(interp, argArray[i], &fieldCount,
  92.         &fieldValues);
  93.     if (result != TCL_OK) {
  94.         goto procError;
  95.     }
  96.     if (fieldCount > 2) {
  97.         ckfree((char *) fieldValues);
  98.         Tcl_AppendResult(interp,
  99.             "too many fields in argument specifier \"",
  100.             argArray[i], "\"", (char *) NULL);
  101.         result = TCL_ERROR;
  102.         goto procError;
  103.     }
  104.     if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
  105.         ckfree((char *) fieldValues);
  106.         Tcl_AppendResult(interp, "procedure \"", argv[1],
  107.             "\" has argument with no name", (char *) NULL);
  108.         result = TCL_ERROR;
  109.         goto procError;
  110.     }
  111.     nameLength = strlen(fieldValues[0]) + 1;
  112.     if (fieldCount == 2) {
  113.         valueLength = strlen(fieldValues[1]) + 1;
  114.     } else {
  115.         valueLength = 0;
  116.     }
  117.     argPtr = (Arg *) ckalloc((unsigned)
  118.         (sizeof(Arg) - sizeof(argPtr->name) + nameLength
  119.         + valueLength));
  120.     if (lastArgPtr == NULL) {
  121.         procPtr->argPtr = argPtr;
  122.     } else {
  123.         lastArgPtr->nextPtr = argPtr;
  124.     }
  125.     lastArgPtr = argPtr;
  126.     argPtr->nextPtr = NULL;
  127.     strcpy(argPtr->name, fieldValues[0]);
  128.     if (fieldCount == 2) {
  129.         argPtr->defValue = argPtr->name + nameLength;
  130.         strcpy(argPtr->defValue, fieldValues[1]);
  131.     } else {
  132.         argPtr->defValue = NULL;
  133.     }
  134.     ckfree((char *) fieldValues);
  135.     }
  136.  
  137.     Tcl_CreateCommand(interp, argv[1], InterpProc, (ClientData) procPtr,
  138.         ProcDeleteProc);
  139.     ckfree((char *) argArray);
  140.     return TCL_OK;
  141.  
  142.     procError:
  143.     ckfree(procPtr->command);
  144.     while (procPtr->argPtr != NULL) {
  145.     argPtr = procPtr->argPtr;
  146.     procPtr->argPtr = argPtr->nextPtr;
  147.     ckfree((char *) argPtr);
  148.     }
  149.     ckfree((char *) procPtr);
  150.     if (argArray != NULL) {
  151.     ckfree((char *) argArray);
  152.     }
  153.     return result;
  154. }
  155.  
  156. /*
  157.  *----------------------------------------------------------------------
  158.  *
  159.  * TclGetFrame --
  160.  *
  161.  *    Given a description of a procedure frame, such as the first
  162.  *    argument to an "uplevel" or "upvar" command, locate the
  163.  *    call frame for the appropriate level of procedure.
  164.  *
  165.  * Results:
  166.  *    The return value is -1 if an error occurred in finding the
  167.  *    frame (in this case an error message is left in interp->result).
  168.  *    1 is returned if string was either a number or a number preceded
  169.  *    by "#" and it specified a valid frame.  0 is returned if string
  170.  *    isn't one of the two things above (in this case, the lookup
  171.  *    acts as if string were "1").  The variable pointed to by
  172.  *    framePtrPtr is filled in with the address of the desired frame
  173.  *    (unless an error occurs, in which case it isn't modified).
  174.  *
  175.  * Side effects:
  176.  *    None.
  177.  *
  178.  *----------------------------------------------------------------------
  179.  */
  180.  
  181. int
  182. TclGetFrame(interp, string, framePtrPtr)
  183.     Tcl_Interp *interp;        /* Interpreter in which to find frame. */
  184.     char *string;        /* String describing frame. */
  185.     CallFrame **framePtrPtr;    /* Store pointer to frame here (or NULL
  186.                  * if global frame indicated). */
  187. {
  188.     register Interp *iPtr = (Interp *) interp;
  189.     int curLevel, level, result;
  190.     CallFrame *framePtr;
  191.  
  192.     /*
  193.      * Parse string to figure out which level number to go to.
  194.      */
  195.  
  196.     result = 1;
  197.     curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level;
  198.     if (*string == '#') {
  199.     if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) {
  200.         return -1;
  201.     }
  202.     if (level < 0) {
  203.         levelError:
  204.         Tcl_AppendResult(interp, "bad level \"", string, "\"",
  205.             (char *) NULL);
  206.         return -1;
  207.     }
  208.     } else if (isdigit(UCHAR(*string))) {
  209.     if (Tcl_GetInt(interp, string, &level) != TCL_OK) {
  210.         return -1;
  211.     }
  212.     level = curLevel - level;
  213.     } else {
  214.     level = curLevel - 1;
  215.     result = 0;
  216.     }
  217.  
  218.     /*
  219.      * Figure out which frame to use, and modify the interpreter so
  220.      * its variables come from that frame.
  221.      */
  222.  
  223.     if (level == 0) {
  224.     framePtr = NULL;
  225.     } else {
  226.     for (framePtr = iPtr->varFramePtr; framePtr != NULL;
  227.         framePtr = framePtr->callerVarPtr) {
  228.         if (framePtr->level == level) {
  229.         break;
  230.         }
  231.     }
  232.     if (framePtr == NULL) {
  233.         goto levelError;
  234.     }
  235.     }
  236.     *framePtrPtr = framePtr;
  237.     return result;
  238. }
  239.  
  240. /*
  241.  *----------------------------------------------------------------------
  242.  *
  243.  * Tcl_UplevelCmd --
  244.  *
  245.  *    This procedure is invoked to process the "uplevel" Tcl command.
  246.  *    See the user documentation for details on what it does.
  247.  *
  248.  * Results:
  249.  *    A standard Tcl result value.
  250.  *
  251.  * Side effects:
  252.  *    See the user documentation.
  253.  *
  254.  *----------------------------------------------------------------------
  255.  */
  256.  
  257.     /* ARGSUSED */
  258. int
  259. Tcl_UplevelCmd(dummy, interp, argc, argv)
  260.     ClientData dummy;            /* Not used. */
  261.     Tcl_Interp *interp;            /* Current interpreter. */
  262.     int argc;                /* Number of arguments. */
  263.     char **argv;            /* Argument strings. */
  264. {
  265.     register Interp *iPtr = (Interp *) interp;
  266.     int result;
  267.     CallFrame *savedVarFramePtr, *framePtr;
  268.  
  269.     if (argc < 2) {
  270.     uplevelSyntax:
  271.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  272.         " ?level? command ?arg ...?\"", (char *) NULL);
  273.     return TCL_ERROR;
  274.     }
  275.  
  276.     /*
  277.      * Find the level to use for executing the command.
  278.      */
  279.  
  280.     result = TclGetFrame(interp, argv[1], &framePtr);
  281.     if (result == -1) {
  282.     return TCL_ERROR;
  283.     }
  284.     argc -= (result+1);
  285.     if (argc == 0) {
  286.     goto uplevelSyntax;
  287.     }
  288.     argv += (result+1);
  289.  
  290.     /*
  291.      * Modify the interpreter state to execute in the given frame.
  292.      */
  293.  
  294.     savedVarFramePtr = iPtr->varFramePtr;
  295.     iPtr->varFramePtr = framePtr;
  296.  
  297.     /*
  298.      * Execute the residual arguments as a command.
  299.      */
  300.  
  301.     if (argc == 1) {
  302.     result = Tcl_Eval(interp, argv[0]);
  303.     } else {
  304.     char *cmd;
  305.  
  306.     cmd = Tcl_Concat(argc, argv);
  307.     result = Tcl_Eval(interp, cmd);
  308.     ckfree(cmd);
  309.     }
  310.     if (result == TCL_ERROR) {
  311.     char msg[60];
  312.     sprintf(msg, "\n    (\"uplevel\" body line %d)", interp->errorLine);
  313.     Tcl_AddErrorInfo(interp, msg);
  314.     }
  315.  
  316.     /*
  317.      * Restore the variable frame, and return.
  318.      */
  319.  
  320.     iPtr->varFramePtr = savedVarFramePtr;
  321.     return result;
  322. }
  323.  
  324. /*
  325.  *----------------------------------------------------------------------
  326.  *
  327.  * TclFindProc --
  328.  *
  329.  *    Given the name of a procedure, return a pointer to the
  330.  *    record describing the procedure.
  331.  *
  332.  * Results:
  333.  *    NULL is returned if the name doesn't correspond to any
  334.  *    procedure.  Otherwise the return value is a pointer to
  335.  *    the procedure's record.
  336.  *
  337.  * Side effects:
  338.  *    None.
  339.  *
  340.  *----------------------------------------------------------------------
  341.  */
  342.  
  343. Proc *
  344. TclFindProc(iPtr, procName)
  345.     Interp *iPtr;        /* Interpreter in which to look. */
  346.     char *procName;        /* Name of desired procedure. */
  347. {
  348.     Tcl_HashEntry *hPtr;
  349.     Command *cmdPtr;
  350.  
  351.     hPtr = Tcl_FindHashEntry(&iPtr->commandTable, procName);
  352.     if (hPtr == NULL) {
  353.     return NULL;
  354.     }
  355.     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  356.     if (cmdPtr->proc != InterpProc) {
  357.     return NULL;
  358.     }
  359.     return (Proc *) cmdPtr->clientData;
  360. }
  361.  
  362. /*
  363.  *----------------------------------------------------------------------
  364.  *
  365.  * TclIsProc --
  366.  *
  367.  *    Tells whether a command is a Tcl procedure or not.
  368.  *
  369.  * Results:
  370.  *    If the given command is actuall a Tcl procedure, the
  371.  *    return value is the address of the record describing
  372.  *    the procedure.  Otherwise the return value is 0.
  373.  *
  374.  * Side effects:
  375.  *    None.
  376.  *
  377.  *----------------------------------------------------------------------
  378.  */
  379.  
  380. Proc *
  381. TclIsProc(cmdPtr)
  382.     Command *cmdPtr;        /* Command to test. */
  383. {
  384.     if (cmdPtr->proc == InterpProc) {
  385.     return (Proc *) cmdPtr->clientData;
  386.     }
  387.     return (Proc *) 0;
  388. }
  389.  
  390. /*
  391.  *----------------------------------------------------------------------
  392.  *
  393.  * InterpProc --
  394.  *
  395.  *    When a Tcl procedure gets invoked, this routine gets invoked
  396.  *    to interpret the procedure.
  397.  *
  398.  * Results:
  399.  *    A standard Tcl result value, usually TCL_OK.
  400.  *
  401.  * Side effects:
  402.  *    Depends on the commands in the procedure.
  403.  *
  404.  *----------------------------------------------------------------------
  405.  */
  406.  
  407. static int
  408. InterpProc(clientData, interp, argc, argv)
  409.     ClientData clientData;    /* Record describing procedure to be
  410.                  * interpreted. */
  411.     Tcl_Interp *interp;        /* Interpreter in which procedure was
  412.                  * invoked. */
  413.     int argc;            /* Count of number of arguments to this
  414.                  * procedure. */
  415.     char **argv;        /* Argument values. */
  416. {
  417.     register Proc *procPtr = (Proc *) clientData;
  418.     register Arg *argPtr;
  419.     register Interp *iPtr;
  420.     char **args;
  421.     CallFrame frame;
  422.     char *value;
  423.     int result;
  424.  
  425.     /*
  426.      * Set up a call frame for the new procedure invocation.
  427.      */
  428.  
  429.     iPtr = procPtr->iPtr;
  430.     Tcl_InitHashTable(&frame.varTable, TCL_STRING_KEYS);
  431.     if (iPtr->varFramePtr != NULL) {
  432.     frame.level = iPtr->varFramePtr->level + 1;
  433.     } else {
  434.     frame.level = 1;
  435.     }
  436.     frame.argc = argc;
  437.     frame.argv = argv;
  438.     frame.callerPtr = iPtr->framePtr;
  439.     frame.callerVarPtr = iPtr->varFramePtr;
  440.     iPtr->framePtr = &frame;
  441.     iPtr->varFramePtr = &frame;
  442.     iPtr->returnCode = TCL_OK;
  443.  
  444.     /*
  445.      * Match the actual arguments against the procedure's formal
  446.      * parameters to compute local variables.
  447.      */
  448.  
  449.     for (argPtr = procPtr->argPtr, args = argv+1, argc -= 1;
  450.         argPtr != NULL;
  451.         argPtr = argPtr->nextPtr, args++, argc--) {
  452.  
  453.     /*
  454.      * Handle the special case of the last formal being "args".  When
  455.      * it occurs, assign it a list consisting of all the remaining
  456.      * actual arguments.
  457.      */
  458.  
  459.     if ((argPtr->nextPtr == NULL)
  460.         && (strcmp(argPtr->name, "args") == 0)) {
  461.         if (argc < 0) {
  462.         argc = 0;
  463.         }
  464.         value = Tcl_Merge(argc, args);
  465.         Tcl_SetVar(interp, argPtr->name, value, 0);
  466.         ckfree(value);
  467.         argc = 0;
  468.         break;
  469.     } else if (argc > 0) {
  470.         value = *args;
  471.     } else if (argPtr->defValue != NULL) {
  472.         value = argPtr->defValue;
  473.     } else {
  474.         Tcl_AppendResult(interp, "no value given for parameter \"",
  475.             argPtr->name, "\" to \"", argv[0], "\"",
  476.             (char *) NULL);
  477.         result = TCL_ERROR;
  478.         goto procDone;
  479.     }
  480.     Tcl_SetVar(interp, argPtr->name, value, 0);
  481.     }
  482.     if (argc > 0) {
  483.     Tcl_AppendResult(interp, "called \"", argv[0],
  484.         "\" with too many arguments", (char *) NULL);
  485.     result = TCL_ERROR;
  486.     goto procDone;
  487.     }
  488.  
  489.     /*
  490.      * Invoke the commands in the procedure's body.
  491.      */
  492.  
  493.     procPtr->refCount++;
  494.     result = Tcl_Eval(interp, procPtr->command);
  495.     procPtr->refCount--;
  496.     if (procPtr->refCount <= 0) {
  497.     CleanupProc(procPtr);
  498.     }
  499.     if (result == TCL_RETURN) {
  500.     result = TclUpdateReturnInfo(iPtr);
  501.     } else if (result == TCL_ERROR) {
  502.     char msg[100];
  503.  
  504.     /*
  505.      * Record information telling where the error occurred.
  506.      */
  507.  
  508.     sprintf(msg, "\n    (procedure \"%.50s\" line %d)", argv[0],
  509.         iPtr->errorLine);
  510.     Tcl_AddErrorInfo(interp, msg);
  511.     } else if (result == TCL_BREAK) {
  512.     iPtr->result = "invoked \"break\" outside of a loop";
  513.     result = TCL_ERROR;
  514.     } else if (result == TCL_CONTINUE) {
  515.     iPtr->result = "invoked \"continue\" outside of a loop";
  516.     result = TCL_ERROR;
  517.     }
  518.  
  519.     /*
  520.      * Delete the call frame for this procedure invocation (it's
  521.      * important to remove the call frame from the interpreter
  522.      * before deleting it, so that traces invoked during the
  523.      * deletion don't see the partially-deleted frame).
  524.      */
  525.  
  526.     procDone:
  527.     iPtr->framePtr = frame.callerPtr;
  528.     iPtr->varFramePtr = frame.callerVarPtr;
  529.  
  530.     /*
  531.      * The check below is a hack.  The problem is that there could be
  532.      * unset traces on the variables, which cause scripts to be evaluated.
  533.      * This will clear the ERR_IN_PROGRESS flag, losing stack trace
  534.      * information if the procedure was exiting with an error.  The
  535.      * code below preserves the flag.  Unfortunately, that isn't
  536.      * really enough:  we really should preserve the errorInfo variable
  537.      * too (otherwise a nested error in the trace script will trash
  538.      * errorInfo).  What's really needed is a general-purpose
  539.      * mechanism for saving and restoring interpreter state.
  540.      */
  541.  
  542.     if (iPtr->flags & ERR_IN_PROGRESS) {
  543.     TclDeleteVars(iPtr, &frame.varTable);
  544.     iPtr->flags |= ERR_IN_PROGRESS;
  545.     } else {
  546.     TclDeleteVars(iPtr, &frame.varTable);
  547.     }
  548.     return result;
  549. }
  550.  
  551. /*
  552.  *----------------------------------------------------------------------
  553.  *
  554.  * ProcDeleteProc --
  555.  *
  556.  *    This procedure is invoked just before a command procedure is
  557.  *    removed from an interpreter.  Its job is to release all the
  558.  *    resources allocated to the procedure.
  559.  *
  560.  * Results:
  561.  *    None.
  562.  *
  563.  * Side effects:
  564.  *    Memory gets freed, unless the procedure is actively being
  565.  *    executed.  In this case the cleanup is delayed until the
  566.  *    last call to the current procedure completes.
  567.  *
  568.  *----------------------------------------------------------------------
  569.  */
  570.  
  571. static void
  572. ProcDeleteProc(clientData)
  573.     ClientData clientData;        /* Procedure to be deleted. */
  574. {
  575.     Proc *procPtr = (Proc *) clientData;
  576.  
  577.     procPtr->refCount--;
  578.     if (procPtr->refCount <= 0) {
  579.     CleanupProc(procPtr);
  580.     }
  581. }
  582.  
  583. /*
  584.  *----------------------------------------------------------------------
  585.  *
  586.  * CleanupProc --
  587.  *
  588.  *    This procedure does all the real work of freeing up a Proc
  589.  *    structure.  It's called only when the structure's reference
  590.  *    count becomes zero.
  591.  *
  592.  * Results:
  593.  *    None.
  594.  *
  595.  * Side effects:
  596.  *    Memory gets freed.
  597.  *
  598.  *----------------------------------------------------------------------
  599.  */
  600.  
  601. static void
  602. CleanupProc(procPtr)
  603.     register Proc *procPtr;        /* Procedure to be deleted. */
  604. {
  605.     register Arg *argPtr;
  606.  
  607.     ckfree((char *) procPtr->command);
  608.     for (argPtr = procPtr->argPtr; argPtr != NULL; ) {
  609.     Arg *nextPtr = argPtr->nextPtr;
  610.  
  611.     ckfree((char *) argPtr);
  612.     argPtr = nextPtr;
  613.     }
  614.     ckfree((char *) procPtr);
  615. }
  616.  
  617. /*
  618.  *----------------------------------------------------------------------
  619.  *
  620.  * TclUpdateReturnInfo --
  621.  *
  622.  *    This procedure is called when procedures return, and at other
  623.  *    points where the TCL_RETURN code is used.  It examines fields
  624.  *    such as iPtr->returnCode and iPtr->errorCode and modifies
  625.  *    the real return status accordingly.
  626.  *
  627.  * Results:
  628.  *    The return value is the true completion code to use for
  629.  *    the procedure, instead of TCL_RETURN.
  630.  *
  631.  * Side effects:
  632.  *    The errorInfo and errorCode variables may get modified.
  633.  *
  634.  *----------------------------------------------------------------------
  635.  */
  636.  
  637. int
  638. TclUpdateReturnInfo(iPtr)
  639.     Interp *iPtr;        /* Interpreter for which TCL_RETURN
  640.                  * exception is being processed. */
  641. {
  642.     int code;
  643.  
  644.     code = iPtr->returnCode;
  645.     iPtr->returnCode = TCL_OK;
  646.     if (code == TCL_ERROR) {
  647.     Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode", (char *) NULL,
  648.         (iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE",
  649.         TCL_GLOBAL_ONLY);
  650.     iPtr->flags |= ERROR_CODE_SET;
  651.     if (iPtr->errorInfo != NULL) {
  652.         Tcl_SetVar2((Tcl_Interp *) iPtr, "errorInfo", (char *) NULL,
  653.             iPtr->errorInfo, TCL_GLOBAL_ONLY);
  654.         iPtr->flags |= ERR_IN_PROGRESS;
  655.     }
  656.     }
  657.     return code;
  658. }
  659.