home *** CD-ROM | disk | FTP | other *** search
/ ARM Club 3 / TheARMClub_PDCD3.iso / hensa / programming / tcl / tclsrc / c / tclBasic < prev    next >
Encoding:
Text File  |  1996-02-06  |  38.7 KB  |  1,464 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 (c) 1987-1994 The Regents of the University of California.
  9.  * Copyright (c) 1994-1995 Sun Microsystems, Inc.
  10.  *
  11.  * See the file "license.terms" for information on usage and redistribution
  12.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  13.  */
  14.  
  15. static char sccsid[] = "@(#) tclBasic.c 1.168 95/06/29 13:33:21";
  16.  
  17. #include "tclInt.h"
  18. #include "RISCOSint.h"
  19. #define TCL_LIBRARY "<Tcl$Dir>.Library"
  20.  
  21. #ifndef TCL_GENERIC_ONLY
  22. #include "tclPort.h"
  23. #endif
  24. #include "patchlevel.h"
  25.  
  26. /*
  27.  * The following variable holds the name of a user-specific startup script
  28.  * to source if the application is being run nteractively (e.g. "~/.tclshrc").
  29.  * Set by Tcl_AppInit.  NULL means don't source anything ever.
  30.  */
  31.  
  32. char *tcl_RcFileName = NULL;
  33.  
  34. /*
  35.  * The following structure defines all of the commands in the Tcl core,
  36.  * and the C procedures that execute them.
  37.  */
  38.  
  39. typedef struct {
  40.     char *name;            /* Name of command. */
  41.     Tcl_CmdProc *proc;        /* Procedure that executes command. */
  42. } CmdInfo;
  43.  
  44. /*
  45.  * Built-in commands, and the procedures associated with them:
  46.  */
  47.  
  48. static CmdInfo builtInCmds[] = {
  49.     /*
  50.      * Commands in the generic core:
  51.      */
  52.  
  53.     {"append",        Tcl_AppendCmd},
  54.     {"array",        Tcl_ArrayCmd},
  55.     {"break",        Tcl_BreakCmd},
  56.     {"case",        Tcl_CaseCmd},
  57.     {"catch",        Tcl_CatchCmd},
  58.     {"concat",        Tcl_ConcatCmd},
  59.     {"continue",    Tcl_ContinueCmd},
  60.     {"error",        Tcl_ErrorCmd},
  61.     {"eval",        Tcl_EvalCmd},
  62.     {"expr",        Tcl_ExprCmd},
  63.     {"for",        Tcl_ForCmd},
  64.     {"foreach",        Tcl_ForeachCmd},
  65.     {"format",        Tcl_FormatCmd},
  66.     {"global",        Tcl_GlobalCmd},
  67. /* RISCOS - shade omits history command */
  68. #ifdef HISTORY
  69.     {"history",        Tcl_HistoryCmd},
  70. #endif
  71.     {"if",        Tcl_IfCmd},
  72.     {"incr",        Tcl_IncrCmd},
  73.     {"info",        Tcl_InfoCmd},
  74.     {"join",        Tcl_JoinCmd},
  75.     {"lappend",        Tcl_LappendCmd},
  76.     {"lindex",        Tcl_LindexCmd},
  77.     {"linsert",        Tcl_LinsertCmd},
  78.     {"list",        Tcl_ListCmd},
  79.     {"llength",        Tcl_LlengthCmd},
  80.     {"lrange",        Tcl_LrangeCmd},
  81.     {"lreplace",    Tcl_LreplaceCmd},
  82.     {"lsearch",        Tcl_LsearchCmd},
  83.     {"lsort",        Tcl_LsortCmd},
  84.     {"proc",        Tcl_ProcCmd},
  85.     {"regexp",        Tcl_RegexpCmd},
  86.     {"regsub",        Tcl_RegsubCmd},
  87.     {"rename",        Tcl_RenameCmd},
  88.     {"return",        Tcl_ReturnCmd},
  89.     {"scan",        Tcl_ScanCmd},
  90.     {"set",        Tcl_SetCmd},
  91.     {"split",        Tcl_SplitCmd},
  92.     {"string",        Tcl_StringCmd},
  93.     {"subst",        Tcl_SubstCmd},
  94.     {"switch",        Tcl_SwitchCmd},
  95.     {"trace",        Tcl_TraceCmd},
  96.     {"unset",        Tcl_UnsetCmd},
  97.     {"uplevel",        Tcl_UplevelCmd},
  98.     {"upvar",        Tcl_UpvarCmd},
  99.     {"while",        Tcl_WhileCmd},
  100. /* RISC OS commands */
  101.     {"close",Tcl_CloseCmd},
  102.     {"eof",Tcl_EofCmd},
  103.     {"exit",Tcl_ExitCmd},
  104.     {"file",Tcl_FileCmd},
  105.     {"flush",Tcl_FlushCmd},
  106.     {"getenv",Tcl_GetenvCmd},
  107.     {"gets",Tcl_GetsCmd},
  108.     {"glob",Tcl_GlobCmd},
  109.     {"open",Tcl_OpenCmd},
  110.     {"puts",Tcl_PutsCmd},
  111.     {"source",Tcl_SourceCmd},
  112.     {"system",Tcl_SystemCmd},
  113.     {"date",Tcl_DateCmd},
  114.     /*
  115.      * Commands in the UNIX core:
  116.      */
  117.  
  118. #ifndef TCL_GENERIC_ONLY
  119.     {"cd",        Tcl_CdCmd},
  120.     {"close",        Tcl_CloseCmd},
  121.     {"eof",        Tcl_EofCmd},
  122.     {"exec",        Tcl_ExecCmd},
  123.     {"exit",        Tcl_ExitCmd},
  124.     {"file",        Tcl_FileCmd},
  125.     {"flush",        Tcl_FlushCmd},
  126.     {"gets",        Tcl_GetsCmd},
  127.     {"glob",        Tcl_GlobCmd},
  128.     {"open",        Tcl_OpenCmd},
  129.     {"pid",        Tcl_PidCmd},
  130.     {"puts",        Tcl_PutsCmd},
  131.     {"pwd",        Tcl_PwdCmd},
  132.     {"read",        Tcl_ReadCmd},
  133.     {"seek",        Tcl_SeekCmd},
  134.     {"source",        Tcl_SourceCmd},
  135.     {"tell",        Tcl_TellCmd},
  136.     {"time",        Tcl_TimeCmd},
  137. #endif /* TCL_GENERIC_ONLY */
  138.     {NULL,        (Tcl_CmdProc *) NULL}
  139. };
  140.  
  141. /*
  142.  *----------------------------------------------------------------------
  143.  *
  144.  * Tcl_CreateInterp --
  145.  *
  146.  *    Create a new TCL command interpreter.
  147.  *
  148.  * Results:
  149.  *    The return value is a token for the interpreter, which may be
  150.  *    used in calls to procedures like Tcl_CreateCmd, Tcl_Eval, or
  151.  *    Tcl_DeleteInterp.
  152.  *
  153.  * Side effects:
  154.  *    The command interpreter is initialized with an empty variable
  155.  *    table and the built-in commands.  SIGPIPE signals are set to
  156.  *    be ignored (see comment below for details).
  157.  *
  158.  *----------------------------------------------------------------------
  159.  */
  160.  
  161. Tcl_Interp *
  162. Tcl_CreateInterp()
  163. {
  164.     register Interp *iPtr;
  165.     register Command *cmdPtr;
  166.     register CmdInfo *cmdInfoPtr;
  167.     int i;
  168.     char *libDir;
  169. #ifndef TCL_GENERIC_ONLY
  170.     static int firstInterp = 1;
  171. #endif
  172.     iPtr = (Interp *) ckalloc(sizeof(Interp));
  173.     iPtr->result = iPtr->resultSpace;
  174.     iPtr->freeProc = 0;
  175.     iPtr->errorLine = 0;
  176.     Tcl_InitHashTable(&iPtr->commandTable, TCL_STRING_KEYS);
  177.     Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS);
  178.     Tcl_InitHashTable(&iPtr->globalTable, TCL_STRING_KEYS);
  179.     iPtr->numLevels = 0;
  180.     iPtr->maxNestingDepth = 1000;
  181.     iPtr->framePtr = NULL;
  182.     iPtr->varFramePtr = NULL;
  183.     iPtr->activeTracePtr = NULL;
  184.     iPtr->returnCode = TCL_OK;
  185.     iPtr->errorInfo = NULL;
  186.     iPtr->errorCode = NULL;
  187.     iPtr->numEvents = 0;
  188.     iPtr->events = NULL;
  189.     iPtr->curEvent = 0;
  190.     iPtr->curEventNum = 0;
  191.     iPtr->revPtr = NULL;
  192.     iPtr->historyFirst = NULL;
  193.     iPtr->revDisables = 1;
  194.     iPtr->evalFirst = iPtr->evalLast = NULL;
  195.     iPtr->appendResult = NULL;
  196.     iPtr->appendAvl = 0;
  197.     iPtr->appendUsed = 0;
  198.     for (i = 0; i < NUM_REGEXPS; i++) {
  199.     iPtr->patterns[i] = NULL;
  200.     iPtr->patLengths[i] = -1;
  201.     iPtr->regexps[i] = NULL;
  202.     }
  203.     strcpy(iPtr->pdFormat, DEFAULT_PD_FORMAT);
  204.     iPtr->pdPrec = DEFAULT_PD_PREC;
  205.     iPtr->cmdCount = 0;
  206.     iPtr->noEval = 0;
  207.     iPtr->evalFlags = 0;
  208.     iPtr->scriptFile = NULL;
  209.     iPtr->flags = 0;
  210.     iPtr->tracePtr = NULL;
  211.     iPtr->deleteCallbackPtr = NULL;
  212.     iPtr->resultSpace[0] = 0;
  213.  
  214.     /*
  215.      * Create the built-in commands.  Do it here, rather than calling
  216.      * Tcl_CreateCommand, because it's faster (there's no need to
  217.      * check for a pre-existing command by the same name).
  218.      */
  219.  
  220.     for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
  221.     int new;
  222.     Tcl_HashEntry *hPtr;
  223.  
  224.     hPtr = Tcl_CreateHashEntry(&iPtr->commandTable,
  225.         cmdInfoPtr->name, &new);
  226.     if (new) {
  227.         cmdPtr = (Command *) ckalloc(sizeof(Command));
  228.         cmdPtr->hPtr = hPtr;
  229.         cmdPtr->proc = cmdInfoPtr->proc;
  230.         cmdPtr->clientData = (ClientData) NULL;
  231.         cmdPtr->deleteProc = NULL;
  232.         cmdPtr->deleteData = (ClientData) NULL;
  233.         Tcl_SetHashValue(hPtr, cmdPtr);
  234.     }
  235.     }
  236.  
  237. #ifndef TCL_GENERIC_ONLY
  238.     TclSetupEnv((Tcl_Interp *) iPtr);
  239.  
  240.     /*
  241.      * The code below causes SIGPIPE (broken pipe) errors to
  242.      * be ignored.  This is needed so that Tcl processes don't
  243.      * die if they create child processes (e.g. using "exec" or
  244.      * "open") that terminate prematurely.  The signal handler
  245.      * is only set up when the first interpreter is created;
  246.      * after this the application can override the handler with
  247.      * a different one of its own, if it wants.
  248.      */
  249.  
  250.     if (firstInterp) {
  251.     (void) signal(SIGPIPE, SIG_IGN);
  252.     firstInterp = 0;
  253.     }
  254. #endif
  255.  
  256.     /*
  257.      * Set up variables such as tcl_library and tcl_precision.
  258.      */
  259.  
  260.     libDir = getenv("TCL_LIBRARY");
  261.     if (libDir == NULL) {
  262.     libDir = TCL_LIBRARY;
  263.     }
  264.     Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_library", libDir, TCL_GLOBAL_ONLY);
  265.     Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_patchLevel", TCL_PATCH_LEVEL,
  266.         TCL_GLOBAL_ONLY);
  267.     Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_version", TCL_VERSION,
  268.         TCL_GLOBAL_ONLY);
  269.     Tcl_TraceVar2((Tcl_Interp *) iPtr, "tcl_precision", (char *) NULL,
  270.         TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
  271.         TclPrecTraceProc, (ClientData) NULL);
  272.     return (Tcl_Interp *) iPtr;
  273. }
  274.  
  275. /*
  276.  *----------------------------------------------------------------------
  277.  *
  278.  * Tcl_Init --
  279.  *
  280.  *    This procedure is typically invoked by Tcl_AppInit procedures
  281.  *    to perform additional initialization for a Tcl interpreter,
  282.  *    such as sourcing the "init.tcl" script.
  283.  *
  284.  * Results:
  285.  *    Returns a standard Tcl completion code and sets interp->result
  286.  *    if there is an error.
  287.  *
  288.  * Side effects:
  289.  *    Depends on what's in the init.tcl script.
  290.  *
  291.  *----------------------------------------------------------------------
  292.  */
  293.  
  294. int
  295. Tcl_Init(interp)
  296.     Tcl_Interp *interp;        /* Interpreter to initialize. */
  297. {
  298.     static char initCmd[] =
  299.     "if [file exists [info library]/init.tcl] {\n\
  300.         source [info library]/init.tcl\n\
  301.     } else {\n\
  302.         set msg \"can't find [info library]/init.tcl; perhaps you \"\n\
  303.         append msg \"need to\\ninstall Tcl or set your TCL_LIBRARY \"\n\
  304.         append msg \"environment variable?\"\n\
  305.         error $msg\n\
  306.     }";
  307.  
  308.     return Tcl_Eval(interp, initCmd);
  309. }
  310.  
  311. /*
  312.  *--------------------------------------------------------------
  313.  *
  314.  * Tcl_CallWhenDeleted --
  315.  *
  316.  *    Arrange for a procedure to be called before a given
  317.  *    interpreter is deleted.
  318.  *
  319.  * Results:
  320.  *    None.
  321.  *
  322.  * Side effects:
  323.  *    When Tcl_DeleteInterp is invoked to delete interp,
  324.  *    proc will be invoked.  See the manual entry for
  325.  *    details.
  326.  *
  327.  *--------------------------------------------------------------
  328.  */
  329.  
  330. void
  331. Tcl_CallWhenDeleted(interp, proc, clientData)
  332.     Tcl_Interp *interp;        /* Interpreter to watch. */
  333.     Tcl_InterpDeleteProc *proc;    /* Procedure to call when interpreter
  334.                  * is about to be deleted. */
  335.     ClientData clientData;    /* One-word value to pass to proc. */
  336. {
  337.     DeleteCallback *dcPtr, *prevPtr;
  338.     Interp *iPtr = (Interp *) interp;
  339.  
  340.     dcPtr = (DeleteCallback *) ckalloc(sizeof(DeleteCallback));
  341.     dcPtr->proc = proc;
  342.     dcPtr->clientData = clientData;
  343.     dcPtr->nextPtr = NULL;
  344.     if (iPtr->deleteCallbackPtr == NULL) {
  345.     iPtr->deleteCallbackPtr = dcPtr;
  346.     } else {
  347.     prevPtr = iPtr->deleteCallbackPtr;
  348.     while (prevPtr->nextPtr != NULL) {
  349.         prevPtr = prevPtr->nextPtr;
  350.     }
  351.     prevPtr->nextPtr = dcPtr;
  352.     }
  353. }
  354.  
  355. /*
  356.  *--------------------------------------------------------------
  357.  *
  358.  * Tcl_DontCallWhenDeleted --
  359.  *
  360.  *    Cancel the arrangement for a procedure to be called when
  361.  *    a given interpreter is deleted.
  362.  *
  363.  * Results:
  364.  *    None.
  365.  *
  366.  * Side effects:
  367.  *    If proc and clientData were previously registered as a
  368.  *    callback via Tcl_CallWhenDeleted, they are unregistered.
  369.  *    If they weren't previously registered then nothing
  370.  *    happens.
  371.  *
  372.  *--------------------------------------------------------------
  373.  */
  374.  
  375. void
  376. Tcl_DontCallWhenDeleted(interp, proc, clientData)
  377.     Tcl_Interp *interp;        /* Interpreter to watch. */
  378.     Tcl_InterpDeleteProc *proc;    /* Procedure to call when interpreter
  379.                  * is about to be deleted. */
  380.     ClientData clientData;    /* One-word value to pass to proc. */
  381. {
  382.     DeleteCallback *prevPtr, *dcPtr;
  383.     Interp *iPtr = (Interp *) interp;
  384.  
  385.     for (prevPtr = NULL, dcPtr = iPtr->deleteCallbackPtr;
  386.         dcPtr != NULL; prevPtr = dcPtr, dcPtr = dcPtr->nextPtr) {
  387.     if ((dcPtr->proc != proc) || (dcPtr->clientData != clientData)) {
  388.         continue;
  389.     }
  390.     if (prevPtr == NULL) {
  391.         iPtr->deleteCallbackPtr = dcPtr->nextPtr;
  392.     } else {
  393.         prevPtr->nextPtr = dcPtr->nextPtr;
  394.     }
  395.     ckfree((char *) dcPtr);
  396.     break;
  397.     }
  398. }
  399.  
  400. /*
  401.  *----------------------------------------------------------------------
  402.  *
  403.  * Tcl_DeleteInterp --
  404.  *
  405.  *    Delete an interpreter and free up all of the resources associated
  406.  *    with it.
  407.  *
  408.  * Results:
  409.  *    None.
  410.  *
  411.  * Side effects:
  412.  *    The interpreter is destroyed.  The caller should never again
  413.  *    use the interp token.
  414.  *
  415.  *----------------------------------------------------------------------
  416.  */
  417.  
  418. void
  419. Tcl_DeleteInterp(interp)
  420.     Tcl_Interp *interp;        /* Token for command interpreter (returned
  421.                  * by a previous call to Tcl_CreateInterp). */
  422. {
  423.     Interp *iPtr = (Interp *) interp;
  424.     Tcl_HashEntry *hPtr;
  425.     Tcl_HashSearch search;
  426.     register Command *cmdPtr;
  427.     DeleteCallback *dcPtr;
  428.     int i;
  429.  
  430.     /*
  431.      * If the interpreter is in use, delay the deletion until later.
  432.      */
  433.  
  434.     iPtr->flags |= DELETED;
  435.     if (iPtr->numLevels != 0) {
  436.     return;
  437.     }
  438.  
  439.     /*
  440.      * Invoke deletion callbacks.
  441.      */
  442.  
  443.     while (iPtr->deleteCallbackPtr != NULL) {
  444.     dcPtr = iPtr->deleteCallbackPtr;
  445.     iPtr->deleteCallbackPtr = dcPtr->nextPtr;
  446.     (*dcPtr->proc)(dcPtr->clientData, interp);
  447.     ckfree((char *) dcPtr);
  448.     }
  449.  
  450.     /*
  451.      * Free up any remaining resources associated with the
  452.      * interpreter.
  453.      */
  454.  
  455.     for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
  456.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  457.     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  458.     if (cmdPtr->deleteProc != NULL) {
  459.         (*cmdPtr->deleteProc)(cmdPtr->deleteData);
  460.     }
  461.     ckfree((char *) cmdPtr);
  462.     }
  463.     Tcl_DeleteHashTable(&iPtr->commandTable);
  464.     for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &search);
  465.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  466.     ckfree((char *) Tcl_GetHashValue(hPtr));
  467.     }
  468.     Tcl_DeleteHashTable(&iPtr->mathFuncTable);
  469.     TclDeleteVars(iPtr, &iPtr->globalTable);
  470.  
  471.     /*
  472.      * Free up the result *after* deleting variables, since variable
  473.      * deletion could have transferred ownership of the result string
  474.      * to Tcl.
  475.      */
  476.  
  477.     Tcl_FreeResult(interp);
  478.     if (iPtr->errorInfo != NULL) {
  479.     ckfree(iPtr->errorInfo);
  480.     }
  481.     if (iPtr->errorCode != NULL) {
  482.     ckfree(iPtr->errorCode);
  483.     }
  484.     if (iPtr->events != NULL) {
  485.     int i;
  486.  
  487.     for (i = 0; i < iPtr->numEvents; i++) {
  488.         ckfree(iPtr->events[i].command);
  489.     }
  490.     ckfree((char *) iPtr->events);
  491.     }
  492.     while (iPtr->revPtr != NULL) {
  493.     HistoryRev *nextPtr = iPtr->revPtr->nextPtr;
  494.  
  495.     ckfree(iPtr->revPtr->newBytes);
  496.     ckfree((char *) iPtr->revPtr);
  497.     iPtr->revPtr = nextPtr;
  498.     }
  499.     if (iPtr->appendResult != NULL) {
  500.     ckfree(iPtr->appendResult);
  501.     }
  502.     for (i = 0; i < NUM_REGEXPS; i++) {
  503.     if (iPtr->patterns[i] == NULL) {
  504.         break;
  505.     }
  506.     ckfree(iPtr->patterns[i]);
  507.     ckfree((char *) iPtr->regexps[i]);
  508.     }
  509.     while (iPtr->tracePtr != NULL) {
  510.     Trace *nextPtr = iPtr->tracePtr->nextPtr;
  511.  
  512.     ckfree((char *) iPtr->tracePtr);
  513.     iPtr->tracePtr = nextPtr;
  514.     }
  515.     ckfree((char *) iPtr);
  516. }
  517.  
  518. /*
  519.  *----------------------------------------------------------------------
  520.  *
  521.  * Tcl_CreateCommand --
  522.  *
  523.  *    Define a new command in a command table.
  524.  *
  525.  * Results:
  526.  *    The return value is a token for the command, which can
  527.  *    be used in future calls to Tcl_NameOfCommand.
  528.  *
  529.  * Side effects:
  530.  *    If a command named cmdName already exists for interp, it is
  531.  *    deleted.  In the future, when cmdName is seen as the name of
  532.  *    a command by Tcl_Eval, proc will be called.  When the command
  533.  *    is deleted from the table, deleteProc will be called.  See the
  534.  *    manual entry for details on the calling sequence.
  535.  *
  536.  *----------------------------------------------------------------------
  537.  */
  538.  
  539. Tcl_Command
  540. Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
  541.     Tcl_Interp *interp;        /* Token for command interpreter (returned
  542.                  * by a previous call to Tcl_CreateInterp). */
  543.     char *cmdName;        /* Name of command. */
  544.     Tcl_CmdProc *proc;        /* Command procedure to associate with
  545.                  * cmdName. */
  546.     ClientData clientData;    /* Arbitrary one-word value to pass to proc. */
  547.     Tcl_CmdDeleteProc *deleteProc;
  548.                 /* If not NULL, gives a procedure to call when
  549.                  * this command is deleted. */
  550. {
  551.     Interp *iPtr = (Interp *) interp;
  552.     register Command *cmdPtr;
  553.     Tcl_HashEntry *hPtr;
  554.     int new;
  555.  
  556.     hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, cmdName, &new);
  557.     if (!new) {
  558.     /*
  559.      * Command already exists:  delete the old one.
  560.      */
  561.  
  562.     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  563.     if (cmdPtr->deleteProc != NULL) {
  564.         (*cmdPtr->deleteProc)(cmdPtr->deleteData);
  565.     }
  566.     } else {
  567.     cmdPtr = (Command *) ckalloc(sizeof(Command));
  568.     Tcl_SetHashValue(hPtr, cmdPtr);
  569.     }
  570.     cmdPtr->hPtr = hPtr;
  571.     cmdPtr->proc = proc;
  572.     cmdPtr->clientData = clientData;
  573.     cmdPtr->deleteProc = deleteProc;
  574.     cmdPtr->deleteData = clientData;
  575.     return (Tcl_Command) cmdPtr;
  576. }
  577.  
  578. /*
  579.  *----------------------------------------------------------------------
  580.  *
  581.  * Tcl_SetCommandInfo --
  582.  *
  583.  *    Modifies various information about a Tcl command.
  584.  *
  585.  * Results:
  586.  *    If cmdName exists in interp, then the information at *infoPtr
  587.  *    is stored with the command in place of the current information
  588.  *    and 1 is returned.  If the command doesn't exist then 0 is
  589.  *    returned.
  590.  *
  591.  * Side effects:
  592.  *    None.
  593.  *
  594.  *----------------------------------------------------------------------
  595.  */
  596.  
  597. int
  598. Tcl_SetCommandInfo(interp, cmdName, infoPtr)
  599.     Tcl_Interp *interp;            /* Interpreter in which to look
  600.                      * for command. */
  601.     char *cmdName;            /* Name of desired command. */
  602.     Tcl_CmdInfo *infoPtr;        /* Where to store information about
  603.                      * command. */
  604. {
  605.     Tcl_HashEntry *hPtr;
  606.     Command *cmdPtr;
  607.  
  608.     hPtr = Tcl_FindHashEntry(&((Interp *) interp)->commandTable, cmdName);
  609.     if (hPtr == NULL) {
  610.     return 0;
  611.     }
  612.     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  613.     cmdPtr->proc = infoPtr->proc;
  614.     cmdPtr->clientData = infoPtr->clientData;
  615.     cmdPtr->deleteProc = infoPtr->deleteProc;
  616.     cmdPtr->deleteData = infoPtr->deleteData;
  617.     return 1;
  618. }
  619.  
  620. /*
  621.  *----------------------------------------------------------------------
  622.  *
  623.  * Tcl_GetCommandInfo --
  624.  *
  625.  *    Returns various information about a Tcl command.
  626.  *
  627.  * Results:
  628.  *    If cmdName exists in interp, then *infoPtr is modified to
  629.  *    hold information about cmdName and 1 is returned.  If the
  630.  *    command doesn't exist then 0 is returned and *infoPtr isn't
  631.  *    modified.
  632.  *
  633.  * Side effects:
  634.  *    None.
  635.  *
  636.  *----------------------------------------------------------------------
  637.  */
  638.  
  639. int
  640. Tcl_GetCommandInfo(interp, cmdName, infoPtr)
  641.     Tcl_Interp *interp;            /* Interpreter in which to look
  642.                      * for command. */
  643.     char *cmdName;            /* Name of desired command. */
  644.     Tcl_CmdInfo *infoPtr;        /* Where to store information about
  645.                      * command. */
  646. {
  647.     Tcl_HashEntry *hPtr;
  648.     Command *cmdPtr;
  649.  
  650.     hPtr = Tcl_FindHashEntry(&((Interp *) interp)->commandTable, cmdName);
  651.     if (hPtr == NULL) {
  652.     return 0;
  653.     }
  654.     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  655.     infoPtr->proc = cmdPtr->proc;
  656.     infoPtr->clientData = cmdPtr->clientData;
  657.     infoPtr->deleteProc = cmdPtr->deleteProc;
  658.     infoPtr->deleteData = cmdPtr->deleteData;
  659.     return 1;
  660. }
  661.  
  662. /*
  663.  *----------------------------------------------------------------------
  664.  *
  665.  * Tcl_GetCommandName --
  666.  *
  667.  *    Given a token returned by Tcl_CreateCommand, this procedure
  668.  *    returns the current name of the command (which may have changed
  669.  *    due to renaming).
  670.  *
  671.  * Results:
  672.  *    The return value is the name of the given command.
  673.  *
  674.  * Side effects:
  675.  *    None.
  676.  *
  677.  *----------------------------------------------------------------------
  678.  */
  679.  
  680. char *
  681. Tcl_GetCommandName(interp, command)
  682.     Tcl_Interp *interp;        /* Interpreter containing the command. */
  683.     Tcl_Command command;    /* Token for the command, returned by a
  684.                  * previous call to Tcl_CreateCommand.
  685.                  * The command must not have been deleted. */
  686. {
  687.     Command *cmdPtr = (Command *) command;
  688.     Interp *iPtr = (Interp *) interp;
  689.  
  690.     return Tcl_GetHashKey(&iPtr->commandTable, cmdPtr->hPtr);
  691. }
  692.  
  693. /*
  694.  *----------------------------------------------------------------------
  695.  *
  696.  * Tcl_DeleteCommand --
  697.  *
  698.  *    Remove the given command from the given interpreter.
  699.  *
  700.  * Results:
  701.  *    0 is returned if the command was deleted successfully.
  702.  *    -1 is returned if there didn't exist a command by that
  703.  *    name.
  704.  *
  705.  * Side effects:
  706.  *    CmdName will no longer be recognized as a valid command for
  707.  *    interp.
  708.  *
  709.  *----------------------------------------------------------------------
  710.  */
  711.  
  712. int
  713. Tcl_DeleteCommand(interp, cmdName)
  714.     Tcl_Interp *interp;        /* Token for command interpreter (returned
  715.                  * by a previous call to Tcl_CreateInterp). */
  716.     char *cmdName;        /* Name of command to remove. */
  717. {
  718.     Interp *iPtr = (Interp *) interp;
  719.     Tcl_HashEntry *hPtr;
  720.     Command *cmdPtr;
  721.  
  722.     hPtr = Tcl_FindHashEntry(&iPtr->commandTable, cmdName);
  723.     if (hPtr == NULL) {
  724.     return -1;
  725.     }
  726.     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  727.     if (cmdPtr->deleteProc != NULL) {
  728.     (*cmdPtr->deleteProc)(cmdPtr->deleteData);
  729.     }
  730.     ckfree((char *) cmdPtr);
  731.     Tcl_DeleteHashEntry(hPtr);
  732.     return 0;
  733. }
  734.  
  735. /*
  736.  *-----------------------------------------------------------------
  737.  *
  738.  * Tcl_Eval --
  739.  *
  740.  *    Parse and execute a command in the Tcl language.
  741.  *
  742.  * Results:
  743.  *    The return value is one of the return codes defined in tcl.hd
  744.  *    (such as TCL_OK), and interp->result contains a string value
  745.  *    to supplement the return code.  The value of interp->result
  746.  *    will persist only until the next call to Tcl_Eval:  copy it or
  747.  *    lose it! *TermPtr is filled in with the character just after
  748.  *    the last one that was part of the command (usually a NULL
  749.  *    character or a closing bracket).
  750.  *
  751.  * Side effects:
  752.  *    Almost certainly;  depends on the command.
  753.  *
  754.  *-----------------------------------------------------------------
  755.  */
  756.  
  757. int
  758. Tcl_Eval(interp, cmd)
  759.     Tcl_Interp *interp;        /* Token for command interpreter (returned
  760.                  * by a previous call to Tcl_CreateInterp). */
  761.     char *cmd;            /* Pointer to TCL command to interpret. */
  762. {
  763.     /*
  764.      * The storage immediately below is used to generate a copy
  765.      * of the command, after all argument substitutions.  Pv will
  766.      * contain the argv values passed to the command procedure.
  767.      */
  768.  
  769. #   define NUM_CHARS 200
  770.     char copyStorage[NUM_CHARS];
  771.     ParseValue pv;
  772.     char *oldBuffer;
  773.  
  774.     /*
  775.      * This procedure generates an (argv, argc) array for the command,
  776.      * It starts out with stack-allocated space but uses dynamically-
  777.      * allocated storage to increase it if needed.
  778.      */
  779.  
  780. #   define NUM_ARGS 10
  781.     char *(argStorage[NUM_ARGS]);
  782.     char **argv = argStorage;
  783.     int argc;
  784.     int argSize = NUM_ARGS;
  785.  
  786.     register char *src;            /* Points to current character
  787.                      * in cmd. */
  788.     char termChar;            /* Return when this character is found
  789.                      * (either ']' or '\0').  Zero means
  790.                      * that newlines terminate commands. */
  791.     int flags;                /* Interp->evalFlags value when the
  792.                      * procedure was called. */
  793.     int result;                /* Return value. */
  794.     register Interp *iPtr = (Interp *) interp;
  795.     Tcl_HashEntry *hPtr;
  796.     Command *cmdPtr;
  797.     char *termPtr;            /* Contains character just after the
  798.                      * last one in the command. */
  799.     char *cmdStart;            /* Points to first non-blank char. in
  800.                      * command (used in calling trace
  801.                      * procedures). */
  802.     char *ellipsis = "";        /* Used in setting errorInfo variable;
  803.                      * set to "..." to indicate that not
  804.                      * all of offending command is included
  805.                      * in errorInfo.  "" means that the
  806.                      * command is all there. */
  807.     register Trace *tracePtr;
  808.     int oldCount = iPtr->cmdCount;    /* Used to tell whether any commands
  809.                      * at all were executed. */
  810.  
  811.     /*
  812.      * Initialize the result to an empty string and clear out any
  813.      * error information.  This makes sure that we return an empty
  814.      * result if there are no commands in the command string.
  815.      */
  816.  
  817.     Tcl_FreeResult((Tcl_Interp *) iPtr);
  818.     iPtr->result = iPtr->resultSpace;
  819.     iPtr->resultSpace[0] = 0;
  820.     result = TCL_OK;
  821.  
  822.     /*
  823.      * Initialize the area in which command copies will be assembled.
  824.      */
  825.  
  826.     pv.buffer = copyStorage;
  827.     pv.end = copyStorage + NUM_CHARS - 1;
  828.     pv.expandProc = TclExpandParseValue;
  829.     pv.clientData = (ClientData) NULL;
  830.  
  831.     src = cmd;
  832.     flags = iPtr->evalFlags;
  833.     iPtr->evalFlags = 0;
  834.     if (flags & TCL_BRACKET_TERM) {
  835.     termChar = ']';
  836.     } else {
  837.     termChar = 0;
  838.     }
  839.     termPtr = src;
  840.     cmdStart = src;
  841.  
  842.     /*
  843.      * Check depth of nested calls to Tcl_Eval:  if this gets too large,
  844.      * it's probably because of an infinite loop somewhere.
  845.      */
  846.  
  847.     iPtr->numLevels++;
  848.     if (iPtr->numLevels > iPtr->maxNestingDepth) {
  849.     iPtr->numLevels--;
  850.     iPtr->result =  "too many nested calls to Tcl_Eval (infinite loop?)";
  851.     iPtr->termPtr = termPtr;
  852.     return TCL_ERROR;
  853.     }
  854.  
  855.     /*
  856.      * There can be many sub-commands (separated by semi-colons or
  857.      * newlines) in one command string.  This outer loop iterates over
  858.      * individual commands.
  859.      */
  860.  
  861.     while (*src != termChar) {
  862.     iPtr->flags &= ~(ERR_IN_PROGRESS | ERROR_CODE_SET);
  863.  
  864.     /*
  865.      * Skim off leading white space and semi-colons, and skip
  866.      * comments.
  867.      */
  868.  
  869.     while (1) {
  870.         register char c = *src;
  871.  
  872.         if ((CHAR_TYPE(c) != TCL_SPACE) && (c != ';') && (c != '\n')) {
  873.         break;
  874.         }
  875.         src += 1;
  876.     }
  877.     if (*src == '#') {
  878.         for (src++; *src != 0; src++) {
  879.         if ((*src == '\n') && (src[-1] != '\\')) {
  880.             src++;
  881.             termPtr = src;
  882.             break;
  883.         }
  884.         }
  885.         continue;
  886.     }
  887.     cmdStart = src;
  888.  
  889.     /*
  890.      * Parse the words of the command, generating the argc and
  891.      * argv for the command procedure.  May have to call
  892.      * TclParseWords several times, expanding the argv array
  893.      * between calls.
  894.      */
  895.  
  896.     pv.next = oldBuffer = pv.buffer;
  897.     argc = 0;
  898.     while (1) {
  899.         int newArgs, maxArgs;
  900.         char **newArgv;
  901.         int i;
  902.  
  903.         /*
  904.          * Note:  the "- 2" below guarantees that we won't use the
  905.          * last two argv slots here.  One is for a NULL pointer to
  906.          * mark the end of the list, and the other is to leave room
  907.          * for inserting the command name "unknown" as the first
  908.          * argument (see below).
  909.          */
  910.  
  911.         maxArgs = argSize - argc - 2;
  912.         result = TclParseWords((Tcl_Interp *) iPtr, src, flags,
  913.             maxArgs, &termPtr, &newArgs, &argv[argc], &pv);
  914.         src = termPtr;
  915.         if (result != TCL_OK) {
  916.         ellipsis = "...";
  917.         goto done;
  918.         }
  919.  
  920.         /*
  921.          * Careful!  Buffer space may have gotten reallocated while
  922.          * parsing words.  If this happened, be sure to update all
  923.          * of the older argv pointers to refer to the new space.
  924.          */
  925.  
  926.         if (oldBuffer != pv.buffer) {
  927.         int i;
  928.  
  929.         for (i = 0; i < argc; i++) {
  930.             argv[i] = pv.buffer + (argv[i] - oldBuffer);
  931.         }
  932.         oldBuffer = pv.buffer;
  933.         }
  934.         argc += newArgs;
  935.         if (newArgs < maxArgs) {
  936.         argv[argc] = (char *) NULL;
  937.         break;
  938.         }
  939.  
  940.         /*
  941.          * Args didn't all fit in the current array.  Make it bigger.
  942.          */
  943.  
  944.         argSize *= 2;
  945.         newArgv = (char **)
  946.             ckalloc((unsigned) argSize * sizeof(char *));
  947.         for (i = 0; i < argc; i++) {
  948.         newArgv[i] = argv[i];
  949.         }
  950.         if (argv != argStorage) {
  951.         ckfree((char *) argv);
  952.         }
  953.         argv = newArgv;
  954.     }
  955.  
  956.     /*
  957.      * If this is an empty command (or if we're just parsing
  958.      * commands without evaluating them), then just skip to the
  959.      * next command.
  960.      */
  961.  
  962.     if ((argc == 0) || iPtr->noEval) {
  963.         continue;
  964.     }
  965.     argv[argc] = NULL;
  966.  
  967.     /*
  968.      * Save information for the history module, if needed.
  969.      */
  970.  
  971.     if (flags & TCL_RECORD_BOUNDS) {
  972.         iPtr->evalFirst = cmdStart;
  973.         iPtr->evalLast = src-1;
  974.     }
  975.  
  976.     /*
  977.      * Find the procedure to execute this command.  If there isn't
  978.      * one, then see if there is a command "unknown".  If so,
  979.      * invoke it instead, passing it the words of the original
  980.      * command as arguments.
  981.      */
  982.  
  983.     hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[0]);
  984.     if (hPtr == NULL) {
  985.         int i;
  986.  
  987.         hPtr = Tcl_FindHashEntry(&iPtr->commandTable, "unknown");
  988.         if (hPtr == NULL) {
  989.         Tcl_ResetResult(interp);
  990.         Tcl_AppendResult(interp, "invalid command name \"",
  991.             argv[0], "\"", (char *) NULL);
  992.         result = TCL_ERROR;
  993.         goto done;
  994.         }
  995.         for (i = argc; i >= 0; i--) {
  996.         argv[i+1] = argv[i];
  997.         }
  998.         argv[0] = "unknown";
  999.         argc++;
  1000.     }
  1001.     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  1002.  
  1003.     /*
  1004.      * Call trace procedures, if any.
  1005.      */
  1006.  
  1007.     for (tracePtr = iPtr->tracePtr; tracePtr != NULL;
  1008.         tracePtr = tracePtr->nextPtr) {
  1009.         char saved;
  1010.  
  1011.         if (tracePtr->level < iPtr->numLevels) {
  1012.         continue;
  1013.         }
  1014.         saved = *src;
  1015.         *src = 0;
  1016.         (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels,
  1017.             cmdStart, cmdPtr->proc, cmdPtr->clientData, argc, argv);
  1018.         *src = saved;
  1019.     }
  1020.  
  1021.     /*
  1022.      * At long last, invoke the command procedure.  Reset the
  1023.      * result to its default empty value first (it could have
  1024.      * gotten changed by earlier commands in the same command
  1025.      * string).
  1026.      */
  1027.  
  1028.     iPtr->cmdCount++;
  1029.     Tcl_FreeResult(iPtr);
  1030.     iPtr->result = iPtr->resultSpace;
  1031.     iPtr->resultSpace[0] = 0;
  1032.     result = (*cmdPtr->proc)(cmdPtr->clientData, interp, argc, argv);
  1033.     if (tcl_AsyncReady) {
  1034.         result = Tcl_AsyncInvoke(interp, result);
  1035.     }
  1036.     if (result != TCL_OK) {
  1037.         break;
  1038.     }
  1039.     }
  1040.  
  1041.     done:
  1042.  
  1043.     /*
  1044.      * If no commands at all were executed, check for asynchronous
  1045.      * handlers so that they at least get one change to execute.
  1046.      * This is needed to handle event loops written in Tcl with
  1047.      * empty bodies (I'm not sure that loops like this are a good
  1048.      * idea, * but...).
  1049.      */
  1050.  
  1051.     if ((oldCount == iPtr->cmdCount) && (tcl_AsyncReady)) {
  1052.     result = Tcl_AsyncInvoke(interp, result);
  1053.     }
  1054.  
  1055.     /*
  1056.      * Free up any extra resources that were allocated.
  1057.      */
  1058.  
  1059.     if (pv.buffer != copyStorage) {
  1060.     ckfree((char *) pv.buffer);
  1061.     }
  1062.     if (argv != argStorage) {
  1063.     ckfree((char *) argv);
  1064.     }
  1065.     iPtr->numLevels--;
  1066.     if (iPtr->numLevels == 0) {
  1067.     if (result == TCL_RETURN) {
  1068.         result = TclUpdateReturnInfo(iPtr);
  1069.     }
  1070.     if ((result != TCL_OK) && (result != TCL_ERROR)
  1071.         && !(flags & TCL_ALLOW_EXCEPTIONS)) {
  1072.         Tcl_ResetResult(interp);
  1073.         if (result == TCL_BREAK) {
  1074.         iPtr->result = "invoked \"break\" outside of a loop";
  1075.         } else if (result == TCL_CONTINUE) {
  1076.         iPtr->result = "invoked \"continue\" outside of a loop";
  1077.         } else {
  1078.         iPtr->result = iPtr->resultSpace;
  1079.         sprintf(iPtr->resultSpace, "command returned bad code: %d",
  1080.             result);
  1081.         }
  1082.         result = TCL_ERROR;
  1083.     }
  1084.     if (iPtr->flags & DELETED) {
  1085.         /*
  1086.          * Someone tried to delete the interpreter, but it couldn't
  1087.          * actually be deleted because commands were in the middle of
  1088.          * being evaluated.  Delete the interpreter now.  Also, return
  1089.          * immediately:  we can't execute the remaining code in the
  1090.          * procedure because it accesses fields of the dead interpreter.
  1091.          */
  1092.  
  1093.         Tcl_DeleteInterp(interp);
  1094.         return result;
  1095.     }
  1096.     }
  1097.  
  1098.     /*
  1099.      * If an error occurred, record information about what was being
  1100.      * executed when the error occurred.
  1101.      */
  1102.  
  1103.     if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
  1104.     int numChars;
  1105.     register char *p;
  1106.  
  1107.     /*
  1108.      * Compute the line number where the error occurred.
  1109.      */
  1110.  
  1111.     iPtr->errorLine = 1;
  1112.     for (p = cmd; p != cmdStart; p++) {
  1113.         if (*p == '\n') {
  1114.         iPtr->errorLine++;
  1115.         }
  1116.     }
  1117.     for ( ; isspace(UCHAR(*p)) || (*p == ';'); p++) {
  1118.         if (*p == '\n') {
  1119.         iPtr->errorLine++;
  1120.         }
  1121.     }
  1122.  
  1123.     /*
  1124.      * Figure out how much of the command to print in the error
  1125.      * message (up to a certain number of characters, or up to
  1126.      * the first new-line).
  1127.      */
  1128.  
  1129.     numChars = src - cmdStart;
  1130.     if (numChars > (NUM_CHARS-50)) {
  1131.         numChars = NUM_CHARS-50;
  1132.         ellipsis = " ...";
  1133.     }
  1134.  
  1135.     if (!(iPtr->flags & ERR_IN_PROGRESS)) {
  1136.         sprintf(copyStorage, "\n    while executing\n\"%.*s%s\"",
  1137.             numChars, cmdStart, ellipsis);
  1138.     } else {
  1139.         sprintf(copyStorage, "\n    invoked from within\n\"%.*s%s\"",
  1140.             numChars, cmdStart, ellipsis);
  1141.     }
  1142.     Tcl_AddErrorInfo(interp, copyStorage);
  1143.     iPtr->flags &= ~ERR_ALREADY_LOGGED;
  1144.     } else {
  1145.     iPtr->flags &= ~ERR_ALREADY_LOGGED;
  1146.     }
  1147.     iPtr->termPtr = termPtr;
  1148.     return result;
  1149. }
  1150.  
  1151. /*
  1152.  *----------------------------------------------------------------------
  1153.  *
  1154.  * Tcl_CreateTrace --
  1155.  *
  1156.  *    Arrange for a procedure to be called to trace command execution.
  1157.  *
  1158.  * Results:
  1159.  *    The return value is a token for the trace, which may be passed
  1160.  *    to Tcl_DeleteTrace to eliminate the trace.
  1161.  *
  1162.  * Side effects:
  1163.  *    From now on, proc will be called just before a command procedure
  1164.  *    is called to execute a Tcl command.  Calls to proc will have the
  1165.  *    following form:
  1166.  *
  1167.  *    void
  1168.  *    proc(clientData, interp, level, command, cmdProc, cmdClientData,
  1169.  *        argc, argv)
  1170.  *        ClientData clientData;
  1171.  *        Tcl_Interp *interp;
  1172.  *        int level;
  1173.  *        char *command;
  1174.  *        int (*cmdProc)();
  1175.  *        ClientData cmdClientData;
  1176.  *        int argc;
  1177.  *        char **argv;
  1178.  *    {
  1179.  *    }
  1180.  *
  1181.  *    The clientData and interp arguments to proc will be the same
  1182.  *    as the corresponding arguments to this procedure.  Level gives
  1183.  *    the nesting level of command interpretation for this interpreter
  1184.  *    (0 corresponds to top level).  Command gives the ASCII text of
  1185.  *    the raw command, cmdProc and cmdClientData give the procedure that
  1186.  *    will be called to process the command and the ClientData value it
  1187.  *    will receive, and argc and argv give the arguments to the
  1188.  *    command, after any argument parsing and substitution.  Proc
  1189.  *    does not return a value.
  1190.  *
  1191.  *----------------------------------------------------------------------
  1192.  */
  1193.  
  1194. Tcl_Trace
  1195. Tcl_CreateTrace(interp, level, proc, clientData)
  1196.     Tcl_Interp *interp;        /* Interpreter in which to create the trace. */
  1197.     int level;            /* Only call proc for commands at nesting level
  1198.                  * <= level (1 => top level). */
  1199.     Tcl_CmdTraceProc *proc;    /* Procedure to call before executing each
  1200.                  * command. */
  1201.     ClientData clientData;    /* Arbitrary one-word value to pass to proc. */
  1202. {
  1203.     register Trace *tracePtr;
  1204.     register Interp *iPtr = (Interp *) interp;
  1205.  
  1206.     tracePtr = (Trace *) ckalloc(sizeof(Trace));
  1207.     tracePtr->level = level;
  1208.     tracePtr->proc = proc;
  1209.     tracePtr->clientData = clientData;
  1210.     tracePtr->nextPtr = iPtr->tracePtr;
  1211.     iPtr->tracePtr = tracePtr;
  1212.  
  1213.     return (Tcl_Trace) tracePtr;
  1214. }
  1215.  
  1216. /*
  1217.  *----------------------------------------------------------------------
  1218.  *
  1219.  * Tcl_DeleteTrace --
  1220.  *
  1221.  *    Remove a trace.
  1222.  *
  1223.  * Results:
  1224.  *    None.
  1225.  *
  1226.  * Side effects:
  1227.  *    From now on there will be no more calls to the procedure given
  1228.  *    in trace.
  1229.  *
  1230.  *----------------------------------------------------------------------
  1231.  */
  1232.  
  1233. void
  1234. Tcl_DeleteTrace(interp, trace)
  1235.     Tcl_Interp *interp;        /* Interpreter that contains trace. */
  1236.     Tcl_Trace trace;        /* Token for trace (returned previously by
  1237.                  * Tcl_CreateTrace). */
  1238. {
  1239.     register Interp *iPtr = (Interp *) interp;
  1240.     register Trace *tracePtr = (Trace *) trace;
  1241.     register Trace *tracePtr2;
  1242.  
  1243.     if (iPtr->tracePtr == tracePtr) {
  1244.     iPtr->tracePtr = tracePtr->nextPtr;
  1245.     ckfree((char *) tracePtr);
  1246.     } else {
  1247.     for (tracePtr2 = iPtr->tracePtr; tracePtr2 != NULL;
  1248.         tracePtr2 = tracePtr2->nextPtr) {
  1249.         if (tracePtr2->nextPtr == tracePtr) {
  1250.         tracePtr2->nextPtr = tracePtr->nextPtr;
  1251.         ckfree((char *) tracePtr);
  1252.         return;
  1253.         }
  1254.     }
  1255.     }
  1256. }
  1257.  
  1258. /*
  1259.  *----------------------------------------------------------------------
  1260.  *
  1261.  * Tcl_AddErrorInfo --
  1262.  *
  1263.  *    Add information to a message being accumulated that describes
  1264.  *    the current error.
  1265.  *
  1266.  * Results:
  1267.  *    None.
  1268.  *
  1269.  * Side effects:
  1270.  *    The contents of message are added to the "errorInfo" variable.
  1271.  *    If Tcl_Eval has been called since the current value of errorInfo
  1272.  *    was set, errorInfo is cleared before adding the new message.
  1273.  *
  1274.  *----------------------------------------------------------------------
  1275.  */
  1276.  
  1277. void
  1278. Tcl_AddErrorInfo(interp, message)
  1279.     Tcl_Interp *interp;        /* Interpreter to which error information
  1280.                  * pertains. */
  1281.     char *message;        /* Message to record. */
  1282. {
  1283.     register Interp *iPtr = (Interp *) interp;
  1284.  
  1285.     /*
  1286.      * If an error is already being logged, then the new errorInfo
  1287.      * is the concatenation of the old info and the new message.
  1288.      * If this is the first piece of info for the error, then the
  1289.      * new errorInfo is the concatenation of the message in
  1290.      * interp->result and the new message.
  1291.      */
  1292.  
  1293.     if (!(iPtr->flags & ERR_IN_PROGRESS)) {
  1294.     Tcl_SetVar2(interp, "errorInfo", (char *) NULL, interp->result,
  1295.         TCL_GLOBAL_ONLY);
  1296.     iPtr->flags |= ERR_IN_PROGRESS;
  1297.  
  1298.     /*
  1299.      * If the errorCode variable wasn't set by the code that generated
  1300.      * the error, set it to "NONE".
  1301.      */
  1302.  
  1303.     if (!(iPtr->flags & ERROR_CODE_SET)) {
  1304.         (void) Tcl_SetVar2(interp, "errorCode", (char *) NULL, "NONE",
  1305.             TCL_GLOBAL_ONLY);
  1306.     }
  1307.     }
  1308.     Tcl_SetVar2(interp, "errorInfo", (char *) NULL, message,
  1309.         TCL_GLOBAL_ONLY|TCL_APPEND_VALUE);
  1310. }
  1311.  
  1312. /*
  1313.  *----------------------------------------------------------------------
  1314.  *
  1315.  * Tcl_VarEval --
  1316.  *
  1317.  *    Given a variable number of string arguments, concatenate them
  1318.  *    all together and execute the result as a Tcl command.
  1319.  *
  1320.  * Results:
  1321.  *    A standard Tcl return result.  An error message or other
  1322.  *    result may be left in interp->result.
  1323.  *
  1324.  * Side effects:
  1325.  *    Depends on what was done by the command.
  1326.  *
  1327.  *----------------------------------------------------------------------
  1328.  */
  1329.     /* VARARGS2 */ /* ARGSUSED */
  1330. int
  1331. #ifndef lint
  1332. Tcl_VarEval(va_alist)
  1333. #else
  1334. Tcl_VarEval(Tcl_Interp *iPtr,...) /* stdarg for RISCOS */
  1335. #endif
  1336. {
  1337.     va_list argList;
  1338.     Tcl_DString buf;
  1339.     char *string;
  1340.     Tcl_Interp *interp;
  1341.     int result;
  1342.  
  1343.     /*
  1344.      * Copy the strings one after the other into a single larger
  1345.      * string.  Use stack-allocated space for small commands, but if
  1346.      * the command gets too large than call ckalloc to create the
  1347.      * space.
  1348.      */
  1349.  
  1350.     interp=iPtr;            /* stdarg for RISCOS */
  1351.     va_start(argList,iPtr);
  1352.     Tcl_DStringInit(&buf);
  1353.     while (1) {
  1354.     string = va_arg(argList, char *);
  1355.     if (string == NULL) {
  1356.         break;
  1357.     }
  1358.     Tcl_DStringAppend(&buf, string, -1);
  1359.     }
  1360.     va_end(argList);
  1361.  
  1362.     result = Tcl_Eval(interp, Tcl_DStringValue(&buf));
  1363.     Tcl_DStringFree(&buf);
  1364.     return result;
  1365. }
  1366.  
  1367. /*
  1368.  *----------------------------------------------------------------------
  1369.  *
  1370.  * Tcl_GlobalEval --
  1371.  *
  1372.  *    Evaluate a command at global level in an interpreter.
  1373.  *
  1374.  * Results:
  1375.  *    A standard Tcl result is returned, and interp->result is
  1376.  *    modified accordingly.
  1377.  *
  1378.  * Side effects:
  1379.  *    The command string is executed in interp, and the execution
  1380.  *    is carried out in the variable context of global level (no
  1381.  *    procedures active), just as if an "uplevel #0" command were
  1382.  *    being executed.
  1383.  *
  1384.  *----------------------------------------------------------------------
  1385.  */
  1386.  
  1387. int
  1388. Tcl_GlobalEval(interp, command)
  1389.     Tcl_Interp *interp;        /* Interpreter in which to evaluate command. */
  1390.     char *command;        /* Command to evaluate. */
  1391. {
  1392.     register Interp *iPtr = (Interp *) interp;
  1393.     int result;
  1394.     CallFrame *savedVarFramePtr;
  1395.  
  1396.     savedVarFramePtr = iPtr->varFramePtr;
  1397.     iPtr->varFramePtr = NULL;
  1398.     result = Tcl_Eval(interp, command);
  1399.     iPtr->varFramePtr = savedVarFramePtr;
  1400.     return result;
  1401. }
  1402.  
  1403. /*
  1404.  *----------------------------------------------------------------------
  1405.  *
  1406.  * Tcl_SetRecursionLimit --
  1407.  *
  1408.  *    Set the maximum number of recursive calls that may be active
  1409.  *    for an interpreter at once.
  1410.  *
  1411.  * Results:
  1412.  *    The return value is the old limit on nesting for interp.
  1413.  *
  1414.  * Side effects:
  1415.  *    None.
  1416.  *
  1417.  *----------------------------------------------------------------------
  1418.  */
  1419.  
  1420. int
  1421. Tcl_SetRecursionLimit(interp, depth)
  1422.     Tcl_Interp *interp;            /* Interpreter whose nesting limit
  1423.                      * is to be set. */
  1424.     int depth;                /* New value for maximimum depth. */
  1425. {
  1426.     Interp *iPtr = (Interp *) interp;
  1427.     int old;
  1428.  
  1429.     old = iPtr->maxNestingDepth;
  1430.     if (depth > 0) {
  1431.     iPtr->maxNestingDepth = depth;
  1432.     }
  1433.     return old;
  1434. }
  1435.  
  1436. /*
  1437.  *----------------------------------------------------------------------
  1438.  *
  1439.  * Tcl_AllowExceptions --
  1440.  *
  1441.  *    Sets a flag in an interpreter so that exceptions can occur
  1442.  *    in the next call to Tcl_Eval without them being turned into
  1443.  *    errors.
  1444.  *
  1445.  * Results:
  1446.  *    None.
  1447.  *
  1448.  * Side effects:
  1449.  *    The TCL_ALLOW_EXCEPTIONS flag gets set in the interpreter's
  1450.  *    evalFlags structure.  See the reference documentation for
  1451.  *    more details.
  1452.  *
  1453.  *----------------------------------------------------------------------
  1454.  */
  1455.  
  1456. void
  1457. Tcl_AllowExceptions(interp)
  1458.     Tcl_Interp *interp;        /* Interpreter in which to set flag. */
  1459. {
  1460.     Interp *iPtr = (Interp *) interp;
  1461.  
  1462.     iPtr->evalFlags |= TCL_ALLOW_EXCEPTIONS;
  1463. }
  1464.