Tcl Source Code

Changes On Branch tip-401
Login
Bounty program for improvements to Tcl and certain Tcl packages.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Changes In Branch tip-401 Excluding Merge-Ins

This is equivalent to a diff from 29535daab1 to 18b67ecc84

2012-05-02
06:50
TclWinCPUID now respects -fPIC compilation on 32-bit Linux check-in: cf269b5da3 user: jan.nijtmans tags: trunk
2012-05-01
12:21
merge trunk Leaf check-in: 18b67ecc84 user: dgp tags: tip-401
04:51
merge trunk check-in: f0310da009 user: dkf tags: tip-400-impl
2012-04-30
21:53
Tame deadlocks in broken refchan tests [Bug 3522560] check-in: 29535daab1 user: ferrieux tags: trunk
20:21
Initial TIP 401 patch check-in: e3a37c3439 user: dgp tags: tip-401
12:55
Revert introduction of non-portable asm snippet in function TclWinCPUID, to restore compilability on... check-in: 2e93a2feb3 user: ferrieux tags: trunk

Changes to generic/tcl.h.

1996
1997
1998
1999
2000
2001
2002





2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013

2014
2015
2016
2017
2018
2019
2020
 *				TCL_TOKEN_SUB_EXPR tokens for the operator's
 *				operands. NumComponents is always 0.
 * TCL_TOKEN_EXPAND_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 expanded - that is, broken into
 *				words after substitution is complete.





 */

#define TCL_TOKEN_WORD		1
#define TCL_TOKEN_SIMPLE_WORD	2
#define TCL_TOKEN_TEXT		4
#define TCL_TOKEN_BS		8
#define TCL_TOKEN_COMMAND	16
#define TCL_TOKEN_VARIABLE	32
#define TCL_TOKEN_SUB_EXPR	64
#define TCL_TOKEN_OPERATOR	128
#define TCL_TOKEN_EXPAND_WORD	256


/*
 * Parsing error types. On any parsing error, one of these values will be
 * stored in the error field of the Tcl_Parse structure defined below.
 */

#define TCL_PARSE_SUCCESS		0






>
>
>
>
>











>







1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
 *				TCL_TOKEN_SUB_EXPR tokens for the operator's
 *				operands. NumComponents is always 0.
 * TCL_TOKEN_EXPAND_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 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
#define TCL_TOKEN_SIMPLE_WORD	2
#define TCL_TOKEN_TEXT		4
#define TCL_TOKEN_BS		8
#define TCL_TOKEN_COMMAND	16
#define TCL_TOKEN_VARIABLE	32
#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
 * stored in the error field of the Tcl_Parse structure defined below.
 */

#define TCL_PARSE_SUCCESS		0

Changes to generic/tclBasic.c.

5145
5146
5147
5148
5149
5150
5151












5152
5153
5154

5155
5156
5157
5158
5159
5160
5161
			wordCLNext, outerScript);

		iPtr->evalFlags = 0;

		if (code != TCL_OK) {
		    break;
		}












		objv[objectsUsed] = Tcl_GetObjResult(interp);
		Tcl_IncrRefCount(objv[objectsUsed]);
		if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {

		    int numElements;

		    code = TclListObjLength(interp, objv[objectsUsed],
			    &numElements);
		    if (code == TCL_ERROR) {
			/*
			 * Attempt to expand a non-list.






>
>
>
>
>
>
>
>
>
>
>
>


<
>







5145
5146
5147
5148
5149
5150
5151
5152
5153
5154
5155
5156
5157
5158
5159
5160
5161
5162
5163
5164
5165

5166
5167
5168
5169
5170
5171
5172
5173
			wordCLNext, outerScript);

		iPtr->evalFlags = 0;

		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 | TCL_TOKEN_COMMENT_WORD)) {
		    int numElements;

		    code = TclListObjLength(interp, objv[objectsUsed],
			    &numElements);
		    if (code == TCL_ERROR) {
			/*
			 * Attempt to expand a non-list.

Changes to generic/tclCompile.c.

1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
....
1638
1639
1640
1641
1642
1643
1644


1645
1646
1647
1648
1649
1650
1651
	     * Check whether expansion has been requested for any of the
	     * words.
	     */

	    for (wordIdx = 0, tokenPtr = parsePtr->tokenPtr;
		    wordIdx < parsePtr->numWords;
		    wordIdx++, tokenPtr += tokenPtr->numComponents + 1) {
		if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
		    expand = 1;
		    break;
		}
	    }

	    envPtr->numCommands++;
	    currCmdIndex = envPtr->numCommands - 1;
................................................................................
		     */

		    TclCompileTokens(interp, tokenPtr+1,
			    tokenPtr->numComponents, envPtr);
		    if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
			TclEmitInstInt4(INST_EXPAND_STKTOP,
				envPtr->currStackDepth, envPtr);


		    }
		    continue;
		}

		/*
		 * This is a simple string of literal characters (i.e. we know
		 * it absolutely and can use it directly). If this is the






|







 







>
>







1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
....
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
	     * Check whether expansion has been requested for any of the
	     * words.
	     */

	    for (wordIdx = 0, tokenPtr = parsePtr->tokenPtr;
		    wordIdx < parsePtr->numWords;
		    wordIdx++, tokenPtr += tokenPtr->numComponents + 1) {
		if (tokenPtr->type & (TCL_TOKEN_EXPAND_WORD | TCL_TOKEN_COMMENT_WORD)) {
		    expand = 1;
		    break;
		}
	    }

	    envPtr->numCommands++;
	    currCmdIndex = envPtr->numCommands - 1;
................................................................................
		     */

		    TclCompileTokens(interp, tokenPtr+1,
			    tokenPtr->numComponents, envPtr);
		    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;
		}

		/*
		 * This is a simple string of literal characters (i.e. we know
		 * it absolutely and can use it directly). If this is the

Changes to generic/tclParse.c.

293
294
295
296
297
298
299
300


301
302
303
304
305
306
307
...
327
328
329
330
331
332
333
334

335
336
337
338
339
340
341
342
...
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369

370
371
372
373
374
375
376
377
378
379
380
381
382
...
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
...
535
536
537
538
539
540
541










































542
543
544
545
546
547
548
    /*
     * The following loop parses the words of the command, one word in each
     * iteration through the loop.
     */

    parsePtr->commandStart = src;
    while (1) {
	int expandWord = 0;



	/*
	 * Create the token for the word.
	 */

	TclGrowParseTokenArray(parsePtr, 1);
	wordIndex = parsePtr->numTokens;
................................................................................
	}
	tokenPtr->start = src;
	parsePtr->numTokens++;
	parsePtr->numWords++;

	/*
	 * 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).
	 */

    parseWord:
	if (*src == '"') {
	    if (Tcl_ParseQuotedString(interp, src, numBytes, parsePtr, 1,
		    &termPtr) != TCL_OK) {
		goto error;
................................................................................
		    &termPtr) != TCL_OK) {
		goto error;
	    }
	    src = termPtr;
	    numBytes = parsePtr->end - src;

	    /*
	     * Check whether the braces contained the word expansion prefix
	     * {*}
	     */

	    expPtr = &parsePtr->tokenPtr[expIdx];
	    if ((0 == expandWord)
		    /* Haven't seen prefix already */
		    && (1 == parsePtr->numTokens - expIdx)
		    /* Only one token */
		    && (((1 == (size_t) expPtr->size)
			    /* Same length as prefix */
			    && (expPtr->start[0] == '*')))

			    /* Is the prefix */
		    && (numBytes > 0) && (0 == ParseWhiteSpace(termPtr,
			    numBytes, &parsePtr->incomplete, &type))
		    && (type != TYPE_COMMAND_END)
		    /* Non-whitespace follows */) {
		expandWord = 1;
		parsePtr->numTokens--;
		goto parseWord;
	    }
	} else {
	    /*
	     * This is an unquoted word. Call ParseTokens and let it do all of
	     * the work.
................................................................................
	 * Finish filling in the token for the word and check for the special
	 * case of a word consisting of a single range of literal text.
	 */

	tokenPtr = &parsePtr->tokenPtr[wordIndex];
	tokenPtr->size = src - tokenPtr->start;
	tokenPtr->numComponents = parsePtr->numTokens - (wordIndex + 1);
	if (expandWord) {
	    int i, isLiteral = 1;

	    /*
	     * When a command includes a word that is an expanded literal; for
	     * example, {*}{1 2 3}, the parser performs that expansion
	     * immediately, generating several TCL_TOKEN_SIMPLE_WORDs instead
	     * of a single TCL_TOKEN_EXPAND_WORD that the Tcl_ParseCommand()
................................................................................
		 * The word to be expanded is not a literal, so defer
		 * expansion to compile/eval time by marking with a
		 * TCL_TOKEN_EXPAND_WORD token.
		 */

		tokenPtr->type = TCL_TOKEN_EXPAND_WORD;
	    }










































	} else if ((tokenPtr->numComponents == 1)
		&& (tokenPtr[1].type == TCL_TOKEN_TEXT)) {
	    tokenPtr->type = TCL_TOKEN_SIMPLE_WORD;
	}

	/*
	 * Do two additional checks: (a) make sure we're really at the end of






|
>
>







 







|
>
|







 







|
|







|

|
>





|







 







|







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
...
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
...
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
...
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
...
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
    /*
     * The following loop parses the words of the command, one word in each
     * iteration through the loop.
     */

    parsePtr->commandStart = src;
    while (1) {
	int expandWord = 0;         /* 0 = ordinary word,
	                             * 1 = word with {*} prefix,
	                             * 2 = word with {#} prefix. */

	/*
	 * Create the token for the word.
	 */

	TclGrowParseTokenArray(parsePtr, 1);
	wordIndex = parsePtr->numTokens;
................................................................................
	}
	tokenPtr->start = src;
	parsePtr->numTokens++;
	parsePtr->numWords++;

	/*
	 * At this point the word can have one of four forms: something
	 * enclosed in quotes, something enclosed in braces, a word with 
	 * prefix (expanding or comment word), or an unquoted word 
	 * (anything else).
	 */

    parseWord:
	if (*src == '"') {
	    if (Tcl_ParseQuotedString(interp, src, numBytes, parsePtr, 1,
		    &termPtr) != TCL_OK) {
		goto error;
................................................................................
		    &termPtr) != TCL_OK) {
		goto error;
	    }
	    src = termPtr;
	    numBytes = parsePtr->end - src;

	    /*
	     * Check whether the braces contained the word expansion 
	     * prefix {*} or the comment word prefix {#}.
	     */

	    expPtr = &parsePtr->tokenPtr[expIdx];
	    if ((0 == expandWord)
		    /* Haven't seen prefix already */
		    && (1 == parsePtr->numTokens - expIdx)
		    /* Only one token */
		    && ((1 == (size_t) expPtr->size)
			    /* Same length as prefix */
			    && ((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 = (expPtr->start[0] == '#') ? 2 : 1;
		parsePtr->numTokens--;
		goto parseWord;
	    }
	} else {
	    /*
	     * This is an unquoted word. Call ParseTokens and let it do all of
	     * the work.
................................................................................
	 * Finish filling in the token for the word and check for the special
	 * case of a word consisting of a single range of literal text.
	 */

	tokenPtr = &parsePtr->tokenPtr[wordIndex];
	tokenPtr->size = src - tokenPtr->start;
	tokenPtr->numComponents = parsePtr->numTokens - (wordIndex + 1);
	if (expandWord == 1) {
	    int i, isLiteral = 1;

	    /*
	     * When a command includes a word that is an expanded literal; for
	     * example, {*}{1 2 3}, the parser performs that expansion
	     * immediately, generating several TCL_TOKEN_SIMPLE_WORDs instead
	     * of a single TCL_TOKEN_EXPAND_WORD that the Tcl_ParseCommand()
................................................................................
		 * The word to be expanded is not a literal, so defer
		 * expansion to compile/eval time by marking with a
		 * TCL_TOKEN_EXPAND_WORD token.
		 */

		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;
	}

	/*
	 * Do two additional checks: (a) make sure we're really at the end of

Changes to generic/tclTest.c.

3614
3615
3616
3617
3618
3619
3620



3621
3622
3623
3624
3625
3626
3627
    Tcl_ListObjAppendElement(NULL, objPtr,
	    Tcl_NewIntObj(parsePtr->numWords));
    for (i = 0; i < parsePtr->numTokens; i++) {
	tokenPtr = &parsePtr->tokenPtr[i];
	switch (tokenPtr->type) {
	case TCL_TOKEN_EXPAND_WORD:
	    typeString = "expand";



	    break;
	case TCL_TOKEN_WORD:
	    typeString = "word";
	    break;
	case TCL_TOKEN_SIMPLE_WORD:
	    typeString = "simple";
	    break;






>
>
>







3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
    Tcl_ListObjAppendElement(NULL, objPtr,
	    Tcl_NewIntObj(parsePtr->numWords));
    for (i = 0; i < parsePtr->numTokens; i++) {
	tokenPtr = &parsePtr->tokenPtr[i];
	switch (tokenPtr->type) {
	case TCL_TOKEN_EXPAND_WORD:
	    typeString = "expand";
	    break;
	case TCL_TOKEN_COMMENT_WORD:
	    typeString = "comment";
	    break;
	case TCL_TOKEN_WORD:
	    typeString = "word";
	    break;
	case TCL_TOKEN_SIMPLE_WORD:
	    typeString = "simple";
	    break;

Changes to generic/tclUtil.c.

442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
...
492
493
494
495
496
497
498





499
500
501
502
503
504
505
...
522
523
524
525
526
527
528
529
530
531


532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
...
554
555
556
557
558
559
560









561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
















577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
...
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
...
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
...
673
674
675
676
677
678
679



























680
681
682
683
684
685
686
687





























688
689
690
691
692
693
694
 *	successfully located. If TCL_ERROR is returned it means that list
 *	didn't have proper list structure; the interp's result contains a more
 *	detailed error message.
 *
 *	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,
 *	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
 *	the element is in braces, then *elementPtr will point to the character
 *	after the opening brace and *sizePtr will not include either of the
 *	braces. If there isn't an element in the list, *sizePtr will be zero,
 *	and both *elementPtr and *nextPtr will point just after the last
................................................................................
				 * TclCopyAndCollapse() by the caller. */
{
    const char *p = list;
    const char *elemStart;	/* Points to first byte of first element. */
    const char *limit;		/* Points just after list's last byte. */
    int openBraces = 0;		/* Brace nesting level during parse. */
    int inQuotes = 0;





    int size = 0;		/* lint. */
    int numChars;
    int literal = 1;
    const char *p2;

    /*
     * Skim off leading white space and check for an opening brace or quote.
................................................................................
    } else if (*p == '"') {
	inQuotes = 1;
	p++;
    }
    elemStart = p;

    /*
     * Find element's end (a space, close brace, or the end of the string).
     */



    while (p < limit) {
	switch (*p) {
	    /*
	     * Open brace: don't treat specially unless the element is in
	     * braces. In this case, keep a nesting count.
	     */

	case '{':
	    if (openBraces != 0) {
		openBraces++;
	    }
	    break;

	    /*
	     * Close brace: if element is in braces, keep nesting count and
	     * quit when the last close brace is seen.
	     */

	case '}':
	    if (openBraces > 1) {
		openBraces--;
	    } else if (openBraces == 1) {
................................................................................
		size = (p - elemStart);
		p++;
		if ((p >= limit) || TclIsSpaceProc(*p)) {
		    goto done;
		}

		/*









		 * 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;
















	    }
	    break;

	    /*
	     * Backslash: skip over everything up to the end of the backslash
	     * sequence.
	     */

	case '\\':
	    if (openBraces == 0) {
		/*
		 * A backslash sequence not within a brace quoted element
		 * 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.
		 */
		literal = 0;
	    }
	    TclParseBackslash(p, limit - p, &numChars, NULL);
	    p += (numChars - 1);
	    break;

	    /*
	     * Space: ignore if element is in braces or quotes; otherwise
	     * terminate element.
	     */

	case ' ':
	case '\f':
	case '\n':
	case '\r':
	case '\t':
................................................................................
	    if ((openBraces == 0) && !inQuotes) {
		size = (p - elemStart);
		goto done;
	    }
	    break;

	    /*
	     * Double-quote: if element is in quotes then terminate it.
	     */

	case '"':
	    if (inQuotes) {
		size = (p - elemStart);
		p++;
		if ((p >= limit) || TclIsSpaceProc(*p)) {
................................................................................
	    }
	    break;
	}
	p++;
    }

    /*
     * End of list: terminate element.
     */

    if (p == limit) {
	if (openBraces != 0) {
	    if (interp != NULL) {
		Tcl_SetResult(interp, "unmatched open brace in list",
			TCL_STATIC);
................................................................................
	size = (p - elemStart);
    }

  done:
    while ((p < limit) && (TclIsSpaceProc(*p))) {
	p++;
    }



























    *elementPtr = elemStart;
    *nextPtr = p;
    if (sizePtr != 0) {
	*sizePtr = size;
    }
    if (literalPtr != 0) {
	*literalPtr = literal;
    }





























    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclCopyAndCollapse --






|







 







>
>
>
>
>







 







|


>
>



|










|







 







>
>
>
>
>
>
>
>
>
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>











|











|
|







 







|







 







|







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
<
|
|
|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
...
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
...
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
...
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
...
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
...
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
...
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739

740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
 *	successfully located. If TCL_ERROR is returned it means that list
 *	didn't have proper list structure; the interp's result contains a more
 *	detailed error message.
 *
 *	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 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
 *	the element is in braces, then *elementPtr will point to the character
 *	after the opening brace and *sizePtr will not include either of the
 *	braces. If there isn't an element in the list, *sizePtr will be zero,
 *	and both *elementPtr and *nextPtr will point just after the last
................................................................................
				 * TclCopyAndCollapse() by the caller. */
{
    const char *p = list;
    const char *elemStart;	/* Points to first byte of first element. */
    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;
    const char *p2;

    /*
     * Skim off leading white space and check for an opening brace or quote.
................................................................................
    } else if (*p == '"') {
	inQuotes = 1;
	p++;
    }
    elemStart = p;

    /*
     * 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 word is in
	     * braces. In this case, keep a nesting count.
	     */

	case '{':
	    if (openBraces != 0) {
		openBraces++;
	    }
	    break;

	    /*
	     * Close brace: if word is in braces, keep nesting count and
	     * quit when the last close brace is seen.
	     */

	case '}':
	    if (openBraces > 1) {
		openBraces--;
	    } else if (openBraces == 1) {
................................................................................
		size = (p - elemStart);
		p++;
		if ((p >= limit) || TclIsSpaceProc(*p)) {
		    goto done;
		}

		/*
		 * 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;
                }
                
		/* 
		 * 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;

	    /*
	     * Backslash: skip over everything up to the end of the backslash
	     * sequence.
	     */

	case '\\':
	    if (openBraces == 0) {
		/*
		 * 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.
		 */
		literal = 0;
	    }
	    TclParseBackslash(p, limit - p, &numChars, NULL);
	    p += (numChars - 1);
	    break;

	    /*
	     * Space: ignore if word is in braces or quotes; otherwise
	     * terminate word.
	     */

	case ' ':
	case '\f':
	case '\n':
	case '\r':
	case '\t':
................................................................................
	    if ((openBraces == 0) && !inQuotes) {
		size = (p - elemStart);
		goto done;
	    }
	    break;

	    /*
	     * Double-quote: if word is in quotes then terminate it.
	     */

	case '"':
	    if (inQuotes) {
		size = (p - elemStart);
		p++;
		if ((p >= limit) || TclIsSpaceProc(*p)) {
................................................................................
	    }
	    break;
	}
	p++;
    }

    /*
     * End of list: terminate word.
     */

    if (p == limit) {
	if (openBraces != 0) {
	    if (interp != NULL) {
		Tcl_SetResult(interp, "unmatched open brace in list",
			TCL_STATIC);
................................................................................
	size = (p - elemStart);
    }

  done:
    while ((p < limit) && (TclIsSpaceProc(*p))) {
	p++;
    }
    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;
    
    /* 
     * 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;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclCopyAndCollapse --

Changes to tests/basic.test.

651
652
653
654
655
656
657




658
659
660
661




662
663
664
665




666
667
668
669








670
671
672
673
674
675
676
...
681
682
683
684
685
686
687






688
689
690
691
692
693
694
    interp alias {} run {} if 1
    set constraints {}
}

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.3.$noComp {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.5.$noComp {Tcl_EvalEx: expansion} $constraints {
    run {list {*}{} {*}	{*}x {*}"y z"}
} {* x y z}









test basic-47.6.$noComp {Tcl_EvalEx: expansion to zero args} $constraints {
    run {list {*}{}}
} {}

test basic-47.7.$noComp {Tcl_EvalEx: expansion to one arg} $constraints {
    run {list {*}x}
................................................................................
} {y z}

test basic-47.9.$noComp {Tcl_EvalEx: expansion and subst order} $constraints {
    set x 0
    run {list [incr x] {*}[incr x] [incr x] \
		{*}[list [incr x] [incr x]] [incr x]}
} {1 2 3 4 5 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}

test basic-47.11.$noComp {Tcl_EvalEx: expand and memory management} $constraints {
    run {concat {*}1 a b c d e f g h i j k l m n o p q r}






>
>
>
>




>
>
>
>




>
>
>
>




>
>
>
>
>
>
>
>







 







>
>
>
>
>
>







651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
...
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
    interp alias {} run {} if 1
    set constraints {}
}

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 {*}{}}
} {}

test basic-47.7.$noComp {Tcl_EvalEx: expansion to one arg} $constraints {
    run {list {*}x}
................................................................................
} {y z}

test basic-47.9.$noComp {Tcl_EvalEx: expansion and subst order} $constraints {
    set x 0
    run {list [incr x] {*}[incr x] [incr x] \
		{*}[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}

test basic-47.11.$noComp {Tcl_EvalEx: expand and memory management} $constraints {
    run {concat {*}1 a b c d e f g h i j k l m n o p q r}

Changes to tests/dict.test.

118
119
120
121
122
123
124








125
126
127
128
129
130
131
    apply {{} {
	dict set a(z) b c
	dict get $a(z) d
    }}
} -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-4.1 {dict replace command} {
    dict replace {a b c d}
} {a b c d}
test dict-4.2 {dict replace command} {
    dict replace {a b c d} e f
} {a b c d e f}






>
>
>
>
>
>
>
>







118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
    apply {{} {
	dict set a(z) b c
	dict get $a(z) d
    }}
} -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}
} {a b c d}
test dict-4.2 {dict replace command} {
    dict replace {a b c d} e f
} {a b c d e f}

Changes to tests/lindex.test.

125
126
127
128
129
130
131


132
133
134
135
136
137
138
...
336
337
338
339
340
341
342


343
344
345
346
347
348
349
350
351
352



353
354
355
356
357
358
359
...
371
372
373
374
375
376
377


















378
379
380
381
382
383
384
} {1 {bad index "0a2": must be integer?[+-]integer? or end?[+-]integer?}}
test lindex-5.2 {good second index} testevalex {
    testevalex {lindex {{a b c} {d e f} {g h i}} 1 2}
} f
test lindex-5.3 {three indices} testevalex {
    testevalex {lindex {{{a b} {c d}} {{e f} {g h}}} 1 0 1}
} f



test lindex-6.1 {error conditions in parsing list} testevalex {
    list [catch {testevalex {lindex "a \{" 2}} msg] $msg
} {1 {unmatched open brace in list}}
test lindex-6.2 {error conditions in parsing list} testevalex {
    list [catch {testevalex {lindex {a {b c}d e} 2}} msg] $msg
} {1 {list element in braces followed by "d" instead of space}}
................................................................................
} f
test lindex-13.3 {three indices} {
    catch {
	lindex {{{a b} {c d}} {{e f} {g h}}} 1 0 1
    } result
    set result
} f



test lindex-14.1 {error conditions in parsing list} {
    list [catch { lindex "a \{" 2 } msg] $msg
} {1 {unmatched open brace in list}}
test lindex-14.2 {error conditions in parsing list} {
    list [catch { lindex {a {b c}d e} 2 } msg] $msg
} {1 {list element in braces followed by "d" instead of space}}
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-15.1 {quoted elements} {
    catch {
	lindex {a "b c" d} 1
    } result
    set result
} {b c}
................................................................................
} {c d " x}
test lindex-15.4 {quoted elements} {
    catch {
	lindex {a b {c d "e} {f g"}} 2
    } result
    set result
} {c d "e}



















test lindex-16.1 {data reuse} {
    set x 0
    catch {
	lindex $x $x
    } result
    set result






>
>







 







>
>










>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
...
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
...
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
} {1 {bad index "0a2": must be integer?[+-]integer? or end?[+-]integer?}}
test lindex-5.2 {good second index} testevalex {
    testevalex {lindex {{a b c} {d e f} {g h i}} 1 2}
} f
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}}
test lindex-6.2 {error conditions in parsing list} testevalex {
    list [catch {testevalex {lindex {a {b c}d e} 2}} msg] $msg
} {1 {list element in braces followed by "d" instead of space}}
................................................................................
} f
test lindex-13.3 {three indices} {
    catch {
	lindex {{{a b} {c d}} {{e f} {g h}}} 1 0 1
    } result
    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}}
test lindex-14.2 {error conditions in parsing list} {
    list [catch { lindex {a {b c}d e} 2 } msg] $msg
} {1 {list element in braces followed by "d" instead of space}}
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 {
	lindex {a "b c" d} 1
    } result
    set result
} {b c}
................................................................................
} {c d " x}
test lindex-15.4 {quoted elements} {
    catch {
	lindex {a b {c d "e} {f g"}} 2
    } 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
    catch {
	lindex $x $x
    } result
    set result

Changes to tests/listObj.test.

103
104
105
106
107
108
109




110
111
112
113
114
115
116
...
166
167
168
169
170
171
172



173
174
175
176
177
178
179
test listobj-5.7 {Tcl_ListObjIndex, basic tests} {
    lindex {} -1
} {}
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-6.1 {Tcl_ListObjLength} {
    llength {a b c d}
} 4
test listobj-6.2 {Tcl_ListObjLength} {
    llength {a b c {a b {c d}} d}
} 5
................................................................................
test listobj-7.13 {Tcl_ListObjReplace, grow array, insert at end} {
    lreplace {1 2 3 4 5} 4 1 a b c d e f g h i j k l
} {1 2 3 4 a b c d e f g h i j k l 5}

test listobj-8.1 {SetListFromAny} {
    lindex {0 foo\x00help 2} 1
} "foo\x00help"




test listobj-9.1 {UpdateStringOfList} {
    string length [list foo\x00help]
} 8

test listobj-10.1 {Bug [2971669]} {*}{
    -constraints testobj






>
>
>
>







 







>
>
>







103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
...
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
test listobj-5.7 {Tcl_ListObjIndex, basic tests} {
    lindex {} -1
} {}
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}
} 4
test listobj-6.2 {Tcl_ListObjLength} {
    llength {a b c {a b {c d}} d}
} 5
................................................................................
test listobj-7.13 {Tcl_ListObjReplace, grow array, insert at end} {
    lreplace {1 2 3 4 5} 4 1 a b c d e f g h i j k l
} {1 2 3 4 a b c d e f g h i j k l 5}

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]
} 8

test listobj-10.1 {Bug [2971669]} {*}{
    -constraints testobj

Changes to tests/llength.test.

21
22
23
24
25
26
27













28
29
30
31
32
33
34
} 4
test llength-1.2 {length of list} {
    llength {a b c {a b {c d}} d}
} 5
test llength-1.3 {length of list} {
    llength {}
} 0














test llength-2.1 {error conditions} {
    list [catch {llength} msg] $msg
} {1 {wrong # args: should be "llength list"}}
test llength-2.2 {error conditions} {
    list [catch {llength 123 2} msg] $msg
} {1 {wrong # args: should be "llength list"}}






>
>
>
>
>
>
>
>
>
>
>
>
>







21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
} 4
test llength-1.2 {length of list} {
    llength {a b c {a b {c d}} d}
} 5
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
} {1 {wrong # args: should be "llength list"}}
test llength-2.2 {error conditions} {
    list [catch {llength 123 2} msg] $msg
} {1 {wrong # args: should be "llength list"}}