diff options
| -rw-r--r-- | generic/tcl.h | 57 | ||||
| -rw-r--r-- | generic/tclCompile.c | 20 | ||||
| -rw-r--r-- | generic/tclInitScript.h | 4 | ||||
| -rw-r--r-- | generic/tclInt.h | 65 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 38 | ||||
| -rw-r--r-- | generic/tclProc.c | 221 | ||||
| -rw-r--r-- | library/init.tcl | 371 | ||||
| -rw-r--r-- | 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 |