Created branch core-8-0-2-syntheticcore_8_0_2core_8_0_2_synthetic

3 files changed, 488 insertions, 1 deletions

diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index a138246..4672982 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.c
@@ -540,7 +540,6 @@ Tcl_Finalize()
     
     TclFinalizeCompExecEnv();
     TclFinalizeEnvironment();
-    TclpFinalize();
     firstExitPtr = NULL;
     tclInExit = 0;
 }
diff --git a/generic/tclInitScript.h b/generic/tclInitScript.h
new file mode 100644
index 0000000..c3b21a3
--- /dev/null
+++ b/generic/tclInitScript.h
@@ -0,0 +1,65 @@
+/* 
+ * tclInitScript.h --
+ *
+ *	This file contains Unix & Windows common init script
+ *      It is not used on the Mac. (the mac init script is in tclMacInit.c)
+ *
+ * Copyright (c) 1998 Sun Microsystems, Inc.
+ *
+ * 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.1 1998/06/27 22:11:40 welch Exp $ 
+ */
+
+/*
+ * The following string is the startup script executed in new
+ * interpreters.  It looks on disk in (way too many) different directories
+ * for a script "init.tcl" that is compatible with this version
+ * of Tcl.  The init.tcl script does all of the real work of
+ * initialization.
+ */
+
+static char initScript[] = "if {[info proc tclInit]==\"\"} {\n\
+  proc tclInit {} {\n\
+    global tcl_library tcl_version tcl_patchLevel errorInfo\n\
+    global tcl_pkgPath\n\
+    rename tclInit {}\n\
+    set errors {}\n\
+    set dirs {}\n\
+    if {[info exists env(TCL_LIBRARY)]} {\n\
+	lappend dirs $env(TCL_LIBRARY)\n\
+    }\n\
+    lappend dirs $tcl_library\n\
+    set parentDir [file dirname [file dirname [info nameofexecutable]]]\n\
+    lappend dirs [file join $parentDir lib/tcl$tcl_version]\n\
+    if {[string match {*[ab]*} $tcl_patchLevel]} {\n\
+	set lib tcl$tcl_patchLevel\n\
+    } else {\n\
+	set lib tcl$tcl_version\n\
+    }\n\
+    lappend dirs [file join [file dirname [file dirname [pwd]]] $lib/library]\n\
+    lappend dirs [file join [file dirname [pwd]] library]\n\
+    lappend dirs [file join [file dirname $parentDir] $lib/library]\n\
+    lappend dirs [file join $parentDir library]\n\
+    foreach i $dirs {\n\
+	set tcl_library $i\n\
+	set tclfile [file join $i init.tcl]\n\
+	if {[file exists $tclfile]} {\n\
+	    if {![catch {uplevel #0 [list source $tclfile]} msg]} {\n\
+                lappend tcl_pkgPath [file dirname $i]\n\
+	        return\n\
+	    } else {\n\
+		append errors \"$tclfile: $msg\n$errorInfo\n\"\n\
+	    }\n\
+	}\n\
+    }\n\
+    set msg \"Can't find a usable init.tcl in the following directories: \n\"\n\
+    append msg \"    $dirs\n\n\"\n\
+    append msg \"$errors\n\n\"\n\
+    append msg \"This probably means that Tcl wasn't installed properly.\n\"\n\
+    error $msg\n\
+  }\n\
+}\n\
+tclInit";
+
diff --git a/generic/tclResolve.c b/generic/tclResolve.c
new file mode 100644
index 0000000..a2bbe46
--- /dev/null
+++ b/generic/tclResolve.c
@@ -0,0 +1,423 @@
+/*
+ * tclResolve.c --
+ *
+ *      Contains hooks for customized command/variable name resolution
+ *      schemes.  These hooks allow extensions like [incr Tcl] to add
+ *      their own name resolution rules to the Tcl language.  Rules can
+ *      be applied to a particular namespace, to the interpreter as a
+ *      whole, or both.
+ *
+ * Copyright (c) 1998 Lucent Technologies, Inc.
+ *
+ * Originally implemented by
+ *   Michael J. McLennan
+ *   Bell Labs Innovations for Lucent Technologies
+ *   mmclennan@lucent.com
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: %Z% $Id: tclResolve.c,v 1.1 1998/06/28 21:41:31 welch Exp $ 
+ */
+
+#include "tclInt.h"
+
+/*
+ * Declarations for procedures local to this file:
+ */
+
+static void		BumpCmdRefEpochs _ANSI_ARGS_((Namespace *nsPtr));
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_AddInterpResolvers --
+ *
+ *	Adds a set of command/variable resolution procedures to an
+ *	interpreter.  These procedures are consulted when commands
+ *	are resolved in Tcl_FindCommand, and when variables are
+ *	resolved in TclLookupVar and LookupCompiledLocal.  Each
+ *	namespace may also have its own set of resolution procedures
+ *	which take precedence over those for the interpreter.
+ *
+ *	When a name is resolved, it is handled as follows.  First,
+ *	the name is passed to the resolution procedures for the
+ *	namespace.  If not resolved, the name is passed to each of
+ *	the resolution procedures added to the interpreter.  Finally,
+ *	if still not resolved, the name is handled using the default
+ *	Tcl rules for name resolution.
+ *
+ * Results:
+ *	Returns pointers to the current name resolution procedures
+ *	in the cmdProcPtr, varProcPtr and compiledVarProcPtr
+ *	arguments.
+ *
+ * Side effects:
+ *	If a compiledVarProc is specified, this procedure bumps the
+ *	compileEpoch for the interpreter, forcing all code to be
+ *	recompiled.  If a cmdProc is specified, this procedure bumps
+ *	the cmdRefEpoch in all namespaces, forcing commands to be
+ *	resolved again using the new rules.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_AddInterpResolvers(interp, name, cmdProc, varProc, compiledVarProc)
+
+    Tcl_Interp *interp;			/* Interpreter whose name resolution
+					 * rules are being modified. */
+    char *name;				/* Name of this resolution scheme. */
+    Tcl_ResolveCmdProc *cmdProc;	/* New procedure for command
+					 * resolution */
+    Tcl_ResolveVarProc *varProc;	/* Procedure for variable resolution
+					 * at runtime */
+    Tcl_ResolveCompiledVarProc *compiledVarProc;
+					/* Procedure for variable resolution
+					 * at compile time. */
+{
+    Interp *iPtr = (Interp*)interp;
+    ResolverScheme *resPtr;
+
+    /*
+     *  Since we're adding a new name resolution scheme, we must force
+     *  all code to be recompiled to use the new scheme.  If there
+     *  are new compiled variable resolution rules, bump the compiler
+     *  epoch to invalidate compiled code.  If there are new command
+     *  resolution rules, bump the cmdRefEpoch in all namespaces.
+     */
+    if (compiledVarProc) {
+        iPtr->compileEpoch++;
+    }
+    if (cmdProc) {
+        BumpCmdRefEpochs(iPtr->globalNsPtr);
+    }
+
+    /*
+     *  Look for an existing scheme with the given name.  If found,
+     *  then replace its rules.
+     */
+    for (resPtr = iPtr->resolverPtr; resPtr != NULL; resPtr = resPtr->nextPtr) {
+        if (*name == *resPtr->name && strcmp(name, resPtr->name) == 0) {
+            resPtr->cmdResProc = cmdProc;
+            resPtr->varResProc = varProc;
+            resPtr->compiledVarResProc = compiledVarProc;
+            return;
+        }
+    }
+
+    /*
+     *  Otherwise, this is a new scheme.  Add it to the FRONT
+     *  of the linked list, so that it overrides existing schemes.
+     */
+    resPtr = (ResolverScheme *) ckalloc(sizeof(ResolverScheme));
+    resPtr->name = (char*)ckalloc((unsigned)(strlen(name)+1));
+    strcpy(resPtr->name, name);
+    resPtr->cmdResProc = cmdProc;
+    resPtr->varResProc = varProc;
+    resPtr->compiledVarResProc = compiledVarProc;
+    resPtr->nextPtr = iPtr->resolverPtr;
+    iPtr->resolverPtr = resPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetInterpResolvers --
+ *
+ *	Looks for a set of command/variable resolution procedures with
+ *	the given name in an interpreter.  These procedures are
+ *	registered by calling Tcl_AddInterpResolvers.
+ *
+ * Results:
+ *	If the name is recognized, this procedure returns non-zero,
+ *	along with pointers to the name resolution procedures in
+ *	the Tcl_ResolverInfo structure.  If the name is not recognized,
+ *	this procedure returns zero.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_GetInterpResolvers(interp, name, resInfoPtr)
+
+    Tcl_Interp *interp;			/* Interpreter whose name resolution
+					 * rules are being queried. */
+    char *name;                         /* Look for a scheme with this name. */
+    Tcl_ResolverInfo *resInfoPtr;	/* Returns pointers to the procedures,
+					 * if found */
+{
+    Interp *iPtr = (Interp*)interp;
+    ResolverScheme *resPtr;
+
+    /*
+     *  Look for an existing scheme with the given name.  If found,
+     *  then return pointers to its procedures.
+     */
+    for (resPtr = iPtr->resolverPtr; resPtr != NULL; resPtr = resPtr->nextPtr) {
+        if (*name == *resPtr->name && strcmp(name, resPtr->name) == 0) {
+	    resInfoPtr->cmdResProc = resPtr->cmdResProc;
+	    resInfoPtr->varResProc = resPtr->varResProc;
+	    resInfoPtr->compiledVarResProc = resPtr->compiledVarResProc;
+            return 1;
+        }
+    }
+
+    return 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_RemoveInterpResolvers --
+ *
+ *	Removes a set of command/variable resolution procedures
+ *	previously added by Tcl_AddInterpResolvers.  The next time
+ *	a command/variable name is resolved, these procedures
+ *	won't be consulted.
+ *
+ * Results:
+ *	Returns non-zero if the name was recognized and the
+ *	resolution scheme was deleted.  Returns zero otherwise.
+ *
+ * Side effects:
+ *	If a scheme with a compiledVarProc was deleted, this procedure
+ *	bumps the compileEpoch for the interpreter, forcing all code
+ *	to be recompiled.  If a scheme with a cmdProc was deleted,
+ *	this procedure bumps the cmdRefEpoch in all namespaces,
+ *	forcing commands to be resolved again using the new rules.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_RemoveInterpResolvers(interp, name)
+
+    Tcl_Interp *interp;			/* Interpreter whose name resolution
+					 * rules are being modified. */
+    char *name;                         /* Name of the scheme to be removed. */
+{
+    Interp *iPtr = (Interp*)interp;
+    ResolverScheme **prevPtrPtr, *resPtr;
+
+    /*
+     *  Look for an existing scheme with the given name.
+     */
+    prevPtrPtr = &iPtr->resolverPtr;
+    for (resPtr = iPtr->resolverPtr; resPtr != NULL; resPtr = resPtr->nextPtr) {
+        if (*name == *resPtr->name && strcmp(name, resPtr->name) == 0) {
+            break;
+        }
+        prevPtrPtr = &resPtr->nextPtr;
+    }
+
+    /*
+     *  If we found the scheme, delete it.
+     */
+    if (resPtr) {
+        /*
+         *  If we're deleting a scheme with compiled variable resolution
+         *  rules, bump the compiler epoch to invalidate compiled code.
+         *  If we're deleting a scheme with command resolution rules,
+         *  bump the cmdRefEpoch in all namespaces.
+         */
+        if (resPtr->compiledVarResProc) {
+            iPtr->compileEpoch++;
+        }
+        if (resPtr->cmdResProc) {
+            BumpCmdRefEpochs(iPtr->globalNsPtr);
+        }
+
+        *prevPtrPtr = resPtr->nextPtr;
+        ckfree(resPtr->name);
+        ckfree((char *) resPtr);
+
+        return 1;
+    }
+    return 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * BumpCmdRefEpochs --
+ *
+ *	This procedure is used to bump the cmdRefEpoch counters in
+ *	the specified namespace and all of its child namespaces.
+ *	It is used whenever name resolution schemes are added/removed
+ *	from an interpreter, to invalidate all command references.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Bumps the cmdRefEpoch in the specified namespace and its
+ *	children, recursively.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+BumpCmdRefEpochs(nsPtr)
+    Namespace *nsPtr;			/* Namespace being modified. */
+{
+    Tcl_HashEntry *entry;
+    Tcl_HashSearch search;
+    Namespace *childNsPtr;
+
+    nsPtr->cmdRefEpoch++;
+
+    for (entry = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
+	    entry != NULL;
+	    entry = Tcl_NextHashEntry(&search)) {
+
+        childNsPtr = (Namespace *) Tcl_GetHashValue(entry);
+        BumpCmdRefEpochs(childNsPtr);
+    }
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetNamespaceResolvers --
+ *
+ *	Sets the command/variable resolution procedures for a namespace,
+ *	thereby changing the way that command/variable names are
+ *	interpreted.  This allows extension writers to support different
+ *	name resolution schemes, such as those for object-oriented
+ *	packages.
+ *
+ *	Command resolution is handled by a procedure of the following
+ *	type:
+ *
+ *	  typedef int (Tcl_ResolveCmdProc) _ANSI_ARGS_((
+ *		Tcl_Interp* interp, char* name, Tcl_Namespace *context,
+ *              int flags, Tcl_Command *rPtr));
+ *          
+ *	Whenever a command is executed or Tcl_FindCommand is invoked
+ *	within the namespace, this procedure is called to resolve the
+ *	command name.  If this procedure is able to resolve the name,
+ *	it should return the status code TCL_OK, along with the
+ *	corresponding Tcl_Command in the rPtr argument.  Otherwise,
+ *	the procedure can return TCL_CONTINUE, and the command will
+ *	be treated under the usual name resolution rules.  Or, it can
+ *	return TCL_ERROR, and the command will be considered invalid.
+ *
+ *	Variable resolution is handled by two procedures.  The first
+ *	is called whenever a variable needs to be resolved at compile
+ *	time:
+ *
+ *        typedef int (Tcl_ResolveCompiledVarProc) _ANSI_ARGS_((
+ *	        Tcl_Interp* interp, char* name, Tcl_Namespace *context,
+ *	        Tcl_ResolvedVarInfo *rPtr));
+ *
+ *      If this procedure is able to resolve the name, it should return
+ *      the status code TCL_OK, along with variable resolution info in
+ *      the rPtr argument; this info will be used to set up compiled
+ *	locals in the call frame at runtime.  The procedure may also
+ *	return TCL_CONTINUE, and the variable will be treated under
+ *	the usual name resolution rules.  Or, it can return TCL_ERROR,
+ *	and the variable will be considered invalid.
+ *
+ *	Another procedure is used whenever a variable needs to be
+ *	resolved at runtime but it is not recognized as a compiled local.
+ *	(For example, the variable may be requested via
+ *	Tcl_FindNamespaceVar.) This procedure has the following type:
+ *
+ *	  typedef int (Tcl_ResolveVarProc) _ANSI_ARGS_((
+ *	        Tcl_Interp* interp, char* name, Tcl_Namespace *context,
+ *	        int flags, Tcl_Var *rPtr));
+ *
+ *	This procedure is quite similar to the compile-time version.
+ *	It returns the same status codes, but if variable resolution
+ *	succeeds, this procedure returns a Tcl_Var directly via the
+ *	rPtr argument.
+ *
+ * Results:
+ *	Nothing.
+ *
+ * Side effects:
+ *	Bumps the command epoch counter for the namespace, invalidating
+ *	all command references in that namespace.  Also bumps the
+ *	resolver epoch counter for the namespace, forcing all code
+ *	in the namespace to be recompiled.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_SetNamespaceResolvers(namespacePtr, cmdProc, varProc, compiledVarProc)
+    Tcl_Namespace *namespacePtr;	/* Namespace whose resolution rules
+					 * are being modified. */
+    Tcl_ResolveCmdProc *cmdProc;	/* Procedure for command resolution */
+    Tcl_ResolveVarProc *varProc;	/* Procedure for variable resolution
+					 * at runtime */
+    Tcl_ResolveCompiledVarProc *compiledVarProc;
+					/* Procedure for variable resolution
+					 * at compile time. */
+{
+    Namespace *nsPtr = (Namespace*)namespacePtr;
+
+    /*
+     *  Plug in the new command resolver, and bump the epoch counters
+     *  so that all code will have to be recompiled and all commands
+     *  will have to be resolved again using the new policy.
+     */
+    nsPtr->cmdResProc = cmdProc;
+    nsPtr->varResProc = varProc;
+    nsPtr->compiledVarResProc = compiledVarProc;
+
+    nsPtr->cmdRefEpoch++;
+    nsPtr->resolverEpoch++;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetNamespaceResolvers --
+ *
+ *	Returns the current command/variable resolution procedures
+ *	for a namespace.  By default, these procedures are NULL.
+ *	New procedures can be installed by calling
+ *	Tcl_SetNamespaceResolvers, to provide new name resolution
+ *	rules.
+ *
+ * Results:
+ *	Returns non-zero if any name resolution procedures have been
+ *	assigned to this namespace; also returns pointers to the
+ *	procedures in the Tcl_ResolverInfo structure.  Returns zero
+ *	otherwise.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_GetNamespaceResolvers(namespacePtr, resInfoPtr)
+
+    Tcl_Namespace *namespacePtr;	/* Namespace whose resolution rules
+					 * are being modified. */
+    Tcl_ResolverInfo *resInfoPtr;	/* Returns: pointers for all
+					 * name resolution procedures
+					 * assigned to this namespace. */
+{
+    Namespace *nsPtr = (Namespace*)namespacePtr;
+
+    resInfoPtr->cmdResProc = nsPtr->cmdResProc;
+    resInfoPtr->varResProc = nsPtr->varResProc;
+    resInfoPtr->compiledVarResProc = nsPtr->compiledVarResProc;
+
+    if (nsPtr->cmdResProc != NULL ||
+        nsPtr->varResProc != NULL ||
+        nsPtr->compiledVarResProc != NULL) {
+	return 1;
+    }
+    return 0;
+}