Attachment "tip201.patch" to
ticket [1031507fff]
added by
rmax
2004-09-21 03:25:38.
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 20 Sep 2004 20:09:20 -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 20 Sep 2004 20:09:20 -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 20 Sep 2004 20:09:21 -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:
{
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 20 Sep 2004 20:09:21 -0000
@@ -134,6 +134,12 @@
#define EXPON 36
/*
+ * 'in' operator
+ */
+#define IN 37
+#define NI 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 == IN || lexeme == NI) {
+ 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 '(' */
@@ -1856,7 +1925,7 @@
return TCL_OK;
case 'e':
- if ((src[1] == 'q') && ((infoPtr->lastChar - src) > 1)) {
+ if ((src[1] == 'q') && !isalpha(src[2]) && ((infoPtr->lastChar - src) > 1)) {
infoPtr->lexeme = STREQ;
infoPtr->size = 2;
infoPtr->next = src+2;
@@ -1866,13 +1935,30 @@
goto checkFuncName;
}
+ case 'i':
+ if ((src[1] == 'n') && !isalpha(src[2]) && ((infoPtr->lastChar - src) > 1)) {
+ infoPtr->lexeme = IN;
+ 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)) {
+ if ((src[1] == 'e') && !isalpha(src[2]) && ((infoPtr->lastChar - src) > 1)) {
infoPtr->lexeme = STRNEQ;
infoPtr->size = 2;
infoPtr->next = src+2;
parsePtr->term = infoPtr->next;
return TCL_OK;
+ } else if (src[1] == 'i' && !isalpha(src[2]) && ((infoPtr->lastChar - src) > 1)) {
+ infoPtr->lexeme = NI;
+ infoPtr->size = 2;
+ infoPtr->next = src+2;
+ parsePtr->term = infoPtr->next;
+ return TCL_OK;
} else {
goto checkFuncName;
}
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 20 Sep 2004 20:09:21 -0000
@@ -871,6 +871,158 @@
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
+
+#
+# Should this fail?
+test expr-24.15 {'in' operator: improper list 1} \
+ -body {
+ expr {"a" in "a b}
+} \
+-returnCodes 1 \
+-result {missing "}
+
+test expr-24.16 {'in' operator: improper list 2} \
+ -body {
+ expr {"a" in \{a b}
+ } \
+ -returnCodes 1 \
+ -result {syntax error in expression ""a" in \{a b": character not legal in expressions}
+
+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.25 {'in'} {
+ expr {false in false}
+} 1
+
+test expr-25.1 {alphanumeric operators must be surrounded by non-alpha characters 'eq'} \
+ -body {
+ expr {cos(1)eqcos(1)}
+ } \
+ -returnCodes 1 \
+ -result {syntax error in expression "cos(1)eqcos(1)": extra tokens at end of expression}
+
+test expr-25.2 {alphanumeric operators must be surrounded by non-alpha characters 'ne'} \
+ -body {
+ expr {cos(1)necos(1)}
+ } \
+ -returnCodes 1 \
+ -result {syntax error in expression "cos(1)necos(1)": extra tokens at end of expression}
+
+test expr-25.3 {alphanumeric operators must be surrounded by non-alpha characters 'in'} {
+ expr {int(1.5)}
+} 1
+
+test expr-25.4 {alphanumeric operators must be surrounded by non-alpha characters 'ni'} \
+ -body {
+ expr {falsenitrue}
+ } \
+ -returnCodes 1 \
+ -result {syntax error in expression "cos(1)necos(1)": extra tokens at end of expression}
+
# cleanup
if {[info exists a]} {
unset a
