;;; srfi.69.recordscm - 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. (module (srfi 69 record) (hash-table-canonical-length load-lengths *make-hash-table eval-make-hash-table-args hash-table-expand! hash-table-contract! hash-table? check-hash-table #;check-hash-table-kind error-hash-table-kind #;check-hash-table-compatible 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) (import (scheme) (chicken base) (chicken fixnum) (chicken flonum) (chicken keyword) (only (chicken format) sprintf) (only (chicken memory representation) record-instance-length) (chicken type)) (import (srfi 69 hash)) ;NOTE hash-table is built-in (: load-lengths (fixnum float float -> fixnum fixnum)) (: hash-table-canonical-length (fixnum -> fixnum)) (: *make-hash-table (((* fixnum -> fixnum) -> (* fixnum -> fixnum)) (boolean boolean -> *) (* * -> boolean) (* #!optional fixnum fixnum -> fixnum) fixnum float float boolean boolean (or false (-> *)) symbol #!optional vector (* #!optional fixnum fixnum -> fixnum) fixnum (* * -> *) -> hash-table)) (: eval-make-hash-table-args (#!rest -> (* * -> boolean) (* #!optional fixnum fixnum -> fixnum) fixnum float float boolean boolean (or false (-> *)))) (define-type hasher (* #!rest -> fixnum)) (define-type rehasher (hash-table vector vector hasher -> void)) (: hash-table-resize! (hash-table vector fixnum fixnum rehasher -> void)) (: hash-table-expand! (hash-table vector fixnum rehasher -> void)) (: hash-table-contract! (hash-table vector fixnum rehasher -> void)) ;FIXME shares builtin type w/ srfi-69! (: hash-table? (* -> boolean : hash-table)) (: check-hash-table ((or false symbol) * -> hash-table)) (: error-hash-table-kind ((or false symbol) * symbol -> hash-table)) (: check-hash-table-kind ((or false symbol) * symbol -> hash-table)) (: check-hash-table-compatible ((or false symbol) * symbol -> hash-table)) (: hash-table-size (hash-table -> fixnum)) (: hash-table-equivalence-function (hash-table --> (* * -> *))) (: hash-table-hash-function (hash-table --> (* fixnum -> fixnum))) (: hash-table-min-load (hash-table --> float)) (: hash-table-max-load (hash-table --> float)) (: hash-table-weak-keys (hash-table --> boolean)) (: hash-table-weak-values (hash-table --> boolean)) (: hash-table-has-initial? (hash-table --> boolean)) (: hash-table-initial (hash-table -> *)) ;;; 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: (include-relative "srfi.69.support.incl") ; Predefined sizes for the hash tables: ; ; Starts with 307; each element is the smallest prime that is at least twice in ; magnitude as the previous element in the list. ; ; The last number is an exception: it is the largest 32-bit fixnum we can represent. ;(assert (and (fixnum? hash-table-max-length) (= 31 (bits-to-represent ...)))) (define hash-table-prime-lengths (vector hash-table-min-length 617 1237 2477 4957 9923 19853 39709 79423 158849 317701 635413 1270849 2541701 5083423 10166857 20333759 40667527 81335063 162670129 325340273 650680571 hash-table-max-length)) ;; Restrict hash-table length to tabled lengths: ;finds the table element nearest to the requested length ; (define (nearest-length tab req) (let ((len (%vector-length tab))) (let loop ([i 0] [prv (the (or false fixnum) #f)]) (let ([cur (%vector-ref tab i)] [nxt (fx+ i 1)]) (if (or (fx>= cur req) (fx>= nxt len)) ;when a previous value we know it must be < the requested value ;so swap the subtraction arguments to avoid an absolute value. (if (and prv (fx< (fx- req prv) (fx- cur req))) prv cur) (loop nxt cur) ) ) ) ) ) (define (hash-table-canonical-length req) (nearest-length hash-table-prime-lengths req) ) (define (load-length ln bd) (inexact->exact (round (* ln bd)))) (define (load-lengths ln mn mx) (values (load-length ln mn) (load-length ln mx))) ;; "Raw" make-hash-table (define *make-hash-table (let ([make-vector make-vector]) (lambda (bind-hash cell-ctor test hash len min-load max-load weak-keys weak-values initial kind #!optional (vec (make-vector len '())) (bndhsh (bind-hash hash)) (size 0) (ctor (cell-ctor weak-keys weak-values))) ;; Cached values to speed up hash-table-check-resize! (receive (min-load-len max-load-len) (load-lengths len min-load max-load) (##sys#make-structure hash-table-record-type vec size test hash min-load max-load weak-keys weak-values initial bndhsh min-load-len max-load-len ctor kind) ) ) ) ) ;; Parse make-hash-table arguments (define eval-make-hash-table-args (let ([core-eq? eq?] [core-eqv? eqv?] [core-equal? equal?] [core-string=? string=?] [core-string-ci=? string-ci=?] [core= =] (eq?-hash eq?-hash) (eqv?-hash eqv?-hash) (equal?-hash equal?-hash) (hash hash) (string-hash string-hash) (string-hash-ci string-hash-ci) (number-hash number-hash)) (lambda arguments0 (let ([arguments arguments0] [test equal?] [hash (the (or false (* #!optional fixnum fixnum -> fixnum)) #f)] [size hash-table-default-length] [initial (the (or false (-> *)) #f)] [min-load hash-table-default-min-load] [max-load hash-table-default-max-load] [weak-keys (the boolean #f)] [weak-values (the boolean #f)]) (let ([hash-for-test (lambda () (cond [(or (eq? core-eq? test) (eq? eq? test)) eq?-hash] [(or (eq? core-eqv? test) (eq? eqv? test)) eqv?-hash] [(or (eq? core-equal? test) (eq? equal? test)) equal?-hash] [(or (eq? core-string=? test) (eq? string=? test)) string-hash] [(or (eq? core-string-ci=? test) (eq? string-ci=? test)) string-hash-ci] [(or (eq? core= test) (eq? = test)) number-hash] [else #f] ) ) ] ) ; Process optional arguments (unless (null? arguments) (let ([arg (car arguments)]) (unless (keyword? arg) (set! test (%check-closure 'make-hash-table arg)) (set! arguments (cdr arguments)) ) ) ) (unless (null? arguments) (let ([arg (car arguments)]) (unless (keyword? arg) (set! hash (%check-closure 'make-hash-table arg)) (set! arguments (cdr arguments)) ) ) ) (unless (null? arguments) (let ([arg (car arguments)]) (unless (keyword? arg) (##sys#check-fixnum arg 'make-hash-table) (unless (fx< 0 arg) (error 'make-hash-table "invalid size" arg) ) (set! size (fxmin hash-table-max-length arg)) (set! arguments (cdr arguments)) ) ) ) ; Process keyword arguments (let loop ([args arguments]) (unless (null? args) (let ([arg (car args)]) (let ([invarg-err (lambda (msg) (error 'make-hash-table msg arg arguments0))]) (if (keyword? arg) (let* ([nxt (cdr args)] [val (if (pair? nxt) (car nxt) (invarg-err "missing keyword value"))]) (case arg [(#:test) (set! test (%check-closure 'make-hash-table val))] [(#:hash) (set! hash (%check-closure 'make-hash-table val))] [(#:size) (##sys#check-fixnum val 'make-hash-table) (unless (fx< 0 val) (error 'make-hash-table "invalid size" val) ) (set! size (fxmin hash-table-max-length val))] [(#:initial) (set! initial (lambda () val))] [(#:min-load) (when (exact? val) (set! val (exact->inexact val))) (##sys#check-inexact val 'make-hash-table) (unless (and (fp< 0.0 val) (fp< val 1.0)) (error 'make-hash-table "invalid min-load" val) ) (set! min-load val)] [(#:max-load) (when (exact? val) (set! val (exact->inexact val))) (##sys#check-inexact val 'make-hash-table) (unless (and (fp< 0.0 val) (fp< val 1.0)) (error 'make-hash-table "invalid max-load" val) ) (set! max-load val)] [(#:weak-keys) (set! weak-keys (and val #t))] [(#:weak-values) (set! weak-values (and val #t))] [else (invarg-err "unknown keyword")]) (loop (cdr nxt)) ) (invarg-err "missing keyword") ) ) ) ) ) ; Load must be a proper interval (when (fp< max-load min-load) (error 'make-hash-table "min-load greater than max-load" min-load max-load) ) ; Force canonical hash-table vector length (set! size (hash-table-canonical-length size)) ; Decide on a hash function when not supplied (unless hash (let ([func (hash-for-test)]) (if func (set! hash func) (begin (warning 'make-hash-table "user test without user hash") (set! hash equal?-hash) ) ) ) ) ; Done (values test hash size min-load max-load weak-keys weak-values initial) ) ) ) ) ) ;; hash-table-resize!: (define (hash-table-resize! ht vec len newlen ht-rehash) ;(print "hash-table-resize! " len " " newlen) (let ((vec2 (make-vector newlen '()))) (receive (new-min-load-len new-max-load-len) (load-lengths newlen (%ht-min-load ht) (%ht-max-load ht)) (ht-rehash ht vec vec2 (%ht-hash ht)) (%ht-vector-set! ht vec2) (%ht-min-load-len-set! ht new-min-load-len) (%ht-max-load-len-set! ht new-max-load-len) ) ) ) (define (hash-table-expand! ht vec len ht-rehash) ;(print "hash-table-expand! " len) (let* ((deslen (fx* len hash-table-new-length-factor)) (newlen (hash-table-canonical-length deslen)) ) ;(print "hash-table-expand! " len " " deslen " " newlen) ;unless at limits (unless (fx= len newlen) (hash-table-resize! ht vec len newlen ht-rehash) ) ) ) (define (hash-table-contract! ht vec len ht-rehash) ;(print "hash-table-contract! " len) (let* ((deslen (fx/ len hash-table-new-length-factor)) (newlen (hash-table-canonical-length deslen)) ) ;(print "hash-table-contract! " len " " deslen " " newlen) ;unless at limits (unless (fx= len newlen) (hash-table-resize! ht vec len newlen ht-rehash) ) ) ) ;; Hash-Table Predicate: (define (hash-table? obj) (and (##sys#structure? obj hash-table-record-type) (= hash-table-record-length (%record-instance-length obj))) ) (define (check-hash-table loc obj) (%check-hash-table loc obj)) (define (error-hash-table-kind loc obj knd) (error loc (sprintf "invalid hash-table kind, not a ~A" knd) (%ht-kind obj)) ) #; ;overhead (define (check-hash-table-kind loc obj knd) (unless (eq? knd (%ht-kind (%check-hash-table loc obj))) (error-hash-table-kind loc obj knd) ) obj ) #;(define (check-hash-table-kind loc obj knd) (check-hash-table loc obj)) #; ;overhead (define (check-hash-table-compatible loc obj knd) (unless (compatible-hash-table? (%check-hash-table loc obj) knd) (error-hash-table-kind loc obj knd) ) obj ) #;(define check-hash-table-compatible check-hash-table-kind) ;; Hash-Table Properties: (define (hash-table-size ht) (%ht-size (%check-hash-table 'hash-table-size ht)) ) (define (hash-table-equivalence-function ht) (%ht-equivalence-function (%check-hash-table 'hash-table-equivalence-function ht)) ) (define (hash-table-hash-function ht) (%ht-hash-function (%check-hash-table 'hash-table-hash-function ht)) ) (define (hash-table-min-load ht) (%ht-min-load (%check-hash-table 'hash-table-min-load ht)) ) (define (hash-table-max-load ht) (%ht-max-load (%check-hash-table 'hash-table-max-load ht)) ) (define (hash-table-weak-keys ht) (%ht-weak-keys (%check-hash-table 'hash-table-weak-keys ht)) ) (define (hash-table-weak-values ht) (%ht-weak-values (%check-hash-table 'hash-table-weak-values ht)) ) (define (hash-table-has-initial? ht) (and (%ht-initial (%check-hash-table 'hash-table-has-initial? ht)) #t ) ) (define (hash-table-initial ht) (and-let* ([thunk (%ht-initial (%check-hash-table 'hash-table-initial ht))]) (thunk) ) ) ;;; Printing (define (hash-table-print ht port) ;srfi-69, ... visible (##sys#print "#" #f port) ) ;srfi-69, ... compatible (##sys#register-record-printer hash-table-record-type hash-table-print) ) ;module (srfi 69 record)