- (let ((name (cadr exp)))
- (if (and (pair? name)
- (eq? (car name) 'setter)
- (pair? (cdr name))
- (symbol? (cadr name))
- (null? (cddr name)))
- (let ((name (cadr name)))
- (cond ((not (symbol? name))
- (goops-error "bad method name: ~S" name))
- ((defined? name env)
+ (let ((head (cadr exp)))
+ (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 ,(cdadr exp)
+ ,@(cddr exp))))
+ ((defined? name env)
+ `(begin
+ ;; *fixme* Temporary hack for the current
+ ;; module system
+ (if (not ,name)
+ (define-accessor ,name))
+ (add-method! (setter ,name)
+ (method ,(cdadr exp)
+ ,@(cddr exp)))))
+ (else
+ `(begin
+ (define-accessor ,name)
+ (add-method! (setter ,name)
+ (method ,(cdadr exp)
+ ,@(cddr exp))))))))
+ ((not (symbol? gf))
+ `(add-method! ,gf (method ,(cdadr exp) ,@(cddr exp))))
+ ((defined? gf env)