summaryrefslogtreecommitdiffstats
path: root/generic/tclCompile.c
diff options
context:
space:
mode:
authorstanton <stanton>1999-04-16 00:46:29 (GMT)
committerstanton <stanton>1999-04-16 00:46:29 (GMT)
commit97464e6cba8eb0008cf2727c15718671992b913f (patch)
treece9959f2747257d98d52ec8d18bf3b0de99b9535 /generic/tclCompile.c
parenta8c96ddb94d1483a9de5e340b740cb74ef6cafa7 (diff)
downloadtcl-97464e6cba8eb0008cf2727c15718671992b913f.zip
tcl-97464e6cba8eb0008cf2727c15718671992b913f.tar.gz
tcl-97464e6cba8eb0008cf2727c15718671992b913f.tar.bz2
merged tcl 8.1 branch back into the main trunk
Diffstat (limited to 'generic/tclCompile.c')
-rw-r--r--generic/tclCompile.c8197
1 files changed, 1779 insertions, 6418 deletions
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 15a30a7..12b6cd4 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -5,19 +5,27 @@
* of commands (like quoted strings or nested sub-commands) into a
* sequence of instructions ("bytecodes").
*
- * Copyright (c) 1996-1997 Sun Microsystems, Inc.
- * Copyright (c) 1998-1999 by Scriptics Corporation.
+ * Copyright (c) 1996-1998 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompile.c,v 1.13 1999/02/03 00:55:04 stanton Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.14 1999/04/16 00:46:44 stanton Exp $
*/
#include "tclInt.h"
#include "tclCompile.h"
/*
+ * Table of all AuxData types.
+ */
+
+static Tcl_HashTable auxDataTypeTable;
+static int auxDataTypeTableInitialized; /* 0 means not yet initialized. */
+
+TCL_DECLARE_MUTEX(tableMutex)
+
+/*
* Variable that controls whether compilation tracing is enabled and, if so,
* what level of tracing is desired:
* 0: no compilation tracing
@@ -30,34 +38,11 @@ int tclTraceCompile = 0;
static int traceInitialized = 0;
/*
- * Count of the number of compilations and various other compilation-
- * related statistics.
- */
-
-#ifdef TCL_COMPILE_STATS
-long tclNumCompilations = 0;
-double tclTotalSourceBytes = 0.0;
-double tclTotalCodeBytes = 0.0;
-
-double tclTotalInstBytes = 0.0;
-double tclTotalObjBytes = 0.0;
-double tclTotalExceptBytes = 0.0;
-double tclTotalAuxBytes = 0.0;
-double tclTotalCmdMapBytes = 0.0;
-
-double tclCurrentSourceBytes = 0.0;
-double tclCurrentCodeBytes = 0.0;
-
-int tclSourceCount[32];
-int tclByteCodeCount[32];
-#endif /* TCL_COMPILE_STATS */
-
-/*
- * A table describing the Tcl bytecode instructions. The entries in this
- * table must correspond to the list of instructions in tclInt.h. The names
- * "op1" and "op4" refer to an instruction's one or four byte first operand.
- * Similarly, "stktop" and "stknext" refer to the topmost and next to
- * topmost stack elements.
+ * A table describing the Tcl bytecode instructions. Entries in this table
+ * must correspond to the instruction opcode definitions in tclCompile.h.
+ * The names "op1" and "op4" refer to an instruction's one or four byte
+ * first operand. Similarly, "stktop" and "stknext" refer to the topmost
+ * and next to topmost stack elements.
*
* Note that the load, store, and incr instructions do not distinguish local
* from global variables; the bytecode interpreter at runtime uses the
@@ -216,7 +201,7 @@ InstructionDesc instructionTable[] = {
* terminate loop, else push 1. */
{"beginCatch4", 5, 1, {OPERAND_UINT4}},
- /* Record start of catch with the operand's exception range index.
+ /* Record start of catch with the operand's exception index.
* Push the current stack depth onto a special catch stack. */
{"endCatch", 1, 0, {OPERAND_NONE}},
/* End of last catch. Pop the bytecode interpreter's catch stack. */
@@ -229,191 +214,32 @@ InstructionDesc instructionTable[] = {
};
/*
- * The following table assigns a type to each character. Only types
- * meaningful to Tcl parsing are represented here. The table is
- * designed to be referenced with either signed or unsigned characters,
- * so it has 384 entries. The first 128 entries correspond to negative
- * character values, the next 256 correspond to positive character
- * values. The last 128 entries are identical to the first 128. The
- * table is always indexed with a 128-byte offset (the 128th entry
- * corresponds to a 0 character value).
- */
-
-unsigned char tclTypeTable[] = {
- /*
- * Negative character values, from -128 to -1:
- */
-
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
-
- /*
- * Positive character values, from 0-127:
- */
-
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_SPACE, TCL_COMMAND_END, TCL_SPACE,
- TCL_SPACE, TCL_SPACE, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_SPACE, TCL_NORMAL, TCL_QUOTE, TCL_NORMAL,
- TCL_DOLLAR, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_COMMAND_END,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_OPEN_BRACKET,
- TCL_BACKSLASH, TCL_COMMAND_END, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_OPEN_BRACE,
- TCL_NORMAL, TCL_CLOSE_BRACE, TCL_NORMAL, TCL_NORMAL,
-
- /*
- * Large unsigned character values, from 128-255:
- */
-
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
-};
-
-/*
- * Table of all AuxData types.
- */
-
-static Tcl_HashTable auxDataTypeTable;
-static int auxDataTypeTableInitialized = 0; /* 0 means not yet
- * initialized. */
-
-/*
* Prototypes for procedures defined later in this file:
*/
-static void AdvanceToNextWord _ANSI_ARGS_((char *string,
- CompileEnv *envPtr));
-static int CollectArgInfo _ANSI_ARGS_((Tcl_Interp *interp,
- char *string, char *lastChar, int flags,
- ArgInfo *argInfoPtr));
-static int CompileBraces _ANSI_ARGS_((Tcl_Interp *interp,
- char *string, char *lastChar, int flags,
- CompileEnv *envPtr));
-static int CompileCmdWordInline _ANSI_ARGS_((
- Tcl_Interp *interp, char *string,
- char *lastChar, int flags, CompileEnv *envPtr));
-static int CompileExprWord _ANSI_ARGS_((Tcl_Interp *interp,
- char *string, char *lastChar, int flags,
- CompileEnv *envPtr));
-static int CompileMultipartWord _ANSI_ARGS_((
- Tcl_Interp *interp, char *string,
- char *lastChar, int flags, CompileEnv *envPtr));
-static int CompileWord _ANSI_ARGS_((Tcl_Interp *interp,
- char *string, char *lastChar, int flags,
- CompileEnv *envPtr));
-static int CreateExceptionRange _ANSI_ARGS_((
- ExceptionRangeType type, CompileEnv *envPtr));
static void DupByteCodeInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr));
-static ClientData DupForeachInfo _ANSI_ARGS_((ClientData clientData));
static unsigned char * EncodeCmdLocMap _ANSI_ARGS_((
CompileEnv *envPtr, ByteCode *codePtr,
unsigned char *startPtr));
static void EnterCmdExtentData _ANSI_ARGS_((
CompileEnv *envPtr, int cmdNumber,
- int numSrcChars, int numCodeBytes));
+ int numSrcBytes, int numCodeBytes));
static void EnterCmdStartData _ANSI_ARGS_((
CompileEnv *envPtr, int cmdNumber,
int srcOffset, int codeOffset));
-static void ExpandObjectArray _ANSI_ARGS_((CompileEnv *envPtr));
-static void FreeForeachInfo _ANSI_ARGS_((
- ClientData clientData));
static void FreeByteCodeInternalRep _ANSI_ARGS_((
Tcl_Obj *objPtr));
-static void FreeArgInfo _ANSI_ARGS_((ArgInfo *argInfoPtr));
static int GetCmdLocEncodingSize _ANSI_ARGS_((
CompileEnv *envPtr));
-static void InitArgInfo _ANSI_ARGS_((ArgInfo *argInfoPtr));
-static int IsLocalScalar _ANSI_ARGS_((char *name, int len));
-static int LookupCompiledLocal _ANSI_ARGS_((
- char *name, int nameChars, int createIfNew,
- int flagsIfCreated, Proc *procPtr));
+static void LogCompilationInfo _ANSI_ARGS_((Tcl_Interp *interp,
+ char *script, char *command, int length));
+#ifdef TCL_COMPILE_STATS
+static void RecordByteCodeStats _ANSI_ARGS_((
+ ByteCode *codePtr));
+#endif /* TCL_COMPILE_STATS */
static int SetByteCodeFromAny _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
-static void UpdateStringOfByteCode _ANSI_ARGS_((Tcl_Obj *objPtr));
/*
* The structure below defines the bytecode Tcl object type by
@@ -421,481 +247,151 @@ static void UpdateStringOfByteCode _ANSI_ARGS_((Tcl_Obj *objPtr));
*/
Tcl_ObjType tclByteCodeType = {
- "bytecode", /* name */
- FreeByteCodeInternalRep, /* freeIntRepProc */
- DupByteCodeInternalRep, /* dupIntRepProc */
- UpdateStringOfByteCode, /* updateStringProc */
- SetByteCodeFromAny /* setFromAnyProc */
-};
-
-/*
- * The structures below define the AuxData types defined in this file.
- */
-
-AuxDataType tclForeachInfoType = {
- "ForeachInfo", /* name */
- DupForeachInfo, /* dupProc */
- FreeForeachInfo /* freeProc */
+ "bytecode", /* name */
+ FreeByteCodeInternalRep, /* freeIntRepProc */
+ DupByteCodeInternalRep, /* dupIntRepProc */
+ (Tcl_UpdateStringProc *) NULL, /* updateStringProc */
+ SetByteCodeFromAny /* setFromAnyProc */
};
/*
- *----------------------------------------------------------------------
+ *-----------------------------------------------------------------------
*
- * TclPrintByteCodeObj --
+ * SetByteCodeFromAny --
*
- * This procedure prints ("disassembles") the instructions of a
- * bytecode object to stdout.
+ * Part of the bytecode Tcl object type implementation. Attempts to
+ * generate an byte code internal form for the Tcl object "objPtr" by
+ * compiling its string representation.
*
* Results:
- * None.
+ * The return value is a standard Tcl object result. If an error occurs
+ * during compilation, an error message is left in the interpreter's
+ * result unless "interp" is NULL.
*
* Side effects:
- * None.
+ * Frees the old internal representation. If no error occurs, then the
+ * compiled code is stored as "objPtr"s bytecode representation.
+ * Also, if debugging, initializes the "tcl_traceCompile" Tcl variable
+ * used to trace compilations.
*
*----------------------------------------------------------------------
*/
-void
-TclPrintByteCodeObj(interp, objPtr)
- Tcl_Interp *interp; /* Used only for Tcl_GetStringFromObj. */
- Tcl_Obj *objPtr; /* The bytecode object to disassemble. */
+static int
+SetByteCodeFromAny(interp, objPtr)
+ Tcl_Interp *interp; /* The interpreter for which the code is
+ * being compiled. Must not be NULL. */
+ Tcl_Obj *objPtr; /* The object to make a ByteCode object. */
{
- ByteCode* codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
- unsigned char *codeStart, *codeLimit, *pc;
- unsigned char *codeDeltaNext, *codeLengthNext;
- unsigned char *srcDeltaNext, *srcLengthNext;
- int codeOffset, codeLen, srcOffset, srcLen;
- int numCmds, numObjs, delta, objBytes, i;
+ Interp *iPtr = (Interp *) interp;
+ CompileEnv compEnv; /* Compilation environment structure
+ * allocated in frame. */
+ LiteralTable *localTablePtr = &(compEnv.localLitTable);
+ register AuxData *auxDataPtr;
+ LiteralEntry *entryPtr;
+ register int i;
+ int length, nested, result;
+ char *string;
- if (codePtr->refCount <= 0) {
- return; /* already freed */
+ if (!traceInitialized) {
+ if (Tcl_LinkVar(interp, "tcl_traceCompile",
+ (char *) &tclTraceCompile, TCL_LINK_INT) != TCL_OK) {
+ panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable");
+ }
+ traceInitialized = 1;
}
- codeStart = codePtr->codeStart;
- codeLimit = (codeStart + codePtr->numCodeBytes);
- numCmds = codePtr->numCommands;
- numObjs = codePtr->numObjects;
-
- objBytes = (numObjs * sizeof(Tcl_Obj));
- for (i = 0; i < numObjs; i++) {
- Tcl_Obj *litObjPtr = codePtr->objArrayPtr[i];
- if (litObjPtr->bytes != NULL) {
- objBytes += litObjPtr->length;
- }
+ if (iPtr->evalFlags & TCL_BRACKET_TERM) {
+ nested = 1;
+ } else {
+ nested = 0;
}
+ string = Tcl_GetStringFromObj(objPtr, &length);
+ TclInitCompileEnv(interp, &compEnv, string, length);
+ result = TclCompileScript(interp, string, length, nested, &compEnv);
+ if (result != TCL_OK) {
+ /*
+ * Compilation errors.
+ */
- /*
- * Print header lines describing the ByteCode.
- */
-
- fprintf(stdout, "\nByteCode 0x%x, ref ct %u, epoch %u, interp 0x%x(epoch %u)\n",
- (unsigned int) codePtr, codePtr->refCount,
- codePtr->compileEpoch, (unsigned int) codePtr->iPtr,
- codePtr->iPtr->compileEpoch);
- fprintf(stdout, " Source ");
- TclPrintSource(stdout, codePtr->source,
- TclMin(codePtr->numSrcChars, 70));
- fprintf(stdout, "\n Cmds %d, chars %d, inst %d, objs %u, aux %d, stk depth %u, code/src %.2f\n",
- numCmds, codePtr->numSrcChars, codePtr->numCodeBytes, numObjs,
- codePtr->numAuxDataItems, codePtr->maxStackDepth,
- (codePtr->numSrcChars?
- ((float)codePtr->totalSize)/((float)codePtr->numSrcChars) : 0.0));
- fprintf(stdout, " Code %d = %d(header)+%d(inst)+%d(objs)+%d(exc)+%d(aux)+%d(cmd map)\n",
- codePtr->totalSize, sizeof(ByteCode), codePtr->numCodeBytes,
- objBytes, (codePtr->numExcRanges * sizeof(ExceptionRange)),
- (codePtr->numAuxDataItems * sizeof(AuxData)),
- codePtr->numCmdLocBytes);
-
- /*
- * If the ByteCode is the compiled body of a Tcl procedure, print
- * information about that procedure. Note that we don't know the
- * procedure's name since ByteCode's can be shared among procedures.
- */
-
- if (codePtr->procPtr != NULL) {
- Proc *procPtr = codePtr->procPtr;
- int numCompiledLocals = procPtr->numCompiledLocals;
- fprintf(stdout,
- " Proc 0x%x, ref ct %d, args %d, compiled locals %d\n",
- (unsigned int) procPtr, procPtr->refCount, procPtr->numArgs,
- numCompiledLocals);
- if (numCompiledLocals > 0) {
- CompiledLocal *localPtr = procPtr->firstLocalPtr;
- for (i = 0; i < numCompiledLocals; i++) {
- fprintf(stdout, " %d: slot %d%s%s%s%s%s%s",
- i, localPtr->frameIndex,
- ((localPtr->flags & VAR_SCALAR)? ", scalar" : ""),
- ((localPtr->flags & VAR_ARRAY)? ", array" : ""),
- ((localPtr->flags & VAR_LINK)? ", link" : ""),
- ((localPtr->flags & VAR_ARGUMENT)? ", arg" : ""),
- ((localPtr->flags & VAR_TEMPORARY)? ", temp" : ""),
- ((localPtr->flags & VAR_RESOLVED)? ", resolved" : ""));
- if (TclIsVarTemporary(localPtr)) {
- fprintf(stdout, "\n");
- } else {
- fprintf(stdout, ", name=\"%s\"\n", localPtr->name);
- }
- localPtr = localPtr->nextPtr;
- }
+ entryPtr = compEnv.literalArrayPtr;
+ for (i = 0; i < compEnv.literalArrayNext; i++) {
+ TclReleaseLiteral(interp, entryPtr->objPtr);
+ entryPtr++;
}
- }
+#ifdef TCL_COMPILE_DEBUG
+ TclVerifyGlobalLiteralTable(iPtr);
+#endif /*TCL_COMPILE_DEBUG*/
- /*
- * Print the ExceptionRange array.
- */
-
- if (codePtr->numExcRanges > 0) {
- fprintf(stdout, " Exception ranges %d, depth %d:\n",
- codePtr->numExcRanges, codePtr->maxExcRangeDepth);
- for (i = 0; i < codePtr->numExcRanges; i++) {
- ExceptionRange *rangePtr = &(codePtr->excRangeArrayPtr[i]);
- fprintf(stdout, " %d: level %d, %s, pc %d-%d, ",
- i, rangePtr->nestingLevel,
- ((rangePtr->type == LOOP_EXCEPTION_RANGE)? "loop":"catch"),
- rangePtr->codeOffset,
- (rangePtr->codeOffset + rangePtr->numCodeBytes - 1));
- switch (rangePtr->type) {
- case LOOP_EXCEPTION_RANGE:
- fprintf(stdout, "continue %d, break %d\n",
- rangePtr->continueOffset, rangePtr->breakOffset);
- break;
- case CATCH_EXCEPTION_RANGE:
- fprintf(stdout, "catch %d\n", rangePtr->catchOffset);
- break;
- default:
- panic("TclPrintSource: unrecognized ExceptionRange type %d\n",
- rangePtr->type);
+ auxDataPtr = compEnv.auxDataArrayPtr;
+ for (i = 0; i < compEnv.auxDataArrayNext; i++) {
+ if (auxDataPtr->type->freeProc != NULL) {
+ auxDataPtr->type->freeProc(auxDataPtr->clientData);
}
+ auxDataPtr++;
}
+ goto done;
}
-
- /*
- * If there were no commands (e.g., an expression or an empty string
- * was compiled), just print all instructions and return.
- */
- if (numCmds == 0) {
- pc = codeStart;
- while (pc < codeLimit) {
- fprintf(stdout, " ");
- pc += TclPrintInstruction(codePtr, pc);
- }
- return;
- }
-
/*
- * Print table showing the code offset, source offset, and source
- * length for each command. These are encoded as a sequence of bytes.
+ * Successful compilation. Add a "done" instruction at the end.
*/
- fprintf(stdout, " Commands %d:", numCmds);
- codeDeltaNext = codePtr->codeDeltaStart;
- codeLengthNext = codePtr->codeLengthStart;
- srcDeltaNext = codePtr->srcDeltaStart;
- srcLengthNext = codePtr->srcLengthStart;
- codeOffset = srcOffset = 0;
- for (i = 0; i < numCmds; i++) {
- if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
- codeDeltaNext++;
- delta = TclGetInt4AtPtr(codeDeltaNext);
- codeDeltaNext += 4;
- } else {
- delta = TclGetInt1AtPtr(codeDeltaNext);
- codeDeltaNext++;
- }
- codeOffset += delta;
-
- if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) {
- codeLengthNext++;
- codeLen = TclGetInt4AtPtr(codeLengthNext);
- codeLengthNext += 4;
- } else {
- codeLen = TclGetInt1AtPtr(codeLengthNext);
- codeLengthNext++;
- }
-
- if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
- srcDeltaNext++;
- delta = TclGetInt4AtPtr(srcDeltaNext);
- srcDeltaNext += 4;
- } else {
- delta = TclGetInt1AtPtr(srcDeltaNext);
- srcDeltaNext++;
- }
- srcOffset += delta;
+ compEnv.numSrcBytes = iPtr->termOffset;
+ TclEmitOpcode(INST_DONE, &compEnv);
- if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
- srcLengthNext++;
- srcLen = TclGetInt4AtPtr(srcLengthNext);
- srcLengthNext += 4;
- } else {
- srcLen = TclGetInt1AtPtr(srcLengthNext);
- srcLengthNext++;
- }
-
- fprintf(stdout, "%s%4d: pc %d-%d, source %d-%d",
- ((i % 2)? " " : "\n "),
- (i+1), codeOffset, (codeOffset + codeLen - 1),
- srcOffset, (srcOffset + srcLen - 1));
- }
- if ((numCmds > 0) && ((numCmds % 2) != 0)) {
- fprintf(stdout, "\n");
- }
-
/*
- * Print each instruction. If the instruction corresponds to the start
- * of a command, print the command's source. Note that we don't need
- * the code length here.
+ * Change the object into a ByteCode object. Ownership of the literal
+ * objects and aux data items is given to the ByteCode object.
*/
-
- codeDeltaNext = codePtr->codeDeltaStart;
- srcDeltaNext = codePtr->srcDeltaStart;
- srcLengthNext = codePtr->srcLengthStart;
- codeOffset = srcOffset = 0;
- pc = codeStart;
- for (i = 0; i < numCmds; i++) {
- if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
- codeDeltaNext++;
- delta = TclGetInt4AtPtr(codeDeltaNext);
- codeDeltaNext += 4;
- } else {
- delta = TclGetInt1AtPtr(codeDeltaNext);
- codeDeltaNext++;
- }
- codeOffset += delta;
-
- if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
- srcDeltaNext++;
- delta = TclGetInt4AtPtr(srcDeltaNext);
- srcDeltaNext += 4;
- } else {
- delta = TclGetInt1AtPtr(srcDeltaNext);
- srcDeltaNext++;
- }
- srcOffset += delta;
-
- if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
- srcLengthNext++;
- srcLen = TclGetInt4AtPtr(srcLengthNext);
- srcLengthNext += 4;
- } else {
- srcLen = TclGetInt1AtPtr(srcLengthNext);
- srcLengthNext++;
- }
-
- /*
- * Print instructions before command i.
- */
-
- while ((pc-codeStart) < codeOffset) {
- fprintf(stdout, " ");
- pc += TclPrintInstruction(codePtr, pc);
- }
-
- fprintf(stdout, " Command %d: ", (i+1));
- TclPrintSource(stdout, (codePtr->source + srcOffset),
- TclMin(srcLen, 70));
- fprintf(stdout, "\n");
+
+#ifdef TCL_COMPILE_DEBUG
+ TclVerifyLocalLiteralTable(&compEnv);
+#endif /*TCL_COMPILE_DEBUG*/
+ TclInitByteCodeObj(objPtr, &compEnv);
+#ifdef TCL_COMPILE_DEBUG
+ if (tclTraceCompile == 2) {
+ TclPrintByteCodeObj(interp, objPtr);
}
- if (pc < codeLimit) {
- /*
- * Print instructions after the last command.
- */
+#endif /* TCL_COMPILE_DEBUG */
- while (pc < codeLimit) {
- fprintf(stdout, " ");
- pc += TclPrintInstruction(codePtr, pc);
- }
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclPrintInstruction --
- *
- * This procedure prints ("disassembles") one instruction from a
- * bytecode object to stdout.
- *
- * Results:
- * Returns the length in bytes of the current instruiction.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclPrintInstruction(codePtr, pc)
- ByteCode* codePtr; /* Bytecode containing the instruction. */
- unsigned char *pc; /* Points to first byte of instruction. */
-{
- Proc *procPtr = codePtr->procPtr;
- unsigned char opCode = *pc;
- register InstructionDesc *instDesc = &instructionTable[opCode];
- unsigned char *codeStart = codePtr->codeStart;
- unsigned int pcOffset = (pc - codeStart);
- int opnd, elemLen, i, j;
- Tcl_Obj *elemPtr;
- char *string;
+ /*
+ * Free storage allocated during compilation.
+ */
- fprintf(stdout, "(%u) %s ", pcOffset, instDesc->name);
- for (i = 0; i < instDesc->numOperands; i++) {
- switch (instDesc->opTypes[i]) {
- case OPERAND_INT1:
- opnd = TclGetInt1AtPtr(pc+1+i);
- if ((i == 0) && ((opCode == INST_JUMP1)
- || (opCode == INST_JUMP_TRUE1)
- || (opCode == INST_JUMP_FALSE1))) {
- fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd));
- } else {
- fprintf(stdout, "%d", opnd);
- }
- break;
- case OPERAND_INT4:
- opnd = TclGetInt4AtPtr(pc+1+i);
- if ((i == 0) && ((opCode == INST_JUMP4)
- || (opCode == INST_JUMP_TRUE4)
- || (opCode == INST_JUMP_FALSE4))) {
- fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd));
- } else {
- fprintf(stdout, "%d", opnd);
- }
- break;
- case OPERAND_UINT1:
- opnd = TclGetUInt1AtPtr(pc+1+i);
- if ((i == 0) && (opCode == INST_PUSH1)) {
- elemPtr = codePtr->objArrayPtr[opnd];
- string = Tcl_GetStringFromObj(elemPtr, &elemLen);
- fprintf(stdout, "%u # ", (unsigned int) opnd);
- TclPrintSource(stdout, string, TclMin(elemLen, 40));
- } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR1)
- || (opCode == INST_LOAD_ARRAY1)
- || (opCode == INST_STORE_SCALAR1)
- || (opCode == INST_STORE_ARRAY1))) {
- int localCt = procPtr->numCompiledLocals;
- CompiledLocal *localPtr = procPtr->firstLocalPtr;
- if (opnd >= localCt) {
- panic("TclPrintInstruction: bad local var index %u (%u locals)\n",
- (unsigned int) opnd, localCt);
- return instDesc->numBytes;
- }
- for (j = 0; j < opnd; j++) {
- localPtr = localPtr->nextPtr;
- }
- if (TclIsVarTemporary(localPtr)) {
- fprintf(stdout, "%u # temp var %u",
- (unsigned int) opnd, (unsigned int) opnd);
- } else {
- fprintf(stdout, "%u # var ", (unsigned int) opnd);
- TclPrintSource(stdout, localPtr->name, 40);
- }
- } else {
- fprintf(stdout, "%u ", (unsigned int) opnd);
- }
- break;
- case OPERAND_UINT4:
- opnd = TclGetUInt4AtPtr(pc+1+i);
- if (opCode == INST_PUSH4) {
- elemPtr = codePtr->objArrayPtr[opnd];
- string = Tcl_GetStringFromObj(elemPtr, &elemLen);
- fprintf(stdout, "%u # ", opnd);
- TclPrintSource(stdout, string, TclMin(elemLen, 40));
- } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR4)
- || (opCode == INST_LOAD_ARRAY4)
- || (opCode == INST_STORE_SCALAR4)
- || (opCode == INST_STORE_ARRAY4))) {
- int localCt = procPtr->numCompiledLocals;
- CompiledLocal *localPtr = procPtr->firstLocalPtr;
- if (opnd >= localCt) {
- panic("TclPrintInstruction: bad local var index %u (%u locals)\n",
- (unsigned int) opnd, localCt);
- return instDesc->numBytes;
- }
- for (j = 0; j < opnd; j++) {
- localPtr = localPtr->nextPtr;
- }
- if (TclIsVarTemporary(localPtr)) {
- fprintf(stdout, "%u # temp var %u",
- (unsigned int) opnd, (unsigned int) opnd);
- } else {
- fprintf(stdout, "%u # var ", (unsigned int) opnd);
- TclPrintSource(stdout, localPtr->name, 40);
- }
- } else {
- fprintf(stdout, "%u ", (unsigned int) opnd);
- }
- break;
- case OPERAND_NONE:
- default:
- break;
- }
+ done:
+ if (localTablePtr->buckets != localTablePtr->staticBuckets) {
+ ckfree((char *) localTablePtr->buckets);
}
- fprintf(stdout, "\n");
- return instDesc->numBytes;
+ TclFreeCompileEnv(&compEnv);
+ return result;
}
/*
*----------------------------------------------------------------------
*
- * TclPrintSource --
+ * DupByteCodeInternalRep --
*
- * This procedure prints up to a specified number of characters from
- * the argument string to a specified file. It tries to produce legible
- * output by adding backslashes as necessary.
+ * Part of the bytecode Tcl object type implementation. However, it
+ * does not copy the internal representation of a bytecode Tcl_Obj, but
+ * instead leaves the new object untyped (with a NULL type pointer).
+ * Code will be compiled for the new object only if necessary.
*
* Results:
* None.
*
* Side effects:
- * Outputs characters to the specified file.
+ * None.
*
*----------------------------------------------------------------------
*/
-void
-TclPrintSource(outFile, string, maxChars)
- FILE *outFile; /* The file to print the source to. */
- char *string; /* The string to print. */
- int maxChars; /* Maximum number of chars to print. */
+static void
+DupByteCodeInternalRep(srcPtr, copyPtr)
+ Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
+ Tcl_Obj *copyPtr; /* Object with internal rep to set. */
{
- register char *p;
- register int i = 0;
-
- if (string == NULL) {
- fprintf(outFile, "\"\"");
- return;
- }
-
- fprintf(outFile, "\"");
- p = string;
- for (; (*p != '\0') && (i < maxChars); p++, i++) {
- switch (*p) {
- case '"':
- fprintf(outFile, "\\\"");
- continue;
- case '\f':
- fprintf(outFile, "\\f");
- continue;
- case '\n':
- fprintf(outFile, "\\n");
- continue;
- case '\r':
- fprintf(outFile, "\\r");
- continue;
- case '\t':
- fprintf(outFile, "\\t");
- continue;
- case '\v':
- fprintf(outFile, "\\v");
- continue;
- default:
- fprintf(outFile, "%c", *p);
- continue;
- }
- }
- fprintf(outFile, "\"");
+ return;
}
/*
@@ -947,202 +443,100 @@ FreeByteCodeInternalRep(objPtr)
* None.
*
* Side effects:
- * Frees objPtr's bytecode internal representation and sets
- * its type and objPtr->internalRep.otherValuePtr NULL. Also
- * decrements the ref counts on each object in its object array,
- * and frees its auxiliary data items.
+ * Frees objPtr's bytecode internal representation and sets its type
+ * and objPtr->internalRep.otherValuePtr NULL. Also releases its
+ * literals and frees its auxiliary data items.
*
*----------------------------------------------------------------------
*/
void
TclCleanupByteCode(codePtr)
- ByteCode *codePtr; /* ByteCode to free. */
+ register ByteCode *codePtr; /* Points to the ByteCode to free. */
{
- Tcl_Obj **objArrayPtr = codePtr->objArrayPtr;
- int numObjects = codePtr->numObjects;
+ Tcl_Interp *interp = (Tcl_Interp *) *codePtr->interpHandle;
+ int numLitObjects = codePtr->numLitObjects;
int numAuxDataItems = codePtr->numAuxDataItems;
+ register Tcl_Obj **objArrayPtr;
register AuxData *auxDataPtr;
- register Tcl_Obj *elemPtr;
- register int i;
+ int i;
+#ifdef TCL_COMPILE_STATS
-#ifdef TCL_COMPILE_STATS
- tclCurrentSourceBytes -= (double) codePtr->numSrcChars;
- tclCurrentCodeBytes -= (double) codePtr->totalSize;
+ if (interp != NULL) {
+ ByteCodeStats *statsPtr;
+ Tcl_Time destroyTime;
+ int lifetimeSec, lifetimeMicroSec, log2;
+
+ statsPtr = &((Interp *) interp)->stats;
+
+ statsPtr->numByteCodesFreed++;
+ statsPtr->currentSrcBytes -= (double) codePtr->numSrcBytes;
+ statsPtr->currentByteCodeBytes -= (double) codePtr->structureSize;
+
+ statsPtr->currentInstBytes -= (double) codePtr->numCodeBytes;
+ statsPtr->currentLitBytes -=
+ (double) (codePtr->numLitObjects * sizeof(Tcl_Obj *));
+ statsPtr->currentExceptBytes -=
+ (double) (codePtr->numExceptRanges * sizeof(ExceptionRange));
+ statsPtr->currentAuxBytes -=
+ (double) (codePtr->numAuxDataItems * sizeof(AuxData));
+ statsPtr->currentCmdMapBytes -= (double) codePtr->numCmdLocBytes;
+
+ TclpGetTime(&destroyTime);
+ lifetimeSec = destroyTime.sec - codePtr->createTime.sec;
+ if (lifetimeSec > 2000) { /* avoid overflow */
+ lifetimeSec = 2000;
+ }
+ lifetimeMicroSec =
+ 1000000*lifetimeSec + (destroyTime.usec - codePtr->createTime.usec);
+
+ log2 = TclLog2(lifetimeMicroSec);
+ if (log2 > 31) {
+ log2 = 31;
+ }
+ statsPtr->lifetimeCount[log2]++;
+ }
#endif /* TCL_COMPILE_STATS */
/*
* A single heap object holds the ByteCode structure and its code,
* object, command location, and auxiliary data arrays. This means we
- * only need to 1) decrement the ref counts on the objects in its
- * object array, 2) call the free procs for the auxiliary data items,
- * and 3) free the ByteCode structure's heap object.
+ * only need to 1) decrement the ref counts of the LiteralEntry's in
+ * its literal array, 2) call the free procs for the auxiliary data
+ * items, and 3) free the ByteCode structure's heap object.
*/
- for (i = 0; i < numObjects; i++) {
- elemPtr = objArrayPtr[i];
- TclDecrRefCount(elemPtr);
- }
-
- auxDataPtr = codePtr->auxDataArrayPtr;
- for (i = 0; i < numAuxDataItems; i++) {
- if (auxDataPtr->type->freeProc != NULL) {
- auxDataPtr->type->freeProc(auxDataPtr->clientData);
- }
- auxDataPtr++;
- }
-
- ckfree((char *) codePtr);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * DupByteCodeInternalRep --
- *
- * Part of the bytecode Tcl object type implementation. However, it
- * does not copy the internal representation of a bytecode Tcl_Obj, but
- * instead leaves the new object untyped (with a NULL type pointer).
- * Code will be compiled for the new object only if necessary.
- *
- * Results:
- * None.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-DupByteCodeInternalRep(srcPtr, copyPtr)
- Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
- Tcl_Obj *copyPtr; /* Object with internal rep to set. */
-{
- return;
-}
-
-/*
- *-----------------------------------------------------------------------
- *
- * SetByteCodeFromAny --
- *
- * Part of the bytecode Tcl object type implementation. Attempts to
- * generate an byte code internal form for the Tcl object "objPtr" by
- * compiling its string representation.
- *
- * Results:
- * The return value is a standard Tcl object result. If an error occurs
- * during compilation, an error message is left in the interpreter's
- * result unless "interp" is NULL.
- *
- * Side effects:
- * Frees the old internal representation. If no error occurs, then the
- * compiled code is stored as "objPtr"s bytecode representation.
- * Also, if debugging, initializes the "tcl_traceCompile" Tcl variable
- * used to trace compilations.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-SetByteCodeFromAny(interp, objPtr)
- Tcl_Interp *interp; /* The interpreter for which the code is
- * compiled. */
- Tcl_Obj *objPtr; /* The object to convert. */
-{
- Interp *iPtr = (Interp *) interp;
- char *string;
- CompileEnv compEnv; /* Compilation environment structure
- * allocated in frame. */
- AuxData *auxDataPtr;
- register int i;
- int length, result;
-
- if (!traceInitialized) {
- if (Tcl_LinkVar(interp, "tcl_traceCompile",
- (char *) &tclTraceCompile, TCL_LINK_INT) != TCL_OK) {
- panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable");
- }
- traceInitialized = 1;
- }
-
- string = Tcl_GetStringFromObj(objPtr, &length);
- TclInitCompileEnv(interp, &compEnv, string);
- result = TclCompileString(interp, string, string+length,
- iPtr->evalFlags, &compEnv);
- if (result == TCL_OK) {
+ if (interp != NULL) {
/*
- * Add a "done" instruction at the end of the instruction sequence.
+ * If the interp has already been freed, then Tcl will have already
+ * forcefully released all the literals used by ByteCodes compiled
+ * with respect to that interp.
*/
-
- TclEmitOpcode(INST_DONE, &compEnv);
-
- /*
- * Convert the object to a ByteCode object.
- */
-
- TclInitByteCodeObj(objPtr, &compEnv);
- } else {
- /*
- * Compilation errors. Decrement the ref counts on any objects in
- * the object array and free any aux data items prior to freeing
- * the compilation environment.
- */
-
- for (i = 0; i < compEnv.objArrayNext; i++) {
- Tcl_Obj *elemPtr = compEnv.objArrayPtr[i];
- Tcl_DecrRefCount(elemPtr);
- }
-
- auxDataPtr = compEnv.auxDataArrayPtr;
- for (i = 0; i < compEnv.auxDataArrayNext; i++) {
- if (auxDataPtr->type->freeProc != NULL) {
- auxDataPtr->type->freeProc(auxDataPtr->clientData);
+
+ objArrayPtr = codePtr->objArrayPtr;
+ for (i = 0; i < numLitObjects; i++) {
+ /*
+ * TclReleaseLiteral sets a ByteCode's object array entry NULL to
+ * indicate that it has already freed the literal.
+ */
+
+ if (*objArrayPtr != NULL) {
+ TclReleaseLiteral(interp, *objArrayPtr);
}
- auxDataPtr++;
+ objArrayPtr++;
}
}
- TclFreeCompileEnv(&compEnv);
-
- if (result == TCL_OK) {
- if (tclTraceCompile == 2) {
- TclPrintByteCodeObj(interp, objPtr);
+
+ auxDataPtr = codePtr->auxDataArrayPtr;
+ for (i = 0; i < numAuxDataItems; i++) {
+ if (auxDataPtr->type->freeProc != NULL) {
+ (*auxDataPtr->type->freeProc)(auxDataPtr->clientData);
}
+ auxDataPtr++;
}
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * UpdateStringOfByteCode --
- *
- * Part of the bytecode Tcl object type implementation. Called to
- * update the string representation for a byte code object.
- * Note: This procedure does not free an existing old string rep
- * so storage will be lost if this has not already been done.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Generates a panic.
- *
- *----------------------------------------------------------------------
- */
-static void
-UpdateStringOfByteCode(objPtr)
- register Tcl_Obj *objPtr; /* ByteCode object with string rep that
- * needs updating. */
-{
- /*
- * This procedure is never invoked since the internal representation of
- * a bytecode object is never modified.
- */
-
- panic("UpdateStringOfByteCode should never be called.");
+ TclHandleRelease(codePtr->interpHandle);
+ ckfree((char *) codePtr);
}
/*
@@ -1163,44 +557,42 @@ UpdateStringOfByteCode(objPtr)
*/
void
-TclInitCompileEnv(interp, envPtr, string)
+TclInitCompileEnv(interp, envPtr, string, numBytes)
Tcl_Interp *interp; /* The interpreter for which a CompileEnv
* structure is initialized. */
register CompileEnv *envPtr; /* Points to the CompileEnv structure to
* initialize. */
char *string; /* The source string to be compiled. */
+ int numBytes; /* Number of bytes in source string. */
{
Interp *iPtr = (Interp *) interp;
envPtr->iPtr = iPtr;
envPtr->source = string;
+ envPtr->numSrcBytes = numBytes;
envPtr->procPtr = iPtr->compiledProcPtr;
envPtr->numCommands = 0;
- envPtr->excRangeDepth = 0;
- envPtr->maxExcRangeDepth = 0;
+ envPtr->exceptDepth = 0;
+ envPtr->maxExceptDepth = 0;
envPtr->maxStackDepth = 0;
- Tcl_InitHashTable(&(envPtr->objTable), TCL_STRING_KEYS);
- envPtr->pushSimpleWords = 1;
- envPtr->wordIsSimple = 0;
- envPtr->numSimpleWordChars = 0;
+ TclInitLiteralTable(&(envPtr->localLitTable));
envPtr->exprIsJustVarRef = 0;
envPtr->exprIsComparison = 0;
- envPtr->termOffset = 0;
envPtr->codeStart = envPtr->staticCodeSpace;
envPtr->codeNext = envPtr->codeStart;
envPtr->codeEnd = (envPtr->codeStart + COMPILEENV_INIT_CODE_BYTES);
envPtr->mallocedCodeArray = 0;
- envPtr->objArrayPtr = envPtr->staticObjArraySpace;
- envPtr->objArrayNext = 0;
- envPtr->objArrayEnd = COMPILEENV_INIT_NUM_OBJECTS;
- envPtr->mallocedObjArray = 0;
+ envPtr->literalArrayPtr = envPtr->staticLiteralSpace;
+ envPtr->literalArrayNext = 0;
+ envPtr->literalArrayEnd = COMPILEENV_INIT_NUM_OBJECTS;
+ envPtr->mallocedLiteralArray = 0;
- envPtr->excRangeArrayPtr = envPtr->staticExcRangeArraySpace;
- envPtr->excRangeArrayNext = 0;
- envPtr->excRangeArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES;
- envPtr->mallocedExcRangeArray = 0;
+ envPtr->exceptArrayPtr = envPtr->staticExceptArraySpace;
+ envPtr->exceptArrayNext = 0;
+ envPtr->exceptArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES;
+ envPtr->mallocedExceptArray = 0;
envPtr->cmdMapPtr = envPtr->staticCmdMapSpace;
envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE;
@@ -1222,15 +614,14 @@ TclInitCompileEnv(interp, envPtr, string)
*
* Results:
* None.
- *
+ *
* Side effects:
* Allocated storage in the CompileEnv structure is freed. Note that
- * ref counts for Tcl objects in its object table are not decremented.
- * In addition, any storage referenced by any auxiliary data items
- * in the CompileEnv structure are not freed either. The expectation
- * is that when compilation is successful, "ownership" (i.e., the
- * pointers to) these objects and aux data items will just be handed
- * over to the corresponding ByteCode structure.
+ * its local literal table is not deleted and its literal objects are
+ * not released. In addition, storage referenced by its auxiliary data
+ * items is not freed. This is done so that, when compilation is
+ * successful, "ownership" of these objects and aux data items is
+ * handed over to the corresponding ByteCode structure.
*
*----------------------------------------------------------------------
*/
@@ -1239,15 +630,14 @@ void
TclFreeCompileEnv(envPtr)
register CompileEnv *envPtr; /* Points to the CompileEnv structure. */
{
- Tcl_DeleteHashTable(&(envPtr->objTable));
if (envPtr->mallocedCodeArray) {
ckfree((char *) envPtr->codeStart);
}
- if (envPtr->mallocedObjArray) {
- ckfree((char *) envPtr->objArrayPtr);
+ if (envPtr->mallocedLiteralArray) {
+ ckfree((char *) envPtr->literalArrayPtr);
}
- if (envPtr->mallocedExcRangeArray) {
- ckfree((char *) envPtr->excRangeArrayPtr);
+ if (envPtr->mallocedExceptArray) {
+ ckfree((char *) envPtr->exceptArrayPtr);
}
if (envPtr->mallocedCmdMap) {
ckfree((char *) envPtr->cmdMapPtr);
@@ -1260,5324 +650,1076 @@ TclFreeCompileEnv(envPtr)
/*
*----------------------------------------------------------------------
*
- * TclInitByteCodeObj --
- *
- * Create a ByteCode structure and initialize it from a CompileEnv
- * compilation environment structure. The ByteCode structure is
- * smaller and contains just that information needed to execute
- * the bytecode instructions resulting from compiling a Tcl script.
- * The resulting structure is placed in the specified object.
- *
- * Results:
- * A newly constructed ByteCode object is stored in the internal
- * representation of the objPtr.
- *
- * Side effects:
- * A single heap object is allocated to hold the new ByteCode structure
- * and its code, object, command location, and aux data arrays. Note
- * that "ownership" (i.e., the pointers to) the Tcl objects and aux
- * data items will be handed over to the new ByteCode structure from
- * the CompileEnv structure.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclInitByteCodeObj(objPtr, envPtr)
- Tcl_Obj *objPtr; /* Points object that should be
- * initialized, and whose string rep
- * contains the source code. */
- register CompileEnv *envPtr; /* Points to the CompileEnv structure from
- * which to create a ByteCode structure. */
-{
- register ByteCode *codePtr;
- size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes;
- size_t auxDataArrayBytes;
- register size_t size, objBytes, totalSize;
- register unsigned char *p;
- unsigned char *nextPtr;
- int srcLen = envPtr->termOffset;
- int numObjects, i;
- Namespace *namespacePtr;
-#ifdef TCL_COMPILE_STATS
- int srcLenLog2, sizeLog2;
-#endif /*TCL_COMPILE_STATS*/
-
- codeBytes = (envPtr->codeNext - envPtr->codeStart);
- numObjects = envPtr->objArrayNext;
- objArrayBytes = (envPtr->objArrayNext * sizeof(Tcl_Obj *));
- exceptArrayBytes = (envPtr->excRangeArrayNext * sizeof(ExceptionRange));
- auxDataArrayBytes = (envPtr->auxDataArrayNext * sizeof(AuxData));
- cmdLocBytes = GetCmdLocEncodingSize(envPtr);
-
- size = sizeof(ByteCode);
- size += TCL_ALIGN(codeBytes); /* align object array */
- size += TCL_ALIGN(objArrayBytes); /* align exception range array */
- size += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
- size += auxDataArrayBytes;
- size += cmdLocBytes;
-
- /*
- * Compute the total number of bytes needed for this bytecode
- * including the storage for the Tcl objects in its object array.
- */
-
- objBytes = (numObjects * sizeof(Tcl_Obj));
- for (i = 0; i < numObjects; i++) {
- Tcl_Obj *litObjPtr = envPtr->objArrayPtr[i];
- if (litObjPtr->bytes != NULL) {
- objBytes += litObjPtr->length;
- }
- }
- totalSize = (size + objBytes);
-
-#ifdef TCL_COMPILE_STATS
- tclNumCompilations++;
- tclTotalSourceBytes += (double) srcLen;
- tclTotalCodeBytes += (double) totalSize;
-
- tclTotalInstBytes += (double) codeBytes;
- tclTotalObjBytes += (double) objBytes;
- tclTotalExceptBytes += exceptArrayBytes;
- tclTotalAuxBytes += (double) auxDataArrayBytes;
- tclTotalCmdMapBytes += (double) cmdLocBytes;
-
- tclCurrentSourceBytes += (double) srcLen;
- tclCurrentCodeBytes += (double) totalSize;
-
- srcLenLog2 = TclLog2(srcLen);
- sizeLog2 = TclLog2((int) totalSize);
- if ((srcLenLog2 > 31) || (sizeLog2 > 31)) {
- panic("TclInitByteCodeObj: bad source or code sizes\n");
- }
- tclSourceCount[srcLenLog2]++;
- tclByteCodeCount[sizeLog2]++;
-#endif /* TCL_COMPILE_STATS */
-
- if (envPtr->iPtr->varFramePtr != NULL) {
- namespacePtr = envPtr->iPtr->varFramePtr->nsPtr;
- } else {
- namespacePtr = envPtr->iPtr->globalNsPtr;
- }
-
- p = (unsigned char *) ckalloc(size);
- codePtr = (ByteCode *) p;
- codePtr->iPtr = envPtr->iPtr;
- codePtr->compileEpoch = envPtr->iPtr->compileEpoch;
- codePtr->nsPtr = namespacePtr;
- codePtr->nsEpoch = namespacePtr->resolverEpoch;
- codePtr->refCount = 1;
- codePtr->flags = 0;
- codePtr->source = envPtr->source;
- codePtr->procPtr = envPtr->procPtr;
- codePtr->totalSize = totalSize;
- codePtr->numCommands = envPtr->numCommands;
- codePtr->numSrcChars = srcLen;
- codePtr->numCodeBytes = codeBytes;
- codePtr->numObjects = numObjects;
- codePtr->numExcRanges = envPtr->excRangeArrayNext;
- codePtr->numAuxDataItems = envPtr->auxDataArrayNext;
- codePtr->auxDataArrayPtr = NULL;
- codePtr->numCmdLocBytes = cmdLocBytes;
- codePtr->maxExcRangeDepth = envPtr->maxExcRangeDepth;
- codePtr->maxStackDepth = envPtr->maxStackDepth;
-
- p += sizeof(ByteCode);
- codePtr->codeStart = p;
- memcpy((VOID *) p, (VOID *) envPtr->codeStart, codeBytes);
-
- p += TCL_ALIGN(codeBytes); /* align object array */
- codePtr->objArrayPtr = (Tcl_Obj **) p;
- memcpy((VOID *) p, (VOID *) envPtr->objArrayPtr, objArrayBytes);
-
- p += TCL_ALIGN(objArrayBytes); /* align exception range array */
- if (exceptArrayBytes > 0) {
- codePtr->excRangeArrayPtr = (ExceptionRange *) p;
- memcpy((VOID *) p, (VOID *) envPtr->excRangeArrayPtr,
- exceptArrayBytes);
- }
-
- p += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
- if (auxDataArrayBytes > 0) {
- codePtr->auxDataArrayPtr = (AuxData *) p;
- memcpy((VOID *) p, (VOID *) envPtr->auxDataArrayPtr,
- auxDataArrayBytes);
- }
-
- p += auxDataArrayBytes;
- nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p);
- if (((size_t)(nextPtr - p)) != cmdLocBytes) {
- panic("TclInitByteCodeObj: encoded cmd location bytes %d != expected size %d\n", (nextPtr - p), cmdLocBytes);
- }
-
- /*
- * Free the old internal rep then convert the object to a
- * bytecode object by making its internal rep point to the just
- * compiled ByteCode.
- */
-
- if ((objPtr->typePtr != NULL) &&
- (objPtr->typePtr->freeIntRepProc != NULL)) {
- objPtr->typePtr->freeIntRepProc(objPtr);
- }
- objPtr->internalRep.otherValuePtr = (VOID *) codePtr;
- objPtr->typePtr = &tclByteCodeType;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * GetCmdLocEncodingSize --
- *
- * Computes the total number of bytes needed to encode the command
- * location information for some compiled code.
- *
- * Results:
- * The byte count needed to encode the compiled location information.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-GetCmdLocEncodingSize(envPtr)
- CompileEnv *envPtr; /* Points to compilation environment
- * structure containing the CmdLocation
- * structure to encode. */
-{
- register CmdLocation *mapPtr = envPtr->cmdMapPtr;
- int numCmds = envPtr->numCommands;
- int codeDelta, codeLen, srcDelta, srcLen;
- int codeDeltaNext, codeLengthNext, srcDeltaNext, srcLengthNext;
- /* The offsets in their respective byte
- * sequences where the next encoded offset
- * or length should go. */
- int prevCodeOffset, prevSrcOffset, i;
-
- codeDeltaNext = codeLengthNext = srcDeltaNext = srcLengthNext = 0;
- prevCodeOffset = prevSrcOffset = 0;
- for (i = 0; i < numCmds; i++) {
- codeDelta = (mapPtr[i].codeOffset - prevCodeOffset);
- if (codeDelta < 0) {
- panic("GetCmdLocEncodingSize: bad code offset");
- } else if (codeDelta <= 127) {
- codeDeltaNext++;
- } else {
- codeDeltaNext += 5; /* 1 byte for 0xFF, 4 for positive delta */
- }
- prevCodeOffset = mapPtr[i].codeOffset;
-
- codeLen = mapPtr[i].numCodeBytes;
- if (codeLen < 0) {
- panic("GetCmdLocEncodingSize: bad code length");
- } else if (codeLen <= 127) {
- codeLengthNext++;
- } else {
- codeLengthNext += 5; /* 1 byte for 0xFF, 4 for length */
- }
-
- srcDelta = (mapPtr[i].srcOffset - prevSrcOffset);
- if ((-127 <= srcDelta) && (srcDelta <= 127)) {
- srcDeltaNext++;
- } else {
- srcDeltaNext += 5; /* 1 byte for 0xFF, 4 for delta */
- }
- prevSrcOffset = mapPtr[i].srcOffset;
-
- srcLen = mapPtr[i].numSrcChars;
- if (srcLen < 0) {
- panic("GetCmdLocEncodingSize: bad source length");
- } else if (srcLen <= 127) {
- srcLengthNext++;
- } else {
- srcLengthNext += 5; /* 1 byte for 0xFF, 4 for length */
- }
- }
-
- return (codeDeltaNext + codeLengthNext + srcDeltaNext + srcLengthNext);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * EncodeCmdLocMap --
- *
- * Encode the command location information for some compiled code into
- * a ByteCode structure. The encoded command location map is stored as
- * three adjacent byte sequences.
- *
- * Results:
- * Pointer to the first byte after the encoded command location
- * information.
- *
- * Side effects:
- * The encoded information is stored into the block of memory headed
- * by codePtr. Also records pointers to the start of the four byte
- * sequences in fields in codePtr's ByteCode header structure.
- *
- *----------------------------------------------------------------------
- */
-
-static unsigned char *
-EncodeCmdLocMap(envPtr, codePtr, startPtr)
- CompileEnv *envPtr; /* Points to compilation environment
- * structure containing the CmdLocation
- * structure to encode. */
- ByteCode *codePtr; /* ByteCode in which to encode envPtr's
- * command location information. */
- unsigned char *startPtr; /* Points to the first byte in codePtr's
- * memory block where the location
- * information is to be stored. */
-{
- register CmdLocation *mapPtr = envPtr->cmdMapPtr;
- int numCmds = envPtr->numCommands;
- register unsigned char *p = startPtr;
- int codeDelta, codeLen, srcDelta, srcLen, prevOffset;
- register int i;
-
- /*
- * Encode the code offset for each command as a sequence of deltas.
- */
-
- codePtr->codeDeltaStart = p;
- prevOffset = 0;
- for (i = 0; i < numCmds; i++) {
- codeDelta = (mapPtr[i].codeOffset - prevOffset);
- if (codeDelta < 0) {
- panic("EncodeCmdLocMap: bad code offset");
- } else if (codeDelta <= 127) {
- TclStoreInt1AtPtr(codeDelta, p);
- p++;
- } else {
- TclStoreInt1AtPtr(0xFF, p);
- p++;
- TclStoreInt4AtPtr(codeDelta, p);
- p += 4;
- }
- prevOffset = mapPtr[i].codeOffset;
- }
-
- /*
- * Encode the code length for each command.
- */
-
- codePtr->codeLengthStart = p;
- for (i = 0; i < numCmds; i++) {
- codeLen = mapPtr[i].numCodeBytes;
- if (codeLen < 0) {
- panic("EncodeCmdLocMap: bad code length");
- } else if (codeLen <= 127) {
- TclStoreInt1AtPtr(codeLen, p);
- p++;
- } else {
- TclStoreInt1AtPtr(0xFF, p);
- p++;
- TclStoreInt4AtPtr(codeLen, p);
- p += 4;
- }
- }
-
- /*
- * Encode the source offset for each command as a sequence of deltas.
- */
-
- codePtr->srcDeltaStart = p;
- prevOffset = 0;
- for (i = 0; i < numCmds; i++) {
- srcDelta = (mapPtr[i].srcOffset - prevOffset);
- if ((-127 <= srcDelta) && (srcDelta <= 127)) {
- TclStoreInt1AtPtr(srcDelta, p);
- p++;
- } else {
- TclStoreInt1AtPtr(0xFF, p);
- p++;
- TclStoreInt4AtPtr(srcDelta, p);
- p += 4;
- }
- prevOffset = mapPtr[i].srcOffset;
- }
-
- /*
- * Encode the source length for each command.
- */
-
- codePtr->srcLengthStart = p;
- for (i = 0; i < numCmds; i++) {
- srcLen = mapPtr[i].numSrcChars;
- if (srcLen < 0) {
- panic("EncodeCmdLocMap: bad source length");
- } else if (srcLen <= 127) {
- TclStoreInt1AtPtr(srcLen, p);
- p++;
- } else {
- TclStoreInt1AtPtr(0xFF, p);
- p++;
- TclStoreInt4AtPtr(srcLen, p);
- p += 4;
- }
- }
-
- return p;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileString --
+ * TclCompileScript --
*
- * Compile a Tcl script in a null-terminated binary string.
+ * Compile a Tcl script in a string.
*
* Results:
* The return value is TCL_OK on a successful compilation and TCL_ERROR
* on failure. If TCL_ERROR is returned, then the interpreter's result
* contains an error message.
*
- * envPtr->termOffset and interp->termOffset are filled in with the
- * offset of the character in the string just after the last one
- * successfully processed; this might be the offset of the ']' (if
- * flags & TCL_BRACKET_TERM), or the offset of the '\0' at the end of
- * the string. Also updates envPtr->maxStackDepth with the maximum
- * number of stack elements needed to execute the string's commands.
+ * interp->termOffset is set to the offset of the character in the
+ * script just after the last one successfully processed; this will be
+ * the offset of the ']' if (flags & TCL_BRACKET_TERM).
+ * envPtr->maxStackDepth is set to the maximum number of stack elements
+ * needed to execute the script's commands.
*
* Side effects:
- * Adds instructions to envPtr to evaluate the string at runtime.
+ * Adds instructions to envPtr to evaluate the script at runtime.
*
*----------------------------------------------------------------------
*/
int
-TclCompileString(interp, string, lastChar, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- char *string; /* The source string to compile. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
+TclCompileScript(interp, script, numBytes, nested, envPtr)
+ Tcl_Interp *interp; /* Used for error and status reporting. */
+ char *script; /* The source script to compile. */
+ int numBytes; /* Number of bytes in script. If < 0, the
+ * script consists of all bytes up to the
+ * first null character. */
+ int nested; /* Non-zero means this is a nested command:
+ * close bracket ']' should be considered a
+ * command terminator. If zero, close
+ * bracket has no special meaning. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Interp *iPtr = (Interp *) interp;
- register char *src = string;/* Points to current source char. */
- register char c = *src; /* The current char. */
- register int type; /* Current char's CHAR_TYPE type. */
- char termChar = (char)((flags & TCL_BRACKET_TERM)? ']' : '\0');
- /* Return when this character is found
- * (either ']' or '\0'). Zero means newlines
- * terminate cmds. */
- int isFirstCmd = 1; /* 1 if compiling the first cmd. */
- char *cmdSrcStart = NULL; /* Points to first non-blank char in each
- * command. Initialized to avoid compiler
- * warning. */
- int cmdIndex; /* The index of the current command in the
- * compilation environment's command
- * location table. */
+ Tcl_Parse parse;
+ int maxDepth = 0; /* Maximum number of stack elements needed
+ * to execute all cmds. */
int lastTopLevelCmdIndex = -1;
/* Index of most recent toplevel command in
* the command location table. Initialized
* to avoid compiler warning. */
- int cmdCodeOffset = -1; /* Offset of first byte of current command's
- * code. Initialized to avoid compiler
- * warning. */
- int cmdWords; /* Number of words in current command. */
- Tcl_Command cmd; /* Used to search for commands. */
- Command *cmdPtr; /* Points to command's Command structure if
- * first word is simple and command was
- * found; else NULL. */
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to execute all cmds. */
- char *termPtr; /* Points to char that terminated word. */
- char savedChar; /* Holds the character from string
- * termporarily replaced by a null character
- * during processing of words. */
- int objIndex = -1; /* The object array index for a pushed
- * object holding a word or word part
- * Initialized to avoid compiler warning. */
+ int startCodeOffset = -1; /* Offset of first byte of current command's
+ * code. Init. to avoid compiler warning. */
unsigned char *entryCodeNext = envPtr->codeNext;
- /* Value of envPtr's current instruction
- * pointer at entry. Used to tell if any
- * instructions generated. */
- char *ellipsis = ""; /* Used to set errorInfo variable; "..."
- * indicates that not all of offending
- * command is included in errorInfo. ""
- * means that the command is all there. */
- Tcl_Obj *objPtr;
- int numChars;
- int result = TCL_OK;
- int savePushSimpleWords = envPtr->pushSimpleWords;
+ char *p, *next;
+ Namespace *cmdNsPtr;
+ Command *cmdPtr;
+ Tcl_Token *tokenPtr;
+ int bytesLeft, isFirstCmd, gotParse, wordIdx, currCmdIndex;
+ int commandLength, objIndex, code;
+ char prev;
+ Tcl_DString ds;
+
+ Tcl_DStringInit(&ds);
+
+ if (numBytes < 0) {
+ numBytes = strlen(script);
+ }
+ Tcl_ResetResult(interp);
+ isFirstCmd = 1;
/*
- * commands: command {(';' | '\n') command}
+ * Each iteration through the following loop compiles the next
+ * command from the script.
*/
- while ((src != lastChar) && (c != termChar)) {
- /*
- * Skip white space, semicolons, backslash-newlines (treated as
- * spaces), and comments before command.
- */
-
- type = CHAR_TYPE(src, lastChar);
- while ((type & (TCL_SPACE | TCL_BACKSLASH))
- || (c == '\n') || (c == ';')) {
- if (type == TCL_BACKSLASH) {
- if (src[1] == '\n') {
- src += 2;
- } else {
- break;
- }
- } else {
- src++;
- }
- c = *src;
- type = CHAR_TYPE(src, lastChar);
+ p = script;
+ bytesLeft = numBytes;
+ gotParse = 0;
+ while (bytesLeft > 0) {
+ if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse) != TCL_OK) {
+ code = TCL_ERROR;
+ goto error;
}
+ gotParse = 1;
+ if (parse.numWords > 0) {
+ /*
+ * If not the first command, pop the previous command's result
+ * and, if we're compiling a top level command, update the last
+ * command's code size to account for the pop instruction.
+ */
- if (c == '#') {
- while (src != lastChar) {
- if (c == '\\') {
- int numRead;
- Tcl_Backslash(src, &numRead);
- src += numRead;
- } else if (c == '\n') {
- src++;
- c = *src;
- envPtr->termOffset = (src - string);
- break;
- } else {
- src++;
+ if (!isFirstCmd) {
+ TclEmitOpcode(INST_POP, envPtr);
+ if (!nested) {
+ envPtr->cmdMapPtr[lastTopLevelCmdIndex].numCodeBytes =
+ (envPtr->codeNext - envPtr->codeStart)
+ - startCodeOffset;
}
- c = *src;
}
- continue; /* end of comment, restart outer command loop */
- }
-
- /*
- * Compile one command: zero or more words terminated by a '\n',
- * ';', ']' (if command is terminated by close bracket), or
- * the end of string.
- *
- * command: word*
- */
- type = CHAR_TYPE(src, lastChar);
- if ((type == TCL_COMMAND_END)
- && ((c != ']') || (flags & TCL_BRACKET_TERM))) {
- continue; /* empty command; restart outer cmd loop */
- }
+ /*
+ * Determine the actual length of the command.
+ */
- /*
- * If not the first command, discard the previous command's result.
- */
-
- if (!isFirstCmd) {
- TclEmitOpcode(INST_POP, envPtr);
- if (!(flags & TCL_BRACKET_TERM)) {
+ commandLength = parse.commandSize;
+ prev = '\0';
+ if (commandLength > 0) {
+ prev = parse.commandStart[commandLength-1];
+ }
+ if (((parse.commandStart+commandLength) != (script+numBytes))
+ || ((prev=='\n') || (nested && (prev==']')))) {
/*
- * We are compiling a top level command. Update the number
- * of code bytes for the last command to account for the pop
- * instruction.
+ * The command didn't end at the end of the script (i.e. it
+ * ended at a terminator character such as ";". Reduce the
+ * length by one so that the trace message doesn't include
+ * the terminator character.
*/
- (envPtr->cmdMapPtr[lastTopLevelCmdIndex]).numCodeBytes =
- (envPtr->codeNext-envPtr->codeStart) - cmdCodeOffset;
+ commandLength -= 1;
}
- }
-
- /*
- * Compile the words of the command. Process the first word
- * specially, since it is the name of a command. If it is a "simple"
- * string (just a sequence of characters), look it up in the table
- * of compilation procedures. If a word other than the first is
- * simple and represents an integer whose formatted representation
- * is the same as the word, just push an integer object. Also record
- * starting source and object information for the command.
- */
- envPtr->numCommands++;
- cmdIndex = (envPtr->numCommands - 1);
- if (!(flags & TCL_BRACKET_TERM)) {
- lastTopLevelCmdIndex = cmdIndex;
- }
-
- cmdSrcStart = src;
- cmdCodeOffset = (envPtr->codeNext - envPtr->codeStart);
- cmdWords = 0;
- EnterCmdStartData(envPtr, cmdIndex, src-envPtr->source,
- cmdCodeOffset);
-
- if ((!(flags & TCL_BRACKET_TERM))
- && (tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) {
- /*
- * Display a line summarizing the top level command we are about
- * to compile.
- */
-
- char *p = cmdSrcStart;
- int numChars, complete;
-
- while ((CHAR_TYPE(p, lastChar) != TCL_COMMAND_END)
- || ((*p == ']') && !(flags & TCL_BRACKET_TERM))) {
- p++;
- }
- numChars = (p - cmdSrcStart);
- complete = 1;
- if (numChars > 60) {
- numChars = 60;
- complete = 0;
- } else if ((numChars >= 2) && (*p == '\n') && (*(p-1) == '{')) {
- complete = 0;
- }
- fprintf(stdout, "Compiling: %.*s%s\n",
- numChars, cmdSrcStart, (complete? "" : " ..."));
- }
-
- while ((type != TCL_COMMAND_END)
- || ((c == ']') && !(flags & TCL_BRACKET_TERM))) {
/*
- * Skip any leading white space at the start of a word. Note
- * that a backslash-newline is treated as a space.
- */
+ * If tracing, print a line for each top level command compiled.
+ */
- while (type & (TCL_SPACE | TCL_BACKSLASH)) {
- if (type == TCL_BACKSLASH) {
- if (src[1] == '\n') {
- src += 2;
- } else {
- break;
- }
- } else {
- src++;
- }
- c = *src;
- type = CHAR_TYPE(src, lastChar);
- }
- if ((type == TCL_COMMAND_END)
- && ((c != ']') || (flags & TCL_BRACKET_TERM))) {
- break; /* no words remain for command. */
+ if ((tclTraceCompile >= 1)
+ && !nested && (envPtr->procPtr == NULL)) {
+ fprintf(stdout, " Compiling: ");
+ TclPrintSource(stdout, parse.commandStart,
+ TclMin(commandLength, 55));
+ fprintf(stdout, "\n");
}
/*
- * Compile one word. We use an inline version of CompileWord to
- * avoid an extra procedure call.
+ * Each iteration of the following loop compiles one word
+ * from the command.
*/
-
- envPtr->pushSimpleWords = 0;
- if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
- src++;
- if (type == TCL_QUOTE) {
- result = TclCompileQuotes(interp, src, lastChar,
- '"', flags, envPtr);
- } else {
- result = CompileBraces(interp, src, lastChar,
- flags, envPtr);
- }
- termPtr = (src + envPtr->termOffset);
- if (result != TCL_OK) {
- src = termPtr;
- goto done;
- }
-
- /*
- * Make sure terminating character of the quoted or braced
- * string is the end of word.
- */
-
- c = *termPtr;
- if ((c == '\\') && (*(termPtr+1) == '\n')) {
- /*
- * Line is continued on next line; the backslash-
- * newline turns into space, which terminates the word.
- */
- } else {
- type = CHAR_TYPE(termPtr, lastChar);
- if ((type != TCL_SPACE) && (type != TCL_COMMAND_END)) {
- Tcl_ResetResult(interp);
- if (*(src-1) == '"') {
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "extra characters after close-quote", -1);
- } else {
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "extra characters after close-brace", -1);
- }
- result = TCL_ERROR;
- }
- }
- } else {
- result = CompileMultipartWord(interp, src, lastChar,
- flags, envPtr);
- termPtr = (src + envPtr->termOffset);
- }
- if (result != TCL_OK) {
- ellipsis = "...";
- src = termPtr;
- goto done;
- }
- if (envPtr->wordIsSimple) {
- /*
- * A simple word. Temporarily replace the terminating
- * character with a null character.
- */
-
- numChars = envPtr->numSimpleWordChars;
- savedChar = src[numChars];
- src[numChars] = '\0';
-
- if ((cmdWords == 0)
- && (!(iPtr->flags & DONT_COMPILE_CMDS_INLINE))) {
+ envPtr->numCommands++;
+ currCmdIndex = (envPtr->numCommands - 1);
+ if (!nested) {
+ lastTopLevelCmdIndex = currCmdIndex;
+ }
+ startCodeOffset = (envPtr->codeNext - envPtr->codeStart);
+ EnterCmdStartData(envPtr, currCmdIndex,
+ (parse.commandStart - envPtr->source), startCodeOffset);
+
+ for (wordIdx = 0, tokenPtr = parse.tokenPtr;
+ wordIdx < parse.numWords;
+ wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) {
+ if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
/*
- * The first word of a command and inline command
- * compilation has not been disabled (e.g., by command
- * traces). Look up the first word in the interpreter's
- * hashtable of commands. If a compilation procedure is
- * found, let it compile the command after resetting
- * error logging information. Note that if we are
- * compiling a procedure, we must look up the command
- * in the procedure's namespace and not the current
- * namespace.
+ * If this is the first word and the command has a
+ * compile procedure, let it compile the command.
*/
- Namespace *cmdNsPtr;
-
- if (envPtr->procPtr != NULL) {
- cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr;
- } else {
- cmdNsPtr = NULL;
- }
-
- cmdPtr = NULL;
- cmd = Tcl_FindCommand(interp, src,
- (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0);
- if (cmd != (Tcl_Command) NULL) {
- cmdPtr = (Command *) cmd;
- }
- if ((cmdPtr != NULL) && (cmdPtr->compileProc != NULL)) {
- char *firstArg = termPtr;
- src[numChars] = savedChar;
- iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS
- | ERROR_CODE_SET);
- result = (*(cmdPtr->compileProc))(interp,
- firstArg, lastChar, flags, envPtr);
- if (result == TCL_OK) {
- src = (firstArg + envPtr->termOffset);
- maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
- goto finishCommand;
- } else if (result == TCL_OUT_LINE_COMPILE) {
- result = TCL_OK;
- src[numChars] = '\0';
+ if (wordIdx == 0) {
+ if (envPtr->procPtr != NULL) {
+ cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr;
} else {
- src = firstArg;
- goto done; /* an error */
+ cmdNsPtr = NULL; /* use current NS */
}
- }
- /*
- * No compile procedure was found for the command: push
- * the word and continue to compile the remaining
- * words. If a hashtable entry was found for the
- * command, push a CmdName object instead to avoid
- * runtime lookups. If necessary, convert the pushed
- * object to be a CmdName object. If this is the first
- * CmdName object in this code unit that refers to the
- * command, increment the reference count in the
- * Command structure to reflect the new reference from
- * the CmdName object and, if the command is deleted
- * later, to keep the Command structure from being freed
- * until TclExecuteByteCode has a chance to recognize
- * that the command was deleted.
- */
+ /*
+ * We copy the string before trying to find the command
+ * by name. We used to modify the string in place, but
+ * this is not safe because the name resolution
+ * handlers could have side effects that rely on the
+ * unmodified string.
+ */
+
+ Tcl_DStringSetLength(&ds, 0);
+ Tcl_DStringAppend(&ds, tokenPtr[1].start,
+ tokenPtr[1].size);
+
+ cmdPtr = (Command *) Tcl_FindCommand(interp,
+ Tcl_DStringValue(&ds),
+ (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0);
+
+ if ((cmdPtr != NULL)
+ && (cmdPtr->compileProc != NULL)
+ && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) {
+ code = (*(cmdPtr->compileProc))(interp, &parse,
+ envPtr);
+ if (code == TCL_OK) {
+ maxDepth = TclMax(envPtr->maxStackDepth,
+ maxDepth);
+ goto finishCommand;
+ } else if (code == TCL_OUT_LINE_COMPILE) {
+ /* do nothing */
+ } else { /* an error */
+ goto error;
+ }
+ }
- objIndex = TclObjIndexForString(src, numChars,
- /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- if (cmdPtr != NULL) {
- objPtr = envPtr->objArrayPtr[objIndex];
- if ((objPtr->typePtr != &tclCmdNameType)
- && (objPtr->bytes != NULL)) {
- ResolvedCmdName *resPtr = (ResolvedCmdName *)
- ckalloc(sizeof(ResolvedCmdName));
- Namespace *nsPtr = (Namespace *)
- Tcl_GetCurrentNamespace(interp);
-
- resPtr->cmdPtr = cmdPtr;
- resPtr->refNsPtr = nsPtr;
- resPtr->refNsId = nsPtr->nsId;
- resPtr->refNsCmdEpoch = nsPtr->cmdRefEpoch;
- resPtr->cmdEpoch = cmdPtr->cmdEpoch;
- resPtr->refCount = 1;
- objPtr->internalRep.twoPtrValue.ptr1 =
- (VOID *) resPtr;
- objPtr->internalRep.twoPtrValue.ptr2 = NULL;
- objPtr->typePtr = &tclCmdNameType;
- cmdPtr->refCount++;
+ /*
+ * No compile procedure so push the word. If the
+ * command was found, push a CmdName object to
+ * reduce runtime lookups.
+ */
+
+ objIndex = TclRegisterLiteral(envPtr,
+ tokenPtr[1].start, tokenPtr[1].size,
+ /*onHeap*/ 0);
+ if (cmdPtr != NULL) {
+ TclSetCmdNameObj(interp,
+ envPtr->literalArrayPtr[objIndex].objPtr,
+ cmdPtr);
}
+ } else {
+ objIndex = TclRegisterLiteral(envPtr,
+ tokenPtr[1].start, tokenPtr[1].size,
+ /*onHeap*/ 0);
}
+ TclEmitPush(objIndex, envPtr);
+ maxDepth = TclMax((wordIdx + 1), maxDepth);
} else {
/*
- * See if the word represents an integer whose formatted
- * representation is the same as the word (e.g., this is
- * true for 123 and -1 but not for 00005). If so, just
- * push an integer object.
+ * The word is not a simple string of characters.
*/
-
- int isCompilableInt = 0;
- long n;
- char buf[40];
- if (TclLooksLikeInt(src)) {
- int code = TclGetLong(interp, src, &n);
- if (code == TCL_OK) {
- TclFormatInt(buf, n);
- if (strcmp(src, buf) == 0) {
- isCompilableInt = 1;
- objIndex = TclObjIndexForString(src,
- numChars, /*allocStrRep*/ 0,
- /*inHeap*/ 0, envPtr);
- objPtr = envPtr->objArrayPtr[objIndex];
-
- Tcl_InvalidateStringRep(objPtr);
- objPtr->internalRep.longValue = n;
- objPtr->typePtr = &tclIntType;
- }
- } else {
- Tcl_ResetResult(interp);
- }
- }
- if (!isCompilableInt) {
- objIndex = TclObjIndexForString(src, numChars,
- /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
+ code = TclCompileTokens(interp, tokenPtr+1,
+ tokenPtr->numComponents, envPtr);
+ if (code != TCL_OK) {
+ goto error;
}
+ maxDepth = TclMax((wordIdx + envPtr->maxStackDepth),
+ maxDepth);
}
- src[numChars] = savedChar;
- TclEmitPush(objIndex, envPtr);
- maxDepth = TclMax((cmdWords + 1), maxDepth);
- } else { /* not a simple word */
- maxDepth = TclMax((cmdWords + envPtr->maxStackDepth),
- maxDepth);
}
- src = termPtr;
- c = *src;
- type = CHAR_TYPE(src, lastChar);
- cmdWords++;
- }
-
- /*
- * Emit an invoke instruction for the command. If a compile command
- * was found for the command we called it and skipped this.
- */
-
- if (cmdWords > 0) {
- if (cmdWords <= 255) {
- TclEmitInstUInt1(INST_INVOKE_STK1, cmdWords, envPtr);
- } else {
- TclEmitInstUInt4(INST_INVOKE_STK4, cmdWords, envPtr);
- }
- }
-
- /*
- * Update the compilation environment structure. Record
- * source/object information for the command.
- */
-
- finishCommand:
- EnterCmdExtentData(envPtr, cmdIndex, src-cmdSrcStart,
- (envPtr->codeNext-envPtr->codeStart) - cmdCodeOffset);
-
- isFirstCmd = 0;
- envPtr->termOffset = (src - string);
- c = *src;
- }
- done:
- if (result == TCL_OK) {
- /*
- * If the source string yielded no instructions (e.g., if it was
- * empty), push an empty string object as the command's result.
- */
-
- if (entryCodeNext == envPtr->codeNext) {
- int objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0,
- /*inHeap*/ 0, envPtr);
- TclEmitPush(objIndex, envPtr);
- maxDepth = 1;
- }
- } else {
- /*
- * Add additional error information. First compute the line number
- * where the error occurred.
- */
+ /*
+ * Emit an invoke instruction for the command. We skip this
+ * if a compile procedure was found for the command.
+ */
+
+ if (wordIdx > 0) {
+ if (wordIdx <= 255) {
+ TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr);
+ } else {
+ TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr);
+ }
+ }
- register char *p;
- int numChars;
- char buf[200];
+ /*
+ * Update the compilation environment structure and record the
+ * offsets of the source and code for the command.
+ */
- iPtr->errorLine = 1;
- for (p = string; p != cmdSrcStart; p++) {
- if (*p == '\n') {
- iPtr->errorLine++;
- }
- }
- for ( ; isspace(UCHAR(*p)) || (*p == ';'); p++) {
- if (*p == '\n') {
- iPtr->errorLine++;
- }
- }
+ finishCommand:
+ EnterCmdExtentData(envPtr, currCmdIndex, commandLength,
+ (envPtr->codeNext-envPtr->codeStart) - startCodeOffset);
+ isFirstCmd = 0;
+ } /* end if parse.numWords > 0 */
/*
- * Figure out how much of the command to print (up to a certain
- * number of characters, or up to the end of the command).
+ * Advance to the next command in the script.
*/
-
- p = cmdSrcStart;
- while ((CHAR_TYPE(p, lastChar) != TCL_COMMAND_END)
- || ((*p == ']') && !(flags & TCL_BRACKET_TERM))) {
- p++;
- }
- numChars = (p - cmdSrcStart);
- if (numChars > 150) {
- numChars = 150;
- ellipsis = " ...";
- } else if ((numChars >= 2) && (*p == '\n') && (*(p-1) == '{')) {
- ellipsis = " ...";
- }
-
- sprintf(buf, "\n while compiling\n\"%.*s%s\"",
- numChars, cmdSrcStart, ellipsis);
- Tcl_AddObjErrorInfo(interp, buf, -1);
- }
- envPtr->termOffset = (src - string);
- iPtr->termOffset = envPtr->termOffset;
- envPtr->maxStackDepth = maxDepth;
- envPtr->pushSimpleWords = savePushSimpleWords;
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * CompileWord --
- *
- * This procedure compiles one word from a command string. It skips
- * any leading white space.
- *
- * Ordinarily, callers set envPtr->pushSimpleWords to 1 and this
- * procedure emits push and other instructions to compute the
- * word on the Tcl evaluation stack at execution time. If a caller sets
- * envPtr->pushSimpleWords to 0, CompileWord will _not_ compile
- * "simple" words: words that are just a sequence of characters without
- * backslashes. It will leave their compilation up to the caller.
- *
- * As an important special case, if the word is simple, this procedure
- * sets envPtr->wordIsSimple to 1 and envPtr->numSimpleWordChars to the
- * number of characters in the simple word. This allows the caller to
- * process these words specially.
- *
- * Results:
- * The return value is a standard Tcl result. If an error occurs, an
- * error message is left in the interpreter's result.
- *
- * envPtr->termOffset is filled in with the offset of the character in
- * "string" just after the last one successfully processed in the last
- * word. This is normally the character just after the last one in a
- * word (perhaps the command terminator), or the vicinity of an error
- * (if the result is not TCL_OK).
- *
- * envPtr->wordIsSimple is set 1 if the word is simple: just a
- * sequence of characters without backslashes. If so, the word's
- * characters are the envPtr->numSimpleWordChars characters starting
- * at string.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to evaluate the word. This is not changed if
- * the word is simple and envPtr->pushSimpleWords was 0 (false).
- *
- * Side effects:
- * Instructions are added to envPtr to compute and push the word
- * at runtime.
- *
- *----------------------------------------------------------------------
- */
+ next = parse.commandStart + parse.commandSize;
+ bytesLeft -= (next - p);
+ p = next;
+ Tcl_FreeParse(&parse);
+ gotParse = 0;
+ if (nested && (p[-1] == ']')) {
+ /*
+ * We get here in the special case where TCL_BRACKET_TERM was
+ * set in the interpreter and we reached a close bracket in the
+ * script. Stop compilation.
+ */
+
+ break;
+ }
+ }
-static int
-CompileWord(interp, string, lastChar, flags, envPtr)
- Tcl_Interp *interp; /* Interpreter to use for nested command
- * evaluations and error messages. */
- char *string; /* First character of word. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int flags; /* Flags to control compilation (same values
- * passed to Tcl_EvalObj). */
- CompileEnv *envPtr; /* Holds the resulting instructions. */
-{
/*
- * Compile one word: approximately
- *
- * word: quoted_string | braced_string | multipart_word
- * quoted_string: '"' char* '"'
- * braced_string: '{' char* '}'
- * multipart_word (see CompileMultipartWord below)
+ * If the source script yielded no instructions (e.g., if it was empty),
+ * push an empty string as the command's result.
*/
- register char *src = string; /* Points to current source char. */
- register int type = CHAR_TYPE(src, lastChar);
- /* Current char's CHAR_TYPE type. */
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to compute and push the word. */
- char *termPtr = src; /* Points to the character that terminated
- * the word. */
- int result = TCL_OK;
-
- /*
- * Skip any leading white space at the start of a word. Note that a
- * backslash-newline is treated as a space.
- */
-
- while (type & (TCL_SPACE | TCL_BACKSLASH)) {
- if (type == TCL_BACKSLASH) {
- if (src[1] == '\n') {
- src += 2;
- } else {
- break; /* no longer white space */
- }
- } else {
- src++;
- }
- type = CHAR_TYPE(src, lastChar);
+ if (envPtr->codeNext == entryCodeNext) {
+ TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*alreadyAlloced*/ 0),
+ envPtr);
+ maxDepth = 1;
}
- if (type == TCL_COMMAND_END) {
- goto done;
+
+ if ((nested != 0) && (p > script) && (p[-1] == ']')) {
+ iPtr->termOffset = (p - 1) - script;
+ } else {
+ iPtr->termOffset = (p - script);
}
-
+ envPtr->maxStackDepth = maxDepth;
+ Tcl_DStringFree(&ds);
+ return TCL_OK;
+
+ error:
/*
- * Compile the word. Handle quoted and braced string words here in order
- * to avoid an extra procedure call.
+ * Generate various pieces of error information, such as the line
+ * number where the error occurred and information to add to the
+ * errorInfo variable. Then free resources that had been allocated
+ * to the command.
*/
- if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
- src++;
- if (type == TCL_QUOTE) {
- result = TclCompileQuotes(interp, src, lastChar, '"', flags,
- envPtr);
- } else {
- result = CompileBraces(interp, src, lastChar, flags, envPtr);
- }
- termPtr = (src + envPtr->termOffset);
- if (result != TCL_OK) {
- goto done;
- }
-
+ commandLength = parse.commandSize;
+ prev = '\0';
+ if (commandLength > 0) {
+ prev = parse.commandStart[commandLength-1];
+ }
+ if (((parse.commandStart+commandLength) != (script+numBytes))
+ || ((prev == '\n') || (nested && (prev == ']')))) {
/*
- * Make sure terminating character of the quoted or braced string is
- * the end of word.
+ * The command where the error occurred didn't end at the end
+ * of the script (i.e. it ended at a terminator character such
+ * as ";". Reduce the length by one so that the error message
+ * doesn't include the terminator character.
*/
-
- if ((*termPtr == '\\') && (*(termPtr+1) == '\n')) {
- /*
- * Line is continued on next line; the backslash-newline turns
- * into space, which terminates the word.
- */
- } else {
- type = CHAR_TYPE(termPtr, lastChar);
- if (!(type & (TCL_SPACE | TCL_COMMAND_END))) {
- Tcl_ResetResult(interp);
- if (*(src-1) == '"') {
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "extra characters after close-quote", -1);
- } else {
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "extra characters after close-brace", -1);
- }
- result = TCL_ERROR;
- goto done;
- }
- }
- maxDepth = envPtr->maxStackDepth;
- } else {
- result = CompileMultipartWord(interp, src, lastChar, flags, envPtr);
- termPtr = (src + envPtr->termOffset);
- maxDepth = envPtr->maxStackDepth;
- }
- /*
- * Done processing the word. The values of envPtr->wordIsSimple and
- * envPtr->numSimpleWordChars are left at the values returned by
- * TclCompileQuotes/Braces/MultipartWord.
- */
-
- done:
- envPtr->termOffset = (termPtr - string);
+ commandLength -= 1;
+ }
+ LogCompilationInfo(interp, script, parse.commandStart, commandLength);
+ if (gotParse) {
+ Tcl_FreeParse(&parse);
+ }
+ iPtr->termOffset = (p - script);
envPtr->maxStackDepth = maxDepth;
- return result;
+ Tcl_DStringFree(&ds);
+ return code;
}
/*
*----------------------------------------------------------------------
*
- * CompileMultipartWord --
- *
- * This procedure compiles one multipart word: a word comprised of some
- * number of nested commands, variable references, or arbitrary
- * characters. This procedure assumes that quoted string and braced
- * string words and the end of command have already been handled by its
- * caller. It also assumes that any leading white space has already
- * been consumed.
- *
- * Ordinarily, callers set envPtr->pushSimpleWords to 1 and this
- * procedure emits push and other instructions to compute the word on
- * the Tcl evaluation stack at execution time. If a caller sets
- * envPtr->pushSimpleWords to 0, it will _not_ compile "simple" words:
- * words that are just a sequence of characters without backslashes.
- * It will leave their compilation up to the caller. This is done, for
- * example, to provide special support for the first word of commands,
- * which are almost always the (simple) name of a command.
- *
- * As an important special case, if the word is simple, this procedure
- * sets envPtr->wordIsSimple to 1 and envPtr->numSimpleWordChars to the
- * number of characters in the simple word. This allows the caller to
- * process these words specially.
+ * TclCompileTokens --
+ *
+ * Given an array of tokens parsed from a Tcl command (e.g., the tokens
+ * that make up a word) this procedure emits instructions to evaluate
+ * the tokens and concatenate their values to form a single result
+ * value on the interpreter's runtime evaluation stack.
*
* Results:
* The return value is a standard Tcl result. If an error occurs, an
* error message is left in the interpreter's result.
*
- * envPtr->termOffset is filled in with the offset of the character in
- * "string" just after the last one successfully processed in the last
- * word. This is normally the character just after the last one in a
- * word (perhaps the command terminator), or the vicinity of an error
- * (if the result is not TCL_OK).
- *
- * envPtr->wordIsSimple is set 1 if the word is simple: just a
- * sequence of characters without backslashes. If so, the word's
- * characters are the envPtr->numSimpleWordChars characters starting
- * at string.
- *
* envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to evaluate the word. This is not changed if
- * the word is simple and envPtr->pushSimpleWords was 0 (false).
+ * elements needed to evaluate the tokens.
*
* Side effects:
- * Instructions are added to envPtr to compute and push the word
+ * Instructions are added to envPtr to push and evaluate the tokens
* at runtime.
*
*----------------------------------------------------------------------
*/
-static int
-CompileMultipartWord(interp, string, lastChar, flags, envPtr)
- Tcl_Interp *interp; /* Interpreter to use for nested command
- * evaluations and error messages. */
- char *string; /* First character of word. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int flags; /* Flags to control compilation (same values
- * passed to Tcl_EvalObj). */
+int
+TclCompileTokens(interp, tokenPtr, count, envPtr)
+ Tcl_Interp *interp; /* Used for error and status reporting. */
+ Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens
+ * to compile. */
+ int count; /* Number of tokens to consider at tokenPtr.
+ * Must be at least 1. */
CompileEnv *envPtr; /* Holds the resulting instructions. */
{
- /*
- * Compile one multi_part word:
- *
- * multi_part_word: word_part+
- * word_part: nested_cmd | var_reference | char+
- * nested_cmd: '[' command ']'
- * var_reference: '$' name | '$' name '(' index_string ')' |
- * '$' '{' braced_name '}')
- * name: (letter | digit | underscore)+
- * braced_name: (non_close_brace_char)*
- * index_string: (non_close_paren_char)*
- */
-
- register char *src = string; /* Points to current source char. */
- register char c = *src; /* The current char. */
- register int type; /* Current char's CHAR_TYPE type. */
- int bracketNormal = !(flags & TCL_BRACKET_TERM);
- int simpleWord = 0; /* Set 1 if word is simple. */
- int numParts = 0; /* Count of word_part objs pushed. */
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to compute and push the word. */
- char *start; /* Starting position of char+ word_part. */
- int hasBackslash; /* Nonzero if '\' in char+ word_part. */
- int numChars; /* Number of chars in char+ word_part. */
- char savedChar; /* Holds the character from string
- * termporarily replaced by a null character
- * during word_part processing. */
- int objIndex; /* The object array index for a pushed
- * object holding a word_part. */
- int savePushSimpleWords = envPtr->pushSimpleWords;
- int result = TCL_OK;
- int numRead;
-
- type = CHAR_TYPE(src, lastChar);
- while (1) {
- /*
- * Process a word_part: a sequence of chars, a var reference, or
- * a nested command.
- */
+ Tcl_DString textBuffer; /* Holds concatenated chars from adjacent
+ * TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */
+ char buffer[TCL_UTF_MAX];
+ char *name, *p;
+ int numObjsToConcat, nameBytes, hasNsQualifiers, localVar;
+ int length, maxDepth, depthForVar, i, code;
+ unsigned char *entryCodeNext = envPtr->codeNext;
- if ((type & (TCL_NORMAL | TCL_CLOSE_BRACE | TCL_BACKSLASH |
- TCL_QUOTE | TCL_OPEN_BRACE)) ||
- ((c == ']') && bracketNormal)) {
- /*
- * A char+ word part. Scan first looking for any backslashes.
- * Note that a backslash-newline must be treated as a word
- * separator, as if the backslash-newline had been collapsed
- * before command parsing began.
- */
-
- start = src;
- hasBackslash = 0;
- do {
- if (type == TCL_BACKSLASH) {
- hasBackslash = 1;
- Tcl_Backslash(src, &numRead);
- if (src[1] == '\n') {
- src += numRead;
- type = TCL_SPACE; /* force word end */
- break;
- }
- src += numRead;
- } else {
- src++;
- }
- c = *src;
- type = CHAR_TYPE(src, lastChar);
- } while (type & (TCL_NORMAL | TCL_BACKSLASH | TCL_QUOTE |
- TCL_OPEN_BRACE | TCL_CLOSE_BRACE)
- || ((c == ']') && bracketNormal));
-
- if ((numParts == 0) && !hasBackslash
- && (type & (TCL_SPACE | TCL_COMMAND_END))) {
+ Tcl_DStringInit(&textBuffer);
+ maxDepth = 0;
+ numObjsToConcat = 0;
+ for ( ; count > 0; count--, tokenPtr++) {
+ switch (tokenPtr->type) {
+ case TCL_TOKEN_TEXT:
+ Tcl_DStringAppend(&textBuffer, tokenPtr->start,
+ tokenPtr->size);
+ break;
+
+ case TCL_TOKEN_BS:
+ length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL,
+ buffer);
+ Tcl_DStringAppend(&textBuffer, buffer, length);
+ break;
+
+ case TCL_TOKEN_COMMAND:
/*
- * The word is "simple": just a sequence of characters
- * without backslashes terminated by a TCL_SPACE or
- * TCL_COMMAND_END. Just return if we are not to compile
- * simple words.
+ * Push any accumulated chars appearing before the command.
*/
-
- simpleWord = 1;
- if (!envPtr->pushSimpleWords) {
- envPtr->wordIsSimple = 1;
- envPtr->numSimpleWordChars = (src - string);
- envPtr->termOffset = envPtr->numSimpleWordChars;
- envPtr->pushSimpleWords = savePushSimpleWords;
- return TCL_OK;
+
+ if (Tcl_DStringLength(&textBuffer) > 0) {
+ int literal;
+
+ literal = TclRegisterLiteral(envPtr,
+ Tcl_DStringValue(&textBuffer),
+ Tcl_DStringLength(&textBuffer), /*onHeap*/ 0);
+ TclEmitPush(literal, envPtr);
+ numObjsToConcat++;
+ maxDepth = TclMax(numObjsToConcat, maxDepth);
+ Tcl_DStringFree(&textBuffer);
}
- }
-
- /*
- * Create and push a string object for the char+ word_part,
- * which starts at "start" and ends at the char just before
- * src. If backslashes were found, copy the word_part's
- * characters with substituted backslashes into a heap-allocated
- * buffer and use it to create the string object. Temporarily
- * replace the terminating character with a null character.
- */
+
+ code = TclCompileScript(interp, tokenPtr->start+1,
+ tokenPtr->size-2, /*nested*/ 1, envPtr);
+ if (code != TCL_OK) {
+ goto error;
+ }
+ maxDepth = TclMax((numObjsToConcat + envPtr->maxStackDepth),
+ maxDepth);
+ numObjsToConcat++;
+ break;
- numChars = (src - start);
- savedChar = start[numChars];
- start[numChars] = '\0';
- if ((numChars > 0) && (hasBackslash)) {
- char *buffer = ckalloc((unsigned) numChars + 1);
- register char *dst = buffer;
- register char *p = start;
- while (p < src) {
- if (*p == '\\') {
- *dst = Tcl_Backslash(p, &numRead);
- if (p[1] == '\n') {
- break;
- }
- p += numRead;
- dst++;
- } else {
- *dst++ = *p++;
- }
+ case TCL_TOKEN_VARIABLE:
+ /*
+ * Push any accumulated chars appearing before the $<var>.
+ */
+
+ if (Tcl_DStringLength(&textBuffer) > 0) {
+ int literal;
+
+ literal = TclRegisterLiteral(envPtr,
+ Tcl_DStringValue(&textBuffer),
+ Tcl_DStringLength(&textBuffer), /*onHeap*/ 0);
+ TclEmitPush(literal, envPtr);
+ numObjsToConcat++;
+ maxDepth = TclMax(numObjsToConcat, maxDepth);
+ Tcl_DStringFree(&textBuffer);
}
- *dst = '\0';
- objIndex = TclObjIndexForString(buffer, dst-buffer,
- /*allocStrRep*/ 1, /*inHeap*/ 1, envPtr);
- } else {
- objIndex = TclObjIndexForString(start, numChars,
- /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- }
- start[numChars] = savedChar;
- TclEmitPush(objIndex, envPtr);
- maxDepth = TclMax((numParts + 1), maxDepth);
- } else if (type == TCL_DOLLAR) {
- result = TclCompileDollarVar(interp, src, lastChar,
- flags, envPtr);
- src += envPtr->termOffset;
- if (result != TCL_OK) {
- goto done;
- }
- maxDepth = TclMax((numParts + envPtr->maxStackDepth), maxDepth);
- c = *src;
- type = CHAR_TYPE(src, lastChar);
- } else if (type == TCL_OPEN_BRACKET) {
- char *termPtr;
- envPtr->pushSimpleWords = 1;
- src++;
- result = TclCompileString(interp, src, lastChar,
- (flags | TCL_BRACKET_TERM), envPtr);
- termPtr = (src + envPtr->termOffset);
- if (*termPtr == ']') {
- termPtr++;
- } else if (*termPtr == '\0') {
+
/*
- * Missing ] at end of nested command.
+ * Check if the name contains any namespace qualifiers.
*/
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "missing close-bracket", -1);
- result = TCL_ERROR;
- }
- src = termPtr;
- if (result != TCL_OK) {
- goto done;
- }
- maxDepth = TclMax((numParts + envPtr->maxStackDepth), maxDepth);
- c = *src;
- type = CHAR_TYPE(src, lastChar);
- } else if (type & (TCL_SPACE | TCL_COMMAND_END)) {
- goto wordEnd;
- }
- numParts++;
- } /* end of infinite loop */
-
- wordEnd:
- /*
- * End of a non-simple word: TCL_SPACE, TCL_COMMAND_END, or
- * backslash-newline. Concatenate the word_parts if necessary.
- */
-
- while (numParts > 255) {
- TclEmitInstUInt1(INST_CONCAT1, 255, envPtr);
- numParts -= 254; /* concat pushes 1 obj, the result */
- }
- if (numParts > 1) {
- TclEmitInstUInt1(INST_CONCAT1, numParts, envPtr);
- }
-
- done:
- if (simpleWord) {
- envPtr->wordIsSimple = 1;
- envPtr->numSimpleWordChars = (src - string);
- } else {
- envPtr->wordIsSimple = 0;
- envPtr->numSimpleWordChars = 0;
- }
- envPtr->termOffset = (src - string);
- envPtr->maxStackDepth = maxDepth;
- envPtr->pushSimpleWords = savePushSimpleWords;
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileQuotes --
- *
- * This procedure compiles a double-quoted string such as a quoted Tcl
- * command argument or a quoted value in a Tcl expression. This
- * procedure is also used to compile array element names within
- * parentheses (where the termChar will be ')' instead of '"'), or
- * anything else that needs the substitutions that happen in quotes.
- *
- * Ordinarily, callers set envPtr->pushSimpleWords to 1 and
- * TclCompileQuotes always emits push and other instructions to compute
- * the word on the Tcl evaluation stack at execution time. If a caller
- * sets envPtr->pushSimpleWords to 0, TclCompileQuotes will not compile
- * "simple" words: words that are just a sequence of characters without
- * backslashes. It will leave their compilation up to the caller. This
- * is done to provide special support for the first word of commands,
- * which are almost always the (simple) name of a command.
- *
- * As an important special case, if the word is simple, this procedure
- * sets envPtr->wordIsSimple to 1 and envPtr->numSimpleWordChars to the
- * number of characters in the simple word. This allows the caller to
- * process these words specially.
- *
- * Results:
- * The return value is a standard Tcl result, which is TCL_OK unless
- * there was an error while parsing the quoted string. If an error
- * occurs then the interpreter's result contains a standard error
- * message.
- *
- * envPtr->termOffset is filled in with the offset of the character in
- * "string" just after the last one successfully processed; this is
- * usually the character just after the matching close-quote.
- *
- * envPtr->wordIsSimple is set 1 if the word is simple: just a
- * sequence of characters without backslashes. If so, the word's
- * characters are the envPtr->numSimpleWordChars characters starting
- * at string.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to evaluate the word. This is not changed if
- * the word is simple and envPtr->pushSimpleWords was 0 (false).
- *
- * Side effects:
- * Instructions are added to envPtr to push the quoted-string
- * at runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileQuotes(interp, string, lastChar, termChar, flags, envPtr)
- Tcl_Interp *interp; /* Interpreter to use for nested command
- * evaluations and error messages. */
- char *string; /* Points to the character just after
- * the opening '"' or '('. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int termChar; /* Character that terminates the "quoted"
- * string (usually double-quote, but might
- * be right-paren or something else). */
- int flags; /* Flags to control compilation (same
- * values passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds the resulting instructions. */
-{
- register char *src = string; /* Points to current source char. */
- register char c = *src; /* The current char. */
- int simpleWord = 0; /* Set 1 if a simple quoted string word. */
- char *start; /* Start position of char+ string_part. */
- int hasBackslash; /* 1 if '\' found in char+ string_part. */
- int numRead; /* Count of chars read by Tcl_Backslash. */
- int numParts = 0; /* Count of string_part objs pushed. */
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to compute and push the string. */
- char savedChar; /* Holds the character from string
- * termporarily replaced by a null
- * char during string_part processing. */
- int objIndex; /* The object array index for a pushed
- * object holding a string_part. */
- int numChars; /* Number of chars in string_part. */
- int savePushSimpleWords = envPtr->pushSimpleWords;
- int result = TCL_OK;
-
- /*
- * quoted_string: '"' string_part* '"' (or termChar instead of ")
- * string_part: var_reference | nested_cmd | char+
- */
-
+ name = tokenPtr[1].start;
+ nameBytes = tokenPtr[1].size;
+ hasNsQualifiers = 0;
+ for (i = 0, p = name; i < nameBytes; i++, p++) {
+ if ((*p == ':') && (i < (nameBytes-1))
+ && (*(p+1) == ':')) {
+ hasNsQualifiers = 1;
+ break;
+ }
+ }
- while ((src != lastChar) && (c != termChar)) {
- if (c == '$') {
- result = TclCompileDollarVar(interp, src, lastChar, flags,
- envPtr);
- src += envPtr->termOffset;
- if (result != TCL_OK) {
- goto done;
- }
- maxDepth = TclMax((numParts + envPtr->maxStackDepth), maxDepth);
- c = *src;
- } else if (c == '[') {
- char *termPtr;
- envPtr->pushSimpleWords = 1;
- src++;
- result = TclCompileString(interp, src, lastChar,
- (flags | TCL_BRACKET_TERM), envPtr);
- termPtr = (src + envPtr->termOffset);
- if (*termPtr == ']') {
- termPtr++;
- }
- src = termPtr;
- if (result != TCL_OK) {
- goto done;
- }
- if (termPtr == lastChar) {
/*
- * Missing ] at end of nested command.
+ * Either push the variable's name, or find its index in
+ * the array of local variables in a procedure frame.
*/
-
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "missing close-bracket", -1);
- result = TCL_ERROR;
- goto done;
- }
- maxDepth = TclMax((numParts + envPtr->maxStackDepth), maxDepth);
- c = *src;
- } else {
- /*
- * Start of a char+ string_part. Scan first looking for any
- * backslashes.
- */
- start = src;
- hasBackslash = 0;
- do {
- if (c == '\\') {
- hasBackslash = 1;
- Tcl_Backslash(src, &numRead);
- src += numRead;
+ depthForVar = 0;
+ if ((envPtr->procPtr == NULL) || hasNsQualifiers) {
+ localVar = -1;
+ TclEmitPush(TclRegisterLiteral(envPtr, name, nameBytes,
+ /*onHeap*/ 0), envPtr);
+ depthForVar = 1;
} else {
- src++;
+ localVar = TclFindCompiledLocal(name, nameBytes,
+ /*create*/ 0, /*flags*/ 0, envPtr->procPtr);
+ if (localVar < 0) {
+ TclEmitPush(TclRegisterLiteral(envPtr, name,
+ nameBytes, /*onHeap*/ 0), envPtr);
+ depthForVar = 1;
+ }
}
- c = *src;
- } while ((src != lastChar) && (c != '$') && (c != '[')
- && (c != termChar));
-
- if ((numParts == 0) && !hasBackslash
- && ((src == lastChar) && (c == termChar))) {
+
/*
- * The quoted string is "simple": just a sequence of
- * characters without backslashes terminated by termChar or
- * a null character. Just return if we are not to compile
- * simple words.
+ * Emit instructions to load the variable.
*/
-
- simpleWord = 1;
- if (!envPtr->pushSimpleWords) {
- if ((src == lastChar) && (termChar != '\0')) {
- char buf[40];
- sprintf(buf, "missing %c", termChar);
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
- result = TCL_ERROR;
+
+ if (tokenPtr->numComponents == 1) {
+ if (localVar < 0) {
+ TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);
+ } else if (localVar <= 255) {
+ TclEmitInstInt1(INST_LOAD_SCALAR1, localVar,
+ envPtr);
} else {
- src++;
+ TclEmitInstInt4(INST_LOAD_SCALAR4, localVar,
+ envPtr);
}
- envPtr->wordIsSimple = 1;
- envPtr->numSimpleWordChars = (src - string - 1);
- envPtr->termOffset = (src - string);
- envPtr->pushSimpleWords = savePushSimpleWords;
- return result;
- }
- }
-
- /*
- * Create and push a string object for the char+ string_part
- * that starts at "start" and ends at the char just before
- * src. If backslashes were found, copy the string_part's
- * characters with substituted backslashes into a heap-allocated
- * buffer and use it to create the string object. Temporarily
- * replace the terminating character with a null character.
- */
-
- numChars = (src - start);
- savedChar = start[numChars];
- start[numChars] = '\0';
- if ((numChars > 0) && (hasBackslash)) {
- char *buffer = ckalloc((unsigned) numChars + 1);
- register char *dst = buffer;
- register char *p = start;
- while (p < src) {
- if (*p == '\\') {
- *dst++ = Tcl_Backslash(p, &numRead);
- p += numRead;
+ } else {
+ code = TclCompileTokens(interp, tokenPtr+2,
+ tokenPtr->numComponents-1, envPtr);
+ if (code != TCL_OK) {
+ sprintf(buffer,
+ "\n (parsing index for array \"%.*s\")",
+ ((nameBytes > 100)? 100 : nameBytes), name);
+ Tcl_AddObjErrorInfo(interp, buffer, -1);
+ goto error;
+ }
+ depthForVar += envPtr->maxStackDepth;
+ if (localVar < 0) {
+ TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr);
+ } else if (localVar <= 255) {
+ TclEmitInstInt1(INST_LOAD_ARRAY1, localVar,
+ envPtr);
} else {
- *dst++ = *p++;
+ TclEmitInstInt4(INST_LOAD_ARRAY4, localVar,
+ envPtr);
}
}
- *dst = '\0';
- objIndex = TclObjIndexForString(buffer, (dst - buffer),
- /*allocStrRep*/ 1, /*inHeap*/ 1, envPtr);
- } else {
- objIndex = TclObjIndexForString(start, numChars,
- /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- }
- start[numChars] = savedChar;
- TclEmitPush(objIndex, envPtr);
- maxDepth = TclMax((numParts + 1), maxDepth);
- }
- numParts++;
- }
-
- /*
- * End of the quoted string: src points at termChar or '\0'. If
- * necessary, concatenate the string_part objects on the stack.
- */
-
- if ((src == lastChar) && (termChar != '\0')) {
- char buf[40];
- sprintf(buf, "missing %c", termChar);
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
- result = TCL_ERROR;
- goto done;
- } else {
- src++;
- }
-
- if (numParts == 0) {
- /*
- * The quoted string was empty. Push an empty string object.
- */
+ maxDepth = TclMax(numObjsToConcat + depthForVar, maxDepth);
+ numObjsToConcat++;
+ count -= tokenPtr->numComponents;
+ tokenPtr += tokenPtr->numComponents;
+ break;
- int objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0,
- /*inHeap*/ 0, envPtr);
- TclEmitPush(objIndex, envPtr);
- } else {
- /*
- * Emit any needed concat instructions.
- */
-
- while (numParts > 255) {
- TclEmitInstUInt1(INST_CONCAT1, 255, envPtr);
- numParts -= 254; /* concat pushes 1 obj, the result */
- }
- if (numParts > 1) {
- TclEmitInstUInt1(INST_CONCAT1, numParts, envPtr);
+ default:
+ panic("Unexpected token type in TclCompileTokens");
}
}
- done:
- if (simpleWord) {
- envPtr->wordIsSimple = 1;
- envPtr->numSimpleWordChars = (src - string - 1);
- } else {
- envPtr->wordIsSimple = 0;
- envPtr->numSimpleWordChars = 0;
- }
- envPtr->termOffset = (src - string);
- envPtr->maxStackDepth = maxDepth;
- envPtr->pushSimpleWords = savePushSimpleWords;
- return result;
-}
-
-/*
- *--------------------------------------------------------------
- *
- * CompileBraces --
- *
- * This procedure compiles characters between matching curly braces.
- *
- * Ordinarily, callers set envPtr->pushSimpleWords to 1 and
- * CompileBraces always emits a push instruction to compute the word on
- * the Tcl evaluation stack at execution time. However, if a caller
- * sets envPtr->pushSimpleWords to 0, CompileBraces will _not_ compile
- * "simple" words: words that are just a sequence of characters without
- * backslash-newlines. It will leave their compilation up to the
- * caller.
- *
- * As an important special case, if the word is simple, this procedure
- * sets envPtr->wordIsSimple to 1 and envPtr->numSimpleWordChars to the
- * number of characters in the simple word. This allows the caller to
- * process these words specially.
- *
- * Results:
- * The return value is a standard Tcl result, which is TCL_OK unless
- * there was an error while parsing string. If an error occurs then
- * the interpreter's result contains a standard error message.
- *
- * envPtr->termOffset is filled in with the offset of the character in
- * "string" just after the last one successfully processed. This is
- * usually the character just after the matching close-brace.
- *
- * envPtr->wordIsSimple is set 1 if the word is simple: just a
- * sequence of characters without backslash-newlines. If so, the word's
- * characters are the envPtr->numSimpleWordChars characters starting
- * at string.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to evaluate the word. This is not changed if
- * the word is simple and envPtr->pushSimpleWords was 0 (false).
- *
- * Side effects:
- * Instructions are added to envPtr to push the braced string
- * at runtime.
- *
- *--------------------------------------------------------------
- */
-
-static int
-CompileBraces(interp, string, lastChar, flags, envPtr)
- Tcl_Interp *interp; /* Interpreter to use for nested command
- * evaluations and error messages. */
- char *string; /* Character just after opening bracket. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int flags; /* Flags to control compilation (same
- * values passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds the resulting instructions. */
-{
- register char *src = string; /* Points to current source char. */
- register char c; /* The current char. */
- int simpleWord = 0; /* Set 1 if a simple braced string word. */
- int level = 1; /* {} nesting level. Initially 1 since {
- * was parsed before we were called. */
- int hasBackslashNewline = 0; /* Nonzero if '\' found. */
- char *last; /* Points just before terminating '}'. */
- int numChars; /* Number of chars in braced string. */
- char savedChar; /* Holds the character from string
- * termporarily replaced by a null
- * char during braced string processing. */
- int objIndex; /* The object array index for a pushed
- * object holding a braced string. */
- int numRead;
- int result = TCL_OK;
-
/*
- * Check for any backslash-newlines, since we must treat
- * backslash-newlines specially (they must be replaced by spaces).
+ * Push any accumulated characters appearing at the end.
*/
- while (1) {
- c = *src;
- if (src == lastChar) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "missing close-brace", -1);
- result = TCL_ERROR;
- goto done;
- }
- if (CHAR_TYPE(src, lastChar) != TCL_NORMAL) {
- if (c == '{') {
- level++;
- } else if (c == '}') {
- --level;
- if (level == 0) {
- src++;
- last = (src - 2); /* point just before terminating } */
- break;
- }
- } else if (c == '\\') {
- if (*(src+1) == '\n') {
- hasBackslashNewline = 1;
- }
- (void) Tcl_Backslash(src, &numRead);
- src += numRead - 1;
- }
- }
- src++;
- }
+ if (Tcl_DStringLength(&textBuffer) > 0) {
+ int literal;
- if (!hasBackslashNewline) {
- /*
- * The braced word is "simple": just a sequence of characters
- * without backslash-newlines. Just return if we are not to compile
- * simple words.
- */
-
- simpleWord = 1;
- if (!envPtr->pushSimpleWords) {
- envPtr->wordIsSimple = 1;
- envPtr->numSimpleWordChars = (src - string - 1);
- envPtr->termOffset = (src - string);
- return TCL_OK;
- }
+ literal = TclRegisterLiteral(envPtr, Tcl_DStringValue(&textBuffer),
+ Tcl_DStringLength(&textBuffer), /*onHeap*/ 0);
+ TclEmitPush(literal, envPtr);
+ numObjsToConcat++;
+ maxDepth = TclMax(numObjsToConcat, maxDepth);
}
/*
- * Create and push a string object for the braced string. This starts at
- * "string" and ends just after "last" (which points to the final
- * character before the terminating '}'). If backslash-newlines were
- * found, we copy characters one at a time into a heap-allocated buffer
- * and do backslash-newline substitutions.
+ * If necessary, concatenate the parts of the word.
*/
- numChars = (last - string + 1);
- savedChar = string[numChars];
- string[numChars] = '\0';
- if ((numChars > 0) && (hasBackslashNewline)) {
- char *buffer = ckalloc((unsigned) numChars + 1);
- register char *dst = buffer;
- register char *p = string;
- while (p <= last) {
- c = *dst++ = *p++;
- if (c == '\\') {
- if (*p == '\n') {
- dst[-1] = Tcl_Backslash(p-1, &numRead);
- p += numRead - 1;
- } else {
- (void) Tcl_Backslash(p-1, &numRead);
- while (numRead > 1) {
- *dst++ = *p++;
- numRead--;
- }
- }
- }
- }
- *dst = '\0';
- objIndex = TclObjIndexForString(buffer, (dst - buffer),
- /*allocStrRep*/ 1, /*inHeap*/ 1, envPtr);
- } else {
- objIndex = TclObjIndexForString(string, numChars, /*allocStrRep*/ 1,
- /*inHeap*/ 0, envPtr);
+ while (numObjsToConcat > 255) {
+ TclEmitInstInt1(INST_CONCAT1, 255, envPtr);
+ numObjsToConcat -= 254; /* concat pushes 1 obj, the result */
}
- string[numChars] = savedChar;
- TclEmitPush(objIndex, envPtr);
-
- done:
- if (simpleWord) {
- envPtr->wordIsSimple = 1;
- envPtr->numSimpleWordChars = (src - string - 1);
- } else {
- envPtr->wordIsSimple = 0;
- envPtr->numSimpleWordChars = 0;
- }
- envPtr->termOffset = (src - string);
- envPtr->maxStackDepth = 1;
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileDollarVar --
- *
- * Given a string starting with a $ sign, parse a variable name
- * and compile instructions to push its value. If the variable
- * reference is just a '$' (i.e. the '$' isn't followed by anything
- * that could possibly be a variable name), just push a string object
- * containing '$'.
- *
- * Results:
- * The return value is a standard Tcl result. If an error occurs
- * then an error message is left in the interpreter's result.
- *
- * envPtr->termOffset is filled in with the offset of the character in
- * "string" just after the last one in the variable reference.
- *
- * envPtr->wordIsSimple is set 0 (false) because the word is not
- * simple: it is not just a sequence of characters without backslashes.
- * For the same reason, envPtr->numSimpleWordChars is set 0.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the string's commands.
- *
- * Side effects:
- * Instructions are added to envPtr to look up the variable and
- * push its value at runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileDollarVar(interp, string, lastChar, flags, envPtr)
- Tcl_Interp *interp; /* Interpreter to use for nested command
- * evaluations and error messages. */
- char *string; /* First char (i.e. $) of var reference. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int flags; /* Flags to control compilation (same
- * values passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds the resulting instructions. */
-{
- register char *src = string; /* Points to current source char. */
- register char c; /* The current char. */
- char *name; /* Start of 1st part of variable name. */
- int nameChars; /* Count of chars in name. */
- int nameHasNsSeparators = 0; /* Set 1 if name contains "::"s. */
- char savedChar; /* Holds the character from string
- * termporarily replaced by a null
- * char during name processing. */
- int objIndex; /* The object array index for a pushed
- * object holding a name part. */
- int isArrayRef = 0; /* 1 if reference to array element. */
- int localIndex = -1; /* Frame index of local if found. */
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to push the variable. */
- int savePushSimpleWords = envPtr->pushSimpleWords;
- int result = TCL_OK;
-
- /*
- * var_reference: '$' '{' braced_name '}' |
- * '$' name ['(' index_string ')']
- *
- * There are three cases:
- * 1. The $ sign is followed by an open curly brace. Then the variable
- * name is everything up to the next close curly brace, and the
- * variable is a scalar variable.
- * 2. The $ sign is not followed by an open curly brace. Then the
- * variable name is everything up to the next character that isn't
- * a letter, digit, underscore, or a "::" namespace separator. If the
- * following character is an open parenthesis, then the information
- * between parentheses is the array element name, which can include
- * any of the substitutions permissible between quotes.
- * 3. The $ sign is followed by something that isn't a letter, digit,
- * underscore, or a "::" namespace separator: in this case,
- * there is no variable name, and "$" is pushed.
- */
-
- src++; /* advance over the '$'. */
-
- /*
- * Collect the first part of the variable's name into "name" and
- * determine if it is an array reference and if it contains any
- * namespace separator (::'s).
- */
-
- if (*src == '{') {
- /*
- * A scalar name in braces.
- */
-
- char *p;
-
- src++;
- name = src;
- c = *src;
- while (c != '}') {
- if (src == lastChar) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "missing close-brace for variable name", -1);
- result = TCL_ERROR;
- goto done;
- }
- src++;
- c = *src;
- }
- nameChars = (src - name);
- for (p = name; p < src; p++) {
- if ((*p == ':') && (*(p+1) == ':')) {
- nameHasNsSeparators = 1;
- break;
- }
- }
- src++; /* advance over the '}'. */
- } else {
- /*
- * Scalar name or array reference not in braces.
- */
-
- name = src;
- c = *src;
- while (isalnum(UCHAR(c)) || (c == '_') || (c == ':')) {
- if (c == ':') {
- if (*(src+1) == ':') {
- nameHasNsSeparators = 1;
- src += 2;
- while (*src == ':') {
- src++;
- }
- c = *src;
- } else {
- break; /* : by itself */
- }
- } else {
- src++;
- c = *src;
- }
- }
- if (src == name) {
- /*
- * A '$' by itself, not a name reference. Push a "$" string.
- */
-
- objIndex = TclObjIndexForString("$", 1, /*allocStrRep*/ 1,
- /*inHeap*/ 0, envPtr);
- TclEmitPush(objIndex, envPtr);
- maxDepth = 1;
- goto done;
- }
- nameChars = (src - name);
- isArrayRef = (c == '(');
+ if (numObjsToConcat > 1) {
+ TclEmitInstInt1(INST_CONCAT1, numObjsToConcat, envPtr);
}
/*
- * Now emit instructions to load the variable. First either push the
- * name of the scalar or array, or determine its index in the array of
- * local variables in a procedure frame. Push the name if we are not
- * compiling a procedure body or if the name has namespace
- * qualifiers ("::"s).
+ * If the tokens yielded no instructions, push an empty string.
*/
- if (!isArrayRef) { /* scalar reference */
- if ((envPtr->procPtr == NULL) || nameHasNsSeparators) {
- savedChar = name[nameChars];
- name[nameChars] = '\0';
- objIndex = TclObjIndexForString(name, nameChars,
- /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- name[nameChars] = savedChar;
- TclEmitPush(objIndex, envPtr);
- TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);
- maxDepth = 1;
- } else {
- localIndex = LookupCompiledLocal(name, nameChars,
- /*createIfNew*/ 0, /*flagsIfCreated*/ 0,
- envPtr->procPtr);
- if (localIndex >= 0) {
- if (localIndex <= 255) {
- TclEmitInstUInt1(INST_LOAD_SCALAR1, localIndex, envPtr);
- } else {
- TclEmitInstUInt4(INST_LOAD_SCALAR4, localIndex, envPtr);
- }
- maxDepth = 0;
- } else {
- savedChar = name[nameChars];
- name[nameChars] = '\0';
- objIndex = TclObjIndexForString(name, nameChars,
- /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- name[nameChars] = savedChar;
- TclEmitPush(objIndex, envPtr);
- TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);
- maxDepth = 1;
- }
- }
- } else { /* array reference */
- if ((envPtr->procPtr == NULL) || nameHasNsSeparators) {
- savedChar = name[nameChars];
- name[nameChars] = '\0';
- objIndex = TclObjIndexForString(name, nameChars,
- /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- name[nameChars] = savedChar;
- TclEmitPush(objIndex, envPtr);
- maxDepth = 1;
- } else {
- localIndex = LookupCompiledLocal(name, nameChars,
- /*createIfNew*/ 0, /*flagsIfCreated*/ 0,
- envPtr->procPtr);
- if (localIndex < 0) {
- savedChar = name[nameChars];
- name[nameChars] = '\0';
- objIndex = TclObjIndexForString(name, nameChars,
- /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- name[nameChars] = savedChar;
- TclEmitPush(objIndex, envPtr);
- maxDepth = 1;
- }
- }
-
- /*
- * Parse and push the array element. Perform substitutions on it,
- * just as is done for quoted strings.
- */
-
- src++;
- envPtr->pushSimpleWords = 1;
- result = TclCompileQuotes(interp, src, lastChar, ')', flags,
- envPtr);
- src += envPtr->termOffset;
- if (result != TCL_OK) {
- char msg[200];
- sprintf(msg, "\n (parsing index for array \"%.*s\")",
- (nameChars > 100? 100 : nameChars), name);
- Tcl_AddObjErrorInfo(interp, msg, -1);
- goto done;
- }
- maxDepth += envPtr->maxStackDepth;
-
- /*
- * Now emit the appropriate load instruction for the array element.
- */
-
- if (localIndex < 0) { /* a global or an unknown local */
- TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr);
- } else {
- if (localIndex <= 255) {
- TclEmitInstUInt1(INST_LOAD_ARRAY1, localIndex, envPtr);
- } else {
- TclEmitInstUInt4(INST_LOAD_ARRAY4, localIndex, envPtr);
- }
- }
+ if (envPtr->codeNext == entryCodeNext) {
+ TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*alreadyAlloced*/ 0),
+ envPtr);
+ maxDepth = 1;
}
-
- done:
- envPtr->termOffset = (src - string);
- envPtr->wordIsSimple = 0;
- envPtr->numSimpleWordChars = 0;
+ Tcl_DStringFree(&textBuffer);
envPtr->maxStackDepth = maxDepth;
- envPtr->pushSimpleWords = savePushSimpleWords;
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * IsLocalScalar --
- *
- * Checks to see if a variable name refers to a local scalar.
- *
- * Results:
- * Returns 1 if the variable is a local scalar.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-IsLocalScalar(varName, length)
- char *varName; /* The name to check. */
- int length; /* The number of characters in the string. */
-{
- char *p;
- char *lastChar = varName + (length - 1);
-
- for (p = varName; p <= lastChar; p++) {
- if ((CHAR_TYPE(p, lastChar) != TCL_NORMAL) &&
- (CHAR_TYPE(p, lastChar) != TCL_COMMAND_END)) {
- /*
- * TCL_COMMAND_END is returned for the last character
- * of the string. By this point we know it isn't
- * an array or namespace reference.
- */
-
- return 0;
- }
- if (*p == '(') {
- if (*lastChar == ')') { /* we have an array element */
- return 0;
- }
- } else if (*p == ':') {
- if ((p != lastChar) && *(p+1) == ':') { /* qualified name */
- return 0;
- }
- }
- }
-
- return 1;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileBreakCmd --
- *
- * Procedure called to compile the "break" command.
- *
- * Results:
- * The return value is a standard Tcl result, which is TCL_OK unless
- * there was an error while parsing string. If an error occurs then
- * the interpreter's result contains a standard error message.
- *
- * envPtr->termOffset is filled in with the offset of the character in
- * "string" just after the last one successfully processed.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the command.
- *
- * Side effects:
- * Instructions are added to envPtr to evaluate the "break" command
- * at runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileBreakCmd(interp, string, lastChar, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- char *string; /* The source string to compile. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds resulting instructions. */
-{
- register char *src = string;/* Points to current source char. */
- register int type; /* Current char's CHAR_TYPE type. */
- int result = TCL_OK;
-
- /*
- * There should be no argument after the "break".
- */
-
- type = CHAR_TYPE(src, lastChar);
- if (type != TCL_COMMAND_END) {
- AdvanceToNextWord(src, envPtr);
- src += envPtr->termOffset;
- type = CHAR_TYPE(src, lastChar);
- if (type != TCL_COMMAND_END) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: should be \"break\"", -1);
- result = TCL_ERROR;
- goto done;
- }
- }
-
- /*
- * Emit a break instruction.
- */
-
- TclEmitOpcode(INST_BREAK, envPtr);
+ return TCL_OK;
- done:
- envPtr->termOffset = (src - string);
- envPtr->maxStackDepth = 0;
- return result;
+ error:
+ Tcl_DStringFree(&textBuffer);
+ envPtr->maxStackDepth = maxDepth;
+ return code;
}
/*
*----------------------------------------------------------------------
*
- * TclCompileCatchCmd --
+ * TclCompileCmdWord --
*
- * Procedure called to compile the "catch" command.
+ * Given an array of parse tokens for a word containing one or more Tcl
+ * commands, emit inline instructions to execute them. This procedure
+ * differs from TclCompileTokens in that a simple word such as a loop
+ * body enclosed in braces is not just pushed as a string, but is
+ * itself parsed into tokens and compiled.
*
* Results:
- * The return value is a standard Tcl result, which is TCL_OK if
- * compilation was successful. If an error occurs then the
- * interpreter's result contains a standard error message and TCL_ERROR
- * is returned. If compilation failed because the command is too
- * complex for TclCompileCatchCmd, TCL_OUT_LINE_COMPILE is returned
- * indicating that the catch command should be compiled "out of line"
- * by emitting code to invoke its command procedure at runtime.
- *
- * envPtr->termOffset is filled in with the offset of the character in
- * "string" just after the last one successfully processed.
- *
+ * The return value is a standard Tcl result. If an error occurs, an
+ * error message is left in the interpreter's result.
+ *
* envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the command.
+ * elements needed to execute the tokens.
*
* Side effects:
- * Instructions are added to envPtr to evaluate the "catch" command
- * at runtime.
+ * Instructions are added to envPtr to execute the tokens at runtime.
*
*----------------------------------------------------------------------
*/
int
-TclCompileCatchCmd(interp, string, lastChar, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- char *string; /* The source string to compile. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds resulting instructions. */
+TclCompileCmdWord(interp, tokenPtr, count, envPtr)
+ Tcl_Interp *interp; /* Used for error and status reporting. */
+ Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens
+ * for a command word to compile inline. */
+ int count; /* Number of tokens to consider at tokenPtr.
+ * Must be at least 1. */
+ CompileEnv *envPtr; /* Holds the resulting instructions. */
{
- Proc *procPtr = envPtr->procPtr;
- /* Points to structure describing procedure
- * containing the catch cmd, else NULL. */
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to execute cmd. */
- ArgInfo argInfo; /* Structure holding information about the
- * start and end of each argument word. */
- int range = -1; /* If we compile the catch command, the
- * index for its catch range record in the
- * ExceptionRange array. -1 if we are not
- * compiling the command. */
- char *name; /* If a var name appears for a scalar local
- * to a procedure, this points to the name's
- * 1st char and nameChars is its length. */
- int nameChars; /* Length of the variable name, if any. */
- int localIndex = -1; /* Index of the variable in the current
- * procedure's array of local variables.
- * Otherwise -1 if not in a procedure or
- * the variable wasn't found. */
- char savedChar; /* Holds the character from string
- * termporarily replaced by a null character
- * during processing of words. */
- JumpFixup jumpFixup; /* Used to emit the jump after the "no
- * errors" epilogue code. */
- int numWords, objIndex, jumpDist, result;
- char *bodyStart, *bodyEnd;
- Tcl_Obj *objPtr;
- int savePushSimpleWords = envPtr->pushSimpleWords;
-
- /*
- * Scan the words of the command and record the start and finish of
- * each argument word.
- */
-
- InitArgInfo(&argInfo);
- result = CollectArgInfo(interp, string, lastChar, flags, &argInfo);
- numWords = argInfo.numArgs; /* i.e., the # after the command name */
- if (result != TCL_OK) {
- goto done;
- }
- if ((numWords != 1) && (numWords != 2)) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: should be \"catch command ?varName?\"", -1);
- result = TCL_ERROR;
- goto done;
- }
-
- /*
- * If a variable was specified and the catch command is at global level
- * (not in a procedure), don't compile it inline: the payoff is
- * too small.
- */
-
- if ((numWords == 2) && (procPtr == NULL)) {
- result = TCL_OUT_LINE_COMPILE;
- goto done;
- }
-
- /*
- * Make sure the variable name, if any, has no substitutions and just
- * refers to a local scaler.
- */
-
- if (numWords == 2) {
- char *firstChar = argInfo.startArray[1];
- char *lastChar = argInfo.endArray[1];
-
- if (*firstChar == '{') {
- if (*lastChar != '}') {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "extra characters after close-brace", -1);
- result = TCL_ERROR;
- goto done;
- }
- firstChar++;
- lastChar--;
- }
-
- nameChars = (lastChar - firstChar + 1);
- if (!IsLocalScalar(firstChar, nameChars)) {
- result = TCL_OUT_LINE_COMPILE;
- goto done;
- }
-
- name = firstChar;
- localIndex = LookupCompiledLocal(name, nameChars,
- /*createIfNew*/ 1, /*flagsIfCreated*/ VAR_SCALAR,
- procPtr);
- }
+ int code;
/*
- *==== At this point we believe we can compile the catch command ====
+ * Handle the common case: if there is a single text token, compile it
+ * into an inline sequence of instructions.
*/
-
- /*
- * Create and initialize a ExceptionRange record to hold information
- * about this catch command.
- */
-
- envPtr->excRangeDepth++;
- envPtr->maxExcRangeDepth =
- TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth);
- range = CreateExceptionRange(CATCH_EXCEPTION_RANGE, envPtr);
-
- /*
- * Emit the instruction to mark the start of the catch command.
- */
-
- TclEmitInstUInt4(INST_BEGIN_CATCH4, range, envPtr);
-
- /*
- * Inline compile the catch's body word: the command it controls. Also
- * register the body's starting PC offset and byte length in the
- * ExceptionRange record.
- */
-
- envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset();
-
- bodyStart = argInfo.startArray[0];
- bodyEnd = argInfo.endArray[0];
- savedChar = *(bodyEnd+1);
- *(bodyEnd+1) = '\0';
- result = CompileCmdWordInline(interp, bodyStart, (bodyEnd+1),
- flags, envPtr);
- *(bodyEnd+1) = savedChar;
-
- if (result != TCL_OK) {
- if (result == TCL_ERROR) {
- char msg[60];
- sprintf(msg, "\n (\"catch\" body line %d)",
- interp->errorLine);
- Tcl_AddObjErrorInfo(interp, msg, -1);
- }
- goto done;
- }
- maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
- envPtr->excRangeArrayPtr[range].numCodeBytes =
- TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset;
-
- /*
- * Now emit the "no errors" epilogue code for the catch. First, if a
- * variable was specified, store the body's result into the
- * variable; otherwise, just discard the body's result. Then push
- * a "0" object as the catch command's "no error" TCL_OK result,
- * and jump around the "error case" epilogue code.
- */
-
- if (localIndex != -1) {
- if (localIndex <= 255) {
- TclEmitInstUInt1(INST_STORE_SCALAR1, localIndex, envPtr);
- } else {
- TclEmitInstUInt4(INST_STORE_SCALAR4, localIndex, envPtr);
- }
- }
- TclEmitOpcode(INST_POP, envPtr);
-
- objIndex = TclObjIndexForString("0", 1, /*allocStrRep*/ 0, /*inHeap*/ 0,
- envPtr);
- objPtr = envPtr->objArrayPtr[objIndex];
- Tcl_InvalidateStringRep(objPtr);
- objPtr->internalRep.longValue = 0;
- objPtr->typePtr = &tclIntType;
-
- TclEmitPush(objIndex, envPtr);
- if (maxDepth == 0) {
- maxDepth = 1; /* since we just pushed one object */
- }
-
- TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
-
- /*
- * Now emit the "error case" epilogue code. First, if a variable was
- * specified, emit instructions to push the interpreter's object result
- * and store it into the variable. Then emit an instruction to push the
- * nonzero error result. Note that the initial PC offset here is the
- * catch's error target.
- */
-
- envPtr->excRangeArrayPtr[range].catchOffset = TclCurrCodeOffset();
- if (localIndex != -1) {
- TclEmitOpcode(INST_PUSH_RESULT, envPtr);
- if (localIndex <= 255) {
- TclEmitInstUInt1(INST_STORE_SCALAR1, localIndex, envPtr);
- } else {
- TclEmitInstUInt4(INST_STORE_SCALAR4, localIndex, envPtr);
- }
- TclEmitOpcode(INST_POP, envPtr);
- }
- TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr);
-
- /*
- * Now that we know the target of the jump after the "no errors"
- * epilogue, update it with the correct distance. This is less
- * than 127 bytes.
- */
-
- jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset);
- if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) {
- panic("TclCompileCatchCmd: bad jump distance %d\n", jumpDist);
+ envPtr->maxStackDepth = 0;
+ if ((count == 1) && (tokenPtr->type == TCL_TOKEN_TEXT)) {
+ code = TclCompileScript(interp, tokenPtr->start, tokenPtr->size,
+ /*nested*/ 0, envPtr);
+ return code;
}
/*
- * Emit the instruction to mark the end of the catch command.
+ * Multiple tokens or the single token involves substitutions. Emit
+ * instructions to invoke the eval command procedure at runtime on the
+ * result of evaluating the tokens.
*/
- TclEmitOpcode(INST_END_CATCH, envPtr);
-
- done:
- if (numWords == 0) {
- envPtr->termOffset = 0;
- } else {
- envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string);
+ code = TclCompileTokens(interp, tokenPtr, count, envPtr);
+ if (code != TCL_OK) {
+ return code;
}
- if (range != -1) { /* we compiled the catch command */
- envPtr->excRangeDepth--;
- }
- envPtr->pushSimpleWords = savePushSimpleWords;
- envPtr->maxStackDepth = maxDepth;
- FreeArgInfo(&argInfo);
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileContinueCmd --
- *
- * Procedure called to compile the "continue" command.
- *
- * Results:
- * The return value is a standard Tcl result, which is TCL_OK unless
- * there was an error while parsing string. If an error occurs then
- * the interpreter's result contains a standard error message.
- *
- * envPtr->termOffset is filled in with the offset of the character in
- * "string" just after the last one successfully processed.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the command.
- *
- * Side effects:
- * Instructions are added to envPtr to evaluate the "continue" command
- * at runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileContinueCmd(interp, string, lastChar, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- char *string; /* The source string to compile. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds resulting instructions. */
-{
- register char *src = string;/* Points to current source char. */
- register int type; /* Current char's CHAR_TYPE type. */
- int result = TCL_OK;
-
- /*
- * There should be no argument after the "continue".
- */
-
- type = CHAR_TYPE(src, lastChar);
- if (type != TCL_COMMAND_END) {
- AdvanceToNextWord(src, envPtr);
- src += envPtr->termOffset;
- type = CHAR_TYPE(src, lastChar);
- if (type != TCL_COMMAND_END) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: should be \"continue\"", -1);
- result = TCL_ERROR;
- goto done;
- }
- }
-
- /*
- * Emit a continue instruction.
- */
-
- TclEmitOpcode(INST_CONTINUE, envPtr);
-
- done:
- envPtr->termOffset = (src - string);
- envPtr->maxStackDepth = 0;
- return result;
+ TclEmitOpcode(INST_EVAL_STK, envPtr);
+ return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * TclCompileExprCmd --
+ * TclCompileExprWords --
*
- * Procedure called to compile the "expr" command.
+ * Given an array of parse tokens representing one or more words that
+ * contain a Tcl expression, emit inline instructions to execute the
+ * expression. This procedure differs from TclCompileExpr in that it
+ * supports Tcl's two-level substitution semantics for expressions that
+ * appear as command words.
*
* Results:
- * The return value is a standard Tcl result, which is TCL_OK
- * unless there was an error while parsing string. If an error occurs
- * then the interpreter's result contains a standard error message.
- *
- * envPtr->termOffset is filled in with the offset of the character in
- * "string" just after the last one successfully processed.
- *
+ * The return value is a standard Tcl result. If an error occurs, an
+ * error message is left in the interpreter's result.
+ *
* envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the "expr" command.
+ * elements needed to execute the expression.
*
* Side effects:
- * Instructions are added to envPtr to evaluate the "expr" command
- * at runtime.
+ * Instructions are added to envPtr to execute the expression.
*
*----------------------------------------------------------------------
*/
int
-TclCompileExprCmd(interp, string, lastChar, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- char *string; /* The source string to compile. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds resulting instructions. */
+TclCompileExprWords(interp, tokenPtr, numWords, envPtr)
+ Tcl_Interp *interp; /* Used for error and status reporting. */
+ Tcl_Token *tokenPtr; /* Points to first in an array of word
+ * tokens tokens for the expression to
+ * compile inline. */
+ int numWords; /* Number of word tokens starting at
+ * tokenPtr. Must be at least 1. Each word
+ * token contains one or more subtokens. */
+ CompileEnv *envPtr; /* Holds the resulting instructions. */
{
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to execute cmd. */
- ArgInfo argInfo; /* Structure holding information about the
- * start and end of each argument word. */
- Tcl_DString buffer; /* Holds the concatenated expr command
- * argument words. */
- int firstWord; /* 1 if processing the first word; 0 if
- * processing subsequent words. */
- char *first, *last; /* Points to the first and last significant
- * chars of the concatenated expression. */
- int inlineCode; /* 1 if inline "optimistic" code is
- * emitted for the expression; else 0. */
- int range = -1; /* If we inline compile the concatenated
- * expression, the index for its catch range
- * record in the ExceptionRange array.
- * Initialized to avoid compile warning. */
- JumpFixup jumpFixup; /* Used to emit the "success" jump after
- * the inline concat. expression's code. */
- char savedChar; /* Holds the character termporarily replaced
- * by a null character during compilation
- * of the concatenated expression. */
- int numWords, objIndex, i, result;
- char *wordStart, *wordEnd, *p;
- char c;
- int savePushSimpleWords = envPtr->pushSimpleWords;
+ Tcl_Token *wordPtr, *partPtr;
+ JumpFixup jumpFixup;
+ int maxDepth, doExprInline, range, numBytes, i, j, code;
+ char *script;
+ char saveChar;
int saveExprIsJustVarRef = envPtr->exprIsJustVarRef;
int saveExprIsComparison = envPtr->exprIsComparison;
- /*
- * Scan the words of the command and record the start and finish of
- * each argument word.
- */
-
- InitArgInfo(&argInfo);
- result = CollectArgInfo(interp, string, lastChar, flags, &argInfo);
- numWords = argInfo.numArgs; /* i.e., the # after the command name */
- if (result != TCL_OK) {
- goto done;
- }
- if (numWords == 0) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: should be \"expr arg ?arg ...?\"", -1);
- result = TCL_ERROR;
- goto done;
- }
+ envPtr->maxStackDepth = 0;
+ maxDepth = 0;
+ range = -1;
+ code = TCL_OK;
/*
- * If there is a single argument word and it is enclosed in {}s, we may
- * strip them off and safely compile the expr command into an inline
- * sequence of instructions using TclCompileExpr. We know these
- * instructions will have the right Tcl7.x expression semantics.
- *
- * Otherwise, if the word is not enclosed in {}s, or there are multiple
- * words, we may need to call the expr command (Tcl_ExprObjCmd) at
- * runtime. This recompiles the expression each time (typically) and so
- * is slow. However, there are some circumstances where we can still
- * compile inline instructions "optimistically" and check, during their
- * execution, for double substitutions (these appear as nonnumeric
- * operands). We check for any backslash or command substitutions. If
- * none appear, and only variable substitutions are found, we generate
- * inline instructions. If there is a compilation error, we must emit
- * instructions that return the error at runtime, since this is when
- * scripts in Tcl7.x would "see" the error.
- *
- * For now, if there are multiple words, or the single argument word is
- * not in {}s, we concatenate the argument words and strip off any
- * enclosing {}s or ""s. We call the expr command at runtime if
- * either command or backslash substitutions appear (but not if
- * only variable substitutions appear).
+ * If the expression is a single word that doesn't require
+ * substitutions, just compile it's string into inline instructions.
*/
- if (numWords == 1) {
- wordStart = argInfo.startArray[0]; /* start of 1st arg word */
- wordEnd = argInfo.endArray[0]; /* last char of 1st arg word */
- if ((*wordStart == '{') && (*wordEnd == '}')) {
- /*
- * Simple case: a single argument word in {}'s.
- */
+ if ((numWords == 1) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) {
+ /*
+ * Temporarily overwrite the character just after the end of the
+ * string with a 0 byte.
+ */
- *wordEnd = '\0';
- result = TclCompileExpr(interp, (wordStart + 1), wordEnd,
- flags, envPtr);
- *wordEnd = '}';
-
- envPtr->termOffset = (wordEnd + 1) - string;
- envPtr->pushSimpleWords = savePushSimpleWords;
- FreeArgInfo(&argInfo);
- return result;
- }
+ script = tokenPtr[1].start;
+ numBytes = tokenPtr[1].size;
+ saveChar = script[numBytes];
+ script[numBytes] = 0;
+ code = TclCompileExpr(interp, script, numBytes, envPtr);
+ script[numBytes] = saveChar;
+ return code;
}
/*
- * There are multiple words or no braces around the single word.
- * Concatenate the expression's argument words while stripping off
- * any enclosing {}s or ""s.
- */
-
- Tcl_DStringInit(&buffer);
- firstWord = 1;
- for (i = 0; i < numWords; i++) {
- wordStart = argInfo.startArray[i];
- wordEnd = argInfo.endArray[i];
- if (((*wordStart == '{') && (*wordEnd == '}'))
- || ((*wordStart == '"') && (*wordEnd == '"'))) {
- wordStart++;
- wordEnd--;
- }
- if (!firstWord) {
- Tcl_DStringAppend(&buffer, " ", 1);
- }
- firstWord = 0;
- if (wordEnd >= wordStart) {
- Tcl_DStringAppend(&buffer, wordStart, (wordEnd-wordStart+1));
+ * Multiple words or the single word requires substitutions. We may
+ * need to call expr's command proc at runtime. This often recompiles
+ * the expression each time and is slow. However, there are some
+ * circumstances where we can still compile inline code "optimistically"
+ * and check for type errors during execution that signal when double
+ * substitutions must be done.
+ */
+
+ doExprInline = 1;
+ wordPtr = tokenPtr;
+ for (i = 0; ((i < numWords) && doExprInline); i++) {
+ if (wordPtr->type == TCL_TOKEN_WORD) {
+ for (j = 0, partPtr = wordPtr+1; j < wordPtr->numComponents;
+ j++, partPtr++) {
+ if ((partPtr->type == TCL_TOKEN_BS)
+ || (partPtr->type == TCL_TOKEN_COMMAND)) {
+ doExprInline = 0;
+ break;
+ }
+ }
}
+ wordPtr += (wordPtr->numComponents + 1);
}
/*
- * Scan the concatenated expression's characters looking for any
- * '['s or '\'s or '$'s. If any are found, just call the expr cmd
- * at runtime.
+ * If only variable substitutions appear (no backslash or command
+ * substitutions), inline compile the expr inside a "catch" so that if
+ * there is any error, we call expr's command proc at runtime.
*/
- inlineCode = 1;
- first = Tcl_DStringValue(&buffer);
- last = first + (Tcl_DStringLength(&buffer) - 1);
- for (p = first; p <= last; p++) {
- c = *p;
- if ((c == '[') || (c == '\\') || (c == '$')) {
- inlineCode = 0;
- break;
- }
- }
-
- if (inlineCode) {
- /*
- * Inline compile the concatenated expression inside a "catch"
- * so that a runtime error will back off to a (slow) call on expr.
- */
-
+ if (doExprInline) {
+ Tcl_DString exprBuffer;
int startCodeOffset = (envPtr->codeNext - envPtr->codeStart);
- int startRangeNext = envPtr->excRangeArrayNext;
-
- /*
- * Create a ExceptionRange record to hold information about the
- * "catch" range for the expression's inline code. Also emit the
- * instruction to mark the start of the range.
- */
-
- envPtr->excRangeDepth++;
- envPtr->maxExcRangeDepth =
- TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth);
- range = CreateExceptionRange(CATCH_EXCEPTION_RANGE, envPtr);
- TclEmitInstUInt4(INST_BEGIN_CATCH4, range, envPtr);
-
- /*
- * Inline compile the concatenated expression.
- */
-
- envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset();
- savedChar = *(last + 1);
- *(last + 1) = '\0';
- result = TclCompileExpr(interp, first, last + 1, flags, envPtr);
- *(last + 1) = savedChar;
+ int startExceptNext = envPtr->exceptArrayNext;
+ envPtr->exceptDepth++;
+ envPtr->maxExceptDepth =
+ TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
+ range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
+ TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr);
+
+ Tcl_DStringInit(&exprBuffer);
+ wordPtr = tokenPtr;
+ for (i = 0; i < numWords; i++) {
+ if (i > 0) {
+ Tcl_DStringAppend(&exprBuffer, " ", 1);
+ }
+ for (j = 0, partPtr = wordPtr+1; j < wordPtr->numComponents;
+ j++, partPtr++) {
+ switch (partPtr->type) {
+ case TCL_TOKEN_TEXT:
+ Tcl_DStringAppend(&exprBuffer, partPtr->start,
+ partPtr->size);
+ break;
+
+ case TCL_TOKEN_VARIABLE:
+ Tcl_DStringAppend(&exprBuffer, partPtr->start,
+ partPtr->size);
+ j += partPtr->numComponents;
+ partPtr += partPtr->numComponents;
+ break;
+
+ default:
+ panic("unexpected token type in TclCompileExprWords");
+ }
+ }
+ wordPtr += (wordPtr->numComponents + 1);
+ }
+ envPtr->exceptArrayPtr[range].codeOffset =
+ (envPtr->codeNext - envPtr->codeStart);
+ code = TclCompileExpr(interp, Tcl_DStringValue(&exprBuffer),
+ Tcl_DStringLength(&exprBuffer), envPtr);
+ envPtr->exceptArrayPtr[range].numCodeBytes =
+ (envPtr->codeNext - envPtr->codeStart)
+ - envPtr->exceptArrayPtr[range].codeOffset;
maxDepth = envPtr->maxStackDepth;
- envPtr->excRangeArrayPtr[range].numCodeBytes =
- TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset;
+ Tcl_DStringFree(&exprBuffer);
- if ((result != TCL_OK) || (envPtr->exprIsJustVarRef)
+ if ((code != TCL_OK) || (envPtr->exprIsJustVarRef)
|| (envPtr->exprIsComparison)) {
/*
- * We must call the expr command at runtime. Either there was a
- * compilation error or the inline code might fail to give the
- * correct 2 level substitution semantics.
- *
- * The latter can happen if the expression consisted of just a
- * single variable reference or if the top-level operator in the
- * expr is a comparison (which might operate on strings). In the
- * latter case, the expression's code might execute (apparently)
- * successfully but produce the wrong result. We depend on its
- * execution failing if a second level of substitutions is
- * required. This causes the "catch" code we generate around the
- * inline code to back off to a call on the expr command at
- * runtime, and this always gives the right 2 level substitution
- * semantics.
- *
- * We delete the inline code by backing up the code pc and catch
- * index. Note that if there was a compilation error, we can't
- * report the error yet since the expression might be valid
- * after the second round of substitutions.
+ * Delete the inline code and call the expr command proc at
+ * runtime. There was a compilation error or the inline code
+ * might not have the right 2 level substitution semantics:
+ * e.g., if the expr consisted of a single variable ref or the
+ * top-level operator is a comparison (which might operate on
+ * strings). The code might appear to execute successfully but
+ * produce the wrong result. We depend on execution failing if a
+ * second level of substitutions is required.
*/
envPtr->codeNext = (envPtr->codeStart + startCodeOffset);
- envPtr->excRangeArrayNext = startRangeNext;
- inlineCode = 0;
+ envPtr->exceptArrayNext = startExceptNext;
+ doExprInline = 0;
} else {
TclEmitOpcode(INST_END_CATCH, envPtr); /* for ok case */
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
- envPtr->excRangeArrayPtr[range].catchOffset = TclCurrCodeOffset();
+ envPtr->exceptArrayPtr[range].catchOffset =
+ (envPtr->codeNext - envPtr->codeStart);
TclEmitOpcode(INST_END_CATCH, envPtr); /* for error case */
}
}
/*
- * Emit code for the (slow) call on the expr command at runtime.
- * Generate code to concatenate the (already substituted once)
- * expression words with a space between each word.
+ * Emit code to call the expr command proc at runtime. Concatenate the
+ * (already substituted once) expr tokens with a space between each.
*/
-
+
+ wordPtr = tokenPtr;
for (i = 0; i < numWords; i++) {
- wordStart = argInfo.startArray[i];
- wordEnd = argInfo.endArray[i];
- savedChar = *(wordEnd + 1);
- *(wordEnd + 1) = '\0';
- envPtr->pushSimpleWords = 1;
- result = CompileWord(interp, wordStart, wordEnd+1, flags, envPtr);
- *(wordEnd + 1) = savedChar;
- if (result != TCL_OK) {
+ code = TclCompileTokens(interp, wordPtr+1, wordPtr->numComponents,
+ envPtr);
+ if (code != TCL_OK) {
break;
}
- if (i != (numWords - 1)) {
- objIndex = TclObjIndexForString(" ", 1, /*allocStrRep*/ 1,
- /*inHeap*/ 0, envPtr);
- TclEmitPush(objIndex, envPtr);
+ if (i < (numWords - 1)) {
+ TclEmitPush(TclRegisterLiteral(envPtr, " ", 1, /*onHeap*/ 0),
+ envPtr);
maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
} else {
maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
}
+ wordPtr += (wordPtr->numComponents + 1);
}
- if (result == TCL_OK) {
+ if (code == TCL_OK) {
int concatItems = 2*numWords - 1;
while (concatItems > 255) {
- TclEmitInstUInt1(INST_CONCAT1, 255, envPtr);
- concatItems -= 254; /* concat pushes 1 obj, the result */
+ TclEmitInstInt1(INST_CONCAT1, 255, envPtr);
+ concatItems -= 254;
}
if (concatItems > 1) {
- TclEmitInstUInt1(INST_CONCAT1, concatItems, envPtr);
+ TclEmitInstInt1(INST_CONCAT1, concatItems, envPtr);
}
TclEmitOpcode(INST_EXPR_STK, envPtr);
}
/*
- * If emitting inline code, update the target of the jump after
- * that inline code.
+ * If generating inline code, update the target of the jump at the end.
*/
- if (inlineCode) {
- int jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset);
+ if (doExprInline) {
+ int jumpDist = (envPtr->codeNext - envPtr->codeStart)
+ - jumpFixup.codeOffset;
if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) {
/*
* Update the inline expression code's catch ExceptionRange
* target since it, being after the jump, also moved down.
*/
- envPtr->excRangeArrayPtr[range].catchOffset += 3;
+ envPtr->exceptArrayPtr[range].catchOffset += 3;
}
+ envPtr->exceptDepth--;
}
- Tcl_DStringFree(&buffer);
- done:
- if (numWords == 0) {
- envPtr->termOffset = 0;
- } else {
- envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string);
- }
- if (range != -1) { /* we inline compiled the expr */
- envPtr->excRangeDepth--;
- }
- envPtr->pushSimpleWords = savePushSimpleWords;
envPtr->exprIsJustVarRef = saveExprIsJustVarRef;
envPtr->exprIsComparison = saveExprIsComparison;
envPtr->maxStackDepth = maxDepth;
- FreeArgInfo(&argInfo);
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileForCmd --
- *
- * Procedure called to compile the "for" command.
- *
- * Results:
- * The return value is a standard Tcl result, which is TCL_OK unless
- * there was an error while parsing string. If an error occurs then
- * the interpreter's result contains a standard error message.
- *
- * envPtr->termOffset is filled in with the offset of the character in
- * "string" just after the last one successfully processed.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the command.
- *
- * Side effects:
- * Instructions are added to envPtr to evaluate the "for" command
- * at runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileForCmd(interp, string, lastChar, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- char *string; /* The source string to compile. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds resulting instructions. */
-{
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to execute cmd. */
- ArgInfo argInfo; /* Structure holding information about the
- * start and end of each argument word. */
- int range1 = -1, range2; /* Indexes in the ExceptionRange array of
- * the loop ranges for this loop: one for
- * its body and one for its "next" cmd. */
- JumpFixup jumpFalseFixup; /* Used to update or replace the ifFalse
- * jump after the "for" test when its target
- * PC is determined. */
- int jumpBackDist, jumpBackOffset, testCodeOffset, jumpDist, objIndex;
- unsigned char *jumpPc;
- int savePushSimpleWords = envPtr->pushSimpleWords;
- int numWords, result;
-
- /*
- * Scan the words of the command and record the start and finish of
- * each argument word.
- */
-
- InitArgInfo(&argInfo);
- result = CollectArgInfo(interp, string, lastChar, flags, &argInfo);
- numWords = argInfo.numArgs; /* i.e., the # after the command name */
- if (result != TCL_OK) {
- goto done;
- }
- if (numWords != 4) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: should be \"for start test next command\"", -1);
- result = TCL_ERROR;
- goto done;
- }
-
- /*
- * If the test expression is not enclosed in braces, don't compile
- * the for inline. As a result of Tcl's two level substitution
- * semantics for expressions, the expression might have a constant
- * value that results in the loop never executing, or executing forever.
- * Consider "set x 0; for {} "$x > 5" {incr x} {}": the loop body
- * should never be executed.
- * NOTE: This is an overly aggressive test, since there are legitimate
- * literals that could be compiled but aren't in braces. However, until
- * the parser is integrated in 8.1, this is the simplest implementation.
- */
-
- if (*(argInfo.startArray[1]) != '{') {
- result = TCL_OUT_LINE_COMPILE;
- goto done;
- }
-
- /*
- * Create a ExceptionRange record for the for loop's body. This is used
- * to implement break and continue commands inside the body.
- * Then create a second ExceptionRange record for the "next" command in
- * order to implement break (but not continue) inside it. The second,
- * "next" ExceptionRange will always have a -1 continueOffset.
- */
-
- envPtr->excRangeDepth++;
- envPtr->maxExcRangeDepth =
- TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth);
- range1 = CreateExceptionRange(LOOP_EXCEPTION_RANGE, envPtr);
- range2 = CreateExceptionRange(LOOP_EXCEPTION_RANGE, envPtr);
-
- /*
- * Compile inline the next word: the initial command.
- */
-
- result = CompileCmdWordInline(interp, argInfo.startArray[0],
- (argInfo.endArray[0] + 1), flags, envPtr);
- if (result != TCL_OK) {
- if (result == TCL_ERROR) {
- Tcl_AddObjErrorInfo(interp, "\n (\"for\" initial command)", -1);
- }
- goto done;
- }
- maxDepth = envPtr->maxStackDepth;
-
- /*
- * Discard the start command's result.
- */
-
- TclEmitOpcode(INST_POP, envPtr);
-
- /*
- * Compile the next word: the test expression.
- */
-
- testCodeOffset = TclCurrCodeOffset();
- envPtr->pushSimpleWords = 1; /* process words normally */
- result = CompileExprWord(interp, argInfo.startArray[1],
- (argInfo.endArray[1] + 1), flags, envPtr);
- if (result != TCL_OK) {
- if (result == TCL_ERROR) {
- Tcl_AddObjErrorInfo(interp, "\n (\"for\" test expression)", -1);
- }
- goto done;
- }
- maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
-
- /*
- * Emit the jump that terminates the for command if the test was
- * false. We emit a one byte (relative) jump here, and replace it later
- * with a four byte jump if the jump target is > 127 bytes away.
- */
-
- TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
-
- /*
- * Compile the loop body word inline. Also register the loop body's
- * starting PC offset and byte length in the its ExceptionRange record.
- */
-
- envPtr->excRangeArrayPtr[range1].codeOffset = TclCurrCodeOffset();
- result = CompileCmdWordInline(interp, argInfo.startArray[3],
- (argInfo.endArray[3] + 1), flags, envPtr);
- if (result != TCL_OK) {
- if (result == TCL_ERROR) {
- char msg[60];
- sprintf(msg, "\n (\"for\" body line %d)", interp->errorLine);
- Tcl_AddObjErrorInfo(interp, msg, -1);
- }
- goto done;
- }
- maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
- envPtr->excRangeArrayPtr[range1].numCodeBytes =
- (TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range1].codeOffset);
-
- /*
- * Discard the loop body's result.
- */
-
- TclEmitOpcode(INST_POP, envPtr);
-
- /*
- * Finally, compile the "next" subcommand word inline.
- */
-
- envPtr->excRangeArrayPtr[range1].continueOffset = TclCurrCodeOffset();
- envPtr->excRangeArrayPtr[range2].codeOffset = TclCurrCodeOffset();
- result = CompileCmdWordInline(interp, argInfo.startArray[2],
- (argInfo.endArray[2] + 1), flags, envPtr);
- if (result != TCL_OK) {
- if (result == TCL_ERROR) {
- Tcl_AddObjErrorInfo(interp, "\n (\"for\" loop-end command)", -1);
- }
- goto done;
- }
- maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
- envPtr->excRangeArrayPtr[range2].numCodeBytes =
- TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range2].codeOffset;
-
- /*
- * Discard the "next" subcommand's result.
- */
-
- TclEmitOpcode(INST_POP, envPtr);
-
- /*
- * Emit the unconditional jump back to the test at the top of the for
- * loop. We generate a four byte jump if the distance to the test is
- * greater than 120 bytes. This is conservative, and ensures that we
- * won't have to replace this unconditional jump if we later need to
- * replace the ifFalse jump with a four-byte jump.
- */
-
- jumpBackOffset = TclCurrCodeOffset();
- jumpBackDist = (jumpBackOffset - testCodeOffset);
- if (jumpBackDist > 120) {
- TclEmitInstInt4(INST_JUMP4, /*offset*/ -jumpBackDist, envPtr);
- } else {
- TclEmitInstInt1(INST_JUMP1, /*offset*/ -jumpBackDist, envPtr);
- }
-
- /*
- * Now that we know the target of the jumpFalse after the test, update
- * it with the correct distance. If the distance is too great (more
- * than 127 bytes), replace that jump with a four byte instruction and
- * move the instructions after the jump down.
- */
-
- jumpDist = (TclCurrCodeOffset() - jumpFalseFixup.codeOffset);
- if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) {
- /*
- * Update the loop body's ExceptionRange record since it moved down:
- * i.e., increment both its start and continue PC offsets. Also,
- * update the "next" command's start PC offset in its ExceptionRange
- * record since it also moved down.
- */
-
- envPtr->excRangeArrayPtr[range1].codeOffset += 3;
- envPtr->excRangeArrayPtr[range1].continueOffset += 3;
- envPtr->excRangeArrayPtr[range2].codeOffset += 3;
-
- /*
- * Update the distance for the unconditional jump back to the test
- * at the top of the loop since it moved down 3 bytes too.
- */
-
- jumpBackOffset += 3;
- jumpPc = (envPtr->codeStart + jumpBackOffset);
- if (jumpBackDist > 120) {
- jumpBackDist += 3;
- TclUpdateInstInt4AtPc(INST_JUMP4, /*offset*/ -jumpBackDist,
- jumpPc);
- } else {
- jumpBackDist += 3;
- TclUpdateInstInt1AtPc(INST_JUMP1, /*offset*/ -jumpBackDist,
- jumpPc);
- }
- }
-
- /*
- * The current PC offset (after the loop's body and "next" subcommand)
- * is the loop's break target.
- */
-
- envPtr->excRangeArrayPtr[range1].breakOffset =
- envPtr->excRangeArrayPtr[range2].breakOffset = TclCurrCodeOffset();
-
- /*
- * Push an empty string object as the for command's result.
- */
-
- objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0, /*inHeap*/ 0,
- envPtr);
- TclEmitPush(objIndex, envPtr);
- if (maxDepth == 0) {
- maxDepth = 1;
- }
-
- done:
- if (numWords == 0) {
- envPtr->termOffset = 0;
- } else {
- envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string);
- }
- envPtr->pushSimpleWords = savePushSimpleWords;
- envPtr->maxStackDepth = maxDepth;
- if (range1 != -1) {
- envPtr->excRangeDepth--;
- }
- FreeArgInfo(&argInfo);
- return result;
+ return code;
}
/*
*----------------------------------------------------------------------
*
- * TclCompileForeachCmd --
+ * TclInitByteCodeObj --
*
- * Procedure called to compile the "foreach" command.
+ * Create a ByteCode structure and initialize it from a CompileEnv
+ * compilation environment structure. The ByteCode structure is
+ * smaller and contains just that information needed to execute
+ * the bytecode instructions resulting from compiling a Tcl script.
+ * The resulting structure is placed in the specified object.
*
* Results:
- * The return value is a standard Tcl result, which is TCL_OK if
- * compilation was successful. If an error occurs then the
- * interpreter's result contains a standard error message and TCL_ERROR
- * is returned. If complation failed because the command is too complex
- * for TclCompileForeachCmd, TCL_OUT_LINE_COMPILE is returned
- * indicating that the foreach command should be compiled "out of line"
- * by emitting code to invoke its command procedure at runtime.
- *
- * envPtr->termOffset is filled in with the offset of the character in
- * "string" just after the last one successfully processed.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the "while" command.
+ * A newly constructed ByteCode object is stored in the internal
+ * representation of the objPtr.
*
* Side effects:
- * Instructions are added to envPtr to evaluate the "foreach" command
- * at runtime.
+ * A single heap object is allocated to hold the new ByteCode structure
+ * and its code, object, command location, and aux data arrays. Note
+ * that "ownership" (i.e., the pointers to) the Tcl objects and aux
+ * data items will be handed over to the new ByteCode structure from
+ * the CompileEnv structure.
*
*----------------------------------------------------------------------
*/
-int
-TclCompileForeachCmd(interp, string, lastChar, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- char *string; /* The source string to compile. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds resulting instructions. */
+void
+TclInitByteCodeObj(objPtr, envPtr)
+ Tcl_Obj *objPtr; /* Points object that should be
+ * initialized, and whose string rep
+ * contains the source code. */
+ register CompileEnv *envPtr; /* Points to the CompileEnv structure from
+ * which to create a ByteCode structure. */
{
- Proc *procPtr = envPtr->procPtr;
- /* Points to structure describing procedure
- * containing foreach command, else NULL. */
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to execute cmd. */
- ArgInfo argInfo; /* Structure holding information about the
- * start and end of each argument word. */
- int numLists = 0; /* Count of variable (and value) lists. */
- int range = -1; /* Index in the ExceptionRange array of the
- * ExceptionRange record for this loop. */
- ForeachInfo *infoPtr; /* Points to the structure describing this
- * foreach command. Stored in a AuxData
- * record in the ByteCode. */
- JumpFixup jumpFalseFixup; /* Used to update or replace the ifFalse
- * jump after test when its target PC is
- * determined. */
- char savedChar; /* Holds the char from string termporarily
- * replaced by a null character during
- * processing of argument words. */
- int firstListTmp = -1; /* If we decide to compile this foreach
- * command, this is the index or "slot
- * number" for the first temp var allocated
- * in the proc frame that holds a pointer to
- * a value list. Initialized to avoid a
- * compiler warning. */
- int loopIterNumTmp; /* If we decide to compile this foreach
- * command, the index for the temp var that
- * holds the current iteration count. */
- char *varListStart, *varListEnd, *valueListStart, *bodyStart, *bodyEnd;
- unsigned char *jumpPc;
- int jumpDist, jumpBackDist, jumpBackOffset;
- int numWords, numVars, infoIndex, tmpIndex, objIndex, i, j, result;
- int savePushSimpleWords = envPtr->pushSimpleWords;
-
- /*
- * We parse the variable list argument words and create two arrays:
- * varcList[i] gives the number of variables in the i-th var list
- * varvList[i] points to an array of the names in the i-th var list
- * These are initially allocated on the stack, and are allocated on
- * the heap if necessary.
- */
-
-#define STATIC_VAR_LIST_SIZE 4
- int varcListStaticSpace[STATIC_VAR_LIST_SIZE];
- char **varvListStaticSpace[STATIC_VAR_LIST_SIZE];
-
- int *varcList = varcListStaticSpace;
- char ***varvList = varvListStaticSpace;
-
- /*
- * If the foreach command is at global level (not in a procedure),
- * don't compile it inline: the payoff is too small.
- */
-
- if (procPtr == NULL) {
- return TCL_OUT_LINE_COMPILE;
- }
-
- /*
- * Scan the words of the command and record the start and finish of
- * each argument word.
- */
-
- InitArgInfo(&argInfo);
- result = CollectArgInfo(interp, string, lastChar, flags, &argInfo);
- numWords = argInfo.numArgs;
- if (result != TCL_OK) {
- goto done;
- }
- if ((numWords < 3) || (numWords%2 != 1)) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: should be \"foreach varList list ?varList list ...? command\"", -1);
- result = TCL_ERROR;
- goto done;
- }
-
- /*
- * Initialize the varcList and varvList arrays; allocate heap storage,
- * if necessary, for them. Also make sure the variable names
- * have no substitutions: that they're just "var" or "var(elem)"
- */
-
- numLists = (numWords - 1)/2;
- if (numLists > STATIC_VAR_LIST_SIZE) {
- varcList = (int *) ckalloc(numLists * sizeof(int));
- varvList = (char ***) ckalloc(numLists * sizeof(char **));
- }
- for (i = 0; i < numLists; i++) {
- varcList[i] = 0;
- varvList[i] = (char **) NULL;
- }
- for (i = 0; i < numLists; i++) {
- /*
- * Break each variable list into its component variables. If the
- * lists is enclosed in {}s or ""s, strip them off first.
- */
-
- varListStart = argInfo.startArray[i*2];
- varListEnd = argInfo.endArray[i*2];
- if ((*varListStart == '{') || (*varListStart == '"')) {
- if ((*varListEnd != '}') && (*varListEnd != '"')) {
- Tcl_ResetResult(interp);
- if (*varListStart == '"') {
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "extra characters after close-quote", -1);
- } else {
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "extra characters after close-brace", -1);
- }
- result = TCL_ERROR;
- goto done;
- }
- varListStart++;
- varListEnd--;
- }
-
- /*
- * NOTE: THIS NEEDS TO BE CONVERTED TO AN OBJECT LIST.
- */
-
- savedChar = *(varListEnd+1);
- *(varListEnd+1) = '\0';
- result = Tcl_SplitList(interp, varListStart,
- &varcList[i], &varvList[i]);
- *(varListEnd+1) = savedChar;
- if (result != TCL_OK) {
- goto done;
- }
-
- /*
- * Check that each variable name has no substitutions and that
- * it is a local scalar name.
- */
-
- numVars = varcList[i];
- for (j = 0; j < numVars; j++) {
- char *varName = varvList[i][j];
- if (!IsLocalScalar(varName, (int) strlen(varName))) {
- result = TCL_OUT_LINE_COMPILE;
- goto done;
- }
- }
- }
-
- /*
- *==== At this point we believe we can compile the foreach command ====
- */
-
- /*
- * Create and initialize a ExceptionRange record to hold information
- * about this loop. This is used to implement break and continue.
- */
-
- envPtr->excRangeDepth++;
- envPtr->maxExcRangeDepth =
- TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth);
- range = CreateExceptionRange(LOOP_EXCEPTION_RANGE, envPtr);
-
- /*
- * Reserve (numLists + 1) temporary variables:
- * - numLists temps for each value list
- * - a temp for the "next value" index into each value list
- * At this time we don't try to reuse temporaries; if there are two
- * nonoverlapping foreach loops, they don't share any temps.
- */
-
- for (i = 0; i < numLists; i++) {
- tmpIndex = LookupCompiledLocal(NULL, /*nameChars*/ 0,
- /*createIfNew*/ 1, /*flagsIfCreated*/ VAR_SCALAR, procPtr);
- if (i == 0) {
- firstListTmp = tmpIndex;
- }
- }
- loopIterNumTmp = LookupCompiledLocal(NULL, /*nameChars*/ 0,
- /*createIfNew*/ 1, /*flagsIfCreated*/ VAR_SCALAR, procPtr);
-
- /*
- * Create and initialize the ForeachInfo and ForeachVarList data
- * structures describing this command. Then create a AuxData record
- * pointing to the ForeachInfo structure in the compilation environment.
- */
-
- infoPtr = (ForeachInfo *) ckalloc((unsigned)
- (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *))));
- infoPtr->numLists = numLists;
- infoPtr->firstListTmp = firstListTmp;
- infoPtr->loopIterNumTmp = loopIterNumTmp;
- for (i = 0; i < numLists; i++) {
- ForeachVarList *varListPtr;
- numVars = varcList[i];
- varListPtr = (ForeachVarList *) ckalloc((unsigned)
- sizeof(ForeachVarList) + numVars*sizeof(int));
- varListPtr->numVars = numVars;
- for (j = 0; j < numVars; j++) {
- char *varName = varvList[i][j];
- int nameChars = strlen(varName);
- varListPtr->varIndexes[j] = LookupCompiledLocal(varName,
- nameChars, /*createIfNew*/ 1,
- /*flagsIfCreated*/ VAR_SCALAR, procPtr);
- }
- infoPtr->varLists[i] = varListPtr;
- }
- infoIndex = TclCreateAuxData((ClientData) infoPtr,
- &tclForeachInfoType, envPtr);
-
- /*
- * Emit code to store each value list into the associated temporary.
- */
-
- for (i = 0; i < numLists; i++) {
- valueListStart = argInfo.startArray[2*i + 1];
- envPtr->pushSimpleWords = 1;
- result = CompileWord(interp, valueListStart, lastChar, flags,
- envPtr);
- if (result != TCL_OK) {
- goto done;
- }
- maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
-
- tmpIndex = (firstListTmp + i);
- if (tmpIndex <= 255) {
- TclEmitInstUInt1(INST_STORE_SCALAR1, tmpIndex, envPtr);
- } else {
- TclEmitInstUInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
- }
- TclEmitOpcode(INST_POP, envPtr);
- }
-
- /*
- * Emit the instruction to initialize the foreach loop's index temp var.
- */
-
- TclEmitInstUInt4(INST_FOREACH_START4, infoIndex, envPtr);
-
- /*
- * Emit the top of loop code that assigns each loop variable and checks
- * whether to terminate the loop.
- */
-
- envPtr->excRangeArrayPtr[range].continueOffset = TclCurrCodeOffset();
- TclEmitInstUInt4(INST_FOREACH_STEP4, infoIndex, envPtr);
+ register ByteCode *codePtr;
+ size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes;
+ size_t auxDataArrayBytes, structureSize;
+ register unsigned char *p;
+ unsigned char *nextPtr;
+ int numLitObjects = envPtr->literalArrayNext;
+ Namespace *namespacePtr;
+ int i;
+ Interp *iPtr;
- /*
- * Emit the ifFalse jump that terminates the foreach if all value lists
- * are exhausted. We emit a one byte (relative) jump here, and replace
- * it later with a four byte jump if the jump target is more than
- * 127 bytes away.
- */
+ iPtr = envPtr->iPtr;
- TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
+ codeBytes = (envPtr->codeNext - envPtr->codeStart);
+ objArrayBytes = (envPtr->literalArrayNext * sizeof(Tcl_Obj *));
+ exceptArrayBytes = (envPtr->exceptArrayNext * sizeof(ExceptionRange));
+ auxDataArrayBytes = (envPtr->auxDataArrayNext * sizeof(AuxData));
+ cmdLocBytes = GetCmdLocEncodingSize(envPtr);
/*
- * Compile the loop body word inline. Also register the loop body's
- * starting PC offset and byte length in the ExceptionRange record.
+ * Compute the total number of bytes needed for this bytecode.
*/
- bodyStart = argInfo.startArray[numWords - 1];
- bodyEnd = argInfo.endArray[numWords - 1];
- savedChar = *(bodyEnd+1);
- *(bodyEnd+1) = '\0';
- envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset();
- result = CompileCmdWordInline(interp, bodyStart, bodyEnd+1, flags,
- envPtr);
- *(bodyEnd+1) = savedChar;
- if (result != TCL_OK) {
- if (result == TCL_ERROR) {
- char msg[60];
- sprintf(msg, "\n (\"foreach\" body line %d)",
- interp->errorLine);
- Tcl_AddObjErrorInfo(interp, msg, -1);
- }
- goto done;
- }
- maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
- envPtr->excRangeArrayPtr[range].numCodeBytes =
- TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset;
-
- /*
- * Discard the loop body's result.
- */
-
- TclEmitOpcode(INST_POP, envPtr);
-
- /*
- * Emit the unconditional jump back to the test at the top of the
- * loop. We generate a four byte jump if the distance to the to of
- * the foreach is greater than 120 bytes. This is conservative and
- * ensures that we won't have to replace this unconditional jump if
- * we later need to replace the ifFalse jump with a four-byte jump.
- */
+ structureSize = sizeof(ByteCode);
+ structureSize += TCL_ALIGN(codeBytes); /* align object array */
+ structureSize += TCL_ALIGN(objArrayBytes); /* align exc range arr */
+ structureSize += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
+ structureSize += auxDataArrayBytes;
+ structureSize += cmdLocBytes;
- jumpBackOffset = TclCurrCodeOffset();
- jumpBackDist =
- (jumpBackOffset - envPtr->excRangeArrayPtr[range].continueOffset);
- if (jumpBackDist > 120) {
- TclEmitInstInt4(INST_JUMP4, /*offset*/ -jumpBackDist, envPtr);
+ if (envPtr->iPtr->varFramePtr != NULL) {
+ namespacePtr = envPtr->iPtr->varFramePtr->nsPtr;
} else {
- TclEmitInstInt1(INST_JUMP1, /*offset*/ -jumpBackDist, envPtr);
- }
-
- /*
- * Now that we know the target of the jumpFalse after the foreach_step
- * test, update it with the correct distance. If the distance is too
- * great (more than 127 bytes), replace that jump with a four byte
- * instruction and move the instructions after the jump down.
- */
-
- jumpDist = (TclCurrCodeOffset() - jumpFalseFixup.codeOffset);
- if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) {
- /*
- * Update the loop body's starting PC offset since it moved down.
- */
-
- envPtr->excRangeArrayPtr[range].codeOffset += 3;
-
- /*
- * Update the distance for the unconditional jump back to the test
- * at the top of the loop since it moved down 3 bytes too.
- */
-
- jumpBackOffset += 3;
- jumpPc = (envPtr->codeStart + jumpBackOffset);
- if (jumpBackDist > 120) {
- jumpBackDist += 3;
- TclUpdateInstInt4AtPc(INST_JUMP4, /*offset*/ -jumpBackDist,
- jumpPc);
- } else {
- jumpBackDist += 3;
- TclUpdateInstInt1AtPc(INST_JUMP1, /*offset*/ -jumpBackDist,
- jumpPc);
- }
+ namespacePtr = envPtr->iPtr->globalNsPtr;
}
-
- /*
- * The current PC offset (after the loop's body) is the loop's
- * break target.
- */
-
- envPtr->excRangeArrayPtr[range].breakOffset = TclCurrCodeOffset();
- /*
- * Push an empty string object as the foreach command's result.
- */
-
- objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0, /*inHeap*/ 0,
- envPtr);
- TclEmitPush(objIndex, envPtr);
- if (maxDepth == 0) {
- maxDepth = 1;
- }
-
- done:
- for (i = 0; i < numLists; i++) {
- if (varvList[i] != (char **) NULL) {
- ckfree((char *) varvList[i]);
- }
- }
- if (varcList != varcListStaticSpace) {
- ckfree((char *) varcList);
- ckfree((char *) varvList);
- }
- envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string);
- envPtr->pushSimpleWords = savePushSimpleWords;
- envPtr->maxStackDepth = maxDepth;
- if (range != -1) {
- envPtr->excRangeDepth--;
- }
- FreeArgInfo(&argInfo);
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * DupForeachInfo --
- *
- * This procedure duplicates a ForeachInfo structure created as
- * auxiliary data during the compilation of a foreach command.
- *
- * Results:
- * A pointer to a newly allocated copy of the existing ForeachInfo
- * structure is returned.
- *
- * Side effects:
- * Storage for the copied ForeachInfo record is allocated. If the
- * original ForeachInfo structure pointed to any ForeachVarList
- * records, these structures are also copied and pointers to them
- * are stored in the new ForeachInfo record.
- *
- *----------------------------------------------------------------------
- */
+ p = (unsigned char *) ckalloc((size_t) structureSize);
+ codePtr = (ByteCode *) p;
+ codePtr->interpHandle = TclHandlePreserve(iPtr->handle);
+ codePtr->compileEpoch = iPtr->compileEpoch;
+ codePtr->nsPtr = namespacePtr;
+ codePtr->nsEpoch = namespacePtr->resolverEpoch;
+ codePtr->refCount = 1;
+ codePtr->flags = 0;
+ codePtr->source = envPtr->source;
+ codePtr->procPtr = envPtr->procPtr;
-static ClientData
-DupForeachInfo(clientData)
- ClientData clientData; /* The foreach command's compilation
- * auxiliary data to duplicate. */
-{
- register ForeachInfo *srcPtr = (ForeachInfo *) clientData;
- ForeachInfo *dupPtr;
- register ForeachVarList *srcListPtr, *dupListPtr;
- int numLists = srcPtr->numLists;
- int numVars, i, j;
+ codePtr->numCommands = envPtr->numCommands;
+ codePtr->numSrcBytes = envPtr->numSrcBytes;
+ codePtr->numCodeBytes = codeBytes;
+ codePtr->numLitObjects = numLitObjects;
+ codePtr->numExceptRanges = envPtr->exceptArrayNext;
+ codePtr->numAuxDataItems = envPtr->auxDataArrayNext;
+ codePtr->numCmdLocBytes = cmdLocBytes;
+ codePtr->maxExceptDepth = envPtr->maxExceptDepth;
+ codePtr->maxStackDepth = envPtr->maxStackDepth;
- dupPtr = (ForeachInfo *) ckalloc((unsigned)
- (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *))));
- dupPtr->numLists = numLists;
- dupPtr->firstListTmp = srcPtr->firstListTmp;
- dupPtr->loopIterNumTmp = srcPtr->loopIterNumTmp;
+ p += sizeof(ByteCode);
+ codePtr->codeStart = p;
+ memcpy((VOID *) p, (VOID *) envPtr->codeStart, (size_t) codeBytes);
- for (i = 0; i < numLists; i++) {
- srcListPtr = srcPtr->varLists[i];
- numVars = srcListPtr->numVars;
- dupListPtr = (ForeachVarList *) ckalloc((unsigned)
- sizeof(ForeachVarList) + numVars*sizeof(int));
- dupListPtr->numVars = numVars;
- for (j = 0; j < numVars; j++) {
- dupListPtr->varIndexes[j] = srcListPtr->varIndexes[j];
- }
- dupPtr->varLists[i] = dupListPtr;
- }
- return (ClientData) dupPtr;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * FreeForeachInfo --
- *
- * Procedure to free a ForeachInfo structure created as auxiliary data
- * during the compilation of a foreach command.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Storage for the ForeachInfo structure pointed to by the ClientData
- * argument is freed as is any ForeachVarList record pointed to by the
- * ForeachInfo structure.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-FreeForeachInfo(clientData)
- ClientData clientData; /* The foreach command's compilation
- * auxiliary data to free. */
-{
- register ForeachInfo *infoPtr = (ForeachInfo *) clientData;
- register ForeachVarList *listPtr;
- int numLists = infoPtr->numLists;
- register int i;
-
- for (i = 0; i < numLists; i++) {
- listPtr = infoPtr->varLists[i];
- ckfree((char *) listPtr);
+ p += TCL_ALIGN(codeBytes); /* align object array */
+ codePtr->objArrayPtr = (Tcl_Obj **) p;
+ for (i = 0; i < numLitObjects; i++) {
+ codePtr->objArrayPtr[i] = envPtr->literalArrayPtr[i].objPtr;
}
- ckfree((char *) infoPtr);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileIfCmd --
- *
- * Procedure called to compile the "if" command.
- *
- * Results:
- * The return value is a standard Tcl result, which is TCL_OK unless
- * there was an error while parsing string. If an error occurs then
- * the interpreter's result contains a standard error message.
- *
- * envPtr->termOffset is filled in with the offset of the character in
- * "string" just after the last one successfully processed.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the command.
- *
- * Side effects:
- * Instructions are added to envPtr to evaluate the "if" command
- * at runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileIfCmd(interp, string, lastChar, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- char *string; /* The source string to compile. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds resulting instructions. */
-{
- register char *src = string;/* Points to current source char. */
- register int type; /* Current char's CHAR_TYPE type. */
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to execute cmd. */
- JumpFixupArray jumpFalseFixupArray;
- /* Used to fix up the ifFalse jump after
- * each "if"/"elseif" test when its target
- * PC is determined. */
- JumpFixupArray jumpEndFixupArray;
- /* Used to fix up the unconditional jump
- * after each "then" command to the end of
- * the "if" when that PC is determined. */
- char *testSrcStart;
- int jumpDist, jumpFalseDist, jumpIndex, objIndex, j, result;
- unsigned char *ifFalsePc;
- unsigned char opCode;
- int savePushSimpleWords = envPtr->pushSimpleWords;
-
- /*
- * Loop compiling "expr then body" clauses after an "if" or "elseif".
- */
-
- TclInitJumpFixupArray(&jumpFalseFixupArray);
- TclInitJumpFixupArray(&jumpEndFixupArray);
- while (1) {
- /*
- * At this point in the loop, we have an expression to test, either
- * the main expression or an expression following an "elseif".
- * The arguments after the expression must be "then" (optional) and
- * a script to execute if the expression is true.
- */
-
- AdvanceToNextWord(src, envPtr);
- src += envPtr->termOffset;
- type = CHAR_TYPE(src, lastChar);
- if (type == TCL_COMMAND_END) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: no expression after \"if\" argument", -1);
- result = TCL_ERROR;
- goto done;
- }
-
- /*
- * Compile the "if"/"elseif" test expression.
- */
-
- testSrcStart = src;
- envPtr->pushSimpleWords = 1;
- result = CompileExprWord(interp, src, lastChar, flags, envPtr);
- if (result != TCL_OK) {
- if (result == TCL_ERROR) {
- Tcl_AddObjErrorInfo(interp,
- "\n (\"if\" test expression)", -1);
- }
- goto done;
- }
- maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
- src += envPtr->termOffset;
-
- /*
- * Emit the ifFalse jump around the "then" part if the test was
- * false. We emit a one byte (relative) jump here, and replace it
- * later with a four byte jump if the jump target is more than 127
- * bytes away.
- */
-
- if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) {
- TclExpandJumpFixupArray(&jumpFalseFixupArray);
- }
- jumpIndex = jumpFalseFixupArray.next;
- jumpFalseFixupArray.next++;
- TclEmitForwardJump(envPtr, TCL_FALSE_JUMP,
- &(jumpFalseFixupArray.fixup[jumpIndex]));
-
- /*
- * Skip over the optional "then" before the then clause.
- */
-
- AdvanceToNextWord(src, envPtr);
- src += envPtr->termOffset;
- type = CHAR_TYPE(src, lastChar);
- if (type == TCL_COMMAND_END) {
- char buf[100];
- sprintf(buf, "wrong # args: no script following \"%.20s\" argument", testSrcStart);
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
- result = TCL_ERROR;
- goto done;
- }
- if ((*src == 't') && (strncmp(src, "then", 4) == 0)) {
- type = CHAR_TYPE(src+4, lastChar);
- if ((type == TCL_SPACE) || (type == TCL_COMMAND_END)) {
- src += 4;
- AdvanceToNextWord(src, envPtr);
- src += envPtr->termOffset;
- type = CHAR_TYPE(src, lastChar);
- if (type == TCL_COMMAND_END) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: no script following \"then\" argument", -1);
- result = TCL_ERROR;
- goto done;
- }
- }
- }
-
- /*
- * Compile the "then" command word inline.
- */
-
- result = CompileCmdWordInline(interp, src, lastChar, flags, envPtr);
- if (result != TCL_OK) {
- if (result == TCL_ERROR) {
- char msg[60];
- sprintf(msg, "\n (\"if\" then script line %d)",
- interp->errorLine);
- Tcl_AddObjErrorInfo(interp, msg, -1);
- }
- goto done;
- }
- maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
- src += envPtr->termOffset;
-
- /*
- * Emit an unconditional jump to the end of the "if" command. We
- * emit a one byte jump here, and replace it later with a four byte
- * jump if the jump target is more than 127 bytes away. Note that
- * both the jumpFalseFixupArray and the jumpEndFixupArray are
- * indexed by the same index, "jumpIndex".
- */
-
- if (jumpEndFixupArray.next >= jumpEndFixupArray.end) {
- TclExpandJumpFixupArray(&jumpEndFixupArray);
- }
- jumpEndFixupArray.next++;
- TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
- &(jumpEndFixupArray.fixup[jumpIndex]));
-
- /*
- * Now that we know the target of the jumpFalse after the if test,
- * update it with the correct distance. We generate a four byte
- * jump if the distance is greater than 120 bytes. This is
- * conservative, and ensures that we won't have to replace this
- * jump if we later also need to replace the preceeding
- * unconditional jump to the end of the "if" with a four-byte jump.
- */
-
- jumpDist = (TclCurrCodeOffset() - jumpFalseFixupArray.fixup[jumpIndex].codeOffset);
- if (TclFixupForwardJump(envPtr,
- &(jumpFalseFixupArray.fixup[jumpIndex]), jumpDist, 120)) {
- /*
- * Adjust the code offset for the unconditional jump at the end
- * of the last "then" clause.
- */
-
- jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3;
- }
-
- /*
- * Check now for a "elseif" word. If we find one, keep looping.
- */
-
- AdvanceToNextWord(src, envPtr);
- src += envPtr->termOffset;
- type = CHAR_TYPE(src, lastChar);
- if ((type != TCL_COMMAND_END)
- && ((*src == 'e') && (strncmp(src, "elseif", 6) == 0))) {
- type = CHAR_TYPE(src+6, lastChar);
- if ((type == TCL_SPACE) || (type == TCL_COMMAND_END)) {
- src += 6;
- AdvanceToNextWord(src, envPtr);
- src += envPtr->termOffset;
- type = CHAR_TYPE(src, lastChar);
- if (type == TCL_COMMAND_END) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: no expression after \"elseif\" argument", -1);
- result = TCL_ERROR;
- goto done;
- }
- continue; /* continue the "expr then body" loop */
- }
- }
- break;
- } /* end of the "expr then body" loop */
- /*
- * No more "elseif expr then body" clauses. Check now for an "else"
- * clause. If there is another word, we are at its start.
- */
-
- if (type != TCL_COMMAND_END) {
- if ((*src == 'e') && (strncmp(src, "else", 4) == 0)) {
- type = CHAR_TYPE(src+4, lastChar);
- if ((type == TCL_SPACE) || (type == TCL_COMMAND_END)) {
- src += 4;
- AdvanceToNextWord(src, envPtr);
- src += envPtr->termOffset;
- type = CHAR_TYPE(src, lastChar);
- if (type == TCL_COMMAND_END) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: no script following \"else\" argument", -1);
- result = TCL_ERROR;
- goto done;
- }
- }
- }
-
- /*
- * Compile the "else" command word inline.
- */
-
- result = CompileCmdWordInline(interp, src, lastChar, flags, envPtr);
- if (result != TCL_OK) {
- if (result == TCL_ERROR) {
- char msg[60];
- sprintf(msg, "\n (\"if\" else script line %d)",
- interp->errorLine);
- Tcl_AddObjErrorInfo(interp, msg, -1);
- }
- goto done;
- }
- maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
- src += envPtr->termOffset;
-
- /*
- * Skip over white space until the end of the command.
- */
-
- type = CHAR_TYPE(src, lastChar);
- if (type != TCL_COMMAND_END) {
- AdvanceToNextWord(src, envPtr);
- src += envPtr->termOffset;
- type = CHAR_TYPE(src, lastChar);
- if (type != TCL_COMMAND_END) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: extra words after \"else\" clause in \"if\" command", -1);
- result = TCL_ERROR;
- goto done;
- }
- }
+ p += TCL_ALIGN(objArrayBytes); /* align exception range array */
+ if (exceptArrayBytes > 0) {
+ codePtr->exceptArrayPtr = (ExceptionRange *) p;
+ memcpy((VOID *) p, (VOID *) envPtr->exceptArrayPtr,
+ (size_t) exceptArrayBytes);
} else {
- /*
- * The "if" command has no "else" clause: push an empty string
- * object as its result.
- */
-
- objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0,
- /*inHeap*/ 0, envPtr);
- TclEmitPush(objIndex, envPtr);
- maxDepth = TclMax(1, maxDepth);
- }
-
- /*
- * Now that we know the target of the unconditional jumps to the end of
- * the "if" command, update them with the correct distance. If the
- * distance is too great (> 127 bytes), replace the jump with a four
- * byte instruction and move instructions after the jump down.
- */
-
- for (j = jumpEndFixupArray.next; j > 0; j--) {
- jumpIndex = (j - 1); /* i.e. process the closest jump first */
- jumpDist = (TclCurrCodeOffset() - jumpEndFixupArray.fixup[jumpIndex].codeOffset);
- if (TclFixupForwardJump(envPtr,
- &(jumpEndFixupArray.fixup[jumpIndex]), jumpDist, 127)) {
- /*
- * Adjust the jump distance for the "ifFalse" jump that
- * immediately preceeds this jump. We've moved it's target
- * (just after this unconditional jump) three bytes down.
- */
-
- ifFalsePc = (envPtr->codeStart + jumpFalseFixupArray.fixup[jumpIndex].codeOffset);
- opCode = *ifFalsePc;
- if (opCode == INST_JUMP_FALSE1) {
- jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1);
- jumpFalseDist += 3;
- TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1));
- } else if (opCode == INST_JUMP_FALSE4) {
- jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1);
- jumpFalseDist += 3;
- TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1));
- } else {
- panic("TclCompileIfCmd: unexpected opcode updating ifFalse jump");
- }
- }
- }
-
- /*
- * Free the jumpFixupArray array if malloc'ed storage was used.
- */
-
- done:
- TclFreeJumpFixupArray(&jumpFalseFixupArray);
- TclFreeJumpFixupArray(&jumpEndFixupArray);
- envPtr->termOffset = (src - string);
- envPtr->maxStackDepth = maxDepth;
- envPtr->pushSimpleWords = savePushSimpleWords;
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileIncrCmd --
- *
- * Procedure called to compile the "incr" command.
- *
- * Results:
- * The return value is a standard Tcl result, which is TCL_OK unless
- * there was an error while parsing string. If an error occurs then
- * the interpreter's result contains a standard error message.
- *
- * envPtr->termOffset is filled in with the offset of the character in
- * "string" just after the last one successfully processed.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the "incr" command.
- *
- * Side effects:
- * Instructions are added to envPtr to evaluate the "incr" command
- * at runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileIncrCmd(interp, string, lastChar, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- char *string; /* The source string to compile. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds resulting instructions. */
-{
- Proc *procPtr = envPtr->procPtr;
- /* Points to structure describing procedure
- * containing incr command, else NULL. */
- register char *src = string;
- /* Points to current source char. */
- register int type; /* Current char's CHAR_TYPE type. */
- int simpleVarName; /* 1 if name is just sequence of chars with
- * an optional element name in parens. */
- char *name = NULL; /* If simpleVarName, points to first char of
- * variable name and nameChars is length.
- * Otherwise NULL. */
- char *elName = NULL; /* If simpleVarName, points to first char of
- * element name and elNameChars is length.
- * Otherwise NULL. */
- int nameChars = 0; /* Length of the var name. Initialized to
- * avoid a compiler warning. */
- int elNameChars = 0; /* Length of array's element name, if any.
- * Initialized to avoid a compiler
- * warning. */
- int incrementGiven; /* 1 if an increment amount was given. */
- int isImmIncrValue = 0; /* 1 if increment amount is a literal
- * integer in [-127..127]. */
- int immIncrValue = 0; /* if isImmIncrValue is 1, the immediate
- * integer value. */
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to execute cmd. */
- int localIndex = -1; /* Index of the variable in the current
- * procedure's array of local variables.
- * Otherwise -1 if not in a procedure or
- * the variable wasn't found. */
- char savedChar; /* Holds the character from string
- * termporarily replaced by a null char
- * during name processing. */
- int objIndex; /* The object array index for a pushed
- * object holding a name part. */
- int savePushSimpleWords = envPtr->pushSimpleWords;
- char *p;
- int i, result;
-
- /*
- * Parse the next word: the variable name. If it is "simple" (requires
- * no substitutions at runtime), divide it up into a simple "name" plus
- * an optional "elName". Otherwise, if not simple, just push the name.
- */
-
- AdvanceToNextWord(src, envPtr);
- src += envPtr->termOffset;
- type = CHAR_TYPE(src, lastChar);
- if (type == TCL_COMMAND_END) {
- badArgs:
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: should be \"incr varName ?increment?\"", -1);
- result = TCL_ERROR;
- goto done;
+ codePtr->exceptArrayPtr = NULL;
}
- envPtr->pushSimpleWords = 0;
- result = CompileWord(interp, src, lastChar, flags, envPtr);
- if (result != TCL_OK) {
- goto done;
- }
- simpleVarName = envPtr->wordIsSimple;
- if (simpleVarName) {
- name = src;
- nameChars = envPtr->numSimpleWordChars;
- if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
- name++;
- }
- elName = NULL;
- elNameChars = 0;
- p = name;
- for (i = 0; i < nameChars; i++) {
- if (*p == '(') {
- char *openParen = p;
- p = (src + nameChars-1);
- if (*p == ')') { /* last char is ')' => array reference */
- nameChars = (openParen - name);
- elName = openParen+1;
- elNameChars = (p - elName);
- }
- break;
- }
- p++;
- }
+ p += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
+ if (auxDataArrayBytes > 0) {
+ codePtr->auxDataArrayPtr = (AuxData *) p;
+ memcpy((VOID *) p, (VOID *) envPtr->auxDataArrayPtr,
+ (size_t) auxDataArrayBytes);
} else {
- maxDepth = envPtr->maxStackDepth;
- }
- src += envPtr->termOffset;
-
- /*
- * See if there is a next word. If so, we are incrementing the variable
- * by that value (which must be an integer).
- */
-
- incrementGiven = 0;
- type = CHAR_TYPE(src, lastChar);
- if (type != TCL_COMMAND_END) {
- AdvanceToNextWord(src, envPtr);
- src += envPtr->termOffset;
- type = CHAR_TYPE(src, lastChar);
- incrementGiven = (type != TCL_COMMAND_END);
- }
-
- /*
- * Non-simple names have already been pushed. If this is a simple
- * variable, either push its name (if a global or an unknown local
- * variable) or look up the variable's local frame index. If a local is
- * not found, push its name and do the lookup at runtime. If this is an
- * array reference, also push the array element.
- */
-
- if (simpleVarName) {
- if (procPtr == NULL) {
- savedChar = name[nameChars];
- name[nameChars] = '\0';
- objIndex = TclObjIndexForString(name, nameChars,
- /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- name[nameChars] = savedChar;
- TclEmitPush(objIndex, envPtr);
- maxDepth = 1;
- } else {
- localIndex = LookupCompiledLocal(name, nameChars,
- /*createIfNew*/ 0, /*flagsIfCreated*/ 0,
- envPtr->procPtr);
- if ((localIndex < 0) || (localIndex > 255)) {
- if (localIndex > 255) { /* we'll push the name */
- localIndex = -1;
- }
- savedChar = name[nameChars];
- name[nameChars] = '\0';
- objIndex = TclObjIndexForString(name, nameChars,
- /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- name[nameChars] = savedChar;
- TclEmitPush(objIndex, envPtr);
- maxDepth = 1;
- } else {
- maxDepth = 0;
- }
- }
-
- if (elName != NULL) {
- /*
- * Parse and push the array element's name. Perform
- * substitutions on it, just as is done for quoted strings.
- */
-
- savedChar = elName[elNameChars];
- elName[elNameChars] = '\0';
- envPtr->pushSimpleWords = 1;
- result = TclCompileQuotes(interp, elName, elName+elNameChars,
- 0, flags, envPtr);
- elName[elNameChars] = savedChar;
- if (result != TCL_OK) {
- char msg[200];
- sprintf(msg, "\n (parsing index for array \"%.*s\")",
- TclMin(nameChars, 100), name);
- Tcl_AddObjErrorInfo(interp, msg, -1);
- goto done;
- }
- maxDepth += envPtr->maxStackDepth;
- }
+ codePtr->auxDataArrayPtr = NULL;
}
- /*
- * If an increment was given, push the new value.
- */
-
- if (incrementGiven) {
- type = CHAR_TYPE(src, lastChar);
- envPtr->pushSimpleWords = 0;
- result = CompileWord(interp, src, lastChar, flags, envPtr);
- if (result != TCL_OK) {
- if (result == TCL_ERROR) {
- Tcl_AddObjErrorInfo(interp,
- "\n (increment expression)", -1);
- }
- goto done;
- }
- if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
- src++;
- }
- if (envPtr->wordIsSimple) {
- /*
- * See if the word represents an integer whose formatted
- * representation is the same as the word (e.g., this is
- * true for 123 and -1 but not for 00005). If so, just
- * push an integer object.
- */
-
- int isCompilableInt = 0;
- int numChars = envPtr->numSimpleWordChars;
- char savedChar = src[numChars];
- char buf[40];
- Tcl_Obj *objPtr;
- long n;
-
- src[numChars] = '\0';
- if (TclLooksLikeInt(src)) {
- int code = TclGetLong(interp, src, &n);
- if (code == TCL_OK) {
- if ((-127 <= n) && (n <= 127)) {
- isCompilableInt = 1;
- isImmIncrValue = 1;
- immIncrValue = n;
- } else {
- TclFormatInt(buf, n);
- if (strcmp(src, buf) == 0) {
- isCompilableInt = 1;
- isImmIncrValue = 0;
- objIndex = TclObjIndexForString(src, numChars,
- /*allocStrRep*/ 0, /*inHeap*/ 0, envPtr);
- objPtr = envPtr->objArrayPtr[objIndex];
-
- Tcl_InvalidateStringRep(objPtr);
- objPtr->internalRep.longValue = n;
- objPtr->typePtr = &tclIntType;
-
- TclEmitPush(objIndex, envPtr);
- maxDepth += 1;
- }
- }
- } else {
- Tcl_ResetResult(interp);
- }
- }
- if (!isCompilableInt) {
- objIndex = TclObjIndexForString(src, numChars,
- /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- TclEmitPush(objIndex, envPtr);
- maxDepth += 1;
- }
- src[numChars] = savedChar;
- } else {
- maxDepth += envPtr->maxStackDepth;
- }
- if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
- src += (envPtr->termOffset - 1); /* already advanced 1 above */
- } else {
- src += envPtr->termOffset;
- }
- } else { /* no incr amount given so use 1 */
- isImmIncrValue = 1;
- immIncrValue = 1;
+ p += auxDataArrayBytes;
+ nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p);
+#ifdef TCL_COMPILE_DEBUG
+ if (((size_t)(nextPtr - p)) != cmdLocBytes) {
+ panic("TclInitByteCodeObj: encoded cmd location bytes %d != expected size %d\n", (nextPtr - p), cmdLocBytes);
}
+#endif
/*
- * Now emit instructions to increment the variable.
- */
-
- if (simpleVarName) {
- if (elName == NULL) { /* scalar */
- if (localIndex >= 0) {
- if (isImmIncrValue) {
- TclEmitInstUInt1(INST_INCR_SCALAR1_IMM, localIndex,
- envPtr);
- TclEmitInt1(immIncrValue, envPtr);
- } else {
- TclEmitInstUInt1(INST_INCR_SCALAR1, localIndex, envPtr);
- }
- } else {
- if (isImmIncrValue) {
- TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immIncrValue,
- envPtr);
- } else {
- TclEmitOpcode(INST_INCR_SCALAR_STK, envPtr);
- }
- }
- } else { /* array */
- if (localIndex >= 0) {
- if (isImmIncrValue) {
- TclEmitInstUInt1(INST_INCR_ARRAY1_IMM, localIndex,
- envPtr);
- TclEmitInt1(immIncrValue, envPtr);
- } else {
- TclEmitInstUInt1(INST_INCR_ARRAY1, localIndex, envPtr);
- }
- } else {
- if (isImmIncrValue) {
- TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immIncrValue,
- envPtr);
- } else {
- TclEmitOpcode(INST_INCR_ARRAY_STK, envPtr);
- }
- }
- }
- } else { /* non-simple variable name */
- if (isImmIncrValue) {
- TclEmitInstInt1(INST_INCR_STK_IMM, immIncrValue, envPtr);
- } else {
- TclEmitOpcode(INST_INCR_STK, envPtr);
- }
- }
-
- /*
- * Skip over white space until the end of the command.
- */
-
- type = CHAR_TYPE(src, lastChar);
- if (type != TCL_COMMAND_END) {
- AdvanceToNextWord(src, envPtr);
- src += envPtr->termOffset;
- type = CHAR_TYPE(src, lastChar);
- if (type != TCL_COMMAND_END) {
- goto badArgs;
- }
- }
-
- done:
- envPtr->termOffset = (src - string);
- envPtr->maxStackDepth = maxDepth;
- envPtr->pushSimpleWords = savePushSimpleWords;
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileSetCmd --
- *
- * Procedure called to compile the "set" command.
- *
- * Results:
- * The return value is a standard Tcl result, which is normally TCL_OK
- * unless there was an error while parsing string. If an error occurs
- * then the interpreter's result contains a standard error message. If
- * complation fails because the set command requires a second level of
- * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
- * set command should be compiled "out of line" by emitting code to
- * invoke its command procedure (Tcl_SetCmd) at runtime.
- *
- * envPtr->termOffset is filled in with the offset of the character in
- * "string" just after the last one successfully processed.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the incr command.
- *
- * Side effects:
- * Instructions are added to envPtr to evaluate the "set" command
- * at runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileSetCmd(interp, string, lastChar, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- char *string; /* The source string to compile. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds resulting instructions. */
-{
- Proc *procPtr = envPtr->procPtr;
- /* Points to structure describing procedure
- * containing the set command, else NULL. */
- ArgInfo argInfo; /* Structure holding information about the
- * start and end of each argument word. */
- int simpleVarName; /* 1 if name is just sequence of chars with
- * an optional element name in parens. */
- char *elName = NULL; /* If simpleVarName, points to first char of
- * element name and elNameChars is length.
- * Otherwise NULL. */
- int isAssignment; /* 1 if assigning value to var, else 0. */
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to execute cmd. */
- int localIndex = -1; /* Index of the variable in the current
- * procedure's array of local variables.
- * Otherwise -1 if not in a procedure, the
- * name contains "::"s, or the variable
- * wasn't found. */
- char savedChar; /* Holds the character from string
- * termporarily replaced by a null char
- * during name processing. */
- int objIndex = -1; /* The object array index for a pushed
- * object holding a name part. Initialized
- * to avoid a compiler warning. */
- char *wordStart, *p;
- int numWords, isCompilableInt, i, result;
- Tcl_Obj *objPtr;
- int savePushSimpleWords = envPtr->pushSimpleWords;
-
- /*
- * Scan the words of the command and record the start and finish of
- * each argument word.
+ * Record various compilation-related statistics about the new ByteCode
+ * structure. Don't include overhead for statistics-related fields.
*/
- InitArgInfo(&argInfo);
- result = CollectArgInfo(interp, string, lastChar, flags, &argInfo);
- numWords = argInfo.numArgs; /* i.e., the # after the command name */
- if (result != TCL_OK) {
- goto done;
- }
- if ((numWords < 1) || (numWords > 2)) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: should be \"set varName ?newValue?\"", -1);
- result = TCL_ERROR;
- goto done;
- }
- isAssignment = (numWords == 2);
-
- /*
- * Parse the next word: the variable name. If the name is enclosed in
- * quotes or braces, we return TCL_OUT_LINE_COMPILE and call the set
- * command procedure at runtime since this makes sure that a second
- * round of substitutions is done properly.
- */
-
- wordStart = argInfo.startArray[0]; /* start of 1st arg word: varname */
- if ((*wordStart == '{') || (*wordStart == '"')) {
- result = TCL_OUT_LINE_COMPILE;
- goto done;
- }
-
- /*
- * Check whether the name is "simple": requires no substitutions at
- * runtime.
- */
+#ifdef TCL_COMPILE_STATS
+ codePtr->structureSize = structureSize
+ - (sizeof(size_t) + sizeof(Tcl_Time));
+ TclpGetTime(&(codePtr->createTime));
- envPtr->pushSimpleWords = 0;
- result = CompileWord(interp, wordStart, argInfo.endArray[0] + 1,
- flags, envPtr);
- if (result != TCL_OK) {
- goto done;
- }
- simpleVarName = envPtr->wordIsSimple;
+ RecordByteCodeStats(codePtr);
+#endif /* TCL_COMPILE_STATS */
- if (!simpleVarName) {
- /*
- * The name isn't simple. CompileWord already pushed it.
- */
-
- maxDepth = envPtr->maxStackDepth;
- } else {
- char *name; /* If simpleVarName, points to first char of
- * variable name and nameChars is length.
- * Otherwise NULL. */
- int nameChars; /* Length of the var name. */
- int nameHasNsSeparators = 0;
- /* Set 1 if name contains "::"s. */
- int elNameChars; /* Length of array's element name if any. */
-
- /*
- * A simple name. First divide it up into "name" plus "elName"
- * for an array element name, if any.
- */
-
- name = wordStart;
- nameChars = envPtr->numSimpleWordChars;
- elName = NULL;
- elNameChars = 0;
-
- p = name;
- for (i = 0; i < nameChars; i++) {
- if (*p == '(') {
- char *openParen = p;
- p = (name + nameChars-1);
- if (*p == ')') { /* last char is ')' => array reference */
- nameChars = (openParen - name);
- elName = openParen+1;
- elNameChars = (p - elName);
- }
- break;
- }
- p++;
- }
-
- /*
- * Determine if name has any namespace separators (::'s).
- */
-
- p = name;
- for (i = 0; i < nameChars; i++) {
- if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) {
- nameHasNsSeparators = 1;
- break;
- }
- p++;
- }
-
- /*
- * Now either push the name or determine its index in the array of
- * local variables in a procedure frame. Note that if we are
- * compiling a procedure the variable must be local unless its
- * name has namespace separators ("::"s). Note also that global
- * variables are implemented by a local variable that "points" to
- * the real global. There are two cases:
- * 1) We are not compiling a procedure body. Push the global
- * variable's name and do the lookup at runtime.
- * 2) We are compiling a procedure and the name has "::"s.
- * Push the namespace variable's name and do the lookup at
- * runtime.
- * 3) We are compiling a procedure and the name has no "::"s.
- * If the variable has already been allocated an local index,
- * just look it up. If the variable is unknown and we are
- * doing an assignment, allocate a new index. Otherwise,
- * push the name and try to do the lookup at runtime.
- */
-
- if ((procPtr == NULL) || nameHasNsSeparators) {
- savedChar = name[nameChars];
- name[nameChars] = '\0';
- objIndex = TclObjIndexForString(name, nameChars,
- /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- name[nameChars] = savedChar;
- TclEmitPush(objIndex, envPtr);
- maxDepth = 1;
- } else {
- localIndex = LookupCompiledLocal(name, nameChars,
- /*createIfNew*/ isAssignment,
- /*flagsIfCreated*/
- ((elName == NULL)? VAR_SCALAR : VAR_ARRAY),
- envPtr->procPtr);
- if (localIndex >= 0) {
- maxDepth = 0;
- } else {
- savedChar = name[nameChars];
- name[nameChars] = '\0';
- objIndex = TclObjIndexForString(name, nameChars,
- /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- name[nameChars] = savedChar;
- TclEmitPush(objIndex, envPtr);
- maxDepth = 1;
- }
- }
-
- /*
- * If we are dealing with a reference to an array element, push the
- * array element. Perform substitutions on it, just as is done
- * for quoted strings.
- */
-
- if (elName != NULL) {
- savedChar = elName[elNameChars];
- elName[elNameChars] = '\0';
- envPtr->pushSimpleWords = 1;
- result = TclCompileQuotes(interp, elName, elName+elNameChars,
- 0, flags, envPtr);
- elName[elNameChars] = savedChar;
- if (result != TCL_OK) {
- char msg[200];
- sprintf(msg, "\n (parsing index for array \"%.*s\")",
- TclMin(nameChars, 100), name);
- Tcl_AddObjErrorInfo(interp, msg, -1);
- goto done;
- }
- maxDepth += envPtr->maxStackDepth;
- }
- }
-
/*
- * If we are doing an assignment, push the new value.
+ * Free the old internal rep then convert the object to a
+ * bytecode object by making its internal rep point to the just
+ * compiled ByteCode.
*/
-
- if (isAssignment) {
- wordStart = argInfo.startArray[1]; /* start of 2nd arg word */
- envPtr->pushSimpleWords = 0; /* we will handle simple words */
- result = CompileWord(interp, wordStart, argInfo.endArray[1] + 1,
- flags, envPtr);
- if (result != TCL_OK) {
- goto done;
- }
- if (!envPtr->wordIsSimple) {
- /*
- * The value isn't simple. CompileWord already pushed it.
- */
-
- maxDepth += envPtr->maxStackDepth;
- } else {
- /*
- * The value is simple. See if the word represents an integer
- * whose formatted representation is the same as the word (e.g.,
- * this is true for 123 and -1 but not for 00005). If so, just
- * push an integer object.
- */
- char buf[40];
- long n;
-
- p = wordStart;
- if ((*wordStart == '"') || (*wordStart == '{')) {
- p++;
- }
- savedChar = p[envPtr->numSimpleWordChars];
- p[envPtr->numSimpleWordChars] = '\0';
- isCompilableInt = 0;
- if (TclLooksLikeInt(p)) {
- int code = TclGetLong(interp, p, &n);
- if (code == TCL_OK) {
- TclFormatInt(buf, n);
- if (strcmp(p, buf) == 0) {
- isCompilableInt = 1;
- objIndex = TclObjIndexForString(p,
- envPtr->numSimpleWordChars,
- /*allocStrRep*/ 0, /*inHeap*/ 0, envPtr);
- objPtr = envPtr->objArrayPtr[objIndex];
-
- Tcl_InvalidateStringRep(objPtr);
- objPtr->internalRep.longValue = n;
- objPtr->typePtr = &tclIntType;
- }
- } else {
- Tcl_ResetResult(interp);
- }
- }
- if (!isCompilableInt) {
- objIndex = TclObjIndexForString(p,
- envPtr->numSimpleWordChars, /*allocStrRep*/ 1,
- /*inHeap*/ 0, envPtr);
- }
- p[envPtr->numSimpleWordChars] = savedChar;
- TclEmitPush(objIndex, envPtr);
- maxDepth += 1;
- }
- }
-
- /*
- * Now emit instructions to set/retrieve the variable.
- */
-
- if (simpleVarName) {
- if (elName == NULL) { /* scalar */
- if (localIndex >= 0) {
- if (localIndex <= 255) {
- TclEmitInstUInt1((isAssignment?
- INST_STORE_SCALAR1 : INST_LOAD_SCALAR1),
- localIndex, envPtr);
- } else {
- TclEmitInstUInt4((isAssignment?
- INST_STORE_SCALAR4 : INST_LOAD_SCALAR4),
- localIndex, envPtr);
- }
- } else {
- TclEmitOpcode((isAssignment?
- INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK),
- envPtr);
- }
- } else { /* array */
- if (localIndex >= 0) {
- if (localIndex <= 255) {
- TclEmitInstUInt1((isAssignment?
- INST_STORE_ARRAY1 : INST_LOAD_ARRAY1),
- localIndex, envPtr);
- } else {
- TclEmitInstUInt4((isAssignment?
- INST_STORE_ARRAY4 : INST_LOAD_ARRAY4),
- localIndex, envPtr);
- }
- } else {
- TclEmitOpcode((isAssignment?
- INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK),
- envPtr);
- }
- }
- } else { /* non-simple variable name */
- TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), envPtr);
- }
-
- done:
- if (numWords == 0) {
- envPtr->termOffset = 0;
- } else {
- envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string);
+ if ((objPtr->typePtr != NULL) &&
+ (objPtr->typePtr->freeIntRepProc != NULL)) {
+ (*objPtr->typePtr->freeIntRepProc)(objPtr);
}
- envPtr->pushSimpleWords = savePushSimpleWords;
- envPtr->maxStackDepth = maxDepth;
- FreeArgInfo(&argInfo);
- return result;
+ objPtr->internalRep.otherValuePtr = (VOID *) codePtr;
+ objPtr->typePtr = &tclByteCodeType;
}
/*
*----------------------------------------------------------------------
*
- * TclCompileWhileCmd --
+ * LogCompilationInfo --
*
- * Procedure called to compile the "while" command.
+ * This procedure is invoked after an error occurs during compilation.
+ * It adds information to the "errorInfo" variable to describe the
+ * command that was being compiled when the error occurred.
*
* Results:
- * The return value is a standard Tcl result, which is TCL_OK if
- * compilation was successful. If an error occurs then the
- * interpreter's result contains a standard error message and TCL_ERROR
- * is returned. If compilation failed because the command is too
- * complex for TclCompileWhileCmd, TCL_OUT_LINE_COMPILE is returned
- * indicating that the while command should be compiled "out of line"
- * by emitting code to invoke its command procedure at runtime.
- *
- * envPtr->termOffset is filled in with the offset of the character in
- * "string" just after the last one successfully processed.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the "while" command.
+ * None.
*
* Side effects:
- * Instructions are added to envPtr to evaluate the "while" command
- * at runtime.
+ * Information about the command is added to errorInfo and the
+ * line number stored internally in the interpreter is set. If this
+ * is the first call to this procedure or Tcl_AddObjErrorInfo since
+ * an error occurred, then old information in errorInfo is
+ * deleted.
*
*----------------------------------------------------------------------
*/
-int
-TclCompileWhileCmd(interp, string, lastChar, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- char *string; /* The source string to compile. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds resulting instructions. */
+static void
+LogCompilationInfo(interp, script, command, length)
+ Tcl_Interp *interp; /* Interpreter in which to log the
+ * information. */
+ char *script; /* First character in script containing
+ * command (must be <= command). */
+ char *command; /* First character in command that
+ * generated the error. */
+ int length; /* Number of bytes in command (-1 means
+ * use all bytes up to first null byte). */
{
- register char *src = string;/* Points to current source char. */
- register int type; /* Current char's CHAR_TYPE type. */
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to execute cmd. */
- int range = -1; /* Index in the ExceptionRange array of the
- * ExceptionRange record for this loop. */
- JumpFixup jumpFalseFixup; /* Used to update or replace the ifFalse
- * jump after test when its target PC is
- * determined. */
- unsigned char *jumpPc;
- int jumpDist, jumpBackDist, jumpBackOffset, objIndex, result;
- int savePushSimpleWords = envPtr->pushSimpleWords;
-
- AdvanceToNextWord(src, envPtr);
- src += envPtr->termOffset;
- type = CHAR_TYPE(src, lastChar);
- if (type == TCL_COMMAND_END) {
- badArgs:
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: should be \"while test command\"", -1);
- result = TCL_ERROR;
- goto done;
- }
-
- /*
- * If the test expression is not enclosed in braces, don't compile
- * the while inline. As a result of Tcl's two level substitution
- * semantics for expressions, the expression might have a constant
- * value that results in the loop never executing, or executing forever.
- * Consider "set x 0; whie "$x > 5" {incr x}": the loop body
- * should never be executed.
- * NOTE: This is an overly aggressive test, since there are legitimate
- * literals that could be compiled but aren't in braces. However, until
- * the parser is integrated in 8.1, this is the simplest implementation.
- */
-
- if (*src != '{') {
- result = TCL_OUT_LINE_COMPILE;
- goto done;
- }
-
- /*
- * Create and initialize a ExceptionRange record to hold information
- * about this loop. This is used to implement break and continue.
- */
-
- envPtr->excRangeDepth++;
- envPtr->maxExcRangeDepth =
- TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth);
-
- range = CreateExceptionRange(LOOP_EXCEPTION_RANGE, envPtr);
- envPtr->excRangeArrayPtr[range].continueOffset = TclCurrCodeOffset();
-
- /*
- * Compile the next word: the test expression.
- */
-
- envPtr->pushSimpleWords = 1;
- result = CompileExprWord(interp, src, lastChar, flags, envPtr);
- if (result != TCL_OK) {
- if (result == TCL_ERROR) {
- Tcl_AddObjErrorInfo(interp,
- "\n (\"while\" test expression)", -1);
- }
- goto done;
- }
- maxDepth = envPtr->maxStackDepth;
- src += envPtr->termOffset;
-
- /*
- * Emit the ifFalse jump that terminates the while if the test was
- * false. We emit a one byte (relative) jump here, and replace it
- * later with a four byte jump if the jump target is more than
- * 127 bytes away.
- */
-
- TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
-
- /*
- * Compile the loop body word inline. Also register the loop body's
- * starting PC offset and byte length in the its ExceptionRange record.
- */
-
- AdvanceToNextWord(src, envPtr);
- src += envPtr->termOffset;
- type = CHAR_TYPE(src, lastChar);
- if (type == TCL_COMMAND_END) {
- goto badArgs;
- }
-
- envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset();
- result = CompileCmdWordInline(interp, src, lastChar,
- flags, envPtr);
- if (result != TCL_OK) {
- if (result == TCL_ERROR) {
- char msg[60];
- sprintf(msg, "\n (\"while\" body line %d)", interp->errorLine);
- Tcl_AddObjErrorInfo(interp, msg, -1);
- }
- goto done;
- }
- maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
- src += envPtr->termOffset;
- envPtr->excRangeArrayPtr[range].numCodeBytes =
- (TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset);
-
- /*
- * Discard the loop body's result.
- */
-
- TclEmitOpcode(INST_POP, envPtr);
-
- /*
- * Emit the unconditional jump back to the test at the top of the
- * loop. We generate a four byte jump if the distance to the while's
- * test is greater than 120 bytes. This is conservative, and ensures
- * that we won't have to replace this unconditional jump if we later
- * need to replace the ifFalse jump with a four-byte jump.
- */
-
- jumpBackOffset = TclCurrCodeOffset();
- jumpBackDist =
- (jumpBackOffset - envPtr->excRangeArrayPtr[range].continueOffset);
- if (jumpBackDist > 120) {
- TclEmitInstInt4(INST_JUMP4, /*offset*/ -jumpBackDist, envPtr);
- } else {
- TclEmitInstInt1(INST_JUMP1, /*offset*/ -jumpBackDist, envPtr);
- }
-
- /*
- * Now that we know the target of the jumpFalse after the test, update
- * it with the correct distance. If the distance is too great (more
- * than 127 bytes), replace that jump with a four byte instruction and
- * move the instructions after the jump down.
- */
-
- jumpDist = (TclCurrCodeOffset() - jumpFalseFixup.codeOffset);
- if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) {
- /*
- * Update the loop body's starting PC offset since it moved down.
- */
-
- envPtr->excRangeArrayPtr[range].codeOffset += 3;
+ char buffer[200];
+ register char *p;
+ char *ellipsis = "";
+ Interp *iPtr = (Interp *) interp;
+ if (iPtr->flags & ERR_ALREADY_LOGGED) {
/*
- * Update the distance for the unconditional jump back to the test
- * at the top of the loop since it moved down 3 bytes too.
+ * Someone else has already logged error information for this
+ * command; we shouldn't add anything more.
*/
- jumpBackOffset += 3;
- jumpPc = (envPtr->codeStart + jumpBackOffset);
- if (jumpBackDist > 120) {
- jumpBackDist += 3;
- TclUpdateInstInt4AtPc(INST_JUMP4, /*offset*/ -jumpBackDist,
- jumpPc);
- } else {
- jumpBackDist += 3;
- TclUpdateInstInt1AtPc(INST_JUMP1, /*offset*/ -jumpBackDist,
- jumpPc);
- }
- }
-
- /*
- * The current PC offset (after the loop's body) is the loop's
- * break target.
- */
-
- envPtr->excRangeArrayPtr[range].breakOffset = TclCurrCodeOffset();
-
- /*
- * Push an empty string object as the while command's result.
- */
-
- objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0, /*inHeap*/ 0,
- envPtr);
- TclEmitPush(objIndex, envPtr);
- if (maxDepth == 0) {
- maxDepth = 1;
+ return;
}
/*
- * Skip over white space until the end of the command.
+ * Compute the line number where the error occurred.
*/
- type = CHAR_TYPE(src, lastChar);
- if (type != TCL_COMMAND_END) {
- AdvanceToNextWord(src, envPtr);
- src += envPtr->termOffset;
- type = CHAR_TYPE(src, lastChar);
- if (type != TCL_COMMAND_END) {
- goto badArgs;
+ iPtr->errorLine = 1;
+ for (p = script; p != command; p++) {
+ if (*p == '\n') {
+ iPtr->errorLine++;
}
}
- done:
- envPtr->termOffset = (src - string);
- envPtr->pushSimpleWords = savePushSimpleWords;
- envPtr->maxStackDepth = maxDepth;
- if (range != -1) {
- envPtr->excRangeDepth--;
- }
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * CompileExprWord --
- *
- * Procedure that compiles a Tcl expression in a command word.
- *
- * Results:
- * The return value is a standard Tcl result, which is TCL_OK unless
- * there was an error while compiling string. If an error occurs then
- * the interpreter's result contains a standard error message.
- *
- * envPtr->termOffset is filled in with the offset of the character in
- * "string" just after the last one successfully processed.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the "expr" word.
- *
- * Side effects:
- * Instructions are added to envPtr to evaluate the expression word
- * at runtime.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-CompileExprWord(interp, string, lastChar, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- char *string; /* The source string to compile. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds resulting instructions. */
-{
- register char *src = string;/* Points to current source char. */
- register int type; /* Current char's CHAR_TYPE type. */
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to execute the expression. */
- int nestedCmd = (flags & TCL_BRACKET_TERM);
- /* 1 if script being compiled is a nested
- * command and is terminated by a ']';
- * otherwise 0. */
- char *first, *last; /* Points to the first and last significant
- * characters of the word. */
- char savedChar; /* Holds the character termporarily replaced
- * by a null character during compilation
- * of the expression. */
- int inlineCode; /* 1 if inline "optimistic" code is
- * emitted for the expression; else 0. */
- int range = -1; /* If we inline compile an un-{}'d
- * expression, the index for its catch range
- * record in the ExceptionRange array.
- * Initialized to enable proper cleanup. */
- JumpFixup jumpFixup; /* Used to emit the "success" jump after
- * the inline expression code. */
- char *p;
- char c;
- int savePushSimpleWords = envPtr->pushSimpleWords;
- int saveExprIsJustVarRef = envPtr->exprIsJustVarRef;
- int saveExprIsComparison = envPtr->exprIsComparison;
- int numChars, result;
-
/*
- * Skip over leading white space.
+ * Create an error message to add to errorInfo, including up to a
+ * maximum number of characters of the command.
*/
- AdvanceToNextWord(src, envPtr);
- src += envPtr->termOffset;
- type = CHAR_TYPE(src, lastChar);
- if (type == TCL_COMMAND_END) {
- badArgs:
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "malformed expression word", -1);
- result = TCL_ERROR;
- goto done;
+ if (length < 0) {
+ length = strlen(command);
}
-
- /*
- * If the word is enclosed in {}s, we may strip them off and safely
- * compile the expression into an inline sequence of instructions using
- * TclCompileExpr. We know these instructions will have the right Tcl7.x
- * expression semantics.
- *
- * Otherwise, if the word is not enclosed in {}s, we may need to call
- * the expr command (Tcl_ExprObjCmd) at runtime. This recompiles the
- * expression each time (typically) and so is slow. However, there are
- * some circumstances where we can still compile inline instructions
- * "optimistically" and check, during their execution, for double
- * substitutions (these appear as nonnumeric operands). We check for any
- * backslash or command substitutions. If none appear, and only variable
- * substitutions are found, we generate inline instructions.
- *
- * For now, if the expression is not enclosed in {}s, we call the expr
- * command at runtime if either command or backslash substitutions
- * appear (but not if only variable substitutions appear).
- */
-
- if (*src == '{') {
- /*
- * Inline compile the expression inside {}s.
- */
-
- first = src+1;
- src = TclWordEnd(src, lastChar, nestedCmd, NULL);
- if (*src == 0) {
- goto badArgs;
- }
- if (*src != '}') {
- goto badArgs;
- }
- last = (src-1);
-
- numChars = (last - first + 1);
- savedChar = first[numChars];
- first[numChars] = '\0';
- result = TclCompileExpr(interp, first, first+numChars,
- flags, envPtr);
- first[numChars] = savedChar;
-
- src++;
- maxDepth = envPtr->maxStackDepth;
- } else {
- /*
- * No braces. If the expression is enclosed in '"'s, call the expr
- * cmd at runtime. Otherwise, scan the word's characters looking for
- * any '['s or (for now) '\'s. If any are found, just call expr cmd
- * at runtime.
- */
-
- first = src;
- last = TclWordEnd(first, lastChar, nestedCmd, NULL);
- if (*last == 0) { /* word doesn't end properly. */
- src = last;
- goto badArgs;
- }
-
- inlineCode = 1;
- if ((*first == '"') && (*last == '"')) {
- inlineCode = 0;
- } else {
- for (p = first; p <= last; p++) {
- c = *p;
- if ((c == '[') || (c == '\\')) {
- inlineCode = 0;
- break;
- }
- }
- }
-
- if (inlineCode) {
- /*
- * Inline compile the expression inside a "catch" so that a
- * runtime error will back off to make a (slow) call on expr.
- */
-
- int startCodeOffset = (envPtr->codeNext - envPtr->codeStart);
- int startRangeNext = envPtr->excRangeArrayNext;
-
- /*
- * Create a ExceptionRange record to hold information about
- * the "catch" range for the expression's inline code. Also
- * emit the instruction to mark the start of the range.
- */
-
- envPtr->excRangeDepth++;
- envPtr->maxExcRangeDepth =
- TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth);
- range = CreateExceptionRange(CATCH_EXCEPTION_RANGE, envPtr);
- TclEmitInstUInt4(INST_BEGIN_CATCH4, range, envPtr);
-
- /*
- * Inline compile the expression.
- */
-
- envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset();
- numChars = (last - first + 1);
- savedChar = first[numChars];
- first[numChars] = '\0';
- result = TclCompileExpr(interp, first, first + numChars,
- flags, envPtr);
- first[numChars] = savedChar;
-
- envPtr->excRangeArrayPtr[range].numCodeBytes =
- TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset;
-
- if ((result != TCL_OK) || (envPtr->exprIsJustVarRef)
- || (envPtr->exprIsComparison)) {
- /*
- * We must call the expr command at runtime. Either there
- * was a compilation error or the inline code might fail to
- * give the correct 2 level substitution semantics.
- *
- * The latter can happen if the expression consisted of just
- * a single variable reference or if the top-level operator
- * in the expr is a comparison (which might operate on
- * strings). In the latter case, the expression's code might
- * execute (apparently) successfully but produce the wrong
- * result. We depend on its execution failing if a second
- * level of substitutions is required. This causes the
- * "catch" code we generate around the inline code to back
- * off to a call on the expr command at runtime, and this
- * always gives the right 2 level substitution semantics.
- *
- * We delete the inline code by backing up the code pc and
- * catch index. Note that if there was a compilation error,
- * we can't report the error yet since the expression might
- * be valid after the second round of substitutions.
- */
-
- envPtr->codeNext = (envPtr->codeStart + startCodeOffset);
- envPtr->excRangeArrayNext = startRangeNext;
- inlineCode = 0;
- } else {
- TclEmitOpcode(INST_END_CATCH, envPtr); /* for ok case */
- TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
- envPtr->excRangeArrayPtr[range].catchOffset = TclCurrCodeOffset();
- TclEmitOpcode(INST_END_CATCH, envPtr); /* for error case */
- }
- }
-
- /*
- * Arrange to call expr at runtime with the (already substituted
- * once) expression word on the stack.
- */
-
- envPtr->pushSimpleWords = 1;
- result = CompileWord(interp, first, lastChar, flags, envPtr);
- src += envPtr->termOffset;
- maxDepth = envPtr->maxStackDepth;
- if (result == TCL_OK) {
- TclEmitOpcode(INST_EXPR_STK, envPtr);
- }
-
- /*
- * If emitting inline code for this non-{}'d expression, update
- * the target of the jump after that inline code.
- */
-
- if (inlineCode) {
- int jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset);
- if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) {
- /*
- * Update the inline expression code's catch ExceptionRange
- * target since it, being after the jump, also moved down.
- */
-
- envPtr->excRangeArrayPtr[range].catchOffset += 3;
- }
- }
- } /* if expression isn't in {}s */
-
- done:
- if (range != -1) {
- envPtr->excRangeDepth--;
+ if (length > 150) {
+ length = 150;
+ ellipsis = "...";
}
- envPtr->termOffset = (src - string);
- envPtr->maxStackDepth = maxDepth;
- envPtr->pushSimpleWords = savePushSimpleWords;
- envPtr->exprIsJustVarRef = saveExprIsJustVarRef;
- envPtr->exprIsComparison = saveExprIsComparison;
- return result;
+ sprintf(buffer, "\n while compiling\n\"%.*s%s\"",
+ length, command, ellipsis);
+ Tcl_AddObjErrorInfo(interp, buffer, -1);
}
/*
*----------------------------------------------------------------------
*
- * CompileCmdWordInline --
- *
- * Procedure that compiles a Tcl command word inline. If the word is
- * enclosed in quotes or braces, we call TclCompileString to compile it
- * after stripping them off. Otherwise, we normally push the word's
- * value and call eval at runtime, but if the word is just a sequence
- * of alphanumeric characters, we emit an invoke instruction
- * directly. This procedure assumes that string points to the start of
- * the word to compile.
- *
- * Results:
- * The return value is a standard Tcl result, which is TCL_OK unless
- * there was an error while compiling string. If an error occurs then
- * the interpreter's result contains a standard error message.
- *
- * envPtr->termOffset is filled in with the offset of the character in
- * "string" just after the last one successfully processed.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the command.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the command word
- * at runtime.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-CompileCmdWordInline(interp, string, lastChar, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- char *string; /* The source string to compile. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds resulting instructions. */
-{
- Interp *iPtr = (Interp *) interp;
- register char *src = string;/* Points to current source char. */
- register int type; /* Current char's CHAR_TYPE type. */
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to execute cmd. */
- char *termPtr; /* Points to char that terminated braced
- * string. */
- char savedChar; /* Holds the character termporarily replaced
- * by a null character during compilation
- * of the command. */
- int savePushSimpleWords = envPtr->pushSimpleWords;
- int objIndex;
- int result = TCL_OK;
- register char c;
-
- type = CHAR_TYPE(src, lastChar);
- if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
- src++;
- envPtr->pushSimpleWords = 0;
- if (type == TCL_QUOTE) {
- result = TclCompileQuotes(interp, src, lastChar,
- '"', flags, envPtr);
- } else {
- result = CompileBraces(interp, src, lastChar, flags, envPtr);
- }
- if (result != TCL_OK) {
- goto done;
- }
-
- /*
- * Make sure the terminating character is the end of word.
- */
-
- termPtr = (src + envPtr->termOffset);
- c = *termPtr;
- if ((c == '\\') && (*(termPtr+1) == '\n')) {
- /*
- * Line is continued on next line; the backslash-newline turns
- * into space, which terminates the word.
- */
- } else {
- type = CHAR_TYPE(termPtr, lastChar);
- if ((type != TCL_SPACE) && (type != TCL_COMMAND_END)) {
- Tcl_ResetResult(interp);
- if (*(src-1) == '"') {
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "extra characters after close-quote", -1);
- } else {
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "extra characters after close-brace", -1);
- }
- result = TCL_ERROR;
- goto done;
- }
- }
-
- if (envPtr->wordIsSimple) {
- /*
- * A simple word enclosed in "" or {}s. Call TclCompileString to
- * compile it inline. Add a null character after the end of the
- * quoted or braced string: i.e., at the " or }. Turn the
- * flag bit TCL_BRACKET_TERM off since the recursively
- * compiled subcommand is now terminated by a null character.
- */
- char *closeCharPos = (termPtr - 1);
-
- savedChar = *closeCharPos;
- *closeCharPos = '\0';
- result = TclCompileString(interp, src, closeCharPos,
- (flags & ~TCL_BRACKET_TERM), envPtr);
- *closeCharPos = savedChar;
- if (result != TCL_OK) {
- goto done;
- }
- } else {
- /*
- * The braced string contained a backslash-newline. Call eval
- * at runtime.
- */
- TclEmitOpcode(INST_EVAL_STK, envPtr);
- }
- src = termPtr;
- maxDepth = envPtr->maxStackDepth;
- } else {
- /*
- * Not a braced or quoted string. We normally push the word's
- * value and call eval at runtime. However, if the word is just
- * a sequence of alphanumeric characters, we call its compile
- * procedure, if any, or otherwise just emit an invoke instruction.
- */
-
- char *p = src;
- c = *p;
- while (isalnum(UCHAR(c)) || (c == '_')) {
- p++;
- c = *p;
- }
- type = CHAR_TYPE(p, lastChar);
- if ((p > src) && (type == TCL_COMMAND_END)) {
- /*
- * Look for a compile procedure and call it. Otherwise emit an
- * invoke instruction to call the command at runtime.
- */
-
- Tcl_Command cmd;
- Command *cmdPtr = NULL;
- int wasCompiled = 0;
-
- savedChar = *p;
- *p = '\0';
-
- cmd = Tcl_FindCommand(interp, src, (Tcl_Namespace *) NULL,
- /*flags*/ 0);
- if (cmd != (Tcl_Command) NULL) {
- cmdPtr = (Command *) cmd;
- }
- if (cmdPtr != NULL && cmdPtr->compileProc != NULL) {
- *p = savedChar;
- src = p;
- iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS
- | ERROR_CODE_SET);
- result = (*(cmdPtr->compileProc))(interp, src, lastChar, flags, envPtr);
- if (result != TCL_OK) {
- goto done;
- }
- wasCompiled = 1;
- src += envPtr->termOffset;
- maxDepth = envPtr->maxStackDepth;
- }
- if (!wasCompiled) {
- objIndex = TclObjIndexForString(src, p-src,
- /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- *p = savedChar;
- TclEmitPush(objIndex, envPtr);
- TclEmitInstUInt1(INST_INVOKE_STK1, 1, envPtr);
- src = p;
- maxDepth = 1;
- }
- } else {
- /*
- * Push the word and call eval at runtime.
- */
-
- envPtr->pushSimpleWords = 1;
- result = CompileWord(interp, src, lastChar, flags, envPtr);
- if (result != TCL_OK) {
- goto done;
- }
- TclEmitOpcode(INST_EVAL_STK, envPtr);
- src += envPtr->termOffset;
- maxDepth = envPtr->maxStackDepth;
- }
- }
-
- done:
- envPtr->termOffset = (src - string);
- envPtr->maxStackDepth = maxDepth;
- envPtr->pushSimpleWords = savePushSimpleWords;
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * LookupCompiledLocal --
+ * TclFindCompiledLocal --
*
* This procedure is called at compile time to look up and optionally
* allocate an entry ("slot") for a variable in a procedure's array of
@@ -6586,39 +1728,37 @@ CompileCmdWordInline(interp, string, lastChar, flags, envPtr)
* referenced using their slot index.)
*
* Results:
- * If createIfNew is 0 (false) and the name is non-NULL, then if the
- * variable is found, the index of its entry in the procedure's array
- * of local variables is returned; otherwise -1 is returned.
- * If name is NULL, the index of a new temporary variable is returned.
- * Finally, if createIfNew is 1 and name is non-NULL, the index of a
- * new entry is returned.
+ * If create is 0 and the name is non-NULL, then if the variable is
+ * found, the index of its entry in the procedure's array of local
+ * variables is returned; otherwise -1 is returned. If name is NULL,
+ * the index of a new temporary variable is returned. Finally, if
+ * create is 1 and name is non-NULL, the index of a new entry is
+ * returned.
*
* Side effects:
- * Creates and registers a new local variable if createIfNew is 1 and
+ * Creates and registers a new local variable if create is 1 and
* the variable is unknown, or if the name is NULL.
*
*----------------------------------------------------------------------
*/
-static int
-LookupCompiledLocal(name, nameChars, createIfNew, flagsIfCreated, procPtr)
+int
+TclFindCompiledLocal(name, nameBytes, create, flags, procPtr)
register char *name; /* Points to first character of the name of
* a scalar or array variable. If NULL, a
* temporary var should be created. */
- int nameChars; /* The length of the name excluding the
- * terminating null character. */
- int createIfNew; /* 1 to allocate a local frame entry for the
- * variable if it is new. */
- int flagsIfCreated; /* Flag bits for the compiled local if
+ int nameBytes; /* Number of bytes in the name. */
+ int create; /* If 1, allocate a local frame entry for
+ * the variable if it is new. */
+ int flags; /* Flag bits for the compiled local if
* created. Only VAR_SCALAR, VAR_ARRAY, and
* VAR_LINK make sense. */
register Proc *procPtr; /* Points to structure describing procedure
* containing the variable reference. */
{
register CompiledLocal *localPtr;
- int localIndex = -1;
+ int localVar = -1;
register int i;
- int localCt;
/*
* If not creating a temporary, does a local variable of the specified
@@ -6626,14 +1766,14 @@ LookupCompiledLocal(name, nameChars, createIfNew, flagsIfCreated, procPtr)
*/
if (name != NULL) {
- localCt = procPtr->numCompiledLocals;
+ int localCt = procPtr->numCompiledLocals;
localPtr = procPtr->firstLocalPtr;
for (i = 0; i < localCt; i++) {
if (!TclIsVarTemporary(localPtr)) {
char *localName = localPtr->name;
if ((name[0] == localName[0])
- && (nameChars == localPtr->nameLength)
- && (strncmp(name, localName, (unsigned) nameChars) == 0)) {
+ && (nameBytes == localPtr->nameLength)
+ && (strncmp(name, localName, (unsigned) nameBytes) == 0)) {
return i;
}
}
@@ -6645,11 +1785,11 @@ LookupCompiledLocal(name, nameChars, createIfNew, flagsIfCreated, procPtr)
* Create a new variable if appropriate.
*/
- if (createIfNew || (name == NULL)) {
- localIndex = procPtr->numCompiledLocals;
+ if (create || (name == NULL)) {
+ localVar = procPtr->numCompiledLocals;
localPtr = (CompiledLocal *) ckalloc((unsigned)
(sizeof(CompiledLocal) - sizeof(localPtr->name)
- + nameChars+1));
+ + nameBytes+1));
if (procPtr->firstLocalPtr == NULL) {
procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
} else {
@@ -6657,22 +1797,23 @@ LookupCompiledLocal(name, nameChars, createIfNew, flagsIfCreated, procPtr)
procPtr->lastLocalPtr = localPtr;
}
localPtr->nextPtr = NULL;
- localPtr->nameLength = nameChars;
- localPtr->frameIndex = localIndex;
- localPtr->flags = flagsIfCreated;
+ localPtr->nameLength = nameBytes;
+ localPtr->frameIndex = localVar;
+ localPtr->flags = flags;
if (name == NULL) {
localPtr->flags |= VAR_TEMPORARY;
}
localPtr->defValuePtr = NULL;
- localPtr->resolveInfo = NULL;
-
+ localPtr->resolveInfo = NULL;
+
if (name != NULL) {
- memcpy((VOID *) localPtr->name, (VOID *) name, (size_t) nameChars);
+ memcpy((VOID *) localPtr->name, (VOID *) name,
+ (size_t) nameBytes);
}
- localPtr->name[nameChars] = '\0';
+ localPtr->name[nameBytes] = '\0';
procPtr->numCompiledLocals++;
}
- return localIndex;
+ return localVar;
}
/*
@@ -6760,7 +1901,7 @@ TclInitCompiledLocals(interp, framePtr, nsPtr)
if (resVarInfo && resVarInfo->fetchProc) {
resolvedVarPtr = (Var*) (*resVarInfo->fetchProc)(interp,
- resVarInfo);
+ resVarInfo);
}
if (resolvedVarPtr) {
@@ -6791,277 +1932,6 @@ TclInitCompiledLocals(interp, framePtr, nsPtr)
/*
*----------------------------------------------------------------------
*
- * AdvanceToNextWord --
- *
- * This procedure is called to skip over any leading white space at the
- * start of a word. Note that a backslash-newline is treated as a
- * space.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Updates envPtr->termOffset with the offset of the first
- * character in "string" that was not white space or a
- * backslash-newline. This might be the offset of the character that
- * ends the command: a newline, null, semicolon, or close-bracket.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-AdvanceToNextWord(string, envPtr)
- char *string; /* The source string to compile. */
- CompileEnv *envPtr; /* Holds resulting instructions. */
-{
- register char *src; /* Points to current source char. */
- register int type; /* Current char's CHAR_TYPE type. */
-
- src = string;
- type = CHAR_TYPE(src, src+1);
- while (type & (TCL_SPACE | TCL_BACKSLASH)) {
- if (type == TCL_BACKSLASH) {
- if (src[1] == '\n') {
- src += 2;
- } else {
- break; /* exit loop; no longer white space */
- }
- } else {
- src++;
- }
- type = CHAR_TYPE(src, src+1);
- }
- envPtr->termOffset = (src - string);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_Backslash --
- *
- * Figure out how to handle a backslash sequence.
- *
- * Results:
- * The return value is the character that should be substituted
- * in place of the backslash sequence that starts at src. If
- * readPtr isn't NULL then it is filled in with a count of the
- * number of characters in the backslash sequence.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-char
-Tcl_Backslash(src, readPtr)
- CONST char *src; /* Points to the backslash character of
- * a backslash sequence. */
- int *readPtr; /* Fill in with number of characters read
- * from src, unless NULL. */
-{
- CONST char *p = src + 1;
- char result;
- int count;
-
- count = 2;
-
- switch (*p) {
- /*
- * Note: in the conversions below, use absolute values (e.g.,
- * 0xa) rather than symbolic values (e.g. \n) that get converted
- * by the compiler. It's possible that compilers on some
- * platforms will do the symbolic conversions differently, which
- * could result in non-portable Tcl scripts.
- */
-
- case 'a':
- result = 0x7;
- break;
- case 'b':
- result = 0x8;
- break;
- case 'f':
- result = 0xc;
- break;
- case 'n':
- result = 0xa;
- break;
- case 'r':
- result = 0xd;
- break;
- case 't':
- result = 0x9;
- break;
- case 'v':
- result = 0xb;
- break;
- case 'x':
- if (isxdigit(UCHAR(p[1]))) {
- char *end;
-
- result = (char) strtoul(p+1, &end, 16);
- count = end - src;
- } else {
- count = 2;
- result = 'x';
- }
- break;
- case '\n':
- do {
- p++;
- } while ((*p == ' ') || (*p == '\t'));
- result = ' ';
- count = p - src;
- break;
- case 0:
- result = '\\';
- count = 1;
- break;
- default:
- if (isdigit(UCHAR(*p))) {
- result = (char)(*p - '0');
- p++;
- if (!isdigit(UCHAR(*p))) {
- break;
- }
- count = 3;
- result = (char)((result << 3) + (*p - '0'));
- p++;
- if (!isdigit(UCHAR(*p))) {
- break;
- }
- count = 4;
- result = (char)((result << 3) + (*p - '0'));
- break;
- }
- result = *p;
- count = 2;
- break;
- }
-
- if (readPtr != NULL) {
- *readPtr = count;
- }
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclObjIndexForString --
- *
- * Procedure to find, or if necessary create, an object in a
- * CompileEnv's object array that has a string representation
- * matching the argument string.
- *
- * Results:
- * The index in the CompileEnv's object array of an object with a
- * string representation matching the argument "string". The object is
- * created if necessary. If inHeap is 1, then string is heap allocated
- * and ownership of the string is passed to TclObjIndexForString;
- * otherwise, the string is owned by the caller and must not be
- * modified or freed by TclObjIndexForString. Typically, a caller sets
- * inHeap 1 if string is an already heap-allocated buffer holding the
- * result of backslash substitutions.
- *
- * Side effects:
- * A new Tcl object will be created if no existing object matches the
- * input string. If allocStrRep is 1 then if a new object is created,
- * its string representation is allocated in the heap, else it is left
- * NULL. If inHeap is 1, this procedure is given ownership of the
- * string: if an object is created and allocStrRep is 1 then its
- * string representation is set directly from string, otherwise
- * the string is freed.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclObjIndexForString(string, length, allocStrRep, inHeap, envPtr)
- register char *string; /* Points to string for which an object is
- * found or created in CompileEnv's object
- * array. */
- int length; /* Length of string. */
- int allocStrRep; /* If 1 then the object's string rep should
- * be allocated in the heap. */
- int inHeap; /* If 1 then string is heap allocated and
- * its ownership is passed to
- * TclObjIndexForString. */
- CompileEnv *envPtr; /* Points to the CompileEnv in whose object
- * array an object is found or created. */
-{
- register Tcl_Obj *objPtr; /* Points to the object created for
- * the string, if one was created. */
- int objIndex; /* Index of matching object. */
- Tcl_HashEntry *hPtr;
- int strLength, new;
-
- /*
- * Look up the string in the code's object hashtable. If found, just
- * return the associated object array index. Note that if the string
- * has embedded nulls, we don't create a hash table entry. This
- * should be fixed, but we need to update hash tables, first.
- */
-
- strLength = strlen(string);
- if (length == -1) {
- length = strLength;
- }
- if (strLength != length) {
- hPtr = NULL;
- } else {
- hPtr = Tcl_CreateHashEntry(&envPtr->objTable, string, &new);
- if (!new) { /* already in object table and array */
- objIndex = (int) Tcl_GetHashValue(hPtr);
- if (inHeap) {
- ckfree(string);
- }
- return objIndex;
- }
- }
-
- /*
- * Create a new object holding the string, add it to the object array,
- * and register its index in the object hashtable.
- */
-
- objPtr = Tcl_NewObj();
- if (allocStrRep) {
- if (inHeap) { /* use input string for obj's string rep */
- objPtr->bytes = string;
- } else {
- if (length > 0) {
- objPtr->bytes = ckalloc((unsigned) length + 1);
- memcpy((VOID *) objPtr->bytes, (VOID *) string,
- (size_t) length);
- objPtr->bytes[length] = '\0';
- }
- }
- objPtr->length = length;
- } else { /* leave the string rep NULL */
- if (inHeap) {
- ckfree(string);
- }
- }
-
- if (envPtr->objArrayNext >= envPtr->objArrayEnd) {
- ExpandObjectArray(envPtr);
- }
- objIndex = envPtr->objArrayNext;
- envPtr->objArrayPtr[objIndex] = objPtr;
- Tcl_IncrRefCount(objPtr);
- envPtr->objArrayNext++;
-
- if (hPtr) {
- Tcl_SetHashValue(hPtr, objIndex);
- }
- return objIndex;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* TclExpandCodeArray --
*
* Procedure that uses malloc to allocate more storage for a
@@ -7090,7 +1960,7 @@ TclExpandCodeArray(envPtr)
* (envPtr->codeNext - 1) [inclusive].
*/
- size_t currBytes = TclCurrCodeOffset();
+ size_t currBytes = (envPtr->codeNext - envPtr->codeStart);
size_t newBytes = 2*(envPtr->codeEnd - envPtr->codeStart);
unsigned char *newPtr = (unsigned char *) ckalloc((unsigned) newBytes);
@@ -7112,57 +1982,6 @@ TclExpandCodeArray(envPtr)
/*
*----------------------------------------------------------------------
*
- * ExpandObjectArray --
- *
- * Procedure that uses malloc to allocate more storage for a
- * CompileEnv's object array.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The object array in *envPtr is reallocated to a new array of
- * double the size, and if envPtr->mallocedObjArray is non-zero the
- * old array is freed. Tcl_Obj pointers are copied from the old array
- * to the new one.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-ExpandObjectArray(envPtr)
- CompileEnv *envPtr; /* Points to the CompileEnv whose object
- * array must be enlarged. */
-{
- /*
- * envPtr->objArrayNext is equal to envPtr->objArrayEnd. The currently
- * allocated Tcl_Obj pointers are stored between elements
- * 0 and (envPtr->objArrayNext - 1) [inclusive] in the object array
- * pointed to by objArrayPtr.
- */
-
- size_t currBytes = envPtr->objArrayNext * sizeof(Tcl_Obj *);
- int newElems = 2*envPtr->objArrayEnd;
- size_t newBytes = newElems * sizeof(Tcl_Obj *);
- Tcl_Obj **newPtr = (Tcl_Obj **) ckalloc((unsigned) newBytes);
-
- /*
- * Copy from old object array to new, free old object array if needed,
- * and mark new object array as malloced.
- */
-
- memcpy((VOID *) newPtr, (VOID *) envPtr->objArrayPtr, currBytes);
- if (envPtr->mallocedObjArray) {
- ckfree((char *) envPtr->objArrayPtr);
- }
- envPtr->objArrayPtr = (Tcl_Obj **) newPtr;
- envPtr->objArrayEnd = newElems;
- envPtr->mallocedObjArray = 1;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* EnterCmdStartData --
*
* Registers the starting source and bytecode location of a
@@ -7225,14 +2044,14 @@ EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset)
if (cmdIndex > 0) {
if (codeOffset < envPtr->cmdMapPtr[cmdIndex-1].codeOffset) {
- panic("EnterCmdStartData: cmd map table not sorted by code offset");
+ panic("EnterCmdStartData: cmd map not sorted by code offset");
}
}
cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]);
cmdLocPtr->codeOffset = codeOffset;
cmdLocPtr->srcOffset = srcOffset;
- cmdLocPtr->numSrcChars = -1;
+ cmdLocPtr->numSrcBytes = -1;
cmdLocPtr->numCodeBytes = -1;
}
@@ -7258,248 +2077,38 @@ EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset)
*/
static void
-EnterCmdExtentData(envPtr, cmdIndex, numSrcChars, numCodeBytes)
+EnterCmdExtentData(envPtr, cmdIndex, numSrcBytes, numCodeBytes)
CompileEnv *envPtr; /* Points to the compilation environment
* structure in which to enter command
* location information. */
int cmdIndex; /* Index of the command whose source and
* code length data is being set. */
- int numSrcChars; /* Number of command source chars. */
+ int numSrcBytes; /* Number of command source chars. */
int numCodeBytes; /* Offset of last byte of command code. */
{
CmdLocation *cmdLocPtr;
if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) {
- panic("EnterCmdStartData: bad command index %d\n", cmdIndex);
+ panic("EnterCmdExtentData: bad command index %d\n", cmdIndex);
}
if (cmdIndex > envPtr->cmdMapEnd) {
- panic("EnterCmdStartData: no start data registered for command with index %d\n", cmdIndex);
+ panic("EnterCmdExtentData: missing start data for command %d\n",
+ cmdIndex);
}
cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]);
- cmdLocPtr->numSrcChars = numSrcChars;
+ cmdLocPtr->numSrcBytes = numSrcBytes;
cmdLocPtr->numCodeBytes = numCodeBytes;
}
/*
*----------------------------------------------------------------------
*
- * InitArgInfo --
- *
- * Initializes a ArgInfo structure to hold information about
- * some number of argument words in a command.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The ArgInfo structure is initialized.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-InitArgInfo(argInfoPtr)
- register ArgInfo *argInfoPtr; /* Points to the ArgInfo structure
- * to initialize. */
-{
- argInfoPtr->numArgs = 0;
- argInfoPtr->startArray = argInfoPtr->staticStartSpace;
- argInfoPtr->endArray = argInfoPtr->staticEndSpace;
- argInfoPtr->allocArgs = ARGINFO_INIT_ENTRIES;
- argInfoPtr->mallocedArrays = 0;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * CollectArgInfo --
- *
- * Procedure to scan the argument words of a command and record the
- * start and finish of each argument word in a ArgInfo structure.
- *
- * Results:
- * The return value is a standard Tcl result, which is TCL_OK unless
- * there was an error while scanning string. If an error occurs then
- * the interpreter's result contains a standard error message.
- *
- * Side effects:
- * If necessary, the argument start and end arrays in *argInfoPtr
- * are grown and reallocated to a new arrays of double the size, and
- * if argInfoPtr->mallocedArray is non-zero the old arrays are freed.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-CollectArgInfo(interp, string, lastChar, flags, argInfoPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- char *string; /* The source command string to scan. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
- register ArgInfo *argInfoPtr;
- /* Points to the ArgInfo structure in which
- * to record the arg word information. */
-{
- register char *src = string;/* Points to current source char. */
- register int type; /* Current char's CHAR_TYPE type. */
- int nestedCmd = (flags & TCL_BRACKET_TERM);
- /* 1 if string being scanned is a nested
- * command and is terminated by a ']';
- * otherwise 0. */
- int scanningArgs; /* 1 if still scanning argument words to
- * determine their start and end. */
- char *wordStart, *wordEnd; /* Points to the first and last significant
- * characters of each word. */
- CompileEnv tempCompEnv; /* Only used to hold the termOffset field
- * updated by AdvanceToNextWord. */
- char *prev;
-
- argInfoPtr->numArgs = 0;
- scanningArgs = 1;
- while (scanningArgs) {
- AdvanceToNextWord(src, &tempCompEnv);
- src += tempCompEnv.termOffset;
- type = CHAR_TYPE(src, lastChar);
-
- if ((type == TCL_COMMAND_END) && ((*src != ']') || nestedCmd)) {
- break; /* done collecting argument words */
- } else if (*src == '"') {
- wordStart = src;
- src = TclWordEnd(src, lastChar, nestedCmd, NULL);
- if (src == lastChar) {
- badStringTermination:
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "quoted string doesn't terminate properly", -1);
- return TCL_ERROR;
- }
- prev = (src-1);
- if (*src == '"') {
- wordEnd = src;
- src++;
- } else if ((*src == ';') && (*prev == '"')) {
- scanningArgs = 0;
- wordEnd = prev;
- } else {
- goto badStringTermination;
- }
- } else if (*src == '{') {
- wordStart = src;
- src = TclWordEnd(src, lastChar, nestedCmd, NULL);
- if (src == lastChar) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "missing close-brace", -1);
- return TCL_ERROR;
- }
- prev = (src-1);
- if (*src == '}') {
- wordEnd = src;
- src++;
- } else if ((*src == ';') && (*prev == '}')) {
- scanningArgs = 0;
- wordEnd = prev;
- } else {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "argument word in braces doesn't terminate properly", -1);
- return TCL_ERROR;
- }
- } else {
- wordStart = src;
- src = TclWordEnd(src, lastChar, nestedCmd, NULL);
- prev = (src-1);
- if (src == lastChar) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "missing close-bracket or close-brace", -1);
- return TCL_ERROR;
- } else if (*src == ';') {
- scanningArgs = 0;
- wordEnd = prev;
- } else {
- wordEnd = src;
- src++;
- if ((src == lastChar) || (*src == '\n')
- || ((*src == ']') && nestedCmd)) {
- scanningArgs = 0;
- }
- }
- } /* end of test on each kind of word */
-
- if (argInfoPtr->numArgs == argInfoPtr->allocArgs) {
- int newArgs = 2*argInfoPtr->numArgs;
- size_t currBytes = argInfoPtr->numArgs * sizeof(char *);
- size_t newBytes = newArgs * sizeof(char *);
- char **newStartArrayPtr =
- (char **) ckalloc((unsigned) newBytes);
- char **newEndArrayPtr =
- (char **) ckalloc((unsigned) newBytes);
-
- /*
- * Copy from the old arrays to the new, free the old arrays if
- * needed, and mark the new arrays as malloc'ed.
- */
-
- memcpy((VOID *) newStartArrayPtr,
- (VOID *) argInfoPtr->startArray, currBytes);
- memcpy((VOID *) newEndArrayPtr,
- (VOID *) argInfoPtr->endArray, currBytes);
- if (argInfoPtr->mallocedArrays) {
- ckfree((char *) argInfoPtr->startArray);
- ckfree((char *) argInfoPtr->endArray);
- }
- argInfoPtr->startArray = newStartArrayPtr;
- argInfoPtr->endArray = newEndArrayPtr;
- argInfoPtr->allocArgs = newArgs;
- argInfoPtr->mallocedArrays = 1;
- }
- argInfoPtr->startArray[argInfoPtr->numArgs] = wordStart;
- argInfoPtr->endArray[argInfoPtr->numArgs] = wordEnd;
- argInfoPtr->numArgs++;
- }
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * FreeArgInfo --
- *
- * Free any storage allocated in a ArgInfo structure.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Allocated storage in the ArgInfo structure is freed.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-FreeArgInfo(argInfoPtr)
- register ArgInfo *argInfoPtr; /* Points to the ArgInfo structure
- * to free. */
-{
- if (argInfoPtr->mallocedArrays) {
- ckfree((char *) argInfoPtr->startArray);
- ckfree((char *) argInfoPtr->endArray);
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * CreateExceptionRange --
+ * TclCreateExceptRange --
*
* Procedure that allocates and initializes a new ExceptionRange
- * structure of the specified kind in a CompileEnv's ExceptionRange
- * array.
+ * structure of the specified kind in a CompileEnv.
*
* Results:
* Returns the index for the newly created ExceptionRange.
@@ -7507,37 +2116,32 @@ FreeArgInfo(argInfoPtr)
* Side effects:
* If there is not enough room in the CompileEnv's ExceptionRange
* array, the array in expanded: a new array of double the size is
- * allocated, if envPtr->mallocedExcRangeArray is non-zero the old
+ * allocated, if envPtr->mallocedExceptArray is non-zero the old
* array is freed, and ExceptionRange entries are copied from the old
* array to the new one.
*
*----------------------------------------------------------------------
*/
-static int
-CreateExceptionRange(type, envPtr)
+int
+TclCreateExceptRange(type, envPtr)
ExceptionRangeType type; /* The kind of ExceptionRange desired. */
- register CompileEnv *envPtr;/* Points to the CompileEnv for which a new
- * loop ExceptionRange structure is to be
- * allocated. */
+ register CompileEnv *envPtr;/* Points to CompileEnv for which to
+ * create a new ExceptionRange structure. */
{
- int index; /* Index for the newly-allocated
- * ExceptionRange structure. */
register ExceptionRange *rangePtr;
- /* Points to the new ExceptionRange
- * structure */
+ int index = envPtr->exceptArrayNext;
- index = envPtr->excRangeArrayNext;
- if (index >= envPtr->excRangeArrayEnd) {
+ if (index >= envPtr->exceptArrayEnd) {
/*
* Expand the ExceptionRange array. The currently allocated entries
- * are stored between elements 0 and (envPtr->excRangeArrayNext - 1)
+ * are stored between elements 0 and (envPtr->exceptArrayNext - 1)
* [inclusive].
*/
size_t currBytes =
- envPtr->excRangeArrayNext * sizeof(ExceptionRange);
- int newElems = 2*envPtr->excRangeArrayEnd;
+ envPtr->exceptArrayNext * sizeof(ExceptionRange);
+ int newElems = 2*envPtr->exceptArrayEnd;
size_t newBytes = newElems * sizeof(ExceptionRange);
ExceptionRange *newPtr = (ExceptionRange *)
ckalloc((unsigned) newBytes);
@@ -7548,20 +2152,20 @@ CreateExceptionRange(type, envPtr)
* array as malloced.
*/
- memcpy((VOID *) newPtr, (VOID *) envPtr->excRangeArrayPtr,
+ memcpy((VOID *) newPtr, (VOID *) envPtr->exceptArrayPtr,
currBytes);
- if (envPtr->mallocedExcRangeArray) {
- ckfree((char *) envPtr->excRangeArrayPtr);
+ if (envPtr->mallocedExceptArray) {
+ ckfree((char *) envPtr->exceptArrayPtr);
}
- envPtr->excRangeArrayPtr = (ExceptionRange *) newPtr;
- envPtr->excRangeArrayEnd = newElems;
- envPtr->mallocedExcRangeArray = 1;
+ envPtr->exceptArrayPtr = (ExceptionRange *) newPtr;
+ envPtr->exceptArrayEnd = newElems;
+ envPtr->mallocedExceptArray = 1;
}
- envPtr->excRangeArrayNext++;
+ envPtr->exceptArrayNext++;
- rangePtr = &(envPtr->excRangeArrayPtr[index]);
+ rangePtr = &(envPtr->exceptArrayPtr[index]);
rangePtr->type = type;
- rangePtr->nestingLevel = envPtr->excRangeDepth;
+ rangePtr->nestingLevel = envPtr->exceptDepth;
rangePtr->codeOffset = -1;
rangePtr->numCodeBytes = -1;
rangePtr->breakOffset = -1;
@@ -7596,10 +2200,10 @@ CreateExceptionRange(type, envPtr)
int
TclCreateAuxData(clientData, typePtr, envPtr)
ClientData clientData; /* The compilation auxiliary data to store
- * in the new aux data record. */
+ * in the new aux data record. */
AuxDataType *typePtr; /* Pointer to the type to attach to this AuxData */
register CompileEnv *envPtr;/* Points to the CompileEnv for which a new
- * aux data structure is to be allocated. */
+ * aux data structure is to be allocated. */
{
int index; /* Index for the new AuxData structure. */
register AuxData *auxDataPtr;
@@ -7635,8 +2239,8 @@ TclCreateAuxData(clientData, typePtr, envPtr)
envPtr->auxDataArrayNext++;
auxDataPtr = &(envPtr->auxDataArrayPtr[index]);
- auxDataPtr->type = typePtr;
auxDataPtr->clientData = clientData;
+ auxDataPtr->type = typePtr;
return index;
}
@@ -7783,24 +2387,24 @@ TclEmitForwardJump(envPtr, jumpType, jumpFixupPtr)
* Initialize the JumpFixup structure:
* - codeOffset is offset of first byte of jump below
* - cmdIndex is index of the command after the current one
- * - excRangeIndex is the index of the first ExceptionRange after
+ * - exceptIndex is the index of the first ExceptionRange after
* the current one.
*/
jumpFixupPtr->jumpType = jumpType;
- jumpFixupPtr->codeOffset = TclCurrCodeOffset();
+ jumpFixupPtr->codeOffset = (envPtr->codeNext - envPtr->codeStart);
jumpFixupPtr->cmdIndex = envPtr->numCommands;
- jumpFixupPtr->excRangeIndex = envPtr->excRangeArrayNext;
+ jumpFixupPtr->exceptIndex = envPtr->exceptArrayNext;
switch (jumpType) {
case TCL_UNCONDITIONAL_JUMP:
- TclEmitInstInt1(INST_JUMP1, /*offset*/ 0, envPtr);
+ TclEmitInstInt1(INST_JUMP1, 0, envPtr);
break;
case TCL_TRUE_JUMP:
- TclEmitInstInt1(INST_JUMP_TRUE1, /*offset*/ 0, envPtr);
+ TclEmitInstInt1(INST_JUMP_TRUE1, 0, envPtr);
break;
default:
- TclEmitInstInt1(INST_JUMP_FALSE1, /*offset*/ 0, envPtr);
+ TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr);
break;
}
}
@@ -7865,9 +2469,14 @@ TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold)
/*
* We must grow the jump then move subsequent instructions down.
+ * Note that if we expand the space for generated instructions,
+ * code addresses might change; be careful about updating any of
+ * these addresses held in variables.
*/
- TclEnsureCodeSpace(3, envPtr); /* NB: might change code addresses! */
+ if ((envPtr->codeNext + 3) > envPtr->codeEnd) {
+ TclExpandCodeArray(envPtr);
+ }
jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset);
for (numBytes = envPtr->codeNext-jumpPc-2, p = jumpPc+2+numBytes-1;
numBytes > 0; numBytes--, p--) {
@@ -7900,10 +2509,10 @@ TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold)
}
}
- firstRange = jumpFixupPtr->excRangeIndex;
- lastRange = (envPtr->excRangeArrayNext - 1);
+ firstRange = jumpFixupPtr->exceptIndex;
+ lastRange = (envPtr->exceptArrayNext - 1);
for (k = firstRange; k <= lastRange; k++) {
- ExceptionRange *rangePtr = &(envPtr->excRangeArrayPtr[k]);
+ ExceptionRange *rangePtr = &(envPtr->exceptArrayPtr[k]);
rangePtr->codeOffset += 3;
switch (rangePtr->type) {
@@ -7917,7 +2526,8 @@ TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold)
rangePtr->catchOffset += 3;
break;
default:
- panic("TclFixupForwardJump: unrecognized ExceptionRange type %d\n", rangePtr->type);
+ panic("TclFixupForwardJump: bad ExceptionRange type %d\n",
+ rangePtr->type);
}
}
return 1; /* the jump was grown */
@@ -7933,8 +2543,8 @@ TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold)
* outside the TCL DLLs.
*
* Results:
- * Returns a pointer to the global instruction table, same as the expression
- * (&instructionTable[0]).
+ * Returns a pointer to the global instruction table, same as the
+ * expression (&instructionTable[0]).
*
* Side effects:
* None.
@@ -7976,6 +2586,7 @@ TclRegisterAuxDataType(typePtr)
register Tcl_HashEntry *hPtr;
int new;
+ Tcl_MutexLock(&tableMutex);
if (!auxDataTypeTableInitialized) {
TclInitAuxDataTypeTable();
}
@@ -7997,6 +2608,7 @@ TclRegisterAuxDataType(typePtr)
if (new) {
Tcl_SetHashValue(hPtr, typePtr);
}
+ Tcl_MutexUnlock(&tableMutex);
}
/*
@@ -8023,6 +2635,7 @@ TclGetAuxDataType(typeName)
register Tcl_HashEntry *hPtr;
AuxDataType *typePtr = NULL;
+ Tcl_MutexLock(&tableMutex);
if (!auxDataTypeTableInitialized) {
TclInitAuxDataTypeTable();
}
@@ -8031,6 +2644,7 @@ TclGetAuxDataType(typeName)
if (hPtr != (Tcl_HashEntry *) NULL) {
typePtr = (AuxDataType *) Tcl_GetHashValue(hPtr);
}
+ Tcl_MutexUnlock(&tableMutex);
return typePtr;
}
@@ -8057,9 +2671,17 @@ TclGetAuxDataType(typeName)
void
TclInitAuxDataTypeTable()
{
- auxDataTypeTableInitialized = 1;
+ /*
+ * The table mutex must already be held before this routine is invoked.
+ */
+ auxDataTypeTableInitialized = 1;
Tcl_InitHashTable(&auxDataTypeTable, TCL_STRING_KEYS);
+
+ /*
+ * There is only one AuxData type at this time, so register it here.
+ */
+
TclRegisterAuxDataType(&tclForeachInfoType);
}
@@ -8070,13 +2692,14 @@ TclInitAuxDataTypeTable()
*
* This procedure is called by Tcl_Finalize after all exit handlers
* have been run to free up storage associated with the table of AuxData
- * types.
+ * types. This procedure is called by TclFinalizeExecution() which
+ * is called by Tcl_Finalize().
*
* Results:
* None.
*
* Side effects:
- * Deletes all entries in the hash table of AuxData types, "auxDataTypeTable".
+ * Deletes all entries in the hash table of AuxData types.
*
*----------------------------------------------------------------------
*/
@@ -8084,8 +2707,746 @@ TclInitAuxDataTypeTable()
void
TclFinalizeAuxDataTypeTable()
{
+ Tcl_MutexLock(&tableMutex);
if (auxDataTypeTableInitialized) {
Tcl_DeleteHashTable(&auxDataTypeTable);
auxDataTypeTableInitialized = 0;
}
+ Tcl_MutexUnlock(&tableMutex);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * GetCmdLocEncodingSize --
+ *
+ * Computes the total number of bytes needed to encode the command
+ * location information for some compiled code.
+ *
+ * Results:
+ * The byte count needed to encode the compiled location information.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+GetCmdLocEncodingSize(envPtr)
+ CompileEnv *envPtr; /* Points to compilation environment
+ * structure containing the CmdLocation
+ * structure to encode. */
+{
+ register CmdLocation *mapPtr = envPtr->cmdMapPtr;
+ int numCmds = envPtr->numCommands;
+ int codeDelta, codeLen, srcDelta, srcLen;
+ int codeDeltaNext, codeLengthNext, srcDeltaNext, srcLengthNext;
+ /* The offsets in their respective byte
+ * sequences where the next encoded offset
+ * or length should go. */
+ int prevCodeOffset, prevSrcOffset, i;
+
+ codeDeltaNext = codeLengthNext = srcDeltaNext = srcLengthNext = 0;
+ prevCodeOffset = prevSrcOffset = 0;
+ for (i = 0; i < numCmds; i++) {
+ codeDelta = (mapPtr[i].codeOffset - prevCodeOffset);
+ if (codeDelta < 0) {
+ panic("GetCmdLocEncodingSize: bad code offset");
+ } else if (codeDelta <= 127) {
+ codeDeltaNext++;
+ } else {
+ codeDeltaNext += 5; /* 1 byte for 0xFF, 4 for positive delta */
+ }
+ prevCodeOffset = mapPtr[i].codeOffset;
+
+ codeLen = mapPtr[i].numCodeBytes;
+ if (codeLen < 0) {
+ panic("GetCmdLocEncodingSize: bad code length");
+ } else if (codeLen <= 127) {
+ codeLengthNext++;
+ } else {
+ codeLengthNext += 5; /* 1 byte for 0xFF, 4 for length */
+ }
+
+ srcDelta = (mapPtr[i].srcOffset - prevSrcOffset);
+ if ((-127 <= srcDelta) && (srcDelta <= 127)) {
+ srcDeltaNext++;
+ } else {
+ srcDeltaNext += 5; /* 1 byte for 0xFF, 4 for delta */
+ }
+ prevSrcOffset = mapPtr[i].srcOffset;
+
+ srcLen = mapPtr[i].numSrcBytes;
+ if (srcLen < 0) {
+ panic("GetCmdLocEncodingSize: bad source length");
+ } else if (srcLen <= 127) {
+ srcLengthNext++;
+ } else {
+ srcLengthNext += 5; /* 1 byte for 0xFF, 4 for length */
+ }
+ }
+
+ return (codeDeltaNext + codeLengthNext + srcDeltaNext + srcLengthNext);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * EncodeCmdLocMap --
+ *
+ * Encode the command location information for some compiled code into
+ * a ByteCode structure. The encoded command location map is stored as
+ * three adjacent byte sequences.
+ *
+ * Results:
+ * Pointer to the first byte after the encoded command location
+ * information.
+ *
+ * Side effects:
+ * The encoded information is stored into the block of memory headed
+ * by codePtr. Also records pointers to the start of the four byte
+ * sequences in fields in codePtr's ByteCode header structure.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static unsigned char *
+EncodeCmdLocMap(envPtr, codePtr, startPtr)
+ CompileEnv *envPtr; /* Points to compilation environment
+ * structure containing the CmdLocation
+ * structure to encode. */
+ ByteCode *codePtr; /* ByteCode in which to encode envPtr's
+ * command location information. */
+ unsigned char *startPtr; /* Points to the first byte in codePtr's
+ * memory block where the location
+ * information is to be stored. */
+{
+ register CmdLocation *mapPtr = envPtr->cmdMapPtr;
+ int numCmds = envPtr->numCommands;
+ register unsigned char *p = startPtr;
+ int codeDelta, codeLen, srcDelta, srcLen, prevOffset;
+ register int i;
+
+ /*
+ * Encode the code offset for each command as a sequence of deltas.
+ */
+
+ codePtr->codeDeltaStart = p;
+ prevOffset = 0;
+ for (i = 0; i < numCmds; i++) {
+ codeDelta = (mapPtr[i].codeOffset - prevOffset);
+ if (codeDelta < 0) {
+ panic("EncodeCmdLocMap: bad code offset");
+ } else if (codeDelta <= 127) {
+ TclStoreInt1AtPtr(codeDelta, p);
+ p++;
+ } else {
+ TclStoreInt1AtPtr(0xFF, p);
+ p++;
+ TclStoreInt4AtPtr(codeDelta, p);
+ p += 4;
+ }
+ prevOffset = mapPtr[i].codeOffset;
+ }
+
+ /*
+ * Encode the code length for each command.
+ */
+
+ codePtr->codeLengthStart = p;
+ for (i = 0; i < numCmds; i++) {
+ codeLen = mapPtr[i].numCodeBytes;
+ if (codeLen < 0) {
+ panic("EncodeCmdLocMap: bad code length");
+ } else if (codeLen <= 127) {
+ TclStoreInt1AtPtr(codeLen, p);
+ p++;
+ } else {
+ TclStoreInt1AtPtr(0xFF, p);
+ p++;
+ TclStoreInt4AtPtr(codeLen, p);
+ p += 4;
+ }
+ }
+
+ /*
+ * Encode the source offset for each command as a sequence of deltas.
+ */
+
+ codePtr->srcDeltaStart = p;
+ prevOffset = 0;
+ for (i = 0; i < numCmds; i++) {
+ srcDelta = (mapPtr[i].srcOffset - prevOffset);
+ if ((-127 <= srcDelta) && (srcDelta <= 127)) {
+ TclStoreInt1AtPtr(srcDelta, p);
+ p++;
+ } else {
+ TclStoreInt1AtPtr(0xFF, p);
+ p++;
+ TclStoreInt4AtPtr(srcDelta, p);
+ p += 4;
+ }
+ prevOffset = mapPtr[i].srcOffset;
+ }
+
+ /*
+ * Encode the source length for each command.
+ */
+
+ codePtr->srcLengthStart = p;
+ for (i = 0; i < numCmds; i++) {
+ srcLen = mapPtr[i].numSrcBytes;
+ if (srcLen < 0) {
+ panic("EncodeCmdLocMap: bad source length");
+ } else if (srcLen <= 127) {
+ TclStoreInt1AtPtr(srcLen, p);
+ p++;
+ } else {
+ TclStoreInt1AtPtr(0xFF, p);
+ p++;
+ TclStoreInt4AtPtr(srcLen, p);
+ p += 4;
+ }
+ }
+
+ return p;
}
+
+#ifdef TCL_COMPILE_DEBUG
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclPrintByteCodeObj --
+ *
+ * This procedure prints ("disassembles") the instructions of a
+ * bytecode object to stdout.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclPrintByteCodeObj(interp, objPtr)
+ Tcl_Interp *interp; /* Used only for Tcl_GetStringFromObj. */
+ Tcl_Obj *objPtr; /* The bytecode object to disassemble. */
+{
+ ByteCode* codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
+ unsigned char *codeStart, *codeLimit, *pc;
+ unsigned char *codeDeltaNext, *codeLengthNext;
+ unsigned char *srcDeltaNext, *srcLengthNext;
+ int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i;
+ Interp *iPtr = (Interp *) *codePtr->interpHandle;
+
+ if (codePtr->refCount <= 0) {
+ return; /* already freed */
+ }
+
+ codeStart = codePtr->codeStart;
+ codeLimit = (codeStart + codePtr->numCodeBytes);
+ numCmds = codePtr->numCommands;
+
+ /*
+ * Print header lines describing the ByteCode.
+ */
+
+ fprintf(stdout, "\nByteCode 0x%x, refCt %u, epoch %u, interp 0x%x (epoch %u)\n",
+ (unsigned int) codePtr, codePtr->refCount,
+ codePtr->compileEpoch, (unsigned int) iPtr,
+ iPtr->compileEpoch);
+ fprintf(stdout, " Source ");
+ TclPrintSource(stdout, codePtr->source,
+ TclMin(codePtr->numSrcBytes, 55));
+ fprintf(stdout, "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",
+ numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes,
+ codePtr->numLitObjects, codePtr->numAuxDataItems,
+ codePtr->maxStackDepth,
+#ifdef TCL_COMPILE_STATS
+ (codePtr->numSrcBytes?
+ ((float)codePtr->structureSize)/((float)codePtr->numSrcBytes) : 0.0));
+#else
+ 0.0);
+#endif
+#ifdef TCL_COMPILE_STATS
+ fprintf(stdout,
+ " Code %d = header %d+inst %d+litObj %d+exc %d+aux %d+cmdMap %d\n",
+ codePtr->structureSize,
+ (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))),
+ codePtr->numCodeBytes,
+ (codePtr->numLitObjects * sizeof(Tcl_Obj *)),
+ (codePtr->numExceptRanges * sizeof(ExceptionRange)),
+ (codePtr->numAuxDataItems * sizeof(AuxData)),
+ codePtr->numCmdLocBytes);
+#endif /* TCL_COMPILE_STATS */
+
+ /*
+ * If the ByteCode is the compiled body of a Tcl procedure, print
+ * information about that procedure. Note that we don't know the
+ * procedure's name since ByteCode's can be shared among procedures.
+ */
+
+ if (codePtr->procPtr != NULL) {
+ Proc *procPtr = codePtr->procPtr;
+ int numCompiledLocals = procPtr->numCompiledLocals;
+ fprintf(stdout,
+ " Proc 0x%x, refCt %d, args %d, compiled locals %d\n",
+ (unsigned int) procPtr, procPtr->refCount, procPtr->numArgs,
+ numCompiledLocals);
+ if (numCompiledLocals > 0) {
+ CompiledLocal *localPtr = procPtr->firstLocalPtr;
+ for (i = 0; i < numCompiledLocals; i++) {
+ fprintf(stdout, " slot %d%s%s%s%s%s%s", i,
+ ((localPtr->flags & VAR_SCALAR)? ", scalar" : ""),
+ ((localPtr->flags & VAR_ARRAY)? ", array" : ""),
+ ((localPtr->flags & VAR_LINK)? ", link" : ""),
+ ((localPtr->flags & VAR_ARGUMENT)? ", arg" : ""),
+ ((localPtr->flags & VAR_TEMPORARY)? ", temp" : ""),
+ ((localPtr->flags & VAR_RESOLVED)? ", resolved" : ""));
+ if (TclIsVarTemporary(localPtr)) {
+ fprintf(stdout, "\n");
+ } else {
+ fprintf(stdout, ", \"%s\"\n", localPtr->name);
+ }
+ localPtr = localPtr->nextPtr;
+ }
+ }
+ }
+
+ /*
+ * Print the ExceptionRange array.
+ */
+
+ if (codePtr->numExceptRanges > 0) {
+ fprintf(stdout, " Exception ranges %d, depth %d:\n",
+ codePtr->numExceptRanges, codePtr->maxExceptDepth);
+ for (i = 0; i < codePtr->numExceptRanges; i++) {
+ ExceptionRange *rangePtr = &(codePtr->exceptArrayPtr[i]);
+ fprintf(stdout, " %d: level %d, %s, pc %d-%d, ",
+ i, rangePtr->nestingLevel,
+ ((rangePtr->type == LOOP_EXCEPTION_RANGE)
+ ? "loop" : "catch"),
+ rangePtr->codeOffset,
+ (rangePtr->codeOffset + rangePtr->numCodeBytes - 1));
+ switch (rangePtr->type) {
+ case LOOP_EXCEPTION_RANGE:
+ fprintf(stdout, "continue %d, break %d\n",
+ rangePtr->continueOffset, rangePtr->breakOffset);
+ break;
+ case CATCH_EXCEPTION_RANGE:
+ fprintf(stdout, "catch %d\n", rangePtr->catchOffset);
+ break;
+ default:
+ panic("TclPrintByteCodeObj: bad ExceptionRange type %d\n",
+ rangePtr->type);
+ }
+ }
+ }
+
+ /*
+ * If there were no commands (e.g., an expression or an empty string
+ * was compiled), just print all instructions and return.
+ */
+
+ if (numCmds == 0) {
+ pc = codeStart;
+ while (pc < codeLimit) {
+ fprintf(stdout, " ");
+ pc += TclPrintInstruction(codePtr, pc);
+ }
+ return;
+ }
+
+ /*
+ * Print table showing the code offset, source offset, and source
+ * length for each command. These are encoded as a sequence of bytes.
+ */
+
+ fprintf(stdout, " Commands %d:", numCmds);
+ codeDeltaNext = codePtr->codeDeltaStart;
+ codeLengthNext = codePtr->codeLengthStart;
+ srcDeltaNext = codePtr->srcDeltaStart;
+ srcLengthNext = codePtr->srcLengthStart;
+ codeOffset = srcOffset = 0;
+ for (i = 0; i < numCmds; i++) {
+ if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
+ codeDeltaNext++;
+ delta = TclGetInt4AtPtr(codeDeltaNext);
+ codeDeltaNext += 4;
+ } else {
+ delta = TclGetInt1AtPtr(codeDeltaNext);
+ codeDeltaNext++;
+ }
+ codeOffset += delta;
+
+ if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) {
+ codeLengthNext++;
+ codeLen = TclGetInt4AtPtr(codeLengthNext);
+ codeLengthNext += 4;
+ } else {
+ codeLen = TclGetInt1AtPtr(codeLengthNext);
+ codeLengthNext++;
+ }
+
+ if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
+ srcDeltaNext++;
+ delta = TclGetInt4AtPtr(srcDeltaNext);
+ srcDeltaNext += 4;
+ } else {
+ delta = TclGetInt1AtPtr(srcDeltaNext);
+ srcDeltaNext++;
+ }
+ srcOffset += delta;
+
+ if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
+ srcLengthNext++;
+ srcLen = TclGetInt4AtPtr(srcLengthNext);
+ srcLengthNext += 4;
+ } else {
+ srcLen = TclGetInt1AtPtr(srcLengthNext);
+ srcLengthNext++;
+ }
+
+ fprintf(stdout, "%s%4d: pc %d-%d, src %d-%d",
+ ((i % 2)? " " : "\n "),
+ (i+1), codeOffset, (codeOffset + codeLen - 1),
+ srcOffset, (srcOffset + srcLen - 1));
+ }
+ if (numCmds > 0) {
+ fprintf(stdout, "\n");
+ }
+
+ /*
+ * Print each instruction. If the instruction corresponds to the start
+ * of a command, print the command's source. Note that we don't need
+ * the code length here.
+ */
+
+ codeDeltaNext = codePtr->codeDeltaStart;
+ srcDeltaNext = codePtr->srcDeltaStart;
+ srcLengthNext = codePtr->srcLengthStart;
+ codeOffset = srcOffset = 0;
+ pc = codeStart;
+ for (i = 0; i < numCmds; i++) {
+ if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
+ codeDeltaNext++;
+ delta = TclGetInt4AtPtr(codeDeltaNext);
+ codeDeltaNext += 4;
+ } else {
+ delta = TclGetInt1AtPtr(codeDeltaNext);
+ codeDeltaNext++;
+ }
+ codeOffset += delta;
+
+ if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
+ srcDeltaNext++;
+ delta = TclGetInt4AtPtr(srcDeltaNext);
+ srcDeltaNext += 4;
+ } else {
+ delta = TclGetInt1AtPtr(srcDeltaNext);
+ srcDeltaNext++;
+ }
+ srcOffset += delta;
+
+ if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
+ srcLengthNext++;
+ srcLen = TclGetInt4AtPtr(srcLengthNext);
+ srcLengthNext += 4;
+ } else {
+ srcLen = TclGetInt1AtPtr(srcLengthNext);
+ srcLengthNext++;
+ }
+
+ /*
+ * Print instructions before command i.
+ */
+
+ while ((pc-codeStart) < codeOffset) {
+ fprintf(stdout, " ");
+ pc += TclPrintInstruction(codePtr, pc);
+ }
+
+ fprintf(stdout, " Command %d: ", (i+1));
+ TclPrintSource(stdout, (codePtr->source + srcOffset),
+ TclMin(srcLen, 55));
+ fprintf(stdout, "\n");
+ }
+ if (pc < codeLimit) {
+ /*
+ * Print instructions after the last command.
+ */
+
+ while (pc < codeLimit) {
+ fprintf(stdout, " ");
+ pc += TclPrintInstruction(codePtr, pc);
+ }
+ }
+}
+#endif /* TCL_COMPILE_DEBUG */
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclPrintInstruction --
+ *
+ * This procedure prints ("disassembles") one instruction from a
+ * bytecode object to stdout.
+ *
+ * Results:
+ * Returns the length in bytes of the current instruiction.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclPrintInstruction(codePtr, pc)
+ ByteCode* codePtr; /* Bytecode containing the instruction. */
+ unsigned char *pc; /* Points to first byte of instruction. */
+{
+ Proc *procPtr = codePtr->procPtr;
+ unsigned char opCode = *pc;
+ register InstructionDesc *instDesc = &instructionTable[opCode];
+ unsigned char *codeStart = codePtr->codeStart;
+ unsigned int pcOffset = (pc - codeStart);
+ int opnd, i, j;
+
+ fprintf(stdout, "(%u) %s ", pcOffset, instDesc->name);
+ for (i = 0; i < instDesc->numOperands; i++) {
+ switch (instDesc->opTypes[i]) {
+ case OPERAND_INT1:
+ opnd = TclGetInt1AtPtr(pc+1+i);
+ if ((i == 0) && ((opCode == INST_JUMP1)
+ || (opCode == INST_JUMP_TRUE1)
+ || (opCode == INST_JUMP_FALSE1))) {
+ fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd));
+ } else {
+ fprintf(stdout, "%d", opnd);
+ }
+ break;
+ case OPERAND_INT4:
+ opnd = TclGetInt4AtPtr(pc+1+i);
+ if ((i == 0) && ((opCode == INST_JUMP4)
+ || (opCode == INST_JUMP_TRUE4)
+ || (opCode == INST_JUMP_FALSE4))) {
+ fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd));
+ } else {
+ fprintf(stdout, "%d", opnd);
+ }
+ break;
+ case OPERAND_UINT1:
+ opnd = TclGetUInt1AtPtr(pc+1+i);
+ if ((i == 0) && (opCode == INST_PUSH1)) {
+ fprintf(stdout, "%u # ", (unsigned int) opnd);
+ TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40);
+ } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR1)
+ || (opCode == INST_LOAD_ARRAY1)
+ || (opCode == INST_STORE_SCALAR1)
+ || (opCode == INST_STORE_ARRAY1))) {
+ int localCt = procPtr->numCompiledLocals;
+ CompiledLocal *localPtr = procPtr->firstLocalPtr;
+ if (opnd >= localCt) {
+ panic("TclPrintInstruction: bad local var index %u (%u locals)\n",
+ (unsigned int) opnd, localCt);
+ return instDesc->numBytes;
+ }
+ for (j = 0; j < opnd; j++) {
+ localPtr = localPtr->nextPtr;
+ }
+ if (TclIsVarTemporary(localPtr)) {
+ fprintf(stdout, "%u # temp var %u",
+ (unsigned int) opnd, (unsigned int) opnd);
+ } else {
+ fprintf(stdout, "%u # var ", (unsigned int) opnd);
+ TclPrintSource(stdout, localPtr->name, 40);
+ }
+ } else {
+ fprintf(stdout, "%u ", (unsigned int) opnd);
+ }
+ break;
+ case OPERAND_UINT4:
+ opnd = TclGetUInt4AtPtr(pc+1+i);
+ if (opCode == INST_PUSH4) {
+ fprintf(stdout, "%u # ", opnd);
+ TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40);
+ } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR4)
+ || (opCode == INST_LOAD_ARRAY4)
+ || (opCode == INST_STORE_SCALAR4)
+ || (opCode == INST_STORE_ARRAY4))) {
+ int localCt = procPtr->numCompiledLocals;
+ CompiledLocal *localPtr = procPtr->firstLocalPtr;
+ if (opnd >= localCt) {
+ panic("TclPrintInstruction: bad local var index %u (%u locals)\n",
+ (unsigned int) opnd, localCt);
+ return instDesc->numBytes;
+ }
+ for (j = 0; j < opnd; j++) {
+ localPtr = localPtr->nextPtr;
+ }
+ if (TclIsVarTemporary(localPtr)) {
+ fprintf(stdout, "%u # temp var %u",
+ (unsigned int) opnd, (unsigned int) opnd);
+ } else {
+ fprintf(stdout, "%u # var ", (unsigned int) opnd);
+ TclPrintSource(stdout, localPtr->name, 40);
+ }
+ } else {
+ fprintf(stdout, "%u ", (unsigned int) opnd);
+ }
+ break;
+ case OPERAND_NONE:
+ default:
+ break;
+ }
+ }
+ fprintf(stdout, "\n");
+ return instDesc->numBytes;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclPrintObject --
+ *
+ * This procedure prints up to a specified number of characters from
+ * the argument Tcl object's string representation to a specified file.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Outputs characters to the specified file.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclPrintObject(outFile, objPtr, maxChars)
+ FILE *outFile; /* The file to print the source to. */
+ Tcl_Obj *objPtr; /* Points to the Tcl object whose string
+ * representation should be printed. */
+ int maxChars; /* Maximum number of chars to print. */
+{
+ char *bytes;
+ int length;
+
+ bytes = Tcl_GetStringFromObj(objPtr, &length);
+ TclPrintSource(outFile, bytes, TclMin(length, maxChars));
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclPrintSource --
+ *
+ * This procedure prints up to a specified number of characters from
+ * the argument string to a specified file. It tries to produce legible
+ * output by adding backslashes as necessary.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Outputs characters to the specified file.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclPrintSource(outFile, string, maxChars)
+ FILE *outFile; /* The file to print the source to. */
+ char *string; /* The string to print. */
+ int maxChars; /* Maximum number of chars to print. */
+{
+ register char *p;
+ register int i = 0;
+
+ if (string == NULL) {
+ fprintf(outFile, "\"\"");
+ return;
+ }
+
+ fprintf(outFile, "\"");
+ p = string;
+ for (; (*p != '\0') && (i < maxChars); p++, i++) {
+ switch (*p) {
+ case '"':
+ fprintf(outFile, "\\\"");
+ continue;
+ case '\f':
+ fprintf(outFile, "\\f");
+ continue;
+ case '\n':
+ fprintf(outFile, "\\n");
+ continue;
+ case '\r':
+ fprintf(outFile, "\\r");
+ continue;
+ case '\t':
+ fprintf(outFile, "\\t");
+ continue;
+ case '\v':
+ fprintf(outFile, "\\v");
+ continue;
+ default:
+ fprintf(outFile, "%c", *p);
+ continue;
+ }
+ }
+ fprintf(outFile, "\"");
+}
+
+#ifdef TCL_COMPILE_STATS
+/*
+ *----------------------------------------------------------------------
+ *
+ * RecordByteCodeStats --
+ *
+ * Accumulates various compilation-related statistics for each newly
+ * compiled ByteCode. Called by the TclInitByteCodeObj when Tcl is
+ * compiled with the -DTCL_COMPILE_STATS flag
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Accumulates aggregate code-related statistics in the interpreter's
+ * ByteCodeStats structure. Records statistics specific to a ByteCode
+ * in its ByteCode structure.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+RecordByteCodeStats(codePtr)
+ ByteCode *codePtr; /* Points to ByteCode structure with info
+ * to add to accumulated statistics. */
+{
+ Interp *iPtr = (Interp *) *codePtr->interpHandle;
+ register ByteCodeStats *statsPtr = &(iPtr->stats);
+
+ statsPtr->numCompilations++;
+ statsPtr->totalSrcBytes += (double) codePtr->numSrcBytes;
+ statsPtr->totalByteCodeBytes += (double) codePtr->structureSize;
+ statsPtr->currentSrcBytes += (double) codePtr->numSrcBytes;
+ statsPtr->currentByteCodeBytes += (double) codePtr->structureSize;
+
+ statsPtr->srcCount[TclLog2(codePtr->numSrcBytes)]++;
+ statsPtr->byteCodeCount[TclLog2(codePtr->structureSize)]++;
+
+ statsPtr->currentInstBytes += (double) codePtr->numCodeBytes;
+ statsPtr->currentLitBytes +=
+ (double) (codePtr->numLitObjects * sizeof(Tcl_Obj *));
+ statsPtr->currentExceptBytes +=
+ (double) (codePtr->numExceptRanges * sizeof(ExceptionRange));
+ statsPtr->currentAuxBytes +=
+ (double) (codePtr->numAuxDataItems * sizeof(AuxData));
+ statsPtr->currentCmdMapBytes += (double) codePtr->numCmdLocBytes;
+}
+#endif /* TCL_COMPILE_STATS */