Attachment "tip201-3.patch" to
ticket [1031507fff]
added by
rmax
2004-09-21 14:52:56.
Index: generic/tclCompExpr.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCompExpr.c,v
retrieving revision 1.22
diff -u -r1.22 tclCompExpr.c
--- generic/tclCompExpr.c 6 Apr 2004 22:25:50 -0000 1.22
+++ generic/tclCompExpr.c 21 Sep 2004 07:42:59 -0000
@@ -91,6 +91,8 @@
#define OP_STREQ 21
#define OP_STRNEQ 22
#define OP_EXPON 23
+#define OP_IN 24
+#define OP_NOT_IN 25
/*
* Table describing the expression operators. Entries in this table must
@@ -134,6 +136,8 @@
{"eq", 2, INST_STR_EQ},
{"ne", 2, INST_STR_NEQ},
{"**", 2, INST_EXPON},
+ {"in", 2, INST_LIST_IN},
+ {"ni", 2, INST_LIST_NOT_IN},
{NULL}
};
Index: generic/tclCompile.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCompile.h,v
retrieving revision 1.47
diff -u -r1.47 tclCompile.h
--- generic/tclCompile.h 3 Jul 2004 02:03:36 -0000 1.47
+++ generic/tclCompile.h 21 Sep 2004 07:42:59 -0000
@@ -544,8 +544,12 @@
#define INST_START_CMD 105
+/* TIP #201 - expr 'in', and 'ni' operators */
+#define INST_LIST_IN 106
+#define INST_LIST_NOT_IN 107
+
/* The last opcode */
-#define LAST_INST_OPCODE 105
+#define LAST_INST_OPCODE 107
/*
* Table describing the Tcl bytecode instructions: their name (for
Index: generic/tclExecute.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclExecute.c,v
retrieving revision 1.149
diff -u -r1.149 tclExecute.c
--- generic/tclExecute.c 18 Sep 2004 19:24:53 -0000 1.149
+++ generic/tclExecute.c 21 Sep 2004 07:43:00 -0000
@@ -2970,6 +2970,76 @@
* ---------------------------------------------------------
*/
+ case INST_LIST_IN:
+ case INST_LIST_NOT_IN:
+ {
+ /*
+ *
+ */
+
+ int iResult;
+ Tcl_Obj *valuePtr, *value2Ptr;
+ char *s1, *s2;
+ int s1len, s2len, llen, i;
+ Tcl_Obj *o;
+
+ value2Ptr = *tosPtr;
+ valuePtr = *(tosPtr - 1);
+
+ s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
+ result = Tcl_ListObjLength(interp, value2Ptr, &llen);
+ if (result != TCL_OK) {
+ goto checkForCatch;
+ }
+ iResult = 0;
+ if (llen > 0) {
+ /* An empty list doesn't match anything */
+ i = 0;
+ do {
+ result = Tcl_ListObjIndex(interp, value2Ptr, i, &o);
+ if (result != TCL_OK) {
+ goto checkForCatch;
+ }
+ if (o != NULL) {
+ s2 = Tcl_GetStringFromObj(o, &s2len);
+ } else {
+ s2 = "";
+ }
+ if (s1len == s2len) {
+ iResult = (strcmp(s1, s2) == 0);
+ }
+ i++;
+ } while (i < llen && iResult == 0);
+ }
+
+ if (*pc == INST_LIST_NOT_IN) {
+ iResult = !iResult;
+ }
+
+ TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));
+
+ /*
+ * Peep-hole optimisation: if you're about to jump, do jump
+ * from here.
+ */
+
+ pc++;
+#ifndef TCL_COMPILE_DEBUG
+ switch (*pc) {
+ case INST_JUMP_FALSE1:
+ NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0);
+ case INST_JUMP_TRUE1:
+ NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
+ case INST_JUMP_FALSE4:
+ NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
+ case INST_JUMP_TRUE4:
+ NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
+ }
+#endif
+ objResultPtr = Tcl_NewIntObj(iResult);
+ NEXT_INST_F(0, 2, 1);
+ }
+
case INST_STR_EQ:
case INST_STR_NEQ:
{
@@ -2988,6 +3058,7 @@
* we don't really have to think hard about equality.
*/
iResult = (*pc == INST_STR_EQ);
+
} else {
char *s1, *s2;
int s1len, s2len;
Index: generic/tclParseExpr.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclParseExpr.c,v
retrieving revision 1.21
diff -u -r1.21 tclParseExpr.c
--- generic/tclParseExpr.c 6 Apr 2004 22:25:54 -0000 1.21
+++ generic/tclParseExpr.c 21 Sep 2004 07:43:00 -0000
@@ -134,6 +134,12 @@
#define EXPON 36
/*
+ * 'in' operator
+ */
+#define LISTIN 37
+#define LISTNI 38
+
+/*
* Mapping from lexemes to strings; used for debugging messages. These
* entries must match the order and number of the lexeme definitions above.
*/
@@ -144,7 +150,7 @@
"*", "/", "%", "+", "-",
"<<", ">>", "<", ">", "<=", ">=", "==", "!=",
"&", "^", "|", "&&", "||", "?", ":",
- "!", "~", "eq", "ne", "**"
+ "!", "~", "eq", "ne", "**", "in", "ni"
};
/*
@@ -169,6 +175,7 @@
static int ParseRelationalExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int ParseShiftExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int ParseExponentialExpr _ANSI_ARGS_((ParseInfo *infoPtr));
+static int ParseInExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int ParseUnaryExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static void PrependSubExprTokens _ANSI_ARGS_((CONST char *op,
int opBytes, CONST char *src, int srcBytes,
@@ -1031,7 +1038,7 @@
* ParseExponentialExpr --
*
* This procedure parses a Tcl exponential expression:
- * exponentialExpr ::= unaryExpr {'**' unaryExpr}
+ * exponentialExpr ::= inExpr {'**' inExpr}
*
* Results:
* The return value is TCL_OK on a successful parse and TCL_ERROR
@@ -1059,7 +1066,7 @@
srcStart = infoPtr->start;
firstIndex = parsePtr->numTokens;
- code = ParseUnaryExpr(infoPtr);
+ code = ParseInExpr(infoPtr);
if (code != TCL_OK) {
return code;
}
@@ -1091,6 +1098,68 @@
/*
*----------------------------------------------------------------------
*
+ * ParseInExpr --
+ *
+ * This procedure parses a Tcl in expression:
+ * inExpr ::= unaryExpr 'in' unaryExpr | unaryExpr
+ *
+ * Results:
+ * The return value is TCL_OK on a successful parse and TCL_ERROR
+ * on failure. If TCL_ERROR is returned, then the interpreter's result
+ * contains an error message.
+ *
+ * Side effects:
+ * If there is insufficient space in parsePtr to hold all the
+ * information about the subexpression, then additional space is
+ * malloc-ed.
+ *
+ *----------------------------------------------------------------------
+ */
+static int
+ParseInExpr(infoPtr)
+ ParseInfo *infoPtr; /* Holds the parse state for the
+ * expression being parsed. */
+{
+ Tcl_Parse *parsePtr = infoPtr->parsePtr;
+ int firstIndex, lexeme, code;
+ CONST char *srcStart, *operator;
+
+ HERE("inExpr", 13);
+ srcStart = infoPtr->start;
+ firstIndex = parsePtr->numTokens;
+
+ code = ParseUnaryExpr(infoPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+
+ lexeme = infoPtr->lexeme;
+ while (lexeme == LISTIN || lexeme == LISTNI) {
+ operator = infoPtr->start;
+ code = GetLexeme(infoPtr); /* skip over the operator */
+ if (code != TCL_OK) {
+ return code;
+ }
+ code = ParseUnaryExpr(infoPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+
+ /*
+ * Generate tokens for the subexpression and 'in' operator.
+ */
+
+ PrependSubExprTokens(operator, 2, srcStart,
+ (infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
+ lexeme = infoPtr->lexeme;
+ }
+ return TCL_OK;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
* ParseUnaryExpr --
*
* This procedure parses a Tcl unary expression:
@@ -1118,7 +1187,7 @@
int firstIndex, lexeme, code;
CONST char *srcStart, *operator;
- HERE("unaryExpr", 13);
+ HERE("unaryExpr", 14);
srcStart = infoPtr->start;
firstIndex = parsePtr->numTokens;
@@ -1188,7 +1257,7 @@
* We simply recurse on parenthesized subexpressions.
*/
- HERE("primaryExpr", 14);
+ HERE("primaryExpr", 15);
lexeme = infoPtr->lexeme;
if (lexeme == OPEN_PAREN) {
code = GetLexeme(infoPtr); /* skip over the '(' */
@@ -1855,30 +1924,7 @@
infoPtr->lexeme = BIT_NOT;
return TCL_OK;
- case 'e':
- if ((src[1] == 'q') && ((infoPtr->lastChar - src) > 1)) {
- infoPtr->lexeme = STREQ;
- infoPtr->size = 2;
- infoPtr->next = src+2;
- parsePtr->term = infoPtr->next;
- return TCL_OK;
- } else {
- goto checkFuncName;
- }
-
- case 'n':
- if ((src[1] == 'e') && ((infoPtr->lastChar - src) > 1)) {
- infoPtr->lexeme = STRNEQ;
- infoPtr->size = 2;
- infoPtr->next = src+2;
- parsePtr->term = infoPtr->next;
- return TCL_OK;
- } else {
- goto checkFuncName;
- }
-
default:
- checkFuncName:
length = (infoPtr->lastChar - src);
if (Tcl_UtfCharComplete(src, length)) {
offset = Tcl_UtfToUniChar(src, &ch);
@@ -1891,7 +1937,7 @@
c = UCHAR(ch);
if (isalpha(UCHAR(c))) { /* INTL: ISO only. */
infoPtr->lexeme = FUNC_NAME;
- while (isalnum(UCHAR(c)) || (c == '_')) { /* INTL: ISO only. */
+ while (isalpha(UCHAR(c))) { /* INTL: ISO only. */
src += offset; length -= offset;
if (Tcl_UtfCharComplete(src, length)) {
offset = Tcl_UtfToUniChar(src, &ch);
@@ -1907,7 +1953,8 @@
infoPtr->next = src;
parsePtr->term = infoPtr->next;
/*
- * Check for boolean literals (true, false, yes, no, on, off)
+ * Check for boolean literals (true, false, yes, no, on, off),
+ * and alphabetic operators (eq, ne, in, ni).
*/
switch (infoPtr->start[0]) {
case 'f':
@@ -1917,12 +1964,32 @@
return TCL_OK;
}
break;
- case 'n':
+ case 'e':
if (infoPtr->size == 2 &&
- strncmp("no", infoPtr->start, 2) == 0) {
- infoPtr->lexeme = LITERAL;
+ strncmp("eq", infoPtr->start, 2) == 0) {
+ infoPtr->lexeme = STREQ;
+ return TCL_OK;
+ }
+ case 'i':
+ if (infoPtr->size == 2 &&
+ strncmp("in", infoPtr->start, 2) == 0) {
+ infoPtr->lexeme = LISTIN;
return TCL_OK;
}
+ case 'n':
+ if (infoPtr->size == 2) {
+ switch (infoPtr->start[1]) {
+ case 'e': /* 'ne' */
+ infoPtr->lexeme = STRNEQ;
+ return TCL_OK;
+ case 'i': /* 'ni' */
+ infoPtr->lexeme = LISTNI;
+ return TCL_OK;
+ case 'o': /* 'no' */
+ infoPtr->lexeme = LITERAL;
+ return TCL_OK;
+ }
+ }
break;
case 'o':
if (infoPtr->size == 3 &&
@@ -1950,6 +2017,21 @@
}
break;
}
+ while (isalnum(UCHAR(c)) || (c == '_')) { /* INTL: ISO only. */
+ src += offset; length -= offset;
+ if (Tcl_UtfCharComplete(src, length)) {
+ offset = Tcl_UtfToUniChar(src, &ch);
+ } else {
+ char utfBytes[TCL_UTF_MAX];
+ memcpy(utfBytes, src, (size_t) length);
+ utfBytes[length] = '\0';
+ offset = Tcl_UtfToUniChar(utfBytes, &ch);
+ }
+ c = UCHAR(ch);
+ }
+ infoPtr->size = (src - infoPtr->start);
+ infoPtr->next = src;
+ parsePtr->term = infoPtr->next;
return TCL_OK;
}
infoPtr->lexeme = UNKNOWN_CHAR;
Index: tests/expr.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/expr.test,v
retrieving revision 1.25
diff -u -r1.25 expr.test
--- tests/expr.test 19 Sep 2004 15:03:48 -0000 1.25
+++ tests/expr.test 21 Sep 2004 07:43:00 -0000
@@ -871,6 +871,161 @@
test expr-24.8 {expr edge cases; shifting} {expr wide(10)<<63} 0
test expr-24.9 {expr edge cases; shifting} {expr 5>>32} 0
+# Tests for the 'in' operator
+test expr-24.1 {'in' operator: first element matches} {
+ expr {"a" in "a b c"}
+} [expr {[lsearch -exact "a b c" a] >=0}]
+
+test expr-24.2 {'in' operator: inner element matches} {
+ expr {"a" in "b a c"}
+} [expr {[lsearch -exact "b a c" a] >= 0}]
+
+test expr-24.3 {'in' operator: last elemet matches} {
+ expr {"a" in "c b a"}
+} [expr {[lsearch -exact "c b a" a] >= 0}]
+
+test expr-24.4 {'in' operator: empty list} {
+ expr {"a" in ""}
+} [expr {[lsearch -exact "" a] >= 0}]
+
+test expr-24.5 {'in' operator: empty string - match} {
+ expr {"" in {a b c ""}}
+} [expr {[lsearch -exact {a b c ""} ""] >= 0}]
+
+test expr-24.6 {'in' operator: empty syting - no match} {
+ expr {"" in "a b c"}
+} [expr {[lsearch -exact "a b c" ""] >= 0}]
+
+test expr-24.7 {'in' operator: both empty} {
+ expr {"" in ""}
+} [expr {[lsearch -exact "" ""] >= 0}]
+
+test expr-24.8 {'in' operator: variables - match} {
+ set a a
+ set b [list a b c]
+ expr {$a in $b}
+} 1
+
+test expr-24.9 {'in' operator: variables - no match} {
+ set a a
+ set b [list b c d]
+ expr {$a in $b}
+} 0
+
+test expr-24.10 {'in' operator: empty list} {
+ expr {"" in " "}
+} [expr {[lsearch -exact " " ""] >= 0}]
+
+test expr-24.11 {'in' operator: checking precedence 1} {
+ expr {"1" eq "a" in "a b"}
+} 1
+
+test expr-24.12 {'in' operator: checking precedence 2} {
+ expr {"a" in "a b" eq "1"}
+} 1
+
+test expr-24.13 {'in' operator: checking precedence 3} {
+ expr {- 1 in "1 2"}
+} 0
+
+test expr-24.14 {'in' operator: checking precedence 4} {
+ expr {1 in 1 + 2}
+} 3
+
+test expr-24.15 {'in' operator: improper list 1} {
+ -body {
+ expr {"a" in "a b \""}
+ }
+ -returnCodes 1
+ -result {unmatched open quote in list}
+}
+
+test expr-24.16 {'in' operator: improper list 2} {
+ -body {
+ expr {"a" in "\{ a"}
+ }
+ -returnCodes 1
+ -result {unmatched open brace in list}
+}
+
+test expr-24.17 {'in' operator: nested list 1} {
+ expr { {a b} in {{a b} {b c}} }
+} 1
+
+test expr-24.18 {'in' operator: nested list 2} {
+ expr { {a b} in {{a b} a b } }
+} 1
+
+test expr-24.19 {'in' operator: list construction} {
+ set a "A"
+ set b "A"
+ expr { $a in [list $b $b]}
+} 1
+
+test expr-24.20 {'in' operator: list construction error} \
+ -body {
+ set a "A"
+ set b "A"
+ expr " $a in [list $b $b] "
+ } \
+ -returnCodes 1 \
+ -result {syntax error in expression " A in A A ": variable references require preceding $}
+
+test expr-24.21 {'in' operator: escape characters 1} {
+ set a [list \" \"\"]
+ expr {"\"" in $a}
+} 1
+
+test expr-24.22 {'in' operator: escape characters 2} {
+ set a [list \{ \{]
+ expr {"\{" in $a}
+} 1
+
+test expr-24.23 {'in' operator: escape characters 3} {
+ set a { {} {{}} }
+ expr {{} in $a}
+} 1
+
+test expr-24.24 {'ni' operator: no match} {
+ expr {"a" ni "a b c"}
+} [expr {[lsearch "a b c" a] == -1}]
+
+test expr-24.25 {'ni' operator: match} {
+ expr {"a" ni "b c d"}
+} [expr {[lsearch "b c d" a] == -1}]
+
+test expr-24.26 {'in' oprtator: no space around} {
+ expr {1in1}
+} 1
+
+test expr-25.1 {alpha character after alpha operator: 'eq'} {
+ -body {
+ expr {1eqcos(1)}
+ }
+ -returnCodes 1
+ -result {syntax error in expression "1eqcos(1)": extra tokens at end of expression}
+}
+
+test expr-25.2 {alpha character after alpha operator: 'ne'} {
+ -body {
+ expr {1necos(1)}
+ }
+ -returnCodes 1
+ -result {syntax error in expression "1necos(1)": extra tokens at end of expression}
+}
+
+test expr-25.3 {alpha character after alpha operator: 'in'} {
+ expr {int(1.5)}
+} 1
+
+test expr-25.4 {alpha character after alpha operator: 'ni'} {
+ -body {
+ expr {1nicos(1)}
+ }
+ -returnCodes 1
+ -result {syntax error in expression "1nicos(1)": extra tokens at end of expression}
+}
+
# cleanup
if {[info exists a]} {
unset a
