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

.

Browse Source 
original commit: b58dd97194b162bce69d7ae13d1b750e0e6f3615
This commit is contained in:
Matthew Flatt 2001-10-26 22:35:43 +00:00
parent d147d6c8e1
commit 3581bcf928
1 changed files with 30 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
collects/mzlib/class.ss
View File

@ -1660,24 +1660,35 @@
;; methods and fields ;; methods and fields
;;-------------------------------------------------------------------- ;;--------------------------------------------------------------------
(define-syntax send (define-syntaxes (send send/apply)
(lambda (stx) (let ([mk
(syntax-case stx () (lambda (flatten?)
[(_ obj name . args) (lambda (stx)
(begin (syntax-case stx ()
(unless (identifier? (syntax name)) [(_ obj name . args)
(raise-syntax-error (begin
#f (unless (identifier? (syntax name))
"method name is not an identifier" (raise-syntax-error
stx #f
(syntax name))) "method name is not an identifier"
(if (stx-list? (syntax args)) stx
(syntax (let ([this obj]) (syntax name)))
((find-method this 'name) this . args))) (if flatten?
(with-syntax ([args (flatten-args (syntax args))]) (if (stx-list? (syntax args))
(syntax (let ([this obj]) (syntax (let ([this obj])
(apply (find-method this 'name) this . args))))))]))) (apply (find-method this 'name) this . args)))
(raise-syntax-error
#f
"bad syntax (illegal use of `.')"
stx))
(if (stx-list? (syntax args))
(syntax (let ([this obj])
((find-method this 'name) this . args)))
(with-syntax ([args (flatten-args (syntax args))])
(syntax (let ([this obj])
(apply (find-method this 'name) this . args)))))))])))])
(values (mk #f) (mk #t))))
(define-syntax send* (define-syntax send*
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()
@ -2004,7 +2015,7 @@
(rename :interface interface) interface? (rename :interface interface) interface?
object% object? object% object?
make-object instantiate make-object instantiate
send send* make-class-field-accessor make-class-field-mutator with-method send send/apply send* make-class-field-accessor make-class-field-mutator with-method
private* public* override* private* public* override*
define/private define/public define/override define/private define/public define/override
(rename make-generic/proc make-generic) send-generic (rename make-generic/proc make-generic) send-generic