mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 21:59:17 +02:00
fix make-comparator hash function arity in SRFI 128
This commit is contained in:
parent
48d6c35548
commit
6aacffc0e8
2 changed files with 15 additions and 2 deletions
|
@ -1,7 +1,8 @@
|
||||||
(define-library (srfi 128)
|
(define-library (srfi 128)
|
||||||
(import (scheme base) (scheme char)
|
(import (scheme base) (scheme char)
|
||||||
(srfi 27) (srfi 69) (srfi 95) (srfi 98) (srfi 151)
|
(srfi 27) (srfi 69) (srfi 95) (srfi 98) (srfi 151)
|
||||||
(only (chibi) fixnum? er-macro-transformer))
|
(only (chibi) fixnum? er-macro-transformer)
|
||||||
|
(only (chibi ast) opcode? procedure? procedure-arity procedure-variadic?))
|
||||||
(export
|
(export
|
||||||
;; Predicates:
|
;; Predicates:
|
||||||
comparator? comparator-ordered? comparator-hashable?
|
comparator? comparator-ordered? comparator-hashable?
|
||||||
|
|
|
@ -1,12 +1,24 @@
|
||||||
|
|
||||||
(define-record-type Comparator
|
(define-record-type Comparator
|
||||||
(make-comparator type-test equality ordering hash)
|
(%make-comparator% type-test equality ordering hash)
|
||||||
comparator?
|
comparator?
|
||||||
(type-test comparator-type-test-predicate)
|
(type-test comparator-type-test-predicate)
|
||||||
(equality comparator-equality-predicate)
|
(equality comparator-equality-predicate)
|
||||||
(ordering comparator-ordering-predicate)
|
(ordering comparator-ordering-predicate)
|
||||||
(hash comparator-hash-function))
|
(hash comparator-hash-function))
|
||||||
|
|
||||||
|
(define (make-comparator type-test equality ordering hash)
|
||||||
|
(%make-comparator%
|
||||||
|
type-test
|
||||||
|
equality
|
||||||
|
ordering
|
||||||
|
(if (or (opcode? hash)
|
||||||
|
(not (procedure? hash))
|
||||||
|
(procedure-variadic? hash)
|
||||||
|
(> (procedure-arity hash) 1))
|
||||||
|
hash
|
||||||
|
(lambda (x . o) (hash x)))))
|
||||||
|
|
||||||
(define-syntax hash-bound
|
(define-syntax hash-bound
|
||||||
(er-macro-transformer
|
(er-macro-transformer
|
||||||
(lambda (expr rename compare)
|
(lambda (expr rename compare)
|
||||||
|
|
Loading…
Add table
Reference in a new issue