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

racket/class: add `send/keyword-apply'

Browse Source
This commit is contained in:
Matthew Flatt 2011-11-25 11:51:45 -07:00
parent bc0c2075fd
commit d421ed1bb6
4 changed files with 61 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
collects/racket/private/class-internal.rkt
View File

@ -36,7 +36,7 @@
object% object? externalizable<%> printable<%> writable<%> equal<%>
object=?
new make-object instantiate
send send/apply send* class-field-accessor class-field-mutator with-method
send send/apply send/keyword-apply send* class-field-accessor class-field-mutator with-method
get-field set-field! field-bound? field-names
private* public* pubment*
override* overment*
@ -3783,10 +3783,10 @@
;; methods and fields
;;--------------------------------------------------------------------
(define-syntaxes (send send/apply send-traced send/apply-traced)
(define-syntaxes (send send/apply send-traced send/apply-traced send/keyword-apply)
(let ()
(define (do-method traced? stx form obj name args rest-arg?)
(define (do-method traced? stx form obj name args rest-arg? kw-args)
(with-syntax ([(sym method receiver)
(generate-temporaries (syntax (1 2 3)))])
(quasisyntax/loc stx
@ -3801,39 +3801,57 @@
(syntax/loc stx method)
(syntax/loc stx sym)
args
rest-arg?))))))
rest-arg?
kw-args))))))
(define (core-send traced? apply?)
(define (core-send traced? apply? kws?)
(lambda (stx)
(syntax-case stx ()
[(form obj name . args)
(identifier? (syntax name))
(if (stx-list? (syntax args))
;; (send obj name arg ...) or (send/apply obj name arg ...)
(do-method traced? stx #'form #'obj #'name #'args apply?)
(do-method traced? stx #'form #'obj #'name
(if kws? (cddr (syntax->list #'args)) #'args)
apply?
(and kws?
(let ([l (syntax->list #'args)])
(list (car l) (cadr l)))))
(if apply?
;; (send/apply obj name arg ... . rest)
(raise-syntax-error
#f "bad syntax (illegal use of `.')" stx)
;; (send obj name arg ... . rest)
(do-method traced? stx #'form #'obj #'name
(flatten-args #'args) #t)))]
(flatten-args #'args) #t #f)))]
[(form obj name . args)
(raise-syntax-error
#f "method name is not an identifier" stx #'name)]
[(form obj)
(raise-syntax-error
#f "expected a method name" stx)])))
(define (send/keyword-apply stx)
(syntax-case stx ()
[(form obj name)
(identifier? (syntax name))
(raise-syntax-error #f "missing expression for list of keywords" stx)]
[(form obj name a)
(identifier? (syntax name))
(raise-syntax-error #f "missing expression for list of keyword arguments" stx)]
[else ((core-send #f #t #t) stx)]))
(values
;; send
(core-send #f #f)
(core-send #f #f #f)
;; send/apply
(core-send #f #t)
(core-send #f #t #f)
;; send-traced
(core-send #t #f)
(core-send #t #f #f)
;; send/apply-traced
(core-send #t #t))))
(core-send #t #t #f)
;; send/keyword-apply
send/keyword-apply)))
(define-syntaxes (send* send*-traced)
(let* ([core-send*
@ -3972,7 +3990,8 @@
(syntax/loc stx ((generic-applicable gen) obj))
(syntax/loc stx (generic-name gen))
flat-stx
(not proper?)))))))])))
(not proper?)
#f))))))])))
(values (core-send-generic #f) (core-send-generic #t))))
(define-syntaxes (class-field-accessor class-field-mutator generic/form)
@ -4799,7 +4818,7 @@
object% object? object=? externalizable<%> printable<%> writable<%> equal<%>
new make-object instantiate
get-field set-field! field-bound? field-names
send send/apply send* class-field-accessor class-field-mutator with-method
send send/apply send/keyword-apply send* class-field-accessor class-field-mutator with-method
private* public* pubment*
override* overment*
augride* augment*

15
collects/racket/private/classidmap.rkt
View File

@ -298,7 +298,8 @@
method-stx
(syntax (quote id))
flat-args-stx
(not proper?)))]
(not proper?)
#f))]
[id
(identifier? (syntax id))
(raise-syntax-error
@ -354,7 +355,8 @@
(class-context? (car ctx))))
(define (make-method-call traced? source-stx object-stx
method-proc-stx method-name-stx args-stx rest-arg?)
method-proc-stx method-name-stx args-stx
rest-arg? kw-args)
(define-syntax (qstx stx)
(syntax-case stx ()
@ -363,7 +365,12 @@
(class-syntax-protect
(with-syntax ([object object-stx]
[method method-proc-stx]
[app (if rest-arg? (qstx apply) (qstx #%app))]
[app (if rest-arg?
(if kw-args
(qstx keyword-apply)
(qstx apply))
(qstx #%app))]
[(kw-arg ...) (or kw-args'())]
[args args-stx])
(if traced?
(with-syntax ([(mth obj) (generate-temporaries
@ -378,7 +385,7 @@
obj name (app list var ...))
(call-with-values (lambda () (app mth obj var ...))
finalize-call-event))))
(qstx (app method object . args))))))
(qstx (app method kw-arg ... object . args))))))
(provide (protect-out make-this-map make-this%-map make-field-map make-method-map
make-direct-method-map

11
collects/scribblings/reference/class.scrbl
View File

@ -1076,8 +1076,8 @@ This form calls the method in a way analogous to @racket[(apply
_method-id _arg ... _arg-list-expr)]. The @racket[arg-list-expr]
must not be a parenthesized expression.
Methods are called from outside a class with the @racket[send] and
@racket[send/apply] forms.
Methods are called from outside a class with the @racket[send],
@racket[send/apply], and @racket[send/keyword-apply] forms.
@defform*[[(send obj-expr method-id arg ...)
(send obj-expr method-id arg ... . arg-list-expr)]]{
@ -1098,6 +1098,13 @@ If @racket[obj-expr] does not produce an object, the
Like the dotted form of @racket[send], but @racket[arg-list-expr] can
be any expression.}
@defform[(send/keyword-apply obj-expr method-id
keyword-list-expr value-list-expr
arg ... arg-list-expr)]{
Like @racket[send/apply], but with expressions for keyword and
argument lists like @racket[keyword-apply].}
@defform/subs[(send* obj-expr msg ...)
([msg (method-id arg ...)

10
collects/tests/racket/object.rktl
View File

@ -16,6 +16,9 @@
(error-test #'(send 7) (lambda (x) (and (exn:fail:syntax? x) (regexp-match "method" (exn-message x)))))
(error-test #'(send/apply 7) (lambda (x) (and (exn:fail:syntax? x) (regexp-match "method" (exn-message x)))))
(error-test #'(send/keyword-apply 7) (lambda (x) (and (exn:fail:syntax? x) (regexp-match "method" (exn-message x)))))
(error-test #'(send/keyword-apply 7 method) (lambda (x) (and (exn:fail:syntax? x) (regexp-match "list of keywords" (exn-message x)))))
(error-test #'(send/keyword-apply 7 method 8) (lambda (x) (and (exn:fail:syntax? x) (regexp-match "list of keyword arguments" (exn-message x)))))
(define (test-init/field init)
(teval #`(test #t class? (class object% (#,init))))
@ -766,12 +769,14 @@
;; Test send/apply dotted send and method-call forms:
(define dotted% (class object%
(public f g)
(public f g h)
(define (f x y z)
(list z y x))
(define (g x)
(let ([w (list x (add1 x) (+ x 2))])
(f . w)))
(define (h x #:y [y 12])
(list x y))
(super-make-object)))
(define dotted (make-object dotted%))
(test '(3 2 1) 'dotted (send dotted f 1 2 3))
@ -784,6 +789,9 @@
(test '(8 6 2) 'dotted (send dotted f 2 . l))
(test '(8 6 2) 'dotted (send/apply dotted f 2 l))
(test '(9 7 3) 'dotted (send/apply dotted f 3 '(7 9))))
(test '(1 12) 'dotted (send/apply dotted h (list 1)))
(test '(2 12) 'dotted (send/keyword-apply dotted h null null (list 2)))
(test '(3 8) 'dotted (send/keyword-apply dotted h '(#:y) (list 8) (list 3)))
(syntax-test #'(send/apply dotted f 2 . l))