suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Added a #:fallbacks option to define-generics.

Browse Source 
The #:fallbacks option specifies a set of method definitions.  Each definition
is used for any value that does not support the specific method.  Like
allows define/generic and absent method definitions.  If neither a specific
implementation or the #:fallbacks clause defines a given method, the normal
runtime error is raised.  The #:defined-table option reports whether a value's
specific implementation supports a method; the presence of a #:fallbacks
implementation for a method does not change this result.
This commit is contained in:
Carl Eastlund 2013-07-09 02:04:50 -04:00
parent fc4c8dd53e
commit c6532131a0
5 changed files with 45 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
pkgs/data-lib/data/order.rkt
View File

@ -15,9 +15,13 @@
;; i.e., exporting prop:ordered-dict as opposed to using a
;; generated hidden property.
(define-primitive-generics
(ordered-dict gen:ordered-dict prop:ordered-dict ordered-methods ordered-dict?
#:defined-table dict-def-table
#:defaults ())
(ordered-dict gen:ordered-dict
prop:ordered-dict
ordered-methods
ordered-dict?
dict-def-table)
#:defaults ()
#:fallbacks ()
(dict-iterate-least ordered-dict)
(dict-iterate-greatest ordered-dict)
(dict-iterate-least/>? ordered-dict key)

6
pkgs/racket-pkgs/racket-test/tests/generic/pr13737.rkt
View File

@ -21,9 +21,9 @@
(local-require racket/private/generic)
(define-primitive-generics
(foo gen:foo prop:foo foo-methods foo?
#:defined-table dummy
#:defaults ([number? (define (meth foo #:kw kw) kw)]))
(foo gen:foo prop:foo foo-methods foo? dummy)
#:defaults ([number? (define (meth foo #:kw kw) kw)])
#:fallbacks ()
(meth foo #:kw kw))
(check-equal? (meth 3 #:kw 5) 5))

28
racket/lib/collects/racket/generic.rkt
View File

@ -15,22 +15,28 @@
(begin-for-syntax
(define (parse stx methods table defaults)
(define (parse stx methods table defaults fallbacks)
(syntax-case stx ()
[(#:defined-table name . args)
(identifier? #'name)
(if table
(wrong-syntax (stx-car stx)
"duplicate #:defined-table specification")
(parse #'args methods #'name defaults))]
(parse #'args methods #'name defaults fallbacks))]
[(#:defined-table . other)
(wrong-syntax (stx-car stx) "invalid #:defined-table specification")]
[(#:defaults ([pred defn ...] ...) . args)
(if defaults
(wrong-syntax (stx-car stx) "duplicate #:defaults specification")
(parse #'args methods table #'([pred defn ...] ...)))]
(parse #'args methods table #'([pred defn ...] ...) fallbacks))]
[(#:defaults . other)
(wrong-syntax (stx-car stx) "invalid #:defaults specification")]
[(#:fallbacks [fallback ...] . args)
(if fallbacks
(wrong-syntax (stx-car stx) "duplicate #:fallbacks specification")
(parse #'args methods table defaults #'[fallback ...]))]
[(#:fallbacks . other)
(wrong-syntax (stx-car stx) "invalid #:fallbacks specification")]
[(kw . args)
(keyword? (syntax-e #'kw))
(wrong-syntax #'kw "invalid keyword argument")]
@ -40,13 +46,14 @@
(let loop ([methods (list (stx-car stx))] [stx #'args])
(syntax-case stx ()
[((_ . _) . args) (loop (cons (stx-car stx) methods) #'args)]
[_ (parse stx (reverse methods) table defaults)])))]
[_ (parse stx (reverse methods) table defaults fallbacks)])))]
[(other . args)
(wrong-syntax #'other
"expected a method identifier with formal arguments")]
[() (values (or methods '())
(or table (generate-temporary 'table))
(or defaults '()))]
(or defaults '())
(or fallbacks '()))]
[other
(wrong-syntax #'other
"expected a list of arguments with no dotted tail")])))
@ -57,9 +64,10 @@
(parameterize ([current-syntax-context stx])
(unless (identifier? #'name)
(wrong-syntax #'name "expected an identifier"))
(define-values (methods table defaults)
(parse #'rest #f #f #f))
(define-values (methods table defaults fallbacks)
(parse #'rest #f #f #f #f))
(define/with-syntax [default ...] defaults)
(define/with-syntax [fallback ...] fallbacks)
(define/with-syntax [method ...] methods)
(define/with-syntax [method-name ...] (map stx-car methods))
(define/with-syntax [method-index ...]
@ -75,9 +83,9 @@
#'(begin
(define-primitive-generics/derived
original
(name gen-name prop-name get-name pred-name
#:defined-table table-name
#:defaults [default ...])
(name gen-name prop-name get-name pred-name table-name)
#:defaults [default ...]
#:fallbacks [fallback ...]
method ...)
(define-generics-contract name pred-name get-name
[method-name method-index]

7
racket/lib/collects/racket/private/dict.rkt
View File

@ -3,9 +3,10 @@
(require racket/private/generic ; to avoid circular dependencies
(for-syntax racket/base))
(define-primitive-generics (dict gen:dict prop:dict dict-methods dict?
#:defined-table dict-def-table
#:defaults ())
(define-primitive-generics
(dict gen:dict prop:dict dict-methods dict? dict-def-table)
#:defaults ()
#:fallbacks ()
(dict-ref dict key [default])
(dict-set! dict key val)
(dict-set dict key val)

17
racket/lib/collects/racket/private/generic.rkt
View File

@ -29,9 +29,13 @@
(define-syntax (define-primitive-generics/derived stx)
(syntax-case stx ()
[(_ original
(self-name generic-name property-name accessor-name predicate-name
#:defined-table supported-name
#:defaults ([default-pred default-defn ...] ...))
(self-name generic-name
property-name
accessor-name
predicate-name
supported-name)
#:defaults ([default-pred default-defn ...] ...)
#:fallbacks [fallback-defn ...]
[method-name . method-signature]
...)
(parameterize ([current-syntax-context #'original])
@ -53,6 +57,8 @@
(generate-temporaries #'(default-pred ...)))
(define/with-syntax (default-impl-name ...)
(generate-temporaries #'(default-pred ...)))
(define/with-syntax fallback-name
(generate-temporary #'self-name))
#'(begin
(define-syntax generic-name
(make-generic-info (quote-syntax property-name)
@ -85,6 +91,8 @@
(define default-impl-name
(generic-method-table generic-name default-defn ...))
...
(define fallback-name
(generic-method-table generic-name fallback-defn ...))
(define-generic-support supported-name
self-name
[method-name ...]
@ -94,7 +102,8 @@
method-name
method-signature
self-name
(vector-ref (table-name self-name 'method-name) 'method-index)
(or (vector-ref (table-name self-name 'method-name) 'method-index)
(vector-ref fallback-name 'method-index))
original)
...))]))