159 lines
8.0 KiB
Racket
159 lines
8.0 KiB
Racket
#lang racket/base
|
|
(require racket/local
|
|
(for-syntax racket/base
|
|
racket/local
|
|
racket/syntax)
|
|
(only-in "define-struct.rkt" define/generic))
|
|
|
|
(define-for-syntax (keyword-stx? v)
|
|
(keyword? (syntax->datum v)))
|
|
|
|
(provide define-generics define/generic)
|
|
(define-syntax (define-generics stx)
|
|
(syntax-case stx () ; can't use syntax-parse, since it depends on us
|
|
;; keyword arguments must _all_ be provided _in_order_. For the
|
|
;; user-facing version of `define-generics', see racket/generic.
|
|
;;
|
|
;; The `header` is the original name the library writer provides
|
|
;; that is used to define the `name`, `prop:name`, and `name?`
|
|
;; identifiers. We have it here so that we can use it to match
|
|
;; the method header's self argument.
|
|
[(_ (header name prop:name name?
|
|
#:defined-table defined-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) ...)
|
|
(and (identifier? #'header)
|
|
(identifier? #'name)
|
|
(identifier? #'prop:name)
|
|
(identifier? #'name?)
|
|
(identifier? #'defined-table)
|
|
(let ([generics (syntax->list #'(generic ...))])
|
|
(and (pair? generics) (andmap identifier? generics))))
|
|
(let* ([idxs (for/list ([i (in-naturals 0)]
|
|
[_ (syntax->list #'(generic ...))])
|
|
i)]
|
|
[name-str (symbol->string (syntax-e #'name?))]
|
|
[generics (syntax->list #'(generic ...))]
|
|
[prop-defined-already? (syntax-e #'defined-already?)])
|
|
(with-syntax ([name-str name-str]
|
|
[how-many-generics (length idxs)]
|
|
[(generic-arity-coerce ...) (generate-temporaries #'(generic ...))]
|
|
[(generic-idx ...) idxs]
|
|
[(generic-this-idx ...)
|
|
(for/list ([top-ga (syntax->list #'(generic-args ...))])
|
|
(let loop ([ga top-ga]
|
|
[i 0])
|
|
(syntax-case ga ()
|
|
[(keyword id . ga)
|
|
(and (keyword-stx? #'keyword)
|
|
(identifier? #'id))
|
|
(loop #'ga i)]
|
|
[(id . ga)
|
|
(and (identifier? #'id))
|
|
(if (free-identifier=? #'header #'id)
|
|
i
|
|
(loop #'ga (add1 i)))]
|
|
[(keyword [id] . ga)
|
|
(and (keyword-stx? #'keyword)
|
|
(identifier? #'id))
|
|
(loop #'ga i)]
|
|
[([id] . ga)
|
|
(and (identifier? #'id))
|
|
(loop #'ga i)]
|
|
[_
|
|
(identifier? #'id)
|
|
(raise-syntax-error #f "No required by-position generic argument" top-ga)])))]
|
|
[(fake-args ...)
|
|
(for/list ([ga (syntax->list #'(generic-args ...))])
|
|
(let loop ([ga ga])
|
|
(syntax-case ga ()
|
|
[(keyword id . ga)
|
|
(and (keyword-stx? #'keyword)
|
|
(identifier? #'id))
|
|
#`(keyword id . #,(loop #'ga))]
|
|
[(id . ga)
|
|
(and (identifier? #'id))
|
|
#`(id . #,(loop #'ga))]
|
|
[(keyword [id] . ga)
|
|
(and (keyword-stx? #'keyword)
|
|
(identifier? #'id))
|
|
#`(keyword [id #f] . #,(loop #'ga))]
|
|
[([id] . ga)
|
|
(and (identifier? #'id))
|
|
#`([id #f] . #,(loop #'ga))]
|
|
[id
|
|
(identifier? #'id)
|
|
#'id]
|
|
[()
|
|
#'()])))]
|
|
;; 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
|
|
(define-syntax name (list #'prop:name #'generic ...))
|
|
; XXX optimize no kws or opts
|
|
(define generic-arity-coerce
|
|
(let*-values ([(p) (lambda fake-args #f)]
|
|
[(generic-arity-spec) (procedure-arity p)]
|
|
[(generic-required-kws generic-allowed-kws) (procedure-keywords p)])
|
|
(lambda (f)
|
|
(procedure-reduce-keyword-arity f generic-arity-spec generic-required-kws generic-allowed-kws))))
|
|
...
|
|
#,@(if prop-defined-already?
|
|
'() ; we don't need to define it
|
|
(list
|
|
#'(define-values (prop:name name? get-generics)
|
|
(make-struct-type-property
|
|
'name
|
|
(lambda (generic-vector si)
|
|
(unless (vector? generic-vector)
|
|
(error 'name
|
|
"bad generics table, expecting a vector, got ~e"
|
|
generic-vector))
|
|
(unless (= (vector-length generic-vector)
|
|
how-many-generics)
|
|
(error 'name
|
|
"bad generics table, expecting a vector of length ~e, got ~e"
|
|
how-many-generics
|
|
(vector-length generic-vector)))
|
|
(vector (let ([mthd-generic (vector-ref generic-vector generic-idx)])
|
|
(and mthd-generic
|
|
(generic-arity-coerce mthd-generic)))
|
|
...))))))
|
|
;; Hash table mapping method name symbols to
|
|
;; whether the given method is implemented
|
|
(define (defined-table this)
|
|
(unless (name? this)
|
|
(raise-argument-error 'defined-table name-str this))
|
|
(for/hash ([name (in-list '(#,@(map syntax->datum generics)))]
|
|
[gen (in-vector (get-generics this))])
|
|
(values name (not (not gen)))))
|
|
(define generic
|
|
(generic-arity-coerce
|
|
(make-keyword-procedure
|
|
(lambda (kws kws-args . given-args)
|
|
(define this (list-ref given-args generic-this-idx))
|
|
(if (name? this)
|
|
(let ([m (vector-ref (get-generics this) generic-idx)])
|
|
(if m
|
|
(keyword-apply m kws kws-args given-args)
|
|
(error 'generic "not implemented for ~e" this)))
|
|
(raise-argument-error 'generic name-str this)))
|
|
; XXX (non-this ... this . rst)
|
|
(lambda given-args
|
|
(define this (list-ref given-args generic-this-idx))
|
|
(if (name? this)
|
|
(let ([m (vector-ref (get-generics this) generic-idx)])
|
|
(if m
|
|
(apply m given-args)
|
|
(error 'generic "not implemented for ~e" this)))
|
|
(raise-argument-error 'generic name-str this))))))
|
|
...)))]))
|