summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog64
-rw-r--r--generic/tclAssembly.c1824
-rw-r--r--generic/tclAssembly.h13
-rw-r--r--generic/tclCmdAH.c3
-rw-r--r--generic/tclDecls.h6
-rw-r--r--generic/tclEvent.c3
-rw-r--r--generic/tclExecute.c212
-rw-r--r--generic/tclMain.c3
-rw-r--r--tests/assemble.test655
-rw-r--r--tests/assemble1.bench113
-rw-r--r--tests/execute.test23
-rw-r--r--tests/stringComp.test320
-rw-r--r--unix/Makefile.in16
-rw-r--r--unix/tclAppInit.c79
-rwxr-xr-xwin/configure2
-rw-r--r--win/tcl.m42
-rw-r--r--win/tclAppInit.c165
-rw-r--r--win/tclWinSock.c48
18 files changed, 2259 insertions, 1292 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 <kennykb@acm.org>
+
+ [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 <jeffh@ActiveState.com>
+
+ * 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 <andreask@activestate.com>
+
+ * 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 <nijtmans@users.sf.net>
+
+ * 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 <dgp@users.sourceforge.net>
+
+ * 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 <nijtmans@users.sf.net>
+
+ * unix/tclAppInit.c: Make compilable with -DUNICODE (not
+ * win/tclAppInit.c: actived yet), many clean-ups in comments.
+
+2010-09-22 Miguel Sofer <msofer@users.sf.net>
+
+ * 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 <nijtmans@users.sf.net>
+
+ * 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 <jeffh@ActiveState.com>
* 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,472 +702,806 @@ 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 */
{
+ Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
+ /* Tcl interpreter */
+ /*
+ * Walk through the assembly script using the Tcl parser.
+ * Each 'command' will be an instruction or assembly directive.
+ */
- 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
+ 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 */
- /* Test that the bytecode that we're given is a well formed list */
+ AssembleEnv* assemEnvPtr = NewAssembleEnv(envPtr, flags);
+ Tcl_Parse* parsePtr = assemEnvPtr->parsePtr;
- if (Tcl_ListObjLength(interp, bcList, &bcListLen) == TCL_ERROR) {
- return TCL_ERROR;
- }
-
- /* Initialize the symbol table and the table of basic blocks */
+ do {
- Tcl_InitHashTable(&labelHash, TCL_STRING_KEYS);
- Tcl_InitHashTable(&BBHash, TCL_STRING_KEYS);
+ /* Parse out one command line from the assembly script */
- /* Allocate a structure to describe the first basic block */
+ status = Tcl_ParseCommand(interp, instPtr, bytesLeft, 0, parsePtr);
+ instLen = parsePtr->commandSize;
+ if (parsePtr->term == parsePtr->commandStart + instLen - 1) {
+ --instLen;
+ }
- curr_bb = AllocBB(envPtr, 0);
- head_bb = curr_bb;
-
- /*
- * Index through the assembly directives and instructions, generating code.
- */
+ /* Report errors in the parse */
- for (ind = 0; ind < bcListLen; ind++) {
+ if (status != TCL_OK) {
+ if (flags & TCL_EVAL_DIRECT) {
+ Tcl_LogCommandInfo(interp, codePtr, parsePtr->commandStart,
+ instLen);
+ }
+ FreeAssembleEnv(assemEnvPtr);
+ return TCL_ERROR;
+ }
- /* Extract the instruction name from a list element */
+ /* Advance the pointers around any leading commentary */
- 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
+ TclAdvanceLines(&assemEnvPtr->cmdLine, instPtr, parsePtr->commandStart);
+ TclAdvanceContinuations(&assemEnvPtr->cmdLine, &assemEnvPtr->clNext,
+ parsePtr->commandStart - envPtr->source);
- /*
- * Extract the first operand, if there is one, and get its string
- * representation
- */
+ /* Process the line of code */
- if (bcSize >= 2) {
- operand1 = Tcl_GetStringFromObj(bcArgs[1], &operand1Len);
- } else {
- operand1 = NULL;
- operand1Len = 0;
- }
+ if (parsePtr->numWords > 0) {
- /* Look up the instruction in the table of instructions */
+ /* If tracing, show each line assembled as it happens */
- if (Tcl_GetIndexFromObjStruct(interp, bcArgs[0],
- &talInstructionTable[0].name,
- sizeof(talInstDesc), "instruction",
- TCL_EXACT, &tblind) != TCL_OK) {
- goto cleanup;
+#ifdef TCL_COMPILE_DEBUG
+ if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) {
+ printf(" Assembling: ");
+ TclPrintSource(stdout, parsePtr->commandStart,
+ TclMin(instLen, 55));
+ printf("\n");
+ }
+#endif
+ if (AssembleOneLine(assemEnvPtr) != TCL_OK) {
+ if (flags & TCL_EVAL_DIRECT) {
+ Tcl_LogCommandInfo(interp, codePtr, parsePtr->commandStart,
+ instLen);
+ }
+ Tcl_FreeParse(parsePtr);
+ FreeAssembleEnv(assemEnvPtr);
+ return TCL_ERROR;
+ }
}
- /* Vector on the type of instruction being processed */
+ /* Advance to the next line of code */
- instType = talInstructionTable[tblind].instType;
- instCode = talInstructionTable[tblind].tclInstCode;
- switch (instType) {
+ 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_LABEL:
+ /* Done with parsing the code */
- 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 */
+ 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
+ *
+ *-----------------------------------------------------------------------------
+ */
- curr_bb = StartBasicBlock(envPtr, &BBHash, curr_bb, 1, ind, NULL);
+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 */
- /* Attach the label to the new basic block */
+ assemEnvPtr->envPtr = envPtr;
+ assemEnvPtr->parsePtr = parsePtr;
+ assemEnvPtr->cmdLine = envPtr->line;
+ assemEnvPtr->clNext = envPtr->clNext;
- 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;
+ /* Make the hashtables that store symbol resolution */
- case ASSEM_INVOKE:
- if (bcSize != 2) {
- Tcl_WrongNumArgs(interp, 1, bcArgs, "count");
- goto cleanup;
- }
- if (Tcl_GetIntFromObj(interp, bcArgs[1], &opnd) != TCL_OK) {
- goto cleanup;
- }
- BBEmitInst1or4(envPtr, curr_bb, tblind, opnd, opnd);
- break;
-
- case ASSEM_JUMP:
- if (bcSize != 2) {
- Tcl_WrongNumArgs(interp, 1, bcArgs, "label");
- goto cleanup;
- }
- entry = Tcl_CreateHashEntry(&labelHash, operand1, &isNew);
- if (isNew) {
- l = (label *) ckalloc(sizeof(label));
- l -> isDefined = 0;
- l -> offset = -1;
- Tcl_SetHashValue(entry, l);
- } else {
- l = Tcl_GetHashValue(entry);
- }
- if (l -> isDefined) {
- BBEmitInst1or4(envPtr, curr_bb, tblind,
- l->offset + envPtr->codeStart
- - envPtr->codeNext, 0);
- } else {
- int here = envPtr->codeNext - envPtr->codeStart;
- BBEmitInstInt4(envPtr, curr_bb, tblind,
- l->offset, 0);
-#if 0
- fprintf(stderr, "forward ref to %s, prev at %d, link %d\n",
- operand1, l->offset, here);
-#endif
- l->offset = here;
- }
-
- /* Start a new basic block at the instruction following the jump */
+ Tcl_InitHashTable(&assemEnvPtr->labelHash, TCL_STRING_KEYS);
+ Tcl_InitHashTable(&assemEnvPtr->BBHash, TCL_STRING_KEYS);
- curr_bb =
- StartBasicBlock(envPtr, &BBHash, curr_bb,
- talInstructionTable[tblind].operandsConsumed,
- ind+1, operand1);
+ /* Start the first basic block */
- 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;
+ assemEnvPtr->head_bb = AllocBB(assemEnvPtr);
+ assemEnvPtr->curr_bb = assemEnvPtr->head_bb;
- 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;
+ /* Stash compilation flags */
- 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;
+ assemEnvPtr->flags = flags;
- case ASSEM_BOOL_LVT4:
- if (bcSize != 3) {
- Tcl_WrongNumArgs(interp, 1, bcArgs, "boolean varName");
- goto cleanup;
- }
- if (Tcl_GetBooleanFromObj(interp, bcArgs[1], &opnd) != TCL_OK) {
- goto cleanup;
- }
- operand1 = Tcl_GetStringFromObj(bcArgs[2], &operand1Len);
- if (CheckNamespaceQualifiers(interp, operand1)) {
- goto cleanup;
- }
- localVar = TclFindCompiledLocal(operand1, operand1Len, 1, envPtr);
- if (localVar == -1) {
- Tcl_SetObjResult(interp,
- Tcl_NewStringObj("cannot use this instruction"
- " in non-proc context", -1));
- Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", NULL);
- goto cleanup;
- }
- BBEmitInstInt1(envPtr, curr_bb, tblind, opnd, 0);
- TclEmitInt4(localVar, envPtr);
- break;
-
- case ASSEM_LVT1_SINT1:
- if (bcSize != 3) {
- Tcl_WrongNumArgs(interp, 1, bcArgs, "varName imm8");
- goto cleanup;
- }
- if (CheckNamespaceQualifiers(interp, operand1)) {
- goto cleanup;
- }
- localVar = TclFindCompiledLocal(operand1, operand1Len, 1, envPtr);
- if (localVar == -1) {
- Tcl_SetObjResult(interp,
- Tcl_NewStringObj("cannot use this instruction"
- " in non-proc context", -1));
- Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", NULL);
- goto cleanup;
- }
- if (CheckOneByte(interp, localVar)) {
- goto cleanup;
- }
- if (Tcl_GetIntFromObj(interp, bcArgs[2], &opnd) != TCL_OK) {
- goto cleanup;
- }
- if (CheckSignedOneByte(interp, opnd)) {
- goto cleanup;
- }
- BBEmitInstInt1(envPtr, curr_bb, tblind, localVar, 0);
- TclEmitInt1(opnd, envPtr);
- break;
-
- case ASSEM_OVER:
- if (bcSize != 2) {
- Tcl_WrongNumArgs(interp, 1, bcArgs, "count");
- goto cleanup;
- }
- if (Tcl_GetIntFromObj(interp, bcArgs[1], &opnd) != TCL_OK) {
- goto cleanup;
- }
- BBEmitInstInt4(envPtr, curr_bb, tblind, opnd, opnd+1);
- break;
+ return assemEnvPtr;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * FreeAssembleEnv --
+ *
+ * Cleans up the assembler environment when assembly is complete.
+ *
+ *-----------------------------------------------------------------------------
+ */
- 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;
+static void
+FreeAssembleEnv(AssembleEnv* assemEnvPtr)
+ /* Environment to free */
+{
+ CompileEnv* envPtr = assemEnvPtr->envPtr;
+ /* Compilation environment being used
+ * for code generation */
+ Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
+ /* Tcl interpreter */
- 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;
+ 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);
+ }
- 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;
+ /* 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);
- 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;
+ TclStackFree(interp, assemEnvPtr->parsePtr);
+ TclStackFree(interp, assemEnvPtr);
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * AssembleOneLine --
+ *
+ * Assembles a single command from an assembly language source.
+ *
+ * Results:
+ * Returns TCL_ERROR with an appropriate error message if the
+ * assembly fails. Returns TCL_OK if the assembly succeeds. Updates
+ * the assembly environment with the state of the assembly.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+AssembleOneLine(AssembleEnv* assemEnvPtr)
+ /* State of the assembly */
+{
+ CompileEnv* envPtr = assemEnvPtr->envPtr;
+ /* Compilation environment being used for
+ * code gen */
+ Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
+ /* Tcl interpreter */
+ Tcl_Parse* parsePtr = assemEnvPtr->parsePtr;
+ /* Parse of the line of code */
+ Tcl_Token* tokenPtr; /* Current token within the line of code */
+ Tcl_Obj* instNameObj = NULL;
+ /* Name of the instruction */
+ int tblind; /* Index in talInstructionTable of the
+ * instruction */
+ enum talInstType instType; /* Type of the instruction */
+ Tcl_Obj* operand1Obj = NULL;
+ /* First operand to the instruction */
+ const char* operand1; /* String rep of the operand */
+ int operand1Len; /* String length of the operand */
+ 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;
+ }
+
+ /* 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;
- TclCompileScript(interp, operand1, operand1Len, envPtr);
- if (curr_bb->finalStackDepth + envPtr->maxStackDepth
- > curr_bb->maxStackDepth) {
- curr_bb->maxStackDepth =
- curr_bb->finalStackDepth + envPtr->maxStackDepth;
+ 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);
}
- curr_bb->finalStackDepth += envPtr->currStackDepth;
+ SyncStackDepth(assemEnvPtr);
+ envPtr->currStackDepth = savedStackDepth;
envPtr->maxStackDepth = savedMaxStackDepth;
- envPtr->currStackDepth = savedCurrStackDepth;
- fprintf(stderr, "compilation returns\n"); fflush(stderr);
- break;
+ } 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;
- default:
- Tcl_Panic("Instruction \"%s\" could not be found, can't happen\n",
- instName);
+ 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 */
- /* Tie off the last basic block */
+ StartBasicBlock(assemEnvPtr,
+ talInstructionTable[tblind].operandsConsumed,
+ Tcl_GetString(operand1Obj));
- 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;
+ break;
+
+ case ASSEM_LABEL:
+
+ if (parsePtr->numWords != 2) {
+ Tcl_WrongNumArgs(interp, 1, &instNameObj, "name");
+ goto cleanup;
}
- 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);
+ if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) {
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);
- }
+ /* Add the (label_name, address) pair to the hash table */
+ if (DefineLabel(assemEnvPtr, Tcl_GetString(operand1Obj)) != TCL_OK) {
+ goto cleanup;
+ }
+ StartBasicBlock(assemEnvPtr, 1, NULL);
- Tcl_DeleteHashTable(&labelHash); // Actually, we need to free each label as well.
+ /* Attach the label to the new basic block */
- return result;
+ /* 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;
+ }
- /* FIXME: Need to make sure that allocated memory gets freed. */
+ /* 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.
+ *
+ *-----------------------------------------------------------------------------
+ */
- if (ind >= 0 && ind < bcSize) {
- Tcl_AddErrorInfo(interp, "\n processing ");
- AddInstructionToErrorInfo(interp, bcList, ind);
+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.
+ *
+ *-----------------------------------------------------------------------------
+ */
- /* TODO: If ind != -1, add error info indicating where in the
- * instruction stream things went wrong */
+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.
+ *
+ *-----------------------------------------------------------------------------
+ */
- return TCL_ERROR;
+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;
}
/*
@@ -1118,12 +1522,14 @@ TclAssembleCode(Tcl_Interp *interp,
static int
CheckNamespaceQualifiers(Tcl_Interp* interp,
/* Tcl interpreter for error reporting */
- const char* name)
+ 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; p++) {
+ for (p = name; p+2 < name+nameLen; p++) {
if ((*p == ':') && (p[1] == ':')) {
result = Tcl_NewStringObj("variable \"", -1);
Tcl_AppendToObj(result, name, -1);
@@ -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 <windows.h>
+#undef WIN32_LEAN_AND_MEAN
#include <locale.h>
+#include <stdlib.h>
+#include <tchar.h>
#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.
generated by cgit v0.12 at 2024-11-01 22:01:59 (GMT)