initial commit of Ozgur Dogan Ugurlu's (SF user:dogeen) assembler for the Tcl bytecode language

1 files changed, 1537 insertions, 0 deletions

diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
new file mode 100644
index 0000000..7063b8a
--- /dev/null
+++ b/generic/tclAssembly.c
@@ -0,0 +1,1537 @@
+#include "tclInt.h"
+#include "tclCompile.h"
+#include "tclAssembly.h"
+#include "tclOOInt.h"
+
+/* Static functions defined in this file */
+
+static void AddBasicBlockRangeToErrorInfo(Tcl_Interp* interp, Tcl_Obj* bcList,
+					  BasicBlock* bbPtr);
+static void AddInstructionToErrorInfo(Tcl_Interp* interp, Tcl_Obj* bcList,
+				      int index);
+static BasicBlock * AllocBB(CompileEnv*, int); 
+static int CheckNamespaceQualifiers(Tcl_Interp*, const char*);
+static int CheckOneByte(Tcl_Interp*, int);
+static int CheckSignedOneByte(Tcl_Interp*, int);
+static int StackCheckBasicBlock(StackCheckerState* , BasicBlock *, BasicBlock *, int);
+static BasicBlock* StartBasicBlock(CompileEnv* envPtr, 	Tcl_HashTable* BBHash,
+				   BasicBlock* currBB, int fallsThrough,
+				   int bcIndex, const char* jumpLabel);
+
+static int CheckStack(Tcl_Interp*, CompileEnv*, BasicBlock *, Tcl_Obj*);
+static void FreeAssembleCodeInternalRep(Tcl_Obj *objPtr);
+static ByteCode * CompileAssembleObj(Tcl_Interp *interp, Tcl_Obj *objPtr);
+static int DefineLabel(Tcl_Interp* interp, CompileEnv* envPtr,
+		       const char* label, Tcl_HashTable* labelHash);
+
+static const Tcl_ObjType assembleCodeType = {
+    "assemblecode",
+    FreeAssembleCodeInternalRep,	/* freeIntRepProc */
+    NULL,	/* dupIntRepProc */
+    NULL,			/* updateStringProc */
+    NULL			/* setFromAnyProc */
+};
+
+/* static int AdvanceIp(const unsigned char *pc); */
+static int StackCheckBasicBlock(StackCheckerState* , BasicBlock *, BasicBlock *, int);
+
+/*
+ * TIP #280: Remember the per-word line information of the current command. An
+ * index is used instead of a pointer as recursive compilation may reallocate,
+ * i.e. move, the array. This is also the reason to save the nuloc now, it may
+ * change during the course of the function.
+ *
+ * Macro to encapsulate the variable definition and setup.
+ */
+
+#define DefineLineInformation \
+    ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr;				\
+    int eclIndex = mapPtr->nuloc - 1
+
+#define SetLineInformation(word) \
+    envPtr->line = mapPtr->loc[eclIndex].line[(word)];			\
+    envPtr->clNext = mapPtr->loc[eclIndex].next[(word)]
+
+/*
+ * Flags bits used by PushVarName.
+ */
+
+#define TCL_NO_LARGE_INDEX 1	/* Do not return localIndex value > 255 */
+
+talInstDesc talInstructionTable[] = {
+
+    /* PUSH must be first, see the code near the end of TclAssembleCode */
+
+    {"push",    ASSEM_PUSH  ,   (INST_PUSH1<<8
+			         | INST_PUSH4), 0   ,   1},
+
+    {"add",	ASSEM_1BYTE ,   INST_ADD    ,   2   ,   1},
+    {"append",  ASSEM_LVT,	(INST_APPEND_SCALAR1<<8
+	    			 | INST_APPEND_SCALAR4),
+                                                1,      1},
+    {"appendArray",
+                ASSEM_LVT,	(INST_APPEND_ARRAY1<<8
+	    			 | INST_APPEND_ARRAY4),
+                                                2,      1},
+    {"appendArrayStk", 
+                ASSEM_1BYTE,    INST_APPEND_ARRAY_STK,
+                                                3,      1}, 
+    {"appendStk", 
+                ASSEM_1BYTE,    INST_APPEND_STK, 
+                                                2,      1}, 
+    {"concat",	ASSEM_CONCAT1,	INST_CONCAT1,	INT_MIN,1},
+    {"eval",	ASSEM_EVAL,	0,		0,	1},
+    {"evalStk",	ASSEM_1BYTE,	INST_EVAL_STK,	1,	1},
+    {"exprStk", ASSEM_1BYTE,	INST_EXPR_STK,	1,	1},
+    {"exist",	ASSEM_LVT4,	INST_EXIST_SCALAR,
+                                                0,      1},
+    {"existArray",
+		ASSEM_LVT4,	INST_EXIST_ARRAY,
+                                                1,      1},
+    {"existArrayStk",
+		ASSEM_1BYTE,	INST_EXIST_ARRAY_STK,
+						2,	1},
+    {"existStk",
+		ASSEM_1BYTE,	INST_EXIST_STK,	1,	1},
+    {"bitand",  ASSEM_1BYTE ,   INST_BITAND ,   2   ,   1},
+    {"bitnot",	ASSEM_1BYTE,    INST_BITNOT,    2,      1},
+    {"bitor",   ASSEM_1BYTE ,   INST_BITOR  ,   2   ,   1},
+    {"bitxor",  ASSEM_1BYTE ,   INST_BITXOR ,   2   ,   1},
+    {"div",     ASSEM_1BYTE,    INST_DIV,       2,      1},
+    {"dup",     ASSEM_1BYTE ,   INST_DUP    ,   1   ,   2}, 
+    {"eq",      ASSEM_1BYTE ,   INST_EQ     ,   2   ,   1},
+    {"expon",   ASSEM_1BYTE,    INST_EXPON,     2,      1},
+    {"ge",      ASSEM_1BYTE ,   INST_GE     ,   2   ,   1},
+    {"gt",      ASSEM_1BYTE ,   INST_GT     ,   2   ,   1},
+    {"incr",    ASSEM_LVT1,     INST_INCR_SCALAR1,
+                                                1,      1},
+    {"incrArray", 
+                ASSEM_LVT1,     INST_INCR_ARRAY1, 
+                                                2,      1},
+    {"incrArrayImm", 
+                ASSEM_LVT1_SINT1,
+                                INST_INCR_ARRAY1_IMM, 
+                                                1,      1},
+    {"incrArrayStk", ASSEM_1BYTE, INST_INCR_ARRAY_STK, 
+                                                3,      1},
+    {"incrArrayStkImm", 
+		ASSEM_SINT1,    INST_INCR_ARRAY_STK_IMM, 
+                                                2,      1},    
+    {"incrImm", 
+                ASSEM_LVT1_SINT1,
+                                INST_INCR_SCALAR1_IMM, 
+                                                0,      1},
+    {"incrStk", ASSEM_1BYTE,    INST_INCR_SCALAR_STK, 
+                                                2,      1},
+    {"incrStkImm", 
+                ASSEM_SINT1,    INST_INCR_SCALAR_STK_IMM, 
+                                                1,      1},
+    {"invokeStk",
+                ASSEM_INVOKE,   (INST_INVOKE_STK1 << 8
+		                 | INST_INVOKE_STK4),
+                                                INT_MIN,1},
+    {"jump",    ASSEM_JUMP,     (INST_JUMP1 << 8
+		                 | INST_JUMP4), 0,      0},
+    {"jumpFalse",
+                ASSEM_JUMP,     (INST_JUMP_FALSE1 << 8
+	                         | INST_JUMP_FALSE4), 
+                                                1,      0},
+    {"jumpTrue",ASSEM_JUMP,     (INST_JUMP_TRUE1 << 8
+		                 | INST_JUMP_TRUE4), 
+                                                1,      0},
+    {"label",   ASSEM_LABEL,    0, 		0,	0}, 
+    {"land",    ASSEM_1BYTE ,   INST_LAND   ,   2   ,   1},
+    {"lappend",  ASSEM_LVT,	(INST_LAPPEND_SCALAR1<<8
+	    			 | INST_LAPPEND_SCALAR4),
+                                                1,      1},
+    {"lappendArray",
+                ASSEM_LVT,	(INST_LAPPEND_ARRAY1<<8
+	    			 | INST_LAPPEND_ARRAY4),
+                                                2,      1},
+    {"lappendArrayStk", 
+                ASSEM_1BYTE,    INST_LAPPEND_ARRAY_STK,
+                                                3,      1}, 
+    {"lappendStk", 
+                ASSEM_1BYTE,    INST_LAPPEND_STK, 
+                                                2,      1}, 
+    {"le",      ASSEM_1BYTE ,   INST_LE     ,   2   ,   1},
+    {"listIndex", 
+     		ASSEM_1BYTE,    INST_LIST_INDEX,2,      1},
+    {"listLength",
+                ASSEM_1BYTE,    INST_LIST_LENGTH,
+                                                1,    1},
+    {"load",    ASSEM_LVT,      (INST_LOAD_SCALAR1 << 8
+	                         | INST_LOAD_SCALAR4), 
+                                                0,      1}, 
+    {"loadArray",
+                ASSEM_LVT,      (INST_LOAD_ARRAY1<<8
+			         | INST_LOAD_ARRAY4),
+                                                1,      1},
+    {"loadArrayStk", 
+                ASSEM_1BYTE,    INST_LOAD_ARRAY_STK,
+                                                2,      1},
+    {"loadStk", ASSEM_1BYTE,    INST_LOAD_SCALAR_STK,
+                                                1,      1},
+    {"lor",     ASSEM_1BYTE ,   INST_LOR    ,   2   ,   1},
+    {"lsetList", 
+                ASSEM_1BYTE,    INST_LSET_LIST, 3,      1},
+    {"lshift",  ASSEM_1BYTE ,   INST_LSHIFT ,   2   ,   1},
+    {"lt",      ASSEM_1BYTE ,   INST_LT     ,   2   ,   1},
+    {"mod",     ASSEM_1BYTE,    INST_MOD,       2,      1},
+    {"mult",    ASSEM_1BYTE ,   INST_MULT   ,   2   ,   1},
+    {"neq",     ASSEM_1BYTE ,   INST_NEQ    ,   2   ,   1},
+    {"not",     ASSEM_1BYTE,    INST_LNOT,      2,      1},
+    {"over",    ASSEM_OVER,     INST_OVER,      INT_MIN, -1-1},
+    {"pop",     ASSEM_1BYTE ,   INST_POP    ,   1   ,   0},
+    {"reverse", ASSEM_REVERSE,  INST_REVERSE,   INT_MIN, -1-0},
+    {"rshift",  ASSEM_1BYTE ,   INST_RSHIFT ,   2   ,   1},
+    {"store",   ASSEM_LVT,      (INST_STORE_SCALAR1<<8
+				      | INST_STORE_SCALAR4),
+                                                1,      1}, 
+    {"storeArray", 
+                ASSEM_LVT,      (INST_STORE_ARRAY1<<8
+                                 | INST_STORE_ARRAY4),
+                                                2,      1}, 
+    {"storeArrayStk", 
+                ASSEM_1BYTE,    INST_STORE_ARRAY_STK,
+                                                3,      1}, 
+    {"storeStk", 
+                ASSEM_1BYTE,    INST_STORE_SCALAR_STK, 
+                                                2,      1}, 
+    {"strcmp",  ASSEM_1BYTE,    INST_STR_CMP,   2,      1},
+    {"streq",   ASSEM_1BYTE,    INST_STR_EQ,    2,      1},
+    {"strindex", 
+                ASSEM_1BYTE,    INST_STR_INDEX, 2,      1},
+    {"strlen",  ASSEM_1BYTE,    INST_STR_LEN,   1,      1},
+    {"strmatch",
+                ASSEM_BOOL,     INST_STR_MATCH, 2,      1},
+    {"strneq",  ASSEM_1BYTE,    INST_STR_NEQ,   2,      1},
+    {"sub",     ASSEM_1BYTE ,   INST_SUB    ,   2   ,   1},
+    {"uminus",  ASSEM_1BYTE,    INST_UMINUS,    1,      1},
+    {"unset",	ASSEM_BOOL_LVT4,
+				INST_UNSET_SCALAR,
+                                                0,      0},
+    {"unsetArray",
+		ASSEM_BOOL_LVT4,
+				INST_UNSET_ARRAY,
+                                                1,      0},
+    {"unsetArrayStk",
+		ASSEM_BOOL,	INST_UNSET_ARRAY_STK,
+						2,	0},
+    {"unsetStk",
+		ASSEM_BOOL,	INST_UNSET_STK,	1,	0},
+    {"uplus",   ASSEM_1BYTE,    INST_UPLUS,     1,      1},
+    {NULL, 0, 0,0}
+};
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * BBAdjustStackDepth --
+ *
+ *	When an opcode is emitted, adjusts the stack information in the
+ *	basic block to reflect the number of operands produced and consumed.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Updates minimum, maximum and final stack requirements in the
+ *	basic block.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static void
+BBAdjustStackDepth(BasicBlock* bbPtr,
+				/* Structure describing the basic block */
+		   int consumed,
+				/* Count of operands consumed by the 
+				 * operation */
+		   int produced)
+				/* Count of operands produced by the
+				 * operation */
+{
+    int depth = bbPtr->finalStackDepth;
+    depth -= consumed;
+    if (depth < bbPtr->minStackDepth) {
+	bbPtr->minStackDepth = depth;
+    }
+    depth += produced;
+    if (depth > bbPtr->maxStackDepth) {
+	bbPtr->maxStackDepth = depth;
+    }
+    bbPtr->finalStackDepth = depth;
+#if 0
+    fprintf(stderr, "update bb: consumed %d produced %d"
+	    " min %d max %d final %d\n",
+	    consumed, produced, bbPtr->minStackDepth, bbPtr->maxStackDepth,
+	    bbPtr->finalStackDepth);
+    fflush(stderr);
+#endif
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * BBUpdateStackReqs --
+ *
+ *	Updates the stack requirements of a basic block, given the opcode
+ *	being emitted and an operand count.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Updates min, max and final stack requirements in the basic block.
+ *
+ * Notes:
+ *	This function must not be called for instructions such as REVERSE
+ *	and OVER that are variadic but do not consume all their operands.
+ *	Instead, BBAdjustStackDepth should be called directly.
+ *
+ *	count should be provided only for variadic operations. For
+ *	operations with known arity, count should be 0.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static void
+BBUpdateStackReqs(BasicBlock* bbPtr,
+				/* Structure describing the basic block */
+		  int tblind,   /* Index in talInstructionTable of the
+				 * operation being assembled */
+		  int count)	/* Count of operands for variadic insts */
+{
+    int consumed = talInstructionTable[tblind].operandsConsumed;
+    int produced = talInstructionTable[tblind].operandsProduced;
+    if (consumed == INT_MIN) {
+	/* The instruction is variadic; it consumes 'count' operands. */
+	consumed = count;
+    }
+    if (produced < 0) {
+	/* The instruction leaves some of its operations on the stack,
+	 * with net stack effect of '-1-produced' */
+	produced = consumed - produced - 1;
+    }
+    BBAdjustStackDepth(bbPtr, consumed, produced);
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * BBEmitOpcode, BBEmitInstInt1, BBEmitInstInt4 --
+ *
+ *	Emit the opcode part of an instruction, or the entirety of an
+ *      instruction with a 1- or 4-byte operand, and adjust stack requirements.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Stores instruction and operand in the operand stream, and
+ *	adjusts the stack.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static void
+BBEmitOpcode(CompileEnv* envPtr,/* Compilation environment */
+	     BasicBlock* bbPtr,	/* Basic block to which the op belongs */
+	     int tblind,	/* Table index in talInstructionTable of op */
+	     int count)		/* Operand count for variadic ops */
+{
+    int op = talInstructionTable[tblind].tclInstCode & 0xff;
+#if 0
+    fprintf(stderr, "Emit %s (%d)\n", tclInstructionTable[op].name, count);
+    fflush(stderr);
+#endif
+    TclEmitInt1(op, envPtr);
+    envPtr->atCmdStart = ((op) == INST_START_CMD);
+    BBUpdateStackReqs(bbPtr, tblind, count);
+}
+static void
+BBEmitInstInt1(CompileEnv* envPtr,
+				/* Compilation environment */
+	       BasicBlock* bbPtr,
+				/* basic block to which the op belongs */
+	       int tblind,	/* Index in talInstructionTable of op */
+	       unsigned char opnd,
+				/* 1-byte operand */
+	       int count)	/* Operand count for variadic ops */
+{
+    BBEmitOpcode(envPtr, bbPtr, tblind, count);
+    TclEmitInt1(opnd, envPtr);
+}
+static void
+BBEmitInstInt4(CompileEnv* envPtr,
+				/* Compilation environment */
+	       BasicBlock* bbPtr,
+				/* basic block to which the op belongs */
+	       int tblind,	/* Index in talInstructionTable of op */
+	       int opnd,	/* 4-byte operand */
+	       int count)	/* Operand count for variadic ops */
+{
+    BBEmitOpcode(envPtr, bbPtr, tblind, count);
+    TclEmitInt4(opnd, envPtr);
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * BBEmitInst1or4 --
+ *
+ *	Emits a 1- or 4-byte operation according to the magnitude of the
+ *	operand
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static void
+BBEmitInst1or4(CompileEnv* envPtr,
+				/* Compilation environment */
+	       BasicBlock* bbPtr,
+				/* Basic block under construction */
+	       int tblind,	/* Index in talInstructionTable of op */
+	       int param,	/* Variable-length parameter */
+	       int count)	/* Arity if variadic */
+{
+
+    int op = talInstructionTable[tblind].tclInstCode;
+    if (param <= 0xff) {
+	op >>= 8;
+    } else {
+	op &= 0xff;
+    }
+#if 0
+    fprintf(stderr, "Emit %s (%d)\n", tclInstructionTable[op].name, count);
+    fflush(stderr);
+#endif
+    TclEmitInt1(op, envPtr);
+    if (param <= 0xff) {
+	TclEmitInt1(param, envPtr);
+    } else {
+	TclEmitInt4(param, envPtr);
+    }
+    envPtr->atCmdStart = ((op) == INST_START_CMD);
+    BBUpdateStackReqs(bbPtr, tblind, count);
+}
+
+int
+Tcl_AssembleObjCmd(
+    ClientData dummy,		/* Not used. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])	/* Argument objects. */
+{
+    return Tcl_NRCallObjProc(interp, TclNRAssembleObjCmd, dummy, objc, objv);
+}
+
+int
+TclNRAssembleObjCmd(
+    ClientData dummy,		/* Not used. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])	/* Argument objects. */
+{
+    Tcl_Obj *objPtr;
+    ByteCode *codePtr;
+
+#if 0
+    int i;
+    fprintf(stderr, "TclNRAssembleObjCmd:");
+    for (i=0; i < objc; ++i) {
+	fprintf(stderr, " {%s}", Tcl_GetString(objv[i]));
+    }
+    fprintf(stderr, "\n"); fflush(stderr);
+#endif
+
+    if (objc != 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "bytecodeList");
+	return TCL_ERROR;
+    }
+
+    objPtr = objv[1];
+    codePtr = CompileAssembleObj(interp, objPtr);
+    if (codePtr == NULL) {
+	return TCL_ERROR;
+    }
+
+#if 0
+    fprintf(stderr, "bytecode: %p\n", codePtr);
+#endif
+    Tcl_NRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_BC_TYPE), codePtr,
+	    NULL, NULL);
+
+    return TCL_OK;
+}
+
+static ByteCode *
+CompileAssembleObj(
+    Tcl_Interp *interp,
+    Tcl_Obj *objPtr)
+{
+    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. */
+    int status;			/* Status return from Tcl_AssembleCode */
+
+    /*
+     * Get the expression ByteCode from the object. If it exists, make sure it
+     * is valid in the current context.
+     */
+     
+    if (objPtr->typePtr == &assembleCodeType) {
+	Namespace *namespacePtr = iPtr->varFramePtr->nsPtr;
+
+	codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
+	if (((Interp *) *codePtr->interpHandle != iPtr)
+	    || (codePtr->compileEpoch != iPtr->compileEpoch)
+	    || (codePtr->nsPtr != namespacePtr)
+	    || (codePtr->nsEpoch != namespacePtr->resolverEpoch)
+	    || (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) {
+		    
+	    FreeAssembleCodeInternalRep(objPtr);
+	}
+    }
+    if (objPtr->typePtr != &assembleCodeType) {
+
+	int length;
+		
+	const char *string = TclGetStringFromObj(objPtr, &length);
+	TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0);
+#if 0
+	fprintf(stderr, "assembling: %s\n", string); fflush(stderr);
+#endif
+	status = TclAssembleCode(interp, objPtr, &compEnv, TCL_EVAL_DIRECT);
+	if (status != TCL_OK) {
+#if 0
+	    fprintf(stderr, "assembly failed: %s\n", 
+		    Tcl_GetString(Tcl_GetObjResult(interp)));
+	    fflush(stderr);
+#endif
+	    /* FIXME - there's memory to clean up */
+	    return NULL;
+	}
+
+	/*
+	 * Successful compilation. If the expression yielded no instructions,
+	 * push an zero object as the expression's result.
+	 */
+
+	if (compEnv.codeNext == compEnv.codeStart) {
+	    fprintf(stderr, "empty bytecode, why did this happen?\n");
+	    fflush(stderr);
+	    TclEmitPush(TclRegisterNewLiteral(&compEnv, "0", 1),
+		    &compEnv);
+	}
+
+	/*
+	 * Add a "done" instruction as the last instruction and change the
+	 * object into a ByteCode object. Ownership of the literal objects and
+	 * aux data items is given to the ByteCode object.
+	 */
+
+	TclEmitOpcode(INST_DONE, &compEnv);
+	TclInitByteCodeObj(objPtr, &compEnv);
+	objPtr->typePtr = &assembleCodeType;
+	TclFreeCompileEnv(&compEnv);
+	codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
+	if (iPtr->varFramePtr->localCachePtr) {
+	    codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
+	    codePtr->localCachePtr->refCount++;
+	}
+#ifdef TCL_COMPILE_DEBUG
+	if (tclTraceCompile >= 2) {
+	    TclPrintByteCodeObj(interp, objPtr);
+	    fflush(stdout);
+	}
+#endif /* TCL_COMPILE_DEBUG */
+    }
+    return codePtr;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * TclCompileAssembleCmd --
+ *
+ *	Compilation procedure for the '::tcl::unsupported::assemble' command.
+ *
+ * Results:
+ *	Returns a standard Tcl result.
+ *
+ * Side effects:
+ *	Puts the result of assembling the code into the bytecode stream
+ *	in 'compileEnv'.
+ *
+ * This procedure makes sure that the command has a single arg, which is
+ * constant. If that condition is met, the procedure calls TclAssembleCode
+ * to produce bytecode for the given assembly code, and returns any error
+ * resulting from the assembly.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+int TclCompileAssembleCmd(
+    Tcl_Interp *interp,		/* Used for error reporting. */
+    Tcl_Parse *parsePtr,	/* Points to a parse structure for the command
+				 * created by Tcl_ParseCommand. */
+    Command *cmdPtr,		/* Points to defintion of command being
+				 * compiled. */
+    CompileEnv *envPtr)		/* Holds resulting instructions. */
+{ 
+    Tcl_Token *tokenPtr;	/* Token in the input script */
+    Tcl_Obj *bcList;		/* List of assembly instructions to process */
+    int status;			/* Status return from assembling the code */
+
+    /* Make sure that the command has a single arg */
+
+    if (parsePtr->numWords != 2) {
+	return TCL_ERROR;
+    }
+
+    /* Make sure that the arg is a simple word */
+
+    tokenPtr = TokenAfter(parsePtr->tokenPtr);
+    if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+	return TCL_ERROR;
+    }
+
+    /* Compile the code and return any error from the compilation */
+
+    bcList = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size);
+    Tcl_IncrRefCount(bcList);
+    status = TclAssembleCode(interp, bcList, envPtr, 0);
+    Tcl_DecrRefCount(bcList);
+    return status;
+
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * TclAssembleCode --
+ *
+ *	Take a list of instructions in a Tcl_Obj, and assemble them to
+ *	Tcl bytecodes
+ *
+ * Results:
+ *	Returns TCL_OK on success, TCL_ERROR on failure.
+ *	If 'flags' includes TCL_EVAL_DIRECT, places an error message
+ *	in the interpreter result.
+ *
+ * Side effects:
+ *	Adds byte codes to the compile environment, and updates the
+ *	environment's stack depth.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+MODULE_SCOPE int
+TclAssembleCode(Tcl_Interp *interp, 
+				/* Tcl interpreter */
+		Tcl_Obj * bcList, 
+				/* List of assembly instructions */
+		CompileEnv *envPtr, 	
+				/* Compilation environment that is to
+				 * receive the generated bytecode */
+		int flags)	/* OR'ed combination of flags */
+{
+
+    int bcListLen = 0;		/* Length of the assembly code list */
+    Tcl_HashTable labelHash;	/* Hashtable storing information about
+				 * labels in the assembly code */
+    Tcl_HashTable BBHash;	/* Hashtable storing information about
+				 * the basic blocks in the bytecode */
+
+    BasicBlock* curr_bb = NULL;	/* Structure describing the current basic 
+				 * block */
+    BasicBlock* head_bb = NULL;	/* Structure describing the first basic
+				 * block in the code */
+    int ind;			/* Index in the list of instructions */
+    int result;			/* Return value from this function */
+    Tcl_Obj* bc;		/* One assembly instruction from the list */
+    int bcSize = 0;		/* Length of the instruction sublist */
+    Tcl_Obj ** bcArgs;		/* Arguments to the instruction */
+    char * instName; 		/* Name of the instruction */
+    enum talInstType instType;	/* Type of the current assembly instruction */
+    unsigned char instCode;	/* Opcode of the current assembly instruction */
+    const char* operand1;	/* First operand passed to the instruction */
+    int operand1Len;		/* Length of the first operand */
+    int tblind = 0;		/* Index in the instruction table of the
+				 * current instruction */
+    int isNew;			/* Flag == 1 if a JUMP is the first
+				 * occurrence of its associated label */
+    Tcl_Obj* resultObj;		/* Error message */
+    int savedMaxStackDepth;	/* Max stack depth saved around compilation
+				 * calls */
+    int savedCurrStackDepth;	/* Current stack depth saved around
+				 * compilation calls. */
+
+    int localVar, opnd = 0;
+    label *l;
+    Tcl_HashEntry * entry;
+    int litIndex;
+     
+    DefineLineInformation;	/* TIP #280 */ /* eclIndex? */
+     
+#if 0
+    fprintf(stderr, "Assembling: %s\n", Tcl_GetString(bcList));
+    fflush(stderr);
+#endif
+
+    /* Test that the bytecode that we're given is a well formed list */
+
+    if (Tcl_ListObjLength(interp, bcList, &bcListLen) == TCL_ERROR) {
+	return TCL_ERROR;
+    }
+  
+    /* Initialize the symbol table and the table of basic blocks */
+
+    Tcl_InitHashTable(&labelHash, TCL_STRING_KEYS);
+    Tcl_InitHashTable(&BBHash, TCL_STRING_KEYS);
+
+    /* Allocate a structure to describe the first basic block */
+
+    curr_bb = AllocBB(envPtr, 0);
+    head_bb = curr_bb;
+     
+    /* 
+     * Index through the assembly directives and instructions, generating code.
+     */
+
+    for (ind = 0; ind < bcListLen; ind++) {
+
+	/* Extract the instruction name from a list element */
+
+	result = TCL_OK;
+	if (Tcl_ListObjIndex(interp, bcList, ind, &bc) != TCL_OK
+	    || Tcl_ListObjGetElements(interp, bc, &bcSize, &bcArgs) != TCL_OK) {
+	    goto cleanup;
+	}
+	if (bcSize == 0) {
+	    continue;
+	}
+	instName = Tcl_GetStringFromObj(bcArgs[0], NULL);
+#if 0
+	fprintf(stderr, "[%d] %s\n",
+		envPtr->codeNext - envPtr->codeStart, instName); 
+	fflush(stderr);
+#endif
+
+	/* 
+	 * Extract the first operand, if there is one, and get its string
+       	 * representation 
+	 */
+
+	if (bcSize >= 2) {
+	    operand1 = Tcl_GetStringFromObj(bcArgs[1], &operand1Len);
+	} else {
+	    operand1 = NULL; 
+	    operand1Len = 0;
+	}
+
+	/* Look up the instruction in the table of instructions */
+
+	if (Tcl_GetIndexFromObjStruct(interp, bcArgs[0],
+				      &talInstructionTable[0].name,
+				      sizeof(talInstDesc), "instruction",
+				      TCL_EXACT, &tblind) != TCL_OK) {
+	    goto cleanup;
+	}
+
+	/* Vector on the type of instruction being processed */
+
+	instType = talInstructionTable[tblind].instType;
+	instCode = talInstructionTable[tblind].tclInstCode;
+	switch (instType) {
+
+	case ASSEM_LABEL:
+
+	    if (bcSize != 2) {
+		Tcl_WrongNumArgs(interp, 1, bcArgs, "name");
+		goto cleanup;
+	    }
+	    /* Add the (label_name, address) pair to the hash table */
+	    if (DefineLabel(interp, envPtr, operand1, &labelHash) != TCL_OK) {
+		goto cleanup;
+	    }
+                    
+	    /* End the current basic block and start a new one */ 
+
+	    curr_bb = StartBasicBlock(envPtr, &BBHash, curr_bb, 1, ind, NULL);
+
+	    /* Attach the label to the new basic block */
+
+	    entry = Tcl_CreateHashEntry(&BBHash, operand1, &opnd);
+	    Tcl_SetHashValue(entry, curr_bb);
+                    
+	    break;
+                
+	case ASSEM_1BYTE:
+	    if (bcSize != 1) {
+		Tcl_WrongNumArgs(interp, 1, bcArgs, "");
+		goto cleanup;
+	    }
+	    BBEmitOpcode(envPtr, curr_bb, tblind, 0);
+	    break;
+
+	case ASSEM_INVOKE:
+	    if (bcSize != 2) {
+		Tcl_WrongNumArgs(interp, 1, bcArgs, "count");
+		goto cleanup;
+	    }
+	    if (Tcl_GetIntFromObj(interp, bcArgs[1], &opnd) != TCL_OK) {
+		goto cleanup;
+	    }
+	    BBEmitInst1or4(envPtr, curr_bb, tblind, opnd, opnd);
+	    break;
+		 
+	case ASSEM_JUMP: 
+	    if (bcSize != 2) {
+		Tcl_WrongNumArgs(interp, 1, bcArgs, "label");
+		goto cleanup;
+	    }
+	    entry = Tcl_CreateHashEntry(&labelHash, operand1, &isNew);
+	    if (isNew) {
+		l = (label *) ckalloc(sizeof(label));
+		l -> isDefined = 0;
+		l -> offset = -1;
+		Tcl_SetHashValue(entry, l);
+	    } else {
+		l = Tcl_GetHashValue(entry);
+	    }
+	    if (l -> isDefined) {
+		BBEmitInst1or4(envPtr, curr_bb, tblind, 
+			       l->offset + envPtr->codeStart
+			       - envPtr->codeNext, 0);
+	    } else {
+		int here = envPtr->codeNext - envPtr->codeStart;
+		BBEmitInstInt4(envPtr, curr_bb, tblind,
+			       l->offset, 0);
+#if 0
+		fprintf(stderr, "forward ref to %s, prev at %d, link %d\n",
+			operand1, l->offset, here);
+#endif
+		l->offset = here;
+	    }   
+                    
+	    /* Start a new basic block at the instruction following the jump */
+
+	    curr_bb = 
+		StartBasicBlock(envPtr, &BBHash, curr_bb,
+				talInstructionTable[tblind].operandsConsumed,
+				ind+1, operand1);
+
+	    break;
+                             
+	case ASSEM_LVT:
+	    if (bcSize != 2) {
+		Tcl_WrongNumArgs(interp, 1, bcArgs, "varname");
+		goto cleanup;
+	    }
+	    if (CheckNamespaceQualifiers(interp, operand1)) {
+		goto cleanup;
+	    }
+	    localVar = TclFindCompiledLocal(operand1, operand1Len, 1, envPtr);
+	    if (localVar == -1) {
+		Tcl_SetObjResult(interp,
+				 Tcl_NewStringObj("cannot use this instruction"
+						  " in non-proc context", -1));
+		Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", NULL);
+		goto cleanup;
+	    }
+	    fprintf(stderr, "operand %s in slot %d\n", operand1, localVar);
+	    BBEmitInst1or4(envPtr, curr_bb, tblind, localVar, 0);
+	    break;
+
+	case ASSEM_LVT1:
+	    if (bcSize != 2) {
+		Tcl_WrongNumArgs(interp, 1, bcArgs, "varname");
+		goto cleanup;
+	    }
+	    if (CheckNamespaceQualifiers(interp, operand1)) {
+		goto cleanup;
+	    }
+	    localVar = TclFindCompiledLocal(operand1, operand1Len, 1, envPtr);
+	    if (localVar == -1) {
+		Tcl_SetObjResult(interp,
+				 Tcl_NewStringObj("cannot use this instruction"
+						  " in non-proc context", -1));
+		Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", NULL);
+		goto cleanup;
+	    }
+	    if (CheckOneByte(interp, localVar)) {
+		goto cleanup;
+	    }
+	    BBEmitInstInt1(envPtr, curr_bb, tblind, localVar, 0);
+	    break;
+
+	case ASSEM_LVT4:
+	    if (bcSize != 2) {
+		Tcl_WrongNumArgs(interp, 1, bcArgs, "varname");
+		goto cleanup;
+	    }
+	    if (CheckNamespaceQualifiers(interp, operand1)) {
+		goto cleanup;
+	    }
+	    localVar = TclFindCompiledLocal(operand1, operand1Len, 1, envPtr);
+	    if (localVar == -1) {
+		Tcl_SetObjResult(interp,
+				 Tcl_NewStringObj("cannot use this instruction"
+						  " in non-proc context", -1));
+		Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", NULL);
+		goto cleanup;
+	    }
+	    BBEmitInstInt4(envPtr, curr_bb, tblind, localVar, 0);
+	    break;
+
+	case ASSEM_BOOL:
+	    if (bcSize != 2) {
+		Tcl_WrongNumArgs(interp, 1, bcArgs, "boolean");
+		goto cleanup;
+	    }
+	    if (Tcl_GetBooleanFromObj(interp, bcArgs[1], &opnd) != TCL_OK) {
+		goto cleanup;
+	    }
+	    BBEmitInstInt1(envPtr, curr_bb, tblind, opnd, 0);
+	    break;
+
+	case ASSEM_BOOL_LVT4:
+	    if (bcSize != 3) {
+		Tcl_WrongNumArgs(interp, 1, bcArgs, "boolean varName");
+		goto cleanup;
+	    }
+	    if (Tcl_GetBooleanFromObj(interp, bcArgs[1], &opnd) != TCL_OK) {
+		goto cleanup;
+	    }
+	    operand1 = Tcl_GetStringFromObj(bcArgs[2], &operand1Len);
+	    if (CheckNamespaceQualifiers(interp, operand1)) {
+		goto cleanup;
+	    }
+	    localVar = TclFindCompiledLocal(operand1, operand1Len, 1, envPtr);
+	    if (localVar == -1) {
+		Tcl_SetObjResult(interp,
+				 Tcl_NewStringObj("cannot use this instruction"
+						  " in non-proc context", -1));
+		Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", NULL);
+		goto cleanup;
+	    }
+	    BBEmitInstInt1(envPtr, curr_bb, tblind, opnd, 0);
+	    TclEmitInt4(localVar, envPtr);
+	    break;
+
+        case ASSEM_LVT1_SINT1:
+	    if (bcSize != 3) {
+		Tcl_WrongNumArgs(interp, 1, bcArgs, "varName imm8");
+		goto cleanup;
+	    }
+	    if (CheckNamespaceQualifiers(interp, operand1)) {
+		goto cleanup;
+	    }
+	    localVar = TclFindCompiledLocal(operand1, operand1Len, 1, envPtr);
+	    if (localVar == -1) {
+		Tcl_SetObjResult(interp,
+				 Tcl_NewStringObj("cannot use this instruction"
+						  " in non-proc context", -1));
+		Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", NULL);
+		goto cleanup;
+	    }
+	    if (CheckOneByte(interp, localVar)) {
+		goto cleanup;
+	    }
+	    if (Tcl_GetIntFromObj(interp, bcArgs[2], &opnd) != TCL_OK) {
+		goto cleanup;
+	    }
+	    if (CheckSignedOneByte(interp, opnd)) {
+		goto cleanup;
+	    }
+	    BBEmitInstInt1(envPtr, curr_bb, tblind, localVar, 0);
+	    TclEmitInt1(opnd, envPtr);
+	    break;
+
+	case ASSEM_OVER:
+	    if (bcSize != 2) {
+		Tcl_WrongNumArgs(interp, 1, bcArgs, "count");
+		goto cleanup;
+	    }
+	    if (Tcl_GetIntFromObj(interp, bcArgs[1], &opnd) != TCL_OK) {
+		goto cleanup;
+	    }
+	    BBEmitInstInt4(envPtr, curr_bb, tblind, opnd, opnd+1);
+	    break;
+
+	case ASSEM_PUSH:
+	    if (bcSize != 2) {
+		Tcl_WrongNumArgs(interp, 1, bcArgs, "value");
+		goto cleanup;
+	    }
+	    litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len);
+	    BBEmitInst1or4(envPtr, curr_bb, tblind, litIndex, 0);
+	    break;
+
+	case ASSEM_REVERSE:
+	    if (bcSize != 2) {
+		Tcl_WrongNumArgs(interp, 1, bcArgs, "count");
+		goto cleanup;
+	    }
+	    if (Tcl_GetIntFromObj(interp, bcArgs[1], &opnd) != TCL_OK) {
+		goto cleanup;
+	    }
+	    BBEmitInstInt4(envPtr, curr_bb, tblind, opnd, opnd);
+	    break;
+		 
+        case ASSEM_SINT1:
+	    if (bcSize != 2) {
+		Tcl_WrongNumArgs(interp, 1, bcArgs, "imm8");
+		goto cleanup;
+	    }
+	    if (Tcl_GetIntFromObj(interp, bcArgs[1], &opnd) != TCL_OK) {
+		goto cleanup;
+	    }
+	    if (CheckSignedOneByte(interp, opnd)) {
+		goto cleanup;
+	    }
+	    BBEmitInstInt1(envPtr, curr_bb, tblind, opnd, 0);
+	    break;
+
+        case ASSEM_CONCAT1:
+	    if (bcSize != 2) {
+		Tcl_WrongNumArgs(interp, 1, bcArgs, "imm8");
+		goto cleanup;
+	    }
+	    if (Tcl_GetIntFromObj(interp, bcArgs[1], &opnd) != TCL_OK) {
+		goto cleanup;
+	    }
+	    if (CheckOneByte(interp, opnd)) {
+		goto cleanup;
+	    }
+	    BBEmitInstInt1(envPtr, curr_bb, tblind, opnd, opnd);
+	    break;
+
+	case ASSEM_EVAL:
+	    if (bcSize != 2) {
+		Tcl_WrongNumArgs(interp, 1, bcArgs, "script");
+		goto cleanup;
+	    }
+	    fprintf(stderr, "compiling: %s\n", operand1); fflush(stderr);
+	    savedMaxStackDepth = envPtr->maxStackDepth;
+	    savedCurrStackDepth = envPtr->currStackDepth;
+	    envPtr->maxStackDepth = 0;
+	    envPtr->currStackDepth = 0;
+	    TclCompileScript(interp, operand1, operand1Len, envPtr);
+	    if (curr_bb->finalStackDepth + envPtr->maxStackDepth
+		> curr_bb->maxStackDepth) {
+		curr_bb->maxStackDepth =
+		    curr_bb->finalStackDepth + envPtr->maxStackDepth;
+	    }
+	    curr_bb->finalStackDepth += envPtr->currStackDepth;
+	    envPtr->maxStackDepth = savedMaxStackDepth;
+	    envPtr->currStackDepth = savedCurrStackDepth;
+	    fprintf(stderr, "compilation returns\n"); fflush(stderr);
+	    break;
+
+	default:
+	    Tcl_Panic("Instruction \"%s\" could not be found, can't happen\n",
+		      instName);
+	}
+            
+    }
+
+    /* Tie off the last basic block */
+
+    curr_bb->may_fall_thru = 0;
+    curr_bb->jumpTargetLabelHashEntry = NULL;
+    result = CheckStack(interp, envPtr, head_bb, bcList);
+    if (result != TCL_OK) {
+	goto cleanup;
+    }
+    if (curr_bb->visited) {
+	int depth = curr_bb->finalStackDepth + curr_bb->initialStackDepth;
+	if (depth == 0) {
+	    /* Emit a 'push' of the empty literal */
+	    litIndex = TclRegisterNewLiteral(envPtr, "", 0);
+	    /* Assumes that 'push' is at slot 0 in talInstructionTable */
+	    BBEmitInst1or4(envPtr, curr_bb, 0, litIndex, 0);
+	    ++depth;
+	}
+	if (depth != 1) {
+	    Tcl_Obj* depthObj = Tcl_NewIntObj(depth);
+	    Tcl_IncrRefCount(depthObj);
+	    resultObj = Tcl_NewStringObj("stack is unbalanced on exit "
+					 "from the code (depth=", -1);
+	    Tcl_AppendObjToObj(resultObj, depthObj);
+	    Tcl_DecrRefCount(depthObj);
+	    Tcl_AppendToObj(resultObj, ")", -1);
+	    Tcl_SetObjResult(interp, resultObj);
+	    goto cleanup;
+	}
+#if 0
+	fprintf(stderr, "before: stackDepth %d\n", envPtr->currStackDepth);
+#endif
+	envPtr->currStackDepth += depth;
+#if 0
+	fprintf(stderr, "after: stackDepth %d\n", envPtr->currStackDepth);
+#endif
+	fflush(stderr);
+    }
+
+    Tcl_DeleteHashTable(&labelHash); // Actually, we need to free each label as well.
+
+    return result;
+
+ cleanup:
+    
+    /* FIXME: Need to make sure that allocated memory gets freed. */
+
+    if (ind >= 0 && ind < bcSize) {
+	Tcl_AddErrorInfo(interp, "\n    processing ");
+	AddInstructionToErrorInfo(interp, bcList, ind);
+    }
+
+    /* TODO: If ind != -1, add error info indicating where in the
+     * instruction stream things went wrong */
+
+    return TCL_ERROR;
+
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * CheckNamespaceQualifiers --
+ *
+ *	Verify that a variable name has no namespace qualifiers before
+ *	attempting to install it in the LVT.
+ *
+ * Results:
+ *	On success, returns TCL_OK. On failure, returns TCL_ERROR and
+ *	stores an error message in the interpreter result.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+CheckNamespaceQualifiers(Tcl_Interp* interp,
+				/* Tcl interpreter for error reporting */
+			 const char* name)
+				/* Variable name to check */
+{
+    Tcl_Obj* result;		/* Error message */
+    const char* p;
+    for (p = name; *p;  p++) {      
+	if ((*p == ':') && (p[1] == ':')) {
+	    result = Tcl_NewStringObj("variable \"", -1);
+	    Tcl_AppendToObj(result, name, -1);
+	    Tcl_AppendToObj(result, "\" is not local", -1);
+	    Tcl_SetObjResult(interp, result);
+	    Tcl_SetErrorCode(interp, "TCL", "ASSEMBLE", "NONLOCAL", name,
+			     NULL);
+	    return TCL_ERROR;
+	}
+    }
+    return TCL_OK;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * CheckOneByte --
+ *
+ *	Verify that a constant fits in a single byte in the instruction stream.
+ *
+ * Results:
+ *	On success, returns TCL_OK. On failure, returns TCL_ERROR and
+ *	stores an error message in the interpreter result.
+ *
+ * This code is here primarily to verify that instructions like INCR_SCALAR1
+ * are possible on a given local variable. The fact that there is no
+ * INCR_SCALAR4 is puzzling.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+CheckOneByte(Tcl_Interp* interp,
+				/* Tcl interpreter for error reporting */
+	     int value)		/* Value to check */
+{
+    Tcl_Obj* result;		/* Error message */
+    if (value < 0 || value > 0xff) {
+	result = Tcl_NewStringObj("operand does not fit in 1 byte", -1);
+	Tcl_SetObjResult(interp, result);
+	Tcl_SetErrorCode(interp, "TCL", "ASSEMBLE", "1BYTE", NULL);
+	return TCL_ERROR;
+    }
+    return TCL_OK;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * CheckSignedOneByte --
+ *
+ *	Verify that a constant fits in a single signed byte in the instruction
+ *      stream.
+ *
+ * Results:
+ *	On success, returns TCL_OK. On failure, returns TCL_ERROR and
+ *	stores an error message in the interpreter result.
+ *
+ * This code is here primarily to verify that instructions like INCR_SCALAR1
+ * are possible on a given local variable. The fact that there is no
+ * INCR_SCALAR4 is puzzling.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+CheckSignedOneByte(Tcl_Interp* interp,
+				/* Tcl interpreter for error reporting */
+	           int value)	/* Value to check */
+{
+    Tcl_Obj* result;		/* Error message */
+    if (value > 0x7f || value < -0x80) {
+	result = Tcl_NewStringObj("operand does not fit in 1 byte", -1);
+	Tcl_SetObjResult(interp, result);
+	Tcl_SetErrorCode(interp, "TCL", "ASSEMBLE", "1BYTE", NULL);
+	return TCL_ERROR;
+    }
+    return TCL_OK;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * DefineLabel --
+ *
+ *	Defines a label appearing in the assembly sequence.
+ *
+ * Results:
+ *	Returns a standard Tcl result. Returns TCL_OK and an empty result
+ *	if the definition succeeds; returns TCL_ERROR and an appropriate
+ *	message if a duplicate definition is found.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+DefineLabel(Tcl_Interp* interp, 	/* Tcl interpreter */
+	    CompileEnv* envPtr,		/* Compilation environment */
+	    const char* labelName,	/* Label being defined */
+	    Tcl_HashTable* labelHash)	/* Symbol table */
+{
+    Tcl_HashEntry* entry;	/* Label's entry in the symbol table */
+    int isNew;			/* Flag == 1 iff the label was previously
+				 * undefined */
+    label* l;			/*  */
+    Tcl_Obj* result;
+
+    /* Look up the newly-defined label in the symbol table */
+
+    entry = Tcl_CreateHashEntry(labelHash, labelName, &isNew);
+    if (isNew) {
+
+	/* This is the first appearance of the label in the code */
+
+	l = (label *)ckalloc(sizeof(label));
+	l->isDefined = 1;
+	l->offset = envPtr->codeNext - envPtr->codeStart; 
+	Tcl_SetHashValue(entry, l);
+
+    } else {
+
+	/* The label has appeared earlier. Make sure that it's not defined. */
+
+	l = (label *) Tcl_GetHashValue(entry);
+	if (l->isDefined) {
+	    result = Tcl_NewStringObj("duplicate definition of label \"", -1);
+	    Tcl_AppendToObj(result, labelName, -1);
+	    Tcl_AppendToObj(result, "\"", -1);
+	    Tcl_SetObjResult(interp, result);
+	    return TCL_ERROR;
+	} else {
+
+	    /* 
+	     * Walk the linked list of previous references to the label 
+	     * and fix them up. 
+	     */
+
+	    int jump = l->offset;
+	    while (jump >= 0) {
+		int prevJump = TclGetInt4AtPtr(envPtr->codeStart + jump + 1);
+#if 0
+		fprintf(stderr, "fixup jump at %d to refer to %d\n",
+			jump, envPtr->codeNext - envPtr->codeStart);
+#endif
+		TclStoreInt4AtPtr(envPtr->codeNext - envPtr->codeStart - jump,
+				  envPtr->codeStart + jump + 1);
+		jump = prevJump;
+	    }
+	    l->offset = envPtr->codeNext - envPtr->codeStart;
+	    l->isDefined = 1;
+	}   
+    }
+    return TCL_OK;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * StartBasicBlock --
+ *
+ *	Starts a new basic block when a label or jump is encountered.
+ *
+ * Results:
+ *	Returns a pointer to the BasicBlock structure of the new
+ *	basic block.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static BasicBlock*
+StartBasicBlock(CompileEnv* envPtr, 
+				/* Compilation environment */
+		Tcl_HashTable* BBHashPtr,
+				/* Hash table where basic blocks are recorded */
+		BasicBlock* currBB,
+				/* Pointer to the BasicBlock structure
+				 * of the block being closed. */
+		int fallsThrough,
+				/* 1 if execution falls through into
+				 * the following block, 0 otherwise */
+		int bcIndex,	/* Index of the current insn in the
+				 * assembly stream */
+		const char* jumpLabel)
+				/* Label of the location that the
+				 * block jumps to, or NULL if the block
+				 * does not jump */
+{
+    int isNew;		 /* Unused return from Tcl_CreateHashEntry */
+    BasicBlock* newBB;	 /* BasicBlock structure for the new basic block */
+
+    /* Coalesce zero-length blocks */
+
+    if (currBB->start == envPtr->codeNext) {
+	return currBB;
+    }
+
+    /* Make the new basic block */
+
+    newBB = AllocBB(envPtr, bcIndex);
+
+    /* Record the jump target if there is one. */
+
+    if (jumpLabel) {
+	currBB->jumpTargetLabelHashEntry =
+	    Tcl_CreateHashEntry(BBHashPtr, jumpLabel, &isNew);
+    } else {
+	currBB->jumpTargetLabelHashEntry = NULL;
+    }
+
+    /* Record the fallthrough if there is one. */
+
+    currBB->may_fall_thru = fallsThrough;
+
+    /* Record the successor block */
+
+    currBB->successor1 = newBB;
+    return newBB;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * AllocBB --
+ *
+ *	Allocates a new basic block
+ *
+ * Results:
+ *	Returns a pointer to the newly allocated block, which is initialized
+ *	to contain no code and begin at the current instruction pointer.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static BasicBlock * 
+AllocBB(CompileEnv* envPtr,	/* Compile environment containing the
+				 * current instruction pointer */
+	int bcIndex)		/* Current index in the list of
+				 * assembly instructions */
+{
+    BasicBlock * bb = (BasicBlock *) ckalloc(sizeof(BasicBlock));
+
+    bb->start = envPtr->codeNext;
+    bb->bcIndex = bcIndex;
+    bb->initialStackDepth = 0;
+    bb->minStackDepth = 0;
+    bb->maxStackDepth = 0;
+    bb->finalStackDepth = 0;
+
+    bb->visited = 0;
+
+    bb->predecessor = NULL;
+    bb->jumpTargetLabelHashEntry = NULL;
+    bb->successor1 = NULL;
+
+    return bb;
+}
+
+static int
+CheckStack(Tcl_Interp* interp,
+	   CompileEnv* envPtr,
+	   BasicBlock * head,
+	   Tcl_Obj* bcList) {
+    StackCheckerState st;
+    st.interp = interp;
+    st.maxDepth = 0;
+    st.envPtr = envPtr;
+    st.bcList = bcList;
+    if(StackCheckBasicBlock(&st, head, NULL, 0) == TCL_ERROR) {
+        return TCL_ERROR;
+    }
+#if 0
+    fprintf(stderr, "Max stack anywhere is %d\n", st->maxDepth);
+#endif
+    if (st.maxDepth + envPtr->currStackDepth > envPtr->maxStackDepth) {
+	envPtr->maxStackDepth = st.maxDepth + envPtr->currStackDepth;
+    }
+    return TCL_OK;
+}
+
+static int
+StackCheckBasicBlock(StackCheckerState *st, BasicBlock * blockPtr, BasicBlock * predecessor, int initialStackDepth) { 
+#if 0
+    CompileEnv* envPtr = st->envPtr;
+    fprintf(stderr, "stack check basic block %p at depth %d\n", 
+	    blockPtr, initialStackDepth);
+    fprintf(stderr, "  start %d may_fall_thru %d visited %d\n",
+	    blockPtr->start - envPtr->codeStart,
+	    blockPtr->may_fall_thru, blockPtr->visited);
+    fprintf(stderr, "  predecessor %p successor1 %p\n", 
+	    blockPtr->predecessor, blockPtr->successor1);
+    fprintf(stderr, "  stack: init %d min %d max %d final %d\n",
+	    blockPtr->initialStackDepth, blockPtr->minStackDepth,
+	    blockPtr->maxStackDepth, blockPtr->finalStackDepth);
+    fflush(stderr);
+#endif    
+    if (blockPtr->visited) {
+        if (blockPtr->initialStackDepth != initialStackDepth) {
+	    Tcl_SetObjResult(st->interp, Tcl_NewStringObj("inconsistent stack depths on two execution paths", -1));
+            /* Trace the offending BasicBlock */
+	    Tcl_AddErrorInfo(st->interp, "\n    to ");
+	    AddInstructionToErrorInfo(st->interp, st->bcList, 
+				      blockPtr->bcIndex);
+	    /* TODO - add execution trace of both paths */
+            return TCL_ERROR;
+        } else {
+            return TCL_OK;
+        }
+    } else {
+
+        blockPtr->visited = 1;
+        blockPtr->predecessor = predecessor;
+        blockPtr->initialStackDepth = initialStackDepth;
+        if (initialStackDepth + blockPtr->minStackDepth < 0) {
+	    Tcl_SetObjResult(st->interp,
+			     Tcl_NewStringObj("stack underflow", -1));
+	    AddBasicBlockRangeToErrorInfo(st->interp, st->bcList, blockPtr);
+            return TCL_ERROR;
+        }
+        if (initialStackDepth + blockPtr->maxStackDepth > st->maxDepth) {
+            st->maxDepth = initialStackDepth + blockPtr->maxStackDepth;
+        }
+    }
+    int stackDepth = initialStackDepth + blockPtr->finalStackDepth;
+    int result = TCL_OK;
+#if 0
+    fprintf(stderr, "on exit from block, depth will be %d\n", stackDepth);
+    fflush(stderr);
+#endif
+    if (blockPtr->may_fall_thru) {
+        result = StackCheckBasicBlock(st, blockPtr->successor1, blockPtr, stackDepth);        
+        
+    }
+    /* FIXME Have we checked for undefined labels yet ? */
+    if (result == TCL_OK && blockPtr->jumpTargetLabelHashEntry != NULL) {
+        BasicBlock * targetBlock = (BasicBlock *) Tcl_GetHashValue(blockPtr->jumpTargetLabelHashEntry);
+        result = StackCheckBasicBlock(st, targetBlock, blockPtr, stackDepth);
+    }
+    return result;
+    
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeAssembleCodeInternalRep --
+ *
+ *	Part of the Tcl object type implementation for Tcl expression
+ *	bytecode. Frees the storage allocated to hold the internal rep, unless
+ *	ref counts indicate bytecode execution is still in progress.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	May free allocated memory. Leaves objPtr untyped.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeAssembleCodeInternalRep(
+    Tcl_Obj *objPtr)
+{
+    ByteCode *codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
+
+    codePtr->refCount--;
+    if (codePtr->refCount <= 0) {
+	TclCleanupByteCode(codePtr);
+    }
+    objPtr->typePtr = NULL;
+    objPtr->internalRep.otherValuePtr = NULL;
+}
+
+static void
+AddBasicBlockRangeToErrorInfo(Tcl_Interp* interp,
+			      Tcl_Obj* bcList,
+			      BasicBlock* bbPtr)
+{
+    Tcl_AddErrorInfo(interp, "\n    between ");
+    AddInstructionToErrorInfo(interp, bcList, bbPtr->bcIndex);
+    Tcl_AddErrorInfo(interp, "\n    and ");
+    if (bbPtr->successor1 != NULL) {
+	AddInstructionToErrorInfo(interp, bcList,
+				  bbPtr->successor1->bcIndex);
+    } else {
+	Tcl_AddErrorInfo(interp, "end of assembly code");
+    }
+}
+
+static void
+AddInstructionToErrorInfo(Tcl_Interp* interp,
+			  Tcl_Obj* bcList,
+			  int bcIndex)
+{
+    Tcl_Obj* msgObj;
+    int msgLen;
+    const char* msgPtr;
+
+    Tcl_AddErrorInfo(interp, "source instruction at list index ");
+    msgObj = Tcl_NewIntObj(bcIndex);
+    Tcl_IncrRefCount(msgObj);
+    msgPtr = Tcl_GetStringFromObj(msgObj, &msgLen);
+    Tcl_AddObjErrorInfo(interp, msgPtr, msgLen);
+    Tcl_DecrRefCount(msgObj);
+    Tcl_AddErrorInfo(interp, " (\"");
+    Tcl_ListObjIndex(NULL, bcList, bcIndex, &msgObj);
+    msgPtr = Tcl_GetStringFromObj(msgObj, &msgLen);
+    Tcl_AddObjErrorInfo(interp, msgPtr, msgLen);
+    Tcl_AddErrorInfo(interp, "\")");
+}	    
+