URL https://opencores.org/ocsvn/or1k/or1k/trunk
Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [tcl/] [generic/] [tclBasic.c] - Blame information for rev 578

Go to most recent revision | Details | Compare with Previous | View Log

/*
 * tclBasic.c --
 *
 *      Contains the basic facilities for TCL command interpretation,
 *      including interpreter creation and deletion, command creation
 *      and deletion, and command parsing and execution.
 *
 * Copyright (c) 1987-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclBasic.c,v 1.1.1.1 2002-01-16 10:25:25 markom Exp $
 */
 
#include "tclInt.h"
#include "tclCompile.h"
#ifndef TCL_GENERIC_ONLY
#   include "tclPort.h"
#endif
 
/*
 * Static procedures in this file:
 */
 
static void             DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp));
static void             HiddenCmdsDeleteProc _ANSI_ARGS_((
                            ClientData clientData, Tcl_Interp *interp));
 
/*
 * The following structure defines the commands in the Tcl core.
 */
 
typedef struct {
    char *name;                 /* Name of object-based command. */
    Tcl_CmdProc *proc;          /* String-based procedure for command. */
    Tcl_ObjCmdProc *objProc;    /* Object-based procedure for command. */
    CompileProc *compileProc;   /* Procedure called to compile command. */
    int isSafe;                 /* If non-zero, command will be present
                                 * in safe interpreter. Otherwise it will
                                 * be hidden. */
} CmdInfo;
 
/*
 * The built-in commands, and the procedures that implement them:
 */
 
static CmdInfo builtInCmds[] = {
    /*
     * Commands in the generic core. Note that at least one of the proc or
     * objProc members should be non-NULL. This avoids infinitely recursive
     * calls between TclInvokeObjectCommand and TclInvokeStringCommand if a
     * command name is computed at runtime and results in the name of a
     * compiled command.
     */
 
    {"append",          (Tcl_CmdProc *) NULL,   Tcl_AppendObjCmd,
        (CompileProc *) NULL,           1},
    {"array",           (Tcl_CmdProc *) NULL,   Tcl_ArrayObjCmd,
        (CompileProc *) NULL,           1},
    {"binary",          (Tcl_CmdProc *) NULL,   Tcl_BinaryObjCmd,
        (CompileProc *) NULL,           1},
    {"break",           Tcl_BreakCmd,           (Tcl_ObjCmdProc *) NULL,
        TclCompileBreakCmd,             1},
    {"case",            (Tcl_CmdProc *) NULL,   Tcl_CaseObjCmd,
        (CompileProc *) NULL,           1},
    {"catch",           (Tcl_CmdProc *) NULL,   Tcl_CatchObjCmd,
        TclCompileCatchCmd,             1},
    {"clock",           (Tcl_CmdProc *) NULL,   Tcl_ClockObjCmd,
        (CompileProc *) NULL,           1},
    {"concat",          (Tcl_CmdProc *) NULL,   Tcl_ConcatObjCmd,
        (CompileProc *) NULL,           1},
    {"continue",        Tcl_ContinueCmd,        (Tcl_ObjCmdProc *) NULL,
        TclCompileContinueCmd,          1},
    {"error",           (Tcl_CmdProc *) NULL,   Tcl_ErrorObjCmd,
        (CompileProc *) NULL,           1},
    {"eval",            (Tcl_CmdProc *) NULL,   Tcl_EvalObjCmd,
        (CompileProc *) NULL,           1},
    {"exit",            (Tcl_CmdProc *) NULL,   Tcl_ExitObjCmd,
        (CompileProc *) NULL,           0},
    {"expr",            (Tcl_CmdProc *) NULL,   Tcl_ExprObjCmd,
        TclCompileExprCmd,              1},
    {"fcopy",           (Tcl_CmdProc *) NULL,   Tcl_FcopyObjCmd,
        (CompileProc *) NULL,           1},
    {"fileevent",       Tcl_FileEventCmd,       (Tcl_ObjCmdProc *) NULL,
        (CompileProc *) NULL,           1},
    {"for",             Tcl_ForCmd,             (Tcl_ObjCmdProc *) NULL,
        TclCompileForCmd,               1},
    {"foreach",         (Tcl_CmdProc *) NULL,   Tcl_ForeachObjCmd,
        TclCompileForeachCmd,           1},
    {"format",          (Tcl_CmdProc *) NULL,   Tcl_FormatObjCmd,
        (CompileProc *) NULL,           1},
    {"global",          (Tcl_CmdProc *) NULL,   Tcl_GlobalObjCmd,
        (CompileProc *) NULL,           1},
    {"if",              Tcl_IfCmd,              (Tcl_ObjCmdProc *) NULL,
        TclCompileIfCmd,                1},
    {"incr",            Tcl_IncrCmd,            (Tcl_ObjCmdProc *) NULL,
        TclCompileIncrCmd,              1},
    {"info",            (Tcl_CmdProc *) NULL,   Tcl_InfoObjCmd,
        (CompileProc *) NULL,           1},
    {"interp",          (Tcl_CmdProc *) NULL,   Tcl_InterpObjCmd,
        (CompileProc *) NULL,           1},
    {"join",            (Tcl_CmdProc *) NULL,   Tcl_JoinObjCmd,
        (CompileProc *) NULL,           1},
    {"lappend",         (Tcl_CmdProc *) NULL,   Tcl_LappendObjCmd,
        (CompileProc *) NULL,           1},
    {"lindex",          (Tcl_CmdProc *) NULL,   Tcl_LindexObjCmd,
        (CompileProc *) NULL,           1},
    {"linsert",         (Tcl_CmdProc *) NULL,   Tcl_LinsertObjCmd,
        (CompileProc *) NULL,           1},
    {"list",            (Tcl_CmdProc *) NULL,   Tcl_ListObjCmd,
        (CompileProc *) NULL,           1},
    {"llength",         (Tcl_CmdProc *) NULL,   Tcl_LlengthObjCmd,
        (CompileProc *) NULL,           1},
    {"load",            Tcl_LoadCmd,            (Tcl_ObjCmdProc *) NULL,
        (CompileProc *) NULL,           0},
    {"lrange",          (Tcl_CmdProc *) NULL,   Tcl_LrangeObjCmd,
        (CompileProc *) NULL,           1},
    {"lreplace",        (Tcl_CmdProc *) NULL,   Tcl_LreplaceObjCmd,
        (CompileProc *) NULL,           1},
    {"lsearch",         (Tcl_CmdProc *) NULL,   Tcl_LsearchObjCmd,
        (CompileProc *) NULL,           1},
    {"lsort",           (Tcl_CmdProc *) NULL,   Tcl_LsortObjCmd,
        (CompileProc *) NULL,           1},
    {"namespace",       (Tcl_CmdProc *) NULL,   Tcl_NamespaceObjCmd,
        (CompileProc *) NULL,           1},
    {"package",         Tcl_PackageCmd,         (Tcl_ObjCmdProc *) NULL,
        (CompileProc *) NULL,           1},
    {"proc",            (Tcl_CmdProc *) NULL,   Tcl_ProcObjCmd,
        (CompileProc *) NULL,           1},
    {"regexp",          Tcl_RegexpCmd,          (Tcl_ObjCmdProc *) NULL,
        (CompileProc *) NULL,           1},
    {"regsub",          Tcl_RegsubCmd,          (Tcl_ObjCmdProc *) NULL,
        (CompileProc *) NULL,           1},
    {"rename",          (Tcl_CmdProc *) NULL,   Tcl_RenameObjCmd,
        (CompileProc *) NULL,           1},
    {"return",          (Tcl_CmdProc *) NULL,   Tcl_ReturnObjCmd,
        (CompileProc *) NULL,           1},
    {"scan",            Tcl_ScanCmd,            (Tcl_ObjCmdProc *) NULL,
        (CompileProc *) NULL,           1},
    {"set",             Tcl_SetCmd,             (Tcl_ObjCmdProc *) NULL,
        TclCompileSetCmd,               1},
    {"split",           (Tcl_CmdProc *) NULL,   Tcl_SplitObjCmd,
        (CompileProc *) NULL,           1},
    {"string",          (Tcl_CmdProc *) NULL,   Tcl_StringObjCmd,
        (CompileProc *) NULL,           1},
    {"subst",           Tcl_SubstCmd,           (Tcl_ObjCmdProc *) NULL,
        (CompileProc *) NULL,           1},
    {"switch",          (Tcl_CmdProc *) NULL,   Tcl_SwitchObjCmd,
        (CompileProc *) NULL,           1},
    {"trace",           Tcl_TraceCmd,           (Tcl_ObjCmdProc *) NULL,
        (CompileProc *) NULL,           1},
    {"unset",           (Tcl_CmdProc *) NULL,   Tcl_UnsetObjCmd,
        (CompileProc *) NULL,           1},
    {"uplevel",         (Tcl_CmdProc *) NULL,   Tcl_UplevelObjCmd,
        (CompileProc *) NULL,           1},
    {"upvar",           (Tcl_CmdProc *) NULL,   Tcl_UpvarObjCmd,
        (CompileProc *) NULL,           1},
    {"variable",        (Tcl_CmdProc *) NULL,   Tcl_VariableObjCmd,
        (CompileProc *) NULL,           1},
    {"while",           Tcl_WhileCmd,           (Tcl_ObjCmdProc *) NULL,
        TclCompileWhileCmd,             1},
 
    /*
     * Commands in the UNIX core:
     */
 
#ifndef TCL_GENERIC_ONLY
    {"after",           (Tcl_CmdProc *) NULL,   Tcl_AfterObjCmd,
        (CompileProc *) NULL,           1},
    {"cd",              (Tcl_CmdProc *) NULL,   Tcl_CdObjCmd,
        (CompileProc *) NULL,           0},
    {"close",           (Tcl_CmdProc *) NULL,   Tcl_CloseObjCmd,
        (CompileProc *) NULL,           1},
    {"eof",             (Tcl_CmdProc *) NULL,   Tcl_EofObjCmd,
        (CompileProc *) NULL,           1},
    {"fblocked",        (Tcl_CmdProc *) NULL,   Tcl_FblockedObjCmd,
        (CompileProc *) NULL,           1},
    {"fconfigure",      Tcl_FconfigureCmd,      (Tcl_ObjCmdProc *) NULL,
        (CompileProc *) NULL,           0},
    {"file",            (Tcl_CmdProc *) NULL,   Tcl_FileObjCmd,
        (CompileProc *) NULL,           0},
    {"flush",           (Tcl_CmdProc *) NULL,   Tcl_FlushObjCmd,
        (CompileProc *) NULL,           1},
    {"gets",            (Tcl_CmdProc *) NULL,   Tcl_GetsObjCmd,
        (CompileProc *) NULL,           1},
    {"glob",            Tcl_GlobCmd,            (Tcl_ObjCmdProc *) NULL,
        (CompileProc *) NULL,           0},
    {"open",            Tcl_OpenCmd,            (Tcl_ObjCmdProc *) NULL,
        (CompileProc *) NULL,           0},
    {"pid",             (Tcl_CmdProc *) NULL,   Tcl_PidObjCmd,
        (CompileProc *) NULL,           1},
    {"puts",            (Tcl_CmdProc *) NULL,   Tcl_PutsObjCmd,
        (CompileProc *) NULL,           1},
    {"pwd",             Tcl_PwdCmd,             (Tcl_ObjCmdProc *) NULL,
        (CompileProc *) NULL,           0},
    {"read",            (Tcl_CmdProc *) NULL,   Tcl_ReadObjCmd,
        (CompileProc *) NULL,           1},
    {"seek",            Tcl_SeekCmd,            (Tcl_ObjCmdProc *) NULL,
        (CompileProc *) NULL,           1},
    {"socket",          Tcl_SocketCmd,          (Tcl_ObjCmdProc *) NULL,
        (CompileProc *) NULL,           0},
    {"tell",            Tcl_TellCmd,            (Tcl_ObjCmdProc *) NULL,
        (CompileProc *) NULL,           1},
    {"time",            (Tcl_CmdProc *) NULL,   Tcl_TimeObjCmd,
        (CompileProc *) NULL,           1},
    {"update",          Tcl_UpdateCmd,          (Tcl_ObjCmdProc *) NULL,
        (CompileProc *) NULL,           1},
    {"vwait",           Tcl_VwaitCmd,           (Tcl_ObjCmdProc *) NULL,
        (CompileProc *) NULL,           1},
 
#ifdef MAC_TCL
    {"beep",            (Tcl_CmdProc *) NULL,   Tcl_BeepObjCmd,
        (CompileProc *) NULL,           0},
    {"echo",            Tcl_EchoCmd,            (Tcl_ObjCmdProc *) NULL,
        (CompileProc *) NULL,           0},
    {"ls",              Tcl_LsCmd,              (Tcl_ObjCmdProc *) NULL,
        (CompileProc *) NULL,           0},
    {"resource",        (Tcl_CmdProc *) NULL,   Tcl_ResourceObjCmd,
        (CompileProc *) NULL,           1},
    {"source",          (Tcl_CmdProc *) NULL,   Tcl_MacSourceObjCmd,
        (CompileProc *) NULL,           0},
#else
    {"exec",            Tcl_ExecCmd,            (Tcl_ObjCmdProc *) NULL,
        (CompileProc *) NULL,           0},
    {"source",          (Tcl_CmdProc *) NULL,   Tcl_SourceObjCmd,
        (CompileProc *) NULL,           0},
#endif /* MAC_TCL */
 
#endif /* TCL_GENERIC_ONLY */
    {NULL,              (Tcl_CmdProc *) NULL,   (Tcl_ObjCmdProc *) NULL,
        (CompileProc *) NULL,           0}
};
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateInterp --
 *
 *      Create a new TCL command interpreter.
 *
 * Results:
 *      The return value is a token for the interpreter, which may be
 *      used in calls to procedures like Tcl_CreateCmd, Tcl_Eval, or
 *      Tcl_DeleteInterp.
 *
 * Side effects:
 *      The command interpreter is initialized with an empty variable
 *      table and the built-in commands.
 *
 *----------------------------------------------------------------------
 */
 
Tcl_Interp *
Tcl_CreateInterp()
{
    register Interp *iPtr;
    register Command *cmdPtr;
    register CmdInfo *cmdInfoPtr;
    union {
        char c[sizeof(short)];
        short s;
    } order;
    int i;
 
    /*
     * Panic if someone updated the CallFrame structure without
     * also updating the Tcl_CallFrame structure (or vice versa).
     */
 
    if (sizeof(Tcl_CallFrame) != sizeof(CallFrame)) {
        /*NOTREACHED*/
        panic("Tcl_CallFrame and CallFrame are not the same size");
    }
 
    /*
     * Initialize support for namespaces and create the global namespace
     * (whose name is ""; an alias is "::"). This also initializes the
     * Tcl object type table and other object management code.
     */
 
    TclInitNamespaces();
 
    iPtr = (Interp *) ckalloc(sizeof(Interp));
    iPtr->result = iPtr->resultSpace;
    iPtr->freeProc = 0;
    iPtr->objResultPtr = Tcl_NewObj(); /* an empty object */
    Tcl_IncrRefCount(iPtr->objResultPtr);
    iPtr->errorLine = 0;
    Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS);
    iPtr->numLevels = 0;
    iPtr->maxNestingDepth = 1000;
    iPtr->framePtr = NULL;
    iPtr->varFramePtr = NULL;
    iPtr->activeTracePtr = NULL;
    iPtr->returnCode = TCL_OK;
    iPtr->errorInfo = NULL;
    iPtr->errorCode = NULL;
    iPtr->appendResult = NULL;
    iPtr->appendAvl = 0;
    iPtr->appendUsed = 0;
    for (i = 0; i < NUM_REGEXPS; i++) {
        iPtr->patterns[i] = NULL;
        iPtr->patLengths[i] = -1;
        iPtr->regexps[i] = NULL;
    }
    Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS);
    iPtr->packageUnknown = NULL;
    iPtr->cmdCount = 0;
    iPtr->termOffset = 0;
    iPtr->compileEpoch = 0;
    iPtr->compiledProcPtr = NULL;
    iPtr->resolverPtr = NULL;
    iPtr->evalFlags = 0;
    iPtr->scriptFile = NULL;
    iPtr->flags = 0;
    iPtr->tracePtr = NULL;
    iPtr->assocData = (Tcl_HashTable *) NULL;
    iPtr->execEnvPtr = NULL;          /* set after namespaces initialized */
    iPtr->emptyObjPtr = Tcl_NewObj(); /* another empty object */
    Tcl_IncrRefCount(iPtr->emptyObjPtr);
    iPtr->resultSpace[0] = 0;
 
    iPtr->globalNsPtr = NULL;   /* force creation of global ns below */
    iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(
            (Tcl_Interp *) iPtr, "", (ClientData) NULL,
            (Tcl_NamespaceDeleteProc *) NULL);
    if (iPtr->globalNsPtr == NULL) {
        panic("Tcl_CreateInterp: can't create global namespace");
    }
 
    /*
     * Initialize support for code compilation. Do this after initializing
     * namespaces since TclCreateExecEnv will try to reference a Tcl
     * variable (it links to the Tcl "tcl_traceExec" variable).
     */
 
    iPtr->execEnvPtr = TclCreateExecEnv((Tcl_Interp *) iPtr);
 
    /*
     * Create the core commands. Do it here, rather than calling
     * Tcl_CreateCommand, because it's faster (there's no need to check for
     * a pre-existing command by the same name). If a command has a
     * Tcl_CmdProc but no Tcl_ObjCmdProc, set the Tcl_ObjCmdProc to
     * TclInvokeStringCommand. This is an object-based wrapper procedure
     * that extracts strings, calls the string procedure, and creates an
     * object for the result. Similarly, if a command has a Tcl_ObjCmdProc
     * but no Tcl_CmdProc, set the Tcl_CmdProc to TclInvokeObjectCommand.
     */
 
    for (cmdInfoPtr = builtInCmds;  cmdInfoPtr->name != NULL;
            cmdInfoPtr++) {
        int new;
        Tcl_HashEntry *hPtr;
 
        if ((cmdInfoPtr->proc == (Tcl_CmdProc *) NULL)
                && (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL)
                && (cmdInfoPtr->compileProc == (CompileProc *) NULL)) {
            panic("Tcl_CreateInterp: builtin command with NULL string and object command procs and a NULL compile proc\n");
        }
 
        hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable,
                cmdInfoPtr->name, &new);
        if (new) {
            cmdPtr = (Command *) ckalloc(sizeof(Command));
            cmdPtr->hPtr = hPtr;
            cmdPtr->nsPtr = iPtr->globalNsPtr;
            cmdPtr->refCount = 1;
            cmdPtr->cmdEpoch = 0;
            cmdPtr->compileProc = cmdInfoPtr->compileProc;
            if (cmdInfoPtr->proc == (Tcl_CmdProc *) NULL) {
                cmdPtr->proc = TclInvokeObjectCommand;
                cmdPtr->clientData = (ClientData) cmdPtr;
            } else {
                cmdPtr->proc = cmdInfoPtr->proc;
                cmdPtr->clientData = (ClientData) NULL;
            }
            if (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL) {
                cmdPtr->objProc = TclInvokeStringCommand;
                cmdPtr->objClientData = (ClientData) cmdPtr;
            } else {
                cmdPtr->objProc = cmdInfoPtr->objProc;
                cmdPtr->objClientData = (ClientData) NULL;
            }
            cmdPtr->deleteProc = NULL;
            cmdPtr->deleteData = (ClientData) NULL;
            cmdPtr->deleted = 0;
            cmdPtr->importRefPtr = NULL;
            Tcl_SetHashValue(hPtr, cmdPtr);
        }
    }
 
    /*
     *  Initialize/Create "errorInfo" and "errorCode" global vars
     *  (because some part of the C code assume they exists
     *   and we can get a seg fault otherwise (in multiple
     *   interps loading of extensions for instance) --dl)
     */
     /*
      *  We can't assume that because we initialize
      *  the variables here, they won't be unset later.
      *  so we had 2 choices:
      *    + Check every place where a GetVar of those is used
      *      and the NULL result is not checked (like in tclLoad.c)
      *    + Make SetVar,... NULL friendly
      *  We choosed the second option because :
      *    + It is easy and low cost to check for NULL pointer before
      *      calling strlen()
      *    + It can be helpfull to other people using those API
      *    + Passing a NULL value to those closest 'meaning' is empty string
      *      (specially with the new objects where 0 bytes strings are ok)
      * So the following init is commented out:              -- dl
      */
    /*
      (void)Tcl_SetVar2((Tcl_Interp *)iPtr, "errorInfo", (char *) NULL, "",
         TCL_GLOBAL_ONLY);
      (void)Tcl_SetVar2((Tcl_Interp *)iPtr, "errorCode", (char *) NULL, "NONE",
            TCL_GLOBAL_ONLY);
     */
 
#ifndef TCL_GENERIC_ONLY
    TclSetupEnv((Tcl_Interp *) iPtr);
#endif
 
    /*
     * Do Multiple/Safe Interps Tcl init stuff
     */
    (void) TclInterpInit((Tcl_Interp *)iPtr);
 
    /*
     * Set up variables such as tcl_version.
     */
 
    TclPlatformInit((Tcl_Interp *)iPtr);
    Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_patchLevel", TCL_PATCH_LEVEL,
            TCL_GLOBAL_ONLY);
    Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_version", TCL_VERSION,
            TCL_GLOBAL_ONLY);
    Tcl_TraceVar2((Tcl_Interp *) iPtr, "tcl_precision", (char *) NULL,
            TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
            TclPrecTraceProc, (ClientData) NULL);
 
    /*
     * Compute the byte order of this machine.
     */
 
    order.s = 1;
    Tcl_SetVar2((Tcl_Interp *) iPtr, "tcl_platform", "byteOrder",
            (order.c[0] == 1) ? "littleEndian" : "bigEndian",
            TCL_GLOBAL_ONLY);
 
    /*
     * Register Tcl's version number.
     */
 
    Tcl_PkgProvide((Tcl_Interp *) iPtr, "Tcl", TCL_VERSION);
 
    return (Tcl_Interp *) iPtr;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclHideUnsafeCommands --
 *
 *      Hides base commands that are not marked as safe from this
 *      interpreter.
 *
 * Results:
 *      TCL_OK if it succeeds, TCL_ERROR else.
 *
 * Side effects:
 *      Hides functionality in an interpreter.
 *
 *----------------------------------------------------------------------
 */
 
int
TclHideUnsafeCommands(interp)
    Tcl_Interp *interp;         /* Hide commands in this interpreter. */
{
    register CmdInfo *cmdInfoPtr;
 
    if (interp == (Tcl_Interp *) NULL) {
        return TCL_ERROR;
    }
    for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
        if (!cmdInfoPtr->isSafe) {
            Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name);
        }
    }
    return TCL_OK;
}
 
/*
 *--------------------------------------------------------------
 *
 * Tcl_CallWhenDeleted --
 *
 *      Arrange for a procedure to be called before a given
 *      interpreter is deleted. The procedure is called as soon
 *      as Tcl_DeleteInterp is called; if Tcl_CallWhenDeleted is
 *      called on an interpreter that has already been deleted,
 *      the procedure will be called when the last Tcl_Release is
 *      done on the interpreter.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      When Tcl_DeleteInterp is invoked to delete interp,
 *      proc will be invoked.  See the manual entry for
 *      details.
 *
 *--------------------------------------------------------------
 */
 
void
Tcl_CallWhenDeleted(interp, proc, clientData)
    Tcl_Interp *interp;         /* Interpreter to watch. */
    Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter
                                 * is about to be deleted. */
    ClientData clientData;      /* One-word value to pass to proc. */
{
    Interp *iPtr = (Interp *) interp;
    static int assocDataCounter = 0;
    int new;
    char buffer[128];
    AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData));
    Tcl_HashEntry *hPtr;
 
    sprintf(buffer, "Assoc Data Key #%d", assocDataCounter);
    assocDataCounter++;
 
    if (iPtr->assocData == (Tcl_HashTable *) NULL) {
        iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
        Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
    }
    hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &new);
    dPtr->proc = proc;
    dPtr->clientData = clientData;
    Tcl_SetHashValue(hPtr, dPtr);
}
 
/*
 *--------------------------------------------------------------
 *
 * Tcl_DontCallWhenDeleted --
 *
 *      Cancel the arrangement for a procedure to be called when
 *      a given interpreter is deleted.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      If proc and clientData were previously registered as a
 *      callback via Tcl_CallWhenDeleted, they are unregistered.
 *      If they weren't previously registered then nothing
 *      happens.
 *
 *--------------------------------------------------------------
 */
 
void
Tcl_DontCallWhenDeleted(interp, proc, clientData)
    Tcl_Interp *interp;         /* Interpreter to watch. */
    Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter
                                 * is about to be deleted. */
    ClientData clientData;      /* One-word value to pass to proc. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_HashTable *hTablePtr;
    Tcl_HashSearch hSearch;
    Tcl_HashEntry *hPtr;
    AssocData *dPtr;
 
    hTablePtr = iPtr->assocData;
    if (hTablePtr == (Tcl_HashTable *) NULL) {
        return;
    }
    for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL;
            hPtr = Tcl_NextHashEntry(&hSearch)) {
        dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
        if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) {
            ckfree((char *) dPtr);
            Tcl_DeleteHashEntry(hPtr);
            return;
        }
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetAssocData --
 *
 *      Creates a named association between user-specified data, a delete
 *      function and this interpreter. If the association already exists
 *      the data is overwritten with the new data. The delete function will
 *      be invoked when the interpreter is deleted.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      Sets the associated data, creates the association if needed.
 *
 *----------------------------------------------------------------------
 */
 
void
Tcl_SetAssocData(interp, name, proc, clientData)
    Tcl_Interp *interp;         /* Interpreter to associate with. */
    char *name;                 /* Name for association. */
    Tcl_InterpDeleteProc *proc; /* Proc to call when interpreter is
                                 * about to be deleted. */
    ClientData clientData;      /* One-word value to pass to proc. */
{
    Interp *iPtr = (Interp *) interp;
    AssocData *dPtr;
    Tcl_HashEntry *hPtr;
    int new;
 
    if (iPtr->assocData == (Tcl_HashTable *) NULL) {
        iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
        Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
    }
    hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &new);
    if (new == 0) {
        dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
    } else {
        dPtr = (AssocData *) ckalloc(sizeof(AssocData));
    }
    dPtr->proc = proc;
    dPtr->clientData = clientData;
 
    Tcl_SetHashValue(hPtr, dPtr);
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteAssocData --
 *
 *      Deletes a named association of user-specified data with
 *      the specified interpreter.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      Deletes the association.
 *
 *----------------------------------------------------------------------
 */
 
void
Tcl_DeleteAssocData(interp, name)
    Tcl_Interp *interp;                 /* Interpreter to associate with. */
    char *name;                         /* Name of association. */
{
    Interp *iPtr = (Interp *) interp;
    AssocData *dPtr;
    Tcl_HashEntry *hPtr;
 
    if (iPtr->assocData == (Tcl_HashTable *) NULL) {
        return;
    }
    hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
    if (hPtr == (Tcl_HashEntry *) NULL) {
        return;
    }
    dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
    if (dPtr->proc != NULL) {
        (dPtr->proc) (dPtr->clientData, interp);
    }
    ckfree((char *) dPtr);
    Tcl_DeleteHashEntry(hPtr);
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetAssocData --
 *
 *      Returns the client data associated with this name in the
 *      specified interpreter.
 *
 * Results:
 *      The client data in the AssocData record denoted by the named
 *      association, or NULL.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */
 
ClientData
Tcl_GetAssocData(interp, name, procPtr)
    Tcl_Interp *interp;                 /* Interpreter associated with. */
    char *name;                         /* Name of association. */
    Tcl_InterpDeleteProc **procPtr;     /* Pointer to place to store address
                                         * of current deletion callback. */
{
    Interp *iPtr = (Interp *) interp;
    AssocData *dPtr;
    Tcl_HashEntry *hPtr;
 
    if (iPtr->assocData == (Tcl_HashTable *) NULL) {
        return (ClientData) NULL;
    }
    hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
    if (hPtr == (Tcl_HashEntry *) NULL) {
        return (ClientData) NULL;
    }
    dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
    if (procPtr != (Tcl_InterpDeleteProc **) NULL) {
        *procPtr = dPtr->proc;
    }
    return dPtr->clientData;
}
 
/*
 *----------------------------------------------------------------------
 *
 * DeleteInterpProc --
 *
 *      Helper procedure to delete an interpreter. This procedure is
 *      called when the last call to Tcl_Preserve on this interpreter
 *      is matched by a call to Tcl_Release. The procedure cleans up
 *      all resources used in the interpreter and calls all currently
 *      registered interpreter deletion callbacks.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      Whatever the interpreter deletion callbacks do. Frees resources
 *      used by the interpreter.
 *
 *----------------------------------------------------------------------
 */
 
static void
DeleteInterpProc(interp)
    Tcl_Interp *interp;                 /* Interpreter to delete. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;
    Tcl_HashTable *hTablePtr;
    AssocData *dPtr;
    ResolverScheme *resPtr, *nextResPtr;
    int i;
 
    /*
     * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup.
     */
 
    if (iPtr->numLevels > 0) {
        panic("DeleteInterpProc called with active evals");
    }
 
    /*
     * The interpreter should already be marked deleted; otherwise how
     * did we get here?
     */
 
    if (!(iPtr->flags & DELETED)) {
        panic("DeleteInterpProc called on interpreter not marked deleted");
    }
 
    /*
     * Dismantle everything in the global namespace except for the
     * "errorInfo" and "errorCode" variables. These remain until the
     * namespace is actually destroyed, in case any errors occur.
     *
     * Dismantle the namespace here, before we clear the assocData. If any
     * background errors occur here, they will be deleted below.
     */
 
    TclTeardownNamespace(iPtr->globalNsPtr);
 
    /*
     * Tear down the math function table.
     */
 
    for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &search);
             hPtr != NULL;
             hPtr = Tcl_NextHashEntry(&search)) {
        ckfree((char *) Tcl_GetHashValue(hPtr));
    }
    Tcl_DeleteHashTable(&iPtr->mathFuncTable);
 
    /*
     * Invoke deletion callbacks; note that a callback can create new
     * callbacks, so we iterate.
     */
 
    while (iPtr->assocData != (Tcl_HashTable *) NULL) {
        hTablePtr = iPtr->assocData;
        iPtr->assocData = (Tcl_HashTable *) NULL;
        for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
                 hPtr != NULL;
                 hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) {
            dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
            Tcl_DeleteHashEntry(hPtr);
            if (dPtr->proc != NULL) {
                (*dPtr->proc)(dPtr->clientData, interp);
            }
            ckfree((char *) dPtr);
        }
        Tcl_DeleteHashTable(hTablePtr);
        ckfree((char *) hTablePtr);
    }
 
    /*
     * Finish deleting the global namespace.
     */
 
    Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr);
 
    /*
     * Free up the result *after* deleting variables, since variable
     * deletion could have transferred ownership of the result string
     * to Tcl.
     */
 
    Tcl_FreeResult(interp);
    interp->result = NULL;
    Tcl_DecrRefCount(iPtr->objResultPtr);
    iPtr->objResultPtr = NULL;
    if (iPtr->errorInfo != NULL) {
        ckfree(iPtr->errorInfo);
        iPtr->errorInfo = NULL;
    }
    if (iPtr->errorCode != NULL) {
        ckfree(iPtr->errorCode);
        iPtr->errorCode = NULL;
    }
    if (iPtr->appendResult != NULL) {
        ckfree(iPtr->appendResult);
        iPtr->appendResult = NULL;
    }
    for (i = 0; i < NUM_REGEXPS; i++) {
        if (iPtr->patterns[i] == NULL) {
            break;
        }
        ckfree(iPtr->patterns[i]);
        ckfree((char *) iPtr->regexps[i]);
        iPtr->regexps[i] = NULL;
    }
    TclFreePackageInfo(iPtr);
    while (iPtr->tracePtr != NULL) {
        Trace *nextPtr = iPtr->tracePtr->nextPtr;
 
        ckfree((char *) iPtr->tracePtr);
        iPtr->tracePtr = nextPtr;
    }
    if (iPtr->execEnvPtr != NULL) {
        TclDeleteExecEnv(iPtr->execEnvPtr);
    }
    Tcl_DecrRefCount(iPtr->emptyObjPtr);
    iPtr->emptyObjPtr = NULL;
 
    resPtr = iPtr->resolverPtr;
    while (resPtr) {
        nextResPtr = resPtr->nextPtr;
        ckfree(resPtr->name);
        ckfree((char *) resPtr);
        resPtr = nextResPtr;
    }
 
    ckfree((char *) iPtr);
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_InterpDeleted --
 *
 *      Returns nonzero if the interpreter has been deleted with a call
 *      to Tcl_DeleteInterp.
 *
 * Results:
 *      Nonzero if the interpreter is deleted, zero otherwise.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */
 
int
Tcl_InterpDeleted(interp)
    Tcl_Interp *interp;
{
    return (((Interp *) interp)->flags & DELETED) ? 1 : 0;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteInterp --
 *
 *      Ensures that the interpreter will be deleted eventually. If there
 *      are no Tcl_Preserve calls in effect for this interpreter, it is
 *      deleted immediately, otherwise the interpreter is deleted when
 *      the last Tcl_Preserve is matched by a call to Tcl_Release. In either
 *      case, the procedure runs the currently registered deletion callbacks.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      The interpreter is marked as deleted. The caller may still use it
 *      safely if there are calls to Tcl_Preserve in effect for the
 *      interpreter, but further calls to Tcl_Eval etc in this interpreter
 *      will fail.
 *
 *----------------------------------------------------------------------
 */
 
void
Tcl_DeleteInterp(interp)
    Tcl_Interp *interp;         /* Token for command interpreter (returned
                                 * by a previous call to Tcl_CreateInterp). */
{
    Interp *iPtr = (Interp *) interp;
 
    /*
     * If the interpreter has already been marked deleted, just punt.
     */
 
    if (iPtr->flags & DELETED) {
        return;
    }
 
    /*
     * Mark the interpreter as deleted. No further evals will be allowed.
     */
 
    iPtr->flags |= DELETED;
 
    /*
     * Ensure that the interpreter is eventually deleted.
     */
 
    Tcl_EventuallyFree((ClientData) interp,
            (Tcl_FreeProc *) DeleteInterpProc);
}
 
/*
 *----------------------------------------------------------------------
 *
 * HiddenCmdsDeleteProc --
 *
 *      Called on interpreter deletion to delete all the hidden
 *      commands in an interpreter.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      Frees up memory.
 *
 *----------------------------------------------------------------------
 */
 
static void
HiddenCmdsDeleteProc(clientData, interp)
    ClientData clientData;              /* The hidden commands hash table. */
    Tcl_Interp *interp;                 /* The interpreter being deleted. */
{
    Tcl_HashTable *hiddenCmdTblPtr;
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch hSearch;
    Command *cmdPtr;
 
    hiddenCmdTblPtr = (Tcl_HashTable *) clientData;
    for (hPtr = Tcl_FirstHashEntry(hiddenCmdTblPtr, &hSearch);
             hPtr != NULL;
             hPtr = Tcl_FirstHashEntry(hiddenCmdTblPtr, &hSearch)) {
 
        /*
         * Cannot use Tcl_DeleteCommand because (a) the command is not
         * in the command hash table, and (b) that table has already been
         * deleted above. Hence we emulate what it does, below.
         */
 
        cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
 
        /*
         * The code here is tricky.  We can't delete the hash table entry
         * before invoking the deletion callback because there are cases
         * where the deletion callback needs to invoke the command (e.g.
         * object systems such as OTcl).  However, this means that the
         * callback could try to delete or rename the command.  The deleted
         * flag allows us to detect these cases and skip nested deletes.
         */
 
        if (cmdPtr->deleted) {
 
            /*
             * Another deletion is already in progress.  Remove the hash
             * table entry now, but don't invoke a callback or free the
             * command structure.
             */
 
            Tcl_DeleteHashEntry(cmdPtr->hPtr);
            cmdPtr->hPtr = NULL;
            continue;
        }
        cmdPtr->deleted = 1;
        if (cmdPtr->deleteProc != NULL) {
            (*cmdPtr->deleteProc)(cmdPtr->deleteData);
        }
 
        /*
         * Bump the command epoch counter. This will invalidate all cached
         * references that refer to this command.
         */
 
        cmdPtr->cmdEpoch++;
 
        /*
         * Don't use hPtr to delete the hash entry here, because it's
         * possible that the deletion callback renamed the command.
         * Instead, use cmdPtr->hptr, and make sure that no-one else
         * has already deleted the hash entry.
         */
 
        if (cmdPtr->hPtr != NULL) {
            Tcl_DeleteHashEntry(cmdPtr->hPtr);
        }
 
        /*
         * Now free the Command structure, unless there is another reference
         * to it from a CmdName Tcl object in some ByteCode code
         * sequence. In that case, delay the cleanup until all references
         * are either discarded (when a ByteCode is freed) or replaced by a
         * new reference (when a cached CmdName Command reference is found
         * to be invalid and TclExecuteByteCode looks up the command in the
         * command hashtable).
         */
 
        TclCleanupCommand(cmdPtr);
    }
    Tcl_DeleteHashTable(hiddenCmdTblPtr);
    ckfree((char *) hiddenCmdTblPtr);
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_HideCommand --
 *
 *      Makes a command hidden so that it cannot be invoked from within
 *      an interpreter, only from within an ancestor.
 *
 * Results:
 *      A standard Tcl result; also leaves a message in interp->result
 *      if an error occurs.
 *
 * Side effects:
 *      Removes a command from the command table and create an entry
 *      into the hidden command table under the specified token name.
 *
 *----------------------------------------------------------------------
 */
 
int
Tcl_HideCommand(interp, cmdName, hiddenCmdToken)
    Tcl_Interp *interp;         /* Interpreter in which to hide command. */
    char *cmdName;              /* Name of command to hide. */
    char *hiddenCmdToken;       /* Token name of the to-be-hidden command. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Command cmd;
    Command *cmdPtr;
    Tcl_HashTable *hTblPtr;
    Tcl_HashEntry *hPtr;
    int new;
 
    if (iPtr->flags & DELETED) {
 
        /*
         * The interpreter is being deleted. Do not create any new
         * structures, because it is not safe to modify the interpreter.
         */
 
        return TCL_ERROR;
    }
 
    /*
     * Disallow hiding of commands that are currently in a namespace or
     * renaming (as part of hiding) into a namespace.
     *
     * (because the current implementation with a single global table
     *  and the needed uniqueness of names cause problems with namespaces)
     *
     * we don't need to check for "::" in cmdName because the real check is
     * on the nsPtr below.
     *
     * hiddenCmdToken is just a string which is not interpreted in any way.
     * It may contain :: but the string is not interpreted as a namespace
     * qualifier command name. Thus, hiding foo::bar to foo::bar and then
     * trying to expose or invoke ::foo::bar will NOT work; but if the
     * application always uses the same strings it will get consistent
     * behaviour.
     *
     * But as we currently limit ourselves to the global namespace only
     * for the source, in order to avoid potential confusion,
     * lets prevent "::" in the token too.  --dl
     */
 
    if (strstr(hiddenCmdToken, "::") != NULL) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "cannot use namespace qualifiers as hidden command",
                "token (rename)", (char *) NULL);
        return TCL_ERROR;
    }
 
    /*
     * Find the command to hide. An error is returned if cmdName can't
     * be found. Look up the command only from the global namespace.
     * Full path of the command must be given if using namespaces.
     */
 
    cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
            /*flags*/ TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY);
    if (cmd == (Tcl_Command) NULL) {
        return TCL_ERROR;
    }
    cmdPtr = (Command *) cmd;
 
    /*
     * Check that the command is really in global namespace
     */
 
    if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "can only hide global namespace commands",
                " (use rename then hide)", (char *) NULL);
        return TCL_ERROR;
    }
 
    /*
     * Initialize the hidden command table if necessary.
     */
 
    hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclHiddenCmds",
            NULL);
    if (hTblPtr == (Tcl_HashTable *) NULL) {
        hTblPtr = (Tcl_HashTable *)
                ckalloc((unsigned) sizeof(Tcl_HashTable));
        Tcl_InitHashTable(hTblPtr, TCL_STRING_KEYS);
        Tcl_SetAssocData(interp, "tclHiddenCmds", HiddenCmdsDeleteProc,
                (ClientData) hTblPtr);
    }
 
    /*
     * It is an error to move an exposed command to a hidden command with
     * hiddenCmdToken if a hidden command with the name hiddenCmdToken already
     * exists.
     */
 
    hPtr = Tcl_CreateHashEntry(hTblPtr, hiddenCmdToken, &new);
    if (!new) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "hidden command named \"", hiddenCmdToken, "\" already exists",
                (char *) NULL);
        return TCL_ERROR;
    }
 
    /*
     * Nb : This code is currently 'like' a rename to a specialy set apart
     * name table. Changes here and in TclRenameCommand must
     * be kept in synch untill the common parts are actually
     * factorized out.
     */
 
    /*
     * Remove the hash entry for the command from the interpreter command
     * table. This is like deleting the command, so bump its command epoch;
     * this invalidates any cached references that point to the command.
     */
 
    if (cmdPtr->hPtr != NULL) {
        Tcl_DeleteHashEntry(cmdPtr->hPtr);
        cmdPtr->hPtr = (Tcl_HashEntry *) NULL;
        cmdPtr->cmdEpoch++;
    }
 
    /*
     * Now link the hash table entry with the command structure.
     * We ensured above that the nsPtr was right.
     */
 
    cmdPtr->hPtr = hPtr;
    Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);
 
    /*
     * If the command being hidden has a compile procedure, increment the
     * interpreter's compileEpoch to invalidate its compiled code. This
     * makes sure that we don't later try to execute old code compiled with
     * command-specific (i.e., inline) bytecodes for the now-hidden
     * command. This field is checked in Tcl_EvalObj and ObjInterpProc,
     * and code whose compilation epoch doesn't match is recompiled.
     */
 
    if (cmdPtr->compileProc != NULL) {
        iPtr->compileEpoch++;
    }
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_ExposeCommand --
 *
 *      Makes a previously hidden command callable from inside the
 *      interpreter instead of only by its ancestors.
 *
 * Results:
 *      A standard Tcl result. If an error occurs, a message is left
 *      in interp->result.
 *
 * Side effects:
 *      Moves commands from one hash table to another.
 *
 *----------------------------------------------------------------------
 */
 
int
Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName)
    Tcl_Interp *interp;         /* Interpreter in which to make command
                                 * callable. */
    char *hiddenCmdToken;       /* Name of hidden command. */
    char *cmdName;              /* Name of to-be-exposed command. */
{
    Interp *iPtr = (Interp *) interp;
    Command *cmdPtr;
    Namespace *nsPtr;
    Tcl_HashEntry *hPtr;
    Tcl_HashTable *hTblPtr;
    int new;
 
    if (iPtr->flags & DELETED) {
        /*
         * The interpreter is being deleted. Do not create any new
         * structures, because it is not safe to modify the interpreter.
         */
 
        return TCL_ERROR;
    }
 
    /*
     * Check that we have a regular name for the command
     * (that the user is not trying to do an expose and a rename
     *  (to another namespace) at the same time)
     */
 
    if (strstr(cmdName, "::") != NULL) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "can not expose to a namespace ",
                "(use expose to toplevel, then rename)",
                 (char *) NULL);
        return TCL_ERROR;
    }
 
    /*
     * Find the hash table for the hidden commands; error out if there
     * is none.
     */
 
    hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclHiddenCmds",
            NULL);
    if (hTblPtr == NULL) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "unknown hidden command \"", hiddenCmdToken,
                "\"", (char *) NULL);
        return TCL_ERROR;
    }
 
    /*
     * Get the command from the hidden command table:
     */
 
    hPtr = Tcl_FindHashEntry(hTblPtr, hiddenCmdToken);
    if (hPtr == (Tcl_HashEntry *) NULL) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "unknown hidden command \"", hiddenCmdToken,
                "\"", (char *) NULL);
        return TCL_ERROR;
    }
    cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
 
 
    /*
     * Check that we have a true global namespace
     * command (enforced by Tcl_HideCommand() but let's double
     * check. (If it was not, we would not really know how to
     * handle it).
     */
    if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) {
        /*
         * This case is theoritically impossible,
         * we might rather panic() than 'nicely' erroring out ?
         */
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "trying to expose a non global command name space command",
                (char *) NULL);
        return TCL_ERROR;
    }
 
    /* This is the global table */
    nsPtr = cmdPtr->nsPtr;
 
    /*
     * It is an error to overwrite an existing exposed command as a result
     * of exposing a previously hidden command.
     */
 
    hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &new);
    if (!new) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "exposed command \"", cmdName,
                "\" already exists", (char *) NULL);
        return TCL_ERROR;
    }
 
    /*
     * Remove the hash entry for the command from the interpreter hidden
     * command table.
     */
 
    if (cmdPtr->hPtr != NULL) {
        Tcl_DeleteHashEntry(cmdPtr->hPtr);
        cmdPtr->hPtr = NULL;
    }
 
    /*
     * Now link the hash table entry with the command structure.
     * This is like creating a new command, so deal with any shadowing
     * of commands in the global namespace.
     */
 
    cmdPtr->hPtr = hPtr;
 
    Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);
 
    /*
     * Not needed as we are only in the global namespace
     * (but would be needed again if we supported namespace command hiding)
     *
     * TclResetShadowedCmdRefs(interp, cmdPtr);
     */
 
 
    /*
     * If the command being exposed has a compile procedure, increment
     * interpreter's compileEpoch to invalidate its compiled code. This
     * makes sure that we don't later try to execute old code compiled
     * assuming the command is hidden. This field is checked in Tcl_EvalObj
     * and ObjInterpProc, and code whose compilation epoch doesn't match is
     * recompiled.
     */
 
    if (cmdPtr->compileProc != NULL) {
        iPtr->compileEpoch++;
    }
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateCommand --
 *
 *      Define a new command in a command table.
 *
 * Results:
 *      The return value is a token for the command, which can
 *      be used in future calls to Tcl_GetCommandName.
 *
 * Side effects:
 *      If a command named cmdName already exists for interp, it is deleted.
 *      In the future, when cmdName is seen as the name of a command by
 *      Tcl_Eval, proc will be called. To support the bytecode interpreter,
 *      the command is created with a wrapper Tcl_ObjCmdProc
 *      (TclInvokeStringCommand) that eventially calls proc. When the
 *      command is deleted from the table, deleteProc will be called.
 *      See the manual entry for details on the calling sequence.
 *
 *----------------------------------------------------------------------
 */
 
Tcl_Command
Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
    Tcl_Interp *interp;         /* Token for command interpreter returned by
                                 * a previous call to Tcl_CreateInterp. */
    char *cmdName;              /* Name of command. If it contains namespace
                                 * qualifiers, the new command is put in the
                                 * specified namespace; otherwise it is put
                                 * in the global namespace. */
    Tcl_CmdProc *proc;          /* Procedure to associate with cmdName. */
    ClientData clientData;      /* Arbitrary value passed to string proc. */
    Tcl_CmdDeleteProc *deleteProc;
                                /* If not NULL, gives a procedure to call
                                 * when this command is deleted. */
{
    Interp *iPtr = (Interp *) interp;
    ImportRef *oldRefPtr = NULL;
    Namespace *nsPtr, *dummy1, *dummy2;
    Command *cmdPtr, *refCmdPtr;
    Tcl_HashEntry *hPtr;
    char *tail;
    int new, result;
    ImportedCmdData *dataPtr;
 
    if (iPtr->flags & DELETED) {
        /*
         * The interpreter is being deleted.  Don't create any new
         * commands; it's not safe to muck with the interpreter anymore.
         */
 
        return (Tcl_Command) NULL;
    }
 
    /*
     * Determine where the command should reside. If its name contains
     * namespace qualifiers, we put it in the specified namespace;
     * otherwise, we always put it in the global namespace.
     */
 
    if (strstr(cmdName, "::") != NULL) {
        result = TclGetNamespaceForQualName(interp, cmdName,
                (Namespace *) NULL, CREATE_NS_IF_UNKNOWN, &nsPtr,
                &dummy1, &dummy2, &tail);
        if ((result != TCL_OK) || (nsPtr == NULL) || (tail == NULL)) {
            return (Tcl_Command) NULL;
        }
    } else {
        nsPtr = iPtr->globalNsPtr;
        tail = cmdName;
    }
 
    hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
    if (!new) {
        /*
         * Command already exists. Delete the old one.
         * Be careful to preserve any existing import links so we can
         * restore them down below.  That way, you can redefine a
         * command and its import status will remain intact.
         */
 
        cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
        oldRefPtr = cmdPtr->importRefPtr;
        cmdPtr->importRefPtr = NULL;
 
        Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
        hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
        if (!new) {
            /*
             * If the deletion callback recreated the command, just throw
             * away the new command (if we try to delete it again, we
             * could get stuck in an infinite loop).
             */
 
             ckfree((char*) cmdPtr);
        }
    }
    cmdPtr = (Command *) ckalloc(sizeof(Command));
    Tcl_SetHashValue(hPtr, cmdPtr);
    cmdPtr->hPtr = hPtr;
    cmdPtr->nsPtr = nsPtr;
    cmdPtr->refCount = 1;
    cmdPtr->cmdEpoch = 0;
    cmdPtr->compileProc = (CompileProc *) NULL;
    cmdPtr->objProc = TclInvokeStringCommand;
    cmdPtr->objClientData = (ClientData) cmdPtr;
    cmdPtr->proc = proc;
    cmdPtr->clientData = clientData;
    cmdPtr->deleteProc = deleteProc;
    cmdPtr->deleteData = clientData;
    cmdPtr->deleted = 0;
    cmdPtr->importRefPtr = NULL;
 
    /*
     * Plug in any existing import references found above.  Be sure
     * to update all of these references to point to the new command.
     */
 
    if (oldRefPtr != NULL) {
        cmdPtr->importRefPtr = oldRefPtr;
        while (oldRefPtr != NULL) {
            refCmdPtr = oldRefPtr->importedCmdPtr;
            dataPtr = (ImportedCmdData*)refCmdPtr->objClientData;
            dataPtr->realCmdPtr = cmdPtr;
            oldRefPtr = oldRefPtr->nextPtr;
        }
    }
 
    /*
     * We just created a command, so in its namespace and all of its parent
     * namespaces, it may shadow global commands with the same name. If any
     * shadowed commands are found, invalidate all cached command references
     * in the affected namespaces.
     */
 
    TclResetShadowedCmdRefs(interp, cmdPtr);
    return (Tcl_Command) cmdPtr;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateObjCommand --
 *
 *      Define a new object-based command in a command table.
 *
 * Results:
 *      The return value is a token for the command, which can
 *      be used in future calls to Tcl_NameOfCommand.
 *
 * Side effects:
 *      If no command named "cmdName" already exists for interp, one is
 *      created. Otherwise, if a command does exist, then if the
 *      object-based Tcl_ObjCmdProc is TclInvokeStringCommand, we assume
 *      Tcl_CreateCommand was called previously for the same command and
 *      just set its Tcl_ObjCmdProc to the argument "proc"; otherwise, we
 *      delete the old command.
 *
 *      In the future, during bytecode evaluation when "cmdName" is seen as
 *      the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based
 *      Tcl_ObjCmdProc proc will be called. When the command is deleted from
 *      the table, deleteProc will be called. See the manual entry for
 *      details on the calling sequence.
 *
 *----------------------------------------------------------------------
 */
 
Tcl_Command
Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc)
    Tcl_Interp *interp;         /* Token for command interpreter (returned
                                 * by previous call to Tcl_CreateInterp). */
    char *cmdName;              /* Name of command. If it contains namespace
                                 * qualifiers, the new command is put in the
                                 * specified namespace; otherwise it is put
                                 * in the global namespace. */
    Tcl_ObjCmdProc *proc;       /* Object-based procedure to associate with
                                 * name. */
    ClientData clientData;      /* Arbitrary value to pass to object
                                 * procedure. */
    Tcl_CmdDeleteProc *deleteProc;
                                /* If not NULL, gives a procedure to call
                                 * when this command is deleted. */
{
    Interp *iPtr = (Interp *) interp;
    ImportRef *oldRefPtr = NULL;
    Namespace *nsPtr, *dummy1, *dummy2;
    Command *cmdPtr, *refCmdPtr;
    Tcl_HashEntry *hPtr;
    char *tail;
    int new, result;
    ImportedCmdData *dataPtr;
 
    if (iPtr->flags & DELETED) {
        /*
         * The interpreter is being deleted.  Don't create any new
         * commands;  it's not safe to muck with the interpreter anymore.
         */
 
        return (Tcl_Command) NULL;
    }
 
    /*
     * Determine where the command should reside. If its name contains
     * namespace qualifiers, we put it in the specified namespace;
     * otherwise, we always put it in the global namespace.
     */
 
    if (strstr(cmdName, "::") != NULL) {
        result = TclGetNamespaceForQualName(interp, cmdName,
                (Namespace *) NULL, CREATE_NS_IF_UNKNOWN, &nsPtr,
                &dummy1, &dummy2, &tail);
        if ((result != TCL_OK) || (nsPtr == NULL) || (tail == NULL)) {
            return (Tcl_Command) NULL;
        }
    } else {
        nsPtr = iPtr->globalNsPtr;
        tail = cmdName;
    }
 
    hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
    if (!new) {
        cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
 
        /*
         * Command already exists. If its object-based Tcl_ObjCmdProc is
         * TclInvokeStringCommand, we just set its Tcl_ObjCmdProc to the
         * argument "proc". Otherwise, we delete the old command.
         */
 
        if (cmdPtr->objProc == TclInvokeStringCommand) {
            cmdPtr->objProc = proc;
            cmdPtr->objClientData = clientData;
            cmdPtr->deleteProc = deleteProc;
            cmdPtr->deleteData = clientData;
            return (Tcl_Command) cmdPtr;
        }
 
        /*
         * Otherwise, we delete the old command.  Be careful to preserve
         * any existing import links so we can restore them down below.
         * That way, you can redefine a command and its import status
         * will remain intact.
         */
 
        oldRefPtr = cmdPtr->importRefPtr;
        cmdPtr->importRefPtr = NULL;
 
        Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
        hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
        if (!new) {
            /*
             * If the deletion callback recreated the command, just throw
             * away the new command (if we try to delete it again, we
             * could get stuck in an infinite loop).
             */
 
             ckfree((char *) Tcl_GetHashValue(hPtr));
        }
    }
    cmdPtr = (Command *) ckalloc(sizeof(Command));
    Tcl_SetHashValue(hPtr, cmdPtr);
    cmdPtr->hPtr = hPtr;
    cmdPtr->nsPtr = nsPtr;
    cmdPtr->refCount = 1;
    cmdPtr->cmdEpoch = 0;
    cmdPtr->compileProc = (CompileProc *) NULL;
    cmdPtr->objProc = proc;
    cmdPtr->objClientData = clientData;
    cmdPtr->proc = TclInvokeObjectCommand;
    cmdPtr->clientData = (ClientData) cmdPtr;
    cmdPtr->deleteProc = deleteProc;
    cmdPtr->deleteData = clientData;
    cmdPtr->deleted = 0;
    cmdPtr->importRefPtr = NULL;
 
    /*
     * Plug in any existing import references found above.  Be sure
     * to update all of these references to point to the new command.
     */
 
    if (oldRefPtr != NULL) {
        cmdPtr->importRefPtr = oldRefPtr;
        while (oldRefPtr != NULL) {
            refCmdPtr = oldRefPtr->importedCmdPtr;
            dataPtr = (ImportedCmdData*)refCmdPtr->objClientData;
            dataPtr->realCmdPtr = cmdPtr;
            oldRefPtr = oldRefPtr->nextPtr;
        }
    }
 
    /*
     * We just created a command, so in its namespace and all of its parent
     * namespaces, it may shadow global commands with the same name. If any
     * shadowed commands are found, invalidate all cached command references
     * in the affected namespaces.
     */
 
    TclResetShadowedCmdRefs(interp, cmdPtr);
    return (Tcl_Command) cmdPtr;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclInvokeStringCommand --
 *
 *      "Wrapper" Tcl_ObjCmdProc used to call an existing string-based
 *      Tcl_CmdProc if no object-based procedure exists for a command. A
 *      pointer to this procedure is stored as the Tcl_ObjCmdProc in a
 *      Command structure. It simply turns around and calls the string
 *      Tcl_CmdProc in the Command structure.
 *
 * Results:
 *      A standard Tcl object result value.
 *
 * Side effects:
 *      Besides those side effects of the called Tcl_CmdProc,
 *      TclInvokeStringCommand allocates and frees storage.
 *
 *----------------------------------------------------------------------
 */
 
int
TclInvokeStringCommand(clientData, interp, objc, objv)
    ClientData clientData;      /* Points to command's Command structure. */
    Tcl_Interp *interp;         /* Current interpreter. */
    register int objc;          /* Number of arguments. */
    Tcl_Obj *CONST objv[];      /* Argument objects. */
{
    register Command *cmdPtr = (Command *) clientData;
    register int i;
    int result;
 
    /*
     * This procedure generates an argv array for the string arguments. It
     * starts out with stack-allocated space but uses dynamically-allocated
     * storage if needed.
     */
 
#define NUM_ARGS 20
    char *(argStorage[NUM_ARGS]);
    char **argv = argStorage;
 
    /*
     * Create the string argument array "argv". Make sure argv is large
     * enough to hold the objc arguments plus 1 extra for the zero
     * end-of-argv word.
     * THIS FAILS IF ANY ARGUMENT OBJECT CONTAINS AN EMBEDDED NULL.
     */
 
    if ((objc + 1) > NUM_ARGS) {
        argv = (char **) ckalloc((unsigned)(objc + 1) * sizeof(char *));
    }
 
    for (i = 0;  i < objc;  i++) {
        argv[i] = Tcl_GetStringFromObj(objv[i], (int *) NULL);
    }
    argv[objc] = 0;
 
    /*
     * Invoke the command's string-based Tcl_CmdProc.
     */
 
    result = (*cmdPtr->proc)(cmdPtr->clientData, interp, objc, argv);
 
    /*
     * Free the argv array if malloc'ed storage was used.
     */
 
    if (argv != argStorage) {
        ckfree((char *) argv);
    }
    return result;
#undef NUM_ARGS
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclInvokeObjectCommand --
 *
 *      "Wrapper" Tcl_CmdProc used to call an existing object-based
 *      Tcl_ObjCmdProc if no string-based procedure exists for a command.
 *      A pointer to this procedure is stored as the Tcl_CmdProc in a
 *      Command structure. It simply turns around and calls the object
 *      Tcl_ObjCmdProc in the Command structure.
 *
 * Results:
 *      A standard Tcl string result value.
 *
 * Side effects:
 *      Besides those side effects of the called Tcl_CmdProc,
 *      TclInvokeStringCommand allocates and frees storage.
 *
 *----------------------------------------------------------------------
 */
 
int
TclInvokeObjectCommand(clientData, interp, argc, argv)
    ClientData clientData;      /* Points to command's Command structure. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int argc;                   /* Number of arguments. */
    register char **argv;       /* Argument strings. */
{
    Command *cmdPtr = (Command *) clientData;
    register Tcl_Obj *objPtr;
    register int i;
    int length, result;
 
    /*
     * This procedure generates an objv array for object arguments that hold
     * the argv strings. It starts out with stack-allocated space but uses
     * dynamically-allocated storage if needed.
     */
 
#define NUM_ARGS 20
    Tcl_Obj *(argStorage[NUM_ARGS]);
    register Tcl_Obj **objv = argStorage;
 
    /*
     * Create the object argument array "objv". Make sure objv is large
     * enough to hold the objc arguments plus 1 extra for the zero
     * end-of-objv word.
     */
 
    if ((argc + 1) > NUM_ARGS) {
        objv = (Tcl_Obj **)
            ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *));
    }
 
    for (i = 0;  i < argc;  i++) {
        length = strlen(argv[i]);
        TclNewObj(objPtr);
        TclInitStringRep(objPtr, argv[i], length);
        Tcl_IncrRefCount(objPtr);
        objv[i] = objPtr;
    }
    objv[argc] = 0;
 
    /*
     * Invoke the command's object-based Tcl_ObjCmdProc.
     */
 
    result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, argc, objv);
 
    /*
     * Move the interpreter's object result to the string result,
     * then reset the object result.
     * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULL BYTES.
     */
 
    Tcl_SetResult(interp,
            TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL),
            TCL_VOLATILE);
 
    /*
     * Decrement the ref counts for the argument objects created above,
     * then free the objv array if malloc'ed storage was used.
     */
 
    for (i = 0;  i < argc;  i++) {
        objPtr = objv[i];
        Tcl_DecrRefCount(objPtr);
    }
    if (objv != argStorage) {
        ckfree((char *) objv);
    }
    return result;
#undef NUM_ARGS
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclRenameCommand --
 *
 *      Called to give an existing Tcl command a different name. Both the
 *      old command name and the new command name can have "::" namespace
 *      qualifiers. If the new command has a different namespace context,
 *      the command will be moved to that namespace and will execute in
 *      the context of that new namespace.
 *
 *      If the new command name is NULL or the null string, the command is
 *      deleted.
 *
 * Results:
 *      Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
 *
 * Side effects:
 *      If anything goes wrong, an error message is returned in the
 *      interpreter's result object.
 *
 *----------------------------------------------------------------------
 */
 
int
TclRenameCommand(interp, oldName, newName)
    Tcl_Interp *interp;                 /* Current interpreter. */
    char *oldName;                      /* Existing command name. */
    char *newName;                      /* New command name. */
{
    Interp *iPtr = (Interp *) interp;
    char *newTail;
    Namespace *cmdNsPtr, *newNsPtr, *dummy1, *dummy2;
    Tcl_Command cmd;
    Command *cmdPtr;
    Tcl_HashEntry *hPtr, *oldHPtr;
    int new, result;
 
    /*
     * Find the existing command. An error is returned if cmdName can't
     * be found.
     */
 
    cmd = Tcl_FindCommand(interp, oldName, (Tcl_Namespace *) NULL,
        /*flags*/ 0);
    cmdPtr = (Command *) cmd;
    if (cmdPtr == NULL) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't ",
                ((newName == NULL)||(*newName == '\0'))? "delete":"rename",
                " \"", oldName, "\": command doesn't exist", (char *) NULL);
        return TCL_ERROR;
    }
    cmdNsPtr = cmdPtr->nsPtr;
 
    /*
     * If the new command name is NULL or empty, delete the command. Do this
     * with Tcl_DeleteCommandFromToken, since we already have the command.
     */
 
    if ((newName == NULL) || (*newName == '\0')) {
        Tcl_DeleteCommandFromToken(interp, cmd);
        return TCL_OK;
    }
 
    /*
     * Make sure that the destination command does not already exist.
     * The rename operation is like creating a command, so we should
     * automatically create the containing namespaces just like
     * Tcl_CreateCommand would.
     */
 
    result = TclGetNamespaceForQualName(interp, newName, (Namespace *) NULL,
            (CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG),
            &newNsPtr, &dummy1, &dummy2, &newTail);
    if (result != TCL_OK) {
        return result;
    }
    if ((newNsPtr == NULL) || (newTail == NULL)) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                 "can't rename to \"", newName, "\": bad command name",
                 (char *) NULL);
        return TCL_ERROR;
    }
    if (Tcl_FindHashEntry(&newNsPtr->cmdTable, newTail) != NULL) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                 "can't rename to \"", newName,
                 "\": command already exists", (char *) NULL);
        return TCL_ERROR;
    }
 
 
    /*
     * Warning: any changes done in the code here are likely
     * to be needed in Tcl_HideCommand() code too.
     * (until the common parts are extracted out)     --dl
     */
 
    /*
     * Put the command in the new namespace so we can check for an alias
     * loop. Since we are adding a new command to a namespace, we must
     * handle any shadowing of the global commands that this might create.
     */
 
    oldHPtr = cmdPtr->hPtr;
    hPtr = Tcl_CreateHashEntry(&newNsPtr->cmdTable, newTail, &new);
    Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);
    cmdPtr->hPtr = hPtr;
    cmdPtr->nsPtr = newNsPtr;
    TclResetShadowedCmdRefs(interp, cmdPtr);
 
    /*
     * Now check for an alias loop. If we detect one, put everything back
     * the way it was and report the error.
     */
 
    result = TclPreventAliasLoop(interp, interp, (Tcl_Command) cmdPtr);
    if (result != TCL_OK) {
        Tcl_DeleteHashEntry(cmdPtr->hPtr);
        cmdPtr->hPtr = oldHPtr;
        cmdPtr->nsPtr = cmdNsPtr;
        return result;
    }
 
    /*
     * The new command name is okay, so remove the command from its
     * current namespace. This is like deleting the command, so bump
     * the cmdEpoch to invalidate any cached references to the command.
     */
 
    Tcl_DeleteHashEntry(oldHPtr);
    cmdPtr->cmdEpoch++;
 
    /*
     * If the command being renamed has a compile procedure, increment the
     * interpreter's compileEpoch to invalidate its compiled code. This
     * makes sure that we don't later try to execute old code compiled for
     * the now-renamed command.
     */
 
    if (cmdPtr->compileProc != NULL) {
        iPtr->compileEpoch++;
    }
 
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetCommandInfo --
 *
 *      Modifies various information about a Tcl command. Note that
 *      this procedure will not change a command's namespace; use
 *      Tcl_RenameCommand to do that. Also, the isNativeObjectProc
 *      member of *infoPtr is ignored.
 *
 * Results:
 *      If cmdName exists in interp, then the information at *infoPtr
 *      is stored with the command in place of the current information
 *      and 1 is returned. If the command doesn't exist then 0 is
 *      returned.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */
 
int
Tcl_SetCommandInfo(interp, cmdName, infoPtr)
    Tcl_Interp *interp;                 /* Interpreter in which to look
                                         * for command. */
    char *cmdName;                      /* Name of desired command. */
    Tcl_CmdInfo *infoPtr;               /* Where to store information about
                                         * command. */
{
    Tcl_Command cmd;
    Command *cmdPtr;
 
    cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
            /*flags*/ 0);
    if (cmd == (Tcl_Command) NULL) {
        return 0;
    }
 
    /*
     * The isNativeObjectProc and nsPtr members of *infoPtr are ignored.
     */
 
    cmdPtr = (Command *) cmd;
    cmdPtr->proc = infoPtr->proc;
    cmdPtr->clientData = infoPtr->clientData;
    if (infoPtr->objProc == (Tcl_ObjCmdProc *) NULL) {
        cmdPtr->objProc = TclInvokeStringCommand;
        cmdPtr->objClientData = (ClientData) cmdPtr;
    } else {
        cmdPtr->objProc = infoPtr->objProc;
        cmdPtr->objClientData = infoPtr->objClientData;
    }
    cmdPtr->deleteProc = infoPtr->deleteProc;
    cmdPtr->deleteData = infoPtr->deleteData;
    return 1;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetCommandInfo --
 *
 *      Returns various information about a Tcl command.
 *
 * Results:
 *      If cmdName exists in interp, then *infoPtr is modified to
 *      hold information about cmdName and 1 is returned.  If the
 *      command doesn't exist then 0 is returned and *infoPtr isn't
 *      modified.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */
 
int
Tcl_GetCommandInfo(interp, cmdName, infoPtr)
    Tcl_Interp *interp;                 /* Interpreter in which to look
                                         * for command. */
    char *cmdName;                      /* Name of desired command. */
    Tcl_CmdInfo *infoPtr;               /* Where to store information about
                                         * command. */
{
    Tcl_Command cmd;
    Command *cmdPtr;
 
    cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
            /*flags*/ 0);
    if (cmd == (Tcl_Command) NULL) {
        return 0;
    }
 
    /*
     * Set isNativeObjectProc 1 if objProc was registered by a call to
     * Tcl_CreateObjCommand. Otherwise set it to 0.
     */
 
    cmdPtr = (Command *) cmd;
    infoPtr->isNativeObjectProc =
            (cmdPtr->objProc != TclInvokeStringCommand);
    infoPtr->objProc = cmdPtr->objProc;
    infoPtr->objClientData = cmdPtr->objClientData;
    infoPtr->proc = cmdPtr->proc;
    infoPtr->clientData = cmdPtr->clientData;
    infoPtr->deleteProc = cmdPtr->deleteProc;
    infoPtr->deleteData = cmdPtr->deleteData;
    infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr;
    return 1;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetCommandName --
 *
 *      Given a token returned by Tcl_CreateCommand, this procedure
 *      returns the current name of the command (which may have changed
 *      due to renaming).
 *
 * Results:
 *      The return value is the name of the given command.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */
 
char *
Tcl_GetCommandName(interp, command)
    Tcl_Interp *interp;         /* Interpreter containing the command. */
    Tcl_Command command;        /* Token for command returned by a previous
                                 * call to Tcl_CreateCommand. The command
                                 * must not have been deleted. */
{
    Command *cmdPtr = (Command *) command;
 
    if ((cmdPtr == NULL) || (cmdPtr->hPtr == NULL)) {
 
        /*
         * This should only happen if command was "created" after the
         * interpreter began to be deleted, so there isn't really any
         * command. Just return an empty string.
         */
 
        return "";
    }
    return Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetCommandFullName --
 *
 *      Given a token returned by, e.g., Tcl_CreateCommand or
 *      Tcl_FindCommand, this procedure appends to an object the command's
 *      full name, qualified by a sequence of parent namespace names. The
 *      command's fully-qualified name may have changed due to renaming.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      The command's fully-qualified name is appended to the string
 *      representation of objPtr.
 *
 *----------------------------------------------------------------------
 */
 
void
Tcl_GetCommandFullName(interp, command, objPtr)
    Tcl_Interp *interp;         /* Interpreter containing the command. */
    Tcl_Command command;        /* Token for command returned by a previous
                                 * call to Tcl_CreateCommand. The command
                                 * must not have been deleted. */
    Tcl_Obj *objPtr;            /* Points to the object onto which the
                                 * command's full name is appended. */
 
{
    Interp *iPtr = (Interp *) interp;
    register Command *cmdPtr = (Command *) command;
    char *name;
 
    /*
     * Add the full name of the containing namespace, followed by the "::"
     * separator, and the command name.
     */
 
    if (cmdPtr != NULL) {
        if (cmdPtr->nsPtr != NULL) {
            Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, -1);
            if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
                Tcl_AppendToObj(objPtr, "::", 2);
            }
        }
        if (cmdPtr->hPtr != NULL) {
            name = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
            Tcl_AppendToObj(objPtr, name, -1);
        }
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteCommand --
 *
 *      Remove the given command from the given interpreter.
 *
 * Results:
 *      0 is returned if the command was deleted successfully.
 *      -1 is returned if there didn't exist a command by that name.
 *
 * Side effects:
 *      cmdName will no longer be recognized as a valid command for
 *      interp.
 *
 *----------------------------------------------------------------------
 */
 
int
Tcl_DeleteCommand(interp, cmdName)
    Tcl_Interp *interp;         /* Token for command interpreter (returned
                                 * by a previous Tcl_CreateInterp call). */
    char *cmdName;              /* Name of command to remove. */
{
    Tcl_Command cmd;
 
    /*
     *  Find the desired command and delete it.
     */
 
    cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
            /*flags*/ 0);
    if (cmd == (Tcl_Command) NULL) {
        return -1;
    }
    return Tcl_DeleteCommandFromToken(interp, cmd);
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteCommandFromToken --
 *
 *      Removes the given command from the given interpreter. This procedure
 *      resembles Tcl_DeleteCommand, but takes a Tcl_Command token instead
 *      of a command name for efficiency.
 *
 * Results:
 *      0 is returned if the command was deleted successfully.
 *      -1 is returned if there didn't exist a command by that name.
 *
 * Side effects:
 *      The command specified by "cmd" will no longer be recognized as a
 *      valid command for "interp".
 *
 *----------------------------------------------------------------------
 */
 
int
Tcl_DeleteCommandFromToken(interp, cmd)
    Tcl_Interp *interp;         /* Token for command interpreter returned by
                                 * a previous call to Tcl_CreateInterp. */
    Tcl_Command cmd;            /* Token for command to delete. */
{
    Interp *iPtr = (Interp *) interp;
    Command *cmdPtr = (Command *) cmd;
    ImportRef *refPtr, *nextRefPtr;
    Tcl_Command importCmd;
 
    /*
     * The code here is tricky.  We can't delete the hash table entry
     * before invoking the deletion callback because there are cases
     * where the deletion callback needs to invoke the command (e.g.
     * object systems such as OTcl). However, this means that the
     * callback could try to delete or rename the command. The deleted
     * flag allows us to detect these cases and skip nested deletes.
     */
 
    if (cmdPtr->deleted) {
        /*
         * Another deletion is already in progress.  Remove the hash
         * table entry now, but don't invoke a callback or free the
         * command structure.
         */
 
        Tcl_DeleteHashEntry(cmdPtr->hPtr);
        cmdPtr->hPtr = NULL;
        return 0;
    }
 
    /*
     * If the command being deleted has a compile procedure, increment the
     * interpreter's compileEpoch to invalidate its compiled code. This
     * makes sure that we don't later try to execute old code compiled with
     * command-specific (i.e., inline) bytecodes for the now-deleted
     * command. This field is checked in Tcl_EvalObj and ObjInterpProc, and
     * code whose compilation epoch doesn't match is recompiled.
     */
 
    if (cmdPtr->compileProc != NULL) {
        iPtr->compileEpoch++;
    }
 
    cmdPtr->deleted = 1;
    if (cmdPtr->deleteProc != NULL) {
        /*
         * Delete the command's client data. If this was an imported command
         * created when a command was imported into a namespace, this client
         * data will be a pointer to a ImportedCmdData structure describing
         * the "real" command that this imported command refers to.
         */
 
        (*cmdPtr->deleteProc)(cmdPtr->deleteData);
    }
 
    /*
     * Bump the command epoch counter. This will invalidate all cached
     * references that point to this command.
     */
 
    cmdPtr->cmdEpoch++;
 
    /*
     * If this command was imported into other namespaces, then imported
     * commands were created that refer back to this command. Delete these
     * imported commands now.
     */
 
    for (refPtr = cmdPtr->importRefPtr;  refPtr != NULL;
            refPtr = nextRefPtr) {
        nextRefPtr = refPtr->nextPtr;
        importCmd = (Tcl_Command) refPtr->importedCmdPtr;
        Tcl_DeleteCommandFromToken(interp, importCmd);
    }
 
    /*
     * Don't use hPtr to delete the hash entry here, because it's
     * possible that the deletion callback renamed the command.
     * Instead, use cmdPtr->hptr, and make sure that no-one else
     * has already deleted the hash entry.
     */
 
    if (cmdPtr->hPtr != NULL) {
        Tcl_DeleteHashEntry(cmdPtr->hPtr);
    }
 
    /*
     * Mark the Command structure as no longer valid. This allows
     * TclExecuteByteCode to recognize when a Command has logically been
     * deleted and a pointer to this Command structure cached in a CmdName
     * object is invalid. TclExecuteByteCode will look up the command again
     * in the interpreter's command hashtable.
     */
 
    cmdPtr->objProc = NULL;
 
    /*
     * Now free the Command structure, unless there is another reference to
     * it from a CmdName Tcl object in some ByteCode code sequence. In that
     * case, delay the cleanup until all references are either discarded
     * (when a ByteCode is freed) or replaced by a new reference (when a
     * cached CmdName Command reference is found to be invalid and
     * TclExecuteByteCode looks up the command in the command hashtable).
     */
 
    TclCleanupCommand(cmdPtr);
    return 0;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclCleanupCommand --
 *
 *      This procedure frees up a Command structure unless it is still
 *      referenced from an interpreter's command hashtable or from a CmdName
 *      Tcl object representing the name of a command in a ByteCode
 *      instruction sequence.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      Memory gets freed unless a reference to the Command structure still
 *      exists. In that case the cleanup is delayed until the command is
 *      deleted or when the last ByteCode referring to it is freed.
 *
 *----------------------------------------------------------------------
 */
 
void
TclCleanupCommand(cmdPtr)
    register Command *cmdPtr;   /* Points to the Command structure to
                                 * be freed. */
{
    cmdPtr->refCount--;
    if (cmdPtr->refCount <= 0) {
        ckfree((char *) cmdPtr);
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_Eval --
 *
 *      Execute a Tcl command in a string.
 *
 * Results:
 *      The return value is one of the return codes defined in tcl.h
 *      (such as TCL_OK), and interp->result contains a string value
 *      to supplement the return code. The value of interp->result
 *      will persist only until the next call to Tcl_Eval or Tcl_EvalObj:
 *      you must copy it or lose it!
 *
 * Side effects:
 *      The string is compiled to produce a ByteCode object that holds the
 *      command's bytecode instructions. However, this ByteCode object is
 *      lost after executing the command. The command's execution will
 *      almost certainly have side effects. interp->termOffset is set to the
 *      offset of the character in "string" just after the last one
 *      successfully compiled or executed.
 *
 *----------------------------------------------------------------------
 */
 
int
Tcl_Eval(interp, string)
    Tcl_Interp *interp;         /* Token for command interpreter (returned
                                 * by previous call to Tcl_CreateInterp). */
    char *string;               /* Pointer to TCL command to execute. */
{
    register Tcl_Obj *cmdPtr;
    int length = strlen(string);
    int result;
 
    if (length > 0) {
        /*
         * Initialize a Tcl object from the command string.
         */
 
        TclNewObj(cmdPtr);
        TclInitStringRep(cmdPtr, string, length);
        Tcl_IncrRefCount(cmdPtr);
 
        /*
         * Compile and execute the bytecodes.
         */
 
        result = Tcl_EvalObj(interp, cmdPtr);
 
        /*
         * Move the interpreter's object result to the string result,
         * then reset the object result.
         * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS.
         */
 
        Tcl_SetResult(interp,
                TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL),
                TCL_VOLATILE);
 
        /*
         * Discard the Tcl object created to hold the command and its code.
         */
 
        Tcl_DecrRefCount(cmdPtr);
    } else {
        /*
         * An empty string. Just reset the interpreter's result.
         */
 
        Tcl_ResetResult(interp);
        result = TCL_OK;
    }
    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_EvalObj --
 *
 *      Execute Tcl commands stored in a Tcl object. These commands are
 *      compiled into bytecodes if necessary.
 *
 * Results:
 *      The return value is one of the return codes defined in tcl.h
 *      (such as TCL_OK), and the interpreter's result contains a value
 *      to supplement the return code.
 *
 * Side effects:
 *      The object is converted, if necessary, to a ByteCode object that
 *      holds the bytecode instructions for the commands. Executing the
 *      commands will almost certainly have side effects that depend
 *      on those commands.
 *
 *      Just as in Tcl_Eval, interp->termOffset is set to the offset of the
 *      last character executed in the objPtr's string.
 *
 *----------------------------------------------------------------------
 */
 
#undef Tcl_EvalObj
 
int
Tcl_EvalObj(interp, objPtr)
    Tcl_Interp *interp;                 /* Token for command interpreter
                                         * (returned by a previous call to
                                         * Tcl_CreateInterp). */
    Tcl_Obj *objPtr;                    /* Pointer to object containing
                                         * commands to execute. */
{
    register Interp *iPtr = (Interp *) interp;
    int flags;                          /* Interp->evalFlags value when the
                                         * procedure was called. */
    register ByteCode* codePtr;         /* Tcl Internal type of bytecode. */
    int oldCount = iPtr->cmdCount;      /* Used to tell whether any commands
                                         * at all were executed. */
    int numSrcChars;
    register int result;
    Namespace *namespacePtr;
 
    /*
     * Reset both the interpreter's string and object results and clear out
     * any error information. This makes sure that we return an empty
     * result if there are no commands in the command string.
     */
 
    Tcl_ResetResult(interp);
 
    /*
     * Check depth of nested calls to Tcl_Eval:  if this gets too large,
     * it's probably because of an infinite loop somewhere.
     */
 
    iPtr->numLevels++;
    if (iPtr->numLevels > iPtr->maxNestingDepth) {
        iPtr->numLevels--;
        Tcl_AppendToObj(Tcl_GetObjResult(interp),
                "too many nested calls to Tcl_EvalObj (infinite loop?)", -1);
        return TCL_ERROR;
    }
 
    /*
     * On the Mac, we will never reach the default recursion limit before blowing
     * the stack. So we need to do a check here.
     */
 
    if (TclpCheckStackSpace() == 0) {
        /*NOTREACHED*/
        iPtr->numLevels--;
        Tcl_AppendToObj(Tcl_GetObjResult(interp),
                "too many nested calls to Tcl_EvalObj (infinite loop?)", -1);
        return TCL_ERROR;
    }
 
    /*
     * If the interpreter has been deleted, return an error.
     */
 
    if (iPtr->flags & DELETED) {
        Tcl_ResetResult(interp);
        Tcl_AppendToObj(Tcl_GetObjResult(interp),
                "attempt to call eval in deleted interpreter", -1);
        Tcl_SetErrorCode(interp, "CORE", "IDELETE",
                "attempt to call eval in deleted interpreter", (char *) NULL);
        iPtr->numLevels--;
        return TCL_ERROR;
    }
 
    /*
     * Get the ByteCode from the object. If it exists, make sure it hasn't
     * been invalidated by, e.g., someone redefining a command with a
     * compile procedure (this might make the compiled code wrong). If
     * necessary, convert the object to be a ByteCode object and compile it.
     * Also, if the code was compiled in/for a different interpreter,
     * or for a different namespace, or for the same namespace but
     * with different name resolution rules, we recompile it.
     *
     * Precompiled objects, however, are immutable and therefore
     * they are not recompiled, even if the epoch has changed.
     */
 
    if (iPtr->varFramePtr != NULL) {
        namespacePtr = iPtr->varFramePtr->nsPtr;
    } else {
        namespacePtr = iPtr->globalNsPtr;
    }
 
    if (objPtr->typePtr == &tclByteCodeType) {
        codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
 
        if ((codePtr->iPtr != iPtr)
                || (codePtr->compileEpoch != iPtr->compileEpoch)
                || (codePtr->nsPtr != namespacePtr)
                || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) {
            if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
                if (codePtr->iPtr != iPtr) {
                    panic("Tcl_EvalObj: compiled script jumped interps");
                }
                codePtr->compileEpoch = iPtr->compileEpoch;
            } else {
                tclByteCodeType.freeIntRepProc(objPtr);
            }
        }
    }
    if (objPtr->typePtr != &tclByteCodeType) {
        /*
         * First reset any error line number information.
         */
 
        iPtr->errorLine = 1;   /* no correct line # information yet */
        result = tclByteCodeType.setFromAnyProc(interp, objPtr);
        if (result != TCL_OK) {
            iPtr->numLevels--;
            return result;
        }
    }
    codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
 
    /*
     * Extract then reset the compilation flags in the interpreter.
     * Resetting the flags must be done after any compilation.
     */
 
    flags = iPtr->evalFlags;
    iPtr->evalFlags = 0;
 
    /*
     * Execute the commands. If the code was compiled from an empty string,
     * don't bother executing the code.
     */
 
    numSrcChars = codePtr->numSrcChars;
    if ((numSrcChars > 0) || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
        /*
         * Increment the code's ref count while it is being executed. If
         * afterwards no references to it remain, free the code.
         */
 
        codePtr->refCount++;
        result = TclExecuteByteCode(interp, codePtr);
        codePtr->refCount--;
        if (codePtr->refCount <= 0) {
            TclCleanupByteCode(codePtr);
        }
    } else {
        Tcl_ResetResult(interp);
        result = TCL_OK;
    }
 
    /*
     * If no commands at all were executed, check for asynchronous
     * handlers so that they at least get one change to execute.
     * This is needed to handle event loops written in Tcl with
     * empty bodies.
     */
 
    if ((oldCount == iPtr->cmdCount) && (Tcl_AsyncReady())) {
        result = Tcl_AsyncInvoke(interp, result);
    }
 
    /*
     * Free up any extra resources that were allocated.
     */
 
    iPtr->numLevels--;
    if (iPtr->numLevels == 0) {
        if (result == TCL_RETURN) {
            result = TclUpdateReturnInfo(iPtr);
        }
        if ((result != TCL_OK) && (result != TCL_ERROR)
                && !(flags & TCL_ALLOW_EXCEPTIONS)) {
            Tcl_ResetResult(interp);
            if (result == TCL_BREAK) {
                Tcl_AppendToObj(Tcl_GetObjResult(interp),
                        "invoked \"break\" outside of a loop", -1);
            } else if (result == TCL_CONTINUE) {
                Tcl_AppendToObj(Tcl_GetObjResult(interp),
                        "invoked \"continue\" outside of a loop", -1);
            } else {
                char buf[50];
                sprintf(buf, "command returned bad code: %d", result);
                Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
            }
            result = TCL_ERROR;
        }
    }
 
    /*
     * If an error occurred, record information about what was being
     * executed when the error occurred.
     */
 
    if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
        char buf[200];
        char *ellipsis = "";
        char *bytes;
        int length;
 
        /*
         * Figure out how much of the command to print in the error
         * message (up to a certain number of characters, or up to
         * the first new-line).
         * THIS FAILS IF THE OBJECT'S STRING REP CONTAINS A NULL.
         */
 
        bytes = Tcl_GetStringFromObj(objPtr, &length);
        length = TclMin(numSrcChars, length);
        if (length > 150) {
            length = 150;
            ellipsis = " ...";
        }
 
        if (!(iPtr->flags & ERR_IN_PROGRESS)) {
            sprintf(buf, "\n    while executing\n\"%.*s%s\"",
                    length, bytes, ellipsis);
        } else {
            sprintf(buf, "\n    invoked from within\n\"%.*s%s\"",
                    length, bytes, ellipsis);
        }
        Tcl_AddObjErrorInfo(interp, buf, -1);
    }
 
    /*
     * Set the interpreter's termOffset member to the offset of the
     * character just after the last one executed. We approximate the offset
     * of the last character executed by using the number of characters
     * compiled.
     */
 
    iPtr->termOffset = numSrcChars;
    iPtr->flags &= ~ERR_ALREADY_LOGGED;
    return result;
}
 
/*
 *--------------------------------------------------------------
 *
 * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean --
 *
 *      Procedures to evaluate an expression and return its value in a
 *      particular form.
 *
 * Results:
 *      Each of the procedures below returns a standard Tcl result. If an
 *      error occurs then an error message is left in interp->result.
 *      Otherwise the value of the expression, in the appropriate form, is
 *      stored at *ptr. If the expression had a result that was
 *      incompatible with the desired form then an error is returned.
 *
 * Side effects:
 *      None.
 *
 *--------------------------------------------------------------
 */
 
int
Tcl_ExprLong(interp, string, ptr)
    Tcl_Interp *interp;         /* Context in which to evaluate the
                                 * expression. */
    char *string;               /* Expression to evaluate. */
    long *ptr;                  /* Where to store result. */
{
    register Tcl_Obj *exprPtr;
    Tcl_Obj *resultPtr;
    int length = strlen(string);
    int result = TCL_OK;
 
    if (length > 0) {
        exprPtr = Tcl_NewStringObj(string, length);
        Tcl_IncrRefCount(exprPtr);
        result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
        if (result == TCL_OK) {
            /*
             * Store an integer based on the expression result.
             */
 
            if (resultPtr->typePtr == &tclIntType) {
                *ptr = resultPtr->internalRep.longValue;
            } else if (resultPtr->typePtr == &tclDoubleType) {
                *ptr = (long) resultPtr->internalRep.doubleValue;
            } else {
                Tcl_SetResult(interp,
                        "expression didn't have numeric value", TCL_STATIC);
                result = TCL_ERROR;
            }
            Tcl_DecrRefCount(resultPtr);  /* discard the result object */
        } else {
            /*
             * Move the interpreter's object result to the string result,
             * then reset the object result.
             * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS.
             */
 
            Tcl_SetResult(interp,
                    TclGetStringFromObj(Tcl_GetObjResult(interp),
                            (int *) NULL),
                    TCL_VOLATILE);
        }
        Tcl_DecrRefCount(exprPtr);  /* discard the expression object */
    } else {
        /*
         * An empty string. Just set the result integer to 0.
         */
 
        *ptr = 0;
    }
    return result;
}
 
int
Tcl_ExprDouble(interp, string, ptr)
    Tcl_Interp *interp;         /* Context in which to evaluate the
                                 * expression. */
    char *string;               /* Expression to evaluate. */
    double *ptr;                /* Where to store result. */
{
    register Tcl_Obj *exprPtr;
    Tcl_Obj *resultPtr;
    int length = strlen(string);
    int result = TCL_OK;
 
    if (length > 0) {
        exprPtr = Tcl_NewStringObj(string, length);
        Tcl_IncrRefCount(exprPtr);
        result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
        if (result == TCL_OK) {
            /*
             * Store a double  based on the expression result.
             */
 
            if (resultPtr->typePtr == &tclIntType) {
                *ptr = (double) resultPtr->internalRep.longValue;
            } else if (resultPtr->typePtr == &tclDoubleType) {
                *ptr = resultPtr->internalRep.doubleValue;
            } else {
                Tcl_SetResult(interp,
                        "expression didn't have numeric value", TCL_STATIC);
                result = TCL_ERROR;
            }
            Tcl_DecrRefCount(resultPtr);  /* discard the result object */
        } else {
            /*
             * Move the interpreter's object result to the string result,
             * then reset the object result.
             * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS.
             */
 
            Tcl_SetResult(interp,
                    TclGetStringFromObj(Tcl_GetObjResult(interp),
                            (int *) NULL),
                    TCL_VOLATILE);
        }
        Tcl_DecrRefCount(exprPtr);  /* discard the expression object */
    } else {
        /*
         * An empty string. Just set the result double to 0.0.
         */
 
        *ptr = 0.0;
    }
    return result;
}
 
int
Tcl_ExprBoolean(interp, string, ptr)
    Tcl_Interp *interp;         /* Context in which to evaluate the
                                 * expression. */
    char *string;               /* Expression to evaluate. */
    int *ptr;                   /* Where to store 0/1 result. */
{
    register Tcl_Obj *exprPtr;
    Tcl_Obj *resultPtr;
    int length = strlen(string);
    int result = TCL_OK;
 
    if (length > 0) {
        exprPtr = Tcl_NewStringObj(string, length);
        Tcl_IncrRefCount(exprPtr);
        result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
        if (result == TCL_OK) {
            /*
             * Store a boolean based on the expression result.
             */
 
            if (resultPtr->typePtr == &tclIntType) {
                *ptr = (resultPtr->internalRep.longValue != 0);
            } else if (resultPtr->typePtr == &tclDoubleType) {
                *ptr = (resultPtr->internalRep.doubleValue != 0.0);
            } else {
                result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr);
            }
            Tcl_DecrRefCount(resultPtr);  /* discard the result object */
        }
        if (result != TCL_OK) {
            /*
             * Move the interpreter's object result to the string result,
             * then reset the object result.
             * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS.
             */
 
            Tcl_SetResult(interp,
                    TclGetStringFromObj(Tcl_GetObjResult(interp),
                            (int *) NULL),
                    TCL_VOLATILE);
        }
        Tcl_DecrRefCount(exprPtr); /* discard the expression object */
    } else {
        /*
         * An empty string. Just set the result boolean to 0 (false).
         */
 
        *ptr = 0;
    }
    return result;
}
 
/*
 *--------------------------------------------------------------
 *
 * Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj --
 *
 *      Procedures to evaluate an expression in an object and return its
 *      value in a particular form.
 *
 * Results:
 *      Each of the procedures below returns a standard Tcl result
 *      object. If an error occurs then an error message is left in the
 *      interpreter's result. Otherwise the value of the expression, in the
 *      appropriate form, is stored at *ptr. If the expression had a result
 *      that was incompatible with the desired form then an error is
 *      returned.
 *
 * Side effects:
 *      None.
 *
 *--------------------------------------------------------------
 */
 
int
Tcl_ExprLongObj(interp, objPtr, ptr)
    Tcl_Interp *interp;                 /* Context in which to evaluate the
                                         * expression. */
    register Tcl_Obj *objPtr;           /* Expression to evaluate. */
    long *ptr;                          /* Where to store long result. */
{
    Tcl_Obj *resultPtr;
    int result;
 
    result = Tcl_ExprObj(interp, objPtr, &resultPtr);
    if (result == TCL_OK) {
        if (resultPtr->typePtr == &tclIntType) {
            *ptr = resultPtr->internalRep.longValue;
        } else if (resultPtr->typePtr == &tclDoubleType) {
            *ptr = (long) resultPtr->internalRep.doubleValue;
        } else {
            result = Tcl_GetLongFromObj(interp, resultPtr, ptr);
            if (result != TCL_OK) {
                return result;
            }
        }
        Tcl_DecrRefCount(resultPtr);  /* discard the result object */
    }
    return result;
}
 
int
Tcl_ExprDoubleObj(interp, objPtr, ptr)
    Tcl_Interp *interp;                 /* Context in which to evaluate the
                                         * expression. */
    register Tcl_Obj *objPtr;           /* Expression to evaluate. */
    double *ptr;                        /* Where to store double result. */
{
    Tcl_Obj *resultPtr;
    int result;
 
    result = Tcl_ExprObj(interp, objPtr, &resultPtr);
    if (result == TCL_OK) {
        if (resultPtr->typePtr == &tclIntType) {
            *ptr = (double) resultPtr->internalRep.longValue;
        } else if (resultPtr->typePtr == &tclDoubleType) {
            *ptr = resultPtr->internalRep.doubleValue;
        } else {
            result = Tcl_GetDoubleFromObj(interp, resultPtr, ptr);
            if (result != TCL_OK) {
                return result;
            }
        }
        Tcl_DecrRefCount(resultPtr);  /* discard the result object */
    }
    return result;
}
 
int
Tcl_ExprBooleanObj(interp, objPtr, ptr)
    Tcl_Interp *interp;                 /* Context in which to evaluate the
                                         * expression. */
    register Tcl_Obj *objPtr;           /* Expression to evaluate. */
    int *ptr;                           /* Where to store 0/1 result. */
{
    Tcl_Obj *resultPtr;
    int result;
 
    result = Tcl_ExprObj(interp, objPtr, &resultPtr);
    if (result == TCL_OK) {
        if (resultPtr->typePtr == &tclIntType) {
            *ptr = (resultPtr->internalRep.longValue != 0);
        } else if (resultPtr->typePtr == &tclDoubleType) {
            *ptr = (resultPtr->internalRep.doubleValue != 0.0);
        } else {
            result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr);
            if (result != TCL_OK) {
                return result;
            }
        }
        Tcl_DecrRefCount(resultPtr);  /* discard the result object */
    }
    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclInvoke --
 *
 *      Invokes a Tcl command, given an argv/argc, from either the
 *      exposed or the hidden sets of commands in the given interpreter.
 *      NOTE: The command is invoked in the current stack frame of
 *      the interpreter, thus it can modify local variables.
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side effects:
 *      Whatever the command does.
 *
 *----------------------------------------------------------------------
 */
 
int
TclInvoke(interp, argc, argv, flags)
    Tcl_Interp *interp;         /* Where to invoke the command. */
    int argc;                   /* Count of args. */
    register char **argv;       /* The arg strings; argv[0] is the name of
                                 * the command to invoke. */
    int flags;                  /* Combination of flags controlling the
                                 * call: TCL_INVOKE_HIDDEN and
                                 * TCL_INVOKE_NO_UNKNOWN. */
{
    register Tcl_Obj *objPtr;
    register int i;
    int length, result;
 
    /*
     * This procedure generates an objv array for object arguments that hold
     * the argv strings. It starts out with stack-allocated space but uses
     * dynamically-allocated storage if needed.
     */
 
#define NUM_ARGS 20
    Tcl_Obj *(objStorage[NUM_ARGS]);
    register Tcl_Obj **objv = objStorage;
 
    /*
     * Create the object argument array "objv". Make sure objv is large
     * enough to hold the objc arguments plus 1 extra for the zero
     * end-of-objv word.
     */
 
    if ((argc + 1) > NUM_ARGS) {
        objv = (Tcl_Obj **)
            ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *));
    }
 
    for (i = 0;  i < argc;  i++) {
        length = strlen(argv[i]);
        objv[i] = Tcl_NewStringObj(argv[i], length);
        Tcl_IncrRefCount(objv[i]);
    }
    objv[argc] = 0;
 
    /*
     * Use TclObjInterpProc to actually invoke the command.
     */
 
    result = TclObjInvoke(interp, argc, objv, flags);
 
    /*
     * Move the interpreter's object result to the string result,
     * then reset the object result.
     * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS.
     */
 
    Tcl_SetResult(interp,
            TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL),
            TCL_VOLATILE);
 
    /*
     * Decrement the ref counts on the objv elements since we are done
     * with them.
     */
 
    for (i = 0;  i < argc;  i++) {
        objPtr = objv[i];
        Tcl_DecrRefCount(objPtr);
    }
 
    /*
     * Free the objv array if malloc'ed storage was used.
     */
 
    if (objv != objStorage) {
        ckfree((char *) objv);
    }
    return result;
#undef NUM_ARGS
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclGlobalInvoke --
 *
 *      Invokes a Tcl command, given an argv/argc, from either the
 *      exposed or hidden sets of commands in the given interpreter.
 *      NOTE: The command is invoked in the global stack frame of
 *      the interpreter, thus it cannot see any current state on
 *      the stack for that interpreter.
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side effects:
 *      Whatever the command does.
 *
 *----------------------------------------------------------------------
 */
 
int
TclGlobalInvoke(interp, argc, argv, flags)
    Tcl_Interp *interp;         /* Where to invoke the command. */
    int argc;                   /* Count of args. */
    register char **argv;       /* The arg strings; argv[0] is the name of
                                 * the command to invoke. */
    int flags;                  /* Combination of flags controlling the
                                 * call: TCL_INVOKE_HIDDEN and
                                 * TCL_INVOKE_NO_UNKNOWN. */
{
    register Interp *iPtr = (Interp *) interp;
    int result;
    CallFrame *savedVarFramePtr;
 
    savedVarFramePtr = iPtr->varFramePtr;
    iPtr->varFramePtr = NULL;
    result = TclInvoke(interp, argc, argv, flags);
    iPtr->varFramePtr = savedVarFramePtr;
    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclObjInvokeGlobal --
 *
 *      Object version: Invokes a Tcl command, given an objv/objc, from
 *      either the exposed or hidden set of commands in the given
 *      interpreter.
 *      NOTE: The command is invoked in the global stack frame of the
 *      interpreter, thus it cannot see any current state on the
 *      stack of that interpreter.
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side effects:
 *      Whatever the command does.
 *
 *----------------------------------------------------------------------
 */
 
int
TclObjInvokeGlobal(interp, objc, objv, flags)
    Tcl_Interp *interp;         /* Interpreter in which command is
                                 * to be invoked. */
    int objc;                   /* Count of arguments. */
    Tcl_Obj *CONST objv[];      /* Argument value objects; objv[0]
                                 * points to the name of the
                                 * command to invoke. */
    int flags;                  /* Combination of flags controlling
                                 * the call: TCL_INVOKE_HIDDEN and
                                 * TCL_INVOKE_NO_UNKNOWN. */
{
    register Interp *iPtr = (Interp *) interp;
    int result;
    CallFrame *savedVarFramePtr;
 
    savedVarFramePtr = iPtr->varFramePtr;
    iPtr->varFramePtr = NULL;
    result = TclObjInvoke(interp, objc, objv, flags);
    iPtr->varFramePtr = savedVarFramePtr;
    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclObjInvoke --
 *
 *      Invokes a Tcl command, given an objv/objc, from either the
 *      exposed or the hidden sets of commands in the given interpreter.
 *
 * Results:
 *      A standard Tcl object result.
 *
 * Side effects:
 *      Whatever the command does.
 *
 *----------------------------------------------------------------------
 */
 
int
TclObjInvoke(interp, objc, objv, flags)
    Tcl_Interp *interp;         /* Interpreter in which command is
                                 * to be invoked. */
    int objc;                   /* Count of arguments. */
    Tcl_Obj *CONST objv[];      /* Argument value objects; objv[0]
                                 * points to the name of the
                                 * command to invoke. */
    int flags;                  /* Combination of flags controlling
                                 * the call: TCL_INVOKE_HIDDEN and
                                 * TCL_INVOKE_NO_UNKNOWN. */
{
    register Interp *iPtr = (Interp *) interp;
    Tcl_HashTable *hTblPtr;     /* Table of hidden commands. */
    char *cmdName;              /* Name of the command from objv[0]. */
    register Tcl_HashEntry *hPtr;
    Tcl_Command cmd;
    Command *cmdPtr;
    int localObjc;              /* Used to invoke "unknown" if the */
    Tcl_Obj **localObjv = NULL; /* command is not found. */
    register int i;
    int length, result;
    char *bytes;
 
    if (interp == (Tcl_Interp *) NULL) {
        return TCL_ERROR;
    }
 
    if ((objc < 1) || (objv == (Tcl_Obj **) NULL)) {
        Tcl_AppendToObj(Tcl_GetObjResult(interp),
                "illegal argument vector", -1);
        return TCL_ERROR;
    }
 
    /*
     * THE FOLLOWING CODE FAILS IF THE STRING REP CONTAINS NULLS.
     */
 
    cmdName = Tcl_GetStringFromObj(objv[0], (int *) NULL);
    if (flags & TCL_INVOKE_HIDDEN) {
        /*
         * Find the table of hidden commands; error out if none.
         */
 
        hTblPtr = (Tcl_HashTable *)
                Tcl_GetAssocData(interp, "tclHiddenCmds", NULL);
        if (hTblPtr == (Tcl_HashTable *) NULL) {
            badhiddenCmdToken:
            Tcl_ResetResult(interp);
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                     "invalid hidden command name \"", cmdName, "\"",
                     (char *) NULL);
            return TCL_ERROR;
        }
        hPtr = Tcl_FindHashEntry(hTblPtr, cmdName);
 
        /*
         * We never invoke "unknown" for hidden commands.
         */
 
        if (hPtr == NULL) {
            goto badhiddenCmdToken;
        }
        cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
    } else {
        cmdPtr = NULL;
        cmd = Tcl_FindCommand(interp, cmdName,
                (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY);
        if (cmd != (Tcl_Command) NULL) {
            cmdPtr = (Command *) cmd;
        }
        if (cmdPtr == NULL) {
            if (!(flags & TCL_INVOKE_NO_UNKNOWN)) {
                cmd = Tcl_FindCommand(interp, "unknown",
                        (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY);
                if (cmd != (Tcl_Command) NULL) {
                    cmdPtr = (Command *) cmd;
                }
                if (cmdPtr != NULL) {
                    localObjc = (objc + 1);
                    localObjv = (Tcl_Obj **)
                        ckalloc((unsigned) (sizeof(Tcl_Obj *) * localObjc));
                    localObjv[0] = Tcl_NewStringObj("unknown", -1);
                    Tcl_IncrRefCount(localObjv[0]);
                    for (i = 0;  i < objc;  i++) {
                        localObjv[i+1] = objv[i];
                    }
                    objc = localObjc;
                    objv = localObjv;
                }
            }
 
            /*
             * Check again if we found the command. If not, "unknown" is
             * not present and we cannot help, or the caller said not to
             * call "unknown" (they specified TCL_INVOKE_NO_UNKNOWN).
             */
 
            if (cmdPtr == NULL) {
                Tcl_ResetResult(interp);
                Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                        "invalid command name \"",  cmdName, "\"",
                         (char *) NULL);
                return TCL_ERROR;
            }
        }
    }
 
    /*
     * Invoke the command procedure. First reset the interpreter's string
     * and object results to their default empty values since they could
     * have gotten changed by earlier invocations.
     */
 
    Tcl_ResetResult(interp);
    iPtr->cmdCount++;
    result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv);
 
    /*
     * If an error occurred, record information about what was being
     * executed when the error occurred.
     */
 
    if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
        Tcl_DString ds;
 
        Tcl_DStringInit(&ds);
        if (!(iPtr->flags & ERR_IN_PROGRESS)) {
            Tcl_DStringAppend(&ds, "\n    while invoking\n\"", -1);
        } else {
            Tcl_DStringAppend(&ds, "\n    invoked from within\n\"", -1);
        }
        for (i = 0;  i < objc;  i++) {
            bytes = Tcl_GetStringFromObj(objv[i], &length);
            Tcl_DStringAppend(&ds, bytes, length);
            if (i < (objc - 1)) {
                Tcl_DStringAppend(&ds, " ", -1);
            } else if (Tcl_DStringLength(&ds) > 100) {
                Tcl_DStringSetLength(&ds, 100);
                Tcl_DStringAppend(&ds, "...", -1);
                break;
            }
        }
 
        Tcl_DStringAppend(&ds, "\"", -1);
        Tcl_AddObjErrorInfo(interp, Tcl_DStringValue(&ds), -1);
        Tcl_DStringFree(&ds);
        iPtr->flags &= ~ERR_ALREADY_LOGGED;
    }
 
    /*
     * Free any locally allocated storage used to call "unknown".
     */
 
    if (localObjv != (Tcl_Obj **) NULL) {
        ckfree((char *) localObjv);
    }
    return result;
}
 
/*
 *--------------------------------------------------------------
 *
 * Tcl_ExprString --
 *
 *      Evaluate an expression in a string and return its value in string
 *      form.
 *
 * Results:
 *      A standard Tcl result. If the result is TCL_OK, then the
 *      interpreter's result is set to the string value of the
 *      expression. If the result is TCL_OK, then interp->result
 *      contains an error message.
 *
 * Side effects:
 *      A Tcl object is allocated to hold a copy of the expression string.
 *      This expression object is passed to Tcl_ExprObj and then
 *      deallocated.
 *
 *--------------------------------------------------------------
 */
 
int
Tcl_ExprString(interp, string)
    Tcl_Interp *interp;         /* Context in which to evaluate the
                                 * expression. */
    char *string;               /* Expression to evaluate. */
{
    register Tcl_Obj *exprPtr;
    Tcl_Obj *resultPtr;
    int length = strlen(string);
    char buf[100];
    int result = TCL_OK;
 
    if (length > 0) {
        TclNewObj(exprPtr);
        TclInitStringRep(exprPtr, string, length);
        Tcl_IncrRefCount(exprPtr);
 
        result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
        if (result == TCL_OK) {
            /*
             * Set the interpreter's string result from the result object.
             */
 
            if (resultPtr->typePtr == &tclIntType) {
                sprintf(buf, "%ld", resultPtr->internalRep.longValue);
                Tcl_SetResult(interp, buf, TCL_VOLATILE);
            } else if (resultPtr->typePtr == &tclDoubleType) {
                Tcl_PrintDouble((Tcl_Interp *) NULL,
                        resultPtr->internalRep.doubleValue, buf);
                Tcl_SetResult(interp, buf, TCL_VOLATILE);
            } else {
                /*
                 * Set interpreter's string result from the result object.
                 * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS.
                 */
 
                Tcl_SetResult(interp,
                        TclGetStringFromObj(resultPtr, (int *) NULL),
                        TCL_VOLATILE);
            }
            Tcl_DecrRefCount(resultPtr);  /* discard the result object */
        } else {
            /*
             * Move the interpreter's object result to the string result,
             * then reset the object result.
             * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS.
             */
 
            Tcl_SetResult(interp,
                    TclGetStringFromObj(Tcl_GetObjResult(interp),
                            (int *) NULL),
                    TCL_VOLATILE);
        }
        Tcl_DecrRefCount(exprPtr); /* discard the expression object */
    } else {
        /*
         * An empty string. Just set the interpreter's result to 0.
         */
 
        Tcl_SetResult(interp, "0", TCL_VOLATILE);
    }
    return result;
}
 
/*
 *--------------------------------------------------------------
 *
 * Tcl_ExprObj --
 *
 *      Evaluate an expression in a Tcl_Obj.
 *
 * Results:
 *      A standard Tcl object result. If the result is other than TCL_OK,
 *      then the interpreter's result contains an error message. If the
 *      result is TCL_OK, then a pointer to the expression's result value
 *      object is stored in resultPtrPtr. In that case, the object's ref
 *      count is incremented to reflect the reference returned to the
 *      caller; the caller is then responsible for the resulting object
 *      and must, for example, decrement the ref count when it is finished
 *      with the object.
 *
 * Side effects:
 *      Any side effects caused by subcommands in the expression, if any.
 *      The interpreter result is not modified unless there is an error.
 *
 *--------------------------------------------------------------
 */
 
int
Tcl_ExprObj(interp, objPtr, resultPtrPtr)
    Tcl_Interp *interp;         /* Context in which to evaluate the
                                 * expression. */
    register Tcl_Obj *objPtr;   /* Points to Tcl object containing
                                 * expression to evaluate. */
    Tcl_Obj **resultPtrPtr;     /* Where the Tcl_Obj* that is the expression
                                 * result is stored if no errors occur. */
{
    Interp *iPtr = (Interp *) interp;
    CompileEnv compEnv;         /* Compilation environment structure
                                 * allocated in frame. */
    register ByteCode *codePtr = NULL;
                                /* Tcl Internal type of bytecode.
                                 * Initialized to avoid compiler warning. */
    AuxData *auxDataPtr;
    Interp dummy;
    Tcl_Obj *saveObjPtr;
    char *string;
    int result;
    int i;
 
    /*
     * Get the ByteCode from the object. If it exists, make sure it hasn't
     * been invalidated by, e.g., someone redefining a command with a
     * compile procedure (this might make the compiled code wrong). If
     * necessary, convert the object to be a ByteCode object and compile it.
     * Also, if the code was compiled in/for a different interpreter, we
     * recompile it.
     *
     * Precompiled expressions, however, are immutable and therefore
     * they are not recompiled, even if the epoch has changed.
     *
     * THIS FAILS IF THE OBJECT'S STRING REP HAS A NULL BYTE.
     */
 
    if (objPtr->typePtr == &tclByteCodeType) {
        codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
        if ((codePtr->iPtr != iPtr)
                || (codePtr->compileEpoch != iPtr->compileEpoch)) {
            if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
                if (codePtr->iPtr != iPtr) {
                    panic("Tcl_ExprObj: compiled expression jumped interps");
                }
                codePtr->compileEpoch = iPtr->compileEpoch;
            } else {
                tclByteCodeType.freeIntRepProc(objPtr);
                objPtr->typePtr = (Tcl_ObjType *) NULL;
            }
        }
    }
    if (objPtr->typePtr != &tclByteCodeType) {
        int length;
        string = Tcl_GetStringFromObj(objPtr, &length);
        TclInitCompileEnv(interp, &compEnv, string);
        result = TclCompileExpr(interp, string, string + length,
                /*flags*/ 0, &compEnv);
        if (result == TCL_OK) {
            /*
             * If the expression yielded no instructions (e.g., was empty),
             * push an integer zero object as the expressions's result.
             */
 
            if (compEnv.codeNext == NULL) {
                int objIndex = TclObjIndexForString("0", 0,
                        /*allocStrRep*/ 0, /*inHeap*/ 0, &compEnv);
                Tcl_Obj *objPtr = compEnv.objArrayPtr[objIndex];
 
                Tcl_InvalidateStringRep(objPtr);
                objPtr->internalRep.longValue = 0;
                objPtr->typePtr = &tclIntType;
 
                TclEmitPush(objIndex, &compEnv);
            }
 
            /*
             * Add done instruction at the end of the instruction sequence.
             */
 
            TclEmitOpcode(INST_DONE, &compEnv);
 
            TclInitByteCodeObj(objPtr, &compEnv);
            codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
            if (tclTraceCompile == 2) {
                TclPrintByteCodeObj(interp, objPtr);
            }
            TclFreeCompileEnv(&compEnv);
        } else {
            /*
             * Compilation errors. Decrement the ref counts on any objects
             * in the object array before freeing the compilation
             * environment.
             */
 
            for (i = 0;  i < compEnv.objArrayNext;  i++) {
                Tcl_Obj *elemPtr = compEnv.objArrayPtr[i];
                Tcl_DecrRefCount(elemPtr);
            }
 
            auxDataPtr = compEnv.auxDataArrayPtr;
            for (i = 0;  i < compEnv.auxDataArrayNext;  i++) {
                if (auxDataPtr->type->freeProc != NULL) {
                    auxDataPtr->type->freeProc(auxDataPtr->clientData);
                }
                auxDataPtr++;
            }
            TclFreeCompileEnv(&compEnv);
            return result;
        }
    }
 
    /*
     * Execute the expression after first saving the interpreter's result.
     */
 
    dummy.objResultPtr = Tcl_NewObj();
    Tcl_IncrRefCount(dummy.objResultPtr);
    if (interp->freeProc == 0) {
        dummy.freeProc = (Tcl_FreeProc *) 0;
        dummy.result = "";
        Tcl_SetResult((Tcl_Interp *) &dummy, interp->result,
                TCL_VOLATILE);
    } else {
        dummy.freeProc = interp->freeProc;
        dummy.result = interp->result;
        interp->freeProc = (Tcl_FreeProc *) 0;
    }
 
    saveObjPtr = Tcl_GetObjResult(interp);
    Tcl_IncrRefCount(saveObjPtr);
 
    /*
     * Increment the code's ref count while it is being executed. If
     * afterwards no references to it remain, free the code.
     */
 
    codePtr->refCount++;
    result = TclExecuteByteCode(interp, codePtr);
    codePtr->refCount--;
    if (codePtr->refCount <= 0) {
        TclCleanupByteCode(codePtr);
    }
 
    /*
     * If the expression evaluated successfully, store a pointer to its
     * value object in resultPtrPtr then restore the old interpreter result.
     * We increment the object's ref count to reflect the reference that we
     * are returning to the caller. We also decrement the ref count of the
     * interpreter's result object after calling Tcl_SetResult since we
     * next store into that field directly.
     */
 
    if (result == TCL_OK) {
        *resultPtrPtr = iPtr->objResultPtr;
        Tcl_IncrRefCount(iPtr->objResultPtr);
 
        Tcl_SetResult(interp, dummy.result,
                ((dummy.freeProc == 0) ? TCL_VOLATILE : dummy.freeProc));
        Tcl_DecrRefCount(iPtr->objResultPtr);
        iPtr->objResultPtr = saveObjPtr;
    } else {
        Tcl_DecrRefCount(saveObjPtr);
        Tcl_FreeResult((Tcl_Interp *) &dummy);
    }
 
    Tcl_DecrRefCount(dummy.objResultPtr);
    dummy.objResultPtr = NULL;
    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateTrace --
 *
 *      Arrange for a procedure to be called to trace command execution.
 *
 * Results:
 *      The return value is a token for the trace, which may be passed
 *      to Tcl_DeleteTrace to eliminate the trace.
 *
 * Side effects:
 *      From now on, proc will be called just before a command procedure
 *      is called to execute a Tcl command.  Calls to proc will have the
 *      following form:
 *
 *      void
 *      proc(clientData, interp, level, command, cmdProc, cmdClientData,
 *              argc, argv)
 *          ClientData clientData;
 *          Tcl_Interp *interp;
 *          int level;
 *          char *command;
 *          int (*cmdProc)();
 *          ClientData cmdClientData;
 *          int argc;
 *          char **argv;
 *      {
 *      }
 *
 *      The clientData and interp arguments to proc will be the same
 *      as the corresponding arguments to this procedure.  Level gives
 *      the nesting level of command interpretation for this interpreter
 *      (0 corresponds to top level).  Command gives the ASCII text of
 *      the raw command, cmdProc and cmdClientData give the procedure that
 *      will be called to process the command and the ClientData value it
 *      will receive, and argc and argv give the arguments to the
 *      command, after any argument parsing and substitution.  Proc
 *      does not return a value.
 *
 *----------------------------------------------------------------------
 */
 
Tcl_Trace
Tcl_CreateTrace(interp, level, proc, clientData)
    Tcl_Interp *interp;         /* Interpreter in which to create trace. */
    int level;                  /* Only call proc for commands at nesting
                                 * level<=argument level (1=>top level). */
    Tcl_CmdTraceProc *proc;     /* Procedure to call before executing each
                                 * command. */
    ClientData clientData;      /* Arbitrary value word to pass to proc. */
{
    register Trace *tracePtr;
    register Interp *iPtr = (Interp *) interp;
 
    /*
     * Invalidate existing compiled code for this interpreter and arrange
     * (by setting the DONT_COMPILE_CMDS_INLINE flag) that when compiling
     * new code, no commands will be compiled inline (i.e., into an inline
     * sequence of instructions). We do this because commands that were
     * compiled inline will never result in a command trace being called.
     */
 
    iPtr->compileEpoch++;
    iPtr->flags |= DONT_COMPILE_CMDS_INLINE;
 
    tracePtr = (Trace *) ckalloc(sizeof(Trace));
    tracePtr->level = level;
    tracePtr->proc = proc;
    tracePtr->clientData = clientData;
    tracePtr->nextPtr = iPtr->tracePtr;
    iPtr->tracePtr = tracePtr;
 
    return (Tcl_Trace) tracePtr;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteTrace --
 *
 *      Remove a trace.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      From now on there will be no more calls to the procedure given
 *      in trace.
 *
 *----------------------------------------------------------------------
 */
 
void
Tcl_DeleteTrace(interp, trace)
    Tcl_Interp *interp;         /* Interpreter that contains trace. */
    Tcl_Trace trace;            /* Token for trace (returned previously by
                                 * Tcl_CreateTrace). */
{
    register Interp *iPtr = (Interp *) interp;
    register Trace *tracePtr = (Trace *) trace;
    register Trace *tracePtr2;
 
    if (iPtr->tracePtr == tracePtr) {
        iPtr->tracePtr = tracePtr->nextPtr;
        ckfree((char *) tracePtr);
    } else {
        for (tracePtr2 = iPtr->tracePtr; tracePtr2 != NULL;
                tracePtr2 = tracePtr2->nextPtr) {
            if (tracePtr2->nextPtr == tracePtr) {
                tracePtr2->nextPtr = tracePtr->nextPtr;
                ckfree((char *) tracePtr);
                break;
            }
        }
    }
 
    if (iPtr->tracePtr == NULL) {
        /*
         * When compiling new code, allow commands to be compiled inline.
         */
 
        iPtr->flags &= ~DONT_COMPILE_CMDS_INLINE;
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_AddErrorInfo --
 *
 *      Add information to the "errorInfo" variable that describes the
 *      current error.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      The contents of message are added to the "errorInfo" variable.
 *      If Tcl_Eval has been called since the current value of errorInfo
 *      was set, errorInfo is cleared before adding the new message.
 *      If we are just starting to log an error, errorInfo is initialized
 *      from the error message in the interpreter's result.
 *
 *----------------------------------------------------------------------
 */
 
void
Tcl_AddErrorInfo(interp, message)
    Tcl_Interp *interp;         /* Interpreter to which error information
                                 * pertains. */
    char *message;              /* Message to record. */
{
    Tcl_AddObjErrorInfo(interp, message, -1);
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_AddObjErrorInfo --
 *
 *      Add information to the "errorInfo" variable that describes the
 *      current error. This routine differs from Tcl_AddErrorInfo by
 *      taking a byte pointer and length.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      "length" bytes from "message" are added to the "errorInfo" variable.
 *      If "length" is negative, use bytes up to the first NULL byte.
 *      If Tcl_EvalObj has been called since the current value of errorInfo
 *      was set, errorInfo is cleared before adding the new message.
 *      If we are just starting to log an error, errorInfo is initialized
 *      from the error message in the interpreter's result.
 *
 *----------------------------------------------------------------------
 */
 
void
Tcl_AddObjErrorInfo(interp, message, length)
    Tcl_Interp *interp;         /* Interpreter to which error information
                                 * pertains. */
    char *message;              /* Points to the first byte of an array of
                                 * bytes of the message. */
    register int length;        /* The number of bytes in the message.
                                 * If < 0, then append all bytes up to a
                                 * NULL byte. */
{
    register Interp *iPtr = (Interp *) interp;
    Tcl_Obj *namePtr, *messagePtr;
 
    /*
     * If we are just starting to log an error, errorInfo is initialized
     * from the error message in the interpreter's result.
     */
 
    namePtr = Tcl_NewStringObj("errorInfo", -1);
    Tcl_IncrRefCount(namePtr);
 
    if (!(iPtr->flags & ERR_IN_PROGRESS)) { /* just starting to log error */
        iPtr->flags |= ERR_IN_PROGRESS;
 
        if (iPtr->result[0] == 0) {
            (void) Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL,
                    iPtr->objResultPtr, TCL_GLOBAL_ONLY);
        } else {                /* use the string result */
            Tcl_SetVar2(interp, "errorInfo", (char *) NULL, interp->result,
                    TCL_GLOBAL_ONLY);
        }
 
        /*
         * If the errorCode variable wasn't set by the code that generated
         * the error, set it to "NONE".
         */
 
        if (!(iPtr->flags & ERROR_CODE_SET)) {
            (void) Tcl_SetVar2(interp, "errorCode", (char *) NULL, "NONE",
                    TCL_GLOBAL_ONLY);
        }
    }
 
    /*
     * Now append "message" to the end of errorInfo.
     */
 
    if (length != 0) {
        messagePtr = Tcl_NewStringObj(message, length);
        Tcl_IncrRefCount(messagePtr);
        Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL, messagePtr,
                (TCL_GLOBAL_ONLY | TCL_APPEND_VALUE));
        Tcl_DecrRefCount(messagePtr); /* free msg object appended above */
    }
 
    Tcl_DecrRefCount(namePtr);    /* free the name object */
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_VarEval --
 *
 *      Given a variable number of string arguments, concatenate them
 *      all together and execute the result as a Tcl command.
 *
 * Results:
 *      A standard Tcl return result.  An error message or other
 *      result may be left in interp->result.
 *
 * Side effects:
 *      Depends on what was done by the command.
 *
 *----------------------------------------------------------------------
 */
        /* VARARGS2 */ /* ARGSUSED */
int
Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1)
{
    va_list argList;
    Tcl_DString buf;
    char *string;
    Tcl_Interp *interp;
    int result;
 
    /*
     * Copy the strings one after the other into a single larger
     * string.  Use stack-allocated space for small commands, but if
     * the command gets too large than call ckalloc to create the
     * space.
     */
 
    interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
    Tcl_DStringInit(&buf);
    while (1) {
        string = va_arg(argList, char *);
        if (string == NULL) {
            break;
        }
        Tcl_DStringAppend(&buf, string, -1);
    }
    va_end(argList);
 
    result = Tcl_Eval(interp, Tcl_DStringValue(&buf));
    Tcl_DStringFree(&buf);
    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_GlobalEval --
 *
 *      Evaluate a command at global level in an interpreter.
 *
 * Results:
 *      A standard Tcl result is returned, and interp->result is
 *      modified accordingly.
 *
 * Side effects:
 *      The command string is executed in interp, and the execution
 *      is carried out in the variable context of global level (no
 *      procedures active), just as if an "uplevel #0" command were
 *      being executed.
 *
 *----------------------------------------------------------------------
 */
 
int
Tcl_GlobalEval(interp, command)
    Tcl_Interp *interp;         /* Interpreter in which to evaluate command. */
    char *command;              /* Command to evaluate. */
{
    register Interp *iPtr = (Interp *) interp;
    int result;
    CallFrame *savedVarFramePtr;
 
    savedVarFramePtr = iPtr->varFramePtr;
    iPtr->varFramePtr = NULL;
    result = Tcl_Eval(interp, command);
    iPtr->varFramePtr = savedVarFramePtr;
    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_GlobalEvalObj --
 *
 *      Execute Tcl commands stored in a Tcl object at global level in
 *      an interpreter. These commands are compiled into bytecodes if
 *      necessary.
 *
 * Results:
 *      A standard Tcl result is returned, and the interpreter's result
 *      contains a Tcl object value to supplement the return code.
 *
 * Side effects:
 *      The object is converted, if necessary, to a ByteCode object that
 *      holds the bytecode instructions for the commands. Executing the
 *      commands will almost certainly have side effects that depend on
 *      those commands.
 *
 *      The commands are executed in interp, and the execution
 *      is carried out in the variable context of global level (no
 *      procedures active), just as if an "uplevel #0" command were
 *      being executed.
 *
 *----------------------------------------------------------------------
 */
 
int
Tcl_GlobalEvalObj(interp, objPtr)
    Tcl_Interp *interp;         /* Interpreter in which to evaluate
                                 * commands. */
    Tcl_Obj *objPtr;            /* Pointer to object containing commands
                                 * to execute. */
{
    register Interp *iPtr = (Interp *) interp;
    int result;
    CallFrame *savedVarFramePtr;
 
    savedVarFramePtr = iPtr->varFramePtr;
    iPtr->varFramePtr = NULL;
    result = Tcl_EvalObj(interp, objPtr);
    iPtr->varFramePtr = savedVarFramePtr;
    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetRecursionLimit --
 *
 *      Set the maximum number of recursive calls that may be active
 *      for an interpreter at once.
 *
 * Results:
 *      The return value is the old limit on nesting for interp.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */
 
int
Tcl_SetRecursionLimit(interp, depth)
    Tcl_Interp *interp;                 /* Interpreter whose nesting limit
                                         * is to be set. */
    int depth;                          /* New value for maximimum depth. */
{
    Interp *iPtr = (Interp *) interp;
    int old;
 
    old = iPtr->maxNestingDepth;
    if (depth > 0) {
        iPtr->maxNestingDepth = depth;
    }
    return old;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_AllowExceptions --
 *
 *      Sets a flag in an interpreter so that exceptions can occur
 *      in the next call to Tcl_Eval without them being turned into
 *      errors.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      The TCL_ALLOW_EXCEPTIONS flag gets set in the interpreter's
 *      evalFlags structure.  See the reference documentation for
 *      more details.
 *
 *----------------------------------------------------------------------
 */
 
void
Tcl_AllowExceptions(interp)
    Tcl_Interp *interp;         /* Interpreter in which to set flag. */
{
    Interp *iPtr = (Interp *) interp;
 
    iPtr->evalFlags |= TCL_ALLOW_EXCEPTIONS;
}
 
Browse

Tools

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [tcl/] [generic/] [tclBasic.c] - Blame information for rev 578

Line No.	Rev	Author	Line
1	578	markom	`/*`
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-1997 Sun Microsystems, Inc.`
10			`* Copyright (c) 1998 by Scriptics Corporation.`
11			`*`
12			`* See the file "license.terms" for information on usage and redistribution`
13			`* of this file, and for a DISCLAIMER OF ALL WARRANTIES.`
14			`*`
15			`* RCS: @(#) $Id: tclBasic.c,v 1.1.1.1 2002-01-16 10:25:25 markom Exp $`
16			`*/`
17
18			`#include "tclInt.h"`
19			`#include "tclCompile.h"`
20			`#ifndef TCL_GENERIC_ONLY`
21			`# include "tclPort.h"`
22			`#endif`
23
24			`/*`
25			`* Static procedures in this file:`
26			`*/`
27
28			`static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp));`
29			`static void HiddenCmdsDeleteProc _ANSI_ARGS_((`
30			`ClientData clientData, Tcl_Interp *interp));`
31
32			`/*`
33			`* The following structure defines the commands in the Tcl core.`
34			`*/`
35
36			`typedef struct {`
37			`char name; / Name of object-based command. */`
38			`Tcl_CmdProc proc; / String-based procedure for command. */`
39			`Tcl_ObjCmdProc objProc; / Object-based procedure for command. */`
40			`CompileProc compileProc; / Procedure called to compile command. */`