summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog12
-rw-r--r--generic/tclInt.decls8
-rw-r--r--generic/tclInt.h9
-rw-r--r--generic/tclProc.c349
-rw-r--r--tests/apply.test38
5 files changed, 260 insertions, 156 deletions
diff --git a/ChangeLog b/ChangeLog
index a511ecd..cf6b929 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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 {}}}