Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
Comment: | Clean up and refactor a bit |
---|---|
Downloads: | Tarball | ZIP archive |
Timelines: | family | ancestors | descendants | both | tip-312-new |
Files: | files | file ages | folders |
SHA3-256: |
258100c83e5d8deaf8f71644ce822c89 |
User & Date: | dkf 2019-04-04 23:47:38.229 |
Context
2019-04-05
| ||
18:37 | More efficient version (after feedback from KBK). Better test too. check-in: 41a632a0b1 user: dkf tags: tip-312-new | |
2019-04-04
| ||
23:47 | Clean up and refactor a bit check-in: 258100c83e user: dkf tags: tip-312-new | |
23:08 | Now with fewer memory leaks check-in: edef464b4f user: dkf tags: tip-312-new | |
Changes
Changes to generic/tclLink.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | /* * tclLink.c -- * * This file implements linked variables (a C variable that is tied to a * Tcl variable). The idea of linked variables was first suggested by * Andreas Stolcke and this implementation is based heavily on a * prototype implementation provided by him. * * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 2008 Rene Zaumseil * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tommath.h" | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | /* * tclLink.c -- * * This file implements linked variables (a C variable that is tied to a * Tcl variable). The idea of linked variables was first suggested by * Andreas Stolcke and this implementation is based heavily on a * prototype implementation provided by him. * * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 2008 Rene Zaumseil * Copyright (c) 2019 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tommath.h" |
︙ | ︙ | |||
94 95 96 97 98 99 100 | */ static char * LinkTraceProc(ClientData clientData,Tcl_Interp *interp, const char *name1, const char *name2, int flags); static Tcl_Obj * ObjValue(Link *linkPtr); static void LinkFree(Link *linkPtr); static int GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr); | < < > > > > > > > > > > > > > > | 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 | */ static char * LinkTraceProc(ClientData clientData,Tcl_Interp *interp, const char *name1, const char *name2, int flags); static Tcl_Obj * ObjValue(Link *linkPtr); static void LinkFree(Link *linkPtr); static int GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr); static int GetInvalidDoubleFromObj(Tcl_Obj *objPtr, double *doublePtr); static int SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); /* * A marker type used to flag weirdnesses so we can pass them around right. */ static Tcl_ObjType invalidRealType = { "invalidReal", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ NULL /* setFromAnyProc */ }; /* * 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 |
︙ | ︙ | |||
436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 | linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL, TCL_GLOBAL_ONLY, LinkTraceProc, NULL); if (linkPtr != NULL) { linkPtr->flags = (linkPtr->flags & ~LINK_BEING_UPDATED) | savedFlag; } } static inline int GetInt( Tcl_Obj *objPtr, int *intPtr) { return (Tcl_GetIntFromObj(NULL, objPtr, intPtr) != TCL_OK && GetInvalidIntFromObj(objPtr, intPtr) != TCL_OK); } static inline int GetWide( Tcl_Obj *objPtr, Tcl_WideInt *widePtr) { | > > > > > > > > > > > | > | > > > > > > | | 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 | linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL, TCL_GLOBAL_ONLY, LinkTraceProc, NULL); if (linkPtr != NULL) { linkPtr->flags = (linkPtr->flags & ~LINK_BEING_UPDATED) | savedFlag; } } /* *---------------------------------------------------------------------- * * GetInt, GetWide, GetUWide, GetDouble, EqualDouble, IsSpecial -- * * Helper functions for LinkTraceProc and ObjValue. These are all * factored out here to make those functions simpler. * *---------------------------------------------------------------------- */ static inline int GetInt( Tcl_Obj *objPtr, int *intPtr) { return (Tcl_GetIntFromObj(NULL, objPtr, intPtr) != TCL_OK && GetInvalidIntFromObj(objPtr, intPtr) != TCL_OK); } static inline int GetWide( Tcl_Obj *objPtr, Tcl_WideInt *widePtr) { if (Tcl_GetWideIntFromObj(NULL, objPtr, widePtr) != TCL_OK) { int intValue; if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) { return 1; } *widePtr = intValue; } return 0; } static inline int GetUWide( Tcl_Obj *objPtr, Tcl_WideUInt *uwidePtr) { Tcl_WideInt *widePtr = (Tcl_WideInt *) uwidePtr; ClientData clientData; int type, intValue; if (TclGetNumberFromObj(NULL, objPtr, &clientData, &type) == TCL_OK) { if (type == TCL_NUMBER_INT) { *widePtr = *((const Tcl_WideInt *) clientData); return (*widePtr < 0); } else if (type == TCL_NUMBER_BIG) { mp_int num; |
︙ | ︙ | |||
505 506 507 508 509 510 511 | } } /* * Evil edge case fallback. */ | > | > > > | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 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 | } } /* * Evil edge case fallback. */ if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) { return 1; } *uwidePtr = intValue; return 0; } static inline int GetDouble( Tcl_Obj *objPtr, double *dblPtr) { if (Tcl_GetDoubleFromObj(NULL, objPtr, dblPtr) == TCL_OK) { return 0; } else { #ifdef ACCEPT_NAN Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &tclDoubleType); if (irPtr != NULL) { *dblPtr = irPtr->doubleValue; return 0; } #endif /* ACCEPT_NAN */ return GetInvalidDoubleFromObj(objPtr, dblPtr) != TCL_OK; } } static inline int EqualDouble( double a, double b) { return (a == b) #ifdef ACCEPT_NAN || (TclIsNaN(a) && TclIsNaN(b)) #endif /* ACCEPT_NAN */ ; } static inline int IsSpecial( double a) { return TclIsInfinite(a) #ifdef ACCEPT_NAN || TclIsNaN(a) #endif /* ACCEPT_NAN */ ; } /* * Mark an object as holding a weird double. */ static int SetInvalidRealFromAny( Tcl_Interp *interp, Tcl_Obj *objPtr) { const char *str; const char *endPtr; str = TclGetString(objPtr); if ((objPtr->length == 1) && (str[0] == '.')) { objPtr->typePtr = &invalidRealType; objPtr->internalRep.doubleValue = 0.0; return TCL_OK; } if (TclParseNumber(NULL, objPtr, NULL, str, objPtr->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); TclFreeIntRep(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", "0d" and "0o" * (upperand lowercase). See bug [39f6304c2e]. */ static int GetInvalidIntFromObj( Tcl_Obj *objPtr, int *intPtr) { const char *str = TclGetString(objPtr); if ((objPtr->length == 0) || ((objPtr->length == 2) && (str[0] == '0') && strchr("xXbBoOdD", str[1]))) { *intPtr = 0; return TCL_OK; } else if ((objPtr->length == 1) && strchr("+-", str[0])) { *intPtr = (str[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]. */ static int GetInvalidDoubleFromObj( Tcl_Obj *objPtr, double *doublePtr) { int intValue; if (TclHasIntRep(objPtr, &invalidRealType)) { goto gotdouble; } if (GetInvalidIntFromObj(objPtr, &intValue) == TCL_OK) { *doublePtr = (double) intValue; return TCL_OK; } if (SetInvalidRealFromAny(NULL, objPtr) == TCL_OK) { gotdouble: *doublePtr = objPtr->internalRep.doubleValue; return TCL_OK; } return TCL_ERROR; } /* *---------------------------------------------------------------------- * * LinkTraceProc -- * * This function is invoked when a linked Tcl variable is read, written, |
︙ | ︙ | |||
1329 1330 1331 1332 1333 1334 1335 | */ default: TclNewLiteralStringObj(resultObj, "??"); return resultObj; } } | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 | */ default: TclNewLiteralStringObj(resultObj, "??"); return resultObj; } } /* *---------------------------------------------------------------------- * * LinkFree -- * * Free's allocated space of given link and link structure. |
︙ | ︙ |