summaryrefslogtreecommitdiffstats
path: root/generic/tclProc.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclProc.c')
-rw-r--r--generic/tclProc.c490
1 files changed, 278 insertions, 212 deletions
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 7ee8415..62f2531 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -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: tclProc.c,v 1.120 2007/06/14 17:29:09 msofer Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.121 2007/06/14 21:02:20 msofer Exp $
*/
#include "tclInt.h"
@@ -24,13 +24,14 @@
static void DupLambdaInternalRep(Tcl_Obj *objPtr,
Tcl_Obj *copyPtr);
static void FreeLambdaInternalRep(Tcl_Obj *objPtr);
+static int InitArgsAndLocals(Tcl_Interp *interp,
+ Tcl_Obj *procNameObj, int skip);
static void InitCompiledLocals(Tcl_Interp *interp,
ByteCode *codePtr, CompiledLocal *localPtr,
Var *varPtr, Namespace *nsPtr);
-static int ObjInterpProcEx(ClientData clientData,
+static int PushProcCallFrame(ClientData clientData,
register Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[], int isLambda,
- ProcErrorProc errorProc);
+ Tcl_Obj *CONST objv[], int isLambda);
static void ProcBodyDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr);
static void ProcBodyFree(Tcl_Obj *objPtr);
static void MakeProcError(Tcl_Interp *interp,
@@ -1009,6 +1010,223 @@ TclIsProc(
/*
*----------------------------------------------------------------------
*
+ * InitArgsAndLocals --
+ *
+ * This routine is invoked in order to initialize the arguments and other
+ * compiled locals table for a new call frame.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Allocates memory on the stack for the compiled local variables, the
+ * caller is responsible for freeing them. Initialises all variables.
+ * May invoke various name resolvers in order to determine which
+ * variables are being referenced at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+InitArgsAndLocals(
+ 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". */
+{
+ CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
+ register Proc *procPtr = framePtr->procPtr;
+ ByteCode *codePtr = procPtr->bodyPtr->internalRep.otherValuePtr;
+ register Var *varPtr;
+ register CompiledLocal *localPtr;
+ int localCt, numArgs, argCt, i, imax;
+ Var *compiledLocals;
+ Tcl_Obj *const *argObjs;
+ Tcl_Obj **desiredObjs;
+ const char *final;
+
+ /*
+ * Create the "compiledLocals" array. Make sure it is large enough to hold
+ * all the procedure's compiled local variables, including its formal
+ * parameters.
+ */
+
+ localCt = procPtr->numCompiledLocals;
+ compiledLocals = (Var*) TclStackAlloc(interp, (int)(localCt*sizeof(Var)));
+ framePtr->numCompiledLocals = localCt;
+ framePtr->compiledLocals = compiledLocals;
+
+ /*
+ * Match and assign the call's actual parameters to the procedure's formal
+ * arguments. The formal arguments are described by the first numArgs
+ * entries in both the Proc structure's local variable list and the call
+ * frame's local variable array.
+ */
+
+ numArgs = procPtr->numArgs;
+ argCt = framePtr->objc - skip; /* Set it to the number of args to the
+ * procedure. */
+ argObjs = framePtr->objv + skip;
+ varPtr = framePtr->compiledLocals;
+ localPtr = procPtr->firstLocalPtr;
+ if (numArgs == 0) {
+ if (argCt) {
+ goto incorrectArgs;
+ } else {
+ goto correctArgs;
+ }
+ }
+ imax = ((argCt < numArgs - 1)? argCt : (numArgs - 1));
+ for (i = 0; i < imax; i++) {
+ /*
+ * "Normal" arguments; last formal is special, depends on it being
+ * 'args'.
+ */
+
+ Tcl_Obj *objPtr = argObjs[i];
+
+ varPtr->value.objPtr = objPtr;
+ Tcl_IncrRefCount(objPtr); /* Local var is a reference. */
+ varPtr->name = localPtr->name;
+ varPtr->nsPtr = NULL;
+ varPtr->hPtr = NULL;
+ varPtr->refCount = 0;
+ varPtr->tracePtr = NULL;
+ varPtr->searchPtr = NULL;
+ varPtr->flags = localPtr->flags;
+ varPtr++;
+ localPtr = localPtr->nextPtr;
+ }
+ for (; i < (numArgs - 1); i++) {
+ /*
+ * This loop is entered if argCt < (numArgs-1). Set default values;
+ * last formal is special.
+ */
+
+ if (localPtr->defValuePtr != NULL) {
+ Tcl_Obj *objPtr = localPtr->defValuePtr;
+
+ varPtr->value.objPtr = objPtr;
+ Tcl_IncrRefCount(objPtr); /* Local var is a reference. */
+ varPtr->name = localPtr->name;
+ varPtr->nsPtr = NULL;
+ varPtr->hPtr = NULL;
+ varPtr->refCount = 0;
+ varPtr->tracePtr = NULL;
+ varPtr->searchPtr = NULL;
+ varPtr->flags = localPtr->flags;
+ varPtr++;
+ localPtr = localPtr->nextPtr;
+ } else {
+ goto incorrectArgs;
+ }
+ }
+
+ /*
+ * When we get here, the last formal argument remains to be defined:
+ * localPtr and varPtr point to the last argument to be initialized.
+ */
+
+ if (localPtr->flags & VAR_IS_ARGS) {
+ Tcl_Obj *listPtr = Tcl_NewListObj(argCt-i, argObjs+i);
+
+ varPtr->value.objPtr = listPtr;
+ Tcl_IncrRefCount(listPtr); /* Local var is a reference. */
+ } else if (argCt == numArgs) {
+ Tcl_Obj *objPtr = argObjs[i];
+
+ varPtr->value.objPtr = objPtr;
+ Tcl_IncrRefCount(objPtr); /* Local var is a reference. */
+ } else if ((argCt < numArgs) && (localPtr->defValuePtr != NULL)) {
+ Tcl_Obj *objPtr = localPtr->defValuePtr;
+
+ varPtr->value.objPtr = objPtr;
+ Tcl_IncrRefCount(objPtr); /* Local var is a reference. */
+ } else {
+
+ goto incorrectArgs;
+ }
+
+ varPtr->name = localPtr->name;
+ varPtr->nsPtr = NULL;
+ varPtr->hPtr = NULL;
+ varPtr->refCount = 0;
+ varPtr->tracePtr = NULL;
+ varPtr->searchPtr = NULL;
+ varPtr->flags = localPtr->flags;
+
+ localPtr = localPtr->nextPtr;
+ varPtr++;
+
+ /*
+ * Initialise and resolve the remaining compiledLocals.
+ */
+
+ correctArgs:
+ if (localPtr) {
+ InitCompiledLocals(interp, codePtr, localPtr, varPtr, framePtr->nsPtr);
+ }
+
+ return TCL_OK;
+
+
+ incorrectArgs:
+ /*
+ * Do initialise all compiled locals, to avoid problems at
+ * DeleteLocalVars.
+ */
+
+ final = NULL;
+ InitCompiledLocals(interp, codePtr, localPtr, varPtr, framePtr->nsPtr);
+
+ /*
+ * Build up desired argument list for Tcl_WrongNumArgs
+ */
+
+ desiredObjs = (Tcl_Obj **) TclStackAlloc(interp,
+ (int) sizeof(Tcl_Obj *) * (numArgs+1));
+
+#ifdef AVOID_HACKS_FOR_ITCL
+ desiredObjs[0] = framePtr->objv[skip-1];
+#else
+ desiredObjs[0] = ((framePtr->isProcCallFrame & FRAME_IS_LAMBDA)
+ ? framePtr->objv[skip-1]
+ : Tcl_NewListObj(skip, framePtr->objv));
+#endif /* AVOID_HACKS_FOR_ITCL */
+ Tcl_IncrRefCount(desiredObjs[0]);
+
+ localPtr = procPtr->firstLocalPtr;
+ for (i=1 ; i<=numArgs ; i++) {
+ Tcl_Obj *argObj;
+
+ if (localPtr->defValuePtr != NULL) {
+ TclNewObj(argObj);
+ Tcl_AppendStringsToObj(argObj, "?", localPtr->name, "?", NULL);
+ } else if ((i==numArgs) && !strcmp(localPtr->name, "args")) {
+ numArgs--;
+ final = "...";
+ break;
+ } else {
+ argObj = Tcl_NewStringObj(localPtr->name, -1);
+ }
+ desiredObjs[i] = argObj;
+ localPtr = localPtr->nextPtr;
+ }
+
+ Tcl_ResetResult(interp);
+ Tcl_WrongNumArgs(interp, numArgs+1, desiredObjs, final);
+
+ for (i=0 ; i<=numArgs ; i++) {
+ Tcl_DecrRefCount(desiredObjs[i]);
+ }
+ TclStackFree(interp);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* InitCompiledLocals --
*
* This routine is invoked in order to initialize the compiled locals
@@ -1186,36 +1404,23 @@ TclInitCompiledLocals(
/*
*----------------------------------------------------------------------
*
- * TclObjInterpProc, ObjInterpProcEx --
+ * PushProcCallFrame --
*
- * When a Tcl procedure gets invoked during bytecode evaluation, this
- * object-based routine gets invoked to interpret the procedure.
+ * Compiles a proc body if necessary, then pushes a CallFrame suitable
+ * for executing it.
*
* Results:
* A standard Tcl object result value.
*
* Side effects:
- * Depends on the commands in the procedure.
+ * The proc's body may be recompiled. A CallFrame is pushed, it will have
+ * to be popped by the caller.
*
*----------------------------------------------------------------------
*/
-int
-TclObjInterpProc(
- 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. */
-{
- return ObjInterpProcEx(clientData, interp, objc, objv, /*isLambda*/ 0,
- &MakeProcError);
-}
-
static int
-ObjInterpProcEx(
+PushProcCallFrame(
ClientData clientData, /* Record describing procedure to be
* interpreted. */
register Tcl_Interp *interp,/* Interpreter in which procedure was
@@ -1223,10 +1428,8 @@ ObjInterpProcEx(
int objc, /* Count of number of arguments to this
* procedure. */
Tcl_Obj *CONST objv[], /* Argument value objects. */
- int isLambda, /* 1 if this is a call by ApplyObjCmd: it
+ int isLambda) /* 1 if this is a call by ApplyObjCmd: it
* needs special rules for error msg */
- ProcErrorProc errorProc) /* How to convert results from the script into
- * results of the overall procedure. */
{
Proc *procPtr = (Proc *) clientData;
Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
@@ -1280,7 +1483,8 @@ ObjInterpProcEx(
framePtrPtr = &framePtr;
result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
- (Tcl_Namespace *) nsPtr, FRAME_IS_PROC);
+ (Tcl_Namespace *) nsPtr,
+ (isLambda? (FRAME_IS_PROC|FRAME_IS_LAMBDA) : FRAME_IS_PROC));
if (result != TCL_OK) {
return result;
}
@@ -1289,8 +1493,44 @@ ObjInterpProcEx(
framePtr->objv = objv;
framePtr->procPtr = procPtr;
- return TclObjInterpProcCore(interp, framePtr, objv[isLambda], isLambda,
- isLambda+1, errorProc);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclObjInterpProc --
+ *
+ * When a Tcl procedure gets invoked during bytecode evaluation, this
+ * object-based routine gets invoked to interpret the procedure.
+ *
+ * Results:
+ * A standard Tcl object result value.
+ *
+ * Side effects:
+ * Depends on the commands in the procedure.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclObjInterpProc(
+ 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 TclObjInterpProcCore(interp, objv[0], 1, &MakeProcError);
+ } else {
+ return TCL_ERROR;
+ }
}
/*
@@ -1315,201 +1555,25 @@ int
TclObjInterpProcCore(
register Tcl_Interp *interp,/* Interpreter in which procedure was
* invoked. */
- CallFrame *framePtr, /* The context to execute. The procPtr field
- * must be non-NULL. */
Tcl_Obj *procNameObj, /* Procedure name for error reporting. */
- int isLambda, /* 1 if this is a call by ApplyObjCmd: it
- * needs special rules for error msg. */
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. */
{
+ CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
register Proc *procPtr = framePtr->procPtr;
ByteCode *codePtr = procPtr->bodyPtr->internalRep.otherValuePtr;
- register Var *varPtr;
- register CompiledLocal *localPtr;
- int localCt, numArgs, argCt, i, imax, result;
- Var *compiledLocals;
- Tcl_Obj *const *argObjs;
-
- /*
- * Create the "compiledLocals" array. Make sure it is large enough to hold
- * all the procedure's compiled local variables, including its formal
- * parameters.
- */
-
- localCt = procPtr->numCompiledLocals;
- compiledLocals = (Var*) TclStackAlloc(interp, (int)(localCt*sizeof(Var)));
- framePtr->numCompiledLocals = localCt;
- framePtr->compiledLocals = compiledLocals;
-
- /*
- * Match and assign the call's actual parameters to the procedure's formal
- * arguments. The formal arguments are described by the first numArgs
- * entries in both the Proc structure's local variable list and the call
- * frame's local variable array.
- */
-
- numArgs = procPtr->numArgs;
- argCt = framePtr->objc - skip; /* Set it to the number of args to the
- * procedure. */
- argObjs = framePtr->objv + skip;
- varPtr = framePtr->compiledLocals;
- localPtr = procPtr->firstLocalPtr;
- if (numArgs == 0) {
- if (argCt) {
- goto incorrectArgs;
- } else {
- goto runProc;
- }
- }
- imax = ((argCt < numArgs - 1)? argCt : (numArgs - 1));
- for (i = 0; i < imax; i++) {
- /*
- * "Normal" arguments; last formal is special, depends on it being
- * 'args'.
- */
-
- Tcl_Obj *objPtr = argObjs[i];
-
- varPtr->value.objPtr = objPtr;
- Tcl_IncrRefCount(objPtr); /* Local var is a reference. */
- varPtr->name = localPtr->name;
- varPtr->nsPtr = NULL;
- varPtr->hPtr = NULL;
- varPtr->refCount = 0;
- varPtr->tracePtr = NULL;
- varPtr->searchPtr = NULL;
- varPtr->flags = localPtr->flags;
- varPtr++;
- localPtr = localPtr->nextPtr;
- }
- for (; i < (numArgs - 1); i++) {
- /*
- * This loop is entered if argCt < (numArgs-1). Set default values;
- * last formal is special.
- */
-
- if (localPtr->defValuePtr != NULL) {
- Tcl_Obj *objPtr = localPtr->defValuePtr;
-
- varPtr->value.objPtr = objPtr;
- Tcl_IncrRefCount(objPtr); /* Local var is a reference. */
- varPtr->name = localPtr->name;
- varPtr->nsPtr = NULL;
- varPtr->hPtr = NULL;
- varPtr->refCount = 0;
- varPtr->tracePtr = NULL;
- varPtr->searchPtr = NULL;
- varPtr->flags = localPtr->flags;
- varPtr++;
- localPtr = localPtr->nextPtr;
- } else {
- goto incorrectArgs;
- }
- }
-
- /*
- * When we get here, the last formal argument remains to be defined:
- * localPtr and varPtr point to the last argument to be initialized.
- */
-
- if (localPtr->flags & VAR_IS_ARGS) {
- Tcl_Obj *listPtr = Tcl_NewListObj(argCt-i, argObjs+i);
-
- varPtr->value.objPtr = listPtr;
- Tcl_IncrRefCount(listPtr); /* Local var is a reference. */
- } else if (argCt == numArgs) {
- Tcl_Obj *objPtr = argObjs[i];
-
- varPtr->value.objPtr = objPtr;
- Tcl_IncrRefCount(objPtr); /* Local var is a reference. */
- } else if ((argCt < numArgs) && (localPtr->defValuePtr != NULL)) {
- Tcl_Obj *objPtr = localPtr->defValuePtr;
-
- varPtr->value.objPtr = objPtr;
- Tcl_IncrRefCount(objPtr); /* Local var is a reference. */
- } else {
- Tcl_Obj **desiredObjs;
- const char *final;
-
- /*
- * Do initialise all compiled locals, to avoid problems at
- * DeleteLocalVars.
- */
-
- incorrectArgs:
- final = NULL;
- InitCompiledLocals(interp, codePtr, localPtr, varPtr, framePtr->nsPtr);
-
- /*
- * Build up desired argument list for Tcl_WrongNumArgs
- */
-
- desiredObjs = (Tcl_Obj **) TclStackAlloc(interp,
- (int) sizeof(Tcl_Obj *) * (numArgs+1));
-
-#ifdef AVOID_HACKS_FOR_ITCL
- desiredObjs[0] = framePtr->objv[skip-1];
-#else
- desiredObjs[0] = (isLambda ? framePtr->objv[skip-1] :
- Tcl_NewListObj(skip, framePtr->objv));
-#endif /* AVOID_HACKS_FOR_ITCL */
- Tcl_IncrRefCount(desiredObjs[0]);
-
- localPtr = procPtr->firstLocalPtr;
- for (i=1 ; i<=numArgs ; i++) {
- Tcl_Obj *argObj;
-
- if (localPtr->defValuePtr != NULL) {
- TclNewObj(argObj);
- Tcl_AppendStringsToObj(argObj, "?", localPtr->name, "?", NULL);
- } else if ((i==numArgs) && !strcmp(localPtr->name, "args")) {
- numArgs--;
- final = "...";
- break;
- } else {
- argObj = Tcl_NewStringObj(localPtr->name, -1);
- }
- desiredObjs[i] = argObj;
- localPtr = localPtr->nextPtr;
- }
-
- Tcl_ResetResult(interp);
- Tcl_WrongNumArgs(interp, numArgs+1, desiredObjs, final);
- result = TCL_ERROR;
+ int result;
- for (i=0 ; i<=numArgs ; i++) {
- Tcl_DecrRefCount(desiredObjs[i]);
- }
- TclStackFree(interp);
+ result = InitArgsAndLocals(interp, procNameObj, skip);
+ if (result != TCL_OK) {
goto procDone;
}
- varPtr->name = localPtr->name;
- varPtr->nsPtr = NULL;
- varPtr->hPtr = NULL;
- varPtr->refCount = 0;
- varPtr->tracePtr = NULL;
- varPtr->searchPtr = NULL;
- varPtr->flags = localPtr->flags;
-
- localPtr = localPtr->nextPtr;
- varPtr++;
-
- /*
- * Initialise and resolve the remaining compiledLocals.
- */
-
- runProc:
- if (localPtr) {
- InitCompiledLocals(interp, codePtr, localPtr, varPtr, framePtr->nsPtr);
- }
-
#if defined(TCL_COMPILE_DEBUG)
if (tclTraceExec >= 1) {
- if (isLambda) {
+ if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) {
fprintf(stdout, "Calling lambda ");
} else {
fprintf(stdout, "Calling proc ");
@@ -2483,8 +2547,10 @@ Tcl_ApplyObjCmd(
iPtr->ensembleRewrite.numInsertedObjs -= 1;
}
- result = ObjInterpProcEx((ClientData) procPtr, interp, objc, objv, 1,
- &MakeLambdaError);
+ result = PushProcCallFrame((ClientData) procPtr, interp, objc, objv, 1);
+ if (result == TCL_OK) {
+ result = TclObjInterpProcCore(interp, objv[1], 2, &MakeLambdaError);
+ }
if (isRootEnsemble) {
iPtr->ensembleRewrite.sourceObjs = NULL;