diff options
Diffstat (limited to 'contrib/tcl/generic')
34 files changed, 4391 insertions, 3556 deletions
diff --git a/contrib/tcl/generic/tcl.h b/contrib/tcl/generic/tcl.h index 22331af..2d773da 100644 --- a/contrib/tcl/generic/tcl.h +++ b/contrib/tcl/generic/tcl.h @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tcl.h 1.318 97/06/26 13:43:02 + * SCCS: @(#) tcl.h 1.324 97/08/07 10:26:49 */ #ifndef _TCL @@ -37,11 +37,11 @@ #define TCL_MAJOR_VERSION 8 #define TCL_MINOR_VERSION 0 -#define TCL_RELEASE_LEVEL 1 -#define TCL_RELEASE_SERIAL 2 +#define TCL_RELEASE_LEVEL 2 +#define TCL_RELEASE_SERIAL 0 #define TCL_VERSION "8.0" -#define TCL_PATCH_LEVEL "8.0b2" +#define TCL_PATCH_LEVEL "8.0" /* * The following definitions set up the proper options for Windows @@ -410,12 +410,25 @@ typedef struct Tcl_Obj { * expression that is expensive to compute or has side effects. */ -#define Tcl_IncrRefCount(objPtr) \ - ++(objPtr)->refCount -#define Tcl_DecrRefCount(objPtr) \ - if (--(objPtr)->refCount <= 0) TclFreeObj(objPtr) -#define Tcl_IsShared(objPtr) \ - ((objPtr)->refCount > 1) +EXTERN void Tcl_IncrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr)); +EXTERN void Tcl_DecrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr)); +EXTERN int Tcl_IsShared _ANSI_ARGS_((Tcl_Obj *objPtr)); + +#ifdef TCL_MEM_DEBUG +# define Tcl_IncrRefCount(objPtr) \ + Tcl_DbIncrRefCount(objPtr, __FILE__, __LINE__) +# define Tcl_DecrRefCount(objPtr) \ + Tcl_DbDecrRefCount(objPtr, __FILE__, __LINE__) +# define Tcl_IsShared(objPtr) \ + Tcl_DbIsShared(objPtr, __FILE__, __LINE__) +#else +# define Tcl_IncrRefCount(objPtr) \ + ++(objPtr)->refCount +# define Tcl_DecrRefCount(objPtr) \ + if (--(objPtr)->refCount <= 0) TclFreeObj(objPtr) +# define Tcl_IsShared(objPtr) \ + ((objPtr)->refCount > 1) +#endif /* * Macros and definitions that help to debug the use of Tcl objects. @@ -511,17 +524,18 @@ typedef struct Tcl_CallFrame { } Tcl_CallFrame; /* - * Information about commands that is returned by Tcl_GetCmdInfo and passed - * to Tcl_SetCmdInfo. objProc is an objc/objv object-based command procedure - * while proc is a traditional Tcl argc/argv string-based procedure. - * 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 procedure was - * registered by Tcl_CreateObjCommand, and to 0 if a string-based procedure - * was registered by Tcl_CreateCommand. The other procedure is typically set - * to a compatibility wrapper that does string-to-object or object-to-string - * argument conversions then calls the other procedure. + * Information about commands that is returned by Tcl_GetCommandInfo and + * passed to Tcl_SetCommandInfo. objProc is an objc/objv object-based + * command procedure while proc is a traditional Tcl argc/argv + * string-based procedure. 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 procedure was registered by Tcl_CreateObjCommand, and to + * 0 if a string-based procedure was registered by Tcl_CreateCommand. + * The other procedure is typically set to a compatibility wrapper that + * does string-to-object or object-to-string argument conversions then + * calls the other procedure. */ typedef struct Tcl_CmdInfo { @@ -985,7 +999,7 @@ EXTERN int Tcl_AsyncInvoke _ANSI_ARGS_((Tcl_Interp *interp, EXTERN void Tcl_AsyncMark _ANSI_ARGS_((Tcl_AsyncHandler async)); EXTERN int Tcl_AsyncReady _ANSI_ARGS_((void)); EXTERN void Tcl_BackgroundError _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN char Tcl_Backslash _ANSI_ARGS_((char *src, +EXTERN char Tcl_Backslash _ANSI_ARGS_((CONST char *src, int *readPtr)); EXTERN int Tcl_BadChannelOption _ANSI_ARGS_((Tcl_Interp *interp, char *optionName, char *optionList)); @@ -1003,9 +1017,9 @@ EXTERN int Tcl_CommandComplete _ANSI_ARGS_((char *cmd)); EXTERN char * Tcl_Concat _ANSI_ARGS_((int argc, char **argv)); EXTERN Tcl_Obj * Tcl_ConcatObj _ANSI_ARGS_((int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_ConvertCountedElement _ANSI_ARGS_((char *src, +EXTERN int Tcl_ConvertCountedElement _ANSI_ARGS_((CONST char *src, int length, char *dst, int flags)); -EXTERN int Tcl_ConvertElement _ANSI_ARGS_((char *src, +EXTERN int Tcl_ConvertElement _ANSI_ARGS_((CONST char *src, char *dst, int flags)); EXTERN int Tcl_ConvertToType _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_ObjType *typePtr)); @@ -1059,6 +1073,12 @@ EXTERN int Tcl_DbCkfree _ANSI_ARGS_((char *ptr, char *file, int line)); EXTERN char * Tcl_DbCkrealloc _ANSI_ARGS_((char *ptr, unsigned int size, char *file, int line)); +EXTERN void Tcl_DbDecrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr, + char *file, int line)); +EXTERN void Tcl_DbIncrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr, + char *file, int line)); +EXTERN int Tcl_DbIsShared _ANSI_ARGS_((Tcl_Obj *objPtr, + char *file, int line)); EXTERN Tcl_Obj * Tcl_DbNewBooleanObj _ANSI_ARGS_((int boolValue, char *file, int line)); EXTERN Tcl_Obj * Tcl_DbNewDoubleObj _ANSI_ARGS_((double doubleValue, @@ -1109,9 +1129,9 @@ EXTERN int Tcl_DoOneEvent _ANSI_ARGS_((int flags)); EXTERN void Tcl_DoWhenIdle _ANSI_ARGS_((Tcl_IdleProc *proc, ClientData clientData)); EXTERN char * Tcl_DStringAppend _ANSI_ARGS_((Tcl_DString *dsPtr, - char *string, int length)); + CONST char *string, int length)); EXTERN char * Tcl_DStringAppendElement _ANSI_ARGS_(( - Tcl_DString *dsPtr, char *string)); + Tcl_DString *dsPtr, CONST char *string)); EXTERN void Tcl_DStringEndSublist _ANSI_ARGS_((Tcl_DString *dsPtr)); EXTERN void Tcl_DStringFree _ANSI_ARGS_((Tcl_DString *dsPtr)); EXTERN void Tcl_DStringGetResult _ANSI_ARGS_((Tcl_Interp *interp, @@ -1137,7 +1157,7 @@ EXTERN int Tcl_EvalObj _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); EXTERN void Tcl_Exit _ANSI_ARGS_((int status)); EXTERN int Tcl_ExposeCommand _ANSI_ARGS_((Tcl_Interp *interp, - char *hiddenCmdName, char *cmdName)); + char *hiddenCmdToken, char *cmdName)); EXTERN int Tcl_ExprBoolean _ANSI_ARGS_((Tcl_Interp *interp, char *string, int *ptr)); EXTERN int Tcl_ExprBooleanObj _ANSI_ARGS_((Tcl_Interp *interp, @@ -1245,7 +1265,7 @@ EXTERN int Tcl_GlobalEvalObj _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); EXTERN char * Tcl_HashStats _ANSI_ARGS_((Tcl_HashTable *tablePtr)); EXTERN int Tcl_HideCommand _ANSI_ARGS_((Tcl_Interp *interp, - char *cmdName, char *hiddenCmdName)); + char *cmdName, char *hiddenCmdToken)); EXTERN int Tcl_Init _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN void Tcl_InitHashTable _ANSI_ARGS_((Tcl_HashTable *tablePtr, int keyType)); @@ -1326,6 +1346,8 @@ EXTERN int Tcl_Read _ANSI_ARGS_((Tcl_Channel chan, EXTERN void Tcl_ReapDetachedProcs _ANSI_ARGS_((void)); EXTERN int Tcl_RecordAndEval _ANSI_ARGS_((Tcl_Interp *interp, char *cmd, int flags)); +EXTERN int Tcl_RecordAndEvalObj _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *cmdPtr, int flags)); EXTERN Tcl_RegExp Tcl_RegExpCompile _ANSI_ARGS_((Tcl_Interp *interp, char *string)); EXTERN int Tcl_RegExpExec _ANSI_ARGS_((Tcl_Interp *interp, @@ -1342,9 +1364,9 @@ EXTERN void Tcl_Release _ANSI_ARGS_((ClientData clientData)); EXTERN void Tcl_RestartIdleTimer _ANSI_ARGS_((void)); EXTERN void Tcl_ResetResult _ANSI_ARGS_((Tcl_Interp *interp)); #define Tcl_Return Tcl_SetResult -EXTERN int Tcl_ScanCountedElement _ANSI_ARGS_((char *string, +EXTERN int Tcl_ScanCountedElement _ANSI_ARGS_((CONST char *string, int length, int *flagPtr)); -EXTERN int Tcl_ScanElement _ANSI_ARGS_((char *string, +EXTERN int Tcl_ScanElement _ANSI_ARGS_((CONST char *string, int *flagPtr)); EXTERN int Tcl_Seek _ANSI_ARGS_((Tcl_Channel chan, int offset, int mode)); diff --git a/contrib/tcl/generic/tclAlloc.c b/contrib/tcl/generic/tclAlloc.c new file mode 100644 index 0000000..cf07036 --- /dev/null +++ b/contrib/tcl/generic/tclAlloc.c @@ -0,0 +1,456 @@ +/* + * 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. + * + * 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. + * + * SCCS: @(#) tclAlloc.c 1.4 97/08/11 18:45:38 + */ + +#include "tclInt.h" +#include "tclPort.h" + +#ifdef TCL_DEBUG +# define DEBUG +/* #define MSTATS */ +# define RCHECK +#endif + +typedef unsigned long caddr_t; + +/* + * The overhead on a block is at least 4 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 *ov_next; /* when free */ + struct { + unsigned char ovu_magic0; /* magic number */ + unsigned char ovu_index; /* bucket # */ + unsigned char ovu_unused; /* unused */ + unsigned char ovu_magic1; /* other magic number */ +#ifdef RCHECK + unsigned short ovu_rmagic; /* range magic number */ + unsigned long ovu_size; /* actual block size */ +#endif + } ovu; +#define ov_magic0 ovu.ovu_magic0 +#define ov_magic1 ovu.ovu_magic1 +#define ov_index ovu.ovu_index +#define ov_rmagic ovu.ovu_rmagic +#define ov_size ovu.ovu_size +}; + + +#define MAGIC 0xef /* magic # on accounting info */ +#define RMAGIC 0x5555 /* magic # on range info */ + +#ifdef RCHECK +#define RSLOP sizeof (unsigned short) +#else +#define RSLOP 0 +#endif + +#define OVERHEAD (sizeof(union overhead) + RSLOP) + +/* + * nextf[i] is the pointer to the next free block of size 2^(i+3). The + * smallest allocatable block is 8 bytes. The overhead information + * precedes the data area returned to the user. + */ + +#define NBUCKETS 13 +#define MAXMALLOC (1<<(NBUCKETS+2)) +static union overhead *nextf[NBUCKETS]; + +#ifdef MSTATS + +/* + * nmalloc[i] is the difference between the number of mallocs and frees + * for a given block size. + */ + +static unsigned int nmalloc[NBUCKETS+1]; +#include <stdio.h> +#endif + +#if defined(DEBUG) || defined(RCHECK) +#define ASSERT(p) if (!(p)) panic(# p) +#define RANGE_ASSERT(p) if (!(p)) panic(# p) +#else +#define ASSERT(p) +#define RANGE_ASSERT(p) +#endif + +/* + * Prototypes for functions used only in this file. + */ + +static void MoreCore _ANSI_ARGS_((int bucket)); + +/* + *---------------------------------------------------------------------- + * + * TclpAlloc -- + * + * Allocate more memory. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +TclpAlloc( + unsigned int nbytes) /* Number of bytes to allocate. */ +{ + register union overhead *op; + register long bucket; + register unsigned amt; + + /* + * First the simple case: we simple allocate big blocks directly + */ + if (nbytes + OVERHEAD >= MAXMALLOC) { + op = (union overhead *)TclpSysAlloc(nbytes+OVERHEAD, 0); + if (op == NULL) { + return NULL; + } + op->ov_magic0 = op->ov_magic1 = MAGIC; + op->ov_index = 0xff; +#ifdef MSTATS + nmalloc[NBUCKETS]++; +#endif +#ifdef RCHECK + /* + * Record allocated size of block and + * bound space with magic numbers. + */ + op->ov_size = (nbytes + RSLOP - 1) & ~(RSLOP - 1); + op->ov_rmagic = RMAGIC; + *(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC; +#endif + return (void *)(op+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. + */ +#ifndef RCHECK + amt = 8; /* size of first bucket */ + bucket = 0; +#else + amt = 16; /* size of first bucket */ + bucket = 1; +#endif + while (nbytes + OVERHEAD > amt) { + amt <<= 1; + if (amt == 0) { + return (NULL); + } + bucket++; + } + ASSERT( bucket < NBUCKETS ); + + /* + * If nothing in hash bucket right now, + * request more memory from the system. + */ + if ((op = nextf[bucket]) == NULL) { + MoreCore(bucket); + if ((op = nextf[bucket]) == NULL) { + return (NULL); + } + } + /* + * Remove from linked list + */ + nextf[bucket] = op->ov_next; + op->ov_magic0 = op->ov_magic1 = MAGIC; + op->ov_index = (unsigned char) bucket; +#ifdef MSTATS + nmalloc[bucket]++; +#endif +#ifdef RCHECK + /* + * Record allocated size of block and + * bound space with magic numbers. + */ + op->ov_size = (nbytes + RSLOP - 1) & ~(RSLOP - 1); + op->ov_rmagic = RMAGIC; + *(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC; +#endif + return ((char *)(op + 1)); +} + +/* + *---------------------------------------------------------------------- + * + * MoreCore -- + * + * Allocate more memory to the indicated bucket. + * + * 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 *op; + register long sz; /* size of desired block */ + long amt; /* amount to allocate */ + int nblks; /* how many blocks we get */ + + /* + * sbrk_size <= 0 only for big, FLUFFY, requests (about + * 2^30 bytes on a VAX, I think) or for a negative arg. + */ + sz = 1 << (bucket + 3); + ASSERT(sz > 0); + + amt = MAXMALLOC; + nblks = amt / sz; + ASSERT(nblks*sz == amt); + + op = (union overhead *)TclpSysAlloc(amt, 1); + /* no more room! */ + if (op == NULL) { + return; + } + + /* + * Add new memory allocated to that on + * free list for this hash bucket. + */ + nextf[bucket] = op; + while (--nblks > 0) { + op->ov_next = (union overhead *)((caddr_t)op + sz); + op = (union overhead *)((caddr_t)op + sz); + } + op->ov_next = (union overhead *)NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TclpFree -- + * + * Free memory. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclpFree( + char *cp) /* Pointer to memory to free. */ +{ + register long size; + register union overhead *op; + + if (cp == NULL) { + return; + } + + op = (union overhead *)((caddr_t)cp - sizeof (union overhead)); + + ASSERT(op->ov_magic0 == MAGIC); /* make sure it was in use */ + ASSERT(op->ov_magic1 == MAGIC); + if (op->ov_magic0 != MAGIC || op->ov_magic1 != MAGIC) { + return; + } + + RANGE_ASSERT(op->ov_rmagic == RMAGIC); + RANGE_ASSERT(*(unsigned short *)((caddr_t)(op + 1) + op->ov_size) == RMAGIC); + size = op->ov_index; + if ( size == 0xff ) { +#ifdef MSTATS + nmalloc[NBUCKETS]--; +#endif + TclpSysFree(op); + return; + } + ASSERT(size < NBUCKETS); + op->ov_next = nextf[size]; /* also clobbers ov_magic */ + nextf[size] = op; +#ifdef MSTATS + nmalloc[size]--; +#endif +} + +/* + *---------------------------------------------------------------------- + * + * TclpRealloc -- + * + * Reallocate memory. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +TclpRealloc( + char *cp, /* Pointer to alloced block. */ + unsigned int nbytes) /* New size of memory. */ +{ + int i; + union overhead *op; + int expensive; + unsigned long maxsize; + + if (cp == NULL) { + return (TclpAlloc(nbytes)); + } + + op = (union overhead *)((caddr_t)cp - sizeof (union overhead)); + + ASSERT(op->ov_magic0 == MAGIC); /* make sure it was in use */ + ASSERT(op->ov_magic1 == MAGIC); + if (op->ov_magic0 != MAGIC || op->ov_magic1 != MAGIC) { + return NULL; + } + + RANGE_ASSERT(op->ov_rmagic == RMAGIC); + RANGE_ASSERT(*(unsigned short *)((caddr_t)(op + 1) + op->ov_size) == RMAGIC); + i = op->ov_index; + + /* + * If the block isn't in a bin, just realloc it. + */ + + if (i == 0xff) { + op = (union overhead *) TclpSysRealloc(op, nbytes+OVERHEAD); + if (op == NULL) { + return NULL; + } +#ifdef MSTATS + nmalloc[NBUCKETS]++; +#endif +#ifdef RCHECK + /* + * Record allocated size of block and update magic number bounds. + */ + + op->ov_size = (nbytes + RSLOP - 1) & ~(RSLOP - 1); + *(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC; +#endif + return (char *)(op+1); + } + maxsize = 1 << (i+3); + expensive = 0; + if ( nbytes + OVERHEAD > maxsize ) { + expensive = 1; + } else if ( i > 0 && nbytes + OVERHEAD < (maxsize/2) ) { + expensive = 1; + } + + if (expensive) { + void *newp; + + newp = TclpAlloc(nbytes); + if ( newp == NULL ) { + return NULL; + } + maxsize -= OVERHEAD; + if ( maxsize < nbytes ) + nbytes = maxsize; + memcpy((VOID *) newp, (VOID *) cp, (size_t) nbytes); + TclpFree(cp); + return newp; + } + + /* + * Ok, we don't have to copy, it fits as-is + */ +#ifdef RCHECK + op->ov_size = (nbytes + RSLOP - 1) & ~(RSLOP - 1); + *(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC; +#endif + return(cp); +} + +/* + *---------------------------------------------------------------------- + * + * 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 *p; + int totfree = 0, + totused = 0; + + fprintf(stderr, "Memory allocation statistics %s\nTclpFree:\t", s); + for (i = 0; i < NBUCKETS; i++) { + for (j = 0, p = nextf[i]; p; p = p->ov_next, j++) + fprintf(stderr, " %d", j); + totfree += j * (1 << (i + 3)); + } + fprintf(stderr, "\nused:\t"); + for (i = 0; i < NBUCKETS; i++) { + fprintf(stderr, " %d", nmalloc[i]); + totused += nmalloc[i] * (1 << (i + 3)); + } + fprintf(stderr, "\n\tTotal small in use: %d, total free: %d\n", + totused, totfree); + fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %d\n", + MAXMALLOC, nmalloc[NBUCKETS]); +} +#endif diff --git a/contrib/tcl/generic/tclBasic.c b/contrib/tcl/generic/tclBasic.c index c043dd4..952292f 100644 --- a/contrib/tcl/generic/tclBasic.c +++ b/contrib/tcl/generic/tclBasic.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclBasic.c 1.280 97/05/20 19:09:26 + * SCCS: @(#) tclBasic.c 1.305 97/08/13 10:34:43 */ #include "tclInt.h" @@ -89,12 +89,10 @@ static CmdInfo builtInCmds[] = { TclCompileForCmd, 1}, {"foreach", (Tcl_CmdProc *) NULL, Tcl_ForeachObjCmd, TclCompileForeachCmd, 1}, - {"format", Tcl_FormatCmd, (Tcl_ObjCmdProc *) NULL, + {"format", (Tcl_CmdProc *) NULL, Tcl_FormatObjCmd, (CompileProc *) NULL, 1}, {"global", (Tcl_CmdProc *) NULL, Tcl_GlobalObjCmd, (CompileProc *) NULL, 1}, - {"history", Tcl_HistoryCmd, (Tcl_ObjCmdProc *) NULL, - (CompileProc *) NULL, 1}, {"if", Tcl_IfCmd, (Tcl_ObjCmdProc *) NULL, TclCompileIfCmd, 1}, {"incr", Tcl_IncrCmd, (Tcl_ObjCmdProc *) NULL, @@ -143,7 +141,7 @@ static CmdInfo builtInCmds[] = { (CompileProc *) NULL, 1}, {"set", Tcl_SetCmd, (Tcl_ObjCmdProc *) NULL, TclCompileSetCmd, 1}, - {"split", Tcl_SplitCmd, (Tcl_ObjCmdProc *) NULL, + {"split", (Tcl_CmdProc *) NULL, Tcl_SplitObjCmd, (CompileProc *) NULL, 1}, {"string", (Tcl_CmdProc *) NULL, Tcl_StringObjCmd, (CompileProc *) NULL, 1}, @@ -169,15 +167,15 @@ static CmdInfo builtInCmds[] = { */ #ifndef TCL_GENERIC_ONLY - {"after", Tcl_AfterCmd, (Tcl_ObjCmdProc *) NULL, + {"after", (Tcl_CmdProc *) NULL, Tcl_AfterObjCmd, (CompileProc *) NULL, 1}, - {"cd", Tcl_CdCmd, (Tcl_ObjCmdProc *) NULL, + {"cd", (Tcl_CmdProc *) NULL, Tcl_CdObjCmd, (CompileProc *) NULL, 0}, - {"close", Tcl_CloseCmd, (Tcl_ObjCmdProc *) NULL, + {"close", (Tcl_CmdProc *) NULL, Tcl_CloseObjCmd, (CompileProc *) NULL, 1}, - {"eof", Tcl_EofCmd, (Tcl_ObjCmdProc *) NULL, + {"eof", (Tcl_CmdProc *) NULL, Tcl_EofObjCmd, (CompileProc *) NULL, 1}, - {"fblocked", Tcl_FblockedCmd, (Tcl_ObjCmdProc *) NULL, + {"fblocked", (Tcl_CmdProc *) NULL, Tcl_FblockedObjCmd, (CompileProc *) NULL, 1}, {"fconfigure", Tcl_FconfigureCmd, (Tcl_ObjCmdProc *) NULL, (CompileProc *) NULL, 0}, @@ -210,7 +208,7 @@ static CmdInfo builtInCmds[] = { {"update", Tcl_UpdateCmd, (Tcl_ObjCmdProc *) NULL, (CompileProc *) NULL, 1}, {"vwait", Tcl_VwaitCmd, (Tcl_ObjCmdProc *) NULL, - (CompileProc *) NULL, 0}, + (CompileProc *) NULL, 1}, #ifdef MAC_TCL {"beep", (Tcl_CmdProc *) NULL, Tcl_BeepObjCmd, @@ -272,6 +270,7 @@ Tcl_CreateInterp() */ if (sizeof(Tcl_CallFrame) != sizeof(CallFrame)) { + /*NOTREACHED*/ panic("Tcl_CallFrame and CallFrame are not the same size"); } @@ -298,14 +297,6 @@ Tcl_CreateInterp() iPtr->returnCode = TCL_OK; iPtr->errorInfo = NULL; iPtr->errorCode = NULL; - iPtr->numEvents = 0; - iPtr->events = NULL; - iPtr->curEvent = 0; - iPtr->curEventNum = 0; - iPtr->revPtr = NULL; - iPtr->historyFirst = NULL; - iPtr->revDisables = 1; - iPtr->evalFirst = iPtr->evalLast = NULL; iPtr->appendResult = NULL; iPtr->appendAvl = 0; iPtr->appendUsed = 0; @@ -399,18 +390,45 @@ Tcl_CreateInterp() } } + /* + * Initialize/Create "errorInfo" and "errorCode" global vars + * (because some part of the C code assume they exists + * and we can get a seg fault otherwise (in multiple + * interps loading of extensions for instance) --dl) + */ + /* + * We can't assume that because we initialize + * the variables here, they won't be unset later. + * so we had 2 choices: + * + Check every place where a GetVar of those is used + * and the NULL result is not checked (like in tclLoad.c) + * + Make SetVar,... NULL friendly + * We choosed the second option because : + * + It is easy and low cost to check for NULL pointer before + * calling strlen() + * + It can be helpfull to other people using those API + * + Passing a NULL value to those closest 'meaning' is empty string + * (specially with the new objects where 0 bytes strings are ok) + * So the following init is commented out: -- dl + */ + /* + (void)Tcl_SetVar2((Tcl_Interp *)iPtr, "errorInfo", (char *) NULL, "", + TCL_GLOBAL_ONLY); + (void)Tcl_SetVar2((Tcl_Interp *)iPtr, "errorCode", (char *) NULL, "NONE", + TCL_GLOBAL_ONLY); + */ + #ifndef TCL_GENERIC_ONLY TclSetupEnv((Tcl_Interp *) iPtr); #endif /* - * Do Safe-Tcl init stuff + * Do Multiple/Safe Interps Tcl init stuff */ - (void) TclInterpInit((Tcl_Interp *)iPtr); /* - * Set up variables such as tcl_library and tcl_precision. + * Set up variables such as tcl_version. */ TclPlatformInit((Tcl_Interp *)iPtr); @@ -418,6 +436,9 @@ Tcl_CreateInterp() TCL_GLOBAL_ONLY); Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_version", TCL_VERSION, TCL_GLOBAL_ONLY); + Tcl_TraceVar2((Tcl_Interp *) iPtr, "tcl_precision", (char *) NULL, + TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + TclPrecTraceProc, (ClientData) NULL); /* * Compute the byte order of this machine. @@ -425,7 +446,7 @@ Tcl_CreateInterp() order.s = 1; Tcl_SetVar2((Tcl_Interp *) iPtr, "tcl_platform", "byteOrder", - (order.c[0] == 1) ? "litteEndian" : "bigEndian", + (order.c[0] == 1) ? "littleEndian" : "bigEndian", TCL_GLOBAL_ONLY); /* @@ -818,20 +839,6 @@ DeleteInterpProc(interp) ckfree(iPtr->errorCode); iPtr->errorCode = NULL; } - if (iPtr->events != NULL) { - for (i = 0; i < iPtr->numEvents; i++) { - ckfree(iPtr->events[i].command); - } - ckfree((char *) iPtr->events); - iPtr->events = NULL; - } - while (iPtr->revPtr != NULL) { - HistoryRev *nextPtr = iPtr->revPtr->nextPtr; - - ckfree(iPtr->revPtr->newBytes); - ckfree((char *) iPtr->revPtr); - iPtr->revPtr = nextPtr; - } if (iPtr->appendResult != NULL) { ckfree(iPtr->appendResult); iPtr->appendResult = NULL; @@ -964,10 +971,6 @@ HiddenCmdsDeleteProc(clientData, interp) Command *cmdPtr; hiddenCmdTblPtr = (Tcl_HashTable *) clientData; - hPtr = Tcl_FindHashEntry(hiddenCmdTblPtr, "tkerror"); - if (hPtr != NULL) { - Tcl_DeleteHashEntry(hPtr); - } for (hPtr = Tcl_FirstHashEntry(hiddenCmdTblPtr, &hSearch); hPtr != NULL; hPtr = Tcl_FirstHashEntry(hiddenCmdTblPtr, &hSearch)) { @@ -1023,7 +1026,18 @@ HiddenCmdsDeleteProc(clientData, interp) if (cmdPtr->hPtr != NULL) { Tcl_DeleteHashEntry(cmdPtr->hPtr); } - ckfree((char *) cmdPtr); + + /* + * Now free the Command structure, unless there is another reference + * to it from a CmdName Tcl object in some ByteCode code + * sequence. In that case, delay the cleanup until all references + * are either discarded (when a ByteCode is freed) or replaced by a + * new reference (when a cached CmdName Command reference is found + * to be invalid and TclExecuteByteCode looks up the command in the + * command hashtable). + */ + + TclCleanupCommand(cmdPtr); } Tcl_DeleteHashTable(hiddenCmdTblPtr); ckfree((char *) hiddenCmdTblPtr); @@ -1042,24 +1056,24 @@ HiddenCmdsDeleteProc(clientData, interp) * if an error occurs. * * Side effects: - * Moves a command from the command table to the hidden command - * table. + * Removes a command from the command table and create an entry + * into the hidden command table under the specified token name. * *---------------------------------------------------------------------- */ int -Tcl_HideCommand(interp, cmdName, hiddenCmdName) +Tcl_HideCommand(interp, cmdName, hiddenCmdToken) Tcl_Interp *interp; /* Interpreter in which to hide command. */ - char *cmdName; /* Name of hidden command. */ - char *hiddenCmdName; /* Name of to-be-hidden command. */ + char *cmdName; /* Name of command to hide. */ + char *hiddenCmdToken; /* Token name of the to-be-hidden command. */ { Interp *iPtr = (Interp *) interp; Tcl_Command cmd; Command *cmdPtr; Tcl_HashTable *hTblPtr; - Tcl_HashEntry *hPtr, *tkErrorHPtr; - int isBgerror, new; + Tcl_HashEntry *hPtr; + int new; if (iPtr->flags & DELETED) { @@ -1071,38 +1085,57 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdName) return TCL_ERROR; } - if (strstr(hiddenCmdName, "::") != NULL) { + /* + * Disallow hiding of commands that are currently in a namespace or + * renaming (as part of hiding) into a namespace. + * + * (because the current implementation with a single global table + * and the needed uniqueness of names cause problems with namespaces) + * + * we don't need to check for "::" in cmdName because the real check is + * on the nsPtr below. + * + * hiddenCmdToken is just a string which is not interpreted in any way. + * It may contain :: but the string is not interpreted as a namespace + * qualifier command name. Thus, hiding foo::bar to foo::bar and then + * trying to expose or invoke ::foo::bar will NOT work; but if the + * application always uses the same strings it will get consistent + * behaviour. + * + * But as we currently limit ourselves to the global namespace only + * for the source, in order to avoid potential confusion, + * lets prevent "::" in the token too. --dl + */ + + if (strstr(hiddenCmdToken, "::") != NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "hidden command names can't have namespace qualifiers", - (char *) NULL); + "cannot use namespace qualifiers as hidden command", + "token (rename)", (char *) NULL); return TCL_ERROR; } /* * Find the command to hide. An error is returned if cmdName can't - * be found. + * be found. Look up the command only from the global namespace. + * Full path of the command must be given if using namespaces. */ cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, - /*flags*/ TCL_LEAVE_ERR_MSG); + /*flags*/ TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY); if (cmd == (Tcl_Command) NULL) { return TCL_ERROR; } cmdPtr = (Command *) cmd; /* - * If this command is the "bgerror" command in the global namespace, - * make note of it now. We'll need to know this later so that we can - * handle its "tkerror" twin below. + * Check that the command is really in global namespace */ - - isBgerror = 0; - if (cmdPtr->hPtr != NULL) { - char *tail = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr); - if ((*tail == 'b') && (strcmp(tail, "bgerror") == 0) - && (cmdPtr->nsPtr == iPtr->globalNsPtr)) { - isBgerror = 1; - } + + if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can only hide global namespace commands", + " (use rename then hide)", (char *) NULL); + return TCL_ERROR; } /* @@ -1121,19 +1154,26 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdName) /* * It is an error to move an exposed command to a hidden command with - * hiddenCmdName if a hidden command with the name hiddenCmdName already + * hiddenCmdToken if a hidden command with the name hiddenCmdToken already * exists. */ - hPtr = Tcl_CreateHashEntry(hTblPtr, hiddenCmdName, &new); + hPtr = Tcl_CreateHashEntry(hTblPtr, hiddenCmdToken, &new); if (!new) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "hidden command named \"", hiddenCmdName, "\" already exists", + "hidden command named \"", hiddenCmdToken, "\" already exists", (char *) NULL); return TCL_ERROR; } /* + * Nb : This code is currently 'like' a rename to a specialy set apart + * name table. Changes here and in TclRenameCommand must + * be kept in synch untill the common parts are actually + * factorized out. + */ + + /* * Remove the hash entry for the command from the interpreter command * table. This is like deleting the command, so bump its command epoch; * this invalidates any cached references that point to the command. @@ -1146,28 +1186,8 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdName) } /* - * If we are creating a hidden command named "bgerror", share the - * command data structure with another command named "tkerror". This - * code should eventually be removed. - */ - - if (isBgerror) { - tkErrorHPtr = Tcl_CreateHashEntry(hTblPtr, "tkerror", &new); - if (!new) { - panic("Tcl_HideCommand: hiding bgerror while tkerror is already hidden!"); - } - Tcl_SetHashValue(tkErrorHPtr, (ClientData) cmdPtr); - tkErrorHPtr = Tcl_FindHashEntry(&(iPtr->globalNsPtr->cmdTable), - "tkerror"); - if (tkErrorHPtr != (Tcl_HashEntry *) NULL) { - Tcl_DeleteHashEntry(tkErrorHPtr); - } - } - - /* - * Now link the hash table entry with the command structure. Keep the - * containing namespace the same. After all, the command really - * "belongs" to that namespace. + * Now link the hash table entry with the command structure. + * We ensured above that the nsPtr was right. */ cmdPtr->hPtr = hPtr; @@ -1207,19 +1227,18 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdName) */ int -Tcl_ExposeCommand(interp, hiddenCmdName, cmdName) +Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName) Tcl_Interp *interp; /* Interpreter in which to make command * callable. */ - char *hiddenCmdName; /* Name of hidden command. */ + char *hiddenCmdToken; /* Name of hidden command. */ char *cmdName; /* Name of to-be-exposed command. */ { Interp *iPtr = (Interp *) interp; Command *cmdPtr; - Namespace *nsPtr, *dummy1, *dummy2; - Tcl_HashEntry *hPtr, *tkErrorHPtr; + Namespace *nsPtr; + Tcl_HashEntry *hPtr; Tcl_HashTable *hTblPtr; - char *tail; - int new, result; + int new; if (iPtr->flags & DELETED) { /* @@ -1231,6 +1250,20 @@ Tcl_ExposeCommand(interp, hiddenCmdName, cmdName) } /* + * Check that we have a regular name for the command + * (that the user is not trying to do an expose and a rename + * (to another namespace) at the same time) + */ + + if (strstr(cmdName, "::") != NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can not expose to a namespace ", + "(use expose to toplevel, then rename)", + (char *) NULL); + return TCL_ERROR; + } + + /* * Find the hash table for the hidden commands; error out if there * is none. */ @@ -1239,7 +1272,7 @@ Tcl_ExposeCommand(interp, hiddenCmdName, cmdName) NULL); if (hTblPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "unknown hidden command \"", hiddenCmdName, + "unknown hidden command \"", hiddenCmdToken, "\"", (char *) NULL); return TCL_ERROR; } @@ -1248,45 +1281,42 @@ Tcl_ExposeCommand(interp, hiddenCmdName, cmdName) * Get the command from the hidden command table: */ - hPtr = Tcl_FindHashEntry(hTblPtr, hiddenCmdName); + hPtr = Tcl_FindHashEntry(hTblPtr, hiddenCmdToken); if (hPtr == (Tcl_HashEntry *) NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "unknown hidden command \"", hiddenCmdName, + "unknown hidden command \"", hiddenCmdToken, "\"", (char *) NULL); return TCL_ERROR; } cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + /* - * Normally, the command will go right back into its containing - * namespace. But if the exposed command name has "::" namespace - * qualifiers, it is being moved to another context. + * Check that we have a true global namespace + * command (enforced by Tcl_HideCommand() but let's double + * check. (If it was not, we would not really know how to + * handle it). */ - - if (strstr(cmdName, "::") != NULL) { - result = TclGetNamespaceForQualName(interp, cmdName, - iPtr->globalNsPtr, - (CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG), - &nsPtr, &dummy1, &dummy2, &tail); - if (result != TCL_OK) { - return result; - } - if ((nsPtr == NULL) || (tail == NULL)) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "bad command name \"", cmdName, "\"", (char *) NULL); - return TCL_ERROR; - } - } else { - nsPtr = cmdPtr->nsPtr; - tail = cmdName; + if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) { + /* + * This case is theoritically impossible, + * we might rather panic() than 'nicely' erroring out ? + */ + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "trying to expose a non global command name space command", + (char *) NULL); + return TCL_ERROR; } + + /* This is the global table */ + nsPtr = cmdPtr->nsPtr; /* * It is an error to overwrite an existing exposed command as a result * of exposing a previously hidden command. */ - hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &new); if (!new) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "exposed command \"", cmdName, @@ -1305,35 +1335,22 @@ Tcl_ExposeCommand(interp, hiddenCmdName, cmdName) } /* - * If we are creating a command named "bgerror", share the command - * data structure with another command named "tkerror". This code - * should eventually be removed. - */ - - if ((*tail == 'b') && (strcmp(tail, "bgerror") == 0) - && (nsPtr == iPtr->globalNsPtr)) { - tkErrorHPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable, - "tkerror", &new); - if (!new) { - panic("Tcl_ExposeCommand: exposing bgerror while tkerror is already exposed!"); - } - Tcl_SetHashValue(tkErrorHPtr, (ClientData) cmdPtr); - tkErrorHPtr = Tcl_FindHashEntry(hTblPtr, "tkerror"); - if (tkErrorHPtr != NULL) { - Tcl_DeleteHashEntry(tkErrorHPtr); - } - } - - /* * Now link the hash table entry with the command structure. * This is like creating a new command, so deal with any shadowing * of commands in the global namespace. */ cmdPtr->hPtr = hPtr; - cmdPtr->nsPtr = nsPtr; + Tcl_SetHashValue(hPtr, (ClientData) cmdPtr); - TclResetShadowedCmdRefs(interp, cmdPtr); + + /* + * Not needed as we are only in the global namespace + * (but would be needed again if we supported namespace command hiding) + * + * TclResetShadowedCmdRefs(interp, cmdPtr); + */ + /* * If the command being exposed has a compile procedure, increment @@ -1421,18 +1438,6 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) tail = cmdName; } - /* - * The code below was added in 11/95 to preserve backwards compatibility - * when "tkerror" was renamed "bgerror": if anyone attempts to define - * "tkerror" as a command, it is actually created as "bgerror". This - * code should eventually be removed. - */ - - if ((*tail == 't') && (strcmp(tail, "tkerror") == 0) - && (nsPtr == iPtr->globalNsPtr)) { - tail = "bgerror"; - } - hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); if (!new) { /* @@ -1469,23 +1474,6 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) cmdPtr->importRefPtr = NULL; /* - * The code below provides more backwards compatibility for the - * renaming of "tkerror" to "bgerror". Like the code above, this - * code should eventually become unnecessary. - */ - - if ((*tail == 'b') && (strcmp(tail, "bgerror") == 0) - && (nsPtr == iPtr->globalNsPtr)) { - /* - * We're currently creating the "bgerror" command; create - * a "tkerror" command that shares the same Command structure. - */ - - hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, "tkerror", &new); - Tcl_SetHashValue(hPtr, cmdPtr); - } - - /* * We just created a command, so in its namespace and all of its parent * namespaces, it may shadow global commands with the same name. If any * shadowed commands are found, invalidate all cached command references @@ -1574,18 +1562,6 @@ Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) tail = cmdName; } - /* - * The code below was added in 11/95 to preserve backwards compatibility - * when "tkerror" was renamed "bgerror": if anyone attempts to define - * "tkerror" as a command, it is actually created as "bgerror". This - * code should eventually be removed. - */ - - if ((*tail == 't') && (strcmp(tail, "tkerror") == 0) - && (nsPtr == iPtr->globalNsPtr)) { - tail = "bgerror"; - } - hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); if (!new) { cmdPtr = (Command *) Tcl_GetHashValue(hPtr); @@ -1601,7 +1577,7 @@ Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) cmdPtr->objClientData = clientData; cmdPtr->deleteProc = deleteProc; cmdPtr->deleteData = clientData; - goto checkForBgerror; + return (Tcl_Command) cmdPtr; } Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); @@ -1632,23 +1608,6 @@ Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) cmdPtr->deleted = 0; cmdPtr->importRefPtr = NULL; - /* - * The code below provides more backwards compatibility for the - * renaming of "tkerror" to "bgerror". Like the code above, this - * code should eventually become unnecessary. - */ - - checkForBgerror: - if ((*tail == 'b') && (strcmp(tail, "bgerror") == 0) - && (nsPtr == iPtr->globalNsPtr)) { - /* - * We're currently creating the "bgerror" command; create - * a "tkerror" command that shares the same Command structure. - */ - - hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, "tkerror", &new); - Tcl_SetHashValue(hPtr, cmdPtr); - } return (Tcl_Command) cmdPtr; } @@ -1830,7 +1789,8 @@ TclInvokeObjectCommand(clientData, interp, argc, argv) * Called to give an existing Tcl command a different name. Both the * old command name and the new command name can have "::" namespace * qualifiers. If the new command has a different namespace context, - * the command is automatically moved to that namespace. + * the command will be moved to that namespace and will execute in + * the context of that new namespace. * * If the new command name is NULL or the null string, the command is * deleted. @@ -1852,12 +1812,12 @@ TclRenameCommand(interp, oldName, newName) char *newName; /* New command name. */ { Interp *iPtr = (Interp *) interp; - char *cmdTail, *newTail; + char *newTail; Namespace *cmdNsPtr, *newNsPtr, *dummy1, *dummy2; Tcl_Command cmd; Command *cmdPtr; Tcl_HashEntry *hPtr, *oldHPtr; - int new, isSrcBgerror, isDestBgerror, result; + int new, result; /* * Find the existing command. An error is returned if cmdName can't @@ -1869,11 +1829,10 @@ TclRenameCommand(interp, oldName, newName) cmdPtr = (Command *) cmd; if (cmdPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't ", - ((newName == NULL) || (*newName == '\0'))? "delete":"rename", + ((newName == NULL)||(*newName == '\0'))? "delete":"rename", " \"", oldName, "\": command doesn't exist", (char *) NULL); return TCL_ERROR; } - cmdTail = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr); cmdNsPtr = cmdPtr->nsPtr; /* @@ -1912,35 +1871,17 @@ TclRenameCommand(interp, oldName, newName) return TCL_ERROR; } + /* - * The code below was added in 11/95 to preserve backwards compatibility - * when "tkerror" was renamed "bgerror": we guarantee that the hash - * table entries for both commands refer to a single shared Command - * structure. This code should eventually become unnecessary. + * Warning: any changes done in the code here are likely + * to be needed in Tcl_HideCommand() code too. + * (until the common parts are extracted out) --dl */ - if ((*cmdTail == 't') && (strcmp(cmdTail, "tkerror") == 0) - && (cmdNsPtr == iPtr->globalNsPtr)) { - cmdTail = "bgerror"; - } - isSrcBgerror = ((*cmdTail == 'b') && (strcmp(cmdTail, "bgerror") == 0) - && (cmdNsPtr == iPtr->globalNsPtr)); - - if ((*newTail == 't') && (strcmp(newTail, "tkerror") == 0) - && (newNsPtr == iPtr->globalNsPtr)) { - newTail = "bgerror"; - } - isDestBgerror = ((*newTail == 'b') && (strcmp(newTail, "bgerror") == 0) - && (newNsPtr == iPtr->globalNsPtr)); - /* - * Put the command in the new namespace, so we can check for an alias + * Put the command in the new namespace so we can check for an alias * loop. Since we are adding a new command to a namespace, we must * handle any shadowing of the global commands that this might create. - * Note that the renamed command has a different hashtable pointer than - * it used to have. This allows the command caching code in tclExecute.c - * to recognize that a command pointer it has cached for this command is - * now invalid. */ oldHPtr = cmdPtr->hPtr; @@ -1951,8 +1892,8 @@ TclRenameCommand(interp, oldName, newName) TclResetShadowedCmdRefs(interp, cmdPtr); /* - * Everything is in place so we can check for an alias loop. If we - * detect one, put everything back the way it was and report the error. + * Now check for an alias loop. If we detect one, put everything back + * the way it was and report the error. */ result = TclPreventAliasLoop(interp, interp, (Tcl_Command) cmdPtr); @@ -1983,32 +1924,6 @@ TclRenameCommand(interp, oldName, newName) iPtr->compileEpoch++; } - /* - * The code below provides more backwards compatibility for the - * "tkerror" => "bgerror" renaming. As with the other compatibility - * code above, it should eventually be removed. - */ - - if (isSrcBgerror) { - /* - * The source command is "bgerror": delete the hash table entry for - * "tkerror" if it exists. - */ - - hPtr = Tcl_FindHashEntry(&cmdNsPtr->cmdTable, "tkerror"); - if (hPtr != NULL) { - Tcl_DeleteHashEntry(hPtr); - } - } - if (isDestBgerror) { - /* - * The destination command is "bgerror"; create a "tkerror" - * command that shares the same Command structure. - */ - - hPtr = Tcl_CreateHashEntry(&newNsPtr->cmdTable, "tkerror", &new); - Tcl_SetHashValue(hPtr, (ClientData) cmdPtr); - } return TCL_OK; } @@ -2283,15 +2198,8 @@ Tcl_DeleteCommandFromToken(interp, cmd) { Interp *iPtr = (Interp *) interp; Command *cmdPtr = (Command *) cmd; - char *cmdName; - int isBgerror; ImportRef *refPtr, *nextRefPtr; Tcl_Command importCmd; - Tcl_HashEntry *tkErrorHPtr; - - cmdName = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr); - isBgerror = ((*cmdName == 'b') && (strcmp(cmdName, "bgerror") == 0) - && (cmdPtr->nsPtr == iPtr->globalNsPtr)); /* * The code here is tricky. We can't delete the hash table entry @@ -2360,29 +2268,6 @@ Tcl_DeleteCommandFromToken(interp, cmd) } /* - * The code below provides more backwards compatibility for the - * renaming of "tkerror" to "bgerror". Like the code above, this - * code should eventually become unnecessary. - */ - - if (isBgerror) { - /* - * When the "bgerror" command is deleted, delete "tkerror" - * as well. It shared the same Command structure as "bgerror", - * so all we have to do is throw away the hash table entry. - * NOTE: we have to be careful since tkerror may already have - * been deleted before bgerror. - */ - - tkErrorHPtr = Tcl_FindHashEntry(cmdPtr->hPtr->tablePtr, - "tkerror"); - - if (tkErrorHPtr != (Tcl_HashEntry *) NULL) { - Tcl_DeleteHashEntry(tkErrorHPtr); - } - } - - /* * Don't use hPtr to delete the hash entry here, because it's * possible that the deletion callback renamed the command. * Instead, use cmdPtr->hptr, and make sure that no-one else @@ -2588,6 +2473,19 @@ Tcl_EvalObj(interp, objPtr) } /* + * On the Mac, we will never reach the default recursion limit before blowing + * the stack. So we need to do a check here. + */ + + if (TclpCheckStackSpace() == 0) { + /*NOTREACHED*/ + iPtr->numLevels--; + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "too many nested calls to Tcl_EvalObj (infinite loop?)", -1); + return TCL_ERROR; + } + + /* * If the interpreter has been deleted, return an error. */ @@ -2641,16 +2539,6 @@ Tcl_EvalObj(interp, objPtr) iPtr->evalFlags = 0; /* - * Save information for the history module, if needed. - * BTL: setting these NULL disables history revisions. - */ - - if (flags & TCL_RECORD_BOUNDS) { - iPtr->evalFirst = NULL; - iPtr->evalLast = NULL; - } - - /* * Execute the commands. If the code was compiled from an empty string, * don't bother executing the code. */ @@ -2723,25 +2611,6 @@ Tcl_EvalObj(interp, objPtr) int length; /* - * Compute the line number where the error occurred. - * BTL: no line # information yet. - */ - - iPtr->errorLine = 1; -#ifdef NOT_YET - for (p = cmd; p != cmdStart; p++) { - if (*p == '\n') { - iPtr->errorLine++; - } - } - for ( ; isspace(UCHAR(*p)) || (*p == ';'); p++) { - if (*p == '\n') { - iPtr->errorLine++; - } - } -#endif - - /* * Figure out how much of the command to print in the error * message (up to a certain number of characters, or up to * the first new-line). @@ -2813,7 +2682,6 @@ Tcl_ExprLong(interp, string, ptr) if (length > 0) { exprPtr = Tcl_NewStringObj(string, length); Tcl_IncrRefCount(exprPtr); - result = Tcl_ExprObj(interp, exprPtr, &resultPtr); if (result == TCL_OK) { /* @@ -2868,7 +2736,6 @@ Tcl_ExprDouble(interp, string, ptr) if (length > 0) { exprPtr = Tcl_NewStringObj(string, length); Tcl_IncrRefCount(exprPtr); - result = Tcl_ExprObj(interp, exprPtr, &resultPtr); if (result == TCL_OK) { /* @@ -2923,7 +2790,6 @@ Tcl_ExprBoolean(interp, string, ptr) if (length > 0) { exprPtr = Tcl_NewStringObj(string, length); Tcl_IncrRefCount(exprPtr); - result = Tcl_ExprObj(interp, exprPtr, &resultPtr); if (result == TCL_OK) { /* @@ -3312,7 +3178,7 @@ TclObjInvoke(interp, objc, objv, flags) hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclHiddenCmds", NULL); if (hTblPtr == (Tcl_HashTable *) NULL) { - badHiddenCmdName: + badhiddenCmdToken: Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "invalid hidden command name \"", cmdName, "\"", @@ -3326,7 +3192,7 @@ TclObjInvoke(interp, objc, objv, flags) */ if (hPtr == NULL) { - goto badHiddenCmdName; + goto badhiddenCmdToken; } cmdPtr = (Command *) Tcl_GetHashValue(hPtr); } else { @@ -3462,7 +3328,7 @@ Tcl_ExprString(interp, string) if (length > 0) { TclNewObj(exprPtr); TclInitStringRep(exprPtr, string, length); - Tcl_DecrRefCount(exprPtr); + Tcl_IncrRefCount(exprPtr); result = Tcl_ExprObj(interp, exprPtr, &resultPtr); if (result == TCL_OK) { @@ -3554,7 +3420,7 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr) Interp dummy; Tcl_Obj *saveObjPtr; char *string; - int result = TCL_OK; + int result; int i; /* @@ -3920,12 +3786,14 @@ Tcl_AddObjErrorInfo(interp, message, length) * Now append "message" to the end of errorInfo. */ - messagePtr = Tcl_NewStringObj(message, length); - Tcl_IncrRefCount(messagePtr); - Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL, messagePtr, - (TCL_GLOBAL_ONLY | TCL_APPEND_VALUE)); - Tcl_DecrRefCount(messagePtr); /* free msg object appended above */ - + if (length != 0) { + messagePtr = Tcl_NewStringObj(message, length); + Tcl_IncrRefCount(messagePtr); + Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL, messagePtr, + (TCL_GLOBAL_ONLY | TCL_APPEND_VALUE)); + Tcl_DecrRefCount(messagePtr); /* free msg object appended above */ + } + Tcl_DecrRefCount(namePtr); /* free the name object */ } diff --git a/contrib/tcl/generic/tclBinary.c b/contrib/tcl/generic/tclBinary.c index 28190cc..c20d03d 100644 --- a/contrib/tcl/generic/tclBinary.c +++ b/contrib/tcl/generic/tclBinary.c @@ -9,9 +9,10 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclBinary.c 1.16 97/05/19 10:29:18 + * SCCS: @(#) tclBinary.c 1.20 97/08/11 18:43:09 */ +#include <math.h> #include "tclInt.h" #include "tclPort.h" @@ -275,9 +276,11 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) count = 1; } if (length >= count) { - memcpy(cursor, str, (size_t) count); + memcpy((VOID *) cursor, (VOID *) str, + (size_t) count); } else { - memcpy(cursor, str, (size_t) length); + memcpy((VOID *) cursor, (VOID *) str, + (size_t) length); memset(cursor+length, pad, (size_t) (count - length)); } @@ -877,12 +880,13 @@ FormatNumber(interp, type, src, cursorPtr) * to the valid range for float. */ - if (dvalue > FLT_MAX) { - *((float *)(*cursorPtr)) = FLT_MAX; - } else if (dvalue < FLT_MIN) { - *((float *)(*cursorPtr)) = FLT_MIN; + if (fabs(dvalue) > (double)FLT_MAX) { + *((float *)(*cursorPtr)) + = (dvalue >= 0.0) ? FLT_MAX : -FLT_MAX; + } else if (fabs(dvalue) < (double)FLT_MIN) { + *((float *)(*cursorPtr)) = (float) 0.0; } else { - *((float *)(*cursorPtr)) = (float)dvalue; + *((float *)(*cursorPtr)) = (float) dvalue; } (*cursorPtr) += sizeof(float); } diff --git a/contrib/tcl/generic/tclClock.c b/contrib/tcl/generic/tclClock.c index c6cb924..bf45583 100644 --- a/contrib/tcl/generic/tclClock.c +++ b/contrib/tcl/generic/tclClock.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclClock.c 1.36 97/06/02 10:14:17 + * SCCS: @(#) tclClock.c 1.37 97/07/29 10:29:58 */ #include "tcl.h" @@ -79,7 +79,7 @@ Tcl_ClockObjCmd (client, interp, objc, objv) switch (index) { case 0: /* clicks */ if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "clicks"); + Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } Tcl_SetLongObj(resultPtr, (long) TclpGetClicks()); @@ -87,8 +87,8 @@ Tcl_ClockObjCmd (client, interp, objc, objv) case 1: /* format */ if ((objc < 3) || (objc > 7)) { wrongFmtArgs: - Tcl_WrongNumArgs(interp, 1, objv, - "format clockval ?-format string? ?-gmt boolean?"); + Tcl_WrongNumArgs(interp, 2, objv, + "clockval ?-format string? ?-gmt boolean?"); return TCL_ERROR; } @@ -126,8 +126,8 @@ Tcl_ClockObjCmd (client, interp, objc, objv) case 2: /* scan */ if ((objc < 3) || (objc > 7)) { wrongScanArgs: - Tcl_WrongNumArgs(interp, 1, objv, - "scan dateString ?-base clockValue? ?-gmt boolean?"); + Tcl_WrongNumArgs(interp, 2, objv, + "dateString ?-base clockValue? ?-gmt boolean?"); return TCL_ERROR; } @@ -184,7 +184,7 @@ Tcl_ClockObjCmd (client, interp, objc, objv) return TCL_OK; case 3: /* seconds */ if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "seconds"); + Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } Tcl_SetLongObj(resultPtr, (long) TclpGetSeconds()); diff --git a/contrib/tcl/generic/tclCmdAH.c b/contrib/tcl/generic/tclCmdAH.c index 46384c9..79968d3 100644 --- a/contrib/tcl/generic/tclCmdAH.c +++ b/contrib/tcl/generic/tclCmdAH.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclCmdAH.c 1.146 97/06/26 13:45:20 + * SCCS: @(#) tclCmdAH.c 1.156 97/08/12 18:10:15 */ #include "tclInt.h" @@ -92,6 +92,7 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv) char *string, *arg; int argLen, caseObjc; Tcl_Obj *CONST *caseObjv; + Tcl_Obj *armPtr; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, @@ -187,11 +188,12 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv) match: if (body != -1) { + armPtr = caseObjv[body-1]; result = Tcl_EvalObj(interp, caseObjv[body]); if (result == TCL_ERROR) { char msg[100]; - arg = Tcl_GetStringFromObj(caseObjv[body-1], &argLen); + arg = Tcl_GetStringFromObj(armPtr, &argLen); sprintf(msg, "\n (\"%.*s\" arm line %d)", argLen, arg, interp->errorLine); Tcl_AddObjErrorInfo(interp, msg, -1); @@ -231,6 +233,7 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { + Tcl_Obj *varNamePtr = NULL; int result; if ((objc != 2) && (objc != 3)) { @@ -244,10 +247,15 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv) * stack rendering objv invalid. */ + if (objc == 3) { + varNamePtr = objv[2]; + } + result = Tcl_EvalObj(interp, objv[1]); + if (objc == 3) { - if (Tcl_ObjSetVar2(interp, objv[2], NULL, Tcl_GetObjResult(interp), - TCL_PARSE_PART1) == NULL) { + if (Tcl_ObjSetVar2(interp, varNamePtr, NULL, + Tcl_GetObjResult(interp), TCL_PARSE_PART1) == NULL) { Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), "couldn't save command result in variable", -1); @@ -270,7 +278,7 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv) /* *---------------------------------------------------------------------- * - * Tcl_CdCmd -- + * Tcl_CdObjCmd -- * * This procedure is invoked to process the "cd" Tcl command. * See the user documentation for details on what it does. @@ -286,24 +294,24 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv) /* ARGSUSED */ int -Tcl_CdCmd(dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ +Tcl_CdObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { char *dirName; + int dirLength; Tcl_DString buffer; int result; - if (argc > 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " dirName\"", (char *) NULL); + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "dirName"); return TCL_ERROR; } - if (argc == 2) { - dirName = argv[1]; + if (objc == 2) { + dirName = Tcl_GetStringFromObj(objv[1], &dirLength); } else { dirName = "~"; } @@ -482,7 +490,7 @@ Tcl_EvalObjCmd(dummy, interp, objc, objv) objPtr = Tcl_ConcatObj(objc-1, objv+1); result = Tcl_EvalObj(interp, objPtr); - TclDecrRefCount(objPtr); /* we're done with the object */ + Tcl_DecrRefCount(objPtr); /* we're done with the object */ } if (result == TCL_ERROR) { char msg[60]; @@ -612,7 +620,7 @@ Tcl_ExprObjCmd(dummy, interp, objc, objv) * Free allocated resources. */ - TclDecrRefCount(objPtr); + Tcl_DecrRefCount(objPtr); return result; } @@ -790,8 +798,8 @@ enum {FILE_ATIME, FILE_ATTRIBUTES, FILE_COPY, FILE_DELETE, FILE_DIRNAME, } /* - * Return the last component, unless it is the only component, and it - * is the root of an absolute path. + * Return the last component, unless it is the only component, + * and it is the root of an absolute path. */ if (pargc > 0) { @@ -826,10 +834,10 @@ enum {FILE_ATIME, FILE_ATTRIBUTES, FILE_COPY, FILE_DELETE, FILE_DIRNAME, errorString = "extension name"; goto not3Args; } - extension = TclGetExtension(Tcl_GetStringFromObj(objv[2], &length)); + extension = TclGetExtension(Tcl_GetStringFromObj(objv[2],&length)); if (extension != NULL) { - Tcl_SetStringObj(resultPtr, extension, (int) strlen(extension)); + Tcl_SetStringObj(resultPtr, extension, (int)strlen(extension)); } goto done; case FILE_PATHTYPE: @@ -878,7 +886,8 @@ enum {FILE_ATIME, FILE_ATTRIBUTES, FILE_COPY, FILE_DELETE, FILE_DIRNAME, pargv[i - 2] = Tcl_GetStringFromObj(objv[i], &length); } Tcl_JoinPath(objc - 2, pargv, &buffer); - Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&buffer), buffer.length); + Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&buffer), + buffer.length); ckfree((char *) pargv); Tcl_DStringFree(&buffer); goto done; @@ -930,7 +939,11 @@ enum {FILE_ATIME, FILE_ATTRIBUTES, FILE_COPY, FILE_DELETE, FILE_DIRNAME, case FILE_NATIVENAME: fileName = Tcl_TranslateFileName(interp, Tcl_GetStringFromObj(objv[2], &length), &buffer); - Tcl_SetStringObj(resultPtr, fileName, -1); + if (fileName == NULL) { + result = TCL_ERROR ; + } else { + Tcl_SetStringObj(resultPtr, fileName, -1); + } goto done; } @@ -950,8 +963,16 @@ enum {FILE_ATIME, FILE_ATTRIBUTES, FILE_COPY, FILE_DELETE, FILE_DIRNAME, } mode = R_OK; checkAccess: - Tcl_SetBooleanObj(resultPtr, !((fileName == NULL) - || (access(fileName, mode) == -1))); + /* + * The result might have been set within Tcl_TranslateFileName + * (like no such user "blah" for file exists ~blah) + * but we don't want to flag an error in that case. + */ + if (fileName == NULL) { + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); + } else { + Tcl_SetBooleanObj(resultPtr, (access(fileName, mode) != -1)); + } goto done; case FILE_WRITABLE: if (objc != 3) { @@ -1237,7 +1258,8 @@ StoreStatData(interp, varName, statPtr) return TCL_ERROR; } if (Tcl_SetVar2(interp, varName, "type", - GetTypeFromMode((int) statPtr->st_mode), TCL_LEAVE_ERR_MSG) == NULL) { + GetTypeFromMode((int) statPtr->st_mode), TCL_LEAVE_ERR_MSG) + == NULL) { return TCL_ERROR; } return TCL_OK; @@ -1343,7 +1365,7 @@ Tcl_ForCmd(dummy, interp, argc, argv) if ((result != TCL_OK) && (result != TCL_CONTINUE)) { if (result == TCL_ERROR) { char msg[60]; - sprintf(msg, "\n (\"for\" body line %d)", interp->errorLine); + sprintf(msg, "\n (\"for\" body line %d)",interp->errorLine); Tcl_AddErrorInfo(interp, msg); } break; @@ -1398,13 +1420,24 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv) int v; /* v selects a loop variable */ int numLists; /* Count of value lists */ Tcl_Obj *bodyPtr; - -#define STATIC_SIZE 4 - int indexArray[STATIC_SIZE]; /* Array of value list indices */ - int varcListArray[STATIC_SIZE]; /* # loop variables per list */ - Tcl_Obj **varvListArray[STATIC_SIZE]; /* Array of variable name lists */ - int argcListArray[STATIC_SIZE]; /* Array of value list sizes */ - Tcl_Obj **argvListArray[STATIC_SIZE]; /* Array of value lists */ + + /* + * We copy the argument object pointers into a local array to avoid + * the problem that "objv" might become invalid. It is a pointer into + * the evaluation stack and that stack might be grown and reallocated + * if the loop body requires a large amount of stack space. + */ + +#define NUM_ARGS 9 + Tcl_Obj *(argObjStorage[NUM_ARGS]); + Tcl_Obj **argObjv = argObjStorage; + +#define STATIC_LIST_SIZE 4 + int indexArray[STATIC_LIST_SIZE]; /* Array of value list indices */ + int varcListArray[STATIC_LIST_SIZE]; /* # loop variables per list */ + Tcl_Obj **varvListArray[STATIC_LIST_SIZE]; /* Array of var name lists */ + int argcListArray[STATIC_LIST_SIZE]; /* Array of value list sizes */ + Tcl_Obj **argvListArray[STATIC_LIST_SIZE]; /* Array of value lists */ int *index = indexArray; int *varcList = varcListArray; @@ -1419,6 +1452,18 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv) } /* + * Create the object argument array "argObjv". Make sure argObjv is + * large enough to hold the objc arguments. + */ + + if (objc > NUM_ARGS) { + argObjv = (Tcl_Obj **) ckalloc(objc * sizeof(Tcl_Obj *)); + } + for (i = 0; i < objc; i++) { + argObjv[i] = objv[i]; + } + + /* * Manage numList parallel value lists. * argvList[i] is a value list counted by argcList[i] * varvList[i] is the list of variables associated with the value list @@ -1427,7 +1472,7 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv) */ numLists = (objc-2)/2; - if (numLists > STATIC_SIZE) { + if (numLists > STATIC_LIST_SIZE) { index = (int *) ckalloc(numLists * sizeof(int)); varcList = (int *) ckalloc(numLists * sizeof(int)); varvList = (Tcl_Obj ***) ckalloc(numLists * sizeof(Tcl_Obj **)); @@ -1449,7 +1494,7 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv) maxj = 0; for (i = 0; i < numLists; i++) { - result = Tcl_ListObjGetElements(interp, objv[1+i*2], + result = Tcl_ListObjGetElements(interp, argObjv[1+i*2], &varcList[i], &varvList[i]); if (result != TCL_OK) { goto done; @@ -1461,7 +1506,7 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv) goto done; } - result = Tcl_ListObjGetElements(interp, objv[2+i*2], + result = Tcl_ListObjGetElements(interp, argObjv[2+i*2], &argcList[i], &argvList[i]); if (result != TCL_OK) { goto done; @@ -1481,9 +1526,30 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv) * If some value lists run out of values, set loop vars to "" */ - bodyPtr = objv[objc-1]; + bodyPtr = argObjv[objc-1]; for (j = 0; j < maxj; j++) { for (i = 0; i < numLists; i++) { + /* + * If a variable or value list object has been converted to + * another kind of Tcl object, convert it back to a list object + * and refetch the pointer to its element array. + */ + + if (argObjv[1+i*2]->typePtr != &tclListType) { + result = Tcl_ListObjGetElements(interp, argObjv[1+i*2], + &varcList[i], &varvList[i]); + if (result != TCL_OK) { + panic("Tcl_ForeachObjCmd: could not reconvert variable list %d to a list object\n", i); + } + } + if (argObjv[2+i*2]->typePtr != &tclListType) { + result = Tcl_ListObjGetElements(interp, argObjv[2+i*2], + &argcList[i], &argvList[i]); + if (result != TCL_OK) { + panic("Tcl_ForeachObjCmd: could not reconvert value list %d to a list object\n", i); + } + } + for (v = 0; v < varcList[i]; v++) { int k = index[i]++; Tcl_Obj *valuePtr, *varValuePtr; @@ -1536,21 +1602,25 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv) } done: - if (numLists > STATIC_SIZE) { + if (numLists > STATIC_LIST_SIZE) { ckfree((char *) index); ckfree((char *) varcList); ckfree((char *) argcList); ckfree((char *) varvList); ckfree((char *) argvList); } + if (argObjv != argObjStorage) { + ckfree((char *) argObjv); + } return result; -#undef STATIC_SIZE +#undef STATIC_LIST_SIZE +#undef NUM_ARGS } /* *---------------------------------------------------------------------- * - * Tcl_FormatCmd -- + * Tcl_FormatObjCmd -- * * This procedure is invoked to process the "format" Tcl command. * See the user documentation for details on what it does. @@ -1566,14 +1636,16 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv) /* ARGSUSED */ int -Tcl_FormatCmd(dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ +Tcl_FormatObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { register char *format; /* Used to read characters from the format * string. */ + int formatLen; /* The length of the format string */ + char *endPtr; /* Points to the last char in format array */ char newFormat[40]; /* A new format specifier is generated here. */ int width; /* Field width from field specifier, or 0 if * no width given. */ @@ -1595,17 +1667,19 @@ Tcl_FormatCmd(dummy, interp, argc, argv) # define INT_VALUE 0 # define PTR_VALUE 1 # define DOUBLE_VALUE 2 - char *dst = interp->result; /* Where result is stored. Starts off at - * interp->resultSpace, but may get dynamically - * re-allocated if this isn't enough. */ - int dstSize = 0; /* Number of non-null characters currently - * stored at dst. */ - int dstSpace = TCL_RESULT_SIZE; - /* Total amount of storage space available - * in dst (not including null terminator. */ +# define MAX_FLOAT_SIZE 320 + + Tcl_Obj *resultPtr; /* Where result is stored finally. */ + char staticBuf[MAX_FLOAT_SIZE]; + /* A static buffer to copy the format results + * into */ + char *dst = staticBuf; /* The buffer that sprintf writes into each + * time the format processes a specifier */ + int dstSize = MAX_FLOAT_SIZE; + /* The size of the dst buffer */ int noPercent; /* Special case for speed: indicates there's - * no field specifier, just a string to copy. */ - int argIndex; /* Index of argument to substitute next. */ + * no field specifier, just a string to copy.*/ + int objIndex; /* Index of argument to substitute next. */ int gotXpg = 0; /* Non-zero means that an XPG3 %n$-style * specifier has been seen. */ int gotSequential = 0; /* Non-zero means that a regular sequential @@ -1620,20 +1694,25 @@ Tcl_FormatCmd(dummy, interp, argc, argv) * 1. this procedure can't trust its arguments. * 2. we must be able to provide a large enough result area to hold * whatever's generated. This is hard to estimate. - * 2. there's no way to move the arguments from argv to the call + * 2. there's no way to move the arguments from objv to the call * to sprintf in a reasonable way. This is particularly nasty * because some of the arguments may be two-word values (doubles). * So, what happens here is to scan the format string one % group * at a time, making many individual calls to sprintf. */ - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " formatString ?arg arg ...?\"", (char *) NULL); + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, + "formatString ?arg arg ...?"); return TCL_ERROR; } - argIndex = 2; - for (format = argv[1]; *format != 0; ) { + + format = Tcl_GetStringFromObj(objv[1], &formatLen); + endPtr = format + formatLen; + resultPtr = Tcl_NewObj(); + objIndex = 2; + + while (format < endPtr) { register char *newPtr = newFormat; width = precision = noPercent = useShort = 0; @@ -1642,17 +1721,12 @@ Tcl_FormatCmd(dummy, interp, argc, argv) /* * Get rid of any characters before the next field specifier. */ - if (*format != '%') { - register char *p; - - ptrValue = p = format; - while ((*format != '%') && (*format != 0)) { - *p = *format; - p++; + ptrValue = format; + while ((*format != '%') && (format < endPtr)) { format++; } - size = p - ptrValue; + size = format - ptrValue; noPercent = 1; goto doField; } @@ -1670,7 +1744,6 @@ Tcl_FormatCmd(dummy, interp, argc, argv) * will be needed to store the result, and substitute for * "*" size specifiers. */ - *newPtr = '%'; newPtr++; format++; @@ -1692,8 +1765,8 @@ Tcl_FormatCmd(dummy, interp, argc, argv) if (gotSequential) { goto mixedXPG; } - argIndex = tmp+1; - if ((argIndex < 2) || (argIndex >= argc)) { + objIndex = tmp+1; + if ((objIndex < 2) || (objIndex >= objc)) { goto badIndex; } goto xpgCheckDone; @@ -1716,13 +1789,14 @@ Tcl_FormatCmd(dummy, interp, argc, argv) width = strtoul(format, &end, 10); format = end; } else if (*format == '*') { - if (argIndex >= argc) { + if (objIndex >= objc) { goto badIndex; } - if (Tcl_GetInt(interp, argv[argIndex], &width) != TCL_OK) { + if (Tcl_GetIntFromObj(interp, objv[objIndex], + &width) != TCL_OK) { goto fmtError; } - argIndex++; + objIndex++; format++; } if (width > 100000) { @@ -1751,13 +1825,14 @@ Tcl_FormatCmd(dummy, interp, argc, argv) precision = strtoul(format, &end, 10); format = end; } else if (*format == '*') { - if (argIndex >= argc) { + if (objIndex >= objc) { goto badIndex; } - if (Tcl_GetInt(interp, argv[argIndex], &precision) != TCL_OK) { + if (Tcl_GetIntFromObj(interp, objv[objIndex], + &precision) != TCL_OK) { goto fmtError; } - argIndex++; + objIndex++; format++; } if (precision != 0) { @@ -1777,7 +1852,7 @@ Tcl_FormatCmd(dummy, interp, argc, argv) *newPtr = *format; newPtr++; *newPtr = 0; - if (argIndex >= argc) { + if (objIndex >= objc) { goto badIndex; } switch (*format) { @@ -1788,20 +1863,19 @@ Tcl_FormatCmd(dummy, interp, argc, argv) case 'u': case 'x': case 'X': - if (Tcl_GetInt(interp, argv[argIndex], (int *) &intValue) - != TCL_OK) { + if (Tcl_GetIntFromObj(interp, objv[objIndex], + (int *) &intValue) != TCL_OK) { goto fmtError; } whichValue = INT_VALUE; size = 40 + precision; break; case 's': - ptrValue = argv[argIndex]; - size = strlen(argv[argIndex]); + ptrValue = Tcl_GetStringFromObj(objv[objIndex], &size); break; case 'c': - if (Tcl_GetInt(interp, argv[argIndex], (int *) &intValue) - != TCL_OK) { + if (Tcl_GetIntFromObj(interp, objv[objIndex], + (int *) &intValue) != TCL_OK) { goto fmtError; } whichValue = INT_VALUE; @@ -1812,12 +1886,12 @@ Tcl_FormatCmd(dummy, interp, argc, argv) case 'f': case 'g': case 'G': - if (Tcl_GetDouble(interp, argv[argIndex], &doubleValue) - != TCL_OK) { + if (Tcl_GetDoubleFromObj(interp, objv[objIndex], + &doubleValue) != TCL_OK) { goto fmtError; } whichValue = DOUBLE_VALUE; - size = 320; + size = MAX_FLOAT_SIZE; if (precision > 10) { size += precision; } @@ -1829,14 +1903,13 @@ Tcl_FormatCmd(dummy, interp, argc, argv) goto fmtError; default: { - char buf[80]; - + char buf[40]; sprintf(buf, "bad field specifier \"%c\"", *format); Tcl_SetResult(interp, buf, TCL_VOLATILE); goto fmtError; } } - argIndex++; + objIndex++; format++; /* @@ -1848,62 +1921,56 @@ Tcl_FormatCmd(dummy, interp, argc, argv) if (width > size) { size = width; } - if ((dstSize + size) > dstSpace) { - char *newDst; - int newSpace; - - newSpace = 2*(dstSize + size); - newDst = (char *) ckalloc((unsigned) newSpace+1); - if (dstSize != 0) { - memcpy((VOID *) newDst, (VOID *) dst, (size_t) dstSize); - } - if (dstSpace != TCL_RESULT_SIZE) { - ckfree(dst); - } - dst = newDst; - dstSpace = newSpace; - } if (noPercent) { - memcpy((VOID *) (dst+dstSize), (VOID *) ptrValue, (size_t) size); - dstSize += size; - dst[dstSize] = 0; + Tcl_AppendToObj(resultPtr, ptrValue, size); } else { + if (size > dstSize) { + if (dst != staticBuf) { + ckfree(dst); + } + dst = (char *) ckalloc((unsigned) (size + 1)); + dstSize = size; + } + if (whichValue == DOUBLE_VALUE) { - sprintf(dst+dstSize, newFormat, doubleValue); + sprintf(dst, newFormat, doubleValue); } else if (whichValue == INT_VALUE) { if (useShort) { - sprintf(dst+dstSize, newFormat, (short) intValue); + sprintf(dst, newFormat, (short) intValue); } else { - sprintf(dst+dstSize, newFormat, intValue); + sprintf(dst, newFormat, intValue); } } else { - sprintf(dst+dstSize, newFormat, ptrValue); + sprintf(dst, newFormat, ptrValue); } - dstSize += strlen(dst+dstSize); + Tcl_AppendToObj(resultPtr, dst, -1); } } - if (dstSpace != TCL_RESULT_SIZE) { - Tcl_SetResult(interp, dst, TCL_DYNAMIC); - } else { - Tcl_SetResult(interp, dst, TCL_STATIC); + Tcl_SetObjResult(interp, resultPtr); + if(dst != staticBuf) { + ckfree(dst); } return TCL_OK; mixedXPG: - interp->result = "cannot mix \"%\" and \"%n$\" conversion specifiers"; + Tcl_SetResult(interp, + "cannot mix \"%\" and \"%n$\" conversion specifiers", TCL_STATIC); goto fmtError; badIndex: if (gotXpg) { - interp->result = "\"%n$\" argument index out of range"; + Tcl_SetResult(interp, + "\"%n$\" argument index out of range", TCL_STATIC); } else { - interp->result = "not enough arguments for all format specifiers"; + Tcl_SetResult(interp, + "not enough arguments for all format specifiers", TCL_STATIC); } fmtError: - if (dstSpace != TCL_RESULT_SIZE) { - ckfree(dst); + if(dst != staticBuf) { + ckfree(dst); } + Tcl_DecrRefCount(resultPtr); return TCL_ERROR; } diff --git a/contrib/tcl/generic/tclCmdIL.c b/contrib/tcl/generic/tclCmdIL.c index 18342f3..6503d35 100644 --- a/contrib/tcl/generic/tclCmdIL.c +++ b/contrib/tcl/generic/tclCmdIL.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclCmdIL.c 1.163 97/06/13 18:16:52 + * SCCS: @(#) tclCmdIL.c 1.168 97/07/29 12:52:40 */ #include "tclInt.h" @@ -55,7 +55,7 @@ typedef struct SortInfo { Tcl_DString compareCmd; /* The Tcl comparison command when sortMode * is SORTMODE_COMMAND. Pre-initialized to * hold base of command.*/ - long index; /* If the -index option was specified, this + int index; /* If the -index option was specified, this * holds the index of the list element * to extract for comparison. If -index * wasn't specified, this is -1. */ @@ -472,7 +472,7 @@ InfoArgsCmd(dummy, interp, objc, objv) Tcl_Obj *listObjPtr; if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "args procname"); + Tcl_WrongNumArgs(interp, 2, objv, "procname"); return TCL_ERROR; } @@ -532,7 +532,7 @@ InfoBodyCmd(dummy, interp, objc, objv) Proc *procPtr; if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "body procname"); + Tcl_WrongNumArgs(interp, 2, objv, "procname"); return TCL_ERROR; } @@ -578,7 +578,7 @@ InfoCmdCountCmd(dummy, interp, objc, objv) Interp *iPtr = (Interp *) interp; if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "cmdcount"); + Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } @@ -659,7 +659,7 @@ InfoCommandsCmd(dummy, interp, objc, objv) specificNsInPattern = (strcmp(simplePattern, pattern) != 0); } } else { - Tcl_WrongNumArgs(interp, 1, objv, "commands ?pattern?"); + Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); return TCL_ERROR; } @@ -749,7 +749,7 @@ InfoCompleteCmd(dummy, interp, objc, objv) char *command; if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "complete command"); + Tcl_WrongNumArgs(interp, 2, objv, "command"); return TCL_ERROR; } @@ -797,7 +797,7 @@ InfoDefaultCmd(dummy, interp, objc, objv) Tcl_Obj *valueObjPtr; if (objc != 5) { - Tcl_WrongNumArgs(interp, 1, objv, "default procname arg varname"); + Tcl_WrongNumArgs(interp, 2, objv, "procname arg varname"); return TCL_ERROR; } @@ -877,7 +877,7 @@ InfoExistsCmd(dummy, interp, objc, objv) Var *varPtr, *arrayPtr; if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "exists varName"); + Tcl_WrongNumArgs(interp, 2, objv, "varName"); return TCL_ERROR; } @@ -933,7 +933,7 @@ InfoGlobalsCmd(dummy, interp, objc, objv) } else if (objc == 3) { pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL); } else { - Tcl_WrongNumArgs(interp, 1, objv, "globals ?pattern?"); + Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); return TCL_ERROR; } @@ -988,7 +988,7 @@ InfoHostnameCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "hostname"); + Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } @@ -1065,7 +1065,7 @@ InfoLevelCmd(dummy, interp, objc, objv) return TCL_OK; } - Tcl_WrongNumArgs(interp, 1, objv, "level ?number?"); + Tcl_WrongNumArgs(interp, 2, objv, "?number?"); return TCL_ERROR; } @@ -1100,7 +1100,7 @@ InfoLibraryCmd(dummy, interp, objc, objv) char *libDirName; if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "library"); + Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } @@ -1146,7 +1146,7 @@ InfoLoadedCmd(dummy, interp, objc, objv) int result; if ((objc != 2) && (objc != 3)) { - Tcl_WrongNumArgs(interp, 1, objv, "loaded ?interp?"); + Tcl_WrongNumArgs(interp, 2, objv, "?interp?"); return TCL_ERROR; } @@ -1201,7 +1201,7 @@ InfoLocalsCmd(dummy, interp, objc, objv) } else if (objc == 3) { pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL); } else { - Tcl_WrongNumArgs(interp, 1, objv, "locals ?pattern?"); + Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); return TCL_ERROR; } @@ -1280,7 +1280,7 @@ InfoNameOfExecutableCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "nameofexecutable"); + Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } @@ -1321,7 +1321,7 @@ InfoPatchLevelCmd(dummy, interp, objc, objv) char *patchlevel; if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "patchlevel"); + Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } @@ -1374,7 +1374,7 @@ InfoProcsCmd(dummy, interp, objc, objv) } else if (objc == 3) { pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL); } else { - Tcl_WrongNumArgs(interp, 1, objv, "procs ?pattern?"); + Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); return TCL_ERROR; } @@ -1430,7 +1430,7 @@ InfoScriptCmd(dummy, interp, objc, objv) { Interp *iPtr = (Interp *) interp; if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "script"); + Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } @@ -1469,7 +1469,7 @@ InfoSharedlibCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "sharedlibextension"); + Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } @@ -1509,7 +1509,7 @@ InfoTclVersionCmd(dummy, interp, objc, objv) char *version; if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "tclversion"); + Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } @@ -1597,7 +1597,7 @@ InfoVarsCmd(dummy, interp, objc, objv) specificNsInPattern = (strcmp(simplePattern, pattern) != 0); } } else { - Tcl_WrongNumArgs(interp, 1, objv, "vars ?pattern?"); + Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); return TCL_ERROR; } @@ -1624,7 +1624,8 @@ InfoVarsCmd(dummy, interp, objc, objv) entryPtr = Tcl_FirstHashEntry(&nsPtr->varTable, &search); while (entryPtr != NULL) { varPtr = (Var *) Tcl_GetHashValue(entryPtr); - if (!TclIsVarUndefined(varPtr)) { + if (!TclIsVarUndefined(varPtr) + || (varPtr->flags & VAR_NAMESPACE_VAR)) { varName = Tcl_GetHashKey(&nsPtr->varTable, entryPtr); if ((simplePattern == NULL) || Tcl_StringMatch(varName, simplePattern)) { @@ -1654,7 +1655,8 @@ InfoVarsCmd(dummy, interp, objc, objv) entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search); while (entryPtr != NULL) { varPtr = (Var *) Tcl_GetHashValue(entryPtr); - if (!TclIsVarUndefined(varPtr)) { + if (!TclIsVarUndefined(varPtr) + || (varPtr->flags & VAR_NAMESPACE_VAR)) { varName = Tcl_GetHashKey(&globalNsPtr->varTable, entryPtr); if ((simplePattern == NULL) @@ -2426,14 +2428,9 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv) -1); return TCL_ERROR; } - if (Tcl_GetLongFromObj(interp, objv[i+1], &sortInfo.index) + if (TclGetIntForIndex(interp, objv[i+1], -2, &sortInfo.index) != TCL_OK) { - if (strcmp("end", Tcl_GetStringFromObj(objv[i+1], &dummy)) - == 0) { - sortInfo.index = -2; - } else { - return TCL_ERROR; - } + return TCL_ERROR; } cmdPtr = objv[i+1]; i++; @@ -2675,7 +2672,7 @@ SortCompare(objPtr1, objPtr2, infoPtr) if (objPtr == NULL) { objPtr = objPtr1; missingElement: - sprintf(buffer, "%ld", infoPtr->index); + sprintf(buffer, "%d", infoPtr->index); Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp), "element ", buffer, " missing from sublist \"", Tcl_GetStringFromObj(objPtr, (int *) NULL), diff --git a/contrib/tcl/generic/tclCmdMZ.c b/contrib/tcl/generic/tclCmdMZ.c index ec1f737..9ab2c82 100644 --- a/contrib/tcl/generic/tclCmdMZ.c +++ b/contrib/tcl/generic/tclCmdMZ.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclCmdMZ.c 1.99 97/05/19 17:37:17 + * SCCS: @(#) tclCmdMZ.c 1.102 97/08/13 10:06:58 */ #include "tclInt.h" @@ -953,7 +953,7 @@ Tcl_SourceObjCmd(dummy, interp, objc, objv) /* *---------------------------------------------------------------------- * - * Tcl_SplitCmd -- + * Tcl_SplitObjCmd -- * * This procedure is invoked to process the "split" Tcl command. * See the user documentation for details on what it does. @@ -969,60 +969,63 @@ Tcl_SourceObjCmd(dummy, interp, objc, objv) /* ARGSUSED */ int -Tcl_SplitCmd(dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ +Tcl_SplitObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - char *splitChars; register char *p, *p2; - char *elementStart; + char *splitChars, *string, *elementStart; + int splitCharLen, stringLen, i, j; + Tcl_Obj *listPtr; - if (argc == 2) { + if (objc == 2) { splitChars = " \n\t\r"; - } else if (argc == 3) { - splitChars = argv[2]; + splitCharLen = 4; + } else if (objc == 3) { + splitChars = Tcl_GetStringFromObj(objv[2], &splitCharLen); } else { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " string ?splitChars?\"", (char *) NULL); + Tcl_WrongNumArgs(interp, 1, objv, "string ?splitChars?"); return TCL_ERROR; } + string = Tcl_GetStringFromObj(objv[1], &stringLen); + listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + /* * Handle the special case of splitting on every character. */ - if (*splitChars == 0) { - char string[2]; - string[1] = 0; - for (p = argv[1]; *p != 0; p++) { - string[0] = *p; - Tcl_AppendElement(interp, string); + if (splitCharLen == 0) { + for (i = 0, p = string; i < stringLen; i++, p++) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(p, 1)); } - return TCL_OK; - } - - /* - * Normal case: split on any of a given set of characters. - * Discard instances of the split characters. - */ + } else { + /* + * Normal case: split on any of a given set of characters. + * Discard instances of the split characters. + */ - for (p = elementStart = argv[1]; *p != 0; p++) { - char c = *p; - for (p2 = splitChars; *p2 != 0; p2++) { - if (*p2 == c) { - *p = 0; - Tcl_AppendElement(interp, elementStart); - *p = c; - elementStart = p+1; - break; + for (i = 0, p = elementStart = string; i < stringLen; i++, p++) { + for (j = 0, p2 = splitChars; j < splitCharLen; j++, p2++) { + if (*p2 == *p) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(elementStart, (p-elementStart))); + elementStart = p+1; + break; + } } } + if (p != string) { + int remainingChars = stringLen - (elementStart-string); + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(elementStart, remainingChars)); + } } - if (p != argv[1]) { - Tcl_AppendElement(interp, elementStart); - } + + Tcl_SetObjResult(interp, listPtr); return TCL_OK; } @@ -1132,15 +1135,17 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } + match = -1; string1 = Tcl_GetStringFromObj(objv[2], &length1); string2 = Tcl_GetStringFromObj(objv[3], &length2); - match = -1; - end = string2 + length2 - length1 + 1; - for (p = string2; p < end; p++) { - if (memcmp(string1, p, (unsigned) length1) == 0) { - match = p - string2; - if (first) { - break; + if (length1 > 0) { + end = string2 + length2 - length1 + 1; + for (p = string2; p < end; p++) { + if (memcmp(string1, p, (unsigned) length1) == 0) { + match = p - string2; + if (first) { + break; + } } } } @@ -2066,7 +2071,7 @@ TraceVarProc(clientData, interp, name1, name2, flags) oldObjResultPtr = iPtr->objResultPtr; iPtr->objResultPtr = saveObjPtr; /* was incremented above */ - TclDecrRefCount(oldObjResultPtr); + Tcl_DecrRefCount(oldObjResultPtr); Tcl_DecrRefCount(dummy.objResultPtr); dummy.objResultPtr = NULL; diff --git a/contrib/tcl/generic/tclCompExpr.c b/contrib/tcl/generic/tclCompExpr.c index 4113879..74b12c1 100644 --- a/contrib/tcl/generic/tclCompExpr.c +++ b/contrib/tcl/generic/tclCompExpr.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclCompExpr.c 1.30 97/06/13 18:17:20 + * SCCS: @(#) tclCompExpr.c 1.31 97/08/07 10:14:07 */ #include "tclInt.h" @@ -69,7 +69,14 @@ typedef struct ExprInfo { * primary to a number if possible. */ int exprIsJustVarRef; /* Set 1 if the expr consists of just a * variable reference as in the expression - * of "if $b then...". Otherwise 0. Used + * of "if $b then...". Otherwise 0. If 1 the + * expr is compiled out-of-line in order to + * implement expr's 2 level substitution + * semantics properly. */ + int exprIsComparison; /* Set 1 if the top-level operator in the + * expr is a comparison. Otherwise 0. If 1, + * because the operands might be strings, + * the expr is compiled out-of-line in order * to implement expr's 2 level substitution * semantics properly. */ } ExprInfo; @@ -242,6 +249,11 @@ static int GetToken _ANSI_ARGS_((Tcl_Interp *interp, * Otherwise it is set 0. This is used to implement Tcl's two level * expression substitution semantics properly. * + * envPtr->exprIsComparison is set 1 if the top-level operator in the + * expr is a comparison. Otherwise it is set 0. If 1, because the + * operands might be strings, the expr is compiled out-of-line in order + * to implement expr's 2 level substitution semantics properly. + * * Side effects: * Adds instructions to envPtr to evaluate the expression at runtime. * @@ -307,6 +319,7 @@ TclCompileExpr(interp, string, lastChar, flags, envPtr) info.lastChar = lastChar; info.hasOperators = 0; info.exprIsJustVarRef = 1; /* will be set 0 if anything else is seen */ + info.exprIsComparison = 0; /* set 1 if topmost operator is <,==,etc. */ /* * Get the first token then compile an expression. @@ -343,6 +356,7 @@ TclCompileExpr(interp, string, lastChar, flags, envPtr) envPtr->termOffset = (info.next - string); envPtr->maxStackDepth = maxDepth; envPtr->exprIsJustVarRef = info.exprIsJustVarRef; + envPtr->exprIsComparison = info.exprIsComparison; return result; } @@ -424,6 +438,7 @@ CompileCondExpr(interp, infoPtr, flags, envPtr) infoPtr->hasOperators = 0; infoPtr->exprIsJustVarRef = 0; + infoPtr->exprIsComparison = 0; result = CompileCondExpr(interp, infoPtr, flags, envPtr); if (result != TCL_OK) { goto done; @@ -495,6 +510,12 @@ CompileCondExpr(interp, infoPtr, flags, envPtr) TclFixupForwardJump(envPtr, &jumpAroundThenFixup, jumpDist, 127); infoPtr->hasOperators = 1; + + /* + * A comparison is not the top-level operator in this expression. + */ + + infoPtr->exprIsComparison = 0; } done: @@ -658,7 +679,12 @@ CompileLorExpr(interp, infoPtr, flags, envPtr) TclFixupForwardJump(envPtr, &(jumpFixupArray.fixup[fixupIndex]), jumpDist, 127); } + /* + * We get here only if one or more ||'s appear as top-level operators. + */ + done: + infoPtr->exprIsComparison = 0; TclFreeJumpFixupArray(&jumpFixupArray); envPtr->maxStackDepth = maxDepth; return result; @@ -817,10 +843,16 @@ CompileLandExpr(interp, infoPtr, flags, envPtr) fixupIndex = (j - 1); /* process closest jump first */ currCodeOffset = TclCurrCodeOffset(); jumpDist = (currCodeOffset - jumpFixupArray.fixup[fixupIndex].codeOffset); - TclFixupForwardJump(envPtr, &(jumpFixupArray.fixup[fixupIndex]), jumpDist, 127); + TclFixupForwardJump(envPtr, &(jumpFixupArray.fixup[fixupIndex]), + jumpDist, 127); } + /* + * We get here only if one or more &&'s appear as top-level operators. + */ + done: + infoPtr->exprIsComparison = 0; TclFreeJumpFixupArray(&jumpFixupArray); envPtr->maxStackDepth = maxDepth; return result; @@ -883,6 +915,12 @@ CompileBitOrExpr(interp, infoPtr, flags, envPtr) maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); TclEmitOpcode(INST_BITOR, envPtr); + + /* + * A comparison is not the top-level operator in this expression. + */ + + infoPtr->exprIsComparison = 0; } done: @@ -947,6 +985,12 @@ CompileBitXorExpr(interp, infoPtr, flags, envPtr) maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); TclEmitOpcode(INST_BITXOR, envPtr); + + /* + * A comparison is not the top-level operator in this expression. + */ + + infoPtr->exprIsComparison = 0; } done: @@ -1011,6 +1055,12 @@ CompileBitAndExpr(interp, infoPtr, flags, envPtr) maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); TclEmitOpcode(INST_BITAND, envPtr); + + /* + * A comparison is not the top-level operator in this expression. + */ + + infoPtr->exprIsComparison = 0; } done: @@ -1082,6 +1132,12 @@ CompileEqualityExpr(interp, infoPtr, flags, envPtr) } op = infoPtr->token; + + /* + * A comparison _is_ the top-level operator in this expression. + */ + + infoPtr->exprIsComparison = 1; } done: @@ -1162,6 +1218,12 @@ CompileRelationalExpr(interp, infoPtr, flags, envPtr) } op = infoPtr->token; + + /* + * A comparison _is_ the top-level operator in this expression. + */ + + infoPtr->exprIsComparison = 1; } done: @@ -1233,6 +1295,12 @@ CompileShiftExpr(interp, infoPtr, flags, envPtr) } op = infoPtr->token; + + /* + * A comparison is not the top-level operator in this expression. + */ + + infoPtr->exprIsComparison = 0; } done: @@ -1304,6 +1372,12 @@ CompileAddExpr(interp, infoPtr, flags, envPtr) } op = infoPtr->token; + + /* + * A comparison is not the top-level operator in this expression. + */ + + infoPtr->exprIsComparison = 0; } done: @@ -1377,6 +1451,12 @@ CompileMultiplyExpr(interp, infoPtr, flags, envPtr) } op = infoPtr->token; + + /* + * A comparison is not the top-level operator in this expression. + */ + + infoPtr->exprIsComparison = 0; } done: @@ -1449,6 +1529,12 @@ CompileUnaryExpr(interp, infoPtr, flags, envPtr) TclEmitOpcode(INST_LNOT, envPtr); break; } + + /* + * A comparison is not the top-level operator in this expression. + */ + + infoPtr->exprIsComparison = 0; } else { /* must be a primaryExpr */ result = CompilePrimaryExpr(interp, infoPtr, flags, envPtr); if (result != TCL_OK) { @@ -1583,6 +1669,7 @@ CompilePrimaryExpr(interp, infoPtr, flags, envPtr) if (result != TCL_OK) { goto done; } + infoPtr->exprIsComparison = 0; result = CompileCondExpr(interp, infoPtr, flags, envPtr); if (result != TCL_OK) { goto done; @@ -1722,6 +1809,7 @@ CompileMathFuncCall(interp, infoPtr, flags, envPtr) if (mathFuncPtr->numArgs > 0) { for (i = 0; ; i++) { + infoPtr->exprIsComparison = 0; result = CompileCondExpr(interp, infoPtr, flags, envPtr); if (result != TCL_OK) { goto done; @@ -1785,7 +1873,12 @@ CompileMathFuncCall(interp, infoPtr, flags, envPtr) TclEmitInstUInt1(INST_CALL_FUNC1, (mathFuncPtr->numArgs+1), envPtr); } + /* + * A comparison is not the top-level operator in this expression. + */ + done: + infoPtr->exprIsComparison = 0; envPtr->maxStackDepth = maxDepth; return result; diff --git a/contrib/tcl/generic/tclCompile.c b/contrib/tcl/generic/tclCompile.c index e8aa99c..d4fad0c 100644 --- a/contrib/tcl/generic/tclCompile.c +++ b/contrib/tcl/generic/tclCompile.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclCompile.c 1.61 97/06/23 18:43:46 + * SCCS: @(#) tclCompile.c 1.76 97/08/12 13:35:43 */ #include "tclInt.h" @@ -29,11 +29,26 @@ int tclTraceCompile = 0; static int traceInitialized = 0; /* - * Count of the number of compilations. + * Count of the number of compilations and various other compilation- + * related statistics. */ #ifdef TCL_COMPILE_STATS long tclNumCompilations = 0; +double tclTotalSourceBytes = 0.0; +double tclTotalCodeBytes = 0.0; + +double tclTotalInstBytes = 0.0; +double tclTotalObjBytes = 0.0; +double tclTotalExceptBytes = 0.0; +double tclTotalAuxBytes = 0.0; +double tclTotalCmdMapBytes = 0.0; + +double tclCurrentSourceBytes = 0.0; +double tclCurrentCodeBytes = 0.0; + +int tclSourceCount[32]; +int tclByteCodeCount[32]; #endif /* TCL_COMPILE_STATS */ /* @@ -365,6 +380,9 @@ static int CreateExceptionRange _ANSI_ARGS_(( static void DupByteCodeInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, Tcl_Obj *copyPtr)); static ClientData DupForeachInfo _ANSI_ARGS_((ClientData clientData)); +static unsigned char * EncodeCmdLocMap _ANSI_ARGS_(( + CompileEnv *envPtr, ByteCode *codePtr, + unsigned char *startPtr)); static void EnterCmdExtentData _ANSI_ARGS_(( CompileEnv *envPtr, int cmdNumber, int numSrcChars, int numCodeBytes)); @@ -377,6 +395,8 @@ static void FreeForeachInfo _ANSI_ARGS_(( static void FreeByteCodeInternalRep _ANSI_ARGS_(( Tcl_Obj *objPtr)); static void FreeArgInfo _ANSI_ARGS_((ArgInfo *argInfoPtr)); +static int GetCmdLocEncodingSize _ANSI_ARGS_(( + CompileEnv *envPtr)); static void InitArgInfo _ANSI_ARGS_((ArgInfo *argInfoPtr)); static int LookupCompiledLocal _ANSI_ARGS_(( char *name, int nameChars, int createIfNew, @@ -421,12 +441,11 @@ TclPrintByteCodeObj(interp, objPtr) Tcl_Obj *objPtr; /* The bytecode object to disassemble. */ { ByteCode* codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; - Proc *procPtr; - CmdLocation *mapPtr; - ExceptionRange *excRangeArrayPtr; - unsigned char *codeStart, *codeLimit, *pc, *start; - int numCmds, numRanges, cmd, maxChars, i; - char *source; + unsigned char *codeStart, *codeLimit, *pc; + unsigned char *codeDeltaNext, *codeLengthNext; + unsigned char *srcDeltaNext, *srcLengthNext; + int codeOffset, codeLen, srcOffset, srcLen; + int numCmds, numObjs, delta, objBytes, i; if (codePtr->refCount <= 0) { return; /* already freed */ @@ -434,28 +453,60 @@ TclPrintByteCodeObj(interp, objPtr) codeStart = codePtr->codeStart; codeLimit = (codeStart + codePtr->numCodeBytes); - source = codePtr->source; - procPtr = codePtr->procPtr; - numCmds = codePtr->numCommands; - numRanges = codePtr->numExcRanges; - mapPtr = codePtr->cmdMapPtr; - excRangeArrayPtr = codePtr->excRangeArrayPtr; - - fprintf(stdout, "\nByteCode 0x%x, ref ct %u, epoch %u, interp 0x%x, interp epoch %u\n", + numCmds = codePtr->numCommands; + numObjs = codePtr->numObjects; + + objBytes = (numObjs * sizeof(Tcl_Obj)); + for (i = 0; i < numObjs; i++) { + Tcl_Obj *litObjPtr = codePtr->objArrayPtr[i]; + if (litObjPtr->bytes != NULL) { + objBytes += litObjPtr->length; + } + } + + /* + * Print header lines describing the ByteCode. + */ + + fprintf(stdout, "\nByteCode 0x%x, ref ct %u, epoch %u, interp 0x%x(epoch %u)\n", (unsigned int) codePtr, codePtr->refCount, codePtr->compileEpoch, (unsigned int) codePtr->iPtr, codePtr->iPtr->compileEpoch); - if (procPtr != NULL) { + fprintf(stdout, " Source "); + TclPrintSource(stdout, codePtr->source, + TclMin(codePtr->numSrcChars, 70)); + fprintf(stdout, "\n Cmds %d, chars %d, inst %d, objs %u, aux %d, stk depth %u, code/src %.2f\n", + numCmds, codePtr->numSrcChars, codePtr->numCodeBytes, numObjs, + codePtr->numAuxDataItems, codePtr->maxStackDepth, + (codePtr->numSrcChars? + ((float)codePtr->totalSize)/((float)codePtr->numSrcChars) : 0.0)); + fprintf(stdout, " Code %d = %d(header)+%d(inst)+%d(objs)+%d(exc)+%d(aux)+%d(cmd map)\n", + codePtr->totalSize, sizeof(ByteCode), codePtr->numCodeBytes, + objBytes, (codePtr->numExcRanges * sizeof(ExceptionRange)), + (codePtr->numAuxDataItems * sizeof(AuxData)), + codePtr->numCmdLocBytes); + + /* + * If the ByteCode is the compiled body of a Tcl procedure, print + * information about that procedure. Note that we don't know the + * procedure's name since ByteCode's can be shared among procedures. + */ + + if (codePtr->procPtr != NULL) { + Proc *procPtr = codePtr->procPtr; int numCompiledLocals = procPtr->numCompiledLocals; fprintf(stdout, - " Proc 0x%x, ref ct=%d, %d args, %d compiled locals\n", + " Proc 0x%x, ref ct %d, args %d, compiled locals %d\n", (unsigned int) procPtr, procPtr->refCount, procPtr->numArgs, numCompiledLocals); if (numCompiledLocals > 0) { CompiledLocal *localPtr = procPtr->firstLocalPtr; for (i = 0; i < numCompiledLocals; i++) { - fprintf(stdout, " %d: frame index=%d, flags=0x%x%s%s", - i, localPtr->frameIndex, localPtr->flags, + fprintf(stdout, " %d: slot %d%s%s%s%s%s", + i, localPtr->frameIndex, + ((localPtr->flags & VAR_SCALAR)? ", scalar" : ""), + ((localPtr->flags & VAR_ARRAY)? ", array" : ""), + ((localPtr->flags & VAR_LINK)? ", link" : ""), (localPtr->isArg? ", arg" : ""), (localPtr->isTemp? ", temp" : "")); if (localPtr->isTemp) { @@ -467,21 +518,43 @@ TclPrintByteCodeObj(interp, objPtr) } } } - fprintf(stdout, " Source: "); - TclPrintSource(stdout, source, TclMin(codePtr->numSrcChars, 70)); - fprintf(stdout, "\n Chars=%d, bytes=%u, objs=%u, stk depth=%u, exc depth=%d, aux items=%d\n", - codePtr->numSrcChars, codePtr->numCodeBytes, - codePtr->numObjects, codePtr->maxStackDepth, - codePtr->maxExcRangeDepth, codePtr->numAuxDataItems); /* + * Print the ExceptionRange array. + */ + + if (codePtr->numExcRanges > 0) { + fprintf(stdout, " Exception ranges %d, depth %d:\n", + codePtr->numExcRanges, codePtr->maxExcRangeDepth); + for (i = 0; i < codePtr->numExcRanges; i++) { + ExceptionRange *rangePtr = &(codePtr->excRangeArrayPtr[i]); + fprintf(stdout, " %d: level %d, %s, pc %d-%d, ", + i, rangePtr->nestingLevel, + ((rangePtr->type == LOOP_EXCEPTION_RANGE)? "loop":"catch"), + rangePtr->codeOffset, + (rangePtr->codeOffset + rangePtr->numCodeBytes - 1)); + switch (rangePtr->type) { + case LOOP_EXCEPTION_RANGE: + fprintf(stdout, "continue %d, break %d\n", + rangePtr->continueOffset, rangePtr->breakOffset); + break; + case CATCH_EXCEPTION_RANGE: + fprintf(stdout, "catch %d\n", rangePtr->catchOffset); + break; + default: + panic("TclPrintSource: unrecognized ExceptionRange type %d\n", + rangePtr->type); + } + } + } + + /* * If there were no commands (e.g., an expression or an empty string - * was compiled), just print all instructions. + * was compiled), just print all instructions and return. */ if (numCmds == 0) { - start = codeStart; - pc = start; + pc = codeStart; while (pc < codeLimit) { fprintf(stdout, " "); pc += TclPrintInstruction(codePtr, pc); @@ -490,68 +563,128 @@ TclPrintByteCodeObj(interp, objPtr) } /* - * Print table giving the source and object locations for each command. + * Print table showing the code offset, source offset, and source + * length for each command. These are encoded as a sequence of bytes. */ - fprintf(stdout, " Commands=%d\n", numCmds); + fprintf(stdout, " Commands %d:", numCmds); + codeDeltaNext = codePtr->codeDeltaStart; + codeLengthNext = codePtr->codeLengthStart; + srcDeltaNext = codePtr->srcDeltaStart; + srcLengthNext = codePtr->srcLengthStart; + codeOffset = srcOffset = 0; for (i = 0; i < numCmds; i++) { - fprintf(stdout, " %d: source=%d-%d, code=%d-%d\n", - (i+1), mapPtr[i].srcOffset, - (mapPtr[i].srcOffset + mapPtr[i].numSrcChars - 1), - mapPtr[i].codeOffset, - (mapPtr[i].codeOffset + mapPtr[i].numCodeBytes - 1)); - } - - /* - * Print the ExceptionRange array. - */ + if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) { + codeDeltaNext++; + delta = TclGetInt4AtPtr(codeDeltaNext); + codeDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(codeDeltaNext); + codeDeltaNext++; + } + codeOffset += delta; - fprintf(stdout, " Exception ranges=%d\n", numRanges); - for (i = 0; i < numRanges; i++) { - ExceptionRange *rangePtr = &(excRangeArrayPtr[i]); - fprintf(stdout, " %d: level=%d, type=%s, pc range=%d-%d, ", - i, rangePtr->nestingLevel, - ((rangePtr->type == LOOP_EXCEPTION_RANGE)? "loop" : "catch"), - rangePtr->codeOffset, - (rangePtr->codeOffset + rangePtr->numCodeBytes - 1)); - switch (rangePtr->type) { - case LOOP_EXCEPTION_RANGE: - fprintf(stdout, "continue=%d, break=%d\n", - rangePtr->continueOffset, rangePtr->breakOffset); - break; - case CATCH_EXCEPTION_RANGE: - fprintf(stdout, "catch=%d\n", rangePtr->catchOffset); - break; - default: - fprintf(stdout, "unrecognized ExceptionRange type %d\n", - rangePtr->type); + if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) { + codeLengthNext++; + codeLen = TclGetInt4AtPtr(codeLengthNext); + codeLengthNext += 4; + } else { + codeLen = TclGetInt1AtPtr(codeLengthNext); + codeLengthNext++; + } + + if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) { + srcDeltaNext++; + delta = TclGetInt4AtPtr(srcDeltaNext); + srcDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(srcDeltaNext); + srcDeltaNext++; + } + srcOffset += delta; + + if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) { + srcLengthNext++; + srcLen = TclGetInt4AtPtr(srcLengthNext); + srcLengthNext += 4; + } else { + srcLen = TclGetInt1AtPtr(srcLengthNext); + srcLengthNext++; } + + fprintf(stdout, "%s%4d: pc %d-%d, source %d-%d", + ((i % 2)? " " : "\n "), + (i+1), codeOffset, (codeOffset + codeLen - 1), + srcOffset, (srcOffset + srcLen - 1)); + } + if ((numCmds > 0) && ((numCmds % 2) != 0)) { + fprintf(stdout, "\n"); } /* * Print each instruction. If the instruction corresponds to the start - * of a command, print the command's source. + * of a command, print the command's source. Note that we don't need + * the code length here. */ - start = codeStart; - cmd = 0; - pc = start; - while (pc < codeLimit) { - int pcOffset = (pc - start); - while ((cmd < numCmds) && (pcOffset >= mapPtr[cmd].codeOffset)) { - /* - * The start of the command with index cmd. - */ - - maxChars = TclMin(mapPtr[cmd].numSrcChars, 70); - fprintf(stdout, " Command %d: ", (cmd+1)); - TclPrintSource(stdout, (source + mapPtr[cmd].srcOffset), - maxChars); - fprintf(stdout, "\n"); - cmd++; + codeDeltaNext = codePtr->codeDeltaStart; + srcDeltaNext = codePtr->srcDeltaStart; + srcLengthNext = codePtr->srcLengthStart; + codeOffset = srcOffset = 0; + pc = codeStart; + for (i = 0; i < numCmds; i++) { + if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) { + codeDeltaNext++; + delta = TclGetInt4AtPtr(codeDeltaNext); + codeDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(codeDeltaNext); + codeDeltaNext++; + } + codeOffset += delta; + + if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) { + srcDeltaNext++; + delta = TclGetInt4AtPtr(srcDeltaNext); + srcDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(srcDeltaNext); + srcDeltaNext++; + } + srcOffset += delta; + + if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) { + srcLengthNext++; + srcLen = TclGetInt4AtPtr(srcLengthNext); + srcLengthNext += 4; + } else { + srcLen = TclGetInt1AtPtr(srcLengthNext); + srcLengthNext++; + } + + /* + * Print instructions before command i. + */ + + while ((pc-codeStart) < codeOffset) { + fprintf(stdout, " "); + pc += TclPrintInstruction(codePtr, pc); + } + + fprintf(stdout, " Command %d: ", (i+1)); + TclPrintSource(stdout, (codePtr->source + srcOffset), + TclMin(srcLen, 70)); + fprintf(stdout, "\n"); + } + if (pc < codeLimit) { + /* + * Print instructions after the last command. + */ + + while (pc < codeLimit) { + fprintf(stdout, " "); + pc += TclPrintInstruction(codePtr, pc); } - fprintf(stdout, " "); - pc += TclPrintInstruction(codePtr, pc); } } @@ -590,7 +723,7 @@ TclPrintInstruction(codePtr, pc) for (i = 0; i < instDesc->numOperands; i++) { switch (instDesc->opTypes[i]) { case OPERAND_INT1: - opnd = TclGetInt1AtPc(pc+1+i); + opnd = TclGetInt1AtPtr(pc+1+i); if ((i == 0) && ((opCode == INST_JUMP1) || (opCode == INST_JUMP_TRUE1) || (opCode == INST_JUMP_FALSE1))) { @@ -600,7 +733,7 @@ TclPrintInstruction(codePtr, pc) } break; case OPERAND_INT4: - opnd = TclGetInt4AtPc(pc+1+i); + opnd = TclGetInt4AtPtr(pc+1+i); if ((i == 0) && ((opCode == INST_JUMP4) || (opCode == INST_JUMP_TRUE4) || (opCode == INST_JUMP_FALSE4))) { @@ -610,7 +743,7 @@ TclPrintInstruction(codePtr, pc) } break; case OPERAND_UINT1: - opnd = TclGetUInt1AtPc(pc+1+i); + opnd = TclGetUInt1AtPtr(pc+1+i); if ((i == 0) && (opCode == INST_PUSH1)) { elemPtr = codePtr->objArrayPtr[opnd]; string = Tcl_GetStringFromObj(elemPtr, &elemLen); @@ -642,7 +775,7 @@ TclPrintInstruction(codePtr, pc) } break; case OPERAND_UINT4: - opnd = TclGetUInt4AtPc(pc+1+i); + opnd = TclGetUInt4AtPtr(pc+1+i); if (opCode == INST_PUSH4) { elemPtr = codePtr->objArrayPtr[opnd]; string = Tcl_GetStringFromObj(elemPtr, &elemLen); @@ -812,6 +945,11 @@ TclCleanupByteCode(codePtr) register Tcl_Obj *elemPtr; register int i; +#ifdef TCL_COMPILE_STATS + tclCurrentSourceBytes -= (double) codePtr->numSrcChars; + tclCurrentCodeBytes -= (double) codePtr->totalSize; +#endif /* TCL_COMPILE_STATS */ + /* * A single heap object holds the ByteCode structure and its code, * object, command location, and auxiliary data arrays. This means we @@ -864,50 +1002,54 @@ DupByteCodeInternalRep(srcPtr, copyPtr) { ByteCode *codePtr = (ByteCode *) srcPtr->internalRep.otherValuePtr; register ByteCode *dupPtr; - int codeBytes = codePtr->numCodeBytes; - int numObjects = codePtr->numObjects; - int numAuxDataItems = codePtr->numAuxDataItems; register AuxData *srcAuxDataPtr, *dupAuxDataPtr; - size_t objArrayBytes, rangeArrayBytes, cmdLocBytes, auxDataBytes; + size_t objArrayBytes, exceptArrayBytes, cmdLocBytes, auxDataBytes; register size_t size; register char *p; - int i; + int codeBytes, numObjects, i; /* * Allocate a single heap object to hold the copied ByteCode structure * and its code, object, command location, and auxiliary data arrays. */ - objArrayBytes = numObjects * sizeof(Tcl_Obj *); - rangeArrayBytes = (codePtr->numExcRanges * sizeof(ExceptionRange)); - cmdLocBytes = codePtr->numCommands * sizeof(CmdLocation); - auxDataBytes = numAuxDataItems * sizeof(AuxData); - - size = TCL_ALIGN(sizeof(ByteCode)); - size += TCL_ALIGN(codeBytes); - size += TCL_ALIGN(objArrayBytes); - size += TCL_ALIGN(rangeArrayBytes); - size += TCL_ALIGN(cmdLocBytes); - size += TCL_ALIGN(auxDataBytes); + codeBytes = codePtr->numCodeBytes; + numObjects = codePtr->numObjects; + objArrayBytes = (numObjects * sizeof(Tcl_Obj *)); + exceptArrayBytes = (codePtr->numExcRanges * sizeof(ExceptionRange)); + auxDataBytes = (codePtr->numAuxDataItems * sizeof(AuxData)); + cmdLocBytes = codePtr->numCmdLocBytes; + + size = sizeof(ByteCode); + size += TCL_ALIGN(codeBytes); /* align object array */ + size += TCL_ALIGN(objArrayBytes); /* align exception range array */ + size += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */ + size += auxDataBytes; + size += cmdLocBytes; p = (char *) ckalloc(size); dupPtr = (ByteCode *) p; memcpy((VOID *) dupPtr, (VOID *) codePtr, size); - p += TCL_ALIGN(sizeof(ByteCode)); + p += sizeof(ByteCode); dupPtr->codeStart = (unsigned char *) p; - p += TCL_ALIGN(codeBytes); + p += TCL_ALIGN(codeBytes); /* object array is aligned */ dupPtr->objArrayPtr = (Tcl_Obj **) p; - p += TCL_ALIGN(objArrayBytes); + p += TCL_ALIGN(objArrayBytes); /* exception range array is aligned */ dupPtr->excRangeArrayPtr = (ExceptionRange *) p; - p += TCL_ALIGN(rangeArrayBytes); - dupPtr->cmdMapPtr = (CmdLocation *) p; - - p += TCL_ALIGN(cmdLocBytes); + p += TCL_ALIGN(exceptArrayBytes); /* AuxData array is aligned */ dupPtr->auxDataArrayPtr = (AuxData *) p; + + p += auxDataBytes; + dupPtr->codeDeltaStart = ((unsigned char *) dupPtr) + + (codePtr->codeDeltaStart - (unsigned char *) codePtr); + dupPtr->srcDeltaStart = ((unsigned char *) dupPtr) + + (codePtr->srcDeltaStart - (unsigned char *) codePtr); + dupPtr->srcLengthStart = ((unsigned char *) dupPtr) + + (codePtr->srcLengthStart - (unsigned char *) codePtr); /* * Increment the ref counts for objects in the object array since we are @@ -924,7 +1066,7 @@ DupByteCodeInternalRep(srcPtr, copyPtr) srcAuxDataPtr = codePtr->auxDataArrayPtr; dupAuxDataPtr = dupPtr->auxDataArrayPtr; - for (i = 0; i < numAuxDataItems; i++) { + for (i = 0; i < codePtr->numAuxDataItems; i++) { if (srcAuxDataPtr->dupProc != NULL) { dupAuxDataPtr->clientData = srcAuxDataPtr->dupProc(srcAuxDataPtr->clientData); @@ -937,6 +1079,11 @@ DupByteCodeInternalRep(srcPtr, copyPtr) copyPtr->internalRep.otherValuePtr = (VOID *) dupPtr; copyPtr->typePtr = &tclByteCodeType; + +#ifdef TCL_COMPILE_STATS + tclCurrentSourceBytes += (double) codePtr->numSrcChars; + tclCurrentCodeBytes += (double) codePtr->totalSize; +#endif /* TCL_COMPILE_STATS */ } /* @@ -984,10 +1131,6 @@ SetByteCodeFromAny(interp, objPtr) traceInitialized = 1; } -#ifdef TCL_COMPILE_STATS - tclNumCompilations++; -#endif /* TCL_COMPILE_STATS */ - string = Tcl_GetStringFromObj(objPtr, &length); TclInitCompileEnv(interp, &compEnv, string); result = TclCompileString(interp, string, string+length, @@ -1105,6 +1248,7 @@ TclInitCompileEnv(interp, envPtr, string) envPtr->wordIsSimple = 0; envPtr->numSimpleWordChars = 0; envPtr->exprIsJustVarRef = 0; + envPtr->exprIsComparison = 0; envPtr->termOffset = 0; envPtr->codeStart = envPtr->staticCodeSpace; @@ -1204,67 +1348,121 @@ TclFreeCompileEnv(envPtr) void TclInitByteCodeObj(objPtr, envPtr) - Tcl_Obj *objPtr; /* Points object that should be - * initialized, and whose string rep - * contains the source code. */ + Tcl_Obj *objPtr; /* Points object that should be + * initialized, and whose string rep + * contains the source code. */ register CompileEnv *envPtr; /* Points to the CompileEnv structure from * which to create a ByteCode structure. */ { register ByteCode *codePtr; - size_t codeBytes, objArrayBytes, rangeArrayBytes, cmdLocBytes; + size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes; size_t auxDataArrayBytes; - register size_t size; - register char *p; + register size_t size, objBytes, totalSize; + register unsigned char *p; + unsigned char *nextPtr; + int srcLen = envPtr->termOffset; + int numObjects, i; +#ifdef TCL_COMPILE_STATS + int srcLenLog2, sizeLog2; +#endif /*TCL_COMPILE_STATS*/ + + codeBytes = (envPtr->codeNext - envPtr->codeStart); + numObjects = envPtr->objArrayNext; + objArrayBytes = (envPtr->objArrayNext * sizeof(Tcl_Obj *)); + exceptArrayBytes = (envPtr->excRangeArrayNext * sizeof(ExceptionRange)); + auxDataArrayBytes = (envPtr->auxDataArrayNext * sizeof(AuxData)); + cmdLocBytes = GetCmdLocEncodingSize(envPtr); + + size = sizeof(ByteCode); + size += TCL_ALIGN(codeBytes); /* align object array */ + size += TCL_ALIGN(objArrayBytes); /* align exception range array */ + size += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */ + size += auxDataArrayBytes; + size += cmdLocBytes; + + /* + * Compute the total number of bytes needed for this bytecode + * including the storage for the Tcl objects in its object array. + */ + + objBytes = (numObjects * sizeof(Tcl_Obj)); + for (i = 0; i < numObjects; i++) { + Tcl_Obj *litObjPtr = envPtr->objArrayPtr[i]; + if (litObjPtr->bytes != NULL) { + objBytes += litObjPtr->length; + } + } + totalSize = (size + objBytes); - codeBytes = envPtr->codeNext - envPtr->codeStart; - objArrayBytes = envPtr->objArrayNext * sizeof(Tcl_Obj *); - rangeArrayBytes = (envPtr->excRangeArrayNext * sizeof(ExceptionRange)); - cmdLocBytes = envPtr->numCommands * sizeof(CmdLocation); - auxDataArrayBytes = envPtr->auxDataArrayNext * sizeof(AuxData); +#ifdef TCL_COMPILE_STATS + tclNumCompilations++; + tclTotalSourceBytes += (double) srcLen; + tclTotalCodeBytes += (double) totalSize; - size = TCL_ALIGN(sizeof(ByteCode)); - size += TCL_ALIGN(codeBytes); - size += TCL_ALIGN(objArrayBytes); - size += TCL_ALIGN(rangeArrayBytes); - size += TCL_ALIGN(cmdLocBytes); - size += TCL_ALIGN(auxDataArrayBytes); + tclTotalInstBytes += (double) codeBytes; + tclTotalObjBytes += (double) objBytes; + tclTotalExceptBytes += exceptArrayBytes; + tclTotalAuxBytes += (double) auxDataArrayBytes; + tclTotalCmdMapBytes += (double) cmdLocBytes; + + tclCurrentSourceBytes += (double) srcLen; + tclCurrentCodeBytes += (double) totalSize; + + srcLenLog2 = TclLog2(srcLen); + sizeLog2 = TclLog2((int) totalSize); + if ((srcLenLog2 > 31) || (sizeLog2 > 31)) { + panic("TclInitByteCodeObj: bad source or code sizes\n"); + } + tclSourceCount[srcLenLog2]++; + tclByteCodeCount[sizeLog2]++; +#endif /* TCL_COMPILE_STATS */ - p = (char *) ckalloc(size); + p = (unsigned char *) ckalloc(size); codePtr = (ByteCode *) p; codePtr->iPtr = envPtr->iPtr; codePtr->compileEpoch = envPtr->iPtr->compileEpoch; codePtr->refCount = 1; codePtr->source = envPtr->source; codePtr->procPtr = envPtr->procPtr; + codePtr->totalSize = totalSize; codePtr->numCommands = envPtr->numCommands; - codePtr->numSrcChars = envPtr->termOffset; + codePtr->numSrcChars = srcLen; codePtr->numCodeBytes = codeBytes; - codePtr->numObjects = envPtr->objArrayNext; + codePtr->numObjects = numObjects; codePtr->numExcRanges = envPtr->excRangeArrayNext; codePtr->numAuxDataItems = envPtr->auxDataArrayNext; + codePtr->numCmdLocBytes = cmdLocBytes; codePtr->maxExcRangeDepth = envPtr->maxExcRangeDepth; codePtr->maxStackDepth = envPtr->maxStackDepth; - p += TCL_ALIGN(sizeof(ByteCode)); - codePtr->codeStart = (unsigned char *) p; + p += sizeof(ByteCode); + codePtr->codeStart = p; memcpy((VOID *) p, (VOID *) envPtr->codeStart, codeBytes); - p += TCL_ALIGN(codeBytes); + p += TCL_ALIGN(codeBytes); /* align object array */ codePtr->objArrayPtr = (Tcl_Obj **) p; memcpy((VOID *) p, (VOID *) envPtr->objArrayPtr, objArrayBytes); - - p += TCL_ALIGN(objArrayBytes); - codePtr->excRangeArrayPtr = (ExceptionRange *) p; - memcpy((VOID *) p, (VOID *) envPtr->excRangeArrayPtr, rangeArrayBytes); - - p += TCL_ALIGN(rangeArrayBytes); - codePtr->cmdMapPtr = (CmdLocation *) p; - memcpy((VOID *) p, (VOID *) envPtr->cmdMapPtr, cmdLocBytes); - p += TCL_ALIGN(cmdLocBytes); - codePtr->auxDataArrayPtr = (AuxData *) p; - memcpy((VOID *) p, (VOID *) envPtr->auxDataArrayPtr, auxDataArrayBytes); + p += TCL_ALIGN(objArrayBytes); /* align exception range array */ + if (exceptArrayBytes > 0) { + codePtr->excRangeArrayPtr = (ExceptionRange *) p; + memcpy((VOID *) p, (VOID *) envPtr->excRangeArrayPtr, + exceptArrayBytes); + } + + p += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */ + if (auxDataArrayBytes > 0) { + codePtr->auxDataArrayPtr = (AuxData *) p; + memcpy((VOID *) p, (VOID *) envPtr->auxDataArrayPtr, + auxDataArrayBytes); + } + p += auxDataArrayBytes; + nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p); + if (((size_t)(nextPtr - p)) != cmdLocBytes) { + panic("TclInitByteCodeObj: encoded cmd location bytes %d != expected size %d\n", (nextPtr - p), cmdLocBytes); + } + /* * Free the old internal rep then convert the object to a * bytecode object by making its internal rep point to the just @@ -1282,6 +1480,204 @@ TclInitByteCodeObj(objPtr, envPtr) /* *---------------------------------------------------------------------- * + * GetCmdLocEncodingSize -- + * + * Computes the total number of bytes needed to encode the command + * location information for some compiled code. + * + * Results: + * The byte count needed to encode the compiled location information. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +GetCmdLocEncodingSize(envPtr) + CompileEnv *envPtr; /* Points to compilation environment + * structure containing the CmdLocation + * structure to encode. */ +{ + register CmdLocation *mapPtr = envPtr->cmdMapPtr; + int numCmds = envPtr->numCommands; + int codeDelta, codeLen, srcDelta, srcLen; + int codeDeltaNext, codeLengthNext, srcDeltaNext, srcLengthNext; + /* The offsets in their respective byte + * sequences where the next encoded offset + * or length should go. */ + int prevCodeOffset, prevSrcOffset, i; + + codeDeltaNext = codeLengthNext = srcDeltaNext = srcLengthNext = 0; + prevCodeOffset = prevSrcOffset = 0; + for (i = 0; i < numCmds; i++) { + codeDelta = (mapPtr[i].codeOffset - prevCodeOffset); + if (codeDelta < 0) { + panic("GetCmdLocEncodingSize: bad code offset"); + } else if (codeDelta <= 127) { + codeDeltaNext++; + } else { + codeDeltaNext += 5; /* 1 byte for 0xFF, 4 for positive delta */ + } + prevCodeOffset = mapPtr[i].codeOffset; + + codeLen = mapPtr[i].numCodeBytes; + if (codeLen < 0) { + panic("GetCmdLocEncodingSize: bad code length"); + } else if (codeLen <= 127) { + codeLengthNext++; + } else { + codeLengthNext += 5; /* 1 byte for 0xFF, 4 for length */ + } + + srcDelta = (mapPtr[i].srcOffset - prevSrcOffset); + if ((-127 <= srcDelta) && (srcDelta <= 127)) { + srcDeltaNext++; + } else { + srcDeltaNext += 5; /* 1 byte for 0xFF, 4 for delta */ + } + prevSrcOffset = mapPtr[i].srcOffset; + + srcLen = mapPtr[i].numSrcChars; + if (srcLen < 0) { + panic("GetCmdLocEncodingSize: bad source length"); + } else if (srcLen <= 127) { + srcLengthNext++; + } else { + srcLengthNext += 5; /* 1 byte for 0xFF, 4 for length */ + } + } + + return (codeDeltaNext + codeLengthNext + srcDeltaNext + srcLengthNext); +} + +/* + *---------------------------------------------------------------------- + * + * EncodeCmdLocMap -- + * + * Encode the command location information for some compiled code into + * a ByteCode structure. The encoded command location map is stored as + * three adjacent byte sequences. + * + * Results: + * Pointer to the first byte after the encoded command location + * information. + * + * Side effects: + * The encoded information is stored into the block of memory headed + * by codePtr. Also records pointers to the start of the four byte + * sequences in fields in codePtr's ByteCode header structure. + * + *---------------------------------------------------------------------- + */ + +static unsigned char * +EncodeCmdLocMap(envPtr, codePtr, startPtr) + CompileEnv *envPtr; /* Points to compilation environment + * structure containing the CmdLocation + * structure to encode. */ + ByteCode *codePtr; /* ByteCode in which to encode envPtr's + * command location information. */ + unsigned char *startPtr; /* Points to the first byte in codePtr's + * memory block where the location + * information is to be stored. */ +{ + register CmdLocation *mapPtr = envPtr->cmdMapPtr; + int numCmds = envPtr->numCommands; + register unsigned char *p = startPtr; + int codeDelta, codeLen, srcDelta, srcLen, prevOffset; + register int i; + + /* + * Encode the code offset for each command as a sequence of deltas. + */ + + codePtr->codeDeltaStart = p; + prevOffset = 0; + for (i = 0; i < numCmds; i++) { + codeDelta = (mapPtr[i].codeOffset - prevOffset); + if (codeDelta < 0) { + panic("EncodeCmdLocMap: bad code offset"); + } else if (codeDelta <= 127) { + TclStoreInt1AtPtr(codeDelta, p); + p++; + } else { + TclStoreInt1AtPtr(0xFF, p); + p++; + TclStoreInt4AtPtr(codeDelta, p); + p += 4; + } + prevOffset = mapPtr[i].codeOffset; + } + + /* + * Encode the code length for each command. + */ + + codePtr->codeLengthStart = p; + for (i = 0; i < numCmds; i++) { + codeLen = mapPtr[i].numCodeBytes; + if (codeLen < 0) { + panic("EncodeCmdLocMap: bad code length"); + } else if (codeLen <= 127) { + TclStoreInt1AtPtr(codeLen, p); + p++; + } else { + TclStoreInt1AtPtr(0xFF, p); + p++; + TclStoreInt4AtPtr(codeLen, p); + p += 4; + } + } + + /* + * Encode the source offset for each command as a sequence of deltas. + */ + + codePtr->srcDeltaStart = p; + prevOffset = 0; + for (i = 0; i < numCmds; i++) { + srcDelta = (mapPtr[i].srcOffset - prevOffset); + if ((-127 <= srcDelta) && (srcDelta <= 127)) { + TclStoreInt1AtPtr(srcDelta, p); + p++; + } else { + TclStoreInt1AtPtr(0xFF, p); + p++; + TclStoreInt4AtPtr(srcDelta, p); + p += 4; + } + prevOffset = mapPtr[i].srcOffset; + } + + /* + * Encode the source length for each command. + */ + + codePtr->srcLengthStart = p; + for (i = 0; i < numCmds; i++) { + srcLen = mapPtr[i].numSrcChars; + if (srcLen < 0) { + panic("EncodeCmdLocMap: bad source length"); + } else if (srcLen <= 127) { + TclStoreInt1AtPtr(srcLen, p); + p++; + } else { + TclStoreInt1AtPtr(0xFF, p); + p++; + TclStoreInt4AtPtr(srcLen, p); + p += 4; + } + } + + return p; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileString -- * * Compile a Tcl script in a null-terminated binary string. @@ -1308,8 +1704,8 @@ int TclCompileString(interp, string, lastChar, flags, envPtr) Tcl_Interp *interp; /* Used for error reporting. */ char *string; /* The source string to compile. */ - char *lastChar; /* Pointer to terminating character of - * string. */ + char *lastChar; /* Pointer to terminating character of + * string. */ int flags; /* Flags to control compilation (same as * passed to Tcl_Eval). */ CompileEnv *envPtr; /* Holds resulting instructions. */ @@ -1326,7 +1722,7 @@ TclCompileString(interp, string, lastChar, flags, envPtr) char *cmdSrcStart = NULL; /* Points to first non-blank char in each * command. Initialized to avoid compiler * warning. */ - int cmdIndex = -1; /* The index of the current command in the + int cmdIndex; /* The index of the current command in the * compilation environment's command * location table. Initialized to avoid * compiler warning. */ @@ -1379,7 +1775,7 @@ TclCompileString(interp, string, lastChar, flags, envPtr) if (src[1] == '\n') { src += 2; } else { - break; /* no longer white space */ + break; } } else { src++; @@ -1418,7 +1814,7 @@ TclCompileString(interp, string, lastChar, flags, envPtr) type = CHAR_TYPE(src, lastChar); if ((type == TCL_COMMAND_END) && ((c != ']') || (flags & TCL_BRACKET_TERM))) { - continue; /* ignore empty command; restart outer cmd loop */ + continue; /* empty command; restart outer cmd loop */ } /* @@ -1449,45 +1845,42 @@ TclCompileString(interp, string, lastChar, flags, envPtr) * of compilation procedures. If a word other than the first is * simple and represents an integer whose formatted representation * is the same as the word, just push an integer object. Also record - * starting source and object information for the command if we are - * at the top level (i.e. we were called directly from - * SetByteCodeFromAny and are not compiling a substring enclosed in - * square brackets). + * starting source and object information for the command. */ cmdSrcStart = src; cmdCodeOffset = (envPtr->codeNext - envPtr->codeStart); cmdWords = 0; - if (!(flags & TCL_BRACKET_TERM)) { - envPtr->numCommands++; - cmdIndex = (envPtr->numCommands - 1); - EnterCmdStartData(envPtr, cmdIndex, - (cmdSrcStart - envPtr->source), cmdCodeOffset); + + envPtr->numCommands++; + cmdIndex = (envPtr->numCommands - 1); + EnterCmdStartData(envPtr, cmdIndex, + (cmdSrcStart - envPtr->source), cmdCodeOffset); - if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) { - /* - * Display a line summarizing the top level command we - * are about to compile. - */ - - char *p = cmdSrcStart; - int numChars; - char *ellipsis = ""; - - while ((CHAR_TYPE(p, lastChar) != TCL_COMMAND_END) - || ((*p == ']') && !(flags & TCL_BRACKET_TERM))) { - p++; - } - numChars = (p - cmdSrcStart); - if (numChars > 60) { - numChars = 60; - ellipsis = " ..."; - } else if ((numChars >= 2) && (*p == '\n') && (*(p-1) == '{')) { - ellipsis = " ..."; - } - fprintf(stdout, "Compiling: %.*s%s\n", - numChars, cmdSrcStart, ellipsis); + if ((!(flags & TCL_BRACKET_TERM)) + && (tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) { + /* + * Display a line summarizing the top level command we are about + * to compile. + */ + + char *p = cmdSrcStart; + int numChars, complete; + + while ((CHAR_TYPE(p, lastChar) != TCL_COMMAND_END) + || ((*p == ']') && !(flags & TCL_BRACKET_TERM))) { + p++; + } + numChars = (p - cmdSrcStart); + complete = 1; + if (numChars > 60) { + numChars = 60; + complete = 0; + } else if ((numChars >= 2) && (*p == '\n') && (*(p-1) == '{')) { + complete = 0; } + fprintf(stdout, "Compiling: %.*s%s\n", + numChars, cmdSrcStart, (complete? "" : " ...")); } while ((type != TCL_COMMAND_END) @@ -1502,7 +1895,7 @@ TclCompileString(interp, string, lastChar, flags, envPtr) if (src[1] == '\n') { src += 2; } else { - break; /* no longer white space */ + break; } } else { src++; @@ -1520,9 +1913,9 @@ TclCompileString(interp, string, lastChar, flags, envPtr) * avoid an extra procedure call. */ - envPtr->pushSimpleWords = 0; /* we will handle simple words */ + envPtr->pushSimpleWords = 0; if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) { - src++; /* advance over the " or { */ + src++; if (type == TCL_QUOTE) { result = TclCompileQuotes(interp, src, lastChar, '"', flags, envPtr); @@ -1590,18 +1983,29 @@ TclCompileString(interp, string, lastChar, flags, envPtr) * traces). Look up the first word in the interpreter's * hashtable of commands. If a compilation procedure is * found, let it compile the command after resetting - * error logging information. + * error logging information. Note that if we are + * compiling a procedure, we must look up the command + * in the procedure's namespace and not the current + * namespace. */ + Namespace *cmdNsPtr; + + if (envPtr->procPtr != NULL) { + cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr; + } else { + cmdNsPtr = NULL; + } + cmdPtr = NULL; cmd = Tcl_FindCommand(interp, src, - (Tcl_Namespace *) NULL, /*flags*/ 0); + (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0); if (cmd != (Tcl_Command) NULL) { cmdPtr = (Command *) cmd; } if ((cmdPtr != NULL) && (cmdPtr->compileProc != NULL)) { char *firstArg = termPtr; - src[numChars] = savedChar; /* restore chr */ + src[numChars] = savedChar; iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET); result = (*(cmdPtr->compileProc))(interp, @@ -1609,9 +2013,9 @@ TclCompileString(interp, string, lastChar, flags, envPtr) if (result == TCL_OK) { src = (firstArg + envPtr->termOffset); maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - goto finishCommand; /* done with command */ + goto finishCommand; } else if (result == TCL_OUT_LINE_COMPILE) { - result = TCL_OK; /* reset result */ + result = TCL_OK; src[numChars] = '\0'; } else { src = firstArg; @@ -1652,8 +2056,9 @@ TclCompileString(interp, string, lastChar, flags, envPtr) resPtr->refNsCmdEpoch = nsPtr->cmdRefEpoch; resPtr->cmdEpoch = cmdPtr->cmdEpoch; resPtr->refCount = 1; - objPtr->internalRep.otherValuePtr = - (VOID *) resPtr; + objPtr->internalRep.twoPtrValue.ptr1 = + (VOID *) resPtr; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = &tclCmdNameType; cmdPtr->refCount++; } @@ -1671,7 +2076,8 @@ TclCompileString(interp, string, lastChar, flags, envPtr) char buf[40]; if (TclLooksLikeInt(src)) { - if (TclGetLong(interp, src, &n) == TCL_OK) { + int code = TclGetLong(interp, src, &n); + if (code == TCL_OK) { TclFormatInt(buf, n); if (strcmp(src, buf) == 0) { isCompilableInt = 1; @@ -1684,6 +2090,8 @@ TclCompileString(interp, string, lastChar, flags, envPtr) objPtr->internalRep.longValue = n; objPtr->typePtr = &tclIntType; } + } else { + Tcl_ResetResult(interp); } } if (!isCompilableInt) { @@ -1691,7 +2099,7 @@ TclCompileString(interp, string, lastChar, flags, envPtr) /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); } } - src[numChars] = savedChar; /* restore the saved char */ + src[numChars] = savedChar; TclEmitPush(objIndex, envPtr); maxDepth = TclMax((cmdWords + 1), maxDepth); } else { /* not a simple word */ @@ -1709,13 +2117,6 @@ TclCompileString(interp, string, lastChar, flags, envPtr) * was found for the command we called it and skipped this. */ -#ifdef TCL_COMPILE_DEBUG - if ((cmdWords < 0) || (cmdWords > 10000)) { - fprintf(stderr, "\nTclCompileString: bad cmdWords value %d\n", - cmdWords); - panic("TclCompileString: bad cmdWords value %d"); - } -#endif /*TCL_COMPILE_DEBUG*/ if (cmdWords > 0) { if (cmdWords <= 255) { TclEmitInstUInt1(INST_INVOKE_STK1, cmdWords, envPtr); @@ -1726,18 +2127,13 @@ TclCompileString(interp, string, lastChar, flags, envPtr) /* * Update the compilation environment structure. Record - * source/object information for the command if we are at the top - * level (i.e. we we called directly from SetByteCodeFromAny and are - * not compiling a substring enclosed in square brackets). + * source/object information for the command. */ finishCommand: - if (!(flags & TCL_BRACKET_TERM)) { - int cmdSrcChars = (src - cmdSrcStart); - cmdCodeBytes = - (envPtr->codeNext - envPtr->codeStart - cmdCodeOffset); - EnterCmdExtentData(envPtr, cmdIndex, cmdSrcChars, cmdCodeBytes); - } + cmdCodeBytes = envPtr->codeNext - envPtr->codeStart - cmdCodeOffset; + EnterCmdExtentData(envPtr, cmdIndex, src-cmdSrcStart, cmdCodeBytes); + isFirstCmd = 0; envPtr->termOffset = (src - string); c = *src; @@ -1754,7 +2150,7 @@ TclCompileString(interp, string, lastChar, flags, envPtr) int objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0, /*inHeap*/ 0, envPtr); TclEmitPush(objIndex, envPtr); - maxDepth = 1; /* we pushed 1 word for the empty string */ + maxDepth = 1; } } else { /* @@ -1762,8 +2158,8 @@ TclCompileString(interp, string, lastChar, flags, envPtr) * where the error occurred. */ - int numChars; register char *p; + int numChars; char buf[200]; iPtr->errorLine = 1; @@ -1780,14 +2176,22 @@ TclCompileString(interp, string, lastChar, flags, envPtr) /* * Figure out how much of the command to print (up to a certain - * number of characters, or up to the first newline). + * number of characters, or up to the end of the command). */ - numChars = (src - cmdSrcStart); + p = cmdSrcStart; + while ((CHAR_TYPE(p, lastChar) != TCL_COMMAND_END) + || ((*p == ']') && !(flags & TCL_BRACKET_TERM))) { + p++; + } + numChars = (p - cmdSrcStart); if (numChars > 150) { numChars = 150; ellipsis = " ..."; + } else if ((numChars >= 2) && (*p == '\n') && (*(p-1) == '{')) { + ellipsis = " ..."; } + sprintf(buf, "\n while compiling\n\"%.*s%s\"", numChars, cmdSrcStart, ellipsis); Tcl_AddObjErrorInfo(interp, buf, -1); @@ -1902,7 +2306,7 @@ CompileWord(interp, string, lastChar, flags, envPtr) */ if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) { - src++; /* advance over the " or { */ + src++; if (type == TCL_QUOTE) { result = TclCompileQuotes(interp, src, lastChar, '"', flags, envPtr); @@ -2080,7 +2484,7 @@ CompileMultipartWord(interp, string, lastChar, flags, envPtr) if (src[1] == '\n') { src += numRead; type = TCL_SPACE; /* force word end */ - break; /* exit loop: \newline is word separator */ + break; } src += numRead; } else { @@ -2131,7 +2535,7 @@ CompileMultipartWord(interp, string, lastChar, flags, envPtr) if (*p == '\\') { *dst = Tcl_Backslash(p, &numRead); if (p[1] == '\n') { - break; /* end of word */ + break; } p += numRead; dst++; @@ -2146,7 +2550,7 @@ CompileMultipartWord(interp, string, lastChar, flags, envPtr) objIndex = TclObjIndexForString(start, numChars, /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); } - start[numChars] = savedChar; /* restore the saved char */ + start[numChars] = savedChar; TclEmitPush(objIndex, envPtr); maxDepth = TclMax((numParts + 1), maxDepth); } else if (type == TCL_DOLLAR) { @@ -2167,7 +2571,7 @@ CompileMultipartWord(interp, string, lastChar, flags, envPtr) (flags | TCL_BRACKET_TERM), envPtr); termPtr = (src + envPtr->termOffset); if (*termPtr == ']') { - termPtr++; /* advance over the ']'. */ + termPtr++; } else if (*termPtr == '\0') { /* * Missing ] at end of nested command. @@ -2327,7 +2731,7 @@ TclCompileQuotes(interp, string, lastChar, termChar, flags, envPtr) (flags | TCL_BRACKET_TERM), envPtr); termPtr = (src + envPtr->termOffset); if (*termPtr == ']') { - termPtr++; /* advance over the ']'. */ + termPtr++; } src = termPtr; if (result != TCL_OK) { @@ -2384,7 +2788,7 @@ TclCompileQuotes(interp, string, lastChar, termChar, flags, envPtr) Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); result = TCL_ERROR; } else { - src++; /* advance over termChar */ + src++; } envPtr->wordIsSimple = 1; envPtr->numSimpleWordChars = (src - string - 1); @@ -2425,7 +2829,7 @@ TclCompileQuotes(interp, string, lastChar, termChar, flags, envPtr) objIndex = TclObjIndexForString(start, numChars, /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); } - start[numChars] = savedChar; /* restore the saved char */ + start[numChars] = savedChar; TclEmitPush(objIndex, envPtr); maxDepth = TclMax((numParts + 1), maxDepth); } @@ -2445,7 +2849,7 @@ TclCompileQuotes(interp, string, lastChar, termChar, flags, envPtr) result = TCL_ERROR; goto done; } else { - src++; /* advance over termChar */ + src++; } if (numParts == 0) { @@ -2577,8 +2981,7 @@ CompileBraces(interp, string, lastChar, flags, envPtr) --level; if (level == 0) { src++; - last = (src - 2); /* i.e. point just before - * terminating } */ + last = (src - 2); /* point just before terminating } */ break; } } else if (c == '\\') { @@ -2645,7 +3048,7 @@ CompileBraces(interp, string, lastChar, flags, envPtr) objIndex = TclObjIndexForString(string, numChars, /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); } - string[numChars] = savedChar; /* restore the saved char */ + string[numChars] = savedChar; TclEmitPush(objIndex, envPtr); done: @@ -2755,7 +3158,7 @@ TclCompileDollarVar(interp, string, lastChar, flags, envPtr) char *p; - src++; /* advance over the '{'. */ + src++; name = src; c = *src; while (c != '}') { @@ -2788,9 +3191,9 @@ TclCompileDollarVar(interp, string, lastChar, flags, envPtr) if (c == ':') { if (*(src+1) == ':') { nameHasNsSeparators = 1; - src += 2; /* skip over the initial :: */ + src += 2; while (*src == ':') { - src++; /* skip over a subsequent : */ + src++; } c = *src; } else { @@ -2826,11 +3229,11 @@ TclCompileDollarVar(interp, string, lastChar, flags, envPtr) if (!isArrayRef) { /* scalar reference */ if ((envPtr->procPtr == NULL) || nameHasNsSeparators) { - savedChar = name[nameChars]; /* save char just after name */ + savedChar = name[nameChars]; name[nameChars] = '\0'; objIndex = TclObjIndexForString(name, nameChars, /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - name[nameChars] = savedChar; /* restore the saved char */ + name[nameChars] = savedChar; TclEmitPush(objIndex, envPtr); TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr); maxDepth = 1; @@ -2846,11 +3249,11 @@ TclCompileDollarVar(interp, string, lastChar, flags, envPtr) } maxDepth = 0; } else { - savedChar = name[nameChars]; /* save char after name */ + savedChar = name[nameChars]; name[nameChars] = '\0'; objIndex = TclObjIndexForString(name, nameChars, /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - name[nameChars] = savedChar; /* restore the saved char */ + name[nameChars] = savedChar; TclEmitPush(objIndex, envPtr); TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr); maxDepth = 1; @@ -2858,11 +3261,11 @@ TclCompileDollarVar(interp, string, lastChar, flags, envPtr) } } else { /* array reference */ if ((envPtr->procPtr == NULL) || nameHasNsSeparators) { - savedChar = name[nameChars]; /* save char after name */ + savedChar = name[nameChars]; name[nameChars] = '\0'; objIndex = TclObjIndexForString(name, nameChars, /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - name[nameChars] = savedChar; /* restore the saved char */ + name[nameChars] = savedChar; TclEmitPush(objIndex, envPtr); maxDepth = 1; } else { @@ -2870,11 +3273,11 @@ TclCompileDollarVar(interp, string, lastChar, flags, envPtr) /*createIfNew*/ 0, /*flagsIfCreated*/ 0, envPtr->procPtr); if (localIndex < 0) { - savedChar = name[nameChars]; /* save char after name */ + savedChar = name[nameChars]; name[nameChars] = '\0'; objIndex = TclObjIndexForString(name, nameChars, /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - name[nameChars] = savedChar; /* restore the saved char */ + name[nameChars] = savedChar; TclEmitPush(objIndex, envPtr); maxDepth = 1; } @@ -2885,11 +3288,11 @@ TclCompileDollarVar(interp, string, lastChar, flags, envPtr) * just as is done for quoted strings. */ - src++; /* advance over the '(' */ + src++; envPtr->pushSimpleWords = 1; result = TclCompileQuotes(interp, src, lastChar, ')', flags, envPtr); - src += envPtr->termOffset; /* advance beyond the terminating ) */ + src += envPtr->termOffset; if (result != TCL_OK) { char msg[200]; sprintf(msg, "\n (parsing index for array \"%.*s\")", @@ -3122,7 +3525,7 @@ TclCompileCatchCmd(interp, string, lastChar, flags, envPtr) if (*p == '(') { if (*lastChar == ')') { /* we have an array element */ result = TCL_OUT_LINE_COMPILE; - goto done; /* only scalar loop vars for now */ + goto done; } } p++; @@ -3165,11 +3568,11 @@ TclCompileCatchCmd(interp, string, lastChar, flags, envPtr) bodyStart = argInfo.startArray[0]; bodyEnd = argInfo.endArray[0]; - savedChar = *(bodyEnd+1); /* save char after body */ + savedChar = *(bodyEnd+1); *(bodyEnd+1) = '\0'; result = CompileCmdWordInline(interp, bodyStart, (bodyEnd+1), flags, envPtr); - *(bodyEnd+1) = savedChar; /* restore the saved char */ + *(bodyEnd+1) = savedChar; if (result != TCL_OK) { if (result == TCL_ERROR) { @@ -3199,7 +3602,7 @@ TclCompileCatchCmd(interp, string, lastChar, flags, envPtr) TclEmitInstUInt4(INST_STORE_SCALAR4, localIndex, envPtr); } } - TclEmitOpcode(INST_POP, envPtr); /* pop the result */ + TclEmitOpcode(INST_POP, envPtr); objIndex = TclObjIndexForString("0", 1, /*allocStrRep*/ 0, /*inHeap*/ 0, envPtr); @@ -3224,14 +3627,7 @@ TclCompileCatchCmd(interp, string, lastChar, flags, envPtr) * catch's error target. */ -#ifdef TCL_COMPILE_DEBUG - if (envPtr->excRangeArrayPtr[range].type != CATCH_EXCEPTION_RANGE) { - panic("TclCompileCatchCmd: bad body ExceptionRange type %d\n", - envPtr->excRangeArrayPtr[range].type); - } -#endif /*TCL_COMPILE_DEBUG*/ envPtr->excRangeArrayPtr[range].catchOffset = TclCurrCodeOffset(); - if (localIndex != -1) { TclEmitOpcode(INST_PUSH_RESULT, envPtr); if (localIndex <= 255) { @@ -3239,7 +3635,7 @@ TclCompileCatchCmd(interp, string, lastChar, flags, envPtr) } else { TclEmitInstUInt4(INST_STORE_SCALAR4, localIndex, envPtr); } - TclEmitOpcode(INST_POP, envPtr); /* pop the result */ + TclEmitOpcode(INST_POP, envPtr); } TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr); @@ -3405,6 +3801,7 @@ TclCompileExprCmd(interp, string, lastChar, flags, envPtr) char c; int savePushSimpleWords = envPtr->pushSimpleWords; int saveExprIsJustVarRef = envPtr->exprIsJustVarRef; + int saveExprIsComparison = envPtr->exprIsComparison; /* * Scan the words of the command and record the start and finish of @@ -3458,10 +3855,10 @@ TclCompileExprCmd(interp, string, lastChar, flags, envPtr) * Simple case: a single argument word in {}'s. */ - *wordEnd = '\0'; /* temporarily replace the '}' by a null */ + *wordEnd = '\0'; result = TclCompileExpr(interp, (wordStart + 1), wordEnd, flags, envPtr); - *wordEnd = '}'; /* restore the '}' */ + *wordEnd = '}'; envPtr->termOffset = (wordEnd + 1) - string; envPtr->pushSimpleWords = savePushSimpleWords; @@ -3529,7 +3926,7 @@ TclCompileExprCmd(interp, string, lastChar, flags, envPtr) envPtr->excRangeDepth++; envPtr->maxExcRangeDepth = - TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth); + TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth); range = CreateExceptionRange(CATCH_EXCEPTION_RANGE, envPtr); TclEmitInstUInt4(INST_BEGIN_CATCH4, range, envPtr); @@ -3539,23 +3936,36 @@ TclCompileExprCmd(interp, string, lastChar, flags, envPtr) envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset(); savedChar = *(last + 1); - *(last + 1) = '\0'; /* replace term. char with null */ + *(last + 1) = '\0'; result = TclCompileExpr(interp, first, last + 1, flags, envPtr); - *(last + 1) = savedChar; /* restore the saved char */ + *(last + 1) = savedChar; maxDepth = envPtr->maxStackDepth; envPtr->excRangeArrayPtr[range].numCodeBytes = - TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset; + TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset; - if ((envPtr->exprIsJustVarRef) || (result != TCL_OK)) { + if ((result != TCL_OK) || (envPtr->exprIsJustVarRef) + || (envPtr->exprIsComparison)) { /* - * We must call the expr command at runtime since the expression - * consisted of just a single variable reference (and a second - * round of substitutions might be needed) or there was a - * compilation error. Delete the inline code by backing up the - * code pc and catch index. Note that if there was a compilation - * error, we can't report the error yet since the expression - * might be valid after the second round of substitutions. + * We must call the expr command at runtime. Either there was a + * compilation error or the inline code might fail to give the + * correct 2 level substitution semantics. + * + * The latter can happen if the expression consisted of just a + * single variable reference or if the top-level operator in the + * expr is a comparison (which might operate on strings). In the + * latter case, the expression's code might execute (apparently) + * successfully but produce the wrong result. We depend on its + * execution failing if a second level of substitutions is + * required. This causes the "catch" code we generate around the + * inline code to back off to a call on the expr command at + * runtime, and this always gives the right 2 level substitution + * semantics. + * + * We delete the inline code by backing up the code pc and catch + * index. Note that if there was a compilation error, we can't + * report the error yet since the expression might be valid + * after the second round of substitutions. */ envPtr->codeNext = (envPtr->codeStart + startCodeOffset); @@ -3579,10 +3989,10 @@ TclCompileExprCmd(interp, string, lastChar, flags, envPtr) wordStart = argInfo.startArray[i]; wordEnd = argInfo.endArray[i]; savedChar = *(wordEnd + 1); - *(wordEnd + 1) = '\0'; /* replace term. char with null */ + *(wordEnd + 1) = '\0'; envPtr->pushSimpleWords = 1; result = CompileWord(interp, wordStart, wordEnd+1, flags, envPtr); - *(wordEnd + 1) = savedChar; /* restore the saved char */ + *(wordEnd + 1) = savedChar; if (result != TCL_OK) { break; } @@ -3620,13 +4030,6 @@ TclCompileExprCmd(interp, string, lastChar, flags, envPtr) * target since it, being after the jump, also moved down. */ -#ifdef TCL_COMPILE_DEBUG - if (envPtr->excRangeArrayPtr[range].type != CATCH_EXCEPTION_RANGE) { - panic("TclCompileExprCmd: bad body ExceptionRange type %d\n", - envPtr->excRangeArrayPtr[range].type); - } -#endif /* TCL_COMPILE_DEBUG */ - envPtr->excRangeArrayPtr[range].catchOffset += 3; } } @@ -3643,6 +4046,7 @@ TclCompileExprCmd(interp, string, lastChar, flags, envPtr) } envPtr->pushSimpleWords = savePushSimpleWords; envPtr->exprIsJustVarRef = saveExprIsJustVarRef; + envPtr->exprIsComparison = saveExprIsComparison; envPtr->maxStackDepth = maxDepth; FreeArgInfo(&argInfo); return result; @@ -3849,13 +4253,6 @@ TclCompileForCmd(interp, string, lastChar, flags, envPtr) jumpBackOffset = TclCurrCodeOffset(); jumpBackDist = (jumpBackOffset - testCodeOffset); -#ifdef TCL_COMPILE_DEBUG - if (jumpBackDist > MAX_JUMP_DIST) { - fprintf(stderr, "\nTclCompileForCmd: bad distance %u for unconditional jump\n", - jumpBackDist); - panic("TclCompileForCmd: bad distance for unconditional jump"); - } -#endif /*TCL_COMPILE_DEBUG*/ if (jumpBackDist > 120) { TclEmitInstInt4(INST_JUMP4, /*offset*/ -jumpBackDist, envPtr); } else { @@ -3878,12 +4275,6 @@ TclCompileForCmd(interp, string, lastChar, flags, envPtr) * record since it also moved down. */ -#ifdef TCL_COMPILE_DEBUG - if (envPtr->excRangeArrayPtr[range1].type != LOOP_EXCEPTION_RANGE) { - panic("TclCompileForCmd: bad body ExceptionRange type %d\n", - envPtr->excRangeArrayPtr[range1].type); - } -#endif /* TCL_COMPILE_DEBUG */ envPtr->excRangeArrayPtr[range1].codeOffset += 3; envPtr->excRangeArrayPtr[range1].continueOffset += 3; envPtr->excRangeArrayPtr[range2].codeOffset += 3; @@ -3911,12 +4302,6 @@ TclCompileForCmd(interp, string, lastChar, flags, envPtr) * is the loop's break target. */ -#ifdef TCL_COMPILE_DEBUG - if (envPtr->excRangeArrayPtr[range1].type != LOOP_EXCEPTION_RANGE) { - panic("TclCompileForCmd: bad body ExceptionRange type %d\n", - envPtr->excRangeArrayPtr[range1].type); - } -#endif /* TCL_COMPILE_DEBUG */ envPtr->excRangeArrayPtr[range1].breakOffset = envPtr->excRangeArrayPtr[range2].breakOffset = TclCurrCodeOffset(); @@ -3928,7 +4313,7 @@ TclCompileForCmd(interp, string, lastChar, flags, envPtr) envPtr); TclEmitPush(objIndex, envPtr); if (maxDepth == 0) { - maxDepth = 1; /* since we just pushed one object */ + maxDepth = 1; } done: @@ -4104,11 +4489,11 @@ TclCompileForeachCmd(interp, string, lastChar, flags, envPtr) * NOTE: THIS NEEDS TO BE CONVERTED TO AN OBJECT LIST. */ - savedChar = *(varListEnd+1); /* save char after var list */ + savedChar = *(varListEnd+1); *(varListEnd+1) = '\0'; result = Tcl_SplitList(interp, varListStart, &varcList[i], &varvList[i]); - *(varListEnd+1) = savedChar; /* restore the saved char */ + *(varListEnd+1) = savedChar; if (result != TCL_OK) { goto done; } @@ -4135,7 +4520,7 @@ TclCompileForeachCmd(interp, string, lastChar, flags, envPtr) q--; if (*q == ')') { /* we have an array element */ result = TCL_OUT_LINE_COMPILE; - goto done; /* only scalar loop vars for now */ + goto done; } } p++; @@ -4224,7 +4609,7 @@ TclCompileForeachCmd(interp, string, lastChar, flags, envPtr) } else { TclEmitInstUInt4(INST_STORE_SCALAR4, tmpIndex, envPtr); } - TclEmitOpcode(INST_POP, envPtr); /* no longer need list on the stk */ + TclEmitOpcode(INST_POP, envPtr); } /* @@ -4257,12 +4642,12 @@ TclCompileForeachCmd(interp, string, lastChar, flags, envPtr) bodyStart = argInfo.startArray[numWords - 1]; bodyEnd = argInfo.endArray[numWords - 1]; - savedChar = *(bodyEnd+1); /* save char after body */ + savedChar = *(bodyEnd+1); *(bodyEnd+1) = '\0'; envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset(); result = CompileCmdWordInline(interp, bodyStart, bodyEnd+1, flags, envPtr); - *(bodyEnd+1) = savedChar; /* restore the saved char */ + *(bodyEnd+1) = savedChar; if (result != TCL_OK) { if (result == TCL_ERROR) { char msg[60]; @@ -4293,12 +4678,6 @@ TclCompileForeachCmd(interp, string, lastChar, flags, envPtr) jumpBackOffset = TclCurrCodeOffset(); jumpBackDist = (jumpBackOffset - envPtr->excRangeArrayPtr[range].continueOffset); -#ifdef TCL_COMPILE_DEBUG - if (jumpBackDist > MAX_JUMP_DIST) { - fprintf(stderr, "\nTclCompileForeachCmd: bad distance %u for unconditional jump\n", jumpBackDist); - panic("TclCompileForeachCmd: bad distance for unconditional jump"); - } -#endif /*TCL_COMPILE_DEBUG*/ if (jumpBackDist > 120) { TclEmitInstInt4(INST_JUMP4, /*offset*/ -jumpBackDist, envPtr); } else { @@ -4318,12 +4697,6 @@ TclCompileForeachCmd(interp, string, lastChar, flags, envPtr) * Update the loop body's starting PC offset since it moved down. */ -#ifdef TCL_COMPILE_DEBUG - if (envPtr->excRangeArrayPtr[range].type != LOOP_EXCEPTION_RANGE) { - panic("TclCompileForeachCmd: bad body ExceptionRange type %d\n", - envPtr->excRangeArrayPtr[range].type); - } -#endif /*TCL_COMPILE_DEBUG*/ envPtr->excRangeArrayPtr[range].codeOffset += 3; /* @@ -4349,12 +4722,6 @@ TclCompileForeachCmd(interp, string, lastChar, flags, envPtr) * break target. */ -#ifdef TCL_COMPILE_DEBUG - if (envPtr->excRangeArrayPtr[range].type != LOOP_EXCEPTION_RANGE) { - panic("TclCompileForeachCmd: bad body ExceptionRange type %d\n", - envPtr->excRangeArrayPtr[range].type); - } -#endif /*TCL_COMPILE_DEBUG*/ envPtr->excRangeArrayPtr[range].breakOffset = TclCurrCodeOffset(); /* @@ -4365,7 +4732,7 @@ TclCompileForeachCmd(interp, string, lastChar, flags, envPtr) envPtr); TclEmitPush(objIndex, envPtr); if (maxDepth == 0) { - maxDepth = 1; /* since we just pushed one object */ + maxDepth = 1; } done: @@ -4541,7 +4908,7 @@ TclCompileIfCmd(interp, string, lastChar, flags, envPtr) * a script to execute if the expression is true. */ - AdvanceToNextWord(src, envPtr); /* make sure there is a next word */ + AdvanceToNextWord(src, envPtr); src += envPtr->termOffset; type = CHAR_TYPE(src, lastChar); if (type == TCL_COMMAND_END) { @@ -4557,7 +4924,7 @@ TclCompileIfCmd(interp, string, lastChar, flags, envPtr) */ testSrcStart = src; - envPtr->pushSimpleWords = 1; /* process words normally */ + envPtr->pushSimpleWords = 1; result = CompileExprWord(interp, src, lastChar, flags, envPtr); if (result != TCL_OK) { if (result == TCL_ERROR) { @@ -4602,7 +4969,7 @@ TclCompileIfCmd(interp, string, lastChar, flags, envPtr) if ((*src == 't') && (strncmp(src, "then", 4) == 0)) { type = CHAR_TYPE(src+4, lastChar); if ((type == TCL_SPACE) || (type == TCL_COMMAND_END)) { - src += 4; /* skip over the "then" */ + src += 4; AdvanceToNextWord(src, envPtr); src += envPtr->termOffset; type = CHAR_TYPE(src, lastChar); @@ -4623,7 +4990,10 @@ TclCompileIfCmd(interp, string, lastChar, flags, envPtr) result = CompileCmdWordInline(interp, src, lastChar, flags, envPtr); if (result != TCL_OK) { if (result == TCL_ERROR) { - Tcl_AddObjErrorInfo(interp, "\n (\"if\" body script)", -1); + char msg[60]; + sprintf(msg, "\n (\"if\" then script line %d)", + interp->errorLine); + Tcl_AddObjErrorInfo(interp, msg, -1); } goto done; } @@ -4676,7 +5046,7 @@ TclCompileIfCmd(interp, string, lastChar, flags, envPtr) && ((*src == 'e') && (strncmp(src, "elseif", 6) == 0))) { type = CHAR_TYPE(src+6, lastChar); if ((type == TCL_SPACE) || (type == TCL_COMMAND_END)) { - src += 6; /* skip over the "elseif" */ + src += 6; AdvanceToNextWord(src, envPtr); src += envPtr->termOffset; type = CHAR_TYPE(src, lastChar); @@ -4690,7 +5060,7 @@ TclCompileIfCmd(interp, string, lastChar, flags, envPtr) continue; /* continue the "expr then body" loop */ } } - break; /* exit the loop */ + break; } /* end of the "expr then body" loop */ /* @@ -4702,7 +5072,7 @@ TclCompileIfCmd(interp, string, lastChar, flags, envPtr) if ((*src == 'e') && (strncmp(src, "else", 4) == 0)) { type = CHAR_TYPE(src+4, lastChar); if ((type == TCL_SPACE) || (type == TCL_COMMAND_END)) { - src += 4; /* skip over the "else" */ + src += 4; AdvanceToNextWord(src, envPtr); src += envPtr->termOffset; type = CHAR_TYPE(src, lastChar); @@ -4723,7 +5093,10 @@ TclCompileIfCmd(interp, string, lastChar, flags, envPtr) result = CompileCmdWordInline(interp, src, lastChar, flags, envPtr); if (result != TCL_OK) { if (result == TCL_ERROR) { - Tcl_AddObjErrorInfo(interp, "\n (\"if\" else script)", -1); + char msg[60]; + sprintf(msg, "\n (\"if\" else script line %d)", + interp->errorLine); + Tcl_AddObjErrorInfo(interp, msg, -1); } goto done; } @@ -4780,13 +5153,13 @@ TclCompileIfCmd(interp, string, lastChar, flags, envPtr) ifFalsePc = (envPtr->codeStart + jumpFalseFixupArray.fixup[jumpIndex].codeOffset); opCode = *ifFalsePc; if (opCode == INST_JUMP_FALSE1) { - jumpFalseDist = TclGetInt1AtPc(ifFalsePc + 1); + jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1); jumpFalseDist += 3; - TclUpdateInt1AtPc(jumpFalseDist, (ifFalsePc + 1)); + TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1)); } else if (opCode == INST_JUMP_FALSE4) { - jumpFalseDist = TclGetInt4AtPc(ifFalsePc + 1); + jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1); jumpFalseDist += 3; - TclUpdateInt4AtPc(jumpFalseDist, (ifFalsePc + 1)); + TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1)); } else { panic("TclCompileIfCmd: unexpected opcode updating ifFalse jump"); } @@ -4886,7 +5259,7 @@ TclCompileIncrCmd(interp, string, lastChar, flags, envPtr) * an optional "elName". Otherwise, if not simple, just push the name. */ - AdvanceToNextWord(src, envPtr); /* make sure there is a next word */ + AdvanceToNextWord(src, envPtr); src += envPtr->termOffset; type = CHAR_TYPE(src, lastChar); if (type == TCL_COMMAND_END) { @@ -4898,7 +5271,7 @@ TclCompileIncrCmd(interp, string, lastChar, flags, envPtr) goto done; } - envPtr->pushSimpleWords = 0; /* we will process the varName */ + envPtr->pushSimpleWords = 0; result = CompileWord(interp, src, lastChar, flags, envPtr); if (result != TCL_OK) { goto done; @@ -4908,7 +5281,7 @@ TclCompileIncrCmd(interp, string, lastChar, flags, envPtr) name = src; nameChars = envPtr->numSimpleWordChars; if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) { - name++; /* advance over the " or { */ + name++; } elName = NULL; elNameChars = 0; @@ -4955,11 +5328,11 @@ TclCompileIncrCmd(interp, string, lastChar, flags, envPtr) if (simpleVarName) { if (procPtr == NULL) { - savedChar = name[nameChars]; /* save char after name */ + savedChar = name[nameChars]; name[nameChars] = '\0'; objIndex = TclObjIndexForString(name, nameChars, /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - name[nameChars] = savedChar; /* restore the saved char */ + name[nameChars] = savedChar; TclEmitPush(objIndex, envPtr); maxDepth = 1; } else { @@ -4970,11 +5343,11 @@ TclCompileIncrCmd(interp, string, lastChar, flags, envPtr) if (localIndex > 255) { /* we'll push the name */ localIndex = -1; } - savedChar = name[nameChars]; /* save char after name */ + savedChar = name[nameChars]; name[nameChars] = '\0'; objIndex = TclObjIndexForString(name, nameChars, /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - name[nameChars] = savedChar; /* restore the saved char */ + name[nameChars] = savedChar; TclEmitPush(objIndex, envPtr); maxDepth = 1; } else { @@ -4988,12 +5361,12 @@ TclCompileIncrCmd(interp, string, lastChar, flags, envPtr) * substitutions on it, just as is done for quoted strings. */ - savedChar = elName[elNameChars]; /* save char after elName */ + savedChar = elName[elNameChars]; elName[elNameChars] = '\0'; envPtr->pushSimpleWords = 1; result = TclCompileQuotes(interp, elName, elName+elNameChars, 0, flags, envPtr); - elName[elNameChars] = savedChar; /* restore the saved char */ + elName[elNameChars] = savedChar; if (result != TCL_OK) { char msg[200]; sprintf(msg, "\n (parsing index for array \"%.*s\")", @@ -5011,17 +5384,17 @@ TclCompileIncrCmd(interp, string, lastChar, flags, envPtr) if (incrementGiven) { type = CHAR_TYPE(src, lastChar); - envPtr->pushSimpleWords = 0; /* we will handle simple words */ + envPtr->pushSimpleWords = 0; result = CompileWord(interp, src, lastChar, flags, envPtr); if (result != TCL_OK) { if (result == TCL_ERROR) { Tcl_AddObjErrorInfo(interp, - "\n (reading increment)", -1); + "\n (increment expression)", -1); } goto done; } if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) { - src++; /* advance over the " or { */ + src++; } if (envPtr->wordIsSimple) { /* @@ -5040,7 +5413,8 @@ TclCompileIncrCmd(interp, string, lastChar, flags, envPtr) src[numChars] = '\0'; if (TclLooksLikeInt(src)) { - if (TclGetLong(interp, src, &n) == TCL_OK) { + int code = TclGetLong(interp, src, &n); + if (code == TCL_OK) { if ((-127 <= n) && (n <= 127)) { isCompilableInt = 1; isImmIncrValue = 1; @@ -5062,6 +5436,8 @@ TclCompileIncrCmd(interp, string, lastChar, flags, envPtr) maxDepth += 1; } } + } else { + Tcl_ResetResult(interp); } } if (!isCompilableInt) { @@ -5070,7 +5446,7 @@ TclCompileIncrCmd(interp, string, lastChar, flags, envPtr) TclEmitPush(objIndex, envPtr); maxDepth += 1; } - src[numChars] = savedChar; /* restore the saved char */ + src[numChars] = savedChar; } else { maxDepth += envPtr->maxStackDepth; } @@ -5088,10 +5464,6 @@ TclCompileIncrCmd(interp, string, lastChar, flags, envPtr) * Now emit instructions to increment the variable. */ - if ((localIndex >= 0) && (localIndex > 255)) { - panic("TclCompileIncrCmd: bad localIndex %d\n", localIndex); - return TCL_ERROR; - } if (simpleVarName) { if (elName == NULL) { /* scalar */ if (localIndex >= 0) { @@ -5146,7 +5518,7 @@ TclCompileIncrCmd(interp, string, lastChar, flags, envPtr) src += envPtr->termOffset; type = CHAR_TYPE(src, lastChar); if (type != TCL_COMMAND_END) { - goto badArgs; /* too many arguments */ + goto badArgs; } } @@ -5263,7 +5635,7 @@ TclCompileSetCmd(interp, string, lastChar, flags, envPtr) * runtime. */ - envPtr->pushSimpleWords = 0; /* we will process the varName */ + envPtr->pushSimpleWords = 0; result = CompileWord(interp, wordStart, argInfo.endArray[0] + 1, flags, envPtr); if (result != TCL_OK) { @@ -5344,11 +5716,11 @@ TclCompileSetCmd(interp, string, lastChar, flags, envPtr) */ if ((procPtr == NULL) || nameHasNsSeparators) { - savedChar = name[nameChars]; /* save char after name */ + savedChar = name[nameChars]; name[nameChars] = '\0'; objIndex = TclObjIndexForString(name, nameChars, /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - name[nameChars] = savedChar; /* restore the saved char */ + name[nameChars] = savedChar; TclEmitPush(objIndex, envPtr); maxDepth = 1; } else { @@ -5360,11 +5732,11 @@ TclCompileSetCmd(interp, string, lastChar, flags, envPtr) if (localIndex >= 0) { maxDepth = 0; } else { - savedChar = name[nameChars]; /* save char after name */ + savedChar = name[nameChars]; name[nameChars] = '\0'; objIndex = TclObjIndexForString(name, nameChars, /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - name[nameChars] = savedChar; /* restore the saved char */ + name[nameChars] = savedChar; TclEmitPush(objIndex, envPtr); maxDepth = 1; } @@ -5377,12 +5749,12 @@ TclCompileSetCmd(interp, string, lastChar, flags, envPtr) */ if (elName != NULL) { - savedChar = elName[elNameChars]; /* save char after elName */ + savedChar = elName[elNameChars]; elName[elNameChars] = '\0'; envPtr->pushSimpleWords = 1; result = TclCompileQuotes(interp, elName, elName+elNameChars, 0, flags, envPtr); - elName[elNameChars] = savedChar; /* restore the saved char */ + elName[elNameChars] = savedChar; if (result != TCL_OK) { char msg[200]; sprintf(msg, "\n (parsing index for array \"%.*s\")", @@ -5425,13 +5797,14 @@ TclCompileSetCmd(interp, string, lastChar, flags, envPtr) p = wordStart; if ((*wordStart == '"') || (*wordStart == '{')) { - p++; /* advance over the " or { */ + p++; } savedChar = p[envPtr->numSimpleWordChars]; p[envPtr->numSimpleWordChars] = '\0'; isCompilableInt = 0; if (TclLooksLikeInt(p)) { - if (TclGetLong(interp, p, &n) == TCL_OK) { + int code = TclGetLong(interp, p, &n); + if (code == TCL_OK) { TclFormatInt(buf, n); if (strcmp(p, buf) == 0) { isCompilableInt = 1; @@ -5444,6 +5817,8 @@ TclCompileSetCmd(interp, string, lastChar, flags, envPtr) objPtr->internalRep.longValue = n; objPtr->typePtr = &tclIntType; } + } else { + Tcl_ResetResult(interp); } } if (!isCompilableInt) { @@ -5451,7 +5826,7 @@ TclCompileSetCmd(interp, string, lastChar, flags, envPtr) envPtr->numSimpleWordChars, /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); } - p[envPtr->numSimpleWordChars] = savedChar; /* restore char */ + p[envPtr->numSimpleWordChars] = savedChar; TclEmitPush(objIndex, envPtr); maxDepth += 1; } @@ -5575,7 +5950,7 @@ TclCompileWhileCmd(interp, string, lastChar, flags, envPtr) range = CreateExceptionRange(LOOP_EXCEPTION_RANGE, envPtr); envPtr->excRangeArrayPtr[range].continueOffset = TclCurrCodeOffset(); - AdvanceToNextWord(src, envPtr); /* make sure there is a next word */ + AdvanceToNextWord(src, envPtr); src += envPtr->termOffset; type = CHAR_TYPE(src, lastChar); if (type == TCL_COMMAND_END) { @@ -5605,7 +5980,7 @@ TclCompileWhileCmd(interp, string, lastChar, flags, envPtr) * Compile the next word: the test expression. */ - envPtr->pushSimpleWords = 1; /* process words normally */ + envPtr->pushSimpleWords = 1; result = CompileExprWord(interp, src, lastChar, flags, envPtr); if (result != TCL_OK) { if (result == TCL_ERROR) { @@ -5630,7 +6005,7 @@ TclCompileWhileCmd(interp, string, lastChar, flags, envPtr) * starting PC offset and byte length in the its ExceptionRange record. */ - AdvanceToNextWord(src, envPtr); /* make sure there is a next word */ + AdvanceToNextWord(src, envPtr); src += envPtr->termOffset; type = CHAR_TYPE(src, lastChar); if (type == TCL_COMMAND_END) { @@ -5670,12 +6045,6 @@ TclCompileWhileCmd(interp, string, lastChar, flags, envPtr) jumpBackOffset = TclCurrCodeOffset(); jumpBackDist = (jumpBackOffset - envPtr->excRangeArrayPtr[range].continueOffset); -#ifdef TCL_COMPILE_DEBUG - if (jumpBackDist > MAX_JUMP_DIST) { - fprintf(stderr, "\nTclCompileWhileCmd: bad distance %u for unconditional jump\n", jumpBackDist); - panic("TclCompileWhileCmd: bad distance for unconditional jump"); - } -#endif /*TCL_COMPILE_DEBUG*/ if (jumpBackDist > 120) { TclEmitInstInt4(INST_JUMP4, /*offset*/ -jumpBackDist, envPtr); } else { @@ -5695,12 +6064,6 @@ TclCompileWhileCmd(interp, string, lastChar, flags, envPtr) * Update the loop body's starting PC offset since it moved down. */ -#ifdef TCL_COMPILE_DEBUG - if (envPtr->excRangeArrayPtr[range].type != LOOP_EXCEPTION_RANGE) { - panic("TclCompileWhileCmd: bad body ExceptionRange type %d\n", - envPtr->excRangeArrayPtr[range].type); - } -#endif /* TCL_COMPILE_DEBUG */ envPtr->excRangeArrayPtr[range].codeOffset += 3; /* @@ -5726,12 +6089,6 @@ TclCompileWhileCmd(interp, string, lastChar, flags, envPtr) * break target. */ -#ifdef TCL_COMPILE_DEBUG - if (envPtr->excRangeArrayPtr[range].type != LOOP_EXCEPTION_RANGE) { - panic("TclCompileWhileCmd: bad body ExceptionRange type %d\n", - envPtr->excRangeArrayPtr[range].type); - } -#endif /* TCL_COMPILE_DEBUG */ envPtr->excRangeArrayPtr[range].breakOffset = TclCurrCodeOffset(); /* @@ -5742,7 +6099,7 @@ TclCompileWhileCmd(interp, string, lastChar, flags, envPtr) envPtr); TclEmitPush(objIndex, envPtr); if (maxDepth == 0) { - maxDepth = 1; /* since we just pushed one object */ + maxDepth = 1; } /* @@ -5755,7 +6112,7 @@ TclCompileWhileCmd(interp, string, lastChar, flags, envPtr) src += envPtr->termOffset; type = CHAR_TYPE(src, lastChar); if (type != TCL_COMMAND_END) { - goto badArgs; /* too many arguments */ + goto badArgs; } } @@ -5827,6 +6184,7 @@ CompileExprWord(interp, string, lastChar, flags, envPtr) char c; int savePushSimpleWords = envPtr->pushSimpleWords; int saveExprIsJustVarRef = envPtr->exprIsJustVarRef; + int saveExprIsComparison = envPtr->exprIsComparison; int numChars, result; /* @@ -5872,7 +6230,7 @@ CompileExprWord(interp, string, lastChar, flags, envPtr) first = src+1; src = TclWordEnd(src, lastChar, nestedCmd, NULL); - if (*src == 0) { /* word doesn't end properly. */ + if (*src == 0) { goto badArgs; } if (*src != '}') { @@ -5882,12 +6240,12 @@ CompileExprWord(interp, string, lastChar, flags, envPtr) numChars = (last - first + 1); savedChar = first[numChars]; - first[numChars] = '\0'; /* replace term. char with null */ + first[numChars] = '\0'; result = TclCompileExpr(interp, first, first+numChars, flags, envPtr); - first[numChars] = savedChar; /* restore the saved char */ + first[numChars] = savedChar; - src++; /* advance src after terminating '}' */ + src++; maxDepth = envPtr->maxStackDepth; } else { /* @@ -5945,24 +6303,36 @@ CompileExprWord(interp, string, lastChar, flags, envPtr) envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset(); numChars = (last - first + 1); savedChar = first[numChars]; - first[numChars] = '\0'; /* replace term. char with null */ + first[numChars] = '\0'; result = TclCompileExpr(interp, first, first + numChars, flags, envPtr); - first[numChars] = savedChar; /* restore the saved char */ + first[numChars] = savedChar; envPtr->excRangeArrayPtr[range].numCodeBytes = TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset; - if ((envPtr->exprIsJustVarRef) || (result != TCL_OK)) { + if ((result != TCL_OK) || (envPtr->exprIsJustVarRef) + || (envPtr->exprIsComparison)) { /* - * We must call the expr command at runtime since the - * expression consisted of just a single variable reference - * (and a second round of substitutions might be needed) or - * there was a compilation error. Delete the inline code by - * backing up the code pc and catch index. Note that if - * there was a compilation error, we can't report the error - * yet since the expression might be valid after the second - * round of substitutions. + * We must call the expr command at runtime. Either there + * was a compilation error or the inline code might fail to + * give the correct 2 level substitution semantics. + * + * The latter can happen if the expression consisted of just + * a single variable reference or if the top-level operator + * in the expr is a comparison (which might operate on + * strings). In the latter case, the expression's code might + * execute (apparently) successfully but produce the wrong + * result. We depend on its execution failing if a second + * level of substitutions is required. This causes the + * "catch" code we generate around the inline code to back + * off to a call on the expr command at runtime, and this + * always gives the right 2 level substitution semantics. + * + * We delete the inline code by backing up the code pc and + * catch index. Note that if there was a compilation error, + * we can't report the error yet since the expression might + * be valid after the second round of substitutions. */ envPtr->codeNext = (envPtr->codeStart + startCodeOffset); @@ -6001,13 +6371,6 @@ CompileExprWord(interp, string, lastChar, flags, envPtr) * target since it, being after the jump, also moved down. */ -#ifdef TCL_COMPILE_DEBUG - if (envPtr->excRangeArrayPtr[range].type != CATCH_EXCEPTION_RANGE) { - panic("CompileExprWord: bad body ExceptionRange type %d\n", - envPtr->excRangeArrayPtr[range].type); - } -#endif /* TCL_COMPILE_DEBUG */ - envPtr->excRangeArrayPtr[range].catchOffset += 3; } } @@ -6018,6 +6381,7 @@ CompileExprWord(interp, string, lastChar, flags, envPtr) envPtr->maxStackDepth = maxDepth; envPtr->pushSimpleWords = savePushSimpleWords; envPtr->exprIsJustVarRef = saveExprIsJustVarRef; + envPtr->exprIsComparison = saveExprIsComparison; return result; } @@ -6079,8 +6443,8 @@ CompileCmdWordInline(interp, string, lastChar, flags, envPtr) type = CHAR_TYPE(src, lastChar); if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) { - src++; /* advance over the " or { */ - envPtr->pushSimpleWords = 0; /* we process a simple word below */ + src++; + envPtr->pushSimpleWords = 0; if (type == TCL_QUOTE) { result = TclCompileQuotes(interp, src, lastChar, '"', flags, envPtr); @@ -6132,7 +6496,7 @@ CompileCmdWordInline(interp, string, lastChar, flags, envPtr) *closeCharPos = '\0'; result = TclCompileString(interp, src, closeCharPos, (flags & ~TCL_BRACKET_TERM), envPtr); - *closeCharPos = savedChar; /* restore the saved char */ + *closeCharPos = savedChar; if (result != TCL_OK) { goto done; } @@ -6168,7 +6532,7 @@ CompileCmdWordInline(interp, string, lastChar, flags, envPtr) Tcl_Command cmd; Command *cmdPtr = NULL; - int wasCompiled = 0; /* set 1 if word has compile proc. */ + int wasCompiled = 0; savedChar = *p; *p = '\0'; @@ -6179,7 +6543,7 @@ CompileCmdWordInline(interp, string, lastChar, flags, envPtr) cmdPtr = (Command *) cmd; } if (cmdPtr != NULL && cmdPtr->compileProc != NULL) { - *p = savedChar; /* restore the saved char */ + *p = savedChar; src = p; iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET); @@ -6194,7 +6558,7 @@ CompileCmdWordInline(interp, string, lastChar, flags, envPtr) if (!wasCompiled) { objIndex = TclObjIndexForString(src, p-src, /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - *p = savedChar; /* restore the saved char */ + *p = savedChar; TclEmitPush(objIndex, envPtr); TclEmitInstUInt1(INST_INVOKE_STK1, 1, envPtr); src = p; @@ -6205,7 +6569,7 @@ CompileCmdWordInline(interp, string, lastChar, flags, envPtr) * Push the word and call eval at runtime. */ - envPtr->pushSimpleWords = 1; /* process words normally */ + envPtr->pushSimpleWords = 1; result = CompileWord(interp, src, lastChar, flags, envPtr); if (result != TCL_OK) { goto done; @@ -6312,7 +6676,7 @@ LookupCompiledLocal(name, nameChars, createIfNew, flagsIfCreated, procPtr) localPtr->flags = flagsIfCreated; localPtr->defValuePtr = NULL; if (name != NULL) { - strncpy(localPtr->name, name, (unsigned) nameChars); + memcpy((VOID *) localPtr->name, (VOID *) name, (size_t) nameChars); } localPtr->name[nameChars] = '\0'; procPtr->numCompiledLocals++; @@ -6387,12 +6751,12 @@ AdvanceToNextWord(string, envPtr) char Tcl_Backslash(src, readPtr) - char *src; /* Points to the backslash character of + CONST char *src; /* Points to the backslash character of * a backslash sequence. */ int *readPtr; /* Fill in with number of characters read * from src, unless NULL. */ { - register char *p = src+1; + CONST char *p = src + 1; char result; int count; @@ -6547,7 +6911,7 @@ TclObjIndexForString(string, length, allocStrRep, inHeap, envPtr) if (!new) { /* already in object table and array */ objIndex = (int) Tcl_GetHashValue(hPtr); if (inHeap) { - ckfree(string); /* since we own the string */ + ckfree(string); } return objIndex; } @@ -6562,17 +6926,18 @@ TclObjIndexForString(string, length, allocStrRep, inHeap, envPtr) if (allocStrRep) { if (inHeap) { /* use input string for obj's string rep */ objPtr->bytes = string; - } else { /* must allocate string rep */ + } else { if (length > 0) { objPtr->bytes = ckalloc((unsigned) length + 1); - memcpy(objPtr->bytes, string, (size_t) length); + memcpy((VOID *) objPtr->bytes, (VOID *) string, + (size_t) length); objPtr->bytes[length] = '\0'; } } objPtr->length = length; } else { /* leave the string rep NULL */ if (inHeap) { - ckfree(string); /* since we own the string */ + ckfree(string); } } @@ -6581,7 +6946,7 @@ TclObjIndexForString(string, length, allocStrRep, inHeap, envPtr) } objIndex = envPtr->objArrayNext; envPtr->objArrayPtr[objIndex] = objPtr; - Tcl_IncrRefCount(objPtr); /* since obj array now has a reference */ + Tcl_IncrRefCount(objPtr); envPtr->objArrayNext++; if (hPtr) { @@ -6754,10 +7119,16 @@ EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset) envPtr->mallocedCmdMap = 1; } + if (cmdIndex > 0) { + if (codeOffset < envPtr->cmdMapPtr[cmdIndex-1].codeOffset) { + panic("EnterCmdStartData: cmd map table not sorted by code offset"); + } + } + cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]); + cmdLocPtr->codeOffset = codeOffset; cmdLocPtr->srcOffset = srcOffset; cmdLocPtr->numSrcChars = -1; - cmdLocPtr->codeOffset = codeOffset; cmdLocPtr->numCodeBytes = -1; } @@ -6766,7 +7137,7 @@ EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset) * * EnterCmdExtentData -- * - * Registers the source and bytecode length of a command. This + * Registers the source and bytecode length for a command. This * information is used at runtime to map between instruction pc and * source locations. * @@ -6895,7 +7266,7 @@ CollectArgInfo(interp, string, lastChar, flags, argInfoPtr) } else if (*src == '"') { wordStart = src; src = TclWordEnd(src, lastChar, nestedCmd, NULL); - if (src == lastChar) { /* word doesn't end properly. */ + if (src == lastChar) { badStringTermination: Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), @@ -6905,9 +7276,9 @@ CollectArgInfo(interp, string, lastChar, flags, argInfoPtr) prev = (src-1); if (*src == '"') { wordEnd = src; - src++; /* skip over terminating '"' */ + src++; } else if ((*src == ';') && (*prev == '"')) { - scanningArgs = 0; /* found a terminating ';' */ + scanningArgs = 0; wordEnd = prev; } else { goto badStringTermination; @@ -6915,7 +7286,7 @@ CollectArgInfo(interp, string, lastChar, flags, argInfoPtr) } else if (*src == '{') { wordStart = src; src = TclWordEnd(src, lastChar, nestedCmd, NULL); - if (src == lastChar) { /* word doesn't end properly. */ + if (src == lastChar) { Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), "missing close-brace", -1); @@ -6924,9 +7295,9 @@ CollectArgInfo(interp, string, lastChar, flags, argInfoPtr) prev = (src-1); if (*src == '}') { wordEnd = src; - src++; /* skip over terminating '}' */ + src++; } else if ((*src == ';') && (*prev == '}')) { - scanningArgs = 0; /* found a terminating ';' */ + scanningArgs = 0; wordEnd = prev; } else { Tcl_ResetResult(interp); @@ -6938,17 +7309,17 @@ CollectArgInfo(interp, string, lastChar, flags, argInfoPtr) wordStart = src; src = TclWordEnd(src, lastChar, nestedCmd, NULL); prev = (src-1); - if (src == lastChar) { /* word doesn't end properly. */ + if (src == lastChar) { Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), "missing close-bracket or close-brace", -1); return TCL_ERROR; } else if (*src == ';') { - scanningArgs = 0; /* found a terminating ';' */ + scanningArgs = 0; wordEnd = prev; } else { wordEnd = src; - src++; /* advance to char after word */ + src++; if ((src == lastChar) || (*src == '\n') || ((*src == ']') && nestedCmd)) { scanningArgs = 0; @@ -7378,13 +7749,6 @@ TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold) int firstCmd, lastCmd, firstRange, lastRange, k; unsigned int numBytes; -#ifdef TCL_COMPILE_DEBUG - if (jumpDist > MAX_JUMP_DIST) { - fprintf(stderr, "\nTclFixupForwardJump: bad jump distance %u\n", jumpDist); - panic("TclFixupForwardJump: bad jump distance"); - } -#endif /*TCL_COMPILE_DEBUG*/ - if (jumpDist <= distThreshold) { jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset); switch (jumpFixupPtr->jumpType) { @@ -7398,7 +7762,7 @@ TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold) TclUpdateInstInt1AtPc(INST_JUMP_FALSE1, jumpDist, jumpPc); break; } - return 0; /* no need to grow the jump */ + return 0; } /* diff --git a/contrib/tcl/generic/tclCompile.h b/contrib/tcl/generic/tclCompile.h index 65bbe42..6dc3f03 100644 --- a/contrib/tcl/generic/tclCompile.h +++ b/contrib/tcl/generic/tclCompile.h @@ -6,7 +6,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclCompile.h 1.33 97/05/02 13:12:43 + * SCCS: @(#) tclCompile.h 1.37 97/08/07 19:11:50 */ #ifndef _TCLCOMPILATION @@ -55,11 +55,29 @@ extern int tclTraceCompile; extern int tclTraceExec; /* - * The number of bytecode compilations. + * The number of bytecode compilations and various other compilation-related + * statistics. The tclByteCodeCount and tclSourceCount arrays are used to + * hold the count of ByteCodes and sources whose sizes fall into various + * binary decades; e.g., tclByteCodeCount[5] is a count of the ByteCodes + * with size larger than 2**4 and less than or equal to 2**5. */ #ifdef TCL_COMPILE_STATS extern long tclNumCompilations; +extern double tclTotalSourceBytes; +extern double tclTotalCodeBytes; + +extern double tclTotalInstBytes; +extern double tclTotalObjBytes; +extern double tclTotalExceptBytes; +extern double tclTotalAuxBytes; +extern double tclTotalCmdMapBytes; + +extern double tclCurrentSourceBytes; +extern double tclCurrentCodeBytes; + +extern int tclSourceCount[32]; +extern int tclByteCodeCount[32]; #endif /* TCL_COMPILE_STATS */ /* @@ -115,15 +133,17 @@ typedef struct ExceptionRange { /* * Structure used to map between instruction pc and source locations. It - * defines for each compiled Tcl command the starting and ending offsets for - * its source and code. + * 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 numSrcChars; /* Number of command source chars. */ - int codeOffset; /* Offset of first byte of command code. */ - int numCodeBytes; /* Number of code bytes for command code. */ } CmdLocation; /* @@ -222,6 +242,12 @@ typedef struct CompileEnv { * of "if $b then...". Otherwise 0. Used * to implement expr's 2 level substitution * semantics properly. */ + int exprIsComparison; /* Set 1 if the top-level operator in the + * expression last compiled is a comparison. + * Otherwise 0. If 1, since the operands + * might be strings, the expr is compiled + * out-of-line to implement expr's 2 level + * substitution semantics properly. */ int termOffset; /* Offset of character just after the last * one compiled. Set by compilation * procedures before returning. */ @@ -307,12 +333,17 @@ typedef struct ByteCode { * pointer is also not owned by the ByteCode * and must not be freed by it. Used for * debugging. */ + size_t totalSize; /* Total number of bytes required for this + * ByteCode structure including the storage + * for Tcl objects in its object array. */ int numCommands; /* Number of commands compiled. */ int numSrcChars; /* Number of source chars compiled. */ int numCodeBytes; /* Number of code bytes. */ int numObjects; /* Number of Tcl objects in object array. */ int numExcRanges; /* Number of ExceptionRange array elems. */ int numAuxDataItems; /* Number of AuxData items. */ + int numCmdLocBytes; /* Number of bytes needed for encoded + * command location information. */ int maxExcRangeDepth; /* Maximum nesting level of ExceptionRanges; * -1 if no ranges were compiled. */ int maxStackDepth; /* Maximum number of stack elements needed @@ -326,13 +357,43 @@ typedef struct ByteCode { /* Points to the start of the ExceptionRange * array. This is just after the last * object in the object array. */ - CmdLocation *cmdMapPtr; /* Points to pc <-> source map: an array of - * numCommands CmdLocation structures. This - * is just after the last entry in the - * ExceptionRange array. */ AuxData *auxDataArrayPtr; /* Points to the start of the auxiliary data * array. This is just after the last entry - * in the CmdLocation array. */ + * 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. */ } ByteCode; /* @@ -709,14 +770,15 @@ EXTERN int TclFixupForwardJump _ANSI_ARGS_(( EXTERN void TclFreeCompileEnv _ANSI_ARGS_((CompileEnv *envPtr)); EXTERN void TclFreeJumpFixupArray _ANSI_ARGS_(( JumpFixupArray *fixupArrayPtr)); -EXTERN int TclGetSrcInfoForPc _ANSI_ARGS_((unsigned char *pc, - ByteCode* codePtr)); EXTERN void TclInitByteCodeObj _ANSI_ARGS_((Tcl_Obj *objPtr, CompileEnv *envPtr)); EXTERN void TclInitCompileEnv _ANSI_ARGS_((Tcl_Interp *interp, CompileEnv *envPtr, char *string)); EXTERN void TclInitJumpFixupArray _ANSI_ARGS_(( JumpFixupArray *fixupArrayPtr)); +#ifdef TCL_COMPILE_STATS +EXTERN int TclLog2 _ANSI_ARGS_((int value)); +#endif /*TCL_COMPILE_STATS*/ EXTERN int TclObjIndexForString _ANSI_ARGS_((char *start, int length, int allocStrRep, int inHeap, CompileEnv *envPtr)); @@ -826,7 +888,7 @@ EXTERN void TclPrintSource _ANSI_ARGS_((FILE *outFile, /* * 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 + * 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: * * EXTERN void TclEmitPush _ANSI_ARGS_((int objIndex, CompileEnv *envPtr)); @@ -840,22 +902,22 @@ EXTERN void TclPrintSource _ANSI_ARGS_((FILE *outFile, } /* - * Macros to update a (signed or unsigned) integer starting at a bytecode - * pc. The two variants depend on the number of bytes. The ANSI C - * "prototypes" for these macros are: + * 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: * - * EXTERN void TclUpdateInt1AtPc _ANSI_ARGS_((int i, unsigned char *pc)); - * EXTERN void TclUpdateInt4AtPc _ANSI_ARGS_((int i, unsigned char *pc)); + * EXTERN void TclStoreInt1AtPtr _ANSI_ARGS_((int i, unsigned char *p)); + * EXTERN void TclStoreInt4AtPtr _ANSI_ARGS_((int i, unsigned char *p)); */ -#define TclUpdateInt1AtPc(i, pc) \ - *(pc) = (unsigned char) ((unsigned int) (i)) +#define TclStoreInt1AtPtr(i, p) \ + *(p) = (unsigned char) ((unsigned int) (i)) -#define TclUpdateInt4AtPc(i, pc) \ - *(pc) = (unsigned char) ((unsigned int) (i) >> 24); \ - *(pc+1) = (unsigned char) ((unsigned int) (i) >> 16); \ - *(pc+2) = (unsigned char) ((unsigned int) (i) >> 8); \ - *(pc+3) = (unsigned char) ((unsigned int) (i) ) +#define TclStoreInt4AtPtr(i, p) \ + *(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) ) /* * Macros to update instructions at a particular pc with a new op code @@ -870,54 +932,54 @@ EXTERN void TclPrintSource _ANSI_ARGS_((FILE *outFile, #define TclUpdateInstInt1AtPc(op, i, pc) \ *(pc) = (unsigned char) (op); \ - TclUpdateInt1AtPc((i), ((pc)+1)) + TclStoreInt1AtPtr((i), ((pc)+1)) #define TclUpdateInstInt4AtPc(op, i, pc) \ *(pc) = (unsigned char) (op); \ - TclUpdateInt4AtPc((i), ((pc)+1)) + TclStoreInt4AtPtr((i), ((pc)+1)) /* * Macros to get a signed integer (GET_INT{1,2}) or an unsigned int - * (GET_UINT{1,2}) from a code pc pointer. There are two variants for each - * return type that depend on the number of bytes fetched from the code - * sequence. The ANSI C "prototypes" for these macros are: + * (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: * - * EXTERN int TclGetInt1AtPc _ANSI_ARGS_((unsigned char *pc)); - * EXTERN int TclGetInt4AtPc _ANSI_ARGS_((unsigned char *pc)); - * EXTERN unsigned int TclGetUInt1AtPc _ANSI_ARGS_((unsigned char *pc)); - * EXTERN unsigned int TclGetUInt4AtPc _ANSI_ARGS_((unsigned char *pc)); + * EXTERN int TclGetInt1AtPtr _ANSI_ARGS_((unsigned char *p)); + * EXTERN int TclGetInt4AtPtr _ANSI_ARGS_((unsigned char *p)); + * EXTERN unsigned int TclGetUInt1AtPtr _ANSI_ARGS_((unsigned char *p)); + * EXTERN unsigned int TclGetUInt4AtPtr _ANSI_ARGS_((unsigned char *p)); */ /* - * The TclGetInt1AtPc macro is tricky because we want to do sign + * 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 + * 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 TclGetInt1AtPc(pc) ((int) *((char *) pc)) +# define TclGetInt1AtPtr(p) ((int) *((char *) p)) #else # ifdef HAVE_SIGNED_CHAR -# define TclGetInt1AtPc(pc) ((int) *((signed char *) pc)) +# define TclGetInt1AtPtr(p) ((int) *((signed char *) p)) # else -# define TclGetInt1AtPc(pc) (((int) *((char *) pc)) \ - | ((*(pc) & 0200) ? (-256) : 0)) +# define TclGetInt1AtPtr(p) (((int) *((char *) p)) \ + | ((*(p) & 0200) ? (-256) : 0)) # endif #endif -#define TclGetInt4AtPc(pc) (((int) TclGetInt1AtPc(pc) << 24) | \ - (*((pc)+1) << 16) | \ - (*((pc)+2) << 8) | \ - (*((pc)+3))) +#define TclGetInt4AtPtr(p) (((int) TclGetInt1AtPtr(p) << 24) | \ + (*((p)+1) << 16) | \ + (*((p)+2) << 8) | \ + (*((p)+3))) -#define TclGetUInt1AtPc(pc) ((unsigned int) *(pc)) -#define TclGetUInt4AtPc(pc) ((unsigned int) (*(pc) << 24) | \ - (*((pc)+1) << 16) | \ - (*((pc)+2) << 8) | \ - (*((pc)+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. diff --git a/contrib/tcl/generic/tclEnv.c b/contrib/tcl/generic/tclEnv.c index f619769..8027f5e 100644 --- a/contrib/tcl/generic/tclEnv.c +++ b/contrib/tcl/generic/tclEnv.c @@ -2,7 +2,9 @@ * tclEnv.c -- * * Tcl support for environment variables, including a setenv - * procedure. + * procedure. This file contains the generic portion of the + * environment module. It is primarily responsible for keeping + * the "env" arrays in sync with the system environment variables. * * Copyright (c) 1991-1994 The Regents of the University of California. * Copyright (c) 1994-1996 Sun Microsystems, Inc. @@ -10,21 +12,11 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclEnv.c 1.43 97/05/21 17:10:56 + * SCCS: @(#) tclEnv.c 1.49 97/08/11 20:22:40 */ -/* - * The putenv and setenv definitions below cause any system prototypes for - * those procedures to be ignored so that there won't be a clash when the - * versions in this file are compiled. - */ - -#define putenv ignore_putenv -#define setenv ignore_setenv #include "tclInt.h" #include "tclPort.h" -#undef putenv -#undef setenv /* * The structure below is used to keep track of all of the interpereters @@ -44,25 +36,30 @@ static EnvInterp *firstInterpPtr = NULL; /* First in list of all managed interpreters, * or NULL if none. */ -static int environSize = 0; /* Non-zero means that the all of the - * environ-related information is malloc-ed - * and the environ array itself has this - * many total entries allocated to it (not - * all may be in use at once). Zero means - * that the environment array is in its - * original static state. */ +static int cacheSize = 0; /* Number of env strings in environCache. */ +static char **environCache = NULL; + /* Array containing all of the environment + * strings that Tcl has allocated. */ + +#ifndef USE_PUTENV +static int environSize = 0; /* Non-zero means that the environ array was + * malloced and has this many total entries + * allocated to it (not all may be in use at + * once). Zero means that the environment + * array is in its original static state. */ +#endif /* * Declarations for local procedures defined in this file: */ -static void EnvExitProc _ANSI_ARGS_((ClientData clientData)); -static void EnvInit _ANSI_ARGS_((void)); static char * EnvTraceProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, char *name1, char *name2, int flags)); static int FindVariable _ANSI_ARGS_((CONST char *name, int *lengthPtr)); +static void ReplaceString _ANSI_ARGS_((CONST char *oldStr, + char *newStr)); void TclSetEnv _ANSI_ARGS_((CONST char *name, CONST char *value)); void TclUnsetEnv _ANSI_ARGS_((CONST char *name)); @@ -100,14 +97,11 @@ TclSetupEnv(interp) Tcl_DString ds; int i, sz; - /* - * First, initialize our environment-related information, if - * necessary. - */ - - if (environSize == 0) { - EnvInit(); +#ifdef MAC_TCL + if (environ == NULL) { + environSize = TclMacCreateEnv(); } +#endif /* * Next, initialize the DString we are going to use for copying @@ -170,97 +164,6 @@ TclSetupEnv(interp) /* *---------------------------------------------------------------------- * - * FindVariable -- - * - * Locate the entry in environ for a given name. - * - * Results: - * The return value is the index in environ of an entry with the - * name "name", or -1 if there is no such entry. The integer at - * *lengthPtr is filled in with the length of name (if a matching - * entry is found) or the length of the environ array (if no matching - * entry is found). - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -FindVariable(name, lengthPtr) - CONST char *name; /* Name of desired environment variable. */ - int *lengthPtr; /* Used to return length of name (for - * successful searches) or number of non-NULL - * entries in environ (for unsuccessful - * searches). */ -{ - int i; - register CONST char *p1, *p2; - - for (i = 0, p1 = environ[i]; p1 != NULL; i++, p1 = environ[i]) { - for (p2 = name; *p2 == *p1; p1++, p2++) { - /* NULL loop body. */ - } - if ((*p1 == '=') && (*p2 == '\0')) { - *lengthPtr = p2-name; - return i; - } - } - *lengthPtr = i; - return -1; -} - -/* - *---------------------------------------------------------------------- - * - * TclGetEnv -- - * - * Get an environment variable or return NULL if the variable - * doesn't exist. This procedure is intended to be a - * stand-in for the UNIX "getenv" procedure so that applications - * using that procedure will interface properly to Tcl. To make - * it a stand-in, the Makefile must define "TclGetEnv" to "getenv". - * - * Results: - * ptr to value on success, NULL if error. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -char * -TclGetEnv(name) - char *name; /* Name of desired environment variable. */ -{ - int i; - size_t len, nameLen; - char *equal; - - nameLen = strlen(name); - for (i = 0; environ[i] != NULL; i++) { - equal = strchr(environ[i], '='); - if (equal == NULL) { - continue; - } - len = (size_t) (equal - environ[i]); - if ((len == nameLen) && (strncmp(name, environ[i], len) == 0)) { - /* - * The caller of this function should regard this - * as static memory. - */ - return &environ[i][len+1]; - } - } - - return NULL; -} - -/* - *---------------------------------------------------------------------- - * * TclSetEnv -- * * Set an environment variable, replacing an existing value @@ -287,12 +190,14 @@ TclSetEnv(name, value) CONST char *value; /* New value for variable. */ { int index, length, nameLength; - char *p; + char *p, *oldValue; EnvInterp *eiPtr; - if (environSize == 0) { - EnvInit(); +#ifdef MAC_TCL + if (environ == NULL) { + environSize = TclMacCreateEnv(); } +#endif /* * Figure out where the entry is going to go. If the name doesn't @@ -302,6 +207,7 @@ TclSetEnv(name, value) index = FindVariable(name, &length); if (index == -1) { +#ifndef USE_PUTENV if ((length+2) > environSize) { char **newEnviron; @@ -309,12 +215,16 @@ TclSetEnv(name, value) ((length+5) * sizeof(char *))); memcpy((VOID *) newEnviron, (VOID *) environ, length*sizeof(char *)); - ckfree((char *) environ); + if (environSize != 0) { + ckfree((char *) environ); + } environ = newEnviron; environSize = length+5; } index = length; environ[index+1] = NULL; +#endif + oldValue = NULL; nameLength = strlen(name); } else { /* @@ -328,35 +238,44 @@ TclSetEnv(name, value) if (strcmp(value, environ[index]+length+1) == 0) { return; } - ckfree(environ[index]); + oldValue = environ[index]; nameLength = length; } + + + /* + * Update all of the interpreters. + */ + + for (eiPtr= firstInterpPtr; eiPtr != NULL; eiPtr = eiPtr->nextPtr) { + (void) Tcl_SetVar2(eiPtr->interp, "env", (char *) name, + (char *) value, TCL_GLOBAL_ONLY); + } /* - * Create a new entry and enter it into the table. + * Create a new entry. */ p = (char *) ckalloc((unsigned) (nameLength + strlen(value) + 2)); - environ[index] = p; strcpy(p, name); - p += nameLength; - *p = '='; - strcpy(p+1, value); + p[nameLength] = '='; + strcpy(p+nameLength+1, value); /* - * Update all of the interpreters. + * Update the system environment. */ - for (eiPtr= firstInterpPtr; eiPtr != NULL; eiPtr = eiPtr->nextPtr) { - (void) Tcl_SetVar2(eiPtr->interp, "env", (char *) name, - p+1, TCL_GLOBAL_ONLY); - } +#ifdef USE_PUTENV + putenv(p); +#else + environ[index] = p; +#endif /* - * Update the system environment. + * Replace the old value with the new value in the cache. */ - TclSetSystemEnv(name, value); + ReplaceString(oldValue, p); } /* @@ -408,7 +327,7 @@ Tcl_PutEnv(string) return 0; } name = (char *) ckalloc((unsigned) nameLength+1); - memcpy(name, string, (size_t) nameLength); + memcpy((VOID *) name, (VOID *) string, (size_t) nameLength); name[nameLength] = 0; TclSetEnv(name, value+1); ckfree(name); @@ -439,29 +358,63 @@ void TclUnsetEnv(name) CONST char *name; /* Name of variable to remove. */ { - int index, dummy; - char **envPtr; EnvInterp *eiPtr; + char *oldValue; + int length, index; +#ifdef USE_PUTENV + char *string; +#else + char **envPtr; +#endif - if (environSize == 0) { - EnvInit(); +#ifdef MAC_TCL + if (environ == NULL) { + environSize = TclMacCreateEnv(); } +#endif + + index = FindVariable(name, &length); /* - * Update the environ array. + * First make sure that the environment variable exists to avoid + * doing needless work and to avoid recursion on the unset. */ - - index = FindVariable(name, &dummy); + if (index == -1) { return; } - ckfree(environ[index]); + /* + * Remember the old value so we can free it if Tcl created the string. + */ + + oldValue = environ[index]; + + /* + * Update the system environment. This must be done before we + * update the interpreters or we will recurse. + */ + +#ifdef USE_PUTENV + string = ckalloc(length+2); + memcpy((VOID *) string, (VOID *) name, (size_t) length); + string[length] = '='; + string[length+1] = '\0'; + putenv(string); + ckfree(string); +#else for (envPtr = environ+index+1; ; envPtr++) { envPtr[-1] = *envPtr; if (*envPtr == NULL) { break; - } + } } +#endif + + /* + * Replace the old value in the cache. + */ + + ReplaceString(oldValue, NULL); /* * Update all of the interpreters. @@ -471,12 +424,43 @@ TclUnsetEnv(name) (void) Tcl_UnsetVar2(eiPtr->interp, "env", (char *) name, TCL_GLOBAL_ONLY); } +} + +/* + *---------------------------------------------------------------------- + * + * TclGetEnv -- + * + * Retrieve the value of an environment variable. + * + * Results: + * Returns a pointer to a static string in the environment, + * or NULL if the value was not found. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - /* - * Update the system environment. - */ +char * +TclGetEnv(name) + CONST char *name; /* Name of variable to find. */ +{ + int length, index; + +#ifdef MAC_TCL + if (environ == NULL) { + environSize = TclMacCreateEnv(); + } +#endif - TclSetSystemEnv(name, NULL); + index = FindVariable(name, &length); + if ((index != -1) && (*(environ[index]+length) == '=')) { + return environ[index]+length+1; + } else { + return NULL; + } } /* @@ -560,91 +544,151 @@ EnvTraceProc(clientData, interp, name1, name2, flags) /* *---------------------------------------------------------------------- * - * EnvInit -- + * ReplaceString -- * - * This procedure is called to initialize our management - * of the environ array. + * Replace one string with another in the environment variable + * cache. The cache keeps track of all of the environment + * variables that Tcl has modified so they can be freed later. * * Results: * None. * * Side effects: - * Environ gets copied to malloc-ed storage, so that in - * the future we don't have to worry about which entries - * are malloc-ed and which are static. + * May free the old string. * *---------------------------------------------------------------------- */ static void -EnvInit() +ReplaceString(oldStr, newStr) + CONST char *oldStr; /* Old environment string. */ + char *newStr; /* New environment string. */ { -#ifdef MAC_TCL - environSize = TclMacCreateEnv(); -#else - char **newEnviron, **oldEnviron; - int i, length; + int i; + char **newCache; - oldEnviron = environ; - if (environSize != 0) { - return; - } - for (length = 0; environ[length] != NULL; length++) { - /* Empty loop body. */ + /* + * Check to see if the old value was allocated by Tcl. If so, + * it needs to be deallocated to avoid memory leaks. Note that this + * algorithm is O(n), not O(1). This will result in n-squared behavior + * if lots of environment changes are being made. + */ + + for (i = 0; i < cacheSize; i++) { + if ((environCache[i] == oldStr) || (environCache[i] == NULL)) { + break; + } } - environSize = length+5; - newEnviron = (char **) ckalloc((unsigned) - (environSize * sizeof(char *))); - for (i = 0; i < length; i++) { - newEnviron[i] = (char *) ckalloc((unsigned) (strlen(environ[i]) + 1)); - strcpy(newEnviron[i], environ[i]); + if (i < cacheSize) { + /* + * Replace or delete the old value. + */ + + if (environCache[i]) { + ckfree(environCache[i]); + } + + if (newStr) { + environCache[i] = newStr; + } else { + for (; i < cacheSize-1; i++) { + environCache[i] = environCache[i+1]; + } + environCache[cacheSize-1] = NULL; + } + } else { + /* + * We need to grow the cache in order to hold the new string. + */ + + newCache = (char **) ckalloc((cacheSize + 5) * sizeof(char *)); + if (environCache) { + memcpy((VOID *) newCache, (VOID *) environCache, + (size_t) (cacheSize * sizeof(char*))); + ckfree((char *) environCache); + } + environCache = newCache; + environCache[cacheSize] = (char *) newStr; + environCache[cacheSize+1] = NULL; + cacheSize += 5; } - newEnviron[length] = NULL; - environ = newEnviron; - Tcl_CreateExitHandler(EnvExitProc, (ClientData) oldEnviron); -#endif } /* *---------------------------------------------------------------------- * - * EnvExitProc -- + * FindVariable -- * - * This procedure is called just before the process exits. It - * frees the memory associated with environment variables. + * Locate the entry in environ for a given name. * * Results: - * None. + * The return value is the index in environ of an entry with the + * name "name", or -1 if there is no such entry. The integer at + * *lengthPtr is filled in with the length of name (if a matching + * entry is found) or the length of the environ array (if no matching + * entry is found). * * Side effects: - * Memory is freed. + * None. * *---------------------------------------------------------------------- */ -static void -EnvExitProc(clientData) - ClientData clientData; /* Old environment pointer -- restore this. */ +static int +FindVariable(name, lengthPtr) + CONST char *name; /* Name of desired environment variable. */ + int *lengthPtr; /* Used to return length of name (for + * successful searches) or number of non-NULL + * entries in environ (for unsuccessful + * searches). */ { - char **p; - EnvInterp *eiPtr, *nextPtr; + int i; + register CONST char *p1, *p2; - for (p = environ; *p != NULL; p++) { - ckfree(*p); + for (i = 0, p1 = environ[i]; p1 != NULL; i++, p1 = environ[i]) { + for (p2 = name; *p2 == *p1; p1++, p2++) { + /* NULL loop body. */ + } + if ((*p1 == '=') && (*p2 == '\0')) { + *lengthPtr = p2-name; + return i; + } } - ckfree((char *) environ); + *lengthPtr = i; + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * TclFinalizeEnvironment -- + * + * This function releases any storage allocated by this module + * that isn't still in use by the global environment. Any + * strings that are still in the environment will be leaked. + * + * Results: + * None. + * + * Side effects: + * May deallocate storage. + * + *---------------------------------------------------------------------- + */ +void +TclFinalizeEnvironment() +{ /* - * Note that we need to reset the environ global so the Borland C run-time - * doesn't choke on exit. + * For now we just deallocate the cache array and none of the environment + * strings. This may leak more memory that strictly necessary, since some + * of the strings may no longer be in the environment. However, + * determining which ones are ok to delete is n-squared, and is pretty + * unlikely, so we don't bother. */ - environ = (char **) clientData; - environSize = 0; - - for (eiPtr = firstInterpPtr; eiPtr != NULL; eiPtr = nextPtr) { - nextPtr = eiPtr->nextPtr; - ckfree((char *) eiPtr); + if (environCache) { + ckfree((char *) environCache); + environCache = NULL; } - firstInterpPtr = NULL; } diff --git a/contrib/tcl/generic/tclEvent.c b/contrib/tcl/generic/tclEvent.c index a503df7..4672982 100644 --- a/contrib/tcl/generic/tclEvent.c +++ b/contrib/tcl/generic/tclEvent.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclEvent.c 1.152 97/05/21 07:06:19 + * SCCS: @(#) tclEvent.c 1.153 97/08/11 20:22:31 */ #include "tclInt.h" @@ -516,6 +516,10 @@ Tcl_Finalize() { ExitHandler *exitPtr; + /* + * Invoke exit handler first. + */ + tclInExit = 1; for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) { /* @@ -530,11 +534,12 @@ Tcl_Finalize() } /* - * Uninitialize everything associated with the compile and execute - * environment. This *must* be done at the latest possible time. + * Now finalize the Tcl execution environment. Note that this must be done + * after the exit handlers, because there are order dependencies. */ TclFinalizeCompExecEnv(); + TclFinalizeEnvironment(); firstExitPtr = NULL; tclInExit = 0; } diff --git a/contrib/tcl/generic/tclExecute.c b/contrib/tcl/generic/tclExecute.c index 111cf4b..4c12437 100644 --- a/contrib/tcl/generic/tclExecute.c +++ b/contrib/tcl/generic/tclExecute.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclExecute.c 1.81 97/06/26 13:50:03 + * SCCS: @(#) tclExecute.c 1.95 97/08/12 17:06:49 */ #include "tclInt.h" @@ -21,7 +21,7 @@ # include <float.h> #endif #ifndef TCL_NO_MATH -#include <math.h> +#include "tclMath.h" #endif /* @@ -119,8 +119,8 @@ static char *resultStrings[] = { */ #ifdef TCL_COMPILE_STATS -static int instructionCount[256]; static long numExecutions = 0; +static int instructionCount[256]; #endif /* TCL_COMPILE_STATS */ /* @@ -283,18 +283,27 @@ static int EvalStatsCmd _ANSI_ARGS_((ClientData clientData, #endif /* TCL_COMPILE_STATS */ static void FreeCmdNameInternalRep _ANSI_ARGS_(( Tcl_Obj *objPtr)); +static char * GetSrcInfoForPc _ANSI_ARGS_((unsigned char *pc, + ByteCode* codePtr, int *lengthPtr)); static void GrowEvaluationStack _ANSI_ARGS_((ExecEnv *eePtr)); static void IllegalExprOperandType _ANSI_ARGS_(( Tcl_Interp *interp, unsigned int opCode, Tcl_Obj *opndPtr)); static void InitByteCodeExecution _ANSI_ARGS_(( Tcl_Interp *interp)); +static void PrintByteCodeInfo _ANSI_ARGS_((ByteCode *codePtr)); static int SetCmdNameFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); #ifdef TCL_COMPILE_DEBUG static char * StringForResultCode _ANSI_ARGS_((int result)); #endif /* TCL_COMPILE_DEBUG */ static void UpdateStringOfCmdName _ANSI_ARGS_((Tcl_Obj *objPtr)); +#ifdef TCL_COMPILE_DEBUG +static void ValidatePcAndStackTop _ANSI_ARGS_(( + ByteCode *codePtr, unsigned char *pc, + int stackTop, int stackLowerBound, + int stackUpperBound)); +#endif /* TCL_COMPILE_DEBUG */ /* * Table describing the built-in math functions. Entries in this table are @@ -388,6 +397,9 @@ InitByteCodeExecution(interp) #ifdef TCL_COMPILE_STATS (VOID *) memset(instructionCount, 0, sizeof(instructionCount)); + (VOID *) memset(tclByteCodeCount, 0, sizeof(tclByteCodeCount)); + (VOID *) memset(tclSourceCount, 0, sizeof(tclSourceCount)); + Tcl_CreateCommand(interp, "evalstats", EvalStatsCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); #endif /* TCL_COMPILE_STATS */ @@ -607,24 +619,7 @@ TclExecuteByteCode(interp, codePtr) */ if (tclTraceExec >= 2) { - Proc *procPtr = codePtr->procPtr; - fprintf(stdout, "\nExecuting ByteCode 0x%x, ref ct %u, epoch %u, cmds %u, interp 0x%x, interp epoch %u\n", - (unsigned int) codePtr, codePtr->refCount, - codePtr->compileEpoch, codePtr->numCommands, - (unsigned int) codePtr->iPtr, codePtr->iPtr->compileEpoch); - if (procPtr != NULL) { - fprintf(stdout, - " Proc 0x%x, ref ct=%d, %d args, %d compiled locals\n", - (unsigned int) procPtr, procPtr->refCount, - procPtr->numArgs, procPtr->numCompiledLocals); - } - fprintf(stdout, " Source: "); - TclPrintSource(stdout, codePtr->source, 70); - fprintf(stdout, "\n"); - fprintf(stdout, " Chars=%d, bytes=%u, objs=%u, stk depth=%u, exc depth=%d, aux items=%d\n", - codePtr->numSrcChars, codePtr->numCodeBytes, - codePtr->numObjects, codePtr->maxStackDepth, - codePtr->maxExcRangeDepth, codePtr->numAuxDataItems); + PrintByteCodeInfo(codePtr); #ifdef TCL_COMPILE_STATS fprintf(stdout, " Starting stack top=%d, system objects=%ld\n", eePtr->stackTop, (tclObjsAlloced - tclObjsFreed)); @@ -671,44 +666,10 @@ TclExecuteByteCode(interp, codePtr) */ for (;;) { - opCode = *pc; - #ifdef TCL_COMPILE_DEBUG - if (((unsigned int) pc < (unsigned int) codePtr->codeStart) - || ((unsigned int) pc > (unsigned int) (codePtr->codeStart + codePtr->numCodeBytes))) { - fprintf(stderr, - "\nTclExecuteByteCode: bad instruction pc 0x%x\n", - (unsigned int) pc); - panic("TclExecuteByteCode execution failure: bad pc"); - } - if ((unsigned int) opCode > LAST_INST_OPCODE) { - fprintf(stderr, - "\nTclExecuteByteCode: bad opcode %d at pc %u\n", - (unsigned int) opCode, - (unsigned int)(pc - codePtr->codeStart)); - panic("TclExecuteByteCode execution failure: bad opcode"); - } - if ((stackTop < initStackTop) || (stackTop > eePtr->stackEnd)) { - int cmdIndex = TclGetSrcInfoForPc(pc, codePtr); - fprintf(stderr, - "\nTclExecuteByteCode: bad stack top %d at pc %u", - stackTop, (unsigned int)(pc - codePtr->codeStart)); - if (cmdIndex != -1) { - CmdLocation *locPtr = &(codePtr->cmdMapPtr[cmdIndex]); - char *ellipsis = ""; - int numChars = locPtr->numSrcChars; - if (numChars > 100) { - numChars = 100; - ellipsis = "..."; - } - fprintf(stderr, "\n executing %.*s%s\n", numChars, - (codePtr->source + locPtr->srcOffset), ellipsis); - } else { - fprintf(stderr, "\n"); - } - panic("TclExecuteByteCode execution failure: bad stack top"); - } -#else /* not TCL_COMPILE_DEBUG - print generic trace if so requested */ + ValidatePcAndStackTop(codePtr, pc, stackTop, initStackTop, + eePtr->stackEnd); +#else /* not TCL_COMPILE_DEBUG */ if (traceInstructions) { #ifdef TCL_COMPILE_STATS fprintf(stdout, "%d: %d,%ld ", iPtr->numLevels, stackTop, @@ -721,10 +682,11 @@ TclExecuteByteCode(interp, codePtr) } #endif /* TCL_COMPILE_DEBUG */ + opCode = *pc; #ifdef TCL_COMPILE_STATS instructionCount[opCode]++; #endif /* TCL_COMPILE_STATS */ - + switch (opCode) { case INST_DONE: /* @@ -733,7 +695,7 @@ TclExecuteByteCode(interp, codePtr) */ valuePtr = POP_OBJECT(); Tcl_SetObjResult(interp, valuePtr); - TclDecrRefCount(valuePtr); /* done with valuePtr */ + TclDecrRefCount(valuePtr); if (stackTop != initStackTop) { fprintf(stderr, "\nTclExecuteByteCode: done instruction at pc %u: stack top %d != entry stack top %d\n", (unsigned int)(pc - codePtr->codeStart), @@ -748,16 +710,16 @@ TclExecuteByteCode(interp, codePtr) goto done; case INST_PUSH1: - valuePtr = objArrayPtr[TclGetUInt1AtPc(pc+1)]; + valuePtr = objArrayPtr[TclGetUInt1AtPtr(pc+1)]; PUSH_OBJECT(valuePtr); - TRACE_WITH_OBJ(("push1 %u => ", TclGetUInt1AtPc(pc+1)), + TRACE_WITH_OBJ(("push1 %u => ", TclGetUInt1AtPtr(pc+1)), valuePtr); ADJUST_PC(2); case INST_PUSH4: - valuePtr = objArrayPtr[TclGetUInt4AtPc(pc+1)]; + valuePtr = objArrayPtr[TclGetUInt4AtPtr(pc+1)]; PUSH_OBJECT(valuePtr); - TRACE_WITH_OBJ(("push4 %u => ", TclGetUInt4AtPc(pc+1)), + TRACE_WITH_OBJ(("push4 %u => ", TclGetUInt4AtPtr(pc+1)), valuePtr); ADJUST_PC(5); @@ -774,7 +736,7 @@ TclExecuteByteCode(interp, codePtr) ADJUST_PC(1); case INST_CONCAT1: - opnd = TclGetUInt1AtPc(pc+1); + opnd = TclGetUInt1AtPtr(pc+1); { Tcl_Obj *concatObjPtr; int totalLen = 0; @@ -828,12 +790,12 @@ TclExecuteByteCode(interp, codePtr) } case INST_INVOKE_STK4: - opnd = TclGetUInt4AtPc(pc+1); + opnd = TclGetUInt4AtPtr(pc+1); pcAdjustment = 5; goto doInvocation; case INST_INVOKE_STK1: - opnd = TclGetUInt1AtPc(pc+1); + opnd = TclGetUInt1AtPtr(pc+1); pcAdjustment = 2; doInvocation: @@ -926,16 +888,12 @@ TclExecuteByteCode(interp, codePtr) for (tracePtr = iPtr->tracePtr; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { if (iPtr->numLevels <= tracePtr->level) { - int cmdIndex = TclGetSrcInfoForPc(pc, codePtr); - if (cmdIndex != -1) { - CmdLocation *locPtr = - &(codePtr->cmdMapPtr[cmdIndex]); - char *command = - (codePtr->source + locPtr->srcOffset); - int numChars = locPtr->numSrcChars; + int numChars; + char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars); + if (cmd != NULL) { DECACHE_STACK_INFO(); CallTraceProcedure(interp, tracePtr, cmdPtr, - command, numChars, objc, objv); + cmd, numChars, objc, objv); CACHE_STACK_INFO(); } } @@ -1083,41 +1041,12 @@ TclExecuteByteCode(interp, codePtr) case TCL_ERROR: /* - * The invoked command returned an error. Record - * information about what was being executed when the - * error occurred, then look for an enclosing catch - * exception range, if any. + * The invoked command returned an error. Look for an + * enclosing catch exception range, if any. */ TRACE_WITH_OBJ(("%s %u => ... after \"%.20s\", TCL_ERROR ", opName[opCode], objc, cmdNameBuf), Tcl_GetObjResult(interp)); - if (!(iPtr->flags & ERR_ALREADY_LOGGED)) { - char buf[200]; - int cmdIndex = TclGetSrcInfoForPc(pc, codePtr); - if (cmdIndex != -1) { - CmdLocation *locPtr = - &(codePtr->cmdMapPtr[cmdIndex]); - char *ellipsis = ""; - int numChars = locPtr->numSrcChars; - if (numChars > 150) { - numChars = 150; - ellipsis = "..."; - } - if (!(iPtr->flags & ERR_IN_PROGRESS)) { - sprintf(buf, "\n while executing\n\"%.*s%s\"", - numChars, - (codePtr->source + locPtr->srcOffset), - ellipsis); - } else { - sprintf(buf, "\n invoked from within\n\"%.*s%s\"", - numChars, - (codePtr->source + locPtr->srcOffset), - ellipsis); - } - Tcl_AddObjErrorInfo(interp, buf, -1); - iPtr->flags |= ERR_ALREADY_LOGGED; - } - } goto checkForCatch; case TCL_RETURN: @@ -1151,7 +1080,7 @@ TclExecuteByteCode(interp, codePtr) PUSH_OBJECT(Tcl_GetObjResult(interp)); TRACE_WITH_OBJ(("evalStk \"%.30s\" => ", O2S(objPtr)), Tcl_GetObjResult(interp)); - TclDecrRefCount(objPtr); /* done with popped object */ + TclDecrRefCount(objPtr); ADJUST_PC(1); } else if ((result == TCL_BREAK) || (result == TCL_CONTINUE)) { /* @@ -1172,7 +1101,7 @@ TclExecuteByteCode(interp, codePtr) if (rangePtr == NULL) { TRACE(("evalStk \"%.30s\" => no encl. loop or catch, returning %s\n", O2S(objPtr), StringForResultCode(result))); - Tcl_DecrRefCount(objPtr); /* done with popped obj */ + Tcl_DecrRefCount(objPtr); goto abnormalReturn; /* no catch exists to check */ } switch (rangePtr->type) { @@ -1182,7 +1111,7 @@ TclExecuteByteCode(interp, codePtr) } else if (rangePtr->continueOffset == -1) { TRACE(("evalStk \"%.30s\" => %s, loop w/o continue, checking for catch\n", O2S(objPtr), StringForResultCode(result))); - Tcl_DecrRefCount(objPtr); /* done with popped obj */ + Tcl_DecrRefCount(objPtr); goto checkForCatch; } else { newPcOffset = rangePtr->continueOffset; @@ -1196,18 +1125,18 @@ TclExecuteByteCode(interp, codePtr) TRACE_WITH_OBJ(("evalStk \"%.30s\" => %s ", O2S(objPtr), StringForResultCode(result)), valuePtr); - Tcl_DecrRefCount(objPtr); /* done with popped obj */ + Tcl_DecrRefCount(objPtr); goto processCatch; /* it will use rangePtr */ default: panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type); } - Tcl_DecrRefCount(objPtr); /* done with popped obj */ + Tcl_DecrRefCount(objPtr); pc = (codePtr->codeStart + newPcOffset); continue; /* restart outer instruction loop at pc */ } else { /* eval returned TCL_ERROR, TCL_RETURN, unknown code */ TRACE_WITH_OBJ(("evalStk \"%.30s\" => ERROR: ", O2S(objPtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(objPtr); /* done with popped obj */ + Tcl_DecrRefCount(objPtr); goto checkForCatch; } @@ -1220,21 +1149,21 @@ TclExecuteByteCode(interp, codePtr) if (result != TCL_OK) { TRACE_WITH_OBJ(("exprStk \"%.30s\" => ERROR: ", O2S(objPtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(objPtr); /* done with popped object */ + Tcl_DecrRefCount(objPtr); goto checkForCatch; } stackPtr[++stackTop].o = valuePtr; /* already has right refct */ TRACE_WITH_OBJ(("exprStk \"%.30s\" => ", O2S(objPtr)), valuePtr); - TclDecrRefCount(objPtr); /* done with popped object */ + TclDecrRefCount(objPtr); ADJUST_PC(1); case INST_LOAD_SCALAR4: - opnd = TclGetInt4AtPc(pc+1); + opnd = TclGetInt4AtPtr(pc+1); pcAdjustment = 5; goto doLoadScalar; case INST_LOAD_SCALAR1: - opnd = TclGetUInt1AtPc(pc+1); + opnd = TclGetUInt1AtPtr(pc+1); pcAdjustment = 2; doLoadScalar: @@ -1261,23 +1190,23 @@ TclExecuteByteCode(interp, codePtr) if (valuePtr == NULL) { TRACE_WITH_OBJ(("loadScalarStk \"%.30s\" => ERROR: ", O2S(namePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(namePtr); /* done with popped name. */ + Tcl_DecrRefCount(namePtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(valuePtr); TRACE_WITH_OBJ(("loadScalarStk \"%.30s\" => ", O2S(namePtr)), valuePtr); - TclDecrRefCount(namePtr); /* done with popped name. */ + TclDecrRefCount(namePtr); ADJUST_PC(1); case INST_LOAD_ARRAY4: - opnd = TclGetUInt4AtPc(pc+1); + opnd = TclGetUInt4AtPtr(pc+1); pcAdjustment = 5; goto doLoadArray; case INST_LOAD_ARRAY1: - opnd = TclGetUInt1AtPc(pc+1); + opnd = TclGetUInt1AtPtr(pc+1); pcAdjustment = 2; doLoadArray: @@ -1292,14 +1221,14 @@ TclExecuteByteCode(interp, codePtr) TRACE_WITH_OBJ(("%s %u \"%.30s\" => ERROR: ", opName[opCode], opnd, O2S(elemPtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(elemPtr); /* done with element name. */ + Tcl_DecrRefCount(elemPtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(valuePtr); TRACE_WITH_OBJ(("%s %u \"%.30s\" => ", opName[opCode], opnd, O2S(elemPtr)), valuePtr); - TclDecrRefCount(elemPtr); /* done with element name. */ + TclDecrRefCount(elemPtr); } ADJUST_PC(pcAdjustment); @@ -1316,16 +1245,16 @@ TclExecuteByteCode(interp, codePtr) TRACE_WITH_OBJ(("loadArrayStk \"%.30s(%.30s)\" => ERROR: ", O2S(namePtr), O2S(elemPtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(namePtr); /* done with array name */ - Tcl_DecrRefCount(elemPtr); /* and element name. */ + Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(elemPtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(valuePtr); TRACE_WITH_OBJ(("loadArrayStk \"%.30s(%.30s)\" => ", O2S(namePtr), O2S(elemPtr)), valuePtr); - TclDecrRefCount(namePtr); /* done with array name */ - TclDecrRefCount(elemPtr); /* and element name. */ + TclDecrRefCount(namePtr); + TclDecrRefCount(elemPtr); } ADJUST_PC(1); @@ -1338,23 +1267,23 @@ TclExecuteByteCode(interp, codePtr) if (valuePtr == NULL) { TRACE_WITH_OBJ(("loadStk \"%.30s\" => ERROR: ", O2S(namePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(namePtr); /* done with popped name. */ + Tcl_DecrRefCount(namePtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(valuePtr); TRACE_WITH_OBJ(("loadStk \"%.30s\" => ", O2S(namePtr)), valuePtr); - TclDecrRefCount(namePtr); /* done with popped name. */ + TclDecrRefCount(namePtr); ADJUST_PC(1); case INST_STORE_SCALAR4: - opnd = TclGetUInt4AtPc(pc+1); + opnd = TclGetUInt4AtPtr(pc+1); pcAdjustment = 5; goto doStoreScalar; case INST_STORE_SCALAR1: - opnd = TclGetUInt1AtPc(pc+1); + opnd = TclGetUInt1AtPtr(pc+1); pcAdjustment = 2; doStoreScalar: @@ -1367,14 +1296,14 @@ TclExecuteByteCode(interp, codePtr) TRACE_WITH_OBJ(("%s %u <- \"%.30s\" => ERROR: ", opName[opCode], opnd, O2S(valuePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(valuePtr); /* done with popped value. */ + Tcl_DecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(value2Ptr); TRACE_WITH_OBJ(("%s %u <- \"%.30s\" => ", opName[opCode], opnd, O2S(valuePtr)), value2Ptr); - TclDecrRefCount(valuePtr); /* done with popped value. */ + TclDecrRefCount(valuePtr); ADJUST_PC(pcAdjustment); case INST_STORE_SCALAR_STK: @@ -1389,8 +1318,8 @@ TclExecuteByteCode(interp, codePtr) ("storeScalarStk \"%.30s\" <- \"%.30s\" => ERROR: ", O2S(namePtr), O2S(valuePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(namePtr); /* done with popped name. */ - Tcl_DecrRefCount(valuePtr); /* done with popped value. */ + Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } @@ -1400,17 +1329,17 @@ TclExecuteByteCode(interp, codePtr) O2S(namePtr), O2S(valuePtr)), value2Ptr); - TclDecrRefCount(namePtr); /* done with popped name. */ - TclDecrRefCount(valuePtr); /* done with popped value. */ + TclDecrRefCount(namePtr); + TclDecrRefCount(valuePtr); ADJUST_PC(1); case INST_STORE_ARRAY4: - opnd = TclGetUInt4AtPc(pc+1); + opnd = TclGetUInt4AtPtr(pc+1); pcAdjustment = 5; goto doStoreArray; case INST_STORE_ARRAY1: - opnd = TclGetUInt1AtPc(pc+1); + opnd = TclGetUInt1AtPtr(pc+1); pcAdjustment = 2; doStoreArray: @@ -1428,8 +1357,8 @@ TclExecuteByteCode(interp, codePtr) ("%s %u \"%.30s\" <- \"%.30s\" => ERROR: ", opName[opCode], opnd, O2S(elemPtr), O2S(valuePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(elemPtr); /* done with element name */ - Tcl_DecrRefCount(valuePtr); /* done with popped value */ + Tcl_DecrRefCount(elemPtr); + Tcl_DecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } @@ -1437,8 +1366,8 @@ TclExecuteByteCode(interp, codePtr) TRACE_WITH_OBJ(("%s %u \"%.30s\" <- \"%.30s\" => ", opName[opCode], opnd, O2S(elemPtr), O2S(valuePtr)), value2Ptr); - TclDecrRefCount(elemPtr); /* done with element name */ - TclDecrRefCount(valuePtr); /* done with popped value */ + TclDecrRefCount(elemPtr); + TclDecrRefCount(valuePtr); } ADJUST_PC(pcAdjustment); @@ -1457,9 +1386,9 @@ TclExecuteByteCode(interp, codePtr) TRACE_WITH_OBJ(("storeArrayStk \"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ", O2S(namePtr), O2S(elemPtr), O2S(valuePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(namePtr); /* done with array name, */ - Tcl_DecrRefCount(elemPtr); /* the element name, */ - Tcl_DecrRefCount(valuePtr); /* and the popped value. */ + Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(elemPtr); + Tcl_DecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } @@ -1467,9 +1396,9 @@ TclExecuteByteCode(interp, codePtr) TRACE_WITH_OBJ(("storeArrayStk \"%.30s(%.30s)\" <- \"%.30s\" => ", O2S(namePtr), O2S(elemPtr), O2S(valuePtr)), value2Ptr); - TclDecrRefCount(namePtr); /* done with array name, */ - TclDecrRefCount(elemPtr); /* the element name, */ - TclDecrRefCount(valuePtr); /* and popped value. */ + TclDecrRefCount(namePtr); + TclDecrRefCount(elemPtr); + TclDecrRefCount(valuePtr); } ADJUST_PC(1); @@ -1484,27 +1413,27 @@ TclExecuteByteCode(interp, codePtr) TRACE_WITH_OBJ(("storeStk \"%.30s\" <- \"%.30s\" => ERROR: ", O2S(namePtr), O2S(valuePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(namePtr); /* done with popped name. */ - Tcl_DecrRefCount(valuePtr); /* and popped value. */ + Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(value2Ptr); TRACE_WITH_OBJ(("storeStk \"%.30s\" <- \"%.30s\" => ", O2S(namePtr), O2S(valuePtr)), value2Ptr); - TclDecrRefCount(namePtr); /* done with popped name */ - TclDecrRefCount(valuePtr); /* and popped value. */ + TclDecrRefCount(namePtr); + TclDecrRefCount(valuePtr); ADJUST_PC(1); case INST_INCR_SCALAR1: - opnd = TclGetUInt1AtPc(pc+1); + opnd = TclGetUInt1AtPtr(pc+1); valuePtr = POP_OBJECT(); if (valuePtr->typePtr != &tclIntType) { result = tclIntType.setFromAnyProc(interp, valuePtr); if (result != TCL_OK) { TRACE_WITH_OBJ(("incrScalar1 %u (by %s) => ERROR converting increment amount to int: ", opnd, O2S(valuePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(valuePtr); /* done with incr amount */ + Tcl_DecrRefCount(valuePtr); goto checkForCatch; } } @@ -1515,14 +1444,14 @@ TclExecuteByteCode(interp, codePtr) if (value2Ptr == NULL) { TRACE_WITH_OBJ(("incrScalar1 %u (by %ld) => ERROR: ", opnd, i), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(valuePtr); /* done with incr amount */ + Tcl_DecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(value2Ptr); TRACE_WITH_OBJ(("incrScalar1 %u (by %ld) => ", opnd, i), value2Ptr); - TclDecrRefCount(valuePtr); /* done with incr amount */ + TclDecrRefCount(valuePtr); ADJUST_PC(2); case INST_INCR_SCALAR_STK: @@ -1535,8 +1464,8 @@ TclExecuteByteCode(interp, codePtr) TRACE_WITH_OBJ(("%s \"%.30s\" (by %s) => ERROR converting increment amount to int: ", opName[opCode], O2S(namePtr), O2S(valuePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(namePtr); /* done with var name */ - Tcl_DecrRefCount(valuePtr); /* done with incr amount */ + Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(valuePtr); goto checkForCatch; } } @@ -1549,23 +1478,23 @@ TclExecuteByteCode(interp, codePtr) TRACE_WITH_OBJ(("%s \"%.30s\" (by %ld) => ERROR: ", opName[opCode], O2S(namePtr), i), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(namePtr); /* done with var name */ - Tcl_DecrRefCount(valuePtr); /* done with incr amount */ + Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(value2Ptr); TRACE_WITH_OBJ(("%s \"%.30s\" (by %ld) => ", opName[opCode], O2S(namePtr), i), value2Ptr); - Tcl_DecrRefCount(namePtr); /* done with var name */ - Tcl_DecrRefCount(valuePtr); /* done with incr amount */ + Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(valuePtr); ADJUST_PC(1); case INST_INCR_ARRAY1: { Tcl_Obj *elemPtr; - opnd = TclGetUInt1AtPc(pc+1); + opnd = TclGetUInt1AtPtr(pc+1); valuePtr = POP_OBJECT(); elemPtr = POP_OBJECT(); if (valuePtr->typePtr != &tclIntType) { @@ -1574,8 +1503,8 @@ TclExecuteByteCode(interp, codePtr) TRACE_WITH_OBJ(("incrArray1 %u \"%.30s\" (by %s) => ERROR converting increment amount to int: ", opnd, O2S(elemPtr), O2S(valuePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(elemPtr); /* done w elem name */ - Tcl_DecrRefCount(valuePtr); /* done w incr amount */ + Tcl_DecrRefCount(elemPtr); + Tcl_DecrRefCount(valuePtr); goto checkForCatch; } } @@ -1588,16 +1517,16 @@ TclExecuteByteCode(interp, codePtr) TRACE_WITH_OBJ(("incrArray1 %u \"%.30s\" (by %ld) => ERROR: ", opnd, O2S(elemPtr), i), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(elemPtr); /* done w element name */ - Tcl_DecrRefCount(valuePtr); /* done w incr amount */ + Tcl_DecrRefCount(elemPtr); + Tcl_DecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(value2Ptr); TRACE_WITH_OBJ(("incrArray1 %u \"%.30s\" (by %ld) => ", opnd, O2S(elemPtr), i), value2Ptr); - Tcl_DecrRefCount(elemPtr); /* done w element name */ - Tcl_DecrRefCount(valuePtr); /* done w incr amount */ + Tcl_DecrRefCount(elemPtr); + Tcl_DecrRefCount(valuePtr); } ADJUST_PC(2); @@ -1614,9 +1543,9 @@ TclExecuteByteCode(interp, codePtr) TRACE_WITH_OBJ(("incrArrayStk \"%.30s(%.30s)\" (by %s) => ERROR converting increment amount to int: ", O2S(namePtr), O2S(elemPtr), O2S(valuePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(namePtr); /* done w array name */ - Tcl_DecrRefCount(elemPtr); /* done w elem name */ - Tcl_DecrRefCount(valuePtr); /* done w incr amount */ + Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(elemPtr); + Tcl_DecrRefCount(valuePtr); goto checkForCatch; } } @@ -1629,24 +1558,24 @@ TclExecuteByteCode(interp, codePtr) TRACE_WITH_OBJ(("incrArrayStk \"%.30s(%.30s)\" (by %ld) => ERROR: ", O2S(namePtr), O2S(elemPtr), i), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(namePtr); /* done w array name */ - Tcl_DecrRefCount(elemPtr); /* done w elem name */ - Tcl_DecrRefCount(valuePtr); /* done w incr amount */ + Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(elemPtr); + Tcl_DecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(value2Ptr); TRACE_WITH_OBJ(("incrArrayStk \"%.30s(%.30s)\" (by %ld) => ", O2S(namePtr), O2S(elemPtr), i), value2Ptr); - Tcl_DecrRefCount(namePtr); /* done w array name */ - Tcl_DecrRefCount(elemPtr); /* done w elem name */ - Tcl_DecrRefCount(valuePtr); /* done w incr amount */ + Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(elemPtr); + Tcl_DecrRefCount(valuePtr); } ADJUST_PC(1); case INST_INCR_SCALAR1_IMM: - opnd = TclGetUInt1AtPc(pc+1); - i = TclGetInt1AtPc(pc+2); + opnd = TclGetUInt1AtPtr(pc+1); + i = TclGetInt1AtPtr(pc+2); DECACHE_STACK_INFO(); value2Ptr = TclIncrIndexedScalar(interp, opnd, i); CACHE_STACK_INFO(); @@ -1664,7 +1593,7 @@ TclExecuteByteCode(interp, codePtr) case INST_INCR_SCALAR_STK_IMM: case INST_INCR_STK_IMM: namePtr = POP_OBJECT(); - i = TclGetInt1AtPc(pc+1); + i = TclGetInt1AtPtr(pc+1); DECACHE_STACK_INFO(); value2Ptr = TclIncrVar2(interp, namePtr, (Tcl_Obj *) NULL, i, /*part1NotParsed*/ (opCode == INST_INCR_STK_IMM)); @@ -1674,21 +1603,21 @@ TclExecuteByteCode(interp, codePtr) opName[opCode], O2S(namePtr), i), Tcl_GetObjResult(interp)); result = TCL_ERROR; - Tcl_DecrRefCount(namePtr); /* done with var name */ + Tcl_DecrRefCount(namePtr); goto checkForCatch; } PUSH_OBJECT(value2Ptr); TRACE_WITH_OBJ(("%s \"%.30s\" %ld => ", opName[opCode], O2S(namePtr), i), value2Ptr); - TclDecrRefCount(namePtr); /* done with var name */ + TclDecrRefCount(namePtr); ADJUST_PC(2); case INST_INCR_ARRAY1_IMM: { Tcl_Obj *elemPtr; - opnd = TclGetUInt1AtPc(pc+1); - i = TclGetInt1AtPc(pc+2); + opnd = TclGetUInt1AtPtr(pc+1); + i = TclGetInt1AtPtr(pc+2); elemPtr = POP_OBJECT(); DECACHE_STACK_INFO(); value2Ptr = TclIncrElementOfIndexedArray(interp, opnd, @@ -1698,14 +1627,14 @@ TclExecuteByteCode(interp, codePtr) TRACE_WITH_OBJ(("incrArray1Imm %u \"%.30s\" (by %ld) => ERROR: ", opnd, O2S(elemPtr), i), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(elemPtr); /* done with element name */ + Tcl_DecrRefCount(elemPtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(value2Ptr); TRACE_WITH_OBJ(("incrArray1Imm %u \"%.30s\" (by %ld) => ", opnd, O2S(elemPtr), i), value2Ptr); - Tcl_DecrRefCount(elemPtr); /* done with element name */ + Tcl_DecrRefCount(elemPtr); } ADJUST_PC(3); @@ -1713,7 +1642,7 @@ TclExecuteByteCode(interp, codePtr) { Tcl_Obj *elemPtr; - i = TclGetInt1AtPc(pc+1); + i = TclGetInt1AtPtr(pc+1); elemPtr = POP_OBJECT(); namePtr = POP_OBJECT(); DECACHE_STACK_INFO(); @@ -1724,38 +1653,38 @@ TclExecuteByteCode(interp, codePtr) TRACE_WITH_OBJ(("incrArrayStkImm \"%.30s(%.30s)\" (by %ld) => ERROR: ", O2S(namePtr), O2S(elemPtr), i), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(namePtr); /* done with array name */ - Tcl_DecrRefCount(elemPtr); /* done with element name */ + Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(elemPtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(value2Ptr); TRACE_WITH_OBJ(("incrArrayStkImm \"%.30s(%.30s)\" (by %ld) => ", O2S(namePtr), O2S(elemPtr), i), value2Ptr); - Tcl_DecrRefCount(namePtr); /* done with array name */ - Tcl_DecrRefCount(elemPtr); /* done with element name */ + Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(elemPtr); } ADJUST_PC(2); case INST_JUMP1: - opnd = TclGetInt1AtPc(pc+1); + opnd = TclGetInt1AtPtr(pc+1); TRACE(("jump1 %d => new pc %u\n", opnd, (unsigned int)(pc + opnd - codePtr->codeStart))); ADJUST_PC(opnd); case INST_JUMP4: - opnd = TclGetInt4AtPc(pc+1); + opnd = TclGetInt4AtPtr(pc+1); TRACE(("jump4 %d => new pc %u\n", opnd, (unsigned int)(pc + opnd - codePtr->codeStart))); ADJUST_PC(opnd); case INST_JUMP_TRUE4: - opnd = TclGetInt4AtPc(pc+1); + opnd = TclGetInt4AtPtr(pc+1); pcAdjustment = 5; goto doJumpTrue; case INST_JUMP_TRUE1: - opnd = TclGetInt1AtPc(pc+1); + opnd = TclGetInt1AtPtr(pc+1); pcAdjustment = 2; doJumpTrue: @@ -1772,7 +1701,7 @@ TclExecuteByteCode(interp, codePtr) if (result != TCL_OK) { TRACE_WITH_OBJ(("%s %d => ERROR: ", opName[opCode], opnd), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(valuePtr); /* done w popped obj */ + Tcl_DecrRefCount(valuePtr); goto checkForCatch; } } @@ -1780,23 +1709,23 @@ TclExecuteByteCode(interp, codePtr) TRACE(("%s %d => %.20s true, new pc %u\n", opName[opCode], opnd, O2S(valuePtr), (unsigned int)(pc+opnd - codePtr->codeStart))); - TclDecrRefCount(valuePtr); /* done with popped obj */ + TclDecrRefCount(valuePtr); ADJUST_PC(opnd); } else { TRACE(("%s %d => %.20s false\n", opName[opCode], opnd, O2S(valuePtr))); - TclDecrRefCount(valuePtr); /* done with popped obj */ + TclDecrRefCount(valuePtr); ADJUST_PC(pcAdjustment); } } case INST_JUMP_FALSE4: - opnd = TclGetInt4AtPc(pc+1); + opnd = TclGetInt4AtPtr(pc+1); pcAdjustment = 5; goto doJumpFalse; case INST_JUMP_FALSE1: - opnd = TclGetInt1AtPc(pc+1); + opnd = TclGetInt1AtPtr(pc+1); pcAdjustment = 2; doJumpFalse: @@ -1813,20 +1742,20 @@ TclExecuteByteCode(interp, codePtr) if (result != TCL_OK) { TRACE_WITH_OBJ(("%s %d => ERROR: ", opName[opCode], opnd), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(valuePtr); /* done w popped obj */ + Tcl_DecrRefCount(valuePtr); goto checkForCatch; } } if (b) { TRACE(("%s %d => %.20s true\n", opName[opCode], opnd, O2S(valuePtr))); - TclDecrRefCount(valuePtr); /* done with popped obj */ + TclDecrRefCount(valuePtr); ADJUST_PC(pcAdjustment); } else { TRACE(("%s %d => %.20s false, new pc %u\n", opName[opCode], opnd, O2S(valuePtr), (unsigned int)(pc + opnd - codePtr->codeStart))); - TclDecrRefCount(valuePtr); /* done with popped obj */ + TclDecrRefCount(valuePtr); ADJUST_PC(opnd); } } @@ -1858,19 +1787,19 @@ TclExecuteByteCode(interp, codePtr) if (TclLooksLikeInt(s)) { result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); - i = (valuePtr->internalRep.longValue != 0); + i = (i != 0); } else { result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d1); - i = (valuePtr->internalRep.doubleValue != 0.0); + i = (d1 != 0.0); } if (result != TCL_OK) { TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s \n", opName[opCode], O2S(valuePtr), (t1Ptr? t1Ptr->name : "null"))); IllegalExprOperandType(interp, opCode, valuePtr); - Tcl_DecrRefCount(valuePtr); /* done with object */ - Tcl_DecrRefCount(value2Ptr); /* done with object */ + Tcl_DecrRefCount(valuePtr); + Tcl_DecrRefCount(value2Ptr); goto checkForCatch; } } @@ -1884,19 +1813,19 @@ TclExecuteByteCode(interp, codePtr) if (TclLooksLikeInt(s)) { result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, value2Ptr, &i2); - i2 = (value2Ptr->internalRep.longValue != 0); + i2 = (i2 != 0); } else { result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, value2Ptr, &d1); - i2 = (value2Ptr->internalRep.doubleValue != 0.0); + i2 = (d1 != 0.0); } if (result != TCL_OK) { TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s \n", opName[opCode], O2S(value2Ptr), (t2Ptr? t2Ptr->name : "null"))); IllegalExprOperandType(interp, opCode, value2Ptr); - Tcl_DecrRefCount(valuePtr); /* done with object */ - Tcl_DecrRefCount(value2Ptr); /* done with object */ + Tcl_DecrRefCount(valuePtr); + Tcl_DecrRefCount(value2Ptr); goto checkForCatch; } } @@ -1914,7 +1843,7 @@ TclExecuteByteCode(interp, codePtr) PUSH_OBJECT(Tcl_NewLongObj(iResult)); TRACE(("%s %.20s %.20s => %ld\n", opName[opCode], O2S(valuePtr), O2S(value2Ptr), iResult)); - TclDecrRefCount(valuePtr); /* done with object */ + TclDecrRefCount(valuePtr); } else { /* reuse the valuePtr object */ TRACE(("%s %.20s %.20s => %ld\n", opName[opCode], /* NB: stack top is off by 1 */ @@ -1922,7 +1851,7 @@ TclExecuteByteCode(interp, codePtr) Tcl_SetLongObj(valuePtr, iResult); ++stackTop; /* valuePtr now on stk top has right r.c. */ } - TclDecrRefCount(value2Ptr); /* done with object */ + TclDecrRefCount(value2Ptr); } ADJUST_PC(1); @@ -1945,7 +1874,7 @@ TclExecuteByteCode(interp, codePtr) double d1 = 0.0; /* Init. avoids compiler warning. */ double d2 = 0.0; /* Init. avoids compiler warning. */ long iResult = 0; /* Init. avoids compiler warning. */ - + value2Ptr = POP_OBJECT(); valuePtr = POP_OBJECT(); t1Ptr = valuePtr->typePtr; @@ -2076,7 +2005,7 @@ TclExecuteByteCode(interp, codePtr) PUSH_OBJECT(Tcl_NewLongObj(iResult)); TRACE(("%s %.20s %.20s => %ld\n", opName[opCode], O2S(valuePtr), O2S(value2Ptr), iResult)); - TclDecrRefCount(valuePtr); /* done with object */ + TclDecrRefCount(valuePtr); } else { /* reuse the valuePtr object */ TRACE(("%s %.20s %.20s => %ld\n", opName[opCode], /* NB: stack top is off by 1 */ @@ -2084,7 +2013,7 @@ TclExecuteByteCode(interp, codePtr) Tcl_SetLongObj(valuePtr, iResult); ++stackTop; /* valuePtr now on stk top has right r.c. */ } - TclDecrRefCount(value2Ptr); /* done with object */ + TclDecrRefCount(value2Ptr); } ADJUST_PC(1); @@ -2115,8 +2044,8 @@ TclExecuteByteCode(interp, codePtr) (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); IllegalExprOperandType(interp, opCode, valuePtr); - Tcl_DecrRefCount(valuePtr); /* done with object */ - Tcl_DecrRefCount(value2Ptr); /* done with object */ + Tcl_DecrRefCount(valuePtr); + Tcl_DecrRefCount(value2Ptr); goto checkForCatch; } } @@ -2131,8 +2060,8 @@ TclExecuteByteCode(interp, codePtr) (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); IllegalExprOperandType(interp, opCode, value2Ptr); - Tcl_DecrRefCount(valuePtr); /* done with object */ - Tcl_DecrRefCount(value2Ptr); /* done with object */ + Tcl_DecrRefCount(valuePtr); + Tcl_DecrRefCount(value2Ptr); goto checkForCatch; } } @@ -2147,8 +2076,8 @@ TclExecuteByteCode(interp, codePtr) */ if (i2 == 0) { TRACE(("mod %ld %ld => DIVIDE BY ZERO\n", i, i2)); - Tcl_DecrRefCount(valuePtr); /* done with object */ - Tcl_DecrRefCount(value2Ptr); /* done with object */ + Tcl_DecrRefCount(valuePtr); + Tcl_DecrRefCount(value2Ptr); goto divideByZero; } negative = 0; @@ -2200,14 +2129,14 @@ TclExecuteByteCode(interp, codePtr) PUSH_OBJECT(Tcl_NewLongObj(iResult)); TRACE(("%s %ld %ld => %ld\n", opName[opCode], i, i2, iResult)); - TclDecrRefCount(valuePtr); /* done with object */ + TclDecrRefCount(valuePtr); } else { /* reuse the valuePtr object */ TRACE(("%s %ld %ld => %ld\n", opName[opCode], i, i2, iResult)); /* NB: stack top is off by 1 */ Tcl_SetLongObj(valuePtr, iResult); ++stackTop; /* valuePtr now on stk top has right r.c. */ } - TclDecrRefCount(value2Ptr); /* done with object */ + TclDecrRefCount(value2Ptr); } ADJUST_PC(1); @@ -2252,8 +2181,8 @@ TclExecuteByteCode(interp, codePtr) (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); IllegalExprOperandType(interp, opCode, valuePtr); - Tcl_DecrRefCount(valuePtr); /* done with object */ - Tcl_DecrRefCount(value2Ptr); /* done with object */ + Tcl_DecrRefCount(valuePtr); + Tcl_DecrRefCount(value2Ptr); goto checkForCatch; } t1Ptr = valuePtr->typePtr; @@ -2278,8 +2207,8 @@ TclExecuteByteCode(interp, codePtr) (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); IllegalExprOperandType(interp, opCode, value2Ptr); - Tcl_DecrRefCount(valuePtr); /* done with object */ - Tcl_DecrRefCount(value2Ptr); /* done with object */ + Tcl_DecrRefCount(valuePtr); + Tcl_DecrRefCount(value2Ptr); goto checkForCatch; } t2Ptr = value2Ptr->typePtr; @@ -2309,8 +2238,8 @@ TclExecuteByteCode(interp, codePtr) if (d2 == 0.0) { TRACE(("div %.6g %.6g => DIVIDE BY ZERO\n", d1, d2)); - Tcl_DecrRefCount(valuePtr); /* done with obj */ - Tcl_DecrRefCount(value2Ptr); /* done with obj */ + Tcl_DecrRefCount(valuePtr); + Tcl_DecrRefCount(value2Ptr); goto divideByZero; } dResult = d1 / d2; @@ -2326,8 +2255,8 @@ TclExecuteByteCode(interp, codePtr) opName[opCode], O2S(valuePtr), O2S(value2Ptr))); TclExprFloatError(interp, dResult); result = TCL_ERROR; - Tcl_DecrRefCount(valuePtr); /* done with object */ - Tcl_DecrRefCount(value2Ptr); /* done with object */ + Tcl_DecrRefCount(valuePtr); + Tcl_DecrRefCount(value2Ptr); goto checkForCatch; } } else { @@ -2354,8 +2283,8 @@ TclExecuteByteCode(interp, codePtr) if (i2 == 0) { TRACE(("div %ld %ld => DIVIDE BY ZERO\n", i, i2)); - Tcl_DecrRefCount(valuePtr); /* done with obj */ - Tcl_DecrRefCount(value2Ptr); /* done with obj */ + Tcl_DecrRefCount(valuePtr); + Tcl_DecrRefCount(value2Ptr); goto divideByZero; } if (i2 < 0) { @@ -2386,7 +2315,7 @@ TclExecuteByteCode(interp, codePtr) TRACE(("%s %ld %ld => %ld\n", opName[opCode], i, i2, iResult)); } - TclDecrRefCount(valuePtr); /* done with object */ + TclDecrRefCount(valuePtr); } else { /* reuse the valuePtr object */ if (doDouble) { /* NB: stack top is off by 1 */ TRACE(("%s %.6g %.6g => %.6g\n", opName[opCode], @@ -2399,7 +2328,7 @@ TclExecuteByteCode(interp, codePtr) } ++stackTop; /* valuePtr now on stk top has right r.c. */ } - TclDecrRefCount(value2Ptr); /* done with object */ + TclDecrRefCount(value2Ptr); } ADJUST_PC(1); @@ -2464,7 +2393,7 @@ TclExecuteByteCode(interp, codePtr) opName[opCode], s, (tPtr? tPtr->name : "null"))); IllegalExprOperandType(interp, opCode, valuePtr); - Tcl_DecrRefCount(valuePtr); /* done with object */ + Tcl_DecrRefCount(valuePtr); goto checkForCatch; } tPtr = valuePtr->typePtr; @@ -2495,7 +2424,7 @@ TclExecuteByteCode(interp, codePtr) objPtr); /* NB: stack top is off by 1 */ } PUSH_OBJECT(objPtr); - TclDecrRefCount(valuePtr); /* done with popped obj */ + TclDecrRefCount(valuePtr); } else { /* * valuePtr is unshared. Modify it directly. @@ -2545,7 +2474,7 @@ TclExecuteByteCode(interp, codePtr) TRACE(("bitnot \"%.20s\" => ILLEGAL TYPE %s\n", O2S(valuePtr), (tPtr? tPtr->name : "null"))); IllegalExprOperandType(interp, opCode, valuePtr); - Tcl_DecrRefCount(valuePtr); /* done with object */ + Tcl_DecrRefCount(valuePtr); goto checkForCatch; } } @@ -2554,7 +2483,7 @@ TclExecuteByteCode(interp, codePtr) if (Tcl_IsShared(valuePtr)) { PUSH_OBJECT(Tcl_NewLongObj(~i)); TRACE(("bitnot 0x%lx => (%lu)\n", i, ~i)); - TclDecrRefCount(valuePtr); /* done with popped obj */ + TclDecrRefCount(valuePtr); } else { /* * valuePtr is unshared. Modify it directly. @@ -2567,7 +2496,7 @@ TclExecuteByteCode(interp, codePtr) ADJUST_PC(1); case INST_CALL_BUILTIN_FUNC1: - opnd = TclGetUInt1AtPc(pc+1); + opnd = TclGetUInt1AtPtr(pc+1); { /* * Call one of the built-in Tcl math functions. @@ -2595,7 +2524,7 @@ TclExecuteByteCode(interp, codePtr) ADJUST_PC(2); case INST_CALL_FUNC1: - opnd = TclGetUInt1AtPc(pc+1); + opnd = TclGetUInt1AtPtr(pc+1); { /* * Call a non-builtin Tcl math function previously @@ -2677,7 +2606,7 @@ TclExecuteByteCode(interp, codePtr) objPtr = Tcl_NewDoubleObj(d); } Tcl_IncrRefCount(objPtr); - TclDecrRefCount(valuePtr); /* done with object */ + TclDecrRefCount(valuePtr); valuePtr = objPtr; tPtr = valuePtr->typePtr; } else { @@ -2695,6 +2624,8 @@ TclExecuteByteCode(interp, codePtr) goto checkForCatch; } } + shared = shared; /* lint, shared not used. */ + converted = converted; /* lint, converted not used. */ TRACE(("tryCvtToNumeric \"%.20s\" => numeric, %s, %s\n", O2S(valuePtr), (converted? "converted" : "not converted"), @@ -2754,7 +2685,7 @@ TclExecuteByteCode(interp, codePtr) if (rangePtr == NULL) { TRACE(("continue => no encl. loop or catch, returning TCL_CONTINUE\n")); result = TCL_CONTINUE; - goto abnormalReturn; /* no catch exists to check */ + goto abnormalReturn; } switch (rangePtr->type) { case LOOP_EXCEPTION_RANGE: @@ -2778,7 +2709,7 @@ TclExecuteByteCode(interp, codePtr) continue; /* restart outer instruction loop at pc */ case INST_FOREACH_START4: - opnd = TclGetUInt4AtPc(pc+1); + opnd = TclGetUInt4AtPtr(pc+1); { /* * Initialize the temporary local var that holds the count @@ -2795,22 +2726,13 @@ TclExecuteByteCode(interp, codePtr) iterVarPtr = &(compiledLocals[iterTmpIndex]); oldValuePtr = iterVarPtr->value.objPtr; -#ifdef TCL_COMPILE_DEBUG - if (TclIsVarLink(iterVarPtr)) { - panic("TclExecuteByteCode execution failure: foreach loop iter temp %d is link\n", iterTmpIndex); - } - if ((oldValuePtr != NULL) && Tcl_IsShared(oldValuePtr)) { - panic("TclExecuteByteCode execution failure: foreach loop iter temp %d has shared object\n", iterTmpIndex); - } -#endif /* TCL_COMPILE_DEBUG */ - if (oldValuePtr == NULL) { iterVarPtr->value.objPtr = Tcl_NewLongObj(-1); Tcl_IncrRefCount(iterVarPtr->value.objPtr); if (oldValuePtr != NULL) { - Tcl_DecrRefCount(oldValuePtr); /* free old value */ + Tcl_DecrRefCount(oldValuePtr); } - } else { /* update object in place */ + } else { Tcl_SetLongObj(oldValuePtr, -1); } TclSetVarScalar(iterVarPtr); @@ -2821,7 +2743,7 @@ TclExecuteByteCode(interp, codePtr) ADJUST_PC(5); case INST_FOREACH_STEP4: - opnd = TclGetUInt4AtPc(pc+1); + opnd = TclGetUInt4AtPtr(pc+1); { /* * "Step" a foreach loop (i.e., begin its next iteration) by @@ -2848,18 +2770,6 @@ TclExecuteByteCode(interp, codePtr) iterVarPtr = &(compiledLocals[iterTmpIndex]); oldValuePtr = iterVarPtr->value.objPtr; -#ifdef TCL_COMPILE_DEBUG - if (TclIsVarLink(iterVarPtr) || TclIsVarUndefined(iterVarPtr) - || !TclIsVarScalar(iterVarPtr)) { - panic("TclExecuteByteCode execution failure: foreach loop iter temp %d is link, undefined, or array\n", iterTmpIndex); - } - if ((oldValuePtr == NULL) - || (oldValuePtr->typePtr != &tclIntType) - || (oldValuePtr->bytes != NULL) - || Tcl_IsShared(oldValuePtr)) { - panic("TclExecuteByteCode execution failure: foreach loop iter count object is bad\n"); - } -#endif /* TCL_COMPILE_DEBUG */ iterNum = (oldValuePtr->internalRep.longValue + 1); Tcl_SetLongObj(oldValuePtr, iterNum); @@ -2875,17 +2785,6 @@ TclExecuteByteCode(interp, codePtr) listVarPtr = &(compiledLocals[listTmpIndex]); listPtr = listVarPtr->value.objPtr; -#ifdef TCL_COMPILE_DEBUG - if (TclIsVarLink(listVarPtr) || TclIsVarUndefined(listVarPtr) - || !TclIsVarScalar(listVarPtr)) { - panic("TclExecuteByteCode execution failure: foreach loop list temp %d is link, undefined, or array\n", listTmpIndex); - } - if (listPtr == NULL) { - panic("TclExecuteByteCode execution failure: NULL foreach list temp %d: \"%s\"\n", - listTmpIndex, - Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length)); - } -#endif /* TCL_COMPILE_DEBUG */ result = Tcl_ListObjLength(interp, listPtr, &listLen); if (result != TCL_OK) { TRACE_WITH_OBJ(("foreach_step4 %u => ERROR converting list %ld, \"%s\": ", @@ -2923,7 +2822,7 @@ TclExecuteByteCode(interp, codePtr) int setEmptyStr = 0; if (valIndex >= listLen) { setEmptyStr = 1; - elemPtr = Tcl_NewObj(); /* set to "" */ + elemPtr = Tcl_NewObj(); } else { elemPtr = listRepPtr->elements[valIndex]; } @@ -2970,7 +2869,7 @@ TclExecuteByteCode(interp, codePtr) */ catchStackPtr[++catchTop] = stackTop; TRACE(("beginCatch4 %u => catchTop=%d, stackTop=%d\n", - TclGetUInt4AtPc(pc+1), catchTop, stackTop)); + TclGetUInt4AtPtr(pc+1), catchTop, stackTop)); ADJUST_PC(5); case INST_END_CATCH: @@ -2985,7 +2884,7 @@ TclExecuteByteCode(interp, codePtr) ADJUST_PC(1); case INST_PUSH_RETURN_CODE: - PUSH_OBJECT(Tcl_NewLongObj(result)); /* i.e., the return code */ + PUSH_OBJECT(Tcl_NewLongObj(result)); TRACE(("pushReturnCode => %u\n", result)); ADJUST_PC(1); @@ -3007,68 +2906,71 @@ TclExecuteByteCode(interp, codePtr) result = TCL_ERROR; /* - * Execution has generated an "exceptional return" (or "exception") - * such as TCL_ERROR. Look for the closest enclosing catch exception - * range, if any. If no enclosing catch range is found, stop - * execution and return the "exceptional return" code. + * Execution has generated an "exception" such as TCL_ERROR. If the + * exception is an error, record information about what was being + * executed when the error occurred. Find the closest enclosing + * catch range, if any. If no enclosing catch range is found, stop + * execution and return the "exception" code. */ checkForCatch: - rangePtr = TclGetExceptionRangeForPc(pc, /*catchOnly*/ 1, codePtr); - if (rangePtr == NULL) { - TRACE((" ... no enclosing catch, returning %s\n", - StringForResultCode(result))); - goto abnormalReturn; /* no catch exists to check */ - } - - /* - * A catch exception range (rangePtr) has been to handle an - * "exception". It was found either by checkForCatch just above or - * by an instruction during break, continue, or error processing. - * Jump to its catchOffset after unwinding the operand stack to - * the depth it had when starting to execute the range's catch - * command. Also, if the exception is an error, record information - * about what was being executed when the error occurred. - */ - - processCatch: if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { + int numChars; + char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars); char buf[200]; - int cmdIndex = TclGetSrcInfoForPc(pc, codePtr); - - /* - * Compute the line number where the error occurred. - */ + register char *p; + char *ellipsis = ""; - iPtr->errorLine = 1; /* no correct line # information yet */ - /* * Print the command in the error message (up to a certain - * number of characters, or up to the first new-line). + * number of characters, or up to the first newline). */ - - if (cmdIndex != -1) { - CmdLocation *locPtr = &(codePtr->cmdMapPtr[cmdIndex]); - char *ellipsis = ""; - int numChars = locPtr->numSrcChars; + + iPtr->errorLine = 1; + if (cmd != NULL) { + for (p = codePtr->source; p != cmd; p++) { + if (*p == '\n') { + iPtr->errorLine++; + } + } + for ( ; (isspace(UCHAR(*p)) || (*p == ';')); p++) { + if (*p == '\n') { + iPtr->errorLine++; + } + } + if (numChars > 150) { numChars = 150; ellipsis = "..."; } if (!(iPtr->flags & ERR_IN_PROGRESS)) { sprintf(buf, "\n while executing\n\"%.*s%s\"", - numChars, (codePtr->source + locPtr->srcOffset), - ellipsis); + numChars, cmd, ellipsis); } else { sprintf(buf, "\n invoked from within\n\"%.*s%s\"", - numChars, (codePtr->source + locPtr->srcOffset), - ellipsis); + numChars, cmd, ellipsis); } Tcl_AddObjErrorInfo(interp, buf, -1); iPtr->flags |= ERR_ALREADY_LOGGED; } } - + rangePtr = TclGetExceptionRangeForPc(pc, /*catchOnly*/ 1, codePtr); + if (rangePtr == NULL) { + TRACE((" ... no enclosing catch, returning %s\n", + StringForResultCode(result))); + goto abnormalReturn; + } + + /* + * A catch exception range (rangePtr) was found to handle an + * "exception". It was found either by checkForCatch just above or + * by an instruction during break, continue, or error processing. + * Jump to its catchOffset after unwinding the operand stack to + * the depth it had when starting to execute the range's catch + * command. + */ + + processCatch: while (stackTop > catchStackPtr[catchTop]) { valuePtr = POP_OBJECT(); TclDecrRefCount(valuePtr); @@ -3107,6 +3009,140 @@ TclExecuteByteCode(interp, codePtr) /* *---------------------------------------------------------------------- * + * PrintByteCodeInfo -- + * + * This procedure prints a summary about a bytecode object to stdout. + * It is called by TclExecuteByteCode when starting to execute the + * bytecode object if tclTraceExec has the value 2 or more. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +PrintByteCodeInfo(codePtr) + register ByteCode *codePtr; /* The bytecode whose summary is printed + * to stdout. */ +{ + Proc *procPtr = codePtr->procPtr; + int numCmds = codePtr->numCommands; + int numObjs = codePtr->numObjects; + int objBytes, i; + + objBytes = (numObjs * sizeof(Tcl_Obj)); + for (i = 0; i < numObjs; i++) { + Tcl_Obj *litObjPtr = codePtr->objArrayPtr[i]; + if (litObjPtr->bytes != NULL) { + objBytes += litObjPtr->length; + } + } + + fprintf(stdout, "\nExecuting ByteCode 0x%x, ref ct %u, epoch %u, interp 0x%x(epoch %u)\n", + (unsigned int) codePtr, codePtr->refCount, + codePtr->compileEpoch, (unsigned int) codePtr->iPtr, + codePtr->iPtr->compileEpoch); + + fprintf(stdout, " Source: "); + TclPrintSource(stdout, codePtr->source, 70); + + fprintf(stdout, "\n Cmds %d, chars %d, inst %u, objs %u, aux %d, stk depth %u, code/src %.2fn", + numCmds, codePtr->numSrcChars, codePtr->numCodeBytes, numObjs, + codePtr->numAuxDataItems, codePtr->maxStackDepth, + (codePtr->numSrcChars? + ((float)codePtr->totalSize)/((float)codePtr->numSrcChars) : 0.0)); + + fprintf(stdout, " Code %d = %d(header)+%d(inst)+%d(objs)+%d(exc)+%d(aux)+%d(cmd map)\n", + codePtr->totalSize, sizeof(ByteCode), codePtr->numCodeBytes, + objBytes, (codePtr->numExcRanges * sizeof(ExceptionRange)), + (codePtr->numAuxDataItems * sizeof(AuxData)), + codePtr->numCmdLocBytes); + + if (procPtr != NULL) { + fprintf(stdout, + " Proc 0x%x, ref ct %d, args %d, compiled locals %d\n", + (unsigned int) procPtr, procPtr->refCount, + procPtr->numArgs, procPtr->numCompiledLocals); + } +} + +/* + *---------------------------------------------------------------------- + * + * ValidatePcAndStackTop -- + * + * This procedure is called by TclExecuteByteCode 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(codePtr, pc, stackTop, stackLowerBound, stackUpperBound) + register ByteCode *codePtr; /* The bytecode whose summary is printed + * to stdout. */ + 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 stackLowerBound; /* Smallest legal value for stackTop. */ + int stackUpperBound; /* Greatest legal value for stackTop. */ +{ + unsigned int relativePc = (unsigned int) (pc - codePtr->codeStart); + unsigned int codeStart = (unsigned int) codePtr->codeStart; + unsigned int codeEnd = (unsigned int) + (codePtr->codeStart + codePtr->numCodeBytes); + unsigned char opCode = *pc; + + if (((unsigned int) pc < codeStart) || ((unsigned int) pc > codeEnd)) { + fprintf(stderr, "\nBad instruction pc 0x%x in TclExecuteByteCode\n", + (unsigned int) pc); + panic("TclExecuteByteCode execution failure: bad pc"); + } + if ((unsigned int) opCode > LAST_INST_OPCODE) { + fprintf(stderr, "\nBad opcode %d at pc %u in TclExecuteByteCode\n", + (unsigned int) opCode, relativePc); + panic("TclExecuteByteCode execution failure: bad opcode"); + } + if ((stackTop < stackLowerBound) || (stackTop > stackUpperBound)) { + int numChars; + char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars); + char *ellipsis = ""; + + fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode", + stackTop, relativePc); + if (cmd != NULL) { + if (numChars > 100) { + numChars = 100; + ellipsis = "..."; + } + fprintf(stderr, "\n executing %.*s%s\n", numChars, cmd, + ellipsis); + } else { + fprintf(stderr, "\n"); + } + panic("TclExecuteByteCode execution failure: bad stack top"); + } +} +#endif /* TCL_COMPILE_DEBUG */ + +/* + *---------------------------------------------------------------------- + * * IllegalExprOperandType -- * * Used by TclExecuteByteCode to add an error message to errorInfo @@ -3201,7 +3237,7 @@ CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv) */ p = (char *) ckalloc((unsigned) (numChars + 1)); - strncpy(p, command, (size_t) numChars); + memcpy((VOID *) p, (VOID *) command, (size_t) numChars); p[numChars] = '\0'; /* @@ -3218,21 +3254,20 @@ CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv) /* *---------------------------------------------------------------------- * - * TclGetSrcInfoForPc -- + * GetSrcInfoForPc -- * - * Procedure that given a program counter value, returns an index - * of the closest command's element in the bytecode code unit's - * CmdLocation array. This element provides information about that - * command's source: a pointer to its first byte and the number - * of its characters. + * Given a program counter value, finds the closest command in the + * bytecode code unit's CmdLocation array and returns information about + * that command's source: a pointer to its first byte and the number of + * characters. * * Results: - * If a command in the bytecode code unit is found that encloses - * the program counter value, the index of the command's element - * in the CmdLocation array is returned. If multiple commands - * resulted in code at pc, the index for the command with code that - * starts closest to pc is returned. If no matching command is - * found, -1 is returned. + * If a command is found that encloses the program counter value, a + * pointer to the command's source is returned and the length of the + * source is stored at *lengthPtr. If multiple commands resulted in + * code at pc, information about the closest enclosing command is + * returned. If no matching command is found, NULL is returned and + * *lengthPtr is unchanged. * * Side effects: * None. @@ -3240,38 +3275,102 @@ CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv) *---------------------------------------------------------------------- */ -int -TclGetSrcInfoForPc(pc, codePtr) +static char * +GetSrcInfoForPc(pc, codePtr, lengthPtr) unsigned char *pc; /* The program counter value for which to * return the closest command's source info. * This points to a bytecode instruction * in codePtr's code. */ ByteCode* codePtr; /* The bytecode sequence in which to look * up the command source for the pc. */ + int *lengthPtr; /* If non-NULL, the location where the + * length of the command's source should be + * stored. If NULL, no length is stored. */ { - int codeOffset = (pc - codePtr->codeStart); - int numCommands = codePtr->numCommands; - CmdLocation *cmdMapPtr = codePtr->cmdMapPtr; - register CmdLocation *locPtr; - int bestCmd = -1; /* Index of current candidate for closest - * command. */ - int bestDist = INT_MAX; /* Distance of pc to bestCmd's start pc. */ - int startOffset, endOffset, dist; - register int i; + register int pcOffset = (pc - codePtr->codeStart); + int numCmds = codePtr->numCommands; + unsigned char *codeDeltaNext, *codeLengthNext; + unsigned char *srcDeltaNext, *srcLengthNext; + int codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i; + int bestDist = INT_MAX; /* Distance of pc to best cmd's start pc. */ + int bestSrcOffset = -1; /* Initialized to avoid compiler warning. */ + int bestSrcLength = -1; /* Initialized to avoid compiler warning. */ + + if ((pcOffset < 0) || (pcOffset >= codePtr->numCodeBytes)) { + return NULL; + } + + /* + * Decode the code and source offset and length for each command. The + * closest enclosing command is the last one whose code started before + * pcOffset. + */ + + codeDeltaNext = codePtr->codeDeltaStart; + codeLengthNext = codePtr->codeLengthStart; + srcDeltaNext = codePtr->srcDeltaStart; + srcLengthNext = codePtr->srcLengthStart; + codeOffset = srcOffset = 0; + for (i = 0; i < numCmds; i++) { + if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) { + codeDeltaNext++; + delta = TclGetInt4AtPtr(codeDeltaNext); + codeDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(codeDeltaNext); + codeDeltaNext++; + } + codeOffset += delta; - for (i = 0; i < numCommands; i++) { - locPtr = &(cmdMapPtr[i]); - startOffset = locPtr->codeOffset; - endOffset = (startOffset + locPtr->numCodeBytes - 1); - if ((startOffset <= codeOffset) && (codeOffset <= endOffset)) { - dist = (codeOffset - startOffset); + if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) { + codeLengthNext++; + codeLen = TclGetInt4AtPtr(codeLengthNext); + codeLengthNext += 4; + } else { + codeLen = TclGetInt1AtPtr(codeLengthNext); + codeLengthNext++; + } + codeEnd = (codeOffset + codeLen - 1); + + if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) { + srcDeltaNext++; + delta = TclGetInt4AtPtr(srcDeltaNext); + srcDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(srcDeltaNext); + srcDeltaNext++; + } + srcOffset += delta; + + if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) { + srcLengthNext++; + srcLen = TclGetInt4AtPtr(srcLengthNext); + srcLengthNext += 4; + } else { + srcLen = TclGetInt1AtPtr(srcLengthNext); + srcLengthNext++; + } + + if (codeOffset > pcOffset) { /* best cmd already found */ + break; + } else if (pcOffset <= codeEnd) { /* this cmd's code encloses pc */ + int dist = (pcOffset - codeOffset); if (dist <= bestDist) { - bestCmd = i; bestDist = dist; + bestSrcOffset = srcOffset; + bestSrcLength = srcLen; } } } - return bestCmd; + + if (bestDist == INT_MAX) { + return NULL; + } + + if (lengthPtr != NULL) { + *lengthPtr = bestSrcLength; + } + return (codePtr->source + bestSrcOffset); } /* @@ -3430,7 +3529,7 @@ ExprUnaryFunc(interp, eePtr, clientData) */ done: - Tcl_DecrRefCount(valuePtr); /* done with popped obj */ + Tcl_DecrRefCount(valuePtr); DECACHE_STACK_INFO(); return result; } @@ -3530,8 +3629,8 @@ ExprBinaryFunc(interp, eePtr, clientData) */ done: - Tcl_DecrRefCount(valuePtr); /* done with popped obj */ - Tcl_DecrRefCount(value2Ptr); /* done with popped obj */ + Tcl_DecrRefCount(valuePtr); + Tcl_DecrRefCount(value2Ptr); DECACHE_STACK_INFO(); return result; } @@ -3625,7 +3724,7 @@ ExprAbsFunc(interp, eePtr, clientData) */ done: - Tcl_DecrRefCount(valuePtr); /* done with popped obj */ + Tcl_DecrRefCount(valuePtr); DECACHE_STACK_INFO(); return result; } @@ -3689,7 +3788,7 @@ ExprDoubleFunc(interp, eePtr, clientData) */ done: - Tcl_DecrRefCount(valuePtr); /* done with popped obj */ + Tcl_DecrRefCount(valuePtr); DECACHE_STACK_INFO(); return result; } @@ -3782,7 +3881,7 @@ ExprIntFunc(interp, eePtr, clientData) */ done: - Tcl_DecrRefCount(valuePtr); /* done with popped obj */ + Tcl_DecrRefCount(valuePtr); DECACHE_STACK_INFO(); return result; } @@ -3956,7 +4055,7 @@ ExprRoundFunc(interp, eePtr, clientData) */ done: - Tcl_DecrRefCount(valuePtr); /* done with popped obj */ + Tcl_DecrRefCount(valuePtr); DECACHE_STACK_INFO(); return result; } @@ -3975,7 +4074,7 @@ ExprSrandFunc(interp, eePtr, clientData) Tcl_Obj *valuePtr; Tcl_ObjType *tPtr; long i = 0; /* Initialized to avoid compiler warning. */ - int result = TCL_OK; + int result; /* * Set stackPtr and stackTop from eePtr. @@ -4000,7 +4099,7 @@ ExprSrandFunc(interp, eePtr, clientData) Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ", ((tPtr == &tclDoubleType)? "floating-point value" : "non-numeric string"), " as argument to srand", (char *) NULL); - Tcl_DecrRefCount(valuePtr); /* done with popped obj */ + Tcl_DecrRefCount(valuePtr); DECACHE_STACK_INFO(); return result; } @@ -4264,6 +4363,39 @@ TclExprFloatError(interp, value) /* *---------------------------------------------------------------------- * + * 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(value) + 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 @@ -4287,23 +4419,108 @@ EvalStatsCmd(unused, interp, argc, argv) { register double total = 0.0; register int i; + int maxSizeDecade = 0; + double totalHeaderBytes = (tclNumCompilations * sizeof(ByteCode)); for (i = 0; i < 256; i++) { - if (instructionCount[i]) { + if (instructionCount[i] != 0) { total += instructionCount[i]; } - } + } + + for (i = 31; i >= 0; i--) { + if ((tclSourceCount[i] > 0) && (tclByteCodeCount[i] > 0)) { + maxSizeDecade = i; + break; + } + } - fprintf(stdout, "\nNumber of ByteCode compilations: %ld\n", + fprintf(stdout, "\nNumber of compilations %ld\n", tclNumCompilations); - fprintf(stdout, "Number of ByteCode executions: %ld\n", + fprintf(stdout, "Number of executions %ld\n", numExecutions); - fprintf(stdout, "Number of Tcl objects in use: %ld, allocated %ld, freed %ld\n", - (tclObjsAlloced - tclObjsFreed), tclObjsAlloced, tclObjsFreed); - fprintf(stdout, "Number of instructions executed: %.0f\n\n", total); + fprintf(stdout, "Average executions/compilation %.0f\n", + ((float) numExecutions/tclNumCompilations)); + + fprintf(stdout, "\nInstructions executed %.0f\n", + total); + fprintf(stdout, "Average instructions/compile %.0f\n", + total/tclNumCompilations); + fprintf(stdout, "Average instructions/execution %.0f\n", + total/numExecutions); + + fprintf(stdout, "\nTotal source bytes %.6g\n", + tclTotalSourceBytes); + fprintf(stdout, "Total code bytes %.6g\n", + tclTotalCodeBytes); + fprintf(stdout, "Average code/compilation %.0f\n", + tclTotalCodeBytes/tclNumCompilations); + fprintf(stdout, "Average code/source %.2f\n", + tclTotalCodeBytes/tclTotalSourceBytes); + fprintf(stdout, "Current source bytes %.6g\n", + tclCurrentSourceBytes); + fprintf(stdout, "Current code bytes %.6g\n", + tclCurrentCodeBytes); + fprintf(stdout, "Current code/source %.2f\n", + tclCurrentCodeBytes/tclCurrentSourceBytes); + + fprintf(stdout, "\nTotal objects allocated %ld\n", + tclObjsAlloced); + fprintf(stdout, "Total objects freed %ld\n", + tclObjsFreed); + fprintf(stdout, "Current objects: %ld\n", + (tclObjsAlloced - tclObjsFreed)); + + fprintf(stdout, "\nBreakdown of code byte requirements:\n"); + fprintf(stdout, " Total bytes Pct of Avg per\n"); + fprintf(stdout, " all code compile\n"); + fprintf(stdout, "Total code %12.6g 100%% %8.2f\n", + tclTotalCodeBytes, tclTotalCodeBytes/tclNumCompilations); + fprintf(stdout, "Header %12.6g %8.2f%% %8.2f\n", + totalHeaderBytes, + ((totalHeaderBytes * 100.0) / tclTotalCodeBytes), + totalHeaderBytes/tclNumCompilations); + fprintf(stdout, "Instructions %12.6g %8.2f%% %8.2f\n", + tclTotalInstBytes, + ((tclTotalInstBytes * 100.0) / tclTotalCodeBytes), + tclTotalInstBytes/tclNumCompilations); + fprintf(stdout, "Objects %12.6g %8.2f%% %8.2f\n", + tclTotalObjBytes, + ((tclTotalObjBytes * 100.0) / tclTotalCodeBytes), + tclTotalObjBytes/tclNumCompilations); + fprintf(stdout, "Exception table %12.6g %8.2f%% %8.2f\n", + tclTotalExceptBytes, + ((tclTotalExceptBytes * 100.0) / tclTotalCodeBytes), + tclTotalExceptBytes/tclNumCompilations); + fprintf(stdout, "Auxiliary data %12.6g %8.2f%% %8.2f\n", + tclTotalAuxBytes, + ((tclTotalAuxBytes * 100.0) / tclTotalCodeBytes), + tclTotalAuxBytes/tclNumCompilations); + fprintf(stdout, "Command map %12.6g %8.2f%% %8.2f\n", + tclTotalCmdMapBytes, + ((tclTotalCmdMapBytes * 100.0) / tclTotalCodeBytes), + tclTotalCmdMapBytes/tclNumCompilations); + + fprintf(stdout, "\nSource and ByteCode size distributions:\n"); + fprintf(stdout, " binary decade source code\n"); + for (i = 0; i <= maxSizeDecade; i++) { + int decadeLow, decadeHigh; + + if (i == 0) { + decadeLow = 0; + } else { + decadeLow = 1 << i; + } + decadeHigh = (1 << (i+1)) - 1; + fprintf(stdout, " %6d -%6d %6d %6d\n", + decadeLow, decadeHigh, + tclSourceCount[i], tclByteCodeCount[i]); + } + + fprintf(stdout, "\nInstruction counts:\n"); for (i = 0; i < 256; i++) { if (instructionCount[i]) { - fprintf(stdout, "%30s %8d %6.2f%%\n", + fprintf(stdout, "%20s %8d %6.2f%%\n", opName[i], instructionCount[i], (instructionCount[i] * 100.0)/total); } @@ -4494,7 +4711,8 @@ DupCmdNameInternalRep(srcPtr, copyPtr) register ResolvedCmdName *resPtr = (ResolvedCmdName *) srcPtr->internalRep.otherValuePtr; - copyPtr->internalRep.otherValuePtr = (VOID *) resPtr; + copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; + copyPtr->internalRep.twoPtrValue.ptr2 = NULL; if (resPtr != NULL) { resPtr->refCount++; } @@ -4590,6 +4808,7 @@ SetCmdNameFromAny(interp, objPtr) } objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = &tclCmdNameType; return TCL_OK; } diff --git a/contrib/tcl/generic/tclFileName.c b/contrib/tcl/generic/tclFileName.c index 7464304..69d825c 100644 --- a/contrib/tcl/generic/tclFileName.c +++ b/contrib/tcl/generic/tclFileName.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclFileName.c 1.28 97/05/14 13:23:48 + * SCCS: @(#) tclFileName.c 1.31 97/08/05 15:23:04 */ #include "tclInt.h" @@ -1088,7 +1088,9 @@ DoTildeSubst(interp, user, resultPtr) } Tcl_JoinPath(1, &dir, resultPtr); } else { - if (TclGetUserHome(user, resultPtr) == NULL) { + + /* lint, TclGetuserHome() always NULL under windows. */ + if (TclGetUserHome(user, resultPtr) == NULL) { if (interp) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "user \"", user, "\" doesn't exist", diff --git a/contrib/tcl/generic/tclHistory.c b/contrib/tcl/generic/tclHistory.c index f6572c7..0419c3d 100644 --- a/contrib/tcl/generic/tclHistory.c +++ b/contrib/tcl/generic/tclHistory.c @@ -1,139 +1,23 @@ /* * tclHistory.c -- * - * This module implements history as an optional addition to Tcl. - * It can be called to record commands ("events") before they are - * executed, and it provides a command that may be used to perform - * history substitutions. + * This module and the Tcl library file history.tcl together implement + * Tcl command history. Tcl_RecordAndEval(Obj) can be called to record + * commands ("events") before they are executed. Commands defined in + * history.tcl may be used to perform history substitutions. * * Copyright (c) 1990-1993 The Regents of the University of California. - * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * Copyright (c) 1994-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclHistory.c 1.43 97/05/14 13:23:18 + * SCCS: @(#) tclHistory.c 1.47 97/08/04 16:08:17 */ #include "tclInt.h" #include "tclPort.h" -/* - * This history stuff is mostly straightforward, except for one thing - * that makes everything very complicated. Suppose that the following - * commands get executed: - * echo foo - * history redo - * It's important that the history event recorded for the second command - * be "echo foo", not "history redo". Otherwise, if another "history redo" - * command is typed, it will result in infinite recursions on the - * "history redo" command. Thus, the actual recorded history must be - * echo foo - * echo foo - * To do this, the history command revises recorded history as part of - * its execution. In the example above, when "history redo" starts - * execution, the current event is "history redo", but the history - * command arranges for the current event to be changed to "echo foo". - * - * There are three additional complications. The first is that history - * substitution may only be part of a command, as in the following - * command sequence: - * echo foo bar - * echo [history word 3] - * In this case, the second event should be recorded as "echo bar". Only - * part of the recorded event is to be modified. Fortunately, Tcl_Eval - * helps with this by recording (in the evalFirst and evalLast fields of - * the intepreter) the location of the command being executed, so the - * history module can replace exactly the range of bytes corresponding - * to the history substitution command. - * - * The second complication is that there are two ways to revise history: - * replace a command, and replace the result of a command. Consider the - * two examples below: - * format {result is %d} $num | format {result is %d} $num - * print [history redo] | print [history word 3] - * Recorded history for these two cases should be as follows: - * format {result is %d} $num | format {result is %d} $num - * print [format {result is %d} $num] | print $num - * In the left case, the history command was replaced with another command - * to be executed (the brackets were retained), but in the case on the - * right the result of executing the history command was replaced (i.e. - * brackets were replaced too). - * - * The third complication is that there could potentially be many - * history substitutions within a single command, as in: - * echo [history word 3] [history word 2] - * There could even be nested history substitutions, as in: - * history subs abc [history word 2] - * If history revisions were made immediately during each "history" command - * invocations, it would be very difficult to produce the correct cumulative - * effect from several substitutions in the same command. To get around - * this problem, the actual history revision isn't made during the execution - * of the "history" command. Information about the changes is just recorded, - * in xxx records, and the actual changes are made during the next call to - * Tcl_RecordHistory (when we know that execution of the previous command - * has finished). - */ - -/* - * Default space allocation for command strings: - */ - -#define INITIAL_CMD_SIZE 40 - -/* - * Forward declarations for procedures defined later in this file: - */ - -static void DoRevs _ANSI_ARGS_((Interp *iPtr)); -static HistoryEvent * GetEvent _ANSI_ARGS_((Interp *iPtr, char *string)); -static char * GetWords _ANSI_ARGS_((Interp *iPtr, char *command, - char *words)); -static void InitHistory _ANSI_ARGS_((Interp *iPtr)); -static void InsertRev _ANSI_ARGS_((Interp *iPtr, - HistoryRev *revPtr)); -static void MakeSpace _ANSI_ARGS_((HistoryEvent *hPtr, int size)); -static void RevCommand _ANSI_ARGS_((Interp *iPtr, char *string)); -static void RevResult _ANSI_ARGS_((Interp *iPtr, char *string)); -static int SubsAndEval _ANSI_ARGS_((Interp *iPtr, char *cmd, - char *old, char *new)); - -/* - *---------------------------------------------------------------------- - * - * InitHistory -- - * - * Initialize history-related state in an interpreter. - * - * Results: - * None. - * - * Side effects: - * History info is initialized in iPtr. - * - *---------------------------------------------------------------------- - */ - -static void -InitHistory(iPtr) - register Interp *iPtr; /* Interpreter to initialize. */ -{ - int i; - - if (iPtr->numEvents != 0) { - return; - } - iPtr->numEvents = 20; - iPtr->events = (HistoryEvent *) - ckalloc((unsigned) (iPtr->numEvents * sizeof(HistoryEvent))); - for (i = 0; i < iPtr->numEvents; i++) { - iPtr->events[i].command = (char *) ckalloc(INITIAL_CMD_SIZE); - *iPtr->events[i].command = 0; - iPtr->events[i].bytesAvl = INITIAL_CMD_SIZE; - } - iPtr->curEvent = 0; - iPtr->curEventNum = 0; -} /* *---------------------------------------------------------------------- @@ -149,11 +33,7 @@ InitHistory(iPtr) * executing cmd. * * Side effects: - * The command is recorded and executed. In addition, pending history - * revisions are carried out, and information is set up to enable - * Tcl_Eval to identify history command ranges. This procedure also - * initializes history information for the interpreter, if it hasn't - * already been initialized. + * The command is recorded and executed. * *---------------------------------------------------------------------- */ @@ -168,931 +48,108 @@ Tcl_RecordAndEval(interp, cmd, flags) * TCL_EVAL_GLOBAL means use Tcl_GlobalEval * instead of Tcl_Eval. */ { - register Interp *iPtr = (Interp *) interp; - register HistoryEvent *eventPtr; - int length, result; - - if (iPtr->numEvents == 0) { - InitHistory(iPtr); - } - DoRevs(iPtr); - - /* - * Don't record empty commands. - */ - - while (isspace(UCHAR(*cmd))) { - cmd++; - } - if (*cmd == '\0') { - Tcl_ResetResult(interp); - return TCL_OK; - } - - iPtr->curEventNum++; - iPtr->curEvent++; - if (iPtr->curEvent >= iPtr->numEvents) { - iPtr->curEvent = 0; - } - eventPtr = &iPtr->events[iPtr->curEvent]; - - /* - * Chop off trailing newlines before recording the command. - */ - - length = strlen(cmd); - while (cmd[length-1] == '\n') { - length--; - } - MakeSpace(eventPtr, length + 1); - strncpy(eventPtr->command, cmd, (size_t) length); - eventPtr->command[length] = 0; - - /* - * Execute the command. Note: history revision isn't possible after - * a nested call to this procedure, because the event at the top of - * the history list no longer corresponds to what's going on when - * a nested call here returns. Thus, must leave history revision - * disabled when we return. - */ - - result = TCL_OK; - if (!(flags & TCL_NO_EVAL)) { - iPtr->historyFirst = cmd; - iPtr->revDisables = 0; - iPtr->evalFlags = (flags & ~TCL_EVAL_GLOBAL) | TCL_RECORD_BOUNDS; - if (flags & TCL_EVAL_GLOBAL) { - result = Tcl_GlobalEval(interp, cmd); - } else { - result = Tcl_Eval(interp, cmd); - } - } - iPtr->revDisables = 1; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_HistoryCmd -- - * - * This procedure is invoked to process the "history" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -int -Tcl_HistoryCmd(dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - register Interp *iPtr = (Interp *) interp; - register HistoryEvent *eventPtr; - size_t length; - int c; - - if (iPtr->numEvents == 0) { - InitHistory(iPtr); - } - - /* - * If no arguments, treat the same as "history info". - */ - - if (argc == 1) { - goto infoCmd; - } - - c = argv[1][0]; - length = strlen(argv[1]); + register Tcl_Obj *cmdPtr; + int length = strlen(cmd); + int result; - if ((c == 'a') && (strncmp(argv[1], "add", length)) == 0) { - if ((argc != 3) && (argc != 4)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " add event ?exec?\"", (char *) NULL); - return TCL_ERROR; - } - if (argc == 4) { - if (strncmp(argv[3], "exec", strlen(argv[3])) != 0) { - Tcl_AppendResult(interp, "bad argument \"", argv[3], - "\": should be \"exec\"", (char *) NULL); - return TCL_ERROR; - } - return Tcl_RecordAndEval(interp, argv[2], 0); - } - return Tcl_RecordAndEval(interp, argv[2], TCL_NO_EVAL); - } else if ((c == 'c') && (strncmp(argv[1], "change", length)) == 0) { - if ((argc != 3) && (argc != 4)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " change newValue ?event?\"", (char *) NULL); - return TCL_ERROR; - } - if (argc == 3) { - eventPtr = &iPtr->events[iPtr->curEvent]; - iPtr->revDisables += 1; - while (iPtr->revPtr != NULL) { - HistoryRev *nextPtr; - - ckfree(iPtr->revPtr->newBytes); - nextPtr = iPtr->revPtr->nextPtr; - ckfree((char *) iPtr->revPtr); - iPtr->revPtr = nextPtr; - } - } else { - eventPtr = GetEvent(iPtr, argv[3]); - if (eventPtr == NULL) { - return TCL_ERROR; - } - } - MakeSpace(eventPtr, (int) strlen(argv[2]) + 1); - strcpy(eventPtr->command, argv[2]); - return TCL_OK; - } else if ((c == 'e') && (strncmp(argv[1], "event", length)) == 0) { - if (argc > 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " event ?event?\"", (char *) NULL); - return TCL_ERROR; - } - eventPtr = GetEvent(iPtr, argc==2 ? "-1" : argv[2]); - if (eventPtr == NULL) { - return TCL_ERROR; - } - RevResult(iPtr, eventPtr->command); - Tcl_SetResult(interp, eventPtr->command, TCL_VOLATILE); - return TCL_OK; - } else if ((c == 'i') && (strncmp(argv[1], "info", length)) == 0) { - int count, indx, i; - char *newline; - - if ((argc != 2) && (argc != 3)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " info ?count?\"", (char *) NULL); - return TCL_ERROR; - } - infoCmd: - if (argc == 3) { - if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) { - return TCL_ERROR; - } - if (count > iPtr->numEvents) { - count = iPtr->numEvents; - } - } else { - count = iPtr->numEvents; - } - newline = ""; - for (i = 0, indx = iPtr->curEvent + 1 + iPtr->numEvents - count; - i < count; i++, indx++) { - char *cur, *next, savedChar; - char serial[20]; - - if (indx >= iPtr->numEvents) { - indx -= iPtr->numEvents; - } - cur = iPtr->events[indx].command; - if (*cur == '\0') { - continue; /* No command recorded here. */ - } - sprintf(serial, "%6d ", iPtr->curEventNum + 1 - (count - i)); - Tcl_AppendResult(interp, newline, serial, (char *) NULL); - newline = "\n"; - - /* - * Tricky formatting here: for multi-line commands, indent - * the continuation lines. - */ + if (length > 0) { + /* + * Call Tcl_RecordAndEvalObj to do the actual work. + */ - while (1) { - next = strchr(cur, '\n'); - if (next == NULL) { - break; - } - next++; - savedChar = *next; - *next = 0; - Tcl_AppendResult(interp, cur, "\t", (char *) NULL); - *next = savedChar; - cur = next; - } - Tcl_AppendResult(interp, cur, (char *) NULL); - } - return TCL_OK; - } else if ((c == 'k') && (strncmp(argv[1], "keep", length)) == 0) { - int count, i, src; - HistoryEvent *events; + TclNewObj(cmdPtr); + TclInitStringRep(cmdPtr, cmd, length); + Tcl_IncrRefCount(cmdPtr); - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " keep number\"", (char *) NULL); - return TCL_ERROR; - } - if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) { - return TCL_ERROR; - } - if ((count <= 0) || (count > 1000)) { - Tcl_AppendResult(interp, "illegal keep count \"", argv[2], - "\"", (char *) NULL); - return TCL_ERROR; - } + result = Tcl_RecordAndEvalObj(interp, cmdPtr, flags); /* - * Create a new history array and copy as much existing history - * as possible from the old array. + * Move the interpreter's object result to the string result, + * then reset the object result. + * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS. */ - events = (HistoryEvent *) - ckalloc((unsigned) (count * sizeof(HistoryEvent))); - if (count < iPtr->numEvents) { - src = iPtr->curEvent + 1 - count; - if (src < 0) { - src += iPtr->numEvents; - } - } else { - src = iPtr->curEvent + 1; - } - for (i = 0; i < count; i++, src++) { - if (src >= iPtr->numEvents) { - src = 0; - } - if (i < iPtr->numEvents) { - events[i] = iPtr->events[src]; - iPtr->events[src].command = NULL; - } else { - events[i].command = (char *) ckalloc(INITIAL_CMD_SIZE); - events[i].command[0] = 0; - events[i].bytesAvl = INITIAL_CMD_SIZE; - } - } + Tcl_SetResult(interp, + TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), + TCL_VOLATILE); /* - * Throw away everything left in the old history array, and - * substitute the new one for the old one. + * Discard the Tcl object created to hold the command. */ - - for (i = 0; i < iPtr->numEvents; i++) { - if (iPtr->events[i].command != NULL) { - ckfree(iPtr->events[i].command); - } - } - ckfree((char *) iPtr->events); - iPtr->events = events; - if (count < iPtr->numEvents) { - iPtr->curEvent = count-1; - } else { - iPtr->curEvent = iPtr->numEvents-1; - } - iPtr->numEvents = count; - return TCL_OK; - } else if ((c == 'n') && (strncmp(argv[1], "nextid", length)) == 0) { - char buf[40]; - if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " nextid\"", (char *) NULL); - return TCL_ERROR; - } - TclFormatInt(buf, iPtr->curEventNum+1); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - return TCL_OK; - } else if ((c == 'r') && (strncmp(argv[1], "redo", length)) == 0) { - if (argc > 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " redo ?event?\"", (char *) NULL); - return TCL_ERROR; - } - eventPtr = GetEvent(iPtr, argc==2 ? "-1" : argv[2]); - if (eventPtr == NULL) { - return TCL_ERROR; - } - RevCommand(iPtr, eventPtr->command); - return Tcl_Eval(interp, eventPtr->command); - } else if ((c == 's') && (strncmp(argv[1], "substitute", length)) == 0) { - if ((argc > 5) || (argc < 4)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " substitute old new ?event?\"", (char *) NULL); - return TCL_ERROR; - } - eventPtr = GetEvent(iPtr, argc==4 ? "-1" : argv[4]); - if (eventPtr == NULL) { - return TCL_ERROR; - } - return SubsAndEval(iPtr, eventPtr->command, argv[2], argv[3]); - } else if ((c == 'w') && (strncmp(argv[1], "words", length)) == 0) { - char *words; - - if ((argc != 3) && (argc != 4)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " words num-num/pat ?event?\"", (char *) NULL); - return TCL_ERROR; - } - eventPtr = GetEvent(iPtr, argc==3 ? "-1" : argv[3]); - if (eventPtr == NULL) { - return TCL_ERROR; - } - words = GetWords(iPtr, eventPtr->command, argv[2]); - if (words == NULL) { - return TCL_ERROR; - } - RevResult(iPtr, words); - Tcl_SetResult(interp, words, TCL_DYNAMIC); - return TCL_OK; - } - - Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be add, change, event, info, keep, nextid, ", - "redo, substitute, or words", (char *) NULL); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * MakeSpace -- - * - * Given a history event, make sure it has enough space for - * a string of a given length (enlarge the string area if - * necessary). - * - * Results: - * None. - * - * Side effects: - * More memory may get allocated. - * - *---------------------------------------------------------------------- - */ - -static void -MakeSpace(hPtr, size) - HistoryEvent *hPtr; - int size; /* # of bytes needed in hPtr. */ -{ - if (hPtr->bytesAvl < size) { - ckfree(hPtr->command); - hPtr->command = (char *) ckalloc((unsigned) size); - hPtr->bytesAvl = size; - } -} - -/* - *---------------------------------------------------------------------- - * - * InsertRev -- - * - * Add a new revision to the list of those pending for iPtr. - * Do it in a way that keeps the revision list sorted in - * increasing order of firstIndex. Also, eliminate revisions - * that are subsets of other revisions. - * - * Results: - * None. - * - * Side effects: - * RevPtr is added to iPtr's revision list. - * - *---------------------------------------------------------------------- - */ - -static void -InsertRev(iPtr, revPtr) - Interp *iPtr; /* Interpreter to use. */ - register HistoryRev *revPtr; /* Revision to add to iPtr's list. */ -{ - register HistoryRev *curPtr; - register HistoryRev *prevPtr; - - for (curPtr = iPtr->revPtr, prevPtr = NULL; curPtr != NULL; - prevPtr = curPtr, curPtr = curPtr->nextPtr) { + Tcl_DecrRefCount(cmdPtr); + } else { /* - * If this revision includes the new one (or vice versa) then - * just eliminate the one that is a subset of the other. + * An empty string. Just reset the interpreter's result. */ - if ((revPtr->firstIndex <= curPtr->firstIndex) - && (revPtr->lastIndex >= curPtr->firstIndex)) { - curPtr->firstIndex = revPtr->firstIndex; - curPtr->lastIndex = revPtr->lastIndex; - curPtr->newSize = revPtr->newSize; - ckfree(curPtr->newBytes); - curPtr->newBytes = revPtr->newBytes; - ckfree((char *) revPtr); - return; - } - if ((revPtr->firstIndex >= curPtr->firstIndex) - && (revPtr->lastIndex <= curPtr->lastIndex)) { - ckfree(revPtr->newBytes); - ckfree((char *) revPtr); - return; - } - - if (revPtr->firstIndex < curPtr->firstIndex) { - break; - } - } - - /* - * Insert revPtr just after prevPtr. - */ - - if (prevPtr == NULL) { - revPtr->nextPtr = iPtr->revPtr; - iPtr->revPtr = revPtr; - } else { - revPtr->nextPtr = prevPtr->nextPtr; - prevPtr->nextPtr = revPtr; - } -} - -/* - *---------------------------------------------------------------------- - * - * RevCommand -- - * - * This procedure is invoked by the "history" command to record - * a command revision. See the comments at the beginning of the - * file for more information about revisions. - * - * Results: - * None. - * - * Side effects: - * Revision information is recorded. - * - *---------------------------------------------------------------------- - */ - -static void -RevCommand(iPtr, string) - register Interp *iPtr; /* Interpreter in which to perform the - * substitution. */ - char *string; /* String to substitute. */ -{ - register HistoryRev *revPtr; - - if ((iPtr->evalFirst == NULL) || (iPtr->revDisables > 0)) { - return; - } - revPtr = (HistoryRev *) ckalloc(sizeof(HistoryRev)); - revPtr->firstIndex = iPtr->evalFirst - iPtr->historyFirst; - revPtr->lastIndex = iPtr->evalLast - iPtr->historyFirst; - revPtr->newSize = strlen(string); - revPtr->newBytes = (char *) ckalloc((unsigned) (revPtr->newSize+1)); - strcpy(revPtr->newBytes, string); - InsertRev(iPtr, revPtr); -} - -/* - *---------------------------------------------------------------------- - * - * RevResult -- - * - * This procedure is invoked by the "history" command to record - * a result revision. See the comments at the beginning of the - * file for more information about revisions. - * - * Results: - * None. - * - * Side effects: - * Revision information is recorded. - * - *---------------------------------------------------------------------- - */ - -static void -RevResult(iPtr, string) - register Interp *iPtr; /* Interpreter in which to perform the - * substitution. */ - char *string; /* String to substitute. */ -{ - register HistoryRev *revPtr; - char *evalFirst, *evalLast; - char *argv[2]; - - if ((iPtr->evalFirst == NULL) || (iPtr->revDisables > 0)) { - return; - } - - /* - * Expand the replacement range to include the brackets that surround - * the command. If there aren't any brackets (i.e. this command was - * invoked at top-level) then don't do any revision. Also, if there - * are several commands in brackets, of which this is just one, - * then don't do any revision. - */ - - evalFirst = iPtr->evalFirst; - evalLast = iPtr->evalLast + 1; - while (1) { - if (evalFirst == iPtr->historyFirst) { - return; - } - evalFirst--; - if (*evalFirst == '[') { - break; - } - if (!isspace(UCHAR(*evalFirst))) { - return; - } - } - if (*evalLast != ']') { - return; - } - - revPtr = (HistoryRev *) ckalloc(sizeof(HistoryRev)); - revPtr->firstIndex = evalFirst - iPtr->historyFirst; - revPtr->lastIndex = evalLast - iPtr->historyFirst; - argv[0] = string; - revPtr->newBytes = Tcl_Merge(1, argv); - revPtr->newSize = strlen(revPtr->newBytes); - InsertRev(iPtr, revPtr); -} - -/* - *---------------------------------------------------------------------- - * - * DoRevs -- - * - * This procedure is called to apply the history revisions that - * have been recorded in iPtr. - * - * Results: - * None. - * - * Side effects: - * The most recent entry in the history for iPtr may be modified. - * - *---------------------------------------------------------------------- - */ - -static void -DoRevs(iPtr) - register Interp *iPtr; /* Interpreter whose history is to - * be modified. */ -{ - register HistoryRev *revPtr; - register HistoryEvent *eventPtr; - char *newCommand, *p; - unsigned int size; - int bytesSeen, count; - - if (iPtr->revPtr == NULL) { - return; - } - - /* - * The revision is done in two passes. The first pass computes the - * amount of space needed for the revised event, and the second pass - * pieces together the new event and frees up the revisions. - */ - - eventPtr = &iPtr->events[iPtr->curEvent]; - size = strlen(eventPtr->command) + 1; - for (revPtr = iPtr->revPtr; revPtr != NULL; revPtr = revPtr->nextPtr) { - size -= revPtr->lastIndex + 1 - revPtr->firstIndex; - size += revPtr->newSize; - } - - newCommand = (char *) ckalloc(size); - p = newCommand; - bytesSeen = 0; - for (revPtr = iPtr->revPtr; revPtr != NULL; ) { - HistoryRev *nextPtr = revPtr->nextPtr; - - count = revPtr->firstIndex - bytesSeen; - if (count > 0) { - strncpy(p, eventPtr->command + bytesSeen, (size_t) count); - p += count; - } - strncpy(p, revPtr->newBytes, (size_t) revPtr->newSize); - p += revPtr->newSize; - bytesSeen = revPtr->lastIndex+1; - ckfree(revPtr->newBytes); - ckfree((char *) revPtr); - revPtr = nextPtr; - } - strcpy(p, eventPtr->command + bytesSeen); - - /* - * Replace the command in the event. - */ - - ckfree(eventPtr->command); - eventPtr->command = newCommand; - eventPtr->bytesAvl = size; - iPtr->revPtr = NULL; -} - -/* - *---------------------------------------------------------------------- - * - * GetEvent -- - * - * Given a textual description of an event (see the manual page - * for legal values) find the corresponding event and return its - * command string. - * - * Results: - * The return value is a pointer to the event named by "string". - * If no such event exists, then NULL is returned and an error - * message is left in iPtr. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static HistoryEvent * -GetEvent(iPtr, string) - register Interp *iPtr; /* Interpreter in which to look. */ - char *string; /* Description of event. */ -{ - int eventNum, index; - register HistoryEvent *eventPtr; - int length; - - /* - * First check for a numeric specification of an event. - */ - - if (isdigit(UCHAR(*string)) || (*string == '-')) { - if (Tcl_GetInt((Tcl_Interp *) iPtr, string, &eventNum) != TCL_OK) { - return NULL; - } - if (eventNum < 0) { - eventNum += iPtr->curEventNum; - } - if (eventNum > iPtr->curEventNum) { - Tcl_AppendResult((Tcl_Interp *) iPtr, "event \"", string, - "\" hasn't occurred yet", (char *) NULL); - return NULL; - } - if ((eventNum <= iPtr->curEventNum-iPtr->numEvents) - || (eventNum <= 0)) { - Tcl_AppendResult((Tcl_Interp *) iPtr, "event \"", string, - "\" is too far in the past", (char *) NULL); - return NULL; - } - index = iPtr->curEvent + (eventNum - iPtr->curEventNum); - if (index < 0) { - index += iPtr->numEvents; - } - return &iPtr->events[index]; - } - - /* - * Next, check for an event that contains the string as a prefix or - * that matches the string in the sense of Tcl_StringMatch. - */ - - length = strlen(string); - for (index = iPtr->curEvent - 1; ; index--) { - if (index < 0) { - index += iPtr->numEvents; - } - if (index == iPtr->curEvent) { - break; - } - eventPtr = &iPtr->events[index]; - if ((strncmp(eventPtr->command, string, (size_t) length) == 0) - || Tcl_StringMatch(eventPtr->command, string)) { - return eventPtr; - } - } - - Tcl_AppendResult((Tcl_Interp *) iPtr, "no event matches \"", string, - "\"", (char *) NULL); - return NULL; -} - -/* - *---------------------------------------------------------------------- - * - * SubsAndEval -- - * - * Generate a new command by making a textual substitution in - * the "cmd" argument. Then execute the new command. - * - * Results: - * The return value is a standard Tcl error. - * - * Side effects: - * History gets revised if the substitution is occurring on - * a recorded command line. Also, the re-executed command - * may produce side-effects. - * - *---------------------------------------------------------------------- - */ - -static int -SubsAndEval(iPtr, cmd, old, new) - register Interp *iPtr; /* Interpreter in which to execute - * new command. */ - char *cmd; /* Command in which to substitute. */ - char *old; /* String to search for in command. */ - char *new; /* Replacement string for "old". */ -{ - char *src, *dst, *newCmd; - int count, oldLength, newLength, length, result; - - /* - * Figure out how much space it will take to hold the - * substituted command (and complain if the old string - * doesn't appear in the original command). - */ - - oldLength = strlen(old); - newLength = strlen(new); - src = cmd; - count = 0; - while (1) { - src = strstr(src, old); - if (src == NULL) { - break; - } - src += oldLength; - count++; - } - if (count == 0) { - Tcl_AppendResult((Tcl_Interp *) iPtr, "\"", old, - "\" doesn't appear in event", (char *) NULL); - return TCL_ERROR; - } - length = strlen(cmd) + count*(newLength - oldLength); - - /* - * Generate a substituted command. - */ - - newCmd = (char *) ckalloc((unsigned) (length + 1)); - dst = newCmd; - while (1) { - src = strstr(cmd, old); - if (src == NULL) { - strcpy(dst, cmd); - break; - } - strncpy(dst, cmd, (size_t) (src-cmd)); - dst += src-cmd; - strcpy(dst, new); - dst += newLength; - cmd = src + oldLength; + Tcl_ResetResult(interp); + result = TCL_OK; } - - RevCommand(iPtr, newCmd); - result = Tcl_Eval((Tcl_Interp *) iPtr, newCmd); - ckfree(newCmd); return result; } /* *---------------------------------------------------------------------- * - * GetWords -- + * Tcl_RecordAndEvalObj -- * - * Given a command string, return one or more words from the - * command string. + * This procedure adds the command held in its argument object to the + * current list of recorded events and then executes the command by + * calling Tcl_EvalObj. * * Results: - * The return value is a pointer to a dynamically-allocated - * string containing the words of command specified by "words". - * If the word specifier has improper syntax then an error - * message is placed in iPtr->result and NULL is returned. + * The return value is a standard Tcl return value, the result of + * executing the command. * * Side effects: - * Memory is allocated. It is the caller's responsibilty to - * free the returned string.. + * The command is recorded and executed. * *---------------------------------------------------------------------- */ -static char * -GetWords(iPtr, command, words) - register Interp *iPtr; /* Tcl interpreter in which to place - * an error message if needed. */ - char *command; /* Command string. */ - char *words; /* Description of which words to extract - * from the command. Either num[-num] or - * a pattern. */ +int +Tcl_RecordAndEvalObj(interp, cmdPtr, flags) + Tcl_Interp *interp; /* Token for interpreter in which command + * will be executed. */ + Tcl_Obj *cmdPtr; /* Points to object holding the command to + * record and execute. */ + int flags; /* Additional flags. TCL_NO_EVAL means + * record only: don't execute the command. + * TCL_EVAL_GLOBAL means use + * Tcl_GlobalEvalObj instead of + * Tcl_EvalObj. */ { - char *result; - char *start, *end, *dst; - register char *next; - int first; /* First word desired. -1 means last word - * only. */ - int last; /* Last word desired. -1 means use everything - * up to the end. */ - int index; /* Index of current word. */ - char *pattern; + Interp *iPtr = (Interp *) interp; + int result; + Tcl_Obj *list[3]; + register Tcl_Obj *objPtr; /* - * Figure out whether we're looking for a numerical range or for - * a pattern. + * Do recording by eval'ing a tcl history command: history add $cmd. */ - pattern = NULL; - first = 0; - last = -1; - if (*words == '$') { - if (words[1] != '\0') { - goto error; - } - first = -1; - } else if (isdigit(UCHAR(*words))) { - first = strtoul(words, &start, 0); - if (*start == 0) { - last = first; - } else if (*start == '-') { - start++; - if (*start == '$') { - start++; - } else if (isdigit(UCHAR(*start))) { - last = strtoul(start, &start, 0); - } else { - goto error; - } - if (*start != 0) { - goto error; - } - } - if ((first > last) && (last != -1)) { - goto error; - } - } else { - pattern = words; - } + list[0] = Tcl_NewStringObj("history", -1); + list[1] = Tcl_NewStringObj("add", -1); + list[2] = cmdPtr; + + objPtr = Tcl_NewListObj(3, list); + Tcl_IncrRefCount(objPtr); + (void) Tcl_GlobalEvalObj(interp, objPtr); + Tcl_DecrRefCount(objPtr); /* - * Scan through the words one at a time, copying those that are - * relevant into the result string. Allocate a result area large - * enough to hold all the words if necessary. + * Execute the command. */ - result = (char *) ckalloc((unsigned) (strlen(command) + 1)); - dst = result; - for (next = command; isspace(UCHAR(*next)); next++) { - /* Empty loop body: just find start of first word. */ - } - for (index = 0; *next != 0; index++) { - start = next; - end = TclWordEnd(next, next + strlen(next), 0, (int *) NULL); - if (*end != 0) { - end++; - for (next = end; isspace(UCHAR(*next)); next++) { - /* Empty loop body: just find start of next word. */ - } - } - if ((first > index) || ((first == -1) && (*next != 0))) { - continue; - } - if ((last != -1) && (last < index)) { - continue; - } - if (pattern != NULL) { - int match; - char savedChar = *end; - - *end = 0; - match = Tcl_StringMatch(start, pattern); - *end = savedChar; - if (!match) { - continue; - } - } - if (dst != result) { - *dst = ' '; - dst++; + result = TCL_OK; + if (!(flags & TCL_NO_EVAL)) { + iPtr->evalFlags = (flags & ~TCL_EVAL_GLOBAL); + if (flags & TCL_EVAL_GLOBAL) { + result = Tcl_GlobalEvalObj(interp, cmdPtr); + } else { + result = Tcl_EvalObj(interp, cmdPtr); } - strncpy(dst, start, (size_t) (end-start)); - dst += end-start; - } - *dst = 0; - - /* - * Check for an out-of-range argument index. - */ - - if ((last >= index) || (first >= index)) { - ckfree(result); - Tcl_AppendResult((Tcl_Interp *) iPtr, "word selector \"", words, - "\" specified non-existent words", (char *) NULL); - return NULL; } return result; - - error: - Tcl_AppendResult((Tcl_Interp *) iPtr, "bad word selector \"", words, - "\": should be num-num or pattern", (char *) NULL); - return NULL; } diff --git a/contrib/tcl/generic/tclIO.c b/contrib/tcl/generic/tclIO.c index b562b7b..2b13e2d 100644 --- a/contrib/tcl/generic/tclIO.c +++ b/contrib/tcl/generic/tclIO.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclIO.c 1.265 97/06/20 13:24:48 + * SCCS: @(#) tclIO.c 1.268 97/07/28 14:20:36 */ #include "tclInt.h" @@ -1682,6 +1682,10 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush) } } else { Tcl_SetErrno(errorCode); + if (interp != NULL) { + Tcl_SetResult(interp, + Tcl_PosixError(interp), TCL_VOLATILE); + } } /* @@ -4969,7 +4973,9 @@ ChannelEventScriptInvoker(clientData, mask) */ if (result != TCL_OK) { - DeleteScriptRecord(interp, chanPtr, mask); + if (chanPtr->typePtr != NULL) { + DeleteScriptRecord(interp, chanPtr, mask); + } Tcl_BackgroundError(interp); } Tcl_Release((ClientData) interp); @@ -5662,14 +5668,6 @@ TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr) csPtr->total = 0; csPtr->interp = interp; if (cmdPtr) { - /* - * We save this command object and mutate it later with - * extra arguments, so we need a private copy. - */ - - if (Tcl_IsShared(cmdPtr)) { - cmdPtr = Tcl_DuplicateObj(cmdPtr); - } Tcl_IncrRefCount(cmdPtr); } csPtr->cmdPtr = cmdPtr; @@ -5838,18 +5836,22 @@ CopyData(csPtr, mask) /* * Make the callback or return the number of bytes transferred. - * The local total is used because StopCopoy frees csPtr. + * The local total is used because StopCopy frees csPtr. */ total = csPtr->total; if (cmdPtr) { + /* + * Get a private copy of the command so we can mutate it + * by adding arguments. Note that StopCopy frees our saved + * reference to the original command obj. + */ + + cmdPtr = Tcl_DuplicateObj(cmdPtr); Tcl_IncrRefCount(cmdPtr); StopCopy(csPtr); Tcl_Preserve((ClientData) interp); - /* - * This is already a private object, so we mutate it to add args. - */ Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewIntObj(total)); if (errObj) { Tcl_ListObjAppendElement(interp, cmdPtr, errObj); diff --git a/contrib/tcl/generic/tclIOCmd.c b/contrib/tcl/generic/tclIOCmd.c index ae09c8f..5640b47 100644 --- a/contrib/tcl/generic/tclIOCmd.c +++ b/contrib/tcl/generic/tclIOCmd.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclIOCmd.c 1.117 97/06/23 18:57:17 + * SCCS: @(#) tclIOCmd.c 1.119 97/07/25 20:49:23 */ #include "tclInt.h" @@ -579,7 +579,7 @@ Tcl_TellCmd(clientData, interp, argc, argv) /* *---------------------------------------------------------------------- * - * Tcl_CloseCmd -- + * Tcl_CloseObjCmd -- * * This procedure is invoked to process the Tcl "close" command. * See the user documentation for details on what it does. @@ -595,26 +595,28 @@ Tcl_TellCmd(clientData, interp, argc, argv) /* ARGSUSED */ int -Tcl_CloseCmd(clientData, interp, argc, argv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ +Tcl_CloseObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Channel chan; /* The channel to close. */ int len; /* Length of error output. */ + char *arg; - if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelId\"", (char *) NULL); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "channelId"); return TCL_ERROR; } - chan = Tcl_GetChannel(interp, argv[1], NULL); + + arg = Tcl_GetStringFromObj(objv[1], NULL); + chan = Tcl_GetChannel(interp, arg, NULL); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } - if (Tcl_UnregisterChannel(interp, chan) != TCL_OK) { + if (Tcl_UnregisterChannel(interp, chan) != TCL_OK) { /* * If there is an error message and it ends with a newline, remove * the newline. This is done for command pipeline channels where the @@ -633,6 +635,7 @@ Tcl_CloseCmd(clientData, interp, argc, argv) return TCL_ERROR; } + return TCL_OK; } @@ -705,7 +708,7 @@ Tcl_FconfigureCmd(clientData, interp, argc, argv) /* *---------------------------------------------------------------------- * - * Tcl_EofCmd -- + * Tcl_EofObjCmd -- * * This procedure is invoked to process the Tcl "eof" command. * See the user documentation for details on what it does. @@ -722,22 +725,24 @@ Tcl_FconfigureCmd(clientData, interp, argc, argv) /* ARGSUSED */ int -Tcl_EofCmd(unused, interp, argc, argv) - ClientData unused; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ +Tcl_EofObjCmd(unused, interp, objc, objv) + ClientData unused; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Channel chan; /* The channel to query for EOF. */ int mode; /* Mode in which channel is opened. */ char buf[40]; + char *arg; - if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelId\"", (char *) NULL); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "channelId"); return TCL_ERROR; } - chan = Tcl_GetChannel(interp, argv[1], &mode); + + arg = Tcl_GetStringFromObj(objv[1], NULL); + chan = Tcl_GetChannel(interp, arg, &mode); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } @@ -891,7 +896,7 @@ Tcl_ExecCmd(dummy, interp, argc, argv) /* *---------------------------------------------------------------------- * - * Tcl_FblockedCmd -- + * Tcl_FblockedObjCmd -- * * This procedure is invoked to process the Tcl "fblocked" command. * See the user documentation for details on what it does. @@ -908,27 +913,30 @@ Tcl_ExecCmd(dummy, interp, argc, argv) /* ARGSUSED */ int -Tcl_FblockedCmd(unused, interp, argc, argv) - ClientData unused; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ +Tcl_FblockedObjCmd(unused, interp, objc, objv) + ClientData unused; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Channel chan; /* The channel to query for blocked. */ int mode; /* Mode in which channel was opened. */ char buf[40]; + char *arg; - if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelId\"", (char *) NULL); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "channelId"); return TCL_ERROR; } - chan = Tcl_GetChannel(interp, argv[1], &mode); + + arg = Tcl_GetStringFromObj(objv[1], NULL); + chan = Tcl_GetChannel(interp, arg, &mode); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", argv[1], + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"", + Tcl_GetStringFromObj(objv[1], NULL), "\" wasn't opened for reading", (char *) NULL); return TCL_ERROR; } @@ -1491,7 +1499,8 @@ Tcl_FcopyObjCmd(dummy, interp, objc, objv) enum { FcopySize, FcopyCommand } index; if ((objc < 3) || (objc > 7) || (objc == 4) || (objc == 6)) { - Tcl_WrongNumArgs(interp, 1, objv, "input output ?-size size? ?-command callback?"); + Tcl_WrongNumArgs(interp, 1, objv, + "input output ?-size size? ?-command callback?"); return TCL_ERROR; } @@ -1541,5 +1550,6 @@ Tcl_FcopyObjCmd(dummy, interp, objc, objv) break; } } + return TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr); } diff --git a/contrib/tcl/generic/tclIndexObj.c b/contrib/tcl/generic/tclIndexObj.c index 86a394f..824270a 100644 --- a/contrib/tcl/generic/tclIndexObj.c +++ b/contrib/tcl/generic/tclIndexObj.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclIndexObj.c 1.4 97/02/11 13:30:01 + * SCCS: @(#) tclIndexObj.c 1.8 97/07/29 10:16:54 */ #include "tclInt.h" @@ -237,3 +237,72 @@ UpdateStringOfIndex(objPtr) { panic("UpdateStringOfIndex should never be invoked"); } + +/* + *---------------------------------------------------------------------- + * + * Tcl_WrongNumArgs -- + * + * This procedure generates a "wrong # args" error message in an + * interpreter. It is used as a utility function by many command + * procedures. + * + * Results: + * None. + * + * Side effects: + * An error message is generated in interp's result object to + * indicate that a command was invoked with the wrong number of + * arguments. The message has the form + * wrong # args: should be "foo bar additional stuff" + * where "foo" and "bar" are the initial objects in objv (objc + * determines how many of these are printed) and "additional stuff" + * is the contents of the message argument. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_WrongNumArgs(interp, objc, objv, message) + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments to print + * from objv. */ + Tcl_Obj *CONST objv[]; /* Initial argument objects, which + * should be included in the error + * message. */ + char *message; /* Error message to print after the + * leading objects in objv. The + * message may be NULL. */ +{ + Tcl_Obj *objPtr; + char **tablePtr; + int i; + + objPtr = Tcl_GetObjResult(interp); + Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1); + for (i = 0; i < objc; i++) { + /* + * If the object is an index type use the index table which allows + * for the correct error message even if the subcommand was + * abbreviated. Otherwise, just use the string rep. + */ + + if (objv[i]->typePtr == &tclIndexType) { + tablePtr = ((char **) objv[i]->internalRep.twoPtrValue.ptr1); + Tcl_AppendStringsToObj(objPtr, + tablePtr[(int) objv[i]->internalRep.twoPtrValue.ptr2], + (char *) NULL); + } else { + Tcl_AppendStringsToObj(objPtr, + Tcl_GetStringFromObj(objv[i], (int *) NULL), + (char *) NULL); + } + if (i < (objc - 1)) { + Tcl_AppendStringsToObj(objPtr, " ", (char *) NULL); + } + } + if (message) { + Tcl_AppendStringsToObj(objPtr, " ", message, (char *) NULL); + } + Tcl_AppendStringsToObj(objPtr, "\"", (char *) NULL); +} diff --git a/contrib/tcl/generic/tclInt.h b/contrib/tcl/generic/tclInt.h index 1e88992..32ef58a 100644 --- a/contrib/tcl/generic/tclInt.h +++ b/contrib/tcl/generic/tclInt.h @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclInt.h 1.277 97/06/20 15:19:00 + *SCCS: @(#) tclInt.h 1.293 97/08/12 17:07:02 */ #ifndef _TCLINT @@ -281,8 +281,9 @@ typedef struct Var { * call frame or the hash table: 1 for each * additional variable whose linkPtr points * here, 1 for each nested trace active on - * variable. This record can't be deleted - * until refCount becomes 0. */ + * variable, and 1 if the variable is a + * namespace variable. This record can't be + * deleted until refCount becomes 0. */ VarTrace *tracePtr; /* First in list of all traces set for this * variable. */ ArraySearch *searchPtr; /* First in list of all searches active @@ -330,6 +331,14 @@ typedef struct Var { * element, so it is not legal for it to be * an array itself (the VAR_ARRAY flag had * better not be set). + * VAR_NAMESPACE_VAR - 1 means that this variable was declared + * as a namespace variable. This flag ensures + * it persists until its namespace is + * destroyed or until the variable is unset; + * it will persist even if it has not been + * initialized and is marked undefined. + * The variable's refCount is incremented to + * reflect the "reference" from its namespace. */ #define VAR_SCALAR 0x1 @@ -339,6 +348,7 @@ typedef struct Var { #define VAR_IN_HASHTABLE 0x10 #define VAR_TRACE_ACTIVE 0x20 #define VAR_ARRAY_ELEMENT 0x40 +#define VAR_NAMESPACE_VAR 0x80 /* * Macros to ensure that various flag bits are set properly for variables. @@ -404,6 +414,13 @@ typedef struct Var { */ /* + * Forward declaration to prevent an error when the forward reference to + * Command is encountered in the Proc and ImportRef types declared below. + */ + +struct Command; + +/* * The variable-length structure below describes a local variable of a * procedure that was recognized by the compiler. These variables have a * name, an element in the array of compiler-assigned local variables in the @@ -459,8 +476,10 @@ typedef struct Proc { * to the procedure that is currently * active. This structure can be freed * when refCount becomes zero. */ - Namespace *nsPtr; /* Points to the namespace that contains - * this procedure. */ + struct Command *cmdPtr; /* Points to the Command structure for + * this procedure. This is used to get + * the namespace in which to execute + * the procedure. */ Tcl_Obj *bodyPtr; /* Points to the ByteCode object for * procedure's body command. */ int numArgs; /* Number of formal parameters. */ @@ -700,13 +719,6 @@ typedef struct ExecEnv { */ /* - * Forward declaration to prevent an error when the forward reference to - * Command is encountered in the ImportRef type declared below. - */ - -struct Command; - -/* * An imported command is created in an namespace when it imports a "real" * command from another namespace. An imported command has a Command * structure that points (via its ClientData value) to the "real" Command @@ -859,32 +871,6 @@ typedef struct Interp { * is TCL_ERROR. Malloc'ed, may be NULL */ /* - * Information related to history: - */ - - int numEvents; /* Number of previously-executed commands - * to retain. */ - HistoryEvent *events; /* Array containing numEvents entries - * (dynamically allocated). */ - int curEvent; /* Index into events of place where current - * (or most recent) command is recorded. */ - int curEventNum; /* Event number associated with the slot - * given by curEvent. */ - HistoryRev *revPtr; /* First in list of pending revisions. */ - char *historyFirst; /* First char. of current command executed - * from history module or NULL if none. */ - int revDisables; /* 0 means history revision OK; > 0 gives - * a count of number of times revision has - * been disabled. */ - char *evalFirst; /* If TCL_RECORD_BOUNDS Tcl_Eval and - * Tcl_EvalObj set this field to point to - * the first char. of text from which the - * current command came. Otherwise set to - * NULL. */ - char *evalLast; /* Similar to evalFirst, except points to - * last character of current command. */ - - /* * Information used by Tcl_AppendResult to keep track of partial * results. See Tcl_AppendResult code for details. */ @@ -976,17 +962,12 @@ typedef struct Interp { * * TCL_BRACKET_TERM 1 means that the current script is terminated by * a close bracket rather than the end of the string. - * TCL_RECORD_BOUNDS Tells Tcl_Eval to record information in the - * evalFirst and evalLast fields for each command - * executed directly from the string (top-level - * commands and those from command substitution). * TCL_ALLOW_EXCEPTIONS 1 means it's OK for the script to terminate with * a code other than TCL_OK or TCL_ERROR; 0 means * codes other than these should be turned into errors. */ #define TCL_BRACKET_TERM 1 -#define TCL_RECORD_BOUNDS 2 #define TCL_ALLOW_EXCEPTIONS 4 /* @@ -1016,6 +997,9 @@ typedef struct Interp { * RAND_SEED_INITIALIZED: Non-zero means that the randSeed value of the * interp has not be initialized. This is set 1 * when we first use the rand() or srand() functions. + * SAFE_INTERP: Non zero means that the current interp is a + * safe interp (ie it has only the safe commands + * installed, less priviledge than a regular interp). */ #define DELETED 1 @@ -1025,6 +1009,7 @@ typedef struct Interp { #define EXPR_INITIALIZED 0x10 #define DONT_COMPILE_CMDS_INLINE 0x20 #define RAND_SEED_INITIALIZED 0x40 +#define SAFE_INTERP 0x80 /* *---------------------------------------------------------------- @@ -1300,6 +1285,7 @@ EXTERN int TclFileMakeDirsCmd _ANSI_ARGS_((Tcl_Interp *interp, EXTERN int TclFileRenameCmd _ANSI_ARGS_((Tcl_Interp *interp, int argc, char **argv)) ; EXTERN void TclFinalizeCompExecEnv _ANSI_ARGS_((void)); +EXTERN void TclFinalizeEnvironment _ANSI_ARGS_((void)); EXTERN void TclFinalizeExecEnv _ANSI_ARGS_((void)); EXTERN int TclFindElement _ANSI_ARGS_((Tcl_Interp *interp, char *list, int listLength, char **elementPtr, @@ -1318,7 +1304,7 @@ EXTERN Tcl_Channel TclGetDefaultStdChannel _ANSI_ARGS_((int type)); EXTERN Tcl_Obj * TclGetElementOfIndexedArray _ANSI_ARGS_(( Tcl_Interp *interp, int localIndex, Tcl_Obj *elemPtr, int leaveErrorMsg)); -EXTERN char * TclGetEnv _ANSI_ARGS_((char *name)); +EXTERN char * TclGetEnv _ANSI_ARGS_((CONST char *name)); EXTERN char * TclGetExtension _ANSI_ARGS_((char *name)); EXTERN int TclGetFrame _ANSI_ARGS_((Tcl_Interp *interp, char *string, CallFrame **framePtrPtr)); @@ -1388,6 +1374,7 @@ EXTERN int TclMatchFiles _ANSI_ARGS_((Tcl_Interp *interp, char *separators, Tcl_DString *dirPtr, char *pattern, char *tail)); EXTERN int TclNeedSpace _ANSI_ARGS_((char *start, char *end)); +EXTERN int TclObjCommandComplete _ANSI_ARGS_((Tcl_Obj *cmdPtr)); EXTERN int TclObjInterpProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); @@ -1396,6 +1383,17 @@ EXTERN int TclObjInvoke _ANSI_ARGS_((Tcl_Interp *interp, EXTERN int TclObjInvokeGlobal _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], int flags)); EXTERN char * TclpAlloc _ANSI_ARGS_((unsigned int size)); + +/* + * On a Mac, we can exit gracefully if the stack gets too small. + */ + +#ifdef MAC_TCL +EXTERN int TclpCheckStackSpace _ANSI_ARGS_((void)); +#else +#define TclpCheckStackSpace() (1) +#endif + EXTERN int TclpCloseFile _ANSI_ARGS_((TclFile file)); EXTERN int TclpCopyFile _ANSI_ARGS_((char *source, char *dest)); EXTERN int TclpCopyDirectory _ANSI_ARGS_((char *source, @@ -1419,15 +1417,27 @@ EXTERN unsigned long TclpGetSeconds _ANSI_ARGS_((void)); EXTERN void TclpGetTime _ANSI_ARGS_((Tcl_Time *time)); EXTERN int TclpGetTimeZone _ANSI_ARGS_((unsigned long time)); EXTERN char * TclpGetTZName _ANSI_ARGS_((void)); +EXTERN int TclpListVolumes _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN TclFile TclpMakeFile _ANSI_ARGS_((Tcl_Channel channel, int direction)); EXTERN TclFile TclpOpenFile _ANSI_ARGS_((char *fname, int mode)); -EXTERN int TclpListVolumes _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN char * TclpRealloc _ANSI_ARGS_((char *ptr, unsigned int size)); EXTERN int TclpRemoveDirectory _ANSI_ARGS_((char *path, int recursive, Tcl_DString *errorPtr)); EXTERN int TclpRenameFile _ANSI_ARGS_((char *source, char *dest)); +EXTERN char * TclpSetEnv _ANSI_ARGS_((CONST char *name, + CONST char *value)); +#ifndef TclpSysAlloc +EXTERN VOID * TclpSysAlloc _ANSI_ARGS_((long size, int isBin)); +#endif +#ifndef TclpSysFree +EXTERN void TclpSysFree _ANSI_ARGS_((VOID *ptr)); +#endif +#ifndef TclpSysRealloc +EXTERN VOID * TclpSysRealloc _ANSI_ARGS_((VOID *cp, + unsigned int size)); +#endif EXTERN int TclParseBraces _ANSI_ARGS_((Tcl_Interp *interp, char *string, char **termPtr, ParseValue *pvPtr)); EXTERN int TclParseNestedCmd _ANSI_ARGS_((Tcl_Interp *interp, @@ -1438,6 +1448,9 @@ EXTERN int TclParseQuotes _ANSI_ARGS_((Tcl_Interp *interp, char **termPtr, ParseValue *pvPtr)); EXTERN void TclPlatformExit _ANSI_ARGS_((int status)); EXTERN void TclPlatformInit _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN char * TclPrecTraceProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *name1, char *name2, + int flags)); EXTERN int TclPreventAliasLoop _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Interp *cmdInterp, Tcl_Command cmd)); EXTERN void TclPrintByteCodeObj _ANSI_ARGS_((Tcl_Interp *interp, @@ -1475,8 +1488,8 @@ EXTERN char * TclWordEnd _ANSI_ARGS_((char *start, char *lastChar, *---------------------------------------------------------------- */ -EXTERN int Tcl_AfterCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_AfterObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_AppendObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_ArrayObjCmd _ANSI_ARGS_((ClientData clientData, @@ -1489,18 +1502,18 @@ EXTERN int Tcl_CaseObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_CatchObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_CdCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_CdObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_ClockObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_CloseCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_CloseObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_ConcatObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_ContinueCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_EofCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_EofObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_ErrorObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_EvalObjCmd _ANSI_ARGS_((ClientData clientData, @@ -1511,8 +1524,8 @@ EXTERN int Tcl_ExitObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_ExprObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_FblockedCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_FblockedObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_FconfigureCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); EXTERN int Tcl_FcopyObjCmd _ANSI_ARGS_((ClientData dummy, @@ -1527,8 +1540,8 @@ EXTERN int Tcl_ForCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); EXTERN int Tcl_ForeachObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_FormatCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_FormatObjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_GetsObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_GlobalObjCmd _ANSI_ARGS_((ClientData clientData, @@ -1597,8 +1610,8 @@ EXTERN int Tcl_SeekCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); EXTERN int Tcl_SetCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_SplitCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_SplitObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_SocketCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); EXTERN int Tcl_SourceObjCmd _ANSI_ARGS_((ClientData clientData, diff --git a/contrib/tcl/generic/tclInterp.c b/contrib/tcl/generic/tclInterp.c index e9ad76a..ae5171a 100644 --- a/contrib/tcl/generic/tclInterp.c +++ b/contrib/tcl/generic/tclInterp.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclInterp.c 1.115 97/06/19 18:06:39 + * SCCS: @(#) tclInterp.c 1.125 97/08/05 15:22:51 */ #include <stdio.h> @@ -17,20 +17,6 @@ #include "tclPort.h" /* - * Tcl script to make an interpreter safe. - */ - -static char makeSafeScript[] = -"if {[info exists env(DISPLAY)]} {\n\ - set ___x___ $env(DISPLAY)\n\ -}\n\ -unset env\n\ -if {[info exists ___x___]} {\n\ - set env(DISPLAY) $___x___\n\ - unset ___x___\n\ -}"; - -/* * Counter for how many aliases were created (global) */ @@ -108,13 +94,15 @@ typedef struct { /* * struct Master: * - * This record is used for three purposes: First, slaveTable (a hashtable) + * This record is used for two purposes: First, slaveTable (a hashtable) * maps from names of commands to slave interpreters. This hashtable is * used to store information about slave interpreters of this interpreter, * to map over all slaves, etc. The second purpose is to store information * about all aliases in slaves (or siblings) which direct to target commands - * in this interpreter (using the targetTable hashtable). The third field in - * the record, isSafe, denotes whether the interpreter is safe or not. Safe + * in this interpreter (using the targetTable hashtable). + * + * NB: the flags field in the interp structure, used with SAFE_INTERP + * mask denotes whether the interpreter is safe or not. Safe * interpreters have restricted functionality, can only create safe slave * interpreters and can only load safe extensions. */ @@ -122,7 +110,6 @@ typedef struct { typedef struct { Tcl_HashTable slaveTable; /* Hash table for slave interpreters. * Maps from command names to Slave records. */ - int isSafe; /* Am I a "safe" interpreter? */ Tcl_HashTable targetTable; /* Hash table for Target Records. Contains * all Target records which denote aliases * from slaves or sibling interpreters that @@ -204,6 +191,9 @@ static int InterpShareHelper _ANSI_ARGS_((Tcl_Interp *interp, static int InterpTargetHelper _ANSI_ARGS_((Tcl_Interp *interp, Master *masterPtr, int objc, Tcl_Obj *CONST objv[])); +static int InterpTransferHelper _ANSI_ARGS_((Tcl_Interp *interp, + Master *masterPtr, int objc, + Tcl_Obj *CONST objv[])); static int MarkTrusted _ANSI_ARGS_((Tcl_Interp *interp)); static void MasterRecordDeleteProc _ANSI_ARGS_(( ClientData clientData, Tcl_Interp *interp)); @@ -351,15 +341,9 @@ static int MarkTrusted(interp) Tcl_Interp *interp; /* Interpreter to be marked unsafe. */ { - Master *masterPtr; /* Master record for interpreter to - * be marked unsafe. */ + Interp *iPtr = (Interp *) interp; - masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", - NULL); - if (masterPtr == (Master *) NULL) { - panic("MarkTrusted: could not find master record"); - } - masterPtr->isSafe = 0; + iPtr->flags &= ~SAFE_INTERP; return TCL_OK; } @@ -386,28 +370,40 @@ int Tcl_MakeSafe(interp) Tcl_Interp *interp; /* Interpreter to be made safe. */ { - Master *masterPtr; /* Master record of interp - * to be made safe. */ Tcl_Channel chan; /* Channel to remove from * safe interpreter. */ - Tcl_Obj *objPtr; + Interp *iPtr = (Interp *) interp; TclHideUnsafeCommands(interp); - masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", - NULL); - if (masterPtr == (Master *) NULL) { - panic("MakeSafe: could not find master record"); - } - masterPtr->isSafe = 1; - objPtr = Tcl_NewStringObj(makeSafeScript, -1); - Tcl_IncrRefCount(objPtr); + + iPtr->flags |= SAFE_INTERP; - if (Tcl_EvalObj(interp, objPtr) == TCL_ERROR) { - Tcl_DecrRefCount(objPtr); - return TCL_ERROR; - } + /* + * Unsetting variables : (which should not have been set + * in the first place, but...) + */ - Tcl_DecrRefCount(objPtr); + /* + * No env array in a safe slave. + */ + + Tcl_UnsetVar(interp, "env", TCL_GLOBAL_ONLY); + + /* + * Remove unsafe parts of tcl_platform + */ + + Tcl_UnsetVar2(interp, "tcl_platform", "os", TCL_GLOBAL_ONLY); + Tcl_UnsetVar2(interp, "tcl_platform", "osVersion", TCL_GLOBAL_ONLY); + Tcl_UnsetVar2(interp, "tcl_platform", "machine", TCL_GLOBAL_ONLY); + + /* + * Unset path informations variables + * (the only one remaining is [info nameofexecutable]) + */ + + Tcl_UnsetVar(interp, "tcl_library", TCL_GLOBAL_ONLY); + Tcl_UnsetVar(interp, "tcl_pkgPath", TCL_GLOBAL_ONLY); /* * Remove the standard channels from the interpreter; safe interpreters @@ -557,7 +553,7 @@ CreateSlave(interp, masterPtr, slavePath, safe) ckfree((char *) masterPath); slavePath = argv[argc-1]; if (!safe) { - safe = masterPtr->isSafe; + safe = Tcl_IsSafe(masterInterp); } } hPtr = Tcl_CreateHashEntry(&(masterPtr->slaveTable), slavePath, &new); @@ -572,7 +568,7 @@ CreateSlave(interp, masterPtr, slavePath, safe) if (slaveInterp == (Tcl_Interp *) NULL) { panic("CreateSlave: out of memory while creating a new interpreter"); } - slavePtr = (Slave *) ckalloc((unsigned) sizeof(Slave)); + slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", NULL); slavePtr->masterInterp = masterInterp; slavePtr->slaveEntry = hPtr; slavePtr->slaveInterp = slaveInterp; @@ -648,10 +644,10 @@ CreateInterpObject(interp, masterPtr, objc, objv) moreFlags = 1; slavePath = NULL; - safe = masterPtr->isSafe; + safe = Tcl_IsSafe(interp); if ((objc < 2) || (objc > 5)) { - Tcl_WrongNumArgs(interp, 1, objv, "create ?-safe? ?--? ?path?"); + Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?"); return TCL_ERROR; } for (i = 2; i < objc; i++) { @@ -675,8 +671,23 @@ CreateInterpObject(interp, masterPtr, objc, objv) } } if (slavePath == (char *) NULL) { - sprintf(localSlaveName, "interp%d", interpCounter); - interpCounter++; + + /* + * Create an anonymous interpreter -- we choose its name and + * the name of the command. We check that the command name that + * we use for the interpreter does not collide with an existing + * command in the master interpreter. + */ + + while (1) { + Tcl_CmdInfo cmdInfo; + + sprintf(localSlaveName, "interp%d", interpCounter); + interpCounter++; + if (!(Tcl_GetCommandInfo(interp, localSlaveName, &cmdInfo))) { + break; + } + } slavePath = localSlaveName; } if (CreateSlave(interp, masterPtr, slavePath, safe) != NULL) { @@ -850,19 +861,12 @@ AliasCreationHelper(curInterp, slaveInterp, masterInterp, masterPtr, slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", NULL); /* - * Fix it up if there is no slave record. This can happen if someone - * uses "" as the source for an alias. + * Slave record should be always present because it is created when + * the interpreter is created. */ if (slavePtr == (Slave *) NULL) { - slavePtr = (Slave *) ckalloc((unsigned) sizeof(Slave)); - slavePtr->masterInterp = (Tcl_Interp *) NULL; - slavePtr->slaveEntry = (Tcl_HashEntry *) NULL; - slavePtr->slaveInterp = slaveInterp; - slavePtr->interpCmd = (Tcl_Command) NULL; - Tcl_InitHashTable(&(slavePtr->aliasTable), TCL_STRING_KEYS); - (void) Tcl_SetAssocData(slaveInterp, "tclSlaveRecord", - SlaveRecordDeleteProc, (ClientData) slavePtr); + panic("AliasCreationHelper: could not find slave record"); } if ((targetName == (char *) NULL) || (targetName[0] == '\0')) { @@ -1018,7 +1022,7 @@ InterpAliasesHelper(interp, masterPtr, objc, objv) Tcl_Obj *listObjPtr, *elemObjPtr; /* Local object pointers. */ if ((objc != 2) && (objc != 3)) { - Tcl_WrongNumArgs(interp, 1, objv, " aliases ?path?"); + Tcl_WrongNumArgs(interp, 2, objv, "?path?"); return TCL_ERROR; } if (objc == 3) { @@ -1092,8 +1096,8 @@ InterpAliasHelper(interp, masterPtr, objc, objv) int len; if (objc < 4) { - Tcl_WrongNumArgs(interp, 1, objv, - "alias slavePath slaveCmd masterPath masterCmd ?args ..?"); + Tcl_WrongNumArgs(interp, 2, objv, + "slavePath slaveCmd masterPath masterCmd ?args ..?"); return TCL_ERROR; } slaveInterp = GetInterp(interp, masterPtr, @@ -1114,8 +1118,8 @@ InterpAliasHelper(interp, masterPtr, objc, objv) Tcl_GetStringFromObj(objv[3], &len)); } if (objc < 6) { - Tcl_WrongNumArgs(interp, 1, objv, - "alias slavePath slaveCmd masterPath masterCmd ?args ..?"); + Tcl_WrongNumArgs(interp, 2, objv, + "slavePath slaveCmd masterPath masterCmd ?args ..?"); return TCL_ERROR; } masterInterp = GetInterp(interp, masterPtr, @@ -1159,19 +1163,19 @@ InterpExistsHelper(interp, masterPtr, objc, objv) int len; if (objc > 3) { - Tcl_WrongNumArgs(interp, 1, objv, "exists ?path?"); + Tcl_WrongNumArgs(interp, 2, objv, "?path?"); return TCL_ERROR; } if (objc == 3) { if (GetInterp(interp, masterPtr, Tcl_GetStringFromObj(objv[2], &len), NULL) == (Tcl_Interp *) NULL) { - objPtr = Tcl_NewStringObj("0", 1); + objPtr = Tcl_NewIntObj(0); } else { - objPtr = Tcl_NewStringObj("1", 1); + objPtr = Tcl_NewIntObj(1); } } else { - objPtr = Tcl_NewStringObj("1", 1); + objPtr = Tcl_NewIntObj(1); } Tcl_SetObjResult(interp, objPtr); @@ -1210,7 +1214,7 @@ InterpEvalHelper(interp, masterPtr, objc, objv) char *string; if (objc < 4) { - Tcl_WrongNumArgs(interp, 1, objv, " eval path arg ?arg ...?"); + Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?"); return TCL_ERROR; } slaveInterp = GetInterp(interp, masterPtr, @@ -1306,8 +1310,8 @@ InterpExposeHelper(interp, masterPtr, objc, objv) int len; /* Dummy length variable. */ if ((objc != 4) && (objc != 5)) { - Tcl_WrongNumArgs(interp, 1, objv, - "expose path hiddenCmdName ?cmdName?"); + Tcl_WrongNumArgs(interp, 2, objv, + "path hiddenCmdName ?cmdName?"); return TCL_ERROR; } if (Tcl_IsSafe(interp)) { @@ -1368,8 +1372,8 @@ InterpHideHelper(interp, masterPtr, objc, objv) int len; /* Dummy length variable. */ if ((objc != 4) && (objc != 5)) { - Tcl_WrongNumArgs(interp, 1, objv, - " hide path cmdName ?hiddenCmdName?"); + Tcl_WrongNumArgs(interp, 2, objv, + "path cmdName ?hiddenCmdName?"); return TCL_ERROR; } if (Tcl_IsSafe(interp)) { @@ -1431,7 +1435,7 @@ InterpHiddenHelper(interp, masterPtr, objc, objv) Tcl_Obj *listObjPtr; /* Local object pointer. */ if (objc > 3) { - Tcl_WrongNumArgs(interp, 1, objv, "hidden ?path?"); + Tcl_WrongNumArgs(interp, 2, objv, "?path?"); return TCL_ERROR; } if (objc == 3) { @@ -1498,8 +1502,8 @@ InterpInvokeHiddenHelper(interp, masterPtr, objc, objv) char *string; if (objc < 4) { - Tcl_WrongNumArgs(interp, 1, objv, - "invokehidden path ?-global? cmd ?arg ..?"); + Tcl_WrongNumArgs(interp, 2, objv, + "path ?-global? cmd ?arg ..?"); return TCL_ERROR; } if (Tcl_IsSafe(interp)) { @@ -1511,8 +1515,8 @@ InterpInvokeHiddenHelper(interp, masterPtr, objc, objv) if (strcmp(Tcl_GetStringFromObj(objv[3], &len), "-global") == 0) { doGlobal = 1; if (objc < 5) { - Tcl_WrongNumArgs(interp, 1, objv, - "invokehidden path ?-global? cmd ?arg ..?"); + Tcl_WrongNumArgs(interp, 2, objv, + "path ?-global? cmd ?arg ..?"); return TCL_ERROR; } } @@ -1607,7 +1611,7 @@ InterpMarkTrustedHelper(interp, masterPtr, objc, objv) int len; /* Dummy length variable. */ if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "marktrusted path"); + Tcl_WrongNumArgs(interp, 2, objv, "path"); return TCL_ERROR; } if (Tcl_IsSafe(interp)) { @@ -1658,7 +1662,7 @@ InterpIsSafeHelper(interp, masterPtr, objc, objv) Tcl_Obj *objPtr; /* Local object pointer. */ if (objc > 3) { - Tcl_WrongNumArgs(interp, 1, objv, "issafe ?path?"); + Tcl_WrongNumArgs(interp, 2, objv, "?path?"); return TCL_ERROR; } if (objc == 3) { @@ -1671,11 +1675,9 @@ InterpIsSafeHelper(interp, masterPtr, objc, objv) (char *) NULL); return TCL_ERROR; } - } - if (masterPtr->isSafe == 0) { - objPtr = Tcl_NewStringObj("0", 1); + objPtr = Tcl_NewIntObj(Tcl_IsSafe(slaveInterp)); } else { - objPtr = Tcl_NewStringObj("1", 1); + objPtr = Tcl_NewIntObj(Tcl_IsSafe(interp)); } Tcl_SetObjResult(interp, objPtr); return TCL_OK; @@ -1710,7 +1712,7 @@ InterpSlavesHelper(interp, masterPtr, objc, objv) Tcl_Obj *listObjPtr; /* Local object pointers. */ if ((objc != 2) && (objc != 3)) { - Tcl_WrongNumArgs(interp, 1, objv, "slaves ?path?"); + Tcl_WrongNumArgs(interp, 2, objv, "?path?"); return TCL_ERROR; } if (objc == 3) { @@ -1768,7 +1770,7 @@ InterpShareHelper(interp, masterPtr, objc, objv) Tcl_Channel chan; if (objc != 5) { - Tcl_WrongNumArgs(interp, 1, objv, "share srcPath channelId destPath"); + Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath"); return TCL_ERROR; } masterInterp = GetInterp(interp, masterPtr, @@ -1826,7 +1828,7 @@ InterpTargetHelper(interp, masterPtr, objc, objv) int len; if (objc != 4) { - Tcl_WrongNumArgs(interp, 1, objv, "target path alias"); + Tcl_WrongNumArgs(interp, 2, objv, "path alias"); return TCL_ERROR; } return GetTarget(interp, @@ -1865,8 +1867,8 @@ InterpTransferHelper(interp, masterPtr, objc, objv) Tcl_Channel chan; if (objc != 5) { - Tcl_WrongNumArgs(interp, 1, objv, - "transfer srcPath channelId destPath"); + Tcl_WrongNumArgs(interp, 2, objv, + "srcPath channelId destPath"); return TCL_ERROR; } masterInterp = GetInterp(interp, masterPtr, @@ -1944,24 +1946,14 @@ DescribeAlias(interp, slaveInterp, aliasName) slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", NULL); - if (slavePtr == (Slave *) NULL) { - /* - * It's possible that the interpreter still does not have a slave - * record. If so, create such a record now. This is only possible - * for interpreters that were created with Tcl_CreateInterp, not - * those created with Tcl_CreateSlave, so this interpreter does - * not have a master. - */ - - slavePtr = (Slave *) ckalloc((unsigned) sizeof(Slave)); - slavePtr->masterInterp = (Tcl_Interp *) NULL; - slavePtr->slaveEntry = (Tcl_HashEntry *) NULL; - slavePtr->slaveInterp = slaveInterp; - slavePtr->interpCmd = (Tcl_Command) NULL; - Tcl_InitHashTable(&(slavePtr->aliasTable), TCL_STRING_KEYS); - (void) Tcl_SetAssocData(slaveInterp, "tclSlaveRecord", - SlaveRecordDeleteProc, (ClientData) slavePtr); + /* + * The slave record should always be present because it is created + * by Tcl_CreateInterp. + */ + + if (slavePtr == (Slave *) NULL) { + panic("DescribeAlias: could not find slave record"); } hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName); if (hPtr == (Tcl_HashEntry *) NULL) { @@ -2322,8 +2314,8 @@ SlaveAliasHelper(interp, slaveInterp, slavePtr, objc, objv) switch (objc-2) { case 0: - Tcl_WrongNumArgs(interp, 1, objv, - "alias aliasName ?targetName? ?args..?"); + Tcl_WrongNumArgs(interp, 2, objv, + "aliasName ?targetName? ?args..?"); return TCL_ERROR; case 1: @@ -2430,7 +2422,7 @@ SlaveEvalHelper(interp, slaveInterp, slavePtr, objc, objv) int result; if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "eval arg ?arg ...?"); + Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?"); return TCL_ERROR; } @@ -2517,7 +2509,7 @@ SlaveExposeHelper(interp, slaveInterp, slavePtr, objc, objv) int len; if ((objc != 3) && (objc != 4)) { - Tcl_WrongNumArgs(interp, 1, objv, "expose hiddenCmdName ?cmdName?"); + Tcl_WrongNumArgs(interp, 2, objv, "hiddenCmdName ?cmdName?"); return TCL_ERROR; } if (Tcl_IsSafe(interp)) { @@ -2566,7 +2558,7 @@ SlaveHideHelper(interp, slaveInterp, slavePtr, objc, objv) int len; if ((objc != 3) && (objc != 4)) { - Tcl_WrongNumArgs(interp, 1, objv, "hide cmdName ?hiddenCmdName?"); + Tcl_WrongNumArgs(interp, 2, objv, "cmdName ?hiddenCmdName?"); return TCL_ERROR; } if (Tcl_IsSafe(interp)) { @@ -2618,7 +2610,7 @@ SlaveHiddenHelper(interp, slaveInterp, slavePtr, objc, objv) Tcl_HashSearch hSearch; /* For local searches. */ if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "hidden"); + Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } @@ -2661,24 +2653,15 @@ SlaveIsSafeHelper(interp, slaveInterp, slavePtr, objc, objv) int objc; /* Count of arguments. */ Tcl_Obj *CONST objv[]; /* Vector of arguments. */ { - Master *masterPtr; /* Master record for slave interp. */ - Tcl_Obj *namePtr; /* Local object pointer. */ + Tcl_Obj *resultPtr; /* Local object pointer. */ if (objc > 2) { - Tcl_WrongNumArgs(interp, 1, objv, "issafe"); + Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } - masterPtr = (Master *) Tcl_GetAssocData(slaveInterp, - "tclMasterRecord", NULL); - if (masterPtr == (Master *) NULL) { - panic("SlaveObjectCmd: could not find master record"); - } - if (masterPtr->isSafe == 1) { - namePtr = Tcl_NewStringObj("1", 1); - } else { - namePtr = Tcl_NewStringObj("0", 1); - } - Tcl_SetObjResult(interp, namePtr); + resultPtr = Tcl_NewIntObj(Tcl_IsSafe(slaveInterp)); + + Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } @@ -2715,8 +2698,8 @@ SlaveInvokeHiddenHelper(interp, slaveInterp, slavePtr, objc, objv) Tcl_Obj *namePtr, *objPtr; if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, - "invokehidden ?-global? cmd ?arg ..?"); + Tcl_WrongNumArgs(interp, 2, objv, + "?-global? cmd ?arg ..?"); return TCL_ERROR; } if (Tcl_IsSafe(interp)) { @@ -2728,8 +2711,8 @@ SlaveInvokeHiddenHelper(interp, slaveInterp, slavePtr, objc, objv) if (strcmp(Tcl_GetStringFromObj(objv[2], &len), "-global") == 0) { doGlobal = 1; if (objc < 4) { - Tcl_WrongNumArgs(interp, 1, objv, - "invokehidden path ?-global? cmd ?arg ..?"); + Tcl_WrongNumArgs(interp, 2, objv, + "path ?-global? cmd ?arg ..?"); return TCL_ERROR; } } @@ -2821,7 +2804,7 @@ SlaveMarkTrustedHelper(interp, slaveInterp, slavePtr, objc, objv) int len; if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "marktrusted"); + Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } if (Tcl_IsSafe(interp)) { @@ -3459,14 +3442,26 @@ TclInterpInit(interp) Tcl_Interp *interp; /* Interpreter to initialize. */ { Master *masterPtr; /* Its Master record. */ + Slave *slavePtr; /* And its slave record. */ masterPtr = (Master *) ckalloc((unsigned) sizeof(Master)); - masterPtr->isSafe = 0; + Tcl_InitHashTable(&(masterPtr->slaveTable), TCL_STRING_KEYS); Tcl_InitHashTable(&(masterPtr->targetTable), TCL_ONE_WORD_KEYS); (void) Tcl_SetAssocData(interp, "tclMasterRecord", MasterRecordDeleteProc, (ClientData) masterPtr); + + slavePtr = (Slave *) ckalloc((unsigned) sizeof(Slave)); + + slavePtr->masterInterp = (Tcl_Interp *) NULL; + slavePtr->slaveEntry = (Tcl_HashEntry *) NULL; + slavePtr->slaveInterp = interp; + slavePtr->interpCmd = (Tcl_Command) NULL; + Tcl_InitHashTable(&(slavePtr->aliasTable), TCL_STRING_KEYS); + + (void) Tcl_SetAssocData(interp, "tclSlaveRecord", SlaveRecordDeleteProc, + (ClientData) slavePtr); return TCL_OK; } @@ -3491,16 +3486,14 @@ int Tcl_IsSafe(interp) Tcl_Interp *interp; /* Is this interpreter "safe" ? */ { - Master *masterPtr; /* Its master record. */ + Interp *iPtr; if (interp == (Tcl_Interp *) NULL) { return 0; } - masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL); - if (masterPtr == (Master *) NULL) { - panic("Tcl_IsSafe: could not find master record"); - } - return masterPtr->isSafe; + iPtr = (Interp *) interp; + + return ( (iPtr->flags) & SAFE_INTERP ) ? 1 : 0 ; } /* diff --git a/contrib/tcl/generic/tclListObj.c b/contrib/tcl/generic/tclListObj.c index 04b2633..0f76f6f 100644 --- a/contrib/tcl/generic/tclListObj.c +++ b/contrib/tcl/generic/tclListObj.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclListObj.c 1.44 97/06/13 18:25:32 + * SCCS: @(#) tclListObj.c 1.47 97/08/12 19:02:02 */ #include "tclInt.h" @@ -413,7 +413,7 @@ Tcl_ListObjAppendElement(interp, listPtr, objPtr) { register List *listRepPtr; register Tcl_Obj **elemPtrs; - int numElems; + int numElems, numRequired; if (Tcl_IsShared(listPtr)) { panic("Tcl_ListObjAppendElement called with shared object"); @@ -428,14 +428,14 @@ Tcl_ListObjAppendElement(interp, listPtr, objPtr) listRepPtr = (List *) listPtr->internalRep.otherValuePtr; elemPtrs = listRepPtr->elements; numElems = listRepPtr->elemCount; + numRequired = numElems + 1 ; /* * If there is no room in the current array of element pointers, * allocate a new, larger array and copy the pointers to it. */ - if (numElems >= listRepPtr->maxElemCount) { - int numRequired = (numElems + 1); + if (numRequired > listRepPtr->maxElemCount) { int newMax = (2 * numRequired); Tcl_Obj **newElemPtrs = (Tcl_Obj **) ckalloc((unsigned) (newMax * sizeof(Tcl_Obj *))); @@ -639,7 +639,7 @@ Tcl_ListObjReplace(interp, listPtr, first, count, objc, objv) } numRequired = (numElems - count + objc); - if (numRequired < listRepPtr->maxElemCount) { + if (numRequired <= listRepPtr->maxElemCount) { /* * Enough room in the current array. First "delete" count * elements starting at first. @@ -941,7 +941,7 @@ SetListFromAny(interp, objPtr) s = ckalloc((unsigned) elemSize + 1); if (hasBrace) { - strncpy(s, elemStart, (size_t) elemSize); + memcpy((VOID *) s, (VOID *) elemStart, (size_t) elemSize); s[elemSize] = 0; } else { elemSize = TclCopyAndCollapse(elemSize, elemStart, s); diff --git a/contrib/tcl/generic/tclLoad.c b/contrib/tcl/generic/tclLoad.c index 2e4e615..a1deee0 100644 --- a/contrib/tcl/generic/tclLoad.c +++ b/contrib/tcl/generic/tclLoad.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclLoad.c 1.16 97/05/14 13:23:37 + * SCCS: @(#) tclLoad.c 1.17 97/07/24 20:05:04 */ #include "tclInt.h" @@ -370,6 +370,10 @@ Tcl_LoadCmd(dummy, interp, argc, argv) * everything we need in target's $errorInfo. */ + /* + * It is (abusively) assumed that errorInfo and errorCode vars exists. + * we changed SetVar2 to accept NULL values to avoid crashes. --dl + */ Tcl_ResetResult(interp); Tcl_AddErrorInfo(interp, Tcl_GetVar2(target, "errorInfo", (char *) NULL, TCL_GLOBAL_ONLY)); diff --git a/contrib/tcl/generic/tclMain.c b/contrib/tcl/generic/tclMain.c index 6ed86e5..ce87636 100644 --- a/contrib/tcl/generic/tclMain.c +++ b/contrib/tcl/generic/tclMain.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclMain.c 1.52 96/10/22 11:23:51 + * SCCS: @(#) tclMain.c 1.54 97/08/07 19:04:43 */ #include "tcl.h" @@ -38,14 +38,13 @@ extern int isatty _ANSI_ARGS_((int fd)); extern char * strcpy _ANSI_ARGS_((char *dst, CONST char *src)); static Tcl_Interp *interp; /* Interpreter for application. */ -static Tcl_DString command; /* Used to buffer incomplete commands being - * read from stdin. */ + #ifdef TCL_MEM_DEBUG static char dumpFile[100]; /* Records where to dump memory allocation * information. */ -static int quitFlag = 0; /* 1 means the "checkmem" command was - * invoked, so the application should quit - * and dump memory allocation information. */ +static int quitFlag = 0; /* 1 means "checkmem" command was called, + * so the application should quit and dump + * memory allocation information. */ #endif /* @@ -78,14 +77,19 @@ static int CheckmemCmd _ANSI_ARGS_((ClientData clientData, void Tcl_Main(argc, argv, appInitProc) - int argc; /* Number of arguments. */ - char **argv; /* Array of argument strings. */ - Tcl_AppInitProc *appInitProc; /* Application-specific initialization - * procedure to call after most - * initialization but before starting - * to execute commands. */ + int argc; /* Number of arguments. */ + char **argv; /* Array of argument strings. */ + Tcl_AppInitProc *appInitProc; + /* Application-specific initialization + * procedure to call after most + * initialization but before starting to + * execute commands. */ { - char buffer[1000], *cmd, *args, *fileName; + Tcl_Obj *prompt1NamePtr = NULL; + Tcl_Obj *prompt2NamePtr = NULL; + Tcl_Obj *resultPtr; + Tcl_Obj *commandPtr = NULL; + char buffer[1000], *args, *fileName, *bytes; int code, gotPartial, tty, length; int exitCode = 0; Tcl_Channel inChannel, outChannel, errChannel; @@ -178,29 +182,38 @@ Tcl_Main(argc, argv, appInitProc) * eval, since they may have been changed. */ - gotPartial = 0; - Tcl_DStringInit(&command); + commandPtr = Tcl_NewObj(); + Tcl_IncrRefCount(commandPtr); + prompt1NamePtr = Tcl_NewStringObj("tcl_prompt1", -1); + Tcl_IncrRefCount(prompt1NamePtr); + prompt2NamePtr = Tcl_NewStringObj("tcl_prompt2", -1); + Tcl_IncrRefCount(prompt2NamePtr); + inChannel = Tcl_GetStdChannel(TCL_STDIN); outChannel = Tcl_GetStdChannel(TCL_STDOUT); + gotPartial = 0; while (1) { if (tty) { - char *promptCmd; + Tcl_Obj *promptCmdPtr; - promptCmd = Tcl_GetVar(interp, - gotPartial ? "tcl_prompt2" : "tcl_prompt1", TCL_GLOBAL_ONLY); - if (promptCmd == NULL) { -defaultPrompt: + promptCmdPtr = Tcl_ObjGetVar2(interp, + (gotPartial? prompt2NamePtr : prompt1NamePtr), + (Tcl_Obj *) NULL, TCL_GLOBAL_ONLY); + if (promptCmdPtr == NULL) { + defaultPrompt: if (!gotPartial && outChannel) { Tcl_Write(outChannel, "% ", 2); } } else { - code = Tcl_Eval(interp, promptCmd); + code = Tcl_EvalObj(interp, promptCmdPtr); inChannel = Tcl_GetStdChannel(TCL_STDIN); outChannel = Tcl_GetStdChannel(TCL_STDOUT); errChannel = Tcl_GetStdChannel(TCL_STDERR); if (code != TCL_OK) { if (errChannel) { - Tcl_Write(errChannel, interp->result, -1); + resultPtr = Tcl_GetObjResult(interp); + bytes = Tcl_GetStringFromObj(resultPtr, &length); + Tcl_Write(errChannel, bytes, length); Tcl_Write(errChannel, "\n", 1); } Tcl_AddErrorInfo(interp, @@ -215,7 +228,7 @@ defaultPrompt: if (!inChannel) { goto done; } - length = Tcl_Gets(inChannel, &command); + length = Tcl_GetsObj(inChannel, commandPtr); if (length < 0) { goto done; } @@ -224,36 +237,41 @@ defaultPrompt: } /* - * Add the newline removed by Tcl_Gets back to the string. + * Add the newline removed by Tcl_GetsObj back to the string. */ - - (void) Tcl_DStringAppend(&command, "\n", -1); - cmd = Tcl_DStringValue(&command); - if (!Tcl_CommandComplete(cmd)) { + Tcl_AppendToObj(commandPtr, "\n", 1); + if (!TclObjCommandComplete(commandPtr)) { gotPartial = 1; continue; } gotPartial = 0; - code = Tcl_RecordAndEval(interp, cmd, 0); + code = Tcl_RecordAndEvalObj(interp, commandPtr, 0); inChannel = Tcl_GetStdChannel(TCL_STDIN); outChannel = Tcl_GetStdChannel(TCL_STDOUT); errChannel = Tcl_GetStdChannel(TCL_STDERR); - Tcl_DStringFree(&command); + Tcl_SetObjLength(commandPtr, 0); if (code != TCL_OK) { if (errChannel) { - Tcl_Write(errChannel, interp->result, -1); + resultPtr = Tcl_GetObjResult(interp); + bytes = Tcl_GetStringFromObj(resultPtr, &length); + Tcl_Write(errChannel, bytes, length); Tcl_Write(errChannel, "\n", 1); } - } else if (tty && (*interp->result != 0)) { - if (outChannel) { - Tcl_Write(outChannel, interp->result, -1); + } else if (tty) { + resultPtr = Tcl_GetObjResult(interp); + bytes = Tcl_GetStringFromObj(resultPtr, &length); + if ((length > 0) && outChannel) { + Tcl_Write(outChannel, bytes, length); Tcl_Write(outChannel, "\n", 1); } } #ifdef TCL_MEM_DEBUG if (quitFlag) { + Tcl_DecrRefCount(commandPtr); + Tcl_DecrRefCount(prompt1NamePtr); + Tcl_DecrRefCount(prompt2NamePtr); Tcl_DeleteInterp(interp); Tcl_Exit(0); } @@ -266,7 +284,16 @@ defaultPrompt: * cleanup on exit. The Tcl_Eval call should never return. */ -done: + done: + if (commandPtr != NULL) { + Tcl_DecrRefCount(commandPtr); + } + if (prompt1NamePtr != NULL) { + Tcl_DecrRefCount(prompt1NamePtr); + } + if (prompt2NamePtr != NULL) { + Tcl_DecrRefCount(prompt2NamePtr); + } sprintf(buffer, "exit %d", exitCode); Tcl_Eval(interp, buffer); } diff --git a/contrib/tcl/generic/tclMath.h b/contrib/tcl/generic/tclMath.h new file mode 100644 index 0000000..fdf2ac9 --- /dev/null +++ b/contrib/tcl/generic/tclMath.h @@ -0,0 +1,27 @@ +/* + * tclMath.h -- + * + * This file is necessary because of Metrowerks CodeWarrior Pro 1 + * on the Macintosh. With 8-byte doubles turned on, the definitions of + * sin, cos, acos, etc., are screwed up. They are fine as long as + * they are used as function calls, but if the function pointers + * are passed around and used, they will crash hard on the 68K. + * + * Copyright (c) 1997 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclMath.h 1.2 97/07/23 17:39:14 + */ + +#ifndef _TCLMATH +#define _TCLMATH + +#if defined(MAC_TCL) +# include "tclMacMath.h" +#else +# include <math.h> +#endif + +#endif /* _TCLMATH */ diff --git a/contrib/tcl/generic/tclNamesp.c b/contrib/tcl/generic/tclNamesp.c index 2155ddf..d4ace43 100644 --- a/contrib/tcl/generic/tclNamesp.c +++ b/contrib/tcl/generic/tclNamesp.c @@ -18,7 +18,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclNamesp.c 1.21 97/06/20 15:21:04 + * SCCS: @(#) tclNamesp.c 1.29 97/08/04 09:32:38 */ #include "tclInt.h" @@ -456,19 +456,20 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc) /* Procedure called to delete client * data when the namespace is deleted. * NULL if no procedure should be - * called.*/ + * called. */ { Interp *iPtr = (Interp *) interp; register Namespace *nsPtr, *ancestorPtr; Namespace *parentPtr, *dummy1Ptr, *dummy2Ptr; Namespace *globalNsPtr = iPtr->globalNsPtr; + char *simpleName; Tcl_HashEntry *entryPtr; Tcl_DString buffer1, buffer2; int newEntry, result; /* - * Check first if there is no active namespace. If so, we assume - * the interpreter is being initialized. + * If there is no active namespace, the interpreter is being + * initialized. */ if ((globalNsPtr == NULL) && (iPtr->varFramePtr == NULL)) { @@ -478,33 +479,41 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc) */ parentPtr = NULL; - name = ""; + simpleName = ""; + } else if (*name == '\0') { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can't create namespace \"\": only global namespace can have empty name", (char *) NULL); + return NULL; } else { /* - * There is no active namespace. Find the parent namespace that will - * contain the new namespace. + * Find the parent for the new namespace. */ result = TclGetNamespaceForQualName(interp, name, (Namespace *) NULL, /*flags*/ (CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG), - &parentPtr, &dummy1Ptr, &dummy2Ptr, &name); + &parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName); if (result != TCL_OK) { return NULL; } + /* + * If the unqualified name at the end is empty, there were trailing + * "::"s after the namespace's name which we ignore. The new + * namespace was already (recursively) created and is pointed to + * by parentPtr. + */ + + if (*simpleName == '\0') { + return (Tcl_Namespace *) parentPtr; + } + /* * Check for a bad namespace name and make sure that the name * does not already exist in the parent namespace. */ - if ((name == NULL) || (*name == '\0')) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "can't create namespace \"", name, - "\": invalid name", (char *) NULL); - return NULL; - } - if (Tcl_FindHashEntry(&parentPtr->childTable, name) != NULL) { + if (Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't create namespace \"", name, "\": already exists", (char *) NULL); @@ -520,8 +529,8 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc) numNsCreated++; nsPtr = (Namespace *) ckalloc(sizeof(Namespace)); - nsPtr->name = (char *) ckalloc((unsigned) (strlen(name)+1)); - strcpy(nsPtr->name, name); + nsPtr->name = (char *) ckalloc((unsigned) (strlen(simpleName)+1)); + strcpy(nsPtr->name, simpleName); nsPtr->fullName = NULL; /* set below */ nsPtr->clientData = clientData; nsPtr->deleteProc = deleteProc; @@ -540,7 +549,7 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc) nsPtr->cmdRefEpoch = 0; if (parentPtr != NULL) { - entryPtr = Tcl_CreateHashEntry(&parentPtr->childTable, name, + entryPtr = Tcl_CreateHashEntry(&parentPtr->childTable, simpleName, &newEntry); Tcl_SetHashValue(entryPtr, (ClientData) nsPtr); } @@ -703,7 +712,6 @@ TclTeardownNamespace(nsPtr) { Interp *iPtr = (Interp *) nsPtr->interp; register Tcl_HashEntry *entryPtr; - Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_Namespace *childNsPtr; Tcl_Command cmd; @@ -798,16 +806,9 @@ TclTeardownNamespace(nsPtr) /* * Delete all commands in this namespace. Be careful when traversing the * hash table: when each command is deleted, it removes itself from the - * command table. There's a special hack here because "tkerror" is just - * a synonym for "bgerror" (they share a Command structure). Just - * delete the hash table entry for "tkerror" without invoking its - * callback or cleaning up its Command structure. + * command table. */ - hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, "tkerror"); - if (hPtr != NULL) { - Tcl_DeleteHashEntry(hPtr); - } for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); entryPtr != NULL; entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search)) { @@ -889,7 +890,7 @@ NamespaceFree(nsPtr) * * Tcl_Export -- * - * Makes all the commands matching a pattern available to later ber + * Makes all the commands matching a pattern available to later be * imported from the namespace specified by contextNsPtr (or the * current namespace if contextNsPtr is NULL). The specified pattern is * appended onto the namespace's export pattern list, which is @@ -924,7 +925,7 @@ Tcl_Export(interp, namespacePtr, pattern, resetListFirst) * cmd conflicts with an existing one. */ { #define INIT_EXPORT_PATTERNS 5 - Namespace *nsPtr, *exportNsPtr, *altNsPtr, *dummyPtr; + Namespace *nsPtr, *exportNsPtr, *dummyPtr; Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); char *simplePattern, *patternCpy; int neededElems, len, i, result; @@ -961,16 +962,12 @@ Tcl_Export(interp, namespacePtr, pattern, resetListFirst) */ result = TclGetNamespaceForQualName(interp, pattern, nsPtr, - /*flags*/ TCL_LEAVE_ERR_MSG, &exportNsPtr, &altNsPtr, + /*flags*/ TCL_LEAVE_ERR_MSG, &exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if (result != TCL_OK) { return result; } - if (exportNsPtr == NULL) { - exportNsPtr = altNsPtr; - } - if ((exportNsPtr != currNsPtr) - || (strcmp(pattern, simplePattern) != 0)) { + if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "invalid export pattern \"", pattern, "\": pattern can't specify a namespace", @@ -983,23 +980,23 @@ Tcl_Export(interp, namespacePtr, pattern, resetListFirst) * new pattern. */ - neededElems = currNsPtr->numExportPatterns + 1; - if (currNsPtr->exportArrayPtr == NULL) { - currNsPtr->exportArrayPtr = (char **) + neededElems = nsPtr->numExportPatterns + 1; + if (nsPtr->exportArrayPtr == NULL) { + nsPtr->exportArrayPtr = (char **) ckalloc((unsigned) (INIT_EXPORT_PATTERNS * sizeof(char *))); - currNsPtr->numExportPatterns = 0; - currNsPtr->maxExportPatterns = INIT_EXPORT_PATTERNS; - } else if (neededElems > currNsPtr->maxExportPatterns) { - int numNewElems = 2 * currNsPtr->maxExportPatterns; - size_t currBytes = currNsPtr->numExportPatterns * sizeof(char *); + nsPtr->numExportPatterns = 0; + nsPtr->maxExportPatterns = INIT_EXPORT_PATTERNS; + } else if (neededElems > nsPtr->maxExportPatterns) { + int numNewElems = 2 * nsPtr->maxExportPatterns; + size_t currBytes = nsPtr->numExportPatterns * sizeof(char *); size_t newBytes = numNewElems * sizeof(char *); char **newPtr = (char **) ckalloc((unsigned) newBytes); - memcpy((VOID *) newPtr, (VOID *) currNsPtr->exportArrayPtr, + memcpy((VOID *) newPtr, (VOID *) nsPtr->exportArrayPtr, currBytes); - ckfree((char *) currNsPtr->exportArrayPtr); - currNsPtr->exportArrayPtr = (char **) newPtr; - currNsPtr->maxExportPatterns = numNewElems; + ckfree((char *) nsPtr->exportArrayPtr); + nsPtr->exportArrayPtr = (char **) newPtr; + nsPtr->maxExportPatterns = numNewElems; } /* @@ -1010,8 +1007,8 @@ Tcl_Export(interp, namespacePtr, pattern, resetListFirst) patternCpy = (char *) ckalloc((unsigned) (len + 1)); strcpy(patternCpy, pattern); - currNsPtr->exportArrayPtr[currNsPtr->numExportPatterns] = patternCpy; - currNsPtr->numExportPatterns++; + nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy; + nsPtr->numExportPatterns++; return TCL_OK; #undef INIT_EXPORT_PATTERNS } @@ -1111,7 +1108,7 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite) * cmd conflicts with an existing one. */ { Interp *iPtr = (Interp *) interp; - Namespace *nsPtr, *importNsPtr, *dummyPtr, *actualCtxPtr; + Namespace *nsPtr, *importNsPtr, *dummyPtr; Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); char *simplePattern, *cmdName; register Tcl_HashEntry *hPtr; @@ -1145,7 +1142,7 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite) } result = TclGetNamespaceForQualName(interp, pattern, nsPtr, /*flags*/ TCL_LEAVE_ERR_MSG, &importNsPtr, &dummyPtr, - &actualCtxPtr, &simplePattern); + &dummyPtr, &simplePattern); if (result != TCL_OK) { return TCL_ERROR; } @@ -1620,7 +1617,11 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, } else if (flags & TCL_GLOBAL_ONLY) { nsPtr = globalNsPtr; } else if (nsPtr == NULL) { - nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + if (iPtr->varFramePtr != NULL) { + nsPtr = iPtr->varFramePtr->nsPtr; + } else { + nsPtr = iPtr->globalNsPtr; + } } start = qualName; /* pts to start of qualifying namespace */ @@ -1680,7 +1681,7 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, } if ((*end == '\0') - && !((len >= 2) && (*(end-1) == ':') && (*(end-2) == ':'))) { + && !((end-start >= 2) && (*(end-1) == ':') && (*(end-2) == ':'))) { /* * qualName ended with a simple name at start. If FIND_ONLY_NS * was specified, look this up as a namespace. Otherwise, @@ -2337,15 +2338,9 @@ Tcl_NamespaceObjCmd(clientData, interp, objc, objv) * Return an index reflecting the particular subcommand. */ - result = Tcl_GetIndexFromObj((Tcl_Interp *) NULL, objv[1], subCmds, - "subcommand", /*flags*/ 0, (int *) &index); + result = Tcl_GetIndexFromObj((Tcl_Interp *) interp, objv[1], subCmds, + "option", /*flags*/ 0, (int *) &index); if (result != TCL_OK) { - Tcl_ResetResult(interp); - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "bad namespace subcommand \"", - Tcl_GetStringFromObj(objv[1], (int *) NULL), - "\": should be children, code, current, delete, eval, export, forget, import, inscope, origin, parent, qualifiers, tail, or which", - (char *) NULL); return result; } @@ -2452,7 +2447,7 @@ NamespaceChildrenCmd(dummy, interp, objc, objv) } nsPtr = (Namespace *) namespacePtr; } else { - Tcl_WrongNumArgs(interp, 1, objv, "children ?name? ?pattern?"); + Tcl_WrongNumArgs(interp, 2, objv, "?name? ?pattern?"); return TCL_ERROR; } @@ -2539,7 +2534,7 @@ NamespaceCodeCmd(dummy, interp, objc, objv) int length; if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "code arg"); + Tcl_WrongNumArgs(interp, 2, objv, "arg"); return TCL_ERROR; } @@ -2619,7 +2614,7 @@ NamespaceCurrentCmd(dummy, interp, objc, objv) register Namespace *currNsPtr; if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "current"); + Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } @@ -2685,7 +2680,7 @@ NamespaceDeleteCmd(dummy, interp, objc, objv) register int i; if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "delete ?name name...?"); + Tcl_WrongNumArgs(interp, 2, objv, "?name name...?"); return TCL_ERROR; } @@ -2765,7 +2760,7 @@ NamespaceEvalCmd(dummy, interp, objc, objv) int length, result; if (objc < 4) { - Tcl_WrongNumArgs(interp, 1, objv, "eval name arg ?arg...?"); + Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?"); return TCL_ERROR; } @@ -2875,8 +2870,8 @@ NamespaceExportCmd(dummy, interp, objc, objv) int firstArg, patternCt, i, result; if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, - "export ?-clear? ?pattern pattern...?"); + Tcl_WrongNumArgs(interp, 2, objv, + "?-clear? ?pattern pattern...?"); return TCL_ERROR; } @@ -2970,7 +2965,7 @@ NamespaceForgetCmd(dummy, interp, objc, objv) register int i, result; if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "forget ?pattern pattern...?"); + Tcl_WrongNumArgs(interp, 2, objv, "?pattern pattern...?"); return TCL_ERROR; } @@ -3034,8 +3029,8 @@ NamespaceImportCmd(dummy, interp, objc, objv) int firstArg; if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, - "import ?-force? ?pattern pattern...?"); + Tcl_WrongNumArgs(interp, 2, objv, + "?-force? ?pattern pattern...?"); return TCL_ERROR; } @@ -3117,7 +3112,7 @@ NamespaceInscopeCmd(dummy, interp, objc, objv) int i, result; if (objc < 4) { - Tcl_WrongNumArgs(interp, 1, objv, "inscope name arg ?arg...?"); + Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?"); return TCL_ERROR; } @@ -3233,7 +3228,7 @@ NamespaceOriginCmd(dummy, interp, objc, objv) Tcl_Command command, origCommand; if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "origin name"); + Tcl_WrongNumArgs(interp, 2, objv, "name"); return TCL_ERROR; } @@ -3306,7 +3301,7 @@ NamespaceParentCmd(dummy, interp, objc, objv) return TCL_ERROR; } } else { - Tcl_WrongNumArgs(interp, 1, objv, "parent ?name?"); + Tcl_WrongNumArgs(interp, 2, objv, "?name?"); return TCL_ERROR; } @@ -3358,7 +3353,7 @@ NamespaceQualifiersCmd(dummy, interp, objc, objv) int length; if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "qualifiers string"); + Tcl_WrongNumArgs(interp, 2, objv, "string"); return TCL_ERROR; } @@ -3374,7 +3369,7 @@ NamespaceQualifiersCmd(dummy, interp, objc, objv) while (--p >= name) { if ((*p == ':') && (p > name) && (*(p-1) == ':')) { p -= 2; /* back up over the :: */ - while ((*p == ':') && (p >= name)) { + while ((p >= name) && (*p == ':')) { p--; /* back up over the preceeding : */ } break; @@ -3424,7 +3419,7 @@ NamespaceTailCmd(dummy, interp, objc, objv) register char *name, *p; if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "tail string"); + Tcl_WrongNumArgs(interp, 2, objv, "string"); return TCL_ERROR; } @@ -3438,7 +3433,7 @@ NamespaceTailCmd(dummy, interp, objc, objv) /* empty body */ } while (--p > name) { - if ((*p == ':') && (p > name) && (*(p-1) == ':')) { + if ((*p == ':') && (*(p-1) == ':')) { p++; /* just after the last "::" */ break; } @@ -3486,8 +3481,8 @@ NamespaceWhichCmd(dummy, interp, objc, objv) if (objc < 3) { badArgs: - Tcl_WrongNumArgs(interp, 1, objv, - "which ?-command? ?-variable? name"); + Tcl_WrongNumArgs(interp, 2, objv, + "?-command? ?-variable? name"); return TCL_ERROR; } diff --git a/contrib/tcl/generic/tclObj.c b/contrib/tcl/generic/tclObj.c index 5d4afe5..bc697f3 100644 --- a/contrib/tcl/generic/tclObj.c +++ b/contrib/tcl/generic/tclObj.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclObj.c 1.44 97/06/20 15:19:32 + * SCCS: @(#) tclObj.c 1.45 97/07/07 18:26:00 */ #include "tclInt.h" @@ -2019,3 +2019,123 @@ Tcl_GetLongFromObj(interp, objPtr, longPtr) } return result; } + +/* + *---------------------------------------------------------------------- + * + * Tcl_DbIncrRefCount -- + * + * This procedure is normally called when debugging: i.e., when + * TCL_MEM_DEBUG is defined. This checks to see whether or not + * the memory has been freed before incrementing the ref count. + * + * When TCL_MEM_DEBUG is not defined, this procedure just increments + * the reference count of the object. + * + * Results: + * None. + * + * Side effects: + * The object's ref count is incremented. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DbIncrRefCount(objPtr, file, line) + register Tcl_Obj *objPtr; /* The object we are adding a reference to. */ + char *file; /* The name of the source file calling this + * procedure; used for debugging. */ + int line; /* Line number in the source file; used + * for debugging. */ +{ +#ifdef TCL_MEM_DEBUG + if (objPtr->refCount == 0x61616161) { + fprintf(stderr, "file = %s, line = %d\n", file, line); + fflush(stderr); + panic("Trying to increment refCount of previously disposed object."); + } +#endif + ++(objPtr)->refCount; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DbDecrRefCount -- + * + * This procedure is normally called when debugging: i.e., when + * TCL_MEM_DEBUG is defined. This checks to see whether or not + * the memory has been freed before incrementing the ref count. + * + * When TCL_MEM_DEBUG is not defined, this procedure just increments + * the reference count of the object. + * + * Results: + * None. + * + * Side effects: + * The object's ref count is incremented. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DbDecrRefCount(objPtr, file, line) + register Tcl_Obj *objPtr; /* The object we are adding a reference to. */ + char *file; /* The name of the source file calling this + * procedure; used for debugging. */ + int line; /* Line number in the source file; used + * for debugging. */ +{ +#ifdef TCL_MEM_DEBUG + if (objPtr->refCount == 0x61616161) { + fprintf(stderr, "file = %s, line = %d\n", file, line); + fflush(stderr); + panic("Trying to increment refCount of previously disposed object."); + } +#endif + if (--(objPtr)->refCount <= 0) { + TclFreeObj(objPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DbIsShared -- + * + * This procedure is normally called when debugging: i.e., when + * TCL_MEM_DEBUG is defined. This checks to see whether or not + * the memory has been freed before incrementing the ref count. + * + * When TCL_MEM_DEBUG is not defined, this procedure just decrements + * the reference count of the object and throws it away if the count + * is 0 or less. + * + * Results: + * None. + * + * Side effects: + * The object's ref count is incremented. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_DbIsShared(objPtr, file, line) + register Tcl_Obj *objPtr; /* The object we are adding a reference to. */ + char *file; /* The name of the source file calling this + * procedure; used for debugging. */ + int line; /* Line number in the source file; used + * for debugging. */ +{ +#ifdef TCL_MEM_DEBUG + if (objPtr->refCount == 0x61616161) { + fprintf(stderr, "file = %s, line = %d\n", file, line); + fflush(stderr); + panic("Trying to increment refCount of previously disposed object."); + } +#endif + return ((objPtr)->refCount > 1); +} diff --git a/contrib/tcl/generic/tclParse.c b/contrib/tcl/generic/tclParse.c index 57ba1e1..69a9e00 100644 --- a/contrib/tcl/generic/tclParse.c +++ b/contrib/tcl/generic/tclParse.c @@ -6,12 +6,12 @@ * strings or nested sub-commands). * * Copyright (c) 1987-1993 The Regents of the University of California. - * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * Copyright (c) 1994-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclParse.c 1.55 97/05/14 13:23:19 + * SCCS: @(#) tclParse.c 1.56 97/07/29 18:40:03 */ #include "tclInt.h" @@ -902,3 +902,37 @@ Tcl_CommandComplete(cmd) p = ScriptEnd(cmd, cmd+strlen(cmd), 0); return (*p != 0); } + +/* + *---------------------------------------------------------------------- + * + * TclObjCommandComplete -- + * + * Given a partial or complete Tcl command in a Tcl object, this + * procedure determines whether the command is complete in the sense of + * having matched braces and quotes and brackets. + * + * Results: + * 1 is returned if the command is complete, 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclObjCommandComplete(cmdPtr) + Tcl_Obj *cmdPtr; /* Points to object holding command + * to check. */ +{ + char *cmd, *p; + int length; + + cmd = Tcl_GetStringFromObj(cmdPtr, &length); + if (length == 0) { + return 1; + } + p = ScriptEnd(cmd, cmd+length, /*nested*/ 0); + return (*p != 0); +} diff --git a/contrib/tcl/generic/tclProc.c b/contrib/tcl/generic/tclProc.c index 14238d9..7cd94ec 100644 --- a/contrib/tcl/generic/tclProc.c +++ b/contrib/tcl/generic/tclProc.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclProc.c 1.113 97/06/23 15:51:52 + * SCCS: @(#) tclProc.c 1.115 97/08/12 13:36:11 */ #include "tclInt.h" @@ -56,6 +56,7 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) char **argArray = NULL; Namespace *nsPtr, *altNsPtr, *cxtNsPtr; Tcl_Obj *defPtr, *bodyPtr; + Tcl_Command cmd; Tcl_DString ds; int numArgs, length, result, i; register CompiledLocal *localPtr; @@ -120,8 +121,11 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) } /* - * We increment the ref count of the procedure's body object since - * there will be a reference to it in the Proc structure. + * Create and initialize a Proc structure for the procedure. Note that + * we initialize its cmdPtr field below after we've created the command + * for the procedure. We increment the ref count of the procedure's + * body object since there will be a reference to it in the Proc + * structure. */ Tcl_IncrRefCount(bodyPtr); @@ -129,7 +133,6 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) procPtr = (Proc *) ckalloc(sizeof(Proc)); procPtr->iPtr = iPtr; procPtr->refCount = 1; - procPtr->nsPtr = nsPtr; procPtr->bodyPtr = bodyPtr; procPtr->numArgs = 0; /* actual argument count is set below. */ procPtr->numCompiledLocals = 0; @@ -243,10 +246,10 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) } /* - * Now create a command for the procedure. This will be in the current - * namespace unless the procedure's name included namespace qualifiers. - * To create the new command in the right namespace, we generate a - * fully qualified name for it. + * Now create a command for the procedure. This will initially be in + * the current namespace unless the procedure's name included namespace + * qualifiers. To create the new command in the right namespace, we + * generate a fully qualified name for it. */ Tcl_DStringInit(&ds); @@ -258,8 +261,18 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) Tcl_CreateCommand(interp, Tcl_DStringValue(&ds), InterpProc, (ClientData) procPtr, ProcDeleteProc); - Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds), TclObjInterpProc, - (ClientData) procPtr, ProcDeleteProc); + cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds), + TclObjInterpProc, (ClientData) procPtr, ProcDeleteProc); + + /* + * Now initialize the new procedure's cmdPtr field. This will be used + * later when the procedure is called to determine what namespace the + * procedure will run in. This will be different than the current + * namespace if the proc was renamed into a different namespace. + */ + + procPtr->cmdPtr = (Command *) cmd; + ckfree((char *) argArray); return TCL_OK; @@ -744,11 +757,14 @@ TclObjInterpProc(clientData, interp, objc, objv) /* * Set up and push a new call frame for the new procedure invocation. * This call frame will execute in the proc's namespace, which might - * be different than the current namespace. + * be different than the current namespace. The proc's namespace is + * that of its command, which can change if the command is renamed + * from one namespace to another. */ result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr, - (Tcl_Namespace *) procPtr->nsPtr, /*isProcCallFrame*/ 1); + (Tcl_Namespace *) procPtr->cmdPtr->nsPtr, + /*isProcCallFrame*/ 1); if (result != TCL_OK) { return result; } @@ -768,7 +784,7 @@ TclObjInterpProc(clientData, interp, objc, objv) localPtr = localPtr->nextPtr) { varPtr->value.objPtr = NULL; varPtr->name = localPtr->name; /* will be just '\0' if temp var */ - varPtr->nsPtr = procPtr->nsPtr; + varPtr->nsPtr = procPtr->cmdPtr->nsPtr; varPtr->hPtr = NULL; varPtr->refCount = 0; varPtr->tracePtr = NULL; @@ -826,6 +842,7 @@ TclObjInterpProc(clientData, interp, objc, objv) Tcl_IncrRefCount(objPtr); /* since the local variable now has * another reference to object. */ } else { + Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "no value given for parameter \"", localPtr->name, "\" to \"", Tcl_GetStringFromObj(objv[0], (int *) NULL), diff --git a/contrib/tcl/generic/tclStringObj.c b/contrib/tcl/generic/tclStringObj.c index e421833..beed142 100644 --- a/contrib/tcl/generic/tclStringObj.c +++ b/contrib/tcl/generic/tclStringObj.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclStringObj.c 1.29 97/06/13 18:17:19 + * SCCS: @(#) tclStringObj.c 1.30 97/07/24 18:53:30 */ #include "tclInt.h" @@ -98,7 +98,7 @@ Tcl_NewStringObj(bytes, length) register Tcl_Obj *objPtr; if (length < 0) { - length = strlen(bytes); + length = bytes ? strlen(bytes) : 0 ; } TclNewObj(objPtr); TclInitStringRep(objPtr, bytes, length); diff --git a/contrib/tcl/generic/tclTest.c b/contrib/tcl/generic/tclTest.c index 7ee313b..ecc2abf 100644 --- a/contrib/tcl/generic/tclTest.c +++ b/contrib/tcl/generic/tclTest.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclTest.c 1.111 97/06/26 14:33:03 + * SCCS: @(#) tclTest.c 1.115 97/08/13 10:27:26 */ #define TCL_TEST @@ -84,6 +84,10 @@ static int CmdProc1 _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); static int CmdProc2 _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); +static void CmdTraceProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int level, char *command, + Tcl_CmdProc *cmdProc, ClientData cmdClientData, + int argc, char **argv)); static int CreatedCommandProc _ANSI_ARGS_(( ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); @@ -111,6 +115,8 @@ static int TestcmdinfoCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); static int TestcmdtokenCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); +static int TestcmdtraceCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); static int TestchmodCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); static int TestcreatecommandCmd _ANSI_ARGS_((ClientData dummy, @@ -127,6 +133,8 @@ static int TestexithandlerCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); static int TestexprlongCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); +static int TestexprstringCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); static int TestfileCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); static int TestfeventCmd _ANSI_ARGS_((ClientData dummy, @@ -225,6 +233,8 @@ Tcltest_Init(interp) (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testcmdinfo", TestcmdinfoCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testcmdtrace", TestcmdtraceCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testcreatecommand", TestcreatecommandCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testdcall", TestdcallCmd, (ClientData) 0, @@ -240,6 +250,8 @@ Tcltest_Init(interp) (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testexprlong", TestexprlongCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testexprstring", TestexprstringCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testfile", TestfileCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testgetassocdata", TestgetassocdataCmd, @@ -626,6 +638,85 @@ TestcmdtokenCmd(dummy, interp, argc, argv) /* *---------------------------------------------------------------------- * + * TestcmdtraceCmd -- + * + * This procedure implements the "testcmdtrace" command. It is used + * to test Tcl_CreateTrace and Tcl_DeleteTrace. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates and deletes a command trace, and tests the invocation of + * a procedure by the command trace. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestcmdtraceCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Trace trace; + Tcl_DString buffer; + int result; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " script\"", (char *) NULL); + return TCL_ERROR; + } + + Tcl_DStringInit(&buffer); + trace = Tcl_CreateTrace(interp, 50000, + (Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer); + + result = Tcl_Eval(interp, argv[1]); + if (result == TCL_OK) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL); + } + + Tcl_DeleteTrace(interp, trace); + Tcl_DStringFree(&buffer); + return TCL_OK; +} + +static void +CmdTraceProc(clientData, interp, level, command, cmdProc, cmdClientData, + argc, argv) + ClientData clientData; /* Pointer to buffer in which the + * command and arguments are appended. + * Accumulates test result. */ + Tcl_Interp *interp; /* Current interpreter. */ + int level; /* Current trace level. */ + char *command; /* The command being traced (after + * substitutions). */ + Tcl_CmdProc *cmdProc; /* Points to command's command procedure. */ + ClientData cmdClientData; /* Client data associated with command + * procedure. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_DString *bufPtr = (Tcl_DString *) clientData; + int i; + + Tcl_DStringAppendElement(bufPtr, command); + + Tcl_DStringStartSublist(bufPtr); + for (i = 0; i < argc; i++) { + Tcl_DStringAppendElement(bufPtr, argv[i]); + } + Tcl_DStringEndSublist(bufPtr); +} + +/* + *---------------------------------------------------------------------- + * * TestcreatecommandCmd -- * * This procedure implements the "testcreatecommand" command. It is @@ -1133,6 +1224,37 @@ TestexprlongCmd(clientData, interp, argc, argv) /* *---------------------------------------------------------------------- * + * TestexprstringCmd -- + * + * This procedure tests the basic operation of Tcl_ExprString. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestexprstringCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " expression\"", (char *) NULL); + return TCL_ERROR; + } + return Tcl_ExprString(interp, argv[1]); +} + +/* + *---------------------------------------------------------------------- + * * TestgetassocdataCmd -- * * This procedure implements the "testgetassocdata" command. It is diff --git a/contrib/tcl/generic/tclTimer.c b/contrib/tcl/generic/tclTimer.c index 2a91f65..7bb8e7d 100644 --- a/contrib/tcl/generic/tclTimer.c +++ b/contrib/tcl/generic/tclTimer.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclTimer.c 1.6 97/05/20 11:08:02 + * SCCS: @(#) tclTimer.c 1.9 97/07/29 16:21:53 */ #include "tclInt.h" @@ -692,7 +692,7 @@ TclServiceIdle() /* *---------------------------------------------------------------------- * - * Tcl_AfterCmd -- + * Tcl_AfterObjCmd -- * * This procedure is invoked to process the "after" Tcl command. * See the user documentation for details on what it does. @@ -708,13 +708,13 @@ TclServiceIdle() /* ARGSUSED */ int -Tcl_AfterCmd(clientData, interp, argc, argv) +Tcl_AfterObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Points to the "tclAfter" assocData for * this interpreter, or NULL if the assocData * hasn't been created yet.*/ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { /* * The variable below is used to generate unique identifiers for @@ -731,11 +731,15 @@ Tcl_AfterCmd(clientData, interp, argc, argv) AfterInfo *afterPtr; AfterAssocData *assocPtr = (AfterAssocData *) clientData; Tcl_CmdInfo cmdInfo; - size_t length; - - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " option ?arg arg ...?\"", (char *) NULL); + int length; + char *arg; + int index, result; + static char *subCmds[] = { + "cancel", "idle", "info", + (char *) NULL}; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); return TCL_ERROR; } @@ -752,39 +756,44 @@ Tcl_AfterCmd(clientData, interp, argc, argv) assocPtr->firstAfterPtr = NULL; Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc, (ClientData) assocPtr); - cmdInfo.proc = Tcl_AfterCmd; - cmdInfo.clientData = (ClientData) assocPtr; - cmdInfo.objProc = NULL; - cmdInfo.objClientData = (ClientData) NULL; + cmdInfo.proc = NULL; + cmdInfo.clientData = (ClientData) NULL; + cmdInfo.objProc = Tcl_AfterObjCmd; + cmdInfo.objClientData = (ClientData) assocPtr; cmdInfo.deleteProc = NULL; cmdInfo.deleteData = (ClientData) assocPtr; - Tcl_SetCommandInfo(interp, argv[0], &cmdInfo); + Tcl_SetCommandInfo(interp, Tcl_GetStringFromObj(objv[0], &length), + &cmdInfo); } /* - * Parse the command. + * First lets see if the command was passed a number as the first argument. */ - - length = strlen(argv[1]); - if (isdigit(UCHAR(argv[1][0]))) { - if (Tcl_GetInt(interp, argv[1], &ms) != TCL_OK) { + + arg = Tcl_GetStringFromObj(objv[1], &length); + if (isdigit(UCHAR(arg[0]))) { + if (Tcl_GetIntFromObj(interp, objv[1], &ms) != TCL_OK) { return TCL_ERROR; } if (ms < 0) { ms = 0; } - if (argc == 2) { + if (objc == 2) { Tcl_Sleep(ms); return TCL_OK; } afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo))); afterPtr->assocPtr = assocPtr; - if (argc == 3) { - afterPtr->command = (char *) ckalloc((unsigned) - (strlen(argv[2]) + 1)); - strcpy(afterPtr->command, argv[2]); + if (objc == 3) { + arg = Tcl_GetStringFromObj(objv[2], &length); + afterPtr->command = (char *) ckalloc((unsigned) (length + 1)); + strcpy(afterPtr->command, arg); } else { - afterPtr->command = Tcl_Concat(argc-2, argv+2); + Tcl_Obj *objPtr = Tcl_ConcatObj(objc-2, objv+2); + arg = Tcl_GetStringFromObj(objPtr, &length); + afterPtr->command = (char *) ckalloc((unsigned) (length + 1)); + strcpy(afterPtr->command, arg); + Tcl_DecrRefCount(objPtr); } afterPtr->id = nextId; nextId += 1; @@ -793,95 +802,113 @@ Tcl_AfterCmd(clientData, interp, argc, argv) afterPtr->nextPtr = assocPtr->firstAfterPtr; assocPtr->firstAfterPtr = afterPtr; sprintf(interp->result, "after#%d", afterPtr->id); - } else if (strncmp(argv[1], "cancel", length) == 0) { - char *arg; + return TCL_OK; + } - if (argc < 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " cancel id|command\"", (char *) NULL); - return TCL_ERROR; - } - if (argc == 3) { - arg = argv[2]; - } else { - arg = Tcl_Concat(argc-2, argv+2); - } - for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; - afterPtr = afterPtr->nextPtr) { - if (strcmp(afterPtr->command, arg) == 0) { + /* + * If it's not a number it must be a subcommand. + */ + result = Tcl_GetIndexFromObj(NULL, objv[1], subCmds, "option", + 0, (int *) &index); + if (result != TCL_OK) { + Tcl_AppendResult(interp, "bad argument \"", arg, + "\": must be cancel, idle, info, or a number", + (char *) NULL); + return TCL_ERROR; + } + + switch (index) { + case 0: /* cancel */ + { + char *arg; + Tcl_Obj *objPtr = NULL; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "id|command"); + return TCL_ERROR; + } + if (objc == 3) { + arg = Tcl_GetStringFromObj(objv[2], &length); + } else { + objPtr = Tcl_ConcatObj(objc-2, objv+2);; + arg = Tcl_GetStringFromObj(objPtr, &length); + } + for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; + afterPtr = afterPtr->nextPtr) { + if (strcmp(afterPtr->command, arg) == 0) { + break; + } + } + if (afterPtr == NULL) { + afterPtr = GetAfterEvent(assocPtr, arg); + } + if (objPtr != NULL) { + Tcl_DecrRefCount(objPtr); + } + if (afterPtr != NULL) { + if (afterPtr->token != NULL) { + Tcl_DeleteTimerHandler(afterPtr->token); + } else { + Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr); + } + FreeAfterPtr(afterPtr); + } break; } - } - if (afterPtr == NULL) { - afterPtr = GetAfterEvent(assocPtr, arg); - } - if (arg != argv[2]) { - ckfree(arg); - } - if (afterPtr != NULL) { - if (afterPtr->token != NULL) { - Tcl_DeleteTimerHandler(afterPtr->token); + case 1: /* idle */ + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "script script ..."); + return TCL_ERROR; + } + afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo))); + afterPtr->assocPtr = assocPtr; + if (objc == 3) { + arg = Tcl_GetStringFromObj(objv[2], &length); + afterPtr->command = (char *) ckalloc((unsigned) length + 1); + strcpy(afterPtr->command, arg); } else { - Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr); + Tcl_Obj *objPtr = Tcl_ConcatObj(objc-2, objv+2);; + arg = Tcl_GetStringFromObj(objPtr, &length); + afterPtr->command = (char *) ckalloc((unsigned) (length + 1)); + strcpy(afterPtr->command, arg); + Tcl_DecrRefCount(objPtr); } - FreeAfterPtr(afterPtr); - } - } else if ((strncmp(argv[1], "idle", length) == 0) - && (length >= 2)) { - if (argc < 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " idle script script ...\"", (char *) NULL); - return TCL_ERROR; - } - afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo))); - afterPtr->assocPtr = assocPtr; - if (argc == 3) { - afterPtr->command = (char *) ckalloc((unsigned) - (strlen(argv[2]) + 1)); - strcpy(afterPtr->command, argv[2]); - } else { - afterPtr->command = Tcl_Concat(argc-2, argv+2); - } - afterPtr->id = nextId; - nextId += 1; - afterPtr->token = NULL; - afterPtr->nextPtr = assocPtr->firstAfterPtr; - assocPtr->firstAfterPtr = afterPtr; - Tcl_DoWhenIdle(AfterProc, (ClientData) afterPtr); - sprintf(interp->result, "after#%d", afterPtr->id); - } else if ((strncmp(argv[1], "info", length) == 0) - && (length >= 2)) { - if (argc == 2) { - char buffer[30]; + afterPtr->id = nextId; + nextId += 1; + afterPtr->token = NULL; + afterPtr->nextPtr = assocPtr->firstAfterPtr; + assocPtr->firstAfterPtr = afterPtr; + Tcl_DoWhenIdle(AfterProc, (ClientData) afterPtr); + sprintf(interp->result, "after#%d", afterPtr->id); + break; + case 2: /* info */ + if (objc == 2) { + char buffer[30]; - for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; - afterPtr = afterPtr->nextPtr) { - if (assocPtr->interp == interp) { - sprintf(buffer, "after#%d", afterPtr->id); - Tcl_AppendElement(interp, buffer); + for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; + afterPtr = afterPtr->nextPtr) { + if (assocPtr->interp == interp) { + sprintf(buffer, "after#%d", afterPtr->id); + Tcl_AppendElement(interp, buffer); + } } + return TCL_OK; } - return TCL_OK; - } - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " info ?id?\"", (char *) NULL); - return TCL_ERROR; - } - afterPtr = GetAfterEvent(assocPtr, argv[2]); - if (afterPtr == NULL) { - Tcl_AppendResult(interp, "event \"", argv[2], - "\" doesn't exist", (char *) NULL); - return TCL_ERROR; - } - Tcl_AppendElement(interp, afterPtr->command); - Tcl_AppendElement(interp, - (afterPtr->token == NULL) ? "idle" : "timer"); - } else { - Tcl_AppendResult(interp, "bad argument \"", argv[1], - "\": must be cancel, idle, info, or a number", - (char *) NULL); - return TCL_ERROR; + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?id?"); + return TCL_ERROR; + } + arg = Tcl_GetStringFromObj(objv[2], &length); + afterPtr = GetAfterEvent(assocPtr, arg); + if (afterPtr == NULL) { + Tcl_AppendResult(interp, "event \"", arg, + "\" doesn't exist", (char *) NULL); + return TCL_ERROR; + } + Tcl_AppendElement(interp, afterPtr->command); + Tcl_AppendElement(interp, + (afterPtr->token == NULL) ? "idle" : "timer"); + break; } return TCL_OK; } diff --git a/contrib/tcl/generic/tclUtil.c b/contrib/tcl/generic/tclUtil.c index 2eca40c..e43482f 100644 --- a/contrib/tcl/generic/tclUtil.c +++ b/contrib/tcl/generic/tclUtil.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclUtil.c 1.154 97/06/26 13:49:14 + * SCCS: @(#) tclUtil.c 1.161 97/08/12 17:07:18 */ #include "tclInt.h" @@ -38,6 +38,23 @@ #define BRACES_UNMATCHED 4 /* + * The following values determine the precision used when converting + * floating-point values to strings. This information is linked to all + * of the tcl_precision variables in all interpreters via the procedure + * TclPrecTraceProc. + * + * NOTE: these variables are not thread-safe. + */ + +static char precisionString[10] = "12"; + /* The string value of all the tcl_precision + * variables. */ +static char precisionFormat[10] = "%.12g"; + /* The format string actually used in calls + * to sprintf. */ + + +/* * Function prototypes for local procedures in this file: */ @@ -99,7 +116,7 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr, * to indicate that arg was/wasn't * in braces. */ { - register char *p = list; + char *p = list; char *elemStart; /* Points to first byte of first element. */ char *limit; /* Points just after list's last byte. */ int openBraces = 0; /* Brace nesting level during parse. */ @@ -313,10 +330,10 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr, int TclCopyAndCollapse(count, src, dst) int count; /* Number of characters to copy from src. */ - register char *src; /* Copy from here... */ - register char *dst; /* ... to here. */ + char *src; /* Copy from here... */ + char *dst; /* ... to here. */ { - register char c; + char c; int numRead; int newCount = 0; @@ -378,7 +395,7 @@ Tcl_SplitList(interp, list, argcPtr, argvPtr) * array of pointers to list elements. */ { char **argv; - register char *p; + char *p; int length, size, i, result, elSize, brace; char *element; @@ -422,7 +439,7 @@ Tcl_SplitList(interp, list, argcPtr, argvPtr) } argv[i] = p; if (brace) { - (void) strncpy(p, element, (size_t) elSize); + memcpy((VOID *) p, (VOID *) element, (size_t) elSize); p += elSize; *p = 0; p++; @@ -463,7 +480,7 @@ Tcl_SplitList(interp, list, argcPtr, argvPtr) int Tcl_ScanElement(string, flagPtr) - char *string; /* String to convert to Tcl list element. */ + CONST char *string; /* String to convert to Tcl list element. */ int *flagPtr; /* Where to store information to guide * Tcl_ConvertCountedElement. */ { @@ -497,14 +514,13 @@ Tcl_ScanElement(string, flagPtr) int Tcl_ScanCountedElement(string, length, flagPtr) - char *string; /* String to convert to Tcl list element. */ + CONST char *string; /* String to convert to Tcl list element. */ int length; /* Number of bytes in string, or -1. */ int *flagPtr; /* Where to store information to guide * Tcl_ConvertElement. */ { int flags, nestingLevel; - register char *p; - char *lastChar; + CONST char *p, *lastChar; /* * This procedure and Tcl_ConvertElement together do two things: @@ -632,7 +648,7 @@ Tcl_ScanCountedElement(string, length, flagPtr) int Tcl_ConvertElement(src, dst, flags) - register char *src; /* Source information for list element. */ + CONST char *src; /* Source information for list element. */ char *dst; /* Place to put list-ified element. */ int flags; /* Flags produced by Tcl_ScanElement. */ { @@ -664,13 +680,13 @@ Tcl_ConvertElement(src, dst, flags) int Tcl_ConvertCountedElement(src, length, dst, flags) - register char *src; /* Source information for list element. */ + CONST char *src; /* Source information for list element. */ int length; /* Number of bytes in src, or -1. */ char *dst; /* Place to put list-ified element. */ int flags; /* Flags produced by Tcl_ScanElement. */ { - register char *p = dst; - char *lastChar; + char *p = dst; + CONST char *lastChar; /* * See the comment block at the beginning of the Tcl_ScanElement @@ -807,7 +823,7 @@ Tcl_Merge(argc, argv) int localFlags[LOCAL_SIZE], *flagPtr; int numChars; char *result; - register char *dst; + char *dst; int i; /* @@ -873,7 +889,7 @@ Tcl_Concat(argc, argv) char **argv; /* Array of strings to concatenate. */ { int totalSize, i; - register char *p; + char *p; char *result; for (totalSize = 1, i = 0; i < argc; i++) { @@ -899,14 +915,15 @@ Tcl_Concat(argc, argv) element++; } for (length = strlen(element); - (length > 0) && (isspace(UCHAR(element[length-1]))); + (length > 0) && (isspace(UCHAR(element[length-1]))) + && ((length < 2) || (element[length-2] != '\\')); length--) { /* Null loop body. */ } if (length == 0) { continue; } - (void) strncpy(p, element, (size_t) length); + memcpy((VOID *) p, (VOID *) element, (size_t) length); p += length; *p = ' '; p++; @@ -943,10 +960,10 @@ Tcl_ConcatObj(objc, objv) Tcl_Obj *CONST objv[]; /* Array of objects to concatenate. */ { int allocSize, finalSize, length, elemLength, i; - register char *p; - register char *element; + char *p; + char *element; char *concatStr; - register Tcl_Obj *objPtr; + Tcl_Obj *objPtr; allocSize = 0; for (i = 0; i < objc; i++) { @@ -986,8 +1003,16 @@ Tcl_ConcatObj(objc, objv) element++; elemLength--; } + + /* + * Trim trailing white space. But, be careful not to trim + * a space character if it is preceded by a backslash: in + * this case it could be significant. + */ + while ((elemLength > 0) - && isspace(UCHAR(element[elemLength-1]))) { + && isspace(UCHAR(element[elemLength-1])) + && ((elemLength < 2) || (element[elemLength-2] != '\\'))) { elemLength--; } if (elemLength == 0) { @@ -1034,9 +1059,9 @@ Tcl_ConcatObj(objc, objv) int Tcl_StringMatch(string, pattern) - register char *string; /* String. */ - register char *pattern; /* Pattern, which may contain - * special characters. */ + char *string; /* String. */ + char *pattern; /* Pattern, which may contain special + * characters. */ { char c2; @@ -1171,13 +1196,13 @@ void Tcl_SetResult(interp, string, freeProc) Tcl_Interp *interp; /* Interpreter with which to associate the * return value. */ - register char *string; /* Value to be returned. If NULL, - * the result is set to an empty string. */ + char *string; /* Value to be returned. If NULL, the + * result is set to an empty string. */ Tcl_FreeProc *freeProc; /* Gives information about the string: * TCL_STATIC, TCL_VOLATILE, or the address * of a Tcl_FreeProc such as free. */ { - register Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *) interp; int length; Tcl_FreeProc *oldFreeProc = iPtr->freeProc; char *oldResult = iPtr->result; @@ -1242,7 +1267,7 @@ Tcl_SetResult(interp, string, freeProc) char * Tcl_GetStringResult(interp) - register Tcl_Interp *interp; /* Interpreter whose result to return. */ + Tcl_Interp *interp; /* Interpreter whose result to return. */ { /* * If the string result is empty, move the object result to the @@ -1282,12 +1307,12 @@ void Tcl_SetObjResult(interp, objPtr) Tcl_Interp *interp; /* Interpreter with which to associate the * return object value. */ - register Tcl_Obj *objPtr; /* Tcl object to be returned. If NULL, the + Tcl_Obj *objPtr; /* Tcl object to be returned. If NULL, the * obj result is made an empty string * object. */ { - register Interp *iPtr = (Interp *) interp; - register Tcl_Obj *oldObjResult = iPtr->objResultPtr; + Interp *iPtr = (Interp *) interp; + Tcl_Obj *oldObjResult = iPtr->objResultPtr; iPtr->objResultPtr = objPtr; Tcl_IncrRefCount(objPtr); /* since interp result is a reference */ @@ -1341,9 +1366,9 @@ Tcl_Obj * Tcl_GetObjResult(interp) Tcl_Interp *interp; /* Interpreter whose result to return. */ { - register Interp *iPtr = (Interp *) interp; - register Tcl_Obj *objResultPtr; - register int length; + Interp *iPtr = (Interp *) interp; + Tcl_Obj *objResultPtr; + int length; /* * If the string result is non-empty, move the string result to the @@ -1398,8 +1423,8 @@ void Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1) { va_list argList; - register Interp *iPtr; - register char *string; + Interp *iPtr; + char *string; int newSpace; /* @@ -1488,9 +1513,9 @@ Tcl_AppendElement(interp, string) char *string; /* String to convert to list element and * add to result. */ { - register Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *) interp; char *dst; - register int size; + int size; int flags; /* @@ -1552,7 +1577,7 @@ Tcl_AppendElement(interp, string) static void SetupAppendBuffer(iPtr, newSpace) - register Interp *iPtr; /* Interpreter whose result is being set up. */ + Interp *iPtr; /* Interpreter whose result is being set up. */ int newSpace; /* Make sure that at least this many bytes * of new information may be added. */ { @@ -1635,9 +1660,9 @@ SetupAppendBuffer(iPtr, newSpace) void Tcl_FreeResult(interp) - register Tcl_Interp *interp; /* Interpreter for which to free result. */ + Tcl_Interp *interp; /* Interpreter for which to free result. */ { - register Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *) interp; if (iPtr->freeProc != NULL) { if ((iPtr->freeProc == TCL_DYNAMIC) @@ -1676,7 +1701,7 @@ void Tcl_ResetResult(interp) Tcl_Interp *interp; /* Interpreter for which to clear result. */ { - register Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *) interp; TclResetObjResult(iPtr); @@ -1805,7 +1830,7 @@ Tcl_RegExpCompile(interp, string) char *string; /* String for which to produce * compiled regular expression. */ { - register Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *) interp; int i, length; regexp *result; @@ -2009,8 +2034,7 @@ Tcl_RegExpMatch(interp, string, pattern) void Tcl_DStringInit(dsPtr) - register Tcl_DString *dsPtr; /* Pointer to structure for - * dynamic string. */ + Tcl_DString *dsPtr; /* Pointer to structure for dynamic string. */ { dsPtr->string = dsPtr->staticSpace; dsPtr->length = 0; @@ -2038,17 +2062,16 @@ Tcl_DStringInit(dsPtr) char * Tcl_DStringAppend(dsPtr, string, length) - register Tcl_DString *dsPtr; /* Structure describing dynamic - * string. */ - char *string; /* String to append. If length is - * -1 then this must be - * null-terminated. */ - int length; /* Number of characters from string - * to append. If < 0, then append all - * of string, up to null at end. */ + Tcl_DString *dsPtr; /* Structure describing dynamic string. */ + CONST char *string; /* String to append. If length is -1 then + * this must be null-terminated. */ + int length; /* Number of characters from string to + * append. If < 0, then append all of string, + * up to null at end. */ { int newSize; - char *newString, *dst, *end; + char *newString, *dst; + CONST char *end; if (length < 0) { length = strlen(string); @@ -2081,7 +2104,7 @@ Tcl_DStringAppend(dsPtr, string, length) string < end; string++, dst++) { *dst = *string; } - *dst = 0; + *dst = '\0'; dsPtr->length += length; return dsPtr->string; } @@ -2106,10 +2129,9 @@ Tcl_DStringAppend(dsPtr, string, length) char * Tcl_DStringAppendElement(dsPtr, string) - register Tcl_DString *dsPtr; /* Structure describing dynamic - * string. */ - char *string; /* String to append. Must be - * null-terminated. */ + Tcl_DString *dsPtr; /* Structure describing dynamic string. */ + CONST char *string; /* String to append. Must be + * null-terminated. */ { int newSize, flags; char *dst, *newString; @@ -2173,9 +2195,8 @@ Tcl_DStringAppendElement(dsPtr, string) void Tcl_DStringSetLength(dsPtr, length) - register Tcl_DString *dsPtr; /* Structure describing dynamic - * string. */ - int length; /* New length for dynamic string. */ + Tcl_DString *dsPtr; /* Structure describing dynamic string. */ + int length; /* New length for dynamic string. */ { if (length < 0) { length = 0; @@ -2223,8 +2244,7 @@ Tcl_DStringSetLength(dsPtr, length) void Tcl_DStringFree(dsPtr) - register Tcl_DString *dsPtr; /* Structure describing dynamic - * string. */ + Tcl_DString *dsPtr; /* Structure describing dynamic string. */ { if (dsPtr->string != dsPtr->staticSpace) { ckfree(dsPtr->string); @@ -2257,10 +2277,9 @@ Tcl_DStringFree(dsPtr) void Tcl_DStringResult(interp, dsPtr) - Tcl_Interp *interp; /* Interpreter whose result is to be - * reset. */ - register Tcl_DString *dsPtr; /* Dynamic string that is to become - * the result of interp. */ + Tcl_Interp *interp; /* Interpreter whose result is to be reset. */ + Tcl_DString *dsPtr; /* Dynamic string that is to become the + * result of interp. */ { Tcl_ResetResult(interp); @@ -2302,12 +2321,11 @@ Tcl_DStringResult(interp, dsPtr) void Tcl_DStringGetResult(interp, dsPtr) - Tcl_Interp *interp; /* Interpreter whose result is to be - * reset. */ - register Tcl_DString *dsPtr; /* Dynamic string that is to become the - * result of interp. */ + Tcl_Interp *interp; /* Interpreter whose result is to be reset. */ + Tcl_DString *dsPtr; /* Dynamic string that is to become the + * result of interp. */ { - register Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *) interp; if (dsPtr->string != dsPtr->staticSpace) { ckfree(dsPtr->string); @@ -2438,9 +2456,9 @@ Tcl_PrintDouble(interp, value, dst) * must have at least TCL_DOUBLE_SPACE * characters. */ { - register char *p; + char *p; - sprintf(dst, "%.17g", value); + sprintf(dst, precisionFormat, value); /* * If the ASCII result looks like an integer, add ".0" so that it @@ -2461,6 +2479,92 @@ Tcl_PrintDouble(interp, value, dst) /* *---------------------------------------------------------------------- * + * TclPrecTraceProc -- + * + * This procedure is invoked whenever the variable "tcl_precision" + * is written. + * + * Results: + * Returns NULL if all went well, or an error message if the + * new value for the variable doesn't make sense. + * + * Side effects: + * If the new value doesn't make sense then this procedure + * undoes the effect of the variable modification. Otherwise + * it modifies the format string that's used by Tcl_PrintDouble. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +char * +TclPrecTraceProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *name1; /* Name of variable. */ + char *name2; /* Second part of variable name. */ + int flags; /* Information about what happened. */ +{ + char *value, *end; + int prec; + + /* + * If the variable is unset, then recreate the trace. + */ + + if (flags & TCL_TRACE_UNSETS) { + if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) { + Tcl_TraceVar2(interp, name1, name2, + TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES + |TCL_TRACE_UNSETS, TclPrecTraceProc, clientData); + } + return (char *) NULL; + } + + /* + * When the variable is read, reset its value from our shared + * value. This is needed in case the variable was modified in + * some other interpreter so that this interpreter's value is + * out of date. + */ + + if (flags & TCL_TRACE_READS) { + Tcl_SetVar2(interp, name1, name2, precisionString, + flags & TCL_GLOBAL_ONLY); + return (char *) NULL; + } + + /* + * The variable is being written. Check the new value and disallow + * it if it isn't reasonable or if this is a safe interpreter (we + * don't want safe interpreters messing up the precision of other + * interpreters). + */ + + if (Tcl_IsSafe(interp)) { + Tcl_SetVar2(interp, name1, name2, precisionString, + flags & TCL_GLOBAL_ONLY); + return "can't modify precision from a safe interpreter"; + } + value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY); + if (value == NULL) { + value = ""; + } + prec = strtoul(value, &end, 10); + if ((prec <= 0) || (prec > TCL_MAX_PREC) || (prec > 100) || + (end == value) || (*end != 0)) { + Tcl_SetVar2(interp, name1, name2, precisionString, + flags & TCL_GLOBAL_ONLY); + return "improper value for precision"; + } + TclFormatInt(precisionString, prec); + sprintf(precisionFormat, "%%.%dg", prec); + return (char *) NULL; +} + +/* + *---------------------------------------------------------------------- + * * TclNeedSpace -- * * This procedure checks to see whether it is appropriate to @@ -2539,12 +2643,12 @@ TclNeedSpace(start, end) int TclFormatInt(buffer, n) - register char *buffer; /* Points to the storage into which the + char *buffer; /* Points to the storage into which the * formatted characters are written. */ long n; /* The integer to format. */ { - register long intVal; - register int i; + long intVal; + int i; int numFormatted, j; char *digits = "0123456789"; @@ -2612,7 +2716,7 @@ TclFormatInt(buffer, n) int TclLooksLikeInt(p) - register char *p; /* Pointer to string. */ + char *p; /* Pointer to string. */ { while (isspace(UCHAR(*p))) { p++; @@ -2636,54 +2740,6 @@ TclLooksLikeInt(p) /* *---------------------------------------------------------------------- * - * Tcl_WrongNumArgs -- - * - * This procedure generates a "wrong # args" error message in an - * interpreter. It is used as a utility function by many command - * procedures. - * - * Results: - * None. - * - * Side effects: - * An error message is generated in interp's result object to - * indicate that a command was invoked with the wrong number of - * arguments. The message has the form - * wrong # args: should be "foo bar additional stuff" - * where "foo" and "bar" are the initial objects in objv (objc - * determines how many of these are printed) and "additional stuff" - * is the contents of the message argument. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_WrongNumArgs(interp, objc, objv, message) - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments to print - * from objv. */ - Tcl_Obj *CONST objv[]; /* Initial argument objects, which - * should be included in the error - * message. */ - char *message; /* Error message to print after the - * leading objects in objv. */ -{ - Tcl_Obj *objPtr; - int i; - - objPtr = Tcl_GetObjResult(interp); - Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1); - for (i = 0; i < objc; i++) { - Tcl_AppendStringsToObj(objPtr, - Tcl_GetStringFromObj(objv[i], (int *) NULL), " ", - (char *) NULL); - } - Tcl_AppendStringsToObj(objPtr, message, "\"", (char *) NULL); -} - -/* - *---------------------------------------------------------------------- - * * TclGetIntForIndex -- * * This procedure returns an integer corresponding to the list index @@ -2711,15 +2767,15 @@ TclGetIntForIndex(interp, objPtr, endValue, indexPtr) Tcl_Interp *interp; /* Interpreter to use for error reporting. * If NULL, then no error message is left * after errors. */ - register Tcl_Obj *objPtr; /* Points to an object containing either + Tcl_Obj *objPtr; /* Points to an object containing either * "end" or an integer. */ int endValue; /* The value to be stored at "indexPtr" if * "objPtr" holds "end". */ - register int *indexPtr; /* Location filled in with an integer + int *indexPtr; /* Location filled in with an integer * representing an index. */ { Interp *iPtr = (Interp *) interp; - register char *bytes; + char *bytes; int index, length, result; /* diff --git a/contrib/tcl/generic/tclVar.c b/contrib/tcl/generic/tclVar.c index 577ba74..587eca9 100644 --- a/contrib/tcl/generic/tclVar.c +++ b/contrib/tcl/generic/tclVar.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclVar.c 1.113 97/06/25 08:54:16 + * SCCS: @(#) tclVar.c 1.125 97/08/06 14:47:55 */ #include "tclInt.h" @@ -782,6 +782,7 @@ TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg) * that we return. Initialized to avoid * compiler warning. */ char *elem, *msg; + int new; #ifdef TCL_COMPILE_DEBUG Proc *procPtr = varFramePtr->procPtr; @@ -833,23 +834,34 @@ TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg) } /* - * Look up the element. + * Look up the element. Note that we must create the element (but leave + * it marked undefined) if it does not already exist. This allows a + * trace to create new array elements "on the fly" that did not exist + * before. A trace is always passed a variable for the array element. If + * the trace does not define the variable, it will be deleted below (at + * errorReturn) and an error returned. */ - hPtr = Tcl_FindHashEntry(arrayPtr->value.tablePtr, elem); - if (hPtr == NULL) { - if (leaveErrorMsg) { - VarErrMsg(interp, arrayName, elem, "read", noSuchElement); + hPtr = Tcl_CreateHashEntry(arrayPtr->value.tablePtr, elem, &new); + if (new) { + if (arrayPtr->searchPtr != NULL) { + DeleteSearches(arrayPtr); } - goto errorReturn; + varPtr = NewVar(); + Tcl_SetHashValue(hPtr, varPtr); + varPtr->hPtr = hPtr; + varPtr->nsPtr = varFramePtr->nsPtr; + TclSetVarArrayElement(varPtr); + } else { + varPtr = (Var *) Tcl_GetHashValue(hPtr); } - varPtr = (Var *) Tcl_GetHashValue(hPtr); /* * Invoke any traces that have been set for the element variable. */ - if (varPtr->tracePtr != NULL) { + if ((varPtr->tracePtr != NULL) + || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { msg = CallTraces(iPtr, arrayPtr, varPtr, arrayName, elem, TCL_TRACE_READS); if (msg != NULL) { @@ -1034,12 +1046,12 @@ Tcl_SetVar2(interp, part1, part2, newValue, flags) * Tcl_ObjSetVar2 to actually set the variable. */ - length = strlen(newValue); + length = newValue ? strlen(newValue) : 0; TclNewObj(valuePtr); TclInitStringRep(valuePtr, newValue, length); Tcl_IncrRefCount(valuePtr); - length = strlen(part1); + length = strlen(part1) ; TclNewObj(part1Ptr); TclInitStringRep(part1Ptr, part1, length); Tcl_IncrRefCount(part1Ptr); @@ -2119,6 +2131,22 @@ Tcl_UnsetVar2(interp, part1, part2, flags) TclDecrRefCount(objPtr); dummyVarPtr->value.objPtr = NULL; } + + /* + * If the variable was a namespace variable, decrement its reference + * count. We are in the process of destroying its namespace so that + * namespace will no longer "refer" to the variable. + */ + + if (varPtr->flags & VAR_NAMESPACE_VAR) { + varPtr->flags &= ~VAR_NAMESPACE_VAR; + varPtr->refCount--; + } + + /* + * It's an error to unset an undefined variable. + */ + if (result != TCL_OK) { if (flags & TCL_LEAVE_ERR_MSG) { VarErrMsg(interp, part1, part2, "unset", @@ -2751,26 +2779,35 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { + static char *arrayOptions[] = {"anymore", "donesearch", "exists", "get", + "names", "nextelement", "set", "size", "startsearch", + (char *) NULL}; Var *varPtr, *arrayPtr; Tcl_HashEntry *hPtr; Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); - int notArray, c; - char *varName, *option; - int length, result; + int notArray; + char *varName; + int index, result; + if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "option arrayName ?arg ...?"); return TCL_ERROR; } + if (Tcl_GetIndexFromObj(interp, objv[1], arrayOptions, "option", 0, &index) + != TCL_OK) { + return TCL_ERROR; + } + /* * Locate the array variable (and it better be an array). * THIS FAILS IF A NAME OBJECT'S STRING REP HAS A NULL BYTE. */ - varName = TclGetStringFromObj(objv[2], (int *) NULL); varPtr = TclLookupVar(interp, varName, (char *) NULL, /*flags*/ 0, /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); + notArray = 0; if (varPtr == NULL) { notArray = 1; @@ -2780,295 +2817,289 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) } } - /* - * Dispatch based on the option. - * THIS FAILS IF THE OPTIONS OBJECT'S STRING REP HAS A NULL BYTE. - */ - - option = TclGetStringFromObj(objv[1], (int *) NULL); - c = option[0]; - length = strlen(option); - if ((c == 'a') - && (strncmp(option, "anymore", (unsigned) length) == 0)) { - ArraySearch *searchPtr; - char *searchId; - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 1, objv, "anymore arrayName searchId"); - return TCL_ERROR; - } - if (notArray) { - goto error; - } - searchId = Tcl_GetStringFromObj(objv[3], (int *) NULL); - searchPtr = ParseSearchId(interp, varPtr, varName, searchId); - if (searchPtr == NULL) { - return TCL_ERROR; - } - while (1) { - Var *varPtr2; + switch (index) { + case 0: { /* anymore */ + ArraySearch *searchPtr; + char *searchId; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, + "arrayName searchId"); + return TCL_ERROR; + } + if (notArray) { + goto error; + } + searchId = Tcl_GetStringFromObj(objv[3], (int *) NULL); + searchPtr = ParseSearchId(interp, varPtr, varName, searchId); + if (searchPtr == NULL) { + return TCL_ERROR; + } + while (1) { + Var *varPtr2; - if (searchPtr->nextEntry != NULL) { - varPtr2 = (Var *) Tcl_GetHashValue(searchPtr->nextEntry); - if (!TclIsVarUndefined(varPtr2)) { - break; + if (searchPtr->nextEntry != NULL) { + varPtr2 = (Var *) Tcl_GetHashValue(searchPtr->nextEntry); + if (!TclIsVarUndefined(varPtr2)) { + break; + } + } + searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search); + if (searchPtr->nextEntry == NULL) { + Tcl_SetIntObj(resultPtr, 0); + return TCL_OK; } } - searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search); - if (searchPtr->nextEntry == NULL) { - Tcl_SetIntObj(resultPtr, 0); - return TCL_OK; - } + Tcl_SetIntObj(resultPtr, 1); + break; } - Tcl_SetIntObj(resultPtr, 1); - return TCL_OK; - } else if ((c == 'd') - && (strncmp(option, "donesearch", (unsigned) length) == 0)) { - ArraySearch *searchPtr, *prevPtr; - char *searchId; + case 1: { /* donesearch */ + ArraySearch *searchPtr, *prevPtr; + char *searchId; - if (objc != 4) { - Tcl_WrongNumArgs(interp, 1, objv, "donesearch arrayName searchId"); - return TCL_ERROR; - } - if (notArray) { - goto error; - } - searchId = Tcl_GetStringFromObj(objv[3], (int *) NULL); - searchPtr = ParseSearchId(interp, varPtr, varName, searchId); - if (searchPtr == NULL) { - return TCL_ERROR; - } - if (varPtr->searchPtr == searchPtr) { - varPtr->searchPtr = searchPtr->nextPtr; - } else { - for (prevPtr = varPtr->searchPtr; ; - prevPtr = prevPtr->nextPtr) { - if (prevPtr->nextPtr == searchPtr) { - prevPtr->nextPtr = searchPtr->nextPtr; - break; + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, + "arrayName searchId"); + return TCL_ERROR; + } + if (notArray) { + goto error; + } + searchId = Tcl_GetStringFromObj(objv[3], (int *) NULL); + searchPtr = ParseSearchId(interp, varPtr, varName, searchId); + if (searchPtr == NULL) { + return TCL_ERROR; + } + if (varPtr->searchPtr == searchPtr) { + varPtr->searchPtr = searchPtr->nextPtr; + } else { + for (prevPtr = varPtr->searchPtr; ; + prevPtr = prevPtr->nextPtr) { + if (prevPtr->nextPtr == searchPtr) { + prevPtr->nextPtr = searchPtr->nextPtr; + break; + } } } + ckfree((char *) searchPtr); + break; } - ckfree((char *) searchPtr); - } else if ((c == 'e') - && (strncmp(option, "exists", (unsigned) length) == 0)) { - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "exists arrayName"); - return TCL_ERROR; - } - Tcl_SetIntObj(resultPtr, !notArray); - } else if ((c == 'g') - && (strncmp(option, "get", (unsigned) length) == 0)) { - Tcl_HashSearch search; - Var *varPtr2; - char *pattern = NULL; - char *name; - Tcl_Obj *namePtr, *valuePtr; - - if ((objc != 3) && (objc != 4)) { - Tcl_WrongNumArgs(interp, 1, objv, "get arrayName ?pattern?"); - return TCL_ERROR; - } - if (notArray) { - return TCL_OK; - } - if (objc == 4) { - pattern = Tcl_GetStringFromObj(objv[3], (int *) NULL); + case 2: { /* exists */ + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); + return TCL_ERROR; + } + Tcl_SetIntObj(resultPtr, !notArray); + break; } - for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - varPtr2 = (Var *) Tcl_GetHashValue(hPtr); - if (TclIsVarUndefined(varPtr2)) { - continue; + case 3: { /*get*/ + Tcl_HashSearch search; + Var *varPtr2; + char *pattern = NULL; + char *name; + Tcl_Obj *namePtr, *valuePtr; + + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?"); + return TCL_ERROR; } - name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); - if ((objc == 4) && !Tcl_StringMatch(name, pattern)) { - continue; /* element name doesn't match pattern */ + if (notArray) { + return TCL_OK; } - - namePtr = Tcl_NewStringObj(name, -1); - result = Tcl_ListObjAppendElement(interp, resultPtr, namePtr); - if (result != TCL_OK) { - Tcl_DecrRefCount(namePtr); /* free unneeded name object */ - return result; + if (objc == 4) { + pattern = Tcl_GetStringFromObj(objv[3], (int *) NULL); } + for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + varPtr2 = (Var *) Tcl_GetHashValue(hPtr); + if (TclIsVarUndefined(varPtr2)) { + continue; + } + name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); + if ((objc == 4) && !Tcl_StringMatch(name, pattern)) { + continue; /* element name doesn't match pattern */ + } + + namePtr = Tcl_NewStringObj(name, -1); + result = Tcl_ListObjAppendElement(interp, resultPtr, namePtr); + if (result != TCL_OK) { + Tcl_DecrRefCount(namePtr); /* free unneeded name object */ + return result; + } - if (varPtr2->value.objPtr == NULL) { - TclNewObj(valuePtr); - } else { - valuePtr = varPtr2->value.objPtr; - } - result = Tcl_ListObjAppendElement(interp, resultPtr, valuePtr); - if (result != TCL_OK) { if (varPtr2->value.objPtr == NULL) { - Tcl_DecrRefCount(valuePtr); /* free unneeded object */ + TclNewObj(valuePtr); + } else { + valuePtr = varPtr2->value.objPtr; + } + result = Tcl_ListObjAppendElement(interp, resultPtr, valuePtr); + if (result != TCL_OK) { + if (varPtr2->value.objPtr == NULL) { + Tcl_DecrRefCount(valuePtr); /* free unneeded object */ + } + return result; } - return result; } + break; } - } else if ((c == 'n') - && (strncmp(option, "names", (unsigned) length) == 0) - && (length >= 2)) { - Tcl_HashSearch search; - Var *varPtr2; - char *pattern = NULL; - char *name; - Tcl_Obj *namePtr; - - if ((objc != 3) && (objc != 4)) { - Tcl_WrongNumArgs(interp, 1, objv, "names arrayName ?pattern?"); - return TCL_ERROR; - } - if (notArray) { - return TCL_OK; - } - if (objc == 4) { - pattern = Tcl_GetStringFromObj(objv[3], (int *) NULL); - } - for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - varPtr2 = (Var *) Tcl_GetHashValue(hPtr); - if (TclIsVarUndefined(varPtr2)) { - continue; + case 4: { /* names */ + Tcl_HashSearch search; + Var *varPtr2; + char *pattern = NULL; + char *name; + Tcl_Obj *namePtr; + + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?"); + return TCL_ERROR; } - name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); - if ((objc == 4) && !Tcl_StringMatch(name, pattern)) { - continue; /* element name doesn't match pattern */ + if (notArray) { + return TCL_OK; } - - namePtr = Tcl_NewStringObj(name, -1); - result = Tcl_ListObjAppendElement(interp, resultPtr, namePtr); - if (result != TCL_OK) { - Tcl_DecrRefCount(namePtr); /* free unneeded name object */ - return result; + if (objc == 4) { + pattern = Tcl_GetStringFromObj(objv[3], (int *) NULL); } + for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + varPtr2 = (Var *) Tcl_GetHashValue(hPtr); + if (TclIsVarUndefined(varPtr2)) { + continue; + } + name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); + if ((objc == 4) && !Tcl_StringMatch(name, pattern)) { + continue; /* element name doesn't match pattern */ + } + + namePtr = Tcl_NewStringObj(name, -1); + result = Tcl_ListObjAppendElement(interp, resultPtr, namePtr); + if (result != TCL_OK) { + Tcl_DecrRefCount(namePtr); /* free unneeded name object */ + return result; + } + } + break; } - } else if ((c == 'n') - && (strncmp(option, "nextelement", (unsigned) length) == 0) - && (length >= 2)) { - ArraySearch *searchPtr; - char *searchId; - Tcl_HashEntry *hPtr; - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 1, objv, "nextelement arrayName searchId"); - return TCL_ERROR; - } - if (notArray) { - goto error; - } - searchId = Tcl_GetStringFromObj(objv[3], (int *) NULL); - searchPtr = ParseSearchId(interp, varPtr, varName, searchId); - if (searchPtr == NULL) { - return TCL_ERROR; - } - while (1) { - Var *varPtr2; + case 5: { /*nextelement*/ + ArraySearch *searchPtr; + char *searchId; + Tcl_HashEntry *hPtr; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, + "arrayName searchId"); + return TCL_ERROR; + } + if (notArray) { + goto error; + } + searchId = Tcl_GetStringFromObj(objv[3], (int *) NULL); + searchPtr = ParseSearchId(interp, varPtr, varName, searchId); + if (searchPtr == NULL) { + return TCL_ERROR; + } + while (1) { + Var *varPtr2; - hPtr = searchPtr->nextEntry; - if (hPtr == NULL) { - hPtr = Tcl_NextHashEntry(&searchPtr->search); + hPtr = searchPtr->nextEntry; if (hPtr == NULL) { - return TCL_OK; + hPtr = Tcl_NextHashEntry(&searchPtr->search); + if (hPtr == NULL) { + return TCL_OK; + } + } else { + searchPtr->nextEntry = NULL; + } + varPtr2 = (Var *) Tcl_GetHashValue(hPtr); + if (!TclIsVarUndefined(varPtr2)) { + break; } - } else { - searchPtr->nextEntry = NULL; - } - varPtr2 = (Var *) Tcl_GetHashValue(hPtr); - if (!TclIsVarUndefined(varPtr2)) { - break; } + Tcl_SetStringObj(resultPtr, + Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), -1); + break; } - Tcl_SetStringObj(resultPtr, - Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), -1); - } else if ((c == 's') - && (strncmp(option, "set", (unsigned) length) == 0) - && (length >= 2)) { - Tcl_Obj **elemPtrs; - int listLen, i, result; - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 1, objv, "set arrayName list"); - return TCL_ERROR; - } - result = Tcl_ListObjGetElements(interp, objv[3], &listLen, &elemPtrs); - if (result != TCL_OK) { + case 6: { /*set*/ + Tcl_Obj **elemPtrs; + int listLen, i, result; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName list"); + return TCL_ERROR; + } + result = Tcl_ListObjGetElements(interp, objv[3], &listLen, + &elemPtrs); + if (result != TCL_OK) { + return result; + } + if (listLen & 1) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "list must have an even number of elements", -1); + return TCL_ERROR; + } + for (i = 0; i < listLen; i += 2) { + if (Tcl_ObjSetVar2(interp, objv[2], elemPtrs[i], elemPtrs[i+1], + TCL_LEAVE_ERR_MSG) == NULL) { + result = TCL_ERROR; + break; + } + } return result; } - if (listLen & 1) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "list must have an even number of elements", -1); - return TCL_ERROR; - } - for (i = 0; i < listLen; i += 2) { - if (Tcl_ObjSetVar2(interp, objv[2], elemPtrs[i], elemPtrs[i+1], - TCL_LEAVE_ERR_MSG) == NULL) { - result = TCL_ERROR; - break; + case 7: { /*size*/ + Tcl_HashSearch search; + Var *varPtr2; + int size; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); + return TCL_ERROR; } - } - return result; - } else if ((c == 's') - && (strncmp(option, "size", (unsigned) length) == 0) - && (length >= 2)) { - Tcl_HashSearch search; - Var *varPtr2; - int size; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "size arrayName"); - return TCL_ERROR; - } - size = 0; - if (!notArray) { - for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - varPtr2 = (Var *) Tcl_GetHashValue(hPtr); - if (TclIsVarUndefined(varPtr2)) { - continue; + size = 0; + if (!notArray) { + for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, + &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + varPtr2 = (Var *) Tcl_GetHashValue(hPtr); + if (TclIsVarUndefined(varPtr2)) { + continue; + } + size++; } - size++; } + Tcl_SetIntObj(resultPtr, size); + break; } - Tcl_SetIntObj(resultPtr, size); - } else if ((c == 's') - && (strncmp(option, "startsearch", (unsigned) length) == 0) - && (length >= 2)) { - ArraySearch *searchPtr; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "startsearch arrayName"); - return TCL_ERROR; - } - if (notArray) { - goto error; - } - searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch)); - if (varPtr->searchPtr == NULL) { - searchPtr->id = 1; - Tcl_AppendStringsToObj(resultPtr, "s-1-", varName, - (char *) NULL); - } else { - char string[20]; + case 8: { /*startsearch*/ + ArraySearch *searchPtr; - searchPtr->id = varPtr->searchPtr->id + 1; - TclFormatInt(string, searchPtr->id); - Tcl_AppendStringsToObj(resultPtr, "s-", string, "-", varName, + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); + return TCL_ERROR; + } + if (notArray) { + goto error; + } + searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch)); + if (varPtr->searchPtr == NULL) { + searchPtr->id = 1; + Tcl_AppendStringsToObj(resultPtr, "s-1-", varName, + (char *) NULL); + } else { + char string[20]; + + searchPtr->id = varPtr->searchPtr->id + 1; + TclFormatInt(string, searchPtr->id); + Tcl_AppendStringsToObj(resultPtr, "s-", string, "-", varName, (char *) NULL); + } + searchPtr->varPtr = varPtr; + searchPtr->nextEntry = Tcl_FirstHashEntry(varPtr->value.tablePtr, + &searchPtr->search); + searchPtr->nextPtr = varPtr->searchPtr; + varPtr->searchPtr = searchPtr; + break; } - searchPtr->varPtr = varPtr; - searchPtr->nextEntry = Tcl_FirstHashEntry(varPtr->value.tablePtr, - &searchPtr->search); - searchPtr->nextPtr = varPtr->searchPtr; - varPtr->searchPtr = searchPtr; - } else { - Tcl_AppendStringsToObj(resultPtr, "bad option \"", option, - "\": should be anymore, donesearch, exists, ", - "get, names, nextelement, ", - "set, size, or startsearch", (char *) NULL); - return TCL_ERROR; } return TCL_OK; @@ -3581,6 +3612,17 @@ Tcl_VariableObjCmd(dummy, interp, objc, objv) } /* + * Mark the variable as a namespace variable and increment its + * reference count so that it will persist until its namespace is + * destroyed or until the variable is unset. + */ + + if (!(varPtr->flags & VAR_NAMESPACE_VAR)) { + varPtr->flags |= VAR_NAMESPACE_VAR; + varPtr->refCount++; + } + + /* * If a value was specified, set the variable to that value. * Otherwise, if the variable is new, leave it undefined. * (If the variable already exists and no value was specified, @@ -3594,7 +3636,7 @@ Tcl_VariableObjCmd(dummy, interp, objc, objv) if (varValuePtr == NULL) { return TCL_ERROR; } - } + } /* * If we are executing inside a Tcl procedure, create a local @@ -4159,6 +4201,18 @@ TclDeleteVars(iPtr, tablePtr) TclSetVarScalar(varPtr); /* + * If the variable was a namespace variable, decrement its + * reference count. We are in the process of destroying its + * namespace so that namespace will no longer "refer" to the + * variable. + */ + + if (varPtr->flags & VAR_NAMESPACE_VAR) { + varPtr->flags &= ~VAR_NAMESPACE_VAR; + varPtr->refCount--; + } + + /* * Recycle the variable's memory space if there aren't any upvar's * pointing to it. If there are upvars to this variable, then the * variable will get freed when the last upvar goes away. |
