summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tcl.h38
-rw-r--r--generic/tclAlloc.c10
-rw-r--r--generic/tclCkalloc.c28
-rw-r--r--generic/tclExecute.c6
-rw-r--r--generic/tclScan.c21
-rw-r--r--generic/tclStringObj.c59
6 files changed, 79 insertions, 83 deletions
diff --git a/generic/tcl.h b/generic/tcl.h
index 07d841d..b847fef 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -396,44 +396,36 @@ typedef long LONG;
# if defined(_WIN32)
# define TCL_WIDE_INT_TYPE __int64
# define TCL_LL_MODIFIER "I64"
+# if defined(_WIN64)
+# define TCL_Z_MODIFIER "I"
+# endif
# elif defined(__GNUC__)
-# define TCL_WIDE_INT_TYPE long long
-# define TCL_LL_MODIFIER "ll"
+# define TCL_Z_MODIFIER "z"
# else /* ! _WIN32 && ! __GNUC__ */
/*
* Don't know what platform it is and configure hasn't discovered what is
* going on for us. Try to guess...
*/
# include <limits.h>
-# if (INT_MAX < LONG_MAX)
+# if defined(LLONG_MAX) && (LLONG_MAX == LONG_MAX)
# define TCL_WIDE_INT_IS_LONG 1
-# else
-# define TCL_WIDE_INT_TYPE long long
# endif
# endif /* _WIN32 */
#endif /* !TCL_WIDE_INT_TYPE & !TCL_WIDE_INT_IS_LONG */
-#ifdef TCL_WIDE_INT_IS_LONG
-# undef TCL_WIDE_INT_TYPE
-# define TCL_WIDE_INT_TYPE long
-#endif /* TCL_WIDE_INT_IS_LONG */
+
+#ifndef TCL_WIDE_INT_TYPE
+# define TCL_WIDE_INT_TYPE long long
+#endif /* !TCL_WIDE_INT_TYPE */
typedef TCL_WIDE_INT_TYPE Tcl_WideInt;
typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt;
-#ifdef TCL_WIDE_INT_IS_LONG
-# ifndef TCL_LL_MODIFIER
-# define TCL_LL_MODIFIER "l"
-# endif /* !TCL_LL_MODIFIER */
-#else /* TCL_WIDE_INT_IS_LONG */
-/*
- * The next short section of defines are only done when not running on Windows
- * or some other strange platform.
- */
-# ifndef TCL_LL_MODIFIER
-# define TCL_LL_MODIFIER "ll"
-# endif /* !TCL_LL_MODIFIER */
-#endif /* TCL_WIDE_INT_IS_LONG */
-
+#ifndef TCL_LL_MODIFIER
+# define TCL_LL_MODIFIER "ll"
+#endif /* !TCL_LL_MODIFIER */
+#ifndef TCL_Z_MODIFIER
+# define TCL_Z_MODIFIER ""
+#endif /* !TCL_Z_MODIFIER */
#define Tcl_WideAsLong(val) ((long)((Tcl_WideInt)(val)))
#define Tcl_LongAsWide(val) ((Tcl_WideInt)((long)(val)))
#define Tcl_WideAsDouble(val) ((double)((Tcl_WideInt)(val)))
diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c
index 64df1a2..fbd8f6e 100644
--- a/generic/tclAlloc.c
+++ b/generic/tclAlloc.c
@@ -661,14 +661,14 @@ mstats(
fprintf(stderr, "\nused:\t");
for (i = 0; i < NBUCKETS; i++) {
- fprintf(stderr, " %" TCL_LL_MODIFIER "d", (Tcl_WideInt)numMallocs[i]);
+ fprintf(stderr, " %" TCL_Z_MODIFIER "d", numMallocs[i]);
totalUsed += numMallocs[i] * (1 << (i + 3));
}
- fprintf(stderr, "\n\tTotal small in use: %" TCL_LL_MODIFIER "d, total free: %" TCL_LL_MODIFIER "d\n",
- (Tcl_WideInt)totalUsed, (Tcl_WideInt)totalFree);
- fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %" TCL_LL_MODIFIER "d\n",
- MAXMALLOC, (Tcl_WideInt)numMallocs[NBUCKETS]);
+ fprintf(stderr, "\n\tTotal small in use: %" TCL_Z_MODIFIER "d, total free: %" TCL_Z_MODIFIER "d\n",
+ totalUsed, totalFree);
+ fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %" TCL_Z_MODIFIER "d\n",
+ MAXMALLOC, numMallocs[NBUCKETS]);
Tcl_MutexUnlock(allocMutexPtr);
}
diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c
index 123d872..18e3edb 100644
--- a/generic/tclCkalloc.c
+++ b/generic/tclCkalloc.c
@@ -187,15 +187,15 @@ TclDumpMemoryInfo(
"total mallocs %10u\n"
"total frees %10u\n"
"current packets allocated %10u\n"
- "current bytes allocated %10" TCL_LL_MODIFIER "u\n"
+ "current bytes allocated %10" TCL_Z_MODIFIER "u\n"
"maximum packets allocated %10u\n"
- "maximum bytes allocated %10" TCL_LL_MODIFIER "u\n",
+ "maximum bytes allocated %10" TCL_Z_MODIFIER "u\n",
total_mallocs,
total_frees,
current_malloc_packets,
- (Tcl_WideInt)current_bytes_malloced,
+ current_bytes_malloced,
maximum_malloc_packets,
- (Tcl_WideInt)maximum_bytes_malloced);
+ maximum_bytes_malloced);
if (flags == 0) {
fprintf((FILE *)clientData, "%s", buf);
} else {
@@ -254,7 +254,7 @@ ValidateMemory(
fprintf(stderr, "low guard failed at %p, %s %d\n",
memHeaderP->body, file, line);
fflush(stderr); /* In case name pointer is bad. */
- fprintf(stderr, "%" TCL_LL_MODIFIER "d bytes allocated at (%s %d)\n", (Tcl_WideInt) memHeaderP->length,
+ fprintf(stderr, "%" TCL_Z_MODIFIER "d bytes allocated at (%s %d)\n", memHeaderP->length,
memHeaderP->file, memHeaderP->line);
Tcl_Panic("Memory validation failure");
}
@@ -276,8 +276,8 @@ ValidateMemory(
fprintf(stderr, "high guard failed at %p, %s %d\n",
memHeaderP->body, file, line);
fflush(stderr); /* In case name pointer is bad. */
- fprintf(stderr, "%" TCL_LL_MODIFIER "d bytes allocated at (%s %d)\n",
- (Tcl_WideInt)memHeaderP->length, memHeaderP->file,
+ fprintf(stderr, "%" TCL_Z_MODIFIER "d bytes allocated at (%s %d)\n",
+ memHeaderP->length, memHeaderP->file,
memHeaderP->line);
Tcl_Panic("Memory validation failure");
}
@@ -359,9 +359,9 @@ Tcl_DumpActiveMemory(
Tcl_MutexLock(ckallocMutexPtr);
for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) {
address = &memScanP->body[0];
- fprintf(fileP, "%p - %p %" TCL_LL_MODIFIER "d @ %s %d %s",
+ fprintf(fileP, "%p - %p %" TCL_Z_MODIFIER "u @ %s %d %s",
address, address + memScanP->length - 1,
- (Tcl_WideInt)memScanP->length, memScanP->file, memScanP->line,
+ memScanP->length, memScanP->file, memScanP->line,
(memScanP->tagPtr == NULL) ? "" : memScanP->tagPtr->string);
(void) fputc('\n', fileP);
}
@@ -611,8 +611,8 @@ Tcl_DbCkfree(
memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET);
if (alloc_tracing) {
- fprintf(stderr, "ckfree %p %" TCL_LL_MODIFIER "d %s %d\n",
- memp->body, (Tcl_WideInt) memp->length, file, line);
+ fprintf(stderr, "ckfree %p %" TCL_Z_MODIFIER "u %s %d\n",
+ memp->body, memp->length, file, line);
}
if (validate_memory) {
@@ -859,12 +859,12 @@ MemoryCmd(
}
if (strcmp(argv[1],"info") == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "%-25s %10u\n%-25s %10u\n%-25s %10u\n%-25s %10" TCL_LL_MODIFIER"d\n%-25s %10u\n%-25s %10" TCL_LL_MODIFIER "d\n",
+ "%-25s %10u\n%-25s %10u\n%-25s %10u\n%-25s %10" TCL_Z_MODIFIER"u\n%-25s %10u\n%-25s %10" TCL_Z_MODIFIER "u\n",
"total mallocs", total_mallocs, "total frees", total_frees,
"current packets allocated", current_malloc_packets,
- "current bytes allocated", (Tcl_WideInt)current_bytes_malloced,
+ "current bytes allocated", current_bytes_malloced,
"maximum packets allocated", maximum_malloc_packets,
- "maximum bytes allocated", (Tcl_WideInt)maximum_bytes_malloced));
+ "maximum bytes allocated", maximum_bytes_malloced));
return TCL_OK;
}
if (strcmp(argv[1], "init") == 0) {
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index f4c71ec..a4ce7ea 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -9478,9 +9478,9 @@ PrintByteCodeInfo(
Proc *procPtr = codePtr->procPtr;
Interp *iPtr = (Interp *) *codePtr->interpHandle;
- fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %" TCL_LL_MODIFIER "u, epoch %" TCL_LL_MODIFIER "u, interp 0x%p (epoch %" TCL_LL_MODIFIER "u)\n",
- codePtr, (Tcl_WideInt)codePtr->refCount, (Tcl_WideInt)codePtr->compileEpoch, iPtr,
- (Tcl_WideInt)iPtr->compileEpoch);
+ fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %" TCL_Z_MODIFIER "u, epoch %" TCL_Z_MODIFIER "u, interp 0x%p (epoch %" TCL_Z_MODIFIER "u)\n",
+ codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr,
+ (size_t)iPtr->compileEpoch);
fprintf(stdout, " Source: ");
TclPrintSource(stdout, codePtr->source, 60);
diff --git a/generic/tclScan.c b/generic/tclScan.c
index e1fcad4..9d001e4 100644
--- a/generic/tclScan.c
+++ b/generic/tclScan.c
@@ -10,6 +10,7 @@
*/
#include "tclInt.h"
+#include "tommath.h"
/*
* Flag values used by Tcl_ScanObjCmd.
@@ -415,14 +416,7 @@ ValidateFormat(
case 'x':
case 'X':
case 'b':
- break;
case 'u':
- if (flags & SCAN_BIG) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "unsigned bignum scans are invalid", -1));
- Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADUNSIGNED",NULL);
- goto error;
- }
break;
/*
* Bracket terms need special checking
@@ -936,7 +930,18 @@ Tcl_ScanObjCmd(
} else {
Tcl_SetWideIntObj(objPtr, wideValue);
}
- } else if (!(flags & SCAN_BIG)) {
+ } else if (flags & SCAN_BIG) {
+ if (flags & SCAN_UNSIGNED) {
+ mp_int big;
+ if ((Tcl_GetBignumFromObj(interp, objPtr, &big) != TCL_OK)
+ || (mp_cmp_d(&big, 0) == MP_LT)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "unsigned bignum scans are invalid", -1));
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADUNSIGNED",NULL);
+ return TCL_ERROR;
+ }
+ }
+ } else {
if (TclGetLongFromObj(NULL, objPtr, &value) != TCL_OK) {
if (TclGetString(objPtr)[0] == '-') {
value = LONG_MIN;
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 59758bb..34e3f28 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -1880,20 +1880,10 @@ Tcl_AppendFormatToObj(
format += step;
step = Tcl_UtfToUniChar(format, &ch);
}
- } else if ((ch == 't') || (ch == 'z')) {
+ } else if ((ch == 't') || (ch == 'z') || (ch == 'q') || (ch == 'j') || (ch == 'L')) {
format += step;
step = Tcl_UtfToUniChar(format, &ch);
-#ifndef TCL_WIDE_INT_IS_LONG
- if (sizeof(size_t) > sizeof(int)) {
- useWide = 1;
- }
-#endif
- } else if ((ch == 'q') ||(ch == 'j')) {
- format += step;
- step = Tcl_UtfToUniChar(format, &ch);
-#ifndef TCL_WIDE_INT_IS_LONG
- useWide = 1;
-#endif
+ useBig = 1;
}
format += step;
@@ -1939,11 +1929,6 @@ Tcl_AppendFormatToObj(
}
case 'u':
- if (useBig) {
- msg = "unsigned bignum format is invalid";
- errCode = "BADUNSIGNED";
- goto errorMsg;
- }
case 'd':
case 'o':
case 'p':
@@ -1967,9 +1952,19 @@ Tcl_AppendFormatToObj(
goto error;
}
isNegative = (mp_cmp_d(&big, 0) == MP_LT);
+ if (ch == 'u') {
+ if (isNegative) {
+ msg = "unsigned bignum format is invalid";
+ errCode = "BADUNSIGNED";
+ goto errorMsg;
+ } else {
+ ch = 'd';
+ }
+ }
+ if (mp_cmp_d(&big, 0) == MP_EQ) gotHash = 0;
#ifndef TCL_WIDE_INT_IS_LONG
} else if (useWide) {
- if (Tcl_GetWideIntFromObj(NULL, segment, &w) != TCL_OK) {
+ if (TclGetWideIntFromObj(NULL, segment, &w) != TCL_OK) {
Tcl_Obj *objPtr;
if (Tcl_GetBignumFromObj(interp,segment,&big) != TCL_OK) {
@@ -1978,13 +1973,14 @@ Tcl_AppendFormatToObj(
mp_mod_2d(&big, (int) CHAR_BIT*sizeof(Tcl_WideInt), &big);
objPtr = Tcl_NewBignumObj(&big);
Tcl_IncrRefCount(objPtr);
- Tcl_GetWideIntFromObj(NULL, objPtr, &w);
+ TclGetWideIntFromObj(NULL, objPtr, &w);
Tcl_DecrRefCount(objPtr);
}
isNegative = (w < (Tcl_WideInt) 0);
+ if (w == (Tcl_WideInt) 0) gotHash = 0;
#endif
} else if (TclGetLongFromObj(NULL, segment, &l) != TCL_OK) {
- if (Tcl_GetWideIntFromObj(NULL, segment, &w) != TCL_OK) {
+ if (TclGetWideIntFromObj(NULL, segment, &w) != TCL_OK) {
Tcl_Obj *objPtr;
if (Tcl_GetBignumFromObj(interp,segment,&big) != TCL_OK) {
@@ -2001,14 +1997,18 @@ Tcl_AppendFormatToObj(
if (useShort) {
s = (short) l;
isNegative = (s < (short) 0);
+ if (s == (short) 0) gotHash = 0;
} else {
isNegative = (l < (long) 0);
+ if (l == (long) 0) gotHash = 0;
}
} else if (useShort) {
s = (short) l;
isNegative = (s < (short) 0);
+ if (s == (short) 0) gotHash = 0;
} else {
isNegative = (l < (long) 0);
+ if (l == (long) 0) gotHash = 0;
}
segment = Tcl_NewObj();
@@ -2025,9 +2025,8 @@ Tcl_AppendFormatToObj(
if (gotHash || (ch == 'p')) {
switch (ch) {
case 'o':
- Tcl_AppendToObj(segment, "0", 1);
- segmentLimit -= 1;
- precision--;
+ Tcl_AppendToObj(segment, "0o", 2);
+ segmentLimit -= 2;
break;
case 'X':
Tcl_AppendToObj(segment, "0X", 2);
@@ -2183,7 +2182,7 @@ Tcl_AppendFormatToObj(
* Need to be sure zero becomes "0", not "".
*/
- if ((numDigits == 0) && !((ch == 'o') && gotHash)) {
+ if (numDigits == 0) {
numDigits = 1;
}
pure = Tcl_NewObj();
@@ -2783,8 +2782,8 @@ TclStringRepeat(
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"string size overflow: unable to alloc %"
- TCL_LL_MODIFIER "d bytes",
- (Tcl_WideUInt)STRING_SIZE(count*length)));
+ TCL_Z_MODIFIER "u bytes",
+ STRING_SIZE(count*length)));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
return TCL_ERROR;
@@ -3089,8 +3088,8 @@ TclStringCatObjv(
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"concatenation failed: unable to alloc %"
- TCL_LL_MODIFIER "d bytes",
- (Tcl_WideUInt)STRING_SIZE(length)));
+ TCL_Z_MODIFIER "u bytes",
+ STRING_SIZE(length)));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
return TCL_ERROR;
@@ -3105,8 +3104,8 @@ TclStringCatObjv(
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"concatenation failed: unable to alloc %"
- TCL_LL_MODIFIER "d bytes",
- (Tcl_WideUInt)STRING_SIZE(length)));
+ TCL_Z_MODIFIER "u bytes",
+ STRING_SIZE(length)));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
return TCL_ERROR;
generated by cgit v0.12 at 2025-06-04 13:35:04 (GMT)