diff options
author | stanton <stanton> | 1998-09-24 23:58:14 (GMT) |
---|---|---|
committer | stanton <stanton> | 1998-09-24 23:58:14 (GMT) |
commit | 9995355714bc90faf7c2e345b3d6a1d041447097 (patch) | |
tree | 2ad97c5b1994495118cef4df947cf16b55e326f2 /generic | |
parent | e13392595faf8e8d0d1c3c514ce160cfadc3d372 (diff) | |
download | tcl-9995355714bc90faf7c2e345b3d6a1d041447097.zip tcl-9995355714bc90faf7c2e345b3d6a1d041447097.tar.gz tcl-9995355714bc90faf7c2e345b3d6a1d041447097.tar.bz2 |
merging changes from 8.0.3 into 8.1a2
Diffstat (limited to 'generic')
57 files changed, 3031 insertions, 460 deletions
diff --git a/generic/README b/generic/README index 4b3aa4f..6d585a7 100644 --- a/generic/README +++ b/generic/README @@ -2,4 +2,4 @@ This directory contains Tcl source files that work on all the platforms where Tcl runs (e.g. UNIX, PCs, and Macintoshes). Platform-specific sources are in the directories ../unix, ../win, and ../mac. -SCCS ID: @(#) README 1.1 95/09/11 14:02:13 +RCS: @(#) $Id: README,v 1.1.2.1 1998/09/24 23:58:39 stanton Exp $ diff --git a/generic/panic.c b/generic/panic.c index 420a157..b863027 100644 --- a/generic/panic.c +++ b/generic/panic.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: @(#) panic.c 1.15 96/09/12 14:55:25 + * RCS: @(#) $Id: panic.c,v 1.1.2.1 1998/09/24 23:58:39 stanton Exp $ */ #include <stdio.h> @@ -25,6 +25,9 @@ #include "tcl.h" #undef panic +# undef TCL_STORAGE_CLASS +# define TCL_STORAGE_CLASS DLLEXPORT + EXTERN void panic _ANSI_ARGS_((char *format, char *arg1, char *arg2, char *arg3, char *arg4, char *arg5, char *arg6, char *arg7, char *arg8)); diff --git a/generic/tcl.h b/generic/tcl.h index 296d4f6..75923d8 100644 --- a/generic/tcl.h +++ b/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.352 98/02/19 13:53:28 + * RCS: @(#) $Id: tcl.h,v 1.1.2.2 1998/09/24 23:58:39 stanton Exp $ */ #ifndef _TCL @@ -21,7 +21,8 @@ * When version numbers change here, must also go into the following files * and update the version numbers: * - * library/init.tcl + * README + * library/init.tcl (only if major.minor changes, not patchlevel) * unix/configure.in * unix/pkginfo * win/makefile.bc @@ -75,11 +76,6 @@ # ifndef USE_TCLALLOC # define USE_TCLALLOC 1 # endif -# ifndef STRINGIFY -# define STRINGIFY(x) STRINGIFY1(x) -# define STRINGIFY1(x) #x -# endif -# define INLINE #endif /* __WIN32__ */ /* @@ -100,6 +96,34 @@ # define INLINE #endif +/* + * Utility macros: STRINGIFY takes an argument and wraps it in "" (double + * quotation marks), JOIN joins two arguments. + */ + +#define VERBATIM(x) x +#ifdef _MSC_VER +# define STRINGIFY(x) STRINGIFY1(x) +# define STRINGIFY1(x) #x +# define JOIN(a,b) JOIN1(a,b) +# define JOIN1(a,b) a##b +#else +# ifdef RESOURCE_INCLUDED +# define STRINGIFY(x) STRINGIFY1(x) +# define STRINGIFY1(x) #x +# define JOIN(a,b) JOIN1(a,b) +# define JOIN1(a,b) a##b +# else +# ifdef __STDC__ +# define STRINGIFY(x) #x +# define JOIN(a,b) a##b +# else +# define STRINGIFY(x) "x" +# define JOIN(a,b) VERBATIM(a)VERBATIM(b) +# endif +# endif +#endif + /* * A special definition used to allow this header file to be included * in resource files so that they can get obtain version information from @@ -140,6 +164,45 @@ #endif /* + * Macros used to declare a function to be exported by a DLL. + * Used by Windows, maps to no-op declarations on non-Windows systems. + * The default build on windows is for a DLL, which causes the DLLIMPORT + * and DLLEXPORT macros to be nonempty. To build a static library, the + * macro STATIC_BUILD should be defined. + * The support follows the convention that a macro called BUILD_xxxx, where + * xxxx is the name of a library we are building, is set on the compile line + * for sources that are to be placed in the library. See BUILD_tcl in this + * file for an example of how the macro is to be used. + */ + +#ifdef __WIN32__ +# ifdef STATIC_BUILD +# define DLLIMPORT +# define DLLEXPORT +# else +# ifdef _MSC_VER +# define DLLIMPORT __declspec(dllimport) +# define DLLEXPORT __declspec(dllexport) +# else +# define DLLIMPORT +# define DLLEXPORT +# endif +# endif +#else +# define DLLIMPORT +# define DLLEXPORT +#endif + +#ifdef TCL_STORAGE_CLASS +# undef TCL_STORAGE_CLASS +#endif +#ifdef BUILD_tcl +# define TCL_STORAGE_CLASS DLLEXPORT +#else +# define TCL_STORAGE_CLASS DLLIMPORT +#endif + +/* * Definitions that allow this header file to be used either with or * without ANSI C features like function prototypes. */ @@ -160,9 +223,9 @@ #endif #ifdef __cplusplus -# define EXTERN extern "C" +# define EXTERN extern "C" TCL_STORAGE_CLASS #else -# define EXTERN extern +# define EXTERN extern TCL_STORAGE_CLASS #endif /* @@ -687,7 +750,7 @@ typedef struct Tcl_DString { #define TCL_TRACE_DESTROYED 0x80 #define TCL_INTERP_DESTROYED 0x100 #define TCL_LEAVE_ERR_MSG 0x200 -#define TCL_TRACE_ARRAY 0x400 +#define TCL_TRACE_ARRAY 0x800 /* * The TCL_PARSE_PART1 flag is deprecated and has no effect. @@ -1447,6 +1510,7 @@ EXTERN int Tcl_GetCommandInfo _ANSI_ARGS_((Tcl_Interp *interp, EXTERN char * Tcl_GetCommandName _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Command command)); EXTERN Tcl_ThreadId Tcl_GetCurrentThread _ANSI_ARGS_((void)); +EXTERN char * Tcl_GetCwd _ANSI_ARGS_((char *buf, int len)); EXTERN int Tcl_GetDouble _ANSI_ARGS_((Tcl_Interp *interp, char *string, double *doublePtr)); EXTERN int Tcl_GetDoubleFromObj _ANSI_ARGS_(( @@ -1477,6 +1541,7 @@ EXTERN int Tcl_GetIntFromObj _ANSI_ARGS_((Tcl_Interp *interp, EXTERN int Tcl_GetLongFromObj _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr)); EXTERN Tcl_Interp * Tcl_GetMaster _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN CONST char * Tcl_GetNameOfExecutable _ANSI_ARGS_((void)); EXTERN Tcl_Obj * Tcl_GetObjResult _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN Tcl_Obj * Tcl_GetObjVar2 _ANSI_ARGS_((Tcl_Interp *interp, char *part1, char *part2, int flags)); @@ -1513,6 +1578,7 @@ EXTERN int Tcl_HideCommand _ANSI_ARGS_((Tcl_Interp *interp, EXTERN int Tcl_Init _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN void Tcl_InitHashTable _ANSI_ARGS_((Tcl_HashTable *tablePtr, int keyType)); +EXTERN void Tcl_InitMemory _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN ClientData Tcl_InitNotifier _ANSI_ARGS_((void)); EXTERN int Tcl_InputBlocked _ANSI_ARGS_((Tcl_Channel chan)); EXTERN int Tcl_InputBuffered _ANSI_ARGS_((Tcl_Channel chan)); @@ -1796,4 +1862,8 @@ EXTERN void Tcl_WrongNumArgs _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], char *message)); #endif /* RESOURCE_INCLUDED */ + +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLIMPORT + #endif /* _TCL */ diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c index 262089a..070302f 100644 --- a/generic/tclAlloc.c +++ b/generic/tclAlloc.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: @(#) tclAlloc.c 1.9 98/02/18 14:40:50 + * RCS: @(#) $Id: tclAlloc.c,v 1.1.2.2 1998/09/24 23:58:40 stanton Exp $ */ #include "tclInt.h" diff --git a/generic/tclAsync.c b/generic/tclAsync.c index 3616218..8abe3c5 100644 --- a/generic/tclAsync.c +++ b/generic/tclAsync.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: @(#) tclAsync.c 1.7 98/02/04 16:21:25 + * RCS: @(#) $Id: tclAsync.c,v 1.1.2.2 1998/09/24 23:58:40 stanton Exp $ */ #include "tclInt.h" diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 8eac237..719203d 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -6,12 +6,13 @@ * and deletion, and command parsing and execution. * * Copyright (c) 1987-1994 The Regents of the University of California. - * Copyright (c) 1994-1998 Sun Microsystems, Inc. + * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 1998 by Scriptics Corporation. * * 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.331 98/02/18 15:32:09 + * RCS: @(#) $Id: tclBasic.c,v 1.1.2.2 1998/09/24 23:58:40 stanton Exp $ */ #include "tclInt.h" @@ -329,6 +330,7 @@ Tcl_CreateInterp() TclInitLiteralTable(&(iPtr->literalTable)); iPtr->compileEpoch = 0; iPtr->compiledProcPtr = NULL; + iPtr->resolverPtr = NULL; iPtr->evalFlags = 0; iPtr->scriptFile = NULL; iPtr->flags = 0; @@ -901,6 +903,8 @@ DeleteInterpProc(interp) Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_HashTable *hTablePtr; + AssocData *dPtr; + ResolverScheme *resPtr, *nextResPtr; int i; /* @@ -1038,6 +1042,14 @@ DeleteInterpProc(interp) Tcl_DecrRefCount(iPtr->emptyObjPtr); iPtr->emptyObjPtr = NULL; + resPtr = iPtr->resolverPtr; + while (resPtr) { + nextResPtr = resPtr->nextPtr; + ckfree(resPtr->name); + ckfree((char *) resPtr); + resPtr = nextResPtr; + } + /* * Free up literal objects created for scripts compiled by the * interpreter. @@ -1397,11 +1409,13 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) * when this command is deleted. */ { Interp *iPtr = (Interp *) interp; + ImportRef *oldRefPtr = NULL; Namespace *nsPtr, *dummy1, *dummy2; - Command *cmdPtr; + Command *cmdPtr, *refCmdPtr; Tcl_HashEntry *hPtr; char *tail; int new, result; + ImportedCmdData *dataPtr; if (iPtr->flags & DELETED) { /* @@ -1434,9 +1448,15 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) if (!new) { /* * Command already exists. Delete the old one. + * Be careful to preserve any existing import links so we can + * restore them down below. That way, you can redefine a + * command and its import status will remain intact. */ cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + oldRefPtr = cmdPtr->importRefPtr; + cmdPtr->importRefPtr = NULL; + Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); if (!new) { @@ -1466,6 +1486,21 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) cmdPtr->importRefPtr = NULL; /* + * Plug in any existing import references found above. Be sure + * to update all of these references to point to the new command. + */ + + if (oldRefPtr != NULL) { + cmdPtr->importRefPtr = oldRefPtr; + while (oldRefPtr != NULL) { + refCmdPtr = oldRefPtr->importedCmdPtr; + dataPtr = (ImportedCmdData*)refCmdPtr->objClientData; + dataPtr->realCmdPtr = cmdPtr; + oldRefPtr = oldRefPtr->nextPtr; + } + } + + /* * 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 @@ -1521,11 +1556,13 @@ Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) * when this command is deleted. */ { Interp *iPtr = (Interp *) interp; + ImportRef *oldRefPtr = NULL; Namespace *nsPtr, *dummy1, *dummy2; - Command *cmdPtr; + Command *cmdPtr, *refCmdPtr; Tcl_HashEntry *hPtr; char *tail; int new, result; + ImportedCmdData *dataPtr; if (iPtr->flags & DELETED) { /* @@ -1572,6 +1609,16 @@ Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) return (Tcl_Command) cmdPtr; } + /* + * Otherwise, we delete the old command. Be careful to preserve + * any existing import links so we can restore them down below. + * That way, you can redefine a command and its import status + * will remain intact. + */ + + oldRefPtr = cmdPtr->importRefPtr; + cmdPtr->importRefPtr = NULL; + Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new); if (!new) { @@ -1599,7 +1646,30 @@ Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) cmdPtr->deleteData = clientData; cmdPtr->deleted = 0; cmdPtr->importRefPtr = NULL; + + /* + * Plug in any existing import references found above. Be sure + * to update all of these references to point to the new command. + */ + + if (oldRefPtr != NULL) { + cmdPtr->importRefPtr = oldRefPtr; + while (oldRefPtr != NULL) { + refCmdPtr = oldRefPtr->importedCmdPtr; + dataPtr = (ImportedCmdData*)refCmdPtr->objClientData; + dataPtr->realCmdPtr = cmdPtr; + oldRefPtr = oldRefPtr->nextPtr; + } + } + /* + * 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 + * in the affected namespaces. + */ + + TclResetShadowedCmdRefs(interp, cmdPtr); return (Tcl_Command) cmdPtr; } @@ -2432,6 +2502,8 @@ Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData) *---------------------------------------------------------------------- */ +#undef Tcl_EvalObj + int Tcl_EvalObj(interp, objPtr, flags) Tcl_Interp *interp; /* Token for command interpreter @@ -2455,6 +2527,7 @@ Tcl_EvalObj(interp, objPtr, flags) int result; CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr * in case TCL_EVAL_GLOBAL was set. */ + Namespace *namespacePtr; /* * Prevent the object from being deleted as a side effect of evaling it. @@ -2535,13 +2608,41 @@ Tcl_EvalObj(interp, objPtr, flags) } /* - * Get the ByteCode from the object. Make sure it hasn't been - * invalidated by, e.g., someone redefining a command with a compile - * procedure (this can make the compiled code wrong). If necessary, - * convert the object to be a ByteCode object and compile it. Also, if - * the code was compiled in a different interpreter, we recompile it. + * Get the ByteCode from the object. If it exists, make sure it hasn't + * been invalidated by, e.g., someone redefining a command with a + * compile procedure (this might make the compiled code wrong). If + * necessary, convert the object to be a ByteCode object and compile it. + * Also, if the code was compiled in/for a different interpreter, + * or for a different namespace, or for the same namespace but + * with different name resolution rules, we recompile it. + * + * Precompiled objects, however, are immutable and therefore + * they are not recompiled, even if the epoch has changed. */ + if (iPtr->varFramePtr != NULL) { + namespacePtr = iPtr->varFramePtr->nsPtr; + } else { + namespacePtr = iPtr->globalNsPtr; + } + + if (objPtr->typePtr == &tclByteCodeType) { + codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + + if ((codePtr->iPtr != iPtr) + || (codePtr->compileEpoch != iPtr->compileEpoch) + || (codePtr->nsPtr != namespacePtr) + || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) { + if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { + if (codePtr->iPtr != iPtr) { + panic("Tcl_EvalObj: compiled script jumped interps"); + } + codePtr->compileEpoch = iPtr->compileEpoch; + } else { + tclByteCodeType.freeIntRepProc(objPtr); + } + } + } if (objPtr->typePtr != &tclByteCodeType) { iPtr->errorLine = 1; result = tclByteCodeType.setFromAnyProc(interp, objPtr); @@ -2577,7 +2678,7 @@ Tcl_EvalObj(interp, objPtr, flags) */ numSrcBytes = codePtr->numSrcBytes; - if (numSrcBytes > 0) { + if ((numSrcBytes > 0) || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { /* * Increment the code's ref count while it is being executed. If * afterwards no references to it remain, free the code. @@ -3526,14 +3627,25 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr) * necessary, convert the object to be a ByteCode object and compile it. * Also, if the code was compiled in/for a different interpreter, we * recompile it. + * + * Precompiled expressions, however, are immutable and therefore + * they are not recompiled, even if the epoch has changed. + * */ if (objPtr->typePtr == &tclByteCodeType) { codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch)) { - (*tclByteCodeType.freeIntRepProc)(objPtr); - objPtr->typePtr = (Tcl_ObjType *) NULL; + if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { + if (codePtr->iPtr != iPtr) { + panic("Tcl_ExprObj: compiled expression jumped interps"); + } + codePtr->compileEpoch = iPtr->compileEpoch; + } else { + (*tclByteCodeType.freeIntRepProc)(objPtr); + objPtr->typePtr = (Tcl_ObjType *) NULL; + } } } if (objPtr->typePtr != &tclByteCodeType) { @@ -3568,8 +3680,8 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr) auxDataPtr = compEnv.auxDataArrayPtr; for (i = 0; i < compEnv.auxDataArrayNext; i++) { - if (auxDataPtr->freeProc != NULL) { - auxDataPtr->freeProc(auxDataPtr->clientData); + if (auxDataPtr->type->freeProc != NULL) { + auxDataPtr->type->freeProc(auxDataPtr->clientData); } auxDataPtr++; } diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 6a34810..e8cd6a6 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.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: @(#) tclBinary.c 1.30 98/02/05 20:20:50 + * RCS: @(#) $Id: tclBinary.c,v 1.1.2.2 1998/09/24 23:58:41 stanton Exp $ */ #include <math.h> @@ -1285,7 +1285,7 @@ GetFormatSpec(formatPtr, cmdPtr, countPtr) if (**formatPtr == '*') { (*formatPtr)++; (*countPtr) = BINARY_ALL; - } else if (isdigit(**formatPtr)) { /* INTL: digit */ + } else if (isdigit(UCHAR(**formatPtr))) { /* INTL: digit */ (*countPtr) = strtoul(*formatPtr, formatPtr, 10); } else { (*countPtr) = BINARY_NOCOUNT; diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index 10440c8..e498b6a 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -12,7 +12,7 @@ * * This code contributed by Karl Lehenbauer and Mark Diekhans * - * SCCS: @(#) tclCkalloc.c 1.35 98/02/18 16:14:29 + * RCS: @(#) $Id: tclCkalloc.c,v 1.1.2.2 1998/09/24 23:58:41 stanton Exp $ */ #include "tclInt.h" diff --git a/generic/tclClock.c b/generic/tclClock.c index 04b0b62..93a4a7a 100644 --- a/generic/tclClock.c +++ b/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.41 98/02/17 17:18:15 + * RCS: @(#) $Id: tclClock.c,v 1.1.2.2 1998/09/24 23:58:41 stanton Exp $ */ #include "tcl.h" diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 6cb154e..5ac1510 100644 --- a/generic/tclCmdAH.c +++ b/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.171 98/02/11 18:54:50 + * RCS: @(#) $Id: tclCmdAH.c,v 1.1.2.2 1998/09/24 23:58:42 stanton Exp $ */ #include "tclInt.h" diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index d6b7f0d..f47fb1e 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -13,20 +13,12 @@ * 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.185 98/02/05 20:20:55 + * RCS: @(#) $Id: tclCmdIL.c,v 1.1.2.2 1998/09/24 23:58:42 stanton Exp $ */ #include "tclInt.h" #include "tclPort.h" - -/* - * The following variable holds the full path name of the binary - * from which this application was executed, or NULL if it isn't - * know. The value of the variable is set by the procedure - * Tcl_FindExecutable. The storage space is dynamically allocated. - */ - -char *tclExecutableName = NULL; +#include "tclCompile.h" /* * During execution of the "lsort" command, structures of the following @@ -81,6 +73,9 @@ typedef struct SortInfo { * Forward declarations for procedures defined in this file: */ +static void AppendLocals _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *listPtr, char *pattern, + int includeLinks)); static int DictionaryCompare _ANSI_ARGS_((char *left, char *right)); static int InfoArgsCmd _ANSI_ARGS_((ClientData dummy, @@ -510,7 +505,7 @@ InfoArgsCmd(dummy, interp, objc, objv) listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; localPtr = localPtr->nextPtr) { - if (localPtr->isArg) { + if (TclIsVarArgument(localPtr)) { Tcl_ListObjAppendElement(interp, listObjPtr, Tcl_NewStringObj(localPtr->name, -1)); } @@ -549,7 +544,8 @@ InfoBodyCmd(dummy, interp, objc, objv) register Interp *iPtr = (Interp *) interp; char *name; Proc *procPtr; - + Tcl_Obj *bodyPtr, *resultPtr; + if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "procname"); return TCL_ERROR; @@ -562,7 +558,27 @@ InfoBodyCmd(dummy, interp, objc, objv) "\"", name, "\" isn't a procedure", (char *) NULL); return TCL_ERROR; } - Tcl_SetObjResult(interp, procPtr->bodyPtr); + + /* + * we need to check if the body from this procedure had been generated + * from a precompiled body. If that is the case, then the bodyPtr's + * string representation is bogus, since sources are not available. + * In order to make sure that later manipulations of the object do not + * invalidate the internal representation, we make a copy of the string + * representation and return that one, instead. + */ + + bodyPtr = procPtr->bodyPtr; + resultPtr = bodyPtr; + if (bodyPtr->typePtr == &tclByteCodeType) { + ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr; + + if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { + resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length); + } + } + + Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } @@ -832,7 +848,8 @@ InfoDefaultCmd(dummy, interp, objc, objv) for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; localPtr = localPtr->nextPtr) { - if ((localPtr->isArg) && (strcmp(argName, localPtr->name) == 0)) { + if (TclIsVarArgument(localPtr) + && (strcmp(argName, localPtr->name) == 0)) { if (localPtr->defValuePtr != NULL) { valueObjPtr = Tcl_SetObjVar2(interp, Tcl_GetString(objv[4]), NULL, @@ -1216,12 +1233,7 @@ InfoLocalsCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { Interp *iPtr = (Interp *) interp; - Var *varPtr; - char *varName, *pattern; - int i, localVarCt; - Tcl_HashTable *localVarTablePtr; - register Tcl_HashEntry *entryPtr; - Tcl_HashSearch search; + char *pattern; Tcl_Obj *listPtr; if (objc == 2) { @@ -1233,10 +1245,9 @@ InfoLocalsCmd(dummy, interp, objc, objv) return TCL_ERROR; } - if (iPtr->varFramePtr == NULL) { + if (iPtr->varFramePtr == NULL || !iPtr->varFramePtr->isProcCallFrame) { return TCL_OK; } - localVarTablePtr = iPtr->varFramePtr->varTablePtr; /* * Return a list containing names of first the compiled locals (i.e. the @@ -1245,18 +1256,63 @@ InfoLocalsCmd(dummy, interp, objc, objv) */ listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - + AppendLocals(interp, listPtr, pattern, 0); + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * AppendLocals -- + * + * Append the local variables for the current frame to the + * specified list object. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +AppendLocals(interp, listPtr, pattern, includeLinks) + Tcl_Interp *interp; /* Current interpreter. */ + Tcl_Obj *listPtr; /* List object to append names to. */ + char *pattern; /* Pattern to match against. */ + int includeLinks; /* 1 if upvars should be included, else 0. */ +{ + Interp *iPtr = (Interp *) interp; + CompiledLocal *localPtr; + Var *varPtr; + int i, localVarCt; + char *varName; + Tcl_HashTable *localVarTablePtr; + register Tcl_HashEntry *entryPtr; + Tcl_HashSearch search; + + localPtr = iPtr->varFramePtr->procPtr->firstLocalPtr; localVarCt = iPtr->varFramePtr->numCompiledLocals; - for (i = 0, varPtr = iPtr->varFramePtr->compiledLocals; - i < localVarCt; - i++, varPtr++) { - if (!TclIsVarUndefined(varPtr)) { + varPtr = iPtr->varFramePtr->compiledLocals; + localVarTablePtr = iPtr->varFramePtr->varTablePtr; + + for (i = 0; i < localVarCt; i++) { + /* + * Skip nameless (temporary) variables and undefined variables + */ + + if (!TclIsVarTemporary(localPtr) && !TclIsVarUndefined(varPtr)) { varName = varPtr->name; if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(varName, -1)); } } + varPtr++; + localPtr = localPtr->nextPtr; } if (localVarTablePtr != NULL) { @@ -1264,7 +1320,8 @@ InfoLocalsCmd(dummy, interp, objc, objv) entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&search)) { varPtr = (Var *) Tcl_GetHashValue(entryPtr); - if (!TclIsVarUndefined(varPtr) && !TclIsVarLink(varPtr)) { + if (!TclIsVarUndefined(varPtr) + && (includeLinks || !TclIsVarLink(varPtr))) { varName = Tcl_GetHashKey(localVarTablePtr, entryPtr); if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { @@ -1274,9 +1331,6 @@ InfoLocalsCmd(dummy, interp, objc, objv) } } } - - Tcl_SetObjResult(interp, listPtr); - return TCL_OK; } /* @@ -1307,13 +1361,17 @@ InfoNameOfExecutableCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { + CONST char *nameOfExecutable; + if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } + + nameOfExecutable = Tcl_GetNameOfExecutable(); - if (tclExecutableName != NULL) { - Tcl_SetStringObj(Tcl_GetObjResult(interp), tclExecutableName, -1); + if (nameOfExecutable != NULL) { + Tcl_SetStringObj(Tcl_GetObjResult(interp), (char *)nameOfExecutable, -1); } return TCL_OK; } @@ -1595,13 +1653,13 @@ InfoVarsCmd(dummy, interp, objc, objv) char *varName, *pattern, *simplePattern; register Tcl_HashEntry *entryPtr; Tcl_HashSearch search; - Var *varPtr, *localVarPtr; + Var *varPtr; Namespace *nsPtr; Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); Tcl_Obj *listPtr, *elemObjPtr; int specificNsInPattern = 0; /* Init. to avoid compiler warning. */ - int i, result; + int result; /* * Get the pattern and find the "effective namespace" in which to @@ -1709,49 +1767,7 @@ InfoVarsCmd(dummy, interp, objc, objv) } } } else { - /* - * We're in a local call frame and no specific namespace was - * specific. Create a list that starts with the compiled locals - * (i.e. the ones stored in the call frame). - */ - - CallFrame *varFramePtr = iPtr->varFramePtr; - int localVarCt = varFramePtr->numCompiledLocals; - Tcl_HashTable *varTablePtr = varFramePtr->varTablePtr; - - for (i = 0, localVarPtr = iPtr->varFramePtr->compiledLocals; - i < localVarCt; - i++, localVarPtr++) { - if (!TclIsVarUndefined(localVarPtr)) { - varName = localVarPtr->name; - if ((simplePattern == NULL) - || Tcl_StringMatch(varName, simplePattern)) { - Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewStringObj(varName, -1)); - } - } - } - - /* - * Now add in the variables in the call frame's variable hash - * table (if one exists). - */ - - if (varTablePtr != NULL) { - for (entryPtr = Tcl_FirstHashEntry(varTablePtr, &search); - entryPtr != NULL; - entryPtr = Tcl_NextHashEntry(&search)) { - varPtr = (Var *) Tcl_GetHashValue(entryPtr); - if (!TclIsVarUndefined(varPtr)) { - varName = Tcl_GetHashKey(varTablePtr, entryPtr); - if ((simplePattern == NULL) - || Tcl_StringMatch(varName, simplePattern)) { - Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewStringObj(varName, -1)); - } - } - } - } + AppendLocals(interp, listPtr, simplePattern, 1); } Tcl_SetObjResult(interp, listPtr); @@ -2895,7 +2911,7 @@ DictionaryCompare(left, right) diff = 0; while (1) { if (diff == 0) { - diff = *left - *right; + diff = UCHAR(*left) - UCHAR(*right); } right++; left++; @@ -2930,7 +2946,7 @@ DictionaryCompare(left, right) left += Tcl_UtfToUniChar(left, &uniLeft); right += Tcl_UtfToUniChar(right, &uniRight); } else { - diff = *left - *right; + diff = UCHAR(*left) - UCHAR(*right); break; } diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index bad8140..12bb1c6 100644 --- a/generic/tclCmdMZ.c +++ b/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.127 98/02/11 18:55:39 + * RCS: @(#) $Id: tclCmdMZ.c,v 1.1.2.2 1998/09/24 23:58:43 stanton Exp $ */ #include "tclInt.h" diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index a7676f4..824818a 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -22,6 +22,16 @@ static ClientData DupForeachInfo _ANSI_ARGS_((ClientData clientData)); static void FreeForeachInfo _ANSI_ARGS_(( ClientData clientData)); + +/* + * The structures below define the AuxData types defined in this file. + */ + +AuxDataType tclForeachInfoType = { + "ForeachInfo", /* name */ + DupForeachInfo, /* dupProc */ + FreeForeachInfo /* freeProc */ +}; /* *---------------------------------------------------------------------- @@ -140,14 +150,8 @@ TclCompileCatchCmd(interp, parsePtr, envPtr) if (nameTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { name = nameTokenPtr[1].start; nameChars = nameTokenPtr[1].size; - for (i = 0, p = name; i < nameChars; i++, p++) { - if (*p == '(') { - p = (name + nameChars-1); - if (*p == ')') { /* last char is ')' => array elem */ - return TCL_OUT_LINE_COMPILE; - } - break; - } + if (!TclIsLocalScalar(name, nameChars)) { + return TCL_OUT_LINE_COMPILE; } localIndex = TclFindCompiledLocal(nameTokenPtr[1].start, nameTokenPtr[1].size, /*create*/ 1, @@ -684,14 +688,9 @@ TclCompileForeachCmd(interp, parsePtr, envPtr) numVars = varcList[loopIndex]; for (j = 0; j < numVars; j++) { char *varName = varvList[loopIndex][j]; - char *p = varName; - while (*p != '\0') { - if ((*p == '\\') || (*p == '$') || (*p == '[') - || (*p == '(') || (*p == '"') || (*p == '{')) { - code = TCL_OUT_LINE_COMPILE; - goto done; - } - p++; + if (!TclIsLocalScalar(varName, strlen(varName))) { + code = TCL_OUT_LINE_COMPILE; + goto done; } } loopIndex++; @@ -743,8 +742,7 @@ TclCompileForeachCmd(interp, parsePtr, envPtr) } infoPtr->varLists[loopIndex] = varListPtr; } - infoIndex = TclCreateAuxData((ClientData) infoPtr, - DupForeachInfo, FreeForeachInfo, envPtr); + infoIndex = TclCreateAuxData((ClientData) infoPtr, &tclForeachInfoType, envPtr); /* * Evaluate then store each value list in the associated temporary. diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 1f57c03..c872698 100644 --- a/generic/tclCompExpr.c +++ b/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.43 98/02/06 15:19:04 + * RCS: @(#) $Id: tclCompExpr.c,v 1.1.2.2 1998/09/24 23:58:43 stanton Exp $ */ #include "tclInt.h" diff --git a/generic/tclCompile.c b/generic/tclCompile.c index fb044cd..f29b1c4 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -10,13 +10,21 @@ * 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.95 98/02/18 11:58:34 + * RCS: @(#) $Id: tclCompile.c,v 1.1.2.2 1998/09/24 23:58:44 stanton Exp $ */ #include "tclInt.h" #include "tclCompile.h" /* + * Table of all AuxData types. + */ + +static Tcl_HashTable auxDataTypeTable; +static int auxDataTypeTableInitialized; /* 0 means not yet initialized. */ +static Tcl_Mutex tableMutex; + +/* * Variable that controls whether compilation tracing is enabled and, if so, * what level of tracing is desired: * 0: no compilation tracing @@ -316,8 +324,8 @@ SetByteCodeFromAny(interp, objPtr) auxDataPtr = compEnv.auxDataArrayPtr; for (i = 0; i < compEnv.auxDataArrayNext; i++) { - if (auxDataPtr->freeProc != NULL) { - auxDataPtr->freeProc(auxDataPtr->clientData); + if (auxDataPtr->type->freeProc != NULL) { + auxDataPtr->type->freeProc(auxDataPtr->clientData); } auxDataPtr++; } @@ -520,8 +528,8 @@ TclCleanupByteCode(codePtr) auxDataPtr = codePtr->auxDataArrayPtr; for (i = 0; i < numAuxDataItems; i++) { - if (auxDataPtr->freeProc != NULL) { - (*auxDataPtr->freeProc)(auxDataPtr->clientData); + if (auxDataPtr->type->freeProc != NULL) { + (*auxDataPtr->type->freeProc)(auxDataPtr->clientData); } auxDataPtr++; } @@ -1502,6 +1510,7 @@ TclInitByteCodeObj(objPtr, envPtr) register unsigned char *p; unsigned char *nextPtr; int numLitObjects = envPtr->literalArrayNext; + Namespace *namespacePtr; int i; Interp *iPtr; @@ -1524,11 +1533,20 @@ TclInitByteCodeObj(objPtr, envPtr) structureSize += auxDataArrayBytes; structureSize += cmdLocBytes; + if (envPtr->iPtr->varFramePtr != NULL) { + namespacePtr = envPtr->iPtr->varFramePtr->nsPtr; + } else { + namespacePtr = envPtr->iPtr->globalNsPtr; + } + p = (unsigned char *) ckalloc((size_t) structureSize); codePtr = (ByteCode *) p; codePtr->interpHandle = TclHandlePreserve(iPtr->handle); codePtr->compileEpoch = iPtr->compileEpoch; + codePtr->nsPtr = namespacePtr; + codePtr->nsEpoch = namespacePtr->resolverEpoch; codePtr->refCount = 1; + codePtr->flags = 0; codePtr->source = envPtr->source; codePtr->procPtr = envPtr->procPtr; @@ -1733,7 +1751,7 @@ TclFindCompiledLocal(name, nameBytes, create, flags, procPtr) int localCt = procPtr->numCompiledLocals; localPtr = procPtr->firstLocalPtr; for (i = 0; i < localCt; i++) { - if (!localPtr->isTemp) { + if (!TclIsVarTemporary(localPtr)) { char *localName = localPtr->name; if ((name[0] == localName[0]) && (nameBytes == localPtr->nameLength) @@ -1763,10 +1781,13 @@ TclFindCompiledLocal(name, nameBytes, create, flags, procPtr) localPtr->nextPtr = NULL; localPtr->nameLength = nameBytes; localPtr->frameIndex = localVar; - localPtr->isArg = 0; - localPtr->isTemp = (name == NULL); + if (name == NULL) { + localPtr->flags |= VAR_TEMPORARY; + } localPtr->flags = flags; localPtr->defValuePtr = NULL; + localPtr->resolveInfo = NULL; + if (name != NULL) { memcpy((VOID *) localPtr->name, (VOID *) name, (size_t) nameBytes); @@ -1780,6 +1801,119 @@ TclFindCompiledLocal(name, nameBytes, create, flags, procPtr) /* *---------------------------------------------------------------------- * + * TclInitCompiledLocals -- + * + * This routine is invoked in order to initialize the compiled + * locals table for a new call frame. + * + * Results: + * None. + * + * Side effects: + * May invoke various name resolvers in order to determine which + * variables are being referenced at runtime. + * + *---------------------------------------------------------------------- + */ + +void +TclInitCompiledLocals(interp, framePtr, nsPtr) + Tcl_Interp *interp; /* Current interpreter. */ + CallFrame *framePtr; /* Call frame to initialize. */ + Namespace *nsPtr; /* Pointer to current namespace. */ +{ + register CompiledLocal *localPtr; + Interp *iPtr = (Interp*) interp; + Tcl_ResolvedVarInfo *vinfo, *resVarInfo; + Var *varPtr = framePtr->compiledLocals; + Var *resolvedVarPtr; + ResolverScheme *resPtr; + int result; + + /* + * Initialize the array of local variables stored in the call frame. + * Some variables may have special resolution rules. In that case, + * we call their "resolver" procs to get our hands on the variable, + * and we make the compiled local a link to the real variable. + */ + + for (localPtr = framePtr->procPtr->firstLocalPtr; + localPtr != NULL; + localPtr = localPtr->nextPtr) { + + /* + * Check to see if this local is affected by namespace or + * interp resolvers. The resolver to use is cached for the + * next invocation of the procedure. + */ + + if (!(localPtr->flags & (VAR_ARGUMENT|VAR_TEMPORARY|VAR_RESOLVED)) + && (nsPtr->compiledVarResProc || iPtr->resolverPtr)) { + resPtr = iPtr->resolverPtr; + + if (nsPtr->compiledVarResProc) { + result = (*nsPtr->compiledVarResProc)(nsPtr->interp, + localPtr->name, localPtr->nameLength, + (Tcl_Namespace *) nsPtr, &vinfo); + } else { + result = TCL_CONTINUE; + } + + while ((result == TCL_CONTINUE) && resPtr) { + if (resPtr->compiledVarResProc) { + result = (*resPtr->compiledVarResProc)(nsPtr->interp, + localPtr->name, localPtr->nameLength, + (Tcl_Namespace *) nsPtr, &vinfo); + } + resPtr = resPtr->nextPtr; + } + if (result == TCL_OK) { + localPtr->resolveInfo = vinfo; + localPtr->flags |= VAR_RESOLVED; + } + } + + /* + * Now invoke the resolvers to determine the exact variables that + * should be used. + */ + + resVarInfo = localPtr->resolveInfo; + resolvedVarPtr = NULL; + + if (resVarInfo && resVarInfo->fetchProc) { + resolvedVarPtr = (Var*) (*resVarInfo->fetchProc)(interp, + resVarInfo); + } + + if (resolvedVarPtr) { + varPtr->name = localPtr->name; /* will be just '\0' if temp var */ + varPtr->nsPtr = NULL; + varPtr->hPtr = NULL; + varPtr->refCount = 0; + varPtr->tracePtr = NULL; + varPtr->searchPtr = NULL; + varPtr->flags = 0; + TclSetVarLink(varPtr); + varPtr->value.linkPtr = resolvedVarPtr; + resolvedVarPtr->refCount++; + } else { + varPtr->value.objPtr = NULL; + varPtr->name = localPtr->name; /* will be just '\0' if temp var */ + varPtr->nsPtr = NULL; + varPtr->hPtr = NULL; + varPtr->refCount = 0; + varPtr->tracePtr = NULL; + varPtr->searchPtr = NULL; + varPtr->flags = (localPtr->flags | VAR_UNDEFINED); + } + varPtr++; + } +} + +/* + *---------------------------------------------------------------------- + * * TclExpandCodeArray -- * * Procedure that uses malloc to allocate more storage for a @@ -2049,12 +2183,7 @@ int TclCreateAuxData(clientData, dupProc, freeProc, envPtr) ClientData clientData; /* The compilation auxiliary data to store * in the new aux data record. */ - AuxDataDupProc *dupProc; /* Procedure to call to duplicate the - * compilation aux data when the containing - * ByteCode structure is duplicated. */ - AuxDataFreeProc *freeProc; /* Procedure to call to free the - * compilation aux data when the containing - * ByteCode structure is freed. */ + AuxDataType *typePtr; /* Pointer to the type to attach to this AuxData */ register CompileEnv *envPtr;/* Points to the CompileEnv for which a new * aux data structure is to be allocated. */ { @@ -2093,8 +2222,7 @@ TclCreateAuxData(clientData, dupProc, freeProc, envPtr) auxDataPtr = &(envPtr->auxDataArrayPtr[index]); auxDataPtr->clientData = clientData; - auxDataPtr->dupProc = dupProc; - auxDataPtr->freeProc = freeProc; + auxDataPtr->type = typePtr; return index; } @@ -2390,6 +2518,188 @@ TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold) /* *---------------------------------------------------------------------- * + * TclGetInstructionTable -- + * + * Returns a pointer to the table describing Tcl bytecode instructions. + * This procedure is defined so that clients can access the pointer from + * outside the TCL DLLs. + * + * Results: + * Returns a pointer to the global instruction table, same as the + * expression (&instructionTable[0]). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +InstructionDesc * +TclGetInstructionTable() +{ + return &instructionTable[0]; +} + +/* + *-------------------------------------------------------------- + * + * TclRegisterAuxDataType -- + * + * This procedure is called to register a new AuxData type + * in the table of all AuxData types supported by Tcl. + * + * Results: + * None. + * + * Side effects: + * The type is registered in the AuxData type table. If there was already + * a type with the same name as in typePtr, it is replaced with the + * new type. + * + *-------------------------------------------------------------- + */ + +void +TclRegisterAuxDataType(typePtr) + AuxDataType *typePtr; /* Information about object type; + * storage must be statically + * allocated (must live forever). */ +{ + register Tcl_HashEntry *hPtr; + int new; + + Tcl_MutexLock(&tableMutex); + if (!auxDataTypeTableInitialized) { + TclInitAuxDataTypeTable(); + } + + /* + * If there's already a type with the given name, remove it. + */ + + hPtr = Tcl_FindHashEntry(&tsdPtr->auxDataTypeTable, typePtr->name); + if (hPtr != (Tcl_HashEntry *) NULL) { + Tcl_DeleteHashEntry(hPtr); + } + + /* + * Now insert the new object type. + */ + + hPtr = Tcl_CreateHashEntry(&tsdPtr->auxDataTypeTable, typePtr->name, &new); + if (new) { + Tcl_SetHashValue(hPtr, typePtr); + } + Tcl_MutexUnlock(&tableMutex); +} + +/* + *---------------------------------------------------------------------- + * + * TclGetAuxDataType -- + * + * This procedure looks up an Auxdata type by name. + * + * Results: + * If an AuxData type with name matching "typeName" is found, a pointer + * to its AuxDataType structure is returned; otherwise, NULL is returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +AuxDataType * +TclGetAuxDataType(typeName) + char *typeName; /* Name of AuxData type to look up. */ +{ + register Tcl_HashEntry *hPtr; + AuxDataType *typePtr = NULL; + + Tcl_MutexLock(&tableMutex); + if (!auxDataTypeTableInitialized) { + TclInitAuxDataTypeTable(); + } + + hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typeName); + if (hPtr != (Tcl_HashEntry *) NULL) { + typePtr = (AuxDataType *) Tcl_GetHashValue(hPtr); + } + Tcl_MutexUnlock(&tableMutex); + + return typePtr; +} + +/* + *-------------------------------------------------------------- + * + * TclInitAuxDataTypeTable -- + * + * This procedure is invoked to perform once-only initialization of + * the AuxData type table. It also registers the AuxData types defined in + * this file. + * + * Results: + * None. + * + * Side effects: + * Initializes the table of defined AuxData types "auxDataTypeTable" with + * builtin AuxData types defined in this file. + * + *-------------------------------------------------------------- + */ + +void +TclInitAuxDataTypeTable() +{ + /* + * The table mutex must already be held before this routine is invoked. + */ + + auxDataTypeTableInitialized = 1; + Tcl_InitHashTable(&auxDataTypeTable, TCL_STRING_KEYS); + + /* + * There is only one AuxData type at this time, so register it here. + */ + + TclRegisterAuxDataType(&tclForeachInfoType); +} + +/* + *---------------------------------------------------------------------- + * + * TclFinalizeAuxDataTypeTable -- + * + * This procedure is called by Tcl_Finalize after all exit handlers + * have been run to free up storage associated with the table of AuxData + * types. This procedure is called by TclFinalizeExecution() which + * is called by Tcl_Finalize(). + * + * Results: + * None. + * + * Side effects: + * Deletes all entries in the hash table of AuxData types. + * + *---------------------------------------------------------------------- + */ + +void +TclFinalizeAuxDataTypeTable() +{ + Tcl_MutexLock(&tableMutex); + if (auxDataTypeTableInitialized) { + Tcl_DeleteHashTable(&auxDataTypeTable); + auxDataTypeTableInitialized = 0; + } + Tcl_MutexUnlock(&tableMutex); +} + +/* + *---------------------------------------------------------------------- + * * GetCmdLocEncodingSize -- * * Computes the total number of bytes needed to encode the command @@ -2671,13 +2981,14 @@ TclPrintByteCodeObj(interp, objPtr) if (numCompiledLocals > 0) { CompiledLocal *localPtr = procPtr->firstLocalPtr; for (i = 0; i < numCompiledLocals; i++) { - fprintf(stdout, " slot %d%s%s%s%s%s", i, + fprintf(stdout, " slot %d%s%s%s%s%s%s", i, ((localPtr->flags & VAR_SCALAR)? ", scalar" : ""), ((localPtr->flags & VAR_ARRAY)? ", array" : ""), ((localPtr->flags & VAR_LINK)? ", link" : ""), - (localPtr->isArg? ", arg" : ""), - (localPtr->isTemp? ", temp" : "")); - if (localPtr->isTemp) { + ((localPtr->flags & VAR_ARGUMENT)? ", arg" : ""), + ((localPtr->flags & VAR_TEMPORARY)? ", temp" : ""), + ((localPtr->flags & VAR_RESOLVED)? ", resolved" : "")); + if (TclIsVarTemporary(localPtr)) { fprintf(stdout, "\n"); } else { fprintf(stdout, ", \"%s\"\n", localPtr->name); @@ -2928,7 +3239,7 @@ TclPrintInstruction(codePtr, pc) for (j = 0; j < opnd; j++) { localPtr = localPtr->nextPtr; } - if (localPtr->isTemp) { + if (TclIsVarTemporary(localPtr)) { fprintf(stdout, "%u # temp var %u", (unsigned int) opnd, (unsigned int) opnd); } else { @@ -2958,7 +3269,7 @@ TclPrintInstruction(codePtr, pc) for (j = 0; j < opnd; j++) { localPtr = localPtr->nextPtr; } - if (localPtr->isTemp) { + if (TclIsVarTemporary(localPtr)) { fprintf(stdout, "%u # temp var %u", (unsigned int) opnd, (unsigned int) opnd); } else { diff --git a/generic/tclCompile.h b/generic/tclCompile.h index d3f883f..0b1b3ec 100644 --- a/generic/tclCompile.h +++ b/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.45 98/02/17 16:30:54 + * RCS: @(#) $Id: tclCompile.h,v 1.1.2.2 1998/09/24 23:58:46 stanton Exp $ */ #ifndef _TCLCOMPILATION @@ -16,6 +16,11 @@ #include "tclInt.h" #endif /* _TCLINT */ +#ifdef BUILD_tcl +# undef TCL_STORAGE_CLASS +# define TCL_STORAGE_CLASS DLLEXPORT +#endif + /* *------------------------------------------------------------------------ * Variables related to compilation. These are used in tclCompile.c, @@ -138,22 +143,36 @@ typedef ClientData (AuxDataDupProc) _ANSI_ARGS_((ClientData clientData)); typedef void (AuxDataFreeProc) _ANSI_ARGS_((ClientData clientData)); /* + * We define a separate AuxDataType struct to hold type-related information + * for the AuxData structure. This separation makes it possible for clients + * outside of the TCL core to manipulate (in a limited fashion!) AuxData; + * for example, it makes it possible to pickle and unpickle AuxData structs. + */ + +typedef struct AuxDataType { + char *name; /* the name of the type. Types can be + * registered and found by name */ + AuxDataDupProc *dupProc; /* Callback procedure to invoke when the + * aux data is duplicated (e.g., when the + * ByteCode structure containing the aux + * data is duplicated). NULL means just + * copy the source clientData bits; no + * proc need be called. */ + AuxDataFreeProc *freeProc; /* Callback procedure to invoke when the + * aux data is freed. NULL means no + * proc need be called. */ +} AuxDataType; + +/* * The definition of the AuxData structure that holds information created * during compilation by CompileProcs and used by instructions during * execution. */ typedef struct AuxData { + AuxDataType *type; /* pointer to the AuxData type associated with + * this ClientData. */ ClientData clientData; /* The compilation data itself. */ - AuxDataDupProc *dupProc; /* Callback procedure to invoke when the - * aux data is duplicated (e.g., when the - * ByteCode structure containing the aux - * data is duplicated). NULL means just - * copy the source clientData bits; no - * proc need be called. */ - AuxDataFreeProc *freeProc; /* Callback procedure to invoke when the - * aux data is freed. NULL means no - * proc need be called. */ } AuxData; /* @@ -268,6 +287,12 @@ typedef struct CompileEnv { * the CmdLocation map, and the compilation AuxData array. */ +/* + * A PRECOMPILED bytecode struct is one that was generated from a compiled + * image rather than implicitly compiled from source + */ +#define TCL_BYTECODE_PRECOMPILED 0x0001 + typedef struct ByteCode { TclHandle interpHandle; /* Handle for interpreter containing the * compiled code. Commands and their compile @@ -278,10 +303,21 @@ typedef struct ByteCode { * ByteCode was compiled. Used to invalidate * code when, e.g., commands with compile * procs are redefined. */ + Namespace *nsPtr; /* Namespace context in which this code + * was compiled. If the code is executed + * if a different namespace, it must be + * recompiled. */ + int nsEpoch; /* Value of nsPtr->resolverEpoch when this + * ByteCode was compiled. Used to invalidate + * code when new namespace resolution rules + * are put into effect. */ int refCount; /* Reference count: set 1 when created * plus 1 for each execution of the code * currently active. This structure can be * freed when refCount becomes zero. */ + unsigned int flags; /* flags describing state for the codebyte. + * this variable holds ORed values from the + * TCL_BYTECODE_ masks defined above */ char *source; /* The source string from which this * ByteCode was compiled. Note that this * pointer is not owned by the ByteCode and @@ -692,9 +728,8 @@ EXTERN int TclCompileScript _ANSI_ARGS_((Tcl_Interp *interp, EXTERN int TclCompileTokens _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Token *tokenPtr, int count, CompileEnv *envPtr)); -EXTERN int TclCreateAuxData _ANSI_ARGS_(( - ClientData clientData, AuxDataDupProc *dupProc, - AuxDataFreeProc *freeProc, CompileEnv *envPtr)); +EXTERN int TclCreateAuxData _ANSI_ARGS_((ClientData clientData, + AuxDataType *typePtr, CompileEnv *envPtr)); EXTERN int TclCreateExceptRange _ANSI_ARGS_(( ExceptionRangeType type, CompileEnv *envPtr)); EXTERN ExecEnv * TclCreateExecEnv _ANSI_ARGS_((Tcl_Interp *interp)); @@ -703,12 +738,18 @@ EXTERN void TclDeleteLiteralTable _ANSI_ARGS_(( Tcl_Interp *interp, LiteralTable *tablePtr)); EXTERN void TclEmitForwardJump _ANSI_ARGS_((CompileEnv *envPtr, TclJumpType jumpType, JumpFixup *jumpFixupPtr)); +EXTERN AuxDataType *TclGetAuxDataType _ANSI_ARGS_((char *typeName)); +EXTERN ExceptionRange * TclGetExceptionRangeForPc _ANSI_ARGS_(( + unsigned char *pc, int catchOnly, + ByteCode* codePtr)); +EXTERN InstructionDesc * TclGetInstructionTable _ANSI_ARGS_(()); EXTERN int TclExecuteByteCode _ANSI_ARGS_((Tcl_Interp *interp, ByteCode *codePtr)); EXTERN void TclExpandCodeArray _ANSI_ARGS_(( CompileEnv *envPtr)); EXTERN void TclExpandJumpFixupArray _ANSI_ARGS_(( JumpFixupArray *fixupArrayPtr)); +EXTERN void TclFinalizeAuxDataTypeTable _ANSI_ARGS_((void)); EXTERN int TclFindCompiledLocal _ANSI_ARGS_((char *name, int nameChars, int create, int flags, Proc *procPtr)); @@ -720,6 +761,7 @@ EXTERN int TclFixupForwardJump _ANSI_ARGS_(( EXTERN void TclFreeCompileEnv _ANSI_ARGS_((CompileEnv *envPtr)); EXTERN void TclFreeJumpFixupArray _ANSI_ARGS_(( JumpFixupArray *fixupArrayPtr)); +EXTERN void TclInitAuxDataTypeTable _ANSI_ARGS_((void)); EXTERN void TclInitByteCodeObj _ANSI_ARGS_((Tcl_Obj *objPtr, CompileEnv *envPtr)); EXTERN void TclInitCompilation _ANSI_ARGS_((void)); @@ -745,6 +787,7 @@ EXTERN void TclPrintObject _ANSI_ARGS_((FILE *outFile, Tcl_Obj *objPtr, int maxChars)); EXTERN void TclPrintSource _ANSI_ARGS_((FILE *outFile, char *string, int maxChars)); +EXTERN void TclRegisterAuxDataType _ANSI_ARGS_((AuxDataType *typePtr)); EXTERN int TclRegisterLiteral _ANSI_ARGS_((CompileEnv *envPtr, char *bytes, int length, int onHeap)); EXTERN void TclReleaseLiteral _ANSI_ARGS_((Tcl_Interp *interp, @@ -930,5 +973,7 @@ EXTERN void TclVerifyLocalLiteralTable _ANSI_ARGS_(( #define TclMin(i, j) ((((int) i) < ((int) j))? (i) : (j)) #define TclMax(i, j) ((((int) i) > ((int) j))? (i) : (j)) -#endif /* _TCLCOMPILATION */ +# undef TCL_STORAGE_CLASS +# define TCL_STORAGE_CLASS DLLIMPORT +#endif /* _TCLCOMPILATION */ diff --git a/generic/tclDate.c b/generic/tclDate.c index cfe2410..1fa8edf 100644 --- a/generic/tclDate.c +++ b/generic/tclDate.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. * - * @(#) tclDate.c 1.33 98/01/12 15:25:37 + * RCS: @(#) $Id: tclDate.c,v 1.1.2.2 1998/09/24 23:58:46 stanton Exp $ */ #include "tclInt.h" diff --git a/generic/tclEnv.c b/generic/tclEnv.c index c11f863..0e471f0 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.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: @(#) tclEnv.c 1.66 98/02/18 16:12:04 + * RCS: @(#) $Id: tclEnv.c,v 1.1.2.2 1998/09/24 23:58:47 stanton Exp $ */ #include "tclInt.h" diff --git a/generic/tclEvent.c b/generic/tclEvent.c index e7ed511..1fc6cb4 100644 --- a/generic/tclEvent.c +++ b/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.173 98/02/18 18:23:41 + * RCS: @(#) $Id: tclEvent.c,v 1.1.2.2 1998/09/24 23:58:47 stanton Exp $ */ #include "tclInt.h" diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 0784f90..22320f7 100644 --- a/generic/tclExecute.c +++ b/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.117 98/02/18 16:14:34 + * RCS: @(#) $Id: tclExecute.c,v 1.1.2.2 1998/09/24 23:58:47 stanton Exp $ */ #include "tclInt.h" @@ -392,6 +392,7 @@ TclCreateExecEnv(interp) Tcl_MutexLock(&execMutex); if (!execInitialized) { + TclInitAuxDataTypeTable(); InitByteCodeExecution(interp); execInitialized = 1; } @@ -450,6 +451,7 @@ TclFinalizeExecution() Tcl_MutexLock(&execMutex); execInitialized = 0; Tcl_MutexUnlock(&execMutex); + TclFinalizeAuxDataTypeTable(); } /* @@ -2632,9 +2634,6 @@ TclExecuteByteCode(interp, codePtr) if (oldValuePtr == NULL) { iterVarPtr->value.objPtr = Tcl_NewLongObj(-1); Tcl_IncrRefCount(iterVarPtr->value.objPtr); - if (oldValuePtr != NULL) { - Tcl_DecrRefCount(oldValuePtr); - } } else { Tcl_SetLongObj(oldValuePtr, -1); } diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 0b291f0..8a7b0ff 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.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: @(#) tclFCmd.c 1.22 98/02/02 21:42:40 + * RCS: @(#) $Id: tclFCmd.c,v 1.1.2.2 1998/09/24 23:58:49 stanton Exp $ */ #include "tclInt.h" @@ -141,9 +141,9 @@ FileCopyRename(interp, argc, argv, copyFlag) result = TCL_OK; /* - * Call stat() so that if target is a symlink that points to a directory - * we will put the sources in that directory instead of overwriting the - * symlink. + * Call TclpStat() so that if target is a symlink that points to a + * directory we will put the sources in that directory instead of + * overwriting the symlink. */ if ((TclpStat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) { @@ -253,8 +253,9 @@ TclFileMakeDirsCmd(interp, argc, argv) char *target = Tcl_JoinPath(j + 1, pargv, &targetBuffer); /* - * Call stat() so that if target is a symlink that points to a - * directory we will create subdirectories in that directory. + * Call TclpStat() so that if target is a symlink that points + * to a directory we will create subdirectories in that + * directory. */ if (TclpStat(target, &statBuf) == 0) { diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 48c2341..13427fc 100644 --- a/generic/tclFileName.c +++ b/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.48 98/02/18 14:42:27 + * RCS: @(#) $Id: tclFileName.c,v 1.1.2.2 1998/09/24 23:58:49 stanton Exp $ */ #include "tclInt.h" diff --git a/generic/tclGet.c b/generic/tclGet.c index 89bd1ce..4287107 100644 --- a/generic/tclGet.c +++ b/generic/tclGet.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: @(#) tclGet.c 1.36 98/01/06 11:04:51 + * RCS: @(#) $Id: tclGet.c,v 1.1.2.2 1998/09/24 23:58:50 stanton Exp $ */ #include "tclInt.h" diff --git a/generic/tclGetDate.y b/generic/tclGetDate.y index 938bb78..3586646 100644 --- a/generic/tclGetDate.y +++ b/generic/tclGetDate.y @@ -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: @(#) tclGetDate.y 1.35 98/01/12 15:25:45 + * RCS: @(#) $Id: tclGetDate.y,v 1.1.2.2 1998/09/24 23:58:50 stanton Exp $ */ %{ diff --git a/generic/tclHash.c b/generic/tclHash.c index 5c0da87..f20588d 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.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: @(#) tclHash.c 1.18 98/01/19 17:25:57 + * RCS: @(#) $Id: tclHash.c,v 1.1.2.2 1998/09/24 23:58:50 stanton Exp $ */ #include "tclInt.h" diff --git a/generic/tclHistory.c b/generic/tclHistory.c index 2210d62..a0c0822 100644 --- a/generic/tclHistory.c +++ b/generic/tclHistory.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: @(#) tclHistory.c 1.51 97/12/22 15:45:29 + * RCS: @(#) $Id: tclHistory.c,v 1.1.2.2 1998/09/24 23:58:51 stanton Exp $ */ #include "tclInt.h" diff --git a/generic/tclIO.c b/generic/tclIO.c index 4d2079f..0faffff 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -4,12 +4,13 @@ * This file provides the generic portions (those that are the same on * all platforms and for all channel types) of Tcl's IO facilities. * + * Copyright (c) 1998 Scriptics Corporation * Copyright (c) 1995-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: @(#) tclIO.c 1.283 98/02/18 16:14:30 + * RCS: @(#) $Id: tclIO.c,v 1.1.2.2 1998/09/24 23:58:51 stanton Exp $ */ #include "tclInt.h" @@ -2817,7 +2818,7 @@ Tcl_GetsObj(chan, objPtr) { GetsState gs; Channel *chanPtr; - int inEofChar, skip; + int inEofChar, skip, copiedTotal; ChannelBuffer *bufPtr; Tcl_Encoding encoding; char *dst, *dstEnd, *eol, *eof; @@ -2826,7 +2827,8 @@ Tcl_GetsObj(chan, objPtr) chanPtr = (Channel *) chan; if (CheckChannelErrors(chanPtr, TCL_READABLE) != 0) { - return -1; + copiedTotal = -1; + goto done; } bufPtr = chanPtr->inQueueHead; @@ -3033,7 +3035,8 @@ Tcl_GetsObj(chan, objPtr) Tcl_SetObjLength(objPtr, 0); CommonGetsCleanup(chanPtr, encoding); - return -1; + copiedTotal = -1; + goto done; } goto goteol; } @@ -3064,7 +3067,8 @@ Tcl_GetsObj(chan, objPtr) Tcl_SetObjLength(objPtr, eol - objPtr->bytes); CommonGetsCleanup(chanPtr, encoding); chanPtr->flags &= ~CHANNEL_BLOCKED; - return gs.totalChars + gs.charsWrote - skip; + copiedTotal = gs.totalChars + gs.charsWrote - skip; + goto done; /* * Couldn't get a complete line. This only happens if we get a error @@ -3097,7 +3101,16 @@ Tcl_GetsObj(chan, objPtr) */ chanPtr->flags |= CHANNEL_NEED_MORE_DATA; - return -1; + copiedTotal = -1; + + done: + /* + * Update the notifier state so we don't block while there is still + * data in the buffers. + */ + + UpdateInterest(chanPtr); + return copiedTotal; } /* @@ -4102,7 +4115,8 @@ Tcl_Ungets(chan, str, len, atEnd) flags = chanPtr->flags; if (CheckChannelErrors(chanPtr, TCL_READABLE) != 0) { - return -1; + len = -1; + goto done; } chanPtr->flags = flags; @@ -4115,7 +4129,7 @@ Tcl_Ungets(chan, str, len, atEnd) */ if (chanPtr->flags & CHANNEL_STICKY_EOF) { - return len; + goto done; } chanPtr->flags &= (~(CHANNEL_BLOCKED | CHANNEL_EOF)); @@ -4138,6 +4152,13 @@ Tcl_Ungets(chan, str, len, atEnd) chanPtr->inQueueHead = bufPtr; } + done: + /* + * Update the notifier state so we don't block while there is still + * data in the buffers. + */ + + UpdateInterest(chanPtr); return len; } @@ -7016,24 +7037,33 @@ DoRead(chanPtr, bufPtr, toRead) toRead - copied); if (copiedNow == 0) { if (chanPtr->flags & CHANNEL_EOF) { - return copied; + goto done; } if (chanPtr->flags & CHANNEL_BLOCKED) { if (chanPtr->flags & CHANNEL_NONBLOCKING) { - return copied; + goto done; } chanPtr->flags &= (~(CHANNEL_BLOCKED)); } result = GetInput(chanPtr); if (result != 0) { - if (result == EAGAIN) { - return copied; + if (result != EAGAIN) { + copied = -1; } - return -1; + goto done; } } } + chanPtr->flags &= (~(CHANNEL_BLOCKED)); + + done: + /* + * Update the notifier state so we don't block while there is still + * data in the buffers. + */ + + UpdateInterest(chanPtr); return copied; } diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index ad76eaa..92ca4cf 100644 --- a/generic/tclIOCmd.c +++ b/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.125 98/02/05 20:21:10 + * RCS: @(#) $Id: tclIOCmd.c,v 1.1.2.2 1998/09/24 23:58:52 stanton Exp $ */ #include "tclInt.h" diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index b0a0c0e..94d8f6c 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.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: @(#) tclIOSock.c 1.22 97/12/08 15:00:32 + * RCS: @(#) $Id: tclIOSock.c,v 1.1.2.2 1998/09/24 23:58:53 stanton Exp $ */ #include "tclInt.h" diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index d5472f9..7bdb93f 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -13,12 +13,65 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclIOUtil.c 1.138 98/01/06 11:10:48 + * RCS: @(#) $Id: tclIOUtil.c,v 1.1.2.2 1998/09/24 23:58:53 stanton Exp $ */ #include "tclInt.h" #include "tclPort.h" + +/* + * The following typedef declarations allow for hooking into the chain + * of functions maintained for 'Tcl_Stat(...)', 'Tcl_Access(...)' & + * 'Tcl_OpenFileChannel(...)'. Basically for each hookable function + * a linked list is defined. + */ + +typedef struct StatProc { + TclStatProc_ *proc; /* Function to process a 'stat()' call */ + struct StatProc *nextPtr; /* The next 'stat()' function to call */ +} StatProc; +typedef struct AccessProc { + TclAccessProc_ *proc; /* Function to process a 'access()' call */ + struct AccessProc *nextPtr; /* The next 'access()' function to call */ +} AccessProc; + +typedef struct OpenFileChannelProc { + TclOpenFileChannelProc_ *proc; /* Function to process a + * 'Tcl_OpenFileChannel()' call */ + struct OpenFileChannelProc *nextPtr; + /* The next 'Tcl_OpenFileChannel()' + * function to call */ +} OpenFileChannelProc; + +/* + * For each type of hookable function, a static node is declared to + * hold the function pointer for the "built-in" routine (e.g. + * 'TclpStat(...)') and the respective list is initialized as a pointer + * to that node. + * + * The "delete" functions (e.g. 'TclStatDeleteProc(...)') ensure that + * these statically declared list entry cannot be inadvertently removed. + * + * This method avoids the need to call any sort of "initialization" + * function + */ + +static StatProc defaultStatProc = { + &TclpStat, NULL +}; +static StatProc *statProcList = &defaultStatProc; + +static AccessProc defaultAccessProc = { + &TclpAccess, NULL +}; +static AccessProc *accessProcList = &defaultAccessProc; + +static OpenFileChannelProc defaultOpenFileChannelProc = { + &TclpOpenFileChannel, NULL +}; +static OpenFileChannelProc *openFileChannelProcList = + &defaultOpenFileChannelProc; /* *--------------------------------------------------------------------------- @@ -235,8 +288,20 @@ Tcl_EvalFile(interp, fileName) result = TCL_ERROR; objPtr = Tcl_NewObj(); - chan = Tcl_OpenFileChannel(NULL, name, "r", 0); - if (chan == NULL) { + if (nativeName != Tcl_DStringValue(&buffer)) { + Tcl_DStringSetLength(&buffer, 0); + Tcl_DStringAppend(&buffer, nativeName, -1); + nativeName = Tcl_DStringValue(&buffer); + } + if (TclpStat(nativeName, &statBuf) == -1) { + Tcl_SetErrno(errno); + Tcl_AppendResult(interp, "couldn't read file \"", fileName, + "\": ", Tcl_PosixError(interp), (char *) NULL); + goto error; + } + chan = Tcl_OpenFileChannel(interp, nativeName, "r", 0644); + if (chan == (Tcl_Channel) NULL) { + Tcl_ResetResult(interp); Tcl_AppendResult(interp, "couldn't read file \"", fileName, "\": ", Tcl_PosixError(interp), (char *) NULL); goto end; @@ -358,3 +423,430 @@ Tcl_PosixError(interp) Tcl_SetErrorCode(interp, "POSIX", id, msg, (char *) NULL); return msg; } + +/* + *---------------------------------------------------------------------- + * + * TclStat -- + * + * This procedure replaces the library version of stat and lsat. + * The chain of functions that have been "inserted" into the + * 'statProcList' will be called in succession until either + * a value of zero is returned, or the entire list is visited. + * + * Results: + * See stat documentation. + * + * Side effects: + * See stat documentation. + * + *---------------------------------------------------------------------- + */ + +int +TclStat(path, buf) + CONST char *path; /* Path of file to stat (in current CP). */ + TclStat_ *buf; /* Filled with results of stat call. */ +{ + StatProc *statProcPtr = statProcList; + int retVal = -1; + + /* + * Call each of the "stat" function in succession. A non-return + * value of -1 indicates the particular function has succeeded. + */ + + while ((retVal == -1) && (statProcPtr != NULL)) { + retVal = (*statProcPtr->proc)(path, buf); + statProcPtr = statProcPtr->nextPtr; + } + + return (retVal); +} + +/* + *---------------------------------------------------------------------- + * + * TclAccess -- + * + * This procedure replaces the library version of access. + * The chain of functions that have been "inserted" into the + * 'accessProcList' will be called in succession until either + * a value of zero is returned, or the entire list is visited. + * + * Results: + * See access documentation. + * + * Side effects: + * See access documentation. + * + *---------------------------------------------------------------------- + */ + +int +TclAccess(path, mode) + CONST char *path; /* Path of file to access (in current CP). */ + int mode; /* Permission setting. */ +{ + AccessProc *accessProcPtr = accessProcList; + int retVal = -1; + + /* + * Call each of the "access" function in succession. A non-return + * value of -1 indicates the particular function has succeeded. + */ + + while ((retVal == -1) && (accessProcPtr != NULL)) { + retVal = (*accessProcPtr->proc)(path, mode); + accessProcPtr = accessProcPtr->nextPtr; + } + + return (retVal); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_OpenFileChannel -- + * + * The chain of functions that have been "inserted" into the + * 'openFileChannelProcList' will be called in succession until + * either a valid file channel is returned, or the entire list is + * visited. + * + * Results: + * The new channel or NULL, if the named file could not be opened. + * + * Side effects: + * May open the channel and may cause creation of a file on the + * file system. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_OpenFileChannel(interp, fileName, modeString, permissions) + Tcl_Interp *interp; /* Interpreter for error reporting; + * can be NULL. */ + char *fileName; /* Name of file to open. */ + char *modeString; /* A list of POSIX open modes or + * a string such as "rw". */ + int permissions; /* If the open involves creating a + * file, with what modes to create + * it? */ +{ + OpenFileChannelProc *openFileChannelProcPtr = openFileChannelProcList; + Tcl_Channel retVal = NULL; + + /* + * Call each of the "Tcl_OpenFileChannel" function in succession. + * A non-NULL return value indicates the particular function has + * succeeded. + */ + + while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) { + retVal = (*openFileChannelProcPtr->proc)(interp, fileName, + modeString, permissions); + openFileChannelProcPtr = openFileChannelProcPtr->nextPtr; + } + + return (retVal); +} + +/* + *---------------------------------------------------------------------- + * + * TclStatInsertProc -- + * + * Insert the passed procedure pointer at the head of the list of + * functions which are used during a call to 'TclStat(...)'. The + * passed function should be have exactly like 'TclStat' when called + * during that time (see 'TclStat(...)' for more informatin). + * The function will be added even if it already in the list. + * + * Results: + * Normally TCL_OK; TCL_ERROR if memory for a new node in the list + * could not be allocated. + * + * Side effects: + * Memory allocataed and modifies the link list for 'TclStat' + * functions. + * + *---------------------------------------------------------------------- + */ + +int +TclStatInsertProc (proc) + TclStatProc_ *proc; +{ + int retVal = TCL_ERROR; + + if (proc != NULL) { + StatProc *newStatProcPtr; + + newStatProcPtr = (StatProc *)Tcl_Alloc(sizeof(StatProc));; + + if (newStatProcPtr != NULL) { + newStatProcPtr->proc = proc; + newStatProcPtr->nextPtr = statProcList; + statProcList = newStatProcPtr; + + retVal = TCL_OK; + } + } + + return (retVal); +} + +/* + *---------------------------------------------------------------------- + * + * TclStatDeleteProc -- + * + * Removed the passed function pointer from the list of 'TclStat' + * functions. Ensures that the built-in stat function is not + * removvable. + * + * Results: + * TCL_OK if the procedure pointer was successfully removed, + * TCL_ERROR otherwise. + * + * Side effects: + * Memory is deallocated and the respective list updated. + * + *---------------------------------------------------------------------- + */ + +int +TclStatDeleteProc (proc) + TclStatProc_ *proc; +{ + int retVal = TCL_ERROR; + StatProc *tmpStatProcPtr = statProcList; + StatProc *prevStatProcPtr = NULL; + + /* + * Traverse the 'statProcList' looking for the particular node + * whose 'proc' member matches 'proc' and remove that one from + * the list. Ensure that the "default" node cannot be removed. + */ + + while ((retVal == TCL_ERROR) && (tmpStatProcPtr != &defaultStatProc)) { + if (tmpStatProcPtr->proc == proc) { + if (prevStatProcPtr == NULL) { + statProcList = tmpStatProcPtr->nextPtr; + } else { + prevStatProcPtr->nextPtr = tmpStatProcPtr->nextPtr; + } + + Tcl_Free((char *)tmpStatProcPtr); + + retVal = TCL_OK; + } else { + prevStatProcPtr = tmpStatProcPtr; + tmpStatProcPtr = tmpStatProcPtr->nextPtr; + } + } + + return (retVal); +} + +/* + *---------------------------------------------------------------------- + * + * TclAccessInsertProc -- + * + * Insert the passed procedure pointer at the head of the list of + * functions which are used during a call to 'TclAccess(...)'. The + * passed function should be have exactly like 'TclAccess' when + * called during that time (see 'TclAccess(...)' for more informatin). + * The function will be added even if it already in the list. + * + * Results: + * Normally TCL_OK; TCL_ERROR if memory for a new node in the list + * could not be allocated. + * + * Side effects: + * Memory allocataed and modifies the link list for 'TclAccess' + * functions. + * + *---------------------------------------------------------------------- + */ + +int +TclAccessInsertProc(proc) + TclAccessProc_ *proc; +{ + int retVal = TCL_ERROR; + + if (proc != NULL) { + AccessProc *newAccessProcPtr; + + newAccessProcPtr = (AccessProc *)Tcl_Alloc(sizeof(AccessProc));; + + if (newAccessProcPtr != NULL) { + newAccessProcPtr->proc = proc; + newAccessProcPtr->nextPtr = accessProcList; + accessProcList = newAccessProcPtr; + + retVal = TCL_OK; + } + } + + return (retVal); +} + +/* + *---------------------------------------------------------------------- + * + * TclAccessDeleteProc -- + * + * Removed the passed function pointer from the list of 'TclAccess' + * functions. Ensures that the built-in access function is not + * removvable. + * + * Results: + * TCL_OK if the procedure pointer was successfully removed, + * TCL_ERROR otherwise. + * + * Side effects: + * Memory is deallocated and the respective list updated. + * + *---------------------------------------------------------------------- + */ + +int +TclAccessDeleteProc(proc) + TclAccessProc_ *proc; +{ + int retVal = TCL_ERROR; + AccessProc *tmpAccessProcPtr = accessProcList; + AccessProc *prevAccessProcPtr = NULL; + + /* + * Traverse the 'accessProcList' looking for the particular node + * whose 'proc' member matches 'proc' and remove that one from + * the list. Ensure that the "default" node cannot be removed. + */ + + while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != &defaultAccessProc)) { + if (tmpAccessProcPtr->proc == proc) { + if (prevAccessProcPtr == NULL) { + accessProcList = tmpAccessProcPtr->nextPtr; + } else { + prevAccessProcPtr->nextPtr = tmpAccessProcPtr->nextPtr; + } + + Tcl_Free((char *)tmpAccessProcPtr); + + retVal = TCL_OK; + } else { + prevAccessProcPtr = tmpAccessProcPtr; + tmpAccessProcPtr = tmpAccessProcPtr->nextPtr; + } + } + + return (retVal); +} + +/* + *---------------------------------------------------------------------- + * + * TclOpenFileChannelInsertProc -- + * + * Insert the passed procedure pointer at the head of the list of + * functions which are used during a call to + * 'Tcl_OpenFileChannel(...)'. The passed function should be have + * exactly like 'Tcl_OpenFileChannel' when called during that time + * (see 'Tcl_OpenFileChannel(...)' for more informatin). The + * function will be added even if it already in the list. + * + * Results: + * Normally TCL_OK; TCL_ERROR if memory for a new node in the list + * could not be allocated. + * + * Side effects: + * Memory allocataed and modifies the link list for + * 'Tcl_OpenFileChannel' functions. + * + *---------------------------------------------------------------------- + */ + +int +TclOpenFileChannelInsertProc(proc) + TclOpenFileChannelProc_ *proc; +{ + int retVal = TCL_ERROR; + + if (proc != NULL) { + OpenFileChannelProc *newOpenFileChannelProcPtr; + + newOpenFileChannelProcPtr = + (OpenFileChannelProc *)Tcl_Alloc(sizeof(OpenFileChannelProc));; + + if (newOpenFileChannelProcPtr != NULL) { + newOpenFileChannelProcPtr->proc = proc; + newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList; + openFileChannelProcList = newOpenFileChannelProcPtr; + + retVal = TCL_OK; + } + } + + return (retVal); +} + +/* + *---------------------------------------------------------------------- + * + * TclOpenFileChannelDeleteProc -- + * + * Removed the passed function pointer from the list of + * 'Tcl_OpenFileChannel' functions. Ensures that the built-in + * open file channel function is not removvable. + * + * Results: + * TCL_OK if the procedure pointer was successfully removed, + * TCL_ERROR otherwise. + * + * Side effects: + * Memory is deallocated and the respective list updated. + * + *---------------------------------------------------------------------- + */ + +int +TclOpenFileChannelDeleteProc(proc) + TclOpenFileChannelProc_ *proc; +{ + int retVal = TCL_ERROR; + OpenFileChannelProc *tmpOpenFileChannelProcPtr = openFileChannelProcList; + OpenFileChannelProc *prevOpenFileChannelProcPtr = NULL; + + /* + * Traverse the 'openFileChannelProcList' looking for the particular + * node whose 'proc' member matches 'proc' and remove that one from + * the list. Ensure that the "default" node cannot be removed. + */ + + while ((retVal == TCL_ERROR) && + (tmpOpenFileChannelProcPtr != &defaultOpenFileChannelProc)) { + if (tmpOpenFileChannelProcPtr->proc == proc) { + if (prevOpenFileChannelProcPtr == NULL) { + openFileChannelProcList = tmpOpenFileChannelProcPtr->nextPtr; + } else { + prevOpenFileChannelProcPtr->nextPtr = + tmpOpenFileChannelProcPtr->nextPtr; + } + + Tcl_Free((char *)tmpOpenFileChannelProcPtr); + + retVal = TCL_OK; + } else { + prevOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr; + tmpOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr->nextPtr; + } + } + + return (retVal); +} diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index f1f0335..32f1955 100644 --- a/generic/tclIndexObj.c +++ b/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.15 97/12/24 13:41:51 + * RCS: @(#) $Id: tclIndexObj.c,v 1.1.2.2 1998/09/24 23:58:53 stanton Exp $ */ #include "tclInt.h" diff --git a/generic/tclInt.h b/generic/tclInt.h index 87e6691..f975005 100644 --- a/generic/tclInt.h +++ b/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.337 98/02/20 10:03:46 + * RCS: @(#) $Id: tclInt.h,v 1.1.2.2 1998/09/24 23:58:53 stanton Exp $ */ #ifndef _TCLINT @@ -54,6 +54,62 @@ # include <varargs.h> #endif +#ifdef BUILD_tcl +# undef TCL_STORAGE_CLASS +# define TCL_STORAGE_CLASS DLLEXPORT +#endif + +/* + * The following procedures allow namespaces to be customized to + * support special name resolution rules for commands/variables. + * + */ + +struct Tcl_ResolvedVarInfo; + +typedef Tcl_Var (Tcl_ResolveRuntimeVarProc) _ANSI_ARGS_(( + Tcl_Interp* interp, struct Tcl_ResolvedVarInfo *vinfoPtr)); + +typedef void (Tcl_ResolveVarDeleteProc) _ANSI_ARGS_(( + struct Tcl_ResolvedVarInfo *vinfoPtr)); + +/* + * The following structure encapsulates the routines needed to resolve a + * variable reference at runtime. Any variable specific state will typically + * be appended to this structure. + */ + + +typedef struct Tcl_ResolvedVarInfo { + Tcl_ResolveRuntimeVarProc *fetchProc; + Tcl_ResolveVarDeleteProc *deleteProc; +} Tcl_ResolvedVarInfo; + + + +typedef int (Tcl_ResolveCompiledVarProc) _ANSI_ARGS_(( + Tcl_Interp* interp, char* name, int length, + Tcl_Namespace *context, Tcl_ResolvedVarInfo **rPtr)); + +typedef int (Tcl_ResolveVarProc) _ANSI_ARGS_(( + Tcl_Interp* interp, char* name, Tcl_Namespace *context, + int flags, Tcl_Var *rPtr)); + +typedef int (Tcl_ResolveCmdProc) _ANSI_ARGS_((Tcl_Interp* interp, + char* name, Tcl_Namespace *context, int flags, + Tcl_Command *rPtr)); + +typedef struct Tcl_ResolverInfo { + Tcl_ResolveCmdProc *cmdResProc; /* Procedure handling command name + * resolution. */ + Tcl_ResolveVarProc *varResProc; /* Procedure handling variable name + * resolution for variables that + * can only be handled at runtime. */ + Tcl_ResolveCompiledVarProc *compiledVarResProc; + /* Procedure handling variable name + * resolution at compile time. */ +} Tcl_ResolverInfo; + /* *---------------------------------------------------------------- * Data structures related to namespaces. @@ -126,6 +182,31 @@ typedef struct Namespace { * namespace has already cached a Command * * pointer; this causes all its cached * Command* pointers to be invalidated. */ + int resolverEpoch; /* Incremented whenever the name resolution + * rules change for this namespace; this + * invalidates all byte codes compiled in + * the namespace, causing the code to be + * recompiled under the new rules. */ + Tcl_ResolveCmdProc *cmdResProc; + /* If non-null, this procedure overrides + * the usual command resolution mechanism + * in Tcl. This procedure is invoked + * within Tcl_FindCommand to resolve all + * command references within the namespace. */ + Tcl_ResolveVarProc *varResProc; + /* If non-null, this procedure overrides + * the usual variable resolution mechanism + * in Tcl. This procedure is invoked + * within Tcl_FindNamespaceVar to resolve all + * variable references within the namespace + * at runtime. */ + Tcl_ResolveCompiledVarProc *compiledVarResProc; + /* If non-null, this procedure overrides + * the usual variable resolution mechanism + * in Tcl. This procedure is invoked + * within LookupCompiledLocal to resolve + * variable references within the namespace + * at compile time. */ } Namespace; /* @@ -336,6 +417,17 @@ typedef struct Var { * initialized and is marked undefined. * The variable's refCount is incremented to * reflect the "reference" from its namespace. + * + * The following additional flags are used with the CompiledLocal type + * defined below: + * + * VAR_ARGUMENT - 1 means that this variable holds a procedure + * argument. + * VAR_TEMPORARY - 1 if the local variable is an anonymous + * temporary variable. Temporaries have a NULL + * name. + * VAR_RESOLVED - 1 if name resolution has been done for this + * variable. */ #define VAR_SCALAR 0x1 @@ -347,6 +439,10 @@ typedef struct Var { #define VAR_ARRAY_ELEMENT 0x40 #define VAR_NAMESPACE_VAR 0x80 +#define VAR_ARGUMENT 0x100 +#define VAR_TEMPORARY 0x200 +#define VAR_RESOLVED 0x400 + /* * Macros to ensure that various flag bits are set properly for variables. * The ANSI C "prototypes" for these macros are: @@ -386,6 +482,9 @@ typedef struct Var { * EXTERN int TclIsVarArray _ANSI_ARGS_((Var *varPtr)); * EXTERN int TclIsVarUndefined _ANSI_ARGS_((Var *varPtr)); * EXTERN int TclIsVarArrayElement _ANSI_ARGS_((Var *varPtr)); + * EXTERN int TclIsVarTemporary _ANSI_ARGS_((Var *varPtr)); + * EXTERN int TclIsVarArgument _ANSI_ARGS_((Var *varPtr)); + * EXTERN int TclIsVarResolved _ANSI_ARGS_((Var *varPtr)); */ #define TclIsVarScalar(varPtr) \ @@ -403,6 +502,15 @@ typedef struct Var { #define TclIsVarArrayElement(varPtr) \ ((varPtr)->flags & VAR_ARRAY_ELEMENT) +#define TclIsVarTemporary(varPtr) \ + ((varPtr)->flags & VAR_TEMPORARY) + +#define TclIsVarArgument(varPtr) \ + ((varPtr)->flags & VAR_ARGUMENT) + +#define TclIsVarResolved(varPtr) \ + ((varPtr)->flags & VAR_RESOLVED) + /* *---------------------------------------------------------------- * Data structures related to procedures. These are used primarily @@ -440,18 +548,21 @@ typedef struct CompiledLocal { * variable lookups. */ int frameIndex; /* Index in the array of compiler-assigned * variables in the procedure call frame. */ - int isArg; /* 1 if the local variable is a formal - * argument. */ - int isTemp; /* 1 if the local variable is an anonymous - * temporary variable. Temporaries have - * a NULL name. */ int flags; /* Flag bits for the local variable. Same as * the flags for the Var structure above, - * although only VAR_SCALAR, VAR_ARRAY, and - * VAR_LINK make sense. */ + * although only VAR_SCALAR, VAR_ARRAY, + * VAR_LINK, VAR_ARGUMENT, VAR_TEMPORARY, and + * VAR_RESOLVED make sense. */ Tcl_Obj *defValuePtr; /* Pointer to the default value of an * argument, if any. NULL if not an argument * or, if an argument, no default value. */ + Tcl_ResolvedVarInfo *resolveInfo; + /* Customized variable resolution info + * supplied by the Tcl_ResolveCompiledVarProc + * associated with a namespace. Each variable + * is marked by a unique ClientData tag + * during compilation, and that same tag + * is used to find the variable at runtime. */ char name[4]; /* Name of the local variable starts here. * If the name is NULL, this will just be * '\0'. The actual size of this field will @@ -918,6 +1029,21 @@ typedef struct ImportRef { } ImportRef; /* + * Data structure used as the ClientData of imported commands: commands + * created in an namespace when it imports a "real" command from another + * namespace. + */ + +typedef struct ImportedCmdData { + struct Command *realCmdPtr; /* "Real" command that this imported command + * refers to. */ + struct Command *selfPtr; /* Pointer to this imported command. Needed + * only when deleting it in order to remove + * it from the real command's linked list of + * imported commands that refer to it. */ +} ImportedCmdData; + +/* * A Command structure exists for each command in a namespace. The * Tcl_Command opaque type actually refers to these structures. */ @@ -969,6 +1095,38 @@ typedef struct Command { /* *---------------------------------------------------------------- + * Data structures related to name resolution procedures. + *---------------------------------------------------------------- + */ + +/* + * The interpreter keeps a linked list of name resolution schemes. + * The scheme for a namespace is consulted first, followed by the + * list of schemes in an interpreter, followed by the default + * name resolution in Tcl. Schemes are added/removed from the + * interpreter's list by calling Tcl_AddInterpResolver and + * Tcl_RemoveInterpResolver. + */ + +typedef struct ResolverScheme { + char *name; /* Name identifying this scheme. */ + Tcl_ResolveCmdProc *cmdResProc; + /* Procedure handling command name + * resolution. */ + Tcl_ResolveVarProc *varResProc; + /* Procedure handling variable name + * resolution for variables that + * can only be handled at runtime. */ + Tcl_ResolveCompiledVarProc *compiledVarResProc; + /* Procedure handling variable name + * resolution at compile time. */ + + struct ResolverScheme *nextPtr; + /* Pointer to next record in linked list. */ +} ResolverScheme; + +/* + *---------------------------------------------------------------- * This structure defines an interpreter, which is a collection of * commands plus other state information related to interpreting * commands, such as variable storage. Primary responsibility for @@ -1135,6 +1293,12 @@ typedef struct Interp { * this is NULL. Set by ObjInterpProc in * tclProc.c and used by tclCompile.c to * process local variables appropriately. */ + ResolverScheme *resolverPtr; + /* Linked list of name resolution schemes + * added to this interpreter. Schemes + * are added/removed by calling + * Tcl_AddInterpResolver and + * Tcl_RemoveInterpResolver. */ char *scriptFile; /* NULL means there is no nested source * command active; otherwise this points to * the name of the file being sourced (it's @@ -1551,6 +1715,25 @@ typedef struct TclFile_ *TclFile; /* *---------------------------------------------------------------- + * Data structures related to hooking 'TclStat(...)' and + * 'TclAccess(...)'. + *---------------------------------------------------------------- + */ + +typedef struct stat TclStat_; +typedef int (TclStatProc_) _ANSI_ARGS_((CONST char *path, TclStat_ *buf)); +typedef int (TclAccessProc_) _ANSI_ARGS_((CONST char *path, int mode)); +typedef Tcl_Channel (TclOpenFileChannelProc_) _ANSI_ARGS_((Tcl_Interp *interp, + char *fileName, char *modeString, + int permissions)); + +typedef int (*TclCmdProcType) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char *argv[])); +typedef int (*TclObjCmdProcType) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST objv[])); + +/* + *---------------------------------------------------------------- * Variables shared among Tcl modules but not used by the outside world. *---------------------------------------------------------------- */ @@ -1603,6 +1786,10 @@ extern char * tclEmptyStringRep; */ EXTERN void panic _ANSI_ARGS_(TCL_VARARGS(char *,format)); +EXTERN int TclAccess _ANSI_ARGS_((CONST char *path, + int mode)); +EXTERN int TclAccessDeleteProc _ANSI_ARGS_((TclAccessProc_ *proc)); +EXTERN int TclAccessInsertProc _ANSI_ARGS_((TclAccessProc_ *proc)); EXTERN void TclAllocateFreeObjects _ANSI_ARGS_((void)); EXTERN int TclCleanupChildren _ANSI_ARGS_((Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, @@ -1687,6 +1874,7 @@ EXTERN char * TclGetExtension _ANSI_ARGS_((char *name)); EXTERN int TclGetFrame _ANSI_ARGS_((Tcl_Interp *interp, char *string, CallFrame **framePtrPtr)); EXTERN int TclGetIdleGeneration _ANSI_ARGS_((void)); +EXTERN TclCmdProcType TclGetInterpProc _ANSI_ARGS_((void)); EXTERN int TclGetIntForIndex _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, int endValue, int *indexPtr)); EXTERN Tcl_Obj * TclGetIndexedScalar _ANSI_ARGS_((Tcl_Interp *interp, @@ -1702,6 +1890,7 @@ EXTERN int TclGetNamespaceForQualName _ANSI_ARGS_(( Namespace **nsPtrPtr, Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr, char **simpleNamePtr)); +EXTERN TclObjCmdProcType TclGetObjInterpProc _ANSI_ARGS_((void)); EXTERN int TclGetOpenMode _ANSI_ARGS_((Tcl_Interp *interp, char *string, int *seekFlagPtr)); EXTERN Tcl_Command TclGetOriginalCommand _ANSI_ARGS_(( @@ -1727,6 +1916,9 @@ EXTERN Tcl_Obj * TclIncrVar2 _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, long incrAmount, int flags)); EXTERN void TclInitAlloc _ANSI_ARGS_((void)); +EXTERN void TclInitCompiledLocals _ANSI_ARGS_(( + Tcl_Interp *interp, CallFrame *framePtr, + Namespace *nsPtr)); EXTERN void TclInitDbCkalloc _ANSI_ARGS_((void)); EXTERN void TclInitEncodingSubsystem _ANSI_ARGS_((void)); EXTERN void TclInitIOSubsystem _ANSI_ARGS_((void)); @@ -1763,6 +1955,10 @@ EXTERN int TclObjInvoke _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], int flags)); EXTERN int TclObjInvokeGlobal _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], int flags)); +EXTERN int TclOpenFileChannelDeleteProc _ANSI_ARGS_(( + TclOpenFileChannelProc_ *proc)); +EXTERN int TclOpenFileChannelInsertProc _ANSI_ARGS_(( + TclOpenFileChannelProc_ *proc)); EXTERN int TclpAccess _ANSI_ARGS_((CONST char *filename, int mode)); EXTERN char * TclpAlloc _ANSI_ARGS_((unsigned int size)); @@ -1786,6 +1982,7 @@ EXTERN int TclpCreateProcess _ANSI_ARGS_((Tcl_Interp *interp, EXTERN TclFile TclpCreateTempFile _ANSI_ARGS_((CONST char *contents)); EXTERN int TclpDeleteFile _ANSI_ARGS_((CONST char *path)); EXTERN void TclpExit _ANSI_ARGS_((int status)); +EXTERN void TclpFinalize _ANSI_ARGS_((void)); EXTERN void TclpFinalizeCondition _ANSI_ARGS_(( Tcl_Condition *condPtr)); EXTERN void TclpFinalizeMutex _ANSI_ARGS_((Tcl_Mutex *mutexPtr)); @@ -1825,6 +2022,9 @@ EXTERN int TclpMatchFiles _ANSI_ARGS_((Tcl_Interp *interp, char *pattern, char *tail)); EXTERN TclFile TclpOpenFile _ANSI_ARGS_((CONST char *fname, int mode)); +EXTERN Tcl_Channel TclpOpenFileChannel _ANSI_ARGS_((Tcl_Interp *interp, + char *fileName, char *modeString, + int permissions)); EXTERN char * TclpReadlink _ANSI_ARGS_((CONST char *fileName, Tcl_DString *linkPtr)); EXTERN char * TclpRealloc _ANSI_ARGS_((char *ptr, @@ -1856,6 +2056,13 @@ EXTERN char * TclPrecTraceProc _ANSI_ARGS_((ClientData clientData, int flags)); EXTERN int TclPreventAliasLoop _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Interp *cmdInterp, Tcl_Command cmd)); +EXTERN void TclProcCleanupProc _ANSI_ARGS_((Proc *procPtr)); +EXTERN int TclProcCompileProc _ANSI_ARGS_((Tcl_Interp *interp, + Proc *procPtr, Tcl_Obj *bodyPtr, Namespace *nsPtr, + CONST char *description, CONST char *procName)); +EXTERN void TclProcDeleteProc _ANSI_ARGS_((ClientData clientData)); +EXTERN int TclProcInterpProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); EXTERN int TclpThreadCreate _ANSI_ARGS_((Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc proc, ClientData clientData)); EXTERN VOID * TclpThreadDataKeyGet _ANSI_ARGS_(( @@ -1881,11 +2088,16 @@ EXTERN void TclSetLibraryPath _ANSI_ARGS_((Tcl_Obj *pathPtr)); EXTERN Tcl_Obj * TclSetIndexedScalar _ANSI_ARGS_((Tcl_Interp *interp, int localIndex, Tcl_Obj *objPtr, int leaveErrorMsg)); +EXTERN char * TclSetPreInitScript _ANSI_ARGS_((char *string)); EXTERN void TclSetupEnv _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN int TclSockGetPort _ANSI_ARGS_((Tcl_Interp *interp, char *string, char *proto, int *portPtr)); EXTERN int TclSockMinimumBuffers _ANSI_ARGS_((int sock, int size)); +EXTERN int TclStat _ANSI_ARGS_((CONST char *path, + TclStat_ *buf)); +EXTERN int TclStatDeleteProc _ANSI_ARGS_((TclStatProc_ *proc)); +EXTERN int TclStatInsertProc _ANSI_ARGS_((TclStatProc_ *proc)); EXTERN void TclTeardownNamespace _ANSI_ARGS_((Namespace *nsPtr)); EXTERN int TclTestChannelCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); @@ -2282,6 +2494,10 @@ extern Tcl_Mutex tclObjMutex; *---------------------------------------------------------------- */ +EXTERN void Tcl_AddInterpResolvers _ANSI_ARGS_((Tcl_Interp *interp, + char *name, Tcl_ResolveCmdProc *cmdProc, + Tcl_ResolveVarProc *varProc, + Tcl_ResolveCompiledVarProc *compiledVarProc)); EXTERN int Tcl_AppendExportList _ANSI_ARGS_(( Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr)); @@ -2299,6 +2515,14 @@ EXTERN Tcl_Command Tcl_FindCommand _ANSI_ARGS_((Tcl_Interp *interp, EXTERN Tcl_Namespace * Tcl_FindNamespace _ANSI_ARGS_((Tcl_Interp *interp, char *name, Tcl_Namespace *contextNsPtr, int flags)); +EXTERN int Tcl_GetInterpResolvers _ANSI_ARGS_((Tcl_Interp *interp, + char *name, Tcl_ResolverInfo *resInfo)); +EXTERN int Tcl_GetNamespaceResolvers _ANSI_ARGS_(( + Tcl_Namespace *namespacePtr, + Tcl_ResolverInfo *resInfo)); +EXTERN void Tcl_GetVariableFullName _ANSI_ARGS_(( + Tcl_Interp *interp, Tcl_Var variable, + Tcl_Obj *objPtr)); EXTERN Tcl_Var Tcl_FindNamespaceVar _ANSI_ARGS_(( Tcl_Interp *interp, char *name, Tcl_Namespace *contextNsPtr, int flags)); @@ -2323,5 +2547,16 @@ EXTERN void Tcl_PopCallFrame _ANSI_ARGS_((Tcl_Interp* interp)); EXTERN int Tcl_PushCallFrame _ANSI_ARGS_((Tcl_Interp* interp, Tcl_CallFrame *framePtr, Tcl_Namespace *nsPtr, int isProcCallFrame)); +EXTERN int Tcl_RemoveInterpResolvers _ANSI_ARGS_(( + Tcl_Interp *interp, char *name)); +EXTERN void Tcl_SetNamespaceResolvers _ANSI_ARGS_(( + Tcl_Namespace *namespacePtr, + Tcl_ResolveCmdProc *cmdProc, + Tcl_ResolveVarProc *varProc, + Tcl_ResolveCompiledVarProc *compiledVarProc)); + +# undef TCL_STORAGE_CLASS +# define TCL_STORAGE_CLASS DLLIMPORT + #endif /* _TCLINT */ diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 36c5738..10a099b 100644 --- a/generic/tclInterp.c +++ b/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.135 98/02/18 15:32:12 + * RCS: @(#) $Id: tclInterp.c,v 1.1.2.2 1998/09/24 23:58:54 stanton Exp $ */ #include <stdio.h> @@ -2315,6 +2315,7 @@ Tcl_MakeSafe(interp) * (the only one remaining is [info nameofexecutable]) */ + Tcl_UnsetVar(interp, "tclDefaultLibrary", TCL_GLOBAL_ONLY); Tcl_UnsetVar(interp, "tcl_library", TCL_GLOBAL_ONLY); Tcl_UnsetVar(interp, "tcl_pkgPath", TCL_GLOBAL_ONLY); diff --git a/generic/tclLink.c b/generic/tclLink.c index 953638e..f66716c 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.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: @(#) tclLink.c 1.18 98/02/18 11:53:10 + * RCS: @(#) $Id: tclLink.c,v 1.1.2.2 1998/09/24 23:58:55 stanton Exp $ */ #include "tclInt.h" diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 004fa24..931c821 100644 --- a/generic/tclListObj.c +++ b/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.53 98/01/06 11:08:29 + * RCS: @(#) $Id: tclListObj.c,v 1.1.2.2 1998/09/24 23:58:55 stanton Exp $ */ #include "tclInt.h" diff --git a/generic/tclLoad.c b/generic/tclLoad.c index bcea456..5678976 100644 --- a/generic/tclLoad.c +++ b/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.30 98/02/19 13:51:49 + * RCS: @(#) $Id: tclLoad.c,v 1.1.2.2 1998/09/24 23:58:55 stanton Exp $ */ #include "tclInt.h" diff --git a/generic/tclLoadNone.c b/generic/tclLoadNone.c index 5bdd026..a4edaca 100644 --- a/generic/tclLoadNone.c +++ b/generic/tclLoadNone.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: @(#) tclLoadNone.c 1.7 97/11/06 15:08:30 + * RCS: @(#) $Id: tclLoadNone.c,v 1.1.2.2 1998/09/24 23:58:56 stanton Exp $ */ #include "tclInt.h" diff --git a/generic/tclMain.c b/generic/tclMain.c index 951b0b4..6fd2aad 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -9,12 +9,15 @@ * 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.68 98/01/20 22:39:24 + * RCS: @(#) $Id: tclMain.c,v 1.1.2.2 1998/09/24 23:58:56 stanton Exp $ */ #include "tcl.h" #include "tclInt.h" +# undef TCL_STORAGE_CLASS +# define TCL_STORAGE_CLASS DLLEXPORT + /* * The following code ensures that tclLink.c is linked whenever * Tcl is linked. Without this code there's no reference to the diff --git a/generic/tclMath.h b/generic/tclMath.h index fdf2ac9..6a0dca4 100644 --- a/generic/tclMath.h +++ b/generic/tclMath.h @@ -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: @(#) tclMath.h 1.2 97/07/23 17:39:14 + * RCS: @(#) $Id: tclMath.h,v 1.1.2.1 1998/09/24 23:58:57 stanton Exp $ */ #ifndef _TCLMATH diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index e159f98..af1b8a9 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -9,6 +9,7 @@ * * Copyright (c) 1993-1997 Lucent Technologies. * Copyright (c) 1997 Sun Microsystems, Inc. + * Copyright (c) 1998 by Scriptics Corporation. * * Originally implemented by * Michael J. McLennan @@ -18,7 +19,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.38 98/02/04 16:21:40 + * RCS: @(#) $Id: tclNamesp.c,v 1.1.2.2 1998/09/24 23:58:57 stanton Exp $ */ #include "tclInt.h" @@ -33,27 +34,19 @@ #define FIND_ONLY_NS 0x1000 /* - * Count of the number of namespaces created. This value is used as a - * unique id for each namespace. + * Initial size of stack allocated space for tail list - used when resetting + * shadowed command references in the functin: TclResetShadowedCmdRefs. */ -static long numNsCreated = 0; -static Tcl_Mutex nsMutex; +#define NUM_TRAIL_ELEMS 5 /* - * Data structure used as the ClientData of imported commands: commands - * created in an namespace when it imports a "real" command from another - * namespace. + * Count of the number of namespaces created. This value is used as a + * unique id for each namespace. */ -typedef struct ImportedCmdData { - Command *realCmdPtr; /* "Real" command that this imported command - * refers to. */ - Command *selfPtr; /* Pointer to this imported command. Needed - * only when deleting it in order to remove - * it from the real command's linked list of - * imported commands that refer to it. */ -} ImportedCmdData; +static long numNsCreated = 0; +static Tcl_Mutex nsMutex; /* * This structure contains a cached pointer to a namespace that is the @@ -538,7 +531,11 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc) nsPtr->exportArrayPtr = NULL; nsPtr->numExportPatterns = 0; nsPtr->maxExportPatterns = 0; - nsPtr->cmdRefEpoch = 0; + nsPtr->cmdRefEpoch = 0; + nsPtr->resolverEpoch = 0; + nsPtr->cmdResProc = NULL; + nsPtr->varResProc = NULL; + nsPtr->compiledVarResProc = NULL; if (parentPtr != NULL) { entryPtr = Tcl_CreateHashEntry(&parentPtr->childTable, simpleName, @@ -876,6 +873,7 @@ NamespaceFree(nsPtr) ckfree((char *) nsPtr); } + /* *---------------------------------------------------------------------- @@ -1072,6 +1070,10 @@ Tcl_AppendExportList(interp, namespacePtr, objPtr) * is NULL). This is done by creating a new command (the "imported * command") that points to the real command in its original namespace. * + * If matching commands are on the autoload path but haven't been + * loaded yet, this command forces them to be loaded, then creates + * the links to them. + * * Results: * Returns TCL_OK if successful, or TCL_ERROR (along with an error * message in the interpreter's result) if something goes wrong. @@ -1107,7 +1109,7 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite) Tcl_HashSearch search; Command *cmdPtr, *realCmdPtr; ImportRef *refPtr; - Tcl_Command importedCmd; + Tcl_Command autoCmd, importedCmd; ImportedCmdData *dataPtr; int wasExported, i, result; @@ -1120,6 +1122,38 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite) } else { nsPtr = (Namespace *) namespacePtr; } + + /* + * First, invoke the "auto_import" command with the pattern + * being imported. This command is part of the Tcl library. + * It looks for imported commands in autoloaded libraries and + * loads them in. That way, they will be found when we try + * to create links below. + */ + + autoCmd = Tcl_FindCommand(interp, "auto_import", + (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY); + + if (autoCmd != NULL) { + Tcl_Obj *objv[2]; + + objv[0] = Tcl_NewStringObj("auto_import", -1); + Tcl_IncrRefCount(objv[0]); + objv[1] = Tcl_NewStringObj(pattern, -1); + Tcl_IncrRefCount(objv[1]); + + cmdPtr = (Command *) autoCmd; + result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, + 2, objv); + + Tcl_DecrRefCount(objv[0]); + Tcl_DecrRefCount(objv[1]); + + if (result != TCL_OK) { + return TCL_ERROR; + } + Tcl_ResetResult(interp); + } /* * From the pattern, find the namespace from which we are importing @@ -1204,8 +1238,8 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite) Tcl_DString ds; Tcl_DStringInit(&ds); - Tcl_DStringAppend(&ds, currNsPtr->fullName, -1); - if (currNsPtr != iPtr->globalNsPtr) { + Tcl_DStringAppend(&ds, nsPtr->fullName, -1); + if (nsPtr != iPtr->globalNsPtr) { Tcl_DStringAppend(&ds, "::", 2); } Tcl_DStringAppend(&ds, cmdName, -1); @@ -1808,7 +1842,7 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, && (nsPtr != globalNsPtr)) { nsPtr = NULL; } - + *nsPtrPtr = nsPtr; *altNsPtrPtr = altNsPtr; Tcl_DStringFree(&buffer); @@ -1919,12 +1953,59 @@ Tcl_FindCommand(interp, name, contextNsPtr, flags) * are given, TCL_GLOBAL_ONLY is * ignored. */ { + Interp *iPtr = (Interp*)interp; + + ResolverScheme *resPtr; Namespace *nsPtr[2], *cxtNsPtr; char *simpleName; register Tcl_HashEntry *entryPtr; register Command *cmdPtr; register int search; int result; + Tcl_Command cmd; + + /* + * If this namespace has a command resolver, then give it first + * crack at the command resolution. If the interpreter has any + * command resolvers, consult them next. The command resolver + * procedures may return a Tcl_Command value, they may signal + * to continue onward, or they may signal an error. + */ + if ((flags & TCL_GLOBAL_ONLY) != 0) { + cxtNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); + } + else if (contextNsPtr != NULL) { + cxtNsPtr = (Namespace *) contextNsPtr; + } + else { + cxtNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + } + + if (cxtNsPtr->cmdResProc != NULL || iPtr->resolverPtr != NULL) { + resPtr = iPtr->resolverPtr; + + if (cxtNsPtr->cmdResProc) { + result = (*cxtNsPtr->cmdResProc)(interp, name, + (Tcl_Namespace *) cxtNsPtr, flags, &cmd); + } else { + result = TCL_CONTINUE; + } + + while (result == TCL_CONTINUE && resPtr) { + if (resPtr->cmdResProc) { + result = (*resPtr->cmdResProc)(interp, name, + (Tcl_Namespace *) cxtNsPtr, flags, &cmd); + } + resPtr = resPtr->nextPtr; + } + + if (result == TCL_OK) { + return cmd; + } + else if (result != TCL_CONTINUE) { + return (Tcl_Command) NULL; + } + } /* * Find the namespace(s) that contain the command. @@ -1960,6 +2041,7 @@ Tcl_FindCommand(interp, name, contextNsPtr, flags) Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "unknown command \"", name, "\"", (char *) NULL); } + return (Tcl_Command) NULL; } @@ -2007,12 +2089,57 @@ Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags) * are given, TCL_GLOBAL_ONLY is * ignored. */ { + Interp *iPtr = (Interp*)interp; + ResolverScheme *resPtr; Namespace *nsPtr[2], *cxtNsPtr; char *simpleName; Tcl_HashEntry *entryPtr; Var *varPtr; register int search; int result; + Tcl_Var var; + + /* + * If this namespace has a variable resolver, then give it first + * crack at the variable resolution. It may return a Tcl_Var + * value, it may signal to continue onward, or it may signal + * an error. + */ + if ((flags & TCL_GLOBAL_ONLY) != 0) { + cxtNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); + } + else if (contextNsPtr != NULL) { + cxtNsPtr = (Namespace *) contextNsPtr; + } + else { + cxtNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + } + + if (cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) { + resPtr = iPtr->resolverPtr; + + if (cxtNsPtr->varResProc) { + result = (*cxtNsPtr->varResProc)(interp, name, + (Tcl_Namespace *) cxtNsPtr, flags, &var); + } else { + result = TCL_CONTINUE; + } + + while (result == TCL_CONTINUE && resPtr) { + if (resPtr->varResProc) { + result = (*resPtr->varResProc)(interp, name, + (Tcl_Namespace *) cxtNsPtr, flags, &var); + } + resPtr = resPtr->nextPtr; + } + + if (result == TCL_OK) { + return var; + } + else if (result != TCL_CONTINUE) { + return (Tcl_Var) NULL; + } + } /* * Find the namespace(s) that contain the variable. @@ -2101,7 +2228,6 @@ TclResetShadowedCmdRefs(interp, newCmdPtr) * storage if needed. */ -#define NUM_TRAIL_ELEMS 5 Namespace *(trailStorage[NUM_TRAIL_ELEMS]); Namespace **trailPtr = trailStorage; int trailFront = -1; @@ -2195,7 +2321,6 @@ TclResetShadowedCmdRefs(interp, newCmdPtr) if (trailPtr != trailStorage) { ckfree((char *) trailPtr); } -#undef NUM_TRAIL_ELEMS } /* @@ -2722,11 +2847,10 @@ NamespaceDeleteCmd(dummy, interp, objc, objv) for (i = 2; i < objc; i++) { name = Tcl_GetString(objv[i]); namespacePtr = Tcl_FindNamespace(interp, name, - (Tcl_Namespace *) NULL, TCL_LEAVE_ERR_MSG); - if (namespacePtr == NULL) { - return TCL_ERROR; + (Tcl_Namespace *) NULL, /* flags */ 0); + if (namespacePtr) { + Tcl_DeleteNamespace(namespacePtr); } - Tcl_DeleteNamespace(namespacePtr); } return TCL_OK; } diff --git a/generic/tclNotify.c b/generic/tclNotify.c index bed8a10..4d85b66 100644 --- a/generic/tclNotify.c +++ b/generic/tclNotify.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: @(#) tclNotify.c 1.23 98/02/19 13:53:03 + * RCS: @(#) $Id: tclNotify.c,v 1.1.2.2 1998/09/24 23:58:59 stanton Exp $ */ #include "tclInt.h" diff --git a/generic/tclObj.c b/generic/tclObj.c index dc6285e..60893ce 100644 --- a/generic/tclObj.c +++ b/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.60 98/02/20 10:24:00 + * RCS: @(#) $Id: tclObj.c,v 1.1.2.2 1998/09/24 23:58:59 stanton Exp $ */ #include "tclInt.h" diff --git a/generic/tclParse.c b/generic/tclParse.c index 9c9398d..36ace07 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.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: @(#) tclParse.c 1.21 98/02/11 18:59:35 + * RCS: @(#) $Id: tclParse.c,v 1.1.2.2 1998/09/24 23:59:00 stanton Exp $ */ #include "tclInt.h" @@ -2032,3 +2032,53 @@ TclObjCommandComplete(objPtr) script = Tcl_GetStringFromObj(objPtr, &length); return CommandComplete(script, length); } + +/* + *---------------------------------------------------------------------- + * + * TclIsLocalScalar -- + * + * Check to see if a given string is a legal scalar variable + * name with no namespace qualifiers or substitutions. + * + * Results: + * Returns 1 if the variable is a local scalar. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclIsLocalScalar(src, len) + CONST char *src; + int len; +{ + char *p; + char *lastChar = src + (len - 1); + + for (p = src; p <= lastChar; p++) { + if ((CHAR_TYPE(p, lastChar) != TCL_NORMAL) && + (CHAR_TYPE(p, lastChar) != TCL_COMMAND_END)) { + /* + * TCL_COMMAND_END is returned for the last character + * of the string. By this point we know it isn't + * an array or namespace reference. + */ + + return 0; + } + if (*p == '(') { + if (*lastChar == ')') { /* we have an array element */ + return 0; + } + } else if (*p == ':') { + if ((p != lastChar) && *(p+1) == ':') { /* qualified name */ + return 0; + } + } + } + + return 1; +} diff --git a/generic/tclPipe.c b/generic/tclPipe.c index 417268c..2ad8a45 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.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: @(#) tclPipe.c 1.17 98/02/17 17:18:19 + * RCS: @(#) $Id: tclPipe.c,v 1.1.2.2 1998/09/24 23:59:00 stanton Exp $ */ #include "tclInt.h" diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 3b88299..075cdcc 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.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: @(#) tclPkg.c 1.13 98/01/06 11:07:58 + * RCS: @(#) $Id: tclPkg.c,v 1.1.2.2 1998/09/24 23:59:01 stanton Exp $ */ #include "tclInt.h" diff --git a/generic/tclPort.h b/generic/tclPort.h index c711cca..78e279f 100644 --- a/generic/tclPort.h +++ b/generic/tclPort.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: @(#) tclPort.h 1.16 98/01/28 17:36:25 + * RCS: @(#) $Id: tclPort.h,v 1.1.2.2 1998/09/24 23:59:01 stanton Exp $ */ #ifndef _TCLPORT diff --git a/generic/tclPosixStr.c b/generic/tclPosixStr.c index ff61bd3..5225b81 100644 --- a/generic/tclPosixStr.c +++ b/generic/tclPosixStr.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: @(#) tclPosixStr.c 1.34 98/02/18 17:34:54 + * RCS: @(#) $Id: tclPosixStr.c,v 1.1.2.2 1998/09/24 23:59:01 stanton Exp $ */ #include "tclInt.h" diff --git a/generic/tclPreserve.c b/generic/tclPreserve.c index d003798..b9ee5ee 100644 --- a/generic/tclPreserve.c +++ b/generic/tclPreserve.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: @(#) tclPreserve.c 1.20 98/02/17 17:20:39 + * RCS: @(#) $Id: tclPreserve.c,v 1.1.2.2 1998/09/24 23:59:02 stanton Exp $ */ #include "tclInt.h" diff --git a/generic/tclProc.c b/generic/tclProc.c index ab2accd..385ad93 100644 --- a/generic/tclProc.c +++ b/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.128 98/02/17 15:57:10 + * RCS: @(#) $Id: tclProc.c,v 1.1.2.2 1998/09/24 23:59:02 stanton Exp $ */ #include "tclInt.h" @@ -20,12 +20,6 @@ * Forward references to procedures defined later in this file: */ -static void CleanupProc _ANSI_ARGS_((Proc *procPtr)); -static int CompileProcBody _ANSI_ARGS_((Tcl_Interp *interp, - Proc *procPtr, char *procName, int nameLen)); -static int InterpProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -static void ProcDeleteProc _ANSI_ARGS_((ClientData clientData)); static int ProcessProcResultCode _ANSI_ARGS_((Tcl_Interp *interp, char *procName, int nameLen, int returnCode)); @@ -56,14 +50,11 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) { register Interp *iPtr = (Interp *) interp; register Proc *procPtr; - char *fullName, *procName, *args, *bytes, *p; - char **argArray = NULL; + char *fullName, *procName; Namespace *nsPtr, *altNsPtr, *cxtNsPtr; - Tcl_Obj *defPtr, *bodyPtr; Tcl_Command cmd; Tcl_DString ds; - int numArgs, length, result, i; - register CompiledLocal *localPtr; + int result; if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "name args body"); @@ -105,6 +96,82 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) } /* + * Create the data structure to represent the procedure. + */ + if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3], + &procPtr) != TCL_OK) { + return TCL_ERROR; + } + + /* + * 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); + if (nsPtr != iPtr->globalNsPtr) { + Tcl_DStringAppend(&ds, nsPtr->fullName, -1); + Tcl_DStringAppend(&ds, "::", 2); + } + Tcl_DStringAppend(&ds, procName, -1); + + Tcl_CreateCommand(interp, Tcl_DStringValue(&ds), TclProcInterpProc, + (ClientData) procPtr, TclProcDeleteProc); + cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds), + TclObjInterpProc, (ClientData) procPtr, TclProcDeleteProc); + + /* + * 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; + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCreateProc -- + * + * Creates the data associated with a Tcl procedure definition. + * + * Results: + * Returns TCL_OK on success, along with a pointer to a Tcl + * procedure definition in procPtrPtr. This definition should + * be freed by calling TclCleanupProc() when it is no longer + * needed. Returns TCL_ERROR if anything goes wrong. + * + * Side effects: + * If anything goes wrong, this procedure returns an error + * message in the interpreter. + * + *---------------------------------------------------------------------- + */ +int +TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr) + Tcl_Interp *interp; /* interpreter containing proc */ + Namespace *nsPtr; /* namespace containing this proc */ + char *procName; /* unqualified name of this proc */ + Tcl_Obj *argsPtr; /* description of arguments */ + Tcl_Obj *bodyPtr; /* command body */ + Proc **procPtrPtr; /* returns: pointer to proc data */ +{ + Interp *iPtr = (Interp*)interp; + char **argArray = NULL; + + register Proc *procPtr; + int i, length, result, numArgs; + char *args, *bytes, *p; + register CompiledLocal *localPtr; + Tcl_Obj *defPtr; + + /* * If the procedure's body object is shared because its string value is * identical to, e.g., the body of another procedure, we must create a * private copy for this procedure to use. Such sharing of procedure @@ -118,10 +185,9 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) * we would not want any bytecode internal representation. */ - bodyPtr = objv[3]; if (Tcl_IsShared(bodyPtr)) { - bytes = Tcl_GetStringFromObj(bodyPtr, &length); - bodyPtr = Tcl_NewStringObj(bytes, length); + bytes = Tcl_GetStringFromObj(bodyPtr, &length); + bodyPtr = Tcl_NewStringObj(bytes, length); } /* @@ -146,9 +212,10 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) /* * Break up the argument list into argument specifiers, then process * each argument specifier. + * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULLS. */ - args = Tcl_GetStringFromObj(objv[2], &length); + args = Tcl_GetStringFromObj(argsPtr, &length); result = Tcl_SplitList(interp, args, &numArgs, &argArray); if (result != TCL_OK) { goto procError; @@ -179,7 +246,7 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) if ((fieldCount == 0) || (*fieldValues[0] == 0)) { ckfree((char *) fieldValues); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "procedure \"", fullName, + "procedure \"", procName, "\" has argument with no name", (char *) NULL); goto procError; } @@ -205,7 +272,7 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) q--; if (*q == ')') { /* we have an array element */ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "procedure \"", fullName, + "procedure \"", procName, "\" has formal parameter \"", fieldValues[0], "\" that is an array element", (char *) NULL); @@ -233,9 +300,9 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) localPtr->nextPtr = NULL; localPtr->nameLength = nameLength; localPtr->frameIndex = i; - localPtr->isArg = 1; - localPtr->isTemp = 0; - localPtr->flags = VAR_SCALAR; + localPtr->flags = VAR_SCALAR | VAR_ARGUMENT; + localPtr->resolveInfo = NULL; + if (fieldCount == 2) { localPtr->defValuePtr = Tcl_NewStringObj(fieldValues[1], valueLength); @@ -249,37 +316,17 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) } /* - * 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); - if (nsPtr != iPtr->globalNsPtr) { - Tcl_DStringAppend(&ds, nsPtr->fullName, -1); - Tcl_DStringAppend(&ds, "::", 2); - } - Tcl_DStringAppend(&ds, procName, -1); - - Tcl_CreateCommand(interp, Tcl_DStringValue(&ds), InterpProc, - (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; - + *procPtrPtr = procPtr; ckfree((char *) argArray); return TCL_OK; - procError: +procError: Tcl_DecrRefCount(bodyPtr); while (procPtr->firstLocalPtr != NULL) { localPtr = procPtr->firstLocalPtr; @@ -496,22 +543,25 @@ TclFindProc(iPtr, procName) Interp *iPtr; /* Interpreter in which to look. */ char *procName; /* Name of desired procedure. */ { - Command *cmdPtr, *realCmdPtr; - - cmdPtr = (Command *) Tcl_FindCommand((Tcl_Interp *) iPtr, procName, + Tcl_Command cmd; + Tcl_Command origCmd; + Command *cmdPtr; + + cmd = Tcl_FindCommand((Tcl_Interp *) iPtr, procName, (Tcl_Namespace *) NULL, /*flags*/ 0); - if (cmdPtr == NULL) { + if (cmd == (Tcl_Command) NULL) { return NULL; } - - if (cmdPtr->proc == InterpProc) { - return (Proc *) cmdPtr->clientData; + cmdPtr = (Command *) cmd; + + origCmd = TclGetOriginalCommand(cmd); + if (origCmd != NULL) { + cmdPtr = (Command *) origCmd; } - realCmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); - if ((realCmdPtr != NULL) && (realCmdPtr->proc == InterpProc)) { - return (Proc *) realCmdPtr->clientData; + if (cmdPtr->proc != TclProcInterpProc) { + return NULL; } - return NULL; + return (Proc *) cmdPtr->clientData; } /* @@ -522,7 +572,7 @@ TclFindProc(iPtr, procName) * Tells whether a command is a Tcl procedure or not. * * Results: - * If the given command is actuall a Tcl procedure, the + * If the given command is actually a Tcl procedure, the * return value is the address of the record describing * the procedure. Otherwise the return value is 0. * @@ -536,7 +586,13 @@ Proc * TclIsProc(cmdPtr) Command *cmdPtr; /* Command to test. */ { - if (cmdPtr->proc == InterpProc) { + Tcl_Command origCmd; + + origCmd = TclGetOriginalCommand((Tcl_Command) cmdPtr); + if (origCmd != NULL) { + cmdPtr = (Command *) origCmd; + } + if (cmdPtr->proc == TclProcInterpProc) { return (Proc *) cmdPtr->clientData; } return (Proc *) 0; @@ -545,7 +601,7 @@ TclIsProc(cmdPtr) /* *---------------------------------------------------------------------- * - * InterpProc -- + * TclProcInterpProc -- * * When a Tcl procedure gets invoked with an argc/argv array of * strings, this routine gets invoked to interpret the procedure. @@ -559,8 +615,8 @@ TclIsProc(cmdPtr) *---------------------------------------------------------------------- */ -static int -InterpProc(clientData, interp, argc, argv) +int +TclProcInterpProc(clientData, interp, argc, argv) ClientData clientData; /* Record describing procedure to be * interpreted. */ Tcl_Interp *interp; /* Interpreter in which procedure was @@ -664,7 +720,7 @@ TclObjInterpProc(clientData, interp, objc, objv) { Interp *iPtr = (Interp *) interp; register Proc *procPtr = (Proc *) clientData; - Tcl_Obj *bodyPtr = procPtr->bodyPtr; + Namespace *nsPtr = procPtr->cmdPtr->nsPtr; CallFrame frame; register CallFrame *framePtr = &frame; register Var *varPtr; @@ -691,28 +747,16 @@ TclObjInterpProc(clientData, interp, objc, objv) /* * If necessary, compile the procedure's body. The compiler will * allocate frame slots for the procedure's non-argument local - * variables. If the ByteCode already exists, make sure it hasn't been - * invalidated by someone redefining a core command (this might make the - * compiled code wrong). Also, if the code was compiled in/for a - * different interpreter, we recompile it. Note that compiling the body - * might increase procPtr->numCompiledLocals if new local variables are - * found while compiling. + * variables. Note that compiling the body might increase + * procPtr->numCompiledLocals if new local variables are found + * while compiling. */ - if (bodyPtr->typePtr == &tclByteCodeType) { - ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr; - - if (((Interp *) *codePtr->interpHandle != iPtr) - || (codePtr->compileEpoch != iPtr->compileEpoch)) { - (*tclByteCodeType.freeIntRepProc)(bodyPtr); - bodyPtr->typePtr = (Tcl_ObjType *) NULL; - } - } - if (bodyPtr->typePtr != &tclByteCodeType) { - result = CompileProcBody(interp, procPtr, procName, nameLen); - if (result != TCL_OK) { - return result; - } + result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr, + "body of proc", procName); + + if (result != TCL_OK) { + return result; } /* @@ -735,34 +779,24 @@ TclObjInterpProc(clientData, interp, objc, objv) */ result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr, - (Tcl_Namespace *) procPtr->cmdPtr->nsPtr, - /*isProcCallFrame*/ 1); + (Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 1); + if (result != TCL_OK) { return result; } + framePtr->objc = objc; framePtr->objv = objv; /* ref counts for args are incremented below */ - framePtr->procPtr = procPtr; - framePtr->numCompiledLocals = localCt; - framePtr->compiledLocals = compiledLocals; /* - * Initialize the array of local variables stored in the call frame. + * Initialize and resolve compiled variable references. */ - varPtr = framePtr->compiledLocals; - for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; - localPtr = localPtr->nextPtr) { - varPtr->value.objPtr = NULL; - varPtr->name = localPtr->name; /* will be just '\0' if temp var */ - varPtr->nsPtr = NULL; - varPtr->hPtr = NULL; - varPtr->refCount = 0; - varPtr->tracePtr = NULL; - varPtr->searchPtr = NULL; - varPtr->flags = (localPtr->flags | VAR_UNDEFINED); - varPtr++; - } + framePtr->procPtr = procPtr; + framePtr->numCompiledLocals = localCt; + framePtr->compiledLocals = compiledLocals; + + TclInitCompiledLocals(interp, framePtr, nsPtr); /* * Match and assign the call's actual parameters to the procedure's @@ -776,12 +810,12 @@ TclObjInterpProc(clientData, interp, objc, objv) localPtr = procPtr->firstLocalPtr; argCt = objc; for (i = 1, argCt -= 1; i <= numArgs; i++, argCt--) { - if (!localPtr->isArg) { + if (!TclIsVarArgument(localPtr)) { panic("TclObjInterpProc: local variable %s is not argument but should be", localPtr->name); return TCL_ERROR; } - if (localPtr->isTemp) { + if (TclIsVarTemporary(localPtr)) { panic("TclObjInterpProc: local variable %d is temporary but should be an argument", i); return TCL_ERROR; } @@ -854,7 +888,7 @@ TclObjInterpProc(clientData, interp, objc, objv) result = Tcl_EvalObj(interp, procPtr->bodyPtr, 0); procPtr->refCount--; if (procPtr->refCount <= 0) { - CleanupProc(procPtr); + TclProcCleanupProc(procPtr); } if (result != TCL_OK) { @@ -878,71 +912,155 @@ TclObjInterpProc(clientData, interp, objc, objv) /* *---------------------------------------------------------------------- * - * CompileProcBody -- + * TclProcCompileProc -- * - * This procedure is called by TclObjInterpProc to compile the body - * script of a Tcl procedure. + * Called just before a procedure is executed to compile the + * body to byte codes. If the type of the body is not + * "byte code" or if the compile conditions have changed + * (namespace context, epoch counters, etc.) then the body + * is recompiled. Otherwise, this procedure does nothing. * * Results: - * If the compilation succeeds, TCL_OK is returned. Otherwise, - * TCL_ERROR is returned and an error message is left in the - * interpreter's result. + * None. * * Side effects: - * Modifies the Tcl object that is the body of the procedure to - * be a ByteCode object. Also arranges (by setting the interpreter's - * compiledProcPtr field) to have the compiler set various fields in - * the procedure's Proc structure such as the number of compiled local - * variables. + * May change the internal representation of the body object + * to compiled code. * *---------------------------------------------------------------------- */ - -static int -CompileProcBody(interp, procPtr, procName, nameLen) - Tcl_Interp *interp; /* The interpreter in which to compile the - * procedure's body. */ - Proc *procPtr; /* Points to structure describing the Tcl - * procedure. */ - char *procName; /* Name of the procedure. Used for error - * messages and trace information. */ - int nameLen; /* Number of bytes in procedure's name. */ + +int +TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName) + Tcl_Interp *interp; /* Interpreter containing procedure. */ + Proc *procPtr; /* Data associated with procedure. */ + Tcl_Obj *bodyPtr; /* Body of proc. (Usually procPtr->bodyPtr, + * but could be any code fragment compiled + * in the context of this procedure.) */ + Namespace *nsPtr; /* Namespace containing procedure. */ + CONST char *description; /* string describing this body of code. */ + CONST char *procName; /* Name of this procedure. */ { - register Interp *iPtr = (Interp *) interp; - Tcl_Obj *bodyPtr = procPtr->bodyPtr; + Interp *iPtr = (Interp*)interp; + int result; + Tcl_CallFrame frame; Proc *saveProcPtr; - char buf[100 + TCL_INTEGER_SPACE]; - int numChars, result; - char *ellipsis; - - if (tclTraceCompile >= 1) { - numChars = nameLen; - ellipsis = ""; - if (numChars > 50) { - numChars = 50; - ellipsis = "..."; - } - fprintf(stdout, "Compiling body of proc \"%.*s%s\"\n", - numChars, procName, ellipsis); + ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr; + + /* + * If necessary, compile the procedure's body. The compiler will + * allocate frame slots for the procedure's non-argument local + * variables. If the ByteCode already exists, make sure it hasn't been + * invalidated by someone redefining a core command (this might make the + * compiled code wrong). Also, if the code was compiled in/for a + * different interpreter, we recompile it. Note that compiling the body + * might increase procPtr->numCompiledLocals if new local variables are + * found while compiling. + * + * Precompiled procedure bodies, however, are immutable and therefore + * they are not recompiled, even if things have changed. + */ + + if (bodyPtr->typePtr == &tclByteCodeType) { + if (((Interp *) *codePtr->interpHandle != iPtr) + || (codePtr->compileEpoch != iPtr->compileEpoch) + || (codePtr->nsPtr != nsPtr)) { + if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { + if ((Interp *) *codePtr->interpHandle != iPtr) { + Tcl_AppendResult(interp, + "a precompiled script jumped interps", NULL); + return TCL_ERROR; + } + codePtr->compileEpoch = iPtr->compileEpoch; + codePtr->nsPtr = nsPtr; + } else { + (*tclByteCodeType.freeIntRepProc)(bodyPtr); + bodyPtr->typePtr = (Tcl_ObjType *) NULL; + } + } } - - saveProcPtr = iPtr->compiledProcPtr; - iPtr->compiledProcPtr = procPtr; - result = tclByteCodeType.setFromAnyProc(interp, bodyPtr); - iPtr->compiledProcPtr = saveProcPtr; - - if (result == TCL_ERROR) { - numChars = nameLen; - ellipsis = ""; - if (numChars > 50) { - numChars = 50; - ellipsis = "..."; + if (bodyPtr->typePtr != &tclByteCodeType) { + char buf[100]; + int numChars; + char *ellipsis; + + if (tclTraceCompile >= 1) { + /* + * Display a line summarizing the top level command we + * are about to compile. + */ + + numChars = strlen(procName); + ellipsis = ""; + if (numChars > 50) { + numChars = 50; + ellipsis = "..."; + } + fprintf(stdout, "Compiling %s \"%.*s%s\"\n", + description, numChars, procName, ellipsis); + } + + /* + * Plug the current procPtr into the interpreter and coerce + * the code body to byte codes. The interpreter needs to + * know which proc it's compiling so that it can access its + * list of compiled locals. + * + * TRICKY NOTE: Be careful to push a call frame with the + * proper namespace context, so that the byte codes are + * compiled in the appropriate class context. + */ + + saveProcPtr = iPtr->compiledProcPtr; + iPtr->compiledProcPtr = procPtr; + + result = Tcl_PushCallFrame(interp, &frame, + (Tcl_Namespace*)nsPtr, /* isProcCallFrame */ 0); + + if (result == TCL_OK) { + result = tclByteCodeType.setFromAnyProc(interp, bodyPtr); + Tcl_PopCallFrame(interp); + } + + iPtr->compiledProcPtr = saveProcPtr; + + if (result != TCL_OK) { + if (result == TCL_ERROR) { + numChars = strlen(procName); + ellipsis = ""; + if (numChars > 50) { + numChars = 50; + ellipsis = "..."; + } + sprintf(buf, "\n (compiling %s \"%.*s%s\", line %d)", + description, numChars, procName, ellipsis, + interp->errorLine); + Tcl_AddObjErrorInfo(interp, buf, -1); + } + return result; + } + } else if (codePtr->nsEpoch != nsPtr->resolverEpoch) { + register CompiledLocal *localPtr; + + /* + * The resolver epoch has changed, but we only need to invalidate + * the resolver cache. + */ + + for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; + localPtr = localPtr->nextPtr) { + localPtr->flags &= ~(VAR_RESOLVED); + if (localPtr->resolveInfo) { + if (localPtr->resolveInfo->deleteProc) { + localPtr->resolveInfo->deleteProc(localPtr->resolveInfo); + } else { + ckfree((char*)localPtr->resolveInfo); + } + localPtr->resolveInfo = NULL; + } } - sprintf(buf, "\n (compiling body of proc \"%.*s%s\", line %d)", - numChars, procName, ellipsis, interp->errorLine); - Tcl_AddObjErrorInfo(interp, buf, -1); } - return result; + return TCL_OK; } /* @@ -1001,7 +1119,7 @@ ProcessProcResultCode(interp, procName, nameLen, returnCode) /* *---------------------------------------------------------------------- * - * ProcDeleteProc -- + * TclProcDeleteProc -- * * This procedure is invoked just before a command procedure is * removed from an interpreter. Its job is to release all the @@ -1018,22 +1136,22 @@ ProcessProcResultCode(interp, procName, nameLen, returnCode) *---------------------------------------------------------------------- */ -static void -ProcDeleteProc(clientData) +void +TclProcDeleteProc(clientData) ClientData clientData; /* Procedure to be deleted. */ { Proc *procPtr = (Proc *) clientData; procPtr->refCount--; if (procPtr->refCount <= 0) { - CleanupProc(procPtr); + TclProcCleanupProc(procPtr); } } /* *---------------------------------------------------------------------- * - * CleanupProc -- + * TclProcCleanupProc -- * * This procedure does all the real work of freeing up a Proc * structure. It's called only when the structure's reference @@ -1048,13 +1166,14 @@ ProcDeleteProc(clientData) *---------------------------------------------------------------------- */ -static void -CleanupProc(procPtr) +void +TclProcCleanupProc(procPtr) register Proc *procPtr; /* Procedure to be deleted. */ { register CompiledLocal *localPtr; Tcl_Obj *bodyPtr = procPtr->bodyPtr; Tcl_Obj *defPtr; + Tcl_ResolvedVarInfo *resVarInfo; if (bodyPtr != NULL) { Tcl_DecrRefCount(bodyPtr); @@ -1062,6 +1181,15 @@ CleanupProc(procPtr) for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; ) { CompiledLocal *nextPtr = localPtr->nextPtr; + resVarInfo = localPtr->resolveInfo; + if (resVarInfo) { + if (resVarInfo->deleteProc) { + (*resVarInfo->deleteProc)(resVarInfo); + } else { + ckfree((char *) resVarInfo); + } + } + if (localPtr->defValuePtr != NULL) { defPtr = localPtr->defValuePtr; Tcl_DecrRefCount(defPtr); @@ -1114,3 +1242,53 @@ TclUpdateReturnInfo(iPtr) } return code; } + +/* + *---------------------------------------------------------------------- + * + * TclGetInterpProc -- + * + * Returns a pointer to the TclProcInterpProc procedure; this is different + * from the value obtained from the TclProcInterpProc reference on systems + * like Windows where import and export versions of a procedure exported + * by a DLL exist. + * + * Results: + * Returns the internal address of the TclProcInterpProc procedure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +TclCmdProcType +TclGetInterpProc() +{ + return TclProcInterpProc; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetObjInterpProc -- + * + * Returns a pointer to the TclObjInterpProc procedure; this is different + * from the value obtained from the TclObjInterpProc reference on systems + * like Windows where import and export versions of a procedure exported + * by a DLL exist. + * + * Results: + * Returns the internal address of the TclProcInterpProc procedure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +TclObjCmdProcType +TclGetObjInterpProc() +{ + return TclObjInterpProc; +} diff --git a/generic/tclRegexp.h b/generic/tclRegexp.h index c545590..be5cb77 100644 --- a/generic/tclRegexp.h +++ b/generic/tclRegexp.h @@ -31,7 +31,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclRegexp.h 1.22 98/01/28 20:44:28 + * RCS: @(#) $Id: tclRegexp.h,v 1.1.2.2 1998/09/24 23:59:02 stanton Exp $ */ #ifndef _TCLREGEXP @@ -41,6 +41,11 @@ #include "tclInt.h" #endif +#ifdef BUILD_tcl +# undef TCL_STORAGE_CLASS +# define TCL_STORAGE_CLASS DLLEXPORT +#endif + /* * The following definitions were culled from wctype.h and wchar.h. * Those two header files are now gone. Eventually we should replace all diff --git a/generic/tclResolve.c b/generic/tclResolve.c new file mode 100644 index 0000000..230e93f --- /dev/null +++ b/generic/tclResolve.c @@ -0,0 +1,423 @@ +/* + * tclResolve.c -- + * + * Contains hooks for customized command/variable name resolution + * schemes. These hooks allow extensions like [incr Tcl] to add + * their own name resolution rules to the Tcl language. Rules can + * be applied to a particular namespace, to the interpreter as a + * whole, or both. + * + * Copyright (c) 1998 Lucent Technologies, Inc. + * + * Originally implemented by + * Michael J. McLennan + * Bell Labs Innovations for Lucent Technologies + * mmclennan@lucent.com + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id: tclResolve.c,v 1.1.2.1 1998/09/24 23:59:02 stanton Exp $ + */ + +#include "tclInt.h" + +/* + * Declarations for procedures local to this file: + */ + +static void BumpCmdRefEpochs _ANSI_ARGS_((Namespace *nsPtr)); + + +/* + *---------------------------------------------------------------------- + * + * Tcl_AddInterpResolvers -- + * + * Adds a set of command/variable resolution procedures to an + * interpreter. These procedures are consulted when commands + * are resolved in Tcl_FindCommand, and when variables are + * resolved in TclLookupVar and LookupCompiledLocal. Each + * namespace may also have its own set of resolution procedures + * which take precedence over those for the interpreter. + * + * When a name is resolved, it is handled as follows. First, + * the name is passed to the resolution procedures for the + * namespace. If not resolved, the name is passed to each of + * the resolution procedures added to the interpreter. Finally, + * if still not resolved, the name is handled using the default + * Tcl rules for name resolution. + * + * Results: + * Returns pointers to the current name resolution procedures + * in the cmdProcPtr, varProcPtr and compiledVarProcPtr + * arguments. + * + * Side effects: + * If a compiledVarProc is specified, this procedure bumps the + * compileEpoch for the interpreter, forcing all code to be + * recompiled. If a cmdProc is specified, this procedure bumps + * the cmdRefEpoch in all namespaces, forcing commands to be + * resolved again using the new rules. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AddInterpResolvers(interp, name, cmdProc, varProc, compiledVarProc) + + Tcl_Interp *interp; /* Interpreter whose name resolution + * rules are being modified. */ + char *name; /* Name of this resolution scheme. */ + Tcl_ResolveCmdProc *cmdProc; /* New procedure for command + * resolution */ + Tcl_ResolveVarProc *varProc; /* Procedure for variable resolution + * at runtime */ + Tcl_ResolveCompiledVarProc *compiledVarProc; + /* Procedure for variable resolution + * at compile time. */ +{ + Interp *iPtr = (Interp*)interp; + ResolverScheme *resPtr; + + /* + * Since we're adding a new name resolution scheme, we must force + * all code to be recompiled to use the new scheme. If there + * are new compiled variable resolution rules, bump the compiler + * epoch to invalidate compiled code. If there are new command + * resolution rules, bump the cmdRefEpoch in all namespaces. + */ + if (compiledVarProc) { + iPtr->compileEpoch++; + } + if (cmdProc) { + BumpCmdRefEpochs(iPtr->globalNsPtr); + } + + /* + * Look for an existing scheme with the given name. If found, + * then replace its rules. + */ + for (resPtr = iPtr->resolverPtr; resPtr != NULL; resPtr = resPtr->nextPtr) { + if (*name == *resPtr->name && strcmp(name, resPtr->name) == 0) { + resPtr->cmdResProc = cmdProc; + resPtr->varResProc = varProc; + resPtr->compiledVarResProc = compiledVarProc; + return; + } + } + + /* + * Otherwise, this is a new scheme. Add it to the FRONT + * of the linked list, so that it overrides existing schemes. + */ + resPtr = (ResolverScheme *) ckalloc(sizeof(ResolverScheme)); + resPtr->name = (char*)ckalloc((unsigned)(strlen(name)+1)); + strcpy(resPtr->name, name); + resPtr->cmdResProc = cmdProc; + resPtr->varResProc = varProc; + resPtr->compiledVarResProc = compiledVarProc; + resPtr->nextPtr = iPtr->resolverPtr; + iPtr->resolverPtr = resPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetInterpResolvers -- + * + * Looks for a set of command/variable resolution procedures with + * the given name in an interpreter. These procedures are + * registered by calling Tcl_AddInterpResolvers. + * + * Results: + * If the name is recognized, this procedure returns non-zero, + * along with pointers to the name resolution procedures in + * the Tcl_ResolverInfo structure. If the name is not recognized, + * this procedure returns zero. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetInterpResolvers(interp, name, resInfoPtr) + + Tcl_Interp *interp; /* Interpreter whose name resolution + * rules are being queried. */ + char *name; /* Look for a scheme with this name. */ + Tcl_ResolverInfo *resInfoPtr; /* Returns pointers to the procedures, + * if found */ +{ + Interp *iPtr = (Interp*)interp; + ResolverScheme *resPtr; + + /* + * Look for an existing scheme with the given name. If found, + * then return pointers to its procedures. + */ + for (resPtr = iPtr->resolverPtr; resPtr != NULL; resPtr = resPtr->nextPtr) { + if (*name == *resPtr->name && strcmp(name, resPtr->name) == 0) { + resInfoPtr->cmdResProc = resPtr->cmdResProc; + resInfoPtr->varResProc = resPtr->varResProc; + resInfoPtr->compiledVarResProc = resPtr->compiledVarResProc; + return 1; + } + } + + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RemoveInterpResolvers -- + * + * Removes a set of command/variable resolution procedures + * previously added by Tcl_AddInterpResolvers. The next time + * a command/variable name is resolved, these procedures + * won't be consulted. + * + * Results: + * Returns non-zero if the name was recognized and the + * resolution scheme was deleted. Returns zero otherwise. + * + * Side effects: + * If a scheme with a compiledVarProc was deleted, this procedure + * bumps the compileEpoch for the interpreter, forcing all code + * to be recompiled. If a scheme with a cmdProc was deleted, + * this procedure bumps the cmdRefEpoch in all namespaces, + * forcing commands to be resolved again using the new rules. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_RemoveInterpResolvers(interp, name) + + Tcl_Interp *interp; /* Interpreter whose name resolution + * rules are being modified. */ + char *name; /* Name of the scheme to be removed. */ +{ + Interp *iPtr = (Interp*)interp; + ResolverScheme **prevPtrPtr, *resPtr; + + /* + * Look for an existing scheme with the given name. + */ + prevPtrPtr = &iPtr->resolverPtr; + for (resPtr = iPtr->resolverPtr; resPtr != NULL; resPtr = resPtr->nextPtr) { + if (*name == *resPtr->name && strcmp(name, resPtr->name) == 0) { + break; + } + prevPtrPtr = &resPtr->nextPtr; + } + + /* + * If we found the scheme, delete it. + */ + if (resPtr) { + /* + * If we're deleting a scheme with compiled variable resolution + * rules, bump the compiler epoch to invalidate compiled code. + * If we're deleting a scheme with command resolution rules, + * bump the cmdRefEpoch in all namespaces. + */ + if (resPtr->compiledVarResProc) { + iPtr->compileEpoch++; + } + if (resPtr->cmdResProc) { + BumpCmdRefEpochs(iPtr->globalNsPtr); + } + + *prevPtrPtr = resPtr->nextPtr; + ckfree(resPtr->name); + ckfree((char *) resPtr); + + return 1; + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * BumpCmdRefEpochs -- + * + * This procedure is used to bump the cmdRefEpoch counters in + * the specified namespace and all of its child namespaces. + * It is used whenever name resolution schemes are added/removed + * from an interpreter, to invalidate all command references. + * + * Results: + * None. + * + * Side effects: + * Bumps the cmdRefEpoch in the specified namespace and its + * children, recursively. + * + *---------------------------------------------------------------------- + */ + +static void +BumpCmdRefEpochs(nsPtr) + Namespace *nsPtr; /* Namespace being modified. */ +{ + Tcl_HashEntry *entry; + Tcl_HashSearch search; + Namespace *childNsPtr; + + nsPtr->cmdRefEpoch++; + + for (entry = Tcl_FirstHashEntry(&nsPtr->childTable, &search); + entry != NULL; + entry = Tcl_NextHashEntry(&search)) { + + childNsPtr = (Namespace *) Tcl_GetHashValue(entry); + BumpCmdRefEpochs(childNsPtr); + } +} + + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetNamespaceResolvers -- + * + * Sets the command/variable resolution procedures for a namespace, + * thereby changing the way that command/variable names are + * interpreted. This allows extension writers to support different + * name resolution schemes, such as those for object-oriented + * packages. + * + * Command resolution is handled by a procedure of the following + * type: + * + * typedef int (Tcl_ResolveCmdProc) _ANSI_ARGS_(( + * Tcl_Interp* interp, char* name, Tcl_Namespace *context, + * int flags, Tcl_Command *rPtr)); + * + * Whenever a command is executed or Tcl_FindCommand is invoked + * within the namespace, this procedure is called to resolve the + * command name. If this procedure is able to resolve the name, + * it should return the status code TCL_OK, along with the + * corresponding Tcl_Command in the rPtr argument. Otherwise, + * the procedure can return TCL_CONTINUE, and the command will + * be treated under the usual name resolution rules. Or, it can + * return TCL_ERROR, and the command will be considered invalid. + * + * Variable resolution is handled by two procedures. The first + * is called whenever a variable needs to be resolved at compile + * time: + * + * typedef int (Tcl_ResolveCompiledVarProc) _ANSI_ARGS_(( + * Tcl_Interp* interp, char* name, Tcl_Namespace *context, + * Tcl_ResolvedVarInfo *rPtr)); + * + * If this procedure is able to resolve the name, it should return + * the status code TCL_OK, along with variable resolution info in + * the rPtr argument; this info will be used to set up compiled + * locals in the call frame at runtime. The procedure may also + * return TCL_CONTINUE, and the variable will be treated under + * the usual name resolution rules. Or, it can return TCL_ERROR, + * and the variable will be considered invalid. + * + * Another procedure is used whenever a variable needs to be + * resolved at runtime but it is not recognized as a compiled local. + * (For example, the variable may be requested via + * Tcl_FindNamespaceVar.) This procedure has the following type: + * + * typedef int (Tcl_ResolveVarProc) _ANSI_ARGS_(( + * Tcl_Interp* interp, char* name, Tcl_Namespace *context, + * int flags, Tcl_Var *rPtr)); + * + * This procedure is quite similar to the compile-time version. + * It returns the same status codes, but if variable resolution + * succeeds, this procedure returns a Tcl_Var directly via the + * rPtr argument. + * + * Results: + * Nothing. + * + * Side effects: + * Bumps the command epoch counter for the namespace, invalidating + * all command references in that namespace. Also bumps the + * resolver epoch counter for the namespace, forcing all code + * in the namespace to be recompiled. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetNamespaceResolvers(namespacePtr, cmdProc, varProc, compiledVarProc) + Tcl_Namespace *namespacePtr; /* Namespace whose resolution rules + * are being modified. */ + Tcl_ResolveCmdProc *cmdProc; /* Procedure for command resolution */ + Tcl_ResolveVarProc *varProc; /* Procedure for variable resolution + * at runtime */ + Tcl_ResolveCompiledVarProc *compiledVarProc; + /* Procedure for variable resolution + * at compile time. */ +{ + Namespace *nsPtr = (Namespace*)namespacePtr; + + /* + * Plug in the new command resolver, and bump the epoch counters + * so that all code will have to be recompiled and all commands + * will have to be resolved again using the new policy. + */ + nsPtr->cmdResProc = cmdProc; + nsPtr->varResProc = varProc; + nsPtr->compiledVarResProc = compiledVarProc; + + nsPtr->cmdRefEpoch++; + nsPtr->resolverEpoch++; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetNamespaceResolvers -- + * + * Returns the current command/variable resolution procedures + * for a namespace. By default, these procedures are NULL. + * New procedures can be installed by calling + * Tcl_SetNamespaceResolvers, to provide new name resolution + * rules. + * + * Results: + * Returns non-zero if any name resolution procedures have been + * assigned to this namespace; also returns pointers to the + * procedures in the Tcl_ResolverInfo structure. Returns zero + * otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetNamespaceResolvers(namespacePtr, resInfoPtr) + + Tcl_Namespace *namespacePtr; /* Namespace whose resolution rules + * are being modified. */ + Tcl_ResolverInfo *resInfoPtr; /* Returns: pointers for all + * name resolution procedures + * assigned to this namespace. */ +{ + Namespace *nsPtr = (Namespace*)namespacePtr; + + resInfoPtr->cmdResProc = nsPtr->cmdResProc; + resInfoPtr->varResProc = nsPtr->varResProc; + resInfoPtr->compiledVarResProc = nsPtr->compiledVarResProc; + + if (nsPtr->cmdResProc != NULL || + nsPtr->varResProc != NULL || + nsPtr->compiledVarResProc != NULL) { + return 1; + } + return 0; +} diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index f55fafc..2dc4a95 100644 --- a/generic/tclStringObj.c +++ b/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.35 97/11/13 13:40:07 + * RCS: @(#) $Id: tclStringObj.c,v 1.1.2.2 1998/09/24 23:59:02 stanton Exp $ */ #include "tclInt.h" diff --git a/generic/tclTest.c b/generic/tclTest.c index 316dec3..8da6785 100644 --- a/generic/tclTest.c +++ b/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.145 98/02/17 11:19:22 + * RCS: @(#) $Id: tclTest.c,v 1.1.2.2 1998/09/24 23:59:02 stanton Exp $ */ #define TCL_TEST @@ -158,6 +158,14 @@ static int RegGetCompFlags _ANSI_ARGS_((char *s)); static int RegGetExecFlags _ANSI_ARGS_((char *s)); static void SpecialFree _ANSI_ARGS_((char *blockPtr)); static int StaticInitProc _ANSI_ARGS_((Tcl_Interp *interp)); +static int TestaccessprocCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestAccessProc1 _ANSI_ARGS_((CONST char *path, + int mode)); +static int TestAccessProc2 _ANSI_ARGS_((CONST char *path, + int mode)); +static int TestAccessProc3 _ANSI_ARGS_((CONST char *path, + int mode)); static int TestasyncCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); static int TestcmdinfoCmd _ANSI_ARGS_((ClientData dummy, @@ -220,6 +228,12 @@ static int TestMathFunc _ANSI_ARGS_((ClientData clientData, static int TestMathFunc2 _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr)); +static Tcl_Channel TestOpenFileChannelProc1 _ANSI_ARGS_((Tcl_Interp *interp, + char *filename, char *modeString, int permissions)); +static Tcl_Channel TestOpenFileChannelProc2 _ANSI_ARGS_((Tcl_Interp *interp, + char *filename, char *modeString, int permissions)); +static Tcl_Channel TestOpenFileChannelProc3 _ANSI_ARGS_((Tcl_Interp *interp, + char *filename, char *modeString, int permissions)); static int TestpanicCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); static int TestparserObjCmd _ANSI_ARGS_((ClientData dummy, @@ -245,6 +259,8 @@ static int TestsetnoerrCmd _ANSI_ARGS_((ClientData dummy, static int TestsetobjerrorcodeCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +static int TestopenfilechannelprocCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); static int TestsetplatformCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); static int TestsetrecursionlimitCmd _ANSI_ARGS_(( @@ -252,6 +268,14 @@ static int TestsetrecursionlimitCmd _ANSI_ARGS_(( int objc, Tcl_Obj *CONST objv[])); static int TeststaticpkgCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); +static int TestStatProc1 _ANSI_ARGS_((CONST char *path, + TclStat_ *buf)); +static int TestStatProc2 _ANSI_ARGS_((CONST char *path, + TclStat_ *buf)); +static int TestStatProc3 _ANSI_ARGS_((CONST char *path, + TclStat_ *buf)); +static int TeststatprocCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); static int TesttranslatefilenameCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); static int TestupvarCmd _ANSI_ARGS_((ClientData dummy, @@ -305,6 +329,8 @@ Tcltest_Init(interp) (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testaccessproc", TestaccessprocCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testasync", TestasyncCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testchannel", TclTestChannelCmd, @@ -361,6 +387,9 @@ Tcltest_Init(interp) (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testopenfilechannelproc", + TestopenfilechannelprocCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd, @@ -396,6 +425,8 @@ Tcltest_Init(interp) (ClientData) 123); Tcl_CreateMathFunc(interp, "T2", 0, (Tcl_ValueType *) NULL, TestMathFunc, (ClientData) 345); + Tcl_CreateCommand(interp, "teststatproc", TeststatprocCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); t3ArgTypes[0] = TCL_EITHER; t3ArgTypes[1] = TCL_EITHER; Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2, @@ -3866,3 +3897,344 @@ TestsaveresultFree(blockPtr) { freeCount++; } + +/* + *---------------------------------------------------------------------- + * + * TeststatprocCmd -- + * + * Implements the "testTclStatProc" cmd that is used to test the + * 'TclStatInsertProc' & 'TclStatDeleteProc' C Apis. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TeststatprocCmd (dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + register Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + TclStatProc_ *proc; + int retVal; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option arg\"", (char *) NULL); + return TCL_ERROR; + } + + if (strcmp(argv[2], "TclpStat") == 0) { + proc = TclpStat; + } else if (strcmp(argv[2], "TestStatProc1") == 0) { + proc = TestStatProc1; + } else if (strcmp(argv[2], "TestStatProc2") == 0) { + proc = TestStatProc2; + } else if (strcmp(argv[2], "TestStatProc3") == 0) { + proc = TestStatProc3; + } else { + Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ", + "must be TclpStat, ", + "TestStatProc1, TestStatProc2, or TestStatProc3", + (char *) NULL); + return TCL_ERROR; + } + + if (strcmp(argv[1], "insert") == 0) { + if (proc == TclpStat) { + Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ", + "must be ", + "TestStatProc1, TestStatProc2, or TestStatProc3", + (char *) NULL); + return TCL_ERROR; + } + retVal = TclStatInsertProc(proc); + } else if (strcmp(argv[1], "delete") == 0) { + retVal = TclStatDeleteProc(proc); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], "\": ", + "must be insert or delete", (char *) NULL); + return TCL_ERROR; + } + + if (retVal == TCL_ERROR) { + Tcl_AppendResult(interp, "\"", argv[2], "\": ", + "could not be ", argv[1], "ed", (char *) NULL); + } + + return retVal; +} + + +static int +TestStatProc1(path, buf) + CONST char *path; + TclStat_ *buf; +{ + buf->st_size = 1234; + return (strcmp("testStat1%.fil", path) ? -1 : 0); +} + + +static int +TestStatProc2(path, buf) + CONST char *path; + TclStat_ *buf; +{ + buf->st_size = 2345; + return (strcmp("testStat2%.fil", path) ? -1 : 0); +} + + +static int +TestStatProc3(path, buf) + CONST char *path; + TclStat_ *buf; +{ + buf->st_size = 3456; + return (strcmp("testStat3%.fil", path) ? -1 : 0); +} + +/* + *---------------------------------------------------------------------- + * + * TestaccessprocCmd -- + * + * Implements the "testTclAccessProc" cmd that is used to test the + * 'TclAccessInsertProc' & 'TclAccessDeleteProc' C Apis. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestaccessprocCmd (dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + register Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + TclAccessProc_ *proc; + int retVal; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option arg\"", (char *) NULL); + return TCL_ERROR; + } + + if (strcmp(argv[2], "TclpAccess") == 0) { + proc = TclpAccess; + } else if (strcmp(argv[2], "TestAccessProc1") == 0) { + proc = TestAccessProc1; + } else if (strcmp(argv[2], "TestAccessProc2") == 0) { + proc = TestAccessProc2; + } else if (strcmp(argv[2], "TestAccessProc3") == 0) { + proc = TestAccessProc3; + } else { + Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ", + "must be TclpAccess, ", + "TestAccessProc1, TestAccessProc2, or TestAccessProc3", + (char *) NULL); + return TCL_ERROR; + } + + if (strcmp(argv[1], "insert") == 0) { + if (proc == TclpAccess) { + Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ", + "must be ", + "TestAccessProc1, TestAccessProc2, or TestAccessProc3", + (char *) NULL); + return TCL_ERROR; + } + retVal = TclAccessInsertProc(proc); + } else if (strcmp(argv[1], "delete") == 0) { + retVal = TclAccessDeleteProc(proc); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], "\": ", + "must be insert or delete", (char *) NULL); + return TCL_ERROR; + } + + if (retVal == TCL_ERROR) { + Tcl_AppendResult(interp, "\"", argv[2], "\": ", + "could not be ", argv[1], "ed", (char *) NULL); + } + + return retVal; +} + + +static int +TestAccessProc1(path, mode) + CONST char *path; + int mode; +{ + return (strcmp("testAccess1%.fil", path) ? -1 : 0); +} + + +static int +TestAccessProc2(path, mode) + CONST char *path; + int mode; +{ + return (strcmp("testAccess2%.fil", path) ? -1 : 0); +} + + +static int +TestAccessProc3(path, mode) + CONST char *path; + int mode; +{ + return (strcmp("testAccess3%.fil", path) ? -1 : 0); +} + +/* + *---------------------------------------------------------------------- + * + * TestopenfilechannelprocCmd -- + * + * Implements the "testTclOpenFileChannelProc" cmd that is used to test the + * 'TclOpenFileChannelInsertProc' & 'TclOpenFileChannelDeleteProc' C Apis. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestopenfilechannelprocCmd (dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + register Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + TclOpenFileChannelProc_ *proc; + int retVal; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option arg\"", (char *) NULL); + return TCL_ERROR; + } + + if (strcmp(argv[2], "TclpOpenFileChannel") == 0) { + proc = TclpOpenFileChannel; + } else if (strcmp(argv[2], "TestOpenFileChannelProc1") == 0) { + proc = TestOpenFileChannelProc1; + } else if (strcmp(argv[2], "TestOpenFileChannelProc2") == 0) { + proc = TestOpenFileChannelProc2; + } else if (strcmp(argv[2], "TestOpenFileChannelProc3") == 0) { + proc = TestOpenFileChannelProc3; + } else { + Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ", + "must be TclpOpenFileChannel, ", + "TestOpenFileChannelProc1, TestOpenFileChannelProc2, or ", + "TestOpenFileChannelProc3", + (char *) NULL); + return TCL_ERROR; + } + + if (strcmp(argv[1], "insert") == 0) { + if (proc == TclpOpenFileChannel) { + Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ", + "must be ", + "TestOpenFileChannelProc1, TestOpenFileChannelProc2, or ", + "TestOpenFileChannelProc3", + (char *) NULL); + return TCL_ERROR; + } + retVal = TclOpenFileChannelInsertProc(proc); + } else if (strcmp(argv[1], "delete") == 0) { + retVal = TclOpenFileChannelDeleteProc(proc); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], "\": ", + "must be insert or delete", (char *) NULL); + return TCL_ERROR; + } + + if (retVal == TCL_ERROR) { + Tcl_AppendResult(interp, "\"", argv[2], "\": ", + "could not be ", argv[1], "ed", (char *) NULL); + } + + return retVal; +} + + +static Tcl_Channel +TestOpenFileChannelProc1(interp, fileName, modeString, permissions) + Tcl_Interp *interp; /* Interpreter for error reporting; + * can be NULL. */ + char *fileName; /* Name of file to open. */ + char *modeString; /* A list of POSIX open modes or + * a string such as "rw". */ + int permissions; /* If the open involves creating a + * file, with what modes to create + * it? */ +{ + if (!strcmp("testOpenFileChannel1%.fil", fileName)) { + return (TclpOpenFileChannel(interp, "__testOpenFileChannel1%__.fil", + modeString, permissions)); + } else { + return (NULL); + } +} + + +static Tcl_Channel +TestOpenFileChannelProc2(interp, fileName, modeString, permissions) + Tcl_Interp *interp; /* Interpreter for error reporting; + * can be NULL. */ + char *fileName; /* Name of file to open. */ + char *modeString; /* A list of POSIX open modes or + * a string such as "rw". */ + int permissions; /* If the open involves creating a + * file, with what modes to create + * it? */ +{ + if (!strcmp("testOpenFileChannel2%.fil", fileName)) { + return (TclpOpenFileChannel(interp, "__testOpenFileChannel2%__.fil", + modeString, permissions)); + } else { + return (NULL); + } +} + + +static Tcl_Channel +TestOpenFileChannelProc3(interp, fileName, modeString, permissions) + Tcl_Interp *interp; /* Interpreter for error reporting; + * can be NULL. */ + char *fileName; /* Name of file to open. */ + char *modeString; /* A list of POSIX open modes or + * a string such as "rw". */ + int permissions; /* If the open involves creating a + * file, with what modes to create + * it? */ +{ + if (!strcmp("testOpenFileChannel3%.fil", fileName)) { + return (TclpOpenFileChannel(interp, "__testOpenFileChannel3%__.fil", + modeString, permissions)); + } else { + return (NULL); + } +} diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index a446ece..471fe63 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.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: @(#) tclTestObj.c 1.35 98/02/11 16:46:28 + * RCS: @(#) $Id: tclTestObj.c,v 1.1.2.2 1998/09/24 23:59:03 stanton Exp $ */ #include "tclInt.h" diff --git a/generic/tclTimer.c b/generic/tclTimer.c index c6c07df..1d9d373 100644 --- a/generic/tclTimer.c +++ b/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.19 98/02/17 23:44:52 + * RCS: @(#) $Id: tclTimer.c,v 1.1.2.2 1998/09/24 23:59:04 stanton Exp $ */ #include "tclInt.h" diff --git a/generic/tclUtil.c b/generic/tclUtil.c index aa9b0d7..1c2338b 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -10,13 +10,22 @@ * 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.178 98/02/19 11:51:59 + * RCS: @(#) $Id: tclUtil.c,v 1.1.2.2 1998/09/24 23:59:04 stanton Exp $ */ #include "tclInt.h" #include "tclPort.h" /* + * The following variable holds the full path name of the binary + * from which this application was executed, or NULL if it isn't + * know. The value of the variable is set by the procedure + * Tcl_FindExecutable. The storage space is dynamically allocated. + */ + +char *tclExecutableName = NULL; + +/* * The following values are used in the flags returned by Tcl_ScanElement * and used by Tcl_ConvertElement. The value TCL_DONT_USE_BRACES is also * defined in tcl.h; make sure its value doesn't overlap with any of the @@ -2048,3 +2057,30 @@ TclGetIntForIndex(interp, objPtr, endValue, indexPtr) *indexPtr = index; return TCL_OK; } + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetNameOfExecutable -- + * + * This procedure simply returns a pointer to the internal full + * path name of the executable file as computed by + * Tcl_FindExecutable. This procedure call is the C API + * equivalent to the "info nameofexecutable" command. + * + * Results: + * A pointer to the internal string or NULL if the internal full + * path name has not been computed or unknown. + * + * Side effects: + * The object referenced by "objPtr" might be converted to an + * integer object. + * + *---------------------------------------------------------------------- + */ + +CONST char * +Tcl_GetNameOfExecutable() +{ + return (tclExecutableName); +} diff --git a/generic/tclVar.c b/generic/tclVar.c index 2a7e365..c4cc847 100644 --- a/generic/tclVar.c +++ b/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.142 98/02/17 23:44:47 + * RCS: @(#) $Id: tclVar.c,v 1.1.2.2 1998/09/24 23:59:04 stanton Exp $ */ #include "tclInt.h" @@ -135,7 +135,8 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, * parens around the index. Otherwise they * are NULL. These are needed to restore * the parens after parsing the name. */ - Namespace *varNsPtr, *dummy1Ptr, *dummy2Ptr; + Namespace *varNsPtr, *cxtNsPtr, *dummy1Ptr, *dummy2Ptr; + ResolverScheme *resPtr; Tcl_HashEntry *hPtr; register char *p; int new, i, result; @@ -145,9 +146,6 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, openParen = closeParen = NULL; varNsPtr = NULL; /* set non-NULL if a nonlocal variable */ - - elName = part2; - /* * Parse part1 into array name and index. * Always check if part1 is an array element name and allow it only if @@ -158,6 +156,7 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, * the part2's test and error reporting or move that code in array set) */ + elName = part2; for (p = part1; *p ; p++) { if (*p == '(') { openParen = p; @@ -184,6 +183,44 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, } /* + * If this namespace has a variable resolver, then give it first + * crack at the variable resolution. It may return a Tcl_Var + * value, it may signal to continue onward, or it may signal + * an error. + */ + if ((flags & TCL_GLOBAL_ONLY) != 0 || iPtr->varFramePtr == NULL) { + cxtNsPtr = iPtr->globalNsPtr; + } else { + cxtNsPtr = iPtr->varFramePtr->nsPtr; + } + + if (cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) { + resPtr = iPtr->resolverPtr; + + if (cxtNsPtr->varResProc) { + result = (*cxtNsPtr->varResProc)(interp, part1, + (Tcl_Namespace *) cxtNsPtr, flags, &var); + } else { + result = TCL_CONTINUE; + } + + while (result == TCL_CONTINUE && resPtr) { + if (resPtr->varResProc) { + result = (*resPtr->varResProc)(interp, part1, + (Tcl_Namespace *) cxtNsPtr, flags, &var); + } + resPtr = resPtr->nextPtr; + } + + if (result == TCL_OK) { + varPtr = (Var *) var; + goto lookupVarPart2; + } else if (result != TCL_CONTINUE) { + return (Var *) NULL; + } + } + + /* * Look up part1. Look it up as either a namespace variable or as a * local variable in a procedure call frame (varFramePtr). * Interpret part1 as a namespace variable if: @@ -254,7 +291,7 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, int part1Len = strlen(part1); for (i = 0; i < localCt; i++) { - if (!localPtr->isTemp) { + if (!TclIsVarTemporary(localPtr)) { register char *localName = localVarPtr->name; if ((part1[0] == localName[0]) && (part1Len == localPtr->nameLength) @@ -299,6 +336,8 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, } } } + +lookupVarPart2: if (openParen != NULL) { *openParen = '('; openParen = NULL; @@ -2671,9 +2710,18 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { + /* + * The list of constants below should match the arrayOptions string array + * below. + */ + + enum {ARRAY_ANYMORE, ARRAY_DONESEARCH, ARRAY_EXISTS, ARRAY_GET, + ARRAY_NAMES, ARRAY_NEXTELEMENT, ARRAY_SET, ARRAY_SIZE, + ARRAY_STARTSEARCH}; static char *arrayOptions[] = {"anymore", "donesearch", "exists", "get", "names", "nextelement", "set", "size", "startsearch", (char *) NULL}; + Interp *iPtr = (Interp *) interp; Var *varPtr, *arrayPtr; Tcl_HashEntry *hPtr; @@ -2723,7 +2771,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) } switch (index) { - case 0: { /* anymore */ + case ARRAY_ANYMORE: { ArraySearch *searchPtr; char *searchId; @@ -2758,7 +2806,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) Tcl_SetIntObj(resultPtr, 1); break; } - case 1: { /* donesearch */ + case ARRAY_DONESEARCH: { ArraySearch *searchPtr, *prevPtr; char *searchId; @@ -2789,7 +2837,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) ckfree((char *) searchPtr); break; } - case 2: { /* exists */ + case ARRAY_EXISTS: { if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); return TCL_ERROR; @@ -2797,7 +2845,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) Tcl_SetIntObj(resultPtr, !notArray); break; } - case 3: { /*get*/ + case ARRAY_GET: { Tcl_HashSearch search; Var *varPtr2; char *pattern = NULL; @@ -2849,7 +2897,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) } break; } - case 4: { /* names */ + case ARRAY_NAMES: { Tcl_HashSearch search; Var *varPtr2; char *pattern = NULL; @@ -2886,7 +2934,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) } break; } - case 5: { /*nextelement*/ + case ARRAY_NEXTELEMENT: { ArraySearch *searchPtr; char *searchId; Tcl_HashEntry *hPtr; @@ -2925,7 +2973,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), -1); break; } - case 6: { /*set*/ + case ARRAY_SET: { Tcl_Obj **elemPtrs; int listLen, i, result; @@ -2953,31 +3001,49 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) break; } } - } else if (varPtr == NULL) { - /* - * The list is empty and the array variable doesn't - * exist yet: create the variable with an empty array - * as the value. - */ - - Tcl_Obj *valuePtr; + return result; + } - valuePtr = Tcl_NewObj(); - if (Tcl_SetObjVar2(interp, Tcl_GetString(objv[2]), - "tempElem", valuePtr, /* flags*/ 0) == NULL) { - Tcl_DecrRefCount(valuePtr); + /* + * The list is empty make sure we have an array, or create + * one if necessary. + */ + + if (varPtr != NULL) { + if (!TclIsVarUndefined(varPtr) && TclIsVarArray(varPtr)) { + /* + * Already an array, done. + */ + + return TCL_OK; + } + if (TclIsVarArrayElement(varPtr) || + !TclIsVarUndefined(varPtr)) { + /* + * Either an array element, or a scalar: lose! + */ + + VarErrMsg(interp, varName, (char *)NULL, "array set", + needArray); return TCL_ERROR; - } - result = Tcl_UnsetVar2(interp, varName, "tempElem", - TCL_LEAVE_ERR_MSG); - if (result != TCL_OK) { - Tcl_DecrRefCount(valuePtr); - return result; - } + } + } else { + /* + * Create variable for new array. + */ + + varPtr = TclLookupVar(interp, varName, (char *) NULL, 0, 0, + /*createPart1*/ 1, /*createPart2*/ 0, + &arrayPtr); } - return result; + TclSetVarArray(varPtr); + TclClearVarUndefined(varPtr); + varPtr->value.tablePtr = + (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS); + return TCL_OK; } - case 7: { /*size*/ + case ARRAY_SIZE: { Tcl_HashSearch search; Var *varPtr2; int size; @@ -3001,7 +3067,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) Tcl_SetIntObj(resultPtr, size); break; } - case 8: { /*startsearch*/ + case ARRAY_STARTSEARCH: { ArraySearch *searchPtr; if (objc != 3) { @@ -3145,7 +3211,7 @@ MakeUpvar(iPtr, framePtr, otherP1, otherP2, otherFlags, myName, myFlags) * leaving the namespace var's reference invalid. */ - if (otherPtr->nsPtr == NULL) { + if ((otherP2 ? arrayPtr->nsPtr : otherPtr->nsPtr) == NULL) { Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"", myName, "\": upvar won't create namespace variable that refers to procedure variable", (char *) NULL); @@ -3171,7 +3237,7 @@ MakeUpvar(iPtr, framePtr, otherP1, otherP2, otherFlags, myName, myFlags) varPtr = NULL; for (i = 0; i < localCt; i++) { - if (!localPtr->isTemp) { + if (!TclIsVarTemporary(localPtr)) { char *localName = localVarPtr->name; if ((myName[0] == localName[0]) && (nameLen == localPtr->nameLength) @@ -4129,6 +4195,7 @@ TclDeleteVars(iPtr, tablePtr) if (TclIsVarArray(varPtr)) { DeleteArray(iPtr, Tcl_GetHashKey(tablePtr, hPtr), varPtr, flags); + varPtr->value.tablePtr = NULL; } if (TclIsVarScalar(varPtr) && (varPtr->value.objPtr != NULL)) { objPtr = varPtr->value.objPtr; |