srfi-69.scm

Scheme跨平台编译器

	(if (fx= len 0)
	    hsh
	    (loop (fx+ hsh
		       (fx+ (fxshl hsh 4)
			    (recursive-hash (##sys#slot obj i) (fx+ depth 1))))
		  (fx+ i 1)
		  (fx- len 1) ) ) ) ) )

  ; Don't recurse into structured objects
  (define (recursive-atomic-hash obj depth)
    (if (or ($eqv?-hash-object? obj)
	    ($byte-block? obj))
	(recursive-hash obj (fx+ depth 1))
	other-hash-value ) )

  ; Recurse into structured objects
  (define (recursive-hash obj depth)
    (cond [(fx>= depth recursive-hash-max-depth)
				  other-hash-value]
	  [(fixnum? obj)	  obj]
	  [(char? obj)		  (char->integer obj)]
	  [(eq? obj #t)		  true-hash-value]
	  [(eq? obj #f)		  false-hash-value]
	  [(null? obj)		  null-hash-value]
	  [(eof-object? obj)	  eof-hash-value]
	  [(symbol? obj)	  ($symbol-hash obj)]
	  #; ;NOT YET (no keyword vs. symbol issue)
	  [(keyword? obj)	  ($keyword-hash obj)]
	  [(number? obj)	  ($non-fixnum-number-hash obj)]
	  [($immediate? obj)	  unknown-immediate-hash-value]
	  [($byte-block? obj)	  ($hash-string obj)]
	  [(list? obj)		  ($*list-hash obj)]
	  [(pair? obj)		  ($*pair-hash obj)]
	  [($port? obj)		  ($*port-hash obj)]
	  [($special? obj)	  ($*special-vector-hash obj)]
	  [else			  ($*regular-vector-hash obj)] ) )

  ;
  (recursive-hash obj 0) )

(define (equal?-hash obj #!optional (bound hash-default-bound))
  (##sys#check-exact bound 'hash)
  ($hash/limit (%equal?-hash obj) bound) )

(define hash equal?-hash)

;; String Hash:

(define (string-hash str #!optional (bound hash-default-bound))
  (##sys#check-string str 'string-hash)
  (##sys#check-exact bound 'string-hash)
  ($hash/limit ($hash-string str) bound) )

(define (string-ci-hash str #!optional (bound hash-default-bound))
  (##sys#check-string str 'string-ci-hash)
  (##sys#check-exact bound 'string-ci-hash)
  ($hash/limit ($hash-string-ci str) bound) )


;;; Hash-Tables:

; 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.

(define-constant hash-table-prime-lengths
  '(307 617
    1237 2477 4957 9923
    19853 39709 79423
    158849 317701 635413
    1270849 2541701 5083423
    10166857 20333759 40667527 81335063 162670129
    325340273 650680571
    ;
    1073741823))

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

;; Restrict hash-table length to tabled lengths:

(define (hash-table-canonical-length tab req)
  (let loop ([tab tab])
    (let ([cur (##sys#slot tab 0)]
	  [nxt (##sys#slot tab 1)])
      (if (or (fx>= cur req)
	      (null? nxt))
	  cur
	  (loop nxt) ) ) ) )

;; "Raw" make-hash-table:

(define %make-hash-table
  (let ([make-vector make-vector])
    (lambda (test hash len min-load max-load weak-keys weak-values initial
	     #!optional (vec (make-vector len '())))
      (##sys#make-structure 'hash-table
       vec 0 test hash min-load max-load #f #f initial) ) ) )

;; 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
  (let ([core-eq? eq?]
	[core-eqv? eqv?]
	[core-equal? equal?]
	[core-string=? string=?]
	[core-string-ci=? string-ci=?]
	[core= =] )
    (lambda arguments0
      (let ([arguments arguments0]
	    [test equal?]
	    [hash #f]
	    [size hash-table-default-length]
	    [initial #f]
	    [min-load hash-table-default-min-load]
	    [max-load hash-table-default-max-load]
	    [weak-keys #f]
	    [weak-values #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-ci-hash]
			[(or (eq? core= test)
			     (eq? = test))		  number-hash]
			[else				  #f] ) ) ] )
	  ; Process optional arguments
	  (unless (null? arguments)
	    (let ([arg (car arguments)])
	      (unless (keyword? arg)
		(##sys#check-closure arg 'make-hash-table)
		(set! test arg)
		(set! arguments (cdr arguments)) ) ) )
	  (unless (null? arguments)
	    (let ([arg (car arguments)])
	      (unless (keyword? arg)
		(##sys#check-closure arg 'make-hash-table)
		(set! hash arg)
		(set! arguments (cdr arguments)) ) ) )
	  (unless (null? arguments)
	    (let ([arg (car arguments)])
	      (unless (keyword? arg)
		(##sys#check-exact arg 'make-hash-table)
		(unless (fx< 0 arg)
		  (error 'make-hash-table "invalid size" arg) )
		(set! size (fxmin hash-table-max-size 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)
			    (##sys#check-closure val 'make-hash-table)
			    (set! test val)]
			  [(#:hash)
			    (##sys#check-closure val 'make-hash-table)
			    (set! hash val)]
			  [(#:size)
			    (##sys#check-exact val 'make-hash-table)
			    (unless (fx< 0 val)
			      (error 'make-hash-table "invalid size" val) )
			    (set! size (fxmin hash-table-max-size val))]
			  [(#:initial)
			    (set! initial (lambda () val))]
			  [(#:min-load)
			    (##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)
			    (##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 hash-table-prime-lengths 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
	  (%make-hash-table test hash size min-load max-load weak-keys weak-values initial) ) ) ) ) )

;; Hash-Table Predicate:

(define (hash-table? obj)
  (##sys#structure? obj 'hash-table) )

;; Hash-Table Properties:

(define (hash-table-size ht)
  (##sys#check-structure ht 'hash-table 'hash-table-size)
  (##sys#slot ht 2) )

(define (hash-table-equivalence-function ht)
  (##sys#check-structure ht 'hash-table 'hash-table-equivalence-function)
  (##sys#slot ht 3) )

(define (hash-table-hash-function ht)
  (##sys#check-structure ht 'hash-table 'hash-table-hash-function)
  (##sys#slot ht 4) )

(define (hash-table-min-load ht)
  (##sys#check-structure ht 'hash-table 'hash-table-min-load)
  (##sys#slot ht 5) )

(define (hash-table-max-load ht)
  (##sys#check-structure ht 'hash-table 'hash-table-max-load)
  (##sys#slot ht 6) )

(define (hash-table-weak-keys ht)
  (##sys#check-structure ht 'hash-table 'hash-table-weak-keys)
  (##sys#slot ht 7) )

(define (hash-table-weak-values ht)
  (##sys#check-structure ht 'hash-table 'hash-table-weak-values)
  (##sys#slot ht 8) )

(define (hash-table-has-initial? ht)
  (##sys#check-structure ht 'hash-table 'hash-table-has-initial?)
  (and (##sys#slot ht 9)
       #t ) )

(define (hash-table-initial ht)
  (##sys#check-structure ht 'hash-table 'hash-table-initial)
  (and-let* ([thunk (##sys#slot ht 9)])
    (thunk) ) )

;; hash-table-copy:

(define %hash-table-copy
  (let ([make-vector make-vector])
    (lambda (ht)
      (let* ([vec1 (##sys#slot ht 1)]
	     [len (##sys#size vec1)]
	     [vec2 (make-vector len '())] )
	(do ([i 0 (fx+ i 1)])
	    [(fx>= i len)
	     (%make-hash-table
	      (##sys#slot ht 3) (##sys#slot ht 4)
	      (##sys#slot ht 2)
	      (##sys#slot ht 5) (##sys#slot ht 6)
	      (##sys#slot ht 7) (##sys#slot ht 8)
	      (##sys#slot ht 9)
	      vec2)]
	  (##sys#setslot vec2 i
	   (let copy-loop ([bucket (##sys#slot vec1 i)])
	     (if (null? bucket)
		 '()
		 (let ([pare (##sys#slot bucket 0)])
		   (cons (cons (##sys#slot pare 0) (##sys#slot pare 1))
			 (copy-loop (##sys#slot bucket 1))))))) ) ) ) ) )

(define (hash-table-copy ht)
  (##sys#check-structure ht 'hash-table 'hash-table-copy)
  (%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-rehash vec1 vec2 hash)
  (let ([len1 (##sys#size vec1)]
	[len2 (##sys#size vec2)] )
    (do ([i 0 (fx+ i 1)])
	[(fx>= i len1)]
      (let loop ([bucket (##sys#slot vec1 i)])
	(unless (null? bucket)
	  (let* ([pare (##sys#slot bucket 0)]
		 [key (##sys#slot pare 0)]
		 [hshidx (hash key len2)] )
	    (##sys#setslot vec2 hshidx
			   (cons (cons key (##sys#slot pare 1))
				 (##sys#slot vec2 hshidx)))
	    (loop (##sys#slot bucket 1)) ) ) ) ) ) )

(define %hash-table-update!
  (let ([core-eq? eq?]
	[floor floor] )
    (lambda (ht key func thunk)
      (let ([hash (##sys#slot ht 4)]
	    [test (##sys#slot ht 3)]