diff --git a/lib/srfi/128.sld b/lib/srfi/128.sld index 710305ef..1d5aa903 100644 --- a/lib/srfi/128.sld +++ b/lib/srfi/128.sld @@ -1,7 +1,8 @@ (define-library (srfi 128) (import (scheme base) (scheme char) (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 ;; Predicates: comparator? comparator-ordered? comparator-hashable? diff --git a/lib/srfi/128/comparators.scm b/lib/srfi/128/comparators.scm index 2d135a73..ab5a282e 100644 --- a/lib/srfi/128/comparators.scm +++ b/lib/srfi/128/comparators.scm @@ -1,12 +1,24 @@ (define-record-type Comparator - (make-comparator type-test equality ordering hash) + (%make-comparator% type-test equality ordering hash) comparator? (type-test comparator-type-test-predicate) (equality comparator-equality-predicate) (ordering comparator-ordering-predicate) (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 (er-macro-transformer (lambda (expr rename compare)