summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--generic/tcl.decls28
-rw-r--r--generic/tclBasic.c770
-rw-r--r--generic/tclCompile.h9
-rw-r--r--generic/tclDecls.h64
-rw-r--r--generic/tclExecute.c391
-rw-r--r--generic/tclInt.decls33
-rw-r--r--generic/tclInt.h24
-rw-r--r--generic/tclIntDecls.h85
-rw-r--r--generic/tclInterp.c19
-rw-r--r--generic/tclNRE.h215
-rw-r--r--generic/tclNamesp.c12
-rw-r--r--generic/tclOOBasic.c7
-rw-r--r--generic/tclOOMethod.c19
-rw-r--r--generic/tclProc.c97
-rw-r--r--generic/tclStubInit.c29
-rw-r--r--generic/tclTest.c38
16 files changed, 641 insertions, 1199 deletions
diff --git a/generic/tcl.decls b/generic/tcl.decls
index 9700497..c67462e 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -12,7 +12,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: tcl.decls,v 1.141 2008/07/28 21:31:15 nijtmans Exp $
+# RCS: @(#) $Id: tcl.decls,v 1.142 2008/07/29 05:30:25 msofer Exp $
library tcl
@@ -2108,25 +2108,31 @@ declare 581 generic {
int Tcl_Canceled(Tcl_Interp *interp, int flags)
}
-# NRE public interface
+# TIP#304 (chan pipe)
+
declare 582 generic {
+ int Tcl_CreatePipe (Tcl_Interp *interp, Tcl_Channel *rchan, Tcl_Channel *wchan, int flags)
+}
+
+# TIP #322 (NRE public interface)
+declare 583 generic {
Tcl_Command Tcl_NRCreateCommand(Tcl_Interp *interp,
CONST char *cmdName, Tcl_ObjCmdProc *proc,
Tcl_ObjCmdProc *nreProc, ClientData clientData,
Tcl_CmdDeleteProc *deleteProc)
}
-declare 583 generic {
+declare 584 generic {
int Tcl_NREvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags)
}
-declare 584 generic {
+declare 585 generic {
int Tcl_NREvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[],
int flags)
}
-declare 585 generic {
+declare 586 generic {
int Tcl_NRCmdSwap(Tcl_Interp *interp, Tcl_Command cmd, int objc,
- Tcl_Obj *CONST objv[])
+ Tcl_Obj *CONST objv[], int flags)
}
-declare 586 generic {
+declare 587 generic {
void Tcl_NRAddCallback(Tcl_Interp *interp, Tcl_NRPostProc *postProcPtr,
ClientData data0, ClientData data1,
ClientData data2, ClientData data3)
@@ -2134,18 +2140,12 @@ declare 586 generic {
# For use by NR extenders, to have a simple way to also provide a (required!)
# classic objProc
-declare 587 generic {
+declare 588 generic {
int Tcl_NRCallObjProc(Tcl_Interp *interp, Tcl_ObjCmdProc *objProc,
ClientData clientData, int objc,
Tcl_Obj *CONST objv[])
}
-# TIP#304 (chan pipe)
-
-declare 588 generic {
- int Tcl_CreatePipe (Tcl_Interp *interp, Tcl_Channel *rchan, Tcl_Channel *wchan, int flags)
-}
-
##############################################################################
# Define the platform specific public Tcl interface. These functions are
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 87a36b3..cb96099 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.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: tclBasic.c,v 1.332 2008/07/28 21:06:09 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.333 2008/07/29 05:30:25 msofer Exp $
*/
#include "tclInt.h"
@@ -107,7 +107,7 @@ static int DTraceObjCmd(ClientData dummy, Tcl_Interp *interp, int objc,
MODULE_SCOPE const TclStubs * const tclConstStubsPtr;
/*
- * Block for Tcl_EvalObjv helpers
+ * Tcl_EvalObjv helpers
*/
static void TEOV_SwitchVarFrame(Tcl_Interp *interp);
@@ -120,8 +120,6 @@ static int TEOV_NotFound(Tcl_Interp *interp, int objc,
static int TEOV_RunEnterTraces(Tcl_Interp *interp,
Command **cmdPtrPtr, int objc,
Tcl_Obj *const objv[], Namespace *lookupNsPtr);
-static int NRPostProcess(Tcl_Interp *interp, int result,
- int objc, Tcl_Obj *const objv[]);
static Tcl_NRPostProc TEOV_RestoreVarFrame;
static Tcl_NRPostProc TEOV_RunLeaveTraces;
static Tcl_NRPostProc TEOV_Exception;
@@ -129,7 +127,26 @@ static Tcl_NRPostProc TEOV_Error;
static Tcl_NRPostProc TEOEx_ListCallback;
static Tcl_NRPostProc TEOEx_ByteCodeCallback;
-static Tcl_NRPostProc TailcallCallback;
+static Tcl_NRPostProc NRCommand;
+static Tcl_NRPostProc NRRunObjProc;
+
+static Tcl_NRPostProc EvalTailcall;
+
+#define NR_IS_COMMAND(callbackPtr) \
+ (callbackPtr \
+ && (callbackPtr->procPtr == NRCommand) \
+ && (PTR2INT(callbackPtr->data[1])))
+
+#define NR_CLEAR_COMMAND(interp) \
+ TEOV_callback *callbackPtr = TOP_CB(interp); \
+ \
+ while (!NR_IS_COMMAND(callbackPtr)) { \
+ callbackPtr = callbackPtr->nextPtr; \
+ } \
+ if (callbackPtr) { \
+ callbackPtr->data[1] = INT2PTR(0); \
+ }
+
/*
* The following structure define the commands in the Tcl core.
@@ -894,7 +911,7 @@ Tcl_CreateInterp(void)
Tcl_Panic(Tcl_GetString(Tcl_GetObjResult(interp)));
}
- TOP_RECORD(iPtr) = NULL;
+ TOP_CB(iPtr) = NULL;
return interp;
}
@@ -3950,7 +3967,7 @@ Tcl_CancelEval(
* TCL_ERROR. A result or error message is left in interp's result.
*
* Side effects:
- * Depends on the command.
+ * Always pushes a callback. Other side effects depend on the command.
*
*----------------------------------------------------------------------
*/
@@ -3967,11 +3984,15 @@ Tcl_EvalObjv(
* TCL_EVAL_GLOBAL, TCL_EVAL_INVOKE and
* TCL_EVAL_NOERR are currently supported. */
{
- return TclEvalObjv(interp, objc, objv, flags, NULL);
+ int result;
+ TEOV_callback *rootPtr = TOP_CB(interp);
+
+ result = TclNREvalObjv(interp, objc, objv, flags, NULL);
+ return TclNRRunCallbacks(interp, result, rootPtr, 0);
}
int
-TclEvalObjv(
+TclNREvalObjv(
Tcl_Interp *interp, /* Interpreter in which to evaluate the
* command. Also used for error reporting. */
int objc, /* Number of words in command. */
@@ -3987,40 +4008,38 @@ TclEvalObjv(
{
Interp *iPtr = (Interp *) interp;
int result;
- Namespace *lookupNsPtr = NULL;
- TEOV_record *rootPtr = TOP_RECORD(iPtr);
- TEOV_record *recordPtr;
+ Namespace *lookupNsPtr = iPtr->lookupNsPtr;
Tcl_ObjCmdProc *objProc;
ClientData objClientData;
- int tebcCall = TEBC_CALL(iPtr);
-
- TEBC_CALL(iPtr) = 0;
-
- if (cmdPtr) {
- if (iPtr->lookupNsPtr) {
- iPtr->lookupNsPtr = NULL;
- }
- PUSH_RECORD(interp, recordPtr);
- goto commandFound;
- }
+ Command **cmdPtrPtr;
+
+ iPtr->lookupNsPtr = NULL;
+
+ /*
+ * Push a callback with cleanup tasks for commands; the cmdPtr at data[0]
+ * will be filled later when the command is found: save its address at
+ * objProcPtr.
+ *
+ * data[1] stores a marker for use by tailcalls; it will be reset to 0 by
+ * command redirectors (imports, alias, ensembles) so that tailcalls
+ * finishes the source command and not just the target.
+ */
- restartAtTop:
+ TclNRAddCallback(interp, NRCommand, NULL, INT2PTR(1),
+ NULL, NULL);
+ cmdPtrPtr = (Command **) &(TOP_CB(interp)->data[0]);
+
TclResetCancellation(interp, 0);
iPtr->numLevels++;
result = TclInterpReady(interp);
if ((result != TCL_OK) || (objc == 0)) {
- iPtr->lookupNsPtr = NULL;
- iPtr->numLevels--;
- goto done;
+ return result;
}
- /*
- * Always push a record for the command (avoid queuing callbacks for an
- * older command!)
- */
-
- PUSH_RECORD(interp, recordPtr);
+ if (cmdPtr) {
+ goto commandFound;
+ }
/*
* Push records for task to be done on return, in INVERSE order. First, if
@@ -4035,12 +4054,9 @@ TclEvalObjv(
* Configure evaluation context to match the requested flags.
*/
- lookupNsPtr = iPtr->lookupNsPtr;
if ((flags & TCL_EVAL_INVOKE) || lookupNsPtr) {
if (!lookupNsPtr) {
lookupNsPtr = iPtr->globalNsPtr;
- } else {
- iPtr->lookupNsPtr = NULL;
}
} else {
if (flags & TCL_EVAL_GLOBAL) {
@@ -4063,15 +4079,12 @@ TclEvalObjv(
if (!cmdPtr) {
notFound:
result = TEOV_NotFound(interp, objc, objv, lookupNsPtr);
- iPtr->numLevels--;
- goto done;
+ return result;
}
iPtr->cmdCount++;
if (TclLimitExceeded(iPtr->limit)) {
- result = TCL_ERROR;
- iPtr->numLevels--;
- goto done;
+ return TCL_ERROR;
}
/*
@@ -4090,8 +4103,7 @@ TclEvalObjv(
goto notFound;
}
if (result != TCL_OK) {
- iPtr->numLevels--;
- goto done;
+ return result;
}
}
@@ -4115,154 +4127,38 @@ TclEvalObjv(
}
/*
- * Finally, invoke the command's Tcl_ObjCmdProc.
- *
- * Do the NR dance right here:
- * - for non-NR enabled commands, just sigh and call the objProc
- * - for NR-enabled commands call the part1, decide what to do with the
- * continuation:
- * . if it is a bytecode AND we were called by TEBC, pass it back.
- * Otherwise just call a new TEBC on it. Don't register the
- * callback, TEBC handles those.
- * . if it is a command and it has a callback, push the callback
- * into the TODO list, set the params as needed and restart at the
- * top.
- *
- * Note that I removed the DTRACE thing: I have not really thought about
- * where it really belongs, and do not really know what it does either.
+ * Fix the original callback to point to the now known cmdPtr. Insure that
+ * the Command struct lives until the command returns.
*/
- objProc = cmdPtr->nreProc;
- if (!objProc) {
- objProc = cmdPtr->objProc;
- }
- objClientData = cmdPtr->objClientData;
-
- COMPLETE_RECORD(recordPtr);
+ *cmdPtrPtr = cmdPtr;
cmdPtr->refCount++;
-
- /*
- * If this is an NR-enabled command, find the real objProc.
- */
-
- result = (*objProc)(objClientData, interp, objc, objv);
- if (result != TCL_OK) {
-#if 0
- TclStackPurge(interp, recordPtr->tosPtr);
-#endif
- goto done;
- }
-
+
/*
- * We got a valid callback request: let us complete the corresponding
- * record and proceed with the next call.
+ * Find the objProc to call: nreProc if available, objProc otherwise. Push
+ * a callback to do the actual running.
*/
- callbackReentryPoint:
- switch(recordPtr->type) {
- case TCL_NR_NO_TYPE:
- break;
- case TCL_NR_BC_TYPE:
- tcl_nr_bc_type:
- if (USE_NR_TEBC && tebcCall) {
- return TCL_OK;
- }
-
- /*
- * No TEBC atop - we'll just have to instantiate a new one and do the
- * callback on return.
- */
-
- result = TclExecuteByteCode(interp, recordPtr->data.codePtr);
- goto done;
- case TCL_NR_TAILCALL_TYPE:
- /*
- * Proceed to cleanup the current command, the tailcall will be run
- * from the callbacks.
- */
-
- if (USE_NR_TEBC && tebcCall) {
- return TCL_OK;
- }
- recordPtr->type = TCL_NR_NO_TYPE;
- break;
- case TCL_NR_CMD_TYPE: {
- /*
- * We got an unshared canonical list to eval , do it from here.
- */
-
- Tcl_Obj *objPtr = recordPtr->data.obj.objPtr;
- Tcl_Obj **elemPtr;
-
- flags = recordPtr->data.obj.flags;
- Tcl_ListObjGetElements(NULL, objPtr, &objc, &elemPtr);
- objv = elemPtr;
- if (objc != 0) {
- goto restartAtTop;
- }
- goto done;
- }
- case TCL_NR_SCRIPT_TYPE: {
- Tcl_Obj *objPtr = recordPtr->data.obj.objPtr;
-
- flags = recordPtr->data.obj.flags;
- if (USE_NR_TEBC && tebcCall) {
- result = TclNREvalObjEx(interp, objPtr, flags, NULL, 0);
- if (result == TCL_OK) {
- switch (recordPtr->type) {
- case TCL_NR_BC_TYPE:
- goto tcl_nr_bc_type;
- case TCL_NR_NO_TYPE:
- goto done;
- default:
- Tcl_Panic("TEOEx called from TEOV returns unexpected record type: %d",
- recordPtr->type);
- }
- }
- } else {
- result = TclEvalObjEx(interp, objPtr, flags, NULL, 0);
- }
- goto done;
- }
- case TCL_NR_CMDSWAP_TYPE:
- /*
- * This is a cmdPtr swap like ns-import does.
- */
-
- cmdPtr = recordPtr->cmdPtr;
- objc = recordPtr->data.objcv.objc;
- objv = recordPtr->data.objcv.objv;
- recordPtr->type = TCL_NR_NO_TYPE;
- goto commandFound;
- default:
- Tcl_Panic("TEOV: unknown NR-request type %i!", recordPtr->type);
- }
-
- done:
- result = TclEvalObjv_NR2(interp, result, rootPtr);
- recordPtr = TOP_RECORD(iPtr);
- if (recordPtr == rootPtr) {
- return result;
+ objProc = cmdPtr->nreProc;
+ if (!objProc) {
+ objProc = cmdPtr->objProc;
}
+ objClientData = cmdPtr->objClientData;
- /*
- * A callback scheduled a new evaluation! Deal with it.
- * Note that recordPtr was already updated right above.
- */
-
- assert((result == TCL_OK));
- goto callbackReentryPoint;
+ TclNRAddCallback(interp, NRRunObjProc, objProc, objClientData,
+ INT2PTR(objc), (ClientData) objv);
+ return TCL_OK;
}
int
-TclEvalObjv_NR2(
+TclNRRunCallbacks(
Tcl_Interp *interp,
int result,
- struct TEOV_record *rootPtr)
+ struct TEOV_callback *rootPtr,
+ int tebcCall)
{
Interp *iPtr = (Interp *) interp;
- TEOV_record *recordPtr;
- TEOV_callback *callbackPtr;
+ TEOV_callback *callbackPtr = TOP_CB(interp);
/*
* If the interpreter has a non-empty string result, the result object is
@@ -4278,68 +4174,57 @@ TclEvalObjv_NR2(
(void) Tcl_GetObjResult(interp);
}
- restart:
- while ((recordPtr = TOP_RECORD(iPtr)) != rootPtr) {
- while (recordPtr->callbackPtr) {
- callbackPtr = recordPtr->callbackPtr;
- recordPtr->callbackPtr = callbackPtr->nextPtr;
- result = callbackPtr->procPtr(callbackPtr->data, interp, result);
- TclSmallFree(callbackPtr);
-
- if (recordPtr != TOP_RECORD(iPtr)) {
-
- if (result != TCL_OK) {
- goto restart;
- }
+ while (TOP_CB(interp) != rootPtr) {
+ callbackPtr = TOP_CB(interp);
+ if (tebcCall) {
+ if ((callbackPtr->procPtr == NRRunBytecode) ||
+ (callbackPtr->procPtr == NRDropCommand)) {
/*
- * A callback scheduled a new evaluation; return so that our
- * caller can run it.
+ * TEBC pass thru: let the caller tebc handle and get rid of
+ * this callback.
*/
- switch(recordPtr->type) {
- case TCL_NR_NO_TYPE:
- goto restart;
- case TCL_NR_BC_TYPE:
- case TCL_NR_CMD_TYPE:
- case TCL_NR_SCRIPT_TYPE:
- case TCL_NR_CMDSWAP_TYPE:
- goto done;
- case TCL_NR_TAILCALL_TYPE:
- Tcl_Panic("Tailcall called from a callback!");
- default:
- Tcl_Panic("TEOV_NR2: invalid record type: %d",
- recordPtr->type);
- }
+ return TCL_OK;
}
}
- TOP_RECORD(iPtr) = recordPtr->nextPtr;
-
- if (!CHECK_EXTRA(iPtr, recordPtr)) {
- Tcl_Panic("TclEvalObjv_NR2: wrong tosPtr?");
- /* TclStackPurge(interp, recordPtr->tosPtr); */
- }
/*
- * Decrement the reference count of cmdPtr and deallocate it if it has
- * dropped to zero. The level only needs fixing for records that
- * pushed a cmdPtr.
+ * IMPLEMENTATION REMARKS (FIXME)
+ *
+ * Add here other direct handling possibilities for optimisation?
+ * One could handle the very frequent NRCommand and NRRunObjProc right
+ * here to save an indirect function call and improve icache
+ * management. Would it? Test it, time it ...
*/
- if (recordPtr->cmdPtr) {
- TclCleanupCommandMacro(recordPtr->cmdPtr);
- iPtr->numLevels--;
- }
-
- FREE_RECORD(iPtr, recordPtr);
+ TOP_CB(interp) = callbackPtr->nextPtr;
+ result = callbackPtr->procPtr(callbackPtr->data, interp, result);
+ TCLNR_FREE(interp, callbackPtr);
}
+ return result;
+}
- /*
- * Do not interrupt a series of cleanups with async or limit checks: just
- * check at the end.
- */
+static int
+NRCommand(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *) interp;
+ Command *cmdPtr = data[0];
+ /* int cmdStart = PTR2INT(data[1]); NOT USED HERE */
- done:
+
+ if (cmdPtr) {
+ TclCleanupCommandMacro(cmdPtr);
+ }
+ ((Interp *)interp)->numLevels--;
+
+ /* OPT ??
+ * Do not interrupt a series of cleanups with async or limit checks:
+ * just check at the end?
+ */
if (TclAsyncReady(iPtr)) {
result = Tcl_AsyncInvoke(interp, result);
@@ -4350,6 +4235,52 @@ TclEvalObjv_NR2(
if (result == TCL_OK && TclLimitReady(iPtr->limit)) {
result = Tcl_LimitCheck(interp);
}
+ return result;
+}
+
+static int
+NRRunObjProc(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ /* OPT: do not call? */
+
+ Tcl_ObjCmdProc *objProc = data[0];
+ ClientData objClientData = data[1];
+ int objc = PTR2INT(data[2]);
+ Tcl_Obj **objv = data[3];
+
+ if (result == TCL_OK) {
+ return (*objProc)(objClientData, interp, objc, objv);
+ }
+ return result;
+}
+
+int
+NRRunBytecode(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ ByteCode *codePtr = data[0];
+
+ if (result == TCL_OK) {
+ return TclExecuteByteCode(interp, codePtr);
+ }
+ return result;
+}
+
+int
+NRDropCommand(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ /* For tailcalls!
+ * drop all callbacks until the last command start: nothing to do here,
+ * just need this to be able to pass it up to tebc.
+ */
return result;
}
@@ -4670,7 +4601,7 @@ TEOV_RunLeaveTraces(
Tcl_DecrRefCount(commandPtr);
/*
- * As cmdPtr is set, TclEvalObjv_NR2 is about to reduce the numlevels.
+ * As cmdPtr is set, TclNRRunCallbacks is about to reduce the numlevels.
* Prevent that by resetting the cmdPtr field and dealing right here with
* cmdPtr->refCount.
*/
@@ -5110,7 +5041,7 @@ TclEvalEx(
TclArgumentEnter(interp, objv, objectsUsed, eeFramePtr);
iPtr->cmdFramePtr = eeFramePtr;
- code = TclEvalObjv(interp, objectsUsed, objv, TCL_EVAL_NOERR, NULL);
+ code = Tcl_EvalObjv(interp, objectsUsed, objv, TCL_EVAL_NOERR);
iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
TclArgumentRelease(interp, objv, objectsUsed);
@@ -5706,17 +5637,10 @@ TclEvalObjEx(
int word) /* Index of the word which is in objPtr. */
{
int result = TCL_OK;
- TEOV_record *recordPtr;
-
- /*
- * Push an empty record. If this is an NR call, it will modify it
- * accordingly.
- */
+ TEOV_callback *rootPtr = TOP_CB(interp);
- PUSH_RECORD(interp, recordPtr);
result = TclNREvalObjEx(interp, objPtr, flags, invoker, word);
- assert((TOP_RECORD(interp) == recordPtr));
- return NRPostProcess(interp, result, 0, NULL);
+ return TclNRRunCallbacks(interp, result, rootPtr, 0);
}
int
@@ -5759,28 +5683,15 @@ TclNREvalObjEx(
if (objPtr->bytes == NULL || /* ...without a string rep */
listRepPtr->canonicalFlag) { /* ...or that is canonical */
+ Tcl_Obj *listPtr = objPtr;
+ CmdFrame *eoFramePtr = NULL;
+ int objc;
+ Tcl_Obj **objv;
+
/*
* TIP #280 Structures for tracking lines. As we know that this is
* dynamic execution we ignore the invoker, even if known.
- */
-
- CmdFrame *eoFramePtr;
-
- eoFramePtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame));
- eoFramePtr->nline = 0;
- eoFramePtr->line = NULL;
-
- eoFramePtr->type = TCL_LOCATION_EVAL_LIST;
- eoFramePtr->level = (iPtr->cmdFramePtr == NULL?
- 1 : iPtr->cmdFramePtr->level + 1);
- eoFramePtr->numLevels = iPtr->numLevels;
- eoFramePtr->framePtr = iPtr->framePtr;
- eoFramePtr->nextPtr = iPtr->cmdFramePtr;
-
- eoFramePtr->cmd.listPtr = objPtr;
- eoFramePtr->data.eval.path = NULL;
-
- /*
+ *
* TIP #280. We do _not_ compute all the line numbers for the
* words in the command. For the eval of a pure list the most
* sensible choice is to put all words on line 1. Given that we
@@ -5788,13 +5699,44 @@ TclNREvalObjEx(
* left NULL. The two places using this information (TclInfoFrame,
* and TclInitCompileEnv), are special-cased to use the proper
* line number directly instead of accessing the 'line' array.
+ *
+ * Note that we use (word==INTMIN) to signal that no command frame
+ * should be pushed, as needed by alias and ensemble redirections.
*/
- iPtr->cmdFramePtr = eoFramePtr;
+ if (word != INT_MIN) {
+ eoFramePtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame));
+ eoFramePtr->nline = 0;
+ eoFramePtr->line = NULL;
+
+ eoFramePtr->type = TCL_LOCATION_EVAL_LIST;
+ eoFramePtr->level = (iPtr->cmdFramePtr == NULL?
+ 1 : iPtr->cmdFramePtr->level + 1);
+ eoFramePtr->numLevels = iPtr->numLevels;
+ eoFramePtr->framePtr = iPtr->framePtr;
+ eoFramePtr->nextPtr = iPtr->cmdFramePtr;
+
+ eoFramePtr->cmd.listPtr = objPtr;
+ eoFramePtr->data.eval.path = NULL;
+
+ iPtr->cmdFramePtr = eoFramePtr;
+ }
+
+ /*
+ * Shimmer protection! Always pass an unshared obj. The caller could
+ * incr the refCount of objPtr AFTER calling us! To be completely safe
+ * we always make a copy.
+ *
+ * FIXME OPT: preserve just the internal rep?
+ */
+ listPtr = TclListObjCopy(interp, objPtr);
+ Tcl_IncrRefCount(listPtr);
TclNRAddCallback(interp, TEOEx_ListCallback, objPtr, eoFramePtr,
- NULL, NULL);
- return Tcl_NREvalObj(interp, objPtr, flags);
+ listPtr, NULL);
+
+ ListObjGetElements(listPtr, objc, objv);
+ return TclNREvalObjv(interp, objc, objv, flags, NULL);
}
}
@@ -5806,7 +5748,7 @@ TclNREvalObjEx(
* We transfer this to the byte code compiler.
*/
- ByteCode *newCodePtr;
+ ByteCode *codePtr;
CallFrame *savedVarFramePtr = NULL; /* Saves old copy of
* iPtr->varFramePtr in case
* TCL_EVAL_GLOBAL was set. */
@@ -5815,18 +5757,12 @@ TclNREvalObjEx(
savedVarFramePtr = iPtr->varFramePtr;
iPtr->varFramePtr = iPtr->rootFramePtr;
}
+ codePtr = TclCompileObj(interp, objPtr, invoker, word);
+
TclNRAddCallback(interp, TEOEx_ByteCodeCallback, savedVarFramePtr,
objPtr, INT2PTR(allowExceptions), NULL);
-
- newCodePtr = TclCompileObj(interp, objPtr, invoker, word);
- if (newCodePtr) {
- TEOV_record *recordPtr = TOP_RECORD(interp);
-
- recordPtr->type = TCL_NR_BC_TYPE;
- recordPtr->data.codePtr = newCodePtr;
- return TCL_OK;
- }
- return TCL_ERROR;
+ TclNRAddCallback(interp, NRRunBytecode, codePtr, NULL, NULL, NULL);
+ return TCL_OK;
}
/*
@@ -5962,14 +5898,18 @@ TEOEx_ListCallback(
Interp *iPtr = (Interp *) interp;
Tcl_Obj *objPtr = data[0];
CmdFrame *eoFramePtr = data[1];
+ Tcl_Obj *listPtr = data[2];
/*
* Remove the cmdFrame
*/
- iPtr->cmdFramePtr = eoFramePtr->nextPtr;
- TclStackFree(interp, eoFramePtr);
+ if (eoFramePtr) {
+ iPtr->cmdFramePtr = eoFramePtr->nextPtr;
+ TclStackFree(interp, eoFramePtr);
+ }
TclDecrRefCount(objPtr);
+ TclDecrRefCount(listPtr);
return result;
}
@@ -7764,76 +7704,10 @@ Tcl_NRCallObjProc(
Tcl_Obj *const objv[])
{
int result = TCL_OK;
- TEOV_record *recordPtr;
+ TEOV_callback *rootPtr = TOP_CB(interp);
- /*
- * Push an empty record. If this is an NR call, it will modify it
- * accordingly.
- */
-
- PUSH_RECORD(interp, recordPtr);
result = (*objProc)(clientData, interp, objc, objv);
- return NRPostProcess(interp, result, objc, objv);
-}
-
-static int
-NRPostProcess(
- Tcl_Interp *interp,
- int result,
- int objc,
- Tcl_Obj *const objv[])
-{
- TEOV_record *recordPtr, *rootPtr = TOP_RECORD(interp)->nextPtr;
-
- restart:
- recordPtr = TOP_RECORD(interp);
- if (result == TCL_OK) {
- switch (recordPtr->type) {
- case TCL_NR_NO_TYPE:
- break;
- case TCL_NR_BC_TYPE:
- result = TclExecuteByteCode(interp, recordPtr->data.codePtr);
- break;
- case TCL_NR_TAILCALL_TYPE:
- Tcl_SetResult(interp,
- "impossible to tailcall from a non-NRE enabled command",
- TCL_STATIC);
- result = TCL_ERROR;
- break;
- case TCL_NR_CMD_TYPE: {
- Tcl_Obj *objPtr = recordPtr->data.obj.objPtr;
- int flags = recordPtr->data.obj.flags;
- Tcl_Obj **objv;
- int objc;
-
- Tcl_ListObjGetElements(NULL, objPtr, &objc, &objv);
- result = TclEvalObjv(interp, objc, objv, flags, NULL);
- break;
- }
- case TCL_NR_SCRIPT_TYPE: {
- Tcl_Obj *objPtr = recordPtr->data.obj.objPtr;
- int flags = recordPtr->data.obj.flags;
-
- result = TclNREvalObjEx(interp, objPtr, flags, NULL, 0);
- break;
- }
- case TCL_NR_CMDSWAP_TYPE: {
- result = TclEvalObjv(interp, recordPtr->data.objcv.objc,
- recordPtr->data.objcv.objv, 0, recordPtr->cmdPtr);
- break;
- }
- default:
- Tcl_Panic("NRPostProcess: invalid record type: %d",
- recordPtr->type);
- }
- }
-
- result = TclEvalObjv_NR2(interp, result, rootPtr);
- if (TOP_RECORD(interp) != rootPtr) {
- assert((result == TCL_OK));
- goto restart;
- }
- return result;
+ return TclNRRunCallbacks(interp, result, rootPtr, 0);
}
/*
@@ -7891,31 +7765,18 @@ Tcl_NRCreateCommand(
return (Tcl_Command) cmdPtr;
}
-/*
- * These are the previous contents of tclNRE.c, part of the NRE api.
- *
- * TclNREvalCmd should only be called as an optimisation: when objPtr is known
- * to be a canonical list that is not (and will not!) be shared
- */
+/****************************************************************************
+ * Stuff for the public api
+ ****************************************************************************/
int
-TclNREvalCmd(
+Tcl_NREvalObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
int flags)
{
- TEOV_record *recordPtr = TOP_RECORD(interp);
-
- Tcl_IncrRefCount(objPtr);
- recordPtr->type = TCL_NR_CMD_TYPE;
- recordPtr->data.obj.objPtr = objPtr;
- recordPtr->data.obj.flags = flags;
- return TCL_OK;
+ return TclNREvalObjEx(interp, objPtr, flags, NULL, INT_MIN);
}
-
-/****************************************************************************
- * Stuff for the public api
- ****************************************************************************/
int
Tcl_NREvalObjv(
@@ -7929,42 +7790,14 @@ Tcl_NREvalObjv(
* TCL_EVAL_GLOBAL, TCL_EVAL_INVOKE and
* TCL_EVAL_NOERR are currently supported. */
{
- Tcl_Obj *listPtr = Tcl_NewListObj(objc, objv);
-
- return TclNREvalCmd(interp, listPtr, flags);
+ return TclNREvalObjv(interp, objc, objv, flags, NULL);
}
-int
-Tcl_NREvalObj(
- Tcl_Interp *interp,
- Tcl_Obj *objPtr,
- int flags)
+void
+TclNRClearCommandFlag(
+ Tcl_Interp *interp)
{
- TEOV_record *recordPtr = TOP_RECORD(interp);
- List *listRep = objPtr->internalRep.twoPtrValue.ptr1;
-
- Tcl_IncrRefCount(objPtr);
- if ((objPtr->typePtr == &tclListType)
- && (!objPtr->bytes || listRep->canonicalFlag)) {
- /*
- * Shimmer protection! Always pass an unshared obj. The caller could
- * incr the refCount of objPtr AFTER calling us! To be completely safe
- * we always make a copy.
- */
-
- Tcl_Obj *origPtr = objPtr;
-
- objPtr = TclListObjCopy(NULL, origPtr);
- Tcl_IncrRefCount(objPtr);
- TclDecrRefCount(origPtr);
-
- recordPtr->type = TCL_NR_CMD_TYPE;
- } else {
- recordPtr->type = TCL_NR_SCRIPT_TYPE;
- }
- recordPtr->data.obj.objPtr = objPtr;
- recordPtr->data.obj.flags = flags;
- return TCL_OK;
+ NR_CLEAR_COMMAND(interp);
}
int
@@ -7972,16 +7805,14 @@ Tcl_NRCmdSwap(
Tcl_Interp *interp,
Tcl_Command cmd,
int objc,
- Tcl_Obj *const objv[])
+ Tcl_Obj *const objv[],
+ int flags)
{
- TEOV_record *recordPtr = TOP_RECORD(interp);
-
- recordPtr->type = TCL_NR_CMDSWAP_TYPE;
- recordPtr->cmdPtr = (Command *) cmd;
- recordPtr->data.objcv.objc = objc;
- recordPtr->data.objcv.objv = (Tcl_Obj **) objv;
+ int result;
- return TCL_OK;
+ result = TclNREvalObjv(interp, objc, objv, flags, (Command *)cmd);
+ NR_CLEAR_COMMAND(interp);
+ return result;
}
/*****************************************************************************
@@ -8016,85 +7847,82 @@ TclTailcallObjCmd(
Tcl_Obj *const objv[])
{
Interp *iPtr = (Interp *) interp;
- TEOV_record *rootPtr = TOP_RECORD(interp);
- TEOV_callback *headPtr, *tailPtr;
- TEOV_record *tmpPtr;
- Tcl_Obj *listPtr;
+ TEOV_callback *rootPtr = TOP_CB(interp);
+ TEOV_callback *tailPtr;
+ Tcl_Obj *scriptPtr;
Namespace *nsPtr = iPtr->varFramePtr->nsPtr;
-
- if (!iPtr->varFramePtr->isProcCallFrame) {
- /* FIXME! Why error? Just look if we have a TEOV above! */
- Tcl_SetResult(interp,
- "tailcall can only be called from a proc or lambda", TCL_STATIC);
- return TCL_ERROR;
+ int count;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?");
}
- nsPtr->activationCount++;
- listPtr = Tcl_NewListObj(objc-1, objv+1);
- rootPtr->type = TCL_NR_TAILCALL_TYPE;
-
/*
- * Add a callback to perform the tailcall as LAST item in the caller's
+ * Add a callback to perform the tailcall as LAST item in the CALLER's
* callback stack.
- * Find the first record for the caller: start at the one below the top
- * (the top being this command's record), and go back until you find
- * the one that contains the cmdPtr.
+ * Find the first record for the caller:
+ * 1. find the SECOND callback that contains a cmdPtr below the top (note
+ * that the FIRST one correspond to this TclTailcallObjCmd call)
+ * 2. set the callback for the tailcalled command below that
*/
- tmpPtr = rootPtr->nextPtr;
- while (tmpPtr->cmdPtr == NULL) {
- tmpPtr = tmpPtr->nextPtr;
+ tailPtr = rootPtr;
+ count = NR_IS_COMMAND(tailPtr);
+ while (tailPtr && tailPtr->nextPtr && (count < 2)) {
+ tailPtr = tailPtr->nextPtr;
+ count += NR_IS_COMMAND(tailPtr);
}
- /*
- * Now find the first and last callbacks in this record, and temporarily
- * set the callback list to empty.
- */
-
- headPtr = tailPtr = tmpPtr->callbackPtr;
- if (headPtr) {
- while (tailPtr->nextPtr) {
- tailPtr = tailPtr->nextPtr;
- }
- tmpPtr->callbackPtr = NULL;
+#if 1
+ if (!iPtr->varFramePtr->isProcCallFrame) {
+ /* FIXME! Why error? Just look if we have a TEOV above! */
+ Tcl_SetResult(interp,
+ "tailcall can only be called from a proc or lambda", TCL_STATIC);
+ return TCL_ERROR;
+ }
+#else
+ if (!tailPtr->nextPtr) {
+ /* FIXME! Is this the behaviour we want? */
+ Tcl_SetResult(interp,
+ "cannot tailcall: not running a command", TCL_STATIC);
+ return TCL_ERROR;
}
+#endif
/*
- * Temporarily put tmpPtr as the TOP_RECORD, register a callback, then
+ * Temporarily put NULL as the TOP_BC, register a callback, then
* replug things back the way they were.
*/
- TOP_RECORD(iPtr) = tmpPtr;
- TclNRAddCallback(interp, TailcallCallback, listPtr, nsPtr, NULL, NULL);
- TOP_RECORD(iPtr) = rootPtr;
-
- if (headPtr) {
- tailPtr->nextPtr = tmpPtr->callbackPtr;
- tmpPtr->callbackPtr = headPtr;
+ nsPtr->activationCount++;
+ if (objc == 2) {
+ scriptPtr = objv[1];
+ } else {
+ scriptPtr = Tcl_NewListObj(objc-1, objv+1);
}
+ TOP_CB(iPtr) = tailPtr->nextPtr;
+ TclNRAddCallback(interp, EvalTailcall, scriptPtr, nsPtr, NULL, NULL);
+ tailPtr->nextPtr = TOP_CB(iPtr);
+ TOP_CB(iPtr) = rootPtr;
+
+ TclNRAddCallback(interp, NRDropCommand, NULL, NULL, NULL, NULL);
return TCL_OK;
}
static int
-TailcallCallback(
+EvalTailcall(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
- Tcl_Obj *listPtr = data[0], *namePtr;
+ Tcl_Obj *scriptPtr = data[0];
Namespace *nsPtr = data[1];
- TEOV_record *recordPtr = TOP_RECORD(iPtr);
- Command *cmdPtr = NULL;
- if (!recordPtr->cmdPtr || recordPtr->callbackPtr) {
- Tcl_Panic("TailcallCallback: should not happen!");
- }
-
- result = Tcl_ListObjIndex(interp, listPtr, 0, &namePtr);
if (result == TCL_OK) {
- cmdPtr = TEOV_LookupCmdFromObj(interp, namePtr, nsPtr);
+ iPtr->lookupNsPtr = nsPtr;
+ result = TclNREvalObjEx(interp, scriptPtr, 0, NULL, 0);
}
nsPtr->activationCount--;
@@ -8107,29 +7935,7 @@ TailcallCallback(
Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr);
}
-
- if (!cmdPtr || (result != TCL_OK)) {
- Tcl_DecrRefCount(listPtr);
- Tcl_SetResult(interp,
- "the command to be tailcalled does not exist", TCL_STATIC);
- return TCL_ERROR;
- }
-
- /*
- * Take over the previous command's record.
- */
-
- TclCleanupCommandMacro(recordPtr->cmdPtr);
- recordPtr->cmdPtr = cmdPtr;
- cmdPtr->refCount++;
-
- /*
- * Push a new record to signal that a new command was scheduled.
- */
-
- PUSH_RECORD(iPtr, recordPtr);
- iPtr->lookupNsPtr = nsPtr;
- return TclNREvalCmd(interp, listPtr, 0);
+ return result;
}
void
@@ -8142,31 +7948,11 @@ Tcl_NRAddCallback(
ClientData data3)
{
if (!(postProcPtr)) {
- Tcl_Panic("Adding a callback without and objProc?!");
+ Tcl_Panic("Adding a callback without an objProc?!");
}
TclNRAddCallback(interp, postProcPtr, data0, data1, data2, data3);
}
-TEOV_record *
-TclNRPushRecord(
- Tcl_Interp *interp)
-{
- TEOV_record *recordPtr;
-
- PUSH_RECORD(interp, recordPtr);
- return recordPtr;
-}
-
-void
-TclNRPopAndFreeRecord(
- Tcl_Interp *interp)
-{
- TEOV_record *recordPtr;
-
- POP_RECORD(interp, recordPtr);
- FREE_RECORD(interp, recordPtr);
-}
-
/*
* Local Variables:
* mode: c
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 63df8ce..c5ab71d 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompile.h,v 1.96 2008/07/22 22:24:21 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.97 2008/07/29 05:30:25 msofer Exp $
*/
#ifndef _TCLCOMPILATION
@@ -830,15 +830,16 @@ typedef struct {
} i;
} TclOpCmdClientData;
+
/*
*----------------------------------------------------------------
* Procedures exported by tclBasic.c to be used within the engine.
*----------------------------------------------------------------
*/
-MODULE_SCOPE int TclEvalObjvInternal(Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[],
- const char *command, int length, int flags);
+MODULE_SCOPE Tcl_NRPostProc NRRunBytecode;
+MODULE_SCOPE Tcl_NRPostProc NRDropCommand;
+
/*
*----------------------------------------------------------------
* Procedures exported by the engine to be used by tclBasic.c
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index 138911f..1417bf9 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclDecls.h,v 1.143 2008/07/28 21:31:21 nijtmans Exp $
+ * RCS: @(#) $Id: tclDecls.h,v 1.144 2008/07/29 05:30:25 msofer Exp $
*/
#ifndef _TCLDECLS
@@ -3517,9 +3517,16 @@ EXTERN int Tcl_CancelEval (Tcl_Interp * interp,
/* 581 */
EXTERN int Tcl_Canceled (Tcl_Interp * interp, int flags);
#endif
+#ifndef Tcl_CreatePipe_TCL_DECLARED
+#define Tcl_CreatePipe_TCL_DECLARED
+/* 582 */
+EXTERN int Tcl_CreatePipe (Tcl_Interp * interp,
+ Tcl_Channel * rchan, Tcl_Channel * wchan,
+ int flags);
+#endif
#ifndef Tcl_NRCreateCommand_TCL_DECLARED
#define Tcl_NRCreateCommand_TCL_DECLARED
-/* 582 */
+/* 583 */
EXTERN Tcl_Command Tcl_NRCreateCommand (Tcl_Interp * interp,
CONST char * cmdName, Tcl_ObjCmdProc * proc,
Tcl_ObjCmdProc * nreProc,
@@ -3528,25 +3535,25 @@ EXTERN Tcl_Command Tcl_NRCreateCommand (Tcl_Interp * interp,
#endif
#ifndef Tcl_NREvalObj_TCL_DECLARED
#define Tcl_NREvalObj_TCL_DECLARED
-/* 583 */
+/* 584 */
EXTERN int Tcl_NREvalObj (Tcl_Interp * interp, Tcl_Obj * objPtr,
int flags);
#endif
#ifndef Tcl_NREvalObjv_TCL_DECLARED
#define Tcl_NREvalObjv_TCL_DECLARED
-/* 584 */
+/* 585 */
EXTERN int Tcl_NREvalObjv (Tcl_Interp * interp, int objc,
Tcl_Obj *CONST objv[], int flags);
#endif
#ifndef Tcl_NRCmdSwap_TCL_DECLARED
#define Tcl_NRCmdSwap_TCL_DECLARED
-/* 585 */
+/* 586 */
EXTERN int Tcl_NRCmdSwap (Tcl_Interp * interp, Tcl_Command cmd,
- int objc, Tcl_Obj *CONST objv[]);
+ int objc, Tcl_Obj *CONST objv[], int flags);
#endif
#ifndef Tcl_NRAddCallback_TCL_DECLARED
#define Tcl_NRAddCallback_TCL_DECLARED
-/* 586 */
+/* 587 */
EXTERN void Tcl_NRAddCallback (Tcl_Interp * interp,
Tcl_NRPostProc * postProcPtr,
ClientData data0, ClientData data1,
@@ -3554,19 +3561,12 @@ EXTERN void Tcl_NRAddCallback (Tcl_Interp * interp,
#endif
#ifndef Tcl_NRCallObjProc_TCL_DECLARED
#define Tcl_NRCallObjProc_TCL_DECLARED
-/* 587 */
+/* 588 */
EXTERN int Tcl_NRCallObjProc (Tcl_Interp * interp,
Tcl_ObjCmdProc * objProc,
ClientData clientData, int objc,
Tcl_Obj *CONST objv[]);
#endif
-#ifndef Tcl_CreatePipe_TCL_DECLARED
-#define Tcl_CreatePipe_TCL_DECLARED
-/* 588 */
-EXTERN int Tcl_CreatePipe (Tcl_Interp * interp,
- Tcl_Channel * rchan, Tcl_Channel * wchan,
- int flags);
-#endif
typedef struct TclStubHooks {
CONST struct TclPlatStubs *tclPlatStubs;
@@ -4208,13 +4208,13 @@ typedef struct TclStubs {
void (*tcl_AppendPrintfToObj) (Tcl_Obj * objPtr, CONST char * format, ...); /* 579 */
int (*tcl_CancelEval) (Tcl_Interp * interp, Tcl_Obj * resultObjPtr, ClientData clientData, int flags); /* 580 */
int (*tcl_Canceled) (Tcl_Interp * interp, int flags); /* 581 */
- Tcl_Command (*tcl_NRCreateCommand) (Tcl_Interp * interp, CONST char * cmdName, Tcl_ObjCmdProc * proc, Tcl_ObjCmdProc * nreProc, ClientData clientData, Tcl_CmdDeleteProc * deleteProc); /* 582 */
- int (*tcl_NREvalObj) (Tcl_Interp * interp, Tcl_Obj * objPtr, int flags); /* 583 */
- int (*tcl_NREvalObjv) (Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], int flags); /* 584 */
- int (*tcl_NRCmdSwap) (Tcl_Interp * interp, Tcl_Command cmd, int objc, Tcl_Obj *CONST objv[]); /* 585 */
- void (*tcl_NRAddCallback) (Tcl_Interp * interp, Tcl_NRPostProc * postProcPtr, ClientData data0, ClientData data1, ClientData data2, ClientData data3); /* 586 */
- int (*tcl_NRCallObjProc) (Tcl_Interp * interp, Tcl_ObjCmdProc * objProc, ClientData clientData, int objc, Tcl_Obj *CONST objv[]); /* 587 */
- int (*tcl_CreatePipe) (Tcl_Interp * interp, Tcl_Channel * rchan, Tcl_Channel * wchan, int flags); /* 588 */
+ int (*tcl_CreatePipe) (Tcl_Interp * interp, Tcl_Channel * rchan, Tcl_Channel * wchan, int flags); /* 582 */
+ Tcl_Command (*tcl_NRCreateCommand) (Tcl_Interp * interp, CONST char * cmdName, Tcl_ObjCmdProc * proc, Tcl_ObjCmdProc * nreProc, ClientData clientData, Tcl_CmdDeleteProc * deleteProc); /* 583 */
+ int (*tcl_NREvalObj) (Tcl_Interp * interp, Tcl_Obj * objPtr, int flags); /* 584 */
+ int (*tcl_NREvalObjv) (Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], int flags); /* 585 */
+ int (*tcl_NRCmdSwap) (Tcl_Interp * interp, Tcl_Command cmd, int objc, Tcl_Obj *CONST objv[], int flags); /* 586 */
+ void (*tcl_NRAddCallback) (Tcl_Interp * interp, Tcl_NRPostProc * postProcPtr, ClientData data0, ClientData data1, ClientData data2, ClientData data3); /* 587 */
+ int (*tcl_NRCallObjProc) (Tcl_Interp * interp, Tcl_ObjCmdProc * objProc, ClientData clientData, int objc, Tcl_Obj *CONST objv[]); /* 588 */
} TclStubs;
#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
@@ -6615,33 +6615,33 @@ extern CONST TclStubs *tclStubsPtr;
#define Tcl_Canceled \
(tclStubsPtr->tcl_Canceled) /* 581 */
#endif
+#ifndef Tcl_CreatePipe
+#define Tcl_CreatePipe \
+ (tclStubsPtr->tcl_CreatePipe) /* 582 */
+#endif
#ifndef Tcl_NRCreateCommand
#define Tcl_NRCreateCommand \
- (tclStubsPtr->tcl_NRCreateCommand) /* 582 */
+ (tclStubsPtr->tcl_NRCreateCommand) /* 583 */
#endif
#ifndef Tcl_NREvalObj
#define Tcl_NREvalObj \
- (tclStubsPtr->tcl_NREvalObj) /* 583 */
+ (tclStubsPtr->tcl_NREvalObj) /* 584 */
#endif
#ifndef Tcl_NREvalObjv
#define Tcl_NREvalObjv \
- (tclStubsPtr->tcl_NREvalObjv) /* 584 */
+ (tclStubsPtr->tcl_NREvalObjv) /* 585 */
#endif
#ifndef Tcl_NRCmdSwap
#define Tcl_NRCmdSwap \
- (tclStubsPtr->tcl_NRCmdSwap) /* 585 */
+ (tclStubsPtr->tcl_NRCmdSwap) /* 586 */
#endif
#ifndef Tcl_NRAddCallback
#define Tcl_NRAddCallback \
- (tclStubsPtr->tcl_NRAddCallback) /* 586 */
+ (tclStubsPtr->tcl_NRAddCallback) /* 587 */
#endif
#ifndef Tcl_NRCallObjProc
#define Tcl_NRCallObjProc \
- (tclStubsPtr->tcl_NRCallObjProc) /* 587 */
-#endif
-#ifndef Tcl_CreatePipe
-#define Tcl_CreatePipe \
- (tclStubsPtr->tcl_CreatePipe) /* 588 */
+ (tclStubsPtr->tcl_NRCallObjProc) /* 588 */
#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 0102f5a..0aee386 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -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.
*
- * RCS: @(#) $Id: tclExecute.c,v 1.387 2008/07/22 21:41:55 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.388 2008/07/29 05:30:26 msofer Exp $
*/
#include "tclInt.h"
@@ -166,27 +166,26 @@ static BuiltinFunc tclBuiltinFuncTable[] = {
/*
* NR_TEBC
* Helpers for NR - non-recursive calls to TEBC
+ * Minimal data required to fully reconstruct the execution state.
*/
typedef struct BottomData {
-#if USE_NR_TEBC
struct BottomData *prevBottomPtr;
- TEOV_record *recordPtr; /* Top record on TEOVI's cleanup stack when
- * this level was entered. */
- ByteCode *codePtr; /* The following data is used on return */
- unsigned char *pc; /* TO this level: they record the state when */
- ptrdiff_t *catchTop; /* a new codePtr was received for NR */
- int cleanup; /* execution. */
+ TEOV_callback *rootPtr; /* State when this bytecode execution began. */
+ ByteCode *codePtr; /* These fields remain constant until it */
+ CmdFrame *cmdFramePtr; /* returns. */
+ /* ------------------------------------------*/
+ unsigned char *pc; /* These fields are used on return TO this */
+ ptrdiff_t *catchTop; /* this level: they record the state when a */
+ int cleanup; /* new codePtr was received for NR execution */
Tcl_Obj *auxObjList;
-#endif
} BottomData;
-#if USE_NR_TEBC
-
-#define NR_DATA_INIT() \
+#define NR_DATA_INIT() \
bottomPtr->prevBottomPtr = oldBottomPtr; \
- bottomPtr->recordPtr = TOP_RECORD(iPtr); \
- bottomPtr->codePtr = codePtr
+ bottomPtr->rootPtr = TOP_CB(iPtr); \
+ bottomPtr->codePtr = codePtr; \
+ bottomPtr->cmdFramePtr = iPtr->cmdFramePtr
#define NR_DATA_BURY() \
bottomPtr->pc = pc; \
@@ -201,12 +200,13 @@ typedef struct BottomData {
catchTop = bottomPtr->catchTop; \
cleanup = bottomPtr->cleanup; \
auxObjList = bottomPtr->auxObjList; \
- iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr
-#endif
+ esPtr = iPtr->execEnvPtr->execStackPtr; \
+ tosPtr = esPtr->tosPtr; \
+ iPtr->cmdFramePtr = bottomPtr->cmdFramePtr;
#define PUSH_AUX_OBJ(objPtr) \
objPtr->internalRep.twoPtrValue.ptr2 = auxObjList; \
- auxObjList = objPtr
+ auxObjList = objPtr
#define POP_AUX_OBJ() \
{ \
@@ -799,8 +799,7 @@ TclCreateExecEnv(
Tcl_IncrRefCount(eePtr->constants[0]);
TclNewBooleanObj(eePtr->constants[1], 1);
Tcl_IncrRefCount(eePtr->constants[1]);
- eePtr->recordPtr = NULL;
- eePtr->tebcCall = 0;
+ eePtr->callbackPtr = NULL;
esPtr->prevPtr = NULL;
esPtr->nextPtr = NULL;
@@ -875,7 +874,7 @@ TclDeleteExecEnv(
TclDecrRefCount(eePtr->constants[0]);
TclDecrRefCount(eePtr->constants[1]);
- if (eePtr->recordPtr) {
+ if (eePtr->callbackPtr) {
Tcl_Panic("Deleting execEnv with pending TEOV callbacks!");
}
ckfree((char *) eePtr);
@@ -1473,7 +1472,7 @@ FreeExprCodeInternalRep(
* This procedure compiles the script contained in a Tcl_Obj
*
* Results:
- * A pointer to the corresponding ByteCode
+ * A pointer to the corresponding ByteCode, never NULL.
*
* Side effects:
* The object is shimmered to bytecode type
@@ -1752,9 +1751,7 @@ TclExecuteByteCode(
/* NR_TEBC */
BottomData *bottomPtr;
-#if USE_NR_TEBC
BottomData *oldBottomPtr = NULL;
-#endif
/*
* Constants: variables that do not change during the execution, used
@@ -1793,10 +1790,7 @@ TclExecuteByteCode(
register int cleanup;
Tcl_Obj *objResultPtr;
- int evalFlags = TCL_EVAL_NOERR;
-#if (USE_NR_TEBC)
- int tailcall = 0;
-#endif
+
/*
* Result variable - needed only when going to checkForcatch or other
* error handlers; also used as local in some opcodes.
@@ -1826,13 +1820,47 @@ TclExecuteByteCode(
* execution stack is large enough to execute this ByteCode.
*/
- /*
- * NR_TEBC
- */
+ int nested = 0;
-#if USE_NR_TEBC
nonRecursiveCallStart:
+ if (nested) {
+ TEOV_callback *callbackPtr = TOP_CB(interp);
+ Tcl_NRPostProc *procPtr = callbackPtr->procPtr;
+ ByteCode *newCodePtr = callbackPtr->data[0];
+
+ assert((result==TCL_OK));
+ assert((callbackPtr != bottomPtr->rootPtr));
+
+ TOP_CB(interp) = callbackPtr->nextPtr;
+ TCLNR_FREE(interp, callbackPtr);
+
+ if (procPtr == NRRunBytecode) {
+ NR_DATA_BURY(); /* this level's state variables */
+ codePtr = newCodePtr;
+ } else if (procPtr == NRDropCommand) {
+ /*
+ * A request to perform a tailcall: just drop this
+ * bytecode as it is; the tailCall has been scheduled in
+ * the callbacks.
+ */
+#ifdef TCL_COMPILE_DEBUG
+ if (traceInstructions) {
+ fprintf(stdout, " Tailcall: request received\n");
+ }
#endif
+ if (catchTop != initCatchTop) {
+ result = TCL_ERROR;
+ Tcl_SetResult(interp,"Tailcall called from within a catch environment",
+ TCL_STATIC);
+ goto checkForCatch;
+ }
+ goto abnormalReturn; /* drop a level */
+ } else {
+ Tcl_Panic("TEBC: TRCB sent us a record we cannot handle! (1)");
+ }
+ }
+ nested = 1;
+
codePtr->refCount++;
bottomPtr = (BottomData *) GrowEvaluationStack(iPtr->execEnvPtr,
sizeof(BottomData) + codePtr->maxExceptDepth + sizeof(CmdFrame)
@@ -1840,12 +1868,9 @@ TclExecuteByteCode(
curInstName = NULL;
auxObjList = NULL;
initLevel = 1;
-
-#if USE_NR_TEBC
NR_DATA_INIT(); /* record this level's data */
-
+
nonRecursiveCallReturn:
-#endif
bcFramePtr = (CmdFrame *) (bottomPtr + 1);
initCatchTop = ((ptrdiff_t *) (bcFramePtr + 1)) - 1;
initTosPtr = (Tcl_Obj **) (initCatchTop + codePtr->maxExceptDepth);
@@ -1880,10 +1905,6 @@ TclExecuteByteCode(
TclArgumentBCEnter((Tcl_Interp*) iPtr,codePtr,bcFramePtr);
-#if (USE_NR_TEBC)
- } else if (tailcall) {
- goto tailcallEntry;
-#endif
} else {
/*
* Returning from a non-recursive call. State is already completely
@@ -2475,6 +2496,25 @@ TclExecuteByteCode(
NEXT_INST_F(5, 0, 0);
}
+ case INST_EXPR_STK: {
+ /*
+ * Moved here to support transforming the eval of an expression to
+ * a non-recursive TEBC call.
+ */
+
+ ByteCode *newCodePtr;
+
+ bcFramePtr->data.tebc.pc = (char *) pc;
+ iPtr->cmdFramePtr = bcFramePtr;
+ DECACHE_STACK_INFO();
+ newCodePtr = CompileExprObj(interp, OBJ_AT_TOS);
+ CACHE_STACK_INFO();
+ cleanup = 1;
+ pc++;
+ Tcl_NRAddCallback(interp, NRRunBytecode, newCodePtr, NULL, NULL, NULL);
+ goto nonRecursiveCallStart;
+ }
+
{
/*
* INVOCATION BLOCK
@@ -2482,70 +2522,7 @@ TclExecuteByteCode(
int objc, pcAdjustment;
Tcl_Obj **objv;
-#if (USE_NR_TEBC)
- TEOV_record *recordPtr;
- ByteCode *newCodePtr;
-#endif
- case INST_EXPR_STK: {
- /*
- * Moved here to support transforming the eval of an expression to
- * a non-recursive TEBC call.
- */
-
-#if (USE_NR_TEBC)
- pcAdjustment = 1;
- cleanup = 1;
- bcFramePtr->data.tebc.pc = (char *) pc;
- iPtr->cmdFramePtr = bcFramePtr;
- DECACHE_STACK_INFO();
- newCodePtr = CompileExprObj(interp, OBJ_AT_TOS);
- CACHE_STACK_INFO();
- goto tebc_do_exec;
-#else
- Tcl_Obj *objPtr, *valuePtr;
-
- objPtr = OBJ_AT_TOS;
-
- DECACHE_STACK_INFO();
- /*Tcl_ResetResult(interp);*/
- result = Tcl_ExprObj(interp, objPtr, &valuePtr);
- CACHE_STACK_INFO();
- if (result == TCL_OK) {
- objResultPtr = valuePtr;
- TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
- NEXT_INST_F(1, 1, -1); /* Already has right refct. */
- } else {
- TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)),
- Tcl_GetObjResult(interp));
- cleanup = 1;
- goto checkForCatch;
- }
-#endif
- }
-
-#if (USE_NR_TEBC)
- tailcallEntry: {
- TEOV_record *recordPtr = TOP_RECORD(iPtr);
-
- /*
- * We take over the record's object, with its refCount. Clear the
- * record type so that it is not freed again when popping the
- * record.
- */
-
- recordPtr->type = TCL_NR_NO_TYPE;
- *++tosPtr = recordPtr->data.obj.objPtr;
- evalFlags = recordPtr->data.obj.flags;
- recordPtr->type = TCL_NR_NO_TYPE;
-#ifdef TCL_COMPILE_DEBUG
- if (traceInstructions) {
- fprintf(stdout, " Tailcall: pushing obj with refCount %i\n",
- (OBJ_AT_TOS)->refCount);
- }
-#endif
- }
-#endif
case INST_EVAL_STK: {
/*
* Moved here to support transforming the eval of objects to a
@@ -2554,10 +2531,10 @@ TclExecuteByteCode(
*/
Tcl_Obj *objPtr = OBJ_AT_TOS;
+ ByteCode *newCodePtr;
cleanup = 1;
- pcAdjustment = !tailcall;
- tailcall = 0;
+ pcAdjustment = 1;
if (objPtr->typePtr == &tclListType) { /* is a list... */
List *listRepPtr = objPtr->internalRep.twoPtrValue.ptr1;
@@ -2580,59 +2557,20 @@ TclExecuteByteCode(
}
/*
+ * Run the bytecode in this same TEBC instance!
+ *
* TIP #280: The invoking context is left NULL for a dynamically
* constructed command. We cannot match its lines to the outer
* context.
- */
+ */
DECACHE_STACK_INFO();
newCodePtr = TclCompileObj(interp, objPtr, NULL, 0);
- if (newCodePtr) {
- /*
- * Run the bytecode in this same TEBC instance!
- */
-#if (USE_NR_TEBC)
- bcFramePtr->data.tebc.pc = (char *) pc;
- iPtr->cmdFramePtr = bcFramePtr;
- goto tebc_do_exec;
-#else
- result = TclExecuteByteCode(interp, newCodePtr);
- CACHE_STACK_INFO();
-
- if (result == TCL_OK) {
- /*
- * Normal return; push the eval's object result.
- */
-
- objResultPtr = Tcl_GetObjResult(interp);
- TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)),
- Tcl_GetObjResult(interp));
-
- /*
- * Reset the interp's result to avoid possible duplications of
- * large objects [Bug 781585]. We do not call Tcl_ResetResult to
- * avoid any side effects caused by the resetting of errorInfo and
- * errorCode [Bug 804681], which are not needed here. We chose
- * instead to manipulate the interp's object result directly.
- *
- * Note that the result object is now in objResultPtr, it keeps
- * the refCount it had in its role of iPtr->objResultPtr.
- */
-
- TclNewObj(objPtr);
- Tcl_IncrRefCount(objPtr);
- iPtr->objResultPtr = objPtr;
- NEXT_INST_F(1, 1, -1);
- }
-#endif
- }
-
- /*
- * Compilation failed, error
- */
-
- result = TCL_ERROR;
- goto processExceptionReturn;
+ bcFramePtr->data.tebc.pc = (char *) pc;
+ iPtr->cmdFramePtr = bcFramePtr;
+ pc++;
+ Tcl_NRAddCallback(interp, NRRunBytecode, newCodePtr, NULL, NULL, NULL);
+ goto nonRecursiveCallStart;
}
case INST_INVOKE_EXPANDED:
@@ -2708,55 +2646,17 @@ TclExecuteByteCode(
DECACHE_STACK_INFO();
-#if (USE_NR_TEBC)
- TEBC_CALL(iPtr) = 1;
- recordPtr = TOP_RECORD(iPtr);
-#endif
- result = TclEvalObjv(interp, objc, objv, evalFlags, NULL);
+ result = TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR, NULL);
+ result = TclNRRunCallbacks(interp, result, bottomPtr->rootPtr, 1);
CACHE_STACK_INFO();
-#if (USE_NR_TEBC)
- evalFlags = TCL_EVAL_NOERR;
- if (TOP_RECORD(iPtr) != recordPtr) {
- assert((result == TCL_OK));
- recordPtr = TOP_RECORD(iPtr);
- switch(recordPtr->type) {
- case TCL_NR_BC_TYPE:
- newCodePtr = recordPtr->data.codePtr;
- tebc_do_exec:
- /*
- * A request to execute a bytecode came back. We save
- * the current state and restart at the top.
- */
- pc += pcAdjustment;
- NR_DATA_BURY(); /* this level's state variables */
- codePtr = newCodePtr;
- goto nonRecursiveCallStart;
- case TCL_NR_TAILCALL_TYPE:
- /*
- * A request to perform a tailcall: just drop this
- * bytecode as it is; the tailCall has been scheduled in
- * the callbacks.
- */
-#ifdef TCL_COMPILE_DEBUG
- if (traceInstructions) {
- fprintf(stdout, " Tailcall: request received\n");
- }
-#endif
- if (catchTop != initCatchTop) {
- result = TCL_ERROR;
- Tcl_SetResult(interp,"Tailcall called from within a catch environment",
- TCL_STATIC);
- goto checkForCatch;
- }
- goto abnormalReturn; /* drop a level */
- default:
- Tcl_Panic("TEBC: TEOV sent us a record we cannot handle!");
- }
+ if (TOP_CB(interp) != bottomPtr->rootPtr) {
+ assert ((result == TCL_OK));
+ pc += pcAdjustment;
+ goto nonRecursiveCallStart;
}
-#endif
iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
-
+
if (result == TCL_OK) {
Tcl_Obj *objPtr;
#ifndef TCL_COMPILE_DEBUG
@@ -7762,81 +7662,64 @@ TclExecuteByteCode(
TclArgumentBCRelease((Tcl_Interp*) iPtr,codePtr);
-#if USE_NR_TEBC
oldBottomPtr = bottomPtr->prevBottomPtr;
-#endif
TclStackFree(interp, bottomPtr); /* free my stack */
if (--codePtr->refCount <= 0) {
TclCleanupByteCode(codePtr);
}
-#if USE_NR_TEBC
if (oldBottomPtr) {
/*
* Restore the state to what it was previous to this bytecode.
- *
- * NR_TEBC
*/
- bottomPtr = oldBottomPtr; /* back to old bc */
+
+ bottomPtr = oldBottomPtr; /* back to old bc */
+ result = TclNRRunCallbacks(interp, result, bottomPtr->rootPtr, 1);
- /* Please free anything that might still be on my new stack */
- resumeCleanup:
- if (TOP_RECORD(iPtr) != bottomPtr->recordPtr) {
- CACHE_STACK_INFO();
- result = TclEvalObjv_NR2(interp, result, bottomPtr->recordPtr);
- if (TOP_RECORD(iPtr) != bottomPtr->recordPtr) {
- TEOV_record *recordPtr = TOP_RECORD(iPtr);
+ NR_DATA_DIG();
+ DECACHE_STACK_INFO();
+ if (TOP_CB(interp) == bottomPtr->rootPtr) {
+ /*
+ * The bytecode is returning, remove the caller's arguments and
+ * keep processing the caller.
+ */
+
+ while (cleanup--) {
+ Tcl_Obj *objPtr = POP_OBJECT();
+ Tcl_DecrRefCount(objPtr);
+ }
+ goto nonRecursiveCallReturn;
+ } else {
+ /*
+ * A request for a new execution: a tailcall. Remove the caller's
+ * arguments and start the new bytecode.
+ *
+ * FIXME KNOWNBUG: we get a pointer smash if we do remove the
+ * arguments, a leak otherwise: tailcalls are not yet quite
+ * there. Chose to leave the leak for now.
+ */
- assert((result == TCL_OK));
-
- /*
- * A callback scheduled a new evaluation: process it.
- */
-
- switch(recordPtr->type) {
- case TCL_NR_BC_TYPE:
- codePtr = recordPtr->data.codePtr;
- goto nonRecursiveCallStart;
- case TCL_NR_TAILCALL_TYPE:
- /* FIXME NRE tailcall*/
- Tcl_Panic("Tailcall called from a callback!");
- NR_DATA_DIG();
- esPtr = iPtr->execEnvPtr->execStackPtr;
- goto abnormalReturn; /* drop a level */
- case TCL_NR_CMD_TYPE:
- case TCL_NR_SCRIPT_TYPE:
- /*
- * FIXME NRE tailcall: error messages will be all wrong?
- */
-#ifdef TCL_COMPILE_DEBUG
- if (traceInstructions) {
- fprintf(stdout, " Tailcall: eval request received from callback\n");
- }
-#endif
- tailcall = 1;
- goto restoreStateVariables;
- case TCL_NR_CMDSWAP_TYPE:
- result = TclEvalObjv(interp, recordPtr->data.objcv.objc,
- recordPtr->data.objcv.objv, 0, recordPtr->cmdPtr);
- goto resumeCleanup;
- default:
- Tcl_Panic("TEBC: TEOV_NR2 sent us a record we cannot handle!");
+ TEOV_callback *callbackPtr = TOP_CB(interp);
+ Tcl_NRPostProc *procPtr = callbackPtr->procPtr;
+
+ if (procPtr == NRRunBytecode) {
+ goto nonRecursiveCallStart;
+ } else if (procPtr == NRDropCommand) {
+ /* FIXME: 'tailcall tailcall' not yet working */
+ Tcl_Panic("Tailcalls from within tailcalls are not yet implemented");
+ if (catchTop != initCatchTop) {
+ result = TCL_ERROR;
+ Tcl_SetResult(interp,"Tailcall called from within a catch environment",
+ TCL_STATIC);
+ goto checkForCatch;
}
+ goto abnormalReturn; /* drop a level */
+ } else {
+ Tcl_Panic("TEBC: TEOV sent us a record we cannot handle! (2)");
}
}
- restoreStateVariables:
- NR_DATA_DIG();
- esPtr = iPtr->execEnvPtr->execStackPtr;
- tosPtr = esPtr->tosPtr;
- while (cleanup--) {
- Tcl_Obj *objPtr = POP_OBJECT();
- Tcl_DecrRefCount(objPtr);
- }
- CACHE_STACK_INFO();
- goto nonRecursiveCallReturn;
}
-#endif
return result;
}
#undef iPtr
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index e1e46d0..8213109 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -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.decls,v 1.126 2008/07/24 22:57:57 nijtmans Exp $
+# RCS: @(#) $Id: tclInt.decls,v 1.127 2008/07/29 05:30:32 msofer Exp $
library tcl
@@ -894,10 +894,12 @@ declare 227 generic {
void TclSetNsPath(Namespace *nsPtr, int pathLength,
Tcl_Namespace *pathAry[])
}
-declare 228 generic {
- int TclObjInterpProcCore(register Tcl_Interp *interp, Tcl_Obj *procNameObj,
- int skip, ProcErrorProc errorProc)
-}
+# Used to be needed for TclOO-extension; unneeded now that TclOO is in the
+# core and NRE-enabled
+# declare 228 generic {
+# int TclObjInterpProcCore(register Tcl_Interp *interp, Tcl_Obj *procNameObj,
+# int skip, ProcErrorProc errorProc)
+# }
declare 229 generic {
int TclPtrMakeUpvar(Tcl_Interp *interp, Var *otherP1Ptr,
CONST char *myName, int myFlags, int index)
@@ -943,28 +945,25 @@ declare 237 generic {
# NRE functions for "rogue" extensions to exploit NRE; they will need to
# include NRE.h too.
declare 238 generic {
- int TclEvalObjv_NR2(Tcl_Interp *interp, int result,
- struct TEOV_record *rootPtr)
-}
-declare 239 generic {
int TclNRInterpProc(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[])
}
-declare 240 generic {
+declare 239 generic {
int TclNRInterpProcCore(Tcl_Interp *interp, Tcl_Obj *procNameObj,
int skip, ProcErrorProc errorProc)
}
-declare 241 generic {
- struct TEOV_record * TclNRPushRecord(Tcl_Interp *interp)
-}
-declare 242 generic {
- void TclNRPopAndFreeRecord(Tcl_Interp *interp)
+declare 240 generic {
+ int TclNRRunCallbacks(Tcl_Interp * interp, int result,
+ struct TEOV_callback * rootPtr, int tebcCall)
}
-
-declare 243 generic {
+declare 241 generic {
int TclNREvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags,
CONST CmdFrame *invoker, int word)
}
+declare 242 generic {
+ int TclNREvalObjv(Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[], int flags, Command *cmdPtr)
+}
##############################################################################
# Define the platform specific internal Tcl interface. These functions are
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 0587ecf..1b10fc6 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.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.
*
- * RCS: @(#) $Id: tclInt.h,v 1.379 2008/07/24 22:57:55 nijtmans Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.380 2008/07/29 05:30:32 msofer Exp $
*/
#ifndef _TCLINT
@@ -1329,17 +1329,13 @@ typedef struct ExecStack {
* currently active execution stack.
*/
-struct TEOV_record;
-
typedef struct ExecEnv {
ExecStack *execStackPtr; /* Points to the first item in the
* evaluation stack on the heap. */
Tcl_Obj *constants[2]; /* Pointers to constant "0" and "1"
- * objs. */
- struct TEOV_record *recordPtr; /* Top record in TEOV's stack */
- int tebcCall; /* used to distinguish tebc calls from
- * other calls to TEOV, and other comms
- * between TEBC and TEOV */
+ * objs. */
+ struct TEOV_callback *callbackPtr;
+ /* Top callback in TEOV's stack */
} ExecEnv;
/*
@@ -2516,10 +2512,12 @@ MODULE_SCOPE char tclEmptyString;
/* Introduced by/for NRE */
MODULE_SCOPE Tcl_ObjCmdProc TclNRNamespaceObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRApplyObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd;
MODULE_SCOPE int TclNREvalCmd(Tcl_Interp * interp, Tcl_Obj * objPtr,
int flags);
-MODULE_SCOPE int TclEvalObjv(Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[], int flags, Command *cmdPtr);
+
+MODULE_SCOPE void TclNRClearCommandFlag(Tcl_Interp *interp);
MODULE_SCOPE void TclAdvanceLines(int *line, const char *start,
const char *end);
@@ -2789,8 +2787,8 @@ MODULE_SCOPE Tcl_Obj * TclDisassembleByteCodeObj(Tcl_Obj *objPtr);
MODULE_SCOPE void * TclpThreadCreateKey(void);
MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr);
MODULE_SCOPE void TclpThreadSetMasterTSD(void *tsdKeyPtr, void *ptr);
-MODULE_SCOPE void * TclpThreadGetMasterTSD(void *tsdKeyPtr);
-
+MODULE_SCOPE void * TclpThreadGetMasterTSD(void *tsdKeyPtr);
+
/*
*----------------------------------------------------------------
* Command procedures in the generic core:
@@ -4011,7 +4009,7 @@ MODULE_SCOPE void TclBNInitBignumFromWideUInt(mp_int *bignum,
#include "tclTomMathDecls.h"
#endif /* _TCLINT */
-
+
/*
* Local Variables:
* mode: c
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index 0ef9eef..2148ab6 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.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.
*
- * RCS: @(#) $Id: tclIntDecls.h,v 1.122 2008/07/24 22:57:54 nijtmans Exp $
+ * RCS: @(#) $Id: tclIntDecls.h,v 1.123 2008/07/29 05:30:34 msofer Exp $
*/
#ifndef _TCLINTDECLS
@@ -1012,13 +1012,7 @@ EXTERN int TclObjBeingDeleted (Tcl_Obj * objPtr);
EXTERN void TclSetNsPath (Namespace * nsPtr, int pathLength,
Tcl_Namespace * pathAry[]);
#endif
-#ifndef TclObjInterpProcCore_TCL_DECLARED
-#define TclObjInterpProcCore_TCL_DECLARED
-/* 228 */
-EXTERN int TclObjInterpProcCore (register Tcl_Interp * interp,
- Tcl_Obj * procNameObj, int skip,
- ProcErrorProc errorProc);
-#endif
+/* Slot 228 is reserved */
#ifndef TclPtrMakeUpvar_TCL_DECLARED
#define TclPtrMakeUpvar_TCL_DECLARED
/* 229 */
@@ -1076,43 +1070,40 @@ EXTERN void TclBackgroundException (Tcl_Interp * interp,
/* 237 */
EXTERN int TclResetCancellation (Tcl_Interp * interp, int force);
#endif
-#ifndef TclEvalObjv_NR2_TCL_DECLARED
-#define TclEvalObjv_NR2_TCL_DECLARED
-/* 238 */
-EXTERN int TclEvalObjv_NR2 (Tcl_Interp * interp, int result,
- struct TEOV_record * rootPtr);
-#endif
#ifndef TclNRInterpProc_TCL_DECLARED
#define TclNRInterpProc_TCL_DECLARED
-/* 239 */
+/* 238 */
EXTERN int TclNRInterpProc (ClientData clientData,
Tcl_Interp * interp, int objc,
Tcl_Obj *CONST objv[]);
#endif
#ifndef TclNRInterpProcCore_TCL_DECLARED
#define TclNRInterpProcCore_TCL_DECLARED
-/* 240 */
+/* 239 */
EXTERN int TclNRInterpProcCore (Tcl_Interp * interp,
Tcl_Obj * procNameObj, int skip,
ProcErrorProc errorProc);
#endif
-#ifndef TclNRPushRecord_TCL_DECLARED
-#define TclNRPushRecord_TCL_DECLARED
-/* 241 */
-EXTERN struct TEOV_record * TclNRPushRecord (Tcl_Interp * interp);
-#endif
-#ifndef TclNRPopAndFreeRecord_TCL_DECLARED
-#define TclNRPopAndFreeRecord_TCL_DECLARED
-/* 242 */
-EXTERN void TclNRPopAndFreeRecord (Tcl_Interp * interp);
+#ifndef TclNRRunCallbacks_TCL_DECLARED
+#define TclNRRunCallbacks_TCL_DECLARED
+/* 240 */
+EXTERN int TclNRRunCallbacks (Tcl_Interp * interp, int result,
+ struct TEOV_callback * rootPtr, int tebcCall);
#endif
#ifndef TclNREvalObjEx_TCL_DECLARED
#define TclNREvalObjEx_TCL_DECLARED
-/* 243 */
+/* 241 */
EXTERN int TclNREvalObjEx (Tcl_Interp * interp,
Tcl_Obj * objPtr, int flags,
CONST CmdFrame * invoker, int word);
#endif
+#ifndef TclNREvalObjv_TCL_DECLARED
+#define TclNREvalObjv_TCL_DECLARED
+/* 242 */
+EXTERN int TclNREvalObjv (Tcl_Interp * interp, int objc,
+ Tcl_Obj *const objv[], int flags,
+ Command * cmdPtr);
+#endif
typedef struct TclIntStubs {
int magic;
@@ -1370,7 +1361,7 @@ typedef struct TclIntStubs {
Tcl_Obj * (*tclTraceDictPath) (Tcl_Interp * interp, Tcl_Obj * rootPtr, int keyc, Tcl_Obj *CONST keyv[], int flags); /* 225 */
int (*tclObjBeingDeleted) (Tcl_Obj * objPtr); /* 226 */
void (*tclSetNsPath) (Namespace * nsPtr, int pathLength, Tcl_Namespace * pathAry[]); /* 227 */
- int (*tclObjInterpProcCore) (register Tcl_Interp * interp, Tcl_Obj * procNameObj, int skip, ProcErrorProc errorProc); /* 228 */
+ void *reserved228;
int (*tclPtrMakeUpvar) (Tcl_Interp * interp, Var * otherP1Ptr, CONST char * myName, int myFlags, int index); /* 229 */
Var * (*tclObjLookupVar) (Tcl_Interp * interp, Tcl_Obj * part1Ptr, CONST char * part2, int flags, CONST char * msg, CONST int createPart1, CONST int createPart2, Var ** arrayPtrPtr); /* 230 */
int (*tclGetNamespaceFromObj) (Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_Namespace ** nsPtrPtr); /* 231 */
@@ -1380,12 +1371,11 @@ typedef struct TclIntStubs {
void (*tclInitVarHashTable) (TclVarHashTable * tablePtr, Namespace * nsPtr); /* 235 */
void (*tclBackgroundException) (Tcl_Interp * interp, int code); /* 236 */
int (*tclResetCancellation) (Tcl_Interp * interp, int force); /* 237 */
- int (*tclEvalObjv_NR2) (Tcl_Interp * interp, int result, struct TEOV_record * rootPtr); /* 238 */
- int (*tclNRInterpProc) (ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[]); /* 239 */
- int (*tclNRInterpProcCore) (Tcl_Interp * interp, Tcl_Obj * procNameObj, int skip, ProcErrorProc errorProc); /* 240 */
- struct TEOV_record * (*tclNRPushRecord) (Tcl_Interp * interp); /* 241 */
- void (*tclNRPopAndFreeRecord) (Tcl_Interp * interp); /* 242 */
- int (*tclNREvalObjEx) (Tcl_Interp * interp, Tcl_Obj * objPtr, int flags, CONST CmdFrame * invoker, int word); /* 243 */
+ int (*tclNRInterpProc) (ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[]); /* 238 */
+ int (*tclNRInterpProcCore) (Tcl_Interp * interp, Tcl_Obj * procNameObj, int skip, ProcErrorProc errorProc); /* 239 */
+ int (*tclNRRunCallbacks) (Tcl_Interp * interp, int result, struct TEOV_callback * rootPtr, int tebcCall); /* 240 */
+ int (*tclNREvalObjEx) (Tcl_Interp * interp, Tcl_Obj * objPtr, int flags, CONST CmdFrame * invoker, int word); /* 241 */
+ int (*tclNREvalObjv) (Tcl_Interp * interp, int objc, Tcl_Obj *const objv[], int flags, Command * cmdPtr); /* 242 */
} TclIntStubs;
#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
@@ -2091,10 +2081,7 @@ extern CONST TclIntStubs *tclIntStubsPtr;
#define TclSetNsPath \
(tclIntStubsPtr->tclSetNsPath) /* 227 */
#endif
-#ifndef TclObjInterpProcCore
-#define TclObjInterpProcCore \
- (tclIntStubsPtr->tclObjInterpProcCore) /* 228 */
-#endif
+/* Slot 228 is reserved */
#ifndef TclPtrMakeUpvar
#define TclPtrMakeUpvar \
(tclIntStubsPtr->tclPtrMakeUpvar) /* 229 */
@@ -2131,29 +2118,25 @@ extern CONST TclIntStubs *tclIntStubsPtr;
#define TclResetCancellation \
(tclIntStubsPtr->tclResetCancellation) /* 237 */
#endif
-#ifndef TclEvalObjv_NR2
-#define TclEvalObjv_NR2 \
- (tclIntStubsPtr->tclEvalObjv_NR2) /* 238 */
-#endif
#ifndef TclNRInterpProc
#define TclNRInterpProc \
- (tclIntStubsPtr->tclNRInterpProc) /* 239 */
+ (tclIntStubsPtr->tclNRInterpProc) /* 238 */
#endif
#ifndef TclNRInterpProcCore
#define TclNRInterpProcCore \
- (tclIntStubsPtr->tclNRInterpProcCore) /* 240 */
+ (tclIntStubsPtr->tclNRInterpProcCore) /* 239 */
#endif
-#ifndef TclNRPushRecord
-#define TclNRPushRecord \
- (tclIntStubsPtr->tclNRPushRecord) /* 241 */
-#endif
-#ifndef TclNRPopAndFreeRecord
-#define TclNRPopAndFreeRecord \
- (tclIntStubsPtr->tclNRPopAndFreeRecord) /* 242 */
+#ifndef TclNRRunCallbacks
+#define TclNRRunCallbacks \
+ (tclIntStubsPtr->tclNRRunCallbacks) /* 240 */
#endif
#ifndef TclNREvalObjEx
#define TclNREvalObjEx \
- (tclIntStubsPtr->tclNREvalObjEx) /* 243 */
+ (tclIntStubsPtr->tclNREvalObjEx) /* 241 */
+#endif
+#ifndef TclNREvalObjv
+#define TclNREvalObjv \
+ (tclIntStubsPtr->tclNREvalObjv) /* 242 */
#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 025109d..d5736c3 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.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.
*
- * RCS: @(#) $Id: tclInterp.c,v 1.93 2008/07/24 22:57:56 nijtmans Exp $
+ * RCS: @(#) $Id: tclInterp.c,v 1.94 2008/07/29 05:30:35 msofer Exp $
*/
#include "tclInt.h"
@@ -687,7 +687,7 @@ Tcl_InterpObjCmd(
/*
* Did they specify a slave interp to cancel the script in
- * progress in? If not, use the current interp.
+ * progress in? If not, use the current interp.
*/
if (i < objc) {
@@ -1488,7 +1488,7 @@ AliasCreate(
if (slaveInterp == masterInterp) {
aliasPtr->slaveCmd = Tcl_NRCreateCommand(slaveInterp,
- TclGetString(namePtr), AliasObjCmd, AliasNRCmd, aliasPtr,
+ TclGetString(namePtr), AliasObjCmd, AliasNRCmd, aliasPtr,
AliasObjCmdDeleteProc);
} else {
aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp,
@@ -1763,7 +1763,8 @@ AliasNRCmd(
Tcl_Obj *listPtr;
List *listRep;
int flags = TCL_EVAL_INVOKE;
-
+ int result;
+
/*
* Append the arguments to the command prefix and invoke the command in
* the target interp's global namespace.
@@ -1777,7 +1778,7 @@ AliasNRCmd(
listRep = listPtr->internalRep.twoPtrValue.ptr1;
listRep->elemCount = cmdc;
cmdv = &listRep->elements;
-
+
prefv = &aliasPtr->objPtr;
memcpy(cmdv, prefv, (size_t) (prefc * sizeof(Tcl_Obj *)));
memcpy(cmdv+prefc, objv+1, (size_t) ((objc-1) * sizeof(Tcl_Obj *)));
@@ -1808,7 +1809,9 @@ AliasNRCmd(
if (isRootEnsemble) {
TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
}
- return TclNREvalCmd(interp, listPtr, flags);
+ result = Tcl_NREvalObj(interp, listPtr, flags);
+ TclNRClearCommandFlag(interp);
+ return result;
}
static int
@@ -2618,7 +2621,7 @@ SlaveEval(
*
* Do not let any intReps accross, with the exception of
* bytecodes. The intrep spoiling is due to happen anyway when
- * compiling.
+ * compiling.
*/
Interp *iPtr = (Interp *) interp;
@@ -2635,7 +2638,7 @@ SlaveEval(
}
TclArgumentGet (interp, objPtr, &invoker, &word);
-
+
result = TclEvalObjEx(slaveInterp, objPtr, 0, invoker, word);
} else {
objPtr = Tcl_ConcatObj(objc, objv);
diff --git a/generic/tclNRE.h b/generic/tclNRE.h
index e0d692d..15f0e54 100644
--- a/generic/tclNRE.h
+++ b/generic/tclNRE.h
@@ -11,7 +11,7 @@
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* // FIXME: RCS numbering?
- * RCS: @(#) $Id: tclNRE.h,v 1.6 2008/07/21 16:26:08 msofer Exp $
+ * RCS: @(#) $Id: tclNRE.h,v 1.7 2008/07/29 05:30:36 msofer Exp $
*/
@@ -23,60 +23,8 @@
*****************************************************************************/
#define USE_SMALL_ALLOC 1 /* perf is important for some of these things! */
-#define USE_STACK_ALLOC 1 /* good mainly for debugging, crashes at
- * smallest timing error */
#define ENABLE_ASSERTS 1
-/*
- * IMPLEMENTED IN THIS VERSION - flags for partial enabling of the different
- * parts, useful for debugging. May not work - meant to be used at "all ones"
- */
-
-#define USE_NR_PROC 1 /* are procs defined as NR functions or not?
- * Used for testing that the old interfaces
- * still work, as they are used by TclOO and
- * iTcl */
-#define USE_NR_TEBC 1 /* does TEBC know about his special powers?
- * with 1 TEBC remains on stack, TEOV gets
- * evicted. */
-#define USE_NR_ALIAS 1 /* First examples: my job */
-
-#define USE_NR_IMPORTS 1 /* First examples: my job */
-
-#define USE_NR_TAILCALLS 1 /* Incomplete implementation as
- * tcl::unsupported::tailcall; best semantics
- * are yet not 100% clear to me. */
-
-#define USE_NR_NS_ENSEMBLE 1 /* snit!! */
-
-/* Here to remind me of what's still missing: none of these do anything today */
-
-#define USE_NR_EVAL 0 /* Tcl_EvalObj should be easy; the others may
- * require some adapting of the parser. dgp? */
-#define USE_NR_UPLEVEL 0 /* piece of cake, I think */
-#define USE_NR_VAR_TRACES 0 /* require major redesign, I fear. About time
- * for it too! */
-
-#define USE_NR_CONTINUATIONS 0
-
-#define MAKE_3X_FASTER 0
-#define RULE_THE_WORLD 0
-
-#define USE_NR_CMD_TRACES /* NEVER?? Maybe ... enter traces on the way in,
- * leave traces done in the callback? So a trace
- * just needs to replace the procPtr and
- * clientData, and TEOV needn't know about the
- * whole s**t! Mmhhh */
-
-/*****************************************************************************
- * Stuff for the public api: gone to the stubs table!
- *
- * Question: should we allow more callback requests during the callback
- * itself? Easy enough to either handle or block, nothing done yet. We could
- * also "lock" the Tcl stack during postProc, but it doesn't sound
- * reasonable. I think.
- *****************************************************************************/
-
/*****************************************************************************
* Private api fo NRE
*****************************************************************************/
@@ -94,162 +42,38 @@ typedef struct TEOV_callback {
struct TEOV_callback *nextPtr;
} TEOV_callback;
-
-/* Try to keep within SmallAlloc sizes! */
-typedef struct TEOV_record {
- int type;
- Command *cmdPtr;
- TEOV_callback *callbackPtr;
- struct TEOV_record *nextPtr;
- union {
- struct ByteCode *codePtr; /* TCL_NR_BC_TYPE */
- struct {
- Tcl_Obj *objPtr;
- int flags;
- } obj;
- struct {
- int objc;
- Tcl_Obj **objv;
- } objcv;
- } data;
-#if !USE_SMALL_ALLOC
- /* Extra checks: can disappear later */
- Tcl_Obj **tosPtr;
-#endif
-} TEOV_record;
-
-/*
- * The types for records; we save the first bit to indicate that it stores an
- * obj, to indicate the necessary refCount management. That is, odd numbers
- * only for obj-carrying types
- */
-
-#define TCL_NR_NO_TYPE 0 /* for internal (cleanup) use only */
-#define TCL_NR_BC_TYPE 2 /* procs, lambdas, TclOO+Itcl sometime ... */
-#define TCL_NR_CMDSWAP_TYPE 4 /* ns-imports (cmdd redirect) */
-#define TCL_NR_TAILCALL_TYPE 6
-#define TCL_NR_TEBC_SWAPENV_TYPE 8 /* continuations, micro-threads !? */
-
-#define TCL_NR_CMD_TYPE 1 /* i-alias, ns-ens use this */
-#define TCL_NR_SCRIPT_TYPE 3 /* ns-eval, uplevel use this */
-
-#define TCL_NR_HAS_OBJ(TYPE) ((TYPE) & 1)
-
-#define TOP_RECORD(iPtr) (((Interp *)(iPtr))->execEnvPtr->recordPtr)
+#define TOP_CB(iPtr) (((Interp *)(iPtr))->execEnvPtr->callbackPtr)
#define GET_TOSPTR(iPtr) \
(((Interp *)iPtr)->execEnvPtr->execStackPtr->tosPtr)
-#if !USE_SMALL_ALLOC
-#define STORE_EXTRA(iPtr, recordPtr) \
- recordPtr->tosPtr = GET_TOSPTR(iPtr)
-#else
-#define STORE_EXTRA(iPtr, recordPtr)
-#endif
-
-/* A SINGLE record being pushed is what is detected as an NRE request by TEOV */
-
-#define PUSH_RECORD(iPtr, recordPtr) \
- TCLNR_ALLOC(interp, recordPtr); \
- recordPtr->nextPtr = TOP_RECORD(iPtr); \
- STORE_EXTRA(iPtr, recordPtr); \
- TOP_RECORD(iPtr) = recordPtr; \
- recordPtr->type = TCL_NR_NO_TYPE; \
- recordPtr->cmdPtr = NULL; \
- recordPtr->callbackPtr = NULL
-
-#define TEBC_CALL(iPtr) \
- (((Interp *)iPtr)->execEnvPtr->tebcCall)
+/*
+ * Inline version of Tcl_NRAddCallback
+ */
-#define TclNRAddCallback(\
- interp,\
- postProcPtr,\
- data0,\
- data1,\
- data2,\
- data3) \
- { \
- TEOV_record *recordPtr; \
- TEOV_callback *callbackPtr; \
- \
- recordPtr = TOP_RECORD(interp); \
+#define TclNRAddCallback( \
+ interp, \
+ postProcPtr, \
+ data0, \
+ data1, \
+ data2, \
+ data3) \
+ { \
+ TEOV_callback *callbackPtr; \
TclSmallAlloc(sizeof(TEOV_callback), callbackPtr); \
- \
callbackPtr->procPtr = (postProcPtr); \
callbackPtr->data[0] = (data0); \
callbackPtr->data[1] = (data1); \
callbackPtr->data[2] = (data2); \
callbackPtr->data[3] = (data3); \
- \
- callbackPtr->nextPtr = recordPtr->callbackPtr; \
- recordPtr->callbackPtr = callbackPtr; \
+ callbackPtr->nextPtr = TOP_CB(interp); \
+ TOP_CB(interp) = callbackPtr; \
}
-
-
-
-/*
- * These are only used by TEOV; here for ease of ref. They should move to
- * tclBasic.c later on.
- */
-
-#define COMPLETE_RECORD(recordPtr) \
- /* accesses variables by name, careful */ \
- recordPtr->cmdPtr = cmdPtr; \
-
-#if !USE_SMALL_ALLOC
-#define CHECK_EXTRA(iPtr, recordPtr) \
- (recordPtr->tosPtr == GET_TOSPTR(iPtr))
-#else
-#define CHECK_EXTRA(iPtr, recordPtr) 1
-#endif
-
-#define POP_RECORD(iPtr, recordPtr) \
- { \
- recordPtr = TOP_RECORD(iPtr); \
- TOP_RECORD(iPtr) = recordPtr->nextPtr; \
- }
-
-
-#define FREE_RECORD(iPtr, recordPtr) \
- { \
- TEOV_callback *callbackPtr = recordPtr->callbackPtr; \
- if (TCL_NR_HAS_OBJ(recordPtr->type)) { \
- Tcl_DecrRefCount(recordPtr->data.obj.objPtr); \
- } \
- while (callbackPtr) { \
- callbackPtr = callbackPtr->nextPtr; \
- TclSmallFree(recordPtr->callbackPtr); \
- } \
- TCLNR_FREE(((Tcl_Interp *)iPtr), recordPtr); \
- }
-
-#define CHECK_VALID_RETURN(iPtr, recordPtr) \
- ((TOP_RECORD(iPtr) == recordPtr) && \
- CHECK_EXTRA(iPtr, recordPtr))
-
-#define READ_OBJV_RECORD(recordPtr) /* TBD? Or read by hand (braille?) */
-
-
-/*
- * functions
- */
-
-#if 0
-/* built as static inline in tclProc.c. Do TclOO/Itcl need this? */
-MODULE_SCOPE int Tcl_NRBC (Tcl_Interp * interp, ByteCode *codePtr,
- Tcl_NRPostProc *postProcPtr, ClientData clientData);
-#endif
-
-/* The following starts purges the stack popping TclStackAllocs down to where
- * tosPtr has the requested value. Panics on failure.*/
-MODULE_SCOPE void TclStackPurge(Tcl_Interp *interp, Tcl_Obj **tosPtr);
/*
* Tailcalls!
*/
-MODULE_SCOPE Tcl_ObjCmdProc TclNRApplyObjCmd;
-MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclTailcallObjCmd;
@@ -258,13 +82,10 @@ MODULE_SCOPE Tcl_ObjCmdProc TclTailcallObjCmd;
*****************************************************************************/
#if USE_SMALL_ALLOC
-#define TCLNR_ALLOC(interp, ptr) TclSmallAlloc(sizeof(TEOV_record), ptr)
+#define TCLNR_ALLOC(interp, ptr) TclSmallAlloc(sizeof(TEOV_callback), ptr)
#define TCLNR_FREE(interp, ptr) TclSmallFree((ptr))
-#elif USE_STACK_ALLOC
-#define TCLNR_ALLOC(interp, ptr) (ptr = TclStackAlloc(interp, sizeof(TEOV_record)))
-#define TCLNR_FREE(interp, ptr) TclStackFree(interp, (ptr))
#else
-#define TCLNR_ALLOC(interp, size, ptr) (ptr = ((ClientData) ckalloc(sizeof(TEOV_record))))
+#define TCLNR_ALLOC(interp, size, ptr) (ptr = ((ClientData) ckalloc(sizeof(TEOV_callback))))
#define TCLNR_FREE(interp, ptr) ckfree((char *) (ptr))
#endif
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 3eda959..ff56db7 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.171 2008/07/21 22:50:36 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.172 2008/07/29 05:30:36 msofer Exp $
*/
#include "tclInt.h"
@@ -1897,7 +1897,7 @@ InvokeImportedNRCmd(
ImportedCmdData *dataPtr = clientData;
Command *realCmdPtr = dataPtr->realCmdPtr;
- return Tcl_NRCmdSwap(interp, (Tcl_Command) realCmdPtr, objc, objv);
+ return Tcl_NRCmdSwap(interp, (Tcl_Command) realCmdPtr, objc, objv, 0);
}
static int
@@ -6225,7 +6225,7 @@ NsEnsembleImplementationCmdNR(
* target command prefix. */
Tcl_Obj *copyPtr; /* The actual list of words to dispatch to.
* Will be freed by the dispatch engine. */
- int prefixObjc, copyObjc;
+ int prefixObjc, copyObjc, result;
Interp *iPtr = (Interp *) interp;
/*
@@ -6285,8 +6285,10 @@ NsEnsembleImplementationCmdNR(
/*
* Hand off to the target command.
*/
-
- return TclNREvalCmd(interp, copyPtr, TCL_EVAL_INVOKE);
+
+ result = Tcl_NREvalObj(interp, copyPtr, TCL_EVAL_INVOKE);
+ TclNRClearCommandFlag(interp);
+ return result;
}
unknownOrAmbiguousSubcommand:
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 2adf547..1e9bd11 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclOOBasic.c,v 1.7 2008/07/18 23:29:44 msofer Exp $
+ * RCS: @(#) $Id: tclOOBasic.c,v 1.8 2008/07/29 05:30:37 msofer Exp $
*/
#ifdef HAVE_CONFIG_H
@@ -49,11 +49,8 @@ static inline Tcl_Object *
AddConstructionFinalizer(
Tcl_Interp *interp)
{
- TEOV_record *recordPtr;
-
TclNRAddCallback(interp, FinalizeConstruction, NULL, NULL, NULL, NULL);
- recordPtr = TOP_RECORD(interp);
- return (Tcl_Object *) &recordPtr->callbackPtr->data[0];
+ return (Tcl_Object *) &(TOP_CB(interp)->data[0]);
}
static int
diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c
index 8ce3c34..9cd2678 100644
--- a/generic/tclOOMethod.c
+++ b/generic/tclOOMethod.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclOOMethod.c,v 1.10 2008/07/27 22:28:54 dkf Exp $
+ * RCS: @(#) $Id: tclOOMethod.c,v 1.11 2008/07/29 05:30:37 msofer Exp $
*/
#ifdef HAVE_CONFIG_H
@@ -55,6 +55,8 @@ static Tcl_Obj ** InitEnsembleRewrite(Tcl_Interp *interp, int objc,
static int InvokeProcedureMethod(ClientData clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
+static int FinalizeForwardCall(ClientData data[], Tcl_Interp *interp,
+ int result);
static int FinalizePMCall(ClientData data[], Tcl_Interp *interp,
int result);
static int PushMethodCallFrame(Tcl_Interp *interp,
@@ -1131,7 +1133,7 @@ InvokeForwardMethod(
CallContext *contextPtr = (CallContext *) context;
ForwardMethod *fmPtr = clientData;
Tcl_Obj **argObjs, **prefixObjs;
- int numPrefixes, result, len, skip = contextPtr->skip;
+ int numPrefixes, len, skip = contextPtr->skip;
/*
* Build the real list of arguments to use. Note that we know that the
@@ -1144,7 +1146,18 @@ InvokeForwardMethod(
argObjs = InitEnsembleRewrite(interp, objc, objv, skip,
numPrefixes, prefixObjs, &len);
- result = Tcl_NREvalObjv(interp, len, argObjs, TCL_EVAL_INVOKE);
+ Tcl_NRAddCallback(interp, FinalizeForwardCall, argObjs, NULL, NULL, NULL);
+ return Tcl_NREvalObjv(interp, len, argObjs, TCL_EVAL_INVOKE);
+}
+
+static int
+FinalizeForwardCall(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Tcl_Obj **argObjs = data[0];
+
TclStackFree(interp, argObjs);
return result;
}
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 63aa7d5..ea5f617 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclProc.c,v 1.152 2008/07/25 22:11:21 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.153 2008/07/29 05:30:37 msofer Exp $
*/
#include "tclInt.h"
@@ -1618,23 +1618,6 @@ PushProcCallFrame(
return TCL_OK;
}
-static int
-Tcl_NRBC(
- Tcl_Interp *interp,
- ByteCode *codePtr,
- Tcl_NRPostProc *postProcPtr,
- Tcl_Obj *procNameObj,
- ProcErrorProc errorProc)
-{
- TEOV_record *recordPtr = TOP_RECORD(interp);
-
- recordPtr->type = TCL_NR_BC_TYPE;
- recordPtr->data.codePtr = codePtr;
- TclNRAddCallback(interp, postProcPtr, procNameObj, errorProc, NULL,
- NULL);
- return TCL_OK;
-}
-
/*
*----------------------------------------------------------------------
*
@@ -1663,16 +1646,10 @@ TclObjInterpProc(
Tcl_Obj *const objv[]) /* Argument value objects. */
{
/*
- * Not used in the core; external interface for iTcl and XOTcl
+ * Not used much in the core; external interface for iTcl
*/
- int result = PushProcCallFrame(clientData, interp, objc, objv,
- /*isLambda*/ 0);
-
- if (result != TCL_OK) {
- return TCL_ERROR;
- }
- return TclObjInterpProcCore(interp, objv[0], 1, &MakeProcError);
+ return Tcl_NRCallObjProc(interp, TclNRInterpProc, clientData, objc, objv);
}
int
@@ -1697,7 +1674,7 @@ TclNRInterpProc(
/*
*----------------------------------------------------------------------
*
- * TclObjInterpProcCore --
+ * TclNRInterpProcCore --
*
* When a Tcl procedure, lambda term or anything else that works like a
* procedure gets invoked during bytecode evaluation, this object-based
@@ -1713,49 +1690,6 @@ TclNRInterpProc(
*/
int
-TclObjInterpProcCore(
- register Tcl_Interp *interp,/* Interpreter in which procedure was
- * invoked. */
- Tcl_Obj *procNameObj, /* Procedure name for error reporting. */
- int skip, /* Number of initial arguments to be skipped,
- * i.e., words in the "command name". */
- ProcErrorProc errorProc) /* How to convert results from the script into
- * results of the overall procedure. */
-{
- /*
- * Not used in the core; external interface for TclOO
- */
-
- Interp *iPtr = (Interp *) interp;
- TEOV_record record, *rootPtr;
- int result;
-
- /*
- * Put a top record NOT ON THE TCL STACK! Note that TclNRInterpProcCore
- * assumes it can free the CallFrame in the error case, there cannot be
- * anything else on top of that. We use a C-stack record, it could also be
- * ckalloc'ed or anything else, just NOT TclStackAlloc.
- */
-
- rootPtr = TOP_RECORD(iPtr);
- TOP_RECORD(iPtr) = &record;
- result = TclNRInterpProcCore(interp, procNameObj, skip, errorProc);
- TOP_RECORD(iPtr) = rootPtr;
-
- if (result == TCL_OK) {
- result = TclExecuteByteCode(interp, record.data.codePtr);
- result = TclEvalObjv_NR2(interp, result, rootPtr);
- if (TOP_RECORD(iPtr) != rootPtr) {
- /* FIXME NRE & tailcalls */
- Tcl_Panic("TclObjInterpProcCore not yet prepared to deal with evals in callbacks!");
- }
- result = InterpProcNR2(record.callbackPtr->data, interp, result);
- TclSmallFree(record.callbackPtr);
- }
- return result;
-}
-
-int
TclNRInterpProcCore(
register Tcl_Interp *interp,/* Interpreter in which procedure was
* invoked. */
@@ -1837,7 +1771,9 @@ TclNRInterpProcCore(
(Tcl_Obj **)(iPtr->varFramePtr->objv + l));
}
- Tcl_NRBC(interp, codePtr, InterpProcNR2, procNameObj, errorProc);
+ TclNRAddCallback(interp, InterpProcNR2, procNameObj, errorProc,
+ NULL, NULL);
+ TclNRAddCallback(interp, NRRunBytecode, codePtr, NULL, NULL, NULL);
return TCL_OK;
}
@@ -2825,21 +2761,8 @@ TclNRApplyObjCmd(
result = PushProcCallFrame((ClientData) procPtr, interp, objc, objv, 1);
if (result == TCL_OK) {
+ TclNRAddCallback(interp, ApplyNR2, extraPtr, NULL, NULL, NULL);
result = TclNRInterpProcCore(interp, objv[1], 2, &MakeLambdaError);
- if (result == TCL_OK) {
- /* Fix the recordPtr! */
-
- TEOV_record *recordPtr = TOP_RECORD(iPtr);
-
- recordPtr->callbackPtr->procPtr = ApplyNR2;
- recordPtr->callbackPtr->data[2] = extraPtr;
- }
- }
- if (result != TCL_OK) {
- if (isRootEnsemble) {
- iPtr->ensembleRewrite.sourceObjs = NULL;
- }
- TclStackFree(interp, extraPtr);
}
return result;
}
@@ -2850,10 +2773,8 @@ ApplyNR2(
Tcl_Interp *interp,
int result)
{
- ApplyExtraData *extraPtr = data[2];
+ ApplyExtraData *extraPtr = data[0];
- result = InterpProcNR2(data, interp, result);
-
if (extraPtr->isRootEnsemble) {
((Interp *) interp)->ensembleRewrite.sourceObjs = NULL;
}
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 76c0e15..49f5029 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclStubInit.c,v 1.161 2008/07/22 23:06:25 das Exp $
+ * RCS: @(#) $Id: tclStubInit.c,v 1.162 2008/07/29 05:30:38 msofer Exp $
*/
#include "tclInt.h"
@@ -297,7 +297,7 @@ static const TclIntStubs tclIntStubs = {
TclTraceDictPath, /* 225 */
TclObjBeingDeleted, /* 226 */
TclSetNsPath, /* 227 */
- TclObjInterpProcCore, /* 228 */
+ NULL, /* 228 */
TclPtrMakeUpvar, /* 229 */
TclObjLookupVar, /* 230 */
TclGetNamespaceFromObj, /* 231 */
@@ -307,12 +307,11 @@ static const TclIntStubs tclIntStubs = {
TclInitVarHashTable, /* 235 */
TclBackgroundException, /* 236 */
TclResetCancellation, /* 237 */
- TclEvalObjv_NR2, /* 238 */
- TclNRInterpProc, /* 239 */
- TclNRInterpProcCore, /* 240 */
- TclNRPushRecord, /* 241 */
- TclNRPopAndFreeRecord, /* 242 */
- TclNREvalObjEx, /* 243 */
+ TclNRInterpProc, /* 238 */
+ TclNRInterpProcCore, /* 239 */
+ TclNRRunCallbacks, /* 240 */
+ TclNREvalObjEx, /* 241 */
+ TclNREvalObjv, /* 242 */
};
static const TclIntPlatStubs tclIntPlatStubs = {
@@ -1108,13 +1107,13 @@ static const TclStubs tclStubs = {
Tcl_AppendPrintfToObj, /* 579 */
Tcl_CancelEval, /* 580 */
Tcl_Canceled, /* 581 */
- Tcl_NRCreateCommand, /* 582 */
- Tcl_NREvalObj, /* 583 */
- Tcl_NREvalObjv, /* 584 */
- Tcl_NRCmdSwap, /* 585 */
- Tcl_NRAddCallback, /* 586 */
- Tcl_NRCallObjProc, /* 587 */
- Tcl_CreatePipe, /* 588 */
+ Tcl_CreatePipe, /* 582 */
+ Tcl_NRCreateCommand, /* 583 */
+ Tcl_NREvalObj, /* 584 */
+ Tcl_NREvalObjv, /* 585 */
+ Tcl_NRCmdSwap, /* 586 */
+ Tcl_NRAddCallback, /* 587 */
+ Tcl_NRCallObjProc, /* 588 */
};
/* !END!: Do not edit above this line. */
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 3052cc9..4ce4277 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -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.
*
- * RCS: @(#) $Id: tclTest.c,v 1.118 2008/07/28 21:31:19 nijtmans Exp $
+ * RCS: @(#) $Id: tclTest.c,v 1.119 2008/07/29 05:30:38 msofer Exp $
*/
#define TCL_TEST
@@ -402,6 +402,9 @@ static int TestNumUtfCharsCmd(ClientData clientData,
static int TestHashSystemHashCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+static int TestNRELevels(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
static const Tcl_Filesystem testReportingFilesystem = {
"reporting",
@@ -658,6 +661,10 @@ Tcltest_Init(
Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2,
(ClientData) 0);
+ Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels,
+ (ClientData) NULL, NULL);
+
+
#ifdef TCL_THREADS
if (TclThread_Init(interp) != TCL_OK) {
return TCL_ERROR;
@@ -6527,6 +6534,35 @@ TestgetintCmd(
}
}
+static int
+TestNRELevels(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Interp *iPtr = (Interp *) interp;
+ static ptrdiff_t *refDepth = NULL;
+ ptrdiff_t depth;
+ Tcl_Obj *levels[5];
+
+ if (refDepth == NULL) {
+ refDepth = &depth;
+ }
+
+ depth = (refDepth - &depth);
+
+ levels[0] = Tcl_NewIntObj(depth);
+ levels[1] = Tcl_NewIntObj(((Interp *)interp)->numLevels);
+ levels[2] = Tcl_NewIntObj(iPtr->cmdFramePtr->level);
+ levels[3] = Tcl_NewIntObj(iPtr->varFramePtr->level);
+ levels[4] = Tcl_NewIntObj((iPtr->execEnvPtr->execStackPtr->tosPtr
+ - iPtr->execEnvPtr->execStackPtr->stackWords));
+
+ Tcl_SetObjResult(interp, Tcl_NewListObj(5, levels));
+ return TCL_OK;
+}
+
/*
* Local Variables:
* mode: c