diff options
| -rw-r--r-- | ChangeLog | 12 | ||||
| -rw-r--r-- | generic/tclInt.decls | 8 | ||||
| -rw-r--r-- | generic/tclInt.h | 9 | ||||
| -rw-r--r-- | generic/tclProc.c | 349 | ||||
| -rw-r--r-- | tests/apply.test | 38 |
5 files changed, 260 insertions, 156 deletions
@@ -1,3 +1,15 @@ +2006-10-28 Donal K. Fellows <dkf@users.sf.net> + + * generic/tclProc.c (ObjInterpProcEx, TclObjInterpProcCore): Split the + core of procedures to make it easier to build procedure-like code + without going through horrible contortions. This is the last critical + component to make advanced OO systems workable as simple loadable + extensions. TOIPC is now in the internal stub table. + (MakeProcError, MakeLambdaError): Refactored ProcessProcResultCode to + be simpler, some of which goes to TclObjInterpProcCore, and the rest + of which is now in these far simpler routines which just do errorInfo + stack generation for different types of procedure-like entity. + 2006-10-27 Donal K. Fellows <dkf@users.sf.net> * generic/tclVar.c (HasLocalVars): New macro to make various bits and diff --git a/generic/tclInt.decls b/generic/tclInt.decls index d2fbb20..4cca690 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.102 2006/10/27 12:53:43 dkf Exp $ +# RCS: @(#) $Id: tclInt.decls,v 1.103 2006/10/28 22:48:42 dkf Exp $ library tcl @@ -894,10 +894,16 @@ declare 225 generic { declare 226 generic { int TclObjBeingDeleted(Tcl_Obj *objPtr) } + declare 227 generic { void TclSetNsPath(Namespace *nsPtr, int pathLength, Tcl_Namespace *pathAry[]) } +declare 228 generic { + int TclObjInterpProcCore(register Tcl_Interp *interp, CallFrame *framePtr, + Tcl_Obj *procNameObj, int isLambda, int skip, + ProcErrorProc errorProc) +} ############################################################################## diff --git a/generic/tclInt.h b/generic/tclInt.h index 290576c..8c62cc1 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.285 2006/10/27 13:31:38 dkf Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.286 2006/10/28 22:48:43 dkf Exp $ */ #ifndef _TCLINT @@ -770,6 +770,13 @@ typedef struct Proc { } Proc; /* + * The type of functions called to process errors found during the execution + * of a procedure (or lambda term or ...). + */ + +typedef void (*ProcErrorProc)(Tcl_Interp *interp, Tcl_Obj *procNameObj); + +/* * The structure below defines a command trace. This is used to allow Tcl * clients to find out whenever a command is about to be executed. */ diff --git a/generic/tclProc.c b/generic/tclProc.c index 74d6ebd..b4c5696 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.100 2006/10/27 00:39:57 msofer Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.101 2006/10/28 22:48:43 dkf Exp $ */ #include "tclInt.h" @@ -29,14 +29,17 @@ static void InitCompiledLocals(Tcl_Interp *interp, Var *varPtr, Namespace *nsPtr); static int ObjInterpProcEx(ClientData clientData, register Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[], int isLambda); + Tcl_Obj *CONST objv[], int isLambda, + ProcErrorProc errorProc); static void ProcBodyDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr); static void ProcBodyFree(Tcl_Obj *objPtr); -static int ProcessProcResultCode(Tcl_Interp *interp, - char *procName, int nameLen, int returnCode); +static void MakeProcError(Tcl_Interp *interp, + Tcl_Obj *procNameObj); +static void MakeLambdaError(Tcl_Interp *interp, + Tcl_Obj *procNameObj); static int SetLambdaFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static int ProcCompileProc (Tcl_Interp *interp, Proc *procPtr, - Tcl_Obj *bodyPtr, Namespace *nsPtr, + Tcl_Obj *bodyPtr, Namespace *nsPtr, CONST char *description, CONST char *procName, Proc **procPtrPtr); @@ -1111,7 +1114,7 @@ TclInitCompiledLocals( /* *---------------------------------------------------------------------- * - * TclObjInterpProc -- + * TclObjInterpProc, ObjInterpProcEx -- * * When a Tcl procedure gets invoked during bytecode evaluation, this * object-based routine gets invoked to interpret the procedure. @@ -1135,10 +1138,10 @@ TclObjInterpProc( * procedure. */ Tcl_Obj *CONST objv[]) /* Argument value objects. */ { - - return ObjInterpProcEx(clientData, interp, objc, objv, /*isLambda*/ 0); + return ObjInterpProcEx(clientData, interp, objc, objv, /*isLambda*/ 0, + &MakeProcError); } - + static int ObjInterpProcEx( ClientData clientData, /* Record describing procedure to be @@ -1148,24 +1151,15 @@ 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 - * needs special rules for error msg */ + 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; CallFrame *framePtr, **framePtrPtr; - register Var *varPtr; - register CompiledLocal *localPtr; - char *procName; - int nameLen, localCt, numArgs, argCt, i, imax, result; - Var *compiledLocals; - Tcl_Obj *CONST *argObjs; - - /* - * Get the procedure's name. - */ - - procName = Tcl_GetStringFromObj(objv[0], &nameLen); + int result; /* * If necessary, compile the procedure's body. The compiler will allocate @@ -1175,13 +1169,12 @@ ObjInterpProcEx( */ result = ProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr, - "body of proc", procName, &procPtr); + "body of proc", TclGetString(objv[0]), &procPtr); if (result != TCL_OK) { return result; } - /* * Set up and push a new call frame for the new procedure invocation. * This call frame will execute in the proc's namespace, which might be @@ -1198,8 +1191,53 @@ ObjInterpProcEx( return result; } + framePtr->objc = objc; + framePtr->objv = objv; framePtr->procPtr = procPtr; + return TclObjInterpProcCore(interp, framePtr, objv[0], isLambda, 1, + errorProc); +} + +/* + *---------------------------------------------------------------------- + * + * TclObjInterpProcCore -- + * + * When a Tcl procedure, lambda term or anything else that works like a + * procedure gets invoked during bytecode evaluation, this object-based + * routine gets invoked to interpret the body. + * + * Results: + * A standard Tcl object result value. + * + * Side effects: + * Nearly anything; depends on the commands in the procedure body. + * + *---------------------------------------------------------------------- + */ + +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. */ +{ + register Proc *procPtr = framePtr->procPtr; + 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 @@ -1207,7 +1245,7 @@ ObjInterpProcEx( */ localCt = procPtr->numCompiledLocals; - compiledLocals = (Var *) TclStackAlloc(interp, (int)(localCt*sizeof(Var))); + compiledLocals = (Var*) TclStackAlloc(interp, (int)(localCt*sizeof(Var))); framePtr->numCompiledLocals = localCt; framePtr->compiledLocals = compiledLocals; @@ -1219,8 +1257,9 @@ ObjInterpProcEx( */ numArgs = procPtr->numArgs; - argCt = objc-1; /* set it to the number of args to the proc */ - argObjs = &objv[1]; + 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) { @@ -1304,7 +1343,7 @@ ObjInterpProcEx( incorrectArgs: codePtr = (ByteCode *) procPtr->bodyPtr->internalRep.otherValuePtr; - InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr); + InitCompiledLocals(interp, codePtr, localPtr, varPtr, framePtr->nsPtr); /* * Build up desired argument list for Tcl_WrongNumArgs @@ -1314,9 +1353,10 @@ ObjInterpProcEx( ckalloc(sizeof(Tcl_Obj *) * (unsigned)(numArgs+1)); #ifdef AVOID_HACKS_FOR_ITCL - desiredObjs[0] = objv[0]; + desiredObjs[0] = framePtr->objv[0]; #else - desiredObjs[0] = (isLambda? objv[0]: Tcl_NewListObj(1, objv)); + desiredObjs[0] = (isLambda ? framePtr->objv[0] : + Tcl_NewListObj(1, framePtr->objv)); #endif /* AVOID_HACKS_FOR_ITCL */ localPtr = procPtr->firstLocalPtr; @@ -1370,18 +1410,25 @@ ObjInterpProcEx( ByteCode *codePtr = (ByteCode *) procPtr->bodyPtr->internalRep.otherValuePtr; - InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr); + InitCompiledLocals(interp, codePtr, localPtr, varPtr, framePtr->nsPtr); } /* - * Invoke the commands in the procedure's body. + * Set the callframe's objc/objv to be what [info level] expects. */ -#ifdef TCL_COMPILE_DEBUG + framePtr->objc = ((Interp *) interp)->callObjc; + framePtr->objv = ((Interp *) interp)->callObjv; + +#if defined(TCL_COMPILE_DEBUG) if (tclTraceExec >= 1) { - fprintf(stdout, "Calling proc "); - for (i = 0; i < objc; i++) { - TclPrintObject(stdout, objv[i], 15); + if (isLambda) { + fprintf(stdout, "Calling lambda "); + } else { + fprintf(stdout, "Calling proc "); + } + for (i = 0; i < framePtr->objc; i++) { + TclPrintObject(stdout, framePtr->objv[i], 15); fprintf(stdout, " "); } fprintf(stdout, "\n"); @@ -1389,6 +1436,10 @@ ObjInterpProcEx( } #endif /*TCL_COMPILE_DEBUG*/ + /* + * Invoke the commands in the procedure's body. + */ + procPtr->refCount++; result = TclCompEvalObj(interp, procPtr->bodyPtr); procPtr->refCount--; @@ -1397,26 +1448,46 @@ ObjInterpProcEx( } if (result != TCL_OK) { - if (isLambda) { - /* - * Use a 'procName' that contains the first skip elements of objv - * for error reporting. This insures that we do not see just - * 'apply', but also the lambda expression that caused the error. - * - * NASTY HACK: looks one object back in objv - it was skipped by - * ApplyObjCmd. Temporary solution, the whole thing needs - * refactoring. - */ - - Tcl_Obj *namePtr; + /* + * Non-standard results are processed by passing them through quickly. + * This means they all work as exceptions, unwinding the stack quickly + * and neatly. Who knows how well they are handled by third-party code + * though... + */ - namePtr = Tcl_NewListObj(2, objv-1); - procName = Tcl_GetStringFromObj(namePtr, &nameLen); - result = ProcessProcResultCode(interp, procName, nameLen, result); - TclDecrRefCount(namePtr); - } else { - result = ProcessProcResultCode(interp, procName, nameLen, result); + if ((result > TCL_CONTINUE) || (result < TCL_OK)) { + goto procDone; } + + /* + * If it is a 'return', do the TIP#90 processing now. + */ + + if (result == TCL_RETURN) { + result = TclUpdateReturnInfo((Interp *) interp); + goto procDone; + } + + /* + * Must be an error, a 'break' or a 'continue'. It's an error to get + * to this point from a 'break' or 'continue' though, so transform to + * an error now. + */ + + if (result != TCL_ERROR) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "invoked \"", + ((result == TCL_BREAK) ? "break" : "continue"), + "\" outside of a loop", NULL); + result = TCL_ERROR; + } + + /* + * Now it _must_ be an error, so we need to log it as such. This means + * filling out the error trace. + */ + + (*errorProc)(interp, procNameObj); } /* @@ -1437,7 +1508,6 @@ ObjInterpProcEx( TclStackFree(interp); /* free compiledLocals */ TclStackFree(interp); /* free CallFrame */ return result; -#undef NUM_LOCALS } /* @@ -1652,56 +1722,35 @@ ProcCompileProc( /* *---------------------------------------------------------------------- * - * ProcessProcResultCode -- + * MakeProcError -- * - * Function called by TclObjInterpProc to process a return code other - * than TCL_OK returned by a Tcl procedure. + * Function called by TclObjInterpProc to create the stack information + * upon an error from a procedure. * * Results: - * Depending on the argument return code, the result returned is another - * return code and the interpreter's result is set to a value to - * supplement that return code. + * The interpreter's error info trace is set to a value that supplements + * the error code. * * Side effects: - * If the result returned is TCL_ERROR, traceback information about the - * procedure just executed is appended to the interpreter's errorInfo - * field. + * none. * *---------------------------------------------------------------------- */ -static int -ProcessProcResultCode( +static void +MakeProcError( Tcl_Interp *interp, /* The interpreter in which the procedure was - * called and returned returnCode. */ - char *procName, /* Name of the procedure. Used for error + * called. */ + Tcl_Obj *procNameObj) /* Name of the procedure. Used for error * messages and trace information. */ - int nameLen, /* Number of bytes in procedure's name. */ - int returnCode) /* The unexpected result code. */ { - Interp *iPtr = (Interp *) interp; - int overflow, limit = 60; + int overflow, limit = 60, nameLen; + const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen); - if (returnCode == TCL_OK) { - return TCL_OK; - } - if ((returnCode > TCL_CONTINUE) || (returnCode < TCL_OK)) { - return returnCode; - } - if (returnCode == TCL_RETURN) { - return TclUpdateReturnInfo(iPtr); - } - if (returnCode != TCL_ERROR) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "invoked \"", - ((returnCode == TCL_BREAK) ? "break" : "continue"), - "\" outside of a loop", NULL); - } overflow = (nameLen > limit); TclFormatToErrorInfo(interp, "\n (procedure \"%.*s%s\" line %d)", (overflow ? limit : nameLen), procName, (overflow ? "..." : ""), interp->errorLine); - return TCL_ERROR; } /* @@ -1954,7 +2003,17 @@ ProcBodyFree( } /* - * LAMBDA and APPLY implementation. [TIP#194] + *---------------------------------------------------------------------- + * + * DupLambdaInternalRep, FreeLambdaInternalRep, SetLambdaFromAny -- + * + * How to manage the internal representations of lambda term objects. + * Syntactically they look like a two- or three-element list, where the + * first element is the formal arguments, the second is the the body, and + * the (optional) third is the namespace to execute the lambda term + * within (the global namespace is assumed if it is absent). + * + *---------------------------------------------------------------------- */ static void @@ -1962,11 +2021,11 @@ DupLambdaInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ register Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - Proc *procPtr = (Proc *) srcPtr->internalRep.twoPtrValue.ptr1; - Tcl_Obj *nsObjPtr = (Tcl_Obj *) srcPtr->internalRep.twoPtrValue.ptr2; + Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1; + Tcl_Obj *nsObjPtr = srcPtr->internalRep.twoPtrValue.ptr2; - copyPtr->internalRep.twoPtrValue.ptr1 = (void *) procPtr; - copyPtr->internalRep.twoPtrValue.ptr2 = (void *) nsObjPtr; + copyPtr->internalRep.twoPtrValue.ptr1 = procPtr; + copyPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr; procPtr->refCount++; Tcl_IncrRefCount(nsObjPtr); @@ -1978,8 +2037,8 @@ FreeLambdaInternalRep( register Tcl_Obj *objPtr) /* CmdName object with internal representation * to free. */ { - Proc *procPtr = (Proc *) objPtr->internalRep.twoPtrValue.ptr1; - Tcl_Obj *nsObjPtr = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr2; + Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1; + Tcl_Obj *nsObjPtr = objPtr->internalRep.twoPtrValue.ptr2; procPtr->refCount--; if (procPtr->refCount == 0) { @@ -2022,26 +2081,26 @@ SetLambdaFromAny( */ name = TclGetString(objPtr); - + if (TclCreateProc(interp, /*ignored nsPtr*/ NULL, name, argsPtr, bodyPtr, &procPtr) != TCL_OK) { TclFormatToErrorInfo(interp, - "\n (parsing lambda expression \"%s\")", - name, NULL); + "\n (parsing lambda expression \"%s\")", name, NULL); return TCL_ERROR; } - /* CAREFUL: TclCreateProc returns refCount==1! [Bug 1578454] + /* + * CAREFUL: TclCreateProc returns refCount==1! [Bug 1578454] * procPtr->refCount = 1; */ - + procPtr->cmdPtr = NULL; /* * Set the namespace for this lambda: given by objv[2] understood as a * global reference, or else global per default. */ - + if (objc == 2) { nsObjPtr = Tcl_NewStringObj("::", 2); } else { @@ -2064,11 +2123,28 @@ SetLambdaFromAny( objPtr->typePtr->freeIntRepProc(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = (void *) procPtr; - objPtr->internalRep.twoPtrValue.ptr2 = (void *) nsObjPtr; + objPtr->internalRep.twoPtrValue.ptr1 = procPtr; + objPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr; objPtr->typePtr = &lambdaType; return TCL_OK; } + +/* + *---------------------------------------------------------------------- + * + * Tcl_ApplyObjCmd -- + * + * This object-based function is invoked to process the "apply" Tcl + * command. See the user documentation for details on what it does. + * + * Results: + * A standard Tcl object result value. + * + * Side effects: + * Depends on the content of the lambda term (i.e., objv[1]). + * + *---------------------------------------------------------------------- + */ int Tcl_ApplyObjCmd( @@ -2094,20 +2170,20 @@ Tcl_ApplyObjCmd( * Set lambdaPtr, convert it to lambdaType in the current interp if * necessary. */ - + lambdaPtr = objv[1]; if (lambdaPtr->typePtr == &lambdaType) { - procPtr = (Proc *) lambdaPtr->internalRep.twoPtrValue.ptr1; + procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1; } #define JOE_EXTENSION 0 #if JOE_EXTENSION - /* - * Joe English's suggestion to allow cmdNames to function as lambdas. - * Requires also making tclCmdNameType non-static in tclObj.c - */ - else { + /* + * Joe English's suggestion to allow cmdNames to function as lambdas. + * Also requires making tclCmdNameType non-static in tclObj.c + */ + Tcl_Obj *elemPtr; int numElem; @@ -2124,17 +2200,17 @@ Tcl_ApplyObjCmd( if (result != TCL_OK) { return result; } - procPtr = (Proc *) lambdaPtr->internalRep.twoPtrValue.ptr1; + procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1; } 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 = (Tcl_Obj *) lambdaPtr->internalRep.twoPtrValue.ptr2; - result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); + + nsObjPtr = lambdaPtr->internalRep.twoPtrValue.ptr2; + result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); if (result != TCL_OK) { return result; } @@ -2146,7 +2222,7 @@ Tcl_ApplyObjCmd( Tcl_SetObjResult(interp, errPtr); return TCL_ERROR; } - + cmd.nsPtr = (Namespace *) nsPtr; isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL); @@ -2158,14 +2234,49 @@ Tcl_ApplyObjCmd( iPtr->ensembleRewrite.numInsertedObjs -= 1; } - result = ObjInterpProcEx((ClientData) procPtr, interp, objc-1, objv+1,1); + result = ObjInterpProcEx((ClientData) procPtr, interp, objc-1, objv+1, 1, + &MakeLambdaError); if (isRootEnsemble) { iPtr->ensembleRewrite.sourceObjs = NULL; iPtr->ensembleRewrite.numRemovedObjs = 0; iPtr->ensembleRewrite.numInsertedObjs = 0; } - return result; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * MakeLambdaError -- + * + * Function called by TclObjInterpProc to create the stack information + * upon an error from a lambda term. + * + * Results: + * The interpreter's error info trace is set to a value that supplements + * the error code. + * + * Side effects: + * none. + * + *---------------------------------------------------------------------- + */ + +static void +MakeLambdaError( + Tcl_Interp *interp, /* The interpreter in which the procedure was + * called. */ + Tcl_Obj *procNameObj) /* Name of the procedure. Used for error + * messages and trace information. */ +{ + int overflow, limit = 60, nameLen; + const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen); + + overflow = (nameLen > limit); + TclFormatToErrorInfo(interp, "\n (lambda term \"%.*s%s\" line %d)", + (overflow ? limit : nameLen), procName, + (overflow ? "..." : ""), interp->errorLine); } /* diff --git a/tests/apply.test b/tests/apply.test index e639638..10131ce 100644 --- a/tests/apply.test +++ b/tests/apply.test @@ -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: apply.test,v 1.8 2006/10/24 23:13:07 msofer Exp $ +# RCS: @(#) $Id: apply.test,v 1.9 2006/10/28 22:48:43 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -23,7 +23,7 @@ if {[info commands ::apply] eq {}} { return } -testConstraint memory [llength [info commands memory]] +testConstraint memory [llength [info commands memory]] # Tests for wrong number of arguments @@ -39,13 +39,11 @@ test apply-2.0 {malformed lambda} { set res [catch {apply $lambda} msg] list $res $msg } {1 {can't interpret "a" as a lambda expression}} - test apply-2.1 {malformed lambda} { set lambda [list a b c d] set res [catch {apply $lambda} msg] list $res $msg } {1 {can't interpret "a b c d" as a lambda expression}} - test apply-2.2 {malformed lambda} { set lambda [list {{}} boo] set res [catch {apply $lambda} msg] @@ -54,7 +52,6 @@ test apply-2.2 {malformed lambda} { (parsing lambda expression "{{}} boo") invoked from within "apply $lambda"}} - test apply-2.3 {malformed lambda} { set lambda [list {{a b c}} boo] set res [catch {apply $lambda} msg] @@ -63,7 +60,6 @@ test apply-2.3 {malformed lambda} { (parsing lambda expression "{{a b c}} boo") invoked from within "apply $lambda"}} - test apply-2.4 {malformed lambda} { set lambda [list a(1) boo] set res [catch {apply $lambda} msg] @@ -72,7 +68,6 @@ test apply-2.4 {malformed lambda} { (parsing lambda expression "a(1) boo") invoked from within "apply $lambda"}} - test apply-2.5 {malformed lambda} { set lambda [list a::b boo] set res [catch {apply $lambda} msg] @@ -82,7 +77,6 @@ test apply-2.5 {malformed lambda} { invoked from within "apply $lambda"}} - # Tests for runtime errors in the lambda expression test apply-3.1 {non-existing namespace} { @@ -90,7 +84,6 @@ test apply-3.1 {non-existing namespace} { set res [catch {apply $lambda x} msg] list $res $msg } {1 {cannot find namespace "::NONEXIST::FOR::SURE"}} - test apply-3.2 {non-existing namespace} { namespace eval ::NONEXIST::FOR::SURE {} set lambda [list x {set x 1} ::NONEXIST::FOR::SURE] @@ -99,13 +92,11 @@ test apply-3.2 {non-existing namespace} { set res [catch {apply $lambda x} msg] list $res $msg } {1 {cannot find namespace "::NONEXIST::FOR::SURE"}} - test apply-3.3 {non-existing namespace} { set lambda [list x {set x 1} NONEXIST::FOR::SURE] set res [catch {apply $lambda x} msg] list $res $msg } {1 {cannot find namespace "::NONEXIST::FOR::SURE"}} - test apply-3.4 {non-existing namespace} { namespace eval ::NONEXIST::FOR::SURE {} set lambda [list x {set x 1} NONEXIST::FOR::SURE] @@ -120,27 +111,23 @@ test apply-4.1 {error in arguments to lambda expression} { set res [catch {apply $lambda} msg] list $res $msg } {1 {wrong # args: should be "apply {x {set x 1}} x"}} - test apply-4.2 {error in arguments to lambda expression} { set lambda [list x {set x 1}] set res [catch {apply $lambda a b} msg] list $res $msg } {1 {wrong # args: should be "apply {x {set x 1}} x"}} - test apply-4.3 {error in arguments to lambda expression} { set lambda [list x {set x 1}] interp alias {} foo {} ::apply $lambda set res [catch {foo a b} msg] list $res $msg [rename foo {}] } {1 {wrong # args: should be "foo x"} {}} - test apply-4.4 {error in arguments to lambda expression} { set lambda [list x {set x 1}] interp alias {} foo {} ::apply $lambda a set res [catch {foo b} msg] list $res $msg [rename foo {}] } {1 {wrong # args: should be "foo"} {}} - test apply-4.5 {error in arguments to lambda expression} { set lambda [list x {set x 1}] namespace eval a { @@ -168,7 +155,7 @@ test apply-5.1 {runtime error in lambda expression} { } {1 {foo while executing "error foo" - (procedure "apply {{} {error foo}}" line 1) + (lambda term "{} {error foo}" line 1) invoked from within "apply $lambda"}} @@ -180,12 +167,10 @@ test apply-6.1 {info level} { set lambda [list {} {info level}] expr {[apply $lambda] - $lev} } 1 - test apply-6.2 {info level} { set lambda [list {} {info level 0}] apply $lambda } {apply {{} {info level 0}}} - test apply-6.3 {info level} { set lambda [list args {info level 0}] apply $lambda x y @@ -202,50 +187,42 @@ test apply-7.1 {namespace access} { set body {set x 1; set x} list [apply [list args $body ::testApply]] $::testApply::x } {1 0} - test apply-7.2 {namespace access} { set ::testApply::x 0 set body {variable x; set x} list [apply [list args $body ::testApply]] $::testApply::x } {0 0} - test apply-7.3 {namespace access} { set ::testApply::x 0 set body {variable x; set x 1} list [apply [list args $body ::testApply]] $::testApply::x } {1 1} - test apply-7.4 {namespace access} { set ::testApply::x 0 set body {testApply} apply [list args $body ::testApply] } testApply - test apply-7.5 {namespace access} { set ::testApply::x 0 set body {set x 1; set x} list [apply [list args $body testApply]] $::testApply::x } {1 0} - test apply-7.6 {namespace access} { set ::testApply::x 0 set body {variable x; set x} list [apply [list args $body testApply]] $::testApply::x } {0 0} - test apply-7.7 {namespace access} { set ::testApply::x 0 set body {variable x; set x 1} list [apply [list args $body testApply]] $::testApply::x } {1 1} - test apply-7.8 {namespace access} { set ::testApply::x 0 set body {testApply} apply [list args $body testApply] } testApply - # Tests for correct argument treatment set applyBody { @@ -260,39 +237,30 @@ set applyBody { test apply-8.1 {args treatment} { apply [list args $applyBody] 1 2 3 } {{args {1 2 3}}} - test apply-8.2 {args treatment} { apply [list {x args} $applyBody] 1 2 } {{x 1} {args 2}} - test apply-8.3 {args treatment} { apply [list {x args} $applyBody] 1 2 3 } {{x 1} {args {2 3}}} - test apply-8.4 {default values} { apply [list {{x 1} {y 2}} $applyBody] } {{x 1} {y 2}} - test apply-8.5 {default values} { apply [list {{x 1} {y 2}} $applyBody] 3 4 } {{x 3} {y 4}} - test apply-8.6 {default values} { apply [list {{x 1} {y 2}} $applyBody] 3 } {{x 3} {y 2}} - test apply-8.7 {default values} { apply [list {x {y 2}} $applyBody] 1 } {{x 1} {y 2}} - test apply-8.8 {default values} { apply [list {x {y 2}} $applyBody] 1 3 } {{x 1} {y 3}} - test apply-8.9 {default values} { apply [list {x {y 2} args} $applyBody] 1 } {{x 1} {y 2} {args {}}} - test apply-8.10 {default values} { apply [list {x {y 2} args} $applyBody] 1 3 } {{x 1} {y 3} {args {}}} |