home *** CD-ROM | disk | FTP | other *** search
/ ARM Club 3 / TheARMClub_PDCD3.iso / hensa / programming / tcl / tclsrc / c / tclVar < prev    next >
Text File  |  1996-01-28  |  73KB  |  2,556 lines
  1. /*
  2.  * tclVar.c --
  3.  *
  4.  *    This file contains routines that implement Tcl variables
  5.  *    (both scalars and arrays).
  6.  *
  7.  *    The implementation of arrays is modelled after an initial
  8.  *    implementation by Mark Diekhans and Karl Lehenbauer.
  9.  *
  10.  * Copyright (c) 1987-1994 The Regents of the University of California.
  11.  * Copyright (c) 1994-1995 Sun Microsystems, Inc.
  12.  *
  13.  * See the file "license.terms" for information on usage and redistribution
  14.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  15.  */
  16.  
  17. static char sccsid[] = "@(#) tclVar.c 1.61 95/06/02 09:29:16";
  18.  
  19. #include "tclInt.h"
  20. #ifndef TCL_GENERIC_ONLY /* not for RISCOS*/
  21. #include "tclPort.h"
  22. #endif
  23.  
  24. /*
  25.  * The strings below are used to indicate what went wrong when a
  26.  * variable access is denied.
  27.  */
  28.  
  29. static char *noSuchVar =    "no such variable";
  30. static char *isArray =        "variable is array";
  31. static char *needArray =    "variable isn't array";
  32. static char *noSuchElement =    "no such element in array";
  33. static char *danglingUpvar =    "upvar refers to element in deleted array";
  34.  
  35. /*
  36.  * Creation flag values passed in to LookupVar:
  37.  *
  38.  * CRT_PART1 -        1 means create hash table entry for part 1 of
  39.  *            name, if it doesn't already exist.  0 means
  40.  *            return an error if it doesn't exist.
  41.  * CRT_PART2 -        1 means create hash table entry for part 2 of
  42.  *            name, if it doesn't already exist.  0 means
  43.  *            return an error if it doesn't exist.
  44.  */
  45.  
  46. #define CRT_PART1    1
  47. #define CRT_PART2    2
  48.  
  49. /*
  50.  * The following additional flag is used internally and passed through
  51.  * to LookupVar to indicate that a procedure like Tcl_GetVar was called
  52.  * instead of Tcl_GetVar2 and the single name value hasn't yet been
  53.  * parsed into an array name and index (if any).
  54.  */
  55.  
  56. #define PART1_NOT_PARSED    0x10000
  57.  
  58. /*
  59.  * Forward references to procedures defined later in this file:
  60.  */
  61.  
  62. static  char *        CallTraces _ANSI_ARGS_((Interp *iPtr, Var *arrayPtr,
  63.                 Var *varPtr, char *part1, char *part2,
  64.                 int flags));
  65. static void        CleanupVar _ANSI_ARGS_((Var *varPtr, Var *arrayPtr));
  66. static void        DeleteSearches _ANSI_ARGS_((Var *arrayVarPtr));
  67. static void        DeleteArray _ANSI_ARGS_((Interp *iPtr, char *arrayName,
  68.                 Var *varPtr, int flags));
  69. static Var *        LookupVar _ANSI_ARGS_((Tcl_Interp *interp, char *part1,
  70.                 char *part2, int flags, char *msg, int create,
  71.                 Var **arrayPtrPtr));
  72. static int        MakeUpvar _ANSI_ARGS_((Interp *iPtr,
  73.                 CallFrame *framePtr, char *otherP1,
  74.                 char *otherP2, char *myName, int flags));
  75. static Var *        NewVar _ANSI_ARGS_((void));
  76. static ArraySearch *    ParseSearchId _ANSI_ARGS_((Tcl_Interp *interp,
  77.                 Var *varPtr, char *varName, char *string));
  78. static void        VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp,
  79.                 char *part1, char *part2, char *operation,
  80.                 char *reason));
  81.  
  82. /*
  83.  *----------------------------------------------------------------------
  84.  *
  85.  * LookupVar --
  86.  *
  87.  *    This procedure is used by virtually all of the variable
  88.  *    code to locate a variable given its name(s).
  89.  *
  90.  * Results:
  91.  *    The return value is a pointer to the variable indicated by
  92.  *    part1 and part2, or NULL if the variable couldn't be found.
  93.  *    If the variable is found, *arrayPtrPtr is filled in with
  94.  *    the address of the array that contains the variable (or NULL
  95.  *    if the variable is a scalar).  Note:  it's possible that the
  96.  *    variable returned may be VAR_UNDEFINED, even if CRT_PART1 and
  97.  *    CRT_PART2 are specified (these only cause the hash table entry
  98.  *    and/or array to be created).
  99.  *
  100.  * Side effects:
  101.  *    None.
  102.  *
  103.  *----------------------------------------------------------------------
  104.  */
  105.  
  106. static Var *
  107. LookupVar(interp, part1, part2, flags, msg, create, arrayPtrPtr)
  108.     Tcl_Interp *interp;        /* Interpreter to use for lookup. */
  109.     char *part1;        /* If part2 isn't NULL, this is the name
  110.                  * of an array.  Otherwise, if the
  111.                  * PART1_NOT_PARSED flag bit is set this
  112.                  * is a full variable name that could
  113.                  * include a parenthesized array elemnt.
  114.                  * If PART1_NOT_PARSED isn't present, then
  115.                  * this is the name of a scalar variable. */
  116.     char *part2;        /* Name of an element within array, or NULL. */
  117.     int flags;            /* Only the TCL_GLOBAL_ONLY, TCL_LEAVE_ERR_MSG,
  118.                  * and PART1_NOT_PARSED bits matter. */
  119.     char *msg;            /* Verb to use in error messages, e.g.
  120.                  * "read" or "set".  Only needed if
  121.                  * TCL_LEAVE_ERR_MSG is set in flags. */
  122.     int create;            /* OR'ed combination of CRT_PART1 and
  123.                  * CRT_PART2.  Tells which entries to create
  124.                  * if they don't already exist. */
  125.     Var **arrayPtrPtr;        /* If the name refers to an element of an
  126.                  * array, *arrayPtrPtr gets filled in with
  127.                  * address of array variable.  Otherwise
  128.                  * this is set to NULL. */
  129. {
  130.     Interp *iPtr = (Interp *) interp;
  131.     Tcl_HashTable *tablePtr;
  132.     Tcl_HashEntry *hPtr;
  133.     Var *varPtr;
  134.     int new;
  135.     char *openParen, *closeParen;    /* If this procedure parses a name
  136.                      * into array and index, these point
  137.                      * to the parens around the index.
  138.                      * Otherwise they are NULL.  These
  139.                      * are needed to restore the parens
  140.                      * after parsing the name. */
  141.     char *elName;            /* Name of array element or NULL;
  142.                      * may be same as part2, or may be
  143.                      * openParen+1. */
  144.     char *p;
  145.  
  146.     /*
  147.      * If the name hasn't been parsed into array name and index yet,
  148.      * do it now.
  149.      */
  150.  
  151.     openParen = closeParen = NULL;
  152.     elName = part2;
  153.     if (flags & PART1_NOT_PARSED) {
  154.     for (p = part1; ; p++) {
  155.         if (*p == 0) {
  156.         elName = NULL;
  157.         break;
  158.         }
  159.         if (*p == '(') {
  160.         openParen = p;
  161.         do {
  162.             p++;
  163.         } while (*p != '\0');
  164.         p--;
  165.         if (*p == ')') {
  166.             closeParen = p;
  167.             *openParen = 0;
  168.             elName = openParen+1;
  169.         } else {
  170.             openParen = NULL;
  171.             elName = NULL;
  172.         }
  173.         break;
  174.         }
  175.     }
  176.     }
  177.  
  178.     /*
  179.      * Lookup part1.
  180.      */
  181.  
  182.     *arrayPtrPtr = NULL;
  183.     if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
  184.     tablePtr = &iPtr->globalTable;
  185.     } else {
  186.     tablePtr = &iPtr->varFramePtr->varTable;
  187.     }
  188.     if (create & CRT_PART1) {
  189.     hPtr = Tcl_CreateHashEntry(tablePtr, part1, &new);
  190.     if (openParen != NULL) {
  191.         *openParen = '(';
  192.     }
  193.     if (new) {
  194.         varPtr = NewVar();
  195.         Tcl_SetHashValue(hPtr, varPtr);
  196.         varPtr->hPtr = hPtr;
  197.     }
  198.     } else {
  199.     hPtr = Tcl_FindHashEntry(tablePtr, part1);
  200.     if (openParen != NULL) {
  201.         *openParen = '(';
  202.     }
  203.     if (hPtr == NULL) {
  204.         if (flags & TCL_LEAVE_ERR_MSG) {
  205.         VarErrMsg(interp, part1, part2, msg, noSuchVar);
  206.         }
  207.         return NULL;
  208.     }
  209.     }
  210.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  211.     if (varPtr->flags & VAR_UPVAR) {
  212.     varPtr = varPtr->value.upvarPtr;
  213.     }
  214.  
  215.     if (elName == NULL) {
  216.     return varPtr;
  217.     }
  218.  
  219.     /*
  220.      * We're dealing with an array element, so make sure the variable
  221.      * is an array and lookup the element (create it if desired).
  222.      */
  223.  
  224.     if (varPtr->flags & VAR_UNDEFINED) {
  225.     if (!(create & CRT_PART1)) {
  226.         if (flags & TCL_LEAVE_ERR_MSG) {
  227.         VarErrMsg(interp, part1, part2, msg, noSuchVar);
  228.         }
  229.         return NULL;
  230.     }
  231.     varPtr->flags = VAR_ARRAY;
  232.     varPtr->value.tablePtr = (Tcl_HashTable *)
  233.         ckalloc(sizeof(Tcl_HashTable));
  234.     Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
  235.     } else if (!(varPtr->flags & VAR_ARRAY)) {
  236.     if (flags & TCL_LEAVE_ERR_MSG) {
  237.         VarErrMsg(interp, part1, part2, msg, needArray);
  238.     }
  239.     return NULL;
  240.     }
  241.     *arrayPtrPtr = varPtr;
  242.     if (closeParen != NULL) {
  243.     *closeParen = 0;
  244.     }
  245.     if (create & CRT_PART2) {
  246.     hPtr = Tcl_CreateHashEntry(varPtr->value.tablePtr, elName, &new);
  247.     if (closeParen != NULL) {
  248.         *closeParen = ')';
  249.     }
  250.     if (new) {
  251.         if (varPtr->searchPtr != NULL) {
  252.         DeleteSearches(varPtr);
  253.         }
  254.         varPtr = NewVar();
  255.         Tcl_SetHashValue(hPtr, varPtr);
  256.         varPtr->hPtr = hPtr;
  257.     }
  258.     } else {
  259.     hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, elName);
  260.     if (closeParen != NULL) {
  261.         *closeParen = ')';
  262.     }
  263.     if (hPtr == NULL) {
  264.         if (flags & TCL_LEAVE_ERR_MSG) {
  265.         VarErrMsg(interp, part1, part2, msg, noSuchElement);
  266.         }
  267.         return NULL;
  268.     }
  269.     }
  270.     return (Var *) Tcl_GetHashValue(hPtr);
  271. }
  272.  
  273. /*
  274.  *----------------------------------------------------------------------
  275.  *
  276.  * Tcl_GetVar --
  277.  *
  278.  *    Return the value of a Tcl variable.
  279.  *
  280.  * Results:
  281.  *    The return value points to the current value of varName.  If
  282.  *    the variable is not defined or can't be read because of a clash
  283.  *    in array usage then a NULL pointer is returned and an error
  284.  *    message is left in interp->result if the TCL_LEAVE_ERR_MSG
  285.  *    flag is set.  Note:  the return value is only valid up until
  286.  *    the next call to Tcl_SetVar or Tcl_SetVar2;  if you depend on
  287.  *    the value lasting longer than that, then make yourself a private
  288.  *    copy.
  289.  *
  290.  * Side effects:
  291.  *    None.
  292.  *
  293.  *----------------------------------------------------------------------
  294.  */
  295.  
  296. char *
  297. Tcl_GetVar(interp, varName, flags)
  298.     Tcl_Interp *interp;        /* Command interpreter in which varName is
  299.                  * to be looked up. */
  300.     char *varName;        /* Name of a variable in interp. */
  301.     int flags;            /* OR-ed combination of TCL_GLOBAL_ONLY
  302.                  * or TCL_LEAVE_ERR_MSG bits. */
  303. {
  304.     return Tcl_GetVar2(interp, varName, (char *) NULL,
  305.         flags | PART1_NOT_PARSED);
  306. }
  307.  
  308. /*
  309.  *----------------------------------------------------------------------
  310.  *
  311.  * Tcl_GetVar2 --
  312.  *
  313.  *    Return the value of a Tcl variable, given a two-part name
  314.  *    consisting of array name and element within array.
  315.  *
  316.  * Results:
  317.  *    The return value points to the current value of the variable
  318.  *    given by part1 and part2.  If the specified variable doesn't
  319.  *    exist, or if there is a clash in array usage, then NULL is
  320.  *    returned and a message will be left in interp->result if the
  321.  *    TCL_LEAVE_ERR_MSG flag is set.  Note:  the return value is
  322.  *    only valid up until the next call to Tcl_SetVar or Tcl_SetVar2;
  323.  *    if you depend on the value lasting longer than that, then make
  324.  *    yourself a private copy.
  325.  *
  326.  * Side effects:
  327.  *    None.
  328.  *
  329.  *----------------------------------------------------------------------
  330.  */
  331.  
  332. char *
  333. Tcl_GetVar2(interp, part1, part2, flags)
  334.     Tcl_Interp *interp;        /* Command interpreter in which variable is
  335.                  * to be looked up. */
  336.     char *part1;        /* Name of array (if part2 is NULL) or
  337.                  * name of variable. */
  338.     char *part2;        /* If non-null, gives name of element in
  339.                  * array. */
  340.     int flags;            /* OR-ed combination of TCL_GLOBAL_ONLY,
  341.                  * TCL_LEAVE_ERR_MSG, and PART1_NOT_PARSED
  342.                  * bits. */
  343. {
  344.     Var *varPtr, *arrayPtr;
  345.     Interp *iPtr = (Interp *) interp;
  346.  
  347.     varPtr = LookupVar(interp, part1, part2, flags, "read", CRT_PART2,
  348.         &arrayPtr);
  349.     if (varPtr == NULL) {
  350.     return NULL;
  351.     }
  352.  
  353.     /*
  354.      * Invoke any traces that have been set for the variable.
  355.      */
  356.  
  357.     if ((varPtr->tracePtr != NULL)
  358.         || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
  359.     char *msg;
  360.  
  361.     msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2,
  362.         (flags & (TCL_GLOBAL_ONLY|PART1_NOT_PARSED)) | TCL_TRACE_READS);
  363.     if (msg != NULL) {
  364.         VarErrMsg(interp, part1, part2, "read", msg);
  365.         goto cleanup;
  366.     }
  367.     }
  368.     if (!(varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR|VAR_ARRAY))) {
  369.     return varPtr->value.string;
  370.     }
  371.     if (flags & TCL_LEAVE_ERR_MSG) {
  372.     char *msg;
  373.  
  374.     if ((varPtr->flags & VAR_UNDEFINED) && (arrayPtr != NULL)
  375.         && !(arrayPtr->flags & VAR_UNDEFINED)) {
  376.         msg = noSuchElement;
  377.     } else if (varPtr->flags & VAR_ARRAY) {
  378.         msg = isArray;
  379.     } else {
  380.         msg = noSuchVar;
  381.     }
  382.     VarErrMsg(interp, part1, part2, "read", msg);
  383.     }
  384.  
  385.     /*
  386.      * If the variable doesn't exist anymore and no-one's using it,
  387.      * then free up the relevant structures and hash table entries.
  388.      */
  389.  
  390.     cleanup:
  391.     if (varPtr->flags & VAR_UNDEFINED) {
  392.     CleanupVar(varPtr, arrayPtr);
  393.     }
  394.     return NULL;
  395. }
  396.  
  397. /*
  398.  *----------------------------------------------------------------------
  399.  *
  400.  * Tcl_SetVar --
  401.  *
  402.  *    Change the value of a variable.
  403.  *
  404.  * Results:
  405.  *    Returns a pointer to the malloc'ed string holding the new
  406.  *    value of the variable.  The caller should not modify this
  407.  *    string.  If the write operation was disallowed then NULL
  408.  *    is returned;  if the TCL_LEAVE_ERR_MSG flag is set, then
  409.  *    an explanatory message will be left in interp->result.
  410.  *
  411.  * Side effects:
  412.  *    If varName is defined as a local or global variable in interp,
  413.  *    its value is changed to newValue.  If varName isn't currently
  414.  *    defined, then a new global variable by that name is created.
  415.  *
  416.  *----------------------------------------------------------------------
  417.  */
  418.  
  419. char *
  420. Tcl_SetVar(interp, varName, newValue, flags)
  421.     Tcl_Interp *interp;        /* Command interpreter in which varName is
  422.                  * to be looked up. */
  423.     char *varName;        /* Name of a variable in interp. */
  424.     char *newValue;        /* New value for varName. */
  425.     int flags;            /* Various flags that tell how to set value:
  426.                  * any of TCL_GLOBAL_ONLY, TCL_APPEND_VALUE,
  427.                  * TCL_LIST_ELEMENT, or TCL_LEAVE_ERR_MSG. */
  428. {
  429.     return Tcl_SetVar2(interp, varName, (char *) NULL, newValue,
  430.         flags | PART1_NOT_PARSED);
  431. }
  432.  
  433. /*
  434.  *----------------------------------------------------------------------
  435.  *
  436.  * Tcl_SetVar2 --
  437.  *
  438.  *    Given a two-part variable name, which may refer either to a
  439.  *    scalar variable or an element of an array, change the value
  440.  *    of the variable.  If the named scalar or array or element
  441.  *    doesn't exist then create one.
  442.  *
  443.  * Results:
  444.  *    Returns a pointer to the malloc'ed string holding the new
  445.  *    value of the variable.  The caller should not modify this
  446.  *    string.  If the write operation was disallowed because an
  447.  *    array was expected but not found (or vice versa), then NULL
  448.  *    is returned;  if the TCL_LEAVE_ERR_MSG flag is set, then
  449.  *    an explanatory message will be left in interp->result.
  450.  *
  451.  * Side effects:
  452.  *    The value of the given variable is set.  If either the array
  453.  *    or the entry didn't exist then a new one is created.
  454.  *
  455.  *----------------------------------------------------------------------
  456.  */
  457.  
  458. char *
  459. Tcl_SetVar2(interp, part1, part2, newValue, flags)
  460.     Tcl_Interp *interp;        /* Command interpreter in which variable is
  461.                  * to be looked up. */
  462.     char *part1;        /* If part2 is NULL, this is name of scalar
  463.                  * variable.  Otherwise it is name of array. */
  464.     char *part2;        /* Name of an element within array, or NULL. */
  465.     char *newValue;        /* New value for variable. */
  466.     int flags;            /* Various flags that tell how to set value:
  467.                  * any of TCL_GLOBAL_ONLY, TCL_APPEND_VALUE,
  468.                  * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG, or
  469.                  * PART1_NOT_PARSED. */
  470. {
  471.     register Var *varPtr;
  472.     register Interp *iPtr = (Interp *) interp;
  473.     int length, listFlags;
  474.     Var *arrayPtr;
  475.     char *result;
  476.  
  477.     varPtr = LookupVar(interp, part1, part2, flags, "set", CRT_PART1|CRT_PART2,
  478.         &arrayPtr);
  479.     if (varPtr == NULL) {
  480.     return NULL;
  481.     }
  482.  
  483.     /*
  484.      * If the variable's hPtr field is NULL, it means that this is an
  485.      * upvar to an array element where the array was deleted, leaving
  486.      * the element dangling at the end of the upvar.  Generate an error
  487.      * (allowing the variable to be reset would screw up our storage
  488.      * allocation and is meaningless anyway).
  489.      */
  490.  
  491.     if (varPtr->hPtr == NULL) {
  492.     if (flags & TCL_LEAVE_ERR_MSG) {
  493.         VarErrMsg(interp, part1, part2, "set", danglingUpvar);
  494.     }
  495.     return NULL;
  496.     }
  497.  
  498.     /*
  499.      * Clear the variable's current value unless this is an
  500.      * append operation.
  501.      */
  502.  
  503.     if (varPtr->flags & VAR_ARRAY) {
  504.     if (flags & TCL_LEAVE_ERR_MSG) {
  505.         VarErrMsg(interp, part1, part2, "set", isArray);
  506.     }
  507.     return NULL;
  508.     }
  509.     if (!(flags & TCL_APPEND_VALUE) || (varPtr->flags & VAR_UNDEFINED)) {
  510.     varPtr->valueLength = 0;
  511.     }
  512.  
  513.     /*
  514.      * Call read trace if variable is being appended to.
  515.      */
  516.  
  517.     if ((flags & TCL_APPEND_VALUE) && ((varPtr->tracePtr != NULL)
  518.         || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL)))) {
  519.     char *msg;
  520.     msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2,
  521.         (flags & (TCL_GLOBAL_ONLY|PART1_NOT_PARSED)) | TCL_TRACE_READS);
  522.     if (msg != NULL) {
  523.         VarErrMsg(interp, part1, part2, "read", msg);
  524.         result = NULL;
  525.         goto cleanup;
  526.     }
  527.     }
  528.  
  529.     /*
  530.      * Compute how many total bytes will be needed for the variable's
  531.      * new value (leave space for a separating space between list
  532.      * elements).  Allocate new space for the value if needed.
  533.      */
  534.  
  535.     if (flags & TCL_LIST_ELEMENT) {
  536.     length = Tcl_ScanElement(newValue, &listFlags) + 1;
  537.     } else {
  538.     length = strlen(newValue);
  539.     }
  540.     length += varPtr->valueLength;
  541.     if (length >= varPtr->valueSpace) {
  542.     char *newValue;
  543.     int newSize;
  544.  
  545.     newSize = 2*varPtr->valueSpace;
  546.     if (newSize <= length) {
  547.         newSize = length + 1;
  548.     }
  549.     if (newSize < 24) {
  550.         /*
  551.          * Don't waste time with teensy-tiny variables;  we'll
  552.          * just end up expanding them later.
  553.          */
  554.  
  555.         newSize = 24;
  556.     }
  557.     newValue = ckalloc((unsigned) newSize);
  558.     if (varPtr->valueSpace > 0) {
  559.         strcpy(newValue, varPtr->value.string);
  560.         ckfree(varPtr->value.string);
  561.     }
  562.     varPtr->valueSpace = newSize;
  563.     varPtr->value.string = newValue;
  564.     }
  565.  
  566.     /*
  567.      * Append the new value to the variable, either as a list
  568.      * element or as a string.
  569.      */
  570.  
  571.     if (flags & TCL_LIST_ELEMENT) {
  572.     char *dst = varPtr->value.string + varPtr->valueLength;
  573.  
  574.     if (TclNeedSpace(varPtr->value.string, dst)) {
  575.         *dst = ' ';
  576.         dst++;
  577.         varPtr->valueLength++;
  578.     }
  579.     varPtr->valueLength += Tcl_ConvertElement(newValue, dst, listFlags);
  580.     } else {
  581.     strcpy(varPtr->value.string + varPtr->valueLength, newValue);
  582.     varPtr->valueLength = length;
  583.     }
  584.     varPtr->flags &= ~VAR_UNDEFINED;
  585.  
  586.     /*
  587.      * Invoke any write traces for the variable.
  588.      */
  589.  
  590.     if ((varPtr->tracePtr != NULL)
  591.         || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
  592.     char *msg;
  593.  
  594.     msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2,
  595.         (flags & (TCL_GLOBAL_ONLY|PART1_NOT_PARSED))
  596.         | TCL_TRACE_WRITES);
  597.     if (msg != NULL) {
  598.         VarErrMsg(interp, part1, part2, "set", msg);
  599.         result = NULL;
  600.         goto cleanup;
  601.     }
  602.     }
  603.  
  604.     /*
  605.      * If the variable was changed in some gross way by a trace (e.g.
  606.      * it was unset and then recreated as an array) then just return
  607.      * an empty string;  otherwise return the variable's current
  608.      * value.
  609.      */
  610.  
  611.     if (!(varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR|VAR_ARRAY))) {
  612.     return varPtr->value.string;
  613.     }
  614.     result = "";
  615.  
  616.     /*
  617.      * If the variable doesn't exist anymore and no-one's using it,
  618.      * then free up the relevant structures and hash table entries.
  619.      */
  620.  
  621.     cleanup:
  622.     if (varPtr->flags & VAR_UNDEFINED) {
  623.     CleanupVar(varPtr, arrayPtr);
  624.     }
  625.     return result;
  626. }
  627.  
  628. /*
  629.  *----------------------------------------------------------------------
  630.  *
  631.  * Tcl_UnsetVar --
  632.  *
  633.  *    Delete a variable, so that it may not be accessed anymore.
  634.  *
  635.  * Results:
  636.  *    Returns TCL_OK if the variable was successfully deleted, TCL_ERROR
  637.  *    if the variable can't be unset.  In the event of an error,
  638.  *    if the TCL_LEAVE_ERR_MSG flag is set then an error message
  639.  *    is left in interp->result.
  640.  *
  641.  * Side effects:
  642.  *    If varName is defined as a local or global variable in interp,
  643.  *    it is deleted.
  644.  *
  645.  *----------------------------------------------------------------------
  646.  */
  647.  
  648. int
  649. Tcl_UnsetVar(interp, varName, flags)
  650.     Tcl_Interp *interp;        /* Command interpreter in which varName is
  651.                  * to be looked up. */
  652.     char *varName;        /* Name of a variable in interp.  May be
  653.                  * either a scalar name or an array name
  654.                  * or an element in an array. */
  655.     int flags;            /* OR-ed combination of any of
  656.                  * TCL_GLOBAL_ONLY or TCL_LEAVE_ERR_MSG. */
  657. {
  658.     return Tcl_UnsetVar2(interp, varName, (char *) NULL,
  659.         flags | PART1_NOT_PARSED);
  660. }
  661.  
  662. /*
  663.  *----------------------------------------------------------------------
  664.  *
  665.  * Tcl_UnsetVar2 --
  666.  *
  667.  *    Delete a variable, given a 2-part name.
  668.  *
  669.  * Results:
  670.  *    Returns TCL_OK if the variable was successfully deleted, TCL_ERROR
  671.  *    if the variable can't be unset.  In the event of an error,
  672.  *    if the TCL_LEAVE_ERR_MSG flag is set then an error message
  673.  *    is left in interp->result.
  674.  *
  675.  * Side effects:
  676.  *    If part1 and part2 indicate a local or global variable in interp,
  677.  *    it is deleted.  If part1 is an array name and part2 is NULL, then
  678.  *    the whole array is deleted.
  679.  *
  680.  *----------------------------------------------------------------------
  681.  */
  682.  
  683. int
  684. Tcl_UnsetVar2(interp, part1, part2, flags)
  685.     Tcl_Interp *interp;        /* Command interpreter in which varName is
  686.                  * to be looked up. */
  687.     char *part1;        /* Name of variable or array. */
  688.     char *part2;        /* Name of element within array or NULL. */
  689.     int flags;            /* OR-ed combination of any of
  690.                  * TCL_GLOBAL_ONLY, TCL_LEAVE_ERR_MSG,
  691.                  * or PART1_NOT_PARSED. */
  692. {
  693.     Var *varPtr, dummyVar;
  694.     Interp *iPtr = (Interp *) interp;
  695.     Var *arrayPtr;
  696.     ActiveVarTrace *activePtr;
  697.     int result;
  698.  
  699.     varPtr = LookupVar(interp, part1, part2, flags, "unset", 0,  &arrayPtr);
  700.     if (varPtr == NULL) {
  701.     return TCL_ERROR;
  702.     }
  703.     result = (varPtr->flags & VAR_UNDEFINED) ? TCL_ERROR : TCL_OK;
  704.  
  705.     if ((arrayPtr != NULL) && (arrayPtr->searchPtr != NULL)) {
  706.     DeleteSearches(arrayPtr);
  707.     }
  708.  
  709.     /*
  710.      * The code below is tricky, because of the possibility that
  711.      * a trace procedure might try to access a variable being
  712.      * deleted.  To handle this situation gracefully, do things
  713.      * in three steps:
  714.      * 1. Copy the contents of the variable to a dummy variable
  715.      *    structure, and mark the original structure as undefined.
  716.      * 2. Invoke traces and clean up the variable, using the copy.
  717.      * 3. If at the end of this the original variable is still
  718.      *    undefined and has no outstanding references, then delete
  719.      *      it (but it could have gotten recreated by a trace).
  720.      */
  721.  
  722.     dummyVar = *varPtr;
  723.     varPtr->valueSpace = 0;
  724.     varPtr->flags = VAR_UNDEFINED;
  725.     varPtr->tracePtr = NULL;
  726.     varPtr->searchPtr = NULL;
  727.  
  728.     /*
  729.      * Call trace procedures for the variable being deleted and delete
  730.      * its traces.  Be sure to abort any other traces for the variable
  731.      * that are still pending.  Special tricks:
  732.      * 1. Increment varPtr's refCount around this:  CallTraces will
  733.      *    use dummyVar so it won't increment varPtr's refCount.
  734.      * 2. Turn off the VAR_TRACE_ACTIVE flag in dummyVar: we want to
  735.      *    call unset traces even if other traces are pending.
  736.      */
  737.  
  738.     if ((dummyVar.tracePtr != NULL)
  739.         || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
  740.     varPtr->refCount++;
  741.     dummyVar.flags &= ~VAR_TRACE_ACTIVE;
  742.     (void) CallTraces(iPtr, arrayPtr, &dummyVar, part1, part2,
  743.         (flags & (TCL_GLOBAL_ONLY|PART1_NOT_PARSED))
  744.         | TCL_TRACE_UNSETS);
  745.     while (dummyVar.tracePtr != NULL) {
  746.         VarTrace *tracePtr = dummyVar.tracePtr;
  747.         dummyVar.tracePtr = tracePtr->nextPtr;
  748.         ckfree((char *) tracePtr);
  749.     }
  750.     for (activePtr = iPtr->activeTracePtr; activePtr != NULL;
  751.         activePtr = activePtr->nextPtr) {
  752.         if (activePtr->varPtr == varPtr) {
  753.         activePtr->nextTracePtr = NULL;
  754.         }
  755.     }
  756.     varPtr->refCount--;
  757.     }
  758.  
  759.     /*
  760.      * If the variable is an array, delete all of its elements.  This
  761.      * must be done after calling the traces on the array, above (that's
  762.      * the way traces are defined).
  763.      */
  764.  
  765.     if (dummyVar.flags & VAR_ARRAY) {
  766.     DeleteArray(iPtr, part1, &dummyVar,
  767.         (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_UNSETS);
  768.     }
  769.     if (dummyVar.valueSpace > 0) {
  770.     ckfree(dummyVar.value.string);
  771.     }
  772.     if (result == TCL_ERROR) {
  773.     if (flags & TCL_LEAVE_ERR_MSG) {
  774.         VarErrMsg(interp, part1, part2, "unset",
  775.             (arrayPtr == NULL) ? noSuchVar : noSuchElement);
  776.     }
  777.     }
  778.  
  779.     /*
  780.      * Finally, if the variable is truly not in use then free up its
  781.      * record and remove it from the hash table.
  782.      */
  783.  
  784.     CleanupVar(varPtr, arrayPtr);
  785.     return result;
  786. }
  787.  
  788. /*
  789.  *----------------------------------------------------------------------
  790.  *
  791.  * Tcl_TraceVar --
  792.  *
  793.  *    Arrange for reads and/or writes to a variable to cause a
  794.  *    procedure to be invoked, which can monitor the operations
  795.  *    and/or change their actions.
  796.  *
  797.  * Results:
  798.  *    A standard Tcl return value.
  799.  *
  800.  * Side effects:
  801.  *    A trace is set up on the variable given by varName, such that
  802.  *    future references to the variable will be intermediated by
  803.  *    proc.  See the manual entry for complete details on the calling
  804.  *    sequence for proc.
  805.  *
  806.  *----------------------------------------------------------------------
  807.  */
  808.  
  809. int
  810. Tcl_TraceVar(interp, varName, flags, proc, clientData)
  811.     Tcl_Interp *interp;        /* Interpreter in which variable is
  812.                  * to be traced. */
  813.     char *varName;        /* Name of variable;  may end with "(index)"
  814.                  * to signify an array reference. */
  815.     int flags;            /* OR-ed collection of bits, including any
  816.                  * of TCL_TRACE_READS, TCL_TRACE_WRITES,
  817.                  * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
  818.     Tcl_VarTraceProc *proc;    /* Procedure to call when specified ops are
  819.                  * invoked upon varName. */
  820.     ClientData clientData;    /* Arbitrary argument to pass to proc. */
  821. {
  822.     return Tcl_TraceVar2(interp, varName, (char *) NULL,
  823.         flags | PART1_NOT_PARSED, proc, clientData);
  824. }
  825.  
  826. /*
  827.  *----------------------------------------------------------------------
  828.  *
  829.  * Tcl_TraceVar2 --
  830.  *
  831.  *    Arrange for reads and/or writes to a variable to cause a
  832.  *    procedure to be invoked, which can monitor the operations
  833.  *    and/or change their actions.
  834.  *
  835.  * Results:
  836.  *    A standard Tcl return value.
  837.  *
  838.  * Side effects:
  839.  *    A trace is set up on the variable given by part1 and part2, such
  840.  *    that future references to the variable will be intermediated by
  841.  *    proc.  See the manual entry for complete details on the calling
  842.  *    sequence for proc.
  843.  *
  844.  *----------------------------------------------------------------------
  845.  */
  846.  
  847. int
  848. Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData)
  849.     Tcl_Interp *interp;        /* Interpreter in which variable is
  850.                  * to be traced. */
  851.     char *part1;        /* Name of scalar variable or array. */
  852.     char *part2;        /* Name of element within array;  NULL means
  853.                  * trace applies to scalar variable or array
  854.                  * as-a-whole. */
  855.     int flags;            /* OR-ed collection of bits, including any
  856.                  * of TCL_TRACE_READS, TCL_TRACE_WRITES,
  857.                  * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and
  858.                  * PART1_NOT_PARSED. */
  859.     Tcl_VarTraceProc *proc;    /* Procedure to call when specified ops are
  860.                  * invoked upon varName. */
  861.     ClientData clientData;    /* Arbitrary argument to pass to proc. */
  862. {
  863.     Var *varPtr, *arrayPtr;
  864.     register VarTrace *tracePtr;
  865.  
  866.     varPtr = LookupVar(interp, part1, part2, (flags | TCL_LEAVE_ERR_MSG),
  867.         "trace", CRT_PART1|CRT_PART2, &arrayPtr);
  868.     if (varPtr == NULL) {
  869.     return TCL_ERROR;
  870.     }
  871.  
  872.     /*
  873.      * Set up trace information.
  874.      */
  875.  
  876.     tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace));
  877.     tracePtr->traceProc = proc;
  878.     tracePtr->clientData = clientData;
  879.     tracePtr->flags = flags &
  880.         (TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS);
  881.     tracePtr->nextPtr = varPtr->tracePtr;
  882.     varPtr->tracePtr = tracePtr;
  883.     return TCL_OK;
  884. }
  885.  
  886. /*
  887.  *----------------------------------------------------------------------
  888.  *
  889.  * Tcl_UntraceVar --
  890.  *
  891.  *    Remove a previously-created trace for a variable.
  892.  *
  893.  * Results:
  894.  *    None.
  895.  *
  896.  * Side effects:
  897.  *    If there exists a trace for the variable given by varName
  898.  *    with the given flags, proc, and clientData, then that trace
  899.  *    is removed.
  900.  *
  901.  *----------------------------------------------------------------------
  902.  */
  903.  
  904. void
  905. Tcl_UntraceVar(interp, varName, flags, proc, clientData)
  906.     Tcl_Interp *interp;        /* Interpreter containing traced variable. */
  907.     char *varName;        /* Name of variable;  may end with "(index)"
  908.                  * to signify an array reference. */
  909.     int flags;            /* OR-ed collection of bits describing
  910.                  * current trace, including any of
  911.                  * TCL_TRACE_READS, TCL_TRACE_WRITES,
  912.                  * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
  913.     Tcl_VarTraceProc *proc;    /* Procedure assocated with trace. */
  914.     ClientData clientData;    /* Arbitrary argument to pass to proc. */
  915. {
  916.     Tcl_UntraceVar2(interp, varName, (char *) NULL, flags | PART1_NOT_PARSED,
  917.         proc, clientData);
  918. }
  919.  
  920. /*
  921.  *----------------------------------------------------------------------
  922.  *
  923.  * Tcl_UntraceVar2 --
  924.  *
  925.  *    Remove a previously-created trace for a variable.
  926.  *
  927.  * Results:
  928.  *    None.
  929.  *
  930.  * Side effects:
  931.  *    If there exists a trace for the variable given by part1
  932.  *    and part2 with the given flags, proc, and clientData, then
  933.  *    that trace is removed.
  934.  *
  935.  *----------------------------------------------------------------------
  936.  */
  937.  
  938. void
  939. Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData)
  940.     Tcl_Interp *interp;        /* Interpreter containing traced variable. */
  941.     char *part1;        /* Name of variable or array. */
  942.     char *part2;        /* Name of element within array;  NULL means
  943.                  * trace applies to scalar variable or array
  944.                  * as-a-whole. */
  945.     int flags;            /* OR-ed collection of bits describing
  946.                  * current trace, including any of
  947.                  * TCL_TRACE_READS, TCL_TRACE_WRITES,
  948.                  * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and
  949.                  * PART1_NOT_PARSED. */
  950.     Tcl_VarTraceProc *proc;    /* Procedure assocated with trace. */
  951.     ClientData clientData;    /* Arbitrary argument to pass to proc. */
  952. {
  953.     register VarTrace *tracePtr;
  954.     VarTrace *prevPtr;
  955.     Var *varPtr, *arrayPtr;
  956.     Interp *iPtr = (Interp *) interp;
  957.     ActiveVarTrace *activePtr;
  958.  
  959.     varPtr = LookupVar(interp, part1, part2,
  960.         flags & (TCL_GLOBAL_ONLY|PART1_NOT_PARSED), (char *) NULL, 0,
  961.         &arrayPtr);
  962.     if (varPtr == NULL) {
  963.     return;
  964.     }
  965.  
  966.     flags &= (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS);
  967.     for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ;
  968.         prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
  969.     if (tracePtr == NULL) {
  970.         return;
  971.     }
  972.     if ((tracePtr->traceProc == proc) && (tracePtr->flags == flags)
  973.         && (tracePtr->clientData == clientData)) {
  974.         break;
  975.     }
  976.     }
  977.  
  978.     /*
  979.      * The code below makes it possible to delete traces while traces
  980.      * are active:  it makes sure that the deleted trace won't be
  981.      * processed by CallTraces.
  982.      */
  983.  
  984.     for (activePtr = iPtr->activeTracePtr; activePtr != NULL;
  985.         activePtr = activePtr->nextPtr) {
  986.     if (activePtr->nextTracePtr == tracePtr) {
  987.         activePtr->nextTracePtr = tracePtr->nextPtr;
  988.     }
  989.     }
  990.     if (prevPtr == NULL) {
  991.     varPtr->tracePtr = tracePtr->nextPtr;
  992.     } else {
  993.     prevPtr->nextPtr = tracePtr->nextPtr;
  994.     }
  995.     ckfree((char *) tracePtr);
  996.  
  997.     /*
  998.      * If this is the last trace on the variable, and the variable is
  999.      * unset and unused, then free up the variable.
  1000.      */
  1001.  
  1002.     if (varPtr->flags & VAR_UNDEFINED) {
  1003.     CleanupVar(varPtr, (Var *) NULL);
  1004.     }
  1005. }
  1006.  
  1007. /*
  1008.  *----------------------------------------------------------------------
  1009.  *
  1010.  * Tcl_VarTraceInfo --
  1011.  *
  1012.  *    Return the clientData value associated with a trace on a
  1013.  *    variable.  This procedure can also be used to step through
  1014.  *    all of the traces on a particular variable that have the
  1015.  *    same trace procedure.
  1016.  *
  1017.  * Results:
  1018.  *    The return value is the clientData value associated with
  1019.  *    a trace on the given variable.  Information will only be
  1020.  *    returned for a trace with proc as trace procedure.  If
  1021.  *    the clientData argument is NULL then the first such trace is
  1022.  *    returned;  otherwise, the next relevant one after the one
  1023.  *    given by clientData will be returned.  If the variable
  1024.  *    doesn't exist, or if there are no (more) traces for it,
  1025.  *    then NULL is returned.
  1026.  *
  1027.  * Side effects:
  1028.  *    None.
  1029.  *
  1030.  *----------------------------------------------------------------------
  1031.  */
  1032.  
  1033. ClientData
  1034. Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData)
  1035.     Tcl_Interp *interp;        /* Interpreter containing variable. */
  1036.     char *varName;        /* Name of variable;  may end with "(index)"
  1037.                  * to signify an array reference. */
  1038.     int flags;            /* 0 or TCL_GLOBAL_ONLY. */
  1039.     Tcl_VarTraceProc *proc;    /* Procedure assocated with trace. */
  1040.     ClientData prevClientData;    /* If non-NULL, gives last value returned
  1041.                  * by this procedure, so this call will
  1042.                  * return the next trace after that one.
  1043.                  * If NULL, this call will return the
  1044.                  * first trace. */
  1045. {
  1046.     return Tcl_VarTraceInfo2(interp, varName, (char *) NULL,
  1047.         flags | PART1_NOT_PARSED, proc, prevClientData);
  1048. }
  1049.  
  1050. /*
  1051.  *----------------------------------------------------------------------
  1052.  *
  1053.  * Tcl_VarTraceInfo2 --
  1054.  *
  1055.  *    Same as Tcl_VarTraceInfo, except takes name in two pieces
  1056.  *    instead of one.
  1057.  *
  1058.  * Results:
  1059.  *    Same as Tcl_VarTraceInfo.
  1060.  *
  1061.  * Side effects:
  1062.  *    None.
  1063.  *
  1064.  *----------------------------------------------------------------------
  1065.  */
  1066.  
  1067. ClientData
  1068. Tcl_VarTraceInfo2(interp, part1, part2, flags, proc, prevClientData)
  1069.     Tcl_Interp *interp;        /* Interpreter containing variable. */
  1070.     char *part1;        /* Name of variable or array. */
  1071.     char *part2;        /* Name of element within array;  NULL means
  1072.                  * trace applies to scalar variable or array
  1073.                  * as-a-whole. */
  1074.     int flags;            /* OR-ed combination of TCL_GLOBAL_ONLY and
  1075.                  * PART1_NOT_PARSED. */
  1076.     Tcl_VarTraceProc *proc;    /* Procedure assocated with trace. */
  1077.     ClientData prevClientData;    /* If non-NULL, gives last value returned
  1078.                  * by this procedure, so this call will
  1079.                  * return the next trace after that one.
  1080.                  * If NULL, this call will return the
  1081.                  * first trace. */
  1082. {
  1083.     register VarTrace *tracePtr;
  1084.     Var *varPtr, *arrayPtr;
  1085.  
  1086.     varPtr = LookupVar(interp, part1, part2,
  1087.         flags & (TCL_GLOBAL_ONLY|PART1_NOT_PARSED), (char *) NULL, 0,
  1088.         &arrayPtr);
  1089.     if (varPtr == NULL) {
  1090.     return NULL;
  1091.     }
  1092.  
  1093.     /*
  1094.      * Find the relevant trace, if any, and return its clientData.
  1095.      */
  1096.  
  1097.     tracePtr = varPtr->tracePtr;
  1098.     if (prevClientData != NULL) {
  1099.     for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
  1100.         if ((tracePtr->clientData == prevClientData)
  1101.             && (tracePtr->traceProc == proc)) {
  1102.         tracePtr = tracePtr->nextPtr;
  1103.         break;
  1104.         }
  1105.     }
  1106.     }
  1107.     for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
  1108.     if (tracePtr->traceProc == proc) {
  1109.         return tracePtr->clientData;
  1110.     }
  1111.     }
  1112.     return NULL;
  1113. }
  1114.  
  1115. /*
  1116.  *----------------------------------------------------------------------
  1117.  *
  1118.  * Tcl_SetCmd --
  1119.  *
  1120.  *    This procedure is invoked to process the "set" Tcl command.
  1121.  *    See the user documentation for details on what it does.
  1122.  *
  1123.  * Results:
  1124.  *    A standard Tcl result value.
  1125.  *
  1126.  * Side effects:
  1127.  *    A variable's value may be changed.
  1128.  *
  1129.  *----------------------------------------------------------------------
  1130.  */
  1131.  
  1132.     /* ARGSUSED */
  1133. int
  1134. Tcl_SetCmd(dummy, interp, argc, argv)
  1135.     ClientData dummy;            /* Not used. */
  1136.     register Tcl_Interp *interp;    /* Current interpreter. */
  1137.     int argc;                /* Number of arguments. */
  1138.     char **argv;            /* Argument strings. */
  1139. {
  1140.     if (argc == 2) {
  1141.     char *value;
  1142.  
  1143.     value = Tcl_GetVar2(interp, argv[1], (char *) NULL,
  1144.         TCL_LEAVE_ERR_MSG|PART1_NOT_PARSED);
  1145.     if (value == NULL) {
  1146.         return TCL_ERROR;
  1147.     }
  1148.     interp->result = value;
  1149.     return TCL_OK;
  1150.     } else if (argc == 3) {
  1151.     char *result;
  1152.  
  1153.     result = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[2],
  1154.         TCL_LEAVE_ERR_MSG|PART1_NOT_PARSED);
  1155.     if (result == NULL) {
  1156.         return TCL_ERROR;
  1157.     }
  1158.     interp->result = result;
  1159.     return TCL_OK;
  1160.     } else {
  1161.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1162.         argv[0], " varName ?newValue?\"", (char *) NULL);
  1163.     return TCL_ERROR;
  1164.     }
  1165. }
  1166.  
  1167. /*
  1168.  *----------------------------------------------------------------------
  1169.  *
  1170.  * Tcl_UnsetCmd --
  1171.  *
  1172.  *    This procedure is invoked to process the "unset" Tcl command.
  1173.  *    See the user documentation for details on what it does.
  1174.  *
  1175.  * Results:
  1176.  *    A standard Tcl result value.
  1177.  *
  1178.  * Side effects:
  1179.  *    See the user documentation.
  1180.  *
  1181.  *----------------------------------------------------------------------
  1182.  */
  1183.  
  1184.     /* ARGSUSED */
  1185. int
  1186. Tcl_UnsetCmd(dummy, interp, argc, argv)
  1187.     ClientData dummy;            /* Not used. */
  1188.     register Tcl_Interp *interp;    /* Current interpreter. */
  1189.     int argc;                /* Number of arguments. */
  1190.     char **argv;            /* Argument strings. */
  1191. {
  1192.     int i;
  1193.  
  1194.     if (argc < 2) {
  1195.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1196.         argv[0], " varName ?varName ...?\"", (char *) NULL);
  1197.     return TCL_ERROR;
  1198.     }
  1199.     for (i = 1; i < argc; i++) {
  1200.     if (Tcl_UnsetVar2(interp, argv[i], (char *) NULL,
  1201.         TCL_LEAVE_ERR_MSG|PART1_NOT_PARSED) != TCL_OK) {
  1202.         return TCL_ERROR;
  1203.     }
  1204.     }
  1205.     return TCL_OK;
  1206. }
  1207.  
  1208. /*
  1209.  *----------------------------------------------------------------------
  1210.  *
  1211.  * Tcl_AppendCmd --
  1212.  *
  1213.  *    This procedure is invoked to process the "append" Tcl command.
  1214.  *    See the user documentation for details on what it does.
  1215.  *
  1216.  * Results:
  1217.  *    A standard Tcl result value.
  1218.  *
  1219.  * Side effects:
  1220.  *    A variable's value may be changed.
  1221.  *
  1222.  *----------------------------------------------------------------------
  1223.  */
  1224.  
  1225.     /* ARGSUSED */
  1226. int
  1227. Tcl_AppendCmd(dummy, interp, argc, argv)
  1228.     ClientData dummy;            /* Not used. */
  1229.     register Tcl_Interp *interp;    /* Current interpreter. */
  1230.     int argc;                /* Number of arguments. */
  1231.     char **argv;            /* Argument strings. */
  1232. {
  1233.     int i;
  1234.     char *result = NULL;        /* (Initialization only needed to keep
  1235.                      * the compiler from complaining) */
  1236.  
  1237.     if (argc < 2) {
  1238.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1239.         argv[0], " varName ?value value ...?\"", (char *) NULL);
  1240.     return TCL_ERROR;
  1241.     }
  1242.     if (argc == 2) {
  1243.     result = Tcl_GetVar2(interp, argv[1], (char *) NULL,
  1244.         TCL_LEAVE_ERR_MSG|PART1_NOT_PARSED);
  1245.     if (result == NULL) {
  1246.         return TCL_ERROR;
  1247.     }
  1248.     interp->result = result;
  1249.     return TCL_OK;
  1250.     }
  1251.  
  1252.     for (i = 2; i < argc; i++) {
  1253.     result = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[i],
  1254.         TCL_APPEND_VALUE|TCL_LEAVE_ERR_MSG|PART1_NOT_PARSED);
  1255.     if (result == NULL) {
  1256.         return TCL_ERROR;
  1257.     }
  1258.     }
  1259.     interp->result = result;
  1260.     return TCL_OK;
  1261. }
  1262.  
  1263. /*
  1264.  *----------------------------------------------------------------------
  1265.  *
  1266.  * Tcl_LappendCmd --
  1267.  *
  1268.  *    This procedure is invoked to process the "lappend" Tcl command.
  1269.  *    See the user documentation for details on what it does.
  1270.  *
  1271.  * Results:
  1272.  *    A standard Tcl result value.
  1273.  *
  1274.  * Side effects:
  1275.  *    A variable's value may be changed.
  1276.  *
  1277.  *----------------------------------------------------------------------
  1278.  */
  1279.  
  1280.     /* ARGSUSED */
  1281. int
  1282. Tcl_LappendCmd(dummy, interp, argc, argv)
  1283.     ClientData dummy;            /* Not used. */
  1284.     register Tcl_Interp *interp;    /* Current interpreter. */
  1285.     int argc;                /* Number of arguments. */
  1286.     char **argv;            /* Argument strings. */
  1287. {
  1288.     int i;
  1289.     char *result = NULL;        /* (Initialization only needed to keep
  1290.                      * the compiler from complaining) */
  1291.  
  1292.     if (argc < 2) {
  1293.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1294.         argv[0], " varName ?value value ...?\"", (char *) NULL);
  1295.     return TCL_ERROR;
  1296.     }
  1297.     if (argc == 2) {
  1298.     result = Tcl_GetVar2(interp, argv[1], (char *) NULL,
  1299.         TCL_LEAVE_ERR_MSG|PART1_NOT_PARSED);
  1300.     if (result == NULL) {
  1301.         return TCL_ERROR;
  1302.     }
  1303.     interp->result = result;
  1304.     return TCL_OK;
  1305.     }
  1306.  
  1307.     for (i = 2; i < argc; i++) {
  1308.     result = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[i],
  1309.         TCL_APPEND_VALUE|TCL_LIST_ELEMENT|TCL_LEAVE_ERR_MSG
  1310.         |PART1_NOT_PARSED);
  1311.     if (result == NULL) {
  1312.         return TCL_ERROR;
  1313.     }
  1314.     }
  1315.     interp->result = result;
  1316.     return TCL_OK;
  1317. }
  1318.  
  1319. /*
  1320.  *----------------------------------------------------------------------
  1321.  *
  1322.  * Tcl_ArrayCmd --
  1323.  *
  1324.  *    This procedure is invoked to process the "array" Tcl command.
  1325.  *    See the user documentation for details on what it does.
  1326.  *
  1327.  * Results:
  1328.  *    A standard Tcl result value.
  1329.  *
  1330.  * Side effects:
  1331.  *    See the user documentation.
  1332.  *
  1333.  *----------------------------------------------------------------------
  1334.  */
  1335.  
  1336.     /* ARGSUSED */
  1337. int
  1338. Tcl_ArrayCmd(dummy, interp, argc, argv)
  1339.     ClientData dummy;            /* Not used. */
  1340.     register Tcl_Interp *interp;    /* Current interpreter. */
  1341.     int argc;                /* Number of arguments. */
  1342.     char **argv;            /* Argument strings. */
  1343. {
  1344.     int c, notArray;
  1345.     size_t length;
  1346.     Var *varPtr = NULL;        /* Initialization needed only to prevent
  1347.                  * compiler warning. */
  1348.     Tcl_HashEntry *hPtr;
  1349.     Interp *iPtr = (Interp *) interp;
  1350.  
  1351.     if (argc < 3) {
  1352.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1353.         argv[0], " option arrayName ?arg ...?\"", (char *) NULL);
  1354.     return TCL_ERROR;
  1355.     }
  1356.  
  1357.     /*
  1358.      * Locate the array variable (and it better be an array).
  1359.      */
  1360.  
  1361.     if (iPtr->varFramePtr == NULL) {
  1362.     hPtr = Tcl_FindHashEntry(&iPtr->globalTable, argv[2]);
  1363.     } else {
  1364.     hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, argv[2]);
  1365.     }
  1366.     notArray = 0;
  1367.     if (hPtr == NULL) {
  1368.     notArray = 1;
  1369.     } else {
  1370.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  1371.     if (varPtr->flags & VAR_UPVAR) {
  1372.         varPtr = varPtr->value.upvarPtr;
  1373.     }
  1374.     if (!(varPtr->flags & VAR_ARRAY)) {
  1375.         notArray = 1;
  1376.     }
  1377.     }
  1378.  
  1379.     /*
  1380.      * Dispatch based on the option.
  1381.      */
  1382.  
  1383.     c = argv[1][0];
  1384.     length = strlen(argv[1]);
  1385.     if ((c == 'a') && (strncmp(argv[1], "anymore", length) == 0)) {
  1386.     ArraySearch *searchPtr;
  1387.  
  1388.     if (argc != 4) {
  1389.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1390.             argv[0], " anymore arrayName searchId\"", (char *) NULL);
  1391.         return TCL_ERROR;
  1392.     }
  1393.     if (notArray) {
  1394.         goto error;
  1395.     }
  1396.     searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]);
  1397.     if (searchPtr == NULL) {
  1398.         return TCL_ERROR;
  1399.     }
  1400.     while (1) {
  1401.         Var *varPtr2;
  1402.  
  1403.         if (searchPtr->nextEntry != NULL) {
  1404.         varPtr2 = (Var *) Tcl_GetHashValue(searchPtr->nextEntry);
  1405.         if (!(varPtr2->flags & VAR_UNDEFINED)) {
  1406.             break;
  1407.         }
  1408.         }
  1409.         searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search);
  1410.         if (searchPtr->nextEntry == NULL) {
  1411.         interp->result = "0";
  1412.         return TCL_OK;
  1413.         }
  1414.     }
  1415.     interp->result = "1";
  1416.     return TCL_OK;
  1417.     } else if ((c == 'd') && (strncmp(argv[1], "donesearch", length) == 0)) {
  1418.     ArraySearch *searchPtr, *prevPtr;
  1419.  
  1420.     if (argc != 4) {
  1421.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1422.             argv[0], " donesearch arrayName searchId\"", (char *) NULL);
  1423.         return TCL_ERROR;
  1424.     }
  1425.     if (notArray) {
  1426.         goto error;
  1427.     }
  1428.     searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]);
  1429.     if (searchPtr == NULL) {
  1430.         return TCL_ERROR;
  1431.     }
  1432.     if (varPtr->searchPtr == searchPtr) {
  1433.         varPtr->searchPtr = searchPtr->nextPtr;
  1434.     } else {
  1435.         for (prevPtr = varPtr->searchPtr; ; prevPtr = prevPtr->nextPtr) {
  1436.         if (prevPtr->nextPtr == searchPtr) {
  1437.             prevPtr->nextPtr = searchPtr->nextPtr;
  1438.             break;
  1439.         }
  1440.         }
  1441.     }
  1442.     ckfree((char *) searchPtr);
  1443.     } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)) {
  1444.     if (argc != 3) {
  1445.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1446.             argv[0], " exists arrayName\"", (char *) NULL);
  1447.         return TCL_ERROR;
  1448.     }
  1449.     interp->result = (notArray) ? "0" : "1";
  1450.     } else if ((c == 'g') && (strncmp(argv[1], "get", length) == 0)) {
  1451.     Tcl_HashSearch search;
  1452.     Var *varPtr2;
  1453.     char *name;
  1454.  
  1455.     if ((argc != 3) && (argc != 4)) {
  1456.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1457.             argv[0], " get arrayName ?pattern?\"", (char *) NULL);
  1458.         return TCL_ERROR;
  1459.     }
  1460.     if (notArray) {
  1461.         return TCL_OK;
  1462.     }
  1463.     for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
  1464.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  1465.         varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
  1466.         if (varPtr2->flags & VAR_UNDEFINED) {
  1467.         continue;
  1468.         }
  1469.         name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
  1470.         if ((argc == 4) && !Tcl_StringMatch(name, argv[3])) {
  1471.         continue;
  1472.         }
  1473.         Tcl_AppendElement(interp, name);
  1474.         Tcl_AppendElement(interp, varPtr2->value.string);
  1475.     }
  1476.     } else if ((c == 'n') && (strncmp(argv[1], "names", length) == 0)
  1477.         && (length >= 2)) {
  1478.     Tcl_HashSearch search;
  1479.     Var *varPtr2;
  1480.     char *name;
  1481.  
  1482.     if ((argc != 3) && (argc != 4)) {
  1483.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1484.             argv[0], " names arrayName ?pattern?\"", (char *) NULL);
  1485.         return TCL_ERROR;
  1486.     }
  1487.     if (notArray) {
  1488.         return TCL_OK;
  1489.     }
  1490.     for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
  1491.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  1492.         varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
  1493.         if (varPtr2->flags & VAR_UNDEFINED) {
  1494.         continue;
  1495.         }
  1496.         name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
  1497.         if ((argc == 4) && !Tcl_StringMatch(name, argv[3])) {
  1498.         continue;
  1499.         }
  1500.         Tcl_AppendElement(interp, name);
  1501.     }
  1502.     } else if ((c == 'n') && (strncmp(argv[1], "nextelement", length) == 0)
  1503.         && (length >= 2)) {
  1504.     ArraySearch *searchPtr;
  1505.     Tcl_HashEntry *hPtr;
  1506.  
  1507.     if (argc != 4) {
  1508.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1509.             argv[0], " nextelement arrayName searchId\"",
  1510.             (char *) NULL);
  1511.         return TCL_ERROR;
  1512.     }
  1513.     if (notArray) {
  1514.         goto error;
  1515.     }
  1516.     searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]);
  1517.     if (searchPtr == NULL) {
  1518.         return TCL_ERROR;
  1519.     }
  1520.     while (1) {
  1521.         Var *varPtr2;
  1522.  
  1523.         hPtr = searchPtr->nextEntry;
  1524.         if (hPtr == NULL) {
  1525.         hPtr = Tcl_NextHashEntry(&searchPtr->search);
  1526.         if (hPtr == NULL) {
  1527.             return TCL_OK;
  1528.         }
  1529.         } else {
  1530.         searchPtr->nextEntry = NULL;
  1531.         }
  1532.         varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
  1533.         if (!(varPtr2->flags & VAR_UNDEFINED)) {
  1534.         break;
  1535.         }
  1536.     }
  1537.     interp->result = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
  1538.     } else if ((c == 's') && (strncmp(argv[1], "set", length) == 0)
  1539.         && (length >= 2)) {
  1540.     char **valueArgv;
  1541.     int valueArgc, i, result;
  1542.  
  1543.     if (argc != 4) {
  1544.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1545.             argv[0], " set arrayName list\"", (char *) NULL);
  1546.         return TCL_ERROR;
  1547.     }
  1548.     if (Tcl_SplitList(interp, argv[3], &valueArgc, &valueArgv) != TCL_OK) {
  1549.         return TCL_ERROR;
  1550.     }
  1551.     result = TCL_OK;
  1552.     if (valueArgc & 1) {
  1553.         interp->result = "list must have an even number of elements";
  1554.         result = TCL_ERROR;
  1555.         goto setDone;
  1556.     }
  1557.     for (i = 0; i < valueArgc; i += 2) {
  1558.         if (Tcl_SetVar2(interp, argv[2], valueArgv[i], valueArgv[i+1],
  1559.             TCL_LEAVE_ERR_MSG) == NULL) {
  1560.         result = TCL_ERROR;
  1561.         break;
  1562.         }
  1563.     }
  1564.     setDone:
  1565.     ckfree((char *) valueArgv);
  1566.     return result;
  1567.     } else if ((c == 's') && (strncmp(argv[1], "size", length) == 0)
  1568.         && (length >= 2)) {
  1569.     Tcl_HashSearch search;
  1570.     Var *varPtr2;
  1571.     int size;
  1572.  
  1573.     if (argc != 3) {
  1574.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1575.             argv[0], " size arrayName\"", (char *) NULL);
  1576.         return TCL_ERROR;
  1577.     }
  1578.     size = 0;
  1579.     if (!notArray) {
  1580.         for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
  1581.             hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  1582.         varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
  1583.         if (varPtr2->flags & VAR_UNDEFINED) {
  1584.             continue;
  1585.         }
  1586.         size++;
  1587.         }
  1588.     }
  1589.     sprintf(interp->result, "%d", size);
  1590.     } else if ((c == 's') && (strncmp(argv[1], "startsearch", length) == 0)
  1591.         && (length >= 2)) {
  1592.     ArraySearch *searchPtr;
  1593.  
  1594.     if (argc != 3) {
  1595.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1596.             argv[0], " startsearch arrayName\"", (char *) NULL);
  1597.         return TCL_ERROR;
  1598.     }
  1599.     if (notArray) {
  1600.         goto error;
  1601.     }
  1602.     searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch));
  1603.     if (varPtr->searchPtr == NULL) {
  1604.         searchPtr->id = 1;
  1605.         Tcl_AppendResult(interp, "s-1-", argv[2], (char *) NULL);
  1606.     } else {
  1607.         char string[20];
  1608.  
  1609.         searchPtr->id = varPtr->searchPtr->id + 1;
  1610.         sprintf(string, "%d", searchPtr->id);
  1611.         Tcl_AppendResult(interp, "s-", string, "-", argv[2],
  1612.             (char *) NULL);
  1613.     }
  1614.     searchPtr->varPtr = varPtr;
  1615.     searchPtr->nextEntry = Tcl_FirstHashEntry(varPtr->value.tablePtr,
  1616.         &searchPtr->search);
  1617.     searchPtr->nextPtr = varPtr->searchPtr;
  1618.     varPtr->searchPtr = searchPtr;
  1619.     } else {
  1620.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  1621.         "\": should be anymore, donesearch, exists, ",
  1622.         "get, names, nextelement, ",
  1623.         "set, size, or startsearch", (char *) NULL);
  1624.     return TCL_ERROR;
  1625.     }
  1626.     return TCL_OK;
  1627.  
  1628.     error:
  1629.     Tcl_AppendResult(interp, "\"", argv[2], "\" isn't an array",
  1630.         (char *) NULL);
  1631.     return TCL_ERROR;
  1632. }
  1633.  
  1634. /*
  1635.  *----------------------------------------------------------------------
  1636.  *
  1637.  * MakeUpvar --
  1638.  *
  1639.  *    This procedure does all of the work of the "global" and "upvar"
  1640.  *    commands.
  1641.  *
  1642.  * Results:
  1643.  *    A standard Tcl completion code.  If an error occurs then an
  1644.  *    error message is left in iPtr->result.
  1645.  *
  1646.  * Side effects:
  1647.  *    The variable given by myName is linked to the variable in
  1648.  *    framePtr given by otherP1 and otherP2, so that references to
  1649.  *    myName are redirected to the other variable like a symbolic
  1650. *    link.
  1651.  *
  1652.  *----------------------------------------------------------------------
  1653.  */
  1654.  
  1655. static int
  1656. MakeUpvar(iPtr, framePtr, otherP1, otherP2, myName, flags)
  1657.     Interp *iPtr;        /* Interpreter containing variables.  Used
  1658.                  * for error messages, too. */
  1659.     CallFrame *framePtr;    /* Call frame containing "other" variable.
  1660.                  * NULL means use global context. */
  1661.     char *otherP1, *otherP2;    /* Two-part name of variable in framePtr. */
  1662.     char *myName;        /* Name of variable in local table, which
  1663.                  * will refer to otherP1/P2.  Must be a
  1664.                  * scalar. */
  1665.     int flags;            /* 0 or TCL_GLOBAL_ONLY: indicates scope of
  1666.                  * myName. */
  1667. {
  1668.     Tcl_HashEntry *hPtr;
  1669.     Var *otherPtr, *varPtr, *arrayPtr;
  1670.     CallFrame *savedFramePtr;
  1671.     int new;
  1672.  
  1673.     /*
  1674.      * In order to use LookupVar to find "other", temporarily replace
  1675.      * the current frame pointer in the interpreter.
  1676.      */
  1677.  
  1678.     savedFramePtr = iPtr->varFramePtr;
  1679.     iPtr->varFramePtr = framePtr;
  1680.     otherPtr = LookupVar((Tcl_Interp *) iPtr, otherP1, otherP2,
  1681.         TCL_LEAVE_ERR_MSG, "access", CRT_PART1|CRT_PART2, &arrayPtr);
  1682.     iPtr->varFramePtr = savedFramePtr;
  1683.     if (otherPtr == NULL) {
  1684.     return TCL_ERROR;
  1685.     }
  1686.     if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
  1687.     hPtr = Tcl_CreateHashEntry(&iPtr->globalTable, myName, &new);
  1688.     } else {
  1689.     hPtr = Tcl_CreateHashEntry(&iPtr->varFramePtr->varTable, myName, &new);
  1690.     }
  1691.     if (new) {
  1692.     varPtr = NewVar();
  1693.     Tcl_SetHashValue(hPtr, varPtr);
  1694.     varPtr->hPtr = hPtr;
  1695.     } else {
  1696.     /*
  1697.      * The variable already exists.  Make sure that this variable
  1698.      * isn't also "otherVar" (avoid circular links).  Also, if it's
  1699.      * not an upvar then it's an error.  If it is an upvar, then
  1700.      * just disconnect it from the thing it currently refers to.
  1701.      */
  1702.  
  1703.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  1704.     if (varPtr == otherPtr) {
  1705.         iPtr->result = "can't upvar from variable to itself";
  1706.         return TCL_ERROR;
  1707.     }
  1708.     if (varPtr->flags & VAR_UPVAR) {
  1709.         Var *upvarPtr;
  1710.  
  1711.         upvarPtr = varPtr->value.upvarPtr;
  1712.         if (upvarPtr == otherPtr) {
  1713.         return TCL_OK;
  1714.         }
  1715.         upvarPtr->refCount--;
  1716.         if (upvarPtr->flags & VAR_UNDEFINED) {
  1717.         CleanupVar(upvarPtr, (Var *) NULL);
  1718.         }
  1719.     } else if (!(varPtr->flags & VAR_UNDEFINED)) {
  1720.         Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName,
  1721.         "\" already exists", (char *) NULL);
  1722.         return TCL_ERROR;
  1723.     }
  1724.     }
  1725.     varPtr->flags = (varPtr->flags & ~VAR_UNDEFINED) | VAR_UPVAR;
  1726.     varPtr->value.upvarPtr = otherPtr;
  1727.     otherPtr->refCount++;
  1728.     return TCL_OK;
  1729. }
  1730.  
  1731. /*
  1732.  *----------------------------------------------------------------------
  1733.  *
  1734.  * Tcl_UpVar --
  1735.  *
  1736.  *    Delete a variable, so that it may not be accessed anymore.
  1737.  *
  1738.  * Results:
  1739.  *    Returns TCL_OK if the variable was successfully deleted, TCL_ERROR
  1740.  *    if the variable can't be unset.  In the event of an error,
  1741.  *    if the TCL_LEAVE_ERR_MSG flag is set then an error message
  1742.  *    is left in interp->result.
  1743.  *
  1744.  * Side effects:
  1745.  *    If varName is defined as a local or global variable in interp,
  1746.  *    it is deleted.
  1747.  *
  1748.  *----------------------------------------------------------------------
  1749.  */
  1750.  
  1751. int
  1752. Tcl_UpVar(interp, frameName, varName, localName, flags)
  1753.     Tcl_Interp *interp;        /* Command interpreter in which varName is
  1754.                  * to be looked up. */
  1755.     char *frameName;        /* Name of the frame containing the source
  1756.                  * variable, such as "1" or "#0". */
  1757.     char *varName;        /* Name of a variable in interp.  May be
  1758.                  * either a scalar name or an element
  1759.                  * in an array. */
  1760.     char *localName;        /* Destination variable name. */
  1761.     int flags;            /* Either 0 or TCL_GLOBAL_ONLY;  indicates
  1762.                  * whether localName is local or global. */
  1763. {
  1764.     int result;
  1765.     CallFrame *framePtr;
  1766.     register char *p;
  1767.  
  1768.     result = TclGetFrame(interp, frameName, &framePtr);
  1769.     if (result == -1) {
  1770.     return TCL_ERROR;
  1771.     }
  1772.  
  1773.     /*
  1774.      * Figure out whether this is an array reference, then call
  1775.      * Tcl_UpVar2 to do all the real work.
  1776.      */
  1777.  
  1778.     for (p = varName; *p != '\0'; p++) {
  1779.     if (*p == '(') {
  1780.         char *openParen = p;
  1781.  
  1782.         do {
  1783.         p++;
  1784.         } while (*p != '\0');
  1785.         p--;
  1786.         if (*p != ')') {
  1787.         goto scalar;
  1788.         }
  1789.         *openParen = '\0';
  1790.         *p = '\0';
  1791.         result = MakeUpvar((Interp *) interp, framePtr, varName,
  1792.             openParen+1, localName, flags);
  1793.         *openParen = '(';
  1794.         *p = ')';
  1795.         return result;
  1796.     }
  1797.     }
  1798.  
  1799.     scalar:
  1800.     return MakeUpvar((Interp *) interp, framePtr, varName, (char *) NULL,
  1801.         localName, flags);
  1802. }
  1803.  
  1804. /*
  1805.  *----------------------------------------------------------------------
  1806.  *
  1807.  * Tcl_UpVar2 --
  1808.  *
  1809.  *    This procedure links one variable to another, just like
  1810.  *    the "upvar" command.
  1811.  *
  1812.  * Results:
  1813.  *    A standard Tcl completion code.  If an error occurs then
  1814.  *    an error message is left in interp->result.
  1815.  *
  1816.  * Side effects:
  1817.  *    The variable in frameName whose name is given by part1 and
  1818.  *    part2 becomes accessible under the name newName, so that
  1819.  *    references to newName are redirected to the other variable
  1820.  *    like a symbolic link.
  1821.  *
  1822.  *----------------------------------------------------------------------
  1823.  */
  1824.  
  1825. int
  1826. Tcl_UpVar2(interp, frameName, part1, part2, localName, flags)
  1827.     Tcl_Interp *interp;        /* Interpreter containing variables.  Used
  1828.                  * for error messages too. */
  1829.     char *frameName;        /* Name of the frame containing the source
  1830.                  * variable, such as "1" or "#0". */
  1831.     char *part1, *part2;    /* Two parts of source variable name. */
  1832.     char *localName;        /* Destination variable name. */
  1833.     int flags;            /* TCL_GLOBAL_ONLY or 0. */
  1834. {
  1835.     int result;
  1836.     CallFrame *framePtr;
  1837.  
  1838.     result = TclGetFrame(interp, frameName, &framePtr);
  1839.     if (result == -1) {
  1840.     return TCL_ERROR;
  1841.     }
  1842.     return MakeUpvar((Interp *) interp, framePtr, part1, part2,
  1843.         localName, flags);
  1844. }
  1845.  
  1846. /*
  1847.  *----------------------------------------------------------------------
  1848.  *
  1849.  * Tcl_GlobalCmd --
  1850.  *
  1851.  *    This procedure is invoked to process the "global" Tcl command.
  1852.  *    See the user documentation for details on what it does.
  1853.  *
  1854.  * Results:
  1855.  *    A standard Tcl result value.
  1856.  *
  1857.  * Side effects:
  1858.  *    See the user documentation.
  1859.  *
  1860.  *----------------------------------------------------------------------
  1861.  */
  1862.  
  1863.     /* ARGSUSED */
  1864. int
  1865. Tcl_GlobalCmd(dummy, interp, argc, argv)
  1866.     ClientData dummy;            /* Not used. */
  1867.     Tcl_Interp *interp;            /* Current interpreter. */
  1868.     int argc;                /* Number of arguments. */
  1869.     char **argv;            /* Argument strings. */
  1870. {
  1871.     register Interp *iPtr = (Interp *) interp;
  1872.  
  1873.     if (argc < 2) {
  1874.     Tcl_AppendResult((Tcl_Interp *) iPtr, "wrong # args: should be \"",
  1875.         argv[0], " varName ?varName ...?\"", (char *) NULL);
  1876.     return TCL_ERROR;
  1877.     }
  1878.     if (iPtr->varFramePtr == NULL) {
  1879.     return TCL_OK;
  1880.     }
  1881.  
  1882.     for (argc--, argv++; argc > 0; argc--, argv++) {
  1883.     if (MakeUpvar(iPtr, (CallFrame *) NULL, *argv, (char *) NULL, *argv, 0)
  1884.         != TCL_OK) {
  1885.         return TCL_ERROR;
  1886.     }
  1887.     }
  1888.     return TCL_OK;
  1889. }
  1890.  
  1891. /*
  1892.  *----------------------------------------------------------------------
  1893.  *
  1894.  * Tcl_UpvarCmd --
  1895.  *
  1896.  *    This procedure is invoked to process the "upvar" Tcl command.
  1897.  *    See the user documentation for details on what it does.
  1898.  *
  1899.  * Results:
  1900.  *    A standard Tcl result value.
  1901.  *
  1902.  * Side effects:
  1903.  *    See the user documentation.
  1904.  *
  1905.  *----------------------------------------------------------------------
  1906.  */
  1907.  
  1908.     /* ARGSUSED */
  1909. int
  1910. Tcl_UpvarCmd(dummy, interp, argc, argv)
  1911.     ClientData dummy;            /* Not used. */
  1912.     Tcl_Interp *interp;            /* Current interpreter. */
  1913.     int argc;                /* Number of arguments. */
  1914.     char **argv;            /* Argument strings. */
  1915. {
  1916.     register Interp *iPtr = (Interp *) interp;
  1917.     int result;
  1918.     CallFrame *framePtr;
  1919.     register char *p;
  1920.  
  1921.     if (argc < 3) {
  1922.     upvarSyntax:
  1923.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1924.         " ?level? otherVar localVar ?otherVar localVar ...?\"",
  1925.         (char *) NULL);
  1926.     return TCL_ERROR;
  1927.     }
  1928.  
  1929.     /*
  1930.      * Find the hash table containing the variable being referenced.
  1931.      */
  1932.  
  1933.     result = TclGetFrame(interp, argv[1], &framePtr);
  1934.     if (result == -1) {
  1935.     return TCL_ERROR;
  1936.     }
  1937.     argc -= result+1;
  1938.     if ((argc & 1) != 0) {
  1939.     goto upvarSyntax;
  1940.     }
  1941.     argv += result+1;
  1942.  
  1943.     /*
  1944.      * Iterate over all the pairs of (other variable, local variable)
  1945.      * names.  For each pair, divide the other variable name into two
  1946.      * parts, then call MakeUpvar to do all the work of creating linking
  1947.      * it to the local variable.
  1948.      */
  1949.  
  1950.     for ( ; argc > 0; argc -= 2, argv += 2) {
  1951.     for (p = argv[0]; *p != 0; p++) {
  1952.         if (*p == '(') {
  1953.         char *openParen = p;
  1954.  
  1955.         do {
  1956.             p++;
  1957.         } while (*p != '\0');
  1958.         p--;
  1959.         if (*p != ')') {
  1960.             goto scalar;
  1961.         }
  1962.         *openParen = '\0';
  1963.         *p = '\0';
  1964.         result = MakeUpvar(iPtr, framePtr, argv[0], openParen+1,
  1965.             argv[1], 0);
  1966.         *openParen = '(';
  1967.         *p = ')';
  1968.         goto checkResult;
  1969.         }
  1970.     }
  1971.     scalar:
  1972.     result = MakeUpvar(iPtr, framePtr, argv[0], (char *) NULL, argv[1], 0);
  1973.  
  1974.     checkResult:
  1975.     if (result != TCL_OK) {
  1976.         return TCL_ERROR;
  1977.     }
  1978.     }
  1979.     return TCL_OK;
  1980. }
  1981.  
  1982. /*
  1983.  *----------------------------------------------------------------------
  1984.  *
  1985.  * CallTraces --
  1986.  *
  1987.  *    This procedure is invoked to find and invoke relevant
  1988.  *    trace procedures associated with a particular operation on
  1989.  *    a variable.  This procedure invokes traces both on the
  1990.  *    variable and on its containing array (where relevant).
  1991.  *
  1992.  * Results:
  1993.  *    The return value is NULL if no trace procedures were invoked, or
  1994.  *    if all the invoked trace procedures returned successfully.
  1995.  *    The return value is non-zero if a trace procedure returned an
  1996.  *    error (in this case no more trace procedures were invoked after
  1997.  *    the error was returned).  In this case the return value is a
  1998.  *    pointer to a static string describing the error.
  1999.  *
  2000.  * Side effects:
  2001.  *    Almost anything can happen, depending on trace;  this procedure
  2002.  *    itself doesn't have any side effects.
  2003.  *
  2004.  *----------------------------------------------------------------------
  2005.  */
  2006.  
  2007. static char *
  2008. CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags)
  2009.     Interp *iPtr;            /* Interpreter containing variable. */
  2010.     register Var *arrayPtr;        /* Pointer to array variable that
  2011.                      * contains the variable, or NULL if
  2012.                      * the variable isn't an element of an
  2013.                      * array. */
  2014.     Var *varPtr;            /* Variable whose traces are to be
  2015.                      * invoked. */
  2016.     char *part1, *part2;        /* Variable's two-part name. */
  2017.     int flags;                /* Flags to pass to trace procedures:
  2018.                      * indicates what's happening to
  2019.                      * variable, plus other stuff like
  2020.                      * TCL_GLOBAL_ONLY and
  2021.                      * TCL_INTERP_DESTROYED. */
  2022. {
  2023.     register VarTrace *tracePtr;
  2024.     ActiveVarTrace active;
  2025.     char *result, *openParen, *p;
  2026.     Tcl_DString nameCopy;
  2027.     int copiedName;
  2028.  
  2029.     /*
  2030.      * If there are already similar trace procedures active for the
  2031.      * variable, don't call them again.
  2032.      */
  2033.  
  2034.     if (varPtr->flags & VAR_TRACE_ACTIVE) {
  2035.     return NULL;
  2036.     }
  2037.     varPtr->flags |= VAR_TRACE_ACTIVE;
  2038.     varPtr->refCount++;
  2039.  
  2040.     /*
  2041.      * If the variable name hasn't been parsed into array name and
  2042.      * element, do it here.  If there really is an array element,
  2043.      * make a copy of the original name so that NULLs can be
  2044.      * inserted into it to separate the names (can't modify the name
  2045.      * string in place, because the string might get used by the
  2046.      * callbacks we invoke).
  2047.      */
  2048.  
  2049.     copiedName = 0;
  2050.     if (flags & PART1_NOT_PARSED) {
  2051.     for (p = part1; ; p++) {
  2052.         if (*p == 0) {
  2053.         break;
  2054.         }
  2055.         if (*p == '(') {
  2056.         openParen = p;
  2057.         do {
  2058.             p++;
  2059.         } while (*p != '\0');
  2060.         p--;
  2061.         if (*p == ')') {
  2062.             Tcl_DStringInit(&nameCopy);
  2063.             Tcl_DStringAppend(&nameCopy, part1, (p-part1));
  2064.             part2 = Tcl_DStringValue(&nameCopy)
  2065.                 + (openParen + 1 - part1);
  2066.             part2[-1] = 0;
  2067.             part1 = Tcl_DStringValue(&nameCopy);
  2068.             copiedName = 1;
  2069.         }
  2070.         break;
  2071.         }
  2072.     }
  2073.     }
  2074.  
  2075.  
  2076.     /*
  2077.      * Invoke traces on the array containing the variable, if relevant.
  2078.      */
  2079.  
  2080.     result = NULL;
  2081.     active.nextPtr = iPtr->activeTracePtr;
  2082.     iPtr->activeTracePtr = &active;
  2083.     if (arrayPtr != NULL) {
  2084.     arrayPtr->refCount++;
  2085.     active.varPtr = arrayPtr;
  2086.     for (tracePtr = arrayPtr->tracePtr;  tracePtr != NULL;
  2087.         tracePtr = active.nextTracePtr) {
  2088.         active.nextTracePtr = tracePtr->nextPtr;
  2089.         if (!(tracePtr->flags & flags)) {
  2090.         continue;
  2091.         }
  2092.         result = (*tracePtr->traceProc)(tracePtr->clientData,
  2093.             (Tcl_Interp *) iPtr, part1, part2, flags);
  2094.         if (result != NULL) {
  2095.         if (flags & TCL_TRACE_UNSETS) {
  2096.             result = NULL;
  2097.         } else {
  2098.             goto done;
  2099.         }
  2100.         }
  2101.     }
  2102.     }
  2103.  
  2104.     /*
  2105.      * Invoke traces on the variable itself.
  2106.      */
  2107.  
  2108.     if (flags & TCL_TRACE_UNSETS) {
  2109.     flags |= TCL_TRACE_DESTROYED;
  2110.     }
  2111.     active.varPtr = varPtr;
  2112.     for (tracePtr = varPtr->tracePtr; tracePtr != NULL;
  2113.         tracePtr = active.nextTracePtr) {
  2114.     active.nextTracePtr = tracePtr->nextPtr;
  2115.     if (!(tracePtr->flags & flags)) {
  2116.         continue;
  2117.     }
  2118.     result = (*tracePtr->traceProc)(tracePtr->clientData,
  2119.         (Tcl_Interp *) iPtr, part1, part2, flags);
  2120.     if (result != NULL) {
  2121.         if (flags & TCL_TRACE_UNSETS) {
  2122.         result = NULL;
  2123.         } else {
  2124.         goto done;
  2125.         }
  2126.     }
  2127.     }
  2128.  
  2129.     /*
  2130.      * Restore the variable's flags, remove the record of our active
  2131.      * traces, and then return.
  2132.      */
  2133.  
  2134.     done:
  2135.     if (arrayPtr != NULL) {
  2136.     arrayPtr->refCount--;
  2137.     }
  2138.     if (copiedName) {
  2139.     Tcl_DStringFree(&nameCopy);
  2140.     }
  2141.     varPtr->flags &= ~VAR_TRACE_ACTIVE;
  2142.     varPtr->refCount--;
  2143.     iPtr->activeTracePtr = active.nextPtr;
  2144.     return result;
  2145. }
  2146.  
  2147. /*
  2148.  *----------------------------------------------------------------------
  2149.  *
  2150.  * NewVar --
  2151.  *
  2152.  *    Create a new variable with a given amount of storage
  2153.  *    space.
  2154.  *
  2155.  * Results:
  2156.  *    The return value is a pointer to the new variable structure.
  2157.  *    The variable will not be part of any hash table yet.  Its
  2158.  *    initial value is empty.
  2159.  *
  2160.  * Side effects:
  2161.  *    Storage gets allocated.
  2162.  *
  2163.  *----------------------------------------------------------------------
  2164.  */
  2165.  
  2166. static Var *
  2167. NewVar()
  2168. {
  2169.     register Var *varPtr;
  2170.  
  2171.     varPtr = (Var *) ckalloc(sizeof(Var));
  2172.     varPtr->valueLength = 0;
  2173.     varPtr->valueSpace = 0;
  2174.     varPtr->value.string = NULL;
  2175.     varPtr->hPtr = NULL;
  2176.     varPtr->refCount = 0;
  2177.     varPtr->tracePtr = NULL;
  2178.     varPtr->searchPtr = NULL;
  2179.     varPtr->flags = VAR_UNDEFINED;
  2180.     return varPtr;
  2181. }
  2182.  
  2183. /*
  2184.  *----------------------------------------------------------------------
  2185.  *
  2186.  * ParseSearchId --
  2187.  *
  2188.  *    This procedure translates from a string to a pointer to an
  2189.  *    active array search (if there is one that matches the string).
  2190.  *
  2191.  * Results:
  2192.  *    The return value is a pointer to the array search indicated
  2193.  *    by string, or NULL if there isn't one.  If NULL is returned,
  2194.  *    interp->result contains an error message.
  2195.  *
  2196.  * Side effects:
  2197.  *    None.
  2198.  *
  2199.  *----------------------------------------------------------------------
  2200.  */
  2201.  
  2202. static ArraySearch *
  2203. ParseSearchId(interp, varPtr, varName, string)
  2204.     Tcl_Interp *interp;        /* Interpreter containing variable. */
  2205.     Var *varPtr;        /* Array variable search is for. */
  2206.     char *varName;        /* Name of array variable that search is
  2207.                  * supposed to be for. */
  2208.     char *string;        /* String containing id of search.  Must have
  2209.                  * form "search-num-var" where "num" is a
  2210.                  * decimal number and "var" is a variable
  2211.                  * name. */
  2212. {
  2213.     char *end;
  2214.     int id;
  2215.     ArraySearch *searchPtr;
  2216.  
  2217.     /*
  2218.      * Parse the id into the three parts separated by dashes.
  2219.      */
  2220.  
  2221.     if ((string[0] != 's') || (string[1] != '-')) {
  2222.     syntax:
  2223.     Tcl_AppendResult(interp, "illegal search identifier \"", string,
  2224.         "\"", (char *) NULL);
  2225.     return NULL;
  2226.     }
  2227.     id = strtoul(string+2, &end, 10);
  2228.     if ((end == (string+2)) || (*end != '-')) {
  2229.     goto syntax;
  2230.     }
  2231.     if (strcmp(end+1, varName) != 0) {
  2232.     Tcl_AppendResult(interp, "search identifier \"", string,
  2233.         "\" isn't for variable \"", varName, "\"", (char *) NULL);
  2234.     return NULL;
  2235.     }
  2236.  
  2237.     /*
  2238.      * Search through the list of active searches on the interpreter
  2239.      * to see if the desired one exists.
  2240.      */
  2241.  
  2242.     for (searchPtr = varPtr->searchPtr; searchPtr != NULL;
  2243.         searchPtr = searchPtr->nextPtr) {
  2244.     if (searchPtr->id == id) {
  2245.         return searchPtr;
  2246.     }
  2247.     }
  2248.     Tcl_AppendResult(interp, "couldn't find search \"", string, "\"",
  2249.         (char *) NULL);
  2250.     return NULL;
  2251. }
  2252.  
  2253. /*
  2254.  *----------------------------------------------------------------------
  2255.  *
  2256.  * DeleteSearches --
  2257.  *
  2258.  *    This procedure is called to free up all of the searches
  2259.  *    associated with an array variable.
  2260.  *
  2261.  * Results:
  2262.  *    None.
  2263.  *
  2264.  * Side effects:
  2265.  *    Memory is released to the storage allocator.
  2266.  *
  2267.  *----------------------------------------------------------------------
  2268.  */
  2269.  
  2270. static void
  2271. DeleteSearches(arrayVarPtr)
  2272.     register Var *arrayVarPtr;        /* Variable whose searches are
  2273.                      * to be deleted. */
  2274. {
  2275.     ArraySearch *searchPtr;
  2276.  
  2277.     while (arrayVarPtr->searchPtr != NULL) {
  2278.     searchPtr = arrayVarPtr->searchPtr;
  2279.     arrayVarPtr->searchPtr = searchPtr->nextPtr;
  2280.     ckfree((char *) searchPtr);
  2281.     }
  2282. }
  2283.  
  2284. /*
  2285.  *----------------------------------------------------------------------
  2286.  *
  2287.  * TclDeleteVars --
  2288.  *
  2289.  *    This procedure is called to recycle all the storage space
  2290.  *    associated with a table of variables.  For this procedure
  2291.  *    to work correctly, it must not be possible for any of the
  2292.  *    variable in the table to be accessed from Tcl commands
  2293.  *    (e.g. from trace procedures).
  2294.  *
  2295.  * Results:
  2296.  *    None.
  2297.  *
  2298.  * Side effects:
  2299.  *    Variables are deleted and trace procedures are invoked, if
  2300.  *    any are declared.
  2301.  *
  2302.  *----------------------------------------------------------------------
  2303.  */
  2304.  
  2305. void
  2306. TclDeleteVars(iPtr, tablePtr)
  2307.     Interp *iPtr;        /* Interpreter to which variables belong. */
  2308.     Tcl_HashTable *tablePtr;    /* Hash table containing variables to
  2309.                  * delete. */
  2310. {
  2311.     Tcl_HashSearch search;
  2312.     Tcl_HashEntry *hPtr;
  2313.     register Var *varPtr;
  2314.     Var *upvarPtr;
  2315.     int flags;
  2316.     ActiveVarTrace *activePtr;
  2317.  
  2318.     flags = TCL_TRACE_UNSETS;
  2319.     if (tablePtr == &iPtr->globalTable) {
  2320.     flags |= TCL_INTERP_DESTROYED | TCL_GLOBAL_ONLY;
  2321.     }
  2322.     for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
  2323.         hPtr = Tcl_NextHashEntry(&search)) {
  2324.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  2325.  
  2326.     /*
  2327.      * For global/upvar variables referenced in procedures, decrement
  2328.      * the reference count on the variable referred to, and free up
  2329.      * the referenced variable if it's no longer needed.
  2330.      */
  2331.  
  2332.     if (varPtr->flags & VAR_UPVAR) {
  2333.         upvarPtr = varPtr->value.upvarPtr;
  2334.         upvarPtr->refCount--;
  2335.         if (upvarPtr->flags & VAR_UNDEFINED) {
  2336.         CleanupVar(upvarPtr, (Var *) NULL);
  2337.         }
  2338.     }
  2339.  
  2340.     /*
  2341.      * Invoke traces on the variable that is being deleted, then
  2342.      * free up the variable's space (no need to free the hash entry
  2343.      * here, unless we're dealing with a global variable:  the
  2344.      * hash entries will be deleted automatically when the whole
  2345.      * table is deleted).
  2346.      */
  2347.  
  2348.     if (varPtr->tracePtr != NULL) {
  2349.         (void) CallTraces(iPtr, (Var *) NULL, varPtr,
  2350.             Tcl_GetHashKey(tablePtr, hPtr), (char *) NULL, flags);
  2351.         while (varPtr->tracePtr != NULL) {
  2352.         VarTrace *tracePtr = varPtr->tracePtr;
  2353.         varPtr->tracePtr = tracePtr->nextPtr;
  2354.         ckfree((char *) tracePtr);
  2355.         }
  2356.         for (activePtr = iPtr->activeTracePtr; activePtr != NULL;
  2357.             activePtr = activePtr->nextPtr) {
  2358.         if (activePtr->varPtr == varPtr) {
  2359.             activePtr->nextTracePtr = NULL;
  2360.         }
  2361.         }
  2362.     }
  2363.     if (varPtr->flags & VAR_ARRAY) {
  2364.         DeleteArray(iPtr, Tcl_GetHashKey(tablePtr, hPtr), varPtr, flags);
  2365.     }
  2366.     if (varPtr->valueSpace > 0) {
  2367.         /*
  2368.          * SPECIAL TRICK:  it's possible that the interpreter's result
  2369.          * currently points to this variable (for example, a "set" or
  2370.          * "lappend" command was the last command in a procedure that's
  2371.          * being returned from).  If this is the case, then just pass
  2372.          * ownership of the value string to the Tcl interpreter.
  2373.          */
  2374.  
  2375.         if (iPtr->result == varPtr->value.string) {
  2376.         iPtr->freeProc = (Tcl_FreeProc *) free;
  2377.         } else {
  2378.         ckfree(varPtr->value.string);
  2379.         }
  2380.         varPtr->valueSpace = 0;
  2381.     }
  2382.     varPtr->hPtr = NULL;
  2383.     varPtr->tracePtr = NULL;
  2384.     varPtr->flags = VAR_UNDEFINED;
  2385.     if (varPtr->refCount == 0) {
  2386.         ckfree((char *) varPtr);
  2387.     }
  2388.     }
  2389.     Tcl_DeleteHashTable(tablePtr);
  2390. }
  2391.  
  2392. /*
  2393.  *----------------------------------------------------------------------
  2394.  *
  2395.  * DeleteArray --
  2396.  *
  2397.  *    This procedure is called to free up everything in an array
  2398.  *    variable.  It's the caller's responsibility to make sure
  2399.  *    that the array is no longer accessible before this procedure
  2400.  *    is called.
  2401.  *
  2402.  * Results:
  2403.  *    None.
  2404.  *
  2405.  * Side effects:
  2406.  *    All storage associated with varPtr's array elements is deleted
  2407.  *    (including the hash table).  Delete trace procedures for
  2408.  *    array elements are invoked.
  2409.  *
  2410.  *----------------------------------------------------------------------
  2411.  */
  2412.  
  2413. static void
  2414. DeleteArray(iPtr, arrayName, varPtr, flags)
  2415.     Interp *iPtr;            /* Interpreter containing array. */
  2416.     char *arrayName;            /* Name of array (used for trace
  2417.                      * callbacks). */
  2418.     Var *varPtr;            /* Pointer to variable structure. */
  2419.     int flags;                /* Flags to pass to CallTraces:
  2420.                      * TCL_TRACE_UNSETS and sometimes
  2421.                      * TCL_INTERP_DESTROYED and/or
  2422.                      * TCL_GLOBAL_ONLY. */
  2423. {
  2424.     Tcl_HashSearch search;
  2425.     register Tcl_HashEntry *hPtr;
  2426.     register Var *elPtr;
  2427.     ActiveVarTrace *activePtr;
  2428.  
  2429.     DeleteSearches(varPtr);
  2430.     for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
  2431.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  2432.     elPtr = (Var *) Tcl_GetHashValue(hPtr);
  2433.     if (elPtr->valueSpace != 0) {
  2434.         /*
  2435.          * SPECIAL TRICK:  it's possible that the interpreter's result
  2436.          * currently points to this element (for example, a "set" or
  2437.          * "lappend" command was the last command in a procedure that's
  2438.          * being returned from).  If this is the case, then just pass
  2439.          * ownership of the value string to the Tcl interpreter.
  2440.          */
  2441.  
  2442.         if (iPtr->result == elPtr->value.string) {
  2443.         iPtr->freeProc = (Tcl_FreeProc *) free;
  2444.         } else {
  2445.         ckfree(elPtr->value.string);
  2446.         }
  2447.         elPtr->valueSpace = 0;
  2448.     }
  2449.     elPtr->hPtr = NULL;
  2450.     if (elPtr->tracePtr != NULL) {
  2451.         elPtr->flags &= ~VAR_TRACE_ACTIVE;
  2452.         (void) CallTraces(iPtr, (Var *) NULL, elPtr, arrayName,
  2453.             Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), flags);
  2454.         while (elPtr->tracePtr != NULL) {
  2455.         VarTrace *tracePtr = elPtr->tracePtr;
  2456.         elPtr->tracePtr = tracePtr->nextPtr;
  2457.         ckfree((char *) tracePtr);
  2458.         }
  2459.         for (activePtr = iPtr->activeTracePtr; activePtr != NULL;
  2460.             activePtr = activePtr->nextPtr) {
  2461.         if (activePtr->varPtr == elPtr) {
  2462.             activePtr->nextTracePtr = NULL;
  2463.         }
  2464.         }
  2465.     }
  2466.     elPtr->flags = VAR_UNDEFINED;
  2467.     if (elPtr->refCount == 0) {
  2468.         ckfree((char *) elPtr);
  2469.     }
  2470.     }
  2471.     Tcl_DeleteHashTable(varPtr->value.tablePtr);
  2472.     ckfree((char *) varPtr->value.tablePtr);
  2473. }
  2474.  
  2475. /*
  2476.  *----------------------------------------------------------------------
  2477.  *
  2478.  * CleanupVar --
  2479.  *
  2480.  *    This procedure is called when it looks like it may be OK
  2481.  *    to free up the variable's record and hash table entry, and
  2482.  *    those of its containing parent.  It's called, for example,
  2483.  *    when a trace on a variable deletes the variable.
  2484.  *
  2485.  * Results:
  2486.  *    None.
  2487.  *
  2488.  * Side effects:
  2489.  *    If the variable (or its containing array) really is dead then
  2490.  *    its record, and possibly its hash table entry, gets freed up.
  2491.  *
  2492.  *----------------------------------------------------------------------
  2493.  */
  2494.  
  2495. static void
  2496. CleanupVar(varPtr, arrayPtr)
  2497.     Var *varPtr;        /* Pointer to variable that may be a
  2498.                  * candidate for being expunged. */
  2499.     Var *arrayPtr;        /* Array that contains the variable, or
  2500.                  * NULL if this variable isn't an array
  2501.                  * element. */
  2502. {
  2503.     if ((varPtr->flags & VAR_UNDEFINED) && (varPtr->refCount == 0)
  2504.         && (varPtr->tracePtr == NULL)) {
  2505.     if (varPtr->hPtr != NULL) {
  2506.         Tcl_DeleteHashEntry(varPtr->hPtr);
  2507.     }
  2508.     ckfree((char *) varPtr);
  2509.     }
  2510.     if (arrayPtr != NULL) {
  2511.     if ((arrayPtr->flags & VAR_UNDEFINED) && (arrayPtr->refCount == 0)
  2512.         && (arrayPtr->tracePtr == NULL)) {
  2513.         if (arrayPtr->hPtr != NULL) {
  2514.         Tcl_DeleteHashEntry(arrayPtr->hPtr);
  2515.         }
  2516.         ckfree((char *) arrayPtr);
  2517.     }
  2518.     }
  2519.     return;
  2520. }
  2521.  
  2522. /*
  2523.  *----------------------------------------------------------------------
  2524.  *
  2525.  * VarErrMsg --
  2526.  *
  2527.  *    Generate a reasonable error message describing why a variable
  2528.  *    operation failed.
  2529.  *
  2530.  * Results:
  2531.  *    None.
  2532.  *
  2533.  * Side effects:
  2534.  *    Interp->result is reset to hold a message identifying the
  2535.  *    variable given by part1 and part2 and describing why the
  2536.  *    variable operation failed.
  2537.  *
  2538.  *----------------------------------------------------------------------
  2539.  */
  2540.  
  2541. static void
  2542. VarErrMsg(interp, part1, part2, operation, reason)
  2543.     Tcl_Interp *interp;        /* Interpreter in which to record message. */
  2544.     char *part1, *part2;    /* Variable's two-part name. */
  2545.     char *operation;        /* String describing operation that failed,
  2546.                  * e.g. "read", "set", or "unset". */
  2547.     char *reason;        /* String describing why operation failed. */
  2548. {
  2549.     Tcl_ResetResult(interp);
  2550.     Tcl_AppendResult(interp, "can't ", operation, " \"", part1, (char *) NULL);
  2551.     if (part2 != NULL) {
  2552.     Tcl_AppendResult(interp, "(", part2, ")", (char *) NULL);
  2553.     }
  2554.     Tcl_AppendResult(interp, "\": ", reason, (char *) NULL);
  2555. }
  2556.