From a92c81902495c74fc0d450c144a03c341872ed6e Mon Sep 17 00:00:00 2001
From: griffin <brian_griffin@mentor.com>
Date: Sun, 19 Feb 2017 01:06:28 +0000
Subject: namespace qualifier support, assignment target limitations.

---
 generic/tclCompExpr.c | 50 ++++++++++++++++++++++++++++++++++----------------
 tests/expr.test       | 46 ++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 80 insertions(+), 16 deletions(-)

diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c
index cf93ba9..23cacb4 100644
--- a/generic/tclCompExpr.c
+++ b/generic/tclCompExpr.c
@@ -1327,6 +1327,20 @@ ParseExpr(
 		}
 	    }
 
+	    /* Enfocre LHS is literal, bareword, function
+	     * TODO: If function, convert to array reference
+	     */
+	    if (lexeme == ASSIGN) {
+		if (complete != OT_LITERAL &&
+		    complete != OT_TOKENS &&
+		    complete != FUNCTION) {
+
+		    TclNewLiteralStringObj(msg, "Target of assignment must be string");
+		    errCode = "SURPRISE";
+		    goto error;		    
+		}
+	    }
+
 	    /* Commas must appear only in function argument lists. */
 	    if (lexeme == COMMA) {
 		if  ((incompletePtr->lexeme != OPEN_PAREN)
@@ -1945,9 +1959,13 @@ ParseLexeme(
 	return 1;
 
     case ':':
-	if ((numBytes > 1) && (start[1] == '=')) {
-	    *lexemePtr = ASSIGN;
-	    return 2;
+	if (numBytes > 1) {
+	    if (start[1] == '=') {
+		*lexemePtr = ASSIGN;
+		return 2;
+	    } else if (start[1] == ':') {
+		break; // bareword
+	    }
 	}
 	*lexemePtr = COLON;
 	return 1;
@@ -2108,7 +2126,7 @@ ParseLexeme(
      * have no direct relevance here.
      */
 
-    if (!TclIsBareword(*start) || *start == '_') {
+    if ((!TclIsBareword(*start) && strncmp("::",start,2)) || *start == '_') {
 	if (Tcl_UtfCharComplete(start, numBytes)) {
 	    scanned = Tcl_UtfToUniChar(start, &ch);
 	} else {
@@ -2123,9 +2141,14 @@ ParseLexeme(
 	return scanned;
     }
     end = start;
-    while (numBytes && TclIsBareword(*end)) {
-	end += 1;
-	numBytes -= 1;
+    while (numBytes && (TclIsBareword(*end) || !strncmp("::",end,2))) {
+	if (*end==':') {
+	    end += 2;
+	    numBytes -= 2;
+	} else {
+	    end += 1;
+	    numBytes -= 1;
+	}
     }
     *lexemePtr = BAREWORD;
     if (literalPtr) {
@@ -2370,15 +2393,10 @@ CompileExprTree(
 		}
 		break;
 	    case ASSIGN:
-		if (convert) {
-		    /*
-		     * Make sure we assign to a variable only values that
-		     * have been numerically normalized in the expr way.
-		     */
-		    TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr);
-		    /* already converted */
-		    convert = 0;
-		}
+		/* No need to convert, value should aready be 
+		 * numeric result of expression.
+		 * A non-numeric result is probably intentional.
+		 */
 		TclEmitOpcode(INST_STORE_STK, envPtr);
 		break;
 	    case OPEN_PAREN:
diff --git a/tests/expr.test b/tests/expr.test
index 8e083c5..bccae27 100644
--- a/tests/expr.test
+++ b/tests/expr.test
@@ -7187,7 +7187,51 @@ test expr-51.1 {test round-to-even on input} {
     expr 6.9294956446009195e15
 } 6929495644600920.0
 
+# Check "expr" assignment operator
 
+test expr-52.1 {expr assignment and separator operators} {
+    set ans [expr  {
+		    t  := 10.0;
+		    x  := 2.0;
+		    dx := 0.2;
+		    f  := ($dx-$x/10);
+		    fs := {$dx-$x/10};
+		    g  := (-$x/5);
+		    center := 1.0;
+		    x  := $x-$center;
+		    dx := $dx+$g;
+		    x  := $x+$f+$center;
+		    x  := $x+$f+$center;
+		    y  := round($x)
+		}]
+    list $ans $t $x $dx $f $fs $g $center $dx $y
+} {3 10.0 3.0 -0.2 0.0 {$dx-$x/10} -0.4 1.0 -0.2 3}
+
+test expr-52.2 {expr assignment with literal names} {
+    set ans [expr  { "-8-"  := 10.0;
+		     "ary(fred)"  := 2.0;
+		     {ary(" ")}  := sqrt(17)
+		 }]
+    list $ans [set "-8-"] [set "ary(fred)"] [set {ary(" ")}]
+} {4.123105625617661 10.0 2.0 4.123105625617661}
+
+test expr-52.3 {expr assignment error} -body {
+    expr  { ary(0) := 500 }
+} -returnCodes error -result {Target of assignment must be string
+in expression " ary(0) := 500 "}
+
+test expr-52.4 {expr assignment variables with qualifiers} {
+    namespace eval n1 {}
+    set ans [expr  {
+		    ::t  := 10.0;
+		    n1::x  := 2.0;
+		    ::n1::dx := 0.2;
+		    n1::f  := ($n1::dx-$n1::x/10);
+		    fs := {$n1::dx-$n1::x/10};
+		    y := -1
+		}]
+    list $ans $::t $n1::x $::n1::dx $n1::f $fs $y
+} {-1 10.0 2.0 0.2 0.0 {$n1::dx-$n1::x/10} -1}
 
 # cleanup
 if {[info exists a]} {
@@ -7195,6 +7239,8 @@ if {[info exists a]} {
 }
 catch {unset min}
 catch {unset max}
+apply {args {foreach v $args {if {[info exists $v]} {unset $v} }}} \
+    ans t x dx f fs g center dx y "-8-" "ary(fred)" {ary(" ")}
 ::tcltest::cleanupTests
 return
 
-- 
cgit v0.12