diff options
| -rw-r--r-- | generic/tclCompile.c | 111 | ||||
| -rw-r--r-- | generic/tclInt.decls | 16 | ||||
| -rw-r--r-- | generic/tclInt.h | 13 | ||||
| -rw-r--r-- | generic/tclIntDecls.h | 29 | ||||
| -rw-r--r-- | generic/tclLiteral.c | 151 | ||||
| -rw-r--r-- | generic/tclStubInit.c | 5 |
6 files changed, 269 insertions, 56 deletions
diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 12b6cd4..25803a0 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. * - * RCS: @(#) $Id: tclCompile.c,v 1.14 1999/04/16 00:46:44 stanton Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.15 1999/04/22 22:57:06 stanton Exp $ */ #include "tclInt.h" @@ -255,13 +255,16 @@ Tcl_ObjType tclByteCodeType = { }; /* - *----------------------------------------------------------------------- + *---------------------------------------------------------------------- * - * SetByteCodeFromAny -- + * TclSetByteCodeFromAny -- * * Part of the bytecode Tcl object type implementation. Attempts to * generate an byte code internal form for the Tcl object "objPtr" by - * compiling its string representation. + * compiling its string representation. This function also takes + * a hook procedure that will be invoked to perform any needed post + * processing on the compilation results before generating byte + * codes. * * Results: * The return value is a standard Tcl object result. If an error occurs @@ -277,11 +280,13 @@ Tcl_ObjType tclByteCodeType = { *---------------------------------------------------------------------- */ -static int -SetByteCodeFromAny(interp, objPtr) +int +TclSetByteCodeFromAny(interp, objPtr, hookProc, clientData) Tcl_Interp *interp; /* The interpreter for which the code is * being compiled. Must not be NULL. */ Tcl_Obj *objPtr; /* The object to make a ByteCode object. */ + CompileHookProc *hookProc; /* Procedure to invoke after compilation. */ + ClientData clientData; /* Hook procedure private data. */ { Interp *iPtr = (Interp *) interp; CompileEnv compEnv; /* Compilation environment structure @@ -309,6 +314,40 @@ SetByteCodeFromAny(interp, objPtr) string = Tcl_GetStringFromObj(objPtr, &length); TclInitCompileEnv(interp, &compEnv, string, length); result = TclCompileScript(interp, string, length, nested, &compEnv); + + if (result == TCL_OK) { + /* + * Successful compilation. Add a "done" instruction at the end. + */ + + compEnv.numSrcBytes = iPtr->termOffset; + TclEmitOpcode(INST_DONE, &compEnv); + + /* + * Invoke the compilation hook procedure if one exists. + */ + + if (hookProc) { + result = (*hookProc)(interp, &compEnv, clientData); + } + + /* + * Change the object into a ByteCode object. Ownership of the literal + * objects and aux data items is given to the ByteCode object. + */ + +#ifdef TCL_COMPILE_DEBUG + TclVerifyLocalLiteralTable(&compEnv); +#endif /*TCL_COMPILE_DEBUG*/ + + TclInitByteCodeObj(objPtr, &compEnv); +#ifdef TCL_COMPILE_DEBUG + if (tclTraceCompile == 2) { + TclPrintByteCodeObj(interp, objPtr); + } +#endif /* TCL_COMPILE_DEBUG */ + } + if (result != TCL_OK) { /* * Compilation errors. @@ -330,36 +369,13 @@ SetByteCodeFromAny(interp, objPtr) } auxDataPtr++; } - goto done; } - /* - * Successful compilation. Add a "done" instruction at the end. - */ - - compEnv.numSrcBytes = iPtr->termOffset; - TclEmitOpcode(INST_DONE, &compEnv); - - /* - * Change the object into a ByteCode object. Ownership of the literal - * objects and aux data items is given to the ByteCode object. - */ - -#ifdef TCL_COMPILE_DEBUG - TclVerifyLocalLiteralTable(&compEnv); -#endif /*TCL_COMPILE_DEBUG*/ - TclInitByteCodeObj(objPtr, &compEnv); -#ifdef TCL_COMPILE_DEBUG - if (tclTraceCompile == 2) { - TclPrintByteCodeObj(interp, objPtr); - } -#endif /* TCL_COMPILE_DEBUG */ /* * Free storage allocated during compilation. */ - done: if (localTablePtr->buckets != localTablePtr->staticBuckets) { ckfree((char *) localTablePtr->buckets); } @@ -368,6 +384,39 @@ SetByteCodeFromAny(interp, objPtr) } /* + *----------------------------------------------------------------------- + * + * SetByteCodeFromAny -- + * + * Part of the bytecode Tcl object type implementation. Attempts to + * generate an byte code internal form for the Tcl object "objPtr" by + * compiling its string representation. + * + * Results: + * The return value is a standard Tcl object result. If an error occurs + * during compilation, an error message is left in the interpreter's + * result unless "interp" is NULL. + * + * Side effects: + * Frees the old internal representation. If no error occurs, then the + * compiled code is stored as "objPtr"s bytecode representation. + * Also, if debugging, initializes the "tcl_traceCompile" Tcl variable + * used to trace compilations. + * + *---------------------------------------------------------------------- + */ + +static int +SetByteCodeFromAny(interp, objPtr) + Tcl_Interp *interp; /* The interpreter for which the code is + * being compiled. Must not be NULL. */ + Tcl_Obj *objPtr; /* The object to make a ByteCode object. */ +{ + return TclSetByteCodeFromAny(interp, objPtr, + (CompileHookProc *) NULL, (ClientData) NULL); +} + +/* *---------------------------------------------------------------------- * * DupByteCodeInternalRep -- @@ -923,7 +972,7 @@ TclCompileScript(interp, script, numBytes, nested, envPtr) */ if (envPtr->codeNext == entryCodeNext) { - TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*alreadyAlloced*/ 0), + TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr); maxDepth = 1; } @@ -1185,7 +1234,7 @@ TclCompileTokens(interp, tokenPtr, count, envPtr) */ if (envPtr->codeNext == entryCodeNext) { - TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*alreadyAlloced*/ 0), + TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr); maxDepth = 1; } diff --git a/generic/tclInt.decls b/generic/tclInt.decls index a643e81..d0244ce 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -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. # -# RCS: @(#) $Id: tclInt.decls,v 1.8 1999/04/21 21:50:26 rjohnson Exp $ +# RCS: @(#) $Id: tclInt.decls,v 1.9 1999/04/22 22:57:07 stanton Exp $ library tcl @@ -525,10 +525,22 @@ declare 139 generic { declare 140 generic { int TclLooksLikeInt(char *bytes, int length) } - declare 141 generic { char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr) } +declare 142 generic { + int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr, \ + CompileHookProc *hookProc, ClientData clientData) +} +declare 143 generic { + int TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr, \ + LiteralEntry **litPtrPtr) +} +declare 144 generic { + void TclHideLiteral(Tcl_Interp *interp, struct CompileEnv *envPtr, \ + int index) +} + ############################################################################## # Define the platform specific internal Tcl interface. These functions are diff --git a/generic/tclInt.h b/generic/tclInt.h index dfc28fc..39032cf 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.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. * - * RCS: @(#) $Id: tclInt.h,v 1.27 1999/04/21 21:50:26 rjohnson Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.28 1999/04/22 22:57:07 stanton Exp $ */ #ifndef _TCLINT @@ -810,7 +810,6 @@ typedef void (Tcl_ThreadCreateProc) _ANSI_ARGS_((ClientData clientData)); * CompileProc declared below. */ -struct Tcl_Parse; struct CompileEnv; /* @@ -833,7 +832,15 @@ struct CompileEnv; #define TCL_OUT_LINE_COMPILE (TCL_CONTINUE + 1) typedef int (CompileProc) _ANSI_ARGS_((Tcl_Interp *interp, - struct Tcl_Parse *parsePtr, struct CompileEnv *compEnvPtr)); + Tcl_Parse *parsePtr, struct CompileEnv *compEnvPtr)); + +/* + * The type of procedure called from the compilation hook point in + * SetByteCodeFromAny. + */ + +typedef int (CompileHookProc) _ANSI_ARGS_((Tcl_Interp *interp, + struct CompileEnv *compEnvPtr, ClientData clientData)); /* * The data structure defining the execution environment for ByteCode's. diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 837ff62..61edee0 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.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. * - * RCS: @(#) $Id: tclIntDecls.h,v 1.7 1999/04/21 21:50:27 rjohnson Exp $ + * RCS: @(#) $Id: tclIntDecls.h,v 1.8 1999/04/22 22:57:07 stanton Exp $ */ #ifndef _TCLINTDECLS @@ -444,6 +444,18 @@ EXTERN int TclLooksLikeInt _ANSI_ARGS_((char * bytes, /* 141 */ EXTERN char * TclpGetCwd _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * cwdPtr)); +/* 142 */ +EXTERN int TclSetByteCodeFromAny _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Obj * objPtr, + CompileHookProc * hookProc, + ClientData clientData)); +/* 143 */ +EXTERN int TclAddLiteralObj _ANSI_ARGS_(( + struct CompileEnv * envPtr, Tcl_Obj * objPtr, + LiteralEntry ** litPtrPtr)); +/* 144 */ +EXTERN void TclHideLiteral _ANSI_ARGS_((Tcl_Interp * interp, + struct CompileEnv * envPtr, int index)); typedef struct TclIntStubs { int magic; @@ -591,6 +603,9 @@ typedef struct TclIntStubs { int (*tclpLoadFile) _ANSI_ARGS_((Tcl_Interp * interp, char * fileName, char * sym1, char * sym2, Tcl_PackageInitProc ** proc1Ptr, Tcl_PackageInitProc ** proc2Ptr, ClientData * clientDataPtr)); /* 139 */ int (*tclLooksLikeInt) _ANSI_ARGS_((char * bytes, int length)); /* 140 */ char * (*tclpGetCwd) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * cwdPtr)); /* 141 */ + int (*tclSetByteCodeFromAny) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, CompileHookProc * hookProc, ClientData clientData)); /* 142 */ + int (*tclAddLiteralObj) _ANSI_ARGS_((struct CompileEnv * envPtr, Tcl_Obj * objPtr, LiteralEntry ** litPtrPtr)); /* 143 */ + void (*tclHideLiteral) _ANSI_ARGS_((Tcl_Interp * interp, struct CompileEnv * envPtr, int index)); /* 144 */ } TclIntStubs; extern TclIntStubs *tclIntStubsPtr; @@ -1130,6 +1145,18 @@ extern TclIntStubs *tclIntStubsPtr; #define TclpGetCwd \ (tclIntStubsPtr->tclpGetCwd) /* 141 */ #endif +#ifndef TclSetByteCodeFromAny +#define TclSetByteCodeFromAny \ + (tclIntStubsPtr->tclSetByteCodeFromAny) /* 142 */ +#endif +#ifndef TclAddLiteralObj +#define TclAddLiteralObj \ + (tclIntStubsPtr->tclAddLiteralObj) /* 143 */ +#endif +#ifndef TclHideLiteral +#define TclHideLiteral \ + (tclIntStubsPtr->tclHideLiteral) /* 144 */ +#endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index eb199bb..1141155 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.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. * - * RCS: @(#) $Id: tclLiteral.c,v 1.2 1999/04/16 00:46:50 stanton Exp $ + * RCS: @(#) $Id: tclLiteral.c,v 1.3 1999/04/22 22:57:07 stanton Exp $ */ #include "tclInt.h" @@ -199,8 +199,9 @@ TclRegisterLiteral(envPtr, bytes, length, onHeap) */ localHash = (hash & localTablePtr->mask); + for (localPtr = localTablePtr->buckets[localHash]; - localPtr != NULL; localPtr = localPtr->nextPtr) { + localPtr != NULL; localPtr = localPtr->nextPtr) { objPtr = localPtr->objPtr; if ((objPtr->length == length) && ((length == 0) || ((objPtr->bytes[0] == bytes[0]) @@ -224,7 +225,7 @@ TclRegisterLiteral(envPtr, bytes, length, onHeap) globalHash = (hash & globalTablePtr->mask); for (globalPtr = globalTablePtr->buckets[globalHash]; - globalPtr != NULL; globalPtr = globalPtr->nextPtr) { + globalPtr != NULL; globalPtr = globalPtr->nextPtr) { objPtr = globalPtr->objPtr; if ((objPtr->length == length) && ((length == 0) || ((objPtr->bytes[0] == bytes[0]) @@ -242,8 +243,8 @@ TclRegisterLiteral(envPtr, bytes, length, onHeap) #ifdef TCL_COMPILE_DEBUG if (globalPtr->refCount < 1) { panic("TclRegisterLiteral: global literal \"%.*s\" had bad refCount %d", - (length>60? 60 : length), bytes, - globalPtr->refCount); + (length>60? 60 : length), bytes, + globalPtr->refCount); } TclVerifyLocalLiteralTable(envPtr); #endif /*TCL_COMPILE_DEBUG*/ @@ -376,6 +377,119 @@ TclLookupLiteralEntry(interp, objPtr) /* *---------------------------------------------------------------------- * + * TclHideLiteral -- + * + * Remove a literal entry from the literal hash tables, leaving it in + * the literal array so existing references continue to function. + * This makes it possible to turn a shared literal into a private + * literal that cannot be shared. + * + * Results: + * None. + * + * Side effects: + * Removes the literal from the local hash table and decrements the + * global hash entry's reference count. + * + *---------------------------------------------------------------------- + */ + +void +TclHideLiteral(interp, envPtr, index) + Tcl_Interp *interp; /* Interpreter for which objPtr was created + * to hold a literal. */ + register CompileEnv *envPtr; /* Points to CompileEnv whose literal array + * contains the entry being hidden. */ + int index; /* The index of the entry in the literal + * array. */ +{ + LiteralEntry **nextPtrPtr, *entryPtr, *lPtr; + LiteralTable *localTablePtr = &(envPtr->localLitTable); + int localHash, length; + char *bytes; + + lPtr = &(envPtr->literalArrayPtr[index]); + + /* + * We need to bump the object refcount to avoid having the object freed + * when we remove the last global reference. + */ + + Tcl_IncrRefCount(lPtr->objPtr); + + TclReleaseLiteral(interp, lPtr->objPtr); + + bytes = Tcl_GetStringFromObj(lPtr->objPtr, &length); + localHash = (HashString(bytes, length) & localTablePtr->mask); + nextPtrPtr = &localTablePtr->buckets[localHash]; + + for (entryPtr = *nextPtrPtr; entryPtr != NULL; entryPtr = *nextPtrPtr) { + if (entryPtr == lPtr) { + *nextPtrPtr = lPtr->nextPtr; + lPtr->nextPtr = NULL; + localTablePtr->numEntries--; + break; + } + nextPtrPtr = &entryPtr->nextPtr; + } +} + +/* + *---------------------------------------------------------------------- + * + * TclAddLiteralObj -- + * + * Add a single literal object to the literal array. This + * function does not add the literal to the local or global + * literal tables. The caller is expected to add the entry + * to whatever tables are appropriate. + * + * Results: + * The index in the CompileEnv's literal array that references the + * literal. Stores the pointer to the new literal entry in the + * location referenced by the localPtrPtr argument. + * + * Side effects: + * Expands the literal array if necessary. Increments the refcount + * on the literal object. + * + *---------------------------------------------------------------------- + */ + +int +TclAddLiteralObj(envPtr, objPtr, litPtrPtr) + register CompileEnv *envPtr; /* Points to CompileEnv in whose literal + * array the object is to be inserted. */ + Tcl_Obj *objPtr; /* The object to insert into the array. */ + LiteralEntry **litPtrPtr; /* The location where the pointer to the + * new literal entry should be stored. + * May be NULL. */ +{ + register LiteralEntry *lPtr; + int objIndex; + + if (envPtr->literalArrayNext >= envPtr->literalArrayEnd) { + ExpandLocalLiteralArray(envPtr); + } + objIndex = envPtr->literalArrayNext; + envPtr->literalArrayNext++; + + lPtr = &(envPtr->literalArrayPtr[objIndex]); + lPtr->objPtr = objPtr; + Tcl_IncrRefCount(objPtr); + lPtr->refCount = -1; /* i.e., unused */ + lPtr->nextPtr = NULL; + + if (litPtrPtr) { + *litPtrPtr = lPtr; + } + + return objIndex; +} + +/* + *---------------------------------------------------------------------- + * * AddLocalLiteralEntry -- * * Insert a new literal into a CompileEnv's local literal array. @@ -402,18 +516,15 @@ AddLocalLiteralEntry(envPtr, globalPtr, localHash) int localHash; /* Hash value for the literal's string. */ { register LiteralTable *localTablePtr = &(envPtr->localLitTable); - register LiteralEntry *localPtr; + LiteralEntry *localPtr; int objIndex; - if (envPtr->literalArrayNext >= envPtr->literalArrayEnd) { - ExpandLocalLiteralArray(envPtr); - } - objIndex = envPtr->literalArrayNext; - envPtr->literalArrayNext++; + objIndex = TclAddLiteralObj(envPtr, globalPtr->objPtr, &localPtr); + + /* + * Add the literal to the local table. + */ - localPtr = &(envPtr->literalArrayPtr[objIndex]); - localPtr->objPtr = globalPtr->objPtr; - localPtr->refCount = -1; /* i.e., unused */ localPtr->nextPtr = localTablePtr->buckets[localHash]; localTablePtr->buckets[localHash] = localPtr; localTablePtr->numEntries++; @@ -614,10 +725,14 @@ TclReleaseLiteral(interp, objPtr) return; } } -#ifdef TCL_COMPILE_DEBUG - panic("TclReleaseLiteral: literal \"%.*s\" not found", - (length>60? 60 : length), bytes); -#endif /*TCL_COMPILE_DEBUG*/ + + /* + * The object wasn't in the literal hash table, so it must be a unique + * local object in the object table that has no global entry. Just + * decrement the refcount and return. + */ + + Tcl_DecrRefCount(objPtr); } /* diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 321c16a..f579c0d 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.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. * - * RCS: @(#) $Id: tclStubInit.c,v 1.10 1999/04/21 21:50:28 rjohnson Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.11 1999/04/22 22:57:07 stanton Exp $ */ #include "tclInt.h" @@ -585,6 +585,9 @@ TclIntStubs tclIntStubs = { TclpLoadFile, /* 139 */ TclLooksLikeInt, /* 140 */ TclpGetCwd, /* 141 */ + TclSetByteCodeFromAny, /* 142 */ + TclAddLiteralObj, /* 143 */ + TclHideLiteral, /* 144 */ }; TclIntPlatStubs tclIntPlatStubs = { |