From aaf71b185279c46208cedda0caf510bc43baa437 Mon Sep 17 00:00:00 2001
From: surles <surles>
Date: Fri, 24 Jul 1998 13:49:13 +0000
Subject: Updated core w/ Micheals latest changes.

---
 generic/tcl.h           |  57 +-------
 generic/tclCompile.c    |  20 ++-
 generic/tclInitScript.h |   4 +-
 generic/tclInt.h        |  65 ++++++++-
 generic/tclNamesp.c     |  38 ++++-
 generic/tclProc.c       | 221 +++++++++++++++++-----------
 library/init.tcl        | 371 +++++++++++++++++++++++++++++++++++++++++-------
 tests/interp.test       |   8 +-
 8 files changed, 581 insertions(+), 203 deletions(-)

diff --git a/generic/tcl.h b/generic/tcl.h
index fb5fc94..2742a6d 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.12 1998/07/21 15:25:42 escoffon Exp $ 
+ * SCCS: %Z% $Id: tcl.h,v 1.13 1998/07/24 13:49:40 surles Exp $ 
  */
 
 #ifndef _TCL
@@ -534,45 +534,6 @@ typedef struct Tcl_Namespace {
 } Tcl_Namespace;
 
 /*
- * The following procedures allow namespaces to be customized to
- * support special name resolution rules for commands/variables.
- * 
- */
-typedef Tcl_Var (Tcl_ResolveRuntimeVarProc) _ANSI_ARGS_((
-	Tcl_Interp* interp, ClientData identity));
-
-typedef void (Tcl_ResolveVarDeleteProc) _ANSI_ARGS_((ClientData identity));
-
-typedef struct Tcl_ResolvedVarInfo {
-    ClientData identity;
-    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;
-
-/*
  * The following structure represents a call frame, or activation record.
  * A call frame defines a naming context for a procedure call: its local
  * scope (for local variables) and its namespace scope (used for non-local
@@ -1063,10 +1024,6 @@ typedef enum Tcl_PathType {
 
 EXTERN void		Tcl_AddErrorInfo _ANSI_ARGS_((Tcl_Interp *interp,
 			    char *message));
-EXTERN void		Tcl_AddInterpResolvers _ANSI_ARGS_((Tcl_Interp *interp,
-			    char *name, Tcl_ResolveCmdProc *cmdProc,
-			    Tcl_ResolveVarProc *varProc,
-			    Tcl_ResolveCompiledVarProc *compiledVarProc));
 EXTERN void		Tcl_AddObjErrorInfo _ANSI_ARGS_((Tcl_Interp *interp,
 			    char *message, int length));
 EXTERN void		Tcl_AllowExceptions _ANSI_ARGS_((Tcl_Interp *interp));
@@ -1321,16 +1278,11 @@ EXTERN int		Tcl_GetInt _ANSI_ARGS_((Tcl_Interp *interp,
 			    char *string, int *intPtr));
 EXTERN int		Tcl_GetInterpPath _ANSI_ARGS_((Tcl_Interp *askInterp,
 			    Tcl_Interp *slaveInterp));
-EXTERN int              Tcl_GetInterpResolvers _ANSI_ARGS_((Tcl_Interp *interp,
-                            char *name, Tcl_ResolverInfo *resInfo));
 EXTERN int		Tcl_GetIntFromObj _ANSI_ARGS_((Tcl_Interp *interp,
 			    Tcl_Obj *objPtr, int *intPtr));
 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 int              Tcl_GetNamespaceResolvers _ANSI_ARGS_((
-			    Tcl_Namespace *namespacePtr,
-			    Tcl_ResolverInfo *resInfo));
 EXTERN CONST char *	Tcl_GetNameOfExecutable _ANSI_ARGS_((void));
 EXTERN Tcl_Obj *	Tcl_GetObjResult _ANSI_ARGS_((Tcl_Interp *interp));
 EXTERN Tcl_ObjType *	Tcl_GetObjType _ANSI_ARGS_((char *typeName));
@@ -1457,8 +1409,6 @@ EXTERN void		Tcl_RegisterChannel _ANSI_ARGS_((Tcl_Interp *interp,
 EXTERN void		Tcl_RegisterObjType _ANSI_ARGS_((
 			    Tcl_ObjType *typePtr));
 EXTERN void		Tcl_Release _ANSI_ARGS_((ClientData clientData));
-EXTERN int		Tcl_RemoveInterpResolvers _ANSI_ARGS_((
-			    Tcl_Interp *interp, char *name));
 EXTERN void		Tcl_RestartIdleTimer _ANSI_ARGS_((void));
 EXTERN void		Tcl_ResetResult _ANSI_ARGS_((Tcl_Interp *interp));
 #define Tcl_Return Tcl_SetResult
@@ -1494,11 +1444,6 @@ EXTERN void		Tcl_SetListObj _ANSI_ARGS_((Tcl_Obj *objPtr,
 EXTERN void		Tcl_SetLongObj _ANSI_ARGS_((Tcl_Obj *objPtr, 
 			    long longValue));
 EXTERN void		Tcl_SetMaxBlockTime _ANSI_ARGS_((Tcl_Time *timePtr));
-EXTERN void		Tcl_SetNamespaceResolvers _ANSI_ARGS_((
-			    Tcl_Namespace *namespacePtr,
-			    Tcl_ResolveCmdProc *cmdProc,
-			    Tcl_ResolveVarProc *varProc,
-			    Tcl_ResolveCompiledVarProc *compiledVarProc));
 EXTERN void		Tcl_SetObjErrorCode _ANSI_ARGS_((Tcl_Interp *interp,
 			    Tcl_Obj *errorObjPtr));
 EXTERN void		Tcl_SetObjLength _ANSI_ARGS_((Tcl_Obj *objPtr,
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 7f07a27..c5bce05 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: %Z% $Id: tclCompile.c,v 1.7 1998/07/06 14:54:30 welch Exp $ 
+ * SCCS: %Z% $Id: tclCompile.c,v 1.8 1998/07/24 13:49:13 surles Exp $ 
  */
 
 #include "tclInt.h"
@@ -6690,8 +6690,9 @@ LookupCompiledLocal(name, nameChars, createIfNew, flagsIfCreated, procPtr)
 	    localPtr = procPtr->firstLocalPtr;
 	    for (i = 0;  i < localCt;  i++) {
 	        if (!localPtr->isTemp) {
-                    currInfo = &localPtr->resolveInfo;
-		    if ( (currInfo->fetchProc == vinfo.fetchProc) &&
+                    currInfo = localPtr->resolveInfo;
+		    if ( currInfo &&
+			    (currInfo->fetchProc == vinfo.fetchProc) &&
 	                 (currInfo->identity == vinfo.identity) ) {
 		        return i;
 		    }
@@ -6729,9 +6730,16 @@ createCompiledLocal:
 	localPtr->isTemp = (name == NULL);
 	localPtr->flags = flagsIfCreated;
 	localPtr->defValuePtr = NULL;
-	localPtr->resolveInfo.identity = vinfo.identity;
-	localPtr->resolveInfo.fetchProc = vinfo.fetchProc;
-	localPtr->resolveInfo.deleteProc = vinfo.deleteProc;
+ 	localPtr->resolveInfo = NULL;
+ 
+	if (vinfo.fetchProc) {
+	    localPtr->resolveInfo =
+		(Tcl_ResolvedVarInfo *) ckalloc( sizeof(Tcl_ResolvedVarInfo) );
+ 	    localPtr->resolveInfo->identity = vinfo.identity;
+ 	    localPtr->resolveInfo->fetchProc = vinfo.fetchProc;
+ 	    localPtr->resolveInfo->deleteProc = vinfo.deleteProc;
+	}
+	
 	if (name != NULL) {
 	    memcpy((VOID *) localPtr->name, (VOID *) name, (size_t) nameChars);
 	}
diff --git a/generic/tclInitScript.h b/generic/tclInitScript.h
index 3c0e1e3..b8900cf 100644
--- a/generic/tclInitScript.h
+++ b/generic/tclInitScript.h
@@ -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: %Z% $Id: tclInitScript.h,v 1.2 1998/07/09 13:46:23 suresh Exp $ 
+ * SCCS: %Z% $Id: tclInitScript.h,v 1.3 1998/07/24 13:49:59 surles Exp $ 
  */
 
 /*
@@ -27,7 +27,7 @@
 static char initScript[] = "if {[info proc tclInit]==\"\"} {\n\
   proc tclInit {} {\n\
     global tcl_library tcl_version tcl_patchLevel errorInfo\n\
-    global tcl_pkgPath env\n\
+    global env tcl_pkgPath\n\
     rename tclInit {}\n\
     set errors {}\n\
     set dirs {}\n\
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 006f895..dbf6215 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: %Z% $Id: tclInt.h,v 1.9 1998/07/13 13:43:24 welch Exp $ 
+ * SCCS: %Z% $Id: tclInt.h,v 1.10 1998/07/24 13:49:46 surles Exp $ 
  */
 
 #ifndef _TCLINT
@@ -58,6 +58,45 @@
 #endif
 
 /*
+  * The following procedures allow namespaces to be customized to
+  * support special name resolution rules for commands/variables.
+  * 
+  */
+typedef Tcl_Var (Tcl_ResolveRuntimeVarProc) _ANSI_ARGS_((
+    Tcl_Interp* interp, ClientData identity));
+
+typedef void (Tcl_ResolveVarDeleteProc) _ANSI_ARGS_((ClientData identity));
+
+typedef struct Tcl_ResolvedVarInfo {
+    ClientData identity;
+    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.
  *----------------------------------------------------------------
@@ -480,7 +519,7 @@ typedef struct CompiledLocal {
     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;
+    Tcl_ResolvedVarInfo *resolveInfo;
 				/* Customized variable resolution info
 				 * supplied by the Tcl_ResolveCompiledVarProc
 				 * associated with a namespace. Each variable
@@ -1552,6 +1591,9 @@ EXTERN int		TclPreventAliasLoop _ANSI_ARGS_((Tcl_Interp *interp,
 EXTERN void		TclPrintByteCodeObj _ANSI_ARGS_((Tcl_Interp *interp,
 		            Tcl_Obj *objPtr));
 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));
@@ -1982,6 +2024,10 @@ EXTERN int	TclCompileWhileCmd _ANSI_ARGS_((Tcl_Interp *interp,
  *----------------------------------------------------------------
  */
 
+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));
@@ -1999,6 +2045,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));
@@ -2023,6 +2077,13 @@ 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));
 
 #endif /* _TCLINT */
 
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index d399426..45367c7 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -1085,6 +1085,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.
@@ -1120,7 +1124,7 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite)
     Tcl_HashSearch search;
     Command *cmdPtr;
     ImportRef *refPtr;
-    Tcl_Command importedCmd;
+    Tcl_Command autoCmd, importedCmd;
     ImportedCmdData *dataPtr;
     int wasExported, i, result;
 
@@ -1133,6 +1137,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
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 145db1c..5042279 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: %Z% $Id: tclProc.c,v 1.9 1998/07/21 15:58:44 surles Exp $ 
+ * SCCS: %Z% $Id: tclProc.c,v 1.10 1998/07/24 13:49:29 surles Exp $ 
  */
 
 #include "tclInt.h"
@@ -45,7 +45,6 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv)
     register Interp *iPtr = (Interp *) interp;
     Proc *procPtr;
     char *fullName, *procName;
-    char **argArray = NULL;
     Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
     Tcl_Command cmd;
     Tcl_DString ds;
@@ -299,10 +298,8 @@ TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr)
 	localPtr->isArg  = 1;
 	localPtr->isTemp = 0;
 	localPtr->flags = VAR_SCALAR;
-        localPtr->resolveInfo.identity   = NULL;
-        localPtr->resolveInfo.fetchProc  = NULL;
-        localPtr->resolveInfo.deleteProc = NULL;
-
+	localPtr->resolveInfo = NULL;
+	
 	if (fieldCount == 2) {
 	    localPtr->defValuePtr =
 		    Tcl_NewStringObj(fieldValues[1], valueLength);
@@ -718,14 +715,12 @@ TclObjInterpProc(clientData, interp, objc, objv)
 {
     Interp *iPtr = (Interp *) interp;
     Proc *procPtr = (Proc *) clientData;
-    Tcl_Obj *bodyPtr = procPtr->bodyPtr;
     Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
     CallFrame frame;
     register CallFrame *framePtr = &frame;
     register Var *varPtr, *resolvedVarPtr;
     register CompiledLocal *localPtr;
     Tcl_ResolvedVarInfo *resVarInfo;
-    Proc *saveProcPtr;
     char *procName, *bytes;
     int nameLen, localCt, numArgs, argCt, length, i, result;
 
@@ -749,75 +744,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.
-     *
-     * Precompiled procedure bodies, however, are immutable and therefore
-     * they are not recompiled, even if the epoch has changed.
+     * 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 ((codePtr->iPtr != iPtr)
-	        || (codePtr->compileEpoch != iPtr->compileEpoch)
-	        || (codePtr->nsPtr != nsPtr)
-	        || (codePtr->nsEpoch != nsPtr->resolverEpoch)) {
-            if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
-                if (codePtr->iPtr != iPtr) {
-                    panic("TclObjInterpProc: compiled body jumped interps");
-                }
-	        codePtr->compileEpoch = iPtr->compileEpoch;
-            } else {
-                tclByteCodeType.freeIntRepProc(bodyPtr);
-                bodyPtr->typePtr = (Tcl_ObjType *) NULL;
-            }
-	}
-    }
-    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 = nameLen;
-	    ellipsis = "";
-	    if (numChars > 50) {
-		numChars = 50;
-		ellipsis = "...";
-	    }
-	    fprintf(stdout, "Compiling body of proc \"%.*s%s\"\n",
-		    numChars, procName, ellipsis);
-	}
-	
-	saveProcPtr = iPtr->compiledProcPtr;
-	iPtr->compiledProcPtr = procPtr;
-	result = tclByteCodeType.setFromAnyProc(interp, bodyPtr);
-	iPtr->compiledProcPtr = saveProcPtr;
-	
-	if (result != TCL_OK) {
-	    if (result == TCL_ERROR) {
-		numChars = nameLen;
-		ellipsis = "";
-		if (numChars > 50) {
-		    numChars = 50;
-		    ellipsis = "...";
-		}
-		sprintf(buf, "\n    (compiling body of proc \"%.*s%s\", line %d)",
-			numChars, procName, ellipsis, interp->errorLine);
-		Tcl_AddObjErrorInfo(interp, buf, -1);
-	    }
-	    return result;
-	}
+    
+    result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr,
+	    "body of proc", procName);
+    
+    if (result != TCL_OK) {
+        return result;
     }
 
     /*
@@ -863,10 +799,10 @@ TclObjInterpProc(clientData, interp, objc, objv)
     for (localPtr = procPtr->firstLocalPtr;  localPtr != NULL;
 	    localPtr = localPtr->nextPtr) {
 
-        resVarInfo = &localPtr->resolveInfo;
+        resVarInfo = localPtr->resolveInfo;
         resolvedVarPtr = NULL;
 
-        if (resVarInfo->fetchProc != NULL) {
+        if (resVarInfo && resVarInfo->fetchProc) {
             resolvedVarPtr = (Var*) (*resVarInfo->fetchProc)(interp,
                 resVarInfo->identity);
         }
@@ -1030,6 +966,130 @@ TclObjInterpProc(clientData, interp, objc, objv)
 /*
  *----------------------------------------------------------------------
  *
+ * TclProcCompileProc --
+ *
+ *	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:
+  *	None.
+  *
+  * Side effects:
+  *	May change the internal representation of the body object
+  *	to compiled code.
+  *
+  *----------------------------------------------------------------------
+  */
+ 
+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. */
+{
+    Interp *iPtr = (Interp*)interp;
+    int result;
+    Tcl_CallFrame frame;
+    Proc *saveProcPtr;
+ 
+    /*
+     * 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.
+     */
+ 
+    if (bodyPtr->typePtr == &tclByteCodeType) {
+ 	ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr;
+ 
+ 	if ((codePtr->iPtr != iPtr)
+ 	        || (codePtr->compileEpoch != iPtr->compileEpoch)
+ 	        || (codePtr->nsPtr != nsPtr)
+ 	        || (codePtr->nsEpoch != nsPtr->resolverEpoch)) {
+ 	    tclByteCodeType.freeIntRepProc(bodyPtr);
+ 	    bodyPtr->typePtr = (Tcl_ObjType *) NULL;
+ 	}
+    }
+    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;
+ 	}
+    }
+    return TCL_OK;
+}
+ 
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TclProcDeleteProc --
  *
  *	This procedure is invoked just before a command procedure is
@@ -1092,10 +1152,11 @@ TclProcCleanupProc(procPtr)
     for (localPtr = procPtr->firstLocalPtr;  localPtr != NULL;  ) {
 	CompiledLocal *nextPtr = localPtr->nextPtr;
 
-        resVarInfo = &localPtr->resolveInfo;
-	if (resVarInfo->deleteProc != NULL) {
+        resVarInfo = localPtr->resolveInfo;
+	if (resVarInfo && resVarInfo->deleteProc) {
             (*resVarInfo->deleteProc)(resVarInfo->identity);
             resVarInfo->identity = NULL;
+	    ckfree((char *) resVarInfo);
         }
 
 	if (localPtr->defValuePtr != NULL) {
diff --git a/library/init.tcl b/library/init.tcl
index 8b6ca1a..6c1aff9 100644
--- a/library/init.tcl
+++ b/library/init.tcl
@@ -3,7 +3,7 @@
 # Default system startup file for Tcl-based applications.  Defines
 # "unknown" procedure and auto-load facilities.
 #
-# SCCS: %Z% $Id: init.tcl,v 1.8 1998/07/20 16:24:45 welch Exp $ 
+# SCCS: %Z% $Id: init.tcl,v 1.9 1998/07/24 13:50:06 surles Exp $ 
 #
 # Copyright (c) 1991-1993 The Regents of the University of California.
 # Copyright (c) 1994-1996 Sun Microsystems, Inc.
@@ -97,11 +97,6 @@ if {[info commands tclLog] == ""} {
     }
 }
 
-# The procs defined in this file that have a leading space
-# are 'hidden' from auto_mkindex because they are not
-# auto-loadable.
-
-
 # unknown --
 # This procedure is called when a Tcl command is invoked that doesn't
 # exist in the interpreter.  It takes the following steps to make the
@@ -124,7 +119,7 @@ if {[info commands tclLog] == ""} {
 # args -	A list whose elements are the words of the original
 #		command, including the command name.
 
- proc unknown args {
+proc unknown args {
     global auto_noexec auto_noload env unknown_pending tcl_interactive
     global errorCode errorInfo
 
@@ -251,9 +246,9 @@ if {[info commands tclLog] == ""} {
 #                       a canonical namespace as returned [namespace current]
 #                       for instance. If not given, namespace current is used.
 
- proc auto_load {cmd {namespace {}}} {
-    global auto_index auto_oldpath auto_path env errorInfo errorCode
-
+proc auto_load {cmd {namespace {}}} {
+    global auto_index auto_oldpath auto_path
+    
     if {[string length $namespace] == 0} {
 	set namespace [uplevel {namespace current}]
     }
@@ -270,6 +265,34 @@ if {[info commands tclLog] == ""} {
     if {![info exists auto_path]} {
 	return 0
     }
+    
+    if {![auto_load_index]} {
+ 	return 0
+    }
+    
+    foreach name $nameList {
+ 	if {[info exists auto_index($name)]} {
+ 	    uplevel #0 $auto_index($name)
+ 	    if {[info commands $name] != ""} {
+ 		return 1
+ 	    }
+ 	}
+    }
+    return 0
+}
+
+# auto_load_index --
+# Loads the contents of tclIndex files on the auto_path directory
+# list.  This is usually invoked within auto_load to load the index
+# of available commands.  Returns 1 if the index is loaded, and 0 if
+# the index is already loaded and up to date.
+#
+# Arguments: 
+# None.
+
+proc auto_load_index {} {
+    global auto_index auto_oldpath auto_path errorInfo errorCode
+    
     if {[info exists auto_oldpath]} {
 	if {$auto_oldpath == $auto_path} {
 	    return 0
@@ -317,15 +340,7 @@ if {[info commands tclLog] == ""} {
 	    }
 	}
     }
-    foreach name $nameList {
-	if {[info exists auto_index($name)]} {
-	    uplevel #0 $auto_index($name)
-	    if {[info commands $name] != ""} {
-		return 1
-	    }
-	}
-    }
-    return 0
+    return 1
 }
 
 # auto_qualify --
@@ -342,8 +357,8 @@ if {[info commands tclLog] == ""} {
 #               a canonical namespace as returned by [namespace current]
 #               for instance.
 
- proc auto_qualify {cmd namespace} {
-
+proc auto_qualify {cmd namespace} {
+    
     # count separators and clean them up
     # (making sure that foo:::::bar will be treated as foo::bar)
     set n [regsub -all {::+} $cmd :: cmd]
@@ -387,6 +402,33 @@ if {[info commands tclLog] == ""} {
     }
 }
 
+# auto_import --
+# invoked during "namespace import" to make see if the imported commands
+# reside in an autoloaded library.  If so, the commands are loaded so
+# that they will be available for the import links.  If not, then this
+# procedure does nothing.
+#
+# Arguments -
+# pattern	The pattern of commands being imported (like "foo::*")
+#               a canonical namespace as returned by [namespace current]
+
+proc auto_import {pattern} {
+    global auto_index
+    
+    set ns [uplevel namespace current]
+    set patternList [auto_qualify $pattern $ns]
+    
+    auto_load_index
+    
+    foreach pattern $patternList {
+	foreach name [array names auto_index] {
+	    if {[string match $pattern $name] && "" == [info commands $name]} {
+		uplevel #0 $auto_index($name)
+	    }
+	}
+    }
+}
+
 if {[string compare $tcl_platform(platform) windows] == 0} {
 
 # auto_execok --
@@ -523,13 +565,31 @@ proc auto_reset {} {
     catch {unset auto_oldpath}
 }
 
+# ----------------------------------------------------------------------
+# auto_mkindex
+# ----------------------------------------------------------------------
+# The following procedures are used to generate the tclIndex file
+# from Tcl source files.  They use a special safe interpreter to
+# parse Tcl source files, writing out index entries as "proc"
+# commands are encountered.  This implementation won't work in a
+# safe interpreter, since a safe interpreter can't create the
+# special parser and mess with its commands.  If this is a safe
+# interpreter, we simply clip these procs out.
+
+if {[interp issafe]} {
+    proc auto_mkindex {dir args} {
+	error "can't generate index within safe interpreter"
+    }
+    proc tcl_nonsafe {args} {}
+} else {
+    proc tcl_nonsafe {args} {eval $args}
+}
+
 # auto_mkindex --
 # Regenerate a tclIndex file from Tcl source files.  Takes as argument
 # the name of the directory in which the tclIndex file is to be placed,
 # followed by any number of glob patterns to use in that directory to
-# locate all of the relevant files. It does not parse or source the file
-# so the generated index will not contain the appropriate namespace qualifiers
-# if you don't explicitly specify it.
+# locate all of the relevant files.
 #
 # Arguments: 
 # dir -			Name of the directory in which to create an index.
@@ -537,11 +597,17 @@ proc auto_reset {} {
 #			names of files within dir.  If no additional
 #			are given auto_mkindex will look for *.tcl.
 
-proc auto_mkindex {dir args} {
+tcl_nonsafe proc auto_mkindex {dir args} {
     global errorCode errorInfo
+    
+    if {[interp issafe]} {
+	error "can't generate index within safe interpreter"
+    }
+    
     set oldDir [pwd]
     cd $dir
     set dir [pwd]
+
     append index "# Tcl autoload index file, version 2.0\n"
     append index "# This file is generated by the \"auto_mkindex\" command\n"
     append index "# and sourced to set up indexing information for one or\n"
@@ -553,42 +619,243 @@ proc auto_mkindex {dir args} {
 	set args *.tcl
     }
     foreach file [eval glob $args] {
-	set f ""
-	set error [catch {
-	    set f [open $file]
-	    while {[gets $f line] >= 0} {
-		if {[regexp {^proc[ 	]+([^ 	]*)} $line match procName]} {
-		    set procName [lindex [auto_qualify $procName "::"] 0]
-		    append index "set [list auto_index($procName)]"
-		    append index " \[list source \[file join \$dir [list $file]\]\]\n"
-		}
-	    }
-	    close $f
-	} msg]
-	if {$error} {
+	if {[catch {auto_mkindex_parser::mkindex $file} msg] == 0} {
+	    append index $msg
+	} else {
 	    set code $errorCode
 	    set info $errorInfo
-	    catch {close $f}
 	    cd $oldDir
 	    error $msg $info $code
 	}
     }
-    set f ""
-    set error [catch {
-	set f [open tclIndex w]
-	puts $f $index nonewline
-	close $f
-	cd $oldDir
-    } msg]
-    if {$error} {
-	set code $errorCode
-	set info $errorInfo
-	catch {close $f}
-	cd $oldDir
-	error $msg $info $code
+    
+    set fid [open "tclIndex" w]
+    puts $fid $index nonewline
+    close $fid
+    cd $oldDir
+}
+
+#
+# Create a safe interpreter that can be used to parse Tcl source files
+# generate a tclIndex file for autoloading.  This interp contains
+# commands for things that need index entries.  Each time a command
+# is executed, it writes an entry out to the index file.
+#
+tcl_nonsafe namespace eval auto_mkindex_parser {
+    variable parser ""          ;# parser used to build index
+    variable index ""           ;# maintains index as it is built
+    variable scriptFile ""      ;# name of file being processed
+    variable contextStack ""    ;# stack of namespace scopes
+    variable imports ""         ;# keeps track of all imported cmds
+    
+    if {![interp issafe]} {
+	set parser [interp create -safe]
+	$parser hide info
+	$parser hide rename
+	$parser hide proc
+	$parser hide namespace
+	$parser hide eval
+	$parser hide puts
+	$parser invokehidden namespace delete ::
+	$parser invokehidden proc unknown {args} {}
+	
+	#
+	# We'll need access to the "namespace" command within the
+	# interp.  Put it back, but move it out of the way.
+	#
+	$parser expose namespace
+	$parser invokehidden rename namespace _%@namespace
+	$parser expose eval
+	$parser invokehidden rename eval _%@eval
+    }
+}
+
+# auto_mkindex_parser::mkindex --
+# Used by the "auto_mkindex" command to create a "tclIndex" file for
+# the given Tcl source file.  Executes the commands in the file, and
+# handles things like the "proc" command by adding an entry for the
+# index file.  Returns a string that represents the index file.
+#
+# Arguments: 
+# file -		Name of Tcl source file to be indexed.
+#
+tcl_nonsafe proc auto_mkindex_parser::mkindex {file} {
+    variable parser
+    variable index
+    variable scriptFile
+    variable contextStack
+    variable imports
+    
+    set scriptFile $file
+    
+    set fid [open $file]
+    set contents [read $fid]
+    close $fid
+    
+    #
+    # There is one problem with sourcing files into the safe
+    # interpreter:  references like "$x" will fail since code is not
+    # really being executed and variables do not really exist.
+    # Be careful to escape all naked "$" before evaluating.
+    #
+    regsub -all {([^\$])\$([^\$])} $contents {\1\\$\2} contents
+    
+    set index ""
+    set contextStack ""
+    set imports ""
+    
+    $parser eval $contents
+    
+    foreach name $imports {
+	catch {$parser eval [list _%@namespace forget $name]}
+    }
+    return $index
+}
+
+#
+# auto_mkindex_parser::command --
+# Registers a new command with the "auto_mkindex_parser" interpreter
+# that parses Tcl files.  These commands are fake versions of things
+# like the "proc" command.  When you execute them, they simply write
+# out an entry to a "tclIndex" file for auto-loading.
+#
+# This procedure allows extensions to register their own commands
+# with the auto_mkindex facility.  For example, a package like
+# [incr Tcl] might register a "class" command so that class definitions
+# could be added to a "tclIndex" file for auto-loading.
+#
+# Arguments:
+# name -		Name of command recognized in Tcl files.
+# arglist -		Argument list for command.
+# body -		Implementation of command to handle indexing.
+#
+tcl_nonsafe proc auto_mkindex_parser::command {name arglist body} {
+    variable parser
+    
+    set ns [namespace qualifiers $name]
+    set tail [namespace tail $name]
+    if {$ns == ""} {
+	set fakeName "[namespace current]::_%@fake_$tail"
+    } else {
+	set fakeName "_%@fake_$name"
+	regsub -all {::} $fakeName "_" fakeName
+	set fakeName "[namespace current]::$fakeName"
+    }
+    proc $fakeName $arglist $body
+    
+    #
+    # YUK!  Tcl won't let us alias fully qualified command names,
+    # so we can't handle names like "::itcl::class".  Instead,
+    # we have to build procs with the fully qualified names, and
+    # have the procs point to the aliases.
+    #
+    if {[regexp {::} $name]} {
+	set exportCmd [list _%@namespace export [namespace tail $name]]
+	$parser eval [list _%@namespace eval $ns $exportCmd]
+	set alias [namespace tail $fakeName]
+	$parser invokehidden proc $name {args} "_%@eval $alias \$args"
+	$parser alias $alias $fakeName
+    } else {
+	$parser alias $name $fakeName
+    }
+    return
+}
+
+# auto_mkindex_parser::fullname --
+# Used by commands like "proc" within the auto_mkindex parser.
+# Returns the qualified namespace name for the "name" argument.
+# If the "name" does not start with "::", elements are added from
+# the current namespace stack to produce a qualified name.  Then,
+# the name is examined to see whether or not it should really be
+# qualified.  If the name has more than the leading "::", it is
+# returned as a fully qualified name.  Otherwise, it is returned
+# as a simple name.  That way, the Tcl autoloader will recognize
+# it properly.
+#
+# Arguments:
+# name -		Name that is being added to index.
+#
+tcl_nonsafe proc auto_mkindex_parser::fullname {name} {
+    variable contextStack
+    
+    if {![string match ::* $name]} {
+	foreach ns $contextStack {
+	    set name "${ns}::$name"
+	    if {[string match ::* $name]} {
+		break
+	    }
+	}
     }
+    
+    if {[namespace qualifiers $name] == ""} {
+	return [namespace tail $name]
+    } elseif {![string match ::* $name]} {
+	return "::$name"
+    }
+    return $name
 }
 
+#
+# Now define all of the procedures for the auto_mkindex parser that
+# will build the "tclIndex" file...
+#
+
+#
+# AUTO MKINDEX:  proc name arglist body
+# Adds an entry to the auto index list for the given procedure name.
+#
+tcl_nonsafe auto_mkindex_parser::command proc {name args} {
+    variable index
+    variable scriptFile
+    append index "set [list auto_index([fullname $name])]"
+    append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n"
+}
+
+#
+# AUTO MKINDEX:  namespace eval name command ?arg arg...?
+# Adds the namespace name onto the context stack and evaluates the
+# associated body of commands.
+#
+# AUTO MKINDEX:  namespace import ?-force? pattern ?pattern...?
+# Performs the "import" action in the parser interpreter.  This is
+# important for any commands contained in a namespace that affect
+# the index.  For example, a script may say "itcl::class ...",
+# or it may import "itcl::*" and then say "class ...".  This
+# procedure does the import operation, but keeps track of imported
+# patterns so we can remove the imports later.
+#
+tcl_nonsafe auto_mkindex_parser::command namespace {op args} {
+    switch -- $op {
+	eval {
+	    variable parser
+	    variable contextStack
+	    
+	    set name [lindex $args 0]
+	    set args [lrange $args 1 end]
+	    
+	    set contextStack [linsert $contextStack 0 $name]
+	    if {[llength $args] == 1} {
+		$parser eval [lindex $args 0]
+	    } else {
+		eval $parser eval $args
+	    }
+	    set contextStack [lrange $contextStack 1 end]
+	}
+	import {
+	    variable parser
+	    variable imports
+	    foreach pattern $args {
+		if {$pattern != "-force"} {
+		    lappend imports $pattern
+		}
+	    }
+	    catch {$parser eval "_%@namespace import $args"}
+	}
+    }
+}
+
+rename tcl_nonsafe ""
+
 # pkg_mkIndex --
 # This procedure creates a package index in a given directory.  The
 # package index consists of a "pkgIndex.tcl" file whose contents are
diff --git a/tests/interp.test b/tests/interp.test
index 919774f..6755f71 100644
--- a/tests/interp.test
+++ b/tests/interp.test
@@ -148,8 +148,8 @@ test interp-3.8 {testing interp exists and interp slaves} {
 } {1 {wrong # args: should be "interp slaves ?path?"}}
 test interp-3.9 {testing interp exists and interp slaves} {
     interp create {a a2} -safe
-    interp slaves a
-} {a2}
+    expr {[lsearch [interp slaves a] a2] >= 0}
+} 1
 test interp-3.10 {testing interp exists and interp slaves} {
     interp exists {a a2}
 } 1
@@ -175,8 +175,8 @@ test interp-4.5 {testing interp delete} {
     interp create a
     interp create {a x1}
     interp delete {a x1}
-    interp slaves a
-} ""
+    expr {[lsearch [interp slaves a] x1] >= 0}
+} 0
 test interp-4.6 {testing interp delete} {
     interp create c1
     interp create c2
-- 
cgit v0.12