diff --git a/collects/racket/private/generic-interfaces.rkt b/collects/racket/private/generic-interfaces.rkt index c998aada21..8cee557eeb 100644 --- a/collects/racket/private/generic-interfaces.rkt +++ b/collects/racket/private/generic-interfaces.rkt @@ -31,6 +31,11 @@ v))) (list (cons prop:equal+hash vector->list)))) + ;; forgeries of generic functions that don't exist + (define (equal-proc a b e) (equal? a b)) + (define (hash-proc x h) (equal-hash-code x)) + (define (hash2-proc x h) (equal-secondary-hash-code x)) + (define-syntax gen:equal+hash (list (quote-syntax prop:gen:equal+hash) (quote-syntax equal-proc) @@ -52,6 +57,14 @@ v))) (list (cons prop:custom-write (lambda (v) (vector-ref v 0)))))) + ;; see above for equal+hash + (define (write-proc v p w) + (case w + [(#t) (write v p)] + [(#f) (display v p)] + [(0 1) (print v p w)] + [else (error 'write-proc "internal error; should not happen")])) + (define-syntax gen:custom-write (list (quote-syntax prop:gen:custom-write) (quote-syntax write-proc))) diff --git a/collects/tests/generic/base-interfaces.rkt b/collects/tests/generic/base-interfaces.rkt new file mode 100644 index 0000000000..12f5e9a0e2 --- /dev/null +++ b/collects/tests/generic/base-interfaces.rkt @@ -0,0 +1,28 @@ +#lang racket/base + +;; Test the existence of forged generic functions for +;; gen:custom-write and gen:equal+hash + +(require racket/generic) + +(struct tuple (ref) + #:methods gen:custom-write + [(define/generic super write-proc) + (define (write-proc v p w) + (super v p w))] + #:methods gen:equal+hash + [(define/generic super-eq equal-proc) + (define/generic hash1 hash-proc) + (define/generic hash2 hash2-proc) + (define (equal-proc a b e) + (super-eq (tuple-ref a) (tuple-ref b) e)) + (define (hash-proc a h) + (hash1 (tuple-ref a) h)) + (define (hash2-proc a h) + (hash2 (tuple-ref a) h))]) + +;; ok if these don't raise unbound id errors +(write (tuple 5)) +(equal? (tuple 5) (tuple 5)) +(equal-hash-code (tuple 5)) +(equal-secondary-hash-code (tuple 5)) diff --git a/collects/tests/generic/tests.rkt b/collects/tests/generic/tests.rkt index 1270fa31c6..1b168632b6 100644 --- a/collects/tests/generic/tests.rkt +++ b/collects/tests/generic/tests.rkt @@ -8,5 +8,6 @@ (submod "struct-form.rkt" test) (submod "equal+hash.rkt" test) (submod "custom-write.rkt" test) + "base-interfaces.rkt" "contract.rkt" "from-unstable.rkt")