summaryrefslogtreecommitdiffstats
path: root/generic/tclProc.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclProc.c')
-rw-r--r--generic/tclProc.c321
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;
}