diff options
-rw-r--r-- | module/oop/goops.scm | 38 |
1 files changed, 20 insertions, 18 deletions
diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 8c980485f..fd2d60058 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -479,23 +479,26 @@ (define-syntax method (lambda (x) - (define (compute-formals args) - (let lp ((ls args) (out '())) - (syntax-case ls () - (((f s) . rest) (lp (syntax rest) (cons (syntax f) out))) - ((f . rest) (identifier? (syntax f)) - (lp (syntax rest) (cons (syntax f) out))) - (() (reverse out)) - (tail (identifier? (syntax tail)) - (append (reverse out) (syntax tail)))))) - - (define (compute-specializers args) - (let lp ((ls args) (out '())) + (define (parse-args args) + (let lp ((ls args) (formals '()) (specializers '())) (syntax-case ls () - (((f s) . rest) (lp (syntax rest) (cons (syntax s) out))) - ((f . rest) (lp (syntax rest) (cons (syntax <top>) out))) - (() (reverse (cons (syntax '()) out))) - (tail (reverse (cons (syntax <top>) out)))))) + (((f s) . rest) + (and (identifier? (syntax f)) (identifier? (syntax s))) + (lp (syntax rest) + (cons (syntax f) formals) + (cons (syntax s) specializers))) + ((f . rest) + (identifier? (syntax f)) + (lp (syntax rest) + (cons (syntax f) formals) + (cons (syntax <top>) specializers))) + (() + (list (reverse formals) + (reverse (cons (syntax '()) specializers)))) + (tail + (identifier? (syntax tail)) + (list (append (reverse formals) (syntax tail)) + (reverse (cons (syntax <top>) specializers))))))) (define (find-free-id exp referent) (syntax-case exp () @@ -561,8 +564,7 @@ (syntax-case x () ((_ args) (syntax (method args (if #f #f)))) ((_ args body0 body1 ...) - (with-syntax ((formals (compute-formals (syntax args))) - ((specializer ...) (compute-specializers (syntax args)))) + (with-syntax (((formals (specializer ...)) (parse-args (syntax args)))) (call-with-values (lambda () (compute-procedures (syntax formals) (syntax (body0 body1 ...)))) |