From f36ecd9184c30ebd51f7fc27d9690984dac6bd24 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Fri, 4 Jan 2019 00:16:54 -0500 Subject: [PATCH] Tweak equality-predicate-property to accept a default-value argument. --- src/runtime/hash-table.scm | 26 +++++++++++++++++--------- 1 file changed, 17 insertions(+), 9 deletions(-) diff --git a/src/runtime/hash-table.scm b/src/runtime/hash-table.scm index 8eaff600a..8c886bc9b 100644 --- a/src/runtime/hash-table.scm +++ b/src/runtime/hash-table.scm @@ -1374,14 +1374,11 @@ USA. (set-equality-predicate-properties! equal? hash-by-equal #t) (set-equality-predicate-properties! string=? string-hash #f) (set-equality-predicate-properties! string-ci=? string-ci-hash #f) - (set-equality-predicate-properties! int:= int:modulo #f))) + (set-equality-predicate-properties! int:= int:modulo #f) + (register-predicate! equality-predicate? 'equality-predicate))) (define (equality-predicate-keylist equality-predicate) - (let ((props (%equality-predicate-properties equality-predicate #f))) - (if (not props) - (error:not-a equality-predicate? equality-predicate - 'equality-predicate-keylist)) - props)) + (%equality-predicate-properties equality-predicate '())) (define (equality-predicate-property-names equality-predicate) (let loop ((keylist (equality-predicate-keylist equality-predicate))) @@ -1389,14 +1386,25 @@ USA. (cons (car keylist) (loop (cddr keylist))) '()))) -(define (equality-predicate-property equality-predicate name) - (get-keyword-value (equality-predicate-keylist equality-predicate) name)) +(define (equality-predicate-property equality-predicate name + #!optional default-value) + (let ((value + (get-keyword-value (equality-predicate-keylist equality-predicate) + name))) + (if (default-object? value) + (begin + (if (default-object? default-value) + (error "Equality predicate missing property" name)) + default-value) + value))) (define (equality-predicate-hasher equality-predicate) (equality-predicate-property equality-predicate 'hasher)) (define (equality-predicate-rehash-after-gc? equality-predicate) - (equality-predicate-property equality-predicate 'rehash-after-gc?)) + (equality-predicate-property equality-predicate + 'rehash-after-gc? + #t)) (define (set-equality-predicate-properties! equality-predicate hasher rehash-after-gc? . keylist) -- 2.25.1