* generic/tclProc.c: minor improvements to [apply]

	* tests/apply.test: new tests; apply-5.1 currently fails to
	indicate missing work in error reporting

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  <msofer@users.sf.net>
+
+	* 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  <dgp@users.sourceforge.net>
 
 	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 {}}}