diff options
-rw-r--r-- | generic/tclCompExpr.c | 129 | ||||
-rw-r--r-- | generic/tclInt.h | 2 | ||||
-rw-r--r-- | generic/tclParse.c | 76 | ||||
-rw-r--r-- | tests/expr.test | 75 |
4 files changed, 257 insertions, 25 deletions
diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index d5cb11a..7074253 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -734,20 +734,58 @@ ParseExpr( if (start[scanned+TclParseAllWhiteSpace( start+scanned, numBytes-scanned)] == '(') { - lexeme = FUNCTION; - /* - * When we compile the expression we'll need the function - * name, and there's no place in the parse tree to store - * it, so we keep a separate list of all the function - * names we've parsed in the order we found them. + /* Look ahead for assignment operator */ + + /* + * TODO: this can probably be simplified. + * For now, it is working. */ - Tcl_ListObjAppendElement(NULL, funcList, literal); + Tcl_Parse vparse; + const char *varend, *varstart = &start[TclParseAllWhiteSpace(start, numBytes)]; + int code, len; + TclParseInit(interp, varstart, numBytes, &vparse); + code = Tcl_ParseVarName(NULL, varstart, numBytes, &vparse, 0); + if (code != TCL_OK) { + //fprintf(stderr, "Replace me with proper error!\n"); + } + len = vparse.tokenPtr[0].size; + varend = varstart+len; + Tcl_FreeParse(&vparse); + + /* Look ahead for Assignment operator ':=' */ + if (code == TCL_OK && + varend[TclParseAllWhiteSpace(varend,numBytes-len)] == ':' && + varend[TclParseAllWhiteSpace(varend,numBytes-len)+1] == '=') { + + lexeme = VARNAME; + + /* Adjust scanned bytes */ + scanned = varend-start; + + /* The variable name is tokenized below as a quoted string */ + + } else { + + lexeme = FUNCTION; + + /* + * When we compile the expression we'll need the function + * name, and there's no place in the parse tree to store + * it, so we keep a separate list of all the function + * names we've parsed in the order we found them. + */ + + Tcl_ListObjAppendElement(NULL, funcList, literal); + } + } else if (start[scanned+TclParseAllWhiteSpace( start+scanned, numBytes-scanned)] == ':' && start[scanned+TclParseAllWhiteSpace( start+scanned, numBytes-scanned)+1] == '=') { + + /* Simple bareword */ lexeme = VARNAME; /* The variable name is stored as an OT_LITERAL below */ @@ -862,7 +900,6 @@ ParseExpr( switch (lexeme) { case NUMBER: case BOOLEAN: - case VARNAME: /* * TODO: Consider using a dict or hash to collapse all * duplicate literals into a single representative value. @@ -886,6 +923,21 @@ ParseExpr( numBytes -= scanned; continue; + case VARNAME: { + int length; + TclGetStringFromObj(literal, &length); + if (length < scanned) { + // Go tokenize the literal... + break; + } else { + Tcl_ListObjAppendElement(NULL, litList, literal); + complete = lastParsed = OT_LITERAL; + start += scanned; + numBytes -= scanned; + continue; + } + } /* VARNAME case */ + default: break; } @@ -932,6 +984,13 @@ ParseExpr( scanned = tokenPtr->size; break; + case VARNAME: + code = TclParseTokens(NULL, start, scanned, TCL_SUBST_ALL, 1, + parsePtr); + + // scanned already adjusted... + break; + case SCRIPT: { Tcl_Parse *nestedPtr = TclStackAlloc(interp, sizeof(Tcl_Parse)); @@ -1327,6 +1386,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) @@ -1614,7 +1687,9 @@ DumpExprTreeIndent( {1,"+"},{2,"-"},{3,"bareword"},{4,"incompatible"},{5,"invalid"}, {0xc1,"number"},{0xc2,"[command]"},{0xc3,"boolean"},{0xc4,"{string}"},{0xc5,"$var"},{0xc6,"\"string\""},{0xc7,"()"}, {0x81,"+"},{0x82,"-"},{0x83,"function"},{0x84,"start"},{0x85,"("},{0x86,"!"},{0x87,"~"}, - {0x41,"+"},{0x42,"-"},{0x43,","},{0x4c,"?"},{0x4d,":"}, + {0x41,"+"},{0x42,"-"},{0x43,","},{0x44,"*"},{0x45,"/"},{0x46,"%"},{0x47,","},{0x48,">"}, + {0x49,"&"},{0x4a,"^"},{0x4b,"|"}, + {0x4c,"?"},{0x4d,":"}, {0x5B,")"},{0x5c,"end"},{0x5d,";"},{0x5e,":="} }; static int lexdone=0; @@ -2224,9 +2299,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; @@ -2387,7 +2466,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 { @@ -2402,9 +2481,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) { @@ -2649,15 +2733,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/generic/tclInt.h b/generic/tclInt.h index 4b4f1f3..327ad3b 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3054,6 +3054,8 @@ MODULE_SCOPE int TclParseNumber(Tcl_Interp *interp, Tcl_Obj *objPtr, MODULE_SCOPE void TclParseInit(Tcl_Interp *interp, const char *string, int numBytes, Tcl_Parse *parsePtr); MODULE_SCOPE int TclParseAllWhiteSpace(const char *src, int numBytes); +MODULE_SCOPE int TclParseTokens(Tcl_Interp *interp, const char *bytes, + int numBytes, int flags, int append, Tcl_Parse *parsePtr); MODULE_SCOPE int TclProcessReturn(Tcl_Interp *interp, int code, int level, Tcl_Obj *returnOpts); MODULE_SCOPE int TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); diff --git a/generic/tclParse.c b/generic/tclParse.c index 3a04df4..71f51b6 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -2502,6 +2502,82 @@ TclObjCommandComplete( } /* + *---------------------------------------------------------------------- + * + * TclParseTokens -- + * + * Token parser used by ParseExpr. Parses the string made up of + * 'numBytes' bytes starting at 'bytes'. Parsing is controlled by the + * flags argument to limit which substitutions to apply, as + * represented by the flag values TCL_SUBST_BACKSLASHES, + * TCL_SUBST_COMMANDS, TCL_SUBST_VARIABLES. + * + * Results: + * Tokens are added to parsePtr and parsePtr->term is filled in with the + * address of the character that terminated the parse (the character at + * parsePtr->end). The return value is TCL_OK if the parse completed + * successfully and TCL_ERROR otherwise. If a parse error occurs and + * parsePtr->interp is not NULL, then an error message is left in the + * interpreter's result. + * + * Side effects: + * The Tcl_Parse struct '*parsePtr' is filled with parse results. + * The caller is expected to eventually call Tcl_FreeParse() to properly + * cleanup the value written there. + * + * If a parse error occurs, the Tcl_InterpState value '*statePtr' is + * filled with the state created by that error. When *statePtr is written + * to, the caller is expected to make the required calls to either + * Tcl_RestoreInterpState() or Tcl_DiscardInterpState() to dispose of the + * value written there. + * + *---------------------------------------------------------------------- + */ + +int +TclParseTokens( + Tcl_Interp *interp, + const char *bytes, + int numBytes, + int flags, + int append, + Tcl_Parse *parsePtr) +{ + int length = numBytes; + const char *p = bytes; + int code, offset, i; + int startToken; + + if (!append) { + TclParseInit(interp, p, length, parsePtr); + } + + startToken = parsePtr->numTokens; + + /* + * First parse the string rep of objPtr, as if it were enclosed as a + * "-quoted word in a normal Tcl command. Honor flags that selectively + * inhibit types of substitution. + */ + + code = ParseTokens(p, length, /* mask */ 0, flags, parsePtr); + /* Truncate last token to length */ + /* Hack? Why does ParseTokens not stop at numBytes? */ + for (i=startToken; i<parsePtr->numTokens; i++) { + offset = parsePtr->tokenPtr[i].start - p + parsePtr->tokenPtr[i].size; + if (offset >= length) break; + } + if (offset > length) { + parsePtr->tokenPtr[i].size = length - (parsePtr->tokenPtr[i].start - p); + /* Truncate tokens */ + if (i < parsePtr->numTokens) + parsePtr->numTokens = i + 1; + } + return code; +} + + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/tests/expr.test b/tests/expr.test index 8e083c5..aee8096 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -7187,7 +7187,80 @@ 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} { + array unset ary + 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} + +# Not anymore +#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} + + +test expr-52.5 {expr assignment array variables} { + array unset ary + set ans [expr { + i:=1; + jkl := 2; + ary($i) :=$i*$jkl; + ary( $jkl ):= double(int(sqrt($jkl) * 1000))/1000.0; + bsg(oh):= round($ary( $jkl ) * $ary( $jkl )) + }] + list $ans $i $jkl [array get ary] [array get bsg] +} {2 1 2 {1 2 { 2 } 1.414} {oh 2}} + +test expr-52.6 {expr assignment odd cases} { + set ans1 [expr { sin( 0 + [puts foobar; # will it be an array access? + string cat 0]) := sin( 0 + [puts foobar; # or will it be a function call? + string cat 0]) }] + set arr(\ \}\ ) hello + set ans2 [expr { arr( { ) := $arr( } ) }] + set ans3 [catch {expr { arr( { ) + $arr( } ) }} err] + set l1 [list $ans1 [array get sin]] + set l2 [list $ans2 [array get arr]] + set l3 [list $ans3 $err] + list $l1 $l2 $l3 + +} {{0.0 {{ 0 + 0} 0.0}} {hello {\ \}\ hello \ \{\ hello}} {1 {invalid command name "tcl::mathfunc::arr"}}} # cleanup if {[info exists a]} { @@ -7195,6 +7268,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 |