Core of implementation of TIP#201 ('in' and 'ni' operators)

5 files changed, 114 insertions, 11 deletions

diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c
index 64d28aa..e25160d 100644
--- a/generic/tclCompExpr.c
+++ b/generic/tclCompExpr.c
@@ -9,7 +9,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclCompExpr.c,v 1.24 2004/10/06 05:52:21 dgp Exp $
+ * RCS: @(#) $Id: tclCompExpr.c,v 1.25 2004/10/08 15:39:52 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -91,6 +91,8 @@ typedef struct ExprInfo {
 #define OP_STREQ	21
 #define OP_STRNEQ	22
 #define OP_EXPON	23
+#define OP_IN_LIST	24
+#define OP_NOT_IN_LIST	25
 
 /*
  * Table describing the expression operators. Entries in this table must
@@ -134,6 +136,8 @@ static OperatorDesc operatorTable[] = {
     {"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}
 };
 
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index d320a15..11383b7 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -11,7 +11,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclCompile.c,v 1.77 2004/10/06 09:31:38 dkf Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.78 2004/10/08 15:39:52 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -295,6 +295,11 @@ InstructionDesc tclInstructionTable[] = {
 
     {"startCommand",      5,    0,         1,   {OPERAND_UINT4}},
         /* Start of bytecoded command: op is the length of the cmd's code */ 
+
+    {"listIn",		  1,	-1,	   0,	{OPERAND_NONE}},
+	/* List containment: push [lsearch stktop stknext]>=0) */
+    {"listNotIn",	  1,	-1,	   0,	{OPERAND_NONE}},
+	/* List negated containment: push [lsearch stktop stknext]<0) */
     {0}
 };
 
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 4654d2b..2734b5f 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -8,7 +8,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclCompile.h,v 1.48 2004/09/26 16:36:04 msofer Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.49 2004/10/08 15:39:53 dkf Exp $
  */
 
 #ifndef _TCLCOMPILATION
@@ -544,8 +544,11 @@ typedef struct ByteCode {
 
 #define INST_START_CMD                  105
 
+#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
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 65a57dd..60b9344 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -11,7 +11,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclExecute.c,v 1.155 2004/10/06 20:09:37 dkf Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.156 2004/10/08 15:39:53 dkf Exp $
  */
 
 #ifdef STDC_HEADERS
@@ -2913,6 +2913,71 @@ TclExecuteByteCode(interp, codePtr)
 	NEXT_INST_F(9, 1, 1);
     }
 
+    case INST_LIST_IN:
+    case INST_LIST_NOT_IN: {
+	/*
+	 * Basic list containment operators.
+	 */
+	int found, s1len, s2len, llen, i;
+	Tcl_Obj *valuePtr, *value2Ptr, *o;
+	char *s1, *s2;
+
+	value2Ptr = *tosPtr;
+	valuePtr = *(tosPtr - 1);
+
+	s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
+	result = Tcl_ListObjLength(interp, value2Ptr, &llen);
+	if (result != TCL_OK) {
+	    TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ERROR: ", O2S(valuePtr),
+		    O2S(value2Ptr)), Tcl_GetObjResult(interp));
+	    goto checkForCatch;
+	}
+	found = 0;
+	if (llen > 0) {
+	    /* An empty list doesn't match anything */
+	    i = 0;
+	    do {
+		Tcl_ListObjIndex(NULL, value2Ptr, i, &o);
+		if (o != NULL) {
+		    s2 = Tcl_GetStringFromObj(o, &s2len);
+		} else {
+		    s2 = "";
+		}
+		if (s1len == s2len) {
+		    found = (strcmp(s1, s2) == 0);
+		}
+		i++;
+	    } while (i < llen && found == 0);
+	}
+
+	if (*pc == INST_LIST_NOT_IN) {
+	    found = !found;
+	}
+
+	TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), found));
+
+	/*
+	 * 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((found ? 2 : TclGetInt1AtPtr(pc+1)), 2, 0);
+	case INST_JUMP_TRUE1:
+	    NEXT_INST_F((found ? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
+	case INST_JUMP_FALSE4:
+	    NEXT_INST_F((found ? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
+	case INST_JUMP_TRUE4:
+	    NEXT_INST_F((found ? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
+	}
+#endif
+	objResultPtr = Tcl_NewBooleanObj(found);
+	NEXT_INST_F(0, 2, 1);
+    }
+
     /*
      *     End of INST_LIST and related instructions.
      * ---------------------------------------------------------
diff --git a/generic/tclParseExpr.c b/generic/tclParseExpr.c
index 266466c..2a1c151 100644
--- a/generic/tclParseExpr.c
+++ b/generic/tclParseExpr.c
@@ -13,7 +13,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclParseExpr.c,v 1.22 2004/10/04 13:56:37 dkf Exp $
+ * RCS: @(#) $Id: tclParseExpr.c,v 1.23 2004/10/08 15:39:55 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -134,6 +134,13 @@ typedef struct ParseInfo {
 #define EXPON		36
 
 /*
+ * List containment operators
+ */
+
+#define IN_LIST		37
+#define NOT_IN_LIST	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 +151,7 @@ static char *lexemeStrings[] = {
     "*", "/", "%", "+", "-",
     "<<", ">>", "<", ">", "<=", ">=", "==", "!=",
     "&", "^", "|", "&&", "||", "?", ":",
-    "!", "~", "eq", "ne", "**"
+    "!", "~", "eq", "ne", "**", "in", "ni"
 };
 
 /*
@@ -747,8 +754,8 @@ ParseEqualityExpr(infoPtr)
     }
 
     lexeme = infoPtr->lexeme;
-    while ((lexeme == EQUAL) || (lexeme == NEQ)
-	    || (lexeme == STREQ) || (lexeme == STRNEQ)) {
+    while (lexeme == EQUAL || lexeme == NEQ || lexeme == NOT_IN_LIST ||
+	    lexeme == IN_LIST || lexeme == STREQ || lexeme == STRNEQ) {
 	operator = infoPtr->start;
 	code = GetLexeme(infoPtr); /* skip over ==, !=, 'eq' or 'ne'  */
 	if (code != TCL_OK) {
@@ -1857,7 +1864,7 @@ GetLexeme(infoPtr)
 
 	case 'e':
 	    if ((src[1] == 'q') && ((infoPtr->lastChar - src) > 1) &&
-		(infoPtr->lastChar-src==2 || !isalpha(UCHAR(src[2])))) {
+		    (infoPtr->lastChar-src==2 || !isalpha(UCHAR(src[2])))) {
 		infoPtr->lexeme = STREQ;
 		infoPtr->size = 2;
 		infoPtr->next = src+2;
@@ -1869,12 +1876,31 @@ GetLexeme(infoPtr)
 
 	case 'n':
 	    if ((src[1] == 'e') && ((infoPtr->lastChar - src) > 1) &&
-		(infoPtr->lastChar-src==2 || !isalpha(UCHAR(src[2])))) {
+		    (infoPtr->lastChar-src==2 || !isalpha(UCHAR(src[2])))) {
 		infoPtr->lexeme = STRNEQ;
 		infoPtr->size = 2;
 		infoPtr->next = src+2;
 		parsePtr->term = infoPtr->next;
 		return TCL_OK;
+	    } else if ((src[1] == 'i') && ((infoPtr->lastChar - src) > 1) &&
+		    (infoPtr->lastChar-src==2 || !isalpha(UCHAR(src[2])))) {
+		infoPtr->lexeme = NOT_IN_LIST;
+		infoPtr->size = 2;
+		infoPtr->next = src+2;
+		parsePtr->term = infoPtr->next;
+		return TCL_OK;
+	    } else {
+		goto checkFuncName;
+	    }
+
+	case 'i':
+	    if ((src[1] == 'n') && ((infoPtr->lastChar - src) > 1) &&
+		    (infoPtr->lastChar-src==2 || !isalpha(UCHAR(src[2])))) {
+		infoPtr->lexeme = IN_LIST;
+		infoPtr->size = 2;
+		infoPtr->next = src+2;
+		parsePtr->term = infoPtr->next;
+		return TCL_OK;
 	    } else {
 		goto checkFuncName;
 	    }