home *** CD-ROM | disk | FTP | other *** search
/ Source Code 1992 March / Source_Code_CD-ROM_Walnut_Creek_March_1992.iso / usenet / altsrcs / 0 / 0991 / tclProc.c next >
C/C++ Source or Header  |  1990-12-28  |  23KB  |  896 lines
  1. /* 
  2.  * tclProc.c --
  3.  *
  4.  *    This file contains routines that implement Tcl procedures and
  5.  *    variables.
  6.  *
  7.  * Copyright 1987 Regents of the University of California
  8.  * Permission to use, copy, modify, and distribute this
  9.  * software and its documentation for any purpose and without
  10.  * fee is hereby granted, provided that the above copyright
  11.  * notice appear in all copies.  The University of California
  12.  * makes no representations about the suitability of this
  13.  * software for any purpose.  It is provided "as is" without
  14.  * express or implied warranty.
  15.  */
  16.  
  17. #ifndef lint
  18. static char rcsid[] = "$Header: /sprite/src/lib/tcl/RCS/tclProc.c,v 1.31 90/01/27 14:44:24 ouster Exp $ SPRITE (Berkeley)";
  19. #endif /* not lint */
  20.  
  21. #include <stdio.h>
  22. #include <stdlib.h>
  23. #include <string.h>
  24. #include <ctype.h>
  25. #include "tclInt.h"
  26.  
  27. /*
  28.  * Forward references to procedures defined later in this file:
  29.  */
  30.  
  31. extern Var *    FindVar();
  32. extern int    InterpProc();
  33. extern Var *    NewVar();
  34. extern void    ProcDeleteProc();
  35.  
  36. /*
  37.  *----------------------------------------------------------------------
  38.  *
  39.  * Tcl_ProcCmd --
  40.  *
  41.  *    This procedure is invoked to process the "proc" Tcl command.
  42.  *    See the user documentation for details on what it does.
  43.  *
  44.  * Results:
  45.  *    A standard Tcl result value.
  46.  *
  47.  * Side effects:
  48.  *    A new procedure gets created.
  49.  *
  50.  *----------------------------------------------------------------------
  51.  */
  52.  
  53.     /* ARGSUSED */
  54. int
  55. Tcl_ProcCmd(dummy, interp, argc, argv)
  56.     ClientData dummy;            /* Not used. */
  57.     Tcl_Interp *interp;            /* Current interpreter. */
  58.     int argc;                /* Number of arguments. */
  59.     char **argv;            /* Argument strings. */
  60. {
  61.     register Interp *iPtr = (Interp *) interp;
  62.     register Proc *procPtr;
  63.     int result, argCount, i;
  64.     char **argArray;
  65.  
  66.     if (argc != 4) {
  67.     sprintf(iPtr->result,
  68.         "wrong # args: should be \"%.50s name args body\"",
  69.         argv[0]);
  70.     return TCL_ERROR;
  71.     }
  72.  
  73.     procPtr = (Proc *) ckalloc(sizeof(Proc));
  74.     procPtr->iPtr = iPtr;
  75.     procPtr->command = (char *) ckalloc((unsigned) strlen(argv[3]) + 1);
  76.     strcpy(procPtr->command, argv[3]);
  77.     procPtr->argPtr = NULL;
  78.     Tcl_CreateCommand(interp, argv[1], InterpProc,
  79.         (ClientData) procPtr, ProcDeleteProc);
  80.  
  81.     /*
  82.      * Break up the argument list into argument specifiers, then process
  83.      * each argument specifier.
  84.      */
  85.  
  86.     result = Tcl_SplitList(interp, argv[2], &argCount, &argArray);
  87.     if (result != TCL_OK) {
  88.     return result;
  89.     }
  90.     for (i = 0; i < argCount; i++) {
  91.     int fieldCount, nameLength, valueLength;
  92.     char **fieldValues;
  93.     register Var *argPtr;
  94.  
  95.     /*
  96.      * Now divide the specifier up into name and default.
  97.      */
  98.  
  99.     result = Tcl_SplitList(interp, argArray[i], &fieldCount,
  100.         &fieldValues);
  101.     if (result != TCL_OK) {
  102.         goto procError;
  103.     }
  104.     if (fieldCount > 2) {
  105.         sprintf(iPtr->result,
  106.             "too many fields in argument specifier \"%.50s\"",
  107.             argArray[i]);
  108.         result = TCL_ERROR;
  109.         goto procError;
  110.     }
  111.     if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
  112.         sprintf(iPtr->result,
  113.             "procedure \"%.50s\" has argument with no name", argv[1]);
  114.         result = TCL_ERROR;
  115.         goto procError;
  116.     }
  117.     nameLength = strlen(fieldValues[0]);
  118.     if (fieldCount == 2) {
  119.         valueLength = strlen(fieldValues[1]);
  120.     } else {
  121.         valueLength = 0;
  122.     }
  123.     if (procPtr->argPtr == NULL) {
  124.         argPtr = (Var *) ckalloc(VAR_SIZE(nameLength, valueLength));
  125.         procPtr->argPtr = argPtr;
  126.     } else {
  127.         argPtr->nextPtr = (Var *) ckalloc(VAR_SIZE(nameLength, valueLength));
  128.         argPtr = argPtr->nextPtr;
  129.     }
  130.     strcpy(argPtr->name, fieldValues[0]);
  131.     if (fieldCount == 2) {
  132.         argPtr->value = argPtr->name + nameLength + 1;
  133.         strcpy(argPtr->value, fieldValues[1]);
  134.     } else {
  135.         argPtr->value = NULL;
  136.     }
  137.     argPtr->valueLength = valueLength;
  138.     argPtr->flags = 0;
  139.     argPtr->nextPtr = NULL;
  140.     ckfree((char *) fieldValues);
  141.     }
  142.  
  143.     ckfree((char *) argArray);
  144.     return TCL_OK;
  145.  
  146.     procError:
  147.     ckfree((char *) argArray);
  148.     return result;
  149. }
  150.  
  151. /*1
  152.  *----------------------------------------------------------------------
  153.  *
  154.  * Tcl_GetVar --
  155.  *
  156.  *    Return the value of a Tcl variable.
  157.  *
  158.  * Results:
  159.  *    The return value points to the current value of varName.  If
  160.  *    the variable is not defined in interp, either as a local or
  161.  *    global variable, then a NULL pointer is returned.
  162.  *
  163.  *    Note:  the return value is only valid up until the next call to
  164.  *    Tcl_SetVar;  if you depend on the value lasting longer than that,
  165.  *    then make yourself a private copy.
  166.  *
  167.  * Side effects:
  168.  *    None.
  169.  *
  170.  *----------------------------------------------------------------------
  171.  */
  172.  
  173. char *
  174. Tcl_GetVar(interp, varName, global)
  175.     Tcl_Interp *interp;        /* Command interpreter in which varName is
  176.                  * to be looked up. */
  177.     char *varName;        /* Name of a variable in interp. */
  178.     int global;            /* If non-zero, use only a global variable */
  179. {
  180.     Var *varPtr;
  181.     Interp *iPtr = (Interp *) interp;
  182.  
  183.     if (global || (iPtr->varFramePtr == NULL)) {
  184.     varPtr = FindVar(&iPtr->globalPtr, varName);
  185.     } else {
  186.     varPtr = FindVar(&iPtr->varFramePtr->varPtr, varName);
  187.     }
  188.     if (varPtr == NULL) {
  189.     return NULL;
  190.     }
  191.     if (varPtr->flags & VAR_GLOBAL) {
  192.     varPtr = varPtr->globalPtr;
  193.     }
  194.     if (varPtr->value == NULL) {
  195.     return "";
  196.     }
  197.     return varPtr->value;
  198. }
  199.  
  200. /*
  201.  *----------------------------------------------------------------------
  202.  *
  203.  * Tcl_SetVar --
  204.  *
  205.  *    Change the value of a variable.
  206.  *
  207.  * Results:
  208.  *    None.
  209.  *
  210.  * Side effects:
  211.  *    If varName is defined as a local or global variable in interp,
  212.  *    its value is changed to newValue.  If varName isn't currently
  213.  *    defined, then a new global variable by that name is created.
  214.  *
  215.  *----------------------------------------------------------------------
  216.  */
  217.  
  218. void
  219. Tcl_SetVar(interp, varName, newValue, global)
  220.     Tcl_Interp *interp;        /* Command interpreter in which varName is
  221.                  * to be looked up. */
  222.     char *varName;        /* Name of a variable in interp. */
  223.     char *newValue;        /* New value for varName. */
  224.     int global;            /* If non-zero, use only a global variable. */
  225. {
  226.     register Var *varPtr, **varListPtr;
  227.     register Interp *iPtr = (Interp *) interp;
  228.     int valueLength;
  229.  
  230.     if (global || (iPtr->varFramePtr == NULL)) {
  231.     varListPtr = &iPtr->globalPtr;
  232.     } else {
  233.     varListPtr = &iPtr->varFramePtr->varPtr;
  234.     }
  235.     varPtr = FindVar(varListPtr, varName);
  236.     if (varPtr == NULL) {
  237.     varPtr = NewVar(varName, newValue);
  238.     varPtr->nextPtr = *varListPtr;
  239.     *varListPtr = varPtr;
  240.     } else {
  241.     if (varPtr->flags & VAR_GLOBAL) {
  242.         varPtr = varPtr->globalPtr;
  243.     }
  244.     valueLength = strlen(newValue);
  245.     if (valueLength > varPtr->valueLength) {
  246.         if (varPtr->flags & VAR_DYNAMIC) {
  247.         ckfree(varPtr->value);
  248.         }
  249.         varPtr->value = (char *) ckalloc((unsigned) valueLength + 1);
  250.         varPtr->flags |= VAR_DYNAMIC;
  251.         varPtr->valueLength = valueLength;
  252.     }
  253.     strcpy(varPtr->value, newValue);
  254.     }
  255. }
  256.  
  257. /*
  258.  *----------------------------------------------------------------------
  259.  *
  260.  * Tcl_ParseVar --
  261.  *
  262.  *    Given a string starting with a $ sign, parse off a variable
  263.  *    name and return its value.
  264.  *
  265.  * Results:
  266.  *    The return value is the contents of the variable given by
  267.  *    the leading characters of string.  If termPtr isn't NULL,
  268.  *    *termPtr gets filled in with the address of the character
  269.  *    just after the last one in the variable specifier.  If the
  270.  *    variable doesn't exist, then the return value is NULL and
  271.  *    an error message will be left in interp->result.
  272.  *
  273.  * Side effects:
  274.  *    None.
  275.  *
  276.  *----------------------------------------------------------------------
  277.  */
  278.  
  279. char *
  280. Tcl_ParseVar(interp, string, termPtr)
  281.     Tcl_Interp *interp;            /* Context for looking up variable. */
  282.     register char *string;        /* String containing variable name.
  283.                      * First character must be "$". */
  284.     char **termPtr;            /* If non-NULL, points to word to fill
  285.                      * in with character just after last
  286.                      * one in the variable specifier. */
  287.  
  288. {
  289.     char *name, c, *result;
  290.  
  291.     /*
  292.      * There are two cases:
  293.      * 1. The $ sign is followed by an open curly brace.  Then the variable
  294.      *    name is everything up to the next close curly brace.
  295.      * 2. The $ sign is not followed by an open curly brace.  Then the
  296.      *    variable name is everything up to the next character that isn't
  297.      *    a letter, digit, or underscore.
  298.      */
  299.  
  300.     string++;
  301.     if (*string == '{') {
  302.     string++;
  303.     name = string;
  304.     while ((*string != '}') && (*string != 0)) {
  305.         string++;
  306.     }
  307.     if (termPtr != 0) {
  308.         if (*string != 0) {
  309.         *termPtr = string+1;
  310.         } else {
  311.         *termPtr = string;
  312.         }
  313.     }
  314.     } else {
  315.     name = string;
  316.     while (isalnum(*string) || (*string == '_')) {
  317.         string++;
  318.     }
  319.     if (termPtr != 0) {
  320.         *termPtr = string;
  321.     }
  322.     }
  323.  
  324.     c = *string;
  325.     *string = 0;
  326.     result = Tcl_GetVar(interp, name, 0);
  327.     if (!result) {
  328.     Tcl_Return(interp, (char *) NULL, TCL_STATIC);
  329.     sprintf(interp->result, "couldn't find variable \"%.50s\"", name);
  330.     }
  331.     *string = c;
  332.     return result;
  333. }
  334.  
  335. /*
  336.  *----------------------------------------------------------------------
  337.  *
  338.  * Tcl_SetCmd --
  339.  *
  340.  *    This procedure is invoked to process the "set" Tcl command.
  341.  *    See the user documentation for details on what it does.
  342.  *
  343.  * Results:
  344.  *    A standard Tcl result value.
  345.  *
  346.  * Side effects:
  347.  *    A variable's value may be changed.
  348.  *
  349.  *----------------------------------------------------------------------
  350.  */
  351.  
  352.     /* ARGSUSED */
  353. int
  354. Tcl_SetCmd(dummy, interp, argc, argv)
  355.     ClientData dummy;            /* Not used. */
  356.     register Tcl_Interp *interp;    /* Current interpreter. */
  357.     int argc;                /* Number of arguments. */
  358.     char **argv;            /* Argument strings. */
  359. {
  360.     if (argc == 2) {
  361.     char *value;
  362.  
  363.     value = Tcl_GetVar(interp, argv[1], 0);
  364.     if (value == 0) {
  365.         sprintf(interp->result, "couldn't find variable \"%.50s\"",
  366.             argv[1]);
  367.         return TCL_ERROR;
  368.     }
  369.     interp->result = value;
  370.     return TCL_OK;
  371.     } else if (argc == 3) {
  372.     Tcl_SetVar(interp, argv[1], argv[2], 0);
  373.     return TCL_OK;
  374.     } else {
  375.     sprintf(interp->result,
  376.         "wrong # args: should be \"%.50s varName [newValue]\"",
  377.         argv[0]);
  378.     return TCL_ERROR;
  379.     }
  380. }
  381.  
  382. /*
  383.  *----------------------------------------------------------------------
  384.  *
  385.  * Tcl_GlobalCmd --
  386.  *
  387.  *    This procedure is invoked to process the "global" Tcl command.
  388.  *    See the user documentation for details on what it does.
  389.  *
  390.  * Results:
  391.  *    A standard Tcl result value.
  392.  *
  393.  * Side effects:
  394.  *    See the user documentation.
  395.  *
  396.  *----------------------------------------------------------------------
  397.  */
  398.  
  399.     /* ARGSUSED */
  400. int
  401. Tcl_GlobalCmd(dummy, interp, argc, argv)
  402.     ClientData dummy;            /* Not used. */
  403.     Tcl_Interp *interp;            /* Current interpreter. */
  404.     int argc;                /* Number of arguments. */
  405.     char **argv;            /* Argument strings. */
  406. {
  407.     register Var *varPtr;
  408.     register Interp *iPtr = (Interp *) interp;
  409.     Var *gVarPtr;
  410.  
  411.     if (argc < 2) {
  412.     sprintf(iPtr->result,
  413.         "too few args:  should be \"%.50s varName varName ...\"",
  414.         argv[0]);
  415.     return TCL_ERROR;
  416.     }
  417.     if (iPtr->varFramePtr == NULL) {
  418.     return TCL_OK;
  419.     }
  420.  
  421.     for (argc--, argv++; argc > 0; argc--, argv++) {
  422.     gVarPtr = FindVar(&iPtr->globalPtr, *argv);
  423.     if (gVarPtr == NULL) {
  424.         gVarPtr = NewVar(*argv, "");
  425.         gVarPtr->nextPtr = iPtr->globalPtr;
  426.         iPtr->globalPtr = gVarPtr;
  427.     }
  428.     varPtr = NewVar(*argv, "");
  429.     varPtr->flags |= VAR_GLOBAL;
  430.     varPtr->globalPtr = gVarPtr;
  431.     varPtr->nextPtr = iPtr->varFramePtr->varPtr;
  432.     iPtr->varFramePtr->varPtr = varPtr;
  433.     }
  434.     return TCL_OK;
  435. }
  436.  
  437. /*
  438.  *----------------------------------------------------------------------
  439.  *
  440.  * Tcl_UplevelCmd --
  441.  *
  442.  *    This procedure is invoked to process the "uplevel" Tcl command.
  443.  *    See the user documentation for details on what it does.
  444.  *
  445.  * Results:
  446.  *    A standard Tcl result value.
  447.  *
  448.  * Side effects:
  449.  *    See the user documentation.
  450.  *
  451.  *----------------------------------------------------------------------
  452.  */
  453.  
  454.     /* ARGSUSED */
  455. int
  456. Tcl_UplevelCmd(dummy, interp, argc, argv)
  457.     ClientData dummy;            /* Not used. */
  458.     Tcl_Interp *interp;            /* Current interpreter. */
  459.     int argc;                /* Number of arguments. */
  460.     char **argv;            /* Argument strings. */
  461. {
  462.     register Interp *iPtr = (Interp *) interp;
  463.     int level, result;
  464.     char *end;
  465.     CallFrame *savedVarFramePtr, *framePtr;
  466.  
  467.     if (argc < 3) {
  468.     sprintf(iPtr->result,
  469.         "too few args:  should be \"%.50s level command ...\"",
  470.         argv[0]);
  471.     return TCL_ERROR;
  472.     }
  473.     level = strtol(argv[1], &end, 10);
  474.     if ((end == argv[1]) || (*end != '\0')) {
  475.     levelError:
  476.     sprintf(iPtr->result, "bad level \"%.50s\"", argv[1]);
  477.     return TCL_ERROR;
  478.     }
  479.  
  480.     /*
  481.      * Figure out which frame to use, and modify the interpreter so
  482.      * its variables come from that frame.
  483.      */
  484.  
  485.     savedVarFramePtr = iPtr->varFramePtr;
  486.     if (level < 0) {
  487.     if (savedVarFramePtr == NULL) {
  488.         goto levelError;
  489.     }
  490.     level += savedVarFramePtr->level;
  491.     }
  492.     if (level == 0) {
  493.     iPtr->varFramePtr = NULL;
  494.     } else {
  495.     for (framePtr = savedVarFramePtr; framePtr != NULL;
  496.         framePtr = framePtr->callerVarPtr) {
  497.         if (framePtr->level == level) {
  498.         break;
  499.         }
  500.     }
  501.     if (framePtr == NULL) {
  502.         goto levelError;
  503.     }
  504.     iPtr->varFramePtr = framePtr;
  505.     }
  506.  
  507.     /*
  508.      * Execute the residual arguments as a command.
  509.      */
  510.  
  511.     if (argc == 3) {
  512.     result = Tcl_Eval(interp, argv[2], 0, (char **) NULL);
  513.     } else {
  514.     char *cmd;
  515.  
  516.     cmd = Tcl_Concat(argc-2, argv+2);
  517.     result = Tcl_Eval(interp, cmd, 0, (char **) NULL);
  518.     }
  519.     if (result == TCL_ERROR) {
  520.     char msg[60];
  521.     sprintf(msg, " (\"uplevel\" body line %d)", interp->errorLine);
  522.     Tcl_AddErrorInfo(interp, msg);
  523.     }
  524.  
  525.     /*
  526.      * Restore the variable frame, and return.
  527.      */
  528.  
  529.     iPtr->varFramePtr = savedVarFramePtr;
  530.     return result;
  531. }
  532.  
  533. /*
  534.  *----------------------------------------------------------------------
  535.  *
  536.  * TclFindProc --
  537.  *
  538.  *    Given the name of a procedure, return a pointer to the
  539.  *    record describing the procedure.
  540.  *
  541.  * Results:
  542.  *    NULL is returned if the name doesn't correspond to any
  543.  *    procedure.  Otherwise the return value is a pointer to
  544.  *    the procedure's record.
  545.  *
  546.  * Side effects:
  547.  *    None.
  548.  *
  549.  *----------------------------------------------------------------------
  550.  */
  551.  
  552. Proc *
  553. TclFindProc(iPtr, procName)
  554.     Interp *iPtr;        /* Interpreter in which to look. */
  555.     char *procName;        /* Name of desired procedure. */
  556. {
  557.     Command *cmdPtr;
  558.  
  559.     cmdPtr = TclFindCmd(iPtr, procName, 0);
  560.     if (cmdPtr == NULL) {
  561.     return NULL;
  562.     }
  563.     if (cmdPtr->proc != InterpProc) {
  564.     return NULL;
  565.     }
  566.     return (Proc *) cmdPtr->clientData;
  567. }
  568.  
  569. /*
  570.  *----------------------------------------------------------------------
  571.  *
  572.  * TclIsProc --
  573.  *
  574.  *    Tells whether a command is a Tcl procedure or not.
  575.  *
  576.  * Results:
  577.  *    If the given command is actuall a Tcl procedure, the
  578.  *    return value is the address of the record describing
  579.  *    the procedure.  Otherwise the return value is 0.
  580.  *
  581.  * Side effects:
  582.  *    None.
  583.  *
  584.  *----------------------------------------------------------------------
  585.  */
  586.  
  587. Proc *
  588. TclIsProc(cmdPtr)
  589.     Command *cmdPtr;        /* Command to test. */
  590. {
  591.     if (cmdPtr->proc == InterpProc) {
  592.     return (Proc *) cmdPtr->clientData;
  593.     }
  594.     return (Proc *) 0;
  595. }
  596.  
  597. /*
  598.  *----------------------------------------------------------------------
  599.  *
  600.  * TclDeleteVars --
  601.  *
  602.  *    This procedure is called as part of deleting an interpreter:
  603.  *    it recycles all the storage space associated with global
  604.  *    variables (the local ones should already have been deleted).
  605.  *
  606.  * Results:
  607.  *    None.
  608.  *
  609.  * Side effects:
  610.  *    Variables are deleted.
  611.  *
  612.  *----------------------------------------------------------------------
  613.  */
  614.  
  615. void
  616. TclDeleteVars(iPtr)
  617.     Interp *iPtr;        /* Interpreter to nuke. */
  618. {
  619.     register Var *varPtr;
  620.  
  621.     for (varPtr = iPtr->globalPtr; varPtr != NULL; varPtr = varPtr->nextPtr) {
  622.     if (varPtr->flags & VAR_DYNAMIC) {
  623.         ckfree(varPtr->value);
  624.     }
  625.     ckfree((char *) varPtr);
  626.     }
  627. }
  628.  
  629. /*
  630.  *----------------------------------------------------------------------
  631.  *
  632.  * InterpProc --
  633.  *
  634.  *    When a Tcl procedure gets invoked, this routine gets invoked
  635.  *    to interpret the procedure.
  636.  *
  637.  * Results:
  638.  *    A standard Tcl result value, usually TCL_OK.
  639.  *
  640.  * Side effects:
  641.  *    Depends on the commands in the procedure.
  642.  *
  643.  *----------------------------------------------------------------------
  644.  */
  645.  
  646. int
  647. InterpProc(procPtr, interp, argc, argv)
  648.     register Proc *procPtr;    /* Record describing procedure to be
  649.                  * interpreted. */
  650.     Tcl_Interp *interp;        /* Interpreter in which procedure was
  651.                  * invoked. */
  652.     int argc;            /* Count of number of arguments to this
  653.                  * procedure. */
  654.     char **argv;        /* Argument values. */
  655. {
  656.     char **args;
  657.     register Var *formalPtr, *argPtr;
  658.     register Interp *iPtr = (Interp *) interp;
  659.     CallFrame frame;
  660.     char *value, *end;
  661.     int result;
  662.  
  663.     /*
  664.      * Set up a call frame for the new procedure invocation.
  665.      */
  666.  
  667.     iPtr = procPtr->iPtr;
  668.     frame.varPtr = NULL;
  669.     if (iPtr->varFramePtr != NULL) {
  670.     frame.level = iPtr->varFramePtr->level + 1;
  671.     } else {
  672.     frame.level = 1;
  673.     }
  674.     frame.argc = argc;
  675.     frame.argv = argv;
  676.     frame.callerPtr = iPtr->framePtr;
  677.     frame.callerVarPtr = iPtr->varFramePtr;
  678.     iPtr->framePtr = &frame;
  679.     iPtr->varFramePtr = &frame;
  680.  
  681.     /*
  682.      * Match the actual arguments against the procedure's formal
  683.      * parameters to compute local variables.
  684.      */
  685.  
  686.     for (formalPtr = procPtr->argPtr, args = argv+1, argc -= 1;
  687.         formalPtr != NULL;
  688.         formalPtr = formalPtr->nextPtr, args++, argc--) {
  689.  
  690.     /*
  691.      * Handle the special case of the last formal being "args".  When
  692.      * it occurs, assign it a list consisting of all the remaining
  693.      * actual arguments.
  694.      */
  695.  
  696.     if ((formalPtr->nextPtr == NULL)
  697.         && (strcmp(formalPtr->name, "args") == 0)) {
  698.         if (argc < 0) {
  699.         argc = 0;
  700.         }
  701.         value = Tcl_Merge(argc, args);
  702.         argPtr = NewVar(formalPtr->name, value);
  703.         ckfree(value);
  704.         argPtr->nextPtr = frame.varPtr;
  705.         frame.varPtr = argPtr;
  706.         argc = 0;
  707.         break;
  708.     } else if (argc > 0) {
  709.         value = *args;
  710.     } else if (formalPtr->value != NULL) {
  711.         value = formalPtr->value;
  712.     } else {
  713.         sprintf(iPtr->result,
  714.             "no value given for parameter \"%s\" to \"%s\"",
  715.             formalPtr->name, argv[0]);
  716.         result = TCL_ERROR;
  717.         goto procDone;
  718.     }
  719.     argPtr = NewVar(formalPtr->name, value);
  720.     argPtr->nextPtr = frame.varPtr;
  721.     frame.varPtr = argPtr;
  722.     }
  723.     if (argc > 0) {
  724.     sprintf(iPtr->result, "called \"%s\" with too many arguments",
  725.         argv[0]);
  726.     result = TCL_ERROR;
  727.     goto procDone;
  728.     }
  729.  
  730.     /*
  731.      * Invoke the commands in the procedure's body.
  732.      */
  733.  
  734.     result = Tcl_Eval(interp, procPtr->command, 0, &end);
  735.     if (result == TCL_RETURN) {
  736.     result = TCL_OK;
  737.     } else if (result == TCL_ERROR) {
  738.     char msg[100];
  739.  
  740.     /*
  741.      * Record information telling where the error occurred.
  742.      */
  743.  
  744.     sprintf(msg, " (procedure \"%.50s\" line %d)", argv[0],
  745.         iPtr->errorLine);
  746.     Tcl_AddErrorInfo(interp, msg);
  747.     } else if (result == TCL_BREAK) {
  748.     iPtr->result = "invoked \"break\" outside of a loop";
  749.     result = TCL_ERROR;
  750.     } else if (result == TCL_CONTINUE) {
  751.     iPtr->result = "invoked \"continue\" outside of a loop";
  752.     result = TCL_ERROR;
  753.     }
  754.  
  755.     /*
  756.      * Delete the call frame for this procedure invocation.
  757.      */
  758.  
  759.     procDone:
  760.     for (argPtr = frame.varPtr; argPtr != NULL; argPtr = argPtr->nextPtr) {
  761.     if (argPtr->flags & VAR_DYNAMIC) {
  762.         ckfree(argPtr->value);
  763.     }
  764.     ckfree((char *) argPtr);
  765.     }
  766.     iPtr->framePtr = frame.callerPtr;
  767.     iPtr->varFramePtr = frame.callerVarPtr;
  768.     return result;
  769. }
  770.  
  771. /*
  772.  *----------------------------------------------------------------------
  773.  *
  774.  * ProcDeleteProc --
  775.  *
  776.  *    This procedure is invoked just before a command procedure is
  777.  *    removed from an interpreter.  Its job is to release all the
  778.  *    resources allocated to the procedure.
  779.  *
  780.  * Results:
  781.  *    None.
  782.  *
  783.  * Side effects:
  784.  *    Memory gets freed.
  785.  *
  786.  *----------------------------------------------------------------------
  787.  */
  788.  
  789. void
  790. ProcDeleteProc(procPtr)
  791.     register Proc *procPtr;        /* Procedure to be deleted. */
  792. {
  793.     register Var *argPtr;
  794.  
  795.     ckfree((char *) procPtr->command);
  796.     for (argPtr = procPtr->argPtr; argPtr != NULL; argPtr = argPtr->nextPtr) {
  797.     if (argPtr->flags & VAR_DYNAMIC) {
  798.         ckfree(argPtr->value);
  799.     }
  800.     ckfree((char *) argPtr);
  801.     }
  802.     ckfree((char *) procPtr);
  803. }
  804.  
  805. /*
  806.  *----------------------------------------------------------------------
  807.  *
  808.  * FindVar --
  809.  *
  810.  *    Locate the Var structure corresponding to varName, if there
  811.  *    is one defined in a given list.
  812.  *
  813.  * Results:
  814.  *    The return value points to the Var structure corresponding to
  815.  *    the current value of varName in varListPtr, or NULL if varName
  816.  *    isn't currently defined in the list.
  817.  *
  818.  * Side effects:
  819.  *    If the variable is found, it is moved to the front of the list.
  820.  *
  821.  *----------------------------------------------------------------------
  822.  */
  823.  
  824. Var *
  825. FindVar(varListPtr, varName)
  826.     Var **varListPtr;        /* Pointer to head of list.  The value pointed
  827.                  * to will be modified to bring the found
  828.                  * variable to the front of the list. */
  829.     char *varName;        /* Desired variable. */
  830. {
  831.     register Var *prev, *cur;
  832.     register char c;
  833.  
  834.     c = *varName;
  835.  
  836.     /*
  837.      * Local variables take precedence over global ones.  Check the
  838.      * first character immediately, before wasting time calling strcmp.
  839.      */
  840.  
  841.     for (prev = NULL, cur = *varListPtr; cur != NULL;
  842.         prev = cur, cur = cur->nextPtr) {
  843.     if ((cur->name[0] == c) && (strcmp(cur->name, varName) == 0)) {
  844.         if (prev != NULL) {
  845.         prev->nextPtr = cur->nextPtr;
  846.         cur->nextPtr = *varListPtr;
  847.         *varListPtr = cur;
  848.         }
  849.         return cur;
  850.     }
  851.     }
  852.     return NULL;
  853. }
  854.  
  855. /*
  856.  *----------------------------------------------------------------------
  857.  *
  858.  * NewVar --
  859.  *
  860.  *    Create a new variable with the given name and initial value.
  861.  *
  862.  * Results:
  863.  *    The return value is a pointer to the new variable.  The variable
  864.  *    will not have been linked into any particular list, and its
  865.  *    nextPtr field will be NULL.
  866.  *
  867.  * Side effects:
  868.  *    Storage gets allocated.
  869.  *
  870.  *----------------------------------------------------------------------
  871.  */
  872.  
  873. Var *
  874. NewVar(name, value)
  875.     char *name;            /* Name for variable. */
  876.     char *value;        /* Value for variable. */
  877. {
  878.     register Var *varPtr;
  879.     int nameLength, valueLength;
  880.  
  881.     nameLength = strlen(name);
  882.     valueLength = strlen(value);
  883.     if (valueLength < 20) {
  884.     valueLength = 20;
  885.     }
  886.     varPtr = (Var *) ckalloc(VAR_SIZE(nameLength, valueLength));
  887.     strcpy(varPtr->name, name);
  888.     varPtr->value = varPtr->name + nameLength + 1;
  889.     strcpy(varPtr->value, value);
  890.     varPtr->valueLength = valueLength;
  891.     varPtr->flags = 0;
  892.     varPtr->globalPtr = NULL;
  893.     varPtr->nextPtr = NULL;
  894.     return varPtr;
  895. }
  896.