* 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.

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 = {