From ba6dbcbada614e41a404b68b0b7edcca6f149f07 Mon Sep 17 00:00:00 2001 From: Miguel Sofer Date: Mon, 1 Sep 2008 12:28:04 +0000 Subject: * generic/tclCmdAH.c: nre-enabling [eval]; eval scripts are now * generic/tclOOBasic.c: bytecompiled. Adapted recursion limit tests * tests/interp.test: that were relying on eval not being * tests/nre.test: compiled. Part of the [Bug 2017632] project. * tests/unsupported.test: --- ChangeLog | 8 ++ generic/tclCmdAH.c | 49 ++++++++----- generic/tclOOBasic.c | 8 +- tests/interp.test | 196 ++++++++++++++++++++++++++++++++++++++++++++----- tests/nre.test | 22 +++++- tests/unsupported.test | 8 +- 6 files changed, 244 insertions(+), 47 deletions(-) diff --git a/ChangeLog b/ChangeLog index 8f5fab5..0d462ed 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +2008-09-01 Miguel Sofer + + * generic/tclCmdAH.c: nre-enabling [eval]; eval scripts are now + * generic/tclOOBasic.c: bytecompiled. Adapted recursion limit tests + * tests/interp.test: that were relying on eval not being + * tests/nre.test: compiled. Part of the [Bug 2017632] project. + * tests/unsupported.test: + 2008-09-01 Donal K. Fellows * generic/tclOOMethod.c (InvokeProcedureMethod): diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 272cb20..80aadeb 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.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: tclCmdAH.c,v 1.103 2008/08/24 14:38:11 dkf Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.104 2008/09/01 12:28:08 msofer Exp $ */ #include "tclInt.h" @@ -57,6 +57,7 @@ static int StoreStatData(Tcl_Interp *interp, Tcl_Obj *varName, static Tcl_NRPostProc CatchObjCmdCallback; static Tcl_NRPostProc ForNextCallback; static Tcl_NRPostProc ForeachLoopStep; +static Tcl_NRPostProc EvalCmdErrMsg; /* *---------------------------------------------------------------------- @@ -690,6 +691,21 @@ Tcl_ErrorObjCmd( */ /* ARGSUSED */ + +static int +EvalCmdErrMsg( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + if (result == TCL_ERROR) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"eval\" body line %d)", interp->errorLine)); + } + return result; +} + + int Tcl_EvalObjCmd( ClientData dummy, /* Not used. */ @@ -697,9 +713,10 @@ Tcl_EvalObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int result; register Tcl_Obj *objPtr; Interp *iPtr = (Interp *) interp; + CmdFrame* invoker = NULL; + int word = 0; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?"); @@ -711,32 +728,24 @@ Tcl_EvalObjCmd( * TIP #280. Make argument location available to eval'd script. */ - CmdFrame* invoker = iPtr->cmdFramePtr; - int word = 1; - TclArgumentGet (interp, objv[1], &invoker, &word); - - result = TclEvalObjEx(interp, objv[1], TCL_EVAL_DIRECT, - invoker, word); + invoker = iPtr->cmdFramePtr; + word = 1; + objPtr = objv[1]; + TclArgumentGet (interp, objPtr, &invoker, &word); } else { /* * More than one argument: concatenate them together with spaces * between, then evaluate the result. Tcl_EvalObjEx will delete the - * object when it decrements its refcount after eval'ing it. + * object when it decrements its refcount after eval'ing it. + * + * TIP #280. Make invoking context available to eval'd script, done + * with the default values. */ objPtr = Tcl_ConcatObj(objc-1, objv+1); - - /* - * TIP #280. Make invoking context available to eval'd script. - */ - - result = TclEvalObjEx(interp, objPtr, TCL_EVAL_DIRECT, NULL, 0); - } - if (result == TCL_ERROR) { - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"eval\" body line %d)", interp->errorLine)); } - return result; + TclNRAddCallback(interp, EvalCmdErrMsg,NULL, NULL, NULL, NULL); + return TclNREvalObjEx(interp, objPtr, 0, invoker, word); } /* diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 28033cd..9df3907 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclOOBasic.c,v 1.9 2008/07/31 14:43:47 msofer Exp $ + * RCS: @(#) $Id: tclOOBasic.c,v 1.10 2008/09/01 12:28:09 msofer Exp $ */ #ifdef HAVE_CONFIG_H @@ -293,7 +293,7 @@ TclOO_Object_Eval( register const int skip = Tcl_ObjectContextSkippedArgs(context); CallFrame *framePtr, **framePtrPtr = &framePtr; Tcl_Obj *scriptPtr; - int result, flags; + int result; CmdFrame *invoker; if (objc-1 < skip) { @@ -329,11 +329,9 @@ TclOO_Object_Eval( if (objc != skip+1) { scriptPtr = Tcl_ConcatObj(objc-skip, objv+skip); - flags = TCL_EVAL_DIRECT; invoker = NULL; } else { scriptPtr = objv[skip]; - flags = 0; invoker = ((Interp *) interp)->cmdFramePtr; } @@ -343,7 +341,7 @@ TclOO_Object_Eval( */ TclNRAddCallback(interp, FinalizeEval, object, NULL, NULL, NULL); - return TclNREvalObjEx(interp, scriptPtr, flags, invoker, skip); + return TclNREvalObjEx(interp, scriptPtr, 0, invoker, skip); } static int diff --git a/tests/interp.test b/tests/interp.test index 33dfda9..01e3ca8 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -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: interp.test,v 1.60 2008/07/19 22:50:38 nijtmans Exp $ +# RCS: @(#) $Id: interp.test,v 1.61 2008/09/01 12:28:09 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 @@ -2623,7 +2623,12 @@ test interp-29.3.6 {recursion limit error reporting} { list $r1 $r2 } {0 ok} -test interp-29.3.7 {recursion limit error reporting} { +# +# Note that TEBC does not verify the interp's nesting level itself; the nesting +# level will only be verified when it invokes a non-bcc'd command. +# + +test interp-29.3.7a {recursion limit error reporting} { interp create slave after 0 {interp recursionlimit slave 5} set r1 [slave eval { @@ -2632,8 +2637,53 @@ test interp-29.3.7 {recursion limit error reporting} { eval { # 3 eval { # 4 eval { # 5 - update - set x ok + update + set x ok + } + } + } + } + } msg + }] + set r2 [slave eval { set msg }] + interp delete slave + list $r1 $r2 +} {0 ok} + +test interp-29.3.7b {recursion limit error reporting} { + interp create slave + after 0 {interp recursionlimit slave 5} + set r1 [slave eval { + catch { # nesting level 1 + eval { # 2 + eval { # 3 + eval { # 4 + update + eval { # 5 + set x ok + } + } + } + } + } msg + }] + set r2 [slave eval { set msg }] + interp delete slave + list $r1 $r2 +} {0 ok} + +test interp-29.3.7c {recursion limit error reporting} { + interp create slave + after 0 {interp recursionlimit slave 5} + set r1 [slave eval { + catch { # nesting level 1 + eval { # 2 + eval { # 3 + eval { # 4 + eval { # 5 + update + set set set + $set x ok } } } @@ -2645,7 +2695,7 @@ test interp-29.3.7 {recursion limit error reporting} { list $r1 $r2 } {1 {too many nested evaluations (infinite loop?)}} -test interp-29.3.8 {recursion limit error reporting} { +test interp-29.3.8a {recursion limit error reporting} { interp create slave after 0 {interp recursionlimit slave 4} set r1 [slave eval { @@ -2654,8 +2704,30 @@ test interp-29.3.8 {recursion limit error reporting} { eval { # 3 eval { # 4 eval { # 5 - update - set x ok + update + set x ok + } + } + } + } + } msg + }] + set r2 [slave eval { set msg }] + interp delete slave + list $r1 $r2 +} {0 ok} + +test interp-29.3.8b {recursion limit error reporting} { + interp create slave + after 0 {interp recursionlimit slave 4} + set r1 [slave eval { + catch { # nesting level 1 + eval { # 2 + eval { # 3 + eval { # 4 + update + eval { # 5 + set x ok } } } @@ -2667,7 +2739,7 @@ test interp-29.3.8 {recursion limit error reporting} { list $r1 $r2 } {1 {too many nested evaluations (infinite loop?)}} -test interp-29.3.9 {recursion limit error reporting} { +test interp-29.3.9a {recursion limit error reporting} { interp create slave after 0 {interp recursionlimit slave 6} set r1 [slave eval { @@ -2676,8 +2748,30 @@ test interp-29.3.9 {recursion limit error reporting} { eval { # 3 eval { # 4 eval { # 5 - update - set x ok + update + set x ok + } + } + } + } + } msg + }] + set r2 [slave eval { set msg }] + interp delete slave + list $r1 $r2 +} {0 ok} + +test interp-29.3.9b {recursion limit error reporting} { + interp create slave + after 0 {interp recursionlimit slave 6} + set r1 [slave eval { + catch { # nesting level 1 + eval { # 2 + eval { # 3 + eval { # 4 + eval { # 5 + set set set + $set x ok } } } @@ -2689,7 +2783,7 @@ test interp-29.3.9 {recursion limit error reporting} { list $r1 $r2 } {0 ok} -test interp-29.3.10 {recursion limit error reporting} { +test interp-29.3.10a {recursion limit error reporting} { interp create slave after 0 {slave recursionlimit 4} set r1 [slave eval { @@ -2709,9 +2803,31 @@ test interp-29.3.10 {recursion limit error reporting} { set r2 [slave eval { set msg }] interp delete slave list $r1 $r2 +} {0 ok} + +test interp-29.3.10b {recursion limit error reporting} { + interp create slave + after 0 {slave recursionlimit 4} + set r1 [slave eval { + catch { # nesting level 1 + eval { # 2 + eval { # 3 + eval { # 4 + update + eval { # 5 + set x ok + } + } + } + } + } msg + }] + set r2 [slave eval { set msg }] + interp delete slave + list $r1 $r2 } {1 {too many nested evaluations (infinite loop?)}} -test interp-29.3.11 {recursion limit error reporting} { +test interp-29.3.11a {recursion limit error reporting} { interp create slave after 0 {slave recursionlimit 5} set r1 [slave eval { @@ -2720,8 +2836,31 @@ test interp-29.3.11 {recursion limit error reporting} { eval { # 3 eval { # 4 eval { # 5 - update - set x ok + update + set x ok + } + } + } + } + } msg + }] + set r2 [slave eval { set msg }] + interp delete slave + list $r1 $r2 +} {0 ok} + +test interp-29.3.11b {recursion limit error reporting} { + interp create slave + after 0 {slave recursionlimit 5} + set r1 [slave eval { + catch { # nesting level 1 + eval { # 2 + eval { # 3 + eval { # 4 + eval { # 5 + update + set set set + $set x ok } } } @@ -2733,7 +2872,7 @@ test interp-29.3.11 {recursion limit error reporting} { list $r1 $r2 } {1 {too many nested evaluations (infinite loop?)}} -test interp-29.3.12 {recursion limit error reporting} { +test interp-29.3.12a {recursion limit error reporting} { interp create slave after 0 {slave recursionlimit 6} set r1 [slave eval { @@ -2742,8 +2881,31 @@ test interp-29.3.12 {recursion limit error reporting} { eval { # 3 eval { # 4 eval { # 5 - update - set x ok + update + set x ok + } + } + } + } + } msg + }] + set r2 [slave eval { set msg }] + interp delete slave + list $r1 $r2 +} {0 ok} + +test interp-29.3.12b {recursion limit error reporting} { + interp create slave + after 0 {slave recursionlimit 6} + set r1 [slave eval { + catch { # nesting level 1 + eval { # 2 + eval { # 3 + eval { # 4 + eval { # 5 + update + set set set + $set x ok } } } diff --git a/tests/nre.test b/tests/nre.test index cc15b13..c415150 100644 --- a/tests/nre.test +++ b/tests/nre.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: nre.test,v 1.4 2008/08/22 18:27:27 dgp Exp $ +# RCS: @(#) $Id: nre.test,v 1.5 2008/09/01 12:28:10 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -236,6 +236,26 @@ test nre-7.5 {[foreach] is not recursive} -constraints {knownBug} -setup { unset abs } -result {{0 2 2 0} 0} +test nre-7.6 {[eval] is not recursive} -setup { + proc a i [makebody {eval [list a $i]}] +} -body { + setabs + a 0 +} -cleanup { + rename a {} + unset abs +} -result {{0 2 2 1} 0} + +test nre-7.7 {[eval] is not recursive} -setup { + proc a i [makebody {eval "a $i"}] +} -body { + setabs + a 0 +} -cleanup { + rename a {} + unset abs +} -result {{0 2 2 1} 0} + test nre-8.1 {nre and {*}} -body { # force an expansion that grows the evaluation stack, check that nre # adapts the bottomPtr. This crashes on failure. diff --git a/tests/unsupported.test b/tests/unsupported.test index 0267c58..37a9313 100644 --- a/tests/unsupported.test +++ b/tests/unsupported.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: unsupported.test,v 1.7 2008/08/26 22:37:05 msofer Exp $ +# RCS: @(#) $Id: unsupported.test,v 1.8 2008/09/01 12:28:10 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -618,7 +618,7 @@ test unsupported-C.1.9 {yield in nested eval} -constraints {coroutine} \ } -cleanup { rename moo {} unset body res -} -returnCodes error -result {cannot yield: C stack busy} +} -result {0 10 20} test unsupported-C.1.10 {yield in nested eval} -constraints {coroutine} \ -setup { @@ -629,7 +629,7 @@ test unsupported-C.1.10 {yield in nested eval} -constraints {coroutine} \ yield while {$i < $imax} { - eval yield + eval yield [expr {$i*$stop}] incr i } } @@ -642,7 +642,7 @@ test unsupported-C.1.10 {yield in nested eval} -constraints {coroutine} \ set res } -cleanup { unset body res -} -returnCodes error -result {cannot yield: C stack busy} +} -result {0 10 20} test unsupported-C.1.11 {yield outside coroutine} -constraints {coroutine} \ -setup { -- cgit v0.12