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

Allow generics to be attached to existing struct properties.

Browse Source
This commit is contained in:
Vincent St-Amour 2012-05-18 17:45:58 -04:00
parent 991cb5f371
commit 0b0473d228
3 changed files with 45 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/racket/generics.rkt
View File

@ -30,12 +30,14 @@
[(_ (name prop:name name?) (generic . generics-args) ...) [(_ (name prop:name name?) (generic . generics-args) ...)
#'(define-generics/pre (name prop:name name? #'(define-generics/pre (name prop:name name?
#:defined-table defined-table #:defined-table defined-table
;; coerce-method-table is not public ;; the following are not public
#:coerce-method-table #f) #:coerce-method-table #f
#:prop-defined-already? #f)
(generic . generics-args) ...)] (generic . generics-args) ...)]
[(_ (name prop:name name? #:defined-table defined-table) [(_ (name prop:name name? #:defined-table defined-table)
(generic . generics-args) ...) (generic . generics-args) ...)
#'(define-generics/pre (name prop:name name? #'(define-generics/pre (name prop:name name?
#:defined-table defined-table #:defined-table defined-table
#:coerce-method-table #f) #:coerce-method-table #f
#:prop-defined-already? #f)
(generic . generics-args) ...)])) (generic . generics-args) ...)]))

3
collects/racket/private/dict.rkt
View File

@ -5,7 +5,8 @@
(define-generics (dict prop:dict dict? #:defined-table dict-def-table (define-generics (dict prop:dict dict? #:defined-table dict-def-table
;; private version needs all kw args, in order ;; private version needs all kw args, in order
#:coerce-method-table #f) #:coerce-method-table #f
#:prop-defined-already? #f)
(dict-ref dict key [default]) (dict-ref dict key [default])
(dict-set! dict key val) (dict-set! dict key val)
(dict-set dict key val) (dict-set dict key val)

60
collects/racket/private/generics.rkt
View File

@ -15,7 +15,11 @@
[(_ (name prop:name name? [(_ (name prop:name name?
#:defined-table defined-table #:defined-table defined-table
;; use of coercion functions is explained below ;; use of coercion functions is explained below
#:coerce-method-table coerce-method-table) #:coerce-method-table coerce-method-table
;; are we being passed an existing struct property? If so,
;; this kw arg is bound to the struct property accessor, and
;; we don't define the struct property
#:prop-defined-already? defined-already?)
(generic . generic-args) ...) (generic . generic-args) ...)
(and (identifier? #'name) (and (identifier? #'name)
(identifier? #'prop:name) (identifier? #'prop:name)
@ -28,7 +32,8 @@
i)] i)]
[name-str (symbol->string (syntax-e #'name))] [name-str (symbol->string (syntax-e #'name))]
[generics (syntax->list #'(generic ...))] [generics (syntax->list #'(generic ...))]
[need-coercion? (syntax->datum #'coerce-method-table)]) [need-coercion? (syntax->datum #'coerce-method-table)]
[prop-defined-already? (syntax-e #'defined-already?)])
(with-syntax ([name-str name-str] (with-syntax ([name-str name-str]
[how-many-generics (length idxs)] [how-many-generics (length idxs)]
[(generic-arity-coerce ...) (generate-temporaries #'(generic ...))] [(generic-arity-coerce ...) (generate-temporaries #'(generic ...))]
@ -86,7 +91,14 @@
;; property for the method table ;; property for the method table
(if need-coercion? (if need-coercion?
(generate-temporary (syntax->datum #'prop:name)) (generate-temporary (syntax->datum #'prop:name))
#'prop:name)]) #'prop:name)]
;; if we're the ones defining the struct property,
;; generate a new id, otherwise use the struct property
;; accessor that we were passed
[get-generics
(if prop-defined-already?
#'defined-already?
(generate-temporary 'get-generics))])
#`(begin #`(begin
(define-syntax name (list #'generic ...)) (define-syntax name (list #'generic ...))
; XXX optimize no kws or opts ; XXX optimize no kws or opts
@ -97,25 +109,29 @@
(lambda (f) (lambda (f)
(procedure-reduce-keyword-arity f generic-arity-spec generic-required-kws generic-allowed-kws)))) (procedure-reduce-keyword-arity f generic-arity-spec generic-required-kws generic-allowed-kws))))
... ...
(define-values (prop:method-table name? get-generics) #,@(if prop-defined-already?
(make-struct-type-property '() ; we don't need to define it
'name (list
(lambda (generic-vector si) #'(define-values (prop:method-table name? get-generics)
(unless (vector? generic-vector) (make-struct-type-property
(error 'name 'name
"bad generics table, expecting a vector, got ~e" (lambda (generic-vector si)
generic-vector)) (unless (vector? generic-vector)
(unless (= (vector-length generic-vector) (error 'name
how-many-generics) "bad generics table, expecting a vector, got ~e"
(error 'name generic-vector))
"bad generics table, expecting a vector of length ~e, got ~e" (unless (= (vector-length generic-vector)
how-many-generics how-many-generics)
(vector-length generic-vector))) (error 'name
(vector (let ([mthd-generic (vector-ref generic-vector generic-idx)]) "bad generics table, expecting a vector of length ~e, got ~e"
(and mthd-generic how-many-generics
(generic-arity-coerce mthd-generic))) (vector-length generic-vector)))
...)))) (vector (let ([mthd-generic (vector-ref generic-vector generic-idx)])
;; Use case for method table coercion: retrofitting a generics- (and mthd-generic
(generic-arity-coerce mthd-generic)))
...))))))
;; Use case for method table coercion: retrofitting a generics-
;; based API on top of a struct property that uses its own ad-hoc ;; based API on top of a struct property that uses its own ad-hoc
;; extension mechanism. ;; extension mechanism.
;; If coercion is used, prop:method-table and prop:name are ;; If coercion is used, prop:method-table and prop:name are