tclbasic.c

来自「tcl是工具命令语言」· C语言 代码 · 共 2,069 行 · 第 1/5 页

/* 
 * tclBasic.c --
 *
 *	Contains the basic facilities for TCL command interpretation,
 *	including interpreter creation and deletion, command creation
 *	and deletion, and command/script execution. 
 *
 * Copyright (c) 1987-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * Copyright (c) 2001, 2002 by Kevin B. Kenny.  All rights reserved.
 *
 * 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.75 2003/02/18 02:37:52 msofer Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"
#ifndef TCL_GENERIC_ONLY
#   include "tclPort.h"
#endif

/*
 * Static procedures in this file:
 */

static char *		CallCommandTraces _ANSI_ARGS_((Interp *iPtr, 
			    Command *cmdPtr, CONST char *oldName, 
			    CONST char* newName, int flags));
static void		DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp));
static void		ProcessUnexpectedResult _ANSI_ARGS_((
			    Tcl_Interp *interp, int returnCode));
static int	        StringTraceProc _ANSI_ARGS_((ClientData clientData,
						     Tcl_Interp* interp,
						     int level,
						     CONST char* command,
						    Tcl_Command commandInfo,
						    int objc,
						    Tcl_Obj *CONST objv[]));
static void           StringTraceDeleteProc _ANSI_ARGS_((ClientData clientData));

extern TclStubs tclStubs;

/*
 * 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,
	TclCompileAppendCmd,		1},
    {"array",		(Tcl_CmdProc *) NULL,	Tcl_ArrayObjCmd,
        (CompileProc *) NULL,		1},
    {"binary",		(Tcl_CmdProc *) NULL,	Tcl_BinaryObjCmd,
        (CompileProc *) NULL,		1},
    {"break",		(Tcl_CmdProc *) NULL,	Tcl_BreakObjCmd,
        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_CmdProc *) NULL,	Tcl_ContinueObjCmd,
        TclCompileContinueCmd,		1},
    {"encoding",	(Tcl_CmdProc *) NULL,	Tcl_EncodingObjCmd,
        (CompileProc *) NULL,		0},
    {"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_CmdProc *) NULL,	Tcl_FileEventObjCmd,
        (CompileProc *) NULL,		1},
    {"for",		(Tcl_CmdProc *) NULL,	Tcl_ForObjCmd,
        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_CmdProc *) NULL,	Tcl_IfObjCmd,
        TclCompileIfCmd,		1},
    {"incr",		(Tcl_CmdProc *) NULL,	Tcl_IncrObjCmd,
        TclCompileIncrCmd,		1},
    {"info",		(Tcl_CmdProc *) NULL,	Tcl_InfoObjCmd,
        (CompileProc *) NULL,		1},
    {"join",		(Tcl_CmdProc *) NULL,	Tcl_JoinObjCmd,
        (CompileProc *) NULL,		1},
    {"lappend",		(Tcl_CmdProc *) NULL,	Tcl_LappendObjCmd,
        TclCompileLappendCmd,		1},
    {"lindex",		(Tcl_CmdProc *) NULL,	Tcl_LindexObjCmd,
        TclCompileLindexCmd,		1},
    {"linsert",		(Tcl_CmdProc *) NULL,	Tcl_LinsertObjCmd,
        (CompileProc *) NULL,		1},
    {"list",		(Tcl_CmdProc *) NULL,	Tcl_ListObjCmd,
        TclCompileListCmd,		1},
    {"llength",		(Tcl_CmdProc *) NULL,	Tcl_LlengthObjCmd,
        TclCompileLlengthCmd,		1},
    {"load",		(Tcl_CmdProc *) NULL,	Tcl_LoadObjCmd,
        (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},
    {"lset",            (Tcl_CmdProc *) NULL,   Tcl_LsetObjCmd,
        TclCompileLsetCmd,           	1},
    {"lsort",		(Tcl_CmdProc *) NULL,	Tcl_LsortObjCmd,
        (CompileProc *) NULL,		1},
    {"namespace",	(Tcl_CmdProc *) NULL,	Tcl_NamespaceObjCmd,
        (CompileProc *) NULL,		1},
    {"package",		(Tcl_CmdProc *) NULL,	Tcl_PackageObjCmd,
        (CompileProc *) NULL,		1},
    {"proc",		(Tcl_CmdProc *) NULL,	Tcl_ProcObjCmd,	
        (CompileProc *) NULL,		1},
    {"regexp",		(Tcl_CmdProc *) NULL,	Tcl_RegexpObjCmd,
        TclCompileRegexpCmd,		1},
    {"regsub",		(Tcl_CmdProc *) NULL,	Tcl_RegsubObjCmd,
        (CompileProc *) NULL,		1},
    {"rename",		(Tcl_CmdProc *) NULL,	Tcl_RenameObjCmd,
        (CompileProc *) NULL,		1},
    {"return",		(Tcl_CmdProc *) NULL,	Tcl_ReturnObjCmd,	
        TclCompileReturnCmd,		1},
    {"scan",		(Tcl_CmdProc *) NULL,	Tcl_ScanObjCmd,
        (CompileProc *) NULL,		1},
    {"set",		(Tcl_CmdProc *) NULL,	Tcl_SetObjCmd,
        TclCompileSetCmd,		1},
    {"split",		(Tcl_CmdProc *) NULL,	Tcl_SplitObjCmd,
        (CompileProc *) NULL,		1},
    {"string",		(Tcl_CmdProc *) NULL,	Tcl_StringObjCmd,
        TclCompileStringCmd,		1},
    {"subst",		(Tcl_CmdProc *) NULL,	Tcl_SubstObjCmd,
        (CompileProc *) NULL,		1},
    {"switch",		(Tcl_CmdProc *) NULL,	Tcl_SwitchObjCmd,	
        (CompileProc *) NULL,		1},
    {"trace",		(Tcl_CmdProc *) NULL,	Tcl_TraceObjCmd,
        (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_CmdProc *) NULL,	Tcl_WhileObjCmd,
        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_CmdProc *) NULL,	Tcl_FconfigureObjCmd,
        (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_CmdProc *) NULL,	Tcl_GlobObjCmd,
        (CompileProc *) NULL,		0},
    {"open",		(Tcl_CmdProc *) NULL,	Tcl_OpenObjCmd,
        (CompileProc *) NULL,		0},
    {"pid",		(Tcl_CmdProc *) NULL,	Tcl_PidObjCmd,
        (CompileProc *) NULL,		1},
    {"puts",		(Tcl_CmdProc *) NULL,	Tcl_PutsObjCmd,
        (CompileProc *) NULL,		1},
    {"pwd",		(Tcl_CmdProc *) NULL,	Tcl_PwdObjCmd,
        (CompileProc *) NULL,		0},
    {"read",		(Tcl_CmdProc *) NULL,	Tcl_ReadObjCmd,
        (CompileProc *) NULL,		1},
    {"seek",		(Tcl_CmdProc *) NULL,	Tcl_SeekObjCmd,
        (CompileProc *) NULL,		1},
    {"socket",		(Tcl_CmdProc *) NULL,	Tcl_SocketObjCmd,
        (CompileProc *) NULL,		0},
    {"tell",		(Tcl_CmdProc *) NULL,	Tcl_TellObjCmd,
        (CompileProc *) NULL,		1},
    {"time",		(Tcl_CmdProc *) NULL,	Tcl_TimeObjCmd,
        (CompileProc *) NULL,		1},
    {"update",		(Tcl_CmdProc *) NULL,	Tcl_UpdateObjCmd,
        (CompileProc *) NULL,		1},
    {"vwait",		(Tcl_CmdProc *) NULL,	Tcl_VwaitObjCmd,
        (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_CmdProc *) NULL, 	Tcl_LsObjCmd,
        (CompileProc *) NULL,		0},
    {"resource",	(Tcl_CmdProc *) NULL,	Tcl_ResourceObjCmd,
        (CompileProc *) NULL,		1},
    {"source",		(Tcl_CmdProc *) NULL,	Tcl_MacSourceObjCmd,
        (CompileProc *) NULL,		0},
#else
    {"exec",		(Tcl_CmdProc *) NULL,	Tcl_ExecObjCmd,
        (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}
};

/*
 * The following structure holds the client data for string-based
 * trace procs
 */

typedef struct StringTraceData {
    ClientData clientData;	/* Client data from Tcl_CreateTrace */
    Tcl_CmdTraceProc* proc;	/* Trace procedure from Tcl_CreateTrace */
} StringTraceData;

/*
 *----------------------------------------------------------------------
 *
 * 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 the built-in commands
 *      and with the variables documented in tclvars(n).
 *
 *----------------------------------------------------------------------
 */

Tcl_Interp *
Tcl_CreateInterp()
{
    Interp *iPtr;
    Tcl_Interp *interp;
    Command *cmdPtr;
    BuiltinFunc *builtinFuncPtr;
    MathFunc *mathFuncPtr;
    Tcl_HashEntry *hPtr;
    CmdInfo *cmdInfoPtr;
    int i;
    union {
	char c[sizeof(short)];
	short s;
    } order;
#ifdef TCL_COMPILE_STATS
    ByteCodeStats *statsPtr;
#endif /* TCL_COMPILE_STATS */

    TclInitSubsystems(NULL);

    /*
     * 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.
     */

    iPtr = (Interp *) ckalloc(sizeof(Interp));
    interp = (Tcl_Interp *) iPtr;

    iPtr->result		= iPtr->resultSpace;
    iPtr->freeProc		= NULL;
    iPtr->errorLine		= 0;
    iPtr->objResultPtr		= Tcl_NewObj();
    Tcl_IncrRefCount(iPtr->objResultPtr);
    iPtr->handle		= TclHandleCreate(iPtr);
    iPtr->globalNsPtr		= NULL;
    iPtr->hiddenCmdTablePtr	= NULL;
    iPtr->interpInfo		= NULL;
    Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS);

    iPtr->numLevels = 0;
    iPtr->maxNestingDepth = MAX_NESTING_DEPTH;
    iPtr->framePtr = NULL;
    iPtr->varFramePtr = NULL;
    iPtr->activeVarTracePtr = NULL;
    iPtr->returnCode = TCL_OK;
    iPtr->errorInfo = NULL;
    iPtr->errorCode = NULL;

    iPtr->appendResult = NULL;
    iPtr->appendAvl = 0;
    iPtr->appendUsed = 0;

    Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS);
    iPtr->packageUnknown = NULL;
    iPtr->cmdCount = 0;
    iPtr->termOffset = 0;
    TclInitLiteralTable(&(iPtr->literalTable));
    iPtr->compileEpoch = 0;
    iPtr->compiledProcPtr = NULL;
    iPtr->resolverPtr = NULL;
    iPtr->evalFlags = 0;
    iPtr->scriptFile = NULL;
    iPtr->flags = 0;
    iPtr->tracePtr = NULL;
    iPtr->tracesForbiddingInline = 0;
    iPtr->activeCmdTracePtr = NULL;
    iPtr->activeInterpTracePtr = 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(interp, "",
	    (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL);
    if (iPtr->globalNsPtr == NULL) {
        panic("Tcl_CreateInterp: can't create global namespace");
    }

    /*
     * Initialize support for code compilation and execution. We call
     * TclCreateExecEnv after initializing namespaces since it tries to
     * reference a Tcl variable (it links to the Tcl "tcl_traceExec"
     * variable).
     */

    iPtr->execEnvPtr = TclCreateExecEnv(interp);

    /*
     * Initialize the compilation and execution statistics kept for this
     * interpreter.
     */

#ifdef TCL_COMPILE_STATS
    statsPtr = &(iPtr->stats);
    statsPtr->numExecutions = 0;
    statsPtr->numCompilations = 0;
    statsPtr->numByteCodesFreed = 0;
    (VOID *) memset(statsPtr->instructionCount, 0,
	    sizeof(statsPtr->instructionCount));

    statsPtr->totalSrcBytes = 0.0;
    statsPtr->totalByteCodeBytes = 0.0;
    statsPtr->currentSrcBytes = 0.0;
    statsPtr->currentByteCodeBytes = 0.0;
    (VOID *) memset(statsPtr->srcCount, 0, sizeof(statsPtr->srcCount));
    (VOID *) memset(statsPtr->byteCodeCount, 0,
	    sizeof(statsPtr->byteCodeCount));
    (VOID *) memset(statsPtr->lifetimeCount, 0,
	    sizeof(statsPtr->lifetimeCount));
    
    statsPtr->currentInstBytes   = 0.0;
    statsPtr->currentLitBytes    = 0.0;
    statsPtr->currentExceptBytes = 0.0;
    statsPtr->currentAuxBytes    = 0.0;
    statsPtr->currentCmdMapBytes = 0.0;
    
    statsPtr->numLiteralsCreated    = 0;
    statsPtr->totalLitStringBytes   = 0.0;
    statsPtr->currentLitStringBytes = 0.0;