From b8ad7e6569c1ac14d88d993310013ae3095d00b1 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 8 Oct 2004 15:39:37 +0000 Subject: Core of implementation of TIP#201 ('in' and 'ni' operators) --- ChangeLog | 5 ++++ generic/tclCompExpr.c | 6 ++++- generic/tclCompile.c | 7 +++++- generic/tclCompile.h | 7 ++++-- generic/tclExecute.c | 67 +++++++++++++++++++++++++++++++++++++++++++++++++- generic/tclParseExpr.c | 38 +++++++++++++++++++++++----- 6 files changed, 119 insertions(+), 11 deletions(-) diff --git a/ChangeLog b/ChangeLog index 5d793f7..203ee3b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,10 @@ 2004-10-08 Donal K. Fellows + * generic/tclExecute.c (TclExecuteByteCode): Implementation of the + INST_LIST_IN and INST_LIST_NOT_IN bytecodes. + * generic/tclParseExpr.c (GetLexeme): Parse the 'in' and 'ni' + operators for TIP#201. + * generic/tclDictObj.c (DictUpdateCmd,DictWithCmd): Core of implementation of TIP#212; docs and tests still to do... 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; } -- cgit v0.12