Changeset 11988 in project
 Timestamp:
 09/24/08 06:04:47 (12 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

chicken/trunk/srfi69.scm
r11960 r11988 9 9 ; 10 10 ; Redistributions of source code must retain the above copyright notice, this list of conditions and the following 11 ; disclaimer. 11 ; disclaimer. 12 12 ; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following 13 ; disclaimer in the documentation and/or other materials provided with the distribution. 13 ; disclaimer in the documentation and/or other materials provided with the distribution. 14 14 ; Neither the name of the author nor the names of its contributors may be used to endorse or promote 15 ; products derived from this software without specific prior written permission. 15 ; products derived from this software without specific prior written permission. 16 16 ; 17 17 ; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS … … 48 48 49 49 (private srfi69 50 unboundvaluethunk51 50 %objectuidhash %eq?hash %eqv?hash %equal?hash 52 %hashtablecopy %hashtable ref %hashtableupdate! %hashtablemerge!51 %hashtablecopy %hashtablemerge! 53 52 %hashtableforeach %hashtablefold 54 hashtablecanonicallength hashtablerehash ) 53 hashtablecanonicallength 54 %hashtablerehash! %hashtablecheckresize! 55 %hashtableupdate!/default ) 55 56 56 57 (declare 57 58 (hide 58 unboundvaluethunk59 59 %objectuidhash %eq?hash %eqv?hash %equal?hash 60 %hashtablecopy %hashtable ref %hashtableupdate! %hashtablemerge!60 %hashtablecopy %hashtablemerge! 61 61 %hashtableforeach %hashtablefold 62 hashtablecanonicallength hashtablerehash) ) 62 hashtablecanonicallength 63 %hashtablerehash! %hashtablecheckresize! 64 %hashtableupdate!/default ) ) 63 65 64 66 (condexpand … … 75 77 76 78 (registerfeature! 'srfi69) 77 78 79 ;;; Unbound Value:80 81 ;; This only works because of '(noboundchecks)'82 83 (definemacro ($unboundvalue)84 '(##sys#slot '##sys#arbitraryunboundsymbol 0) )85 86 (define unboundvaluethunk (lambda () ($unboundvalue)))87 88 (definemacro ($unbound? ?val)89 `(eq? ($unboundvalue) ,?val) )90 79 91 80 … … 325 314 (define (%equal?hash obj) 326 315 327 ; Recurse into some portion of the vector's slots 316 ; Recurse into some portion of the vector's slots 328 317 (define (vectorhash obj seed depth start) 329 318 (let ([len (##sys#size obj)]) … … 608 597 (thunk) ) ) 609 598 599 ;; %hashtablerehash!: 600 601 (define (%hashtablerehash! vec1 vec2 hash) 602 (let ([len1 (##sys#size vec1)] 603 [len2 (##sys#size vec2)] ) 604 (do ([i 0 (fx+ i 1)]) 605 [(fx>= i len1)] 606 (let loop ([bucket (##sys#slot vec1 i)]) 607 (unless (null? bucket) 608 (let* ([pare (##sys#slot bucket 0)] 609 [key (##sys#slot pare 0)] 610 [hshidx (hash key len2)] ) 611 (##sys#setslot vec2 hshidx 612 (cons (cons key (##sys#slot pare 1)) (##sys#slot vec2 hshidx))) 613 (loop (##sys#slot bucket 1)) ) ) ) ) ) ) 614 615 ;; %hashtableresize!: 616 617 (define (%hashtableresize! ht vec len) 618 (let* ([deslen (fxmin hashtablemaxlength (fx* len hashtablenewlengthfactor))] 619 [newlen (hashtablecanonicallength hashtableprimelengths deslen)] 620 [vec2 (makevector newlen '())] ) 621 (%hashtablerehash! vec vec2 (##sys#slot ht 4)) 622 (##sys#setslot ht 1 vec2) ) ) 623 624 ;; %hashtablecheckresize!: 625 626 #; ;UNUSED 627 (define %hashtablecheckresize! 628 ; Note that these are standard integrations! 629 (let ([floor floor] 630 [inexact>exact inexact>exact] 631 [* *] ) 632 (lambda (ht newsiz) 633 (let ([vec (##sys#slot ht 1)] 634 [minload (##sys#slot ht 5)] 635 [maxload (##sys#slot ht 6)] ) 636 (let ([len (##sys#size vec)] ) 637 (let ([minloadlen (inexact>exact (floor (* len minload)))] 638 [maxloadlen (inexact>exact (floor (* len maxload)))] ) 639 (if (and (fx< len hashtablemaxlength) 640 (fx<= minloadlen newsiz) (fx<= newsiz maxloadlen)) 641 (%hashtableresize! ht vec len) ) ) ) ) ) ) ) 642 643 (defineinline (%hashtablecheckresize! ht newsiz) 644 (let ([vec (##sys#slot ht 1)] 645 [minload (##sys#slot ht 5)] 646 [maxload (##sys#slot ht 6)] ) 647 (let ([len (##sys#size vec)] ) 648 (let ([minloadlen (inexact>exact (floor (* len minload)))] 649 [maxloadlen (inexact>exact (floor (* len maxload)))] ) 650 (if (and (fx< len hashtablemaxlength) 651 (fx<= minloadlen newsiz) (fx<= newsiz maxloadlen)) 652 (%hashtableresize! ht vec len) ) ) ) ) ) 653 610 654 ;; hashtablecopy: 611 655 … … 642 686 ;; Modified for ht props min & max load. 643 687 644 (define (hashtablerehash vec1 vec2 hash) 645 (let ([len1 (##sys#size vec1)] 646 [len2 (##sys#size vec2)] ) 647 (do ([i 0 (fx+ i 1)]) 648 [(fx>= i len1)] 649 (let loop ([bucket (##sys#slot vec1 i)]) 650 (unless (null? bucket) 651 (let* ([pare (##sys#slot bucket 0)] 652 [key (##sys#slot pare 0)] 653 [hshidx (hash key len2)] ) 654 (##sys#setslot vec2 hshidx 655 (cons (cons key (##sys#slot pare 1)) 656 (##sys#slot vec2 hshidx))) 657 (loop (##sys#slot bucket 1)) ) ) ) ) ) ) 658 659 (define %hashtableupdate! 660 (let ([coreeq? eq?] 661 [floor floor] ) 662 (lambda (ht key func thunk) 663 (let ([hash (##sys#slot ht 4)] 664 [test (##sys#slot ht 3)] 665 [newsiz (fx+ (##sys#slot ht 2) 1)] 666 [minload (##sys#slot ht 5)] 667 [maxload (##sys#slot ht 6)] ) 668 (let reenter () 669 (let* ([vec (##sys#slot ht 1)] 670 [len (##sys#size vec)] ) 671 (let ([minloadlen (inexact>exact (floor (* len minload)))] 672 [maxloadlen (inexact>exact (floor (* len maxload)))] 673 [hshidx (hash key len)] ) 674 ; Need to resize table? 675 (if (and (fx< len hashtablemaxlength) 676 (fx<= minloadlen newsiz) (fx<= newsiz maxloadlen)) 677 ; then resize the table: 678 (let ([vec2 (makevector 679 (hashtablecanonicallength 680 hashtableprimelengths 681 (fxmin hashtablemaxlength 682 (fx* len hashtablenewlengthfactor))) 683 '())]) 684 (hashtablerehash vec vec2 hash) 685 (##sys#setslot ht 1 vec2) 686 (reenter) ) 687 ; else update the table: 688 (let ([bucket0 (##sys#slot vec hshidx)]) 689 (if (eq? coreeq? test) 690 ; Fast path (eq? is rewritten by the compiler): 691 (let loop ([bucket bucket0]) 692 (cond [(null? bucket) 693 (let ([val (func (thunk))]) 694 (##sys#setslot vec hshidx (cons (cons key val) bucket0)) 695 (##sys#setislot ht 2 newsiz) 696 val) ] 697 [else 698 (let ([pare (##sys#slot bucket 0)]) 699 (if (eq? key (##sys#slot pare 0)) 700 (let ([val (func (##sys#slot pare 1))]) 701 (##sys#setslot pare 1 val) 702 val) 703 (loop (##sys#slot bucket 1)) ) ) ] ) ) 704 ; Slow path 705 (let loop ([bucket bucket0]) 706 (cond [(null? bucket) 707 (let ([val (func (thunk))]) 708 (##sys#setslot vec hshidx (cons (cons key val) bucket0)) 709 (##sys#setislot ht 2 newsiz) 710 val) ] 711 [else 712 (let ([pare (##sys#slot bucket 0)]) 713 (if (test key (##sys#slot pare 0)) 714 (let ([val (func (##sys#slot pare 1))]) 715 (##sys#setslot pare 1 val) 716 val) 717 (loop (##sys#slot bucket 1)) ) ) ] ) ) ) ) ) ) ) ) ) ) ) ) 718 719 (define (hashtableupdate! 720 ht key 721 #!optional (func identity) 722 (thunk 723 (let ([thunk (##sys#slot ht 9)]) 724 (or thunk 725 (lambda () 726 (##sys#signalhook #:accesserror 727 'hashtableupdate! 728 "hashtable does not contain key" key ht)))))) 729 (##sys#checkstructure ht 'hashtable 'hashtableupdate!) 730 (##sys#checkclosure func 'hashtableupdate!) 731 (##sys#checkclosure thunk 'hashtableupdate!) 732 (%hashtableupdate! ht key func thunk) ) 688 (define hashtableupdate! 689 (let ([coreeq? eq?] ) 690 (lambda (ht key 691 #!optional (func identity) 692 (thunk 693 (let ([thunk (##sys#slot ht 9)]) 694 (or thunk 695 (lambda () 696 (##sys#signalhook #:accesserror 697 'hashtableupdate! 698 "hashtable does not contain key" key ht)))))) 699 (##sys#checkstructure ht 'hashtable 'hashtableupdate!) 700 (##sys#checkclosure func 'hashtableupdate!) 701 (##sys#checkclosure thunk 'hashtableupdate!) 702 (let ([newsiz (fx+ (##sys#slot ht 2) 1)] ) 703 (%hashtablecheckresize! ht newsiz) 704 (let ([hash (##sys#slot ht 4)] 705 [test (##sys#slot ht 3)] 706 [vec (##sys#slot ht 1)] ) 707 (let* ([len (##sys#size vec)] 708 [hshidx (hash key len)] 709 [bucket0 (##sys#slot vec hshidx)] ) 710 (if (eq? coreeq? test) 711 ; Fast path (eq? is rewritten by the compiler): 712 (let loop ([bucket bucket0]) 713 (if (null? bucket) 714 (let ([val (func (thunk))]) 715 (##sys#setslot vec hshidx (cons (cons key val) bucket0)) 716 (##sys#setislot ht 2 newsiz) 717 val ) 718 (let ([pare (##sys#slot bucket 0)]) 719 (if (eq? key (##sys#slot pare 0)) 720 (let ([val (func (##sys#slot pare 1))]) 721 (##sys#setslot pare 1 val) 722 val) 723 (loop (##sys#slot bucket 1)) ) ) ) ) 724 ; Slow path 725 (let loop ([bucket bucket0]) 726 (if (null? bucket) 727 (let ([val (func (thunk))]) 728 (##sys#setslot vec hshidx (cons (cons key val) bucket0)) 729 (##sys#setislot ht 2 newsiz) 730 val ) 731 (let ([pare (##sys#slot bucket 0)]) 732 (if (test key (##sys#slot pare 0)) 733 (let ([val (func (##sys#slot pare 1))]) 734 (##sys#setslot pare 1 val) 735 val ) 736 (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) ) ) ) ) 737 738 (define %hashtableupdate!/default 739 (let ([coreeq? eq?] ) 740 (lambda (ht key func def) 741 (let ([newsiz (fx+ (##sys#slot ht 2) 1)] ) 742 (%hashtablecheckresize! ht newsiz) 743 (let ([hash (##sys#slot ht 4)] 744 [test (##sys#slot ht 3)] 745 [vec (##sys#slot ht 1)] ) 746 (let* ([len (##sys#size vec)] 747 [hshidx (hash key len)] 748 [bucket0 (##sys#slot vec hshidx)] ) 749 (if (eq? coreeq? test) 750 ; Fast path (eq? is rewritten by the compiler): 751 (let loop ([bucket bucket0]) 752 (if (null? bucket) 753 (let ([val (func def)]) 754 (##sys#setslot vec hshidx (cons (cons key val) bucket0)) 755 (##sys#setislot ht 2 newsiz) 756 val ) 757 (let ([pare (##sys#slot bucket 0)]) 758 (if (eq? key (##sys#slot pare 0)) 759 (let ([val (func (##sys#slot pare 1))]) 760 (##sys#setslot pare 1 val) 761 val) 762 (loop (##sys#slot bucket 1)) ) ) ) ) 763 ; Slow path 764 (let loop ([bucket bucket0]) 765 (if (null? bucket) 766 (let ([val (func def)]) 767 (##sys#setslot vec hshidx (cons (cons key val) bucket0)) 768 (##sys#setislot ht 2 newsiz) 769 val ) 770 (let ([pare (##sys#slot bucket 0)]) 771 (if (test key (##sys#slot pare 0)) 772 (let ([val (func (##sys#slot pare 1))]) 773 (##sys#setslot pare 1 val) 774 val ) 775 (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) ) ) ) ) 733 776 734 777 (define (hashtableupdate!/default ht key func def) 735 778 (##sys#checkstructure ht 'hashtable 'hashtableupdate!/default) 736 779 (##sys#checkclosure func 'hashtableupdate!/default) 737 (%hashtableupdate! ht key func (lambda () def)) ) 738 739 (define (hashtableset! ht key val) 740 (##sys#checkstructure ht 'hashtable 'hashtableset!) 741 (let ([thunk (lambda _ val)]) 742 (%hashtableupdate! ht key thunk thunk) ) 743 (void) ) 780 (%hashtableupdate!/default ht key func def) ) 781 782 (define hashtableset! 783 (let ([coreeq? eq?] ) 784 (lambda (ht key val) 785 (##sys#checkstructure ht 'hashtable 'hashtableset!) 786 (let ([newsiz (fx+ (##sys#slot ht 2) 1)] ) 787 (%hashtablecheckresize! ht newsiz) 788 (let ([hash (##sys#slot ht 4)] 789 [test (##sys#slot ht 3)] 790 [vec (##sys#slot ht 1)] ) 791 (let* ([len (##sys#size vec)] 792 [hshidx (hash key len)] 793 [bucket0 (##sys#slot vec hshidx)] ) 794 (if (eq? coreeq? test) 795 ; Fast path (eq? is rewritten by the compiler): 796 (let loop ([bucket bucket0]) 797 (if (null? bucket) 798 (begin 799 (##sys#setslot vec hshidx (cons (cons key val) bucket0)) 800 (##sys#setislot ht 2 newsiz) ) 801 (let ([pare (##sys#slot bucket 0)]) 802 (if (eq? key (##sys#slot pare 0)) 803 (##sys#setslot pare 1 val) 804 (loop (##sys#slot bucket 1)) ) ) ) ) 805 ; Slow path 806 (let loop ([bucket bucket0]) 807 (if (null? bucket) 808 (begin 809 (##sys#setslot vec hshidx (cons (cons key val) bucket0)) 810 (##sys#setislot ht 2 newsiz) ) 811 (let ([pare (##sys#slot bucket 0)]) 812 (if (test key (##sys#slot pare 0)) 813 (##sys#setslot pare 1 val) 814 (loop (##sys#slot bucket 1)) ) ) ) ) ) 815 (void) ) ) ) ) ) ) 744 816 745 817 ;; HashTable Reference: 746 818 747 (define %hashtableref 819 (define hashtableref 820 (getterwithsetter 821 (let ([coreeq? eq?]) 822 (lambda (ht key #!optional (def (lambda () 823 (##sys#signalhook #:accesserror 824 'hashtableref 825 "hashtable does not contain key" key ht)))) 826 (##sys#checkstructure ht 'hashtable 'hashtableref) 827 (##sys#checkclosure def 'hashtableref) 828 (let ([vec (##sys#slot ht 1)] 829 [test (##sys#slot ht 3)] ) 830 (let* ([hash (##sys#slot ht 4)] 831 [hshidx (hash key (##sys#size vec))] ) 832 (if (eq? coreeq? test) 833 ; Fast path (eq? is rewritten by the compiler): 834 (let loop ([bucket (##sys#slot vec hshidx)]) 835 (if (null? bucket) 836 (def) 837 (let ([pare (##sys#slot bucket 0)]) 838 (if (eq? key (##sys#slot pare 0)) 839 (##sys#slot pare 1) 840 (loop (##sys#slot bucket 1)) ) ) ) ) 841 ; Slow path 842 (let loop ([bucket (##sys#slot vec hshidx)]) 843 (if (null? bucket) 844 (def) 845 (let ([pare (##sys#slot bucket 0)]) 846 (if (test key (##sys#slot pare 0)) 847 (##sys#slot pare 1) 848 (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) ) ) 849 hashtableset!) ) 850 851 (define hashtableref/default 748 852 (let ([coreeq? eq?]) 749 853 (lambda (ht key def) 750 (let ([vec (##sys#slot ht 1)] 751 [test (##sys#slot ht 3)] ) 752 (let* ([hash (##sys#slot ht 4)] 753 [hshidx (hash key (##sys#size vec))] ) 854 (##sys#checkstructure ht 'hashtable 'hashtableref/default) 855 (let ([vec (##sys#slot ht 1)] 856 [test (##sys#slot ht 3)] ) 857 (let* ([hash (##sys#slot ht 4)] 858 [hshidx (hash key (##sys#size vec))] ) 754 859 (if (eq? coreeq? test) 755 860 ; Fast path (eq? is rewritten by the compiler): 756 861 (let loop ([bucket (##sys#slot vec hshidx)]) 757 862 (if (null? bucket) 758 (def)863 def 759 864 (let ([pare (##sys#slot bucket 0)]) 760 865 (if (eq? key (##sys#slot pare 0)) … … 764 869 (let loop ([bucket (##sys#slot vec hshidx)]) 765 870 (if (null? bucket) 766 (def)871 def 767 872 (let ([pare (##sys#slot bucket 0)]) 768 873 (if (test key (##sys#slot pare 0)) … … 770 875 (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) ) ) ) 771 876 772 (define hashtableref 773 (getterwithsetter 774 (lambda (ht key #!optional (def (lambda () 775 (##sys#signalhook #:accesserror 776 'hashtableref 777 "hashtable does not contain key" key ht)))) 778 (##sys#checkstructure ht 'hashtable 'hashtableref) 779 (##sys#checkclosure def 'hashtableref) 780 (%hashtableref ht key def) ) 781 hashtableset!)) 782 783 (define (hashtableref/default ht key default) 784 (##sys#checkstructure ht 'hashtable 'hashtableref/default) 785 (%hashtableref ht key (lambda () default)) ) 786 787 (define (hashtableexists? ht key) 788 (##sys#checkstructure ht 'hashtable 'hashtableexists?) 789 (not ($unbound? (%hashtableref ht key unboundvaluethunk))) ) 877 (define hashtableexists? 878 (let ([coreeq? eq?]) 879 (lambda (ht key) 880 (##sys#checkstructure ht 'hashtable 'hashtableexists?) 881 (let ([vec (##sys#slot ht 1)] 882 [test (##sys#slot ht 3)] ) 883 (let* ([hash (##sys#slot ht 4)] 884 [hshidx (hash key (##sys#size vec))] ) 885 (if (eq? coreeq? test) 886 ; Fast path (eq? is rewritten by the compiler): 887 (let loop ([bucket (##sys#slot vec hshidx)]) 888 (and (not (null? bucket)) 889 (let ([pare (##sys#slot bucket 0)]) 890 (or (eq? key (##sys#slot pare 0)) 891 (loop (##sys#slot bucket 1)) ) ) ) ) 892 ; Slow path 893 (let loop ([bucket (##sys#slot vec hshidx)]) 894 (and (not (null? bucket)) 895 (let ([pare (##sys#slot bucket 0)]) 896 (or (test key (##sys#slot pare 0)) 897 (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) ) ) ) 790 898 791 899 ;; hashtabledelete!: … … 870 978 [(null? lst)] 871 979 (let ([b (##sys#slot lst 0)]) 872 (%hashtableupdate! ht1 (##sys#slot b 0) 873 identity (lambda () (##sys#slot b 1))) ) ) ) ) ) 980 (%hashtableupdate!/default ht1 (##sys#slot b 0) identity (##sys#slot b 1)) ) ) ) ) ) 874 981 875 982 (define (hashtablemerge! ht1 ht2) … … 906 1013 (let ([ht (apply makehashtable rest)]) 907 1014 (foreach (lambda (x) 908 (%hashtableupdate! ht (##sys#slot x 0) 909 identity (lambda () (##sys#slot x 1))) ) 1015 (%hashtableupdate!/default ht (##sys#slot x 0) identity (##sys#slot x 1)) ) 910 1016 alist) 911 1017 ht ) ) ) )
Note: See TracChangeset
for help on using the changeset viewer.