;;; srfi-69.support.incl.scm
;
; 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.

;;; 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 hash-table-min-length 307)
(define-constant hash-table-max-length 1073741823)

(define-constant hash-table-default-length 307)
(define-constant hash-table-new-length-factor 2)

(define-constant hash-table-default-min-load 0.5)
(define-constant hash-table-default-max-load 0.8)

(define-constant hash-table-record-type 'hash-table)
(define-constant hash-table-record-length 14)

;struct 'hash-table
(define-inline (%ht-vector ht) (##sys#slot ht 1))
(define-inline (%ht-size ht) (##sys#slot ht 2))
(define-inline (%ht-equivalence-function ht) (##sys#slot ht 3))
(define-inline (%ht-hash-function ht) (##sys#slot ht 4))
(define-inline (%ht-min-load ht) (##sys#slot ht 5))
(define-inline (%ht-max-load ht) (##sys#slot ht 6))
(define-inline (%ht-weak-keys ht) (##sys#slot ht 7))
(define-inline (%ht-weak-values ht) (##sys#slot ht 8))
(define-inline (%ht-initial ht) (##sys#slot ht 9))
(define-inline (%ht-hash ht) (##sys#slot ht 10))
(define-inline (%ht-min-load-len ht) (##sys#slot ht 11))
(define-inline (%ht-max-load-len ht) (##sys#slot ht 12))
(define-inline (%ht-make-entry ht) (##sys#slot ht 13))
(define-inline (%ht-kind ht) (##sys#slot ht hash-table-record-length))

(define-inline (%ht-vector-set! ht x) (##sys#setslot ht 1 x))
(define-inline (%ht-size-set! ht x) (##sys#setislot ht 2 x))
(define-inline (%ht-hash-set! ht x) (##sys#setslot ht 10 x))
(define-inline (%ht-min-load-len-set! ht x) (##sys#setislot ht 11 x))
(define-inline (%ht-max-load-len-set! ht x) (##sys#setislot ht 12 x))
(define-inline (%ht-make-entry-set! ht x) (##sys#setslot ht 13 x))

(define-inline (%car pare) (##sys#slot pare 0))
(define-inline (%cdr pare) (##sys#slot pare 1))
(define-inline (%cadr pare) (%car (%cdr pare)))
(define-inline (%set-car! pare x) (##sys#setslot pare 0 x))
(define-inline (%set-cdr! pare x) (##sys#setslot pare 1 x))
(define-inline (%set-cadr! pare x) (%set-car! (%cdr pare) x))

(define-inline (%vector-ref v i) (##sys#slot v i))
(define-inline (%vector-set! v i x) (##sys#setslot v i x))
(define-inline (%vector-length v) (##sys#size v))

(define-inline (%record-instance-length x) (fx- (##sys#size x) 1))

;##sys#check-fixnum
;##sys#check-inexact
;##sys#check-list
;##sys#check-pair

(define-inline (%check-closure loc obj)
  (##sys#check-closure obj loc)
  obj )

(define-inline (%check-hash-table loc obj)
  (##sys#check-structure obj hash-table-record-type loc)
  obj )

;ugh
(define-inline (%check-hash-table/kind loc obj)
  (unless (eq? *mod-ht-kind* (%ht-kind (%check-hash-table loc obj)))
    (im:error-hash-table-kind loc obj *mod-ht-kind*) )
  obj )

#; ;overhead
(define-inline (compatible-hash-table? ht knd)
  (let ((htknd (%ht-kind ht)))
    (or (eq? knd htknd)
        (case knd
          ((weak.var) (eq? 'strong htknd) )
          ((strong)   (and (eq? 'weak.var htknd)
                           (not (%ht-weak-keys ht))
                           (not (%ht-weak-values ht))) )
          (else       #f) ) ) ) )

;; hash-table-check-resize!:

;Note vec len passed to resize routines since already fetched
;and the siz is only used here (i make the decisions)

(define-inline (hash-table-check-resize! ht newsiz ht-rehash)
  (let* ((vec (%ht-vector ht))
         (len (%vector-length vec))
         (siz (%ht-size ht)) )
    ;direction?
    (if (fx> newsiz siz)
        ;then growing, @ upper bound?
        (unless (and (fx< len hash-table-max-length)                ;resizeable up?
                     ;FIXME load-len compared to size violates dimensions
                     ;is a crappy proxy
                     (fx<= newsiz (%ht-max-load-len ht)))
;(print "hash-table-check-resize! up " len " " newsiz)
          (im:hash-table-expand! ht vec len hash-table-rehash!) )
        ;else shrinking, @ lower bound?
        (when (and (fx< hash-table-min-length len)                ;resizeable down?
                   ;FIXME load-len compared to size violates dimensions
                   ;is a crappy proxy
                   (fx< newsiz (%ht-min-load-len ht)))
;(print "hash-table-check-resize! down " len " " newsiz)
          (im:hash-table-contract! ht vec len hash-table-rehash!) ) ) ) )