tclcompile.c

tcl是工具命令语言

/* 
 * tclCompile.c --
 *
 *	This file contains procedures that compile Tcl commands or parts
 *	of commands (like quoted strings or nested sub-commands) into a
 *	sequence of instructions ("bytecodes"). 
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 * Copyright (c) 2001 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: tclCompile.c,v 1.43 2003/02/19 14:33:39 msofer Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"

/*
 * Table of all AuxData types.
 */
 
static Tcl_HashTable auxDataTypeTable;
static int auxDataTypeTableInitialized; /* 0 means not yet initialized. */

TCL_DECLARE_MUTEX(tableMutex)

/*
 * Variable that controls whether compilation tracing is enabled and, if so,
 * what level of tracing is desired:
 *    0: no compilation tracing
 *    1: summarize compilation of top level cmds and proc bodies
 *    2: display all instructions of each ByteCode compiled
 * This variable is linked to the Tcl variable "tcl_traceCompile".
 */

#ifdef TCL_COMPILE_DEBUG
int tclTraceCompile = 0;
static int traceInitialized = 0;
#endif

/*
 * A table describing the Tcl bytecode instructions. Entries in this table
 * must correspond to the instruction opcode definitions in tclCompile.h.
 * The names "op1" and "op4" refer to an instruction's one or four byte
 * first operand. Similarly, "stktop" and "stknext" refer to the topmost
 * and next to topmost stack elements.
 *
 * Note that the load, store, and incr instructions do not distinguish local
 * from global variables; the bytecode interpreter at runtime uses the
 * existence of a procedure call frame to distinguish these.
 */

InstructionDesc tclInstructionTable[] = {
   /* Name	      Bytes stackEffect #Opnds Operand types	Stack top, next	  */
    {"done",		  1,   -1,        0,   {OPERAND_NONE}},
	/* Finish ByteCode execution and return stktop (top stack item) */
    {"push1",		  2,   +1,         1,   {OPERAND_UINT1}},
	/* Push object at ByteCode objArray[op1] */
    {"push4",		  5,   +1,         1,   {OPERAND_UINT4}},
	/* Push object at ByteCode objArray[op4] */
    {"pop",		  1,   -1,        0,   {OPERAND_NONE}},
	/* Pop the topmost stack object */
    {"dup",		  1,   +1,         0,   {OPERAND_NONE}},
	/* Duplicate the topmost stack object and push the result */
    {"concat1",		  2,   INT_MIN,    1,   {OPERAND_UINT1}},
	/* Concatenate the top op1 items and push result */
    {"invokeStk1",	  2,   INT_MIN,    1,   {OPERAND_UINT1}},
	/* Invoke command named objv[0]; <objc,objv> = <op1,top op1> */
    {"invokeStk4",	  5,   INT_MIN,    1,   {OPERAND_UINT4}},
	/* Invoke command named objv[0]; <objc,objv> = <op4,top op4> */
    {"evalStk",		  1,   0,          0,   {OPERAND_NONE}},
	/* Evaluate command in stktop using Tcl_EvalObj. */
    {"exprStk",		  1,   0,          0,   {OPERAND_NONE}},
	/* Execute expression in stktop using Tcl_ExprStringObj. */
    
    {"loadScalar1",	  2,   1,          1,   {OPERAND_UINT1}},
	/* Load scalar variable at index op1 <= 255 in call frame */
    {"loadScalar4",	  5,   1,          1,   {OPERAND_UINT4}},
	/* Load scalar variable at index op1 >= 256 in call frame */
    {"loadScalarStk",	  1,   0,          0,   {OPERAND_NONE}},
	/* Load scalar variable; scalar's name is stktop */
    {"loadArray1",	  2,   0,          1,   {OPERAND_UINT1}},
	/* Load array element; array at slot op1<=255, element is stktop */
    {"loadArray4",	  5,   0,          1,   {OPERAND_UINT4}},
	/* Load array element; array at slot op1 > 255, element is stktop */
    {"loadArrayStk",	  1,   -1,         0,   {OPERAND_NONE}},
	/* Load array element; element is stktop, array name is stknext */
    {"loadStk",		  1,   0,          0,   {OPERAND_NONE}},
	/* Load general variable; unparsed variable name is stktop */
    {"storeScalar1",	  2,   0,          1,   {OPERAND_UINT1}},
	/* Store scalar variable at op1<=255 in frame; value is stktop */
    {"storeScalar4",	  5,   0,          1,   {OPERAND_UINT4}},
	/* Store scalar variable at op1 > 255 in frame; value is stktop */
    {"storeScalarStk",	  1,   -1,         0,   {OPERAND_NONE}},
	/* Store scalar; value is stktop, scalar name is stknext */
    {"storeArray1",	  2,   -1,         1,   {OPERAND_UINT1}},
	/* Store array element; array at op1<=255, value is top then elem */
    {"storeArray4",	  5,   -1,          1,   {OPERAND_UINT4}},
	/* Store array element; array at op1>=256, value is top then elem */
    {"storeArrayStk",	  1,   -2,         0,   {OPERAND_NONE}},
	/* Store array element; value is stktop, then elem, array names */
    {"storeStk",	  1,   -1,         0,   {OPERAND_NONE}},
	/* Store general variable; value is stktop, then unparsed name */
    
    {"incrScalar1",	  2,   0,          1,   {OPERAND_UINT1}},
	/* Incr scalar at index op1<=255 in frame; incr amount is stktop */
    {"incrScalarStk",	  1,   -1,         0,   {OPERAND_NONE}},
	/* Incr scalar; incr amount is stktop, scalar's name is stknext */
    {"incrArray1",	  2,   -1,         1,   {OPERAND_UINT1}},
	/* Incr array elem; arr at slot op1<=255, amount is top then elem */
    {"incrArrayStk",	  1,   -2,         0,   {OPERAND_NONE}},
	/* Incr array element; amount is top then elem then array names */
    {"incrStk",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Incr general variable; amount is stktop then unparsed var name */
    {"incrScalar1Imm",	  3,   +1,         2,   {OPERAND_UINT1, OPERAND_INT1}},
	/* Incr scalar at slot op1 <= 255; amount is 2nd operand byte */
    {"incrScalarStkImm",  2,   0,          1,   {OPERAND_INT1}},
	/* Incr scalar; scalar name is stktop; incr amount is op1 */
    {"incrArray1Imm",	  3,   0,         2,   {OPERAND_UINT1, OPERAND_INT1}},
	/* Incr array elem; array at slot op1 <= 255, elem is stktop,
	 * amount is 2nd operand byte */
    {"incrArrayStkImm",	  2,   -1,         1,   {OPERAND_INT1}},
	/* Incr array element; elem is top then array name, amount is op1 */
    {"incrStkImm",	  2,   0,         1,   {OPERAND_INT1}},
	/* Incr general variable; unparsed name is top, amount is op1 */
    
    {"jump1",		  2,   0,          1,   {OPERAND_INT1}},
	/* Jump relative to (pc + op1) */
    {"jump4",		  5,   0,          1,   {OPERAND_INT4}},
	/* Jump relative to (pc + op4) */
    {"jumpTrue1",	  2,   -1,         1,   {OPERAND_INT1}},
	/* Jump relative to (pc + op1) if stktop expr object is true */
    {"jumpTrue4",	  5,   -1,         1,   {OPERAND_INT4}},
	/* Jump relative to (pc + op4) if stktop expr object is true */
    {"jumpFalse1",	  2,   -1,         1,   {OPERAND_INT1}},
	/* Jump relative to (pc + op1) if stktop expr object is false */
    {"jumpFalse4",	  5,   -1,         1,   {OPERAND_INT4}},
	/* Jump relative to (pc + op4) if stktop expr object is false */

    {"lor",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Logical or:	push (stknext || stktop) */
    {"land",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Logical and:	push (stknext && stktop) */
    {"bitor",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Bitwise or:	push (stknext | stktop) */
    {"bitxor",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Bitwise xor	push (stknext ^ stktop) */
    {"bitand",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Bitwise and:	push (stknext & stktop) */
    {"eq",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Equal:	push (stknext == stktop) */
    {"neq",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Not equal:	push (stknext != stktop) */
    {"lt",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Less:	push (stknext < stktop) */
    {"gt",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Greater:	push (stknext || stktop) */
    {"le",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Logical or:	push (stknext || stktop) */
    {"ge",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Logical or:	push (stknext || stktop) */
    {"lshift",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Left shift:	push (stknext << stktop) */
    {"rshift",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Right shift:	push (stknext >> stktop) */
    {"add",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Add:		push (stknext + stktop) */
    {"sub",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Sub:		push (stkext - stktop) */
    {"mult",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Multiply:	push (stknext * stktop) */
    {"div",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Divide:	push (stknext / stktop) */
    {"mod",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Mod:		push (stknext % stktop) */
    {"uplus",		  1,   0,          0,   {OPERAND_NONE}},
	/* Unary plus:	push +stktop */
    {"uminus",		  1,   0,          0,   {OPERAND_NONE}},
	/* Unary minus:	push -stktop */
    {"bitnot",		  1,   0,          0,   {OPERAND_NONE}},
	/* Bitwise not:	push ~stktop */
    {"not",		  1,   0,          0,   {OPERAND_NONE}},
	/* Logical not:	push !stktop */
    {"callBuiltinFunc1",  2,   1,          1,   {OPERAND_UINT1}},
	/* Call builtin math function with index op1; any args are on stk */
    {"callFunc1",	  2,   INT_MIN,    1,   {OPERAND_UINT1}},
	/* Call non-builtin func objv[0]; <objc,objv>=<op1,top op1>  */
    {"tryCvtToNumeric",	  1,   0,          0,   {OPERAND_NONE}},
	/* Try converting stktop to first int then double if possible. */

    {"break",		  1,   0,          0,   {OPERAND_NONE}},
	/* Abort closest enclosing loop; if none, return TCL_BREAK code. */
    {"continue",	  1,   0,          0,   {OPERAND_NONE}},
	/* Skip to next iteration of closest enclosing loop; if none,
	 * return TCL_CONTINUE code. */

    {"foreach_start4",	  5,   0,          1,   {OPERAND_UINT4}},
	/* Initialize execution of a foreach loop. Operand is aux data index
	 * of the ForeachInfo structure for the foreach command. */
    {"foreach_step4",	  5,   +1,         1,   {OPERAND_UINT4}},
	/* "Step" or begin next iteration of foreach loop. Push 0 if to
	 *  terminate loop, else push 1. */

    {"beginCatch4",	  5,   0,          1,   {OPERAND_UINT4}},
	/* Record start of catch with the operand's exception index.
	 * Push the current stack depth onto a special catch stack. */
    {"endCatch",	  1,   0,          0,   {OPERAND_NONE}},
	/* End of last catch. Pop the bytecode interpreter's catch stack. */
    {"pushResult",	  1,   +1,         0,   {OPERAND_NONE}},
	/* Push the interpreter's object result onto the stack. */
    {"pushReturnCode",	  1,   +1,         0,   {OPERAND_NONE}},
	/* Push interpreter's return code (e.g. TCL_OK or TCL_ERROR) as
	 * a new object onto the stack. */
    {"streq",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Str Equal:	push (stknext eq stktop) */
    {"strneq",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Str !Equal:	push (stknext neq stktop) */
    {"strcmp",		  1,   -1,         0,   {OPERAND_NONE}},
	/* Str Compare:	push (stknext cmp stktop) */
    {"strlen",		  1,   0,          0,   {OPERAND_NONE}},
	/* Str Length:	push (strlen stktop) */
    {"strindex",	  1,   -1,         0,   {OPERAND_NONE}},
	/* Str Index:	push (strindex stknext stktop) */
    {"strmatch",	  2,   -1,         1,   {OPERAND_INT1}},
	/* Str Match:	push (strmatch stknext stktop) opnd == nocase */
    {"list",		  5,   INT_MIN,    1,   {OPERAND_UINT4}},
	/* List:	push (stk1 stk2 ... stktop) */
    {"listindex",	  1,   -1,         0,   {OPERAND_NONE}},
	/* List Index:	push (listindex stknext stktop) */
    {"listlength",	  1,   0,          0,   {OPERAND_NONE}},
	/* List Len:	push (listlength stktop) */
    {"appendScalar1",	  2,   0,          1,   {OPERAND_UINT1}},
	/* Append scalar variable at op1<=255 in frame; value is stktop */
    {"appendScalar4",	  5,   0,          1,   {OPERAND_UINT4}},
	/* Append scalar variable at op1 > 255 in frame; value is stktop */
    {"appendArray1",	  2,   -1,         1,   {OPERAND_UINT1}},
	/* Append array element; array at op1<=255, value is top then elem */
    {"appendArray4",	  5,   -1,         1,   {OPERAND_UINT4}},
	/* Append array element; array at op1>=256, value is top then elem */
    {"appendArrayStk",	  1,   -2,         0,   {OPERAND_NONE}},
	/* Append array element; value is stktop, then elem, array names */
    {"appendStk",	  1,   -1,         0,   {OPERAND_NONE}},
	/* Append general variable; value is stktop, then unparsed name */
    {"lappendScalar1",	  2,   0,          1,   {OPERAND_UINT1}},
	/* Lappend scalar variable at op1<=255 in frame; value is stktop */
    {"lappendScalar4",	  5,   0,          1,   {OPERAND_UINT4}},
	/* Lappend scalar variable at op1 > 255 in frame; value is stktop */
    {"lappendArray1",	  2,   -1,         1,   {OPERAND_UINT1}},
	/* Lappend array element; array at op1<=255, value is top then elem */
    {"lappendArray4",	  5,   -1,         1,   {OPERAND_UINT4}},
	/* Lappend array element; array at op1>=256, value is top then elem */
    {"lappendArrayStk",	  1,   -2,         0,   {OPERAND_NONE}},
	/* Lappend array element; value is stktop, then elem, array names */
    {"lappendStk",	  1,   -1,         0,   {OPERAND_NONE}},
	/* Lappend general variable; value is stktop, then unparsed name */
    {"lindexMulti",	  5,   INT_MIN,   1,   {OPERAND_UINT4}},
        /* Lindex with generalized args, operand is number of stacked objs 
	 * used: (operand-1) entries from stktop are the indices; then list 
	 * to process. */
    {"over",		  5,   +1,         1,   {OPERAND_UINT4}},
        /* Duplicate the arg-th element from top of stack (TOS=0) */
    {"lsetList",          1,   -2,         0,   {OPERAND_NONE}},
        /* Four-arg version of 'lset'. stktop is old value; next is
         * new element value, next is the index list; pushes new value */
    {"lsetFlat",          5,   INT_MIN,   1,   {OPERAND_UINT4}},
        /* Three- or >=5-arg version of 'lset', operand is number of 
	 * stacked objs: stktop is old value, next is new element value, next 
	 * come (operand-2) indices; pushes the new value.
	 */
    {0}
};

/*
 * Prototypes for procedures defined later in this file:
 */

static void		DupByteCodeInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
			    Tcl_Obj *copyPtr));
static unsigned char *	EncodeCmdLocMap _ANSI_ARGS_((
			    CompileEnv *envPtr, ByteCode *codePtr,
			    unsigned char *startPtr));
static void		EnterCmdExtentData _ANSI_ARGS_((
    			    CompileEnv *envPtr, int cmdNumber,
			    int numSrcBytes, int numCodeBytes));
static void		EnterCmdStartData _ANSI_ARGS_((
    			    CompileEnv *envPtr, int cmdNumber,
			    int srcOffset, int codeOffset));
static void		FreeByteCodeInternalRep _ANSI_ARGS_((
    			    Tcl_Obj *objPtr));
static int		GetCmdLocEncodingSize _ANSI_ARGS_((
			    CompileEnv *envPtr));
static void		LogCompilationInfo _ANSI_ARGS_((Tcl_Interp *interp,
        		    CONST char *script, CONST char *command,
			    int length));
#ifdef TCL_COMPILE_STATS
static void		RecordByteCodeStats _ANSI_ARGS_((
			    ByteCode *codePtr));
#endif /* TCL_COMPILE_STATS */
static int		SetByteCodeFromAny _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));

/*
 * The structure below defines the bytecode Tcl object type by
 * means of procedures that can be invoked by generic object code.
 */

Tcl_ObjType tclByteCodeType = {
    "bytecode",				/* name */
    FreeByteCodeInternalRep,		/* freeIntRepProc */
    DupByteCodeInternalRep,		/* dupIntRepProc */
    (Tcl_UpdateStringProc *) NULL,	/* updateStringProc */
    SetByteCodeFromAny			/* setFromAnyProc */
};

/*
 *----------------------------------------------------------------------
 *
 * TclSetByteCodeFromAny --
 *
 *	Part of the bytecode Tcl object type implementation. Attempts to
 *	generate an byte code internal form for the Tcl object "objPtr" by
 *	compiling its string representation.  This function also takes
 *	a hook procedure that will be invoked to perform any needed post
 *	processing on the compilation results before generating byte
 *	codes.
 *
 * Results:
 *	The return value is a standard Tcl object result. If an error occurs
 *	during compilation, an error message is left in the interpreter's
 *	result unless "interp" is NULL.
 *
 * Side effects:
 *	Frees the old internal representation. If no error occurs, then the
 *	compiled code is stored as "objPtr"s bytecode representation.
 *	Also, if debugging, initializes the "tcl_traceCompile" Tcl variable
 *	used to trace compilations.
 *
 *----------------------------------------------------------------------
 */

int
TclSetByteCodeFromAny(interp, objPtr, hookProc, clientData)
    Tcl_Interp *interp;		/* The interpreter for which the code is
				 * being compiled.  Must not be NULL. */
    Tcl_Obj *objPtr;		/* The object to make a ByteCode object. */
    CompileHookProc *hookProc;	/* Procedure to invoke after compilation. */
    ClientData clientData;	/* Hook procedure private data. */
{
    Interp *iPtr = (Interp *) interp;
    CompileEnv compEnv;		/* Compilation environment structure
				 * allocated in frame. */
    LiteralTable *localTablePtr = &(compEnv.localLitTable);
    register AuxData *auxDataPtr;
    LiteralEntry *entryPtr;
    register int i;
    int length, nested, result;
    char *string;

#ifdef TCL_COMPILE_DEBUG
    if (!traceInitialized) {
        if (Tcl_LinkVar(interp, "tcl_traceCompile",
	            (char *) &tclTraceCompile,  TCL_LINK_INT) != TCL_OK) {
            panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable");
        }
        traceInitialized = 1;
    }
#endif

    if (iPtr->evalFlags & TCL_BRACKET_TERM) {
	nested = 1;
    } else {
	nested = 0;
    }
    string = Tcl_GetStringFromObj(objPtr, &length);
    TclInitCompileEnv(interp, &compEnv, string, length);
    result = TclCompileScript(interp, string, length, nested, &compEnv);

    if (result == TCL_OK) {
	/*
	 * Successful compilation. Add a "done" instruction at the end.
	 */

	compEnv.numSrcBytes = iPtr->termOffset;
	TclEmitOpcode(INST_DONE, &compEnv);

	/*
	 * Invoke the compilation hook procedure if one exists.
	 */

	if (hookProc) {
	    result = (*hookProc)(interp, &compEnv, clientData);