srfi-69.scm

Scheme跨平台编译器

	    [newsiz (fx+ (##sys#slot ht 2) 1)]
	    [min-load (##sys#slot ht 5)]
	    [max-load (##sys#slot ht 6)] )
	(let re-enter ()
	  (let* ([vec (##sys#slot ht 1)]
		 [len (##sys#size vec)] )
	    (let ([min-load-len (inexact->exact (floor (* len min-load)))]
		  [max-load-len (inexact->exact (floor (* len max-load)))]
		  [hshidx (hash key len)] )
	      ; Need to resize table?
	      (if (and (fx< len hash-table-max-length)
		       (fx<= min-load-len newsiz) (fx<= newsiz max-load-len))
		  ; then resize the table:
		  (let ([vec2 (make-vector
			       (hash-table-canonical-length
				hash-table-prime-lengths
				(fxmin hash-table-max-length
				       (fx* len hash-table-new-length-factor)))
			       '())])
		    (hash-table-rehash vec vec2 hash)
		    (##sys#setslot ht 1 vec2)
		    (re-enter) )
		  ; else update the table:
		  (let ([bucket0 (##sys#slot vec hshidx)])
		    (if (eq? core-eq? test)
			; Fast path (eq? is rewritten by the compiler):
			(let loop ([bucket bucket0])
			  (cond [(null? bucket)
				 (let ([val (func (thunk))])
				   (##sys#setslot vec hshidx (cons (cons key val) bucket0))
				   (##sys#setislot ht 2 newsiz)
				   val) ]
				[else
				 (let ([pare (##sys#slot bucket 0)])
				   (if (eq? key (##sys#slot pare 0))
				       (let ([val (func (##sys#slot pare 1))])
					 (##sys#setslot pare 1 val)
					 val)
				       (loop (##sys#slot bucket 1)) ) ) ] ) )
			; Slow path
			(let loop ([bucket bucket0])
			  (cond [(null? bucket)
				 (let ([val (func (thunk))])
				   (##sys#setslot vec hshidx (cons (cons key val) bucket0))
				   (##sys#setislot ht 2 newsiz)
				   val) ]
				[else
				 (let ([pare (##sys#slot bucket 0)])
				   (if (test key (##sys#slot pare 0))
				       (let ([val (func (##sys#slot pare 1))])
					 (##sys#setslot pare 1 val)
					 val)
				       (loop (##sys#slot bucket 1)) ) ) ] ) ) ) ) ) ) ) ) ) ) ) )

(define (hash-table-update!
	 ht key
	 #!optional (func identity)
		    (thunk
		     (let ([thunk (##sys#slot ht 9)])
		       (or thunk
			   (lambda ()
			     (##sys#signal-hook #:access-error
			      'hash-table-update!
			      "hash-table does not contain key" key ht))))))
  (##sys#check-structure ht 'hash-table 'hash-table-update!)
  (##sys#check-closure func 'hash-table-update!)
  (##sys#check-closure thunk 'hash-table-update!)
  (%hash-table-update! ht key func thunk) )

(define (hash-table-update!/default ht key func def)
  (##sys#check-structure ht 'hash-table 'hash-table-update!/default)
  (##sys#check-closure func 'hash-table-update!/default)
  (%hash-table-update! ht key func (lambda () def)) )

(define (hash-table-set! ht key val)
  (##sys#check-structure ht 'hash-table 'hash-table-set!)
  (let ([thunk (lambda _ val)])
    (%hash-table-update! ht key thunk thunk) )
  (void) )

;; Hash-Table Reference:

(define %hash-table-ref
  (let ([core-eq? eq?])
    (lambda (ht key def)
       (let  ([vec (##sys#slot ht 1)]
	      [test (##sys#slot ht 3)] )
	 (let* ([hash (##sys#slot ht 4)]
		[hshidx (hash key (##sys#size vec))] )
	   (if (eq? core-eq? test)
	       ; Fast path (eq? is rewritten by the compiler):
	       (let loop ([bucket (##sys#slot vec hshidx)])
		 (if (null? bucket)
		     (def)
		     (let ([pare (##sys#slot bucket 0)])
		       (if (eq? key (##sys#slot pare 0))
			   (##sys#slot pare 1)
			   (loop (##sys#slot bucket 1)) ) ) ) )
	       ; Slow path
	       (let loop ([bucket (##sys#slot vec hshidx)])
		 (if (null? bucket)
		     (def)
		     (let ([pare (##sys#slot bucket 0)])
		       (if (test key (##sys#slot pare 0))
			   (##sys#slot pare 1)
			   (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) ) ) )

(define hash-table-ref
  (getter-with-setter
   (lambda (ht key #!optional (def (lambda ()
				     (##sys#signal-hook #:access-error
				      'hash-table-ref
				      "hash-table does not contain key" key ht))))
     (##sys#check-structure ht 'hash-table 'hash-table-ref)
     (##sys#check-closure def 'hash-table-ref)
     (%hash-table-ref ht key def) )
   hash-table-set!))

(define (hash-table-ref/default ht key default)
  (##sys#check-structure ht 'hash-table 'hash-table-ref/default)
  (%hash-table-ref ht key (lambda () default)) )

(define (hash-table-exists? ht key)
  (##sys#check-structure ht 'hash-table 'hash-table-exists?)
  (not ($unbound? (%hash-table-ref ht key unbound-value-thunk))) )

;; hash-table-delete!:

(define hash-table-delete!
  (let ([core-eq? eq?])
    (lambda (ht key)
      (##sys#check-structure ht 'hash-table 'hash-table-delete!)
      (let* ([vec (##sys#slot ht 1)]
             [len (##sys#size vec)]
             [hash (##sys#slot ht 4)]
             [hshidx (hash key len)] )
        (let ([test (##sys#slot ht 3)]
              [newsiz (fx- (##sys#slot ht 2) 1)]
              [bucket0 (##sys#slot vec hshidx)] )
          (if (eq? core-eq? test)
              ; Fast path (eq? is rewritten by the compiler):
              (let loop ([prev #f] [bucket bucket0])
                (and (not (null? bucket))
                     (let ([pare (##sys#slot bucket 0)]
                           [nxt (##sys#slot bucket 1)])
                       (if (eq? key (##sys#slot pare 0))
                           (begin
                             (if prev
                                 (##sys#setslot prev 1 nxt)
                                 (##sys#setslot vec hshidx nxt) )
                             (##sys#setislot ht 2 newsiz)
                             #t )
                           (loop bucket nxt) ) ) ) )
              ; Slow path
              (let loop ([prev #f] [bucket bucket0])
                (and (not (null? bucket))
                     (let ([pare (##sys#slot bucket 0)]
                           [nxt (##sys#slot bucket 1)])
                       (if (test key (##sys#slot pare 0))
                           (begin
                             (if prev
                                 (##sys#setslot prev 1 nxt)
                                 (##sys#setslot vec hshidx nxt) )
                             (##sys#setislot ht 2 newsiz)
                             #t )
                           (loop bucket nxt) ) ) ) ) ) ) ) ) ) )

;; hash-table-remove!:

(define (hash-table-remove! ht func)
  (##sys#check-structure ht 'hash-table 'hash-table-remove!)
  (##sys#check-closure func 'hash-table-remove!)
  (let* ([vec (##sys#slot ht 1)]
	 [len (##sys#size vec)] )
    (let ([siz (##sys#slot ht 2)])
      (do ([i 0 (fx+ i 1)])
	  [(fx>= i len) (##sys#setislot ht 2 siz)]
	(let loop ([prev #f] [bucket (##sys#slot vec i)])
	  (and (not (null? bucket))
	       (let ([pare (##sys#slot bucket 0)]
		     [nxt (##sys#slot bucket 1)])
		 (if (func (##sys#slot pare 0) (##sys#slot pare 1))
		     (begin
		       (if prev
			   (##sys#setslot prev 1 nxt)
			   (##sys#setslot vec i nxt) )
		       (set! siz (fx- siz 1))
		       #t )
		     (loop bucket nxt ) ) ) ) ) ) ) ) )

;; hash-table-clear!:

(define (hash-table-clear! ht)
  (##sys#check-structure ht 'hash-table 'hash-table-clear!)
  (vector-fill! (##sys#slot ht 1) '())
  (##sys#setislot ht 2 0) )

;; Hash Table Merge:

(define (%hash-table-merge! ht1 ht2)
  (let* ([vec (##sys#slot ht2 1)]
	 [len (##sys#size vec)] )
    (do ([i 0 (fx+ i 1)])
	[(fx>= i len) ht1]
      (do ([lst (##sys#slot vec i) (##sys#slot lst 1)])
	  [(null? lst)]
	(let ([b (##sys#slot lst 0)])
	  (%hash-table-update! ht1 (##sys#slot b 0)
				   identity (lambda () (##sys#slot b 1))) ) ) ) ) )

(define (hash-table-merge! ht1 ht2)
  (##sys#check-structure ht1 'hash-table 'hash-table-merge!)
  (##sys#check-structure ht2 'hash-table 'hash-table-merge!)
  (%hash-table-merge! ht1 ht2) )

(define (hash-table-merge ht1 ht2)
  (##sys#check-structure ht1 'hash-table 'hash-table-merge)
  (##sys#check-structure ht2 'hash-table 'hash-table-merge)
  (%hash-table-merge! (%hash-table-copy ht1) ht2) )

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

(define (hash-table->alist ht)
  (##sys#check-structure ht 'hash-table 'hash-table->alist)
  (let* ([vec (##sys#slot ht 1)]
	 [len (##sys#size vec)] )
    (let loop ([i 0] [lst '()])
      (if (fx>= i len)
	  lst
	  (let loop2 ([bucket (##sys#slot vec i)]
		      [lst lst])
	    (if (null? bucket)
		(loop (fx+ i 1) lst)
		(loop2 (##sys#slot bucket 1)
		       (let ([x (##sys#slot bucket 0)])
			 (cons (cons (##sys#slot x 0) (##sys#slot x 1)) lst) ) ) ) ) ) ) ) )

(define alist->hash-table
  (let ([make-hash-table make-hash-table])
    (lambda (alist . rest)
      (##sys#check-list alist 'alist->hash-table)
      (let ([ht (apply make-hash-table rest)])
	(for-each (lambda (x)
		    (%hash-table-update! ht (##sys#slot x 0)
					    identity (lambda () (##sys#slot x 1))) )
		  alist)
	ht ) ) ) )

;; Hash-Table Keys & Values:

(define (hash-table-keys ht)
  (##sys#check-structure ht 'hash-table 'hash-table-keys)
  (let* ([vec (##sys#slot ht 1)]
	 [len (##sys#size vec)] )
    (let loop ([i 0] [lst '()])
      (if (fx>= i len)
	  lst
	  (let loop2 ([bucket (##sys#slot vec i)]
		      [lst lst])
	    (if (null? bucket)
		(loop (fx+ i 1) lst)
		(loop2 (##sys#slot bucket 1)
		       (let ([x (##sys#slot bucket 0)])
			 (cons (##sys#slot x 0) lst) ) ) ) ) ) ) ) )

(define (hash-table-values ht)
  (##sys#check-structure ht 'hash-table 'hash-table-values)
  (let* ([vec (##sys#slot ht 1)]
	 [len (##sys#size vec)] )
    (let loop ([i 0] [lst '()])
      (if (fx>= i len)
	  lst
	  (let loop2 ([bucket (##sys#slot vec i)]
		      [lst lst])
	    (if (null? bucket)
		(loop (fx+ i 1) lst)
		(loop2 (##sys#slot bucket 1)
		       (let ([x (##sys#slot bucket 0)])
			 (cons (##sys#slot x 1) 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 (##sys#slot ht 1)]
	 [len (##sys#size vec)] )
    (do ([i 0 (fx+ i 1)] )
	[(fx>= i len)]
      (##sys#for-each (lambda (bucket)
			(proc (##sys#slot bucket 0) (##sys#slot bucket 1)) )
		      (##sys#slot vec i)) ) ) )

(define (%hash-table-fold ht func init)
  (let* ([vec (##sys#slot ht 1)]
	 [len (##sys#size vec)] )
    (let loop ([i 0] [acc init])
      (if (fx>= i len)
	  acc
	  (let fold2 ([bucket (##sys#slot vec i)]
		      [acc acc])
	    (if (null? bucket)
		(loop (fx+ i 1) acc)
		(let ([pare (##sys#slot bucket 0)])
		  (fold2 (##sys#slot bucket 1)
			 (func (##sys#slot pare 0) (##sys#slot pare 1) acc) ) ) ) ) ) ) ) )

(define (hash-table-fold ht func init)
  (##sys#check-structure ht 'hash-table 'hash-table-fold)
  (##sys#check-closure func 'hash-table-fold)
  (%hash-table-fold ht func init) )

(define (hash-table-for-each ht proc)
  (##sys#check-structure ht 'hash-table 'hash-table-for-each)
  (##sys#check-closure proc 'hash-table-for-each)
  (%hash-table-for-each ht proc) )

(define (hash-table-walk ht proc)
  (##sys#check-structure ht 'hash-table 'hash-table-walk)
  (##sys#check-closure proc 'hash-table-walk)
  (%hash-table-for-each ht proc) )

(define (hash-table-map ht func)
  (##sys#check-structure ht 'hash-table 'hash-table-map)
  (##sys#check-closure func 'hash-table-map)
  (%hash-table-fold ht (lambda (k v a) (cons (func k v) a)) '()) )