summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authorstanton <stanton>1999-04-22 22:57:06 (GMT)
committerstanton <stanton>1999-04-22 22:57:06 (GMT)
commit804bb2b478378a4c8bdf5426fc4f01fe8310d1f9 (patch)
tree7d3cbee11446913d235f80af0181bb20588351fc /generic
parenteeb2fba346c1470404ea5892db056f44d8decb22 (diff)
downloadtcl-804bb2b478378a4c8bdf5426fc4f01fe8310d1f9.zip
tcl-804bb2b478378a4c8bdf5426fc4f01fe8310d1f9.tar.gz
tcl-804bb2b478378a4c8bdf5426fc4f01fe8310d1f9.tar.bz2
* generic/tclInt.h:
* generic/tclInt.decls: * generic/tclCompile.c: Added TclSetByteCodeFromAny that takes a hook procedure to invoke after compilation but before the byte codes are emitted. This makes it possible to do postprocessing on the compiled byte codes before the ByteCode is generated. * generic/tclLiteral.c: Added TclHideLiteral and TclAddLiteralObj to make it possible to create local unshared literal objects.
Diffstat (limited to 'generic')
-rw-r--r--generic/tclCompile.c111
-rw-r--r--generic/tclInt.decls16
-rw-r--r--generic/tclInt.h13
-rw-r--r--generic/tclIntDecls.h29
-rw-r--r--generic/tclLiteral.c151
-rw-r--r--generic/tclStubInit.c5
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 = {