;;; 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. (declare (bound-to-procedure ##sys#slot ##sys#setslot ##sys#setislot ##sys#size ##sys#make-structure ##sys#print ##sys#register-record-printer)) (module (srfi 69 record) (;export hash-table-canonical-length load-lengths **make-hash-table *make-hash-table *hash-table-empty-copy 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 hash-table-empty? ;only via .record module hash-table-loading-count hash-table-loading) (import (scheme) (chicken base) (chicken fixnum) (chicken flonum) (chicken keyword) (only (chicken format) sprintf) (chicken type)) (import (srfi 69 hash)) ;symbol-name-utils (define (symbol->keyword sym) (string->keyword (symbol->string sym))) ;NOTE hash-table is built-in (: load-lengths (fixnum float float -> fixnum fixnum)) (: hash-table-canonical-length (fixnum -> fixnum)) (: **make-hash-table ((* * -> boolean) (* #!optional fixnum fixnum -> fixnum) fixnum float float boolean boolean (or false (-> *)) symbol vector (* #!optional fixnum fixnum -> fixnum) fixnum (* * -> *) -> hash-table)) (: *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)) (: *hash-table-empty-copy (hash-table -> 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 -> *)) ;never thread-safe, always mutable, no comparator, no ephemeronm ;(: hash-table-thread-safe? (hash-table -> boolean)) ;(: hash-table-mutable? (hash-table -> boolean)) ;(: hash-table-ephemeral-keys? (hash-table -> boolean)) ;(: hash-table-ephemeral-values? (hash-table -> boolean)) (: hash-table-empty? (hash-table -> boolean)) (: hash-table-loading-count (hash-table -> fixnum)) (: hash-table-loading (hash-table #!optional fixnum -> (vector-of fixnum))) ;;; 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 test hash len min-load max-load weak-keys weak-values initial kind vec bndhsh size ctor) ;; Cached values to speed up hash-table-check-resize! (receive (min-load-len max-load-len) (load-lengths len min-load max-load) (%make-record 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) ) ) ;FIXME cumbersome w/ the 1st 2 being used only to support the last 2 (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))) (**make-hash-table test hash len min-load max-load weak-keys weak-values initial kind vec bndhsh size ctor) ) ) ) (define (*hash-table-empty-copy ht) ;FIXME must follow *make-hash-table rules for vector make (**make-hash-table (%ht-equivalence-function ht) (%ht-hash-function ht) hash-table-min-length (%ht-min-load ht) (%ht-max-load ht) (%ht-weak-keys ht) (%ht-weak-values ht) (%ht-initial ht) (%ht-kind ht) (make-vector hash-table-min-length '()) (%ht-hash ht) 0 (%ht-make-entry ht)) ) ;; Parse make-hash-table arguments (define hash-for-test (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 (test) (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] ) ) ) ) (define (eval-make-hash-table-args . 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)]) ; Process optional arguments [[test [hash]] size] ; test (unless (null? arguments) (let ([arg (car arguments)]) (unless (or (keyword? arg) (fixnum? arg)) (set! test (%check-closure 'make-hash-table arg)) (set! arguments (cdr arguments)) ) ) ) ; hash (unless (null? arguments) (let ([arg (car arguments)]) (unless (or (keyword? arg) (fixnum? arg)) (set! hash (%check-closure 'make-hash-table arg)) (set! arguments (cdr arguments)) ) ) ) ; size (unless (null? arguments) (let ([arg (car arguments)]) (unless (keyword? arg) (##sys#check-fixnum arg 'make-hash-table) (set! size (fxmin hash-table-max-length arg)) (set! arguments (cdr arguments)) ) ) ) ; Process keyword arguments (let loop ([args (the list arguments)]) ;maybe null, maybe not (unless (null? args) (let ([kwd (car args)]) (define (invarg-err msg) (error 'make-hash-table msg kwd arguments0)) (if (not (keyword? kwd)) ;then (invarg-err "missing keyword") ;else by name (let* ([nxt (cdr args)] [val (if (pair? nxt) (car nxt) (invarg-err "missing keyword value"))]) (case kwd [(#: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) (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))] ;ignore SRFI 125 options [(#:immutable #:thread-safe) (void)] ;no comparator, no ephemeron ;[#:ephemeral-keys #:ephemeral-values) ; (void)] [else (invarg-err "unknown keyword")]) (loop (cdr nxt)) ) ) ) ) ) ; Load must be a proper interval (unless (fp<= min-load max-load) (error 'make-hash-table "min-load greater than max-load" min-load max-load) ) ; Force canonical hash-table vector length (unless (fx< 0 size) (error 'make-hash-table "invalid size" size) ) (set! size (hash-table-canonical-length size)) ; Decide on a hash function when not supplied (unless hash (let ([func (hash-for-test 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!: ; Goal is to limit number of procedure calls. The -expand!/contract! routines ; delay the -resize! invocation by code duplication. The -check-resize! delays ; the call to the -expand!/contract! routines, again at the cost of code ; duplication. (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) ) ) ) ;FIXME rather than prints, expose enough for advice; i.e. hash-table-resize! ;above should need to be visible. (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-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) ) ) ;never thread-safe, always mutable, no comparator, no ephemeronm ;(define (hash-table-thread-safe? ht) #f) ;(define (hash-table-mutable? ht) #t) ;(define (hash-table-ephemeral-keys ? ht) #f) ;(define (hash-table-ephemeral-values? ht) #f) (define (hash-table-empty? ht) (fx= 0 (%ht-size (%check-hash-table 'hash-table-empty? ht))) ) ;only used once (define (hash-table-loading-count ht) ;%vector-fold (let* ((vec (%ht-vector (%check-hash-table 'hash-table-loading ht))) (veclen (%vector-length vec)) ) (do ((i 0 (fx+ i 1)) (cnt 0 (if (null? (vector-ref vec i)) cnt (fx+ cnt 1))) ) ((fx= i veclen) cnt)) ) ) (define-constant LD-MIN-WIN-SZ 4) (define-constant LD-WIN-MULT 500) (define (hash-table-loading ht #!optional n) (let* ((vec (%ht-vector (%check-hash-table 'hash-table-loading ht))) (veclen (%vector-length vec)) (sldmax (fxmax LD-MIN-WIN-SZ (fx/ (hash-table-loading-count ht) LD-WIN-MULT))) (sldlen (if (not n) sldmax (fxmin sldmax (%check-fixnum 'hash-table-loading n)))) (sldvec (the (vector-of fixnum) (make-vector sldlen 0))) (sldcnt (fx/ veclen sldlen)) (sldcnt (fx+ sldcnt (if (fx< 0 (fx- veclen (fx* sldlen sldcnt))) 1 0))) ) ;(assert (fx<= veclen (fx* sldlen sldcnt))) ;slide the "window" (sldvec) over the vec, floor(veclen / sldlen) times (do ((sldcnt sldcnt (fx- sldcnt 1)) ;cardinal number (i 0 (fx+ i sldlen)) ) ;natural number ((fx= 0 sldcnt) sldvec) ;per slide length max (do ((j 0 (fx+ j 1)) (k i (fx+ k 1))) ((or (fx= j sldlen) (fx= k veclen))) (vector-set! sldvec j (fx+ (length (vector-ref vec k)) (vector-ref sldvec j))) ) ) ) ) ;;; Printing (srfi-69, srfi-90, ... record compatible) (define (hash-table-print ht port) ;srfi-69, ... visible (%print-object/noread "#" port) ) (set-record-printer! hash-table-record-type hash-table-print) ) ;module (srfi 69 record)