summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--generic/tclLink.c54
-rw-r--r--tests/link.test21
2 files changed, 70 insertions, 5 deletions
diff --git a/generic/tclLink.c b/generic/tclLink.c
index 56f8a5c..a80ec8a 100644
--- a/generic/tclLink.c
+++ b/generic/tclLink.c
@@ -677,6 +677,50 @@ ObjValue(
return resultObj;
}
}
+
+static int SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
+
+static Tcl_ObjType invalidRealType = {
+ "invalidReal", /* name */
+ NULL, /* freeIntRepProc */
+ NULL, /* dupIntRepProc */
+ NULL, /* updateStringProc */
+ SetInvalidRealFromAny /* setFromAnyProc */
+};
+
+static int
+SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) {
+ int length;
+ const char *str;
+ const char *endPtr;
+
+ str = TclGetStringFromObj(objPtr, &length);
+ if ((length == 1) && (str[0] == '.')){
+ objPtr->typePtr = &invalidRealType;
+ objPtr->internalRep.doubleValue = 0.0;
+ return TCL_OK;
+ }
+ if (TclParseNumber(NULL, objPtr, NULL, str, length, &endPtr,
+ TCL_PARSE_DECIMAL_ONLY|TCL_PARSE_INTEGER_ONLY) == TCL_OK) {
+ /* If number is followed by [eE][+-]?, then it is an invalid
+ * double, but it could be the start of a valid double. */
+ if (*endPtr == 'e' || *endPtr == 'E') {
+ ++endPtr;
+ if (*endPtr == '+' || *endPtr == '-') ++endPtr;
+ if (*endPtr == 0) {
+ double doubleValue = 0.0;
+ Tcl_GetDoubleFromObj(NULL, objPtr, &doubleValue);
+ if (objPtr->typePtr->freeIntRepProc) objPtr->typePtr->freeIntRepProc(objPtr);
+ objPtr->typePtr = &invalidRealType;
+ objPtr->internalRep.doubleValue = doubleValue;
+ return TCL_OK;
+ }
+ }
+ }
+ return TCL_ERROR;
+}
+
+
/*
* This function checks for integer representations, which are valid
* when linking with C variables, but which are invalid in other
@@ -704,17 +748,17 @@ GetInvalidIntFromObj(Tcl_Obj *objPtr,
* This function checks for double representations, which are valid
* when linking with C variables, but which are invalid in other
* contexts in Tcl. Handled are ".", "+", "-", "0x", "0b" and "0o"
- * (upper- and lowercase). See bug [39f6304c2e].
+ * (upper- and lowercase) and sequences like "1e-". See bug [39f6304c2e].
*/
int
GetInvalidDoubleFromObj(Tcl_Obj *objPtr,
double *doublePtr)
{
- int length, intValue, result;
- const char *str = TclGetStringFromObj(objPtr, &length);
+ int intValue, result;
- if ((length == 1) && (str[0] == '.')){
- *doublePtr = 0.0;
+ if ((objPtr->typePtr == &invalidRealType) ||
+ (SetInvalidRealFromAny(NULL, objPtr) == TCL_OK)) {
+ *doublePtr = objPtr->internalRep.doubleValue;
return TCL_OK;
}
result = GetInvalidIntFromObj(objPtr, &intValue);
diff --git a/tests/link.test b/tests/link.test
index 9ff44db..1e29ac5 100644
--- a/tests/link.test
+++ b/tests/link.test
@@ -141,6 +141,27 @@ test link-2.8 {writing C variables from Tcl} -constraints {testlink} -setup {
set uwide "0O"
concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide
} -result {0 0.0 0 0 0 0 0 0 0 0 0 0 0.0 0 | 0x 0b 0 0 0O 0X 0B 0O 0x 0b 0o 0X 0B 0O}
+test link-2.8 {writing C variables from Tcl} -constraints {testlink} -setup {
+ testlink delete
+} -body {
+ testlink set 43 1.21 4 - 56785678 64 250 30000 60000 0xbaadbeef 12321 32123 3.25 1231231234
+ testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+ set int 0
+ set real 5000e
+ set bool 0
+ set string 0
+ set wide 0
+ set char 0
+ set uchar 0
+ set short 0
+ set ushort 0
+ set uint 0
+ set long 0
+ set ulong 0
+ set float -6000e+
+ set uwide 0
+ concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide
+} -result {0 5000.0 0 0 0 0 0 0 0 0 0 0 -6000.0 0 | 0 5000e 0 0 0 0 0 0 0 0 0 0 -6000e+ 0}
test link-3.1 {read-only variables} {testlink} {
testlink delete