Changeset 8278 in project


Ignore:
Timestamp:
02/08/08 01:10:19 (12 years ago)
Author:
Kon Lovett
Message:

Bug fixes for hash-table & hash. Added hash-table test to runtests.

Location:
chicken/trunk
Files:
1 added
3 edited

Legend:

Unmodified
Added
Removed
  • chicken/trunk/buildsvnrevision

    r8235 r8278  
    1 8234
     18277
  • chicken/trunk/extras.scm

    r8275 r8278  
    6464      ##sys#pointer->string ##sys#user-print-hook ##sys#peek-char-0
    6565      ##sys#read-char-0 ##sys#write-char ##sys#string-append ##sys#gcd ##sys#lcm
    66       ##sys#fudge ##sys#check-list ##sys#user-read-hook ##sys#check-closure
    67       %equal?-hash
    68       hash-table-set!
     66      ##sys#fudge ##sys#check-list ##sys#user-read-hook ##sys#check-closure ##sys#check-inexact
     67      ##extras#%equal?-hash
    6968      input-port? make-vector list->vector sort! merge! open-output-string floor
    7069      get-output-string current-output-port display write port? list->string
     
    7675  fprintf0 generic-write
    7776  unbound-value-thunk false-thunk
    78   %number-hash %object-uid-hash %eq?-hash %eqv?-hash %equal?-hash
    79   %hash-table-ref %hash-table-update! %hash-table-for-each %hash-table-fold
     77  %object-uid-hash %eq?-hash %eqv?-hash %equal?-hash
     78  %hash-table-copy %hash-table-ref %hash-table-update! %hash-table-merge!
     79  %hash-table-for-each %hash-table-fold
    8080  hash-table-canonical-length hash-table-rehash )
    8181
     
    8484    fprintf0 generic-write
    8585    unbound-value-thunk false-thunk
    86     %number-hash %object-uid-hash %eq?-hash %eqv?-hash %equal?-hash
    87     %hash-table-ref %hash-table-update! %hash-table-for-each %hash-table-fold
     86    %object-uid-hash %eq?-hash %eqv?-hash %equal?-hash
     87    %hash-table-copy %hash-table-ref %hash-table-update! %hash-table-merge!
     88    %hash-table-for-each %hash-table-fold
    8889    hash-table-canonical-length hash-table-rehash) )
    8990
     
    9293  (eval-when (compile)
    9394    (define-macro (##sys#check-closure . _) '(##core#undefined))
     95    (define-macro (##sys#check-inexact . _) '(##core#undefined))
    9496    (define-macro (##sys#check-structure . _) '(##core#undefined))
    9597    (define-macro (##sys#check-range . _) '(##core#undefined))
     
    113115;; This only works because of '(no-bound-checks)'
    114116
    115 (define *unbound* (##sys#slot '##sys#arbitrary-unbound-symbol 0))
    116 
    117 (define unbound-value-thunk (lambda () *unbound*))
     117(define-macro ($unbound-value)
     118 '(##sys#slot '##sys#arbitrary-unbound-symbol 0) )
     119
     120(define unbound-value-thunk (lambda () ($unbound-value)))
    118121
    119122(define-macro ($unbound? ?val)
    120   `(eq? *unbound* ,?val) )
     123  `(eq? ($unbound-value) ,?val) )
    121124
    122125
    123126;;; Core Inlines:
    124127
    125 (define-inline ($quick-flonum-truncate flo)
    126   `(##core#inline "C_quickflonumtruncate" flo) )
    127 
    128 (define-inline ($block? obj)
    129   (##core#inline "C_blockp" obj) )
    130 
    131 (define-inline ($pair? obj)
    132   (##core#inline "C_pairp" obj) )
    133 
    134 (define-inline ($special? obj)
    135   (##core#inline "C_specialp" obj) )
    136 
    137 (define-inline ($port? obj)
    138   (##core#inline "C_portp" obj) )
    139 
    140 (define-inline ($byte-block? obj)
    141   (##core#inline "C_byteblockp" obj) )
    142 
    143 (define-inline ($hash-string str)
    144   (##core#inline "C_hash_string" str) )
    145 
    146 (define-inline ($hash-string-ci str)
    147   (##core#inline "C_hash_string_ci" str) )
     128(define-macro ($quick-flonum-truncate ?flo)
     129  `(##core#inline "C_quickflonumtruncate" ,?flo) )
     130
     131(define-macro ($fix ?wrd)
     132  `(##core#inline "C_fix" ,?wrd) )
     133
     134(define-macro ($block? ?obj)
     135  `(##core#inline "C_blockp" ,?obj) )
     136
     137(define-macro ($special? ?obj)
     138  `(##core#inline "C_specialp" ,?obj) )
     139
     140(define-macro ($port? ?obj)
     141  `(##core#inline "C_portp" ,?obj) )
     142
     143(define-macro ($byte-block? ?obj)
     144  `(##core#inline "C_byteblockp" ,?obj) )
     145
     146(define-macro ($hash-string ?str)
     147  `(##core#inline "C_hash_string" ,?str) )
     148
     149(define-macro ($hash-string-ci ?str)
     150  `(##core#inline "C_hash_string_ci" ,?str) )
    148151
    149152
    150153;;;
    151 
    152 (define-macro ($64-bit?)
    153   `(##sys#fudge 3) )
    154154
    155155(define-macro ($immediate? ?obj)
     
    159159;;; Boolean Thunks:
    160160
    161 #; ;UNUSED
    162 (define true-thunk (lambda () #t))
    163 
    164161(define false-thunk (lambda () #f))
    165 
    166 #; ;UNUSED
    167 (define-macro ($unbound-symbol? ?sym)
    168   `($unbound-value? (##sys#slot ,?sym 0)) )
    169162
    170163
     
    294287  (let loop ((lst lst))
    295288    (let ((next (##sys#slot lst 1)))
    296       (if (and ($block? next) ($pair? next))
     289      (if (and (##core#inline "C_blockp" next) (##core#inline "C_pairp" next))
    297290          (cons (##sys#slot lst 0) (loop next))
    298291          '() ) ) ) )
     
    821814              ((##core#inline "C_undefinedp" obj) (out "#<unspecified>" col))
    822815              ((##core#inline "C_anypointerp" obj) (out (##sys#pointer->string obj) col))
    823               (($unbound? obj)
     816              ((eq? obj (##sys#slot '##sys#arbitrary-unbound-symbol 0))
    824817               (out "#<unbound value>" col) )
    825818              ((##sys#generic-structure? obj)
     
    12061199                               (##core#inline "C_substring_copy" ds str2 0 dslen n3)
    12071200                               (loop2 next (fx+ n3 dslen)) ) ) ) ) ) ) ) )
    1208             ((and ($block? ss) ($pair? ss))
     1201            ((and (##core#inline "C_blockp" ss) (##core#inline "C_pairp" ss))
    12091202             (let ((stri (##sys#slot ss 0)))
    12101203               (##sys#check-string stri 'string-intersperse)
     
    15921585;; foo - global checked procedure
    15931586
     1587;; All '%foo-hash' return fixnum
     1588
    15941589;; Fixed hash-values:
    15951590
     
    16071602;; Force Hash to Bounded Fixnum:
    16081603
     1604(define-macro ($fxabs ?fxn)
     1605  `(let ([_fxn ,?fxn]) (if (fx< _fxn 0) (fxneg _fxn) _fxn ) ) )
     1606
    16091607(define-macro ($hash/limit ?hsh ?lim)
    16101608  `(fxmod (fxand (foreign-value "C_MOST_POSITIVE_FIXNUM" int)
    1611                  ,?hsh)
     1609                 ($fxabs ,?hsh))
    16121610          ,?lim) )
    16131611
     
    16161614(define-constant flonum-magic 331804471)
    16171615
    1618 (define-macro ($hash-flonum ?obj)
    1619   `(if ($64-bit?)
    1620        ;XXX should split & combine
    1621        (fx* flonum-magic ($quick-flonum-truncate (##sys#slot ,?obj 0)))
    1622        (fx* flonum-magic
    1623             (fx+ ($quick-flonum-truncate (##sys#slot ,?obj 0))
    1624                  (fxshl ($quick-flonum-truncate (##sys#slot ,?obj 1)) 1))) ) )
    1625 
    1626 (define ##sys#number-hash-hook %equal?-hash)
    1627 
    1628 (define (%number-hash obj)
    1629   (cond [(fixnum? obj)  obj]
    1630         [(flonum? obj)  ($hash-flonum ?obj) ]
    1631         [else           (##sys#number-hash-hook obj)] ) )
     1616(define-macro ($subbyte ?bytvec ?i)
     1617  `(##core#inline "C_subbyte" ,?bytvec ,?i) )
     1618
     1619#; ; Not sure which is "better"
     1620(define-macro ($hash-flonum ?flo)
     1621  `(fx* flonum-magic
     1622        ,(let loop ([idx (fx- (##sys#size 1.0) 1)])
     1623            (if (fx= 0 idx)
     1624                `($subbyte ,?flo 0)
     1625                `(fx+ ($subbyte ,?flo ,idx)
     1626                      (fxshl ,(loop (fx- idx 1)) 1))))) )
     1627
     1628(define-macro ($hash-flonum ?flo)
     1629  `(fx* flonum-magic ($quick-flonum-truncate ,?flo)) )
     1630
     1631(define (##sys#number-hash-hook obj)
     1632  (%equal?-hash obj) )
     1633
     1634(define-macro ($other-number-hash ?obj)
     1635  `(cond [(flonum? obj) ($hash-flonum ,?obj)]
     1636         [else          ($fix (##sys#number-hash-hook ,?obj))] ) )
     1637
     1638(define-macro ($number-hash ?obj)
     1639  `(cond [(fixnum? obj) ,?obj]
     1640         [else          ($other-number-hash ?obj)] ) )
    16321641
    16331642(define (number-hash obj #!optional (bound hash-default-bound))
     
    16351644    (##sys#signal-hook #:type 'number-hash "invalid number" obj) )
    16361645  (##sys#check-exact bound 'number-hash)
    1637   ($hash/limit (%number-hash obj) bound) )
     1646  ($hash/limit ($number-hash obj) bound) )
    16381647
    16391648;; Object UID Hash:
     
    16421651(define (%object-uid-hash obj)
    16431652  (%uid-hash (##sys#object->uid obj)) )
    1644 (define %object-uid-hash %equal?-hash)
     1653
     1654(define (%object-uid-hash obj)
     1655  (%equal?-hash obj) )
    16451656
    16461657(define (object-uid-hash obj #!optional (bound hash-default-bound))
     
    16531664(define-macro ($symbol-hash ?obj)
    16541665  `(##sys#slot ,?obj INDEX-OF-UNIQUE-HASH-VALUE-COMPUTED-DURING-SYMBOL-CREATION) )
     1666
    16551667(define-macro ($symbol-hash ?obj)
    16561668  `($hash-string (##sys#slot ,?obj 1)) )
     
    16631675;; Keyword Hash:
    16641676
    1665 #| UNUSED (no keyword vs. symbol issue)
    16661677(define (##sys#check-keyword x . y)
    16671678  (unless (keyword? x)
     
    16701681                       "bad argument type - not a keyword" x) ) )
    16711682
    1672 #; ;NOT YET (no unique-symbol-hash)
     1683#; ;NOT YET (no unique-keyword-hash)
    16731684(define-macro ($keyword-hash ?obj)
    16741685  `(##sys#slot ,?obj INDEX-OF-UNIQUE-HASH-VALUE-COMPUTED-DURING-KEYWORD-CREATION) )
     1686
    16751687(define-macro ($keyword-hash ?obj)
    16761688  `($hash-string (##sys#slot ,?obj 1)) )
     
    16801692  (##sys#check-exact bound 'keyword-hash)
    16811693  ($hash/limit ($keyword-hash obj) bound) )
    1682 |#
    16831694
    16841695;; Eq Hash:
     
    16871698  `(or ($immediate? ,?obj)
    16881699       (symbol? ,?obj)
    1689        #; ;UNUSED (no keyword vs. symbol issue)
    1690        (keyword? obj) ) )
     1700       #; ;NOT YET (no keyword vs. symbol issue)
     1701       (keyword? ,?obj) ) )
    16911702
    16921703(define (%eq?-hash obj)
     
    16981709        [(eof-object? obj)      eof-hash-value]
    16991710        [(symbol? obj)          ($symbol-hash obj)]
    1700         #; ;UNUSED (no keyword vs. symbol issue)
     1711        #; ;NOT YET (no keyword vs. symbol issue)
    17011712        [(keyword? obj)         ($keyword-hash obj)]
    17021713        [($immediate? obj)      unknown-immediate-hash-value]
     
    17221733        [(null? obj)            null-hash-value]
    17231734        [(eof-object? obj)      eof-hash-value]
    1724         [(number? obj)          (%number-hash obj)]
    17251735        [(symbol? obj)          ($symbol-hash obj)]
    1726         #; ;UNUSED (no keyword vs. symbol issue)
     1736        #; ;NOT YET (no keyword vs. symbol issue)
    17271737        [(keyword? obj)         ($keyword-hash obj)]
    1728         [($immediate? ,?obj)    unknown-immediate-hash-value]
     1738        [(number? obj)          ($other-number-hash obj)]
     1739        [($immediate? obj)      unknown-immediate-hash-value]
    17291740        [else                   (%object-uid-hash obj) ] ) )
    17301741
     
    17421753
    17431754  (define-macro ($*list-hash ?obj)
    1744     `(fx+ (fxshl (length ,?obj) 4)
     1755    `(fx+ (length ,?obj)
    17451756          (recursive-atomic-hash (##sys#slot ,?obj 0) depth)) )
    17461757
     
    17501761
    17511762  (define-macro ($*port-hash ?obj)
    1752     `(fx+ (fxshl (##sys#peek-fixnum ,?obj 0) 4)
     1763    `(fx+ (fxshl (##sys#peek-fixnum ,?obj 0) 4) ; Little extra "identity"
    17531764          (if (input-port? ,?obj)
    17541765              input-port-hash-value
     
    17921803          [(null? obj)            null-hash-value]
    17931804          [(eof-object? obj)      eof-hash-value]
    1794           [(number? obj)          (%number-hash obj)]
    17951805          [(symbol? obj)          ($symbol-hash obj)]
    1796           #; ;UNUSED (no keyword vs. symbol issue)
     1806          #; ;NOT YET (no keyword vs. symbol issue)
    17971807          [(keyword? obj)         ($keyword-hash obj)]
    1798           [($immediate? ,?obj)    unknown-immediate-hash-value]
     1808          [(number? obj)          ($other-number-hash obj)]
     1809          [($immediate? obj)      unknown-immediate-hash-value]
    17991810          [($byte-block? obj)     ($hash-string obj)]
    1800           [(list? obj)            ($*list-hash ?obj)]
    1801           [(pair? obj)            ($*pair-hash ?obj)]
    1802           [($port? obj)           ($*port-hash ?obj)]
     1811          [(list? obj)            ($*list-hash obj)]
     1812          [(pair? obj)            ($*pair-hash obj)]
     1813          [($port? obj)           ($*port-hash obj)]
    18031814          [($special? obj)        ($*special-vector-hash obj)]
    18041815          [else                   ($*regular-vector-hash obj)] ) )
     
    18871898
    18881899(define make-hash-table
    1889   (let ([core-eq? eq?])
     1900  (let ([core-eq? eq?]
     1901        [core-eqv? eqv?]
     1902        [core-equal? equal?]
     1903        [core-string=? string=?]
     1904        [core-string-ci=? string-ci=?]
     1905        [core= =] )
    18901906    (lambda arguments0
    18911907      (let ([arguments arguments0]
     
    19001916        (let ([hash-for-test
    19011917                (lambda ()
    1902                   (cond [(eq? core-eq? test)      eq?-hash]
    1903                         [(eq? eqv? test)          eqv?-hash]
    1904                         [(eq? equal? test)        equal?-hash]
    1905                         [(eq? string=? test)      string-hash]
    1906                         [(eq? string-ci=? test)   string-ci-hash]
    1907                         [else                     #f] ) ) ] )
     1918                  (cond [(or (eq? core-eq? test)
     1919                             (eq? eq? test))              eq?-hash]
     1920                        [(or (eq? core-eqv? test)
     1921                             (eq? eqv? test))             eqv?-hash]
     1922                        [(or (eq? core-equal? test)
     1923                             (eq? equal? test))           equal?-hash]
     1924                        [(or (eq? core-string=? test)
     1925                             (eq? string=? test))         string-hash]
     1926                        [(or (eq? core-string-ci=? test)
     1927                             (eq? string-ci=? test))      string-ci-hash]
     1928                        [(or (eq? core= test)
     1929                             (eq? = test))                number-hash]
     1930                        [else                             #f] ) ) ] )
    19081931          ; Process optional arguments
    19091932          (unless (null? arguments)
     
    19341957                        (lambda (msg)
    19351958                          (error 'make-hash-table msg arg arguments0))])
    1936                   (if (keyword? args)
     1959                  (if (keyword? arg)
    19371960                      (let* ([nxt (cdr args)]
    19381961                             [val (if (pair? nxt)
     
    19641987                            (set! max-load val)]
    19651988                          [(#:weak-keys)
    1966                             (##sys#check-boolean val 'make-hash-table)
    1967                             (set! weak-keys val)]
     1989                            (set! weak-keys (and val #t))]
    19681990                          [(#:weak-values)
    1969                             (##sys#check-boolean val 'make-hash-table)
    1970                             (set! weak-values val)]
     1991                            (set! weak-values (and val #t))]
    19711992                          [else
    19721993                            (invarg-err "unknown keyword")])
     
    19761997          (when (fp< max-load min-load)
    19771998            (error 'make-hash-table "min-load greater than max-load" min-load max-load) )
    1978           ; Force non-canonical hash-table vector length
     1999          ; Force canonical hash-table vector length
    19792000          (set! size (hash-table-canonical-length hash-table-prime-lengths size))
    19802001          ; Decide on a hash function when not supplied
     
    20252046
    20262047(define (hash-table-has-initial? ht)
    2027   (##sys#check-structure ht 'hash-table 'hash-table-weak-values)
     2048  (##sys#check-structure ht 'hash-table 'hash-table-has-initial?)
    20282049  (and (##sys#slot ht 9)
    20292050       #t ) )
    20302051
    20312052(define (hash-table-initial ht)
    2032   (##sys#check-structure ht 'hash-table 'hash-table-weak-values)
     2053  (##sys#check-structure ht 'hash-table 'hash-table-initial)
    20332054  (and-let* ([thunk (##sys#slot ht 9)])
    20342055    (thunk) ) )
     
    20362057;; hash-table-copy:
    20372058
    2038 (define hash-table-copy
     2059(define %hash-table-copy
    20392060  (let ([make-vector make-vector])
    20402061    (lambda (ht)
    2041       (##sys#check-structure ht 'hash-table 'hash-table-copy)
    20422062      (let* ([vec1 (##sys#slot ht 1)]
    20432063             [len (##sys#size vec1)]
     
    20602080                         (copy-loop (##sys#slot bucket 1))))))) ) ) ) ) )
    20612081
    2062 ;; Hash-Table Reference:
    2063 
    2064 (define %hash-table-ref
    2065   (let ([core-eq? eq?])
    2066     (lambda (ht key def)
    2067        (let  ([vec (##sys#slot ht 1)]
    2068               [test (##sys#slot ht 3)] )
    2069          (let* ([hash (##sys#slot ht 4)]
    2070                 [hshidx (hash key (##sys#size vec))] )
    2071            (if (eq? core-eq? test)
    2072                ; Fast path (eq? is rewritten by the compiler):
    2073                (let loop ([bucket (##sys#slot vec hshidx)])
    2074                  (if (null? bucket)
    2075                      (def)
    2076                      (let ([pare (##sys#slot bucket 0)])
    2077                        (if (eq? key (##sys#slot pare 0))
    2078                            (##sys#slot pare 1)
    2079                            (loop (##sys#slot bucket 1)) ) ) ) )
    2080                ; Slow path
    2081                (let loop ([bucket (##sys#slot vec hshidx)])
    2082                  (if (null? bucket)
    2083                      (def)
    2084                      (let ([pare (##sys#slot bucket 0)])
    2085                        (if (test key (##sys#slot pare 0))
    2086                            (##sys#slot pare 1)
    2087                            (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) ) ) )
    2088 
    2089 (define hash-table-ref
    2090   (getter-with-setter
    2091    (lambda (ht key #!optional (def (lambda ()
    2092                                      (##sys#signal-hook #:access-error
    2093                                       'hash-table-ref
    2094                                       "hash-table does not contain key" key ht))))
    2095      (##sys#check-structure ht 'hash-table 'hash-table-ref)
    2096      (##sys#check-closure def 'hash-table-ref)
    2097      (%hash-table-ref ht key def) )
    2098    hash-table-set!))
    2099 
    2100 (define (hash-table-ref/default ht key default)
    2101   (##sys#check-structure ht 'hash-table 'hash-table-ref/default)
    2102   (%hash-table-ref ht key (lambda () default)) )
    2103 
    2104 (define (hash-table-exists? ht key)
    2105   (##sys#check-structure ht 'hash-table 'hash-table-exists?)
    2106   (not ($unbound? (%hash-table-ref ht key unbound-value-thunk))) )
     2082(define (hash-table-copy ht)
     2083  (##sys#check-structure ht 'hash-table 'hash-table-copy)
     2084  (%hash-table-copy ht) )
    21072085
    21082086;; hash-table-update!:
     
    21872165
    21882166(define (hash-table-update!
    2189          ht key func
    2190          #!optional (thunk
    2191                      (lambda ()
    2192                        (let ([thunk (##sys#slot ht 9)])
    2193                          (or thunk
     2167         ht key
     2168         #!optional (func identity)
     2169                    (thunk
     2170                     (let ([thunk (##sys#slot ht 9)])
     2171                       (or thunk
     2172                           (lambda ()
    21942173                             (##sys#signal-hook #:access-error
    21952174                              'hash-table-update!
     
    22072186(define (hash-table-set! ht key val)
    22082187  (##sys#check-structure ht 'hash-table 'hash-table-set!)
    2209   (let ([val-thunk (lambda _ val)])
    2210     (%hash-table-update! ht key val-thunk val-thunk) ) )
     2188  (%hash-table-update! ht key identity (lambda () val)) )
     2189
     2190;; Hash-Table Reference:
     2191
     2192(define %hash-table-ref
     2193  (let ([core-eq? eq?])
     2194    (lambda (ht key def)
     2195       (let  ([vec (##sys#slot ht 1)]
     2196              [test (##sys#slot ht 3)] )
     2197         (let* ([hash (##sys#slot ht 4)]
     2198                [hshidx (hash key (##sys#size vec))] )
     2199           (if (eq? core-eq? test)
     2200               ; Fast path (eq? is rewritten by the compiler):
     2201               (let loop ([bucket (##sys#slot vec hshidx)])
     2202                 (if (null? bucket)
     2203                     (def)
     2204                     (let ([pare (##sys#slot bucket 0)])
     2205                       (if (eq? key (##sys#slot pare 0))
     2206                           (##sys#slot pare 1)
     2207                           (loop (##sys#slot bucket 1)) ) ) ) )
     2208               ; Slow path
     2209               (let loop ([bucket (##sys#slot vec hshidx)])
     2210                 (if (null? bucket)
     2211                     (def)
     2212                     (let ([pare (##sys#slot bucket 0)])
     2213                       (if (test key (##sys#slot pare 0))
     2214                           (##sys#slot pare 1)
     2215                           (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) ) ) )
     2216
     2217(define hash-table-ref
     2218  (getter-with-setter
     2219   (lambda (ht key #!optional (def (lambda ()
     2220                                     (##sys#signal-hook #:access-error
     2221                                      'hash-table-ref
     2222                                      "hash-table does not contain key" key ht))))
     2223     (##sys#check-structure ht 'hash-table 'hash-table-ref)
     2224     (##sys#check-closure def 'hash-table-ref)
     2225     (%hash-table-ref ht key def) )
     2226   hash-table-set!))
     2227
     2228(define (hash-table-ref/default ht key default)
     2229  (##sys#check-structure ht 'hash-table 'hash-table-ref/default)
     2230  (%hash-table-ref ht key (lambda () default)) )
     2231
     2232(define (hash-table-exists? ht key)
     2233  (##sys#check-structure ht 'hash-table 'hash-table-exists?)
     2234  (not ($unbound? (%hash-table-ref ht key unbound-value-thunk))) )
    22112235
    22122236;; hash-table-delete!:
    22132237
    2214 (define (hash-table-delete! ht key)
    2215   (##sys#check-structure ht 'hash-table 'hash-table-delete!)
     2238(define hash-table-delete!
    22162239  (let ([core-eq? eq?])
    22172240    (lambda (ht key)
     2241      (##sys#check-structure ht 'hash-table 'hash-table-delete!)
    22182242      (let* ([vec (##sys#slot ht 1)]
    22192243             [len (##sys#size vec)] )
     
    22272251                (let loop ([prev #f] [bucket bucket0])
    22282252                  (and (not (null? bucket))
    2229                        (let ([pare (##sys#slot bucket 0)])
     2253                       (let ([pare (##sys#slot bucket 0)]
     2254                             [nxt (##sys#slot bucket 1)])
    22302255                         (if (eq? key (##sys#slot pare 0))
    22312256                             (begin
    2232                                (if (not prev)
    2233                                    (##sys#setslot vec hshidx (##sys#slot bucket 1))
    2234                                    (##sys#setslot prev 1 (##sys#slot bucket 1)))
     2257                               (if prev
     2258                                   (##sys#setslot prev 1 nxt)
     2259                                   (##sys#setslot vec hshidx nxt) )
    22352260                               (##sys#setslot ht 2 newsiz)
    22362261                               #t )
    2237                              (loop bucket (##sys#slot bucket 1)) ) ) ) )
     2262                             (loop bucket nxt) ) ) ) )
    22382263                ; Slow path
    22392264                (let loop ([prev #f] [bucket bucket0])
    22402265                  (and (not (null? bucket))
    2241                        (let ([pare (##sys#slot bucket 0)])
     2266                       (let ([pare (##sys#slot bucket 0)]
     2267                             [nxt (##sys#slot bucket 1)])
    22422268                         (if (test key (##sys#slot pare 0))
    22432269                             (begin
    2244                                (if (not prev)
    2245                                    (##sys#setslot vec hshidx (##sys#slot bucket 1))
    2246                                    (##sys#setslot prev 1 (##sys#slot bucket 1)))
     2270                               (if prev
     2271                                   (##sys#setslot prev 1 nxt)
     2272                                   (##sys#setslot vec hshidx nxt) )
    22472273                               (##sys#setslot ht 2 newsiz)
    22482274                               #t )
    2249                              (loop bucket (##sys#slot bucket 1)) ) ) ) ) ) ) ) ) ) ) )
     2275                             (loop bucket nxt) ) ) ) ) ) ) ) ) ) ) )
    22502276
    22512277;; hash-table-remove!:
     
    22602286          [(fx>= i len) (##sys#setislot ht 2 siz)]
    22612287        (let loop ([prev #f] [bucket (##sys#slot vec i)])
    2262           (unless (null? bucket)
    2263             (let ([pare (##sys#slot bucket 0)])
    2264               (when (func (##sys#slot pare 0) (##sys#slot pare 1))
    2265                 (if prev
    2266                     (##sys#setslot prev 1 (##sys#slot bucket 1))
    2267                     (##sys#setslot vec i (##sys#slot bucket 1)) )
    2268                 (set! siz (fx- siz 1)) )
    2269               (loop bucket (##sys#slot bucket 1) ) ) ) ) ) ) ) )
    2270 
    2271 ;; hash-table-merge!:
    2272 
    2273 (define (hash-table-merge! ht1 ht2)
    2274   (##sys#check-structure ht1 'hash-table 'hash-table-merge!)
    2275   (##sys#check-structure ht2 'hash-table 'hash-table-merge!)
     2288          (and (not (null? bucket))
     2289               (let ([pare (##sys#slot bucket 0)]
     2290                     [nxt (##sys#slot bucket 1)])
     2291                 (if (func (##sys#slot pare 0) (##sys#slot pare 1))
     2292                     (begin
     2293                       (if prev
     2294                           (##sys#setslot prev 1 nxt)
     2295                           (##sys#setslot vec i nxt) )
     2296                       (set! siz (fx- siz 1))
     2297                       #t )
     2298                     (loop bucket nxt ) ) ) ) ) ) ) ) )
     2299
     2300;; Hash Table Merge:
     2301
     2302(define (%hash-table-merge! ht1 ht2)
    22762303  (let* ([vec (##sys#slot ht2 1)]
    22772304         [len (##sys#size vec)] )
     
    22802307      (do ([lst (##sys#slot vec i) (##sys#slot lst 1)])
    22812308          [(null? lst)]
    2282         (let* ([b (##sys#slot lst 0)]
    2283                [val-thunk (lambda _ (##sys#slot b 1))] )
    2284           (%hash-table-update! ht (##sys#slot b 0) val-thunk val-thunk) ) ) ) ) )
     2309        (let ([b (##sys#slot lst 0)])
     2310          (%hash-table-update! ht1 (##sys#slot b 0)
     2311                                   identity (lambda () (##sys#slot b 1))) ) ) ) ) )
     2312
     2313(define (hash-table-merge! ht1 ht2)
     2314  (##sys#check-structure ht1 'hash-table 'hash-table-merge!)
     2315  (##sys#check-structure ht2 'hash-table 'hash-table-merge!)
     2316  (%hash-table-merge! ht1 ht2) )
     2317
     2318(define (hash-table-merge ht1 ht2)
     2319  (##sys#check-structure ht1 'hash-table 'hash-table-merge)
     2320  (##sys#check-structure ht2 'hash-table 'hash-table-merge)
     2321  (%hash-table-merge! (%hash-table-copy ht1) ht2) )
    22852322
    22862323;; Hash-Table <-> Association-List:
     
    22932330      (if (fx>= i len)
    22942331          lst
    2295           (let loop2 ([bucket (##sys#slot vec i)] [lst lst])
     2332          (let loop2 ([bucket (##sys#slot vec i)]
     2333                      [lst lst])
    22962334            (if (null? bucket)
    22972335                (loop (fx+ i 1) lst)
    22982336                (loop2 (##sys#slot bucket 1)
    22992337                       (let ([x (##sys#slot bucket 0)])
    2300                           (cons (cons (##sys#slot x 0) (##sys#slot x 1)) lst) ) ) ) ) ) ) ) )
     2338                         (cons (cons (##sys#slot x 0) (##sys#slot x 1)) lst) ) ) ) ) ) ) ) )
    23012339
    23022340(define alist->hash-table
     
    23042342    (lambda (alist . rest)
    23052343      (##sys#check-list alist 'alist->hash-table)
    2306       (let ((ht (apply make-hash-table rest)))
     2344      (let ([ht (apply make-hash-table rest)])
    23072345        (for-each (lambda (x)
    2308                     (let ([val-thunk (lambda _ (cdr x))])
    2309                       (%hash-table-update! ht (car x) val-thunk val-thunk) ) )
     2346                    (%hash-table-update! ht (##sys#slot x 0)
     2347                                            identity (lambda () (##sys#slot x 1))) )
    23102348                  alist)
    23112349        ht ) ) ) )
     
    24762514       (do ((lst lst0 (##sys#slot lst 1)))
    24772515           ((eq? (##sys#slot lst 1) '()) lst)
    2478          (if (or ($immediate? lst)
    2479                  (not ($pair? lst)) )
     2516         (if (or (not (##core#inline "C_blockp" lst))
     2517                 (not (##core#inline "C_pairp" lst)) )
    24802518             (##sys#not-a-proper-list-error lst0 'list->queue) ) ) ) ) )
    24812519
  • chicken/trunk/tests/runtests.sh

    r7972 r8278  
    1414echo "======================================== library tests ..."
    1515../csi -w -s library-tests.scm
     16
     17echo "======================================== hash-table tests ..."
     18../csi -w -s hash-table-tests.scm
    1619
    1720echo "======================================== port tests ..."
Note: See TracChangeset for help on using the changeset viewer.