diff options
35 files changed, 8085 insertions, 92 deletions
@@ -1,5 +1,25 @@ 2011-03-01 Miguel Sofer <msofer@users.sf.net> + * generic/tclCompCmdsSZ.c (TclCompileThrowCmd) + (TclCompileUnsetCmd): fix leaks + + * generic/tclBasic.c: This is [Patch 3168398], + * generic/tclCompCmdsSZ.c: Joe Mistachkin's optimisation + * generic/tclExecute.c: of Tip #285 + * generic/tclInt.decls: + * generic/tclInt.h: + * generic/tclIntDecls.h: + * generic/tclInterp.c: + * generic/tclOODecls.h: + * generic/tclStubInit.c: + * win/makefile.vc: + + * generic/tclExecute.c (ExprObjCallback): fix object leak + + * generic/tclExecute.c (TEBCresume): store local var array and + constants in automatic vars to reduce indirection, slight perf + increase + * generic/tclOOCall.c (TclOODeleteContext): added missing '*' so that trunk compiles. @@ -181,6 +201,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. @@ -542,6 +572,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 @@ -569,6 +605,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]: @@ -684,6 +737,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 @@ -708,6 +778,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 @@ -743,6 +838,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 @@ -766,6 +890,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 @@ -827,6 +976,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/compat/fake-rfc2553.h b/compat/fake-rfc2553.h index 9bfdee0..a24b4aa 100644 --- a/compat/fake-rfc2553.h +++ b/compat/fake-rfc2553.h @@ -1,4 +1,4 @@ -/* $Id: fake-rfc2553.h,v 1.2 2010/09/28 15:14:57 rmax Exp $ */ +/* $Id: fake-rfc2553.h,v 1.2.2.2 2010/09/28 15:43:01 kennykb Exp $ */ /* * Copyright (C) 2000-2003 Damien Miller. All rights reserved. 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 d2c506d..f88ea27 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -826,6 +826,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, @@ -3235,28 +3242,29 @@ CancelEvalProc( if (iPtr != NULL) { /* - * Setting this flag will cause the script in progress to be - * canceled as soon as possible. The core honors this flag at all - * the necessary places to ensure script cancellation is + * Setting the CANCELED flag will cause the script in progress to + * be canceled as soon as possible. The core honors this flag at + * all the necessary places to ensure script cancellation is * responsive. Extensions can check for this flag by calling * Tcl_Canceled and checking if TCL_ERROR is returned or they can * choose to ignore the script cancellation flag and the - * associated functionality altogether. + * associated functionality altogether. Currently, the only other + * flag we care about here is the TCL_CANCEL_UNWIND flag (from + * Tcl_CancelEval). We do not want to simply combine all the flags + * from original Tcl_CancelEval call with the interp flags here + * just in case the caller passed flags that might cause behaviour + * unrelated to script cancellation. */ - iPtr->flags |= CANCELED; + TclSetCancelFlags(iPtr, cancelInfo->flags | CANCELED); /* - * Currently, we only care about the TCL_CANCEL_UNWIND flag from - * Tcl_CancelEval. We do not want to simply combine all the flags - * from original Tcl_CancelEval call with the interp flags here - * just in case the caller passed flags that might cause behaviour - * unrelated to script cancellation. + * Now, we must set the script cancellation flags on all the slave + * interpreters belonging to this one. */ - if (cancelInfo->flags & TCL_CANCEL_UNWIND) { - iPtr->flags |= TCL_CANCEL_UNWIND; - } + TclSetSlaveCancelFlags((Tcl_Interp *) iPtr, + cancelInfo->flags | CANCELED, 0); /* * Create the result object now so that Tcl_Canceled can avoid @@ -3785,7 +3793,15 @@ TclInterpReady( return TCL_ERROR; } - if (iPtr->execEnvPtr->rewind || + if (iPtr->execEnvPtr->rewind) { + return TCL_ERROR; + } + + /* + * Make sure the script being evaluated (if any) has not been canceled. + */ + + if (TclCanceled(iPtr) && (TCL_OK != Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG))) { return TCL_ERROR; } @@ -3835,7 +3851,7 @@ TclResetCancellation( } if (force || (iPtr->numLevels == 0)) { - iPtr->flags &= (~(CANCELED | TCL_CANCEL_UNWIND)); + TclUnsetCancelFlags(iPtr); } return TCL_OK; } @@ -3873,21 +3889,12 @@ Tcl_Canceled( register Interp *iPtr = (Interp *) interp; /* - * Traverse up the to the top-level interp, checking for the CANCELED flag - * along the way. If any of the intervening interps have the CANCELED flag - * set, the current script in progress is considered to be canceled and we - * stop checking. Otherwise, if any interp has the DELETED flag set we - * stop checking. - */ - - for (; iPtr!=NULL; iPtr = (Interp *) Tcl_GetMaster((Tcl_Interp *) iPtr)) { - /* * Has the current script in progress for this interpreter been * canceled or is the stack being unwound due to the previous script * cancellation? */ - if ((iPtr->flags & CANCELED) || (iPtr->flags & TCL_CANCEL_UNWIND)) { + if (TclCanceled(iPtr)) { /* * The CANCELED flag is a one-shot flag that is reset immediately * upon being detected; however, if the TCL_CANCEL_UNWIND flag is @@ -3955,20 +3962,6 @@ Tcl_Canceled( return TCL_ERROR; } - } else { - /* - * FIXME: If this interpreter is being deleted we cannot continue - * to traverse up the interp chain due to an issue with - * Tcl_GetMaster (really the slave interp bookkeeping) that causes - * us to run off into a freed interp struct. Ideally, this check - * would not be necessary because Tcl_GetMaster would return NULL - * instead of a pointer to invalid (freed) memory. - */ - - if (iPtr->flags & DELETED) { - break; - } - } } return TCL_OK; @@ -4365,7 +4358,7 @@ NRCommand( if (TclAsyncReady(iPtr)) { result = Tcl_AsyncInvoke(interp, result); } - if (result == TCL_OK) { + if ((result == TCL_OK) && TclCanceled(iPtr)) { result = Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG); } if (result == TCL_OK && TclLimitReady(iPtr->limit)) { @@ -4494,7 +4487,7 @@ TEOV_Exception( * here directly. */ - iPtr->flags &= (~(CANCELED | TCL_CANCEL_UNWIND)); + TclUnsetCancelFlags(iPtr); return result; } @@ -6197,7 +6190,7 @@ TEOEx_ByteCodeCallback( * Let us just unset the flags inline. */ - iPtr->flags &= (~(CANCELED | TCL_CANCEL_UNWIND)); + TclUnsetCancelFlags(iPtr); } iPtr->evalFlags = 0; diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 3528bab..807c3e4 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -393,7 +393,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. */ @@ -479,7 +479,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/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 2f86be1..348098b 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -1863,6 +1863,7 @@ TclCompileThrowCmd( CompileWord(envPtr, msgToken, interp, 2); TclCompileSyntaxError(interp, envPtr); + Tcl_DecrRefCount(objPtr); return TCL_OK; } if (len == 0) { @@ -2586,6 +2587,7 @@ TclCompileUnsetCmd( * evaluation with reasonable effort, so spill to interpreted version. */ + TclDecrRefCount(leadingWord); return TCL_ERROR; } TclDecrRefCount(leadingWord); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 8561bd4..d34b364 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -1407,7 +1407,6 @@ ExprObjCallback( if (result == TCL_OK) { TclSetDuplicateObj(resultPtr, Tcl_GetObjResult(interp)); - Tcl_IncrRefCount(resultPtr); Tcl_SetObjResult(interp, saveObjPtr); } TclDecrRefCount(saveObjPtr); @@ -2053,8 +2052,12 @@ TEBCresume( int traceInstructions; /* Whether we are doing instruction-level * tracing or not. */ #endif -#define LOCAL(i) (&iPtr->varFramePtr->compiledLocals[(i)]) -#define TCONST(i) (iPtr->execEnvPtr->constants[(i)]) + + Var *compiledLocals = iPtr->varFramePtr->compiledLocals; + Tcl_Obj **constants = &iPtr->execEnvPtr->constants[0]; + +#define LOCAL(i) (&compiledLocals[(i)]) +#define TCONST(i) (constants[(i)]) /* * These macros are just meant to save some global variables that are not @@ -2077,10 +2080,6 @@ TEBCresume( * stack. */ const unsigned char *pc; /* The current program counter. */ -#ifdef TCL_COMPILE_DEBUG - traceInstructions = (tclTraceExec == 3); -#endif - /* * Transfer variables - needed only between opcodes, but not while * executing an instruction. @@ -2097,12 +2096,17 @@ TEBCresume( Tcl_Obj *objPtr, *valuePtr, *value2Ptr, *part1Ptr, *part2Ptr, *tmpPtr; Tcl_Obj **objv; - int opnd, objc, length, pcAdjustment; + int objc = 0; + int opnd, length, pcAdjustment; Var *varPtr, *arrayPtr; #ifdef TCL_COMPILE_DEBUG char cmdNameBuf[21]; #endif +#ifdef TCL_COMPILE_DEBUG + traceInstructions = (tclTraceExec == 3); +#endif + NR_DATA_DIG(); #ifdef TCL_COMPILE_DEBUG @@ -2277,9 +2281,11 @@ TEBCresume( } } - if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) { - CACHE_STACK_INFO(); - goto gotError; + if (TclCanceled(iPtr)) { + if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) { + CACHE_STACK_INFO(); + goto gotError; + } } if (TclLimitReady(iPtr->limit)) { @@ -6300,7 +6306,7 @@ TEBCresume( * already be set prior to vectoring down to this point in the code. */ - if (Tcl_Canceled(interp, 0) == TCL_ERROR) { + if (TclCanceled(iPtr) && (Tcl_Canceled(interp, 0) == TCL_ERROR)) { #ifdef TCL_COMPILE_DEBUG if (traceInstructions) { fprintf(stdout, " ... cancel with unwind, returning %s\n", diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 61f25d8..d39634e 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -1002,6 +1002,11 @@ declare 249 { int* decpt, int* signum, char** endPtr) } +# TIP #285: Script cancellation support. +declare 250 { + void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags, int force) +} + ############################################################################## # Define the platform specific internal Tcl interface. These functions are diff --git a/generic/tclInt.h b/generic/tclInt.h index f759593..5069ffc 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2184,6 +2184,22 @@ typedef struct Interp { *((iPtr)->asyncReadyPtr) /* + * Macros for script cancellation support (TIP #285). + */ + +#define TclCanceled(iPtr) \ + (((iPtr)->flags & CANCELED) || ((iPtr)->flags & TCL_CANCEL_UNWIND)) + +#define TclSetCancelFlags(iPtr, cancelFlags) \ + (iPtr)->flags |= CANCELED; \ + if ((cancelFlags) & TCL_CANCEL_UNWIND) { \ + (iPtr)->flags |= TCL_CANCEL_UNWIND; \ + } + +#define TclUnsetCancelFlags(iPtr) \ + (iPtr)->flags &= (~(CANCELED | TCL_CANCEL_UNWIND)) + +/* * General list of interpreters. Doubly linked for easier removal of items * deep in the list. */ @@ -3196,6 +3212,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[]); @@ -3688,6 +3713,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/tclIntDecls.h b/generic/tclIntDecls.h index cae5e4e..23f500f 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -600,6 +600,9 @@ EXTERN int TclCopyChannel(Tcl_Interp *interp, /* 249 */ EXTERN char* TclDoubleDigits(double dv, int ndigits, int flags, int*decpt, int*signum, char**endPtr); +/* 250 */ +EXTERN void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags, + int force); typedef struct TclIntStubs { int magic; @@ -855,6 +858,7 @@ typedef struct TclIntStubs { void (*tclResetRewriteEnsemble) (Tcl_Interp *interp, int isRootEnsemble); /* 247 */ int (*tclCopyChannel) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr); /* 248 */ char* (*tclDoubleDigits) (double dv, int ndigits, int flags, int*decpt, int*signum, char**endPtr); /* 249 */ + void (*tclSetSlaveCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */ } TclIntStubs; #ifdef __cplusplus @@ -1277,6 +1281,8 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclCopyChannel) /* 248 */ #define TclDoubleDigits \ (tclIntStubsPtr->tclDoubleDigits) /* 249 */ +#define TclSetSlaveCancelFlags \ + (tclIntStubsPtr->tclSetSlaveCancelFlags) /* 250 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 6ccde87..bfcc383 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -2096,6 +2096,72 @@ Tcl_GetMaster( /* *---------------------------------------------------------------------- * + * TclSetSlaveCancelFlags -- + * + * This function marks all slave interpreters belonging to a given + * interpreter as being canceled or not canceled, depending on the + * provided flags. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclSetSlaveCancelFlags( + Tcl_Interp *interp, /* Set cancel flags of this interpreter. */ + int flags, /* Collection of OR-ed bits that control + * the cancellation of the script. Only + * TCL_CANCEL_UNWIND is currently + * supported. */ + int force) /* Non-zero to ignore numLevels for the purpose + * of resetting the cancellation flags. */ +{ + Master *masterPtr; /* Master record of given interpreter. */ + Tcl_HashEntry *hPtr; /* Search element. */ + Tcl_HashSearch hashSearch; /* Search variable. */ + Slave *slavePtr; /* Slave record of interpreter. */ + Interp *iPtr; + + if (interp == NULL) { + return; + } + + flags &= (CANCELED | TCL_CANCEL_UNWIND); + + masterPtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->master; + + hPtr = Tcl_FirstHashEntry(&masterPtr->slaveTable, &hashSearch); + for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) { + slavePtr = Tcl_GetHashValue(hPtr); + iPtr = (Interp *) slavePtr->slaveInterp; + + if (iPtr == NULL) { + continue; + } + + if (flags == 0) { + TclResetCancellation((Tcl_Interp *) iPtr, force); + } else { + TclSetCancelFlags(iPtr, flags); + } + + /* + * Now, recursively handle this for the slaves of this slave + * interpreter. + */ + + TclSetSlaveCancelFlags((Tcl_Interp *) iPtr, flags, force); + } +} + +/* + *---------------------------------------------------------------------- + * * Tcl_GetInterpPath -- * * Sets the result of the asking interpreter to a proper Tcl list @@ -2717,6 +2783,16 @@ SlaveEval( { int result; + /* + * TIP #285: If necessary, reset the cancellation flags for the slave + * interpreter now; otherwise, canceling a script in a master interpreter + * can result in a situation where a slave interpreter can no longer + * evaluate any scripts unless somebody calls the TclResetCancellation + * function for that particular Tcl_Interp. + */ + + TclSetSlaveCancelFlags(slaveInterp, 0, 0); + Tcl_Preserve(slaveInterp); Tcl_AllowExceptions(slaveInterp); diff --git a/generic/tclMain.c b/generic/tclMain.c index 4f992e5..f1a6ce7 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -652,7 +652,7 @@ Tcl_MainEx( Tcl_Release(interp); Tcl_Exit(exitCode); } - + #ifndef UNICODE void Tcl_Main( diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index 697570d..161be09 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -24,7 +24,7 @@ * in the generic/tclOO.decls script. */ -#if defined(USE_TCLOO_STUBS) +#if defined(USE_TCL_STUBS) extern const char *TclOOInitializeStubs(Tcl_Interp *, const char *version); #define Tcl_OOInitStubs(interp) TclOOInitializeStubs((interp),TCLOO_VERSION) #else diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 98ef9b7..542e604 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -306,6 +306,7 @@ static const TclIntStubs tclIntStubs = { TclResetRewriteEnsemble, /* 247 */ TclCopyChannel, /* 248 */ TclDoubleDigits, /* 249 */ + TclSetSlaveCancelFlags, /* 250 */ }; static const TclIntPlatStubs tclIntPlatStubs = { diff --git a/generic/tclTomMath.decls b/generic/tclTomMath.decls index 0bd5ca5..4f6bc70 100644 --- a/generic/tclTomMath.decls +++ b/generic/tclTomMath.decls @@ -219,4 +219,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 f746aed..3a42a32 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -2268,7 +2268,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 e429b86..dfa58ea 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -1229,7 +1229,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 d053516..21afbfb 100644 --- a/tests/append.test +++ b/tests/append.test @@ -18,7 +18,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 @@ -294,7 +294,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 d8eee8c..9d1e3a5 100644 --- a/tests/appendComp.test +++ b/tests/appendComp.test @@ -18,7 +18,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 { @@ -440,7 +440,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 51cf64c..49df0aa 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -28,7 +28,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} @@ -707,7 +707,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 c5de6e8..bfb3e26 100644 --- a/tests/execute.test +++ b/tests/execute.test @@ -35,7 +35,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 a5770aa..ee7c5b3 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -172,7 +172,7 @@ append long $long append long $long append long $long append long $long - + test fCmd-1.1 {TclFileRenameCmd} -constraints {notRoot} -setup { cleanup } -body { @@ -2583,7 +2583,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 c67dcf7..6057f51 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -3569,7 +3569,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 c4fd71d..f5358c7 100644 --- a/tests/ioTrans.test +++ b/tests/ioTrans.test @@ -102,7 +102,7 @@ set helperscript { eval $helperscript #puts <<[file channels]>> - + # ### ### ### ######### ######### ######### test iortrans-1.0 {chan, wrong#args} -returnCodes error -body { @@ -1036,7 +1036,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. @@ -1862,7 +1862,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 40f6b82..527b7b7 100644 --- a/tests/iogt.test +++ b/tests/iogt.test @@ -354,7 +354,7 @@ proc asort {alist} { array set a $alist array_sget a } - + ######################################################################## test iogt-1.1 {stack/unstack} testchannel { @@ -793,7 +793,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 0413a47..264edbe 100644 --- a/tests/uplevel.test +++ b/tests/uplevel.test @@ -26,7 +26,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 @@ -197,7 +197,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 22e03ee..b16fa28 100644 --- a/tests/util.test +++ b/tests/util.test @@ -3868,4 +3868,4 @@ return # Local Variables: # mode: tcl -# End:
\ No newline at end of file +# End: diff --git a/tests/winPipe.test b/tests/winPipe.test index 632f8e7..eeb69fa 100644 --- a/tests/winPipe.test +++ b/tests/winPipe.test @@ -59,7 +59,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)] @@ -426,7 +426,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 0d6d337..2283c0b 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -308,7 +308,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 @@ -384,6 +385,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 \ @@ -452,6 +454,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 = \ @@ -1012,6 +1015,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 f567447..db86d61 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -523,7 +523,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); @@ -660,7 +660,7 @@ TcpGetOptionProc( Tcl_DStringAppendElement(dsPtr, "-peername"); Tcl_DStringStartSublist(dsPtr); } - + getnameinfo(&peername.sa, size, host, sizeof(host), NULL, 0, NI_NUMERICHOST); Tcl_DStringAppendElement(dsPtr, host); @@ -1319,7 +1319,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 01adbdb..499f06d 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -213,6 +213,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 988d823..403c9e6 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -250,6 +250,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 \ @@ -494,11 +495,11 @@ STUB_CFLAGS = $(cflags) $(cdebug) $(OPTDEFINES) #--------------------------------------------------------------------- !if $(DEBUG) -ldebug = -debug:full -debugtype:cv +ldebug = -debug -debugtype:cv !else ldebug = -release -opt:ref -opt:icf,3 !if $(SYMBOLS) -ldebug = $(ldebug) -debug:full -debugtype:cv +ldebug = $(ldebug) -debug -debugtype:cv !endif !endif @@ -831,7 +832,7 @@ $(OUT_DIR)\tclConfig.sh: $(WINDIR)\tclConfig.sh.in @DEFS@ $(TCL_CFLAGS) @CFLAGS_DEBUG@ -nologo -c -W3 -YX -Fp$(TMP_DIR)\ -MDd @CFLAGS_OPTIMIZE@ -nologo -c -W3 -YX -Fp$(TMP_DIR)\ -MD -@LDFLAGS_DEBUG@ -nologo -machine:$(MACHINE) -debug:full -debugtype:cv +@LDFLAGS_DEBUG@ -nologo -machine:$(MACHINE) -debug -debugtype:cv @LDFLAGS_OPTIMIZE@ -nologo -machine:$(MACHINE) -release -opt:ref -opt:icf,3 @TCL_DBGX@ $(SUFX) @TCL_LIB_FILE@ $(PROJECT)$(VERSION)$(SUFX).lib diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 93c79eb..bdf2b04 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -830,7 +830,7 @@ tclWinDebugPanic( MB_ICONSTOP | MB_OK | MB_TASKMODAL | MB_SETFOREGROUND); } } - + /* *--------------------------------------------------------------------------- * @@ -985,7 +985,7 @@ TclpMatchInDirectory( } attr = GetFileAttributes(native); - if ((attr == INVALID_FILE_ATTRIBUTES) + if ((attr == INVALID_FILE_ATTRIBUTES) || ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0)) { return TCL_OK; } @@ -2054,7 +2054,7 @@ NativeStat( /* * We might have just been denied access */ - + WIN32_FIND_DATA ffd; HANDLE hFind; hFind = FindFirstFile(nativePath, &ffd); |