diff options
| -rw-r--r-- | generic/tclLink.c | 54 | ||||
| -rw-r--r-- | tests/link.test | 21 |
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 |