diff options
| -rw-r--r-- | ChangeLog | 6 | ||||
| -rw-r--r-- | generic/tclCmdIL.c | 45 | ||||
| -rw-r--r-- | generic/tclInt.h | 18 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 76 |
4 files changed, 98 insertions, 47 deletions
@@ -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 |