srfi-69.scm

Scheme跨平台编译器

;;; srfi-69.scm - Optional non-standard extensions
;
; Copyright (c) 2000-2007, Felix L. Winkelmann
; Copyright (c) 2008, The Chicken Team
; 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
 (unit srfi-69)
 (usual-integrations)
 (disable-warning redef) ) ; hash-table-ref is an extended binding!

(cond-expand
 [paranoia]
 [else
  (declare
    (no-bound-checks)
    (no-procedure-checks-for-usual-bindings)
    (bound-to-procedure
      ##sys#check-string ##sys#check-symbol ##sys#check-exact ##sys#check-closure
      ##sys#check-inexact ##sys#check-structure
      ##sys#signal-hook
      ##sys#peek-fixnum
      ##sys#make-structure
      ##sys#size
      ##sys#slot ##sys#setslot
      ##srfi-69#%equal?-hash ) ) ] )

(private srfi-69
  unbound-value-thunk
  %object-uid-hash %eq?-hash %eqv?-hash %equal?-hash
  %hash-table-copy %hash-table-ref %hash-table-update! %hash-table-merge!
  %hash-table-for-each %hash-table-fold
  hash-table-canonical-length hash-table-rehash )

(declare
  (hide
    unbound-value-thunk
    %object-uid-hash %eq?-hash %eqv?-hash %equal?-hash
    %hash-table-copy %hash-table-ref %hash-table-update! %hash-table-merge!
    %hash-table-for-each %hash-table-fold
    hash-table-canonical-length hash-table-rehash) )

(cond-expand
 [unsafe
  (eval-when (compile)
    (define-macro (##sys#check-closure . _) '(##core#undefined))
    (define-macro (##sys#check-inexact . _) '(##core#undefined))
    (define-macro (##sys#check-structure . _) '(##core#undefined))
    (define-macro (##sys#check-symbol . _) '(##core#undefined))
    (define-macro (##sys#check-string . _) '(##core#undefined))
    (define-macro (##sys#check-exact . _) '(##core#undefined)) ) ]
 [else
  (declare (emit-exports "srfi-69.exports")) ] )

(register-feature! 'srfi-69)


;;; Unbound Value:

;; This only works because of '(no-bound-checks)'

(define-macro ($unbound-value)
 '(##sys#slot '##sys#arbitrary-unbound-symbol 0) )

(define unbound-value-thunk (lambda () ($unbound-value)))

(define-macro ($unbound? ?val)
  `(eq? ($unbound-value) ,?val) )


;;; Core Inlines:

(define-macro ($quick-flonum-truncate ?flo)
  `(##core#inline "C_quickflonumtruncate" ,?flo) )

(define-macro ($fix ?wrd)
  `(##core#inline "C_fix" ,?wrd) )

(define-macro ($block? ?obj)
  `(##core#inline "C_blockp" ,?obj) )

(define-macro ($special? ?obj)
  `(##core#inline "C_specialp" ,?obj) )

(define-macro ($port? ?obj)
  `(##core#inline "C_portp" ,?obj) )

(define-macro ($byte-block? ?obj)
  `(##core#inline "C_byteblockp" ,?obj) )

(define-macro ($hash-string ?str)
  `(##core#inline "C_hash_string" ,?str) )

(define-macro ($hash-string-ci ?str)
  `(##core#inline "C_hash_string_ci" ,?str) )


;;;

(define-macro ($immediate? ?obj)
  `(not ($block? ,?obj)) )


;;; Generation of hash-values:

;; Naming Conventions:
;; $foo - macro
;; $*foo - local macro (no such thing but at least it looks different)
;; %foo - private, usually unchecked, procedure
;; ##sys#foo - public, but undocumented, un-checked procedure
;; foo - public checked procedure
;;
;; All '%foo-hash' return a fixnum, not necessarily positive. The "overflow" of
;; a, supposedly, unsigned hash value into negative is not checked during
;; intermediate computation.
;;
;; The body of '%eq?-hash' is duplicated in 'eqv?-hash' and the body of '%eqv?-hash'
;; is duplicated in '%equal?-hash' to save on procedure calls.

;; Fixed hash-values:

(define-constant other-hash-value 99)
(define-constant true-hash-value 256)
(define-constant false-hash-value 257)
(define-constant null-hash-value 258)
(define-constant eof-hash-value 259)
(define-constant input-port-hash-value 260)
(define-constant output-port-hash-value 261)
(define-constant unknown-immediate-hash-value 262)

(define-constant hash-default-bound 536870912)

;; Force Hash to Bounded Fixnum:

(define-macro ($fxabs ?fxn)
  `(let ([_fxn ,?fxn]) (if (fx< _fxn 0) (fxneg _fxn) _fxn ) ) )

(define-macro ($hash/limit ?hsh ?lim)
  `(fxmod (fxand (foreign-value "C_MOST_POSITIVE_FIXNUM" int)
		 ($fxabs ,?hsh))
	  ,?lim) )

;; Number Hash:

(define-constant flonum-magic 331804471)

#| Not sure which is "better"; went with speed
(define-macro ($subbyte ?bytvec ?i)
  `(##core#inline "C_subbyte" ,?bytvec ,?i) )

(define-macro ($hash-flonum ?flo)
  `(fx* flonum-magic
	,(let loop ([idx (fx- (##sys#size 1.0) 1)])
	    (if (fx= 0 idx)
		`($subbyte ,?flo 0)
		`(fx+ ($subbyte ,?flo ,idx)
		      (fxshl ,(loop (fx- idx 1)) 1))))) )
|#

(define-macro ($hash-flonum ?flo)
  `(fx* flonum-magic ($quick-flonum-truncate ,?flo)) )

(define (##sys#number-hash-hook obj)
  (%equal?-hash obj) )

(define-macro ($non-fixnum-number-hash ?obj)
  `(cond [(flonum? obj)	($hash-flonum ,?obj)]
	 [else		($fix (##sys#number-hash-hook ,?obj))] ) )

(define-macro ($number-hash ?obj)
  `(cond [(fixnum? obj)	,?obj]
	 [else		($non-fixnum-number-hash ?obj)] ) )

(define (number-hash obj #!optional (bound hash-default-bound))
  (unless (number? obj)
    (##sys#signal-hook #:type 'number-hash "invalid number" obj) )
  (##sys#check-exact bound 'number-hash)
  ($hash/limit ($number-hash obj) bound) )

;; Object UID Hash:

#; ;NOT YET (no weak-reference)
(define (%object-uid-hash obj)
  (%uid-hash (##sys#object->uid obj)) )

(define (%object-uid-hash obj)
  (%equal?-hash obj) )

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

;; Symbol Hash:

#; ;NOT YET (no unique-symbol-hash)
(define-macro ($symbol-hash ?obj)
  `(##sys#slot ,?obj INDEX-OF-UNIQUE-HASH-VALUE-COMPUTED-DURING-SYMBOL-CREATION) )

(define-macro ($symbol-hash ?obj)
  `($hash-string (##sys#slot ,?obj 1)) )

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

;; Keyword Hash:

(define (##sys#check-keyword x . y)
  (unless (keyword? x)
    (##sys#signal-hook #:type-error
		       (and (not (null? y)) (car y))
		       "bad argument type - not a keyword" x) ) )

#; ;NOT YET (no unique-keyword-hash)
(define-macro ($keyword-hash ?obj)
  `(##sys#slot ,?obj INDEX-OF-UNIQUE-HASH-VALUE-COMPUTED-DURING-KEYWORD-CREATION) )

(define-macro ($keyword-hash ?obj)
  `($hash-string (##sys#slot ,?obj 1)) )

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

;; Eq Hash:

(define-macro ($eq?-hash-object? ?obj)
  `(or ($immediate? ,?obj)
       (symbol? ,?obj)
       #; ;NOT YET (no keyword vs. symbol issue)
       (keyword? ,?obj) ) )

(define (%eq?-hash obj)
  (cond [(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)]
	[($immediate? obj)	unknown-immediate-hash-value]
	[else			(%object-uid-hash obj) ] ) )

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

(define hash-by-identity eq?-hash)

;; Eqv Hash:

(define-macro ($eqv?-hash-object? ?obj)
  `(or ($eq?-hash-object? ,?obj)
       (number? ,?obj)) )

(define (%eqv?-hash obj)
  (cond [(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]
	[else			(%object-uid-hash obj) ] ) )

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

;; Equal Hash:

;XXX Be nice if these were parameters
(define-constant recursive-hash-max-depth 4)
(define-constant recursive-hash-max-length 4)

(define-macro ($*list-hash ?obj)
  `(fx+ (length ,?obj)
	(recursive-atomic-hash (##sys#slot ,?obj 0) depth)) )

(define-macro ($*pair-hash ?obj)
  `(fx+ (fxshl (recursive-atomic-hash (##sys#slot ,?obj 0) depth) 16)
	(recursive-atomic-hash (##sys#slot ,?obj 1) depth)) )

(define-macro ($*port-hash ?obj)
  `(fx+ (fxshl (##sys#peek-fixnum ,?obj 0) 4) ; Little extra "identity"
	(if (input-port? ,?obj)
	    input-port-hash-value
	    output-port-hash-value)) )

(define-macro ($*special-vector-hash ?obj)
  `(vector-hash ,?obj (##sys#peek-fixnum ,?obj 0) depth 1) )

(define-macro ($*regular-vector-hash ?obj)
  `(vector-hash ,?obj 0 depth 0) )

(define (%equal?-hash obj)

  ; Recurse into some portion of the vector's slots 
  (define (vector-hash obj seed depth start)
    (let ([len (##sys#size obj)])
      (let loop ([hsh (fx+ len seed)]
		 [i start]
		 [len (fx- (fxmin recursive-hash-max-length len) start)] )