-(define-macro (define-method head . body)
- (if (not (pair? head))
- (goops-error "bad method head: ~S" head))
- (let ((gf (car head)))
- (cond ((and (pair? gf)
- (eq? (car gf) 'setter)
- (pair? (cdr gf))
- (symbol? (cadr gf))
- (null? (cddr gf)))
- ;; named setter method
- (let ((name (cadr gf)))
- (cond ((not (symbol? name))
- `(add-method! (setter ,name)
- (method ,(cdr head) ,@body)))
- (else
- `(begin
- (if (or (not (defined? ',name))
- (not (is-a? ,name <accessor>)))
- (define-accessor ,name))
- (add-method! (setter ,name)
- (method ,(cdr head) ,@body)))))))
- ((not (symbol? gf))
- `(add-method! ,gf (method ,(cdr head) ,@body)))
- (else
- `(begin
- ;; FIXME: this code is how it always was, but it's quite
- ;; cracky: it will only define the generic function if it
- ;; was undefined before (ok), or *was defined to #f*. The
- ;; latter is crack. But there are bootstrap issues about
- ;; fixing this -- change it to (is-a? ,gf <generic>) and
- ;; see.
- (if (or (not (defined? ',gf))
- (not ,gf))
- (define-generic ,gf))
- (add-method! ,gf
- (method ,(cdr head) ,@body)))))))
-
-(define-macro (method args . body)
- (letrec ((specializers
- (lambda (ls)
- (cond ((null? ls) (list (list 'quote '())))
- ((pair? ls) (cons (if (pair? (car ls))
- (cadar ls)
- '<top>)
- (specializers (cdr ls))))
- (else '(<top>)))))
- (formals
- (lambda (ls)
- (if (pair? ls)
- (cons (if (pair? (car ls)) (caar ls) (car ls))
- (formals (cdr ls)))
- ls))))
- (let ((make-proc (compile-make-procedure (formals args)
- (specializers args)
- body)))
- `(make <method>
- #:specializers (cons* ,@(specializers args))
- #:formals ',(formals args)
- #:body ',body
- #:make-procedure ,make-proc
- #:procedure ,(and (not make-proc)
- ;; that is to say: we set #:procedure if
- ;; `compile-make-procedure' returned `#f',
- ;; which is the case if `body' does not
- ;; contain a call to `next-method'
- `(lambda ,(formals args)
- ,@(if (null? body)
- '((begin))
- body)))))))
+(define (toplevel-define! name val)
+ (module-define! (current-module) name val))
+
+(define-syntax define-method
+ (syntax-rules (setter)
+ ((_ ((setter name) . args) body ...)
+ (begin
+ (if (or (not (defined? 'name))
+ (not (is-a? name <accessor>)))
+ (toplevel-define! 'name
+ (ensure-accessor
+ (if (defined? 'name) name #f) 'name)))
+ (add-method! (setter name) (method args body ...))))
+ ((_ (name . args) body ...)
+ (begin
+ ;; FIXME: this code is how it always was, but it's quite cracky:
+ ;; it will only define the generic function if it was undefined
+ ;; before (ok), or *was defined to #f*. The latter is crack. But
+ ;; there are bootstrap issues about fixing this -- change it to
+ ;; (is-a? name <generic>) and see.
+ (if (or (not (defined? 'name))
+ (not name))
+ (toplevel-define! 'name (make <generic> #:name 'name)))
+ (add-method! name (method args body ...))))))
+
+(define-syntax method
+ (lambda (x)
+ (define (parse-args args)
+ (let lp ((ls args) (formals '()) (specializers '()))
+ (syntax-case ls ()
+ (((f s) . rest)
+ (and (identifier? #'f) (identifier? #'s))
+ (lp #'rest
+ (cons #'f formals)
+ (cons #'s specializers)))
+ ((f . rest)
+ (identifier? #'f)
+ (lp #'rest
+ (cons #'f formals)
+ (cons #'<top> specializers)))
+ (()
+ (list (reverse formals)
+ (reverse (cons #''() specializers))))
+ (tail
+ (identifier? #'tail)
+ (list (append (reverse formals) #'tail)
+ (reverse (cons #'<top> specializers)))))))
+
+ (define (find-free-id exp referent)
+ (syntax-case exp ()
+ ((x . y)
+ (or (find-free-id #'x referent)
+ (find-free-id #'y referent)))
+ (x
+ (identifier? #'x)
+ (let ((id (datum->syntax #'x referent)))
+ (and (free-identifier=? #'x id) id)))
+ (_ #f)))
+
+ (define (compute-procedure formals body)
+ (syntax-case body ()
+ ((body0 ...)
+ (with-syntax ((formals formals))
+ #'(lambda formals body0 ...)))))
+
+ (define (->proper args)
+ (let lp ((ls args) (out '()))
+ (syntax-case ls ()
+ ((x . xs) (lp #'xs (cons #'x out)))
+ (() (reverse out))
+ (tail (reverse (cons #'tail out))))))
+
+ (define (compute-make-procedure formals body next-method)
+ (syntax-case body ()
+ ((body ...)
+ (with-syntax ((next-method next-method))
+ (syntax-case formals ()
+ ((formal ...)
+ #'(lambda (real-next-method)
+ (lambda (formal ...)
+ (let ((next-method (lambda args
+ (if (null? args)
+ (real-next-method formal ...)
+ (apply real-next-method args)))))
+ body ...))))
+ (formals
+ (with-syntax (((formal ...) (->proper #'formals)))
+ #'(lambda (real-next-method)
+ (lambda formals
+ (let ((next-method (lambda args
+ (if (null? args)
+ (apply real-next-method formal ...)
+ (apply real-next-method args)))))
+ body ...))))))))))
+
+ (define (compute-procedures formals body)
+ ;; So, our use of this is broken, because it operates on the
+ ;; pre-expansion source code. It's equivalent to just searching
+ ;; for referent in the datums. Ah well.
+ (let ((id (find-free-id body 'next-method)))
+ (if id
+ ;; return a make-procedure
+ (values #'#f
+ (compute-make-procedure formals body id))
+ (values (compute-procedure formals body)
+ #'#f))))
+
+ (syntax-case x ()
+ ((_ args) #'(method args (if #f #f)))
+ ((_ args body0 body1 ...)
+ (with-syntax (((formals (specializer ...)) (parse-args #'args)))
+ (call-with-values
+ (lambda ()
+ (compute-procedures #'formals #'(body0 body1 ...)))
+ (lambda (procedure make-procedure)
+ (with-syntax ((procedure procedure)
+ (make-procedure make-procedure))
+ #'(make <method>
+ #:specializers (cons* specializer ...)
+ #:formals 'formals
+ #:body '(body0 body1 ...)
+ #:make-procedure make-procedure
+ #:procedure procedure)))))))))