From 7c8477dc94e07b3d0bf87a4e81902b5dd52ebd5b Mon Sep 17 00:00:00 2001 From: Miguel Sofer Date: Wed, 1 Feb 2006 20:17:27 +0000 Subject: * generic/tclProc.c: minor improvements to [apply] * tests/apply.test: new tests; apply-5.1 currently fails to indicate missing work in error reporting --- ChangeLog | 6 ++++ generic/tclProc.c | 54 +++++++++++++++---------------- tests/apply.test | 95 +++++++++++++++++++++++++++++++++++++++++++------------ 3 files changed, 107 insertions(+), 48 deletions(-) diff --git a/ChangeLog b/ChangeLog index 2c0b210..021b5a9 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2006-02-01 Miguel Sofer + + * generic/tclProc.c: minor improvements to [apply] + * tests/apply.test: new tests; apply-5.1 currently fails to + indicate missing work in error reporting + 2006-02-01 Don Porter TIP#194 IMPLEMENTATION diff --git a/generic/tclProc.c b/generic/tclProc.c index c2dab7e..438fa5e 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.85 2006/02/01 19:26:02 dgp Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.86 2006/02/01 20:17:28 msofer Exp $ */ #include "tclInt.h" @@ -1893,15 +1893,15 @@ TclCompileNoOp( * */ -static void DupLambdaInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr, - Tcl_Obj *copyPtr)); -static void FreeLambdaInternalRep _ANSI_ARGS_(( - Tcl_Obj *objPtr)); -static int SetLambdaFromAny _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr)); +static void DupLambdaInternalRep(Tcl_Obj *objPtr, + Tcl_Obj *copyPtr); +static void FreeLambdaInternalRep( + Tcl_Obj *objPtr); +static int SetLambdaFromAny(Tcl_Interp *interp, + Tcl_Obj *objPtr); Tcl_ObjType lambdaType = { - "lambda", /* name */ + "lambdaExpr", /* name */ FreeLambdaInternalRep, /* freeIntRepProc */ DupLambdaInternalRep, /* dupIntRepProc */ (Tcl_UpdateStringProc *) NULL, /* updateStringProc */ @@ -1909,7 +1909,7 @@ Tcl_ObjType lambdaType = { }; /* - * a Lambda Tcl_Obj has the form + * a lambdaType Tcl_Obj has the form * * ptr1 is a *Proc: pointer to a proc structure * ptr2 is a *Tcl_Obj: the lambda's namespace @@ -1967,11 +1967,9 @@ SetLambdaFromAny(interp, objPtr) result = Tcl_ListObjGetElements(interp, objPtr, &objc, &objv); if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) { errPtr = Tcl_NewStringObj("can't interpret \"",-1); - Tcl_IncrRefCount(errPtr); Tcl_AppendObjToObj(errPtr, objPtr); Tcl_AppendToObj(errPtr, "\" as a lambda expression", -1); Tcl_SetObjResult(interp, errPtr); - Tcl_DecrRefCount(errPtr); return TCL_ERROR; } @@ -1987,9 +1985,9 @@ SetLambdaFromAny(interp, objPtr) if (TclCreateProc(interp, /*ignored nsPtr*/ NULL, name, argsPtr, bodyPtr, &procPtr) != TCL_OK) { - Tcl_AddErrorInfo(interp, "\n (parsing lambda expression \""); - Tcl_AddErrorInfo(interp, name); - Tcl_AddErrorInfo(interp, "\")"); + TclFormatToErrorInfo(interp, + "\n (parsing lambda expression \"%s\")", + Tcl_GetString(objPtr), NULL); return TCL_ERROR; } procPtr->refCount++; @@ -2000,14 +1998,20 @@ SetLambdaFromAny(interp, objPtr) * as a global reference, or else global per default. */ - nsObjPtr = Tcl_NewStringObj("::", 2); - Tcl_IncrRefCount(nsObjPtr); - - if (objc == 3) { - Tcl_AppendObjToObj(nsObjPtr, objv[2]); + if (objc == 2) { + nsObjPtr = Tcl_NewStringObj("::", 2); + } else { + char *nsName = Tcl_GetString(objv[2]); + if ((*nsName != ':') || (*(nsName+1) != ':')) { + nsObjPtr = Tcl_NewStringObj("::", 2); + Tcl_AppendObjToObj(nsObjPtr, objv[2]); + } else { + nsObjPtr = objv[2]; + } } - - + + Tcl_IncrRefCount(nsObjPtr); + /* * Free the list internalrep of objPtr - this will free argsPtr, but * bodyPtr retains a reference from the Proc structure. Then finish @@ -2088,19 +2092,15 @@ Tcl_ApplyObjCmd(dummy, interp, objc, objv) if (result != TCL_OK) { return result; } + if (nsPtr == (Tcl_Namespace *) NULL) { errPtr = Tcl_NewStringObj("cannot find namespace \"",-1); - Tcl_IncrRefCount(errPtr); Tcl_AppendObjToObj(errPtr, nsObjPtr); Tcl_AppendToObj(errPtr, "\"", -1); Tcl_SetObjResult(interp, errPtr); - Tcl_DecrRefCount(errPtr); return TCL_ERROR; } - - /* - cmd = *((Command *) Tcl_GetCommandFromObj(interp, objv[0])); - */ + cmd.nsPtr = (Namespace *) nsPtr; return ObjInterpProcEx((ClientData) procPtr, interp, objc, objv, 2); diff --git a/tests/apply.test b/tests/apply.test index c000c6e..9218847 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.1 2006/02/01 19:26:02 dgp Exp $ +# RCS: @(#) $Id: apply.test,v 1.2 2006/02/01 20:17:28 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -87,7 +87,7 @@ test apply-3.1 {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"}} +} {1 {cannot find namespace "::NONEXIST::FOR::SURE"}} test apply-3.2 {non-existing namespace} { namespace eval ::NONEXIST::FOR::SURE {} @@ -96,7 +96,22 @@ test apply-3.2 {non-existing namespace} { namespace delete ::NONEXIST set res [catch {apply $lambda x} msg] list $res $msg -} {1 {cannot find namespace "::::NONEXIST::FOR::SURE"}} +} {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.2 {non-existing namespace} { + namespace eval ::NONEXIST::FOR::SURE {} + set lambda [list x {set x 1} NONEXIST::FOR::SURE] + apply $lambda x + namespace delete ::NONEXIST + set res [catch {apply $lambda x} msg] + list $res $msg +} {1 {cannot find namespace "::NONEXIST::FOR::SURE"}} test apply-4.1 {error in arguments to lambda expression} { set lambda [list x {set x 1}] @@ -110,21 +125,32 @@ test apply-4.2 {error in arguments to lambda expression} { list $res $msg } {1 {wrong # args: should be "apply {x {set x 1}} x"}} +test apply-5.1 {runtime error in lambda expression} { + set lambda [list {} {error foo}] + set res [catch {apply $lambda}] + list $res $errorInfo +} {1 {foo + while executing +"error foo" + (procedure "apply" line 1) CHECK & MODIFY + invoked from within +"apply $lambda"}} + # Tests for correct execution; as the implementation is the same as that for # procs, the general functionality is mostly tested elsewhere -test apply-5.1 {info level} { +test apply-6.1 {info level} { set lev [info level] set lambda [list {} {info level}] expr {[apply $lambda] - $lev} } 1 -test apply-5.2 {info level} { +test apply-6.2 {info level} { set lambda [list {} {info level 0}] apply $lambda } {apply {{} {info level 0}}} -test apply-5.3 {info level} { +test apply-6.3 {info level} { set lambda [list args {info level 0}] apply $lambda x y } {apply {args {info level 0}} x y} @@ -132,30 +158,57 @@ test apply-5.3 {info level} { # Tests for correct namespace scope namespace eval ::testApply { - set x 0 proc testApply args {return testApply} } -test apply-6.1 {namespace access} { +test apply-7.1 {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-6.2 {namespace access} { +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-6.3 {namespace access} { +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-6.3 {namespace access} { +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 @@ -168,43 +221,43 @@ set applyBody { set res } -test apply-7.1 {args treatment} { +test apply-8.1 {args treatment} { apply [list args $applyBody] 1 2 3 } {{args {1 2 3}}} -test apply-7.2 {args treatment} { +test apply-8.2 {args treatment} { apply [list {x args} $applyBody] 1 2 } {{x 1} {args 2}} -test apply-7.3 {args treatment} { +test apply-8.3 {args treatment} { apply [list {x args} $applyBody] 1 2 3 } {{x 1} {args {2 3}}} -test apply-7.4 {default values} { +test apply-8.4 {default values} { apply [list {{x 1} {y 2}} $applyBody] } {{x 1} {y 2}} -test apply-7.5 {default values} { +test apply-8.5 {default values} { apply [list {{x 1} {y 2}} $applyBody] 3 4 } {{x 3} {y 4}} -test apply-7.6 {default values} { +test apply-8.6 {default values} { apply [list {{x 1} {y 2}} $applyBody] 3 } {{x 3} {y 2}} -test apply-7.7 {default values} { +test apply-8.7 {default values} { apply [list {x {y 2}} $applyBody] 1 } {{x 1} {y 2}} -test apply-7.8 {default values} { +test apply-8.8 {default values} { apply [list {x {y 2}} $applyBody] 1 3 } {{x 1} {y 3}} -test apply-7.9 {default values} { +test apply-8.9 {default values} { apply [list {x {y 2} args} $applyBody] 1 } {{x 1} {y 2} {args {}}} -test apply-7.10 {default values} { +test apply-8.10 {default values} { apply [list {x {y 2} args} $applyBody] 1 3 } {{x 1} {y 3} {args {}}} -- cgit v0.12