From a65bf10cd7e281f19056e37d4bab5dae217c6394 Mon Sep 17 00:00:00 2001 From: Kevin B Kenny Date: Sat, 25 Sep 2010 14:51:11 +0000 Subject: * tclAssembly.c: Massive refactoring of the assembler * 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. --- ChangeLog | 64 ++ generic/tclAssembly.c | 1942 ++++++++++++++++++++++++++++++++----------------- generic/tclAssembly.h | 13 +- generic/tclCmdAH.c | 3 +- generic/tclDecls.h | 6 +- generic/tclEvent.c | 3 +- generic/tclExecute.c | 212 +++--- generic/tclMain.c | 3 +- tests/assemble.test | 655 +++++++++++------ tests/assemble1.bench | 113 +-- tests/execute.test | 23 +- tests/stringComp.test | 320 ++++---- unix/Makefile.in | 16 +- unix/tclAppInit.c | 79 +- win/configure | 2 +- win/tcl.m4 | 2 +- win/tclAppInit.c | 165 +++-- win/tclWinSock.c | 48 +- 18 files changed, 2318 insertions(+), 1351 deletions(-) diff --git a/ChangeLog b/ChangeLog index 3babd85..31b889f 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,67 @@ +2010-09-25 Kevin B. Kenny + + [dogeen-assembler-branch] + + * tclAssembly.c: Massive refactoring of the assembler + * 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 + + * tests/stringComp.test: improved string eq/cmp test coverage + * generic/tclExecute.c (TclExecuteByteCode): merge INST_STR_CMP + and INST_STR_EQ/INST_STR_NEQ paths. Speeds up eq/ne/[string eq] + with obj-aware comparisons and eq/==/ne/!= with length equality + check. + +2010-09-24 Andreas Kupries + + * tclWinsock.c: [Bug 3056775]: Fixed race condition between thread + and internal co-thread access of a socket's structure because of + the thread not using the socketListLock in TcpAccept(). Added + documentation on how the module works to the top. + +2010-09-23 Jan Nijtmans + + * generic/tclDecls.h: Make Tcl_SetPanicProc and Tcl_GetStringResult + * unix/tclAppInit.c: callable without stubs, just as Tcl_SetVar. + * win/tclAppInit.c: + +2010-09-23 Don Porter + + * generic/tclCmdAH.c: Fix cases where value returned by + * generic/tclEvent.c: Tcl_GetReturnOptions() was leaked. + * generic/tclMain.c: Thanks to Jeff Hobbs for discovery of the + anti-pattern to seek and destroy. + +2010-09-23 Jan Nijtmans + + * unix/tclAppInit.c: Make compilable with -DUNICODE (not + * win/tclAppInit.c: actived yet), many clean-ups in comments. + +2010-09-22 Miguel Sofer + + * generic/tclExecute: one more DECACHE_STACK_INFO() missing; this + fixes [Bug 3072640] + + * tests/execute.test: added execute-10.3 for [Bug 3072640]. The + test causes a mem failure. + + * generic/tclExecute: protect all possible writes to ::errorInfo + or ::errorCode with DECACHE_STACK_INFO(), as they could run + traces. The new calls to be protected are Tcl_ResetResult(), + Tcl_SetErrorCode(), IllegalExprOperandType(), + TclExprFloatError(). The error was triggered by [Patch 3072080]. + +2010-09-22 Jan Nijtmans + + * win/tcl.m4: Add kernel32 to LIBS, so the link line for mingw + * win/configure: is exactly the same as for MSVC++. + 2010-09-21 Jeff Hobbs * generic/tclExecute.c (TclExecuteByteCode): diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 7063b8a..40e79f5 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -3,38 +3,73 @@ #include "tclAssembly.h" #include "tclOOInt.h" + +/* Structure that holds the state of the assembler while generating code */ + +typedef struct AssembleEnv { + 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] */ + + /* TODO: Next table could be a simple list keyed off memory address? + * Or the BB pointers could be in the 'label' struct */ + Tcl_HashTable BBHash; /* Hash table whose keys are labels and + * whose values are BasicBlock structure + * pointers for the basic blocks at those + * locations */ + BasicBlock* head_bb; /* First basic block in the code */ + BasicBlock* curr_bb; /* Current basic block */ + + int maxDepth; /* Maximum stack depth encountered */ + int flags; /* Compilation flags (TCL_EVAL_DIRECT) */ +} AssembleEnv; + /* Static functions defined in this file */ -static void AddBasicBlockRangeToErrorInfo(Tcl_Interp* interp, Tcl_Obj* bcList, - BasicBlock* bbPtr); +static void AddBasicBlockRangeToErrorInfo(AssembleEnv*, BasicBlock*); static void AddInstructionToErrorInfo(Tcl_Interp* interp, Tcl_Obj* bcList, int index); -static BasicBlock * AllocBB(CompileEnv*, int); -static int CheckNamespaceQualifiers(Tcl_Interp*, const char*); +static BasicBlock * AllocBB(AssembleEnv*); +static int AssembleOneLine(AssembleEnv* envPtr); +static int CheckNamespaceQualifiers(Tcl_Interp*, const char*, int); static int CheckOneByte(Tcl_Interp*, int); static int CheckSignedOneByte(Tcl_Interp*, int); -static int StackCheckBasicBlock(StackCheckerState* , BasicBlock *, BasicBlock *, int); -static BasicBlock* StartBasicBlock(CompileEnv* envPtr, Tcl_HashTable* BBHash, - BasicBlock* currBB, int fallsThrough, - int bcIndex, const char* jumpLabel); - -static int CheckStack(Tcl_Interp*, CompileEnv*, BasicBlock *, Tcl_Obj*); -static void FreeAssembleCodeInternalRep(Tcl_Obj *objPtr); +static int CheckStack(AssembleEnv*); static ByteCode * CompileAssembleObj(Tcl_Interp *interp, Tcl_Obj *objPtr); -static int DefineLabel(Tcl_Interp* interp, CompileEnv* envPtr, - const char* label, Tcl_HashTable* labelHash); +static int DefineLabel(AssembleEnv* envPtr, const char* label); +static int FindLocalVar(AssembleEnv* envPtr, Tcl_Token** tokenPtrPtr); +static int FinishAssembly(AssembleEnv*); +static void FreeAssembleCodeInternalRep(Tcl_Obj *objPtr); +static void FreeAssembleEnv(AssembleEnv*); +static int GetBooleanOperand(AssembleEnv*, Tcl_Token**, int*); +static int GetIntegerOperand(AssembleEnv*, Tcl_Token**, int*); +static int GetNextOperand(AssembleEnv*, Tcl_Token**, Tcl_Obj**); +static AssembleEnv* NewAssembleEnv(CompileEnv*, int); +static int StackCheckBasicBlock(AssembleEnv*, BasicBlock *, BasicBlock *, int); +static BasicBlock* StartBasicBlock(AssembleEnv*, int fallthrough, + const char* jumpLabel); +/* static int AdvanceIp(const unsigned char *pc); */ +static int StackCheckBasicBlock(AssembleEnv*, BasicBlock *, BasicBlock *, int); +static void SyncStackDepth(AssembleEnv*); + +/* Tcl_ObjType that describes bytecode emitted by the assembler */ static const Tcl_ObjType assembleCodeType = { "assemblecode", - FreeAssembleCodeInternalRep, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - NULL, /* updateStringProc */ - NULL /* setFromAnyProc */ + FreeAssembleCodeInternalRep, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + NULL, /* updateStringProc */ + NULL /* setFromAnyProc */ }; -/* static int AdvanceIp(const unsigned char *pc); */ -static int StackCheckBasicBlock(StackCheckerState* , BasicBlock *, BasicBlock *, int); - /* * TIP #280: Remember the per-word line information of the current command. An * index is used instead of a pointer as recursive compilation may reallocate, @@ -80,8 +115,9 @@ talInstDesc talInstructionTable[] = { ASSEM_1BYTE, INST_APPEND_STK, 2, 1}, {"concat", ASSEM_CONCAT1, INST_CONCAT1, INT_MIN,1}, - {"eval", ASSEM_EVAL, 0, 0, 1}, + {"eval", ASSEM_EVAL, INST_EVAL_STK, 0, 1}, {"evalStk", ASSEM_1BYTE, INST_EVAL_STK, 1, 1}, + {"expr", ASSEM_EVAL, INST_EXPR_STK, 0, 1}, {"exprStk", ASSEM_1BYTE, INST_EXPR_STK, 1, 1}, {"exist", ASSEM_LVT4, INST_EXIST_SCALAR, 0, 1}, @@ -336,11 +372,15 @@ BBUpdateStackReqs(BasicBlock* bbPtr, */ static void -BBEmitOpcode(CompileEnv* envPtr,/* Compilation environment */ - BasicBlock* bbPtr, /* Basic block to which the op belongs */ +BBEmitOpcode(AssembleEnv* 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 0 fprintf(stderr, "Emit %s (%d)\n", tclInstructionTable[op].name, count); @@ -351,29 +391,25 @@ BBEmitOpcode(CompileEnv* envPtr,/* Compilation environment */ BBUpdateStackReqs(bbPtr, tblind, count); } static void -BBEmitInstInt1(CompileEnv* envPtr, - /* Compilation environment */ - BasicBlock* bbPtr, - /* basic block to which the op belongs */ +BBEmitInstInt1(AssembleEnv* assemEnvPtr, + /* Assembly environment */ int tblind, /* Index in talInstructionTable of op */ unsigned char opnd, /* 1-byte operand */ int count) /* Operand count for variadic ops */ { - BBEmitOpcode(envPtr, bbPtr, tblind, count); - TclEmitInt1(opnd, envPtr); + BBEmitOpcode(assemEnvPtr, tblind, count); + TclEmitInt1(opnd, assemEnvPtr->envPtr); } static void -BBEmitInstInt4(CompileEnv* envPtr, - /* Compilation environment */ - BasicBlock* bbPtr, - /* basic block to which the op belongs */ +BBEmitInstInt4(AssembleEnv* assemEnvPtr, + /* Assembly environment */ int tblind, /* Index in talInstructionTable of op */ int opnd, /* 4-byte operand */ int count) /* Operand count for variadic ops */ { - BBEmitOpcode(envPtr, bbPtr, tblind, count); - TclEmitInt4(opnd, envPtr); + BBEmitOpcode(assemEnvPtr, tblind, count); + TclEmitInt4(opnd, assemEnvPtr->envPtr); } /* @@ -388,14 +424,16 @@ BBEmitInstInt4(CompileEnv* envPtr, */ static void -BBEmitInst1or4(CompileEnv* envPtr, - /* Compilation environment */ - BasicBlock* bbPtr, - /* Basic block under construction */ +BBEmitInst1or4(AssembleEnv* 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) { @@ -417,6 +455,23 @@ BBEmitInst1or4(CompileEnv* envPtr, 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. */ @@ -424,9 +479,13 @@ Tcl_AssembleObjCmd( 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. */ @@ -434,50 +493,75 @@ TclNRAssembleObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Obj *objPtr; - ByteCode *codePtr; + ByteCode *codePtr; /* Pointer to the bytecode to execute */ + Tcl_Obj* backtrace; /* Object where extra error information + * is constructed. */ -#if 0 - int i; - fprintf(stderr, "TclNRAssembleObjCmd:"); - for (i=0; i < objc; ++i) { - fprintf(stderr, " {%s}", Tcl_GetString(objv[i])); - } - fprintf(stderr, "\n"); fflush(stderr); -#endif + /* Check args */ if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "bytecodeList"); return TCL_ERROR; } - objPtr = objv[1]; - codePtr = CompileAssembleObj(interp, objPtr); + /* 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; } -#if 0 - fprintf(stderr, "bytecode: %p\n", codePtr); -#endif + /* Use NRE to evaluate the bytecode from the trampoline */ + Tcl_NRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_BC_TYPE), codePtr, NULL, NULL); return TCL_OK; } - + +/* + *----------------------------------------------------------------------------- + * + * 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_Obj *objPtr) + Tcl_Interp *interp, /* Tcl interpreter */ + Tcl_Obj *objPtr) /* Source code to assemble */ { Interp *iPtr = (Interp *) interp; - CompileEnv compEnv; /* Compilation environment structure allocated - * in frame. */ + /* Internals of the interpreter */ + CompileEnv compEnv; /* Compilation environment structure */ register ByteCode *codePtr = NULL; - /* Tcl Internal type of bytecode. Initialized - * to avoid compiler warning. */ + /* 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 @@ -485,8 +569,7 @@ CompileAssembleObj( */ if (objPtr->typePtr == &assembleCodeType) { - Namespace *namespacePtr = iPtr->varFramePtr->nsPtr; - + namespacePtr = iPtr->varFramePtr->nsPtr; codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) @@ -499,34 +582,17 @@ CompileAssembleObj( } if (objPtr->typePtr != &assembleCodeType) { - int length; - - const char *string = TclGetStringFromObj(objPtr, &length); - TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0); -#if 0 - fprintf(stderr, "assembling: %s\n", string); fflush(stderr); -#endif - status = TclAssembleCode(interp, objPtr, &compEnv, TCL_EVAL_DIRECT); + /* 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) { -#if 0 - fprintf(stderr, "assembly failed: %s\n", - Tcl_GetString(Tcl_GetObjResult(interp))); - fflush(stderr); -#endif - /* FIXME - there's memory to clean up */ - return NULL; - } - /* - * Successful compilation. If the expression yielded no instructions, - * push an zero object as the expression's result. - */ + /* Assembly failed. Clean up and report the error */ - if (compEnv.codeNext == compEnv.codeStart) { - fprintf(stderr, "empty bytecode, why did this happen?\n"); - fflush(stderr); - TclEmitPush(TclRegisterNewLiteral(&compEnv, "0", 1), - &compEnv); + TclFreeCompileEnv(&compEnv); + return NULL; } /* @@ -539,11 +605,19 @@ CompileAssembleObj( 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); @@ -553,7 +627,7 @@ CompileAssembleObj( } return codePtr; } - + /* *----------------------------------------------------------------------------- * @@ -585,7 +659,6 @@ int TclCompileAssembleCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *tokenPtr; /* Token in the input script */ - Tcl_Obj *bcList; /* List of assembly instructions to process */ int status; /* Status return from assembling the code */ /* Make sure that the command has a single arg */ @@ -603,10 +676,7 @@ int TclCompileAssembleCmd( /* Compile the code and return any error from the compilation */ - bcList = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size); - Tcl_IncrRefCount(bcList); - status = TclAssembleCode(interp, bcList, envPtr, 0); - Tcl_DecrRefCount(bcList); + status = TclAssembleCode(envPtr, tokenPtr[1].start, tokenPtr[1].size, 0); return status; } @@ -632,543 +702,879 @@ int TclCompileAssembleCmd( */ MODULE_SCOPE int -TclAssembleCode(Tcl_Interp *interp, - /* Tcl interpreter */ - Tcl_Obj * bcList, - /* List of assembly instructions */ - CompileEnv *envPtr, +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 */ { - - int bcListLen = 0; /* Length of the assembly code list */ - Tcl_HashTable labelHash; /* Hashtable storing information about - * labels in the assembly code */ - Tcl_HashTable BBHash; /* Hashtable storing information about - * the basic blocks in the bytecode */ - - BasicBlock* curr_bb = NULL; /* Structure describing the current basic - * block */ - BasicBlock* head_bb = NULL; /* Structure describing the first basic - * block in the code */ - int ind; /* Index in the list of instructions */ - int result; /* Return value from this function */ - Tcl_Obj* bc; /* One assembly instruction from the list */ - int bcSize = 0; /* Length of the instruction sublist */ - Tcl_Obj ** bcArgs; /* Arguments to the instruction */ - char * instName; /* Name of the instruction */ - enum talInstType instType; /* Type of the current assembly instruction */ - unsigned char instCode; /* Opcode of the current assembly instruction */ - const char* operand1; /* First operand passed to the instruction */ - int operand1Len; /* Length of the first operand */ - int tblind = 0; /* Index in the instruction table of the - * current instruction */ - int isNew; /* Flag == 1 if a JUMP is the first - * occurrence of its associated label */ - Tcl_Obj* resultObj; /* Error message */ - int savedMaxStackDepth; /* Max stack depth saved around compilation - * calls */ - int savedCurrStackDepth; /* Current stack depth saved around - * compilation calls. */ - - int localVar, opnd = 0; - label *l; - Tcl_HashEntry * entry; - int litIndex; - - DefineLineInformation; /* TIP #280 */ /* eclIndex? */ - -#if 0 - fprintf(stderr, "Assembling: %s\n", Tcl_GetString(bcList)); - fflush(stderr); -#endif - - /* Test that the bytecode that we're given is a well formed list */ - - if (Tcl_ListObjLength(interp, bcList, &bcListLen) == TCL_ERROR) { - return TCL_ERROR; - } - - /* Initialize the symbol table and the table of basic blocks */ - - Tcl_InitHashTable(&labelHash, TCL_STRING_KEYS); - Tcl_InitHashTable(&BBHash, TCL_STRING_KEYS); - - /* Allocate a structure to describe the first basic block */ - - curr_bb = AllocBB(envPtr, 0); - head_bb = curr_bb; - + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ /* - * Index through the assembly directives and instructions, generating code. + * Walk through the assembly script using the Tcl parser. + * Each 'command' will be an instruction or assembly directive. */ - for (ind = 0; ind < bcListLen; ind++) { + 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 */ - /* Extract the instruction name from a list element */ + AssembleEnv* assemEnvPtr = NewAssembleEnv(envPtr, flags); + Tcl_Parse* parsePtr = assemEnvPtr->parsePtr; - result = TCL_OK; - if (Tcl_ListObjIndex(interp, bcList, ind, &bc) != TCL_OK - || Tcl_ListObjGetElements(interp, bc, &bcSize, &bcArgs) != TCL_OK) { - goto cleanup; - } - if (bcSize == 0) { - continue; - } - instName = Tcl_GetStringFromObj(bcArgs[0], NULL); -#if 0 - fprintf(stderr, "[%d] %s\n", - envPtr->codeNext - envPtr->codeStart, instName); - fflush(stderr); -#endif + do { - /* - * Extract the first operand, if there is one, and get its string - * representation - */ + /* Parse out one command line from the assembly script */ - if (bcSize >= 2) { - operand1 = Tcl_GetStringFromObj(bcArgs[1], &operand1Len); - } else { - operand1 = NULL; - operand1Len = 0; + status = Tcl_ParseCommand(interp, instPtr, bytesLeft, 0, parsePtr); + instLen = parsePtr->commandSize; + if (parsePtr->term == parsePtr->commandStart + instLen - 1) { + --instLen; } - /* Look up the instruction in the table of instructions */ + /* Report errors in the parse */ - if (Tcl_GetIndexFromObjStruct(interp, bcArgs[0], - &talInstructionTable[0].name, - sizeof(talInstDesc), "instruction", - TCL_EXACT, &tblind) != TCL_OK) { - goto cleanup; + if (status != TCL_OK) { + if (flags & TCL_EVAL_DIRECT) { + Tcl_LogCommandInfo(interp, codePtr, parsePtr->commandStart, + instLen); + } + FreeAssembleEnv(assemEnvPtr); + return TCL_ERROR; } - /* Vector on the type of instruction being processed */ - - instType = talInstructionTable[tblind].instType; - instCode = talInstructionTable[tblind].tclInstCode; - switch (instType) { + /* Advance the pointers around any leading commentary */ - case ASSEM_LABEL: - - if (bcSize != 2) { - Tcl_WrongNumArgs(interp, 1, bcArgs, "name"); - goto cleanup; - } - /* Add the (label_name, address) pair to the hash table */ - if (DefineLabel(interp, envPtr, operand1, &labelHash) != TCL_OK) { - goto cleanup; - } - - /* End the current basic block and start a new one */ + TclAdvanceLines(&assemEnvPtr->cmdLine, instPtr, parsePtr->commandStart); + TclAdvanceContinuations(&assemEnvPtr->cmdLine, &assemEnvPtr->clNext, + parsePtr->commandStart - envPtr->source); - curr_bb = StartBasicBlock(envPtr, &BBHash, curr_bb, 1, ind, NULL); + /* Process the line of code */ - /* Attach the label to the new basic block */ + if (parsePtr->numWords > 0) { - entry = Tcl_CreateHashEntry(&BBHash, operand1, &opnd); - Tcl_SetHashValue(entry, curr_bb); - - break; - - case ASSEM_1BYTE: - if (bcSize != 1) { - Tcl_WrongNumArgs(interp, 1, bcArgs, ""); - goto cleanup; - } - BBEmitOpcode(envPtr, curr_bb, tblind, 0); - break; + /* If tracing, show each line assembled as it happens */ - case ASSEM_INVOKE: - if (bcSize != 2) { - Tcl_WrongNumArgs(interp, 1, bcArgs, "count"); - goto cleanup; - } - if (Tcl_GetIntFromObj(interp, bcArgs[1], &opnd) != TCL_OK) { - goto cleanup; - } - BBEmitInst1or4(envPtr, curr_bb, tblind, opnd, opnd); - break; - - case ASSEM_JUMP: - if (bcSize != 2) { - Tcl_WrongNumArgs(interp, 1, bcArgs, "label"); - goto cleanup; - } - entry = Tcl_CreateHashEntry(&labelHash, operand1, &isNew); - if (isNew) { - l = (label *) ckalloc(sizeof(label)); - l -> isDefined = 0; - l -> offset = -1; - Tcl_SetHashValue(entry, l); - } else { - l = Tcl_GetHashValue(entry); +#ifdef TCL_COMPILE_DEBUG + if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) { + printf(" Assembling: "); + TclPrintSource(stdout, parsePtr->commandStart, + TclMin(instLen, 55)); + printf("\n"); } - if (l -> isDefined) { - BBEmitInst1or4(envPtr, curr_bb, tblind, - l->offset + envPtr->codeStart - - envPtr->codeNext, 0); - } else { - int here = envPtr->codeNext - envPtr->codeStart; - BBEmitInstInt4(envPtr, curr_bb, tblind, - l->offset, 0); -#if 0 - fprintf(stderr, "forward ref to %s, prev at %d, link %d\n", - operand1, l->offset, here); #endif - l->offset = here; - } - - /* Start a new basic block at the instruction following the jump */ - - curr_bb = - StartBasicBlock(envPtr, &BBHash, curr_bb, - talInstructionTable[tblind].operandsConsumed, - ind+1, operand1); - - break; - - case ASSEM_LVT: - if (bcSize != 2) { - Tcl_WrongNumArgs(interp, 1, bcArgs, "varname"); - goto cleanup; - } - if (CheckNamespaceQualifiers(interp, operand1)) { - goto cleanup; - } - localVar = TclFindCompiledLocal(operand1, operand1Len, 1, envPtr); - if (localVar == -1) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("cannot use this instruction" - " in non-proc context", -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", NULL); - goto cleanup; - } - fprintf(stderr, "operand %s in slot %d\n", operand1, localVar); - BBEmitInst1or4(envPtr, curr_bb, tblind, localVar, 0); - break; - - case ASSEM_LVT1: - if (bcSize != 2) { - Tcl_WrongNumArgs(interp, 1, bcArgs, "varname"); - goto cleanup; - } - if (CheckNamespaceQualifiers(interp, operand1)) { - goto cleanup; - } - localVar = TclFindCompiledLocal(operand1, operand1Len, 1, envPtr); - if (localVar == -1) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("cannot use this instruction" - " in non-proc context", -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", NULL); - goto cleanup; - } - if (CheckOneByte(interp, localVar)) { - goto cleanup; - } - BBEmitInstInt1(envPtr, curr_bb, tblind, localVar, 0); - break; - - case ASSEM_LVT4: - if (bcSize != 2) { - Tcl_WrongNumArgs(interp, 1, bcArgs, "varname"); - goto cleanup; - } - if (CheckNamespaceQualifiers(interp, operand1)) { - goto cleanup; - } - localVar = TclFindCompiledLocal(operand1, operand1Len, 1, envPtr); - if (localVar == -1) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("cannot use this instruction" - " in non-proc context", -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", NULL); - goto cleanup; - } - BBEmitInstInt4(envPtr, curr_bb, tblind, localVar, 0); - break; - - case ASSEM_BOOL: - if (bcSize != 2) { - Tcl_WrongNumArgs(interp, 1, bcArgs, "boolean"); - goto cleanup; - } - if (Tcl_GetBooleanFromObj(interp, bcArgs[1], &opnd) != TCL_OK) { - goto cleanup; - } - BBEmitInstInt1(envPtr, curr_bb, tblind, opnd, 0); - break; - - case ASSEM_BOOL_LVT4: - if (bcSize != 3) { - Tcl_WrongNumArgs(interp, 1, bcArgs, "boolean varName"); - goto cleanup; - } - if (Tcl_GetBooleanFromObj(interp, bcArgs[1], &opnd) != TCL_OK) { - goto cleanup; - } - operand1 = Tcl_GetStringFromObj(bcArgs[2], &operand1Len); - if (CheckNamespaceQualifiers(interp, operand1)) { - goto cleanup; - } - localVar = TclFindCompiledLocal(operand1, operand1Len, 1, envPtr); - if (localVar == -1) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("cannot use this instruction" - " in non-proc context", -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", NULL); - goto cleanup; - } - BBEmitInstInt1(envPtr, curr_bb, tblind, opnd, 0); - TclEmitInt4(localVar, envPtr); - break; - - case ASSEM_LVT1_SINT1: - if (bcSize != 3) { - Tcl_WrongNumArgs(interp, 1, bcArgs, "varName imm8"); - goto cleanup; - } - if (CheckNamespaceQualifiers(interp, operand1)) { - goto cleanup; - } - localVar = TclFindCompiledLocal(operand1, operand1Len, 1, envPtr); - if (localVar == -1) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("cannot use this instruction" - " in non-proc context", -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", NULL); - goto cleanup; - } - if (CheckOneByte(interp, localVar)) { - goto cleanup; - } - if (Tcl_GetIntFromObj(interp, bcArgs[2], &opnd) != TCL_OK) { - goto cleanup; + if (AssembleOneLine(assemEnvPtr) != TCL_OK) { + if (flags & TCL_EVAL_DIRECT) { + Tcl_LogCommandInfo(interp, codePtr, parsePtr->commandStart, + instLen); + } + Tcl_FreeParse(parsePtr); + FreeAssembleEnv(assemEnvPtr); + return TCL_ERROR; } - if (CheckSignedOneByte(interp, opnd)) { - goto cleanup; - } - BBEmitInstInt1(envPtr, curr_bb, tblind, localVar, 0); - TclEmitInt1(opnd, envPtr); - break; - - case ASSEM_OVER: - if (bcSize != 2) { - Tcl_WrongNumArgs(interp, 1, bcArgs, "count"); - goto cleanup; - } - if (Tcl_GetIntFromObj(interp, bcArgs[1], &opnd) != TCL_OK) { - goto cleanup; - } - BBEmitInstInt4(envPtr, curr_bb, tblind, opnd, opnd+1); - break; - - case ASSEM_PUSH: - if (bcSize != 2) { - Tcl_WrongNumArgs(interp, 1, bcArgs, "value"); - goto cleanup; - } - litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len); - BBEmitInst1or4(envPtr, curr_bb, tblind, litIndex, 0); - break; + } - case ASSEM_REVERSE: - if (bcSize != 2) { - Tcl_WrongNumArgs(interp, 1, bcArgs, "count"); - goto cleanup; - } - if (Tcl_GetIntFromObj(interp, bcArgs[1], &opnd) != TCL_OK) { - goto cleanup; - } - BBEmitInstInt4(envPtr, curr_bb, tblind, opnd, opnd); - break; - - case ASSEM_SINT1: - if (bcSize != 2) { - Tcl_WrongNumArgs(interp, 1, bcArgs, "imm8"); - goto cleanup; - } - if (Tcl_GetIntFromObj(interp, bcArgs[1], &opnd) != TCL_OK) { - goto cleanup; - } - if (CheckSignedOneByte(interp, opnd)) { - goto cleanup; - } - BBEmitInstInt1(envPtr, curr_bb, tblind, opnd, 0); - break; + /* Advance to the next line of code */ - case ASSEM_CONCAT1: - if (bcSize != 2) { - Tcl_WrongNumArgs(interp, 1, bcArgs, "imm8"); - goto cleanup; - } - if (Tcl_GetIntFromObj(interp, bcArgs[1], &opnd) != TCL_OK) { - goto cleanup; - } - if (CheckOneByte(interp, opnd)) { - goto cleanup; - } - BBEmitInstInt1(envPtr, curr_bb, tblind, opnd, opnd); - break; + 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); - case ASSEM_EVAL: - if (bcSize != 2) { - Tcl_WrongNumArgs(interp, 1, bcArgs, "script"); - goto cleanup; - } - fprintf(stderr, "compiling: %s\n", operand1); fflush(stderr); - savedMaxStackDepth = envPtr->maxStackDepth; - savedCurrStackDepth = envPtr->currStackDepth; - envPtr->maxStackDepth = 0; - envPtr->currStackDepth = 0; - TclCompileScript(interp, operand1, operand1Len, envPtr); - if (curr_bb->finalStackDepth + envPtr->maxStackDepth - > curr_bb->maxStackDepth) { - curr_bb->maxStackDepth = - curr_bb->finalStackDepth + envPtr->maxStackDepth; - } - curr_bb->finalStackDepth += envPtr->currStackDepth; - envPtr->maxStackDepth = savedMaxStackDepth; - envPtr->currStackDepth = savedCurrStackDepth; - fprintf(stderr, "compilation returns\n"); fflush(stderr); - break; + /* Done with parsing the code */ - default: - Tcl_Panic("Instruction \"%s\" could not be found, can't happen\n", - instName); - } - - } + status = FinishAssembly(assemEnvPtr); + FreeAssembleEnv(assemEnvPtr); + return status; +} + +/* + *----------------------------------------------------------------------------- + * + * NewAssembleEnv -- + * + * Creates an environment for the assembler to run in. + * + * Results: + * Allocates, initialises and returns an assembler environment + * + *----------------------------------------------------------------------------- + */ - /* Tie off the last basic block */ +static AssembleEnv* +NewAssembleEnv(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 */ + AssembleEnv* assemEnvPtr = TclStackAlloc(interp, sizeof(AssembleEnv)); + /* Assembler environment under construction */ + Tcl_Parse* parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse)); + /* Parse of one line of assembly code */ - curr_bb->may_fall_thru = 0; - curr_bb->jumpTargetLabelHashEntry = NULL; - result = CheckStack(interp, envPtr, head_bb, bcList); - if (result != TCL_OK) { - goto cleanup; - } - if (curr_bb->visited) { - int depth = curr_bb->finalStackDepth + curr_bb->initialStackDepth; - if (depth == 0) { - /* Emit a 'push' of the empty literal */ - litIndex = TclRegisterNewLiteral(envPtr, "", 0); - /* Assumes that 'push' is at slot 0 in talInstructionTable */ - BBEmitInst1or4(envPtr, curr_bb, 0, litIndex, 0); - ++depth; - } - if (depth != 1) { - Tcl_Obj* depthObj = Tcl_NewIntObj(depth); - Tcl_IncrRefCount(depthObj); - resultObj = Tcl_NewStringObj("stack is unbalanced on exit " - "from the code (depth=", -1); - Tcl_AppendObjToObj(resultObj, depthObj); - Tcl_DecrRefCount(depthObj); - Tcl_AppendToObj(resultObj, ")", -1); - Tcl_SetObjResult(interp, resultObj); - goto cleanup; - } -#if 0 - fprintf(stderr, "before: stackDepth %d\n", envPtr->currStackDepth); -#endif - envPtr->currStackDepth += depth; -#if 0 - fprintf(stderr, "after: stackDepth %d\n", envPtr->currStackDepth); -#endif - fflush(stderr); - } + assemEnvPtr->envPtr = envPtr; + assemEnvPtr->parsePtr = parsePtr; + assemEnvPtr->cmdLine = envPtr->line; + assemEnvPtr->clNext = envPtr->clNext; - Tcl_DeleteHashTable(&labelHash); // Actually, we need to free each label as well. + /* Make the hashtables that store symbol resolution */ - return result; + Tcl_InitHashTable(&assemEnvPtr->labelHash, TCL_STRING_KEYS); + Tcl_InitHashTable(&assemEnvPtr->BBHash, TCL_STRING_KEYS); - cleanup: - - /* FIXME: Need to make sure that allocated memory gets freed. */ + /* Start the first basic block */ - if (ind >= 0 && ind < bcSize) { - Tcl_AddErrorInfo(interp, "\n processing "); - AddInstructionToErrorInfo(interp, bcList, ind); - } + assemEnvPtr->head_bb = AllocBB(assemEnvPtr); + assemEnvPtr->curr_bb = assemEnvPtr->head_bb; - /* TODO: If ind != -1, add error info indicating where in the - * instruction stream things went wrong */ + /* Stash compilation flags */ - return TCL_ERROR; + assemEnvPtr->flags = flags; + return assemEnvPtr; } /* *----------------------------------------------------------------------------- * - * CheckNamespaceQualifiers -- - * - * Verify that a variable name has no namespace qualifiers before - * attempting to install it in the LVT. + * FreeAssembleEnv -- * - * Results: - * On success, returns TCL_OK. On failure, returns TCL_ERROR and - * stores an error message in the interpreter result. + * Cleans up the assembler environment when assembly is complete. * *----------------------------------------------------------------------------- */ -static int -CheckNamespaceQualifiers(Tcl_Interp* interp, - /* Tcl interpreter for error reporting */ - const char* name) - /* Variable name to check */ +static void +FreeAssembleEnv(AssembleEnv* assemEnvPtr) + /* Environment to free */ { - Tcl_Obj* result; /* Error message */ - const char* p; - for (p = name; *p; p++) { - if ((*p == ':') && (p[1] == ':')) { - result = Tcl_NewStringObj("variable \"", -1); - Tcl_AppendToObj(result, name, -1); - Tcl_AppendToObj(result, "\" is not local", -1); - Tcl_SetObjResult(interp, result); - Tcl_SetErrorCode(interp, "TCL", "ASSEMBLE", "NONLOCAL", name, - NULL); - return TCL_ERROR; - } + 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; + label* labelPtr; + + /* Free the basic block hash index and all the basic block structures */ + Tcl_DeleteHashTable(&assemEnvPtr->BBHash); + for (thisBB = assemEnvPtr->head_bb; thisBB != NULL; thisBB = nextBB) { + nextBB = thisBB->successor1; + ckfree((char*)thisBB); } - return TCL_OK; + + /* Free all the labels */ + while ((hashEntry = Tcl_FirstHashEntry(&assemEnvPtr->labelHash, + &hashSearch)) != NULL) { + labelPtr = (label*) Tcl_GetHashValue(hashEntry); + ckfree((char*) labelPtr); + Tcl_DeleteHashEntry(hashEntry); + } + Tcl_DeleteHashTable(&assemEnvPtr->labelHash); + + TclStackFree(interp, assemEnvPtr->parsePtr); + TclStackFree(interp, assemEnvPtr); } /* *----------------------------------------------------------------------------- * - * CheckOneByte -- + * AssembleOneLine -- * - * Verify that a constant fits in a single byte in the instruction stream. + * Assembles a single command from an assembly language source. * * 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. + * 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 -CheckOneByte(Tcl_Interp* interp, - /* Tcl interpreter for error reporting */ - int value) /* Value to check */ +AssembleOneLine(AssembleEnv* assemEnvPtr) + /* State of the assembly */ { - Tcl_Obj* result; /* Error message */ - if (value < 0 || value > 0xff) { - result = Tcl_NewStringObj("operand does not fit in 1 byte", -1); - Tcl_SetObjResult(interp, result); - Tcl_SetErrorCode(interp, "TCL", "ASSEMBLE", "1BYTE", NULL); + 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 */ + Tcl_HashEntry* entry; /* Hash entry from label and basic + * block operations */ + int isNew; /* Flag indicating that a new hash entry + * has been created */ + label* l; /* Structure descibing a label in the + * assembly code */ + int opnd; /* Integer representation of an operand */ + int litIndex; /* Literal pool index of a constant */ + int localVar; /* LVT index of a local variable */ + 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; } - return TCL_OK; -} + + /* 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_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 (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK + || Tcl_GetIntFromObj(interp, operand1Obj, &opnd) != TCL_OK) { + goto cleanup; + } + if (CheckOneByte(interp, opnd)) { + goto cleanup; + } + BBEmitInstInt1(assemEnvPtr, tblind, opnd, opnd); + 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) { + /* + * 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. + */ + int savedStackDepth = envPtr->currStackDepth; + int savedMaxStackDepth = envPtr->maxStackDepth; + envPtr->currStackDepth = 0; + envPtr->maxStackDepth = 0; + switch(talInstructionTable[tblind].tclInstCode) { + case INST_EVAL_STK: + TclCompileScript(interp, tokenPtr[1].start, + tokenPtr[1].size, envPtr); + break; + case INST_EXPR_STK: + TclCompileExpr(interp, tokenPtr[1].start, + tokenPtr[1].size, envPtr, 1); + break; + default: + Tcl_Panic("no ASSEM_EVAL case for %s (%d), can't happen", + talInstructionTable[tblind].name, + talInstructionTable[tblind].tclInstCode); + } + SyncStackDepth(assemEnvPtr); + envPtr->currStackDepth = savedStackDepth; + envPtr->maxStackDepth = savedMaxStackDepth; + } 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 (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK + || Tcl_GetIntFromObj(interp, operand1Obj, &opnd) != TCL_OK) { + goto cleanup; + } + BBEmitInst1or4(assemEnvPtr, tblind, opnd, opnd); + break; + + case ASSEM_JUMP: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "label"); + goto cleanup; + } + if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) { + goto cleanup; + } + entry = Tcl_CreateHashEntry(&assemEnvPtr->labelHash, + Tcl_GetString(operand1Obj), &isNew); + if (isNew) { + l = (label *) ckalloc(sizeof(label)); + l -> isDefined = 0; + l -> offset = -1; + Tcl_SetHashValue(entry, l); + } else { + l = Tcl_GetHashValue(entry); + } + if (l -> isDefined) { + BBEmitInst1or4(assemEnvPtr, tblind, + (l->offset + envPtr->codeStart + - envPtr->codeNext), 0); + } else { + int here = envPtr->codeNext - envPtr->codeStart; + BBEmitInstInt4(assemEnvPtr, tblind, l->offset, 0); + l->offset = here; + } + + /* Start a new basic block at the instruction following the jump */ + + StartBasicBlock(assemEnvPtr, + talInstructionTable[tblind].operandsConsumed, + Tcl_GetString(operand1Obj)); + + 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; + } + StartBasicBlock(assemEnvPtr, 1, NULL); + + /* Attach the label to the new basic block */ + + /* TODO - do this in DefineLable and make the BB a field in the + * label struct */ + entry = Tcl_CreateHashEntry(&assemEnvPtr->BBHash, + Tcl_GetString(operand1Obj), &opnd); + Tcl_SetHashValue(entry, assemEnvPtr->curr_bb); + 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) { + goto cleanup; + } + BBEmitInstInt4(assemEnvPtr, tblind, opnd, opnd+1); + break; + + case ASSEM_REVERSE: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); + goto cleanup; + } + if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &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; + + 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; +} + +/* + *----------------------------------------------------------------------------- + * + * 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(AssembleEnv* 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(AssembleEnv* 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(AssembleEnv* 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; +} + +/* + *----------------------------------------------------------------------------- + * + * 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(AssembleEnv* 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" + " in non-proc context", -1)); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", NULL); + } + return -1; + } + *tokenPtrPtr = TokenAfter(tokenPtr); + return localVar; +} + + +/* + *----------------------------------------------------------------------------- + * + * 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(AssembleEnv* 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; +} + +/* + *----------------------------------------------------------------------------- + * + * 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", "ASSEMBLE", "NONLOCAL", name, + NULL); + return TCL_ERROR; + } + } + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * CheckOneByte -- + * + * Verify that a constant fits in a single byte in the instruction stream. + * + * Results: + * On success, returns TCL_OK. On failure, returns TCL_ERROR and + * stores an error message in the interpreter result. + * + * This code is here primarily to verify that instructions like INCR_SCALAR1 + * are possible on a given local variable. The fact that there is no + * INCR_SCALAR4 is puzzling. + * + *----------------------------------------------------------------------------- + */ + +static int +CheckOneByte(Tcl_Interp* interp, + /* Tcl interpreter for error reporting */ + int value) /* Value to check */ +{ + Tcl_Obj* result; /* Error message */ + if (value < 0 || value > 0xff) { + result = Tcl_NewStringObj("operand does not fit in 1 byte", -1); + Tcl_SetObjResult(interp, result); + Tcl_SetErrorCode(interp, "TCL", "ASSEMBLE", "1BYTE", NULL); + return TCL_ERROR; + } + return TCL_OK; +} /* *----------------------------------------------------------------------------- @@ -1220,11 +1626,13 @@ CheckSignedOneByte(Tcl_Interp* interp, */ static int -DefineLabel(Tcl_Interp* interp, /* Tcl interpreter */ - CompileEnv* envPtr, /* Compilation environment */ - const char* labelName, /* Label being defined */ - Tcl_HashTable* labelHash) /* Symbol table */ +DefineLabel(AssembleEnv* 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 */ @@ -1233,7 +1641,7 @@ DefineLabel(Tcl_Interp* interp, /* Tcl interpreter */ /* Look up the newly-defined label in the symbol table */ - entry = Tcl_CreateHashEntry(labelHash, labelName, &isNew); + entry = Tcl_CreateHashEntry(&assemEnvPtr->labelHash, labelName, &isNew); if (isNew) { /* This is the first appearance of the label in the code */ @@ -1294,25 +1702,21 @@ DefineLabel(Tcl_Interp* interp, /* Tcl interpreter */ */ static BasicBlock* -StartBasicBlock(CompileEnv* envPtr, - /* Compilation environment */ - Tcl_HashTable* BBHashPtr, - /* Hash table where basic blocks are recorded */ - BasicBlock* currBB, - /* Pointer to the BasicBlock structure - * of the block being closed. */ +StartBasicBlock(AssembleEnv* assemEnvPtr, + /* Assembly environment */ int fallsThrough, /* 1 if execution falls through into * the following block, 0 otherwise */ - int bcIndex, /* Index of the current insn in the - * assembly stream */ const char* jumpLabel) /* Label of the location that the * block jumps to, or NULL if the block * does not jump */ { - int isNew; /* Unused return from Tcl_CreateHashEntry */ - BasicBlock* newBB; /* BasicBlock structure for the new basic block */ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + int isNew; /* Unused return from Tcl_CreateHashEntry */ + BasicBlock* newBB; /* BasicBlock structure for the new block */ + BasicBlock* currBB = assemEnvPtr->curr_bb; /* Coalesce zero-length blocks */ @@ -1322,13 +1726,13 @@ StartBasicBlock(CompileEnv* envPtr, /* Make the new basic block */ - newBB = AllocBB(envPtr, bcIndex); + newBB = AllocBB(assemEnvPtr); /* Record the jump target if there is one. */ if (jumpLabel) { currBB->jumpTargetLabelHashEntry = - Tcl_CreateHashEntry(BBHashPtr, jumpLabel, &isNew); + Tcl_CreateHashEntry(&assemEnvPtr->BBHash, jumpLabel, &isNew); } else { currBB->jumpTargetLabelHashEntry = NULL; } @@ -1340,6 +1744,7 @@ StartBasicBlock(CompileEnv* envPtr, /* Record the successor block */ currBB->successor1 = newBB; + assemEnvPtr->curr_bb = newBB; return newBB; } @@ -1358,15 +1763,14 @@ StartBasicBlock(CompileEnv* envPtr, */ static BasicBlock * -AllocBB(CompileEnv* envPtr, /* Compile environment containing the - * current instruction pointer */ - int bcIndex) /* Current index in the list of - * assembly instructions */ +AllocBB(AssembleEnv* assemEnvPtr) + /* Assembly environment */ { + CompileEnv* envPtr = assemEnvPtr->envPtr; BasicBlock * bb = (BasicBlock *) ckalloc(sizeof(BasicBlock)); bb->start = envPtr->codeNext; - bb->bcIndex = bcIndex; + bb->startLine = assemEnvPtr->cmdLine; bb->initialStackDepth = 0; bb->minStackDepth = 0; bb->maxStackDepth = 0; @@ -1380,89 +1784,291 @@ AllocBB(CompileEnv* envPtr, /* Compile environment containing the 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(AssembleEnv* assemEnvPtr) + /* Assembly environment */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ + BasicBlock* curr_bb = assemEnvPtr->curr_bb; + /* Last basic block in the program */ + Tcl_Obj* depthObj; /* Depth of the stack on exit */ + Tcl_Obj* resultObj; /* Error message from this function */ + int litIndex; /* Index of the empty literal {} */ + + /* TODO - Check for undefined labels */ + + /* Tie off the last basic block */ + + curr_bb->may_fall_thru = 0; + curr_bb->jumpTargetLabelHashEntry = NULL; + + /* Compute stack balance throughout the program */ + + if (CheckStack(assemEnvPtr) != TCL_OK) { + return TCL_ERROR; + } + + /* TODO - Check for unreachable code */ + + /* If the exit is reachable, make sure that the program exits with + * 1 operand on the stack. */ + + if (curr_bb->visited) { + + /* Exit with no operands; push an empty one. */ + + int depth = curr_bb->finalStackDepth + curr_bb->initialStackDepth; + if (depth == 0) { + /* Emit a 'push' of the empty literal */ + litIndex = TclRegisterNewLiteral(envPtr, "", 0); + /* Assumes that 'push' is at slot 0 in talInstructionTable */ + BBEmitInst1or4(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; +} + +/* + *----------------------------------------------------------------------------- + * + * 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(Tcl_Interp* interp, - CompileEnv* envPtr, - BasicBlock * head, - Tcl_Obj* bcList) { - StackCheckerState st; - st.interp = interp; - st.maxDepth = 0; - st.envPtr = envPtr; - st.bcList = bcList; - if(StackCheckBasicBlock(&st, head, NULL, 0) == TCL_ERROR) { +CheckStack(AssembleEnv* 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; } -#if 0 - fprintf(stderr, "Max stack anywhere is %d\n", st->maxDepth); -#endif - if (st.maxDepth + envPtr->currStackDepth > envPtr->maxStackDepth) { - envPtr->maxStackDepth = st.maxDepth + envPtr->currStackDepth; + + /* Post the max stack depth back to the compilation environment */ + + maxDepth = assemEnvPtr->maxDepth + envPtr->currStackDepth; + if (maxDepth > envPtr->maxStackDepth) { + envPtr->maxStackDepth = maxDepth; } + 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(StackCheckerState *st, BasicBlock * blockPtr, BasicBlock * predecessor, int initialStackDepth) { -#if 0 - CompileEnv* envPtr = st->envPtr; - fprintf(stderr, "stack check basic block %p at depth %d\n", - blockPtr, initialStackDepth); - fprintf(stderr, " start %d may_fall_thru %d visited %d\n", - blockPtr->start - envPtr->codeStart, - blockPtr->may_fall_thru, blockPtr->visited); - fprintf(stderr, " predecessor %p successor1 %p\n", - blockPtr->predecessor, blockPtr->successor1); - fprintf(stderr, " stack: init %d min %d max %d final %d\n", - blockPtr->initialStackDepth, blockPtr->minStackDepth, - blockPtr->maxStackDepth, blockPtr->finalStackDepth); - fflush(stderr); -#endif +StackCheckBasicBlock(AssembleEnv* 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 */ + int stackDepth; /* Current stack depth */ + int maxDepth; /* Maximum stack depth so far */ + int result; /* Tcl status return */ + if (blockPtr->visited) { + + /* + * If the block is already visited, check stack depth for consistency + * among the paths that reach it. + */ if (blockPtr->initialStackDepth != initialStackDepth) { - Tcl_SetObjResult(st->interp, Tcl_NewStringObj("inconsistent stack depths on two execution paths", -1)); - /* Trace the offending BasicBlock */ - Tcl_AddErrorInfo(st->interp, "\n to "); - AddInstructionToErrorInfo(st->interp, st->bcList, - blockPtr->bcIndex); - /* TODO - add execution trace of both paths */ + 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; } - } else { + } - blockPtr->visited = 1; - blockPtr->predecessor = predecessor; - blockPtr->initialStackDepth = initialStackDepth; - if (initialStackDepth + blockPtr->minStackDepth < 0) { - Tcl_SetObjResult(st->interp, + /* + * 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. + * Calculate max and min stack depth, flag an error if the + * block underflows the stack, and update max stack depth in the + * assembly environment. + */ + blockPtr->visited = 1; + blockPtr->predecessor = predecessor; + blockPtr->initialStackDepth = initialStackDepth; + if (initialStackDepth + blockPtr->minStackDepth < 0) { + if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("stack underflow", -1)); - AddBasicBlockRangeToErrorInfo(st->interp, st->bcList, blockPtr); - return TCL_ERROR; - } - if (initialStackDepth + blockPtr->maxStackDepth > st->maxDepth) { - st->maxDepth = initialStackDepth + blockPtr->maxStackDepth; - } + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL); + AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr); + Tcl_SetErrorLine(interp, blockPtr->startLine); + } + return TCL_ERROR; } - int stackDepth = initialStackDepth + blockPtr->finalStackDepth; - int result = TCL_OK; -#if 0 - fprintf(stderr, "on exit from block, depth will be %d\n", stackDepth); - fflush(stderr); -#endif + 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->may_fall_thru) { - result = StackCheckBasicBlock(st, blockPtr->successor1, blockPtr, stackDepth); + result = StackCheckBasicBlock(assemEnvPtr, blockPtr->successor1, + blockPtr, stackDepth); } - /* FIXME Have we checked for undefined labels yet ? */ if (result == TCL_OK && blockPtr->jumpTargetLabelHashEntry != NULL) { - BasicBlock * targetBlock = (BasicBlock *) Tcl_GetHashValue(blockPtr->jumpTargetLabelHashEntry); - result = StackCheckBasicBlock(st, targetBlock, blockPtr, stackDepth); + BasicBlock * targetBlock = (BasicBlock *) + Tcl_GetHashValue(blockPtr->jumpTargetLabelHashEntry); + result = StackCheckBasicBlock(assemEnvPtr, targetBlock, blockPtr, + stackDepth); } return result; - +} + +/* + *----------------------------------------------------------------------------- + * + * 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(AssembleEnv* 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); } /* @@ -1496,42 +2102,4 @@ FreeAssembleCodeInternalRep( objPtr->typePtr = NULL; objPtr->internalRep.otherValuePtr = NULL; } - -static void -AddBasicBlockRangeToErrorInfo(Tcl_Interp* interp, - Tcl_Obj* bcList, - BasicBlock* bbPtr) -{ - Tcl_AddErrorInfo(interp, "\n between "); - AddInstructionToErrorInfo(interp, bcList, bbPtr->bcIndex); - Tcl_AddErrorInfo(interp, "\n and "); - if (bbPtr->successor1 != NULL) { - AddInstructionToErrorInfo(interp, bcList, - bbPtr->successor1->bcIndex); - } else { - Tcl_AddErrorInfo(interp, "end of assembly code"); - } -} - -static void -AddInstructionToErrorInfo(Tcl_Interp* interp, - Tcl_Obj* bcList, - int bcIndex) -{ - Tcl_Obj* msgObj; - int msgLen; - const char* msgPtr; - - Tcl_AddErrorInfo(interp, "source instruction at list index "); - msgObj = Tcl_NewIntObj(bcIndex); - Tcl_IncrRefCount(msgObj); - msgPtr = Tcl_GetStringFromObj(msgObj, &msgLen); - Tcl_AddObjErrorInfo(interp, msgPtr, msgLen); - Tcl_DecrRefCount(msgObj); - Tcl_AddErrorInfo(interp, " (\""); - Tcl_ListObjIndex(NULL, bcList, bcIndex, &msgObj); - msgPtr = Tcl_GetStringFromObj(msgObj, &msgLen); - Tcl_AddObjErrorInfo(interp, msgPtr, msgLen); - Tcl_AddErrorInfo(interp, "\")"); -} diff --git a/generic/tclAssembly.h b/generic/tclAssembly.h index c788eed..c1cb0e5 100644 --- a/generic/tclAssembly.h +++ b/generic/tclAssembly.h @@ -3,18 +3,11 @@ #include "tclCompile.h" -typedef struct StackCheckerState { - Tcl_Interp* interp; - CompileEnv* envPtr; - int maxDepth; - Tcl_Obj* bcList; -} StackCheckerState; - typedef struct BasicBlock { /* FIXME: start needs to be an offset from envPtr->codeStart */ unsigned char * start; /* Instruction address of the start * of the block */ - int bcIndex; /* Index in the input instruction + int startLine; /* Index in the input instruction * list of the start of the block */ int may_fall_thru; /* Flag == 1 if control passes from this * block to its successor. */ @@ -77,7 +70,7 @@ typedef struct label { int offset; } label; -MODULE_SCOPE int TclAssembleCode(Tcl_Interp* interp, Tcl_Obj* code, - CompileEnv* compEnv, int flags); +MODULE_SCOPE int TclAssembleCode(CompileEnv* compEnv, const char* codePtr, + int codeLen, int flags); #endif diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 7ef3bec..2f52595 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdAH.c,v 1.126 2010/08/30 14:02:09 msofer Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.126.2.1 2010/09/25 14:51:12 kennykb Exp $ */ #include "tclInt.h" @@ -336,6 +336,7 @@ CatchObjCmdCallback( if (NULL == Tcl_ObjSetVar2(interp, optionVarNamePtr, NULL, options, 0)) { + Tcl_DecrRefCount(options); Tcl_ResetResult(interp); Tcl_AppendResult(interp, "couldn't save return options in variable", NULL); diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 675f383..0c64526 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclDecls.h,v 1.186 2010/09/16 14:49:37 nijtmans Exp $ + * RCS: @(#) $Id: tclDecls.h,v 1.186.2.1 2010/09/25 14:51:12 kennykb Exp $ */ #ifndef _TCLDECLS @@ -3774,12 +3774,16 @@ extern const TclStubs *tclStubsPtr; #if defined(USE_TCL_STUBS) # undef Tcl_CreateInterp # undef Tcl_FindExecutable +# undef Tcl_GetStringResult # undef Tcl_Init +# undef Tcl_SetPanicProc # undef Tcl_SetVar # undef Tcl_StaticPackage # undef TclFSGetNativePath # define Tcl_CreateInterp() (tclStubsPtr->tcl_CreateInterp()) +# define Tcl_GetStringResult(interp) (tclStubsPtr->tcl_GetStringResult(interp)) # define Tcl_Init(interp) (tclStubsPtr->tcl_Init(interp)) +# define Tcl_SetPanicProc(proc) (tclStubsPtr->tcl_SetPanicProc(proc)) # define Tcl_SetVar(interp, varName, newValue, flags) \ (tclStubsPtr->tcl_SetVar(interp, varName, newValue, flags)) #endif diff --git a/generic/tclEvent.c b/generic/tclEvent.c index ad87cd5..67b3fde 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclEvent.c,v 1.93 2010/06/16 14:49:50 nijtmans Exp $ + * RCS: @(#) $Id: tclEvent.c,v 1.93.2.1 2010/09/25 14:51:12 kennykb Exp $ */ #include "tclInt.h" @@ -281,6 +281,7 @@ HandleBgErrors( } Tcl_WriteChars(errChannel, "\n", 1); Tcl_Flush(errChannel); + Tcl_DecrRefCount(options); } } } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 58434c0..2998657 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclExecute.c,v 1.494.2.1 2010/09/22 01:08:49 kennykb Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.494.2.2 2010/09/25 14:51:12 kennykb Exp $ */ #include "tclInt.h" @@ -2858,20 +2858,23 @@ TclExecuteByteCode( Tcl_SetResult(interp, "yield can only be called in a coroutine", TCL_STATIC); + DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL); + CACHE_STACK_INFO(); pc--; goto gotError; } NRE_ASSERT(iPtr->execEnvPtr == corPtr->eePtr); NRE_ASSERT(corPtr->stackLevel != NULL); - NRE_ASSERT(BP == corPtr->eePtr->bottomPtr); if (corPtr->stackLevel != &TAUX) { Tcl_SetResult(interp, "cannot yield: C stack busy", TCL_STATIC); + DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "CANT_YIELD", NULL); + CACHE_STACK_INFO(); pc--; goto gotError; } @@ -2880,6 +2883,7 @@ TclExecuteByteCode( * Mark suspended, save our state and return */ + DECACHE_STACK_INFO(); corPtr->stackLevel = NULL; iPtr->execEnvPtr = corPtr->callerEEPtr; OBP = *corPtr->callerBPPtr; @@ -4146,14 +4150,18 @@ TclExecuteByteCode( if (TclGetBooleanFromObj(NULL, valuePtr, &i1) != TCL_OK) { TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); + DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); + CACHE_STACK_INFO(); goto gotError; } if (TclGetBooleanFromObj(NULL, value2Ptr, &i2) != TCL_OK) { TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr), (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); + DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, value2Ptr); + CACHE_STACK_INFO(); goto gotError; } @@ -4520,114 +4528,90 @@ TclExecuteByteCode( case INST_STR_EQ: case INST_STR_NEQ: /* String (in)equality check */ - /* - * TODO: Consider merging into INST_STR_CMP - */ - + case INST_STR_CMP: /* String compare. */ + stringCompare: value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; if (valuePtr == value2Ptr) { + match = 0; + } else { /* - * On the off-chance that the objects are the same, we don't - * really have to think hard about equality. + * We only need to check (in)equality when we have equal length + * strings. We can use memcmp in all (n)eq cases because we + * don't need to worry about lexical LE/BE variance. */ - - match = (*pc == INST_STR_EQ); - } else { - s1 = TclGetStringFromObj(valuePtr, &s1len); - s2 = TclGetStringFromObj(value2Ptr, &s2len); - if (s1len == s2len) { + typedef int (*memCmpFn_t)(const void*, const void*, size_t); + memCmpFn_t memCmpFn; + int checkEq = ((*pc == INST_EQ) || (*pc == INST_NEQ) + || (*pc == INST_STR_EQ) || (*pc == INST_STR_NEQ)); + + if (TclIsPureByteArray(valuePtr) + && TclIsPureByteArray(value2Ptr)) { + s1 = (char *) Tcl_GetByteArrayFromObj(valuePtr, &s1len); + s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len); + memCmpFn = memcmp; + } else if (((valuePtr->typePtr == &tclStringType) + && (value2Ptr->typePtr == &tclStringType))) { /* - * We only need to check (in)equality when we have equal - * length strings. + * Do a unicode-specific comparison if both of the args are of + * String type. If the char length == byte length, we can do a + * memcmp. In benchmark testing this proved the most efficient + * check between the unicode and string comparison operations. */ - if (*pc == INST_STR_NEQ) { - match = (memcmp(s1, s2, s1len) != 0); + s1len = Tcl_GetCharLength(valuePtr); + s2len = Tcl_GetCharLength(value2Ptr); + if ((s1len == valuePtr->length) + && (s2len == value2Ptr->length)) { + s1 = valuePtr->bytes; + s2 = value2Ptr->bytes; + memCmpFn = memcmp; } else { - /* INST_STR_EQ */ - match = (memcmp(s1, s2, s1len) == 0); + s1 = (char *) Tcl_GetUnicode(valuePtr); + s2 = (char *) Tcl_GetUnicode(value2Ptr); + if ( +#ifdef WORDS_BIGENDIAN + 1 +#else + checkEq +#endif + ) { + memCmpFn = memcmp; + s1len *= sizeof(Tcl_UniChar); + s2len *= sizeof(Tcl_UniChar); + } else { + memCmpFn = (memCmpFn_t) Tcl_UniCharNcmp; + } } } else { - match = (*pc == INST_STR_NEQ); - } - } - - TRACE(("%.20s %.20s => %d\n", O2S(valuePtr),O2S(value2Ptr),match)); - - /* - * Peep-hole optimisation: if you're about to jump, do jump from here. - */ - - pc++; -#ifndef TCL_COMPILE_DEBUG - switch (*pc) { - case INST_JUMP_FALSE1: - NEXT_INST_F((match? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE1: - NEXT_INST_F((match? TclGetInt1AtPtr(pc+1) : 2), 2, 0); - case INST_JUMP_FALSE4: - NEXT_INST_F((match? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE4: - NEXT_INST_F((match? TclGetInt4AtPtr(pc+1) : 5), 2, 0); - } -#endif - objResultPtr = TCONST(match); - NEXT_INST_F(0, 2, 1); - - stringCompare: - case INST_STR_CMP: /* String compare. */ - value2Ptr = OBJ_AT_TOS; - valuePtr = OBJ_UNDER_TOS; - - /* - * The comparison function should compare up to the minimum byte - * length only. - */ - - if (valuePtr == value2Ptr) { - /* - * In the pure equality case, set lengths too for the checks below - * (or we could goto beyond it). - */ + /* + * strcmp can't do a simple memcmp in order to handle the + * special Tcl \xC0\x80 null encoding for utf-8. + */ - match = s1len = s2len = 0; - } else if (TclIsPureByteArray(valuePtr) - && TclIsPureByteArray(value2Ptr)) { - s1 = (char *) Tcl_GetByteArrayFromObj(valuePtr, &s1len); - s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len); - match = memcmp(s1, s2, - (size_t) ((s1len < s2len) ? s1len : s2len)); - } else if (((valuePtr->typePtr == &tclStringType) - && (value2Ptr->typePtr == &tclStringType))) { - /* - * Do a unicode-specific comparison if both of the args are of - * String type. If the char length == byte length, we can do a - * memcmp. In benchmark testing this proved the most efficient - * check between the unicode and string comparison operations. - */ + s1 = TclGetStringFromObj(valuePtr, &s1len); + s2 = TclGetStringFromObj(value2Ptr, &s2len); + if (checkEq) { + memCmpFn = memcmp; + } else { + memCmpFn = (memCmpFn_t) TclpUtfNcmp2; + } + } - s1len = Tcl_GetCharLength(valuePtr); - s2len = Tcl_GetCharLength(value2Ptr); - if ((s1len == valuePtr->length) && (s2len == value2Ptr->length)) { - match = memcmp(valuePtr->bytes, value2Ptr->bytes, - (unsigned) ((s1len < s2len) ? s1len : s2len)); + if (checkEq && (s1len != s2len)) { + match = 1; } else { - match = TclUniCharNcmp(Tcl_GetUnicode(valuePtr), - Tcl_GetUnicode(value2Ptr), - (unsigned) ((s1len < s2len) ? s1len : s2len)); + /* + * The comparison function should compare up to the minimum + * byte length only. + */ + match = memCmpFn(s1, s2, + (size_t) ((s1len < s2len) ? s1len : s2len)); + if (match == 0) { + match = s1len - s2len; + } } - } else { - /* - * We can't do a simple memcmp in order to handle the special Tcl - * \xC0\x80 null encoding for utf-8. - */ - - s1 = TclGetStringFromObj(valuePtr, &s1len); - s2 = TclGetStringFromObj(value2Ptr, &s2len); - match = TclpUtfNcmp2(s1, s2, - (size_t) ((s1len < s2len) ? s1len : s2len)); } /* @@ -4635,19 +4619,17 @@ TclExecuteByteCode( * TODO: consider peephole opt. */ - if (match == 0) { - match = s1len - s2len; - } - if (*pc != INST_STR_CMP) { /* * Take care of the opcodes that goto'ed into here. */ switch (*pc) { + case INST_STR_EQ: case INST_EQ: match = (match == 0); break; + case INST_STR_NEQ: case INST_NEQ: match = (match != 0); break; @@ -4956,7 +4938,9 @@ TclExecuteByteCode( TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(valuePtr), O2S(value2Ptr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); + DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); + CACHE_STACK_INFO(); goto gotError; } @@ -4965,7 +4949,9 @@ TclExecuteByteCode( TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(valuePtr), O2S(value2Ptr), (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); + DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, value2Ptr); + CACHE_STACK_INFO(); goto gotError; } @@ -5023,9 +5009,11 @@ TclExecuteByteCode( Tcl_SetResult(interp, "negative shift argument", TCL_STATIC); #if 0 + DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "domain error: argument not in valid range", NULL); + CACHE_STACK_INFO(); #endif goto gotError; } else if (l1 == 0) { @@ -5069,9 +5057,11 @@ TclExecuteByteCode( Tcl_SetResult(interp, "negative shift argument", TCL_STATIC); #if 0 + DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "domain error: argument not in valid range", NULL); + CACHE_STACK_INFO(); #endif goto gotError; } else if (l1 == 0) { @@ -5091,8 +5081,10 @@ TclExecuteByteCode( "integer value too large to represent", TCL_STATIC); #if 0 + DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", "integer value too large to represent", NULL); + CACHE_STACK_INFO(); #endif goto gotError; } else { @@ -5175,7 +5167,9 @@ TclExecuteByteCode( TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(value2Ptr), O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name: "null"))); + DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); + CACHE_STACK_INFO(); goto gotError; } @@ -5194,7 +5188,9 @@ TclExecuteByteCode( TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(value2Ptr), O2S(valuePtr), (value2Ptr->typePtr? value2Ptr->typePtr->name: "null"))); + DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, value2Ptr); + CACHE_STACK_INFO(); goto gotError; } @@ -5341,7 +5337,9 @@ TclExecuteByteCode( if (TclGetBooleanFromObj(NULL, valuePtr, &b) != TCL_OK) { TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); + DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); + CACHE_STACK_INFO(); goto gotError; } /* TODO: Consider peephole opt. */ @@ -5359,7 +5357,9 @@ TclExecuteByteCode( TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); + DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); + CACHE_STACK_INFO(); goto gotError; } if (type1 == TCL_NUMBER_LONG) { @@ -5384,7 +5384,9 @@ TclExecuteByteCode( || IsErroringNaNType(type1)) { TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); + DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); + CACHE_STACK_INFO(); goto gotError; } switch (type1) { @@ -5428,7 +5430,9 @@ TclExecuteByteCode( TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name:"null"))); + DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); + CACHE_STACK_INFO(); goto gotError; } @@ -5444,7 +5448,9 @@ TclExecuteByteCode( TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name:"null"))); + DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); + CACHE_STACK_INFO(); } else { /* * Numeric conversion of NaN -> error. @@ -5452,7 +5458,9 @@ TclExecuteByteCode( TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n", O2S(objResultPtr))); + DECACHE_STACK_INFO(); TclExprFloatError(interp, *((const double *) ptr1)); + CACHE_STACK_INFO(); } goto gotError; } @@ -5692,7 +5700,9 @@ TclExecuteByteCode( case INST_END_CATCH: catchTop--; + DECACHE_STACK_INFO(); Tcl_ResetResult(interp); + CACHE_STACK_INFO(); TRESULT = TCL_OK; TRACE(("=> catchTop=%d\n", (int) (catchTop - initCatchTop - 1))); NEXT_INST_F(1, 0, 0); @@ -5768,11 +5778,13 @@ TclExecuteByteCode( TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_V(5, opnd+1, 1); } + DECACHE_STACK_INFO(); Tcl_ResetResult(interp); Tcl_AppendResult(interp, "key \"", TclGetString(OBJ_AT_TOS), "\" not known in dictionary", NULL); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", TclGetString(OBJ_AT_TOS), NULL); + CACHE_STACK_INFO(); TRACE_WITH_OBJ(("%u => ERROR ", opnd), Tcl_GetObjResult(interp)); } else { TRACE_WITH_OBJ(( @@ -6337,8 +6349,10 @@ TclExecuteByteCode( */ divideByZero: + DECACHE_STACK_INFO(); Tcl_SetResult(interp, "divide by zero", TCL_STATIC); Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL); + CACHE_STACK_INFO(); goto gotError; /* @@ -6347,10 +6361,12 @@ TclExecuteByteCode( */ exponOfZero: + DECACHE_STACK_INFO(); Tcl_SetResult(interp, "exponentiation of zero by negative power", TCL_STATIC); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "exponentiation of zero by negative power", NULL); + CACHE_STACK_INFO(); /* * Almost all error paths feed through here rather than assigning to diff --git a/generic/tclMain.c b/generic/tclMain.c index 5d4c6f9..fcccbd3 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclMain.c,v 1.50 2010/04/30 07:07:06 nijtmans Exp $ + * RCS: @(#) $Id: tclMain.c,v 1.50.2.1 2010/09/25 14:51:13 kennykb Exp $ */ #include "tclInt.h" @@ -368,6 +368,7 @@ Tcl_Main( Tcl_WriteObj(errChannel, valuePtr); } Tcl_WriteChars(errChannel, "\n", 1); + Tcl_DecrRefCount(options); } exitCode = 1; } diff --git a/tests/assemble.test b/tests/assemble.test index d0cbdaa..a2ce531 100644 --- a/tests/assemble.test +++ b/tests/assemble.test @@ -33,69 +33,118 @@ test assemble-1.4 {empty body} { -result {} } +test assemble-1.4.1 {unknown assembly instruction} { + -body { + list [catch { + tcl::unsupported::assemble { + push 2 + push 2 + rubbish + } + } result] $result $errorCode $errorInfo + } + -match glob + -result {1 {bad instruction "rubbish":*} {bad instruction "rubbish":* + while executing +"rubbish" + ("tcl::unsupported::assemble" body, line 4)*}} +} + test assemble-1.5 {Testing push and add} { - -body { tcl::unsupported::assemble {{push 2} {push 2} {add}} } + -body { tcl::unsupported::assemble { + push 2 + push 2 + add + } + } -result {4} } test assemble-1.6 {Testing push, dup, add} { - -body { tcl::unsupported::assemble {{push 2} {dup} {add}} } + -body { + tcl::unsupported::assemble { + push 2 + dup + add + } + } -result {4} } test assemble-1.6a {wrong # args} { -body { catch { - tcl::unsupported::assemble {{push 2 2} {dup} {add}} + tcl::unsupported::assemble { + push 2 2 + dup + add + } } set ::errorInfo } -match glob -result {wrong # args: should be "push value" - processing source instruction at list index 0 ("push 2 2")*} + while executing +"push 2 2" + ("tcl::unsupported::assemble" body, line 2)* + } } -test assemble-1.7 { Testing push, dup, mul, push, dup, mult, push, expon sequence } { - -body { tcl::unsupported::assemble {{push 3} dup mult {push 4} dup mult expon}} +test assemble-1.7 {longer sequence} { + -body { + tcl::unsupported::assemble { + push 3 + dup + mult + push 4 + dup + mult + expon + } + } -result {1853020188851841} } -test assemble-1.8 { Testing push, dup, mul, push, dup, mult, push, expon, pop sequence with unbalanced stack } {*}{ +test assemble-1.8 {unbalanced stack} { -body { list \ [catch { tcl::unsupported::assemble { - {push 3} + push 3 dup mult - {push 4} + push 4 dup mult pop - expon} + expon + } } result] $result $::errorInfo } -result {1 {stack underflow} {stack underflow - between source instruction at list index 0 ("push 3") - and end of assembly code*}} + in assembly code between lines 1 and end of assembly code*}} -match glob -returnCodes ok } + test assemble-1.8a {unbalanced stack} {*}{ -body { list \ [catch { tcl::unsupported::assemble { - {label a} - {pop} - {label b} - {pop} + label a + push {} + label b + pop + label c + pop + label d + push {} } } result] $result $::errorInfo } -result {1 {stack underflow} {stack underflow - between source instruction at list index 0 ("label a") - and source instruction at list index 2 ("label b")*}} + in assembly code between lines 6 and 8*}} -match glob -returnCodes ok } @@ -103,35 +152,46 @@ test assemble-1.8a {unbalanced stack} {*}{ # Tests for load and store test assemble-1.9 { Testing load within a proc } { - -body { proc x y { tcl::unsupported::assemble {{load y} dup mult }} + -body { + proc x y { + tcl::unsupported::assemble { + load y + dup + mult + } + } x 10 } -result {100} } -test assemble-1.10 { Testing store and load, saving the string "aString" to a variable and then - loading it from variable } { - -body { - proc x arg { - tcl::unsupported::assemble { - {push aString} {store arg} {pop} {load arg}} +test assemble-1.10 {store and load again} { + -body { + proc x arg { + tcl::unsupported::assemble { + push aString + store arg + pop + load arg } - x "not_aString" - } - -result {aString} + } + x "not_aString" } + -result {aString} +} -test assemble-1.11 { Testing storeArray and loadArray } { - -body { set anArray(1,2) "not_aString" +test assemble-1.11 {Testing storeArray and loadArray} { + -body { + set anArray(1,2) "not_aString" proc x arg { upvar $arg anArray tcl::unsupported::assemble { - {push 1,2} - {push aString} - {storeArray anArray} + push 1,2 + push aString + storeArray anArray pop - {push 1,2} - {loadArray anArray} + push 1,2 + loadArray anArray } } x anArray @@ -140,30 +200,51 @@ test assemble-1.11 { Testing storeArray and loadArray } { -result {aString} } -test assemble-1.12 { Testing loadStk with a variable } { - -body { set vara 10 - tcl::unsupported::assemble {{push vara} loadStk dup mult {push 4} dup mult add}} +test assemble-1.12 {Testing loadStk with a variable} { + -body { + set vara 10 + tcl::unsupported::assemble { + push vara + loadStk + dup + mult + push 4 + dup + mult + add + } + } -cleanup {unset vara} -result {116} } -test assemble-1.13 { Testing loadStk with an array variable } { - -body { set vararr(1,2) 10 - tcl::unsupported::assemble {{push vararr(1,2)} loadStk dup mult {push 4} dup mult add}} +test assemble-1.13 {Testing loadStk with an array variable} { + -body { + set vararr(1,2) 10 + tcl::unsupported::assemble { + push vararr(1,2) + loadStk + dup + mult + push 4 + dup + mult + add + } + } -cleanup {unset vararr} -result {116} } - -test assemble-1.14 { Testing loadStk and storeStk } { - -body { +test assemble-1.14 {Testing loadStk and storeStk} { + -body { set aVar 5 tcl::unsupported::assemble { - {push aVar} - {push aString} - {storeStk} + push aVar + push aString + storeStk pop - {push aVar} + push aVar loadStk } } @@ -171,17 +252,17 @@ test assemble-1.14 { Testing loadStk and storeStk } { -result {aString} } -test assemble-1.15 { Testing loadArrayStk and storeArrayStk } { +test assemble-1.15 {Testing loadArrayStk and storeArrayStk} { -body { set aVar(1,2) 5 tcl::unsupported::assemble { - {push aVar} - {push 1,2} - {push aString} - {storeArrayStk} + push aVar + push 1,2 + push aString + storeArrayStk pop - {push aVar} - {push 1,2} + push aVar + push 1,2 loadArrayStk } } @@ -192,81 +273,130 @@ test assemble-1.15 { Testing loadArrayStk and storeArrayStk } { # Tests for incr instructions test assemble-1.16 { Testing incr } { - -body { proc x arg { set i 5 - tcl::unsupported::assemble {{push 5} {incr i}} - } + -body { + proc x arg { + set i 5 + tcl::unsupported::assemble { + push 5 + incr i + } + } x 1 } -result {10} } test assemble-1.17 { Testing incrImm } { - -body { proc x arg { set i 5 - tcl::unsupported::assemble {{incrImm i 5}} - } + -body { + proc x arg { + set i 5 + tcl::unsupported::assemble { + incrImm i 5 + } + } x 1 } -result {10} } test assemble-1.18 { Testing incrStk } { - -body { proc x arg { set i 5 - tcl::unsupported::assemble {{push i} {push 5} {incrStk}} - } + -body { + proc x arg { + set i 5 + tcl::unsupported::assemble { + push i + push 5 + incrStk + } + } x 1 } -result {10} } test assemble-1.19 { Testing incrStkImm } { - -body { proc x arg { set i 5 - tcl::unsupported::assemble {{push i} {incrStkImm 5}} - } + -body { + proc x arg { + set i 5 + tcl::unsupported::assemble { + push i + incrStkImm 5 + } + } x 1 } -result {10} } test assemble-1.20 { Testing incrStkImm } { - -body { proc x arg { set i 5 - tcl::unsupported::assemble {{push i} {incrStkImm 5}} - } + -body { + proc x arg { + set i 5 + tcl::unsupported::assemble { + push i + incrStkImm 5 + } + } x 1 } -result {10} } test assemble-1.21 { Testing incrArray } { - -body { proc x arg { set i(1,2) 5 - tcl::unsupported::assemble {{push 1,2} {push 5} {incrArray i}} - } + -body { + proc x arg { + set i(1,2) 5 + tcl::unsupported::assemble { + push 1,2 + push 5 + incrArray i + } + } x 1 } -result {10} } test assemble-1.22 { Testing incrArrayImm } { - -body { proc x arg { set i(1,2) 5 - tcl::unsupported::assemble {{push 1,2} {incrArrayImm i 5}} - } + -body { + proc x arg { + set i(1,2) 5 + tcl::unsupported::assemble { + push 1,2 + incrArrayImm i 5 + } + } x 1 } -result {10} } test assemble-1.23 { Testing incrArrayStk } { - -body { proc x arg { set i(1,2) 5 - tcl::unsupported::assemble {{push i} {push 1,2} {push 5} {incrArrayStk}} - } + -body { + proc x arg { + set i(1,2) 5 + tcl::unsupported::assemble { + push i + push 1,2 + push 5 + incrArrayStk + } + } x 1 } -result {10} } test assemble-1.24 { Testing incrArrayStkImm } { - -body { proc x arg { set i(1,2) 5 - tcl::unsupported::assemble {{push i} {push 1,2} {incrArrayStkImm 5}} - } + -body { + proc x arg { + set i(1,2) 5 + tcl::unsupported::assemble { + push i + push 1,2 + incrArrayStkImm 5 + } + } x 1 } -result {10} @@ -279,9 +409,24 @@ test assemble-1.24 { Testing incrArrayStkImm } { test assemble-1.25 { Testing label and jumpTrue } { -body { - proc x {arg1 arg2} { tcl::unsupported::assemble {{label a} {load arg2} - {push 2} {mult} {store arg2} pop {load arg1} {push 1} {sub} {store arg1} - {push 0} {neq} {jumpTrue a} {load arg2}}} + proc x {arg1 arg2} { + tcl::unsupported::assemble { + label a + load arg2 + push 2 + mult + store arg2 + pop + load arg1 + push 1 + sub + store arg1 + push 0 + neq + jumpTrue a + load arg2 + } + } x 4 2 } -result {32} @@ -289,39 +434,99 @@ test assemble-1.25 { Testing label and jumpTrue } { test assemble-1.26 { Testing label and jumpFalse } { -body { - proc x {arg1 arg2} { tcl::unsupported::assemble {{label a} {load arg2} - {push 2} {mult} {store arg2} pop {load arg1} {push 1} {sub} {store arg1} - {push 0} {eq} {jumpFalse a} {load arg2}}} + proc x {arg1 arg2} { + tcl::unsupported::assemble { + label a + load arg2 + push 2 + mult + store arg2 + pop + load arg1 + push 1 + sub + store arg1 + push 0 + eq + jumpFalse a + load arg2 + } + } x 4 2 } -result {32} } -test assemble-1.27 { Testing trampoline undefined label and jump } { +test assemble-1.27 {forward jumps} { -body { - proc x {arg1 arg2 arg3} { tcl::unsupported::assemble {{jump a} {push aString} - {store arg1} pop {label a} {jump b} {push aString} {store arg2} {label b} {jump c} - {push aString} {store arg3} {label c} {load arg1} }} + proc x {arg1 arg2 arg3} { + tcl::unsupported::assemble { + jump a + push aString + store arg1 + pop + label a + jump b + push aString + store arg2 + label b + jump c + push aString + store arg3 + label c + load arg1 + } + } x 1 2 3 } -result {1} } -test assemble-1.28 { Testing trampoline undefined label and jump } { +test assemble-1.28 {forward jumps} { -body { - proc x {arg1 arg2 arg3} { tcl::unsupported::assemble {{jump a} {push aString} - {store arg1} pop {label a} {jump b} {push aString} {store arg2} {label b} {jump c} - {push aString} {store arg3} {label c} {load arg2} }} + proc x {arg1 arg2 arg3} { + tcl::unsupported::assemble { + jump a + push aString + store arg1 + pop + label a + jump b + push aString + store arg2 + label b + jump c + push aString + store arg3 + label c + load arg2 + } + } x 1 2 3 } -result {2} } -test assemble-1.29 { Testing trampoline undefined label and jump } { +test assemble-1.29 {forward jumps} { -body { - proc x {arg1 arg2 arg3} { tcl::unsupported::assemble {{jump a} {push aString} - {store arg1} pop {label a} {jump b} {push aString} {store arg2} {label b} {jump c} - {push aString} {store arg3} {label c} {load arg3} }} + proc x {arg1 arg2 arg3} { + tcl::unsupported::assemble { + jump a + push aString + store arg1 + pop + label a + jump b + push aString + store arg2 + label b + jump c + push aString + store arg3 + label c + load arg3 + } + } x 1 2 3 } -result {3} @@ -331,14 +536,14 @@ test assemble-1.30 {Inconsistent stack usage} {*}{ -body { proc x {y} { tcl::unsupported::assemble { - {load y} - {jumpFalse else} - {push 0} - {jump then} - {label else} - {push 1} - {push 2} - {label then} + load y + jumpFalse else + push 0 + jump then + label else + push 1 + push 2 + label then pop } } @@ -347,67 +552,67 @@ test assemble-1.30 {Inconsistent stack usage} {*}{ } -match glob -result {inconsistent stack depths on two execution paths - to source instruction at list index 7 ("label then")*} + ("tcl::unsupported::assemble" body, line 9)*} } test assemble-1.31 {unset, exists, lappend - smoke test} { -body { proc x {y} { tcl::unsupported::assemble { - {exist result} - {store result} - {pop} - - {exist result} - {lappend result} - {pop} - - {push result} - {push y} - {existStk} - {lappendStk} - {pop} - - {push y} - {unsetStk true} - {exist y} - {lappend result} - {pop} - - {push {}} - {store foo} - {pop} - {exist foo} - {lappend result} - {pop} - - {unset true foo} - {exist foo} - {lappend result} - {pop} - - {push a} - {existArray z} - {lappend result} - {pop} - - {push a} - {push b} - {lappendArray z} - {lappend result} - {pop} - - {push z} - {push a} - {existArrayStk} - {lappend result} - {pop} - - {push z} - {push a} - {push c} - {lappendArrayStk} - {lappend result} + exist result + store result + pop + + exist result + lappend result + pop + + push result + push y + existStk + lappendStk + pop + + push y + unsetStk true + exist y + lappend result + pop + + push {} + store foo + pop + exist foo + lappend result + pop + + unset true foo + exist foo + lappend result + pop + + push a + existArray z + lappend result + pop + + push a + push b + lappendArray z + lappend result + pop + + push z + push a + existArrayStk + lappend result + pop + + push z + push a + push c + lappendArrayStk + lappend result } } @@ -419,10 +624,10 @@ test assemble-1.31 {unset, exists, lappend - smoke test} { test assemble-2.1 {concat} { -body { ::tcl::unsupported::assemble { - {push a} - {push b} - {push c} - {concat 3} + push a + push b + push c + concat 3 } } -result abc @@ -431,8 +636,8 @@ test assemble-2.1 {concat} { test assemble-3.1 {expr} { -body { ::tcl::unsupported::assemble { - {push {1+2+3+4+5}} - {exprStk} + push {1+2+3+4+5} + exprStk } } -result 15 @@ -440,72 +645,89 @@ test assemble-3.1 {expr} { test assemble-4.1 {eval} { -body { ::tcl::unsupported::assemble { - {push {join [list [expr {1+2+3+4+5}] a] {}}} - {evalStk} + push {join [list [expr {1+2+3+4+5}] a] {}} + evalStk } } -result 15a } -set ::tcl_traceCompile 2 test assemble-4.2 {eval} { -body { proc x {} { ::tcl::unsupported::assemble { - {push 3} - {store n} + push 3 + store n pop - {eval {expr {3*$n + 1}}} + eval {expr {3*$n + 1}} + push 1 + add } } x } - -result 10 + -result 11 } -set ::tcl_traceCompile 0 +test assemble-4.3 {expr} { + -body { + proc x {} { + ::tcl::unsupported::assemble { + push 3 + store n + pop + expr {3*$n + 1} + push 1 + add + } + } + x + } + -result 11 +} + test assemble-30.1 {Ulam's 3n+1 problem, TAL implementation} { -body { - regsub -all {\#[^\n]*} { - {load n} # max - {dup} # max n - {jump start} # max n + proc ulam {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 n max n - {ge} # man n max>=n - {jumpTrue skip} # max n - - {reverse 2} # n max - {pop} # n - {dup} # n 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 + 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 + 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 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 + 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 - - } {} code - proc ulam n [list tcl::unsupported::assemble $code] + pop; # max + } + } set result {} for {set i 1} {$i < 30} {incr i} { lappend result [ulam $i] @@ -513,4 +735,11 @@ test assemble-30.1 {Ulam's 3n+1 problem, TAL implementation} { 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} -} \ No newline at end of file +} + +::tcltest::cleanupTests +return + +# Local Variables: +# mode: tcl +# End: \ No newline at end of file diff --git a/tests/assemble1.bench b/tests/assemble1.bench index 4f4dbce..18fd3a9 100644 --- a/tests/assemble1.bench +++ b/tests/assemble1.bench @@ -12,49 +12,74 @@ proc ulam1 {n} { } return $max } -set i 0 -puts [time {ulam1 [incr i]} 10000] -regsub -all {\#[^\n]*} { - {load n} # max - {dup} # max n - {jump start} # max n - - {label loop} # max n - {over 1} # max n max - {over 1} # max n 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; 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)}]" -} {} code -proc ulam2 n [list tcl::unsupported::assemble $code] -set i 0 -puts [time {ulam2 [incr i]} 10000] + 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/execute.test b/tests/execute.test index ce21040..4519890 100644 --- a/tests/execute.test +++ b/tests/execute.test @@ -14,7 +14,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: execute.test,v 1.35 2010/04/05 19:44:45 ferrieux Exp $ +# RCS: @(#) $Id: execute.test,v 1.35.2.1 2010/09/25 14:51:13 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -993,6 +993,27 @@ test execute-10.2 {Bug 2802881} -setup { interp delete slave } -returnCodes error -match glob -result * +test execute-10.3 {Bug 3072640} -setup { + proc generate {n} { + for {set i 0} {$i < $n} {incr i} { + yield $i + } + } + proc t {args} { + incr ::foo + } + trace add execution ::generate enterstep ::t +} -body { + coroutine coro generate 5 + trace remove execution ::generate enterstep ::t + set ::foo +} -cleanup { + unset ::foo + rename generate {} + rename t {} + rename coro {} +} -result 4 + # cleanup if {[info commands testobj] != {}} { testobj freeallvars diff --git a/tests/stringComp.test b/tests/stringComp.test index 2f187be..35c11d1 100644 --- a/tests/stringComp.test +++ b/tests/stringComp.test @@ -15,7 +15,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: stringComp.test,v 1.17 2009/06/24 15:17:41 dgp Exp $ +# RCS: @(#) $Id: stringComp.test,v 1.17.4.1 2010/09/25 14:51:13 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -44,180 +44,166 @@ test stringComp-1.3 {error condition - undefined method during compile} { foo abc 0 } a -test stringComp-2.1 {string compare, too few args} { - proc foo {} {string compare a} - list [catch {foo} msg] $msg -} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}} -test stringComp-2.2 {string compare, bad args} { - proc foo {} {string compare a b c} - list [catch {foo} msg] $msg -} {1 {bad option "a": must be -nocase or -length}} -test stringComp-2.3 {string compare, bad args} { - list [catch {string compare -length -nocase str1 str2} msg] $msg -} {1 {expected integer but got "-nocase"}} -test stringComp-2.4 {string compare, too many args} { - list [catch {string compare -length 10 -nocase str1 str2 str3} msg] $msg -} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}} -test stringComp-2.5 {string compare with length unspecified} { - list [catch {string compare -length 10 10} msg] $msg -} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}} -test stringComp-2.6 {string compare} { - proc foo {} {string compare abcde abdef} - foo -} -1 -test stringComp-2.7 {string compare, shortest method name} { - proc foo {} {string c abcde ABCDE} - foo -} 1 -test stringComp-2.8 {string compare} { - proc foo {} {string compare abcde abcde} - foo -} 0 -test stringComp-2.9 {string compare with length} { - proc foo {} {string compare -length 2 abcde abxyz} - foo -} 0 -test stringComp-2.10 {string compare with special index} { - proc foo {} {string compare -length end-3 abcde abxyz} - list [catch {foo} msg] $msg -} {1 {expected integer but got "end-3"}} -test stringComp-2.11 {string compare, unicode} { - proc foo {} {string compare ab\u7266 ab\u7267} - foo -} -1 -test stringComp-2.12 {string compare, high bit} { - # This test will fail if the underlying comparaison - # is using signed chars instead of unsigned chars. - # (like SunOS's default memcmp thus the compat/memcmp.c) - proc foo {} {string compare "\x80" "@"} - foo - # Nb this tests works also in utf8 space because \x80 is - # translated into a 2 or more bytelength but whose first byte has - # the high bit set. -} 1 -test stringComp-2.13 {string compare -nocase} { - proc foo {} {string compare -nocase abcde abdef} - foo -} -1 -test stringComp-2.14 {string compare -nocase} { - proc foo {} {string c -nocase abcde ABCDE} - foo -} 0 -test stringComp-2.15 {string compare -nocase} { - proc foo {} {string compare -nocase abcde abcde} - foo -} 0 -test stringComp-2.16 {string compare -nocase with length} { - proc foo {} {string compare -length 2 -nocase abcde Abxyz} - foo -} 0 -test stringComp-2.17 {string compare -nocase with length} { - proc foo {} {string compare -nocase -length 3 abcde Abxyz} - foo -} -1 -test stringComp-2.18 {string compare -nocase with length <= 0} { - proc foo {} {string compare -nocase -length -1 abcde AbCdEf} - foo -} -1 -test stringComp-2.19 {string compare -nocase with excessive length} { - proc foo {} {string compare -nocase -length 50 AbCdEf abcde} - foo -} 1 -test stringComp-2.20 {string compare -len unicode} { - # These are strings that are 6 BYTELENGTH long, but the length - # shouldn't make a different because there are actually 3 CHARS long - proc foo {} {string compare -len 5 \334\334\334 \334\334\374} - foo -} -1 -test stringComp-2.21 {string compare -nocase with special index} { - proc foo {} {string compare -nocase -length end-3 Abcde abxyz} - list [catch {foo} msg] $msg -} {1 {expected integer but got "end-3"}} -test stringComp-2.22 {string compare, null strings} { - proc foo {} {string compare "" ""} - foo -} 0 -test stringComp-2.23 {string compare, null strings} { - proc foo {} {string compare "" foo} - foo -} -1 -test stringComp-2.24 {string compare, null strings} { - proc foo {} {string compare foo ""} - foo -} 1 -test stringComp-2.25 {string compare -nocase, null strings} { - proc foo {} {string compare -nocase "" ""} - foo -} 0 -test stringComp-2.26 {string compare -nocase, null strings} { - proc foo {} {string compare -nocase "" foo} - foo -} -1 -test stringComp-2.27 {string compare -nocase, null strings} { - proc foo {} {string compare -nocase foo ""} - foo -} 1 -test stringComp-2.28 {string compare with length, unequal strings} { - proc foo {} {string compare -length 2 abc abde} - foo -} 0 -test stringComp-2.29 {string compare with length, unequal strings} { - proc foo {} {string compare -length 2 ab abde} - foo -} 0 -test stringComp-2.30 {string compare with NUL character vs. other ASCII} { - # Be careful here, since UTF-8 rep comparison with memcmp() of - # these puts chars in the wrong order - proc foo {} {string compare \x00 \x01} - foo -} -1 -test stringComp-2.31 {string compare, high bit} { - proc foo {} {string compare "a\x80" "a@"} - foo -} 1 -test stringComp-2.32 {string compare, high bit} { - proc foo {} {string compare "a\x00" "a\x01"} - foo -} -1 -test stringComp-2.33 {string compare, high bit} { - proc foo {} {string compare "\x00\x00" "\x00\x01"} - foo -} -1 +## Test string compare|equal over equal constraints +## Use result for string compare, and negate it for string equal +## The body will be tested both in and outside a proc +set i 0 +foreach {tname tbody tresult tcode} { + {too few args} { + string compare a + } {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"} {error} + {bad args} { + string compare a b c + } {bad option "a": must be -nocase or -length} {error} + {bad args} { + string compare -length -nocase str1 str2 + } {expected integer but got "-nocase"} {error} + {too many args} { + string compare -length 10 -nocase str1 str2 str3 + } {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"} {error} + {compare with length unspecified} { + string compare -length 10 10 + } {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"} {error} + {basic operation fail} { + string compare abcde abdef + } {-1} {} + {basic operation success} { + string compare abcde abcde + } {0} {} + {with length} { + string compare -length 2 abcde abxyz + } {0} {} + {with special index} { + string compare -length end-3 abcde abxyz + } {expected integer but got "end-3"} {error} + {unicode} { + string compare ab\u7266 ab\u7267 + } {-1} {} + {unicode} {string compare \334 \u00dc} 0 {} + {unicode} {string compare \334 \u00fc} -1 {} + {unicode} {string compare \334\334\334\374\374 \334\334\334\334\334} 1 {} + {high bit} { + # This test will fail if the underlying comparaison + # is using signed chars instead of unsigned chars. + # (like SunOS's default memcmp thus the compat/memcmp.c) + string compare "\x80" "@" + # Nb this tests works also in utf8 space because \x80 is + # translated into a 2 or more bytelength but whose first byte has + # the high bit set. + } {1} {} + {-nocase 1} {string compare -nocase abcde abdef} {-1} {} + {-nocase 2} {string compare -nocase abcde Abdef} {-1} {} + {-nocase 3} {string compare -nocase abcde ABCDE} {0} {} + {-nocase 4} {string compare -nocase abcde abcde} {0} {} + {-nocase unicode} { + string compare -nocase \334 \u00dc + } 0 {} + {-nocase unicode} { + string compare -nocase \334\334\334\374\u00fc \334\334\334\334\334 + } 0 {} + {-nocase with length} { + string compare -length 2 -nocase abcde Abxyz + } {0} {} + {-nocase with length} { + string compare -nocase -length 3 abcde Abxyz + } {-1} {} + {-nocase with length <= 0} { + string compare -nocase -length -1 abcde AbCdEf + } {-1} {} + {-nocase with excessive length} { + string compare -nocase -length 50 AbCdEf abcde + } {1} {} + {-len unicode} { + # These are strings that are 6 BYTELENGTH long, but the length + # shouldn't make a different because there are actually 3 CHARS long + string compare -len 5 \334\334\334 \334\334\374 + } -1 {} + {-nocase with special index} { + string compare -nocase -length end-3 Abcde abxyz + } {expected integer but got "end-3"} error + {null strings} { + string compare "" "" + } 0 {} + {null strings} { + string compare "" foo + } -1 {} + {null strings} { + string compare foo "" + } 1 {} + {-nocase null strings} { + string compare -nocase "" "" + } 0 {} + {-nocase null strings} { + string compare -nocase "" foo + } -1 {} + {-nocase null strings} { + string compare -nocase foo "" + } 1 {} + {with length, unequal strings} { + string compare -length 2 abc abde + } 0 {} + {with length, unequal strings} { + string compare -length 2 ab abde + } 0 {} + {with NUL character vs. other ASCII} { + # Be careful here, since UTF-8 rep comparison with memcmp() of + # these puts chars in the wrong order + string compare \x00 \x01 + } -1 {} + {high bit} { + string compare "a\x80" "a@" + } 1 {} + {high bit} { + string compare "a\x00" "a\x01" + } -1 {} + {high bit} { + string compare "\x00\x00" "\x00\x01" + } -1 {} + {binary equal} { + string compare [binary format a100 0] [binary format a100 0] + } 0 {} + {binary neq} { + string compare [binary format a100a 0 1] [binary format a100a 0 0] + } 1 {} + {binary neq inequal length} { + string compare [binary format a20a 0 1] [binary format a100a 0 0] + } 1 {} +} { + if {$tname eq ""} { continue } + if {$tcode eq ""} { set tcode ok } + test stringComp-2.[incr i] "string compare, $tname" \ + -body [list eval $tbody] \ + -returnCodes $tcode -result $tresult + test stringComp-2.[incr i] "string compare bc, $tname" \ + -body "[list proc foo {} $tbody];foo" \ + -returnCodes $tcode -result $tresult + if {"error" ni $tcode} { + set tresult [expr {!$tresult}] + } else { + set tresult [string map {compare equal} $tresult] + } + set tbody [string map {compare equal} $tbody] + test stringComp-2.[incr i] "string equal, $tname" \ + -body [list eval $tbody] \ + -returnCodes $tcode -result $tresult + test stringComp-2.[incr i] "string equal bc, $tname" \ + -body "[list proc foo {} $tbody];foo" \ + -returnCodes $tcode -result $tresult +} -# only need a few tests on equal, since it uses the same code as -# string compare, but just modifies the return output -test stringComp-3.1 {string equal} { - proc foo {} {string equal abcde abdef} - foo -} 0 -test stringComp-3.2 {string equal} { - proc foo {} {string eq abcde ABCDE} - foo -} 0 -test stringComp-3.3 {string equal} { - proc foo {} {string equal abcde abcde} - foo -} 1 -test stringComp-3.4 {string equal -nocase} { - proc foo {} {string equal -nocase \334\334\334\334\374\374\374\374 \334\334\334\334\334\334\334\334} +# need a few extra tests short abbr cmd +test stringComp-3.1 {string compare, shortest method name} { + proc foo {} {string c abcde ABCDE} foo } 1 -test stringComp-3.5 {string equal -nocase} { - proc foo {} {string equal -nocase abcde abdef} +test stringComp-3.2 {string equal, shortest method name} { + proc foo {} {string e abcde ABCDE} foo } 0 -test stringComp-3.6 {string equal -nocase} { +test stringComp-3.3 {string equal -nocase} { proc foo {} {string eq -nocase abcde ABCDE} foo } 1 -test stringComp-3.7 {string equal -nocase} { - proc foo {} {string equal -nocase abcde abcde} - foo -} 1 -test stringComp-3.8 {string equal with length, unequal strings} { - proc foo {} {string equal -length 2 abc abde} - foo -} 1 test stringComp-4.1 {string first, too few args} { proc foo {} {string first a} diff --git a/unix/Makefile.in b/unix/Makefile.in index 3175283..ba16b85 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -4,7 +4,7 @@ # "./configure", which is a configuration script generated by the "autoconf" # program (constructs like "@foo@" will get replaced in the actual Makefile. # -# RCS: @(#) $Id: Makefile.in,v 1.306.2.1 2010/09/21 19:32:26 kennykb Exp $ +# RCS: @(#) $Id: Makefile.in,v 1.306.2.2 2010/09/25 14:51:13 kennykb Exp $ VERSION = @TCL_VERSION@ MAJOR_VERSION = @TCL_MAJOR_VERSION@ @@ -1668,7 +1668,7 @@ packages: configure-packages ${STUB_LIB_FILE} pkg=`basename $$i`; \ if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \ echo "Building package '$$pkg'"; \ - ( cd $(PKG_DIR)/$$pkg; $(MAKE); ) || exit $$?; \ + ( cd $(PKG_DIR)/$$pkg; $(MAKE) --no-print-directory; ) || exit $$?; \ fi; \ fi; \ done @@ -1679,7 +1679,7 @@ install-packages: packages pkg=`basename $$i`; \ if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \ echo "Installing package '$$pkg'"; \ - ( cd $(PKG_DIR)/$$pkg; $(MAKE) install \ + ( cd $(PKG_DIR)/$$pkg; $(MAKE) --no-print-directory install \ "DESTDIR=$(INSTALL_ROOT)"; ) || exit $$?; \ fi; \ fi; \ @@ -1690,8 +1690,10 @@ test-packages: tcltest packages if [ -d $$i ]; then \ pkg=`basename $$i`; \ if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \ + echo ""; \ + echo ""; \ echo "Testing package '$$pkg'"; \ - ( cd $(PKG_DIR)/$$pkg; $(MAKE) \ + ( cd $(PKG_DIR)/$$pkg; $(MAKE) --no-print-directory \ "@LD_LIBRARY_PATH_VAR@=../..:$${@LD_LIBRARY_PATH_VAR@}" \ "TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" \ "TCLLIBPATH=../../pkgs" test \ @@ -1705,7 +1707,7 @@ clean-packages: if [ -d $$i ]; then \ pkg=`basename $$i`; \ if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \ - ( cd $(PKG_DIR)/$$pkg; $(MAKE) clean; ) \ + ( cd $(PKG_DIR)/$$pkg; $(MAKE) --no-print-directory clean; ) \ fi; \ fi; \ done @@ -1715,7 +1717,7 @@ distclean-packages: if [ -d $$i ]; then \ pkg=`basename $$i`; \ if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \ - ( cd $(PKG_DIR)/$$pkg; $(MAKE) distclean; ) \ + ( cd $(PKG_DIR)/$$pkg; $(MAKE) --no-print-directory distclean; ) \ fi; \ rm -rf $(PKG_DIR)/$$pkg; \ fi; \ @@ -1729,7 +1731,7 @@ dist-packages: configure-packages if [ -d $$i ]; then \ pkg=`basename $$i`; \ if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \ - ( cd $(PKG_DIR)/$$pkg; $(MAKE) dist \ + ( cd $(PKG_DIR)/$$pkg; $(MAKE) --no-print-directory dist \ "DIST_ROOT=$(DISTROOT)/pkgs"; ) || exit $$?; \ fi; \ fi; \ diff --git a/unix/tclAppInit.c b/unix/tclAppInit.c index 7c78b58..459f45f 100644 --- a/unix/tclAppInit.c +++ b/unix/tclAppInit.c @@ -2,33 +2,50 @@ * tclAppInit.c -- * * Provides a default version of the main program and Tcl_AppInit - * function for Tcl applications (without Tk). + * procedure for tclsh and other Tcl-based applications (without Tk). * * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. - * Copyright (c) 1998-1999 by Scriptics Corporation. + * Copyright (c) 1998-1999 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclAppInit.c,v 1.22 2009/11/29 09:00:24 das Exp $ + * RCS: @(#) $Id: tclAppInit.c,v 1.22.4.1 2010/09/25 14:51:13 kennykb Exp $ */ #include "tcl.h" #ifdef TCL_TEST - -#include "tclInt.h" - -extern Tcl_PackageInitProc Tcltest_Init; -extern Tcl_PackageInitProc Tcltest_SafeInit; - +extern Tcl_PackageInitProc Tcltest_Init; +extern Tcl_PackageInitProc Tcltest_SafeInit; #endif /* TCL_TEST */ #ifdef TCL_XT_TEST extern void XtToolkitInitialize(void); extern int Tclxttest_Init(Tcl_Interp *interp); #endif + +/* + * The following #if block allows you to change the AppInit function by using + * a #define of TCL_LOCAL_APPINIT instead of rewriting this entire file. The + * #if checks for that #define and uses Tcl_AppInit if it doesn't exist. + */ + +#ifndef TCL_LOCAL_APPINIT +#define TCL_LOCAL_APPINIT Tcl_AppInit +#endif +extern int TCL_LOCAL_APPINIT(Tcl_Interp *interp); + +/* + * The following #if block allows you to change how Tcl finds the startup + * script, prime the library or encoding paths, fiddle with the argv, etc., + * without needing to rewrite Tcl_Main() + */ + +#ifdef TCL_LOCAL_MAIN_HOOK +extern int TCL_LOCAL_MAIN_HOOK(int *argc, char ***argv); +#endif /* *---------------------------------------------------------------------- @@ -38,11 +55,11 @@ extern int Tclxttest_Init(Tcl_Interp *interp); * This is the main program for the application. * * Results: - * None: Tcl_Main never returns here, so this function never returns + * None: Tcl_Main never returns here, so this procedure never returns * either. * * Side effects: - * Whatever the application does. + * Just about anything, since from here we call arbitrary Tcl code. * *---------------------------------------------------------------------- */ @@ -52,28 +69,6 @@ main( int argc, /* Number of command-line arguments. */ char **argv) /* Values of command-line arguments. */ { - /* - * The following #if block allows you to change the AppInit function by - * using a #define of TCL_LOCAL_APPINIT instead of rewriting this entire - * file. The #if checks for that #define and uses Tcl_AppInit if it does - * not exist. - */ - -#ifndef TCL_LOCAL_APPINIT -#define TCL_LOCAL_APPINIT Tcl_AppInit -#endif - extern int TCL_LOCAL_APPINIT(Tcl_Interp *interp); - - /* - * The following #if block allows you to change how Tcl finds the startup - * script, prime the library or encoding paths, fiddle with the argv, - * etc., without needing to rewrite Tcl_Main() - */ - -#ifdef TCL_LOCAL_MAIN_HOOK - extern int TCL_LOCAL_MAIN_HOOK(int *argc, char ***argv); -#endif - #ifdef TCL_XT_TEST XtToolkitInitialize(); #endif @@ -83,7 +78,6 @@ main( #endif Tcl_Main(argc, argv, TCL_LOCAL_APPINIT); - return 0; /* Needed only to prevent compiler warning. */ } @@ -92,9 +86,9 @@ main( * * Tcl_AppInit -- * - * This function performs application-specific initialization. Most + * This procedure performs application-specific initialization. Most * applications, especially those that incorporate additional packages, - * will have their own version of this function. + * will have their own version of this procedure. * * Results: * Returns a standard Tcl completion code, and leaves an error message in @@ -110,16 +104,17 @@ int Tcl_AppInit( Tcl_Interp *interp) /* Interpreter for application. */ { - if (Tcl_Init(interp) == TCL_ERROR) { + if ((Tcl_Init)(interp) == TCL_ERROR) { return TCL_ERROR; } -#ifdef TCL_TEST #ifdef TCL_XT_TEST if (Tclxttest_Init(interp) == TCL_ERROR) { return TCL_ERROR; } #endif + +#ifdef TCL_TEST if (Tcltest_Init(interp) == TCL_ERROR) { return TCL_ERROR; } @@ -127,7 +122,7 @@ Tcl_AppInit( #endif /* TCL_TEST */ /* - * Call the init functions for included packages. Each call should look + * Call the init procedures for included packages. Each call should look * like this: * * if (Mod_Init(interp) == TCL_ERROR) { @@ -140,7 +135,7 @@ Tcl_AppInit( /* * Call Tcl_CreateCommand for application-specific commands, if they - * weren't already created by the init functions called above. + * weren't already created by the init procedures called above. */ /* @@ -151,9 +146,9 @@ Tcl_AppInit( */ #ifdef DJGPP - Tcl_SetVar(interp, "tcl_rcFileName", "~/tclsh.rc", TCL_GLOBAL_ONLY); + (Tcl_SetVar)(interp, "tcl_rcFileName", "~/tclsh.rc", TCL_GLOBAL_ONLY); #else - Tcl_SetVar(interp, "tcl_rcFileName", "~/.tclshrc", TCL_GLOBAL_ONLY); + (Tcl_SetVar)(interp, "tcl_rcFileName", "~/.tclshrc", TCL_GLOBAL_ONLY); #endif return TCL_OK; diff --git a/win/configure b/win/configure index fefa99b..771a1cb 100755 --- a/win/configure +++ b/win/configure @@ -4070,7 +4070,7 @@ echo "${ECHO_T} Using 64-bit $MACHINE mode" >&6 fi fi - LIBS="user32.lib advapi32.lib ws2_32.lib" + LIBS="kernel32.lib user32.lib advapi32.lib ws2_32.lib" if test "$do64bit" != "no" ; then # The space-based-path will work for the Makefile, but will # not work if AC_TRY_COMPILE is called. TEA has the diff --git a/win/tcl.m4 b/win/tcl.m4 index 1ad10ae..20845c0 100644 --- a/win/tcl.m4 +++ b/win/tcl.m4 @@ -615,7 +615,7 @@ file for information about building with Mingw.]) fi fi - LIBS="user32.lib advapi32.lib ws2_32.lib" + LIBS="kernel32.lib user32.lib advapi32.lib ws2_32.lib" if test "$do64bit" != "no" ; then # The space-based-path will work for the Makefile, but will # not work if AC_TRY_COMPILE is called. TEA has the diff --git a/win/tclAppInit.c b/win/tclAppInit.c index a4d38de..6711384 100644 --- a/win/tclAppInit.c +++ b/win/tclAppInit.c @@ -2,30 +2,62 @@ * tclAppInit.c -- * * Provides a default version of the main program and Tcl_AppInit - * function for Tcl applications (without Tk). Note that this program - * must be built in Win32 console mode to work properly. + * procedure for tclsh and other Tcl-based applications (without Tk). + * Note that this program must be built in Win32 console mode to work properly. * - * Copyright (c) 1996-1997 by Sun Microsystems, Inc. - * Copyright (c) 1998-1999 by Scriptics Corporation. + * Copyright (c) 1993 The Regents of the University of California. + * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 1998-1999 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclAppInit.c,v 1.31 2010/05/03 13:20:39 nijtmans Exp $ + * RCS: @(#) $Id: tclAppInit.c,v 1.31.2.1 2010/09/25 14:51:13 kennykb Exp $ */ +/* TODO: This file does not compile in UNICODE mode. + * See [Freq 2965056]: Windows build with -DUNICODE + */ +#undef UNICODE +#undef _UNICODE + #include "tcl.h" +#define WIN32_LEAN_AND_MEAN #include +#undef WIN32_LEAN_AND_MEAN #include +#include +#include #ifdef TCL_TEST -extern Tcl_PackageInitProc Tcltest_Init; -extern Tcl_PackageInitProc Tcltest_SafeInit; +extern Tcl_PackageInitProc Tcltest_Init; +extern Tcl_PackageInitProc Tcltest_SafeInit; #endif /* TCL_TEST */ #if defined(__GNUC__) -static void setargv(int *argcPtr, char ***argvPtr); +static void setargv(int *argcPtr, TCHAR ***argvPtr); #endif /* __GNUC__ */ + +/* + * The following #if block allows you to change the AppInit function by using + * a #define of TCL_LOCAL_APPINIT instead of rewriting this entire file. The + * #if checks for that #define and uses Tcl_AppInit if it doesn't exist. + */ + +#ifndef TCL_LOCAL_APPINIT +#define TCL_LOCAL_APPINIT Tcl_AppInit +#endif +extern int TCL_LOCAL_APPINIT(Tcl_Interp *interp); + +/* + * The following #if block allows you to change how Tcl finds the startup + * script, prime the library or encoding paths, fiddle with the argv, etc., + * without needing to rewrite Tcl_Main() + */ + +#ifdef TCL_LOCAL_MAIN_HOOK +extern int TCL_LOCAL_MAIN_HOOK(int *argc, TCHAR ***argv); +#endif /* *---------------------------------------------------------------------- @@ -35,61 +67,44 @@ static void setargv(int *argcPtr, char ***argvPtr); * This is the main program for the application. * * Results: - * None: Tcl_Main never returns here, so this function never returns + * None: Tcl_Main never returns here, so this procedure never returns * either. * * Side effects: - * Whatever the application does. + * Just about anything, since from here we call arbitrary Tcl code. * *---------------------------------------------------------------------- */ int -main( +_tmain( int argc, - char *argv[]) + TCHAR *argv[]) { - /* - * The following #if block allows you to change the AppInit function by - * using a #define of TCL_LOCAL_APPINIT instead of rewriting this entire - * file. The #if checks for that #define and uses Tcl_AppInit if it - * doesn't exist. - */ - -#ifndef TCL_LOCAL_APPINIT -#define TCL_LOCAL_APPINIT Tcl_AppInit -#endif - extern int TCL_LOCAL_APPINIT(Tcl_Interp *interp); + TCHAR *p; /* - * The following #if block allows you to change how Tcl finds the startup - * script, prime the library or encoding paths, fiddle with the argv, - * etc., without needing to rewrite Tcl_Main() + * Set up the default locale to be standard "C" locale so parsing is + * performed correctly. */ -#ifdef TCL_LOCAL_MAIN_HOOK - extern int TCL_LOCAL_MAIN_HOOK(int *argc, char ***argv); -#endif - - char *p; + setlocale(LC_ALL, "C"); /* - * Set up the default locale to be standard "C" locale so parsing is - * performed correctly. + * Get our args from the c-runtime. Ignore lpszCmdLine. */ #if defined(__GNUC__) setargv(&argc, &argv); #endif - setlocale(LC_ALL, "C"); /* * Forward slashes substituted for backslashes. */ - for (p = argv[0]; *p != '\0'; p++) { - if (*p == '\\') { - *p = '/'; + for (p = argv[0]; *p != TEXT('\0'); p++) { + if (*p == TEXT('\\')) { + *p = TEXT('/'); } } @@ -98,7 +113,6 @@ main( #endif Tcl_Main(argc, argv, TCL_LOCAL_APPINIT); - return 0; /* Needed only to prevent compiler warning. */ } @@ -107,9 +121,9 @@ main( * * Tcl_AppInit -- * - * This function performs application-specific initialization. Most + * This procedure performs application-specific initialization. Most * applications, especially those that incorporate additional packages, - * will have their own version of this function. + * will have their own version of this procedure. * * Results: * Returns a standard Tcl completion code, and leaves an error message in @@ -125,17 +139,10 @@ int Tcl_AppInit( Tcl_Interp *interp) /* Interpreter for application. */ { - if (Tcl_Init(interp) == TCL_ERROR) { + if ((Tcl_Init)(interp) == TCL_ERROR) { return TCL_ERROR; } -#ifdef TCL_TEST - if (Tcltest_Init(interp) == TCL_ERROR) { - return TCL_ERROR; - } - Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, NULL); -#endif /* TCL_TEST */ - #if defined(STATIC_BUILD) && TCL_USE_STATIC_PACKAGES { extern Tcl_PackageInitProc Registry_Init; @@ -154,30 +161,38 @@ Tcl_AppInit( } #endif +#ifdef TCL_TEST + if (Tcltest_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, Tcltest_SafeInit); +#endif /* TCL_TEST */ + /* - * Call the init functions for included packages. Each call should look + * Call the init procedures for included packages. Each call should look * like this: * * if (Mod_Init(interp) == TCL_ERROR) { * return TCL_ERROR; * } * - * where "Mod" is the name of the module. + * where "Mod" is the name of the module. (Dynamically-loadable packages + * should have the same entry-point name.) */ /* * Call Tcl_CreateCommand for application-specific commands, if they - * weren't already created by the init functions called above. + * weren't already created by the init procedures called above. */ /* * Specify a user-specific startup file to invoke if the application is * run interactively. Typically the startup file is "~/.apprc" where "app" - * is the name of the application. If this line is deleted then no - * user-specific startup file will be run under any conditions. + * is the name of the application. If this line is deleted then no user- + * specific startup file will be run under any conditions. */ - Tcl_SetVar(interp, "tcl_rcFileName", "~/tclshrc.tcl", TCL_GLOBAL_ONLY); + (Tcl_SetVar)(interp, "tcl_rcFileName", "~/tclshrc.tcl", TCL_GLOBAL_ONLY); return TCL_OK; } @@ -212,13 +227,13 @@ Tcl_AppInit( static void setargv( int *argcPtr, /* Filled with number of argument strings. */ - char ***argvPtr) /* Filled with argument strings (malloc'd). */ + TCHAR ***argvPtr) /* Filled with argument strings (malloc'd). */ { - char *cmdLine, *p, *arg, *argSpace; - char **argv; + TCHAR *cmdLine, *p, *arg, *argSpace; + TCHAR **argv; int argc, size, inquote, copy, slashes; - cmdLine = GetCommandLineA(); /* INTL: BUG */ + cmdLine = GetCommandLine(); /* * Precompute an overly pessimistic guess at the number of arguments in @@ -226,30 +241,30 @@ setargv( */ size = 2; - for (p = cmdLine; *p != '\0'; p++) { - if ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */ + for (p = cmdLine; *p != TEXT('\0'); p++) { + if ((*p == TEXT(' ')) || (*p == TEXT('\t'))) { /* INTL: ISO space. */ size++; - while ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */ + while ((*p == TEXT(' ')) || (*p == TEXT('\t'))) { /* INTL: ISO space. */ p++; } - if (*p == '\0') { + if (*p == TEXT('\0')) { break; } } } - argSpace = (char *) ckalloc( - (unsigned) (size * sizeof(char *) + strlen(cmdLine) + 1)); - argv = (char **) argSpace; - argSpace += size * sizeof(char *); + argSpace = (TCHAR *) ckalloc( + (unsigned) (size * sizeof(TCHAR *) + (_tcslen(cmdLine) * sizeof(TCHAR)) + 1)); + argv = (TCHAR **) argSpace; + argSpace += size * sizeof(TCHAR *); size--; p = cmdLine; for (argc = 0; argc < size; argc++) { argv[argc] = arg = argSpace; - while ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */ + while ((*p == TEXT(' ')) || (*p == TEXT('\t'))) { /* INTL: ISO space. */ p++; } - if (*p == '\0') { + if (*p == TEXT('\0')) { break; } @@ -257,14 +272,14 @@ setargv( slashes = 0; while (1) { copy = 1; - while (*p == '\\') { + while (*p == TEXT('\\')) { slashes++; p++; } - if (*p == '"') { + if (*p == TEXT('"')) { if ((slashes & 1) == 0) { copy = 0; - if ((inquote) && (p[1] == '"')) { + if ((inquote) && (p[1] == TEXT('"'))) { p++; copy = 1; } else { @@ -275,13 +290,13 @@ setargv( } while (slashes) { - *arg = '\\'; + *arg = TEXT('\\'); arg++; slashes--; } - if ((*p == '\0') || (!inquote && - ((*p == ' ') || (*p == '\t')))) { /* INTL: ISO space. */ + if ((*p == TEXT('\0')) || (!inquote && + ((*p == TEXT(' ')) || (*p == TEXT('\t'))))) { /* INTL: ISO space. */ break; } if (copy != 0) { @@ -290,7 +305,7 @@ setargv( } p++; } - *arg = '\0'; + *arg = TEXT('\0'); argSpace = arg + 1; } argv[argc] = NULL; diff --git a/win/tclWinSock.c b/win/tclWinSock.c index b4ef80b..8181113 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -8,7 +8,43 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinSock.c,v 1.74 2010/09/13 14:20:39 nijtmans Exp $ + * RCS: @(#) $Id: tclWinSock.c,v 1.74.2.1 2010/09/25 14:51:13 kennykb Exp $ + * + * ----------------------------------------------------------------------- + * + * General information on how this module works. + * + * - Each Tcl-thread with its sockets maintains an internal window to receive + * socket messages from the OS. + * + * - To ensure that message reception is always running this window is + * actually owned and handled by an internal thread. This we call the + * co-thread of Tcl's thread. + * + * - The whole structure is set up by InitSockets() which is called for each + * Tcl thread. The implementation of the co-thread is in SocketThread(), + * and the messages are handled by SocketProc(). The connection between + * both is not directly visible, it is done through a Win32 window class. + * This class is initialized by InitSockets() as well, and used in the + * creation of the message receiver windows. + * + * - An important thing to note is that *both* thread and co-thread have + * access to the list of sockets maintained in the private TSD data of the + * thread. The co-thread was given access to it upon creation through the + * new thread's client-data. + * + * Because of this dual access the TSD data contains an OS mutex, the + * "socketListLock", to mediate exclusion between thread and co-thread. + * + * The co-thread's access is all in SocketProc(). The thread's access is + * through SocketEventProc() (1) and the functions called by it. + * + * (Ad 1) This is the handler function for all queued socket events, which + * all the OS messages are translated to through the EventSource (2) + * driven by the OS messages. + * + * (Ad 2) The main functions for this are SocketSetupProc() and + * SocketCheckProc(). */ #include "tclWinInt.h" @@ -1463,6 +1499,12 @@ TcpAccept( &len); /* + * Protect access to sockets (acceptEventCount, readyEvents) in socketList + * by the lock. Fix for SF Tcl Bug 3056775. + */ + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + + /* * Clear the ready mask so we can detect the next connection request. Note * that connection requests are level triggered, so if there is a request * already pending, a new event will be generated. @@ -1471,6 +1513,8 @@ TcpAccept( if (newSocket == INVALID_SOCKET) { infoPtr->acceptEventCount = 0; infoPtr->readyEvents &= ~(FD_ACCEPT); + + SetEvent(tsdPtr->socketListLock); return; } @@ -1486,6 +1530,8 @@ TcpAccept( infoPtr->readyEvents &= ~(FD_ACCEPT); } + SetEvent(tsdPtr->socketListLock); + /* * Win-NT has a misfeature that sockets are inherited in child processes * by default. Turn off the inherit bit. -- cgit v0.12