home *** CD-ROM | disk | FTP | other *** search
/ Source Code 1992 March / Source_Code_CD-ROM_Walnut_Creek_March_1992.iso / usenet / altsrcs / 0 / 0990 / tclBasic.c
Encoding:
C/C++ Source or Header  |  1990-12-28  |  31.7 KB  |  1,309 lines
  1. /* 
  2.  * tclBasic.c --
  3.  *
  4.  *    Contains the basic facilities for TCL command interpretation,
  5.  *    including interpreter creation and deletion, command creation
  6.  *    and deletion, and command parsing and execution.
  7.  *
  8.  * Copyright 1987 Regents of the University of California
  9.  * Permission to use, copy, modify, and distribute this
  10.  * software and its documentation for any purpose and without
  11.  * fee is hereby granted, provided that the above copyright
  12.  * notice appear in all copies.  The University of California
  13.  * makes no representations about the suitability of this
  14.  * software for any purpose.  It is provided "as is" without
  15.  * express or implied warranty.
  16.  */
  17.  
  18. #ifndef lint
  19. static char rcsid[] = "$Header: /sprite/src/lib/tcl/RCS/tclBasic.c,v 1.62 90/01/27 14:43:53 ouster Exp $ SPRITE (Berkeley)";
  20. #endif /* not lint */
  21.  
  22. #include <stdio.h>
  23. #include <ctype.h>
  24. #include <stdlib.h>
  25. #include <string.h>
  26. #include "tclInt.h"
  27.  
  28. /*
  29.  * Built-in commands, and the procedures associated with them:
  30.  */
  31.  
  32. static char *builtInCmds[] = {
  33.     "break",
  34.     "case",
  35.     "catch",
  36.     "concat",
  37.     "continue",
  38.     "error",
  39.     "eval",
  40.     "exec",
  41.     "expr",
  42.     "file",
  43.     "for",
  44.     "foreach",
  45.     "format",
  46. #ifdef GNU
  47.     "glob",
  48. #endif
  49.     "global",
  50.     "if",
  51.     "strchr",
  52.     "info",
  53.     "length",
  54.     "list",
  55.     "print",
  56.     "proc",
  57.     "range",
  58.     "rename",
  59.     "return",
  60.     "scan",
  61.     "set",
  62.     "source",
  63.     "string",
  64.     "time",
  65.     "uplevel",
  66.     NULL
  67. };
  68.  
  69. static int (*(builtInProcs[]))() = {
  70.     Tcl_BreakCmd,
  71.     Tcl_CaseCmd,
  72.     Tcl_CatchCmd,
  73.     Tcl_ConcatCmd,
  74.     Tcl_ContinueCmd,
  75.     Tcl_ErrorCmd,
  76.     Tcl_EvalCmd,
  77.     Tcl_ExecCmd,
  78.     Tcl_ExprCmd,
  79.     Tcl_FileCmd,
  80.     Tcl_ForCmd,
  81.     Tcl_ForeachCmd,
  82.     Tcl_FormatCmd,
  83. #ifdef GNU
  84.     Tcl_GlobCmd,
  85. #endif
  86.     Tcl_GlobalCmd,
  87.     Tcl_IfCmd,
  88.     Tcl_IndexCmd,
  89.     Tcl_InfoCmd,
  90.     Tcl_LengthCmd,
  91.     Tcl_ListCmd,
  92.     Tcl_PrintCmd,
  93.     Tcl_ProcCmd,
  94.     Tcl_RangeCmd,
  95.     Tcl_RenameCmd,
  96.     Tcl_ReturnCmd,
  97.     Tcl_ScanCmd,
  98.     Tcl_SetCmd,
  99.     Tcl_SourceCmd,
  100.     Tcl_StringCmd,
  101.     Tcl_TimeCmd,
  102.     Tcl_UplevelCmd,
  103.     NULL
  104. };
  105.  
  106. /*
  107.  *----------------------------------------------------------------------
  108.  *
  109.  * Tcl_CreateInterp --
  110.  *
  111.  *    Create a new TCL command interpreter.
  112.  *
  113.  * Results:
  114.  *    The return value is a token for the interpreter, which may be
  115.  *    used in calls to procedures like Tcl_CreateCmd, Tcl_Eval, or
  116.  *    Tcl_DeleteInterp.
  117.  *
  118.  * Side effects:
  119.  *    The command interpreter is initialized with an empty variable
  120.  *    table and the built-in commands.
  121.  *
  122.  *----------------------------------------------------------------------
  123.  */
  124.  
  125. Tcl_Interp *
  126. Tcl_CreateInterp()
  127. {
  128.     register Interp *iPtr;
  129.     register char **namePtr;
  130.     register int (**procPtr)();
  131.     register Command *cmdPtr;
  132.  
  133.     iPtr = (Interp *) ckalloc(sizeof(Interp));
  134.     iPtr->result = iPtr->resultSpace;
  135.     iPtr->dynamic = 0;
  136.     iPtr->errorLine = 0;
  137.     iPtr->commandPtr = NULL;
  138.     iPtr->globalPtr = NULL;
  139.     iPtr->numLevels = 0;
  140.     iPtr->framePtr = NULL;
  141.     iPtr->varFramePtr = NULL;
  142.     iPtr->cmdCount = 0;
  143.     iPtr->errInProgress = 0;
  144.     iPtr->noEval = 0;
  145.     iPtr->flags = 0;
  146.     iPtr->tracePtr = NULL;
  147.     iPtr->callbackPtr = NULL;
  148.     iPtr->resultSpace[0] = 0;
  149.  
  150.     /*
  151.      * Create the built-in commands.  Do it here, rather than calling
  152.      * Tcl_CreateCommand, because it's faster (there's no need to
  153.      * check for a pre-existing command by the same name).
  154.      */
  155.  
  156.     for (namePtr = builtInCmds, procPtr = builtInProcs;
  157.         *namePtr != NULL; namePtr++, procPtr++) {
  158.     cmdPtr = (Command *) ckalloc(CMD_SIZE(strlen(*namePtr)));
  159.     cmdPtr->proc = *procPtr;
  160.     cmdPtr->clientData = (ClientData) NULL;
  161.     cmdPtr->deleteProc = NULL;
  162.     cmdPtr->nextPtr = iPtr->commandPtr;
  163.     iPtr->commandPtr = cmdPtr;
  164.     strcpy(cmdPtr->name, *namePtr);
  165.     }
  166.  
  167.     return (Tcl_Interp *) iPtr;
  168. }
  169.  
  170. /*
  171.  *--------------------------------------------------------------
  172.  *
  173.  * Tcl_WatchInterp --
  174.  *
  175.  *    Arrange for a procedure to be called before a given
  176.  *    interpreter is deleted.
  177.  *
  178.  * Results:
  179.  *    None.
  180.  *
  181.  * Side effects:
  182.  *    When Tcl_DeleteInterp is invoked to delete interp,
  183.  *    proc will be invoked.  See the manual entry for
  184.  *    details.
  185.  *
  186.  *--------------------------------------------------------------
  187.  */
  188.  
  189. void
  190. Tcl_WatchInterp(interp, proc, clientData)
  191.     Tcl_Interp *interp;        /* Interpreter to watch. */
  192.     void (*proc)();        /* Procedure to call when interpreter
  193.                  * is about to be deleted. */
  194.     ClientData clientData;    /* One-word value to pass to proc. */
  195. {
  196.     register InterpCallback *icPtr;
  197.     Interp *iPtr = (Interp *) interp;
  198.  
  199.     icPtr = (InterpCallback *) ckalloc(sizeof(InterpCallback));
  200.     icPtr->proc = proc;
  201.     icPtr->clientData = clientData;
  202.     icPtr->nextPtr = iPtr->callbackPtr;
  203.     iPtr->callbackPtr = icPtr;
  204. }
  205.  
  206. /*
  207.  *----------------------------------------------------------------------
  208.  *
  209.  * Tcl_DeleteInterp --
  210.  *
  211.  *    Delete an interpreter and ckfree up all of the resources associated
  212.  *    with it.
  213.  *
  214.  * Results:
  215.  *    None.
  216.  *
  217.  * Side effects:
  218.  *    The interpreter is destroyed.  The caller should never again
  219.  *    use the interp token.
  220.  *
  221.  *----------------------------------------------------------------------
  222.  */
  223.  
  224. void
  225. Tcl_DeleteInterp(interp)
  226.     Tcl_Interp *interp;        /* Token for command interpreter (returned
  227.                  * by a previous call to Tcl_CreateInterp). */
  228. {
  229.     Interp *iPtr = (Interp *) interp;
  230.     register Command *cmdPtr;
  231.     register Trace *tracePtr;
  232.     register InterpCallback *icPtr;
  233.  
  234.     /*
  235.      * If the interpreter is in use, delay the deletion until later.
  236.      */
  237.  
  238.     iPtr->flags |= DELETED;
  239.     if (iPtr->numLevels != 0) {
  240.     return;
  241.     }
  242.  
  243.     /*
  244.      * Invoke callbacks, if there's anyone who wants to know about
  245.      * the interpreter deletion.
  246.      */
  247.  
  248.     for (icPtr = iPtr->callbackPtr; icPtr != NULL;
  249.         icPtr = icPtr->nextPtr) {
  250.     (*icPtr->proc)(icPtr->clientData, interp);
  251.     ckfree((char *) icPtr);
  252.     }
  253.  
  254.     /*
  255.      * Free up any remaining resources associated with the
  256.      * interpreter.
  257.      */
  258.  
  259.     for (cmdPtr = iPtr->commandPtr; cmdPtr != NULL;
  260.         cmdPtr = cmdPtr->nextPtr) {
  261.     if (cmdPtr->deleteProc != NULL) { 
  262.         (*cmdPtr->deleteProc)(cmdPtr->clientData);
  263.     }
  264.     ckfree((char *) cmdPtr);
  265.     }
  266.     iPtr->commandPtr = NULL;
  267.     TclDeleteVars(iPtr);
  268.     for (tracePtr = iPtr->tracePtr; tracePtr != NULL;
  269.         tracePtr = tracePtr->nextPtr) {
  270.     ckfree((char *) tracePtr);
  271.     }
  272.     ckfree((char *) iPtr);
  273. }
  274.  
  275. /*
  276.  *----------------------------------------------------------------------
  277.  *
  278.  * Tcl_CreateCommand --
  279.  *
  280.  *    Define a new command in a command table.
  281.  *
  282.  * Results:
  283.  *    None.
  284.  *
  285.  * Side effects:
  286.  *    If a command named cmdName already exists for interp, it is
  287.  *    deleted.  In the future, when cmdName is seen as the name of
  288.  *    a command by Tcl_Eval, proc will be called with the following
  289.  *    syntax:
  290.  *
  291.  *    int
  292.  *    proc(clientData, interp, argc, argv)
  293.  *        ClientData clientData;
  294.  *        Tcl_Interp *interp;
  295.  *        int argc;
  296.  *        char **argv;
  297.  *    {
  298.  *    }
  299.  *
  300.  *    The clientData and interp arguments are the same as the corresponding
  301.  *    arguments passed to this procedure.  Argc and argv describe the
  302.  *    arguments to the command, in the usual UNIX fashion.  Proc must
  303.  *    return a code like TCL_OK or TCL_ERROR.  It can also set interp->result
  304.  *    ("" is the default value if proc doesn't set it) and interp->dynamic (0
  305.  *    is the default).  See tcl.h for more information on these variables.
  306.  *
  307.  *    When the command is deleted from the table, deleteProc will be called
  308.  *    in the following way:
  309.  *
  310.  *    void
  311.  *    deleteProc(clientData)
  312.  *        ClientData clientData;
  313.  *    {
  314.  *    }
  315.  *
  316.  *    DeleteProc allows command implementors to perform their own cleanup
  317.  *    when commands (or interpreters) are deleted.
  318.  *
  319.  *----------------------------------------------------------------------
  320.  */
  321.  
  322. void
  323. Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
  324.     Tcl_Interp *interp;        /* Token for command interpreter (returned
  325.                  * by a previous call to Tcl_CreateInterp). */
  326.     char *cmdName;        /* Name of command. */
  327.     int (*proc)();        /* Command procedure to associate with
  328.                  * cmdName. */
  329.     ClientData clientData;    /* Arbitrary one-word value to pass to proc. */
  330.     void (*deleteProc)();    /* If not NULL, gives a procedure to call when
  331.                  * this command is deleted. */
  332. {
  333.     Interp *iPtr = (Interp *) interp;
  334.     register Command *cmdPtr;
  335.  
  336.     Tcl_DeleteCommand(interp, cmdName);
  337.     cmdPtr = (Command *) ckalloc(CMD_SIZE(strlen(cmdName)));
  338.     cmdPtr->proc = proc;
  339.     cmdPtr->clientData = clientData;
  340.     cmdPtr->deleteProc = deleteProc;
  341.     cmdPtr->nextPtr = iPtr->commandPtr;
  342.     iPtr->commandPtr = cmdPtr;
  343.     strcpy(cmdPtr->name, cmdName);
  344. }
  345.  
  346. /*
  347.  *----------------------------------------------------------------------
  348.  *
  349.  * Tcl_DeleteCommand --
  350.  *
  351.  *    Remove the given command from the given interpreter.
  352.  *
  353.  * Results:
  354.  *    None.
  355.  *
  356.  * Side effects:
  357.  *    CmdName will no longer be recognized as a valid command for
  358.  *    interp.
  359.  *
  360.  *----------------------------------------------------------------------
  361.  */
  362.  
  363. void
  364. Tcl_DeleteCommand(interp, cmdName)
  365.     Tcl_Interp *interp;        /* Token for command interpreter (returned
  366.                  * by a previous call to Tcl_CreateInterp). */
  367.     char *cmdName;        /* Name of command to remove. */
  368. {
  369.     Interp *iPtr = (Interp *) interp;
  370.     Command *cmdPtr;
  371.  
  372.     cmdPtr = TclFindCmd(iPtr, cmdName, 0);
  373.     if (cmdPtr != NULL) {
  374.     if (cmdPtr->deleteProc != NULL) {
  375.         (*cmdPtr->deleteProc)(cmdPtr->clientData);
  376.     }
  377.     iPtr->commandPtr = cmdPtr->nextPtr;
  378.     ckfree((char *) cmdPtr);
  379.     }
  380. }
  381.  
  382. /*
  383.  *-----------------------------------------------------------------
  384.  *
  385.  * Tcl_Eval --
  386.  *
  387.  *    Parse and execute a command in the Tcl language.
  388.  *
  389.  * Results:
  390.  *    The return value is one of the return codes defined in
  391.  *    tcl.h (such as TCL_OK), and interp->result contains a string
  392.  *    value to supplement the return code.  The value of interp->result
  393.  *    will persist only until the next call to Tcl_Eval:  copy it
  394.  *    or lose it!
  395.  *
  396.  * Side effects:
  397.  *    Almost certainly;  depends on the command.
  398.  *
  399.  *-----------------------------------------------------------------
  400.  */
  401.  
  402. int
  403. Tcl_Eval(interp, cmd, flags, termPtr)
  404.     Tcl_Interp *interp;        /* Token for command interpreter (returned
  405.                  * by a previous call to Tcl_CreateInterp). */
  406.     char *cmd;            /* Pointer to TCL command to interpret. */
  407.     int flags;            /* OR-ed combination of flags like
  408.                  * TCL_BRACKET_TERM. */
  409.     char **termPtr;        /* If non-NULL, fill in the address it points
  410.                  * to with the address of the char. just after
  411.                  * the last one that was part of cmd.  See
  412.                  * the man page for details on this. */
  413. {
  414.     /*
  415.      * While processing the command, make a local copy of
  416.      * the command characters.  This is needed in order to
  417.      * terminate each argument with a null character, replace
  418.      * backslashed-characters, etc.  The copy starts out in
  419.      * a static string (for speed) but gets expanded into
  420.      * dynamically-allocated strings if necessary.  The constant
  421.      * BUFFER indicates how much space there must be in the copy
  422.      * in order to pass through the main loop below (e.g., must
  423.      * have space to copy both a backslash and its following
  424.      * characters).
  425.      */
  426.  
  427. #   define NUM_CHARS 200
  428. #   define BUFFER 5
  429.     char copyStorage[NUM_CHARS];
  430.     char *copy = copyStorage;    /* Pointer to current copy. */
  431.     int copySize = NUM_CHARS;    /* Size of current copy. */
  432.     register char *dst;        /* Points to next place to copy
  433.                  * a character. */
  434.     char *limit;        /* When dst gets here, must make
  435.                  * the copy larger. */
  436.  
  437.     /*
  438.      * This procedure generates an (argv, argc) array for the command,
  439.      * It starts out with stack-allocated space but uses dynamically-
  440.      * allocated storage to increase it if needed.
  441.      */
  442.  
  443. #   define NUM_ARGS 10
  444.     char *(argStorage[NUM_ARGS]);
  445.     char **argv = argStorage;
  446.     int argc;
  447.     int argSize = NUM_ARGS;
  448.  
  449.     /*
  450.      * Keep count of how many nested open braces or quotes there
  451.      * are at the current point in the current argument.  If a
  452.      * quoted argument is being read, then openQuote and openBraces
  453.      * will both be 1.
  454.      */
  455.  
  456.     int openBraces = 0;            /* Curent nesting level. */
  457.     int openQuote = 0;            /* Non-zero means quoted arg
  458.                      * in progress. */
  459.  
  460.     register char *src;            /* Points to current character
  461.                      * in cmd. */
  462.     char termChar;            /* Return when this character is found
  463.                      * (either ']' or '\0').  Zero means
  464.                      * that newlines terminate commands. */
  465.     char *argStart;            /* Location in cmd of first                             * non-separator character in
  466.                      * current argument;  it's
  467.                      * used to eliminate multiple
  468.                      * separators between args and
  469.                      * extra separators after last
  470.                      * arg in command. */
  471.     int result = TCL_OK;        /* Return value. */
  472.     int i;
  473.     register Interp *iPtr = (Interp *) interp;
  474.     Command *cmdPtr;
  475.     char *tmp;
  476.     char *dummy;            /* Make termPtr point here if it was
  477.                      * originally NULL. */
  478.     char *syntaxMsg;
  479.     char *syntaxPtr;            /* Points to "relevant" character
  480.                      * for syntax violations. */
  481.     char *cmdStart;            /* Points to first non-blank char. in
  482.                      * command (used in calling trace
  483.                      * procedures). */
  484.     register Trace *tracePtr;
  485.  
  486.     /*
  487.      * Set up the result so that if there's no command at all in
  488.      * the string then this procedure will return TCL_OK.
  489.      */
  490.  
  491.     if (iPtr->dynamic) {
  492.     ckfree((char *) iPtr->result);
  493.     iPtr->dynamic = 0;
  494.     }
  495.     iPtr->result = iPtr->resultSpace;
  496.     iPtr->resultSpace[0] = 0;
  497.  
  498.     iPtr->numLevels++;
  499.     iPtr->errInProgress = 0;
  500.     src = cmd;
  501.     result = TCL_OK;
  502.     if (flags & TCL_BRACKET_TERM) {
  503.     termChar = ']';
  504.     } else {
  505.     termChar = 0;
  506.     }
  507.     if (termPtr == NULL) {
  508.     termPtr = &dummy;
  509.     }
  510.  
  511.     /*
  512.      * There can be many sub-commands (separated by semi-colons or
  513.      * newlines) in one command string.  This outer loop iterates over
  514.      * the inner commands.
  515.      */
  516.  
  517.     for (*termPtr = src; *src != termChar; *termPtr = src) {
  518.  
  519.     /*
  520.      * Skim off leading white space and semi-colons, and skip comments.
  521.      */
  522.  
  523.     while (isspace(*src) || (*src == ';')) {
  524.         src += 1;
  525.     }
  526.     if (*src == '#') {
  527.         for (src++; *src != 0; src++) {
  528.         if (*src == '\n') {
  529.             src++;
  530.             break;
  531.         }
  532.         }
  533.         continue;
  534.     }
  535.  
  536.     /*
  537.      * Set up the first argument (the command name).  Note that
  538.      * the arg pointer gets set up BEFORE the first real character
  539.      * of the argument has been found.
  540.      */
  541.     
  542.     dst = copy;
  543.     argc = 0;
  544.     limit = copy + copySize - BUFFER;
  545.     argv[0] = dst;
  546.     argStart = cmdStart = src;
  547.  
  548.     /*
  549.      * Skim off the command name and arguments by looping over
  550.      * characters and processing each one according to its type.
  551.      */
  552.     
  553.     while (1) {
  554.         switch (*src) {
  555.     
  556.         /*
  557.          * All braces are treated as normal characters
  558.          * unless the first character of the argument is an
  559.          * open brace.  In that case, braces nest and
  560.          * the argument terminates when all braces are matched.
  561.          * Internal braces are also copied like normal chars.
  562.          */
  563.     
  564.         case '{': {
  565.             if ((openBraces == 0) && (dst == argv[argc])) {
  566.             syntaxPtr = src;
  567.             openBraces = 1;
  568.             break;
  569.             }
  570.             *dst = '{'; dst++;
  571.             if ((openBraces > 0) && !openQuote) {
  572.             openBraces++;
  573.             }
  574.             break;
  575.         }
  576.  
  577.         case '}': {
  578.             if (openBraces == 1) {
  579.             openBraces = 0;
  580.             if (!isspace(src[1]) && (src[1] != termChar) &&
  581.                 (src[1] != 0) && (src[1] != ';')) {
  582.                 syntaxPtr = src;
  583.                 syntaxMsg = "extra characters after close-brace";
  584.                 goto syntaxError;
  585.             }
  586.             } else {
  587.             *dst = '}'; dst++;
  588.             if ((openBraces > 0) && !openQuote) {
  589.                 openBraces--;
  590.             }
  591.             }
  592.             break;
  593.         }
  594.  
  595.         case '"': {
  596.             if (!openQuote) {
  597.             if ((openBraces) || (dst != argv[argc])) {
  598.                 *dst = '"'; dst++;
  599.                 break;
  600.             }
  601.             syntaxPtr = src;
  602.             openQuote = 1;
  603.             openBraces = 1;
  604.             } else {
  605.             openQuote = 0;
  606.             openBraces = 0;
  607.             if (!isspace(src[1]) && (src[1] != termChar) &&
  608.                 (src[1] != 0)) {
  609.                 syntaxPtr = src;
  610.                 syntaxMsg = "extra characters after close-quote";
  611.                 goto syntaxError;
  612.             }
  613.             }
  614.             break;
  615.         }
  616.     
  617.         case '[': {
  618.     
  619.             /*
  620.              * Open bracket: if not in middle of braces, then execute
  621.              * following command and substitute result into argument.
  622.              */
  623.  
  624.             if (openBraces != 0) {
  625.             *dst = '['; dst++;
  626.             } else {
  627.             int length;
  628.     
  629.             result = Tcl_Eval(interp, src+1, TCL_BRACKET_TERM,
  630.                 &tmp);
  631.             src = tmp;
  632.             if (result != TCL_OK) {
  633.                 goto done;
  634.             }
  635.     
  636.             /*
  637.              * Copy the return value into the current argument.
  638.              * May have to enlarge the argument storage.  When
  639.              * enlarging, get more than enough to reduce the
  640.              * likelihood of having to enlarge again.  This code
  641.              * is used for $-processing also.
  642.              */
  643.  
  644.             copyResult:
  645.             length = strlen(iPtr->result);
  646.             if ((limit - dst) < length) {
  647.                 char *newCopy;
  648.                 int bytes;
  649.  
  650.                 bytes = dst - copy;
  651.                 copySize = length + 10 + bytes;
  652.                 newCopy = (char *) ckalloc((unsigned) copySize);
  653.                 move_argv(argv, argc, copy, newCopy, bytes);
  654.                 dst = newCopy + bytes;
  655.                 if (copy != copyStorage) {
  656.                 ckfree((char *) copy);
  657.                 }
  658.                 copy = newCopy;
  659.                 limit = newCopy + copySize - BUFFER;
  660.             }
  661.             bcopy(iPtr->result, dst, length);
  662.             dst += length;
  663.  
  664.             /*
  665.              * Clear out the return value again.
  666.              */
  667.  
  668.             if (iPtr->dynamic) {
  669.                 ckfree((char *) iPtr->result);
  670.                 iPtr->dynamic = 0;
  671.             }
  672.             iPtr->result = iPtr->resultSpace;
  673.             iPtr->resultSpace[0] = 0;
  674.             }
  675.             break;
  676.         }
  677.  
  678.         case '$': {
  679.             if (openBraces != 0) {
  680.             *dst = '$'; dst++;
  681.             } else {
  682.             char *value;
  683.  
  684.             /*
  685.              * Parse off a variable name and copy its value.
  686.              */
  687.     
  688.             value = Tcl_ParseVar(interp, src, &tmp);
  689.             if (value == 0) {
  690.                 result = TCL_ERROR;
  691.                 goto done;
  692.             }
  693.             interp->result = value;
  694.             src = tmp-1;
  695.             goto copyResult;
  696.             }
  697.             break;
  698.         }
  699.  
  700.         case ']': {
  701.             if ((openBraces == 0) && (termChar == ']')) {
  702.             goto cmdComplete;
  703.             }
  704.             *dst = ']'; dst++;
  705.             break;
  706.         }
  707.  
  708.         case ';': {
  709.             if (openBraces == 0) {
  710.             goto cmdComplete;
  711.             }
  712.             *dst = *src; dst++;
  713.             break;
  714.         }
  715.     
  716.         case '\n': {
  717.  
  718.             /*
  719.              * A newline can be either a command terminator
  720.              * or a space character.  If it's a space character,
  721.              * just fall through to the space code below.
  722.              */
  723.     
  724.             if ((openBraces == 0) && (termChar == 0)) {
  725.             goto cmdComplete;
  726.             }
  727.         }
  728.  
  729.         case '\r':
  730.         case ' ':
  731.         case '\t': {
  732.             if (openBraces > 0) {
  733.     
  734.             /*
  735.              * Quoted space.  Copy it into the argument.
  736.              */
  737.  
  738.             *dst = *src; dst++;
  739.             } else {
  740.  
  741.             /*
  742.              * Argument separator.  If there are many
  743.              * separators in a row (src == argStart) just
  744.              * ignore this separator.  Otherwise,
  745.              * Null-terminate the current argument and
  746.              * set up for the next one.
  747.              */
  748.  
  749.             if (src == argStart) {
  750.                 argStart = src+1;
  751.                 break;
  752.             }
  753.             argStart = src+1;
  754.             *dst = 0;
  755.             dst++; argc++;
  756.  
  757.             /*
  758.              * Make sure that the argument array is large enough
  759.              * for the next argument plus a final NULL argument
  760.              * pointer to terminate the list.
  761.              */
  762.  
  763.             if (argc >= argSize-1) {
  764.                 char **newArgs;
  765.     
  766.                 argSize *= 2;
  767.                 newArgs = (char **)
  768.                     ckalloc((unsigned) argSize * sizeof(char *));
  769.                 for (i = 0; i < argc; i++) {
  770.                 newArgs[i] = argv[i];
  771.                 }
  772.                 if (argv != argStorage) {
  773.                 ckfree((char *) argv);
  774.                 }
  775.                 argv = newArgs;
  776.             }
  777.             argv[argc] = dst;
  778.             break;
  779.             }
  780.             break;
  781.         }
  782.     
  783.         case '\\': {
  784.             int numRead;
  785.  
  786.             /*
  787.              * First of all, make the special check for
  788.              * backslash followed by newline.  This can't
  789.              * be processed in the normal fashion of
  790.              * Tcl_Backslash because is maps to "nothing",
  791.              * rather than to a character.
  792.              */
  793.  
  794.             if (src[1] == '\n') {
  795.             if (argStart  == src) {
  796.                 argStart += 2;
  797.             }
  798.             src++;
  799.             break;
  800.             }
  801.  
  802.             /*
  803.              * If we're in an argument in braces then the
  804.              * backslash doesn't get collapsed.  However,
  805.              * whether we're in braces or not the characters
  806.              * inside the backslash sequence must not receive
  807.              * any additional processing:  make src point to
  808.              * the last character of the sequence.
  809.              */
  810.  
  811.             *dst = Tcl_Backslash(src, &numRead);
  812.             if (openBraces > 0) {
  813.             for ( ; numRead > 0; src++, dst++, numRead--) {
  814.                 *dst = *src;
  815.             }
  816.             src--;
  817.             } else {
  818.             src += numRead-1;
  819.             dst++;
  820.             }
  821.             break;
  822.         }
  823.     
  824.         case 0: {
  825.  
  826.             /*
  827.              * End of string.  Make sure that braces/quotes
  828.              * were properly matched.  Also, it's only legal
  829.              * to terminate a command by a null character if
  830.              * termChar is zero.
  831.              */
  832.  
  833.             if (openBraces != 0) {
  834.             if (openQuote) {
  835.                 syntaxMsg = "unmatched quote";
  836.             } else {
  837.                 syntaxMsg = "unmatched brace";
  838.             }
  839.             goto syntaxError;
  840.             } else if (termChar == ']') {
  841.             syntaxPtr = cmd;
  842.             syntaxMsg = "missing close-bracket";
  843.             goto syntaxError;
  844.             }
  845.             goto cmdComplete;
  846.         }
  847.     
  848.         default: {
  849.             *dst = *src; dst++;
  850.             break;
  851.         }
  852.         }
  853.         src += 1;
  854.     
  855.         /*
  856.          * Make sure that we're not running out of space in the
  857.          * string copy area.  If we are, allocate a larger area
  858.          * and copy the string.  Be sure to update all of the
  859.          * relevant pointers too.
  860.          */
  861.     
  862.         if (dst >= limit) {
  863.         char *newCopy;
  864.         int bytes;
  865.     
  866.         bytes = dst - copy;
  867.         copySize *= 2;
  868.         newCopy = (char *) ckalloc((unsigned) copySize);
  869.         move_argv(argv, argc, copy, newCopy, bytes);
  870.         dst = newCopy + bytes;
  871.         if (copy != copyStorage) {
  872.             ckfree((char *) copy);
  873.         }
  874.         copy = newCopy;
  875.         limit = newCopy + copySize - BUFFER;
  876.         }
  877.     
  878.     }
  879.     
  880.     /*
  881.      * Terminate the last argument and add a final NULL argument.  If
  882.      * the interpreter has been deleted then return;  if there's no
  883.      * command, then go on to the next iteration.
  884.      */
  885.  
  886.     cmdComplete:
  887.     if (iPtr->flags & DELETED) {
  888.         goto done;
  889.     }
  890.     if (src != argStart) {
  891.         *dst = 0;
  892.         argc++;
  893.     }
  894.     if ((argc == 0) || iPtr->noEval) {
  895.         continue;
  896.     }
  897.     argv[argc] = NULL;
  898.  
  899.     cmdPtr = TclFindCmd(iPtr, argv[0], 1);
  900.     if (cmdPtr == NULL) {
  901.         sprintf(iPtr->result,
  902.             "\"%.50s\" is an invalid command name %s",
  903.             argv[0], "or ambiguous abbreviation");
  904.         result = TCL_ERROR;
  905.         goto done;
  906.     }
  907.  
  908.     /*
  909.      * Call trace procedures, if any, then invoke the command.
  910.      */
  911.  
  912.     for (tracePtr = iPtr->tracePtr; tracePtr != NULL;
  913.         tracePtr = tracePtr->nextPtr) {
  914.         char saved;
  915.  
  916.         if (tracePtr->level < iPtr->numLevels) {
  917.         continue;
  918.         }
  919.         saved = *src;
  920.         *src = 0;
  921.         (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels,
  922.             cmdStart, cmdPtr->proc, cmdPtr->clientData, argc, argv);
  923.         *src = saved;
  924.     }
  925.  
  926.     iPtr->cmdCount++;
  927.     result = (*cmdPtr->proc)(cmdPtr->clientData, interp, argc, argv);
  928.     if (result != TCL_OK) {
  929.         break;
  930.     }
  931.     }
  932.  
  933.     /*
  934.      * Free up any extra resources that were allocated.
  935.      */
  936.  
  937.     done:
  938.     if (copy != copyStorage) {
  939.     ckfree((char *) copy);
  940.     }
  941.     if (argv != argStorage) {
  942.     ckfree((char *) argv);
  943.     }
  944.     iPtr->numLevels--;
  945.     if (iPtr->numLevels == 0) {
  946.     if (result == TCL_RETURN) {
  947.         result = TCL_OK;
  948.     }
  949.     if ((result != TCL_OK) && (result != TCL_ERROR)) {
  950.         if (iPtr->dynamic) {
  951.         ckfree(iPtr->result);
  952.         iPtr->dynamic = 0;
  953.         }
  954.         if (result == TCL_BREAK) {
  955.         iPtr->result = "invoked \"break\" outside of a loop";
  956.         } else if (result == TCL_CONTINUE) {
  957.         iPtr->result = "invoked \"continue\" outside of a loop";
  958.         } else {
  959.         iPtr->result = iPtr->resultSpace;
  960.         sprintf(iPtr->resultSpace, "command returned bad code: %d",
  961.             result);
  962.         }
  963.         result = TCL_ERROR;
  964.     }
  965.     if (iPtr->flags & DELETED) {
  966.         Tcl_DeleteInterp(interp);
  967.     }
  968.     }
  969.  
  970.     /*
  971.      * If an error occurred, record information about what was being
  972.      * executed when the error occurred.
  973.      */
  974.  
  975.     if (result == TCL_ERROR) {
  976.     int numChars;
  977.     register char *p;
  978.     char *ellipsis;
  979.  
  980.     /*
  981.      * Compute the line number where the error occurred.
  982.      */
  983.  
  984.     iPtr->errorLine = 1;
  985.     for (p = cmd; p != cmdStart; p++) {
  986.         if (*p == '\n') {
  987.         iPtr->errorLine++;
  988.         }
  989.     }
  990.     for ( ; isspace(*p) || (*p == ';'); p++) {
  991.         if (*p == '\n') {
  992.         iPtr->errorLine++;
  993.         }
  994.     }
  995.  
  996.     /*
  997.      * Figure out how much of the command to print in the error
  998.      * message (up to a certain number of characters, or up to
  999.      * the first new-line).
  1000.      */
  1001.  
  1002.     ellipsis = "";
  1003.     p = strchr(cmdStart, '\n');
  1004.     if (p == NULL) {
  1005.         numChars = strlen(cmdStart);
  1006.     } else {
  1007.         if (p < src) {
  1008.         ellipsis = "...";
  1009.         }
  1010.         numChars = p - cmdStart;
  1011.     }
  1012.     if (numChars > 40) {
  1013.         numChars = 40;
  1014.         ellipsis = "...";
  1015.     }
  1016.  
  1017.     if (!iPtr->errInProgress) {
  1018.         /*
  1019.          * This is the first piece of information being recorded
  1020.          * for this error.  Log the error message as well as the
  1021.          * command being executed.
  1022.          */
  1023.  
  1024.         if (strlen(iPtr->result) < 50) {
  1025.         sprintf(copyStorage,
  1026.             "%s, while executing\n\"%.*s%s\"",
  1027.             iPtr->result, numChars, cmdStart, ellipsis);
  1028.         } else {
  1029.         sprintf(copyStorage,
  1030.             "%.50s..., while executing\n\"%.*s%s\"",
  1031.             iPtr->result, numChars, cmdStart, ellipsis);
  1032.         }
  1033.     } else {
  1034.         sprintf(copyStorage, ", invoked from within\n\"%.*s%s\"",
  1035.             numChars, cmdStart, ellipsis);
  1036.     }
  1037.     Tcl_AddErrorInfo(interp, copyStorage);
  1038.     }
  1039.     return result;
  1040.  
  1041.     /*
  1042.      * Syntax error:  generate an error message.
  1043.      */
  1044.  
  1045.     syntaxError: {
  1046.     char *first, *last;
  1047.  
  1048.     Tcl_Return(interp, (char *) NULL, TCL_STATIC);
  1049.     for (first = syntaxPtr; ((first != cmd) && (first[-1] != '\n'));
  1050.         first--) {
  1051.         /* Null loop body. */
  1052.     }
  1053.     for (last = syntaxPtr; ((*last != 0) && (*last!= '\n')); last++) {
  1054.         /* Null loop body. */
  1055.     }
  1056.     if ((syntaxPtr - first) > 60) {
  1057.         first = syntaxPtr - 60;
  1058.     }
  1059.     if ((last - first) > 70) {
  1060.         last = first + 70;
  1061.     }
  1062.     if (last == first) {
  1063.         sprintf(iPtr->resultSpace, "%s", syntaxMsg);
  1064.     } else {
  1065.         sprintf(iPtr->resultSpace, "%s: '%.*s => %.*s'", syntaxMsg,
  1066.             syntaxPtr-first, first, last-syntaxPtr, syntaxPtr);
  1067.     }
  1068.     result = TCL_ERROR;
  1069.     iPtr->result = iPtr->resultSpace;
  1070.     }
  1071.  
  1072.     goto done;
  1073. }
  1074.  
  1075. /*
  1076.  *----------------------------------------------------------------------
  1077.  *
  1078.  * Tcl_CreateTrace --
  1079.  *
  1080.  *    Arrange for a procedure to be called to trace command execution.
  1081.  *
  1082.  * Results:
  1083.  *    The return value is a token for the trace, which may be passed
  1084.  *    to Tcl_DeleteTrace to eliminate the trace.
  1085.  *
  1086.  * Side effects:
  1087.  *    From now on, proc will be called just before a command procedure
  1088.  *    is called to execute a Tcl command.  Calls to proc will have the
  1089.  *    following form:
  1090.  *
  1091.  *    void
  1092.  *    proc(clientData, interp, level, command, cmdProc, cmdClientData,
  1093.  *        argc, argv)
  1094.  *        ClientData clientData;
  1095.  *        Tcl_Interp *interp;
  1096.  *        int level;
  1097.  *        char *command;
  1098.  *        int (*cmdProc)();
  1099.  *        ClientData cmdClientData;
  1100.  *        int argc;
  1101.  *        char **argv;
  1102.  *    {
  1103.  *    }
  1104.  *
  1105.  *    The clientData and interp arguments to proc will be the same
  1106.  *    as the corresponding arguments to this procedure.  Level gives
  1107.  *    the nesting level of command interpretation for this interpreter
  1108.  *    (0 corresponds to top level).  Command gives the ASCII text of
  1109.  *    the raw command, cmdProc and cmdClientData give the procedure that
  1110.  *    will be called to process the command and the ClientData value it
  1111.  *    will receive, and argc and argv give the arguments to the
  1112.  *    command, after any argument parsing and substitution.  Proc
  1113.  *    does not return a value.
  1114.  *
  1115.  *----------------------------------------------------------------------
  1116.  */
  1117.  
  1118. Tcl_Trace
  1119. Tcl_CreateTrace(interp, level, proc, clientData)
  1120.     Tcl_Interp *interp;        /* Interpreter in which to create the trace. */
  1121.     int level;            /* Only call proc for commands at nesting level
  1122.                  * <= level (1 => top level). */
  1123.     void (*proc)();        /* Procedure to call before executing each
  1124.                  * command. */
  1125.     ClientData clientData;    /* Arbitrary one-word value to pass to proc. */
  1126. {
  1127.     register Trace *tracePtr;
  1128.     register Interp *iPtr = (Interp *) interp;
  1129.  
  1130.     tracePtr = (Trace *) ckalloc(sizeof(Trace));
  1131.     tracePtr->level = level;
  1132.     tracePtr->proc = proc;
  1133.     tracePtr->clientData = clientData;
  1134.     tracePtr->nextPtr = iPtr->tracePtr;
  1135.     iPtr->tracePtr = tracePtr;
  1136.  
  1137.     return (Tcl_Trace) tracePtr;
  1138. }
  1139.  
  1140. /*
  1141.  *----------------------------------------------------------------------
  1142.  *
  1143.  * Tcl_DeleteTrace --
  1144.  *
  1145.  *    Remove a trace.
  1146.  *
  1147.  * Results:
  1148.  *    None.
  1149.  *
  1150.  * Side effects:
  1151.  *    From now on there will be no more calls to the procedure given
  1152.  *    in trace.
  1153.  *
  1154.  *----------------------------------------------------------------------
  1155.  */
  1156.  
  1157. void
  1158. Tcl_DeleteTrace(interp, trace)
  1159.     Tcl_Interp *interp;        /* Interpreter that contains trace. */
  1160.     Tcl_Trace trace;        /* Token for trace (returned previously by
  1161.                  * Tcl_CreateTrace). */
  1162. {
  1163.     register Interp *iPtr = (Interp *) interp;
  1164.     register Trace *tracePtr = (Trace *) trace;
  1165.     register Trace *tracePtr2;
  1166.  
  1167.     if (iPtr->tracePtr == tracePtr) {
  1168.     iPtr->tracePtr = tracePtr->nextPtr;
  1169.     ckfree((char *) tracePtr);
  1170.     } else {
  1171.     for (tracePtr2 = iPtr->tracePtr; tracePtr2 != NULL;
  1172.         tracePtr2 = tracePtr2->nextPtr) {
  1173.         if (tracePtr2->nextPtr == tracePtr) {
  1174.         tracePtr2->nextPtr = tracePtr->nextPtr;
  1175.         ckfree((char *) tracePtr);
  1176.         return;
  1177.         }
  1178.     }
  1179.     }
  1180. }
  1181.  
  1182. /*
  1183.  *----------------------------------------------------------------------
  1184.  *
  1185.  * Tcl_AddErrorInfo --
  1186.  *
  1187.  *    Add information to a message being accumulated that describes
  1188.  *    the current error.
  1189.  *
  1190.  * Results:
  1191.  *    None.
  1192.  *
  1193.  * Side effects:
  1194.  *    The contents of message are added to the "errorInfo" variable.
  1195.  *    If Tcl_Eval has been called since the current value of errorInfo
  1196.  *    was set, errorInfo is cleared before adding the new message.
  1197.  *
  1198.  *----------------------------------------------------------------------
  1199.  */
  1200.  
  1201. void
  1202. Tcl_AddErrorInfo(interp, message)
  1203.     Tcl_Interp *interp;        /* Interpreter to which error information
  1204.                  * pertains. */
  1205.     char *message;        /* Message to record. */
  1206. {
  1207.     register Interp *iPtr = (Interp *) interp;
  1208.  
  1209.     if (iPtr->errInProgress) {
  1210.     int length;
  1211.     char *buffer, *oldVar;
  1212.  
  1213.     oldVar = Tcl_GetVar(interp, "errorInfo", 1);
  1214.     if(!oldVar) oldVar = "";
  1215.     length = strlen(oldVar);
  1216.     buffer = (char *)ckalloc((unsigned) (length + strlen(message) + 1));
  1217.     strcpy(buffer, oldVar);
  1218.     strcpy(buffer+length, message);
  1219.     Tcl_SetVar(interp, "errorInfo", buffer, 1);
  1220.     } else {
  1221.     iPtr->errInProgress = 1;
  1222.     Tcl_SetVar(interp, "errorInfo", message, 1);
  1223.     }
  1224. }
  1225.  
  1226. /*
  1227.  *----------------------------------------------------------------------
  1228.  *
  1229.  * TclFindCmd --
  1230.  *
  1231.  *    Find a particular command in an interpreter.
  1232.  *
  1233.  * Results:
  1234.  *    If the command doesn't exist in the table, or if it is an
  1235.  *    ambiguous abbreviation, then NULL is returned.  Otherwise
  1236.  *    the return value is a pointer to the command.  Unique
  1237.  *    abbreviations are allowed if abbrevOK is non-zero, but
  1238.  *    abbreviations take longer to look up (must scan the whole
  1239.  *    table twice).
  1240.  *
  1241.  * Side effects:
  1242.  *    If the command is found and is an exact match, it is relinked
  1243.  *    at the front of iPtr's command list so it will be found more
  1244.  *    quickly in the future.
  1245.  *
  1246.  *----------------------------------------------------------------------
  1247.  */
  1248.  
  1249. Command *
  1250. TclFindCmd(iPtr, cmdName, abbrevOK)
  1251.     Interp *iPtr;        /* Interpreter in which to search. */
  1252.     char *cmdName;        /* Desired command. */
  1253.     int abbrevOK;        /* Non-zero means permit abbreviations.
  1254.                  * Zero means exact matches only. */
  1255. {
  1256.     register Command *prev;
  1257.     register Command *cur;
  1258.     register char c;
  1259.     Command *match;
  1260.     int length;
  1261.  
  1262.     /*
  1263.      * First check for an exact match.
  1264.      */
  1265.  
  1266.     c = *cmdName;
  1267.     for (prev = NULL, cur = iPtr->commandPtr; cur != NULL;
  1268.         prev = cur, cur = cur->nextPtr) {
  1269.  
  1270.     /*
  1271.      * Check the first character here before wasting time calling
  1272.      * strcmp.
  1273.      */
  1274.  
  1275.     if ((cur->name[0] == c) && (strcmp(cur->name, cmdName) == 0)) {
  1276.         if (prev != NULL) {
  1277.         prev->nextPtr = cur->nextPtr;
  1278.         cur->nextPtr = iPtr->commandPtr;
  1279.         iPtr->commandPtr = cur;
  1280.         }
  1281.         return cur;
  1282.     }
  1283.     }
  1284.     if (!abbrevOK) {
  1285.     return NULL;
  1286.     }
  1287.  
  1288.     /*
  1289.      * No exact match.  Make a second pass to check for a unique
  1290.      * abbreviation.  Don't bother to pull the matching entry to
  1291.      * the front of the list, since we have to search the whole list
  1292.      * for abbreviations anyway.
  1293.      */
  1294.  
  1295.     length = strlen(cmdName);
  1296.     match = NULL;
  1297.     for (prev = NULL, cur = iPtr->commandPtr; cur != NULL;
  1298.         prev = cur, cur = cur->nextPtr) {
  1299.     if ((cur->name[0] == c) && (strncmp(cur->name, cmdName, length) == 0)) {
  1300.         if (match != NULL) {
  1301.         return NULL;
  1302.         }
  1303.         match = cur;
  1304.     }
  1305.     }
  1306.     return match;
  1307. }
  1308.  
  1309.