restrictions on array index confined to lhs.

generic/tclBasic.c

@@ -836,6 +836,9 @@ Tcl_CreateInterp(void)
 	    Tcl_DisassembleObjCmd, INT2PTR(1), NULL);
     Tcl_CreateObjCommand(interp, "::tcl::unsupported::representation",
 	    Tcl_RepresentationCmd, NULL, NULL);
+    Tcl_CreateObjCommand(interp, "::tcl::unsupported::parseexpr",
+	    Tcl_ParseAndDumpExprObjCmd, NULL, NULL);
+    
 
     /* Adding the bytecode assembler command */
     cmdPtr = (Command *) Tcl_NRCreateCommand(interp,

generic/tclCompExpr.c

@@ -183,6 +183,8 @@ enum Marks {
 				/* Used only for an empty argument list to a
 				 * function. Represents the empty string
 				 * within parens in the expression: rand() */
+#define VARNAME         (LEAF | 8)
+                                /* Bareword as varname target of assignment */
 
 /* Unary operator lexemes */
 
@@ -288,6 +290,11 @@ enum Marks {
 				 * the CLOSE_PAREN lexeme and END pairs with
 				 * START, in the same way that CLOSE_PAREN
 				 * pairs with OPEN_PAREN. */
+#define SEPARATOR      ( BINARY | 29)
+#define ASSIGN         ( BINARY | 30)
+				/* ASSIGN, like EXPON, is right associative,
+ 				 * and this distinction is coded directly in
+				 * ParseExpr() */
 
 /*
  * When ParseExpr() builds the parse tree it must choose which operands to
@@ -304,6 +311,8 @@ enum Precedence {
     PREC_CLOSE_PAREN,	/* ")" */
     PREC_OPEN_PAREN,	/* "(" */
     PREC_COMMA,		/* "," */
+    PREC_SEPARATOR,	/* ";" */
+    PREC_ASSIGN,	/* ":=" */
     PREC_CONDITIONAL,	/* "?", ":" */
     PREC_OR,		/* "||" */
     PREC_AND,		/* "&&" */
@@ -361,8 +370,10 @@ static const unsigned char prec[] = {
     PREC_EQUAL,		/* NOT_IN_LIST */
     PREC_CLOSE_PAREN,	/* CLOSE_PAREN */
     PREC_END,		/* END */
+    PREC_SEPARATOR,	/* SEPARATOR */
+    PREC_ASSIGN,	/* ASSIGN */
     /* Expansion room for more binary operators */
-    0,  0,  0,
+    0,
     0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     0,
@@ -416,8 +427,10 @@ static const unsigned char instruction[] = {
     INST_LIST_NOT_IN,	/* NOT_IN_LIST */
     0,			/* CLOSE_PAREN */
     0,			/* END */
+    0,			/* SEPARATOR */
+    0,			/* ASSIGN */
     /* Expansion room for more binary operators */
-    0,  0,  0,
+    0,
     0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     0,
@@ -462,9 +475,9 @@ static const unsigned char Lexeme[] = {
 	COMMA		/* , */,	MINUS		/* - */,
 	0		/* . */,	DIVIDE		/* / */,
 	0, 0, 0, 0, 0, 0, 0, 0, 0, 0,			/* 0-9 */
-	COLON		/* : */,	INVALID		/* ; */,
+	0		/* : or := */,	SEPARATOR	/* ; */,
 	0		/* < or << or <= */,
-	0		/* == or INVALID */,
+	0		/* == or INCOMPLETE */,
 	0		/* > or >> or >= */,
 	QUESTION	/* ? */,	INVALID		/* @ */,
 	0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,		/* A-M */
@@ -721,16 +734,64 @@ ParseExpr(
 
 		if (start[scanned+TclParseAllWhiteSpace(
 			start+scanned, numBytes-scanned)] == '(') {
-		    lexeme = FUNCTION;
 
-		    /*
-		     * When we compile the expression we'll need the function
-		     * name, and there's no place in the parse tree to store
-		     * it, so we keep a separate list of all the function
-		     * names we've parsed in the order we found them.
+		    /* Look ahead for assignment operator */
+
+		    /* 
+		     * TODO: this can probably be simplified.  
+		     * For now, it is working. 
 		     */
 
-		    Tcl_ListObjAppendElement(NULL, funcList, literal);
+		    Tcl_Parse vparse;
+		    const char *varend;
+		    const char *varstart = &start[TclParseAllWhiteSpace(start, numBytes)];
+		    int code, len;
+		    code = Tcl_ParseVarName(NULL, varstart, numBytes, &vparse, -1);
+		    len = vparse.tokenPtr[0].size;
+		    varend = varstart+len;
+		    Tcl_FreeParse(&vparse);
+
+		    /* 
+		     * An error here just means it's not a valid variable name,
+		     * so continue on to treat as a function 
+		     */
+
+		    /* Look ahead for Assignment operator ':=' */
+		    if (code == TCL_OK &&
+			varend[TclParseAllWhiteSpace(varend,numBytes-len)] == ':' && 
+			varend[TclParseAllWhiteSpace(varend,numBytes-len)+1] == '=') {
+
+			lexeme = VARNAME;
+
+			/* Adjust scanned bytes */
+			scanned = varend-start;
+
+			/* The variable name is tokenized below as a quoted string */
+
+		    } else {
+
+			lexeme = FUNCTION;
+
+			/*
+			 * When we compile the expression we'll need the function
+			 * name, and there's no place in the parse tree to store
+			 * it, so we keep a separate list of all the function
+			 * names we've parsed in the order we found them.
+			 */
+
+			Tcl_ListObjAppendElement(NULL, funcList, literal);
+		    }
+
+		} else if (start[scanned+TclParseAllWhiteSpace(
+			start+scanned, numBytes-scanned)] == ':' &&
+			   start[scanned+TclParseAllWhiteSpace(
+			start+scanned, numBytes-scanned)+1] == '=') {
+
+		    /* Simple bareword */
+		    lexeme = VARNAME;
+
+		    /* The variable name is stored as an OT_LITERAL below */
+
 		} else if (Tcl_GetBooleanFromObj(NULL,literal,&b) == TCL_OK) {
 		    lexeme = BOOLEAN;
 		} else {
@@ -864,6 +925,21 @@ ParseExpr(
 		numBytes -= scanned;
 		continue;
 
+	    case VARNAME: {
+		int length;
+		TclGetStringFromObj(literal, &length);
+		if (length < scanned) {
+		    // Go tokenize the literal...
+		    break;
+		} else {
+		    Tcl_ListObjAppendElement(NULL, litList, literal);
+		    complete = lastParsed = OT_LITERAL;
+		    start += scanned;
+		    numBytes -= scanned;
+		    continue;
+		}
+	    } /* VARNAME case */
+
 	    default:
 		break;
 	    }
@@ -910,6 +986,12 @@ ParseExpr(
 		scanned = tokenPtr->size;
 		break;
 
+	    case VARNAME:
+		code = TclParseTokens(start, scanned, /* mask */ 0, TCL_SUBST_ALL,  parsePtr);
+
+		// scanned already adjusted...
+		break;
+
 	    case SCRIPT: {
 		Tcl_Parse *nestedPtr =
 			TclStackAlloc(interp, sizeof(Tcl_Parse));
@@ -1174,6 +1256,11 @@ ParseExpr(
 			break;
 		    }
 
+		    /* Right association rules for assignment. */
+		    if (lexeme == ASSIGN) {
+			break;
+		    }
+
 		    /*
 		     * Special association rules for the conditional
 		     * operators. The "?" and ":" operators have equal
@@ -1252,6 +1339,16 @@ ParseExpr(
 		    nodes[complete].constant = incompletePtr->constant;
 		}
 
+		/*
+		 * We declare all ASSIGN operators to be non-constant
+		 * expressions because we do not want to optimize their
+		 * variable-setting side effects out of existence.
+		 */
+
+		if (incompletePtr->lexeme == ASSIGN) {
+		    incompletePtr->constant = 0;
+		}
+
 		if (incompletePtr->lexeme == START) {
 		    /*
 		     * Completing the START tree indicates we're done.
@@ -1290,6 +1387,20 @@ ParseExpr(
 		}
 	    }
 
+	    /* Enfocre LHS is literal, bareword, function
+	     * TODO: If function, convert to array reference
+	     */
+	    if (lexeme == ASSIGN) {
+		if (complete != OT_LITERAL &&
+		    complete != OT_TOKENS &&
+		    complete != FUNCTION) {
+
+		    TclNewLiteralStringObj(msg, "Target of assignment must be string");
+		    errCode = "SURPRISE";
+		    goto error;		    
+		}
+	    }
+
 	    /* Commas must appear only in function argument lists. */
 	    if (lexeme == COMMA) {
 		if  ((incompletePtr->lexeme != OPEN_PAREN)
@@ -1444,6 +1555,287 @@ ParseExpr(
 
     return TCL_ERROR;
 }
+
+
+/*
+ * Tree Dump Utilities
+ */
+
+static int
+MeasureTree(
+	     OpNode *nodes,
+	     int index)
+{
+    switch(nodes[index].lexeme&NODE_TYPE) {
+    case UNARY:
+	return 1+((nodes[index].right>=0)?MeasureTree(nodes,nodes[index].right):0);
+    case BINARY:
+	return 1+((nodes[index].left>=0)?MeasureTree(nodes,nodes[index].left):0)
+	    +((nodes[index].right>=0)?MeasureTree(nodes,nodes[index].right):0);
+    }
+    return 1;
+}
+
+struct OpExtra {
+    void *leftThing;
+    void *rightThing;
+    void *middleThing;
+};
+
+static void
+AdornTreeRec(OpNode *nodes,int index,struct OpExtra *extra,Tcl_Obj ***litObjvPtr,Tcl_Obj ***funcObjvPtr,Tcl_Token **tokensPtr)
+{
+    int ty,x;
+    
+    ty=nodes[index].lexeme;
+    switch(ty&NODE_TYPE) {
+    case BINARY:
+	x=nodes[index].left;
+	if (x>=0) {
+	    AdornTreeRec(nodes,x,extra,litObjvPtr,funcObjvPtr,tokensPtr);
+	} else {
+	    switch(x) {
+	    case OT_LITERAL:
+		extra[index].leftThing=(void *)**litObjvPtr;
+		(*litObjvPtr)++;
+		break;
+	    case OT_TOKENS:
+		extra[index].leftThing=(void *)*tokensPtr;
+		(*tokensPtr)+=(*tokensPtr)->numComponents+1;
+		break;
+	    }
+	}
+    }
+    if (ty==FUNCTION) {
+	extra[index].middleThing=(void *)**funcObjvPtr;
+	(*funcObjvPtr)++;
+    }
+    switch(ty&NODE_TYPE) {
+    case UNARY:
+    case BINARY:
+	x=nodes[index].right;
+	if (x>=0) {
+	    AdornTreeRec(nodes,x,extra,litObjvPtr,funcObjvPtr,tokensPtr);
+	} else {
+	    switch(x) {
+	    case OT_LITERAL:
+		extra[index].rightThing=(void *)**litObjvPtr;
+		(*litObjvPtr)++;
+		break;
+	    case OT_TOKENS:
+		extra[index].rightThing=(void *)*tokensPtr;
+		(*tokensPtr)+=(*tokensPtr)->numComponents+1;
+		break;
+	    }
+	}
+    }
+}
+
+static struct OpExtra *
+AdornTree(OpNode *nodes,Tcl_Obj **litObjv,Tcl_Obj **funcObjv,Tcl_Token *tokens)
+{
+    int n;
+    struct OpExtra *extra;
+
+    n=MeasureTree(nodes,0);
+    extra=(struct OpExtra *)ckalloc(n*sizeof(struct OpExtra));
+    AdornTreeRec(nodes,0,extra,&litObjv,&funcObjv,&tokens);
+
+    return extra;
+}
+
+static void DecodeNonOps(int x,void *thing,char *dst)
+{
+    switch(x) {
+    case OT_EMPTY:
+	strcpy(dst,"()");
+	return;
+    case OT_TOKENS:
+	{
+	    int n;
+	    #define MAXTOKS 1023
+	    char toks[MAXTOKS+1];
+
+	    n=((Tcl_Token *)thing)->size;
+	    if (n>=MAXTOKS) n=MAXTOKS;
+	    memcpy(toks,((Tcl_Token *)thing)->start,n);
+	    toks[n]=0;
+	    sprintf(dst,"TOKENS: %s",toks);
+	}
+	return;
+    case OT_LITERAL:
+	sprintf(dst,"LITERAL: %s",TclGetString((Tcl_Obj *)thing));
+	return;
+    default:
+	strcpy(dst,"N/A");
+	return;
+    }
+}
+
+static void
+DumpExprTreeIndent(
+	     OpNode *nodes,
+	     int index,
+	     const char *indent,
+	     struct OpExtra *extra)
+{
+    #define INDENTMAX 1024
+    char indent2[INDENTMAX];
+    int ty;
+    static const char *types[]={"AMBIG","BINARY","UNARY","LEAF"};
+    static const char *lexemes[256];
+    static const struct {int pos;const char *lex;} lexdesc[]={
+	{1,"+"},{2,"-"},{3,"bareword"},{4,"incompatible"},{5,"invalid"},
+	{0xc1,"number"},{0xc2,"[command]"},{0xc3,"boolean"},{0xc4,"{string}"},{0xc5,"$var"},{0xc6,"\"string\""},{0xc7,"()"},
+	{0x81,"+"},{0x82,"-"},{0x83,"function"},{0x84,"start"},{0x85,"("},{0x86,"!"},{0x87,"~"},
+	{0x41,"+"},{0x42,"-"},{0x43,","},{0x44,"*"},{0x45,"/"},{0x46,"%"},{0x47,","},{0x48,">"},
+	{0x49,"&"},{0x4a,"^"},{0x4b,"|"},
+	{0x4c,"?"},{0x4d,":"},
+	{0x5B,")"},{0x5c,"end"},{0x5d,";"},{0x5e,":="}
+    };
+    static int lexdone=0;
+
+    if (!lexdone) {
+	int i;
+	
+	lexdone=1;
+	for(i=0;i<256;i++) lexemes[i]="???";
+	for(i=0;i<(int)(sizeof(lexdesc)/sizeof(lexdesc[0]));i++) {
+	    lexemes[lexdesc[i].pos]=lexdesc[i].lex;
+	}
+    }
+
+    ty=nodes[index].lexeme;
+    fprintf(stderr,"--%s(%02X): %s %s\n",types[(ty&NODE_TYPE)>>6],ty,lexemes[ty],(ty==FUNCTION)?TclGetString((Tcl_Obj *)extra[index].middleThing):"");
+    switch(ty&NODE_TYPE) {
+    case UNARY:
+	fprintf(stderr,"%s   |\n%s   `",indent,indent);
+	snprintf(indent2,INDENTMAX,"%s    ",indent);
+	if (nodes[index].right<0) {
+	    char buf[1024];
+	    DecodeNonOps(nodes[index].right,extra[index].rightThing,buf);
+	    fprintf(stderr,"--%s\n",buf);
+	} else {
+	    DumpExprTreeIndent(nodes,nodes[index].right,indent2,extra);
+	}
+	break;
+    case BINARY:
+	fprintf(stderr,"%s   |\n%s   |",indent,indent);
+	snprintf(indent2,INDENTMAX,"%s   |",indent);
+	if (nodes[index].left<0) {
+	    char buf[1024];
+	    DecodeNonOps(nodes[index].left,extra[index].leftThing,buf);
+	    fprintf(stderr,"--%s\n",buf);
+	} else {
+	    DumpExprTreeIndent(nodes,nodes[index].left,indent2,extra);
+	}
+	fprintf(stderr,"%s   |\n%s   `",indent,indent);
+	snprintf(indent2,INDENTMAX,"%s    ",indent);
+	if (nodes[index].right<0) {
+	    char buf[1024];
+	    DecodeNonOps(nodes[index].right,extra[index].rightThing,buf);
+	    fprintf(stderr,"--%s\n",buf);
+	} else {
+	    DumpExprTreeIndent(nodes,nodes[index].right,indent2,extra);
+	}
+	break;
+    }
+}
+
+static void
+DumpExprTree(
+	     OpNode *nodes,
+	     int index,
+	     const char *script,
+	     int len,
+	     Tcl_Obj **litObjv,
+	     Tcl_Obj **funcObjv,
+	     Tcl_Token *tokens)
+{
+    #define MAXSCR 1024
+    char scr[MAXSCR];
+    struct OpExtra *extra;
+
+    if (len>=(MAXSCR-1)) len=MAXSCR-1;
+    memcpy(scr,script,len);
+    scr[len]=0;
+    fprintf(stderr,"=== EXPR TREE FOR {%s} ===\n\n",scr);
+    extra=AdornTree(nodes,litObjv,funcObjv,tokens);
+    DumpExprTreeIndent(nodes,index,"",extra);
+    fprintf(stderr,"\n=================\n");
+    ckfree(extra);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ParseAndDumpExpr, Tcl_ParseAndDumpExprObjCmd --
+ *
+ *	These procedures parse a string containing a Tcl expression and
+ *      dump the resulting parse tree to stderr in a readable layout.
+ *
+ * Results:
+ *	A standard Tcl return code and result left in interp.
+ *
+ * Side effects:
+ *	Output to stderr
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ParseAndDumpExpr(
+    Tcl_Interp *interp,		/* Used for error reporting. */
+    const char *script,		/* The source script to compile. */
+    int numBytes)		/* Number of bytes in script. */
+{
+    OpNode *opTree = NULL;	/* Will point to the tree of operators */
+    Tcl_Obj *litList = Tcl_NewObj();	/* List to hold the literals */
+    Tcl_Obj *funcList = Tcl_NewObj();	/* List to hold the functon names*/
+    Tcl_Parse *parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse));
+				/* Holds the Tcl_Tokens of substitutions */
+
+    int code = ParseExpr(interp, script, numBytes, &opTree, litList,
+	    funcList, parsePtr, 0 /* parseOnly */);
+
+    if (code == TCL_OK) {
+	/*
+	 * Valid parse; dump the tree.
+	 */
+
+	int objc;
+	Tcl_Obj **litObjv;
+	Tcl_Obj **funcObjv;
+
+	TclListObjGetElements(NULL, litList, &objc, (Tcl_Obj ***)&litObjv);
+	TclListObjGetElements(NULL, funcList, &objc, &funcObjv);
+	DumpExprTree(opTree,0,script,numBytes,litObjv,funcObjv,parsePtr->tokenPtr);
+    }
+
+    Tcl_FreeParse(parsePtr);
+    TclStackFree(interp, parsePtr);
+    Tcl_DecrRefCount(funcList);
+    Tcl_DecrRefCount(litList);
+    ckfree(opTree);
+
+    return code;
+}
+
+int Tcl_ParseAndDumpExprObjCmd(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[])
+{
+    char *s;
+    
+    if (objc != 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "expression");
+	return TCL_ERROR;
+    }
+    s=TclGetString(objv[1]);
+    
+    return ParseAndDumpExpr(interp,s,strlen(s));
+}
+
 
 /*
  *----------------------------------------------------------------------
@@ -1907,6 +2299,19 @@ ParseLexeme(
 	*lexemePtr = MULT;
 	return 1;
 
+    case ':':
+	if (numBytes > 1) {
+	    if (start[1] == '=') {
+		*lexemePtr = ASSIGN;
+		return 2;
+	    } else if (start[1] == ':') {
+		break; // bareword
+	    }
+	}
+	*lexemePtr = COLON;
+	return 1;
+
+	
     case '=':
 	if ((numBytes > 1) && (start[1] == '=')) {
 	    *lexemePtr = EQUAL;
@@ -2062,7 +2467,7 @@ ParseLexeme(
      * have no direct relevance here.
      */
 
-    if (!TclIsBareword(*start) || *start == '_') {
+    if ((!TclIsBareword(*start) && strncmp("::",start,2)) || *start == '_') {
 	if (Tcl_UtfCharComplete(start, numBytes)) {
 	    scanned = Tcl_UtfToUniChar(start, &ch);
 	} else {
@@ -2077,9 +2482,14 @@ ParseLexeme(
 	return scanned;
     }
     end = start;
-    while (numBytes && TclIsBareword(*end)) {
-	end += 1;
-	numBytes -= 1;
+    while (numBytes && (TclIsBareword(*end) || !strncmp("::",end,2))) {
+	if (*end==':') {
+	    end += 2;
+	    numBytes -= 2;
+	} else {
+	    end += 1;
+	    numBytes -= 1;
+	}
     }
     *lexemePtr = BAREWORD;
     if (literalPtr) {
@@ -2282,6 +2692,9 @@ CompileExprTree(
 		nodePtr->left = numWords;
 		numWords = 2;	/* Command plus one argument */
 		break;
+	    case SEPARATOR:
+		TclEmitOpcode(INST_POP, envPtr);
+		break;
 	    }
 	    case QUESTION:
 		newJump = TclStackAlloc(interp, sizeof(JumpList));
@@ -2320,7 +2733,15 @@ CompileExprTree(
 		    TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr);
 		}
 		break;
+	    case ASSIGN:
+		/* No need to convert, value should aready be 
+		 * numeric result of expression.
+		 * A non-numeric result is probably intentional.
+		 */
+		TclEmitOpcode(INST_STORE_STK, envPtr);
+		break;
 	    case OPEN_PAREN:
+	    case SEPARATOR:
 
 		/* do nothing */
 		break;

generic/tclInt.h

@@ -3054,6 +3054,8 @@ MODULE_SCOPE int	TclParseNumber(Tcl_Interp *interp, Tcl_Obj *objPtr,
 MODULE_SCOPE void	TclParseInit(Tcl_Interp *interp, const char *string,
 			    int numBytes, Tcl_Parse *parsePtr);
 MODULE_SCOPE int	TclParseAllWhiteSpace(const char *src, int numBytes);
+MODULE_SCOPE int	TclParseTokens(const char *src, int numBytes, int mask,
+			    int flags, Tcl_Parse *parsePtr);
 MODULE_SCOPE int	TclProcessReturn(Tcl_Interp *interp,
 			    int code, int level, Tcl_Obj *returnOpts);
 MODULE_SCOPE int	TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf);
@@ -3269,6 +3271,9 @@ MODULE_SCOPE Tcl_Obj *	TclDictWithInit(Tcl_Interp *interp, Tcl_Obj *dictPtr,
 MODULE_SCOPE int	Tcl_DisassembleObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
+MODULE_SCOPE int	Tcl_ParseAndDumpExprObjCmd(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[]);
 
 /* Assemble command function */
 MODULE_SCOPE int	Tcl_AssembleObjCmd(ClientData clientData,

generic/tclParse.c

@@ -35,7 +35,7 @@
  *			newline.
  * TYPE_COMMAND_END -	Character is newline or semicolon.
  * TYPE_SUBS -		Character begins a substitution or has other special
- *			meaning in ParseTokens: backslash, dollar sign, or
+ *			meaning in TclParseTokens: backslash, dollar sign, or
  *			open bracket.
  * TYPE_QUOTE -		Character is a double quote.
  * TYPE_CLOSE_PAREN -	Character is a right parenthesis.
@@ -95,7 +95,7 @@ const char tclCharTypeTable[] = {
     TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,
     TYPE_SPACE,       TYPE_NORMAL,      TYPE_QUOTE,       TYPE_NORMAL,
     TYPE_SUBS,        TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,
-    TYPE_NORMAL,      TYPE_CLOSE_PAREN, TYPE_NORMAL,      TYPE_NORMAL,
+    TYPE_OPEN_PAREN,  TYPE_CLOSE_PAREN, TYPE_NORMAL,      TYPE_NORMAL,
     TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,
     TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,
     TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,
@@ -163,8 +163,6 @@ const char tclCharTypeTable[] = {
 static inline int	CommandComplete(const char *script, int numBytes);
 static int		ParseComment(const char *src, int numBytes,
 			    Tcl_Parse *parsePtr);
-static int		ParseTokens(const char *src, int numBytes, int mask,
-			    int flags, Tcl_Parse *parsePtr);
 static int		ParseWhiteSpace(const char *src, int numBytes,
 			    int *incompletePtr, char *typePtr);
 static int		ParseAllWhiteSpace(const char *src, int numBytes,
@@ -399,11 +397,11 @@ Tcl_ParseCommand(
 	    }
 	} else {
 	    /*
-	     * This is an unquoted word. Call ParseTokens and let it do all of
+	     * This is an unquoted word. Call TclParseTokens and let it do all of
 	     * the work.
 	     */
 
-	    if (ParseTokens(src, numBytes, TYPE_SPACE|terminators,
+	    if (TclParseTokens(src, numBytes, TYPE_SPACE|terminators,
 		    TCL_SUBST_ALL, parsePtr) != TCL_OK) {
 		goto error;
 	    }
@@ -1051,7 +1049,7 @@ ParseComment(
 /*
  *----------------------------------------------------------------------
  *
- * ParseTokens --
+ * TclParseTokens --
  *
  *	This function forms the heart of the Tcl parser. It parses one or more
  *	tokens from a string, up to a termination point specified by the
@@ -1073,8 +1071,8 @@ ParseComment(
  *----------------------------------------------------------------------
  */
 
-static int
-ParseTokens(
+int
+TclParseTokens(
     register const char *src,	/* First character to parse. */
     register int numBytes,	/* Max number of bytes to scan. */
     int mask,			/* Specifies when to stop parsing. The parse
@@ -1169,6 +1167,8 @@ ParseTokens(
 	    numBytes--;
 	    nestedPtr = TclStackAlloc(parsePtr->interp, sizeof(Tcl_Parse));
 	    while (1) {
+		const char *curEnd;
+		
 		if (Tcl_ParseCommand(parsePtr->interp, src, numBytes, 1,
 			nestedPtr) != TCL_OK) {
 		    parsePtr->errorType = nestedPtr->errorType;
@@ -1177,8 +1177,9 @@ ParseTokens(
 		    TclStackFree(parsePtr->interp, nestedPtr);
 		    return TCL_ERROR;
 		}
+		curEnd = src + numBytes;
 		src = nestedPtr->commandStart + nestedPtr->commandSize;
-		numBytes = parsePtr->end - src;
+		numBytes = curEnd - src;
 		Tcl_FreeParse(nestedPtr);
 
 		/*
@@ -1266,7 +1267,7 @@ ParseTokens(
 	    src++;
 	    numBytes--;
 	} else {
-	    Tcl_Panic("ParseTokens encountered unknown character");
+	    Tcl_Panic("TclParseTokens encountered unknown character");
 	}
     }
     if (parsePtr->numTokens == originalTokens) {
@@ -1356,14 +1357,15 @@ Tcl_ParseVarName(
 				 * first null character. */
     Tcl_Parse *parsePtr,	/* Structure to fill in with information about
 				 * the variable name. */
-    int append)			/* Non-zero means append tokens to existing
+    int append)			/* greater-zero means append tokens to existing
 				 * information in parsePtr; zero means ignore
-				 * existing tokens in parsePtr and
-				 * reinitialize it. */
+				 * existing tokens in parsePtr and reinitialize
+				 * it. less-zero means being strict and disallow
+				 * un-escaped quotes, braces or open parens. */
 {
     Tcl_Token *tokenPtr;
     register const char *src;
-    int varIndex;
+    int varIndex, braceCount = 0;
     unsigned array;
 
     if ((numBytes == 0) || (start == NULL)) {
@@ -1373,7 +1375,7 @@ Tcl_ParseVarName(
 	numBytes = strlen(start);
     }
 
-    if (!append) {
+    if (append <= 0) {
 	TclParseInit(interp, start, numBytes, parsePtr);
     }
 
@@ -1416,15 +1418,20 @@ Tcl_ParseVarName(
      */
 
     if (*src == '{') {
+        char ch;
 	src++;
 	numBytes--;
 	tokenPtr->type = TCL_TOKEN_TEXT;
 	tokenPtr->start = src;
 	tokenPtr->numComponents = 0;
 
-	while (numBytes && (*src != '}')) {
+	ch = *src;
+	while (numBytes && (braceCount>0 || ch != '}')) {
+	    if (ch == '{') { braceCount++; }
+	    else if (ch == '}') { braceCount--; }
 	    numBytes--;
 	    src++;
+	    ch= *src;
 	}
 	if (numBytes == 0) {
 	    if (parsePtr->interp != NULL) {
@@ -1475,16 +1482,17 @@ Tcl_ParseVarName(
 	parsePtr->numTokens++;
 	if (array) {
 	    /*
-	     * This is a reference to an array element. Call ParseTokens
+	     * This is a reference to an array element. Call TclParseTokens
 	     * recursively to parse the element name, since it could contain
 	     * any number of substitutions.
 	     */
 
-	    if (TCL_OK != ParseTokens(src+1, numBytes-1, TYPE_CLOSE_PAREN,
+            int endFlag = (append<0) ? TYPE_BAD_ARRAY_INDEX : TYPE_CLOSE_PAREN;
+	    if (TCL_OK != TclParseTokens(src+1, numBytes-1, endFlag,
 		    TCL_SUBST_ALL, parsePtr)) {
 		goto error;
 	    }
-	    if ((parsePtr->term == src+numBytes) || (*parsePtr->term != ')')){
+	    if ((parsePtr->term == src+numBytes)){
 		if (parsePtr->interp != NULL) {
 		    Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj(
 			    "missing )", -1));
@@ -1493,6 +1501,14 @@ Tcl_ParseVarName(
 		parsePtr->term = src;
 		parsePtr->incomplete = 1;
 		goto error;
+	    } else if ((*parsePtr->term != ')')){
+		if (parsePtr->interp != NULL) {
+		    Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj(
+			    "invalid char in array index", -1));
+		}
+		parsePtr->errorType = TCL_PARSE_SYNTAX;
+		parsePtr->term = src;
+		goto error;
 	    }
 	    src = parsePtr->term + 1;
 	}
@@ -1857,7 +1873,7 @@ Tcl_ParseQuotedString(
 	TclParseInit(interp, start, numBytes, parsePtr);
     }
 
-    if (TCL_OK != ParseTokens(start+1, numBytes-1, TYPE_QUOTE, TCL_SUBST_ALL,
+    if (TCL_OK != TclParseTokens(start+1, numBytes-1, TYPE_QUOTE, TCL_SUBST_ALL,
 	    parsePtr)) {
 	goto error;
     }
@@ -1929,7 +1945,7 @@ TclSubstParse(
      * inhibit types of substitution.
      */
 
-    if (TCL_OK != ParseTokens(p, length, /* mask */ 0, flags, parsePtr)) {
+    if (TCL_OK != TclParseTokens(p, length, /* mask */ 0, flags, parsePtr)) {
 	/*
 	 * There was a parse error. Save the interpreter state for possible
 	 * error reporting later.
@@ -1945,7 +1961,7 @@ TclSubstParse(
 	 * which points to either the unmatched opener, or to characters that
 	 * follow a close brace or close quote.
 	 *
-	 * Call ParseTokens again, working on the string up to parse.term.
+	 * Call TclParseTokens again, working on the string up to parse.term.
 	 * Keep repeating until we get a good parse on a prefix.
 	 */
 
@@ -1956,7 +1972,7 @@ TclSubstParse(
 	    parsePtr->incomplete = 0;
 	    parsePtr->errorType = TCL_PARSE_SUCCESS;
 	} while (TCL_OK !=
-		ParseTokens(p, parsePtr->end - p, 0, flags, parsePtr));
+		TclParseTokens(p, parsePtr->end - p, 0, flags, parsePtr));
 
 	/*
 	 * The good parse will have to be followed by {, (, or [.

generic/tclParse.h

@@ -11,6 +11,8 @@
 #define TYPE_CLOSE_PAREN	0x10
 #define TYPE_CLOSE_BRACK	0x20
 #define TYPE_BRACE		0x40
+#define TYPE_OPEN_PAREN		0x80
+#define TYPE_BAD_ARRAY_INDEX	(TYPE_OPEN_PAREN|TYPE_CLOSE_PAREN|TYPE_QUOTE|TYPE_BRACE)
 
 #define CHAR_TYPE(c) (tclCharTypeTable+128)[(int)(c)]
 

generic/tclZlib.c

@@ -1204,10 +1204,10 @@ Tcl_ZlibStreamPut(
 	zshPtr->stream.avail_in = size;
 
 	/*
-	 * Must not do a zero-length compress. [Bug 25842c161]
+	 * Must not do a zero-length compress unless finalizing. [Bug 25842c161]
 	 */
 
-	if (size == 0) {
+	if (size == 0 && flush != Z_FINISH) {
 	    return TCL_OK;
 	}
 

tests/expr.test

@@ -7187,7 +7187,80 @@ test expr-51.1 {test round-to-even on input} {
     expr 6.9294956446009195e15
 } 6929495644600920.0
 
+# Check "expr" assignment operator
 
+test expr-52.1 {expr assignment and separator operators} {
+    set ans [expr  {
+		    t  := 10.0;
+		    x  := 2.0;
+		    dx := 0.2;
+		    f  := ($dx-$x/10);
+		    fs := {$dx-$x/10};
+		    g  := (-$x/5);
+		    center := 1.0;
+		    x  := $x-$center;
+		    dx := $dx+$g;
+		    x  := $x+$f+$center;
+		    x  := $x+$f+$center;
+		    y  := round($x)
+		}]
+    list $ans $t $x $dx $f $fs $g $center $dx $y
+} {3 10.0 3.0 -0.2 0.0 {$dx-$x/10} -0.4 1.0 -0.2 3}
+
+test expr-52.2 {expr assignment with literal names} {
+    array unset ary
+    set ans [expr  { "-8-"  := 10.0;
+		     "ary(fred)"  := 2.0;
+		     {ary(" ")}  := sqrt(17)
+		 }]
+    list $ans [set "-8-"] [set "ary(fred)"] [set {ary(" ")}]
+} {4.123105625617661 10.0 2.0 4.123105625617661}
+
+# Not anymore
+#test expr-52.3 {expr assignment error} -body {
+#    expr  { ary(0) := 500 }
+#} -returnCodes error -result {Target of assignment must be string
+#in expression " ary(0) := 500 "}
+
+test expr-52.4 {expr assignment variables with qualifiers} {
+    namespace eval n1 {}
+    set ans [expr  {
+		    ::t  := 10.0;
+		    n1::x  := 2.0;
+		    ::n1::dx := 0.2;
+		    n1::f  := ($n1::dx-$n1::x/10);
+		    fs := {$n1::dx-$n1::x/10};
+		    y := -1
+		}]
+    list $ans $::t $n1::x $::n1::dx $n1::f $fs $y
+} {-1 10.0 2.0 0.2 0.0 {$n1::dx-$n1::x/10} -1}
+
+
+test expr-52.5 {expr assignment array variables} {
+    array unset ary
+    set ans [expr {
+		    i:=1;
+		    jkl := 2;
+		    ary($i) :=$i*$jkl;
+		    ary( $jkl ):= double(int(sqrt($jkl) * 1000))/1000.0;
+		    bsg(oh):= round($ary( $jkl ) * $ary( $jkl ))
+		}]
+    list $ans $i $jkl [array get ary] [array get bsg]
+} {2 1 2 {1 2 { 2 } 1.414} {oh 2}}
+
+test expr-52.6 {expr assignment odd cases} {
+    set ans1 [expr { sin( 0 + [puts foobar; # will it be an array access?
+			       string cat 0]) := sin( 0 + [puts foobar; # or will it be a function call?
+							   string cat 0]) }]
+    set arr(\ \}\ ) hello
+    set ans2 [expr { arr( { ) := $arr( } ) }]
+    set ans3 [catch {expr { arr( { ) + $arr( } ) }} err]
+    set l1 [list $ans1 [array get sin]]
+    set l2 [list $ans2 [array get arr]]
+    set l3 [list $ans3 $err]
+    list $l1 $l2 $l3
+
+} {{0.0 {{ 0 + 0} 0.0}} {hello {\ \}\  hello \ \{\  hello}} {1 {invalid command name "tcl::mathfunc::arr"}}}
 
 # cleanup
 if {[info exists a]} {
@@ -7195,6 +7268,8 @@ if {[info exists a]} {
 }
 catch {unset min}
 catch {unset max}
+apply {args {foreach v $args {if {[info exists $v]} {unset $v} }}} \
+    ans t x dx f fs g center dx y "-8-" "ary(fred)" {ary(" ")}
 ::tcltest::cleanupTests
 return
 

tests/zlib.test

@@ -157,6 +157,48 @@ test zlib-7.8 {zlib stream: Bug b26e38a3e4} -constraints zlib -setup {
     catch {$strm close}
     unset -nocomplain randdata data
 } -result {120185 18003000}
+test zlib-7.9 {zlib stream finalize (bug 25842c161)} -constraints zlib -setup {
+    set z1 [zlib stream gzip]
+    set z2 [zlib stream gzip]
+} -body {
+    $z1 put ABCDEedbca..
+    $z1 finalize
+    zlib gunzip [$z1 get]
+} -cleanup {
+    $z1 close
+} -result ABCDEedbca..
+test zlib-7.10 {zlib stream finalize (bug 25842c161)} -constraints zlib -setup {
+    set z2 [zlib stream gzip]
+} -body {
+    $z2 put -finalize ABCDEedbca..
+    zlib gunzip [$z2 get]
+} -cleanup {
+    $z2 close
+} -result ABCDEedbca..
+test zlib-7.11 {zlib stream put -finalize (bug 25842c161)} -constraints zlib -setup {
+    set c [zlib stream gzip]
+    set d [zlib stream gunzip]
+} -body {
+    $c put abcdeEDCBA..
+    $c finalize
+    $d put [$c get]
+    $d finalize
+    $d get
+} -cleanup {
+    $c close
+    $d close
+} -result abcdeEDCBA..
+test zlib-7.12 {zlib stream put; zlib stream finalize (bug 25842c161)} -constraints zlib -setup {
+    set c [zlib stream gzip]
+    set d [zlib stream gunzip]
+} -body {
+    $c put -finalize abcdeEDCBA..
+    $d put -finalize [$c get]
+    $d get
+} -cleanup {
+    $c close
+    $d close
+} -result abcdeEDCBA..
 
 test zlib-8.1 {zlib transformation} -constraints zlib -setup {
     set file [makeFile {} test.gz]