summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorjan.nijtmans <nijtmans@users.sourceforge.net>2016-12-14 15:03:13 (GMT)
committerjan.nijtmans <nijtmans@users.sourceforge.net>2016-12-14 15:03:13 (GMT)
commit76e88df0f7df0d886ef26fad352fe22ac87df18d (patch)
tree6aa685119f2b5ff380f1049c9c645853b996e560
parent6da0c767cd83c18aa8a2c152ad6b0298ea4f28ab (diff)
parent82d0258052c45ac6767727539635540dc724182c (diff)
downloadtcl-76e88df0f7df0d886ef26fad352fe22ac87df18d.zip
tcl-76e88df0f7df0d886ef26fad352fe22ac87df18d.tar.gz
tcl-76e88df0f7df0d886ef26fad352fe22ac87df18d.tar.bz2
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.
-rw-r--r--generic/tclStringObj.c19
-rw-r--r--generic/tclTest.c42
-rw-r--r--tests/util.test25
3 files changed, 86 insertions, 0 deletions
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 9471381..db233b3 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -1865,6 +1865,14 @@ Tcl_AppendFormatToObj(
useWide = 1;
#endif
}
+ } else if ((ch == 'I') && (format[1] == '6') && (format[2] == '4')) {
+ format += (step + 2);
+ step = Tcl_UtfToUniChar(format, &ch);
+ useBig = 1;
+ } else if (ch == 'L') {
+ format += step;
+ step = Tcl_UtfToUniChar(format, &ch);
+ useBig = 1;
}
format += step;
@@ -2509,6 +2517,17 @@ AppendPrintfToObjVA(
++size;
p++;
break;
+ case 'L':
+ size = 2;
+ p++;
+ break;
+ case 'I':
+ if (p[1]=='6' && p[2]=='4') {
+ p += 2;
+ size = 2;
+ }
+ p++;
+ break;
case 'h':
size = -1;
default:
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