summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorsurles <surles>1998-07-24 13:49:13 (GMT)
committersurles <surles>1998-07-24 13:49:13 (GMT)
commitaaf71b185279c46208cedda0caf510bc43baa437 (patch)
treeadfbcc6f4259a132707c66b34c76a64cab2654f4
parent88d6f2dc3a97fd42cfca3ea9bb1cb3a721e10c76 (diff)
downloadtcl-aaf71b185279c46208cedda0caf510bc43baa437.zip
tcl-aaf71b185279c46208cedda0caf510bc43baa437.tar.gz
tcl-aaf71b185279c46208cedda0caf510bc43baa437.tar.bz2
Updated core w/ Micheals latest changes.
-rw-r--r--generic/tcl.h57
-rw-r--r--generic/tclCompile.c20
-rw-r--r--generic/tclInitScript.h4
-rw-r--r--generic/tclInt.h65
-rw-r--r--generic/tclNamesp.c38
-rw-r--r--generic/tclProc.c221
-rw-r--r--library/init.tcl371
-rw-r--r--tests/interp.test8
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