summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--generic/tclStringObj.c11
-rw-r--r--generic/tclTest.c42
-rw-r--r--tests/util.test25
3 files changed, 77 insertions, 1 deletions
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