From d421ed1bb68999a51e0bf435ecc33173b9f8c15b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 25 Nov 2011 11:51:45 -0700 Subject: [PATCH] racket/class: add `send/keyword-apply' --- collects/racket/private/class-internal.rkt | 45 +++++++++++++++------- collects/racket/private/classidmap.rkt | 15 ++++++-- collects/scribblings/reference/class.scrbl | 11 +++++- collects/tests/racket/object.rktl | 10 ++++- 4 files changed, 61 insertions(+), 20 deletions(-) diff --git a/collects/racket/private/class-internal.rkt b/collects/racket/private/class-internal.rkt index da2e6bc26a..7a9260c140 100644 --- a/collects/racket/private/class-internal.rkt +++ b/collects/racket/private/class-internal.rkt @@ -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* diff --git a/collects/racket/private/classidmap.rkt b/collects/racket/private/classidmap.rkt index 87edbbf269..7c55e1e7f8 100644 --- a/collects/racket/private/classidmap.rkt +++ b/collects/racket/private/classidmap.rkt @@ -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 diff --git a/collects/scribblings/reference/class.scrbl b/collects/scribblings/reference/class.scrbl index 38083d74a4..41ff561635 100644 --- a/collects/scribblings/reference/class.scrbl +++ b/collects/scribblings/reference/class.scrbl @@ -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 ...) diff --git a/collects/tests/racket/object.rktl b/collects/tests/racket/object.rktl index 1cf62c844c..2841da62ee 100644 --- a/collects/tests/racket/object.rktl +++ b/collects/tests/racket/object.rktl @@ -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))