Tcl Source Code

Artifact Content
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.

Artifact 8e21154f2d484653f8ebff4e57fce2d60bf71ca5:

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