summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog147
-rw-r--r--generic/tclAssembly.c4176
-rw-r--r--generic/tclBasic.c7
-rw-r--r--generic/tclCompCmds.c4
-rw-r--r--generic/tclInt.h13
-rw-r--r--generic/tclMain.c2
-rw-r--r--generic/tclTomMath.decls2
-rw-r--r--generic/tclUtil.c2
-rw-r--r--generic/tclZlib.c2
-rw-r--r--tests/append.test4
-rw-r--r--tests/appendComp.test4
-rw-r--r--tests/assemble.test3441
-rw-r--r--tests/assemble1.bench85
-rw-r--r--tests/compile.test4
-rw-r--r--tests/execute.test2
-rw-r--r--tests/fCmd.test4
-rw-r--r--tests/interp.test2
-rw-r--r--tests/ioTrans.test6
-rw-r--r--tests/iogt.test4
-rw-r--r--tests/uplevel.test4
-rw-r--r--tests/util.test2
-rw-r--r--tests/winPipe.test4
-rw-r--r--unix/Makefile.in8
-rw-r--r--unix/tclUnixSock.c6
-rw-r--r--win/Makefile.in1
-rw-r--r--win/makefile.vc1
-rw-r--r--win/tclWinFile.c6
27 files changed, 7909 insertions, 34 deletions
diff --git a/ChangeLog b/ChangeLog
index 7c6a50c..e59a5c8 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -56,7 +56,7 @@
* 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.
@@ -238,6 +238,16 @@
* 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 <kennykb@acm.org>
+
+ [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 <nijtmans@users.sf.net>
* generic/tclPanic.c: Restore abort() as it was before.
@@ -599,6 +609,12 @@
* generic/tclTimer.c: [Bug 2905784]: Stop small [after]s from
wasting CPU while keeping accuracy.
+2010-10-28 Kevin B. Kenny <kennykb@acm.org>
+
+ [dogeen-assembler-branch]
+ * generic/tclAssembly.c:
+ * tests/assembly.test (assemble-31.*): Added jump tables.
+
2010-10-28 Don Porter <dgp@users.sourceforge.net>
* tests/http.test: [Bug 3097490]: Make http-4.15 pass in
@@ -626,6 +642,23 @@
[fconfigure -sockname] and [fconfigure -peername] from doing
reverse DNS queries.
+2010-10-24 Kevin B. Kenny <kennykb@acm.org>
+
+ [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 <kennykb@acm.org>
+
+ [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 <ferrieux@users.sourceforge.net>
* doc/info.n: [Patch 2995655]:
@@ -741,6 +774,23 @@
* 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 <kennykb@acm.org>
+
+ [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 <kennykb@acm.org>
+
+ [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 <dkf@users.sf.net>
* generic/tclExecute.c (TEBCresume): [Bug 3079830]: Added invalidation
@@ -765,6 +815,31 @@
More purging of strcpy() from locations where we already know the
length of the data being copied.
+2010-10-01 Kevin B. Kenny <kennykb@acm.org>
+
+ [dogeen-assembler-branch]
+
+ * tests/assemble.test:
+ * generic/tclAssemble.h:
+ * generic/tclAssemble.c: Added listIn, listNotIn, and dictGet.
+
+2010-09-30 Kevin B. Kenny <kennykb@acm.org>
+
+ [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 <kennykb@acm.org>
+
+ [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 <nijtmans@users.sf.net>
* unix/configure: Re-generate with autoconf-2.59
@@ -800,6 +875,35 @@
tests running in parallel or other services on
the machine.
+2010-09-28 Kevin B. Kenny <kennykb@acm.org>
+
+ [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 <kennykb@acm.org>
+
+ [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 <msofer@users.sf.net>
* generic/tclBasic.c: [Patch 3072080] (minus the itcl
@@ -823,6 +927,31 @@
duplication, let the runtime var resolver call the compiled var
resolver.
+2010-09-26 Kevin B. Kenny <kennykb@acm.org>
+
+ [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 <kennykb@acm.org>
+
+ [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 <jeffh@ActiveState.com>
* tests/stringComp.test: improved string eq/cmp test coverage
@@ -884,6 +1013,22 @@
* generic/tclResult.c (TclMergeReturnOptions): Use memcmp where
applicable as possible speedup on some libc variants.
+2010-09-21 Kevin B. Kenny <kennykb@acm.org>
+
+ [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 <nijtmans@users.sf.net>
* win/tclWinFile.c: Fix declaration after statement.
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
new file mode 100644
index 0000000..26372c6
--- /dev/null
+++ b/generic/tclAssembly.c
@@ -0,0 +1,4176 @@
+/*
+ * 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;
+}
+
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index ce5be25..b07a55d 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -824,6 +824,13 @@ Tcl_CreateInterp(void)
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,
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index c4d88a0..8ce8baa 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -391,7 +391,7 @@ TclCompileCatchCmd(
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.
*/
@@ -477,7 +477,7 @@ TclCompileCatchCmd(
TclEmitOpcode(INST_POP, envPtr);
}
- /*
+ /*
* Result of all this, on either branch, should have been to leave
* one operand -- the return code -- on the stack.
*/
diff --git a/generic/tclInt.h b/generic/tclInt.h
index a804969..ca87530 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3210,6 +3210,15 @@ 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[]);
@@ -3702,6 +3711,10 @@ MODULE_SCOPE int TclStreqOpCmd(ClientData clientData,
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
diff --git a/generic/tclMain.c b/generic/tclMain.c
index 7caadd1..ea9a5c4 100644
--- a/generic/tclMain.c
+++ b/generic/tclMain.c
@@ -650,7 +650,7 @@ Tcl_MainEx(
Tcl_Release(interp);
Tcl_Exit(exitCode);
}
-
+
#ifndef UNICODE
void
Tcl_Main(
diff --git a/generic/tclTomMath.decls b/generic/tclTomMath.decls
index 5bf338e..e7e0076 100644
--- a/generic/tclTomMath.decls
+++ b/generic/tclTomMath.decls
@@ -217,4 +217,4 @@ declare 61 {
}
declare 62 {
int TclBN_mp_set_int(mp_int* a, unsigned long i)
-}
+} \ No newline at end of file
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 535634f..fa0ad4b 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -2266,7 +2266,7 @@ Tcl_PrintDouble(
/*
* Ordinary (normal and denormal) values.
*/
-
+
if (*precisionPtr == 0) {
digits = TclDoubleDigits(value, -1, TCL_DD_SHORTEST,
&exponent, &signum, &end);
diff --git a/generic/tclZlib.c b/generic/tclZlib.c
index 7f17bc7..e75e1da 100644
--- a/generic/tclZlib.c
+++ b/generic/tclZlib.c
@@ -1227,7 +1227,7 @@ Tcl_ZlibDeflate(
if (!interp) {
return TCL_ERROR;
}
-
+
/*
* Compressed format is specified by the wbits parameter. See zlib.h for
* details.
diff --git a/tests/append.test b/tests/append.test
index 69c6381..e35b5b1 100644
--- a/tests/append.test
+++ b/tests/append.test
@@ -16,7 +16,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
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
@@ -292,7 +292,7 @@ test append-9.3 {bug 3057639, append direct eval, read trace on non-existing env
} -cleanup {
unset -nocomplain ::env(__DUMMY__)
} -result {0 {new value}}
-
+
unset -nocomplain i x result y
catch {rename foo ""}
diff --git a/tests/appendComp.test b/tests/appendComp.test
index f85c3ba..4ce7574 100644
--- a/tests/appendComp.test
+++ b/tests/appendComp.test
@@ -16,7 +16,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
catch {unset x}
-
+
test appendComp-1.1 {append command} -setup {
unset -nocomplain x
} -body {
@@ -438,7 +438,7 @@ test appendComp-9.3 {bug 3057639, append direct eval, read trace on non-existing
} -cleanup {
unset -nocomplain ::env(__DUMMY__)
} -result {0 {new value}}
-
+
catch {unset i x result y}
catch {rename foo ""}
catch {rename bar ""}
diff --git a/tests/assemble.test b/tests/assemble.test
new file mode 100644
index 0000000..b9178ec
--- /dev/null
+++ b/tests/assemble.test
@@ -0,0 +1,3441 @@
+# 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: \ No newline at end of file
diff --git a/tests/assemble1.bench b/tests/assemble1.bench
new file mode 100644
index 0000000..18fd3a9
--- /dev/null
+++ b/tests/assemble1.bench
@@ -0,0 +1,85 @@
+proc ulam1 {n} {
+ set max $n
+ while {$n != 1} {
+ if {$n > $max} {
+ set max $n
+ }
+ if {$n % 2} {
+ set n [expr {3 * $n + 1}]
+ } else {
+ set n [expr {$n / 2}]
+ }
+ }
+ return $max
+}
+
+set tcl_traceCompile 2; ulam1 1; set tcl_traceCompile 0
+
+proc ulam2 {n} {
+ tcl::unsupported::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 tcl_traceCompile 2; ulam2 1; set tcl_traceCompile 0
+
+proc test1 {n} {
+ for {set i 1} {$i <= $n} {incr i} {
+ ulam1 $i
+ }
+}
+proc test2 {n} {
+ for {set i 1} {$i <= $n} {incr i} {
+ ulam2 $i
+ }
+}
+
+for {set j 0} {$j < 10} {incr j} {
+ test1 1
+ set before [clock microseconds]
+ test1 30000
+ set after [clock microseconds]
+ puts "compiled: [expr {1e-6 * ($after - $before)}]"
+
+ test2 1
+ set before [clock microseconds]
+ test2 30000
+ set after [clock microseconds]
+ puts "assembled: [expr {1e-6 * ($after - $before)}]"
+}
+ \ No newline at end of file
diff --git a/tests/compile.test b/tests/compile.test
index d6048be..d3915a6 100644
--- a/tests/compile.test
+++ b/tests/compile.test
@@ -26,7 +26,7 @@ catch {namespace delete test_ns_compile}
catch {unset x}
catch {unset y}
catch {unset a}
-
+
test compile-1.1 {TclCompileString: look up cmds in proc ns, not current ns} -setup {
catch {namespace delete test_ns_compile}
catch {unset x}
@@ -705,7 +705,7 @@ test compile-18.19 {disassembler - basics} -setup {
foo destroy
} -match glob -result *
# TODO sometime - check that bytecode from tbcload is *not* disassembled.
-
+
# cleanup
catch {rename p ""}
catch {namespace delete test_ns_compile}
diff --git a/tests/execute.test b/tests/execute.test
index 012b3a7..18cf848 100644
--- a/tests/execute.test
+++ b/tests/execute.test
@@ -33,7 +33,7 @@ testConstraint testobj [expr {
testConstraint longIs32bit [expr {int(0x80000000) < 0}]
testConstraint testexprlongobj [llength [info commands testexprlongobj]]
-
+
# Tests for the omnibus TclExecuteByteCode function:
# INST_DONE not tested
diff --git a/tests/fCmd.test b/tests/fCmd.test
index 410e610..0627729 100644
--- a/tests/fCmd.test
+++ b/tests/fCmd.test
@@ -169,7 +169,7 @@ append long $long
append long $long
append long $long
append long $long
-
+
test fCmd-1.1 {TclFileRenameCmd} -constraints {notRoot} -setup {
cleanup
} -body {
@@ -2580,7 +2580,7 @@ test fCmd-30.3 {file readable on 'pagefile.sys'} -constraints {win} -body {
}
return $r
} -result {exists 1 readable 0 stat 0 {}}
-
+
# cleanup
cleanup
::tcltest::cleanupTests
diff --git a/tests/interp.test b/tests/interp.test
index fd6090e..1944b3a 100644
--- a/tests/interp.test
+++ b/tests/interp.test
@@ -3567,7 +3567,7 @@ test interp-37.1 {safe interps and min() and max(): Bug 2895741} -setup {
unset -nocomplain result
interp delete a
} -result {26 26}
-
+
test interp-38.1 {interp debug one-way switch} -setup {
catch {interp delete a}
interp create a
diff --git a/tests/ioTrans.test b/tests/ioTrans.test
index 8dbad78..f994091 100644
--- a/tests/ioTrans.test
+++ b/tests/ioTrans.test
@@ -100,7 +100,7 @@ set helperscript {
eval $helperscript
#puts <<[file channels]>>
-
+
# ### ### ### ######### ######### #########
test iortrans-1.0 {chan, wrong#args} -returnCodes error -body {
@@ -1034,7 +1034,7 @@ test iortrans-11.2 {delete interp of reflected transform} -setup {
}
interp delete slave
} -result {}
-
+
# ### ### ### ######### ######### #########
## Same tests as above, but exercising the code forwarding and receiving
## driver operations to the originator thread.
@@ -1860,7 +1860,7 @@ test iortrans.tf-11.1 {origin thread of moved transform destroyed during access}
tcltest::threadReap
tempdone
} -result {Owner lost}
-
+
# ### ### ### ######### ######### #########
cleanupTests
diff --git a/tests/iogt.test b/tests/iogt.test
index 60d7ab8..9804fcf 100644
--- a/tests/iogt.test
+++ b/tests/iogt.test
@@ -352,7 +352,7 @@ proc asort {alist} {
array set a $alist
array_sget a
}
-
+
########################################################################
test iogt-1.1 {stack/unstack} testchannel {
@@ -791,7 +791,7 @@ test iogt-6.1 {Push back and up} -constraints {testchannel knownBug} -body {
} -cleanup {
close $f
} -result {xxxghi}
-
+
# cleanup
foreach file [list dummy dummyout __echo_srv__.tcl] {
removeFile $file
diff --git a/tests/uplevel.test b/tests/uplevel.test
index 0410469..5224faa 100644
--- a/tests/uplevel.test
+++ b/tests/uplevel.test
@@ -24,7 +24,7 @@ proc newset {name value} {
uplevel set $name $value
uplevel 1 {uplevel 1 {set xyz 22}}
}
-
+
test uplevel-1.1 {simple operation} {
set xyz 0
a 22 33
@@ -195,7 +195,7 @@ test uplevel-7.3 {var access, LVT in upper level} -setup {
rename foo {}
rename moo {}
} -result {3 3 3}
-
+
# cleanup
::tcltest::cleanupTests
return
diff --git a/tests/util.test b/tests/util.test
index 1f214b5..b1b5056 100644
--- a/tests/util.test
+++ b/tests/util.test
@@ -3866,4 +3866,4 @@ return
# Local Variables:
# mode: tcl
-# End:
+# End: \ No newline at end of file
diff --git a/tests/winPipe.test b/tests/winPipe.test
index 62d7d0d..ea2919f 100644
--- a/tests/winPipe.test
+++ b/tests/winPipe.test
@@ -57,7 +57,7 @@ set path(more) [makeFile {
set path(stdout) [makeFile {} stdout]
set path(stderr) [makeFile {} stderr]
-
+
test winpipe-1.1 {32 bit comprehensive tests: from little file} {win exec cat32} {
exec $cat32 < $path(little) > $path(stdout) 2> $path(stderr)
list [contents $path(stdout)] [contents $path(stderr)]
@@ -424,7 +424,7 @@ test winpipe-8.18 {BuildCommandLine/parse_cmdline pass-thru: special chars #2} {
test winpipe-8.19 {ensure parse_cmdline isn't doing wildcard replacement} {win exec} {
exec [interpreter] $path(echoArgs.tcl) foo * makefile.?c bar
} [list $path(echoArgs.tcl) [list foo * makefile.?c bar]]
-
+
# restore old values for env(TMP) and env(TEMP)
if {[catch {set env(TMP) $env_tmp}]} {
diff --git a/unix/Makefile.in b/unix/Makefile.in
index f0f766c..bba6f91 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -306,7 +306,8 @@ GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \
tclStrToD.o tclThread.o \
tclThreadAlloc.o tclThreadJoin.o tclThreadStorage.o tclStubInit.o \
tclTimer.o tclTrace.o tclUtf.o tclUtil.o tclVar.o tclZlib.o \
- tclTomMathInterface.o
+ tclTomMathInterface.o \
+ tclAssembly.o
OO_OBJS = tclOO.o tclOOBasic.o tclOOCall.o tclOODefineCmds.o tclOOInfo.o \
tclOOMethod.o tclOOStubInit.o
@@ -382,6 +383,7 @@ GENERIC_SRCS = \
$(GENERIC_DIR)/regfree.c \
$(GENERIC_DIR)/regerror.c \
$(GENERIC_DIR)/tclAlloc.c \
+ $(GENERIC_DIR)/tclAssembly.c \
$(GENERIC_DIR)/tclAsync.c \
$(GENERIC_DIR)/tclBasic.c \
$(GENERIC_DIR)/tclBinary.c \
@@ -450,6 +452,7 @@ GENERIC_SRCS = \
$(GENERIC_DIR)/tclTrace.c \
$(GENERIC_DIR)/tclUtil.c \
$(GENERIC_DIR)/tclVar.c \
+ $(GENERIC_DIR)/tclAssembly.c \
$(GENERIC_DIR)/tclZlib.c
OO_SRCS = \
@@ -1010,6 +1013,9 @@ tclAppInit.o: $(UNIX_DIR)/tclAppInit.c
tclAlloc.o: $(GENERIC_DIR)/tclAlloc.c
$(CC) -c $(CC_SWITCHES) -DUSE_TCLALLOC=0 $(GENERIC_DIR)/tclAlloc.c
+tclAssembly.o: $(GENERIC_DIR)/tclAssembly.c $(COMPILEHDR)
+ $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAssembly.c
+
tclAsync.o: $(GENERIC_DIR)/tclAsync.c
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAsync.c
diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c
index b55d1cb..c26b955 100644
--- a/unix/tclUnixSock.c
+++ b/unix/tclUnixSock.c
@@ -521,7 +521,7 @@ TcpCloseProc(
* handlers are already deleted in the generic IO channel closing code
* that called this function, so we do not have to delete them here.
*/
-
+
for (fds = statePtr->fds; fds != NULL; fds = statePtr->fds) {
statePtr->fds = fds->next;
Tcl_DeleteFileHandler(fds->fd);
@@ -658,7 +658,7 @@ TcpGetOptionProc(
Tcl_DStringAppendElement(dsPtr, "-peername");
Tcl_DStringStartSublist(dsPtr);
}
-
+
getnameinfo(&peername.sa, size, host, sizeof(host), NULL, 0,
NI_NUMERICHOST);
Tcl_DStringAppendElement(dsPtr, host);
@@ -1317,7 +1317,7 @@ TcpAccept(
socklen_t len; /* For accept interface */
char channelName[16 + TCL_INTEGER_SPACE];
char host[NI_MAXHOST], port[NI_MAXSERV];
-
+
fds = (TcpFdList *) data;
len = sizeof(addr);
diff --git a/win/Makefile.in b/win/Makefile.in
index b47a7e1..eaf40d1 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -211,6 +211,7 @@ GENERIC_OBJS = \
regfree.$(OBJEXT) \
regerror.$(OBJEXT) \
tclAlloc.$(OBJEXT) \
+ tclAssembly.$(OBJEXT) \
tclAsync.$(OBJEXT) \
tclBasic.$(OBJEXT) \
tclBinary.$(OBJEXT) \
diff --git a/win/makefile.vc b/win/makefile.vc
index f04e193..9cf4769 100644
--- a/win/makefile.vc
+++ b/win/makefile.vc
@@ -247,6 +247,7 @@ COREOBJS = \
$(TMP_DIR)\regexec.obj \
$(TMP_DIR)\regfree.obj \
$(TMP_DIR)\tclAlloc.obj \
+ $(TMP_DIR)\tclAssembly.obj \
$(TMP_DIR)\tclAsync.obj \
$(TMP_DIR)\tclBasic.obj \
$(TMP_DIR)\tclBinary.obj \
diff --git a/win/tclWinFile.c b/win/tclWinFile.c
index 34be41f..dcefb3f 100644
--- a/win/tclWinFile.c
+++ b/win/tclWinFile.c
@@ -828,7 +828,7 @@ tclWinDebugPanic(
MB_ICONSTOP | MB_OK | MB_TASKMODAL | MB_SETFOREGROUND);
}
}
-
+
/*
*---------------------------------------------------------------------------
*
@@ -983,7 +983,7 @@ TclpMatchInDirectory(
}
attr = GetFileAttributes(native);
- if ((attr == INVALID_FILE_ATTRIBUTES)
+ if ((attr == INVALID_FILE_ATTRIBUTES)
|| ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0)) {
return TCL_OK;
}
@@ -2052,7 +2052,7 @@ NativeStat(
/*
* We might have just been denied access
*/
-
+
WIN32_FIND_DATA ffd;
HANDLE hFind;
hFind = FindFirstFile(nativePath, &ffd);
generated by cgit v0.12 at 2024-11-17 09:39:45 (GMT)