;;; srfi.69.weak.fix.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 fix) (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-update!
                            hash-table-update!/default
                            hash-table-set!
                            hash-table-ref
                            hash-table-ref/default
                            hash-table-exists?
                            hash-table-delete!
                            hash-table-remove!
                            hash-table-clear!
                            hash-table-merge!
                            hash-table-merge
                            hash-table-clean!
                            hash-table->alist
                            alist->hash-table
                            hash-table-keys
                            hash-table-values
                            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 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.fix)

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

(define (cons/strong key val)     (cons key (cons val (void))))
(define (weak-cons/key key val)   (weak-cons key (cons val (void))))
(define (weak-cons/val key val)   (cons key (weak-cons val (void))))
(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) (%car pare))
(define-inline (val-of pare) (%cadr pare))
(define-inline (val-of-set! pare val) (%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* ?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))
                   (?parval (val-of ?pare)) )
              (if (?test ?key ?parkey)
                  ?succ
                  (loop ?cur ?nxt) ) ) ) ) ) ) )

(define-syntax bucket-search-body/scavenge*
  (syntax-rules ()
    ((bucket-search-body/scavenge* ?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))
                   (?parval (val-of ?pare)) )
              (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 ?weak? ?core-eq?
                         ?ht ?key ?test ?vec ?hshidx
                         (?prv ?cur ?nxt ?pare ?parkey ?parval)
                         ?succ
                         ()
                         ?fail)
      (if (eq? ?core-eq? ?test)
          (if ?weak?
              (bucket-search-body/scavenge* ?ht ?key eq? ?vec ?hshidx
                                            (?prv ?cur ?nxt ?pare ?parkey ?parval)
                                            ?succ
                                            ()
                                            ?fail)
              (bucket-search-body/plain* ?ht ?key eq? ?vec ?hshidx
                                         (?prv ?cur ?nxt ?pare ?parkey ?parval)
                                         ?succ
                                         ()
                                         ?fail) )
          (if ?weak?
              (bucket-search-body/scavenge* ?ht ?key ?test ?vec ?hshidx
                                            (?prv ?cur ?nxt ?pare ?parkey ?parval)
                                            ?succ
                                            ()
                                            ?fail)
              (bucket-search-body/plain* ?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)
        (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)]
                   (val (val-of pare)) )
              (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 '()))
             (mak-it (%ht-make-entry ht))
             (nsiz 0) )
        (do ((i 0 (fx+ i 1)))
            ((fx>= i len)
             (im:*make-hash-table
              wrap-hash/std entry-object-ctor
              (%ht-equivalence-function ht) (%ht-hash-function ht)
              (%ht-size ht)
              (%ht-min-load ht) (%ht-max-load ht)
              (%ht-weak-keys ht) (%ht-weak-values ht)
              (%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))
                                     (val (val-of pare)) )
                                ;do not perform when empty entry
                                (if (bwp-entry? key val)
                                    (copy-loop (%cdr bucket) tsiz)
                                    (cons (mak-it key val)
                                          (copy-loop (%cdr bucket) (fx+ tsiz 1)))))))) ) ) ) ) )

(define (hash-table-copy ht)
  (*hash-table-copy (%check-hash-table/kind 'hash-table-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)]
             (weak? (or (%ht-weak-keys ht) (%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))
            val ) )
        (bucket-search-body weak? 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)]
             (weak? (or (%ht-weak-keys ht) (%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))
            val ) )
        (bucket-search-body weak? 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)]
             (weak? (or (%ht-weak-keys ht) (%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 weak? core-eq?
                            ht key test vec hshidx
                            (prv cur nxt pare parkey parval)
                            (val-of-set! pare val)
                            ()
                            (on-fail))
        (void) ) ) ) )

;; 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)]
               (weak? (or (%ht-weak-keys ht) (%ht-weak-values ht)))
               [hash (%ht-hash ht)]
               [hshidx (hash key (%vector-length vec))] )
          (bucket-search-body weak? 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)]
             (weak? (or (%ht-weak-keys ht) (%ht-weak-values ht)))
             [hash (%ht-hash ht)]
             [hshidx (hash key (%vector-length vec))] )
        (bucket-search-body weak? 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)]
             (weak? (or (%ht-weak-keys ht) (%ht-weak-values ht)))
             [hash (%ht-hash ht)]
             [hshidx (hash key (%vector-length vec))] )
        (bucket-search-body weak? 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)]
             [newsiz (fx- (%ht-size ht) 1)]
             [hash (%ht-hash ht)]
             [hshidx (hash key len)]
             (weak? (or (%ht-weak-keys ht) (%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))
          (hash-table-check-resize! ht newsiz hash-table-rehash!)
          (%ht-size-set! ht (fx- (%ht-size ht) 1))
          #t )
        (bucket-search-body weak? core-eq?
                            ht key test vec hshidx
                            (prv cur nxt pare parkey parval)
                            (on-succ prv nxt)
                            ()
                            #f) ) ) ) )

;; hash-table-remove!:

(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)] )
    (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))
                 (val (val-of pare))
                 (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-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 Merge:

(define (*hash-table-merge! ht1 ht2)
  (let* ([vec (%ht-vector ht2)]
         [len (%vector-length vec)] )
    (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))
               (val (val-of pare)) )
          ;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-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)] )
    (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) (val-of pare))
                (begin
                  (if prv
                      (%set-cdr! prv nxt)
                      (%vector-set! vec i nxt))
                  (set! siz (fx- siz 1))
                  (loop prv nxt) )
                (loop bucket nxt) ) ) ) ) ) ) )

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

(define (hash-table->alist ht)
  (%check-hash-table/kind 'hash-table->alist ht)
  (let* ([vec (%ht-vector ht)]
         [len (%vector-length vec)] )
    (let loop ([i 0] [lst '()])
      (if (fx>= i len)
          lst
          (let loop2 ([bucket (%vector-ref vec i)]
                      [lst lst])
            (if (null? bucket)
                (loop (fx+ i 1) lst)
                (loop2 (%cdr bucket)
                       (let* ([pare (%car bucket)]
                              (key (key-of pare))
                              (val (val-of pare)) )
                         ;do not perform when empty entry
                         (if (bwp-entry? key val)
                             lst
                             (cons (cons key val) lst) ) ) ) ) ) ) ) ) )

(define (alist->hash-table alist . rest)
  (##sys#check-list alist 'alist->hash-table)
  (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) ) ) )
     alist)
    ht ) )

;; Hash-Table Keys & Values:

;#!bwp impossible result elm
(define (hash-table-keys ht)
  (%check-hash-table/kind 'hash-table-keys ht)
  (let* ([vec (%ht-vector ht)]
         [len (%vector-length vec)] )
    (let loop ([i 0] [lst '()])
      (if (fx>= i len)
          lst
          (let loop2 ([bucket (%vector-ref vec i)]
                      [lst lst])
            (if (null? bucket)
                (loop (fx+ i 1) lst)
                (loop2 (%cdr bucket)
                       (let* ([pare (%car bucket)]
                              (key (key-of pare))
                              (val (val-of pare)) )
                         ;do not perform when empty entry
                         (if (bwp-entry? key val)
                             lst
                             (cons key lst) ) ) ) ) ) ) ) ) )

;#!bwp possible result elm
(define (hash-table-values ht)
  (%check-hash-table/kind 'hash-table-values ht)
  (let* ([vec (%ht-vector ht)]
         [len (%vector-length vec)] )
    (let loop ([i 0] [lst '()])
      (if (fx>= i len)
          lst
          (let loop2 ([bucket (%vector-ref vec i)]
                      [lst lst])
            (if (null? bucket)
                (loop (fx+ i 1) lst)
                (loop2 (%cdr bucket)
                       (let* ([pare (%car bucket)]
                              (key (key-of pare))
                              (val (val-of pare)) )
                         ;do not perform when empty entry
                         (if (bwp-entry? key val)
                             lst
                             (cons val lst) ) ) ) ) ) ) ) ) )

;; Mapping Over Hash-Table Keys & Values:
;;
;; hash-table-for-each:
;; hash-table-walk:
;; hash-table-fold:
;; hash-table-map:

(define (*hash-table-for-each ht proc)
  (let* ([vec (%ht-vector ht)]
         [len (%vector-length vec)] )
    (do ([i 0 (fx+ i 1)])
        [(fx>= i len)]
      (##sys#for-each (lambda (pare)
                        (let ((key (key-of pare))
                              (val (val-of pare)) )
                          ;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)] )
    (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))
                       (val (val-of pare)) )
                  (if (bwp-entry? key val)
                      (fold2 (%cdr bucket) acc)
                      (fold2 (%cdr bucket) (func key val acc)) ) ) ) ) ) ) ) )

(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 fix)