NRE implementation [Patch 2017110]

1 files changed, 237 insertions, 84 deletions

diff --git a/generic/tclProc.c b/generic/tclProc.c
index 42f65ba..90cac16 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -12,11 +12,21 @@
  * 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.142 2008/06/13 05:45:14 mistachkin Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.143 2008/07/13 09:03:35 msofer Exp $
  */
 
 #include "tclInt.h"
 #include "tclCompile.h"
+#include "tclNRE.h"
+
+typedef struct {
+    int isRootEnsemble;
+    Command cmd;
+    ExtraFrameInfo efi;
+} ApplyExtraData;
+
+static TclNR_PostProc ApplyNR2;
+static TclNR_PostProc InterpProcNR2;
 
 /*
  * Prototypes for static functions in this file
@@ -47,6 +57,8 @@ static int		ProcCompileProc(Tcl_Interp *interp, Proc *procPtr,
 			    const char *description, const char *procName,
 			    Proc **procPtrPtr);
 
+static TclNR_PostProc Uplevel_Callback;
+
 /*
  * The ProcBodyObjType type
  */
@@ -185,9 +197,8 @@ Tcl_ProcObjCmd(
     }
     Tcl_DStringAppend(&ds, procName, -1);
 
-    cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds),
-	    TclObjInterpProc, (ClientData) procPtr, TclProcDeleteProc);
-
+    cmd = TclNR_CreateCommand(interp, Tcl_DStringValue(&ds), TclObjInterpProc,
+	    TclNRInterpProc, (ClientData) procPtr, TclProcDeleteProc);
     Tcl_DStringFree(&ds);
 
     /*
@@ -864,6 +875,27 @@ TclObjGetFrame(
  *----------------------------------------------------------------------
  */
 
+static int
+Uplevel_Callback(
+    ClientData data[],
+    Tcl_Interp *interp,
+    int result)
+{
+    CallFrame *savedVarFramePtr = data[0];
+
+    if (result == TCL_ERROR) {
+	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+		"\n    (\"uplevel\" body line %d)", interp->errorLine));
+    }
+
+    /*
+     * Restore the variable frame, and return.
+     */
+
+    ((Interp *)interp)->varFramePtr = savedVarFramePtr;
+    return result;
+}
+
 	/* ARGSUSED */
 int
 Tcl_UplevelObjCmd(
@@ -872,9 +904,21 @@ Tcl_UplevelObjCmd(
     int objc,			/* Number of arguments. */
     Tcl_Obj *const objv[])	/* Argument objects. */
 {
+    return TclNR_CallObjProc(interp, TclNRUplevelObjCmd, dummy, objc, objv);
+}
+
+int
+TclNRUplevelObjCmd(
+    ClientData dummy,		/* Not used. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])	/* Argument objects. */
+{
+
     register Interp *iPtr = (Interp *) interp;
     int result;
     CallFrame *savedVarFramePtr, *framePtr;
+    Tcl_Obj *objPtr;
 
     if (objc < 2) {
     uplevelSyntax:
@@ -908,7 +952,7 @@ Tcl_UplevelObjCmd(
      */
 
     if (objc == 1) {
-	result = Tcl_EvalObjEx(interp, objv[0], 0);
+	objPtr = objv[0];
     } else {
 	/*
 	 * More than one argument: concatenate them together with spaces
@@ -916,22 +960,11 @@ Tcl_UplevelObjCmd(
 	 * object when it decrements its refcount after eval'ing it.
 	 */
 
-	Tcl_Obj *objPtr;
-
 	objPtr = Tcl_ConcatObj(objc, objv);
-	result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
-    }
-    if (result == TCL_ERROR) {
-	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
-		"\n    (\"uplevel\" body line %d)", interp->errorLine));
     }
 
-    /*
-     * Restore the variable frame, and return.
-     */
-
-    iPtr->varFramePtr = savedVarFramePtr;
-    return result;
+    TclNR_AddCallback(interp, Uplevel_Callback, savedVarFramePtr, NULL, NULL, NULL);
+    return TclNREvalObjEx(interp, objPtr, 0, NULL, 0);
 }
 
 /*
@@ -963,7 +996,6 @@ TclFindProc(
     const char *procName)	/* Name of desired procedure. */
 {
     Tcl_Command cmd;
-    Tcl_Command origCmd;
     Command *cmdPtr;
 
     cmd = Tcl_FindCommand((Tcl_Interp *) iPtr, procName, NULL, /*flags*/ 0);
@@ -972,14 +1004,7 @@ TclFindProc(
     }
     cmdPtr = (Command *) cmd;
 
-    origCmd = TclGetOriginalCommand(cmd);
-    if (origCmd != NULL) {
-	cmdPtr = (Command *) origCmd;
-    }
-    if (cmdPtr->objProc != TclObjInterpProc) {
-	return NULL;
-    }
-    return (Proc *) cmdPtr->objClientData;
+    return TclIsProc(cmdPtr);
 }
 
 /*
@@ -1010,7 +1035,7 @@ TclIsProc(
     if (origCmd != NULL) {
 	cmdPtr = (Command *) origCmd;
     }
-    if (cmdPtr->objProc == TclObjInterpProc) {
+    if (cmdPtr->deleteProc == TclProcDeleteProc) {
 	return (Proc *) cmdPtr->objClientData;
     }
     return (Proc *) 0;
@@ -1581,6 +1606,23 @@ PushProcCallFrame(
     return TCL_OK;
 }
 
+
+static int
+TclNR_BC(
+    Tcl_Interp * interp,
+    ByteCode *codePtr,
+    TclNR_PostProc *postProcPtr,
+    Tcl_Obj *procNameObj,
+    ProcErrorProc errorProc)
+{
+    TEOV_record *recordPtr = TOP_RECORD(interp);
+
+    recordPtr->type         = TCL_NR_BC_TYPE;
+    recordPtr->data.codePtr = codePtr;
+    TclNR_AddCallback(interp, postProcPtr, procNameObj, errorProc, NULL, NULL);
+    return TCL_OK;
+}
+
 /*
  *----------------------------------------------------------------------
  *
@@ -1610,6 +1652,10 @@ TclObjInterpProc(
 {
     int result;
 
+    /*
+     * Not used in the core; external interface for iTcl and XOTcl
+     */
+    
     result = PushProcCallFrame(clientData, interp, objc, objv, /*isLambda*/ 0);
     if (result == TCL_OK) {
 	return TclObjInterpProcCore(interp, objv[0], 1, &MakeProcError);
@@ -1617,6 +1663,26 @@ TclObjInterpProc(
 	return TCL_ERROR;
     }
 }
+
+int
+TclNRInterpProc(
+    ClientData clientData, 	/* Record describing procedure to be
+				 * interpreted. */
+    register Tcl_Interp *interp,/* Interpreter in which procedure was
+				 * invoked. */
+    int objc,			/* Count of number of arguments to this
+				 * procedure. */
+    Tcl_Obj *CONST objv[])	/* Argument value objects. */
+{
+    int result;
+
+    result = PushProcCallFrame(clientData, interp, objc, objv, /*isLambda*/ 0);
+    if (result == TCL_OK) {
+	return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError);
+    } else {
+	return TCL_ERROR;
+    }
+}
 
 /*
  *----------------------------------------------------------------------
@@ -1646,14 +1712,59 @@ TclObjInterpProcCore(
     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);
+	result = InterpProcNR2(&record.callbackPtr->data0, interp, result);
+	TclSmallFree(record.callbackPtr);
+    }
+    return result;
+}
+
+int
+TclNRInterpProcCore(
+    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. */
+{
     Interp *iPtr = (Interp *) interp;
     register Proc *procPtr = iPtr->varFramePtr->procPtr;
     int result;
     CallFrame *freePtr;
+    ByteCode *codePtr;
 
     result = InitArgsAndLocals(interp, procNameObj, skip);
     if (result != TCL_OK) {
-	goto procDone;
+	freePtr = iPtr->framePtr;
+	Tcl_PopCallFrame(interp);	 /* Pop but do not free. */
+	TclStackFree(interp, freePtr->compiledLocals);
+	                                /* Free compiledLocals. */
+	TclStackFree(interp, freePtr);	/* Free CallFrame. */
+	return TCL_ERROR;
     }
 
 #if defined(TCL_COMPILE_DEBUG)
@@ -1703,36 +1814,37 @@ TclObjInterpProcCore(
     TclResetCancellation(interp, 0);
 
     procPtr->refCount++;
-    iPtr->numLevels++;
+    codePtr = procPtr->bodyPtr->internalRep.otherValuePtr;
+    if (TCL_DTRACE_PROC_ENTRY_ENABLED()) {
+	int l;
+	
+	l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 2 : 1;
+	TCL_DTRACE_PROC_ENTRY(TclGetString(procNameObj),
+		iPtr->varFramePtr->objc - l,
+		(Tcl_Obj **)(iPtr->varFramePtr->objv + l));
+    }
 
-    if (TclInterpReady(interp) == TCL_ERROR) {
-	result = TCL_ERROR;
-    } else {
-	register ByteCode *codePtr =
-		procPtr->bodyPtr->internalRep.otherValuePtr;
+    TclNR_BC(interp, codePtr, InterpProcNR2, procNameObj, errorProc);
+    
+    return TCL_OK;
+}
 
-	codePtr->refCount++;
-	if (TCL_DTRACE_PROC_ENTRY_ENABLED()) {
-	    int l;
-	    
-	    l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 2 : 1;
-	    TCL_DTRACE_PROC_ENTRY(TclGetString(procNameObj),
-		    iPtr->varFramePtr->objc - l,
-		    (Tcl_Obj **)(iPtr->varFramePtr->objv + l));
-	}
-	result = TclExecuteByteCode(interp, codePtr);
-	if (TCL_DTRACE_PROC_RETURN_ENABLED()) {
-	    TCL_DTRACE_PROC_RETURN(TclGetString(procNameObj), result);
-	}
-	codePtr->refCount--;
-	if (codePtr->refCount <= 0) {
-	    TclCleanupByteCode(codePtr);
-	}
+static int
+InterpProcNR2(
+    ClientData data[],
+    Tcl_Interp *interp,
+    int result)
+{
+    Interp *iPtr = (Interp *) interp;
+    Proc *procPtr = iPtr->varFramePtr->procPtr;
+    CallFrame *freePtr;
+    Tcl_Obj *procNameObj = data[0];
+    ProcErrorProc errorProc = data[1];
+    
+    if (TCL_DTRACE_PROC_RETURN_ENABLED()) {
+	TCL_DTRACE_PROC_RETURN(TclGetString(procNameObj), result);
     }
-
-    iPtr->numLevels--;
-    procPtr->refCount--;
-    if (procPtr->refCount <= 0) {
+    if (--procPtr->refCount <= 0) {
 	TclProcCleanupProc(procPtr);
     }
 
@@ -1798,7 +1910,6 @@ TclObjInterpProcCore(
 		TclGetString(r), r);
     }
 
-  procDone:
     /*
      * Free the stack-allocated compiled locals and CallFrame. It is important
      * to pop the call frame without freeing it first: the compiledLocals
@@ -1812,6 +1923,7 @@ TclObjInterpProcCore(
     TclStackFree(interp, freePtr->compiledLocals);
 					/* Free compiledLocals. */
     TclStackFree(interp, freePtr);	/* Free CallFrame. */
+
     return result;
 }
 
@@ -2591,13 +2703,23 @@ Tcl_ApplyObjCmd(
     int objc,			/* Number of arguments. */
     Tcl_Obj *const objv[])	/* Argument objects. */
 {
+    return TclNR_CallObjProc(interp, TclNRApplyObjCmd, dummy, objc, objv);
+}
+
+
+int
+TclNRApplyObjCmd(
+    ClientData dummy,		/* Not used. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *CONST objv[])	/* Argument objects. */
+{
     Interp *iPtr = (Interp *) interp;
     Proc *procPtr = NULL;
     Tcl_Obj *lambdaPtr, *nsObjPtr;
     int result, isRootEnsemble;
-    Command cmd;
     Tcl_Namespace *nsPtr;
-    ExtraFrameInfo efi;
+    ApplyExtraData *extraPtr;
 
     if (objc < 2) {
 	Tcl_WrongNumArgs(interp, 1, objv, "lambdaExpr ?arg1 arg2 ...?");
@@ -2615,6 +2737,12 @@ Tcl_ApplyObjCmd(
     }
 
 #define JOE_EXTENSION 0
+/*
+ * Note: this code is NOT FUNCTIONAL due to the NR implementation; DO NOT
+ * ENABLE! Leaving here as reminder to (a) TIP the suggestion, and (b) adapt
+ * the code. (MS)
+ */
+    
 #if JOE_EXTENSION
     else {
 	/*
@@ -2641,8 +2769,21 @@ Tcl_ApplyObjCmd(
 	procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1;
     }
 
-    memset(&cmd, 0, sizeof(Command));
-    procPtr->cmdPtr = &cmd;
+    /*
+     * Find the namespace where this lambda should run, and push a call frame
+     * for that namespace. Note that TclObjInterpProc() will pop it.
+     */
+
+    nsObjPtr = lambdaPtr->internalRep.twoPtrValue.ptr2;
+    result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
+    if (result != TCL_OK) {
+	return TCL_ERROR;
+    }
+
+    extraPtr = TclStackAlloc(interp, sizeof(ApplyExtraData));
+    memset(&extraPtr->cmd, 0, sizeof(Command));
+    procPtr->cmdPtr = &extraPtr->cmd;
+    extraPtr->cmd.nsPtr = (Namespace *) nsPtr;
 
     /*
      * TIP#280 (semi-)HACK!
@@ -2654,24 +2795,11 @@ Tcl_ApplyObjCmd(
      * 'hPtr', and lambda's never.
      */
 
-    efi.length = 1;
-    efi.fields[0].name = "lambda";
-    efi.fields[0].proc = NULL;
-    efi.fields[0].clientData = lambdaPtr;
-    cmd.clientData = &efi;
-
-    /*
-     * Find the namespace where this lambda should run, and push a call frame
-     * for that namespace. Note that TclObjInterpProc() will pop it.
-     */
-
-    nsObjPtr = lambdaPtr->internalRep.twoPtrValue.ptr2;
-    result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
-    if (result != TCL_OK) {
-	return result;
-    }
-
-    cmd.nsPtr = (Namespace *) nsPtr;
+    extraPtr->efi.length = 1;
+    extraPtr->efi.fields[0].name = "lambda";
+    extraPtr->efi.fields[0].proc = NULL;
+    extraPtr->efi.fields[0].clientData = lambdaPtr;
+    extraPtr->cmd.clientData = &extraPtr->efi;
 
     isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL);
     if (isRootEnsemble) {
@@ -2681,18 +2809,43 @@ Tcl_ApplyObjCmd(
     } else {
 	iPtr->ensembleRewrite.numInsertedObjs -= 1;
     }
+    extraPtr->isRootEnsemble = isRootEnsemble;
 
     result = PushProcCallFrame((ClientData) procPtr, interp, objc, objv, 1);
     if (result == TCL_OK) {
-	result = TclObjInterpProcCore(interp, objv[1], 2, &MakeLambdaError);
+	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->data2 = extraPtr;
+	}
     }
+    if (result != TCL_OK) {
+	if (isRootEnsemble) {
+	    iPtr->ensembleRewrite.sourceObjs = NULL;
+	}
+	TclStackFree(interp, extraPtr);
+    }
+    return result;
+}
 
-    if (isRootEnsemble) {
-	iPtr->ensembleRewrite.sourceObjs = NULL;
-	iPtr->ensembleRewrite.numRemovedObjs = 0;
-	iPtr->ensembleRewrite.numInsertedObjs = 0;
+static int
+ApplyNR2(
+    ClientData data[],
+    Tcl_Interp *interp,
+    int result)
+{
+    ApplyExtraData *extraPtr = data[2];
+    
+    result = InterpProcNR2(data, interp, result);
+
+    if (extraPtr->isRootEnsemble) {
+	((Interp *) interp)->ensembleRewrite.sourceObjs = NULL;
     }
 
+    TclStackFree(interp, extraPtr);
     return result;
 }