summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorMiguel Sofer <miguel.sofer@gmail.com>2006-10-24 00:29:30 (GMT)
committerMiguel Sofer <miguel.sofer@gmail.com>2006-10-24 00:29:30 (GMT)
commit7dbcf3186d085c65101f4b9c10cb8ba485258e2e (patch)
treeac8de96d13826b1e1bc57dee584633871ab7e09f
parentbf63c22236bf05cc0f69635e66cd22a3010dcb6a (diff)
downloadtcl-7dbcf3186d085c65101f4b9c10cb8ba485258e2e.zip
tcl-7dbcf3186d085c65101f4b9c10cb8ba485258e2e.tar.gz
tcl-7dbcf3186d085c65101f4b9c10cb8ba485258e2e.tar.bz2
* generic/tclProc.c (ApplyObjCmd): fix wrong#args for apply by
using the ensemble rewrite engine, [Bug 1574835]. * generic/tclInterp.c (AliasObjCmd): previous commit missed usage of TCL_EVAL_NOREWRITE for aliases.
-rw-r--r--ChangeLog5
-rw-r--r--generic/tclInterp.c8
-rw-r--r--generic/tclProc.c47
3 files changed, 44 insertions, 16 deletions
diff --git a/ChangeLog b/ChangeLog
index 7dd12be..0f7f7dc 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,10 @@
2006-10-23 Miguel Sofer <msofer@users.sf.net>
+ * generic/tclProc.c (ApplyObjCmd): fix wrong#args for apply by
+ using the ensemble rewrite engine, [Bug 1574835].
+ * generic/tclInterp.c (AliasObjCmd): previous commit missed usage
+ of TCL_EVAL_NOREWRITE for aliases.
+
* generic/tclBasic.c (TclEvalObjvInternal): removed redundant
check for ensembles [Bug 1577628].
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 60e6eb6..9de1fbd 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInterp.c,v 1.64 2006/10/17 15:39:24 msofer Exp $
+ * RCS: @(#) $Id: tclInterp.c,v 1.65 2006/10/24 00:29:30 msofer Exp $
*/
#include "tclInt.h"
@@ -1740,10 +1740,12 @@ AliasObjCmd(
if (targetInterp != interp) {
Tcl_Preserve((ClientData) targetInterp);
- result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_INVOKE);
+ result = Tcl_EvalObjv(targetInterp, cmdc, cmdv,
+ TCL_EVAL_INVOKE|TCL_EVAL_NOREWRITE);
TclTransferResult(targetInterp, result, interp);
} else {
- result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_INVOKE);
+ result = Tcl_EvalObjv(targetInterp, cmdc, cmdv,
+ TCL_EVAL_INVOKE|TCL_EVAL_NOREWRITE);
}
if (isRootEnsemble) {
diff --git a/generic/tclProc.c b/generic/tclProc.c
index b0df000..b2ff2b9 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.97 2006/10/23 22:49:25 msofer Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.98 2006/10/24 00:29:31 msofer Exp $
*/
#include "tclInt.h"
@@ -29,7 +29,7 @@ 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 skip);
+ Tcl_Obj *CONST objv[], int isLambda);
static void ProcBodyDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr);
static void ProcBodyFree(Tcl_Obj *objPtr);
static int ProcessProcResultCode(Tcl_Interp *interp,
@@ -1136,7 +1136,7 @@ TclObjInterpProc(
Tcl_Obj *CONST objv[]) /* Argument value objects. */
{
- return ObjInterpProcEx(clientData, interp, objc, objv, /*skip*/ 1);
+ return ObjInterpProcEx(clientData, interp, objc, objv, /*isLambda*/ 0);
}
static int
@@ -1148,8 +1148,8 @@ ObjInterpProcEx(
int objc, /* Count of number of arguments to this
* procedure. */
Tcl_Obj *CONST objv[], /* Argument value objects. */
- int skip) /* Number of initial arguments to be skipped,
- * ie, words in the "command name" */
+ int isLambda) /* 1 if this is a call by ApplyObjCmd: it
+ * needs special rules for error msg */
{
Proc *procPtr = (Proc *) clientData;
Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
@@ -1219,8 +1219,8 @@ ObjInterpProcEx(
*/
numArgs = procPtr->numArgs;
- argCt = objc-skip; /* set it to the number of args to the proc */
- argObjs = &objv[skip];
+ argCt = objc-1; /* set it to the number of args to the proc */
+ argObjs = &objv[1];
varPtr = framePtr->compiledLocals;
localPtr = procPtr->firstLocalPtr;
if (numArgs == 0) {
@@ -1316,7 +1316,7 @@ ObjInterpProcEx(
#ifdef AVOID_HACKS_FOR_ITCL
desiredObjs[0] = objv[0];
#else
- desiredObjs[0] = Tcl_NewListObj(skip, objv);
+ desiredObjs[0] = Tcl_NewListObj(1, objv);
#endif /* AVOID_HACKS_FOR_ITCL */
localPtr = procPtr->firstLocalPtr;
@@ -1397,21 +1397,25 @@ ObjInterpProcEx(
}
if (result != TCL_OK) {
- if (skip == 1) {
- result = ProcessProcResultCode(interp, procName, nameLen, result);
- } else {
+ 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;
- namePtr = Tcl_NewListObj(skip, objv);
+ 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);
}
}
@@ -2079,6 +2083,7 @@ Tcl_ApplyObjCmd(
int result;
Command cmd;
Tcl_Namespace *nsPtr;
+ int isRootEnsemble;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "lambdaExpr ?arg1 arg2 ...?");
@@ -2144,7 +2149,23 @@ Tcl_ApplyObjCmd(
cmd.nsPtr = (Namespace *) nsPtr;
- return ObjInterpProcEx((ClientData) procPtr, interp, objc, objv, 2);
+ isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL);
+ if (isRootEnsemble) {
+ iPtr->ensembleRewrite.sourceObjs = objv;
+ iPtr->ensembleRewrite.numRemovedObjs = 1;
+ iPtr->ensembleRewrite.numInsertedObjs = 0;
+ } else {
+ iPtr->ensembleRewrite.numInsertedObjs -= 1;
+ }
+
+ result = ObjInterpProcEx((ClientData) procPtr, interp, objc-1, objv+1,1);
+
+ if (isRootEnsemble) {
+ iPtr->ensembleRewrite.sourceObjs = NULL;
+ iPtr->ensembleRewrite.numRemovedObjs = 0;
+ iPtr->ensembleRewrite.numInsertedObjs = 0;
+ }
+ return result;
}
/*