diff options
68 files changed, 2762 insertions, 31143 deletions
diff --git a/INCOMPATIBILITIES b/INCOMPATIBILITIES new file mode 100644 index 0000000..e49cf9d --- /dev/null +++ b/INCOMPATIBILITIES @@ -0,0 +1,50 @@ +This file documents the incompatibilities to Tcl8.6 in the published API, +as seen by scripts, tcl.h, tcl.decls and tclInt.decls. Other changes in +tclInt.h are not listed. + +GONE FOR GOOD (or so I hope) +------------- + +* compile flags USE_TCLALLOC and USE_THREAD_ALLOC are ignored + +* Tcl_CallFrame is gone (was in tcl.h!); some CallFrame manips (push, pop) + are gone from tclInt.decls (more to come) + +* allocator API is gone from tclInt.decls: no more obj or stack allocation + accessible from outside, TclpAlloc and friends are gone too + +* There is no more direct evaluation, everything goes through bytecodes + (except for canonical lists). TCL_EVAL_DIRECT is simply ignored. + INCOMPLETE: Tcl_Eval is still there ... + +* [case] + +* parts of the 8.6 NRE public API (most of it will be recreated). + Tcl_NRCreateCommand is gone for good (may come back for API compat, if + further breakage does not make the issue moot) + + +GONE FOR NOW (or so I hope) +------------ + +* TIP280 and [info frame] do not exist anymore. Some changes in tclInt.decls. + TIP348 and [info errorstack] are also gone. + +* The complete Tcl_CmdInfo manipulation. Functionality will be *partially* + reenabled, minus the ability to call *objProc "safely" (API will be provided) + +* all BC introspection and debugging; facilities will appear when we finish + replacing TEBC and friends + +* the ability to [yield] from within [subst]: we have 8.5 [subst], it is + recursive (and can blow the stack ... as can the compiler anyway) + +* command compilation: ALL commands are run from TEBC via EvalObjv. Only + expressions make a non-trivial use of TEBC. + + +TO BE STUDIED +------------- +* Precise wording of error messages, is it worth working towards + reproducing them faithfully? Not losing time on that now - not even in + rewriting the tests. diff --git a/generic/tcl.decls b/generic/tcl.decls index 1829249..ac416d7 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -473,9 +473,9 @@ declare 129 { declare 130 { int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName) } -declare 131 { - int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) -} +#declare 131 { +# int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) +#} declare 132 { void Tcl_EventuallyFree(ClientData clientData, Tcl_FreeProc *freeProc) } @@ -568,10 +568,10 @@ declare 157 { declare 158 { CONST86 Tcl_ChannelType *Tcl_GetChannelType(Tcl_Channel chan) } -declare 159 { - int Tcl_GetCommandInfo(Tcl_Interp *interp, const char *cmdName, - Tcl_CmdInfo *infoPtr) -} +#declare 159 { +# int Tcl_GetCommandInfo(Tcl_Interp *interp, const char *cmdName, +# Tcl_CmdInfo *infoPtr) +#} declare 160 { CONST84_RETURN char *Tcl_GetCommandName(Tcl_Interp *interp, Tcl_Command command) @@ -636,9 +636,9 @@ declare 176 { declare 177 { int Tcl_GlobalEval(Tcl_Interp *interp, const char *command) } -declare 178 { - int Tcl_GlobalEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) -} +#declare 178 { +# int Tcl_GlobalEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) +#} declare 179 { int Tcl_HideCommand(Tcl_Interp *interp, const char *cmdName, const char *hiddenCmdToken) @@ -801,10 +801,10 @@ declare 225 { int Tcl_SetChannelOption(Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, const char *newValue) } -declare 226 { - int Tcl_SetCommandInfo(Tcl_Interp *interp, const char *cmdName, - const Tcl_CmdInfo *infoPtr) -} +#declare 226 { +# int Tcl_SetCommandInfo(Tcl_Interp *interp, const char *cmdName, +# const Tcl_CmdInfo *infoPtr) +#} declare 227 { void Tcl_SetErrno(int err) } @@ -1726,13 +1726,13 @@ declare 483 { Tcl_CmdObjTraceProc *objProc, ClientData clientData, Tcl_CmdObjTraceDeleteProc *delProc) } -declare 484 { - int Tcl_GetCommandInfoFromToken(Tcl_Command token, Tcl_CmdInfo *infoPtr) -} -declare 485 { - int Tcl_SetCommandInfoFromToken(Tcl_Command token, - const Tcl_CmdInfo *infoPtr) -} +#declare 484 { +# int Tcl_GetCommandInfoFromToken(Tcl_Command token, Tcl_CmdInfo *infoPtr) +#} +#declare 485 { +# int Tcl_SetCommandInfoFromToken(Tcl_Command token, +# const Tcl_CmdInfo *infoPtr) +#} ### New functions on 64-bit dev branch ### # TIP#72 (64-bit values) dkf @@ -2128,12 +2128,12 @@ declare 582 { } # TIP #322 (NRE public interface) msofer -declare 583 { - Tcl_Command Tcl_NRCreateCommand(Tcl_Interp *interp, - const char *cmdName, Tcl_ObjCmdProc *proc, - Tcl_ObjCmdProc *nreProc, ClientData clientData, - Tcl_CmdDeleteProc *deleteProc) -} +#declare 583 { +# Tcl_Command Tcl_NRCreateCommand(Tcl_Interp *interp, +# const char *cmdName, Tcl_ObjCmdProc *proc, +# Tcl_ObjCmdProc *nreProc, ClientData clientData, +# Tcl_CmdDeleteProc *deleteProc) +#} declare 584 { int Tcl_NREvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags) } @@ -2300,9 +2300,9 @@ declare 625 { } # TIP #356 (NR-enabled substitution) dgp -declare 626 { - int Tcl_NRSubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags) -} +#declare 626 { +# int Tcl_NRSubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags) +#} # TIP #357 (Export TclLoadFile and TclpFindSymbol) kbk declare 627 { diff --git a/generic/tcl.h b/generic/tcl.h index 3003abf..226ef72 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -141,19 +141,10 @@ extern "C" { *---------------------------------------------------------------------------- * Support for functions with a variable number of arguments. * - * The following TCL_VARARGS* macros are to support old extensions - * written for older versions of Tcl where the macros permitted - * support for the varargs.h system as well as stdarg.h . - * * New code should just directly be written to use stdarg.h conventions. */ #include <stdarg.h> -#ifndef TCL_NO_DEPRECATED -# define TCL_VARARGS(type, name) (type name, ...) -# define TCL_VARARGS_DEF(type, name) (type name, ...) -# define TCL_VARARGS_START(type, name, list) (va_start(list, name), name) -#endif #if defined(__GNUC__) && (__GNUC__ > 2) # define TCL_FORMAT_PRINTF(a,b) __attribute__ ((__format__ (__printf__, a, b))) #else @@ -244,19 +235,6 @@ extern "C" { #endif /* - * The following _ANSI_ARGS_ macro is to support old extensions - * written for older versions of Tcl where it permitted support - * for compilers written in the pre-prototype era of C. - * - * New code should use prototypes. - */ - -#ifndef TCL_NO_DEPRECATED -# undef _ANSI_ARGS_ -# define _ANSI_ARGS_(x) x -#endif - -/* * Definitions that allow this header file to be used either with or without * ANSI C features. */ @@ -489,48 +467,9 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; * Programmers should use either the function Tcl_GetObjResult() or * Tcl_GetStringResult() to read the interpreter's result. See the SetResult * man page for details. - * - * Note: any change to the Tcl_Interp definition below must be mirrored in the - * "real" definition in tclInt.h. - * - * Note: Tcl_ObjCmdProc functions do not directly set result and freeProc. - * Instead, they set a Tcl_Obj member in the "real" structure that can be - * accessed with Tcl_GetObjResult() and Tcl_SetObjResult(). - */ - -typedef struct Tcl_Interp -#ifndef TCL_NO_DEPRECATED -{ - /* TIP #330: Strongly discourage extensions from using the string - * result. */ -#ifdef USE_INTERP_RESULT - char *result TCL_DEPRECATED_API("use Tcl_GetResult/Tcl_SetResult"); - /* If the last command returned a string - * result, this points to it. */ - void (*freeProc) (char *blockPtr) - TCL_DEPRECATED_API("use Tcl_GetResult/Tcl_SetResult"); - /* Zero means the string result is statically - * allocated. TCL_DYNAMIC means it was - * allocated with ckalloc and should be freed - * with ckfree. Other values give the address - * of function to invoke to free the result. - * Tcl_Eval must free it before executing next - * command. */ -#else - char *resultDontUse; /* Don't use in extensions! */ - void (*freeProcDontUse) (char *); /* Don't use in extensions! */ -#endif -#ifdef USE_INTERP_ERRORLINE - int errorLine TCL_DEPRECATED_API("use Tcl_GetErrorLine/Tcl_SetErrorLine"); - /* When TCL_ERROR is returned, this gives the - * line number within the command where the - * error occurred (1 if first line). */ -#else - int errorLineDontUse; /* Don't use in extensions! */ -#endif -} -#endif /* TCL_NO_DEPRECATED */ -Tcl_Interp; + */ + +typedef struct Tcl_Interp Tcl_Interp; typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler; typedef struct Tcl_Channel_ *Tcl_Channel; @@ -905,79 +844,13 @@ typedef struct Tcl_Namespace { /* *---------------------------------------------------------------------------- - * The following structure represents a call frame, or activation record. A - * call frame defines a naming context for a procedure call: its local scope - * (for local variables) and its namespace scope (used for non-local - * variables; often the global :: namespace). A call frame can also define the - * naming context for a namespace eval or namespace inscope command: the - * namespace in which the command's code should execute. The Tcl_CallFrame - * structures exist only while procedures or namespace eval/inscope's are - * being executed, and provide a Tcl call stack. - * - * A call frame is initialized and pushed using Tcl_PushCallFrame and popped - * using Tcl_PopCallFrame. Storage for a Tcl_CallFrame must be provided by the - * Tcl_PushCallFrame caller, and callers typically allocate them on the C call - * stack for efficiency. For this reason, Tcl_CallFrame is defined as a - * structure and not as an opaque token. However, most Tcl_CallFrame fields - * are hidden since applications should not access them directly; others are - * declared as "dummyX". + * DO NOT USE TCL CALL FRAMES! * - * WARNING!! The structure definition must be kept consistent with the - * CallFrame structure in tclInt.h. If you change one, change the other. - */ - -typedef struct Tcl_CallFrame { - Tcl_Namespace *nsPtr; - int dummy1; - int dummy2; - void *dummy3; - void *dummy4; - void *dummy5; - int dummy6; - void *dummy7; - void *dummy8; - int dummy9; - void *dummy10; - void *dummy11; - void *dummy12; - void *dummy13; -} Tcl_CallFrame; + * The Tcl_CallFrame struct has been retired! + * This macro here to cause your compilation to fail and warn you. + */ -/* - *---------------------------------------------------------------------------- - * Information about commands that is returned by Tcl_GetCommandInfo and - * passed to Tcl_SetCommandInfo. objProc is an objc/objv object-based command - * function while proc is a traditional Tcl argc/argv string-based function. - * Tcl_CreateObjCommand and Tcl_CreateCommand ensure that both objProc and - * proc are non-NULL and can be called to execute the command. However, it may - * be faster to call one instead of the other. The member isNativeObjectProc - * is set to 1 if an object-based function was registered by - * Tcl_CreateObjCommand, and to 0 if a string-based function was registered by - * Tcl_CreateCommand. The other function is typically set to a compatibility - * wrapper that does string-to-object or object-to-string argument conversions - * then calls the other function. - */ - -typedef struct Tcl_CmdInfo { - int isNativeObjectProc; /* 1 if objProc was registered by a call to - * Tcl_CreateObjCommand; 0 otherwise. - * Tcl_SetCmdInfo does not modify this - * field. */ - Tcl_ObjCmdProc *objProc; /* Command's object-based function. */ - ClientData objClientData; /* ClientData for object proc. */ - Tcl_CmdProc *proc; /* Command's string-based function. */ - ClientData clientData; /* ClientData for string proc. */ - Tcl_CmdDeleteProc *deleteProc; - /* Function to call when command is - * deleted. */ - ClientData deleteData; /* Value to pass to deleteProc (usually the - * same as clientData). */ - Tcl_Namespace *namespacePtr;/* Points to the namespace that contains this - * command. Note that Tcl_SetCmdInfo will not - * change a command's namespace; use - * TclRenameCommand or Tcl_Eval (of 'rename') - * to do that. */ -} Tcl_CmdInfo; +#define Tcl_CallFrame DO NOT USE Tcl_CallFrame! /* *---------------------------------------------------------------------------- @@ -1127,10 +1000,6 @@ typedef struct Tcl_DString { * give the flag) */ -#ifndef TCL_NO_DEPRECATED -# define TCL_PARSE_PART1 0x400 -#endif - /* * Types for linked variables: */ @@ -2601,28 +2470,6 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); * Deprecated Tcl functions: */ -#ifndef TCL_NO_DEPRECATED -# undef Tcl_EvalObj -# define Tcl_EvalObj(interp,objPtr) \ - Tcl_EvalObjEx((interp),(objPtr),0) -# undef Tcl_GlobalEvalObj -# define Tcl_GlobalEvalObj(interp,objPtr) \ - Tcl_EvalObjEx((interp),(objPtr),TCL_EVAL_GLOBAL) - -/* - * These function have been renamed. The old names are deprecated, but we - * define these macros for backwards compatibilty. - */ - -# define Tcl_Ckalloc Tcl_Alloc -# define Tcl_Ckfree Tcl_Free -# define Tcl_Ckrealloc Tcl_Realloc -# define Tcl_Return Tcl_SetResult -# define Tcl_TildeSubst Tcl_TranslateFileName -# define panic Tcl_Panic -# define panicVA Tcl_PanicVA -#endif /* !TCL_NO_DEPRECATED */ - /* *---------------------------------------------------------------------------- * Convenience declaration of Tcl_AppInit for backwards compatibility. This diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c deleted file mode 100644 index ae61e85..0000000 --- a/generic/tclAlloc.c +++ /dev/null @@ -1,759 +0,0 @@ -/* - * tclAlloc.c -- - * - * This is a very fast storage allocator. It allocates blocks of a small - * number of different sizes, and keeps free lists of each size. Blocks - * that don't exactly fit are passed up to the next larger size. Blocks - * over a certain size are directly allocated from the system. - * - * Copyright (c) 1983 Regents of the University of California. - * Copyright (c) 1996-1997 Sun Microsystems, Inc. - * Copyright (c) 1998-1999 by Scriptics Corporation. - * - * Portions contributed by Chris Kingsley, Jack Jansen and Ray Johnson. - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -/* - * Windows and Unix use an alternative allocator when building with threads - * that has significantly reduced lock contention. - */ - -#include "tclInt.h" -#if !defined(TCL_THREADS) || !defined(USE_THREAD_ALLOC) - -#if USE_TCLALLOC - -/* - * We should really make use of AC_CHECK_TYPE(caddr_t) here, but it can wait - * until Tcl uses config.h properly. - */ - -#if defined(_MSC_VER) || defined(__MINGW32__) || defined(__BORLANDC__) -typedef unsigned long caddr_t; -#endif - -/* - * The overhead on a block is at least 8 bytes. When free, this space contains - * a pointer to the next free block, and the bottom two bits must be zero. - * When in use, the first byte is set to MAGIC, and the second byte is the - * size index. The remaining bytes are for alignment. If range checking is - * enabled then a second word holds the size of the requested block, less 1, - * rounded up to a multiple of sizeof(RMAGIC). The order of elements is - * critical: ov.magic must overlay the low order bits of ov.next, and ov.magic - * can not be a valid ov.next bit pattern. - */ - -union overhead { - union overhead *next; /* when free */ - unsigned char padding[TCL_ALLOCALIGN]; /* align struct to TCL_ALLOCALIGN bytes */ - struct { - unsigned char magic0; /* magic number */ - unsigned char index; /* bucket # */ - unsigned char unused; /* unused */ - unsigned char magic1; /* other magic number */ -#ifndef NDEBUG - unsigned short rmagic; /* range magic number */ - unsigned long size; /* actual block size */ - unsigned short unused2; /* padding to 8-byte align */ -#endif - } ovu; -#define overMagic0 ovu.magic0 -#define overMagic1 ovu.magic1 -#define bucketIndex ovu.index -#define rangeCheckMagic ovu.rmagic -#define realBlockSize ovu.size -}; - - -#define MAGIC 0xef /* magic # on accounting info */ -#define RMAGIC 0x5555 /* magic # on range info */ - -#ifndef NDEBUG -#define RSLOP sizeof(unsigned short) -#else -#define RSLOP 0 -#endif - -#define OVERHEAD (sizeof(union overhead) + RSLOP) - -/* - * Macro to make it easier to refer to the end-of-block guard magic. - */ - -#define BLOCK_END(overPtr) \ - (*(unsigned short *)((caddr_t)((overPtr) + 1) + (overPtr)->realBlockSize)) - -/* - * nextf[i] is the pointer to the next free block of size 2^(i+3). The - * smallest allocatable block is MINBLOCK bytes. The overhead information - * precedes the data area returned to the user. - */ - -#define MINBLOCK ((sizeof(union overhead) + (TCL_ALLOCALIGN-1)) & ~(TCL_ALLOCALIGN-1)) -#define NBUCKETS (13 - (MINBLOCK >> 4)) -#define MAXMALLOC (1<<(NBUCKETS+2)) -static union overhead *nextf[NBUCKETS]; - -/* - * The following structure is used to keep track of all system memory - * currently owned by Tcl. When finalizing, all this memory will be returned - * to the system. - */ - -struct block { - struct block *nextPtr; /* Linked list. */ - struct block *prevPtr; /* Linked list for big blocks, ensures 8-byte - * alignment for suballocated blocks. */ -}; - -static struct block *blockList; /* Tracks the suballocated blocks. */ -static struct block bigBlocks={ /* Big blocks aren't suballocated. */ - &bigBlocks, &bigBlocks -}; - -/* - * The allocator is protected by a special mutex that must be explicitly - * initialized. Futhermore, because Tcl_Alloc may be used before anything else - * in Tcl, we make this module self-initializing after all with the allocInit - * variable. - */ - -#ifdef TCL_THREADS -static Tcl_Mutex *allocMutexPtr; -#endif -static int allocInit = 0; - -#ifdef MSTATS - -/* - * numMallocs[i] is the difference between the number of mallocs and frees for - * a given block size. - */ - -static unsigned int numMallocs[NBUCKETS+1]; -#endif - -#if !defined(NDEBUG) -#define ASSERT(p) if (!(p)) Tcl_Panic(# p) -#define RANGE_ASSERT(p) if (!(p)) Tcl_Panic(# p) -#else -#define ASSERT(p) -#define RANGE_ASSERT(p) -#endif - -/* - * Prototypes for functions used only in this file. - */ - -static void MoreCore(int bucket); - -/* - *------------------------------------------------------------------------- - * - * TclInitAlloc -- - * - * Initialize the memory system. - * - * Results: - * None. - * - * Side effects: - * Initialize the mutex used to serialize allocations. - * - *------------------------------------------------------------------------- - */ - -void -TclInitAlloc(void) -{ - if (!allocInit) { - allocInit = 1; -#ifdef TCL_THREADS - allocMutexPtr = Tcl_GetAllocMutex(); -#endif - } -} - -/* - *------------------------------------------------------------------------- - * - * TclFinalizeAllocSubsystem -- - * - * Release all resources being used by this subsystem, including - * aggressively freeing all memory allocated by TclpAlloc() that has not - * yet been released with TclpFree(). - * - * After this function is called, all memory allocated with TclpAlloc() - * should be considered unusable. - * - * Results: - * None. - * - * Side effects: - * This subsystem is self-initializing, since memory can be allocated - * before Tcl is formally initialized. After this call, this subsystem - * has been reset to its initial state and is usable again. - * - *------------------------------------------------------------------------- - */ - -void -TclFinalizeAllocSubsystem(void) -{ - unsigned int i; - struct block *blockPtr, *nextPtr; - - Tcl_MutexLock(allocMutexPtr); - for (blockPtr = blockList; blockPtr != NULL; blockPtr = nextPtr) { - nextPtr = blockPtr->nextPtr; - TclpSysFree(blockPtr); - } - blockList = NULL; - - for (blockPtr = bigBlocks.nextPtr; blockPtr != &bigBlocks; ) { - nextPtr = blockPtr->nextPtr; - TclpSysFree(blockPtr); - blockPtr = nextPtr; - } - bigBlocks.nextPtr = &bigBlocks; - bigBlocks.prevPtr = &bigBlocks; - - for (i=0 ; i<NBUCKETS ; i++) { - nextf[i] = NULL; -#ifdef MSTATS - numMallocs[i] = 0; -#endif - } -#ifdef MSTATS - numMallocs[i] = 0; -#endif - Tcl_MutexUnlock(allocMutexPtr); -} - -/* - *---------------------------------------------------------------------- - * - * TclpAlloc -- - * - * Allocate more memory. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -char * -TclpAlloc( - unsigned int numBytes) /* Number of bytes to allocate. */ -{ - register union overhead *overPtr; - register long bucket; - register unsigned amount; - struct block *bigBlockPtr = NULL; - - if (!allocInit) { - /* - * We have to make the "self initializing" because Tcl_Alloc may be - * used before any other part of Tcl. E.g., see main() for tclsh! - */ - - TclInitAlloc(); - } - Tcl_MutexLock(allocMutexPtr); - - /* - * First the simple case: we simple allocate big blocks directly. - */ - - if (numBytes >= MAXMALLOC - OVERHEAD) { - if (numBytes <= UINT_MAX - OVERHEAD -sizeof(struct block)) { - bigBlockPtr = (struct block *) TclpSysAlloc((unsigned) - (sizeof(struct block) + OVERHEAD + numBytes), 0); - } - if (bigBlockPtr == NULL) { - Tcl_MutexUnlock(allocMutexPtr); - return NULL; - } - bigBlockPtr->nextPtr = bigBlocks.nextPtr; - bigBlocks.nextPtr = bigBlockPtr; - bigBlockPtr->prevPtr = &bigBlocks; - bigBlockPtr->nextPtr->prevPtr = bigBlockPtr; - - overPtr = (union overhead *) (bigBlockPtr + 1); - overPtr->overMagic0 = overPtr->overMagic1 = MAGIC; - overPtr->bucketIndex = 0xff; -#ifdef MSTATS - numMallocs[NBUCKETS]++; -#endif - -#ifndef NDEBUG - /* - * Record allocated size of block and bound space with magic numbers. - */ - - overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1); - overPtr->rangeCheckMagic = RMAGIC; - BLOCK_END(overPtr) = RMAGIC; -#endif - - Tcl_MutexUnlock(allocMutexPtr); - return (void *)(overPtr+1); - } - - /* - * Convert amount of memory requested into closest block size stored in - * hash buckets which satisfies request. Account for space used per block - * for accounting. - */ - - amount = MINBLOCK; /* size of first bucket */ - bucket = MINBLOCK >> 4; - - while (numBytes + OVERHEAD > amount) { - amount <<= 1; - if (amount == 0) { - Tcl_MutexUnlock(allocMutexPtr); - return NULL; - } - bucket++; - } - ASSERT(bucket < NBUCKETS); - - /* - * If nothing in hash bucket right now, request more memory from the - * system. - */ - - if ((overPtr = nextf[bucket]) == NULL) { - MoreCore(bucket); - if ((overPtr = nextf[bucket]) == NULL) { - Tcl_MutexUnlock(allocMutexPtr); - return NULL; - } - } - - /* - * Remove from linked list - */ - - nextf[bucket] = overPtr->next; - overPtr->overMagic0 = overPtr->overMagic1 = MAGIC; - overPtr->bucketIndex = (unsigned char) bucket; - -#ifdef MSTATS - numMallocs[bucket]++; -#endif - -#ifndef NDEBUG - /* - * Record allocated size of block and bound space with magic numbers. - */ - - overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1); - overPtr->rangeCheckMagic = RMAGIC; - BLOCK_END(overPtr) = RMAGIC; -#endif - - Tcl_MutexUnlock(allocMutexPtr); - return ((char *)(overPtr + 1)); -} - -/* - *---------------------------------------------------------------------- - * - * MoreCore -- - * - * Allocate more memory to the indicated bucket. - * - * Assumes Mutex is already held. - * - * Results: - * None. - * - * Side effects: - * Attempts to get more memory from the system. - * - *---------------------------------------------------------------------- - */ - -static void -MoreCore( - int bucket) /* What bucket to allocat to. */ -{ - register union overhead *overPtr; - register long size; /* size of desired block */ - long amount; /* amount to allocate */ - int numBlocks; /* how many blocks we get */ - struct block *blockPtr; - - /* - * sbrk_size <= 0 only for big, FLUFFY, requests (about 2^30 bytes on a - * VAX, I think) or for a negative arg. - */ - - size = 1 << (bucket + 3); - ASSERT(size > 0); - - amount = MAXMALLOC; - numBlocks = amount / size; - ASSERT(numBlocks*size == amount); - - blockPtr = (struct block *) TclpSysAlloc((unsigned) - (sizeof(struct block) + amount), 1); - /* no more room! */ - if (blockPtr == NULL) { - return; - } - blockPtr->nextPtr = blockList; - blockList = blockPtr; - - overPtr = (union overhead *) (blockPtr + 1); - - /* - * Add new memory allocated to that on free list for this hash bucket. - */ - - nextf[bucket] = overPtr; - while (--numBlocks > 0) { - overPtr->next = (union overhead *)((caddr_t)overPtr + size); - overPtr = (union overhead *)((caddr_t)overPtr + size); - } - overPtr->next = NULL; -} - -/* - *---------------------------------------------------------------------- - * - * TclpFree -- - * - * Free memory. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void -TclpFree( - char *oldPtr) /* Pointer to memory to free. */ -{ - register long size; - register union overhead *overPtr; - struct block *bigBlockPtr; - - if (oldPtr == NULL) { - return; - } - - Tcl_MutexLock(allocMutexPtr); - overPtr = (union overhead *)((caddr_t)oldPtr - sizeof(union overhead)); - - ASSERT(overPtr->overMagic0 == MAGIC); /* make sure it was in use */ - ASSERT(overPtr->overMagic1 == MAGIC); - if (overPtr->overMagic0 != MAGIC || overPtr->overMagic1 != MAGIC) { - Tcl_MutexUnlock(allocMutexPtr); - return; - } - - RANGE_ASSERT(overPtr->rangeCheckMagic == RMAGIC); - RANGE_ASSERT(BLOCK_END(overPtr) == RMAGIC); - size = overPtr->bucketIndex; - if (size == 0xff) { -#ifdef MSTATS - numMallocs[NBUCKETS]--; -#endif - - bigBlockPtr = (struct block *) overPtr - 1; - bigBlockPtr->prevPtr->nextPtr = bigBlockPtr->nextPtr; - bigBlockPtr->nextPtr->prevPtr = bigBlockPtr->prevPtr; - TclpSysFree(bigBlockPtr); - - Tcl_MutexUnlock(allocMutexPtr); - return; - } - ASSERT(size < NBUCKETS); - overPtr->next = nextf[size]; /* also clobbers overMagic */ - nextf[size] = overPtr; - -#ifdef MSTATS - numMallocs[size]--; -#endif - - Tcl_MutexUnlock(allocMutexPtr); -} - -/* - *---------------------------------------------------------------------- - * - * TclpRealloc -- - * - * Reallocate memory. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -char * -TclpRealloc( - char *oldPtr, /* Pointer to alloced block. */ - unsigned int numBytes) /* New size of memory. */ -{ - int i; - union overhead *overPtr; - struct block *bigBlockPtr; - int expensive; - unsigned long maxSize; - - if (oldPtr == NULL) { - return TclpAlloc(numBytes); - } - - Tcl_MutexLock(allocMutexPtr); - - overPtr = (union overhead *)((caddr_t)oldPtr - sizeof(union overhead)); - - ASSERT(overPtr->overMagic0 == MAGIC); /* make sure it was in use */ - ASSERT(overPtr->overMagic1 == MAGIC); - if (overPtr->overMagic0 != MAGIC || overPtr->overMagic1 != MAGIC) { - Tcl_MutexUnlock(allocMutexPtr); - return NULL; - } - - RANGE_ASSERT(overPtr->rangeCheckMagic == RMAGIC); - RANGE_ASSERT(BLOCK_END(overPtr) == RMAGIC); - i = overPtr->bucketIndex; - - /* - * If the block isn't in a bin, just realloc it. - */ - - if (i == 0xff) { - struct block *prevPtr, *nextPtr; - bigBlockPtr = (struct block *) overPtr - 1; - prevPtr = bigBlockPtr->prevPtr; - nextPtr = bigBlockPtr->nextPtr; - bigBlockPtr = (struct block *) TclpSysRealloc(bigBlockPtr, - sizeof(struct block) + OVERHEAD + numBytes); - if (bigBlockPtr == NULL) { - Tcl_MutexUnlock(allocMutexPtr); - return NULL; - } - - if (prevPtr->nextPtr != bigBlockPtr) { - /* - * If the block has moved, splice the new block into the list - * where the old block used to be. - */ - - prevPtr->nextPtr = bigBlockPtr; - nextPtr->prevPtr = bigBlockPtr; - } - - overPtr = (union overhead *) (bigBlockPtr + 1); - -#ifdef MSTATS - numMallocs[NBUCKETS]++; -#endif - -#ifndef NDEBUG - /* - * Record allocated size of block and update magic number bounds. - */ - - overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1); - BLOCK_END(overPtr) = RMAGIC; -#endif - - Tcl_MutexUnlock(allocMutexPtr); - return (char *)(overPtr+1); - } - maxSize = 1 << (i+3); - expensive = 0; - if (numBytes+OVERHEAD > maxSize) { - expensive = 1; - } else if (i>0 && numBytes+OVERHEAD < maxSize/2) { - expensive = 1; - } - - if (expensive) { - void *newPtr; - - Tcl_MutexUnlock(allocMutexPtr); - - newPtr = TclpAlloc(numBytes); - if (newPtr == NULL) { - return NULL; - } - maxSize -= OVERHEAD; - if (maxSize < numBytes) { - numBytes = maxSize; - } - memcpy(newPtr, oldPtr, (size_t) numBytes); - TclpFree(oldPtr); - return newPtr; - } - - /* - * Ok, we don't have to copy, it fits as-is - */ - -#ifndef NDEBUG - overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1); - BLOCK_END(overPtr) = RMAGIC; -#endif - - Tcl_MutexUnlock(allocMutexPtr); - return(oldPtr); -} - -/* - *---------------------------------------------------------------------- - * - * mstats -- - * - * Prints two lines of numbers, one showing the length of the free list - * for each size category, the second showing the number of mallocs - - * frees for each size category. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -#ifdef MSTATS -void -mstats( - char *s) /* Where to write info. */ -{ - register int i, j; - register union overhead *overPtr; - int totalFree = 0, totalUsed = 0; - - Tcl_MutexLock(allocMutexPtr); - - fprintf(stderr, "Memory allocation statistics %s\nTclpFree:\t", s); - for (i = 0; i < NBUCKETS; i++) { - for (j=0, overPtr=nextf[i]; overPtr; overPtr=overPtr->next, j++) { - fprintf(stderr, " %d", j); - } - totalFree += j * (1 << (i + 3)); - } - - fprintf(stderr, "\nused:\t"); - for (i = 0; i < NBUCKETS; i++) { - fprintf(stderr, " %d", numMallocs[i]); - totalUsed += numMallocs[i] * (1 << (i + 3)); - } - - fprintf(stderr, "\n\tTotal small in use: %d, total free: %d\n", - totalUsed, totalFree); - fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %d\n", - MAXMALLOC, numMallocs[NBUCKETS]); - - Tcl_MutexUnlock(allocMutexPtr); -} -#endif - -#else /* !USE_TCLALLOC */ - -/* - *---------------------------------------------------------------------- - * - * TclpAlloc -- - * - * Allocate more memory. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -char * -TclpAlloc( - unsigned int numBytes) /* Number of bytes to allocate. */ -{ - return (char *) malloc(numBytes); -} - -/* - *---------------------------------------------------------------------- - * - * TclpFree -- - * - * Free memory. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void -TclpFree( - char *oldPtr) /* Pointer to memory to free. */ -{ - free(oldPtr); - return; -} - -/* - *---------------------------------------------------------------------- - * - * TclpRealloc -- - * - * Reallocate memory. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -char * -TclpRealloc( - char *oldPtr, /* Pointer to alloced block. */ - unsigned int numBytes) /* New size of memory. */ -{ - return (char *) realloc(oldPtr, numBytes); -} - -#endif /* !USE_TCLALLOC */ -#endif /* !TCL_THREADS */ - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ diff --git a/generic/tclAlloc.h b/generic/tclAlloc.h new file mode 100644 index 0000000..3913773 --- /dev/null +++ b/generic/tclAlloc.h @@ -0,0 +1,66 @@ +/* + * tclAlloc.h -- + * + * This defines the interface for pluggable memory allocators for Tcl. + * + * Copyright (c) 2013 by Miguel Sofer. All rights reserved. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#ifndef _TCLALLOC +#define _TCLALLOC + +/* + * These 5 functions MUST be defined by the allocator. + */ + +char * TclpAlloc(unsigned int reqSize); +char * TclpRealloc(char *ptr, unsigned int reqSize); +void TclpFree(char *ptr); +void TclXpInitAlloc(void); +void TclXpFinalizeAlloc(void); +void TclXpFreeAllocCache(void *ptr); + + +/* + * These are utility functions (defined in tclAlloc.c) to give access to + * either per-thread or per-interp caches. They will return a pointer to which + * the allocator should attach the proper structure that it wishes to + * maintain. If the allocator doesn't want to use Tcl's resources, it will + * just never call them. + * + * If TclGetAllocCache returns NULL, it means that the value has not been + * initialized for this interp or thread and the corresponding Set function + * should be called. + */ + +void TclSetSharedAllocCache(void *allocCachePtr); +void TclSetAllocCache(void *allocCachePtr); +void *TclGetAllocCache(void); + +/* + * The allocator should allow for "purify mode" by checking this variable. If + * it is set to !0, it should just shunt to plain malloc. + * This is used for debugging; the value can be treated as a constant, it does + * not change in a running process. + */ + +int TCL_PURIFY; +int TCL_THREADED; + +/* + * This macro is used to properly align the memory allocated by Tcl, giving + * the same alignment as the native malloc. + */ + +#if defined(__APPLE__) +#define ALLOCALIGN 16 +#else +#define ALLOCALIGN (2*sizeof(void *)) +#endif + +#define ALIGN(x) (((x) + ALLOCALIGN - 1) & ~(ALLOCALIGN - 1)) + +#endif diff --git a/generic/tclAllocNative.c b/generic/tclAllocNative.c new file mode 100644 index 0000000..6fb354a --- /dev/null +++ b/generic/tclAllocNative.c @@ -0,0 +1,52 @@ +/* + * tclAlloc.c -- + * + * This is the basic native allocator for Tcl. + * + * Copyright (c) 2013 by Miguel Sofer. All rights reserved. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include <stdlib.h> +#include "tclAlloc.h" + +char * +TclpAlloc( + unsigned int reqSize) +{ + return malloc(reqSize); +} + +char * +TclpRealloc( + char *ptr, + unsigned int reqSize) +{ + return realloc(ptr, reqSize); +} + +void +TclpFree( + char *ptr) +{ + free(ptr); +} + +void +TclXpInitAlloc(void) +{ +} + +void +TclXpFinalizeAlloc(void) +{ +} + +void +TclXpFreeAllocCache( + void *ptr) +{ +} + diff --git a/generic/tclAllocZippy.c b/generic/tclAllocZippy.c new file mode 100644 index 0000000..d720747 --- /dev/null +++ b/generic/tclAllocZippy.c @@ -0,0 +1,763 @@ +/* + * tclAllocZippy.c -- + * + * This is a very flexible storage allocator for Tcl, for use with or + * without threads. + * + * It is essentially the ex-tclThreadAlloc, aolserver's fast threaded + * allocator. Mods with respect to the original: + * - it is split into two: the freeObj list is part of Tcl itself, + * in tclAlloc.c, and the malloc() part is here + * - split blocks in the shared pool before mallocing again for + * improved cache usage + * - stats and Tcl_GetMemoryInfo are gone + * - adapt for unthreaded usage as replacement of the ex tclAlloc + * - (TODO!) build zippy as a pre-loadable library to use with a + * native build as a malloc replacement. Difficulty is to make it + * portable (easy enough on modern elf/unix, to be researched on + * win and mac . This would be the best option, instead of + * MULTI. It could be built in two versions (perf, debug/stats) + * + * The Initial Developer of the Original Code is America Online, Inc. + * Portions created by AOL are Copyright (C) 1999 America Online, Inc. + * + * Copyright (c) 2008-2013 by Miguel Sofer. All rights reserved. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tclInt.h" +#include "tclAlloc.h" + +#undef TclpAlloc +#undef TclpRealloc +#undef TclpFree + +/* + * The following struct stores accounting information for each block including + * two small magic numbers and a bucket number when in use or a next pointer + * when free. The original requested size (not including the Block overhead) + * is also maintained. + */ + +/* + * The following union stores accounting information for each block including + * two small magic numbers and a bucket number when in use or a next pointer + * when free. The original requested size (not including the Block overhead) + * is also maintained. + */ + +typedef struct Block { + union { + struct Block *next; /* Next in free list. */ + struct { + unsigned char magic1; /* First magic number. */ + unsigned char bucket; /* Bucket block allocated from. */ + unsigned char inUse; /* Block memory currently in use, used + * by realloc. */ + unsigned char magic2; /* Second magic number. */ + } s; + } u; +} Block; + +#define OFFSET ALIGN(sizeof(Block)) + +#define nextBlock u.next +#define sourceBucket u.s.bucket +#define magicNum1 u.s.magic1 +#define magicNum2 u.s.magic2 +#define used u.s.inUse +#define MAGIC 0xEF + +/* + * The following defines the minimum and maximum block sizes and the number + * of buckets in the bucket cache. + * 32b 64b Apple-32b(?) + * ALLOCALIGN 8 16 16 + * sizeof(Block) 8 16 16 + * OFFSET 8 16 16 + * MINALLOC 16 32 32 + * NBUCKETS 11 10 10 + * MAXALLOC 16384 16384 16384 + * small allocs 1024 512 1024 + * at a time + */ + +#define MINALLOC ALIGN(OFFSET+8) +#define NBUCKETS (11 - (MINALLOC >> 5)) +#define MAXALLOC (MINALLOC << (NBUCKETS - 1)) + +/* + * The following structure defines a bucket of blocks, optionally with various + * accounting and statistics information. + */ + +typedef struct Bucket { + Block *firstPtr; /* First block available */ + long numFree; /* Number of blocks available */ +} Bucket; + +/* + * The following array specifies various per-bucket limits and locks. The + * values are statically initialized to avoid calculating them repeatedly. + */ + +static struct { + size_t blockSize; /* Bucket blocksize. */ + int shift; + int maxBlocks; /* Max blocks before move to share. */ + int numMove; /* Num blocks to move to share. */ + Tcl_Mutex *lockPtr; /* Share bucket lock. */ +} bucketInfo[NBUCKETS]; + +/* + * The Tcl_Obj per-thread cache, used by aNATIVE, aZIPPY and aMULTI. + */ + +typedef struct Cache { + Bucket buckets[NBUCKETS]; /* The buckets for this thread */ +} Cache; + +static Cache sharedCache; +#define sharedPtr (&sharedCache) + +static void InitBucketInfo(void); +static inline char * Block2Ptr(Block *blockPtr, + int bucket, unsigned int reqSize); +static inline Block * Ptr2Block(char *ptr); + +static int GetBlocks(Cache *cachePtr, int bucket); + +static void PutBlocks(Cache *cachePtr, int bucket, int numMove); +static inline void LockBucket(int bucket); +static inline void UnlockBucket(int bucket); + + +/* + *------------------------------------------------------------------------- + * + * TclXpInitAlloc -- + * + * Initialize the memory system. + * + * Results: + * None. + * + * Side effects: + * Initialize the mutex used to serialize allocations. + * + *------------------------------------------------------------------------- + */ + +static void +InitBucketInfo () +{ + int i; + int shift = 0; + + for (i = 0; i < NBUCKETS; ++i) { + bucketInfo[i].blockSize = MINALLOC << i; + while (((bucketInfo[i].blockSize -OFFSET) >> shift) > 255) { + ++shift; + } + bucketInfo[i].shift = shift; + + if (TCL_THREADED) { + /* TODO: clearer logic? Change move to keep? */ + bucketInfo[i].maxBlocks = 1 << (NBUCKETS - 1 - i); + bucketInfo[i].numMove = i < NBUCKETS - 1 ? + 1 << (NBUCKETS - 2 - i) : 1; + bucketInfo[i].lockPtr = TclpNewAllocMutex(); + } + } +} + +void +TclXpInitAlloc(void) +{ + /* + * Set the params for the correct allocator + */ + + if (TCL_THREADED) { + InitBucketInfo(); + TclSetSharedAllocCache(sharedPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclXpFinalizeAlloc -- + * + * This procedure is used to destroy all private resources used in this + * file. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclXpFinalizeAlloc(void) +{ + + if (TCL_THREADED) { + unsigned int i; + + for (i = 0; i < NBUCKETS; ++i) { + TclpFreeAllocMutex(bucketInfo[i].lockPtr); + bucketInfo[i].lockPtr = NULL; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TclXpFreeAllocCache -- + * + * Flush and delete a cache + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclXpFreeAllocCache( + void *arg) +{ + Cache *cachePtr = arg; + + register unsigned int bucket; + + /* + * Flush blocks. + */ + + for (bucket = 0; bucket < NBUCKETS; ++bucket) { + if (cachePtr->buckets[bucket].numFree > 0) { + PutBlocks(cachePtr, bucket, cachePtr->buckets[bucket].numFree); + } + } + free(cachePtr); +} + +/* + *---------------------------------------------------------------------- + * + * Block2Ptr, Ptr2Block -- + * + * Convert between internal blocks and user pointers. + * + * Results: + * User pointer or internal block. + * + * Side effects: + * Invalid blocks will abort the server. + * + *---------------------------------------------------------------------- + */ + +static inline char * +Block2Ptr( + Block *blockPtr, + int bucket, + unsigned int reqSize) +{ + register void *ptr; + + blockPtr->magicNum1 = blockPtr->magicNum2 = MAGIC; + if (bucket == NBUCKETS) { + blockPtr->used = 255; + } else { + blockPtr->used = (reqSize >> bucketInfo[bucket].shift); + } + blockPtr->sourceBucket = bucket; + ptr = (void *) (((char *)blockPtr) + OFFSET); + return (char *) ptr; +} + +static inline Block * +Ptr2Block( + char *ptr) +{ + register Block *blockPtr; + + blockPtr = (Block *) (((char *) ptr) - OFFSET); + if (blockPtr->magicNum1 != MAGIC || blockPtr->magicNum2 != MAGIC) { + Tcl_Panic("alloc: invalid block: %p: %x %x", + blockPtr, blockPtr->magicNum1, blockPtr->magicNum2); + } + return blockPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclpAlloc -- + * + * Allocate memory. + * + * Results: + * Pointer to memory just beyond Block pointer. + * + * Side effects: + * May allocate more blocks for a bucket. + * + *---------------------------------------------------------------------- + */ + +static inline Cache * +GetAllocCache(void) +{ + Cache *cachePtr = TclGetAllocCache(); + if (cachePtr == NULL) { + cachePtr = calloc(1, sizeof(Cache)); + if (cachePtr == NULL) { + Tcl_Panic("alloc: could not allocate new cache"); + } + TclSetAllocCache(cachePtr); + } + return cachePtr; +} + + +char * +TclpAlloc( + unsigned int reqSize) +{ + Cache *cachePtr; + Block *blockPtr; + register int bucket; + size_t size; + + if (TCL_PURIFY) { + return (void *) malloc(reqSize); + } + + cachePtr = GetAllocCache(); + +#ifndef __LP64__ + if (sizeof(int) >= sizeof(size_t)) { + /* An unsigned int overflow can also be a size_t overflow */ + const size_t zero = 0; + const size_t max = ~zero; + + if (((size_t) reqSize) > max - OFFSET) { + /* Requested allocation exceeds memory */ + return NULL; + } + } +#endif + + /* + * Increment the requested size to include room for the Block structure. + * Call malloc() directly if the required amount is greater than the + * largest block, otherwise pop the smallest block large enough, + * allocating more blocks if necessary. + */ + + size = reqSize + OFFSET; + if (size > MAXALLOC) { + bucket = NBUCKETS; + blockPtr = malloc(size); + } else { + blockPtr = NULL; + bucket = 0; + while (bucketInfo[bucket].blockSize < size) { + bucket++; + } + if (cachePtr->buckets[bucket].numFree || GetBlocks(cachePtr, bucket)) { + blockPtr = cachePtr->buckets[bucket].firstPtr; + cachePtr->buckets[bucket].firstPtr = blockPtr->nextBlock; + cachePtr->buckets[bucket].numFree--; + } + if (blockPtr == NULL) { + return NULL; + } + } + return Block2Ptr(blockPtr, bucket, reqSize); +} + +/* + *---------------------------------------------------------------------- + * + * TclpFree -- + * + * Return blocks to the thread block cache. + * + * Results: + * None. + * + * Side effects: + * May move blocks to shared cache. + * + *---------------------------------------------------------------------- + */ + +void +TclpFree( + char *ptr) +{ + Cache *cachePtr; + Block *blockPtr; + int bucket; + + if (TCL_PURIFY) { + return free((char *) ptr); + } + + if (ptr == NULL) { + return; + } + + blockPtr = Ptr2Block(ptr); + + /* + * Get the block back from the user pointer and call system free directly + * for large blocks. Otherwise, push the block back on the bucket and move + * blocks to the shared cache if there are now too many free. + */ + + bucket = blockPtr->sourceBucket; + if (bucket == NBUCKETS) { + free(blockPtr); + return; + } + + cachePtr = GetAllocCache(); + + blockPtr->nextBlock = cachePtr->buckets[bucket].firstPtr; + cachePtr->buckets[bucket].firstPtr = blockPtr; + cachePtr->buckets[bucket].numFree++; + if (cachePtr != sharedPtr && + cachePtr->buckets[bucket].numFree > bucketInfo[bucket].maxBlocks) { + PutBlocks(cachePtr, bucket, bucketInfo[bucket].numMove); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclpRealloc -- + * + * Re-allocate memory to a larger or smaller size. + * + * Results: + * Pointer to memory just beyond Block pointer. + * + * Side effects: + * Previous memory, if any, may be freed. + * + *---------------------------------------------------------------------- + */ + +char * +TclpRealloc( + char *ptr, + unsigned int reqSize) +{ + Block *blockPtr; + void *newPtr; + size_t size, min; + int bucket; + + if (TCL_PURIFY) { + return (void *) realloc((char *) ptr, reqSize); + } + + if (ptr == NULL) { + return TclpAlloc(reqSize); + } + +#ifndef __LP64__ + if (sizeof(int) >= sizeof(size_t)) { + /* An unsigned int overflow can also be a size_t overflow */ + const size_t zero = 0; + const size_t max = ~zero; + + if (((size_t) reqSize) > max - OFFSET) { + /* Requested allocation exceeds memory */ + return NULL; + } + } +#endif + + /* + * If the block is not a system block and belongs in the same block, + * simply return the existing pointer. Otherwise, if the block is a system + * block and the new size would also require a system block, call + * realloc() directly. + */ + + blockPtr = Ptr2Block(ptr); + + size = reqSize + OFFSET; + bucket = blockPtr->sourceBucket; + if (bucket != NBUCKETS) { + if (bucket > 0) { + min = bucketInfo[bucket-1].blockSize; + } else { + min = 0; + } + if (size > min && size <= bucketInfo[bucket].blockSize) { + return Block2Ptr(blockPtr, bucket, reqSize); + } + } else if (size > MAXALLOC) { + blockPtr = realloc(blockPtr, size); + if (blockPtr == NULL) { + return NULL; + } + return Block2Ptr(blockPtr, NBUCKETS, reqSize); + } + + /* + * Finally, perform an expensive malloc/copy/free. + */ + + newPtr = TclpAlloc(reqSize); + if (newPtr != NULL) { + size_t maxSize = bucketInfo[bucket].blockSize - OFFSET; + size_t toCopy = ((blockPtr->used + 1) << bucketInfo[bucket].shift); + + if (toCopy > maxSize) { + toCopy = maxSize; + } + if (toCopy > reqSize) { + toCopy = reqSize; + } + + memcpy(newPtr, ptr, toCopy); + TclpFree(ptr); + } + return newPtr; +} + +/* + *---------------------------------------------------------------------- + * + * LockBucket, UnlockBucket -- + * + * Set/unset the lock to access a bucket in the shared cache. + * + * Results: + * None. + * + * Side effects: + * Lock activity and contention are monitored globally and on a per-cache + * basis. + * + *---------------------------------------------------------------------- + */ + +static inline void +LockBucket( + int bucket) +{ + Tcl_MutexLock(bucketInfo[bucket].lockPtr); +} + +static inline void +UnlockBucket( + int bucket) +{ + Tcl_MutexUnlock(bucketInfo[bucket].lockPtr); +} + +/* + *---------------------------------------------------------------------- + * + * PutBlocks -- + * + * Return unused blocks to the shared cache. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +PutBlocks( + Cache *cachePtr, + int bucket, + int numMove) +{ + register Block *lastPtr, *firstPtr; + register int n = numMove; + + /* + * Before acquiring the lock, walk the block list to find the last block + * to be moved. + */ + + firstPtr = lastPtr = cachePtr->buckets[bucket].firstPtr; + while (--n > 0) { + lastPtr = lastPtr->nextBlock; + } + cachePtr->buckets[bucket].firstPtr = lastPtr->nextBlock; + cachePtr->buckets[bucket].numFree -= numMove; + + /* + * Aquire the lock and place the list of blocks at the front of the shared + * cache bucket. + */ + + LockBucket(bucket); + lastPtr->nextBlock = sharedPtr->buckets[bucket].firstPtr; + sharedPtr->buckets[bucket].firstPtr = firstPtr; + sharedPtr->buckets[bucket].numFree += numMove; + UnlockBucket(bucket); +} + +/* + *---------------------------------------------------------------------- + * + * GetBlocks -- + * + * Get more blocks for a bucket. + * + * Results: + * 1 if blocks where allocated, 0 otherwise. + * + * Side effects: + * Cache may be filled with available blocks. + * + *---------------------------------------------------------------------- + */ + +static int +GetBlocks( + Cache *cachePtr, + int bucket) +{ + register Block *blockPtr = NULL; + register int n; + + /* + * First, atttempt to move blocks from the shared cache. Note the + * potentially dirty read of numFree before acquiring the lock which is a + * slight performance enhancement. The value is verified after the lock is + * actually acquired. + */ + + if (cachePtr != sharedPtr && sharedPtr->buckets[bucket].numFree > 0) { + LockBucket(bucket); + if (sharedPtr->buckets[bucket].numFree > 0) { + + /* + * Either move the entire list or walk the list to find the last + * block to move. + */ + + n = bucketInfo[bucket].numMove; + if (n >= sharedPtr->buckets[bucket].numFree) { + cachePtr->buckets[bucket].firstPtr = + sharedPtr->buckets[bucket].firstPtr; + cachePtr->buckets[bucket].numFree = + sharedPtr->buckets[bucket].numFree; + sharedPtr->buckets[bucket].firstPtr = NULL; + sharedPtr->buckets[bucket].numFree = 0; + } else { + blockPtr = sharedPtr->buckets[bucket].firstPtr; + cachePtr->buckets[bucket].firstPtr = blockPtr; + sharedPtr->buckets[bucket].numFree -= n; + cachePtr->buckets[bucket].numFree = n; + while (--n > 0) { + blockPtr = blockPtr->nextBlock; + } + sharedPtr->buckets[bucket].firstPtr = blockPtr->nextBlock; + blockPtr->nextBlock = NULL; + } + } + UnlockBucket(bucket); + } + + if (cachePtr->buckets[bucket].numFree == 0) { + register size_t size; + + /* + * If no blocks could be moved from shared, first look for a larger + * block in this cache OR the shared cache to split up. + */ + + n = NBUCKETS; + size = 0; /* lint */ + while (--n > bucket) { + if (cachePtr->buckets[n].numFree > 0) { + size = bucketInfo[n].blockSize; + blockPtr = cachePtr->buckets[n].firstPtr; + cachePtr->buckets[n].firstPtr = blockPtr->nextBlock; + cachePtr->buckets[n].numFree--; + break; + } + } + if (blockPtr == NULL) { + n = NBUCKETS; + size = 0; /* lint */ + while (--n > bucket) { + if (sharedPtr->buckets[n].numFree > 0) { + size = bucketInfo[n].blockSize; + LockBucket(n); + if (sharedPtr->buckets[n].numFree > 0) { + blockPtr = sharedPtr->buckets[n].firstPtr; + sharedPtr->buckets[n].firstPtr = blockPtr->nextBlock; + sharedPtr->buckets[n].numFree--; + UnlockBucket(n); + break; + } + UnlockBucket(n); + } + } + } + /* + * Otherwise, allocate a big new block directly. + */ + + if (blockPtr == NULL) { + size = MAXALLOC; + blockPtr = malloc(size); + if (blockPtr == NULL) { + return 0; + } + } + + /* + * Split the larger block into smaller blocks for this bucket. + */ + + n = size / bucketInfo[bucket].blockSize; + cachePtr->buckets[bucket].numFree = n; + cachePtr->buckets[bucket].firstPtr = blockPtr; + while (--n > 0) { + blockPtr->nextBlock = (Block *) + ((char *) blockPtr + bucketInfo[bucket].blockSize); + blockPtr = blockPtr->nextBlock; + } + blockPtr->nextBlock = NULL; + } + return 1; +} + + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c deleted file mode 100644 index d805bd1..0000000 --- a/generic/tclAssembly.c +++ /dev/null @@ -1,4332 +0,0 @@ -/* - * tclAssembly.c -- - * - * Assembler for Tcl bytecodes. - * - * This file contains the procedures that convert Tcl Assembly Language (TAL) - * to a sequence of bytecode instructions for the Tcl execution engine. - * - * Copyright (c) 2010 by Ozgur Dogan Ugurlu. - * Copyright (c) 2010 by Kevin B. Kenny. - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -/*- - *- THINGS TO DO: - *- More instructions: - *- done - alternate exit point (affects stack and exception range checking) - *- break and continue - if exception ranges can be sorted out. - *- foreach_start4, foreach_step4 - *- returnImm, returnStk - *- expandStart, expandStkTop, invokeExpanded - *- dictFirst, dictNext, dictDone - *- dictUpdateStart, dictUpdateEnd - *- jumpTable testing - *- syntax (?) - *- returnCodeBranch - */ - -#include "tclInt.h" -#include "tclCompile.h" -#include "tclOOInt.h" - -/* - * Structure that represents a range of instructions in the bytecode. - */ - -typedef struct CodeRange { - int startOffset; /* Start offset in the bytecode array */ - int endOffset; /* End offset in the bytecode array */ -} CodeRange; - -/* - * State identified for a basic block's catch context. - */ - -typedef enum BasicBlockCatchState { - BBCS_UNKNOWN = 0, /* Catch context has not yet been identified */ - BBCS_NONE, /* Block is outside of any catch */ - BBCS_INCATCH, /* Block is within a catch context */ - BBCS_CAUGHT, /* Block is within a catch context and - * may be executed after an exception fires */ -} BasicBlockCatchState; - -/* - * Structure that defines a basic block - a linear sequence of bytecode - * instructions with no jumps in or out (including not changing the - * state of any exception range). - */ - -typedef struct BasicBlock { - int originalStartOffset; /* Instruction offset before JUMP1s were - * substituted with JUMP4's */ - int startOffset; /* Instruction offset of the start of the - * block */ - int startLine; /* Line number in the input script of the - * instruction at the start of the block */ - int jumpOffset; /* Bytecode offset of the 'jump' instruction - * that ends the block, or -1 if there is no - * jump. */ - int jumpLine; /* Line number in the input script of the - * 'jump' instruction that ends the block, or - * -1 if there is no jump */ - struct BasicBlock* prevPtr; /* Immediate predecessor of this block */ - struct BasicBlock* predecessor; - /* Predecessor of this block in the spanning - * tree */ - struct BasicBlock* successor1; - /* BasicBlock structure of the following - * block: NULL at the end of the bytecode - * sequence. */ - Tcl_Obj* jumpTarget; /* Jump target label if the jump target is - * unresolved */ - int initialStackDepth; /* Absolute stack depth on entry */ - int minStackDepth; /* Low-water relative stack depth */ - int maxStackDepth; /* High-water relative stack depth */ - int finalStackDepth; /* Relative stack depth on exit */ - enum BasicBlockCatchState catchState; - /* State of the block for 'catch' analysis */ - int catchDepth; /* Number of nested catches in which the basic - * block appears */ - struct BasicBlock* enclosingCatch; - /* BasicBlock structure of the last startCatch - * executed on a path to this block, or NULL - * if there is no enclosing catch */ - int foreignExceptionBase; /* Base index of foreign exceptions */ - int foreignExceptionCount; /* Count of foreign exceptions */ - ExceptionRange* foreignExceptions; - /* ExceptionRange structures for exception - * ranges belonging to embedded scripts and - * expressions in this block */ - JumptableInfo* jtPtr; /* Jump table at the end of this basic block */ - int flags; /* Boolean flags */ -} BasicBlock; - -/* - * Flags that pertain to a basic block. - */ - -enum BasicBlockFlags { - BB_VISITED = (1 << 0), /* Block has been visited in the current - * traversal */ - BB_FALLTHRU = (1 << 1), /* Control may pass from this block to a - * successor */ - BB_JUMP1 = (1 << 2), /* Basic block ends with a 1-byte-offset jump - * and may need expansion */ - BB_JUMPTABLE = (1 << 3), /* Basic block ends with a jump table */ - BB_BEGINCATCH = (1 << 4), /* Block ends with a 'beginCatch' instruction, - * marking it as the start of a 'catch' - * sequence. The 'jumpTarget' is the exception - * exit from the catch block. */ - BB_ENDCATCH = (1 << 5), /* Block ends with an 'endCatch' instruction, - * unwinding the catch from the exception - * stack. */ -}; - -/* - * Source instruction type recognized by the assembler. - */ - -typedef enum TalInstType { - ASSEM_1BYTE, /* Fixed arity, 1-byte instruction */ - ASSEM_BEGIN_CATCH, /* Begin catch: one 4-byte jump offset to be - * converted to appropriate exception - * ranges */ - ASSEM_BOOL, /* One Boolean operand */ - ASSEM_BOOL_LVT4, /* One Boolean, one 4-byte LVT ref. */ - ASSEM_CONCAT1, /* 1-byte unsigned-integer operand count, must - * be strictly positive, consumes N, produces - * 1 */ - ASSEM_DICT_GET, /* 'dict get' and related - consumes N+1 - * operands, produces 1, N > 0 */ - ASSEM_DICT_SET, /* specifies key count and LVT index, consumes - * N+1 operands, produces 1, N > 0 */ - ASSEM_DICT_UNSET, /* specifies key count and LVT index, consumes - * N operands, produces 1, N > 0 */ - ASSEM_END_CATCH, /* End catch. No args. Exception range popped - * from stack and stack pointer restored. */ - ASSEM_EVAL, /* 'eval' - evaluate a constant script (by - * compiling it in line with the assembly - * code! I love Tcl!) */ - ASSEM_INDEX, /* 4 byte operand, integer or end-integer */ - ASSEM_INVOKE, /* 1- or 4-byte operand count, must be - * strictly positive, consumes N, produces - * 1. */ - ASSEM_JUMP, /* Jump instructions */ - ASSEM_JUMP4, /* Jump instructions forcing a 4-byte offset */ - ASSEM_JUMPTABLE, /* Jumptable (switch -exact) */ - ASSEM_LABEL, /* The assembly directive that defines a - * label */ - ASSEM_LINDEX_MULTI, /* 4-byte operand count, must be strictly - * positive, consumes N, produces 1 */ - ASSEM_LIST, /* 4-byte operand count, must be nonnegative, - * consumses N, produces 1 */ - ASSEM_LSET_FLAT, /* 4-byte operand count, must be >= 3, - * consumes N, produces 1 */ - ASSEM_LVT, /* One operand that references a local - * variable */ - ASSEM_LVT1, /* One 1-byte operand that references a local - * variable */ - ASSEM_LVT1_SINT1, /* One 1-byte operand that references a local - * variable, one signed-integer 1-byte - * operand */ - ASSEM_LVT4, /* One 4-byte operand that references a local - * variable */ - ASSEM_OVER, /* OVER: 4-byte operand count, consumes N+1, - * produces N+2 */ - ASSEM_PUSH, /* one literal operand */ - ASSEM_REGEXP, /* One Boolean operand, but weird mapping to - * call flags */ - ASSEM_REVERSE, /* REVERSE: 4-byte operand count, consumes N, - * produces N */ - ASSEM_SINT1, /* One 1-byte signed-integer operand - * (INCR_STK_IMM) */ - ASSEM_SINT4_LVT4, /* Signed 4-byte integer operand followed by - * LVT entry. Fixed arity */ -} TalInstType; - -/* - * Description of an instruction recognized by the assembler. - */ - -typedef struct TalInstDesc { - const char *name; /* Name of instruction. */ - TalInstType instType; /* The type of instruction */ - int tclInstCode; /* Instruction code. For instructions having - * 1- and 4-byte variables, tclInstCode is - * ((1byte)<<8) || (4byte) */ - int operandsConsumed; /* Number of operands consumed by the - * operation, or INT_MIN if the operation is - * variadic */ - int operandsProduced; /* Number of operands produced by the - * operation. If negative, the operation has a - * net stack effect of -1-operandsProduced */ -} TalInstDesc; - -/* - * Structure that holds the state of the assembler while generating code. - */ - -typedef struct AssemblyEnv { - CompileEnv* envPtr; /* Compilation environment being used for code - * generation */ - Tcl_Parse* parsePtr; /* Parse of the current line of source */ - Tcl_HashTable labelHash; /* Hash table whose keys are labels and whose - * values are 'label' objects storing the code - * offsets of the labels. */ - int cmdLine; /* Current line number within the assembly - * code */ - int* clNext; /* Invisible continuation line for - * [info frame] */ - BasicBlock* head_bb; /* First basic block in the code */ - BasicBlock* curr_bb; /* Current basic block */ - int maxDepth; /* Maximum stack depth encountered */ - int curCatchDepth; /* Current depth of catches */ - int maxCatchDepth; /* Maximum depth of catches encountered */ - int flags; /* Compilation flags (TCL_EVAL_DIRECT) */ -} AssemblyEnv; - -/* - * Static functions defined in this file. - */ - -static void AddBasicBlockRangeToErrorInfo(AssemblyEnv*, - BasicBlock*); -static void AdvanceLines(int *line, const char *start, - const char *end); -static BasicBlock * AllocBB(AssemblyEnv*); -static int AssembleOneLine(AssemblyEnv* envPtr); -static void BBAdjustStackDepth(BasicBlock* bbPtr, int consumed, - int produced); -static void BBUpdateStackReqs(BasicBlock* bbPtr, int tblIdx, - int count); -static void BBEmitInstInt1(AssemblyEnv* assemEnvPtr, int tblIdx, - int opnd, int count); -static void BBEmitInstInt4(AssemblyEnv* assemEnvPtr, int tblIdx, - int opnd, int count); -static void BBEmitInst1or4(AssemblyEnv* assemEnvPtr, int tblIdx, - int param, int count); -static void BBEmitOpcode(AssemblyEnv* assemEnvPtr, int tblIdx, - int count); -static int BuildExceptionRanges(AssemblyEnv* assemEnvPtr); -static int CalculateJumpRelocations(AssemblyEnv*, int*); -static int CheckForUnclosedCatches(AssemblyEnv*); -static int CheckForThrowInWrongContext(AssemblyEnv*); -static int CheckNonThrowingBlock(AssemblyEnv*, BasicBlock*); -static int BytecodeMightThrow(unsigned char); -static int CheckJumpTableLabels(AssemblyEnv*, BasicBlock*); -static int CheckNamespaceQualifiers(Tcl_Interp*, const char*, - int); -static int CheckNonNegative(Tcl_Interp*, int); -static int CheckOneByte(Tcl_Interp*, int); -static int CheckSignedOneByte(Tcl_Interp*, int); -static int CheckStack(AssemblyEnv*); -static int CheckStrictlyPositive(Tcl_Interp*, int); -static ByteCode * CompileAssembleObj(Tcl_Interp *interp, - Tcl_Obj *objPtr); -static void CompileEmbeddedScript(AssemblyEnv*, Tcl_Token*, - const TalInstDesc*); -static int DefineLabel(AssemblyEnv* envPtr, const char* label); -static void DeleteMirrorJumpTable(JumptableInfo* jtPtr); -static void DupAssembleCodeInternalRep(Tcl_Obj* src, - Tcl_Obj* dest); -static void FillInJumpOffsets(AssemblyEnv*); -static int CreateMirrorJumpTable(AssemblyEnv* assemEnvPtr, - Tcl_Obj* jumpTable); -static int FindLocalVar(AssemblyEnv* envPtr, - Tcl_Token** tokenPtrPtr); -static int FinishAssembly(AssemblyEnv*); -static void FreeAssembleCodeInternalRep(Tcl_Obj *objPtr); -static void FreeAssemblyEnv(AssemblyEnv*); -static int GetBooleanOperand(AssemblyEnv*, Tcl_Token**, int*); -static int GetListIndexOperand(AssemblyEnv*, Tcl_Token**, int*); -static int GetIntegerOperand(AssemblyEnv*, Tcl_Token**, int*); -static int GetNextOperand(AssemblyEnv*, Tcl_Token**, Tcl_Obj**); -static void LookForFreshCatches(BasicBlock*, BasicBlock**); -static void MoveCodeForJumps(AssemblyEnv*, int); -static void MoveExceptionRangesToBasicBlock(AssemblyEnv*, int, - int); -static AssemblyEnv* NewAssemblyEnv(CompileEnv*, int); -static int ProcessCatches(AssemblyEnv*); -static int ProcessCatchesInBasicBlock(AssemblyEnv*, BasicBlock*, - BasicBlock*, enum BasicBlockCatchState, int); -static void ResetVisitedBasicBlocks(AssemblyEnv*); -static void ResolveJumpTableTargets(AssemblyEnv*, BasicBlock*); -static void ReportUndefinedLabel(AssemblyEnv*, BasicBlock*, - Tcl_Obj*); -static void RestoreEmbeddedExceptionRanges(AssemblyEnv*); -static int StackCheckBasicBlock(AssemblyEnv*, BasicBlock *, - BasicBlock *, int); -static BasicBlock* StartBasicBlock(AssemblyEnv*, int fallthrough, - Tcl_Obj* jumpLabel); -/* static int AdvanceIp(const unsigned char *pc); */ -static int StackCheckBasicBlock(AssemblyEnv*, BasicBlock *, - BasicBlock *, int); -static int StackCheckExit(AssemblyEnv*); -static void StackFreshCatches(AssemblyEnv*, BasicBlock*, int, - BasicBlock**, int*); -static void SyncStackDepth(AssemblyEnv*); -static int TclAssembleCode(CompileEnv* envPtr, const char* code, - int codeLen, int flags); -static void UnstackExpiredCatches(CompileEnv*, BasicBlock*, int, - BasicBlock**, int*); - -/* - * Tcl_ObjType that describes bytecode emitted by the assembler. - */ - -static const Tcl_ObjType assembleCodeType = { - "assemblecode", - FreeAssembleCodeInternalRep, /* freeIntRepProc */ - DupAssembleCodeInternalRep, /* dupIntRepProc */ - NULL, /* updateStringProc */ - NULL /* setFromAnyProc */ -}; - - -/* - * Flags bits used by PushVarName. - */ - -#define TCL_NO_LARGE_INDEX 1 /* Do not return localIndex value > 255 */ - -/* - * Source instructions recognized in the Tcl Assembly Language (TAL) - */ - -static const TalInstDesc TalInstructionTable[] = { - /* PUSH must be first, see the code near the end of TclAssembleCode */ - {"push", ASSEM_PUSH, (INST_PUSH1<<8 - | INST_PUSH4), 0, 1}, - - {"add", ASSEM_1BYTE, INST_ADD, 2, 1}, - {"append", ASSEM_LVT, (INST_APPEND_SCALAR1<<8 - | INST_APPEND_SCALAR4),1, 1}, - {"appendArray", ASSEM_LVT, (INST_APPEND_ARRAY1<<8 - | INST_APPEND_ARRAY4), 2, 1}, - {"appendArrayStk", ASSEM_1BYTE, INST_APPEND_ARRAY_STK, 3, 1}, - {"appendStk", ASSEM_1BYTE, INST_APPEND_STK, 2, 1}, - {"arrayExistsImm", ASSEM_LVT4, INST_ARRAY_EXISTS_IMM, 0, 1}, - {"arrayExistsStk", ASSEM_1BYTE, INST_ARRAY_EXISTS_STK, 1, 1}, - {"arrayMakeImm", ASSEM_LVT4, INST_ARRAY_MAKE_IMM, 0, 0}, - {"arrayMakeStk", ASSEM_1BYTE, INST_ARRAY_MAKE_STK, 1, 0}, - {"beginCatch", ASSEM_BEGIN_CATCH, - INST_BEGIN_CATCH4, 0, 0}, - {"bitand", ASSEM_1BYTE, INST_BITAND, 2, 1}, - {"bitnot", ASSEM_1BYTE, INST_BITNOT, 1, 1}, - {"bitor", ASSEM_1BYTE, INST_BITOR, 2, 1}, - {"bitxor", ASSEM_1BYTE, INST_BITXOR, 2, 1}, - {"concat", ASSEM_CONCAT1, INST_CONCAT1, INT_MIN,1}, - {"coroName", ASSEM_1BYTE, INST_COROUTINE_NAME, 0, 1}, - {"currentNamespace",ASSEM_1BYTE, INST_NS_CURRENT, 0, 1}, - {"dictAppend", ASSEM_LVT4, INST_DICT_APPEND, 2, 1}, - {"dictExists", ASSEM_DICT_GET, INST_DICT_EXISTS, INT_MIN,1}, - {"dictExpand", ASSEM_1BYTE, INST_DICT_EXPAND, 3, 1}, - {"dictGet", ASSEM_DICT_GET, INST_DICT_GET, INT_MIN,1}, - {"dictIncrImm", ASSEM_SINT4_LVT4, - INST_DICT_INCR_IMM, 1, 1}, - {"dictLappend", ASSEM_LVT4, INST_DICT_LAPPEND, 2, 1}, - {"dictRecombineStk",ASSEM_1BYTE, INST_DICT_RECOMBINE_STK,3, 0}, - {"dictRecombineImm",ASSEM_LVT4, INST_DICT_RECOMBINE_IMM,2, 0}, - {"dictSet", ASSEM_DICT_SET, INST_DICT_SET, INT_MIN,1}, - {"dictUnset", ASSEM_DICT_UNSET, - INST_DICT_UNSET, INT_MIN,1}, - {"div", ASSEM_1BYTE, INST_DIV, 2, 1}, - {"dup", ASSEM_1BYTE, INST_DUP, 1, 2}, - {"endCatch", ASSEM_END_CATCH,INST_END_CATCH, 0, 0}, - {"eq", ASSEM_1BYTE, INST_EQ, 2, 1}, - {"eval", ASSEM_EVAL, INST_EVAL_STK, 1, 1}, - {"evalStk", ASSEM_1BYTE, INST_EVAL_STK, 1, 1}, - {"exist", ASSEM_LVT4, INST_EXIST_SCALAR, 0, 1}, - {"existArray", ASSEM_LVT4, INST_EXIST_ARRAY, 1, 1}, - {"existArrayStk", ASSEM_1BYTE, INST_EXIST_ARRAY_STK, 2, 1}, - {"existStk", ASSEM_1BYTE, INST_EXIST_STK, 1, 1}, - {"expon", ASSEM_1BYTE, INST_EXPON, 2, 1}, - {"expr", ASSEM_EVAL, INST_EXPR_STK, 1, 1}, - {"exprStk", ASSEM_1BYTE, INST_EXPR_STK, 1, 1}, - {"ge", ASSEM_1BYTE, INST_GE, 2, 1}, - {"gt", ASSEM_1BYTE, INST_GT, 2, 1}, - {"incr", ASSEM_LVT1, INST_INCR_SCALAR1, 1, 1}, - {"incrArray", ASSEM_LVT1, INST_INCR_ARRAY1, 2, 1}, - {"incrArrayImm", ASSEM_LVT1_SINT1, - INST_INCR_ARRAY1_IMM, 1, 1}, - {"incrArrayStk", ASSEM_1BYTE, INST_INCR_ARRAY_STK, 3, 1}, - {"incrArrayStkImm", ASSEM_SINT1, INST_INCR_ARRAY_STK_IMM,2, 1}, - {"incrImm", ASSEM_LVT1_SINT1, - INST_INCR_SCALAR1_IMM, 0, 1}, - {"incrStk", ASSEM_1BYTE, INST_INCR_SCALAR_STK, 2, 1}, - {"incrStkImm", ASSEM_SINT1, INST_INCR_SCALAR_STK_IMM, - 1, 1}, - {"infoLevelArgs", ASSEM_1BYTE, INST_INFO_LEVEL_ARGS, 1, 1}, - {"infoLevelNumber", ASSEM_1BYTE, INST_INFO_LEVEL_NUM, 0, 1}, - {"invokeStk", ASSEM_INVOKE, (INST_INVOKE_STK1 << 8 - | INST_INVOKE_STK4), INT_MIN,1}, - {"jump", ASSEM_JUMP, INST_JUMP1, 0, 0}, - {"jump4", ASSEM_JUMP4, INST_JUMP4, 0, 0}, - {"jumpFalse", ASSEM_JUMP, INST_JUMP_FALSE1, 1, 0}, - {"jumpFalse4", ASSEM_JUMP4, INST_JUMP_FALSE4, 1, 0}, - {"jumpTable", ASSEM_JUMPTABLE,INST_JUMP_TABLE, 1, 0}, - {"jumpTrue", ASSEM_JUMP, INST_JUMP_TRUE1, 1, 0}, - {"jumpTrue4", ASSEM_JUMP4, INST_JUMP_TRUE4, 1, 0}, - {"label", ASSEM_LABEL, 0, 0, 0}, - {"land", ASSEM_1BYTE, INST_LAND, 2, 1}, - {"lappend", ASSEM_LVT, (INST_LAPPEND_SCALAR1<<8 - | INST_LAPPEND_SCALAR4), - 1, 1}, - {"lappendArray", ASSEM_LVT, (INST_LAPPEND_ARRAY1<<8 - | INST_LAPPEND_ARRAY4),2, 1}, - {"lappendArrayStk", ASSEM_1BYTE, INST_LAPPEND_ARRAY_STK, 3, 1}, - {"lappendStk", ASSEM_1BYTE, INST_LAPPEND_STK, 2, 1}, - {"le", ASSEM_1BYTE, INST_LE, 2, 1}, - {"lindexMulti", ASSEM_LINDEX_MULTI, - INST_LIST_INDEX_MULTI, INT_MIN,1}, - {"list", ASSEM_LIST, INST_LIST, INT_MIN,1}, - {"listIn", ASSEM_1BYTE, INST_LIST_IN, 2, 1}, - {"listIndex", ASSEM_1BYTE, INST_LIST_INDEX, 2, 1}, - {"listIndexImm", ASSEM_INDEX, INST_LIST_INDEX_IMM, 1, 1}, - {"listLength", ASSEM_1BYTE, INST_LIST_LENGTH, 1, 1}, - {"listNotIn", ASSEM_1BYTE, INST_LIST_NOT_IN, 2, 1}, - {"load", ASSEM_LVT, (INST_LOAD_SCALAR1 << 8 - | INST_LOAD_SCALAR4), 0, 1}, - {"loadArray", ASSEM_LVT, (INST_LOAD_ARRAY1<<8 - | INST_LOAD_ARRAY4), 1, 1}, - {"loadArrayStk", ASSEM_1BYTE, INST_LOAD_ARRAY_STK, 2, 1}, - {"loadStk", ASSEM_1BYTE, INST_LOAD_SCALAR_STK, 1, 1}, - {"lor", ASSEM_1BYTE, INST_LOR, 2, 1}, - {"lsetFlat", ASSEM_LSET_FLAT,INST_LSET_FLAT, INT_MIN,1}, - {"lsetList", ASSEM_1BYTE, INST_LSET_LIST, 3, 1}, - {"lshift", ASSEM_1BYTE, INST_LSHIFT, 2, 1}, - {"lt", ASSEM_1BYTE, INST_LT, 2, 1}, - {"mod", ASSEM_1BYTE, INST_MOD, 2, 1}, - {"mult", ASSEM_1BYTE, INST_MULT, 2, 1}, - {"neq", ASSEM_1BYTE, INST_NEQ, 2, 1}, - {"nop", ASSEM_1BYTE, INST_NOP, 0, 0}, - {"not", ASSEM_1BYTE, INST_LNOT, 1, 1}, - {"nsupvar", ASSEM_LVT4, INST_NSUPVAR, 2, 1}, - {"over", ASSEM_OVER, INST_OVER, INT_MIN,-1-1}, - {"pop", ASSEM_1BYTE, INST_POP, 1, 0}, - {"pushReturnCode", ASSEM_1BYTE, INST_PUSH_RETURN_CODE, 0, 1}, - {"pushReturnOpts", ASSEM_1BYTE, INST_PUSH_RETURN_OPTIONS, - 0, 1}, - {"pushResult", ASSEM_1BYTE, INST_PUSH_RESULT, 0, 1}, - {"regexp", ASSEM_REGEXP, INST_REGEXP, 2, 1}, - {"resolveCmd", ASSEM_1BYTE, INST_RESOLVE_COMMAND, 1, 1}, - {"reverse", ASSEM_REVERSE, INST_REVERSE, INT_MIN,-1-0}, - {"rshift", ASSEM_1BYTE, INST_RSHIFT, 2, 1}, - {"store", ASSEM_LVT, (INST_STORE_SCALAR1<<8 - | INST_STORE_SCALAR4), 1, 1}, - {"storeArray", ASSEM_LVT, (INST_STORE_ARRAY1<<8 - | INST_STORE_ARRAY4), 2, 1}, - {"storeArrayStk", ASSEM_1BYTE, INST_STORE_ARRAY_STK, 3, 1}, - {"storeStk", ASSEM_1BYTE, INST_STORE_SCALAR_STK, 2, 1}, - {"strcmp", ASSEM_1BYTE, INST_STR_CMP, 2, 1}, - {"streq", ASSEM_1BYTE, INST_STR_EQ, 2, 1}, - {"strfind", ASSEM_1BYTE, INST_STR_FIND, 2, 1}, - {"strindex", ASSEM_1BYTE, INST_STR_INDEX, 2, 1}, - {"strlen", ASSEM_1BYTE, INST_STR_LEN, 1, 1}, - {"strmap", ASSEM_1BYTE, INST_STR_MAP, 3, 1}, - {"strmatch", ASSEM_BOOL, INST_STR_MATCH, 2, 1}, - {"strneq", ASSEM_1BYTE, INST_STR_NEQ, 2, 1}, - {"strrange", ASSEM_1BYTE, INST_STR_RANGE, 3, 1}, - {"strrfind", ASSEM_1BYTE, INST_STR_FIND_LAST, 2, 1}, - {"sub", ASSEM_1BYTE, INST_SUB, 2, 1}, - {"tclooClass", ASSEM_1BYTE, INST_TCLOO_CLASS, 1, 1}, - {"tclooIsObject", ASSEM_1BYTE, INST_TCLOO_IS_OBJECT, 1, 1}, - {"tclooNamespace", ASSEM_1BYTE, INST_TCLOO_NS, 1, 1}, - {"tclooSelf", ASSEM_1BYTE, INST_TCLOO_SELF, 0, 1}, - {"tryCvtToNumeric", ASSEM_1BYTE, INST_TRY_CVT_TO_NUMERIC,1, 1}, - {"uminus", ASSEM_1BYTE, INST_UMINUS, 1, 1}, - {"unset", ASSEM_BOOL_LVT4,INST_UNSET_SCALAR, 0, 0}, - {"unsetArray", ASSEM_BOOL_LVT4,INST_UNSET_ARRAY, 1, 0}, - {"unsetArrayStk", ASSEM_BOOL, INST_UNSET_ARRAY_STK, 2, 0}, - {"unsetStk", ASSEM_BOOL, INST_UNSET_STK, 1, 0}, - {"uplus", ASSEM_1BYTE, INST_UPLUS, 1, 1}, - {"upvar", ASSEM_LVT4, INST_UPVAR, 2, 1}, - {"variable", ASSEM_LVT4, INST_VARIABLE, 1, 0}, - {"verifyDict", ASSEM_1BYTE, INST_DICT_VERIFY, 1, 0}, - {"yield", ASSEM_1BYTE, INST_YIELD, 1, 1}, - {NULL, 0, 0, 0, 0} -}; - -/* - * List of instructions that cannot throw an exception under any - * circumstances. These instructions are the ones that are permissible after - * an exception is caught but before the corresponding exception range is - * popped from the stack. - * The instructions must be in ascending order by numeric operation code. - */ - -static const unsigned char NonThrowingByteCodes[] = { - INST_PUSH1, INST_PUSH4, INST_POP, INST_DUP, /* 1-4 */ - INST_JUMP1, INST_JUMP4, /* 34-35 */ - INST_END_CATCH, INST_PUSH_RESULT, INST_PUSH_RETURN_CODE, /* 70-72 */ - INST_OVER, /* 95 */ - INST_PUSH_RETURN_OPTIONS, /* 108 */ - INST_REVERSE, /* 126 */ - INST_NOP, /* 132 */ - INST_STR_MAP, /* 143 */ - INST_STR_FIND, /* 144 */ - INST_COROUTINE_NAME, /* 149 */ - INST_NS_CURRENT, /* 151 */ - INST_INFO_LEVEL_NUM, /* 152 */ - INST_RESOLVE_COMMAND /* 154 */ -}; - -static void -AdvanceLines( - int *line, - const char *start, - const char *end) -{ - register const char *p; - - for (p = start; p < end; p++) { - if (*p == '\n') { - (*line)++; - } - } -} - -/* - * Helper macros. - */ - -#if defined(TCL_DEBUG_ASSEMBLY) && defined(__GNUC__) && __GNUC__ > 2 -#define DEBUG_PRINT(...) fprintf(stderr, ##__VA_ARGS__);fflush(stderr) -#elif defined(__GNUC__) && __GNUC__ > 2 -#define DEBUG_PRINT(...) /* nothing */ -#else -#define DEBUG_PRINT /* nothing */ -#endif - -/* - *----------------------------------------------------------------------------- - * - * BBAdjustStackDepth -- - * - * When an opcode is emitted, adjusts the stack information in the basic - * block to reflect the number of operands produced and consumed. - * - * Results: - * None. - * - * Side effects: - * Updates minimum, maximum and final stack requirements in the basic - * block. - * - *----------------------------------------------------------------------------- - */ - -static void -BBAdjustStackDepth( - BasicBlock *bbPtr, /* Structure describing the basic block */ - int consumed, /* Count of operands consumed by the - * operation */ - int produced) /* Count of operands produced by the - * operation */ -{ - int depth = bbPtr->finalStackDepth; - - depth -= consumed; - if (depth < bbPtr->minStackDepth) { - bbPtr->minStackDepth = depth; - } - depth += produced; - if (depth > bbPtr->maxStackDepth) { - bbPtr->maxStackDepth = depth; - } - bbPtr->finalStackDepth = depth; -} - -/* - *----------------------------------------------------------------------------- - * - * BBUpdateStackReqs -- - * - * Updates the stack requirements of a basic block, given the opcode - * being emitted and an operand count. - * - * Results: - * None. - * - * Side effects: - * Updates min, max and final stack requirements in the basic block. - * - * Notes: - * This function must not be called for instructions such as REVERSE and - * OVER that are variadic but do not consume all their operands. Instead, - * BBAdjustStackDepth should be called directly. - * - * count should be provided only for variadic operations. For operations - * with known arity, count should be 0. - * - *----------------------------------------------------------------------------- - */ - -static void -BBUpdateStackReqs( - BasicBlock* bbPtr, /* Structure describing the basic block */ - int tblIdx, /* Index in TalInstructionTable of the - * operation being assembled */ - int count) /* Count of operands for variadic insts */ -{ - int consumed = TalInstructionTable[tblIdx].operandsConsumed; - int produced = TalInstructionTable[tblIdx].operandsProduced; - - if (consumed == INT_MIN) { - /* - * The instruction is variadic; it consumes 'count' operands. - */ - - consumed = count; - } - if (produced < 0) { - /* - * The instruction leaves some of its variadic operands on the stack, - * with net stack effect of '-1-produced' - */ - - produced = consumed - produced - 1; - } - BBAdjustStackDepth(bbPtr, consumed, produced); -} - -/* - *----------------------------------------------------------------------------- - * - * BBEmitOpcode, BBEmitInstInt1, BBEmitInstInt4 -- - * - * Emit the opcode part of an instruction, or the entirety of an - * instruction with a 1- or 4-byte operand, and adjust stack - * requirements. - * - * Results: - * None. - * - * Side effects: - * Stores instruction and operand in the operand stream, and adjusts the - * stack. - * - *----------------------------------------------------------------------------- - */ - -static void -BBEmitOpcode( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - int tblIdx, /* Table index in TalInstructionTable of op */ - int count) /* Operand count for variadic ops */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - BasicBlock* bbPtr = assemEnvPtr->curr_bb; - /* Current basic block */ - int op = TalInstructionTable[tblIdx].tclInstCode & 0xff; - - /* - * If this is the first instruction in a basic block, record its line - * number. - */ - - if (bbPtr->startOffset == envPtr->codeNext - envPtr->codeStart) { - bbPtr->startLine = assemEnvPtr->cmdLine; - } - - TclEmitInt1(op, envPtr); - envPtr->atCmdStart = ((op) == INST_START_CMD); - BBUpdateStackReqs(bbPtr, tblIdx, count); -} - -static void -BBEmitInstInt1( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - int tblIdx, /* Index in TalInstructionTable of op */ - int opnd, /* 1-byte operand */ - int count) /* Operand count for variadic ops */ -{ - BBEmitOpcode(assemEnvPtr, tblIdx, count); - TclEmitInt1(opnd, assemEnvPtr->envPtr); -} - -static void -BBEmitInstInt4( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - int tblIdx, /* Index in TalInstructionTable of op */ - int opnd, /* 4-byte operand */ - int count) /* Operand count for variadic ops */ -{ - BBEmitOpcode(assemEnvPtr, tblIdx, count); - TclEmitInt4(opnd, assemEnvPtr->envPtr); -} - -/* - *----------------------------------------------------------------------------- - * - * BBEmitInst1or4 -- - * - * Emits a 1- or 4-byte operation according to the magnitude of the - * operand - * - *----------------------------------------------------------------------------- - */ - -static void -BBEmitInst1or4( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - int tblIdx, /* Index in TalInstructionTable of op */ - int param, /* Variable-length parameter */ - int count) /* Arity if variadic */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - BasicBlock* bbPtr = assemEnvPtr->curr_bb; - /* Current basic block */ - int op = TalInstructionTable[tblIdx].tclInstCode; - - if (param <= 0xff) { - op >>= 8; - } else { - op &= 0xff; - } - TclEmitInt1(op, envPtr); - if (param <= 0xff) { - TclEmitInt1(param, envPtr); - } else { - TclEmitInt4(param, envPtr); - } - envPtr->atCmdStart = ((op) == INST_START_CMD); - BBUpdateStackReqs(bbPtr, tblIdx, count); -} - -/* - *----------------------------------------------------------------------------- - * - * Tcl_AssembleObjCmd, TclNRAssembleObjCmd -- - * - * Direct evaluation path for tcl::unsupported::assemble - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * Assembles the code in objv[1], and executes it, so side effects - * include whatever the code does. - * - *----------------------------------------------------------------------------- - */ - -int -Tcl_AssembleObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - /* - * Boilerplate - make sure that there is an NRE trampoline on the C stack - * because there needs to be one in place to execute bytecode. - */ - - return Tcl_NRCallObjProc(interp, TclNRAssembleObjCmd, dummy, objc, objv); -} - -int -TclNRAssembleObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - ByteCode *codePtr; /* Pointer to the bytecode to execute */ - Tcl_Obj* backtrace; /* Object where extra error information is - * constructed. */ - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "bytecodeList"); - return TCL_ERROR; - } - - /* - * Assemble the source to bytecode. - */ - - codePtr = CompileAssembleObj(interp, objv[1]); - - /* - * On failure, report error line. - */ - - if (codePtr == NULL) { - Tcl_AddErrorInfo(interp, "\n (\""); - Tcl_AddErrorInfo(interp, Tcl_GetString(objv[0])); - Tcl_AddErrorInfo(interp, "\" body, line "); - backtrace = Tcl_NewIntObj(Tcl_GetErrorLine(interp)); - Tcl_IncrRefCount(backtrace); - Tcl_AddErrorInfo(interp, Tcl_GetString(backtrace)); - Tcl_DecrRefCount(backtrace); - Tcl_AddErrorInfo(interp, ")"); - return TCL_ERROR; - } - - /* - * Use NRE to evaluate the bytecode from the trampoline. - */ - - return TclNRExecuteByteCode(interp, codePtr); -} - -/* - *----------------------------------------------------------------------------- - * - * CompileAssembleObj -- - * - * Sets up and assembles Tcl bytecode for the direct-execution path in - * the Tcl bytecode assembler. - * - * Results: - * Returns a pointer to the assembled code. Returns NULL if the assembly - * fails for any reason, with an appropriate error message in the - * interpreter. - * - *----------------------------------------------------------------------------- - */ - -static ByteCode * -CompileAssembleObj( - Tcl_Interp *interp, /* Tcl interpreter */ - Tcl_Obj *objPtr) /* Source code to assemble */ -{ - Interp *iPtr = (Interp *) interp; - /* Internals of the interpreter */ - CompileEnv compEnv; /* Compilation environment structure */ - register ByteCode *codePtr = NULL; - /* Bytecode resulting from the assembly */ - register const AuxData * auxDataPtr; - /* Pointer to an auxiliary data element - * in a compilation environment being - * destroyed. */ - Namespace* namespacePtr; /* Namespace in which variable and command - * names in the bytecode resolve */ - int status; /* Status return from Tcl_AssembleCode */ - const char* source; /* String representation of the source code */ - int sourceLen; /* Length of the source code in bytes */ - int i; - - - /* - * Get the expression ByteCode from the object. If it exists, make sure it - * is valid in the current context. - */ - - if (objPtr->typePtr == &assembleCodeType) { - namespacePtr = iPtr->varFramePtr->nsPtr; - codePtr = objPtr->internalRep.otherValuePtr; - if (((Interp *) *codePtr->interpHandle == iPtr) - && (codePtr->compileEpoch == iPtr->compileEpoch) - && (codePtr->nsPtr == namespacePtr) - && (codePtr->nsEpoch == namespacePtr->resolverEpoch) - && (codePtr->localCachePtr - == iPtr->varFramePtr->localCachePtr)) { - return codePtr; - } - - /* - * Not valid, so free it and regenerate. - */ - - FreeAssembleCodeInternalRep(objPtr); - } - - /* Set up the compilation environment, and assemble the code */ - - source = TclGetStringFromObj(objPtr, &sourceLen); - TclInitCompileEnv(interp, &compEnv, source, sourceLen); - status = TclAssembleCode(&compEnv, source, sourceLen, TCL_EVAL_DIRECT); - if (status != TCL_OK) { - - /* Assembly failed. Clean up and report the error */ - - /* - * Free any literals that were constructed for the assembly. - */ - for (i = 0; i < compEnv.literalArrayNext; i++) { - TclReleaseLiteral(interp, compEnv.literalArrayPtr[i].objPtr); - } - - /* - * Free any auxiliary data that was attached to the bytecode - * under construction. - */ - - for (i = 0; i < compEnv.auxDataArrayNext; i++) { - auxDataPtr = compEnv.auxDataArrayPtr + i; - if (auxDataPtr->type->freeProc != NULL) { - (auxDataPtr->type->freeProc)(auxDataPtr->clientData); - } - } - - TclFreeCompileEnv(&compEnv); - return NULL; - } - - /* - * Add a "done" instruction as the last instruction and change the object - * into a ByteCode object. Ownership of the literal objects and aux data - * items is given to the ByteCode object. - */ - - TclEmitOpcode(INST_DONE, &compEnv); - TclInitByteCodeObj(objPtr, &compEnv); - objPtr->typePtr = &assembleCodeType; - TclFreeCompileEnv(&compEnv); - - /* - * Record the local variable context to which the bytecode pertains - */ - - codePtr = objPtr->internalRep.otherValuePtr; - if (iPtr->varFramePtr->localCachePtr) { - codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; - codePtr->localCachePtr->refCount++; - } - - /* - * Report on what the assembler did. - */ - -#ifdef TCL_COMPILE_DEBUG - if (tclTraceCompile >= 2) { - TclPrintByteCodeObj(interp, objPtr); - fflush(stdout); - } -#endif /* TCL_COMPILE_DEBUG */ - - return codePtr; -} - -/* - *----------------------------------------------------------------------------- - * - * TclCompileAssembleCmd -- - * - * Compilation procedure for the '::tcl::unsupported::assemble' command. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * Puts the result of assembling the code into the bytecode stream in - * 'compileEnv'. - * - * This procedure makes sure that the command has a single arg, which is - * constant. If that condition is met, the procedure calls TclAssembleCode to - * produce bytecode for the given assembly code, and returns any error - * resulting from the assembly. - * - *----------------------------------------------------------------------------- - */ - -int -TclCompileAssembleCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr; /* Token in the input script */ - - /* - * Make sure that the command has a single arg that is a simple word. - */ - - if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(parsePtr->tokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - - /* - * Compile the code and return any error from the compilation. - */ - - return TclAssembleCode(envPtr, tokenPtr[1].start, tokenPtr[1].size, 0); -} - -/* - *----------------------------------------------------------------------------- - * - * TclAssembleCode -- - * - * Take a list of instructions in a Tcl_Obj, and assemble them to Tcl - * bytecodes - * - * Results: - * Returns TCL_OK on success, TCL_ERROR on failure. If 'flags' includes - * TCL_EVAL_DIRECT, places an error message in the interpreter result. - * - * Side effects: - * Adds byte codes to the compile environment, and updates the - * environment's stack depth. - * - *----------------------------------------------------------------------------- - */ - -static int -TclAssembleCode( - CompileEnv *envPtr, /* Compilation environment that is to receive - * the generated bytecode */ - const char* codePtr, /* Assembly-language code to be processed */ - int codeLen, /* Length of the code */ - int flags) /* OR'ed combination of flags */ -{ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - /* - * Walk through the assembly script using the Tcl parser. Each 'command' - * will be an instruction or assembly directive. - */ - - const char* instPtr = codePtr; - /* Where to start looking for a line of code */ - int instLen; /* Length in bytes of the current line of - * code */ - const char* nextPtr; /* Pointer to the end of the line of code */ - int bytesLeft = codeLen; /* Number of bytes of source code remaining to - * be parsed */ - int status; /* Tcl status return */ - AssemblyEnv* assemEnvPtr = NewAssemblyEnv(envPtr, flags); - Tcl_Parse* parsePtr = assemEnvPtr->parsePtr; - - do { - /* - * Parse out one command line from the assembly script. - */ - - status = Tcl_ParseCommand(interp, instPtr, bytesLeft, 0, parsePtr); - instLen = parsePtr->commandSize; - if (parsePtr->term == parsePtr->commandStart + instLen - 1) { - --instLen; - } - - /* - * Report errors in the parse. - */ - - if (status != TCL_OK) { - if (flags & TCL_EVAL_DIRECT) { - Tcl_LogCommandInfo(interp, codePtr, parsePtr->commandStart, - instLen); - } - FreeAssemblyEnv(assemEnvPtr); - return TCL_ERROR; - } - - /* - * Advance the pointers around any leading commentary. - */ - - AdvanceLines(&assemEnvPtr->cmdLine, instPtr, - parsePtr->commandStart); - - /* - * Process the line of code. - */ - - if (parsePtr->numWords > 0) { - /* - * If tracing, show each line assembled as it happens. - */ - -#ifdef TCL_COMPILE_DEBUG - if ((tclTraceCompile >= 2) && (envPtr->procPtr == NULL)) { - printf(" %4ld Assembling: ", - (long)(envPtr->codeNext - envPtr->codeStart)); - TclPrintSource(stdout, parsePtr->commandStart, - TclMin(instLen, 55)); - printf("\n"); - } -#endif - if (AssembleOneLine(assemEnvPtr) != TCL_OK) { - if (flags & TCL_EVAL_DIRECT) { - Tcl_LogCommandInfo(interp, codePtr, - parsePtr->commandStart, instLen); - } - Tcl_FreeParse(parsePtr); - FreeAssemblyEnv(assemEnvPtr); - return TCL_ERROR; - } - } - - /* - * Advance to the next line of code. - */ - - nextPtr = parsePtr->commandStart + parsePtr->commandSize; - bytesLeft -= (nextPtr - instPtr); - instPtr = nextPtr; - AdvanceLines(&assemEnvPtr->cmdLine, parsePtr->commandStart, - instPtr); - Tcl_FreeParse(parsePtr); - } while (bytesLeft > 0); - - /* - * Done with parsing the code. - */ - - status = FinishAssembly(assemEnvPtr); - FreeAssemblyEnv(assemEnvPtr); - return status; -} - -/* - *----------------------------------------------------------------------------- - * - * NewAssemblyEnv -- - * - * Creates an environment for the assembler to run in. - * - * Results: - * Allocates, initialises and returns an assembler environment - * - *----------------------------------------------------------------------------- - */ - -static AssemblyEnv* -NewAssemblyEnv( - CompileEnv* envPtr, /* Compilation environment being used for code - * generation*/ - int flags) /* Compilation flags (TCL_EVAL_DIRECT) */ -{ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - AssemblyEnv* assemEnvPtr = TclStackAlloc(interp, sizeof(AssemblyEnv)); - /* Assembler environment under construction */ - Tcl_Parse* parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse)); - /* Parse of one line of assembly code */ - - assemEnvPtr->envPtr = envPtr; - assemEnvPtr->parsePtr = parsePtr; - assemEnvPtr->cmdLine = 1; - - /* - * Make the hashtables that store symbol resolution. - */ - - Tcl_InitHashTable(&assemEnvPtr->labelHash, TCL_STRING_KEYS); - - /* - * Start the first basic block. - */ - - assemEnvPtr->curr_bb = NULL; - assemEnvPtr->head_bb = AllocBB(assemEnvPtr); - assemEnvPtr->curr_bb = assemEnvPtr->head_bb; - assemEnvPtr->head_bb->startLine = 1; - - /* - * Stash compilation flags. - */ - - assemEnvPtr->flags = flags; - return assemEnvPtr; -} - -/* - *----------------------------------------------------------------------------- - * - * FreeAssemblyEnv -- - * - * Cleans up the assembler environment when assembly is complete. - * - *----------------------------------------------------------------------------- - */ - -static void -FreeAssemblyEnv( - AssemblyEnv* assemEnvPtr) /* Environment to free */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment being used for code - * generation */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - BasicBlock* thisBB; /* Pointer to a basic block being deleted */ - BasicBlock* nextBB; /* Pointer to a deleted basic block's - * successor */ - - /* - * Free all the basic block structures. - */ - - for (thisBB = assemEnvPtr->head_bb; thisBB != NULL; thisBB = nextBB) { - if (thisBB->jumpTarget != NULL) { - Tcl_DecrRefCount(thisBB->jumpTarget); - } - if (thisBB->foreignExceptions != NULL) { - ckfree(thisBB->foreignExceptions); - } - nextBB = thisBB->successor1; - if (thisBB->jtPtr != NULL) { - DeleteMirrorJumpTable(thisBB->jtPtr); - thisBB->jtPtr = NULL; - } - ckfree(thisBB); - } - - /* - * Dispose what's left. - */ - - Tcl_DeleteHashTable(&assemEnvPtr->labelHash); - TclStackFree(interp, assemEnvPtr->parsePtr); - TclStackFree(interp, assemEnvPtr); -} - -/* - *----------------------------------------------------------------------------- - * - * AssembleOneLine -- - * - * Assembles a single command from an assembly language source. - * - * Results: - * Returns TCL_ERROR with an appropriate error message if the assembly - * fails. Returns TCL_OK if the assembly succeeds. Updates the assembly - * environment with the state of the assembly. - * - *----------------------------------------------------------------------------- - */ - -static int -AssembleOneLine( - AssemblyEnv* assemEnvPtr) /* State of the assembly */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment being used for code - * gen */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - Tcl_Parse* parsePtr = assemEnvPtr->parsePtr; - /* Parse of the line of code */ - Tcl_Token* tokenPtr; /* Current token within the line of code */ - Tcl_Obj* instNameObj; /* Name of the instruction */ - int tblIdx; /* Index in TalInstructionTable of the - * instruction */ - enum TalInstType instType; /* Type of the instruction */ - Tcl_Obj* operand1Obj = NULL; - /* First operand to the instruction */ - const char* operand1; /* String rep of the operand */ - int operand1Len; /* String length of the operand */ - int opnd; /* Integer representation of an operand */ - int litIndex; /* Literal pool index of a constant */ - int localVar; /* LVT index of a local variable */ - int flags; /* Flags for a basic block */ - JumptableInfo* jtPtr; /* Pointer to a jumptable */ - int infoIndex; /* Index of the jumptable in auxdata */ - int status = TCL_ERROR; /* Return value from this function */ - - /* - * Make sure that the instruction name is known at compile time. - */ - - tokenPtr = parsePtr->tokenPtr; - if (GetNextOperand(assemEnvPtr, &tokenPtr, &instNameObj) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Look up the instruction name. - */ - - if (Tcl_GetIndexFromObjStruct(interp, instNameObj, - &TalInstructionTable[0].name, sizeof(TalInstDesc), "instruction", - TCL_EXACT, &tblIdx) != TCL_OK) { - goto cleanup; - } - - /* - * Vector on the type of instruction being processed. - */ - - instType = TalInstructionTable[tblIdx].instType; - switch (instType) { - - case ASSEM_PUSH: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "value"); - goto cleanup; - } - if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) { - goto cleanup; - } - operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len); - litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len); - BBEmitInst1or4(assemEnvPtr, tblIdx, litIndex, 0); - break; - - case ASSEM_1BYTE: - if (parsePtr->numWords != 1) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, ""); - goto cleanup; - } - BBEmitOpcode(assemEnvPtr, tblIdx, 0); - break; - - case ASSEM_BEGIN_CATCH: - /* - * Emit the BEGIN_CATCH instruction with the code offset of the - * exception branch target instead of the exception range index. The - * correct index will be generated and inserted later, when catches - * are being resolved. - */ - - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "label"); - goto cleanup; - } - if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) { - goto cleanup; - } - assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine; - assemEnvPtr->curr_bb->jumpOffset = envPtr->codeNext-envPtr->codeStart; - BBEmitInstInt4(assemEnvPtr, tblIdx, 0, 0); - assemEnvPtr->curr_bb->flags |= BB_BEGINCATCH; - StartBasicBlock(assemEnvPtr, BB_FALLTHRU, operand1Obj); - break; - - case ASSEM_BOOL: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean"); - goto cleanup; - } - if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) { - goto cleanup; - } - BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, 0); - break; - - case ASSEM_BOOL_LVT4: - if (parsePtr->numWords != 3) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean varName"); - goto cleanup; - } - if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) { - goto cleanup; - } - localVar = FindLocalVar(assemEnvPtr, &tokenPtr); - if (localVar < 0) { - goto cleanup; - } - BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, 0); - TclEmitInt4(localVar, envPtr); - break; - - case ASSEM_CONCAT1: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8"); - goto cleanup; - } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK - || CheckOneByte(interp, opnd) != TCL_OK - || CheckStrictlyPositive(interp, opnd) != TCL_OK) { - goto cleanup; - } - BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, opnd); - break; - - case ASSEM_DICT_GET: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); - goto cleanup; - } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK - || CheckStrictlyPositive(interp, opnd) != TCL_OK) { - goto cleanup; - } - BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd+1); - break; - - case ASSEM_DICT_SET: - if (parsePtr->numWords != 3) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName"); - goto cleanup; - } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK - || CheckStrictlyPositive(interp, opnd) != TCL_OK) { - goto cleanup; - } - localVar = FindLocalVar(assemEnvPtr, &tokenPtr); - if (localVar < 0) { - goto cleanup; - } - BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd+1); - TclEmitInt4(localVar, envPtr); - break; - - case ASSEM_DICT_UNSET: - if (parsePtr->numWords != 3) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName"); - goto cleanup; - } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK - || CheckStrictlyPositive(interp, opnd) != TCL_OK) { - goto cleanup; - } - localVar = FindLocalVar(assemEnvPtr, &tokenPtr); - if (localVar < 0) { - goto cleanup; - } - BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd); - TclEmitInt4(localVar, envPtr); - break; - - case ASSEM_END_CATCH: - if (parsePtr->numWords != 1) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, ""); - goto cleanup; - } - assemEnvPtr->curr_bb->flags |= BB_ENDCATCH; - BBEmitOpcode(assemEnvPtr, tblIdx, 0); - StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL); - break; - - case ASSEM_EVAL: - /* TODO - Refactor this stuff into a subroutine that takes the inst - * code, the message ("script" or "expression") and an evaluator - * callback that calls TclCompileScript or TclCompileExpr. */ - - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, - ((TalInstructionTable[tblIdx].tclInstCode - == INST_EVAL_STK) ? "script" : "expression")); - goto cleanup; - } - if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - CompileEmbeddedScript(assemEnvPtr, tokenPtr+1, - TalInstructionTable+tblIdx); - } else if (GetNextOperand(assemEnvPtr, &tokenPtr, - &operand1Obj) != TCL_OK) { - goto cleanup; - } else { - operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len); - litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len); - - /* - * Assumes that PUSH is the first slot! - */ - - BBEmitInst1or4(assemEnvPtr, 0, litIndex, 0); - BBEmitOpcode(assemEnvPtr, tblIdx, 0); - } - break; - - case ASSEM_INVOKE: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); - goto cleanup; - } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK - || CheckStrictlyPositive(interp, opnd) != TCL_OK) { - goto cleanup; - } - - BBEmitInst1or4(assemEnvPtr, tblIdx, opnd, opnd); - break; - - case ASSEM_JUMP: - case ASSEM_JUMP4: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "label"); - goto cleanup; - } - if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) { - goto cleanup; - } - assemEnvPtr->curr_bb->jumpOffset = envPtr->codeNext-envPtr->codeStart; - if (instType == ASSEM_JUMP) { - flags = BB_JUMP1; - BBEmitInstInt1(assemEnvPtr, tblIdx, 0, 0); - } else { - flags = 0; - BBEmitInstInt4(assemEnvPtr, tblIdx, 0, 0); - } - - /* - * Start a new basic block at the instruction following the jump. - */ - - assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine; - if (TalInstructionTable[tblIdx].operandsConsumed != 0) { - flags |= BB_FALLTHRU; - } - StartBasicBlock(assemEnvPtr, flags, operand1Obj); - break; - - case ASSEM_JUMPTABLE: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "table"); - goto cleanup; - } - if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) { - goto cleanup; - } - - jtPtr = ckalloc(sizeof(JumptableInfo)); - - Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS); - assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine; - assemEnvPtr->curr_bb->jumpOffset = envPtr->codeNext-envPtr->codeStart; - DEBUG_PRINT("bb %p jumpLine %d jumpOffset %d\n", - assemEnvPtr->curr_bb, assemEnvPtr->cmdLine, - envPtr->codeNext - envPtr->codeStart); - - infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr); - DEBUG_PRINT("auxdata index=%d\n", infoIndex); - - BBEmitInstInt4(assemEnvPtr, tblIdx, infoIndex, 0); - if (CreateMirrorJumpTable(assemEnvPtr, operand1Obj) != TCL_OK) { - goto cleanup; - } - StartBasicBlock(assemEnvPtr, BB_JUMPTABLE|BB_FALLTHRU, NULL); - break; - - case ASSEM_LABEL: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "name"); - goto cleanup; - } - if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) { - goto cleanup; - } - - /* - * Add the (label_name, address) pair to the hash table. - */ - - if (DefineLabel(assemEnvPtr, Tcl_GetString(operand1Obj)) != TCL_OK) { - goto cleanup; - } - break; - - case ASSEM_LINDEX_MULTI: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); - goto cleanup; - } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK - || CheckStrictlyPositive(interp, opnd) != TCL_OK) { - goto cleanup; - } - BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd); - break; - - case ASSEM_LIST: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); - goto cleanup; - } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK - || CheckNonNegative(interp, opnd) != TCL_OK) { - goto cleanup; - } - BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd); - break; - - case ASSEM_INDEX: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); - goto cleanup; - } - if (GetListIndexOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) { - goto cleanup; - } - BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd); - break; - - case ASSEM_LSET_FLAT: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); - goto cleanup; - } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) { - goto cleanup; - } - if (opnd < 2) { - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("operand must be >=2", -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND>=2", NULL); - } - goto cleanup; - } - BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd); - break; - - case ASSEM_LVT: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname"); - goto cleanup; - } - localVar = FindLocalVar(assemEnvPtr, &tokenPtr); - if (localVar < 0) { - goto cleanup; - } - BBEmitInst1or4(assemEnvPtr, tblIdx, localVar, 0); - break; - - case ASSEM_LVT1: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname"); - goto cleanup; - } - localVar = FindLocalVar(assemEnvPtr, &tokenPtr); - if (localVar < 0 || CheckOneByte(interp, localVar)) { - goto cleanup; - } - BBEmitInstInt1(assemEnvPtr, tblIdx, localVar, 0); - break; - - case ASSEM_LVT1_SINT1: - if (parsePtr->numWords != 3) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "varName imm8"); - goto cleanup; - } - localVar = FindLocalVar(assemEnvPtr, &tokenPtr); - if (localVar < 0 || CheckOneByte(interp, localVar) - || GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK - || CheckSignedOneByte(interp, opnd)) { - goto cleanup; - } - BBEmitInstInt1(assemEnvPtr, tblIdx, localVar, 0); - TclEmitInt1(opnd, envPtr); - break; - - case ASSEM_LVT4: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname"); - goto cleanup; - } - localVar = FindLocalVar(assemEnvPtr, &tokenPtr); - if (localVar < 0) { - goto cleanup; - } - BBEmitInstInt4(assemEnvPtr, tblIdx, localVar, 0); - break; - - case ASSEM_OVER: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); - goto cleanup; - } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK - || CheckNonNegative(interp, opnd) != TCL_OK) { - goto cleanup; - } - BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd+1); - break; - - case ASSEM_REGEXP: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean"); - goto cleanup; - } - if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) { - goto cleanup; - } - { - int flags = TCL_REG_ADVANCED | (opnd ? TCL_REG_NOCASE : 0); - - BBEmitInstInt1(assemEnvPtr, tblIdx, flags, 0); - } - break; - - case ASSEM_REVERSE: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); - goto cleanup; - } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK - || CheckNonNegative(interp, opnd) != TCL_OK) { - goto cleanup; - } - BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd); - break; - - case ASSEM_SINT1: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8"); - goto cleanup; - } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK - || CheckSignedOneByte(interp, opnd) != TCL_OK) { - goto cleanup; - } - BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, 0); - break; - - case ASSEM_SINT4_LVT4: - if (parsePtr->numWords != 3) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName"); - goto cleanup; - } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) { - goto cleanup; - } - localVar = FindLocalVar(assemEnvPtr, &tokenPtr); - if (localVar < 0) { - goto cleanup; - } - BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, 0); - TclEmitInt4(localVar, envPtr); - break; - - default: - Tcl_Panic("Instruction \"%s\" could not be found, can't happen\n", - Tcl_GetString(instNameObj)); - } - - status = TCL_OK; - cleanup: - Tcl_DecrRefCount(instNameObj); - if (operand1Obj) { - Tcl_DecrRefCount(operand1Obj); - } - return status; -} - -/* - *----------------------------------------------------------------------------- - * - * CompileEmbeddedScript -- - * - * Compile an embedded 'eval' or 'expr' that appears in assembly code. - * - * This procedure is called when the 'eval' or 'expr' assembly directive is - * encountered, and the argument to the directive is a simple word that - * requires no substitution. The appropriate compiler (TclCompileScript or - * TclCompileExpr) is invoked recursively, and emits bytecode. - * - * Before the compiler is invoked, the compilation environment's stack - * consumption is reset to zero. Upon return from the compilation, the net - * stack effect of the compilation is in the compiler env, and this stack - * effect is posted to the assembler environment. The compile environment's - * stack consumption is then restored to what it was before (which is actually - * the state of the stack on entry to the block of assembly code). - * - * Any exception ranges pushed by the compilation are copied to the basic - * block and removed from the compiler environment. They will be rebuilt at - * the end of assembly, when the exception stack depth is actually known. - * - *----------------------------------------------------------------------------- - */ - -static void -CompileEmbeddedScript( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - Tcl_Token* tokenPtr, /* Tcl_Token containing the script */ - const TalInstDesc* instPtr) /* Instruction that determines whether - * the script is 'expr' or 'eval' */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - - /* - * The expression or script is not only known at compile time, but - * actually a "simple word". It can be compiled inline by invoking the - * compiler recursively. - * - * Save away the stack depth and reset it before compiling the script. - * We'll record the stack usage of the script in the BasicBlock, and - * accumulate it together with the stack usage of the enclosing assembly - * code. - */ - - int savedStackDepth = envPtr->currStackDepth; - int savedMaxStackDepth = envPtr->maxStackDepth; - int savedCodeIndex = envPtr->codeNext - envPtr->codeStart; - int savedExceptArrayNext = envPtr->exceptArrayNext; - - envPtr->currStackDepth = 0; - envPtr->maxStackDepth = 0; - - StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL); - switch(instPtr->tclInstCode) { - case INST_EVAL_STK: - TclCompileScript(interp, tokenPtr->start, tokenPtr->size, envPtr); - break; - case INST_EXPR_STK: - TclCompileExpr(interp, tokenPtr->start, tokenPtr->size, envPtr, 1); - break; - default: - Tcl_Panic("no ASSEM_EVAL case for %s (%d), can't happen", - instPtr->name, instPtr->tclInstCode); - } - - /* - * Roll up the stack usage of the embedded block into the assembler - * environment. - */ - - SyncStackDepth(assemEnvPtr); - envPtr->currStackDepth = savedStackDepth; - envPtr->maxStackDepth = savedMaxStackDepth; - - /* - * Save any exception ranges that were pushed by the compiler; they will - * need to be fixed up once the stack depth is known. - */ - - MoveExceptionRangesToBasicBlock(assemEnvPtr, savedCodeIndex, - savedExceptArrayNext); - - /* - * Flush the current basic block. - */ - - StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL); -} - -/* - *----------------------------------------------------------------------------- - * - * SyncStackDepth -- - * - * Copies the stack depth from the compile environment to a basic block. - * - * Side effects: - * Current and max stack depth in the current basic block are adjusted. - * - * This procedure is called on return from invoking the compiler for the - * 'eval' and 'expr' operations. It adjusts the stack depth of the current - * basic block to reflect the stack required by the just-compiled code. - * - *----------------------------------------------------------------------------- - */ - -static void -SyncStackDepth( - AssemblyEnv* assemEnvPtr) /* Assembly environment */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - BasicBlock* curr_bb = assemEnvPtr->curr_bb; - /* Current basic block */ - int maxStackDepth = curr_bb->finalStackDepth + envPtr->maxStackDepth; - /* Max stack depth in the basic block */ - - if (maxStackDepth > curr_bb->maxStackDepth) { - curr_bb->maxStackDepth = maxStackDepth; - } - curr_bb->finalStackDepth += envPtr->currStackDepth; -} - -/* - *----------------------------------------------------------------------------- - * - * MoveExceptionRangesToBasicBlock -- - * - * Removes exception ranges that were created by compiling an embedded - * script from the CompileEnv, and stores them in the BasicBlock. They - * will be reinstalled, at the correct stack depth, after control flow - * analysis is complete on the assembly code. - * - *----------------------------------------------------------------------------- - */ - -static void -MoveExceptionRangesToBasicBlock( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - int savedCodeIndex, /* Start of the embedded code */ - int savedExceptArrayNext) /* Saved index of the end of the exception - * range array */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - BasicBlock* curr_bb = assemEnvPtr->curr_bb; - /* Current basic block */ - int exceptionCount = envPtr->exceptArrayNext - savedExceptArrayNext; - /* Number of ranges that must be moved */ - int i; - - if (exceptionCount == 0) { - /* Nothing to do */ - return; - } - - /* - * Save the exception ranges in the basic block. They will be re-added at - * the conclusion of assembly; at this time, the INST_BEGIN_CATCH - * instructions in the block will be adjusted from whatever range indices - * they have [savedExceptArrayNext .. envPtr->exceptArrayNext) to the - * indices that the exceptions acquire. The saved exception ranges are - * converted to a relative nesting depth. The depth will be recomputed - * once flow analysis has determined the actual stack depth of the block. - */ - - DEBUG_PRINT("basic block %p has %d exceptions starting at %d\n", - curr_bb, exceptionCount, savedExceptArrayNext); - curr_bb->foreignExceptionBase = savedExceptArrayNext; - curr_bb->foreignExceptionCount = exceptionCount; - curr_bb->foreignExceptions = - ckalloc(exceptionCount * sizeof(ExceptionRange)); - memcpy(curr_bb->foreignExceptions, - envPtr->exceptArrayPtr + savedExceptArrayNext, - exceptionCount * sizeof(ExceptionRange)); - for (i = 0; i < exceptionCount; ++i) { - curr_bb->foreignExceptions[i].nestingLevel -= envPtr->exceptDepth; - } - envPtr->exceptArrayNext = savedExceptArrayNext; -} - -/* - *----------------------------------------------------------------------------- - * - * CreateMirrorJumpTable -- - * - * Makes a jump table with comparison values and assembly code labels. - * - * Results: - * Returns a standard Tcl status, with an error message in the - * interpreter on error. - * - * Side effects: - * Initializes the jump table pointer in the current basic block to a - * JumptableInfo. The keys in the JumptableInfo are the comparison - * strings. The values, instead of being jump displacements, are - * Tcl_Obj's with the code labels. - */ - -static int -CreateMirrorJumpTable( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - Tcl_Obj* jumps) /* List of alternating keywords and labels */ -{ - int objc; /* Number of elements in the 'jumps' list */ - Tcl_Obj** objv; /* Pointers to the elements in the list */ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - BasicBlock* bbPtr = assemEnvPtr->curr_bb; - /* Current basic block */ - JumptableInfo* jtPtr; - Tcl_HashTable* jtHashPtr; /* Hashtable in the JumptableInfo */ - Tcl_HashEntry* hashEntry; /* Entry for a key in the hashtable */ - int isNew; /* Flag==1 if the key is not yet in the - * table. */ - int i; - - if (Tcl_ListObjGetElements(interp, jumps, &objc, &objv) != TCL_OK) { - return TCL_ERROR; - } - if (objc % 2 != 0) { - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "jump table must have an even number of list elements", - -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADJUMPTABLE", NULL); - } - return TCL_ERROR; - } - - /* - * Allocate the jumptable. - */ - - jtPtr = ckalloc(sizeof(JumptableInfo)); - jtHashPtr = &jtPtr->hashTable; - Tcl_InitHashTable(jtHashPtr, TCL_STRING_KEYS); - - /* - * Fill the keys and labels into the table. - */ - - DEBUG_PRINT("jump table {\n"); - for (i = 0; i < objc; i+=2) { - DEBUG_PRINT(" %s -> %s\n", Tcl_GetString(objv[i]), - Tcl_GetString(objv[i+1])); - hashEntry = Tcl_CreateHashEntry(jtHashPtr, Tcl_GetString(objv[i]), - &isNew); - if (!isNew) { - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "duplicate entry in jump table for \"%s\"", - Tcl_GetString(objv[i]))); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPJUMPTABLEENTRY"); - DeleteMirrorJumpTable(jtPtr); - return TCL_ERROR; - } - } - Tcl_SetHashValue(hashEntry, objv[i+1]); - Tcl_IncrRefCount(objv[i+1]); - } - DEBUG_PRINT("}\n"); - - /* - * Put the mirror jumptable in the basic block struct. - */ - - bbPtr->jtPtr = jtPtr; - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * DeleteMirrorJumpTable -- - * - * Cleans up a jump table when the basic block is deleted. - * - *----------------------------------------------------------------------------- - */ - -static void -DeleteMirrorJumpTable( - JumptableInfo* jtPtr) -{ - Tcl_HashTable* jtHashPtr = &jtPtr->hashTable; - /* Hash table pointer */ - Tcl_HashSearch search; /* Hash search control */ - Tcl_HashEntry* entry; /* Hash table entry containing a jump label */ - Tcl_Obj* label; /* Jump label from the hash table */ - - for (entry = Tcl_FirstHashEntry(jtHashPtr, &search); - entry != NULL; - entry = Tcl_NextHashEntry(&search)) { - label = Tcl_GetHashValue(entry); - Tcl_DecrRefCount(label); - Tcl_SetHashValue(entry, NULL); - } - Tcl_DeleteHashTable(jtHashPtr); - ckfree(jtPtr); -} - -/* - *----------------------------------------------------------------------------- - * - * GetNextOperand -- - * - * Retrieves the next operand in sequence from an assembly instruction, - * and makes sure that its value is known at compile time. - * - * Results: - * If successful, returns TCL_OK and leaves a Tcl_Obj with the operand - * text in *operandObjPtr. In case of failure, returns TCL_ERROR and - * leaves *operandObjPtr untouched. - * - * Side effects: - * Advances *tokenPtrPtr around the token just processed. - * - *----------------------------------------------------------------------------- - */ - -static int -GetNextOperand( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - Tcl_Token** tokenPtrPtr, /* INPUT/OUTPUT: Pointer to the token holding - * the operand */ - Tcl_Obj** operandObjPtr) /* OUTPUT: Tcl object holding the operand text - * with \-substitutions done. */ -{ - Tcl_Interp* interp = (Tcl_Interp*) assemEnvPtr->envPtr->iPtr; - Tcl_Obj* operandObj = Tcl_NewObj(); - - if (!TclWordKnownAtCompileTime(*tokenPtrPtr, operandObj)) { - Tcl_DecrRefCount(operandObj); - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "assembly code may not contain substitutions", -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOSUBST", NULL); - } - return TCL_ERROR; - } - *tokenPtrPtr = TokenAfter(*tokenPtrPtr); - Tcl_IncrRefCount(operandObj); - *operandObjPtr = operandObj; - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * GetBooleanOperand -- - * - * Retrieves a Boolean operand from the input stream and advances - * the token pointer. - * - * Results: - * Returns a standard Tcl result (with an error message in the - * interpreter on failure). - * - * Side effects: - * Stores the Boolean value in (*result) and advances (*tokenPtrPtr) - * to the next token. - * - *----------------------------------------------------------------------------- - */ - -static int -GetBooleanOperand( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - Tcl_Token** tokenPtrPtr, /* Current token from the parser */ - int* result) /* OUTPUT: Integer extracted from the token */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - Tcl_Token* tokenPtr = *tokenPtrPtr; - /* INOUT: Pointer to the next token in the - * source code */ - Tcl_Obj* intObj; /* Integer from the source code */ - int status; /* Tcl status return */ - - /* - * Extract the next token as a string. - */ - - if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Convert to an integer, advance to the next token and return. - */ - - status = Tcl_GetBooleanFromObj(interp, intObj, result); - Tcl_DecrRefCount(intObj); - *tokenPtrPtr = TokenAfter(tokenPtr); - return status; -} - -/* - *----------------------------------------------------------------------------- - * - * GetIntegerOperand -- - * - * Retrieves an integer operand from the input stream and advances the - * token pointer. - * - * Results: - * Returns a standard Tcl result (with an error message in the - * interpreter on failure). - * - * Side effects: - * Stores the integer value in (*result) and advances (*tokenPtrPtr) to - * the next token. - * - *----------------------------------------------------------------------------- - */ - -static int -GetIntegerOperand( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - Tcl_Token** tokenPtrPtr, /* Current token from the parser */ - int* result) /* OUTPUT: Integer extracted from the token */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - Tcl_Token* tokenPtr = *tokenPtrPtr; - /* INOUT: Pointer to the next token in the - * source code */ - Tcl_Obj* intObj; /* Integer from the source code */ - int status; /* Tcl status return */ - - /* - * Extract the next token as a string. - */ - - if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Convert to an integer, advance to the next token and return. - */ - - status = Tcl_GetIntFromObj(interp, intObj, result); - Tcl_DecrRefCount(intObj); - *tokenPtrPtr = TokenAfter(tokenPtr); - return status; -} - -/* - *----------------------------------------------------------------------------- - * - * GetListIndexOperand -- - * - * Gets the value of an operand intended to serve as a list index. - * - * Results: - * Returns a standard Tcl result: TCL_OK if the parse is successful and - * TCL_ERROR (with an appropriate error message) if the parse fails. - * - * Side effects: - * Stores the list index at '*index'. Values between -1 and 0x7fffffff - * have their natural meaning; values between -2 and -0x80000000 - * represent 'end-2-N'. - * - *----------------------------------------------------------------------------- - */ - -static int -GetListIndexOperand( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - Tcl_Token** tokenPtrPtr, /* Current token from the parser */ - int* result) /* OUTPUT: Integer extracted from the token */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - Tcl_Token* tokenPtr = *tokenPtrPtr; - /* INOUT: Pointer to the next token in the - * source code */ - Tcl_Obj* intObj; /* Integer from the source code */ - int status; /* Tcl status return */ - - /* - * Extract the next token as a string. - */ - - if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Convert to an integer, advance to the next token and return. - */ - - status = TclGetIntForIndex(interp, intObj, -2, result); - Tcl_DecrRefCount(intObj); - *tokenPtrPtr = TokenAfter(tokenPtr); - return status; -} - -/* - *----------------------------------------------------------------------------- - * - * FindLocalVar -- - * - * Gets the name of a local variable from the input stream and advances - * the token pointer. - * - * Results: - * Returns the LVT index of the local variable. Returns -1 if the - * variable is non-local, not known at compile time, or cannot be - * installed in the LVT (leaving an error message in the interpreter - * result if necessary). - * - * Side effects: - * Advances the token pointer. May define a new LVT slot if the variable - * has not yet been seen and the execution context allows for it. - * - *----------------------------------------------------------------------------- - */ - -static int -FindLocalVar( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - Tcl_Token** tokenPtrPtr) -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - Tcl_Token* tokenPtr = *tokenPtrPtr; - /* INOUT: Pointer to the next token in the - * source code. */ - Tcl_Obj* varNameObj; /* Name of the variable */ - const char* varNameStr; - int varNameLen; - int localVar; /* Index of the variable in the LVT */ - - if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &varNameObj) != TCL_OK) { - return -1; - } - varNameStr = Tcl_GetStringFromObj(varNameObj, &varNameLen); - if (CheckNamespaceQualifiers(interp, varNameStr, varNameLen)) { - Tcl_DecrRefCount(varNameObj); - return -1; - } - localVar = TclFindCompiledLocal(varNameStr, varNameLen, 1, envPtr); - Tcl_DecrRefCount(varNameObj); - if (localVar == -1) { - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot use this instruction to create a variable" - " in a non-proc context", -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", NULL); - } - return -1; - } - *tokenPtrPtr = TokenAfter(tokenPtr); - return localVar; -} - -/* - *----------------------------------------------------------------------------- - * - * CheckNamespaceQualifiers -- - * - * Verify that a variable name has no namespace qualifiers before - * attempting to install it in the LVT. - * - * Results: - * On success, returns TCL_OK. On failure, returns TCL_ERROR and stores - * an error message in the interpreter result. - * - *----------------------------------------------------------------------------- - */ - -static int -CheckNamespaceQualifiers( - Tcl_Interp* interp, /* Tcl interpreter for error reporting */ - const char* name, /* Variable name to check */ - int nameLen) /* Length of the variable */ -{ - const char* p; - - for (p = name; p+2 < name+nameLen; p++) { - if ((*p == ':') && (p[1] == ':')) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "variable \"%s\" is not local", name)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONLOCAL", name, NULL); - return TCL_ERROR; - } - } - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * CheckOneByte -- - * - * Verify that a constant fits in a single byte in the instruction - * stream. - * - * Results: - * On success, returns TCL_OK. On failure, returns TCL_ERROR and stores - * an error message in the interpreter result. - * - * This code is here primarily to verify that instructions like INCR_SCALAR1 - * are possible on a given local variable. The fact that there is no - * INCR_SCALAR4 is puzzling. - * - *----------------------------------------------------------------------------- - */ - -static int -CheckOneByte( - Tcl_Interp* interp, /* Tcl interpreter for error reporting */ - int value) /* Value to check */ -{ - Tcl_Obj* result; /* Error message */ - - if (value < 0 || value > 0xff) { - result = Tcl_NewStringObj("operand does not fit in one byte", -1); - Tcl_SetObjResult(interp, result); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", NULL); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * CheckSignedOneByte -- - * - * Verify that a constant fits in a single signed byte in the instruction - * stream. - * - * Results: - * On success, returns TCL_OK. On failure, returns TCL_ERROR and stores - * an error message in the interpreter result. - * - * This code is here primarily to verify that instructions like INCR_SCALAR1 - * are possible on a given local variable. The fact that there is no - * INCR_SCALAR4 is puzzling. - * - *----------------------------------------------------------------------------- - */ - -static int -CheckSignedOneByte( - Tcl_Interp* interp, /* Tcl interpreter for error reporting */ - int value) /* Value to check */ -{ - Tcl_Obj* result; /* Error message */ - - if (value > 0x7f || value < -0x80) { - result = Tcl_NewStringObj("operand does not fit in one byte", -1); - Tcl_SetObjResult(interp, result); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", NULL); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * CheckNonNegative -- - * - * Verify that a constant is nonnegative - * - * Results: - * On success, returns TCL_OK. On failure, returns TCL_ERROR and stores - * an error message in the interpreter result. - * - * This code is here primarily to verify that instructions like INCR_INVOKE - * are consuming a positive number of operands - * - *----------------------------------------------------------------------------- - */ - -static int -CheckNonNegative( - Tcl_Interp* interp, /* Tcl interpreter for error reporting */ - int value) /* Value to check */ -{ - Tcl_Obj* result; /* Error message */ - - if (value < 0) { - result = Tcl_NewStringObj("operand must be nonnegative", -1); - Tcl_SetObjResult(interp, result); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONNEGATIVE", NULL); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * CheckStrictlyPositive -- - * - * Verify that a constant is positive - * - * Results: - * On success, returns TCL_OK. On failure, returns TCL_ERROR and - * stores an error message in the interpreter result. - * - * This code is here primarily to verify that instructions like INCR_INVOKE - * are consuming a positive number of operands - * - *----------------------------------------------------------------------------- - */ - -static int -CheckStrictlyPositive( - Tcl_Interp* interp, /* Tcl interpreter for error reporting */ - int value) /* Value to check */ -{ - Tcl_Obj* result; /* Error message */ - - if (value <= 0) { - result = Tcl_NewStringObj("operand must be positive", -1); - Tcl_SetObjResult(interp, result); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "POSITIVE", NULL); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * DefineLabel -- - * - * Defines a label appearing in the assembly sequence. - * - * Results: - * Returns a standard Tcl result. Returns TCL_OK and an empty result if - * the definition succeeds; returns TCL_ERROR and an appropriate message - * if a duplicate definition is found. - * - *----------------------------------------------------------------------------- - */ - -static int -DefineLabel( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - const char* labelName) /* Label being defined */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - Tcl_HashEntry* entry; /* Label's entry in the symbol table */ - int isNew; /* Flag == 1 iff the label was previously - * undefined */ - - /* TODO - This can now be simplified! */ - - StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL); - - /* - * Look up the newly-defined label in the symbol table. - */ - - entry = Tcl_CreateHashEntry(&assemEnvPtr->labelHash, labelName, &isNew); - if (!isNew) { - /* - * This is a duplicate label. - */ - - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "duplicate definition of label \"%s\"", labelName)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPLABEL", labelName, - NULL); - } - return TCL_ERROR; - } - - /* - * This is the first appearance of the label in the code. - */ - - Tcl_SetHashValue(entry, assemEnvPtr->curr_bb); - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * StartBasicBlock -- - * - * Starts a new basic block when a label or jump is encountered. - * - * Results: - * Returns a pointer to the BasicBlock structure of the new - * basic block. - * - *----------------------------------------------------------------------------- - */ - -static BasicBlock* -StartBasicBlock( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - int flags, /* Flags to apply to the basic block being - * closed, if there is one. */ - Tcl_Obj* jumpLabel) /* Label of the location that the block jumps - * to, or NULL if the block does not jump */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - BasicBlock* newBB; /* BasicBlock structure for the new block */ - BasicBlock* currBB = assemEnvPtr->curr_bb; - - /* - * Coalesce zero-length blocks. - */ - - if (currBB->startOffset == envPtr->codeNext - envPtr->codeStart) { - currBB->startLine = assemEnvPtr->cmdLine; - return currBB; - } - - /* - * Make the new basic block. - */ - - newBB = AllocBB(assemEnvPtr); - - /* - * Record the jump target if there is one. - */ - - currBB->jumpTarget = jumpLabel; - if (jumpLabel != NULL) { - Tcl_IncrRefCount(currBB->jumpTarget); - } - - /* - * Record the fallthrough if there is one. - */ - - currBB->flags |= flags; - - /* - * Record the successor block. - */ - - currBB->successor1 = newBB; - assemEnvPtr->curr_bb = newBB; - return newBB; -} - -/* - *----------------------------------------------------------------------------- - * - * AllocBB -- - * - * Allocates a new basic block - * - * Results: - * Returns a pointer to the newly allocated block, which is initialized - * to contain no code and begin at the current instruction pointer. - * - *----------------------------------------------------------------------------- - */ - -static BasicBlock * -AllocBB( - AssemblyEnv* assemEnvPtr) /* Assembly environment */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - BasicBlock *bb = ckalloc(sizeof(BasicBlock)); - - bb->originalStartOffset = - bb->startOffset = envPtr->codeNext - envPtr->codeStart; - bb->startLine = assemEnvPtr->cmdLine + 1; - bb->jumpOffset = -1; - bb->jumpLine = -1; - bb->prevPtr = assemEnvPtr->curr_bb; - bb->predecessor = NULL; - bb->successor1 = NULL; - bb->jumpTarget = NULL; - bb->initialStackDepth = 0; - bb->minStackDepth = 0; - bb->maxStackDepth = 0; - bb->finalStackDepth = 0; - bb->enclosingCatch = NULL; - bb->foreignExceptionBase = -1; - bb->foreignExceptionCount = 0; - bb->foreignExceptions = NULL; - bb->jtPtr = NULL; - bb->flags = 0; - - return bb; -} - -/* - *----------------------------------------------------------------------------- - * - * FinishAssembly -- - * - * Postprocessing after all bytecode has been generated for a block of - * assembly code. - * - * Results: - * Returns a standard Tcl result, with an error message left in the - * interpreter if appropriate. - * - * Side effects: - * The program is checked to see if any undefined labels remain. The - * initial stack depth of all the basic blocks in the flow graph is - * calculated and saved. The stack balance on exit is computed, checked - * and saved. - * - *----------------------------------------------------------------------------- - */ - -static int -FinishAssembly( - AssemblyEnv* assemEnvPtr) /* Assembly environment */ -{ - int mustMove; /* Amount by which the code needs to be grown - * because of expanding jumps */ - - /* - * Resolve the targets of all jumps and determine whether code needs to be - * moved around. - */ - - if (CalculateJumpRelocations(assemEnvPtr, &mustMove)) { - return TCL_ERROR; - } - - /* - * Move the code if necessary. - */ - - if (mustMove) { - MoveCodeForJumps(assemEnvPtr, mustMove); - } - - /* - * Resolve jump target labels to bytecode offsets. - */ - - FillInJumpOffsets(assemEnvPtr); - - /* - * Label each basic block with its catch context. Quit on inconsistency. - */ - - if (ProcessCatches(assemEnvPtr) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Make sure that no block accessible from a catch's error exit that hasn't - * popped the exception stack can throw an exception. - */ - - if (CheckForThrowInWrongContext(assemEnvPtr) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Compute stack balance throughout the program. - */ - - if (CheckStack(assemEnvPtr) != TCL_OK) { - return TCL_ERROR; - } - - /* - * TODO - Check for unreachable code. Or maybe not; unreachable code is - * Mostly Harmless. - */ - - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * CalculateJumpRelocations -- - * - * Calculate any movement that has to be done in the assembly code to - * expand JUMP1 instructions to JUMP4 (because they jump more than a - * 1-byte range). - * - * Results: - * Returns a standard Tcl result, with an appropriate error message if - * anything fails. - * - * Side effects: - * Sets the 'startOffset' pointer in every basic block to the new origin - * of the block, and turns off JUMP1 flags on instructions that must be - * expanded (and adjusts them to the corresponding JUMP4's). Does *not* - * store the jump offsets at this point. - * - * Sets *mustMove to 1 if and only if at least one instruction changed - * size so the code must be moved. - * - * As a side effect, also checks for undefined labels and reports them. - * - *----------------------------------------------------------------------------- - */ - -static int -CalculateJumpRelocations( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - int* mustMove) /* OUTPUT: Number of bytes that have been - * added to the code */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - BasicBlock* bbPtr; /* Pointer to a basic block being checked */ - Tcl_HashEntry* entry; /* Exit label's entry in the symbol table */ - BasicBlock* jumpTarget; /* Basic block where the jump goes */ - int motion; /* Amount by which the code has expanded */ - int offset; /* Offset in the bytecode from a jump - * instruction to its target */ - unsigned opcode; /* Opcode in the bytecode being adjusted */ - - /* - * Iterate through basic blocks as long as a change results in code - * expansion. - */ - - *mustMove = 0; - do { - motion = 0; - for (bbPtr = assemEnvPtr->head_bb; - bbPtr != NULL; - bbPtr = bbPtr->successor1) { - /* - * Advance the basic block start offset by however many bytes we - * have inserted in the code up to this point - */ - - bbPtr->startOffset += motion; - - /* - * If the basic block references a label (and hence performs a - * jump), find the location of the label. Report an error if the - * label is missing. - */ - - if (bbPtr->jumpTarget != NULL) { - entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(bbPtr->jumpTarget)); - if (entry == NULL) { - ReportUndefinedLabel(assemEnvPtr, bbPtr, - bbPtr->jumpTarget); - return TCL_ERROR; - } - - /* - * If the instruction is a JUMP1, turn it into a JUMP4 if its - * target is out of range. - */ - - jumpTarget = Tcl_GetHashValue(entry); - if (bbPtr->flags & BB_JUMP1) { - offset = jumpTarget->startOffset - - (bbPtr->jumpOffset + motion); - if (offset < -0x80 || offset > 0x7f) { - opcode = TclGetUInt1AtPtr(envPtr->codeStart - + bbPtr->jumpOffset); - ++opcode; - TclStoreInt1AtPtr(opcode, - envPtr->codeStart + bbPtr->jumpOffset); - motion += 3; - bbPtr->flags &= ~BB_JUMP1; - } - } - } - - /* - * If the basic block references a jump table, that doesn't affect - * the code locations, but resolve the labels now, and store basic - * block pointers in the jumptable hash. - */ - - if (bbPtr->flags & BB_JUMPTABLE) { - if (CheckJumpTableLabels(assemEnvPtr, bbPtr) != TCL_OK) { - return TCL_ERROR; - } - } - } - *mustMove += motion; - } while (motion != 0); - - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * CheckJumpTableLabels -- - * - * Make sure that all the labels in a jump table are defined. - * - * Results: - * Returns TCL_OK if they are, TCL_ERROR if they aren't. - * - *----------------------------------------------------------------------------- - */ - -static int -CheckJumpTableLabels( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - BasicBlock* bbPtr) /* Basic block that ends in a jump table */ -{ - Tcl_HashTable* symHash = &bbPtr->jtPtr->hashTable; - /* Hash table with the symbols */ - Tcl_HashSearch search; /* Hash table iterator */ - Tcl_HashEntry* symEntryPtr; /* Hash entry for the symbols */ - Tcl_Obj* symbolObj; /* Jump target */ - Tcl_HashEntry* valEntryPtr; /* Hash entry for the resolutions */ - - /* - * Look up every jump target in the jump hash. - */ - - DEBUG_PRINT("check jump table labels %p {\n", bbPtr); - for (symEntryPtr = Tcl_FirstHashEntry(symHash, &search); - symEntryPtr != NULL; - symEntryPtr = Tcl_NextHashEntry(&search)) { - symbolObj = Tcl_GetHashValue(symEntryPtr); - valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(symbolObj)); - DEBUG_PRINT(" %s -> %s (%d)\n", - (char*) Tcl_GetHashKey(symHash, symEntryPtr), - Tcl_GetString(symbolObj), (valEntryPtr != NULL)); - if (valEntryPtr == NULL) { - ReportUndefinedLabel(assemEnvPtr, bbPtr, symbolObj); - return TCL_ERROR; - } - } - DEBUG_PRINT("}\n"); - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * ReportUndefinedLabel -- - * - * Report that a basic block refers to an undefined jump label - * - * Side effects: - * Stores an error message, error code, and line number information in - * the assembler's Tcl interpreter. - * - *----------------------------------------------------------------------------- - */ - -static void -ReportUndefinedLabel( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - BasicBlock* bbPtr, /* Basic block that contains the undefined - * label */ - Tcl_Obj* jumpTarget) /* Label of a jump target */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "undefined label \"%s\"", Tcl_GetString(jumpTarget))); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOLABEL", - Tcl_GetString(jumpTarget), NULL); - Tcl_SetErrorLine(interp, bbPtr->jumpLine); - } -} - -/* - *----------------------------------------------------------------------------- - * - * MoveCodeForJumps -- - * - * Move bytecodes in memory to accommodate JUMP1 instructions that have - * expanded to become JUMP4's. - * - *----------------------------------------------------------------------------- - */ - -static void -MoveCodeForJumps( - AssemblyEnv* assemEnvPtr, /* Assembler environment */ - int mustMove) /* Number of bytes of added code */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - BasicBlock* bbPtr; /* Pointer to a basic block being checked */ - int topOffset; /* Bytecode offset of the following basic - * block before code motion */ - - /* - * Make sure that there is enough space in the bytecode array to - * accommodate the expanded code. - */ - - while (envPtr->codeEnd < envPtr->codeNext + mustMove) { - TclExpandCodeArray(envPtr); - } - - /* - * Iterate through the bytecodes in reverse order, and move them upward to - * their new homes. - */ - - topOffset = envPtr->codeNext - envPtr->codeStart; - for (bbPtr = assemEnvPtr->curr_bb; bbPtr != NULL; bbPtr = bbPtr->prevPtr) { - DEBUG_PRINT("move code from %d to %d\n", - bbPtr->originalStartOffset, bbPtr->startOffset); - memmove(envPtr->codeStart + bbPtr->startOffset, - envPtr->codeStart + bbPtr->originalStartOffset, - topOffset - bbPtr->originalStartOffset); - topOffset = bbPtr->originalStartOffset; - bbPtr->jumpOffset += (bbPtr->startOffset - bbPtr->originalStartOffset); - } - envPtr->codeNext += mustMove; -} - -/* - *----------------------------------------------------------------------------- - * - * FillInJumpOffsets -- - * - * Fill in the final offsets of all jump instructions once bytecode - * locations have been completely determined. - * - *----------------------------------------------------------------------------- - */ - -static void -FillInJumpOffsets( - AssemblyEnv* assemEnvPtr) /* Assembly environment */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - BasicBlock* bbPtr; /* Pointer to a basic block being checked */ - Tcl_HashEntry* entry; /* Hashtable entry for a jump target label */ - BasicBlock* jumpTarget; /* Basic block where a jump goes */ - int fromOffset; /* Bytecode location of a jump instruction */ - int targetOffset; /* Bytecode location of a jump instruction's - * target */ - - for (bbPtr = assemEnvPtr->head_bb; - bbPtr != NULL; - bbPtr = bbPtr->successor1) { - if (bbPtr->jumpTarget != NULL) { - entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(bbPtr->jumpTarget)); - jumpTarget = Tcl_GetHashValue(entry); - fromOffset = bbPtr->jumpOffset; - targetOffset = jumpTarget->startOffset; - if (bbPtr->flags & BB_JUMP1) { - TclStoreInt1AtPtr(targetOffset - fromOffset, - envPtr->codeStart + fromOffset + 1); - } else { - TclStoreInt4AtPtr(targetOffset - fromOffset, - envPtr->codeStart + fromOffset + 1); - } - } - if (bbPtr->flags & BB_JUMPTABLE) { - ResolveJumpTableTargets(assemEnvPtr, bbPtr); - } - } -} - -/* - *----------------------------------------------------------------------------- - * - * ResolveJumpTableTargets -- - * - * Puts bytecode addresses for the targets of a jumptable into the - * table - * - * Results: - * Returns TCL_OK if they are, TCL_ERROR if they aren't. - * - *----------------------------------------------------------------------------- - */ - -static void -ResolveJumpTableTargets( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - BasicBlock* bbPtr) /* Basic block that ends in a jump table */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_HashTable* symHash = &bbPtr->jtPtr->hashTable; - /* Hash table with the symbols */ - Tcl_HashSearch search; /* Hash table iterator */ - Tcl_HashEntry* symEntryPtr; /* Hash entry for the symbols */ - Tcl_Obj* symbolObj; /* Jump target */ - Tcl_HashEntry* valEntryPtr; /* Hash entry for the resolutions */ - int auxDataIndex; /* Index of the auxdata */ - JumptableInfo* realJumpTablePtr; - /* Jump table in the actual code */ - Tcl_HashTable* realJumpHashPtr; - /* Jump table hash in the actual code */ - Tcl_HashEntry* realJumpEntryPtr; - /* Entry in the jump table hash in - * the actual code */ - BasicBlock* jumpTargetBBPtr; - /* Basic block that the jump proceeds to */ - int junk; - - auxDataIndex = TclGetInt4AtPtr(envPtr->codeStart + bbPtr->jumpOffset + 1); - DEBUG_PRINT("bbPtr = %p jumpOffset = %d auxDataIndex = %d\n", - bbPtr, bbPtr->jumpOffset, auxDataIndex); - realJumpTablePtr = envPtr->auxDataArrayPtr[auxDataIndex].clientData; - realJumpHashPtr = &realJumpTablePtr->hashTable; - - /* - * Look up every jump target in the jump hash. - */ - - DEBUG_PRINT("resolve jump table {\n"); - for (symEntryPtr = Tcl_FirstHashEntry(symHash, &search); - symEntryPtr != NULL; - symEntryPtr = Tcl_NextHashEntry(&search)) { - symbolObj = Tcl_GetHashValue(symEntryPtr); - DEBUG_PRINT(" symbol %s\n", Tcl_GetString(symbolObj)); - - valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(symbolObj)); - jumpTargetBBPtr = Tcl_GetHashValue(valEntryPtr); - - realJumpEntryPtr = Tcl_CreateHashEntry(realJumpHashPtr, - Tcl_GetHashKey(symHash, symEntryPtr), &junk); - DEBUG_PRINT(" %s -> %s -> bb %p (pc %d) hash entry %p\n", - (char*) Tcl_GetHashKey(symHash, symEntryPtr), - Tcl_GetString(symbolObj), jumpTargetBBPtr, - jumpTargetBBPtr->startOffset, realJumpEntryPtr); - - Tcl_SetHashValue(realJumpEntryPtr, - INT2PTR(jumpTargetBBPtr->startOffset - bbPtr->jumpOffset)); - } - DEBUG_PRINT("}\n"); -} - -/* - *----------------------------------------------------------------------------- - * - * CheckForThrowInWrongContext -- - * - * Verify that no beginCatch/endCatch sequence can throw an exception - * after an original exception is caught and before its exception context - * is removed from the stack. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * Stores an appropriate error message in the interpreter as needed. - * - *----------------------------------------------------------------------------- - */ - -static int -CheckForThrowInWrongContext( - AssemblyEnv* assemEnvPtr) /* Assembly environment */ -{ - BasicBlock* blockPtr; /* Current basic block */ - - /* - * Walk through the basic blocks in turn, checking all the ones that have - * caught an exception and not disposed of it properly. - */ - - for (blockPtr = assemEnvPtr->head_bb; - blockPtr != NULL; - blockPtr = blockPtr->successor1) { - if (blockPtr->catchState == BBCS_CAUGHT) { - /* - * Walk through the instructions in the basic block. - */ - - if (CheckNonThrowingBlock(assemEnvPtr, blockPtr) != TCL_OK) { - return TCL_ERROR; - } - } - } - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * CheckNonThrowingBlock -- - * - * Check that a basic block cannot throw an exception. - * - * Results: - * Returns TCL_ERROR if the block cannot be proven to be nonthrowing. - * - * Side effects: - * Stashes an error message in the interpreter result. - * - *----------------------------------------------------------------------------- - */ - -static int -CheckNonThrowingBlock( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - BasicBlock* blockPtr) /* Basic block where exceptions are not - * allowed */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - BasicBlock* nextPtr; /* Pointer to the succeeding basic block */ - int offset; /* Bytecode offset of the current - * instruction */ - int bound; /* Bytecode offset following the last - * instruction of the block. */ - unsigned char opcode; /* Current bytecode instruction */ - - /* - * Determine where in the code array the basic block ends. - */ - - nextPtr = blockPtr->successor1; - if (nextPtr == NULL) { - bound = envPtr->codeNext - envPtr->codeStart; - } else { - bound = nextPtr->startOffset; - } - - /* - * Walk through the instructions of the block. - */ - - offset = blockPtr->startOffset; - while (offset < bound) { - /* - * Determine whether an instruction is nonthrowing. - */ - - opcode = (envPtr->codeStart)[offset]; - if (BytecodeMightThrow(opcode)) { - /* - * Report an error for a throw in the wrong context. - */ - - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" instruction may not appear in " - "a context where an exception has been " - "caught and not disposed of.", - tclInstructionTable[opcode].name)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADTHROW", NULL); - AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr); - } - return TCL_ERROR; - } - offset += tclInstructionTable[opcode].numBytes; - } - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * BytecodeMightThrow -- - * - * Tests if a given bytecode instruction might throw an exception. - * - * Results: - * Returns 1 if the bytecode might throw an exception, 0 if the - * instruction is known never to throw. - * - *----------------------------------------------------------------------------- - */ - -static int -BytecodeMightThrow( - unsigned char opcode) -{ - /* - * Binary search on the non-throwing bytecode list. - */ - - int min = 0; - int max = sizeof(NonThrowingByteCodes) - 1; - int mid; - unsigned char c; - - while (max >= min) { - mid = (min + max) / 2; - c = NonThrowingByteCodes[mid]; - if (opcode < c) { - max = mid-1; - } else if (opcode > c) { - min = mid+1; - } else { - /* - * Opcode is nonthrowing. - */ - - return 0; - } - } - - return 1; -} - -/* - *----------------------------------------------------------------------------- - * - * CheckStack -- - * - * Audit stack usage in a block of assembly code. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * Updates stack depth on entry for all basic blocks in the flowgraph. - * Calculates the max stack depth used in the program, and updates the - * compilation environment to reflect it. - * - *----------------------------------------------------------------------------- - */ - -static int -CheckStack( - AssemblyEnv* assemEnvPtr) /* Assembly environment */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - int maxDepth; /* Maximum stack depth overall */ - - /* - * Checking the head block will check all the other blocks recursively. - */ - - assemEnvPtr->maxDepth = 0; - if (StackCheckBasicBlock(assemEnvPtr, assemEnvPtr->head_bb, NULL, - 0) == TCL_ERROR) { - return TCL_ERROR; - } - - /* - * Post the max stack depth back to the compilation environment. - */ - - maxDepth = assemEnvPtr->maxDepth + envPtr->currStackDepth; - if (maxDepth > envPtr->maxStackDepth) { - envPtr->maxStackDepth = maxDepth; - } - - /* - * If the exit is reachable, make sure that the program exits with 1 - * operand on the stack. - */ - - if (StackCheckExit(assemEnvPtr) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Reset the visited state on all basic blocks. - */ - - ResetVisitedBasicBlocks(assemEnvPtr); - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * StackCheckBasicBlock -- - * - * Checks stack consumption for a basic block (and recursively for its - * successors). - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * Updates initial stack depth for the basic block and its successors. - * (Final and maximum stack depth are relative to initial, and are not - * touched). - * - * This procedure eventually checks, for the entire flow graph, whether stack - * balance is consistent. It is an error for a given basic block to be - * reachable along multiple flow paths with different stack depths. - * - *----------------------------------------------------------------------------- - */ - -static int -StackCheckBasicBlock( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - BasicBlock* blockPtr, /* Pointer to the basic block being checked */ - BasicBlock* predecessor, /* Pointer to the block that passed control to - * this one. */ - int initialStackDepth) /* Stack depth on entry to the block */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - BasicBlock* jumpTarget; /* Basic block where a jump goes */ - int stackDepth; /* Current stack depth */ - int maxDepth; /* Maximum stack depth so far */ - int result; /* Tcl status return */ - Tcl_HashSearch jtSearch; /* Search structure for the jump table */ - Tcl_HashEntry* jtEntry; /* Hash entry in the jump table */ - Tcl_Obj* targetLabel; /* Target label from the jump table */ - Tcl_HashEntry* entry; /* Hash entry in the label table */ - - if (blockPtr->flags & BB_VISITED) { - /* - * If the block is already visited, check stack depth for consistency - * among the paths that reach it. - */ - - if (blockPtr->initialStackDepth == initialStackDepth) { - return TCL_OK; - } - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "inconsistent stack depths on two execution paths", -1)); - - /* - * TODO - add execution trace of both paths - */ - - Tcl_SetErrorLine(interp, blockPtr->startLine); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL); - } - return TCL_ERROR; - } - - /* - * If the block is not already visited, set the 'predecessor' link to - * indicate how control got to it. Set the initial stack depth to the - * current stack depth in the flow of control. - */ - - blockPtr->flags |= BB_VISITED; - blockPtr->predecessor = predecessor; - blockPtr->initialStackDepth = initialStackDepth; - - /* - * Calculate minimum stack depth, and flag an error if the block - * underflows the stack. - */ - - if (initialStackDepth + blockPtr->minStackDepth < 0) { - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("stack underflow", -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL); - AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr); - Tcl_SetErrorLine(interp, blockPtr->startLine); - } - return TCL_ERROR; - } - - /* - * Make sure that the block doesn't try to pop below the stack level of an - * enclosing catch. - */ - - if (blockPtr->enclosingCatch != 0 && - initialStackDepth + blockPtr->minStackDepth - < (blockPtr->enclosingCatch->initialStackDepth - + blockPtr->enclosingCatch->finalStackDepth)) { - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "code pops stack below level of enclosing catch", -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACKINCATCH", -1); - AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr); - Tcl_SetErrorLine(interp, blockPtr->startLine); - } - return TCL_ERROR; - } - - /* - * Update maximum stgack depth. - */ - - maxDepth = initialStackDepth + blockPtr->maxStackDepth; - if (maxDepth > assemEnvPtr->maxDepth) { - assemEnvPtr->maxDepth = maxDepth; - } - - /* - * Calculate stack depth on exit from the block, and invoke this procedure - * recursively to check successor blocks. - */ - - stackDepth = initialStackDepth + blockPtr->finalStackDepth; - result = TCL_OK; - if (blockPtr->flags & BB_FALLTHRU) { - result = StackCheckBasicBlock(assemEnvPtr, blockPtr->successor1, - blockPtr, stackDepth); - } - - if (result == TCL_OK && blockPtr->jumpTarget != NULL) { - entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(blockPtr->jumpTarget)); - jumpTarget = Tcl_GetHashValue(entry); - result = StackCheckBasicBlock(assemEnvPtr, jumpTarget, blockPtr, - stackDepth); - } - - /* - * All blocks referenced in a jump table are successors. - */ - - if (blockPtr->flags & BB_JUMPTABLE) { - for (jtEntry = Tcl_FirstHashEntry(&blockPtr->jtPtr->hashTable, - &jtSearch); - result == TCL_OK && jtEntry != NULL; - jtEntry = Tcl_NextHashEntry(&jtSearch)) { - targetLabel = Tcl_GetHashValue(jtEntry); - entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(targetLabel)); - jumpTarget = Tcl_GetHashValue(entry); - result = StackCheckBasicBlock(assemEnvPtr, jumpTarget, - blockPtr, stackDepth); - } - } - - return result; -} - -/* - *----------------------------------------------------------------------------- - * - * StackCheckExit -- - * - * Makes sure that the net stack effect of an entire assembly language - * script is to push 1 result. - * - * Results: - * Returns a standard Tcl result, with an error message in the - * interpreter result if the stack is wrong. - * - * Side effects: - * If the assembly code had a net stack effect of zero, emits code to the - * concluding block to push a null result. In any case, updates the stack - * depth in the compile environment to reflect the net effect of the - * assembly code. - * - *----------------------------------------------------------------------------- - */ - -static int -StackCheckExit( - AssemblyEnv* assemEnvPtr) /* Assembly environment */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - int depth; /* Net stack effect */ - int litIndex; /* Index in the literal pool of the empty - * string */ - BasicBlock* curr_bb = assemEnvPtr->curr_bb; - /* Final basic block in the assembly */ - - /* - * Don't perform these checks if execution doesn't reach the exit (either - * because of an infinite loop or because the only return is from the - * middle. - */ - - if (curr_bb->flags & BB_VISITED) { - /* - * Exit with no operands; push an empty one. - */ - - depth = curr_bb->finalStackDepth + curr_bb->initialStackDepth; - if (depth == 0) { - /* - * Emit a 'push' of the empty literal. - */ - - litIndex = TclRegisterNewLiteral(envPtr, "", 0); - - /* - * Assumes that 'push' is at slot 0 in TalInstructionTable. - */ - - BBEmitInst1or4(assemEnvPtr, 0, litIndex, 0); - ++depth; - } - - /* - * Exit with unbalanced stack. - */ - - if (depth != 1) { - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "stack is unbalanced on exit from the code (depth=%d)", - depth)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL); - } - return TCL_ERROR; - } - - /* - * Record stack usage. - */ - - envPtr->currStackDepth += depth; - } - - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * ProcessCatches -- - * - * First pass of 'catch' processing. - * - * Results: - * Returns a standard Tcl result, with an appropriate error message if - * the result is TCL_ERROR. - * - * Side effects: - * Labels all basic blocks with their enclosing catches. - * - *----------------------------------------------------------------------------- - */ - -static int -ProcessCatches( - AssemblyEnv* assemEnvPtr) /* Assembly environment */ -{ - BasicBlock* blockPtr; /* Pointer to a basic block */ - - /* - * Clear the catch state of all basic blocks. - */ - - for (blockPtr = assemEnvPtr->head_bb; - blockPtr != NULL; - blockPtr = blockPtr->successor1) { - blockPtr->catchState = BBCS_UNKNOWN; - blockPtr->enclosingCatch = NULL; - } - - /* - * Start the check recursively from the first basic block, which is - * outside any exception context - */ - - if (ProcessCatchesInBasicBlock(assemEnvPtr, assemEnvPtr->head_bb, - NULL, BBCS_NONE, 0) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Check for unclosed catch on exit. - */ - - if (CheckForUnclosedCatches(assemEnvPtr) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Now there's enough information to build the exception ranges. - */ - - if (BuildExceptionRanges(assemEnvPtr) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Finally, restore any exception ranges from embedded scripts. - */ - - RestoreEmbeddedExceptionRanges(assemEnvPtr); - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * ProcessCatchesInBasicBlock -- - * - * First-pass catch processing for one basic block. - * - * Results: - * Returns a standard Tcl result, with error message in the interpreter - * result if an error occurs. - * - * This procedure checks consistency of the exception context through the - * assembler program, and records the enclosing 'catch' for every basic block. - * - *----------------------------------------------------------------------------- - */ - -static int -ProcessCatchesInBasicBlock( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - BasicBlock* bbPtr, /* Basic block being processed */ - BasicBlock* enclosing, /* Start basic block of the enclosing catch */ - enum BasicBlockCatchState state, - /* BBCS_NONE, BBCS_INCATCH, or BBCS_CAUGHT */ - int catchDepth) /* Depth of nesting of catches */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - int result; /* Return value from this procedure */ - BasicBlock* fallThruEnclosing; - /* Enclosing catch if execution falls thru */ - enum BasicBlockCatchState fallThruState; - /* Catch state of the successor block */ - BasicBlock* jumpEnclosing; /* Enclosing catch if execution goes to jump - * target */ - enum BasicBlockCatchState jumpState; - /* Catch state of the jump target */ - int changed = 0; /* Flag == 1 iff successor blocks need to be - * checked because the state of this block has - * changed. */ - BasicBlock* jumpTarget; /* Basic block where a jump goes */ - Tcl_HashSearch jtSearch; /* Hash search control for a jumptable */ - Tcl_HashEntry* jtEntry; /* Entry in a jumptable */ - Tcl_Obj* targetLabel; /* Target label from a jumptable */ - Tcl_HashEntry* entry; /* Entry from the label table */ - - /* - * Update the state of the current block, checking for consistency. Set - * 'changed' to 1 if the state changes and successor blocks need to be - * rechecked. - */ - - if (bbPtr->catchState == BBCS_UNKNOWN) { - bbPtr->enclosingCatch = enclosing; - } else if (bbPtr->enclosingCatch != enclosing) { - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "execution reaches an instruction in inconsistent " - "exception contexts", -1)); - Tcl_SetErrorLine(interp, bbPtr->startLine); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADCATCH", NULL); - } - return TCL_ERROR; - } - if (state > bbPtr->catchState) { - bbPtr->catchState = state; - changed = 1; - } - - /* - * If this block has been visited before, and its state hasn't changed, - * we're done with it for now. - */ - - if (!changed) { - return TCL_OK; - } - bbPtr->catchDepth = catchDepth; - - /* - * Determine enclosing catch and 'caught' state for the fallthrough and - * the jump target. Default for both is the state of the current block. - */ - - fallThruEnclosing = enclosing; - fallThruState = state; - jumpEnclosing = enclosing; - jumpState = state; - - /* - * TODO: Make sure that the test cases include validating that a natural - * loop can't include 'beginCatch' or 'endCatch' - */ - - if (bbPtr->flags & BB_BEGINCATCH) { - /* - * If the block begins a catch, the state for the successor is 'in - * catch'. The jump target is the exception exit, and the state of the - * jump target is 'caught.' - */ - - fallThruEnclosing = bbPtr; - fallThruState = BBCS_INCATCH; - jumpEnclosing = bbPtr; - jumpState = BBCS_CAUGHT; - ++catchDepth; - } - - if (bbPtr->flags & BB_ENDCATCH) { - /* - * If the block ends a catch, the state for the successor is whatever - * the state was on entry to the catch. - */ - - if (enclosing == NULL) { - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "endCatch without a corresponding beginCatch", -1)); - Tcl_SetErrorLine(interp, bbPtr->startLine); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADENDCATCH", NULL); - } - return TCL_ERROR; - } - fallThruEnclosing = enclosing->enclosingCatch; - fallThruState = enclosing->catchState; - --catchDepth; - } - - /* - * Visit any successor blocks with the appropriate exception context - */ - - result = TCL_OK; - if (bbPtr->flags & BB_FALLTHRU) { - result = ProcessCatchesInBasicBlock(assemEnvPtr, bbPtr->successor1, - fallThruEnclosing, fallThruState, catchDepth); - } - if (result == TCL_OK && bbPtr->jumpTarget != NULL) { - entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(bbPtr->jumpTarget)); - jumpTarget = Tcl_GetHashValue(entry); - result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget, - jumpEnclosing, jumpState, catchDepth); - } - - /* - * All blocks referenced in a jump table are successors. - */ - - if (bbPtr->flags & BB_JUMPTABLE) { - for (jtEntry = Tcl_FirstHashEntry(&bbPtr->jtPtr->hashTable,&jtSearch); - result == TCL_OK && jtEntry != NULL; - jtEntry = Tcl_NextHashEntry(&jtSearch)) { - targetLabel = Tcl_GetHashValue(jtEntry); - entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(targetLabel)); - jumpTarget = Tcl_GetHashValue(entry); - result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget, - jumpEnclosing, jumpState, catchDepth); - } - } - - return result; -} - -/* - *----------------------------------------------------------------------------- - * - * CheckForUnclosedCatches -- - * - * Checks that a sequence of assembly code has no unclosed catches on - * exit. - * - * Results: - * Returns a standard Tcl result, with an error message for unclosed - * catches. - * - *----------------------------------------------------------------------------- - */ - -static int -CheckForUnclosedCatches( - AssemblyEnv* assemEnvPtr) /* Assembly environment */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - - if (assemEnvPtr->curr_bb->catchState >= BBCS_INCATCH) { - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "catch still active on exit from assembly code", -1)); - Tcl_SetErrorLine(interp, - assemEnvPtr->curr_bb->enclosingCatch->startLine); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "UNCLOSEDCATCH", NULL); - } - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * BuildExceptionRanges -- - * - * Walks through the assembly code and builds exception ranges for the - * catches embedded therein. - * - * Results: - * Returns a standard Tcl result with an error message in the interpreter - * if anything is unsuccessful. - * - * Side effects: - * Each contiguous block of code with a given catch exit is assigned an - * exception range at the appropriate level. - * Exception ranges in embedded blocks have their levels corrected and - * collated into the table. - * Blocks that end with 'beginCatch' are associated with the innermost - * exception range of the following block. - * - *----------------------------------------------------------------------------- - */ - -static int -BuildExceptionRanges( - AssemblyEnv* assemEnvPtr) /* Assembly environment */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - BasicBlock* bbPtr; /* Current basic block */ - BasicBlock* prevPtr = NULL; /* Previous basic block */ - int catchDepth = 0; /* Current catch depth */ - int maxCatchDepth = 0; /* Maximum catch depth in the program */ - BasicBlock** catches; /* Stack of catches in progress */ - int* catchIndices; /* Indices of the exception ranges of catches - * in progress */ - int i; - - /* - * Determine the max catch depth for the entire assembly script - * (excluding embedded eval's and expr's, which will be handled later). - */ - - for (bbPtr=assemEnvPtr->head_bb; bbPtr != NULL; bbPtr=bbPtr->successor1) { - if (bbPtr->catchDepth > maxCatchDepth) { - maxCatchDepth = bbPtr->catchDepth; - } - } - - /* - * Allocate memory for a stack of active catches. - */ - - catches = ckalloc(maxCatchDepth * sizeof(BasicBlock*)); - catchIndices = ckalloc(maxCatchDepth * sizeof(int)); - for (i = 0; i < maxCatchDepth; ++i) { - catches[i] = NULL; - catchIndices[i] = -1; - } - - /* - * Walk through the basic blocks and manage exception ranges. - */ - - for (bbPtr=assemEnvPtr->head_bb; bbPtr != NULL; bbPtr=bbPtr->successor1) { - UnstackExpiredCatches(envPtr, bbPtr, catchDepth, catches, - catchIndices); - LookForFreshCatches(bbPtr, catches); - StackFreshCatches(assemEnvPtr, bbPtr, catchDepth, catches, - catchIndices); - - /* - * If the last block was a 'begin catch', fill in the exception range. - */ - - catchDepth = bbPtr->catchDepth; - if (prevPtr != NULL && (prevPtr->flags & BB_BEGINCATCH)) { - TclStoreInt4AtPtr(catchIndices[catchDepth-1], - envPtr->codeStart + bbPtr->startOffset - 4); - } - - prevPtr = bbPtr; - } - - /* Make sure that all catches are closed */ - - if (catchDepth != 0) { - Tcl_Panic("unclosed catch at end of code in " - "tclAssembly.c:BuildExceptionRanges, can't happen"); - } - - /* Free temp storage */ - - ckfree(catchIndices); - ckfree(catches); - - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * UnstackExpiredCatches -- - * - * Unstacks and closes the exception ranges for any catch contexts that - * were active in the previous basic block but are inactive in the - * current one. - * - *----------------------------------------------------------------------------- - */ - -static void -UnstackExpiredCatches( - CompileEnv* envPtr, /* Compilation environment */ - BasicBlock* bbPtr, /* Basic block being processed */ - int catchDepth, /* Depth of nesting of catches prior to entry - * to this block */ - BasicBlock** catches, /* Array of catch contexts */ - int* catchIndices) /* Indices of the exception ranges - * corresponding to the catch contexts */ -{ - ExceptionRange* range; /* Exception range for a specific catch */ - BasicBlock* catch; /* Catch block being examined */ - BasicBlockCatchState catchState; - /* State of the code relative to the catch - * block being examined ("in catch" or - * "caught"). */ - - /* - * Unstack any catches that are deeper than the nesting level of the basic - * block being entered. - */ - - while (catchDepth > bbPtr->catchDepth) { - --catchDepth; - range = envPtr->exceptArrayPtr + catchIndices[catchDepth]; - range->numCodeBytes = bbPtr->startOffset - range->codeOffset; - catches[catchDepth] = NULL; - catchIndices[catchDepth] = -1; - } - - /* - * Unstack any catches that don't match the basic block being entered, - * either because they are no longer part of the context, or because the - * context has changed from INCATCH to CAUGHT. - */ - - catchState = bbPtr->catchState; - catch = bbPtr->enclosingCatch; - while (catchDepth > 0) { - --catchDepth; - if (catches[catchDepth] != NULL) { - if (catches[catchDepth] != catch || catchState >= BBCS_CAUGHT) { - range = envPtr->exceptArrayPtr + catchIndices[catchDepth]; - range->numCodeBytes = bbPtr->startOffset - range->codeOffset; - catches[catchDepth] = NULL; - catchIndices[catchDepth] = -1; - } - catchState = catch->catchState; - catch = catch->enclosingCatch; - } - } -} - -/* - *----------------------------------------------------------------------------- - * - * LookForFreshCatches -- - * - * Determines whether a basic block being entered needs any exception - * ranges that are not already stacked. - * - * Does not create the ranges: this procedure iterates from the innermost - * catch outward, but exception ranges must be created from the outermost - * catch inward. - * - *----------------------------------------------------------------------------- - */ - -static void -LookForFreshCatches( - BasicBlock* bbPtr, /* Basic block being entered */ - BasicBlock** catches) /* Array of catch contexts that are already - * entered */ -{ - BasicBlockCatchState catchState; - /* State ("in catch" or "caught") of the - * current catch. */ - BasicBlock* catch; /* Current enclosing catch */ - int catchDepth; /* Nesting depth of the current catch */ - - catchState = bbPtr->catchState; - catch = bbPtr->enclosingCatch; - catchDepth = bbPtr->catchDepth; - while (catchDepth > 0) { - --catchDepth; - if (catches[catchDepth] != catch && catchState < BBCS_CAUGHT) { - catches[catchDepth] = catch; - } - catchState = catch->catchState; - catch = catch->enclosingCatch; - } -} - -/* - *----------------------------------------------------------------------------- - * - * StackFreshCatches -- - * - * Make ExceptionRange records for any catches that are in the basic - * block being entered and were not in the previous basic block. - * - *----------------------------------------------------------------------------- - */ - -static void -StackFreshCatches( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - BasicBlock* bbPtr, /* Basic block being processed */ - int catchDepth, /* Depth of nesting of catches prior to entry - * to this block */ - BasicBlock** catches, /* Array of catch contexts */ - int* catchIndices) /* Indices of the exception ranges - * corresponding to the catch contexts */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - ExceptionRange* range; /* Exception range for a specific catch */ - BasicBlock* catch; /* Catch block being examined */ - BasicBlock* errorExit; /* Error exit from the catch block */ - Tcl_HashEntry* entryPtr; - - catchDepth = 0; - - /* - * Iterate through the enclosing catch blocks from the outside in, - * looking for ones that don't have exception ranges (and are uncaught) - */ - - for (catchDepth = 0; catchDepth < bbPtr->catchDepth; ++catchDepth) { - if (catchIndices[catchDepth] == -1 && catches[catchDepth] != NULL) { - /* - * Create an exception range for a block that needs one. - */ - - catch = catches[catchDepth]; - catchIndices[catchDepth] = - TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - range = envPtr->exceptArrayPtr + catchIndices[catchDepth]; - range->nestingLevel = envPtr->exceptDepth + catchDepth; - envPtr->maxExceptDepth = - TclMax(range->nestingLevel + 1, envPtr->maxExceptDepth); - range->codeOffset = bbPtr->startOffset; - - entryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(catch->jumpTarget)); - if (entryPtr == NULL) { - Tcl_Panic("undefined label in tclAssembly.c:" - "BuildExceptionRanges, can't happen"); - } - - errorExit = Tcl_GetHashValue(entryPtr); - range->catchOffset = errorExit->startOffset; - } - } -} - -/* - *----------------------------------------------------------------------------- - * - * RestoreEmbeddedExceptionRanges -- - * - * Processes an assembly script, replacing any exception ranges that - * were present in embedded code. - * - *----------------------------------------------------------------------------- - */ - -static void -RestoreEmbeddedExceptionRanges( - AssemblyEnv* assemEnvPtr) /* Assembly environment */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - BasicBlock* bbPtr; /* Current basic block */ - int rangeBase; /* Base of the foreign exception ranges when - * they are reinstalled */ - int rangeIndex; /* Index of the current foreign exception - * range as reinstalled */ - ExceptionRange* range; /* Current foreign exception range */ - unsigned char opcode; /* Current instruction's opcode */ - int catchIndex; /* Index of the exception range to which the - * current instruction refers */ - int i; - - /* - * Walk the basic blocks looking for exceptions in embedded scripts. - */ - - for (bbPtr = assemEnvPtr->head_bb; - bbPtr != NULL; - bbPtr = bbPtr->successor1) { - if (bbPtr->foreignExceptionCount != 0) { - /* - * Reinstall the embedded exceptions and track their nesting level - */ - - rangeBase = envPtr->exceptArrayNext; - for (i = 0; i < bbPtr->foreignExceptionCount; ++i) { - range = bbPtr->foreignExceptions + i; - rangeIndex = TclCreateExceptRange(range->type, envPtr); - range->nestingLevel += envPtr->exceptDepth + bbPtr->catchDepth; - memcpy(envPtr->exceptArrayPtr + rangeIndex, range, - sizeof(ExceptionRange)); - if (range->nestingLevel >= envPtr->maxExceptDepth) { - envPtr->maxExceptDepth = range->nestingLevel + 1; - } - } - - /* - * Walk through the bytecode of the basic block, and relocate - * INST_BEGIN_CATCH4 instructions to the new locations - */ - - i = bbPtr->startOffset; - while (i < bbPtr->successor1->startOffset) { - opcode = envPtr->codeStart[i]; - if (opcode == INST_BEGIN_CATCH4) { - catchIndex = TclGetUInt4AtPtr(envPtr->codeStart + i + 1); - if (catchIndex >= bbPtr->foreignExceptionBase - && catchIndex < (bbPtr->foreignExceptionBase + - bbPtr->foreignExceptionCount)) { - catchIndex -= bbPtr->foreignExceptionBase; - catchIndex += rangeBase; - TclStoreInt4AtPtr(catchIndex, envPtr->codeStart+i+1); - } - } - i += tclInstructionTable[opcode].numBytes; - } - } - } -} - -/* - *----------------------------------------------------------------------------- - * - * ResetVisitedBasicBlocks -- - * - * Turns off the 'visited' flag in all basic blocks at the conclusion - * of a pass. - * - *----------------------------------------------------------------------------- - */ - -static void -ResetVisitedBasicBlocks( - AssemblyEnv* assemEnvPtr) /* Assembly environment */ -{ - BasicBlock* block; - - for (block = assemEnvPtr->head_bb; block != NULL; - block = block->successor1) { - block->flags &= ~BB_VISITED; - } -} - -/* - *----------------------------------------------------------------------------- - * - * AddBasicBlockRangeToErrorInfo -- - * - * Updates the error info of the Tcl interpreter to show a given basic - * block in the code. - * - * This procedure is used to label the callstack with source location - * information when reporting an error in stack checking. - * - *----------------------------------------------------------------------------- - */ - -static void -AddBasicBlockRangeToErrorInfo( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - BasicBlock* bbPtr) /* Basic block in which the error is found */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - Tcl_Obj* lineNo; /* Line number in the source */ - - Tcl_AddErrorInfo(interp, "\n in assembly code between lines "); - lineNo = Tcl_NewIntObj(bbPtr->startLine); - Tcl_IncrRefCount(lineNo); - Tcl_AddErrorInfo(interp, Tcl_GetString(lineNo)); - Tcl_AddErrorInfo(interp, " and "); - if (bbPtr->successor1 != NULL) { - Tcl_SetIntObj(lineNo, bbPtr->successor1->startLine); - Tcl_AddErrorInfo(interp, Tcl_GetString(lineNo)); - } else { - Tcl_AddErrorInfo(interp, "end of assembly code"); - } - Tcl_DecrRefCount(lineNo); -} - -/* - *----------------------------------------------------------------------------- - * - * DupAssembleCodeInternalRep -- - * - * Part of the Tcl object type implementation for Tcl assembly language - * bytecode. We do not copy the bytecode intrep. Instead, we return - * without setting copyPtr->typePtr, so the copy is a plain string copy - * of the assembly source, and if it is to be used as a compiled - * expression, it will need to be reprocessed. - * - * This makes sense, because with Tcl's copy-on-write practices, the - * usual (only?) time Tcl_DuplicateObj() will be called is when the copy - * is about to be modified, which would invalidate any copied bytecode - * anyway. The only reason it might make sense to copy the bytecode is if - * we had some modifying routines that operated directly on the intrep, - * as we do for lists and dicts. - * - * Results: - * None. - * - * Side effects: - * None. - * - *----------------------------------------------------------------------------- - */ - -static void -DupAssembleCodeInternalRep( - Tcl_Obj *srcPtr, - Tcl_Obj *copyPtr) -{ - return; -} - -/* - *----------------------------------------------------------------------------- - * - * FreeAssembleCodeInternalRep -- - * - * Part of the Tcl object type implementation for Tcl expression - * bytecode. Frees the storage allocated to hold the internal rep, unless - * ref counts indicate bytecode execution is still in progress. - * - * Results: - * None. - * - * Side effects: - * May free allocated memory. Leaves objPtr untyped. - * - *----------------------------------------------------------------------------- - */ - -static void -FreeAssembleCodeInternalRep( - Tcl_Obj *objPtr) -{ - ByteCode *codePtr = objPtr->internalRep.otherValuePtr; - - codePtr->refCount--; - if (codePtr->refCount <= 0) { - TclCleanupByteCode(codePtr); - } - objPtr->typePtr = NULL; - objPtr->internalRep.otherValuePtr = NULL; -} - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ diff --git a/generic/tclBasic.c b/generic/tclBasic.c index fca5855..a32247b 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -206,7 +206,6 @@ typedef struct { const char *name; /* Name of object-based command. */ Tcl_ObjCmdProc *objProc; /* Object-based function for command. */ CompileProc *compileProc; /* Function called to compile command. */ - Tcl_ObjCmdProc *nreProc; /* NR-based function for command */ int isSafe; /* If non-zero, command will be present in * safe interpreter. Otherwise it will be * hidden. */ @@ -221,96 +220,93 @@ static const CmdInfo builtInCmds[] = { * Commands in the generic core. */ - {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, 1}, - {"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, 1}, - {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, 1}, -#ifndef EXCLUDE_OBSOLETE_COMMANDS - {"case", Tcl_CaseObjCmd, NULL, NULL, 1}, -#endif - {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, 1}, - {"concat", Tcl_ConcatObjCmd, NULL, NULL, 1}, - {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, 1}, - {"coroutine", NULL, NULL, TclNRCoroutineObjCmd, 1}, - {"error", Tcl_ErrorObjCmd, TclCompileErrorCmd, NULL, 1}, - {"eval", Tcl_EvalObjCmd, NULL, TclNREvalObjCmd, 1}, - {"expr", Tcl_ExprObjCmd, TclCompileExprCmd, TclNRExprObjCmd, 1}, - {"for", Tcl_ForObjCmd, TclCompileForCmd, TclNRForObjCmd, 1}, - {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, TclNRForeachCmd, 1}, - {"format", Tcl_FormatObjCmd, TclCompileFormatCmd, NULL, 1}, - {"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, NULL, 1}, - {"if", Tcl_IfObjCmd, TclCompileIfCmd, TclNRIfObjCmd, 1}, - {"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, NULL, 1}, - {"join", Tcl_JoinObjCmd, NULL, NULL, 1}, - {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, NULL, 1}, - {"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, NULL, 1}, - {"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, 1}, - {"linsert", Tcl_LinsertObjCmd, NULL, NULL, 1}, - {"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, 1}, - {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, 1}, - {"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, 1}, - {"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, NULL, 1}, - {"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, 1}, - {"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, 1}, - {"lreverse", Tcl_LreverseObjCmd, NULL, NULL, 1}, - {"lsearch", Tcl_LsearchObjCmd, NULL, NULL, 1}, - {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, 1}, - {"lsort", Tcl_LsortObjCmd, NULL, NULL, 1}, - {"package", Tcl_PackageObjCmd, NULL, NULL, 1}, - {"proc", Tcl_ProcObjCmd, NULL, NULL, 1}, - {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, 1}, - {"regsub", Tcl_RegsubObjCmd, TclCompileRegsubCmd, NULL, 1}, - {"rename", Tcl_RenameObjCmd, NULL, NULL, 1}, - {"return", Tcl_ReturnObjCmd, TclCompileReturnCmd, NULL, 1}, - {"scan", Tcl_ScanObjCmd, NULL, NULL, 1}, - {"set", Tcl_SetObjCmd, TclCompileSetCmd, NULL, 1}, - {"split", Tcl_SplitObjCmd, NULL, NULL, 1}, - {"subst", Tcl_SubstObjCmd, TclCompileSubstCmd, TclNRSubstObjCmd, 1}, - {"switch", Tcl_SwitchObjCmd, TclCompileSwitchCmd, TclNRSwitchObjCmd, 1}, - {"tailcall", NULL, TclCompileTailcallCmd, TclNRTailcallObjCmd, 1}, - {"throw", Tcl_ThrowObjCmd, TclCompileThrowCmd, NULL, 1}, - {"trace", Tcl_TraceObjCmd, NULL, NULL, 1}, - {"try", Tcl_TryObjCmd, TclCompileTryCmd, TclNRTryObjCmd, 1}, - {"unset", Tcl_UnsetObjCmd, TclCompileUnsetCmd, NULL, 1}, - {"uplevel", Tcl_UplevelObjCmd, NULL, TclNRUplevelObjCmd, 1}, - {"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, NULL, 1}, - {"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, NULL, 1}, - {"while", Tcl_WhileObjCmd, TclCompileWhileCmd, TclNRWhileObjCmd, 1}, - {"yield", NULL, TclCompileYieldCmd, TclNRYieldObjCmd, 1}, - {"yieldto", NULL, NULL, TclNRYieldToObjCmd, 1}, + {"append", Tcl_AppendObjCmd, NULL, 1}, + {"apply", Tcl_ApplyObjCmd, NULL, 1}, + {"break", Tcl_BreakObjCmd, NULL, 1}, + {"catch", Tcl_CatchObjCmd, NULL, 1}, + {"concat", Tcl_ConcatObjCmd, NULL, 1}, + {"continue", Tcl_ContinueObjCmd, NULL, 1}, + {"coroutine", TclNRCoroutineObjCmd, NULL, 1}, + {"error", Tcl_ErrorObjCmd, NULL, 1}, + {"eval", Tcl_EvalObjCmd, NULL, 1}, + {"expr", Tcl_ExprObjCmd, NULL, 1}, + {"for", Tcl_ForObjCmd, NULL, 1}, + {"foreach", Tcl_ForeachObjCmd, NULL, 1}, + {"format", Tcl_FormatObjCmd, NULL, 1}, + {"global", Tcl_GlobalObjCmd, NULL, 1}, + {"if", Tcl_IfObjCmd, NULL, 1}, + {"incr", Tcl_IncrObjCmd, NULL, 1}, + {"join", Tcl_JoinObjCmd, NULL, 1}, + {"lappend", Tcl_LappendObjCmd, NULL, 1}, + {"lassign", Tcl_LassignObjCmd, NULL, 1}, + {"lindex", Tcl_LindexObjCmd, NULL, 1}, + {"linsert", Tcl_LinsertObjCmd, NULL, 1}, + {"list", Tcl_ListObjCmd, NULL, 1}, + {"llength", Tcl_LlengthObjCmd, NULL, 1}, + {"lmap", Tcl_LmapObjCmd, NULL, 1}, + {"lrange", Tcl_LrangeObjCmd, NULL, 1}, + {"lrepeat", Tcl_LrepeatObjCmd, NULL, 1}, + {"lreplace", Tcl_LreplaceObjCmd, NULL, 1}, + {"lreverse", Tcl_LreverseObjCmd, NULL, 1}, + {"lsearch", Tcl_LsearchObjCmd, NULL, 1}, + {"lset", Tcl_LsetObjCmd, NULL, 1}, + {"lsort", Tcl_LsortObjCmd, NULL, 1}, + {"package", Tcl_PackageObjCmd, NULL, 1}, + {"proc", Tcl_ProcObjCmd, NULL, 1}, + {"regexp", Tcl_RegexpObjCmd, NULL, 1}, + {"regsub", Tcl_RegsubObjCmd, NULL, 1}, + {"rename", Tcl_RenameObjCmd, NULL, 1}, + {"return", Tcl_ReturnObjCmd, NULL, 1}, + {"scan", Tcl_ScanObjCmd, NULL, 1}, + {"set", Tcl_SetObjCmd, NULL, 1}, + {"split", Tcl_SplitObjCmd, NULL, 1}, + {"subst", Tcl_SubstObjCmd, NULL, 1}, + {"switch", Tcl_SwitchObjCmd, NULL, 1}, + {"tailcall", TclNRTailcallObjCmd, NULL, 1}, + {"throw", Tcl_ThrowObjCmd, NULL, 1}, + {"trace", Tcl_TraceObjCmd, NULL, 1}, + {"try", Tcl_TryObjCmd, NULL, 1}, + {"unset", Tcl_UnsetObjCmd, NULL, 1}, + {"uplevel", Tcl_UplevelObjCmd, NULL, 1}, + {"upvar", Tcl_UpvarObjCmd, NULL, 1}, + {"variable", Tcl_VariableObjCmd, NULL, 1}, + {"while", Tcl_WhileObjCmd, NULL, 1}, + {"yield", TclNRYieldObjCmd, NULL, 1}, + {"yieldto", TclNRYieldToObjCmd, NULL, 1}, /* * Commands in the OS-interface. Note that many of these are unsafe. */ - {"after", Tcl_AfterObjCmd, NULL, NULL, 1}, - {"cd", Tcl_CdObjCmd, NULL, NULL, 0}, - {"close", Tcl_CloseObjCmd, NULL, NULL, 1}, - {"eof", Tcl_EofObjCmd, NULL, NULL, 1}, - {"encoding", Tcl_EncodingObjCmd, NULL, NULL, 0}, - {"exec", Tcl_ExecObjCmd, NULL, NULL, 0}, - {"exit", Tcl_ExitObjCmd, NULL, NULL, 0}, - {"fblocked", Tcl_FblockedObjCmd, NULL, NULL, 1}, - {"fconfigure", Tcl_FconfigureObjCmd, NULL, NULL, 0}, - {"fcopy", Tcl_FcopyObjCmd, NULL, NULL, 1}, - {"fileevent", Tcl_FileEventObjCmd, NULL, NULL, 1}, - {"flush", Tcl_FlushObjCmd, NULL, NULL, 1}, - {"gets", Tcl_GetsObjCmd, NULL, NULL, 1}, - {"glob", Tcl_GlobObjCmd, NULL, NULL, 0}, - {"load", Tcl_LoadObjCmd, NULL, NULL, 0}, - {"open", Tcl_OpenObjCmd, NULL, NULL, 0}, - {"pid", Tcl_PidObjCmd, NULL, NULL, 1}, - {"puts", Tcl_PutsObjCmd, NULL, NULL, 1}, - {"pwd", Tcl_PwdObjCmd, NULL, NULL, 0}, - {"read", Tcl_ReadObjCmd, NULL, NULL, 1}, - {"seek", Tcl_SeekObjCmd, NULL, NULL, 1}, - {"socket", Tcl_SocketObjCmd, NULL, NULL, 0}, - {"source", Tcl_SourceObjCmd, NULL, TclNRSourceObjCmd, 0}, - {"tell", Tcl_TellObjCmd, NULL, NULL, 1}, - {"time", Tcl_TimeObjCmd, NULL, NULL, 1}, - {"unload", Tcl_UnloadObjCmd, NULL, NULL, 0}, - {"update", Tcl_UpdateObjCmd, NULL, NULL, 1}, - {"vwait", Tcl_VwaitObjCmd, NULL, NULL, 1}, - {NULL, NULL, NULL, NULL, 0} + {"after", Tcl_AfterObjCmd, NULL, 1}, + {"cd", Tcl_CdObjCmd, NULL, 0}, + {"close", Tcl_CloseObjCmd, NULL, 1}, + {"eof", Tcl_EofObjCmd, NULL, 1}, + {"encoding", Tcl_EncodingObjCmd, NULL, 0}, + {"exec", Tcl_ExecObjCmd, NULL, 0}, + {"exit", Tcl_ExitObjCmd, NULL, 0}, + {"fblocked", Tcl_FblockedObjCmd, NULL, 1}, + {"fconfigure", Tcl_FconfigureObjCmd, NULL, 0}, + {"fcopy", Tcl_FcopyObjCmd, NULL, 1}, + {"fileevent", Tcl_FileEventObjCmd, NULL, 1}, + {"flush", Tcl_FlushObjCmd, NULL, 1}, + {"gets", Tcl_GetsObjCmd, NULL, 1}, + {"glob", Tcl_GlobObjCmd, NULL, 0}, + {"load", Tcl_LoadObjCmd, NULL, 0}, + {"open", Tcl_OpenObjCmd, NULL, 0}, + {"pid", Tcl_PidObjCmd, NULL, 1}, + {"puts", Tcl_PutsObjCmd, NULL, 1}, + {"pwd", Tcl_PwdObjCmd, NULL, 0}, + {"read", Tcl_ReadObjCmd, NULL, 1}, + {"seek", Tcl_SeekObjCmd, NULL, 1}, + {"socket", Tcl_SocketObjCmd, NULL, 0}, + {"source", Tcl_SourceObjCmd, NULL, 0}, + {"tell", Tcl_TellObjCmd, NULL, 1}, + {"time", Tcl_TimeObjCmd, NULL, 1}, + {"unload", Tcl_UnloadObjCmd, NULL, 0}, + {"update", Tcl_UpdateObjCmd, NULL, 1}, + {"vwait", Tcl_VwaitObjCmd, NULL, 1}, + {NULL, NULL, NULL, 0} }; /* @@ -484,25 +480,12 @@ Tcl_CreateInterp(void) char c[sizeof(short)]; short s; } order; -#ifdef TCL_COMPILE_STATS - ByteCodeStats *statsPtr; -#endif /* TCL_COMPILE_STATS */ char mathFuncName[32]; CallFrame *framePtr; int result; TclInitSubsystems(); - /* - * Panic if someone updated the CallFrame structure without also updating - * the Tcl_CallFrame structure (or vice versa). - */ - - if (sizeof(Tcl_CallFrame) < sizeof(CallFrame)) { - /*NOTREACHED*/ - Tcl_Panic("Tcl_CallFrame must not be smaller than CallFrame"); - } - if (cancelTableInitialized == 0) { Tcl_MutexLock(&cancelLock); if (cancelTableInitialized == 0) { @@ -567,7 +550,6 @@ Tcl_CreateInterp(void) iPtr->cmdCount = 0; TclInitLiteralTable(&iPtr->literalTable); - iPtr->compileEpoch = 0; iPtr->compiledProcPtr = NULL; iPtr->resolverPtr = NULL; iPtr->evalFlags = 0; @@ -611,13 +593,11 @@ Tcl_CreateInterp(void) } /* - * Initialise the rootCallframe. It cannot be allocated on the stack, as - * it has to be in place before TclCreateExecEnv tries to use a variable. + * Initialise the rootCallframe. */ /* This is needed to satisfy GCC 3.3's strict aliasing rules */ - framePtr = ckalloc(sizeof(CallFrame)); - result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr, + result = TclPushStackFrame(interp, &framePtr, (Tcl_Namespace *) iPtr->globalNsPtr, /*isProcCallFrame*/ 0); if (result != TCL_OK) { Tcl_Panic("Tcl_CreateInterp: failed to push the root stack frame"); @@ -663,39 +643,6 @@ Tcl_CreateInterp(void) Tcl_MutexUnlock(&cancelLock); /* - * Initialize the compilation and execution statistics kept for this - * interpreter. - */ - -#ifdef TCL_COMPILE_STATS - statsPtr = &iPtr->stats; - statsPtr->numExecutions = 0; - statsPtr->numCompilations = 0; - statsPtr->numByteCodesFreed = 0; - memset(statsPtr->instructionCount, 0, - sizeof(statsPtr->instructionCount)); - - statsPtr->totalSrcBytes = 0.0; - statsPtr->totalByteCodeBytes = 0.0; - statsPtr->currentSrcBytes = 0.0; - statsPtr->currentByteCodeBytes = 0.0; - memset(statsPtr->srcCount, 0, sizeof(statsPtr->srcCount)); - memset(statsPtr->byteCodeCount, 0, sizeof(statsPtr->byteCodeCount)); - memset(statsPtr->lifetimeCount, 0, sizeof(statsPtr->lifetimeCount)); - - statsPtr->currentInstBytes = 0.0; - statsPtr->currentLitBytes = 0.0; - statsPtr->currentExceptBytes = 0.0; - statsPtr->currentAuxBytes = 0.0; - statsPtr->currentCmdMapBytes = 0.0; - - statsPtr->numLiteralsCreated = 0; - statsPtr->totalLitStringBytes = 0.0; - statsPtr->currentLitStringBytes = 0.0; - memset(statsPtr->literalCount, 0, sizeof(statsPtr->literalCount)); -#endif /* TCL_COMPILE_STATS */ - - /* * Initialise the stub table pointer. */ @@ -720,12 +667,6 @@ Tcl_CreateInterp(void) * cache was already initialised by the call to alloc the interp struct. */ -#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) - iPtr->allocCache = TclpGetAllocCache(); -#else - iPtr->allocCache = NULL; -#endif - iPtr->pendingObjDataPtr = NULL; iPtr->asyncReadyPtr = TclGetAsyncReadyPtr(); iPtr->deferredCallbacks = NULL; @@ -733,44 +674,22 @@ Tcl_CreateInterp(void) TclInvalidateStringRep(iPtr->cmdSourcePtr); /* - * Create the core commands. Do it here, rather than calling - * Tcl_CreateCommand, because it's faster (there's no need to check for a - * pre-existing command by the same name). If a command has a Tcl_CmdProc - * but no Tcl_ObjCmdProc, set the Tcl_ObjCmdProc to - * TclInvokeStringCommand. This is an object-based wrapper function that - * extracts strings, calls the string function, and creates an object for - * the result. Similarly, if a command has a Tcl_ObjCmdProc but no - * Tcl_CmdProc, set the Tcl_CmdProc to TclInvokeObjectCommand. + * Create the core commands by calling Tcl_CreateCommand. + * + * FIXME! do it directly for faster interp creation */ for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) { + Command *cmdPtr; + if ((cmdInfoPtr->objProc == NULL) - && (cmdInfoPtr->compileProc == NULL) - && (cmdInfoPtr->nreProc == NULL)) { + && (cmdInfoPtr->compileProc == NULL)) { Tcl_Panic("builtin command with NULL object command proc and a NULL compile proc"); } - hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable, - cmdInfoPtr->name, &isNew); - if (isNew) { - cmdPtr = ckalloc(sizeof(Command)); - cmdPtr->hPtr = hPtr; - cmdPtr->nsPtr = iPtr->globalNsPtr; - cmdPtr->refCount = 1; - cmdPtr->cmdEpoch = 0; - cmdPtr->compileProc = cmdInfoPtr->compileProc; - cmdPtr->proc = TclInvokeObjectCommand; - cmdPtr->clientData = cmdPtr; - cmdPtr->objProc = cmdInfoPtr->objProc; - cmdPtr->objClientData = NULL; - cmdPtr->deleteProc = NULL; - cmdPtr->deleteData = NULL; - cmdPtr->flags = 0; - cmdPtr->importRefPtr = NULL; - cmdPtr->tracePtr = NULL; - cmdPtr->nreProc = cmdInfoPtr->nreProc; - Tcl_SetHashValue(hPtr, cmdPtr); - } + cmdPtr = (Command *) Tcl_CreateObjCommand(interp, cmdInfoPtr->name, cmdInfoPtr->objProc, + NULL, NULL); + cmdPtr->compileProc = cmdInfoPtr->compileProc; } /* @@ -814,18 +733,10 @@ Tcl_CreateInterp(void) * Create unsupported commands for debugging bytecode and objects. */ - Tcl_CreateObjCommand(interp, "::tcl::unsupported::disassemble", - Tcl_DisassembleObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "::tcl::unsupported::representation", Tcl_RepresentationCmd, NULL, NULL); - /* Adding the bytecode assembler command */ - cmdPtr = (Command *) Tcl_NRCreateCommand(interp, - "::tcl::unsupported::assemble", Tcl_AssembleObjCmd, - TclNRAssembleObjCmd, NULL, NULL); - cmdPtr->compileProc = &TclCompileAssembleCmd; - - Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL, + Tcl_CreateObjCommand(interp, "::tcl::unsupported::inject", NRCoroInjectObjCmd, NULL, NULL); #ifdef USE_DTRACE @@ -1304,7 +1215,6 @@ Tcl_DeleteInterp( */ iPtr->flags |= DELETED; - iPtr->compileEpoch++; /* * Ensure that the interpreter is eventually deleted. @@ -1475,8 +1385,7 @@ DeleteInterpProc( if ((iPtr->framePtr != iPtr->rootFramePtr) && !TclInExit()) { Tcl_Panic("DeleteInterpProc: popping rootCallFrame with other frames on top"); } - Tcl_PopCallFrame(interp); - ckfree(iPtr->rootFramePtr); + TclPopStackFrame(interp); iPtr->rootFramePtr = NULL; Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr); @@ -1703,18 +1612,6 @@ Tcl_HideCommand( cmdPtr->hPtr = hPtr; Tcl_SetHashValue(hPtr, cmdPtr); - /* - * If the command being hidden has a compile function, increment the - * interpreter's compileEpoch to invalidate its compiled code. This makes - * sure that we don't later try to execute old code compiled with - * command-specific (i.e., inline) bytecodes for the now-hidden command. - * This field is checked in Tcl_EvalObj and ObjInterpProc, and code whose - * compilation epoch doesn't match is recompiled. - */ - - if (cmdPtr->compileProc != NULL) { - iPtr->compileEpoch++; - } return TCL_OK; } @@ -1874,18 +1771,6 @@ Tcl_ExposeCommand( * TclResetShadowedCmdRefs(interp, cmdPtr); */ - /* - * If the command being exposed has a compile function, increment - * interpreter's compileEpoch to invalidate its compiled code. This makes - * sure that we don't later try to execute old code compiled assuming the - * command is hidden. This field is checked in Tcl_EvalObj and - * ObjInterpProc, and code whose compilation epoch doesn't match is - * recompiled. - */ - - if (cmdPtr->compileProc != NULL) { - iPtr->compileEpoch++; - } return TCL_OK; } @@ -2023,7 +1908,6 @@ Tcl_CreateCommand( cmdPtr->flags = 0; cmdPtr->importRefPtr = NULL; cmdPtr->tracePtr = NULL; - cmdPtr->nreProc = NULL; /* * Plug in any existing import references found above. Be sure to update @@ -2207,7 +2091,6 @@ Tcl_CreateObjCommand( cmdPtr->flags = 0; cmdPtr->importRefPtr = NULL; cmdPtr->tracePtr = NULL; - cmdPtr->nreProc = NULL; /* * Plug in any existing import references found above. Be sure to update @@ -2265,8 +2148,7 @@ TclInvokeStringCommand( { Command *cmdPtr = clientData; int i, result; - const char **argv = - TclStackAlloc(interp, (unsigned)(objc + 1) * sizeof(char *)); + const char **argv = ckalloc((unsigned)(objc + 1) * sizeof(char *)); for (i = 0; i < objc; i++) { argv[i] = Tcl_GetString(objv[i]); @@ -2279,7 +2161,7 @@ TclInvokeStringCommand( result = cmdPtr->proc(cmdPtr->clientData, interp, objc, argv); - TclStackFree(interp, (void *) argv); + ckfree((void *) argv); return result; } @@ -2314,8 +2196,7 @@ TclInvokeObjectCommand( Command *cmdPtr = clientData; Tcl_Obj *objPtr; int i, length, result; - Tcl_Obj **objv = - TclStackAlloc(interp, (unsigned)(argc * sizeof(Tcl_Obj *))); + Tcl_Obj **objv = ckalloc((unsigned)(argc * sizeof(Tcl_Obj *))); for (i = 0; i < argc; i++) { length = strlen(argv[i]); @@ -2328,12 +2209,8 @@ TclInvokeObjectCommand( * Invoke the command's object-based Tcl_ObjCmdProc. */ - if (cmdPtr->objProc != NULL) { - result = cmdPtr->objProc(cmdPtr->objClientData, interp, argc, objv); - } else { - result = Tcl_NRCallObjProc(interp, cmdPtr->nreProc, - cmdPtr->objClientData, argc, objv); - } + result = Tcl_NRCallObjProc(interp, cmdPtr->objProc, + cmdPtr->objClientData, argc, objv); /* * Move the interpreter's object result to the string result, then reset @@ -2351,7 +2228,7 @@ TclInvokeObjectCommand( objPtr = objv[i]; Tcl_DecrRefCount(objPtr); } - TclStackFree(interp, objv); + ckfree(objv); return result; } @@ -2537,17 +2414,6 @@ TclRenameCommand( cmdPtr->cmdEpoch++; /* - * If the command being renamed has a compile function, increment the - * interpreter's compileEpoch to invalidate its compiled code. This makes - * sure that we don't later try to execute old code compiled for the - * now-renamed command. - */ - - if (cmdPtr->compileProc != NULL) { - iPtr->compileEpoch++; - } - - /* * Now free the Command structure, if the "oldName" command has been * deleted by invocation of rename traces. */ @@ -2563,176 +2429,6 @@ TclRenameCommand( /* *---------------------------------------------------------------------- * - * Tcl_SetCommandInfo -- - * - * Modifies various information about a Tcl command. Note that this - * function will not change a command's namespace; use TclRenameCommand - * to do that. Also, the isNativeObjectProc member of *infoPtr is - * ignored. - * - * Results: - * If cmdName exists in interp, then the information at *infoPtr is - * stored with the command in place of the current information and 1 is - * returned. If the command doesn't exist then 0 is returned. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_SetCommandInfo( - Tcl_Interp *interp, /* Interpreter in which to look for - * command. */ - const char *cmdName, /* Name of desired command. */ - const Tcl_CmdInfo *infoPtr) /* Where to find information to store in the - * command. */ -{ - Tcl_Command cmd; - - cmd = Tcl_FindCommand(interp, cmdName, NULL, /*flags*/ 0); - return Tcl_SetCommandInfoFromToken(cmd, infoPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetCommandInfoFromToken -- - * - * Modifies various information about a Tcl command. Note that this - * function will not change a command's namespace; use TclRenameCommand - * to do that. Also, the isNativeObjectProc member of *infoPtr is - * ignored. - * - * Results: - * If cmdName exists in interp, then the information at *infoPtr is - * stored with the command in place of the current information and 1 is - * returned. If the command doesn't exist then 0 is returned. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_SetCommandInfoFromToken( - Tcl_Command cmd, - const Tcl_CmdInfo *infoPtr) -{ - Command *cmdPtr; /* Internal representation of the command */ - - if (cmd == NULL) { - return 0; - } - - /* - * The isNativeObjectProc and nsPtr members of *infoPtr are ignored. - */ - - cmdPtr = (Command *) cmd; - cmdPtr->proc = infoPtr->proc; - cmdPtr->clientData = infoPtr->clientData; - if (infoPtr->objProc == NULL) { - cmdPtr->objProc = TclInvokeStringCommand; - cmdPtr->objClientData = cmdPtr; - cmdPtr->nreProc = NULL; - } else { - if (infoPtr->objProc != cmdPtr->objProc) { - cmdPtr->nreProc = NULL; - cmdPtr->objProc = infoPtr->objProc; - } - cmdPtr->objClientData = infoPtr->objClientData; - } - cmdPtr->deleteProc = infoPtr->deleteProc; - cmdPtr->deleteData = infoPtr->deleteData; - return 1; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetCommandInfo -- - * - * Returns various information about a Tcl command. - * - * Results: - * If cmdName exists in interp, then *infoPtr is modified to hold - * information about cmdName and 1 is returned. If the command doesn't - * exist then 0 is returned and *infoPtr isn't modified. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GetCommandInfo( - Tcl_Interp *interp, /* Interpreter in which to look for - * command. */ - const char *cmdName, /* Name of desired command. */ - Tcl_CmdInfo *infoPtr) /* Where to store information about - * command. */ -{ - Tcl_Command cmd; - - cmd = Tcl_FindCommand(interp, cmdName, NULL, /*flags*/ 0); - return Tcl_GetCommandInfoFromToken(cmd, infoPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetCommandInfoFromToken -- - * - * Returns various information about a Tcl command. - * - * Results: - * Copies information from the command identified by 'cmd' into a - * caller-supplied structure and returns 1. If the 'cmd' is NULL, leaves - * the structure untouched and returns 0. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GetCommandInfoFromToken( - Tcl_Command cmd, - Tcl_CmdInfo *infoPtr) -{ - Command *cmdPtr; /* Internal representation of the command */ - - if (cmd == NULL) { - return 0; - } - - /* - * Set isNativeObjectProc 1 if objProc was registered by a call to - * Tcl_CreateObjCommand. Otherwise set it to 0. - */ - - cmdPtr = (Command *) cmd; - infoPtr->isNativeObjectProc = - (cmdPtr->objProc != TclInvokeStringCommand); - infoPtr->objProc = cmdPtr->objProc; - infoPtr->objClientData = cmdPtr->objClientData; - infoPtr->proc = cmdPtr->proc; - infoPtr->clientData = cmdPtr->clientData; - infoPtr->deleteProc = cmdPtr->deleteProc; - infoPtr->deleteData = cmdPtr->deleteData; - infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr; - - return 1; -} - -/* - *---------------------------------------------------------------------- - * * Tcl_GetCommandName -- * * Given a token returned by Tcl_CreateCommand, this function returns the @@ -2964,19 +2660,6 @@ Tcl_DeleteCommandFromToken( TclInvalidateNsCmdLookup(cmdPtr->nsPtr); - /* - * If the command being deleted has a compile function, increment the - * interpreter's compileEpoch to invalidate its compiled code. This makes - * sure that we don't later try to execute old code compiled with - * command-specific (i.e., inline) bytecodes for the now-deleted command. - * This field is checked in Tcl_EvalObj and ObjInterpProc, and code whose - * compilation epoch doesn't match is recompiled. - */ - - if (cmdPtr->compileProc != NULL) { - iPtr->compileEpoch++; - } - if (cmdPtr->deleteProc != NULL) { /* * Delete the command's client data. If this was an imported command @@ -4188,18 +3871,12 @@ TclNREvalObjv( cmdPtr->refCount++; /* - * Find the objProc to call: nreProc if available, objProc otherwise. Push - * a callback to do the actual running. + * Find the objProc to call, push a callback to do the actual running. */ - if (cmdPtr->nreProc) { - TclNRAddCallback(interp, NRRunObjProc, cmdPtr, - INT2PTR(objc), (ClientData) objv, NULL); - - return TCL_OK; - } else { - return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); - } + TclNRAddCallback(interp, NRRunObjProc, cmdPtr, + INT2PTR(objc), (ClientData) objv, NULL); + return TCL_OK; } int @@ -4207,24 +3884,9 @@ TclNRRunCallbacks( Tcl_Interp *interp, int result) /* Callbacks are run until the first NRRoot.*/ { - Interp *iPtr = (Interp *) interp; NRE_callback *cbPtr; Tcl_NRPostProc *procPtr; - /* - * If the interpreter has a non-empty string result, the result object is - * either empty or stale because some function set interp->result - * directly. If so, move the string result to the result object, then - * reset the string result. - * - * This only needs to be done for the first item in the list: all other - * are for NR function calls, and those are Tcl_Obj based. - */ - - if (*(iPtr->result) != 0) { - (void) Tcl_GetObjResult(interp); - } - while (TOP_CB(interp) && (TOP_CB(interp)->procPtr != NRRoot)) { POP_CB(interp, cbPtr); procPtr = cbPtr->procPtr; @@ -4317,7 +3979,7 @@ NRRunObjProc( int objc = PTR2INT(data[1]); Tcl_Obj **objv = data[2]; - return cmdPtr->nreProc(cmdPtr->objClientData, interp, objc, objv); + return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); } @@ -4497,7 +4159,7 @@ TEOV_NotFound( Tcl_ListObjGetElements(NULL, currNsPtr->unknownHandlerPtr, &handlerObjc, &handlerObjv); newObjc = objc + handlerObjc; - newObjv = TclStackAlloc(interp, (int) sizeof(Tcl_Obj *) * newObjc); + newObjv = ckalloc((int) sizeof(Tcl_Obj *) * newObjc); /* * Copy command prefix from unknown handler and add on the real command's @@ -4536,7 +4198,7 @@ TEOV_NotFound( for (i = 0; i < handlerObjc; ++i) { Tcl_DecrRefCount(newObjv[i]); } - TclStackFree(interp, newObjv); + ckfree(newObjv); return TCL_ERROR; } @@ -4574,7 +4236,7 @@ TEOV_NotFoundCallback( for (i = 0; i < objc; ++i) { Tcl_DecrRefCount(objv[i]); } - TclStackFree(interp, objv); + ckfree(objv); return result; } @@ -4836,10 +4498,10 @@ Tcl_EvalEx( * state has been allocated while evaluating * the script, so that it can be freed * properly if an error occurs. */ - Tcl_Parse *parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse)); + Tcl_Parse *parsePtr = ckalloc(sizeof(Tcl_Parse)); Tcl_Obj **stackObjArray = - TclStackAlloc(interp, minObjs * sizeof(Tcl_Obj *)); - int *expandStack = TclStackAlloc(interp, minObjs * sizeof(int)); + ckalloc(minObjs * sizeof(Tcl_Obj *)); + int *expandStack = ckalloc(minObjs * sizeof(int)); if (numBytes < 0) { numBytes = strlen(script); @@ -5066,9 +4728,9 @@ Tcl_EvalEx( iPtr->varFramePtr = savedVarFramePtr; cleanup_return: - TclStackFree(interp, expandStack); - TclStackFree(interp, stackObjArray); - TclStackFree(interp, parsePtr); + ckfree(expandStack); + ckfree(stackObjArray); + ckfree(parsePtr); return code; } @@ -5116,45 +4778,11 @@ Tcl_Eval( /* *---------------------------------------------------------------------- * - * Tcl_EvalObj, Tcl_GlobalEvalObj -- - * - * These functions are deprecated but we keep them around for backwards - * compatibility reasons. - * - * Results: - * See the functions they call. - * - * Side effects: - * See the functions they call. - * - *---------------------------------------------------------------------- - */ - -#undef Tcl_EvalObj -int -Tcl_EvalObj( - Tcl_Interp *interp, - Tcl_Obj *objPtr) -{ - return Tcl_EvalObjEx(interp, objPtr, 0); -} -#undef Tcl_GlobalEvalObj -int -Tcl_GlobalEvalObj( - Tcl_Interp *interp, - Tcl_Obj *objPtr) -{ - return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL); -} - -/* - *---------------------------------------------------------------------- - * * Tcl_EvalObjEx, TclEvalObjEx -- * * Execute Tcl commands stored in a Tcl object. These commands are - * compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT is - * specified. + * compiled into bytecodes, or run directly if the obj is a canonical + * list. * * Results: * The return value is one of the return codes defined in tcl.h (such as @@ -5177,7 +4805,7 @@ Tcl_EvalObjEx( * execute. */ int flags) /* Collection of OR-ed bits that control the * evaluation of the script. Supported values - * are TCL_EVAL_GLOBAL and TCL_EVAL_DIRECT. */ + * are TCL_EVAL_GLOBAL. */ { int result = TCL_OK; @@ -5194,10 +4822,9 @@ TclNREvalObjEx( * execute. */ int flags) /* Collection of OR-ed bits that control the * evaluation of the script. Supported values - * are TCL_EVAL_GLOBAL and TCL_EVAL_DIRECT. */ + * are TCL_EVAL_GLOBAL. */ { Interp *iPtr = (Interp *) interp; - int result; /* * This function consists of three independent blocks for: direct @@ -5246,15 +4873,13 @@ TclNREvalObjEx( ListObjGetElements(listPtr, objc, objv); return TclNREvalObjv(interp, objc, objv, flags, NULL); - } - - if (!(flags & TCL_EVAL_DIRECT)) { + } else { /* * Let the compiler/engine subsystem do the evaluation. */ int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); - ByteCode *codePtr; + struct ByteCode *codePtr; CallFrame *savedVarFramePtr = NULL; /* Saves old copy of * iPtr->varFramePtr in case * TCL_EVAL_GLOBAL was set. */ @@ -5273,24 +4898,6 @@ TclNREvalObjEx( objPtr, INT2PTR(allowExceptions), NULL); return TclNRExecuteByteCode(interp, codePtr); } - - { - /* - * We're not supposed to use the compiler or byte-code - * interpreter. Let Tcl_EvalEx evaluate the command directly (and - * probably more slowly). - * - */ - - const char *script; - int numSrcBytes; - - Tcl_IncrRefCount(objPtr); - script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); - result = Tcl_EvalEx(interp, script, numSrcBytes, flags); - TclDecrRefCount(objPtr); - return result; - } } static int @@ -5662,7 +5269,7 @@ TclObjInvokeNamespace( * or TCL_INVOKE_NO_TRACEBACK. */ { int result; - Tcl_CallFrame *framePtr; + CallFrame *framePtr; /* * Make the specified namespace the current namespace and invoke the @@ -5752,12 +5359,8 @@ TclObjInvoke( */ iPtr->cmdCount++; - if (cmdPtr->objProc != NULL) { - result = cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); - } else { - result = Tcl_NRCallObjProc(interp, cmdPtr->nreProc, - cmdPtr->objClientData, objc, objv); - } + result = Tcl_NRCallObjProc(interp, cmdPtr->objProc, + cmdPtr->objClientData, objc, objv); /* * If an error occurred, record information about what was being executed @@ -7192,60 +6795,6 @@ Tcl_NRCallObjProc( return TclNRRunCallbacks(interp, result); } -/* - *---------------------------------------------------------------------- - * - * Tcl_NRCreateCommand -- - * - * Define a new NRE-enabled object-based command in a command table. - * - * Results: - * The return value is a token for the command, which can be used in - * future calls to Tcl_GetCommandName. - * - * Side effects: - * If no command named "cmdName" already exists for interp, one is - * created. Otherwise, if a command does exist, then if the object-based - * Tcl_ObjCmdProc is TclInvokeStringCommand, we assume Tcl_CreateCommand - * was called previously for the same command and just set its - * Tcl_ObjCmdProc to the argument "proc"; otherwise, we delete the old - * command. - * - * In the future, during bytecode evaluation when "cmdName" is seen as - * the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based - * Tcl_ObjCmdProc proc will be called. When the command is deleted from - * the table, deleteProc will be called. See the manual entry for details - * on the calling sequence. - * - *---------------------------------------------------------------------- - */ - -Tcl_Command -Tcl_NRCreateCommand( - Tcl_Interp *interp, /* Token for command interpreter (returned by - * previous call to Tcl_CreateInterp). */ - const char *cmdName, /* Name of command. If it contains namespace - * qualifiers, the new command is put in the - * specified namespace; otherwise it is put in - * the global namespace. */ - Tcl_ObjCmdProc *proc, /* Object-based function to associate with - * name, provides direct access for direct - * calls. */ - Tcl_ObjCmdProc *nreProc, /* Object-based function to associate with - * name, provides NR implementation */ - ClientData clientData, /* Arbitrary value to pass to object - * function. */ - Tcl_CmdDeleteProc *deleteProc) - /* If not NULL, gives a function to call when - * this command is deleted. */ -{ - Command *cmdPtr = (Command *) - Tcl_CreateObjCommand(interp,cmdName,proc,clientData,deleteProc); - - cmdPtr->nreProc = nreProc; - return (Tcl_Command) cmdPtr; -} - /**************************************************************************** * Stuff for the public api ****************************************************************************/ @@ -7939,7 +7488,7 @@ NRCoroInjectObjCmd( } cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]); - if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) { + if ((!cmdPtr) || (cmdPtr->deleteProc != DeleteCoroutine)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "can only inject a command into a coroutine", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE", @@ -8096,8 +7645,8 @@ TclNRCoroutineObjCmd( } Tcl_DStringAppend(&ds, procName, -1); - cmdPtr = (Command *) Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), - /*objProc*/ NULL, TclNRInterpCoroutine, corPtr, DeleteCoroutine); + cmdPtr = (Command *) Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds), + TclNRInterpCoroutine, corPtr, DeleteCoroutine); Tcl_DStringFree(&ds); corPtr->cmdPtr = cmdPtr; diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 455b5a6..babd725 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -132,23 +132,23 @@ static const char B64Digits[65] = { */ static const EnsembleImplMap binaryMap[] = { - { "format", BinaryFormatCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0 }, - { "scan", BinaryScanCmd, TclCompileBasicMin2ArgCmd, NULL, NULL, 0 }, - { "encode", NULL, NULL, NULL, NULL, 0 }, - { "decode", NULL, NULL, NULL, NULL, 0 }, - { NULL, NULL, NULL, NULL, NULL, 0 } + { "format", BinaryFormatCmd, NULL, NULL, 0 }, + { "scan", BinaryScanCmd, NULL, NULL, 0 }, + { "encode", NULL, NULL, NULL, 0 }, + { "decode", NULL, NULL, NULL, 0 }, + { NULL, NULL, NULL, NULL, 0 } }; static const EnsembleImplMap encodeMap[] = { - { "hex", BinaryEncodeHex, TclCompileBasic1ArgCmd, NULL, (ClientData)HexDigits, 0 }, - { "uuencode", BinaryEncode64, NULL, NULL, (ClientData)UueDigits, 0 }, - { "base64", BinaryEncode64, NULL, NULL, (ClientData)B64Digits, 0 }, - { NULL, NULL, NULL, NULL, NULL, 0 } + { "hex", BinaryEncodeHex, NULL, (ClientData)HexDigits, 0 }, + { "uuencode", BinaryEncode64, NULL, (ClientData)UueDigits, 0 }, + { "base64", BinaryEncode64, NULL, (ClientData)B64Digits, 0 }, + { NULL, NULL, NULL, NULL, 0 } }; static const EnsembleImplMap decodeMap[] = { - { "hex", BinaryDecodeHex, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 }, - { "uuencode", BinaryDecodeUu, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 }, - { "base64", BinaryDecode64, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 }, - { NULL, NULL, NULL, NULL, NULL, 0 } + { "hex", BinaryDecodeHex, NULL, NULL, 0 }, + { "uuencode", BinaryDecodeUu, NULL, NULL, 0 }, + { "base64", BinaryDecode64, NULL, NULL, 0 }, + { NULL, NULL, NULL, NULL, 0 } }; /* diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index ab977cb..2973678 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -1307,10 +1307,6 @@ TclFinalizeMemorySubsystem(void) Tcl_MutexUnlock(ckallocMutexPtr); #endif - -#if USE_TCLALLOC - TclFinalizeAllocSubsystem(); -#endif } /* diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 7e22f7c..775e421 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -132,143 +132,6 @@ Tcl_BreakObjCmd( /* *---------------------------------------------------------------------- * - * Tcl_CaseObjCmd -- - * - * This procedure is invoked to process the "case" Tcl command. See the - * user documentation for details on what it does. THIS COMMAND IS - * OBSOLETE AND DEPRECATED. SLATED FOR REMOVAL IN TCL 9.0. - * - * Results: - * A standard Tcl object result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -int -Tcl_CaseObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - register int i; - int body, result, caseObjc; - const char *stringPtr, *arg; - Tcl_Obj *const *caseObjv; - Tcl_Obj *armPtr; - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, - "string ?in? ?pattern body ...? ?default body?"); - return TCL_ERROR; - } - - stringPtr = TclGetString(objv[1]); - body = -1; - - arg = TclGetString(objv[2]); - if (strcmp(arg, "in") == 0) { - i = 3; - } else { - i = 2; - } - caseObjc = objc - i; - caseObjv = objv + i; - - /* - * If all of the pattern/command pairs are lumped into a single argument, - * split them out again. - */ - - if (caseObjc == 1) { - Tcl_Obj **newObjv; - - TclListObjGetElements(interp, caseObjv[0], &caseObjc, &newObjv); - caseObjv = newObjv; - } - - for (i = 0; i < caseObjc; i += 2) { - int patObjc, j; - const char **patObjv; - const char *pat; - unsigned char *p; - - if (i == caseObjc-1) { - Tcl_ResetResult(interp); - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "extra case pattern with no body", -1)); - return TCL_ERROR; - } - - /* - * Check for special case of single pattern (no list) with no - * backslash sequences. - */ - - pat = TclGetString(caseObjv[i]); - for (p = (unsigned char *) pat; *p != '\0'; p++) { - if (isspace(*p) || (*p == '\\')) { /* INTL: ISO space, UCHAR */ - break; - } - } - if (*p == '\0') { - if ((*pat == 'd') && (strcmp(pat, "default") == 0)) { - body = i + 1; - } - if (Tcl_StringMatch(stringPtr, pat)) { - body = i + 1; - goto match; - } - continue; - } - - /* - * Break up pattern lists, then check each of the patterns in the - * list. - */ - - result = Tcl_SplitList(interp, pat, &patObjc, &patObjv); - if (result != TCL_OK) { - return result; - } - for (j = 0; j < patObjc; j++) { - if (Tcl_StringMatch(stringPtr, patObjv[j])) { - body = i + 1; - break; - } - } - ckfree(patObjv); - if (j < patObjc) { - break; - } - } - - match: - if (body != -1) { - armPtr = caseObjv[body - 1]; - result = Tcl_EvalObjEx(interp, caseObjv[body], 0); - if (result == TCL_ERROR) { - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"%.50s\" arm line %d)", - TclGetString(armPtr), Tcl_GetErrorLine(interp))); - } - return result; - } - - /* - * Nothing matched: return nothing. - */ - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * * Tcl_CatchObjCmd -- * * This object-based procedure is invoked to process the "catch" Tcl @@ -291,16 +154,6 @@ Tcl_CatchObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - return Tcl_NRCallObjProc(interp, TclNRCatchObjCmd, dummy, objc, objv); -} - -int -TclNRCatchObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ Tcl_Obj *varNamePtr = NULL; Tcl_Obj *optionVarNamePtr = NULL; @@ -744,16 +597,6 @@ Tcl_EvalObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - return Tcl_NRCallObjProc(interp, TclNREvalObjCmd, dummy, objc, objv); -} - -int -TclNREvalObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ register Tcl_Obj *objPtr; if (objc < 2) { @@ -850,16 +693,6 @@ Tcl_ExprObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - return Tcl_NRCallObjProc(interp, TclNRExprObjCmd, dummy, objc, objv); -} - -int -TclNRExprObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ Tcl_Obj *resultPtr, *objPtr; if (objc < 2) { @@ -932,41 +765,41 @@ TclInitFileCmd( */ static const EnsembleImplMap initMap[] = { - {"atime", FileAttrAccessTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {"attributes", TclFileAttrsCmd, NULL, NULL, NULL, 0}, - {"channels", TclChannelNamesCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, - {"copy", TclFileCopyCmd, NULL, NULL, NULL, 0}, - {"delete", TclFileDeleteCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, - {"dirname", PathDirNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"executable", FileAttrIsExecutableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"exists", FileAttrIsExistingCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"extension", PathExtensionCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"isdirectory", FileAttrIsDirectoryCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"isfile", FileAttrIsFileCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"join", PathJoinCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, - {"link", TclFileLinkCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, - {"lstat", FileAttrLinkStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"mtime", FileAttrModifyTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {"mkdir", TclFileMakeDirsCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, - {"nativename", PathNativeNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"normalize", PathNormalizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"owned", FileAttrIsOwnedCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"pathtype", PathTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"readable", FileAttrIsReadableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"readlink", TclFileReadLinkCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"rename", TclFileRenameCmd, NULL, NULL, NULL, 0}, - {"rootname", PathRootNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"separator", FilesystemSeparatorCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, - {"size", FileAttrSizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"split", PathSplitCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"stat", FileAttrStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"system", PathFilesystemCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, - {"tail", PathTailCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"tempfile", TclFileTemporaryCmd, TclCompileBasic0To2ArgCmd, NULL, NULL, 0}, - {"type", FileAttrTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"volumes", FilesystemVolumesCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, - {"writable", FileAttrIsWritableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {NULL, NULL, NULL, NULL, NULL, 0} + {"atime", FileAttrAccessTimeCmd, NULL, NULL, 0}, + {"attributes", TclFileAttrsCmd, NULL, NULL, 0}, + {"channels", TclChannelNamesCmd, NULL, NULL, 0}, + {"copy", TclFileCopyCmd, NULL, NULL, 0}, + {"delete", TclFileDeleteCmd, NULL, NULL, 0}, + {"dirname", PathDirNameCmd, NULL, NULL, 0}, + {"executable", FileAttrIsExecutableCmd, NULL, NULL, 0}, + {"exists", FileAttrIsExistingCmd, NULL, NULL, 0}, + {"extension", PathExtensionCmd, NULL, NULL, 0}, + {"isdirectory", FileAttrIsDirectoryCmd, NULL, NULL, 0}, + {"isfile", FileAttrIsFileCmd, NULL, NULL, 0}, + {"join", PathJoinCmd, NULL, NULL, 0}, + {"link", TclFileLinkCmd, NULL, NULL, 0}, + {"lstat", FileAttrLinkStatCmd, NULL, NULL, 0}, + {"mtime", FileAttrModifyTimeCmd, NULL, NULL, 0}, + {"mkdir", TclFileMakeDirsCmd, NULL, NULL, 0}, + {"nativename", PathNativeNameCmd, NULL, NULL, 0}, + {"normalize", PathNormalizeCmd, NULL, NULL, 0}, + {"owned", FileAttrIsOwnedCmd, NULL, NULL, 0}, + {"pathtype", PathTypeCmd, NULL, NULL, 0}, + {"readable", FileAttrIsReadableCmd, NULL, NULL, 0}, + {"readlink", TclFileReadLinkCmd, NULL, NULL, 0}, + {"rename", TclFileRenameCmd, NULL, NULL, 0}, + {"rootname", PathRootNameCmd, NULL, NULL, 0}, + {"separator", FilesystemSeparatorCmd, NULL, NULL, 0}, + {"size", FileAttrSizeCmd, NULL, NULL, 0}, + {"split", PathSplitCmd, NULL, NULL, 0}, + {"stat", FileAttrStatCmd, NULL, NULL, 0}, + {"system", PathFilesystemCmd, NULL, NULL, 0}, + {"tail", PathTailCmd, NULL, NULL, 0}, + {"tempfile", TclFileTemporaryCmd, NULL, NULL, 0}, + {"type", FileAttrTypeCmd, NULL, NULL, 0}, + {"volumes", FilesystemVolumesCmd, NULL, NULL, 0}, + {"writable", FileAttrIsWritableCmd, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, 0} }; return TclMakeEnsemble(interp, "file", initMap); } @@ -2380,16 +2213,6 @@ Tcl_ForObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - return Tcl_NRCallObjProc(interp, TclNRForObjCmd, dummy, objc, objv); -} - -int -TclNRForObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ ForIterData *iterPtr; if (objc != 5) { @@ -2397,7 +2220,7 @@ TclNRForObjCmd( return TCL_ERROR; } - TclSmallAllocEx(interp, sizeof(ForIterData), iterPtr); + TclCkSmallAlloc(sizeof(ForIterData), iterPtr); iterPtr->cond = objv[2]; iterPtr->body = objv[4]; iterPtr->next = objv[3]; @@ -2419,7 +2242,7 @@ ForSetupCallback( if (result == TCL_ERROR) { Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)"); } - TclSmallFreeEx(interp, iterPtr); + TclSmallFree(iterPtr); return result; } Tcl_NRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL, NULL, NULL); @@ -2457,7 +2280,7 @@ TclNRForIterCallback( Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(iterPtr->msg, Tcl_GetErrorLine(interp))); } - TclSmallFreeEx(interp, iterPtr); + TclSmallFree(iterPtr); return result; } @@ -2473,11 +2296,11 @@ ForCondCallback( if (result != TCL_OK) { Tcl_DecrRefCount(boolObj); - TclSmallFreeEx(interp, iterPtr); + TclSmallFree(iterPtr); return result; } else if (Tcl_GetBooleanFromObj(interp, boolObj, &value) != TCL_OK) { Tcl_DecrRefCount(boolObj); - TclSmallFreeEx(interp, iterPtr); + TclSmallFree(iterPtr); return TCL_ERROR; } Tcl_DecrRefCount(boolObj); @@ -2492,7 +2315,7 @@ ForCondCallback( } return TclNREvalObjEx(interp, iterPtr->body, 0); } - TclSmallFreeEx(interp, iterPtr); + TclSmallFree(iterPtr); return result; } @@ -2526,7 +2349,7 @@ ForPostNextCallback( if ((result != TCL_BREAK) && (result != TCL_OK)) { if (result == TCL_ERROR) { Tcl_AddErrorInfo(interp, "\n (\"for\" loop-end command)"); - TclSmallFreeEx(interp, iterPtr); + TclSmallFree(iterPtr); } return result; } @@ -2537,7 +2360,7 @@ ForPostNextCallback( /* *---------------------------------------------------------------------- * - * Tcl_ForeachObjCmd, TclNRForeachCmd, EachloopCmd -- + * Tcl_ForeachObjCmd, EachloopCmd -- * * This object-based procedure is invoked to process the "foreach" Tcl * command. See the user documentation for details on what it does. @@ -2559,16 +2382,6 @@ Tcl_ForeachObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - return Tcl_NRCallObjProc(interp, TclNRForeachCmd, dummy, objc, objv); -} - -int -TclNRForeachCmd( - ClientData dummy, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ return EachloopCmd(interp, TCL_EACH_KEEP_NONE, objc, objv); } @@ -2579,16 +2392,6 @@ Tcl_LmapObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - return Tcl_NRCallObjProc(interp, TclNRLmapCmd, dummy, objc, objv); -} - -int -TclNRLmapCmd( - ClientData dummy, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ return EachloopCmd(interp, TCL_EACH_COLLECT, objc, objv); } @@ -2626,7 +2429,7 @@ EachloopCmd( * allocation for better performance. */ - statePtr = TclStackAlloc(interp, + statePtr = ckalloc( sizeof(struct ForeachState) + 3 * numLists * sizeof(int) + 2 * numLists * (sizeof(Tcl_Obj **) + sizeof(Tcl_Obj *))); memset(statePtr, 0, @@ -2847,7 +2650,7 @@ ForeachCleanup( if (statePtr->resultList != NULL) { TclDecrRefCount(statePtr->resultList); } - TclStackFree(interp, statePtr); + ckfree(statePtr); } /* diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 08e8445..ddab1fa 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -155,29 +155,29 @@ static Tcl_Obj * SelectObjFromSublist(Tcl_Obj *firstPtr, */ static const EnsembleImplMap defaultInfoMap[] = { - {"args", InfoArgsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"body", InfoBodyCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"cmdcount", InfoCmdCountCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, - {"commands", InfoCommandsCmd, TclCompileInfoCommandsCmd, NULL, NULL, 0}, - {"complete", InfoCompleteCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"coroutine", TclInfoCoroutineCmd, TclCompileInfoCoroutineCmd, NULL, NULL, 0}, - {"default", InfoDefaultCmd, TclCompileBasic3ArgCmd, NULL, NULL, 0}, - {"exists", TclInfoExistsCmd, TclCompileInfoExistsCmd, NULL, NULL, 0}, - {"functions", InfoFunctionsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, - {"globals", TclInfoGlobalsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, - {"hostname", InfoHostnameCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, - {"level", InfoLevelCmd, TclCompileInfoLevelCmd, NULL, NULL, 0}, - {"library", InfoLibraryCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, - {"loaded", InfoLoadedCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, - {"locals", TclInfoLocalsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, - {"nameofexecutable", InfoNameOfExecutableCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, - {"patchlevel", InfoPatchLevelCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, - {"procs", InfoProcsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, - {"script", InfoScriptCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, - {"sharedlibextension", InfoSharedlibCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, - {"tclversion", InfoTclVersionCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, - {"vars", TclInfoVarsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, - {NULL, NULL, NULL, NULL, NULL, 0} + {"args", InfoArgsCmd, NULL, NULL, 0}, + {"body", InfoBodyCmd, NULL, NULL, 0}, + {"cmdcount", InfoCmdCountCmd, NULL, NULL, 0}, + {"commands", InfoCommandsCmd, NULL, NULL, 0}, + {"complete", InfoCompleteCmd, NULL, NULL, 0}, + {"coroutine", TclInfoCoroutineCmd, NULL, NULL, 0}, + {"default", InfoDefaultCmd, NULL, NULL, 0}, + {"exists", TclInfoExistsCmd, NULL, NULL, 0}, + {"functions", InfoFunctionsCmd, NULL, NULL, 0}, + {"globals", TclInfoGlobalsCmd, NULL, NULL, 0}, + {"hostname", InfoHostnameCmd, NULL, NULL, 0}, + {"level", InfoLevelCmd, NULL, NULL, 0}, + {"library", InfoLibraryCmd, NULL, NULL, 0}, + {"loaded", InfoLoadedCmd, NULL, NULL, 0}, + {"locals", TclInfoLocalsCmd, NULL, NULL, 0}, + {"nameofexecutable", InfoNameOfExecutableCmd, NULL, NULL, 0}, + {"patchlevel", InfoPatchLevelCmd, NULL, NULL, 0}, + {"procs", InfoProcsCmd, NULL, NULL, 0}, + {"script", InfoScriptCmd, NULL, NULL, 0}, + {"sharedlibextension", InfoSharedlibCmd, NULL, NULL, 0}, + {"tclversion", InfoTclVersionCmd, NULL, NULL, 0}, + {"vars", TclInfoVarsCmd, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, 0} }; /* @@ -208,16 +208,6 @@ Tcl_IfObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - return Tcl_NRCallObjProc(interp, TclNRIfObjCmd, dummy, objc, objv); -} - -int -TclNRIfObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ Tcl_Obj *boolObj; if (objc <= 1) { @@ -2644,7 +2634,7 @@ Tcl_LsearchObjCmd( int j; if (sortInfo.indexc > 1) { - TclStackFree(interp, sortInfo.indexv); + ckfree(sortInfo.indexv); } if (i > objc-4) { if (startPtr != NULL) { @@ -2680,7 +2670,7 @@ Tcl_LsearchObjCmd( break; default: sortInfo.indexv = - TclStackAlloc(interp, sizeof(int) * sortInfo.indexc); + ckalloc(sizeof(int) * sortInfo.indexc); } /* @@ -2791,7 +2781,7 @@ Tcl_LsearchObjCmd( if (offset > listc-1) { if (sortInfo.indexc > 1) { - TclStackFree(interp, sortInfo.indexv); + ckfree(sortInfo.indexv); } if (allMatches || inlineReturn) { Tcl_ResetResult(interp); @@ -3116,7 +3106,7 @@ Tcl_LsearchObjCmd( done: if (sortInfo.indexc > 1) { - TclStackFree(interp, sortInfo.indexv); + ckfree(sortInfo.indexv); } return result; } @@ -3410,7 +3400,7 @@ Tcl_LsortObjCmd( break; default: sortInfo.indexv = - TclStackAlloc(interp, sizeof(int) * sortInfo.indexc); + ckalloc(sizeof(int) * sortInfo.indexc); allocatedIndexVector = 1; /* Cannot use indexc field, as it * might be decreased by 1 later. */ } @@ -3509,6 +3499,7 @@ Tcl_LsortObjCmd( /* * Do not shrink the actual memory block used; that doesn't * work with TclStackAlloc-allocated memory. [Bug 2918962] + * FIXME: TclStackAlloc is now retired, we could shrink it. */ for (i = 0; i < sortInfo.indexc; i++) { @@ -3546,7 +3537,7 @@ Tcl_LsortObjCmd( * begins sorting it into the sublists as it appears. */ - elementArray = TclStackAlloc(interp, length * sizeof(SortElement)); + elementArray = ckalloc(length * sizeof(SortElement)); for (i=0; i < length; i++){ idx = groupSize * i + groupOffset; @@ -3670,7 +3661,7 @@ Tcl_LsortObjCmd( } done1: - TclStackFree(interp, elementArray); + ckfree(elementArray); done: if (sortInfo.sortMode == SORTMODE_COMMAND) { @@ -3680,7 +3671,7 @@ Tcl_LsortObjCmd( } done2: if (allocatedIndexVector) { - TclStackFree(interp, sortInfo.indexv); + ckfree(sortInfo.indexv); } return sortInfo.resultCode; } diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 0be71d4..afe8378 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -977,16 +977,6 @@ Tcl_SourceObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - return Tcl_NRCallObjProc(interp, TclNRSourceObjCmd, dummy, objc, objv); -} - -int -TclNRSourceObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ const char *encodingName = NULL; Tcl_Obj *fileName; @@ -1902,7 +1892,7 @@ StringMapCmd( * adapt this code... */ - mapElemv = TclStackAlloc(interp, sizeof(Tcl_Obj *) * mapElemc); + mapElemv = ckalloc(sizeof(Tcl_Obj *) * mapElemc); Tcl_DictObjFirst(interp, objv[objc-2], &search, mapElemv+0, mapElemv+1, &done); for (i=2 ; i<mapElemc ; i+=2) { @@ -2013,10 +2003,10 @@ StringMapCmd( * case. */ - mapStrings = TclStackAlloc(interp, mapElemc*2*sizeof(Tcl_UniChar *)); - mapLens = TclStackAlloc(interp, mapElemc * 2 * sizeof(int)); + mapStrings = ckalloc(mapElemc*2*sizeof(Tcl_UniChar *)); + mapLens = ckalloc(mapElemc * 2 * sizeof(int)); if (nocase) { - u2lc = TclStackAlloc(interp, mapElemc * sizeof(Tcl_UniChar)); + u2lc = ckalloc(mapElemc * sizeof(Tcl_UniChar)); } for (index = 0; index < mapElemc; index++) { mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index], @@ -2066,10 +2056,10 @@ StringMapCmd( } } if (nocase) { - TclStackFree(interp, u2lc); + ckfree(u2lc); } - TclStackFree(interp, mapLens); - TclStackFree(interp, mapStrings); + ckfree(mapLens); + ckfree(mapStrings); } if (p != ustring1) { /* @@ -2081,7 +2071,7 @@ StringMapCmd( Tcl_SetObjResult(interp, resultPtr); done: if (mapWithDict) { - TclStackFree(interp, mapElemv); + ckfree(mapElemv); } if (copySource) { Tcl_DecrRefCount(sourceObj); @@ -3324,29 +3314,29 @@ TclInitStringCmd( Tcl_Interp *interp) /* Current interpreter. */ { static const EnsembleImplMap stringImplMap[] = { - {"bytelength", StringBytesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"compare", StringCmpCmd, TclCompileStringCmpCmd, NULL, NULL, 0}, - {"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0}, - {"first", StringFirstCmd, TclCompileStringFirstCmd, NULL, NULL, 0}, - {"index", StringIndexCmd, TclCompileStringIndexCmd, NULL, NULL, 0}, - {"is", StringIsCmd, NULL, NULL, NULL, 0}, - {"last", StringLastCmd, TclCompileStringLastCmd, NULL, NULL, 0}, - {"length", StringLenCmd, TclCompileStringLenCmd, NULL, NULL, 0}, - {"map", StringMapCmd, TclCompileStringMapCmd, NULL, NULL, 0}, - {"match", StringMatchCmd, TclCompileStringMatchCmd, NULL, NULL, 0}, - {"range", StringRangeCmd, TclCompileStringRangeCmd, NULL, NULL, 0}, - {"repeat", StringReptCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"replace", StringRplcCmd, NULL, NULL, NULL, 0}, - {"reverse", StringRevCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"tolower", StringLowerCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, - {"toupper", StringUpperCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, - {"totitle", StringTitleCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, - {"trim", StringTrimCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {"trimleft", StringTrimLCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {"trimright", StringTrimRCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {"wordend", StringEndCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"wordstart", StringStartCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {NULL, NULL, NULL, NULL, NULL, 0} + {"bytelength", StringBytesCmd, NULL, NULL, 0}, + {"compare", StringCmpCmd, NULL, NULL, 0}, + {"equal", StringEqualCmd, NULL, NULL, 0}, + {"first", StringFirstCmd, NULL, NULL, 0}, + {"index", StringIndexCmd, NULL, NULL, 0}, + {"is", StringIsCmd, NULL, NULL, 0}, + {"last", StringLastCmd, NULL, NULL, 0}, + {"length", StringLenCmd, NULL, NULL, 0}, + {"map", StringMapCmd, NULL, NULL, 0}, + {"match", StringMatchCmd, NULL, NULL, 0}, + {"range", StringRangeCmd, NULL, NULL, 0}, + {"repeat", StringReptCmd, NULL, NULL, 0}, + {"replace", StringRplcCmd, NULL, NULL, 0}, + {"reverse", StringRevCmd, NULL, NULL, 0}, + {"tolower", StringLowerCmd, NULL, NULL, 0}, + {"toupper", StringUpperCmd, NULL, NULL, 0}, + {"totitle", StringTitleCmd, NULL, NULL, 0}, + {"trim", StringTrimCmd, NULL, NULL, 0}, + {"trimleft", StringTrimLCmd, NULL, NULL, 0}, + {"trimright", StringTrimRCmd, NULL, NULL, 0}, + {"wordend", StringEndCmd, NULL, NULL, 0}, + {"wordstart", StringStartCmd, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, 0} }; return TclMakeEnsemble(interp, "string", stringImplMap); @@ -3417,28 +3407,58 @@ Tcl_SubstObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - return Tcl_NRCallObjProc(interp, TclNRSubstObjCmd, dummy, objc, objv); -} + static const char *substOptions[] = { + "-nobackslashes", "-nocommands", "-novariables", NULL + }; + enum substOptions { + SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS + }; + Tcl_Obj *resultPtr; + int flags, i; -int -TclNRSubstObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - int flags; + /* + * Parse command-line options. + */ - if (objc < 2) { + flags = TCL_SUBST_ALL; + for (i = 1; i < (objc-1); i++) { + int optionIndex; + + if (Tcl_GetIndexFromObj(interp, objv[i], substOptions, "switch", 0, + &optionIndex) != TCL_OK) { + return TCL_ERROR; + } + switch (optionIndex) { + case SUBST_NOBACKSLASHES: + flags &= ~TCL_SUBST_BACKSLASHES; + break; + case SUBST_NOCOMMANDS: + flags &= ~TCL_SUBST_COMMANDS; + break; + case SUBST_NOVARS: + flags &= ~TCL_SUBST_VARIABLES; + break; + default: + Tcl_Panic("Tcl_SubstObjCmd: bad option index to SubstOptions"); + } + } + if (i != objc-1) { Tcl_WrongNumArgs(interp, 1, objv, "?-nobackslashes? ?-nocommands? ?-novariables? string"); return TCL_ERROR; } - if (TclSubstOptions(interp, objc-2, objv+1, &flags) != TCL_OK) { + /* + * Perform the substitution. + */ + + resultPtr = Tcl_SubstObj(interp, objv[i], flags); + + if (resultPtr == NULL) { return TCL_ERROR; } - return Tcl_NRSubstObj(interp, objv[objc-1], flags); + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; } /* @@ -3465,15 +3485,6 @@ Tcl_SwitchObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - return Tcl_NRCallObjProc(interp, TclNRSwitchObjCmd, dummy, objc, objv); -} -int -TclNRSwitchObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ int i,j, index, mode, foundmode, splitObjs, numMatchesSaved; int noCase, patternLength; const char *pattern; @@ -4043,7 +4054,7 @@ Tcl_TimeObjCmd( /* *---------------------------------------------------------------------- * - * Tcl_TryObjCmd, TclNRTryObjCmd -- + * Tcl_TryObjCmd -- * * This procedure is invoked to process the "try" Tcl command. See the * user documentation (or TIP #329) for details on what it does. @@ -4059,17 +4070,7 @@ Tcl_TimeObjCmd( int Tcl_TryObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - return Tcl_NRCallObjProc(interp, TclNRTryObjCmd, dummy, objc, objv); -} - -int -TclNRTryObjCmd( - ClientData clientData, /* Not used. */ + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -4634,16 +4635,6 @@ Tcl_WhileObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - return Tcl_NRCallObjProc(interp, TclNRWhileObjCmd, dummy, objc, objv); -} - -int -TclNRWhileObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ ForIterData *iterPtr; if (objc != 3) { @@ -4655,7 +4646,7 @@ TclNRWhileObjCmd( * We reuse [for]'s callback, passing a NULL for the 'next' script. */ - TclSmallAllocEx(interp, sizeof(ForIterData), iterPtr); + TclCkSmallAlloc(sizeof(ForIterData), iterPtr); iterPtr->cond = objv[1]; iterPtr->body = objv[2]; iterPtr->next = NULL; diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index aebf649..ddde94f 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -14,40 +14,13 @@ */ #include "tclInt.h" -#include "tclCompile.h" +#include "tclCompileInt.h" #include <assert.h> /* * Prototypes for procedures defined later in this file: */ -static ClientData DupDictUpdateInfo(ClientData clientData); -static void FreeDictUpdateInfo(ClientData clientData); -static void PrintDictUpdateInfo(ClientData clientData, - Tcl_Obj *appendObj, ByteCode *codePtr, - unsigned int pcOffset); -static ClientData DupForeachInfo(ClientData clientData); -static void FreeForeachInfo(ClientData clientData); -static void PrintForeachInfo(ClientData clientData, - Tcl_Obj *appendObj, ByteCode *codePtr, - unsigned int pcOffset); -static void CompileReturnInternal(CompileEnv *envPtr, - unsigned char op, int code, int level, - Tcl_Obj *returnOpts); -static int IndexTailVarIfKnown(Tcl_Interp *interp, - Tcl_Token *varTokenPtr, CompileEnv *envPtr); -static int PushVarName(Tcl_Interp *interp, - Tcl_Token *varTokenPtr, CompileEnv *envPtr, - int flags, int *localIndexPtr, - int *simpleVarNamePtr, int *isScalarPtr); -static int CompileEachloopCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - CompileEnv *envPtr, int collect); -static int CompileDictEachCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr, int collect); - - /* * Macro that encapsulates an efficiency trick that avoids a function call for * the simplest of compiles. The ANSI C "prototype" for this macro is: @@ -71,11 +44,7 @@ static int CompileDictEachCmd(Tcl_Interp *interp, */ #define Emit14Inst(nm,idx,envPtr) \ - if (idx <= 255) { \ - TclEmitInstInt1(nm##1,idx,envPtr); \ - } else { \ - TclEmitInstInt4(nm##4,idx,envPtr); \ - } + TclEmitInstInt4(nm##4,idx,envPtr) /* * Flags bits used by PushVarName. @@ -83,5433 +52,7 @@ static int CompileDictEachCmd(Tcl_Interp *interp, #define TCL_NO_LARGE_INDEX 1 /* Do not return localIndex value > 255 */ -/* - * The structures below define the AuxData types defined in this file. - */ - -const AuxDataType tclForeachInfoType = { - "ForeachInfo", /* name */ - DupForeachInfo, /* dupProc */ - FreeForeachInfo, /* freeProc */ - PrintForeachInfo /* printProc */ -}; - -const AuxDataType tclDictUpdateInfoType = { - "DictUpdateInfo", /* name */ - DupDictUpdateInfo, /* dupProc */ - FreeDictUpdateInfo, /* freeProc */ - PrintDictUpdateInfo /* printProc */ -}; - -/* - *---------------------------------------------------------------------- - * - * TclCompileAppendCmd -- - * - * Procedure called to compile the "append" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "append" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileAppendCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *varTokenPtr, *valueTokenPtr; - int simpleVarName, isScalar, localIndex, numWords; - - numWords = parsePtr->numWords; - if (numWords == 1) { - return TCL_ERROR; - } else if (numWords == 2) { - /* - * append varName == set varName - */ - - return TclCompileSetCmd(interp, parsePtr, cmdPtr, envPtr); - } else if (numWords > 3) { - /* - * APPEND instructions currently only handle one value. - */ - - return TCL_ERROR; - } - - /* - * Decide if we can use a frame slot for the var/array name or if we need - * to emit code to compute and push the name at runtime. We use a frame - * slot (entry in the array of local vars) if we are compiling a procedure - * body and if the name is simple text that does not include namespace - * qualifiers. - */ - - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - - PushVarName(interp, varTokenPtr, envPtr, 0, - &localIndex, &simpleVarName, &isScalar); - - /* - * We are doing an assignment, otherwise TclCompileSetCmd was called, so - * push the new value. This will need to be extended to push a value for - * each argument. - */ - - if (numWords > 2) { - valueTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, valueTokenPtr, interp); - } - - /* - * Emit instructions to set/get the variable. - */ - - if (simpleVarName) { - if (isScalar) { - if (localIndex < 0) { - TclEmitOpcode(INST_APPEND_STK, envPtr); - } else { - Emit14Inst(INST_APPEND_SCALAR, localIndex, envPtr); - } - } else { - if (localIndex < 0) { - TclEmitOpcode(INST_APPEND_ARRAY_STK, envPtr); - } else { - Emit14Inst(INST_APPEND_ARRAY, localIndex, envPtr); - } - } - } else { - TclEmitOpcode(INST_APPEND_STK, envPtr); - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileArray*Cmd -- - * - * Functions called to compile "array" sucommands. - * - * Results: - * All return TCL_OK for a successful compile, and TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "array" subcommand at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileArrayExistsCmd( - Tcl_Interp *interp, /* Used for looking up stuff. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr; - int simpleVarName, isScalar, localIndex; - - if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarName(interp, tokenPtr, envPtr, 0, - &localIndex, &simpleVarName, &isScalar); - if (!isScalar) { - return TCL_ERROR; - } - - if (localIndex >= 0) { - TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); - } else { - TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); - } - return TCL_OK; -} - -int -TclCompileArraySetCmd( - Tcl_Interp *interp, /* Used for looking up stuff. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr; - int simpleVarName, isScalar, localIndex; - int dataVar, iterVar, keyVar, valVar, infoIndex; - int back, fwd, offsetBack, offsetFwd, savedStackDepth; - ForeachInfo *infoPtr; - - if (parsePtr->numWords != 3) { - return TCL_ERROR; - } - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarName(interp, tokenPtr, envPtr, 0, - &localIndex, &simpleVarName, &isScalar); - if (!isScalar) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(tokenPtr); - - /* - * Special case: literal empty value argument is just an "ensure array" - * operation. - */ - - if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD && tokenPtr[1].size == 0) { - if (localIndex >= 0) { - TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); - TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr); - TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr); - } else { - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); - TclEmitInstInt1(INST_JUMP_TRUE1, 5, envPtr); - savedStackDepth = envPtr->currStackDepth; - TclEmitOpcode( INST_ARRAY_MAKE_STK, envPtr); - TclEmitInstInt1(INST_JUMP1, 3, envPtr); - envPtr->currStackDepth = savedStackDepth; - TclEmitOpcode( INST_POP, envPtr); - } - PushLiteral(envPtr, "", 0); - return TCL_OK; - } - - /* - * Prepare for the internal foreach. - */ - - if (envPtr->procPtr == NULL) { - return TCL_ERROR; - } - dataVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); - iterVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); - keyVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); - valVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); - - infoPtr = ckalloc(sizeof(ForeachInfo) + sizeof(ForeachVarList *)); - infoPtr->numLists = 1; - infoPtr->firstValueTemp = dataVar; - infoPtr->loopCtTemp = iterVar; - infoPtr->varLists[0] = ckalloc(sizeof(ForeachVarList) * 2*sizeof(int)); - infoPtr->varLists[0]->numVars = 2; - infoPtr->varLists[0]->varIndexes[0] = keyVar; - infoPtr->varLists[0]->varIndexes[1] = valVar; - infoIndex = TclCreateAuxData(infoPtr, &tclForeachInfoType, envPtr); - - /* - * Start issuing instructions to write to the array. - */ - - CompileWord(envPtr, tokenPtr, interp); - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_LIST_LENGTH, envPtr); - PushLiteral(envPtr, "1", 1); - TclEmitOpcode( INST_BITAND, envPtr); - offsetFwd = CurrentOffset(envPtr); - TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr); - savedStackDepth = envPtr->currStackDepth; - PushLiteral(envPtr, "list must have an even number of elements", - strlen("list must have an even number of elements")); - PushLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}", - strlen("-errorCode {TCL ARGUMENT FORMAT}")); - TclEmitInstInt4( INST_RETURN_IMM, 1, envPtr); - TclEmitInt4( 0, envPtr); - envPtr->currStackDepth = savedStackDepth; - fwd = CurrentOffset(envPtr) - offsetFwd; - TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); - Emit14Inst( INST_STORE_SCALAR, dataVar, envPtr); - TclEmitOpcode( INST_POP, envPtr); - - if (localIndex >= 0) { - TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); - TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr); - TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr); - TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr); - offsetBack = CurrentOffset(envPtr); - TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr); - offsetFwd = CurrentOffset(envPtr); - TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); - savedStackDepth = envPtr->currStackDepth; - Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr); - Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr); - Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); - back = offsetBack - CurrentOffset(envPtr); - TclEmitInstInt1(INST_JUMP1, back, envPtr); - fwd = CurrentOffset(envPtr) - offsetFwd; - TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); - envPtr->currStackDepth = savedStackDepth; - } else { - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); - TclEmitInstInt1(INST_JUMP_TRUE1, 4, envPtr); - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_ARRAY_MAKE_STK, envPtr); - TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr); - offsetBack = CurrentOffset(envPtr); - TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr); - offsetFwd = CurrentOffset(envPtr); - TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); - savedStackDepth = envPtr->currStackDepth; - TclEmitOpcode( INST_DUP, envPtr); - Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr); - Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr); - TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr); - TclEmitOpcode( INST_POP, envPtr); - back = offsetBack - CurrentOffset(envPtr); - TclEmitInstInt1(INST_JUMP1, back, envPtr); - fwd = CurrentOffset(envPtr) - offsetFwd; - TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); - envPtr->currStackDepth = savedStackDepth; - TclEmitOpcode( INST_POP, envPtr); - } - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( dataVar, envPtr); - PushLiteral(envPtr, "", 0); - return TCL_OK; -} - -int -TclCompileArrayUnsetCmd( - Tcl_Interp *interp, /* Used for looking up stuff. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - int simpleVarName, isScalar, localIndex, savedStackDepth; - - if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - - PushVarName(interp, tokenPtr, envPtr, 0, - &localIndex, &simpleVarName, &isScalar); - if (!isScalar) { - return TCL_ERROR; - } - - if (localIndex >= 0) { - TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); - TclEmitInstInt1(INST_JUMP_FALSE1, 8, envPtr); - TclEmitInstInt1(INST_UNSET_SCALAR, 1, envPtr); - TclEmitInt4( localIndex, envPtr); - } else { - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); - TclEmitInstInt1(INST_JUMP_FALSE1, 6, envPtr); - savedStackDepth = envPtr->currStackDepth; - TclEmitInstInt1(INST_UNSET_STK, 1, envPtr); - TclEmitInstInt1(INST_JUMP1, 3, envPtr); - envPtr->currStackDepth = savedStackDepth; - TclEmitOpcode( INST_POP, envPtr); - } - PushLiteral(envPtr, "", 0); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileBreakCmd -- - * - * Procedure called to compile the "break" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "break" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileBreakCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - if (parsePtr->numWords != 1) { - return TCL_ERROR; - } - - /* - * Emit a break instruction. - */ - - TclEmitOpcode(INST_BREAK, envPtr); - PushLiteral(envPtr, "", 0); /* Evil hack! */ - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileCatchCmd -- - * - * Procedure called to compile the "catch" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "catch" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileCatchCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - JumpFixup jumpFixup; - Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr; - const char *name; - int resultIndex, optsIndex, nameChars, range; - int initStackDepth = envPtr->currStackDepth; - int savedStackDepth; - - /* - * If syntax does not match what we expect for [catch], do not compile. - * Let runtime checks determine if syntax has changed. - */ - - if ((parsePtr->numWords < 2) || (parsePtr->numWords > 4)) { - return TCL_ERROR; - } - - /* - * If variables were specified and the catch command is at global level - * (not in a procedure), don't compile it inline: the payoff is too small. - */ - - if ((parsePtr->numWords >= 3) && !EnvHasLVT(envPtr)) { - return TCL_ERROR; - } - - /* - * Make sure the variable names, if any, have no substitutions and just - * refer to local scalars. - */ - - resultIndex = optsIndex = -1; - cmdTokenPtr = TokenAfter(parsePtr->tokenPtr); - if (parsePtr->numWords >= 3) { - resultNameTokenPtr = TokenAfter(cmdTokenPtr); - /* DGP */ - if (resultNameTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - - name = resultNameTokenPtr[1].start; - nameChars = resultNameTokenPtr[1].size; - if (!TclIsLocalScalar(name, nameChars)) { - return TCL_ERROR; - } - resultIndex = TclFindCompiledLocal(resultNameTokenPtr[1].start, - resultNameTokenPtr[1].size, /*create*/ 1, envPtr); - if (resultIndex < 0) { - return TCL_ERROR; - } - - /* DKF */ - if (parsePtr->numWords == 4) { - optsNameTokenPtr = TokenAfter(resultNameTokenPtr); - if (optsNameTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - name = optsNameTokenPtr[1].start; - nameChars = optsNameTokenPtr[1].size; - if (!TclIsLocalScalar(name, nameChars)) { - return TCL_ERROR; - } - optsIndex = TclFindCompiledLocal(optsNameTokenPtr[1].start, - optsNameTokenPtr[1].size, /*create*/ 1, envPtr); - if (optsIndex < 0) { - return TCL_ERROR; - } - } - } - - /* - * We will compile the catch command. Declare the exception range that it - * uses. - */ - - range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); - - /* - * If the body is a simple word, compile a BEGIN_CATCH instruction, - * followed by the instructions to eval the body. - * Otherwise, compile instructions to substitute the body text before - * starting the catch, then BEGIN_CATCH, and then EVAL_STK to evaluate the - * substituted body. - * Care has to be taken to make sure that substitution happens outside the - * catch range so that errors in the substitution are not caught. - * [Bug 219184] - * The reason for duplicating the script is that EVAL_STK would otherwise - * begin by undeflowing the stack below the mark set by BEGIN_CATCH4. - */ - - if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - savedStackDepth = envPtr->currStackDepth; - TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); - ExceptionRangeStarts(envPtr, range); - CompileBody(envPtr, cmdTokenPtr, interp); - } else { - CompileTokens(envPtr, cmdTokenPtr, interp); - savedStackDepth = envPtr->currStackDepth; - TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); - ExceptionRangeStarts(envPtr, range); - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_EVAL_STK, envPtr); - } - /* Stack at this point: - * nonsimple: script <mark> result - * simple: <mark> result - */ - - if (resultIndex == -1) { - /* - * Special case when neither result nor options are being saved. In - * that case, we can skip quite a bit of the command epilogue; all we - * have to do is drop the result and push the return code (and, of - * course, finish the catch context). - */ - - TclEmitOpcode( INST_POP, envPtr); - PushLiteral(envPtr, "0", 1); - TclEmitInstInt1( INST_JUMP1, 3, envPtr); - envPtr->currStackDepth = savedStackDepth; - ExceptionRangeTarget(envPtr, range, catchOffset); - TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr); - ExceptionRangeEnds(envPtr, range); - TclEmitOpcode( INST_END_CATCH, envPtr); - - /* - * Stack at this point: - * nonsimple: script <mark> returnCode - * simple: <mark> returnCode - */ - - goto dropScriptAtEnd; - } - - /* - * Emit the "no errors" epilogue: push "0" (TCL_OK) as the catch result, - * and jump around the "error case" code. - */ - - PushLiteral(envPtr, "0", 1); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); - /* Stack at this point: ?script? <mark> result TCL_OK */ - - /* - * Emit the "error case" epilogue. Push the interpreter result and the - * return code. - */ - - envPtr->currStackDepth = savedStackDepth; - ExceptionRangeTarget(envPtr, range, catchOffset); - /* Stack at this point: ?script? */ - TclEmitOpcode( INST_PUSH_RESULT, envPtr); - TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr); - - /* - * Update the target of the jump after the "no errors" code. - */ - - /* Stack at this point: ?script? result returnCode */ - if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { - Tcl_Panic("TclCompileCatchCmd: bad jump distance %d", - (int)(CurrentOffset(envPtr) - jumpFixup.codeOffset)); - } - - /* - * Push the return options if the caller wants them. - */ - - if (optsIndex != -1) { - TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); - } - - /* - * End the catch - */ - - ExceptionRangeEnds(envPtr, range); - TclEmitOpcode( INST_END_CATCH, envPtr); - - /* - * At this point, the top of the stack is inconveniently ordered: - * ?script? result returnCode ?returnOptions? - * Reverse the stack to bring the result to the top. - */ - - if (optsIndex != -1) { - TclEmitInstInt4( INST_REVERSE, 3, envPtr); - } else { - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - } - - /* - * Store the result and remove it from the stack. - */ - - Emit14Inst( INST_STORE_SCALAR, resultIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); - - /* - * Stack is now ?script? ?returnOptions? returnCode. - * If the options dict has been requested, it is buried on the stack under - * the return code. Reverse the stack to bring it to the top, store it and - * remove it from the stack. - */ - - if (optsIndex != -1) { - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - Emit14Inst( INST_STORE_SCALAR, optsIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - - dropScriptAtEnd: - - /* - * Stack is now ?script? result. Get rid of the subst'ed script if it's - * hanging arond. - */ - - if (cmdTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - - /* - * Result of all this, on either branch, should have been to leave one - * operand -- the return code -- on the stack. - */ - - if (envPtr->currStackDepth != initStackDepth + 1) { - Tcl_Panic("in TclCompileCatchCmd, currStackDepth = %d should be %d", - envPtr->currStackDepth, initStackDepth+1); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileContinueCmd -- - * - * Procedure called to compile the "continue" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "continue" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileContinueCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - /* - * There should be no argument after the "continue". - */ - - if (parsePtr->numWords != 1) { - return TCL_ERROR; - } - - /* - * Emit a continue instruction. - */ - - TclEmitOpcode(INST_CONTINUE, envPtr); - PushLiteral(envPtr, "", 0); /* Evil hack! */ - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileDict*Cmd -- - * - * Functions called to compile "dict" sucommands. - * - * Results: - * All return TCL_OK for a successful compile, and TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "dict" subcommand at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileDictSetCmd( - Tcl_Interp *interp, /* Used for looking up stuff. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr; - int numWords, i; - Tcl_Token *varTokenPtr; - int dictVarIndex, nameChars; - const char *name; - - /* - * There must be at least one argument after the command. - */ - - if (parsePtr->numWords < 4) { - return TCL_ERROR; - } - - /* - * The dictionary variable must be a local scalar that is knowable at - * compile time; anything else exceeds the complexity of the opcode. So - * discover what the index is. - */ - - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - name = varTokenPtr[1].start; - nameChars = varTokenPtr[1].size; - if (!TclIsLocalScalar(name, nameChars)) { - return TCL_ERROR; - } - dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr); - if (dictVarIndex < 0) { - return TCL_ERROR; - } - - /* - * Remaining words (key path and value to set) can be handled normally. - */ - - tokenPtr = TokenAfter(varTokenPtr); - numWords = parsePtr->numWords-1; - for (i=1 ; i<numWords ; i++) { - CompileWord(envPtr, tokenPtr, interp); - tokenPtr = TokenAfter(tokenPtr); - } - - /* - * Now emit the instruction to do the dict manipulation. - */ - - TclEmitInstInt4( INST_DICT_SET, numWords-2, envPtr); - TclEmitInt4( dictVarIndex, envPtr); - TclAdjustStackDepth(-1, envPtr); - return TCL_OK; -} - -int -TclCompileDictIncrCmd( - Tcl_Interp *interp, /* Used for looking up stuff. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *varTokenPtr, *keyTokenPtr; - int dictVarIndex, nameChars, incrAmount; - const char *name; - - /* - * There must be at least two arguments after the command. - */ - - if (parsePtr->numWords < 3 || parsePtr->numWords > 4) { - return TCL_ERROR; - } - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - keyTokenPtr = TokenAfter(varTokenPtr); - - /* - * Parse the increment amount, if present. - */ - - if (parsePtr->numWords == 4) { - const char *word; - int numBytes, code; - Tcl_Token *incrTokenPtr; - Tcl_Obj *intObj; - - incrTokenPtr = TokenAfter(keyTokenPtr); - if (incrTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - word = incrTokenPtr[1].start; - numBytes = incrTokenPtr[1].size; - - intObj = Tcl_NewStringObj(word, numBytes); - Tcl_IncrRefCount(intObj); - code = TclGetIntFromObj(NULL, intObj, &incrAmount); - TclDecrRefCount(intObj); - if (code != TCL_OK) { - return TCL_ERROR; - } - } else { - incrAmount = 1; - } - - /* - * The dictionary variable must be a local scalar that is knowable at - * compile time; anything else exceeds the complexity of the opcode. So - * discover what the index is. - */ - - if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - name = varTokenPtr[1].start; - nameChars = varTokenPtr[1].size; - if (!TclIsLocalScalar(name, nameChars)) { - return TCL_ERROR; - } - dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr); - if (dictVarIndex < 0) { - return TCL_ERROR; - } - - /* - * Emit the key and the code to actually do the increment. - */ - - CompileWord(envPtr, keyTokenPtr, interp); - TclEmitInstInt4( INST_DICT_INCR_IMM, incrAmount, envPtr); - TclEmitInt4( dictVarIndex, envPtr); - return TCL_OK; -} - -int -TclCompileDictGetCmd( - Tcl_Interp *interp, /* Used for looking up stuff. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr; - int numWords, i; - - /* - * There must be at least two arguments after the command (the single-arg - * case is legal, but too special and magic for us to deal with here). - */ - - if (parsePtr->numWords < 3) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(parsePtr->tokenPtr); - numWords = parsePtr->numWords-1; - - /* - * Only compile this because we need INST_DICT_GET anyway. - */ - - for (i=0 ; i<numWords ; i++) { - CompileWord(envPtr, tokenPtr, interp); - tokenPtr = TokenAfter(tokenPtr); - } - TclEmitInstInt4(INST_DICT_GET, numWords-1, envPtr); - TclAdjustStackDepth(-1, envPtr); - return TCL_OK; -} - -int -TclCompileDictExistsCmd( - Tcl_Interp *interp, /* Used for looking up stuff. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr; - int numWords, i; - - /* - * There must be at least two arguments after the command (the single-arg - * case is legal, but too special and magic for us to deal with here). - */ - - if (parsePtr->numWords < 3) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(parsePtr->tokenPtr); - numWords = parsePtr->numWords-1; - - /* - * Now we do the code generation. - */ - - for (i=0 ; i<numWords ; i++) { - CompileWord(envPtr, tokenPtr, interp); - tokenPtr = TokenAfter(tokenPtr); - } - TclEmitInstInt4(INST_DICT_EXISTS, numWords-1, envPtr); - TclAdjustStackDepth(-1, envPtr); - return TCL_OK; -} - -int -TclCompileDictUnsetCmd( - Tcl_Interp *interp, /* Used for looking up stuff. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr; - int i, dictVarIndex, nameChars; - const char *name; - - /* - * There must be at least one argument after the variable name for us to - * compile to bytecode. - */ - - if (parsePtr->numWords < 3) { - return TCL_ERROR; - } - - /* - * The dictionary variable must be a local scalar that is knowable at - * compile time; anything else exceeds the complexity of the opcode. So - * discover what the index is. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - name = tokenPtr[1].start; - nameChars = tokenPtr[1].size; - if (!TclIsLocalScalar(name, nameChars)) { - return TCL_ERROR; - } - dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr); - if (dictVarIndex < 0) { - return TCL_ERROR; - } - - /* - * Remaining words (the key path) can be handled normally. - */ - - for (i=2 ; i<parsePtr->numWords ; i++) { - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp); - } - - /* - * Now emit the instruction to do the dict manipulation. - */ - - TclEmitInstInt4( INST_DICT_UNSET, parsePtr->numWords-2, envPtr); - TclEmitInt4( dictVarIndex, envPtr); - return TCL_OK; -} - -int -TclCompileDictCreateCmd( - Tcl_Interp *interp, /* Used for looking up stuff. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - int worker; /* Temp var for building the value in. */ - Tcl_Token *tokenPtr; - Tcl_Obj *keyObj, *valueObj, *dictObj; - const char *bytes; - int i, len; - - if ((parsePtr->numWords & 1) == 0) { - return TCL_ERROR; - } - - /* - * See if we can build the value at compile time... - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - dictObj = Tcl_NewObj(); - Tcl_IncrRefCount(dictObj); - for (i=1 ; i<parsePtr->numWords ; i+=2) { - keyObj = Tcl_NewObj(); - Tcl_IncrRefCount(keyObj); - if (!TclWordKnownAtCompileTime(tokenPtr, keyObj)) { - Tcl_DecrRefCount(keyObj); - Tcl_DecrRefCount(dictObj); - goto nonConstant; - } - tokenPtr = TokenAfter(tokenPtr); - valueObj = Tcl_NewObj(); - Tcl_IncrRefCount(valueObj); - if (!TclWordKnownAtCompileTime(tokenPtr, valueObj)) { - Tcl_DecrRefCount(keyObj); - Tcl_DecrRefCount(valueObj); - Tcl_DecrRefCount(dictObj); - goto nonConstant; - } - tokenPtr = TokenAfter(tokenPtr); - Tcl_DictObjPut(NULL, dictObj, keyObj, valueObj); - Tcl_DecrRefCount(keyObj); - Tcl_DecrRefCount(valueObj); - } - - /* - * We did! Excellent. The "verifyDict" is to do type forcing. - */ - - bytes = Tcl_GetStringFromObj(dictObj, &len); - PushLiteral(envPtr, bytes, len); - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_DICT_VERIFY, envPtr); - Tcl_DecrRefCount(dictObj); - return TCL_OK; - - /* - * Otherwise, we've got to issue runtime code to do the building, which we - * do by [dict set]ting into an unnamed local variable. This requires that - * we are in a context with an LVT. - */ - - nonConstant: - worker = TclFindCompiledLocal(NULL, 0, 1, envPtr); - if (worker < 0) { - return TCL_ERROR; - } - - PushLiteral(envPtr, "", 0); - Emit14Inst( INST_STORE_SCALAR, worker, envPtr); - TclEmitOpcode( INST_POP, envPtr); - tokenPtr = TokenAfter(parsePtr->tokenPtr); - for (i=1 ; i<parsePtr->numWords ; i+=2) { - CompileWord(envPtr, tokenPtr, interp); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp); - tokenPtr = TokenAfter(tokenPtr); - TclEmitInstInt4( INST_DICT_SET, 1, envPtr); - TclEmitInt4( worker, envPtr); - TclAdjustStackDepth(-1, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - Emit14Inst( INST_LOAD_SCALAR, worker, envPtr); - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( worker, envPtr); - return TCL_OK; -} - -int -TclCompileDictMergeCmd( - Tcl_Interp *interp, /* Used for looking up stuff. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr; - int i, workerIndex, infoIndex, outLoop; - - /* - * Deal with some special edge cases. Note that in the case with one - * argument, the only thing to do is to verify the dict-ness. - */ - - if (parsePtr->numWords < 2) { - PushLiteral(envPtr, "", 0); - return TCL_OK; - } else if (parsePtr->numWords == 2) { - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp); - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_DICT_VERIFY, envPtr); - return TCL_OK; - } - - /* - * There's real merging work to do. - * - * Allocate some working space. This means we'll only ever compile this - * command when there's an LVT present. - */ - - workerIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr); - if (workerIndex < 0) { - return TCL_ERROR; - } - infoIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr); - - /* - * Get the first dictionary and verify that it is so. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp); - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_DICT_VERIFY, envPtr); - Emit14Inst( INST_STORE_SCALAR, workerIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); - - /* - * For each of the remaining dictionaries... - */ - - outLoop = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); - TclEmitInstInt4( INST_BEGIN_CATCH4, outLoop, envPtr); - ExceptionRangeStarts(envPtr, outLoop); - for (i=2 ; i<parsePtr->numWords ; i++) { - /* - * Get the dictionary, and merge its pairs into the first dict (using - * a small loop). - */ - - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp); - TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr); - TclEmitInstInt1( INST_JUMP_TRUE1, 24, envPtr); - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - TclEmitInstInt4( INST_DICT_SET, 1, envPtr); - TclEmitInt4( workerIndex, envPtr); - TclAdjustStackDepth(-1, envPtr); - TclEmitOpcode( INST_POP, envPtr); - TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr); - TclEmitInstInt1( INST_JUMP_FALSE1, -20, envPtr); - TclEmitOpcode( INST_POP, envPtr); - TclEmitOpcode( INST_POP, envPtr); - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( infoIndex, envPtr); - } - ExceptionRangeEnds(envPtr, outLoop); - TclEmitOpcode( INST_END_CATCH, envPtr); - - /* - * Clean up any state left over. - */ - - Emit14Inst( INST_LOAD_SCALAR, workerIndex, envPtr); - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( workerIndex, envPtr); - TclEmitInstInt1( INST_JUMP1, 18, envPtr); - - /* - * If an exception happens when starting to iterate over the second (and - * subsequent) dicts. This is strictly not necessary, but it is nice. - */ - - ExceptionRangeTarget(envPtr, outLoop, catchOffset); - TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); - TclEmitOpcode( INST_PUSH_RESULT, envPtr); - TclEmitOpcode( INST_END_CATCH, envPtr); - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( workerIndex, envPtr); - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( infoIndex, envPtr); - TclEmitOpcode( INST_RETURN_STK, envPtr); - - return TCL_OK; -} - -int -TclCompileDictForCmd( - Tcl_Interp *interp, /* Used for looking up stuff. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - return CompileDictEachCmd(interp, parsePtr, cmdPtr, envPtr, - TCL_EACH_KEEP_NONE); -} - -int -TclCompileDictMapCmd( - Tcl_Interp *interp, /* Used for looking up stuff. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - return CompileDictEachCmd(interp, parsePtr, cmdPtr, envPtr, - TCL_EACH_COLLECT); -} - -int -CompileDictEachCmd( - Tcl_Interp *interp, /* Used for looking up stuff. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr, /* Holds resulting instructions. */ - int collect) /* Flag == TCL_EACH_COLLECT to collect and - * construct a new dictionary with the loop - * body result. */ -{ - Tcl_Token *varsTokenPtr, *dictTokenPtr, *bodyTokenPtr; - int keyVarIndex, valueVarIndex, nameChars, loopRange, catchRange; - int infoIndex, jumpDisplacement, bodyTargetOffset, emptyTargetOffset; - int numVars, endTargetOffset; - int collectVar = -1; /* Index of temp var holding the result - * dict. */ - int savedStackDepth = envPtr->currStackDepth; - /* Needed because jumps confuse the stack - * space calculator. */ - const char **argv; - Tcl_DString buffer; - - /* - * There must be at least three argument after the command. - */ - - if (parsePtr->numWords != 4) { - return TCL_ERROR; - } - - varsTokenPtr = TokenAfter(parsePtr->tokenPtr); - dictTokenPtr = TokenAfter(varsTokenPtr); - bodyTokenPtr = TokenAfter(dictTokenPtr); - if (varsTokenPtr->type != TCL_TOKEN_SIMPLE_WORD || - bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - - /* - * Create temporary variable to capture return values from loop body when - * we're collecting results. - */ - - if (collect == TCL_EACH_COLLECT) { - collectVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1, - envPtr); - if (collectVar < 0) { - return TCL_ERROR; - } - } - - /* - * Check we've got a pair of variables and that they are local variables. - * Then extract their indices in the LVT. - */ - - Tcl_DStringInit(&buffer); - TclDStringAppendToken(&buffer, &varsTokenPtr[1]); - if (Tcl_SplitList(NULL, Tcl_DStringValue(&buffer), &numVars, - &argv) != TCL_OK) { - Tcl_DStringFree(&buffer); - return TCL_ERROR; - } - Tcl_DStringFree(&buffer); - if (numVars != 2) { - ckfree(argv); - return TCL_ERROR; - } - - nameChars = strlen(argv[0]); - if (!TclIsLocalScalar(argv[0], nameChars)) { - ckfree(argv); - return TCL_ERROR; - } - keyVarIndex = TclFindCompiledLocal(argv[0], nameChars, 1, envPtr); - - nameChars = strlen(argv[1]); - if (!TclIsLocalScalar(argv[1], nameChars)) { - ckfree(argv); - return TCL_ERROR; - } - valueVarIndex = TclFindCompiledLocal(argv[1], nameChars, 1, envPtr); - ckfree(argv); - - if ((keyVarIndex < 0) || (valueVarIndex < 0)) { - return TCL_ERROR; - } - - /* - * Allocate a temporary variable to store the iterator reference. The - * variable will contain a Tcl_DictSearch reference which will be - * allocated by INST_DICT_FIRST and disposed when the variable is unset - * (at which point it should also have been finished with). - */ - - infoIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr); - if (infoIndex < 0) { - return TCL_ERROR; - } - - /* - * Preparation complete; issue instructions. Note that this code issues - * fixed-sized jumps. That simplifies things a lot! - * - * First up, initialize the accumulator dictionary if needed. - */ - - if (collect == TCL_EACH_COLLECT) { - PushLiteral(envPtr, "", 0); - Emit14Inst( INST_STORE_SCALAR, collectVar, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - - /* - * Get the dictionary and start the iteration. No catching of errors at - * this point. - */ - - CompileWord(envPtr, dictTokenPtr, interp); - TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr); - emptyTargetOffset = CurrentOffset(envPtr); - TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr); - - /* - * Now we catch errors from here on so that we can finalize the search - * started by Tcl_DictObjFirst above. - */ - - catchRange = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); - TclEmitInstInt4( INST_BEGIN_CATCH4, catchRange, envPtr); - ExceptionRangeStarts(envPtr, catchRange); - - /* - * Inside the iteration, write the loop variables. - */ - - bodyTargetOffset = CurrentOffset(envPtr); - Emit14Inst( INST_STORE_SCALAR, keyVarIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); - Emit14Inst( INST_STORE_SCALAR, valueVarIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); - - /* - * Set up the loop exception targets. - */ - - loopRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE); - ExceptionRangeStarts(envPtr, loopRange); - - /* - * Compile the loop body itself. It should be stack-neutral. - */ - - CompileBody(envPtr, bodyTokenPtr, interp); - if (collect == TCL_EACH_COLLECT) { - Emit14Inst( INST_LOAD_SCALAR, keyVarIndex, envPtr); - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitInstInt4(INST_DICT_SET, 1, envPtr); - TclEmitInt4( collectVar, envPtr); - TclAdjustStackDepth(-1, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - TclEmitOpcode( INST_POP, envPtr); - - /* - * Both exception target ranges (error and loop) end here. - */ - - ExceptionRangeEnds(envPtr, loopRange); - ExceptionRangeEnds(envPtr, catchRange); - - /* - * Continue (or just normally process) by getting the next pair of items - * from the dictionary and jumping back to the code to write them into - * variables if there is another pair. - */ - - ExceptionRangeTarget(envPtr, loopRange, continueOffset); - TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr); - jumpDisplacement = bodyTargetOffset - CurrentOffset(envPtr); - TclEmitInstInt4( INST_JUMP_FALSE4, jumpDisplacement, envPtr); - TclEmitOpcode( INST_POP, envPtr); - TclEmitOpcode( INST_POP, envPtr); - - /* - * Now do the final cleanup for the no-error case (this is where we break - * out of the loop to) by force-terminating the iteration (if not already - * terminated), ditching the exception info and jumping to the last - * instruction for this command. In theory, this could be done using the - * "finally" clause (next generated) but this is faster. - */ - - ExceptionRangeTarget(envPtr, loopRange, breakOffset); - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( infoIndex, envPtr); - TclEmitOpcode( INST_END_CATCH, envPtr); - endTargetOffset = CurrentOffset(envPtr); - TclEmitInstInt4( INST_JUMP4, 0, envPtr); - - /* - * Error handler "finally" clause, which force-terminates the iteration - * and rethrows the error. - */ - - ExceptionRangeTarget(envPtr, catchRange, catchOffset); - TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); - TclEmitOpcode( INST_PUSH_RESULT, envPtr); - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( infoIndex, envPtr); - TclEmitOpcode( INST_END_CATCH, envPtr); - if (collect == TCL_EACH_COLLECT) { - TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( collectVar, envPtr); - } - TclEmitOpcode( INST_RETURN_STK, envPtr); - - /* - * Otherwise we're done (the jump after the DICT_FIRST points here) and we - * need to pop the bogus key/value pair (pushed to keep stack calculations - * easy!) Note that we skip the END_CATCH. [Bug 1382528] - */ - - envPtr->currStackDepth = savedStackDepth + 2; - jumpDisplacement = CurrentOffset(envPtr) - emptyTargetOffset; - TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDisplacement, - envPtr->codeStart + emptyTargetOffset); - TclEmitOpcode( INST_POP, envPtr); - TclEmitOpcode( INST_POP, envPtr); - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( infoIndex, envPtr); - - /* - * Final stage of the command (normal case) is that we push an empty - * object (or push the accumulator as the result object). This is done - * last to promote peephole optimization when it's dropped immediately. - */ - - jumpDisplacement = CurrentOffset(envPtr) - endTargetOffset; - TclUpdateInstInt4AtPc(INST_JUMP4, jumpDisplacement, - envPtr->codeStart + endTargetOffset); - if (collect == TCL_EACH_COLLECT) { - Emit14Inst( INST_LOAD_SCALAR, collectVar, envPtr); - TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( collectVar, envPtr); - } else { - PushLiteral(envPtr, "", 0); - } - return TCL_OK; -} - -int -TclCompileDictUpdateCmd( - Tcl_Interp *interp, /* Used for looking up stuff. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - const char *name; - int i, nameChars, dictIndex, numVars, range, infoIndex; - Tcl_Token **keyTokenPtrs, *dictVarTokenPtr, *bodyTokenPtr, *tokenPtr; - int savedStackDepth = envPtr->currStackDepth; - DictUpdateInfo *duiPtr; - JumpFixup jumpFixup; - - /* - * There must be at least one argument after the command. - */ - - if (parsePtr->numWords < 5) { - return TCL_ERROR; - } - - /* - * Parse the command. Expect the following: - * dict update <lit(eral)> <any> <lit> ?<any> <lit> ...? <lit> - */ - - if ((parsePtr->numWords - 1) & 1) { - return TCL_ERROR; - } - numVars = (parsePtr->numWords - 3) / 2; - - /* - * The dictionary variable must be a local scalar that is knowable at - * compile time; anything else exceeds the complexity of the opcode. So - * discover what the index is. - */ - - dictVarTokenPtr = TokenAfter(parsePtr->tokenPtr); - if (dictVarTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - name = dictVarTokenPtr[1].start; - nameChars = dictVarTokenPtr[1].size; - if (!TclIsLocalScalar(name, nameChars)) { - return TCL_ERROR; - } - dictIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr); - if (dictIndex < 0) { - return TCL_ERROR; - } - - /* - * Assemble the instruction metadata. This is complex enough that it is - * represented as auxData; it holds an ordered list of variable indices - * that are to be used. - */ - - duiPtr = ckalloc(sizeof(DictUpdateInfo) + sizeof(int) * (numVars - 1)); - duiPtr->length = numVars; - keyTokenPtrs = TclStackAlloc(interp, - sizeof(Tcl_Token *) * numVars); - tokenPtr = TokenAfter(dictVarTokenPtr); - - for (i=0 ; i<numVars ; i++) { - /* - * Put keys to one side for later compilation to bytecode. - */ - - keyTokenPtrs[i] = tokenPtr; - - /* - * Variables first need to be checked for sanity. - */ - - tokenPtr = TokenAfter(tokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - goto failedUpdateInfoAssembly; - } - name = tokenPtr[1].start; - nameChars = tokenPtr[1].size; - if (!TclIsLocalScalar(name, nameChars)) { - goto failedUpdateInfoAssembly; - } - - /* - * Stash the index in the auxiliary data. - */ - - duiPtr->varIndices[i] = - TclFindCompiledLocal(name, nameChars, 1, envPtr); - if (duiPtr->varIndices[i] < 0) { - goto failedUpdateInfoAssembly; - } - tokenPtr = TokenAfter(tokenPtr); - } - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - failedUpdateInfoAssembly: - ckfree(duiPtr); - TclStackFree(interp, keyTokenPtrs); - return TCL_ERROR; - } - bodyTokenPtr = tokenPtr; - - /* - * The list of variables to bind is stored in auxiliary data so that it - * can't be snagged by literal sharing and forced to shimmer dangerously. - */ - - infoIndex = TclCreateAuxData(duiPtr, &tclDictUpdateInfoType, envPtr); - - for (i=0 ; i<numVars ; i++) { - CompileWord(envPtr, keyTokenPtrs[i], interp); - } - TclEmitInstInt4( INST_LIST, numVars, envPtr); - TclEmitInstInt4( INST_DICT_UPDATE_START, dictIndex, envPtr); - TclEmitInt4( infoIndex, envPtr); - - range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); - TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); - - ExceptionRangeStarts(envPtr, range); - envPtr->currStackDepth++; - CompileBody(envPtr, bodyTokenPtr, interp); - envPtr->currStackDepth = savedStackDepth; - ExceptionRangeEnds(envPtr, range); - - /* - * Normal termination code: the stack has the key list below the result of - * the body evaluation: swap them and finish the update code. - */ - - TclEmitOpcode( INST_END_CATCH, envPtr); - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr); - TclEmitInt4( infoIndex, envPtr); - - /* - * Jump around the exceptional termination code. - */ - - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); - - /* - * Termination code for non-ok returns: stash the result and return - * options in the stack, bring up the key list, finish the update code, - * and finally return with the catched return data - */ - - ExceptionRangeTarget(envPtr, range, catchOffset); - TclEmitOpcode( INST_PUSH_RESULT, envPtr); - TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); - TclEmitOpcode( INST_END_CATCH, envPtr); - TclEmitInstInt4( INST_REVERSE, 3, envPtr); - - TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr); - TclEmitInt4( infoIndex, envPtr); - TclEmitOpcode( INST_RETURN_STK, envPtr); - - if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { - Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d", - (int) (CurrentOffset(envPtr) - jumpFixup.codeOffset)); - } - TclStackFree(interp, keyTokenPtrs); - envPtr->currStackDepth = savedStackDepth + 1; - return TCL_OK; -} - -int -TclCompileDictAppendCmd( - Tcl_Interp *interp, /* Used for looking up stuff. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr; - int i, dictVarIndex; - - /* - * There must be at least two argument after the command. And we impose an - * (arbirary) safe limit; anyone exceeding it should stop worrying about - * speed quite so much. ;-) - */ - - if (parsePtr->numWords<4 || parsePtr->numWords>100) { - return TCL_ERROR; - } - - /* - * Get the index of the local variable that we will be working with. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } else { - register const char *name = tokenPtr[1].start; - register int nameChars = tokenPtr[1].size; - - if (!TclIsLocalScalar(name, nameChars)) { - return TCL_ERROR; - } - dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr); - if (dictVarIndex < 0) { - return TCL_ERROR; - } - } - - /* - * Produce the string to concatenate onto the dictionary entry. - */ - - tokenPtr = TokenAfter(tokenPtr); - for (i=2 ; i<parsePtr->numWords ; i++) { - CompileWord(envPtr, tokenPtr, interp); - tokenPtr = TokenAfter(tokenPtr); - } - if (parsePtr->numWords > 4) { - TclEmitInstInt1(INST_CONCAT1, parsePtr->numWords-3, envPtr); - } - - /* - * Do the concatenation. - */ - - TclEmitInstInt4(INST_DICT_APPEND, dictVarIndex, envPtr); - return TCL_OK; -} - -int -TclCompileDictLappendCmd( - Tcl_Interp *interp, /* Used for looking up stuff. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *varTokenPtr, *keyTokenPtr, *valueTokenPtr; - int dictVarIndex, nameChars; - const char *name; - - /* - * There must be three arguments after the command. - */ - - if (parsePtr->numWords != 4) { - return TCL_ERROR; - } - - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - keyTokenPtr = TokenAfter(varTokenPtr); - valueTokenPtr = TokenAfter(keyTokenPtr); - if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - name = varTokenPtr[1].start; - nameChars = varTokenPtr[1].size; - if (!TclIsLocalScalar(name, nameChars)) { - return TCL_ERROR; - } - dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr); - if (dictVarIndex < 0) { - return TCL_ERROR; - } - CompileWord(envPtr, keyTokenPtr, interp); - CompileWord(envPtr, valueTokenPtr, interp); - TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr); - return TCL_OK; -} - -int -TclCompileDictWithCmd( - Tcl_Interp *interp, /* Used for looking up stuff. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - int i, range, varNameTmp, pathTmp, keysTmp, gotPath, dictVar = -1; - int bodyIsEmpty = 1; - Tcl_Token *varTokenPtr, *tokenPtr; - int savedStackDepth = envPtr->currStackDepth; - JumpFixup jumpFixup; - const char *ptr, *end; - - /* - * There must be at least one argument after the command. - */ - - if (parsePtr->numWords < 3) { - return TCL_ERROR; - } - - /* - * Parse the command (trivially). Expect the following: - * dict with <any (varName)> ?<any> ...? <literal> - */ - - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - tokenPtr = TokenAfter(varTokenPtr); - for (i=3 ; i<parsePtr->numWords ; i++) { - tokenPtr = TokenAfter(tokenPtr); - } - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - - /* - * Test if the last word is an empty script; if so, we can compile it in - * all cases, but if it is non-empty we need local variable table entries - * to hold the temporary variables (used to keep stack usage simple). - */ - - for (ptr=tokenPtr[1].start,end=ptr+tokenPtr[1].size ; ptr!=end ; ptr++) { - if (*ptr!=' ' && *ptr!='\t' && *ptr!='\n' && *ptr!='\r') { - if (envPtr->procPtr == NULL) { - return TCL_ERROR; - } - bodyIsEmpty = 0; - break; - } - } - - /* - * Determine if we're manipulating a dict in a simple local variable. - */ - - gotPath = (parsePtr->numWords > 3); - if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD && - TclIsLocalScalar(varTokenPtr[1].start, varTokenPtr[1].size)) { - dictVar = TclFindCompiledLocal(varTokenPtr[1].start, - varTokenPtr[1].size, 1, envPtr); - } - - /* - * Special case: an empty body means we definitely have no need to issue - * try-finally style code or to allocate local variable table entries for - * storing temporaries. Still need to do both INST_DICT_EXPAND and - * INST_DICT_RECOMBINE_* though, because we can't determine if we're free - * of traces. - */ - - if (bodyIsEmpty) { - if (dictVar >= 0) { - if (gotPath) { - /* - * Case: Path into dict in LVT with empty body. - */ - - tokenPtr = TokenAfter(varTokenPtr); - for (i=2 ; i<parsePtr->numWords-1 ; i++) { - CompileWord(envPtr, tokenPtr, interp); - tokenPtr = TokenAfter(tokenPtr); - } - TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr); - Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr); - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitOpcode( INST_DICT_EXPAND, envPtr); - TclEmitInstInt4(INST_DICT_RECOMBINE_IMM, dictVar, envPtr); - PushLiteral(envPtr, "", 0); - } else { - /* - * Case: Direct dict in LVT with empty body. - */ - - PushLiteral(envPtr, "", 0); - Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr); - PushLiteral(envPtr, "", 0); - TclEmitOpcode( INST_DICT_EXPAND, envPtr); - TclEmitInstInt4(INST_DICT_RECOMBINE_IMM, dictVar, envPtr); - PushLiteral(envPtr, "", 0); - } - } else { - if (gotPath) { - /* - * Case: Path into dict in non-simple var with empty body. - */ - - tokenPtr = varTokenPtr; - for (i=1 ; i<parsePtr->numWords-1 ; i++) { - CompileWord(envPtr, tokenPtr, interp); - tokenPtr = TokenAfter(tokenPtr); - } - TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr); - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitOpcode( INST_LOAD_STK, envPtr); - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitOpcode( INST_DICT_EXPAND, envPtr); - TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr); - PushLiteral(envPtr, "", 0); - } else { - /* - * Case: Direct dict in non-simple var with empty body. - */ - - CompileWord(envPtr, varTokenPtr, interp); - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_LOAD_STK, envPtr); - PushLiteral(envPtr, "", 0); - TclEmitOpcode( INST_DICT_EXPAND, envPtr); - PushLiteral(envPtr, "", 0); - TclEmitInstInt4(INST_REVERSE, 2, envPtr); - TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr); - PushLiteral(envPtr, "", 0); - } - } - envPtr->currStackDepth = savedStackDepth + 1; - return TCL_OK; - } - - /* - * OK, we have a non-trivial body. This means that the focus is on - * generating a try-finally structure where the INST_DICT_RECOMBINE_* goes - * in the 'finally' clause. - * - * Start by allocating local (unnamed, untraced) working variables. - */ - - if (dictVar == -1) { - varNameTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr); - } else { - varNameTmp = -1; - } - if (gotPath) { - pathTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr); - } else { - pathTmp = -1; - } - keysTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr); - - /* - * Issue instructions. First, the part to expand the dictionary. - */ - - if (varNameTmp > -1) { - CompileWord(envPtr, varTokenPtr, interp); - Emit14Inst( INST_STORE_SCALAR, varNameTmp, envPtr); - } - tokenPtr = TokenAfter(varTokenPtr); - if (gotPath) { - for (i=2 ; i<parsePtr->numWords-1 ; i++) { - CompileWord(envPtr, tokenPtr, interp); - tokenPtr = TokenAfter(tokenPtr); - } - TclEmitInstInt4( INST_LIST, parsePtr->numWords-3,envPtr); - Emit14Inst( INST_STORE_SCALAR, pathTmp, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - if (dictVar == -1) { - TclEmitOpcode( INST_LOAD_STK, envPtr); - } else { - Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr); - } - if (gotPath) { - Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr); - } else { - PushLiteral(envPtr, "", 0); - } - TclEmitOpcode( INST_DICT_EXPAND, envPtr); - Emit14Inst( INST_STORE_SCALAR, keysTmp, envPtr); - TclEmitOpcode( INST_POP, envPtr); - - /* - * Now the body of the [dict with]. - */ - - range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); - TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); - - ExceptionRangeStarts(envPtr, range); - envPtr->currStackDepth++; - CompileBody(envPtr, tokenPtr, interp); - envPtr->currStackDepth = savedStackDepth; - ExceptionRangeEnds(envPtr, range); - - /* - * Now fold the results back into the dictionary in the OK case. - */ - - TclEmitOpcode( INST_END_CATCH, envPtr); - if (varNameTmp > -1) { - Emit14Inst( INST_LOAD_SCALAR, varNameTmp, envPtr); - } - if (gotPath) { - Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr); - } else { - PushLiteral(envPtr, "", 0); - } - Emit14Inst( INST_LOAD_SCALAR, keysTmp, envPtr); - if (dictVar == -1) { - TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr); - } else { - TclEmitInstInt4( INST_DICT_RECOMBINE_IMM, dictVar, envPtr); - } - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); - - /* - * Now fold the results back into the dictionary in the exception case. - */ - - ExceptionRangeTarget(envPtr, range, catchOffset); - TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); - TclEmitOpcode( INST_PUSH_RESULT, envPtr); - TclEmitOpcode( INST_END_CATCH, envPtr); - if (varNameTmp > -1) { - Emit14Inst( INST_LOAD_SCALAR, varNameTmp, envPtr); - } - if (parsePtr->numWords > 3) { - Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr); - } else { - PushLiteral(envPtr, "", 0); - } - Emit14Inst( INST_LOAD_SCALAR, keysTmp, envPtr); - if (dictVar == -1) { - TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr); - } else { - TclEmitInstInt4( INST_DICT_RECOMBINE_IMM, dictVar, envPtr); - } - TclEmitOpcode( INST_RETURN_STK, envPtr); - - /* - * Prepare for the start of the next command. - */ - - envPtr->currStackDepth = savedStackDepth + 1; - if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { - Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d", - (int) (CurrentOffset(envPtr) - jumpFixup.codeOffset)); - } - return TCL_OK; -} -/* - *---------------------------------------------------------------------- - * - * DupDictUpdateInfo, FreeDictUpdateInfo -- - * - * Functions to duplicate, release and print the aux data created for use - * with the INST_DICT_UPDATE_START and INST_DICT_UPDATE_END instructions. - * - * Results: - * DupDictUpdateInfo: a copy of the auxiliary data - * FreeDictUpdateInfo: none - * PrintDictUpdateInfo: none - * - * Side effects: - * DupDictUpdateInfo: allocates memory - * FreeDictUpdateInfo: releases memory - * PrintDictUpdateInfo: none - * - *---------------------------------------------------------------------- - */ - -static ClientData -DupDictUpdateInfo( - ClientData clientData) -{ - DictUpdateInfo *dui1Ptr, *dui2Ptr; - unsigned len; - - dui1Ptr = clientData; - len = sizeof(DictUpdateInfo) + sizeof(int) * (dui1Ptr->length - 1); - dui2Ptr = ckalloc(len); - memcpy(dui2Ptr, dui1Ptr, len); - return dui2Ptr; -} - -static void -FreeDictUpdateInfo( - ClientData clientData) -{ - ckfree(clientData); -} - -static void -PrintDictUpdateInfo( - ClientData clientData, - Tcl_Obj *appendObj, - ByteCode *codePtr, - unsigned int pcOffset) -{ - DictUpdateInfo *duiPtr = clientData; - int i; - - for (i=0 ; i<duiPtr->length ; i++) { - if (i) { - Tcl_AppendToObj(appendObj, ", ", -1); - } - Tcl_AppendPrintfToObj(appendObj, "%%v%u", duiPtr->varIndices[i]); - } -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileErrorCmd -- - * - * Procedure called to compile the "error" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "error" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileErrorCmd( - Tcl_Interp *interp, /* Used for context. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - /* - * General syntax: [error message ?errorInfo? ?errorCode?] - * However, we only deal with the case where there is just a message. - */ - Tcl_Token *messageTokenPtr; - int savedStackDepth = envPtr->currStackDepth; - - if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - messageTokenPtr = TokenAfter(parsePtr->tokenPtr); - - PushLiteral(envPtr, "-code error -level 0", 20); - CompileWord(envPtr, messageTokenPtr, interp); - TclEmitOpcode(INST_RETURN_STK, envPtr); - envPtr->currStackDepth = savedStackDepth + 1; - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileExprCmd -- - * - * Procedure called to compile the "expr" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "expr" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileExprCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *firstWordPtr; - - if (parsePtr->numWords == 1) { - return TCL_ERROR; - } - - firstWordPtr = TokenAfter(parsePtr->tokenPtr); - TclCompileExprWords(interp, firstWordPtr, parsePtr->numWords-1, envPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileForCmd -- - * - * Procedure called to compile the "for" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "for" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileForCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr; - JumpFixup jumpEvalCondFixup; - int testCodeOffset, bodyCodeOffset, nextCodeOffset, jumpDist; - int bodyRange, nextRange; - int savedStackDepth = envPtr->currStackDepth; - - if (parsePtr->numWords != 5) { - return TCL_ERROR; - } - - /* - * If the test expression requires substitutions, don't compile the for - * command inline. E.g., the expression might cause the loop to never - * execute or execute forever, as in "for {} "$x > 5" {incr x} {}". - */ - - startTokenPtr = TokenAfter(parsePtr->tokenPtr); - testTokenPtr = TokenAfter(startTokenPtr); - if (testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - - /* - * Bail out also if the body or the next expression require substitutions - * in order to insure correct behaviour [Bug 219166] - */ - - nextTokenPtr = TokenAfter(testTokenPtr); - bodyTokenPtr = TokenAfter(nextTokenPtr); - if ((nextTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) - || (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) { - return TCL_ERROR; - } - - /* - * Create ExceptionRange records for the body and the "next" command. The - * "next" command's ExceptionRange supports break but not continue (and - * has a -1 continueOffset). - */ - - bodyRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE); - nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); - - /* - * Inline compile the initial command. - */ - - CompileBody(envPtr, startTokenPtr, interp); - TclEmitOpcode(INST_POP, envPtr); - - /* - * Jump to the evaluation of the condition. This code uses the "loop - * rotation" optimisation (which eliminates one branch from the loop). - * "for start cond next body" produces then: - * start - * goto A - * B: body : bodyCodeOffset - * next : nextCodeOffset, continueOffset - * A: cond -> result : testCodeOffset - * if (result) goto B - */ - - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup); - - /* - * Compile the loop body. - */ - - bodyCodeOffset = ExceptionRangeStarts(envPtr, bodyRange); - CompileBody(envPtr, bodyTokenPtr, interp); - ExceptionRangeEnds(envPtr, bodyRange); - envPtr->currStackDepth = savedStackDepth + 1; - TclEmitOpcode(INST_POP, envPtr); - - /* - * Compile the "next" subcommand. - */ - - envPtr->currStackDepth = savedStackDepth; - nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange); - CompileBody(envPtr, nextTokenPtr, interp); - ExceptionRangeEnds(envPtr, nextRange); - envPtr->currStackDepth = savedStackDepth + 1; - TclEmitOpcode(INST_POP, envPtr); - envPtr->currStackDepth = savedStackDepth; - - /* - * Compile the test expression then emit the conditional jump that - * terminates the for. - */ - - testCodeOffset = CurrentOffset(envPtr); - - jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset; - if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) { - bodyCodeOffset += 3; - nextCodeOffset += 3; - testCodeOffset += 3; - } - - envPtr->currStackDepth = savedStackDepth; - TclCompileExprWords(interp, testTokenPtr, 1, envPtr); - envPtr->currStackDepth = savedStackDepth + 1; - - jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; - if (jumpDist > 127) { - TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr); - } else { - TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr); - } - - /* - * Fix the starting points of the exception ranges (may have moved due to - * jump type modification) and set where the exceptions target. - */ - - envPtr->exceptArrayPtr[bodyRange].codeOffset = bodyCodeOffset; - envPtr->exceptArrayPtr[bodyRange].continueOffset = nextCodeOffset; - - envPtr->exceptArrayPtr[nextRange].codeOffset = nextCodeOffset; - - ExceptionRangeTarget(envPtr, bodyRange, breakOffset); - ExceptionRangeTarget(envPtr, nextRange, breakOffset); - - /* - * The for command's result is an empty string. - */ - - envPtr->currStackDepth = savedStackDepth; - PushLiteral(envPtr, "", 0); - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileForeachCmd -- - * - * Procedure called to compile the "foreach" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "foreach" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileForeachCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - return CompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr, - TCL_EACH_KEEP_NONE); -} - -/* - *---------------------------------------------------------------------- - * - * CompileEachloopCmd -- - * - * Procedure called to compile the "foreach" and "lmap" commands. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "foreach" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -static int -CompileEachloopCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr, /* Holds resulting instructions. */ - int collect) /* Select collecting or accumulating mode - * (TCL_EACH_*) */ -{ - Proc *procPtr = envPtr->procPtr; - ForeachInfo *infoPtr; /* Points to the structure describing this - * foreach command. Stored in a AuxData - * record in the ByteCode. */ - int firstValueTemp; /* Index of the first temp var in the frame - * used to point to a value list. */ - int loopCtTemp; /* Index of temp var holding the loop's - * iteration count. */ - int collectVar = -1; /* Index of temp var holding the result var - * index. */ - - Tcl_Token *tokenPtr, *bodyTokenPtr; - unsigned char *jumpPc; - JumpFixup jumpFalseFixup; - int jumpBackDist, jumpBackOffset, infoIndex, range; - int numWords, numLists, numVars, loopIndex, tempVar, i, j, code; - int savedStackDepth = envPtr->currStackDepth; - - /* - * We parse the variable list argument words and create two arrays: - * varcList[i] is number of variables in i-th var list. - * varvList[i] points to array of var names in i-th var list. - */ - - int *varcList; - const char ***varvList; - - /* - * If the foreach command isn't in a procedure, don't compile it inline: - * the payoff is too small. - */ - - if (procPtr == NULL) { - return TCL_ERROR; - } - - numWords = parsePtr->numWords; - if ((numWords < 4) || (numWords%2 != 0)) { - return TCL_ERROR; - } - - /* - * Bail out if the body requires substitutions in order to insure correct - * behaviour. [Bug 219166] - */ - - for (i = 0, tokenPtr = parsePtr->tokenPtr; i < numWords-1; i++) { - tokenPtr = TokenAfter(tokenPtr); - } - bodyTokenPtr = tokenPtr; - if (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - - /* - * Allocate storage for the varcList and varvList arrays if necessary. - */ - - numLists = (numWords - 2)/2; - varcList = TclStackAlloc(interp, numLists * sizeof(int)); - memset(varcList, 0, numLists * sizeof(int)); - varvList = (const char ***) TclStackAlloc(interp, - numLists * sizeof(const char **)); - memset((char*) varvList, 0, numLists * sizeof(const char **)); - - /* - * Break up each var list and set the varcList and varvList arrays. Don't - * compile the foreach inline if any var name needs substitutions or isn't - * a scalar, or if any var list needs substitutions. - */ - - loopIndex = 0; - for (i = 0, tokenPtr = parsePtr->tokenPtr; - i < numWords-1; - i++, tokenPtr = TokenAfter(tokenPtr)) { - Tcl_DString varList; - - if (i%2 != 1) { - continue; - } - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - code = TCL_ERROR; - goto done; - } - - /* - * Lots of copying going on here. Need a ListObj wizard to show a - * better way. - */ - - Tcl_DStringInit(&varList); - TclDStringAppendToken(&varList, &tokenPtr[1]); - code = Tcl_SplitList(interp, Tcl_DStringValue(&varList), - &varcList[loopIndex], &varvList[loopIndex]); - Tcl_DStringFree(&varList); - if (code != TCL_OK) { - code = TCL_ERROR; - goto done; - } - numVars = varcList[loopIndex]; - - /* - * If the variable list is empty, we can enter an infinite loop when - * the interpreted version would not. Take care to ensure this does - * not happen. [Bug 1671138] - */ - - if (numVars == 0) { - code = TCL_ERROR; - goto done; - } - - for (j = 0; j < numVars; j++) { - const char *varName = varvList[loopIndex][j]; - - if (!TclIsLocalScalar(varName, (int) strlen(varName))) { - code = TCL_ERROR; - goto done; - } - } - loopIndex++; - } - - if (collect == TCL_EACH_COLLECT) { - collectVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1, - envPtr); - if (collectVar < 0) { - return TCL_ERROR; - } - } - - /* - * We will compile the foreach command. Reserve (numLists + 1) temporary - * variables: - * - numLists temps to hold each value list - * - 1 temp for the loop counter (index of next element in each list) - * - * At this time we don't try to reuse temporaries; if there are two - * nonoverlapping foreach loops, they don't share any temps. - */ - - code = TCL_OK; - firstValueTemp = -1; - for (loopIndex = 0; loopIndex < numLists; loopIndex++) { - tempVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0, - /*create*/ 1, envPtr); - if (loopIndex == 0) { - firstValueTemp = tempVar; - } - } - loopCtTemp = TclFindCompiledLocal(NULL, /*nameChars*/ 0, - /*create*/ 1, envPtr); - - /* - * Create and initialize the ForeachInfo and ForeachVarList data - * structures describing this command. Then create a AuxData record - * pointing to the ForeachInfo structure. - */ - - infoPtr = ckalloc(sizeof(ForeachInfo) - + numLists * sizeof(ForeachVarList *)); - infoPtr->numLists = numLists; - infoPtr->firstValueTemp = firstValueTemp; - infoPtr->loopCtTemp = loopCtTemp; - for (loopIndex = 0; loopIndex < numLists; loopIndex++) { - ForeachVarList *varListPtr; - - numVars = varcList[loopIndex]; - varListPtr = ckalloc(sizeof(ForeachVarList) - + numVars * sizeof(int)); - varListPtr->numVars = numVars; - for (j = 0; j < numVars; j++) { - const char *varName = varvList[loopIndex][j]; - int nameChars = strlen(varName); - - varListPtr->varIndexes[j] = TclFindCompiledLocal(varName, - nameChars, /*create*/ 1, envPtr); - } - infoPtr->varLists[loopIndex] = varListPtr; - } - infoIndex = TclCreateAuxData(infoPtr, &tclForeachInfoType, envPtr); - - /* - * Create an exception record to handle [break] and [continue]. - */ - - range = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE); - - /* - * Evaluate then store each value list in the associated temporary. - */ - - loopIndex = 0; - for (i = 0, tokenPtr = parsePtr->tokenPtr; - i < numWords-1; - i++, tokenPtr = TokenAfter(tokenPtr)) { - if ((i%2 == 0) && (i > 0)) { - CompileTokens(envPtr, tokenPtr, interp); - tempVar = (firstValueTemp + loopIndex); - Emit14Inst( INST_STORE_SCALAR, tempVar, envPtr); - TclEmitOpcode( INST_POP, envPtr); - loopIndex++; - } - } - - /* - * Create temporary variable to capture return values from loop body. - */ - - if (collect == TCL_EACH_COLLECT) { - PushLiteral(envPtr, "", 0); - Emit14Inst( INST_STORE_SCALAR, collectVar, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - - /* - * Initialize the temporary var that holds the count of loop iterations. - */ - - TclEmitInstInt4( INST_FOREACH_START4, infoIndex, envPtr); - - /* - * Top of loop code: assign each loop variable and check whether - * to terminate the loop. - */ - - ExceptionRangeTarget(envPtr, range, continueOffset); - TclEmitInstInt4( INST_FOREACH_STEP4, infoIndex, envPtr); - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup); - - /* - * Inline compile the loop body. - */ - - ExceptionRangeStarts(envPtr, range); - CompileBody(envPtr, bodyTokenPtr, interp); - ExceptionRangeEnds(envPtr, range); - envPtr->currStackDepth = savedStackDepth + 1; - - if (collect == TCL_EACH_COLLECT) { - Emit14Inst( INST_LAPPEND_SCALAR, collectVar,envPtr); - } - TclEmitOpcode( INST_POP, envPtr); - - /* - * Jump back to the test at the top of the loop. Generate a 4 byte jump if - * the distance to the test is > 120 bytes. This is conservative and - * ensures that we won't have to replace this jump if we later need to - * replace the ifFalse jump with a 4 byte jump. - */ - - jumpBackOffset = CurrentOffset(envPtr); - jumpBackDist = jumpBackOffset-envPtr->exceptArrayPtr[range].continueOffset; - if (jumpBackDist > 120) { - TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr); - } else { - TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr); - } - - /* - * Fix the target of the jump after the foreach_step test. - */ - - if (TclFixupForwardJumpToHere(envPtr, &jumpFalseFixup, 127)) { - /* - * Update the loop body's starting PC offset since it moved down. - */ - - envPtr->exceptArrayPtr[range].codeOffset += 3; - - /* - * Update the jump back to the test at the top of the loop since it - * also moved down 3 bytes. - */ - - jumpBackOffset += 3; - jumpPc = (envPtr->codeStart + jumpBackOffset); - jumpBackDist += 3; - if (jumpBackDist > 120) { - TclUpdateInstInt4AtPc(INST_JUMP4, -jumpBackDist, jumpPc); - } else { - TclUpdateInstInt1AtPc(INST_JUMP1, -jumpBackDist, jumpPc); - } - } - - /* - * Set the loop's break target. - */ - - ExceptionRangeTarget(envPtr, range, breakOffset); - - /* - * The command's result is an empty string if not collecting, or the - * list of results from evaluating the loop body. - */ - - envPtr->currStackDepth = savedStackDepth; - if (collect == TCL_EACH_COLLECT) { - Emit14Inst( INST_LOAD_SCALAR, collectVar, envPtr); - TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( collectVar, envPtr); - } else { - PushLiteral(envPtr, "", 0); - } - envPtr->currStackDepth = savedStackDepth + 1; - - done: - for (loopIndex = 0; loopIndex < numLists; loopIndex++) { - if (varvList[loopIndex] != NULL) { - ckfree(varvList[loopIndex]); - } - } - TclStackFree(interp, (void *)varvList); - TclStackFree(interp, varcList); - return code; -} - -/* - *---------------------------------------------------------------------- - * - * 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) /* The foreach command's compilation auxiliary - * data to duplicate. */ -{ - register ForeachInfo *srcPtr = clientData; - ForeachInfo *dupPtr; - register ForeachVarList *srcListPtr, *dupListPtr; - int numVars, i, j, numLists = srcPtr->numLists; - - dupPtr = ckalloc(sizeof(ForeachInfo) - + numLists * sizeof(ForeachVarList *)); - dupPtr->numLists = numLists; - dupPtr->firstValueTemp = srcPtr->firstValueTemp; - dupPtr->loopCtTemp = srcPtr->loopCtTemp; - - for (i = 0; i < numLists; i++) { - srcListPtr = srcPtr->varLists[i]; - numVars = srcListPtr->numVars; - dupListPtr = ckalloc(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 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) /* The foreach command's compilation auxiliary - * data to free. */ -{ - register ForeachInfo *infoPtr = clientData; - register ForeachVarList *listPtr; - int numLists = infoPtr->numLists; - register int i; - - for (i = 0; i < numLists; i++) { - listPtr = infoPtr->varLists[i]; - ckfree(listPtr); - } - ckfree(infoPtr); -} - -/* - *---------------------------------------------------------------------- - * - * PrintForeachInfo -- - * - * Function to write a human-readable representation of a ForeachInfo - * structure to stdout for debugging. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -PrintForeachInfo( - ClientData clientData, - Tcl_Obj *appendObj, - ByteCode *codePtr, - unsigned int pcOffset) -{ - register ForeachInfo *infoPtr = clientData; - register ForeachVarList *varsPtr; - int i, j; - - Tcl_AppendToObj(appendObj, "data=[", -1); - - for (i=0 ; i<infoPtr->numLists ; i++) { - if (i) { - Tcl_AppendToObj(appendObj, ", ", -1); - } - Tcl_AppendPrintfToObj(appendObj, "%%v%u", - (unsigned) (infoPtr->firstValueTemp + i)); - } - Tcl_AppendPrintfToObj(appendObj, "], loop=%%v%u", - (unsigned) infoPtr->loopCtTemp); - for (i=0 ; i<infoPtr->numLists ; i++) { - if (i) { - Tcl_AppendToObj(appendObj, ",", -1); - } - Tcl_AppendPrintfToObj(appendObj, "\n\t\t it%%v%u\t[", - (unsigned) (infoPtr->firstValueTemp + i)); - varsPtr = infoPtr->varLists[i]; - for (j=0 ; j<varsPtr->numVars ; j++) { - if (j) { - Tcl_AppendToObj(appendObj, ", ", -1); - } - Tcl_AppendPrintfToObj(appendObj, "%%v%u", - (unsigned) varsPtr->varIndexes[j]); - } - Tcl_AppendToObj(appendObj, "]", -1); - } -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileFormatCmd -- - * - * Procedure called to compile the "format" command. Handles cases that - * can be done as constants or simple string concatenation only. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "format" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileFormatCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr = parsePtr->tokenPtr; - Tcl_Obj **objv, *formatObj, *tmpObj; - char *bytes, *start; - int i, j, len; - - /* - * Don't handle any guaranteed-error cases. - */ - - if (parsePtr->numWords < 2) { - return TCL_ERROR; - } - - /* - * Check if the argument words are all compile-time-known literals; that's - * a case we can handle by compiling to a constant. - */ - - formatObj = Tcl_NewObj(); - Tcl_IncrRefCount(formatObj); - tokenPtr = TokenAfter(tokenPtr); - if (!TclWordKnownAtCompileTime(tokenPtr, formatObj)) { - Tcl_DecrRefCount(formatObj); - return TCL_ERROR; - } - - objv = ckalloc((parsePtr->numWords-2) * sizeof(Tcl_Obj *)); - for (i=0 ; i+2 < parsePtr->numWords ; i++) { - tokenPtr = TokenAfter(tokenPtr); - objv[i] = Tcl_NewObj(); - Tcl_IncrRefCount(objv[i]); - if (!TclWordKnownAtCompileTime(tokenPtr, objv[i])) { - goto checkForStringConcatCase; - } - } - - /* - * Everything is a literal, so the result is constant too (or an error if - * the format is broken). Do the format now. - */ - - tmpObj = Tcl_Format(interp, Tcl_GetString(formatObj), - parsePtr->numWords-2, objv); - for (; --i>=0 ;) { - Tcl_DecrRefCount(objv[i]); - } - ckfree(objv); - Tcl_DecrRefCount(formatObj); - if (tmpObj == NULL) { - return TCL_ERROR; - } - - /* - * Not an error, always a constant result, so just push the result as a - * literal. Job done. - */ - - bytes = Tcl_GetStringFromObj(tmpObj, &len); - PushLiteral(envPtr, bytes, len); - Tcl_DecrRefCount(tmpObj); - return TCL_OK; - - checkForStringConcatCase: - /* - * See if we can generate a sequence of things to concatenate. This - * requires that all the % sequences be %s or %%, as everything else is - * sufficiently complex that we don't bother. - * - * First, get the state of the system relatively sensible (cleaning up - * after our attempt to spot a literal). - */ - - for (; i>=0 ; i--) { - Tcl_DecrRefCount(objv[i]); - } - ckfree(objv); - tokenPtr = TokenAfter(parsePtr->tokenPtr); - tokenPtr = TokenAfter(tokenPtr); - i = 0; - - /* - * Now scan through and check for non-%s and non-%% substitutions. - */ - - for (bytes = Tcl_GetString(formatObj) ; *bytes ; bytes++) { - if (*bytes == '%') { - bytes++; - if (*bytes == 's') { - i++; - continue; - } else if (*bytes == '%') { - continue; - } - Tcl_DecrRefCount(formatObj); - return TCL_ERROR; - } - } - - /* - * Check if the number of things to concatenate will fit in a byte. - */ - - if (i+2 != parsePtr->numWords || i > 125) { - Tcl_DecrRefCount(formatObj); - return TCL_ERROR; - } - - /* - * Generate the pushes of the things to concatenate, a sequence of - * literals and compiled tokens (of which at least one is non-literal or - * we'd have the case in the first half of this function) which we will - * concatenate. - */ - - i = 0; /* The count of things to concat. */ - j = 2; /* The index into the argument tokens, for - * TIP#280 handling. */ - start = Tcl_GetString(formatObj); - /* The start of the currently-scanned literal - * in the format string. */ - tmpObj = Tcl_NewObj(); /* The buffer used to accumulate the literal - * being built. */ - for (bytes = start ; *bytes ; bytes++) { - if (*bytes == '%') { - Tcl_AppendToObj(tmpObj, start, bytes - start); - if (*++bytes == '%') { - Tcl_AppendToObj(tmpObj, "%", 1); - } else { - char *b = Tcl_GetStringFromObj(tmpObj, &len); - - /* - * If there is a non-empty literal from the format string, - * push it and reset. - */ - - if (len > 0) { - PushLiteral(envPtr, b, len); - Tcl_DecrRefCount(tmpObj); - tmpObj = Tcl_NewObj(); - i++; - } - - /* - * Push the code to produce the string that would be - * substituted with %s, except we'll be concatenating - * directly. - */ - - CompileWord(envPtr, tokenPtr, interp); - tokenPtr = TokenAfter(tokenPtr); - j++; - i++; - } - start = bytes + 1; - } - } - - /* - * Handle the case of a trailing literal. - */ - - Tcl_AppendToObj(tmpObj, start, bytes - start); - bytes = Tcl_GetStringFromObj(tmpObj, &len); - if (len > 0) { - PushLiteral(envPtr, bytes, len); - i++; - } - Tcl_DecrRefCount(tmpObj); - Tcl_DecrRefCount(formatObj); - - if (i > 1) { - /* - * Do the concatenation, which produces the result. - */ - - TclEmitInstInt1(INST_CONCAT1, i, envPtr); - } else { - /* - * EVIL HACK! Force there to be a string representation in the case - * where there's just a "%s" in the format; case covered by the test - * format-20.1 (and it is horrible...) - */ - - TclEmitOpcode(INST_DUP, envPtr); - PushLiteral(envPtr, "", 0); - TclEmitOpcode(INST_STR_EQ, envPtr); - TclEmitOpcode(INST_POP, envPtr); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileGlobalCmd -- - * - * Procedure called to compile the "global" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "global" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileGlobalCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *varTokenPtr; - int localIndex, numWords, i; - - numWords = parsePtr->numWords; - if (numWords < 2) { - return TCL_ERROR; - } - - /* - * 'global' has no effect outside of proc bodies; handle that at runtime - */ - - if (envPtr->procPtr == NULL) { - return TCL_ERROR; - } - - /* - * Push the namespace - */ - - PushLiteral(envPtr, "::", 2); - - /* - * Loop over the variables. - */ - - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - for (i=2; i<=numWords; varTokenPtr = TokenAfter(varTokenPtr),i++) { - localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr); - - if (localIndex < 0) { - return TCL_ERROR; - } - - CompileWord(envPtr, varTokenPtr, interp); - TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr); - } - - /* - * Pop the namespace, and set the result to empty - */ - - TclEmitOpcode( INST_POP, envPtr); - PushLiteral(envPtr, "", 0); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileIfCmd -- - * - * Procedure called to compile the "if" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "if" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileIfCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - JumpFixupArray jumpFalseFixupArray; - /* Used to fix the ifFalse jump after each - * test when its target PC is determined. */ - JumpFixupArray jumpEndFixupArray; - /* Used to fix the jump after each "then" body - * to the end of the "if" when that PC is - * determined. */ - Tcl_Token *tokenPtr, *testTokenPtr; - int jumpIndex = 0; /* Avoid compiler warning. */ - int jumpFalseDist, numWords, wordIdx, numBytes, j, code; - const char *word; - int savedStackDepth = envPtr->currStackDepth; - /* Saved stack depth at the start of the first - * test; the envPtr current depth is restored - * to this value at the start of each test. */ - int realCond = 1; /* Set to 0 for static conditions: - * "if 0 {..}" */ - int boolVal; /* Value of static condition. */ - int compileScripts = 1; - - /* - * Only compile the "if" command if all arguments are simple words, in - * order to insure correct substitution [Bug 219166] - */ - - tokenPtr = parsePtr->tokenPtr; - wordIdx = 0; - numWords = parsePtr->numWords; - - for (wordIdx = 0; wordIdx < numWords; wordIdx++) { - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(tokenPtr); - } - - TclInitJumpFixupArray(&jumpFalseFixupArray); - TclInitJumpFixupArray(&jumpEndFixupArray); - code = TCL_OK; - - /* - * Each iteration of this loop compiles one "if expr ?then? body" or - * "elseif expr ?then? body" clause. - */ - - tokenPtr = parsePtr->tokenPtr; - wordIdx = 0; - while (wordIdx < numWords) { - /* - * Stop looping if the token isn't "if" or "elseif". - */ - - word = tokenPtr[1].start; - numBytes = tokenPtr[1].size; - if ((tokenPtr == parsePtr->tokenPtr) - || ((numBytes == 6) && (strncmp(word, "elseif", 6) == 0))) { - tokenPtr = TokenAfter(tokenPtr); - wordIdx++; - } else { - break; - } - if (wordIdx >= numWords) { - code = TCL_ERROR; - goto done; - } - - /* - * Compile the test expression then emit the conditional jump around - * the "then" part. - */ - - envPtr->currStackDepth = savedStackDepth; - testTokenPtr = tokenPtr; - - if (realCond) { - /* - * Find out if the condition is a constant. - */ - - Tcl_Obj *boolObj = Tcl_NewStringObj(testTokenPtr[1].start, - testTokenPtr[1].size); - - Tcl_IncrRefCount(boolObj); - code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal); - TclDecrRefCount(boolObj); - if (code == TCL_OK) { - /* - * A static condition. - */ - - realCond = 0; - if (!boolVal) { - compileScripts = 0; - } - } else { - Tcl_ResetResult(interp); - TclCompileExprWords(interp, testTokenPtr, 1, envPtr); - if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { - TclExpandJumpFixupArray(&jumpFalseFixupArray); - } - jumpIndex = jumpFalseFixupArray.next; - jumpFalseFixupArray.next++; - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, - jumpFalseFixupArray.fixup+jumpIndex); - } - code = TCL_OK; - } - - /* - * Skip over the optional "then" before the then clause. - */ - - tokenPtr = TokenAfter(testTokenPtr); - wordIdx++; - if (wordIdx >= numWords) { - code = TCL_ERROR; - goto done; - } - if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - word = tokenPtr[1].start; - numBytes = tokenPtr[1].size; - if ((numBytes == 4) && (strncmp(word, "then", 4) == 0)) { - tokenPtr = TokenAfter(tokenPtr); - wordIdx++; - if (wordIdx >= numWords) { - code = TCL_ERROR; - goto done; - } - } - } - - /* - * Compile the "then" command body. - */ - - if (compileScripts) { - envPtr->currStackDepth = savedStackDepth; - CompileBody(envPtr, tokenPtr, interp); - } - - if (realCond) { - /* - * Jump to the end of the "if" command. Both jumpFalseFixupArray - * and jumpEndFixupArray are indexed by "jumpIndex". - */ - - if (jumpEndFixupArray.next >= jumpEndFixupArray.end) { - TclExpandJumpFixupArray(&jumpEndFixupArray); - } - jumpEndFixupArray.next++; - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - jumpEndFixupArray.fixup+jumpIndex); - - /* - * Fix the target of the jumpFalse after the test. Generate a 4 - * byte jump if the distance is > 120 bytes. This is conservative, - * and ensures that we won't have to replace this jump if we later - * also need to replace the proceeding jump to the end of the "if" - * with a 4 byte jump. - */ - - if (TclFixupForwardJumpToHere(envPtr, - jumpFalseFixupArray.fixup+jumpIndex, 120)) { - /* - * Adjust the code offset for the proceeding jump to the end - * of the "if" command. - */ - - jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3; - } - } else if (boolVal) { - /* - * We were processing an "if 1 {...}"; stop compiling scripts. - */ - - compileScripts = 0; - } else { - /* - * We were processing an "if 0 {...}"; reset so that the rest - * (elseif, else) is compiled correctly. - */ - - realCond = 1; - compileScripts = 1; - } - - tokenPtr = TokenAfter(tokenPtr); - wordIdx++; - } - - /* - * Restore the current stack depth in the environment; the "else" clause - * (or its default) will add 1 to this. - */ - - envPtr->currStackDepth = savedStackDepth; - - /* - * Check for the optional else clause. Do not compile anything if this was - * an "if 1 {...}" case. - */ - - if ((wordIdx < numWords) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) { - /* - * There is an else clause. Skip over the optional "else" word. - */ - - word = tokenPtr[1].start; - numBytes = tokenPtr[1].size; - if ((numBytes == 4) && (strncmp(word, "else", 4) == 0)) { - tokenPtr = TokenAfter(tokenPtr); - wordIdx++; - if (wordIdx >= numWords) { - code = TCL_ERROR; - goto done; - } - } - - if (compileScripts) { - /* - * Compile the else command body. - */ - - CompileBody(envPtr, tokenPtr, interp); - } - - /* - * Make sure there are no words after the else clause. - */ - - wordIdx++; - if (wordIdx < numWords) { - code = TCL_ERROR; - goto done; - } - } else { - /* - * No else clause: the "if" command's result is an empty string. - */ - - if (compileScripts) { - PushLiteral(envPtr, "", 0); - } - } - - /* - * Fix the unconditional jumps to the end of the "if" command. - */ - - for (j = jumpEndFixupArray.next; j > 0; j--) { - jumpIndex = (j - 1); /* i.e. process the closest jump first. */ - if (TclFixupForwardJumpToHere(envPtr, - jumpEndFixupArray.fixup+jumpIndex, 127)) { - /* - * Adjust the immediately preceeding "ifFalse" jump. We moved it's - * target (just after this jump) down three bytes. - */ - - unsigned char *ifFalsePc = envPtr->codeStart - + jumpFalseFixupArray.fixup[jumpIndex].codeOffset; - unsigned char 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 { - Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", (int) opCode); - } - } - } - - /* - * Free the jumpFixupArray array if malloc'ed storage was used. - */ - - done: - envPtr->currStackDepth = savedStackDepth + 1; - TclFreeJumpFixupArray(&jumpFalseFixupArray); - TclFreeJumpFixupArray(&jumpEndFixupArray); - return code; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileIncrCmd -- - * - * Procedure called to compile the "incr" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "incr" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileIncrCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *varTokenPtr, *incrTokenPtr; - int simpleVarName, isScalar, localIndex, haveImmValue, immValue; - - if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) { - return TCL_ERROR; - } - - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - - PushVarName(interp, varTokenPtr, envPtr, TCL_NO_LARGE_INDEX, - &localIndex, &simpleVarName, &isScalar); - - /* - * If an increment is given, push it, but see first if it's a small - * integer. - */ - - haveImmValue = 0; - immValue = 1; - if (parsePtr->numWords == 3) { - incrTokenPtr = TokenAfter(varTokenPtr); - if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - const char *word = incrTokenPtr[1].start; - int numBytes = incrTokenPtr[1].size; - int code; - Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes); - - Tcl_IncrRefCount(intObj); - code = TclGetIntFromObj(NULL, intObj, &immValue); - TclDecrRefCount(intObj); - if ((code == TCL_OK) && (-127 <= immValue) && (immValue <= 127)) { - haveImmValue = 1; - } - if (!haveImmValue) { - PushLiteral(envPtr, word, numBytes); - } - } else { - CompileTokens(envPtr, incrTokenPtr, interp); - } - } else { /* No incr amount given so use 1. */ - haveImmValue = 1; - } - - /* - * Emit the instruction to increment the variable. - */ - - if (!simpleVarName) { - if (haveImmValue) { - TclEmitInstInt1( INST_INCR_STK_IMM, immValue, envPtr); - } else { - TclEmitOpcode( INST_INCR_STK, envPtr); - } - } else if (isScalar) { /* Simple scalar variable. */ - if (localIndex >= 0) { - if (haveImmValue) { - TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, envPtr); - TclEmitInt1(immValue, envPtr); - } else { - TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr); - } - } else { - if (haveImmValue) { - TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immValue, envPtr); - } else { - TclEmitOpcode( INST_INCR_SCALAR_STK, envPtr); - } - } - } else { /* Simple array variable. */ - if (localIndex >= 0) { - if (haveImmValue) { - TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex, envPtr); - TclEmitInt1(immValue, envPtr); - } else { - TclEmitInstInt1(INST_INCR_ARRAY1, localIndex, envPtr); - } - } else { - if (haveImmValue) { - TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue, envPtr); - } else { - TclEmitOpcode( INST_INCR_ARRAY_STK, envPtr); - } - } - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileInfo*Cmd -- - * - * Procedures called to compile "info" subcommands. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "info" subcommand at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileInfoCommandsCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - Tcl_Token *tokenPtr; - Tcl_Obj *objPtr; - char *bytes; - - /* - * We require one compile-time known argument for the case we can compile. - */ - - if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(parsePtr->tokenPtr); - objPtr = Tcl_NewObj(); - Tcl_IncrRefCount(objPtr); - if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) { - goto notCompilable; - } - bytes = Tcl_GetString(objPtr); - - /* - * We require that the argument start with "::" and not have any of "*\[?" - * in it. (Theoretically, we should look in only the final component, but - * the difference is so slight given current naming practices.) - */ - - if (bytes[0] != ':' || bytes[1] != ':' || !TclMatchIsTrivial(bytes)) { - goto notCompilable; - } - Tcl_DecrRefCount(objPtr); - - /* - * Confirmed as a literal that will not frighten the horses. Compile. Note - * that the result needs to be list-ified. - */ - - CompileWord(envPtr, tokenPtr, interp); - TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr); - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_STR_LEN, envPtr); - TclEmitInstInt1( INST_JUMP_FALSE1, 7, envPtr); - TclEmitInstInt4( INST_LIST, 1, envPtr); - return TCL_OK; - - notCompilable: - Tcl_DecrRefCount(objPtr); - return TCL_ERROR; -} - -int -TclCompileInfoCoroutineCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - /* - * Only compile [info coroutine] without arguments. - */ - - if (parsePtr->numWords != 1) { - return TCL_ERROR; - } - - /* - * Not much to do; we compile to a single instruction... - */ - - TclEmitOpcode( INST_COROUTINE_NAME, envPtr); - return TCL_OK; -} - -int -TclCompileInfoExistsCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr; - int isScalar, simpleVarName, localIndex; - - if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - - /* - * Decide if we can use a frame slot for the var/array name or if we need - * to emit code to compute and push the name at runtime. We use a frame - * slot (entry in the array of local vars) if we are compiling a procedure - * body and if the name is simple text that does not include namespace - * qualifiers. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarName(interp, tokenPtr, envPtr, 0, &localIndex, - &simpleVarName, &isScalar); - - /* - * Emit instruction to check the variable for existence. - */ - - if (!simpleVarName) { - TclEmitOpcode( INST_EXIST_STK, envPtr); - } else if (isScalar) { - if (localIndex < 0) { - TclEmitOpcode( INST_EXIST_STK, envPtr); - } else { - TclEmitInstInt4( INST_EXIST_SCALAR, localIndex, envPtr); - } - } else { - if (localIndex < 0) { - TclEmitOpcode( INST_EXIST_ARRAY_STK, envPtr); - } else { - TclEmitInstInt4( INST_EXIST_ARRAY, localIndex, envPtr); - } - } - - return TCL_OK; -} - -int -TclCompileInfoLevelCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - /* - * Only compile [info level] without arguments or with a single argument. - */ - - if (parsePtr->numWords == 1) { - /* - * Not much to do; we compile to a single instruction... - */ - - TclEmitOpcode( INST_INFO_LEVEL_NUM, envPtr); - } else if (parsePtr->numWords != 2) { - return TCL_ERROR; - } else { - - /* - * Compile the argument, then add the instruction to convert it into a - * list of arguments. - */ - - CompileTokens(envPtr, TokenAfter(parsePtr->tokenPtr), interp); - TclEmitOpcode( INST_INFO_LEVEL_ARGS, envPtr); - } - return TCL_OK; -} - -int -TclCompileInfoObjectClassCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - - if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - CompileWord(envPtr, tokenPtr, interp); - TclEmitOpcode( INST_TCLOO_CLASS, envPtr); - return TCL_OK; -} - -int -TclCompileInfoObjectIsACmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - - /* - * We only handle [info object isa object <somevalue>]. The first three - * words are compressed to a single token by the ensemble compilation - * engine. - */ - - if (parsePtr->numWords != 3) { - return TCL_ERROR; - } - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size < 1 - || strncmp(tokenPtr[1].start, "object", tokenPtr[1].size)) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(tokenPtr); - - /* - * Issue the code. - */ - - CompileWord(envPtr, tokenPtr, interp); - TclEmitOpcode( INST_TCLOO_IS_OBJECT, envPtr); - return TCL_OK; -} - -int -TclCompileInfoObjectNamespaceCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - - if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - CompileWord(envPtr, tokenPtr, interp); - TclEmitOpcode( INST_TCLOO_NS, envPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileLappendCmd -- - * - * Procedure called to compile the "lappend" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "lappend" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileLappendCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *varTokenPtr; - int simpleVarName, isScalar, localIndex, numWords; - - /* - * If we're not in a procedure, don't compile. - */ - - if (envPtr->procPtr == NULL) { - return TCL_ERROR; - } - - numWords = parsePtr->numWords; - if (numWords == 1) { - return TCL_ERROR; - } - if (numWords != 3) { - /* - * LAPPEND instructions currently only handle one value appends. - */ - - return TCL_ERROR; - } - - /* - * Decide if we can use a frame slot for the var/array name or if we - * need to emit code to compute and push the name at runtime. We use a - * frame slot (entry in the array of local vars) if we are compiling a - * procedure body and if the name is simple text that does not include - * namespace qualifiers. - */ - - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - - PushVarName(interp, varTokenPtr, envPtr, 0, - &localIndex, &simpleVarName, &isScalar); - - /* - * If we are doing an assignment, push the new value. In the no values - * case, create an empty object. - */ - - if (numWords > 2) { - Tcl_Token *valueTokenPtr = TokenAfter(varTokenPtr); - - CompileWord(envPtr, valueTokenPtr, interp); - } - - /* - * Emit instructions to set/get the variable. - */ - - /* - * The *_STK opcodes should be refactored to make better use of existing - * LOAD/STORE instructions. - */ - - if (!simpleVarName) { - TclEmitOpcode( INST_LAPPEND_STK, envPtr); - } else if (isScalar) { - if (localIndex < 0) { - TclEmitOpcode( INST_LAPPEND_STK, envPtr); - } else { - Emit14Inst( INST_LAPPEND_SCALAR, localIndex, envPtr); - } - } else { - if (localIndex < 0) { - TclEmitOpcode( INST_LAPPEND_ARRAY_STK, envPtr); - } else { - Emit14Inst( INST_LAPPEND_ARRAY, localIndex, envPtr); - } - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileLassignCmd -- - * - * Procedure called to compile the "lassign" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "lassign" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileLassignCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr; - int simpleVarName, isScalar, localIndex, numWords, idx; - - numWords = parsePtr->numWords; - - /* - * Check for command syntax error, but we'll punt that to runtime. - */ - - if (numWords < 3) { - return TCL_ERROR; - } - - /* - * Generate code to push list being taken apart by [lassign]. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp); - - /* - * Generate code to assign values from the list to variables. - */ - - for (idx=0 ; idx<numWords-2 ; idx++) { - tokenPtr = TokenAfter(tokenPtr); - - /* - * Generate the next variable name. - */ - - PushVarName(interp, tokenPtr, envPtr, 0, &localIndex, - &simpleVarName, &isScalar); - - /* - * Emit instructions to get the idx'th item out of the list value on - * the stack and assign it to the variable. - */ - - if (!simpleVarName) { - TclEmitInstInt4( INST_OVER, 1, envPtr); - TclEmitInstInt4( INST_LIST_INDEX_IMM, idx, envPtr); - TclEmitOpcode( INST_STORE_STK, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } else if (isScalar) { - if (localIndex >= 0) { - TclEmitOpcode( INST_DUP, envPtr); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } else { - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - TclEmitOpcode( INST_STORE_SCALAR_STK, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - } else { - if (localIndex >= 0) { - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } else { - TclEmitInstInt4(INST_OVER, 2, envPtr); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - } - } - - /* - * Generate code to leave the rest of the list on the stack. - */ - - TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr); - TclEmitInt4( -2 /* == "end" */, envPtr); - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileLindexCmd -- - * - * Procedure called to compile the "lindex" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "lindex" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileLindexCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *idxTokenPtr, *valTokenPtr; - int i, numWords = parsePtr->numWords; - - /* - * Quit if too few args. - */ - - if (numWords <= 1) { - return TCL_ERROR; - } - - valTokenPtr = TokenAfter(parsePtr->tokenPtr); - if (numWords != 3) { - goto emitComplexLindex; - } - - idxTokenPtr = TokenAfter(valTokenPtr); - if (idxTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - Tcl_Obj *tmpObj; - int idx, result; - - tmpObj = Tcl_NewStringObj(idxTokenPtr[1].start, idxTokenPtr[1].size); - result = TclGetIntFromObj(NULL, tmpObj, &idx); - if (result == TCL_OK) { - if (idx < 0) { - result = TCL_ERROR; - } - } else { - result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx); - if (result == TCL_OK && idx > -2) { - result = TCL_ERROR; - } - } - TclDecrRefCount(tmpObj); - - if (result == TCL_OK) { - /* - * All checks have been completed, and we have exactly one of - * these constructs: - * lindex <arbitraryValue> <posInt> - * lindex <arbitraryValue> end-<posInt> - * This is best compiled as a push of the arbitrary value followed - * by an "immediate lindex" which is the most efficient variety. - */ - - CompileWord(envPtr, valTokenPtr, interp); - TclEmitInstInt4( INST_LIST_INDEX_IMM, idx, envPtr); - return TCL_OK; - } - - /* - * If the conversion failed or the value was negative, we just keep on - * going with the more complex compilation. - */ - } - - /* - * Push the operands onto the stack. - */ - - emitComplexLindex: - for (i=1 ; i<numWords ; i++) { - CompileWord(envPtr, valTokenPtr, interp); - valTokenPtr = TokenAfter(valTokenPtr); - } - - /* - * Emit INST_LIST_INDEX if objc==3, or INST_LIST_INDEX_MULTI if there are - * multiple index args. - */ - - if (numWords == 3) { - TclEmitOpcode( INST_LIST_INDEX, envPtr); - } else { - TclEmitInstInt4( INST_LIST_INDEX_MULTI, numWords-1, envPtr); - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileListCmd -- - * - * Procedure called to compile the "list" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "list" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileListCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *valueTokenPtr; - int i, numWords; - - /* - * If we're not in a procedure, don't compile. - */ - - if (envPtr->procPtr == NULL) { - return TCL_ERROR; - } - - if (parsePtr->numWords == 1) { - /* - * [list] without arguments just pushes an empty object. - */ - - PushLiteral(envPtr, "", 0); - } else { - /* - * Push the all values onto the stack. - */ - - numWords = parsePtr->numWords; - valueTokenPtr = TokenAfter(parsePtr->tokenPtr); - for (i = 1; i < numWords; i++) { - CompileWord(envPtr, valueTokenPtr, interp); - valueTokenPtr = TokenAfter(valueTokenPtr); - } - TclEmitInstInt4( INST_LIST, numWords - 1, envPtr); - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileLlengthCmd -- - * - * Procedure called to compile the "llength" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "llength" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileLlengthCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *varTokenPtr; - - if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - - CompileWord(envPtr, varTokenPtr, interp); - TclEmitOpcode( INST_LIST_LENGTH, envPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileLrangeCmd -- - * - * How to compile the "lrange" command. We only bother because we needed - * the opcode anyway for "lassign". - * - *---------------------------------------------------------------------- - */ - -int -TclCompileLrangeCmd( - Tcl_Interp *interp, /* Tcl interpreter for context. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the - * command. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds the resulting instructions. */ -{ - Tcl_Token *tokenPtr, *listTokenPtr; - Tcl_Obj *tmpObj; - int idx1, idx2, result; - - if (parsePtr->numWords != 4) { - return TCL_ERROR; - } - listTokenPtr = TokenAfter(parsePtr->tokenPtr); - - /* - * Parse the first index. Will only compile if it is constant and not an - * _integer_ less than zero (since we reserve negative indices here for - * end-relative indexing). - */ - - tokenPtr = TokenAfter(listTokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size); - result = TclGetIntFromObj(NULL, tmpObj, &idx1); - if (result == TCL_OK) { - if (idx1 < 0) { - result = TCL_ERROR; - } - } else { - result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx1); - if (result == TCL_OK && idx1 > -2) { - result = TCL_ERROR; - } - } - TclDecrRefCount(tmpObj); - if (result != TCL_OK) { - return TCL_ERROR; - } - - /* - * Parse the second index. Will only compile if it is constant and not an - * _integer_ less than zero (since we reserve negative indices here for - * end-relative indexing). - */ - - tokenPtr = TokenAfter(tokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size); - result = TclGetIntFromObj(NULL, tmpObj, &idx2); - if (result == TCL_OK) { - if (idx2 < 0) { - result = TCL_ERROR; - } - } else { - result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx2); - if (result == TCL_OK && idx2 > -2) { - result = TCL_ERROR; - } - } - TclDecrRefCount(tmpObj); - if (result != TCL_OK) { - return TCL_ERROR; - } - - /* - * Issue instructions. It's not safe to skip doing the LIST_RANGE, as - * we've not proved that the 'list' argument is really a list. Not that it - * is worth trying to do that given current knowledge. - */ - - CompileWord(envPtr, listTokenPtr, interp); - TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr); - TclEmitInt4( idx2, envPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileLreplaceCmd -- - * - * How to compile the "lreplace" command. We only bother with the case - * where there are no elements to insert and where both the 'first' and - * 'last' arguments are constant and one can be deterined to be at the - * end of the list. (This is the case that could also be written with - * "lrange".) - * - *---------------------------------------------------------------------- - */ - -int -TclCompileLreplaceCmd( - Tcl_Interp *interp, /* Tcl interpreter for context. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the - * command. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds the resulting instructions. */ -{ - Tcl_Token *tokenPtr, *listTokenPtr; - Tcl_Obj *tmpObj; - int idx1, idx2, result, guaranteedDropAll = 0; - - if (parsePtr->numWords != 4) { - return TCL_ERROR; - } - listTokenPtr = TokenAfter(parsePtr->tokenPtr); - - /* - * Parse the first index. Will only compile if it is constant and not an - * _integer_ less than zero (since we reserve negative indices here for - * end-relative indexing). - */ - - tokenPtr = TokenAfter(listTokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size); - result = TclGetIntFromObj(NULL, tmpObj, &idx1); - if (result == TCL_OK) { - if (idx1 < 0) { - result = TCL_ERROR; - } - } else { - result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx1); - if (result == TCL_OK && idx1 > -2) { - result = TCL_ERROR; - } - } - TclDecrRefCount(tmpObj); - if (result != TCL_OK) { - return TCL_ERROR; - } - - /* - * Parse the second index. Will only compile if it is constant and not an - * _integer_ less than zero (since we reserve negative indices here for - * end-relative indexing). - */ - - tokenPtr = TokenAfter(tokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size); - result = TclGetIntFromObj(NULL, tmpObj, &idx2); - if (result == TCL_OK) { - if (idx2 < 0) { - result = TCL_ERROR; - } - } else { - result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx2); - if (result == TCL_OK && idx2 > -2) { - result = TCL_ERROR; - } - } - TclDecrRefCount(tmpObj); - if (result != TCL_OK) { - return TCL_ERROR; - } - - /* - * Sanity check: can only issue when we're removing a range at one or - * other end of the list. If we're at one end or the other, convert the - * indices into the equivalent for an [lrange]. - */ - - if (idx1 == 0) { - if (idx2 == -2) { - guaranteedDropAll = 1; - } - idx1 = idx2 + 1; - idx2 = -2; - } else if (idx2 == -2) { - idx2 = idx1 - 1; - idx1 = 0; - } else { - return TCL_ERROR; - } - - /* - * Issue instructions. It's not safe to skip doing the LIST_RANGE, as - * we've not proved that the 'list' argument is really a list. Not that it - * is worth trying to do that given current knowledge. - */ - - CompileWord(envPtr, listTokenPtr, interp); - if (guaranteedDropAll) { - TclEmitOpcode( INST_LIST_LENGTH, envPtr); - TclEmitOpcode( INST_POP, envPtr); - PushLiteral(envPtr, "", 0); - } else { - TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr); - TclEmitInt4( idx2, envPtr); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileLsetCmd -- - * - * Procedure called to compile the "lset" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "lset" command at - * runtime. - * - * The general template for execution of the "lset" command is: - * (1) Instructions to push the variable name, unless the variable is - * local to the stack frame. - * (2) If the variable is an array element, instructions to push the - * array element name. - * (3) Instructions to push each of zero or more "index" arguments to the - * stack, followed with the "newValue" element. - * (4) Instructions to duplicate the variable name and/or array element - * name onto the top of the stack, if either was pushed at steps (1) - * and (2). - * (5) The appropriate INST_LOAD_* instruction to place the original - * value of the list variable at top of stack. - * (6) At this point, the stack contains: - * varName? arrayElementName? index1 index2 ... newValue oldList - * The compiler emits one of INST_LSET_FLAT or INST_LSET_LIST - * according as whether there is exactly one index element (LIST) or - * either zero or else two or more (FLAT). This instruction removes - * everything from the stack except for the two names and pushes the - * new value of the variable. - * (7) Finally, INST_STORE_* stores the new value in the variable and - * cleans up the stack. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileLsetCmd( - Tcl_Interp *interp, /* Tcl interpreter for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the - * command. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds the resulting instructions. */ -{ - int tempDepth; /* Depth used for emitting one part of the - * code burst. */ - Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the - * parse of the variable name. */ - int localIndex; /* Index of var in local var table. */ - int simpleVarName; /* Flag == 1 if var name is simple. */ - int isScalar; /* Flag == 1 if scalar, 0 if array. */ - int i; - - /* - * Check argument count. - */ - - if (parsePtr->numWords < 3) { - /* - * Fail at run time, not in compilation. - */ - - return TCL_ERROR; - } - - /* - * Decide if we can use a frame slot for the var/array name or if we need - * to emit code to compute and push the name at runtime. We use a frame - * slot (entry in the array of local vars) if we are compiling a procedure - * body and if the name is simple text that does not include namespace - * qualifiers. - */ - - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarName(interp, varTokenPtr, envPtr, 0, - &localIndex, &simpleVarName, &isScalar); - - /* - * Push the "index" args and the new element value. - */ - - for (i=2 ; i<parsePtr->numWords ; ++i) { - varTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, varTokenPtr, interp); - } - - /* - * Duplicate the variable name if it's been pushed. - */ - - if (!simpleVarName || localIndex < 0) { - if (!simpleVarName || isScalar) { - tempDepth = parsePtr->numWords - 2; - } else { - tempDepth = parsePtr->numWords - 1; - } - TclEmitInstInt4( INST_OVER, tempDepth, envPtr); - } - - /* - * Duplicate an array index if one's been pushed. - */ - - if (simpleVarName && !isScalar) { - if (localIndex < 0) { - tempDepth = parsePtr->numWords - 1; - } else { - tempDepth = parsePtr->numWords - 2; - } - TclEmitInstInt4( INST_OVER, tempDepth, envPtr); - } - - /* - * Emit code to load the variable's value. - */ - - if (!simpleVarName) { - TclEmitOpcode( INST_LOAD_STK, envPtr); - } else if (isScalar) { - if (localIndex < 0) { - TclEmitOpcode( INST_LOAD_SCALAR_STK, envPtr); - } else { - Emit14Inst( INST_LOAD_SCALAR, localIndex, envPtr); - } - } else { - if (localIndex < 0) { - TclEmitOpcode( INST_LOAD_ARRAY_STK, envPtr); - } else { - Emit14Inst( INST_LOAD_ARRAY, localIndex, envPtr); - } - } - - /* - * Emit the correct variety of 'lset' instruction. - */ - - if (parsePtr->numWords == 4) { - TclEmitOpcode( INST_LSET_LIST, envPtr); - } else { - TclEmitInstInt4( INST_LSET_FLAT, parsePtr->numWords-1, envPtr); - } - - /* - * Emit code to put the value back in the variable. - */ - - if (!simpleVarName) { - TclEmitOpcode( INST_STORE_STK, envPtr); - } else if (isScalar) { - if (localIndex < 0) { - TclEmitOpcode( INST_STORE_SCALAR_STK, envPtr); - } else { - Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); - } - } else { - if (localIndex < 0) { - TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr); - } else { - Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); - } - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileLmapCmd -- - * - * Procedure called to compile the "lmap" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "lmap" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileLmapCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - return CompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr, - TCL_EACH_COLLECT); -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileNamespace*Cmd -- - * - * Procedures called to compile the "namespace" command; currently, only - * the subcommands "namespace current" and "namespace upvar" are compiled - * to bytecodes, and the latter only inside a procedure(-like) context. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "namespace upvar" - * command at runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileNamespaceCurrentCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - /* - * Only compile [namespace current] without arguments. - */ - - if (parsePtr->numWords != 1) { - return TCL_ERROR; - } - - /* - * Not much to do; we compile to a single instruction... - */ - - TclEmitOpcode( INST_NS_CURRENT, envPtr); - return TCL_OK; -} - -int -TclCompileNamespaceCodeCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr; - - if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(parsePtr->tokenPtr); - - /* - * The specification of [namespace code] is rather shocking, in that it is - * supposed to check if the argument is itself the result of [namespace - * code] and not apply itself in that case. Which is excessively cautious, - * but what the test suite checks for. - */ - - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || (tokenPtr[1].size > 20 - && strncmp(tokenPtr[1].start, "::namespace inscope ", 20) == 0)) { - /* - * Technically, we could just pass a literal '::namespace inscope ' - * term through, but that's something which really shouldn't be - * occurring as something that the user writes so we'll just punt it. - */ - - return TCL_ERROR; - } - - /* - * Now we can compile using the same strategy as [namespace code]'s normal - * implementation does internally. Note that we can't bind the namespace - * name directly here, because TclOO plays complex games with namespaces; - * the value needs to be determined at runtime for safety. - */ - - PushLiteral(envPtr, "::namespace", 11); - PushLiteral(envPtr, "inscope", 7); - TclEmitOpcode( INST_NS_CURRENT, envPtr); - CompileWord(envPtr, tokenPtr, interp); - TclEmitInstInt4( INST_LIST, 4, envPtr); - return TCL_OK; -} - -int -TclCompileNamespaceQualifiersCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - int off; - - if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - - CompileWord(envPtr, tokenPtr, interp); - PushLiteral(envPtr, "0", 1); - PushLiteral(envPtr, "::", 2); - TclEmitInstInt4( INST_OVER, 2, envPtr); - TclEmitOpcode( INST_STR_FIND_LAST, envPtr); - off = CurrentOffset(envPtr); - PushLiteral(envPtr, "1", 1); - TclEmitOpcode( INST_SUB, envPtr); - TclEmitInstInt4( INST_OVER, 2, envPtr); - TclEmitInstInt4( INST_OVER, 1, envPtr); - TclEmitOpcode( INST_STR_INDEX, envPtr); - PushLiteral(envPtr, ":", 1); - TclEmitOpcode( INST_STR_EQ, envPtr); - off = off - CurrentOffset(envPtr); - TclEmitInstInt1( INST_JUMP_TRUE1, off, envPtr); - TclEmitOpcode( INST_STR_RANGE, envPtr); - return TCL_OK; -} - -int -TclCompileNamespaceTailCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - JumpFixup jumpFixup; - - if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - - /* - * Take care; only add 2 to found index if the string was actually found. - */ - - CompileWord(envPtr, tokenPtr, interp); - PushLiteral(envPtr, "::", 2); - TclEmitInstInt4( INST_OVER, 1, envPtr); - TclEmitOpcode( INST_STR_FIND_LAST, envPtr); - TclEmitOpcode( INST_DUP, envPtr); - PushLiteral(envPtr, "0", 1); - TclEmitOpcode( INST_GE, envPtr); - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFixup); - PushLiteral(envPtr, "2", 1); - TclEmitOpcode( INST_ADD, envPtr); - TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127); - PushLiteral(envPtr, "end", 3); - TclEmitOpcode( INST_STR_RANGE, envPtr); - return TCL_OK; -} - -int -TclCompileNamespaceUpvarCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; - int simpleVarName, isScalar, localIndex, numWords, i; - - if (envPtr->procPtr == NULL) { - return TCL_ERROR; - } - - /* - * Only compile [namespace upvar ...]: needs an even number of args, >=4 - */ - - numWords = parsePtr->numWords; - if ((numWords % 2) || (numWords < 4)) { - return TCL_ERROR; - } - - /* - * Push the namespace - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp); - - /* - * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a - * local variable, return an error so that the non-compiled command will - * be called at runtime. - */ - - localTokenPtr = tokenPtr; - for (i=3; i<=numWords; i+=2) { - otherTokenPtr = TokenAfter(localTokenPtr); - localTokenPtr = TokenAfter(otherTokenPtr); - - CompileWord(envPtr, otherTokenPtr, interp); - PushVarName(interp, localTokenPtr, envPtr, 0, - &localIndex, &simpleVarName, &isScalar); - - if ((localIndex < 0) || !isScalar) { - return TCL_ERROR; - } - TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr); - } - - /* - * Pop the namespace, and set the result to empty - */ - - TclEmitOpcode( INST_POP, envPtr); - PushLiteral(envPtr, "", 0); - return TCL_OK; -} - -int -TclCompileNamespaceWhichCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr, *opt; - int idx; - - if (parsePtr->numWords < 2 || parsePtr->numWords > 3) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(parsePtr->tokenPtr); - idx = 1; - - /* - * If there's an option, check that it's "-command". We don't handle - * "-variable" (currently) and anything else is an error. - */ - - if (parsePtr->numWords == 3) { - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - opt = tokenPtr + 1; - if (opt->size < 2 || opt->size > 8 - || strncmp(opt->start, "-command", opt->size) != 0) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(tokenPtr); - idx++; - } - - /* - * Issue the bytecode. - */ - - CompileWord(envPtr, tokenPtr, interp); - TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileRegexpCmd -- - * - * Procedure called to compile the "regexp" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "regexp" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileRegexpCmd( - Tcl_Interp *interp, /* Tcl interpreter for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the - * command. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds the resulting instructions. */ -{ - Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the - * parse of the RE or string. */ - int i, len, nocase, exact, sawLast, simple; - const char *str; - - /* - * We are only interested in compiling simple regexp cases. Currently - * supported compile cases are: - * regexp ?-nocase? ?--? staticString $var - * regexp ?-nocase? ?--? {^staticString$} $var - */ - - if (parsePtr->numWords < 3) { - return TCL_ERROR; - } - - simple = 0; - nocase = 0; - sawLast = 0; - varTokenPtr = parsePtr->tokenPtr; - - /* - * We only look for -nocase and -- as options. Everything else gets pushed - * to runtime execution. This is different than regexp's runtime option - * handling, but satisfies our stricter needs. - */ - - for (i = 1; i < parsePtr->numWords - 2; i++) { - varTokenPtr = TokenAfter(varTokenPtr); - if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - /* - * Not a simple string, so punt to runtime. - */ - - return TCL_ERROR; - } - str = varTokenPtr[1].start; - len = varTokenPtr[1].size; - if ((len == 2) && (str[0] == '-') && (str[1] == '-')) { - sawLast++; - i++; - break; - } else if ((len > 1) && (strncmp(str,"-nocase",(unsigned)len) == 0)) { - nocase = 1; - } else { - /* - * Not an option we recognize. - */ - - return TCL_ERROR; - } - } - - if ((parsePtr->numWords - i) != 2) { - /* - * We don't support capturing to variables. - */ - - return TCL_ERROR; - } - - /* - * Get the regexp string. If it is not a simple string or can't be - * converted to a glob pattern, push the word for the INST_REGEXP. - * Keep changes here in sync with TclCompileSwitchCmd Switch_Regexp. - */ - - varTokenPtr = TokenAfter(varTokenPtr); - - if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - Tcl_DString ds; - - str = varTokenPtr[1].start; - len = varTokenPtr[1].size; - - /* - * If it has a '-', it could be an incorrectly formed regexp command. - */ - - if ((*str == '-') && !sawLast) { - return TCL_ERROR; - } - - if (len == 0) { - /* - * The semantics of regexp are always match on re == "". - */ - - PushLiteral(envPtr, "1", 1); - return TCL_OK; - } - - /* - * Attempt to convert pattern to glob. If successful, push the - * converted pattern as a literal. - */ - - if (TclReToGlob(NULL, varTokenPtr[1].start, len, &ds, &exact) - == TCL_OK) { - simple = 1; - PushLiteral(envPtr, Tcl_DStringValue(&ds),Tcl_DStringLength(&ds)); - Tcl_DStringFree(&ds); - } - } - - if (!simple) { - CompileWord(envPtr, varTokenPtr, interp); - } - - /* - * Push the string arg. - */ - - varTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, varTokenPtr, interp); - - if (simple) { - if (exact && !nocase) { - TclEmitOpcode( INST_STR_EQ, envPtr); - } else { - TclEmitInstInt1( INST_STR_MATCH, nocase, envPtr); - } - } else { - /* - * Pass correct RE compile flags. We use only Int1 (8-bit), but - * that handles all the flags we want to pass. - * Don't use TCL_REG_NOSUB as we may have backrefs. - */ - - int cflags = TCL_REG_ADVANCED | (nocase ? TCL_REG_NOCASE : 0); - - TclEmitInstInt1( INST_REGEXP, cflags, envPtr); - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileRegsubCmd -- - * - * Procedure called to compile the "regsub" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "regsub" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileRegsubCmd( - Tcl_Interp *interp, /* Tcl interpreter for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the - * command. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds the resulting instructions. */ -{ - /* - * We only compile the case with [regsub -all] where the pattern is both - * known at compile time and simple (i.e., no RE metacharacters). That is, - * the pattern must be translatable into a glob like "*foo*" with no other - * glob metacharacters inside it; there must be some "foo" in there too. - * The substitution string must also be known at compile time and free of - * metacharacters ("\digit" and "&"). Finally, there must not be a - * variable mentioned in the [regsub] to write the result back to (because - * we can't get the count of substitutions that would be the result in - * that case). The key is that these are the conditions under which a - * [string map] could be used instead, in particular a [string map] of the - * form we can compile to bytecode. - * - * In short, we look for: - * - * regsub -all [--] simpleRE string simpleReplacement - * - * The only optional part is the "--", and no other options are handled. - */ - - Tcl_Token *tokenPtr, *stringTokenPtr; - Tcl_Obj *patternObj = NULL, *replacementObj = NULL; - Tcl_DString pattern; - const char *bytes; - int len, exact, result = TCL_ERROR; - - if (parsePtr->numWords < 5 || parsePtr->numWords > 6) { - return TCL_ERROR; - } - - /* - * Parse the "-all", which must be the first argument (other options not - * supported, non-"-all" substitution we can't compile). - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size != 4 - || strncmp(tokenPtr[1].start, "-all", 4)) { - return TCL_ERROR; - } - - /* - * Get the pattern into patternObj, checking for "--" in the process. - */ - - Tcl_DStringInit(&pattern); - tokenPtr = TokenAfter(tokenPtr); - patternObj = Tcl_NewObj(); - if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) { - goto done; - } - if (Tcl_GetString(patternObj)[0] == '-') { - if (strcmp(Tcl_GetString(patternObj), "--") != 0 - || parsePtr->numWords == 5) { - goto done; - } - tokenPtr = TokenAfter(tokenPtr); - Tcl_DecrRefCount(patternObj); - patternObj = Tcl_NewObj(); - if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) { - goto done; - } - } else if (parsePtr->numWords == 6) { - goto done; - } - - /* - * Identify the code which produces the string to apply the substitution - * to (stringTokenPtr), and the replacement string (into replacementObj). - */ - - stringTokenPtr = TokenAfter(tokenPtr); - tokenPtr = TokenAfter(stringTokenPtr); - replacementObj = Tcl_NewObj(); - if (!TclWordKnownAtCompileTime(tokenPtr, replacementObj)) { - goto done; - } - - /* - * Next, higher-level checks. Is the RE a very simple glob? Is the - * replacement "simple"? - */ - - bytes = Tcl_GetStringFromObj(patternObj, &len); - if (TclReToGlob(NULL, bytes, len, &pattern, &exact) != TCL_OK || exact) { - goto done; - } - bytes = Tcl_DStringValue(&pattern); - if (*bytes++ != '*') { - goto done; - } - while (1) { - switch (*bytes) { - case '*': - if (bytes[1] == '\0') { - /* - * OK, we've proved there are no metacharacters except for the - * '*' at each end. - */ - - len = Tcl_DStringLength(&pattern) - 2; - if (len > 0) { - goto isSimpleGlob; - } - - /* - * The pattern is "**"! I believe that should be impossible, - * but we definitely can't handle that at all. - */ - } - case '\0': case '?': case '[': case '\\': - goto done; - } - bytes++; - } - isSimpleGlob: - for (bytes = Tcl_GetString(replacementObj); *bytes; bytes++) { - switch (*bytes) { - case '\\': case '&': - goto done; - } - } - - /* - * Proved the simplicity constraints! Time to issue the code. - */ - - result = TCL_OK; - bytes = Tcl_DStringValue(&pattern) + 1; - PushLiteral(envPtr, bytes, len); - bytes = Tcl_GetStringFromObj(replacementObj, &len); - PushLiteral(envPtr, bytes, len); - CompileWord(envPtr, stringTokenPtr, interp); - TclEmitOpcode( INST_STR_MAP, envPtr); - - done: - Tcl_DStringFree(&pattern); - if (patternObj) { - Tcl_DecrRefCount(patternObj); - } - if (replacementObj) { - Tcl_DecrRefCount(replacementObj); - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileReturnCmd -- - * - * Procedure called to compile the "return" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "return" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileReturnCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - /* - * General syntax: [return ?-option value ...? ?result?] - * An even number of words means an explicit result argument is present. - */ - int level, code, objc, size, status = TCL_OK; - int numWords = parsePtr->numWords; - int explicitResult = (0 == (numWords % 2)); - int numOptionWords = numWords - 1 - explicitResult; - int savedStackDepth = envPtr->currStackDepth; - Tcl_Obj *returnOpts, **objv; - Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr); - - /* - * Check for special case which can always be compiled: - * return -options <opts> <msg> - * Unlike the normal [return] compilation, this version does everything at - * runtime so it can handle arbitrary words and not just literals. Note - * that if INST_RETURN_STK wasn't already needed for something else - * ('finally' clause processing) this piece of code would not be present. - */ - - if ((numWords == 4) && (wordTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) - && (wordTokenPtr[1].size == 8) - && (strncmp(wordTokenPtr[1].start, "-options", 8) == 0)) { - Tcl_Token *optsTokenPtr = TokenAfter(wordTokenPtr); - Tcl_Token *msgTokenPtr = TokenAfter(optsTokenPtr); - - CompileWord(envPtr, optsTokenPtr, interp); - CompileWord(envPtr, msgTokenPtr, interp); - TclEmitOpcode(INST_RETURN_STK, envPtr); - envPtr->currStackDepth = savedStackDepth + 1; - return TCL_OK; - } - - /* - * Allocate some working space. - */ - - objv = TclStackAlloc(interp, numOptionWords * sizeof(Tcl_Obj *)); - - /* - * Scan through the return options. If any are unknown at compile time, - * there is no value in bytecompiling. Save the option values known in an - * objv array for merging into a return options dictionary. - */ - - for (objc = 0; objc < numOptionWords; objc++) { - objv[objc] = Tcl_NewObj(); - Tcl_IncrRefCount(objv[objc]); - if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) { - objc++; - status = TCL_ERROR; - goto cleanup; - } - wordTokenPtr = TokenAfter(wordTokenPtr); - } - status = TclMergeReturnOptions(interp, objc, objv, - &returnOpts, &code, &level); - cleanup: - while (--objc >= 0) { - TclDecrRefCount(objv[objc]); - } - TclStackFree(interp, objv); - if (TCL_ERROR == status) { - /* - * Something was bogus in the return options. Clear the error message, - * and report back to the compiler that this must be interpreted at - * runtime. - */ - - Tcl_ResetResult(interp); - return TCL_ERROR; - } - - /* - * All options are known at compile time, so we're going to bytecompile. - * Emit instructions to push the result on the stack. - */ - - if (explicitResult) { - CompileWord(envPtr, wordTokenPtr, interp); - } else { - /* - * No explict result argument, so default result is empty string. - */ - - PushLiteral(envPtr, "", 0); - } - - /* - * Check for optimization: When [return] is in a proc, and there's no - * enclosing [catch], and there are no return options, then the INST_DONE - * instruction is equivalent, and may be more efficient. - */ - - if (numOptionWords == 0 && envPtr->procPtr != NULL) { - /* - * We have default return options and we're in a proc ... - */ - - int index = envPtr->exceptArrayNext - 1; - int enclosingCatch = 0; - - while (index >= 0) { - ExceptionRange range = envPtr->exceptArrayPtr[index]; - - if ((range.type == CATCH_EXCEPTION_RANGE) - && (range.catchOffset == -1)) { - enclosingCatch = 1; - break; - } - index--; - } - if (!enclosingCatch) { - /* - * ... and there is no enclosing catch. Issue the maximally - * efficient exit instruction. - */ - - Tcl_DecrRefCount(returnOpts); - TclEmitOpcode(INST_DONE, envPtr); - return TCL_OK; - } - } - - /* Optimize [return -level 0 $x]. */ - Tcl_DictObjSize(NULL, returnOpts, &size); - if (size == 0 && level == 0 && code == TCL_OK) { - Tcl_DecrRefCount(returnOpts); - return TCL_OK; - } - - /* - * Could not use the optimization, so we push the return options dict, and - * emit the INST_RETURN_IMM instruction with code and level as operands. - */ - - CompileReturnInternal(envPtr, INST_RETURN_IMM, code, level, returnOpts); - return TCL_OK; -} - static void CompileReturnInternal( CompileEnv *envPtr, @@ -5536,586 +79,10 @@ TclCompileSyntaxError( CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0, Tcl_GetReturnOptions(interp, TCL_ERROR)); } - -/* - *---------------------------------------------------------------------- - * - * TclCompileUpvarCmd -- - * - * Procedure called to compile the "upvar" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "upvar" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileUpvarCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; - int simpleVarName, isScalar, localIndex, numWords, i; - Tcl_Obj *objPtr = Tcl_NewObj(); - - if (envPtr->procPtr == NULL) { - Tcl_DecrRefCount(objPtr); - return TCL_ERROR; - } - - numWords = parsePtr->numWords; - if (numWords < 3) { - Tcl_DecrRefCount(objPtr); - return TCL_ERROR; - } - - /* - * Push the frame index if it is known at compile time - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - if (TclWordKnownAtCompileTime(tokenPtr, objPtr)) { - CallFrame *framePtr; - const Tcl_ObjType *newTypePtr, *typePtr = objPtr->typePtr; - - /* - * Attempt to convert to a level reference. Note that TclObjGetFrame - * only changes the obj type when a conversion was successful. - */ - - TclObjGetFrame(interp, objPtr, &framePtr); - newTypePtr = objPtr->typePtr; - Tcl_DecrRefCount(objPtr); - - if (newTypePtr != typePtr) { - if (numWords%2) { - return TCL_ERROR; - } - CompileWord(envPtr, tokenPtr, interp); - otherTokenPtr = TokenAfter(tokenPtr); - i = 4; - } else { - if (!(numWords%2)) { - return TCL_ERROR; - } - PushLiteral(envPtr, "1", 1); - otherTokenPtr = tokenPtr; - i = 3; - } - } else { - Tcl_DecrRefCount(objPtr); - return TCL_ERROR; - } - - /* - * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a - * local variable, return an error so that the non-compiled command will - * be called at runtime. - */ - - for (; i<=numWords; i+=2, otherTokenPtr = TokenAfter(localTokenPtr)) { - localTokenPtr = TokenAfter(otherTokenPtr); - - CompileWord(envPtr, otherTokenPtr, interp); - PushVarName(interp, localTokenPtr, envPtr, 0, - &localIndex, &simpleVarName, &isScalar); - - if ((localIndex < 0) || !isScalar) { - return TCL_ERROR; - } - TclEmitInstInt4( INST_UPVAR, localIndex, envPtr); - } - - /* - * Pop the frame index, and set the result to empty - */ - - TclEmitOpcode( INST_POP, envPtr); - PushLiteral(envPtr, "", 0); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileVariableCmd -- - * - * Procedure called to compile the "variable" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "variable" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileVariableCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *varTokenPtr, *valueTokenPtr; - int localIndex, numWords, i; - - numWords = parsePtr->numWords; - if (numWords < 2) { - return TCL_ERROR; - } - - /* - * Bail out if not compiling a proc body - */ - - if (envPtr->procPtr == NULL) { - return TCL_ERROR; - } - - /* - * Loop over the (var, value) pairs. - */ - - valueTokenPtr = parsePtr->tokenPtr; - for (i=1; i<numWords; i+=2) { - varTokenPtr = TokenAfter(valueTokenPtr); - valueTokenPtr = TokenAfter(varTokenPtr); - - localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr); - - if (localIndex < 0) { - return TCL_ERROR; - } - - CompileWord(envPtr, varTokenPtr, interp); - TclEmitInstInt4( INST_VARIABLE, localIndex, envPtr); - - if (i+1 < numWords) { - /* - * A value has been given: set the variable, pop the value - */ - - CompileWord(envPtr, valueTokenPtr, interp); - Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - } - - /* - * Set the result to empty - */ - - PushLiteral(envPtr, "", 0); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * IndexTailVarIfKnown -- - * - * Procedure used in compiling [global] and [variable] commands. It - * inspects the variable name described by varTokenPtr and, if the tail - * is known at compile time, defines a corresponding local variable. - * - * Results: - * Returns the variable's index in the table of compiled locals if the - * tail is known at compile time, or -1 otherwise. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ -static int -IndexTailVarIfKnown( - Tcl_Interp *interp, - Tcl_Token *varTokenPtr, /* Token representing the variable name */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Obj *tailPtr; - const char *tailName, *p; - int len, n = varTokenPtr->numComponents; - Tcl_Token *lastTokenPtr; - int full, localIndex; - - /* - * Determine if the tail is (a) known at compile time, and (b) not an - * array element. Should any of these fail, return an error so that the - * non-compiled command will be called at runtime. - * - * In order for the tail to be known at compile time, the last token in - * the word has to be constant and contain "::" if it is not the only one. - */ - - if (!EnvHasLVT(envPtr)) { - return -1; - } - TclNewObj(tailPtr); - if (TclWordKnownAtCompileTime(varTokenPtr, tailPtr)) { - full = 1; - lastTokenPtr = varTokenPtr; - } else { - full = 0; - lastTokenPtr = varTokenPtr + n; - if (!TclWordKnownAtCompileTime(lastTokenPtr, tailPtr)) { - Tcl_DecrRefCount(tailPtr); - return -1; - } - } - - tailName = TclGetStringFromObj(tailPtr, &len); - - if (len) { - if (*(tailName+len-1) == ')') { - /* - * Possible array: bail out - */ - - Tcl_DecrRefCount(tailPtr); - return -1; - } - - /* - * Get the tail: immediately after the last '::' - */ - - for (p = tailName + len -1; p > tailName; p--) { - if ((*p == ':') && (*(p-1) == ':')) { - p++; - break; - } - } - if (!full && (p == tailName)) { - /* - * No :: in the last component. - */ - - Tcl_DecrRefCount(tailPtr); - return -1; - } - len -= p - tailName; - tailName = p; - } - - localIndex = TclFindCompiledLocal(tailName, len, 1, envPtr); - Tcl_DecrRefCount(tailPtr); - return localIndex; -} -int -TclCompileObjectSelfCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - /* - * We only handle [self] and [self object] (which is the same operation). - * These are the only very common operations on [self] for which - * bytecoding is at all reasonable. - */ - - if (parsePtr->numWords == 1) { - goto compileSelfObject; - } else if (parsePtr->numWords == 2) { - Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr), *subcmd; - - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size==0) { - return TCL_ERROR; - } - - subcmd = tokenPtr + 1; - if (strncmp(subcmd->start, "object", subcmd->size) == 0) { - goto compileSelfObject; - } else if (strncmp(subcmd->start, "namespace", subcmd->size) == 0) { - goto compileSelfNamespace; - } - } - - /* - * Can't compile; handle with runtime call. - */ - - return TCL_ERROR; - - compileSelfObject: - - /* - * This delegates the entire problem to a single opcode. - */ - - TclEmitOpcode( INST_TCLOO_SELF, envPtr); - return TCL_OK; - - compileSelfNamespace: - - /* - * This is formally only correct with TclOO methods as they are currently - * implemented; it assumes that the current namespace is invariably when a - * TclOO context is present is the object's namespace, and that's - * technically only something that's a matter of current policy. But it - * avoids creating another opcode, so that's all good! - */ - TclEmitOpcode( INST_TCLOO_SELF, envPtr); - TclEmitOpcode( INST_POP, envPtr); - TclEmitOpcode( INST_NS_CURRENT, envPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * PushVarName -- - * - * Procedure used in the compiling where pushing a variable name is - * necessary (append, lappend, set). - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "set" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -static int -PushVarName( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Token *varTokenPtr, /* Points to a variable token. */ - CompileEnv *envPtr, /* Holds resulting instructions. */ - int flags, /* TCL_NO_LARGE_INDEX. */ - int *localIndexPtr, /* Must not be NULL. */ - int *simpleVarNamePtr, /* Must not be NULL. */ - int *isScalarPtr) /* Must not be NULL. */ -{ - register const char *p; - const char *name, *elName; - register int i, n; - Tcl_Token *elemTokenPtr = NULL; - int nameChars, elNameChars, simpleVarName, localIndex; - int elemTokenCount = 0, allocedTokens = 0, removedParen = 0; - - /* - * Decide if we can use a frame slot for the var/array name or if we need - * to emit code to compute and push the name at runtime. We use a frame - * slot (entry in the array of local vars) if we are compiling a procedure - * body and if the name is simple text that does not include namespace - * qualifiers. - */ - - simpleVarName = 0; - name = elName = NULL; - nameChars = elNameChars = 0; - localIndex = -1; - - /* - * Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether - * curly braces surround the variable name. This really matters for array - * elements to handle things like - * set {x($foo)} 5 - * which raises an undefined var error if we are not careful here. - */ - - if ((varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) && - (varTokenPtr->start[0] != '{')) { - /* - * A simple variable name. Divide it up into "name" and "elName" - * strings. If it is not a local variable, look it up at runtime. - */ - - simpleVarName = 1; - - name = varTokenPtr[1].start; - nameChars = varTokenPtr[1].size; - if (name[nameChars-1] == ')') { - /* - * last char is ')' => potential array reference. - */ - - for (i=0,p=name ; i<nameChars ; i++,p++) { - if (*p == '(') { - elName = p + 1; - elNameChars = nameChars - i - 2; - nameChars = i; - break; - } - } - - if ((elName != NULL) && elNameChars) { - /* - * An array element, the element name is a simple string: - * assemble the corresponding token. - */ - - elemTokenPtr = TclStackAlloc(interp, sizeof(Tcl_Token)); - allocedTokens = 1; - elemTokenPtr->type = TCL_TOKEN_TEXT; - elemTokenPtr->start = elName; - elemTokenPtr->size = elNameChars; - elemTokenPtr->numComponents = 0; - elemTokenCount = 1; - } - } - } else if (((n = varTokenPtr->numComponents) > 1) - && (varTokenPtr[1].type == TCL_TOKEN_TEXT) - && (varTokenPtr[n].type == TCL_TOKEN_TEXT) - && (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) { - /* - * Check for parentheses inside first token. - */ - - simpleVarName = 0; - for (i = 0, p = varTokenPtr[1].start; - i < varTokenPtr[1].size; i++, p++) { - if (*p == '(') { - simpleVarName = 1; - break; - } - } - if (simpleVarName) { - int remainingChars; - - /* - * Check the last token: if it is just ')', do not count it. - * Otherwise, remove the ')' and flag so that it is restored at - * the end. - */ - - if (varTokenPtr[n].size == 1) { - n--; - } else { - varTokenPtr[n].size--; - removedParen = n; - } - - name = varTokenPtr[1].start; - nameChars = p - varTokenPtr[1].start; - elName = p + 1; - remainingChars = (varTokenPtr[2].start - p) - 1; - elNameChars = (varTokenPtr[n].start-p) + varTokenPtr[n].size - 2; - - if (remainingChars) { - /* - * Make a first token with the extra characters in the first - * token. - */ - - elemTokenPtr = TclStackAlloc(interp, n * sizeof(Tcl_Token)); - allocedTokens = 1; - elemTokenPtr->type = TCL_TOKEN_TEXT; - elemTokenPtr->start = elName; - elemTokenPtr->size = remainingChars; - elemTokenPtr->numComponents = 0; - elemTokenCount = n; - - /* - * Copy the remaining tokens. - */ - - memcpy(elemTokenPtr+1, varTokenPtr+2, - (n-1) * sizeof(Tcl_Token)); - } else { - /* - * Use the already available tokens. - */ - - elemTokenPtr = &varTokenPtr[2]; - elemTokenCount = n - 1; - } - } - } - - if (simpleVarName) { - /* - * See whether name has any namespace separators (::'s). - */ - - int hasNsQualifiers = 0; - - for (i = 0, p = name; i < nameChars; i++, p++) { - if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) { - hasNsQualifiers = 1; - break; - } - } - - /* - * Look up the var name's index in the array of local vars in the proc - * frame. If retrieving the var's value and it doesn't already exist, - * push its name and look it up at runtime. - */ - - if (!hasNsQualifiers) { - localIndex = TclFindCompiledLocal(name, nameChars, - 1, envPtr); - if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) { - /* - * We'll push the name. - */ - - localIndex = -1; - } - } - if (localIndex < 0) { - PushLiteral(envPtr, name, nameChars); - } - - /* - * Compile the element script, if any. - */ - - if (elName != NULL) { - if (elNameChars) { - TclCompileTokens(interp, elemTokenPtr, elemTokenCount, - envPtr); - } else { - PushLiteral(envPtr, "", 0); - } - } - } else { - /* - * The var name isn't simple: compile and push it. - */ - CompileTokens(envPtr, varTokenPtr, interp); - } - - if (removedParen) { - varTokenPtr[removedParen].size++; - } - if (allocedTokens) { - TclStackFree(interp, elemTokenPtr); - } - *localIndexPtr = localIndex; - *simpleVarNamePtr = simpleVarName; - *isScalarPtr = (elName == NULL); - return TCL_OK; -} - /* * Local Variables: * mode: c diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index ba94b27..c27f644 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -16,21 +16,12 @@ */ #include "tclInt.h" -#include "tclCompile.h" +#include "tclCompileInt.h" /* * Prototypes for procedures defined later in this file: */ -static ClientData DupJumptableInfo(ClientData clientData); -static void FreeJumptableInfo(ClientData clientData); -static void PrintJumptableInfo(ClientData clientData, - Tcl_Obj *appendObj, ByteCode *codePtr, - unsigned int pcOffset); -static int PushVarName(Tcl_Interp *interp, - Tcl_Token *varTokenPtr, CompileEnv *envPtr, - int flags, int *localIndexPtr, - int *simpleVarNamePtr, int *isScalarPtr); static int CompileAssociativeBinaryOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, const char *identity, int instruction, CompileEnv *envPtr); @@ -43,25 +34,6 @@ static int CompileStrictlyBinaryOpCmd(Tcl_Interp *interp, static int CompileUnaryOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, int instruction, CompileEnv *envPtr); -static void IssueSwitchChainedTests(Tcl_Interp *interp, - CompileEnv *envPtr, int mode, int noCase, - int valueIndex, Tcl_Token *valueTokenPtr, - int numWords, Tcl_Token **bodyToken); -static void IssueSwitchJumpTable(Tcl_Interp *interp, - CompileEnv *envPtr, int valueIndex, - Tcl_Token *valueTokenPtr, int numWords, - Tcl_Token **bodyToken); -static int IssueTryFinallyInstructions(Tcl_Interp *interp, - CompileEnv *envPtr, Tcl_Token *bodyToken, - int numHandlers, int *matchCodes, - Tcl_Obj **matchClauses, int *resultVarIndices, - int *optionVarIndices, Tcl_Token **handlerTokens, - Tcl_Token *finallyToken); -static int IssueTryInstructions(Tcl_Interp *interp, - CompileEnv *envPtr, Tcl_Token *bodyToken, - int numHandlers, int *matchCodes, - Tcl_Obj **matchClauses, int *resultVarIndices, - int *optionVarIndices, Tcl_Token **handlerTokens); /* * Macro that encapsulates an efficiency trick that avoids a function call for @@ -87,17 +59,6 @@ static int IssueTryInstructions(Tcl_Interp *interp, #define TCL_NO_LARGE_INDEX 1 /* Do not return localIndex value > 255 */ /* - * The structures below define the AuxData types defined in this file. - */ - -const AuxDataType tclJumptableInfoType = { - "JumptableInfo", /* name */ - DupJumptableInfo, /* dupProc */ - FreeJumptableInfo, /* freeProc */ - PrintJumptableInfo /* printProc */ -}; - -/* * Shorthand macros for instruction issuing. */ @@ -117,3025 +78,9 @@ const AuxDataType tclJumptableInfoType = { #define FIXJUMP(var) \ TclStoreInt4AtPtr(CurrentOffset(envPtr)-(var),envPtr->codeStart+(var)+1) #define LOAD(idx) \ - if ((idx)<256) {OP1(LOAD_SCALAR1,(idx));} else {OP4(LOAD_SCALAR4,(idx));} + OP4(LOAD_SCALAR4,(idx)) #define STORE(idx) \ - if ((idx)<256) {OP1(STORE_SCALAR1,(idx));} else {OP4(STORE_SCALAR4,(idx));} - -/* - *---------------------------------------------------------------------- - * - * TclCompileSetCmd -- - * - * Procedure called to compile the "set" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "set" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileSetCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *varTokenPtr, *valueTokenPtr; - int isAssignment, isScalar, simpleVarName, localIndex, numWords; - - numWords = parsePtr->numWords; - if ((numWords != 2) && (numWords != 3)) { - return TCL_ERROR; - } - isAssignment = (numWords == 3); - - /* - * Decide if we can use a frame slot for the var/array name or if we need - * to emit code to compute and push the name at runtime. We use a frame - * slot (entry in the array of local vars) if we are compiling a procedure - * body and if the name is simple text that does not include namespace - * qualifiers. - */ - - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarName(interp, varTokenPtr, envPtr, 0, - &localIndex, &simpleVarName, &isScalar); - - /* - * If we are doing an assignment, push the new value. - */ - - if (isAssignment) { - valueTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, valueTokenPtr, interp, 2); - } - - /* - * Emit instructions to set/get the variable. - */ - - if (simpleVarName) { - if (isScalar) { - if (localIndex < 0) { - TclEmitOpcode((isAssignment? - INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK), - envPtr); - } else if (localIndex <= 255) { - TclEmitInstInt1((isAssignment? - INST_STORE_SCALAR1 : INST_LOAD_SCALAR1), - localIndex, envPtr); - } else { - TclEmitInstInt4((isAssignment? - INST_STORE_SCALAR4 : INST_LOAD_SCALAR4), - localIndex, envPtr); - } - } else { - if (localIndex < 0) { - TclEmitOpcode((isAssignment? - INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK), envPtr); - } else if (localIndex <= 255) { - TclEmitInstInt1((isAssignment? - INST_STORE_ARRAY1 : INST_LOAD_ARRAY1), - localIndex, envPtr); - } else { - TclEmitInstInt4((isAssignment? - INST_STORE_ARRAY4 : INST_LOAD_ARRAY4), - localIndex, envPtr); - } - } - } else { - TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), envPtr); - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileString*Cmd -- - * - * Procedures called to compile various subcommands of the "string" - * command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "string" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileStringCmpCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr; - - /* - * We don't support any flags; the bytecode isn't that sophisticated. - */ - - if (parsePtr->numWords != 3) { - return TCL_ERROR; - } - - /* - * Push the two operands onto the stack and then the test. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); - TclEmitOpcode(INST_STR_CMP, envPtr); - return TCL_OK; -} - -int -TclCompileStringEqualCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr; - - /* - * We don't support any flags; the bytecode isn't that sophisticated. - */ - - if (parsePtr->numWords != 3) { - return TCL_ERROR; - } - - /* - * Push the two operands onto the stack and then the test. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); - TclEmitOpcode(INST_STR_EQ, envPtr); - return TCL_OK; -} - -int -TclCompileStringFirstCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr; - - /* - * We don't support any flags; the bytecode isn't that sophisticated. - */ - - if (parsePtr->numWords != 3) { - return TCL_ERROR; - } - - /* - * Push the two operands onto the stack and then the test. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); - OP(STR_FIND); - return TCL_OK; -} - -int -TclCompileStringLastCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr; - - /* - * We don't support any flags; the bytecode isn't that sophisticated. - */ - - if (parsePtr->numWords != 3) { - return TCL_ERROR; - } - - /* - * Push the two operands onto the stack and then the test. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); - OP(STR_FIND_LAST); - return TCL_OK; -} - -int -TclCompileStringIndexCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr; - - if (parsePtr->numWords != 3) { - return TCL_ERROR; - } - - /* - * Push the two operands onto the stack and then the index operation. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); - TclEmitOpcode(INST_STR_INDEX, envPtr); - return TCL_OK; -} - -int -TclCompileStringMatchCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr; - int i, length, exactMatch = 0, nocase = 0; - const char *str; - - if (parsePtr->numWords < 3 || parsePtr->numWords > 4) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(parsePtr->tokenPtr); - - /* - * Check if we have a -nocase flag. - */ - - if (parsePtr->numWords == 4) { - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - str = tokenPtr[1].start; - length = tokenPtr[1].size; - if ((length <= 1) || strncmp(str, "-nocase", (size_t) length)) { - /* - * Fail at run time, not in compilation. - */ - - return TCL_ERROR; - } - nocase = 1; - tokenPtr = TokenAfter(tokenPtr); - } - - /* - * Push the strings to match against each other. - */ - - for (i = 0; i < 2; i++) { - if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - str = tokenPtr[1].start; - length = tokenPtr[1].size; - if (!nocase && (i == 0)) { - /* - * Trivial matches can be done by 'string equal'. If -nocase - * was specified, we can't do this because INST_STR_EQ has no - * support for nocase. - */ - - Tcl_Obj *copy = Tcl_NewStringObj(str, length); - - Tcl_IncrRefCount(copy); - exactMatch = TclMatchIsTrivial(TclGetString(copy)); - TclDecrRefCount(copy); - } - PushLiteral(envPtr, str, length); - } else { - CompileTokens(envPtr, tokenPtr, interp); - } - tokenPtr = TokenAfter(tokenPtr); - } - - /* - * Push the matcher. - */ - - if (exactMatch) { - TclEmitOpcode(INST_STR_EQ, envPtr); - } else { - TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr); - } - return TCL_OK; -} - -int -TclCompileStringLenCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr; - Tcl_Obj *objPtr; - - if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - TclNewObj(objPtr); - if (TclWordKnownAtCompileTime(tokenPtr, objPtr)) { - /* - * Here someone is asking for the length of a static string (or - * something with backslashes). Just push the actual character (not - * byte) length. - */ - - char buf[TCL_INTEGER_SPACE]; - int len = Tcl_GetCharLength(objPtr); - - len = sprintf(buf, "%d", len); - PushLiteral(envPtr, buf, len); - } else { - CompileTokens(envPtr, tokenPtr, interp); - TclEmitOpcode(INST_STR_LEN, envPtr); - } - TclDecrRefCount(objPtr); - return TCL_OK; -} - -int -TclCompileStringMapCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *mapTokenPtr, *stringTokenPtr; - Tcl_Obj *mapObj, **objv; - char *bytes; - int len; - - /* - * We only handle the case: - * - * string map {foo bar} $thing - * - * That is, a literal two-element list (doesn't need to be brace-quoted, - * but does need to be compile-time knowable) and any old argument (the - * thing to map). - */ - - if (parsePtr->numWords != 3) { - return TCL_ERROR; - } - mapTokenPtr = TokenAfter(parsePtr->tokenPtr); - stringTokenPtr = TokenAfter(mapTokenPtr); - mapObj = Tcl_NewObj(); - Tcl_IncrRefCount(mapObj); - if (!TclWordKnownAtCompileTime(mapTokenPtr, mapObj)) { - Tcl_DecrRefCount(mapObj); - return TCL_ERROR; - } else if (Tcl_ListObjGetElements(NULL, mapObj, &len, &objv) != TCL_OK) { - Tcl_DecrRefCount(mapObj); - return TCL_ERROR; - } else if (len != 2) { - Tcl_DecrRefCount(mapObj); - return TCL_ERROR; - } - - /* - * Now issue the opcodes. Note that in the case that we know that the - * first word is an empty word, we don't issue the map at all. That is the - * correct semantics for mapping. - */ - - bytes = Tcl_GetStringFromObj(objv[0], &len); - if (len == 0) { - CompileWord(envPtr, stringTokenPtr, interp, 2); - } else { - PushLiteral(envPtr, bytes, len); - bytes = Tcl_GetStringFromObj(objv[1], &len); - PushLiteral(envPtr, bytes, len); - CompileWord(envPtr, stringTokenPtr, interp, 2); - OP(STR_MAP); - } - Tcl_DecrRefCount(mapObj); - return TCL_OK; -} - -int -TclCompileStringRangeCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *stringTokenPtr, *fromTokenPtr, *toTokenPtr; - Tcl_Obj *tmpObj; - int idx1, idx2, result; - - if (parsePtr->numWords != 4) { - return TCL_ERROR; - } - stringTokenPtr = TokenAfter(parsePtr->tokenPtr); - fromTokenPtr = TokenAfter(stringTokenPtr); - toTokenPtr = TokenAfter(fromTokenPtr); - - /* - * Parse the first index. Will only compile if it is constant and not an - * _integer_ less than zero (since we reserve negative indices here for - * end-relative indexing). - */ - - tmpObj = Tcl_NewObj(); - result = TCL_ERROR; - if (TclWordKnownAtCompileTime(fromTokenPtr, tmpObj)) { - if (TclGetIntFromObj(NULL, tmpObj, &idx1) == TCL_OK) { - if (idx1 >= 0) { - result = TCL_OK; - } - } else if (TclGetIntForIndexM(NULL, tmpObj, -2, &idx1) == TCL_OK) { - if (idx1 <= -2) { - result = TCL_OK; - } - } - } - TclDecrRefCount(tmpObj); - if (result != TCL_OK) { - goto nonConstantIndices; - } - - /* - * Parse the second index. Will only compile if it is constant and not an - * _integer_ less than zero (since we reserve negative indices here for - * end-relative indexing). - */ - - tmpObj = Tcl_NewObj(); - result = TCL_ERROR; - if (TclWordKnownAtCompileTime(toTokenPtr, tmpObj)) { - if (TclGetIntFromObj(NULL, tmpObj, &idx2) == TCL_OK) { - if (idx2 >= 0) { - result = TCL_OK; - } - } else if (TclGetIntForIndexM(NULL, tmpObj, -2, &idx2) == TCL_OK) { - if (idx2 <= -2) { - result = TCL_OK; - } - } - } - TclDecrRefCount(tmpObj); - if (result != TCL_OK) { - goto nonConstantIndices; - } - - /* - * Push the operand onto the stack and then the substring operation. - */ - - CompileWord(envPtr, stringTokenPtr, interp, 1); - OP44( STR_RANGE_IMM, idx1, idx2); - return TCL_OK; - - /* - * Push the operands onto the stack and then the substring operation. - */ - - nonConstantIndices: - CompileWord(envPtr, stringTokenPtr, interp, 1); - CompileWord(envPtr, fromTokenPtr, interp, 2); - CompileWord(envPtr, toTokenPtr, interp, 3); - OP( STR_RANGE); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileSubstCmd -- - * - * Procedure called to compile the "subst" command. - * - * Results: - * Returns TCL_OK for successful compile, or TCL_ERROR to defer - * evaluation to runtime (either when it is too complex to get the - * semantics right, or when we know for sure that it is an error but need - * the error to happen at the right time). - * - * Side effects: - * Instructions are added to envPtr to execute the "subst" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileSubstCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - int numArgs = parsePtr->numWords - 1; - int numOpts = numArgs - 1; - int objc, flags = TCL_SUBST_ALL; - Tcl_Obj **objv/*, *toSubst = NULL*/; - Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr); - int code = TCL_ERROR; - - if (numArgs == 0) { - return TCL_ERROR; - } - - objv = TclStackAlloc(interp, /*numArgs*/ numOpts * sizeof(Tcl_Obj *)); - - for (objc = 0; objc < /*numArgs*/ numOpts; objc++) { - objv[objc] = Tcl_NewObj(); - Tcl_IncrRefCount(objv[objc]); - if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) { - objc++; - goto cleanup; - } - wordTokenPtr = TokenAfter(wordTokenPtr); - } - -/* - if (TclSubstOptions(NULL, numOpts, objv, &flags) == TCL_OK) { - toSubst = objv[numOpts]; - Tcl_IncrRefCount(toSubst); - } -*/ - - /* TODO: Figure out expansion to cover WordKnownAtCompileTime - * The difficulty is that WKACT makes a copy, and if TclSubstParse - * below parses the copy of the original source string, some deep - * parts of the compile machinery get upset. They want all pointers - * stored in Tcl_Tokens to point back to the same original string. - */ - if (wordTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - code = TclSubstOptions(NULL, numOpts, objv, &flags); - } - - cleanup: - while (--objc >= 0) { - TclDecrRefCount(objv[objc]); - } - TclStackFree(interp, objv); - if (/*toSubst == NULL*/ code != TCL_OK) { - return TCL_ERROR; - } - - TclSubstCompile(interp, wordTokenPtr[1].start, wordTokenPtr[1].size, - flags, envPtr); - -/* TclDecrRefCount(toSubst);*/ - return TCL_OK; -} - -void -TclSubstCompile( - Tcl_Interp *interp, - const char *bytes, - int numBytes, - int flags, - CompileEnv *envPtr) -{ - Tcl_Token *endTokenPtr, *tokenPtr; - int breakOffset = 0, count = 0; - Tcl_Parse parse; - Tcl_InterpState state = NULL; - - TclSubstParse(interp, bytes, numBytes, flags, &parse, &state); - - /* - * Tricky point! If the first token does not result in a *guaranteed* push - * of a Tcl_Obj on the stack, we must push an empty object. Otherwise it - * is possible to get to an INST_CONCAT1 or INST_DONE without enough - * values on the stack, resulting in a crash. Thanks to Joe Mistachkin for - * identifying a script that could trigger this case. - */ - - tokenPtr = parse.tokenPtr; - if (tokenPtr->type != TCL_TOKEN_TEXT && tokenPtr->type != TCL_TOKEN_BS) { - PushLiteral(envPtr, "", 0); - count++; - } - - for (endTokenPtr = tokenPtr + parse.numTokens; - tokenPtr < endTokenPtr; tokenPtr = TokenAfter(tokenPtr)) { - int length, literal, catchRange, breakJump; - char buf[TCL_UTF_MAX]; - JumpFixup startFixup, okFixup, returnFixup, breakFixup; - JumpFixup continueFixup, otherFixup, endFixup; - - switch (tokenPtr->type) { - case TCL_TOKEN_TEXT: - literal = TclRegisterNewLiteral(envPtr, - tokenPtr->start, tokenPtr->size); - TclEmitPush(literal, envPtr); - count++; - continue; - case TCL_TOKEN_BS: - length = TclParseBackslash(tokenPtr->start, tokenPtr->size, - NULL, buf); - literal = TclRegisterNewLiteral(envPtr, buf, length); - TclEmitPush(literal, envPtr); - count++; - continue; - case TCL_TOKEN_VARIABLE: - /* - * Check for simple variable access; see if we can only generate - * TCL_OK or TCL_ERROR from the substituted variable read; if so, - * there is no need to generate elaborate exception-management - * code. Note that the first component of TCL_TOKEN_VARIABLE is - * always TCL_TOKEN_TEXT... - */ - - if (tokenPtr->numComponents > 1) { - int i, foundCommand = 0; - - for (i=2 ; i<=tokenPtr->numComponents ; i++) { - if (tokenPtr[i].type == TCL_TOKEN_COMMAND) { - foundCommand = 1; - break; - } - } - if (foundCommand) { - break; - } - } - - TclCompileVarSubst(interp, tokenPtr, envPtr); - count++; - continue; - } - - while (count > 255) { - OP1( CONCAT1, 255); - count -= 254; - } - if (count > 1) { - OP1( CONCAT1, count); - count = 1; - } - - if (breakOffset == 0) { - /* Jump to the start (jump over the jump to end) */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &startFixup); - - /* Jump to the end (all BREAKs land here) */ - breakOffset = CurrentOffset(envPtr); - TclEmitInstInt4(INST_JUMP4, 0, envPtr); - - /* Start */ - if (TclFixupForwardJumpToHere(envPtr, &startFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad start jump distance %d", - (int) (CurrentOffset(envPtr) - startFixup.codeOffset)); - } - } - - catchRange = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); - OP4( BEGIN_CATCH4, catchRange); - ExceptionRangeStarts(envPtr, catchRange); - - switch (tokenPtr->type) { - case TCL_TOKEN_COMMAND: - TclCompileScript(interp, tokenPtr->start+1, tokenPtr->size-2, - envPtr); - count++; - break; - case TCL_TOKEN_VARIABLE: - TclCompileVarSubst(interp, tokenPtr, envPtr); - count++; - break; - default: - Tcl_Panic("unexpected token type in TclCompileSubstCmd: %d", - tokenPtr->type); - } - - ExceptionRangeEnds(envPtr, catchRange); - - /* Substitution produced TCL_OK */ - OP( END_CATCH); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &okFixup); - - /* Exceptional return codes processed here */ - ExceptionRangeTarget(envPtr, catchRange, catchOffset); - OP( PUSH_RETURN_OPTIONS); - OP( PUSH_RESULT); - OP( PUSH_RETURN_CODE); - OP( END_CATCH); - OP( RETURN_CODE_BRANCH); - - /* ERROR -> reraise it */ - OP( RETURN_STK); - OP( NOP); - - /* RETURN */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &returnFixup); - - /* BREAK */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &breakFixup); - - /* CONTINUE */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &continueFixup); - - /* OTHER */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &otherFixup); - - /* BREAK destination */ - if (TclFixupForwardJumpToHere(envPtr, &breakFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad break jump distance %d", - (int) (CurrentOffset(envPtr) - breakFixup.codeOffset)); - } - OP( POP); - OP( POP); - - breakJump = CurrentOffset(envPtr) - breakOffset; - if (breakJump > 127) { - OP4(JUMP4, -breakJump); - } else { - OP1(JUMP1, -breakJump); - } - - /* CONTINUE destination */ - if (TclFixupForwardJumpToHere(envPtr, &continueFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad continue jump distance %d", - (int) (CurrentOffset(envPtr) - continueFixup.codeOffset)); - } - OP( POP); - OP( POP); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &endFixup); - - /* RETURN + other destination */ - if (TclFixupForwardJumpToHere(envPtr, &returnFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad return jump distance %d", - (int) (CurrentOffset(envPtr) - returnFixup.codeOffset)); - } - if (TclFixupForwardJumpToHere(envPtr, &otherFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad other jump distance %d", - (int) (CurrentOffset(envPtr) - otherFixup.codeOffset)); - } - - /* - * Pull the result to top of stack, discard options dict. - */ - - OP4( REVERSE, 2); - OP( POP); - - /* - * We've emitted several POP instructions, and the automatic - * computations for stack depth requirements have been decrementing - * for every one. However, we know that every branch actually taken - * only encounters some of those instructions. No branch passes - * through them all. So, we now have a stack requirements estimate - * that is too low. Here we manually fix that up. - */ - - TclAdjustStackDepth(5, envPtr); - - /* OK destination */ - if (TclFixupForwardJumpToHere(envPtr, &okFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad ok jump distance %d", - (int) (CurrentOffset(envPtr) - okFixup.codeOffset)); - } - if (count > 1) { - OP1(CONCAT1, count); - count = 1; - } - - /* CONTINUE jump to here */ - if (TclFixupForwardJumpToHere(envPtr, &endFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad end jump distance %d", - (int) (CurrentOffset(envPtr) - endFixup.codeOffset)); - } - } - - while (count > 255) { - OP1( CONCAT1, 255); - count -= 254; - } - if (count > 1) { - OP1( CONCAT1, count); - } - - Tcl_FreeParse(&parse); - - if (state != NULL) { - Tcl_RestoreInterpState(interp, state); - TclCompileSyntaxError(interp, envPtr); - TclAdjustStackDepth(-1, envPtr); - } - - /* Final target of the multi-jump from all BREAKs */ - if (breakOffset > 0) { - TclUpdateInstInt4AtPc(INST_JUMP4, CurrentOffset(envPtr) - breakOffset, - envPtr->codeStart + breakOffset); - } -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileSwitchCmd -- - * - * Procedure called to compile the "switch" command. - * - * Results: - * Returns TCL_OK for successful compile, or TCL_ERROR to defer - * evaluation to runtime (either when it is too complex to get the - * semantics right, or when we know for sure that it is an error but need - * the error to happen at the right time). - * - * Side effects: - * Instructions are added to envPtr to execute the "switch" command at - * runtime. - * - * FIXME: - * Stack depths are probably not calculated correctly. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileSwitchCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr; /* Pointer to tokens in command. */ - int numWords; /* Number of words in command. */ - - Tcl_Token *valueTokenPtr; /* Token for the value to switch on. */ - enum {Switch_Exact, Switch_Glob, Switch_Regexp} mode; - /* What kind of switch are we doing? */ - - Tcl_Token *bodyTokenArray; /* Array of real pattern list items. */ - Tcl_Token **bodyToken; /* Array of pointers to pattern list items. */ - int noCase; /* Has the -nocase flag been given? */ - int foundMode = 0; /* Have we seen a mode flag yet? */ - int i, valueIndex; - int result = TCL_ERROR; - - /* - * Only handle the following versions: - * switch ?--? word {pattern body ...} - * switch -exact ?--? word {pattern body ...} - * switch -glob ?--? word {pattern body ...} - * switch -regexp ?--? word {pattern body ...} - * switch -- word simpleWordPattern simpleWordBody ... - * switch -exact -- word simpleWordPattern simpleWordBody ... - * switch -glob -- word simpleWordPattern simpleWordBody ... - * switch -regexp -- word simpleWordPattern simpleWordBody ... - * When the mode is -glob, can also handle a -nocase flag. - * - * First off, we don't care how the command's word was generated; we're - * compiling it anyway! So skip it... - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - valueIndex = 1; - numWords = parsePtr->numWords-1; - - /* - * Check for options. - */ - - noCase = 0; - mode = Switch_Exact; - if (numWords == 2) { - /* - * There's just the switch value and the bodies list. In that case, we - * can skip all option parsing and move on to consider switch values - * and the body list. - */ - - goto finishedOptionParse; - } - - /* - * There must be at least one option, --, because without that there is no - * way to statically avoid the problems you get from strings-to-be-matched - * that start with a - (the interpreted code falls apart if it encounters - * them, so we punt if we *might* encounter them as that is the easiest - * way of emulating the behaviour). - */ - - for (; numWords>=3 ; tokenPtr=TokenAfter(tokenPtr),numWords--) { - register unsigned size = tokenPtr[1].size; - register const char *chrs = tokenPtr[1].start; - - /* - * We only process literal options, and we assume that -e, -g and -n - * are unique prefixes of -exact, -glob and -nocase respectively (true - * at time of writing). Note that -exact and -glob may only be given - * at most once or we bail out (error case). - */ - - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || size < 2) { - return TCL_ERROR; - } - - if ((size <= 6) && !memcmp(chrs, "-exact", size)) { - if (foundMode) { - return TCL_ERROR; - } - mode = Switch_Exact; - foundMode = 1; - valueIndex++; - continue; - } else if ((size <= 5) && !memcmp(chrs, "-glob", size)) { - if (foundMode) { - return TCL_ERROR; - } - mode = Switch_Glob; - foundMode = 1; - valueIndex++; - continue; - } else if ((size <= 7) && !memcmp(chrs, "-regexp", size)) { - if (foundMode) { - return TCL_ERROR; - } - mode = Switch_Regexp; - foundMode = 1; - valueIndex++; - continue; - } else if ((size <= 7) && !memcmp(chrs, "-nocase", size)) { - noCase = 1; - valueIndex++; - continue; - } else if ((size == 2) && !memcmp(chrs, "--", 2)) { - valueIndex++; - break; - } - - /* - * The switch command has many flags we cannot compile at all (e.g. - * all the RE-related ones) which we must have encountered. Either - * that or we have run off the end. The action here is the same: punt - * to interpreted version. - */ - - return TCL_ERROR; - } - if (numWords < 3) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(tokenPtr); - numWords--; - if (noCase && (mode == Switch_Exact)) { - /* - * Can't compile this case; no opcode for case-insensitive equality! - */ - - return TCL_ERROR; - } - - /* - * The value to test against is going to always get pushed on the stack. - * But not yet; we need to verify that the rest of the command is - * compilable too. - */ - - finishedOptionParse: - valueTokenPtr = tokenPtr; - /* For valueIndex, see previous loop. */ - tokenPtr = TokenAfter(tokenPtr); - numWords--; - - /* - * Build an array of tokens for the matcher terms and script bodies. Note - * that in the case of the quoted bodies, this is tricky as we cannot use - * copies of the string from the input token for the generated tokens (it - * causes a crash during exception handling). When multiple tokens are - * available at this point, this is pretty easy. - */ - - if (numWords == 1) { - const char *bytes; - int maxLen, numBytes; - - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - bytes = tokenPtr[1].start; - numBytes = tokenPtr[1].size; - - /* Allocate enough space to work in. */ - maxLen = TclMaxListLength(bytes, numBytes, NULL); - if (maxLen < 2) { - return TCL_ERROR; - } - bodyTokenArray = ckalloc(sizeof(Tcl_Token) * maxLen); - bodyToken = ckalloc(sizeof(Tcl_Token *) * maxLen); - - numWords = 0; - - while (numBytes > 0) { - const char *prevBytes = bytes; - int literal; - - if (TCL_OK != TclFindElement(NULL, bytes, numBytes, - &(bodyTokenArray[numWords].start), &bytes, - &(bodyTokenArray[numWords].size), &literal) || !literal) { - goto abort; - } - - bodyTokenArray[numWords].type = TCL_TOKEN_TEXT; - bodyTokenArray[numWords].numComponents = 0; - bodyToken[numWords] = bodyTokenArray + numWords; - - numBytes -= (bytes - prevBytes); - numWords++; - } - if (numWords % 2) { - abort: - ckfree((char *) bodyToken); - ckfree((char *) bodyTokenArray); - return TCL_ERROR; - } - } else if (numWords % 2 || numWords == 0) { - /* - * Odd number of words (>1) available, or no words at all available. - * Both are error cases, so punt and let the interpreted-version - * generate the error message. Note that the second case probably - * should get caught earlier, but it's easy to check here again anyway - * because it'd cause a nasty crash otherwise. - */ - - return TCL_ERROR; - } else { - /* - * Multi-word definition of patterns & actions. - */ - - bodyToken = ckalloc(sizeof(Tcl_Token *) * numWords); - bodyTokenArray = NULL; - for (i=0 ; i<numWords ; i++) { - /* - * We only handle the very simplest case. Anything more complex is - * a good reason to go to the interpreted case anyway due to - * traces, etc. - */ - - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - goto freeTemporaries; - } - bodyToken[i] = tokenPtr+1; - - tokenPtr = TokenAfter(tokenPtr); - } - } - - /* - * Fall back to interpreted if the last body is a continuation (it's - * illegal, but this makes the error happen at the right time). - */ - - if (bodyToken[numWords-1]->size == 1 && - bodyToken[numWords-1]->start[0] == '-') { - goto freeTemporaries; - } - - /* - * Now we commit to generating code; the parsing stage per se is done. - * Check if we can generate a jump table, since if so that's faster than - * doing an explicit compare with each body. Note that we're definitely - * over-conservative with determining whether we can do the jump table, - * but it handles the most common case well enough. - */ - - if (mode == Switch_Exact) { - IssueSwitchJumpTable(interp, envPtr, valueIndex, - valueTokenPtr, numWords, bodyToken); - } else { - IssueSwitchChainedTests(interp, envPtr, mode,noCase, - valueIndex, valueTokenPtr, numWords, bodyToken); - } - result = TCL_OK; - - /* - * Clean up all our temporary space and return. - */ - - freeTemporaries: - ckfree(bodyToken); - if (bodyTokenArray != NULL) { - ckfree(bodyTokenArray); - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * IssueSwitchChainedTests -- - * - * Generate instructions for a [switch] command that is to be compiled - * into a sequence of tests. This is the generic handle-everything mode - * that inherently has performance that is (on average) linear in the - * number of tests. It is the only mode that can handle -glob and -regexp - * matches, or anything that is case-insensitive. It does not handle the - * wild-and-wooly end of regexp matching (i.e., capture of match results) - * so that's when we spill to the interpreted version. - * - *---------------------------------------------------------------------- - */ - -static void -IssueSwitchChainedTests( - Tcl_Interp *interp, /* Context for compiling script bodies. */ - CompileEnv *envPtr, /* Holds resulting instructions. */ - int mode, /* Exact, Glob or Regexp */ - int noCase, /* Case-insensitivity flag. */ - int valueIndex, /* The value to match against. */ - Tcl_Token *valueTokenPtr, - int numBodyTokens, /* Number of tokens describing things the - * switch can match against and bodies to - * execute when the match succeeds. */ - Tcl_Token **bodyToken) /* Array of pointers to pattern list items. */ -{ - enum {Switch_Exact, Switch_Glob, Switch_Regexp}; - int savedStackDepth = envPtr->currStackDepth; - int foundDefault; /* Flag to indicate whether a "default" clause - * is present. */ - JumpFixup *fixupArray; /* Array of forward-jump fixup records. */ - int *fixupTargetArray; /* Array of places for fixups to point at. */ - int fixupCount; /* Number of places to fix up. */ - int contFixIndex; /* Where the first of the jumps due to a group - * of continuation bodies starts, or -1 if - * there aren't any. */ - int contFixCount; /* Number of continuation bodies pointing to - * the current (or next) real body. */ - int nextArmFixupIndex; - int simple, exact; /* For extracting the type of regexp. */ - int i; - - /* - * First, we push the value we're matching against on the stack. - */ - - CompileTokens(envPtr, valueTokenPtr, interp); - - /* - * Generate a test for each arm. - */ - - contFixIndex = -1; - contFixCount = 0; - fixupArray = TclStackAlloc(interp, sizeof(JumpFixup) * numBodyTokens); - fixupTargetArray = TclStackAlloc(interp, sizeof(int) * numBodyTokens); - memset(fixupTargetArray, 0, numBodyTokens * sizeof(int)); - fixupCount = 0; - foundDefault = 0; - for (i=0 ; i<numBodyTokens ; i+=2) { - nextArmFixupIndex = -1; - envPtr->currStackDepth = savedStackDepth + 1; - if (i!=numBodyTokens-2 || bodyToken[numBodyTokens-2]->size != 7 || - memcmp(bodyToken[numBodyTokens-2]->start, "default", 7)) { - /* - * Generate the test for the arm. - */ - - switch (mode) { - case Switch_Exact: - OP( DUP); - TclCompileTokens(interp, bodyToken[i], 1, envPtr); - OP( STR_EQ); - break; - case Switch_Glob: - TclCompileTokens(interp, bodyToken[i], 1, envPtr); - OP4( OVER, 1); - OP1( STR_MATCH, noCase); - break; - case Switch_Regexp: - simple = exact = 0; - - /* - * Keep in sync with TclCompileRegexpCmd. - */ - - if (bodyToken[i]->type == TCL_TOKEN_TEXT) { - Tcl_DString ds; - - if (bodyToken[i]->size == 0) { - /* - * The semantics of regexps are that they always match - * when the RE == "". - */ - - PushLiteral(envPtr, "1", 1); - break; - } - - /* - * Attempt to convert pattern to glob. If successful, push - * the converted pattern. - */ - - if (TclReToGlob(NULL, bodyToken[i]->start, - bodyToken[i]->size, &ds, &exact) == TCL_OK) { - simple = 1; - PushLiteral(envPtr, Tcl_DStringValue(&ds), - Tcl_DStringLength(&ds)); - Tcl_DStringFree(&ds); - } - } - if (!simple) { - TclCompileTokens(interp, bodyToken[i], 1, envPtr); - } - - OP4( OVER, 1); - if (!simple) { - /* - * Pass correct RE compile flags. We use only Int1 - * (8-bit), but that handles all the flags we want to - * pass. Don't use TCL_REG_NOSUB as we may have backrefs - * or capture vars. - */ - - int cflags = TCL_REG_ADVANCED - | (noCase ? TCL_REG_NOCASE : 0); - - OP1(REGEXP, cflags); - } else if (exact && !noCase) { - OP( STR_EQ); - } else { - OP1(STR_MATCH, noCase); - } - break; - default: - Tcl_Panic("unknown switch mode: %d", mode); - } - - /* - * In a fall-through case, we will jump on _true_ to the place - * where the body starts (generated later, with guarantee of this - * ensured earlier; the final body is never a fall-through). - */ - - if (bodyToken[i+1]->size==1 && bodyToken[i+1]->start[0]=='-') { - if (contFixIndex == -1) { - contFixIndex = fixupCount; - contFixCount = 0; - } - TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, - &fixupArray[contFixIndex+contFixCount]); - fixupCount++; - contFixCount++; - continue; - } - - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, - &fixupArray[fixupCount]); - nextArmFixupIndex = fixupCount; - fixupCount++; - } else { - /* - * Got a default clause; set a flag to inhibit the generation of - * the jump after the body and the cleanup of the intermediate - * value that we are switching against. - * - * Note that default clauses (which are always terminal clauses) - * cannot be fall-through clauses as well, since the last clause - * is never a fall-through clause (which we have already - * verified). - */ - - foundDefault = 1; - } - - /* - * Generate the body for the arm. This is guaranteed not to be a - * fall-through case, but it might have preceding fall-through cases, - * so we must process those first. - */ - - if (contFixIndex != -1) { - int j; - - for (j=0 ; j<contFixCount ; j++) { - fixupTargetArray[contFixIndex+j] = CurrentOffset(envPtr); - } - contFixIndex = -1; - } - - /* - * Now do the actual compilation. Note that we do not use CompileBody - * because we may have synthesized the tokens in a non-standard - * pattern. - */ - - OP( POP); - envPtr->currStackDepth = savedStackDepth + 1; - TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr); - - if (!foundDefault) { - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &fixupArray[fixupCount]); - fixupCount++; - fixupTargetArray[nextArmFixupIndex] = CurrentOffset(envPtr); - } - } - - /* - * Discard the value we are matching against unless we've had a default - * clause (in which case it will already be gone due to the code at the - * start of processing an arm, guaranteed) and make the result of the - * command an empty string. - */ - - if (!foundDefault) { - OP( POP); - PushLiteral(envPtr, "", 0); - } - - /* - * Do jump fixups for arms that were executed. First, fill in the jumps of - * all jumps that don't point elsewhere to point to here. - */ - - for (i=0 ; i<fixupCount ; i++) { - if (fixupTargetArray[i] == 0) { - fixupTargetArray[i] = envPtr->codeNext-envPtr->codeStart; - } - } - - /* - * Now scan backwards over all the jumps (all of which are forward jumps) - * doing each one. When we do one and there is a size changes, we must - * scan back over all the previous ones and see if they need adjusting - * before proceeding with further jump fixups (the interleaved nature of - * all the jumps makes this impossible to do without nested loops). - */ - - for (i=fixupCount-1 ; i>=0 ; i--) { - if (TclFixupForwardJump(envPtr, &fixupArray[i], - fixupTargetArray[i] - fixupArray[i].codeOffset, 127)) { - int j; - - for (j=i-1 ; j>=0 ; j--) { - if (fixupTargetArray[j] > fixupArray[i].codeOffset) { - fixupTargetArray[j] += 3; - } - } - } - } - TclStackFree(interp, fixupTargetArray); - TclStackFree(interp, fixupArray); - - envPtr->currStackDepth = savedStackDepth + 1; -} - -/* - *---------------------------------------------------------------------- - * - * IssueSwitchJumpTable -- - * - * Generate instructions for a [switch] command that is to be compiled - * into a jump table. This only handles the case where case-sensitive, - * exact matching is used, but this is actually the most common case in - * real code. - * - *---------------------------------------------------------------------- - */ - -static void -IssueSwitchJumpTable( - Tcl_Interp *interp, /* Context for compiling script bodies. */ - CompileEnv *envPtr, /* Holds resulting instructions. */ - int valueIndex, /* The value to match against. */ - Tcl_Token *valueTokenPtr, - int numBodyTokens, /* Number of tokens describing things the - * switch can match against and bodies to - * execute when the match succeeds. */ - Tcl_Token **bodyToken) /* Array of pointers to pattern list items. */ -{ - JumptableInfo *jtPtr; - int savedStackDepth = envPtr->currStackDepth; - int infoIndex, isNew, *finalFixups, numRealBodies = 0, jumpLocation; - int mustGenerate, foundDefault, jumpToDefault, i; - Tcl_DString buffer; - Tcl_HashEntry *hPtr; - - /* - * First, we push the value we're matching against on the stack. - */ - - CompileTokens(envPtr, valueTokenPtr, interp); - - /* - * Compile the switch by using a jump table, which is basically a - * hashtable that maps from literal values to match against to the offset - * (relative to the INST_JUMP_TABLE instruction) to jump to. The jump - * table itself is independent of any invokation of the bytecode, and as - * such is stored in an auxData block. - * - * Start by allocating the jump table itself, plus some workspace. - */ - - jtPtr = ckalloc(sizeof(JumptableInfo)); - Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS); - infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr); - finalFixups = TclStackAlloc(interp, sizeof(int) * (numBodyTokens/2)); - foundDefault = 0; - mustGenerate = 1; - - /* - * Next, issue the instruction to do the jump, together with what we want - * to do if things do not work out (jump to either the default clause or - * the "default" default, which just sets the result to empty). Note that - * we will come back and rewrite the jump's offset parameter when we know - * what it should be, and that all jumps we issue are of the wide kind - * because that makes the code much easier to debug! - */ - - jumpLocation = CurrentOffset(envPtr); - OP4( JUMP_TABLE, infoIndex); - jumpToDefault = CurrentOffset(envPtr); - OP4( JUMP4, 0); - - for (i=0 ; i<numBodyTokens ; i+=2) { - /* - * For each arm, we must first work out what to do with the match - * term. - */ - - if (i!=numBodyTokens-2 || bodyToken[numBodyTokens-2]->size != 7 || - memcmp(bodyToken[numBodyTokens-2]->start, "default", 7)) { - /* - * This is not a default clause, so insert the current location as - * a target in the jump table (assuming it isn't already there, - * which would indicate that this clause is probably masked by an - * earlier one). Note that we use a Tcl_DString here simply - * because the hash API does not let us specify the string length. - */ - - Tcl_DStringInit(&buffer); - TclDStringAppendToken(&buffer, bodyToken[i]); - hPtr = Tcl_CreateHashEntry(&jtPtr->hashTable, - Tcl_DStringValue(&buffer), &isNew); - if (isNew) { - /* - * First time we've encountered this match clause, so it must - * point to here. - */ - - Tcl_SetHashValue(hPtr, CurrentOffset(envPtr) - jumpLocation); - } - Tcl_DStringFree(&buffer); - } else { - /* - * This is a default clause, so patch up the fallthrough from the - * INST_JUMP_TABLE instruction to here. - */ - - foundDefault = 1; - isNew = 1; - TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault, - envPtr->codeStart+jumpToDefault+1); - } - - /* - * Now, for each arm we must deal with the body of the clause. - * - * If this is a continuation body (never true of a final clause, - * whether default or not) we're done because the next jump target - * will also point here, so we advance to the next clause. - */ - - if (bodyToken[i+1]->size == 1 && bodyToken[i+1]->start[0] == '-') { - mustGenerate = 1; - continue; - } - - /* - * Also skip this arm if its only match clause is masked. (We could - * probably be more aggressive about this, but that would be much more - * difficult to get right.) - */ - - if (!isNew && !mustGenerate) { - continue; - } - mustGenerate = 0; - - /* - * Compile the body of the arm. - */ - - envPtr->currStackDepth = savedStackDepth; - TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr); - - /* - * Compile a jump in to the end of the command if this body is - * anything other than a user-supplied default arm (to either skip - * over the remaining bodies or the code that generates an empty - * result). - */ - - if (i+2 < numBodyTokens || !foundDefault) { - finalFixups[numRealBodies++] = CurrentOffset(envPtr); - - /* - * Easier by far to issue this jump as a fixed-width jump, since - * otherwise we'd need to do a lot more (and more awkward) - * rewriting when we fixed this all up. - */ - - OP4( JUMP4, 0); - } - } - - /* - * We're at the end. If we've not already done so through the processing - * of a user-supplied default clause, add in a "default" default clause - * now. - */ - - if (!foundDefault) { - envPtr->currStackDepth = savedStackDepth; - TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault, - envPtr->codeStart+jumpToDefault+1); - PushLiteral(envPtr, "", 0); - } - - /* - * No more instructions to be issued; everything that needs to jump to the - * end of the command is fixed up at this point. - */ - - for (i=0 ; i<numRealBodies ; i++) { - TclStoreInt4AtPtr(CurrentOffset(envPtr)-finalFixups[i], - envPtr->codeStart+finalFixups[i]+1); - } - - /* - * Clean up all our temporary space and return. - */ - - TclStackFree(interp, finalFixups); - envPtr->currStackDepth = savedStackDepth + 1; -} - -/* - *---------------------------------------------------------------------- - * - * DupJumptableInfo, FreeJumptableInfo -- - * - * Functions to duplicate, release and print a jump-table created for use - * with the INST_JUMP_TABLE instruction. - * - * Results: - * DupJumptableInfo: a copy of the jump-table - * FreeJumptableInfo: none - * PrintJumptableInfo: none - * - * Side effects: - * DupJumptableInfo: allocates memory - * FreeJumptableInfo: releases memory - * PrintJumptableInfo: none - * - *---------------------------------------------------------------------- - */ - -static ClientData -DupJumptableInfo( - ClientData clientData) -{ - JumptableInfo *jtPtr = clientData; - JumptableInfo *newJtPtr = ckalloc(sizeof(JumptableInfo)); - Tcl_HashEntry *hPtr, *newHPtr; - Tcl_HashSearch search; - int isNew; - - Tcl_InitHashTable(&newJtPtr->hashTable, TCL_STRING_KEYS); - hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search); - while (hPtr != NULL) { - newHPtr = Tcl_CreateHashEntry(&newJtPtr->hashTable, - Tcl_GetHashKey(&jtPtr->hashTable, hPtr), &isNew); - Tcl_SetHashValue(newHPtr, Tcl_GetHashValue(hPtr)); - } - return newJtPtr; -} - -static void -FreeJumptableInfo( - ClientData clientData) -{ - JumptableInfo *jtPtr = clientData; - - Tcl_DeleteHashTable(&jtPtr->hashTable); - ckfree(jtPtr); -} - -static void -PrintJumptableInfo( - ClientData clientData, - Tcl_Obj *appendObj, - ByteCode *codePtr, - unsigned int pcOffset) -{ - register JumptableInfo *jtPtr = clientData; - Tcl_HashEntry *hPtr; - Tcl_HashSearch search; - const char *keyPtr; - int offset, i = 0; - - hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search); - for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) { - keyPtr = Tcl_GetHashKey(&jtPtr->hashTable, hPtr); - offset = PTR2INT(Tcl_GetHashValue(hPtr)); - - if (i++) { - Tcl_AppendToObj(appendObj, ", ", -1); - if (i%4==0) { - Tcl_AppendToObj(appendObj, "\n\t\t", -1); - } - } - Tcl_AppendPrintfToObj(appendObj, "\"%s\"->pc %d", - keyPtr, pcOffset + offset); - } -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileTailcallCmd -- - * - * Procedure called to compile the "tailcall" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "tailcall" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileTailcallCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr = parsePtr->tokenPtr; - int i; - - if (parsePtr->numWords < 2 || parsePtr->numWords > 256 - || envPtr->procPtr == NULL) { - return TCL_ERROR; - } - - /* make room for the nsObjPtr */ - CompileWord(envPtr, tokenPtr, interp, 0); - for (i=1 ; i<parsePtr->numWords ; i++) { - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, i); - } - TclEmitInstInt1( INST_TAILCALL, parsePtr->numWords, envPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileThrowCmd -- - * - * Procedure called to compile the "throw" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "throw" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileThrowCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - int numWords = parsePtr->numWords; - int savedStackDepth = envPtr->currStackDepth; - Tcl_Token *codeToken, *msgToken; - Tcl_Obj *objPtr; - - if (numWords != 3) { - return TCL_ERROR; - } - codeToken = TokenAfter(parsePtr->tokenPtr); - msgToken = TokenAfter(codeToken); - - TclNewObj(objPtr); - Tcl_IncrRefCount(objPtr); - if (TclWordKnownAtCompileTime(codeToken, objPtr)) { - Tcl_Obj *errPtr, *dictPtr; - const char *string; - int len; - - /* - * The code is known at compilation time. This allows us to issue a - * very efficient sequence of instructions. - */ - - if (Tcl_ListObjLength(interp, objPtr, &len) != TCL_OK) { - /* - * Must still do this; might generate an error when getting this - * "ignored" value prepared as an argument. - */ - - CompileWord(envPtr, msgToken, interp, 2); - TclCompileSyntaxError(interp, envPtr); - Tcl_DecrRefCount(objPtr); - envPtr->currStackDepth = savedStackDepth + 1; - return TCL_OK; - } - if (len == 0) { - /* - * Must still do this; might generate an error when getting this - * "ignored" value prepared as an argument. - */ - - CompileWord(envPtr, msgToken, interp, 2); - goto issueErrorForEmptyCode; - } - TclNewLiteralStringObj(errPtr, "-errorcode"); - TclNewObj(dictPtr); - Tcl_DictObjPut(NULL, dictPtr, errPtr, objPtr); - Tcl_IncrRefCount(dictPtr); - string = Tcl_GetStringFromObj(dictPtr, &len); - CompileWord(envPtr, msgToken, interp, 2); - PushLiteral(envPtr, string, len); - TclDecrRefCount(dictPtr); - OP44( RETURN_IMM, 1, 0); - envPtr->currStackDepth = savedStackDepth + 1; - } else { - /* - * When the code token is not known at compilation time, we need to do - * a little bit more work. The main tricky bit here is that the error - * code has to be a list (a [throw] restriction) so we must emit extra - * instructions to enforce that condition. - */ - - CompileWord(envPtr, codeToken, interp, 1); - PUSH( "-errorcode"); - CompileWord(envPtr, msgToken, interp, 2); - OP4( REVERSE, 3); - OP( DUP); - OP( LIST_LENGTH); - OP1( JUMP_FALSE1, 16); - OP4( LIST, 2); - OP44( RETURN_IMM, 1, 0); - - /* - * Generate an error for being an empty list. Can't leverage anything - * else to do this for us. - */ - - issueErrorForEmptyCode: - PUSH( "type must be non-empty list"); - PUSH( ""); - OP44( RETURN_IMM, 1, 0); - } - envPtr->currStackDepth = savedStackDepth + 1; - TclDecrRefCount(objPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileTryCmd -- - * - * Procedure called to compile the "try" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "try" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileTryCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - int numWords = parsePtr->numWords, numHandlers, result = TCL_ERROR; - Tcl_Token *bodyToken, *finallyToken, *tokenPtr; - Tcl_Token **handlerTokens = NULL; - Tcl_Obj **matchClauses = NULL; - int *matchCodes=NULL, *resultVarIndices=NULL, *optionVarIndices=NULL; - int i; - - if (numWords < 2) { - return TCL_ERROR; - } - - bodyToken = TokenAfter(parsePtr->tokenPtr); - - if (numWords == 2) { - /* - * No handlers or finally; do nothing beyond evaluating the body. - */ - - CompileBody(envPtr, bodyToken, interp); - return TCL_OK; - } - - numWords -= 2; - tokenPtr = TokenAfter(bodyToken); - - /* - * Extract information about what handlers there are. - */ - - numHandlers = numWords >> 2; - numWords -= numHandlers * 4; - if (numHandlers > 0) { - handlerTokens = TclStackAlloc(interp, sizeof(Tcl_Token*)*numHandlers); - matchClauses = TclStackAlloc(interp, sizeof(Tcl_Obj *) * numHandlers); - memset(matchClauses, 0, sizeof(Tcl_Obj *) * numHandlers); - matchCodes = TclStackAlloc(interp, sizeof(int) * numHandlers); - resultVarIndices = TclStackAlloc(interp, sizeof(int) * numHandlers); - optionVarIndices = TclStackAlloc(interp, sizeof(int) * numHandlers); - - for (i=0 ; i<numHandlers ; i++) { - Tcl_Obj *tmpObj, **objv; - int objc; - - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - goto failedToCompile; - } - if (tokenPtr[1].size == 4 - && !strncmp(tokenPtr[1].start, "trap", 4)) { - /* - * Parse the list of errorCode words to match against. - */ - - matchCodes[i] = TCL_ERROR; - tokenPtr = TokenAfter(tokenPtr); - TclNewObj(tmpObj); - Tcl_IncrRefCount(tmpObj); - if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj) - || Tcl_ListObjLength(NULL, tmpObj, &objc) != TCL_OK - || (objc == 0)) { - TclDecrRefCount(tmpObj); - goto failedToCompile; - } - Tcl_ListObjReplace(NULL, tmpObj, 0, 0, 0, NULL); - matchClauses[i] = tmpObj; - } else if (tokenPtr[1].size == 2 - && !strncmp(tokenPtr[1].start, "on", 2)) { - int code; - - /* - * Parse the result code to look for. - */ - - tokenPtr = TokenAfter(tokenPtr); - TclNewObj(tmpObj); - Tcl_IncrRefCount(tmpObj); - if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) { - TclDecrRefCount(tmpObj); - goto failedToCompile; - } - if (TCL_ERROR == TclGetCompletionCodeFromObj(NULL, tmpObj, &code)) { - TclDecrRefCount(tmpObj); - goto failedToCompile; - } - matchCodes[i] = code; - TclDecrRefCount(tmpObj); - } else { - goto failedToCompile; - } - - /* - * Parse the variable binding. - */ - - tokenPtr = TokenAfter(tokenPtr); - TclNewObj(tmpObj); - Tcl_IncrRefCount(tmpObj); - if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) { - TclDecrRefCount(tmpObj); - goto failedToCompile; - } - if (Tcl_ListObjGetElements(NULL, tmpObj, &objc, &objv) != TCL_OK - || (objc > 2)) { - TclDecrRefCount(tmpObj); - goto failedToCompile; - } - if (objc > 0) { - int len; - const char *varname = Tcl_GetStringFromObj(objv[0], &len); - - if (!TclIsLocalScalar(varname, len)) { - TclDecrRefCount(tmpObj); - goto failedToCompile; - } - resultVarIndices[i] = - TclFindCompiledLocal(varname, len, 1, envPtr); - } else { - resultVarIndices[i] = -1; - } - if (objc == 2) { - int len; - const char *varname = Tcl_GetStringFromObj(objv[1], &len); - - if (!TclIsLocalScalar(varname, len)) { - TclDecrRefCount(tmpObj); - goto failedToCompile; - } - optionVarIndices[i] = - TclFindCompiledLocal(varname, len, 1, envPtr); - } else { - optionVarIndices[i] = -1; - } - TclDecrRefCount(tmpObj); - - /* - * Extract the body for this handler. - */ - - tokenPtr = TokenAfter(tokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - goto failedToCompile; - } - if (tokenPtr[1].size == 1 && tokenPtr[1].start[0] == '-') { - handlerTokens[i] = NULL; - } else { - handlerTokens[i] = tokenPtr; - } - - tokenPtr = TokenAfter(tokenPtr); - } - - if (handlerTokens[numHandlers-1] == NULL) { - goto failedToCompile; - } - } - - /* - * Parse the finally clause - */ - - if (numWords == 0) { - finallyToken = NULL; - } else if (numWords == 2) { - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size != 7 - || strncmp(tokenPtr[1].start, "finally", 7)) { - goto failedToCompile; - } - finallyToken = TokenAfter(tokenPtr); - } else { - goto failedToCompile; - } - - /* - * Issue the bytecode. - */ - - if (finallyToken) { - result = IssueTryFinallyInstructions(interp, envPtr, bodyToken, - numHandlers, matchCodes, matchClauses, resultVarIndices, - optionVarIndices, handlerTokens, finallyToken); - } else { - result = IssueTryInstructions(interp, envPtr, bodyToken, numHandlers, - matchCodes, matchClauses, resultVarIndices, optionVarIndices, - handlerTokens); - } - - /* - * Delete any temporary state and finish off. - */ - - failedToCompile: - if (numHandlers > 0) { - for (i=0 ; i<numHandlers ; i++) { - if (matchClauses[i]) { - TclDecrRefCount(matchClauses[i]); - } - } - TclStackFree(interp, optionVarIndices); - TclStackFree(interp, resultVarIndices); - TclStackFree(interp, matchCodes); - TclStackFree(interp, matchClauses); - TclStackFree(interp, handlerTokens); - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * IssueTryInstructions, IssueTryFinallyInstructions -- - * - * The code generators for [try]. Split from the parsing engine for - * reasons of developer sanity, and also split between no-finally and - * with-finally cases because so many of the details of generation vary - * between the two. - * - * The macros below make the instruction issuing easier to follow. - * - *---------------------------------------------------------------------- - */ - -static int -IssueTryInstructions( - Tcl_Interp *interp, - CompileEnv *envPtr, - Tcl_Token *bodyToken, - int numHandlers, - int *matchCodes, - Tcl_Obj **matchClauses, - int *resultVars, - int *optionVars, - Tcl_Token **handlerTokens) -{ - int range, resultVar, optionsVar; - int savedStackDepth = envPtr->currStackDepth; - int i, j, len, forwardsNeedFixing = 0; - int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource; - char buf[TCL_INTEGER_SPACE]; - - resultVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); - optionsVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); - if (resultVar < 0 || optionsVar < 0) { - return TCL_ERROR; - } - - /* - * Compile the body, trapping any error in it so that we can trap on it - * and/or run a finally clause. Note that there must be at least one - * on/trap clause; when none is present, this whole function is not called - * (and it's never called when there's a finally clause). - */ - - range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); - OP4( BEGIN_CATCH4, range); - ExceptionRangeStarts(envPtr, range); - BODY( bodyToken, 1); - ExceptionRangeEnds(envPtr, range); - PUSH( "0"); - OP4( REVERSE, 2); - OP1( JUMP1, 4); - ExceptionRangeTarget(envPtr, range, catchOffset); - OP( PUSH_RETURN_CODE); - OP( PUSH_RESULT); - OP( PUSH_RETURN_OPTIONS); - OP( END_CATCH); - STORE( optionsVar); - OP( POP); - STORE( resultVar); - OP( POP); - - /* - * Now we handle all the registered 'on' and 'trap' handlers in order. - * For us to be here, there must be at least one handler. - * - * Slight overallocation, but reduces size of this function. - */ - - addrsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers); - forwardsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers); - - for (i=0 ; i<numHandlers ; i++) { - sprintf(buf, "%d", matchCodes[i]); - OP( DUP); - PUSH( buf); - OP( EQ); - JUMP(notCodeJumpSource, JUMP_FALSE4); - if (matchClauses[i]) { - Tcl_ListObjLength(NULL, matchClauses[i], &len); - - /* - * Match the errorcode according to try/trap rules. - */ - - LOAD( optionsVar); - PUSH( "-errorcode"); - OP4( DICT_GET, 1); - TclAdjustStackDepth(-1, envPtr); - OP44( LIST_RANGE_IMM, 0, len-1); - PUSH( TclGetString(matchClauses[i])); - OP( STR_EQ); - JUMP(notECJumpSource, JUMP_FALSE4); - } else { - notECJumpSource = -1; /* LINT */ - } - OP( POP); - - /* - * There is no finally clause, so we can avoid wrapping a catch - * context around the handler. That simplifies what instructions need - * to be issued a lot since we can let errors just fall through. - */ - - if (resultVars[i] >= 0) { - LOAD( resultVar); - STORE( resultVars[i]); - OP( POP); - if (optionVars[i] >= 0) { - LOAD( optionsVar); - STORE( optionVars[i]); - OP( POP); - } - } - if (!handlerTokens[i]) { - forwardsNeedFixing = 1; - JUMP(forwardsToFix[i], JUMP4); - } else { - forwardsToFix[i] = -1; - if (forwardsNeedFixing) { - forwardsNeedFixing = 0; - for (j=0 ; j<i ; j++) { - if (forwardsToFix[j] == -1) { - continue; - } - FIXJUMP(forwardsToFix[j]); - forwardsToFix[j] = -1; - } - } - envPtr->currStackDepth = savedStackDepth; - BODY( handlerTokens[i], 5+i*4); - } - - JUMP(addrsToFix[i], JUMP4); - if (matchClauses[i]) { - FIXJUMP(notECJumpSource); - } - FIXJUMP(notCodeJumpSource); - } - - /* - * Drop the result code since it didn't match any clause, and reissue the - * exception. Note also that INST_RETURN_STK can proceed to the next - * instruction. - */ - - OP( POP); - LOAD( optionsVar); - LOAD( resultVar); - OP( RETURN_STK); - - /* - * Fix all the jumps from taken clauses to here (which is the end of the - * [try]). - */ - - for (i=0 ; i<numHandlers ; i++) { - FIXJUMP(addrsToFix[i]); - } - TclStackFree(interp, forwardsToFix); - TclStackFree(interp, addrsToFix); - envPtr->currStackDepth = savedStackDepth + 1; - return TCL_OK; -} - -static int -IssueTryFinallyInstructions( - Tcl_Interp *interp, - CompileEnv *envPtr, - Tcl_Token *bodyToken, - int numHandlers, - int *matchCodes, - Tcl_Obj **matchClauses, - int *resultVars, - int *optionVars, - Tcl_Token **handlerTokens, - Tcl_Token *finallyToken) /* Not NULL */ -{ - int savedStackDepth = envPtr->currStackDepth; - int range, resultVar, optionsVar, i, j, len, forwardsNeedFixing = 0; - int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource; - char buf[TCL_INTEGER_SPACE]; - - resultVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); - optionsVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); - if (resultVar < 0 || optionsVar < 0) { - return TCL_ERROR; - } - - /* - * Compile the body, trapping any error in it so that we can trap on it - * (if any trap matches) and run a finally clause. - */ - - range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); - OP4( BEGIN_CATCH4, range); - ExceptionRangeStarts(envPtr, range); - envPtr->currStackDepth = savedStackDepth; - BODY( bodyToken, 1); - ExceptionRangeEnds(envPtr, range); - PUSH( "0"); - OP4( REVERSE, 2); - OP1( JUMP1, 4); - ExceptionRangeTarget(envPtr, range, catchOffset); - OP( PUSH_RETURN_CODE); - OP( PUSH_RESULT); - OP( PUSH_RETURN_OPTIONS); - OP( END_CATCH); - STORE( optionsVar); - OP( POP); - STORE( resultVar); - OP( POP); - envPtr->currStackDepth = savedStackDepth + 1; - - /* - * Now we handle all the registered 'on' and 'trap' handlers in order. - */ - - if (numHandlers) { - /* - * Slight overallocation, but reduces size of this function. - */ - - addrsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers); - forwardsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers); - - for (i=0 ; i<numHandlers ; i++) { - sprintf(buf, "%d", matchCodes[i]); - OP( DUP); - PUSH( buf); - OP( EQ); - JUMP(notCodeJumpSource, JUMP_FALSE4); - if (matchClauses[i]) { - Tcl_ListObjLength(NULL, matchClauses[i], &len); - - /* - * Match the errorcode according to try/trap rules. - */ - - LOAD( optionsVar); - PUSH( "-errorcode"); - OP4( DICT_GET, 1); - TclAdjustStackDepth(-1, envPtr); - OP44( LIST_RANGE_IMM, 0, len-1); - PUSH( TclGetString(matchClauses[i])); - OP( STR_EQ); - JUMP(notECJumpSource, JUMP_FALSE4); - } else { - notECJumpSource = -1; /* LINT */ - } - - /* - * There is a finally clause, so we need a fairly complex sequence - * of instructions to deal with an on/trap handler because we must - * call the finally handler *and* we need to substitute the result - * from a failed trap for the result from the main script. - */ - - if (resultVars[i] >= 0 || handlerTokens[i]) { - range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); - OP4( BEGIN_CATCH4, range); - ExceptionRangeStarts(envPtr, range); - } - if (resultVars[i] >= 0) { - LOAD( resultVar); - STORE( resultVars[i]); - OP( POP); - if (optionVars[i] >= 0) { - LOAD( optionsVar); - STORE( optionVars[i]); - OP( POP); - } - - if (!handlerTokens[i]) { - /* - * No handler. Will not be the last handler (that is a - * condition that is checked by the caller). Chain to the - * next one. - */ - - ExceptionRangeEnds(envPtr, range); - OP( END_CATCH); - forwardsNeedFixing = 1; - JUMP(forwardsToFix[i], JUMP4); - goto finishTrapCatchHandling; - } - } else if (!handlerTokens[i]) { - /* - * No handler. Will not be the last handler (that condition is - * checked by the caller). Chain to the next one. - */ - - forwardsNeedFixing = 1; - JUMP(forwardsToFix[i], JUMP4); - goto endOfThisArm; - } - - /* - * Got a handler. Make sure that any pending patch-up actions from - * previous unprocessed handlers are dealt with now that we know - * where they are to jump to. - */ - - if (forwardsNeedFixing) { - forwardsNeedFixing = 0; - OP1( JUMP1, 7); - for (j=0 ; j<i ; j++) { - if (forwardsToFix[j] == -1) { - continue; - } - FIXJUMP(forwardsToFix[j]); - forwardsToFix[j] = -1; - } - OP4( BEGIN_CATCH4, range); - } - envPtr->currStackDepth = savedStackDepth; - BODY( handlerTokens[i], 5+i*4); - ExceptionRangeEnds(envPtr, range); - OP( PUSH_RETURN_OPTIONS); - OP4( REVERSE, 2); - OP1( JUMP1, 4); - forwardsToFix[i] = -1; - - /* - * Error in handler or setting of variables; replace the stored - * exception with the new one. Note that we only push this if we - * have either a body or some variable setting here. Otherwise - * this code is unreachable. - */ - - finishTrapCatchHandling: - ExceptionRangeTarget(envPtr, range, catchOffset); - OP( PUSH_RETURN_OPTIONS); - OP( PUSH_RESULT); - OP( END_CATCH); - STORE( resultVar); - OP( POP); - STORE( optionsVar); - OP( POP); - - endOfThisArm: - if (i+1 < numHandlers) { - JUMP(addrsToFix[i], JUMP4); - } - if (matchClauses[i]) { - FIXJUMP(notECJumpSource); - } - FIXJUMP(notCodeJumpSource); - } - - /* - * Fix all the jumps from taken clauses to here (the start of the - * finally clause). - */ - - for (i=0 ; i<numHandlers-1 ; i++) { - FIXJUMP(addrsToFix[i]); - } - TclStackFree(interp, forwardsToFix); - TclStackFree(interp, addrsToFix); - } - - /* - * Drop the result code. - */ - - OP( POP); - - /* - * Process the finally clause (at last!) Note that we do not wrap this in - * error handlers because we would just rethrow immediately anyway. Then - * (on normal success) we reissue the exception. Note also that - * INST_RETURN_STK can proceed to the next instruction; that'll be the - * next command (or some inter-command manipulation). - */ - - envPtr->currStackDepth = savedStackDepth; - BODY( finallyToken, 3 + 4*numHandlers); - OP( POP); - LOAD( optionsVar); - LOAD( resultVar); - OP( RETURN_STK); - envPtr->currStackDepth = savedStackDepth + 1; - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileUnsetCmd -- - * - * Procedure called to compile the "unset" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "unset" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileUnsetCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *varTokenPtr; - int isScalar, simpleVarName, localIndex, numWords, flags, i; - Tcl_Obj *leadingWord; - - numWords = parsePtr->numWords-1; - flags = 1; - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - leadingWord = Tcl_NewObj(); - if (numWords > 0 && TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) { - int len; - const char *bytes = Tcl_GetStringFromObj(leadingWord, &len); - - if (len == 11 && !strncmp("-nocomplain", bytes, 11)) { - flags = 0; - varTokenPtr = TokenAfter(varTokenPtr); - numWords--; - } else if (len == 2 && !strncmp("--", bytes, 2)) { - varTokenPtr = TokenAfter(varTokenPtr); - numWords--; - } - } else { - /* - * Cannot guarantee that the first word is not '-nocomplain' at - * evaluation with reasonable effort, so spill to interpreted version. - */ - - TclDecrRefCount(leadingWord); - return TCL_ERROR; - } - TclDecrRefCount(leadingWord); - - for (i=0 ; i<numWords ; i++) { - /* - * Decide if we can use a frame slot for the var/array name or if we - * need to emit code to compute and push the name at runtime. We use a - * frame slot (entry in the array of local vars) if we are compiling a - * procedure body and if the name is simple text that does not include - * namespace qualifiers. - */ - - PushVarName(interp, varTokenPtr, envPtr, 0, - &localIndex, &simpleVarName, &isScalar); - - /* - * Emit instructions to unset the variable. - */ - - if (!simpleVarName) { - OP1( UNSET_STK, flags); - } else if (isScalar) { - if (localIndex < 0) { - OP1( UNSET_STK, flags); - } else { - OP14( UNSET_SCALAR, flags, localIndex); - } - } else { - if (localIndex < 0) { - OP1( UNSET_ARRAY_STK, flags); - } else { - OP14( UNSET_ARRAY, flags, localIndex); - } - } - - varTokenPtr = TokenAfter(varTokenPtr); - } - PushLiteral(envPtr, "", 0); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileWhileCmd -- - * - * Procedure called to compile the "while" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "while" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileWhileCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *testTokenPtr, *bodyTokenPtr; - JumpFixup jumpEvalCondFixup; - int testCodeOffset, bodyCodeOffset, jumpDist, range, code, boolVal; - int savedStackDepth = envPtr->currStackDepth; - int loopMayEnd = 1; /* This is set to 0 if it is recognized as an - * infinite loop. */ - Tcl_Obj *boolObj; - - if (parsePtr->numWords != 3) { - return TCL_ERROR; - } - - /* - * If the test expression requires substitutions, don't compile the while - * command inline. E.g., the expression might cause the loop to never - * execute or execute forever, as in "while "$x < 5" {}". - * - * Bail out also if the body expression requires substitutions in order to - * insure correct behaviour [Bug 219166] - */ - - testTokenPtr = TokenAfter(parsePtr->tokenPtr); - bodyTokenPtr = TokenAfter(testTokenPtr); - - if ((testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) - || (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) { - return TCL_ERROR; - } - - /* - * Find out if the condition is a constant. - */ - - boolObj = Tcl_NewStringObj(testTokenPtr[1].start, testTokenPtr[1].size); - Tcl_IncrRefCount(boolObj); - code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal); - TclDecrRefCount(boolObj); - if (code == TCL_OK) { - if (boolVal) { - /* - * It is an infinite loop; flag it so that we generate a more - * efficient body. - */ - - loopMayEnd = 0; - } else { - /* - * This is an empty loop: "while 0 {...}" or such. Compile no - * bytecodes. - */ - - goto pushResult; - } - } - - /* - * Create a ExceptionRange record for the loop body. This is used to - * implement break and continue. - */ - - range = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE); - - /* - * Jump to the evaluation of the condition. This code uses the "loop - * rotation" optimisation (which eliminates one branch from the loop). - * "while cond body" produces then: - * goto A - * B: body : bodyCodeOffset - * A: cond -> result : testCodeOffset, continueOffset - * if (result) goto B - * - * The infinite loop "while 1 body" produces: - * B: body : all three offsets here - * goto B - */ - - if (loopMayEnd) { - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &jumpEvalCondFixup); - testCodeOffset = 0; /* Avoid compiler warning. */ - } else { - /* - * Make sure that the first command in the body is preceded by an - * INST_START_CMD, and hence counted properly. [Bug 1752146] - */ - - envPtr->atCmdStart = 0; - testCodeOffset = CurrentOffset(envPtr); - } - - /* - * Compile the loop body. - */ - - bodyCodeOffset = ExceptionRangeStarts(envPtr, range); - CompileBody(envPtr, bodyTokenPtr, interp); - ExceptionRangeEnds(envPtr, range); - envPtr->currStackDepth = savedStackDepth + 1; - OP( POP); - - /* - * Compile the test expression then emit the conditional jump that - * terminates the while. We already know it's a simple word. - */ - - if (loopMayEnd) { - testCodeOffset = CurrentOffset(envPtr); - jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset; - if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) { - bodyCodeOffset += 3; - testCodeOffset += 3; - } - envPtr->currStackDepth = savedStackDepth; - TclCompileExprWords(interp, testTokenPtr, 1, envPtr); - envPtr->currStackDepth = savedStackDepth + 1; - - jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; - if (jumpDist > 127) { - TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr); - } else { - TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr); - } - } else { - jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; - if (jumpDist > 127) { - TclEmitInstInt4(INST_JUMP4, -jumpDist, envPtr); - } else { - TclEmitInstInt1(INST_JUMP1, -jumpDist, envPtr); - } - } - - /* - * Set the loop's body, continue and break offsets. - */ - - envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset; - envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset; - ExceptionRangeTarget(envPtr, range, breakOffset); - - /* - * The while command's result is an empty string. - */ - - pushResult: - envPtr->currStackDepth = savedStackDepth; - PushLiteral(envPtr, "", 0); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileYieldCmd -- - * - * Procedure called to compile the "yield" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "yield" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileYieldCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - if (parsePtr->numWords < 1 || parsePtr->numWords > 2) { - return TCL_ERROR; - } - - if (parsePtr->numWords == 1) { - PushLiteral(envPtr, "", 0); - } else { - Tcl_Token *valueTokenPtr = TokenAfter(parsePtr->tokenPtr); - - CompileWord(envPtr, valueTokenPtr, interp, 1); - } - OP( YIELD); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * PushVarName -- - * - * Procedure used in the compiling where pushing a variable name is - * necessary (append, lappend, set). - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "set" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -static int -PushVarName( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Token *varTokenPtr, /* Points to a variable token. */ - CompileEnv *envPtr, /* Holds resulting instructions. */ - int flags, /* TCL_NO_LARGE_INDEX. */ - int *localIndexPtr, /* Must not be NULL. */ - int *simpleVarNamePtr, /* Must not be NULL. */ - int *isScalarPtr) /* Must not be NULL. */ -{ - register const char *p; - const char *name, *elName; - register int i, n; - Tcl_Token *elemTokenPtr = NULL; - int nameChars, elNameChars, simpleVarName, localIndex; - int elemTokenCount = 0, allocedTokens = 0, removedParen = 0; - - /* - * Decide if we can use a frame slot for the var/array name or if we need - * to emit code to compute and push the name at runtime. We use a frame - * slot (entry in the array of local vars) if we are compiling a procedure - * body and if the name is simple text that does not include namespace - * qualifiers. - */ - - simpleVarName = 0; - name = elName = NULL; - nameChars = elNameChars = 0; - localIndex = -1; - - /* - * Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether - * curly braces surround the variable name. This really matters for array - * elements to handle things like - * set {x($foo)} 5 - * which raises an undefined var error if we are not careful here. - */ - - if ((varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) && - (varTokenPtr->start[0] != '{')) { - /* - * A simple variable name. Divide it up into "name" and "elName" - * strings. If it is not a local variable, look it up at runtime. - */ - - simpleVarName = 1; - - name = varTokenPtr[1].start; - nameChars = varTokenPtr[1].size; - if (name[nameChars-1] == ')') { - /* - * last char is ')' => potential array reference. - */ - - for (i=0,p=name ; i<nameChars ; i++,p++) { - if (*p == '(') { - elName = p + 1; - elNameChars = nameChars - i - 2; - nameChars = i; - break; - } - } - - if ((elName != NULL) && elNameChars) { - /* - * An array element, the element name is a simple string: - * assemble the corresponding token. - */ - - elemTokenPtr = TclStackAlloc(interp, sizeof(Tcl_Token)); - allocedTokens = 1; - elemTokenPtr->type = TCL_TOKEN_TEXT; - elemTokenPtr->start = elName; - elemTokenPtr->size = elNameChars; - elemTokenPtr->numComponents = 0; - elemTokenCount = 1; - } - } - } else if (((n = varTokenPtr->numComponents) > 1) - && (varTokenPtr[1].type == TCL_TOKEN_TEXT) - && (varTokenPtr[n].type == TCL_TOKEN_TEXT) - && (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) { - /* - * Check for parentheses inside first token. - */ - - simpleVarName = 0; - for (i = 0, p = varTokenPtr[1].start; - i < varTokenPtr[1].size; i++, p++) { - if (*p == '(') { - simpleVarName = 1; - break; - } - } - if (simpleVarName) { - int remainingChars; - - /* - * Check the last token: if it is just ')', do not count it. - * Otherwise, remove the ')' and flag so that it is restored at - * the end. - */ - - if (varTokenPtr[n].size == 1) { - n--; - } else { - varTokenPtr[n].size--; - removedParen = n; - } - - name = varTokenPtr[1].start; - nameChars = p - varTokenPtr[1].start; - elName = p + 1; - remainingChars = (varTokenPtr[2].start - p) - 1; - elNameChars = (varTokenPtr[n].start-p) + varTokenPtr[n].size - 2; - - if (remainingChars) { - /* - * Make a first token with the extra characters in the first - * token. - */ - - elemTokenPtr = TclStackAlloc(interp, n * sizeof(Tcl_Token)); - allocedTokens = 1; - elemTokenPtr->type = TCL_TOKEN_TEXT; - elemTokenPtr->start = elName; - elemTokenPtr->size = remainingChars; - elemTokenPtr->numComponents = 0; - elemTokenCount = n; - - /* - * Copy the remaining tokens. - */ - - memcpy(elemTokenPtr+1, varTokenPtr+2, - (n-1) * sizeof(Tcl_Token)); - } else { - /* - * Use the already available tokens. - */ - - elemTokenPtr = &varTokenPtr[2]; - elemTokenCount = n - 1; - } - } - } - - if (simpleVarName) { - /* - * See whether name has any namespace separators (::'s). - */ - - int hasNsQualifiers = 0; - - for (i = 0, p = name; i < nameChars; i++, p++) { - if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) { - hasNsQualifiers = 1; - break; - } - } - - /* - * Look up the var name's index in the array of local vars in the proc - * frame. If retrieving the var's value and it doesn't already exist, - * push its name and look it up at runtime. - */ - - if (!hasNsQualifiers) { - localIndex = TclFindCompiledLocal(name, nameChars, - 1, envPtr); - if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) { - /* - * We'll push the name. - */ - - localIndex = -1; - } - } - if (localIndex < 0) { - PushLiteral(envPtr, name, nameChars); - } - - /* - * Compile the element script, if any. - */ - - if (elName != NULL) { - if (elNameChars) { - TclCompileTokens(interp, elemTokenPtr, elemTokenCount, - envPtr); - } else { - PushLiteral(envPtr, "", 0); - } - } - } else { - /* - * The var name isn't simple: compile and push it. - */ - - CompileTokens(envPtr, varTokenPtr, interp); - } - - if (removedParen) { - varTokenPtr[removedParen].size++; - } - if (allocedTokens) { - TclStackFree(interp, elemTokenPtr); - } - *localIndexPtr = localIndex; - *simpleVarNamePtr = simpleVarName; - *isScalarPtr = (elName == NULL); - return TCL_OK; -} + OP4(STORE_SCALAR4,(idx)) /* *---------------------------------------------------------------------- diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 46b652c..3fc070c 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -12,7 +12,7 @@ */ #include "tclInt.h" -#include "tclCompile.h" /* CompileEnv */ +#include "tclCompileInt.h" /* CompileEnv */ /* * Expression parsing takes place in the routine ParseExpr(). It takes a @@ -917,7 +917,7 @@ ParseExpr( case SCRIPT: { Tcl_Parse *nestedPtr = - TclStackAlloc(interp, sizeof(Tcl_Parse)); + ckalloc(sizeof(Tcl_Parse)); tokenPtr = parsePtr->tokenPtr + parsePtr->numTokens; tokenPtr->type = TCL_TOKEN_COMMAND; @@ -952,7 +952,7 @@ ParseExpr( break; } } - TclStackFree(interp, nestedPtr); + ckfree(nestedPtr); end = start; start = tokenPtr->start; scanned = end - start; @@ -1835,7 +1835,7 @@ Tcl_ParseExpr( OpNode *opTree = NULL; /* Will point to the tree of operators. */ Tcl_Obj *litList = Tcl_NewObj(); /* List to hold the literals. */ Tcl_Obj *funcList = Tcl_NewObj(); /* List to hold the functon names. */ - Tcl_Parse *exprParsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse)); + Tcl_Parse *exprParsePtr = ckalloc(sizeof(Tcl_Parse)); /* Holds the Tcl_Tokens of substitutions. */ if (numBytes < 0) { @@ -1857,7 +1857,7 @@ Tcl_ParseExpr( } Tcl_FreeParse(exprParsePtr); - TclStackFree(interp, exprParsePtr); + ckfree(exprParsePtr); ckfree(opTree); return code; } @@ -2127,7 +2127,7 @@ TclCompileExpr( OpNode *opTree = NULL; /* Will point to the tree of operators */ Tcl_Obj *litList = Tcl_NewObj(); /* List to hold the literals */ Tcl_Obj *funcList = Tcl_NewObj(); /* List to hold the functon names*/ - Tcl_Parse *parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse)); + Tcl_Parse *parsePtr = ckalloc(sizeof(Tcl_Parse)); /* Holds the Tcl_Tokens of substitutions */ int code = ParseExpr(interp, script, numBytes, &opTree, litList, @@ -2151,7 +2151,7 @@ TclCompileExpr( } Tcl_FreeParse(parsePtr); - TclStackFree(interp, parsePtr); + ckfree(parsePtr); Tcl_DecrRefCount(funcList); Tcl_DecrRefCount(litList); ckfree(opTree); @@ -2194,7 +2194,7 @@ ExecConstantExprTree( */ TclNRSetRoot(interp); - envPtr = TclStackAlloc(interp, sizeof(CompileEnv)); + envPtr = ckalloc(sizeof(CompileEnv)); TclInitCompileEnv(interp, envPtr, NULL, 0); CompileExprTree(interp, nodes, index, litObjvPtr, NULL, NULL, envPtr, 0 /* optimize */); @@ -2202,7 +2202,7 @@ ExecConstantExprTree( Tcl_IncrRefCount(byteCodeObj); TclInitByteCodeObj(byteCodeObj, envPtr); TclFreeCompileEnv(envPtr); - TclStackFree(interp, envPtr); + ckfree(envPtr); byteCodePtr = byteCodeObj->internalRep.otherValuePtr; TclNRExecuteByteCode(interp, byteCodePtr); code = TclNRRunCallbacks(interp, TCL_OK); @@ -2259,10 +2259,10 @@ CompileExprTree( switch (nodePtr->lexeme) { case QUESTION: - newJump = TclStackAlloc(interp, sizeof(JumpList)); + newJump = ckalloc(sizeof(JumpList)); newJump->next = jumpPtr; jumpPtr = newJump; - newJump = TclStackAlloc(interp, sizeof(JumpList)); + newJump = ckalloc(sizeof(JumpList)); newJump->next = jumpPtr; jumpPtr = newJump; jumpPtr->depth = envPtr->currStackDepth; @@ -2270,13 +2270,13 @@ CompileExprTree( break; case AND: case OR: - newJump = TclStackAlloc(interp, sizeof(JumpList)); + newJump = ckalloc(sizeof(JumpList)); newJump->next = jumpPtr; jumpPtr = newJump; - newJump = TclStackAlloc(interp, sizeof(JumpList)); + newJump = ckalloc(sizeof(JumpList)); newJump->next = jumpPtr; jumpPtr = newJump; - newJump = TclStackAlloc(interp, sizeof(JumpList)); + newJump = ckalloc(sizeof(JumpList)); newJump->next = jumpPtr; jumpPtr = newJump; jumpPtr->depth = envPtr->currStackDepth; @@ -2349,11 +2349,7 @@ CompileExprTree( * command with the correct number of arguments. */ - if (numWords < 255) { - TclEmitInstInt1(INST_INVOKE_STK1, numWords, envPtr); - } else { - TclEmitInstInt4(INST_INVOKE_STK4, numWords, envPtr); - } + TclEmitInstInt4(INST_INVOKE_STK4, numWords, envPtr); /* * Restore any saved numWords value. @@ -2382,10 +2378,10 @@ CompileExprTree( envPtr->currStackDepth = jumpPtr->depth + 1; freePtr = jumpPtr; jumpPtr = jumpPtr->next; - TclStackFree(interp, freePtr); + ckfree(freePtr); freePtr = jumpPtr; jumpPtr = jumpPtr->next; - TclStackFree(interp, freePtr); + ckfree(freePtr); break; case AND: case OR: @@ -2409,13 +2405,13 @@ CompileExprTree( envPtr->currStackDepth = jumpPtr->depth + 1; freePtr = jumpPtr; jumpPtr = jumpPtr->next; - TclStackFree(interp, freePtr); + ckfree(freePtr); freePtr = jumpPtr; jumpPtr = jumpPtr->next; - TclStackFree(interp, freePtr); + ckfree(freePtr); freePtr = jumpPtr; jumpPtr = jumpPtr->next; - TclStackFree(interp, freePtr); + ckfree(freePtr); break; default: TclEmitOpcode(instruction[nodePtr->lexeme], envPtr); @@ -2619,9 +2615,8 @@ TclSortingOpCmd( Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); } else { TclOpCmdClientData *occdPtr = clientData; - Tcl_Obj **litObjv = TclStackAlloc(interp, - 2 * (objc-2) * sizeof(Tcl_Obj *)); - OpNode *nodes = TclStackAlloc(interp, 2 * (objc-2) * sizeof(OpNode)); + Tcl_Obj **litObjv = ckalloc(2 * (objc-2) * sizeof(Tcl_Obj *)); + OpNode *nodes = ckalloc(2 * (objc-2) * sizeof(OpNode)); unsigned char lexeme; int i, lastAnd = 1; Tcl_Obj *const *litObjPtrPtr = litObjv; @@ -2661,8 +2656,8 @@ TclSortingOpCmd( code = ExecConstantExprTree(interp, nodes, 0, &litObjPtrPtr); - TclStackFree(interp, nodes); - TclStackFree(interp, litObjv); + ckfree(nodes); + ckfree(litObjv); } return code; } @@ -2748,7 +2743,7 @@ TclVariadicOpCmd( return code; } else { Tcl_Obj *const *litObjv = objv + 1; - OpNode *nodes = TclStackAlloc(interp, (objc-1) * sizeof(OpNode)); + OpNode *nodes = ckalloc((objc-1) * sizeof(OpNode)); int i, lastOp = OT_LITERAL; nodes[0].lexeme = START; @@ -2781,7 +2776,7 @@ TclVariadicOpCmd( code = ExecConstantExprTree(interp, nodes, 0, &litObjv); - TclStackFree(interp, nodes); + ckfree(nodes); return code; } } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 2f6b166..424a6f4 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -13,7 +13,7 @@ */ #include "tclInt.h" -#include "tclCompile.h" +#include "tclCompileInt.h" /* * Table of all AuxData types. @@ -33,10 +33,6 @@ TCL_DECLARE_MUTEX(tableMutex) * This variable is linked to the Tcl variable "tcl_traceCompile". */ -#ifdef TCL_COMPILE_DEBUG -int tclTraceCompile = 0; -static int traceInitialized = 0; -#endif /* * A table describing the Tcl bytecode instructions. Entries in this table @@ -52,488 +48,53 @@ static int traceInitialized = 0; InstructionDesc const tclInstructionTable[] = { /* Name Bytes stackEffect #Opnds Operand types */ - {"done", 1, -1, 0, {OPERAND_NONE}}, - /* Finish ByteCode execution and return stktop (top stack item) */ - {"push1", 2, +1, 1, {OPERAND_UINT1}}, - /* Push object at ByteCode objArray[op1] */ - {"push4", 5, +1, 1, {OPERAND_UINT4}}, - /* Push object at ByteCode objArray[op4] */ - {"pop", 1, -1, 0, {OPERAND_NONE}}, - /* Pop the topmost stack object */ - {"dup", 1, +1, 0, {OPERAND_NONE}}, - /* Duplicate the topmost stack object and push the result */ - {"concat1", 2, INT_MIN, 1, {OPERAND_UINT1}}, - /* Concatenate the top op1 items and push result */ - {"invokeStk1", 2, INT_MIN, 1, {OPERAND_UINT1}}, - /* Invoke command named objv[0]; <objc,objv> = <op1,top op1> */ - {"invokeStk4", 5, INT_MIN, 1, {OPERAND_UINT4}}, - /* Invoke command named objv[0]; <objc,objv> = <op4,top op4> */ - {"evalStk", 1, 0, 0, {OPERAND_NONE}}, - /* Evaluate command in stktop using Tcl_EvalObj. */ - {"exprStk", 1, 0, 0, {OPERAND_NONE}}, - /* Execute expression in stktop using Tcl_ExprStringObj. */ - - {"loadScalar1", 2, 1, 1, {OPERAND_LVT1}}, - /* Load scalar variable at index op1 <= 255 in call frame */ - {"loadScalar4", 5, 1, 1, {OPERAND_LVT4}}, - /* Load scalar variable at index op1 >= 256 in call frame */ - {"loadScalarStk", 1, 0, 0, {OPERAND_NONE}}, - /* Load scalar variable; scalar's name is stktop */ - {"loadArray1", 2, 0, 1, {OPERAND_LVT1}}, - /* Load array element; array at slot op1<=255, element is stktop */ - {"loadArray4", 5, 0, 1, {OPERAND_LVT4}}, - /* Load array element; array at slot op1 > 255, element is stktop */ - {"loadArrayStk", 1, -1, 0, {OPERAND_NONE}}, - /* Load array element; element is stktop, array name is stknext */ - {"loadStk", 1, 0, 0, {OPERAND_NONE}}, - /* Load general variable; unparsed variable name is stktop */ - {"storeScalar1", 2, 0, 1, {OPERAND_LVT1}}, - /* Store scalar variable at op1<=255 in frame; value is stktop */ - {"storeScalar4", 5, 0, 1, {OPERAND_LVT4}}, - /* Store scalar variable at op1 > 255 in frame; value is stktop */ - {"storeScalarStk", 1, -1, 0, {OPERAND_NONE}}, - /* Store scalar; value is stktop, scalar name is stknext */ - {"storeArray1", 2, -1, 1, {OPERAND_LVT1}}, - /* Store array element; array at op1<=255, value is top then elem */ - {"storeArray4", 5, -1, 1, {OPERAND_LVT4}}, - /* Store array element; array at op1>=256, value is top then elem */ - {"storeArrayStk", 1, -2, 0, {OPERAND_NONE}}, - /* Store array element; value is stktop, then elem, array names */ - {"storeStk", 1, -1, 0, {OPERAND_NONE}}, - /* Store general variable; value is stktop, then unparsed name */ - - {"incrScalar1", 2, 0, 1, {OPERAND_LVT1}}, - /* Incr scalar at index op1<=255 in frame; incr amount is stktop */ - {"incrScalarStk", 1, -1, 0, {OPERAND_NONE}}, - /* Incr scalar; incr amount is stktop, scalar's name is stknext */ - {"incrArray1", 2, -1, 1, {OPERAND_LVT1}}, - /* Incr array elem; arr at slot op1<=255, amount is top then elem */ - {"incrArrayStk", 1, -2, 0, {OPERAND_NONE}}, - /* Incr array element; amount is top then elem then array names */ - {"incrStk", 1, -1, 0, {OPERAND_NONE}}, - /* Incr general variable; amount is stktop then unparsed var name */ - {"incrScalar1Imm", 3, +1, 2, {OPERAND_LVT1, OPERAND_INT1}}, - /* Incr scalar at slot op1 <= 255; amount is 2nd operand byte */ - {"incrScalarStkImm", 2, 0, 1, {OPERAND_INT1}}, - /* Incr scalar; scalar name is stktop; incr amount is op1 */ - {"incrArray1Imm", 3, 0, 2, {OPERAND_LVT1, OPERAND_INT1}}, - /* Incr array elem; array at slot op1 <= 255, elem is stktop, - * amount is 2nd operand byte */ - {"incrArrayStkImm", 2, -1, 1, {OPERAND_INT1}}, - /* Incr array element; elem is top then array name, amount is op1 */ - {"incrStkImm", 2, 0, 1, {OPERAND_INT1}}, - /* Incr general variable; unparsed name is top, amount is op1 */ - - {"jump1", 2, 0, 1, {OPERAND_INT1}}, - /* Jump relative to (pc + op1) */ - {"jump4", 5, 0, 1, {OPERAND_INT4}}, - /* Jump relative to (pc + op4) */ - {"jumpTrue1", 2, -1, 1, {OPERAND_INT1}}, - /* Jump relative to (pc + op1) if stktop expr object is true */ - {"jumpTrue4", 5, -1, 1, {OPERAND_INT4}}, - /* Jump relative to (pc + op4) if stktop expr object is true */ - {"jumpFalse1", 2, -1, 1, {OPERAND_INT1}}, - /* Jump relative to (pc + op1) if stktop expr object is false */ - {"jumpFalse4", 5, -1, 1, {OPERAND_INT4}}, - /* Jump relative to (pc + op4) if stktop expr object is false */ - - {"lor", 1, -1, 0, {OPERAND_NONE}}, - /* Logical or: push (stknext || stktop) */ - {"land", 1, -1, 0, {OPERAND_NONE}}, - /* Logical and: push (stknext && stktop) */ - {"bitor", 1, -1, 0, {OPERAND_NONE}}, - /* Bitwise or: push (stknext | stktop) */ - {"bitxor", 1, -1, 0, {OPERAND_NONE}}, - /* Bitwise xor push (stknext ^ stktop) */ - {"bitand", 1, -1, 0, {OPERAND_NONE}}, - /* Bitwise and: push (stknext & stktop) */ - {"eq", 1, -1, 0, {OPERAND_NONE}}, - /* Equal: push (stknext == stktop) */ - {"neq", 1, -1, 0, {OPERAND_NONE}}, - /* Not equal: push (stknext != stktop) */ - {"lt", 1, -1, 0, {OPERAND_NONE}}, - /* Less: push (stknext < stktop) */ - {"gt", 1, -1, 0, {OPERAND_NONE}}, - /* Greater: push (stknext > stktop) */ - {"le", 1, -1, 0, {OPERAND_NONE}}, - /* Less or equal: push (stknext <= stktop) */ - {"ge", 1, -1, 0, {OPERAND_NONE}}, - /* Greater or equal: push (stknext >= stktop) */ - {"lshift", 1, -1, 0, {OPERAND_NONE}}, - /* Left shift: push (stknext << stktop) */ - {"rshift", 1, -1, 0, {OPERAND_NONE}}, - /* Right shift: push (stknext >> stktop) */ - {"add", 1, -1, 0, {OPERAND_NONE}}, - /* Add: push (stknext + stktop) */ - {"sub", 1, -1, 0, {OPERAND_NONE}}, - /* Sub: push (stkext - stktop) */ - {"mult", 1, -1, 0, {OPERAND_NONE}}, - /* Multiply: push (stknext * stktop) */ - {"div", 1, -1, 0, {OPERAND_NONE}}, - /* Divide: push (stknext / stktop) */ - {"mod", 1, -1, 0, {OPERAND_NONE}}, - /* Mod: push (stknext % stktop) */ - {"uplus", 1, 0, 0, {OPERAND_NONE}}, - /* Unary plus: push +stktop */ - {"uminus", 1, 0, 0, {OPERAND_NONE}}, - /* Unary minus: push -stktop */ - {"bitnot", 1, 0, 0, {OPERAND_NONE}}, - /* Bitwise not: push ~stktop */ - {"not", 1, 0, 0, {OPERAND_NONE}}, - /* Logical not: push !stktop */ - {"callBuiltinFunc1", 2, 1, 1, {OPERAND_UINT1}}, - /* Call builtin math function with index op1; any args are on stk */ - {"callFunc1", 2, INT_MIN, 1, {OPERAND_UINT1}}, - /* Call non-builtin func objv[0]; <objc,objv>=<op1,top op1> */ - {"tryCvtToNumeric", 1, 0, 0, {OPERAND_NONE}}, - /* Try converting stktop to first int then double if possible. */ - - {"break", 1, 0, 0, {OPERAND_NONE}}, - /* Abort closest enclosing loop; if none, return TCL_BREAK code. */ - {"continue", 1, 0, 0, {OPERAND_NONE}}, - /* Skip to next iteration of closest enclosing loop; if none, return - * TCL_CONTINUE code. */ - - {"foreach_start4", 5, 0, 1, {OPERAND_AUX4}}, - /* Initialize execution of a foreach loop. Operand is aux data index - * of the ForeachInfo structure for the foreach command. */ - {"foreach_step4", 5, +1, 1, {OPERAND_AUX4}}, - /* "Step" or begin next iteration of foreach loop. Push 0 if to - * terminate loop, else push 1. */ - - {"beginCatch4", 5, 0, 1, {OPERAND_UINT4}}, - /* Record start of catch with the operand's exception index. Push the - * current stack depth onto a special catch stack. */ - {"endCatch", 1, 0, 0, {OPERAND_NONE}}, - /* End of last catch. Pop the bytecode interpreter's catch stack. */ - {"pushResult", 1, +1, 0, {OPERAND_NONE}}, - /* Push the interpreter's object result onto the stack. */ - {"pushReturnCode", 1, +1, 0, {OPERAND_NONE}}, - /* Push interpreter's return code (e.g. TCL_OK or TCL_ERROR) as a new - * object onto the stack. */ - - {"streq", 1, -1, 0, {OPERAND_NONE}}, - /* Str Equal: push (stknext eq stktop) */ - {"strneq", 1, -1, 0, {OPERAND_NONE}}, - /* Str !Equal: push (stknext neq stktop) */ - {"strcmp", 1, -1, 0, {OPERAND_NONE}}, - /* Str Compare: push (stknext cmp stktop) */ - {"strlen", 1, 0, 0, {OPERAND_NONE}}, - /* Str Length: push (strlen stktop) */ - {"strindex", 1, -1, 0, {OPERAND_NONE}}, - /* Str Index: push (strindex stknext stktop) */ - {"strmatch", 2, -1, 1, {OPERAND_INT1}}, - /* Str Match: push (strmatch stknext stktop) opnd == nocase */ - - {"list", 5, INT_MIN, 1, {OPERAND_UINT4}}, - /* List: push (stk1 stk2 ... stktop) */ - {"listIndex", 1, -1, 0, {OPERAND_NONE}}, - /* List Index: push (listindex stknext stktop) */ - {"listLength", 1, 0, 0, {OPERAND_NONE}}, - /* List Len: push (listlength stktop) */ - - {"appendScalar1", 2, 0, 1, {OPERAND_LVT1}}, - /* Append scalar variable at op1<=255 in frame; value is stktop */ - {"appendScalar4", 5, 0, 1, {OPERAND_LVT4}}, - /* Append scalar variable at op1 > 255 in frame; value is stktop */ - {"appendArray1", 2, -1, 1, {OPERAND_LVT1}}, - /* Append array element; array at op1<=255, value is top then elem */ - {"appendArray4", 5, -1, 1, {OPERAND_LVT4}}, - /* Append array element; array at op1>=256, value is top then elem */ - {"appendArrayStk", 1, -2, 0, {OPERAND_NONE}}, - /* Append array element; value is stktop, then elem, array names */ - {"appendStk", 1, -1, 0, {OPERAND_NONE}}, - /* Append general variable; value is stktop, then unparsed name */ - {"lappendScalar1", 2, 0, 1, {OPERAND_LVT1}}, - /* Lappend scalar variable at op1<=255 in frame; value is stktop */ - {"lappendScalar4", 5, 0, 1, {OPERAND_LVT4}}, - /* Lappend scalar variable at op1 > 255 in frame; value is stktop */ - {"lappendArray1", 2, -1, 1, {OPERAND_LVT1}}, - /* Lappend array element; array at op1<=255, value is top then elem */ - {"lappendArray4", 5, -1, 1, {OPERAND_LVT4}}, - /* Lappend array element; array at op1>=256, value is top then elem */ - {"lappendArrayStk", 1, -2, 0, {OPERAND_NONE}}, - /* Lappend array element; value is stktop, then elem, array names */ - {"lappendStk", 1, -1, 0, {OPERAND_NONE}}, - /* Lappend general variable; value is stktop, then unparsed name */ - - {"lindexMulti", 5, INT_MIN, 1, {OPERAND_UINT4}}, - /* Lindex with generalized args, operand is number of stacked objs - * used: (operand-1) entries from stktop are the indices; then list to - * process. */ - {"over", 5, +1, 1, {OPERAND_UINT4}}, - /* Duplicate the arg-th element from top of stack (TOS=0) */ - {"lsetList", 1, -2, 0, {OPERAND_NONE}}, - /* Four-arg version of 'lset'. stktop is old value; next is new - * element value, next is the index list; pushes new value */ - {"lsetFlat", 5, INT_MIN, 1, {OPERAND_UINT4}}, - /* Three- or >=5-arg version of 'lset', operand is number of stacked - * objs: stktop is old value, next is new element value, next come - * (operand-2) indices; pushes the new value. - */ - - {"returnImm", 9, -1, 2, {OPERAND_INT4, OPERAND_UINT4}}, - /* Compiled [return], code, level are operands; options and result - * are on the stack. */ - {"expon", 1, -1, 0, {OPERAND_NONE}}, - /* Binary exponentiation operator: push (stknext ** stktop) */ - - /* - * NOTE: the stack effects of expandStkTop and invokeExpanded are wrong - - * but it cannot be done right at compile time, the stack effect is only - * known at run time. The value for invokeExpanded is estimated better at - * compile time. - * See the comments further down in this file, where INST_INVOKE_EXPANDED - * is emitted. - */ - {"expandStart", 1, 0, 0, {OPERAND_NONE}}, - /* Start of command with {*} (expanded) arguments */ - {"expandStkTop", 5, 0, 1, {OPERAND_UINT4}}, - /* Expand the list at stacktop: push its elements on the stack */ - {"invokeExpanded", 1, 0, 0, {OPERAND_NONE}}, - /* Invoke the command marked by the last 'expandStart' */ - - {"listIndexImm", 5, 0, 1, {OPERAND_IDX4}}, - /* List Index: push (lindex stktop op4) */ - {"listRangeImm", 9, 0, 2, {OPERAND_IDX4, OPERAND_IDX4}}, - /* List Range: push (lrange stktop op4 op4) */ - {"startCommand", 9, 0, 2, {OPERAND_INT4,OPERAND_UINT4}}, - /* Start of bytecoded command: op is the length of the cmd's code, op2 - * is number of commands here */ - - {"listIn", 1, -1, 0, {OPERAND_NONE}}, - /* List containment: push [lsearch stktop stknext]>=0) */ - {"listNotIn", 1, -1, 0, {OPERAND_NONE}}, - /* List negated containment: push [lsearch stktop stknext]<0) */ - - {"pushReturnOpts", 1, +1, 0, {OPERAND_NONE}}, - /* Push the interpreter's return option dictionary as an object on the - * stack. */ - {"returnStk", 1, -2, 0, {OPERAND_NONE}}, - /* Compiled [return]; options and result are on the stack, code and - * level are in the options. */ - - {"dictGet", 5, INT_MIN, 1, {OPERAND_UINT4}}, - /* The top op4 words (min 1) are a key path into the dictionary just - * below the keys on the stack, and all those values are replaced by - * the value read out of that key-path (like [dict get]). - * Stack: ... dict key1 ... keyN => ... value */ - {"dictSet", 9, INT_MIN, 2, {OPERAND_UINT4, OPERAND_LVT4}}, - /* Update a dictionary value such that the keys are a path pointing to - * the value. op4#1 = numKeys, op4#2 = LVTindex - * Stack: ... key1 ... keyN value => ... newDict */ - {"dictUnset", 9, INT_MIN, 2, {OPERAND_UINT4, OPERAND_LVT4}}, - /* Update a dictionary value such that the keys are not a path pointing - * to any value. op4#1 = numKeys, op4#2 = LVTindex - * Stack: ... key1 ... keyN => ... newDict */ - {"dictIncrImm", 9, 0, 2, {OPERAND_INT4, OPERAND_LVT4}}, - /* Update a dictionary value such that the value pointed to by key is - * incremented by some value (or set to it if the key isn't in the - * dictionary at all). op4#1 = incrAmount, op4#2 = LVTindex - * Stack: ... key => ... newDict */ - {"dictAppend", 5, -1, 1, {OPERAND_LVT4}}, - /* Update a dictionary value such that the value pointed to by key has - * some value string-concatenated onto it. op4 = LVTindex - * Stack: ... key valueToAppend => ... newDict */ - {"dictLappend", 5, -1, 1, {OPERAND_LVT4}}, - /* Update a dictionary value such that the value pointed to by key has - * some value list-appended onto it. op4 = LVTindex - * Stack: ... key valueToAppend => ... newDict */ - {"dictFirst", 5, +2, 1, {OPERAND_LVT4}}, - /* Begin iterating over the dictionary, using the local scalar - * indicated by op4 to hold the iterator state. The local scalar - * should not refer to a named variable as the value is not wholly - * managed correctly. - * Stack: ... dict => ... value key doneBool */ - {"dictNext", 5, +3, 1, {OPERAND_LVT4}}, - /* Get the next iteration from the iterator in op4's local scalar. - * Stack: ... => ... value key doneBool */ - {"dictDone", 5, 0, 1, {OPERAND_LVT4}}, - /* Terminate the iterator in op4's local scalar. Use unsetScalar - * instead (with 0 for flags). */ - {"dictUpdateStart", 9, 0, 2, {OPERAND_LVT4, OPERAND_AUX4}}, - /* Create the variables (described in the aux data referred to by the - * second immediate argument) to mirror the state of the dictionary in - * the variable referred to by the first immediate argument. The list - * of keys (top of the stack, not poppsed) must be the same length as - * the list of variables. - * Stack: ... keyList => ... keyList */ - {"dictUpdateEnd", 9, -1, 2, {OPERAND_LVT4, OPERAND_AUX4}}, - /* Reflect the state of local variables (described in the aux data - * referred to by the second immediate argument) back to the state of - * the dictionary in the variable referred to by the first immediate - * argument. The list of keys (popped from the stack) must be the same - * length as the list of variables. - * Stack: ... keyList => ... */ - {"jumpTable", 5, -1, 1, {OPERAND_AUX4}}, - /* Jump according to the jump-table (in AuxData as indicated by the - * operand) and the argument popped from the list. Always executes the - * next instruction if no match against the table's entries was found. - * Stack: ... value => ... - * Note that the jump table contains offsets relative to the PC when - * it points to this instruction; the code is relocatable. */ - {"upvar", 5, -1, 1, {OPERAND_LVT4}}, - /* finds level and otherName in stack, links to local variable at - * index op1. Leaves the level on stack. */ - {"nsupvar", 5, -1, 1, {OPERAND_LVT4}}, - /* finds namespace and otherName in stack, links to local variable at - * index op1. Leaves the namespace on stack. */ - {"variable", 5, -1, 1, {OPERAND_LVT4}}, - /* finds namespace and otherName in stack, links to local variable at - * index op1. Leaves the namespace on stack. */ - {"syntax", 9, -1, 2, {OPERAND_INT4, OPERAND_UINT4}}, - /* Compiled bytecodes to signal syntax error. */ - {"reverse", 5, 0, 1, {OPERAND_UINT4}}, - /* Reverse the order of the arg elements at the top of stack */ - - {"regexp", 2, -1, 1, {OPERAND_INT1}}, - /* Regexp: push (regexp stknext stktop) opnd == nocase */ - - {"existScalar", 5, 1, 1, {OPERAND_LVT4}}, - /* Test if scalar variable at index op1 in call frame exists */ - {"existArray", 5, 0, 1, {OPERAND_LVT4}}, - /* Test if array element exists; array at slot op1, element is - * stktop */ - {"existArrayStk", 1, -1, 0, {OPERAND_NONE}}, - /* Test if array element exists; element is stktop, array name is - * stknext */ - {"existStk", 1, 0, 0, {OPERAND_NONE}}, - /* Test if general variable exists; unparsed variable name is stktop*/ - - {"nop", 1, 0, 0, {OPERAND_NONE}}, - /* Do nothing */ - {"returnCodeBranch", 1, -1, 0, {OPERAND_NONE}}, - /* Jump to next instruction based on the return code on top of stack - * ERROR: +1; RETURN: +3; BREAK: +5; CONTINUE: +7; - * Other non-OK: +9 - */ - - {"unsetScalar", 6, 0, 2, {OPERAND_UINT1, OPERAND_LVT4}}, - /* Make scalar variable at index op2 in call frame cease to exist; - * op1 is 1 for errors on problems, 0 otherwise */ - {"unsetArray", 6, -1, 2, {OPERAND_UINT1, OPERAND_LVT4}}, - /* Make array element cease to exist; array at slot op2, element is - * stktop; op1 is 1 for errors on problems, 0 otherwise */ - {"unsetArrayStk", 2, -2, 1, {OPERAND_UINT1}}, - /* Make array element cease to exist; element is stktop, array name is - * stknext; op1 is 1 for errors on problems, 0 otherwise */ - {"unsetStk", 2, -1, 1, {OPERAND_UINT1}}, - /* Make general variable cease to exist; unparsed variable name is - * stktop; op1 is 1 for errors on problems, 0 otherwise */ - - {"dictExpand", 1, -1, 0, {OPERAND_NONE}}, - /* Probe into a dict and extract it (or a subdict of it) into - * variables with matched names. Produces list of keys bound as - * result. Part of [dict with]. - * Stack: ... dict path => ... keyList */ - {"dictRecombineStk", 1, -3, 0, {OPERAND_NONE}}, - /* Map variable contents back into a dictionary in a variable. Part of - * [dict with]. - * Stack: ... dictVarName path keyList => ... */ - {"dictRecombineImm", 1, -2, 1, {OPERAND_LVT4}}, - /* Map variable contents back into a dictionary in the local variable - * indicated by the LVT index. Part of [dict with]. - * Stack: ... path keyList => ... */ - {"dictExists", 5, INT_MIN, 1, {OPERAND_UINT4}}, - /* The top op4 words (min 1) are a key path into the dictionary just - * below the keys on the stack, and all those values are replaced by a - * boolean indicating whether it is possible to read out a value from - * that key-path (like [dict exists]). - * Stack: ... dict key1 ... keyN => ... boolean */ - {"verifyDict", 1, -1, 0, {OPERAND_NONE}}, - /* Verifies that the word on the top of the stack is a dictionary, - * popping it if it is and throwing an error if it is not. - * Stack: ... value => ... */ - - {"strmap", 1, -2, 0, {OPERAND_NONE}}, - /* Simplified version of [string map] that only applies one change - * string, and only case-sensitively. - * Stack: ... from to string => ... changedString */ - {"strfind", 1, -1, 0, {OPERAND_NONE}}, - /* Find the first index of a needle string in a haystack string, - * producing the index (integer) or -1 if nothing found. - * Stack: ... needle haystack => ... index */ - {"strrfind", 1, -1, 0, {OPERAND_NONE}}, - /* Find the last index of a needle string in a haystack string, - * producing the index (integer) or -1 if nothing found. - * Stack: ... needle haystack => ... index */ - {"strrangeImm", 9, 0, 2, {OPERAND_IDX4, OPERAND_IDX4}}, - /* String Range: push (string range stktop op4 op4) */ - {"strrange", 1, -2, 0, {OPERAND_NONE}}, - /* String Range with non-constant arguments. - * Stack: ... string idxA idxB => ... substring */ - - {"yield", 1, 0, 0, {OPERAND_NONE}}, - /* Makes the current coroutine yield the value at the top of the - * stack, and places the response back on top of the stack when it - * resumes. - * Stack: ... valueToYield => ... resumeValue */ - {"coroName", 1, +1, 0, {OPERAND_NONE}}, - /* Push the name of the interpreter's current coroutine as an object - * on the stack. */ - {"tailcall", 2, INT_MIN, 1, {OPERAND_UINT1}}, - /* Do a tailcall with the opnd items on the stack as the thing to - * tailcall to; opnd must be greater than 0 for the semantics to work - * right. */ - - {"currentNamespace", 1, +1, 0, {OPERAND_NONE}}, - /* Push the name of the interpreter's current namespace as an object - * on the stack. */ - {"infoLevelNumber", 1, +1, 0, {OPERAND_NONE}}, - /* Push the stack depth (i.e., [info level]) of the interpreter as an - * object on the stack. */ - {"infoLevelArgs", 1, 0, 0, {OPERAND_NONE}}, - /* Push the argument words to a stack depth (i.e., [info level <n>]) - * of the interpreter as an object on the stack. - * Stack: ... depth => ... argList */ - {"resolveCmd", 1, 0, 0, {OPERAND_NONE}}, - /* Resolves the command named on the top of the stack to its fully - * qualified version, or produces the empty string if no such command - * exists. Never generates errors. - * Stack: ... cmdName => ... fullCmdName */ - {"tclooSelf", 1, +1, 0, {OPERAND_NONE}}, - /* Push the identity of the current TclOO object (i.e., the name of - * its current public access command) on the stack. */ - {"tclooClass", 1, 0, 0, {OPERAND_NONE}}, - /* Push the class of the TclOO object named at the top of the stack - * onto the stack. - * Stack: ... object => ... class */ - {"tclooNamespace", 1, 0, 0, {OPERAND_NONE}}, - /* Push the namespace of the TclOO object named at the top of the - * stack onto the stack. - * Stack: ... object => ... namespace */ - {"tclooIsObject", 1, 0, 0, {OPERAND_NONE}}, - /* Push whether the value named at the top of the stack is a TclOO - * object (i.e., a boolean). Can corrupt the interpreter result - * despite not throwing, so not safe for use in a post-exception - * context. - * Stack: ... value => ... boolean */ - - {"arrayExistsStk", 1, 0, 0, {OPERAND_NONE}}, - /* Looks up the element on the top of the stack and tests whether it - * is an array. Pushes a boolean describing whether this is the - * case. Also runs the whole-array trace on the named variable, so can - * throw anything. - * Stack: ... varName => ... boolean */ - {"arrayExistsImm", 5, +1, 1, {OPERAND_UINT4}}, - /* Looks up the variable indexed by opnd and tests whether it is an - * array. Pushes a boolean describing whether this is the case. Also - * runs the whole-array trace on the named variable, so can throw - * anything. - * Stack: ... => ... boolean */ - {"arrayMakeStk", 1, -1, 0, {OPERAND_NONE}}, - /* Forces the element on the top of the stack to be the name of an - * array. - * Stack: ... varName => ... */ - {"arrayMakeImm", 5, 0, 1, {OPERAND_UINT4}}, - /* Forces the variable indexed by opnd to be an array. Does not touch - * the stack. */ - - {"invokeReplace", 6, INT_MIN, 2, {OPERAND_UINT4,OPERAND_UINT1}}, - /* Invoke command named objv[0], replacing the first two words with - * the word at the top of the stack; - * <objc,objv> = <op4,top op4 after popping 1> */ - + {"done", 1, -1, 0, {OPERAND_NONE}},//0 + {"push4", 5, +1, 1, {OPERAND_UINT4}},//1 + {"pop", 1, -1, 0, {OPERAND_NONE}},//2 + {"concat1", 2, INT_MIN, 1, {OPERAND_UINT1}},//3 + {"invokeStk4", 5, INT_MIN, 1, {OPERAND_UINT4}},//4 + {"loadScalar4", 5, 1, 1, {OPERAND_LVT4}},//5 + {"loadScalarStk", 1, 0, 0, {OPERAND_NONE}},//6 + {"loadArray4", 5, 0, 1, {OPERAND_LVT4}},//7 + {"loadArrayStk", 1, -1, 0, {OPERAND_NONE}},//8 + {"storeScalar4", 5, 0, 1, {OPERAND_LVT4}},//9 + {"jump4", 5, 0, 1, {OPERAND_INT4}},//10 + {"jumpTrue4", 5, -1, 1, {OPERAND_INT4}},//11 + {"jumpFalse4", 5, -1, 1, {OPERAND_INT4}},//12 + {"bitor", 1, -1, 0, {OPERAND_NONE}},//13 + {"bitxor", 1, -1, 0, {OPERAND_NONE}},//14 + {"bitand", 1, -1, 0, {OPERAND_NONE}},//15 + {"eq", 1, -1, 0, {OPERAND_NONE}},//16 + {"neq", 1, -1, 0, {OPERAND_NONE}},//17 + {"lt", 1, -1, 0, {OPERAND_NONE}},//18 + {"gt", 1, -1, 0, {OPERAND_NONE}},//19 + {"le", 1, -1, 0, {OPERAND_NONE}},//20 + {"ge", 1, -1, 0, {OPERAND_NONE}},//21 + {"lshift", 1, -1, 0, {OPERAND_NONE}},//22 + {"rshift", 1, -1, 0, {OPERAND_NONE}},//23 + {"add", 1, -1, 0, {OPERAND_NONE}},//24 + {"sub", 1, -1, 0, {OPERAND_NONE}},//25 + {"mult", 1, -1, 0, {OPERAND_NONE}},//26 + {"div", 1, -1, 0, {OPERAND_NONE}},//27 + {"mod", 1, -1, 0, {OPERAND_NONE}},//28 + {"uplus", 1, 0, 0, {OPERAND_NONE}},//29 + {"uminus", 1, 0, 0, {OPERAND_NONE}},//30 + {"bitnot", 1, 0, 0, {OPERAND_NONE}},//31 + {"not", 1, 0, 0, {OPERAND_NONE}},//32 + {"tryCvtToNumeric", 1, 0, 0, {OPERAND_NONE}},//33 + {"streq", 1, -1, 0, {OPERAND_NONE}},//34 + {"strneq", 1, -1, 0, {OPERAND_NONE}},//35 + {"expon", 1, -1, 0, {OPERAND_NONE}},//36 + {"expandStart", 1, 0, 0, {OPERAND_NONE}},//37 + {"expandStkTop", 5, 0, 1, {OPERAND_UINT4}},//38 + {"invokeExpanded", 1, 0, 0, {OPERAND_NONE}},//39 + {"listIn", 1, -1, 0, {OPERAND_NONE}},//40 + {"listNotIn", 1, -1, 0, {OPERAND_NONE}},//41 + {"syntax", 9, -1, 2, {OPERAND_INT4, OPERAND_UINT4}},//42 + {"reverse", 5, 0, 1, {OPERAND_UINT4}},//43 + {"unsetScalar", 6, 0, 2, {OPERAND_UINT1, OPERAND_LVT4}},//44 + {"currentNamespace", 1, +1, 0, {OPERAND_NONE}},//45 + {"tclooSelf", 1, +1, 0, {OPERAND_NONE}},//46 {NULL, 0, 0, 0, {OPERAND_NONE}} }; @@ -541,8 +102,6 @@ InstructionDesc const tclInstructionTable[] = { * Prototypes for procedures defined later in this file: */ -static ByteCode * CompileSubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - int flags); static void DupByteCodeInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static unsigned char * EncodeCmdLocMap(CompileEnv *envPtr, @@ -552,17 +111,9 @@ static void EnterCmdExtentData(CompileEnv *envPtr, static void EnterCmdStartData(CompileEnv *envPtr, int cmdNumber, int srcOffset, int codeOffset); static void FreeByteCodeInternalRep(Tcl_Obj *objPtr); -static void FreeSubstCodeInternalRep(Tcl_Obj *objPtr); static int GetCmdLocEncodingSize(CompileEnv *envPtr); -#ifdef TCL_COMPILE_STATS -static void RecordByteCodeStats(ByteCode *codePtr); -#endif /* TCL_COMPILE_STATS */ static int SetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); -static int FormatInstruction(ByteCode *codePtr, - const unsigned char *pc, Tcl_Obj *bufferObj); -static void PrintSourceToObj(Tcl_Obj *appendObj, - const char *stringPtr, int maxChars); /* * The structure below defines the bytecode Tcl object type by means of @@ -577,19 +128,6 @@ const Tcl_ObjType tclByteCodeType = { SetByteCodeFromAny /* setFromAnyProc */ }; -/* - * The structure below defines a bytecode Tcl object type to hold the - * compiled bytecode for the [subst]itution of Tcl values. - */ - -static const Tcl_ObjType substCodeType = { - "substcode", /* name */ - FreeSubstCodeInternalRep, /* freeIntRepProc */ - DupByteCodeInternalRep, /* dupIntRepProc - shared with bytecode */ - NULL, /* updateStringProc */ - NULL, /* setFromAnyProc */ -}; - /* *---------------------------------------------------------------------- @@ -633,16 +171,6 @@ TclSetByteCodeFromAny( int length, result = TCL_OK; const char *stringPtr; -#ifdef TCL_COMPILE_DEBUG - if (!traceInitialized) { - if (Tcl_LinkVar(interp, "tcl_traceCompile", - (char *) &tclTraceCompile, TCL_LINK_INT) != TCL_OK) { - Tcl_Panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable"); - } - traceInitialized = 1; - } -#endif - stringPtr = TclGetStringFromObj(objPtr, &length); TclInitCompileEnv(interp, &compEnv, stringPtr, length); @@ -680,18 +208,7 @@ TclSetByteCodeFromAny( * objects and aux data items is given to the ByteCode object. */ -#ifdef TCL_COMPILE_DEBUG - TclVerifyLocalLiteralTable(&compEnv); -#endif /*TCL_COMPILE_DEBUG*/ - TclInitByteCodeObj(objPtr, &compEnv); -#ifdef TCL_COMPILE_DEBUG - if (tclTraceCompile >= 2) { - TclPrintByteCodeObj(interp, objPtr); - fflush(stdout); - } -#endif /* TCL_COMPILE_DEBUG */ - if (result != TCL_OK) { /* * Handle any error from the hookProc @@ -702,9 +219,6 @@ TclSetByteCodeFromAny( TclReleaseLiteral(interp, entryPtr->objPtr); entryPtr++; } -#ifdef TCL_COMPILE_DEBUG - TclVerifyGlobalLiteralTable((Interp *)interp); -#endif /*TCL_COMPILE_DEBUG*/ auxDataPtr = compEnv.auxDataArrayPtr; for (i = 0; i < compEnv.auxDataArrayNext; i++) { @@ -846,44 +360,6 @@ TclCleanupByteCode( register Tcl_Obj **objArrayPtr, *objPtr; register const AuxData *auxDataPtr; int i; -#ifdef TCL_COMPILE_STATS - - if (interp != NULL) { - ByteCodeStats *statsPtr; - Tcl_Time destroyTime; - int lifetimeSec, lifetimeMicroSec, log2; - - statsPtr = &((Interp *)interp)->stats; - - statsPtr->numByteCodesFreed++; - statsPtr->currentSrcBytes -= (double) codePtr->numSrcBytes; - statsPtr->currentByteCodeBytes -= (double) codePtr->structureSize; - - statsPtr->currentInstBytes -= (double) codePtr->numCodeBytes; - statsPtr->currentLitBytes -= (double) - codePtr->numLitObjects * sizeof(Tcl_Obj *); - statsPtr->currentExceptBytes -= (double) - codePtr->numExceptRanges * sizeof(ExceptionRange); - statsPtr->currentAuxBytes -= (double) - codePtr->numAuxDataItems * sizeof(AuxData); - statsPtr->currentCmdMapBytes -= (double) codePtr->numCmdLocBytes; - - Tcl_GetTime(&destroyTime); - lifetimeSec = destroyTime.sec - codePtr->createTime.sec; - if (lifetimeSec > 2000) { /* avoid overflow */ - lifetimeSec = 2000; - } - lifetimeMicroSec = 1000000 * lifetimeSec + - (destroyTime.usec - codePtr->createTime.usec); - - log2 = TclLog2(lifetimeMicroSec); - if (log2 > 31) { - log2 = 31; - } - statsPtr->lifetimeCount[log2]++; - } -#endif /* TCL_COMPILE_STATS */ - /* * A single heap object holds the ByteCode structure and its code, object, * command location, and auxiliary data arrays. This means we only need to @@ -951,174 +427,6 @@ TclCleanupByteCode( /* *---------------------------------------------------------------------- * - * Tcl_SubstObj -- - * - * This function performs the substitutions specified on the given string - * as described in the user documentation for the "subst" Tcl command. - * - * Results: - * A Tcl_Obj* containing the substituted string, or NULL to indicate that - * an error occurred. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -Tcl_SubstObj( - Tcl_Interp *interp, /* Interpreter in which substitution occurs */ - Tcl_Obj *objPtr, /* The value to be substituted. */ - int flags) /* What substitutions to do. */ -{ - TclNRSetRoot(interp); - if (TclNRRunCallbacks(interp, Tcl_NRSubstObj(interp, objPtr, flags)) - != TCL_OK) { - return NULL; - } - return Tcl_GetObjResult(interp); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_NRSubstObj -- - * - * Request substitution of a Tcl value by the NR stack. - * - * Results: - * Returns TCL_OK. - * - * Side effects: - * Compiles objPtr into bytecode that performs the substitutions as - * governed by flags and places callbacks on the NR stack to execute - * the bytecode and store the result in the interp. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_NRSubstObj( - Tcl_Interp *interp, - Tcl_Obj *objPtr, - int flags) -{ - ByteCode *codePtr = CompileSubstObj(interp, objPtr, flags); - - /* TODO: Confirm we do not need this. */ - /* Tcl_ResetResult(interp); */ - return TclNRExecuteByteCode(interp, codePtr); -} - -/* - *---------------------------------------------------------------------- - * - * CompileSubstObj -- - * - * Compile a Tcl value into ByteCode implementing its substitution, as - * governed by flags. - * - * Results: - * A (ByteCode *) is returned pointing to the resulting ByteCode. - * The caller must manage its refCount and arrange for a call to - * TclCleanupByteCode() when the last reference disappears. - * - * Side effects: - * The Tcl_ObjType of objPtr is changed to the "substcode" type, and the - * ByteCode and governing flags value are kept in the internal rep for - * faster operations the next time CompileSubstObj is called on the same - * value. - * - *---------------------------------------------------------------------- - */ - -static ByteCode * -CompileSubstObj( - Tcl_Interp *interp, - Tcl_Obj *objPtr, - int flags) -{ - Interp *iPtr = (Interp *) interp; - ByteCode *codePtr = NULL; - - if (objPtr->typePtr == &substCodeType) { - Namespace *nsPtr = iPtr->varFramePtr->nsPtr; - - codePtr = objPtr->internalRep.ptrAndLongRep.ptr; - if ((unsigned long)flags != objPtr->internalRep.ptrAndLongRep.value - || ((Interp *) *codePtr->interpHandle != iPtr) - || (codePtr->compileEpoch != iPtr->compileEpoch) - || (codePtr->nsPtr != nsPtr) - || (codePtr->nsEpoch != nsPtr->resolverEpoch) - || (codePtr->localCachePtr != - iPtr->varFramePtr->localCachePtr)) { - FreeSubstCodeInternalRep(objPtr); - } - } - if (objPtr->typePtr != &substCodeType) { - CompileEnv compEnv; - int numBytes; - const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes); - - TclInitCompileEnv(interp, &compEnv, bytes, numBytes); - - TclSubstCompile(interp, bytes, numBytes, flags, &compEnv); - - TclEmitOpcode(INST_DONE, &compEnv); - TclInitByteCodeObj(objPtr, &compEnv); - objPtr->typePtr = &substCodeType; - TclFreeCompileEnv(&compEnv); - - codePtr = objPtr->internalRep.otherValuePtr; - objPtr->internalRep.ptrAndLongRep.ptr = codePtr; - objPtr->internalRep.ptrAndLongRep.value = flags; - if (iPtr->varFramePtr->localCachePtr) { - codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; - codePtr->localCachePtr->refCount++; - } - /* TODO: Debug printing? */ - } - return codePtr; -} - -/* - *---------------------------------------------------------------------- - * - * FreeSubstCodeInternalRep -- - * - * Part of the substcode Tcl object type implementation. Frees the - * storage associated with a substcode object's internal representation - * unless its code is actively being executed. - * - * Results: - * None. - * - * Side effects: - * The substcode 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 -FreeSubstCodeInternalRep( - register Tcl_Obj *objPtr) /* Object whose internal rep to free. */ -{ - register ByteCode *codePtr = objPtr->internalRep.ptrAndLongRep.ptr; - - objPtr->typePtr = NULL; - objPtr->internalRep.otherValuePtr = NULL; - codePtr->refCount--; - if (codePtr->refCount <= 0) { - TclCleanupByteCode(codePtr); - } -} - -/* - *---------------------------------------------------------------------- - * * TclInitCompileEnv -- * * Initializes a CompileEnv compilation environment structure for the @@ -1339,7 +647,6 @@ TclCompileScript( * first null character. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - Interp *iPtr = (Interp *) interp; int lastTopLevelCmdIndex = -1; /* Index of most recent toplevel command in * the command location table. Initialized to @@ -1353,7 +660,7 @@ TclCompileScript( Tcl_Token *tokenPtr; int bytesLeft, isFirstCmd, wordIdx, currCmdIndex, commandLength, objIndex; Tcl_DString ds; - Tcl_Parse *parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse)); + Tcl_Parse *parsePtr = ckalloc(sizeof(Tcl_Parse)); Tcl_DStringInit(&ds); @@ -1424,19 +731,6 @@ TclCompileScript( commandLength -= 1; } -#ifdef TCL_COMPILE_DEBUG - /* - * If tracing, print a line for each top level command compiled. - */ - - if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) { - fprintf(stdout, " Compiling: "); - TclPrintSource(stdout, parsePtr->commandStart, - TclMin(commandLength, 55)); - fprintf(stdout, "\n"); - } -#endif - /* * Check whether expansion has been requested for any of the * words. @@ -1512,120 +806,6 @@ TclCompileScript( Tcl_DStringValue(&ds), (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0); - if ((cmdPtr != NULL) - && (cmdPtr->compileProc != NULL) - && !(cmdPtr->nsPtr->flags&NS_SUPPRESS_COMPILATION) - && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES) - && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) { - int code, savedNumCmds = envPtr->numCommands; - unsigned savedCodeNext = - envPtr->codeNext - envPtr->codeStart; - int update = 0; -#ifdef TCL_COMPILE_DEBUG - int startStackDepth = envPtr->currStackDepth; -#endif - - /* - * Mark the start of the command; the proper bytecode - * length will be updated later. There is no need to - * do this for the first bytecode in the compile env, - * as the check is done before calling - * TclNRExecuteByteCode(). Do emit an INST_START_CMD in - * special cases where the first bytecode is in a - * loop, to insure that the corresponding command is - * counted properly. Compilers for commands able to - * produce such a beast (currently 'while 1' only) set - * envPtr->atCmdStart to 0 in order to signal this - * case. [Bug 1752146] - * - * Note that the environment is initialised with - * atCmdStart=1 to avoid emitting ISC for the first - * command. - */ - - if (envPtr->atCmdStart) { - if (savedCodeNext != 0) { - /* - * Increase the number of commands being - * started at the current point. Note that - * this depends on the exact layout of the - * INST_START_CMD's operands, so be careful! - */ - - unsigned char *fixPtr = envPtr->codeNext - 4; - - TclStoreInt4AtPtr(TclGetUInt4AtPtr(fixPtr)+1, - fixPtr); - } - } else { - TclEmitInstInt4(INST_START_CMD, 0, envPtr); - TclEmitInt4(1, envPtr); - update = 1; - } - - code = cmdPtr->compileProc(interp, parsePtr, cmdPtr, - envPtr); - - if (code == TCL_OK) { - /* - * Confirm that the command compiler generated a - * single value on the stack as its result. This - * is only done in debugging mode, as it *should* - * be correct and normal users have no reasonable - * way to fix it anyway. - */ - -#ifdef TCL_COMPILE_DEBUG - int diff = envPtr->currStackDepth-startStackDepth; - - if (diff != 1 && (diff != 0 || - *(envPtr->codeNext-1) != INST_DONE)) { - Tcl_Panic("bad stack adjustment when compiling" - " %.*s (was %d instead of 1)", - parsePtr->tokenPtr->size, - parsePtr->tokenPtr->start, diff); - } -#endif - if (update) { - /* - * Fix the bytecode length. - */ - - unsigned char *fixPtr = envPtr->codeStart - + savedCodeNext + 1; - unsigned fixLen = envPtr->codeNext - - envPtr->codeStart - savedCodeNext; - - TclStoreInt4AtPtr(fixLen, fixPtr); - } - goto finishCommand; - } - - if (envPtr->atCmdStart && savedCodeNext != 0) { - /* - * Decrease the number of commands being started - * at the current point. Note that this depends on - * the exact layout of the INST_START_CMD's - * operands, so be careful! - */ - - unsigned char *fixPtr = envPtr->codeNext - 4; - - TclStoreInt4AtPtr(TclGetUInt4AtPtr(fixPtr)-1, - fixPtr); - } - - /* - * Restore numCommands and codeNext to their correct - * values, removing any commands compiled before the - * failure to produce bytecode got reported. [Bugs - * 705406 and 735055] - */ - - envPtr->numCommands = savedNumCmds; - envPtr->codeNext = envPtr->codeStart + savedCodeNext; - } - /* * No compile procedure so push the word. If the command * was found, push a CmdName object to reduce runtime @@ -1681,11 +861,7 @@ TclCompileScript( TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); TclAdjustStackDepth((1-wordIdx), envPtr); } else if (wordIdx > 0) { - if (wordIdx <= 255) { - TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); - } else { - TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr); - } + TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr); } /* @@ -1693,7 +869,6 @@ TclCompileScript( * offsets of the source and code for the command. */ - finishCommand: EnterCmdExtentData(envPtr, currCmdIndex, commandLength, (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); isFirstCmd = 0; @@ -1720,7 +895,7 @@ TclCompileScript( } envPtr->numSrcBytes = p - script; - TclStackFree(interp, parsePtr); + ckfree(parsePtr); Tcl_DStringFree(&ds); } @@ -1795,8 +970,6 @@ TclCompileVarSubst( if (tokenPtr->numComponents == 1) { if (localVar < 0) { TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr); - } else if (localVar <= 255) { - TclEmitInstInt1(INST_LOAD_SCALAR1, localVar, envPtr); } else { TclEmitInstInt4(INST_LOAD_SCALAR4, localVar, envPtr); } @@ -1804,8 +977,6 @@ TclCompileVarSubst( TclCompileTokens(interp, tokenPtr+2, tokenPtr->numComponents-1, envPtr); if (localVar < 0) { TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr); - } else if (localVar <= 255) { - TclEmitInstInt1(INST_LOAD_ARRAY1, localVar, envPtr); } else { TclEmitInstInt4(INST_LOAD_ARRAY4, localVar, envPtr); } @@ -1925,171 +1096,6 @@ TclCompileTokens( /* *---------------------------------------------------------------------- * - * TclCompileCmdWord -- - * - * Given an array of parse tokens for a word containing one or more Tcl - * commands, emit inline instructions to execute them. This procedure - * differs from TclCompileTokens in that a simple word such as a loop - * body enclosed in braces is not just pushed as a string, but is itself - * parsed into tokens and compiled. - * - * Results: - * The return value is a standard Tcl result. If an error occurs, an - * error message is left in the interpreter's result. - * - * Side effects: - * Instructions are added to envPtr to execute the tokens at runtime. - * - *---------------------------------------------------------------------- - */ - -void -TclCompileCmdWord( - Tcl_Interp *interp, /* Used for error and status reporting. */ - Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens for - * a command word to compile inline. */ - int count, /* Number of tokens to consider at tokenPtr. - * Must be at least 1. */ - CompileEnv *envPtr) /* Holds the resulting instructions. */ -{ - if ((count == 1) && (tokenPtr->type == TCL_TOKEN_TEXT)) { - /* - * Handle the common case: if there is a single text token, compile it - * into an inline sequence of instructions. - */ - - TclCompileScript(interp, tokenPtr->start, tokenPtr->size, envPtr); - } else { - /* - * Multiple tokens or the single token involves substitutions. Emit - * instructions to invoke the eval command procedure at runtime on the - * result of evaluating the tokens. - */ - - TclCompileTokens(interp, tokenPtr, count, envPtr); - TclEmitOpcode(INST_EVAL_STK, envPtr); - } -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileExprWords -- - * - * Given an array of parse tokens representing one or more words that - * contain a Tcl expression, emit inline instructions to execute the - * expression. This procedure differs from TclCompileExpr in that it - * supports Tcl's two-level substitution semantics for expressions that - * appear as command words. - * - * Results: - * The return value is a standard Tcl result. If an error occurs, an - * error message is left in the interpreter's result. - * - * Side effects: - * Instructions are added to envPtr to execute the expression. - * - *---------------------------------------------------------------------- - */ - -void -TclCompileExprWords( - Tcl_Interp *interp, /* Used for error and status reporting. */ - Tcl_Token *tokenPtr, /* Points to first in an array of word tokens - * tokens for the expression to compile - * inline. */ - int numWords, /* Number of word tokens starting at tokenPtr. - * Must be at least 1. Each word token - * contains one or more subtokens. */ - CompileEnv *envPtr) /* Holds the resulting instructions. */ -{ - Tcl_Token *wordPtr; - int i, concatItems; - - /* - * If the expression is a single word that doesn't require substitutions, - * just compile its string into inline instructions. - */ - - if ((numWords == 1) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) { - TclCompileExpr(interp, tokenPtr[1].start,tokenPtr[1].size, envPtr, 1); - return; - } - - /* - * Emit code to call the expr command proc at runtime. Concatenate the - * (already substituted once) expr tokens with a space between each. - */ - - wordPtr = tokenPtr; - for (i = 0; i < numWords; i++) { - TclCompileTokens(interp, wordPtr+1, wordPtr->numComponents, envPtr); - if (i < (numWords - 1)) { - TclEmitPush(TclRegisterNewLiteral(envPtr, " ", 1), envPtr); - } - wordPtr += wordPtr->numComponents + 1; - } - concatItems = 2*numWords - 1; - while (concatItems > 255) { - TclEmitInstInt1(INST_CONCAT1, 255, envPtr); - concatItems -= 254; - } - if (concatItems > 1) { - TclEmitInstInt1(INST_CONCAT1, concatItems, envPtr); - } - TclEmitOpcode(INST_EXPR_STK, envPtr); -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileNoOp -- - * - * Function called to compile no-op's - * - * Results: - * The return value is TCL_OK, indicating successful compilation. - * - * Side effects: - * Instructions are added to envPtr to execute a no-op at runtime. No - * result is pushed onto the stack: the compiler has to take care of this - * itself if the last compiled command is a NoOp. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileNoOp( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr; - int i; - int savedStackDepth = envPtr->currStackDepth; - - tokenPtr = parsePtr->tokenPtr; - for (i = 1; i < parsePtr->numWords; i++) { - tokenPtr = tokenPtr + tokenPtr->numComponents + 1; - envPtr->currStackDepth = savedStackDepth; - - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, - envPtr); - TclEmitOpcode(INST_POP, envPtr); - } - } - envPtr->currStackDepth = savedStackDepth; - TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * * TclInitByteCodeObj -- * * Create a ByteCode structure and initialize it from a CompileEnv @@ -2124,9 +1130,6 @@ TclInitByteCodeObj( size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes; size_t auxDataArrayBytes, structureSize; register unsigned char *p; -#ifdef TCL_COMPILE_DEBUG - unsigned char *nextPtr; -#endif int numLitObjects = envPtr->literalArrayNext; Namespace *namespacePtr; int i; @@ -2160,7 +1163,6 @@ TclInitByteCodeObj( p = ckalloc(structureSize); codePtr = (ByteCode *) p; codePtr->interpHandle = TclHandlePreserve(iPtr->handle); - codePtr->compileEpoch = iPtr->compileEpoch; codePtr->nsPtr = namespacePtr; codePtr->nsEpoch = namespacePtr->resolverEpoch; codePtr->refCount = 1; @@ -2229,28 +1231,13 @@ TclInitByteCodeObj( } p += auxDataArrayBytes; -#ifndef TCL_COMPILE_DEBUG EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p); -#else - nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p); - if (((size_t)(nextPtr - p)) != cmdLocBytes) { - Tcl_Panic("TclInitByteCodeObj: encoded cmd location bytes %lu != expected size %lu", (unsigned long)(nextPtr - p), (unsigned long)cmdLocBytes); - } -#endif /* * Record various compilation-related statistics about the new ByteCode * structure. Don't include overhead for statistics-related fields. */ -#ifdef TCL_COMPILE_STATS - codePtr->structureSize = structureSize - - (sizeof(size_t) + sizeof(Tcl_Time)); - Tcl_GetTime(&codePtr->createTime); - - RecordByteCodeStats(codePtr); -#endif /* TCL_COMPILE_STATS */ - /* * Free the old internal rep then convert the object to a bytecode object * by making its internal rep point to the just compiled ByteCode. @@ -2867,13 +1854,13 @@ TclEmitForwardJump( switch (jumpType) { case TCL_UNCONDITIONAL_JUMP: - TclEmitInstInt1(INST_JUMP1, 0, envPtr); + TclEmitInstInt4(INST_JUMP4, 0, envPtr); break; case TCL_TRUE_JUMP: - TclEmitInstInt1(INST_JUMP_TRUE1, 0, envPtr); + TclEmitInstInt4(INST_JUMP_TRUE4, 0, envPtr); break; default: - TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); + TclEmitInstInt4(INST_JUMP_FALSE4, 0, envPtr); break; } } @@ -2914,90 +1901,21 @@ TclFixupForwardJump( 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 numBytes; + unsigned char *jumpPc; - if (jumpDist <= distThreshold) { - jumpPc = envPtr->codeStart + jumpFixupPtr->codeOffset; - switch (jumpFixupPtr->jumpType) { + jumpPc = envPtr->codeStart + jumpFixupPtr->codeOffset; + switch (jumpFixupPtr->jumpType) { case TCL_UNCONDITIONAL_JUMP: - TclUpdateInstInt1AtPc(INST_JUMP1, jumpDist, jumpPc); + TclUpdateInstInt4AtPc(INST_JUMP4, jumpDist, jumpPc); break; case TCL_TRUE_JUMP: - TclUpdateInstInt1AtPc(INST_JUMP_TRUE1, jumpDist, jumpPc); + TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDist, jumpPc); break; default: - TclUpdateInstInt1AtPc(INST_JUMP_FALSE1, jumpDist, jumpPc); - break; - } - return 0; - } - - /* - * We must grow the jump then move subsequent instructions down. Note that - * if we expand the space for generated instructions, code addresses might - * change; be careful about updating any of these addresses held in - * variables. - */ - - if ((envPtr->codeNext + 3) > envPtr->codeEnd) { - TclExpandCodeArray(envPtr); - } - jumpPc = envPtr->codeStart + jumpFixupPtr->codeOffset; - numBytes = envPtr->codeNext-jumpPc-2; - p = jumpPc+2; - memmove(p+3, p, numBytes); - - 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->exceptIndex; - lastRange = envPtr->exceptArrayNext - 1; - for (k = firstRange; k <= lastRange; k++) { - ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[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; + TclUpdateInstInt4AtPc(INST_JUMP_FALSE4, jumpDist, jumpPc); break; - default: - Tcl_Panic("TclFixupForwardJump: bad ExceptionRange type %d", - rangePtr->type); - } } - return 1; /* the jump was grown */ + return 0; } /* @@ -3149,9 +2067,6 @@ TclInitAuxDataTypeTable(void) * There are only two AuxData type at this time, so register them here. */ - TclRegisterAuxDataType(&tclForeachInfoType); - TclRegisterAuxDataType(&tclJumptableInfoType); - TclRegisterAuxDataType(&tclDictUpdateInfoType); } /* @@ -3382,657 +2297,6 @@ EncodeCmdLocMap( return p; } -#ifdef TCL_COMPILE_DEBUG -/* - *---------------------------------------------------------------------- - * - * TclPrintByteCodeObj -- - * - * This procedure prints ("disassembles") the instructions of a bytecode - * object to stdout. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void -TclPrintByteCodeObj( - Tcl_Interp *interp, /* Used only for Tcl_GetStringFromObj. */ - Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ -{ - Tcl_Obj *bufPtr = TclDisassembleByteCodeObj(objPtr); - - fprintf(stdout, "\n%s", TclGetString(bufPtr)); - Tcl_DecrRefCount(bufPtr); -} - -/* - *---------------------------------------------------------------------- - * - * 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( - ByteCode *codePtr, /* Bytecode containing the instruction. */ - const unsigned char *pc) /* Points to first byte of instruction. */ -{ - Tcl_Obj *bufferObj; - int numBytes; - - TclNewObj(bufferObj); - numBytes = FormatInstruction(codePtr, pc, bufferObj); - fprintf(stdout, "%s", TclGetString(bufferObj)); - Tcl_DecrRefCount(bufferObj); - return numBytes; -} - -/* - *---------------------------------------------------------------------- - * - * TclPrintObject -- - * - * This procedure prints up to a specified number of characters from the - * argument Tcl object's string representation to a specified file. - * - * Results: - * None. - * - * Side effects: - * Outputs characters to the specified file. - * - *---------------------------------------------------------------------- - */ - -void -TclPrintObject( - FILE *outFile, /* The file to print the source to. */ - Tcl_Obj *objPtr, /* Points to the Tcl object whose string - * representation should be printed. */ - int maxChars) /* Maximum number of chars to print. */ -{ - char *bytes; - int length; - - bytes = Tcl_GetStringFromObj(objPtr, &length); - TclPrintSource(outFile, bytes, TclMin(length, maxChars)); -} - -/* - *---------------------------------------------------------------------- - * - * TclPrintSource -- - * - * This procedure prints up to a specified number of characters from the - * argument string to a specified file. It tries to produce legible - * output by adding backslashes as necessary. - * - * Results: - * None. - * - * Side effects: - * Outputs characters to the specified file. - * - *---------------------------------------------------------------------- - */ - -void -TclPrintSource( - FILE *outFile, /* The file to print the source to. */ - const char *stringPtr, /* The string to print. */ - int maxChars) /* Maximum number of chars to print. */ -{ - Tcl_Obj *bufferObj; - - TclNewObj(bufferObj); - PrintSourceToObj(bufferObj, stringPtr, maxChars); - fprintf(outFile, "%s", TclGetString(bufferObj)); - Tcl_DecrRefCount(bufferObj); -} -#endif /* TCL_COMPILE_DEBUG */ - -/* - *---------------------------------------------------------------------- - * - * TclDisassembleByteCodeObj -- - * - * Given an object which is of bytecode type, return a disassembled - * version of the bytecode (in a new refcount 0 object). No guarantees - * are made about the details of the contents of the result. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclDisassembleByteCodeObj( - Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ -{ - ByteCode *codePtr = objPtr->internalRep.otherValuePtr; - unsigned char *codeStart, *codeLimit, *pc; - unsigned char *codeDeltaNext, *codeLengthNext; - unsigned char *srcDeltaNext, *srcLengthNext; - int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i; - Interp *iPtr = (Interp *) *codePtr->interpHandle; - Tcl_Obj *bufferObj; - char ptrBuf1[20], ptrBuf2[20]; - - TclNewObj(bufferObj); - if (codePtr->refCount <= 0) { - return bufferObj; /* Already freed. */ - } - - codeStart = codePtr->codeStart; - codeLimit = codeStart + codePtr->numCodeBytes; - numCmds = codePtr->numCommands; - - /* - * Print header lines describing the ByteCode. - */ - - sprintf(ptrBuf1, "%p", codePtr); - sprintf(ptrBuf2, "%p", iPtr); - Tcl_AppendPrintfToObj(bufferObj, - "ByteCode 0x%s, refCt %u, epoch %u, interp 0x%s (epoch %u)\n", - ptrBuf1, codePtr->refCount, codePtr->compileEpoch, ptrBuf2, - iPtr->compileEpoch); - Tcl_AppendToObj(bufferObj, " Source ", -1); - PrintSourceToObj(bufferObj, codePtr->source, - TclMin(codePtr->numSrcBytes, 55)); - Tcl_AppendPrintfToObj(bufferObj, - "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", - numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes, - codePtr->numLitObjects, codePtr->numAuxDataItems, - codePtr->maxStackDepth, -#ifdef TCL_COMPILE_STATS - codePtr->numSrcBytes? - codePtr->structureSize/(float)codePtr->numSrcBytes : -#endif - 0.0); - -#ifdef TCL_COMPILE_STATS - Tcl_AppendPrintfToObj(bufferObj, - " Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n", - (unsigned long) codePtr->structureSize, - (unsigned long) (sizeof(ByteCode) - sizeof(size_t) - sizeof(Tcl_Time)), - codePtr->numCodeBytes, - (unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)), - (unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)), - (unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)), - codePtr->numCmdLocBytes); -#endif /* TCL_COMPILE_STATS */ - - /* - * If the ByteCode is the compiled body of a Tcl procedure, print - * information about that procedure. Note that we don't know the - * procedure's name since ByteCode's can be shared among procedures. - */ - - if (codePtr->procPtr != NULL) { - Proc *procPtr = codePtr->procPtr; - int numCompiledLocals = procPtr->numCompiledLocals; - - sprintf(ptrBuf1, "%p", procPtr); - Tcl_AppendPrintfToObj(bufferObj, - " Proc 0x%s, refCt %d, args %d, compiled locals %d\n", - ptrBuf1, procPtr->refCount, procPtr->numArgs, - numCompiledLocals); - if (numCompiledLocals > 0) { - CompiledLocal *localPtr = procPtr->firstLocalPtr; - - for (i = 0; i < numCompiledLocals; i++) { - Tcl_AppendPrintfToObj(bufferObj, - " slot %d%s%s%s%s%s%s", i, - (localPtr->flags & (VAR_ARRAY|VAR_LINK)) ? "" : ", 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)) { - Tcl_AppendToObj(bufferObj, "\n", -1); - } else { - Tcl_AppendPrintfToObj(bufferObj, ", \"%s\"\n", - localPtr->name); - } - localPtr = localPtr->nextPtr; - } - } - } - - /* - * Print the ExceptionRange array. - */ - - if (codePtr->numExceptRanges > 0) { - Tcl_AppendPrintfToObj(bufferObj, " Exception ranges %d, depth %d:\n", - codePtr->numExceptRanges, codePtr->maxExceptDepth); - for (i = 0; i < codePtr->numExceptRanges; i++) { - ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; - - Tcl_AppendPrintfToObj(bufferObj, - " %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: - Tcl_AppendPrintfToObj(bufferObj, "continue %d, break %d\n", - rangePtr->continueOffset, rangePtr->breakOffset); - break; - case CATCH_EXCEPTION_RANGE: - Tcl_AppendPrintfToObj(bufferObj, "catch %d\n", - rangePtr->catchOffset); - break; - default: - Tcl_Panic("TclDisassembleByteCodeObj: bad ExceptionRange type %d", - 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) { - Tcl_AppendToObj(bufferObj, " ", -1); - pc += FormatInstruction(codePtr, pc, bufferObj); - } - return bufferObj; - } - - /* - * Print table showing the code offset, source offset, and source length - * for each command. These are encoded as a sequence of bytes. - */ - - Tcl_AppendPrintfToObj(bufferObj, " 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) *codeDeltaNext == (unsigned) 0xFF) { - codeDeltaNext++; - delta = TclGetInt4AtPtr(codeDeltaNext); - codeDeltaNext += 4; - } else { - delta = TclGetInt1AtPtr(codeDeltaNext); - codeDeltaNext++; - } - codeOffset += delta; - - if ((unsigned) *codeLengthNext == (unsigned) 0xFF) { - codeLengthNext++; - codeLen = TclGetInt4AtPtr(codeLengthNext); - codeLengthNext += 4; - } else { - codeLen = TclGetInt1AtPtr(codeLengthNext); - codeLengthNext++; - } - - if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) { - srcDeltaNext++; - delta = TclGetInt4AtPtr(srcDeltaNext); - srcDeltaNext += 4; - } else { - delta = TclGetInt1AtPtr(srcDeltaNext); - srcDeltaNext++; - } - srcOffset += delta; - - if ((unsigned) *srcLengthNext == (unsigned) 0xFF) { - srcLengthNext++; - srcLen = TclGetInt4AtPtr(srcLengthNext); - srcLengthNext += 4; - } else { - srcLen = TclGetInt1AtPtr(srcLengthNext); - srcLengthNext++; - } - - Tcl_AppendPrintfToObj(bufferObj, "%s%4d: pc %d-%d, src %d-%d", - ((i % 2)? " " : "\n "), - (i+1), codeOffset, (codeOffset + codeLen - 1), - srcOffset, (srcOffset + srcLen - 1)); - } - if (numCmds > 0) { - Tcl_AppendToObj(bufferObj, "\n", -1); - } - - /* - * 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) *codeDeltaNext == (unsigned) 0xFF) { - codeDeltaNext++; - delta = TclGetInt4AtPtr(codeDeltaNext); - codeDeltaNext += 4; - } else { - delta = TclGetInt1AtPtr(codeDeltaNext); - codeDeltaNext++; - } - codeOffset += delta; - - if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) { - srcDeltaNext++; - delta = TclGetInt4AtPtr(srcDeltaNext); - srcDeltaNext += 4; - } else { - delta = TclGetInt1AtPtr(srcDeltaNext); - srcDeltaNext++; - } - srcOffset += delta; - - if ((unsigned) *srcLengthNext == (unsigned) 0xFF) { - srcLengthNext++; - srcLen = TclGetInt4AtPtr(srcLengthNext); - srcLengthNext += 4; - } else { - srcLen = TclGetInt1AtPtr(srcLengthNext); - srcLengthNext++; - } - - /* - * Print instructions before command i. - */ - - while ((pc-codeStart) < codeOffset) { - Tcl_AppendToObj(bufferObj, " ", -1); - pc += FormatInstruction(codePtr, pc, bufferObj); - } - - Tcl_AppendPrintfToObj(bufferObj, " Command %d: ", i+1); - PrintSourceToObj(bufferObj, (codePtr->source + srcOffset), - TclMin(srcLen, 55)); - Tcl_AppendToObj(bufferObj, "\n", -1); - } - if (pc < codeLimit) { - /* - * Print instructions after the last command. - */ - - while (pc < codeLimit) { - Tcl_AppendToObj(bufferObj, " ", -1); - pc += FormatInstruction(codePtr, pc, bufferObj); - } - } - return bufferObj; -} - -/* - *---------------------------------------------------------------------- - * - * FormatInstruction -- - * - * Appends a representation of a bytecode instruction to a Tcl_Obj. - * - *---------------------------------------------------------------------- - */ - -static int -FormatInstruction( - ByteCode *codePtr, /* Bytecode containing the instruction. */ - const unsigned char *pc, /* Points to first byte of instruction. */ - Tcl_Obj *bufferObj) /* Object to append instruction info to. */ -{ - Proc *procPtr = codePtr->procPtr; - unsigned char opCode = *pc; - register const InstructionDesc *instDesc = &tclInstructionTable[opCode]; - unsigned char *codeStart = codePtr->codeStart; - unsigned pcOffset = pc - codeStart; - int opnd = 0, i, j, numBytes = 1; - int localCt = procPtr ? procPtr->numCompiledLocals : 0; - CompiledLocal *localPtr = procPtr ? procPtr->firstLocalPtr : NULL; - char suffixBuffer[128]; /* Additional info to print after main opcode - * and immediates. */ - char *suffixSrc = NULL; - Tcl_Obj *suffixObj = NULL; - AuxData *auxPtr = NULL; - - suffixBuffer[0] = '\0'; - Tcl_AppendPrintfToObj(bufferObj, "(%u) %s ", pcOffset, instDesc->name); - for (i = 0; i < instDesc->numOperands; i++) { - switch (instDesc->opTypes[i]) { - case OPERAND_INT1: - opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++; - if (opCode == INST_JUMP1 || opCode == INST_JUMP_TRUE1 - || opCode == INST_JUMP_FALSE1) { - sprintf(suffixBuffer, "pc %u", pcOffset+opnd); - } - Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); - break; - case OPERAND_INT4: - opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; - if (opCode == INST_JUMP4 || opCode == INST_JUMP_TRUE4 - || opCode == INST_JUMP_FALSE4) { - sprintf(suffixBuffer, "pc %u", pcOffset+opnd); - } else if (opCode == INST_START_CMD) { - sprintf(suffixBuffer, "next cmd at pc %u", pcOffset+opnd); - } - Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); - break; - case OPERAND_UINT1: - opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; - if (opCode == INST_PUSH1) { - suffixObj = codePtr->objArrayPtr[opnd]; - } - Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); - break; - case OPERAND_AUX4: - case OPERAND_UINT4: - opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; - if (opCode == INST_PUSH4) { - suffixObj = codePtr->objArrayPtr[opnd]; - } else if (opCode == INST_START_CMD && opnd != 1) { - sprintf(suffixBuffer+strlen(suffixBuffer), - ", %u cmds start here", opnd); - } - Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); - if (instDesc->opTypes[i] == OPERAND_AUX4) { - auxPtr = &codePtr->auxDataArrayPtr[opnd]; - } - break; - case OPERAND_IDX4: - opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; - if (opnd >= -1) { - Tcl_AppendPrintfToObj(bufferObj, "%d ", opnd); - } else if (opnd == -2) { - Tcl_AppendPrintfToObj(bufferObj, "end "); - } else { - Tcl_AppendPrintfToObj(bufferObj, "end-%d ", -2-opnd); - } - break; - case OPERAND_LVT1: - opnd = TclGetUInt1AtPtr(pc+numBytes); - numBytes++; - goto printLVTindex; - case OPERAND_LVT4: - opnd = TclGetUInt4AtPtr(pc+numBytes); - numBytes += 4; - printLVTindex: - if (localPtr != NULL) { - if (opnd >= localCt) { - Tcl_Panic("FormatInstruction: bad local var index %u (%u locals)", - (unsigned) opnd, localCt); - } - for (j = 0; j < opnd; j++) { - localPtr = localPtr->nextPtr; - } - if (TclIsVarTemporary(localPtr)) { - sprintf(suffixBuffer, "temp var %u", (unsigned) opnd); - } else { - sprintf(suffixBuffer, "var "); - suffixSrc = localPtr->name; - } - } - Tcl_AppendPrintfToObj(bufferObj, "%%v%u ", (unsigned) opnd); - break; - case OPERAND_NONE: - default: - break; - } - } - if (suffixObj) { - const char *bytes; - int length; - - Tcl_AppendToObj(bufferObj, "\t# ", -1); - bytes = Tcl_GetStringFromObj(codePtr->objArrayPtr[opnd], &length); - PrintSourceToObj(bufferObj, bytes, TclMin(length, 40)); - } else if (suffixBuffer[0]) { - Tcl_AppendPrintfToObj(bufferObj, "\t# %s", suffixBuffer); - if (suffixSrc) { - PrintSourceToObj(bufferObj, suffixSrc, 40); - } - } - Tcl_AppendToObj(bufferObj, "\n", -1); - if (auxPtr && auxPtr->type->printProc) { - Tcl_AppendToObj(bufferObj, "\t\t[", -1); - auxPtr->type->printProc(auxPtr->clientData, bufferObj, codePtr, - pcOffset); - Tcl_AppendToObj(bufferObj, "]\n", -1); - } - return numBytes; -} - -/* - *---------------------------------------------------------------------- - * - * PrintSourceToObj -- - * - * Appends a quoted representation of a string to a Tcl_Obj. - * - *---------------------------------------------------------------------- - */ - -static void -PrintSourceToObj( - Tcl_Obj *appendObj, /* The object to print the source to. */ - const char *stringPtr, /* The string to print. */ - int maxChars) /* Maximum number of chars to print. */ -{ - register const char *p; - register int i = 0; - - if (stringPtr == NULL) { - Tcl_AppendToObj(appendObj, "\"\"", -1); - return; - } - - Tcl_AppendToObj(appendObj, "\"", -1); - p = stringPtr; - for (; (*p != '\0') && (i < maxChars); p++, i++) { - switch (*p) { - case '"': - Tcl_AppendToObj(appendObj, "\\\"", -1); - continue; - case '\f': - Tcl_AppendToObj(appendObj, "\\f", -1); - continue; - case '\n': - Tcl_AppendToObj(appendObj, "\\n", -1); - continue; - case '\r': - Tcl_AppendToObj(appendObj, "\\r", -1); - continue; - case '\t': - Tcl_AppendToObj(appendObj, "\\t", -1); - continue; - case '\v': - Tcl_AppendToObj(appendObj, "\\v", -1); - continue; - default: - Tcl_AppendPrintfToObj(appendObj, "%c", *p); - continue; - } - } - Tcl_AppendToObj(appendObj, "\"", -1); -} - -#ifdef TCL_COMPILE_STATS -/* - *---------------------------------------------------------------------- - * - * RecordByteCodeStats -- - * - * Accumulates various compilation-related statistics for each newly - * compiled ByteCode. Called by the TclInitByteCodeObj when Tcl is - * compiled with the -DTCL_COMPILE_STATS flag - * - * Results: - * None. - * - * Side effects: - * Accumulates aggregate code-related statistics in the interpreter's - * ByteCodeStats structure. Records statistics specific to a ByteCode in - * its ByteCode structure. - * - *---------------------------------------------------------------------- - */ - -void -RecordByteCodeStats( - ByteCode *codePtr) /* Points to ByteCode structure with info - * to add to accumulated statistics. */ -{ - Interp *iPtr = (Interp *) *codePtr->interpHandle; - register ByteCodeStats *statsPtr; - - if (iPtr == NULL) { - /* Avoid segfaulting in case we're called in a deleted interp */ - return; - } - statsPtr = &(iPtr->stats); - - statsPtr->numCompilations++; - statsPtr->totalSrcBytes += (double) codePtr->numSrcBytes; - statsPtr->totalByteCodeBytes += (double) codePtr->structureSize; - statsPtr->currentSrcBytes += (double) codePtr->numSrcBytes; - statsPtr->currentByteCodeBytes += (double) codePtr->structureSize; - - statsPtr->srcCount[TclLog2(codePtr->numSrcBytes)]++; - statsPtr->byteCodeCount[TclLog2((int) codePtr->structureSize)]++; - - statsPtr->currentInstBytes += (double) codePtr->numCodeBytes; - statsPtr->currentLitBytes += (double) - codePtr->numLitObjects * sizeof(Tcl_Obj *); - statsPtr->currentExceptBytes += (double) - codePtr->numExceptRanges * sizeof(ExceptionRange); - statsPtr->currentAuxBytes += (double) - codePtr->numAuxDataItems * sizeof(AuxData); - statsPtr->currentCmdMapBytes += (double) codePtr->numCmdLocBytes; -} -#endif /* TCL_COMPILE_STATS */ - /* * Local Variables: * mode: c diff --git a/generic/tclCompile.h b/generic/tclCompile.h index cedd638..b6288d0 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -10,825 +10,8 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#ifndef _TCLCOMPILATION -#define _TCLCOMPILATION 1 - -#include "tclInt.h" - struct ByteCode; /* Forward declaration. */ -/* - *------------------------------------------------------------------------ - * Variables related to compilation. These are used in tclCompile.c, - * tclExecute.c, tclBasic.c, and their clients. - *------------------------------------------------------------------------ - */ - -#ifdef TCL_COMPILE_DEBUG -/* - * 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". - */ - -MODULE_SCOPE int tclTraceCompile; - -/* - * Variable that controls whether execution tracing is enabled and, if so, - * what level of tracing is desired: - * 0: no execution tracing - * 1: trace invocations of Tcl procs only - * 2: trace invocations of all (not compiled away) commands - * 3: display each instruction executed - * This variable is linked to the Tcl variable "tcl_traceExec". - */ - -MODULE_SCOPE int tclTraceExec; -#endif - -/* - *------------------------------------------------------------------------ - * Data structures related to compilation. - *------------------------------------------------------------------------ - */ - -/* - * The structure used to implement Tcl "exceptions" (exceptional returns): for - * example, those generated in loops by the break and continue commands, and - * those generated by scripts and caught by the catch command. This - * ExceptionRange structure describes a range of code (e.g., a loop body), the - * kind of exceptions (e.g., a break or continue) that might occur, and the PC - * offsets to jump to if a matching exception does occur. Exception ranges can - * nest so this structure includes a nesting level that is used at runtime to - * find the closest exception range surrounding a PC. For example, when a - * break command is executed, the ExceptionRange structure for the most deeply - * nested loop, if any, is found and used. These structures are also generated - * for the "next" subcommands of for loops since a break there terminates the - * for command. This means a for command actually generates two LoopInfo - * structures. - */ - -typedef enum { - LOOP_EXCEPTION_RANGE, /* Exception's range is part of a loop. Break - * and continue "exceptions" cause jumps to - * appropriate PC offsets. */ - CATCH_EXCEPTION_RANGE /* Exception's range is controlled by a catch - * command. Errors in the range cause a jump - * to a catch PC offset. */ -} ExceptionRangeType; - -typedef struct ExceptionRange { - ExceptionRangeType type; /* The kind of ExceptionRange. */ - int nestingLevel; /* Static depth of the exception range. Used - * to find the most deeply-nested range - * surrounding a PC at runtime. */ - int codeOffset; /* Offset of the first instruction byte of the - * code range. */ - int numCodeBytes; /* Number of bytes in the code range. */ - int breakOffset; /* If LOOP_EXCEPTION_RANGE, the target PC - * offset for a break command in the range. */ - int continueOffset; /* If LOOP_EXCEPTION_RANGE and not -1, the - * target PC offset for a continue command in - * the code range. Otherwise, ignore this - * range when processing a continue - * command. */ - int catchOffset; /* If a CATCH_EXCEPTION_RANGE, the target PC - * offset for any "exception" in range. */ -} ExceptionRange; - -/* - * Structure used to map between instruction pc and source locations. It - * defines for each compiled Tcl command its code's starting offset and its - * source's starting offset and length. Note that the code offset increases - * monotonically: that is, the table is sorted in code offset order. The - * source offset is not monotonic. - */ - -typedef struct CmdLocation { - int codeOffset; /* Offset of first byte of command code. */ - int numCodeBytes; /* Number of bytes for command's code. */ - int srcOffset; /* Offset of first char of the command. */ - int numSrcBytes; /* Number of command source chars. */ -} CmdLocation; - -/* - * CompileProcs need the ability to record information during compilation that - * can be used by bytecode instructions during execution. The AuxData - * structure provides this "auxiliary data" mechanism. An arbitrary number of - * these structures can be stored in the ByteCode record (during compilation - * they are stored in a CompileEnv structure). Each AuxData record holds one - * word of client-specified data (often a pointer) and is given an index that - * instructions can later use to look up the structure and its data. - * - * The following definitions declare the types of procedures that are called - * to duplicate or free this auxiliary data when the containing ByteCode - * objects are duplicated and freed. Pointers to these procedures are kept in - * the AuxData structure. - */ - -typedef ClientData (AuxDataDupProc) (ClientData clientData); -typedef void (AuxDataFreeProc) (ClientData clientData); -typedef void (AuxDataPrintProc)(ClientData clientData, - Tcl_Obj *appendObj, struct ByteCode *codePtr, - unsigned int pcOffset); - -/* - * We define a separate AuxDataType struct to hold type-related information - * for the AuxData structure. This separation makes it possible for clients - * outside of the TCL core to manipulate (in a limited fashion!) AuxData; for - * example, it makes it possible to pickle and unpickle AuxData structs. - */ - -typedef struct AuxDataType { - const char *name; /* The name of the type. Types can be - * registered and found by name */ - AuxDataDupProc *dupProc; /* Callback procedure to invoke when the aux - * data is duplicated (e.g., when the ByteCode - * structure containing the aux data is - * duplicated). NULL means just copy the - * source clientData bits; no proc need be - * called. */ - AuxDataFreeProc *freeProc; /* Callback procedure to invoke when the aux - * data is freed. NULL means no proc need be - * called. */ - AuxDataPrintProc *printProc;/* Callback function to invoke when printing - * the aux data as part of debugging. NULL - * means that the data can't be printed. */ -} AuxDataType; - -/* - * The definition of the AuxData structure that holds information created - * during compilation by CompileProcs and used by instructions during - * execution. - */ - -typedef struct AuxData { - const AuxDataType *type; /* Pointer to the AuxData type associated with - * this ClientData. */ - ClientData clientData; /* The compilation data itself. */ -} AuxData; - -/* - * Structure defining the compilation environment. After compilation, fields - * describing bytecode instructions are copied out into the more compact - * ByteCode structure defined below. - */ - -#define COMPILEENV_INIT_CODE_BYTES 250 -#define COMPILEENV_INIT_NUM_OBJECTS 60 -#define COMPILEENV_INIT_EXCEPT_RANGES 5 -#define COMPILEENV_INIT_CMD_MAP_SIZE 40 -#define COMPILEENV_INIT_AUX_DATA_SIZE 5 - -typedef struct CompileEnv { - Interp *iPtr; /* Interpreter containing the code being - * compiled. Commands and their compile procs - * are specific to an interpreter so the code - * emitted will depend on the interpreter. */ - const char *source; /* The source string being compiled by - * SetByteCodeFromAny. This pointer is not - * owned by the CompileEnv and must not be - * freed or changed by it. */ - int numSrcBytes; /* Number of bytes in source. */ - Proc *procPtr; /* If a procedure is being compiled, a pointer - * to its Proc structure; otherwise NULL. Used - * to compile local variables. Set from - * information provided by ObjInterpProc in - * tclProc.c. */ - int numCommands; /* Number of commands compiled. */ - int exceptDepth; /* Current exception range nesting level; -1 - * if not in any range currently. */ - int maxExceptDepth; /* Max nesting level of exception ranges; -1 - * if no ranges have been compiled. */ - int maxStackDepth; /* Maximum number of stack elements needed to - * execute the code. Set by compilation - * procedures before returning. */ - int currStackDepth; /* Current stack depth. */ - LiteralTable localLitTable; /* Contains LiteralEntry's describing all Tcl - * objects referenced by this compiled code. - * Indexed by the string representations of - * the literals. Used to avoid creating - * duplicate objects. */ - unsigned char *codeStart; /* Points to the first byte of the code. */ - unsigned char *codeNext; /* Points to next code array byte to use. */ - unsigned char *codeEnd; /* Points just after the last allocated code - * array byte. */ - int mallocedCodeArray; /* Set 1 if code array was expanded and - * codeStart points into the heap.*/ - LiteralEntry *literalArrayPtr; - /* Points to start of LiteralEntry array. */ - int literalArrayNext; /* Index of next free object array entry. */ - int literalArrayEnd; /* Index just after last obj array entry. */ - int mallocedLiteralArray; /* 1 if object array was expanded and objArray - * points into the heap, else 0. */ - ExceptionRange *exceptArrayPtr; - /* Points to start of the ExceptionRange - * array. */ - int exceptArrayNext; /* Next free ExceptionRange array index. - * exceptArrayNext is the number of ranges and - * (exceptArrayNext-1) is the index of the - * current range's array entry. */ - int exceptArrayEnd; /* Index after the last ExceptionRange array - * entry. */ - int mallocedExceptArray; /* 1 if ExceptionRange array was expanded and - * exceptArrayPtr points in heap, else 0. */ - CmdLocation *cmdMapPtr; /* Points to start of CmdLocation array. - * numCommands is the index of the next entry - * to use; (numCommands-1) is the entry index - * for the last command. */ - int cmdMapEnd; /* Index after last CmdLocation entry. */ - int mallocedCmdMap; /* 1 if command map array was expanded and - * cmdMapPtr points in the heap, else 0. */ - AuxData *auxDataArrayPtr; /* Points to auxiliary data array start. */ - int auxDataArrayNext; /* Next free compile aux data array index. - * auxDataArrayNext is the number of aux data - * items and (auxDataArrayNext-1) is index of - * current aux data array entry. */ - int auxDataArrayEnd; /* Index after last aux data array entry. */ - int mallocedAuxDataArray; /* 1 if aux data array was expanded and - * auxDataArrayPtr points in heap else 0. */ - unsigned char staticCodeSpace[COMPILEENV_INIT_CODE_BYTES]; - /* Initial storage for code. */ - LiteralEntry staticLiteralSpace[COMPILEENV_INIT_NUM_OBJECTS]; - /* Initial storage of LiteralEntry array. */ - ExceptionRange staticExceptArraySpace[COMPILEENV_INIT_EXCEPT_RANGES]; - /* Initial ExceptionRange array storage. */ - CmdLocation staticCmdMapSpace[COMPILEENV_INIT_CMD_MAP_SIZE]; - /* Initial storage for cmd location map. */ - AuxData staticAuxDataArraySpace[COMPILEENV_INIT_AUX_DATA_SIZE]; - /* Initial storage for aux data array. */ - int atCmdStart; /* Flag to say whether an INST_START_CMD - * should be issued; they should never be - * issued repeatedly, as that is significantly - * inefficient. */ -} CompileEnv; - -/* - * The structure defining the bytecode instructions resulting from compiling a - * Tcl script. Note that this structure is variable length: a single heap - * object is allocated to hold the ByteCode structure immediately followed by - * the code bytes, the literal object array, the ExceptionRange array, the - * CmdLocation map, and the compilation AuxData array. - */ - -/* - * A PRECOMPILED bytecode struct is one that was generated from a compiled - * image rather than implicitly compiled from source - */ - -#define TCL_BYTECODE_PRECOMPILED 0x0001 - -/* - * When a bytecode is compiled, interp or namespace resolvers have not been - * applied yet: this is indicated by the TCL_BYTECODE_RESOLVE_VARS flag. - */ - -#define TCL_BYTECODE_RESOLVE_VARS 0x0002 - -#define TCL_BYTECODE_RECOMPILE 0x0004 - -typedef struct ByteCode { - TclHandle interpHandle; /* Handle for interpreter containing the - * compiled code. Commands and their compile - * procs are specific to an interpreter so the - * code emitted will depend on the - * interpreter. */ - int compileEpoch; /* Value of iPtr->compileEpoch when this - * ByteCode was compiled. Used to invalidate - * code when, e.g., commands with compile - * procs are redefined. */ - Namespace *nsPtr; /* Namespace context in which this code was - * compiled. If the code is executed if a - * different namespace, it must be - * recompiled. */ - int nsEpoch; /* Value of nsPtr->resolverEpoch when this - * ByteCode was compiled. Used to invalidate - * code when new namespace resolution rules - * are put into effect. */ - int refCount; /* Reference count: set 1 when created plus 1 - * for each execution of the code currently - * active. This structure can be freed when - * refCount becomes zero. */ - unsigned int flags; /* flags describing state for the codebyte. - * this variable holds ORed values from the - * TCL_BYTECODE_ masks defined above */ - const char *source; /* The source string from which this ByteCode - * was compiled. Note that this pointer is not - * owned by the ByteCode and must not be freed - * or modified by it. */ - Proc *procPtr; /* If the ByteCode was compiled from a - * procedure body, this is a pointer to its - * Proc structure; otherwise NULL. This - * pointer is also not owned by the ByteCode - * and must not be freed by it. */ - size_t structureSize; /* Number of bytes in the ByteCode structure - * itself. Does not include heap space for - * literal Tcl objects or storage referenced - * by AuxData entries. */ - int numCommands; /* Number of commands compiled. */ - int numSrcBytes; /* Number of source bytes compiled. */ - int numCodeBytes; /* Number of code bytes. */ - int numLitObjects; /* Number of objects in literal array. */ - int numExceptRanges; /* Number of ExceptionRange array elems. */ - int numAuxDataItems; /* Number of AuxData items. */ - int numCmdLocBytes; /* Number of bytes needed for encoded command - * location information. */ - int maxExceptDepth; /* Maximum nesting level of ExceptionRanges; - * -1 if no ranges were compiled. */ - int maxStackDepth; /* Maximum number of stack elements needed to - * execute the code. */ - unsigned char *codeStart; /* Points to the first byte of the code. This - * is just after the final ByteCode member - * cmdMapPtr. */ - Tcl_Obj **objArrayPtr; /* Points to the start of the literal object - * array. This is just after the last code - * byte. */ - ExceptionRange *exceptArrayPtr; - /* Points to the start of the ExceptionRange - * array. This is just after the last object - * in the object array. */ - AuxData *auxDataArrayPtr; /* Points to the start of the auxiliary data - * array. This is just after the last entry in - * the ExceptionRange array. */ - unsigned char *codeDeltaStart; - /* Points to the first of a sequence of bytes - * that encode the change in the starting - * offset of each command's code. If -127 <= - * delta <= 127, it is encoded as 1 byte, - * otherwise 0xFF (128) appears and the delta - * is encoded by the next 4 bytes. Code deltas - * are always positive. This sequence is just - * after the last entry in the AuxData - * array. */ - unsigned char *codeLengthStart; - /* Points to the first of a sequence of bytes - * that encode the length of each command's - * code. The encoding is the same as for code - * deltas. Code lengths are always positive. - * This sequence is just after the last entry - * in the code delta sequence. */ - unsigned char *srcDeltaStart; - /* Points to the first of a sequence of bytes - * that encode the change in the starting - * offset of each command's source. The - * encoding is the same as for code deltas. - * Source deltas can be negative. This - * sequence is just after the last byte in the - * code length sequence. */ - unsigned char *srcLengthStart; - /* Points to the first of a sequence of bytes - * that encode the length of each command's - * source. The encoding is the same as for - * code deltas. Source lengths are always - * positive. This sequence is just after the - * last byte in the source delta sequence. */ - LocalCache *localCachePtr; /* Pointer to the start of the cached variable - * names and initialisation data for local - * variables. */ -#ifdef TCL_COMPILE_STATS - Tcl_Time createTime; /* Absolute time when the ByteCode was - * created. */ -#endif /* TCL_COMPILE_STATS */ -} ByteCode; - -/* - * Opcodes for the Tcl bytecode instructions. These must correspond to the - * entries in the table of instruction descriptions, tclInstructionTable, in - * tclCompile.c. Also, the order and number of the expression opcodes (e.g., - * INST_LOR) must match the entries in the array operatorStrings in - * tclExecute.c. - */ - -/* Opcodes 0 to 9 */ -#define INST_DONE 0 -#define INST_PUSH1 1 -#define INST_PUSH4 2 -#define INST_POP 3 -#define INST_DUP 4 -#define INST_CONCAT1 5 -#define INST_INVOKE_STK1 6 -#define INST_INVOKE_STK4 7 -#define INST_EVAL_STK 8 -#define INST_EXPR_STK 9 - -/* Opcodes 10 to 23 */ -#define INST_LOAD_SCALAR1 10 -#define INST_LOAD_SCALAR4 11 -#define INST_LOAD_SCALAR_STK 12 -#define INST_LOAD_ARRAY1 13 -#define INST_LOAD_ARRAY4 14 -#define INST_LOAD_ARRAY_STK 15 -#define INST_LOAD_STK 16 -#define INST_STORE_SCALAR1 17 -#define INST_STORE_SCALAR4 18 -#define INST_STORE_SCALAR_STK 19 -#define INST_STORE_ARRAY1 20 -#define INST_STORE_ARRAY4 21 -#define INST_STORE_ARRAY_STK 22 -#define INST_STORE_STK 23 - -/* Opcodes 24 to 33 */ -#define INST_INCR_SCALAR1 24 -#define INST_INCR_SCALAR_STK 25 -#define INST_INCR_ARRAY1 26 -#define INST_INCR_ARRAY_STK 27 -#define INST_INCR_STK 28 -#define INST_INCR_SCALAR1_IMM 29 -#define INST_INCR_SCALAR_STK_IMM 30 -#define INST_INCR_ARRAY1_IMM 31 -#define INST_INCR_ARRAY_STK_IMM 32 -#define INST_INCR_STK_IMM 33 - -/* Opcodes 34 to 39 */ -#define INST_JUMP1 34 -#define INST_JUMP4 35 -#define INST_JUMP_TRUE1 36 -#define INST_JUMP_TRUE4 37 -#define INST_JUMP_FALSE1 38 -#define INST_JUMP_FALSE4 39 - -/* Opcodes 40 to 64 */ -#define INST_LOR 40 -#define INST_LAND 41 -#define INST_BITOR 42 -#define INST_BITXOR 43 -#define INST_BITAND 44 -#define INST_EQ 45 -#define INST_NEQ 46 -#define INST_LT 47 -#define INST_GT 48 -#define INST_LE 49 -#define INST_GE 50 -#define INST_LSHIFT 51 -#define INST_RSHIFT 52 -#define INST_ADD 53 -#define INST_SUB 54 -#define INST_MULT 55 -#define INST_DIV 56 -#define INST_MOD 57 -#define INST_UPLUS 58 -#define INST_UMINUS 59 -#define INST_BITNOT 60 -#define INST_LNOT 61 -#define INST_CALL_BUILTIN_FUNC1 62 -#define INST_CALL_FUNC1 63 -#define INST_TRY_CVT_TO_NUMERIC 64 - -/* Opcodes 65 to 66 */ -#define INST_BREAK 65 -#define INST_CONTINUE 66 - -/* Opcodes 67 to 68 */ -#define INST_FOREACH_START4 67 -#define INST_FOREACH_STEP4 68 - -/* Opcodes 69 to 72 */ -#define INST_BEGIN_CATCH4 69 -#define INST_END_CATCH 70 -#define INST_PUSH_RESULT 71 -#define INST_PUSH_RETURN_CODE 72 - -/* Opcodes 73 to 78 */ -#define INST_STR_EQ 73 -#define INST_STR_NEQ 74 -#define INST_STR_CMP 75 -#define INST_STR_LEN 76 -#define INST_STR_INDEX 77 -#define INST_STR_MATCH 78 - -/* Opcodes 78 to 81 */ -#define INST_LIST 79 -#define INST_LIST_INDEX 80 -#define INST_LIST_LENGTH 81 - -/* Opcodes 82 to 87 */ -#define INST_APPEND_SCALAR1 82 -#define INST_APPEND_SCALAR4 83 -#define INST_APPEND_ARRAY1 84 -#define INST_APPEND_ARRAY4 85 -#define INST_APPEND_ARRAY_STK 86 -#define INST_APPEND_STK 87 - -/* Opcodes 88 to 93 */ -#define INST_LAPPEND_SCALAR1 88 -#define INST_LAPPEND_SCALAR4 89 -#define INST_LAPPEND_ARRAY1 90 -#define INST_LAPPEND_ARRAY4 91 -#define INST_LAPPEND_ARRAY_STK 92 -#define INST_LAPPEND_STK 93 - -/* TIP #22 - LINDEX operator with flat arg list */ - -#define INST_LIST_INDEX_MULTI 94 - -/* - * TIP #33 - 'lset' command. Code gen also required a Forth-like - * OVER operation. - */ - -#define INST_OVER 95 -#define INST_LSET_LIST 96 -#define INST_LSET_FLAT 97 - -/* TIP#90 - 'return' command. */ - -#define INST_RETURN_IMM 98 - -/* TIP#123 - exponentiation operator. */ - -#define INST_EXPON 99 - -/* TIP #157 - {*}... (word expansion) language syntax support. */ - -#define INST_EXPAND_START 100 -#define INST_EXPAND_STKTOP 101 -#define INST_INVOKE_EXPANDED 102 - -/* - * TIP #57 - 'lassign' command. Code generation requires immediate - * LINDEX and LRANGE operators. - */ - -#define INST_LIST_INDEX_IMM 103 -#define INST_LIST_RANGE_IMM 104 - -#define INST_START_CMD 105 - -#define INST_LIST_IN 106 -#define INST_LIST_NOT_IN 107 - -#define INST_PUSH_RETURN_OPTIONS 108 -#define INST_RETURN_STK 109 - -/* - * Dictionary (TIP#111) related commands. - */ - -#define INST_DICT_GET 110 -#define INST_DICT_SET 111 -#define INST_DICT_UNSET 112 -#define INST_DICT_INCR_IMM 113 -#define INST_DICT_APPEND 114 -#define INST_DICT_LAPPEND 115 -#define INST_DICT_FIRST 116 -#define INST_DICT_NEXT 117 -#define INST_DICT_DONE 118 -#define INST_DICT_UPDATE_START 119 -#define INST_DICT_UPDATE_END 120 - -/* - * Instruction to support jumps defined by tables (instead of the classic - * [switch] technique of chained comparisons). - */ - -#define INST_JUMP_TABLE 121 - -/* - * Instructions to support compilation of global, variable, upvar and - * [namespace upvar]. - */ - -#define INST_UPVAR 122 -#define INST_NSUPVAR 123 -#define INST_VARIABLE 124 - -/* Instruction to support compiling syntax error to bytecode */ - -#define INST_SYNTAX 125 - -/* Instruction to reverse N items on top of stack */ - -#define INST_REVERSE 126 - -/* regexp instruction */ - -#define INST_REGEXP 127 - -/* For [info exists] compilation */ -#define INST_EXIST_SCALAR 128 -#define INST_EXIST_ARRAY 129 -#define INST_EXIST_ARRAY_STK 130 -#define INST_EXIST_STK 131 - -/* For [subst] compilation */ -#define INST_NOP 132 -#define INST_RETURN_CODE_BRANCH 133 - -/* For [unset] compilation */ -#define INST_UNSET_SCALAR 134 -#define INST_UNSET_ARRAY 135 -#define INST_UNSET_ARRAY_STK 136 -#define INST_UNSET_STK 137 - -/* For [dict with], [dict exists], [dict create] and [dict merge] */ -#define INST_DICT_EXPAND 138 -#define INST_DICT_RECOMBINE_STK 139 -#define INST_DICT_RECOMBINE_IMM 140 -#define INST_DICT_EXISTS 141 -#define INST_DICT_VERIFY 142 - -/* For [string map] and [regsub] compilation */ -#define INST_STR_MAP 143 -#define INST_STR_FIND 144 -#define INST_STR_FIND_LAST 145 -#define INST_STR_RANGE_IMM 146 -#define INST_STR_RANGE 147 - -/* For operations to do with coroutines and other NRE-manipulators */ -#define INST_YIELD 148 -#define INST_COROUTINE_NAME 149 -#define INST_TAILCALL 150 - -/* For compilation of basic information operations */ -#define INST_NS_CURRENT 151 -#define INST_INFO_LEVEL_NUM 152 -#define INST_INFO_LEVEL_ARGS 153 -#define INST_RESOLVE_COMMAND 154 -#define INST_TCLOO_SELF 155 -#define INST_TCLOO_CLASS 156 -#define INST_TCLOO_NS 157 -#define INST_TCLOO_IS_OBJECT 158 - -/* For compilation of [array] subcommands */ -#define INST_ARRAY_EXISTS_STK 159 -#define INST_ARRAY_EXISTS_IMM 160 -#define INST_ARRAY_MAKE_STK 161 -#define INST_ARRAY_MAKE_IMM 162 - -#define INST_INVOKE_REPLACE 163 - -/* The last opcode */ -#define LAST_INST_OPCODE 163 - -/* - * Table describing the Tcl bytecode instructions: their name (for displaying - * code), total number of code bytes required (including operand bytes), and a - * description of the type of each operand. These operand types include signed - * and unsigned integers of length one and four bytes. The unsigned integers - * are used for indexes or for, e.g., the count of objects to push in a "push" - * instruction. - */ - -#define MAX_INSTRUCTION_OPERANDS 2 - -typedef enum InstOperandType { - OPERAND_NONE, - OPERAND_INT1, /* One byte signed integer. */ - OPERAND_INT4, /* Four byte signed integer. */ - OPERAND_UINT1, /* One byte unsigned integer. */ - OPERAND_UINT4, /* Four byte unsigned integer. */ - OPERAND_IDX4, /* Four byte signed index (actually an - * integer, but displayed differently.) */ - OPERAND_LVT1, /* One byte unsigned index into the local - * variable table. */ - OPERAND_LVT4, /* Four byte unsigned index into the local - * variable table. */ - OPERAND_AUX4 /* Four byte unsigned index into the aux data - * table. */ -} InstOperandType; - -typedef struct InstructionDesc { - const char *name; /* Name of instruction. */ - int numBytes; /* Total number of bytes for instruction. */ - int stackEffect; /* The worst-case balance stack effect of the - * instruction, used for stack requirements - * computations. The value INT_MIN signals - * that the instruction's worst case effect is - * (1-opnd1). */ - int numOperands; /* Number of operands. */ - InstOperandType opTypes[MAX_INSTRUCTION_OPERANDS]; - /* The type of each operand. */ -} InstructionDesc; - -MODULE_SCOPE InstructionDesc const tclInstructionTable[]; - -/* - * Compilation of some Tcl constructs such as if commands and the logical or - * (||) and logical and (&&) operators in expressions requires the generation - * of forward jumps. Since the PC target of these jumps isn't known when the - * jumps are emitted, we record the offset of each jump in an array of - * JumpFixup structures. There is one array for each sequence of jumps to one - * target PC. When we learn the target PC, we update the jumps with the - * correct distance. Also, if the distance is too great (> 127 bytes), we - * replace the single-byte jump with a four byte jump instruction, move the - * instructions after the jump down, and update the code offsets for any - * commands between the jump and the target. - */ - -typedef enum { - TCL_UNCONDITIONAL_JUMP, - TCL_TRUE_JUMP, - TCL_FALSE_JUMP -} TclJumpType; - -typedef struct JumpFixup { - TclJumpType jumpType; /* Indicates the kind of jump. */ - int codeOffset; /* Offset of the first byte of the one-byte - * forward jump's code. */ - int cmdIndex; /* Index of the first command after the one - * for which the jump was emitted. Used to - * update the code offsets for subsequent - * commands if the two-byte jump at jumpPc - * must be replaced with a five-byte one. */ - int exceptIndex; /* Index of the first range entry in the - * ExceptionRange array after the current one. - * This field is used to adjust the code - * offsets in subsequent ExceptionRange - * records when a jump is grown from 2 bytes - * to 5 bytes. */ -} JumpFixup; - -#define JUMPFIXUP_INIT_ENTRIES 10 - -typedef struct JumpFixupArray { - JumpFixup *fixup; /* Points to start of jump fixup array. */ - int next; /* Index of next free array entry. */ - int end; /* Index of last usable entry in array. */ - int mallocedArray; /* 1 if array was expanded and fixups points - * into the heap, else 0. */ - JumpFixup staticFixupSpace[JUMPFIXUP_INIT_ENTRIES]; - /* Initial storage for jump fixup array. */ -} JumpFixupArray; - -/* - * The structure describing one variable list of a foreach command. Note that - * only foreach commands inside procedure bodies are compiled inline so a - * ForeachVarList structure always describes local variables. Furthermore, - * only scalar variables are supported for inline-compiled foreach loops. - */ - -typedef struct ForeachVarList { - int numVars; /* The number of variables in the list. */ - int varIndexes[1]; /* An array of the indexes ("slot numbers") - * for each variable in the procedure's array - * of local variables. Only scalar variables - * are supported. The actual size of this - * field will be large enough to numVars - * indexes. THIS MUST BE THE LAST FIELD IN THE - * STRUCTURE! */ -} ForeachVarList; - -/* - * Structure used to hold information about a foreach command that is needed - * during program execution. These structures are stored in CompileEnv and - * ByteCode structures as auxiliary data. - */ - -typedef struct ForeachInfo { - int numLists; /* The number of both the variable and value - * lists of the foreach command. */ - int firstValueTemp; /* Index of the first temp var in a proc frame - * used to point to a value list. */ - int loopCtTemp; /* Index of temp var in a proc frame holding - * the loop's iteration count. Used to - * determine next value list element to assign - * each loop var. */ - ForeachVarList *varLists[1];/* An array of pointers to ForeachVarList - * structures describing each var list. The - * actual size of this field will be large - * enough to numVars indexes. THIS MUST BE THE - * LAST FIELD IN THE STRUCTURE! */ -} ForeachInfo; - -MODULE_SCOPE const AuxDataType tclForeachInfoType; - -/* - * Structure used to hold information about a switch command that is needed - * during program execution. These structures are stored in CompileEnv and - * ByteCode structures as auxiliary data. - */ - -typedef struct JumptableInfo { - Tcl_HashTable hashTable; /* Hash that maps strings to signed ints (PC - * offsets). */ -} JumptableInfo; - -MODULE_SCOPE const AuxDataType tclJumptableInfoType; - -/* - * Structure used to hold information about a [dict update] command that is - * needed during program execution. These structures are stored in CompileEnv - * and ByteCode structures as auxiliary data. - */ - -typedef struct { - int length; /* Size of array */ - int varIndices[1]; /* Array of variable indices to manage when - * processing the start and end of a [dict - * update]. There is really more than one - * entry, and the structure is allocated to - * take account of this. MUST BE LAST FIELD IN - * STRUCTURE. */ -} DictUpdateInfo; - -MODULE_SCOPE const AuxDataType tclDictUpdateInfoType; - -/* - * ClientData type used by the math operator commands. - */ typedef struct { const char *op; /* Do not call it 'operator': C++ reserved */ @@ -838,107 +21,7 @@ typedef struct { int identity; } i; } TclOpCmdClientData; - -/* - *---------------------------------------------------------------- - * Procedures exported by tclBasic.c to be used within the engine. - *---------------------------------------------------------------- - */ - -MODULE_SCOPE Tcl_ObjCmdProc TclNRInterpCoroutine; -/* - *---------------------------------------------------------------- - * Procedures exported by the engine to be used by tclBasic.c - *---------------------------------------------------------------- - */ - -MODULE_SCOPE ByteCode * TclCompileObj(Tcl_Interp *interp, Tcl_Obj *objPtr); - -/* - *---------------------------------------------------------------- - * Procedures shared among Tcl bytecode compilation and execution modules but - * not used outside: - *---------------------------------------------------------------- - */ - -MODULE_SCOPE void TclCleanupByteCode(ByteCode *codePtr); -MODULE_SCOPE void TclCompileCmdWord(Tcl_Interp *interp, - Tcl_Token *tokenPtr, int count, - CompileEnv *envPtr); -MODULE_SCOPE void TclCompileExpr(Tcl_Interp *interp, const char *script, - int numBytes, CompileEnv *envPtr, int optimize); -MODULE_SCOPE void TclCompileExprWords(Tcl_Interp *interp, - Tcl_Token *tokenPtr, int numWords, - CompileEnv *envPtr); -MODULE_SCOPE void TclCompileScript(Tcl_Interp *interp, - const char *script, int numBytes, - CompileEnv *envPtr); -MODULE_SCOPE void TclCompileSyntaxError(Tcl_Interp *interp, - CompileEnv *envPtr); -MODULE_SCOPE void TclCompileTokens(Tcl_Interp *interp, - Tcl_Token *tokenPtr, int count, - CompileEnv *envPtr); -MODULE_SCOPE void TclCompileVarSubst(Tcl_Interp *interp, - Tcl_Token *tokenPtr, CompileEnv *envPtr); -MODULE_SCOPE int TclCreateAuxData(ClientData clientData, - const AuxDataType *typePtr, CompileEnv *envPtr); -MODULE_SCOPE int TclCreateExceptRange(ExceptionRangeType type, - CompileEnv *envPtr); -MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp, int size); -MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, char *bytes, - int length, unsigned int hash, int *newPtr, - Namespace *nsPtr, int flags, - LiteralEntry **globalPtrPtr); -MODULE_SCOPE void TclDeleteExecEnv(ExecEnv *eePtr); -MODULE_SCOPE void TclDeleteLiteralTable(Tcl_Interp *interp, - LiteralTable *tablePtr); -MODULE_SCOPE void TclEmitForwardJump(CompileEnv *envPtr, - TclJumpType jumpType, JumpFixup *jumpFixupPtr); -MODULE_SCOPE ExceptionRange * TclGetExceptionRangeForPc(unsigned char *pc, - int catchOnly, ByteCode *codePtr); -MODULE_SCOPE void TclExpandJumpFixupArray(JumpFixupArray *fixupArrayPtr); -MODULE_SCOPE int TclNRExecuteByteCode(Tcl_Interp *interp, - ByteCode *codePtr); -MODULE_SCOPE void TclFinalizeAuxDataTypeTable(void); -MODULE_SCOPE int TclFindCompiledLocal(const char *name, int nameChars, - int create, CompileEnv *envPtr); -MODULE_SCOPE LiteralEntry * TclLookupLiteralEntry(Tcl_Interp *interp, - Tcl_Obj *objPtr); -MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr, - JumpFixup *jumpFixupPtr, int jumpDist, - int distThreshold); -MODULE_SCOPE void TclFreeCompileEnv(CompileEnv *envPtr); -MODULE_SCOPE void TclFreeJumpFixupArray(JumpFixupArray *fixupArrayPtr); -MODULE_SCOPE void TclInitAuxDataTypeTable(void); -MODULE_SCOPE void TclInitByteCodeObj(Tcl_Obj *objPtr, - CompileEnv *envPtr); -MODULE_SCOPE void TclInitCompilation(void); -MODULE_SCOPE void TclInitCompileEnv(Tcl_Interp *interp, - CompileEnv *envPtr, const char *string, - int numBytes); -MODULE_SCOPE void TclInitJumpFixupArray(JumpFixupArray *fixupArrayPtr); -MODULE_SCOPE void TclInitLiteralTable(LiteralTable *tablePtr); -#ifdef TCL_COMPILE_STATS -MODULE_SCOPE char * TclLiteralStats(LiteralTable *tablePtr); -MODULE_SCOPE int TclLog2(int value); -#endif -#ifdef TCL_COMPILE_DEBUG -MODULE_SCOPE void TclPrintByteCodeObj(Tcl_Interp *interp, - Tcl_Obj *objPtr); -#endif -MODULE_SCOPE int TclPrintInstruction(ByteCode *codePtr, - const unsigned char *pc); -MODULE_SCOPE void TclPrintObject(FILE *outFile, - Tcl_Obj *objPtr, int maxChars); -MODULE_SCOPE void TclPrintSource(FILE *outFile, - const char *string, int maxChars); -MODULE_SCOPE void TclRegisterAuxDataType(const AuxDataType *typePtr); -MODULE_SCOPE int TclRegisterLiteral(CompileEnv *envPtr, - char *bytes, int length, int flags); -MODULE_SCOPE void TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr); -MODULE_SCOPE void TclInvalidateCmdLiteral(Tcl_Interp *interp, - const char *name, Namespace *nsPtr); MODULE_SCOPE int TclSingleOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -951,621 +34,21 @@ MODULE_SCOPE int TclVariadicOpCmd(ClientData clientData, MODULE_SCOPE int TclNoIdentOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -#ifdef TCL_COMPILE_DEBUG -MODULE_SCOPE void TclVerifyGlobalLiteralTable(Interp *iPtr); -MODULE_SCOPE void TclVerifyLocalLiteralTable(CompileEnv *envPtr); -#endif -MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr, - Tcl_Obj *valuePtr); - -/* - *---------------------------------------------------------------- - * Macros and flag values used by Tcl bytecode compilation and execution - * modules inside the Tcl core but not used outside. - *---------------------------------------------------------------- - */ - -#define LITERAL_ON_HEAP 0x01 -#define LITERAL_CMD_NAME 0x02 - -/* - * Form of TclRegisterLiteral with flags == 0. In that case, it is safe to - * cast away constness, and it is cleanest to do that here, all in one place. - * - * int TclRegisterNewLiteral(CompileEnv *envPtr, const char *bytes, - * int length); - */ - -#define TclRegisterNewLiteral(envPtr, bytes, length) \ - TclRegisterLiteral(envPtr, (char *)(bytes), length, /*flags*/ 0) - -/* - * Form of TclRegisterLiteral with flags == LITERAL_CMD_NAME. In that case, it - * is safe to cast away constness, and it is cleanest to do that here, all in - * one place. - * - * int TclRegisterNewNSLiteral(CompileEnv *envPtr, const char *bytes, - * int length); - */ - -#define TclRegisterNewCmdLiteral(envPtr, bytes, length) \ - TclRegisterLiteral(envPtr, (char *)(bytes), length, LITERAL_CMD_NAME) - -/* - * Macro used to manually adjust the stack requirements; used in cases where - * the stack effect cannot be computed from the opcode and its operands, but - * is still known at compile time. - * - * void TclAdjustStackDepth(int delta, CompileEnv *envPtr); - */ - -#define TclAdjustStackDepth(delta, envPtr) \ - do { \ - if ((delta) < 0) { \ - if ((envPtr)->maxStackDepth < (envPtr)->currStackDepth) { \ - (envPtr)->maxStackDepth = (envPtr)->currStackDepth; \ - } \ - } \ - (envPtr)->currStackDepth += (delta); \ - } while (0) - -/* - * Macro used to update the stack requirements. It is called by the macros - * TclEmitOpCode, TclEmitInst1 and TclEmitInst4. - * Remark that the very last instruction of a bytecode always reduces the - * stack level: INST_DONE or INST_POP, so that the maxStackdepth is always - * updated. - * - * void TclUpdateStackReqs(unsigned char op, int i, CompileEnv *envPtr); - */ - -#define TclUpdateStackReqs(op, i, envPtr) \ - do { \ - int delta = tclInstructionTable[(op)].stackEffect; \ - if (delta) { \ - if (delta == INT_MIN) { \ - delta = 1 - (i); \ - } \ - TclAdjustStackDepth(delta, envPtr); \ - } \ - } while (0) - -/* - * Macro to emit an opcode byte into a CompileEnv's code array. The ANSI C - * "prototype" for this macro is: - * - * void TclEmitOpcode(unsigned char op, CompileEnv *envPtr); - */ - -#define TclEmitOpcode(op, envPtr) \ - do { \ - if ((envPtr)->codeNext == (envPtr)->codeEnd) { \ - TclExpandCodeArray(envPtr); \ - } \ - *(envPtr)->codeNext++ = (unsigned char) (op); \ - (envPtr)->atCmdStart = ((op) == INST_START_CMD); \ - TclUpdateStackReqs(op, 0, envPtr); \ - } while (0) - -/* - * Macros to emit an integer operand. The ANSI C "prototype" for these macros - * are: - * - * void TclEmitInt1(int i, CompileEnv *envPtr); - * void TclEmitInt4(int i, CompileEnv *envPtr); - */ - -#define TclEmitInt1(i, envPtr) \ - do { \ - if ((envPtr)->codeNext == (envPtr)->codeEnd) { \ - TclExpandCodeArray(envPtr); \ - } \ - *(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i)); \ - } while (0) - -#define TclEmitInt4(i, envPtr) \ - do { \ - if (((envPtr)->codeNext + 4) > (envPtr)->codeEnd) { \ - TclExpandCodeArray(envPtr); \ - } \ - *(envPtr)->codeNext++ = \ - (unsigned char) ((unsigned int) (i) >> 24); \ - *(envPtr)->codeNext++ = \ - (unsigned char) ((unsigned int) (i) >> 16); \ - *(envPtr)->codeNext++ = \ - (unsigned char) ((unsigned int) (i) >> 8); \ - *(envPtr)->codeNext++ = \ - (unsigned char) ((unsigned int) (i) ); \ - } while (0) - -/* - * Macros to emit an instruction with signed or unsigned integer operands. - * Four byte integers are stored in "big-endian" order with the high order - * byte stored at the lowest address. The ANSI C "prototypes" for these macros - * are: - * - * void TclEmitInstInt1(unsigned char op, int i, CompileEnv *envPtr); - * void TclEmitInstInt4(unsigned char op, int i, CompileEnv *envPtr); - */ - -#define TclEmitInstInt1(op, i, envPtr) \ - do { \ - if (((envPtr)->codeNext + 2) > (envPtr)->codeEnd) { \ - TclExpandCodeArray(envPtr); \ - } \ - *(envPtr)->codeNext++ = (unsigned char) (op); \ - *(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i)); \ - (envPtr)->atCmdStart = ((op) == INST_START_CMD); \ - TclUpdateStackReqs(op, i, envPtr); \ - } while (0) - -#define TclEmitInstInt4(op, i, envPtr) \ - do { \ - if (((envPtr)->codeNext + 5) > (envPtr)->codeEnd) { \ - TclExpandCodeArray(envPtr); \ - } \ - *(envPtr)->codeNext++ = (unsigned char) (op); \ - *(envPtr)->codeNext++ = \ - (unsigned char) ((unsigned int) (i) >> 24); \ - *(envPtr)->codeNext++ = \ - (unsigned char) ((unsigned int) (i) >> 16); \ - *(envPtr)->codeNext++ = \ - (unsigned char) ((unsigned int) (i) >> 8); \ - *(envPtr)->codeNext++ = \ - (unsigned char) ((unsigned int) (i) ); \ - (envPtr)->atCmdStart = ((op) == INST_START_CMD); \ - TclUpdateStackReqs(op, i, envPtr); \ - } while (0) - -/* - * Macro to push a Tcl object onto the Tcl evaluation stack. It emits the - * object's one or four byte array index into the CompileEnv's code array. - * These support, respectively, a maximum of 256 (2**8) and 2**32 objects in a - * CompileEnv. The ANSI C "prototype" for this macro is: - * - * void TclEmitPush(int objIndex, CompileEnv *envPtr); - */ - -#define TclEmitPush(objIndex, envPtr) \ - do { \ - register int objIndexCopy = (objIndex); \ - if (objIndexCopy <= 255) { \ - TclEmitInstInt1(INST_PUSH1, objIndexCopy, (envPtr)); \ - } else { \ - TclEmitInstInt4(INST_PUSH4, objIndexCopy, (envPtr)); \ - } \ - } while (0) - -/* - * Macros to update a (signed or unsigned) integer starting at a pointer. The - * two variants depend on the number of bytes. The ANSI C "prototypes" for - * these macros are: - * - * void TclStoreInt1AtPtr(int i, unsigned char *p); - * void TclStoreInt4AtPtr(int i, unsigned char *p); - */ - -#define TclStoreInt1AtPtr(i, p) \ - *(p) = (unsigned char) ((unsigned int) (i)) - -#define TclStoreInt4AtPtr(i, p) \ - do { \ - *(p) = (unsigned char) ((unsigned int) (i) >> 24); \ - *(p+1) = (unsigned char) ((unsigned int) (i) >> 16); \ - *(p+2) = (unsigned char) ((unsigned int) (i) >> 8); \ - *(p+3) = (unsigned char) ((unsigned int) (i) ); \ - } while (0) - -/* - * Macros to update instructions at a particular pc with a new op code and a - * (signed or unsigned) int operand. The ANSI C "prototypes" for these macros - * are: - * - * void TclUpdateInstInt1AtPc(unsigned char op, int i, unsigned char *pc); - * void TclUpdateInstInt4AtPc(unsigned char op, int i, unsigned char *pc); - */ - -#define TclUpdateInstInt1AtPc(op, i, pc) \ - do { \ - *(pc) = (unsigned char) (op); \ - TclStoreInt1AtPtr((i), ((pc)+1)); \ - } while (0) - -#define TclUpdateInstInt4AtPc(op, i, pc) \ - do { \ - *(pc) = (unsigned char) (op); \ - TclStoreInt4AtPtr((i), ((pc)+1)); \ - } while (0) - -/* - * Macro to fix up a forward jump to point to the current code-generation - * position in the bytecode being created (the most common case). The ANSI C - * "prototypes" for this macro is: - * - * int TclFixupForwardJumpToHere(CompileEnv *envPtr, JumpFixup *fixupPtr, - * int threshold); - */ - -#define TclFixupForwardJumpToHere(envPtr, fixupPtr, threshold) \ - TclFixupForwardJump((envPtr), (fixupPtr), \ - (envPtr)->codeNext-(envPtr)->codeStart-(fixupPtr)->codeOffset, \ - (threshold)) - -/* - * Macros to get a signed integer (GET_INT{1,2}) or an unsigned int - * (GET_UINT{1,2}) from a pointer. There are two variants for each return type - * that depend on the number of bytes fetched. The ANSI C "prototypes" for - * these macros are: - * - * int TclGetInt1AtPtr(unsigned char *p); - * int TclGetInt4AtPtr(unsigned char *p); - * unsigned int TclGetUInt1AtPtr(unsigned char *p); - * unsigned int TclGetUInt4AtPtr(unsigned char *p); - */ - -/* - * The TclGetInt1AtPtr macro is tricky because we want to do sign extension on - * the 1-byte value. Unfortunately the "char" type isn't signed on all - * platforms so sign-extension doesn't always happen automatically. Sometimes - * we can explicitly declare the pointer to be signed, but other times we have - * to explicitly sign-extend the value in software. - */ - -#ifndef __CHAR_UNSIGNED__ -# define TclGetInt1AtPtr(p) ((int) *((char *) p)) -#elif defined(HAVE_SIGNED_CHAR) -# define TclGetInt1AtPtr(p) ((int) *((signed char *) p)) -#else -# define TclGetInt1AtPtr(p) \ - (((int) *((char *) p)) | ((*(p) & 0200) ? (-256) : 0)) -#endif - -#define TclGetInt4AtPtr(p) \ - (((int) TclGetInt1AtPtr(p) << 24) | \ - (*((p)+1) << 16) | \ - (*((p)+2) << 8) | \ - (*((p)+3))) - -#define TclGetUInt1AtPtr(p) \ - ((unsigned int) *(p)) -#define TclGetUInt4AtPtr(p) \ - ((unsigned int) (*(p) << 24) | \ - (*((p)+1) << 16) | \ - (*((p)+2) << 8) | \ - (*((p)+3))) - -/* - * Macros used to compute the minimum and maximum of two integers. The ANSI C - * "prototypes" for these macros are: - * - * int TclMin(int i, int j); - * int TclMax(int i, int j); - */ - -#define TclMin(i, j) ((((int) i) < ((int) j))? (i) : (j)) -#define TclMax(i, j) ((((int) i) > ((int) j))? (i) : (j)) -/* - * Convenience macro for use when compiling bodies of commands. The ANSI C - * "prototype" for this macro is: - * - * static void CompileBody(CompileEnv *envPtr, Tcl_Token *tokenPtr, - * Tcl_Interp *interp); - */ - -#define CompileBody(envPtr, tokenPtr, interp) \ - TclCompileCmdWord((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ - (envPtr)) - -/* - * Convenience macro for use when compiling tokens to be pushed. The ANSI C - * "prototype" for this macro is: - * - * static void CompileTokens(CompileEnv *envPtr, Tcl_Token *tokenPtr, - * Tcl_Interp *interp); - */ - -#define CompileTokens(envPtr, tokenPtr, interp) \ - TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ - (envPtr)); -/* - * Convenience macro for use when pushing literals. The ANSI C "prototype" for - * this macro is: - * - * static void PushLiteral(CompileEnv *envPtr, - * const char *string, int length); - */ - -#define PushLiteral(envPtr, string, length) \ - TclEmitPush(TclRegisterNewLiteral((envPtr), (string), (length)), (envPtr)) - -/* - * Macro to advance to the next token; it is more mnemonic than the address - * arithmetic that it replaces. The ANSI C "prototype" for this macro is: - * - * static Tcl_Token * TokenAfter(Tcl_Token *tokenPtr); - */ - -#define TokenAfter(tokenPtr) \ - ((tokenPtr) + ((tokenPtr)->numComponents + 1)) - -/* - * Macro to get the offset to the next instruction to be issued. The ANSI C - * "prototype" for this macro is: - * - * static int CurrentOffset(CompileEnv *envPtr); - */ - -#define CurrentOffset(envPtr) \ - ((envPtr)->codeNext - (envPtr)->codeStart) - -/* - * Note: the exceptDepth is a bit of a misnomer: TEBC only needs the - * maximal depth of nested CATCH ranges in order to alloc runtime - * memory. These macros should compute precisely that? OTOH, the nesting depth - * of LOOP ranges is an interesting datum for debugging purposes, and that is - * what we compute now. - * - * static int DeclareExceptionRange(CompileEnv *envPtr, int type); - * static int ExceptionRangeStarts(CompileEnv *envPtr, int index); - * static void ExceptionRangeEnds(CompileEnv *envPtr, int index); - * static void ExceptionRangeTarget(CompileEnv *envPtr, int index, LABEL); - */ - -#define DeclareExceptionRange(envPtr, type) \ - (TclCreateExceptRange((type), (envPtr))) -#define ExceptionRangeStarts(envPtr, index) \ - (((envPtr)->exceptDepth++), \ - ((envPtr)->maxExceptDepth = \ - TclMax((envPtr)->exceptDepth, (envPtr)->maxExceptDepth)), \ - ((envPtr)->exceptArrayPtr[(index)].codeOffset = CurrentOffset(envPtr))) -#define ExceptionRangeEnds(envPtr, index) \ - (((envPtr)->exceptDepth--), \ - ((envPtr)->exceptArrayPtr[(index)].numCodeBytes = \ - CurrentOffset(envPtr) - (envPtr)->exceptArrayPtr[(index)].codeOffset)) -#define ExceptionRangeTarget(envPtr, index, targetType) \ - ((envPtr)->exceptArrayPtr[(index)].targetType = CurrentOffset(envPtr)) - -/* - * Check if there is an LVT for compiled locals - */ - -#define EnvHasLVT(envPtr) \ - (envPtr->procPtr || envPtr->iPtr->varFramePtr->localCachePtr) - -/* - * Macros for making it easier to deal with tokens and DStrings. - */ - -#define TclDStringAppendToken(dsPtr, tokenPtr) \ - Tcl_DStringAppend((dsPtr), (tokenPtr)->start, (tokenPtr)->size) -#define TclRegisterDStringLiteral(envPtr, dsPtr) \ - TclRegisterLiteral(envPtr, Tcl_DStringValue(dsPtr), \ - Tcl_DStringLength(dsPtr), /*flags*/ 0) - -/* - * DTrace probe macros (NOPs if DTrace support is not enabled). - */ - -/* - * Define the following macros to enable debug logging of the DTrace proc, - * cmd, and inst probes. Note that this does _not_ require a platform with - * DTrace, it simply logs all probe output to /tmp/tclDTraceDebug-[pid].log. - * - * If the second macro is defined, logging to file starts immediately, - * otherwise only after the first call to [tcl::dtrace]. Note that the debug - * probe data is always computed, even when it is not logged to file. - * - * Defining the third macro enables debug logging of inst probes (disabled - * by default due to the significant performance impact). - */ - -/* -#define TCL_DTRACE_DEBUG 1 -#define TCL_DTRACE_DEBUG_LOG_ENABLED 1 -#define TCL_DTRACE_DEBUG_INST_PROBES 1 -*/ - -#if !(defined(TCL_DTRACE_DEBUG) && defined(__GNUC__)) - -#ifdef USE_DTRACE - -#if defined(__GNUC__) && __GNUC__ > 2 -/* - * Use gcc branch prediction hint to minimize cost of DTrace ENABLED checks. - */ -#define unlikely(x) (__builtin_expect((x), 0)) -#else -#define unlikely(x) (x) -#endif - -#define TCL_DTRACE_PROC_ENTRY_ENABLED() unlikely(TCL_PROC_ENTRY_ENABLED()) -#define TCL_DTRACE_PROC_RETURN_ENABLED() unlikely(TCL_PROC_RETURN_ENABLED()) -#define TCL_DTRACE_PROC_RESULT_ENABLED() unlikely(TCL_PROC_RESULT_ENABLED()) -#define TCL_DTRACE_PROC_ARGS_ENABLED() unlikely(TCL_PROC_ARGS_ENABLED()) -#define TCL_DTRACE_PROC_INFO_ENABLED() unlikely(TCL_PROC_INFO_ENABLED()) -#define TCL_DTRACE_PROC_ENTRY(a0, a1, a2) TCL_PROC_ENTRY(a0, a1, a2) -#define TCL_DTRACE_PROC_RETURN(a0, a1) TCL_PROC_RETURN(a0, a1) -#define TCL_DTRACE_PROC_RESULT(a0, a1, a2, a3) TCL_PROC_RESULT(a0, a1, a2, a3) -#define TCL_DTRACE_PROC_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \ - TCL_PROC_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) -#define TCL_DTRACE_PROC_INFO(a0, a1, a2, a3, a4, a5, a6, a7) \ - TCL_PROC_INFO(a0, a1, a2, a3, a4, a5, a6, a7) - -#define TCL_DTRACE_CMD_ENTRY_ENABLED() unlikely(TCL_CMD_ENTRY_ENABLED()) -#define TCL_DTRACE_CMD_RETURN_ENABLED() unlikely(TCL_CMD_RETURN_ENABLED()) -#define TCL_DTRACE_CMD_RESULT_ENABLED() unlikely(TCL_CMD_RESULT_ENABLED()) -#define TCL_DTRACE_CMD_ARGS_ENABLED() unlikely(TCL_CMD_ARGS_ENABLED()) -#define TCL_DTRACE_CMD_INFO_ENABLED() unlikely(TCL_CMD_INFO_ENABLED()) -#define TCL_DTRACE_CMD_ENTRY(a0, a1, a2) TCL_CMD_ENTRY(a0, a1, a2) -#define TCL_DTRACE_CMD_RETURN(a0, a1) TCL_CMD_RETURN(a0, a1) -#define TCL_DTRACE_CMD_RESULT(a0, a1, a2, a3) TCL_CMD_RESULT(a0, a1, a2, a3) -#define TCL_DTRACE_CMD_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \ - TCL_CMD_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) -#define TCL_DTRACE_CMD_INFO(a0, a1, a2, a3, a4, a5, a6, a7) \ - TCL_CMD_INFO(a0, a1, a2, a3, a4, a5, a6, a7) - -#define TCL_DTRACE_INST_START_ENABLED() unlikely(TCL_INST_START_ENABLED()) -#define TCL_DTRACE_INST_DONE_ENABLED() unlikely(TCL_INST_DONE_ENABLED()) -#define TCL_DTRACE_INST_START(a0, a1, a2) TCL_INST_START(a0, a1, a2) -#define TCL_DTRACE_INST_DONE(a0, a1, a2) TCL_INST_DONE(a0, a1, a2) - -#define TCL_DTRACE_TCL_PROBE_ENABLED() unlikely(TCL_TCL_PROBE_ENABLED()) -#define TCL_DTRACE_TCL_PROBE(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \ - TCL_TCL_PROBE(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) - -#define TCL_DTRACE_DEBUG_LOG() - -MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, const char **args, - int *argsi); - -#else /* USE_DTRACE */ - -#define TCL_DTRACE_PROC_ENTRY_ENABLED() 0 -#define TCL_DTRACE_PROC_RETURN_ENABLED() 0 -#define TCL_DTRACE_PROC_RESULT_ENABLED() 0 -#define TCL_DTRACE_PROC_ARGS_ENABLED() 0 -#define TCL_DTRACE_PROC_INFO_ENABLED() 0 -#define TCL_DTRACE_PROC_ENTRY(a0, a1, a2) {if (a0) {}} -#define TCL_DTRACE_PROC_RETURN(a0, a1) {if (a0) {}} -#define TCL_DTRACE_PROC_RESULT(a0, a1, a2, a3) {if (a0) {}; if (a3) {}} -#define TCL_DTRACE_PROC_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) {} -#define TCL_DTRACE_PROC_INFO(a0, a1, a2, a3, a4, a5, a6, a7) {} - -#define TCL_DTRACE_CMD_ENTRY_ENABLED() 0 -#define TCL_DTRACE_CMD_RETURN_ENABLED() 0 -#define TCL_DTRACE_CMD_RESULT_ENABLED() 0 -#define TCL_DTRACE_CMD_ARGS_ENABLED() 0 -#define TCL_DTRACE_CMD_INFO_ENABLED() 0 -#define TCL_DTRACE_CMD_ENTRY(a0, a1, a2) {} -#define TCL_DTRACE_CMD_RETURN(a0, a1) {} -#define TCL_DTRACE_CMD_RESULT(a0, a1, a2, a3) {} -#define TCL_DTRACE_CMD_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) {} -#define TCL_DTRACE_CMD_INFO(a0, a1, a2, a3, a4, a5, a6, a7) {} - -#define TCL_DTRACE_INST_START_ENABLED() 0 -#define TCL_DTRACE_INST_DONE_ENABLED() 0 -#define TCL_DTRACE_INST_START(a0, a1, a2) {} -#define TCL_DTRACE_INST_DONE(a0, a1, a2) {} - -#define TCL_DTRACE_TCL_PROBE_ENABLED() 0 -#define TCL_DTRACE_TCL_PROBE(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) {} -#define TclDTraceInfo(info, args, argsi) {*args = ""; *argsi = 0;} - -#endif /* USE_DTRACE */ - -#else /* TCL_DTRACE_DEBUG */ - -#define USE_DTRACE 1 - -#if !defined(TCL_DTRACE_DEBUG_LOG_ENABLED) || !(TCL_DTRACE_DEBUG_LOG_ENABLED) -#undef TCL_DTRACE_DEBUG_LOG_ENABLED -#define TCL_DTRACE_DEBUG_LOG_ENABLED 0 -#endif - -#if !defined(TCL_DTRACE_DEBUG_INST_PROBES) || !(TCL_DTRACE_DEBUG_INST_PROBES) -#undef TCL_DTRACE_DEBUG_INST_PROBES -#define TCL_DTRACE_DEBUG_INST_PROBES 0 -#endif - -MODULE_SCOPE int tclDTraceDebugEnabled, tclDTraceDebugIndent; -MODULE_SCOPE FILE *tclDTraceDebugLog; -MODULE_SCOPE void TclDTraceOpenDebugLog(void); -MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, const char **args, int *argsi); - -#define TCL_DTRACE_DEBUG_LOG() \ - int tclDTraceDebugEnabled = TCL_DTRACE_DEBUG_LOG_ENABLED; \ - int tclDTraceDebugIndent = 0; \ - FILE *tclDTraceDebugLog = NULL; \ - void TclDTraceOpenDebugLog(void) { \ - char n[35]; \ - sprintf(n, "/tmp/tclDTraceDebug-%lu.log", \ - (unsigned long) getpid()); \ - tclDTraceDebugLog = fopen(n, "a"); \ - } - -#define TclDTraceDbgMsg(p, m, ...) \ - do { \ - if (tclDTraceDebugEnabled) { \ - int _l, _t = 0; \ - if (!tclDTraceDebugLog) { TclDTraceOpenDebugLog(); } \ - fprintf(tclDTraceDebugLog, "%.12s:%.4d:%n", \ - strrchr(__FILE__, '/')+1, __LINE__, &_l); _t += _l; \ - fprintf(tclDTraceDebugLog, " %.*s():%n", \ - (_t < 18 ? 18 - _t : 0) + 18, __func__, &_l); _t += _l; \ - fprintf(tclDTraceDebugLog, "%*s" p "%n", \ - (_t < 40 ? 40 - _t : 0) + 2 * tclDTraceDebugIndent, \ - "", &_l); _t += _l; \ - fprintf(tclDTraceDebugLog, "%*s" m "\n", \ - (_t < 64 ? 64 - _t : 1), "", ##__VA_ARGS__); \ - fflush(tclDTraceDebugLog); \ - } \ - } while (0) - -#define TCL_DTRACE_PROC_ENTRY_ENABLED() 1 -#define TCL_DTRACE_PROC_RETURN_ENABLED() 1 -#define TCL_DTRACE_PROC_RESULT_ENABLED() 1 -#define TCL_DTRACE_PROC_ARGS_ENABLED() 1 -#define TCL_DTRACE_PROC_INFO_ENABLED() 1 -#define TCL_DTRACE_PROC_ENTRY(a0, a1, a2) \ - tclDTraceDebugIndent++; \ - TclDTraceDbgMsg("-> proc-entry", "%s %d %p", a0, a1, a2) -#define TCL_DTRACE_PROC_RETURN(a0, a1) \ - TclDTraceDbgMsg("<- proc-return", "%s %d", a0, a1); \ - tclDTraceDebugIndent-- -#define TCL_DTRACE_PROC_RESULT(a0, a1, a2, a3) \ - TclDTraceDbgMsg(" | proc-result", "%s %d %s %p", a0, a1, a2, a3) -#define TCL_DTRACE_PROC_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \ - TclDTraceDbgMsg(" | proc-args", "%s %s %s %s %s %s %s %s %s %s", a0, \ - a1, a2, a3, a4, a5, a6, a7, a8, a9) -#define TCL_DTRACE_PROC_INFO(a0, a1, a2, a3, a4, a5, a6, a7) \ - TclDTraceDbgMsg(" | proc-info", "%s %s %s %s %d %d %s %s", a0, a1, \ - a2, a3, a4, a5, a6, a7) +MODULE_SCOPE void TclInitLiteralTable(LiteralTable *tablePtr); +MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp, int size); +MODULE_SCOPE void TclDeleteExecEnv(ExecEnv *eePtr); +MODULE_SCOPE void TclDeleteLiteralTable(Tcl_Interp *interp, + LiteralTable *tablePtr); +MODULE_SCOPE void TclInvalidateCmdLiteral(Tcl_Interp *interp, + const char *name, Namespace *nsPtr); -#define TCL_DTRACE_CMD_ENTRY_ENABLED() 1 -#define TCL_DTRACE_CMD_RETURN_ENABLED() 1 -#define TCL_DTRACE_CMD_RESULT_ENABLED() 1 -#define TCL_DTRACE_CMD_ARGS_ENABLED() 1 -#define TCL_DTRACE_CMD_INFO_ENABLED() 1 -#define TCL_DTRACE_CMD_ENTRY(a0, a1, a2) \ - tclDTraceDebugIndent++; \ - TclDTraceDbgMsg("-> cmd-entry", "%s %d %p", a0, a1, a2) -#define TCL_DTRACE_CMD_RETURN(a0, a1) \ - TclDTraceDbgMsg("<- cmd-return", "%s %d", a0, a1); \ - tclDTraceDebugIndent-- -#define TCL_DTRACE_CMD_RESULT(a0, a1, a2, a3) \ - TclDTraceDbgMsg(" | cmd-result", "%s %d %s %p", a0, a1, a2, a3) -#define TCL_DTRACE_CMD_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \ - TclDTraceDbgMsg(" | cmd-args", "%s %s %s %s %s %s %s %s %s %s", a0, \ - a1, a2, a3, a4, a5, a6, a7, a8, a9) -#define TCL_DTRACE_CMD_INFO(a0, a1, a2, a3, a4, a5, a6, a7) \ - TclDTraceDbgMsg(" | cmd-info", "%s %s %s %s %d %d %s %s", a0, a1, \ - a2, a3, a4, a5, a6, a7) +MODULE_SCOPE struct ByteCode * TclCompileObj(Tcl_Interp *interp, Tcl_Obj *objPtr); -#define TCL_DTRACE_INST_START_ENABLED() TCL_DTRACE_DEBUG_INST_PROBES -#define TCL_DTRACE_INST_DONE_ENABLED() TCL_DTRACE_DEBUG_INST_PROBES -#define TCL_DTRACE_INST_START(a0, a1, a2) \ - TclDTraceDbgMsg(" | inst-start", "%s %d %p", a0, a1, a2) -#define TCL_DTRACE_INST_DONE(a0, a1, a2) \ - TclDTraceDbgMsg(" | inst-end", "%s %d %p", a0, a1, a2) +MODULE_SCOPE int TclNRExecuteByteCode(Tcl_Interp *interp, + struct ByteCode *codePtr); -#define TCL_DTRACE_TCL_PROBE_ENABLED() 1 -#define TCL_DTRACE_TCL_PROBE(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \ - do { \ - tclDTraceDebugEnabled = 1; \ - TclDTraceDbgMsg(" | tcl-probe", "%s %s %s %s %s %s %s %s %s %s", a0, \ - a1, a2, a3, a4, a5, a6, a7, a8, a9); \ - } while (0) +MODULE_SCOPE Tcl_ObjCmdProc TclNRInterpCoroutine; -#endif /* TCL_DTRACE_DEBUG */ -#endif /* _TCLCOMPILATION */ - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 2801102..9ccca78 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -407,8 +407,7 @@ EXTERN int Tcl_Eval(Tcl_Interp *interp, const char *script); /* 130 */ EXTERN int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName); -/* 131 */ -EXTERN int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr); +/* Slot 131 is reserved */ /* 132 */ EXTERN void Tcl_EventuallyFree(ClientData clientData, Tcl_FreeProc *freeProc); @@ -488,9 +487,7 @@ EXTERN int Tcl_GetChannelOption(Tcl_Interp *interp, Tcl_DString *dsPtr); /* 158 */ EXTERN CONST86 Tcl_ChannelType * Tcl_GetChannelType(Tcl_Channel chan); -/* 159 */ -EXTERN int Tcl_GetCommandInfo(Tcl_Interp *interp, - const char *cmdName, Tcl_CmdInfo *infoPtr); +/* Slot 159 is reserved */ /* 160 */ EXTERN CONST84_RETURN char * Tcl_GetCommandName(Tcl_Interp *interp, Tcl_Command command); @@ -544,9 +541,7 @@ EXTERN CONST84_RETURN char * Tcl_GetVar2(Tcl_Interp *interp, /* 177 */ EXTERN int Tcl_GlobalEval(Tcl_Interp *interp, const char *command); -/* 178 */ -EXTERN int Tcl_GlobalEvalObj(Tcl_Interp *interp, - Tcl_Obj *objPtr); +/* Slot 178 is reserved */ /* 179 */ EXTERN int Tcl_HideCommand(Tcl_Interp *interp, const char *cmdName, @@ -671,10 +666,7 @@ EXTERN void Tcl_SetChannelBufferSize(Tcl_Channel chan, int sz); EXTERN int Tcl_SetChannelOption(Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, const char *newValue); -/* 226 */ -EXTERN int Tcl_SetCommandInfo(Tcl_Interp *interp, - const char *cmdName, - const Tcl_CmdInfo *infoPtr); +/* Slot 226 is reserved */ /* 227 */ EXTERN void Tcl_SetErrno(int err); /* 228 */ @@ -1389,12 +1381,8 @@ EXTERN Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp, int level, int flags, Tcl_CmdObjTraceProc *objProc, ClientData clientData, Tcl_CmdObjTraceDeleteProc *delProc); -/* 484 */ -EXTERN int Tcl_GetCommandInfoFromToken(Tcl_Command token, - Tcl_CmdInfo *infoPtr); -/* 485 */ -EXTERN int Tcl_SetCommandInfoFromToken(Tcl_Command token, - const Tcl_CmdInfo *infoPtr); +/* Slot 484 is reserved */ +/* Slot 485 is reserved */ /* 486 */ EXTERN Tcl_Obj * Tcl_DbNewWideIntObj(Tcl_WideInt wideValue, const char *file, int line); @@ -1676,12 +1664,7 @@ EXTERN int Tcl_Canceled(Tcl_Interp *interp, int flags); EXTERN int Tcl_CreatePipe(Tcl_Interp *interp, Tcl_Channel *rchan, Tcl_Channel *wchan, int flags); -/* 583 */ -EXTERN Tcl_Command Tcl_NRCreateCommand(Tcl_Interp *interp, - const char *cmdName, Tcl_ObjCmdProc *proc, - Tcl_ObjCmdProc *nreProc, - ClientData clientData, - Tcl_CmdDeleteProc *deleteProc); +/* Slot 583 is reserved */ /* 584 */ EXTERN int Tcl_NREvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); @@ -1794,9 +1777,7 @@ EXTERN int Tcl_CloseEx(Tcl_Interp *interp, Tcl_Channel chan, /* 625 */ EXTERN int Tcl_NRExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj *resultPtr); -/* 626 */ -EXTERN int Tcl_NRSubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - int flags); +/* Slot 626 is reserved */ /* 627 */ EXTERN int Tcl_LoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *const symv[], int flags, @@ -1969,7 +1950,7 @@ typedef struct TclStubs { CONST84_RETURN char * (*tcl_ErrnoMsg) (int err); /* 128 */ int (*tcl_Eval) (Tcl_Interp *interp, const char *script); /* 129 */ int (*tcl_EvalFile) (Tcl_Interp *interp, const char *fileName); /* 130 */ - int (*tcl_EvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 131 */ + void (*reserved131)(void); void (*tcl_EventuallyFree) (ClientData clientData, Tcl_FreeProc *freeProc); /* 132 */ void (*tcl_Exit) (int status); /* 133 */ int (*tcl_ExposeCommand) (Tcl_Interp *interp, const char *hiddenCmdToken, const char *cmdName); /* 134 */ @@ -1997,7 +1978,7 @@ typedef struct TclStubs { CONST84_RETURN char * (*tcl_GetChannelName) (Tcl_Channel chan); /* 156 */ int (*tcl_GetChannelOption) (Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, Tcl_DString *dsPtr); /* 157 */ CONST86 Tcl_ChannelType * (*tcl_GetChannelType) (Tcl_Channel chan); /* 158 */ - int (*tcl_GetCommandInfo) (Tcl_Interp *interp, const char *cmdName, Tcl_CmdInfo *infoPtr); /* 159 */ + void (*reserved159)(void); CONST84_RETURN char * (*tcl_GetCommandName) (Tcl_Interp *interp, Tcl_Command command); /* 160 */ int (*tcl_GetErrno) (void); /* 161 */ CONST84_RETURN char * (*tcl_GetHostName) (void); /* 162 */ @@ -2024,7 +2005,7 @@ typedef struct TclStubs { CONST84_RETURN char * (*tcl_GetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 175 */ CONST84_RETURN char * (*tcl_GetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 176 */ int (*tcl_GlobalEval) (Tcl_Interp *interp, const char *command); /* 177 */ - int (*tcl_GlobalEvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 178 */ + void (*reserved178)(void); int (*tcl_HideCommand) (Tcl_Interp *interp, const char *cmdName, const char *hiddenCmdToken); /* 179 */ int (*tcl_Init) (Tcl_Interp *interp); /* 180 */ void (*tcl_InitHashTable) (Tcl_HashTable *tablePtr, int keyType); /* 181 */ @@ -2072,7 +2053,7 @@ typedef struct TclStubs { void (*tcl_SetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc *proc, ClientData clientData); /* 223 */ void (*tcl_SetChannelBufferSize) (Tcl_Channel chan, int sz); /* 224 */ int (*tcl_SetChannelOption) (Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, const char *newValue); /* 225 */ - int (*tcl_SetCommandInfo) (Tcl_Interp *interp, const char *cmdName, const Tcl_CmdInfo *infoPtr); /* 226 */ + void (*reserved226)(void); void (*tcl_SetErrno) (int err); /* 227 */ void (*tcl_SetErrorCode) (Tcl_Interp *interp, ...); /* 228 */ void (*tcl_SetMaxBlockTime) (const Tcl_Time *timePtr); /* 229 */ @@ -2330,8 +2311,8 @@ typedef struct TclStubs { int (*tcl_EvalTokensStandard) (Tcl_Interp *interp, Tcl_Token *tokenPtr, int count); /* 481 */ void (*tcl_GetTime) (Tcl_Time *timeBuf); /* 482 */ Tcl_Trace (*tcl_CreateObjTrace) (Tcl_Interp *interp, int level, int flags, Tcl_CmdObjTraceProc *objProc, ClientData clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 483 */ - int (*tcl_GetCommandInfoFromToken) (Tcl_Command token, Tcl_CmdInfo *infoPtr); /* 484 */ - int (*tcl_SetCommandInfoFromToken) (Tcl_Command token, const Tcl_CmdInfo *infoPtr); /* 485 */ + void (*reserved484)(void); + void (*reserved485)(void); Tcl_Obj * (*tcl_DbNewWideIntObj) (Tcl_WideInt wideValue, const char *file, int line); /* 486 */ int (*tcl_GetWideIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_WideInt *widePtr); /* 487 */ Tcl_Obj * (*tcl_NewWideIntObj) (Tcl_WideInt wideValue); /* 488 */ @@ -2429,7 +2410,7 @@ typedef struct TclStubs { int (*tcl_CancelEval) (Tcl_Interp *interp, Tcl_Obj *resultObjPtr, ClientData clientData, int flags); /* 580 */ int (*tcl_Canceled) (Tcl_Interp *interp, int flags); /* 581 */ int (*tcl_CreatePipe) (Tcl_Interp *interp, Tcl_Channel *rchan, Tcl_Channel *wchan, int flags); /* 582 */ - Tcl_Command (*tcl_NRCreateCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, Tcl_ObjCmdProc *nreProc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 583 */ + void (*reserved583)(void); int (*tcl_NREvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 584 */ int (*tcl_NREvalObjv) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* 585 */ int (*tcl_NRCmdSwap) (Tcl_Interp *interp, Tcl_Command cmd, int objc, Tcl_Obj *const objv[], int flags); /* 586 */ @@ -2472,7 +2453,7 @@ typedef struct TclStubs { Tcl_Obj * (*tcl_GetStartupScript) (const char **encodingPtr); /* 623 */ int (*tcl_CloseEx) (Tcl_Interp *interp, Tcl_Channel chan, int flags); /* 624 */ int (*tcl_NRExprObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj *resultPtr); /* 625 */ - int (*tcl_NRSubstObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 626 */ + void (*reserved626)(void); int (*tcl_LoadFile) (Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *const symv[], int flags, void *procPtrs, Tcl_LoadHandle *handlePtr); /* 627 */ void * (*tcl_FindSymbol) (Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol); /* 628 */ int (*tcl_FSUnloadFile) (Tcl_Interp *interp, Tcl_LoadHandle handlePtr); /* 629 */ @@ -2767,8 +2748,7 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_Eval) /* 129 */ #define Tcl_EvalFile \ (tclStubsPtr->tcl_EvalFile) /* 130 */ -#define Tcl_EvalObj \ - (tclStubsPtr->tcl_EvalObj) /* 131 */ +/* Slot 131 is reserved */ #define Tcl_EventuallyFree \ (tclStubsPtr->tcl_EventuallyFree) /* 132 */ #define Tcl_Exit \ @@ -2823,8 +2803,7 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_GetChannelOption) /* 157 */ #define Tcl_GetChannelType \ (tclStubsPtr->tcl_GetChannelType) /* 158 */ -#define Tcl_GetCommandInfo \ - (tclStubsPtr->tcl_GetCommandInfo) /* 159 */ +/* Slot 159 is reserved */ #define Tcl_GetCommandName \ (tclStubsPtr->tcl_GetCommandName) /* 160 */ #define Tcl_GetErrno \ @@ -2867,8 +2846,7 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_GetVar2) /* 176 */ #define Tcl_GlobalEval \ (tclStubsPtr->tcl_GlobalEval) /* 177 */ -#define Tcl_GlobalEvalObj \ - (tclStubsPtr->tcl_GlobalEvalObj) /* 178 */ +/* Slot 178 is reserved */ #define Tcl_HideCommand \ (tclStubsPtr->tcl_HideCommand) /* 179 */ #define Tcl_Init \ @@ -2962,8 +2940,7 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_SetChannelBufferSize) /* 224 */ #define Tcl_SetChannelOption \ (tclStubsPtr->tcl_SetChannelOption) /* 225 */ -#define Tcl_SetCommandInfo \ - (tclStubsPtr->tcl_SetCommandInfo) /* 226 */ +/* Slot 226 is reserved */ #define Tcl_SetErrno \ (tclStubsPtr->tcl_SetErrno) /* 227 */ #define Tcl_SetErrorCode \ @@ -3477,10 +3454,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_GetTime) /* 482 */ #define Tcl_CreateObjTrace \ (tclStubsPtr->tcl_CreateObjTrace) /* 483 */ -#define Tcl_GetCommandInfoFromToken \ - (tclStubsPtr->tcl_GetCommandInfoFromToken) /* 484 */ -#define Tcl_SetCommandInfoFromToken \ - (tclStubsPtr->tcl_SetCommandInfoFromToken) /* 485 */ +/* Slot 484 is reserved */ +/* Slot 485 is reserved */ #define Tcl_DbNewWideIntObj \ (tclStubsPtr->tcl_DbNewWideIntObj) /* 486 */ #define Tcl_GetWideIntFromObj \ @@ -3675,8 +3650,7 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_Canceled) /* 581 */ #define Tcl_CreatePipe \ (tclStubsPtr->tcl_CreatePipe) /* 582 */ -#define Tcl_NRCreateCommand \ - (tclStubsPtr->tcl_NRCreateCommand) /* 583 */ +/* Slot 583 is reserved */ #define Tcl_NREvalObj \ (tclStubsPtr->tcl_NREvalObj) /* 584 */ #define Tcl_NREvalObjv \ @@ -3761,8 +3735,7 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_CloseEx) /* 624 */ #define Tcl_NRExprObj \ (tclStubsPtr->tcl_NRExprObj) /* 625 */ -#define Tcl_NRSubstObj \ - (tclStubsPtr->tcl_NRSubstObj) /* 626 */ +/* Slot 626 is reserved */ #define Tcl_LoadFile \ (tclStubsPtr->tcl_LoadFile) /* 627 */ #define Tcl_FindSymbol \ diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 85d2d27..019521c 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -88,27 +88,27 @@ static int DictMapLoopCallback(ClientData data[], */ static const EnsembleImplMap implementationMap[] = { - {"append", DictAppendCmd, TclCompileDictAppendCmd, NULL, NULL, 0 }, - {"create", DictCreateCmd, TclCompileDictCreateCmd, NULL, NULL, 0 }, - {"exists", DictExistsCmd, TclCompileDictExistsCmd, NULL, NULL, 0 }, - {"filter", DictFilterCmd, NULL, NULL, NULL, 0 }, - {"for", NULL, TclCompileDictForCmd, DictForNRCmd, NULL, 0 }, - {"get", DictGetCmd, TclCompileDictGetCmd, NULL, NULL, 0 }, - {"incr", DictIncrCmd, TclCompileDictIncrCmd, NULL, NULL, 0 }, - {"info", DictInfoCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 }, - {"keys", DictKeysCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 }, - {"lappend", DictLappendCmd, TclCompileDictLappendCmd, NULL, NULL, 0 }, - {"map", NULL, TclCompileDictMapCmd, DictMapNRCmd, NULL, 0 }, - {"merge", DictMergeCmd, TclCompileDictMergeCmd, NULL, NULL, 0 }, - {"remove", DictRemoveCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0 }, - {"replace", DictReplaceCmd, NULL, NULL, NULL, 0 }, - {"set", DictSetCmd, TclCompileDictSetCmd, NULL, NULL, 0 }, - {"size", DictSizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 }, - {"unset", DictUnsetCmd, TclCompileDictUnsetCmd, NULL, NULL, 0 }, - {"update", DictUpdateCmd, TclCompileDictUpdateCmd, NULL, NULL, 0 }, - {"values", DictValuesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 }, - {"with", DictWithCmd, TclCompileDictWithCmd, NULL, NULL, 0 }, - {NULL, NULL, NULL, NULL, NULL, 0} + {"append", DictAppendCmd, NULL, NULL, 0 }, + {"create", DictCreateCmd, NULL, NULL, 0 }, + {"exists", DictExistsCmd, NULL, NULL, 0 }, + {"filter", DictFilterCmd, NULL, NULL, 0 }, + {"for", DictForNRCmd, NULL, NULL, 0 }, + {"get", DictGetCmd, NULL, NULL, 0 }, + {"incr", DictIncrCmd, NULL, NULL, 0 }, + {"info", DictInfoCmd, NULL, NULL, 0 }, + {"keys", DictKeysCmd, NULL, NULL, 0 }, + {"lappend", DictLappendCmd, NULL, NULL, 0 }, + {"map", DictMapNRCmd, NULL, NULL, 0 }, + {"merge", DictMergeCmd, NULL, NULL, 0 }, + {"remove", DictRemoveCmd, NULL, NULL, 0 }, + {"replace", DictReplaceCmd, NULL, NULL, 0 }, + {"set", DictSetCmd, NULL, NULL, 0 }, + {"size", DictSizeCmd, NULL, NULL, 0 }, + {"unset", DictUnsetCmd, NULL, NULL, 0 }, + {"update", DictUpdateCmd, NULL, NULL, 0 }, + {"values", DictValuesCmd, NULL, NULL, 0 }, + {"with", DictWithCmd, NULL, NULL, 0 }, + {NULL, NULL, NULL, NULL, 0} }; /* @@ -2400,14 +2400,14 @@ DictForNRCmd( "must have exactly two variable names", -1)); return TCL_ERROR; } - searchPtr = TclStackAlloc(interp, sizeof(Tcl_DictSearch)); + searchPtr = ckalloc(sizeof(Tcl_DictSearch)); if (Tcl_DictObjFirst(interp, objv[2], searchPtr, &keyObj, &valueObj, &done) != TCL_OK) { - TclStackFree(interp, searchPtr); + ckfree(searchPtr); return TCL_ERROR; } if (done) { - TclStackFree(interp, searchPtr); + ckfree(searchPtr); return TCL_OK; } TclListObjGetElements(NULL, objv[1], &varc, &varv); @@ -2457,7 +2457,7 @@ DictForNRCmd( TclDecrRefCount(valueVarObj); TclDecrRefCount(scriptObj); Tcl_DictObjDone(searchPtr); - TclStackFree(interp, searchPtr); + ckfree(searchPtr); return TCL_ERROR; } @@ -2538,7 +2538,7 @@ DictForLoopCallback( TclDecrRefCount(valueVarObj); TclDecrRefCount(scriptObj); Tcl_DictObjDone(searchPtr); - TclStackFree(interp, searchPtr); + ckfree(searchPtr); return result; } @@ -2589,10 +2589,10 @@ DictMapNRCmd( "must have exactly two variable names", -1)); return TCL_ERROR; } - storagePtr = TclStackAlloc(interp, sizeof(DictMapStorage)); + storagePtr = ckalloc(sizeof(DictMapStorage)); if (Tcl_DictObjFirst(interp, objv[2], &storagePtr->search, &keyObj, &valueObj, &done) != TCL_OK) { - TclStackFree(interp, storagePtr); + ckfree(storagePtr); return TCL_ERROR; } if (done) { @@ -2602,7 +2602,7 @@ DictMapNRCmd( * an empty dictionary. */ - TclStackFree(interp, storagePtr); + ckfree(storagePtr); return TCL_OK; } TclNewObj(storagePtr->accumulatorObj); @@ -2657,7 +2657,7 @@ DictMapNRCmd( TclDecrRefCount(storagePtr->scriptObj); TclDecrRefCount(storagePtr->accumulatorObj); Tcl_DictObjDone(&storagePtr->search); - TclStackFree(interp, storagePtr); + ckfree(storagePtr); return TCL_ERROR; } @@ -2745,7 +2745,7 @@ DictMapLoopCallback( TclDecrRefCount(storagePtr->scriptObj); TclDecrRefCount(storagePtr->accumulatorObj); Tcl_DictObjDone(&storagePtr->search); - TclStackFree(interp, storagePtr); + ckfree(storagePtr); return result; } diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 64b8da0..a58851d 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -11,7 +11,6 @@ */ #include "tclInt.h" -#include "tclCompile.h" /* * Declarations for functions local to this file: @@ -23,8 +22,6 @@ static inline int EnsembleUnknownCallback(Tcl_Interp *interp, Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr); static int NsEnsembleImplementationCmd(ClientData clientData, Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); -static int NsEnsembleImplementationCmdNR(ClientData clientData, - Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static void BuildEnsembleConfig(EnsembleConfig *ensemblePtr); static int NsEnsembleStringOrder(const void *strPtr1, const void *strPtr2); @@ -35,15 +32,6 @@ static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr, static void FreeEnsembleCmdRep(Tcl_Obj *objPtr); static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static void StringOfEnsembleCmdRep(Tcl_Obj *objPtr); -static int CompileToCompiledCommand(Tcl_Interp *interp, - Tcl_Parse *parsePtr, int depth, Command *cmdPtr, - CompileEnv *envPtr); -static void CompileToInvokedCommand(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Tcl_Obj *replacements, - Command *cmdPtr, CompileEnv *envPtr); -static int CompileBasicNArgCommand(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - CompileEnv *envPtr); /* * The lists of subcommands and options for the [namespace ensemble] command. @@ -88,6 +76,8 @@ const Tcl_ObjType tclEnsembleCmdType = { NULL /* setFromAnyProc */ }; +#define isEnsemble(cmdPtr) ((cmdPtr)->deleteProc == DeleteEnsembleConfig) + static inline Tcl_Obj * NewNsObj( @@ -676,9 +666,8 @@ Tcl_CreateEnsemble( ensemblePtr->numParameters = 0; ensemblePtr->parameterList = NULL; ensemblePtr->unknownHandler = NULL; - ensemblePtr->token = Tcl_NRCreateCommand(interp, name, - NsEnsembleImplementationCmd, NsEnsembleImplementationCmdNR, - ensemblePtr, DeleteEnsembleConfig); + ensemblePtr->token = Tcl_CreateObjCommand(interp, name, + NsEnsembleImplementationCmd, ensemblePtr, DeleteEnsembleConfig); ensemblePtr->next = (EnsembleConfig *) nsPtr->ensembles; nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr; @@ -691,10 +680,6 @@ Tcl_CreateEnsemble( nsPtr->exportLookupEpoch++; - if (flags & ENSEMBLE_COMPILE) { - ((Command *) ensemblePtr->token)->compileProc = TclCompileEnsemble; - } - if (nameObj != NULL) { TclDecrRefCount(nameObj); } @@ -728,7 +713,7 @@ Tcl_SetEnsembleSubcommandList( EnsembleConfig *ensemblePtr; Tcl_Obj *oldList; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (!isEnsemble(cmdPtr)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); @@ -764,15 +749,6 @@ Tcl_SetEnsembleSubcommandList( ensemblePtr->nsPtr->exportLookupEpoch++; - /* - * Special hack to make compiling of [info exists] work when the - * dictionary is modified. - */ - - if (cmdPtr->compileProc != NULL) { - ((Interp *) interp)->compileEpoch++; - } - return TCL_OK; } @@ -804,7 +780,7 @@ Tcl_SetEnsembleParameterList( Tcl_Obj *oldList; int length; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (!isEnsemble(cmdPtr)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); @@ -841,15 +817,6 @@ Tcl_SetEnsembleParameterList( ensemblePtr->nsPtr->exportLookupEpoch++; - /* - * Special hack to make compiling of [info exists] work when the - * dictionary is modified. - */ - - if (cmdPtr->compileProc != NULL) { - ((Interp *) interp)->compileEpoch++; - } - return TCL_OK; } @@ -880,7 +847,7 @@ Tcl_SetEnsembleMappingDict( EnsembleConfig *ensemblePtr; Tcl_Obj *oldDict; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (!isEnsemble(cmdPtr)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); @@ -940,15 +907,6 @@ Tcl_SetEnsembleMappingDict( ensemblePtr->nsPtr->exportLookupEpoch++; - /* - * Special hack to make compiling of [info exists] work when the - * dictionary is modified. - */ - - if (cmdPtr->compileProc != NULL) { - ((Interp *) interp)->compileEpoch++; - } - return TCL_OK; } @@ -979,7 +937,7 @@ Tcl_SetEnsembleUnknownHandler( EnsembleConfig *ensemblePtr; Tcl_Obj *oldList; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (!isEnsemble(cmdPtr)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); @@ -1043,9 +1001,8 @@ Tcl_SetEnsembleFlags( { Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; - int wasCompiled; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (!isEnsemble(cmdPtr)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); @@ -1053,7 +1010,6 @@ Tcl_SetEnsembleFlags( } ensemblePtr = cmdPtr->objClientData; - wasCompiled = ensemblePtr->flags & ENSEMBLE_COMPILE; /* * This API refuses to set the ENSEMBLE_DEAD flag... @@ -1071,24 +1027,6 @@ Tcl_SetEnsembleFlags( ensemblePtr->nsPtr->exportLookupEpoch++; - /* - * If the ENSEMBLE_COMPILE flag status was changed, install or remove the - * compiler function and bump the interpreter's compilation epoch so that - * bytecode gets regenerated. - */ - - if (flags & ENSEMBLE_COMPILE) { - if (!wasCompiled) { - ((Command*) ensemblePtr->token)->compileProc = TclCompileEnsemble; - ((Interp *) interp)->compileEpoch++; - } - } else { - if (wasCompiled) { - ((Command *) ensemblePtr->token)->compileProc = NULL; - ((Interp *) interp)->compileEpoch++; - } - } - return TCL_OK; } @@ -1121,7 +1059,7 @@ Tcl_GetEnsembleSubcommandList( Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (!isEnsemble(cmdPtr)) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); @@ -1163,7 +1101,7 @@ Tcl_GetEnsembleParameterList( Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (!isEnsemble(cmdPtr)) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); @@ -1205,7 +1143,7 @@ Tcl_GetEnsembleMappingDict( Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (!isEnsemble(cmdPtr)) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); @@ -1246,7 +1184,7 @@ Tcl_GetEnsembleUnknownHandler( Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (!isEnsemble(cmdPtr)) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); @@ -1287,7 +1225,7 @@ Tcl_GetEnsembleFlags( Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (!isEnsemble(cmdPtr)) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); @@ -1328,7 +1266,7 @@ Tcl_GetEnsembleNamespace( Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (!isEnsemble(cmdPtr)) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); @@ -1378,7 +1316,7 @@ Tcl_FindEnsemble( return NULL; } - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (!isEnsemble(cmdPtr)) { /* * Reuse existing infrastructure for following import link chains * rather than duplicating it. @@ -1386,7 +1324,7 @@ Tcl_FindEnsemble( cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); - if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd){ + if (cmdPtr == NULL || !isEnsemble(cmdPtr)){ if (flags & TCL_LEAVE_ERR_MSG) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" is not an ensemble command", @@ -1424,11 +1362,11 @@ Tcl_IsEnsemble( { Command *cmdPtr = (Command *) token; - if (cmdPtr->objProc == NsEnsembleImplementationCmd) { + if (isEnsemble(cmdPtr)) { return 1; } cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); - if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr == NULL || !isEnsemble(cmdPtr)) { return 0; } return 1; @@ -1536,7 +1474,8 @@ TclMakeEnsemble( if (ensemble != NULL) { Tcl_Obj *mapDict, *fromObj, *toObj; Command *cmdPtr; - + Tcl_ObjCmdProc *objProc; + TclDStringAppendLiteral(&buf, "::"); TclNewObj(mapDict); for (i=0 ; map[i].name != NULL ; i++) { @@ -1546,7 +1485,7 @@ TclMakeEnsemble( Tcl_AppendToObj(toObj, map[i].name, -1); Tcl_DictObjPut(NULL, mapDict, fromObj, toObj); - if (map[i].proc || map[i].nreProc) { + if (map[i].proc) { /* * If the command is unsafe, hide it when we're in a safe * interpreter. The code to do this is really hokey! It also @@ -1555,10 +1494,11 @@ TclMakeEnsemble( * Tcl_IsSafe check fails. */ + objProc = map[i].proc; if (map[i].unsafe && Tcl_IsSafe(interp)) { cmdPtr = (Command *) - Tcl_NRCreateCommand(interp, "___tmp", map[i].proc, - map[i].nreProc, map[i].clientData, NULL); + Tcl_CreateObjCommand(interp, "___tmp", objProc, + map[i].clientData, NULL); Tcl_DStringSetLength(&hiddenBuf, hiddenLen); if (Tcl_HideCommand(interp, "___tmp", Tcl_DStringAppend(&hiddenBuf, map[i].name, -1))) { @@ -1570,22 +1510,13 @@ TclMakeEnsemble( */ cmdPtr = (Command *) - Tcl_NRCreateCommand(interp, TclGetString(toObj), - map[i].proc, map[i].nreProc, map[i].clientData, - NULL); + Tcl_CreateObjCommand(interp, TclGetString(toObj), + objProc, map[i].clientData, NULL); } cmdPtr->compileProc = map[i].compileProc; } } Tcl_SetEnsembleMappingDict(interp, ensemble, mapDict); - - /* - * Switch on compilation always for core ensembles now that we can do - * nice bytecode things with them. - */ - - Tcl_SetEnsembleFlags(interp, ensemble, - ensembleFlags | ENSEMBLE_COMPILE); } Tcl_DStringFree(&buf); @@ -1625,17 +1556,6 @@ NsEnsembleImplementationCmd( int objc, Tcl_Obj *const objv[]) { - return Tcl_NRCallObjProc(interp, NsEnsembleImplementationCmdNR, - clientData, objc, objv); -} - -static int -NsEnsembleImplementationCmdNR( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ EnsembleConfig *ensemblePtr = clientData; /* The ensemble itself. */ Tcl_Obj *prefixObj; /* An object containing the prefix words of @@ -2714,791 +2634,6 @@ StringOfEnsembleCmdRep( } /* - *---------------------------------------------------------------------- - * - * TclCompileEnsemble -- - * - * Procedure called to compile an ensemble command. Note that most - * ensembles are not compiled, since modifying a compiled ensemble causes - * a invalidation of all existing bytecode (expensive!) which is not - * normally warranted. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the subcommands of the - * ensemble at runtime if a compile-time mapping is possible. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileEnsemble( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems; - Tcl_Obj *replaced = Tcl_NewObj(), *replacement; - Tcl_Command ensemble = (Tcl_Command) cmdPtr; - Command *oldCmdPtr = cmdPtr, *newCmdPtr; - int len, result, flags = 0, i, depth = 1, invokeAnyway = 0; - int ourResult = TCL_ERROR; - unsigned numBytes; - const char *word; - - Tcl_IncrRefCount(replaced); - - /* - * This is where we return to if we are parsing multiple nested compiled - * ensembles. [info object] is such a beast. - */ - - checkNextWord: - if (parsePtr->numWords < depth + 1) { - goto failed; - } - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - /* - * Too hard. - */ - - goto failed; - } - - word = tokenPtr[1].start; - numBytes = tokenPtr[1].size; - - /* - * There's a sporting chance we'll be able to compile this. But now we - * must check properly. To do that, check that we're compiling an ensemble - * that has a compilable command as its appropriate subcommand. - */ - - if (Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj) != TCL_OK - || mapObj == NULL) { - /* - * Either not an ensemble or a mapping isn't installed. Crud. Too hard - * to proceed. - */ - - goto failed; - } - - /* - * Also refuse to compile anything that uses a formal parameter list for - * now, on the grounds that it is too complex. - */ - - if (Tcl_GetEnsembleParameterList(NULL, ensemble, &listObj) != TCL_OK - || listObj != NULL) { - /* - * Figuring out how to compile this has become too much. Bail out. - */ - - goto failed; - } - - /* - * Next, get the flags. We need them on several code paths so that we can - * know whether we're to do prefix matching. - */ - - (void) Tcl_GetEnsembleFlags(NULL, ensemble, &flags); - - /* - * Check to see if there's also a subcommand list; must check to see if - * the subcommand we are calling is in that list if it exists, since that - * list filters the entries in the map. - */ - - (void) Tcl_GetEnsembleSubcommandList(NULL, ensemble, &listObj); - if (listObj != NULL) { - int sclen; - const char *str; - Tcl_Obj *matchObj = NULL; - - if (Tcl_ListObjGetElements(NULL, listObj, &len, &elems) != TCL_OK) { - goto failed; - } - for (i=0 ; i<len ; i++) { - str = Tcl_GetStringFromObj(elems[i], &sclen); - if ((sclen == (int) numBytes) && !memcmp(word, str, numBytes)) { - /* - * Exact match! Excellent! - */ - - result = Tcl_DictObjGet(NULL, mapObj,elems[i], &targetCmdObj); - if (result != TCL_OK || targetCmdObj == NULL) { - goto failed; - } - replacement = elems[i]; - goto doneMapLookup; - } - - /* - * Check to see if we've got a prefix match. A single prefix match - * is fine, and allows us to refine our dictionary lookup, but - * multiple prefix matches is a Bad Thing and will prevent us from - * making progress. Note that we cannot do the lookup immediately - * in the prefix case; might be another entry later in the list - * that causes things to fail. - */ - - if ((flags & TCL_ENSEMBLE_PREFIX) - && strncmp(word, str, numBytes) == 0) { - if (matchObj != NULL) { - goto failed; - } - matchObj = elems[i]; - } - } - if (matchObj == NULL) { - goto failed; - } - result = Tcl_DictObjGet(NULL, mapObj, matchObj, &targetCmdObj); - if (result != TCL_OK || targetCmdObj == NULL) { - goto failed; - } - replacement = matchObj; - } else { - Tcl_DictSearch s; - int done, matched; - Tcl_Obj *tmpObj; - - /* - * No map, so check the dictionary directly. - */ - - TclNewStringObj(subcmdObj, word, (int) numBytes); - result = Tcl_DictObjGet(NULL, mapObj, subcmdObj, &targetCmdObj); - if (result == TCL_OK && targetCmdObj != NULL) { - /* - * Got it. Skip the fiddling around with prefixes. - */ - - replacement = subcmdObj; - goto doneMapLookup; - } - TclDecrRefCount(subcmdObj); - - /* - * We've not literally got a valid subcommand. But maybe we have a - * prefix. Check if prefix matches are allowed. - */ - - if (!(flags & TCL_ENSEMBLE_PREFIX)) { - goto failed; - } - - /* - * Iterate over the keys in the dictionary, checking to see if we're a - * prefix. - */ - - Tcl_DictObjFirst(NULL, mapObj, &s, &subcmdObj, &tmpObj, &done); - matched = 0; - replacement = NULL; /* Silence, fool compiler! */ - while (!done) { - if (strncmp(TclGetString(subcmdObj), word, numBytes) == 0) { - if (matched++) { - /* - * Must have matched twice! Not unique, so no point - * looking further. - */ - - break; - } - replacement = subcmdObj; - targetCmdObj = tmpObj; - } - Tcl_DictObjNext(&s, &subcmdObj, &tmpObj, &done); - } - Tcl_DictObjDone(&s); - - /* - * If we have anything other than a single match, we've failed the - * unique prefix check. - */ - - if (matched != 1) { - invokeAnyway = 1; - goto failed; - } - } - - /* - * OK, we definitely map to something. But what? - * - * The command we map to is the first word out of the map element. Note - * that we also reject dealing with multi-element rewrites if we are in a - * safe interpreter, as there is otherwise a (highly gnarly!) way to make - * Tcl crash open to exploit. - */ - - doneMapLookup: - Tcl_ListObjAppendElement(NULL, replaced, replacement); - if (Tcl_ListObjGetElements(NULL, targetCmdObj, &len, &elems) != TCL_OK) { - goto failed; - } else if (len != 1) { - /* - * Note that at this point we know we can't issue any special - * instruction sequence as the mapping isn't one that we support at - * the compiled level. - */ - - goto cleanup; - } - targetCmdObj = elems[0]; - - oldCmdPtr = cmdPtr; - Tcl_IncrRefCount(targetCmdObj); - newCmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj); - TclDecrRefCount(targetCmdObj); - if (newCmdPtr == NULL || Tcl_IsSafe(interp) - || newCmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION - || newCmdPtr->flags & CMD_HAS_EXEC_TRACES - || ((Interp *)interp)->flags & DONT_COMPILE_CMDS_INLINE) { - /* - * Maps to an undefined command or a command without a compiler. - * Cannot compile. - */ - - goto cleanup; - } - cmdPtr = newCmdPtr; - depth++; - - /* - * See whether we have a nested ensemble. If we do, we can go round the - * mulberry bush again, consuming the next word. - */ - - if (cmdPtr->compileProc == TclCompileEnsemble) { - tokenPtr = TokenAfter(tokenPtr); - ensemble = (Tcl_Command) cmdPtr; - goto checkNextWord; - } - - /* - * Now we've done the mapping process, can now actually try to compile. - * If there is a subcommand compiler and that successfully produces code, - * we'll use that. Otherwise, we fall back to generating opcodes to do the - * invoke at runtime. - */ - - invokeAnyway = 1; - if (CompileToCompiledCommand(interp, parsePtr, depth, cmdPtr, - envPtr) == TCL_OK) { - ourResult = TCL_OK; - goto cleanup; - } - - /* - * Failed to do a full compile for some reason. Try to do a direct invoke - * instead of going through the ensemble lookup process again. - */ - - failed: - if (depth < 250) { - if (depth > 1) { - if (!invokeAnyway) { - cmdPtr = oldCmdPtr; - depth--; - } - (void) Tcl_ListObjReplace(NULL, replaced, depth, 2, 0, NULL); - } - CompileToInvokedCommand(interp, parsePtr, replaced, cmdPtr, envPtr); - ourResult = TCL_OK; - } - - /* - * Release the memory we allocated. If we've got here, we've either done - * something useful or we're in a case that we can't compile at all and - * we're just giving up. - */ - - cleanup: - Tcl_DecrRefCount(replaced); - return ourResult; -} - -/* - * How to compile a subcommand using its own command compiler. To do that, we - * have to perform some trickery to rewrite the arguments, as compilers *must* - * have parse tokens that refer to addresses in the original script. - */ - -static int -CompileToCompiledCommand( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - int depth, - Command *cmdPtr, - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Parse synthetic; - Tcl_Token *tokenPtr; - int result, i; - - if (cmdPtr->compileProc == NULL) { - return TCL_ERROR; - } - - TclParseInit(interp, NULL, 0, &synthetic); - synthetic.numWords = parsePtr->numWords - depth + 1; - TclGrowParseTokenArray(&synthetic, 2); - synthetic.numTokens = 2; - - /* - * Now we have the space to work in, install something rewritten. The - * first word will "officially" be the bytes of the structured ensemble - * name. That's technically wrong, but nobody will care; we just need - * *something* here... - */ - - synthetic.tokenPtr[0].type = TCL_TOKEN_SIMPLE_WORD; - synthetic.tokenPtr[0].start = parsePtr->tokenPtr[0].start; - synthetic.tokenPtr[0].numComponents = 1; - synthetic.tokenPtr[1].type = TCL_TOKEN_TEXT; - synthetic.tokenPtr[1].start = parsePtr->tokenPtr[0].start; - synthetic.tokenPtr[1].numComponents = 0; - for (i=0,tokenPtr=parsePtr->tokenPtr ; i<depth ; i++) { - int sclen = (tokenPtr->start - synthetic.tokenPtr[0].start) - + tokenPtr->size; - - synthetic.tokenPtr[0].size = sclen; - synthetic.tokenPtr[1].size = sclen; - tokenPtr = TokenAfter(tokenPtr); - } - - /* - * Copy over the real argument tokens. - */ - - for (i=1; i<synthetic.numWords; i++) { - int toCopy; - - toCopy = tokenPtr->numComponents + 1; - TclGrowParseTokenArray(&synthetic, toCopy); - memcpy(synthetic.tokenPtr + synthetic.numTokens, tokenPtr, - sizeof(Tcl_Token) * toCopy); - synthetic.numTokens += toCopy; - tokenPtr = TokenAfter(tokenPtr); - } - - /* - * Hand off compilation to the subcommand compiler. At last! - */ - - result = cmdPtr->compileProc(interp, &synthetic, cmdPtr, envPtr); - - /* - * Clean up if necessary. - */ - - Tcl_FreeParse(&synthetic); - return result; -} - -/* - * How to compile a subcommand to a _replacing_ invoke of its implementation - * command. - */ - -static void -CompileToInvokedCommand( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Tcl_Obj *replacements, - Command *cmdPtr, - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokPtr; - Tcl_Obj *objPtr, **words; - char *bytes; - int length, i, numWords, cmdLit; - - /* - * Push the words of the command. Take care; the command words may be - * scripts that have backslashes in them, and [info frame 0] can see the - * difference. Hence the call to TclContinuationsEnterDerived... - */ - - Tcl_ListObjGetElements(NULL, replacements, &numWords, &words); - for (i=0,tokPtr=parsePtr->tokenPtr ; i<parsePtr->numWords ; i++) { - if (i > 0 && i < numWords+1) { - bytes = Tcl_GetStringFromObj(words[i-1], &length); - PushLiteral(envPtr, bytes, length); - } else if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) { - int literal = TclRegisterNewLiteral(envPtr, - tokPtr[1].start, tokPtr[1].size); - - TclEmitPush(literal, envPtr); - } else { - CompileTokens(envPtr, tokPtr, interp); - } - tokPtr = TokenAfter(tokPtr); - } - - /* - * Push the name of the command we're actually dispatching to as part of - * the implementation. - */ - - objPtr = Tcl_NewObj(); - Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); - bytes = Tcl_GetStringFromObj(objPtr, &length); - cmdLit = TclRegisterNewCmdLiteral(envPtr, bytes, length); - TclSetCmdNameObj(interp, envPtr->literalArrayPtr[cmdLit].objPtr, cmdPtr); - TclEmitPush(cmdLit, envPtr); - TclDecrRefCount(objPtr); - - /* - * Do the replacing dispatch. - */ - - TclEmitInstInt4(INST_INVOKE_REPLACE, parsePtr->numWords, envPtr); - TclEmitInt1(numWords+1, envPtr); - TclAdjustStackDepth(-1, envPtr); /* Correction to stack depth calcs. */ -} - -/* - * Helpers that do issuing of instructions for commands that "don't have - * compilers" (well, they do; these). They all work by just generating base - * code to invoke the command; they're intended for ensemble subcommands so - * that the costs of INST_INVOKE_REPLACE can be avoided where we can work out - * that they're not needed. - * - * Note that these are NOT suitable for commands where there's an argument - * that is a script, as an [info level] or [info frame] in the inner context - * can see the difference. - */ - -static int -CompileBasicNArgCommand( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr; - Tcl_Obj *objPtr; - char *bytes; - int length, i, literal; - - /* - * Push the name of the command we're actually dispatching to as part of - * the implementation. - */ - - objPtr = Tcl_NewObj(); - Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); - bytes = Tcl_GetStringFromObj(objPtr, &length); - literal = TclRegisterNewCmdLiteral(envPtr, bytes, length); - TclSetCmdNameObj(interp, envPtr->literalArrayPtr[literal].objPtr, cmdPtr); - TclEmitPush(literal, envPtr); - TclDecrRefCount(objPtr); - - /* - * Push the words of the command. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - for (i=1 ; i<parsePtr->numWords ; i++) { - if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - PushLiteral(envPtr, tokenPtr[1].start, tokenPtr[1].size); - } else { - CompileTokens(envPtr, tokenPtr, interp); - } - tokenPtr = TokenAfter(tokenPtr); - } - - /* - * Do the standard dispatch. - */ - - if (i <= 255) { - TclEmitInstInt1(INST_INVOKE_STK1, i, envPtr); - } else { - TclEmitInstInt4(INST_INVOKE_STK4, i, envPtr); - } - return TCL_OK; -} - -int -TclCompileBasic0ArgCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - /* - * Verify that the number of arguments is correct; that's the only case - * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, - * which is the only code that sees the shenanigans of ensemble dispatch. - */ - - if (parsePtr->numWords != 1) { - return TCL_ERROR; - } - - return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); -} - -int -TclCompileBasic1ArgCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - /* - * Verify that the number of arguments is correct; that's the only case - * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, - * which is the only code that sees the shenanigans of ensemble dispatch. - */ - - if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - - return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); -} - -int -TclCompileBasic2ArgCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - /* - * Verify that the number of arguments is correct; that's the only case - * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, - * which is the only code that sees the shenanigans of ensemble dispatch. - */ - - if (parsePtr->numWords != 3) { - return TCL_ERROR; - } - - return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); -} - -int -TclCompileBasic3ArgCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - /* - * Verify that the number of arguments is correct; that's the only case - * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, - * which is the only code that sees the shenanigans of ensemble dispatch. - */ - - if (parsePtr->numWords != 4) { - return TCL_ERROR; - } - - return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); -} - -int -TclCompileBasic0Or1ArgCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - /* - * Verify that the number of arguments is correct; that's the only case - * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, - * which is the only code that sees the shenanigans of ensemble dispatch. - */ - - if (parsePtr->numWords != 1 && parsePtr->numWords != 2) { - return TCL_ERROR; - } - - return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); -} - -int -TclCompileBasic1Or2ArgCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - /* - * Verify that the number of arguments is correct; that's the only case - * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, - * which is the only code that sees the shenanigans of ensemble dispatch. - */ - - if (parsePtr->numWords != 2 && parsePtr->numWords != 3) { - return TCL_ERROR; - } - - return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); -} - -int -TclCompileBasic2Or3ArgCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - /* - * Verify that the number of arguments is correct; that's the only case - * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, - * which is the only code that sees the shenanigans of ensemble dispatch. - */ - - if (parsePtr->numWords != 3 && parsePtr->numWords != 4) { - return TCL_ERROR; - } - - return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); -} - -int -TclCompileBasic0To2ArgCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - /* - * Verify that the number of arguments is correct; that's the only case - * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, - * which is the only code that sees the shenanigans of ensemble dispatch. - */ - - if (parsePtr->numWords < 1 || parsePtr->numWords > 3) { - return TCL_ERROR; - } - - return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); -} - -int -TclCompileBasic1To3ArgCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - /* - * Verify that the number of arguments is correct; that's the only case - * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, - * which is the only code that sees the shenanigans of ensemble dispatch. - */ - - if (parsePtr->numWords < 2 || parsePtr->numWords > 4) { - return TCL_ERROR; - } - - return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); -} - -int -TclCompileBasicMin0ArgCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - /* - * Verify that the number of arguments is correct; that's the only case - * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, - * which is the only code that sees the shenanigans of ensemble dispatch. - */ - - if (parsePtr->numWords < 1) { - return TCL_ERROR; - } - - return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); -} - -int -TclCompileBasicMin1ArgCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - /* - * Verify that the number of arguments is correct; that's the only case - * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, - * which is the only code that sees the shenanigans of ensemble dispatch. - */ - - if (parsePtr->numWords < 2) { - return TCL_ERROR; - } - - return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); -} - -int -TclCompileBasicMin2ArgCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - /* - * Verify that the number of arguments is correct; that's the only case - * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, - * which is the only code that sees the shenanigans of ensemble dispatch. - */ - - if (parsePtr->numWords < 3) { - return TCL_ERROR; - } - - return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); -} - -/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 0b585b6..5f8fbee 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1043,11 +1043,9 @@ TclInitSubsystems(void) * implementation of self-initializing locks. */ + TclInitAlloc(); /* Process wide allocator init */ TclInitThreadStorage(); /* Creates master hash table for * thread local storage */ -#if USE_TCLALLOC - TclInitAlloc(); /* Process wide mutex init */ -#endif #ifdef TCL_MEM_DEBUG TclInitDbCkalloc(); /* Process wide mutex init */ #endif @@ -1221,14 +1219,6 @@ Tcl_Finalize(void) TclFinalizeSynchronization(); /* - * Close down the thread-specific object allocator. - */ - -#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) - TclFinalizeThreadAlloc(); -#endif - - /* * We defer unloading of packages until very late to avoid memory access * issues. Both exit callbacks and synchronization variables may be stored * in packages. @@ -1252,6 +1242,14 @@ Tcl_Finalize(void) TclFinalizeMemorySubsystem(); + /* + * Close down the thread-specific object allocator. + */ + + TclFinalizeAlloc(); + + + alreadyFinalized: TclFinalizeLock(); } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 5d8ca60..be85fb9 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -16,7 +16,7 @@ */ #include "tclInt.h" -#include "tclCompile.h" +#include "tclCompileInt.h" #include "tclOOInt.h" #include "tommath.h" #include <math.h> @@ -52,31 +52,17 @@ TCL_DECLARE_MUTEX(execMutex) static int cachedInExit = 0; -#ifdef TCL_COMPILE_DEBUG -/* - * Variable that controls whether execution tracing is enabled and, if so, - * what level of tracing is desired: - * 0: no execution tracing - * 1: trace invocations of Tcl procs only - * 2: trace invocations of all (not compiled away) commands - * 3: display each instruction executed - * This variable is linked to the Tcl variable "tcl_traceExec". - */ - -int tclTraceExec = 0; -#endif - /* * Mapping from expression instruction opcodes to strings; used for error * messages. Note that these entries must match the order and number of the - * expression opcodes (e.g., INST_LOR) in tclCompile.h. + * expression opcodes (e.g., INST_BITOR) in tclCompile.h. * * Does not include the string for INST_EXPON (and beyond), as that is * disjoint for backward-compatability reasons. */ static const char *const operatorStrings[] = { - "||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>", + "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>", "+", "-", "*", "/", "%", "+", "-", "~", "!", "BUILTIN FUNCTION", "FUNCTION", "", "", "", "", "", "", "", "", "eq", "ne" @@ -87,79 +73,10 @@ static const char *const operatorStrings[] = { * messages. */ -#ifdef TCL_COMPILE_DEBUG -static const char *const resultStrings[] = { - "TCL_OK", "TCL_ERROR", "TCL_RETURN", "TCL_BREAK", "TCL_CONTINUE" -}; -#endif - /* * These are used by evalstats to monitor object usage in Tcl. */ -#ifdef TCL_COMPILE_STATS -long tclObjsAlloced = 0; -long tclObjsFreed = 0; -long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; -#endif /* TCL_COMPILE_STATS */ - -/* - * Support pre-8.5 bytecodes unless specifically requested otherwise. - */ - -#ifndef TCL_SUPPORT_84_BYTECODE -#define TCL_SUPPORT_84_BYTECODE 1 -#endif - -#if TCL_SUPPORT_84_BYTECODE -/* - * We need to know the tclBuiltinFuncTable to support translation of pre-8.5 - * math functions to the namespace-based ::tcl::mathfunc::op in 8.5+. - */ - -typedef struct { - const char *name; /* Name of function. */ - int numArgs; /* Number of arguments for function. */ -} BuiltinFunc; - -/* - * Table describing the built-in math functions. Entries in this table are - * indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's - * operand byte. - */ - -static BuiltinFunc const tclBuiltinFuncTable[] = { - {"acos", 1}, - {"asin", 1}, - {"atan", 1}, - {"atan2", 2}, - {"ceil", 1}, - {"cos", 1}, - {"cosh", 1}, - {"exp", 1}, - {"floor", 1}, - {"fmod", 2}, - {"hypot", 2}, - {"log", 1}, - {"log10", 1}, - {"pow", 2}, - {"sin", 1}, - {"sinh", 1}, - {"sqrt", 1}, - {"tan", 1}, - {"tanh", 1}, - {"abs", 1}, - {"double", 1}, - {"int", 1}, - {"rand", 0}, - {"round", 1}, - {"srand", 1}, - {"wide", 1}, - {NULL, 0}, -}; - -#define LAST_BUILTIN_FUNC 25 -#endif /* * NR_TEBC @@ -167,14 +84,16 @@ static BuiltinFunc const tclBuiltinFuncTable[] = { * Minimal data required to fully reconstruct the execution state. */ -typedef struct TEBCdata { +typedef struct { ByteCode *codePtr; /* Constant until the BC returns */ /* -----------------------------------------*/ + Tcl_Obj **tosPtr; const unsigned char *pc; /* These fields are used on return TO this */ - ptrdiff_t *catchTop; /* this level: they record the state when a */ + unsigned long catchDepth; /* this level: they record the state when a */ int cleanup; /* new codePtr was received for NR */ Tcl_Obj *auxObjList; /* execution. */ int checkInterp; + unsigned int capacity; void *stack[1]; /* Start of the actual combined catch and obj * stacks; the struct will be expanded as * necessary */ @@ -182,7 +101,7 @@ typedef struct TEBCdata { #define TEBC_YIELD() \ do { \ - esPtr->tosPtr = tosPtr; \ + TD->tosPtr = tosPtr; \ TD->pc = pc; \ TD->cleanup = cleanup; \ Tcl_NRAddCallback(interp, TEBCresume, TD, INT2PTR(1), NULL, NULL); \ @@ -192,7 +111,7 @@ typedef struct TEBCdata { do { \ pc = TD->pc; \ cleanup = TD->cleanup; \ - tosPtr = esPtr->tosPtr; \ + tosPtr = TD->tosPtr; \ } while (0) #define PUSH_TAUX_OBJ(objPtr) \ @@ -252,18 +171,9 @@ VarHashCreateVar( /* Verify the stack depth, only when no expansion is in progress */ -#if TCL_COMPILE_DEBUG -#define CHECK_STACK() \ - ValidatePcAndStackTop(codePtr, pc, CURR_DEPTH, \ - /*checkStack*/ auxObjList == NULL) -#else -#define CHECK_STACK() -#endif - #define NEXT_INST_F(pcAdjustment, nCleanup, resultHandling) \ do { \ TCL_CT_ASSERT((nCleanup >= 0) && (nCleanup <= 2)); \ - CHECK_STACK(); \ if (nCleanup == 0) { \ if (resultHandling != 0) { \ if ((resultHandling) > 0) { \ @@ -293,7 +203,6 @@ VarHashCreateVar( } while (0) #define NEXT_INST_V(pcAdjustment, nCleanup, resultHandling) \ - CHECK_STACK(); \ do { \ pc += (pcAdjustment); \ cleanup = (nCleanup); \ @@ -308,20 +217,6 @@ VarHashCreateVar( } while (0) /* - * Macros used to cache often-referenced Tcl evaluation stack information - * in local variables. Note that a DECACHE_STACK_INFO()-CACHE_STACK_INFO() - * pair must surround any call inside TclNRExecuteByteCode (and a few other - * procedures that use this scheme) that could result in a recursive call - * to TclNRExecuteByteCode. - */ - -#define CACHE_STACK_INFO() \ - checkInterp = 1 - -#define DECACHE_STACK_INFO() \ - esPtr->tosPtr = tosPtr - -/* * Macros used to access items on the Tcl evaluation stack. PUSH_OBJECT * increments the object's ref count since it makes the stack have another * reference pointing to the object. However, POP_OBJECT does not decrement @@ -355,68 +250,6 @@ VarHashCreateVar( * only used in TRACE* calls to get a string from an object. */ -#ifdef TCL_COMPILE_DEBUG -# define TRACE(a) \ - while (traceInstructions) { \ - fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \ - (int) CURR_DEPTH, \ - (unsigned) (pc - codePtr->codeStart), \ - GetOpcodeName(pc)); \ - printf a; \ - break; \ - } -# define TRACE_APPEND(a) \ - while (traceInstructions) { \ - printf a; \ - break; \ - } -# define TRACE_WITH_OBJ(a, objPtr) \ - while (traceInstructions) { \ - fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \ - (int) CURR_DEPTH, \ - (unsigned) (pc - codePtr->codeStart), \ - GetOpcodeName(pc)); \ - printf a; \ - TclPrintObject(stdout, objPtr, 30); \ - fprintf(stdout, "\n"); \ - break; \ - } -# define O2S(objPtr) \ - (objPtr ? TclGetString(objPtr) : "") -#else /* !TCL_COMPILE_DEBUG */ -# define TRACE(a) -# define TRACE_APPEND(a) -# define TRACE_WITH_OBJ(a, objPtr) -# define O2S(objPtr) -#endif /* TCL_COMPILE_DEBUG */ - -/* - * DTrace instruction probe macros. - */ - -#define TCL_DTRACE_INST_NEXT() \ - do { \ - if (TCL_DTRACE_INST_DONE_ENABLED()) { \ - if (curInstName) { \ - TCL_DTRACE_INST_DONE(curInstName, (int) CURR_DEPTH, \ - tosPtr); \ - } \ - curInstName = tclInstructionTable[*pc].name; \ - if (TCL_DTRACE_INST_START_ENABLED()) { \ - TCL_DTRACE_INST_START(curInstName, (int) CURR_DEPTH, \ - tosPtr); \ - } \ - } else if (TCL_DTRACE_INST_START_ENABLED()) { \ - TCL_DTRACE_INST_START(tclInstructionTable[*pc].name, \ - (int) CURR_DEPTH, tosPtr); \ - } \ - } while (0) -#define TCL_DTRACE_INST_LAST() \ - do { \ - if (TCL_DTRACE_INST_DONE_ENABLED() && curInstName) { \ - TCL_DTRACE_INST_DONE(curInstName, (int) CURR_DEPTH, tosPtr);\ - } \ - } while (0) /* * Macro used in this file to save a function call for common uses of @@ -681,21 +514,7 @@ static const size_t Exp64ValueSize = sizeof(Exp64Value) / sizeof(Tcl_WideInt); * Declarations for local procedures to this file: */ -#ifdef TCL_COMPILE_STATS -static int EvalStatsCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -#endif /* TCL_COMPILE_STATS */ -#ifdef TCL_COMPILE_DEBUG -static const char * GetOpcodeName(const unsigned char *pc); -static void PrintByteCodeInfo(ByteCode *codePtr); -static const char * StringForResultCode(int result); -static void ValidatePcAndStackTop(ByteCode *codePtr, - const unsigned char *pc, int stackTop, - int checkStack); -#endif /* TCL_COMPILE_DEBUG */ static ByteCode * CompileExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr); -static void DeleteExecStack(ExecStack *esPtr); static void DupExprCodeInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr, @@ -711,16 +530,9 @@ static ExceptionRange * GetExceptRangeForPc(const unsigned char *pc, static const char * GetSrcInfoForPc(const unsigned char *pc, ByteCode *codePtr, int *lengthPtr, const unsigned char **pcBeg); -static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, int growth, - int move); static void IllegalExprOperandType(Tcl_Interp *interp, const unsigned char *pc, Tcl_Obj *opndPtr); static void InitByteCodeExecution(Tcl_Interp *interp); -static inline int OFFSET(void *ptr); -static void ReleaseDictIterator(Tcl_Obj *objPtr); -/* Useful elsewhere, make available in tclInt.h or stubs? */ -static Tcl_Obj ** StackAllocWords(Tcl_Interp *interp, int numWords); -static Tcl_Obj ** StackReallocWords(Tcl_Interp *interp, int numWords); static Tcl_NRPostProc CopyCallback; static Tcl_NRPostProc ExprObjCallback; @@ -739,55 +551,6 @@ static const Tcl_ObjType exprCodeType = { NULL /* setFromAnyProc */ }; -/* - * Custom object type only used in this file; values of its type should never - * be seen by user scripts. - */ - -static const Tcl_ObjType dictIteratorType = { - "dictIterator", - ReleaseDictIterator, - NULL, NULL, NULL -}; - -/* - *---------------------------------------------------------------------- - * - * ReleaseDictIterator -- - * - * This takes apart a dictionary iterator that is stored in the given Tcl - * object. - * - * Results: - * None. - * - * Side effects: - * Deallocates memory, marks the object as being untyped. - * - *---------------------------------------------------------------------- - */ - -static void -ReleaseDictIterator( - Tcl_Obj *objPtr) -{ - Tcl_DictSearch *searchPtr; - Tcl_Obj *dictPtr; - - /* - * First kill the search, and then release the reference to the dictionary - * that we were holding. - */ - - searchPtr = objPtr->internalRep.twoPtrValue.ptr1; - Tcl_DictObjDone(searchPtr); - ckfree(searchPtr); - - dictPtr = objPtr->internalRep.twoPtrValue.ptr2; - TclDecrRefCount(dictPtr); - - objPtr->typePtr = NULL; -} static void UpdateStringOfBcSource(Tcl_Obj *objPtr); @@ -815,7 +578,19 @@ UpdateStringOfBcSource( objPtr->length = len; } +static inline int +TclCodeIsStale( + ByteCode *codePtr, + Interp *iPtr) +{ + Namespace *namespacePtr = iPtr->varFramePtr->nsPtr; + int check = (((Interp *) *codePtr->interpHandle != iPtr) + || (codePtr->nsPtr != namespacePtr) + || (codePtr->nsEpoch != namespacePtr->resolverEpoch) + || (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)); + return check; +} /* @@ -845,15 +620,6 @@ InitByteCodeExecution( * "tcl_traceExec" is linked to control * instruction tracing. */ { -#ifdef TCL_COMPILE_DEBUG - if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec, - TCL_LINK_INT) != TCL_OK) { - Tcl_Panic("InitByteCodeExecution: can't create link for tcl_traceExec variable"); - } -#endif -#ifdef TCL_COMPILE_STATS - Tcl_CreateObjCommand(interp, "evalstats", EvalStatsCmd, NULL, NULL); -#endif /* TCL_COMPILE_STATS */ } /* @@ -886,10 +652,7 @@ TclCreateExecEnv( * [sizeof(Tcl_Obj*)] */ { ExecEnv *eePtr = ckalloc(sizeof(ExecEnv)); - ExecStack *esPtr = ckalloc(sizeof(ExecStack) - + (size_t) (size-1) * sizeof(Tcl_Obj *)); - eePtr->execStackPtr = esPtr; TclNewBooleanObj(eePtr->constants[0], 0); Tcl_IncrRefCount(eePtr->constants[0]); TclNewBooleanObj(eePtr->constants[1], 1); @@ -899,12 +662,6 @@ TclCreateExecEnv( eePtr->corPtr = NULL; eePtr->rewind = 0; - esPtr->prevPtr = NULL; - esPtr->nextPtr = NULL; - esPtr->markerPtr = NULL; - esPtr->endPtr = &esPtr->stackWords[size-1]; - esPtr->tosPtr = &esPtr->stackWords[-1]; - Tcl_MutexLock(&execMutex); if (!execInitialized) { TclInitAuxDataTypeTable(); @@ -933,44 +690,16 @@ TclCreateExecEnv( *---------------------------------------------------------------------- */ -static void -DeleteExecStack( - ExecStack *esPtr) -{ - if (esPtr->markerPtr && !cachedInExit) { - Tcl_Panic("freeing an execStack which is still in use"); - } - - if (esPtr->prevPtr) { - esPtr->prevPtr->nextPtr = esPtr->nextPtr; - } - if (esPtr->nextPtr) { - esPtr->nextPtr->prevPtr = esPtr->prevPtr; - } - ckfree(esPtr); -} - void TclDeleteExecEnv( ExecEnv *eePtr) /* Execution environment to free. */ { - ExecStack *esPtr = eePtr->execStackPtr, *tmpPtr; - cachedInExit = TclInExit(); /* * Delete all stacks in this exec env. */ - while (esPtr->nextPtr) { - esPtr = esPtr->nextPtr; - } - while (esPtr) { - tmpPtr = esPtr; - esPtr = tmpPtr->prevPtr; - DeleteExecStack(tmpPtr); - } - TclDecrRefCount(eePtr->constants[0]); TclDecrRefCount(eePtr->constants[1]); if (eePtr->callbackPtr && !cachedInExit) { @@ -1010,351 +739,6 @@ TclFinalizeExecution(void) } /* - * Auxiliary code to insure that GrowEvaluationStack always returns correctly - * aligned memory. - * - * WALLOCALIGN represents the alignment reqs in words, just as TCL_ALLOCALIGN - * represents the reqs in bytes. This assumes that TCL_ALLOCALIGN is a - * multiple of the wordsize 'sizeof(Tcl_Obj *)'. - */ - -#define WALLOCALIGN \ - (TCL_ALLOCALIGN/sizeof(Tcl_Obj *)) - -/* - * OFFSET computes how many words have to be skipped until the next aligned - * word. Note that we are only interested in the low order bits of ptr, so - * that any possible information loss in PTR2INT is of no consequence. - */ - -static inline int -OFFSET( - void *ptr) -{ - int mask = TCL_ALLOCALIGN-1; - int base = PTR2INT(ptr) & mask; - return (TCL_ALLOCALIGN - base)/sizeof(Tcl_Obj *); -} - -/* - * Given a marker, compute where the following aligned memory starts. - */ - -#define MEMSTART(markerPtr) \ - ((markerPtr) + OFFSET(markerPtr)) - -/* - *---------------------------------------------------------------------- - * - * GrowEvaluationStack -- - * - * This procedure grows a Tcl evaluation stack stored in an ExecEnv, - * copying over the words since the last mark if so requested. A mark is - * set at the beginning of the new area when no copying is requested. - * - * Results: - * Returns a pointer to the first usable word in the (possibly) grown - * stack. - * - * Side effects: - * The size of the evaluation stack may be grown, a marker is set - * - *---------------------------------------------------------------------- - */ - -static Tcl_Obj ** -GrowEvaluationStack( - ExecEnv *eePtr, /* Points to the ExecEnv with an evaluation - * stack to enlarge. */ - int growth, /* How much larger than the current used - * size. */ - int move) /* 1 if move words since last marker. */ -{ - ExecStack *esPtr = eePtr->execStackPtr, *oldPtr = NULL; - int newBytes, newElems, currElems; - int needed = growth - (esPtr->endPtr - esPtr->tosPtr); - Tcl_Obj **markerPtr = esPtr->markerPtr, **memStart; - int moveWords = 0; - - if (move) { - if (!markerPtr) { - Tcl_Panic("STACK: Reallocating with no previous alloc"); - } - if (needed <= 0) { - return MEMSTART(markerPtr); - } - } else { -#ifndef PURIFY - Tcl_Obj **tmpMarkerPtr = esPtr->tosPtr + 1; - int offset = OFFSET(tmpMarkerPtr); - - if (needed + offset < 0) { - /* - * Put a marker pointing to the previous marker in this stack, and - * store it in esPtr as the current marker. Return a pointer to - * the start of aligned memory. - */ - - esPtr->markerPtr = tmpMarkerPtr; - memStart = tmpMarkerPtr + offset; - esPtr->tosPtr = memStart - 1; - *esPtr->markerPtr = (Tcl_Obj *) markerPtr; - return memStart; - } -#endif - } - - /* - * Reset move to hold the number of words to be moved to new stack (if - * any) and growth to hold the complete stack requirements: add one for - * the marker, (WALLOCALIGN-1) for the maximal possible offset. - */ - - if (move) { - moveWords = esPtr->tosPtr - MEMSTART(markerPtr) + 1; - } - needed = growth + moveWords + WALLOCALIGN; - - - /* - * Check if there is enough room in the next stack (if there is one, it - * should be both empty and the last one!) - */ - - if (esPtr->nextPtr) { - oldPtr = esPtr; - esPtr = oldPtr->nextPtr; - currElems = esPtr->endPtr - &esPtr->stackWords[-1]; - if (esPtr->markerPtr || (esPtr->tosPtr != &esPtr->stackWords[-1])) { - Tcl_Panic("STACK: Stack after current is in use"); - } - if (esPtr->nextPtr) { - Tcl_Panic("STACK: Stack after current is not last"); - } - if (needed <= currElems) { - goto newStackReady; - } - DeleteExecStack(esPtr); - esPtr = oldPtr; - } else { - currElems = esPtr->endPtr - &esPtr->stackWords[-1]; - } - - /* - * We need to allocate a new stack! It needs to store 'growth' words, - * including the elements to be copied over and the new marker. - */ - -#ifndef PURIFY - newElems = 2*currElems; - while (needed > newElems) { - newElems *= 2; - } -#else - newElems = needed; -#endif - - newBytes = sizeof(ExecStack) + (newElems-1) * sizeof(Tcl_Obj *); - - oldPtr = esPtr; - esPtr = ckalloc(newBytes); - - oldPtr->nextPtr = esPtr; - esPtr->prevPtr = oldPtr; - esPtr->nextPtr = NULL; - esPtr->endPtr = &esPtr->stackWords[newElems-1]; - - newStackReady: - eePtr->execStackPtr = esPtr; - - /* - * Store a NULL marker at the beginning of the stack, to indicate that - * this is the first marker in this stack and that rewinding to here - * should actually be a return to the previous stack. - */ - - esPtr->stackWords[0] = NULL; - esPtr->markerPtr = &esPtr->stackWords[0]; - memStart = MEMSTART(esPtr->markerPtr); - esPtr->tosPtr = memStart - 1; - - if (move) { - memcpy(memStart, MEMSTART(markerPtr), moveWords*sizeof(Tcl_Obj *)); - esPtr->tosPtr += moveWords; - oldPtr->markerPtr = (Tcl_Obj **) *markerPtr; - oldPtr->tosPtr = markerPtr-1; - } - - /* - * Free the old stack if it is now unused. - */ - - if (!oldPtr->markerPtr) { - DeleteExecStack(oldPtr); - } - - return memStart; -} - -/* - *-------------------------------------------------------------- - * - * TclStackAlloc, TclStackRealloc, TclStackFree -- - * - * Allocate memory from the execution stack; it has to be returned later - * with a call to TclStackFree. - * - * Results: - * A pointer to the first byte allocated, or panics if the allocation did - * not succeed. - * - * Side effects: - * The execution stack may be grown. - * - *-------------------------------------------------------------- - */ - -static Tcl_Obj ** -StackAllocWords( - Tcl_Interp *interp, - int numWords) -{ - /* - * Note that GrowEvaluationStack sets a marker in the stack. This marker - * is read when rewinding, e.g., by TclStackFree. - */ - - Interp *iPtr = (Interp *) interp; - ExecEnv *eePtr = iPtr->execEnvPtr; - Tcl_Obj **resPtr = GrowEvaluationStack(eePtr, numWords, 0); - - eePtr->execStackPtr->tosPtr += numWords; - return resPtr; -} - -static Tcl_Obj ** -StackReallocWords( - Tcl_Interp *interp, - int numWords) -{ - Interp *iPtr = (Interp *) interp; - ExecEnv *eePtr = iPtr->execEnvPtr; - Tcl_Obj **resPtr = GrowEvaluationStack(eePtr, numWords, 1); - - eePtr->execStackPtr->tosPtr += numWords; - return resPtr; -} - -void -TclStackFree( - Tcl_Interp *interp, - void *freePtr) -{ - Interp *iPtr = (Interp *) interp; - ExecEnv *eePtr; - ExecStack *esPtr; - Tcl_Obj **markerPtr, *marker; - - if (iPtr == NULL || iPtr->execEnvPtr == NULL) { - ckfree((char *) freePtr); - return; - } - - /* - * Rewind the stack to the previous marker position. The current marker, - * as set in the last call to GrowEvaluationStack, contains a pointer to - * the previous marker. - */ - - eePtr = iPtr->execEnvPtr; - esPtr = eePtr->execStackPtr; - markerPtr = esPtr->markerPtr; - marker = *markerPtr; - - if ((freePtr != NULL) && (MEMSTART(markerPtr) != (Tcl_Obj **)freePtr)) { - Tcl_Panic("TclStackFree: incorrect freePtr (%p != %p). Call out of sequence?", - freePtr, MEMSTART(markerPtr)); - } - - esPtr->tosPtr = markerPtr - 1; - esPtr->markerPtr = (Tcl_Obj **) marker; - if (marker) { - return; - } - - /* - * Return to previous active stack. Note that repeated expansions or - * reallocs could have generated several unused intervening stacks: free - * them too. - */ - - while (esPtr->nextPtr) { - esPtr = esPtr->nextPtr; - } - esPtr->tosPtr = &esPtr->stackWords[-1]; - while (esPtr->prevPtr) { - ExecStack *tmpPtr = esPtr->prevPtr; - if (tmpPtr->tosPtr == &tmpPtr->stackWords[-1]) { - DeleteExecStack(tmpPtr); - } else { - break; - } - } - if (esPtr->prevPtr) { - eePtr->execStackPtr = esPtr->prevPtr; -#ifdef PURIFY - eePtr->execStackPtr->nextPtr = NULL; - DeleteExecStack(esPtr); -#endif - } else { - eePtr->execStackPtr = esPtr; - } -} - -void * -TclStackAlloc( - Tcl_Interp *interp, - int numBytes) -{ - Interp *iPtr = (Interp *) interp; - int numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); - - if (iPtr == NULL || iPtr->execEnvPtr == NULL) { - return (void *) ckalloc(numBytes); - } - - return (void *) StackAllocWords(interp, numWords); -} - -void * -TclStackRealloc( - Tcl_Interp *interp, - void *ptr, - int numBytes) -{ - Interp *iPtr = (Interp *) interp; - ExecEnv *eePtr; - ExecStack *esPtr; - Tcl_Obj **markerPtr; - int numWords; - - if (iPtr == NULL || iPtr->execEnvPtr == NULL) { - return (void *) ckrealloc((char *) ptr, numBytes); - } - - eePtr = iPtr->execEnvPtr; - esPtr = eePtr->execStackPtr; - markerPtr = esPtr->markerPtr; - - if (MEMSTART(markerPtr) != (Tcl_Obj **)ptr) { - Tcl_Panic("TclStackRealloc: incorrect ptr. Call out of sequence?"); - } - - numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); - return (void *) StackReallocWords(interp, numWords); -} - -/* *-------------------------------------------------------------- * * Tcl_ExprObj -- @@ -1513,14 +897,8 @@ CompileExprObj( * is valid in the current context. */ if (objPtr->typePtr == &exprCodeType) { - Namespace *namespacePtr = iPtr->varFramePtr->nsPtr; - codePtr = objPtr->internalRep.otherValuePtr; - if (((Interp *) *codePtr->interpHandle != iPtr) - || (codePtr->compileEpoch != iPtr->compileEpoch) - || (codePtr->nsPtr != namespacePtr) - || (codePtr->nsEpoch != namespacePtr->resolverEpoch) - || (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) { + if (TclCodeIsStale(codePtr, iPtr)) { FreeExprCodeInternalRep(objPtr); } } @@ -1556,12 +934,6 @@ CompileExprObj( codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; } -#ifdef TCL_COMPILE_DEBUG - if (tclTraceCompile == 2) { - TclPrintByteCodeObj(interp, objPtr); - fflush(stdout); - } -#endif /* TCL_COMPILE_DEBUG */ } return codePtr; } @@ -1656,7 +1028,6 @@ TclCompileObj( { register Interp *iPtr = (Interp *) interp; register ByteCode *codePtr; /* Tcl Internal type of bytecode. */ - Namespace *namespacePtr = iPtr->varFramePtr->nsPtr; /* * If the object is not already of tclByteCodeType, compile it (and reset @@ -1683,17 +1054,13 @@ TclCompileObj( */ codePtr = objPtr->internalRep.otherValuePtr; - if (((Interp *) *codePtr->interpHandle != iPtr) - || (codePtr->compileEpoch != iPtr->compileEpoch) - || (codePtr->nsPtr != namespacePtr) - || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) { + if (TclCodeIsStale(codePtr, iPtr)) { if (!(codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { goto recompileObj; } if ((Interp *) *codePtr->interpHandle != iPtr) { Tcl_Panic("Tcl_EvalObj: compiled script jumped interps"); } - codePtr->compileEpoch = iPtr->compileEpoch; } /* @@ -1706,7 +1073,6 @@ TclCompileObj( (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)){ goto recompileObj; } - return codePtr; } @@ -1866,9 +1232,23 @@ TclIncrObj( * *---------------------------------------------------------------------- */ -#define initCatchTop ((ptrdiff_t *) (&TD->stack[-1])) -#define initTosPtr ((Tcl_Obj **) (initCatchTop+codePtr->maxExceptDepth)) -#define esPtr (iPtr->execEnvPtr->execStackPtr) +#define catchStack (TD->stack) +#define initTosPtr ((Tcl_Obj **) &TD->stack[codePtr->maxExceptDepth - 1]) + +/* + * The execution uses a unified stack: first a TEBCdata, immediately + * above it the catch stack, then the execution stack. + * + * Make sure the catch stack is large enough to hold the maximum number of + * catch commands that could ever be executing at the same time (this will + * be no more than the exception range array's depth). Make sure the + * execution stack is large enough to execute this ByteCode. + */ + +// FIXME! The "+1" should not be necessary, temporary until we fix BC issues + +#define capacity2size(cap) \ + (offsetof(TEBCdata, stack) + sizeof(void *)*(cap + codePtr->maxExceptDepth + 1)) int TclNRExecuteByteCode( @@ -1877,11 +1257,7 @@ TclNRExecuteByteCode( { Interp *iPtr = (Interp *) interp; TEBCdata *TD; - int size = sizeof(TEBCdata) - 1 - + (codePtr->maxStackDepth + codePtr->maxExceptDepth) - * sizeof(void *); - int numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *); - + if (iPtr->execEnvPtr->rewind) { return TCL_ERROR; } @@ -1890,29 +1266,18 @@ TclNRExecuteByteCode( /* * Reserve the stack, setup the TEBCdataPtr (TD) and CallFrame - * - * The execution uses a unified stack: first a TEBCdata, immediately - * above it the catch stack, then the execution stack. - * - * Make sure the catch stack is large enough to hold the maximum number of - * catch commands that could ever be executing at the same time (this will - * be no more than the exception range array's depth). Make sure the - * execution stack is large enough to execute this ByteCode. */ - TD = (TEBCdata *) GrowEvaluationStack(iPtr->execEnvPtr, numWords, 0); - esPtr->tosPtr = initTosPtr; + TD = ckalloc(capacity2size(codePtr->maxStackDepth)); TD->codePtr = codePtr; - TD->pc = codePtr->codeStart; - TD->catchTop = initCatchTop; + TD->tosPtr = initTosPtr; + TD->pc = codePtr->codeStart; + TD->catchDepth = -1; TD->cleanup = 0; TD->auxObjList = NULL; TD->checkInterp = 0; - -#ifdef TCL_COMPILE_STATS - iPtr->stats.numExecutions++; -#endif + TD->capacity = codePtr->maxStackDepth; /* * Push the callback for bytecode execution @@ -1954,11 +1319,6 @@ TEBCresume( int instructionCount = 0; /* Counter that is used to work out when to * call Tcl_AsyncReady() */ - const char *curInstName; -#ifdef TCL_COMPILE_DEBUG - int traceInstructions; /* Whether we are doing instruction-level - * tracing or not. */ -#endif Var *compiledLocals = iPtr->varFramePtr->compiledLocals; Tcl_Obj **constants = &iPtr->execEnvPtr->constants[0]; @@ -1973,11 +1333,11 @@ TEBCresume( TEBCdata *TD = data[0]; #define auxObjList (TD->auxObjList) -#define catchTop (TD->catchTop) +#define catchDepth (TD->catchDepth) #define codePtr (TD->codePtr) #define checkInterp (TD->checkInterp) - /* Indicates when a check of interp readyness is - * necessary. Set by CACHE_STACK_INFO() */ + /* Indicates when a check of interp readyness + * is necessary. Set by checkInterp = 1 */ /* * Globals: variables that store state, must remain valid at all times. @@ -1986,8 +1346,7 @@ TEBCresume( Tcl_Obj **tosPtr; /* Cached pointer to top of evaluation * stack. */ const unsigned char *pc; /* The current program counter. */ - unsigned char inst; /* The currently running instruction */ - + /* * Transfer variables - needed only between opcodes, but not while * executing an instruction. @@ -2007,23 +1366,9 @@ TEBCresume( int objc = 0; int opnd, length, pcAdjustment; Var *varPtr, *arrayPtr; -#ifdef TCL_COMPILE_DEBUG - char cmdNameBuf[21]; -#endif -#ifdef TCL_COMPILE_DEBUG - traceInstructions = (tclTraceExec == 3); -#endif TEBC_DATA_DIG(); -#ifdef TCL_COMPILE_DEBUG - if (!data[1] && (tclTraceExec >= 2)) { - PrintByteCodeInfo(codePtr); - fprintf(stdout, " Starting stack top=%d\n", (int) CURR_DEPTH); - fflush(stdout); - } -#endif - if (data[1] /* resume from invocation */) { if (iPtr->execEnvPtr->rewind) { result = TCL_ERROR; @@ -2033,21 +1378,17 @@ TEBCresume( codePtr->flags &= ~TCL_BYTECODE_RECOMPILE; } - CACHE_STACK_INFO(); + checkInterp = 1; if (result == TCL_OK) { -#ifndef TCL_COMPILE_DEBUG if (*pc == INST_POP) { NEXT_INST_V(1, cleanup, 0); } -#endif + /* * Push the call's object result and continue execution with the * next instruction. */ - TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=", - objc, cmdNameBuf), Tcl_GetObjResult(interp)); - objResultPtr = Tcl_GetObjResult(interp); /* @@ -2153,89 +1494,32 @@ TEBCresume( */ if ((instructionCount++ & ASYNC_CHECK_COUNT_MASK) == 0) { - DECACHE_STACK_INFO(); if (TclAsyncReady(iPtr)) { result = Tcl_AsyncInvoke(interp, result); if (result == TCL_ERROR) { - CACHE_STACK_INFO(); + checkInterp = 1; goto gotError; } } if (TclCanceled(iPtr)) { if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) { - CACHE_STACK_INFO(); + checkInterp = 1; goto gotError; } } if (TclLimitReady(iPtr->limit)) { if (Tcl_LimitCheck(interp) == TCL_ERROR) { - CACHE_STACK_INFO(); + checkInterp = 1; goto gotError; } } - CACHE_STACK_INFO(); + checkInterp = 1; } - /* - * These two instructions account for 26% of all instructions (according - * to measurements on tclbench by Ben Vitale - * [http://www.cs.toronto.edu/syslab/pubs/tcl2005-vitale-zaleski.pdf] - * Resolving them before the switch reduces the cost of branch - * mispredictions, seems to improve runtime by 5% to 15%, and (amazingly!) - * reduces total obj size. - */ - - inst = *pc; - - peepholeStart: -#ifdef TCL_COMPILE_STATS - iPtr->stats.instructionCount[*pc]++; -#endif - -#ifdef TCL_COMPILE_DEBUG - /* - * Skip the stack depth check if an expansion is in progress. - */ - - CHECK_STACK(); - if (traceInstructions) { - fprintf(stdout, "%2d: %2d ", iPtr->numLevels, (int) CURR_DEPTH); - TclPrintInstruction(codePtr, pc); - fflush(stdout); - } -#endif /* TCL_COMPILE_DEBUG */ - - TCL_DTRACE_INST_NEXT(); - - if (inst == INST_LOAD_SCALAR1) { - goto instLoadScalar1; - } else if (inst == INST_PUSH1) { - PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]); - TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), OBJ_AT_TOS); - inst = *(pc += 2); - goto peepholeStart; - } else if (inst == INST_START_CMD) { - /* - * Peephole: do not run INST_START_CMD, just skip it - */ - - iPtr->cmdCount += TclGetUInt4AtPtr(pc+5); - if (checkInterp) { - checkInterp = 0; - if ((codePtr->compileEpoch != iPtr->compileEpoch) - || (codePtr->nsEpoch != iPtr->varFramePtr->nsPtr->resolverEpoch)) { - goto instStartCmdFailed; - } - } - inst = *(pc += 9); - goto peepholeStart; - } - - switch (inst) { - case INST_SYNTAX: - case INST_RETURN_IMM: { + switch (*pc) { + case INST_SYNTAX: { int code = TclGetInt4AtPtr(pc+1); int level = TclGetUInt4AtPtr(pc+5); @@ -2243,11 +1527,8 @@ TEBCresume( * OBJ_AT_TOS is returnOpts, OBJ_UNDER_TOS is resultObjPtr. */ - TRACE(("%u %u => ", code, level)); result = TclProcessReturn(interp, code, level, OBJ_AT_TOS); if (result == TCL_OK) { - TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")", - O2S(objResultPtr))); NEXT_INST_F(9, 1, 0); } Tcl_SetObjResult(interp, OBJ_UNDER_TOS); @@ -2258,98 +1539,6 @@ TEBCresume( goto processExceptionReturn; } - case INST_RETURN_STK: - TRACE(("=> ")); - objResultPtr = POP_OBJECT(); - result = Tcl_SetReturnOptions(interp, OBJ_AT_TOS); - Tcl_DecrRefCount(OBJ_AT_TOS); - OBJ_AT_TOS = objResultPtr; - if (result == TCL_OK) { - TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")", - O2S(objResultPtr))); - NEXT_INST_F(1, 0, 0); - } - Tcl_SetObjResult(interp, objResultPtr); - cleanup = 1; - goto processExceptionReturn; - - case INST_YIELD: { - CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; - - TRACE(("%.30s => ", O2S(OBJ_AT_TOS))); - if (!corPtr) { - TRACE_APPEND(("ERROR: yield outside coroutine\n")); - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "yield can only be called in a coroutine", -1)); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", - NULL); - goto gotError; - } - -#ifdef TCL_COMPILE_DEBUG - TRACE_WITH_OBJ(("yield, result="), iPtr->objResultPtr); - if (traceInstructions) { - fprintf(stdout, "\n"); - } -#endif - - pc++; - cleanup = 1; - TEBC_YIELD(); - - Tcl_SetObjResult(interp, OBJ_AT_TOS); - Tcl_NRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, - INT2PTR(0), NULL, NULL); - - return TCL_OK; - } - - case INST_TAILCALL: { - Tcl_Obj *listPtr, *nsObjPtr; - - opnd = TclGetUInt1AtPtr(pc+1); - - if (!(iPtr->varFramePtr->isProcCallFrame & 1)) { - TRACE(("%d => ERROR: tailcall in non-proc context\n", opnd)); - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "tailcall can only be called from a proc or lambda", -1)); - Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL); - goto gotError; - } - -#ifdef TCL_COMPILE_DEBUG - { - register int i; - - TRACE(("%d [", opnd)); - for (i=opnd-1 ; i>=0 ; i--) { - TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_DEPTH(i)))); - if (i > 0) { - TRACE_APPEND((" ")); - } - } - TRACE_APPEND(("] => RETURN...")); - } -#endif - - /* - * Push the evaluation of the called command into the NR callback - * stack. - */ - - listPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1)); - nsObjPtr = Tcl_NewStringObj(iPtr->varFramePtr->nsPtr->fullName, -1); - TclListObjSetElement(interp, listPtr, 0, nsObjPtr); - if (iPtr->varFramePtr->tailcallPtr) { - Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr); - } - iPtr->varFramePtr->tailcallPtr = listPtr; - - result = TCL_RETURN; - cleanup = opnd; - goto processExceptionReturn; - } - case INST_DONE: if (tosPtr > initTosPtr) { /* @@ -2360,13 +1549,6 @@ TEBCresume( */ Tcl_SetObjResult(interp, OBJ_AT_TOS); -#ifdef TCL_COMPILE_DEBUG - TRACE_WITH_OBJ(("=> return code=%d, result=", result), - iPtr->objResultPtr); - if (traceInstructions) { - fprintf(stdout, "\n"); - } -#endif goto checkForCatch; } (void) POP_OBJECT(); @@ -2374,27 +1556,6 @@ TEBCresume( case INST_PUSH4: objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)]; - TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), objResultPtr); - NEXT_INST_F(5, 0, 1); - - case INST_POP: - TRACE_WITH_OBJ(("=> discarding "), OBJ_AT_TOS); - objPtr = POP_OBJECT(); - TclDecrRefCount(objPtr); - NEXT_INST_F(1, 0, 0); - - case INST_NOP: - NEXT_INST_F(1, 0, 0); - - case INST_DUP: - objResultPtr = OBJ_AT_TOS; - TRACE_WITH_OBJ(("=> "), objResultPtr); - NEXT_INST_F(1, 0, 1); - - case INST_OVER: - opnd = TclGetUInt4AtPtr(pc+1); - objResultPtr = OBJ_AT_DEPTH(opnd); - TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(5, 0, 1); case INST_REVERSE: { @@ -2471,7 +1632,6 @@ TEBCresume( */ if (appendLen == 0) { - TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); NEXT_INST_V(2, (opnd-1), 0); } @@ -2492,15 +1652,6 @@ TEBCresume( Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } -#if !TCL_COMPILE_DEBUG - if (bytes != tclEmptyStringRep && !Tcl_IsShared(objResultPtr)) { - TclFreeIntRep(objResultPtr); - objResultPtr->bytes = ckrealloc(bytes, length+appendLen+1); - objResultPtr->length = length + appendLen; - p = TclGetString(objResultPtr) + length; - currPtr = &OBJ_AT_DEPTH(opnd - 2); - } else -#endif { p = ckalloc(length + appendLen + 1); TclNewObj(objResultPtr); @@ -2528,14 +1679,6 @@ TEBCresume( Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } -#if !TCL_COMPILE_DEBUG - if (!Tcl_IsShared(objResultPtr)) { - bytes = (char *) Tcl_SetByteArrayLength(objResultPtr, - length + appendLen); - p = bytes + length; - currPtr = &OBJ_AT_DEPTH(opnd - 2); - } else -#endif { TclNewObj(objResultPtr); bytes = (char *) Tcl_SetByteArrayLength(objResultPtr, @@ -2557,7 +1700,6 @@ TEBCresume( } } - TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); NEXT_INST_V(2, opnd, 1); } @@ -2582,7 +1724,7 @@ TEBCresume( case INST_EXPAND_STKTOP: { int i; - ptrdiff_t moved; + unsigned int reqWords; /* * Make sure that the element at stackTop is a list; if not, just @@ -2592,11 +1734,8 @@ TEBCresume( objPtr = OBJ_AT_TOS; if (TclListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) { - TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(objPtr)), - Tcl_GetObjResult(interp)); goto gotError; } - (void) POP_OBJECT(); /* * Make sure there is enough room in the stack to expand this list @@ -2605,22 +1744,23 @@ TEBCresume( * stack depth, as seen by the compiler. */ - length = objc + (codePtr->maxStackDepth - TclGetInt4AtPtr(pc+1)); - DECACHE_STACK_INFO(); - moved = GrowEvaluationStack(iPtr->execEnvPtr, length, 1) - - (Tcl_Obj **) TD; - if (moved) { - /* - * Change the global data to point to the new stack: move the - * TEBCdataPtr TD, recompute the position of every other - * stack-allocated parameter, update the stack pointers. - */ + reqWords = + /* how many were needed originally */ + codePtr->maxStackDepth + /* plus how many we already consumed in previous expansions */ + + (CURR_DEPTH - TclGetInt4AtPtr(pc+1)) + /* plus how many are needed for this expansion */ + + objc - 1; - esPtr = iPtr->execEnvPtr->execStackPtr; - TD = (TEBCdata *) (((Tcl_Obj **)TD) + moved); + (void) POP_OBJECT(); + if (reqWords > TD->capacity) { + ptrdiff_t depth; + unsigned int size = capacity2size(reqWords); - catchTop += moved; - tosPtr += moved; + depth = tosPtr - initTosPtr; + TD = ckrealloc(TD, size); + TD->capacity = reqWords; + tosPtr = initTosPtr + depth; } /* @@ -2636,29 +1776,6 @@ TEBCresume( NEXT_INST_F(5, 0, 0); } - case INST_EXPR_STK: { - ByteCode *newCodePtr; - - DECACHE_STACK_INFO(); - newCodePtr = CompileExprObj(interp, OBJ_AT_TOS); - CACHE_STACK_INFO(); - cleanup = 1; - pc++; - TEBC_YIELD(); - return TclNRExecuteByteCode(interp, newCodePtr); - } - - /* - * INVOCATION BLOCK - */ - - instEvalStk: - case INST_EVAL_STK: - cleanup = 1; - pc += 1; - TEBC_YIELD(); - return TclNREvalObjEx(interp, OBJ_AT_TOS, 0); - case INST_INVOKE_EXPANDED: CLANG_ASSERT(auxObjList); objc = CURR_DEPTH - auxObjList->internalRep.ptrAndLongRep.value; @@ -2678,35 +1795,12 @@ TEBCresume( case INST_INVOKE_STK4: objc = TclGetUInt4AtPtr(pc+1); pcAdjustment = 5; - goto doInvocation; - - case INST_INVOKE_STK1: - objc = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; doInvocation: + objv = &OBJ_AT_DEPTH(objc-1); cleanup = objc; -#ifdef TCL_COMPILE_DEBUG - if (tclTraceExec >= 2) { - int i; - - if (traceInstructions) { - strncpy(cmdNameBuf, TclGetString(objv[0]), 20); - TRACE(("%u => call ", objc)); - } else { - fprintf(stdout, "%d: (%u) invoking ", iPtr->numLevels, - (unsigned)(pc - codePtr->codeStart)); - } - for (i = 0; i < objc; i++) { - TclPrintObject(stdout, objv[i], 15); - fprintf(stdout, " "); - } - fprintf(stdout, "\n"); - fflush(stdout); - } -#endif /*TCL_COMPILE_DEBUG*/ /* * Finally, let TclEvalObjv handle the command. @@ -2724,149 +1818,11 @@ TEBCresume( return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR, NULL); -#if TCL_SUPPORT_84_BYTECODE - case INST_CALL_BUILTIN_FUNC1: - /* - * Call one of the built-in pre-8.5 Tcl math functions. This - * translates to INST_INVOKE_STK1 with the first argument of - * ::tcl::mathfunc::$objv[0]. We need to insert the named math - * function into the stack. - */ - - opnd = TclGetUInt1AtPtr(pc+1); - if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) { - TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd)); - Tcl_Panic("TclNRExecuteByteCode: unrecognized builtin function code %d", opnd); - } - - TclNewLiteralStringObj(objPtr, "::tcl::mathfunc::"); - Tcl_AppendToObj(objPtr, tclBuiltinFuncTable[opnd].name, -1); - - /* - * Only 0, 1 or 2 args. - */ - - { - int numArgs = tclBuiltinFuncTable[opnd].numArgs; - Tcl_Obj *tmpPtr1, *tmpPtr2; - - if (numArgs == 0) { - PUSH_OBJECT(objPtr); - } else if (numArgs == 1) { - tmpPtr1 = POP_OBJECT(); - PUSH_OBJECT(objPtr); - PUSH_OBJECT(tmpPtr1); - Tcl_DecrRefCount(tmpPtr1); - } else { - tmpPtr2 = POP_OBJECT(); - tmpPtr1 = POP_OBJECT(); - PUSH_OBJECT(objPtr); - PUSH_OBJECT(tmpPtr1); - PUSH_OBJECT(tmpPtr2); - Tcl_DecrRefCount(tmpPtr1); - Tcl_DecrRefCount(tmpPtr2); - } - objc = numArgs + 1; - } - pcAdjustment = 2; - goto doInvocation; - - case INST_CALL_FUNC1: - /* - * Call a non-builtin Tcl math function previously registered by a - * call to Tcl_CreateMathFunc pre-8.5. This is essentially - * INST_INVOKE_STK1 converting the first arg to - * ::tcl::mathfunc::$objv[0]. - */ - - objc = TclGetUInt1AtPtr(pc+1); /* Number of arguments. The function - * name is the 0-th argument. */ - - objPtr = OBJ_AT_DEPTH(objc-1); - TclNewLiteralStringObj(tmpPtr, "::tcl::mathfunc::"); - Tcl_AppendObjToObj(tmpPtr, objPtr); - Tcl_DecrRefCount(objPtr); - - /* - * Variation of PUSH_OBJECT. - */ - - OBJ_AT_DEPTH(objc-1) = tmpPtr; - Tcl_IncrRefCount(tmpPtr); - - pcAdjustment = 2; - goto doInvocation; -#else /* * INST_CALL_BUILTIN_FUNC1 and INST_CALL_FUNC1 were made obsolete by the - * changes to add a ::tcl::mathfunc namespace in 8.5. Optional support - * remains for existing bytecode precompiled files. + * changes to add a ::tcl::mathfunc namespace in 8.5. */ - case INST_CALL_BUILTIN_FUNC1: - Tcl_Panic("TclNRExecuteByteCode: obsolete INST_CALL_BUILTIN_FUNC1 found"); - case INST_CALL_FUNC1: - Tcl_Panic("TclNRExecuteByteCode: obsolete INST_CALL_FUNC1 found"); -#endif - - case INST_INVOKE_REPLACE: - objc = TclGetUInt4AtPtr(pc+1); - opnd = TclGetUInt1AtPtr(pc+5); - objPtr = POP_OBJECT(); - objv = &OBJ_AT_DEPTH(objc-1); - cleanup = objc; -#ifdef TCL_COMPILE_DEBUG - if (tclTraceExec >= 2) { - int i; - - if (traceInstructions) { - strncpy(cmdNameBuf, TclGetString(objv[0]), 20); - TRACE(("%u => call (implementation %s) ", objc, O2S(objPtr))); - } else { - fprintf(stdout, - "%d: (%u) invoking (using implementation %s) ", - iPtr->numLevels, (unsigned)(pc - codePtr->codeStart), - O2S(objPtr)); - } - for (i = 0; i < objc; i++) { - if (i < opnd) { - fprintf(stdout, "<"); - TclPrintObject(stdout, objv[i], 15); - fprintf(stdout, ">"); - } else { - TclPrintObject(stdout, objv[i], 15); - } - fprintf(stdout, " "); - } - fprintf(stdout, "\n"); - fflush(stdout); - } -#endif /*TCL_COMPILE_DEBUG*/ - { - Tcl_Obj *copyPtr = Tcl_NewListObj(objc - opnd + 1, NULL); - register List *listRepPtr = copyPtr->internalRep.twoPtrValue.ptr1; - Tcl_Obj **copyObjv = &listRepPtr->elements; - int i; - - listRepPtr->elemCount = objc - opnd + 1; - copyObjv[0] = objPtr; - memcpy(copyObjv+1, objv+opnd, sizeof(Tcl_Obj *) * (objc - opnd)); - for (i=1 ; i<objc-opnd+1 ; i++) { - Tcl_IncrRefCount(copyObjv[i]); - } - objPtr = copyPtr; - } - iPtr->ensembleRewrite.sourceObjs = objv; - iPtr->ensembleRewrite.numRemovedObjs = opnd; - iPtr->ensembleRewrite.numInsertedObjs = 1; - DECACHE_STACK_INFO(); - pc += 6; - TEBC_YIELD(); - - Tcl_NRAddCallback(interp, TclClearRootEnsemble, NULL,NULL,NULL,NULL); - TclSkipTailcall(interp); - return TclNREvalObjEx(interp, objPtr, TCL_EVAL_INVOKE); - /* * ----------------------------------------------------------------- * Start of INST_LOAD instructions. @@ -2876,43 +1832,18 @@ TEBCresume( * common execution code. */ - case INST_LOAD_SCALAR1: - instLoadScalar1: - opnd = TclGetUInt1AtPtr(pc+1); - varPtr = LOCAL(opnd); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - TRACE(("%u => ", opnd)); - if (TclIsVarDirectReadable(varPtr)) { - /* - * No errors, no traces: just get the value. - */ - - objResultPtr = varPtr->value.objPtr; - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(2, 0, 1); - } - pcAdjustment = 2; - cleanup = 0; - arrayPtr = NULL; - part1Ptr = part2Ptr = NULL; - goto doCallPtrGetVar; - case INST_LOAD_SCALAR4: opnd = TclGetUInt4AtPtr(pc+1); varPtr = LOCAL(opnd); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } - TRACE(("%u => ", opnd)); if (TclIsVarDirectReadable(varPtr)) { /* * No errors, no traces: just get the value. */ objResultPtr = varPtr->value.objPtr; - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_F(5, 0, 1); } pcAdjustment = 5; @@ -2926,10 +1857,6 @@ TEBCresume( pcAdjustment = 5; goto doLoadArray; - case INST_LOAD_ARRAY1: - opnd = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; - doLoadArray: part1Ptr = NULL; part2Ptr = OBJ_AT_TOS; @@ -2937,7 +1864,6 @@ TEBCresume( while (TclIsVarLink(arrayPtr)) { arrayPtr = arrayPtr->value.linkPtr; } - TRACE(("%u \"%.30s\" => ", opnd, O2S(part2Ptr))); if (TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr)) { varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); if (varPtr && TclIsVarDirectReadable(varPtr)) { @@ -2946,14 +1872,12 @@ TEBCresume( */ objResultPtr = varPtr->value.objPtr; - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_F(pcAdjustment, 1, 1); } } varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr, opnd); if (varPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); goto gotError; } cleanup = 1; @@ -2963,15 +1887,12 @@ TEBCresume( cleanup = 2; part2Ptr = OBJ_AT_TOS; /* element name */ objPtr = OBJ_UNDER_TOS; /* array name */ - TRACE(("\"%.30s(%.30s)\" => ", O2S(objPtr), O2S(part2Ptr))); goto doLoadStk; - case INST_LOAD_STK: case INST_LOAD_SCALAR_STK: cleanup = 1; part2Ptr = NULL; objPtr = OBJ_AT_TOS; /* variable name */ - TRACE(("\"%.30s\" => ", O2S(objPtr))); doLoadStk: part1Ptr = objPtr; @@ -2979,7 +1900,6 @@ TEBCresume( TCL_LEAVE_ERR_MSG, "read", /*createPart1*/0, /*createPart2*/1, &arrayPtr); if (!varPtr) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); goto gotError; } @@ -2989,7 +1909,6 @@ TEBCresume( */ objResultPtr = varPtr->value.objPtr; - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_V(1, cleanup, 1); } pcAdjustment = 1; @@ -3001,15 +1920,12 @@ TEBCresume( * TclPtrGetVar to process fully. */ - DECACHE_STACK_INFO(); objResultPtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, opnd); - CACHE_STACK_INFO(); + checkInterp = 1; if (!objResultPtr) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); goto gotError; } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_V(pcAdjustment, cleanup, 1); /* @@ -3022,987 +1938,27 @@ TEBCresume( * common execution code. */ - { - int storeFlags; - - case INST_STORE_ARRAY4: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - goto doStoreArrayDirect; - - case INST_STORE_ARRAY1: - opnd = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; - - doStoreArrayDirect: - valuePtr = OBJ_AT_TOS; - part2Ptr = OBJ_UNDER_TOS; - arrayPtr = LOCAL(opnd); - TRACE(("%u \"%.30s\" <- \"%.30s\" => ", opnd, O2S(part2Ptr), - O2S(valuePtr))); - while (TclIsVarLink(arrayPtr)) { - arrayPtr = arrayPtr->value.linkPtr; - } - if (TclIsVarArray(arrayPtr) && !WriteTraced(arrayPtr)) { - varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); - if (varPtr && TclIsVarDirectWritable(varPtr)) { - tosPtr--; - Tcl_DecrRefCount(OBJ_AT_TOS); - OBJ_AT_TOS = valuePtr; - goto doStoreVarDirect; - } - } - cleanup = 2; - storeFlags = TCL_LEAVE_ERR_MSG; - part1Ptr = NULL; - goto doStoreArrayDirectFailed; - case INST_STORE_SCALAR4: opnd = TclGetUInt4AtPtr(pc+1); pcAdjustment = 5; - goto doStoreScalarDirect; - - case INST_STORE_SCALAR1: - opnd = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; - doStoreScalarDirect: valuePtr = OBJ_AT_TOS; varPtr = LOCAL(opnd); - TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr))); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - if (!TclIsVarDirectWritable(varPtr)) { - storeFlags = TCL_LEAVE_ERR_MSG; - part1Ptr = NULL; - goto doStoreScalar; - } - - /* - * No traces, no errors, plain 'set': we can safely inline. The value - * *will* be set to what's requested, so that the stack top remains - * pointing to the same Tcl_Obj. - */ - - doStoreVarDirect: - valuePtr = varPtr->value.objPtr; if (valuePtr != NULL) { TclDecrRefCount(valuePtr); } + objResultPtr = OBJ_AT_TOS; varPtr->value.objPtr = objResultPtr; -#ifndef TCL_COMPILE_DEBUG - if (*(pc+pcAdjustment) == INST_POP) { - tosPtr--; - NEXT_INST_F((pcAdjustment+1), 0, 0); - } -#else - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); -#endif Tcl_IncrRefCount(objResultPtr); - NEXT_INST_F(pcAdjustment, 0, 0); - - case INST_LAPPEND_STK: - valuePtr = OBJ_AT_TOS; /* value to append */ - part2Ptr = NULL; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE - | TCL_LIST_ELEMENT); - goto doStoreStk; - - case INST_LAPPEND_ARRAY_STK: - valuePtr = OBJ_AT_TOS; /* value to append */ - part2Ptr = OBJ_UNDER_TOS; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE - | TCL_LIST_ELEMENT); - goto doStoreStk; - - case INST_APPEND_STK: - valuePtr = OBJ_AT_TOS; /* value to append */ - part2Ptr = NULL; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); - goto doStoreStk; - - case INST_APPEND_ARRAY_STK: - valuePtr = OBJ_AT_TOS; /* value to append */ - part2Ptr = OBJ_UNDER_TOS; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); - goto doStoreStk; - - case INST_STORE_ARRAY_STK: - valuePtr = OBJ_AT_TOS; - part2Ptr = OBJ_UNDER_TOS; - storeFlags = TCL_LEAVE_ERR_MSG; - goto doStoreStk; - - case INST_STORE_STK: - case INST_STORE_SCALAR_STK: - valuePtr = OBJ_AT_TOS; - part2Ptr = NULL; - storeFlags = TCL_LEAVE_ERR_MSG; - - doStoreStk: - objPtr = OBJ_AT_DEPTH(1 + (part2Ptr != NULL)); /* variable name */ - part1Ptr = objPtr; -#ifdef TCL_COMPILE_DEBUG - if (part2Ptr == NULL) { - TRACE(("\"%.30s\" <- \"%.30s\" =>", O2S(part1Ptr),O2S(valuePtr))); - } else { - TRACE(("\"%.30s(%.30s)\" <- \"%.30s\" => ", - O2S(part1Ptr), O2S(part2Ptr), O2S(valuePtr))); - } -#endif - varPtr = TclObjLookupVarEx(interp, objPtr,part2Ptr, TCL_LEAVE_ERR_MSG, - "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); - if (!varPtr) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - cleanup = ((part2Ptr == NULL)? 2 : 3); - pcAdjustment = 1; - opnd = -1; - goto doCallPtrSetVar; - - case INST_LAPPEND_ARRAY4: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE - | TCL_LIST_ELEMENT); - goto doStoreArray; - - case INST_LAPPEND_ARRAY1: - opnd = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE - | TCL_LIST_ELEMENT); - goto doStoreArray; - - case INST_APPEND_ARRAY4: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); - goto doStoreArray; - - case INST_APPEND_ARRAY1: - opnd = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); - goto doStoreArray; - - doStoreArray: - valuePtr = OBJ_AT_TOS; - part2Ptr = OBJ_UNDER_TOS; - arrayPtr = LOCAL(opnd); - TRACE(("%u \"%.30s\" <- \"%.30s\" => ", opnd, O2S(part2Ptr), - O2S(valuePtr))); - while (TclIsVarLink(arrayPtr)) { - arrayPtr = arrayPtr->value.linkPtr; - } - cleanup = 2; - part1Ptr = NULL; - - doStoreArrayDirectFailed: - varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, - TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr, opnd); - if (!varPtr) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - goto doCallPtrSetVar; - - case INST_LAPPEND_SCALAR4: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE - | TCL_LIST_ELEMENT); - goto doStoreScalar; - - case INST_LAPPEND_SCALAR1: - opnd = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE - | TCL_LIST_ELEMENT); - goto doStoreScalar; - - case INST_APPEND_SCALAR4: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); - goto doStoreScalar; - - case INST_APPEND_SCALAR1: - opnd = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); - goto doStoreScalar; - - doStoreScalar: - valuePtr = OBJ_AT_TOS; - varPtr = LOCAL(opnd); - TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr))); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - cleanup = 1; - arrayPtr = NULL; - part1Ptr = part2Ptr = NULL; - - doCallPtrSetVar: - DECACHE_STACK_INFO(); - objResultPtr = TclPtrSetVar(interp, varPtr, arrayPtr, - part1Ptr, part2Ptr, valuePtr, storeFlags, opnd); - CACHE_STACK_INFO(); - if (!objResultPtr) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } -#ifndef TCL_COMPILE_DEBUG - if (*(pc+pcAdjustment) == INST_POP) { - NEXT_INST_V((pcAdjustment+1), cleanup, 0); - } -#endif - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(pcAdjustment, cleanup, 1); - } - - /* - * End of INST_STORE and related instructions. - * ----------------------------------------------------------------- - * Start of INST_INCR instructions. - * - * WARNING: more 'goto' here than your doctor recommended! The different - * instructions set the value of some variables and then jump to somme - * common execution code. - */ - -/*TODO: Consider more untangling here; merge with LOAD and STORE ? */ - - { - Tcl_Obj *incrPtr; -#ifndef NO_WIDE_TYPE - Tcl_WideInt w; -#endif - long increment; - - case INST_INCR_SCALAR1: - case INST_INCR_ARRAY1: - case INST_INCR_ARRAY_STK: - case INST_INCR_SCALAR_STK: - case INST_INCR_STK: - opnd = TclGetUInt1AtPtr(pc+1); - incrPtr = POP_OBJECT(); - switch (*pc) { - case INST_INCR_SCALAR1: - pcAdjustment = 2; - goto doIncrScalar; - case INST_INCR_ARRAY1: - pcAdjustment = 2; - goto doIncrArray; - default: - pcAdjustment = 1; - goto doIncrStk; - } - - case INST_INCR_ARRAY_STK_IMM: - case INST_INCR_SCALAR_STK_IMM: - case INST_INCR_STK_IMM: - increment = TclGetInt1AtPtr(pc+1); - incrPtr = Tcl_NewIntObj(increment); - Tcl_IncrRefCount(incrPtr); - pcAdjustment = 2; - - doIncrStk: - if ((*pc == INST_INCR_ARRAY_STK_IMM) - || (*pc == INST_INCR_ARRAY_STK)) { - part2Ptr = OBJ_AT_TOS; - objPtr = OBJ_UNDER_TOS; - TRACE(("\"%.30s(%.30s)\" (by %ld) => ", - O2S(objPtr), O2S(part2Ptr), increment)); - } else { - part2Ptr = NULL; - objPtr = OBJ_AT_TOS; - TRACE(("\"%.30s\" (by %ld) => ", O2S(objPtr), increment)); - } - part1Ptr = objPtr; - opnd = -1; - varPtr = TclObjLookupVarEx(interp, objPtr, part2Ptr, - TCL_LEAVE_ERR_MSG, "read", 1, 1, &arrayPtr); - if (!varPtr) { - Tcl_AddObjErrorInfo(interp, - "\n (reading value of variable to increment)", -1); - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - Tcl_DecrRefCount(incrPtr); - goto gotError; - } - cleanup = ((part2Ptr == NULL)? 1 : 2); - goto doIncrVar; - - case INST_INCR_ARRAY1_IMM: - opnd = TclGetUInt1AtPtr(pc+1); - increment = TclGetInt1AtPtr(pc+2); - incrPtr = Tcl_NewIntObj(increment); - Tcl_IncrRefCount(incrPtr); - pcAdjustment = 3; - - doIncrArray: - part1Ptr = NULL; - part2Ptr = OBJ_AT_TOS; - arrayPtr = LOCAL(opnd); - cleanup = 1; - while (TclIsVarLink(arrayPtr)) { - arrayPtr = arrayPtr->value.linkPtr; - } - TRACE(("%u \"%.30s\" (by %ld) => ", opnd, O2S(part2Ptr), increment)); - varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, - TCL_LEAVE_ERR_MSG, "read", 1, 1, arrayPtr, opnd); - if (!varPtr) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - Tcl_DecrRefCount(incrPtr); - goto gotError; - } - goto doIncrVar; - - case INST_INCR_SCALAR1_IMM: - opnd = TclGetUInt1AtPtr(pc+1); - increment = TclGetInt1AtPtr(pc+2); - pcAdjustment = 3; - cleanup = 0; - varPtr = LOCAL(opnd); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - - if (TclIsVarDirectModifyable(varPtr)) { - ClientData ptr; - int type; - - objPtr = varPtr->value.objPtr; - if (GetNumberFromObj(NULL, objPtr, &ptr, &type) == TCL_OK) { - if (type == TCL_NUMBER_LONG) { - long augend = *((const long *)ptr); - long sum = augend + increment; - - /* - * Overflow when (augend and sum have different sign) and - * (augend and increment have the same sign). This is - * encapsulated in the Overflowing macro. - */ - - if (!Overflowing(augend, increment, sum)) { - TRACE(("%u %ld => ", opnd, increment)); - if (Tcl_IsShared(objPtr)) { - objPtr->refCount--; /* We know it's shared. */ - TclNewLongObj(objResultPtr, sum); - Tcl_IncrRefCount(objResultPtr); - varPtr->value.objPtr = objResultPtr; - } else { - objResultPtr = objPtr; - TclSetLongObj(objPtr, sum); - } - goto doneIncr; - } -#ifndef NO_WIDE_TYPE - w = (Tcl_WideInt)augend; - - TRACE(("%u %ld => ", opnd, increment)); - if (Tcl_IsShared(objPtr)) { - objPtr->refCount--; /* We know it's shared. */ - objResultPtr = Tcl_NewWideIntObj(w+increment); - Tcl_IncrRefCount(objResultPtr); - varPtr->value.objPtr = objResultPtr; - } else { - objResultPtr = objPtr; - - /* - * We know the sum value is outside the long range; - * use macro form that doesn't range test again. - */ - - TclSetWideIntObj(objPtr, w+increment); - } - goto doneIncr; -#endif - } /* end if (type == TCL_NUMBER_LONG) */ -#ifndef NO_WIDE_TYPE - if (type == TCL_NUMBER_WIDE) { - Tcl_WideInt sum; - - w = *((const Tcl_WideInt *) ptr); - sum = w + increment; - - /* - * Check for overflow. - */ - - if (!Overflowing(w, increment, sum)) { - TRACE(("%u %ld => ", opnd, increment)); - if (Tcl_IsShared(objPtr)) { - objPtr->refCount--; /* We know it's shared. */ - objResultPtr = Tcl_NewWideIntObj(sum); - Tcl_IncrRefCount(objResultPtr); - varPtr->value.objPtr = objResultPtr; - } else { - objResultPtr = objPtr; - - /* - * We *do not* know the sum value is outside the - * long range (wide + long can yield long); use - * the function call that checks range. - */ - - Tcl_SetWideIntObj(objPtr, sum); - } - goto doneIncr; - } - } -#endif - } - if (Tcl_IsShared(objPtr)) { - objPtr->refCount--; /* We know it's shared */ - objResultPtr = Tcl_DuplicateObj(objPtr); - Tcl_IncrRefCount(objResultPtr); - varPtr->value.objPtr = objResultPtr; - } else { - objResultPtr = objPtr; - } - TclNewLongObj(incrPtr, increment); - if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) { - Tcl_DecrRefCount(incrPtr); - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - Tcl_DecrRefCount(incrPtr); - goto doneIncr; - } - - /* - * All other cases, flow through to generic handling. - */ - - TclNewLongObj(incrPtr, increment); - Tcl_IncrRefCount(incrPtr); - - doIncrScalar: - varPtr = LOCAL(opnd); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - arrayPtr = NULL; - part1Ptr = part2Ptr = NULL; - cleanup = 0; - TRACE(("%u %ld => ", opnd, increment)); - - doIncrVar: - if (TclIsVarDirectModifyable2(varPtr, arrayPtr)) { - objPtr = varPtr->value.objPtr; - if (Tcl_IsShared(objPtr)) { - objPtr->refCount--; /* We know it's shared */ - objResultPtr = Tcl_DuplicateObj(objPtr); - Tcl_IncrRefCount(objResultPtr); - varPtr->value.objPtr = objResultPtr; - } else { - objResultPtr = objPtr; - } - if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) { - Tcl_DecrRefCount(incrPtr); - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - Tcl_DecrRefCount(incrPtr); - } else { - DECACHE_STACK_INFO(); - objResultPtr = TclPtrIncrObjVar(interp, varPtr, arrayPtr, - part1Ptr, part2Ptr, incrPtr, TCL_LEAVE_ERR_MSG, opnd); - CACHE_STACK_INFO(); - Tcl_DecrRefCount(incrPtr); - if (objResultPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - } - doneIncr: - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); -#ifndef TCL_COMPILE_DEBUG - if (*(pc+pcAdjustment) == INST_POP) { - NEXT_INST_V((pcAdjustment+1), cleanup, 0); - } -#endif - NEXT_INST_V(pcAdjustment, cleanup, 1); - } - - /* - * End of INST_INCR instructions. - * ----------------------------------------------------------------- - * Start of INST_EXIST instructions. - */ - - case INST_EXIST_SCALAR: - opnd = TclGetUInt4AtPtr(pc+1); - varPtr = LOCAL(opnd); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - TRACE(("%u => ", opnd)); - if (ReadTraced(varPtr)) { - DECACHE_STACK_INFO(); - TclObjCallVarTraces(iPtr, NULL, varPtr, NULL, NULL, - TCL_TRACE_READS, 0, opnd); - CACHE_STACK_INFO(); - if (TclIsVarUndefined(varPtr)) { - TclCleanupVar(varPtr, NULL); - varPtr = NULL; - } - } - - /* - * Tricky! Arrays always exist. - */ - - objResultPtr = TCONST(!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1); - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(5, 0, 1); - - case INST_EXIST_ARRAY: - opnd = TclGetUInt4AtPtr(pc+1); - part2Ptr = OBJ_AT_TOS; - arrayPtr = LOCAL(opnd); - while (TclIsVarLink(arrayPtr)) { - arrayPtr = arrayPtr->value.linkPtr; - } - TRACE(("%u \"%.30s\" => ", opnd, O2S(part2Ptr))); - if (TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr)) { - varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); - if (!varPtr || !ReadTraced(varPtr)) { - goto doneExistArray; - } - } - varPtr = TclLookupArrayElement(interp, NULL, part2Ptr, 0, "access", - 0, 1, arrayPtr, opnd); - if (varPtr) { - if (ReadTraced(varPtr) || (arrayPtr && ReadTraced(arrayPtr))) { - DECACHE_STACK_INFO(); - TclObjCallVarTraces(iPtr, arrayPtr, varPtr, NULL, part2Ptr, - TCL_TRACE_READS, 0, opnd); - CACHE_STACK_INFO(); - } - if (TclIsVarUndefined(varPtr)) { - TclCleanupVar(varPtr, arrayPtr); - varPtr = NULL; - } - } - doneExistArray: - objResultPtr = TCONST(!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1); - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(5, 1, 1); - - case INST_EXIST_ARRAY_STK: - cleanup = 2; - part2Ptr = OBJ_AT_TOS; /* element name */ - part1Ptr = OBJ_UNDER_TOS; /* array name */ - TRACE(("\"%.30s(%.30s)\" => ", O2S(part1Ptr), O2S(part2Ptr))); - goto doExistStk; - - case INST_EXIST_STK: - cleanup = 1; - part2Ptr = NULL; - part1Ptr = OBJ_AT_TOS; /* variable name */ - TRACE(("\"%.30s\" => ", O2S(part1Ptr))); - - doExistStk: - varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, 0, "access", - /*createPart1*/0, /*createPart2*/1, &arrayPtr); - if (varPtr) { - if (ReadTraced(varPtr) || (arrayPtr && ReadTraced(arrayPtr))) { - DECACHE_STACK_INFO(); - TclObjCallVarTraces(iPtr, arrayPtr, varPtr, part1Ptr,part2Ptr, - TCL_TRACE_READS, 0, -1); - CACHE_STACK_INFO(); - } - if (TclIsVarUndefined(varPtr)) { - TclCleanupVar(varPtr, arrayPtr); - varPtr = NULL; - } - } - objResultPtr = TCONST(!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1); - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(1, cleanup, 1); - - /* - * End of INST_EXIST instructions. - * ----------------------------------------------------------------- - * Start of INST_UNSET instructions. - */ - - { - int flags; - - case INST_UNSET_SCALAR: - flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0; - opnd = TclGetUInt4AtPtr(pc+2); - varPtr = LOCAL(opnd); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - TRACE(("%s %u\n", (flags?"normal":"noerr"), opnd)); - if (TclIsVarDirectUnsettable(varPtr) && !TclIsVarInHash(varPtr)) { - /* - * No errors, no traces, no searches: just make the variable cease - * to exist. - */ - - if (!TclIsVarUndefined(varPtr)) { - TclDecrRefCount(varPtr->value.objPtr); - } else if (flags & TCL_LEAVE_ERR_MSG) { - goto slowUnsetScalar; - } - varPtr->value.objPtr = NULL; - NEXT_INST_F(6, 0, 0); - } - - slowUnsetScalar: - DECACHE_STACK_INFO(); - if (TclPtrUnsetVar(interp, varPtr, NULL, NULL, NULL, flags, - opnd) != TCL_OK && flags) { - goto errorInUnset; - } - CACHE_STACK_INFO(); - NEXT_INST_F(6, 0, 0); - - case INST_UNSET_ARRAY: - flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0; - opnd = TclGetUInt4AtPtr(pc+2); - part2Ptr = OBJ_AT_TOS; - arrayPtr = LOCAL(opnd); - while (TclIsVarLink(arrayPtr)) { - arrayPtr = arrayPtr->value.linkPtr; - } - TRACE(("%s %u \"%.30s\"\n", - (flags ? "normal" : "noerr"), opnd, O2S(part2Ptr))); - if (TclIsVarArray(arrayPtr) && !UnsetTraced(arrayPtr)) { - varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); - if (varPtr && TclIsVarDirectUnsettable(varPtr)) { - /* - * No nasty traces and element exists, so we can proceed to - * unset it. Might still not exist though... - */ - - if (!TclIsVarUndefined(varPtr)) { - TclDecrRefCount(varPtr->value.objPtr); - } else if (flags & TCL_LEAVE_ERR_MSG) { - goto slowUnsetArray; - } - varPtr->value.objPtr = NULL; - NEXT_INST_F(6, 1, 0); - } else if (!varPtr && !(flags & TCL_LEAVE_ERR_MSG)) { - /* - * Don't need to do anything here. - */ - - NEXT_INST_F(6, 1, 0); - } - } - slowUnsetArray: - DECACHE_STACK_INFO(); - varPtr = TclLookupArrayElement(interp, NULL, part2Ptr, flags, "unset", - 0, 0, arrayPtr, opnd); - if (!varPtr) { - if (flags & TCL_LEAVE_ERR_MSG) { - goto errorInUnset; - } - } else if (TclPtrUnsetVar(interp, varPtr, arrayPtr, NULL, part2Ptr, - flags, opnd) != TCL_OK && (flags & TCL_LEAVE_ERR_MSG)) { - goto errorInUnset; - } - CACHE_STACK_INFO(); - NEXT_INST_F(6, 1, 0); - - case INST_UNSET_ARRAY_STK: - flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0; - cleanup = 2; - part2Ptr = OBJ_AT_TOS; /* element name */ - part1Ptr = OBJ_UNDER_TOS; /* array name */ - TRACE(("%s \"%.30s(%.30s)\"\n", (flags?"normal":"noerr"), - O2S(part1Ptr), O2S(part2Ptr))); - goto doUnsetStk; - - case INST_UNSET_STK: - flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0; - cleanup = 1; - part2Ptr = NULL; - part1Ptr = OBJ_AT_TOS; /* variable name */ - TRACE(("%s \"%.30s\"\n", (flags?"normal":"noerr"), O2S(part1Ptr))); - - doUnsetStk: - DECACHE_STACK_INFO(); - if (TclObjUnsetVar2(interp, part1Ptr, part2Ptr, flags) != TCL_OK - && (flags & TCL_LEAVE_ERR_MSG)) { - goto errorInUnset; - } - CACHE_STACK_INFO(); - NEXT_INST_V(2, cleanup, 0); - - errorInUnset: - CACHE_STACK_INFO(); - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - goto gotError; - - /* - * This is really an unset operation these days. Do not issue. - */ - - case INST_DICT_DONE: - opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u\n", opnd)); - varPtr = LOCAL(opnd); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - if (TclIsVarDirectUnsettable(varPtr) && !TclIsVarInHash(varPtr)) { - if (!TclIsVarUndefined(varPtr)) { - TclDecrRefCount(varPtr->value.objPtr); - } - varPtr->value.objPtr = NULL; - } else { - DECACHE_STACK_INFO(); - TclPtrUnsetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd); - CACHE_STACK_INFO(); - } NEXT_INST_F(5, 0, 0); - } - - /* - * End of INST_UNSET instructions. - * ----------------------------------------------------------------- - * Start of INST_ARRAY instructions. - */ - - case INST_ARRAY_EXISTS_IMM: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - cleanup = 0; - part1Ptr = NULL; - arrayPtr = NULL; - TRACE(("%u => ", opnd)); - varPtr = LOCAL(opnd); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - goto doArrayExists; - case INST_ARRAY_EXISTS_STK: - opnd = -1; - pcAdjustment = 1; - cleanup = 1; - part1Ptr = OBJ_AT_TOS; - TRACE(("\"%.30s\" => ", O2S(part1Ptr))); - varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, 0, NULL, - /*createPart1*/0, /*createPart2*/0, &arrayPtr); - doArrayExists: - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - DECACHE_STACK_INFO(); - result = TclObjCallVarTraces(iPtr, arrayPtr, varPtr, part1Ptr, - NULL, (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY| - TCL_GLOBAL_ONLY|TCL_TRACE_ARRAY), 1, opnd); - CACHE_STACK_INFO(); - if (result == TCL_ERROR) { - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - } - if (varPtr && TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { - objResultPtr = TCONST(1); - } else { - objResultPtr = TCONST(0); - } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(pcAdjustment, cleanup, 1); - - case INST_ARRAY_MAKE_IMM: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - cleanup = 0; - part1Ptr = NULL; - arrayPtr = NULL; - TRACE(("%u => ", opnd)); - varPtr = LOCAL(opnd); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - goto doArrayMake; - case INST_ARRAY_MAKE_STK: - opnd = -1; - pcAdjustment = 1; - cleanup = 1; - part1Ptr = OBJ_AT_TOS; - TRACE(("\"%.30s\" => ", O2S(part1Ptr))); - varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, TCL_LEAVE_ERR_MSG, - "set", /*createPart1*/1, /*createPart2*/0, &arrayPtr); - if (varPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - doArrayMake: - if (varPtr && !TclIsVarArray(varPtr)) { - if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) { - /* - * Either an array element, or a scalar: lose! - */ - - TclObjVarErrMsg(interp, part1Ptr, NULL, "array set", - "variable isn't array", opnd); - Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); - TRACE_APPEND(("ERROR: bad array ref: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - TclSetVarArray(varPtr); - varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable)); - TclInitVarHashTable(varPtr->value.tablePtr, - TclGetVarNsPtr(varPtr)); -#ifdef TCL_COMPILE_DEBUG - TRACE_APPEND(("done\n")); - } else { - TRACE_APPEND(("nothing to do\n")); -#endif - } - NEXT_INST_V(pcAdjustment, cleanup, 0); /* - * End of INST_ARRAY instructions. - * ----------------------------------------------------------------- - * Start of variable linking instructions. - */ - - { - Var *otherPtr; - CallFrame *framePtr, *savedFramePtr; - Tcl_Namespace *nsPtr; - Namespace *savedNsPtr; - - case INST_UPVAR: - TRACE_WITH_OBJ(("upvar "), OBJ_UNDER_TOS); - - if (TclObjGetFrame(interp, OBJ_UNDER_TOS, &framePtr) == -1) { - goto gotError; - } - - /* - * Locate the other variable. - */ - - savedFramePtr = iPtr->varFramePtr; - iPtr->varFramePtr = framePtr; - otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL, - TCL_LEAVE_ERR_MSG, "access", /*createPart1*/ 1, - /*createPart2*/ 1, &varPtr); - iPtr->varFramePtr = savedFramePtr; - if (!otherPtr) { - goto gotError; - } - goto doLinkVars; - - case INST_NSUPVAR: - TRACE_WITH_OBJ(("nsupvar "), OBJ_UNDER_TOS); - if (TclGetNamespaceFromObj(interp, OBJ_UNDER_TOS, &nsPtr) != TCL_OK) { - goto gotError; - } - - /* - * Locate the other variable. - */ - - savedNsPtr = iPtr->varFramePtr->nsPtr; - iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr; - otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL, - (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access", - /*createPart1*/ 1, /*createPart2*/ 1, &varPtr); - iPtr->varFramePtr->nsPtr = savedNsPtr; - if (!otherPtr) { - goto gotError; - } - goto doLinkVars; - - case INST_VARIABLE: - TRACE(("variable ")); - otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL, - (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access", - /*createPart1*/ 1, /*createPart2*/ 1, &varPtr); - if (!otherPtr) { - goto gotError; - } - - /* - * Do the [variable] magic. - */ - - TclSetVarNamespaceVar(otherPtr); - - doLinkVars: - - /* - * If we are here, the local variable has already been created: do the - * little work of TclPtrMakeUpvar that remains to be done right here - * if there are no errors; otherwise, let it handle the case. - */ - - opnd = TclGetInt4AtPtr(pc+1);; - varPtr = LOCAL(opnd); - if ((varPtr != otherPtr) && !TclIsVarTraced(varPtr) - && (TclIsVarUndefined(varPtr) || TclIsVarLink(varPtr))) { - if (!TclIsVarUndefined(varPtr)) { - /* - * Then it is a defined link. - */ - - Var *linkPtr = varPtr->value.linkPtr; - - if (linkPtr == otherPtr) { - NEXT_INST_F(5, 1, 0); - } - if (TclIsVarInHash(linkPtr)) { - VarHashRefCount(linkPtr)--; - if (TclIsVarUndefined(linkPtr)) { - TclCleanupVar(linkPtr, NULL); - } - } - } - TclSetVarLink(varPtr); - varPtr->value.linkPtr = otherPtr; - if (TclIsVarInHash(otherPtr)) { - VarHashRefCount(otherPtr)++; - } - } else if (TclPtrObjMakeUpvar(interp, otherPtr, NULL, 0, - opnd) != TCL_OK) { - goto gotError; - } - - /* - * Do not pop the namespace or frame index, it may be needed for other - * variables - and [variable] did not push it at all. - */ - - NEXT_INST_F(5, 1, 0); - } - - /* - * End of variable linking instructions. - * ----------------------------------------------------------------- + * End of INST_STORE and related instructions. */ - case INST_JUMP1: - opnd = TclGetInt1AtPtr(pc+1); - TRACE(("%d => new pc %u\n", opnd, - (unsigned)(pc + opnd - codePtr->codeStart))); - NEXT_INST_F(opnd, 0, 0); - case INST_JUMP4: opnd = TclGetInt4AtPtr(pc+1); - TRACE(("%d => new pc %u\n", opnd, - (unsigned)(pc + opnd - codePtr->codeStart))); NEXT_INST_F(opnd, 0, 0); { @@ -4020,551 +1976,32 @@ TEBCresume( jmpOffset[1] = TclGetInt4AtPtr(pc+1); goto doCondJump; - case INST_JUMP_FALSE1: - jmpOffset[0] = TclGetInt1AtPtr(pc+1); - jmpOffset[1] = 2; - goto doCondJump; - - case INST_JUMP_TRUE1: - jmpOffset[0] = 2; - jmpOffset[1] = TclGetInt1AtPtr(pc+1); - doCondJump: valuePtr = OBJ_AT_TOS; /* TODO - check claim that taking address of b harms performance */ /* TODO - consider optimization search for constants */ if (TclGetBooleanFromObj(interp, valuePtr, &b) != TCL_OK) { - TRACE_WITH_OBJ(("%d => ERROR: ", jmpOffset[ - ((*pc == INST_JUMP_FALSE1) || (*pc == INST_JUMP_FALSE4)) - ? 0 : 1]), Tcl_GetObjResult(interp)); goto gotError; } -#ifdef TCL_COMPILE_DEBUG - if (b) { - if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) { - TRACE(("%d => %.20s true, new pc %u\n", jmpOffset[1], - O2S(valuePtr), - (unsigned)(pc + jmpOffset[1] - codePtr->codeStart))); - } else { - TRACE(("%d => %.20s true\n", jmpOffset[0], O2S(valuePtr))); - } - } else { - if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) { - TRACE(("%d => %.20s false\n", jmpOffset[0], O2S(valuePtr))); - } else { - TRACE(("%d => %.20s false, new pc %u\n", jmpOffset[0], - O2S(valuePtr), - (unsigned)(pc + jmpOffset[1] - codePtr->codeStart))); - } - } -#endif NEXT_INST_F(jmpOffset[b], 1, 0); } - case INST_JUMP_TABLE: { - Tcl_HashEntry *hPtr; - JumptableInfo *jtPtr; - - /* - * Jump to location looked up in a hashtable; fall through to next - * instr if lookup fails. - */ - - opnd = TclGetInt4AtPtr(pc+1); - jtPtr = (JumptableInfo *) codePtr->auxDataArrayPtr[opnd].clientData; - TRACE(("%d => %.20s ", opnd, O2S(OBJ_AT_TOS))); - hPtr = Tcl_FindHashEntry(&jtPtr->hashTable, TclGetString(OBJ_AT_TOS)); - if (hPtr != NULL) { - int jumpOffset = PTR2INT(Tcl_GetHashValue(hPtr)); - - TRACE_APPEND(("found in table, new pc %u\n", - (unsigned)(pc - codePtr->codeStart + jumpOffset))); - NEXT_INST_F(jumpOffset, 1, 0); - } else { - TRACE_APPEND(("not found in table\n")); - NEXT_INST_F(5, 1, 0); - } - } - - /* - * These two instructions are now redundant: the complete logic of the LOR - * and LAND is now handled by the expression compiler. - */ - - case INST_LOR: - case INST_LAND: { - /* - * Operands must be boolean or numeric. No int->double conversions are - * performed. - */ - - int i1, i2, iResult; - - value2Ptr = OBJ_AT_TOS; - valuePtr = OBJ_UNDER_TOS; - if (TclGetBooleanFromObj(NULL, valuePtr, &i1) != TCL_OK) { - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), - (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); - DECACHE_STACK_INFO(); - IllegalExprOperandType(interp, pc, valuePtr); - CACHE_STACK_INFO(); - goto gotError; - } - - if (TclGetBooleanFromObj(NULL, value2Ptr, &i2) != TCL_OK) { - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr), - (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); - DECACHE_STACK_INFO(); - IllegalExprOperandType(interp, pc, value2Ptr); - CACHE_STACK_INFO(); - goto gotError; - } - - if (*pc == INST_LOR) { - iResult = (i1 || i2); - } else { - iResult = (i1 && i2); - } - objResultPtr = TCONST(iResult); - TRACE(("%.20s %.20s => %d\n", O2S(valuePtr),O2S(value2Ptr),iResult)); - NEXT_INST_F(1, 2, 1); - } - /* * ----------------------------------------------------------------- * Start of general introspector instructions. */ - case INST_NS_CURRENT: { - Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); - - if (currNsPtr == (Namespace *) TclGetGlobalNamespace(interp)) { - TclNewLiteralStringObj(objResultPtr, "::"); - } else { - TclNewStringObj(objResultPtr, currNsPtr->fullName, - strlen(currNsPtr->fullName)); - } - TRACE_WITH_OBJ(("=> "), objResultPtr); - NEXT_INST_F(1, 0, 1); - } - case INST_COROUTINE_NAME: { - CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; - - TclNewObj(objResultPtr); - if (corPtr && !(corPtr->cmdPtr->flags & CMD_IS_DELETED)) { - Tcl_GetCommandFullName(interp, (Tcl_Command) corPtr->cmdPtr, - objResultPtr); - } - TRACE_WITH_OBJ(("=> "), objResultPtr); - NEXT_INST_F(1, 0, 1); - } - case INST_INFO_LEVEL_NUM: - TclNewIntObj(objResultPtr, iPtr->varFramePtr->level); - TRACE_WITH_OBJ(("=> "), objResultPtr); - NEXT_INST_F(1, 0, 1); - case INST_INFO_LEVEL_ARGS: { - int level; - register CallFrame *framePtr = iPtr->varFramePtr; - register CallFrame *rootFramePtr = iPtr->rootFramePtr; - - valuePtr = OBJ_AT_TOS; - if (TclGetIntFromObj(interp, valuePtr, &level) != TCL_OK) { - TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)), - Tcl_GetObjResult(interp)); - goto gotError; - } - TRACE(("%d => ", level)); - if (level <= 0) { - level += framePtr->level; - } - for (; (framePtr->level!=level) && (framePtr!=rootFramePtr) ; - framePtr = framePtr->callerVarPtr) { - /* Empty loop body */ - } - if (framePtr == rootFramePtr) { - Tcl_AppendResult(interp, "bad level \"", TclGetString(valuePtr), - "\"", NULL); - TRACE_APPEND(("ERROR: bad level\n")); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_LEVEL", - TclGetString(valuePtr), NULL); - goto gotError; - } - objResultPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv); - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 1, 1); - } - case INST_RESOLVE_COMMAND: { - Tcl_Command cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS); - - TclNewObj(objResultPtr); - if (cmd != NULL) { - Tcl_GetCommandFullName(interp, cmd, objResultPtr); - } - TRACE_WITH_OBJ(("\"%.20s\" => ", O2S(OBJ_AT_TOS)), objResultPtr); - NEXT_INST_F(1, 1, 1); - } - case INST_TCLOO_SELF: { - CallFrame *framePtr = iPtr->varFramePtr; - CallContext *contextPtr; - - if (framePtr == NULL || - !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { - TRACE(("=> ERROR: no TclOO call context\n")); - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "self may only be called from inside a method", - -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); - goto gotError; - } - contextPtr = framePtr->clientData; - - /* - * Call out to get the name; it's expensive to compute but cached. - */ - - objResultPtr = TclOOObjectName(interp, contextPtr->oPtr); - TRACE_WITH_OBJ(("=> "), objResultPtr); - NEXT_INST_F(1, 0, 1); - } - { - Object *oPtr; - - case INST_TCLOO_IS_OBJECT: - oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS); - objResultPtr = TCONST(oPtr != NULL ? 1 : 0); - TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr); - NEXT_INST_F(1, 1, 1); - case INST_TCLOO_CLASS: - oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS); - if (oPtr == NULL) { - TRACE(("%.30s => ERROR: not object\n", O2S(OBJ_AT_TOS))); - goto gotError; - } - objResultPtr = TclOOObjectName(interp, oPtr->selfCls->thisPtr); - TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr); - NEXT_INST_F(1, 1, 1); - case INST_TCLOO_NS: - oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS); - if (oPtr == NULL) { - TRACE(("%.30s => ERROR: not object\n", O2S(OBJ_AT_TOS))); - goto gotError; - } - - /* - * TclOO objects *never* have the global namespace as their NS. - */ - - TclNewStringObj(objResultPtr, oPtr->namespacePtr->fullName, - strlen(oPtr->namespacePtr->fullName)); - TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr); - NEXT_INST_F(1, 1, 1); - } - /* * ----------------------------------------------------------------- * Start of INST_LIST and related instructions. */ { - int index, numIndices, fromIdx, toIdx; - int nocase, match, length2, cflags, s1len, s2len; + int match, s1len, s2len; const char *s1, *s2; - case INST_LIST: - /* - * Pop the opnd (objc) top stack elements into a new list obj and then - * decrement their ref counts. - */ - - opnd = TclGetUInt4AtPtr(pc+1); - objResultPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1)); - TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); - NEXT_INST_V(5, opnd, 1); - - case INST_LIST_LENGTH: - valuePtr = OBJ_AT_TOS; - if (TclListObjLength(interp, valuePtr, &length) != TCL_OK) { - TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)), - Tcl_GetObjResult(interp)); - goto gotError; - } - TclNewIntObj(objResultPtr, length); - TRACE(("%.20s => %d\n", O2S(valuePtr), length)); - NEXT_INST_F(1, 1, 1); - - case INST_LIST_INDEX: /* lindex with objc == 3 */ - value2Ptr = OBJ_AT_TOS; - valuePtr = OBJ_UNDER_TOS; - - /* - * Extract the desired list element. - */ - - if ((TclListObjGetElements(interp, valuePtr, &objc, &objv) == TCL_OK) - && (value2Ptr->typePtr != &tclListType) - && (TclGetIntForIndexM(NULL , value2Ptr, objc-1, - &index) == TCL_OK)) { - TclDecrRefCount(value2Ptr); - tosPtr--; - pcAdjustment = 1; - goto lindexFastPath; - } - - objResultPtr = TclLindexList(interp, valuePtr, value2Ptr); - if (!objResultPtr) { - TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", O2S(valuePtr), - O2S(value2Ptr)), Tcl_GetObjResult(interp)); - goto gotError; - } - - /* - * Stash the list element on the stack. - */ - - TRACE(("%.20s %.20s => %s\n", - O2S(valuePtr), O2S(value2Ptr), O2S(objResultPtr))); - NEXT_INST_F(1, 2, -1); /* Already has the correct refCount */ - - case INST_LIST_INDEX_IMM: /* lindex with objc==3 and index in bytecode - * stream */ - - /* - * Pop the list and get the index. - */ - - valuePtr = OBJ_AT_TOS; - opnd = TclGetInt4AtPtr(pc+1); - - /* - * Get the contents of the list, making sure that it really is a list - * in the process. - */ - - if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { - TRACE_WITH_OBJ(("\"%.30s\" %d => ERROR: ", O2S(valuePtr), opnd), - Tcl_GetObjResult(interp)); - goto gotError; - } - - /* - * Select the list item based on the index. Negative operand means - * end-based indexing. - */ - - if (opnd < -1) { - index = opnd+1 + objc; - } else { - index = opnd; - } - pcAdjustment = 5; - - lindexFastPath: - if (index >= 0 && index < objc) { - objResultPtr = objv[index]; - } else { - TclNewObj(objResultPtr); - } - - TRACE_WITH_OBJ(("\"%.30s\" %d => ", O2S(valuePtr), opnd), - objResultPtr); - NEXT_INST_F(pcAdjustment, 1, 1); - - case INST_LIST_INDEX_MULTI: /* 'lindex' with multiple index args */ - /* - * Determine the count of index args. - */ - - opnd = TclGetUInt4AtPtr(pc+1); - numIndices = opnd-1; - - /* - * Do the 'lindex' operation. - */ - - objResultPtr = TclLindexFlat(interp, OBJ_AT_DEPTH(numIndices), - numIndices, &OBJ_AT_DEPTH(numIndices - 1)); - if (!objResultPtr) { - TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp)); - goto gotError; - } - - /* - * Set result. - */ - - TRACE(("%d => %s\n", opnd, O2S(objResultPtr))); - NEXT_INST_V(5, opnd, -1); - - case INST_LSET_FLAT: - /* - * Lset with 3, 5, or more args. Get the number of index args. - */ - - opnd = TclGetUInt4AtPtr(pc + 1); - numIndices = opnd - 2; - - /* - * Get the old value of variable, and remove the stack ref. This is - * safe because the variable still references the object; the ref - * count will never go zero here - we can use the smaller macro - * Tcl_DecrRefCount. - */ - - valuePtr = POP_OBJECT(); - Tcl_DecrRefCount(valuePtr); /* This one should be done here */ - - /* - * Compute the new variable value. - */ - - objResultPtr = TclLsetFlat(interp, valuePtr, numIndices, - &OBJ_AT_DEPTH(numIndices), OBJ_AT_TOS); - if (!objResultPtr) { - TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp)); - goto gotError; - } - - /* - * Set result. - */ - - TRACE(("%d => %s\n", opnd, O2S(objResultPtr))); - NEXT_INST_V(5, numIndices+1, -1); - - case INST_LSET_LIST: /* 'lset' with 4 args */ - /* - * Get the old value of variable, and remove the stack ref. This is - * safe because the variable still references the object; the ref - * count will never go zero here - we can use the smaller macro - * Tcl_DecrRefCount. - */ - - objPtr = POP_OBJECT(); - Tcl_DecrRefCount(objPtr); /* This one should be done here. */ - - /* - * Get the new element value, and the index list. - */ - - valuePtr = OBJ_AT_TOS; - value2Ptr = OBJ_UNDER_TOS; - - /* - * Compute the new variable value. - */ - - objResultPtr = TclLsetList(interp, objPtr, value2Ptr, valuePtr); - if (!objResultPtr) { - TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(value2Ptr)), - Tcl_GetObjResult(interp)); - goto gotError; - } - - /* - * Set result. - */ - - TRACE(("=> %s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, -1); - - case INST_LIST_RANGE_IMM: /* lrange with objc==4 and both indices in - * bytecode stream */ - - /* - * Pop the list and get the indices. - */ - - valuePtr = OBJ_AT_TOS; - fromIdx = TclGetInt4AtPtr(pc+1); - toIdx = TclGetInt4AtPtr(pc+5); - - /* - * Get the contents of the list, making sure that it really is a list - * in the process. - */ - - if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { - TRACE_WITH_OBJ(("\"%.30s\" %d %d => ERROR: ", O2S(valuePtr), - fromIdx, toIdx), Tcl_GetObjResult(interp)); - goto gotError; - } - - /* - * Skip a lot of work if we're about to throw the result away (common - * with uses of [lassign]). - */ - -#ifndef TCL_COMPILE_DEBUG - if (*(pc+9) == INST_POP) { - NEXT_INST_F(10, 1, 0); - } -#endif - - /* - * Adjust the indices for end-based handling. - */ - - if (fromIdx < -1) { - fromIdx += 1+objc; - if (fromIdx < -1) { - fromIdx = -1; - } - } else if (fromIdx > objc) { - fromIdx = objc; - } - if (toIdx < -1) { - toIdx += 1 + objc; - if (toIdx < -1) { - toIdx = -1; - } - } else if (toIdx > objc) { - toIdx = objc; - } - - /* - * Check if we are referring to a valid, non-empty list range, and if - * so, build the list of elements in that range. - */ - - if (fromIdx<=toIdx && fromIdx<objc && toIdx>=0) { - if (fromIdx < 0) { - fromIdx = 0; - } - if (toIdx >= objc) { - toIdx = objc-1; - } - if (fromIdx == 0 && toIdx != objc-1 && !Tcl_IsShared(valuePtr)) { - /* - * BEWARE! This is looking inside the implementation of the - * list type. - */ - - List *listPtr = valuePtr->internalRep.twoPtrValue.ptr1; - - if (listPtr->refCount == 1) { - TRACE(("\"%.30s\" %d %d => ", O2S(valuePtr), - TclGetInt4AtPtr(pc+1), TclGetInt4AtPtr(pc+5))); - for (index=toIdx+1 ; index<objc-1 ; index++) { - TclDecrRefCount(objv[index]); - } - listPtr->elemCount = toIdx+1; - listPtr->canonicalFlag = 1; - TclInvalidateStringRep(valuePtr); - TRACE_APPEND(("%.30s\n", O2S(valuePtr))); - NEXT_INST_F(9, 0, 0); - } - } - objResultPtr = Tcl_NewListObj(toIdx-fromIdx+1, objv+fromIdx); - } else { - TclNewObj(objResultPtr); - } - - TRACE_WITH_OBJ(("\"%.30s\" %d %d => ", O2S(valuePtr), - TclGetInt4AtPtr(pc+1), TclGetInt4AtPtr(pc+5)), objResultPtr); - NEXT_INST_F(9, 1, 1); - case INST_LIST_IN: case INST_LIST_NOT_IN: /* Basic list containment operators. */ value2Ptr = OBJ_AT_TOS; @@ -4572,8 +2009,6 @@ TEBCresume( s1 = TclGetStringFromObj(valuePtr, &s1len); if (TclListObjLength(interp, value2Ptr, &length) != TCL_OK) { - TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ERROR: ", O2S(valuePtr), - O2S(value2Ptr)), Tcl_GetObjResult(interp)); goto gotError; } match = 0; @@ -4604,8 +2039,6 @@ TEBCresume( match = !match; } - TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match)); - /* * Peep-hole optimisation: if you're about to jump, do jump from here. * We're saving the effort of pushing a boolean value only to pop it @@ -4613,30 +2046,11 @@ TEBCresume( */ pc++; -#ifndef TCL_COMPILE_DEBUG - switch (*pc) { - case INST_JUMP_FALSE1: - NEXT_INST_F((match ? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE1: - NEXT_INST_F((match ? TclGetInt1AtPtr(pc+1) : 2), 2, 0); - case INST_JUMP_FALSE4: - NEXT_INST_F((match ? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE4: - NEXT_INST_F((match ? TclGetInt4AtPtr(pc+1) : 5), 2, 0); - } -#endif objResultPtr = TCONST(match); NEXT_INST_F(0, 2, 1); - /* - * End of INST_LIST and related instructions. - * ----------------------------------------------------------------- - * Start of string-related instructions. - */ - - case INST_STR_EQ: + case INST_STR_EQ: case INST_STR_NEQ: /* String (in)equality check */ - case INST_STR_CMP: /* String compare. */ stringCompare: value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; @@ -4728,7 +2142,7 @@ TEBCresume( * TODO: consider peephole opt. */ - if (*pc != INST_STR_CMP) { + if (1) { /* * Take care of the opcodes that goto'ed into here. */ @@ -4761,334 +2175,8 @@ TEBCresume( } else { objResultPtr = TCONST(match > 0); } - TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr), - O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); - case INST_STR_LEN: - valuePtr = OBJ_AT_TOS; - length = Tcl_GetCharLength(valuePtr); - TclNewIntObj(objResultPtr, length); - TRACE(("%.20s => %d\n", O2S(valuePtr), length)); - NEXT_INST_F(1, 1, 1); - - case INST_STR_INDEX: - value2Ptr = OBJ_AT_TOS; - valuePtr = OBJ_UNDER_TOS; - - /* - * Get char length to calulate what 'end' means. - */ - - length = Tcl_GetCharLength(valuePtr); - if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) { - goto gotError; - } - - if ((index < 0) || (index >= length)) { - TclNewObj(objResultPtr); - } else if (TclIsPureByteArray(valuePtr)) { - objResultPtr = Tcl_NewByteArrayObj( - Tcl_GetByteArrayFromObj(valuePtr, &length)+index, 1); - } else if (valuePtr->bytes && length == valuePtr->length) { - objResultPtr = Tcl_NewStringObj((const char *) - valuePtr->bytes+index, 1); - } else { - char buf[TCL_UTF_MAX]; - Tcl_UniChar ch = Tcl_GetUniChar(valuePtr, index); - - /* - * This could be: Tcl_NewUnicodeObj((const Tcl_UniChar *)&ch, 1) - * but creating the object as a string seems to be faster in - * practical use. - */ - - length = Tcl_UniCharToUtf(ch, buf); - objResultPtr = Tcl_NewStringObj(buf, length); - } - - TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr), - O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - - case INST_STR_RANGE: - TRACE(("\"%.20s\" %s %s =>", - O2S(OBJ_AT_DEPTH(2)), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS))); - length = Tcl_GetCharLength(OBJ_AT_DEPTH(2)) - 1; - if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length, - &fromIdx) != TCL_OK - || TclGetIntForIndexM(interp, OBJ_AT_TOS, length, - &toIdx) != TCL_OK) { - goto gotError; - } - - if (fromIdx < 0) { - fromIdx = 0; - } - if (toIdx >= length) { - toIdx = length; - } - if (toIdx >= fromIdx) { - objResultPtr = Tcl_GetRange(OBJ_AT_DEPTH(2), fromIdx, toIdx); - } else { - TclNewObj(objResultPtr); - } - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); - NEXT_INST_V(1, 3, 1); - - case INST_STR_RANGE_IMM: - valuePtr = OBJ_AT_TOS; - fromIdx = TclGetInt4AtPtr(pc+1); - toIdx = TclGetInt4AtPtr(pc+5); - length = Tcl_GetCharLength(valuePtr); - TRACE(("\"%.20s\" %d %d => ", O2S(valuePtr), fromIdx, toIdx)); - - /* - * Adjust indices for end-based indexing. - */ - - if (fromIdx < -1) { - fromIdx += 1 + length; - if (fromIdx < 0) { - fromIdx = 0; - } - } else if (fromIdx >= length) { - fromIdx = length; - } - if (toIdx < -1) { - toIdx += 1 + length; - } else if (toIdx >= length) { - toIdx = length - 1; - } - - /* - * Check if we can do a sane substring. - */ - - if (fromIdx <= toIdx) { - objResultPtr = Tcl_GetRange(valuePtr, fromIdx, toIdx); - } else { - TclNewObj(objResultPtr); - } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(9, 1, 1); - - { - Tcl_UniChar *ustring1, *ustring2, *ustring3, *end, *p; - int length3; - Tcl_Obj *value3Ptr; - - case INST_STR_MAP: - valuePtr = OBJ_AT_TOS; /* "Main" string. */ - value3Ptr = OBJ_UNDER_TOS; /* "Target" string. */ - value2Ptr = OBJ_AT_DEPTH(2); /* "Source" string. */ - if (value3Ptr == value2Ptr) { - objResultPtr = valuePtr; - NEXT_INST_V(1, 3, 1); - } else if (valuePtr == value2Ptr) { - objResultPtr = value3Ptr; - NEXT_INST_V(1, 3, 1); - } - ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length); - if (length == 0) { - objResultPtr = valuePtr; - NEXT_INST_V(1, 3, 1); - } - ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2); - if (length2 > length || length2 == 0) { - objResultPtr = valuePtr; - NEXT_INST_V(1, 3, 1); - } else if (length2 == length) { - if (memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length)) { - objResultPtr = valuePtr; - } else { - objResultPtr = value3Ptr; - } - NEXT_INST_V(1, 3, 1); - } - ustring3 = Tcl_GetUnicodeFromObj(value3Ptr, &length3); - - objResultPtr = Tcl_NewUnicodeObj(ustring1, 0); - p = ustring1; - end = ustring1 + length; - for (; ustring1 < end; ustring1++) { - if ((*ustring1 == *ustring2) && (length2==1 || - memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length2) - == 0)) { - if (p != ustring1) { - Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1-p); - p = ustring1 + length2; - } else { - p += length2; - } - ustring1 = p - 1; - - Tcl_AppendUnicodeToObj(objResultPtr, ustring3, length3); - } - } - if (p != ustring1) { - /* - * Put the rest of the unmapped chars onto result. - */ - - Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1 - p); - } - TRACE_WITH_OBJ(("%.20s %.20s %.20s => ", - O2S(value2Ptr), O2S(value3Ptr), O2S(valuePtr)), objResultPtr); - NEXT_INST_V(1, 3, 1); - - case INST_STR_FIND: - ustring1 = Tcl_GetUnicodeFromObj(OBJ_AT_TOS, &length); /* Haystack */ - ustring2 = Tcl_GetUnicodeFromObj(OBJ_UNDER_TOS, &length2);/* Needle */ - - match = -1; - if (length2 > 0 && length2 <= length) { - end = ustring1 + length - length2 + 1; - for (p=ustring1 ; p<end ; p++) { - if ((*p == *ustring2) && - memcmp(ustring2,p,sizeof(Tcl_UniChar)*length2) == 0) { - match = p - ustring1; - break; - } - } - } - - TRACE(("%.20s %.20s => %d\n", - O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match)); - - TclNewIntObj(objResultPtr, match); - NEXT_INST_F(1, 2, 1); - - case INST_STR_FIND_LAST: - ustring1 = Tcl_GetUnicodeFromObj(OBJ_AT_TOS, &length); /* Haystack */ - ustring2 = Tcl_GetUnicodeFromObj(OBJ_UNDER_TOS, &length2);/* Needle */ - - match = -1; - if (length2 > 0 && length2 <= length) { - for (p=ustring1+length-length2 ; p>=ustring1 ; p--) { - if ((*p == *ustring2) && - memcmp(ustring2,p,sizeof(Tcl_UniChar)*length2) == 0) { - match = p - ustring1; - break; - } - } - } - - TRACE(("%.20s %.20s => %d\n", - O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match)); - - TclNewIntObj(objResultPtr, match); - NEXT_INST_F(1, 2, 1); - } - - case INST_STR_MATCH: - nocase = TclGetInt1AtPtr(pc+1); - valuePtr = OBJ_AT_TOS; /* String */ - value2Ptr = OBJ_UNDER_TOS; /* Pattern */ - - /* - * Check that at least one of the objects is Unicode before promoting - * both. - */ - - if ((valuePtr->typePtr == &tclStringType) - || (value2Ptr->typePtr == &tclStringType)) { - Tcl_UniChar *ustring1, *ustring2; - - ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length); - ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2); - match = TclUniCharMatch(ustring1, length, ustring2, length2, - nocase); - } else if (TclIsPureByteArray(valuePtr) && !nocase) { - unsigned char *bytes1, *bytes2; - - bytes1 = Tcl_GetByteArrayFromObj(valuePtr, &length); - bytes2 = Tcl_GetByteArrayFromObj(value2Ptr, &length2); - match = TclByteArrayMatch(bytes1, length, bytes2, length2, 0); - } else { - match = Tcl_StringCaseMatch(TclGetString(valuePtr), - TclGetString(value2Ptr), nocase); - } - - /* - * Reuse value2Ptr object already on stack if possible. Adjustment is - * 2 due to the nocase byte - */ - - TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match)); - - /* - * Peep-hole optimisation: if you're about to jump, do jump from here. - */ - - pc += 2; -#ifndef TCL_COMPILE_DEBUG - switch (*pc) { - case INST_JUMP_FALSE1: - NEXT_INST_F((match? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE1: - NEXT_INST_F((match? TclGetInt1AtPtr(pc+1) : 2), 2, 0); - case INST_JUMP_FALSE4: - NEXT_INST_F((match? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE4: - NEXT_INST_F((match? TclGetInt4AtPtr(pc+1) : 5), 2, 0); - } -#endif - objResultPtr = TCONST(match); - NEXT_INST_F(0, 2, 1); - - case INST_REGEXP: - cflags = TclGetInt1AtPtr(pc+1); /* RE compile flages like NOCASE */ - valuePtr = OBJ_AT_TOS; /* String */ - value2Ptr = OBJ_UNDER_TOS; /* Pattern */ - - /* - * Compile and match the regular expression. - */ - - { - Tcl_RegExp regExpr = - Tcl_GetRegExpFromObj(interp, value2Ptr, cflags); - - if (regExpr == NULL) { - goto regexpFailure; - } - - match = Tcl_RegExpExecObj(interp, regExpr, valuePtr, 0, 0, 0); - - if (match < 0) { - regexpFailure: -#ifdef TCL_COMPILE_DEBUG - objResultPtr = Tcl_GetObjResult(interp); - TRACE_WITH_OBJ(("%.20s %.20s => ERROR: ", - O2S(valuePtr), O2S(value2Ptr)), objResultPtr); -#endif - goto gotError; - } - } - - TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match)); - - /* - * Peep-hole optimisation: if you're about to jump, do jump from here. - * Adjustment is 2 due to the nocase byte. - */ - - pc += 2; -#ifndef TCL_COMPILE_DEBUG - switch (*pc) { - case INST_JUMP_FALSE1: - NEXT_INST_F((match? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE1: - NEXT_INST_F((match? TclGetInt1AtPtr(pc+1) : 2), 2, 0); - case INST_JUMP_FALSE4: - NEXT_INST_F((match? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE4: - NEXT_INST_F((match? TclGetInt4AtPtr(pc+1) : 5), 2, 0); - } -#endif - objResultPtr = TCONST(match); - NEXT_INST_F(0, 2, 1); } /* @@ -5187,18 +2275,6 @@ TEBCresume( foundResult: pc++; -#ifndef TCL_COMPILE_DEBUG - switch (*pc) { - case INST_JUMP_FALSE1: - NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE1: - NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0); - case INST_JUMP_FALSE4: - NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE4: - NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0); - } -#endif objResultPtr = TCONST(iResult); NEXT_INST_F(0, 2, 1); } @@ -5214,23 +2290,15 @@ TEBCresume( if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) || (type1==TCL_NUMBER_DOUBLE) || (type1==TCL_NUMBER_NAN)) { - TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(valuePtr), - O2S(value2Ptr), (valuePtr->typePtr? - valuePtr->typePtr->name : "null"))); - DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); - CACHE_STACK_INFO(); + checkInterp = 1; goto gotError; } if ((GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) || (type2==TCL_NUMBER_DOUBLE) || (type2==TCL_NUMBER_NAN)) { - TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(valuePtr), - O2S(value2Ptr), (value2Ptr->typePtr? - value2Ptr->typePtr->name : "null"))); - DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, value2Ptr); - CACHE_STACK_INFO(); + checkInterp = 1; goto gotError; } @@ -5245,26 +2313,20 @@ TEBCresume( switch (*pc) { case INST_MOD: if (l2 == 0) { - TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr), - O2S(value2Ptr))); goto divideByZero; } else if ((l2 == 1) || (l2 == -1)) { /* * Div. by |1| always yields remainder of 0. */ - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); objResultPtr = TCONST(0); - TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } else if (l1 == 0) { /* * 0 % (non-zero) always yields remainder of 0. */ - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); objResultPtr = TCONST(0); - TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } else { lResult = l1 / l2; @@ -5288,17 +2350,14 @@ TEBCresume( Tcl_SetObjResult(interp, Tcl_NewStringObj( "negative shift argument", -1)); #if 0 - DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "domain error: argument not in valid range", NULL); - CACHE_STACK_INFO(); + checkInterp = 1; #endif goto gotError; } else if (l1 == 0) { - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); objResultPtr = TCONST(0); - TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } else { /* @@ -5313,13 +2372,11 @@ TEBCresume( * 4e9 and the latter 32 or 64... */ - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); if (l1 > 0L) { objResultPtr = TCONST(0); } else { TclNewIntObj(objResultPtr, -1); } - TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } @@ -5336,17 +2393,14 @@ TEBCresume( Tcl_SetObjResult(interp, Tcl_NewStringObj( "negative shift argument", -1)); #if 0 - DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "domain error: argument not in valid range", NULL); - CACHE_STACK_INFO(); + checkInterp = 1; #endif goto gotError; } else if (l1 == 0) { - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); objResultPtr = TCONST(0); - TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } else if (l2 > (long) INT_MAX) { /* @@ -5359,10 +2413,9 @@ TEBCresume( Tcl_SetObjResult(interp, Tcl_NewStringObj( "integer value too large to represent", -1)); #if 0 - DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", "integer value too large to represent", NULL); - CACHE_STACK_INFO(); + checkInterp = 1; #endif goto gotError; } else { @@ -5384,7 +2437,6 @@ TEBCresume( * Too large; need to use the broken-out function. */ - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); break; case INST_BITAND: @@ -5396,14 +2448,11 @@ TEBCresume( case INST_BITXOR: lResult = l1 ^ l2; longResultOfArithmetic: - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); if (Tcl_IsShared(valuePtr)) { TclNewLongObj(objResultPtr, lResult); - TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } TclSetLongObj(valuePtr, lResult); - TRACE(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 0); } } @@ -5414,21 +2463,15 @@ TEBCresume( * is highly undesirable due to the overall impact on size. */ - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); objResultPtr = ExecuteExtendedBinaryMathOp(interp, *pc, &TCONST(0), valuePtr, value2Ptr); if (objResultPtr == DIVIDED_BY_ZERO) { - TRACE_APPEND(("DIVIDE BY ZERO\n")); goto divideByZero; } else if (objResultPtr == GENERAL_ARITHMETIC_ERROR) { - TRACE_APPEND(("ERROR: %s\n", - TclGetString(Tcl_GetObjResult(interp)))); goto gotError; } else if (objResultPtr == NULL) { - TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 0); } else { - TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } @@ -5442,12 +2485,8 @@ TEBCresume( if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) || IsErroringNaNType(type1)) { - TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", - O2S(value2Ptr), O2S(valuePtr), - (valuePtr->typePtr? valuePtr->typePtr->name: "null"))); - DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); - CACHE_STACK_INFO(); + checkInterp = 1; goto gotError; } @@ -5463,12 +2502,8 @@ TEBCresume( if ((GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) || IsErroringNaNType(type2)) { - TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", - O2S(value2Ptr), O2S(valuePtr), - (value2Ptr->typePtr? value2Ptr->typePtr->name: "null"))); - DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, value2Ptr); - CACHE_STACK_INFO(); + checkInterp = 1; goto gotError; } @@ -5530,20 +2565,15 @@ TEBCresume( } #endif wideResultOfArithmetic: - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); if (Tcl_IsShared(valuePtr)) { objResultPtr = Tcl_NewWideIntObj(wResult); - TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } Tcl_SetWideIntObj(valuePtr, wResult); - TRACE(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 0); case INST_DIV: if (l2 == 0) { - TRACE(("%s %s => DIVIDE BY ZERO\n", - O2S(valuePtr), O2S(value2Ptr))); goto divideByZero; } else if ((l1 == LONG_MIN) && (l2 == -1)) { /* @@ -5584,24 +2614,17 @@ TEBCresume( } overflow: - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); objResultPtr = ExecuteExtendedBinaryMathOp(interp, *pc, &TCONST(0), valuePtr, value2Ptr); if (objResultPtr == DIVIDED_BY_ZERO) { - TRACE_APPEND(("DIVIDE BY ZERO\n")); goto divideByZero; } else if (objResultPtr == EXPONENT_OF_ZERO) { - TRACE_APPEND(("EXPONENT OF ZERO\n")); goto exponOfZero; } else if (objResultPtr == GENERAL_ARITHMETIC_ERROR) { - TRACE_APPEND(("ERROR: %s\n", - TclGetString(Tcl_GetObjResult(interp)))); goto gotError; } else if (objResultPtr == NULL) { - TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 0); } else { - TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } @@ -5613,11 +2636,8 @@ TEBCresume( /* TODO - check claim that taking address of b harms performance */ /* TODO - consider optimization search for constants */ if (TclGetBooleanFromObj(NULL, valuePtr, &b) != TCL_OK) { - TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", O2S(valuePtr), - (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); - DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); - CACHE_STACK_INFO(); + checkInterp = 1; goto gotError; } /* TODO: Consider peephole opt. */ @@ -5633,11 +2653,8 @@ TEBCresume( * ... ~$NonInteger => raise an error. */ - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), - (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); - DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); - CACHE_STACK_INFO(); + checkInterp = 1; goto gotError; } if (type1 == TCL_NUMBER_LONG) { @@ -5660,11 +2677,8 @@ TEBCresume( valuePtr = OBJ_AT_TOS; if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) || IsErroringNaNType(type1)) { - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), - (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); - DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); - CACHE_STACK_INFO(); + checkInterp = 1; goto gotError; } switch (type1) { @@ -5706,16 +2720,12 @@ TEBCresume( * ... +$NonNumeric => raise an error. */ - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), - (valuePtr->typePtr? valuePtr->typePtr->name:"null"))); - DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); - CACHE_STACK_INFO(); + checkInterp = 1; goto gotError; } /* ... TryConvertToNumeric($NonNumeric) is acceptable */ - TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } if (IsErroringNaNType(type1)) { @@ -5724,21 +2734,15 @@ TEBCresume( * ... +$NonNumeric => raise an error. */ - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), - (valuePtr->typePtr? valuePtr->typePtr->name:"null"))); - DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); - CACHE_STACK_INFO(); + checkInterp = 1; } else { /* * Numeric conversion of NaN -> error. */ - TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n", - O2S(objResultPtr))); - DECACHE_STACK_INFO(); TclExprFloatError(interp, *((const double *) ptr1)); - CACHE_STACK_INFO(); + checkInterp = 1; } goto gotError; } @@ -5753,7 +2757,6 @@ TEBCresume( */ if (valuePtr->bytes == NULL) { - TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } if (Tcl_IsShared(valuePtr)) { @@ -5768,11 +2771,9 @@ TEBCresume( valuePtr->bytes = NULL; objResultPtr = Tcl_DuplicateObj(valuePtr); valuePtr->bytes = savedString; - TRACE(("\"%.20s\" => numeric, new Tcl_Obj\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 1); } TclInvalidateStringRep(valuePtr); - TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } @@ -5781,848 +2782,6 @@ TEBCresume( * ----------------------------------------------------------------- */ - case INST_BREAK: - /* - DECACHE_STACK_INFO(); - Tcl_ResetResult(interp); - CACHE_STACK_INFO(); - */ - result = TCL_BREAK; - cleanup = 0; - goto processExceptionReturn; - - case INST_CONTINUE: - /* - DECACHE_STACK_INFO(); - Tcl_ResetResult(interp); - CACHE_STACK_INFO(); - */ - result = TCL_CONTINUE; - cleanup = 0; - goto processExceptionReturn; - - { - ForeachInfo *infoPtr; - Var *iterVarPtr, *listVarPtr; - Tcl_Obj *oldValuePtr, *listPtr, **elements; - ForeachVarList *varListPtr; - int numLists, iterNum, listTmpIndex, listLen, numVars; - int varIndex, valIndex, continueLoop, j, iterTmpIndex; - long i; - - case INST_FOREACH_START4: - /* - * Initialize the temporary local var that holds the count of the - * number of iterations of the loop body to -1. - */ - - opnd = TclGetUInt4AtPtr(pc+1); - infoPtr = codePtr->auxDataArrayPtr[opnd].clientData; - iterTmpIndex = infoPtr->loopCtTemp; - iterVarPtr = LOCAL(iterTmpIndex); - oldValuePtr = iterVarPtr->value.objPtr; - - if (oldValuePtr == NULL) { - TclNewLongObj(iterVarPtr->value.objPtr, -1); - Tcl_IncrRefCount(iterVarPtr->value.objPtr); - } else { - TclSetLongObj(oldValuePtr, -1); - } - TRACE(("%u => loop iter count temp %d\n", opnd, iterTmpIndex)); - -#ifndef TCL_COMPILE_DEBUG - /* - * Remark that the compiler ALWAYS sets INST_FOREACH_STEP4 immediately - * after INST_FOREACH_START4 - let us just fall through instead of - * jumping back to the top. - */ - - pc += 5; - TCL_DTRACE_INST_NEXT(); -#else - NEXT_INST_F(5, 0, 0); -#endif - - case INST_FOREACH_STEP4: - /* - * "Step" a foreach loop (i.e., begin its next iteration) by assigning - * the next value list element to each loop var. - */ - - opnd = TclGetUInt4AtPtr(pc+1); - infoPtr = codePtr->auxDataArrayPtr[opnd].clientData; - numLists = infoPtr->numLists; - - /* - * Increment the temp holding the loop iteration number. - */ - - iterVarPtr = LOCAL(infoPtr->loopCtTemp); - valuePtr = iterVarPtr->value.objPtr; - iterNum = valuePtr->internalRep.longValue + 1; - TclSetLongObj(valuePtr, iterNum); - - /* - * Check whether all value lists are exhausted and we should stop the - * loop. - */ - - continueLoop = 0; - listTmpIndex = infoPtr->firstValueTemp; - for (i = 0; i < numLists; i++) { - varListPtr = infoPtr->varLists[i]; - numVars = varListPtr->numVars; - - listVarPtr = LOCAL(listTmpIndex); - listPtr = listVarPtr->value.objPtr; - if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) { - TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ", - opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp)); - goto gotError; - } - if (listLen > iterNum * numVars) { - continueLoop = 1; - } - listTmpIndex++; - } - - /* - * If some var in some var list still has a remaining list element - * iterate one more time. Assign to var the next element from its - * value list. We already checked above that each list temp holds a - * valid list object (by calling Tcl_ListObjLength), but cannot rely - * on that check remaining valid: one list could have been shimmered - * as a side effect of setting a traced variable. - */ - - if (continueLoop) { - listTmpIndex = infoPtr->firstValueTemp; - for (i = 0; i < numLists; i++) { - varListPtr = infoPtr->varLists[i]; - numVars = varListPtr->numVars; - - listVarPtr = LOCAL(listTmpIndex); - listPtr = TclListObjCopy(NULL, listVarPtr->value.objPtr); - TclListObjGetElements(interp, listPtr, &listLen, &elements); - - valIndex = (iterNum * numVars); - for (j = 0; j < numVars; j++) { - if (valIndex >= listLen) { - TclNewObj(valuePtr); - } else { - valuePtr = elements[valIndex]; - } - - varIndex = varListPtr->varIndexes[j]; - varPtr = LOCAL(varIndex); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - if (TclIsVarDirectWritable(varPtr)) { - value2Ptr = varPtr->value.objPtr; - if (valuePtr != value2Ptr) { - if (value2Ptr != NULL) { - TclDecrRefCount(value2Ptr); - } - varPtr->value.objPtr = valuePtr; - Tcl_IncrRefCount(valuePtr); - } - } else { - DECACHE_STACK_INFO(); - if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, - valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){ - CACHE_STACK_INFO(); - TRACE_WITH_OBJ(( - "%u => ERROR init. index temp %d: ", - opnd,varIndex), Tcl_GetObjResult(interp)); - TclDecrRefCount(listPtr); - goto gotError; - } - CACHE_STACK_INFO(); - } - valIndex++; - } - TclDecrRefCount(listPtr); - listTmpIndex++; - } - } - TRACE(("%u => %d lists, iter %d, %s loop\n", opnd, numLists, - iterNum, (continueLoop? "continue" : "exit"))); - - /* - * Run-time peep-hole optimisation: the compiler ALWAYS follows - * INST_FOREACH_STEP4 with an INST_JUMP_FALSE. We just skip that - * instruction and jump direct from here. - */ - - pc += 5; - if (*pc == INST_JUMP_FALSE1) { - NEXT_INST_F((continueLoop? 2 : TclGetInt1AtPtr(pc+1)), 0, 0); - } else { - NEXT_INST_F((continueLoop? 5 : TclGetInt4AtPtr(pc+1)), 0, 0); - } - } - - case INST_BEGIN_CATCH4: - /* - * Record start of the catch command with exception range index equal - * to the operand. Push the current stack depth onto the special catch - * stack. - */ - - *(++catchTop) = CURR_DEPTH; - TRACE(("%u => catchTop=%d, stackTop=%d\n", - TclGetUInt4AtPtr(pc+1), (int) (catchTop - initCatchTop - 1), - (int) CURR_DEPTH)); - NEXT_INST_F(5, 0, 0); - - case INST_END_CATCH: - catchTop--; - DECACHE_STACK_INFO(); - Tcl_ResetResult(interp); - CACHE_STACK_INFO(); - result = TCL_OK; - TRACE(("=> catchTop=%d\n", (int) (catchTop - initCatchTop - 1))); - NEXT_INST_F(1, 0, 0); - - case INST_PUSH_RESULT: - objResultPtr = Tcl_GetObjResult(interp); - TRACE_WITH_OBJ(("=> "), objResultPtr); - - /* - * See the comments at INST_INVOKE_STK - */ - - TclNewObj(objPtr); - Tcl_IncrRefCount(objPtr); - iPtr->objResultPtr = objPtr; - NEXT_INST_F(1, 0, -1); - - case INST_PUSH_RETURN_CODE: - TclNewIntObj(objResultPtr, result); - TRACE(("=> %u\n", result)); - NEXT_INST_F(1, 0, 1); - - case INST_PUSH_RETURN_OPTIONS: - DECACHE_STACK_INFO(); - objResultPtr = Tcl_GetReturnOptions(interp, result); - CACHE_STACK_INFO(); - TRACE_WITH_OBJ(("=> "), objResultPtr); - NEXT_INST_F(1, 0, 1); - - case INST_RETURN_CODE_BRANCH: { - int code; - - if (TclGetIntFromObj(NULL, OBJ_AT_TOS, &code) != TCL_OK) { - Tcl_Panic("INST_RETURN_CODE_BRANCH: TOS not a return code!"); - } - if (code == TCL_OK) { - Tcl_Panic("INST_RETURN_CODE_BRANCH: TOS is TCL_OK!"); - } - if (code < TCL_ERROR || code > TCL_CONTINUE) { - code = TCL_CONTINUE + 1; - } - NEXT_INST_F(2*code -1, 1, 0); - } - - /* - * ----------------------------------------------------------------- - * Start of dictionary-related instructions. - */ - - { - int opnd2, allocateDict, done, i, allocdict; - Tcl_Obj *dictPtr, *statePtr, *keyPtr, *listPtr, *varNamePtr, *keysPtr; - Tcl_Obj *emptyPtr, **keyPtrPtr; - Tcl_DictSearch *searchPtr; - DictUpdateInfo *duiPtr; - - case INST_DICT_VERIFY: - dictPtr = OBJ_AT_TOS; - TRACE(("=> ")); - if (Tcl_DictObjSize(interp, dictPtr, &done) != TCL_OK) { - TRACE_APPEND(("ERROR verifying dictionary nature of \"%s\": %s\n", - O2S(OBJ_AT_DEPTH(opnd)), O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - TRACE_APPEND(("OK\n")); - NEXT_INST_F(1, 1, 0); - - case INST_DICT_GET: - case INST_DICT_EXISTS: { - register Tcl_Interp *interp2 = interp; - - opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u => ", opnd)); - dictPtr = OBJ_AT_DEPTH(opnd); - if (*pc == INST_DICT_EXISTS) { - interp2 = NULL; - } - if (opnd > 1) { - dictPtr = TclTraceDictPath(interp2, dictPtr, opnd-1, - &OBJ_AT_DEPTH(opnd-1), DICT_PATH_READ); - if (dictPtr == NULL) { - if (*pc == INST_DICT_EXISTS) { - goto dictNotExists; - } - TRACE_WITH_OBJ(( - "ERROR tracing dictionary path into \"%s\": ", - O2S(OBJ_AT_DEPTH(opnd))), - Tcl_GetObjResult(interp)); - goto gotError; - } - } - if (Tcl_DictObjGet(interp2, dictPtr, OBJ_AT_TOS, - &objResultPtr) == TCL_OK) { - if (*pc == INST_DICT_EXISTS) { - objResultPtr = TCONST(objResultPtr ? 1 : 0); - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd+1, 1); - } - if (objResultPtr) { - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd+1, 1); - } - DECACHE_STACK_INFO(); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "key \"%s\" not known in dictionary", - TclGetString(OBJ_AT_TOS))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", - TclGetString(OBJ_AT_TOS), NULL); - CACHE_STACK_INFO(); - TRACE_WITH_OBJ(("%u => ERROR ", opnd), Tcl_GetObjResult(interp)); - } else { - if (*pc == INST_DICT_EXISTS) { - dictNotExists: - objResultPtr = TCONST(0); - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd+1, 1); - } - TRACE_WITH_OBJ(( - "%u => ERROR reading leaf dictionary key \"%s\": ", - opnd, O2S(dictPtr)), Tcl_GetObjResult(interp)); - } - goto gotError; - } - - case INST_DICT_SET: - case INST_DICT_UNSET: - case INST_DICT_INCR_IMM: - opnd = TclGetUInt4AtPtr(pc+1); - opnd2 = TclGetUInt4AtPtr(pc+5); - - varPtr = LOCAL(opnd2); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - TRACE(("%u %u => ", opnd, opnd2)); - if (TclIsVarDirectReadable(varPtr)) { - dictPtr = varPtr->value.objPtr; - } else { - DECACHE_STACK_INFO(); - dictPtr = TclPtrGetVar(interp, varPtr, NULL,NULL,NULL, 0, opnd2); - CACHE_STACK_INFO(); - } - if (dictPtr == NULL) { - TclNewObj(dictPtr); - allocateDict = 1; - } else { - allocateDict = Tcl_IsShared(dictPtr); - if (allocateDict) { - dictPtr = Tcl_DuplicateObj(dictPtr); - } - } - - switch (*pc) { - case INST_DICT_SET: - cleanup = opnd + 1; - result = Tcl_DictObjPutKeyList(interp, dictPtr, opnd, - &OBJ_AT_DEPTH(opnd), OBJ_AT_TOS); - break; - case INST_DICT_INCR_IMM: - cleanup = 1; - opnd = TclGetInt4AtPtr(pc+1); - result = Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, &valuePtr); - if (result != TCL_OK) { - break; - } - if (valuePtr == NULL) { - Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS,Tcl_NewIntObj(opnd)); - } else { - value2Ptr = Tcl_NewIntObj(opnd); - Tcl_IncrRefCount(value2Ptr); - if (Tcl_IsShared(valuePtr)) { - valuePtr = Tcl_DuplicateObj(valuePtr); - Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS, valuePtr); - } - result = TclIncrObj(interp, valuePtr, value2Ptr); - if (result == TCL_OK) { - TclInvalidateStringRep(dictPtr); - } - TclDecrRefCount(value2Ptr); - } - break; - case INST_DICT_UNSET: - cleanup = opnd; - result = Tcl_DictObjRemoveKeyList(interp, dictPtr, opnd, - &OBJ_AT_DEPTH(opnd-1)); - break; - default: - cleanup = 0; /* stop compiler warning */ - Tcl_Panic("Should not happen!"); - } - - if (result != TCL_OK) { - if (allocateDict) { - TclDecrRefCount(dictPtr); - } - TRACE_WITH_OBJ(("%u %u => ERROR updating dictionary: ", - opnd, opnd2), Tcl_GetObjResult(interp)); - goto checkForCatch; - } - - if (TclIsVarDirectWritable(varPtr)) { - if (allocateDict) { - value2Ptr = varPtr->value.objPtr; - Tcl_IncrRefCount(dictPtr); - if (value2Ptr != NULL) { - TclDecrRefCount(value2Ptr); - } - varPtr->value.objPtr = dictPtr; - } - objResultPtr = dictPtr; - } else { - Tcl_IncrRefCount(dictPtr); - DECACHE_STACK_INFO(); - objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, - dictPtr, TCL_LEAVE_ERR_MSG, opnd2); - CACHE_STACK_INFO(); - TclDecrRefCount(dictPtr); - if (objResultPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - } -#ifndef TCL_COMPILE_DEBUG - if (*(pc+9) == INST_POP) { - NEXT_INST_V(10, cleanup, 0); - } -#endif - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(9, cleanup, 1); - - case INST_DICT_APPEND: - case INST_DICT_LAPPEND: - opnd = TclGetUInt4AtPtr(pc+1); - varPtr = LOCAL(opnd); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - TRACE(("%u => ", opnd)); - if (TclIsVarDirectReadable(varPtr)) { - dictPtr = varPtr->value.objPtr; - } else { - DECACHE_STACK_INFO(); - dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd); - CACHE_STACK_INFO(); - } - if (dictPtr == NULL) { - TclNewObj(dictPtr); - allocateDict = 1; - } else { - allocateDict = Tcl_IsShared(dictPtr); - if (allocateDict) { - dictPtr = Tcl_DuplicateObj(dictPtr); - } - } - - if (Tcl_DictObjGet(interp, dictPtr, OBJ_UNDER_TOS, - &valuePtr) != TCL_OK) { - if (allocateDict) { - TclDecrRefCount(dictPtr); - } - goto gotError; - } - - /* - * Note that a non-existent key results in a NULL valuePtr, which is a - * case handled separately below. What we *can* say at this point is - * that the write-back will always succeed. - */ - - switch (*pc) { - case INST_DICT_APPEND: - if (valuePtr == NULL) { - Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, OBJ_AT_TOS); - } else if (Tcl_IsShared(valuePtr)) { - valuePtr = Tcl_DuplicateObj(valuePtr); - Tcl_AppendObjToObj(valuePtr, OBJ_AT_TOS); - Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, valuePtr); - } else { - Tcl_AppendObjToObj(valuePtr, OBJ_AT_TOS); - - /* - * Must invalidate the string representation of dictionary - * here because we have directly updated the internal - * representation; if we don't, callers could see the wrong - * string rep despite the internal version of the dictionary - * having the correct value. [Bug 3079830] - */ - - TclInvalidateStringRep(dictPtr); - } - break; - case INST_DICT_LAPPEND: - /* - * More complex because list-append can fail. - */ - - if (valuePtr == NULL) { - Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, - Tcl_NewListObj(1, &OBJ_AT_TOS)); - break; - } else if (Tcl_IsShared(valuePtr)) { - valuePtr = Tcl_DuplicateObj(valuePtr); - if (Tcl_ListObjAppendElement(interp, valuePtr, - OBJ_AT_TOS) != TCL_OK) { - TclDecrRefCount(valuePtr); - if (allocateDict) { - TclDecrRefCount(dictPtr); - } - goto gotError; - } - Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, valuePtr); - } else { - if (Tcl_ListObjAppendElement(interp, valuePtr, - OBJ_AT_TOS) != TCL_OK) { - if (allocateDict) { - TclDecrRefCount(dictPtr); - } - goto gotError; - } - - /* - * Must invalidate the string representation of dictionary - * here because we have directly updated the internal - * representation; if we don't, callers could see the wrong - * string rep despite the internal version of the dictionary - * having the correct value. [Bug 3079830] - */ - - TclInvalidateStringRep(dictPtr); - } - break; - default: - Tcl_Panic("Should not happen!"); - } - - if (TclIsVarDirectWritable(varPtr)) { - if (allocateDict) { - value2Ptr = varPtr->value.objPtr; - Tcl_IncrRefCount(dictPtr); - if (value2Ptr != NULL) { - TclDecrRefCount(value2Ptr); - } - varPtr->value.objPtr = dictPtr; - } - objResultPtr = dictPtr; - } else { - Tcl_IncrRefCount(dictPtr); - DECACHE_STACK_INFO(); - objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, - dictPtr, TCL_LEAVE_ERR_MSG, opnd); - CACHE_STACK_INFO(); - TclDecrRefCount(dictPtr); - if (objResultPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - } -#ifndef TCL_COMPILE_DEBUG - if (*(pc+5) == INST_POP) { - NEXT_INST_F(6, 2, 0); - } -#endif - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(5, 2, 1); - - case INST_DICT_FIRST: - opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u => ", opnd)); - dictPtr = POP_OBJECT(); - searchPtr = ckalloc(sizeof(Tcl_DictSearch)); - if (Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr, - &valuePtr, &done) != TCL_OK) { - ckfree(searchPtr); - goto gotError; - } - TclNewObj(statePtr); - statePtr->typePtr = &dictIteratorType; - statePtr->internalRep.twoPtrValue.ptr1 = searchPtr; - statePtr->internalRep.twoPtrValue.ptr2 = dictPtr; - varPtr = LOCAL(opnd); - if (varPtr->value.objPtr) { - if (varPtr->value.objPtr->typePtr == &dictIteratorType) { - Tcl_Panic("mis-issued dictFirst!"); - } - TclDecrRefCount(varPtr->value.objPtr); - } - varPtr->value.objPtr = statePtr; - Tcl_IncrRefCount(statePtr); - goto pushDictIteratorResult; - - case INST_DICT_NEXT: - opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u => ", opnd)); - statePtr = (*LOCAL(opnd)).value.objPtr; - if (statePtr == NULL || statePtr->typePtr != &dictIteratorType) { - Tcl_Panic("mis-issued dictNext!"); - } - searchPtr = statePtr->internalRep.twoPtrValue.ptr1; - Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done); - pushDictIteratorResult: - if (done) { - TclNewObj(emptyPtr); - PUSH_OBJECT(emptyPtr); - PUSH_OBJECT(emptyPtr); - } else { - PUSH_OBJECT(valuePtr); - PUSH_OBJECT(keyPtr); - } - -#ifndef TCL_COMPILE_DEBUG - /* - * The INST_DICT_FIRST and INST_DICT_NEXT instructsions are always - * followed by a conditional jump, so we can take advantage of this to - * do some peephole optimization (note that we're careful to not close - * out someone doing something else). - */ - - pc += 5; - switch (*pc) { - case INST_JUMP_FALSE1: - NEXT_INST_F((done ? 2 : TclGetInt1AtPtr(pc+1)), 0, 0); - case INST_JUMP_FALSE4: - NEXT_INST_F((done ? 5 : TclGetInt4AtPtr(pc+1)), 0, 0); - case INST_JUMP_TRUE1: - NEXT_INST_F((done ? TclGetInt1AtPtr(pc+1) : 2), 0, 0); - case INST_JUMP_TRUE4: - NEXT_INST_F((done ? TclGetInt4AtPtr(pc+1) : 5), 0, 0); - default: - pc -= 5; - /* fall through to non-debug handling */ - } -#endif - - TRACE_APPEND(("\"%.30s\" \"%.30s\" %d", - O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), done)); - objResultPtr = TCONST(done); - /* TODO: consider opt like INST_FOREACH_STEP4 */ - NEXT_INST_F(5, 0, 1); - - case INST_DICT_UPDATE_START: - opnd = TclGetUInt4AtPtr(pc+1); - opnd2 = TclGetUInt4AtPtr(pc+5); - varPtr = LOCAL(opnd); - duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData; - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - TRACE(("%u => ", opnd)); - if (TclIsVarDirectReadable(varPtr)) { - dictPtr = varPtr->value.objPtr; - } else { - DECACHE_STACK_INFO(); - dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, - TCL_LEAVE_ERR_MSG, opnd); - CACHE_STACK_INFO(); - if (dictPtr == NULL) { - goto gotError; - } - } - if (TclListObjGetElements(interp, OBJ_AT_TOS, &length, - &keyPtrPtr) != TCL_OK) { - goto gotError; - } - if (length != duiPtr->length) { - Tcl_Panic("dictUpdateStart argument length mismatch"); - } - for (i=0 ; i<length ; i++) { - if (Tcl_DictObjGet(interp, dictPtr, keyPtrPtr[i], - &valuePtr) != TCL_OK) { - goto gotError; - } - varPtr = LOCAL(duiPtr->varIndices[i]); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - DECACHE_STACK_INFO(); - if (valuePtr == NULL) { - TclObjUnsetVar2(interp, - localName(iPtr->varFramePtr, duiPtr->varIndices[i]), - NULL, 0); - } else if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, - valuePtr, TCL_LEAVE_ERR_MSG, - duiPtr->varIndices[i]) == NULL) { - CACHE_STACK_INFO(); - goto gotError; - } - CACHE_STACK_INFO(); - } - NEXT_INST_F(9, 0, 0); - - case INST_DICT_UPDATE_END: - opnd = TclGetUInt4AtPtr(pc+1); - opnd2 = TclGetUInt4AtPtr(pc+5); - varPtr = LOCAL(opnd); - duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData; - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - TRACE(("%u => ", opnd)); - if (TclIsVarDirectReadable(varPtr)) { - dictPtr = varPtr->value.objPtr; - } else { - DECACHE_STACK_INFO(); - dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd); - CACHE_STACK_INFO(); - } - if (dictPtr == NULL) { - NEXT_INST_F(9, 1, 0); - } - if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK - || TclListObjGetElements(interp, OBJ_AT_TOS, &length, - &keyPtrPtr) != TCL_OK) { - goto gotError; - } - allocdict = Tcl_IsShared(dictPtr); - if (allocdict) { - dictPtr = Tcl_DuplicateObj(dictPtr); - } - if (length > 0) { - TclInvalidateStringRep(dictPtr); - } - for (i=0 ; i<length ; i++) { - Var *var2Ptr = LOCAL(duiPtr->varIndices[i]); - - while (TclIsVarLink(var2Ptr)) { - var2Ptr = var2Ptr->value.linkPtr; - } - if (TclIsVarDirectReadable(var2Ptr)) { - valuePtr = var2Ptr->value.objPtr; - } else { - DECACHE_STACK_INFO(); - valuePtr = TclPtrGetVar(interp, var2Ptr, NULL, NULL, NULL, 0, - duiPtr->varIndices[i]); - CACHE_STACK_INFO(); - } - if (valuePtr == NULL) { - Tcl_DictObjRemove(interp, dictPtr, keyPtrPtr[i]); - } else if (dictPtr == valuePtr) { - Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i], - Tcl_DuplicateObj(valuePtr)); - } else { - Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i], valuePtr); - } - } - if (TclIsVarDirectWritable(varPtr)) { - Tcl_IncrRefCount(dictPtr); - TclDecrRefCount(varPtr->value.objPtr); - varPtr->value.objPtr = dictPtr; - } else { - DECACHE_STACK_INFO(); - objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, - dictPtr, TCL_LEAVE_ERR_MSG, opnd); - CACHE_STACK_INFO(); - if (objResultPtr == NULL) { - if (allocdict) { - TclDecrRefCount(dictPtr); - } - goto gotError; - } - } - NEXT_INST_F(9, 1, 0); - - case INST_DICT_EXPAND: - dictPtr = OBJ_UNDER_TOS; - listPtr = OBJ_AT_TOS; - if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { - TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", - O2S(dictPtr), O2S(listPtr)), Tcl_GetObjResult(interp)); - goto gotError; - } - objResultPtr = TclDictWithInit(interp, dictPtr, objc, objv); - if (objResultPtr == NULL) { - TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", - O2S(dictPtr), O2S(listPtr)), Tcl_GetObjResult(interp)); - goto gotError; - } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - - case INST_DICT_RECOMBINE_STK: - keysPtr = POP_OBJECT(); - varNamePtr = OBJ_UNDER_TOS; - listPtr = OBJ_AT_TOS; - TRACE(("\"%.30s\" \"%.30s\" \"%.30s\" => ", - O2S(varNamePtr), O2S(valuePtr), O2S(keysPtr))); - if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - TclDecrRefCount(keysPtr); - goto gotError; - } - varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL, - TCL_LEAVE_ERR_MSG, "set", 1, 1, &arrayPtr); - if (varPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - TclDecrRefCount(keysPtr); - goto gotError; - } - DECACHE_STACK_INFO(); - result = TclDictWithFinish(interp, varPtr,arrayPtr,varNamePtr,NULL,-1, - objc, objv, keysPtr); - CACHE_STACK_INFO(); - TclDecrRefCount(keysPtr); - if (result != TCL_OK) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - TRACE_APPEND(("OK\n")); - NEXT_INST_F(1, 2, 0); - - case INST_DICT_RECOMBINE_IMM: - opnd = TclGetUInt4AtPtr(pc+1); - listPtr = OBJ_UNDER_TOS; - keysPtr = OBJ_AT_TOS; - varPtr = LOCAL(opnd); - TRACE(("%u <- \"%.30s\" \"%.30s\" => ", opnd, O2S(valuePtr), - O2S(keysPtr))); - if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - DECACHE_STACK_INFO(); - result = TclDictWithFinish(interp, varPtr, NULL, NULL, NULL, opnd, - objc, objv, keysPtr); - CACHE_STACK_INFO(); - if (result != TCL_OK) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - TRACE_APPEND(("OK\n")); - NEXT_INST_F(5, 2, 0); - } - - /* - * End of dictionary-related instructions. - * ----------------------------------------------------------------- - */ - default: Tcl_Panic("TclNRExecuteByteCode: unrecognized opCode %u", *pc); } /* end of switch on opCode */ @@ -6646,37 +2805,12 @@ TEBCresume( */ processExceptionReturn: -#if TCL_COMPILE_DEBUG - switch (*pc) { - case INST_INVOKE_STK1: - opnd = TclGetUInt1AtPtr(pc+1); - TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf)); - break; - case INST_INVOKE_STK4: - opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf)); - break; - case INST_EVAL_STK: - /* - * Note that the object at stacktop has to be used before doing - * the cleanup. - */ - - TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS))); - break; - default: - TRACE(("=> ")); - } -#endif if ((result == TCL_CONTINUE) || (result == TCL_BREAK)) { rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr); if (rangePtr == NULL) { - TRACE_APPEND(("no encl. loop or catch, returning %s\n", - StringForResultCode(result))); goto abnormalReturn; } if (rangePtr->type == CATCH_EXCEPTION_RANGE) { - TRACE_APPEND(("%s ...\n", StringForResultCode(result))); goto processCatch; } while (cleanup--) { @@ -6686,35 +2820,15 @@ TEBCresume( if (result == TCL_BREAK) { result = TCL_OK; pc = (codePtr->codeStart + rangePtr->breakOffset); - TRACE_APPEND(("%s, range at %d, new pc %d\n", - StringForResultCode(result), - rangePtr->codeOffset, rangePtr->breakOffset)); NEXT_INST_F(0, 0, 0); } if (rangePtr->continueOffset == -1) { - TRACE_APPEND(("%s, loop w/o continue, checking for catch\n", - StringForResultCode(result))); goto checkForCatch; } result = TCL_OK; pc = (codePtr->codeStart + rangePtr->continueOffset); - TRACE_APPEND(("%s, range at %d, new pc %d\n", - StringForResultCode(result), - rangePtr->codeOffset, rangePtr->continueOffset)); NEXT_INST_F(0, 0, 0); } -#if TCL_COMPILE_DEBUG - if (traceInstructions) { - objPtr = Tcl_GetObjResult(interp); - if ((result != TCL_ERROR) && (result != TCL_RETURN)) { - TRACE_APPEND(("OTHER RETURN CODE %d, result= \"%s\"\n ", - result, O2S(objPtr))); - } else { - TRACE_APPEND(("%s, result= \"%s\"\n", - StringForResultCode(result), O2S(objPtr))); - } - } -#endif goto checkForCatch; /* @@ -6723,10 +2837,9 @@ TEBCresume( */ divideByZero: - DECACHE_STACK_INFO(); - Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1)); + Tcl_SetResult(interp, "divide by zero", TCL_STATIC); Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL); - CACHE_STACK_INFO(); + checkInterp = 1; goto gotError; /* @@ -6735,12 +2848,11 @@ TEBCresume( */ exponOfZero: - DECACHE_STACK_INFO(); - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "exponentiation of zero by negative power", -1)); + Tcl_SetResult(interp, "exponentiation of zero by negative power", + TCL_STATIC); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "exponentiation of zero by negative power", NULL); - CACHE_STACK_INFO(); + checkInterp = 1; /* * Almost all error paths feed through here rather than assigning to @@ -6766,10 +2878,9 @@ TEBCresume( const unsigned char *pcBeg; bytes = GetSrcInfoForPc(pc, codePtr, &length, &pcBeg); - DECACHE_STACK_INFO(); Tcl_LogCommandInfo(interp, codePtr->source, bytes, bytes ? length : 0); - CACHE_STACK_INFO(); + checkInterp = 1; } iPtr->flags &= ~ERR_ALREADY_LOGGED; @@ -6779,9 +2890,8 @@ TEBCresume( */ while (auxObjList) { - if ((catchTop != initCatchTop) - && (*catchTop > (ptrdiff_t) - auxObjList->internalRep.ptrAndLongRep.value)) { + if ((catchDepth >=0) && (PTR2INT(catchStack[catchDepth]) > + PTR2INT(auxObjList->internalRep.twoPtrValue.ptr1))) { break; } POP_TAUX_OBJ(); @@ -6797,12 +2907,6 @@ TEBCresume( */ if (TclCanceled(iPtr) && (Tcl_Canceled(interp, 0) == TCL_ERROR)) { -#ifdef TCL_COMPILE_DEBUG - if (traceInstructions) { - fprintf(stdout, " ... cancel with unwind, returning %s\n", - StringForResultCode(result)); - } -#endif goto abnormalReturn; } @@ -6813,21 +2917,9 @@ TEBCresume( */ if (TclLimitExceeded(iPtr->limit)) { -#ifdef TCL_COMPILE_DEBUG - if (traceInstructions) { - fprintf(stdout, " ... limit exceeded, returning %s\n", - StringForResultCode(result)); - } -#endif goto abnormalReturn; } - if (catchTop == initCatchTop) { -#ifdef TCL_COMPILE_DEBUG - if (traceInstructions) { - fprintf(stdout, " ... no enclosing catch, returning %s\n", - StringForResultCode(result)); - } -#endif + if (catchDepth == -1) { goto abnormalReturn; } rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 1, codePtr); @@ -6838,12 +2930,6 @@ TEBCresume( * breaking compat with previous .tbc compiled scripts. */ -#ifdef TCL_COMPILE_DEBUG - if (traceInstructions) { - fprintf(stdout, " ... no enclosing catch, returning %s\n", - StringForResultCode(result)); - } -#endif goto abnormalReturn; } @@ -6856,18 +2942,10 @@ TEBCresume( */ processCatch: - while (CURR_DEPTH > *catchTop) { + while (CURR_DEPTH > PTR2INT(catchStack[catchDepth])) { valuePtr = POP_OBJECT(); TclDecrRefCount(valuePtr); } -#ifdef TCL_COMPILE_DEBUG - if (traceInstructions) { - fprintf(stdout, " ... found catch at %d, catchTop=%d, " - "unwound to %ld, new pc %u\n", - rangePtr->codeOffset, (int) (catchTop - initCatchTop - 1), - (long) *catchTop, (unsigned) rangePtr->catchOffset); - } -#endif pc = (codePtr->codeStart + rangePtr->catchOffset); NEXT_INST_F(0, 0, 0); /* Restart the execution loop at pc. */ @@ -6882,8 +2960,6 @@ TEBCresume( */ abnormalReturn: - TCL_DTRACE_INST_LAST(); - /* * Clear all expansions and same-level NR calls. * @@ -6912,53 +2988,16 @@ TEBCresume( if (--codePtr->refCount <= 0) { TclCleanupByteCode(codePtr); } - TclStackFree(interp, TD); /* free my stack */ + ckfree(TD); /* free my stack */ return result; - - /* - * INST_START_CMD failure case removed where it doesn't bother that much - * - * Remark that if the interpreter is marked for deletion its - * compileEpoch is modified, so that the epoch check also verifies - * that the interp is not deleted. If no outside call has been made - * since the last check, it is safe to omit the check. - - * case INST_START_CMD: - */ - - instStartCmdFailed: - { - const char *bytes; - - checkInterp = 1; - length = 0; - - /* - * We used to switch to direct eval; for NRE-awareness we now - * compile and eval the command so that this evaluation does not - * add a new TEBC instance. [Bug 2910748] - */ - - if (TclInterpReady(interp) == TCL_ERROR) { - goto gotError; - } - - codePtr->flags |= TCL_BYTECODE_RECOMPILE; - bytes = GetSrcInfoForPc(pc, codePtr, &length, NULL); - opnd = TclGetUInt4AtPtr(pc+1); - pc += (opnd-1); - PUSH_OBJECT(Tcl_NewStringObj(bytes, length)); - goto instEvalStk; - NEXT_INST_F(9, 0, 0); - } } #undef codePtr #undef iPtr #undef initTosPtr #undef auxObjList -#undef catchTop +#undef catchDepth #undef TCONST /* @@ -8321,141 +4360,6 @@ TclCompareTwoNumbers( } } -#ifdef TCL_COMPILE_DEBUG -/* - *---------------------------------------------------------------------- - * - * PrintByteCodeInfo -- - * - * This procedure prints a summary about a bytecode object to stdout. It - * is called by TclNRExecuteByteCode when starting to execute the bytecode - * object if tclTraceExec has the value 2 or more. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -PrintByteCodeInfo( - register ByteCode *codePtr) /* The bytecode whose summary is printed to - * stdout. */ -{ - Proc *procPtr = codePtr->procPtr; - Interp *iPtr = (Interp *) *codePtr->interpHandle; - - fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %u, epoch %u, interp 0x%p (epoch %u)\n", - codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr, - iPtr->compileEpoch); - - fprintf(stdout, " Source: "); - TclPrintSource(stdout, codePtr->source, 60); - - fprintf(stdout, "\n Cmds %d, src %d, inst %u, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", - codePtr->numCommands, codePtr->numSrcBytes, - codePtr->numCodeBytes, codePtr->numLitObjects, - codePtr->numAuxDataItems, codePtr->maxStackDepth, -#ifdef TCL_COMPILE_STATS - codePtr->numSrcBytes? - ((float)codePtr->structureSize)/codePtr->numSrcBytes : -#endif - 0.0); - -#ifdef TCL_COMPILE_STATS - fprintf(stdout, " Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n", - (unsigned long) codePtr->structureSize, - (unsigned long) (sizeof(ByteCode)-sizeof(size_t)-sizeof(Tcl_Time)), - codePtr->numCodeBytes, - (unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)), - (unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)), - (unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)), - codePtr->numCmdLocBytes); -#endif /* TCL_COMPILE_STATS */ - if (procPtr != NULL) { - fprintf(stdout, - " Proc 0x%p, refCt %d, args %d, compiled locals %d\n", - procPtr, procPtr->refCount, procPtr->numArgs, - procPtr->numCompiledLocals); - } -} -#endif /* TCL_COMPILE_DEBUG */ - -/* - *---------------------------------------------------------------------- - * - * ValidatePcAndStackTop -- - * - * This procedure is called by TclNRExecuteByteCode when debugging to - * verify that the program counter and stack top are valid during - * execution. - * - * Results: - * None. - * - * Side effects: - * Prints a message to stderr and panics if either the pc or stack top - * are invalid. - * - *---------------------------------------------------------------------- - */ - -#ifdef TCL_COMPILE_DEBUG -static void -ValidatePcAndStackTop( - register ByteCode *codePtr, /* The bytecode whose summary is printed to - * stdout. */ - const unsigned char *pc, /* Points to first byte of a bytecode - * instruction. The program counter. */ - int stackTop, /* Current stack top. Must be between - * stackLowerBound and stackUpperBound - * (inclusive). */ - int checkStack) /* 0 if the stack depth check should be - * skipped. */ -{ - int stackUpperBound = codePtr->maxStackDepth; - /* Greatest legal value for stackTop. */ - unsigned relativePc = (unsigned) (pc - codePtr->codeStart); - unsigned long codeStart = (unsigned long) codePtr->codeStart; - unsigned long codeEnd = (unsigned long) - (codePtr->codeStart + codePtr->numCodeBytes); - unsigned char opCode = *pc; - - if (((unsigned long) pc < codeStart) || ((unsigned long) pc > codeEnd)) { - fprintf(stderr, "\nBad instruction pc 0x%p in TclNRExecuteByteCode\n", - pc); - Tcl_Panic("TclNRExecuteByteCode execution failure: bad pc"); - } - if ((unsigned) opCode > LAST_INST_OPCODE) { - fprintf(stderr, "\nBad opcode %d at pc %u in TclNRExecuteByteCode\n", - (unsigned) opCode, relativePc); - Tcl_Panic("TclNRExecuteByteCode execution failure: bad opcode"); - } - if (checkStack && - ((stackTop < 0) || (stackTop > stackUpperBound))) { - int numChars; - const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL); - - fprintf(stderr, "\nBad stack top %d at pc %u in TclNRExecuteByteCode (min 0, max %i)", - stackTop, relativePc, stackUpperBound); - if (cmd != NULL) { - Tcl_Obj *message; - - TclNewLiteralStringObj(message, "\n executing "); - Tcl_IncrRefCount(message); - Tcl_AppendLimitedToObj(message, cmd, numChars, 100, NULL); - fprintf(stderr,"%s\n", Tcl_GetString(message)); - Tcl_DecrRefCount(message); - } else { - fprintf(stderr, "\n"); - } - Tcl_Panic("TclNRExecuteByteCode execution failure: bad stack top"); - } -} -#endif /* TCL_COMPILE_DEBUG */ /* *---------------------------------------------------------------------- @@ -8487,7 +4391,7 @@ IllegalExprOperandType( ClientData ptr; int type; const unsigned char opcode = *pc; - const char *description, *operator = operatorStrings[opcode - INST_LOR]; + const char *description, *operator = operatorStrings[opcode - INST_BITOR]; if (opcode == INST_EXPON) { operator = "**"; @@ -8735,36 +4639,6 @@ GetExceptRangeForPc( /* *---------------------------------------------------------------------- * - * GetOpcodeName -- - * - * This procedure is called by the TRACE and TRACE_WITH_OBJ macros used - * in TclNRExecuteByteCode when debugging. It returns the name of the - * bytecode instruction at a specified instruction pc. - * - * Results: - * A character string for the instruction. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -#ifdef TCL_COMPILE_DEBUG -static const char * -GetOpcodeName( - const unsigned char *pc) /* Points to the instruction whose name should - * be returned. */ -{ - unsigned char opCode = *pc; - - return tclInstructionTable[opCode].name; -} -#endif /* TCL_COMPILE_DEBUG */ - -/* - *---------------------------------------------------------------------- - * * TclExprFloatError -- * * This procedure is called when an error occurs during a floating-point @@ -8811,497 +4685,7 @@ TclExprFloatError( } } -#ifdef TCL_COMPILE_STATS -/* - *---------------------------------------------------------------------- - * - * TclLog2 -- - * - * Procedure used while collecting compilation statistics to determine - * the log base 2 of an integer. - * - * Results: - * Returns the log base 2 of the operand. If the argument is less than or - * equal to zero, a zero is returned. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclLog2( - register int value) /* The integer for which to compute the log - * base 2. */ -{ - register int n = value; - register int result = 0; - - while (n > 1) { - n = n >> 1; - result++; - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * EvalStatsCmd -- - * - * Implements the "evalstats" command that prints instruction execution - * counts to stdout. - * - * Results: - * Standard Tcl results. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -EvalStatsCmd( - ClientData unused, /* Unused. */ - Tcl_Interp *interp, /* The current interpreter. */ - int objc, /* The number of arguments. */ - Tcl_Obj *const objv[]) /* The argument strings. */ -{ - Interp *iPtr = (Interp *) interp; - LiteralTable *globalTablePtr = &iPtr->literalTable; - ByteCodeStats *statsPtr = &iPtr->stats; - double totalCodeBytes, currentCodeBytes; - double totalLiteralBytes, currentLiteralBytes; - double objBytesIfUnshared, strBytesIfUnshared, sharingBytesSaved; - double strBytesSharedMultX, strBytesSharedOnce; - double numInstructions, currentHeaderBytes; - long numCurrentByteCodes, numByteCodeLits; - long refCountSum, literalMgmtBytes, sum; - int numSharedMultX, numSharedOnce; - int decadeHigh, minSizeDecade, maxSizeDecade, length, i; - char *litTableStats; - LiteralEntry *entryPtr; - Tcl_Obj *objPtr; - -#define Percent(a,b) ((a) * 100.0 / (b)) - - objPtr = Tcl_NewObj(); - Tcl_IncrRefCount(objPtr); - - numInstructions = 0.0; - for (i = 0; i < 256; i++) { - if (statsPtr->instructionCount[i] != 0) { - numInstructions += statsPtr->instructionCount[i]; - } - } - - totalLiteralBytes = sizeof(LiteralTable) - + iPtr->literalTable.numBuckets * sizeof(LiteralEntry *) - + (statsPtr->numLiteralsCreated * sizeof(LiteralEntry)) - + (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj)) - + statsPtr->totalLitStringBytes; - totalCodeBytes = statsPtr->totalByteCodeBytes + totalLiteralBytes; - - numCurrentByteCodes = - statsPtr->numCompilations - statsPtr->numByteCodesFreed; - currentHeaderBytes = numCurrentByteCodes - * (sizeof(ByteCode) - sizeof(size_t) - sizeof(Tcl_Time)); - literalMgmtBytes = sizeof(LiteralTable) - + (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)) - + (iPtr->literalTable.numEntries * sizeof(LiteralEntry)); - currentLiteralBytes = literalMgmtBytes - + iPtr->literalTable.numEntries * sizeof(Tcl_Obj) - + statsPtr->currentLitStringBytes; - currentCodeBytes = statsPtr->currentByteCodeBytes + currentLiteralBytes; - - /* - * Summary statistics, total and current source and ByteCode sizes. - */ - - Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n"); - Tcl_AppendPrintfToObj(objPtr, - "Compilation and execution statistics for interpreter %#lx\n", - (long int)iPtr); - - Tcl_AppendPrintfToObj(objPtr, "\nNumber ByteCodes executed\t%ld\n", - statsPtr->numExecutions); - Tcl_AppendPrintfToObj(objPtr, "Number ByteCodes compiled\t%ld\n", - statsPtr->numCompilations); - Tcl_AppendPrintfToObj(objPtr, " Mean executions/compile\t%.1f\n", - statsPtr->numExecutions / (float)statsPtr->numCompilations); - - Tcl_AppendPrintfToObj(objPtr, "\nInstructions executed\t\t%.0f\n", - numInstructions); - Tcl_AppendPrintfToObj(objPtr, " Mean inst/compile\t\t%.0f\n", - numInstructions / statsPtr->numCompilations); - Tcl_AppendPrintfToObj(objPtr, " Mean inst/execution\t\t%.0f\n", - numInstructions / statsPtr->numExecutions); - - Tcl_AppendPrintfToObj(objPtr, "\nTotal ByteCodes\t\t\t%ld\n", - statsPtr->numCompilations); - Tcl_AppendPrintfToObj(objPtr, " Source bytes\t\t\t%.6g\n", - statsPtr->totalSrcBytes); - Tcl_AppendPrintfToObj(objPtr, " Code bytes\t\t\t%.6g\n", - totalCodeBytes); - Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes\t\t%.6g\n", - statsPtr->totalByteCodeBytes); - Tcl_AppendPrintfToObj(objPtr, " Literal bytes\t\t%.6g\n", - totalLiteralBytes); - Tcl_AppendPrintfToObj(objPtr, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n", - (unsigned long) sizeof(LiteralTable), - (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)), - (unsigned long) (statsPtr->numLiteralsCreated * sizeof(LiteralEntry)), - (unsigned long) (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj)), - statsPtr->totalLitStringBytes); - Tcl_AppendPrintfToObj(objPtr, " Mean code/compile\t\t%.1f\n", - totalCodeBytes / statsPtr->numCompilations); - Tcl_AppendPrintfToObj(objPtr, " Mean code/source\t\t%.1f\n", - totalCodeBytes / statsPtr->totalSrcBytes); - - Tcl_AppendPrintfToObj(objPtr, "\nCurrent (active) ByteCodes\t%ld\n", - numCurrentByteCodes); - Tcl_AppendPrintfToObj(objPtr, " Source bytes\t\t\t%.6g\n", - statsPtr->currentSrcBytes); - Tcl_AppendPrintfToObj(objPtr, " Code bytes\t\t\t%.6g\n", - currentCodeBytes); - Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes\t\t%.6g\n", - statsPtr->currentByteCodeBytes); - Tcl_AppendPrintfToObj(objPtr, " Literal bytes\t\t%.6g\n", - currentLiteralBytes); - Tcl_AppendPrintfToObj(objPtr, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n", - (unsigned long) sizeof(LiteralTable), - (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)), - (unsigned long) (iPtr->literalTable.numEntries * sizeof(LiteralEntry)), - (unsigned long) (iPtr->literalTable.numEntries * sizeof(Tcl_Obj)), - statsPtr->currentLitStringBytes); - Tcl_AppendPrintfToObj(objPtr, " Mean code/source\t\t%.1f\n", - currentCodeBytes / statsPtr->currentSrcBytes); - Tcl_AppendPrintfToObj(objPtr, " Code + source bytes\t\t%.6g (%0.1f mean code/src)\n", - (currentCodeBytes + statsPtr->currentSrcBytes), - (currentCodeBytes / statsPtr->currentSrcBytes) + 1.0); - - /* - * Tcl_IsShared statistics check - * - * This gives the refcount of each obj as Tcl_IsShared was called for it. - * Shared objects must be duplicated before they can be modified. - */ - - numSharedMultX = 0; - Tcl_AppendPrintfToObj(objPtr, "\nTcl_IsShared object check (all objects):\n"); - Tcl_AppendPrintfToObj(objPtr, " Object had refcount <=1 (not shared)\t%ld\n", - tclObjsShared[1]); - for (i = 2; i < TCL_MAX_SHARED_OBJ_STATS; i++) { - Tcl_AppendPrintfToObj(objPtr, " refcount ==%d\t\t%ld\n", - i, tclObjsShared[i]); - numSharedMultX += tclObjsShared[i]; - } - Tcl_AppendPrintfToObj(objPtr, " refcount >=%d\t\t%ld\n", - i, tclObjsShared[0]); - numSharedMultX += tclObjsShared[0]; - Tcl_AppendPrintfToObj(objPtr, " Total shared objects\t\t\t%d\n", - numSharedMultX); - - /* - * Literal table statistics. - */ - - numByteCodeLits = 0; - refCountSum = 0; - numSharedMultX = 0; - numSharedOnce = 0; - objBytesIfUnshared = 0.0; - strBytesIfUnshared = 0.0; - strBytesSharedMultX = 0.0; - strBytesSharedOnce = 0.0; - for (i = 0; i < globalTablePtr->numBuckets; i++) { - for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL; - entryPtr = entryPtr->nextPtr) { - if (entryPtr->objPtr->typePtr == &tclByteCodeType) { - numByteCodeLits++; - } - (void) Tcl_GetStringFromObj(entryPtr->objPtr, &length); - refCountSum += entryPtr->refCount; - objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj)); - strBytesIfUnshared += (entryPtr->refCount * (length+1)); - if (entryPtr->refCount > 1) { - numSharedMultX++; - strBytesSharedMultX += (length+1); - } else { - numSharedOnce++; - strBytesSharedOnce += (length+1); - } - } - } - sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared) - - currentLiteralBytes; - - Tcl_AppendPrintfToObj(objPtr, "\nTotal objects (all interps)\t%ld\n", - tclObjsAlloced); - Tcl_AppendPrintfToObj(objPtr, "Current objects\t\t\t%ld\n", - (tclObjsAlloced - tclObjsFreed)); - Tcl_AppendPrintfToObj(objPtr, "Total literal objects\t\t%ld\n", - statsPtr->numLiteralsCreated); - - Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal objects\t\t%d (%0.1f%% of current objects)\n", - globalTablePtr->numEntries, - Percent(globalTablePtr->numEntries, tclObjsAlloced-tclObjsFreed)); - Tcl_AppendPrintfToObj(objPtr, " ByteCode literals\t\t%ld (%0.1f%% of current literals)\n", - numByteCodeLits, - Percent(numByteCodeLits, globalTablePtr->numEntries)); - Tcl_AppendPrintfToObj(objPtr, " Literals reused > 1x\t\t%d\n", - numSharedMultX); - Tcl_AppendPrintfToObj(objPtr, " Mean reference count\t\t%.2f\n", - ((double) refCountSum) / globalTablePtr->numEntries); - Tcl_AppendPrintfToObj(objPtr, " Mean len, str reused >1x \t%.2f\n", - (numSharedMultX ? strBytesSharedMultX/numSharedMultX : 0.0)); - Tcl_AppendPrintfToObj(objPtr, " Mean len, str used 1x\t\t%.2f\n", - (numSharedOnce ? strBytesSharedOnce/numSharedOnce : 0.0)); - Tcl_AppendPrintfToObj(objPtr, " Total sharing savings\t\t%.6g (%0.1f%% of bytes if no sharing)\n", - sharingBytesSaved, - Percent(sharingBytesSaved, objBytesIfUnshared+strBytesIfUnshared)); - Tcl_AppendPrintfToObj(objPtr, " Bytes with sharing\t\t%.6g\n", - currentLiteralBytes); - Tcl_AppendPrintfToObj(objPtr, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n", - (unsigned long) sizeof(LiteralTable), - (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)), - (unsigned long) (iPtr->literalTable.numEntries * sizeof(LiteralEntry)), - (unsigned long) (iPtr->literalTable.numEntries * sizeof(Tcl_Obj)), - statsPtr->currentLitStringBytes); - Tcl_AppendPrintfToObj(objPtr, " Bytes if no sharing\t\t%.6g = objects %.6g + strings %.6g\n", - (objBytesIfUnshared + strBytesIfUnshared), - objBytesIfUnshared, strBytesIfUnshared); - Tcl_AppendPrintfToObj(objPtr, " String sharing savings \t%.6g = unshared %.6g - shared %.6g\n", - (strBytesIfUnshared - statsPtr->currentLitStringBytes), - strBytesIfUnshared, statsPtr->currentLitStringBytes); - Tcl_AppendPrintfToObj(objPtr, " Literal mgmt overhead\t\t%ld (%0.1f%% of bytes with sharing)\n", - literalMgmtBytes, - Percent(literalMgmtBytes, currentLiteralBytes)); - Tcl_AppendPrintfToObj(objPtr, " table %lu + buckets %lu + entries %lu\n", - (unsigned long) sizeof(LiteralTable), - (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)), - (unsigned long) (iPtr->literalTable.numEntries * sizeof(LiteralEntry))); - - /* - * Breakdown of current ByteCode space requirements. - */ - - Tcl_AppendPrintfToObj(objPtr, "\nBreakdown of current ByteCode requirements:\n"); - Tcl_AppendPrintfToObj(objPtr, " Bytes Pct of Avg per\n"); - Tcl_AppendPrintfToObj(objPtr, " total ByteCode\n"); - Tcl_AppendPrintfToObj(objPtr, "Total %12.6g 100.00%% %8.1f\n", - statsPtr->currentByteCodeBytes, - statsPtr->currentByteCodeBytes / numCurrentByteCodes); - Tcl_AppendPrintfToObj(objPtr, "Header %12.6g %8.1f%% %8.1f\n", - currentHeaderBytes, - Percent(currentHeaderBytes, statsPtr->currentByteCodeBytes), - currentHeaderBytes / numCurrentByteCodes); - Tcl_AppendPrintfToObj(objPtr, "Instructions %12.6g %8.1f%% %8.1f\n", - statsPtr->currentInstBytes, - Percent(statsPtr->currentInstBytes,statsPtr->currentByteCodeBytes), - statsPtr->currentInstBytes / numCurrentByteCodes); - Tcl_AppendPrintfToObj(objPtr, "Literal ptr array %12.6g %8.1f%% %8.1f\n", - statsPtr->currentLitBytes, - Percent(statsPtr->currentLitBytes,statsPtr->currentByteCodeBytes), - statsPtr->currentLitBytes / numCurrentByteCodes); - Tcl_AppendPrintfToObj(objPtr, "Exception table %12.6g %8.1f%% %8.1f\n", - statsPtr->currentExceptBytes, - Percent(statsPtr->currentExceptBytes,statsPtr->currentByteCodeBytes), - statsPtr->currentExceptBytes / numCurrentByteCodes); - Tcl_AppendPrintfToObj(objPtr, "Auxiliary data %12.6g %8.1f%% %8.1f\n", - statsPtr->currentAuxBytes, - Percent(statsPtr->currentAuxBytes,statsPtr->currentByteCodeBytes), - statsPtr->currentAuxBytes / numCurrentByteCodes); - Tcl_AppendPrintfToObj(objPtr, "Command map %12.6g %8.1f%% %8.1f\n", - statsPtr->currentCmdMapBytes, - Percent(statsPtr->currentCmdMapBytes,statsPtr->currentByteCodeBytes), - statsPtr->currentCmdMapBytes / numCurrentByteCodes); - - /* - * Detailed literal statistics. - */ - - Tcl_AppendPrintfToObj(objPtr, "\nLiteral string sizes:\n"); - Tcl_AppendPrintfToObj(objPtr, "\t Up to length\t\tPercentage\n"); - maxSizeDecade = 0; - for (i = 31; i >= 0; i--) { - if (statsPtr->literalCount[i] > 0) { - maxSizeDecade = i; - break; - } - } - sum = 0; - for (i = 0; i <= maxSizeDecade; i++) { - decadeHigh = (1 << (i+1)) - 1; - sum += statsPtr->literalCount[i]; - Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%8.0f%%\n", - decadeHigh, Percent(sum, statsPtr->numLiteralsCreated)); - } - - litTableStats = TclLiteralStats(globalTablePtr); - Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal table statistics:\n%s\n", - litTableStats); - ckfree(litTableStats); - - /* - * Source and ByteCode size distributions. - */ - - Tcl_AppendPrintfToObj(objPtr, "\nSource sizes:\n"); - Tcl_AppendPrintfToObj(objPtr, "\t Up to size\t\tPercentage\n"); - minSizeDecade = maxSizeDecade = 0; - for (i = 0; i < 31; i++) { - if (statsPtr->srcCount[i] > 0) { - minSizeDecade = i; - break; - } - } - for (i = 31; i >= 0; i--) { - if (statsPtr->srcCount[i] > 0) { - maxSizeDecade = i; - break; - } - } - sum = 0; - for (i = minSizeDecade; i <= maxSizeDecade; i++) { - decadeHigh = (1 << (i+1)) - 1; - sum += statsPtr->srcCount[i]; - Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%8.0f%%\n", - decadeHigh, Percent(sum, statsPtr->numCompilations)); - } - - Tcl_AppendPrintfToObj(objPtr, "\nByteCode sizes:\n"); - Tcl_AppendPrintfToObj(objPtr, "\t Up to size\t\tPercentage\n"); - minSizeDecade = maxSizeDecade = 0; - for (i = 0; i < 31; i++) { - if (statsPtr->byteCodeCount[i] > 0) { - minSizeDecade = i; - break; - } - } - for (i = 31; i >= 0; i--) { - if (statsPtr->byteCodeCount[i] > 0) { - maxSizeDecade = i; - break; - } - } - sum = 0; - for (i = minSizeDecade; i <= maxSizeDecade; i++) { - decadeHigh = (1 << (i+1)) - 1; - sum += statsPtr->byteCodeCount[i]; - Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%8.0f%%\n", - decadeHigh, Percent(sum, statsPtr->numCompilations)); - } - - Tcl_AppendPrintfToObj(objPtr, "\nByteCode longevity (excludes Current ByteCodes):\n"); - Tcl_AppendPrintfToObj(objPtr, "\t Up to ms\t\tPercentage\n"); - minSizeDecade = maxSizeDecade = 0; - for (i = 0; i < 31; i++) { - if (statsPtr->lifetimeCount[i] > 0) { - minSizeDecade = i; - break; - } - } - for (i = 31; i >= 0; i--) { - if (statsPtr->lifetimeCount[i] > 0) { - maxSizeDecade = i; - break; - } - } - sum = 0; - for (i = minSizeDecade; i <= maxSizeDecade; i++) { - decadeHigh = (1 << (i+1)) - 1; - sum += statsPtr->lifetimeCount[i]; - Tcl_AppendPrintfToObj(objPtr, "\t%12.3f\t\t%8.0f%%\n", - decadeHigh/1000.0, Percent(sum, statsPtr->numByteCodesFreed)); - } - - /* - * Instruction counts. - */ - - Tcl_AppendPrintfToObj(objPtr, "\nInstruction counts:\n"); - for (i = 0; i <= LAST_INST_OPCODE; i++) { - Tcl_AppendPrintfToObj(objPtr, "%20s %8ld ", - tclInstructionTable[i].name, statsPtr->instructionCount[i]); - if (statsPtr->instructionCount[i]) { - Tcl_AppendPrintfToObj(objPtr, "%6.1f%%\n", - Percent(statsPtr->instructionCount[i], numInstructions)); - } else { - Tcl_AppendPrintfToObj(objPtr, "0\n"); - } - } - -#ifdef TCL_MEM_DEBUG - Tcl_AppendPrintfToObj(objPtr, "\nHeap Statistics:\n"); - TclDumpMemoryInfo((ClientData) objPtr, 1); -#endif - Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n"); - - if (objc == 1) { - Tcl_SetObjResult(interp, objPtr); - } else { - Tcl_Channel outChan; - char *str = Tcl_GetStringFromObj(objv[1], &length); - - if (length) { - if (strcmp(str, "stdout") == 0) { - outChan = Tcl_GetStdChannel(TCL_STDOUT); - } else if (strcmp(str, "stderr") == 0) { - outChan = Tcl_GetStdChannel(TCL_STDERR); - } else { - outChan = Tcl_OpenFileChannel(NULL, str, "w", 0664); - } - } else { - outChan = Tcl_GetStdChannel(TCL_STDOUT); - } - if (outChan != NULL) { - Tcl_WriteObj(outChan, objPtr); - } - } - Tcl_DecrRefCount(objPtr); - return TCL_OK; -} -#endif /* TCL_COMPILE_STATS */ -#ifdef TCL_COMPILE_DEBUG -/* - *---------------------------------------------------------------------- - * - * StringForResultCode -- - * - * Procedure that returns a human-readable string representing a Tcl - * result code such as TCL_ERROR. - * - * Results: - * If the result code is one of the standard Tcl return codes, the result - * is a string representing that code such as "TCL_ERROR". Otherwise, the - * result string is that code formatted as a sequence of decimal digit - * characters. Note that the resulting string must not be modified by the - * caller. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static const char * -StringForResultCode( - int result) /* The Tcl result code for which to generate a - * string. */ -{ - static char buf[TCL_INTEGER_SPACE]; - - if ((result >= TCL_OK) && (result <= TCL_CONTINUE)) { - return resultStrings[result]; - } - TclFormatInt(buf, result); - return buf; -} -#endif /* TCL_COMPILE_DEBUG */ /* * Local Variables: diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 33c1496..f4eca1e 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -701,7 +701,7 @@ CopyRenameOneFile( Tcl_ListObjAppendElement(interp, copyCommand, target); Tcl_IncrRefCount(copyCommand); result = Tcl_EvalObjEx(interp, copyCommand, - TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); + TCL_EVAL_GLOBAL); Tcl_DecrRefCount(copyCommand); if (result != TCL_OK) { /* @@ -1007,7 +1007,7 @@ TclFileAttrsCmd( goto end; } attributeStringsAllocated = (const char **) - TclStackAlloc(interp, (1+numObjStrings) * sizeof(char *)); + ckalloc((1+numObjStrings) * sizeof(char *)); for (index = 0; index < numObjStrings; index++) { Tcl_ListObjIndex(interp, objStrings, index, &objPtr); attributeStringsAllocated[index] = TclGetString(objPtr); @@ -1138,7 +1138,7 @@ TclFileAttrsCmd( end: if (attributeStringsAllocated != NULL) { - TclStackFree(interp, (void *) attributeStringsAllocated); + ckfree((void *) attributeStringsAllocated); } if (objStrings != NULL) { Tcl_DecrRefCount(objStrings); diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 5d4702b..c8dc3d3 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -1449,7 +1449,7 @@ Tcl_GlobObjCmd( if (length <= 0) { goto skipTypes; } - globTypes = TclStackAlloc(interp, sizeof(Tcl_GlobTypeData)); + globTypes = ckalloc(sizeof(Tcl_GlobTypeData)); globTypes->type = 0; globTypes->perm = 0; globTypes->macType = NULL; @@ -1669,7 +1669,7 @@ Tcl_GlobObjCmd( if (globTypes->macCreator != NULL) { Tcl_DecrRefCount(globTypes->macCreator); } - TclStackFree(interp, globTypes); + ckfree(globTypes); } return result; } diff --git a/generic/tclHistory.c b/generic/tclHistory.c index b10d423..5e70b6a 100644 --- a/generic/tclHistory.c +++ b/generic/tclHistory.c @@ -128,10 +128,10 @@ Tcl_RecordAndEvalObj( * in global variable context instead of the * current procedure. */ { - int result, call = 1; - Tcl_CmdInfo info; + int result; HistoryObjs *histObjsPtr = Tcl_GetAssocData(interp, HISTORY_OBJS_KEY, NULL); + Tcl_Obj *list[3]; /* * Create the references to the [::history add] command if necessary. @@ -148,37 +148,23 @@ Tcl_RecordAndEvalObj( } /* - * Do not call [history] if it has been replaced by an empty proc + * Do recording by eval'ing a tcl history command: history add $cmd. */ - - result = Tcl_GetCommandInfo(interp, "::history", &info); - if (result && (info.deleteProc == TclProcDeleteProc)) { - Proc *procPtr = (Proc *) info.objClientData; - call = (procPtr->cmdPtr->compileProc != TclCompileNoOp); - } - - if (call) { - Tcl_Obj *list[3]; - - /* - * Do recording by eval'ing a tcl history command: history add $cmd. - */ - - list[0] = histObjsPtr->historyObj; - list[1] = histObjsPtr->addObj; - list[2] = cmdPtr; - - Tcl_IncrRefCount(cmdPtr); - (void) Tcl_EvalObjv(interp, 3, list, TCL_EVAL_GLOBAL); - Tcl_DecrRefCount(cmdPtr); - - /* - * One possible failure mode above: exceeding a resource limit. - */ - - if (Tcl_LimitExceeded(interp)) { - return TCL_ERROR; - } + + list[0] = histObjsPtr->historyObj; + list[1] = histObjsPtr->addObj; + list[2] = cmdPtr; + + Tcl_IncrRefCount(cmdPtr); + (void) Tcl_EvalObjv(interp, 3, list, TCL_EVAL_GLOBAL); + Tcl_DecrRefCount(cmdPtr); + + /* + * One possible failure mode above: exceeding a resource limit. + */ + + if (Tcl_LimitExceeded(interp)) { + return TCL_ERROR; } /* diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 1673bce..4d157cc 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -931,7 +931,7 @@ Tcl_ExecObjCmd( */ argc = objc - skip; - argv = TclStackAlloc(interp, (unsigned)(argc + 1) * sizeof(char *)); + argv = ckalloc((unsigned)(argc + 1) * sizeof(char *)); /* * Copy the string conversions of each (post option) object into the @@ -949,7 +949,7 @@ Tcl_ExecObjCmd( * Free the argv array. */ - TclStackFree(interp, (void *) argv); + ckfree((void *) argv); if (chan == NULL) { return TCL_ERROR; @@ -1952,26 +1952,26 @@ TclInitChanCmd( * function at the moment. */ static const EnsembleImplMap initMap[] = { - {"blocked", Tcl_FblockedObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"close", Tcl_CloseObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {"copy", Tcl_FcopyObjCmd, NULL, NULL, NULL, 0}, - {"create", TclChanCreateObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #219 */ - {"eof", Tcl_EofObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"event", Tcl_FileEventObjCmd, TclCompileBasic2Or3ArgCmd, NULL, NULL, 0}, - {"flush", Tcl_FlushObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"gets", Tcl_GetsObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {"names", TclChannelNamesCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, - {"pending", ChanPendingObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #287 */ - {"pipe", ChanPipeObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, /* TIP #304 */ - {"pop", TclChanPopObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, /* TIP #230 */ - {"postevent", TclChanPostEventObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #219 */ - {"push", TclChanPushObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #230 */ - {"puts", Tcl_PutsObjCmd, NULL, NULL, NULL, 0}, - {"read", Tcl_ReadObjCmd, NULL, NULL, NULL, 0}, - {"seek", Tcl_SeekObjCmd, TclCompileBasic2Or3ArgCmd, NULL, NULL, 0}, - {"tell", Tcl_TellObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"truncate", ChanTruncateObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, /* TIP #208 */ - {NULL, NULL, NULL, NULL, NULL, 0} + {"blocked", Tcl_FblockedObjCmd, NULL, NULL, 0}, + {"close", Tcl_CloseObjCmd, NULL, NULL, 0}, + {"copy", Tcl_FcopyObjCmd, NULL, NULL, 0}, + {"create", TclChanCreateObjCmd, NULL, NULL, 0}, /* TIP #219 */ + {"eof", Tcl_EofObjCmd, NULL, NULL, 0}, + {"event", Tcl_FileEventObjCmd, NULL, NULL, 0}, + {"flush", Tcl_FlushObjCmd, NULL, NULL, 0}, + {"gets", Tcl_GetsObjCmd, NULL, NULL, 0}, + {"names", TclChannelNamesCmd, NULL, NULL, 0}, + {"pending", ChanPendingObjCmd, NULL, NULL, 0}, /* TIP #287 */ + {"pipe", ChanPipeObjCmd, NULL, NULL, 0}, /* TIP #304 */ + {"pop", TclChanPopObjCmd, NULL, NULL, 0}, /* TIP #230 */ + {"postevent", TclChanPostEventObjCmd, NULL, NULL, 0}, /* TIP #219 */ + {"push", TclChanPushObjCmd, NULL, NULL, 0}, /* TIP #230 */ + {"puts", Tcl_PutsObjCmd, NULL, NULL, 0}, + {"read", Tcl_ReadObjCmd, NULL, NULL, 0}, + {"seek", Tcl_SeekObjCmd, NULL, NULL, 0}, + {"tell", Tcl_TellObjCmd, NULL, NULL, 0}, + {"truncate", ChanTruncateObjCmd, NULL, NULL, 0}, /* TIP #208 */ + {NULL, NULL, NULL, NULL, 0} }; static const char *const extras[] = { "configure", "::fconfigure", diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 512f5ba..a439db9 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -533,10 +533,10 @@ TclInitPrefixCmd( Tcl_Interp *interp) /* Current interpreter. */ { static const EnsembleImplMap prefixImplMap[] = { - {"all", PrefixAllObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"longest", PrefixLongestObjCmd,TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"match", PrefixMatchObjCmd, TclCompileBasicMin2ArgCmd, NULL, NULL, 0}, - {NULL, NULL, NULL, NULL, NULL, 0} + {"all", PrefixAllObjCmd, NULL, NULL, 0}, + {"longest", PrefixLongestObjCmd,NULL, NULL, 0}, + {"match", PrefixMatchObjCmd, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, 0} }; Tcl_Command prefixCmd; @@ -965,13 +965,12 @@ Tcl_WrongNumArgs( len = TclScanElement(elementStr, elemLen, &flags); if (MAY_QUOTE_WORD && len != elemLen) { - char *quotedElementStr = TclStackAlloc(interp, - (unsigned)len + 1); + char *quotedElementStr = ckalloc((unsigned)len + 1); len = TclConvertElement(elementStr, elemLen, quotedElementStr, flags); Tcl_AppendToObj(objPtr, quotedElementStr, len); - TclStackFree(interp, quotedElementStr); + ckfree(quotedElementStr); } else { Tcl_AppendToObj(objPtr, elementStr, elemLen); } @@ -1021,13 +1020,12 @@ Tcl_WrongNumArgs( len = TclScanElement(elementStr, elemLen, &flags); if (MAY_QUOTE_WORD && len != elemLen) { - char *quotedElementStr = TclStackAlloc(interp, - (unsigned) len + 1); + char *quotedElementStr = ckalloc((unsigned) len + 1); len = TclConvertElement(elementStr, elemLen, quotedElementStr, flags); Tcl_AppendToObj(objPtr, quotedElementStr, len); - TclStackFree(interp, quotedElementStr); + ckfree(quotedElementStr); } else { Tcl_AppendToObj(objPtr, elementStr, elemLen); } diff --git a/generic/tclInt.decls b/generic/tclInt.decls index a57afed..58c23ff 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -34,9 +34,9 @@ interface tclInt #declare 2 { # int TclAccessInsertProc(TclAccessProc_ *proc) #} -declare 3 { - void TclAllocateFreeObjects(void) -} +#declare 3 { +# void TclAllocateFreeObjects(void) +#} # Replaced by TclpChdir in 8.1: # declare 4 { # int TclChdir(Tcl_Interp *interp, char *dirName) @@ -289,9 +289,9 @@ declare 64 { #declare 68 { # int TclpAccess(const char *path, int mode) #} -declare 69 { - char *TclpAlloc(unsigned int size) -} +#declare 69 { +# char *TclpAlloc(unsigned int size) +#} #declare 70 { # int TclpCopyFile(const char *source, const char *dest) #} @@ -305,9 +305,9 @@ declare 69 { #declare 73 { # int TclpDeleteFile(const char *path) #} -declare 74 { - void TclpFree(char *ptr) -} +#declare 74 { +# void TclpFree(char *ptr) +#} declare 75 { unsigned long TclpGetClicks(void) } @@ -332,9 +332,9 @@ declare 77 { # Tcl_Channel TclpOpenFileChannel(Tcl_Interp *interp, char *fileName, # char *modeString, int permissions) #} -declare 81 { - char *TclpRealloc(char *ptr, unsigned int size) -} +#declare 81 { +# char *TclpRealloc(char *ptr, unsigned int size) +#} #declare 82 { # int TclpRemoveDirectory(const char *path, int recursive, # Tcl_DString *errorPtr) @@ -519,7 +519,7 @@ declare 128 { void Tcl_PopCallFrame(Tcl_Interp *interp) } declare 129 { - int Tcl_PushCallFrame(Tcl_Interp *interp, Tcl_CallFrame *framePtr, + int Tcl_PushCallFrame(Tcl_Interp *interp, CallFrame *framePtr, Tcl_Namespace *nsPtr, int isProcCallFrame) } declare 130 { @@ -870,14 +870,14 @@ declare 213 { declare 214 { void TclSetObjNameOfExecutable(Tcl_Obj *name, Tcl_Encoding encoding) } -declare 215 { - void *TclStackAlloc(Tcl_Interp *interp, int numBytes) -} -declare 216 { - void TclStackFree(Tcl_Interp *interp, void *freePtr) -} +#declare 215 { +# void *TclStackAlloc(Tcl_Interp *interp, unsigned int numBytes) +#} +#declare 216 { +# void TclStackFree(Tcl_Interp *interp, void *freePtr) +#} declare 217 { - int TclPushStackFrame(Tcl_Interp *interp, Tcl_CallFrame **framePtrPtr, + int TclPushStackFrame(Tcl_Interp *interp, CallFrame **framePtrPtr, Tcl_Namespace *namespacePtr, int isProcCallFrame) } declare 218 { @@ -894,9 +894,9 @@ declare 225 { Tcl_Obj *TclTraceDictPath(Tcl_Interp *interp, Tcl_Obj *rootPtr, int keyc, Tcl_Obj *const keyv[], int flags) } -declare 226 { - int TclObjBeingDeleted(Tcl_Obj *objPtr) -} +#declare 226 { +# int TclObjBeingDeleted(Tcl_Obj *objPtr) +#} declare 227 { void TclSetNsPath(Namespace *nsPtr, int pathLength, Tcl_Namespace *pathAry[]) @@ -941,9 +941,9 @@ declare 235 { # TIP 337 made this one public -declare 236 { - void TclBackgroundException(Tcl_Interp *interp, int code) -} +#declare 236 { +# void TclBackgroundException(Tcl_Interp *interp, int code) +#} # TIP #285: Script cancellation support. declare 237 { @@ -952,10 +952,10 @@ declare 237 { # NRE functions for "rogue" extensions to exploit NRE; they will need to # include NRE.h too. -declare 238 { - int TclNRInterpProc(ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]) -} +#declare 238 { +# int TclNRInterpProc(ClientData clientData, Tcl_Interp *interp, +# int objc, Tcl_Obj *const objv[]) +#} declare 239 { int TclNRInterpProcCore(Tcl_Interp *interp, Tcl_Obj *procNameObj, int skip, ProcErrorProc *errorProc) diff --git a/generic/tclInt.h b/generic/tclInt.h index 4ac0b77..b91a718 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -10,7 +10,7 @@ * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved. - * Copyright (c) 2008 by Miguel Sofer. All rights reserved. + * Copyright (c) 2008-2011 by Miguel Sofer. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -1075,12 +1075,9 @@ typedef struct AssocData { * and its global naming scope (a namespace, perhaps the global :: namespace). * A call frame can also define the naming context for a namespace eval or * namespace inscope command: the namespace in which the command's code should - * execute. The Tcl_CallFrame structures exist only while procedures or + * execute. The CallFrame structures exist only while procedures or * namespace eval/inscope's are being executed, and provide a kind of Tcl call * stack. - * - * WARNING!! The structure definition must be kept consistent with the - * Tcl_CallFrame structure in tcl.h. If you change one, change the other. */ /* @@ -1208,13 +1205,6 @@ MODULE_SCOPE void TclThreadDataKeySet(Tcl_ThreadDataKey *keyPtr, (ThreadSpecificData *)Tcl_GetThreadData((keyPtr), sizeof(ThreadSpecificData)) /* - *---------------------------------------------------------------- - * Data structures related to bytecode compilation and execution. These are - * used primarily in tclCompile.c, tclExecute.c, and tclBasic.c. - *---------------------------------------------------------------- - */ - -/* * Forward declaration to prevent errors when the forward references to * Tcl_Parse and CompileEnv are encountered in the procedure type CompileProc * declared below. @@ -1256,19 +1246,6 @@ typedef int (CompileHookProc)(Tcl_Interp *interp, struct CompileEnv *compEnvPtr, ClientData clientData); /* - * The data structure for a (linked list of) execution stacks. - */ - -typedef struct ExecStack { - struct ExecStack *prevPtr; - struct ExecStack *nextPtr; - Tcl_Obj **markerPtr; - Tcl_Obj **endPtr; - Tcl_Obj **tosPtr; - Tcl_Obj *stackWords[1]; -} ExecStack; - -/* * The data structure defining the execution environment for ByteCode's. * There is one ExecEnv structure per Tcl interpreter. It holds the evaluation * stack that holds command operands and results. The stack grows towards @@ -1303,8 +1280,6 @@ typedef struct CoroutineData { } CoroutineData; typedef struct ExecEnv { - ExecStack *execStackPtr; /* Points to the first item in the evaluation - * stack on the heap. */ Tcl_Obj *constants[2]; /* Pointers to constant "0" and "1" objs. */ struct Tcl_Interp *interp; struct NRE_callback *callbackPtr; @@ -1372,38 +1347,6 @@ typedef struct LiteralTable { * interpreter's operation in that interpreter. */ -#ifdef TCL_COMPILE_STATS -typedef struct ByteCodeStats { - long numExecutions; /* Number of ByteCodes executed. */ - long numCompilations; /* Number of ByteCodes created. */ - long numByteCodesFreed; /* Number of ByteCodes destroyed. */ - long instructionCount[256]; /* Number of times each instruction was - * executed. */ - - double totalSrcBytes; /* Total source bytes ever compiled. */ - double totalByteCodeBytes; /* Total bytes for all ByteCodes. */ - double currentSrcBytes; /* Src bytes for all current ByteCodes. */ - double currentByteCodeBytes;/* Code bytes in all current ByteCodes. */ - - long srcCount[32]; /* Source size distribution: # of srcs of - * size [2**(n-1)..2**n), n in [0..32). */ - long byteCodeCount[32]; /* ByteCode size distribution. */ - long lifetimeCount[32]; /* ByteCode lifetime distribution (ms). */ - - double currentInstBytes; /* Instruction bytes-current ByteCodes. */ - double currentLitBytes; /* Current literal bytes. */ - double currentExceptBytes; /* Current exception table bytes. */ - double currentAuxBytes; /* Current auxiliary information bytes. */ - double currentCmdMapBytes; /* Current src<->code map bytes. */ - - long numLiteralsCreated; /* Total literal objects ever compiled. */ - double totalLitStringBytes; /* Total string bytes in all literals. */ - double currentLitStringBytes; - /* String bytes in current literals. */ - long literalCount[32]; /* Distribution of literal string sizes. */ -} ByteCodeStats; -#endif /* TCL_COMPILE_STATS */ - /* * Structure used in implementation of those core ensembles which are * partially compiled. Used as an array of these, with a terminating field @@ -1414,7 +1357,6 @@ typedef struct { const char *name; /* The name of the subcommand. */ Tcl_ObjCmdProc *proc; /* The implementation of the subcommand. */ CompileProc *compileProc; /* The compiler for the subcommand. */ - Tcl_ObjCmdProc *nreProc; /* NRE implementation of this command. */ ClientData clientData; /* Any clientData to give the command. */ int unsafe; /* Whether this command is to be hidden by * default in a safe interpreter. */ @@ -1510,7 +1452,6 @@ typedef struct Command { * command. */ CommandTrace *tracePtr; /* First in list of all traces set for this * command. */ - Tcl_ObjCmdProc *nreProc; /* NRE implementation of this command. */ } Command; /* @@ -1586,24 +1527,6 @@ enum PkgPreferOptions { /* *---------------------------------------------------------------- - * This structure shadows the first few fields of the memory cache for the - * allocator defined in tclThreadAlloc.c; it has to be kept in sync with the - * definition there. - * Some macros require knowledge of some fields in the struct in order to - * avoid hitting the TSD unnecessarily. In order to facilitate this, a pointer - * to the relevant fields is kept in the objCache field in struct Interp. - *---------------------------------------------------------------- - */ - -typedef struct AllocCache { - struct Cache *nextPtr; /* Linked list of cache entries. */ - Tcl_ThreadId owner; /* Which thread's cache is this? */ - Tcl_Obj *firstObjPtr; /* List of free objects for thread. */ - int numObjects; /* Number of objects for thread. */ -} AllocCache; - -/* - *---------------------------------------------------------------- * This structure defines an interpreter, which is a collection of commands * plus other state information related to interpreting commands, such as * variable storage. Primary responsibility for this data structure is in @@ -1731,11 +1654,6 @@ typedef struct Interp { * compiled by the interpreter. Indexed by the * string representations of literals. Used to * avoid creating duplicate objects. */ - int compileEpoch; /* Holds the current "compilation epoch" for - * this interpreter. This is incremented to - * invalidate existing ByteCodes when, e.g., a - * command with a compile procedure is - * redefined. */ Proc *compiledProcPtr; /* If a procedure is being compiled, a pointer * to its Proc structure; otherwise, this is * NULL. Set by ObjInterpProc in tclProc.c and @@ -1887,10 +1805,6 @@ typedef struct Interp { * They are used by the macros defined below. */ - AllocCache *allocCache; - void *pendingObjDataPtr; /* Pointer to the Cache and PendingObjData - * structs for this interp's thread; see - * tclObj.c and tclThreadAlloc.c */ int *asyncReadyPtr; /* Pointer to the asyncReady indicator for * this interp's thread; see tclAsync.c */ /* @@ -1918,15 +1832,6 @@ typedef struct Interp { * over the default error messages returned by * a script cancellation operation. */ -#ifdef TCL_COMPILE_STATS - /* - * Statistical information about the bytecode compiler and interpreter's - * operation. This should be the last field of Interp. - */ - - ByteCodeStats stats; /* Holds compilation and execution statistics - * for this interpreter. */ -#endif /* TCL_COMPILE_STATS */ Tcl_Obj *cmdSourcePtr; /* Command source obj, used for command traces */ } Interp; @@ -2106,17 +2011,6 @@ struct LimitHandler { #define UCHAR(c) ((unsigned char) (c)) /* - * This macro is used to properly align the memory allocated by Tcl, giving - * the same alignment as the native malloc. - */ - -#if defined(__APPLE__) -#define TCL_ALLOCALIGN 16 -#else -#define TCL_ALLOCALIGN (2*sizeof(void *)) -#endif - -/* * This macro is used to determine the offset needed to safely allocate any * data structure in memory. Given a starting offset or size, it "rounds up" * or "aligns" the offset to the next 8-byte boundary so that any data @@ -2503,20 +2397,6 @@ MODULE_SCOPE const Tcl_HashKeyType tclStringHashKeyType; MODULE_SCOPE const Tcl_HashKeyType tclObjHashKeyType; /* - * The head of the list of free Tcl objects, and the total number of Tcl - * objects ever allocated and freed. - */ - -MODULE_SCOPE Tcl_Obj * tclFreeObjList; - -#ifdef TCL_COMPILE_STATS -MODULE_SCOPE long tclObjsAlloced; -MODULE_SCOPE long tclObjsFreed; -#define TCL_MAX_SHARED_OBJ_STATS 5 -MODULE_SCOPE long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS]; -#endif /* TCL_COMPILE_STATS */ - -/* * Pointer to a heap-allocated string of length zero that the Tcl core uses as * the value of an empty string representation for an object. This value is * shared by all new objects allocated by Tcl_NewObj. @@ -2532,21 +2412,6 @@ MODULE_SCOPE char tclEmptyString; *---------------------------------------------------------------- */ -MODULE_SCOPE Tcl_ObjCmdProc TclNRApplyObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclNREvalObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclNRCatchObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclNRExprObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclNRLmapCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclNRSubstObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclNRSwitchObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclNRTryObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd; - MODULE_SCOPE Tcl_NRPostProc TclNRForIterCallback; MODULE_SCOPE Tcl_NRPostProc TclNRCoroutineActivateCallback; MODULE_SCOPE Tcl_ObjCmdProc TclNRTailcallObjCmd; @@ -2669,7 +2534,6 @@ MODULE_SCOPE char * TclDStringAppendObj(Tcl_DString *dsPtr, MODULE_SCOPE char * TclDStringAppendDString(Tcl_DString *dsPtr, Tcl_DString *toAppendPtr); MODULE_SCOPE Tcl_Obj * TclDStringToObj(Tcl_DString *dsPtr); -MODULE_SCOPE void TclFinalizeAllocSubsystem(void); MODULE_SCOPE void TclFinalizeAsync(void); MODULE_SCOPE void TclFinalizeDoubleConversion(void); MODULE_SCOPE void TclFinalizeEncodingSubsystem(void); @@ -2686,7 +2550,6 @@ MODULE_SCOPE void TclFinalizeNotifier(void); MODULE_SCOPE void TclFinalizeObjects(void); MODULE_SCOPE void TclFinalizePreserve(void); MODULE_SCOPE void TclFinalizeSynchronization(void); -MODULE_SCOPE void TclFinalizeThreadAlloc(void); MODULE_SCOPE void TclFinalizeThreadData(void); MODULE_SCOPE void TclFinalizeThreadObjects(void); MODULE_SCOPE double TclFloor(const mp_int *a); @@ -2727,7 +2590,6 @@ MODULE_SCOPE int TclInfoLocalsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclInfoVarsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE void TclInitAlloc(void); MODULE_SCOPE void TclInitDbCkalloc(void); MODULE_SCOPE void TclInitDoubleConversion(void); MODULE_SCOPE void TclInitEmbeddedConfigurationInformation( @@ -2862,15 +2724,11 @@ MODULE_SCOPE void TclSetDuplicateObj(Tcl_Obj *dupPtr, Tcl_Obj *objPtr); MODULE_SCOPE void TclSetProcessGlobalValue(ProcessGlobalValue *pgvPtr, Tcl_Obj *newValue, Tcl_Encoding encoding); MODULE_SCOPE void TclSignalExitThread(Tcl_ThreadId id, int result); -MODULE_SCOPE void * TclStackRealloc(Tcl_Interp *interp, void *ptr, - int numBytes); MODULE_SCOPE int TclStringMatch(const char *str, int strLen, const char *pattern, int ptnLen, int flags); MODULE_SCOPE int TclStringMatchObj(Tcl_Obj *stringObj, Tcl_Obj *patternObj, int flags); MODULE_SCOPE Tcl_Obj * TclStringObjReverse(Tcl_Obj *objPtr); -MODULE_SCOPE void TclSubstCompile(Tcl_Interp *interp, const char *bytes, - int numBytes, int flags, struct CompileEnv *envPtr); MODULE_SCOPE int TclSubstOptions(Tcl_Interp *interp, int numOpts, Tcl_Obj *const opts[], int *flagPtr); MODULE_SCOPE void TclSubstParse(Tcl_Interp *interp, const char *bytes, @@ -2901,7 +2759,6 @@ MODULE_SCOPE void TclFinalizeThreadStorage(void); MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void); MODULE_SCOPE double TclpWideClicksToNanoseconds(Tcl_WideInt clicks); #endif -MODULE_SCOPE Tcl_Obj * TclDisassembleByteCodeObj(Tcl_Obj *objPtr); MODULE_SCOPE int TclZlibInit(Tcl_Interp *interp); MODULE_SCOPE void * TclpThreadCreateKey(void); MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr); @@ -2928,9 +2785,6 @@ MODULE_SCOPE Tcl_Command TclInitBinaryCmd(Tcl_Interp *interp); MODULE_SCOPE int Tcl_BreakObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_CaseObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_CatchObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -2974,18 +2828,6 @@ MODULE_SCOPE int TclDictWithFinish(Tcl_Interp *interp, Var *varPtr, Tcl_Obj *const pathv[], Tcl_Obj *keysPtr); MODULE_SCOPE Tcl_Obj * TclDictWithInit(Tcl_Interp *interp, Tcl_Obj *dictPtr, int pathc, Tcl_Obj *const pathv[]); -MODULE_SCOPE int Tcl_DisassembleObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); - -/* Assemble command function */ -MODULE_SCOPE int Tcl_AssembleObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int TclNRAssembleObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); - MODULE_SCOPE int Tcl_EncodingObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -3208,271 +3050,6 @@ MODULE_SCOPE int Tcl_WhileObjCmd(ClientData clientData, *---------------------------------------------------------------- */ -MODULE_SCOPE int TclCompileAppendCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileArrayExistsCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileArraySetCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileArrayUnsetCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileBreakCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileCatchCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileContinueCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileDictAppendCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileDictCreateCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileDictExistsCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileDictForCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileDictGetCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileDictIncrCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileDictLappendCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileDictMapCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileDictMergeCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileDictSetCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileDictUnsetCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileDictUpdateCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileDictWithCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileEnsemble(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileErrorCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileExprCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileForCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileForeachCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileFormatCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileGlobalCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileIfCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileInfoCommandsCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileInfoCoroutineCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileInfoExistsCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileInfoLevelCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileInfoObjectClassCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileInfoObjectIsACmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileInfoObjectNamespaceCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileIncrCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileLappendCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileLassignCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileLindexCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileListCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileLlengthCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileLmapCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileLrangeCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileLreplaceCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileLsetCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileNamespaceCodeCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileNamespaceCurrentCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileNamespaceQualifiersCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileNamespaceTailCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileNamespaceUpvarCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileNamespaceWhichCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileNoOp(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileObjectSelfCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileRegexpCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileRegsubCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileReturnCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileSetCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileStringCmpCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileStringEqualCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileStringFirstCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileStringIndexCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileStringLastCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileStringLenCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileStringMapCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileStringMatchCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileStringRangeCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileSubstCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileSwitchCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileTailcallCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileThrowCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileTryCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileUnsetCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileUpvarCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileVariableCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileWhileCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileYieldCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileBasic0ArgCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileBasic1ArgCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileBasic2ArgCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileBasic3ArgCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileBasic0Or1ArgCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileBasic1Or2ArgCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileBasic2Or3ArgCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileBasic0To2ArgCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileBasic1To3ArgCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileBasicMin0ArgCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileBasicMin1ArgCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileBasicMin2ArgCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); - MODULE_SCOPE int TclInvertOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -3612,10 +3189,6 @@ MODULE_SCOPE int TclCompileStreqOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileAssembleCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); - /* * Functions defined in generic/tclVar.c and currenttly exported only for use * by the bytecode compiler and engine. Some of these could later be placed in @@ -3705,21 +3278,14 @@ typedef const char *TclDTraceStr; #define TCL_DTRACE_OBJ_FREE(objPtr) {} #endif /* USE_DTRACE */ -#ifdef TCL_COMPILE_STATS -# define TclIncrObjsAllocated() \ - tclObjsAlloced++ -# define TclIncrObjsFreed() \ - tclObjsFreed++ -#else # define TclIncrObjsAllocated() # define TclIncrObjsFreed() -#endif /* TCL_COMPILE_STATS */ # define TclAllocObjStorage(objPtr) \ - TclAllocObjStorageEx(NULL, (objPtr)) + (objPtr) = TclSmallAlloc() # define TclFreeObjStorage(objPtr) \ - TclFreeObjStorageEx(NULL, (objPtr)) + TclSmallFree(objPtr) #ifndef TCL_MEM_DEBUG # define TclNewObj(objPtr) \ @@ -3754,112 +3320,6 @@ typedef const char *TclDTraceStr; } \ } -#if defined(PURIFY) - -/* - * The PURIFY mode is like the regular mode, but instead of doing block - * Tcl_Obj allocation and keeping a freed list for efficiency, it always - * allocates and frees a single Tcl_Obj so that tools like Purify can better - * track memory leaks. - */ - -# define TclAllocObjStorageEx(interp, objPtr) \ - (objPtr) = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj)) - -# define TclFreeObjStorageEx(interp, objPtr) \ - ckfree((char *) (objPtr)) - -#undef USE_THREAD_ALLOC -#undef USE_TCLALLOC -#elif defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) - -/* - * The TCL_THREADS mode is like the regular mode but allocates Tcl_Obj's from - * per-thread caches. - */ - -MODULE_SCOPE Tcl_Obj * TclThreadAllocObj(void); -MODULE_SCOPE void TclThreadFreeObj(Tcl_Obj *); -MODULE_SCOPE Tcl_Mutex *TclpNewAllocMutex(void); -MODULE_SCOPE void TclFreeAllocCache(void *); -MODULE_SCOPE void * TclpGetAllocCache(void); -MODULE_SCOPE void TclpSetAllocCache(void *); -MODULE_SCOPE void TclpFreeAllocMutex(Tcl_Mutex *mutex); -MODULE_SCOPE void TclpFreeAllocCache(void *); - -/* - * These macros need to be kept in sync with the code of TclThreadAllocObj() - * and TclThreadFreeObj(). - * - * Note that the optimiser should resolve the case (interp==NULL) at compile - * time. - */ - -# define ALLOC_NOBJHIGH 1200 - -# define TclAllocObjStorageEx(interp, objPtr) \ - do { \ - AllocCache *cachePtr; \ - if (((interp) == NULL) || \ - ((cachePtr = ((Interp *)(interp))->allocCache), \ - (cachePtr->numObjects == 0))) { \ - (objPtr) = TclThreadAllocObj(); \ - } else { \ - (objPtr) = cachePtr->firstObjPtr; \ - cachePtr->firstObjPtr = (objPtr)->internalRep.otherValuePtr; \ - --cachePtr->numObjects; \ - } \ - } while (0) - -# define TclFreeObjStorageEx(interp, objPtr) \ - do { \ - AllocCache *cachePtr; \ - if (((interp) == NULL) || \ - ((cachePtr = ((Interp *)(interp))->allocCache), \ - (cachePtr->numObjects >= ALLOC_NOBJHIGH))) { \ - TclThreadFreeObj(objPtr); \ - } else { \ - (objPtr)->internalRep.otherValuePtr = cachePtr->firstObjPtr; \ - cachePtr->firstObjPtr = objPtr; \ - ++cachePtr->numObjects; \ - } \ - } while (0) - -#else /* not PURIFY or USE_THREAD_ALLOC */ - -#if defined(USE_TCLALLOC) && USE_TCLALLOC - MODULE_SCOPE void TclFinalizeAllocSubsystem(); - MODULE_SCOPE void TclInitAlloc(); -#else -# define USE_TCLALLOC 0 -#endif - -#ifdef TCL_THREADS -/* declared in tclObj.c */ -MODULE_SCOPE Tcl_Mutex tclObjMutex; -#endif - -# define TclAllocObjStorageEx(interp, objPtr) \ - do { \ - Tcl_MutexLock(&tclObjMutex); \ - if (tclFreeObjList == NULL) { \ - TclAllocateFreeObjects(); \ - } \ - (objPtr) = tclFreeObjList; \ - tclFreeObjList = (Tcl_Obj *) \ - tclFreeObjList->internalRep.otherValuePtr; \ - Tcl_MutexUnlock(&tclObjMutex); \ - } while (0) - -# define TclFreeObjStorageEx(interp, objPtr) \ - do { \ - Tcl_MutexLock(&tclObjMutex); \ - (objPtr)->internalRep.otherValuePtr = (void *) tclFreeObjList; \ - tclFreeObjList = (objPtr); \ - Tcl_MutexUnlock(&tclObjMutex); \ - } while (0) -#endif - #else /* TCL_MEM_DEBUG */ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, int line); @@ -3882,10 +3342,56 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, # define TclNewListObjDirect(objc, objv) \ TclDbNewListObjDirect(objc, objv, __FILE__, __LINE__) -#undef USE_THREAD_ALLOC #endif /* TCL_MEM_DEBUG */ /* + * Macros that drive the allocator behaviour + */ + +#if defined(TCL_THREADS) +/* + * The TCL_THREADS mode is like the regular mode but allocates Tcl_Obj's from + * per-thread caches. + */ +MODULE_SCOPE void TclpFreeAllocCache(void *); +MODULE_SCOPE void * TclpGetAllocCache(void); +MODULE_SCOPE void TclpSetAllocCache(void *); +MODULE_SCOPE void TclFreeAllocCache(void *); +MODULE_SCOPE void TclpFreeAllocMutex(Tcl_Mutex *mutex); +MODULE_SCOPE Tcl_Mutex *TclpNewAllocMutex(void); +#endif + +MODULE_SCOPE void * TclSmallAlloc(); +MODULE_SCOPE void TclSmallFree(void *ptr); +MODULE_SCOPE void TclInitAlloc(void); +MODULE_SCOPE void TclFinalizeAlloc(void); + +#define TclCkSmallAlloc(nbytes, memPtr) \ + do { \ + TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \ + memPtr = TclSmallAlloc(); \ + } while (0) + +/* + * Support for Clang Static Analyzer <http://clang-analyzer.llvm.org> + */ + +#if defined(PURIFY) && defined(__clang__) +#if __has_feature(attribute_analyzer_noreturn) && \ + !defined(Tcl_Panic) && defined(Tcl_Panic_TCL_DECLARED) +void Tcl_Panic(const char *, ...) __attribute__((analyzer_noreturn)); +#endif +#if !defined(CLANG_ASSERT) +#include <assert.h> +#define CLANG_ASSERT(x) assert(x) +#endif +#elif !defined(CLANG_ASSERT) + #define CLANG_ASSERT(x) +#endif /* PURIFY && __clang__ */ + + + +/* *---------------------------------------------------------------- * Macro used by the Tcl core to set a Tcl_Obj's string representation to a * copy of the "len" bytes starting at "bytePtr". This code works even if the @@ -4420,73 +3926,11 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; {enum { ct_assert_value = 1/(!!(e)) };} /* - *---------------------------------------------------------------- - * Allocator for small structs (<=sizeof(Tcl_Obj)) using the Tcl_Obj pool. - * Only checked at compile time. - * - * ONLY USE FOR CONSTANT nBytes. - * - * DO NOT LET THEM CROSS THREAD BOUNDARIES - *---------------------------------------------------------------- - */ - -#define TclSmallAlloc(nbytes, memPtr) \ - TclSmallAllocEx(NULL, (nbytes), (memPtr)) - -#define TclSmallFree(memPtr) \ - TclSmallFreeEx(NULL, (memPtr)) - -#ifndef TCL_MEM_DEBUG -#define TclSmallAllocEx(interp, nbytes, memPtr) \ - do { \ - Tcl_Obj *objPtr; \ - TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \ - TclIncrObjsAllocated(); \ - TclAllocObjStorageEx((interp), (objPtr)); \ - memPtr = (ClientData) (objPtr); \ - } while (0) - -#define TclSmallFreeEx(interp, memPtr) \ - do { \ - TclFreeObjStorageEx((interp), (Tcl_Obj *) (memPtr)); \ - TclIncrObjsFreed(); \ - } while (0) - -#else /* TCL_MEM_DEBUG */ -#define TclSmallAllocEx(interp, nbytes, memPtr) \ - do { \ - Tcl_Obj *objPtr; \ - TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \ - TclNewObj(objPtr); \ - memPtr = (ClientData) objPtr; \ - } while (0) - -#define TclSmallFreeEx(interp, memPtr) \ - do { \ - Tcl_Obj *objPtr = (Tcl_Obj *) memPtr; \ - objPtr->bytes = NULL; \ - objPtr->typePtr = NULL; \ - objPtr->refCount = 1; \ - TclDecrRefCount(objPtr); \ - } while (0) -#endif /* TCL_MEM_DEBUG */ - -/* * Support for Clang Static Analyzer <http://clang-analyzer.llvm.org> */ -#if defined(PURIFY) && defined(__clang__) -#if __has_feature(attribute_analyzer_noreturn) && \ - !defined(Tcl_Panic) && defined(Tcl_Panic_TCL_DECLARED) -void Tcl_Panic(const char *, ...) __attribute__((analyzer_noreturn)); -#endif -#if !defined(CLANG_ASSERT) -#include <assert.h> -#define CLANG_ASSERT(x) assert(x) -#endif -#elif !defined(CLANG_ASSERT) #define CLANG_ASSERT(x) -#endif /* PURIFY && __clang__ */ + /* *---------------------------------------------------------------- @@ -4518,16 +3962,30 @@ typedef struct NRE_callback { #endif +/* GET OUT OF THE ALLOCATOR BIZ! */ +#define TclpAlloc(size) malloc(size) +#define TclpRealloc(ptr, size) realloc((ptr),(size)) +#define TclpFree(ptr) free(ptr) + +#ifdef PURIFY +#define TclSmallAlloc() ckalloc(sizeof(Tcl_Obj)) +#define TclSmallFree(ptr) ckfree(ptr) +#define TclInitAlloc() +#define TclFinalizeAlloc() +#define TclFreeAllocCache(ptr) +#endif + #include "tclIntDecls.h" #include "tclIntPlatDecls.h" #include "tclTomMathDecls.h" -#if !defined(USE_TCL_STUBS) && !defined(TCL_MEM_DEBUG) +#if !defined(USE_TCL_STUBS) #define Tcl_AttemptAlloc(size) TclpAlloc(size) #define Tcl_AttemptRealloc(ptr, size) TclpRealloc((ptr), (size)) #define Tcl_Free(ptr) TclpFree(ptr) #endif + #endif /* _TCLINT */ /* diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 77dd9c6..639e6de 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -59,8 +59,7 @@ /* Slot 0 is reserved */ /* Slot 1 is reserved */ /* Slot 2 is reserved */ -/* 3 */ -EXTERN void TclAllocateFreeObjects(void); +/* Slot 3 is reserved */ /* Slot 4 is reserved */ /* 5 */ EXTERN int TclCleanupChildren(Tcl_Interp *interp, int numPids, @@ -201,14 +200,12 @@ EXTERN int TclObjInvoke(Tcl_Interp *interp, int objc, /* Slot 66 is reserved */ /* Slot 67 is reserved */ /* Slot 68 is reserved */ -/* 69 */ -EXTERN char * TclpAlloc(unsigned int size); +/* Slot 69 is reserved */ /* Slot 70 is reserved */ /* Slot 71 is reserved */ /* Slot 72 is reserved */ /* Slot 73 is reserved */ -/* 74 */ -EXTERN void TclpFree(char *ptr); +/* Slot 74 is reserved */ /* 75 */ EXTERN unsigned long TclpGetClicks(void); /* 76 */ @@ -218,8 +215,7 @@ EXTERN void TclpGetTime(Tcl_Time *time); /* Slot 78 is reserved */ /* Slot 79 is reserved */ /* Slot 80 is reserved */ -/* 81 */ -EXTERN char * TclpRealloc(char *ptr, unsigned int size); +/* Slot 81 is reserved */ /* Slot 82 is reserved */ /* Slot 83 is reserved */ /* Slot 84 is reserved */ @@ -332,8 +328,8 @@ EXTERN int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr, EXTERN void Tcl_PopCallFrame(Tcl_Interp *interp); /* 129 */ EXTERN int Tcl_PushCallFrame(Tcl_Interp *interp, - Tcl_CallFrame *framePtr, - Tcl_Namespace *nsPtr, int isProcCallFrame); + CallFrame *framePtr, Tcl_Namespace *nsPtr, + int isProcCallFrame); /* 130 */ EXTERN int Tcl_RemoveInterpResolvers(Tcl_Interp *interp, const char *name); @@ -510,13 +506,11 @@ EXTERN Tcl_Obj * TclGetObjNameOfExecutable(void); /* 214 */ EXTERN void TclSetObjNameOfExecutable(Tcl_Obj *name, Tcl_Encoding encoding); -/* 215 */ -EXTERN void * TclStackAlloc(Tcl_Interp *interp, int numBytes); -/* 216 */ -EXTERN void TclStackFree(Tcl_Interp *interp, void *freePtr); +/* Slot 215 is reserved */ +/* Slot 216 is reserved */ /* 217 */ EXTERN int TclPushStackFrame(Tcl_Interp *interp, - Tcl_CallFrame **framePtrPtr, + CallFrame **framePtrPtr, Tcl_Namespace *namespacePtr, int isProcCallFrame); /* 218 */ @@ -532,8 +526,7 @@ EXTERN TclPlatformType * TclGetPlatform(void); EXTERN Tcl_Obj * TclTraceDictPath(Tcl_Interp *interp, Tcl_Obj *rootPtr, int keyc, Tcl_Obj *const keyv[], int flags); -/* 226 */ -EXTERN int TclObjBeingDeleted(Tcl_Obj *objPtr); +/* Slot 226 is reserved */ /* 227 */ EXTERN void TclSetNsPath(Namespace *nsPtr, int pathLength, Tcl_Namespace *pathAry[]); @@ -558,14 +551,10 @@ EXTERN Var * TclVarHashCreateVar(TclVarHashTable *tablePtr, /* 235 */ EXTERN void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr); -/* 236 */ -EXTERN void TclBackgroundException(Tcl_Interp *interp, int code); +/* Slot 236 is reserved */ /* 237 */ EXTERN int TclResetCancellation(Tcl_Interp *interp, int force); -/* 238 */ -EXTERN int TclNRInterpProc(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +/* Slot 238 is reserved */ /* 239 */ EXTERN int TclNRInterpProcCore(Tcl_Interp *interp, Tcl_Obj *procNameObj, int skip, @@ -610,7 +599,7 @@ typedef struct TclIntStubs { void (*reserved0)(void); void (*reserved1)(void); void (*reserved2)(void); - void (*tclAllocateFreeObjects) (void); /* 3 */ + void (*reserved3)(void); void (*reserved4)(void); int (*tclCleanupChildren) (Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 5 */ void (*tclCleanupCommand) (Command *cmdPtr); /* 6 */ @@ -676,19 +665,19 @@ typedef struct TclIntStubs { void (*reserved66)(void); void (*reserved67)(void); void (*reserved68)(void); - char * (*tclpAlloc) (unsigned int size); /* 69 */ + void (*reserved69)(void); void (*reserved70)(void); void (*reserved71)(void); void (*reserved72)(void); void (*reserved73)(void); - void (*tclpFree) (char *ptr); /* 74 */ + void (*reserved74)(void); unsigned long (*tclpGetClicks) (void); /* 75 */ unsigned long (*tclpGetSeconds) (void); /* 76 */ void (*tclpGetTime) (Tcl_Time *time); /* 77 */ void (*reserved78)(void); void (*reserved79)(void); void (*reserved80)(void); - char * (*tclpRealloc) (char *ptr, unsigned int size); /* 81 */ + void (*reserved81)(void); void (*reserved82)(void); void (*reserved83)(void); void (*reserved84)(void); @@ -736,7 +725,7 @@ typedef struct TclIntStubs { void (*tcl_GetVariableFullName) (Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr); /* 126 */ int (*tcl_Import) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite); /* 127 */ void (*tcl_PopCallFrame) (Tcl_Interp *interp); /* 128 */ - int (*tcl_PushCallFrame) (Tcl_Interp *interp, Tcl_CallFrame *framePtr, Tcl_Namespace *nsPtr, int isProcCallFrame); /* 129 */ + int (*tcl_PushCallFrame) (Tcl_Interp *interp, CallFrame *framePtr, Tcl_Namespace *nsPtr, int isProcCallFrame); /* 129 */ int (*tcl_RemoveInterpResolvers) (Tcl_Interp *interp, const char *name); /* 130 */ void (*tcl_SetNamespaceResolvers) (Tcl_Namespace *namespacePtr, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 131 */ int (*tclpHasSockets) (Tcl_Interp *interp); /* 132 */ @@ -822,9 +811,9 @@ typedef struct TclIntStubs { void (*tclpFindExecutable) (const char *argv0); /* 212 */ Tcl_Obj * (*tclGetObjNameOfExecutable) (void); /* 213 */ void (*tclSetObjNameOfExecutable) (Tcl_Obj *name, Tcl_Encoding encoding); /* 214 */ - void * (*tclStackAlloc) (Tcl_Interp *interp, int numBytes); /* 215 */ - void (*tclStackFree) (Tcl_Interp *interp, void *freePtr); /* 216 */ - int (*tclPushStackFrame) (Tcl_Interp *interp, Tcl_CallFrame **framePtrPtr, Tcl_Namespace *namespacePtr, int isProcCallFrame); /* 217 */ + void (*reserved215)(void); + void (*reserved216)(void); + int (*tclPushStackFrame) (Tcl_Interp *interp, CallFrame **framePtrPtr, Tcl_Namespace *namespacePtr, int isProcCallFrame); /* 217 */ void (*tclPopStackFrame) (Tcl_Interp *interp); /* 218 */ void (*reserved219)(void); void (*reserved220)(void); @@ -833,7 +822,7 @@ typedef struct TclIntStubs { void (*reserved223)(void); TclPlatformType * (*tclGetPlatform) (void); /* 224 */ Tcl_Obj * (*tclTraceDictPath) (Tcl_Interp *interp, Tcl_Obj *rootPtr, int keyc, Tcl_Obj *const keyv[], int flags); /* 225 */ - int (*tclObjBeingDeleted) (Tcl_Obj *objPtr); /* 226 */ + void (*reserved226)(void); void (*tclSetNsPath) (Namespace *nsPtr, int pathLength, Tcl_Namespace *pathAry[]); /* 227 */ void (*reserved228)(void); int (*tclPtrMakeUpvar) (Tcl_Interp *interp, Var *otherP1Ptr, const char *myName, int myFlags, int index); /* 229 */ @@ -843,9 +832,9 @@ typedef struct TclIntStubs { void (*reserved233)(void); Var * (*tclVarHashCreateVar) (TclVarHashTable *tablePtr, const char *key, int *newPtr); /* 234 */ void (*tclInitVarHashTable) (TclVarHashTable *tablePtr, Namespace *nsPtr); /* 235 */ - void (*tclBackgroundException) (Tcl_Interp *interp, int code); /* 236 */ + void (*reserved236)(void); int (*tclResetCancellation) (Tcl_Interp *interp, int force); /* 237 */ - int (*tclNRInterpProc) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 238 */ + void (*reserved238)(void); int (*tclNRInterpProcCore) (Tcl_Interp *interp, Tcl_Obj *procNameObj, int skip, ProcErrorProc *errorProc); /* 239 */ int (*tclNRRunCallbacks) (Tcl_Interp *interp, int result); /* 240 */ int (*tclNREvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 241 */ @@ -877,8 +866,7 @@ extern const TclIntStubs *tclIntStubsPtr; /* Slot 0 is reserved */ /* Slot 1 is reserved */ /* Slot 2 is reserved */ -#define TclAllocateFreeObjects \ - (tclIntStubsPtr->tclAllocateFreeObjects) /* 3 */ +/* Slot 3 is reserved */ /* Slot 4 is reserved */ #define TclCleanupChildren \ (tclIntStubsPtr->tclCleanupChildren) /* 5 */ @@ -982,14 +970,12 @@ extern const TclIntStubs *tclIntStubsPtr; /* Slot 66 is reserved */ /* Slot 67 is reserved */ /* Slot 68 is reserved */ -#define TclpAlloc \ - (tclIntStubsPtr->tclpAlloc) /* 69 */ +/* Slot 69 is reserved */ /* Slot 70 is reserved */ /* Slot 71 is reserved */ /* Slot 72 is reserved */ /* Slot 73 is reserved */ -#define TclpFree \ - (tclIntStubsPtr->tclpFree) /* 74 */ +/* Slot 74 is reserved */ #define TclpGetClicks \ (tclIntStubsPtr->tclpGetClicks) /* 75 */ #define TclpGetSeconds \ @@ -999,8 +985,7 @@ extern const TclIntStubs *tclIntStubsPtr; /* Slot 78 is reserved */ /* Slot 79 is reserved */ /* Slot 80 is reserved */ -#define TclpRealloc \ - (tclIntStubsPtr->tclpRealloc) /* 81 */ +/* Slot 81 is reserved */ /* Slot 82 is reserved */ /* Slot 83 is reserved */ /* Slot 84 is reserved */ @@ -1219,10 +1204,8 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclGetObjNameOfExecutable) /* 213 */ #define TclSetObjNameOfExecutable \ (tclIntStubsPtr->tclSetObjNameOfExecutable) /* 214 */ -#define TclStackAlloc \ - (tclIntStubsPtr->tclStackAlloc) /* 215 */ -#define TclStackFree \ - (tclIntStubsPtr->tclStackFree) /* 216 */ +/* Slot 215 is reserved */ +/* Slot 216 is reserved */ #define TclPushStackFrame \ (tclIntStubsPtr->tclPushStackFrame) /* 217 */ #define TclPopStackFrame \ @@ -1236,8 +1219,7 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclGetPlatform) /* 224 */ #define TclTraceDictPath \ (tclIntStubsPtr->tclTraceDictPath) /* 225 */ -#define TclObjBeingDeleted \ - (tclIntStubsPtr->tclObjBeingDeleted) /* 226 */ +/* Slot 226 is reserved */ #define TclSetNsPath \ (tclIntStubsPtr->tclSetNsPath) /* 227 */ /* Slot 228 is reserved */ @@ -1253,12 +1235,10 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclVarHashCreateVar) /* 234 */ #define TclInitVarHashTable \ (tclIntStubsPtr->tclInitVarHashTable) /* 235 */ -#define TclBackgroundException \ - (tclIntStubsPtr->tclBackgroundException) /* 236 */ +/* Slot 236 is reserved */ #define TclResetCancellation \ (tclIntStubsPtr->tclResetCancellation) /* 237 */ -#define TclNRInterpProc \ - (tclIntStubsPtr->tclNRInterpProc) /* 238 */ +/* Slot 238 is reserved */ #define TclNRInterpProcCore \ (tclIntStubsPtr->tclNRInterpProcCore) /* 239 */ #define TclNRRunCallbacks \ @@ -1338,4 +1318,7 @@ extern const TclIntStubs *tclIntStubsPtr; (tclStubsPtr->tcl_GetCommandFullName) /* 517 */ #endif +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLIMPORT + #endif /* _TCLINTDECLS */ diff --git a/generic/tclInterp.c b/generic/tclInterp.c index fb84247..41f9520 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -248,6 +248,9 @@ static void DeleteScriptLimitCallback(ClientData clientData); static void RunLimitHandlers(LimitHandler *handlerPtr, Tcl_Interp *interp); static void TimeLimitCallback(ClientData clientData); + +#define isAlias(cmdPtr) ((cmdPtr)->deleteProc == AliasObjCmdDeleteProc) + /* *---------------------------------------------------------------------- @@ -761,10 +764,8 @@ Tcl_InterpObjCmd( */ for (i = 0; ; i++) { - Tcl_CmdInfo cmdInfo; - sprintf(buf, "interp%d", i); - if (Tcl_GetCommandInfo(interp, buf, &cmdInfo) == 0) { + if (Tcl_FindCommand(interp, buf, NULL, 0) == 0) { break; } } @@ -1133,7 +1134,7 @@ Tcl_CreateAlias( int i; int result; - objv = TclStackAlloc(slaveInterp, (unsigned) sizeof(Tcl_Obj *) * argc); + objv = ckalloc((unsigned) sizeof(Tcl_Obj *) * argc); for (i = 0; i < argc; i++) { objv[i] = Tcl_NewStringObj(argv[i], -1); Tcl_IncrRefCount(objv[i]); @@ -1151,7 +1152,7 @@ Tcl_CreateAlias( for (i = 0; i < argc; i++) { Tcl_DecrRefCount(objv[i]); } - TclStackFree(slaveInterp, objv); + ckfree(objv); Tcl_DecrRefCount(targetObjPtr); Tcl_DecrRefCount(slaveObjPtr); @@ -1359,7 +1360,7 @@ TclPreventAliasLoop( * create or rename the command. */ - if (cmdPtr->objProc != AliasObjCmd) { + if (!isAlias(cmdPtr)) { return TCL_OK; } @@ -1414,7 +1415,7 @@ TclPreventAliasLoop( * Otherwise we do not have a loop. */ - if (aliasCmdPtr->objProc != AliasObjCmd) { + if (!isAlias(aliasCmdPtr)) { return TCL_OK; } nextAliasPtr = aliasCmdPtr->objClientData; @@ -1479,8 +1480,8 @@ AliasCreate( Tcl_Preserve(masterInterp); if (slaveInterp == masterInterp) { - aliasPtr->slaveCmd = Tcl_NRCreateCommand(slaveInterp, - TclGetString(namePtr), AliasObjCmd, AliasNRCmd, aliasPtr, + aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp, + TclGetString(namePtr), AliasNRCmd, aliasPtr, AliasObjCmdDeleteProc); } else { aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp, @@ -1831,7 +1832,7 @@ AliasObjCmd( if (cmdc <= ALIAS_CMDV_PREALLOC) { cmdv = cmdArr; } else { - cmdv = TclStackAlloc(interp, cmdc * sizeof(Tcl_Obj *)); + cmdv = ckalloc(cmdc * sizeof(Tcl_Obj *)); } prefv = &aliasPtr->objPtr; @@ -1898,7 +1899,7 @@ AliasObjCmd( Tcl_DecrRefCount(cmdv[i]); } if (cmdv != cmdArr) { - TclStackFree(interp, cmdv); + ckfree(cmdv); } return result; #undef ALIAS_CMDV_PREALLOC diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index 441ea91..628a5d8 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -15,7 +15,7 @@ */ #include "tclInt.h" -#include "tclCompile.h" +#include "tclCompileInt.h" /* * When there are this many entries per bucket, on average, rebuild a @@ -108,10 +108,6 @@ TclDeleteLiteralTable( * search from the bucket chain we last found an entry. */ -#ifdef TCL_COMPILE_DEBUG - TclVerifyGlobalLiteralTable((Interp *) interp); -#endif /*TCL_COMPILE_DEBUG*/ - /* * We used to call TclReleaseLiteral for each literal in the table, which * is rather inefficient as it causes one lookup-by-hash for each @@ -238,13 +234,6 @@ TclCreateLiteral( TclInitStringRep(objPtr, bytes, length); } -#ifdef TCL_COMPILE_DEBUG - if (TclLookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) { - Tcl_Panic("%s: literal \"%.*s\" found globally but shouldn't be", - "TclRegisterLiteral", (length>60? 60 : length), bytes); - } -#endif - globalPtr = ckalloc(sizeof(LiteralEntry)); globalPtr->objPtr = objPtr; globalPtr->refCount = 1; @@ -262,35 +251,6 @@ TclCreateLiteral( RebuildLiteralTable(globalTablePtr); } -#ifdef TCL_COMPILE_DEBUG - TclVerifyGlobalLiteralTable(iPtr); - { - LiteralEntry *entryPtr; - int found, i; - - found = 0; - for (i=0 ; i<globalTablePtr->numBuckets ; i++) { - for (entryPtr=globalTablePtr->buckets[i]; entryPtr!=NULL ; - entryPtr=entryPtr->nextPtr) { - if ((entryPtr == globalPtr) && (entryPtr->objPtr == objPtr)) { - found = 1; - } - } - } - if (!found) { - Tcl_Panic("%s: literal \"%.*s\" wasn't global", - "TclRegisterLiteral", (length>60? 60 : length), bytes); - } - } -#endif /*TCL_COMPILE_DEBUG*/ - -#ifdef TCL_COMPILE_STATS - iPtr->stats.numLiteralsCreated++; - iPtr->stats.totalLitStringBytes += (double) (length + 1); - iPtr->stats.currentLitStringBytes += (double) (length + 1); - iPtr->stats.literalCount[TclLog2(length)]++; -#endif /*TCL_COMPILE_STATS*/ - if (globalPtrPtr) { *globalPtrPtr = globalPtr; } @@ -370,9 +330,6 @@ TclRegisterLiteral( ckfree(bytes); } objIndex = (localPtr - envPtr->literalArrayPtr); -#ifdef TCL_COMPILE_DEBUG - TclVerifyLocalLiteralTable(envPtr); -#endif /*TCL_COMPILE_DEBUG*/ return objIndex; } @@ -403,14 +360,6 @@ TclRegisterLiteral( &globalPtr); objIndex = AddLocalLiteralEntry(envPtr, objPtr, localHash); -#ifdef TCL_COMPILE_DEBUG - if (globalPtr->refCount < 1) { - Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d", - "TclRegisterLiteral", (length>60? 60 : length), bytes, - globalPtr->refCount); - } - TclVerifyLocalLiteralTable(envPtr); -#endif /*TCL_COMPILE_DEBUG*/ return objIndex; } @@ -620,30 +569,6 @@ AddLocalLiteralEntry( RebuildLiteralTable(localTablePtr); } -#ifdef TCL_COMPILE_DEBUG - TclVerifyLocalLiteralTable(envPtr); - { - char *bytes; - int length, found, i; - - found = 0; - for (i=0 ; i<localTablePtr->numBuckets ; i++) { - for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL ; - localPtr=localPtr->nextPtr) { - if (localPtr->objPtr == objPtr) { - found = 1; - } - } - } - - if (!found) { - bytes = Tcl_GetStringFromObj(objPtr, &length); - Tcl_Panic("%s: literal \"%.*s\" wasn't found locally", - "AddLocalLiteralEntry", (length>60? 60 : length), bytes); - } - } -#endif /*TCL_COMPILE_DEBUG*/ - return objIndex; } @@ -786,9 +711,6 @@ TclReleaseLiteral( TclDecrRefCount(objPtr); -#ifdef TCL_COMPILE_STATS - iPtr->stats.currentLitStringBytes -= (double) (length + 1); -#endif /*TCL_COMPILE_STATS*/ } break; } @@ -976,192 +898,6 @@ TclInvalidateCmdLiteral( } } -#ifdef TCL_COMPILE_STATS -/* - *---------------------------------------------------------------------- - * - * TclLiteralStats -- - * - * Return statistics describing the layout of the hash table in its hash - * buckets. - * - * Results: - * The return value is a malloc-ed string containing information about - * tablePtr. It is the caller's responsibility to free this string. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -char * -TclLiteralStats( - LiteralTable *tablePtr) /* Table for which to produce stats. */ -{ -#define NUM_COUNTERS 10 - int count[NUM_COUNTERS], overflow, i, j; - double average, tmp; - register LiteralEntry *entryPtr; - char *result, *p; - - /* - * Compute a histogram of bucket usage. For each bucket chain i, j is the - * number of entries in the chain. - */ - - for (i=0 ; i<NUM_COUNTERS ; i++) { - count[i] = 0; - } - overflow = 0; - average = 0.0; - for (i=0 ; i<tablePtr->numBuckets ; i++) { - j = 0; - for (entryPtr=tablePtr->buckets[i] ; entryPtr!=NULL; - entryPtr=entryPtr->nextPtr) { - j++; - } - if (j < NUM_COUNTERS) { - count[j]++; - } else { - overflow++; - } - tmp = j; - average += (tmp+1.0)*(tmp/tablePtr->numEntries)/2.0; - } - - /* - * Print out the histogram and a few other pieces of information. - */ - - result = ckalloc(NUM_COUNTERS*60 + 300); - sprintf(result, "%d entries in table, %d buckets\n", - tablePtr->numEntries, tablePtr->numBuckets); - p = result + strlen(result); - for (i=0 ; i<NUM_COUNTERS ; i++) { - sprintf(p, "number of buckets with %d entries: %d\n", - i, count[i]); - p += strlen(p); - } - sprintf(p, "number of buckets with %d or more entries: %d\n", - NUM_COUNTERS, overflow); - p += strlen(p); - sprintf(p, "average search distance for entry: %.1f", average); - return result; -} -#endif /*TCL_COMPILE_STATS*/ - -#ifdef TCL_COMPILE_DEBUG -/* - *---------------------------------------------------------------------- - * - * TclVerifyLocalLiteralTable -- - * - * Check a CompileEnv's local literal table for consistency. - * - * Results: - * None. - * - * Side effects: - * Tcl_Panic if problems are found. - * - *---------------------------------------------------------------------- - */ - -void -TclVerifyLocalLiteralTable( - CompileEnv *envPtr) /* Points to CompileEnv whose literal table is - * to be validated. */ -{ - register LiteralTable *localTablePtr = &envPtr->localLitTable; - register LiteralEntry *localPtr; - char *bytes; - register int i; - int length, count; - - count = 0; - for (i=0 ; i<localTablePtr->numBuckets ; i++) { - for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL; - localPtr=localPtr->nextPtr) { - count++; - if (localPtr->refCount != -1) { - bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length); - Tcl_Panic("%s: local literal \"%.*s\" had bad refCount %d", - "TclVerifyLocalLiteralTable", - (length>60? 60 : length), bytes, localPtr->refCount); - } - if (TclLookupLiteralEntry((Tcl_Interp *) envPtr->iPtr, - localPtr->objPtr) == NULL) { - bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length); - Tcl_Panic("%s: local literal \"%.*s\" is not global", - "TclVerifyLocalLiteralTable", - (length>60? 60 : length), bytes); - } - if (localPtr->objPtr->bytes == NULL) { - Tcl_Panic("%s: literal has NULL string rep", - "TclVerifyLocalLiteralTable"); - } - } - } - if (count != localTablePtr->numEntries) { - Tcl_Panic("%s: local literal table had %d entries, should be %d", - "TclVerifyLocalLiteralTable", count, - localTablePtr->numEntries); - } -} - -/* - *---------------------------------------------------------------------- - * - * TclVerifyGlobalLiteralTable -- - * - * Check an interpreter's global literal table literal for consistency. - * - * Results: - * None. - * - * Side effects: - * Tcl_Panic if problems are found. - * - *---------------------------------------------------------------------- - */ - -void -TclVerifyGlobalLiteralTable( - Interp *iPtr) /* Points to interpreter whose global literal - * table is to be validated. */ -{ - register LiteralTable *globalTablePtr = &iPtr->literalTable; - register LiteralEntry *globalPtr; - char *bytes; - register int i; - int length, count; - - count = 0; - for (i=0 ; i<globalTablePtr->numBuckets ; i++) { - for (globalPtr=globalTablePtr->buckets[i] ; globalPtr!=NULL; - globalPtr=globalPtr->nextPtr) { - count++; - if (globalPtr->refCount < 1) { - bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length); - Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d", - "TclVerifyGlobalLiteralTable", - (length>60? 60 : length), bytes, globalPtr->refCount); - } - if (globalPtr->objPtr->bytes == NULL) { - Tcl_Panic("%s: literal has NULL string rep", - "TclVerifyGlobalLiteralTable"); - } - } - } - if (count != globalTablePtr->numEntries) { - Tcl_Panic("%s: global literal table had %d entries, should be %d", - "TclVerifyGlobalLiteralTable", count, - globalTablePtr->numEntries); - } -} -#endif /*TCL_COMPILE_DEBUG*/ - /* * Local Variables: * mode: c diff --git a/generic/tclNRE.h b/generic/tclNRE.h index d740105..9c99f19 100644 --- a/generic/tclNRE.h +++ b/generic/tclNRE.h @@ -3,7 +3,11 @@ * ********************************************** */ +#ifdef TCL_NRE_DEBUG +#define NRE_STACK_DEBUG 1 +#else #define NRE_STACK_DEBUG 0 +#endif #define NRE_STACK_SIZE 100 diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 7604026..14408c9 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -91,8 +91,6 @@ static int GetNamespaceFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); static int InvokeImportedCmd(ClientData clientData, Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); -static int InvokeImportedNRCmd(ClientData clientData, - Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int NamespaceChildrenCmd(ClientData dummy, Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int NamespaceCodeCmd(ClientData dummy, Tcl_Interp *interp, @@ -103,8 +101,6 @@ static int NamespaceDeleteCmd(ClientData dummy,Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int NamespaceEvalCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int NRNamespaceEvalCmd(ClientData dummy, - Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int NamespaceExistsCmd(ClientData dummy,Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int NamespaceExportCmd(ClientData dummy,Tcl_Interp *interp, @@ -116,8 +112,6 @@ static int NamespaceImportCmd(ClientData dummy,Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int NamespaceInscopeCmd(ClientData dummy, Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); -static int NRNamespaceInscopeCmd(ClientData dummy, - Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int NamespaceOriginCmd(ClientData dummy,Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int NamespaceParentCmd(ClientData dummy,Tcl_Interp *interp, @@ -160,26 +154,26 @@ static const Tcl_ObjType nsNameType = { */ static const EnsembleImplMap defaultNamespaceMap[] = { - {"children", NamespaceChildrenCmd, TclCompileBasic0To2ArgCmd, NULL, NULL, 0}, - {"code", NamespaceCodeCmd, TclCompileNamespaceCodeCmd, NULL, NULL, 0}, - {"current", NamespaceCurrentCmd, TclCompileNamespaceCurrentCmd, NULL, NULL, 0}, - {"delete", NamespaceDeleteCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, - {"ensemble", TclNamespaceEnsembleCmd, NULL, NULL, NULL, 0}, - {"eval", NamespaceEvalCmd, NULL, NRNamespaceEvalCmd, NULL, 0}, - {"exists", NamespaceExistsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"export", NamespaceExportCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, - {"forget", NamespaceForgetCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, - {"import", NamespaceImportCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, - {"inscope", NamespaceInscopeCmd, NULL, NRNamespaceInscopeCmd, NULL, 0}, - {"origin", NamespaceOriginCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"parent", NamespaceParentCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, - {"path", NamespacePathCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, - {"qualifiers", NamespaceQualifiersCmd, TclCompileNamespaceQualifiersCmd, NULL, NULL, 0}, - {"tail", NamespaceTailCmd, TclCompileNamespaceTailCmd, NULL, NULL, 0}, - {"unknown", NamespaceUnknownCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, - {"upvar", NamespaceUpvarCmd, TclCompileNamespaceUpvarCmd, NULL, NULL, 0}, - {"which", NamespaceWhichCmd, TclCompileNamespaceWhichCmd, NULL, NULL, 0}, - {NULL, NULL, NULL, NULL, NULL, 0} + {"children", NamespaceChildrenCmd, NULL, NULL, 0}, + {"code", NamespaceCodeCmd, NULL, NULL, 0}, + {"current", NamespaceCurrentCmd, NULL, NULL, 0}, + {"delete", NamespaceDeleteCmd, NULL, NULL, 0}, + {"ensemble", TclNamespaceEnsembleCmd, NULL, NULL, 0}, + {"eval", NamespaceEvalCmd, NULL, NULL, 0}, + {"exists", NamespaceExistsCmd, NULL, NULL, 0}, + {"export", NamespaceExportCmd, NULL, NULL, 0}, + {"forget", NamespaceForgetCmd, NULL, NULL, 0}, + {"import", NamespaceImportCmd, NULL, NULL, 0}, + {"inscope", NamespaceInscopeCmd, NULL, NULL, 0}, + {"origin", NamespaceOriginCmd, NULL, NULL, 0}, + {"parent", NamespaceParentCmd, NULL, NULL, 0}, + {"path", NamespacePathCmd, NULL, NULL, 0}, + {"qualifiers", NamespaceQualifiersCmd, NULL, NULL, 0}, + {"tail", NamespaceTailCmd, NULL, NULL, 0}, + {"unknown", NamespaceUnknownCmd, NULL, NULL, 0}, + {"upvar", NamespaceUpvarCmd, NULL, NULL, 0}, + {"which", NamespaceWhichCmd, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, 0} }; /* @@ -278,7 +272,7 @@ int Tcl_PushCallFrame( Tcl_Interp *interp, /* Interpreter in which the new call frame is * to be pushed. */ - Tcl_CallFrame *callFramePtr,/* Points to a call frame structure to push. + CallFrame *framePtr, /* Points to a call frame structure to push. * Storage for this has already been allocated * by the caller; typically this is the * address of a CallFrame structure allocated @@ -301,7 +295,6 @@ Tcl_PushCallFrame( * variables. */ { Interp *iPtr = (Interp *) interp; - register CallFrame *framePtr = (CallFrame *) callFramePtr; register Namespace *nsPtr; if (namespacePtr == NULL) { @@ -450,7 +443,7 @@ int TclPushStackFrame( Tcl_Interp *interp, /* Interpreter in which the new call frame is * to be pushed. */ - Tcl_CallFrame **framePtrPtr,/* Place to store a pointer to the stack + CallFrame **framePtrPtr,/* Place to store a pointer to the stack * allocated call frame. */ Tcl_Namespace *namespacePtr,/* Points to the namespace in which the frame * will execute. If NULL, the interpreter's @@ -465,7 +458,7 @@ TclPushStackFrame( * treated as references to namespace * variables. */ { - *framePtrPtr = TclStackAlloc(interp, sizeof(CallFrame)); + *framePtrPtr = ckalloc(sizeof(CallFrame)); return Tcl_PushCallFrame(interp, *framePtrPtr, namespacePtr, isProcCallFrame); } @@ -477,7 +470,7 @@ TclPopStackFrame( CallFrame *freePtr = ((Interp *) interp)->framePtr; Tcl_PopCallFrame(interp); - TclStackFree(interp, freePtr); + ckfree(freePtr); } /* @@ -914,7 +907,7 @@ Tcl_DeleteNamespace( for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); entryPtr != NULL;) { cmdPtr = Tcl_GetHashValue(entryPtr); - if (cmdPtr->nreProc == TclNRInterpCoroutine) { + if (cmdPtr->objProc == TclNRInterpCoroutine) { Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, (Tcl_Command) cmdPtr); entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); @@ -1695,9 +1688,8 @@ DoImport( } dataPtr = ckalloc(sizeof(ImportedCmdData)); - importedCmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), - InvokeImportedCmd, InvokeImportedNRCmd, dataPtr, - DeleteImportedCmd); + importedCmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds), + InvokeImportedCmd, dataPtr, DeleteImportedCmd); dataPtr->realCmdPtr = cmdPtr; dataPtr->selfPtr = (Command *) importedCmd; dataPtr->selfPtr->compileProc = cmdPtr->compileProc; @@ -1840,14 +1832,13 @@ Tcl_ForgetImport( for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); (hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) { - Tcl_CmdInfo info; Tcl_Command token = Tcl_GetHashValue(hPtr); - Tcl_Command origin = TclGetOriginalCommand(token); + Command *origin = (Command *) TclGetOriginalCommand(token); - if (Tcl_GetCommandInfoFromToken(origin, &info) == 0) { + if (origin == NULL) { continue; /* Not an imported command. */ } - if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) { + if (origin->nsPtr != sourceNsPtr) { /* * Original not in namespace we're matching. Check the first link * in the import chain. @@ -1855,18 +1846,17 @@ Tcl_ForgetImport( Command *cmdPtr = (Command *) token; ImportedCmdData *dataPtr = cmdPtr->objClientData; - Tcl_Command firstToken = (Tcl_Command) dataPtr->realCmdPtr; + Command *firstToken = dataPtr->realCmdPtr; if (firstToken == origin) { continue; } - Tcl_GetCommandInfoFromToken(firstToken, &info); - if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) { + if (firstToken->nsPtr != sourceNsPtr) { continue; } origin = firstToken; } - if (Tcl_StringMatch(Tcl_GetCommandName(NULL, origin), simplePattern)){ + if (Tcl_StringMatch(Tcl_GetCommandName(NULL, (Tcl_Command) origin), simplePattern)){ Tcl_DeleteCommandFromToken(interp, token); } } @@ -1935,7 +1925,7 @@ TclGetOriginalCommand( */ static int -InvokeImportedNRCmd( +InvokeImportedCmd( ClientData clientData, /* Points to the imported command's * ImportedCmdData structure. */ Tcl_Interp *interp, /* Current interpreter. */ @@ -1948,18 +1938,6 @@ InvokeImportedNRCmd( TclSkipTailcall(interp); return Tcl_NRCmdSwap(interp, (Tcl_Command) realCmdPtr, objc, objv, 0); } - -static int -InvokeImportedCmd( - ClientData clientData, /* Points to the imported command's - * ImportedCmdData structure. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* The argument objects. */ -{ - return Tcl_NRCallObjProc(interp, InvokeImportedNRCmd, clientData, - objc, objv); -} /* *---------------------------------------------------------------------- @@ -2265,7 +2243,7 @@ TclGetNamespaceForQualName( if (entryPtr != NULL) { nsPtr = Tcl_GetHashValue(entryPtr); } else if (flags & TCL_CREATE_NS_IF_UNKNOWN) { - Tcl_CallFrame *framePtr; + CallFrame *framePtr; (void) TclPushStackFrame(interp, &framePtr, (Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 0); @@ -2641,8 +2619,7 @@ TclResetShadowedCmdRefs( int found, i; int trailFront = -1; int trailSize = 5; /* Formerly NUM_TRAIL_ELEMS. */ - Namespace **trailPtr = TclStackAlloc(interp, - trailSize * sizeof(Namespace *)); + Namespace **trailPtr = ckalloc(trailSize * sizeof(Namespace *)); /* * Start at the namespace containing the new command, and work up through @@ -2731,13 +2708,12 @@ TclResetShadowedCmdRefs( if (trailFront == trailSize) { int newSize = 2 * trailSize; - trailPtr = TclStackRealloc(interp, trailPtr, - newSize * sizeof(Namespace *)); + trailPtr = ckrealloc(trailPtr, newSize * sizeof(Namespace *)); trailSize = newSize; } trailPtr[trailFront] = nsPtr; } - TclStackFree(interp, trailPtr); + ckfree(trailPtr); } /* @@ -3227,17 +3203,6 @@ NamespaceEvalCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - return Tcl_NRCallObjProc(interp, NRNamespaceEvalCmd, clientData, objc, - objv); -} - -static int -NRNamespaceEvalCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ Interp *iPtr = (Interp *) interp; Tcl_Namespace *namespacePtr; CallFrame *framePtr, **framePtrPtr; @@ -3276,7 +3241,7 @@ NRNamespaceEvalCmd( /* This is needed to satisfy GCC 3.3's strict aliasing rules */ framePtrPtr = &framePtr; - result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, + result = TclPushStackFrame(interp, framePtrPtr, namespacePtr, /*isProcCallFrame*/ 0); if (result != TCL_OK) { return TCL_ERROR; @@ -3690,17 +3655,6 @@ NamespaceInscopeCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - return Tcl_NRCallObjProc(interp, NRNamespaceInscopeCmd, clientData, objc, - objv); -} - -static int -NRNamespaceInscopeCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ Tcl_Namespace *namespacePtr; CallFrame *framePtr, **framePtrPtr; register Interp *iPtr = (Interp *) interp; @@ -3726,7 +3680,7 @@ NRNamespaceInscopeCmd( framePtrPtr = &framePtr; /* This is needed to satisfy GCC's * strict aliasing rules. */ - result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, + result = TclPushStackFrame(interp, framePtrPtr, namespacePtr, /*isProcCallFrame*/ 0); if (result != TCL_OK) { return result; @@ -3963,8 +3917,7 @@ NamespacePathCmd( goto badNamespace; } if (nsObjc != 0) { - namespaceList = TclStackAlloc(interp, - sizeof(Tcl_Namespace *) * nsObjc); + namespaceList = ckalloc(sizeof(Tcl_Namespace *) * nsObjc); for (i=0 ; i<nsObjc ; i++) { if (TclGetNamespaceFromObj(interp, nsObjv[i], @@ -3983,7 +3936,7 @@ NamespacePathCmd( result = TCL_OK; badNamespace: if (namespaceList != NULL) { - TclStackFree(interp, namespaceList); + ckfree(namespaceList); } return result; } diff --git a/generic/tclOO.c b/generic/tclOO.c index e7071ec..cbdd2dc 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -87,15 +87,9 @@ static void SquelchedNsFirst(ClientData clientData); static int PublicObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -static int PublicNRObjectCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); static int PrivateObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -static int PrivateNRObjectCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); /* * Methods in the oo::object and oo::class classes. First, we define a helper @@ -314,7 +308,6 @@ InitFoundation( Foundation *fPtr = ckalloc(sizeof(Foundation)); Tcl_Obj *namePtr, *argsPtr, *bodyPtr; Tcl_DString buffer; - Command *cmdPtr; int i; /* @@ -441,9 +434,8 @@ InitFoundation( NULL); Tcl_CreateObjCommand(interp, "::oo::Helpers::nextto", TclOONextToObjCmd, NULL, NULL); - cmdPtr = (Command *) Tcl_CreateObjCommand(interp, "::oo::Helpers::self", + Tcl_CreateObjCommand(interp, "::oo::Helpers::self", TclOOSelfObjCmd, NULL, NULL); - cmdPtr->compileProc = TclCompileObjectSelfCmd; Tcl_CreateObjCommand(interp, "::oo::define", TclOODefineObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "::oo::objdefine", TclOOObjDefObjCmd, NULL, @@ -673,7 +665,7 @@ AllocObject( */ cmdPtr = (Command *) oPtr->command; - cmdPtr->nreProc = PublicNRObjectCmd; + cmdPtr->objProc = PublicObjectCmd; cmdPtr->tracePtr = tracePtr = ckalloc(sizeof(CommandTrace)); tracePtr->traceProc = ObjectRenamedTrace; tracePtr->clientData = oPtr; @@ -697,7 +689,7 @@ AllocObject( cmdPtr->objClientData = cmdPtr->deleteData = oPtr; cmdPtr->proc = TclInvokeObjectCommand; cmdPtr->clientData = cmdPtr; - cmdPtr->nreProc = PrivateNRObjectCmd; + cmdPtr->objProc = PrivateObjectCmd; Tcl_SetHashValue(cmdPtr->hPtr, cmdPtr); oPtr->myCommand = (Tcl_Command) cmdPtr; @@ -2385,16 +2377,6 @@ PublicObjectCmd( int objc, Tcl_Obj *const *objv) { - return Tcl_NRCallObjProc(interp, PublicNRObjectCmd, clientData,objc,objv); -} - -static int -PublicNRObjectCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ return TclOOObjectCmdCore(clientData, interp, objc, objv, PUBLIC_METHOD, NULL); } @@ -2406,16 +2388,6 @@ PrivateObjectCmd( int objc, Tcl_Obj *const *objv) { - return Tcl_NRCallObjProc(interp, PrivateNRObjectCmd,clientData,objc,objv); -} - -static int -PrivateNRObjectCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ return TclOOObjectCmdCore(clientData, interp, objc, objv, 0, NULL); } diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index c08e975..e79069f 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -124,7 +124,7 @@ TclOO_Class_Constructor( * trace, so use TCL_EVAL_NOERR. */ - return TclNREvalObjv(interp, 3, invoke, TCL_EVAL_NOERR, NULL); + return Tcl_EvalObjv(interp, 3, invoke, TCL_EVAL_NOERR); } static int @@ -417,7 +417,7 @@ TclOO_Object_Eval( * command(s). */ - result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, + result = TclPushStackFrame(interp, framePtrPtr, Tcl_GetObjectNamespace(object), 0); if (result != TCL_OK) { return TCL_ERROR; @@ -708,7 +708,7 @@ TclOO_Object_VarName( */ if (iPtr->varFramePtr == NULL) { - Tcl_CallFrame *dummyFrame; + CallFrame *dummyFrame; TclPushStackFrame(interp, &dummyFrame, Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context)),0); diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 88a5bd9..a18b364 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -105,7 +105,7 @@ TclOODeleteContext( TclOODeleteChain(contextPtr->callPtr); if (oPtr != NULL) { - TclStackFree(oPtr->fPtr->interp, contextPtr); + ckfree(contextPtr); DelRef(oPtr); } } @@ -1105,7 +1105,7 @@ TclOOGetCallContext( } returnContext: - contextPtr = TclStackAlloc(oPtr->fPtr->interp, sizeof(CallContext)); + contextPtr = ckalloc(sizeof(CallContext)); contextPtr->oPtr = oPtr; AddRef(oPtr); contextPtr->callPtr = callPtr; @@ -1446,7 +1446,7 @@ TclOORenderCallChain( * method (or "object" if it is declared on the instance). */ - objv = TclStackAlloc(interp, callPtr->numChain * sizeof(Tcl_Obj *)); + objv = ckalloc(callPtr->numChain * sizeof(Tcl_Obj *)); for (i=0 ; i<callPtr->numChain ; i++) { struct MInvoke *miPtr = &callPtr->chain[i]; @@ -1483,7 +1483,7 @@ TclOORenderCallChain( */ resultObj = Tcl_NewListObj(callPtr->numChain, objv); - TclStackFree(interp, objv); + ckfree(objv); return resultObj; } diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index db0db6d..d7afcd0 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -545,7 +545,7 @@ TclOOUnknownDefinition( * Got one match, and only one match! */ - Tcl_Obj **newObjv = TclStackAlloc(interp, sizeof(Tcl_Obj*)*(objc-1)); + Tcl_Obj **newObjv = ckalloc(sizeof(Tcl_Obj*)*(objc-1)); int result; newObjv[0] = Tcl_NewStringObj(matchedStr, -1); @@ -555,7 +555,7 @@ TclOOUnknownDefinition( } result = Tcl_EvalObjv(interp, objc-1, newObjv, 0); Tcl_DecrRefCount(newObjv[0]); - TclStackFree(interp, newObjv); + ckfree(newObjv); return result; } @@ -658,7 +658,7 @@ InitDefineContext( /* framePtrPtr is needed to satisfy GCC 3.3's strict aliasing rules */ - result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, + result = TclPushStackFrame(interp, framePtrPtr, namespacePtr, FRAME_IS_OO_DEFINE); if (result != TCL_OK) { return TCL_ERROR; @@ -1650,7 +1650,7 @@ TclOODefineMixinObjCmd( Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } - mixins = TclStackAlloc(interp, sizeof(Class *) * (objc-1)); + mixins = ckalloc(sizeof(Class *) * (objc-1)); for (i=1 ; i<objc ; i++) { Class *clsPtr = GetClassInOuterContext(interp, objv[i], @@ -1674,11 +1674,11 @@ TclOODefineMixinObjCmd( TclOOClassSetMixins(interp, oPtr->classPtr, objc-1, mixins); } - TclStackFree(interp, mixins); + ckfree(mixins); return TCL_OK; freeAndError: - TclStackFree(interp, mixins); + ckfree(mixins); return TCL_ERROR; } @@ -2087,7 +2087,7 @@ ClassMixinSet( return TCL_ERROR; } - mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc); + mixins = ckalloc(sizeof(Class *) * mixinc); for (i=0 ; i<mixinc ; i++) { mixins[i] = GetClassInOuterContext(interp, mixinv[i], @@ -2104,11 +2104,11 @@ ClassMixinSet( } TclOOClassSetMixins(interp, oPtr->classPtr, mixinc, mixins); - TclStackFree(interp, mixins); + ckfree(mixins); return TCL_OK; freeAndError: - TclStackFree(interp, mixins); + ckfree(mixins); return TCL_ERROR; } @@ -2528,19 +2528,19 @@ ObjMixinSet( return TCL_ERROR; } - mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc); + mixins = ckalloc(sizeof(Class *) * mixinc); for (i=0 ; i<mixinc ; i++) { mixins[i] = GetClassInOuterContext(interp, mixinv[i], "may only mix in classes"); if (mixins[i] == NULL) { - TclStackFree(interp, mixins); + ckfree(mixins); return TCL_ERROR; } } TclOOObjectSetMixins(oPtr, mixinc, mixins); - TclStackFree(interp, mixins); + ckfree(mixins); return TCL_OK; } diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index 3217f98..25ca79b 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -48,19 +48,19 @@ static Tcl_ObjCmdProc InfoClassVariablesCmd; */ static const EnsembleImplMap infoObjectCmds[] = { - {"call", InfoObjectCallCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"class", InfoObjectClassCmd, TclCompileInfoObjectClassCmd, NULL, NULL, 0}, - {"definition", InfoObjectDefnCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"filters", InfoObjectFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"forward", InfoObjectForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"isa", InfoObjectIsACmd, TclCompileInfoObjectIsACmd, NULL, NULL, 0}, - {"methods", InfoObjectMethodsCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, - {"methodtype", InfoObjectMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"mixins", InfoObjectMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"namespace", InfoObjectNsCmd, TclCompileInfoObjectNamespaceCmd, NULL, NULL, 0}, - {"variables", InfoObjectVariablesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"vars", InfoObjectVarsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {NULL, NULL, NULL, NULL, NULL, 0} + {"call", InfoObjectCallCmd, NULL, NULL, 0}, + {"class", InfoObjectClassCmd, NULL, NULL, 0}, + {"definition", InfoObjectDefnCmd, NULL, NULL, 0}, + {"filters", InfoObjectFiltersCmd, NULL, NULL, 0}, + {"forward", InfoObjectForwardCmd, NULL, NULL, 0}, + {"isa", InfoObjectIsACmd, NULL, NULL, 0}, + {"methods", InfoObjectMethodsCmd, NULL, NULL, 0}, + {"methodtype", InfoObjectMethodTypeCmd, NULL, NULL, 0}, + {"mixins", InfoObjectMixinsCmd, NULL, NULL, 0}, + {"namespace", InfoObjectNsCmd, NULL, NULL, 0}, + {"variables", InfoObjectVariablesCmd, NULL, NULL, 0}, + {"vars", InfoObjectVarsCmd, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, 0} }; /* @@ -68,20 +68,20 @@ static const EnsembleImplMap infoObjectCmds[] = { */ static const EnsembleImplMap infoClassCmds[] = { - {"call", InfoClassCallCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"constructor", InfoClassConstrCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"definition", InfoClassDefnCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"destructor", InfoClassDestrCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"filters", InfoClassFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"forward", InfoClassForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"instances", InfoClassInstancesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {"methods", InfoClassMethodsCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, - {"methodtype", InfoClassMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"mixins", InfoClassMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"subclasses", InfoClassSubsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {"superclasses", InfoClassSupersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"variables", InfoClassVariablesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {NULL, NULL, NULL, NULL, NULL, 0} + {"call", InfoClassCallCmd, NULL, NULL, 0}, + {"constructor", InfoClassConstrCmd, NULL, NULL, 0}, + {"definition", InfoClassDefnCmd, NULL, NULL, 0}, + {"destructor", InfoClassDestrCmd, NULL, NULL, 0}, + {"filters", InfoClassFiltersCmd, NULL, NULL, 0}, + {"forward", InfoClassForwardCmd, NULL, NULL, 0}, + {"instances", InfoClassInstancesCmd, NULL, NULL, 0}, + {"methods", InfoClassMethodsCmd, NULL, NULL, 0}, + {"methodtype", InfoClassMethodTypeCmd, NULL, NULL, 0}, + {"mixins", InfoClassMixinsCmd, NULL, NULL, 0}, + {"subclasses", InfoClassSubsCmd, NULL, NULL, 0}, + {"superclasses", InfoClassSupersCmd, NULL, NULL, 0}, + {"variables", InfoClassVariablesCmd, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, 0} }; /* diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 14a0e97..cd21512 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -66,7 +66,7 @@ typedef struct Method { */ typedef int (TclOO_PreCallProc)(ClientData clientData, Tcl_Interp *interp, - Tcl_ObjectContext context, Tcl_CallFrame *framePtr, int *isFinished); + Tcl_ObjectContext context, CallFrame *framePtr, int *isFinished); typedef int (TclOO_PostCallProc)(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, Tcl_Namespace *namespacePtr, int result); typedef void (TclOO_PmCDDeleteProc)(ClientData clientData); diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 628090f..5cc78c7 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -14,7 +14,7 @@ #endif #include "tclInt.h" #include "tclOOInt.h" -#include "tclCompile.h" +#include "tclCompileInt.h" /* * Structure used to contain all the information needed about a call frame @@ -543,7 +543,7 @@ InvokeProcedureMethod( * Allocate the special frame data. */ - fdPtr = TclStackAlloc(interp, sizeof(PMFrameData)); + fdPtr = ckalloc(sizeof(PMFrameData)); /* * Create a call frame for this method. @@ -552,7 +552,7 @@ InvokeProcedureMethod( result = PushMethodCallFrame(interp, (CallContext *) context, pmPtr, objc, objv, fdPtr); if (result != TCL_OK) { - TclStackFree(interp, fdPtr); + ckfree(fdPtr); return result; } pmPtr->refCount++; @@ -566,7 +566,7 @@ InvokeProcedureMethod( int isFinished; result = pmPtr->preCallProc(pmPtr->clientData, interp, context, - (Tcl_CallFrame *) fdPtr->framePtr, &isFinished); + (CallFrame *) fdPtr->framePtr, &isFinished); if (isFinished || result != TCL_OK) { /* * Restore the old cmdPtr so that a subsequent use of [info frame] @@ -575,12 +575,12 @@ InvokeProcedureMethod( pmPtr->procPtr->cmdPtr = fdPtr->oldCmdPtr; - Tcl_PopCallFrame(interp); - TclStackFree(interp, fdPtr->framePtr); + TclPopStackFrame(interp); + //ckfree(fdPtr->framePtr); if (--pmPtr->refCount < 1) { DeleteProcedureMethodRecord(pmPtr); } - TclStackFree(interp, fdPtr); + ckfree(fdPtr); return result; } } @@ -631,7 +631,7 @@ FinalizePMCall( if (--pmPtr->refCount < 1) { DeleteProcedureMethodRecord(pmPtr); } - TclStackFree(interp, fdPtr); + ckfree(fdPtr); return result; } @@ -730,7 +730,7 @@ PushMethodCallFrame( * This operation may fail. */ - result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, + result = TclPushStackFrame(interp, (CallFrame **) framePtrPtr, (Tcl_Namespace *) nsPtr, FRAME_IS_PROC|FRAME_IS_METHOD); if (result != TCL_OK) { goto failureReturn; @@ -1243,7 +1243,7 @@ FinalizeForwardCall( { Tcl_Obj **argObjs = data[0]; - TclStackFree(interp, argObjs); + ckfree(argObjs); return result; } @@ -1372,7 +1372,7 @@ InitEnsembleRewrite( Tcl_Obj **argObjs; unsigned len = rewriteLength + objc - toRewrite; - argObjs = TclStackAlloc(interp, sizeof(Tcl_Obj *) * len); + argObjs = ckalloc(sizeof(Tcl_Obj *) * len); memcpy(argObjs, rewriteObjs, rewriteLength * sizeof(Tcl_Obj *)); memcpy(argObjs + rewriteLength, objv + toRewrite, sizeof(Tcl_Obj *) * (objc - toRewrite)); diff --git a/generic/tclOOStubLib.c b/generic/tclOOStubLib.c index 921aced..55f2378 100644 --- a/generic/tclOOStubLib.c +++ b/generic/tclOOStubLib.c @@ -2,6 +2,19 @@ * ORIGINAL SOURCE: tk/generic/tkStubLib.c, version 1.9 2004/03/17 */ +/* + * We need to ensure that we use the tcl stub macros so that this file + * contains no references to any of the tcl stub functions. + */ + +#undef USE_TCL_STUBS +#define USE_TCL_STUBS + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif + +#define USE_TCLOO_STUBS 1 #include "tclOOInt.h" MODULE_SCOPE const TclOOStubs *tclOOStubsPtr; @@ -22,48 +35,51 @@ const TclOOIntStubs *tclOOIntStubsPtr = NULL; * to indicate that an error occurred. * * Side effects: - * Sets the stub table pointers. + * Sets the stub table pointer. * *---------------------------------------------------------------------- */ MODULE_SCOPE const char * TclOOInitializeStubs( - Tcl_Interp *interp, - const char *version) + Tcl_Interp *interp, const char *version) { int exact = 0; const char *packageName = "TclOO"; const char *errMsg = NULL; - TclOOStubs *stubsPtr = NULL; - const char *actualVersion = tclStubsPtr->tcl_PkgRequireEx(interp, - packageName, version, exact, &stubsPtr); + ClientData clientData = NULL; + const char *actualVersion = + Tcl_PkgRequireEx(interp, packageName,version, exact, &clientData); - if (actualVersion == NULL) { + if (clientData == NULL) { + Tcl_ResetResult(interp); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error loading %s package; package not present or incomplete", + packageName)); return NULL; - } - if (stubsPtr == NULL) { - errMsg = "missing stub table pointer"; } else { - tclOOStubsPtr = stubsPtr; - if (stubsPtr->hooks) { - tclOOIntStubsPtr = stubsPtr->hooks->tclOOIntStubs; - } else { - tclOOIntStubsPtr = NULL; + const TclOOStubs * const stubsPtr = clientData; + const TclOOIntStubs * const intStubsPtr = stubsPtr->hooks ? + stubsPtr->hooks->tclOOIntStubs : NULL; + + if (!actualVersion) { + return NULL; } + + if (!stubsPtr || !intStubsPtr) { + errMsg = "missing stub table pointer"; + goto error; + } + + tclOOStubsPtr = stubsPtr; + tclOOIntStubsPtr = intStubsPtr; return actualVersion; + + error: + Tcl_ResetResult(interp); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("Error loading %s package" + " (requested version '%s', loaded version '%s'): %s", + packageName, version, actualVersion, errMsg)); + return NULL; } - tclStubsPtr->tcl_ResetResult(interp); - tclStubsPtr->tcl_AppendResult(interp, "Error loading ", packageName, - " (requested version ", version, ", actual version ", - actualVersion, "): ", errMsg, NULL); - return NULL; } - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ diff --git a/generic/tclObj.c b/generic/tclObj.c index 56593e6..34f1387 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -26,20 +26,8 @@ static Tcl_HashTable typeTable; static int typeTableInitialized = 0; /* 0 means not yet initialized. */ TCL_DECLARE_MUTEX(tableMutex) -/* - * Head of the list of free Tcl_Obj structs we maintain. - */ - -Tcl_Obj *tclFreeObjList = NULL; - -/* - * The object allocator is single threaded. This mutex is referenced by the - * TclNewObj macro, however, so must be visible. - */ - -#ifdef TCL_THREADS -MODULE_SCOPE Tcl_Mutex tclObjMutex; -Tcl_Mutex tclObjMutex; +#if (defined(TCL_THREADS) && TCL_MEM_DEBUG) +static Tcl_Mutex tclObjMutex; #endif /* @@ -81,9 +69,11 @@ typedef struct ThreadSpecificData { Tcl_HashTable *objThreadMap;/* Thread local table that is used to check * that a Tcl_Obj was not allocated by some * other thread. */ + } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; + #endif /* TCL_MEM_DEBUG && TCL_THREADS */ /* @@ -400,19 +390,6 @@ TclInitObjSubsystem(void) Tcl_RegisterObjType(&tclWideIntType); #endif -#ifdef TCL_COMPILE_STATS - Tcl_MutexLock(&tclObjMutex); - tclObjsAlloced = 0; - tclObjsFreed = 0; - { - int i; - - for (i=0 ; i<TCL_MAX_SHARED_OBJ_STATS ; i++) { - tclObjsShared[i] = 0; - } - } - Tcl_MutexUnlock(&tclObjMutex); -#endif } /* @@ -484,15 +461,6 @@ TclFinalizeObjects(void) typeTableInitialized = 0; } Tcl_MutexUnlock(&tableMutex); - - /* - * All we do here is reset the head pointer of the linked list of free - * Tcl_Obj's to NULL; the memory finalization will take care of releasing - * memory for us. - */ - Tcl_MutexLock(&tclObjMutex); - tclFreeObjList = NULL; - Tcl_MutexUnlock(&tclObjMutex); } /* @@ -892,59 +860,6 @@ Tcl_DbNewObj( /* *---------------------------------------------------------------------- * - * TclAllocateFreeObjects -- - * - * Function to allocate a number of free Tcl_Objs. This is done using a - * single ckalloc to reduce the overhead for Tcl_Obj allocation. - * - * Assumes mutex is held. - * - * Results: - * None. - * - * Side effects: - * tclFreeObjList, the head of the list of free Tcl_Objs, is set to the - * first of a number of free Tcl_Obj's linked together by their - * internalRep.otherValuePtrs. - * - *---------------------------------------------------------------------- - */ - -#define OBJS_TO_ALLOC_EACH_TIME 100 - -void -TclAllocateFreeObjects(void) -{ - size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * sizeof(Tcl_Obj)); - char *basePtr; - register Tcl_Obj *prevPtr, *objPtr; - register int i; - - /* - * This has been noted by Purify to be a potential leak. The problem is - * that Tcl, when not TCL_MEM_DEBUG compiled, keeps around all allocated - * Tcl_Obj's, pointed to by tclFreeObjList, when freed instead of actually - * freeing the memory. TclFinalizeObjects() does not ckfree() this memory, - * but leaves it to Tcl's memory subsystem finalization to release it. - * Purify apparently can't figure that out, and fires a false alarm. - */ - - basePtr = ckalloc(bytesToAlloc); - - prevPtr = NULL; - objPtr = (Tcl_Obj *) basePtr; - for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) { - objPtr->internalRep.otherValuePtr = prevPtr; - prevPtr = objPtr; - objPtr++; - } - tclFreeObjList = prevPtr; -} -#undef OBJS_TO_ALLOC_EACH_TIME - -/* - *---------------------------------------------------------------------- - * * TclFreeObj -- * * This function frees the memory associated with the argument object. @@ -990,7 +905,6 @@ TclFreeObj( */ TclInvalidateStringRep(objPtr); - objPtr->length = -1; if (ObjDeletePending(context)) { PushObjToDelete(context, objPtr); @@ -1036,7 +950,6 @@ TclFreeObj( */ TclInvalidateStringRep(objPtr); - objPtr->length = -1; if (!objPtr->typePtr || !objPtr->typePtr->freeIntRepProc) { /* @@ -1097,31 +1010,6 @@ TclFreeObj( /* *---------------------------------------------------------------------- * - * TclObjBeingDeleted -- - * - * This function returns 1 when the Tcl_Obj is being deleted. It is - * provided for the rare cases where the reason for the loss of an - * internal rep might be relevant. [FR 1512138] - * - * Results: - * 1 if being deleted, 0 otherwise. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclObjBeingDeleted( - Tcl_Obj *objPtr) -{ - return (objPtr->length == -1); -} - -/* - *---------------------------------------------------------------------- - * * Tcl_DuplicateObj -- * * Create and return a new object that is a duplicate of the argument @@ -3468,18 +3356,6 @@ Tcl_DbIsShared( # endif /* TCL_THREADS */ #endif /* TCL_MEM_DEBUG */ -#ifdef TCL_COMPILE_STATS - Tcl_MutexLock(&tclObjMutex); - if ((objPtr)->refCount <= 1) { - tclObjsShared[1]++; - } else if ((objPtr)->refCount < TCL_MAX_SHARED_OBJ_STATS) { - tclObjsShared[(objPtr)->refCount]++; - } else { - tclObjsShared[0]++; - } - Tcl_MutexUnlock(&tclObjMutex); -#endif /* TCL_COMPILE_STATS */ - return ((objPtr)->refCount > 1); } diff --git a/generic/tclObjAlloc.c b/generic/tclObjAlloc.c new file mode 100644 index 0000000..08900e8 --- /dev/null +++ b/generic/tclObjAlloc.c @@ -0,0 +1,442 @@ +/* + * tclAlloc.c -- + * + * This is the generic part of the Tcl allocator. It handles the + * freeObjLists and defines which main allocator will be used. + * + * Copyright (c) 2013 by Miguel Sofer. All rights reserved. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#ifndef PURIFY + +#include "tclInt.h" + +static int purify = 0; + +/* + * Parameters for the per-thread Tcl_Obj cache: + * - if >NOBJHIGH free objects, move some to the shared cache + * - if no objects are available, create NOBJALLOC of them + */ + +#define NOBJHIGH 1200 +#define NOBJALLOC ((NOBJHIGH*2)/3) + + +/* + * The Tcl_Obj per-thread cache. + */ + +typedef struct Cache { + Tcl_Obj *firstObjPtr; /* List of free objects for thread */ + int numObjects; /* Number of objects for thread */ + void *allocCachePtr; +} Cache; + +static Cache sharedCache; +#define sharedPtr (&sharedCache) + +#if defined(TCL_THREADS) +static Tcl_Mutex *objLockPtr; + +static Cache * GetCache(void); +static void MoveObjs(Cache *fromPtr, Cache *toPtr, int numMove); + +#if defined(HAVE_FAST_TSD) +static __thread Cache *tcachePtr; + +# define GETCACHE(cachePtr) \ + do { \ + if (!tcachePtr) { \ + tcachePtr = GetCache(); \ + } \ + (cachePtr) = tcachePtr; \ + } while (0) + +#else /* THREADS, not HAVE_FAST_TSD */ +# define GETCACHE(cachePtr) \ + do { \ + (cachePtr) = TclpGetAllocCache(); \ + if ((cachePtr) == NULL) { \ + (cachePtr) = GetCache(); \ + } \ + } while (0) +#endif /* FAST TSD */ + +#else /* NOT THREADS */ +#define GETCACHE(cachePtr) \ + (cachePtr) = (&sharedCache) +#endif /* THREADS */ + + +/* + *---------------------------------------------------------------------- + * + * GetCache --- + * + * Gets per-thread memory cache, allocating it if necessary. + * + * Results: + * Pointer to cache. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#if defined(TCL_THREADS) +static Cache * +GetCache(void) +{ + Cache *cachePtr; + + /* + * Get this thread's cache, allocating if necessary. + */ + + cachePtr = TclpGetAllocCache(); + if (cachePtr == NULL) { + cachePtr = calloc(1, sizeof(Cache)); + if (cachePtr == NULL) { + Tcl_Panic("alloc: could not allocate new cache"); + } + cachePtr->allocCachePtr= NULL; + TclpSetAllocCache(cachePtr); + } + return cachePtr; +} +#endif + +/* + * TclSetSharedAllocCache, TclSetAllocCache, TclGetAllocCache + * + * These are utility functions for the loadable allocator. + */ + +void +TclSetSharedAllocCache( + void *allocCachePtr) +{ + sharedPtr->allocCachePtr = allocCachePtr; +} + +void +TclSetAllocCache( + void *allocCachePtr) +{ + Cache *cachePtr; + + GETCACHE(cachePtr); + cachePtr->allocCachePtr = allocCachePtr; +} + +void * +TclGetAllocCache(void) +{ + Cache *cachePtr; + + GETCACHE(cachePtr); + return cachePtr->allocCachePtr; +} + + +/* + *------------------------------------------------------------------------- + * + * TclInitAlloc -- + * + * Initialize the memory system. + * + * Results: + * None. + * + * Side effects: + * Initialize the mutex used to serialize obj allocations. + * Call the allocator-specific initialization. + * + *------------------------------------------------------------------------- + */ + +void +TclInitAlloc(void) +{ + /* + * Set the params for the correct allocator + */ + +#if defined(TCL_THREADS) + Tcl_Mutex *initLockPtr; + + initLockPtr = Tcl_GetAllocMutex(); + Tcl_MutexLock(initLockPtr); + objLockPtr = TclpNewAllocMutex(); + Tcl_MutexUnlock(initLockPtr); +#endif + + /* Make it possible to switch to purify mode without recompiling */ + purify = (getenv("TCL_PURIFY") != NULL); +} + +/* + *---------------------------------------------------------------------- + * + * TclFinalizeAlloc -- + * + * This procedure is used to destroy all private resources used in this + * file. + * + * Results: + * None. + * + * Side effects: + * Call the allocator-specific finalization. + * + *---------------------------------------------------------------------- + */ + +void +TclFinalizeAlloc(void) +{ +#if defined(TCL_THREADS) + + TclpFreeAllocMutex(objLockPtr); + objLockPtr = NULL; + + TclpFreeAllocCache(NULL); +#endif +} + +/* + *---------------------------------------------------------------------- + * + * TclFreeAllocCache -- + * + * Flush and delete a cache, removing from list of caches. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#if defined(TCL_THREADS) +void +TclFreeAllocCache( + void *arg) +{ + Cache *cachePtr = arg; + + /* + * Flush objs. + */ + + if (cachePtr->numObjects > 0) { + Tcl_MutexLock(objLockPtr); + MoveObjs(cachePtr, sharedPtr, cachePtr->numObjects); + Tcl_MutexUnlock(objLockPtr); + } +} +#endif + +/* + *---------------------------------------------------------------------- + * + * TclSmallAlloc -- + * + * Allocate a Tcl_Obj sized block from the per-thread cache. + * + * Results: + * Pointer to uninitialized memory. + * + * Side effects: + * May move blocks from shared cached or allocate new blocks if + * list is empty. + * + *---------------------------------------------------------------------- + */ + +void * +TclSmallAlloc(void) +{ + register Cache *cachePtr; + register Tcl_Obj *objPtr; + int numMove; + Tcl_Obj *newObjsPtr; + + GETCACHE(cachePtr); + + /* + * Pop the first object. + */ + + if(cachePtr->firstObjPtr) { + haveObj: + objPtr = cachePtr->firstObjPtr; + cachePtr->firstObjPtr = objPtr->internalRep.otherValuePtr; + cachePtr->numObjects--; + return objPtr; + } + + /* + * Do it AFTER looking at the queue, so that it doesn't slow down + * non-purify small allocs. + */ + + if (purify) { + Tcl_Obj *objPtr = (Tcl_Obj *) TclpAlloc(sizeof(Tcl_Obj)); + if (objPtr == NULL) { + Tcl_Panic("alloc: could not allocate a new object"); + } + return objPtr; + } + + /* + * Get this thread's obj list structure and move or allocate new objs if + * necessary. + */ + +#if defined(TCL_THREADS) + Tcl_MutexLock(objLockPtr); + numMove = sharedPtr->numObjects; + if (numMove > 0) { + if (numMove > NOBJALLOC) { + numMove = NOBJALLOC; + } + MoveObjs(sharedPtr, cachePtr, numMove); + } + Tcl_MutexUnlock(objLockPtr); + if (cachePtr->firstObjPtr) { + goto haveObj; + } +#endif + cachePtr->numObjects = numMove = NOBJALLOC; + newObjsPtr = malloc(sizeof(Tcl_Obj) * numMove); + if (newObjsPtr == NULL) { + Tcl_Panic("alloc: could not allocate %d new objects", numMove); + } + while (--numMove >= 0) { + objPtr = &newObjsPtr[numMove]; + objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr; + cachePtr->firstObjPtr = objPtr; + } + goto haveObj; +} + + +/* + *---------------------------------------------------------------------- + * + * TclSmallFree -- + * + * Return a free Tcl_Obj-sized block to the per-thread cache. + * + * Results: + * None. + * + * Side effects: + * May move free blocks to shared list upon hitting high water mark. + * + *---------------------------------------------------------------------- + */ + +void +TclSmallFree( + void *ptr) +{ + Cache *cachePtr; + Tcl_Obj *objPtr = ptr; + + if (purify) { + TclpFree((char *) ptr); + return; + } + + GETCACHE(cachePtr); + + /* + * Get this thread's list and push on the free Tcl_Obj. + */ + + objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr; + cachePtr->firstObjPtr = objPtr; + cachePtr->numObjects++; + +#if defined(TCL_THREADS) + /* + * If the number of free objects has exceeded the high water mark, move + * some blocks to the shared list. + */ + + if (cachePtr->numObjects > NOBJHIGH) { + Tcl_MutexLock(objLockPtr); + MoveObjs(cachePtr, sharedPtr, NOBJALLOC); + Tcl_MutexUnlock(objLockPtr); + } +#endif +} + +/* + *---------------------------------------------------------------------- + * + * MoveObjs -- + * + * Move Tcl_Obj's between caches. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#if defined(TCL_THREADS) +static void +MoveObjs( + Cache *fromPtr, + Cache *toPtr, + int numMove) +{ + register Tcl_Obj *objPtr = fromPtr->firstObjPtr; + Tcl_Obj *fromFirstObjPtr = objPtr; + + toPtr->numObjects += numMove; + fromPtr->numObjects -= numMove; + + /* + * Find the last object to be moved; set the next one (the first one not + * to be moved) as the first object in the 'from' cache. + */ + + while (--numMove) { + objPtr = objPtr->internalRep.otherValuePtr; + } + fromPtr->firstObjPtr = objPtr->internalRep.otherValuePtr; + + /* + * Move all objects as a block - they are already linked to each other, we + * just have to update the first and last. + */ + + objPtr->internalRep.otherValuePtr = toPtr->firstObjPtr; + toPtr->firstObjPtr = fromFirstObjPtr; +} +#endif + +#endif /* PURIFY */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclParse.c b/generic/tclParse.c index 048cfdd..a9bc2ad 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -1149,14 +1149,14 @@ ParseTokens( src++; numBytes--; - nestedPtr = TclStackAlloc(parsePtr->interp, sizeof(Tcl_Parse)); + nestedPtr = ckalloc(sizeof(Tcl_Parse)); while (1) { if (Tcl_ParseCommand(parsePtr->interp, src, numBytes, 1, nestedPtr) != TCL_OK) { parsePtr->errorType = nestedPtr->errorType; parsePtr->term = nestedPtr->term; parsePtr->incomplete = nestedPtr->incomplete; - TclStackFree(parsePtr->interp, nestedPtr); + ckfree(nestedPtr); return TCL_ERROR; } src = nestedPtr->commandStart + nestedPtr->commandSize; @@ -1182,11 +1182,11 @@ ParseTokens( parsePtr->errorType = TCL_PARSE_MISSING_BRACKET; parsePtr->term = tokenPtr->start; parsePtr->incomplete = 1; - TclStackFree(parsePtr->interp, nestedPtr); + ckfree(nestedPtr); return TCL_ERROR; } } - TclStackFree(parsePtr->interp, nestedPtr); + ckfree(nestedPtr); tokenPtr->type = TCL_TOKEN_COMMAND; tokenPtr->size = src - tokenPtr->start; parsePtr->numTokens++; @@ -1546,10 +1546,10 @@ Tcl_ParseVar( { register Tcl_Obj *objPtr; int code; - Tcl_Parse *parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse)); + Tcl_Parse *parsePtr = ckalloc(sizeof(Tcl_Parse)); if (Tcl_ParseVarName(interp, start, -1, parsePtr, 0) != TCL_OK) { - TclStackFree(interp, parsePtr); + ckfree(parsePtr); return NULL; } @@ -1561,13 +1561,13 @@ Tcl_ParseVar( * There isn't a variable name after all: the $ is just a $. */ - TclStackFree(interp, parsePtr); + ckfree(parsePtr); return "$"; } code = TclSubstTokens(interp, parsePtr->tokenPtr, parsePtr->numTokens, NULL); - TclStackFree(interp, parsePtr); + ckfree(parsePtr); if (code != TCL_OK) { return NULL; } @@ -2030,7 +2030,7 @@ TclSubstParse( Tcl_Token *tokenPtr; const char *lastTerm = parsePtr->term; Tcl_Parse *nestedPtr = - TclStackAlloc(interp, sizeof(Tcl_Parse)); + ckalloc(sizeof(Tcl_Parse)); while (TCL_OK == Tcl_ParseCommand(NULL, p, length, 0, nestedPtr)) { @@ -2048,7 +2048,7 @@ TclSubstParse( } lastTerm = nestedPtr->term; } - TclStackFree(interp, nestedPtr); + ckfree(nestedPtr); if (lastTerm == parsePtr->term) { /* @@ -2082,6 +2082,254 @@ TclSubstParse( /* *---------------------------------------------------------------------- * + * Tcl_SubstObj -- + * + * This function performs the substitutions specified on the given string + * as described in the user documentation for the "subst" Tcl command. + * + * Results: + * A Tcl_Obj* containing the substituted string, or NULL to indicate that + * an error occurred. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +Tcl_SubstObj( + Tcl_Interp *interp, /* Interpreter in which substitution occurs */ + Tcl_Obj *objPtr, /* The value to be substituted. */ + int flags) /* What substitutions to do. */ +{ + int length, tokensLeft, code; + Tcl_Token *endTokenPtr; + Tcl_Obj *result, *errMsg = NULL; + const char *p = TclGetStringFromObj(objPtr, &length); + Tcl_Parse *parsePtr = (Tcl_Parse *) ckalloc(sizeof(Tcl_Parse)); + + TclParseInit(interp, p, length, parsePtr); + + /* + * First parse the string rep of objPtr, as if it were enclosed as a + * "-quoted word in a normal Tcl command. Honor flags that selectively + * inhibit types of substitution. + */ + + if (TCL_OK != ParseTokens(p, length, /* mask */ 0, flags, parsePtr)) { + /* + * There was a parse error. Save the error message for possible + * reporting later. + */ + + errMsg = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(errMsg); + + /* + * We need to re-parse to get the portion of the string we can [subst] + * before the parse error. Sadly, all the Tcl_Token's created by the + * first parse attempt are gone, freed according to the public spec + * for the Tcl_Parse* routines. The only clue we have is parse.term, + * which points to either the unmatched opener, or to characters that + * follow a close brace or close quote. + * + * Call ParseTokens again, working on the string up to parse.term. + * Keep repeating until we get a good parse on a prefix. + */ + + do { + parsePtr->numTokens = 0; + parsePtr->tokensAvailable = NUM_STATIC_TOKENS; + parsePtr->end = parsePtr->term; + parsePtr->incomplete = 0; + parsePtr->errorType = TCL_PARSE_SUCCESS; + } while (TCL_OK != + ParseTokens(p, parsePtr->end - p, 0, flags, parsePtr)); + + /* + * The good parse will have to be followed by {, (, or [. + */ + + switch (*(parsePtr->term)) { + case '{': + /* + * Parse error was a missing } in a ${varname} variable + * substitution at the toplevel. We will subst everything up to + * that broken variable substitution before reporting the parse + * error. Substituting the leftover '$' will have no side-effects, + * so the current token stream is fine. + */ + break; + + case '(': + /* + * Parse error was during the parsing of the index part of an + * array variable substitution at the toplevel. + */ + + if (*(parsePtr->term - 1) == '$') { + /* + * Special case where removing the array index left us with + * just a dollar sign (array variable with name the empty + * string as its name), instead of with a scalar variable + * reference. + * + * As in the previous case, existing token stream is OK. + */ + } else { + /* + * The current parse includes a successful parse of a scalar + * variable substitution where there should have been an array + * variable substitution. We remove that mistaken part of the + * parse before moving on. A scalar variable substitution is + * two tokens. + */ + + Tcl_Token *varTokenPtr = + parsePtr->tokenPtr + parsePtr->numTokens - 2; + + if (varTokenPtr->type != TCL_TOKEN_VARIABLE) { + Tcl_Panic("Tcl_SubstObj: programming error"); + } + if (varTokenPtr[1].type != TCL_TOKEN_TEXT) { + Tcl_Panic("Tcl_SubstObj: programming error"); + } + parsePtr->numTokens -= 2; + } + break; + case '[': + /* + * Parse error occurred during parsing of a toplevel command + * substitution. + */ + + parsePtr->end = p + length; + p = parsePtr->term + 1; + length = parsePtr->end - p; + if (length == 0) { + /* + * No commands, just an unmatched [. As in previous cases, + * existing token stream is OK. + */ + } else { + /* + * We want to add the parsing of as many commands as we can + * within that substitution until we reach the actual parse + * error. We'll do additional parsing to determine what length + * to claim for the final TCL_TOKEN_COMMAND token. + */ + + Tcl_Token *tokenPtr; + const char *lastTerm = parsePtr->term; + Tcl_Parse *nestedPtr = (Tcl_Parse *) + ckalloc(sizeof(Tcl_Parse)); + + while (TCL_OK == + Tcl_ParseCommand(NULL, p, length, 0, nestedPtr)) { + Tcl_FreeParse(nestedPtr); + p = nestedPtr->term + (nestedPtr->term < nestedPtr->end); + length = nestedPtr->end - p; + if ((length == 0) && (nestedPtr->term == nestedPtr->end)) { + /* + * If we run out of string, blame the missing close + * bracket on the last command, and do not evaluate it + * during substitution. + */ + + break; + } + lastTerm = nestedPtr->term; + } + ckfree(nestedPtr); + + if (lastTerm == parsePtr->term) { + /* + * Parse error in first command. No commands to subst, add + * no more tokens. + */ + break; + } + + /* + * Create a command substitution token for whatever commands + * got parsed. + */ + + TclGrowParseTokenArray(parsePtr, 1); + tokenPtr = &(parsePtr->tokenPtr[parsePtr->numTokens]); + tokenPtr->start = parsePtr->term; + tokenPtr->numComponents = 0; + tokenPtr->type = TCL_TOKEN_COMMAND; + tokenPtr->size = lastTerm - tokenPtr->start + 1; + parsePtr->numTokens++; + } + break; + + default: + Tcl_Panic("bad parse in Tcl_SubstObj: %c", p[length]); + } + } + + /* + * Next, substitute the parsed tokens just as in normal Tcl evaluation. + */ + + endTokenPtr = parsePtr->tokenPtr + parsePtr->numTokens; + tokensLeft = parsePtr->numTokens; + code = TclSubstTokens(interp, endTokenPtr - tokensLeft, tokensLeft, + &tokensLeft); + if (code == TCL_OK) { + Tcl_FreeParse(parsePtr); + ckfree(parsePtr); + if (errMsg != NULL) { + Tcl_SetObjResult(interp, errMsg); + Tcl_DecrRefCount(errMsg); + return NULL; + } + return Tcl_GetObjResult(interp); + } + + result = Tcl_NewObj(); + while (1) { + switch (code) { + case TCL_ERROR: + Tcl_FreeParse(parsePtr); + ckfree(parsePtr); + Tcl_DecrRefCount(result); + if (errMsg != NULL) { + Tcl_DecrRefCount(errMsg); + } + return NULL; + case TCL_BREAK: + tokensLeft = 0; /* Halt substitution */ + default: + Tcl_AppendObjToObj(result, Tcl_GetObjResult(interp)); + } + + if (tokensLeft == 0) { + Tcl_FreeParse(parsePtr); + ckfree(parsePtr); + if (errMsg != NULL) { + if (code != TCL_BREAK) { + Tcl_DecrRefCount(result); + Tcl_SetObjResult(interp, errMsg); + Tcl_DecrRefCount(errMsg); + return NULL; + } + Tcl_DecrRefCount(errMsg); + } + return result; + } + + code = TclSubstTokens(interp, endTokenPtr - tokensLeft, tokensLeft, + &tokensLeft); + } +} + +/* + *---------------------------------------------------------------------- + * * TclSubstTokens -- * * Accepts an array of count Tcl_Token's, and creates a result value in diff --git a/generic/tclProc.c b/generic/tclProc.c index cecc1a8..c949086 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -14,7 +14,7 @@ */ #include "tclInt.h" -#include "tclCompile.h" +#include "tclCompileInt.h" #include "tclOOInt.h" /* @@ -130,7 +130,7 @@ Tcl_ProcObjCmd( register Interp *iPtr = (Interp *) interp; Proc *procPtr; const char *fullName; - const char *procName, *procArgs, *procBody; + const char *procName; Namespace *nsPtr, *altNsPtr, *cxtNsPtr; Tcl_Command cmd; Tcl_DString ds; @@ -199,8 +199,8 @@ Tcl_ProcObjCmd( } Tcl_DStringAppend(&ds, procName, -1); - cmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), TclObjInterpProc, - TclNRInterpProc, procPtr, TclProcDeleteProc); + cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds), TclObjInterpProc, + procPtr, TclProcDeleteProc); Tcl_DStringFree(&ds); /* @@ -211,61 +211,6 @@ Tcl_ProcObjCmd( */ procPtr->cmdPtr = (Command *) cmd; - - /* - * Optimize for no-op procs: if the body is not precompiled (like a TclPro - * procbody), and the argument list is just "args" and the body is empty, - * define a compileProc to compile a no-op. - * - * Notes: - * - cannot be done for any argument list without having different - * compiled/not-compiled behaviour in the "wrong argument #" case, or - * making this code much more complicated. In any case, it doesn't - * seem to make a lot of sense to verify the number of arguments we - * are about to ignore ... - * - could be enhanced to handle also non-empty bodies that contain only - * comments; however, parsing the body will slow down the compilation - * of all procs whose argument list is just _args_ - */ - - if (objv[3]->typePtr == &tclProcBodyType) { - goto done; - } - - procArgs = TclGetString(objv[2]); - - while (*procArgs == ' ') { - procArgs++; - } - - if ((procArgs[0] == 'a') && (strncmp(procArgs, "args", 4) == 0)) { - int numBytes; - - procArgs +=4; - while (*procArgs != '\0') { - if (*procArgs != ' ') { - goto done; - } - procArgs++; - } - - /* - * The argument list is just "args"; check the body - */ - - procBody = Tcl_GetStringFromObj(objv[3], &numBytes); - if (TclParseAllWhiteSpace(procBody, numBytes) < numBytes) { - goto done; - } - - /* - * The body is just spaces: link the compileProc - */ - - ((Command *) cmd)->compileProc = TclCompileNoOp; - } - - done: return TCL_OK; } @@ -849,16 +794,6 @@ Tcl_UplevelObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - return Tcl_NRCallObjProc(interp, TclNRUplevelObjCmd, dummy, objc, objv); -} - -int -TclNRUplevelObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ register Interp *iPtr = (Interp *) interp; int result; @@ -1003,8 +938,7 @@ ProcWrongNumArgs( */ numArgs = framePtr->procPtr->numArgs; - desiredObjs = TclStackAlloc(interp, - (int) sizeof(Tcl_Obj *) * (numArgs+1)); + desiredObjs = ckalloc((int) sizeof(Tcl_Obj *) * (numArgs+1)); if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) { desiredObjs[0] = Tcl_NewStringObj("lambdaExpr", -1); @@ -1044,7 +978,7 @@ ProcWrongNumArgs( for (i=0 ; i<=numArgs ; i++) { Tcl_DecrRefCount(desiredObjs[i]); } - TclStackFree(interp, desiredObjs); + ckfree(desiredObjs); return TCL_ERROR; } @@ -1358,7 +1292,7 @@ InitArgsAndLocals( * parameters. */ - varPtr = TclStackAlloc(interp, (int)(localCt * sizeof(Var))); + varPtr = ckalloc((int)(localCt * sizeof(Var))); framePtr->compiledLocals = varPtr; framePtr->numCompiledLocals = localCt; @@ -1520,7 +1454,6 @@ PushProcCallFrame( codePtr = procPtr->bodyPtr->internalRep.otherValuePtr; if (((Interp *) *codePtr->interpHandle != iPtr) - || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != nsPtr) || (codePtr->nsEpoch != nsPtr->resolverEpoch)) { goto doCompilation; @@ -1544,7 +1477,7 @@ PushProcCallFrame( */ framePtrPtr = &framePtr; - result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, + result = TclPushStackFrame(interp, (CallFrame **) framePtrPtr, (Tcl_Namespace *) nsPtr, (isLambda? (FRAME_IS_PROC|FRAME_IS_LAMBDA) : FRAME_IS_PROC)); if (result != TCL_OK) { @@ -1585,23 +1518,6 @@ TclObjInterpProc( * procedure. */ Tcl_Obj *const objv[]) /* Argument value objects. */ { - /* - * Not used much in the core; external interface for iTcl - */ - - return Tcl_NRCallObjProc(interp, TclNRInterpProc, clientData, objc, objv); -} - -int -TclNRInterpProc( - ClientData clientData, /* Record describing procedure to be - * interpreted. */ - register Tcl_Interp *interp,/* Interpreter in which procedure was - * invoked. */ - int objc, /* Count of number of arguments to this - * procedure. */ - Tcl_Obj *const objv[]) /* Argument value objects. */ -{ int result = PushProcCallFrame(clientData, interp, objc, objv, /*isLambda*/ 0); @@ -1649,62 +1565,12 @@ TclNRInterpProcCore( if (result != TCL_OK) { freePtr = iPtr->framePtr; Tcl_PopCallFrame(interp); /* Pop but do not free. */ - TclStackFree(interp, freePtr->compiledLocals); + ckfree(freePtr->compiledLocals); /* Free compiledLocals. */ - TclStackFree(interp, freePtr); /* Free CallFrame. */ + ckfree(freePtr); /* Free CallFrame. */ return TCL_ERROR; } -#if defined(TCL_COMPILE_DEBUG) - if (tclTraceExec >= 1) { - register CallFrame *framePtr = iPtr->varFramePtr; - register int i; - - if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) { - fprintf(stdout, "Calling lambda "); - } else { - fprintf(stdout, "Calling proc "); - } - for (i = 0; i < framePtr->objc; i++) { - TclPrintObject(stdout, framePtr->objv[i], 15); - fprintf(stdout, " "); - } - fprintf(stdout, "\n"); - fflush(stdout); - } -#endif /*TCL_COMPILE_DEBUG*/ - -#ifdef USE_DTRACE - if (TCL_DTRACE_PROC_ARGS_ENABLED()) { - int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; - const char *a[10]; - int i; - - for (i = 0 ; i < 10 ; i++) { - a[i] = (l < iPtr->varFramePtr->objc ? - TclGetString(iPtr->varFramePtr->objv[l]) : NULL); - l++; - } - TCL_DTRACE_PROC_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], - a[8], a[9]); - } - if (TCL_DTRACE_PROC_ENTRY_ENABLED()) { - int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; - - TCL_DTRACE_PROC_ENTRY(l < iPtr->varFramePtr->objc ? - TclGetString(iPtr->varFramePtr->objv[l]) : NULL, - iPtr->varFramePtr->objc - l - 1, - (Tcl_Obj **)(iPtr->varFramePtr->objv + l + 1)); - } - if (TCL_DTRACE_PROC_ENTRY_ENABLED()) { - int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; - - TCL_DTRACE_PROC_ENTRY(l < iPtr->varFramePtr->objc ? - TclGetString(iPtr->varFramePtr->objv[l]) : NULL, - iPtr->varFramePtr->objc - l - 1, - (Tcl_Obj **)(iPtr->varFramePtr->objv + l + 1)); - } -#endif /* USE_DTRACE */ /* * Invoke the commands in the procedure's body. @@ -1813,9 +1679,9 @@ InterpProcNR2( freePtr = iPtr->framePtr; Tcl_PopCallFrame(interp); /* Pop but do not free. */ - TclStackFree(interp, freePtr->compiledLocals); + ckfree(freePtr->compiledLocals); /* Free compiledLocals. */ - TclStackFree(interp, freePtr); /* Free CallFrame. */ + ckfree(freePtr); /* Free CallFrame. */ return result; } @@ -1852,7 +1718,7 @@ TclProcCompileProc( const char *procName) /* Name of this procedure. */ { Interp *iPtr = (Interp *) interp; - Tcl_CallFrame *framePtr; + CallFrame *framePtr; ByteCode *codePtr = bodyPtr->internalRep.otherValuePtr; /* @@ -1871,7 +1737,6 @@ TclProcCompileProc( if (bodyPtr->typePtr == &tclByteCodeType) { if (((Interp *) *codePtr->interpHandle == iPtr) - && (codePtr->compileEpoch == iPtr->compileEpoch) && (codePtr->nsPtr == nsPtr) && (codePtr->nsEpoch == nsPtr->resolverEpoch)) { return TCL_OK; @@ -1885,7 +1750,6 @@ TclProcCompileProc( "CROSSINTERPBYTECODE", NULL); return TCL_ERROR; } - codePtr->compileEpoch = iPtr->compileEpoch; codePtr->nsPtr = nsPtr; } else { TclFreeIntRep(bodyPtr); @@ -1893,24 +1757,6 @@ TclProcCompileProc( } if (bodyPtr->typePtr != &tclByteCodeType) { -#ifdef TCL_COMPILE_DEBUG - if (tclTraceCompile >= 1) { - /* - * Display a line summarizing the top level command we are about - * to compile. - */ - - Tcl_Obj *message; - - TclNewLiteralStringObj(message, "Compiling "); - Tcl_IncrRefCount(message); - Tcl_AppendStringsToObj(message, description, " \"", NULL); - Tcl_AppendLimitedToObj(message, procName, -1, 50, NULL); - fprintf(stdout, "%s\"\n", TclGetString(message)); - Tcl_DecrRefCount(message); - } -#endif - /* * Plug the current procPtr into the interpreter and coerce the code * body to byte codes. The interpreter needs to know which proc it's @@ -2420,16 +2266,6 @@ Tcl_ApplyObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - return Tcl_NRCallObjProc(interp, TclNRApplyObjCmd, dummy, objc, objv); -} - -int -TclNRApplyObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ Interp *iPtr = (Interp *) interp; Proc *procPtr = NULL; Tcl_Obj *lambdaPtr, *nsObjPtr; @@ -2496,7 +2332,7 @@ TclNRApplyObjCmd( return TCL_ERROR; } - extraPtr = TclStackAlloc(interp, sizeof(ApplyExtraData)); + extraPtr = ckalloc(sizeof(ApplyExtraData)); memset(&extraPtr->cmd, 0, sizeof(Command)); procPtr->cmdPtr = &extraPtr->cmd; extraPtr->cmd.nsPtr = (Namespace *) nsPtr; @@ -2531,7 +2367,7 @@ ApplyNR2( ((Interp *) interp)->ensembleRewrite.sourceObjs = NULL; } - TclStackFree(interp, extraPtr); + ckfree(extraPtr); return result; } @@ -2571,235 +2407,6 @@ MakeLambdaError( } /* - *---------------------------------------------------------------------- - * - * Tcl_DisassembleObjCmd -- - * - * Implementation of the "::tcl::unsupported::disassemble" command. This - * command is not documented, but will disassemble procedures, lambda - * terms and general scripts. Note that will compile terms if necessary - * in order to disassemble them. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_DisassembleObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - static const char *const types[] = { - "lambda", "method", "objmethod", "proc", "script", NULL - }; - enum Types { - DISAS_LAMBDA, DISAS_CLASS_METHOD, DISAS_OBJECT_METHOD, DISAS_PROC, - DISAS_SCRIPT - }; - int idx, result; - Tcl_Obj *codeObjPtr = NULL; - Proc *procPtr = NULL; - Tcl_HashEntry *hPtr; - Object *oPtr; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "type ..."); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[1], types, "type", 0, &idx)!=TCL_OK){ - return TCL_ERROR; - } - - switch ((enum Types) idx) { - case DISAS_LAMBDA: { - Command cmd; - Tcl_Obj *nsObjPtr; - Tcl_Namespace *nsPtr; - - /* - * Compile (if uncompiled) and disassemble a lambda term. - */ - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "lambdaTerm"); - return TCL_ERROR; - } - if (objv[2]->typePtr == &lambdaType) { - procPtr = objv[2]->internalRep.twoPtrValue.ptr1; - } - if (procPtr == NULL || procPtr->iPtr != (Interp *) interp) { - result = SetLambdaFromAny(interp, objv[2]); - if (result != TCL_OK) { - return result; - } - procPtr = objv[2]->internalRep.twoPtrValue.ptr1; - } - - memset(&cmd, 0, sizeof(Command)); - nsObjPtr = objv[2]->internalRep.twoPtrValue.ptr2; - result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); - if (result != TCL_OK) { - return result; - } - cmd.nsPtr = (Namespace *) nsPtr; - procPtr->cmdPtr = &cmd; - result = PushProcCallFrame(procPtr, interp, objc, objv, 1); - if (result != TCL_OK) { - return result; - } - TclPopStackFrame(interp); - codeObjPtr = procPtr->bodyPtr; - break; - } - case DISAS_PROC: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "procName"); - return TCL_ERROR; - } - - procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2])); - if (procPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" isn't a procedure", TclGetString(objv[2]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROC", - TclGetString(objv[2]), NULL); - return TCL_ERROR; - } - - /* - * Compile (if uncompiled) and disassemble a procedure. - */ - - result = PushProcCallFrame(procPtr, interp, 2, objv+1, 1); - if (result != TCL_OK) { - return result; - } - TclPopStackFrame(interp); - codeObjPtr = procPtr->bodyPtr; - break; - case DISAS_SCRIPT: - /* - * Compile and disassemble a script. - */ - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "script"); - return TCL_ERROR; - } - if (objv[2]->typePtr != &tclByteCodeType) { - if (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK){ - return TCL_ERROR; - } - } - codeObjPtr = objv[2]; - break; - - case DISAS_CLASS_METHOD: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "className methodName"); - return TCL_ERROR; - } - - /* - * Look up the body of a class method. - */ - - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); - if (oPtr == NULL) { - return TCL_ERROR; - } - if (oPtr->classPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" is not a class", TclGetString(objv[2]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", - TclGetString(objv[2]), NULL); - return TCL_ERROR; - } - hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, - (char *) objv[3]); - goto methodBody; - case DISAS_OBJECT_METHOD: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "objectName methodName"); - return TCL_ERROR; - } - - /* - * Look up the body of an instance method. - */ - - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); - if (oPtr == NULL) { - return TCL_ERROR; - } - if (oPtr->methodsPtr == NULL) { - goto unknownMethod; - } - hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[3]); - - /* - * Compile (if necessary) and disassemble a method body. - */ - - methodBody: - if (hPtr == NULL) { - unknownMethod: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unknown method \"%s\"", TclGetString(objv[3]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(objv[3]), NULL); - return TCL_ERROR; - } - procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr)); - if (procPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "body not available for this kind of method", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", - "METHODTYPE", NULL); - return TCL_ERROR; - } - if (procPtr->bodyPtr->typePtr != &tclByteCodeType) { - Command cmd; - - /* - * Yes, this is ugly, but we need to pass the namespace in to the - * compiler in two places. - */ - - cmd.nsPtr = (Namespace *) oPtr->namespacePtr; - procPtr->cmdPtr = &cmd; - result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, - (Namespace *) oPtr->namespacePtr, "body of method", - TclGetString(objv[3])); - procPtr->cmdPtr = NULL; - if (result != TCL_OK) { - return result; - } - } - codeObjPtr = procPtr->bodyPtr; - break; - default: - CLANG_ASSERT(0); - } - - /* - * Do the actual disassembly. - */ - - if (((ByteCode *) codeObjPtr->internalRep.otherValuePtr)->flags - & TCL_BYTECODE_PRECOMPILED) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "may not disassemble prebuilt bytecode", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", - "BYTECODE", NULL); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(codeObjPtr)); - return TCL_OK; -} - -/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclResolve.c b/generic/tclResolve.c index 974737e..4520890 100644 --- a/generic/tclResolve.c +++ b/generic/tclResolve.c @@ -43,8 +43,6 @@ static void BumpCmdRefEpochs(Namespace *nsPtr); * cmdProcPtr, varProcPtr and compiledVarProcPtr arguments. * * Side effects: - * If a compiledVarProc is specified, this function bumps the - * compileEpoch for the interpreter, forcing all code to be recompiled. * If a cmdProc is specified, this function bumps the cmdRefEpoch in all * namespaces, forcing commands to be resolved again using the new rules. * @@ -75,9 +73,6 @@ Tcl_AddInterpResolvers( * cmdRefEpoch in all namespaces. */ - if (compiledVarProc) { - iPtr->compileEpoch++; - } if (cmdProc) { BumpCmdRefEpochs(iPtr->globalNsPtr); } @@ -175,9 +170,7 @@ Tcl_GetInterpResolvers( * was deleted. Returns zero otherwise. * * Side effects: - * If a scheme with a compiledVarProc was deleted, this function bumps - * the compileEpoch for the interpreter, forcing all code to be - * recompiled. If a scheme with a cmdProc was deleted, this function + * If a scheme with a cmdProc was deleted, this function * bumps the cmdRefEpoch in all namespaces, forcing commands to be * resolved again using the new rules. * @@ -217,9 +210,6 @@ Tcl_RemoveInterpResolvers( * cmdRefEpoch in all namespaces. */ - if (resPtr->compiledVarResProc) { - iPtr->compileEpoch++; - } if (resPtr->cmdResProc) { BumpCmdRefEpochs(iPtr->globalNsPtr); } diff --git a/generic/tclScan.c b/generic/tclScan.c index ef7eedf..9b1f40a 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -259,7 +259,7 @@ ValidateFormat( char *end; Tcl_UniChar ch; int objIndex, xpgSize, nspace = numVars; - int *nassign = TclStackAlloc(interp, nspace * sizeof(int)); + int *nassign = ckalloc(nspace * sizeof(int)); char buf[TCL_UTF_MAX+1]; Tcl_Obj *errorMsg; /* Place to build an error messages. Note that * these are messy operations because we do @@ -480,8 +480,7 @@ ValidateFormat( } else { nspace += 16; /* formerly STATIC_LIST_SIZE */ } - nassign = TclStackRealloc(interp, nassign, - nspace * sizeof(int)); + nassign = ckrealloc(nassign, nspace * sizeof(int)); for (i = value; i < nspace; i++) { nassign[i] = 0; } @@ -526,7 +525,7 @@ ValidateFormat( } } - TclStackFree(interp, nassign); + ckfree(nassign); return TCL_OK; badIndex: @@ -542,7 +541,7 @@ ValidateFormat( } error: - TclStackFree(interp, nassign); + ckfree(nassign); return TCL_ERROR; } diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 2ec064f..28382b9 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -41,7 +41,6 @@ #undef Tcl_FindExecutable #undef TclpGetPid #undef TclSockMinimumBuffers -#define TclBackgroundException Tcl_BackgroundException /* See bug 510001: TclSockMinimumBuffers needs plat imp */ #ifdef _WIN64 @@ -193,7 +192,7 @@ static const TclIntStubs tclIntStubs = { 0, /* 0 */ 0, /* 1 */ 0, /* 2 */ - TclAllocateFreeObjects, /* 3 */ + 0, /* 3 */ 0, /* 4 */ TclCleanupChildren, /* 5 */ TclCleanupCommand, /* 6 */ @@ -259,19 +258,19 @@ static const TclIntStubs tclIntStubs = { 0, /* 66 */ 0, /* 67 */ 0, /* 68 */ - TclpAlloc, /* 69 */ + 0, /* 69 */ 0, /* 70 */ 0, /* 71 */ 0, /* 72 */ 0, /* 73 */ - TclpFree, /* 74 */ + 0, /* 74 */ TclpGetClicks, /* 75 */ TclpGetSeconds, /* 76 */ TclpGetTime, /* 77 */ 0, /* 78 */ 0, /* 79 */ 0, /* 80 */ - TclpRealloc, /* 81 */ + 0, /* 81 */ 0, /* 82 */ 0, /* 83 */ 0, /* 84 */ @@ -405,8 +404,8 @@ static const TclIntStubs tclIntStubs = { TclpFindExecutable, /* 212 */ TclGetObjNameOfExecutable, /* 213 */ TclSetObjNameOfExecutable, /* 214 */ - TclStackAlloc, /* 215 */ - TclStackFree, /* 216 */ + 0, /* 215 */ + 0, /* 216 */ TclPushStackFrame, /* 217 */ TclPopStackFrame, /* 218 */ 0, /* 219 */ @@ -416,7 +415,7 @@ static const TclIntStubs tclIntStubs = { 0, /* 223 */ TclGetPlatform, /* 224 */ TclTraceDictPath, /* 225 */ - TclObjBeingDeleted, /* 226 */ + 0, /* 226 */ TclSetNsPath, /* 227 */ 0, /* 228 */ TclPtrMakeUpvar, /* 229 */ @@ -426,9 +425,9 @@ static const TclIntStubs tclIntStubs = { 0, /* 233 */ TclVarHashCreateVar, /* 234 */ TclInitVarHashTable, /* 235 */ - TclBackgroundException, /* 236 */ + 0, /* 236 */ TclResetCancellation, /* 237 */ - TclNRInterpProc, /* 238 */ + 0, /* 238 */ TclNRInterpProcCore, /* 239 */ TclNRRunCallbacks, /* 240 */ TclNREvalObjEx, /* 241 */ @@ -785,7 +784,7 @@ const TclStubs tclStubs = { Tcl_ErrnoMsg, /* 128 */ Tcl_Eval, /* 129 */ Tcl_EvalFile, /* 130 */ - Tcl_EvalObj, /* 131 */ + 0, /* 131 */ Tcl_EventuallyFree, /* 132 */ Tcl_Exit, /* 133 */ Tcl_ExposeCommand, /* 134 */ @@ -813,7 +812,7 @@ const TclStubs tclStubs = { Tcl_GetChannelName, /* 156 */ Tcl_GetChannelOption, /* 157 */ Tcl_GetChannelType, /* 158 */ - Tcl_GetCommandInfo, /* 159 */ + 0, /* 159 */ Tcl_GetCommandName, /* 160 */ Tcl_GetErrno, /* 161 */ Tcl_GetHostName, /* 162 */ @@ -840,7 +839,7 @@ const TclStubs tclStubs = { Tcl_GetVar, /* 175 */ Tcl_GetVar2, /* 176 */ Tcl_GlobalEval, /* 177 */ - Tcl_GlobalEvalObj, /* 178 */ + 0, /* 178 */ Tcl_HideCommand, /* 179 */ Tcl_Init, /* 180 */ Tcl_InitHashTable, /* 181 */ @@ -888,7 +887,7 @@ const TclStubs tclStubs = { Tcl_SetAssocData, /* 223 */ Tcl_SetChannelBufferSize, /* 224 */ Tcl_SetChannelOption, /* 225 */ - Tcl_SetCommandInfo, /* 226 */ + 0, /* 226 */ Tcl_SetErrno, /* 227 */ Tcl_SetErrorCode, /* 228 */ Tcl_SetMaxBlockTime, /* 229 */ @@ -1146,8 +1145,8 @@ const TclStubs tclStubs = { Tcl_EvalTokensStandard, /* 481 */ Tcl_GetTime, /* 482 */ Tcl_CreateObjTrace, /* 483 */ - Tcl_GetCommandInfoFromToken, /* 484 */ - Tcl_SetCommandInfoFromToken, /* 485 */ + 0, /* 484 */ + 0, /* 485 */ Tcl_DbNewWideIntObj, /* 486 */ Tcl_GetWideIntFromObj, /* 487 */ Tcl_NewWideIntObj, /* 488 */ @@ -1245,7 +1244,7 @@ const TclStubs tclStubs = { Tcl_CancelEval, /* 580 */ Tcl_Canceled, /* 581 */ Tcl_CreatePipe, /* 582 */ - Tcl_NRCreateCommand, /* 583 */ + 0, /* 583 */ Tcl_NREvalObj, /* 584 */ Tcl_NREvalObjv, /* 585 */ Tcl_NRCmdSwap, /* 586 */ @@ -1288,7 +1287,7 @@ const TclStubs tclStubs = { Tcl_GetStartupScript, /* 623 */ Tcl_CloseEx, /* 624 */ Tcl_NRExprObj, /* 625 */ - Tcl_NRSubstObj, /* 626 */ + 0, /* 626 */ Tcl_LoadFile, /* 627 */ Tcl_FindSymbol, /* 628 */ Tcl_FSUnloadFile, /* 629 */ diff --git a/generic/tclTest.c b/generic/tclTest.c index 75ecb6a..a1ca641 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -163,12 +163,8 @@ static Tcl_ThreadCreateType AsyncThreadProc(ClientData); #endif static void CleanupTestSetassocdataTests( ClientData clientData, Tcl_Interp *interp); -static void CmdDelProc1(ClientData clientData); -static void CmdDelProc2(ClientData clientData); static int CmdProc1(ClientData clientData, Tcl_Interp *interp, int argc, const char **argv); -static int CmdProc2(ClientData clientData, - Tcl_Interp *interp, int argc, const char **argv); static void CmdTraceDeleteProc( ClientData clientData, Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *cmdProc, @@ -220,8 +216,6 @@ static void SpecialFree(char *blockPtr); static int StaticInitProc(Tcl_Interp *interp); static int TestasyncCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestcmdinfoCmd(ClientData dummy, - Tcl_Interp *interp, int argc, const char **argv); static int TestcmdtokenCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestcmdtraceCmd(ClientData dummy, @@ -571,8 +565,6 @@ Tcltest_Init( NULL, NULL); Tcl_CreateCommand(interp, "testcmdtoken", TestcmdtokenCmd, NULL, NULL); - Tcl_CreateCommand(interp, "testcmdinfo", TestcmdinfoCmd, NULL, - NULL); Tcl_CreateCommand(interp, "testcmdtrace", TestcmdtraceCmd, NULL, NULL); Tcl_CreateCommand(interp, "testconcatobj", TestconcatobjCmd, @@ -995,96 +987,7 @@ AsyncThreadProc( } #endif -/* - *---------------------------------------------------------------------- - * - * TestcmdinfoCmd -- - * - * This procedure implements the "testcmdinfo" command. It is used to - * test Tcl_GetCommandInfo, Tcl_SetCommandInfo, and command creation and - * deletion. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Creates and deletes various commands and modifies their data. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -TestcmdinfoCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - const char **argv) /* Argument strings. */ -{ - Tcl_CmdInfo info; - - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " option cmdName\"", NULL); - return TCL_ERROR; - } - if (strcmp(argv[1], "create") == 0) { - Tcl_CreateCommand(interp, argv[2], CmdProc1, (ClientData) "original", - CmdDelProc1); - } else if (strcmp(argv[1], "delete") == 0) { - Tcl_DStringInit(&delString); - Tcl_DeleteCommand(interp, argv[2]); - Tcl_DStringResult(interp, &delString); - } else if (strcmp(argv[1], "get") == 0) { - if (Tcl_GetCommandInfo(interp, argv[2], &info) ==0) { - Tcl_SetResult(interp, "??", TCL_STATIC); - return TCL_OK; - } - if (info.proc == CmdProc1) { - Tcl_AppendResult(interp, "CmdProc1", " ", - (char *) info.clientData, NULL); - } else if (info.proc == CmdProc2) { - Tcl_AppendResult(interp, "CmdProc2", " ", - (char *) info.clientData, NULL); - } else { - Tcl_AppendResult(interp, "unknown", NULL); - } - if (info.deleteProc == CmdDelProc1) { - Tcl_AppendResult(interp, " CmdDelProc1", " ", - (char *) info.deleteData, NULL); - } else if (info.deleteProc == CmdDelProc2) { - Tcl_AppendResult(interp, " CmdDelProc2", " ", - (char *) info.deleteData, NULL); - } else { - Tcl_AppendResult(interp, " unknown", NULL); - } - Tcl_AppendResult(interp, " ", info.namespacePtr->fullName, NULL); - if (info.isNativeObjectProc) { - Tcl_AppendResult(interp, " nativeObjectProc", NULL); - } else { - Tcl_AppendResult(interp, " stringProc", NULL); - } - } else if (strcmp(argv[1], "modify") == 0) { - info.proc = CmdProc2; - info.clientData = (ClientData) "new_command_data"; - info.objProc = NULL; - info.objClientData = NULL; - info.deleteProc = CmdDelProc2; - info.deleteData = (ClientData) "new_delete_data"; - if (Tcl_SetCommandInfo(interp, argv[2], &info) == 0) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); - } else { - Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); - } - } else { - Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be create, delete, get, or modify", NULL); - return TCL_ERROR; - } - return TCL_OK; -} - - /*ARGSUSED*/ static int CmdProc1( ClientData clientData, /* String to return. */ @@ -1097,35 +1000,6 @@ CmdProc1( } /*ARGSUSED*/ -static int -CmdProc2( - ClientData clientData, /* String to return. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - const char **argv) /* Argument strings. */ -{ - Tcl_AppendResult(interp, "CmdProc2 ", (char *) clientData, NULL); - return TCL_OK; -} - -static void -CmdDelProc1( - ClientData clientData) /* String to save. */ -{ - Tcl_DStringInit(&delString); - Tcl_DStringAppend(&delString, "CmdDelProc1 ", -1); - Tcl_DStringAppend(&delString, (char *) clientData, -1); -} - -static void -CmdDelProc2( - ClientData clientData) /* String to save. */ -{ - Tcl_DStringInit(&delString); - Tcl_DStringAppend(&delString, "CmdDelProc2 ", -1); - Tcl_DStringAppend(&delString, (char *) clientData, -1); -} - /* *---------------------------------------------------------------------- * @@ -1440,18 +1314,17 @@ CreatedCommandProc( int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { - Tcl_CmdInfo info; - int found; + Command *cmd;; - found = Tcl_GetCommandInfo(interp, "test_ns_basic::createdcommand", - &info); - if (!found) { + cmd = (Command *) Tcl_FindCommand(interp, "test_ns_basic::createdcommand", + NULL, 0); + if (cmd == NULL) { Tcl_AppendResult(interp, "CreatedCommandProc could not get command info for test_ns_basic::createdcommand", NULL); return TCL_ERROR; } Tcl_AppendResult(interp, "CreatedCommandProc in ", - info.namespacePtr->fullName, NULL); + cmd->nsPtr->fullName, NULL); return TCL_OK; } @@ -1462,17 +1335,16 @@ CreatedCommandProc2( int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { - Tcl_CmdInfo info; - int found; + Command *cmd;; - found = Tcl_GetCommandInfo(interp, "value:at:", &info); - if (!found) { + cmd = (Command *) Tcl_FindCommand(interp, "value:at:", NULL, 0); + if (cmd == NULL) { Tcl_AppendResult(interp, "CreatedCommandProc2 could not get command info for test_ns_basic::createdcommand", NULL); return TCL_ERROR; } Tcl_AppendResult(interp, "CreatedCommandProc2 in ", - info.namespacePtr->fullName, NULL); + cmd->nsPtr->fullName, NULL); return TCL_OK; } @@ -4637,7 +4509,7 @@ TestgetvarfullnameCmd( const char *name, *arg; int flags = 0; Tcl_Namespace *namespacePtr; - Tcl_CallFrame *framePtr; + CallFrame *framePtr; Tcl_Var variable; int result; @@ -6798,16 +6670,15 @@ TestNRELevels( levels[0] = Tcl_NewIntObj(depth); levels[1] = Tcl_NewIntObj(iPtr->numLevels); levels[2] = Tcl_NewIntObj(iPtr->varFramePtr->level); - levels[3] = Tcl_NewIntObj(iPtr->execEnvPtr->execStackPtr->tosPtr - - iPtr->execEnvPtr->execStackPtr->stackWords); + while (cbPtr) { i++; cbPtr = NEXT_CB(cbPtr); } - levels[4] = Tcl_NewIntObj(i); + levels[3] = Tcl_NewIntObj(i); - Tcl_SetObjResult(interp, Tcl_NewListObj(5, levels)); + Tcl_SetObjResult(interp, Tcl_NewListObj(4, levels)); return TCL_OK; } diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c deleted file mode 100644 index e4261d6..0000000 --- a/generic/tclThreadAlloc.c +++ /dev/null @@ -1,1080 +0,0 @@ -/* - * tclThreadAlloc.c -- - * - * This is a very fast storage allocator for used with threads (designed - * avoid lock contention). The basic strategy is to allocate memory in - * fixed size blocks from block caches. - * - * The Initial Developer of the Original Code is America Online, Inc. - * Portions created by AOL are Copyright (C) 1999 America Online, Inc. - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#include "tclInt.h" -#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) - -/* - * If range checking is enabled, an additional byte will be allocated to store - * the magic number at the end of the requested memory. - */ - -#ifndef RCHECK -#ifdef NDEBUG -#define RCHECK 0 -#else -#define RCHECK 1 -#endif -#endif - -/* - * The following define the number of Tcl_Obj's to allocate/move at a time and - * the high water mark to prune a per-thread cache. On a 32 bit system, - * sizeof(Tcl_Obj) = 24 so 800 * 24 = ~16k. - */ - -#define NOBJALLOC 800 - -/* Actual definition moved to tclInt.h */ -#define NOBJHIGH ALLOC_NOBJHIGH - -/* - * The following union stores accounting information for each block including - * two small magic numbers and a bucket number when in use or a next pointer - * when free. The original requested size (not including the Block overhead) - * is also maintained. - */ - -typedef union Block { - struct { - union { - union Block *next; /* Next in free list. */ - struct { - unsigned char magic1; /* First magic number. */ - unsigned char bucket; /* Bucket block allocated from. */ - unsigned char unused; /* Padding. */ - unsigned char magic2; /* Second magic number. */ - } s; - } u; - size_t reqSize; /* Requested allocation size. */ - } b; - unsigned char padding[TCL_ALLOCALIGN]; -} Block; -#define nextBlock b.u.next -#define sourceBucket b.u.s.bucket -#define magicNum1 b.u.s.magic1 -#define magicNum2 b.u.s.magic2 -#define MAGIC 0xEF -#define blockReqSize b.reqSize - -/* - * The following defines the minimum and and maximum block sizes and the number - * of buckets in the bucket cache. - */ - -#define MINALLOC ((sizeof(Block) + 8 + (TCL_ALLOCALIGN-1)) & ~(TCL_ALLOCALIGN-1)) -#define NBUCKETS (11 - (MINALLOC >> 5)) -#define MAXALLOC (MINALLOC << (NBUCKETS - 1)) - -/* - * The following structure defines a bucket of blocks with various accounting - * and statistics information. - */ - -typedef struct Bucket { - Block *firstPtr; /* First block available */ - long numFree; /* Number of blocks available */ - - /* All fields below for accounting only */ - - long numRemoves; /* Number of removes from bucket */ - long numInserts; /* Number of inserts into bucket */ - long numWaits; /* Number of waits to acquire a lock */ - long numLocks; /* Number of locks acquired */ - long totalAssigned; /* Total space assigned to bucket */ -} Bucket; - -/* - * The following structure defines a cache of buckets and objs, of which there - * will be (at most) one per thread. Any changes need to be reflected in the - * struct AllocCache defined in tclInt.h, possibly also in the initialisation - * code in Tcl_CreateInterp(). - */ - -typedef struct Cache { - struct Cache *nextPtr; /* Linked list of cache entries */ - Tcl_ThreadId owner; /* Which thread's cache is this? */ - Tcl_Obj *firstObjPtr; /* List of free objects for thread */ - int numObjects; /* Number of objects for thread */ - int totalAssigned; /* Total space assigned to thread */ - Bucket buckets[NBUCKETS]; /* The buckets for this thread */ -} Cache; - -/* - * The following array specifies various per-bucket limits and locks. The - * values are statically initialized to avoid calculating them repeatedly. - */ - -static struct { - size_t blockSize; /* Bucket blocksize. */ - int maxBlocks; /* Max blocks before move to share. */ - int numMove; /* Num blocks to move to share. */ - Tcl_Mutex *lockPtr; /* Share bucket lock. */ -} bucketInfo[NBUCKETS]; - -/* - * Static functions defined in this file. - */ - -static Cache * GetCache(void); -static void LockBucket(Cache *cachePtr, int bucket); -static void UnlockBucket(Cache *cachePtr, int bucket); -static void PutBlocks(Cache *cachePtr, int bucket, int numMove); -static int GetBlocks(Cache *cachePtr, int bucket); -static Block * Ptr2Block(char *ptr); -static char * Block2Ptr(Block *blockPtr, int bucket, unsigned int reqSize); -static void MoveObjs(Cache *fromPtr, Cache *toPtr, int numMove); - -/* - * Local variables defined in this file and initialized at startup. - */ - -static Tcl_Mutex *listLockPtr; -static Tcl_Mutex *objLockPtr; -static Cache sharedCache; -static Cache *sharedPtr = &sharedCache; -static Cache *firstCachePtr = &sharedCache; - -#if defined(HAVE_FAST_TSD) -static __thread Cache *tcachePtr; - -# define GETCACHE(cachePtr) \ - do { \ - if (!tcachePtr) { \ - tcachePtr = GetCache(); \ - } \ - (cachePtr) = tcachePtr; \ - } while (0) -#else -# define GETCACHE(cachePtr) \ - do { \ - (cachePtr) = TclpGetAllocCache(); \ - if ((cachePtr) == NULL) { \ - (cachePtr) = GetCache(); \ - } \ - } while (0) -#endif - -/* - *---------------------------------------------------------------------- - * - * GetCache --- - * - * Gets per-thread memory cache, allocating it if necessary. - * - * Results: - * Pointer to cache. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static Cache * -GetCache(void) -{ - Cache *cachePtr; - - /* - * Check for first-time initialization. - */ - - if (listLockPtr == NULL) { - Tcl_Mutex *initLockPtr; - unsigned int i; - - initLockPtr = Tcl_GetAllocMutex(); - Tcl_MutexLock(initLockPtr); - if (listLockPtr == NULL) { - listLockPtr = TclpNewAllocMutex(); - objLockPtr = TclpNewAllocMutex(); - for (i = 0; i < NBUCKETS; ++i) { - bucketInfo[i].blockSize = MINALLOC << i; - bucketInfo[i].maxBlocks = 1 << (NBUCKETS - 1 - i); - bucketInfo[i].numMove = i < NBUCKETS - 1 ? - 1 << (NBUCKETS - 2 - i) : 1; - bucketInfo[i].lockPtr = TclpNewAllocMutex(); - } - } - Tcl_MutexUnlock(initLockPtr); - } - - /* - * Get this thread's cache, allocating if necessary. - */ - - cachePtr = TclpGetAllocCache(); - if (cachePtr == NULL) { - cachePtr = calloc(1, sizeof(Cache)); - if (cachePtr == NULL) { - Tcl_Panic("alloc: could not allocate new cache"); - } - Tcl_MutexLock(listLockPtr); - cachePtr->nextPtr = firstCachePtr; - firstCachePtr = cachePtr; - Tcl_MutexUnlock(listLockPtr); - cachePtr->owner = Tcl_GetCurrentThread(); - TclpSetAllocCache(cachePtr); - } - return cachePtr; -} - -/* - *---------------------------------------------------------------------- - * - * TclFreeAllocCache -- - * - * Flush and delete a cache, removing from list of caches. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void -TclFreeAllocCache( - void *arg) -{ - Cache *cachePtr = arg; - Cache **nextPtrPtr; - register unsigned int bucket; - - /* - * Flush blocks. - */ - - for (bucket = 0; bucket < NBUCKETS; ++bucket) { - if (cachePtr->buckets[bucket].numFree > 0) { - PutBlocks(cachePtr, bucket, cachePtr->buckets[bucket].numFree); - } - } - - /* - * Flush objs. - */ - - if (cachePtr->numObjects > 0) { - Tcl_MutexLock(objLockPtr); - MoveObjs(cachePtr, sharedPtr, cachePtr->numObjects); - Tcl_MutexUnlock(objLockPtr); - } - - /* - * Remove from pool list. - */ - - Tcl_MutexLock(listLockPtr); - nextPtrPtr = &firstCachePtr; - while (*nextPtrPtr != cachePtr) { - nextPtrPtr = &(*nextPtrPtr)->nextPtr; - } - *nextPtrPtr = cachePtr->nextPtr; - cachePtr->nextPtr = NULL; - Tcl_MutexUnlock(listLockPtr); - free(cachePtr); -} - -/* - *---------------------------------------------------------------------- - * - * TclpAlloc -- - * - * Allocate memory. - * - * Results: - * Pointer to memory just beyond Block pointer. - * - * Side effects: - * May allocate more blocks for a bucket. - * - *---------------------------------------------------------------------- - */ - -char * -TclpAlloc( - unsigned int reqSize) -{ - Cache *cachePtr; - Block *blockPtr; - register int bucket; - size_t size; - -#ifndef __LP64__ - if (sizeof(int) >= sizeof(size_t)) { - /* An unsigned int overflow can also be a size_t overflow */ - const size_t zero = 0; - const size_t max = ~zero; - - if (((size_t) reqSize) > max - sizeof(Block) - RCHECK) { - /* Requested allocation exceeds memory */ - return NULL; - } - } -#endif - - GETCACHE(cachePtr); - - /* - * Increment the requested size to include room for the Block structure. - * Call malloc() directly if the required amount is greater than the - * largest block, otherwise pop the smallest block large enough, - * allocating more blocks if necessary. - */ - - blockPtr = NULL; - size = reqSize + sizeof(Block); -#if RCHECK - size++; -#endif - if (size > MAXALLOC) { - bucket = NBUCKETS; - blockPtr = malloc(size); - if (blockPtr != NULL) { - cachePtr->totalAssigned += reqSize; - } - } else { - bucket = 0; - while (bucketInfo[bucket].blockSize < size) { - bucket++; - } - if (cachePtr->buckets[bucket].numFree || GetBlocks(cachePtr, bucket)) { - blockPtr = cachePtr->buckets[bucket].firstPtr; - cachePtr->buckets[bucket].firstPtr = blockPtr->nextBlock; - cachePtr->buckets[bucket].numFree--; - cachePtr->buckets[bucket].numRemoves++; - cachePtr->buckets[bucket].totalAssigned += reqSize; - } - } - if (blockPtr == NULL) { - return NULL; - } - return Block2Ptr(blockPtr, bucket, reqSize); -} - -/* - *---------------------------------------------------------------------- - * - * TclpFree -- - * - * Return blocks to the thread block cache. - * - * Results: - * None. - * - * Side effects: - * May move blocks to shared cache. - * - *---------------------------------------------------------------------- - */ - -void -TclpFree( - char *ptr) -{ - Cache *cachePtr; - Block *blockPtr; - int bucket; - - if (ptr == NULL) { - return; - } - - GETCACHE(cachePtr); - - /* - * Get the block back from the user pointer and call system free directly - * for large blocks. Otherwise, push the block back on the bucket and move - * blocks to the shared cache if there are now too many free. - */ - - blockPtr = Ptr2Block(ptr); - bucket = blockPtr->sourceBucket; - if (bucket == NBUCKETS) { - cachePtr->totalAssigned -= blockPtr->blockReqSize; - free(blockPtr); - return; - } - - cachePtr->buckets[bucket].totalAssigned -= blockPtr->blockReqSize; - blockPtr->nextBlock = cachePtr->buckets[bucket].firstPtr; - cachePtr->buckets[bucket].firstPtr = blockPtr; - cachePtr->buckets[bucket].numFree++; - cachePtr->buckets[bucket].numInserts++; - - if (cachePtr != sharedPtr && - cachePtr->buckets[bucket].numFree > bucketInfo[bucket].maxBlocks) { - PutBlocks(cachePtr, bucket, bucketInfo[bucket].numMove); - } -} - -/* - *---------------------------------------------------------------------- - * - * TclpRealloc -- - * - * Re-allocate memory to a larger or smaller size. - * - * Results: - * Pointer to memory just beyond Block pointer. - * - * Side effects: - * Previous memory, if any, may be freed. - * - *---------------------------------------------------------------------- - */ - -char * -TclpRealloc( - char *ptr, - unsigned int reqSize) -{ - Cache *cachePtr; - Block *blockPtr; - void *newPtr; - size_t size, min; - int bucket; - - if (ptr == NULL) { - return TclpAlloc(reqSize); - } - -#ifndef __LP64__ - if (sizeof(int) >= sizeof(size_t)) { - /* An unsigned int overflow can also be a size_t overflow */ - const size_t zero = 0; - const size_t max = ~zero; - - if (((size_t) reqSize) > max - sizeof(Block) - RCHECK) { - /* Requested allocation exceeds memory */ - return NULL; - } - } -#endif - - GETCACHE(cachePtr); - - /* - * If the block is not a system block and fits in place, simply return the - * existing pointer. Otherwise, if the block is a system block and the new - * size would also require a system block, call realloc() directly. - */ - - blockPtr = Ptr2Block(ptr); - size = reqSize + sizeof(Block); -#if RCHECK - size++; -#endif - bucket = blockPtr->sourceBucket; - if (bucket != NBUCKETS) { - if (bucket > 0) { - min = bucketInfo[bucket-1].blockSize; - } else { - min = 0; - } - if (size > min && size <= bucketInfo[bucket].blockSize) { - cachePtr->buckets[bucket].totalAssigned -= blockPtr->blockReqSize; - cachePtr->buckets[bucket].totalAssigned += reqSize; - return Block2Ptr(blockPtr, bucket, reqSize); - } - } else if (size > MAXALLOC) { - cachePtr->totalAssigned -= blockPtr->blockReqSize; - cachePtr->totalAssigned += reqSize; - blockPtr = realloc(blockPtr, size); - if (blockPtr == NULL) { - return NULL; - } - return Block2Ptr(blockPtr, NBUCKETS, reqSize); - } - - /* - * Finally, perform an expensive malloc/copy/free. - */ - - newPtr = TclpAlloc(reqSize); - if (newPtr != NULL) { - if (reqSize > blockPtr->blockReqSize) { - reqSize = blockPtr->blockReqSize; - } - memcpy(newPtr, ptr, reqSize); - TclpFree(ptr); - } - return newPtr; -} - -/* - *---------------------------------------------------------------------- - * - * TclThreadAllocObj -- - * - * Allocate a Tcl_Obj from the per-thread cache. - * - * Results: - * Pointer to uninitialized Tcl_Obj. - * - * Side effects: - * May move Tcl_Obj's from shared cached or allocate new Tcl_Obj's if - * list is empty. - * - * Note: - * If this code is updated, the changes need to be reflected in the macro - * TclAllocObjStorageEx() defined in tclInt.h - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclThreadAllocObj(void) -{ - register Cache *cachePtr; - register Tcl_Obj *objPtr; - - GETCACHE(cachePtr); - - /* - * Get this thread's obj list structure and move or allocate new objs if - * necessary. - */ - - if (cachePtr->numObjects == 0) { - register int numMove; - - Tcl_MutexLock(objLockPtr); - numMove = sharedPtr->numObjects; - if (numMove > 0) { - if (numMove > NOBJALLOC) { - numMove = NOBJALLOC; - } - MoveObjs(sharedPtr, cachePtr, numMove); - } - Tcl_MutexUnlock(objLockPtr); - if (cachePtr->numObjects == 0) { - Tcl_Obj *newObjsPtr; - - cachePtr->numObjects = numMove = NOBJALLOC; - newObjsPtr = malloc(sizeof(Tcl_Obj) * numMove); - if (newObjsPtr == NULL) { - Tcl_Panic("alloc: could not allocate %d new objects", numMove); - } - while (--numMove >= 0) { - objPtr = &newObjsPtr[numMove]; - objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr; - cachePtr->firstObjPtr = objPtr; - } - } - } - - /* - * Pop the first object. - */ - - objPtr = cachePtr->firstObjPtr; - cachePtr->firstObjPtr = objPtr->internalRep.otherValuePtr; - cachePtr->numObjects--; - return objPtr; -} - -/* - *---------------------------------------------------------------------- - * - * TclThreadFreeObj -- - * - * Return a free Tcl_Obj to the per-thread cache. - * - * Results: - * None. - * - * Side effects: - * May move free Tcl_Obj's to shared list upon hitting high water mark. - * - * Note: - * If this code is updated, the changes need to be reflected in the macro - * TclAllocObjStorageEx() defined in tclInt.h - * - *---------------------------------------------------------------------- - */ - -void -TclThreadFreeObj( - Tcl_Obj *objPtr) -{ - Cache *cachePtr; - - GETCACHE(cachePtr); - - /* - * Get this thread's list and push on the free Tcl_Obj. - */ - - objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr; - cachePtr->firstObjPtr = objPtr; - cachePtr->numObjects++; - - /* - * If the number of free objects has exceeded the high water mark, move - * some blocks to the shared list. - */ - - if (cachePtr->numObjects > NOBJHIGH) { - Tcl_MutexLock(objLockPtr); - MoveObjs(cachePtr, sharedPtr, NOBJALLOC); - Tcl_MutexUnlock(objLockPtr); - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetMemoryInfo -- - * - * Return a list-of-lists of memory stats. - * - * Results: - * None. - * - * Side effects: - * List appended to given dstring. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_GetMemoryInfo( - Tcl_DString *dsPtr) -{ - Cache *cachePtr; - char buf[200]; - unsigned int n; - - Tcl_MutexLock(listLockPtr); - cachePtr = firstCachePtr; - while (cachePtr != NULL) { - Tcl_DStringStartSublist(dsPtr); - if (cachePtr == sharedPtr) { - Tcl_DStringAppendElement(dsPtr, "shared"); - } else { - sprintf(buf, "thread%p", cachePtr->owner); - Tcl_DStringAppendElement(dsPtr, buf); - } - for (n = 0; n < NBUCKETS; ++n) { - sprintf(buf, "%lu %ld %ld %ld %ld %ld %ld", - (unsigned long) bucketInfo[n].blockSize, - cachePtr->buckets[n].numFree, - cachePtr->buckets[n].numRemoves, - cachePtr->buckets[n].numInserts, - cachePtr->buckets[n].totalAssigned, - cachePtr->buckets[n].numLocks, - cachePtr->buckets[n].numWaits); - Tcl_DStringAppendElement(dsPtr, buf); - } - Tcl_DStringEndSublist(dsPtr); - cachePtr = cachePtr->nextPtr; - } - Tcl_MutexUnlock(listLockPtr); -} - -/* - *---------------------------------------------------------------------- - * - * MoveObjs -- - * - * Move Tcl_Obj's between caches. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -MoveObjs( - Cache *fromPtr, - Cache *toPtr, - int numMove) -{ - register Tcl_Obj *objPtr = fromPtr->firstObjPtr; - Tcl_Obj *fromFirstObjPtr = objPtr; - - toPtr->numObjects += numMove; - fromPtr->numObjects -= numMove; - - /* - * Find the last object to be moved; set the next one (the first one not - * to be moved) as the first object in the 'from' cache. - */ - - while (--numMove) { - objPtr = objPtr->internalRep.otherValuePtr; - } - fromPtr->firstObjPtr = objPtr->internalRep.otherValuePtr; - - /* - * Move all objects as a block - they are already linked to each other, we - * just have to update the first and last. - */ - - objPtr->internalRep.otherValuePtr = toPtr->firstObjPtr; - toPtr->firstObjPtr = fromFirstObjPtr; -} - -/* - *---------------------------------------------------------------------- - * - * Block2Ptr, Ptr2Block -- - * - * Convert between internal blocks and user pointers. - * - * Results: - * User pointer or internal block. - * - * Side effects: - * Invalid blocks will abort the server. - * - *---------------------------------------------------------------------- - */ - -static char * -Block2Ptr( - Block *blockPtr, - int bucket, - unsigned int reqSize) -{ - register void *ptr; - - blockPtr->magicNum1 = blockPtr->magicNum2 = MAGIC; - blockPtr->sourceBucket = bucket; - blockPtr->blockReqSize = reqSize; - ptr = ((void *) (blockPtr + 1)); -#if RCHECK - ((unsigned char *)(ptr))[reqSize] = MAGIC; -#endif - return (char *) ptr; -} - -static Block * -Ptr2Block( - char *ptr) -{ - register Block *blockPtr; - - blockPtr = (((Block *) ptr) - 1); - if (blockPtr->magicNum1 != MAGIC || blockPtr->magicNum2 != MAGIC) { - Tcl_Panic("alloc: invalid block: %p: %x %x", - blockPtr, blockPtr->magicNum1, blockPtr->magicNum2); - } -#if RCHECK - if (((unsigned char *) ptr)[blockPtr->blockReqSize] != MAGIC) { - Tcl_Panic("alloc: invalid block: %p: %x %x %x", - blockPtr, blockPtr->magicNum1, blockPtr->magicNum2, - ((unsigned char *) ptr)[blockPtr->blockReqSize]); - } -#endif - return blockPtr; -} - -/* - *---------------------------------------------------------------------- - * - * LockBucket, UnlockBucket -- - * - * Set/unset the lock to access a bucket in the shared cache. - * - * Results: - * None. - * - * Side effects: - * Lock activity and contention are monitored globally and on a per-cache - * basis. - * - *---------------------------------------------------------------------- - */ - -static void -LockBucket( - Cache *cachePtr, - int bucket) -{ - Tcl_MutexLock(bucketInfo[bucket].lockPtr); - cachePtr->buckets[bucket].numLocks++; - sharedPtr->buckets[bucket].numLocks++; -} - -static void -UnlockBucket( - Cache *cachePtr, - int bucket) -{ - Tcl_MutexUnlock(bucketInfo[bucket].lockPtr); -} - -/* - *---------------------------------------------------------------------- - * - * PutBlocks -- - * - * Return unused blocks to the shared cache. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -PutBlocks( - Cache *cachePtr, - int bucket, - int numMove) -{ - register Block *lastPtr, *firstPtr; - register int n = numMove; - - /* - * Before acquiring the lock, walk the block list to find the last block - * to be moved. - */ - - firstPtr = lastPtr = cachePtr->buckets[bucket].firstPtr; - while (--n > 0) { - lastPtr = lastPtr->nextBlock; - } - cachePtr->buckets[bucket].firstPtr = lastPtr->nextBlock; - cachePtr->buckets[bucket].numFree -= numMove; - - /* - * Aquire the lock and place the list of blocks at the front of the shared - * cache bucket. - */ - - LockBucket(cachePtr, bucket); - lastPtr->nextBlock = sharedPtr->buckets[bucket].firstPtr; - sharedPtr->buckets[bucket].firstPtr = firstPtr; - sharedPtr->buckets[bucket].numFree += numMove; - UnlockBucket(cachePtr, bucket); -} - -/* - *---------------------------------------------------------------------- - * - * GetBlocks -- - * - * Get more blocks for a bucket. - * - * Results: - * 1 if blocks where allocated, 0 otherwise. - * - * Side effects: - * Cache may be filled with available blocks. - * - *---------------------------------------------------------------------- - */ - -static int -GetBlocks( - Cache *cachePtr, - int bucket) -{ - register Block *blockPtr; - register int n; - - /* - * First, atttempt to move blocks from the shared cache. Note the - * potentially dirty read of numFree before acquiring the lock which is a - * slight performance enhancement. The value is verified after the lock is - * actually acquired. - */ - - if (cachePtr != sharedPtr && sharedPtr->buckets[bucket].numFree > 0) { - LockBucket(cachePtr, bucket); - if (sharedPtr->buckets[bucket].numFree > 0) { - - /* - * Either move the entire list or walk the list to find the last - * block to move. - */ - - n = bucketInfo[bucket].numMove; - if (n >= sharedPtr->buckets[bucket].numFree) { - cachePtr->buckets[bucket].firstPtr = - sharedPtr->buckets[bucket].firstPtr; - cachePtr->buckets[bucket].numFree = - sharedPtr->buckets[bucket].numFree; - sharedPtr->buckets[bucket].firstPtr = NULL; - sharedPtr->buckets[bucket].numFree = 0; - } else { - blockPtr = sharedPtr->buckets[bucket].firstPtr; - cachePtr->buckets[bucket].firstPtr = blockPtr; - sharedPtr->buckets[bucket].numFree -= n; - cachePtr->buckets[bucket].numFree = n; - while (--n > 0) { - blockPtr = blockPtr->nextBlock; - } - sharedPtr->buckets[bucket].firstPtr = blockPtr->nextBlock; - blockPtr->nextBlock = NULL; - } - } - UnlockBucket(cachePtr, bucket); - } - - if (cachePtr->buckets[bucket].numFree == 0) { - register size_t size; - - /* - * If no blocks could be moved from shared, first look for a larger - * block in this cache to split up. - */ - - blockPtr = NULL; - n = NBUCKETS; - size = 0; /* lint */ - while (--n > bucket) { - if (cachePtr->buckets[n].numFree > 0) { - size = bucketInfo[n].blockSize; - blockPtr = cachePtr->buckets[n].firstPtr; - cachePtr->buckets[n].firstPtr = blockPtr->nextBlock; - cachePtr->buckets[n].numFree--; - break; - } - } - - /* - * Otherwise, allocate a big new block directly. - */ - - if (blockPtr == NULL) { - size = MAXALLOC; - blockPtr = malloc(size); - if (blockPtr == NULL) { - return 0; - } - } - - /* - * Split the larger block into smaller blocks for this bucket. - */ - - n = size / bucketInfo[bucket].blockSize; - cachePtr->buckets[bucket].numFree = n; - cachePtr->buckets[bucket].firstPtr = blockPtr; - while (--n > 0) { - blockPtr->nextBlock = (Block *) - ((char *) blockPtr + bucketInfo[bucket].blockSize); - blockPtr = blockPtr->nextBlock; - } - blockPtr->nextBlock = NULL; - } - return 1; -} - -/* - *---------------------------------------------------------------------- - * - * TclFinalizeThreadAlloc -- - * - * This procedure is used to destroy all private resources used in this - * file. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void -TclFinalizeThreadAlloc(void) -{ - unsigned int i; - - for (i = 0; i < NBUCKETS; ++i) { - TclpFreeAllocMutex(bucketInfo[i].lockPtr); - bucketInfo[i].lockPtr = NULL; - } - - TclpFreeAllocMutex(objLockPtr); - objLockPtr = NULL; - - TclpFreeAllocMutex(listLockPtr); - listLockPtr = NULL; - - TclpFreeAllocCache(NULL); -} - -#else /* !(TCL_THREADS && USE_THREAD_ALLOC) */ -/* - *---------------------------------------------------------------------- - * - * Tcl_GetMemoryInfo -- - * - * Return a list-of-lists of memory stats. - * - * Results: - * None. - * - * Side effects: - * List appended to given dstring. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_GetMemoryInfo( - Tcl_DString *dsPtr) -{ - Tcl_Panic("Tcl_GetMemoryInfo called when threaded memory allocator not in use"); -} - -/* - *---------------------------------------------------------------------- - * - * TclFinalizeThreadAlloc -- - * - * This procedure is used to destroy all private resources used in this - * file. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void -TclFinalizeThreadAlloc(void) -{ - Tcl_Panic("TclFinalizeThreadAlloc called when threaded memory allocator not in use"); -} -#endif /* TCL_THREADS && USE_THREAD_ALLOC */ - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ diff --git a/generic/tclTomMathStubLib.c b/generic/tclTomMathStubLib.c index 324f2a3..a3bc4b3 100644 --- a/generic/tclTomMathStubLib.c +++ b/generic/tclTomMathStubLib.c @@ -11,6 +11,15 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ +/* + * We need to ensure that we use the stub macros so that this file contains no + * references to any of the stub functions. This will make it possible to + * build an extension that references Tcl_InitStubs but doesn't end up + * including the rest of the stub functions. + */ + +#define USE_TCL_STUBS + #include "tclInt.h" MODULE_SCOPE const TclTomMathStubs *tclTomMathStubsPtr; @@ -46,30 +55,31 @@ TclTomMathInitializeStubs( int exact = 0; const char *packageName = "tcl::tommath"; const char *errMsg = NULL; - TclTomMathStubs *stubsPtr = NULL; - const char *actualVersion = tclStubsPtr->tcl_PkgRequireEx(interp, - packageName, version, exact, &stubsPtr); + ClientData pkgClientData = NULL; + const char *actualVersion = + Tcl_PkgRequireEx(interp, packageName, version, exact, &pkgClientData); + const TclTomMathStubs *stubsPtr = pkgClientData; if (actualVersion == NULL) { return NULL; } - if (stubsPtr == NULL) { + if (pkgClientData == NULL) { errMsg = "missing stub table pointer"; - } else if(stubsPtr->tclBN_epoch() != epoch) { + } else if ((stubsPtr->tclBN_epoch)() != epoch) { errMsg = "epoch number mismatch"; - } else if(stubsPtr->tclBN_revision() != revision) { + } else if ((stubsPtr->tclBN_revision)() != revision) { errMsg = "requires a later revision"; } else { tclTomMathStubsPtr = stubsPtr; return actualVersion; } - tclStubsPtr->tcl_ResetResult(interp); - tclStubsPtr->tcl_AppendResult(interp, "Error loading ", packageName, - " (requested version ", version, ", actual version ", - actualVersion, "): ", errMsg, NULL); + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error loading %s (requested version %s, actual version %s): %s", + packageName, version, actualVersion, errMsg)); return NULL; } - + /* * Local Variables: * mode: c diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 519f201..4157c43 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -1131,10 +1131,6 @@ Tcl_TraceCommand( * Bug 3484621: up the interp's epoch if this is a BC'ed command */ - if ((cmdPtr->compileProc != NULL) && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES)){ - Interp *iPtr = (Interp *) interp; - iPtr->compileEpoch++; - } cmdPtr->flags |= CMD_HAS_EXEC_TRACES; } @@ -1241,15 +1237,6 @@ Tcl_UntraceCommand( */ cmdPtr->flags &= ~CMD_HAS_EXEC_TRACES; - - /* - * Bug 3484621: up the interp's epoch if this is a BC'ed command - */ - - if (cmdPtr->compileProc != NULL) { - Interp *iPtr = (Interp *) interp; - iPtr->compileEpoch++; - } } } @@ -1679,7 +1666,7 @@ CallTraceFunction( * Copy the command characters into a new string. */ - commandCopy = TclStackAlloc(interp, (unsigned) numChars + 1); + commandCopy = ckalloc((unsigned) numChars + 1); memcpy(commandCopy, command, (size_t) numChars); commandCopy[numChars] = '\0'; @@ -1690,7 +1677,7 @@ CallTraceFunction( traceCode = tracePtr->proc(tracePtr->clientData, (Tcl_Interp *) iPtr, iPtr->numLevels, commandCopy, (Tcl_Command) cmdPtr, objc, objv); - TclStackFree(interp, commandCopy); + ckfree(commandCopy); return traceCode; } @@ -2142,24 +2129,6 @@ Tcl_CreateObjTrace( * Test if this trace allows inline compilation of commands. */ - if (!(flags & TCL_ALLOW_INLINE_COMPILATION)) { - if (iPtr->tracesForbiddingInline == 0) { - /* - * When the first trace forbidding inline compilation is created, - * invalidate existing compiled code for this interpreter and - * arrange (by setting the DONT_COMPILE_CMDS_INLINE flag) that - * when compiling new code, no commands will be compiled inline - * (i.e., into an inline sequence of instructions). We do this - * because commands that were compiled inline will never result in - * a command trace being called. - */ - - iPtr->compileEpoch++; - iPtr->flags |= DONT_COMPILE_CMDS_INLINE; - } - iPtr->tracesForbiddingInline++; - } - tracePtr = ckalloc(sizeof(Trace)); tracePtr->level = level; tracePtr->proc = proc; @@ -2267,7 +2236,7 @@ StringTraceProc( * which uses strings for everything. */ - argv = (const char **) TclStackAlloc(interp, + argv = (const char **) ckalloc( (unsigned) ((objc + 1) * sizeof(const char *))); for (i = 0; i < objc; i++) { argv[i] = Tcl_GetString(objv[i]); @@ -2282,7 +2251,7 @@ StringTraceProc( data->proc(data->clientData, interp, level, (char *) command, cmdPtr->proc, cmdPtr->clientData, objc, argv); - TclStackFree(interp, (void *) argv); + ckfree((void *) argv); return TCL_OK; } @@ -2371,21 +2340,6 @@ Tcl_DeleteTrace( } /* - * If the trace forbids bytecode compilation, change the interpreter's - * state. If bytecode compilation is now permitted, flag the fact and - * advance the compilation epoch so that procs will be recompiled to take - * advantage of it. - */ - - if (!(tracePtr->flags & TCL_ALLOW_INLINE_COMPILATION)) { - iPtr->tracesForbiddingInline--; - if (iPtr->tracesForbiddingInline == 0) { - iPtr->flags &= ~DONT_COMPILE_CMDS_INLINE; - iPtr->compileEpoch++; - } - } - - /* * Execute any delete callback. */ diff --git a/generic/tclVar.c b/generic/tclVar.c index e21f6e4..f7a1966 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -4214,18 +4214,18 @@ TclInitArrayCmd( Tcl_Interp *interp) /* Current interpreter. */ { static const EnsembleImplMap arrayImplMap[] = { - {"anymore", ArrayAnyMoreCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"donesearch", ArrayDoneSearchCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"exists", ArrayExistsCmd, TclCompileArrayExistsCmd, NULL, NULL, 0}, - {"get", ArrayGetCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {"names", ArrayNamesCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, - {"nextelement", ArrayNextElementCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"set", ArraySetCmd, TclCompileArraySetCmd, NULL, NULL, 0}, - {"size", ArraySizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"startsearch", ArrayStartSearchCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"statistics", ArrayStatsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"unset", ArrayUnsetCmd, TclCompileArrayUnsetCmd, NULL, NULL, 0}, - {NULL, NULL, NULL, NULL, NULL, 0} + {"anymore", ArrayAnyMoreCmd, NULL, NULL, 0}, + {"donesearch", ArrayDoneSearchCmd, NULL, NULL, 0}, + {"exists", ArrayExistsCmd, NULL, NULL, 0}, + {"get", ArrayGetCmd, NULL, NULL, 0}, + {"names", ArrayNamesCmd, NULL, NULL, 0}, + {"nextelement", ArrayNextElementCmd, NULL, NULL, 0}, + {"set", ArraySetCmd, NULL, NULL, 0}, + {"size", ArraySizeCmd, NULL, NULL, 0}, + {"startsearch", ArrayStartSearchCmd, NULL, NULL, 0}, + {"statistics", ArrayStatsCmd, NULL, NULL, 0}, + {"unset", ArrayUnsetCmd, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, 0} }; return TclMakeEnsemble(interp, "array", arrayImplMap); diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 9c1176e..8d3e435 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -643,7 +643,6 @@ Tcl_ZlibStreamInit( int e; ZlibStreamHandle *zshPtr = NULL; Tcl_DString cmdname; - Tcl_CmdInfo cmdinfo; GzipHeader *gzHeaderPtr = NULL; switch (mode) { @@ -769,8 +768,7 @@ Tcl_ZlibStreamInit( Tcl_DStringInit(&cmdname); TclDStringAppendLiteral(&cmdname, "::tcl::zlib::streamcmd_"); TclDStringAppendObj(&cmdname, Tcl_GetObjResult(interp)); - if (Tcl_GetCommandInfo(interp, Tcl_DStringValue(&cmdname), - &cmdinfo) == 1) { + if (Tcl_FindCommand(interp, Tcl_DStringValue(&cmdname), NULL, /*flags*/ 0)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "BUG: Stream command name already exists", -1)); Tcl_SetErrorCode(interp, "TCL", "BUG", "EXISTING_CMD", NULL); diff --git a/tests/assemble.test b/tests/assemble.test deleted file mode 100644 index 7d4e5d1..0000000 --- a/tests/assemble.test +++ /dev/null @@ -1,3293 +0,0 @@ -# assemble.test -- -# -# Test suite for the 'tcl::unsupported::assemble' command -# -# Copyright (c) 2010 by Ozgur Dogan Ugurlu. -# Copyright (c) 2010 by Kevin B. Kenny. -# -# See the file "license.terms" for information on usage and redistribution of -# this file, and for a DISCLAIMER OF ALL WARRANTIES. -#----------------------------------------------------------------------------- - -# Commands covered: assemble - -if {"::tcltest" ni [namespace children]} { - package require tcltest 2.2 - namespace import -force ::tcltest::* -} -namespace eval tcl::unsupported {namespace export assemble} -namespace import tcl::unsupported::assemble - -# Procedure to make code that fills the literal and local variable tables, to -# force instructions to spill to four bytes. - -proc fillTables {} { - set s {} - set sep {} - for {set i 0} {$i < 256} {incr i} { - append s $sep [list set v$i literal$i] - set sep \n - } - return $s -} - -testConstraint memory [llength [info commands memory]] -if {[testConstraint memory]} { - proc getbytes {} { - set lines [split [memory info] \n] - return [lindex $lines 3 3] - } - proc leaktest {script {iterations 3}} { - set end [getbytes] - for {set i 0} {$i < $iterations} {incr i} { - uplevel 1 $script - set tmp $end - set end [getbytes] - } - return [expr {$end - $tmp}] - } -} - -# assemble-1 - TclNRAssembleObjCmd - -test assemble-1.1 {wrong # args, direct eval} { - -body { - eval [list assemble] - } - -returnCodes error - -result {wrong # args*} - -match glob -} -test assemble-1.2 {wrong # args, direct eval} { - -body { - eval [list assemble too many] - } - -returnCodes error - -result {wrong # args*} - -match glob -} -test assemble-1.3 {error reporting, direct eval} { - -body { - list [catch { - eval [list assemble { - # bad opcode - rubbish - }] - } result] $result $errorInfo - } - -match glob - -result {1 {bad instruction "rubbish":*} {bad instruction "rubbish":* - while executing -"rubbish" - ("assemble" body, line 3)*}} - -cleanup {unset result} -} -test assemble-1.4 {simple direct eval} { - -body { - eval [list assemble {push {this is a test}}] - } - -result {this is a test} -} - -# assemble-2 - CompileAssembleObj - -test assemble-2.1 {bytecode reuse, direct eval} { - -body { - set x {push "this is a test"} - list [eval [list assemble $x]] \ - [eval [list assemble $x]] - } - -result {{this is a test} {this is a test}} -} -test assemble-2.2 {bytecode discard, direct eval} { - -body { - set x {load value} - proc p1 {x} { - set value value1 - assemble $x - } - proc p2 {x} { - set a b - set value value2 - assemble $x - } - list [p1 $x] [p2 $x] - } - -result {value1 value2} - -cleanup { - unset x - rename p1 {} - rename p2 {} - } -} -test assemble-2.3 {null script, direct eval} { - -body { - set x {} - assemble $x - } - -result {} - -cleanup {unset x} -} - -# assemble-3 - TclCompileAssembleCmd - -test assemble-3.1 {wrong # args, compiled path} { - -body { - proc x {} { - assemble - } - x - } - -returnCodes error - -match glob - -result {wrong # args:*} -} -test assemble-3.2 {wrong # args, compiled path} { - -body { - proc x {} { - assemble too many - } - x - } - -returnCodes error - -match glob - -result {wrong # args:*} - -cleanup { - rename x {} - } -} - -# assemble-4 - TclAssembleCode mainline - -test assemble-4.1 {syntax error} { - -body { - proc x {} { - assemble { - {}extra - } - } - list [catch x result] $result $::errorInfo - } - -cleanup { - rename x {} - unset result - } - -match glob - -result {1 {extra characters after close-brace} {extra characters after close-brace - while executing -"{}extra - " - ("assemble" body, line 2)*}} -} -test assemble-4.2 {null command} { - -body { - proc x {} { - assemble { - push hello; pop;;push goodbye - } - } - x - } - -result goodbye - -cleanup { - rename x {} - } -} - -# assemble-5 - GetNextOperand off-nominal cases - -test assemble-5.1 {unsupported expansion} { - -body { - proc x {y} { - assemble { - {*}$y - } - } - list [catch {x {push hello}} result] $result $::errorCode - } - -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} - -cleanup { - rename x {} - unset result - } -} -test assemble-5.2 {unsupported substitution} { - -body { - proc x {y} { - assemble { - $y - } - } - list [catch {x {nop}} result] $result $::errorCode - } - -cleanup { - rename x {} - unset result - } - -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} -} -test assemble-5.3 {unsupported substitution} { - -body { - proc x {} { - assemble { - [x] - } - } - list [catch {x} result] $result $::errorCode - } - -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} -} -test assemble-5.4 {backslash substitution} { - -body { - proc x {} { - assemble { - p\x75sh\ - hello\ world - } - } - x - } - -cleanup { - rename x {} - } - -result {hello world} -} - -# assemble-6 - ASSEM_PUSH - -test assemble-6.1 {push, wrong # args} { - -body { - assemble push - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-6.2 {push, wrong # args} { - -body { - assemble {push too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-6.3 {push} { - -body { - eval [list assemble {push hello}] - } - -result hello -} -test assemble-6.4 {push4} { - -body { - proc x {} " - [fillTables] - assemble {push hello} - " - x - } - -cleanup { - rename x {} - } - -result hello -} - -# assemble-7 - ASSEM_1BYTE - -test assemble-7.1 {add, wrong # args} { - -body { - assemble {add excess} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-7.2 {add} { - -body { - assemble { - push 2 - push 2 - add - } - } - -result {4} -} -test assemble-7.3 {appendArrayStk} { - -body { - set a(b) {hello, } - assemble { - push a - push b - push world - appendArrayStk - } - set a(b) - } - -result {hello, world} - -cleanup {unset a} -} -test assemble-7.4 {appendStk} { - -body { - set a {hello, } - assemble { - push a - push world - appendStk - } - set a - } - -result {hello, world} - -cleanup {unset a} -} -test assemble-7.5 {bitwise ops} { - -body { - list \ - [assemble {push 0b1100; push 0b1010; bitand}] \ - [assemble {push 0b1100; bitnot}] \ - [assemble {push 0b1100; push 0b1010; bitor}] \ - [assemble {push 0b1100; push 0b1010; bitxor}] - } - -result {8 -13 14 6} -} -test assemble-7.6 {div} { - -body { - assemble {push 999999; push 7; div} - } - -result 142857 -} -test assemble-7.7 {dup} { - -body { - assemble { - push 1; dup; dup; add; dup; add; dup; add; add - } - } - -result 9 -} -test assemble-7.8 {eq} { - -body { - list \ - [assemble {push able; push baker; eq}] \ - [assemble {push able; push able; eq}] - } - -result {0 1} -} -test assemble-7.9 {evalStk} { - -body { - assemble { - push {concat test 7.3} - evalStk - } - } - -result {test 7.3} -} -test assemble-7.9a {evalStk, syntax} { - -body { - assemble { - push {{}bad} - evalStk - } - } - -returnCodes error - -result {extra characters after close-brace} -} -test assemble-7.9b {evalStk, backtrace} { - -body { - proc y {z} { - error testing - } - proc x {} { - assemble { - push { - # test error in evalStk - y asd - } - evalStk - } - } - list [catch x result] $result $errorInfo - } - -result {1 testing {testing - while executing -"error testing" - (procedure "y" line 2) - invoked from within -"y asd"*}} - -match glob - -cleanup { - rename y {} - rename x {} - } -} -test assemble-7.10 {existArrayStk} { - -body { - proc x {name key} { - set a(b) c - assemble { - load name; load key; existArrayStk - } - } - list [x a a] [x a b] [x b a] [x b b] - } - -result {0 1 0 0} - -cleanup {rename x {}} -} -test assemble-7.11 {existStk} { - -body { - proc x {name} { - set a b - assemble { - load name; existStk - } - } - list [x a] [x b] - } - -result {1 0} - -cleanup {rename x {}} -} -test assemble-7.12 {expon} { - -body { - assemble {push 3; push 4; expon} - } - -result 81 -} -test assemble-7.13 {exprStk} { - -body { - assemble { - push {acos(-1)} - exprStk - } - } - -result 3.141592653589793 -} -test assemble-7.13a {exprStk, syntax} { - -body { - assemble { - push {2+} - exprStk - } - } - -returnCodes error - -result {missing operand at _@_ -in expression "2+_@_"} -} -test assemble-7.13b {exprStk, backtrace} { - -body { - proc y {z} { - error testing - } - proc x {} { - assemble { - push {[y asd]} - exprStk - } - } - list [catch x result] $result $errorInfo - } - -result {1 testing {testing - while executing -"error testing" - (procedure "y" line 2) - invoked from within -"y asd"*}} - -match glob - -cleanup { - rename y {} - rename x {} - } -} -test assemble-7.14 {ge gt le lt} { - -body { - proc x {a b} { - list [assemble {load a; load b; ge}] \ - [assemble {load a; load b; gt}] \ - [assemble {load a; load b; le}] \ - [assemble {load a; load b; lt}] - } - list [x 0 0] [x 0 1] [x 1 0] - } - -result {{1 0 1 0} {0 0 1 1} {1 1 0 0}} - -cleanup {rename x {}} -} -test assemble-7.15 {incrArrayStk} { - -body { - proc x {} { - set a(b) 5 - assemble { - push a; push b; push 7; incrArrayStk - } - } - x - } - -result 12 - -cleanup {rename x {}} -} -test assemble-7.16 {incrStk} { - -body { - proc x {} { - set a 5 - assemble { - push a; push 7; incrStk - } - } - x - } - -result 12 - -cleanup {rename x {}} -} -test assemble-7.17 {land/lor} { - -body { - proc x {a b} { - list \ - [assemble {load a; load b; land}] \ - [assemble {load a; load b; lor}] - } - list [x 0 0] [x 0 23] [x 35 0] [x 47 59] - } - -result {{0 0} {0 1} {0 1} {1 1}} - -cleanup {rename x {}} -} -test assemble-7.18 {lappendArrayStk} { - -body { - proc x {} { - set able(baker) charlie - assemble { - push able - push baker - push dog - lappendArrayStk - } - } - x - } - -result {charlie dog} - -cleanup {rename x {}} -} -test assemble-7.19 {lappendStk} { - -body { - proc x {} { - set able baker - assemble { - push able - push charlie - lappendStk - } - } - x - } - -result {baker charlie} - -cleanup {rename x {}} -} -test assemble-7.20 {listIndex} { - -body { - assemble { - push {a b c d} - push 2 - listIndex - } - } - -result c -} -test assemble-7.21 {listLength} { - -body { - assemble { - push {a b c d} - listLength - } - } - -result 4 -} -test assemble-7.22 {loadArrayStk} { - -body { - proc x {} { - set able(baker) charlie - assemble { - push able - push baker - loadArrayStk - } - } - x - } - -result charlie - -cleanup {rename x {}} -} -test assemble-7.23 {loadStk} { - -body { - proc x {} { - set able baker - assemble { - push able - loadStk - } - } - x - } - -result baker - -cleanup {rename x {}} -} -test assemble-7.24 {lsetList} { - -body { - proc x {} { - set l {{a b} {c d} {e f} {g h}} - assemble { - push {2 1}; push i; load l; lsetList - } - } - x - } - -result {{a b} {c d} {e i} {g h}} -} -test assemble-7.25 {lshift} { - -body { - assemble {push 16; push 4; lshift} - } - -result 256 -} -test assemble-7.26 {mod} { - -body { - assemble {push 123456; push 1000; mod} - } - -result 456 -} -test assemble-7.27 {mult} { - -body { - assemble {push 12345679; push 9; mult} - } - -result 111111111 -} -test assemble-7.28 {neq} { - -body { - list \ - [assemble {push able; push baker; neq}] \ - [assemble {push able; push able; neq}] - } - -result {1 0} -} -test assemble-7.29 {not} { - -body { - list \ - [assemble {push 17; not}] \ - [assemble {push 0; not}] - } - -result {0 1} -} -test assemble-7.30 {pop} { - -body { - assemble {push this; pop; push that} - } - -result that -} -test assemble-7.31 {rshift} { - -body { - assemble {push 257; push 4; rshift} - } - -result 16 -} -test assemble-7.32 {storeArrayStk} { - -body { - proc x {} { - assemble { - push able; push baker; push charlie; storeArrayStk - } - array get able - } - x - } - -result {baker charlie} - -cleanup {rename x {}} -} -test assemble-7.33 {storeStk} { - -body { - proc x {} { - assemble { - push able; push baker; storeStk - } - set able - } - x - } - -result {baker} - -cleanup {rename x {}} -} -test assemble-7,34 {strcmp} { - -body { - proc x {a b} { - assemble { - load a; load b; strcmp - } - } - list [x able baker] [x baker able] [x baker baker] - } - -result {-1 1 0} - -cleanup {rename x {}} -} -test assemble-7.35 {streq/strneq} { - -body { - proc x {a b} { - list \ - [assemble {load a; load b; streq}] \ - [assemble {load a; load b; strneq}] - } - list [x able able] [x able baker] - } - -result {{1 0} {0 1}} - -cleanup {rename x {}} -} -test assemble-7.36 {strindex} { - -body { - assemble {push testing; push 4; strindex} - } - -result i -} -test assemble-7.37 {strlen} { - -body { - assemble {push testing; strlen} - } - -result 7 -} -test assemble-7.38 {sub} { - -body { - assemble {push 42; push 17; sub} - } - -result 25 -} -test assemble-7.39 {tryCvtToNumeric} { - -body { - assemble { - push 42; tryCvtToNumeric - } - } - -result 42 -} -# assemble-7.40 absent -test assemble-7.41 {uminus} { - -body { - assemble { - push 42; uminus - } - } - -result -42 -} -test assemble-7.42 {uplus} { - -body { - assemble { - push 42; uplus - } - } - -result 42 -} -test assemble-7.43 {uplus} { - -body { - assemble { - push NaN; uplus - } - } - -returnCodes error - -result {can't use non-numeric floating-point value as operand of "+"} -} -test assemble-7.43.1 {tryCvtToNumeric} { - -body { - assemble { - push NaN; tryCvtToNumeric - } - } - -returnCodes error - -result {domain error: argument not in valid range} -} -test assemble-7.44 {listIn} { - -body { - assemble { - push b; push {a b c}; listIn - } - } - -result 1 -} -test assemble-7.45 {listNotIn} { - -body { - assemble { - push d; push {a b c}; listNotIn - } - } - -result 1 -} -test assemble-7.46 {nop} { - -body { - assemble { push x; nop; nop; nop} - } - -result x -} - -# assemble-8 ASSEM_LVT and FindLocalVar - -test assemble-8.1 {load, wrong # args} { - -body { - assemble load - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-8.2 {load, wrong # args} { - -body { - assemble {load too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-8.3 {nonlocal var} { - -body { - list [catch {assemble {load ::env}} result] $result $errorCode - } - -result {1 {variable "::env" is not local} {TCL ASSEM NONLOCAL ::env}} - -cleanup {unset result} -} -test assemble-8.4 {bad context} { - -body { - set x 1 - list [catch {assemble {load x}} result] $result $errorCode - } - -result {1 {cannot use this instruction to create a variable in a non-proc context} {TCL ASSEM LVT}} - -cleanup {unset result} -} -test assemble-8.5 {bad context} { - -body { - namespace eval assem { - set x 1 - list [catch {assemble {load x}} result] $result $errorCode - } - } - -result {1 {cannot use this instruction to create a variable in a non-proc context} {TCL ASSEM LVT}} - -cleanup {namespace delete assem} -} -test assemble-8.6 {load1} { - -body { - proc x {a} { - assemble { - load a - } - } - x able - } - -result able - -cleanup {rename x {}} -} -test assemble-8.7 {load4} { - -body { - proc x {a} " - [fillTables] - set b \$a - assemble {load b} - " - x able - } - -result able - -cleanup {rename x {}} -} -test assemble-8.8 {loadArray1} { - -body { - proc x {} { - set able(baker) charlie - assemble { - push baker - loadArray able - } - } - x - } - -result charlie - -cleanup {rename x {}} -} -test assemble-8.9 {loadArray4} { - -body " - proc x {} { - [fillTables] - set able(baker) charlie - assemble { - push baker - loadArray able - } - } - x - " - -result charlie - -cleanup {rename x {}} -} -test assemble-8.10 {append1} { - -body { - proc x {} { - set y {hello, } - assemble { - push world; append y - } - } - x - } - -result {hello, world} - -cleanup {rename x {}} -} -test assemble-8.11 {append4} { - -body { - proc x {} " - [fillTables] - set y {hello, } - assemble { - push world; append y - } - " - x - } - -result {hello, world} - -cleanup {rename x {}} -} -test assemble-8.12 {appendArray1} { - -body { - proc x {} { - set y(z) {hello, } - assemble { - push z; push world; appendArray y - } - } - x - } - -result {hello, world} - -cleanup {rename x {}} -} -test assemble-8.13 {appendArray4} { - -body { - proc x {} " - [fillTables] - set y(z) {hello, } - assemble { - push z; push world; appendArray y - } - " - x - } - -result {hello, world} - -cleanup {rename x {}} -} -test assemble-8.14 {lappend1} { - -body { - proc x {} { - set y {hello,} - assemble { - push world; lappend y - } - } - x - } - -result {hello, world} - -cleanup {rename x {}} -} -test assemble-8.15 {lappend4} { - -body { - proc x {} " - [fillTables] - set y {hello,} - assemble { - push world; lappend y - } - " - x - } - -result {hello, world} - -cleanup {rename x {}} -} -test assemble-8.16 {lappendArray1} { - -body { - proc x {} { - set y(z) {hello,} - assemble { - push z; push world; lappendArray y - } - } - x - } - -result {hello, world} - -cleanup {rename x {}} -} -test assemble-8.17 {lappendArray4} { - -body { - proc x {} " - [fillTables] - set y(z) {hello,} - assemble { - push z; push world; lappendArray y - } - " - x - } - -result {hello, world} - -cleanup {rename x {}} -} -test assemble-8.18 {store1} { - -body { - proc x {} { - assemble { - push test; store y - } - set y - } - x - } - -result {test} - -cleanup {rename x {}} -} -test assemble-8.19 {store4} { - -body { - proc x {} " - [fillTables] - assemble { - push test; store y - } - set y - " - x - } - -result test - -cleanup {rename x {}} -} -test assemble-8.20 {storeArray1} { - -body { - proc x {} { - assemble { - push z; push test; storeArray y - } - set y(z) - } - x - } - -result test - -cleanup {rename x {}} -} -test assemble-8.21 {storeArray4} { - -body { - proc x {} " - [fillTables] - assemble { - push z; push test; storeArray y - } - " - x - } - -result test - -cleanup {rename x {}} -} - -# assemble-9 - ASSEM_CONCAT1, GetIntegerOperand, CheckOneByte - -test assemble-9.1 {wrong # args} { - -body {assemble concat} - -result {wrong # args*} - -match glob - -returnCodes error -} -test assemble-9.2 {wrong # args} { - -body {assemble {concat too many}} - -result {wrong # args*} - -match glob - -returnCodes error -} -test assemble-9.3 {not a number} { - -body {assemble {concat rubbish}} - -result {expected integer but got "rubbish"} - -returnCodes error -} -test assemble-9.4 {too small} { - -body {assemble {concat -1}} - -result {operand does not fit in one byte} - -returnCodes error -} -test assemble-9.5 {too small} { - -body {assemble {concat 256}} - -result {operand does not fit in one byte} - -returnCodes error -} -test assemble-9.6 {concat} { - -body { - assemble {push h; push e; push l; push l; push o; concat 5} - } - -result hello -} -test assemble-9.7 {concat} { - -body { - list [catch {assemble {concat 0}} result] $result $::errorCode - } - -result {1 {operand must be positive} {TCL ASSEM POSITIVE}} - -cleanup {unset result} -} - -# assemble-10 -- eval and expr - -test assemble-10.1 {eval - wrong # args} { - -body { - assemble {eval} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-10.2 {eval - wrong # args} { - -body { - assemble {eval too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-10.3 {eval} { - -body { - proc x {} { - assemble { - push 3 - store n - pop - eval {expr {3*$n + 1}} - push 1 - add - } - } - x - } - -result 11 - -cleanup {rename x {}} -} -test assemble-10.4 {expr} { - -body { - proc x {} { - assemble { - push 3 - store n - pop - expr {3*$n + 1} - push 1 - add - } - } - x - } - -result 11 - -cleanup {rename x {}} -} -test assemble-10.5 {eval and expr - nonsimple} { - -body { - proc x {} { - assemble { - eval "s\x65t n 3" - pop - expr "\x33*\$n + 1" - push 1 - add - } - } - x - } - -result 11 - -cleanup { - rename x {} - } -} -test assemble-10.6 {eval - noncompilable} { - -body { - list [catch {assemble {eval $x}} result] $result $::errorCode - } - -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} -} -test assemble-10.7 {expr - noncompilable} { - -body { - list [catch {assemble {expr $x}} result] $result $::errorCode - } - -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} -} - -# assemble-11 - ASSEM_LVT4 (exist, existArray, dictAppend, dictLappend, -# nsupvar, variable, upvar) - -test assemble-11.1 {exist - wrong # args} { - -body { - assemble {exist} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-11.2 {exist - wrong # args} { - -body { - assemble {exist too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-11.3 {nonlocal var} { - -body { - list [catch {assemble {exist ::env}} result] $result $errorCode - } - -result {1 {variable "::env" is not local} {TCL ASSEM NONLOCAL ::env}} - -cleanup {unset result} -} -test assemble-11.4 {exist} { - -body { - proc x {} { - set y z - list [assemble {exist y}] \ - [assemble {exist z}] - } - x - } - -result {1 0} - -cleanup {rename x {}} -} -test assemble-11.5 {existArray} { - -body { - proc x {} { - set a(b) c - list [assemble {push b; existArray a}] \ - [assemble {push c; existArray a}] \ - [assemble {push a; existArray b}] - } - x - } - -result {1 0 0} - -cleanup {rename x {}} -} -test assemble-11.6 {dictAppend} { - -body { - proc x {} { - set dict {a 1 b 2 c 3} - assemble {push b; push 22; dictAppend dict} - } - x - } - -result {a 1 b 222 c 3} - -cleanup {rename x {}} -} -test assemble-11.7 {dictLappend} { - -body { - proc x {} { - set dict {a 1 b 2 c 3} - assemble {push b; push 2; dictLappend dict} - } - x - } - -result {a 1 b {2 2} c 3} - -cleanup {rename x {}} -} -test assemble-11.8 {upvar} { - -body { - proc x {v} { - assemble {push 1; load v; upvar w; pop; load w} - } - proc y {} { - set z 123 - x z - } - y - } - -result 123 - -cleanup {rename x {}; rename y {}} -} -test assemble-11.9 {nsupvar} { - -body { - namespace eval q { variable v 123 } - proc x {} { - assemble {push q; push v; nsupvar y; pop; load y} - } - x - } - -result 123 - -cleanup {namespace delete q; rename x {}} -} -test assemble-11.10 {variable} { - -body { - namespace eval q { namespace eval r {variable v 123}} - proc x {} { - assemble {push q::r::v; variable y; load y} - } - x - } - -result 123 - -cleanup {namespace delete q; rename x {}} -} - -# assemble-12 - ASSEM_LVT1 (incr and incrArray) - -test assemble-12.1 {incr - wrong # args} { - -body { - assemble {incr} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-12.2 {incr - wrong # args} { - -body { - assemble {incr too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-12.3 {incr nonlocal var} { - -body { - list [catch {assemble {incr ::env}} result] $result $errorCode - } - -result {1 {variable "::env" is not local} {TCL ASSEM NONLOCAL ::env}} - -cleanup {unset result} -} -test assemble-12.4 {incr} { - -body { - proc x {} { - set y 5 - assemble {push 3; incr y} - } - x - } - -result 8 - -cleanup {rename x {}} -} -test assemble-12.5 {incrArray} { - -body { - proc x {} { - set a(b) 5 - assemble {push b; push 3; incrArray a} - } - x - } - -result 8 - -cleanup {rename x {}} -} -test assemble-12.6 {incr, stupid stack restriction} { - -body { - proc x {} " - [fillTables] - set y 5 - assemble {push 3; incr y} - " - list [catch {x} result] $result $errorCode - } - -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}} - -cleanup {unset result; rename x {}} -} - -# assemble-13 -- ASSEM_LVT1_SINT1 - incrImm and incrArrayImm - -test assemble-13.1 {incrImm - wrong # args} { - -body { - assemble {incrImm x} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-13.2 {incrImm - wrong # args} { - -body { - assemble {incrImm too many args} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-13.3 {incrImm nonlocal var} { - -body { - list [catch {assemble {incrImm ::env 2}} result] $result $errorCode - } - -result {1 {variable "::env" is not local} {TCL ASSEM NONLOCAL ::env}} - -cleanup {unset result} -} -test assemble-13.4 {incrImm not a number} { - -body { - proc x {} { - assemble {incrImm x rubbish} - } - x - } - -returnCodes error - -result {expected integer but got "rubbish"} - -cleanup {rename x {}} -} -test assemble-13.5 {incrImm too big} { - -body { - proc x {} { - assemble {incrImm x 0x80} - } - list [catch x result] $result $::errorCode - } - -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}} - -cleanup {rename x {}; unset result} -} -test assemble-13.6 {incrImm too small} { - -body { - proc x {} { - assemble {incrImm x -0x81} - } - list [catch x result] $result $::errorCode - } - -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}} - -cleanup {rename x {}; unset result} -} -test assemble-13.7 {incrImm} { - -body { - proc x {} { - set y 1 - list [assemble {incrImm y -0x80}] [assemble {incrImm y 0x7f}] - } - x - } - -result {-127 0} - -cleanup {rename x {}} -} -test assemble-13.8 {incrArrayImm} { - -body { - proc x {} { - set a(b) 5 - assemble {push b; incrArrayImm a 3} - } - x - } - -result 8 - -cleanup {rename x {}} -} -test assemble-13.9 {incrImm, stupid stack restriction} { - -body { - proc x {} " - [fillTables] - set y 5 - assemble {incrImm y 3} - " - list [catch {x} result] $result $errorCode - } - -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}} - -cleanup {unset result; rename x {}} -} - -# assemble-14 -- ASSEM_SINT1 (incrArrayStkImm and incrStkImm) - -test assemble-14.1 {incrStkImm - wrong # args} { - -body { - assemble {incrStkImm} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-14.2 {incrStkImm - wrong # args} { - -body { - assemble {incrStkImm too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-14.3 {incrStkImm not a number} { - -body { - proc x {} { - assemble {incrStkImm rubbish} - } - x - } - -returnCodes error - -result {expected integer but got "rubbish"} - -cleanup {rename x {}} -} -test assemble-14.4 {incrStkImm too big} { - -body { - proc x {} { - assemble {incrStkImm 0x80} - } - list [catch x result] $result $::errorCode - } - -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}} - -cleanup {rename x {}; unset result} -} -test assemble-14.5 {incrStkImm too small} { - -body { - proc x {} { - assemble {incrStkImm -0x81} - } - list [catch x result] $result $::errorCode - } - -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}} - -cleanup {rename x {}; unset result} -} -test assemble-14.6 {incrStkImm} { - -body { - proc x {} { - set y 1 - list [assemble {push y; incrStkImm -0x80}] \ - [assemble {push y; incrStkImm 0x7f}] - } - x - } - -result {-127 0} - -cleanup {rename x {}} -} -test assemble-14.7 {incrArrayStkImm} { - -body { - proc x {} { - set a(b) 5 - assemble {push a; push b; incrArrayStkImm 3} - } - x - } - -result 8 - -cleanup {rename x {}} -} - -# assemble-15 - listIndexImm - -test assemble-15.1 {listIndexImm - wrong # args} { - -body { - assemble {listIndexImm} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-15.2 {listIndexImm - wrong # args} { - -body { - assemble {listIndexImm too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-15.3 {listIndexImm - bad substitution} { - -body { - list [catch {assemble {listIndexImm $foo}} result] $result $::errorCode - } - -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} - -cleanup {unset result} -} -test assemble-15.4 {listIndexImm - invalid index} { - -body { - assemble {listIndexImm rubbish} - } - -returnCodes error - -match glob - -result {bad index "rubbish"*} -} -test assemble-15.5 {listIndexImm} { - -body { - assemble {push {a b c}; listIndexImm 2} - } - -result c -} -test assemble-15.6 {listIndexImm} { - -body { - assemble {push {a b c}; listIndexImm end-1} - } - -result b -} -test assemble-15.7 {listIndexImm} { - -body { - assemble {push {a b c}; listIndexImm end} - } - -result c -} - -# assemble-16 - invokeStk - -test assemble-16.1 {invokeStk - wrong # args} { - -body { - assemble {invokeStk} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-16.2 {invokeStk - wrong # args} { - -body { - assemble {invokeStk too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-16.3 {invokeStk - not a number} { - -body { - proc x {} { - assemble {invokeStk rubbish} - } - x - } - -returnCodes error - -result {expected integer but got "rubbish"} - -cleanup {rename x {}} -} -test assemble-16.4 {invokeStk - no operands} { - -body { - proc x {} { - assemble {invokeStk 0} - } - list [catch x result] $result $::errorCode - } - -result {1 {operand must be positive} {TCL ASSEM POSITIVE}} - -cleanup {rename x {}; unset result} -} -test assemble-16.5 {invokeStk1} { - -body { - tcl::unsupported::assemble {push concat; push 1; push 2; invokeStk 3} - } - -result {1 2} -} -test assemble-16.6 {invokeStk4} { - -body { - proc x {n} { - set code {push concat} - set shouldbe {} - for {set i 1} {$i < $n} {incr i} { - append code \n {push a} $i - lappend shouldbe a$i - } - append code \n {invokeStk} { } $n - set is [assemble $code] - expr {$is eq $shouldbe} - } - list [x 254] [x 255] [x 256] [x 257] - } - -result {1 1 1 1} - -cleanup {rename x {}} -} - -# assemble-17 -- jumps and labels - -test assemble-17.1 {label, wrong # args} { - -body { - assemble {label} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-17.2 {label, wrong # args} { - -body { - assemble {label too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-17.3 {label, bad subst} { - -body { - list [catch {assemble {label $foo}} result] $result $::errorCode - } - -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} - -cleanup {unset result} -} -test assemble-17.4 {duplicate label} { - -body { - list [catch {assemble {label foo; label foo}} result] \ - $result $::errorCode - } - -result {1 {duplicate definition of label "foo"} {TCL ASSEM DUPLABEL foo}} -} -test assemble-17.5 {jump, wrong # args} { - -body { - assemble {jump} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-17.6 {jump, wrong # args} { - -body { - assemble {jump too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-17.7 {jump, bad subst} { - -body { - list [catch {assemble {jump $foo}} result] $result $::errorCode - } - -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} - -cleanup {unset result} -} -test assemble-17.8 {jump - ahead and back} { - -body { - assemble { - jump three - - label one - push a - jump four - - label two - push b - jump six - - label three - push c - jump five - - label four - push d - jump two - - label five - push e - jump one - - label six - push f - concat 6 - } - } - -result ceadbf -} -test assemble-17.9 {jump - resolve a label multiple times} { - -body { - proc x {} { - set case 0 - set result {} - assemble { - jump common - - label zero - pop - incrImm case 1 - pop - push a - append result - pop - jump common - - label one - pop - incrImm case 1 - pop - push b - append result - pop - jump common - - label common - load case - dup - push 0 - eq - jumpTrue zero - dup - push 1 - eq - jumpTrue one - dup - push 2 - eq - jumpTrue two - dup - push 3 - eq - jumpTrue three - - label two - pop - incrImm case 1 - pop - push c - append result - pop - jump common - - label three - pop - incrImm case 1 - pop - push d - append result - } - } - x - } - -result abcd - -cleanup {rename x {}} -} -test assemble-17.10 {jump4 needed} { - -body { - assemble "push x; jump one; label two; [string repeat {dup; pop;} 128] - jump three; label one; jump two; label three" - } - -result x -} -test assemble-17.11 {jumpTrue} { - -body { - proc x {y} { - assemble { - load y - jumpTrue then - push no - jump else - label then - push yes - label else - } - } - list [x 0] [x 1] - } - -result {no yes} - -cleanup {rename x {}} -} -test assemble-17.12 {jumpFalse} { - -body { - proc x {y} { - assemble { - load y - jumpFalse then - push no - jump else - label then - push yes - label else - } - } - list [x 0] [x 1] - } - -result {yes no} - -cleanup {rename x {}} -} -test assemble-17.13 {jump to undefined label} { - -body { - list [catch {assemble {jump nowhere}} result] $result $::errorCode - } - -result {1 {undefined label "nowhere"} {TCL ASSEM NOLABEL nowhere}} -} -test assemble-17.14 {jump to undefined label, line number correct?} { - -body { - catch {assemble {#1 - #2 - #3 - jump nowhere - #5 - #6 - }} - set ::errorInfo - } - -match glob - -result {*"assemble" body, line 4*} -} -test assemble-17.15 {multiple passes of code resizing} { - -setup { - set body { - push - - } - for {set i 0} {$i < 14} {incr i} { - append body "label a" $i \ - "; push a; concat 2; nop; nop; jump b" \ - $i \n - } - append body {label a14; push a; concat 2; push 1; jumpTrue b14} \n - append body {label a15; push a; concat 2; push 0; jumpFalse b15} \n - for {set i 0} {$i < 15} {incr i} { - append body "label b" $i \ - "; push b; concat 2; nop; nop; jump a" \ - [expr {$i+1}] \n - } - append body {label c; push -; concat 2; nop; nop; nop; jump d} \n - append body {label b15; push b; concat 2; nop; nop; jump c} \n - append body {label d} - proc x {} [list assemble $body] - } - -body { - x - } - -cleanup { - catch {unset body} - catch {rename x {}} - } - -result -abababababababababababababababab- -} - -# assemble-18 - lindexMulti - -test assemble-18.1 {lindexMulti - wrong # args} { - -body { - assemble {lindexMulti} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-18.2 {lindexMulti - wrong # args} { - -body { - assemble {lindexMulti too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-18.3 {lindexMulti - bad subst} { - -body { - assemble {lindexMulti $foo} - } - -returnCodes error - -match glob - -result {assembly code may not contain substitutions} -} -test assemble-18.4 {lindexMulti - not a number} { - -body { - proc x {} { - assemble {lindexMulti rubbish} - } - x - } - -returnCodes error - -result {expected integer but got "rubbish"} - -cleanup {rename x {}} -} -test assemble-18.5 {lindexMulti - bad operand count} { - -body { - proc x {} { - assemble {lindexMulti 0} - } - list [catch x result] $result $::errorCode - } - -result {1 {operand must be positive} {TCL ASSEM POSITIVE}} - -cleanup {rename x {}; unset result} -} -test assemble-18.6 {lindexMulti} { - -body { - assemble {push {{a b c} {d e f} {g h j}}; lindexMulti 1} - } - -result {{a b c} {d e f} {g h j}} -} -test assemble-18.7 {lindexMulti} { - -body { - assemble {push {{a b c} {d e f} {g h j}}; push 1; lindexMulti 2} - } - -result {d e f} -} -test assemble-18.8 {lindexMulti} { - -body { - assemble {push {{a b c} {d e f} {g h j}}; push 2; push 1; lindexMulti 3} - } - -result h -} - -# assemble-19 - list - -test assemble-19.1 {list - wrong # args} { - -body { - assemble {list} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-19.2 {list - wrong # args} { - -body { - assemble {list too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-19.3 {list - bad subst} { - -body { - assemble {list $foo} - } - -returnCodes error - -match glob - -result {assembly code may not contain substitutions} -} -test assemble-19.4 {list - not a number} { - -body { - proc x {} { - assemble {list rubbish} - } - x - } - -returnCodes error - -result {expected integer but got "rubbish"} - -cleanup {rename x {}} -} -test assemble-19.5 {list - negative operand count} { - -body { - proc x {} { - assemble {list -1} - } - list [catch x result] $result $::errorCode - } - -result {1 {operand must be nonnegative} {TCL ASSEM NONNEGATIVE}} - -cleanup {rename x {}; unset result} -} -test assemble-19.6 {list - no args} { - -body { - assemble {list 0} - } - -result {} -} -test assemble-19.7 {list - 1 arg} { - -body { - assemble {push hello; list 1} - } - -result hello -} -test assemble-19.8 {list - 2 args} { - -body { - assemble {push hello; push world; list 2} - } - -result {hello world} -} - -# assemble-20 - lsetFlat - -test assemble-20.1 {lsetFlat - wrong # args} { - -body { - assemble {lsetFlat} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-20.2 {lsetFlat - wrong # args} { - -body { - assemble {lsetFlat too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-20.3 {lsetFlat - bad subst} { - -body { - assemble {lsetFlat $foo} - } - -returnCodes error - -match glob - -result {assembly code may not contain substitutions} -} -test assemble-20.4 {lsetFlat - not a number} { - -body { - proc x {} { - assemble {lsetFlat rubbish} - } - x - } - -returnCodes error - -result {expected integer but got "rubbish"} - -cleanup {rename x {}} -} -test assemble-20.5 {lsetFlat - negative operand count} { - -body { - proc x {} { - assemble {lsetFlat 1} - } - list [catch x result] $result $::errorCode - } - -result {1 {operand must be >=2} {TCL ASSEM OPERAND>=2}} - -cleanup {rename x {}; unset result} -} -test assemble-20.6 {lsetFlat} { - -body { - assemble {push b; push a; lsetFlat 2} - } - -result b -} -test assemble-20.7 {lsetFlat} { - -body { - assemble {push 1; push d; push {a b c}; lsetFlat 3} - } - -result {a d c} -} - -# assemble-21 - over - -test assemble-21.1 {over - wrong # args} { - -body { - assemble {over} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-21.2 {over - wrong # args} { - -body { - assemble {over too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-21.3 {over - bad subst} { - -body { - assemble {over $foo} - } - -returnCodes error - -match glob - -result {assembly code may not contain substitutions} -} -test assemble-21.4 {over - not a number} { - -body { - proc x {} { - assemble {over rubbish} - } - x - } - -returnCodes error - -result {expected integer but got "rubbish"} - -cleanup {rename x {}} -} -test assemble-21.5 {over - negative operand count} { - -body { - proc x {} { - assemble {over -1} - } - list [catch x result] $result $::errorCode - } - -result {1 {operand must be nonnegative} {TCL ASSEM NONNEGATIVE}} - -cleanup {rename x {}; unset result} -} -test assemble-21.6 {over} { - -body { - proc x {} { - assemble { - push 1 - push 2 - push 3 - over 0 - store x - pop - pop - pop - pop - load x - } - } - x - } - -result 3 - -cleanup {rename x {}} -} -test assemble-21.7 {over} { - -body { - proc x {} { - assemble { - push 1 - push 2 - push 3 - over 2 - store x - pop - pop - pop - pop - load x - } - } - x - } - -result 1 - -cleanup {rename x {}} -} - -# assemble-22 - reverse - -test assemble-22.1 {reverse - wrong # args} { - -body { - assemble {reverse} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-22.2 {reverse - wrong # args} { - -body { - assemble {reverse too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} - -test assemble-22.3 {reverse - bad subst} { - -body { - assemble {reverse $foo} - } - -returnCodes error - -match glob - -result {assembly code may not contain substitutions} -} - -test assemble-22.4 {reverse - not a number} { - -body { - proc x {} { - assemble {reverse rubbish} - } - x - } - -returnCodes error - -result {expected integer but got "rubbish"} - -cleanup {rename x {}} -} -test assemble-22.5 {reverse - negative operand count} { - -body { - proc x {} { - assemble {reverse -1} - } - list [catch x result] $result $::errorCode - } - -result {1 {operand must be nonnegative} {TCL ASSEM NONNEGATIVE}} - -cleanup {rename x {}; unset result} -} -test assemble-22.6 {reverse - zero operand count} { - -body { - proc x {} { - assemble {push 1; reverse 0} - } - x - } - -result 1 - -cleanup {rename x {}} -} -test assemble-22.7 {reverse} { - -body { - proc x {} { - assemble { - push 1 - push 2 - push 3 - reverse 1 - store x - pop - pop - pop - load x - } - } - x - } - -result 3 - -cleanup {rename x {}} -} -test assemble-22.8 {reverse} { - -body { - proc x {} { - assemble { - push 1 - push 2 - push 3 - reverse 3 - store x - pop - pop - pop - load x - } - } - x - } - -result 1 - -cleanup {rename x {}} -} - -# assemble-23 - ASSEM_BOOL (strmatch, unsetStk, unsetArrayStk) - -test assemble-23.1 {strmatch - wrong # args} { - -body { - assemble {strmatch} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-23.2 {strmatch - wrong # args} { - -body { - assemble {strmatch too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-23.3 {strmatch - bad subst} { - -body { - assemble {strmatch $foo} - } - -returnCodes error - -match glob - -result {assembly code may not contain substitutions} -} -test assemble-23.4 {strmatch - not a boolean} { - -body { - proc x {} { - assemble {strmatch rubbish} - } - x - } - -returnCodes error - -result {expected boolean value but got "rubbish"} - -cleanup {rename x {}} -} -test assemble-23.5 {strmatch} { - -body { - proc x {a b} { - list [assemble {load a; load b; strmatch 0}] \ - [assemble {load a; load b; strmatch 1}] - } - list [x foo*.grill fengbar.grill] [x foo*.grill foobar.grill] [x foo*.grill FOOBAR.GRILL] - } - -result {{0 0} {1 1} {0 1}} - -cleanup {rename x {}} -} -test assemble-23.6 {unsetStk} { - -body { - proc x {} { - set a {} - assemble {push a; unsetStk false} - info exists a - } - x - } - -result 0 - -cleanup {rename x {}} -} -test assemble-23.7 {unsetStk} { - -body { - proc x {} { - assemble {push a; unsetStk false} - info exists a - } - x - } - -result 0 - -cleanup {rename x {}} -} -test assemble-23.8 {unsetStk} { - -body { - proc x {} { - assemble {push a; unsetStk true} - info exists a - } - x - } - -returnCodes error - -result {can't unset "a": no such variable} - -cleanup {rename x {}} -} -test assemble-23.9 {unsetArrayStk} { - -body { - proc x {} { - set a(b) {} - assemble {push a; push b; unsetArrayStk false} - info exists a(b) - } - x - } - -result 0 - -cleanup {rename x {}} -} -test assemble-23.10 {unsetArrayStk} { - -body { - proc x {} { - assemble {push a; push b; unsetArrayStk false} - info exists a(b) - } - x - } - -result 0 - -cleanup {rename x {}} -} -test assemble-23.11 {unsetArrayStk} { - -body { - proc x {} { - assemble {push a; push b; unsetArrayStk true} - info exists a(b) - } - x - } - -returnCodes error - -result {can't unset "a(b)": no such variable} - -cleanup {rename x {}} -} - -# assemble-24 -- ASSEM_BOOL_LVT4 (unset; unsetArray) - -test assemble-24.1 {unset - wrong # args} { - -body { - assemble {unset one} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-24.2 {unset - wrong # args} { - -body { - assemble {unset too many args} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-24.3 {unset - bad subst -arg 1} { - -body { - assemble {unset $foo bar} - } - -returnCodes error - -match glob - -result {assembly code may not contain substitutions} -} -test assemble-24.4 {unset - not a boolean} { - -body { - proc x {} { - assemble {unset rubbish trash} - } - x - } - -returnCodes error - -result {expected boolean value but got "rubbish"} - -cleanup {rename x {}} -} -test assemble-24.5 {unset - bad subst - arg 2} { - -body { - assemble {unset true $bar} - } - -returnCodes error - -result {assembly code may not contain substitutions} -} -test assemble-24.6 {unset - nonlocal var} { - -body { - assemble {unset true ::foo::bar} - } - -returnCodes error - -result {variable "::foo::bar" is not local} -} -test assemble-24.7 {unset} { - -body { - proc x {} { - set a {} - assemble {unset false a} - info exists a - } - x - } - -result 0 - -cleanup {rename x {}} -} -test assemble-24.8 {unset} { - -body { - proc x {} { - assemble {unset false a} - info exists a - } - x - } - -result 0 - -cleanup {rename x {}} -} -test assemble-24.9 {unset} { - -body { - proc x {} { - assemble {unset true a} - info exists a - } - x - } - -returnCodes error - -result {can't unset "a": no such variable} - -cleanup {rename x {}} -} -test assemble-24.10 {unsetArray} { - -body { - proc x {} { - set a(b) {} - assemble {push b; unsetArray false a} - info exists a(b) - } - x - } - -result 0 - -cleanup {rename x {}} -} -test assemble-24.11 {unsetArray} { - -body { - proc x {} { - assemble {push b; unsetArray false a} - info exists a(b) - } - x - } - -result 0 - -cleanup {rename x {}} -} -test assemble-24.12 {unsetArray} { - -body { - proc x {} { - assemble {push b; unsetArray true a} - info exists a(b) - } - x - } - -returnCodes error - -result {can't unset "a(b)": no such variable} - -cleanup {rename x {}} -} - -# assemble-25 - dict get - -test assemble-25.1 {dict get - wrong # args} { - -body { - assemble {dictGet} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-25.2 {dict get - wrong # args} { - -body { - assemble {dictGet too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-25.3 {dictGet - bad subst} { - -body { - assemble {dictGet $foo} - } - -returnCodes error - -match glob - -result {assembly code may not contain substitutions} -} -test assemble-25.4 {dict get - not a number} { - -body { - proc x {} { - assemble {dictGet rubbish} - } - x - } - -returnCodes error - -result {expected integer but got "rubbish"} - -cleanup {rename x {}} -} -test assemble-25.5 {dictGet - negative operand count} { - -body { - proc x {} { - assemble {dictGet 0} - } - list [catch x result] $result $::errorCode - } - -result {1 {operand must be positive} {TCL ASSEM POSITIVE}} - -cleanup {rename x {}; unset result} -} -test assemble-25.6 {dictGet - 1 index} { - -body { - assemble {push {a 1 b 2}; push a; dictGet 1} - } - -result 1 -} - -# assemble-26 - dict set - -test assemble-26.1 {dict set - wrong # args} { - -body { - assemble {dictSet 1} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-26.2 {dict get - wrong # args} { - -body { - assemble {dictSet too many args} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-26.3 {dictSet - bad subst} { - -body { - assemble {dictSet 1 $foo} - } - -returnCodes error - -match glob - -result {assembly code may not contain substitutions} -} -test assemble-26.4 {dictSet - not a number} { - -body { - proc x {} { - assemble {dictSet rubbish foo} - } - x - } - -returnCodes error - -result {expected integer but got "rubbish"} - -cleanup {rename x {}} -} -test assemble-26.5 {dictSet - zero operand count} { - -body { - proc x {} { - assemble {dictSet 0 foo} - } - list [catch x result] $result $::errorCode - } - -result {1 {operand must be positive} {TCL ASSEM POSITIVE}} - -cleanup {rename x {}; unset result} -} -test assemble-26.6 {dictSet - bad local} { - -body { - proc x {} { - assemble {dictSet 1 ::foo::bar} - } - list [catch x result] $result $::errorCode - } - -result {1 {variable "::foo::bar" is not local} {TCL ASSEM NONLOCAL ::foo::bar}} - -cleanup {rename x {}; unset result} -} -test assemble-26.7 {dictSet} { - -body { - proc x {} { - set dict {a 1 b 2 c 3} - assemble {push b; push 4; dictSet 1 dict} - } - x - } - -result {a 1 b 4 c 3} - -cleanup {rename x {}} -} - -# assemble-27 - dictUnset - -test assemble-27.1 {dictUnset - wrong # args} { - -body { - assemble {dictUnset 1} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-27.2 {dictUnset - wrong # args} { - -body { - assemble {dictUnset too many args} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-27.3 {dictUnset - bad subst} { - -body { - assemble {dictUnset 1 $foo} - } - -returnCodes error - -match glob - -result {assembly code may not contain substitutions} -} -test assemble-27.4 {dictUnset - not a number} { - -body { - proc x {} { - assemble {dictUnset rubbish foo} - } - x - } - -returnCodes error - -result {expected integer but got "rubbish"} - -cleanup {rename x {}} -} -test assemble-27.5 {dictUnset - zero operand count} { - -body { - proc x {} { - assemble {dictUnset 0 foo} - } - list [catch x result] $result $::errorCode - } - -result {1 {operand must be positive} {TCL ASSEM POSITIVE}} - -cleanup {rename x {}; unset result} -} -test assemble-27.6 {dictUnset - bad local} { - -body { - proc x {} { - assemble {dictUnset 1 ::foo::bar} - } - list [catch x result] $result $::errorCode - } - -result {1 {variable "::foo::bar" is not local} {TCL ASSEM NONLOCAL ::foo::bar}} - -cleanup {rename x {}; unset result} -} -test assemble-27.7 {dictUnset} { - -body { - proc x {} { - set dict {a 1 b 2 c 3} - assemble {push b; dictUnset 1 dict} - } - x - } - -result {a 1 c 3} - -cleanup {rename x {}} -} - -# assemble-28 - dictIncrImm - -test assemble-28.1 {dictIncrImm - wrong # args} { - -body { - assemble {dictIncrImm 1} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-28.2 {dictIncrImm - wrong # args} { - -body { - assemble {dictIncrImm too many args} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-28.3 {dictIncrImm - bad subst} { - -body { - assemble {dictIncrImm 1 $foo} - } - -returnCodes error - -match glob - -result {assembly code may not contain substitutions} -} -test assemble-28.4 {dictIncrImm - not a number} { - -body { - proc x {} { - assemble {dictIncrImm rubbish foo} - } - x - } - -returnCodes error - -result {expected integer but got "rubbish"} - -cleanup {rename x {}} -} -test assemble-28.5 {dictIncrImm - bad local} { - -body { - proc x {} { - assemble {dictIncrImm 1 ::foo::bar} - } - list [catch x result] $result $::errorCode - } - -result {1 {variable "::foo::bar" is not local} {TCL ASSEM NONLOCAL ::foo::bar}} - -cleanup {rename x {}; unset result} -} -test assemble-28.6 {dictIncrImm} { - -body { - proc x {} { - set dict {a 1 b 2 c 3} - assemble {push b; dictIncrImm 42 dict} - } - x - } - -result {a 1 b 44 c 3} - -cleanup {rename x {}} -} - -# assemble-29 - ASSEM_REGEXP - -test assemble-29.1 {regexp - wrong # args} { - -body { - assemble {regexp} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-29.2 {regexp - wrong # args} { - -body { - assemble {regexp too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-29.3 {regexp - bad subst} { - -body { - assemble {regexp $foo} - } - -returnCodes error - -match glob - -result {assembly code may not contain substitutions} -} -test assemble-29.4 {regexp - not a boolean} { - -body { - proc x {} { - assemble {regexp rubbish} - } - x - } - -returnCodes error - -result {expected boolean value but got "rubbish"} - -cleanup {rename x {}} -} -test assemble-29.5 {regexp} { - -body { - assemble {push br.*br; push abracadabra; regexp false} - } - -result 1 -} -test assemble-29.6 {regexp} { - -body { - assemble {push br.*br; push aBRacadabra; regexp false} - } - -result 0 -} -test assemble-29.7 {regexp} { - -body { - assemble {push br.*br; push aBRacadabra; regexp true} - } - -result 1 -} - -# assemble-30 - Catches - -test assemble-30.1 {simplest possible catch} { - -body { - proc x {} { - assemble { - beginCatch @bad - push error - push testing - invokeStk 2 - pop - push 0 - jump @ok - label @bad - push 1; # should be pushReturnCode - label @ok - endCatch - } - } - x - } - -result 1 - -cleanup {rename x {}} -} -test assemble-30.2 {catch in external catch conntext} { - -body { - proc x {} { - list [catch { - assemble { - beginCatch @bad - push error - push testing - invokeStk 2 - pop - push 0 - jump @ok - label @bad - pushReturnCode - label @ok - endCatch - } - } result] $result - } - x - } - -result {0 1} - -cleanup {rename x {}} -} -test assemble-30.3 {embedded catches} { - -body { - proc x {} { - list [catch { - assemble { - beginCatch @bad - push error - eval { list [catch {error whatever} result] $result } - invokeStk 2 - push 0 - reverse 2 - jump @done - label @bad - pushReturnCode - pushResult - label @done - endCatch - list 2 - } - } result2] $result2 - } - x - } - -result {0 {1 {1 whatever}}} - -cleanup {rename x {}} -} -test assemble-30.4 {throw in wrong context} { - -body { - proc x {} { - list [catch { - assemble { - beginCatch @bad - push error - eval { list [catch {error whatever} result] $result } - invokeStk 2 - push 0 - reverse 2 - jump @done - - label @bad - load x - pushResult - - label @done - endCatch - list 2 - } - } result] $result $::errorCode [split $::errorInfo \n] - } - x - } - -match glob - -result {1 {"loadScalar1" instruction may not appear in a context where an exception has been caught and not disposed of.} {TCL ASSEM BADTHROW} {{"loadScalar1" instruction may not appear in a context where an exception has been caught and not disposed of.} { in assembly code between lines 10 and 15}*}} - -cleanup {rename x {}} -} -test assemble-30.5 {unclosed catch} { - -body { - proc x {} { - assemble { - beginCatch @error - push 0 - jump @done - label @error - push 1 - label @done - push "" - pop - } - } - list [catch {x} result] $result $::errorCode $::errorInfo - } - -match glob - -result {1 {catch still active on exit from assembly code} {TCL ASSEM UNCLOSEDCATCH} {catch still active on exit from assembly code - ("assemble" body, line 2)*}} - -cleanup {rename x {}} -} -test assemble-30.6 {inconsistent catch contexts} { - -body { - proc x {y} { - assemble { - load y - jumpTrue @inblock - beginCatch @error - label @inblock - push 0 - jump @done - label @error - push 1 - label @done - } - } - list [catch {x 2} result] $::errorCode $::errorInfo - } - -match glob - -result {1 {TCL ASSEM BADCATCH} {execution reaches an instruction in inconsistent exception contexts - ("assemble" body, line 5)*}} - -cleanup {rename x {}} -} - -# assemble-31 - Jump tables - -test assemble-31.1 {jumpTable, wrong # args} { - -body { - assemble {jumpTable} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-31.2 {jumpTable, wrong # args} { - -body { - assemble {jumpTable too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-31.3 {jumpTable - bad subst} { - -body { - assemble {jumpTable $foo} - } - -returnCodes error - -match glob - -result {assembly code may not contain substitutions} -} -test assemble-31.4 {jumptable - not a list} { - -body { - assemble {jumpTable \{rubbish} - } - -returnCodes error - -result {unmatched open brace in list} -} -test assemble-31.5 {jumpTable, badly structured} { - -body { - list [catch {assemble { - # line 2 - jumpTable {one two three};# line 3 - }} result] \ - $result $::errorCode $::errorInfo - } - -match glob - -result {1 {jump table must have an even number of list elements} {TCL ASSEM BADJUMPTABLE} {jump table must have an even number of list elements*("assemble" body, line 3)*}} -} -test assemble-31.6 {jumpTable, missing symbol} { - -body { - list [catch {assemble { - # line 2 - jumpTable {1 a};# line 3 - }} result] \ - $result $::errorCode $::errorInfo - } - -match glob - -result {1 {undefined label "a"} {TCL ASSEM NOLABEL a} {undefined label "a"*("assemble" body, line 3)*}} -} -test assemble-31.7 {jumptable, actual example} { - -setup { - proc x {} { - set result {} - for {set i 0} {$i < 5} {incr i} { - lappend result [assemble { - load i - jumpTable {1 @one 2 @two 3 @three} - push {none of the above} - jump @done - label @one - push one - jump @done - label @two - push two - jump @done - label @three - push three - label @done - }] - } - set tcl_traceCompile 2 - set result - } - } - -body x - -result {{none of the above} one two three {none of the above}} - -cleanup {set tcl_traceCompile 0; rename x {}} -} - -test assemble-40.1 {unbalanced stack} { - -body { - list \ - [catch { - assemble { - push 3 - dup - mult - push 4 - dup - mult - pop - expon - } - } result] $result $::errorInfo - } - -result {1 {stack underflow} {stack underflow - in assembly code between lines 1 and end of assembly code*}} - -match glob - -returnCodes ok -} -test assemble-40.2 {unbalanced stack} {*}{ - -body { - list \ - [catch { - assemble { - label a - push {} - label b - pop - label c - pop - label d - push {} - } - } result] $result $::errorInfo - } - -result {1 {stack underflow} {stack underflow - in assembly code between lines 7 and 9*}} - -match glob - -returnCodes ok -} - -test assemble-41.1 {Inconsistent stack usage} {*}{ - -body { - proc x {y} { - assemble { - load y - jumpFalse else - push 0 - jump then - label else - push 1 - push 2 - label then - pop - } - } - catch {x 1} - set errorInfo - } - -match glob - -result {inconsistent stack depths on two execution paths - ("assemble" body, line 10)*} -} -test assemble-41.2 {Inconsistent stack, jumptable and default} { - -body { - proc x {y} { - assemble { - load y - jumpTable {0 else} - push 0 - label else - pop - } - } - catch {x 1} - set errorInfo - } - -match glob - -result {inconsistent stack depths on two execution paths - ("assemble" body, line 6)*} -} -test assemble-41.3 {Inconsistent stack, two legs of jumptable} { - -body { - proc x {y} { - assemble { - load y - jumpTable {0 no 1 yes} - label no - push 0 - label yes - pop - } - } - catch {x 1} - set errorInfo - } - -match glob - -result {inconsistent stack depths on two execution paths - ("assemble" body, line 7)*} -} - -test assemble-50.1 {Ulam's 3n+1 problem, TAL implementation} { - -body { - proc ulam {n} { - assemble { - load n; # max - dup; # max n - jump start; # max n - - label loop; # max n - over 1; # max n max - over 1; # max in max n - ge; # man n max>=n - jumpTrue skip; # max n - - reverse 2; # n max - pop; # n - dup; # n n - - label skip; # max n - dup; # max n n - push 2; # max n n 2 - mod; # max n n%2 - jumpTrue odd; # max n - - push 2; # max n 2 - div; # max n/2 -> max n - jump start; # max n - - label odd; # max n - push 3; # max n 3 - mult; # max 3*n - push 1; # max 3*n 1 - add; # max 3*n+1 - - label start; # max n - dup; # max n n - push 1; # max n n 1 - neq; # max n n>1 - jumpTrue loop; # max n - - pop; # max - } - } - set result {} - for {set i 1} {$i < 30} {incr i} { - lappend result [ulam $i] - } - set result - } - -result {1 2 16 4 16 16 52 8 52 16 52 16 40 52 160 16 52 52 88 20 64 52 160 24 88 40 9232 52 88} -} - -test assemble-51.1 {memory leak testing} memory { - leaktest { - apply {{} {assemble {push hello}}} - } -} 0 -test assemble-51.2 {memory leak testing} memory { - leaktest { - apply {{{x 0}} {assemble {incrImm x 1}}} - } -} 0 -test assemble-51.3 {memory leak testing} memory { - leaktest { - apply {{n} { - assemble { - load n; # max - dup; # max n - jump start; # max n - - label loop; # max n - over 1; # max n max - over 1; # max in max n - ge; # man n max>=n - jumpTrue skip; # max n - - reverse 2; # n max - pop; # n - dup; # n n - - label skip; # max n - dup; # max n n - push 2; # max n n 2 - mod; # max n n%2 - jumpTrue odd; # max n - - push 2; # max n 2 - div; # max n/2 -> max n - jump start; # max n - - label odd; # max n - push 3; # max n 3 - mult; # max 3*n - push 1; # max 3*n 1 - add; # max 3*n+1 - - label start; # max n - dup; # max n n - push 1; # max n n 1 - neq; # max n n>1 - jumpTrue loop; # max n - - pop; # max - } - }} 1 - } -} 0 -test assemble-51.4 {memory leak testing} memory { - leaktest { - catch { - apply {{} { - assemble {reverse polish notation} - }} - } - } -} 0 - -rename fillTables {} -rename assemble {} - -::tcltest::cleanupTests -return - -# Local Variables: -# mode: tcl -# fill-column: 78 -# End: diff --git a/tests/assemble1.bench b/tests/assemble1.bench deleted file mode 100644 index 18fd3a9..0000000 --- a/tests/assemble1.bench +++ /dev/null @@ -1,85 +0,0 @@ -proc ulam1 {n} { - set max $n - while {$n != 1} { - if {$n > $max} { - set max $n - } - if {$n % 2} { - set n [expr {3 * $n + 1}] - } else { - set n [expr {$n / 2}] - } - } - return $max -} - -set tcl_traceCompile 2; ulam1 1; set tcl_traceCompile 0 - -proc ulam2 {n} { - tcl::unsupported::assemble { - load n; # max - dup; # max n - jump start; # max n - - label loop; # max n - over 1; # max n max - over 1; # max in max n - ge; # man n max>=n - jumpTrue skip; # max n - - reverse 2; # n max - pop; # n - dup; # n n - - label skip; # max n - dup; # max n n - push 2; # max n n 2 - mod; # max n n%2 - jumpTrue odd; # max n - - push 2; # max n 2 - div; # max n/2 -> max n - jump start; # max n - - label odd; # max n - push 3; # max n 3 - mult; # max 3*n - push 1; # max 3*n 1 - add; # max 3*n+1 - - label start; # max n - dup; # max n n - push 1; # max n n 1 - neq; # max n n>1 - jumpTrue loop; # max n - - pop; # max - } -} -set tcl_traceCompile 2; ulam2 1; set tcl_traceCompile 0 - -proc test1 {n} { - for {set i 1} {$i <= $n} {incr i} { - ulam1 $i - } -} -proc test2 {n} { - for {set i 1} {$i <= $n} {incr i} { - ulam2 $i - } -} - -for {set j 0} {$j < 10} {incr j} { - test1 1 - set before [clock microseconds] - test1 30000 - set after [clock microseconds] - puts "compiled: [expr {1e-6 * ($after - $before)}]" - - test2 1 - set before [clock microseconds] - test2 30000 - set after [clock microseconds] - puts "assembled: [expr {1e-6 * ($after - $before)}]" -} -
\ No newline at end of file diff --git a/tests/case.test b/tests/case.test deleted file mode 100644 index 6d63cea..0000000 --- a/tests/case.test +++ /dev/null @@ -1,89 +0,0 @@ -# Commands covered: case -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 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. - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import -force ::tcltest::* -} - -test case-1.1 {simple pattern} { - case a in a {format 1} b {format 2} c {format 3} default {format 4} -} 1 -test case-1.2 {simple pattern} { - case b a {format 1} b {format 2} c {format 3} default {format 4} -} 2 -test case-1.3 {simple pattern} { - case x in a {format 1} b {format 2} c {format 3} default {format 4} -} 4 -test case-1.4 {simple pattern} { - case x a {format 1} b {format 2} c {format 3} -} {} -test case-1.5 {simple pattern matches many times} { - case b a {format 1} b {format 2} b {format 3} b {format 4} -} 2 -test case-1.6 {fancier pattern} { - case cx a {format 1} *c {format 2} *x {format 3} default {format 4} -} 3 -test case-1.7 {list of patterns} { - case abc in {a b c} {format 1} {def abc ghi} {format 2} -} 2 - -test case-2.1 {error in executed command} { - list [catch {case a in a {error "Just a test"} default {format 1}} msg] \ - $msg $::errorInfo -} {1 {Just a test} {Just a test - while executing -"error "Just a test"" - ("a" arm line 1) - invoked from within -"case a in a {error "Just a test"} default {format 1}"}} -test case-2.2 {error: not enough args} { - list [catch {case} msg] $msg -} {1 {wrong # args: should be "case string ?in? ?pattern body ...? ?default body?"}} -test case-2.3 {error: pattern with no body} { - list [catch {case a b} msg] $msg -} {1 {extra case pattern with no body}} -test case-2.4 {error: pattern with no body} { - list [catch {case a in b {format 1} c} msg] $msg -} {1 {extra case pattern with no body}} -test case-2.5 {error in default command} { - list [catch {case foo in a {error case1} default {error case2} \ - b {error case 3}} msg] $msg $::errorInfo -} {1 case2 {case2 - while executing -"error case2" - ("default" arm line 1) - invoked from within -"case foo in a {error case1} default {error case2} b {error case 3}"}} - -test case-3.1 {single-argument form for pattern/command pairs} { - case b in { - a {format 1} - b {format 2} - default {format 6} - } -} {2} -test case-3.2 {single-argument form for pattern/command pairs} { - case b { - a {format 1} - b {format 2} - default {format 6} - } -} {2} -test case-3.3 {single-argument form for pattern/command pairs} { - list [catch {case z in {a 2 b}} msg] $msg -} {1 {extra case pattern with no body}} - -# cleanup -::tcltest::cleanupTests -return diff --git a/tests/compile.test b/tests/compile.test index 4d91940..384f20d 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -624,90 +624,6 @@ test compile-17.2 {Command interpretation binding for non-compiled code} -setup interp delete $i } -result substituted -# This tests the supported parts of the unsupported [disassemble] command. It -# does not check the format of disassembled bytecode though; that's liable to -# change without warning. - -test compile-18.1 {disassembler - basics} -returnCodes error -body { - tcl::unsupported::disassemble -} -match glob -result {wrong # args: should be "*"} -test compile-18.2 {disassembler - basics} -returnCodes error -body { - tcl::unsupported::disassemble ? -} -match glob -result {bad type "?": must be *} -test compile-18.3 {disassembler - basics} -returnCodes error -body { - tcl::unsupported::disassemble lambda -} -match glob -result {wrong # args: should be "* lambda lambdaTerm"} -test compile-18.4 {disassembler - basics} -returnCodes error -body { - tcl::unsupported::disassemble lambda \{ -} -result "can't interpret \"\{\" as a lambda expression" -test compile-18.5 {disassembler - basics} -body { - # Allow any string: the result format is not defined anywhere! - tcl::unsupported::disassemble lambda {{} {}} -} -match glob -result * -test compile-18.6 {disassembler - basics} -returnCodes error -body { - tcl::unsupported::disassemble proc -} -match glob -result {wrong # args: should be "* proc procName"} -test compile-18.7 {disassembler - basics} -returnCodes error -body { - tcl::unsupported::disassemble proc nosuchproc -} -result {"nosuchproc" isn't a procedure} -test compile-18.8 {disassembler - basics} -setup { - proc chewonthis {} {} -} -body { - # Allow any string: the result format is not defined anywhere! - tcl::unsupported::disassemble proc chewonthis -} -cleanup { - rename chewonthis {} -} -match glob -result * -test compile-18.9 {disassembler - basics} -returnCodes error -body { - tcl::unsupported::disassemble script -} -match glob -result {wrong # args: should be "* script script"} -test compile-18.10 {disassembler - basics} -body { - # Allow any string: the result format is not defined anywhere! - tcl::unsupported::disassemble script {} -} -match glob -result * -test compile-18.11 {disassembler - basics} -returnCodes error -body { - tcl::unsupported::disassemble method -} -match glob -result {wrong # args: should be "* method className methodName"} -test compile-18.12 {disassembler - basics} -returnCodes error -body { - tcl::unsupported::disassemble method nosuchclass foo -} -result {nosuchclass does not refer to an object} -test compile-18.13 {disassembler - basics} -returnCodes error -setup { - oo::object create justanobject -} -body { - tcl::unsupported::disassemble method justanobject foo -} -cleanup { - justanobject destroy -} -result {"justanobject" is not a class} -test compile-18.14 {disassembler - basics} -returnCodes error -body { - tcl::unsupported::disassemble method oo::object nosuchmethod -} -result {unknown method "nosuchmethod"} -test compile-18.15 {disassembler - basics} -setup { - oo::class create foo {method bar {} {}} -} -body { - # Allow any string: the result format is not defined anywhere! - tcl::unsupported::disassemble method foo bar -} -cleanup { - foo destroy -} -match glob -result * -test compile-18.16 {disassembler - basics} -returnCodes error -body { - tcl::unsupported::disassemble objmethod -} -match glob -result {wrong # args: should be "* objmethod objectName methodName"} -test compile-18.17 {disassembler - basics} -returnCodes error -body { - tcl::unsupported::disassemble objmethod nosuchobject foo -} -result {nosuchobject does not refer to an object} -test compile-18.18 {disassembler - basics} -returnCodes error -body { - tcl::unsupported::disassemble objmethod oo::object nosuchmethod -} -result {unknown method "nosuchmethod"} -test compile-18.19 {disassembler - basics} -setup { - oo::object create foo - oo::objdefine foo {method bar {} {}} -} -body { - # Allow any string: the result format is not defined anywhere! - tcl::unsupported::disassemble objmethod foo bar -} -cleanup { - foo destroy -} -match glob -result * -# TODO sometime - check that bytecode from tbcload is *not* disassembled. # cleanup catch {rename p ""} diff --git a/tests/coroutine.test b/tests/coroutine.test index d31d029..654111e 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -240,13 +240,6 @@ test coroutine-1.12 {proc as coroutine} -setup { rename moo {} rename foo {} } -result {16 24} -test coroutine-1.13 {subst as coroutine: literal} { - list [coroutine foo eval {subst {>>[yield a],[yield b]<<}}] [foo x] [foo y] -} {a b >>x,y<<} -test coroutine-1.14 {subst as coroutine: in variable} { - set pattern {>>[yield c],[yield d]<<} - list [coroutine foo eval {subst $pattern}] [foo p] [foo q] -} {c d >>p,q<<} test coroutine-2.1 {self deletion on return} -body { coroutine foo set x 3 diff --git a/tests/interp.test b/tests/interp.test index 0af9887..b039876 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -2479,7 +2479,7 @@ test interp-29.3.1 {recursion limit} { }] interp delete $i set r -} {1 {too many nested evaluations (infinite loop?)} 49} +} {1 {too many nested evaluations (infinite loop?)} 48} test interp-29.3.2 {recursion limit} { set i [interp create] interp recursionlimit $i 50 @@ -2490,7 +2490,7 @@ test interp-29.3.2 {recursion limit} { }] interp delete $i set r -} {1 {too many nested evaluations (infinite loop?)} 49} +} {1 {too many nested evaluations (infinite loop?)} 48} test interp-29.3.3 {recursion limit} { set i [interp create] $i recursionlimit 50 @@ -2501,7 +2501,7 @@ test interp-29.3.3 {recursion limit} { }] interp delete $i set r -} {1 {too many nested evaluations (infinite loop?)} 49} +} {1 {too many nested evaluations (infinite loop?)} 48} test interp-29.3.4 {recursion limit error reporting} { interp create slave set r1 [slave eval { @@ -2565,10 +2565,11 @@ test interp-29.3.6 {recursion limit error reporting} { # # Note that TEBC does not verify the interp's nesting level itself; the nesting # level will only be verified when it invokes a non-bcc'd command. +# THIS IS WRONG IN THIS BRANCH! # test interp-29.3.7a {recursion limit error reporting} { interp create slave - after 0 {interp recursionlimit slave 5} + after 0 {interp recursionlimit slave 6} set r1 [slave eval { catch { # nesting level 1 eval { # 2 @@ -2589,7 +2590,7 @@ test interp-29.3.7a {recursion limit error reporting} { } {0 ok} test interp-29.3.7b {recursion limit error reporting} { interp create slave - after 0 {interp recursionlimit slave 5} + after 0 {interp recursionlimit slave 6} set r1 [slave eval { catch { # nesting level 1 eval { # 2 @@ -2632,7 +2633,7 @@ test interp-29.3.7c {recursion limit error reporting} { } {1 {too many nested evaluations (infinite loop?)}} test interp-29.3.8a {recursion limit error reporting} { interp create slave - after 0 {interp recursionlimit slave 4} + after 0 {interp recursionlimit slave 6} set r1 [slave eval { catch { # nesting level 1 eval { # 2 @@ -2716,7 +2717,7 @@ test interp-29.3.9b {recursion limit error reporting} { } {0 ok} test interp-29.3.10a {recursion limit error reporting} { interp create slave - after 0 {slave recursionlimit 4} + after 0 {slave recursionlimit 6} set r1 [slave eval { catch { # nesting level 1 eval { # 2 @@ -2758,7 +2759,7 @@ test interp-29.3.10b {recursion limit error reporting} { } {1 {too many nested evaluations (infinite loop?)}} test interp-29.3.11a {recursion limit error reporting} { interp create slave - after 0 {slave recursionlimit 5} + after 0 {slave recursionlimit 6} set r1 [slave eval { catch { # nesting level 1 eval { # 2 @@ -2856,7 +2857,7 @@ test interp-29.4.1 {recursion limit inheritance} { }] interp delete $i set r -} 50 +} 48 test interp-29.4.2 {recursion limit inheritance} { set i [interp create] $i recursionlimit 50 @@ -2869,7 +2870,7 @@ test interp-29.4.2 {recursion limit inheritance} { }] interp delete $i set r -} 50 +} 48 test interp-29.5.1 {does slave recursion limit affect master?} { set before [interp recursionlimit {}] set i [interp create] @@ -3151,7 +3152,7 @@ test interp-34.4 {limits with callbacks: extending limits} -setup { -value [expr {$curlim+10}] $i eval {for {set i 0} {$i<10} {incr i} {foo}} list $a $b $c -} -result {6 4 b} -cleanup { +} -result {5 5 b} -cleanup { interp delete $i rename cb1 {} rename cb2 {} @@ -3179,7 +3180,7 @@ test interp-34.5 {limits with callbacks: removing limits} -setup { $i limit command -command "cb2 {}" -value [expr {$curlim+10}] $i eval {for {set i 0} {$i<10} {incr i} {foo}} list $a $b $c -} -result {6 4 b} -cleanup { +} -result {5 5 b} -cleanup { interp delete $i rename cb1 {} rename cb2 {} @@ -3204,7 +3205,7 @@ test interp-34.6 {limits with callbacks: removing limits and handlers} -setup { $i limit command -command cb2 -value [expr {$curlim+10}] $i eval {for {set i 0} {$i<10} {incr i} {foo}} list $a $b $c -} -result {6 4 b} -cleanup { +} -result {5 5 b} -cleanup { interp delete $i rename cb1 {} rename cb2 {} @@ -3251,7 +3252,7 @@ test interp-34.7 {limits with callbacks: deleting the handler interp} -setup { } } list $n [interp exists $i] -} -result {4 0} -cleanup { +} -result {5 0} -cleanup { rename cb3 {} rename cb4 {} } diff --git a/tests/nre.test b/tests/nre.test index 14fac9f..0ddfff6 100644 --- a/tests/nre.test +++ b/tests/nre.test @@ -28,9 +28,10 @@ if {[testConstraint testnrelevels]} { namespace eval testnre { namespace path ::tcl::mathop # - # [testnrelevels] returns a 5-list with: C-stack depth, iPtr->numlevels, - # callFrame level, tosPtr and callback depth + # [testnrelevels] returns a 4-list with: C-stack depth, iPtr->numlevels, + # callFrame level and callback depth # + variable last [testnrelevels] proc depthDiff {} { variable last @@ -162,7 +163,7 @@ test nre-5.1 {[namespace eval] is not recursive} -setup { namespace delete ::foo } -constraints { testnrelevels -} -result {{0 2 2} 0} +} -result {{0 3 2} 0} test nre-5.2 {[namespace eval] is not recursive} -setup { namespace eval ::foo { @@ -175,7 +176,7 @@ test nre-5.2 {[namespace eval] is not recursive} -setup { namespace delete ::foo } -constraints { testnrelevels -} -result {{0 2 2} 0} +} -result {{0 3 2} 0} test nre-6.1 {[uplevel] is not recursive} -setup { proc a i [makebody {uplevel 1 [list a $i]}] @@ -217,7 +218,7 @@ test nre-7.2 {[if] is not recursive} -setup { rename a {} } -constraints { testnrelevels -} -result {{0 2 0} 0} +} -result {{0 3 0} 0} test nre-7.3 {[while] is not recursive} -setup { setabs proc a i [makebody {uplevel 1 "while 1 {set res \[a $i\]; break}; set res"}] @@ -227,7 +228,7 @@ test nre-7.3 {[while] is not recursive} -setup { rename a {} } -constraints { testnrelevels -} -result {{0 2 0} 0} +} -result {{0 3 0} 0} test nre-7.4 {[for] is not recursive} -setup { setabs proc a i [makebody {uplevel 1 "for {set j 0} {\$j < 10} {incr j} {set res \[a $i\]; break}; set res"}] @@ -237,7 +238,7 @@ test nre-7.4 {[for] is not recursive} -setup { rename a {} } -constraints { testnrelevels -} -result {{0 2 0} 0} +} -result {{0 3 0} 0} test nre-7.5 {[foreach] is not recursive} -setup { # # Enable once [foreach] is NR-enabled diff --git a/tests/tailcall.test b/tests/tailcall.test index d6b0214..b445725 100644 --- a/tests/tailcall.test +++ b/tests/tailcall.test @@ -27,8 +27,9 @@ testConstraint testnrelevels [llength [info commands testnrelevels]] if {[testConstraint testnrelevels]} { namespace eval testnre { # - # [testnrelevels] returns a 5-list with: C-stack depth, iPtr->numlevels, - # callFrame level, tosPtr and callback depth + # + # [testnrelevels] returns a 4-list with: C-stack depth, iPtr->numlevels, + # callFrame level and callback depth # proc depthDiff {} { @@ -71,7 +72,7 @@ test tailcall-0.1 {tailcall is constant space} -constraints testnrelevels -setup a 0 } -cleanup { rename a {} -} -result {0 0 0 0 0} +} -result {0 0 0 0} test tailcall-0.2 {tailcall is constant space} -constraints testnrelevels -setup { set a { i { @@ -86,7 +87,7 @@ test tailcall-0.2 {tailcall is constant space} -constraints testnrelevels -setup apply $a 0 } -cleanup { unset a -} -result {0 0 0 0 0} +} -result {0 0 0 0} test tailcall-0.3 {tailcall is constant space} -constraints testnrelevels -setup { proc a i { @@ -102,7 +103,7 @@ test tailcall-0.3 {tailcall is constant space} -constraints testnrelevels -setup } -cleanup { rename a {} rename b {} -} -result {0 0 0 0 0} +} -result {0 0 0 0} test tailcall-0.4 {tailcall is constant space} -constraints testnrelevels -setup { namespace eval ::ns { @@ -123,7 +124,7 @@ test tailcall-0.4 {tailcall is constant space} -constraints testnrelevels -setup } -cleanup { rename b {} namespace delete ::ns -} -result {0 0 0 0 0} +} -result {0 0 0 0} test tailcall-0.5 {tailcall is constant space} -constraints testnrelevels -setup { proc b i { @@ -139,7 +140,7 @@ test tailcall-0.5 {tailcall is constant space} -constraints testnrelevels -setup } -cleanup { rename a {} rename b {} -} -result {0 0 0 0 0} +} -result {0 0 0 0} test tailcall-0.6 {tailcall is constant space} -constraints {testnrelevels knownBug} -setup { # @@ -162,7 +163,7 @@ test tailcall-0.6 {tailcall is constant space} -constraints {testnrelevels known rename a {} rename c {} rename d {} -} -result {0 0 0 0 0} +} -result {0 0 0 0} test tailcall-0.7 {tailcall is constant space} -constraints testnrelevels -setup { catch {rename foo {}} @@ -181,7 +182,7 @@ test tailcall-0.7 {tailcall is constant space} -constraints testnrelevels -setup } -cleanup { rename a {} rename foo {} -} -result {0 0 0 0 0} +} -result {0 0 0 0} test tailcall-1 {tailcall} -body { namespace eval a { diff --git a/unix/Makefile.in b/unix/Makefile.in index cc7f42f..dd94d7e 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -290,7 +290,7 @@ TCLTEST_OBJS = tclTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \ XTTEST_OBJS = xtTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \ tclThreadTest.o tclUnixTest.o tclXtNotify.o tclXtTest.o -GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \ +GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o \ tclAsync.o tclBasic.o tclBinary.o tclCkalloc.o tclClock.o \ tclCmdAH.o tclCmdIL.o tclCmdMZ.o tclCompCmds.o tclCompCmdsSZ.o \ tclCompExpr.o tclCompile.o tclConfig.o tclDate.o tclDictObj.o \ @@ -300,15 +300,14 @@ GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \ tclIORChan.o tclIORTrans.o tclIOGT.o tclIOSock.o tclIOUtil.o \ tclLink.o tclListObj.o \ tclLiteral.o tclLoad.o tclMain.o tclNamesp.o tclNotify.o \ - tclObj.o tclPanic.o tclParse.o tclPathObj.o tclPipe.o \ + tclObj.o tclObjAlloc.o tclPanic.o tclParse.o tclPathObj.o tclPipe.o \ tclPkg.o tclPkgConfig.o tclPosixStr.o \ tclPreserve.o tclProc.o tclRegexp.o \ tclResolve.o tclResult.o tclScan.o tclStringObj.o \ tclStrToD.o tclThread.o \ - tclThreadAlloc.o tclThreadJoin.o tclThreadStorage.o tclStubInit.o \ + tclThreadJoin.o tclThreadStorage.o tclStubInit.o \ tclTimer.o tclTrace.o tclUtf.o tclUtil.o tclVar.o tclZlib.o \ - tclTomMathInterface.o \ - tclAssembly.o + tclTomMathInterface.o OO_OBJS = tclOO.o tclOOBasic.o tclOOCall.o tclOODefineCmds.o tclOOInfo.o \ tclOOMethod.o tclOOStubInit.o @@ -384,8 +383,6 @@ GENERIC_SRCS = \ $(GENERIC_DIR)/regexec.c \ $(GENERIC_DIR)/regfree.c \ $(GENERIC_DIR)/regerror.c \ - $(GENERIC_DIR)/tclAlloc.c \ - $(GENERIC_DIR)/tclAssembly.c \ $(GENERIC_DIR)/tclAsync.c \ $(GENERIC_DIR)/tclBasic.c \ $(GENERIC_DIR)/tclBinary.c \ @@ -428,6 +425,7 @@ GENERIC_SRCS = \ $(GENERIC_DIR)/tclNamesp.c \ $(GENERIC_DIR)/tclNotify.c \ $(GENERIC_DIR)/tclObj.c \ + $(GENERIC_DIR)/tclObjAlloc.c \ $(GENERIC_DIR)/tclParse.c \ $(GENERIC_DIR)/tclPathObj.c \ $(GENERIC_DIR)/tclPipe.c \ @@ -447,14 +445,12 @@ GENERIC_SRCS = \ $(GENERIC_DIR)/tclTestObj.c \ $(GENERIC_DIR)/tclTestProcBodyObj.c \ $(GENERIC_DIR)/tclThread.c \ - $(GENERIC_DIR)/tclThreadAlloc.c \ $(GENERIC_DIR)/tclThreadJoin.c \ $(GENERIC_DIR)/tclThreadStorage.c \ $(GENERIC_DIR)/tclTimer.c \ $(GENERIC_DIR)/tclTrace.c \ $(GENERIC_DIR)/tclUtil.c \ $(GENERIC_DIR)/tclVar.c \ - $(GENERIC_DIR)/tclAssembly.c \ $(GENERIC_DIR)/tclZlib.c OO_SRCS = \ @@ -996,7 +992,7 @@ xtTestInit.o: $(UNIX_DIR)/tclAppInit.c ${TCL_EXE} REGHDRS=$(GENERIC_DIR)/regex.h $(GENERIC_DIR)/regguts.h \ $(GENERIC_DIR)/regcustom.h TCLREHDRS=$(GENERIC_DIR)/tclRegexp.h -COMPILEHDR=$(GENERIC_DIR)/tclCompile.h +COMPILEHDR=$(GENERIC_DIR)/tclCompileInt.h FSHDR=$(GENERIC_DIR)/tclFileSystem.h IOHDR=$(GENERIC_DIR)/tclIO.h MATHHDRS=$(GENERIC_DIR)/tommath.h $(GENERIC_DIR)/tclTomMath.h @@ -1020,12 +1016,6 @@ regerror.o: $(REGHDRS) $(GENERIC_DIR)/regerrs.h $(GENERIC_DIR)/regerror.c tclAppInit.o: $(UNIX_DIR)/tclAppInit.c $(CC) -c $(APP_CC_SWITCHES) $(UNIX_DIR)/tclAppInit.c -tclAlloc.o: $(GENERIC_DIR)/tclAlloc.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAlloc.c - -tclAssembly.o: $(GENERIC_DIR)/tclAssembly.c $(COMPILEHDR) - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAssembly.c - tclAsync.o: $(GENERIC_DIR)/tclAsync.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAsync.c @@ -1074,7 +1064,7 @@ tclDictObj.o: $(GENERIC_DIR)/tclDictObj.c $(MATHHDRS) tclEncoding.o: $(GENERIC_DIR)/tclEncoding.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclEncoding.c -tclEnsemble.o: $(GENERIC_DIR)/tclEnsemble.c $(COMPILEHDR) +tclEnsemble.o: $(GENERIC_DIR)/tclEnsemble.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclEnsemble.c tclEnv.o: $(GENERIC_DIR)/tclEnv.c @@ -1137,9 +1127,12 @@ tclListObj.o: $(GENERIC_DIR)/tclListObj.c tclLiteral.o: $(GENERIC_DIR)/tclLiteral.c $(COMPILEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLiteral.c -tclObj.o: $(GENERIC_DIR)/tclObj.c $(COMPILEHDR) $(MATHHDRS) +tclObj.o: $(GENERIC_DIR)/tclObj.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclObj.c +tclObjAlloc.o: $(GENERIC_DIR)/tclObjAlloc.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclObjAlloc.c + tclLoad.o: $(GENERIC_DIR)/tclLoad.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLoad.c @@ -1170,7 +1163,7 @@ tclLoadShl.o: $(UNIX_DIR)/tclLoadShl.c tclMain.o: $(GENERIC_DIR)/tclMain.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclMain.c -tclNamesp.o: $(GENERIC_DIR)/tclNamesp.c $(COMPILEHDR) +tclNamesp.o: $(GENERIC_DIR)/tclNamesp.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclNamesp.c tclNotify.o: $(GENERIC_DIR)/tclNotify.c @@ -1191,7 +1184,7 @@ tclOODefineCmds.o: $(GENERIC_DIR)/tclOODefineCmds.c tclOOInfo.o: $(GENERIC_DIR)/tclOOInfo.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOOInfo.c -tclOOMethod.o: $(GENERIC_DIR)/tclOOMethod.c +tclOOMethod.o: $(GENERIC_DIR)/tclOOMethod.c $(COMPILEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOOMethod.c tclOOStubInit.o: $(GENERIC_DIR)/tclOOStubInit.c @@ -1296,9 +1289,6 @@ tclTimer.o: $(GENERIC_DIR)/tclTimer.c tclThread.o: $(GENERIC_DIR)/tclThread.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclThread.c -tclThreadAlloc.o: $(GENERIC_DIR)/tclThreadAlloc.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclThreadAlloc.c - tclThreadJoin.o: $(GENERIC_DIR)/tclThreadJoin.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclThreadJoin.c diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index 9c21b28..249a703 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -430,8 +430,8 @@ TclpCreateProcess( * deallocated later */ - dsArray = TclStackAlloc(interp, argc * sizeof(Tcl_DString)); - newArgv = TclStackAlloc(interp, (argc+1) * sizeof(char *)); + dsArray = ckalloc(argc * sizeof(Tcl_DString)); + newArgv = ckalloc((argc+1) * sizeof(char *)); newArgv[argc] = NULL; for (i = 0; i < argc; i++) { newArgv[i] = Tcl_UtfToExternalDString(NULL, argv[i], -1, &dsArray[i]); @@ -503,8 +503,8 @@ TclpCreateProcess( for (i = 0; i < argc; i++) { Tcl_DStringFree(&dsArray[i]); } - TclStackFree(interp, newArgv); - TclStackFree(interp, dsArray); + ckfree(newArgv); + ckfree(dsArray); if (pid == -1) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( diff --git a/unix/tclUnixThrd.c b/unix/tclUnixThrd.c index 789dbb6..752795c 100644 --- a/unix/tclUnixThrd.c +++ b/unix/tclUnixThrd.c @@ -674,12 +674,11 @@ TclpInetNtoa( #endif } -#ifdef TCL_THREADS +#if defined(TCL_THREADS) /* * Additions by AOL for specialized thread memory allocator. */ -#ifdef USE_THREAD_ALLOC static volatile int initialized = 0; static pthread_key_t key; @@ -716,6 +715,7 @@ TclpFreeAllocMutex( free(lockPtr); } + void TclpFreeAllocCache( void *ptr) @@ -725,8 +725,9 @@ TclpFreeAllocCache( * Called by the pthread lib when a thread exits */ +#ifndef PURIFY TclFreeAllocCache(ptr); - +#endif } else if (initialized) { /* * Called by us in TclFinalizeThreadAlloc() during the library @@ -758,8 +759,9 @@ TclpSetAllocCache( { pthread_setspecific(key, arg); } -#endif /* USE_THREAD_ALLOC */ +#endif +#ifdef TCL_THREADS void * TclpThreadCreateKey(void) { |