diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tclInt.decls | 7 | ||||
| -rw-r--r-- | generic/tclInt.h | 5 | ||||
| -rw-r--r-- | generic/tclIntDecls.h | 7 | ||||
| -rw-r--r-- | generic/tclProc.c | 490 |
4 files changed, 287 insertions, 222 deletions
diff --git a/generic/tclInt.decls b/generic/tclInt.decls index b17c8e7..4437b7d 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.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: tclInt.decls,v 1.108 2007/05/05 23:33:14 dkf Exp $ +# RCS: @(#) $Id: tclInt.decls,v 1.109 2007/06/14 21:02:19 msofer Exp $ library tcl @@ -901,9 +901,8 @@ declare 227 generic { Tcl_Namespace *pathAry[]) } declare 228 generic { - int TclObjInterpProcCore(register Tcl_Interp *interp, CallFrame *framePtr, - Tcl_Obj *procNameObj, int isLambda, int skip, - ProcErrorProc errorProc) + int TclObjInterpProcCore(register Tcl_Interp *interp, Tcl_Obj *procNameObj, + int skip, ProcErrorProc errorProc) } declare 229 generic { int TclPtrMakeUpvar(Tcl_Interp *interp, Var *otherP1Ptr, diff --git a/generic/tclInt.h b/generic/tclInt.h index 64d81dd..8ad0c0b 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -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: tclInt.h,v 1.318 2007/06/12 12:34:00 dkf Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.319 2007/06/14 21:02:19 msofer Exp $ */ #ifndef _TCLINT @@ -954,7 +954,8 @@ typedef struct CallFrame { * specify. */ } CallFrame; -#define FRAME_IS_PROC 0x1 +#define FRAME_IS_PROC 0x1 +#define FRAME_IS_LAMBDA 0x2 /* * TIP #280 diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index f50e87f..15f7dcf 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.99 2007/05/05 23:36:36 dkf Exp $ + * RCS: @(#) $Id: tclIntDecls.h,v 1.100 2007/06/14 21:02:20 msofer Exp $ */ #ifndef _TCLINTDECLS @@ -1002,8 +1002,7 @@ EXTERN void TclSetNsPath (Namespace * nsPtr, int pathLength, #define TclObjInterpProcCore_TCL_DECLARED /* 228 */ EXTERN int TclObjInterpProcCore (register Tcl_Interp * interp, - CallFrame * framePtr, Tcl_Obj * procNameObj, - int isLambda, int skip, + Tcl_Obj * procNameObj, int skip, ProcErrorProc errorProc); #endif #ifndef TclPtrMakeUpvar_TCL_DECLARED @@ -1288,7 +1287,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, CallFrame * framePtr, Tcl_Obj * procNameObj, int isLambda, int skip, ProcErrorProc errorProc); /* 228 */ + int (*tclObjInterpProcCore) (register Tcl_Interp * interp, Tcl_Obj * procNameObj, int skip, ProcErrorProc errorProc); /* 228 */ 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 */ 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; |