From 6a1787475cafd1f3f1e9c9a845ee03088c214def Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Fri, 2 Dec 2016 15:52:09 +0000
Subject: implement "I64" format in Tcl_ObjPrintf as well. Still to be tested.
---
generic/tclStringObj.c | 16 +++++++++++++---
1 file changed, 13 insertions(+), 3 deletions(-)
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 4b171f3..65f9ab1 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -1865,6 +1865,9 @@ Tcl_AppendFormatToObj(
useWide = 1;
#endif
}
+ } else if ((ch == 'I') && (format[1] == '6') && (format[2] == '4')) {
+ step += 2;
+ useBig = 1;
}
format += step;
@@ -2509,6 +2512,13 @@ AppendPrintfToObjVA(
++size;
p++;
break;
+ case 'I':
+ if (p[1]=='6' && p[2]=='4') {
+ p += 2;
+ size = 2;
+ }
+ p++;
+ break;
case 'h':
size = -1;
default:
@@ -2712,7 +2722,7 @@ TclStringRepeat(
if (0 == Tcl_AttemptSetObjLength(objResultPtr, count*length)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "string size overflow: unable to alloc %llu bytes",
+ "string size overflow: unable to alloc %" TCL_LL_MODIFIER "u bytes",
(Tcl_WideUInt)STRING_SIZE(count*length)));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
@@ -2935,7 +2945,7 @@ TclStringCatObjv(
if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "concatenation failed: unable to alloc %llu bytes",
+ "concatenation failed: unable to alloc %" TCL_LL_MODIFIER "u bytes",
(Tcl_WideUInt)STRING_SIZE(length)));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
@@ -2950,7 +2960,7 @@ TclStringCatObjv(
if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "concatenation failed: unable to alloc %llu bytes",
+ "concatenation failed: unable to alloc %" TCL_LL_MODIFIER "u bytes",
(Tcl_WideUInt)STRING_SIZE(length)));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
--
cgit v0.12
From b2c94acd0b2a386e7f049c00b6cf7c05888bfda5 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Wed, 14 Dec 2016 14:14:17 +0000
Subject: Implement all possible TCL_LL_MODIFIER formats in Tcl_ObjPrintf(),
can be "ll", "I64" and "L", whatever the platform defines for long long
integer. With test-cases.
---
generic/tclStringObj.c | 11 ++++++++++-
generic/tclTest.c | 42 ++++++++++++++++++++++++++++++++++++++++++
tests/util.test | 25 +++++++++++++++++++++++++
3 files changed, 77 insertions(+), 1 deletion(-)
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 65f9ab1..2b1dfc5 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -1866,7 +1866,12 @@ Tcl_AppendFormatToObj(
#endif
}
} else if ((ch == 'I') && (format[1] == '6') && (format[2] == '4')) {
- step += 2;
+ format += (step + 2);
+ step = Tcl_UtfToUniChar(format, &ch);
+ useBig = 1;
+ } else if (ch == 'L') {
+ format += step;
+ step = Tcl_UtfToUniChar(format, &ch);
useBig = 1;
}
@@ -2512,6 +2517,10 @@ AppendPrintfToObjVA(
++size;
p++;
break;
+ case 'L':
+ size = 2;
+ p++;
+ break;
case 'I':
if (p[1]=='6' && p[2]=='4') {
p += 2;
diff --git a/generic/tclTest.c b/generic/tclTest.c
index e30c4d0..dee1fe7 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -318,6 +318,9 @@ static int TestparsevarnameObjCmd(ClientData dummy,
static int TestpreferstableObjCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+static int TestprintObjCmd(ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
static int TestregexpObjCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -649,6 +652,8 @@ Tcltest_Init(
NULL, NULL);
Tcl_CreateObjCommand(interp, "testpreferstable", TestpreferstableObjCmd,
NULL, NULL);
+ Tcl_CreateObjCommand(interp, "testprint", TestprintObjCmd,
+ NULL, NULL);
Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd,
@@ -3820,6 +3825,43 @@ TestpreferstableObjCmd(
/*
*----------------------------------------------------------------------
*
+ * TestprintObjCmd --
+ *
+ * This procedure implements the "testprint" command. It is
+ * used for being able to test the Tcl_ObjPrintf() function.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestprintObjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* The argument objects. */
+{
+ Tcl_WideInt argv1 = 0;
+
+ if (objc < 2 || objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "format wideint");
+ }
+
+ if (objc > 1) {
+ Tcl_GetWideIntFromObj(interp, objv[2], &argv1);
+ }
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(Tcl_GetString(objv[1]), argv1));
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestregexpObjCmd --
*
* This procedure implements the "testregexp" command. It is used to give
diff --git a/tests/util.test b/tests/util.test
index 2ac11bf..1a3eecb 100644
--- a/tests/util.test
+++ b/tests/util.test
@@ -20,6 +20,7 @@ testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint testdstring [llength [info commands testdstring]]
testConstraint testconcatobj [llength [info commands testconcatobj]]
testConstraint testdoubledigits [llength [info commands testdoubledigits]]
+testConstraint testprint [llength [info commands testprint]]
# Big test for correct ordering of data in [expr]
@@ -4017,6 +4018,30 @@ test util-17.1 {bankers' rounding [Bug 3349507]} {ieeeFloatingPoint} {
0x4400000000000000 0xc400000000000000
}]
+test util-18.1 {Tcl_ObjPrintf} {testprint} {
+ testprint %lld [expr 2**63-1]
+} {9223372036854775807}
+
+test util-18.2 {Tcl_ObjPrintf} {testprint} {
+ testprint %I64d [expr 2**63-1]
+} {9223372036854775807}
+
+test util-18.3 {Tcl_ObjPrintf} {testprint} {
+ testprint %Ld [expr 2**63-1]
+} {9223372036854775807}
+
+test util-18.4 {Tcl_ObjPrintf} {testprint} {
+ testprint %lld [expr -2**63]
+} {-9223372036854775808}
+
+test util-18.5 {Tcl_ObjPrintf} {testprint} {
+ testprint %I64d [expr -2**63]
+} {-9223372036854775808}
+
+test util-18.6 {Tcl_ObjPrintf} {testprint} {
+ testprint %Ld [expr -2**63]
+} {-9223372036854775808}
+
set ::tcl_precision $saved_precision
# cleanup
--
cgit v0.12