Tcl Source Code

	* win/makefile.vc:

	* generic/tclExecute.c (ExprObjCallback): fix object leak

	* generic/tclExecute.c (TEBCresume): store local var array and
	constants in automatic vars to reduce indirection, slight perf
	increase 

	* generic/tclOOCall.c (TclOODeleteContext): added missing '*' so
	that trunk compiles.

	* generic/tclBasic.c (TclNRRunCallbacks): don't do the trampoline
	dance for commands that do not have an nreProc, [Patch 3168229]

2011-03-01  Donal K. Fellows  <[email protected]>

	* unix/Makefile.in:  [Bug 2537626]: Use 'rpmbuild', not 'rpm'.

2010-12-16  Jan Nijtmans  <[email protected]>

	* generic/tclPanic.c:  [Patch 3124554]: Move WishPanic from Tk to Tcl
	* win/tclWinFile.c:    Better communication with debugger, if present.

2010-12-15  Kevin B. Kenny  <[email protected]>

	[dogeen-assembler-branch]

	* tclAssembly.c:
	* assemble.test: 	Reworked beginCatch/endCatch handling to
	enforce the more severe (but more correct) restrictions on catch
	handling that appeared in the discussion of [Bug 3098302] and in
	tcl-core traffic beginning about 2010-10-29.

2010-12-15  Jan Nijtmans  <[email protected]>

	* generic/tclPanic.c:    Restore abort() as it was before.
	* win/tclWinFile.c:      [Patch 3124554]: Use ExitProcess() here, like
	in wish.

	* library/tzdata/Pacific/Fiji:   Olson's tzdata2010o.

2010-10-29  Alexandre Ferrieux  <[email protected]>

	* generic/tclTimer.c:	[Bug 2905784]: Stop small [after]s from
				wasting CPU while keeping accuracy.

2010-10-28  Kevin B. Kenny  <[email protected]>

	[dogeen-assembler-branch]
	* generic/tclAssembly.c:
	* tests/assembly.test (assemble-31.*): Added jump tables.

2010-10-28  Don Porter  <[email protected]>

	* tests/http.test:	[Bug 3097490]: Make http-4.15 pass in
				isolation.

	* unix/tclUnixSock.c:	[Bug 3093120]: Prevent calls of
				freeaddrinfo(NULL) which can crash some

2010-10-26  Reinhard Max  <[email protected]>

	* unix/tclUnixSock.c (TcpGetOptionProc): Added support for
	::tcl::unsupported::noReverseDNS, which if set to any value, prevents
	[fconfigure -sockname] and [fconfigure -peername] from doing
	reverse DNS queries.

2010-10-24  Kevin B. Kenny  <[email protected]>

	[dogeen-assembler-branch]
	* generic/tclAssembly.c:
	* tests/assembly.test (assemble-17.15): Reworked branch handling so that
	forward branches can use jump1 (jumpTrue1, jumpFalse1). Added test
	cases that the forward branches will expand to jump4, jumpTrue4,
	jumpFalse4 when needed.

2010-10-23  Kevin B. Kenny  <[email protected]>

	[dogeen-assembler-branch]
	* generic/tclAssembly.h (removed):
				Removed file that was included in only one
				source file.
	* generictclAssembly.c:	Inlined tclAssembly.h.

2010-10-17  Alexandre Ferrieux  <[email protected]>

	* doc/info.n:            [Patch 2995655]:
	* generic/tclBasic.c:    Report inner contexts in [info errorstack]
	* generic/tclCompCmds.c:
	* generic/tclCompile.c:
	* generic/tclCompile.h:

2010-10-06  Don Porter  <[email protected]>

	* tests/winPipe.test:	Test hygiene with makeFile and removeFile.

	* generic/tclCompile.c:	[Bug 3081065]: Prevent writing to the intrep
	* tests/subst.test:	fields of a freed Tcl_Obj.

2010-10-06  Kevin B. Kenny  <[email protected]>

	[dogeen-assembler-branch]

	* generic/tclAssembly.c:
	* generic/tclAssembly.h:
	* tests/assemble.test: Added catches. Still needs a lot of testing.

2010-10-02  Kevin B. Kenny  <[email protected]>

	[dogeen-assembler-branch]

	* generic/tclAssembly.c:
	* generic/tclAssembly.h:
	* tests/assemble.test: Added dictAppend, dictIncrImm, dictLappend,
	dictSet, dictUnset, nop, regexp, nsupvar, upvar, and variable.

2010-10-02  Donal K. Fellows  <[email protected]>

	* generic/tclExecute.c (TEBCresume): [Bug 3079830]: Added invalidation
	of string representations of dictionaries in some cases.

2010-10-01  Jeff Hobbs  <[email protected]>

	* generic/tclBasic.c, generic/tclClock.c, generic/tclEncoding.c,
	* generic/tclEnv.c, generic/tclLoad.c, generic/tclNamesp.c,
	* generic/tclObj.c, generic/tclRegexp.c, generic/tclResolve.c,
	* generic/tclResult.c, generic/tclUtil.c, macosx/tclMacOSXFCmd.c:
	More purging of strcpy() from locations where we already know the
	length of the data being copied.

2010-10-01  Kevin B. Kenny  <[email protected]>

	[dogeen-assembler-branch]

	* tests/assemble.test:
	* generic/tclAssemble.h:
	* generic/tclAssemble.c:  Added listIn, listNotIn, and dictGet.

2010-09-30  Kevin B. Kenny  <[email protected]>

	[dogeen-assembler-branch]

	* tests/assemble.test:   Added tryCvtToNumeric and several more list
	* generic/tclAssemble.c: operations.
	* generic/tclAssemble.h:

2010-09-29  Kevin B. Kenny  <[email protected]>

	[dogeen-assembler-branch]

	* tests/assemble.test:   Completed conversion of tests to a
	* generic/tclAssemble.c: "white box" structure that follows the
	C code. Added missing safety checks on the operands of 'over' and
	'reverse' so that negative operand counts don't smash the stack.

2010-09-29  Jan Nijtmans  <[email protected]>

	* unix/configure:	Re-generate with autoconf-2.59
	* win/configure:
	* generic/tclMain.c:	Make compilable with -DUNICODE as well

2010-09-28  Reinhard Max  <[email protected]>

	* win/configure.in:	Allow cross-compilation by default.

	* tests/socket.test:	Improve the test suite to make more use of
	* tests/remote.tcl:	randomized ports to reduce interference with
				tests running in parallel or other services on
				the machine.

2010-09-28  Kevin B. Kenny  <[email protected]>

	[dogeen-assembler-branch]

	* tests/assemble.test: Added more "white box" tests.
	* generic/tclAssembly.c: Added the error checking and reporting
	for undefined labels. Revised code so that no pointers into the
	bytecode sequence are held (because the sequence can move!),
	that no Tcl_HashEntry pointers are held (because the hash table
	doesn't guarantee their stability!) and to eliminate the BBHash
	table, which is merely additional information indexed by jump
	labels and can just as easily be held in the 'label' structure.
	Renamed shared structures to CamelCase, and renamed 'label' to
	JumpLabel because other types of labels may eventually be possible.

2010-09-27  Kevin B. Kenny  <[email protected]>

	[dogeen-assembler-branch]

	* tests/assemble.test: Added more "white box" tests.
	* generic/tclAssembly.c: Fixed bugs exposed by the new tests.
	(a) [eval] and [expr] had incorrect stack balance computed if
	the arg was not a simple word. (b) [concat] accepted a negative
	operand count. (c) [invoke] accepted a zero or negative operand
	count. (d) more misspelt error messages.
	Also replaced a funky NRCallTEBC with the new call
	TclNRExecuteByteCode, necessitated by a merge with changes on the
	HEAD.

2010-09-26  Miguel Sofer  <[email protected]>

	* generic/tclBasic.c:    [Patch 3072080] (minus the itcl
	* generic/tclCmdIL.c:    update): a saner NRE.
	* generic/tclCompExpr.c:
	* generic/tclCompile.c:  This makes TclNRExecuteByteCode (ex TEBC)

2010-09-26  Miguel Sofer  <[email protected]>

	* generic/tclOOMethod.c (ProcedureMethodVarResolver): avoid code
	duplication, let the runtime var resolver call the compiled var
	resolver.

2010-09-26  Kevin B. Kenny  <[email protected]>

	[dogeen-assembler-branch]

	* tests/assemble.test:	Added many new tests moving toward a more
	comprehensive test suite for the assembler.
	* generic/tclAssembly.c:	Fixed bugs exposed by the new tests:
	(a) [bitnot] and [not] had incorrect operand counts. (b)
	INST_CONCAT cannot concatenate zero objects. (c) misspelt error
	messages. (d) the "assembly code" internal representation lacked
	a duplicator, which caused double-frees of the Bytecode object
	if assembly code ever was duplicated.

2010-09-25  Kevin B. Kenny   <[email protected]>

	[dogeen-assembler-branch]

	* generic/tclAssembly.c:	Massive refactoring of the assembler
	* generic/tclAssembly.h:	to use a Tcl-like syntax (and use
	* tests/assemble.test:		Tcl_ParseCommand to parse it). The
	* tests/assemble1.bench:	refactoring also ensures that
	Tcl_Tokens in the assembler have string ranges inside the source
	code, which allows for [eval] and [expr] assembler directives
	that simply call TclCompileScript and TclCompileExpr recursively.

2010-09-24  Jeff Hobbs  <[email protected]>

	* tests/stringComp.test: improved string eq/cmp test coverage
	* generic/tclExecute.c (TclExecuteByteCode): merge INST_STR_CMP and
	INST_STR_EQ/INST_STR_NEQ paths.  Speeds up eq/ne/[string eq] with
	obj-aware comparisons and eq/==/ne/!= with length equality check.

	* generic/tclExecute.c (TclExecuteByteCode):
	* generic/tclOOMethod.c (ProcedureMethodCompiledVarConnect):
	* generic/tclVar.c (TclLookupSimpleVar, CompareVarKeys):
	* generic/tclPathObj.c (Tcl_FSGetNormalizedPath, Tcl_FSEqualPaths):
	* generic/tclIOUtil.c (TclFSCwdPointerEquals): peephole opt
	* generic/tclResult.c (TclMergeReturnOptions): Use memcmp where
	applicable as possible speedup on some libc variants.

2010-09-21  Kevin B. Kenny  <[email protected]>

	[BRANCH: dogeen-assembler-branch]

	* generic/tclAssembly.c (new file): 
	* generic/tclAssembly.h:
	* generic/tclBasic.c (builtInCmds, Tcl_CreateInterp):
	* generic/tclInt.h:
	* tests/assemble.test (new file):
	* tests/assemble1.bench (new file):
	* unix/Makefile.in:
	* win/Makefile.in:
	* win/Makefile.vc:
		Initial commit of Ozgur Dogan Ugurlu's (SF user: dogeen)
		assembler for the Tcl bytecode language.

2010-09-21  Jan Nijtmans  <[email protected]>

	* win/tclWinFile.c:   Fix declaration after statement.
	* win/tcl.m4:         Add -Wdeclaration-after-statement, so this
	* win/configure:      mistake cannot happen again.
	* win/tclWinFCmd.c:   [Bug 3069278]: Breakage on head Windows

/*
 * tclAssembly,c --
 *
 *	Assembler for Tcl bytecodes.
 *
 * This file contains the procedures that convert Tcl Assembly Language
 * (TAL) to a sequence of bytecode instructions for the Tcl execution engine.
 *
 * Copyright (c) 2010 by Ozgur Dogan Ugurlu.
 * Copyright (c) 2010 by Kevin B. Kenny.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclAssembly.c,v 1.1.2.18 2010/12/16 01:40:42 kennykb Exp $
 */

/*-
 *- THINGS TO DO:
 *- More instructions:
 *-   done - alternate exit point (affects stack and exception range checking)
 *-   break and continue - if exception ranges can be sorted out.
 *-   foreach_start4, foreach_step4
 *-   returnImm, returnStk
 *-   expandStart, expandStkTop, invokeExpanded
 *-   dictFirst, dictNext, dictDone
 *-   dictUpdateStart, dictUpdateEnd
 *-   jumpTable testing
 *-   syntax (?)
 *-   returnCodeBranch
 */

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

/* Structure that represents a range of instructions in the bytecode */

typedef struct CodeRange {
    int startOffset;		/* Start offset in the bytecode array */
    int endOffset;		/* End offset in the bytecode array */
} CodeRange;

/* State identified for a basic block's catch context */

typedef enum BasicBlockCatchState {
    BBCS_UNKNOWN = 0,		/* Catch context has not yet been identified */
    BBCS_NONE,			/* Block is outside of any catch */
    BBCS_INCATCH,		/* Block is within a catch context */
    BBCS_CAUGHT,		/* Block is within a catch context and
				 * may be executed after an exception fires */
} BasicBlockCatchState;

/* 
 * Structure that defines a basic block - a linear sequence of bytecode
 * instructions with no jumps in or out (including not changing the
 * state of any exception range).
 */

typedef struct BasicBlock {

    int originalStartOffset;	/* Instruction offset before JUMP1s
				 * were substituted with JUMP4's */
    int startOffset;		/* Instruction offset of the start of 
				 * the block */
    int startLine;		/* Line number in the input script of the
				 * instruction at the  start of the block */
    int jumpOffset;	        /* Bytecode offset of the 'jump' instruction
				 * that ends the block, or -1 if there is no
				 * jump. */
    int jumpLine;	        /* Line number in the input script of the
				 * 'jump' instruction that ends the block,
				 * or -1 if there is no jump */
    struct BasicBlock* prevPtr;	/* Immediate predecessor of this block */
    struct BasicBlock* predecessor;	
				/* Predecessor of this block in the
				 * spanning tree */
    struct BasicBlock * successor1;
				/* BasicBlock structure of the following 
				 * block:  NULL at the end of the bytecode 
				 * sequence. */
    Tcl_Obj * jumpTarget;	/* Jump target label if the jump target 
				 * is unresolved */
    
    int initialStackDepth;	/* Absolute stack depth on entry */
    int minStackDepth;		/* Low-water relative stack depth */
    int maxStackDepth; 		/* High-water relative stack depth */
    int finalStackDepth;	/* Relative stack depth on exit */

    enum BasicBlockCatchState catchState;
				/* State of the block for 'catch' analysis */
    int catchDepth;		/* Number of nested catches in which the
				 * basic block appears */
    struct BasicBlock* enclosingCatch;
				/* BasicBlock structure of the last
				 * startCatch executed on a path to this 
				 * block, or NULL if there is no
				 * enclosing catch */

    int foreignExceptionBase;	/* Base index of foreign exceptions */
    int foreignExceptionCount;	/* Count of foreign exceptions */
    ExceptionRange* foreignExceptions;
				/* ExceptionRange structures for
				 * exception ranges belonging to embedded
				 * scripts and expressions in this block */

    JumptableInfo* jtPtr;	/* Jump table at the end of this basic block */

    int flags;			/* Boolean flags */

} BasicBlock;

/* Flags that pertain to a basic block */

enum BasicBlockFlags {
    BB_VISITED = (1 << 0),	/* Block has been visited in the current
				 * traversal */
    BB_FALLTHRU = (1 << 1),	/* Control may pass from this block to
				 * a successor */
    BB_JUMP1 = (1 << 2),	/* Basic block ends with a 1-byte-offset
				 * jump and may need expansion */
    BB_JUMPTABLE = (1 << 3),	/* Basic block ends with a jump table */
    BB_BEGINCATCH = (1 << 4),	/* Block ends with a 'beginCatch' instruction,
				 * marking it as the start of a 'catch' 
				 * sequence. The 'jumpTarget' is the exception
				 * exit from the catch block. */
    BB_ENDCATCH = (1 << 5),	/* Block ends with an 'endCatch' instruction,
				 * unwinding the catch from the exception 
				 * stack. */
};

/* Source instruction type recognized by the assembler */

typedef enum TalInstType {

    ASSEM_1BYTE,    /* Fixed arity, 1-byte instruction */
    ASSEM_BEGIN_CATCH,
		    /* Begin catch: one 4-byte jump offset to be converted
		     * to appropriate exception ranges */
    ASSEM_BOOL,	    /* One Boolean operand */
    ASSEM_BOOL_LVT4,/* One Boolean, one 4-byte LVT ref. */
    ASSEM_CONCAT1,  /* 1-byte unsigned-integer operand count, must be 
		     * strictly positive, consumes N, produces 1 */
    ASSEM_DICT_GET, /* 'dict get' and related - consumes N+1 operands,
		     * produces 1, N > 0 */
    ASSEM_DICT_SET, /* specifies key count and LVT index, consumes N+1 operands,
		     * produces 1, N > 0 */
    ASSEM_DICT_UNSET,
		    /* specifies key count and LVT index, consumes N operands,
		     * produces 1, N > 0 */
    ASSEM_END_CATCH,/* End catch. No args. Exception range popped from stack
		     * and stack pointer restored. */
    ASSEM_EVAL,	    /* 'eval' - evaluate a constant script (by compiling it
		     * in line with the assembly code! I love Tcl!) */
    ASSEM_INDEX,    /* 4 byte operand, integer or end-integer */
    ASSEM_INVOKE,   /* 1- or 4-byte operand count, must be strictly positive,
		     * consumes N, produces 1. */
    ASSEM_JUMP,	    /* Jump instructions */
    ASSEM_JUMP4,    /* Jump instructions forcing a 4-byte offset */
    ASSEM_JUMPTABLE,/* Jumptable (switch -exact) */
    ASSEM_LABEL,    /* The assembly directive that defines a label */
    ASSEM_LINDEX_MULTI,
		    /* 4-byte operand count, must be strictly positive,
		     * consumes N, produces 1 */
    ASSEM_LIST,     /* 4-byte operand count, must be nonnegative, consumses N,
		     * produces 1 */
    ASSEM_LSET_FLAT,/* 4-byte operand count, must be >= 3, consumes N,
		     * produces 1 */
    ASSEM_LVT,      /* One operand that references a local variable */
    ASSEM_LVT1,     /* One 1-byte operand that references a local variable */
    ASSEM_LVT1_SINT1,
		    /* One 1-byte operand that references a local variable,
		     * one signed-integer 1-byte operand */
    ASSEM_LVT4,     /* One 4-byte operand that references a local variable */
    ASSEM_OVER,	    /* OVER: 4-byte operand count, consumes N+1, produces N+2 */
    ASSEM_PUSH,     /* one literal operand */
    ASSEM_REGEXP,   /* One Boolean operand, but weird mapping to call flags */
    ASSEM_REVERSE,  /* REVERSE: 4-byte operand count, consumes N, produces N */
    ASSEM_SINT1,    /* One 1-byte signed-integer operand (INCR_STK_IMM) */
    ASSEM_SINT4_LVT4,
                    /* Signed 4-byte integer operand followed by LVT entry. 
		     * Fixed arity */
} TalInstType;

/* Description of an instruction recognized by the assembler. */

typedef struct TalInstDesc {
    const char *name;		/* Name of instruction. */
    TalInstType instType; 	/* The type of instruction */
    int tclInstCode;		/* Instruction code. For instructions having
				 * 1- and 4-byte variables, tclInstCode is
				 * ((1byte)<<8) || (4byte) */
    int operandsConsumed;	/* Number of operands consumed by the
				 * operation, or INT_MIN if the operation
				 * is variadic */
    int operandsProduced;	/* Number of operands produced by the
				 * operation. If negative, the operation
				 * has a net stack effect of 
				 * -1-operandsProduced */
} TalInstDesc;

/* Structure that holds the state of the assembler while generating code */

typedef struct AssemblyEnv {
    CompileEnv* envPtr;		/* Compilation environment being used
				 * for code generation */
    Tcl_Parse* parsePtr;        /* Parse of the current line of source */
    Tcl_HashTable labelHash;	/* Hash table whose keys are labels and
				 * whose values are 'label' objects storing 
				 * the code offsets of the labels. */

    int cmdLine;		/* Current line number within the assembly 
				 * code */
    int* clNext;		/* Invisible continuation line for
				 * [info frame] */

    BasicBlock* head_bb;	/* First basic block in the code */
    BasicBlock* curr_bb;	/* Current basic block */

    int maxDepth;	     	/* Maximum stack depth encountered */

    int curCatchDepth;		/* Current depth of catches */
    int maxCatchDepth;		/* Maximum depth of catches encountered */

    int flags;			/* Compilation flags (TCL_EVAL_DIRECT) */
} AssemblyEnv;

/* Static functions defined in this file */

static void AddBasicBlockRangeToErrorInfo(AssemblyEnv*, BasicBlock*);
static BasicBlock * AllocBB(AssemblyEnv*); 
static int AssembleOneLine(AssemblyEnv* envPtr);
static void BBAdjustStackDepth(BasicBlock* bbPtr, int consumed, int produced);
static void BBUpdateStackReqs(BasicBlock* bbPtr, int tblind, int count);
static void BBEmitInstInt1(AssemblyEnv* assemEnvPtr, int tblind,
			   unsigned char opnd, int count);
static void BBEmitInstInt4(AssemblyEnv* assemEnvPtr, int tblind, int opnd,
			   int count);
static void BBEmitInst1or4(AssemblyEnv* assemEnvPtr, int tblind, int param,
			   int count);
static void BBEmitOpcode(AssemblyEnv* assemEnvPtr, int tblind, int count);
static int BuildExceptionRanges(AssemblyEnv* assemEnvPtr);
static int CalculateJumpRelocations(AssemblyEnv*, int*);
static int CheckForUnclosedCatches(AssemblyEnv*);
static int CheckForThrowInWrongContext(AssemblyEnv*);
static int CheckNonThrowingBlock(AssemblyEnv*, BasicBlock*);
static int BytecodeMightThrow(unsigned char);
static int CheckJumpTableLabels(AssemblyEnv*, BasicBlock*);
static int CheckNamespaceQualifiers(Tcl_Interp*, const char*, int);
static int CheckNonNegative(Tcl_Interp*, int);
static int CheckOneByte(Tcl_Interp*, int);
static int CheckSignedOneByte(Tcl_Interp*, int);
static int CheckStack(AssemblyEnv*);
static int CheckStrictlyPositive(Tcl_Interp*, int);
static ByteCode * CompileAssembleObj(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void CompileEmbeddedScript(AssemblyEnv*, Tcl_Token*, TalInstDesc*);
static int DefineLabel(AssemblyEnv* envPtr, const char* label);
static void DeleteMirrorJumpTable(JumptableInfo* jtPtr);
static void DupAssembleCodeInternalRep(Tcl_Obj* src, Tcl_Obj* dest);
static void FillInJumpOffsets(AssemblyEnv*);
static int CreateMirrorJumpTable(AssemblyEnv* assemEnvPtr, Tcl_Obj* jumpTable);
static int FindLocalVar(AssemblyEnv* envPtr, Tcl_Token** tokenPtrPtr);
static int FinishAssembly(AssemblyEnv*);
static void FreeAssembleCodeInternalRep(Tcl_Obj *objPtr);
static void FreeAssemblyEnv(AssemblyEnv*);
static int GetBooleanOperand(AssemblyEnv*, Tcl_Token**, int*);
static int GetListIndexOperand(AssemblyEnv*, Tcl_Token**, int*);
static int GetIntegerOperand(AssemblyEnv*, Tcl_Token**, int*);
static int GetNextOperand(AssemblyEnv*, Tcl_Token**, Tcl_Obj**);
static void LookForFreshCatches(BasicBlock*, BasicBlock**);
static void MoveCodeForJumps(AssemblyEnv*, int);
static void MoveExceptionRangesToBasicBlock(AssemblyEnv*, int, int);
static AssemblyEnv* NewAssemblyEnv(CompileEnv*, int);
static int ProcessCatches(AssemblyEnv*);
static int ProcessCatchesInBasicBlock(AssemblyEnv*, BasicBlock*, BasicBlock*,
				      enum BasicBlockCatchState, int);
static void ResetVisitedBasicBlocks(AssemblyEnv*);
static void ResolveJumpTableTargets(AssemblyEnv*, BasicBlock*);
static void ReportUndefinedLabel(AssemblyEnv*, BasicBlock*, Tcl_Obj*);
static void RestoreEmbeddedExceptionRanges(AssemblyEnv*);
static int StackCheckBasicBlock(AssemblyEnv*, BasicBlock *, BasicBlock *, int);
static BasicBlock* StartBasicBlock(AssemblyEnv*, int fallthrough,
				   Tcl_Obj* jumpLabel);
/* static int AdvanceIp(const unsigned char *pc); */
static int StackCheckBasicBlock(AssemblyEnv*, BasicBlock *, BasicBlock *, int);
static int StackCheckExit(AssemblyEnv*);
static void StackFreshCatches(AssemblyEnv*, BasicBlock*, int, BasicBlock**,
			      int*);
static void SyncStackDepth(AssemblyEnv*);
static int TclAssembleCode(CompileEnv* envPtr, const char* code, int codeLen,
			   int flags);
static void UnstackExpiredCatches(CompileEnv*, BasicBlock*, int, 
				  BasicBlock**, int*);

/* Tcl_ObjType that describes bytecode emitted by the assembler */

static const Tcl_ObjType assembleCodeType = {
    "assemblecode",
    FreeAssembleCodeInternalRep, /* freeIntRepProc */
    DupAssembleCodeInternalRep,	 /* dupIntRepProc */
    NULL,			 /* updateStringProc */
    NULL			 /* setFromAnyProc */
};

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

/*
 * Source instructions recognized in the Tcl Assembly Language (TAL)
 */

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}, 
    {"beginCatch",	ASSEM_BEGIN_CATCH,
     					INST_BEGIN_CATCH4,	0,	0},
    {"bitand",  	ASSEM_1BYTE ,   INST_BITAND ,   	2   ,   1},
    {"bitnot",		ASSEM_1BYTE,    INST_BITNOT,    	1,      1},
    {"bitor",   	ASSEM_1BYTE ,   INST_BITOR  ,   	2   ,   1},
    {"bitxor",  	ASSEM_1BYTE ,   INST_BITXOR ,   	2   ,   1},
    {"concat",		ASSEM_CONCAT1,	INST_CONCAT1,		INT_MIN,1},
    {"dictAppend",	ASSEM_LVT4,	INST_DICT_APPEND,	2,      1},
    {"dictGet", 	ASSEM_DICT_GET, INST_DICT_GET,  	INT_MIN,1},
    {"dictIncrImm",    	ASSEM_SINT4_LVT4,
     					INST_DICT_INCR_IMM,	1,	1},
    {"dictLappend",	ASSEM_LVT4,	INST_DICT_LAPPEND,	2,      1},
    {"dictSet", 	ASSEM_DICT_SET, INST_DICT_SET,		INT_MIN,1},
    {"dictUnset",	ASSEM_DICT_UNSET,
     					INST_DICT_UNSET,	INT_MIN,1},
    {"div",     	ASSEM_1BYTE,    INST_DIV,       	2,      1},
    {"dup",     	ASSEM_1BYTE ,   INST_DUP    ,   	1   ,   2}, 
    {"endCatch",	ASSEM_END_CATCH,INST_END_CATCH, 	0,	0},
    {"eq",      	ASSEM_1BYTE ,   INST_EQ     ,   	2   ,   1},
    {"eval",		ASSEM_EVAL,	INST_EVAL_STK,		1,	1},
    {"evalStk",		ASSEM_1BYTE,	INST_EVAL_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},
    {"expon",   	ASSEM_1BYTE,    INST_EXPON,     	2,      1},
    {"expr",		ASSEM_EVAL,	INST_EXPR_STK,		1,	1},
    {"exprStk", 	ASSEM_1BYTE,	INST_EXPR_STK,		1,	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,	 	0,      0},
    {"jump4",    	ASSEM_JUMP4,    INST_JUMP4,	 	0,      0},
    {"jumpFalse",       ASSEM_JUMP,     INST_JUMP_FALSE1,	1,      0},
    {"jumpFalse4",      ASSEM_JUMP4,    INST_JUMP_FALSE4,	1,      0},
    {"jumpTable",	ASSEM_JUMPTABLE,INST_JUMP_TABLE,	1,	0},
    {"jumpTrue",	ASSEM_JUMP,     INST_JUMP_TRUE1, 	1,      0},
    {"jumpTrue4",	ASSEM_JUMP4,    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},
    {"lindexMulti",	ASSEM_LINDEX_MULTI,
     					INST_LIST_INDEX_MULTI,	INT_MIN,1},
    {"list",		ASSEM_LIST,	INST_LIST,		INT_MIN,1},
    {"listIn",		ASSEM_1BYTE,	INST_LIST_IN,		2,	1},
    {"listIndex", 	ASSEM_1BYTE,    INST_LIST_INDEX,	2,      1},
    {"listIndexImm",	ASSEM_INDEX,	INST_LIST_INDEX_IMM,	1,	1},
    {"listLength",	ASSEM_1BYTE,    INST_LIST_LENGTH,	1,      1},
    {"listNotIn",	ASSEM_1BYTE,	INST_LIST_NOT_IN,	2,	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},
    {"lsetFlat",	ASSEM_LSET_FLAT,INST_LSET_FLAT,		INT_MIN,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},
    {"nop",		ASSEM_1BYTE,	INST_NOP,		0,	0},
    {"not",     	ASSEM_1BYTE,    INST_LNOT,      	1,      1},
    {"nsupvar",		ASSEM_LVT4,	INST_NSUPVAR,		2,	1},
    {"over",    	ASSEM_OVER,     INST_OVER,      	INT_MIN,-1-1},
    {"pop",     	ASSEM_1BYTE ,   INST_POP    ,   	1   ,   0},
    {"pushReturnCode",	ASSEM_1BYTE,	INST_PUSH_RETURN_CODE,	0,	1},
    {"pushReturnOpts",	ASSEM_1BYTE,	INST_PUSH_RETURN_OPTIONS,
     								0,	1},
    {"pushResult",	ASSEM_1BYTE,	INST_PUSH_RESULT,	0,	1},
    {"regexp",		ASSEM_REGEXP,	INST_REGEXP,		2,	1},
    {"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},
    {"tryCvtToNumeric",	ASSEM_1BYTE,    INST_TRY_CVT_TO_NUMERIC,1,      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},
    {"upvar",		ASSEM_LVT4,	INST_UPVAR,		2,	1},
    {"variable",	ASSEM_LVT4,	INST_VARIABLE,		1,	0},
    {NULL, 		0,		0,			0,	0}
};

/*
 * List of instructions that cannot throw an exception under any circumstances.
 * These instructions are the ones that are permissible after an exception
 * is caught but before the corresponding exception range is popped from
 * the stack.
 * The instructions must be in ascending order by numeric operation code.
 */

static unsigned char NonThrowingByteCodes[] = {
    INST_PUSH1, INST_PUSH4, INST_POP, INST_DUP,			/* 1-4 */
    INST_JUMP1, INST_JUMP4,					/* 34-35 */
    INST_END_CATCH, INST_PUSH_RESULT, INST_PUSH_RETURN_CODE,	/* 70-72 */
    INST_OVER,							/* 95 */
    INST_PUSH_RETURN_OPTIONS,					/* 108 */
    INST_REVERSE,						/* 126 */
    INST_NOP							/* 132 */
};

/*
 *-----------------------------------------------------------------------------
 *
 * 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;
}

/*
 *-----------------------------------------------------------------------------
 *
 * 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 variadic operands 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(AssemblyEnv* assemEnvPtr,
				/* Assembly environment */
	     int tblind,	/* Table index in TalInstructionTable of op */
	     int count)		/* Operand count for variadic ops */
{
    CompileEnv* envPtr = assemEnvPtr->envPtr;
				/* Compilation environment */
    BasicBlock* bbPtr = assemEnvPtr->curr_bb;
				/* Current basic block */
    int op = TalInstructionTable[tblind].tclInstCode & 0xff;

    /* If this is the first instruction in a basic block, record its
     * line number. */

    if (bbPtr->startOffset == envPtr->codeNext - envPtr->codeStart) {
	bbPtr->startLine = assemEnvPtr->cmdLine;
    }

    TclEmitInt1(op, envPtr);
    envPtr->atCmdStart = ((op) == INST_START_CMD);
    BBUpdateStackReqs(bbPtr, tblind, count);
}
static void
BBEmitInstInt1(AssemblyEnv* assemEnvPtr,
				/* Assembly environment */
	       int tblind,	/* Index in TalInstructionTable of op */
	       unsigned char opnd,
				/* 1-byte operand */
	       int count)	/* Operand count for variadic ops */
{
    BBEmitOpcode(assemEnvPtr, tblind, count);
    TclEmitInt1(opnd, assemEnvPtr->envPtr);
}
static void
BBEmitInstInt4(AssemblyEnv* assemEnvPtr,
				/* Assembly environment */
	       int tblind,	/* Index in TalInstructionTable of op */
	       int opnd,	/* 4-byte operand */
	       int count)	/* Operand count for variadic ops */
{
    BBEmitOpcode(assemEnvPtr, tblind, count);
    TclEmitInt4(opnd, assemEnvPtr->envPtr);
}

/*
 *-----------------------------------------------------------------------------
 *
 * BBEmitInst1or4 --
 *
 *	Emits a 1- or 4-byte operation according to the magnitude of the
 *	operand
 *
 *-----------------------------------------------------------------------------
 */

static void
BBEmitInst1or4(AssemblyEnv* assemEnvPtr,
				/* Assembly environment */
	       int tblind,	/* Index in TalInstructionTable of op */
	       int param,	/* Variable-length parameter */
	       int count)	/* Arity if variadic */
{
    CompileEnv* envPtr = assemEnvPtr->envPtr;
				/* Compilation environment */
    BasicBlock* bbPtr = assemEnvPtr->curr_bb;
				/* Current basic block */

    int op = TalInstructionTable[tblind].tclInstCode;
    if (param <= 0xff) {
	op >>= 8;
    } else {
	op &= 0xff;
    }
    TclEmitInt1(op, envPtr);
    if (param <= 0xff) {
	TclEmitInt1(param, envPtr);
    } else {
	TclEmitInt4(param, envPtr);
    }
    envPtr->atCmdStart = ((op) == INST_START_CMD);
    BBUpdateStackReqs(bbPtr, tblind, count);
}

/*
 *-----------------------------------------------------------------------------
 *
 * Tcl_AssembleObjCmd, TclNRAssembleObjCmd --
 *
 *	Direct evaluation path for tcl::unsupported::assemble
 *
 * Results:
 *	Returns a standard Tcl result.
 *
 * Side effects:
 *	Assembles the code in objv[1], and executes it, so side effects
 *	include whatever the code does.
 *
 *-----------------------------------------------------------------------------
 */

int
Tcl_AssembleObjCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    /* 
     * Boilerplate - make sure that there is an NRE trampoline on the
     * C stack because there needs to be one in place to execute bytecode.
     */
        
    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. */
{
    ByteCode *codePtr;		/* Pointer to the bytecode to execute */
    Tcl_Obj* backtrace;		/* Object where extra error information
				 * is constructed. */

    /* Check args */

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "bytecodeList");
	return TCL_ERROR;
    }

    /* Assemble the source to bytecode */

    codePtr = CompileAssembleObj(interp, objv[1]);

    /* On failure, report error line */

    if (codePtr == NULL) {
	Tcl_AddErrorInfo(interp, "\n    (\"");
	Tcl_AddErrorInfo(interp, Tcl_GetString(objv[0]));
	Tcl_AddErrorInfo(interp, "\" body, line ");
	backtrace = Tcl_NewIntObj(Tcl_GetErrorLine(interp));
	Tcl_IncrRefCount(backtrace);
	Tcl_AddErrorInfo(interp, Tcl_GetString(backtrace));
	Tcl_DecrRefCount(backtrace);
	Tcl_AddErrorInfo(interp, ")");
	return TCL_ERROR;
    }

    /* Use NRE to evaluate the bytecode from the trampoline */

    /*
    Tcl_NRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_BC_TYPE), codePtr,
	    NULL, NULL);
    return TCL_OK;
    */
    return TclNRExecuteByteCode(interp, codePtr);

}

/*
 *-----------------------------------------------------------------------------
 *
 * CompileAssembleObj --
 *
 *	Sets up and assembles Tcl bytecode for the direct-execution path
 *	in the Tcl bytecode assembler.
 *
 * Results:
 *	Returns a pointer to the assembled code. Returns NULL if the
 *	assembly fails for any reason, with an appropriate error message
 *	in the interpreter.
 *
 *-----------------------------------------------------------------------------
 */
 
static ByteCode *
CompileAssembleObj(
    Tcl_Interp *interp,		/* Tcl interpreter */
    Tcl_Obj *objPtr)		/* Source code to assemble */
{
    Interp *iPtr = (Interp *) interp;
				/* Internals of the interpreter */
    CompileEnv compEnv;		/* Compilation environment structure */
    register ByteCode *codePtr = NULL;
				/* Bytecode resulting from the assembly */
    Namespace* namespacePtr;	/* Namespace in which variable and
				 * command names in the bytecode resolve */
    int status;			/* Status return from Tcl_AssembleCode */
    const char* source;		/* String representation of the
				 * source code */
    int sourceLen;			/* Length of the source code in bytes */

    /*
     * Get the expression ByteCode from the object. If it exists, make sure it
     * is valid in the current context.
     */
     
    if (objPtr->typePtr == &assembleCodeType) {
	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) {

	/* Set up the compilation environment, and assemble the code */

	source = TclGetStringFromObj(objPtr, &sourceLen);
	TclInitCompileEnv(interp, &compEnv, source, sourceLen, NULL, 0);
	status = TclAssembleCode(&compEnv, source, sourceLen, TCL_EVAL_DIRECT);
	if (status != TCL_OK) {

	    /* Assembly failed. Clean up and report the error */

	    TclFreeCompileEnv(&compEnv);
	    return NULL;
	}

	/*
	 * 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);

	/*
	 * Record the local variable context to which the bytecode pertains
	 */

	codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
	if (iPtr->varFramePtr->localCachePtr) {
	    codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
	    codePtr->localCachePtr->refCount++;
	}

	/* Report on what the assembler did. */

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

    status = TclAssembleCode(envPtr, tokenPtr[1].start, tokenPtr[1].size, 0);
    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.
 *
 *-----------------------------------------------------------------------------
 */

static int
TclAssembleCode(CompileEnv *envPtr, 	
				/* Compilation environment that is to
				 * receive the generated bytecode */
		const char* codePtr,
				/* Assembly-language code to be processed */
		int codeLen,	/* Length of the code */
		int flags)	/* OR'ed combination of flags */
{
    Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
				/* Tcl interpreter */
    /* 
     * Walk through the assembly script using the Tcl parser.
     * Each 'command' will be an instruction or assembly directive.
     */

    const char* instPtr = codePtr;
				/* Where to start looking for a line of code */
    int instLen;		/* Length in bytes of the current line of 
				 * code */
    const char* nextPtr;	/* Pointer to the end of the line of code */
    int bytesLeft = codeLen;	/* Number of bytes of source code remaining 
				 * to be parsed */
    int status;			/* Tcl status return */

    AssemblyEnv* assemEnvPtr = NewAssemblyEnv(envPtr, flags);
    Tcl_Parse* parsePtr = assemEnvPtr->parsePtr;

    do {

	/* Parse out one command line from the assembly script */

	status = Tcl_ParseCommand(interp, instPtr, bytesLeft, 0, parsePtr);
	instLen = parsePtr->commandSize;
	if (parsePtr->term == parsePtr->commandStart + instLen - 1) {
	    --instLen;
	}

	/* Report errors in the parse */

	if (status != TCL_OK) {
	    if (flags & TCL_EVAL_DIRECT) {
		Tcl_LogCommandInfo(interp, codePtr, parsePtr->commandStart, 
				   instLen);
	    }
	    FreeAssemblyEnv(assemEnvPtr);
	    return TCL_ERROR;
	}

	/* Advance the pointers around any leading commentary */

	TclAdvanceLines(&assemEnvPtr->cmdLine, instPtr, parsePtr->commandStart);
	TclAdvanceContinuations(&assemEnvPtr->cmdLine, &assemEnvPtr->clNext, 
				parsePtr->commandStart - envPtr->source);

	/* Process the line of code  */

	if (parsePtr->numWords > 0) {

	    /* If tracing, show each line assembled as it happens */

#ifdef TCL_COMPILE_DEBUG
	    if ((tclTraceCompile >= 2) && (envPtr->procPtr == NULL)) {
		printf("  %4d Assembling: ",
		       envPtr->codeNext - envPtr->codeStart);
		TclPrintSource(stdout, parsePtr->commandStart,
			       TclMin(instLen, 55));
		printf("\n");
	    }
#endif
	    if (AssembleOneLine(assemEnvPtr) != TCL_OK) {
		if (flags & TCL_EVAL_DIRECT) {
		    Tcl_LogCommandInfo(interp, codePtr, parsePtr->commandStart, 
				       instLen);
		}
		Tcl_FreeParse(parsePtr);
		FreeAssemblyEnv(assemEnvPtr);
		return TCL_ERROR;
	    }
	}

	/* Advance to the next line of code */

	nextPtr = parsePtr->commandStart + parsePtr->commandSize;
	bytesLeft -= (nextPtr - instPtr);
	instPtr = nextPtr;
	TclAdvanceLines(&assemEnvPtr->cmdLine, parsePtr->commandStart, instPtr);
	TclAdvanceContinuations(&assemEnvPtr->cmdLine, &assemEnvPtr->clNext,
				instPtr - envPtr->source);
	Tcl_FreeParse(parsePtr);
    } while (bytesLeft > 0);

    /* Done with parsing the code */

    status = FinishAssembly(assemEnvPtr);
    FreeAssemblyEnv(assemEnvPtr);
    return status;
}

/*
 *-----------------------------------------------------------------------------
 *
 * NewAssemblyEnv --
 *
 *	Creates an environment for the assembler to run in.
 *
 * Results:
 *	Allocates, initialises and returns an assembler environment
 *
 *-----------------------------------------------------------------------------
 */

static AssemblyEnv*
NewAssemblyEnv(CompileEnv* envPtr,
				/* Compilation environment being used
				 * for code generation*/
	       int flags)	/* Compilation flags (TCL_EVAL_DIRECT) */
{
    Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
				/* Tcl interpreter */
    AssemblyEnv* assemEnvPtr = TclStackAlloc(interp, sizeof(AssemblyEnv));
				/* Assembler environment under construction */
    Tcl_Parse* parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse));
				/* Parse of one line of assembly code */

    assemEnvPtr->envPtr = envPtr;
    assemEnvPtr->parsePtr = parsePtr;
    assemEnvPtr->cmdLine = envPtr->line;
    assemEnvPtr->clNext = envPtr->clNext;

    /* Make the hashtables that store symbol resolution */

    Tcl_InitHashTable(&assemEnvPtr->labelHash, TCL_STRING_KEYS);

    /* Start the first basic block */

    assemEnvPtr->curr_bb = NULL;
    assemEnvPtr->head_bb = AllocBB(assemEnvPtr);
    assemEnvPtr->curr_bb = assemEnvPtr->head_bb;
    assemEnvPtr->head_bb->startLine = 1;

    /* Stash compilation flags */

    assemEnvPtr->flags = flags;

    return assemEnvPtr;
}

/*
 *-----------------------------------------------------------------------------
 *
 * FreeAssemblyEnv --
 *
 *	Cleans up the assembler environment when assembly is complete.
 *
 *-----------------------------------------------------------------------------
 */

static void
FreeAssemblyEnv(AssemblyEnv* assemEnvPtr)
				/* Environment to free */
{
    CompileEnv* envPtr = assemEnvPtr->envPtr;
				/* Compilation environment being used
				 * for code generation */
    Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
				/* Tcl interpreter */

    BasicBlock* thisBB;		/* Pointer to a basic block being deleted */
    BasicBlock* nextBB;		/* Pointer to a deleted basic block's 
				 * successor */
    Tcl_HashEntry* hashEntry;
    Tcl_HashSearch hashSearch;

    /* Free all the basic block structures */
    for (thisBB = assemEnvPtr->head_bb; thisBB != NULL; thisBB = nextBB) {
	if (thisBB->jumpTarget != NULL) {
	    Tcl_DecrRefCount(thisBB->jumpTarget);
	}
	if (thisBB->foreignExceptions != NULL) {
	    ckfree((char*)(thisBB->foreignExceptions));
	}
	nextBB = thisBB->successor1;
	if (thisBB->jtPtr != NULL) {
	    DeleteMirrorJumpTable(thisBB->jtPtr);
	    thisBB->jtPtr = NULL;
	}
	ckfree((char*)thisBB);
    }

    /* Free the label hash */
    while ((hashEntry = Tcl_FirstHashEntry(&assemEnvPtr->labelHash,
					    &hashSearch)) != NULL) {
	Tcl_DeleteHashEntry(hashEntry);
    }

    TclStackFree(interp, assemEnvPtr->parsePtr);
    TclStackFree(interp, assemEnvPtr);
}

/*
 *-----------------------------------------------------------------------------
 *
 * AssembleOneLine --
 *
 *	Assembles a single command from an assembly language source.
 *
 * Results:
 *	Returns TCL_ERROR with an appropriate error message if the
 *	assembly fails. Returns TCL_OK if the assembly succeeds. Updates
 *	the assembly environment with the state of the assembly.
 *
 *-----------------------------------------------------------------------------
 */

static int
AssembleOneLine(AssemblyEnv* assemEnvPtr)
				/* State of the assembly */
{
    CompileEnv* envPtr = assemEnvPtr->envPtr;
				/* Compilation environment being used for
				 * code gen */
    Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
				/* Tcl interpreter */
    Tcl_Parse* parsePtr = assemEnvPtr->parsePtr;
				/* Parse of the line of code */
    Tcl_Token* tokenPtr;	/* Current token within the line of code */
    Tcl_Obj* instNameObj = NULL;
				/* Name of the instruction */
    int tblind;			/* Index in TalInstructionTable of the 
				 * instruction */
    enum TalInstType instType;	/* Type of the instruction */
    Tcl_Obj* operand1Obj = NULL;
    				/* First operand to the instruction */
    const char* operand1;	/* String rep of the operand */
    int operand1Len;		/* String length of the operand  */
    int opnd;			/* Integer representation of an operand */
    int litIndex;		/* Literal pool index of a constant */
    int localVar;		/* LVT index of a local variable */
    int flags;			/* Flags for a basic block */
    JumptableInfo* jtPtr;	/* Pointer to a jumptable */
    int infoIndex;		/* Index of the jumptable in auxdata */
    int status = TCL_ERROR;	/* Return value from this function */
    
    /* Make sure that the instruction name is known at compile time. */

    tokenPtr = parsePtr->tokenPtr;
    instNameObj = Tcl_NewObj();
    Tcl_IncrRefCount(instNameObj);
    if (GetNextOperand(assemEnvPtr, &tokenPtr, &instNameObj) != TCL_OK) {
	return TCL_ERROR;
    }

    /* Look up the instruction name */
    
    if (Tcl_GetIndexFromObjStruct(interp, instNameObj,
				  &TalInstructionTable[0].name,
				  sizeof(TalInstDesc), "instruction",
				  TCL_EXACT, &tblind) != TCL_OK) {
	return TCL_ERROR;
    }

    /* Vector on the type of instruction being processed */

    instType = TalInstructionTable[tblind].instType;
    switch (instType) {

    case ASSEM_PUSH:
	if (parsePtr->numWords != 2) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "value");
	    goto cleanup;
	}
	if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) {
	    goto cleanup;
	}
	operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len);
	litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len);
	BBEmitInst1or4(assemEnvPtr, tblind, litIndex, 0);
	break;

    case ASSEM_1BYTE:
	if (parsePtr->numWords != 1) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "");
	    goto cleanup;
	}
	BBEmitOpcode(assemEnvPtr, tblind, 0);
	break;

    case ASSEM_BEGIN_CATCH:
	/* 
	 * Emit the BEGIN_CATCH instruction with the code offset of the
	 * exception branch target instead of the exception range index.
	 * The correct index will be generated and inserted later, when
	 * catches are being resolved.
	 */
	if (parsePtr->numWords != 2) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "label");
	    goto cleanup;
	}
	if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) {
	    goto cleanup;
	}
	assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine;
	assemEnvPtr->curr_bb->jumpOffset = envPtr->codeNext - envPtr->codeStart;
	BBEmitInstInt4(assemEnvPtr, tblind, 0, 0);
	assemEnvPtr->curr_bb->flags |= BB_BEGINCATCH;
	StartBasicBlock(assemEnvPtr, BB_FALLTHRU, operand1Obj);
	break;

    case ASSEM_BOOL:
	if (parsePtr->numWords != 2) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean");
	    goto cleanup;
	}
	if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
	    goto cleanup;
	}
	BBEmitInstInt1(assemEnvPtr, tblind, opnd, 0);
	break;

    case ASSEM_BOOL_LVT4:
	if (parsePtr->numWords != 3) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean varName");
	    goto cleanup;
	}
	if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
	    || (localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) < 0) {
	    goto cleanup;
	}
	BBEmitInstInt1(assemEnvPtr, tblind, opnd, 0);
	TclEmitInt4(localVar, envPtr);
	break;

    case ASSEM_CONCAT1:
	if (parsePtr->numWords != 2) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8");
	    goto cleanup;
	}
	if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
	    || CheckOneByte(interp, opnd) != TCL_OK
	    || CheckStrictlyPositive(interp, opnd) != TCL_OK) {
	    goto cleanup;
	}
	BBEmitInstInt1(assemEnvPtr, tblind, opnd, opnd);
	break;

    case ASSEM_DICT_GET:
	if (parsePtr->numWords != 2) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
	    goto cleanup;
	}
	if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
	    || CheckStrictlyPositive(interp, opnd) != TCL_OK) {
	    goto cleanup;
	}
	BBEmitInstInt4(assemEnvPtr, tblind, opnd, opnd+1);
	break;

    case ASSEM_DICT_SET:
	if (parsePtr->numWords != 3) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName");
	    goto cleanup;
	}
	if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
	    || CheckStrictlyPositive(interp, opnd) != TCL_OK
	    || (localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) == -1) {
	    goto cleanup;
	}
	BBEmitInstInt4(assemEnvPtr, tblind, opnd, opnd+1);
	TclEmitInt4(localVar, envPtr);
	break;

    case ASSEM_DICT_UNSET:
	if (parsePtr->numWords != 3) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName");
	    goto cleanup;
	}
	if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
	    || CheckStrictlyPositive(interp, opnd) != TCL_OK
	    || (localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) == -1) {
	    goto cleanup;
	}
	BBEmitInstInt4(assemEnvPtr, tblind, opnd, opnd);
	TclEmitInt4(localVar, envPtr);
	break;

    case ASSEM_END_CATCH:
	if (parsePtr->numWords != 1) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "");
	    goto cleanup;
	}
	assemEnvPtr->curr_bb->flags |= BB_ENDCATCH;
	BBEmitOpcode(assemEnvPtr, tblind, 0);
	StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL);
	break;

    case ASSEM_EVAL:
	/* TODO - Refactor this stuff into a subroutine
	 * that takes the inst code, the message ("script" or "expression")
	 * and an evaluator callback that calls TclCompileScript or
	 * TclCompileExpr. 
	 */
	if (parsePtr->numWords != 2) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, 
			     ((TalInstructionTable[tblind].tclInstCode
			       == INST_EVAL_STK) ? "script" : "expression"));
	    goto cleanup;
	}
	if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	    CompileEmbeddedScript(assemEnvPtr, tokenPtr+1, 
				  TalInstructionTable+tblind);
	} else if (GetNextOperand(assemEnvPtr, &tokenPtr,
				  &operand1Obj) != TCL_OK) {
	    goto cleanup;
	} else {
	    operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len);
	    litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len);
	    /* Assumes that PUSH is the first slot! */
	    BBEmitInst1or4(assemEnvPtr, 0, litIndex, 0);
	    BBEmitOpcode(assemEnvPtr, tblind, 0);
	}
	break;

    case ASSEM_INVOKE:
	if (parsePtr->numWords != 2) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
	    goto cleanup;
	}
	if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
	    || CheckStrictlyPositive(interp, opnd) != TCL_OK) {
	    goto cleanup;
	}
	
	BBEmitInst1or4(assemEnvPtr, tblind, opnd, opnd);
	break;
		 
    case ASSEM_JUMP: 
    case ASSEM_JUMP4:
	if (parsePtr->numWords != 2) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "label");
	    goto cleanup;
	}
	if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) {
	    goto cleanup;
	}
	assemEnvPtr->curr_bb->jumpOffset = envPtr->codeNext - envPtr->codeStart;
	if (instType == ASSEM_JUMP) {
	    flags = BB_JUMP1;
	    BBEmitInstInt1(assemEnvPtr, tblind, 0, 0);
	} else {
	    flags = 0;
	    BBEmitInstInt4(assemEnvPtr, tblind, 0, 0);
	}
                    
	/* Start a new basic block at the instruction following the jump */

	assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine;
	if (TalInstructionTable[tblind].operandsConsumed != 0) {
	    flags |= BB_FALLTHRU;
	}
	StartBasicBlock(assemEnvPtr, flags, operand1Obj);

	break;
                             
    case ASSEM_JUMPTABLE:
	if (parsePtr->numWords != 2) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "table");
	    goto cleanup;
	}
	if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) {
	    goto cleanup;
	}
	jtPtr = (JumptableInfo*) ckalloc(sizeof(JumptableInfo));
	Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS);
	assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine;
	assemEnvPtr->curr_bb->jumpOffset = envPtr->codeNext - envPtr->codeStart;
	/*fprintf(stderr, "bb %p jumpLine %d jumpOffset %d\n",
		assemEnvPtr->curr_bb, assemEnvPtr->cmdLine,
		envPtr->codeNext - envPtr->codeStart); fflush(stderr); */
	infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr);
	/* fprintf(stderr, "auxdata index=%d\n", infoIndex); */
	BBEmitInstInt4(assemEnvPtr, tblind, infoIndex, 0);
	if (CreateMirrorJumpTable(assemEnvPtr, operand1Obj) != TCL_OK) {
	    goto cleanup;
	}
	StartBasicBlock(assemEnvPtr, BB_JUMPTABLE|BB_FALLTHRU, NULL);
	break;

    case ASSEM_LABEL:

	if (parsePtr->numWords != 2) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "name");
	    goto cleanup;
	}
	if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) {
	    goto cleanup;
	}
	/* Add the (label_name, address) pair to the hash table */
	if (DefineLabel(assemEnvPtr, Tcl_GetString(operand1Obj)) != TCL_OK) {
	    goto cleanup;
	}
	break;

    case ASSEM_LINDEX_MULTI:
	if (parsePtr->numWords != 2) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
	    goto cleanup;
	}
	if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
	    || CheckStrictlyPositive(interp, opnd) != TCL_OK) {
	    goto cleanup;
	}
	BBEmitInstInt4(assemEnvPtr, tblind, opnd, opnd);
	break;
		 
    case ASSEM_LIST:
	if (parsePtr->numWords != 2) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
	    goto cleanup;
	}
	if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
	    || CheckNonNegative(interp, opnd) != TCL_OK) {
	    goto cleanup;
	}
	BBEmitInstInt4(assemEnvPtr, tblind, opnd, opnd);
	break;
		 
    case ASSEM_INDEX:
	if (parsePtr->numWords != 2) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
	    goto cleanup;
	}
	if (GetListIndexOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
	    goto cleanup;
	}
	BBEmitInstInt4(assemEnvPtr, tblind, opnd, opnd);
	break;

    case ASSEM_LSET_FLAT:
	if (parsePtr->numWords != 2) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
	    goto cleanup;
	}
	if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
	    goto cleanup;
	}
	if (opnd < 2) {
	    if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
		Tcl_SetObjResult(interp,
				 Tcl_NewStringObj("operand must be >=2", -1));
		Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND>=2", NULL);
	    }
	    goto cleanup;
	}
	BBEmitInstInt4(assemEnvPtr, tblind, opnd, opnd);
	break;
		 
    case ASSEM_LVT:
	if (parsePtr->numWords != 2) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname");
	    goto cleanup;
	}
	if ((localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) < 0) {
	    goto cleanup;
	}
	BBEmitInst1or4(assemEnvPtr, tblind, localVar, 0);
	break;

    case ASSEM_LVT1:
	if (parsePtr->numWords != 2) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname");
	    goto cleanup;
	}
	if ((localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) < 0
	    || CheckOneByte(interp, localVar)) {
	    goto cleanup;
	}
	BBEmitInstInt1(assemEnvPtr, tblind, localVar, 0);
	break;

    case ASSEM_LVT1_SINT1:
	if (parsePtr->numWords != 3) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "varName imm8");
	    goto cleanup;
	}
	if ((localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) < 0
	    || CheckOneByte(interp, localVar)
	    || GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
	    || CheckSignedOneByte(interp, opnd)) {
	    goto cleanup;
	}
	BBEmitInstInt1(assemEnvPtr, tblind, localVar, 0);
	TclEmitInt1(opnd, envPtr);
	break;

    case ASSEM_LVT4:
	if (parsePtr->numWords != 2) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname");
	    goto cleanup;
	}
	if ((localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) < 0) {
	    goto cleanup;
	}
	BBEmitInstInt4(assemEnvPtr, tblind, localVar, 0);
	break;

    case ASSEM_OVER:
	if (parsePtr->numWords != 2) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
	    goto cleanup;
	}
	if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
	    || CheckNonNegative(interp, opnd) != TCL_OK) {
	    goto cleanup;
	}
	BBEmitInstInt4(assemEnvPtr, tblind, opnd, opnd+1);
	break;

    case ASSEM_REGEXP:
	if (parsePtr->numWords != 2) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean");
	    goto cleanup;
	}
	if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
	    goto cleanup;
	}
	{
	    int flags = TCL_REG_ADVANCED | (opnd ? TCL_REG_NOCASE : 0);
	    BBEmitInstInt1(assemEnvPtr, tblind, flags, 0);
	}
	break;

    case ASSEM_REVERSE:
	if (parsePtr->numWords != 2) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
	    goto cleanup;
	}
	if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
	    || CheckNonNegative(interp, opnd) != TCL_OK) {
	    goto cleanup;
	}
	BBEmitInstInt4(assemEnvPtr, tblind, opnd, opnd);
	break;
		 
    case ASSEM_SINT1:
	if (parsePtr->numWords != 2) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8");
	    goto cleanup;
	}
	if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
	    || CheckSignedOneByte(interp, opnd) != TCL_OK) {
	    goto cleanup;
	}
	BBEmitInstInt1(assemEnvPtr, tblind, opnd, 0);
	break;

    case ASSEM_SINT4_LVT4:
	if (parsePtr->numWords != 3) {
	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName");
	    goto cleanup;
	}
	if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
	    || (localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) == -1) {
	    goto cleanup;
	}
	BBEmitInstInt4(assemEnvPtr, tblind, opnd, 0);
	TclEmitInt4(localVar, envPtr);
	break;

    default:
	Tcl_Panic("Instruction \"%s\" could not be found, can't happen\n",
		  Tcl_GetString(instNameObj));
    }

    status = TCL_OK;
 cleanup:
    if (instNameObj) {
	Tcl_DecrRefCount(instNameObj);
    }
    if (operand1Obj) {
	Tcl_DecrRefCount(operand1Obj);
    }
    return status;
}

/*
 *-----------------------------------------------------------------------------
 *
 * CompileEmbeddedScript --
 *
 *	Compile an embedded 'eval' or 'expr' that appears in assembly code.
 *
 * This procedure is called when the 'eval' or 'expr' assembly directive
 * is encountered, and the argument to the directive is a simple word that
 * requires no substitution. The appropriate compiler (TclCompileScript or
 * TclCompileExpr) is invoked recursively, and emits bytecode.
 *
 * Before the compiler is invoked, the compilation environment's stack
 * consumption is reset to zero. Upon return from the compilation, the
 * net stack effect of the compilation is in the compiler env, and this
 * stack effect is posted to the assembler environment. The compile
 * environment's stack consumption is then restored to what it was
 * before (which is actually the state of the stack on entry to the block
 * of assembly code).
 *
 * Any exception ranges pushed by the compilation are copied to the basic
 * block and removed from the compiler environment. They will be rebuilt at
 * the end of assembly, when the exception stack depth is actually known.
 *
 *-----------------------------------------------------------------------------
 */

static void
CompileEmbeddedScript(AssemblyEnv* assemEnvPtr,
				/* Assembler environment */
		      Tcl_Token* tokenPtr,
				/* Tcl_Token containing the script */
		      TalInstDesc* instPtr)
				/* Instruction that determines whether
				 * the script is 'expr' or 'eval' */
{
    /*
     * The expression or script is not only known at compile time,
     * but actually a "simple word". It can be compiled inline by
     * invoking the compiler recursively.
     */
    CompileEnv* envPtr = assemEnvPtr->envPtr;
				/* Compilation environment */
    Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
				/* Tcl interpreter */

    /* 
     * Save away the stack depth and reset it before compiling the script.
     * We'll record the stack usage of the script in the BasicBlock, and
     * accumulate it together with the stack usage of the enclosing assembly
     * code.
     */

    int savedStackDepth = envPtr->currStackDepth;
    int savedMaxStackDepth = envPtr->maxStackDepth;
    int savedCodeIndex = envPtr->codeNext - envPtr->codeStart;
    int savedExceptArrayNext = envPtr->exceptArrayNext;

    envPtr->currStackDepth = 0;
    envPtr->maxStackDepth = 0;

    StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL);
    switch(instPtr->tclInstCode) {
    case INST_EVAL_STK:
	TclCompileScript(interp, tokenPtr->start, tokenPtr->size, envPtr);
	break;
    case INST_EXPR_STK:
	TclCompileExpr(interp, tokenPtr->start, tokenPtr->size, envPtr, 1);
	break;
    default:
	Tcl_Panic("no ASSEM_EVAL case for %s (%d), can't happen",
		  instPtr->name, instPtr->tclInstCode);
    }

    /* 
     * Roll up the stack usage of the embedded block into the assembler
     * environment.
     */
    SyncStackDepth(assemEnvPtr);
    envPtr->currStackDepth = savedStackDepth;
    envPtr->maxStackDepth = savedMaxStackDepth;

    /* 
     * Save any exception ranges that were pushed by the compiler, They
     * will need to be fixed up once the stack depth is known.
     */

    MoveExceptionRangesToBasicBlock(assemEnvPtr, savedCodeIndex, 
				    savedExceptArrayNext);

    /* Flush the current basic block */

    StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL);
}

/*
 *-----------------------------------------------------------------------------
 *
 * SyncStackDepth --
 *
 *	Copies the stack depth from the compile environment to a basic
 *	block.
 *
 * Side effects:
 *	Current and max stack depth in the current basic block are
 *	adjusted.
 *
 * This procedure is called on return from invoking the compiler for
 * the 'eval' and 'expr' operations. It adjusts the stack depth of the
 * current basic block to reflect the stack required by the just-compiled
 * code.
 *
 *-----------------------------------------------------------------------------
 */

static void
SyncStackDepth(AssemblyEnv* assemEnvPtr)
				/* Assembly environment */
{
    CompileEnv* envPtr = assemEnvPtr->envPtr;
				/* Compilation environment */
    BasicBlock* curr_bb = assemEnvPtr->curr_bb;
				/* Current basic block */
    int maxStackDepth = curr_bb->finalStackDepth + envPtr->maxStackDepth;
				/* Max stack depth in the basic block */

    if (maxStackDepth > curr_bb->maxStackDepth) {
	curr_bb->maxStackDepth = maxStackDepth;
    }
    curr_bb->finalStackDepth += envPtr->currStackDepth;
}

/*
 *-----------------------------------------------------------------------------
 *
 * MoveExceptionRangesToBasicBlock --
 *
 *	Removes exception ranges that were created by compiling an embedded
 *	script from the CompileEnv, and stores them in the BasicBlock. They
 *	will be reinstalled, at the correct stack depth, after control flow
 *	analysis is complete on the assembly code.
 *
 *-----------------------------------------------------------------------------
 */

static void
MoveExceptionRangesToBasicBlock(AssemblyEnv* assemEnvPtr,
				/* Assembler environment */
				int savedCodeIndex,
				/* Start of the embedded code */
				int savedExceptArrayNext)
				/* Saved index of the end of the exception
				 * range array */
{
    CompileEnv* envPtr = assemEnvPtr->envPtr;
				/* Compilation environment */
    BasicBlock* curr_bb = assemEnvPtr->curr_bb;
				/* Current basic block */
    int exceptionCount = envPtr->exceptArrayNext - savedExceptArrayNext;
				/* Number of ranges that must be moved */
    int i;

    if (exceptionCount == 0) {
	/* Nothing to do */
	return;
    }

    /* 
     * Save the exception ranges in the basic block. They will be re-added
     * at the conclusion of assembly; at this time, the INST_BEGIN_CATCH
     * instructions in the block will be adjusted from whatever range
     * indices they have [savedExceptArrayNext .. envPtr->exceptArrayNext)
     * to the indices that the exceptions acquire. The saved exception ranges
     * are converted to a relative nesting depth. The depth will be recomputed
     * once flow analysis has determined the actual stack depth of the block.
     */

    /*fprintf(stderr, "basic block %p has %d exceptions starting at %d\n",
      curr_bb, exceptionCount, savedExceptArrayNext); */
    curr_bb->foreignExceptionBase = savedExceptArrayNext;
    curr_bb->foreignExceptionCount = exceptionCount;
    curr_bb->foreignExceptions = (ExceptionRange*)
	ckalloc(exceptionCount * sizeof(ExceptionRange));
    memcpy(curr_bb->foreignExceptions,
	   envPtr->exceptArrayPtr + savedExceptArrayNext,
	   exceptionCount * sizeof(ExceptionRange));
    for (i = 0; i < exceptionCount; ++i) {
	curr_bb->foreignExceptions[i].nestingLevel -= envPtr->exceptDepth;
    }
    envPtr->exceptArrayNext = savedExceptArrayNext;
    
}

/*
 *-----------------------------------------------------------------------------
 * 
 * CreateMirrorJumpTable --
 *
 *	Makes a jump table with comparison values and assembly code labels.
 *
 * Results:
 *	Returns a standard Tcl status, with an error message in the interpreter
 *	on error.
 *
 * Side effects:
 *	Initializes the jump table pointer in the current basic block to
 *	a JumptableInfo. The keys in the JumptableInfo are the comparison
 *	strings. The values, instead of being jump displacements, are
 *	Tcl_Obj's with the code labels.
 */

static int
CreateMirrorJumpTable(AssemblyEnv* assemEnvPtr,
				/* Assembly environment */
		      Tcl_Obj* jumps)
				/* List of alternating keywords and labels */
{
    int objc;			/* Number of elements in the 'jumps' list */
    Tcl_Obj** objv;		/* Pointers to the elements in the list */

    CompileEnv* envPtr = assemEnvPtr->envPtr;
				/* Compilation environment */
    Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
				/* Tcl interpreter */
    BasicBlock* bbPtr = assemEnvPtr->curr_bb;
				/* Current basic block */
    JumptableInfo* jtPtr;
    Tcl_HashTable* jtHashPtr;	/* Hashtable in the JumptableInfo */
    Tcl_HashEntry* hashEntry;	/* Entry for a key in the hashtable */
    int isNew;			/* Flag==1 if the key is not yet in the table */
    Tcl_Obj* result;		/* Error message */
    int i;

    if (Tcl_ListObjGetElements(interp, jumps, &objc, &objv) != TCL_OK) {
	return TCL_ERROR;
    }
    if (objc % 2 != 0) {
	if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
	    Tcl_SetObjResult(interp,
			     Tcl_NewStringObj("jump table must have an "
					      "even number of list "
					      "elements", -1));
	    Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADJUMPTABLE", NULL);
	}
	return TCL_ERROR;
    }
    
    /* Allocate the jumptable */

    jtPtr = (JumptableInfo*) ckalloc(sizeof(JumptableInfo));
    jtHashPtr = &(jtPtr->hashTable);
    Tcl_InitHashTable(jtHashPtr, TCL_STRING_KEYS);

    /* Fill the keys and labels into the table */

    /* fprintf(stderr, "jump table {\n"); */
    for (i = 0; i < objc; i+=2) {
	/* fprintf(stderr, "  %s -> %s\n", Tcl_GetString(objv[i]),
	   Tcl_GetString(objv[i+1])); fflush(stderr); */
	hashEntry = Tcl_CreateHashEntry(jtHashPtr, Tcl_GetString(objv[i]),
				       &isNew);
	if (!isNew) {
	    if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
		result = Tcl_NewStringObj("duplicate entry in jump table for "
					  "\"", -1);
		Tcl_AppendObjToObj(result, objv[i]);
		Tcl_AppendToObj(result, "\"", -1);
		Tcl_SetObjResult(interp, result);
		Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPJUMPTABLEENTRY");
		DeleteMirrorJumpTable(jtPtr);
		return TCL_ERROR;
	    }
	}
	Tcl_SetHashValue(hashEntry, (ClientData) objv[i+1]);
	Tcl_IncrRefCount(objv[i+1]);
    }
    /* fprintf(stderr, "}\n"); fflush(stderr); */
	    

    /* Put the mirror jumptable in the basic block struct */

    bbPtr->jtPtr = jtPtr;

    return TCL_OK;
}

/*
 *-----------------------------------------------------------------------------
 *
 * DeleteMirrorJumpTable --
 *
 *	Cleans up a jump table when the basic block is deleted.
 *
 *-----------------------------------------------------------------------------
 */

static void
DeleteMirrorJumpTable(JumptableInfo* jtPtr)
{
    Tcl_HashTable* jtHashPtr = &jtPtr->hashTable;
				/* Hash table pointer */
    Tcl_HashSearch search;	/* Hash search control */
    Tcl_HashEntry* entry;	/* Hash table entry containing a jump label */
    Tcl_Obj* label;		/* Jump label from the hash table */

    for (entry = Tcl_FirstHashEntry(jtHashPtr, &search);
	 entry != NULL;
	 entry = Tcl_NextHashEntry(&search)) {
	label = (Tcl_Obj*) Tcl_GetHashValue(entry);
	Tcl_DecrRefCount(label);
	Tcl_SetHashValue(entry, NULL);
    }
    Tcl_DeleteHashTable(jtHashPtr);
    ckfree((char*)jtPtr);
}
				    

/*
 *-----------------------------------------------------------------------------
 *
 * GetNextOperand --
 *
 *	Retrieves the next operand in sequence from an assembly
 *	instruction, and makes sure that its value is known at
 *	compile time.
 *
 * Results:
 *	If successful, returns TCL_OK and leaves a Tcl_Obj with
 *	the operand text in *operandObjPtr. In case of failure,
 *	returns TCL_ERROR and leaves *operandObjPtr untouched.
 *
 * Side effects:
 *	Advances *tokenPtrPtr around the token just processed.
 *
 *-----------------------------------------------------------------------------
 */

static int
GetNextOperand(AssemblyEnv* assemEnvPtr,
				/* Assembler environment */
	       Tcl_Token** tokenPtrPtr,
				/* INPUT/OUTPUT: Pointer to the token
				 * holding the operand */
	       Tcl_Obj** operandObjPtr)
				/* OUTPUT: Tcl object holding the
				 * operand text with \-substitutions 
				 * done. */
{
    Tcl_Interp* interp = (Tcl_Interp*) assemEnvPtr->envPtr->iPtr;
    Tcl_Obj* operandObj = Tcl_NewObj();
    if (!TclWordKnownAtCompileTime(*tokenPtrPtr, operandObj)) {
	Tcl_DecrRefCount(operandObj);
	if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
	    Tcl_SetObjResult(interp,
			     Tcl_NewStringObj("assembly code may not "
					      "contain substitutions", -1));
	    Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOSUBST", NULL);
	}
	return TCL_ERROR;
    }
    *tokenPtrPtr = TokenAfter(*tokenPtrPtr);
    Tcl_IncrRefCount(operandObj);
    *operandObjPtr = operandObj;
    return TCL_OK;
}

/*
 *-----------------------------------------------------------------------------
 *
 * GetBooleanOperand --
 *
 *	Retrieves a Boolean operand from the input stream and advances
 *	the token pointer.
 *
 * Results:
 *	Returns a standard Tcl result (with an error message in the
 *	interpreter on failure).
 *
 * Side effects:
 *	Stores the Boolean value in (*result) and advances (*tokenPtrPtr)
 *	to the next token.
 *
 *-----------------------------------------------------------------------------
 */

static int
GetBooleanOperand(AssemblyEnv* assemEnvPtr,
				/* Assembly environment */
		  Tcl_Token** tokenPtrPtr,
				/* Current token from the parser */
		  int* result)
				/* OUTPUT: Integer extracted from the token */
{
    CompileEnv* envPtr = assemEnvPtr->envPtr;
				/* Compilation environment */
    Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
				/* Tcl interpreter */
    Tcl_Token* tokenPtr = *tokenPtrPtr;
				/* INOUT: Pointer to the next token
				 * in the source code */
    Tcl_Obj* intObj = Tcl_NewObj();
				/* Integer from the source code */
    int status;			/* Tcl status return */

    /* Extract the next token as a string */

    Tcl_IncrRefCount(intObj);
    if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) {
	Tcl_DecrRefCount(intObj);
	return TCL_ERROR;
    }
    
    /* Convert to an integer, advance to the next token and return */

    status = Tcl_GetBooleanFromObj(interp, intObj, result);
    Tcl_DecrRefCount(intObj);
    *tokenPtrPtr = TokenAfter(tokenPtr);
    return status;
}

/*
 *-----------------------------------------------------------------------------
 *
 * GetIntegerOperand --
 *
 *	Retrieves an integer operand from the input stream and advances
 *	the token pointer.
 *
 * Results:
 *	Returns a standard Tcl result (with an error message in the
 *	interpreter on failure).
 *
 * Side effects:
 *	Stores the integer value in (*result) and advances (*tokenPtrPtr)
 *	to the next token.
 *
 *-----------------------------------------------------------------------------
 */

static int
GetIntegerOperand(AssemblyEnv* assemEnvPtr,
				/* Assembly environment */
		  Tcl_Token** tokenPtrPtr,
				/* Current token from the parser */
		  int* result)
				/* OUTPUT: Integer extracted from the token */
{
    CompileEnv* envPtr = assemEnvPtr->envPtr;
				/* Compilation environment */
    Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
				/* Tcl interpreter */
    Tcl_Token* tokenPtr = *tokenPtrPtr;
				/* INOUT: Pointer to the next token
				 * in the source code */
    Tcl_Obj* intObj = Tcl_NewObj();
				/* Integer from the source code */
    int status;			/* Tcl status return */

    /* Extract the next token as a string */

    Tcl_IncrRefCount(intObj);
    if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) {
	Tcl_DecrRefCount(intObj);
	return TCL_ERROR;
    }
    
    /* Convert to an integer, advance to the next token and return */

    status = Tcl_GetIntFromObj(interp, intObj, result);
    Tcl_DecrRefCount(intObj);
    *tokenPtrPtr = TokenAfter(tokenPtr);
    return status;
}

/*
 *-----------------------------------------------------------------------------
 *
 * GetListIndexOperand --
 *
 *	Gets the value of an operand intended to serve as a list index.
 *
 * Results:
 *	Returns a standard Tcl result: TCL_OK if the parse is successful
 *	and TCL_ERROR (with an appropriate error message) if the parse fails.
 *
 * Side effects:
 *	Stores the list index at '*index'. Values between -1 and 0x7fffffff
 *	have their natural meaning; values between -2 and -0x80000000
 *	represent 'end-2-N'.
 *
 *-----------------------------------------------------------------------------
 */

static int
GetListIndexOperand(
		    AssemblyEnv* assemEnvPtr,
				/* Assembly environment */
		    Tcl_Token** tokenPtrPtr,
				/* Current token from the parser */
		    int* result)
				/* OUTPUT: Integer extracted from the token */
{
    CompileEnv* envPtr = assemEnvPtr->envPtr;
				/* Compilation environment */
    Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
				/* Tcl interpreter */
    Tcl_Token* tokenPtr = *tokenPtrPtr;
				/* INOUT: Pointer to the next token
				 * in the source code */
    Tcl_Obj* intObj = Tcl_NewObj();
				/* Integer from the source code */
    int status;			/* Tcl status return */

    /* Extract the next token as a string */

    Tcl_IncrRefCount(intObj);
    if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) {
	Tcl_DecrRefCount(intObj);
	return TCL_ERROR;
    }

    /* Convert to an integer, advance to the next token and return */

    status = TclGetIntForIndex(interp, intObj, -2, result);
    Tcl_DecrRefCount(intObj);
    *tokenPtrPtr = TokenAfter(tokenPtr);
    return status;
}

/*
 *-----------------------------------------------------------------------------
 *
 * FindLocalVar --
 *
 *	Gets the name of a local variable from the input stream and advances
 *	the token pointer.
 *
 * Results:
 *	Returns the LVT index of the local variable.  Returns -1 if
 *	the variable is non-local, not known at compile time, or
 *	cannot be installed in the LVT (leaving an error message in
 *	the interpreter result if necessary).
 *
 * Side effects:
 *	Advances the token pointer.  May define a new LVT slot if the
 *	variable has not yet been seen and the execution context allows
 *	for it.
 *
 *-----------------------------------------------------------------------------
 */

static int
FindLocalVar(AssemblyEnv* assemEnvPtr,
	     Tcl_Token** tokenPtrPtr)
{
    CompileEnv* envPtr = assemEnvPtr->envPtr;
				/* Compilation environment */
    Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
				/* Tcl interpreter */
    Tcl_Token* tokenPtr = *tokenPtrPtr;
				/* INOUT: Pointer to the next token
				 * in the source code */
    Tcl_Obj* varNameObj = Tcl_NewObj();
				/* Name of the variable */
    const char* varNameStr;
    int varNameLen;
    int localVar;		/* Index of the variable in the LVT */

    Tcl_IncrRefCount(varNameObj);
    if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &varNameObj) != TCL_OK) {
	Tcl_DecrRefCount(varNameObj);
	return -1;
    }
    varNameStr = Tcl_GetStringFromObj(varNameObj, &varNameLen);
    if (CheckNamespaceQualifiers(interp, varNameStr, varNameLen)) {
	return -1;
    }
    localVar = TclFindCompiledLocal(varNameStr, varNameLen, 1, envPtr);
    Tcl_DecrRefCount(varNameObj);
    if (localVar == -1) {
	if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
	    Tcl_SetObjResult(interp,
			     Tcl_NewStringObj("cannot use this instruction"
					      " to create a variable"
					      " in a non-proc context", -1));
	    Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", NULL);
	}
	return -1;
    }
    *tokenPtrPtr = TokenAfter(tokenPtr);
    return localVar;
}

/*
 *-----------------------------------------------------------------------------
 *
 * 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 */
			 int nameLen)
				/* Length of the variable */
{
    Tcl_Obj* result;		/* Error message */
    const char* p;
    for (p = name; p+2 < name+nameLen;  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", "ASSEM", "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 one byte", -1);
	Tcl_SetObjResult(interp, result);
	Tcl_SetErrorCode(interp, "TCL", "ASSEM", "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 one byte", -1);
	Tcl_SetObjResult(interp, result);
	Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *-----------------------------------------------------------------------------
 *
 * CheckNonNegative --
 *
 *	Verify that a constant is nonnegative
 *
 * 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_INVOKE
 * are consuming a positive number of operands
 *
 *-----------------------------------------------------------------------------
 */

static int
CheckNonNegative(Tcl_Interp* interp,
				/* Tcl interpreter for error reporting */
		 int value)	/* Value to check */
{
    Tcl_Obj* result;		/* Error message */
    if (value < 0) {
	result = Tcl_NewStringObj("operand must be nonnegative", -1);
	Tcl_SetObjResult(interp, result);
	Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONNEGATIVE", NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *-----------------------------------------------------------------------------
 *
 * CheckStrictlyPositive --
 *
 *	Verify that a constant is positive
 *
 * 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_INVOKE
 * are consuming a positive number of operands
 *
 *-----------------------------------------------------------------------------
 */

static int
CheckStrictlyPositive(Tcl_Interp* interp,
				/* Tcl interpreter for error reporting */
		      int value)	/* Value to check */
{
    Tcl_Obj* result;		/* Error message */
    if (value <= 0) {
	result = Tcl_NewStringObj("operand must be positive", -1);
	Tcl_SetObjResult(interp, result);
	Tcl_SetErrorCode(interp, "TCL", "ASSEM", "POSITIVE", 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(AssemblyEnv* assemEnvPtr,	/* Assembly environment */
	    const char* labelName)	/* Label being defined */
{
    CompileEnv* envPtr = assemEnvPtr->envPtr;
				/* Compilation environment */
    Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
				/* Tcl interpreter */
    Tcl_HashEntry* entry;	/* Label's entry in the symbol table */
    int isNew;			/* Flag == 1 iff the label was previously
				 * undefined */
    Tcl_Obj* result;		/* Error message */

    /* TODO - This can now be simplified! */

    StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL);

    /* Look up the newly-defined label in the symbol table */

    entry = Tcl_CreateHashEntry(&assemEnvPtr->labelHash, labelName, &isNew);
    if (isNew) {

	/* This is the first appearance of the label in the code */

	Tcl_SetHashValue(entry, assemEnvPtr->curr_bb);

    } else {

	/* This is a duplicate label */

	if (assemEnvPtr-> flags & (TCL_EVAL_DIRECT)) {
	    result = Tcl_NewStringObj("duplicate definition "
				      "of label \"", -1);
	    Tcl_AppendToObj(result, labelName, -1);
	    Tcl_AppendToObj(result, "\"", -1);
	    Tcl_SetObjResult(interp, result);
	    Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPLABEL", 
			     labelName, NULL);
	}
	return TCL_ERROR;
    }

    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(AssemblyEnv* assemEnvPtr,
				/* Assembly environment */
		int flags,	/* Flags to apply to the basic block
				 * being closed, if there is one. */
		Tcl_Obj* jumpLabel)
				/* Label of the location that the
				 * block jumps to, or NULL if the block
				 * does not jump */
{
    CompileEnv* envPtr = assemEnvPtr->envPtr;
				/* Compilation environment */
    BasicBlock* newBB;	 	/* BasicBlock structure for the new block */
    BasicBlock* currBB = assemEnvPtr->curr_bb;

    /* Coalesce zero-length blocks */

    if (currBB->startOffset == envPtr->codeNext - envPtr->codeStart) {
	currBB->startLine = assemEnvPtr->cmdLine;
	return currBB;
    }

    /* Make the new basic block */

    newBB = AllocBB(assemEnvPtr);

    /* Record the jump target if there is one. */

    if ((currBB->jumpTarget = jumpLabel) != NULL) { 
	Tcl_IncrRefCount(currBB->jumpTarget);
    }

    /* Record the fallthrough if there is one. */

    currBB->flags |= flags;

    /* Record the successor block */

    currBB->successor1 = newBB;
    assemEnvPtr->curr_bb = 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(AssemblyEnv* assemEnvPtr)
				/* Assembly environment */
{
    CompileEnv* envPtr = assemEnvPtr->envPtr;
    BasicBlock * bb = (BasicBlock *) ckalloc(sizeof(BasicBlock));

    bb->originalStartOffset =
	bb->startOffset = envPtr->codeNext - envPtr->codeStart;
    bb->startLine = assemEnvPtr->cmdLine + 1;
    bb->jumpOffset = -1;
    bb->jumpLine = -1;
    bb->prevPtr = assemEnvPtr->curr_bb;
    bb->predecessor = NULL;
    bb->successor1 = NULL;
    bb->jumpTarget = NULL;
    bb->initialStackDepth = 0;
    bb->minStackDepth = 0;
    bb->maxStackDepth = 0;
    bb->finalStackDepth = 0;
    bb->enclosingCatch = NULL;
    bb->foreignExceptionBase = -1;
    bb->foreignExceptionCount = 0;
    bb->foreignExceptions = NULL;
    bb->jtPtr = NULL;
    bb->flags = 0;

    return bb;
}

/*
 *-----------------------------------------------------------------------------
 *
 * FinishAssembly --
 *
 *	Postprocessing after all bytecode has been generated for a block
 *	of assembly code.
 *
 * Results:
 *	Returns a standard Tcl result, with an error message left in the
 *	interpreter if appropriate.
 *
 * Side effects:
 *	The program is checked to see if any undefined labels remain.
 *	The initial stack depth of all the basic blocks in the flow graph
 *	is calculated and saved.  The stack balance on exit is computed,
 *	checked and saved.
 *
 *-----------------------------------------------------------------------------
 */

static int 
FinishAssembly(AssemblyEnv* assemEnvPtr)
				/* Assembly environment */
{

    int mustMove;		/* Amount by which the code needs to be
				 * grown because of expanding jumps */

    /* 
     * Resolve the targets of all jumps and determine whether code needs
     * to be moved around.
     */

    if (CalculateJumpRelocations(assemEnvPtr, &mustMove)) {
	return TCL_ERROR;
    }

    /* Move the code if necessary */

    if (mustMove) {
	MoveCodeForJumps(assemEnvPtr, mustMove);
    }

    /* Resolve jump target labels to bytecode offsets */

    FillInJumpOffsets(assemEnvPtr);

    /* Label each basic block with its catch context. Quit on inconsistency */

    if (ProcessCatches(assemEnvPtr) != TCL_OK) {
	return TCL_ERROR;
    }

    /*
     * Make sure that no block accessible from a catch's error exit that hasn't
     * popped the exception stack can throw an exception.
     */

    if (CheckForThrowInWrongContext(assemEnvPtr) != TCL_OK) {
	return TCL_ERROR;
    }

    /* Compute stack balance throughout the program */

    if (CheckStack(assemEnvPtr) != TCL_OK) {
	return TCL_ERROR;
    }

    /* TODO - Check for unreachable code */
    /* Maybe not - unreachable code is Mostly Harmless. */

    return TCL_OK;
}

/*
 *-----------------------------------------------------------------------------
 *
 * CalculateJumpRelocations --
 *
 *	Calculate any movement that has to be done in the assembly code to
 *	expand JUMP1 instructions to JUMP4 (because they jump more than
 *	a 1-byte range).
 *
 * Results:
 *	Returns a standard Tcl result, with an appropriate error message
 *	if anything fails.
 *
 * Side effects:
 *	Sets the 'startOffset' pointer in every basic block to the new
 *	origin of the block, and turns off JUMP1 flags on instructions that
 *	must be expanded (and adjusts them to the corresponding JUMP4's)
 *	Does *not* store the jump offsets at this point.
 *
 *	Sets *mustMove to 1 if and only if at least one instruction changed
 *	size so the code must be moved.
 *	
 *	As a side effect, also checks for undefined labels
 *	and reports them.
 *
 *-----------------------------------------------------------------------------
 */

static int
CalculateJumpRelocations(AssemblyEnv* assemEnvPtr,
				/* Assembler environment */
			 int* mustMove)
				/* OUTPUT: Number of bytes that have been
				 * added to the code */
{
    CompileEnv* envPtr = assemEnvPtr->envPtr;
				/* Compilation environment */
    BasicBlock* bbPtr;		/* Pointer to a basic block being checked */
    Tcl_HashEntry* entry;	/* Exit label's entry in the symbol table */
    BasicBlock* jumpTarget;	/* Basic block where the jump goes */
    int motion;		        /* Amount by which the code has expanded */
    int offset;			/* Offset in the bytecode from a jump
				 * instruction to its target */
    unsigned opcode;		/* Opcode in the bytecode being adjusted */

    /* Iterate through basic blocks as long as a change results in
     * code expansion */

    *mustMove = 0;
    do {
	motion = 0;
	for (bbPtr = assemEnvPtr->head_bb;
	     bbPtr != NULL;
	     bbPtr=bbPtr->successor1) {

	    /* 
	     * Advance the basic block start offset by however many bytes
	     * we have inserted in the code up to this point
	     */
	    bbPtr->startOffset += motion;

	    /* 
	     * If the basic block references a label (and hence performs
	     * a jump), find the location of the label. Report an error if
	     * the label is missing.
	     */
	    if (bbPtr->jumpTarget != NULL) {
		entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, 
					  Tcl_GetString(bbPtr->jumpTarget));
		if (entry == NULL) {
		    ReportUndefinedLabel(assemEnvPtr, bbPtr,
					 bbPtr->jumpTarget);
		    return TCL_ERROR;
		}

		/* 
		 * If the instruction is a JUMP1, turn it into a JUMP4 if its
		 * target is out of range.
		 */
		jumpTarget = (BasicBlock*) Tcl_GetHashValue(entry);
		if (bbPtr->flags & BB_JUMP1) {
		    offset = jumpTarget->startOffset
			- (bbPtr->jumpOffset + motion);
		    if (offset < -0x80 || offset > 0x7f) {
			opcode = TclGetUInt1AtPtr(envPtr->codeStart
						  + bbPtr->jumpOffset);
			++opcode;
			TclStoreInt1AtPtr(opcode, 
					  envPtr->codeStart
					  + bbPtr->jumpOffset);
			motion += 3;
			bbPtr->flags &= ~BB_JUMP1;
		    }
		}
	    }

	    /*
	     * If the basic block references a jump table, that doesn't
	     * affect the code locations, but resolve the labels now, and
	     * store basic block pointers in the jumptable hash.
	     */

	    if (bbPtr->flags & BB_JUMPTABLE) {
		if (CheckJumpTableLabels(assemEnvPtr, bbPtr) != TCL_OK) {
		    return TCL_ERROR;
		}
	    }
	}
	*mustMove += motion;
    } while (motion != 0);

    return TCL_OK;
}

/*
 *-----------------------------------------------------------------------------
 *
 * CheckJumpTableLabels --
 *
 *	Make sure that all the labels in a jump table are defined.
 *
 * Results:
 *	Returns TCL_OK if they are, TCL_ERROR if they aren't.
 *
 *-----------------------------------------------------------------------------
 */

static int
CheckJumpTableLabels(AssemblyEnv* assemEnvPtr,
				/* Assembly environment */
		     BasicBlock* bbPtr)
				/* Basic block that ends in a jump table */
{
    Tcl_HashTable* symHash = &bbPtr->jtPtr->hashTable;
				/* Hash table with the symbols */
    Tcl_HashSearch search;	/* Hash table iterator */
    Tcl_HashEntry* symEntryPtr;	/* Hash entry for the symbols */
    Tcl_Obj* symbolObj;		/* Jump target */
    Tcl_HashEntry* valEntryPtr;	/* Hash entry for the resolutions */

    /* Look up every jump target in the jump hash */

    /* fprintf(stderr, "check jump table labels %p {\n", bbPtr); */
    for (symEntryPtr = Tcl_FirstHashEntry(symHash, &search);
	 symEntryPtr != NULL;
	 symEntryPtr = Tcl_NextHashEntry(&search)) {
	symbolObj = (Tcl_Obj*) Tcl_GetHashValue(symEntryPtr);
	valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, 
					Tcl_GetString(symbolObj));
	/* fprintf(stderr, "  %s -> %s (%d)\n",
		(char*)Tcl_GetHashKey(symHash, symEntryPtr),
		Tcl_GetString(symbolObj),
		(valEntryPtr != NULL)); fflush(stderr); */
	if (valEntryPtr == NULL) {
	    ReportUndefinedLabel(assemEnvPtr, bbPtr, symbolObj);
	    return TCL_ERROR;
	}
    }
    /* fprintf(stderr, "}\n"); fflush(stderr); */
    return TCL_OK;
}

/*
 *-----------------------------------------------------------------------------
 *
 * ReportUndefinedLabel --
 *
 *	Report that a basic block refers to an undefined jump label
 *
 * Side effects:
 *	Stores an error message, error code, and line number information in
 *	the assembler's Tcl interpreter.
 *
 *-----------------------------------------------------------------------------
 */
static void
ReportUndefinedLabel(AssemblyEnv* assemEnvPtr,
				/* Assembler environment */
		     BasicBlock* bbPtr,
				/* Basic block that contains the
				 * undefined label */
		     Tcl_Obj* jumpTarget)
				/* Label of a jump target */
{
    CompileEnv* envPtr = assemEnvPtr->envPtr;
				/* Compilation environment */
    Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
				/* Tcl interpreter */
    Tcl_Obj* result;		/* Error message */

    if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
	result = Tcl_NewStringObj("undefined label \"", -1);
	Tcl_AppendObjToObj(result, jumpTarget);
	Tcl_AppendToObj(result, "\"", -1);
	Tcl_SetObjResult(interp, result);
	Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOLABEL",
			 Tcl_GetString(jumpTarget),  NULL);
	Tcl_SetErrorLine(interp, bbPtr->jumpLine);
    }
}

/*
 *-----------------------------------------------------------------------------
 *
 * MoveCodeForJumps --
 *
 *	Move bytecodes in memory to accommodate JUMP1 instructions that have
 *	expanded to become JUMP4's.
 *
 *-----------------------------------------------------------------------------
 */

static void
MoveCodeForJumps(AssemblyEnv* assemEnvPtr,
				/* Assembler environment */
		 int mustMove)	/* Number of bytes of added code */
{
    CompileEnv* envPtr = assemEnvPtr->envPtr;
				/* Compilation environment */
    BasicBlock* bbPtr;		/* Pointer to a basic block being checked */
    int topOffset;		/* Bytecode offset of the following
				 * basic block before code motion */

    /* 
     * Make sure that there is enough space in the bytecode array to accommodate
     * the expanded code.
     */

    while (envPtr->codeEnd < envPtr->codeNext + mustMove) {
	TclExpandCodeArray(envPtr);
    }

    /* 
     * Iterate through the bytecodes in reverse order, and move them
     * upward to their new homes.
     */

    topOffset = envPtr->codeNext - envPtr->codeStart;
    for (bbPtr = assemEnvPtr->curr_bb; bbPtr != NULL; bbPtr = bbPtr->prevPtr) {
	/* fprintf(stderr, "move code from %d to %d\n",
		bbPtr->originalStartOffset, bbPtr->startOffset); fflush(stderr);
	*/
	memmove(envPtr->codeStart + bbPtr->startOffset,
		envPtr->codeStart + bbPtr->originalStartOffset,
		topOffset - bbPtr->originalStartOffset);
	topOffset = bbPtr->originalStartOffset;
	bbPtr->jumpOffset += (bbPtr->startOffset - bbPtr->originalStartOffset);
    }
    envPtr->codeNext += mustMove;
}

/*
 *-----------------------------------------------------------------------------
 *
 * FillInJumpOffsets --
 *
 *	Fill in the final offsets of all jump instructions once bytecode
 *	locations have been completely determined.
 *
 *-----------------------------------------------------------------------------
 */

static void
FillInJumpOffsets(AssemblyEnv* assemEnvPtr)
{
    CompileEnv* envPtr = assemEnvPtr->envPtr;
				/* Compilation environment */
    BasicBlock* bbPtr;		/* Pointer to a basic block being checked */
    Tcl_HashEntry* entry;	/* Hashtable entry for a jump target label */
    BasicBlock* jumpTarget;	/* Basic block where a jump goes */
    int fromOffset;		/* Bytecode location of a jump instruction */
    int targetOffset;		/* Bytecode location of a jump instruction's
				 * target */

    for (bbPtr = assemEnvPtr->head_bb;
	 bbPtr != NULL;
	 bbPtr = bbPtr->successor1) {
	if (bbPtr->jumpTarget != NULL) {
	    entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, 
				      Tcl_GetString(bbPtr->jumpTarget));
	    jumpTarget = (BasicBlock*) Tcl_GetHashValue(entry);
	    fromOffset = bbPtr->jumpOffset;
	    targetOffset = jumpTarget->startOffset;
	    if (bbPtr->flags & BB_JUMP1) {
		TclStoreInt1AtPtr(targetOffset - fromOffset,
				  envPtr->codeStart + fromOffset + 1);
	    } else {
		TclStoreInt4AtPtr(targetOffset - fromOffset,
				  envPtr->codeStart + fromOffset + 1);
	    }
	}
	if (bbPtr->flags & BB_JUMPTABLE) {
	    ResolveJumpTableTargets(assemEnvPtr, bbPtr);
	}
    }

}

/*
 *-----------------------------------------------------------------------------
 *
 * ResolveJumpTableTargets --
 *
 *	Puts bytecode addresses for the targets of a jumptable into the
 *	table
 *
 * Results:
 *	Returns TCL_OK if they are, TCL_ERROR if they aren't.
 *
 *-----------------------------------------------------------------------------
 */

static void
ResolveJumpTableTargets(AssemblyEnv* assemEnvPtr,
				/* Assembly environment */
			BasicBlock* bbPtr)
				/* Basic block that ends in a jump table */
{
    CompileEnv* envPtr = assemEnvPtr->envPtr;;
				/* Compilation environment */
    Tcl_HashTable* symHash = &bbPtr->jtPtr->hashTable;
				/* Hash table with the symbols */
    Tcl_HashSearch search;	/* Hash table iterator */
    Tcl_HashEntry* symEntryPtr;	/* Hash entry for the symbols */
    Tcl_Obj* symbolObj;		/* Jump target */
    Tcl_HashEntry* valEntryPtr;	/* Hash entry for the resolutions */
    int auxDataIndex;		/* Index of the auxdata */
    JumptableInfo* realJumpTablePtr;
				/* Jump table in the actual code */
    Tcl_HashTable* realJumpHashPtr;
				/* Jump table hash in the actual code */
    Tcl_HashEntry* realJumpEntryPtr;
				/* Entry in the jump table hash in 
				 * the actual code */
    BasicBlock* jumpTargetBBPtr;
				/* Basic block that the jump proceeds to */
    int junk;
    
    auxDataIndex = TclGetInt4AtPtr(envPtr->codeStart + bbPtr->jumpOffset + 1);
    /* fprintf(stderr, "bbPtr = %p jumpOffset = %d auxDataIndex = %d\n", 
       bbPtr, bbPtr->jumpOffset, auxDataIndex); */
    realJumpTablePtr = (JumptableInfo*)
	envPtr->auxDataArrayPtr[auxDataIndex].clientData;
    realJumpHashPtr = &(realJumpTablePtr->hashTable);

    /* Look up every jump target in the jump hash */

    /* fprintf(stderr, "resolve jump table {\n"); fflush(stderr); */
    for (symEntryPtr = Tcl_FirstHashEntry(symHash, &search);
	 symEntryPtr != NULL;
	 symEntryPtr = Tcl_NextHashEntry(&search)) {
	symbolObj = (Tcl_Obj*) Tcl_GetHashValue(symEntryPtr);
	/* fprintf(stderr, "     symbol %s\n", Tcl_GetString(symbolObj)); */
	valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
					Tcl_GetString(symbolObj));
	jumpTargetBBPtr = (BasicBlock*) Tcl_GetHashValue(valEntryPtr);
	realJumpEntryPtr =
	    Tcl_CreateHashEntry(realJumpHashPtr,
				Tcl_GetHashKey(symHash, symEntryPtr),
				&junk);
	/* fprintf(stderr, "  %s -> %s -> bb %p (pc %d)    hash entry %p\n",
		(char*)Tcl_GetHashKey(symHash, symEntryPtr),
		Tcl_GetString(symbolObj), jumpTargetBBPtr,
		jumpTargetBBPtr->startOffset, realJumpEntryPtr);
	   fflush(stderr); */
	Tcl_SetHashValue(realJumpEntryPtr,
			 (ClientData) (jumpTargetBBPtr->startOffset
				       - bbPtr->jumpOffset));
    }
    /* fprintf(stderr, "}\n"); fflush(stderr); */
}

/*
 *-----------------------------------------------------------------------------
 *
 * CheckForThrowInWrongContext --
 *
 *	Verify that no beginCatch/endCatch sequence can throw an exception
 *	after an original exception is caught and before its exception
 *	context is removed from the stack.
 *
 * Results:
 *	Returns a standard Tcl result.
 *
 * Side effects:
 *	Stores an appropriate error message in the interpreter as needed.
 *
 *-----------------------------------------------------------------------------
 */

static int
CheckForThrowInWrongContext(AssemblyEnv* assemEnvPtr)
				/* Assembler environment */
{
    BasicBlock* blockPtr;	/* Current basic block */

    /* 
     * Walk through the basic blocks in turn, checking all the ones
     * that have caught an exception and not disposed of it properly.
     */

    for (blockPtr = assemEnvPtr->head_bb;
	 blockPtr != NULL;
	 blockPtr = blockPtr->successor1) {

	if (blockPtr->catchState == BBCS_CAUGHT) {

	    /* Walk through the instructions in the basic block */

	    if (CheckNonThrowingBlock(assemEnvPtr, blockPtr) != TCL_OK) {
		return TCL_ERROR;
	    }
	    
	}
    }
    return TCL_OK;
}

/*
 *-----------------------------------------------------------------------------
 *
 * CheckNonThrowingBlock --
 *
 *	Check that a basic block cannot throw an exception.
 *
 * Results:
 *	Returns TCL_ERROR if the block cannot be proven to be nonthrowing.
 *
 * Side effects:
 *	Stashes an error message in the interpreter result.
 *
 *-----------------------------------------------------------------------------
 */

static int
CheckNonThrowingBlock(AssemblyEnv* assemEnvPtr,
				/* Assembler environment */
		      BasicBlock* blockPtr)
				/* Basic block where exceptions are
				 * not allowed */
{
    CompileEnv* envPtr = assemEnvPtr->envPtr;
				/* Compilation environment */
    Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
				/* Tcl interpreter */
    BasicBlock* nextPtr;	/* Pointer to the succeeding basic block */
    int offset;			/* Bytecode offset of the current instruction */
    int bound;			/* Bytecode offset following the last
				 * instruction of the block. */
    unsigned char opcode;	/* Current bytecode instruction */
    Tcl_Obj* retval;		/* Error message */

    /* Determine where in the code array the basic block ends */
    
    nextPtr = blockPtr->successor1;
    if (nextPtr == NULL) {
	bound = envPtr->codeNext - envPtr->codeStart;
    } else {
	bound = nextPtr->startOffset;
    }

    /* Walk through the instructions of the block */

    offset = blockPtr->startOffset;
    while (offset < bound) {

	/* Determine whether an instruction is nonthrowing */
	
	opcode = (envPtr->codeStart)[offset];

	if (BytecodeMightThrow(opcode)) {

	    /* Report an error for a throw in the wrong context */

	    if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
		retval = Tcl_NewStringObj("\"", -1);
		Tcl_AppendToObj(retval, tclInstructionTable[opcode].name,
				-1);
		Tcl_AppendToObj(retval, "\" instruction may not appear in "
				"a context where an exception has been "
				"caught and not disposed of.", -1);
		Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADTHROW", NULL);
		Tcl_SetObjResult(interp, retval);
		AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr);
	    }
	    return TCL_ERROR;
	}
	offset += tclInstructionTable[opcode].numBytes;
    }
    return TCL_OK;
}

/*
 *-----------------------------------------------------------------------------
 *
 * BytecodeMightThrow --
 *
 *	Tests if a given bytecode instruction might throw an exception.
 *
 * Results:
 *	Returns 1 if the bytecode might throw an exception, 0 if the
 *	instruction is known never to throw.
 *
 *-----------------------------------------------------------------------------
 */

static int
BytecodeMightThrow(unsigned char opcode)
{

    /* Binary search on the non-throwing bytecode list */

    int min = 0;
    int max = sizeof(NonThrowingByteCodes)-1;
    int mid;
    unsigned char c;
    while (max >= min) {
	mid = (min + max) / 2;
	c = NonThrowingByteCodes[mid];
	if (opcode < c) {
	    max = mid-1;
	} else if (opcode > c) {
	    min = mid+1;
	} else {

	    /* Opcode is nonthrowing */

	    return 0;
	}
    }

    return 1;
}

/*
 *-----------------------------------------------------------------------------
 *
 * CheckStack --
 *
 *	Audit stack usage in a block of assembly code.
 *
 * Results:
 *	Returns a standard Tcl result.
 *
 * Side effects:
 *	Updates stack depth on entry for all basic blocks in the flowgraph.
 *	Calculates the max stack depth used in the program, and updates the
 *	compilation environment to reflect it.
 *
 *-----------------------------------------------------------------------------
 */

static int
CheckStack(AssemblyEnv* assemEnvPtr)
				/* Assembly environment */
{
    CompileEnv* envPtr = assemEnvPtr->envPtr;
				/* Compilation environment */
    int maxDepth;		/* Maximum stack depth overall */

    /* Checking the head block will check all the other blocks recursively. */

    assemEnvPtr->maxDepth = 0;
    if (StackCheckBasicBlock(assemEnvPtr,
			    assemEnvPtr->head_bb, NULL, 0) == TCL_ERROR) {
        return TCL_ERROR;
    }

    /* Post the max stack depth back to the compilation environment */

    maxDepth = assemEnvPtr->maxDepth + envPtr->currStackDepth;
    if (maxDepth > envPtr->maxStackDepth) {
	envPtr->maxStackDepth = maxDepth;
    }

    /* If the exit is reachable, make sure that the program exits with
     * 1 operand on the stack. */

    if (StackCheckExit(assemEnvPtr) != TCL_OK) {
	return TCL_ERROR;
    }

    /* Reset the visited state on all basic blocks */

    ResetVisitedBasicBlocks(assemEnvPtr);

    return TCL_OK;
}

/*
 *-----------------------------------------------------------------------------
 *
 * StackCheckBasicBlock --
 *
 *	Checks stack consumption for a basic block (and recursively for
 *	its successors).
 *
 * Results:
 *	Returns a standard Tcl result.
 *
 * Side effects:
 *	Updates initial stack depth for the basic block and its
 *	successors. (Final and maximum stack depth are relative to
 *	initial, and are not touched).
 *
 * This procedure eventually checks, for the entire flow graph, whether
 * stack balance is consistent.  It is an error for a given basic block
 * to be reachable along multiple flow paths with different stack depths.
 *
 *-----------------------------------------------------------------------------
 */

static int
StackCheckBasicBlock(AssemblyEnv* assemEnvPtr,
				/* Assembly environment */
		     BasicBlock* blockPtr,
				/* Pointer to the basic block being checked */
		     BasicBlock* predecessor,
				/* Pointer to the block that passed control
				 * to this one. */
		     int initialStackDepth) 
				/* Stack depth on entry to the block */
{
    CompileEnv* envPtr = assemEnvPtr->envPtr;
				/* Compilation environment */
    Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
				/* Tcl interpreter */
    BasicBlock* jumpTarget;	/* Basic block where a jump goes */
    int stackDepth;		/* Current stack depth */
    int maxDepth;		/* Maximum stack depth so far */
    int result;			/* Tcl status return */
    Tcl_HashSearch jtSearch;	/* Search structure for the jump table */
    Tcl_HashEntry* jtEntry;	/* Hash entry in the jump table */
    Tcl_Obj* targetLabel;	/* Target label from the jump table */
    Tcl_HashEntry* entry;	/* Hash entry in the label table */

    if (blockPtr->flags & BB_VISITED) {

	/* 
	 * If the block is already visited, check stack depth for consistency
	 * among the paths that reach it.
	 */
        if (blockPtr->initialStackDepth != initialStackDepth) {
	    if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
		Tcl_SetObjResult(interp,
				 Tcl_NewStringObj("inconsistent stack depths "
						  "on two execution paths",
						  -1));
		/* TODO - add execution trace of both paths */
		Tcl_SetErrorLine(interp, blockPtr->startLine);
		Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL);
	    }
            return TCL_ERROR;
        } else {
            return TCL_OK;
        }
    }

    /*
     * If the block is not already visited, set the 'predecessor'
     * link to indicate how control got to it. Set the initial stack
     * depth to the current stack depth in the flow of control.
     */
    blockPtr->flags |= BB_VISITED;
    blockPtr->predecessor = predecessor;
    blockPtr->initialStackDepth = initialStackDepth;

    /* 
     * Calculate minimum stack depth, and flag an error if the block
     * underflows the stack.
     */
    if (initialStackDepth + blockPtr->minStackDepth < 0) {
	if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
	    Tcl_SetObjResult(interp,
			     Tcl_NewStringObj("stack underflow", -1));
	    Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL);
	    AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr);
	    Tcl_SetErrorLine(interp, blockPtr->startLine);
	}
	return TCL_ERROR;
    }

    /*
     * Make sure that the block doesn't try to pop below the stack level
     * of an enclosing catch.
     */
    if (blockPtr->enclosingCatch != 0
	&& initialStackDepth + blockPtr->minStackDepth
	< (blockPtr->enclosingCatch->initialStackDepth
	   + blockPtr->enclosingCatch->finalStackDepth)) {
	if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
	    Tcl_SetObjResult(interp,
			     Tcl_NewStringObj("code pops stack below level of"
					      " enclosing catch", -1));
	    Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACKINCATCH", -1);
	    AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr);
	    Tcl_SetErrorLine(interp, blockPtr->startLine);
	}
	return TCL_ERROR;
    }

    /*
     * Update maximum stgack depth.
     */
    maxDepth = initialStackDepth + blockPtr->maxStackDepth;
    if (maxDepth > assemEnvPtr->maxDepth) {
	assemEnvPtr->maxDepth = maxDepth;
    }
    
    /*
     * Calculate stack depth on exit from the block, and invoke this
     * procedure recursively to check successor blocks
     */

    stackDepth = initialStackDepth + blockPtr->finalStackDepth;
    result = TCL_OK;
    if (blockPtr->flags & BB_FALLTHRU) {
        result = StackCheckBasicBlock(assemEnvPtr, blockPtr->successor1,
				      blockPtr, stackDepth);        
        
    }
    if (result == TCL_OK && blockPtr->jumpTarget != NULL) {
	entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
				  Tcl_GetString(blockPtr->jumpTarget));
	jumpTarget = (BasicBlock*) Tcl_GetHashValue(entry);
        result = StackCheckBasicBlock(assemEnvPtr, jumpTarget,
				      blockPtr, stackDepth);
    }

    /* All blocks referenced in a jump table are successors */

    if (blockPtr->flags & BB_JUMPTABLE) {
	for (jtEntry = Tcl_FirstHashEntry(&(blockPtr->jtPtr->hashTable),
					  &jtSearch);
	     result == TCL_OK && jtEntry != NULL;
	     jtEntry = Tcl_NextHashEntry(&jtSearch)) {
	    targetLabel = (Tcl_Obj*) Tcl_GetHashValue(jtEntry);
	    entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
				      Tcl_GetString(targetLabel));
	    jumpTarget = (BasicBlock*) Tcl_GetHashValue(entry);
	    result = StackCheckBasicBlock(assemEnvPtr, jumpTarget,
					  blockPtr, stackDepth);
	}
    }
	    
    return result;
}

/*
 *-----------------------------------------------------------------------------
 *
 * StackCheckExit --
 *
 *	Makes sure that the net stack effect of an entire assembly language
 *	script is to push 1 result.
 *
 * Results:
 *	Returns a standard Tcl result, with an error message in the interpreter
 *	result if the stack is wrong.
 *
 * Side effects:
 *	If the assembly code had a net stack effect of zero, emits code
 *	to the concluding block to push a null result. In any case, 
 *	updates the stack depth in the compile environment to reflect
 * 	the net effect of the assembly code.
 *
 *-----------------------------------------------------------------------------
 */

static int
StackCheckExit(AssemblyEnv* assemEnvPtr)
				/* Assembler environment */
{

    CompileEnv* envPtr = assemEnvPtr->envPtr;
				/* Compilation environment */
    Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
				/* Tcl interpreter */
    int depth;			/* Net stack effect */
    int litIndex;		/* Index in the literal pool of the empty 
				 * string */
    Tcl_Obj* depthObj;		/* Net stack effect for an error message */
    Tcl_Obj* resultObj;		/* Error message from this procedure */
    BasicBlock* curr_bb = assemEnvPtr->curr_bb;
				/* Final basic block in the assembly */

    /* 
     * Don't perform these checks if execution doesn't reach the
     * exit (either because of an infinite loop or because the only
     * return is from the middle. 
     */

    if (curr_bb->flags & BB_VISITED) {

    	/* Exit with no operands; push an empty one. */

    	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(assemEnvPtr, 0, litIndex, 0);
    	    ++depth;
    	}

    	/* Exit with unbalanced stack */

    	if (depth != 1) {
    	    if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
    		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);
    		Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL);
    	    }
    	    return TCL_ERROR;
    	}

    	/* Record stack usage */

    	envPtr->currStackDepth += depth;
    }

    return TCL_OK;
}

/*
 *-----------------------------------------------------------------------------
 *
 * ProcessCatches --
 *
 *	First pass of 'catch' processing. 
 *
 * Results:
 *	Returns a standard Tcl result, with an appropriate error message
 *	if the result is TCL_ERROR.
 *
 * Side effects:
 *	Labels all basic blocks with their enclosing catches.
 *
 *-----------------------------------------------------------------------------
 */

static int
ProcessCatches(AssemblyEnv* assemEnvPtr)
				/* Assembler environment */
{
    BasicBlock* blockPtr;	/* Pointer to a basic block */

    /*
     * Clear the catch state of all basic blocks
     */

    for (blockPtr = assemEnvPtr->head_bb;
	 blockPtr != NULL;
	 blockPtr = blockPtr->successor1) {
	blockPtr->catchState = BBCS_UNKNOWN;
	blockPtr->enclosingCatch = NULL;
    }

    /* 
     * Start the check recursively from the first basic block, which
     * is outside any exception context 
     */

    if (ProcessCatchesInBasicBlock(assemEnvPtr, assemEnvPtr->head_bb,
				   NULL, BBCS_NONE, 0) != TCL_OK) {
	return TCL_ERROR;
    }

    /* Check for unclosed catch on exit */

    if (CheckForUnclosedCatches(assemEnvPtr) != TCL_OK) {
	return TCL_ERROR;
    }

    /* Now there's enough information to build the exception ranges. */

    if (BuildExceptionRanges(assemEnvPtr) != TCL_OK) {
	return TCL_ERROR;
    }

    /* Finally, restore any exception ranges from embedded scripts */

    RestoreEmbeddedExceptionRanges(assemEnvPtr);

    return TCL_OK;
}

/*
 *-----------------------------------------------------------------------------
 *
 * ProcessCatchesInBasicBlock --
 *
 *	First-pass catch processing for one basic block.
 *
 * Results:
 *	Returns a standard Tcl result, with error message in the interpreter
 *	result if an error occurs.
 *
 * This procedure checks consistency of the exception context through the
 * assembler program, and records the enclosing 'catch' for every basic
 * block.
 *
 *-----------------------------------------------------------------------------
 */

static int
ProcessCatchesInBasicBlock(AssemblyEnv* assemEnvPtr,
				/* Assembler environment */
			   BasicBlock* bbPtr,
				/* Basic block being processed */
			   BasicBlock* enclosing,
				/* Start basic block of the enclosing catch */
			   enum BasicBlockCatchState state,
				/* BBCS_NONE, BBCS_INCATCH, or BBCS_CAUGHT */
			   int catchDepth)
				/* Depth of nesting of catches */
{
    CompileEnv* envPtr = assemEnvPtr->envPtr;
				/* Compilation environment */
    Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
				/* Tcl interpreter */
    int result;			/* Return value from this procedure */
    BasicBlock* fallThruEnclosing;
				/* Enclosing catch if execution falls thru */
    enum BasicBlockCatchState fallThruState;
				/* Catch state of the successor block */
    BasicBlock* jumpEnclosing;
				/* Enclosing catch if execution goes to
				 * jump target */
    enum BasicBlockCatchState jumpState;
				/* Catch state of the jump target */
    int changed = 0;		/* Flag == 1 iff successor blocks need
				 * to be checked because the state of this
				 * block has changed. */
    BasicBlock* jumpTarget;	/* Basic block where a jump goes */
    Tcl_HashSearch jtSearch;	/* Hash search control for a jumptable */
    Tcl_HashEntry* jtEntry;	/* Entry in a jumptable */
    Tcl_Obj* targetLabel;	/* Target label from a jumptable */
    Tcl_HashEntry* entry;	/* Entry from the label table */

    /* 
     * Update the state of the current block, checking for consistency.
     * Set 'changed' to 1 if the state changes and successor blocks
     * need to be rechecked.
     */

    if (bbPtr->catchState == BBCS_UNKNOWN) {
	bbPtr->enclosingCatch = enclosing;
    } else if (bbPtr->enclosingCatch != enclosing) {
	if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
	    Tcl_SetObjResult(interp,
			     Tcl_NewStringObj("execution reaches an "
					      "instruction in "
					      "inconsistent exception contexts",
					      -1));
	    Tcl_SetErrorLine(interp, bbPtr->startLine);
	    Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADCATCH", NULL);
	}
	return TCL_ERROR;
    } 
    if (state > bbPtr->catchState) {
	bbPtr->catchState = state;
	changed = 1;
    }

    /* 
     * If this block has been visited before, and its state hasn't
     * changed, we're done with it for now.
     */

    if (!changed) {
	return TCL_OK;
    }
    bbPtr->catchDepth = catchDepth;

    /*
     * Determine enclosing catch and 'caught' state for the fallthrough
     * and the jump target. Default for both is the state of the current block.
     */

    fallThruEnclosing = enclosing;
    fallThruState = state;
    jumpEnclosing = enclosing;
    jumpState = state;

    /* TODO: Make sure that the test cases include validating
     *       that a natural loop can't include 'beginCatch' or 'endCatch' */

    if (bbPtr->flags & BB_BEGINCATCH) {
	/* 
	 * If the block begins a catch, the state for the successor is
	 * 'in catch'. The jump target is the exception exit, and the state
	 * of the jump target is 'caught.'
	 */
	fallThruEnclosing = bbPtr;
	fallThruState = BBCS_INCATCH;
	jumpEnclosing = bbPtr;
	jumpState = BBCS_CAUGHT;
	++catchDepth;
    } 

    if (bbPtr->flags & BB_ENDCATCH) {
	/*
	 * If the block ends a catch, the state for the successor is
	 * whatever the state was on entry to the catch.
	 */
	if (enclosing == NULL) {
	    if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
		Tcl_SetObjResult(interp,
				 Tcl_NewStringObj("endCatch without a "
						  "corresponding beginCatch",
						  -1));
		Tcl_SetErrorLine(interp, bbPtr->startLine);
		Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADENDCATCH", NULL);
	    }
	    return TCL_ERROR;
	}
	fallThruEnclosing = enclosing->enclosingCatch;
	fallThruState = enclosing->catchState;
	--catchDepth;
    }

    /*
     * Visit any successor blocks with the appropriate exception context
     */

    result = TCL_OK;
    if (bbPtr->flags & BB_FALLTHRU) {
        result = ProcessCatchesInBasicBlock(assemEnvPtr, bbPtr->successor1,
					    fallThruEnclosing, fallThruState,
					    catchDepth);        
    }
    if (result == TCL_OK && bbPtr->jumpTarget != NULL) {
	entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
				  Tcl_GetString(bbPtr->jumpTarget));
	jumpTarget = (BasicBlock*) Tcl_GetHashValue(entry);
        result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget,
					    jumpEnclosing, jumpState,
					    catchDepth);
    }
    
    /* All blocks referenced in a jump table are successors */

    if (bbPtr->flags & BB_JUMPTABLE) {
	for (jtEntry = Tcl_FirstHashEntry(&(bbPtr->jtPtr->hashTable),
					  &jtSearch);
	     result == TCL_OK && jtEntry != NULL;
	     jtEntry = Tcl_NextHashEntry(&jtSearch)) {
	    targetLabel = (Tcl_Obj*) Tcl_GetHashValue(jtEntry);
	    entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
				      Tcl_GetString(targetLabel));
	    jumpTarget = (BasicBlock*) Tcl_GetHashValue(entry);
	    result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget,
						jumpEnclosing, jumpState,
						catchDepth);
	}
    }
	    
    return result;
}

/*
 *-----------------------------------------------------------------------------
 *
 * CheckForUnclosedCatches -- 
 *
 *	Checks that a sequence of assembly code has no unclosed catches
 *	on exit.
 *
 * Results:
 *	Returns a standard Tcl result, with an error message for unclosed
 *	catches.
 *
 *-----------------------------------------------------------------------------
 */

static int
CheckForUnclosedCatches(AssemblyEnv* assemEnvPtr)
{
    CompileEnv* envPtr = assemEnvPtr->envPtr;
				/* Compilation environment */
    Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
				/* Tcl interpreter */

    if (assemEnvPtr->curr_bb->catchState >= BBCS_INCATCH) {
	if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj("catch still active on "
						      "exit from assembly "
						      "code", -1));
	    Tcl_SetErrorLine(interp,
			     assemEnvPtr->curr_bb->enclosingCatch->startLine);
	    Tcl_SetErrorCode(interp, "TCL", "ASSEM", "UNCLOSEDCATCH", NULL);
	}
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *-----------------------------------------------------------------------------
 *
 * BuildExceptionRanges --
 *
 *	Walks through the assembly code and builds exception ranges for
 *	the catches embedded therein.
 *
 * Results:
 *	Returns a standard Tcl result with an error message in the interpreter
 *	if anything is unsuccessful.
 *
 * Side effects:
 *	Each contiguous block of code with a given catch exit is assigned
 *	an exception range at the appropriate level.
 *	Exception ranges in embedded blocks have their levels corrected
 *	and collated into the table.
 *	Blocks that end with 'beginCatch' are associated with the innermost
 *	exception range of the following block.
 *
 *-----------------------------------------------------------------------------
 */

static int
BuildExceptionRanges(AssemblyEnv* assemEnvPtr)
				/* Assembler environment */
{
    CompileEnv* envPtr = assemEnvPtr->envPtr;
				/* Compilation environment */
    BasicBlock* bbPtr;		/* Current basic block */
    BasicBlock* prevPtr = NULL;	/* Previous basic block */
    int catchDepth = 0;		/* Current catch depth */
    int maxCatchDepth= 0;	/* Maximum catch depth in the program */
    BasicBlock** catches;	/* Stack of catches in progress */
    int* catchIndices;		/* Indices of the exception ranges
				 * of catches in progress */
    int i;

    /* 
     * Determine the max catch depth for the entire assembly script
     * (excluding embedded eval's and expr's, which will be handled later).
     */
    for (bbPtr = assemEnvPtr->head_bb; bbPtr != NULL; bbPtr=bbPtr->successor1) {
	if (bbPtr->catchDepth > maxCatchDepth) {
	    maxCatchDepth = bbPtr->catchDepth;
	}
    }

    /* Allocate memory for a stack of active catches */

    catches = (BasicBlock**) ckalloc(maxCatchDepth * sizeof(BasicBlock*));
    catchIndices = (int*) ckalloc(maxCatchDepth * sizeof(int));
    for (i = 0; i < maxCatchDepth; ++i) {
	catches[i] = NULL;
	catchIndices[i] = -1;
    }

    /* Walk through the basic blocks and manage exception ranges. */

    for (bbPtr = assemEnvPtr->head_bb; bbPtr != NULL; bbPtr=bbPtr->successor1) {

	UnstackExpiredCatches(envPtr, bbPtr, catchDepth,
			      catches, catchIndices);
	LookForFreshCatches(bbPtr, catches);
	StackFreshCatches(assemEnvPtr, bbPtr, catchDepth,
			  catches, catchIndices);

	/* If the last block was a 'begin catch', fill in the exception range */

	catchDepth = bbPtr->catchDepth;
	if (prevPtr != NULL
	    && (prevPtr->flags & BB_BEGINCATCH)) {
	    TclStoreInt4AtPtr(catchIndices[catchDepth-1],
			      envPtr->codeStart + bbPtr->startOffset - 4);
	}

	prevPtr = bbPtr;
    }

    if (catchDepth != 0) {
	Tcl_Panic("unclosed catch at end of code in "
		  "tclAssembly.c:BuildExceptionRanges, can't happen");
    }

    return TCL_OK;
}

/*
 *-----------------------------------------------------------------------------
 *
 * UnstackExpiredCatches --
 *
 *	Unstacks and closes the exception ranges for any catch contexts that
 *	were active in the previous basic block but are inactive in the
 *	current one.
 *
 *-----------------------------------------------------------------------------
 */

static void
UnstackExpiredCatches(CompileEnv* envPtr,
				/* Compilation environment */
		      BasicBlock* bbPtr,
				/* Basic block being processed */
		      int catchDepth,
				/* Depth of nesting of catches prior to
				 * entry to this block */
		      BasicBlock** catches,
				/* Array of catch contexts */
		      int* catchIndices)
				/* Indices of the exception ranges 
				 * corresponding to the catch contexts */
{

    ExceptionRange* range;	/* Exception range for a specific catch */
    BasicBlock* catch;		/* Catch block being examined */
    BasicBlockCatchState catchState;
				/* State of the code relative to
				 * the catch block being examined 
				 * ("in catch" or "caught") */

    /* 
     * Unstack any catches that are deeper than the nesting level of
     * the basic block being entered.
     */
    
    while (catchDepth > bbPtr->catchDepth) {
	--catchDepth;
	range = envPtr->exceptArrayPtr + catchIndices[catchDepth];
	range->numCodeBytes = bbPtr->startOffset - range->codeOffset;
	catches[catchDepth] = NULL;
	catchIndices[catchDepth] = -1;
    }

    /* 
     * Unstack any catches that don't match the basic block being entered,
     * either because they are no longer part of the context, or because
     * the context has changed from INCATCH to CAUGHT.
     */
    
    catchState = bbPtr->catchState;
    catch = bbPtr->enclosingCatch;
    while (catchDepth > 0) {
	--catchDepth;
	if (catches[catchDepth] != NULL) {
	    if (catches[catchDepth] != catch
		|| catchState >= BBCS_CAUGHT) {
		range = envPtr->exceptArrayPtr + catchIndices[catchDepth];
		range->numCodeBytes = bbPtr->startOffset - range->codeOffset;
		catches[catchDepth] = NULL;
		catchIndices[catchDepth] = -1;
	    }
	    catchState = catch->catchState;
	    catch = catch->enclosingCatch;
	}
    }
}

/*
 *-----------------------------------------------------------------------------
 *
 * LookForFreshCatches --
 *
 *	Determines whether a basic block being entered needs any exception
 *	ranges that are not already stacked.
 *
 * Does not create the ranges: this procedure iterates from the innermost
 * catch outward, but exception ranges must be created from the outermost
 * catch inward.
 *
 *-----------------------------------------------------------------------------
 */

static void
LookForFreshCatches(BasicBlock* bbPtr,
				/* Basic block being entered */
		    BasicBlock** catches)
				/* Array of catch contexts that are
				 * already entered */
{
    BasicBlockCatchState catchState;
				/* State ("in catch" or "caught" of
				 * the current catch. */
    BasicBlock* catch;		/* Current enclosing catch */
    int catchDepth;		/* Nesting depth of the current catch */

    catchState = bbPtr->catchState;
    catch = bbPtr->enclosingCatch;
    catchDepth = bbPtr->catchDepth;
    while (catchDepth > 0) {
	--catchDepth;
	if (catches[catchDepth] != catch && catchState < BBCS_CAUGHT) {
	    catches[catchDepth] = catch;
	}
	catchState = catch->catchState;
	catch = catch->enclosingCatch;
    }
}

/*
 *-----------------------------------------------------------------------------\ *
 * StackFreshCatches --
 *
 *	Make ExceptionRange records for any catches that are in the
 *	basic block being entered and were not in the previous basic block.
 *
 *-----------------------------------------------------------------------------
 */

static void
StackFreshCatches(AssemblyEnv* assemEnvPtr,
				/* Assembly environment */
		  BasicBlock* bbPtr,
				/* Basic block being processed */
		  int catchDepth,
				/* Depth of nesting of catches prior to
				 * entry to this block */
		  BasicBlock** catches,
				/* Array of catch contexts */
		  int* catchIndices)
				/* Indices of the exception ranges 
				 * corresponding to the catch contexts */
{
    CompileEnv* envPtr = assemEnvPtr->envPtr;
				/* Compilation environment */
    ExceptionRange* range;	/* Exception range for a specific catch */
    BasicBlock* catch;		/* Catch block being examined */
    BasicBlock* errorExit;	/* Error exit from the catch block */
    Tcl_HashEntry* entryPtr;

    catchDepth = 0;

    /*
     * Iterate through the enclosing catch blocks from the outside in,
     * looking for ones that don't have exception ranges (and are uncaught)
     */

    for (catchDepth = 0; catchDepth < bbPtr->catchDepth; ++catchDepth) {
	if (catchIndices[catchDepth] == -1  && catches[catchDepth] != NULL) {

	    /* Create an exception range for a block that needs one. */

	    catch = catches[catchDepth];
	    catchIndices[catchDepth] =
		TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
	    range = envPtr->exceptArrayPtr + catchIndices[catchDepth];
	    range->nestingLevel = envPtr->exceptDepth + catchDepth;
	    envPtr->maxExceptDepth =
		TclMax(range->nestingLevel + 1, envPtr->maxExceptDepth);
	    range->codeOffset = bbPtr->startOffset;
	    
	    if ((entryPtr =
		 Tcl_FindHashEntry(&assemEnvPtr->labelHash,
				   Tcl_GetString(catch->jumpTarget)))
		== NULL) {
		Tcl_Panic("undefined label in tclAssembly.c:"
			  "BuildExceptionRanges, can't happen");
	    } else {
		errorExit = (BasicBlock*) Tcl_GetHashValue(entryPtr);
		range->catchOffset = errorExit->startOffset;
	    }
	}
    }
}

/*
 *-----------------------------------------------------------------------------
 *
 * RestoreEmbeddedExceptionRanges --
 *
 *	Processes an assembly script, replacing any exception ranges that
 *	were present in embedded code.
 *
 *-----------------------------------------------------------------------------
 */

static void
RestoreEmbeddedExceptionRanges(AssemblyEnv* assemEnvPtr)
				/* Assembler environment */
{
    CompileEnv* envPtr = assemEnvPtr->envPtr;
				/* Compilation environment */
    BasicBlock* bbPtr;		/* Current basic block */
    int rangeBase;		/* Base of the foreign exception ranges
				 * when they are reinstalled */
    int rangeIndex;		/* Index of the current foreign exception
				 * range as reinstalled */
    ExceptionRange* range;      /* Current foreign exception range */
    unsigned char opcode;	/* Current instruction's opcode */
    unsigned int catchIndex;	/* Index of the exception range to which
				 * the current instruction refers */
    int i;

    /* Walk the basic blocks looking for exceptions in embedded scripts */

    for (bbPtr = assemEnvPtr->head_bb;
	 bbPtr != NULL;
	 bbPtr = bbPtr->successor1) {
	if (bbPtr->foreignExceptionCount != 0) {
	    /* 
	     * Reinstall the embedded exceptions and track their 
	     * nesting level 
	     */
	    rangeBase = envPtr->exceptArrayNext;
	    for (i = 0; i < bbPtr->foreignExceptionCount; ++i) {
		range = bbPtr->foreignExceptions + i;
		rangeIndex = TclCreateExceptRange(range->type, envPtr);
		range->nestingLevel += envPtr->exceptDepth + bbPtr->catchDepth;
		memcpy(envPtr->exceptArrayPtr + rangeIndex, range,
		       sizeof(ExceptionRange));
		if (range->nestingLevel >= envPtr->maxExceptDepth) {
		    envPtr->maxExceptDepth = range->nestingLevel + 1;
		}
	    }

	    /*
	     * Walk through the bytecode of the basic block, and relocate
	     * INST_BEGIN_CATCH4 instructions to the new locations
	     */
	    i = bbPtr->startOffset;
	    while (i < bbPtr->successor1->startOffset) {
		opcode = envPtr->codeStart[i];
		if (opcode == INST_BEGIN_CATCH4) {
		    catchIndex = TclGetUInt4AtPtr(envPtr->codeStart + i + 1);
		    if (catchIndex >= bbPtr->foreignExceptionBase
			&& catchIndex < (bbPtr->foreignExceptionBase +
					 bbPtr->foreignExceptionCount)) {
			catchIndex -= bbPtr->foreignExceptionBase;
			catchIndex += rangeBase;
			TclStoreInt4AtPtr(catchIndex,
					  envPtr->codeStart + i + 1);
		    }
		}
		i += tclInstructionTable[opcode].numBytes;
	    }
	}
    }

}

/*
 *-----------------------------------------------------------------------------
 *
 * ResetVisitedBasicBlocks --
 *
 *	Turns off the 'visited' flag in all basic blocks at the conclusion
 *	of a pass.
 *
 *-----------------------------------------------------------------------------
 */

static void
ResetVisitedBasicBlocks(AssemblyEnv* assemEnvPtr)
{
    BasicBlock* block;
    for (block = assemEnvPtr->head_bb; block != NULL; 
	 block = block->successor1) {
	block->flags &= ~BB_VISITED;
    }
}

/*
 *-----------------------------------------------------------------------------
 *
 * AddBasicBlockRangeToErrorInfo --
 *
 *	Updates the error info of the Tcl interpreter to show a given
 *	basic block in the code.
 *
 * This procedure is used to label the callstack with source location
 * information when reporting an error in stack checking.
 *
 *-----------------------------------------------------------------------------
 */

static void
AddBasicBlockRangeToErrorInfo(AssemblyEnv* assemEnvPtr,
				/* Assembly environment */
			      BasicBlock* bbPtr)
				/* Basic block in which the error is
				 * found */
{
    CompileEnv* envPtr = assemEnvPtr->envPtr;
				/* Compilation environment */
    Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
				/* Tcl interpreter */
    Tcl_Obj* lineNo;		/* Line number in the source */

    Tcl_AddErrorInfo(interp, "\n    in assembly code between lines ");
    lineNo = Tcl_NewIntObj(bbPtr->startLine);
    Tcl_IncrRefCount(lineNo);
    Tcl_AddErrorInfo(interp, Tcl_GetString(lineNo));
    Tcl_AddErrorInfo(interp, " and ");
    if (bbPtr->successor1 != NULL) {
	Tcl_SetIntObj(lineNo, bbPtr->successor1->startLine);
	Tcl_AddErrorInfo(interp, Tcl_GetString(lineNo));
    } else {
	Tcl_AddErrorInfo(interp, "end of assembly code");
    }
    Tcl_DecrRefCount(lineNo);
}

/*
 *-----------------------------------------------------------------------------
 *
 * DupAssembleCodeInternalRep --
 *
 *	Part of the Tcl object type implementation for Tcl assembly language
 *	bytecode. We do not copy the bytecode intrep. Instead, we return
 *	without setting copyPtr->typePtr, so the copy is a plain string copy
 *	of the assembly source, and if it is to be used as a compiled
 *	expression, it will need to be reprocessed.
 *
 *	This makes sense, because with Tcl's copy-on-write practices, the
 *	usual (only?) time Tcl_DuplicateObj() will be called is when the copy
 *	is about to be modified, which would invalidate any copied bytecode
 *	anyway. The only reason it might make sense to copy the bytecode is if
 *	we had some modifying routines that operated directly on the intrep,
 *	as we do for lists and dicts.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *-----------------------------------------------------------------------------
 */
  
static void
DupAssembleCodeInternalRep(
    Tcl_Obj *srcPtr,
    Tcl_Obj *copyPtr)
{
    return;
}

/*
 *-----------------------------------------------------------------------------
 *
 * 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;
}
	    

     */

    Tcl_CreateObjCommand(interp, "::tcl::unsupported::disassemble",
	    Tcl_DisassembleObjCmd, NULL, NULL);
    Tcl_CreateObjCommand(interp, "::tcl::unsupported::representation",
	    Tcl_RepresentationCmd, NULL, NULL);

    /* Adding the bytecode assembler command */
    cmdPtr = (Command*)
        Tcl_NRCreateCommand(interp, "::tcl::unsupported::assemble",
                            Tcl_AssembleObjCmd, TclNRAssembleObjCmd,
                            NULL, NULL);
    cmdPtr->compileProc = &TclCompileAssembleCmd;

    Tcl_NRCreateCommand(interp, "::tcl::unsupported::yieldTo", NULL,
	    TclNRYieldToObjCmd, NULL, NULL);
    Tcl_NRCreateCommand(interp, "::tcl::unsupported::yieldm", NULL,
	    TclNRYieldObjCmd, INT2PTR(CORO_ACTIVATE_YIELDM), NULL);
    Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL,
	    NRCoroInjectObjCmd, NULL, NULL);
    

     * result, and jump around the "error case" code.
     */

    PushLiteral(envPtr, "0", 1);
    TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
    /* Stack at this point: ?script? <mark> result TCL_OK */

    /*
     * Emit the "error case" epilogue. Push the interpreter result
     * and the return code.
     */

    envPtr->currStackDepth = savedStackDepth;
    ExceptionRangeTarget(envPtr, range, catchOffset);
    /* Stack at this point:  ?script? */

     */

    if (cmdTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
	TclEmitInstInt4(INST_REVERSE, 2, envPtr);
	TclEmitOpcode(INST_POP, envPtr);
    }

    /*
     * Result of all this, on either branch, should have been to leave
     * one operand -- the return code -- on the stack.
     */

    if (envPtr->currStackDepth != initStackDepth + 1) {
	Tcl_Panic("in TclCompileCatchCmd, currStackDepth = %d should be %d",
		  envPtr->currStackDepth, initStackDepth+1);

MODULE_SCOPE int	TclDefaultBgErrorHandlerObjCmd(
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
MODULE_SCOPE Tcl_Command TclInitDictCmd(Tcl_Interp *interp);
MODULE_SCOPE int	Tcl_DisassembleObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
			    
/* Assemble command function */			    
MODULE_SCOPE int	Tcl_AssembleObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);			    
MODULE_SCOPE int	TclNRAssembleObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);			    
			    
MODULE_SCOPE int	Tcl_EncodingObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE int	Tcl_EofObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE int	Tcl_ErrorObjCmd(ClientData clientData,

			    struct CompileEnv *envPtr);
MODULE_SCOPE int	TclStreqOpCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE int	TclCompileStreqOpCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, Command *cmdPtr,
			    struct CompileEnv *envPtr);
			    
MODULE_SCOPE int	TclCompileAssembleCmd(Tcl_Interp *interp,
			    Tcl_Parse *parsePtr, Command *cmdPtr,
			    struct CompileEnv *envPtr);

/*
 * Functions defined in generic/tclVar.c and currenttly exported only for use
 * by the bytecode compiler and engine. Some of these could later be placed in
 * the public interface.
 */

     * If we get here, the master interp has been deleted. Allow its
     * destruction with the last matching Tcl_Release.
     */

    Tcl_Release(interp);
    Tcl_Exit(exitCode);
}

#ifndef UNICODE
void
Tcl_Main(
    int argc,			/* Number of arguments. */
    TCHAR **argv,		/* Array of argument strings. */
    Tcl_AppInitProc *appInitProc)
				/* Application-specific initialization

	}
	return;
    }

    /*
     * Ordinary (normal and denormal) values.
     */

    if (*precisionPtr == 0) {
	digits = TclDoubleDigits(value, -1, TCL_DD_SHORTEST,
				 &exponent, &signum, &end);
    } else {
	/*
	 * There are at least two possible interpretations for tcl_precision.
	 *

    GzipHeader header;
    gz_header *headerPtr = NULL;
    Tcl_Obj *obj;

    if (!interp) {
	return TCL_ERROR;
    }

    /*
     * Compressed format is specified by the wbits parameter. See zlib.h for
     * details.
     */

    if (format == TCL_ZLIB_FORMAT_RAW) {
	wbits = WBITS_RAW;

# this file, and for a DISCLAIMER OF ALL WARRANTIES.

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}
unset -nocomplain x

test append-1.1 {append command} {
    unset -nocomplain x
    list [append x 1 2 abc "long string"] $x
} {{12abclong string} {12abclong string}}
test append-1.2 {append command} {
    set x ""
    list [append x first] [append x second] [append x third] $x

} -body {
    list [catch {
	append ::env(__DUMMY__) "new value"
    } msg] $msg
} -cleanup {
    unset -nocomplain ::env(__DUMMY__)
} -result {0 {new value}}

unset -nocomplain i x result y
catch {rename foo ""}

# cleanup
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# fill-column: 78
# End:

# this file, and for a DISCLAIMER OF ALL WARRANTIES.

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}
catch {unset x}

test appendComp-1.1 {append command} -setup {
    unset -nocomplain x
} -body {
    proc foo {} {append ::x 1 2 abc "long string"}
    list [foo] $x
} -result {{12abclong string} {12abclong string}}
test appendComp-1.2 {append command} {

    proc foo {} {
	append ::env(__DUMMY__) "new value"
    }
    list [catch { foo } msg] $msg
} -cleanup {
    unset -nocomplain ::env(__DUMMY__)
} -result {0 {new value}}

catch {unset i x result y}
catch {rename foo ""}
catch {rename bar ""}
catch {rename check ""}
catch {rename bar {}}

# cleanup

# assemble.test --
#
#	Test suite for the 'tcl::unsupported::assemble' command
#
# Copyright (c) 2010 by Ozgur Dogan Ugurlu.
# Copyright (c) 2010 by Kevin B. Kenny.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: assemble.test,v 1.1.2.16 2010/12/16 01:40:42 kennykb Exp $
#-----------------------------------------------------------------------------

# Commands covered: assemble

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2.2
    namespace import -force ::tcltest::*
}
namespace eval tcl::unsupported {namespace export assemble}
namespace import tcl::unsupported::assemble

# Procedure to make code that fills the literal and local variable tables,
# to force instructions to spill to four bytes.

proc fillTables {} {
    set s {}
    set sep {}
    for {set i 0} {$i < 256} {incr i} {
	append s $sep [list set v$i literal$i]
	set sep \n
    }
    return $s
}

# assemble-1 - TclNRAssembleObjCmd

test assemble-1.1 {wrong # args, direct eval} {
    -body {
	eval [list assemble]
    }
    -returnCodes error
    -result {wrong # args*}
    -match glob
}

test assemble-1.2 {wrong # args, direct eval} {
    -body {
	eval [list assemble too many]
    }
    -returnCodes error
    -result {wrong # args*}
    -match glob
}

test assemble-1.3 {error reporting, direct eval} {
    -body {
	list [catch {
	    eval [list assemble {
		# bad opcode
		rubbish
	    }]
	} result] $result $errorInfo
    }
    -match glob
    -result {1 {bad instruction "rubbish":*} {bad instruction "rubbish":*
    while executing
"rubbish"
    ("assemble" body, line 3)*}}
    -cleanup {unset result}
}

test assemble-1.4 {simple direct eval} {
    -body {
	eval [list assemble {push {this is a test}}]
    }
    -result {this is a test}
}

# assemble-2 - CompileAssembleObj

test assemble-2.1 {bytecode reuse, direct eval} {
    -body {
	set x {push "this is a test"}
	list [eval [list assemble $x]] \
	    [eval [list assemble $x]]
    }
    -result {{this is a test} {this is a test}}
}

test assemble-2.2 {bytecode discard, direct eval} {
    -body {
	set x {load value}
	proc p1 {x} {
	    set value value1
	    assemble $x
	}
	proc p2 {x} {
	    set a b
	    set value value2
	    assemble $x
	}
	list [p1 $x] [p2 $x]
    }
    -result {value1 value2}
    -cleanup {
	unset x
	rename p1 {}
	rename p2 {}
    }
}

test assemble-2.3 {null script, direct eval} {
    -body {
	set x {}
	assemble $x
    }
    -result {}
    -cleanup {unset x}
}

# assemble-3 - TclCompileAssembleCmd

test assemble-3.1 {wrong # args, compiled path} {
    -body {
	proc x {} {
	    assemble
	}
	x
    }
    -returnCodes error
    -match glob
    -result {wrong # args:*}
}

test assemble-3.2 {wrong # args, compiled path} {
    -body {
	proc x {} {
	    assemble too many
	}
	x
    }
    -returnCodes error
    -match glob
    -result {wrong # args:*}
    -cleanup {
	rename x {}
    }
}

# assemble-4 - TclAssembleCode mainline

test assemble-4.1 {syntax error} {
    -body {
	proc x {} {
	    assemble {
		{}extra
	    }
	}
	list [catch x result] $result $::errorInfo
    }
    -cleanup {
	rename x {}
	unset result
    }
    -match glob
    -result {1 {extra characters after close-brace} {extra characters after close-brace
    while executing
"{}extra
	    "
    ("assemble" body, line 2)*}}
}

test assemble-4.2 {null command} {
    -body {
	proc x {} {
	    assemble {
		push hello; pop;;push goodbye
	    }
	}
	x
    }
    -result goodbye
    -cleanup {
	rename x {}
    }
}

# assemble-5 - GetNextOperand off-nominal cases

test assemble-5.1 {unsupported expansion} {
    -body {
	proc x {y} {
	    assemble {
		{*}$y
	    }
	}
	list [catch {x {push hello}} result] $result $::errorCode
    }
    -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}}
    -cleanup {
	rename x {}
	unset result
    }
}

test assemble-5.2 {unsupported substitution} {
    -body {
	proc x {y} {
	    assemble {
		$y
	    }
	}
	list [catch {x {nop}} result] $result $::errorCode
    }
    -cleanup {
	rename x {}
	unset result
    }
    -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}}
}

test assemble-5.3 {unsupported substitution} {
    -body {
	proc x {} {
	    assemble {
		[x]
	    }
	}
	list [catch {x} result] $result $::errorCode
    }
    -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}}
}

test assemble-5.4 {backslash substitution} {
    -body {
	proc x {} {
	    assemble {
		p\x75sh\
		    hello\ world
	    }
	}
	x
    }
    -cleanup {
	rename x {}
    }
    -result {hello world}
}

# assemble-6 - ASSEM_PUSH

test assemble-6.1 {push, wrong # args} {
    -body {
	assemble push
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-6.2 {push, wrong # args} {
    -body {
	assemble {push too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}


test assemble-6.3 {push} {
    -body {
	eval [list assemble {push hello}]
    }
    -result hello
}

test assemble-6.4 {push4} {
    -body {
	proc x {} "
            [fillTables]
            assemble {push hello}
        "
        x
    }
    -cleanup {
	rename x {}
    }
    -result hello
}

# assemble-7 - ASSEM_1BYTE

test assemble-7.1 {add, wrong # args} {
    -body {
	assemble {add excess}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-7.2 {add} {
    -body { 
	assemble {
	    push 2
	    push 2
	    add
	} 
    }
    -result {4}
}

test assemble-7.3 {appendArrayStk} {
    -body {
	set a(b) {hello, }
	assemble {
	    push a
	    push b
	    push world
	    appendArrayStk
	}
	set a(b)
    }
    -result {hello, world}
    -cleanup {unset a}
}

test assemble-7.4 {appendStk} {
    -body {
	set a {hello, }
	assemble {
	    push a
	    push world
	    appendStk
	}
	set a
    }
    -result {hello, world}
    -cleanup {unset a}
}

test assemble-7.5 {bitwise ops} {
    -body {
	list \
	    [assemble {push 0b1100; push 0b1010; bitand}] \
	    [assemble {push 0b1100; bitnot}] \
	    [assemble {push 0b1100; push 0b1010; bitor}] \
	    [assemble {push 0b1100; push 0b1010; bitxor}]
    }
    -result {8 -13 14 6}
}

test assemble-7.6 {div} {
    -body {
	assemble {push 999999; push 7; div} 
    }
    -result 142857
}

test assemble-7.7 {dup} {
    -body {
	assemble {
	    push 1; dup; dup; add; dup; add; dup; add; add
	}
    }
    -result 9
}	

test assemble-7.8 {eq} {
    -body {
	list \
	    [assemble {push able; push baker; eq}] \
	    [assemble {push able; push able;  eq}]
    }
    -result {0 1}
}


test assemble-7.9 {evalStk} {
    -body {
	assemble {
	    push {concat test 7.3}
	    evalStk
	}
    }
    -result {test 7.3}
}

test assemble-7.9a {evalStk, syntax} {
    -body {
	assemble {
	    push {{}bad}
	    evalStk
	}
    }
    -returnCodes error
    -result {extra characters after close-brace}
}

test assemble-7.9b {evalStk, backtrace} {
    -body {
	proc y {z} {
	    error testing
	}
	proc x {} {
	    assemble {
		push {
		    # test error in evalStk
		    y asd
		}
		evalStk
	    }
	}
	list [catch x result] $result $errorInfo
    }
    -result {1 testing {testing
    while executing
"error testing"
    (procedure "y" line 2)
    invoked from within
"y asd"*}}
    -match glob
    -cleanup {
	rename y {}
	rename x {}
    }
}

test assemble-7.10 {existArrayStk} {
    -body {
	proc x {name key} {
	    set a(b) c
	    assemble {
		load name; load key; existArrayStk
	    }
	}
	list [x a a] [x a b] [x b a] [x b b]
    }
    -result {0 1 0 0}
    -cleanup {rename x {}}
}

test assemble-7.11 {existStk} {
    -body {
	proc x {name} {
	    set a b
	    assemble {
		load name; existStk
	    }
	}
	list [x a] [x b]
    }
    -result {1 0}
    -cleanup {rename x {}}
}

test assemble-7.12 {expon} {
    -body {
	assemble {push 3; push 4; expon}
    }
    -result 81
}

test assemble-7.13 {exprStk} {
    -body {
	assemble {
	    push {acos(-1)}
	    exprStk
	}
    }
    -result 3.141592653589793
}

test assemble-7.13a {exprStk, syntax} {
    -body {
	assemble {
	    push {2+}
	    exprStk
	}
    }
    -returnCodes error
    -result {missing operand at _@_
in expression "2+_@_"}
}

test assemble-7.13b {exprStk, backtrace} {
    -body {
	proc y {z} {
	    error testing
	}
	proc x {} {
	    assemble {
		push {[y asd]}
		exprStk
	    }
	}
	list [catch x result] $result $errorInfo
    }
    -result {1 testing {testing
    while executing
"error testing"
    (procedure "y" line 2)
    invoked from within
"y asd"*}}
    -match glob
    -cleanup {
	rename y {}
	rename x {}
    }
}

test assemble-7.14 {ge gt le lt} {
    -body {
	proc x {a b} {
	    list [assemble {load a; load b; ge}] \
		[assemble {load a; load b; gt}] \
		[assemble {load a; load b; le}] \
		[assemble {load a; load b; lt}]
	}
	list [x 0 0] [x 0 1] [x 1 0]
    }
    -result {{1 0 1 0} {0 0 1 1} {1 1 0 0}}
    -cleanup {rename x {}}
}

test assemble-7.15 {incrArrayStk} {
    -body {
	proc x {} {
	    set a(b) 5
	    assemble {
		push a; push b; push 7; incrArrayStk
	    }
	}
	x
    }
    -result 12
    -cleanup {rename x {}}
}

test assemble-7.16 {incrStk} {
    -body {
	proc x {} {
	    set a 5
	    assemble {
		push a; push 7; incrStk
	    }
	}
	x
    }
    -result 12
    -cleanup {rename x {}}
}

test assemble-7.17 {land/lor} {
    -body {
	proc x {a b} {
	    list \
		[assemble {load a; load b; land}] \
		[assemble {load a; load b; lor}]
	}
	list [x 0 0] [x 0 23] [x 35 0] [x 47 59]
    }
    -result {{0 0} {0 1} {0 1} {1 1}}
    -cleanup {rename x {}}
}

test assemble-7.18 {lappendArrayStk} {
    -body {
	proc x {} {
	    set able(baker) charlie
	    assemble {
		push able
		push baker
		push dog
		lappendArrayStk
	    }
	}
	x
    }
    -result {charlie dog}
    -cleanup {rename x {}}
}

test assemble-7.19 {lappendStk} {
    -body {
	proc x {} {
	    set able baker
	    assemble {
		push able
		push charlie
		lappendStk
	    }
	}
	x
    }
    -result {baker charlie}
    -cleanup {rename x {}}
}

test assemble-7.20 {listIndex} {
    -body {
	assemble {
	    push {a b c d}
	    push 2
	    listIndex
	}
    }
    -result c
}

test assemble-7.21 {listLength} {
    -body {
	assemble {
	    push {a b c d}
	    listLength
	}
    }
    -result 4
}

test assemble-7.22 {loadArrayStk} {
    -body {
	proc x {} {
	    set able(baker) charlie
	    assemble {
		push able
		push baker
		loadArrayStk
	    }
	}
	x
    }
    -result charlie
    -cleanup {rename x {}}
}

test assemble-7.23 {loadStk} {
    -body {
	proc x {} {
	    set able baker
	    assemble {
		push able
		loadStk
	    }
	}
	x
    }
    -result baker
    -cleanup {rename x {}}
}

test assemble-7.24 {lsetList} {
    -body {
	proc x {} {
	    set l {{a b} {c d} {e f} {g h}}
	    assemble {
		push {2 1}; push i; load l; lsetList
	    }
	}
	x
    }
    -result {{a b} {c d} {e i} {g h}}
}

test assemble-7.25 {lshift} {
    -body {
	assemble {push 16; push 4; lshift}
    } 
    -result 256
}

test assemble-7.26 {mod} {
    -body {
	assemble {push 123456; push 1000; mod}
    }
    -result 456
}

test assemble-7.27 {mult} {
    -body {
	assemble {push 12345679; push 9; mult}
    }
    -result 111111111
}

test assemble-7.28 {neq} {
    -body {
	list \
	    [assemble {push able; push baker; neq}] \
	    [assemble {push able; push able;  neq}]
    }
    -result {1 0}
}

test assemble-7.29 {not} {
    -body {
	list \
	    [assemble {push 17; not}] \
	    [assemble {push 0; not}]
    }
    -result {0 1}
}

test assemble-7.30 {pop} {
    -body {
	assemble {push this; pop; push that}
    }
    -result that
}

test assemble-7.31 {rshift} {
    -body {
	assemble {push 257; push 4; rshift}
    } 
    -result 16
}

test assemble-7.32 {storeArrayStk} {
    -body {
	proc x {} {
	    assemble {
		push able; push baker; push charlie; storeArrayStk
	    }
	    array get able
	}
	x
    }
    -result {baker charlie}
    -cleanup {rename x {}}
}

test assemble-7.33 {storeStk} {
    -body {
	proc x {} {
	    assemble {
		push able; push baker; storeStk
	    }
	    set able
	}
	x
    }
    -result {baker}
    -cleanup {rename x {}}
}

test assemble-7,34 {strcmp} {
    -body {
	proc x {a b} {
	    assemble {
		load a; load b; strcmp
	    }
	}
	list [x able baker] [x baker able] [x baker baker]
    }
    -result {-1 1 0}
    -cleanup {rename x {}}
}

test assemble-7.35 {streq/strneq} {
    -body {
	proc x {a b} {
	    list \
		[assemble {load a; load b; streq}] \
		[assemble {load a; load b; strneq}]
	}
	list [x able able] [x able baker]
    }
    -result {{1 0} {0 1}}
    -cleanup {rename x {}}
}

test assemble-7.36 {strindex} {
    -body {
	assemble {push testing; push 4; strindex}
    }
    -result i
}

test assemble-7.37 {strlen} {
    -body {
	assemble {push testing; strlen}
    }
    -result 7
}

test assemble-7.38 {sub} {
    -body {
	assemble {push 42; push 17; sub}
    }
    -result 25
}

test assemble-7.39 {tryCvtToNumeric} {
    -body {
	assemble {
	    push 42; tryCvtToNumeric
	}
    }
    -result 42
}

test assemble-7.41 {uminus} {
    -body {
	assemble {
	    push 42; uminus
	}
    }
    -result -42
}

test assemble-7.42 {uplus} {
    -body {
	assemble {
	    push 42; uplus
	}
    }
    -result 42
}
test assemble-7.43 {uplus} {
    -body {
	assemble {
	    push NaN; uplus
	}
    }
    -returnCodes error
    -result {can't use non-numeric floating-point value as operand of "+"}
}

test assemble-7.43 {tryCvtToNumeric} {
    -body {
	assemble {
	    push NaN; tryCvtToNumeric
	}
    }
    -returnCodes error
    -result {domain error: argument not in valid range}
}

test assemble-7.44 {listIn} {
    -body {
	assemble {
	    push b; push {a b c}; listIn
	}
    }
    -result 1
}

test assemble-7.45 {listNotIn} {
    -body {
	assemble {
	    push d; push {a b c}; listNotIn
	}
    }
    -result 1
}

test assemble-7.46 {nop} {
    -body {
	assemble { push x; nop; nop; nop}
    }
    -result x
}

# assemble-8 ASSEM_LVT and FindLocalVar

test assemble-8.1 {load, wrong # args} {
    -body {
	assemble load
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-8.2 {load, wrong # args} {
    -body {
	assemble {load too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-8.3 {nonlocal var} {
    -body {
	list [catch {assemble {load ::env}} result] $result $errorCode
    }
    -result {1 {variable "::env" is not local} {TCL ASSEM NONLOCAL ::env}}
    -cleanup {unset result}
}

test assemble-8.4 {bad context} {
    -body {
	set x 1
	list [catch {assemble {load x}} result] $result $errorCode
    }
    -result {1 {cannot use this instruction to create a variable in a non-proc context} {TCL ASSEM LVT}}
    -cleanup {unset result}
}

test assemble-8.5 {bad context} {
    -body {
	namespace eval assem {
	    set x 1
	    list [catch {assemble {load x}} result] $result $errorCode
	}
    }
    -result {1 {cannot use this instruction to create a variable in a non-proc context} {TCL ASSEM LVT}}
    -cleanup {namespace delete assem}
}

test assemble-8.6 {load1} {
    -body {
	proc x {a} {
	    assemble {
		load a
	    }
	}
	x able
    }
    -result able
    -cleanup {rename x {}}
}

test assemble-8.7 {load4} {
    -body {
	proc x {a} "
	    [fillTables]
            set b \$a
            assemble {load b}
        "
	x able
    }
    -result able
    -cleanup {rename x {}}
}

test assemble-8.8 {loadArray1} {
    -body {
	proc x {} {
	    set able(baker) charlie
	    assemble {
		push baker
		loadArray able
	    }
	}
	x
    }
    -result charlie
    -cleanup {rename x {}}
}

test assemble-8.9 {loadArray4} {
    -body "
	proc x {} {
            [fillTables]
	    set able(baker) charlie
	    assemble {
		push baker
		loadArray able
	    }
	}
	x
    "
    -result charlie
    -cleanup {rename x {}}
}

test assemble-8.10 {append1} {
    -body {
	proc x {} {
	    set y {hello, }
	    assemble {
		push world; append y
	    }
	}
	x
    }
    -result {hello, world}
    -cleanup {rename x {}}
}

test assemble-8.11 {append4} {
    -body {
	proc x {} "
            [fillTables]
	    set y {hello, }
	    assemble {
		push world; append y
	    }
	"
	x
    }
    -result {hello, world}
    -cleanup {rename x {}}
}

test assemble-8.12 {appendArray1} {
    -body {
	proc x {} {
	    set y(z) {hello, }
	    assemble {
		push z; push world; appendArray y
	    }
	}
	x
    }
    -result {hello, world}
    -cleanup {rename x {}}
}

test assemble-8.13 {appendArray4} {
    -body {
	proc x {} "
            [fillTables]
	    set y(z) {hello, }
	    assemble {
		push z; push world; appendArray y
	    }
	"
	x
    }
    -result {hello, world}
    -cleanup {rename x {}}
}

test assemble-8.14 {lappend1} {
    -body {
	proc x {} {
	    set y {hello,}
	    assemble {
		push world; lappend y
	    }
	}
	x
    }
    -result {hello, world}
    -cleanup {rename x {}}
}

test assemble-8.15 {lappend4} {
    -body {
	proc x {} "
            [fillTables]
	    set y {hello,}
	    assemble {
		push world; lappend y
	    }
	"
	x
    }
    -result {hello, world}
    -cleanup {rename x {}}
}

test assemble-8.16 {lappendArray1} {
    -body {
	proc x {} {
	    set y(z) {hello,}
	    assemble {
		push z; push world; lappendArray y
	    }
	}
	x
    }
    -result {hello, world}
    -cleanup {rename x {}}
}

test assemble-8.17 {lappendArray4} {
    -body {
	proc x {} "
            [fillTables]
	    set y(z) {hello,}
	    assemble {
		push z; push world; lappendArray y
	    }
	"
	x
    }
    -result {hello, world}
    -cleanup {rename x {}}
}

test assemble-8.18 {store1} {
    -body {
	proc x {} {
	    assemble {
		push test; store y
	    }
	    set y
	}
	x
    }
    -result {test}
    -cleanup {rename x {}}
}

test assemble-8.19 {store4} {
    -body {
	proc x {} "
            [fillTables]
	    assemble {
		push test; store y
	    }
            set y
	"
	x
    }
    -result test
    -cleanup {rename x {}}
}

test assemble-8.20 {storeArray1} {
    -body {
	proc x {} {
	    assemble {
		push z; push test; storeArray y
	    }
	    set y(z)
	}
	x
    }
    -result test
    -cleanup {rename x {}}
}

test assemble-8.21 {storeArray4} {
    -body {
	proc x {} "
            [fillTables]
	    assemble {
		push z; push test; storeArray y
	    }
	"
	x
    }
    -result test
    -cleanup {rename x {}}
}

# assemble-9 - ASSEM_CONCAT1, GetIntegerOperand, CheckOneByte

test assemble-9.1 {wrong # args} {
    -body {assemble concat}
    -result {wrong # args*}
    -match glob
    -returnCodes error
}

test assemble-9.2 {wrong # args} {
    -body {assemble {concat too many}}
    -result {wrong # args*}
    -match glob
    -returnCodes error
}

test assemble-9.3 {not a number} {
    -body {assemble {concat rubbish}}
    -result {expected integer but got "rubbish"}
    -returnCodes error
}
test assemble-9.4 {too small} {
    -body {assemble {concat -1}}
    -result {operand does not fit in one byte}
    -returnCodes error
}
test assemble-9.5 {too small} {
    -body {assemble {concat 256}}
    -result {operand does not fit in one byte}
    -returnCodes error
}
test assemble-9.6 {concat} {
    -body {
	assemble {push h; push e; push l; push l; push o; concat 5}
    }
    -result hello
}
test assemble-9.7 {concat} {
    -body {
	list [catch {assemble {concat 0}} result] $result $::errorCode
    }
    -result {1 {operand must be positive} {TCL ASSEM POSITIVE}}
    -cleanup {unset result}
}

# assemble-10 -- eval and expr

test assemble-10.1 {eval - wrong # args} {
    -body {
	assemble {eval}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-10.2 {eval - wrong # args} {
    -body {
	assemble {eval too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-10.3 {eval} {
    -body {
	proc x {} {
	    assemble {
		push 3
		store n
		pop
		eval {expr {3*$n + 1}}
		push 1
		add
	    }
	}
	x
    }
    -result 11
    -cleanup {rename x {}}
}

test assemble-10.4 {expr} {
    -body {
	proc x {} {
	    assemble {
		push 3
		store n
		pop
		expr {3*$n + 1}
		push 1
		add
	    }
	}
	x
    }
    -result 11
    -cleanup {rename x {}}
}

test assemble-10.5 {eval and expr - nonsimple} {
    -body {
	proc x {} {
	    assemble {
		eval "s\x65t n 3"
		pop
		expr "\x33*\$n + 1"
		push 1
		add
	    }
	}
	x
    }
    -result 11
    -cleanup {
	rename x {}
    }
}

test assemble-10.6 {eval - noncompilable} {
    -body {
	list [catch {assemble {eval $x}} result] $result $::errorCode
    }
    -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}}
}

test assemble-10.7 {expr - noncompilable} {
    -body {
	list [catch {assemble {expr $x}} result] $result $::errorCode
    }
    -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}}
}

# assemble-11 - ASSEM_LVT4 (exist, existArray, dictAppend, dictLappend,
#			    nsupvar, variable, upvar)
		
test assemble-11.1 {exist - wrong # args} {
    -body {
	assemble {exist}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-11.2 {exist - wrong # args} {
    -body {
	assemble {exist too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-11.3 {nonlocal var} {
    -body {
	list [catch {assemble {exist ::env}} result] $result $errorCode
    }
    -result {1 {variable "::env" is not local} {TCL ASSEM NONLOCAL ::env}}
    -cleanup {unset result}
}

test assemble-11.4 {exist} {
    -body {
	proc x {} {
	    set y z
	    list [assemble {exist y}] \
		[assemble {exist z}]
	}
	x
    }
    -result {1 0}
    -cleanup {rename x {}}
}

test assemble-11.5 {existArray} {
    -body {
	proc x {} {
	    set a(b) c
	    list [assemble {push b; existArray a}] \
		[assemble {push c; existArray a}] \
		[assemble {push a; existArray b}]
	}
	x
    }
    -result {1 0 0}
    -cleanup {rename x {}}
}

test assemble-11.6 {dictAppend} {
    -body {
	proc x {} {
	    set dict {a 1 b 2 c 3}
	    assemble {push b; push 22; dictAppend dict}
	}
	x
    }
    -result {a 1 b 222 c 3}
    -cleanup {rename x {}}
}

test assemble-11.7 {dictLappend} {
    -body {
	proc x {} {
	    set dict {a 1 b 2 c 3}
	    assemble {push b; push 2; dictLappend dict}
	}
	x
    }
    -result {a 1 b {2 2} c 3}
    -cleanup {rename x {}}
}

test assemble-11.8 {upvar} {
    -body {
	proc x {v} {
	    assemble {push 1; load v; upvar w; pop; load w}
	}
	proc y {} {
	    set z 123
	    x z
	}
	y
    }
    -result 123
    -cleanup {rename x {}; rename y {}}
}

test assemble-11.9 {nsupvar} {
    -body {
	namespace eval q { variable v 123 }
	proc x {} {
	    assemble {push q; push v; nsupvar y; pop; load y}
	}
	x
    }
    -result 123
    -cleanup {namespace delete q; rename x {}}
}

test assemble-11.10 {variable} {
    -body {
	namespace eval q { namespace eval r {variable v 123}}
	proc x {} {
	    assemble {push q::r::v; variable y; load y}
	}
	x
    }
    -result 123
    -cleanup {namespace delete q; rename x {}}
}

# assemble-12 - ASSEM_LVT1 (incr and incrArray)
		
test assemble-12.1 {incr - wrong # args} {
    -body {
	assemble {incr}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-12.2 {incr - wrong # args} {
    -body {
	assemble {incr too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-12.3 {incr nonlocal var} {
    -body {
	list [catch {assemble {incr ::env}} result] $result $errorCode
    }
    -result {1 {variable "::env" is not local} {TCL ASSEM NONLOCAL ::env}}
    -cleanup {unset result}
}

test assemble-12.4 {incr} {
    -body {
	proc x {} {
	    set y 5
	    assemble {push 3; incr y}
	}
	x
    }
    -result 8
    -cleanup {rename x {}}
}

test assemble-12.5 {incrArray} {
    -body {
	proc x {} {
	    set a(b) 5
	    assemble {push b; push 3; incrArray a}
	}
	x
    }
    -result 8
    -cleanup {rename x {}}
}

test assemble-12.6 {incr, stupid stack restriction} {
    -body {
	proc x {} "
	    [fillTables]
            set y 5
            assemble {push 3; incr y}
        "
	list [catch {x} result] $result $errorCode
    }
    -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}}
    -cleanup {unset result; rename x {}}
}

# assemble-13 -- ASSEM_LVT1_SINT1 - incrImm and incrArrayImm

test assemble-13.1 {incrImm - wrong # args} {
    -body {
	assemble {incrImm x}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-13.2 {incrImm - wrong # args} {
    -body {
	assemble {incrImm too many args}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-13.3 {incrImm nonlocal var} {
    -body {
	list [catch {assemble {incrImm ::env 2}} result] $result $errorCode
    }
    -result {1 {variable "::env" is not local} {TCL ASSEM NONLOCAL ::env}}
    -cleanup {unset result}
}

test assemble-13.4 {incrImm not a number} {
    -body {
	proc x {} {
	    assemble {incrImm x rubbish}
	}
	x
    }
    -returnCodes error
    -result {expected integer but got "rubbish"}
    -cleanup {rename x {}}
}

test assemble-13.5 {incrImm too big} {
    -body {
	proc x {} {
	    assemble {incrImm x 0x80}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}}
    -cleanup {rename x {}; unset result}
}
    
test assemble-13.6 {incrImm too small} {
    -body {
	proc x {} {
	    assemble {incrImm x -0x81}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}}
    -cleanup {rename x {}; unset result}
}

test assemble-13.7 {incrImm} {
    -body {
	proc x {} {
	    set y 1
	    list [assemble {incrImm y -0x80}] [assemble {incrImm y 0x7f}]
	}
	x
    }
    -result {-127 0}
    -cleanup {rename x {}}
}

test assemble-13.8 {incrArrayImm} {
    -body {
	proc x {} {
	    set a(b) 5
	    assemble {push b; incrArrayImm a 3}
	}
	x
    }
    -result 8
    -cleanup {rename x {}}
}

test assemble-13.9 {incrImm, stupid stack restriction} {
    -body {
	proc x {} "
	    [fillTables]
            set y 5
            assemble {incrImm y 3}
        "
	list [catch {x} result] $result $errorCode
    }
    -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}}
    -cleanup {unset result; rename x {}}
}

# assemble-14 -- ASSEM_SINT1 (incrArrayStkImm and incrStkImm)

test assemble-14.1 {incrStkImm - wrong # args} {
    -body {
	assemble {incrStkImm}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-14.2 {incrStkImm - wrong # args} {
    -body {
	assemble {incrStkImm too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-14.3 {incrStkImm not a number} {
    -body {
	proc x {} {
	    assemble {incrStkImm rubbish}
	}
	x
    }
    -returnCodes error
    -result {expected integer but got "rubbish"}
    -cleanup {rename x {}}
}

test assemble-14.4 {incrStkImm too big} {
    -body {
	proc x {} {
	    assemble {incrStkImm 0x80}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}}
    -cleanup {rename x {}; unset result}
}
    
test assemble-14.5 {incrStkImm too small} {
    -body {
	proc x {} {
	    assemble {incrStkImm -0x81}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}}
    -cleanup {rename x {}; unset result}
}

test assemble-14.6 {incrStkImm} {
    -body {
	proc x {} {
	    set y 1
	    list [assemble {push y; incrStkImm -0x80}] \
		[assemble {push y; incrStkImm 0x7f}]
	}
	x
    }
    -result {-127 0}
    -cleanup {rename x {}}
}

test assemble-14.7 {incrArrayStkImm} {
    -body {
	proc x {} {
	    set a(b) 5
	    assemble {push a; push b; incrArrayStkImm 3}
	}
	x
    }
    -result 8
    -cleanup {rename x {}}
}

# assemble-15 - listIndexImm

test assemble-15.1 {listIndexImm - wrong # args} {
    -body {
	assemble {listIndexImm}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-16.2 {listIndexImm - wrong # args} {
    -body {
	assemble {listIndexImm too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-16.3 {listIndexImm - bad substitution} {
    -body {
	list [catch {assemble {listIndexImm $foo}} result] $result $::errorCode
    }
    -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}}
    -cleanup {unset result}
}

test assemble-16.4 {listIndexImm - invalid index} {
    -body {
	assemble {listIndexImm rubbish}
    }
    -returnCodes error
    -match glob
    -result {bad index "rubbish"*}
}

test assemble-16.5 {listIndexImm} {
    -body {
	assemble {push {a b c}; listIndexImm 2}
    }
    -result c
}

test assemble-16.6 {listIndexImm} {
    -body {
	assemble {push {a b c}; listIndexImm end-1}
    }
    -result b
}

test assemble-16.6 {listIndexImm} {
    -body {
	assemble {push {a b c}; listIndexImm end}
    }
    -result c
}

# assemble-16 - invokeStk

test assemble-16.1 {invokeStk - wrong # args} {
    -body {
	assemble {invokeStk}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-16.2 {invokeStk - wrong # args} {
    -body {
	assemble {invokeStk too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-16.3 {invokeStk - not a number} {
    -body {
	proc x {} {
	    assemble {invokeStk rubbish}
	}
	x
    }
    -returnCodes error
    -result {expected integer but got "rubbish"}
    -cleanup {rename x {}}
}

test assemble-16.4 {invokeStk - no operands} {
    -body {
	proc x {} {
	    assemble {invokeStk 0}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand must be positive} {TCL ASSEM POSITIVE}}
    -cleanup {rename x {}; unset result}
}

test assemble-16.5 {invokeStk1} {
    -body {
	tcl::unsupported::assemble {push concat; push 1; push 2; invokeStk 3}
    }
    -result {1 2}
}

test assemble-16.6 {invokeStk4} {
    -body {
	proc x {n} {
	    set code {push concat}
	    set shouldbe {}
	    for {set i 1} {$i < $n} {incr i} {
		append code \n {push a} $i
		lappend shouldbe a$i
	    }
	    append code \n {invokeStk} { } $n
	    set is [assemble $code]
	    expr {$is eq $shouldbe}
	}
	list [x 254] [x 255] [x 256] [x 257]
    }
    -result {1 1 1 1}
    -cleanup {rename x {}}
}

# assemble-17 -- jumps and labels

test assemble-17.1 {label, wrong # args} {
    -body {
	assemble {label}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-17.2 {label, wrong # args} {
    -body {
	assemble {label too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-17.3 {label, bad subst} {
    -body {
	list [catch {assemble {label $foo}} result] $result $::errorCode
    }
    -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}}
    -cleanup {unset result}
}

test assemble-17.4 {duplicate label} {
    -body {
	list [catch {assemble {label foo; label foo}} result] \
	    $result $::errorCode
    }
    -result {1 {duplicate definition of label "foo"} {TCL ASSEM DUPLABEL foo}}
}

test assemble-17.5 {jump, wrong # args} {
    -body {
	assemble {jump}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-17.6 {jump, wrong # args} {
    -body {
	assemble {jump too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-17.7 {jump, bad subst} {
    -body {
	list [catch {assemble {jump $foo}} result] $result $::errorCode
    }
    -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}}
    -cleanup {unset result}
}

test assemble-17.8 {jump - ahead and back} {
    -body {
	assemble {
	    jump three

	    label one
	    push a
	    jump four

	    label two
	    push b
	    jump six

	    label three
	    push c
	    jump five

	    label four
	    push d
	    jump two

	    label five
	    push e
	    jump one

	    label six
	    push f
	    concat 6
	}
    }
    -result ceadbf
}

test assemble-17.9 {jump - resolve a label multiple times} {
    -body {
	proc x {} {
	    set case 0
	    set result {}
	    assemble {
		jump common
		
		label zero
		pop		
		incrImm case 1
		pop
		push a
		append result
		pop
		jump common
		
		label one
		pop
		incrImm case 1
		pop
		push b
		append result
		pop
		jump common
		
		label common
		load case
		dup
		push 0
		eq
		jumpTrue zero
		dup
		push 1
		eq
		jumpTrue one
		dup
		push 2
		eq
		jumpTrue two
		dup
		push 3
		eq
		jumpTrue three
		
		label two
		pop
		incrImm case 1
		pop
		push c
		append result
		pop
		jump common
		
		label three
		pop
		incrImm case 1
		pop
		push d
		append result
	    }
	}
	x
    }
    -result abcd
    -cleanup {rename x {}}
}

test assemble-17.10 {jump4 needed} {
    -body {
	assemble "push x; jump one; label two; [string repeat {dup; pop;} 128]
	      jump three; label one; jump two; label three"
    }
    -result x
}

test assemble-17.11 {jumpTrue} {
    -body {
	proc x {y} {
	    assemble {
		load y
		jumpTrue then
		push no
		jump else
		label then
		push yes
		label else
	    }
	}
	list [x 0] [x 1]
    }
    -result {no yes}
    -cleanup {rename x {}}
}

test assemble-17.12 {jumpFalse} {
    -body {
	proc x {y} {
	    assemble {
		load y
		jumpFalse then
		push no
		jump else
		label then
		push yes
		label else
	    }
	}
	list [x 0] [x 1]
    }
    -result {yes no}
    -cleanup {rename x {}}
}

test assemble-17.13 {jump to undefined label} {
    -body {
	list [catch {assemble {jump nowhere}} result] $result $::errorCode
    }
    -result {1 {undefined label "nowhere"} {TCL ASSEM NOLABEL nowhere}}
}

test assemble-17.14 {jump to undefined label, line number correct?} {
    -body {
	catch {assemble {#1
	    #2
	    #3
	    jump nowhere
	    #5
	    #6
	}}
	set ::errorInfo
    }
    -match glob
    -result {*"assemble" body, line 4*}
}

test assemble-17.15 {multiple passes of code resizing} {
    -setup {
	set body {
	    push -
	}
	for {set i 0} {$i < 14} {incr i} {
	    append body "label a" $i \
		"; push a; concat 2; nop; nop; jump b" \
		$i \n
	}
	append body {label a14; push a; concat 2; push 1; jumpTrue b14} \n
	append body {label a15; push a; concat 2; push 0; jumpFalse b15} \n
	for {set i 0} {$i < 15} {incr i} {
	    append body "label b" $i \
		"; push b; concat 2; nop; nop; jump a" \
		[expr {$i+1}] \n
	}
	append body {label c; push -; concat 2; nop; nop; nop; jump d} \n
	append body {label b15; push b; concat 2; nop; nop; jump c} \n
	append body {label d}
	proc x {} [list assemble $body]
    }	
    -body {
	x
    }
    -cleanup {
	catch {unset body}
	catch {rename x {}}
    }
    -result -abababababababababababababababab-
}

# assemble-18 - lindexMulti

test assemble-18.1 {lindexMulti - wrong # args} {
    -body {
	assemble {lindexMulti}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-18.2 {lindexMulti - wrong # args} {
    -body {
	assemble {lindexMulti too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-18.3 {lindexMulti - bad subst} {
    -body {
	assemble {lindexMulti $foo}
    }
    -returnCodes error
    -match glob
    -result {assembly code may not contain substitutions}
}

test assemble-18.4 {lindexMulti - not a number} {
    -body {
	proc x {} {
	    assemble {lindexMulti rubbish}
	}
	x
    }
    -returnCodes error
    -result {expected integer but got "rubbish"}
    -cleanup {rename x {}}
}

test assemble-18.5 {lindexMulti - bad operand count} {
    -body {
	proc x {} {
	    assemble {lindexMulti 0}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand must be positive} {TCL ASSEM POSITIVE}}
    -cleanup {rename x {}; unset result}
}

test assemble-18.6 {lindexMulti} {
    -body {
	assemble {push {{a b c} {d e f} {g h j}}; lindexMulti 1}
    }
    -result {{a b c} {d e f} {g h j}}
}

test assemble-18.7 {lindexMulti} {
    -body {
	assemble {push {{a b c} {d e f} {g h j}}; push 1; lindexMulti 2}
    }
    -result {d e f}
}

test assemble-18.8 {lindexMulti} {
    -body {
	assemble {push {{a b c} {d e f} {g h j}}; push 2; push 1; lindexMulti 3}
    }
    -result h
}

# assemble-19 - list

test assemble-19.1 {list - wrong # args} {
    -body {
	assemble {list}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-19.2 {list - wrong # args} {
    -body {
	assemble {list too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-19.3 {list - bad subst} {
    -body {
	assemble {list $foo}
    }
    -returnCodes error
    -match glob
    -result {assembly code may not contain substitutions}
}

test assemble-19.4 {list - not a number} {
    -body {
	proc x {} {
	    assemble {list rubbish}
	}
	x
    }
    -returnCodes error
    -result {expected integer but got "rubbish"}
    -cleanup {rename x {}}
}

test assemble-19.5 {list - negative operand count} {
    -body {
	proc x {} {
	    assemble {list -1}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand must be nonnegative} {TCL ASSEM NONNEGATIVE}}
    -cleanup {rename x {}; unset result}
}

test assemble-19.6 {list - no args} {
    -body {
	assemble {list 0}
    }
    -result {}
}

test assemble-19.7 {list - 1 arg} {
    -body {
	assemble {push hello; list 1}
    }
    -result hello
}

test assemble-19.8 {list - 2 args} {
    -body {
	assemble {push hello; push world; list 2}
    }
    -result {hello world}
}

# assemble-20 - lsetFlat

test assemble-20.1 {lsetFlat - wrong # args} {
    -body {
	assemble {lsetFlat}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-20.2 {lsetFlat - wrong # args} {
    -body {
	assemble {lsetFlat too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-20.3 {lsetFlat - bad subst} {
    -body {
	assemble {lsetFlat $foo}
    }
    -returnCodes error
    -match glob
    -result {assembly code may not contain substitutions}
}

test assemble-20.4 {lsetFlat - not a number} {
    -body {
	proc x {} {
	    assemble {lsetFlat rubbish}
	}
	x
    }
    -returnCodes error
    -result {expected integer but got "rubbish"}
    -cleanup {rename x {}}
}

test assemble-20.5 {lsetFlat - negative operand count} {
    -body {
	proc x {} {
	    assemble {lsetFlat 1}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand must be >=2} {TCL ASSEM OPERAND>=2}}
    -cleanup {rename x {}; unset result}
}

test assemble-20.6 {lsetFlat} {
    -body {
	assemble {push b; push a; lsetFlat 2}
    } 
    -result b
}

test assemble-20.7 {lsetFlat} {
    -body {
	assemble {push 1; push d; push {a b c}; lsetFlat 3}
    }
    -result {a d c}
}

# assemble-21 - over

test assemble-21.1 {over - wrong # args} {
    -body {
	assemble {over}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-21.2 {over - wrong # args} {
    -body {
	assemble {over too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-21.3 {over - bad subst} {
    -body {
	assemble {over $foo}
    }
    -returnCodes error
    -match glob
    -result {assembly code may not contain substitutions}
}

test assemble-21.4 {over - not a number} {
    -body {
	proc x {} {
	    assemble {over rubbish}
	}
	x
    }
    -returnCodes error
    -result {expected integer but got "rubbish"}
    -cleanup {rename x {}}
}

test assemble-21.5 {over - negative operand count} {
    -body {
	proc x {} {
	    assemble {over -1}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand must be nonnegative} {TCL ASSEM NONNEGATIVE}}
    -cleanup {rename x {}; unset result}
}

test assemble-21.6 {over} {
    -body {
	proc x {} {
	    assemble {
		push 1
		push 2
		push 3
		over 0
		store x
		pop
		pop
		pop
		pop
		load x
	    }
	}
	x
    }
    -result 3
    -cleanup {rename x {}}
}

test assemble-21.7 {over} {
    -body {
	proc x {} {
	    assemble {
		push 1
		push 2
		push 3
		over 2
		store x
		pop
		pop
		pop
		pop
		load x
	    }
	}
	x
    }
    -result 1
    -cleanup {rename x {}}
}

# assemble-22 - reverse

test assemble-22.1 {reverse - wrong # args} {
    -body {
	assemble {reverse}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-22.2 {reverse - wrong # args} {
    -body {
	assemble {reverse too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-22.3 {reverse - bad subst} {
    -body {
	assemble {reverse $foo}
    }
    -returnCodes error
    -match glob
    -result {assembly code may not contain substitutions}
}

test assemble-22.4 {reverse - not a number} {
    -body {
	proc x {} {
	    assemble {reverse rubbish}
	}
	x
    }
    -returnCodes error
    -result {expected integer but got "rubbish"}
    -cleanup {rename x {}}
}

test assemble-22.5 {reverse - negative operand count} {
    -body {
	proc x {} {
	    assemble {reverse -1}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand must be nonnegative} {TCL ASSEM NONNEGATIVE}}
    -cleanup {rename x {}; unset result}
}

test assemble-22.6 {reverse - zero operand count} {
    -body {
	proc x {} {
	    assemble {push 1; reverse 0}
	}
	x
    }
    -result 1
    -cleanup {rename x {}}
}

test assemble-22.7 {reverse} {
    -body {
	proc x {} {
	    assemble {
		push 1
		push 2
		push 3
		reverse 1
		store x
		pop
		pop
		pop
		load x
	    }
	}
	x
    }
    -result 3
    -cleanup {rename x {}}
}

test assemble-22.8 {reverse} {
    -body {
	proc x {} {
	    assemble {
		push 1
		push 2
		push 3
		reverse 3
		store x
		pop
		pop
		pop
		load x
	    }
	}
	x
    }
    -result 1
    -cleanup {rename x {}}
}

# assemble-23 - ASSEM_BOOL (strmatch, unsetStk, unsetArrayStk)

test assemble-23.1 {strmatch - wrong # args} {
    -body {
	assemble {strmatch}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-23.2 {strmatch - wrong # args} {
    -body {
	assemble {strmatch too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-23.3 {strmatch - bad subst} {
    -body {
	assemble {strmatch $foo}
    }
    -returnCodes error
    -match glob
    -result {assembly code may not contain substitutions}
}

test assemble-23.4 {strmatch - not a boolean} {
    -body {
	proc x {} {
	    assemble {strmatch rubbish}
	}
	x
    }
    -returnCodes error
    -result {expected boolean value but got "rubbish"}
    -cleanup {rename x {}}
}

test assemble-23.5 {strmatch} {
    -body {
	proc x {a b} {
	    list [assemble {load a; load b; strmatch 0}] \
		[assemble {load a; load b; strmatch 1}]
	}
	list [x foo*.grill fengbar.grill] [x foo*.grill foobar.grill] [x foo*.grill FOOBAR.GRILL]
    }
    -result {{0 0} {1 1} {0 1}}
    -cleanup {rename x {}}
}

test assemble-23.6 {unsetStk} {
    -body {
	proc x {} {
	    set a {}
	    assemble {push a; unsetStk false}
	    info exists a
	}
	x
    }
    -result 0
    -cleanup {rename x {}}
}

test assemble-23.7 {unsetStk} {
    -body {
	proc x {} {
	    assemble {push a; unsetStk false}
	    info exists a
	}
	x
    }
    -result 0
    -cleanup {rename x {}}
}
test assemble-23.8 {unsetStk} {
    -body {
	proc x {} {
	    assemble {push a; unsetStk true}
	    info exists a
	}
	x
    }
    -returnCodes error
    -result {can't unset "a": no such variable}
    -cleanup {rename x {}}
}

test assemble-23.9 {unsetArrayStk} {
    -body {
	proc x {} {
	    set a(b) {}
	    assemble {push a; push b; unsetArrayStk false}
	    info exists a(b)
	}
	x
    }
    -result 0
    -cleanup {rename x {}}
}

test assemble-23.10 {unsetArrayStk} {
    -body {
	proc x {} {
	    assemble {push a; push b; unsetArrayStk false}
	    info exists a(b)
	}
	x
    }
    -result 0
    -cleanup {rename x {}}
}
test assemble-23.11 {unsetArrayStk} {
    -body {
	proc x {} {
	    assemble {push a; push b; unsetArrayStk true}
	    info exists a(b)
	}
	x
    }
    -returnCodes error
    -result {can't unset "a(b)": no such variable}
    -cleanup {rename x {}}
}

# assemble-24 -- ASSEM_BOOL_LVT4 (unset; unsetArray)

test assemble-24.1 {unset - wrong # args} {
    -body {
	assemble {unset one}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-24.2 {unset - wrong # args} {
    -body {
	assemble {unset too many args}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-24.3 {unset - bad subst -arg 1} {
    -body {
	assemble {unset $foo bar}
    }
    -returnCodes error
    -match glob
    -result {assembly code may not contain substitutions}
}

test assemble-24.4 {unset - not a boolean} {
    -body {
	proc x {} {
	    assemble {unset rubbish trash}
	}
	x
    }
    -returnCodes error
    -result {expected boolean value but got "rubbish"}
    -cleanup {rename x {}}
}

test assemble-24.5 {unset - bad subst - arg 2} {
    -body {
	assemble {unset true $bar}
    }
    -returnCodes error
    -result {assembly code may not contain substitutions}
}

test assemble-24.6 {unset - nonlocal var} {
    -body {
	assemble {unset true ::foo::bar}
    }
    -returnCodes error
    -result {variable "::foo::bar" is not local}
}

test assemble-24.7 {unset} {
    -body {
	proc x {} {
	    set a {}
	    assemble {unset false a}
	    info exists a
	}
	x
    }
    -result 0
    -cleanup {rename x {}}
}

test assemble-24.8 {unset} {
    -body {
	proc x {} {
	    assemble {unset false a}
	    info exists a
	}
	x
    }
    -result 0
    -cleanup {rename x {}}
}
test assemble-24.9 {unset} {
    -body {
	proc x {} {
	    assemble {unset true a}
	    info exists a
	}
	x
    }
    -returnCodes error
    -result {can't unset "a": no such variable}
    -cleanup {rename x {}}
}

test assemble-24.10 {unsetArray} {
    -body {
	proc x {} {
	    set a(b) {}
	    assemble {push b; unsetArray false a}
	    info exists a(b)
	}
	x
    }
    -result 0
    -cleanup {rename x {}}
}

test assemble-24.11 {unsetArray} {
    -body {
	proc x {} {
	    assemble {push b; unsetArray false a}
	    info exists a(b)
	}
	x
    }
    -result 0
    -cleanup {rename x {}}
}

test assemble-24.12 {unsetArray} {
    -body {
	proc x {} {
	    assemble {push b; unsetArray true a}
	    info exists a(b)
	}
	x
    }
    -returnCodes error
    -result {can't unset "a(b)": no such variable}
    -cleanup {rename x {}}
}

# assemble-25 - dict get

test assemble-25.1 {dict get - wrong # args} {
    -body {
	assemble {dictGet}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-25.2 {dict get - wrong # args} {
    -body {
	assemble {dictGet too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-25.3 {dictGet - bad subst} {
    -body {
	assemble {dictGet $foo}
    }
    -returnCodes error
    -match glob
    -result {assembly code may not contain substitutions}
}

test assemble-25.4 {dict get - not a number} {
    -body {
	proc x {} {
	    assemble {dictGet rubbish}
	}
	x
    }
    -returnCodes error
    -result {expected integer but got "rubbish"}
    -cleanup {rename x {}}
}

test assemble-25.5 {dictGet - negative operand count} {
    -body {
	proc x {} {
	    assemble {dictGet 0}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand must be positive} {TCL ASSEM POSITIVE}}
    -cleanup {rename x {}; unset result}
}

test assemble-25.6 {dictGet - 1 index} {
    -body {
	assemble {push {a 1 b 2}; push a; dictGet 1}
    }
    -result 1
}

# assemble-26 - dict set

test assemble-26.1 {dict set - wrong # args} {
    -body {
	assemble {dictSet 1}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-26.2 {dict get - wrong # args} {
    -body {
	assemble {dictSet too many args}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-26.3 {dictSet - bad subst} {
    -body {
	assemble {dictSet 1 $foo}
    }
    -returnCodes error
    -match glob
    -result {assembly code may not contain substitutions}
}

test assemble-26.4 {dictSet - not a number} {
    -body {
	proc x {} {
	    assemble {dictSet rubbish foo}
	}
	x
    }
    -returnCodes error
    -result {expected integer but got "rubbish"}
    -cleanup {rename x {}}
}

test assemble-26.5 {dictSet - zero operand count} {
    -body {
	proc x {} {
	    assemble {dictSet 0 foo}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand must be positive} {TCL ASSEM POSITIVE}}
    -cleanup {rename x {}; unset result}
}

test assemble-26.6 {dictSet - bad local} {
    -body {
	proc x {} {
	    assemble {dictSet 1 ::foo::bar}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {variable "::foo::bar" is not local} {TCL ASSEM NONLOCAL ::foo::bar}}
    -cleanup {rename x {}; unset result}
}

test assemble-26.7 {dictSet} {
    -body {
	proc x {} {
	    set dict {a 1 b 2 c 3}
	    assemble {push b; push 4; dictSet 1 dict}
	}
	x
    }
    -result {a 1 b 4 c 3}
    -cleanup {rename x {}}
}

# assemble-27 - dictUnset

test assemble-27.1 {dictUnset - wrong # args} {
    -body {
	assemble {dictUnset 1}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-27.2 {dictUnset - wrong # args} {
    -body {
	assemble {dictUnset too many args}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-27.3 {dictUnset - bad subst} {
    -body {
	assemble {dictUnset 1 $foo}
    }
    -returnCodes error
    -match glob
    -result {assembly code may not contain substitutions}
}

test assemble-27.4 {dictUnset - not a number} {
    -body {
	proc x {} {
	    assemble {dictUnset rubbish foo}
	}
	x
    }
    -returnCodes error
    -result {expected integer but got "rubbish"}
    -cleanup {rename x {}}
}

test assemble-27.5 {dictUnset - zero operand count} {
    -body {
	proc x {} {
	    assemble {dictUnset 0 foo}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand must be positive} {TCL ASSEM POSITIVE}}
    -cleanup {rename x {}; unset result}
}

test assemble-27.6 {dictUnset - bad local} {
    -body {
	proc x {} {
	    assemble {dictUnset 1 ::foo::bar}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {variable "::foo::bar" is not local} {TCL ASSEM NONLOCAL ::foo::bar}}
    -cleanup {rename x {}; unset result}
}

test assemble-27.7 {dictUnset} {
    -body {
	proc x {} {
	    set dict {a 1 b 2 c 3}
	    assemble {push b; dictUnset 1 dict}
	}
	x
    }
    -result {a 1 c 3}
    -cleanup {rename x {}}
}

# assemble-28 - dictIncrImm

test assemble-28.1 {dictIncrImm - wrong # args} {
    -body {
	assemble {dictIncrImm 1}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-28.2 {dictIncrImm - wrong # args} {
    -body {
	assemble {dictIncrImm too many args}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-28.3 {dictIncrImm - bad subst} {
    -body {
	assemble {dictIncrImm 1 $foo}
    }
    -returnCodes error
    -match glob
    -result {assembly code may not contain substitutions}
}

test assemble-28.4 {dictIncrImm - not a number} {
    -body {
	proc x {} {
	    assemble {dictIncrImm rubbish foo}
	}
	x
    }
    -returnCodes error
    -result {expected integer but got "rubbish"}
    -cleanup {rename x {}}
}

test assemble-28.5 {dictIncrImm - bad local} {
    -body {
	proc x {} {
	    assemble {dictIncrImm 1 ::foo::bar}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {variable "::foo::bar" is not local} {TCL ASSEM NONLOCAL ::foo::bar}}
    -cleanup {rename x {}; unset result}
}

test assemble-28.6 {dictIncrImm} {
    -body {
	proc x {} {
	    set dict {a 1 b 2 c 3}
	    assemble {push b; dictIncrImm 42 dict}
	}
	x
    }
    -result {a 1 b 44 c 3}
    -cleanup {rename x {}}
}

# assemble-29 - ASSEM_REGEXP

test assemble-29.1 {regexp - wrong # args} {
    -body {
	assemble {regexp}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-29.2 {regexp - wrong # args} {
    -body {
	assemble {regexp too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-29.3 {regexp - bad subst} {
    -body {
	assemble {regexp $foo}
    }
    -returnCodes error
    -match glob
    -result {assembly code may not contain substitutions}
}

test assemble-29.4 {regexp - not a boolean} {
    -body {
	proc x {} {
	    assemble {regexp rubbish}
	}
	x
    }
    -returnCodes error
    -result {expected boolean value but got "rubbish"}
    -cleanup {rename x {}}
}

test assemble-29.5 {regexp} {
    -body {
	assemble {push br.*br; push abracadabra; regexp false}
    }
    -result 1
}

test assemble-29.6 {regexp} {
    -body {
	assemble {push br.*br; push aBRacadabra; regexp false}
    }
    -result 0
}

test assemble-29.7 {regexp} {
    -body {
	assemble {push br.*br; push aBRacadabra; regexp true}
    }
    -result 1
}

# assemble-30 - Catches

test assemble-30.1 {simplest possible catch} {
    -body {
	proc x {} {
	    assemble {
		beginCatch @bad
		push error
		push testing
		invokeStk 2
		pop
		push 0
		jump @ok
		label @bad
		push 1; # should be pushReturnCode
		label @ok
		endCatch
	    }
	}
	x
    }
    -result 1
    -cleanup {rename x {}}
}
	    
test assemble-30.2 {catch in external catch conntext} {
    -body {
	proc x {} {
	    list [catch {
		assemble {
		    beginCatch @bad
		    push error
		    push testing
		    invokeStk 2
		    pop
		    push 0
		    jump @ok
		    label @bad
		    pushReturnCode
		    label @ok
		    endCatch
		}
	    } result] $result
	}
	x
    }
    -result {0 1}
    -cleanup {rename x {}}
}

test assemble-30.3 {embedded catches} {
    -body {
	proc x {} {
	    list [catch {
		assemble {
		    beginCatch @bad
		    push error
		    eval { list [catch {error whatever} result] $result }
		    invokeStk 2
		    push 0
		    reverse 2
		    jump @done
		    label @bad
		    pushReturnCode
		    pushResult
		    label @done
		    endCatch
		    list 2
		}
	    } result2] $result2
	}
	x
    }
    -result {0 {1 {1 whatever}}}
    -cleanup {rename x {}}
}

test assemble-30.4 {throw in wrong context} {
    -body {
	proc x {} {
	    list [catch {
		assemble {
		    beginCatch @bad
		    push error
		    eval { list [catch {error whatever} result] $result }
		    invokeStk 2
		    push 0
		    reverse 2
		    jump @done

		    label @bad
		    load x
		    pushResult

		    label @done
		    endCatch
		    list 2
		}
	    } result] $result $::errorCode [split $::errorInfo \n]
	}
	x
    }
    -match glob
    -result {1 {"loadScalar1" instruction may not appear in a context where an exception has been caught and not disposed of.} {TCL ASSEM BADTHROW} {{"loadScalar1" instruction may not appear in a context where an exception has been caught and not disposed of.} {    in assembly code between lines 10 and 15}*}}
    -cleanup {rename x {}}
}
    
test assemble-30.5 {unclosed catch} {
    -body {
	proc x {} {
	    assemble {
		beginCatch @error
		push 0
		jump @done
		label @error
		push 1
		label @done
		push ""
		pop
	    }
	}
	list [catch {x} result] $result $::errorCode $::errorInfo
    }
    -match glob
    -result {1 {catch still active on exit from assembly code} {TCL ASSEM UNCLOSEDCATCH} {catch still active on exit from assembly code
    ("assemble" body, line 2)*}}
    -cleanup {rename x {}}
}

test assemble-30.6 {inconsistent catch contexts} {
    -body {
	proc x {y} {
	    assemble {
		load y
		jumpTrue @inblock
		beginCatch @error
		label @inblock
		push 0
		jump @done
		label @error
		push 1
		label @done
	    }
	}
	list [catch {x 2} result] $::errorCode $::errorInfo
    }
    -match glob
    -result {1 {TCL ASSEM BADCATCH} {execution reaches an instruction in inconsistent exception contexts
    ("assemble" body, line 5)*}}
    -cleanup {rename x {}}
}

# assemble-31 - Jump tables

test assemble-31.1 {jumpTable, wrong # args} {
    -body {
	assemble {jumpTable}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-31.2 {jumpTable, wrong # args} {
    -body {
	assemble {jumpTable too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-31.3 {jumpTable - bad subst} {
    -body {
	assemble {jumpTable $foo}
    }
    -returnCodes error
    -match glob
    -result {assembly code may not contain substitutions}
}
test assemble-31.4 {jumptable - not a list} {
    -body {
	assemble {jumpTable \{rubbish}
    }
    -returnCodes error
    -result {unmatched open brace in list}
}
test assemble-31.5 {jumpTable, badly structured} {
    -body {
	list [catch {assemble {
	    # line 2
	    jumpTable {one two three};# line 3
	}} result] \
	    $result $::errorCode $::errorInfo
    }
    -match glob
    -result {1 {jump table must have an even number of list elements} {TCL ASSEM BADJUMPTABLE} {jump table must have an even number of list elements*("assemble" body, line 3)*}}
}
test assemble-31.6 {jumpTable, missing symbol} {
    -body {
	list [catch {assemble {
	    # line 2
	    jumpTable {1 a};# line 3
	}} result] \
	    $result $::errorCode $::errorInfo
    }
    -match glob
    -result {1 {undefined label "a"} {TCL ASSEM NOLABEL a} {undefined label "a"*("assemble" body, line 3)*}}
}

test assemble-31.7 {jumptable, actual example} {
    -setup {
	proc x {} {
	    set result {}
	    for {set i 0} {$i < 5} {incr i} {
		lappend result [assemble {
		    load i
		    jumpTable {1 @one 2 @two 3 @three}
		    push {none of the above}
		    jump @done
		    label @one
		    push one
		    jump @done
		    label @two
		    push two
		    jump @done
		    label @three
		    push three
		    label @done
		}]
	    }
	    set tcl_traceCompile 2
	    set result
	}
    }
    -body x
    -result {{none of the above} one two three {none of the above}}
    -cleanup {set tcl_traceCompile 0; rename x {}}
}

test assemble-40.1 {unbalanced stack} {
    -body {
	list \
	    [catch {
		assemble {
		    push 3
		    dup 
		    mult 
		    push 4
		    dup 
		    mult 
		    pop 
		    expon
		}
	    } result] $result $::errorInfo
    }
    -result {1 {stack underflow} {stack underflow
    in assembly code between lines 1 and end of assembly code*}}
    -match glob
   -returnCodes ok
}

test assemble-40.2 {unbalanced stack} {*}{
    -body {
	list \
	    [catch {
		assemble {
		    label a
		    push {}
		    label b
		    pop
		    label c
		    pop
		    label d
		    push {}
		}
	    } result] $result $::errorInfo
    }
    -result {1 {stack underflow} {stack underflow
    in assembly code between lines 7 and 9*}}
    -match glob
   -returnCodes ok
}

test assemble-41.1 {Inconsistent stack usage} {*}{
    -body {
	proc x {y} {
	    assemble {
		load y
		jumpFalse else
		push 0
		jump then
	      label else
		push 1
		push 2
	      label then
		pop
	    }
	}
	catch {x 1}
	set errorInfo
    }
    -match glob
    -result {inconsistent stack depths on two execution paths
    ("assemble" body, line 10)*}
}

test assemble-41.2 {Inconsistent stack, jumptable and default} {
    -body {
	proc x {y} {
	    assemble {
		load y
		jumpTable {0 else}
		push 0
	      label else
		pop
	    }
	}
	catch {x 1}
	set errorInfo
    }
    -match glob
    -result {inconsistent stack depths on two execution paths
    ("assemble" body, line 6)*}
}

test assemble-41.3 {Inconsistent stack, two legs of jumptable} {
    -body {
	proc x {y} {
	    assemble {
		load y
		jumpTable {0 no 1 yes}
		label no
		push 0
		label yes
		pop
	    }
	}
	catch {x 1}
	set errorInfo
    }
    -match glob
    -result {inconsistent stack depths on two execution paths
    ("assemble" body, line 7)*}
}

test assemble-50.1 {Ulam's 3n+1 problem, TAL implementation} {
    -body {
	proc ulam {n} {
	    assemble {
		load n;		# max
		dup;		# max n
		jump start;     # max n
	    
		label loop;	# max n
		over 1;         # max n max
		over 1;		# max in max n
		ge;             # man n max>=n
		jumpTrue skip;  # max n

		reverse 2;      # n max
		pop;            # n
		dup;            # n n
	    
		label skip;	# max n
		dup;            # max n n
		push 2;         # max n n 2
		mod;            # max n n%2
		jumpTrue odd;   # max n
	    
		push 2;         # max n 2
		div;            # max n/2 -> max n
		jump start;     # max n
	     
		label odd;	# max n
		push 3;         # max n 3
		mult;           # max 3*n
		push 1;         # max 3*n 1
		add;            # max 3*n+1
	    
		label start;	# max n
		dup;		# max n n
		push 1;		# max n n 1
		neq;		# max n n>1
		jumpTrue loop;	# max n
	    
		pop;		# max
	    }
	}
	set result {}
	for {set i 1} {$i < 30} {incr i} {
	    lappend result [ulam $i]
	}
	set result
    }
    -result {1 2 16 4 16 16 52 8 52 16 52 16 40 52 160 16 52 52 88 20 64 52 160 24 88 40 9232 52 88}
}

rename fillTables {}
rename assemble {}

::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End: