merge trunk

generic/tcl.h

@@ -2000,6 +2000,11 @@ typedef struct Tcl_Token {
  *				literal character prefix "{*}". This word is
  *				marked to be expanded - that is, broken into
  *				words after substitution is complete.
+ * TCL_TOKEN_COMMENT_WORD -	This token is just like TCL_TOKEN_WORD except
+ *				that it marks a word that began with the
+ *				literal character prefix "{#}". This word is
+ *				marked to be ignored - that is, treated as 
+ *				if it denotes an expansion of the empty list.
  */
 
 #define TCL_TOKEN_WORD		1
@@ -2011,6 +2016,7 @@ typedef struct Tcl_Token {
 #define TCL_TOKEN_SUB_EXPR	64
 #define TCL_TOKEN_OPERATOR	128
 #define TCL_TOKEN_EXPAND_WORD	256
+#define TCL_TOKEN_COMMENT_WORD	512
 
 /*
  * Parsing error types. On any parsing error, one of these values will be

generic/tclBasic.c

@@ -5149,9 +5149,21 @@ TclEvalEx(
 		if (code != TCL_OK) {
 		    break;
 		}
+                
+                if (tokenPtr->type == TCL_TOKEN_COMMENT_WORD) {
+		    /* 
+		     * TIP #???. Word comments are handled by pretending 
+		     * that they are expansions of the empty list. 
+		     * There is probably a less roundabout way to achieve 
+		     * the same end, though.
+		     */
+                    
+                    Tcl_ResetResult(interp);
+                }
+                
 		objv[objectsUsed] = Tcl_GetObjResult(interp);
 		Tcl_IncrRefCount(objv[objectsUsed]);
-		if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
+		if (tokenPtr->type & (TCL_TOKEN_EXPAND_WORD | TCL_TOKEN_COMMENT_WORD)) {
 		    int numElements;
 
 		    code = TclListObjLength(interp, objv[objectsUsed],

generic/tclCompile.c

@@ -1585,7 +1585,7 @@ TclCompileScript(
 	    for (wordIdx = 0, tokenPtr = parsePtr->tokenPtr;
 		    wordIdx < parsePtr->numWords;
 		    wordIdx++, tokenPtr += tokenPtr->numComponents + 1) {
-		if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
+		if (tokenPtr->type & (TCL_TOKEN_EXPAND_WORD | TCL_TOKEN_COMMENT_WORD)) {
 		    expand = 1;
 		    break;
 		}
@@ -1642,6 +1642,8 @@ TclCompileScript(
 		    if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
 			TclEmitInstInt4(INST_EXPAND_STKTOP,
 				envPtr->currStackDepth, envPtr);
+		    } else if (tokenPtr->type == TCL_TOKEN_COMMENT_WORD) {
+			TclEmitOpcode(INST_POP, envPtr);
 		    }
 		    continue;
 		}

generic/tclParse.c

@@ -297,7 +297,9 @@ Tcl_ParseCommand(
 
     parsePtr->commandStart = src;
     while (1) {
-	int expandWord = 0;
+	int expandWord = 0;         /* 0 = ordinary word,
+	                             * 1 = word with {*} prefix,
+	                             * 2 = word with {#} prefix. */
 
 	/*
 	 * Create the token for the word.
@@ -331,8 +333,9 @@ Tcl_ParseCommand(
 
 	/*
 	 * At this point the word can have one of four forms: something
-	 * enclosed in quotes, something enclosed in braces, and expanding
-	 * word, or an unquoted word (anything else).
+	 * enclosed in quotes, something enclosed in braces, a word with 
+	 * prefix (expanding or comment word), or an unquoted word 
+	 * (anything else).
 	 */
 
     parseWord:
@@ -355,8 +358,8 @@ Tcl_ParseCommand(
 	    numBytes = parsePtr->end - src;
 
 	    /*
-	     * Check whether the braces contained the word expansion prefix
-	     * {*}
+	     * Check whether the braces contained the word expansion 
+	     * prefix {*} or the comment word prefix {#}.
 	     */
 
 	    expPtr = &parsePtr->tokenPtr[expIdx];
@@ -364,15 +367,16 @@ Tcl_ParseCommand(
 		    /* Haven't seen prefix already */
 		    && (1 == parsePtr->numTokens - expIdx)
 		    /* Only one token */
-		    && (((1 == (size_t) expPtr->size)
+		    && ((1 == (size_t) expPtr->size)
 			    /* Same length as prefix */
-			    && (expPtr->start[0] == '*')))
+			    && ((expPtr->start[0] == '*')
+                                    || (expPtr->start[0] == '#')))
 			    /* Is the prefix */
 		    && (numBytes > 0) && (0 == ParseWhiteSpace(termPtr,
 			    numBytes, &parsePtr->incomplete, &type))
 		    && (type != TYPE_COMMAND_END)
 		    /* Non-whitespace follows */) {
-		expandWord = 1;
+		expandWord = (expPtr->start[0] == '#') ? 2 : 1;
 		parsePtr->numTokens--;
 		goto parseWord;
 	    }
@@ -398,7 +402,7 @@ Tcl_ParseCommand(
 	tokenPtr = &parsePtr->tokenPtr[wordIndex];
 	tokenPtr->size = src - tokenPtr->start;
 	tokenPtr->numComponents = parsePtr->numTokens - (wordIndex + 1);
-	if (expandWord) {
+	if (expandWord == 1) {
 	    int i, isLiteral = 1;
 
 	    /*
@@ -539,6 +543,48 @@ Tcl_ParseCommand(
 
 		tokenPtr->type = TCL_TOKEN_EXPAND_WORD;
 	    }
+	} else if (expandWord == 2) {
+	    int i, isLiteral = 1;
+
+	    /*
+	     * When a command includes a comment word then processing 
+	     * proceeds in much the same way as for expansion words, but 
+	     * several cases can be pruned. One that remains is that of 
+	     * distinguishing between a literal and non-literal comment, 
+	     * since substitution is carried out in a comment word even 
+	     * if the result of that substitution will always be discarded.
+	     *
+	     * First check whether the thing to be expanded is a literal,
+	     * in the sense of being composed entirely of TCL_TOKEN_TEXT
+	     * tokens.
+	     */
+
+	    for (i = 1; i <= tokenPtr->numComponents; i++) {
+		if (tokenPtr[i].type != TCL_TOKEN_TEXT) {
+		    isLiteral = 0;
+		    break;
+		}
+	    }
+
+	    if (isLiteral) {
+		/*
+		 * The comment is a literal, so just forget about it 
+		 * right away. This is effectively the same as happens 
+		 * when {*} acts on a length 0 literate list.
+		 */
+                
+                parsePtr->numWords--;
+                parsePtr->numTokens = wordIndex;
+
+	    } else {
+		/*
+		 * The comment word is not a literal, so defer
+		 * processing to compile/eval time by marking with a
+		 * TCL_TOKEN_COMMENT_WORD token.
+		 */
+
+		tokenPtr->type = TCL_TOKEN_COMMENT_WORD;
+	    }
 	} else if ((tokenPtr->numComponents == 1)
 		&& (tokenPtr[1].type == TCL_TOKEN_TEXT)) {
 	    tokenPtr->type = TCL_TOKEN_SIMPLE_WORD;

generic/tclTest.c

@@ -3619,6 +3619,9 @@ PrintParse(
 	case TCL_TOKEN_EXPAND_WORD:
 	    typeString = "expand";
 	    break;
+	case TCL_TOKEN_COMMENT_WORD:
+	    typeString = "comment";
+	    break;
 	case TCL_TOKEN_WORD:
 	    typeString = "word";
 	    break;

generic/tclUtil.c

@@ -446,7 +446,7 @@ TclMaxListLength(
  *	If TCL_OK is returned, then *elementPtr will be set to point to the
  *	first element of list, and *nextPtr will be set to point to the
  *	character just after any white space following the last character
- *	that's part of the element. If this is the last argument in the list,
+ *	that's part of the element. If this is the last element in the list,
  *	then *nextPtr will point just after the last character in the list
  *	(i.e., at the character at list+listLength). If sizePtr is non-NULL,
  *	*sizePtr is filled in with the number of bytes in the element. If
@@ -496,6 +496,11 @@ TclFindElement(
     const char *limit;		/* Points just after list's last byte. */
     int openBraces = 0;		/* Brace nesting level during parse. */
     int inQuotes = 0;
+    enum TFECommentState {      /* TIP#??? */
+        ELEMENT_WORD,           /* Not in a comment word (that we know). */
+        BEFORE_COMMENT,         /* In a comment before the element. */
+        AFTER_COMMENT           /* In a comment after the element. */
+    } inComment = ELEMENT_WORD;     
     int size = 0;		/* lint. */
     int numChars;
     int literal = 1;
@@ -526,13 +531,15 @@ TclFindElement(
     elemStart = p;
 
     /*
-     * Find element's end (a space, close brace, or the end of the string).
+     * Find end of word (a space, close brace, or the end of the string).
      */
 
+  mainLoop:                     /* Comment words may cause jumping back 
+                                 * to this point in the function. */
     while (p < limit) {
 	switch (*p) {
 	    /*
-	     * Open brace: don't treat specially unless the element is in
+	     * Open brace: don't treat specially unless the word is in
 	     * braces. In this case, keep a nesting count.
 	     */
 
@@ -543,7 +550,7 @@ TclFindElement(
 	    break;
 
 	    /*
-	     * Close brace: if element is in braces, keep nesting count and
+	     * Close brace: if word is in braces, keep nesting count and
 	     * quit when the last close brace is seen.
 	     */
 
@@ -558,22 +565,47 @@ TclFindElement(
 		}
 
 		/*
-		 * Garbage after the closing brace; return an error.
+		 * There is something after the closing brace. Could that 
+		 * be because it is the closing brace of a comment prefix?
 		 */
+                
+                if ((size != 1) || (inComment != ELEMENT_WORD) || 
+                        (*elemStart != '#')) {
+                    
+                    /*
+                     * No, that was no comment prefix, so *p is simply 
+                     * garbage after the closing brace; return an error.
+                     */
 
-		if (interp != NULL) {
-		    p2 = p;
-		    while ((p2 < limit) && (!TclIsSpaceProc(*p2))
-			    && (p2 < p+20)) {
-			p2++;
-		    }
-		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
-			    "list element in braces followed by \"%.*s\" "
-			    "instead of space", (int) (p2-p), p));
-		    Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "JUNK",
-			    NULL);
-		}
-		return TCL_ERROR;
+                    if (interp != NULL) {
+                        p2 = p;
+                        while ((p2 < limit) && (!TclIsSpaceProc(*p2))
+                                && (p2 < p+20)) {
+                            p2++;
+                        }
+                        Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+                                "list element in braces followed by \"%.*s\" "
+                                "instead of space", (int) (p2-p), p));
+                        Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "JUNK",
+                                NULL);
+                    }
+                    return TCL_ERROR;
+                }
+                
+		/* 
+		 * Yes, that was a comment prefix. Check if the comment 
+		 * is brace- or quote-delimited.
+		 */
+                
+                inComment = BEFORE_COMMENT;
+                openBraces = 0;
+                if (*p == '{') {
+                    openBraces = 1;
+                    p++;
+                } else if (*p == '"') {
+                    inQuotes = 1;
+                    p++;
+                }
 	    }
 	    break;
 
@@ -585,7 +617,7 @@ TclFindElement(
 	case '\\':
 	    if (openBraces == 0) {
 		/*
-		 * A backslash sequence not within a brace quoted element
+		 * A backslash sequence not within a brace quoted word
 		 * means the value of the element is different from the
 		 * substring we are parsing.  A call to TclCopyAndCollapse()
 		 * is needed to produce the element value.  Inform the caller.
@@ -597,8 +629,8 @@ TclFindElement(
 	    break;
 
 	    /*
-	     * Space: ignore if element is in braces or quotes; otherwise
-	     * terminate element.
+	     * Space: ignore if word is in braces or quotes; otherwise
+	     * terminate word.
 	     */
 
 	case ' ':
@@ -614,7 +646,7 @@ TclFindElement(
 	    break;
 
 	    /*
-	     * Double-quote: if element is in quotes then terminate it.
+	     * Double-quote: if word is in quotes then terminate it.
 	     */
 
 	case '"':
@@ -649,7 +681,7 @@ TclFindElement(
     }
 
     /*
-     * End of list: terminate element.
+     * End of list: terminate word.
      */
 
     if (p == limit) {
@@ -677,14 +709,69 @@ TclFindElement(
     while ((p < limit) && (TclIsSpaceProc(*p))) {
 	p++;
     }
-    *elementPtr = elemStart;
+    if (inComment == BEFORE_COMMENT) {
+        
+	/* 
+	 * The word which has just been read was a comment rather than 
+	 * a list element, so we'll have to do it all again.
+	 */
+        
+        inComment = ELEMENT_WORD;
+        literal = 1;
+        openBraces = 0;
+        inQuotes = 0;
+        if (*p == '{') {
+            openBraces = 1;
+            p++;
+        } else if (*p == '"') {
+            inQuotes = 1;
+            p++;
+        }
+        elemStart = p;
+        goto mainLoop;
+    }
+    if (inComment == ELEMENT_WORD) {
+        
+	/* 
+	 * The word which has just been read was the sought list element.
+	 */
+        
+        *elementPtr = elemStart;
+        if (sizePtr != 0) {
+            *sizePtr = size;
+        }
+        if (literalPtr != 0) {
+            *literalPtr = literal;
+        }
+    }
     *nextPtr = p;
-    if (sizePtr != 0) {
-	*sizePtr = size;
-    }
-    if (literalPtr != 0) {
-	*literalPtr = literal;
+    
+    /* 
+     * Could there be a comment word after what has been read so far?
+     */
+    
+    if ((limit - p > 3) && (p[0] == '{') && (p[1] == '#') && 
+            (p[2] == '}') && !(TclIsSpaceProc(p[3]))) {
+	/* 
+	 * It appears there is, so go back and scan past it. 
+	 * This is needed because callers use (*nextPtr == limit) as 
+	 * a test for whether this was the last list element.
+	 */
+        
+        p += 3;
+        inComment = AFTER_COMMENT;
+        openBraces = 0;
+        inQuotes = 0;
+        if (*p == '{') {
+            openBraces = 1;
+            p++;
+        } else if (*p == '"') {
+            inQuotes = 1;
+            p++;
+        }
+        goto mainLoop;
     }
+    
     return TCL_OK;
 }
 

tests/basic.test

@@ -656,18 +656,38 @@ test basic-47.2.$noComp {Tcl_EvalEx: error during word expansion} -body {
     run {{*}\{}
 } -constraints $constraints -returnCodes error -result {unmatched open brace in list}
 
+test basic-47.2.$noComp.2 {Tcl_EvalEx: no error for non-list comment word} -body {
+    run {{#}\{}
+} -constraints $constraints
+
 test basic-47.3.$noComp {Tcl_EvalEx, error during substitution} -body {
     run {{*}[error foo]}
 } -constraints $constraints -returnCodes error -result foo
 
+test basic-47.3.$noComp.2 {Tcl_EvalEx, error during substitution} -body {
+    run {{#}[error foo]}
+} -constraints $constraints -returnCodes error -result foo
+
 test basic-47.4.$noComp {Tcl_EvalEx: no expansion} $constraints {
     run {list {*} {*}	{*}}
 } {* * *}
 
+test basic-47.4.$noComp.2 {Tcl_EvalEx: not comment words} $constraints {
+    run {list {#} {#}	{#}}
+} [list \# \# \#]
+
 test basic-47.5.$noComp {Tcl_EvalEx: expansion} $constraints {
     run {list {*}{} {*}	{*}x {*}"y z"}
 } {* x y z}
 
+test basic-47.5.$noComp.2 {Tcl_EvalEx: word comments} $constraints {
+    run {list {#}{} {#}	{#}x {#}"y z"}
+} [list \#]
+
+test basic-47.5.$noComp.3 {Tcl_EvalEx: expansion/comment mix} $constraints {
+    run {list a {*}b {#}{c} {*} d {#}e {#}f\ g {*}h\ i {*}"j k" l}
+} {a b * d h i j k l}
+
 test basic-47.6.$noComp {Tcl_EvalEx: expansion to zero args} $constraints {
     run {list {*}{}}
 } {}
@@ -686,6 +706,12 @@ test basic-47.9.$noComp {Tcl_EvalEx: expansion and subst order} $constraints {
 		{*}[list [incr x] [incr x]] [incr x]}
 } {1 2 3 4 5 6}
 
+test basic-47.9.$noComp.2 {Tcl_EvalEx: word comment and subst order} $constraints {
+    set x 0
+    run {list [incr x] {#}[incr x] [incr x] \
+		{#}[list [incr x] [incr x]] [incr x]}
+} {1 3 6}
+
 test basic-47.10.$noComp {Tcl_EvalEx: expand and memory management} $constraints {
     run {concat {*}{} a b c d e f g h i j k l m n o p q r}
 } {a b c d e f g h i j k l m n o p q r}

tests/dict.test

@@ -122,6 +122,14 @@ test dict-3.15 {compiled dict get error cleanliness - Bug 2431847} -body {
 } -returnCodes error -result {key "d" not known in dictionary}
 test dict-3.16 {dict/list shimmering - Bug 3004007} {set l [list p 1 p 2 q 3];dict get $l q;set l} {p 1 p 2 q 3}
 test dict-3.17 {dict/list shimmering - Bug 3004007} {set l [list p 1 p 2 q 3];dict get $l q;llength $l} 6
+test dict-3.18 {dict get command, comment words} -body {
+    dict get {
+        {#}"First heading"
+        key1 value1
+        {#}"Second heading" {#}{extra comment}
+        key2 {#}nothing value2
+    }
+} -result {key1 value1 key2 value2}
 
 test dict-4.1 {dict replace command} {
     dict replace {a b c d}

tests/lindex.test

@@ -130,6 +130,8 @@ test lindex-5.3 {three indices} testevalex {
     testevalex {lindex {{{a b} {c d}} {{e f} {g h}}} 1 0 1}
 } f
 
+# List parsing
+
 test lindex-6.1 {error conditions in parsing list} testevalex {
     list [catch {testevalex {lindex "a \{" 2}} msg] $msg
 } {1 {unmatched open brace in list}}
@@ -341,6 +343,8 @@ test lindex-13.3 {three indices} {
     set result
 } f
 
+# List parsing
+
 test lindex-14.1 {error conditions in parsing list} {
     list [catch { lindex "a \{" 2 } msg] $msg
 } {1 {unmatched open brace in list}}
@@ -350,6 +354,9 @@ test lindex-14.2 {error conditions in parsing list} {
 test lindex-14.3 {error conditions in parsing list} {
     list [catch { lindex {a "b c"def ghi} 2 } msg] $msg
 } {1 {list element in quotes followed by "def" instead of space}}
+test lindex-14.4 {error conditions in parsing list} {
+    list [catch { lindex {a {#}"b c"def ghi} 2 } msg] $msg
+} {1 {list element in quotes followed by "def" instead of space}}
 
 test lindex-15.1 {quoted elements} {
     catch {
@@ -375,6 +382,24 @@ test lindex-15.4 {quoted elements} {
     } result
     set result
 } {c d "e}
+test lindex-15.5 {comment words} {
+    catch {
+	lindex {a {#}b c d} 1
+    } result
+    set result
+} {c}
+test lindex-15.6 {comment words} {
+    catch {
+	lindex {a {#}"b c" d} 1
+    } result
+    set result
+} {d}
+test lindex-15.7 {comment words} {
+    catch {
+	lindex {{#}a "b c" {#}d} 0
+    } result
+    set result
+} {b c}
 
 test lindex-16.1 {data reuse} {
     set x 0

tests/listObj.test

@@ -107,6 +107,10 @@ test listobj-5.8 {Tcl_ListObjIndex, error in conversion} {
     set x " \{"
     list [catch {lindex $x 0} msg] $msg
 } {1 {unmatched open brace in list}}
+test listobj-5.9 {Tcl_ListObjIndex, error in conversion} {
+    set x " {#}{a b}c "
+    list [catch {lindex $x 0} msg] $msg
+} {1 {list element in braces followed by "c" instead of space}}
 
 test listobj-6.1 {Tcl_ListObjLength} {
     llength {a b c d}
@@ -170,6 +174,9 @@ test listobj-7.13 {Tcl_ListObjReplace, grow array, insert at end} {
 test listobj-8.1 {SetListFromAny} {
     lindex {0 foo\x00help 2} 1
 } "foo\x00help"
+test listobj-8.2 {SetListFromAny, comment} {
+    lindex {0 {#}foo\ help 2} 1
+} 2
 
 test listobj-9.1 {UpdateStringOfList} {
     string length [list foo\x00help]

tests/llength.test

@@ -25,6 +25,19 @@ test llength-1.2 {length of list} {
 test llength-1.3 {length of list} {
     llength {}
 } 0
+test llength-1.4 {length of list with comment word} {
+    llength {a b {#}c d}
+} 3
+test llength-1.5 {length of list with comment word} {
+    llength {a {#}"b c" d}
+} 2
+test llength-1.6 {length of list with comment words} {
+    llength {{#}{a b} c {#}\ d}
+} 1
+test llength-1.7 {length of list with comment words only} {
+    llength {{#}"a b" {#}c {#}{d}}
+} 0
+
 
 test llength-2.1 {error conditions} {
     list [catch {llength} msg] $msg