Tcl Source Code

Check-in [fc4c109c84]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to tclconference@googlegroups.com
or submit via the online form by Sep 9.

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

Overview
Comment:
[kennykb-numerics-branch]
* generic/tclScan.c: Extended scan to accept the %lld, %llo, %llx, and %lli formats. Numeric scanning is now done via TclParseNumber calls.
* generic/tclInt.h: Extended TclParseNumber to accept new flag * generic/tclStrToD.c: values TCL_PARSE_INTEGER_ONLY, TCL_PARSE_OCTAL_ONLY, and TCL_PARSE_HEXIDECIMAL_ONLY, to give caller more control over the parsing rules.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | kennykb-numerics-branch
Files: files | file ages | folders
SHA1:fc4c109c84c44373f3b711ed98861401d2a0db3f
User & Date: dgp 2005-09-01 16:09:56
Context
2005-09-01
16:27
* generic/tclObj.c: TclParseNumber calls meant to parse an integer value now pas...
check-in: 6e311ccfa4 user: dgp tags: kennykb-numerics-branch
16:09
[kennykb-numerics-branch]
* generic/tclScan.c: Extended scan to accept the %ll...
check-in: fc4c109c84 user: dgp tags: kennykb-numerics-branch
2005-08-30
19:20
[kennykb-numerics-branch]
* generic/tclObj.c: Extended bignum support to includ...
check-in: 4ef199b1b3 user: dgp tags: kennykb-numerics-branch
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ChangeLog.














1
2
3
4
5
6
7













2005-08-30  Don Porter  <dgp@users.sourceforge.net>

	[kennykb-numerics-branch]

	* generic/tclObj.c:	Extended bignum support to include bignums
	so large they will not pack into a Tcl_Obj.  When they outgrow Tcl's
	string rep length limits, a panic will result.
>
>
>
>
>
>
>
>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
2005-09-01  Don Porter  <dgp@users.sourceforge.net>

	[kennykb-numerics-branch]

	* generic/tclScan.c:	Extended [scan] to accept the %lld,
	%llo, %llx, and %lli formats.  Numeric scanning is now done
	via TclParseNumber calls.

	* generic/tclInt.h:	Extended TclParseNumber to accept new flag
	* generic/tclStrToD.c:	values TCL_PARSE_INTEGER_ONLY,
	TCL_PARSE_OCTAL_ONLY, and TCL_PARSE_HEXIDECIMAL_ONLY, to give caller
	more control over the parsing rules.

2005-08-30  Don Porter  <dgp@users.sourceforge.net>

	[kennykb-numerics-branch]

	* generic/tclObj.c:	Extended bignum support to include bignums
	so large they will not pack into a Tcl_Obj.  When they outgrow Tcl's
	string rep length limits, a panic will result.

Changes to generic/tclInt.h.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
....
1887
1888
1889
1890
1891
1892
1893





1894
1895
1896
1897
1898
1899
1900
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 1998-19/99 by Scriptics Corporation.
 * Copyright (c) 2001, 2002 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclInt.h,v 1.202.2.35 2005/08/29 18:38:45 dgp Exp $
 */

#ifndef _TCLINT
#define _TCLINT

/*
 * Some numerics configuration options
................................................................................
 *----------------------------------------------------------------------
 * Flags for TclParseNumber
 *----------------------------------------------------------------------
 */

#define TCL_PARSE_DECIMAL_ONLY 1
				/* Leading zero doesn't denote octal or hex */






/*
 *----------------------------------------------------------------
 * Variables shared among Tcl modules but not used by the outside world.
 *----------------------------------------------------------------
 */








|







 







>
>
>
>
>







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
....
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 1998-19/99 by Scriptics Corporation.
 * Copyright (c) 2001, 2002 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclInt.h,v 1.202.2.36 2005/09/01 16:09:56 dgp Exp $
 */

#ifndef _TCLINT
#define _TCLINT

/*
 * Some numerics configuration options
................................................................................
 *----------------------------------------------------------------------
 * Flags for TclParseNumber
 *----------------------------------------------------------------------
 */

#define TCL_PARSE_DECIMAL_ONLY 1
				/* Leading zero doesn't denote octal or hex */
#define TCL_PARSE_OCTAL_ONLY 2	/* Parse octal even without prefix */
#define TCL_PARSE_HEXADECIMAL_ONLY 4
				/* Parse hexadecimal even without prefix */
#define TCL_PARSE_INTEGER_ONLY 8
				/* Disable floating point parsing */

/*
 *----------------------------------------------------------------
 * Variables shared among Tcl modules but not used by the outside world.
 *----------------------------------------------------------------
 */

Changes to generic/tclScan.c.

4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24

25
26
27
28
29
30

31
32

33
34
35
36
37
38
39
...
362
363
364
365
366
367
368






369
370
371
372
373
374
375
...
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413

414





415
416
417
418
419
420
421
422
423
424
425
426
427
428
...
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
...
627
628
629
630
631
632
633

634
635
636
637
638
639
640
...
674
675
676
677
678
679
680

681
682
683
684
685
686
687
688
689
690
...
699
700
701
702
703
704
705






706
707
708
709
710
711
712
...
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
...
899
900
901
902
903
904
905

906
907
908
909
910
911
912
....
1045
1046
1047
1048
1049
1050
1051





1052











































1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065

1066
1067
1068
1069
1070
1071
1072
1073






1074
1075

1076
1077
1078
1079
1080
1081
1082
 *	This file contains the implementation of the "scan" command.
 *
 * Copyright (c) 1998 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclScan.c,v 1.16.2.3 2005/08/23 18:28:51 kennykb Exp $
 */

#include "tclInt.h"

/*
 * Flag values used by Tcl_ScanObjCmd.
 */

#define SCAN_NOSKIP	0x1		/* Don't skip blanks. */
#define SCAN_SUPPRESS	0x2		/* Suppress assignment. */
#define SCAN_UNSIGNED	0x4		/* Read an unsigned value. */
#define SCAN_WIDTH	0x8		/* A width value was supplied. */


#define SCAN_SIGNOK	0x10		/* A +/- character is allowed. */
#define SCAN_NODIGITS	0x20		/* No digits have been scanned. */
#define SCAN_NOZERO	0x40		/* No zero digits have been scanned. */
#define SCAN_XOK	0x80		/* An 'x' is allowed. */
#define SCAN_PTOK	0x100		/* Decimal point is allowed. */
#define SCAN_EXPOK	0x200		/* An exponent is allowed. */


#define SCAN_LONGER	0x400		/* Asked for a wide value. */


/*
 * The following structure contains the information associated with a
 * character set.
 */

typedef struct CharSet {
................................................................................

	/*
	 * Handle any size specifier.
	 */

	switch (ch) {
	case 'l':






	case 'L':
	    flags |= SCAN_LONGER;
	case 'h':
	    format += Tcl_UtfToUniChar(format, &ch);
	}

	if (!(flags & SCAN_SUPPRESS) && numVars && (objIndex >= numVars)) {
................................................................................
		goto error;
	    }
	    /*
	     * Fall through!
	     */
	case 'n':
	case 's':
	    if (flags & SCAN_LONGER) {
	    invalidLonger:
		buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
		Tcl_AppendResult(interp,
			"'l' modifier may not be specified in %", buf,
			" conversion", NULL);
		goto error;
	    }
	    /*
	     * Fall through!
	     */
	case 'd':
	case 'e':
	case 'f':
	case 'g':
	case 'i':
	case 'o':
	case 'u':

	case 'x':





	    break;
	    /*
	     * Bracket terms need special checking
	     */
	case '[':
	    if (flags & SCAN_LONGER) {
		goto invalidLonger;
	    }
	    if (*format == '\0') {
		goto badSet;
	    }
	    format += Tcl_UtfToUniChar(format, &ch);
	    if (ch == '^') {
		if (*format == '\0') {
................................................................................
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    char *format;
    int numVars, nconversions, totalVars = -1;
    int objIndex, offset, i, result, code;
    long value;
    char *string, *end, *baseString;
    char op = 0;
    int base = 0;
    int underflow = 0;
    size_t width;
    long (*fn) _ANSI_ARGS_((char*,void*,int)) = NULL;
#ifndef TCL_WIDE_INT_IS_LONG
    Tcl_WideInt (*lfn) _ANSI_ARGS_((char*,void*,int)) = NULL;
    Tcl_WideInt wideValue;
#endif
    Tcl_UniChar ch, sch;
    Tcl_Obj **objs = NULL, *objPtr = NULL;
    int flags;
    char buf[513];		/* Temporary buffer to hold scanned number
				 * strings before they are passed to
				 * strtoul. */








    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"string format ?varName varName ...?");
	return TCL_ERROR;
    }

................................................................................
     * reach the end of input, the end of the format string, or there is a
     * mismatch.
     */

    objIndex = 0;
    nconversions = 0;
    while (*format != '\0') {

	format += Tcl_UtfToUniChar(format, &ch);

	flags = 0;

	/*
	 * If we see whitespace in the format, skip whitespace in the string.
	 */
................................................................................
	 * ('%n$').
	 */

	if (ch == '*') {
	    flags |= SCAN_SUPPRESS;
	    format += Tcl_UtfToUniChar(format, &ch);
	} else if ((ch < 0x80) && isdigit(UCHAR(ch))) {	/* INTL: "C" locale. */

	    value = strtoul(format-1, &end, 10);	/* INTL: "C" locale. */
	    if (*end == '$') {
		format = end+1;
		format += Tcl_UtfToUniChar(format, &ch);
		objIndex = (int) value - 1;
	    }
	}

	/*
	 * Parse any width specifier.
................................................................................

	/*
	 * Handle any size specifier.
	 */

	switch (ch) {
	case 'l':






	case 'L':
	    flags |= SCAN_LONGER;
	    /*
	     * Fall through so we skip to the next character.
	     */
	case 'h':
	    format += Tcl_UtfToUniChar(format, &ch);
................................................................................
		objs[objIndex++] = objPtr;
	    }
	    nconversions++;
	    continue;

	case 'd':
	    op = 'i';


	    base = 10;
	    fn = (long (*) _ANSI_ARGS_((char*,void*,int)))strtol;
#ifndef TCL_WIDE_INT_IS_LONG
	    lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoll;

#endif
	    break;
	case 'i':
	    op = 'i';

	    base = 0;
	    fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtol;
#ifndef TCL_WIDE_INT_IS_LONG
	    lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoll;

#endif
	    break;
	case 'o':
	    op = 'i';


	    base = 8;
	    fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtoul;
#ifndef TCL_WIDE_INT_IS_LONG
	    lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoull;

#endif
	    break;
	case 'x':
	    op = 'i';


	    base = 16;
	    fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtoul;
#ifndef TCL_WIDE_INT_IS_LONG
	    lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoull;

#endif
	    break;
	case 'u':
	    op = 'i';
	    base = 10;
	    flags |= SCAN_UNSIGNED;


	    fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtoul;
#ifndef TCL_WIDE_INT_IS_LONG
	    lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoull;

#endif
	    break;

	case 'f':
	case 'e':
	case 'g':
	    op = 'f';
................................................................................
	    break;

	case 'i':
	    /*
	     * Scan an unsigned or signed integer.
	     */


	    if ((width == 0) || (width > sizeof(buf) - 1)) {
		width = sizeof(buf) - 1;
	    }
	    flags |= SCAN_SIGNOK | SCAN_NODIGITS | SCAN_NOZERO;
	    for (end = buf; width > 0; width--) {
		switch (*string) {
		    /*
................................................................................
		}
#endif
		Tcl_IncrRefCount(objPtr);
		objs[objIndex++] = objPtr;
	    }

	    break;

















































	case 'f':
	    /*
	     * Scan a floating point number
	     */

	    flags &= ~SCAN_LONGER;
	    objPtr = Tcl_NewObj();
	    Tcl_IncrRefCount(objPtr);
	    if (width == 0) {
		width = -1;
	    }
	    if (TclParseNumber(NULL, objPtr, "", string, width, &end,
			       TCL_PARSE_DECIMAL_ONLY) != TCL_OK) {

		Tcl_DecrRefCount(objPtr);
		goto done;
	    } else if (flags & SCAN_SUPPRESS) {
		Tcl_DecrRefCount(objPtr);
		string = end;
	    } else {
		double dvalue;
		if (Tcl_GetDoubleFromObj(NULL, objPtr, &dvalue) != TCL_OK) {






		    Tcl_DecrRefCount(objPtr);
		    goto done;

		}
		Tcl_SetDoubleObj(objPtr, dvalue);
		objs[objIndex++] = objPtr;
		string = end;
	    }
	}
	nconversions++;







|













>






>


>







 







>
>
>
>
>
>







 







|
|


|












|
>
|
>
>
>
>
>





|
|







 







|

<


<
<
<

<






>
>
>
>
>
>
>







 







>







 







>
|
|
|







 







>
>
>
>
>
>







 







>
>




>




>




>




>
>




>




>
>




>




<

>
>



>







 







>







 







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





<
|




|

>








>
>
>
>
>
>


>







4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
...
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
...
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
...
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
...
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
...
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
...
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
...
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
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798

799
800
801
802
803
804
805
806
807
808
809
810
811
812
...
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
....
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144

1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
 *	This file contains the implementation of the "scan" command.
 *
 * Copyright (c) 1998 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclScan.c,v 1.16.2.4 2005/09/01 16:09:57 dgp Exp $
 */

#include "tclInt.h"

/*
 * Flag values used by Tcl_ScanObjCmd.
 */

#define SCAN_NOSKIP	0x1		/* Don't skip blanks. */
#define SCAN_SUPPRESS	0x2		/* Suppress assignment. */
#define SCAN_UNSIGNED	0x4		/* Read an unsigned value. */
#define SCAN_WIDTH	0x8		/* A width value was supplied. */

#if 0
#define SCAN_SIGNOK	0x10		/* A +/- character is allowed. */
#define SCAN_NODIGITS	0x20		/* No digits have been scanned. */
#define SCAN_NOZERO	0x40		/* No zero digits have been scanned. */
#define SCAN_XOK	0x80		/* An 'x' is allowed. */
#define SCAN_PTOK	0x100		/* Decimal point is allowed. */
#define SCAN_EXPOK	0x200		/* An exponent is allowed. */
#endif

#define SCAN_LONGER	0x400		/* Asked for a wide value. */
#define SCAN_BIG	0x800		/* Asked for a bignum value. */

/*
 * The following structure contains the information associated with a
 * character set.
 */

typedef struct CharSet {
................................................................................

	/*
	 * Handle any size specifier.
	 */

	switch (ch) {
	case 'l':
	    if (*format == 'l') {
		flags |= SCAN_BIG;
		format += 1;
		format += Tcl_UtfToUniChar(format, &ch);
		break;
	    }
	case 'L':
	    flags |= SCAN_LONGER;
	case 'h':
	    format += Tcl_UtfToUniChar(format, &ch);
	}

	if (!(flags & SCAN_SUPPRESS) && numVars && (objIndex >= numVars)) {
................................................................................
		goto error;
	    }
	    /*
	     * Fall through!
	     */
	case 'n':
	case 's':
	    if (flags & (SCAN_LONGER|SCAN_BIG)) {
	    invalidFieldSize:
		buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
		Tcl_AppendResult(interp,
			"field size modifier may not be specified in %", buf,
			" conversion", NULL);
		goto error;
	    }
	    /*
	     * Fall through!
	     */
	case 'd':
	case 'e':
	case 'f':
	case 'g':
	case 'i':
	case 'o':
	case 'x':
	    break;
	case 'u':
	    if (flags & SCAN_BIG) {
		Tcl_SetResult(interp,
			"unsigned bignum scans are invalid", TCL_STATIC);
		goto error;
	    }
	    break;
	    /*
	     * Bracket terms need special checking
	     */
	case '[':
	    if (flags & (SCAN_LONGER|SCAN_BIG)) {
		goto invalidFieldSize;
	    }
	    if (*format == '\0') {
		goto badSet;
	    }
	    format += Tcl_UtfToUniChar(format, &ch);
	    if (ch == '^') {
		if (*format == '\0') {
................................................................................
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    char *format;
    int numVars, nconversions, totalVars = -1;
    int objIndex, offset, i, result, code;
    long value;
    CONST char *string, *end, *baseString;
    char op = 0;

    int underflow = 0;
    size_t width;



    Tcl_WideInt wideValue;

    Tcl_UniChar ch, sch;
    Tcl_Obj **objs = NULL, *objPtr = NULL;
    int flags;
    char buf[513];		/* Temporary buffer to hold scanned number
				 * strings before they are passed to
				 * strtoul. */
#if 0
    int base = 0;
    long (*fn) _ANSI_ARGS_((char*,void*,int)) = NULL;
#ifndef TCL_WIDE_INT_IS_LONG
    Tcl_WideInt (*lfn) _ANSI_ARGS_((char*,void*,int)) = NULL;
#endif
#endif

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"string format ?varName varName ...?");
	return TCL_ERROR;
    }

................................................................................
     * reach the end of input, the end of the format string, or there is a
     * mismatch.
     */

    objIndex = 0;
    nconversions = 0;
    while (*format != '\0') {
	int parseFlag = 0;
	format += Tcl_UtfToUniChar(format, &ch);

	flags = 0;

	/*
	 * If we see whitespace in the format, skip whitespace in the string.
	 */
................................................................................
	 * ('%n$').
	 */

	if (ch == '*') {
	    flags |= SCAN_SUPPRESS;
	    format += Tcl_UtfToUniChar(format, &ch);
	} else if ((ch < 0x80) && isdigit(UCHAR(ch))) {	/* INTL: "C" locale. */
	    char *formatEnd;
	    value = strtoul(format-1, &formatEnd, 10);/* INTL: "C" locale. */
	    if (*formatEnd == '$') {
		format = formatEnd+1;
		format += Tcl_UtfToUniChar(format, &ch);
		objIndex = (int) value - 1;
	    }
	}

	/*
	 * Parse any width specifier.
................................................................................

	/*
	 * Handle any size specifier.
	 */

	switch (ch) {
	case 'l':
	    if (*format == 'l') {
		flags |= SCAN_BIG;
		format += 1;
		format += Tcl_UtfToUniChar(format, &ch);
		break;
	    }
	case 'L':
	    flags |= SCAN_LONGER;
	    /*
	     * Fall through so we skip to the next character.
	     */
	case 'h':
	    format += Tcl_UtfToUniChar(format, &ch);
................................................................................
		objs[objIndex++] = objPtr;
	    }
	    nconversions++;
	    continue;

	case 'd':
	    op = 'i';
	    parseFlag = TCL_PARSE_DECIMAL_ONLY;
#if 0
	    base = 10;
	    fn = (long (*) _ANSI_ARGS_((char*,void*,int)))strtol;
#ifndef TCL_WIDE_INT_IS_LONG
	    lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoll;
#endif
#endif
	    break;
	case 'i':
	    op = 'i';
#if 0
	    base = 0;
	    fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtol;
#ifndef TCL_WIDE_INT_IS_LONG
	    lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoll;
#endif
#endif
	    break;
	case 'o':
	    op = 'i';
	    parseFlag = TCL_PARSE_OCTAL_ONLY;
#if 0
	    base = 8;
	    fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtoul;
#ifndef TCL_WIDE_INT_IS_LONG
	    lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoull;
#endif
#endif
	    break;
	case 'x':
	    op = 'i';
	    parseFlag = TCL_PARSE_HEXADECIMAL_ONLY;
#if 0
	    base = 16;
	    fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtoul;
#ifndef TCL_WIDE_INT_IS_LONG
	    lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoull;
#endif
#endif
	    break;
	case 'u':
	    op = 'i';

	    flags |= SCAN_UNSIGNED;
#if 0
	    base = 10;
	    fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtoul;
#ifndef TCL_WIDE_INT_IS_LONG
	    lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoull;
#endif
#endif
	    break;

	case 'f':
	case 'e':
	case 'g':
	    op = 'f';
................................................................................
	    break;

	case 'i':
	    /*
	     * Scan an unsigned or signed integer.
	     */

#if 0
	    if ((width == 0) || (width > sizeof(buf) - 1)) {
		width = sizeof(buf) - 1;
	    }
	    flags |= SCAN_SIGNOK | SCAN_NODIGITS | SCAN_NOZERO;
	    for (end = buf; width > 0; width--) {
		switch (*string) {
		    /*
................................................................................
		}
#endif
		Tcl_IncrRefCount(objPtr);
		objs[objIndex++] = objPtr;
	    }

	    break;
#else
	    objPtr = Tcl_NewLongObj(0);
	    Tcl_IncrRefCount(objPtr);
	    if (width == 0) {
		width = -1;
	    }
	    if (TclParseNumber(NULL, objPtr, NULL, string, width, &end,
		    TCL_PARSE_INTEGER_ONLY | parseFlag) != TCL_OK) {
		Tcl_DecrRefCount(objPtr);
		/* TODO: set underflow?  test scan-4.44 */
		goto done;
	    }
	    string = end;
	    if (flags & SCAN_SUPPRESS) {
		Tcl_DecrRefCount(objPtr);
		break;
	    }
	    if (flags & SCAN_LONGER) {
		if (Tcl_GetWideIntFromObj(NULL, objPtr, &wideValue) != TCL_OK) {		    wideValue = ~(Tcl_WideUInt)0 >> 1;	/* WIDE_MAX */
		    if (Tcl_GetString(objPtr)[0] == '-') {
			wideValue++;	/* WIDE_MAX + 1 = WIDE_MIN */
		    }
		}
		if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) {
		    sprintf(buf, "%" TCL_LL_MODIFIER "u",
			    (Tcl_WideUInt)wideValue);
		    Tcl_SetStringObj(objPtr, buf, -1);
		} else {
		    Tcl_SetWideIntObj(objPtr, wideValue);
		}
	    } else if (!(flags & SCAN_BIG)) {
		if (Tcl_GetLongFromObj(NULL, objPtr, &value) != TCL_OK) {
		    if (Tcl_GetString(objPtr)[0] == '-') {
			value = LONG_MIN;
		    } else {
			value = LONG_MAX;
		    }
		}
		if ((flags & SCAN_UNSIGNED) && (value < 0)) {
		    sprintf(buf, "%lu", value);	/* INTL: ISO digit */
		    Tcl_SetStringObj(objPtr, buf, -1);
		} else {
		    Tcl_SetLongObj(objPtr, value);
		}
	    }
	    objs[objIndex++] = objPtr;
	    break;
#endif

	case 'f':
	    /*
	     * Scan a floating point number
	     */


	    objPtr = Tcl_NewDoubleObj(0.0);
	    Tcl_IncrRefCount(objPtr);
	    if (width == 0) {
		width = -1;
	    }
	    if (TclParseNumber(NULL, objPtr, NULL, string, width, &end,
			       TCL_PARSE_DECIMAL_ONLY) != TCL_OK) {
		/* TODO: set underflow?  test scan-4.55 */
		Tcl_DecrRefCount(objPtr);
		goto done;
	    } else if (flags & SCAN_SUPPRESS) {
		Tcl_DecrRefCount(objPtr);
		string = end;
	    } else {
		double dvalue;
		if (Tcl_GetDoubleFromObj(NULL, objPtr, &dvalue) != TCL_OK) {
#ifdef ACCEPT_NAN
		    if (objPtr->typePtr == &tclDoubleType) {
			dValue = objPtr->internalRep.doubleValue;
		    } else
#endif
		    {
		    Tcl_DecrRefCount(objPtr);
		    goto done;
		    }
		}
		Tcl_SetDoubleObj(objPtr, dvalue);
		objs[objIndex++] = objPtr;
		string = end;
	    }
	}
	nconversions++;

Changes to generic/tclStrToD.c.

10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
...
334
335
336
337
338
339
340




341
342
343
344
345


346
347
348
349
350
351
352
...
379
380
381
382
383
384
385



386
387
388
389
390
391
392
...
398
399
400
401
402
403
404

405
406
407
408
409
410
411
...
455
456
457
458
459
460
461




462
463
464
465
466
467
468
...
503
504
505
506
507
508
509

510
511
512
513
514
515
516
...
618
619
620
621
622
623
624


625
626
627
628
629
630
631
 *	interconversion among 'double' and 'mp_int' types.
 *
 * Copyright (c) 2005 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclStrToD.c,v 1.1.2.34 2005/08/24 21:49:23 dgp Exp $
 *
 *----------------------------------------------------------------------
 */

#include <tclInt.h>
#include <stdio.h>
#include <stdlib.h>
................................................................................
	    if (c == '0') {
		if (flags & TCL_PARSE_DECIMAL_ONLY) {
		    state = DECIMAL;
		} else {
		    state = ZERO;
		}
		break;




	    } else if (isdigit(UCHAR(c))) {
		significandWide = c - '0';
		numSigDigs = 1;
		state = DECIMAL;
		break;


	    } else if (c == '.') {
		state = LEADING_RADIX_POINT;
		break;
	    } else if (c == 'I' || c == 'i') {
		state = sI;
		break;
#ifdef IEEE_FLOATING_POINT
................................................................................
	    }
	    if (c == 'o' || c == 'O') {
		explicitOctal = 1;
		state = ZERO_O;
		break;
	    }
#endif



#ifdef KILL_OCTAL
	    goto decimal;
#endif
	    /* FALLTHROUGH */

	case OCTAL:
	    /*
................................................................................
	    acceptState = state;
	    acceptPoint = p;
	    acceptLen = len;
#ifdef TIP_114_FORMATS
	    /* FALLTHROUGH */
	case ZERO_O:
#endif

	    if (c == '0') {
		++numTrailZeros;
		state = OCTAL;
		break;
	    } else if (c >= '1' && c <= '7') {
		if (objPtr != NULL) {
		    shift = 3 * (numTrailZeros + 1);
................................................................................
	case BAD_OCTAL:
#ifdef TIP_114_FORMATS
	    if (explicitOctal) {
		/* No forgiveness for bad digits in explicitly octal numbers */
		goto endgame;
	    }
#endif




#ifndef KILL_OCTAL
	    /*
	     * Scanned a number with a leading zero that contains an
	     * 8, 9, radix point or E.  This is an invalid octal number,
	     * but might still be floating point.  
	     */
	    if (c == '0') {
................................................................................
	     */
	case HEXADECIMAL:
	    acceptState = state;
	    acceptPoint = p;
	    acceptLen = len;
	    /* FALLTHROUGH */
	case ZERO_X:

	    if (c == '0') {
		++numTrailZeros;
		state = HEXADECIMAL;
		break;
	    } else if (isdigit(UCHAR(c))) {
		d = (c-'0');
	    } else if (c >= 'A' && c <= 'F') {
................................................................................
					       &significandBig, 
					       significandOverflow);
		}
		numSigDigs += ( numTrailZeros + 1 );
		numTrailZeros = 0;
		state = DECIMAL;
		break;


	    } else if (c == '.') {
		state = FRACTION;
		break;
	    } else if (c == 'E' || c == 'e') {
		state = EXPONENT_START;
		break;
	    }







|







 







>
>
>
>





>
>







 







>
>
>







 







>







 







>
>
>
>







 







>







 







>
>







10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
...
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
...
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
...
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
...
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
...
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
...
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
 *	interconversion among 'double' and 'mp_int' types.
 *
 * Copyright (c) 2005 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclStrToD.c,v 1.1.2.35 2005/09/01 16:09:57 dgp Exp $
 *
 *----------------------------------------------------------------------
 */

#include <tclInt.h>
#include <stdio.h>
#include <stdlib.h>
................................................................................
	    if (c == '0') {
		if (flags & TCL_PARSE_DECIMAL_ONLY) {
		    state = DECIMAL;
		} else {
		    state = ZERO;
		}
		break;
	    } else if (flags & TCL_PARSE_HEXADECIMAL_ONLY) {
		goto zerox;
	    } else if (flags & TCL_PARSE_OCTAL_ONLY) {
		goto zeroo;
	    } else if (isdigit(UCHAR(c))) {
		significandWide = c - '0';
		numSigDigs = 1;
		state = DECIMAL;
		break;
	    } else if (flags & TCL_PARSE_INTEGER_ONLY) {
		goto endgame;
	    } else if (c == '.') {
		state = LEADING_RADIX_POINT;
		break;
	    } else if (c == 'I' || c == 'i') {
		state = sI;
		break;
#ifdef IEEE_FLOATING_POINT
................................................................................
	    }
	    if (c == 'o' || c == 'O') {
		explicitOctal = 1;
		state = ZERO_O;
		break;
	    }
#endif
	    if (flags & TCL_PARSE_HEXADECIMAL_ONLY) {
		goto zerox;
	    }
#ifdef KILL_OCTAL
	    goto decimal;
#endif
	    /* FALLTHROUGH */

	case OCTAL:
	    /*
................................................................................
	    acceptState = state;
	    acceptPoint = p;
	    acceptLen = len;
#ifdef TIP_114_FORMATS
	    /* FALLTHROUGH */
	case ZERO_O:
#endif
	zeroo:
	    if (c == '0') {
		++numTrailZeros;
		state = OCTAL;
		break;
	    } else if (c >= '1' && c <= '7') {
		if (objPtr != NULL) {
		    shift = 3 * (numTrailZeros + 1);
................................................................................
	case BAD_OCTAL:
#ifdef TIP_114_FORMATS
	    if (explicitOctal) {
		/* No forgiveness for bad digits in explicitly octal numbers */
		goto endgame;
	    }
#endif
	    if (flags & TCL_PARSE_INTEGER_ONLY) {
		/* No seeking floating point when parsing only integer */
		goto endgame;
	    }
#ifndef KILL_OCTAL
	    /*
	     * Scanned a number with a leading zero that contains an
	     * 8, 9, radix point or E.  This is an invalid octal number,
	     * but might still be floating point.  
	     */
	    if (c == '0') {
................................................................................
	     */
	case HEXADECIMAL:
	    acceptState = state;
	    acceptPoint = p;
	    acceptLen = len;
	    /* FALLTHROUGH */
	case ZERO_X:
	zerox:
	    if (c == '0') {
		++numTrailZeros;
		state = HEXADECIMAL;
		break;
	    } else if (isdigit(UCHAR(c))) {
		d = (c-'0');
	    } else if (c >= 'A' && c <= 'F') {
................................................................................
					       &significandBig, 
					       significandOverflow);
		}
		numSigDigs += ( numTrailZeros + 1 );
		numTrailZeros = 0;
		state = DECIMAL;
		break;
	    } else if (flags & TCL_PARSE_INTEGER_ONLY) {
		goto endgame;
	    } else if (c == '.') {
		state = FRACTION;
		break;
	    } else if (c == 'E' || c == 'e') {
		state = EXPONENT_START;
		break;
	    }