diff options
author | escoffon <escoffon@noemail.net> | 1998-07-01 19:08:21 (GMT) |
---|---|---|
committer | escoffon <escoffon@noemail.net> | 1998-07-01 19:08:21 (GMT) |
commit | fec207b454b1bb037aa9d1697fada998c65fcc1d (patch) | |
tree | 3f17ff710b2f551cdac37c439b2fd217437261e3 /generic | |
parent | f621363b96e71aafb0cbbd863fc186c2f24ac35f (diff) | |
download | tcl-fec207b454b1bb037aa9d1697fada998c65fcc1d.zip tcl-fec207b454b1bb037aa9d1697fada998c65fcc1d.tar.gz tcl-fec207b454b1bb037aa9d1697fada998c65fcc1d.tar.bz2 |
Merged changes between child workspace "/home/escoffon/ws/tcl8.0" and
parent workspace "/ws/tcl8.0".
FossilOrigin-Name: 8be93cc2840296948ed2ca4488b8f655c858786d
Diffstat (limited to 'generic')
-rw-r--r-- | generic/tcl.h | 34 | ||||
-rw-r--r-- | generic/tclBasic.c | 6 | ||||
-rw-r--r-- | generic/tclCompile.c | 186 |
3 files changed, 201 insertions, 25 deletions
diff --git a/generic/tcl.h b/generic/tcl.h index 77719ee..d9fa893 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: %Z% $Id: tcl.h,v 1.7 1998/06/29 18:08:50 welch Exp $ + * SCCS: %Z% $Id: tcl.h,v 1.8 1998/07/01 19:08:21 escoffon Exp $ */ #ifndef _TCL @@ -70,10 +70,6 @@ # ifndef USE_TCLALLOC # define USE_TCLALLOC 1 # endif -# ifndef STRINGIFY -# define STRINGIFY(x) STRINGIFY1(x) -# define STRINGIFY1(x) #x -# endif #endif /* __WIN32__ */ /* @@ -93,6 +89,34 @@ # endif #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 diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 40813ec..e8db382 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: %Z% $Id: tclBasic.c,v 1.4 1998/06/29 17:32:09 welch Exp $ + * SCCS: %Z% $Id: tclBasic.c,v 1.5 1998/07/01 19:09:11 escoffon Exp $ */ #include "tclInt.h" @@ -3494,8 +3494,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/tclCompile.c b/generic/tclCompile.c index 48b5641..4c40d64 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclCompile.c 1.80 97/09/18 18:23:30 + * SCCS: %Z% $Id: tclCompile.c,v 1.6 1998/07/01 19:12:42 escoffon Exp $ */ #include "tclInt.h" @@ -352,6 +352,14 @@ unsigned char tclTypeTable[] = { }; /* + * Table of all AuxData types. + */ + +static Tcl_HashTable auxDataTypeTable; +static int auxDataTypeTableInitialized = 0; /* 0 means not yet + * initialized. */ + +/* * Prototypes for procedures defined later in this file: */ @@ -418,6 +426,16 @@ Tcl_ObjType tclByteCodeType = { UpdateStringOfByteCode, /* updateStringProc */ SetByteCodeFromAny /* setFromAnyProc */ }; + +/* + * The structures below define the AuxData types defined in this file. + */ + +AuxDataType tclForeachInfoType = { + "ForeachInfo", /* name */ + DupForeachInfo, /* dupProc */ + FreeForeachInfo /* freeProc */ +}; /* *---------------------------------------------------------------------- @@ -966,8 +984,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++; } @@ -1077,8 +1095,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++; } @@ -4533,7 +4551,7 @@ TclCompileForeachCmd(interp, string, lastChar, flags, envPtr) infoPtr->varLists[i] = varListPtr; } infoIndex = TclCreateAuxData((ClientData) infoPtr, - DupForeachInfo, FreeForeachInfo, envPtr); + &tclForeachInfoType, envPtr); /* * Emit code to store each value list into the associated temporary. @@ -7447,17 +7465,12 @@ CreateExceptionRange(type, envPtr) */ int -TclCreateAuxData(clientData, dupProc, freeProc, envPtr) +TclCreateAuxData(clientData, typePtr, 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. */ + * in the new aux data record. */ + AuxDataType *typePtr; /* Pointer to the type to attach to this AuxData */ register CompileEnv *envPtr;/* Points to the CompileEnv for which a new - * aux data structure is to be allocated. */ + * aux data structure is to be allocated. */ { int index; /* Index for the new AuxData structure. */ register AuxData *auxDataPtr; @@ -7493,9 +7506,8 @@ TclCreateAuxData(clientData, dupProc, freeProc, envPtr) envPtr->auxDataArrayNext++; auxDataPtr = &(envPtr->auxDataArrayPtr[index]); + auxDataPtr->type = typePtr; auxDataPtr->clientData = clientData; - auxDataPtr->dupProc = dupProc; - auxDataPtr->freeProc = freeProc; return index; } @@ -7806,5 +7818,145 @@ TclGetInstructionTable() { return &instructionTable[0]; } + +/* + *-------------------------------------------------------------- + * + * TclRegisterAuxDataType -- + * + * This procedure is called to register a new AuxData type + * in the table of all AuxData types supported by Tcl. + * + * Results: + * None. + * + * Side effects: + * The type is registered in the AuxData type table. If there was already + * a type with the same name as in typePtr, it is replaced with the + * new type. + * + *-------------------------------------------------------------- + */ +void +TclRegisterAuxDataType(typePtr) + AuxDataType *typePtr; /* Information about object type; + * storage must be statically + * allocated (must live forever). */ +{ + register Tcl_HashEntry *hPtr; + int new; + if (!auxDataTypeTableInitialized) { + TclInitAuxDataTypeTable(); + } + + /* + * If there's already a type with the given name, remove it. + */ + + hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typePtr->name); + if (hPtr != (Tcl_HashEntry *) NULL) { + Tcl_DeleteHashEntry(hPtr); + } + + /* + * Now insert the new object type. + */ + + hPtr = Tcl_CreateHashEntry(&auxDataTypeTable, typePtr->name, &new); + if (new) { + Tcl_SetHashValue(hPtr, typePtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclGetAuxDataType -- + * + * This procedure looks up an Auxdata type by name. + * + * Results: + * If an AuxData type with name matching "typeName" is found, a pointer + * to its AuxDataType structure is returned; otherwise, NULL is returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +AuxDataType * +TclGetAuxDataType(typeName) + char *typeName; /* Name of AuxData type to look up. */ +{ + register Tcl_HashEntry *hPtr; + AuxDataType *typePtr = NULL; + + if (!auxDataTypeTableInitialized) { + TclInitAuxDataTypeTable(); + } + + hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typeName); + if (hPtr != (Tcl_HashEntry *) NULL) { + typePtr = (AuxDataType *) Tcl_GetHashValue(hPtr); + } + + return typePtr; +} + +/* + *-------------------------------------------------------------- + * + * TclInitAuxDataTypeTable -- + * + * This procedure is invoked to perform once-only initialization of + * the AuxData type table. It also registers the AuxData types defined in + * this file. + * + * Results: + * None. + * + * Side effects: + * Initializes the table of defined AuxData types "auxDataTypeTable" with + * builtin AuxData types defined in this file. + * + *-------------------------------------------------------------- + */ + +void +TclInitAuxDataTypeTable() +{ + auxDataTypeTableInitialized = 1; + + Tcl_InitHashTable(&auxDataTypeTable, TCL_STRING_KEYS); + TclRegisterAuxDataType(&tclForeachInfoType); +} + +/* + *---------------------------------------------------------------------- + * + * TclFinalizeAuxDataTypeTable -- + * + * This procedure is called by Tcl_Finalize after all exit handlers + * have been run to free up storage associated with the table of AuxData + * types. + * + * Results: + * None. + * + * Side effects: + * Deletes all entries in the hash table of AuxData types, "auxDataTypeTable". + * + *---------------------------------------------------------------------- + */ + +void +TclFinalizeAuxDataTypeTable() +{ + if (auxDataTypeTableInitialized) { + Tcl_DeleteHashTable(&auxDataTypeTable); + auxDataTypeTableInitialized = 0; + } +} |