Factor out the core compiled-ensemble builder for simplicity.

4 files changed, 98 insertions, 47 deletions

diff --git a/ChangeLog b/ChangeLog
index 81a3205..7d9ae95 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,4 +1,8 @@
-2007-10-21  Donal K. Fellows  <donal.k.fellows@manchester.ac.uk>
+2007-11-21  Donal K. Fellows  <donal.k.fellows@manchester.ac.uk>
+
+	* generic/tclNamesp.c (TclMakeEnsemble): Factor out the code to set up
+	a core ensemble from a table of information about subcommands, ready
+	for reuse within the core.
 
 	* generic/various: Start to return more useful Error codes, currently
 	mainly on assorted lookup failures.
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 8c3262e..8d05eba 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -16,7 +16,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclCmdIL.c,v 1.126 2007/11/16 14:11:51 dkf Exp $
+ * RCS: @(#) $Id: tclCmdIL.c,v 1.127 2007/11/21 14:30:31 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -149,11 +149,7 @@ static Tcl_Obj *	SelectObjFromSublist(Tcl_Obj *firstPtr,
  * "info" command.
  */
 
-static const struct {
-    const char *name;		/* The name of the subcommand. */
-    Tcl_ObjCmdProc *proc;	/* The implementation of the subcommand. */
-    CompileProc *compileProc;	/* The compiler for the subcommand. */
-} defaultInfoMap[] = {
+static const EnsembleImplMap defaultInfoMap[] = {
     {"args",		   InfoArgsCmd,		    NULL},
     {"body",		   InfoBodyCmd,		    NULL},
     {"cmdcount",	   InfoCmdCountCmd,	    NULL},
@@ -388,42 +384,7 @@ Tcl_Command
 TclInitInfoCmd(
     Tcl_Interp *interp)		/* Current interpreter. */
 {
-    Tcl_Command ensemble;	/* The overall ensemble. */
-    Tcl_Namespace *tclNsPtr;	/* Reference to the "::tcl" namespace. */
-
-    tclNsPtr = Tcl_FindNamespace(interp, "::tcl", NULL,
-	    TCL_CREATE_NS_IF_UNKNOWN);
-    if (tclNsPtr == NULL) {
-	Tcl_Panic("unable to find or create ::tcl namespace!");
-    }
-    tclNsPtr = Tcl_FindNamespace(interp, "::tcl::info", NULL,
-	    TCL_CREATE_NS_IF_UNKNOWN);
-    if (tclNsPtr == NULL) {
-	Tcl_Panic("unable to find or create ::tcl::info namespace!");
-    }
-    ensemble = Tcl_CreateEnsemble(interp, "::info", tclNsPtr,
-	    TCL_ENSEMBLE_PREFIX | ENSEMBLE_COMPILE);
-    if (ensemble != NULL) {
-	Tcl_Obj *mapDict;
-	int i;
-
-	TclNewObj(mapDict);
-	for (i=0 ; defaultInfoMap[i].name != NULL ; i++) {
-	    Tcl_Obj *fromObj, *toObj;
-	    Command *cmdPtr;
-
-	    fromObj = Tcl_NewStringObj(defaultInfoMap[i].name, -1);
-	    TclNewLiteralStringObj(toObj, "::tcl::info::");
-	    Tcl_AppendToObj(toObj, defaultInfoMap[i].name, -1);
-	    Tcl_DictObjPut(NULL, mapDict, fromObj, toObj);
-	    cmdPtr = (Command *) Tcl_CreateObjCommand(interp,
-		    TclGetString(toObj), defaultInfoMap[i].proc, NULL, NULL);
-	    cmdPtr->compileProc = defaultInfoMap[i].compileProc;
-	}
-	Tcl_SetEnsembleMappingDict(interp, ensemble, mapDict);
-    }
-
-    return ensemble;
+    return TclMakeEnsemble(interp, "info", defaultInfoMap);
 }
 
 /*
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 479232b..f726571 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -13,7 +13,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclInt.h,v 1.349 2007/11/20 20:43:12 dkf Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.350 2007/11/21 14:30:34 dkf Exp $
  */
 
 #ifndef _TCLINT
@@ -1291,7 +1291,6 @@ typedef struct ExecStack {
     Tcl_Obj *stackWords[1];
 } ExecStack;
 
-
 /*
  * The data structure defining the execution environment for ByteCode's.
  * There is one ExecEnv structure per Tcl interpreter. It holds the evaluation
@@ -1394,6 +1393,17 @@ typedef struct ByteCodeStats {
 #endif /* TCL_COMPILE_STATS */
 
 /*
+ * Structure used in implementation of those core ensembles which are
+ * partially compiled.
+ */
+
+typedef struct {
+    const char *name;		/* The name of the subcommand. */
+    Tcl_ObjCmdProc *proc;	/* The implementation of the subcommand. */
+    CompileProc *compileProc;	/* The compiler for the subcommand. */
+} EnsembleImplMap;
+
+/*
  *----------------------------------------------------------------
  * Data structures related to commands.
  *----------------------------------------------------------------
@@ -1880,7 +1890,7 @@ typedef struct Interp {
 } Interp;
 
 /*
- * Macros that use the TSD-ekeko 
+ * Macros that use the TSD-ekeko.
  */
 
 #define TclAsyncReady(iPtr) \
@@ -2521,6 +2531,8 @@ MODULE_SCOPE Tcl_Obj *	TclLsetList(Tcl_Interp *interp, Tcl_Obj *listPtr,
 MODULE_SCOPE Tcl_Obj *	TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr,
 			    int indexCount, Tcl_Obj *const indexArray[],
 			    Tcl_Obj *valuePtr);
+MODULE_SCOPE Tcl_Command TclMakeEnsemble(Tcl_Interp *interp, const char *name,
+			    const EnsembleImplMap map[]);
 MODULE_SCOPE int        TclMarkList(Tcl_Interp *interp, const char *list,
 			    const char *end, int *argcPtr,
 			    const int **argszPtr, const char ***argvPtr);
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index bab0684..d8023a7 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -23,7 +23,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclNamesp.c,v 1.157 2007/11/19 11:02:40 dkf Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.158 2007/11/21 14:30:34 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -5875,6 +5875,80 @@ Tcl_IsEnsemble(
 /*
  *----------------------------------------------------------------------
  *
+ * TclMakeEnsemble --
+ *
+ *	Create an ensemble from a table of implementation commands. The
+ *	ensemble will be subject to (limited) compilation if any of the
+ *	implementation commands are compilable.
+ *
+ * Results:
+ *	Handle for the ensemble, or NULL if creation of it fails.
+ *
+ * Side effects:
+ *	May advance bytecode compilation epoch.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Command
+TclMakeEnsemble(
+    Tcl_Interp *interp,
+    const char *name,
+    const EnsembleImplMap map[])
+{
+    Tcl_Command ensemble;	/* The overall ensemble. */
+    Tcl_Namespace *tclNsPtr;	/* Reference to the "::tcl" namespace. */
+    Tcl_DString buf;
+
+    tclNsPtr = Tcl_FindNamespace(interp, "::tcl", NULL,
+	    TCL_CREATE_NS_IF_UNKNOWN);
+    if (tclNsPtr == NULL) {
+	Tcl_Panic("unable to find or create ::tcl namespace!");
+    }
+    Tcl_DStringInit(&buf);
+    Tcl_DStringAppend(&buf, "::tcl::", -1);
+    Tcl_DStringAppend(&buf, name, -1);
+    tclNsPtr = Tcl_FindNamespace(interp, Tcl_DStringValue(&buf), NULL,
+	    TCL_CREATE_NS_IF_UNKNOWN);
+    if (tclNsPtr == NULL) {
+	Tcl_Panic("unable to find or create %s namespace!",
+		Tcl_DStringValue(&buf));
+    }
+    ensemble = Tcl_CreateEnsemble(interp, Tcl_DStringValue(&buf)+5, tclNsPtr,
+	    TCL_ENSEMBLE_PREFIX);
+    Tcl_DStringAppend(&buf, "::", -1);
+    if (ensemble != NULL) {
+	Tcl_Obj *mapDict;
+	int i, compile = 0;
+
+	TclNewObj(mapDict);
+	for (i=0 ; map[i].name != NULL ; i++) {
+	    Tcl_Obj *fromObj, *toObj;
+	    Command *cmdPtr;
+
+	    fromObj = Tcl_NewStringObj(map[i].name, -1);
+	    TclNewStringObj(toObj, Tcl_DStringValue(&buf),
+		    Tcl_DStringLength(&buf));
+	    Tcl_AppendToObj(toObj, map[i].name, -1);
+	    Tcl_DictObjPut(NULL, mapDict, fromObj, toObj);
+	    cmdPtr = (Command *) Tcl_CreateObjCommand(interp,
+		    TclGetString(toObj), map[i].proc, NULL, NULL);
+	    cmdPtr->compileProc = map[i].compileProc;
+	    compile |= (map[i].compileProc != NULL);
+	}
+	Tcl_SetEnsembleMappingDict(interp, ensemble, mapDict);
+	if (compile) {
+	    Tcl_SetEnsembleFlags(interp, ensemble,
+		    TCL_ENSEMBLE_PREFIX | ENSEMBLE_COMPILE);
+	}
+    }
+
+    return ensemble;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * NsEnsembleImplementationCmd --
  *
  *	Implements an ensemble of commands (being those exported by a