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 tclconference@googlegroups.com
or submit via the online form by Sep 9.

Artifact 5fe0b469f9dfc8538d209d51ce53713b28cd5849:

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