summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclCompile.c5
-rw-r--r--generic/tclCompile.h4
-rw-r--r--generic/tclEnsemble.c81
-rw-r--r--generic/tclExecute.c57
4 files changed, 141 insertions, 6 deletions
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 309682d..c052531 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -529,6 +529,11 @@ InstructionDesc const tclInstructionTable[] = {
/* Forces the variable indexed by opnd to be an array. Does not touch
* the stack. */
+ {"invokeReplace", 5, INT_MIN, 1, {OPERAND_UINT4}},
+ /* Invoke command named objv[0], replacing the first two words with
+ * the word at the top of the stack;
+ * <objc,objv> = <op4,top op4 after popping 1> */
+
{NULL, 0, 0, 0, {OPERAND_NONE}}
};
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 3302f9b..4d8ed65 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -711,8 +711,10 @@ typedef struct ByteCode {
#define INST_ARRAY_MAKE_STK 161
#define INST_ARRAY_MAKE_IMM 162
+#define INST_INVOKE_REPLACE 163
+
/* The last opcode */
-#define LAST_INST_OPCODE 162
+#define LAST_INST_OPCODE 163
/*
* Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index b76c603..8f0d4fe 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -35,6 +35,14 @@ static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr,
static void FreeEnsembleCmdRep(Tcl_Obj *objPtr);
static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
static void StringOfEnsembleCmdRep(Tcl_Obj *objPtr);
+static int CompileToCompiledCommand(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Tcl_Token *tokenPtr,
+ int len, Tcl_Obj **elems, Command *cmdPtr,
+ CompileEnv *envPtr);
+static int CompileToInvokedCommand(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Tcl_Token *tokenPtr,
+ int len, Tcl_Obj **elems, Command *cmdPtr,
+ CompileEnv *envPtr);
/*
* The lists of subcommands and options for the [namespace ensemble] command.
@@ -2734,7 +2742,6 @@ TclCompileEnsemble(
Tcl_Token *tokenPtr;
Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems;
Tcl_Command ensemble = (Tcl_Command) cmdPtr;
- Tcl_Parse synthetic;
int len, result, flags = 0, i;
unsigned numBytes;
const char *word;
@@ -2920,7 +2927,7 @@ TclCompileEnsemble(
if (Tcl_ListObjGetElements(NULL, targetCmdObj, &len, &elems) != TCL_OK) {
return TCL_ERROR;
}
- if (len > 1 && Tcl_IsSafe(interp)) {
+ if (len > 1 || Tcl_IsSafe(interp)) {
return TCL_ERROR;
}
targetCmdObj = elems[0];
@@ -2928,7 +2935,7 @@ TclCompileEnsemble(
Tcl_IncrRefCount(targetCmdObj);
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj);
TclDecrRefCount(targetCmdObj);
- if (cmdPtr == NULL || cmdPtr->compileProc == NULL
+ if (cmdPtr == NULL
|| cmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION
|| cmdPtr->flags * CMD_HAS_EXEC_TRACES
|| ((Interp *)interp)->flags & DONT_COMPILE_CMDS_INLINE) {
@@ -2942,10 +2949,39 @@ TclCompileEnsemble(
/*
* Now we've done the mapping process, can now actually try to compile.
- * We do this by handing off to the subcommand's actual compiler. But to
- * do that, we have to perform some trickery to rewrite the arguments.
+ * If there is a subcommand compiler and that successfully produces code,
+ * we'll use that. Otherwise, we fall back to generating opcodes to do the
+ * invoke at runtime.
*/
+ if (cmdPtr->compileProc != NULL &&
+ CompileToCompiledCommand(interp, parsePtr, tokenPtr,
+ len, elems, cmdPtr, envPtr) == TCL_OK) {
+ return TCL_OK;
+ }
+ return CompileToInvokedCommand(interp, parsePtr, tokenPtr,
+ len, elems, cmdPtr, envPtr);
+}
+
+/*
+ * How to compile a subcommand using its own command compiler. To do that, we
+ * have to perform some trickery to rewrite the arguments, as compilers *must*
+ * have parse tokens that refer to addresses in the original script.
+ */
+
+static int
+CompileToCompiledCommand(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Tcl_Token *tokenPtr,
+ int len,
+ Tcl_Obj **elems,
+ Command *cmdPtr,
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Parse synthetic;
+ int result, i;
+
TclParseInit(interp, NULL, 0, &synthetic);
synthetic.numWords = parsePtr->numWords - 2 + len;
TclGrowParseTokenArray(&synthetic, 2*len);
@@ -3001,6 +3037,41 @@ TclCompileEnsemble(
Tcl_FreeParse(&synthetic);
return result;
}
+
+static int
+CompileToInvokedCommand(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Tcl_Token *tokenPtr,
+ int len,
+ Tcl_Obj **elems,
+ Command *cmdPtr,
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Obj *objPtr = Tcl_NewObj();
+ char *bytes;
+ int length, i, literal;
+
+ if (len != 1) {
+ return TCL_ERROR;
+ }
+
+ // TODO: Generate magic (with new instruction) for setting up the ensemble
+ // rewriting...
+
+ for (i=0,tokenPtr=parsePtr->tokenPtr ; i<parsePtr->numWords ; i++) {
+ TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, envPtr);
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+ Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
+ bytes = Tcl_GetStringFromObj(objPtr, &length);
+ literal = TclRegisterNewCmdLiteral(envPtr, bytes, length);
+ TclDecrRefCount(objPtr);
+ TclEmitPush(literal, envPtr);
+ TclEmitInstInt4(INST_INVOKE_REPLACE, parsePtr->numWords, envPtr);
+ TclAdjustStackDepth(-1, envPtr);
+ return TCL_OK;
+}
/*
* Local Variables:
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 2b5f713..3fab3cc 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -2972,6 +2972,63 @@ TEBCresume(
Tcl_Panic("TclNRExecuteByteCode: obsolete INST_CALL_FUNC1 found");
#endif
+ case INST_INVOKE_REPLACE:
+ objc = TclGetUInt4AtPtr(pc+1);
+ objPtr = POP_OBJECT();
+ objv = &OBJ_AT_DEPTH(objc-1);
+ cleanup = objc;
+#ifdef TCL_COMPILE_DEBUG
+ if (tclTraceExec >= 2) {
+ int i;
+
+ if (traceInstructions) {
+ strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
+ TRACE(("%u => call (implementation %s) ",
+ objc, O2S(objPtr)));
+ } else {
+ fprintf(stdout,
+ "%d: (%u) invoking (using implementation %s) ",
+ iPtr->numLevels, (unsigned)(pc - codePtr->codeStart),
+ O2S(objPtr));
+ }
+ for (i = 0; i < objc; i++) {
+ TclPrintObject(stdout, objv[i], 15);
+ fprintf(stdout, " ");
+ }
+ fprintf(stdout, "\n");
+ fflush(stdout);
+ }
+#endif /*TCL_COMPILE_DEBUG*/
+ {
+ Tcl_Obj *copyPtr = Tcl_NewListObj(objc - 1, NULL);
+ register List *listRepPtr = copyPtr->internalRep.twoPtrValue.ptr1;
+ Tcl_Obj **copyObjv = &listRepPtr->elements;
+ int i;
+
+ listRepPtr->elemCount = objc - 1;
+ copyObjv[0] = objPtr;
+ memcpy(copyObjv+1, objv+2, sizeof(Tcl_Obj *) * (objc - 2));
+ for (i=1 ; i<objc-1 ; i++) {
+ Tcl_IncrRefCount(copyObjv[i]);
+ }
+ objPtr = copyPtr;
+ }
+ bcFramePtr->data.tebc.pc = (char *) pc;
+ iPtr->cmdFramePtr = bcFramePtr;
+ if (iPtr->flags & INTERP_DEBUG_FRAME) {
+ TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
+ codePtr, bcFramePtr, pc - codePtr->codeStart);
+ }
+ iPtr->ensembleRewrite.sourceObjs = objv;
+ iPtr->ensembleRewrite.numRemovedObjs = 2;
+ iPtr->ensembleRewrite.numInsertedObjs = 1;
+ DECACHE_STACK_INFO();
+ pc += 5;
+ TEBC_YIELD();
+ TclNRAddCallback(interp, TclClearRootEnsemble, NULL,NULL,NULL,NULL);
+ iPtr->evalFlags |= TCL_EVAL_REDIRECT;
+ return TclNREvalObjEx(interp, objPtr, TCL_EVAL_INVOKE, NULL, INT_MIN);
+
/*
* -----------------------------------------------------------------
* Start of INST_LOAD instructions.
generated by cgit v0.12 at 2024-11-04 17:46:10 (GMT)