Default implementations are only reached in the absence of method tables.
This commit is contained in:
parent
16a75761b0
commit
04f535cadc
|
@ -127,7 +127,8 @@
|
|||
(generate-temporary 'get-generics))]
|
||||
;; for each generic method, builds a cond clause to do the
|
||||
;; predicate dispatch found in method-impl-list
|
||||
[((cond-impl ...) ...) marked-generics])
|
||||
[((cond-impl ...) ...) marked-generics]
|
||||
[(-name?) (generate-temporaries #'(name?))])
|
||||
#`(begin
|
||||
(define-syntax name (list #'prop:name #'generic ...))
|
||||
; XXX optimize no kws or opts
|
||||
|
@ -197,15 +198,16 @@
|
|||
(lambda given-args
|
||||
(define this (list-ref given-args generic-this-idx))
|
||||
(cond
|
||||
;; default cases
|
||||
[(pred? this) (apply cond-impl given-args)]
|
||||
...
|
||||
;; Fallthrough
|
||||
[(name? this)
|
||||
[#,(if prop-defined-already?
|
||||
#'(name? this)
|
||||
#'(-name? this))
|
||||
(let ([m (vector-ref (get-generics this) generic-idx)])
|
||||
(if m
|
||||
(apply m given-args)
|
||||
(error 'generic "not implemented for ~e" this)))]
|
||||
;; default cases
|
||||
[(pred? this) (apply cond-impl given-args)]
|
||||
...
|
||||
[else (raise-argument-error 'generic name-str this)])))))
|
||||
...)))]))
|
||||
|
||||
|
|
|
@ -69,7 +69,7 @@ availability.
|
|||
|
||||
When @racket[maybe-defaults] is provided, each generic function
|
||||
uses @racket[pred?]s to dispatch to the given default implementations,
|
||||
@racket[method-impl]s, before dispatching to the generic method table.
|
||||
@racket[method-impl]s, if dispatching to the generic method table fails.
|
||||
The syntax of the @racket[method-impl]s is the same as the methods
|
||||
provided for the @racket[#:methods] keyword for @racket[struct].}
|
||||
|
||||
|
|
|
@ -41,3 +41,24 @@
|
|||
(check-false (stream-empty? l4))
|
||||
(check-equal? (stream-first l4) 1)
|
||||
(check-equal? (stream-first (stream-rest l4)) 2))
|
||||
|
||||
(struct a ())
|
||||
|
||||
(define-generics bool-able
|
||||
(to-bool bool-able)
|
||||
#:defaults
|
||||
([a? (define (to-bool a) #t)]))
|
||||
|
||||
(struct b a ()
|
||||
#:methods gen:bool-able
|
||||
[(define (to-bool b) #f)])
|
||||
|
||||
(module+ test
|
||||
(define my-a (a))
|
||||
(define my-b (b))
|
||||
|
||||
(check-true (bool-able? my-a))
|
||||
(check-true (bool-able? my-b))
|
||||
|
||||
(check-true (to-bool my-a))
|
||||
(check-false (to-bool my-b)))
|
||||
|
|
Loading…
Reference in New Issue
Block a user