/*
* tclCompile.c --
*
* This file contains procedures that compile Tcl commands or parts
* 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.
*
* 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 $
*/
#include "tclInt.h"
#include "tclCompile.h"
/*
* Variable that controls whether compilation tracing is enabled and, if so,
* what level of tracing is desired:
* 0: no compilation tracing
* 1: summarize compilation of top level cmds and proc bodies
* 2: display all instructions of each ByteCode compiled
* This variable is linked to the Tcl variable "tcl_traceCompile".
*/
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.
*
* Note that the load, store, and incr instructions do not distinguish local
* from global variables; the bytecode interpreter at runtime uses the
* existence of a procedure call frame to distinguish these.
*/
InstructionDesc instructionTable[] = {
/* Name Bytes #Opnds Operand types Stack top, next */
{"done", 1, 0, {OPERAND_NONE}},
/* Finish ByteCode execution and return stktop (top stack item) */
{"push1", 2, 1, {OPERAND_UINT1}},
/* Push object at ByteCode objArray[op1] */
{"push4", 5, 1, {OPERAND_UINT4}},
/* Push object at ByteCode objArray[op4] */
{"pop", 1, 0, {OPERAND_NONE}},
/* Pop the topmost stack object */
{"dup", 1, 0, {OPERAND_NONE}},
/* Duplicate the topmost stack object and push the result */
{"concat1", 2, 1, {OPERAND_UINT1}},
/* Concatenate the top op1 items and push result */
{"invokeStk1", 2, 1, {OPERAND_UINT1}},
/* Invoke command named objv[0]; <objc,objv> = <op1,top op1> */
{"invokeStk4", 5, 1, {OPERAND_UINT4}},
/* Invoke command named objv[0]; <objc,objv> = <op4,top op4> */
{"evalStk", 1, 0, {OPERAND_NONE}},
/* Evaluate command in stktop using Tcl_EvalObj. */
{"exprStk", 1, 0, {OPERAND_NONE}},
/* Execute expression in stktop using Tcl_ExprStringObj. */
{"loadScalar1", 2, 1, {OPERAND_UINT1}},
/* Load scalar variable at index op1 <= 255 in call frame */
{"loadScalar4", 5, 1, {OPERAND_UINT4}},
/* Load scalar variable at index op1 >= 256 in call frame */
{"loadScalarStk", 1, 0, {OPERAND_NONE}},
/* Load scalar variable; scalar's name is stktop */
{"loadArray1", 2, 1, {OPERAND_UINT1}},
/* Load array element; array at slot op1<=255, element is stktop */
{"loadArray4", 5, 1, {OPERAND_UINT4}},
/* Load array element; array at slot op1 > 255, element is stktop */
{"loadArrayStk", 1, 0, {OPERAND_NONE}},
/* Load array element; element is stktop, array name is stknext */
{"loadStk", 1, 0, {OPERAND_NONE}},
/* Load general variable; unparsed variable name is stktop */
{"storeScalar1", 2, 1, {OPERAND_UINT1}},
/* Store scalar variable at op1<=255 in frame; value is stktop */
{"storeScalar4", 5, 1, {OPERAND_UINT4}},
/* Store scalar variable at op1 > 255 in frame; value is stktop */
{"storeScalarStk", 1, 0, {OPERAND_NONE}},
/* Store scalar; value is stktop, scalar name is stknext */
{"storeArray1", 2, 1, {OPERAND_UINT1}},
/* Store array element; array at op1<=255, value is top then elem */
{"storeArray4", 5, 1, {OPERAND_UINT4}},
/* Store array element; array at op1>=256, value is top then elem */
{"storeArrayStk", 1, 0, {OPERAND_NONE}},
/* Store array element; value is stktop, then elem, array names */
{"storeStk", 1, 0, {OPERAND_NONE}},
/* Store general variable; value is stktop, then unparsed name */
{"incrScalar1", 2, 1, {OPERAND_UINT1}},
/* Incr scalar at index op1<=255 in frame; incr amount is stktop */
{"incrScalarStk", 1, 0, {OPERAND_NONE}},
/* Incr scalar; incr amount is stktop, scalar's name is stknext */
{"incrArray1", 2, 1, {OPERAND_UINT1}},
/* Incr array elem; arr at slot op1<=255, amount is top then elem */
{"incrArrayStk", 1, 0, {OPERAND_NONE}},
/* Incr array element; amount is top then elem then array names */
{"incrStk", 1, 0, {OPERAND_NONE}},
/* Incr general variable; amount is stktop then unparsed var name */
{"incrScalar1Imm", 3, 2, {OPERAND_UINT1, OPERAND_INT1}},
/* Incr scalar at slot op1 <= 255; amount is 2nd operand byte */
{"incrScalarStkImm", 2, 1, {OPERAND_INT1}},
/* Incr scalar; scalar name is stktop; incr amount is op1 */
{"incrArray1Imm", 3, 2, {OPERAND_UINT1, OPERAND_INT1}},
/* Incr array elem; array at slot op1 <= 255, elem is stktop,
* amount is 2nd operand byte */
{"incrArrayStkImm", 2, 1, {OPERAND_INT1}},
/* Incr array element; elem is top then array name, amount is op1 */
{"incrStkImm", 2, 1, {OPERAND_INT1}},
/* Incr general variable; unparsed name is top, amount is op1 */
{"jump1", 2, 1, {OPERAND_INT1}},
/* Jump relative to (pc + op1) */
{"jump4", 5, 1, {OPERAND_INT4}},
/* Jump relative to (pc + op4) */
{"jumpTrue1", 2, 1, {OPERAND_INT1}},
/* Jump relative to (pc + op1) if stktop expr object is true */
{"jumpTrue4", 5, 1, {OPERAND_INT4}},
/* Jump relative to (pc + op4) if stktop expr object is true */
{"jumpFalse1", 2, 1, {OPERAND_INT1}},
/* Jump relative to (pc + op1) if stktop expr object is false */
{"jumpFalse4", 5, 1, {OPERAND_INT4}},
/* Jump relative to (pc + op4) if stktop expr object is false */
{"lor", 1, 0, {OPERAND_NONE}},
/* Logical or: push (stknext || stktop) */
{"land", 1, 0, {OPERAND_NONE}},
/* Logical and: push (stknext && stktop) */
{"bitor", 1, 0, {OPERAND_NONE}},
/* Bitwise or: push (stknext | stktop) */
{"bitxor", 1, 0, {OPERAND_NONE}},
/* Bitwise xor push (stknext ^ stktop) */
{"bitand", 1, 0, {OPERAND_NONE}},
/* Bitwise and: push (stknext & stktop) */
{"eq", 1, 0, {OPERAND_NONE}},
/* Equal: push (stknext == stktop) */
{"neq", 1, 0, {OPERAND_NONE}},
/* Not equal: push (stknext != stktop) */
{"lt", 1, 0, {OPERAND_NONE}},
/* Less: push (stknext < stktop) */
{"gt", 1, 0, {OPERAND_NONE}},
/* Greater: push (stknext || stktop) */
{"le", 1, 0, {OPERAND_NONE}},
/* Logical or: push (stknext || stktop) */
{"ge", 1, 0, {OPERAND_NONE}},
/* Logical or: push (stknext || stktop) */
{"lshift", 1, 0, {OPERAND_NONE}},
/* Left shift: push (stknext << stktop) */
{"rshift", 1, 0, {OPERAND_NONE}},
/* Right shift: push (stknext >> stktop) */
{"add", 1, 0, {OPERAND_NONE}},
/* Add: push (stknext + stktop) */
{"sub", 1, 0, {OPERAND_NONE}},
/* Sub: push (stkext - stktop) */
{"mult", 1, 0, {OPERAND_NONE}},
/* Multiply: push (stknext * stktop) */
{"div", 1, 0, {OPERAND_NONE}},
/* Divide: push (stknext / stktop) */
{"mod", 1, 0, {OPERAND_NONE}},
/* Mod: push (stknext % stktop) */
{"uplus", 1, 0, {OPERAND_NONE}},
/* Unary plus: push +stktop */
{"uminus", 1, 0, {OPERAND_NONE}},
/* Unary minus: push -stktop */
{"bitnot", 1, 0, {OPERAND_NONE}},
/* Bitwise not: push ~stktop */
{"not", 1, 0, {OPERAND_NONE}},
/* Logical not: push !stktop */
{"callBuiltinFunc1", 2, 1, {OPERAND_UINT1}},
/* Call builtin math function with index op1; any args are on stk */
{"callFunc1", 2, 1, {OPERAND_UINT1}},
/* Call non-builtin func objv[0]; <objc,objv>=<op1,top op1> */
{"tryCvtToNumeric", 1, 0, {OPERAND_NONE}},
/* Try converting stktop to first int then double if possible. */
{"break", 1, 0, {OPERAND_NONE}},
/* Abort closest enclosing loop; if none, return TCL_BREAK code. */
{"continue", 1, 0, {OPERAND_NONE}},
/* Skip to next iteration of closest enclosing loop; if none,
* return TCL_CONTINUE code. */
{"foreach_start4", 5, 1, {OPERAND_UINT4}},
/* Initialize execution of a foreach loop. Operand is aux data index
* of the ForeachInfo structure for the foreach command. */
{"foreach_step4", 5, 1, {OPERAND_UINT4}},
/* "Step" or begin next iteration of foreach loop. Push 0 if to
* terminate loop, else push 1. */
{"beginCatch4", 5, 1, {OPERAND_UINT4}},
/* Record start of catch with the operand's exception range 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. */
{"pushResult", 1, 0, {OPERAND_NONE}},
/* Push the interpreter's object result onto the stack. */
{"pushReturnCode", 1, 0, {OPERAND_NONE}},
/* Push interpreter's return code (e.g. TCL_OK or TCL_ERROR) as
* a new object onto the stack. */
{0}
};
/*
* 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));
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 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
* means of procedures that can be invoked by generic object code.
*/
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 */
};
/*
*----------------------------------------------------------------------
*
* 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;
int numCmds, numObjs, delta, objBytes, i;
if (codePtr->refCount <= 0) {
return; /* already freed */
}
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;
}
}
/*
* 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;
}
}
}
/*
* 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);
}
}
}
/*
* 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, 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.
*/
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");
}
if (pc < codeLimit) {
/*
* Print instructions after the last command.
*/
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;
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;
}
}
fprintf(stdout, "\n");
return instDesc->numBytes;
}
/*
*----------------------------------------------------------------------
*
* 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, "\"");
}
/*
*----------------------------------------------------------------------
*
* FreeByteCodeInternalRep --
*
* Part of the bytecode Tcl object type implementation. Frees the
* storage associated with a bytecode object's internal representation
* unless its code is actively being executed.
*
* Results:
* None.
*
* Side effects:
* The bytecode object's internal rep is marked invalid and its
* code gets freed unless the code is actively being executed.
* In that case the cleanup is delayed until the last execution
* of the code completes.
*
*----------------------------------------------------------------------
*/
static void
FreeByteCodeInternalRep(objPtr)
register Tcl_Obj *objPtr; /* Object whose internal rep to free. */
{
register ByteCode *codePtr =
(ByteCode *) objPtr->internalRep.otherValuePtr;
codePtr->refCount--;
if (codePtr->refCount <= 0) {
TclCleanupByteCode(codePtr);
}
objPtr->typePtr = NULL;
objPtr->internalRep.otherValuePtr = NULL;
}
/*
*----------------------------------------------------------------------
*
* TclCleanupByteCode --
*
* This procedure does all the real work of freeing up a bytecode
* object's ByteCode structure. It's called only when the structure's
* reference count becomes zero.
*
* Results:
* 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.
*
*----------------------------------------------------------------------
*/
void
TclCleanupByteCode(codePtr)
ByteCode *codePtr; /* ByteCode to free. */
{
Tcl_Obj **objArrayPtr = codePtr->objArrayPtr;
int numObjects = codePtr->numObjects;
int numAuxDataItems = codePtr->numAuxDataItems;
register AuxData *auxDataPtr;
register Tcl_Obj *elemPtr;
register int i;
#ifdef TCL_COMPILE_STATS
tclCurrentSourceBytes -= (double) codePtr->numSrcChars;
tclCurrentCodeBytes -= (double) codePtr->totalSize;
#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.
*/
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) {
/*
* Add a "done" instruction at the end of the instruction sequence.
*/
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);
}
auxDataPtr++;
}
}
TclFreeCompileEnv(&compEnv);
if (result == TCL_OK) {
if (tclTraceCompile == 2) {
TclPrintByteCodeObj(interp, objPtr);
}
}
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.");
}
/*
*----------------------------------------------------------------------
*
* TclInitCompileEnv --
*
* Initializes a CompileEnv compilation environment structure for the
* compilation of a string in an interpreter.
*
* Results:
* None.
*
* Side effects:
* The CompileEnv structure is initialized.
*
*----------------------------------------------------------------------
*/
void
TclInitCompileEnv(interp, envPtr, string)
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. */
{
Interp *iPtr = (Interp *) interp;
envPtr->iPtr = iPtr;
envPtr->source = string;
envPtr->procPtr = iPtr->compiledProcPtr;
envPtr->numCommands = 0;
envPtr->excRangeDepth = 0;
envPtr->maxExcRangeDepth = 0;
envPtr->maxStackDepth = 0;
Tcl_InitHashTable(&(envPtr->objTable), TCL_STRING_KEYS);
envPtr->pushSimpleWords = 1;
envPtr->wordIsSimple = 0;
envPtr->numSimpleWordChars = 0;
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->excRangeArrayPtr = envPtr->staticExcRangeArraySpace;
envPtr->excRangeArrayNext = 0;
envPtr->excRangeArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES;
envPtr->mallocedExcRangeArray = 0;
envPtr->cmdMapPtr = envPtr->staticCmdMapSpace;
envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE;
envPtr->mallocedCmdMap = 0;
envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace;
envPtr->auxDataArrayNext = 0;
envPtr->auxDataArrayEnd = COMPILEENV_INIT_AUX_DATA_SIZE;
envPtr->mallocedAuxDataArray = 0;
}
/*
*----------------------------------------------------------------------
*
* TclFreeCompileEnv --
*
* Free the storage allocated in a CompileEnv compilation environment
* structure.
*
* 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.
*
*----------------------------------------------------------------------
*/
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->mallocedExcRangeArray) {
ckfree((char *) envPtr->excRangeArrayPtr);
}
if (envPtr->mallocedCmdMap) {
ckfree((char *) envPtr->cmdMapPtr);
}
if (envPtr->mallocedAuxDataArray) {
ckfree((char *) envPtr->auxDataArrayPtr);
}
}
/*
*----------------------------------------------------------------------
*
* 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 --
*
* Compile a Tcl script in a null-terminated binary 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.
*
* Side effects:
* Adds instructions to envPtr to evaluate the string 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). */
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. */
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. */
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;
/*
* commands: command {(';' | '\n') command}
*/
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);
}
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++;
}
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 */
}
/*
* If not the first command, discard the previous command's result.
*/
if (!isFirstCmd) {
TclEmitOpcode(INST_POP, envPtr);
if (!(flags & TCL_BRACKET_TERM)) {
/*
* We are compiling a top level command. Update the number
* of code bytes for the last command to account for the pop
* instruction.
*/
(envPtr->cmdMapPtr[lastTopLevelCmdIndex]).numCodeBytes =
(envPtr->codeNext-envPtr->codeStart) - cmdCodeOffset;
}
}
/*
* 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.
*/
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. */
}
/*
* Compile one word. We use an inline version of CompileWord to
* avoid an extra procedure call.
*/
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))) {
/*
* 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.
*/
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';
} else {
src = firstArg;
goto done; /* an error */
}
}
/*
* 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.
*/
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++;
}
}
} 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.
*/
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);
}
}
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.
*/
register char *p;
int numChars;
char buf[200];
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++;
}
}
/*
* Figure out how much of the command to print (up to a certain
* number of characters, or up to the end of the command).
*/
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.
*
*----------------------------------------------------------------------
*/
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)
*/
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 (type == TCL_COMMAND_END) {
goto done;
}
/*
* Compile the word. Handle quoted and braced string words here in order
* to avoid an extra procedure call.
*/
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;
}
/*
* Make sure terminating character of the quoted or braced string is
* the end of word.
*/
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);
envPtr->maxStackDepth = maxDepth;
return result;
}
/*
*----------------------------------------------------------------------
*
* 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.
*
* 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.
*
*----------------------------------------------------------------------
*/
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). */
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.
*/
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))) {
/*
* 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.
*/
simpleWord = 1;
if (!envPtr->pushSimpleWords) {
envPtr->wordIsSimple = 1;
envPtr->numSimpleWordChars = (src - string);
envPtr->termOffset = envPtr->numSimpleWordChars;
envPtr->pushSimpleWords = savePushSimpleWords;
return TCL_OK;
}
}
/*
* 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.
*/
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++;
}
}
*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.
*/
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+
*/
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.
*/
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;
} else {
src++;
}
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.
*/
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;
} else {
src++;
}
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 {
*dst++ = *p++;
}
}
*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.
*/
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);
}
}
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).
*/
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 (!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;
}
}
/*
* 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.
*/
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);
}
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 == '(');
}
/*
* 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 (!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);
}
}
}
done:
envPtr->termOffset = (src - string);
envPtr->wordIsSimple = 0;
envPtr->numSimpleWordChars = 0;
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);
done:
envPtr->termOffset = (src - string);
envPtr->maxStackDepth = 0;
return result;
}
/*
*----------------------------------------------------------------------
*
* TclCompileCatchCmd --
*
* Procedure called to compile the "catch" command.
*
* 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.
*
* 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 "catch" command
* 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. */
{
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);
}
/*
*==== At this point we believe we can compile the catch command ====
*/
/*
* 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);
}
/*
* Emit the instruction to mark the end of the catch command.
*/
TclEmitOpcode(INST_END_CATCH, envPtr);
done:
if (numWords == 0) {
envPtr->termOffset = 0;
} else {
envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string);
}
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;
}
/*
*----------------------------------------------------------------------
*
* TclCompileExprCmd --
*
* Procedure called to compile the "expr" 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 "expr" command.
*
* Side effects:
* Instructions are added to envPtr to evaluate the "expr" command
* at runtime.
*
*----------------------------------------------------------------------
*/
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. */
{
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;
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;
}
/*
* 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 (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.
*/
*wordEnd = '\0';
result = TclCompileExpr(interp, (wordStart + 1), wordEnd,
flags, envPtr);
*wordEnd = '}';
envPtr->termOffset = (wordEnd + 1) - string;
envPtr->pushSimpleWords = savePushSimpleWords;
FreeArgInfo(&argInfo);
return result;
}
}
/*
* 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));
}
}
/*
* 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.
*/
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.
*/
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;
maxDepth = envPtr->maxStackDepth;
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 */
}
}
/*
* 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.
*/
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) {
break;
}
if (i != (numWords - 1)) {
objIndex = TclObjIndexForString(" ", 1, /*allocStrRep*/ 1,
/*inHeap*/ 0, envPtr);
TclEmitPush(objIndex, envPtr);
maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
} else {
maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
}
}
if (result == TCL_OK) {
int concatItems = 2*numWords - 1;
while (concatItems > 255) {
TclEmitInstUInt1(INST_CONCAT1, 255, envPtr);
concatItems -= 254; /* concat pushes 1 obj, the result */
}
if (concatItems > 1) {
TclEmitInstUInt1(INST_CONCAT1, concatItems, envPtr);
}
TclEmitOpcode(INST_EXPR_STK, envPtr);
}
/*
* If emitting inline code, 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;
}
}
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;
}
/*
*----------------------------------------------------------------------
*
* TclCompileForeachCmd --
*
* Procedure called to compile the "foreach" command.
*
* 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.
*
* Side effects:
* Instructions are added to envPtr to evaluate the "foreach" command
* at runtime.
*
*----------------------------------------------------------------------
*/
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. */
{
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);
/*
* 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.
*/
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 ExceptionRange record.
*/
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.
*/
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 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);
}
}
/*
* 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.
*
*----------------------------------------------------------------------
*/
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;
dupPtr = (ForeachInfo *) ckalloc((unsigned)
(sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *))));
dupPtr->numLists = numLists;
dupPtr->firstListTmp = srcPtr->firstListTmp;
dupPtr->loopIterNumTmp = srcPtr->loopIterNumTmp;
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);
}
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;
}
}
} 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;
}
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++;
}
} 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;
}
}
/*
* 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;
}
/*
* 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.
*/
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.
*/
envPtr->pushSimpleWords = 0;
result = CompileWord(interp, wordStart, argInfo.endArray[0] + 1,
flags, envPtr);
if (result != TCL_OK) {
goto done;
}
simpleVarName = envPtr->wordIsSimple;
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.
*/
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);
}
envPtr->pushSimpleWords = savePushSimpleWords;
envPtr->maxStackDepth = maxDepth;
FreeArgInfo(&argInfo);
return result;
}
/*
*----------------------------------------------------------------------
*
* TclCompileWhileCmd --
*
* Procedure called to compile the "while" command.
*
* 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.
*
* Side effects:
* Instructions are added to envPtr to evaluate the "while" command
* at runtime.
*
*----------------------------------------------------------------------
*/
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. */
{
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;
/*
* 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) 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;
}
/*
* 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->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.
*/
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 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--;
}
envPtr->termOffset = (src - string);
envPtr->maxStackDepth = maxDepth;
envPtr->pushSimpleWords = savePushSimpleWords;
envPtr->exprIsJustVarRef = saveExprIsJustVarRef;
envPtr->exprIsComparison = saveExprIsComparison;
return result;
}
/*
*----------------------------------------------------------------------
*
* 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 --
*
* 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
* local variables. If the variable's name is NULL, a new temporary
* variable is always created. (Such temporary variables can only be
* 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.
*
* Side effects:
* Creates and registers a new local variable if createIfNew is 1 and
* the variable is unknown, or if the name is NULL.
*
*----------------------------------------------------------------------
*/
static int
LookupCompiledLocal(name, nameChars, createIfNew, flagsIfCreated, 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
* 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;
register int i;
int localCt;
/*
* If not creating a temporary, does a local variable of the specified
* name already exist?
*/
if (name != NULL) {
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)) {
return i;
}
}
localPtr = localPtr->nextPtr;
}
}
/*
* Create a new variable if appropriate.
*/
if (createIfNew || (name == NULL)) {
localIndex = procPtr->numCompiledLocals;
localPtr = (CompiledLocal *) ckalloc((unsigned)
(sizeof(CompiledLocal) - sizeof(localPtr->name)
+ nameChars+1));
if (procPtr->firstLocalPtr == NULL) {
procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
} else {
procPtr->lastLocalPtr->nextPtr = localPtr;
procPtr->lastLocalPtr = localPtr;
}
localPtr->nextPtr = NULL;
localPtr->nameLength = nameChars;
localPtr->frameIndex = localIndex;
localPtr->flags = flagsIfCreated;
if (name == NULL) {
localPtr->flags |= VAR_TEMPORARY;
}
localPtr->defValuePtr = NULL;
localPtr->resolveInfo = NULL;
if (name != NULL) {
memcpy((VOID *) localPtr->name, (VOID *) name, (size_t) nameChars);
}
localPtr->name[nameChars] = '\0';
procPtr->numCompiledLocals++;
}
return localIndex;
}
/*
*----------------------------------------------------------------------
*
* TclInitCompiledLocals --
*
* This routine is invoked in order to initialize the compiled
* locals table for a new call frame.
*
* Results:
* None.
*
* Side effects:
* May invoke various name resolvers in order to determine which
* variables are being referenced at runtime.
*
*----------------------------------------------------------------------
*/
void
TclInitCompiledLocals(interp, framePtr, nsPtr)
Tcl_Interp *interp; /* Current interpreter. */
CallFrame *framePtr; /* Call frame to initialize. */
Namespace *nsPtr; /* Pointer to current namespace. */
{
register CompiledLocal *localPtr;
Interp *iPtr = (Interp*) interp;
Tcl_ResolvedVarInfo *vinfo, *resVarInfo;
Var *varPtr = framePtr->compiledLocals;
Var *resolvedVarPtr;
ResolverScheme *resPtr;
int result;
/*
* Initialize the array of local variables stored in the call frame.
* Some variables may have special resolution rules. In that case,
* we call their "resolver" procs to get our hands on the variable,
* and we make the compiled local a link to the real variable.
*/
for (localPtr = framePtr->procPtr->firstLocalPtr;
localPtr != NULL;
localPtr = localPtr->nextPtr) {
/*
* Check to see if this local is affected by namespace or
* interp resolvers. The resolver to use is cached for the
* next invocation of the procedure.
*/
if (!(localPtr->flags & (VAR_ARGUMENT|VAR_TEMPORARY|VAR_RESOLVED))
&& (nsPtr->compiledVarResProc || iPtr->resolverPtr)) {
resPtr = iPtr->resolverPtr;
if (nsPtr->compiledVarResProc) {
result = (*nsPtr->compiledVarResProc)(nsPtr->interp,
localPtr->name, localPtr->nameLength,
(Tcl_Namespace *) nsPtr, &vinfo);
} else {
result = TCL_CONTINUE;
}
while ((result == TCL_CONTINUE) && resPtr) {
if (resPtr->compiledVarResProc) {
result = (*resPtr->compiledVarResProc)(nsPtr->interp,
localPtr->name, localPtr->nameLength,
(Tcl_Namespace *) nsPtr, &vinfo);
}
resPtr = resPtr->nextPtr;
}
if (result == TCL_OK) {
localPtr->resolveInfo = vinfo;
localPtr->flags |= VAR_RESOLVED;
}
}
/*
* Now invoke the resolvers to determine the exact variables that
* should be used.
*/
resVarInfo = localPtr->resolveInfo;
resolvedVarPtr = NULL;
if (resVarInfo && resVarInfo->fetchProc) {
resolvedVarPtr = (Var*) (*resVarInfo->fetchProc)(interp,
resVarInfo);
}
if (resolvedVarPtr) {
varPtr->name = localPtr->name; /* will be just '\0' if temp var */
varPtr->nsPtr = NULL;
varPtr->hPtr = NULL;
varPtr->refCount = 0;
varPtr->tracePtr = NULL;
varPtr->searchPtr = NULL;
varPtr->flags = 0;
TclSetVarLink(varPtr);
varPtr->value.linkPtr = resolvedVarPtr;
resolvedVarPtr->refCount++;
} else {
varPtr->value.objPtr = NULL;
varPtr->name = localPtr->name; /* will be just '\0' if temp var */
varPtr->nsPtr = NULL;
varPtr->hPtr = NULL;
varPtr->refCount = 0;
varPtr->tracePtr = NULL;
varPtr->searchPtr = NULL;
varPtr->flags = (localPtr->flags | VAR_UNDEFINED);
}
varPtr++;
}
}
/*
*----------------------------------------------------------------------
*
* 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
* CompileEnv's code array.
*
* Results:
* None.
*
* Side effects:
* The byte code array in *envPtr is reallocated to a new array of
* double the size, and if envPtr->mallocedCodeArray is non-zero the
* old array is freed. Byte codes are copied from the old array to the
* new one.
*
*----------------------------------------------------------------------
*/
void
TclExpandCodeArray(envPtr)
CompileEnv *envPtr; /* Points to the CompileEnv whose code array
* must be enlarged. */
{
/*
* envPtr->codeNext is equal to envPtr->codeEnd. The currently defined
* code bytes are stored between envPtr->codeStart and
* (envPtr->codeNext - 1) [inclusive].
*/
size_t currBytes = TclCurrCodeOffset();
size_t newBytes = 2*(envPtr->codeEnd - envPtr->codeStart);
unsigned char *newPtr = (unsigned char *) ckalloc((unsigned) newBytes);
/*
* Copy from old code array to new, free old code array if needed, and
* mark new code array as malloced.
*/
memcpy((VOID *) newPtr, (VOID *) envPtr->codeStart, currBytes);
if (envPtr->mallocedCodeArray) {
ckfree((char *) envPtr->codeStart);
}
envPtr->codeStart = newPtr;
envPtr->codeNext = (newPtr + currBytes);
envPtr->codeEnd = (newPtr + newBytes);
envPtr->mallocedCodeArray = 1;
}
/*
*----------------------------------------------------------------------
*
* 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
* command. This information is used at runtime to map between
* instruction pc and source locations.
*
* Results:
* None.
*
* Side effects:
* Inserts source and code location information into the compilation
* environment envPtr for the command at index cmdIndex. The
* compilation environment's CmdLocation array is grown if necessary.
*
*----------------------------------------------------------------------
*/
static void
EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset)
CompileEnv *envPtr; /* Points to the compilation environment
* structure in which to enter command
* location information. */
int cmdIndex; /* Index of the command whose start data
* is being set. */
int srcOffset; /* Offset of first char of the command. */
int codeOffset; /* Offset of first byte of command code. */
{
CmdLocation *cmdLocPtr;
if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) {
panic("EnterCmdStartData: bad command index %d\n", cmdIndex);
}
if (cmdIndex >= envPtr->cmdMapEnd) {
/*
* Expand the command location array by allocating more storage from
* the heap. The currently allocated CmdLocation entries are stored
* from cmdMapPtr[0] up to cmdMapPtr[envPtr->cmdMapEnd] (inclusive).
*/
size_t currElems = envPtr->cmdMapEnd;
size_t newElems = 2*currElems;
size_t currBytes = currElems * sizeof(CmdLocation);
size_t newBytes = newElems * sizeof(CmdLocation);
CmdLocation *newPtr = (CmdLocation *) ckalloc((unsigned) newBytes);
/*
* Copy from old command location array to new, free old command
* location array if needed, and mark new array as malloced.
*/
memcpy((VOID *) newPtr, (VOID *) envPtr->cmdMapPtr, currBytes);
if (envPtr->mallocedCmdMap) {
ckfree((char *) envPtr->cmdMapPtr);
}
envPtr->cmdMapPtr = (CmdLocation *) newPtr;
envPtr->cmdMapEnd = newElems;
envPtr->mallocedCmdMap = 1;
}
if (cmdIndex > 0) {
if (codeOffset < envPtr->cmdMapPtr[cmdIndex-1].codeOffset) {
panic("EnterCmdStartData: cmd map table not sorted by code offset");
}
}
cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]);
cmdLocPtr->codeOffset = codeOffset;
cmdLocPtr->srcOffset = srcOffset;
cmdLocPtr->numSrcChars = -1;
cmdLocPtr->numCodeBytes = -1;
}
/*
*----------------------------------------------------------------------
*
* EnterCmdExtentData --
*
* Registers the source and bytecode length for a command. This
* information is used at runtime to map between instruction pc and
* source locations.
*
* Results:
* None.
*
* Side effects:
* Inserts source and code length information into the compilation
* environment envPtr for the command at index cmdIndex. Starting
* source and bytecode information for the command must already
* have been registered.
*
*----------------------------------------------------------------------
*/
static void
EnterCmdExtentData(envPtr, cmdIndex, numSrcChars, 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 numCodeBytes; /* Offset of last byte of command code. */
{
CmdLocation *cmdLocPtr;
if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) {
panic("EnterCmdStartData: bad command index %d\n", cmdIndex);
}
if (cmdIndex > envPtr->cmdMapEnd) {
panic("EnterCmdStartData: no start data registered for command with index %d\n", cmdIndex);
}
cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]);
cmdLocPtr->numSrcChars = numSrcChars;
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 --
*
* Procedure that allocates and initializes a new ExceptionRange
* structure of the specified kind in a CompileEnv's ExceptionRange
* array.
*
* Results:
* Returns the index for the newly created ExceptionRange.
*
* 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
* array is freed, and ExceptionRange entries are copied from the old
* array to the new one.
*
*----------------------------------------------------------------------
*/
static int
CreateExceptionRange(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. */
{
int index; /* Index for the newly-allocated
* ExceptionRange structure. */
register ExceptionRange *rangePtr;
/* Points to the new ExceptionRange
* structure */
index = envPtr->excRangeArrayNext;
if (index >= envPtr->excRangeArrayEnd) {
/*
* Expand the ExceptionRange array. The currently allocated entries
* are stored between elements 0 and (envPtr->excRangeArrayNext - 1)
* [inclusive].
*/
size_t currBytes =
envPtr->excRangeArrayNext * sizeof(ExceptionRange);
int newElems = 2*envPtr->excRangeArrayEnd;
size_t newBytes = newElems * sizeof(ExceptionRange);
ExceptionRange *newPtr = (ExceptionRange *)
ckalloc((unsigned) newBytes);
/*
* Copy from old ExceptionRange array to new, free old
* ExceptionRange array if needed, and mark the new ExceptionRange
* array as malloced.
*/
memcpy((VOID *) newPtr, (VOID *) envPtr->excRangeArrayPtr,
currBytes);
if (envPtr->mallocedExcRangeArray) {
ckfree((char *) envPtr->excRangeArrayPtr);
}
envPtr->excRangeArrayPtr = (ExceptionRange *) newPtr;
envPtr->excRangeArrayEnd = newElems;
envPtr->mallocedExcRangeArray = 1;
}
envPtr->excRangeArrayNext++;
rangePtr = &(envPtr->excRangeArrayPtr[index]);
rangePtr->type = type;
rangePtr->nestingLevel = envPtr->excRangeDepth;
rangePtr->codeOffset = -1;
rangePtr->numCodeBytes = -1;
rangePtr->breakOffset = -1;
rangePtr->continueOffset = -1;
rangePtr->catchOffset = -1;
return index;
}
/*
*----------------------------------------------------------------------
*
* TclCreateAuxData --
*
* Procedure that allocates and initializes a new AuxData structure in
* a CompileEnv's array of compilation auxiliary data records. These
* AuxData records hold information created during compilation by
* CompileProcs and used by instructions during execution.
*
* Results:
* Returns the index for the newly created AuxData structure.
*
* Side effects:
* If there is not enough room in the CompileEnv's AuxData array,
* the AuxData array in expanded: a new array of double the size
* is allocated, if envPtr->mallocedAuxDataArray is non-zero
* the old array is freed, and AuxData entries are copied from
* the old array to the new one.
*
*----------------------------------------------------------------------
*/
int
TclCreateAuxData(clientData, typePtr, envPtr)
ClientData clientData; /* The compilation auxiliary data to store
* 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. */
{
int index; /* Index for the new AuxData structure. */
register AuxData *auxDataPtr;
/* Points to the new AuxData structure */
index = envPtr->auxDataArrayNext;
if (index >= envPtr->auxDataArrayEnd) {
/*
* Expand the AuxData array. The currently allocated entries are
* stored between elements 0 and (envPtr->auxDataArrayNext - 1)
* [inclusive].
*/
size_t currBytes = envPtr->auxDataArrayNext * sizeof(AuxData);
int newElems = 2*envPtr->auxDataArrayEnd;
size_t newBytes = newElems * sizeof(AuxData);
AuxData *newPtr = (AuxData *) ckalloc((unsigned) newBytes);
/*
* Copy from old AuxData array to new, free old AuxData array if
* needed, and mark the new AuxData array as malloced.
*/
memcpy((VOID *) newPtr, (VOID *) envPtr->auxDataArrayPtr,
currBytes);
if (envPtr->mallocedAuxDataArray) {
ckfree((char *) envPtr->auxDataArrayPtr);
}
envPtr->auxDataArrayPtr = newPtr;
envPtr->auxDataArrayEnd = newElems;
envPtr->mallocedAuxDataArray = 1;
}
envPtr->auxDataArrayNext++;
auxDataPtr = &(envPtr->auxDataArrayPtr[index]);
auxDataPtr->type = typePtr;
auxDataPtr->clientData = clientData;
return index;
}
/*
*----------------------------------------------------------------------
*
* TclInitJumpFixupArray --
*
* Initializes a JumpFixupArray structure to hold some number of
* jump fixup entries.
*
* Results:
* None.
*
* Side effects:
* The JumpFixupArray structure is initialized.
*
*----------------------------------------------------------------------
*/
void
TclInitJumpFixupArray(fixupArrayPtr)
register JumpFixupArray *fixupArrayPtr;
/* Points to the JumpFixupArray structure
* to initialize. */
{
fixupArrayPtr->fixup = fixupArrayPtr->staticFixupSpace;
fixupArrayPtr->next = 0;
fixupArrayPtr->end = (JUMPFIXUP_INIT_ENTRIES - 1);
fixupArrayPtr->mallocedArray = 0;
}
/*
*----------------------------------------------------------------------
*
* TclExpandJumpFixupArray --
*
* Procedure that uses malloc to allocate more storage for a
* jump fixup array.
*
* Results:
* None.
*
* Side effects:
* The jump fixup array in *fixupArrayPtr is reallocated to a new array
* of double the size, and if fixupArrayPtr->mallocedArray is non-zero
* the old array is freed. Jump fixup structures are copied from the
* old array to the new one.
*
*----------------------------------------------------------------------
*/
void
TclExpandJumpFixupArray(fixupArrayPtr)
register JumpFixupArray *fixupArrayPtr;
/* Points to the JumpFixupArray structure
* to enlarge. */
{
/*
* The currently allocated jump fixup entries are stored from fixup[0]
* up to fixup[fixupArrayPtr->fixupNext] (*not* inclusive). We assume
* fixupArrayPtr->fixupNext is equal to fixupArrayPtr->fixupEnd.
*/
size_t currBytes = fixupArrayPtr->next * sizeof(JumpFixup);
int newElems = 2*(fixupArrayPtr->end + 1);
size_t newBytes = newElems * sizeof(JumpFixup);
JumpFixup *newPtr = (JumpFixup *) ckalloc((unsigned) newBytes);
/*
* Copy from the old array to new, free the old array if needed,
* and mark the new array as malloced.
*/
memcpy((VOID *) newPtr, (VOID *) fixupArrayPtr->fixup, currBytes);
if (fixupArrayPtr->mallocedArray) {
ckfree((char *) fixupArrayPtr->fixup);
}
fixupArrayPtr->fixup = (JumpFixup *) newPtr;
fixupArrayPtr->end = newElems;
fixupArrayPtr->mallocedArray = 1;
}
/*
*----------------------------------------------------------------------
*
* TclFreeJumpFixupArray --
*
* Free any storage allocated in a jump fixup array structure.
*
* Results:
* None.
*
* Side effects:
* Allocated storage in the JumpFixupArray structure is freed.
*
*----------------------------------------------------------------------
*/
void
TclFreeJumpFixupArray(fixupArrayPtr)
register JumpFixupArray *fixupArrayPtr;
/* Points to the JumpFixupArray structure
* to free. */
{
if (fixupArrayPtr->mallocedArray) {
ckfree((char *) fixupArrayPtr->fixup);
}
}
/*
*----------------------------------------------------------------------
*
* TclEmitForwardJump --
*
* Procedure to emit a two-byte forward jump of kind "jumpType". Since
* the jump may later have to be grown to five bytes if the jump target
* is more than, say, 127 bytes away, this procedure also initializes a
* JumpFixup record with information about the jump.
*
* Results:
* None.
*
* Side effects:
* The JumpFixup record pointed to by "jumpFixupPtr" is initialized
* with information needed later if the jump is to be grown. Also,
* a two byte jump of the designated type is emitted at the current
* point in the bytecode stream.
*
*----------------------------------------------------------------------
*/
void
TclEmitForwardJump(envPtr, jumpType, jumpFixupPtr)
CompileEnv *envPtr; /* Points to the CompileEnv structure that
* holds the resulting instruction. */
TclJumpType jumpType; /* Indicates the kind of jump: if true or
* false or unconditional. */
JumpFixup *jumpFixupPtr; /* Points to the JumpFixup structure to
* initialize with information about this
* forward jump. */
{
/*
* 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
* the current one.
*/
jumpFixupPtr->jumpType = jumpType;
jumpFixupPtr->codeOffset = TclCurrCodeOffset();
jumpFixupPtr->cmdIndex = envPtr->numCommands;
jumpFixupPtr->excRangeIndex = envPtr->excRangeArrayNext;
switch (jumpType) {
case TCL_UNCONDITIONAL_JUMP:
TclEmitInstInt1(INST_JUMP1, /*offset*/ 0, envPtr);
break;
case TCL_TRUE_JUMP:
TclEmitInstInt1(INST_JUMP_TRUE1, /*offset*/ 0, envPtr);
break;
default:
TclEmitInstInt1(INST_JUMP_FALSE1, /*offset*/ 0, envPtr);
break;
}
}
/*
*----------------------------------------------------------------------
*
* TclFixupForwardJump --
*
* Procedure that updates a previously-emitted forward jump to jump
* a specified number of bytes, "jumpDist". If necessary, the jump is
* grown from two to five bytes; this is done if the jump distance is
* greater than "distThreshold" (normally 127 bytes). The jump is
* described by a JumpFixup record previously initialized by
* TclEmitForwardJump.
*
* Results:
* 1 if the jump was grown and subsequent instructions had to be moved;
* otherwise 0. This result is returned to allow callers to update
* any additional code offsets they may hold.
*
* Side effects:
* The jump may be grown and subsequent instructions moved. If this
* happens, the code offsets for any commands and any ExceptionRange
* records between the jump and the current code address will be
* updated to reflect the moved code. Also, the bytecode instruction
* array in the CompileEnv structure may be grown and reallocated.
*
*----------------------------------------------------------------------
*/
int
TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold)
CompileEnv *envPtr; /* Points to the CompileEnv structure that
* holds the resulting instruction. */
JumpFixup *jumpFixupPtr; /* Points to the JumpFixup structure that
* describes the forward jump. */
int jumpDist; /* Jump distance to set in jump
* instruction. */
int distThreshold; /* Maximum distance before the two byte
* jump is grown to five bytes. */
{
unsigned char *jumpPc, *p;
int firstCmd, lastCmd, firstRange, lastRange, k;
unsigned int numBytes;
if (jumpDist <= distThreshold) {
jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset);
switch (jumpFixupPtr->jumpType) {
case TCL_UNCONDITIONAL_JUMP:
TclUpdateInstInt1AtPc(INST_JUMP1, jumpDist, jumpPc);
break;
case TCL_TRUE_JUMP:
TclUpdateInstInt1AtPc(INST_JUMP_TRUE1, jumpDist, jumpPc);
break;
default:
TclUpdateInstInt1AtPc(INST_JUMP_FALSE1, jumpDist, jumpPc);
break;
}
return 0;
}
/*
* We must grow the jump then move subsequent instructions down.
*/
TclEnsureCodeSpace(3, envPtr); /* NB: might change code addresses! */
jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset);
for (numBytes = envPtr->codeNext-jumpPc-2, p = jumpPc+2+numBytes-1;
numBytes > 0; numBytes--, p--) {
p[3] = p[0];
}
envPtr->codeNext += 3;
jumpDist += 3;
switch (jumpFixupPtr->jumpType) {
case TCL_UNCONDITIONAL_JUMP:
TclUpdateInstInt4AtPc(INST_JUMP4, jumpDist, jumpPc);
break;
case TCL_TRUE_JUMP:
TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDist, jumpPc);
break;
default:
TclUpdateInstInt4AtPc(INST_JUMP_FALSE4, jumpDist, jumpPc);
break;
}
/*
* Adjust the code offsets for any commands and any ExceptionRange
* records between the jump and the current code address.
*/
firstCmd = jumpFixupPtr->cmdIndex;
lastCmd = (envPtr->numCommands - 1);
if (firstCmd < lastCmd) {
for (k = firstCmd; k <= lastCmd; k++) {
(envPtr->cmdMapPtr[k]).codeOffset += 3;
}
}
firstRange = jumpFixupPtr->excRangeIndex;
lastRange = (envPtr->excRangeArrayNext - 1);
for (k = firstRange; k <= lastRange; k++) {
ExceptionRange *rangePtr = &(envPtr->excRangeArrayPtr[k]);
rangePtr->codeOffset += 3;
switch (rangePtr->type) {
case LOOP_EXCEPTION_RANGE:
rangePtr->breakOffset += 3;
if (rangePtr->continueOffset != -1) {
rangePtr->continueOffset += 3;
}
break;
case CATCH_EXCEPTION_RANGE:
rangePtr->catchOffset += 3;
break;
default:
panic("TclFixupForwardJump: unrecognized ExceptionRange type %d\n", rangePtr->type);
}
}
return 1; /* the jump was grown */
}
/*
*----------------------------------------------------------------------
*
* TclGetInstructionTable --
*
* Returns a pointer to the table describing Tcl bytecode instructions.
* This procedure is defined so that clients can access the pointer from
* outside the TCL DLLs.
*
* Results:
* Returns a pointer to the global instruction table, same as the expression
* (&instructionTable[0]).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
InstructionDesc *
TclGetInstructionTable()
{
return &instructionTable[0];
}
/*
*--------------------------------------------------------------
*
* TclRegisterAuxDataType --
*
* This procedure is called to register a new AuxData type
* in the table of all AuxData types supported by Tcl.
*
* Results:
* None.
*
* Side effects:
* The type is registered in the AuxData type table. If there was already
* a type with the same name as in typePtr, it is replaced with the
* new type.
*
*--------------------------------------------------------------
*/
void
TclRegisterAuxDataType(typePtr)
AuxDataType *typePtr; /* Information about object type;
* storage must be statically
* allocated (must live forever). */
{
register Tcl_HashEntry *hPtr;
int new;
if (!auxDataTypeTableInitialized) {
TclInitAuxDataTypeTable();
}
/*
* If there's already a type with the given name, remove it.
*/
hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typePtr->name);
if (hPtr != (Tcl_HashEntry *) NULL) {
Tcl_DeleteHashEntry(hPtr);
}
/*
* Now insert the new object type.
*/
hPtr = Tcl_CreateHashEntry(&auxDataTypeTable, typePtr->name, &new);
if (new) {
Tcl_SetHashValue(hPtr, typePtr);
}
}
/*
*----------------------------------------------------------------------
*
* TclGetAuxDataType --
*
* This procedure looks up an Auxdata type by name.
*
* Results:
* If an AuxData type with name matching "typeName" is found, a pointer
* to its AuxDataType structure is returned; otherwise, NULL is returned.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
AuxDataType *
TclGetAuxDataType(typeName)
char *typeName; /* Name of AuxData type to look up. */
{
register Tcl_HashEntry *hPtr;
AuxDataType *typePtr = NULL;
if (!auxDataTypeTableInitialized) {
TclInitAuxDataTypeTable();
}
hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typeName);
if (hPtr != (Tcl_HashEntry *) NULL) {
typePtr = (AuxDataType *) Tcl_GetHashValue(hPtr);
}
return typePtr;
}
/*
*--------------------------------------------------------------
*
* TclInitAuxDataTypeTable --
*
* This procedure is invoked to perform once-only initialization of
* the AuxData type table. It also registers the AuxData types defined in
* this file.
*
* Results:
* None.
*
* Side effects:
* Initializes the table of defined AuxData types "auxDataTypeTable" with
* builtin AuxData types defined in this file.
*
*--------------------------------------------------------------
*/
void
TclInitAuxDataTypeTable()
{
auxDataTypeTableInitialized = 1;
Tcl_InitHashTable(&auxDataTypeTable, TCL_STRING_KEYS);
TclRegisterAuxDataType(&tclForeachInfoType);
}
/*
*----------------------------------------------------------------------
*
* TclFinalizeAuxDataTypeTable --
*
* 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.
*
* Results:
* None.
*
* Side effects:
* Deletes all entries in the hash table of AuxData types, "auxDataTypeTable".
*
*----------------------------------------------------------------------
*/
void
TclFinalizeAuxDataTypeTable()
{
if (auxDataTypeTableInitialized) {
Tcl_DeleteHashTable(&auxDataTypeTable);
auxDataTypeTableInitialized = 0;
}
}