Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
| Comment: | merge core-8-6-branch |
|---|---|
| Downloads: | Tarball | ZIP archive |
| Timelines: | family | ancestors | descendants | both | trunk |
| Files: | files | file ages | folders |
| SHA1: |
eb8b79d49c75aa73a1d0452a450ecc71 |
| User & Date: | jan.nijtmans 2017-01-01 19:49:56.485 |
Context
|
2017-02-28
| ||
| 13:39 | Implement the ?targetNamespace? parameter for [oo::copy] check-in: 998812b7db user: limeboy tags: oo-copy-ns | |
|
2017-01-04
| ||
| 11:55 | merge core-8-6-branch check-in: 13dc69ec99 user: jan.nijtmans tags: trunk | |
|
2017-01-02
| ||
| 14:31 | [win] bug fix in NativeGetTime: each call of it blurs current performance counters actualized in cal... check-in: b6fc234ef3 user: sebres tags: bug_b87ad7e914 | |
|
2017-01-01
| ||
| 19:50 | merge trunk check-in: d8746f0cb8 user: jan.nijtmans tags: novem | |
| 19:49 | merge core-8-6-branch check-in: eb8b79d49c user: jan.nijtmans tags: trunk | |
| 19:46 | Fix [39f6304c2e]: Tcl_LinkVar is not tolerant to minus, plus, dot check-in: 07bc29650e user: jan.nijtmans tags: core-8-6-branch | |
| 19:10 | Update zlib to version 1.2.9. Dll's and *.lib files not updated yet check-in: 4b7084a579 user: jan.nijtmans tags: trunk | |
Changes
Changes to generic/tclLink.c.
| ︙ | ︙ | |||
63 64 65 66 67 68 69 70 71 72 73 74 75 76 | /* * Forward references to functions defined later in this file: */ static char * LinkTraceProc(ClientData clientData,Tcl_Interp *interp, const char *name1, const char *name2, int flags); static Tcl_Obj * ObjValue(Link *linkPtr); /* * Convenience macro for accessing the value of the C variable pointed to by a * link. Note that this macro produces something that may be regarded as an * lvalue or rvalue; it may be assigned to as well as read. Also note that * this macro assumes the name of the variable being accessed (linkPtr); this * is not strictly a good thing, but it keeps the code much shorter and | > > > > | 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 | /* * Forward references to functions defined later in this file: */ static char * LinkTraceProc(ClientData clientData,Tcl_Interp *interp, const char *name1, const char *name2, int flags); static Tcl_Obj * ObjValue(Link *linkPtr); static int GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr); static int GetInvalidDoubleFromObj(Tcl_Obj *objPtr, double *doublePtr); /* * Convenience macro for accessing the value of the C variable pointed to by a * link. Note that this macro produces something that may be regarded as an * lvalue or rvalue; it may be assigned to as well as read. Also note that * this macro assumes the name of the variable being accessed (linkPtr); this * is not strictly a good thing, but it keeps the code much shorter and |
| ︙ | ︙ | |||
376 377 378 379 380 381 382 |
return (char *) "internal error: linked variable couldn't be read";
}
switch (linkPtr->type) {
case TCL_LINK_INT:
if (Tcl_GetIntFromObj(NULL, valueObj, &linkPtr->lastValue.i)
!= TCL_OK) {
| > > | | > > > | | < > | > > > | | | > < < > > > | | | > > > | | | > > > | | | > > > | | | > > > | | | > > > > | | | > > > > | | | > > > > | | | > > > > | | | < < | > > | 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 |
return (char *) "internal error: linked variable couldn't be read";
}
switch (linkPtr->type) {
case TCL_LINK_INT:
if (Tcl_GetIntFromObj(NULL, valueObj, &linkPtr->lastValue.i)
!= TCL_OK) {
if (GetInvalidIntFromObj(valueObj, &linkPtr->lastValue.i)
!= TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return (char *) "variable must have integer value";
}
}
LinkedVar(int) = linkPtr->lastValue.i;
break;
case TCL_LINK_WIDE_INT:
if (Tcl_GetWideIntFromObj(NULL, valueObj, &linkPtr->lastValue.w)
!= TCL_OK) {
if (GetInvalidIntFromObj(valueObj, &valueInt)
!= TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return (char *) "variable must have integer value";
}
linkPtr->lastValue.w = (Tcl_WideInt) valueInt;
}
LinkedVar(Tcl_WideInt) = linkPtr->lastValue.w;
break;
case TCL_LINK_DOUBLE:
if (Tcl_GetDoubleFromObj(NULL, valueObj, &linkPtr->lastValue.d)
!= TCL_OK) {
#ifdef ACCEPT_NAN
if (valueObj->typePtr != &tclDoubleType) {
#endif
if (GetInvalidDoubleFromObj(valueObj, &linkPtr->lastValue.d)
!= TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return (char *) "variable must have real value";
}
#ifdef ACCEPT_NAN
}
linkPtr->lastValue.d = valueObj->internalRep.doubleValue;
#endif
}
LinkedVar(double) = linkPtr->lastValue.d;
break;
case TCL_LINK_BOOLEAN:
if (Tcl_GetBooleanFromObj(NULL, valueObj, &linkPtr->lastValue.i)
!= TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return (char *) "variable must have boolean value";
}
LinkedVar(int) = linkPtr->lastValue.i;
break;
case TCL_LINK_CHAR:
if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
|| valueInt < SCHAR_MIN || valueInt > SCHAR_MAX) {
if (GetInvalidIntFromObj(valueObj, &valueInt)
!= TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return (char *) "variable must have char value";
}
}
linkPtr->lastValue.c = (char)valueInt;
LinkedVar(char) = linkPtr->lastValue.c;
break;
case TCL_LINK_UCHAR:
if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
|| valueInt < 0 || valueInt > UCHAR_MAX) {
if (GetInvalidIntFromObj(valueObj, &valueInt)
!= TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return (char *) "variable must have unsigned char value";
}
}
linkPtr->lastValue.uc = (unsigned char) valueInt;
LinkedVar(unsigned char) = linkPtr->lastValue.uc;
break;
case TCL_LINK_SHORT:
if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
|| valueInt < SHRT_MIN || valueInt > SHRT_MAX) {
if (GetInvalidIntFromObj(valueObj, &valueInt)
!= TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return (char *) "variable must have short value";
}
}
linkPtr->lastValue.s = (short)valueInt;
LinkedVar(short) = linkPtr->lastValue.s;
break;
case TCL_LINK_USHORT:
if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
|| valueInt < 0 || valueInt > USHRT_MAX) {
if (GetInvalidIntFromObj(valueObj, &valueInt)
!= TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return (char *) "variable must have unsigned short value";
}
}
linkPtr->lastValue.us = (unsigned short)valueInt;
LinkedVar(unsigned short) = linkPtr->lastValue.us;
break;
case TCL_LINK_UINT:
if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
|| valueWide < 0 || valueWide > UINT_MAX) {
if (GetInvalidIntFromObj(valueObj, &valueInt)
!= TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return (char *) "variable must have unsigned int value";
}
linkPtr->lastValue.ui = (unsigned int)valueInt;
} else {
linkPtr->lastValue.ui = (unsigned int)valueWide;
}
LinkedVar(unsigned int) = linkPtr->lastValue.ui;
break;
case TCL_LINK_LONG:
if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
|| valueWide < LONG_MIN || valueWide > LONG_MAX) {
if (GetInvalidIntFromObj(valueObj, &valueInt)
!= TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return (char *) "variable must have long value";
}
linkPtr->lastValue.l = (long)valueInt;
} else {
linkPtr->lastValue.l = (long)valueWide;
}
LinkedVar(long) = linkPtr->lastValue.l;
break;
case TCL_LINK_ULONG:
if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
|| valueWide < 0 || (Tcl_WideUInt) valueWide > ULONG_MAX) {
if (GetInvalidIntFromObj(valueObj, &valueInt)
!= TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return (char *) "variable must have unsigned long value";
}
linkPtr->lastValue.ul = (unsigned long)valueInt;
} else {
linkPtr->lastValue.ul = (unsigned long)valueWide;
}
LinkedVar(unsigned long) = linkPtr->lastValue.ul;
break;
case TCL_LINK_WIDE_UINT:
/*
* FIXME: represent as a bignum.
*/
if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK) {
if (GetInvalidIntFromObj(valueObj, &valueInt)
!= TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return (char *) "variable must have unsigned wide int value";
}
linkPtr->lastValue.uw = (Tcl_WideUInt)valueInt;
} else {
linkPtr->lastValue.uw = (Tcl_WideUInt)valueWide;
}
LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw;
break;
case TCL_LINK_FLOAT:
if (Tcl_GetDoubleFromObj(NULL, valueObj, &valueDouble) != TCL_OK
|| valueDouble < -FLT_MAX || valueDouble > FLT_MAX) {
if (GetInvalidDoubleFromObj(valueObj, &valueDouble)
!= TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return (char *) "variable must have float value";
}
}
linkPtr->lastValue.f = (float)valueDouble;
LinkedVar(float) = linkPtr->lastValue.f;
break;
case TCL_LINK_STRING:
value = TclGetStringFromObj(valueObj, &valueLength);
valueLength++;
pp = (char **) linkPtr->addr;
|
| ︙ | ︙ | |||
629 630 631 632 633 634 635 |
*/
default:
TclNewLiteralStringObj(resultObj, "??");
return resultObj;
}
}
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 |
*/
default:
TclNewLiteralStringObj(resultObj, "??");
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_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
* contexts in Tcl. Handled are "+", "-", "0x", "0b" and "0o" (upper-
* and lowercase). See bug [39f6304c2e].
*/
int
GetInvalidIntFromObj(Tcl_Obj *objPtr,
int *intPtr)
{
int length;
const char *str = TclGetStringFromObj(objPtr, &length);
if ((length == 1) && strchr("+-", str[0])) {
*intPtr = (str[0] == '+');
return TCL_OK;
} else if ((length == 2) && (str[0] == '0') && strchr("xXbBoO", str[1])) {
*intPtr = 0;
return TCL_OK;
}
return TCL_ERROR;
}
/*
* 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) and sequences like "1e-". See bug [39f6304c2e].
*/
int
GetInvalidDoubleFromObj(Tcl_Obj *objPtr,
double *doublePtr)
{
int intValue, result;
if ((objPtr->typePtr == &invalidRealType) ||
(SetInvalidRealFromAny(NULL, objPtr) == TCL_OK)) {
*doublePtr = objPtr->internalRep.doubleValue;
return TCL_OK;
}
result = GetInvalidIntFromObj(objPtr, &intValue);
if (result == TCL_OK) {
*doublePtr = (double) intValue;
}
return result;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclTest.c.
| ︙ | ︙ | |||
3845 3846 3847 3848 3849 3850 3851 |
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) {
| | | 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 |
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;
|
| ︙ | ︙ |
Changes to tests/link.test.
| ︙ | ︙ | |||
85 86 87 88 89 90 91 92 93 94 95 96 97 98 |
test link-2.5 {writing bad values into variables} -setup {
testlink delete
} -constraints {testlink} -body {
testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
list [catch {set wide gorp} msg] $msg $bool
} -result {1 {can't set "wide": variable must have integer value} 1}
test link-3.1 {read-only variables} -constraints {testlink} -setup {
testlink delete
} -body {
testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
testlink create 0 1 1 0 0 0 0 0 0 0 0 0 0 0
list [catch {set int 4} msg] $msg $int \
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 |
test link-2.5 {writing bad values into variables} -setup {
testlink delete
} -constraints {testlink} -body {
testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
list [catch {set wide gorp} msg] $msg $bool
} -result {1 {can't set "wide": variable must have integer value} 1}
test link-2.6 {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 "+"
set real "+"
set bool 1
set string "+"
set wide "+"
set char "+"
set uchar "+"
set short "+"
set ushort "+"
set uint "+"
set long "+"
set ulong "+"
set float "+"
set uwide "+"
concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide
} -result {1 1.0 1 + 1 1 1 1 1 1 1 1 1.0 1 | + + 1 + + + + + + + + + + +}
test link-2.7 {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 "-"
set real "-"
set bool 0
set string "-"
set wide "-"
set char "-"
set uchar "-"
set short "-"
set ushort "-"
set uint "-"
set long "-"
set ulong "-"
set float "-"
set uwide "-"
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 - - - - - - - - - - -}
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 "0x"
set real "0b"
set bool 0
set string "0"
set wide "0O"
set char "0X"
set uchar "0B"
set short "0O"
set ushort "0x"
set uint "0b"
set long "0o"
set ulong "0X"
set float "0B"
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 -60.00e+
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 -60.0 0 | 0 5000e 0 0 0 0 0 0 0 0 0 0 -60.00e+ 0}
test link-3.1 {read-only variables} -constraints {testlink} -setup {
testlink delete
} -body {
testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
testlink create 0 1 1 0 0 0 0 0 0 0 0 0 0 0
list [catch {set int 4} msg] $msg $int \
|
| ︙ | ︙ |