diff --git a/collects/racket/private/class-internal.rkt b/collects/racket/private/class-internal.rkt index 58a71efae4..7fab71a4dc 100644 --- a/collects/racket/private/class-internal.rkt +++ b/collects/racket/private/class-internal.rkt @@ -37,7 +37,7 @@ object% object? externalizable<%> printable<%> writable<%> equal<%> object=? new make-object instantiate - send send/apply send/keyword-apply send* dynamic-send + send send/apply send/keyword-apply send* send+ dynamic-send class-field-accessor class-field-mutator with-method get-field set-field! field-bound? field-names private* public* pubment* @@ -4195,6 +4195,7 @@ An example (unless (symbol? method-name) (raise-argument-error 'dynamic-send "symbol?" method-name)) (keyword-apply (find-method/who 'dynamic-send obj method-name) kws kw-vals obj args)))) +;; imperative chained send (define-syntax (send* stx) (syntax-case stx () [(form obj clause ...) @@ -4211,6 +4212,18 @@ An example #f "bad method call" stx clause-stx)])) (syntax->list (syntax (clause ...)))))))])) +;; functional chained send +(define-syntax (send+ stx) + (define-syntax-class send-clause + #:description "method clause" + (pattern [name:id . args])) + (syntax-parse stx + [(_ obj:expr clause-0:send-clause clause:send-clause ...) + (quasisyntax/loc stx + (let ([o (send obj clause-0.name . clause-0.args)]) + (send+ o clause ...)))] + [(_ obj:expr) (syntax/loc stx obj)])) + ;; find-method/who : symbol[top-level-form/proc-name] ;; any[object] ;; symbol[method-name] @@ -5112,7 +5125,7 @@ An example object% object? object=? externalizable<%> printable<%> writable<%> equal<%> new make-object instantiate get-field set-field! field-bound? field-names - send send/apply send/keyword-apply send* dynamic-send + send send/apply send/keyword-apply send* send+ dynamic-send class-field-accessor class-field-mutator with-method private* public* pubment* override* overment* diff --git a/collects/scribblings/reference/class.scrbl b/collects/scribblings/reference/class.scrbl index 2ce27f6550..6493b29271 100644 --- a/collects/scribblings/reference/class.scrbl +++ b/collects/scribblings/reference/class.scrbl @@ -1156,6 +1156,33 @@ is the same as (send o end-edit-sequence)) ]} +@defform/subs[(send+ obj-expr msg ...) + ([msg (method-id arg ...) + (method-id arg ... . arg-list-expr)])]{ + +Calls methods (in order) starting with the object produced by +@racket[obj-expr]. Each method call will be invoked on the result of +the last method call, which is expected to be an object. Each +@racket[msg] corresponds to a use of @racket[send]. + +This is the functional analogue of @racket[send*]. + +@defexamples[#:eval class-eval +(define point% + (class object% + (super-new) + (init-field [x 0] [y 0]) + (define/public (move-x dx) + (new this% [x (+ x dx)])) + (define/public (move-y dy) + (new this% [y (+ y dy)])))) + +(send+ (new point%) + (move-x 5) + (move-y 7) + (move-x 12)) +]} + @defform[(with-method ((id (obj-expr method-id)) ...) body ...+)]{ diff --git a/collects/tests/racket/object.rktl b/collects/tests/racket/object.rktl index 07b74a5c9d..679367409d 100644 --- a/collects/tests/racket/object.rktl +++ b/collects/tests/racket/object.rktl @@ -1189,6 +1189,7 @@ (super-make-object))]) (test 100 'priv (send (make-object c% 100) priv)) (test 100 'priv (send* (make-object c% 100) (priv))) + (test 100 'priv (send+ (make-object c% 100) (priv))) (test 100 'priv (with-method ([p ((make-object c% 100) priv)]) (p))) (test 100 'gen-priv-cls (send-generic (make-object c% 100) (generic c% priv))) (test 100 'gen-priv-intf (send-generic (make-object c% 100) (generic i<%> priv))) @@ -1197,6 +1198,7 @@ (test #t object? (make-object c% 10)) (err/rt-test (send (make-object c% 10) priv) exn:fail:object?) (err/rt-test (send* (make-object c% 10) (priv)) exn:fail:object?) + (err/rt-test (send+ (make-object c% 10) (priv)) exn:fail:object?) (err/rt-test (with-method ([p ((make-object c% 100) priv)]) (p)) exn:fail:object?) (err/rt-test (generic c% priv) exn:fail:object?) (err/rt-test (make-generic c% 'priv) exn:fail:object?)) @@ -1211,6 +1213,19 @@ (super-new)))]) (test 16 'send-using-local (send (new c%) pub 3))) +;; ------------------------------------------------------------ +;; `send+' tests + +(let ([c% (class object% + (define/public (m . args) this) + (super-new))]) + (syntax-test #'(send+ (new c%) (m 5) (m 10))) + (syntax-test #'(send+ (new c%) (m . (1 2 3)))) + (syntax-test #'(send+ (new c%) (m 5) (m . (1 2 3)))) + + (test #t object? (send+ (new c%) (m 5) (m 15))) + (test #t object? (send+ (new c%) (m 5) (m . (1 2 3 4))))) + ;; ------------------------------------------------------------ ;; `new' tests