;;; srfi.69.weak.var.scm - Optional non-standard extensions
;
; Copyright (c) 2008-2021, The Chicken Team
; Copyright (c) 2000-2007, Felix L. Winkelmann
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
; conditions are met:
;
;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
;     disclaimer.
;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
;     disclaimer in the documentation and/or other materials provided with the distribution.
;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
;     products derived from this software without specific prior written permission.
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.

(declare
  (bound-to-procedure
    ##sys#slot ##sys#setslot ##sys#setislot ##sys#size))

(module (srfi 69 weak var) (make-hash-table
                            hash-table?
                            hash-table-size
                            hash-table-equivalence-function
                            hash-table-hash-function
                            hash-table-min-load
                            hash-table-max-load
                            hash-table-weak-keys
                            hash-table-weak-values
                            hash-table-has-initial?
                            hash-table-initial
                            hash-table-copy hash-table-empty-copy
                            hash-table-update!
                            hash-table-update!/default
                            hash-table-set!
                            hash-table-set*!
                            hash-table-ref
                            hash-table-ref/default
                            hash-table-exists?
                            hash-table-delete!
                            hash-table-remove!
                            hash-table-pop!
                            hash-table-clear!
                            hash-table-merge!
                            hash-table-merge
                            hash-table-clean!
                            hash-table->alist
                            alist->hash-table
                            hash-table->plist
                            plist->hash-table
                            hash-table-keys
                            hash-table-values
                            hash-table-key-vector
                            hash-table-value-vector
                            hash-table-find
                            hash-table-union!
                            hash-table-intersection!
                            hash-table-difference!
                            hash-table-xor!
                            hash-table-fold
                            hash-table-for-each
                            hash-table-map
                            hash-table-walk)

(import (scheme)
        (chicken base)
        (chicken fixnum)
        (only (chicken platform) register-feature!)
        (only (chicken random) pseudo-random-integer)
        (only (chicken format) sprintf))
(import (only (srfi 69 hash) wrap-hash/std))
;prefixing helps ensure <exporting-module>#<imported-name>
(import (prefix (srfi 69 record) im:))

(register-feature! 'srfi-69-weak)

;;; Naming Conventions:

;; %foo - inline primitive
;; %%foo - local inline (no such thing but at least it looks different)
;; $foo - local macro
;; *foo - local unchecked variant of a checked procedure
;; ##sys#foo - public, but undocumented, un-checked procedure
;; foo - public checked procedure

;;; Hash-Tables:

(define-constant *mod-ht-kind* 'weak.var)

(include-relative "srfi.69.support.incl")

(define cons/strong               cons)
(define weak-cons/key             weak-cons)
(define (weak-cons/val key val)   (weak-cons val key))
(define (weak-cons/both key val)  (weak-cons key (weak-cons val (void))))

(define (entry-object-ctor wk? wv?)
  (cond ((and (not wk?) (not wv?))  cons/strong)
        ((and wk? (not wv?))        weak-cons/key)
        ((and (not wk?) wv?)        weak-cons/val)
        (else                       weak-cons/both) ) )

(define-inline (key-of pare wk? wv?)
  (cond ((not wv?)  (%car pare))
        ((not wk?)  (%cdr pare))
        (else       (%car pare)) ) )

(define-inline (val-of pare wk? wv?)
  (cond ((not wv?)  (%cdr pare))
        ((not wk?)  (%car pare))
        (else       (%cadr pare)) ) )

(define-inline (val-of-set! pare val wk? wv?)
  (cond ((not wv?)  (%set-cdr! pare val))
        ((not wk?)  (%set-car! pare val))
        (else       (%set-cadr! pare val)) ) )

(define-inline (bwp-entry? k v)
  (or (bwp-object? k) (bwp-object? v)) )

(define (error-not-bwp loc obj nam)
  (error loc (sprintf "invalid ~A" nam) obj) )

(define (check-not-bwp loc obj nam)
  (when (bwp-object? obj) (error-not-bwp loc obj nam))
  obj )

(define (check-key loc obj)
  (check-not-bwp loc obj 'key) )

(define (check-value loc obj)
  (check-not-bwp loc obj 'value) )

(define-syntax bucket-search-body/plain*
  (syntax-rules ()
    ((bucket-search-body/plain* ?wk? ?wv?
                                ?ht ?key ?test ?vec ?hshidx
                                (?prv ?cur ?nxt ?pare ?parkey ?parval)
                                ?succ
                                ()
                                ?fail)
      (let loop ((?prv #f) (?cur (%vector-ref ?vec ?hshidx)))
        (if (null? ?cur)
            ?fail
            (let* ((?pare (%car ?cur))
                   (?nxt (%cdr ?cur))
                   (?parkey (key-of ?pare ?wk? ?wv?))
                   (?parval (val-of ?pare ?wk? ?wv?)) )
              (if (?test ?key ?parkey)
                  ?succ
                  (loop ?cur ?nxt) ) ) ) ) ) ) )

(define-syntax bucket-search-body/scavenge*
  (syntax-rules ()
    ((bucket-search-body/scavenge* ?wk? ?wv?
                                   ?ht ?key ?test ?vec ?hshidx
                                   (?prv ?cur ?nxt ?pare ?parkey ?parval)
                                   ?succ
                                   ()
                                   ?fail)
      (let loop ((?prv #f) (?cur (%vector-ref ?vec ?hshidx)))
        (if (null? ?cur)
            ?fail
            (let* ((?pare (%car ?cur))
                   (?nxt (%cdr ?cur))
                   (?parkey (key-of ?pare ?wk? ?wv?))
                   (?parval (val-of ?pare ?wk? ?wv?)) )
              (if (bwp-entry? ?parkey ?parval)
                  (begin
                    (if ?prv
                        (%set-cdr! ?prv ?nxt)
                        (%vector-set! ?vec ?hshidx ?nxt))
                    ;FIXME use loop var & set! on exit
                    (%ht-size-set! ?ht (fx- (%ht-size ?ht) 1))
                    (loop ?prv ?nxt) )
                  (if (?test ?key ?parkey)
                      ?succ
                      (loop ?cur ?nxt) ) ) ) ) ) ) ) )

(define-syntax bucket-search-body
  (syntax-rules ()
    ((bucket-search-body ?wk? ?wv? ?core-eq?
                         ?ht ?key ?test ?vec ?hshidx
                         (?prv ?cur ?nxt ?pare ?parkey ?parval)
                         ?succ
                         ()
                         ?fail)
      (let ((weak? (or ?wk? ?wv?)))
        (if (eq? ?core-eq? ?test)
            (if weak?
                (bucket-search-body/scavenge* ?wk? ?wv?
                                              ?ht ?key eq? ?vec ?hshidx
                                              (?prv ?cur ?nxt ?pare ?parkey ?parval)
                                              ?succ
                                              ()
                                              ?fail)
                (bucket-search-body/plain* ?wk? ?wv?
                                           ?ht ?key eq? ?vec ?hshidx
                                           (?prv ?cur ?nxt ?pare ?parkey ?parval)
                                           ?succ
                                           ()
                                           ?fail) )
            (if weak?
                (bucket-search-body/scavenge* ?wk? ?wv?
                                              ?ht ?key ?test ?vec ?hshidx
                                              (?prv ?cur ?nxt ?pare ?parkey ?parval)
                                              ?succ
                                              ()
                                              ?fail)
                (bucket-search-body/plain* ?wk? ?wv?
                                           ?ht ?key ?test ?vec ?hshidx
                                           (?prv ?cur ?nxt ?pare ?parkey ?parval)
                                           ?succ
                                           ()
                                           ?fail) ) ) ) ) ) )

;; SRFI-69 & SRFI-90'ish.
;;
;; Argument list is the pattern
;;
;; (make-hash-table #!optional test hash size
;;                  #!key test hash size initial
;;                        min-load max-load weak-keys weak-values)
;;
;; where a keyword argument takes precedence over the corresponding optional
;; argument. Keyword arguments MUST come after optional & required
;; arugments.
;;
;; Wish DSSSL (extended) argument list processing Did-What-I-Want (DWIW).

(define (make-hash-table . args)
  (receive (test hash size min-load max-load weak-keys weak-values initial)
           (apply im:eval-make-hash-table-args args)
    (im:*make-hash-table wrap-hash/std entry-object-ctor
                         test hash size min-load max-load
                         weak-keys weak-values initial
                         *mod-ht-kind*) ) )

;; Hash-Table Predicate:

(define (hash-table? obj)
  (and (im:hash-table? obj)
       (eq? *mod-ht-kind* (%ht-kind obj))) )

;; Hash-Table Properties:

(define hash-table-size im:hash-table-size)
(define hash-table-equivalence-function im:hash-table-equivalence-function)
(define hash-table-hash-function im:hash-table-hash-function)
(define hash-table-min-load im:hash-table-min-load)
(define hash-table-max-load im:hash-table-max-load)
(define hash-table-weak-keys im:hash-table-weak-keys)
(define hash-table-weak-values im:hash-table-weak-values)
(define hash-table-has-initial? im:hash-table-has-initial?)
(define hash-table-initial im:hash-table-initial)

;; hash-table-rehash!:

(define (hash-table-rehash! ht vec1 vec2 hash)
  (let ([len1 (%vector-length vec1)]
        [len2 (%vector-length vec2)]
        (nsiz 0)
        (wkk? (%ht-weak-keys ht))
        (wkv? (%ht-weak-values ht))
        (mak-it (%ht-make-entry ht)) )
    (do ([i 0 (fx+ i 1)])
        [(fx>= i len1) nsiz]
      (let loop ([bucket (%vector-ref vec1 i)] (tsiz nsiz))
        (if (null? bucket)
            (set! nsiz tsiz)
            (let* ([pare (%car bucket)]
                   [key (key-of pare wkk? wkv?)]
                   (val (val-of pare wkk? wkv?)) )
              (if (bwp-entry? key val)
                  (loop (%cdr bucket) tsiz)
                  (let ([hshidx (hash key len2)])
                    (%vector-set! vec2 hshidx
                                  (cons (mak-it key val) (%vector-ref vec2 hshidx)))
                    (loop (%cdr bucket) (fx+ tsiz 1)) ) ) ) ) ) ) ) )

;; hash-table-copy:

(define *hash-table-copy
  (let ((make-vector make-vector))
    (lambda (ht)
      (let* ((vec1 (%ht-vector ht))
             (len (%vector-length vec1))
             (vec2 (make-vector len '()))
             (wkk? (%ht-weak-keys ht))
             (wkv? (%ht-weak-values ht))
             (mak-it (%ht-make-entry ht))
             (nsiz 0) )
        (do ((i 0 (fx+ i 1)))
            ((fx>= i len)
             (im:**make-hash-table
              (%ht-equivalence-function ht) (%ht-hash-function ht)
              len
              (%ht-min-load ht) (%ht-max-load ht)
              wkk? wkv?
              (%ht-initial ht)
              (%ht-kind ht)
              vec2 (%ht-hash ht) (%ht-size ht) (%ht-make-entry ht)) )
          (%vector-set! vec2 i
                        (let copy-loop ((bucket (%vector-ref vec1 i)) (tsiz nsiz))
                          (if (null? bucket)
                              (begin
                                (set! nsiz tsiz)
                                '() )
                              (let* ((pare (%car bucket))
                                     (key (key-of pare wkk? wkv?))
                                     (val (val-of pare wkk? wkv?))
                                     (nxt (%cdr bucket)) )
                                ;do not perform when empty entry
                                (if (bwp-entry? key val)
                                    (copy-loop nxt tsiz)
                                    (cons (mak-it key val)
                                          (copy-loop nxt (fx+ tsiz 1)))))))) ) ) ) ) )

(define (hash-table-copy ht)
  (*hash-table-copy (%check-hash-table/kind 'hash-table-copy ht)) )

(define (hash-table-empty-copy ht)
  (im:*hash-table-empty-copy (%check-hash-table/kind 'hash-table-empty-copy ht)) )

;; hash-table-update!:
;;
;; This one was suggested by Sven Hartrumpf (and subsequently added in SRFI-69).
;; Modified for ht props min & max load.

(define hash-table-update!
  (let ([core-eq? eq?])
    (lambda (ht key func
                #!optional
                (thunk
                 (let ([thunk (%ht-initial ht)])
                   (or thunk
                       (lambda ()
                         (##sys#signal-hook
                          #:access-error
                          'hash-table-update!
                          "hash-table does not contain key" key ht))))))
      (check-key 'hash-table-update! key)
      (%check-hash-table/kind 'hash-table-update! ht)
      (##sys#check-closure func 'hash-table-update!)
      (##sys#check-closure thunk 'hash-table-update!)
      (let* ([hash (%ht-hash ht)]
             [test (%ht-equivalence-function ht)]
             [vec (%ht-vector ht)]
             (wkk? (%ht-weak-keys ht))
             (wkv? (%ht-weak-values ht))
             [len (%vector-length vec)]
             [hshidx (hash key len)] )
        (define (on-fail)
          (let ([val (func (thunk))]
                ;re-fetch, could be changed
                [bucket0 (%vector-ref vec hshidx)]
                [newsiz (fx+ (%ht-size ht) 1)] )
            (check-value 'hash-table-update! val)
            (%vector-set! vec hshidx (cons ((%ht-make-entry ht) key val) bucket0))
            (hash-table-check-resize! ht newsiz hash-table-rehash!)
            (%ht-size-set! ht newsiz)
            val ) )
        (define (on-succ pare parval)
          (let ([val (func parval)])
            (val-of-set! pare (check-value 'hash-table-update! val) wkk? wkv?)
            val ) )
        (bucket-search-body wkk? wkv? core-eq?
                            ht key test vec hshidx
                            (prv cur nxt pare parkey parval)
                            (on-succ pare parval)
                            ()
                            (on-fail)) ) ) ) )

(define *hash-table-update!/default
  (let ([core-eq? eq?])
    (lambda (ht key func def)
      (check-key 'hash-table-update!/default key)
      (let* ([hash (%ht-hash ht)]
             [test (%ht-equivalence-function ht)]
             [vec (%ht-vector ht)]
             (wkk? (%ht-weak-keys ht))
             (wkv? (%ht-weak-values ht))
             [len (%vector-length vec)]
             [hshidx (hash key len)] )
        (define (on-fail)
          (let ([val (func def)]
                [bucket0 (%vector-ref vec hshidx)]
                ;re-fetch, could be changed
                [newsiz (fx+ (%ht-size ht) 1)] )
            (check-value 'hash-table-update!/default val)
            (%vector-set! vec hshidx (cons ((%ht-make-entry ht) key val) bucket0))
            (hash-table-check-resize! ht newsiz hash-table-rehash!)
            (%ht-size-set! ht newsiz)
            val ) )
        (define (on-succ pare parval)
          (let ([val (func parval)])
            (val-of-set! pare (check-value 'hash-table-update!/default val) wkk? wkv?)
            val ) )
        (bucket-search-body wkk? wkv? core-eq?
                            ht key test vec hshidx
                            (prv cur nxt pare parkey parval)
                            (on-succ pare parval)
                            ()
                            (on-fail)) ) ) ) )

(define (hash-table-update!/default ht key func def)
  (%check-hash-table/kind 'hash-table-update!/default ht)
  (##sys#check-closure func 'hash-table-update!/default)
  (*hash-table-update!/default ht key func def) )

(define hash-table-set!
  (let ([core-eq? eq?])
    (lambda (ht key val)
      (check-key 'hash-table-set! key)
      (check-value 'hash-table-set! val)
      (%check-hash-table/kind 'hash-table-set! ht)
      (let* ([hash (%ht-hash ht)]
             [test (%ht-equivalence-function ht)]
             [vec (%ht-vector ht)]
             (wkk? (%ht-weak-keys ht))
             (wkv? (%ht-weak-values ht))
             [len (%vector-length vec)]
             [hshidx (hash key len)] )
        (define (on-fail)
          (let ([bucket0 (%vector-ref vec hshidx)]
                ;re-fetch, could be changed
                [newsiz (fx+ (%ht-size ht) 1)] )
            (%vector-set! vec hshidx (cons ((%ht-make-entry ht) key val) bucket0))
            (hash-table-check-resize! ht newsiz hash-table-rehash!)
            (%ht-size-set! ht newsiz) ) )
        (bucket-search-body wkk? wkv? core-eq?
                            ht key test vec hshidx
                            (prv cur nxt pare parkey parval)
                            (val-of-set! pare val wkk? wkv?)
                            ()
                            (on-fail))
        (void) ) ) ) )

(define (hash-table-set*! ht . plist)
  (%check-hash-table/kind 'hash-table-set*! ht)
  (%plist-for-each (cut *hash-table-update!/default ht <> identity <>)
                   plist) )

;; Hash-Table Reference:

(define hash-table-ref
  (getter-with-setter
    (let ([core-eq? eq?])
      (lambda (ht key #!optional (def (lambda ()
                                        (##sys#signal-hook #:access-error
                                         'hash-table-ref
                                         "hash-table does not contain key" key ht))))
        ;(check-key 'hash-table-ref key)
        (%check-hash-table/kind 'hash-table-ref ht)
        (##sys#check-closure def 'hash-table-ref)
        (let* ([vec (%ht-vector ht)]
               [test (%ht-equivalence-function ht)]
               (wkk? (%ht-weak-keys ht))
               (wkv? (%ht-weak-values ht))
               [hash (%ht-hash ht)]
               [hshidx (hash key (%vector-length vec))] )
          (bucket-search-body wkk? wkv? core-eq?
                              ht key test vec hshidx
                              (prv cur nxt pare parkey parval)
                              parval
                              ()
                              (def)) ) ) )
   hash-table-set!
   "(hash-table-ref ht key . def)") )

(define hash-table-ref/default
  (let ([core-eq? eq?])
    (lambda (ht key def)
      ;(check-key 'hash-table-ref/default key)
      (%check-hash-table/kind 'hash-table-ref/default ht)
      (let* ([vec (%ht-vector ht)]
             [test (%ht-equivalence-function ht)]
             (wkk? (%ht-weak-keys ht))
             (wkv? (%ht-weak-values ht))
             [hash (%ht-hash ht)]
             [hshidx (hash key (%vector-length vec))] )
        (bucket-search-body wkk? wkv? core-eq?
                            ht key test vec hshidx
                            (prv cur nxt pare parkey parval)
                            parval
                            ()
                            def) ) ) ) )

(define hash-table-exists?
  (let ([core-eq? eq?])
    (lambda (ht key)
      ;(check-key 'hash-table-exists? key)
      (%check-hash-table/kind 'hash-table-exists? ht)
      (let* ([vec (%ht-vector ht)]
             [test (%ht-equivalence-function ht)]
             (wkk? (%ht-weak-keys ht))
             (wkv? (%ht-weak-values ht))
             [hash (%ht-hash ht)]
             [hshidx (hash key (%vector-length vec))] )
        (bucket-search-body wkk? wkv? core-eq?
                            ht key test vec hshidx
                            (prv cur nxt pare parkey parval)
                            #t
                            ()
                            #f) ) ) ) )

;; hash-table-delete!:

(define hash-table-delete!
  (let ([core-eq? eq?])
    (lambda (ht key)
      ;(check-key 'hash-table-delete! key)
      (%check-hash-table/kind 'hash-table-delete! ht)
      (let* ([vec (%ht-vector ht)]
             [len (%vector-length vec)]
             [hash (%ht-hash ht)]
             [hshidx (hash key len)]
             (wkk? (%ht-weak-keys ht))
             (wkv? (%ht-weak-values ht))
             [test (%ht-equivalence-function ht)] )
        (define (on-succ prv nxt)
          (if prv
              (%set-cdr! prv nxt)
              (%vector-set! vec hshidx nxt))
          (let ([newsiz (fx- (%ht-size ht) 1)])
            (hash-table-check-resize! ht newsiz hash-table-rehash!)
            (%ht-size-set! ht newsiz) )
          #t )
        (bucket-search-body wkk? wkv? core-eq?
                            ht key test vec hshidx
                            (prv cur nxt pare parkey parval)
                            (on-succ prv nxt)
                            ()
                            #f) ) ) ) )

;; hash-table-remove!:

;NOTE (hash-table-remove! ht (constantly #f)) is ht gc
(define (hash-table-remove! ht func)
  (%check-hash-table/kind 'hash-table-remove! ht)
  (##sys#check-closure func 'hash-table-remove!)
  (let* ([vec (%ht-vector ht)]
         [len (%vector-length vec)]
         [siz (%ht-size ht)]
         (wkk? (%ht-weak-keys ht))
         (wkv? (%ht-weak-values ht)) )
    (do ([i 0 (fx+ i 1)])
        [(fx>= i len)
          (begin
            (hash-table-check-resize! ht siz hash-table-rehash!)
            (%ht-size-set! ht siz))]
      (let loop ([prv #f] [bucket (%vector-ref vec i)])
        (unless (null? bucket)
          (let* ([pare (%car bucket)]
                 [nxt (%cdr bucket)]
                 (key (key-of pare wkk? wkv?))
                 (val (val-of pare wkk? wkv?))
                 (empty? (bwp-entry? key val)) )
            (when (or empty? (func key val))
              (if prv
                  (%set-cdr! prv nxt)
                  (%vector-set! vec i nxt))
              (set! siz (fx- siz 1)) )
            (loop bucket nxt) ) ) ) ) ) )

;; hash-table-pop!:

(define hash-table-pop!
  (let ([core-eq? eq?])
    (lambda (ht #!optional (rndint pseudo-random-integer))
      (%check-hash-table/kind 'hash-table-pop! ht)
      (when (fx= 0 (%ht-size ht))
        (##sys#signal-hook #:access-error 'hash-table-pop!
                                          "hash-table empty" ht) )
      (let* ([vec (%ht-vector ht)]
             [len (%vector-length vec)]
             [hshidx (%ht-vector-first-occupied-index
                      'hash-table-pop! vec (rndint len))]
             (wkk? (%ht-weak-keys ht))
             (wkv? (%ht-weak-values ht))
             ;take the 1st (pop); there is better sampling but this
             ;reuses what we got
             [test (lambda (a b) #t)]
             [key (void)] )
        (define (on-fail)
          (##sys#signal-hook #:access-error 'hash-table-pop!
                                            "hash-table empty" ht) )
        (define (on-succ prv nxt parkey parval)
          (if prv
              (%set-cdr! prv nxt)
              (%vector-set! vec hshidx nxt))
          (let ([newsiz (fx- (%ht-size ht) 1)])
            (hash-table-check-resize! ht newsiz hash-table-rehash!)
            (%ht-size-set! ht newsiz) )
          (values parkey parval) )
        (bucket-search-body wkk? wkv? core-eq?
                            ht key test vec hshidx
                            (prv cur nxt pare parkey parval)
                            (on-succ prv nxt parkey parval)
                            ()
                            (on-fail)) ) ) ) )

;; hash-table-clear!:

(define (hash-table-clear! ht)
  (%check-hash-table/kind 'hash-table-clear! ht)
  (vector-fill! (%ht-vector ht) '())
  (%ht-size-set! ht 0) )

;; hash-table-clean!:

(define (hash-table-clean! ht)
  (%check-hash-table/kind 'hash-table-clean! ht)
  (let* ([vec (%ht-vector ht)]
         [len (%vector-length vec)]
         [siz (%ht-size ht)]
         (wkk? (%ht-weak-keys ht))
         (wkv? (%ht-weak-values ht)) )
    (do ([i 0 (fx+ i 1)])
        [(fx>= i len) (%ht-size-set! ht siz)]
      (let loop ([prv #f] [bucket (%vector-ref vec i)])
        (unless (null? bucket)
          (let ([nxt (%cdr bucket)]
                (pare (%car bucket)) )
            (if (bwp-entry? (key-of pare wkk? wkv?) (val-of pare wkk? wkv?))
                (begin
                  (if prv
                      (%set-cdr! prv nxt)
                      (%vector-set! vec i nxt))
                  (set! siz (fx- siz 1))
                  (loop prv nxt) )
                (loop bucket nxt) ) ) ) ) ) ) )

;;; Mapping Over Hash-Table Keys & Values:

(define (*hash-table-for-each ht proc)
  (let* ([vec (%ht-vector ht)]
         [len (%vector-length vec)]
         (wkk? (%ht-weak-keys ht))
         (wkv? (%ht-weak-values ht)) )
    (do ([i 0 (fx+ i 1)])
        [(fx>= i len)]
      (##sys#for-each (lambda (pare)
                        (let ((key (key-of pare wkk? wkv?))
                              (val (val-of pare wkk? wkv?)) )
                          ;do not perform when empty entry
                          (unless (bwp-entry? key val)
                            (proc key val) ) ) )
                      (%vector-ref vec i)) ) ) )

(define (*hash-table-fold ht func init)
  (let* ([vec (%ht-vector ht)]
         [len (%vector-length vec)]
         (wkk? (%ht-weak-keys ht))
         (wkv? (%ht-weak-values ht)) )
    (let loop ([i 0] [acc init])
      (if (fx>= i len)
          acc
          (let fold2 ([bucket (%vector-ref vec i)]
                      [acc acc])
            (if (null? bucket)
                (loop (fx+ i 1) acc)
                (let* ([pare (%car bucket)]
                       (key (key-of pare wkk? wkv?))
                       (val (val-of pare wkk? wkv?)) )
                  (if (bwp-entry? key val)
                      (fold2 (%cdr bucket) acc)
                      (fold2 (%cdr bucket) (func key val acc)) ) ) ) ) ) ) ) )

;; Hash-Table <-> Association-List | Property-List::

(define (hash-table->alist ht)
  (*hash-table-fold (%check-hash-table/kind 'hash-table->alist ht)
                    (lambda (k v l) (cons (cons k v) l))
                    '()) )

(define (alist->hash-table alist . rest)
  (let ([ht (apply make-hash-table rest)])
    (for-each
     (lambda (x)
       (##sys#check-pair x 'alist->hash-table)
       (let ((key (%car x))
             (val (%cdr x)) )
         (unless (bwp-entry? key val)
           (*hash-table-update!/default ht key identity val) ) ) )
     (%check-list 'alist->hash-table alist))
    ht ) )

(define (hash-table->plist ht)
  (*hash-table-fold (%check-hash-table/kind 'hash-table->plist ht)
                    (lambda (k v l) (cons k (cons v l)))
                    '()) )

(define (plist->hash-table plist . rest)
  (let ((ht (apply make-hash-table rest)))
    (apply hash-table-set*! ht
                            (%check-list 'plist->hash-table plist))
    ht ) )

;; Hash-Table Keys & Values:

;#!bwp impossible result elm
(define (hash-table-keys ht)
  (*hash-table-fold (%check-hash-table/kind 'hash-table-keys ht)
                    (lambda (k v l) (cons k l))
                    '()) )

;#!bwp possible result elm
(define (hash-table-values ht)
  (*hash-table-fold (%check-hash-table/kind 'hash-table-values ht)
                    (lambda (k v l) (cons v l))
                    '()) )

(define (hash-table-key-vector ht)
  (%check-hash-table/kind 'hash-table-key-vector ht)
  (%vector-cursor-vector
    (*hash-table-fold ht
                      (lambda (k v vi)
                        (let ((i (car vi)))
                          (vector-set! (cdr vi) i k)
                          (%vector-cursor-inc! vi)
                          vi ) )
                      (%vector-cursor (make-vector (%ht-size ht))))) )

(define (hash-table-value-vector ht)
  (%check-hash-table/kind 'hash-table-key-vector ht)
  (%vector-cursor-vector
    (*hash-table-fold ht
                      (lambda (k v vi)
                        (let ((i (car vi)))
                          (vector-set! (cdr vi) i v)
                            (%vector-cursor-inc! vi)
                          vi ) )
                      (%vector-cursor (make-vector (%ht-size ht))))) )

(define (hash-table-find ht func failure)
  (call/cc
    (lambda (return)
      (*hash-table-fold (%check-hash-table/kind 'hash-table-find ht)
                        (lambda (k v _) (and-let* ((res (func k v))) (return res)))
                        #f)
      (failure) ) ) )

;; Hash Table Merge:

(define (*hash-table-merge! ht1 ht2)
  (let* ([vec (%ht-vector ht2)]
         [len (%vector-length vec)]
         (wkk? (%ht-weak-keys ht2))
         (wkv? (%ht-weak-values ht2)) )
    (do ([i 0 (fx+ i 1)])
        [(fx>= i len) ht1]
      (do ([lst (%vector-ref vec i) (%cdr lst)])
          [(null? lst)]
        (let* ([pare (%car lst)]
               (key (key-of pare wkk? wkv?))
               (val (val-of pare wkk? wkv?)) )
          ;do not perform when empty entry
          (unless (bwp-entry? key val)
            (*hash-table-update!/default ht1 key identity val) ) ) ) ) ) )

(define (hash-table-merge! ht1 ht2)
  (*hash-table-merge!
   (%check-hash-table/kind 'hash-table-merge! ht1)
   (%check-hash-table/kind 'hash-table-merge! ht2)) )

(define (hash-table-merge ht1 ht2)
  (*hash-table-merge!
   (*hash-table-copy (%check-hash-table/kind 'hash-table-merge ht1))
   (%check-hash-table/kind 'hash-table-merge ht2)) )

;hash-table-exists? too common to add *hash-table-exists?.      (yes)
;hash-table-delete! not too common to add *hash-table-delete!?  (don't bother)
;hash-table-remove! not too common to add *hash-table-delete!?  (don't bother)

(define (hash-table-union! ht1 ht2)
  (*hash-table-merge!
   (%check-hash-table/kind 'hash-table-union! ht1)
   (%check-hash-table/kind 'hash-table-union! ht2))
  #; ;reuse what we have
  (*hash-table-fold
    (%check-hash-table/kind 'hash-table-union! ht2)
    (lambda (k2 v2 ht)
      (unless (hash-table-exists? ht k2)
        (*hash-table-update!/default ht k2 identity v2) ) )
    (%check-hash-table/kind 'hash-table-union! ht1)) )

(define (hash-table-intersection! ht1 ht2)
  #;(%check-hash-table/kind 'hash-table-intersection! ht2)
  (hash-table-remove! ht1 #;(%check-hash-table/kind 'hash-table-intersection! ht1)
                      (lambda (k v) (not (hash-table-exists? ht2 k))))
  ht1 )

(define (hash-table-difference! ht1 ht2)
  #;(%check-hash-table/kind 'hash-table-difference! ht2)
  (hash-table-remove! ht1 #;(%check-hash-table/kind 'hash-table-intersection! ht1)
                      (lambda (k v) (hash-table-exists? ht2 k)))
  ht1 )

(define (hash-table-xor! ht1 ht2)
  (*hash-table-fold
    (%check-hash-table/kind 'hash-table-xor! ht2)
    (lambda (k2 v2 ht)
      (if (hash-table-exists? ht k2)
          (hash-table-delete! ht k2)
          (*hash-table-update!/default ht k2 identity v2) )
      ht )
    (%check-hash-table/kind 'hash-table-xor! ht1)) )

(define (hash-table-fold ht func init)
  (*hash-table-fold
   (%check-hash-table/kind 'hash-table-fold ht)
   (%check-closure 'hash-table-fold func)
   init) )

(define (hash-table-for-each ht proc)
  (*hash-table-for-each
   (%check-hash-table/kind 'hash-table-for-each ht)
   (%check-closure 'hash-table-for-each proc)) )

(define (hash-table-walk ht proc)
  (*hash-table-for-each
   (%check-hash-table/kind 'hash-table-walk ht)
   (%check-closure 'hash-table-walk proc)) )

(define (hash-table-map ht func)
  (%check-closure 'hash-table-map func)
  (*hash-table-fold
   (%check-hash-table/kind 'hash-table-map ht)
   (lambda (k v a) (cons (func k v) a))
   '()) )

) ;module (srfi 69 weak var)