Usenet 1994 January/usenetsourcesnewsgroupsinfomagicjanuary1994.iso/sources/misc/volume25/tcl/part17

Text File | 1991-11-15 | 30.1 KB | 1,095 lines

Newsgroups: comp.sources.misc
From: [e-mail] (Karl Lehenbauer)
Subject:  v25i085:  tcl - tool command language, version 6.1, Part17/33
Message-ID: <[e-mail]>
X-Md4-Signature: 5a7a26146b9c714a0ce71c4429843743
Date: Fri, 15 Nov 1991 22:47:45 GMT
Approved: [e-mail]

Submitted-by: [e-mail] (Karl Lehenbauer)
Posting-number: Volume 25, Issue 85
Archive-name: tcl/part17
Environment: UNIX

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#        "End of archive 17 (of 33)."
# Contents:  tcl6.1/tclBasic.c
# Wrapped by karl@one on Tue Nov 12 19:44:26 1991
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'tcl6.1/tclBasic.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'tcl6.1/tclBasic.c'\"
else
echo shar: Extracting \"'tcl6.1/tclBasic.c'\" \(27576 characters\)
sed "s/^X//" >'tcl6.1/tclBasic.c' <<'END_OF_FILE'
X/*
X * tclBasic.c --
X *
X *    Contains the basic facilities for TCL command interpretation,
X *    including interpreter creation and deletion, command creation
X *    and deletion, and command parsing and execution.
X *
X * Copyright 1987-1991 Regents of the University of California
X * Permission to use, copy, modify, and distribute this
X * software and its documentation for any purpose and without
X * fee is hereby granted, provided that the above copyright
X * notice appear in all copies.  The University of California
X * makes no representations about the suitability of this
X * software for any purpose.  It is provided "as is" without
X * express or implied warranty.
X */
X
X#ifndef lint
Xstatic char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclBasic.c,v 1.128 91/10/31 16:41:13 ouster Exp $ SPRITE (Berkeley)";
X#endif
X
X#include "tclInt.h"
X
X/*
X * The following structure defines all of the commands in the Tcl core,
X * and the C procedures that execute them.
X */
X
Xtypedef struct {
X    char *name;            /* Name of command. */
X    Tcl_CmdProc *proc;        /* Procedure that executes command. */
X} CmdInfo;
X
X/*
X * Built-in commands, and the procedures associated with them:
X */
X
Xstatic CmdInfo builtInCmds[] = {
X    /*
X     * Commands in the generic core:
X     */
X
X    {"append",        Tcl_AppendCmd},
X    {"array",        Tcl_ArrayCmd},
X    {"break",        Tcl_BreakCmd},
X    {"case",        Tcl_CaseCmd},
X    {"catch",        Tcl_CatchCmd},
X    {"concat",        Tcl_ConcatCmd},
X    {"continue",    Tcl_ContinueCmd},
X    {"error",        Tcl_ErrorCmd},
X    {"eval",        Tcl_EvalCmd},
X    {"expr",        Tcl_ExprCmd},
X    {"for",        Tcl_ForCmd},
X    {"foreach",        Tcl_ForeachCmd},
X    {"format",        Tcl_FormatCmd},
X    {"global",        Tcl_GlobalCmd},
X    {"if",        Tcl_IfCmd},
X    {"incr",        Tcl_IncrCmd},
X    {"info",        Tcl_InfoCmd},
X    {"join",        Tcl_JoinCmd},
X    {"lappend",        Tcl_LappendCmd},
X    {"lindex",        Tcl_LindexCmd},
X    {"linsert",        Tcl_LinsertCmd},
X    {"list",        Tcl_ListCmd},
X    {"llength",        Tcl_LlengthCmd},
X    {"lrange",        Tcl_LrangeCmd},
X    {"lreplace",    Tcl_LreplaceCmd},
X    {"lsearch",        Tcl_LsearchCmd},
X    {"lsort",        Tcl_LsortCmd},
X    {"proc",        Tcl_ProcCmd},
X    {"regexp",        Tcl_RegexpCmd},
X    {"regsub",        Tcl_RegsubCmd},
X    {"rename",        Tcl_RenameCmd},
X    {"return",        Tcl_ReturnCmd},
X    {"scan",        Tcl_ScanCmd},
X    {"set",        Tcl_SetCmd},
X    {"split",        Tcl_SplitCmd},
X    {"string",        Tcl_StringCmd},
X    {"trace",        Tcl_TraceCmd},
X    {"unset",        Tcl_UnsetCmd},
X    {"uplevel",        Tcl_UplevelCmd},
X    {"upvar",        Tcl_UpvarCmd},
X    {"while",        Tcl_WhileCmd},
X
X    /*
X     * Commands in the UNIX core:
X     */
X
X#ifndef TCL_GENERIC_ONLY
X    {"cd",        Tcl_CdCmd},
X    {"close",        Tcl_CloseCmd},
X    {"eof",        Tcl_EofCmd},
X    {"exec",        Tcl_ExecCmd},
X    {"exit",        Tcl_ExitCmd},
X    {"file",        Tcl_FileCmd},
X    {"flush",        Tcl_FlushCmd},
X    {"gets",        Tcl_GetsCmd},
X    {"glob",        Tcl_GlobCmd},
X    {"open",        Tcl_OpenCmd},
X    {"puts",        Tcl_PutsCmd},
X    {"pwd",        Tcl_PwdCmd},
X    {"read",        Tcl_ReadCmd},
X    {"seek",        Tcl_SeekCmd},
X    {"source",        Tcl_SourceCmd},
X    {"tell",        Tcl_TellCmd},
X    {"time",        Tcl_TimeCmd},
X#endif /* TCL_GENERIC_ONLY */
X    {NULL,        (Tcl_CmdProc *) NULL}
X};
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_CreateInterp --
X *
X *    Create a new TCL command interpreter.
X *
X * Results:
X *    The return value is a token for the interpreter, which may be
X *    used in calls to procedures like Tcl_CreateCmd, Tcl_Eval, or
X *    Tcl_DeleteInterp.
X *
X * Side effects:
X *    The command interpreter is initialized with an empty variable
X *    table and the built-in commands.
X *
X *----------------------------------------------------------------------
X */
X
XTcl_Interp *
XTcl_CreateInterp()
X{
X    register Interp *iPtr;
X    register Command *cmdPtr;
X    register CmdInfo *cmdInfoPtr;
X    int i;
X
X    iPtr = (Interp *) ckalloc(sizeof(Interp));
X    iPtr->result = iPtr->resultSpace;
X    iPtr->freeProc = 0;
X    iPtr->errorLine = 0;
X    Tcl_InitHashTable(&iPtr->commandTable, TCL_STRING_KEYS);
X    Tcl_InitHashTable(&iPtr->globalTable, TCL_STRING_KEYS);
X    iPtr->numLevels = 0;
X    iPtr->framePtr = NULL;
X    iPtr->varFramePtr = NULL;
X    iPtr->activeTracePtr = NULL;
X    iPtr->numEvents = 0;
X    iPtr->events = NULL;
X    iPtr->curEvent = 0;
X    iPtr->curEventNum = 0;
X    iPtr->revPtr = NULL;
X    iPtr->historyFirst = NULL;
X    iPtr->revDisables = 1;
X    iPtr->evalFirst = iPtr->evalLast = NULL;
X    iPtr->appendResult = NULL;
X    iPtr->appendAvl = 0;
X    iPtr->appendUsed = 0;
X    iPtr->numFiles = 0;
X    iPtr->filePtrArray = NULL;
X    for (i = 0; i < NUM_REGEXPS; i++) {
X    iPtr->patterns[i] = NULL;
X    iPtr->regexps[i] = NULL;
X    }
X    iPtr->cmdCount = 0;
X    iPtr->noEval = 0;
X    iPtr->scriptFile = NULL;
X    iPtr->flags = 0;
X    iPtr->tracePtr = NULL;
X    iPtr->resultSpace[0] = 0;
X
X    /*
X     * Create the built-in commands.  Do it here, rather than calling
X     * Tcl_CreateCommand, because it's faster (there's no need to
X     * check for a pre-existing command by the same name).
X     */
X
X    for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
X    int new;
X    Tcl_HashEntry *hPtr;
X
X    hPtr = Tcl_CreateHashEntry(&iPtr->commandTable,
X        cmdInfoPtr->name, &new);
X    if (new) {
X        cmdPtr = (Command *) ckalloc(sizeof(Command));
X        cmdPtr->proc = cmdInfoPtr->proc;
X        cmdPtr->clientData = (ClientData) NULL;
X        cmdPtr->deleteProc = NULL;
X        Tcl_SetHashValue(hPtr, cmdPtr);
X    }
X    }
X
X#ifndef TCL_GENERIC_ONLY
X    TclSetupEnv((Tcl_Interp *) iPtr);
X#endif
X
X    return (Tcl_Interp *) iPtr;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_DeleteInterp --
X *
X *    Delete an interpreter and free up all of the resources associated
X *    with it.
X *
X * Results:
X *    None.
X *
X * Side effects:
X *    The interpreter is destroyed.  The caller should never again
X *    use the interp token.
X *
X *----------------------------------------------------------------------
X */
X
Xvoid
XTcl_DeleteInterp(interp)
X    Tcl_Interp *interp;        /* Token for command interpreter (returned
X                 * by a previous call to Tcl_CreateInterp). */
X{
X    Interp *iPtr = (Interp *) interp;
X    Tcl_HashEntry *hPtr;
X    Tcl_HashSearch search;
X    register Command *cmdPtr;
X    int i;
X
X    /*
X     * If the interpreter is in use, delay the deletion until later.
X     */
X
X    iPtr->flags |= DELETED;
X    if (iPtr->numLevels != 0) {
X    return;
X    }
X
X    /*
X     * Free up any remaining resources associated with the
X     * interpreter.
X     */
X
X    for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
X        hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
X    cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
X    if (cmdPtr->deleteProc != NULL) {
X        (*cmdPtr->deleteProc)(cmdPtr->clientData);
X    }
X    ckfree((char *) cmdPtr);
X    }
X    Tcl_DeleteHashTable(&iPtr->commandTable);
X    TclDeleteVars(iPtr, &iPtr->globalTable);
X    if (iPtr->events != NULL) {
X    int i;
X
X    for (i = 0; i < iPtr->numEvents; i++) {
X        ckfree(iPtr->events[i].command);
X    }
X    ckfree((char *) iPtr->events);
X    }
X    while (iPtr->revPtr != NULL) {
X    HistoryRev *nextPtr = iPtr->revPtr->nextPtr;
X
X    ckfree((char *) iPtr->revPtr);
X    iPtr->revPtr = nextPtr;
X    }
X    if (iPtr->appendResult != NULL) {
X    ckfree(iPtr->appendResult);
X    }
X#ifndef TCL_GENERIC_ONLY
X    if (iPtr->numFiles > 0) {
X    for (i = 0; i < iPtr->numFiles; i++) {
X        OpenFile *filePtr;
X
X        filePtr = iPtr->filePtrArray[i];
X        if (filePtr == NULL) {
X        continue;
X        }
X        if (i >= 3) {
X        fclose(filePtr->f);
X        if (filePtr->f2 != NULL) {
X            fclose(filePtr->f2);
X        }
X        if (filePtr->numPids > 0) {
X            Tcl_DetachPids(filePtr->numPids, filePtr->pidPtr);
X            ckfree((char *) filePtr->pidPtr);
X        }
X        }
X        ckfree((char *) filePtr);
X    }
X    ckfree((char *) iPtr->filePtrArray);
X    }
X#endif
X    for (i = 0; i < NUM_REGEXPS; i++) {
X    if (iPtr->patterns[i] == NULL) {
X        break;
X    }
X    ckfree(iPtr->patterns[i]);
X    ckfree((char *) iPtr->regexps[i]);
X    }
X    while (iPtr->tracePtr != NULL) {
X    Trace *nextPtr = iPtr->tracePtr->nextPtr;
X
X    ckfree((char *) iPtr->tracePtr);
X    iPtr->tracePtr = nextPtr;
X    }
X    ckfree((char *) iPtr);
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_CreateCommand --
X *
X *    Define a new command in a command table.
X *
X * Results:
X *    None.
X *
X * Side effects:
X *    If a command named cmdName already exists for interp, it is
X *    deleted.  In the future, when cmdName is seen as the name of
X *    a command by Tcl_Eval, proc will be called.  When the command
X *    is deleted from the table, deleteProc will be called.  See the
X *    manual entry for details on the calling sequence.
X *
X *----------------------------------------------------------------------
X */
X
Xvoid
XTcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
X    Tcl_Interp *interp;        /* Token for command interpreter (returned
X                 * by a previous call to Tcl_CreateInterp). */
X    char *cmdName;        /* Name of command. */
X    Tcl_CmdProc *proc;        /* Command procedure to associate with
X                 * cmdName. */
X    ClientData clientData;    /* Arbitrary one-word value to pass to proc. */
X    Tcl_CmdDeleteProc *deleteProc;
X                /* If not NULL, gives a procedure to call when
X                 * this command is deleted. */
X{
X    Interp *iPtr = (Interp *) interp;
X    register Command *cmdPtr;
X    Tcl_HashEntry *hPtr;
X    int new;
X
X    hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, cmdName, &new);
X    if (!new) {
X    /*
X     * Command already exists:  delete the old one.
X     */
X
X    cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
X    if (cmdPtr->deleteProc != NULL) {
X        (*cmdPtr->deleteProc)(cmdPtr->clientData);
X    }
X    } else {
X    cmdPtr = (Command *) ckalloc(sizeof(Command));
X    Tcl_SetHashValue(hPtr, cmdPtr);
X    }
X    cmdPtr->proc = proc;
X    cmdPtr->clientData = clientData;
X    cmdPtr->deleteProc = deleteProc;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_DeleteCommand --
X *
X *    Remove the given command from the given interpreter.
X *
X * Results:
X *    0 is returned if the command was deleted successfully.
X *    -1 is returned if there didn't exist a command by that
X *    name.
X *
X * Side effects:
X *    CmdName will no longer be recognized as a valid command for
X *    interp.
X *
X *----------------------------------------------------------------------
X */
X
Xint
XTcl_DeleteCommand(interp, cmdName)
X    Tcl_Interp *interp;        /* Token for command interpreter (returned
X                 * by a previous call to Tcl_CreateInterp). */
X    char *cmdName;        /* Name of command to remove. */
X{
X    Interp *iPtr = (Interp *) interp;
X    Tcl_HashEntry *hPtr;
X    Command *cmdPtr;
X
X    hPtr = Tcl_FindHashEntry(&iPtr->commandTable, cmdName);
X    if (hPtr == NULL) {
X    return -1;
X    }
X    cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
X    if (cmdPtr->deleteProc != NULL) {
X    (*cmdPtr->deleteProc)(cmdPtr->clientData);
X    }
X    ckfree((char *) cmdPtr);
X    Tcl_DeleteHashEntry(hPtr);
X    return 0;
X}
X
X/*
X *-----------------------------------------------------------------
X *
X * Tcl_Eval --
X *
X *    Parse and execute a command in the Tcl language.
X *
X * Results:
X *    The return value is one of the return codes defined in tcl.hd
X *    (such as TCL_OK), and interp->result contains a string value
X *    to supplement the return code.  The value of interp->result
X *    will persist only until the next call to Tcl_Eval:  copy it or
X *    lose it! *TermPtr is filled in with the character just after
X *    the last one that was part of the command (usually a NULL
X *    character or a closing bracket).
X *
X * Side effects:
X *    Almost certainly;  depends on the command.
X *
X *-----------------------------------------------------------------
X */
X
Xint
XTcl_Eval(interp, cmd, flags, termPtr)
X    Tcl_Interp *interp;        /* Token for command interpreter (returned
X                 * by a previous call to Tcl_CreateInterp). */
X    char *cmd;            /* Pointer to TCL command to interpret. */
X    int flags;            /* OR-ed combination of flags like
X                 * TCL_BRACKET_TERM and TCL_RECORD_BOUNDS. */
X    char **termPtr;        /* If non-NULL, fill in the address it points
X                 * to with the address of the char. just after
X                 * the last one that was part of cmd.  See
X                 * the man page for details on this. */
X{
X    /*
X     * The storage immediately below is used to generate a copy
X     * of the command, after all argument substitutions.  Pv will
X     * contain the argv values passed to the command procedure.
X     */
X
X#   define NUM_CHARS 200
X    char copyStorage[NUM_CHARS];
X    ParseValue pv;
X    char *oldBuffer;
X
X    /*
X     * This procedure generates an (argv, argc) array for the command,
X     * It starts out with stack-allocated space but uses dynamically-
X     * allocated storage to increase it if needed.
X     */
X
X#   define NUM_ARGS 10
X    char *(argStorage[NUM_ARGS]);
X    char **argv = argStorage;
X    int argc;
X    int argSize = NUM_ARGS;
X
X    register char *src;            /* Points to current character
X                     * in cmd. */
X    char termChar;            /* Return when this character is found
X                     * (either ']' or '\0').  Zero means
X                     * that newlines terminate commands. */
X    int result;                /* Return value. */
X    register Interp *iPtr = (Interp *) interp;
X    Tcl_HashEntry *hPtr;
X    Command *cmdPtr;
X    char *dummy;            /* Make termPtr point here if it was
X                     * originally NULL. */
X    char *cmdStart;            /* Points to first non-blank char. in
X                     * command (used in calling trace
X                     * procedures). */
X    char *ellipsis = "";        /* Used in setting errorInfo variable;
X                     * set to "..." to indicate that not
X                     * all of offending command is included
X                     * in errorInfo.  "" means that the
X                     * command is all there. */
X    register Trace *tracePtr;
X
X    /*
X     * Initialize the result to an empty string and clear out any
X     * error information.  This makes sure that we return an empty
X     * result if there are no commands in the command string.
X     */
X
X    Tcl_FreeResult((Tcl_Interp *) iPtr);
X    iPtr->result = iPtr->resultSpace;
X    iPtr->resultSpace[0] = 0;
X    result = TCL_OK;
X
X    /*
X     * Check depth of nested calls to Tcl_Eval:  if this gets too large,
X     * it's probably because of an infinite loop somewhere.
X     */
X
X    iPtr->numLevels++;
X    if (iPtr->numLevels > MAX_NESTING_DEPTH) {
X    iPtr->result =  "too many nested calls to Tcl_Eval (infinite loop?)";
X    return TCL_ERROR;
X    }
X
X    /*
X     * Initialize the area in which command copies will be assembled.
X     */
X
X    pv.buffer = copyStorage;
X    pv.end = copyStorage + NUM_CHARS - 1;
X    pv.expandProc = TclExpandParseValue;
X    pv.clientData = (ClientData) NULL;
X
X    src = cmd;
X    if (flags & TCL_BRACKET_TERM) {
X    termChar = ']';
X    } else {
X    termChar = 0;
X    }
X    if (termPtr == NULL) {
X    termPtr = &dummy;
X    }
X    *termPtr = src;
X    cmdStart = src;
X
X    /*
X     * There can be many sub-commands (separated by semi-colons or
X     * newlines) in one command string.  This outer loop iterates over
X     * individual commands.
X     */
X
X    while (*src != termChar) {
X    iPtr->flags &= ~(ERR_IN_PROGRESS | ERROR_CODE_SET);
X
X    /*
X     * Skim off leading white space and semi-colons, and skip
X     * comments.
X     */
X
X    while (1) {
X        register char c = *src;
X
X        if ((CHAR_TYPE(c) != TCL_SPACE) && (c != ';') && (c != '\n')) {
X        break;
X        }
X        src += 1;
X    }
X    if (*src == '#') {
X        for (src++; *src != 0; src++) {
X        if (*src == '\n') {
X            src++;
X            break;
X        }
X        }
X        continue;
X    }
X    cmdStart = src;
X
X    /*
X     * Parse the words of the command, generating the argc and
X     * argv for the command procedure.  May have to call
X     * TclParseWords several times, expanding the argv array
X     * between calls.
X     */
X
X    pv.next = oldBuffer = pv.buffer;
X    argc = 0;
X    while (1) {
X        int newArgs, maxArgs;
X        char **newArgv;
X        int i;
X
X        /*
X         * Note:  the "- 2" below guarantees that we won't use the
X         * last two argv slots here.  One is for a NULL pointer to
X         * mark the end of the list, and the other is to leave room
X         * for inserting the command name "unknown" as the first
X         * argument (see below).
X         */
X
X        maxArgs = argSize - argc - 2;
X        result = TclParseWords((Tcl_Interp *) iPtr, src, flags,
X            maxArgs, termPtr, &newArgs, &argv[argc], &pv);
X        src = *termPtr;
X        if (result != TCL_OK) {
X        ellipsis = "...";
X        goto done;
X        }
X
X        /*
X         * Careful!  Buffer space may have gotten reallocated while
X         * parsing words.  If this happened, be sure to update all
X         * of the older argv pointers to refer to the new space.
X         */
X
X        if (oldBuffer != pv.buffer) {
X        int i;
X
X        for (i = 0; i < argc; i++) {
X            argv[i] = pv.buffer + (argv[i] - oldBuffer);
X        }
X        oldBuffer = pv.buffer;
X        }
X        argc += newArgs;
X        if (newArgs < maxArgs) {
X        argv[argc] = (char *) NULL;
X        break;
X        }
X
X        /*
X         * Args didn't all fit in the current array.  Make it bigger.
X         */
X
X        argSize *= 2;
X        newArgv = (char **)
X            ckalloc((unsigned) argSize * sizeof(char *));
X        for (i = 0; i < argc; i++) {
X        newArgv[i] = argv[i];
X        }
X        if (argv != argStorage) {
X        ckfree((char *) argv);
X        }
X        argv = newArgv;
X    }
X
X    /*
X     * If this is an empty command (or if we're just parsing
X     * commands without evaluating them), then just skip to the
X     * next command.
X     */
X
X    if ((argc == 0) || iPtr->noEval) {
X        continue;
X    }
X    argv[argc] = NULL;
X
X    /*
X     * Save information for the history module, if needed.
X     */
X
X    if (flags & TCL_RECORD_BOUNDS) {
X        iPtr->evalFirst = cmdStart;
X        iPtr->evalLast = src-1;
X    }
X
X    /*
X     * Find the procedure to execute this command.  If there isn't
X     * one, then see if there is a command "unknown".  If so,
X     * invoke it instead, passing it the words of the original
X     * command as arguments.
X     */
X
X    hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[0]);
X    if (hPtr == NULL) {
X        int i;
X
X        hPtr = Tcl_FindHashEntry(&iPtr->commandTable, "unknown");
X        if (hPtr == NULL) {
X        Tcl_ResetResult(interp);
X        Tcl_AppendResult(interp, "invalid command name: \"",
X            argv[0], "\"", (char *) NULL);
X        result = TCL_ERROR;
X        goto done;
X        }
X        for (i = argc; i >= 0; i--) {
X        argv[i+1] = argv[i];
X        }
X        argv[0] = "unknown";
X        argc++;
X    }
X    cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
X
X    /*
X     * Call trace procedures, if any.
X     */
X
X    for (tracePtr = iPtr->tracePtr; tracePtr != NULL;
X        tracePtr = tracePtr->nextPtr) {
X        char saved;
X
X        if (tracePtr->level < iPtr->numLevels) {
X        continue;
X        }
X        saved = *src;
X        *src = 0;
X        (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels,
X            cmdStart, cmdPtr->proc, cmdPtr->clientData, argc, argv);
X        *src = saved;
X    }
X
X    /*
X     * At long last, invoke the command procedure.  Reset the
X     * result to its default empty value first (it could have
X     * gotten changed by earlier commands in the same command
X     * string).
X     */
X
X    iPtr->cmdCount++;
X    Tcl_FreeResult(iPtr);
X    iPtr->result = iPtr->resultSpace;
X    iPtr->resultSpace[0] = 0;
X    result = (*cmdPtr->proc)(cmdPtr->clientData, interp, argc, argv);
X    if (result != TCL_OK) {
X        break;
X    }
X    }
X
X    /*
X     * Free up any extra resources that were allocated.
X     */
X
X    done:
X    if (pv.buffer != copyStorage) {
X    ckfree((char *) pv.buffer);
X    }
X    if (argv != argStorage) {
X    ckfree((char *) argv);
X    }
X    iPtr->numLevels--;
X    if (iPtr->numLevels == 0) {
X    if (result == TCL_RETURN) {
X        result = TCL_OK;
X    }
X    if ((result != TCL_OK) && (result != TCL_ERROR)) {
X        Tcl_ResetResult(interp);
X        if (result == TCL_BREAK) {
X        iPtr->result = "invoked \"break\" outside of a loop";
X        } else if (result == TCL_CONTINUE) {
X        iPtr->result = "invoked \"continue\" outside of a loop";
X        } else {
X        iPtr->result = iPtr->resultSpace;
X        sprintf(iPtr->resultSpace, "command returned bad code: %d",
X            result);
X        }
X        result = TCL_ERROR;
X    }
X    if (iPtr->flags & DELETED) {
X        Tcl_DeleteInterp(interp);
X    }
X    }
X
X    /*
X     * If an error occurred, record information about what was being
X     * executed when the error occurred.
X     */
X
X    if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
X    int numChars;
X    register char *p;
X
X    /*
X     * Compute the line number where the error occurred.
X     */
X
X    iPtr->errorLine = 1;
X    for (p = cmd; p != cmdStart; p++) {
X        if (*p == '\n') {
X        iPtr->errorLine++;
X        }
X    }
X    for ( ; isspace(*p) || (*p == ';'); p++) {
X        if (*p == '\n') {
X        iPtr->errorLine++;
X        }
X    }
X
X    /*
X     * Figure out how much of the command to print in the error
X     * message (up to a certain number of characters, or up to
X     * the first new-line).
X     */
X
X    numChars = src - cmdStart;
X    if (numChars > (NUM_CHARS-50)) {
X        numChars = NUM_CHARS-50;
X        ellipsis = " ...";
X    }
X
X    if (!(iPtr->flags & ERR_IN_PROGRESS)) {
X        sprintf(copyStorage, "\n    while executing\n\"%.*s%s\"",
X            numChars, cmdStart, ellipsis);
X    } else {
X        sprintf(copyStorage, "\n    invoked from within\n\"%.*s%s\"",
X            numChars, cmdStart, ellipsis);
X    }
X    Tcl_AddErrorInfo(interp, copyStorage);
X    iPtr->flags &= ~ERR_ALREADY_LOGGED;
X    } else {
X    iPtr->flags &= ~ERR_ALREADY_LOGGED;
X    }
X    return result;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_CreateTrace --
X *
X *    Arrange for a procedure to be called to trace command execution.
X *
X * Results:
X *    The return value is a token for the trace, which may be passed
X *    to Tcl_DeleteTrace to eliminate the trace.
X *
X * Side effects:
X *    From now on, proc will be called just before a command procedure
X *    is called to execute a Tcl command.  Calls to proc will have the
X *    following form:
X *
X *    void
X *    proc(clientData, interp, level, command, cmdProc, cmdClientData,
X *        argc, argv)
X *        ClientData clientData;
X *        Tcl_Interp *interp;
X *        int level;
X *        char *command;
X *        int (*cmdProc)();
X *        ClientData cmdClientData;
X *        int argc;
X *        char **argv;
X *    {
X *    }
X *
X *    The clientData and interp arguments to proc will be the same
X *    as the corresponding arguments to this procedure.  Level gives
X *    the nesting level of command interpretation for this interpreter
X *    (0 corresponds to top level).  Command gives the ASCII text of
X *    the raw command, cmdProc and cmdClientData give the procedure that
X *    will be called to process the command and the ClientData value it
X *    will receive, and argc and argv give the arguments to the
X *    command, after any argument parsing and substitution.  Proc
X *    does not return a value.
X *
X *----------------------------------------------------------------------
X */
X
XTcl_Trace
XTcl_CreateTrace(interp, level, proc, clientData)
X    Tcl_Interp *interp;        /* Interpreter in which to create the trace. */
X    int level;            /* Only call proc for commands at nesting level
X                 * <= level (1 => top level). */
X    Tcl_CmdTraceProc *proc;    /* Procedure to call before executing each
X                 * command. */
X    ClientData clientData;    /* Arbitrary one-word value to pass to proc. */
X{
X    register Trace *tracePtr;
X    register Interp *iPtr = (Interp *) interp;
X
X    tracePtr = (Trace *) ckalloc(sizeof(Trace));
X    tracePtr->level = level;
X    tracePtr->proc = proc;
X    tracePtr->clientData = clientData;
X    tracePtr->nextPtr = iPtr->tracePtr;
X    iPtr->tracePtr = tracePtr;
X
X    return (Tcl_Trace) tracePtr;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_DeleteTrace --
X *
X *    Remove a trace.
X *
X * Results:
X *    None.
X *
X * Side effects:
X *    From now on there will be no more calls to the procedure given
X *    in trace.
X *
X *----------------------------------------------------------------------
X */
X
Xvoid
XTcl_DeleteTrace(interp, trace)
X    Tcl_Interp *interp;        /* Interpreter that contains trace. */
X    Tcl_Trace trace;        /* Token for trace (returned previously by
X                 * Tcl_CreateTrace). */
X{
X    register Interp *iPtr = (Interp *) interp;
X    register Trace *tracePtr = (Trace *) trace;
X    register Trace *tracePtr2;
X
X    if (iPtr->tracePtr == tracePtr) {
X    iPtr->tracePtr = tracePtr->nextPtr;
X    ckfree((char *) tracePtr);
X    } else {
X    for (tracePtr2 = iPtr->tracePtr; tracePtr2 != NULL;
X        tracePtr2 = tracePtr2->nextPtr) {
X        if (tracePtr2->nextPtr == tracePtr) {
X        tracePtr2->nextPtr = tracePtr->nextPtr;
X        ckfree((char *) tracePtr);
X        return;
X        }
X    }
X    }
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_AddErrorInfo --
X *
X *    Add information to a message being accumulated that describes
X *    the current error.
X *
X * Results:
X *    None.
X *
X * Side effects:
X *    The contents of message are added to the "errorInfo" variable.
X *    If Tcl_Eval has been called since the current value of errorInfo
X *    was set, errorInfo is cleared before adding the new message.
X *
X *----------------------------------------------------------------------
X */
X
Xvoid
XTcl_AddErrorInfo(interp, message)
X    Tcl_Interp *interp;        /* Interpreter to which error information
X                 * pertains. */
X    char *message;        /* Message to record. */
X{
X    register Interp *iPtr = (Interp *) interp;
X
X    /*
X     * If an error is already being logged, then the new errorInfo
X     * is the concatenation of the old info and the new message.
X     * If this is the first piece of info for the error, then the
X     * new errorInfo is the concatenation of the message in
X     * interp->result and the new message.
X     */
X
X    if (!(iPtr->flags & ERR_IN_PROGRESS)) {
X    Tcl_SetVar2(interp, "errorInfo", (char *) NULL, interp->result,
X        TCL_GLOBAL_ONLY);
X    iPtr->flags |= ERR_IN_PROGRESS;
X
X    /*
X     * If the errorCode variable wasn't set by the code that generated
X     * the error, set it to "NONE".
X     */
X
X    if (!(iPtr->flags & ERROR_CODE_SET)) {
X        (void) Tcl_SetVar2(interp, "errorCode", (char *) NULL, "NONE",
X            TCL_GLOBAL_ONLY);
X    }
X    }
X    Tcl_SetVar2(interp, "errorInfo", (char *) NULL, message,
X        TCL_GLOBAL_ONLY|TCL_APPEND_VALUE);
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_VarEval --
X *
X *    Given a variable number of string arguments, concatenate them
X *    all together and execute the result as a Tcl command.
X *
X * Results:
X *    A standard Tcl return result.  An error message or other
X *    result may be left in interp->result.
X *
X * Side effects:
X *    Depends on what was done by the command.
X *
X *----------------------------------------------------------------------
X */
X    /* VARARGS2 */ /* ARGSUSED */
Xint
X#ifndef lint
XTcl_VarEval(va_alist)
X#else
XTcl_VarEval(interp, p, va_alist)
X    Tcl_Interp *interp;        /* Interpreter in which to execute command. */
X    char *p;            /* One or more strings to concatenate,
X                 * terminated with a NULL string. */
X#endif
X    va_dcl
X{
X    va_list argList;
X#define FIXED_SIZE 200
X    char fixedSpace[FIXED_SIZE+1];
X    int spaceAvl, spaceUsed, length;
X    char *string, *cmd;
X    Tcl_Interp *interp;
X    int result;
X
X    /*
X     * Copy the strings one after the other into a single larger
X     * string.  Use stack-allocated space for small commands, but if
X     * the commands gets too large than call ckalloc to create the
X     * space.
X     */
X
X    va_start(argList);
X    interp = va_arg(argList, Tcl_Interp *);
X    spaceAvl = FIXED_SIZE;
X    spaceUsed = 0;
X    cmd = fixedSpace;
X    while (1) {
X    string = va_arg(argList, char *);
X    if (string == NULL) {
X        break;
X    }
X    length = strlen(string);
X    if ((spaceUsed + length) > spaceAvl) {
X        char *new;
X
X        spaceAvl = spaceUsed + length;
X        spaceAvl += spaceAvl/2;
X        new = ckalloc((unsigned) spaceAvl);
X        memcpy((VOID *) new, (VOID *) cmd, spaceUsed);
X        if (cmd != fixedSpace) {
X        ckfree(cmd);
X        }
X        cmd = new;
X    }
X    strcpy(cmd + spaceUsed, string);
X    spaceUsed += length;
X    }
X    va_end(argList);
X    cmd[spaceUsed] = '\0';
X
X    result = Tcl_Eval(interp, cmd, 0, (char **) NULL);
X    if (cmd != fixedSpace) {
X    ckfree(cmd);
X    }
X    return result;
X}
END_OF_FILE
if test 27576 -ne `wc -c <'tcl6.1/tclBasic.c'`; then
    echo shar: \"'tcl6.1/tclBasic.c'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tclBasic.c'
fi
echo shar: End of archive 17 \(of 33\).
cp /dev/null ark17isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 33 archives.
    rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
    echo You still need to unpack the following archives:
    echo "        " ${MISSING}
fi
##  End of shell archive.
exit 0

exit 0 # Just in case...
--
Kent Landfield                   INTERNET: [e-mail]
Sterling Software, IMD           UUCP:     uunet!sparky!kent
Phone:    [phone]         FAX:      [phone]
Please send comp.sources.misc-related mail to [e-mail].