Tcl Source Code

Check-in [d64c1ea4de]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:namespace qualifier support, assignment target limitations.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | bg-tip-282
Files: files | file ages | folders
SHA1: d64c1ea4de1b76c503d5ef2876a288db89cdae7b
User & Date: griffin 2017-02-19 01:06:28
Original User & Date: briang42 2017-02-19 01:06:28
Context
2017-02-22
00:39
Add support for arrays in assignment Lvalues check-in: ceec540b41 user: griffin tags: bg-tip-282
2017-02-19
01:06
namespace qualifier support, assignment target limitations. check-in: d64c1ea4de user: griffin tags: bg-tip-282
2017-02-17
10:51
Prevents dual convert "tryCvtToNumeric" (once before assignment should be enough); check-in: 41f67f9169 user: sebres tags: bg-tip-282
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclCompExpr.c.

1322
1323
1324
1325
1326
1327
1328














1329
1330
1331
1332
1333
1334
1335
....
1941
1942
1943
1944
1945
1946
1947

1948
1949
1950



1951
1952
1953
1954
1955
1956
1957
....
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
....
2119
2120
2121
2122
2123
2124
2125
2126




2127
2128

2129
2130
2131
2132
2133
2134
2135
....
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
	    if (lexeme == CLOSE_PAREN) {
		if (incompletePtr->lexeme != OPEN_PAREN) {
		    TclNewLiteralStringObj(msg, "unbalanced close paren");
		    errCode = "UNBALANCED";
		    goto error;
		}
	    }















	    /* Commas must appear only in function argument lists. */
	    if (lexeme == COMMA) {
		if  ((incompletePtr->lexeme != OPEN_PAREN)
			|| (incompletePtr[-1].lexeme != FUNCTION)) {
		    TclNewLiteralStringObj(msg,
			    "unexpected \",\" outside function argument list");
................................................................................
	    *lexemePtr = EXPON;
	    return 2;
	}
	*lexemePtr = MULT;
	return 1;

    case ':':

	if ((numBytes > 1) && (start[1] == '=')) {
	    *lexemePtr = ASSIGN;
	    return 2;



	}
	*lexemePtr = COLON;
	return 1;

	
    case '=':
	if ((numBytes > 1) && (start[1] == '=')) {
................................................................................

    /*
     * We reject leading underscores in bareword.  No sensible reason why.
     * Might be inspired by reserved identifier rules in C, which of course
     * have no direct relevance here.
     */

    if (!TclIsBareword(*start) || *start == '_') {
	if (Tcl_UtfCharComplete(start, numBytes)) {
	    scanned = Tcl_UtfToUniChar(start, &ch);
	} else {
	    char utfBytes[TCL_UTF_MAX];

	    memcpy(utfBytes, start, (size_t) numBytes);
	    utfBytes[numBytes] = '\0';
................................................................................
	    scanned = Tcl_UtfToUniChar(utfBytes, &ch);
	}
	*lexemePtr = INVALID;
	Tcl_DecrRefCount(literal);
	return scanned;
    }
    end = start;
    while (numBytes && TclIsBareword(*end)) {




	end += 1;
	numBytes -= 1;

    }
    *lexemePtr = BAREWORD;
    if (literalPtr) {
	Tcl_SetStringObj(literal, start, (int) (end-start));
	*literalPtr = literal;
    } else {
	Tcl_DecrRefCount(literal);
................................................................................
	    case START:
	    case QUESTION:
		if (convert && (nodePtr == rootPtr)) {
		    TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr);
		}
		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;
		}
		TclEmitOpcode(INST_STORE_STK, envPtr);
		break;
	    case OPEN_PAREN:
	    case SEPARATOR:

		/* do nothing */
		break;






>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>
|
|
|
>
>
>







 







|







 







|
>
>
>
>
|
|
>







 







|
|
|
<
|
<
<
<
<







1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
....
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
....
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
....
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
....
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398

2399




2400
2401
2402
2403
2404
2405
2406
	    if (lexeme == CLOSE_PAREN) {
		if (incompletePtr->lexeme != OPEN_PAREN) {
		    TclNewLiteralStringObj(msg, "unbalanced close paren");
		    errCode = "UNBALANCED";
		    goto error;
		}
	    }

	    /* 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)
			|| (incompletePtr[-1].lexeme != FUNCTION)) {
		    TclNewLiteralStringObj(msg,
			    "unexpected \",\" outside function argument list");
................................................................................
	    *lexemePtr = EXPON;
	    return 2;
	}
	*lexemePtr = MULT;
	return 1;

    case ':':
	if (numBytes > 1) {
	    if (start[1] == '=') {
		*lexemePtr = ASSIGN;
		return 2;
	    } else if (start[1] == ':') {
		break; // bareword
	    }
	}
	*lexemePtr = COLON;
	return 1;

	
    case '=':
	if ((numBytes > 1) && (start[1] == '=')) {
................................................................................

    /*
     * We reject leading underscores in bareword.  No sensible reason why.
     * Might be inspired by reserved identifier rules in C, which of course
     * have no direct relevance here.
     */

    if ((!TclIsBareword(*start) && strncmp("::",start,2)) || *start == '_') {
	if (Tcl_UtfCharComplete(start, numBytes)) {
	    scanned = Tcl_UtfToUniChar(start, &ch);
	} else {
	    char utfBytes[TCL_UTF_MAX];

	    memcpy(utfBytes, start, (size_t) numBytes);
	    utfBytes[numBytes] = '\0';
................................................................................
	    scanned = Tcl_UtfToUniChar(utfBytes, &ch);
	}
	*lexemePtr = INVALID;
	Tcl_DecrRefCount(literal);
	return scanned;
    }
    end = start;
    while (numBytes && (TclIsBareword(*end) || !strncmp("::",end,2))) {
	if (*end==':') {
	    end += 2;
	    numBytes -= 2;
	} else {
	    end += 1;
	    numBytes -= 1;
	}
    }
    *lexemePtr = BAREWORD;
    if (literalPtr) {
	Tcl_SetStringObj(literal, start, (int) (end-start));
	*literalPtr = literal;
    } else {
	Tcl_DecrRefCount(literal);
................................................................................
	    case START:
	    case QUESTION:
		if (convert && (nodePtr == rootPtr)) {
		    TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr);
		}
		break;
	    case ASSIGN:
		/* 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:
	    case SEPARATOR:

		/* do nothing */
		break;

Changes to tests/expr.test.

7183
7184
7185
7186
7187
7188
7189

7190











































7191
7192
7193
7194
7195
7196
7197


7198
7199
7200
7201
7202
7203
    expr {sqrt("1[string repeat 0 616]") == 1e308}
} 1

test expr-51.1 {test round-to-even on input} {
    expr 6.9294956446009195e15
} 6929495644600920.0















































# cleanup
if {[info exists a]} {
    unset a
}
catch {unset min}
catch {unset max}


::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:






>

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







>
>






7183
7184
7185
7186
7187
7188
7189
7190
7191
7192
7193
7194
7195
7196
7197
7198
7199
7200
7201
7202
7203
7204
7205
7206
7207
7208
7209
7210
7211
7212
7213
7214
7215
7216
7217
7218
7219
7220
7221
7222
7223
7224
7225
7226
7227
7228
7229
7230
7231
7232
7233
7234
7235
7236
7237
7238
7239
7240
7241
7242
7243
7244
7245
7246
7247
7248
7249
    expr {sqrt("1[string repeat 0 616]") == 1e308}
} 1

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]} {
    unset 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

# Local Variables:
# mode: tcl
# End: