mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 05:50:26 +02:00
Code Activity

just parse method arguments once.

Browse source 
* module/oop/goops.scm (method): Tweak to just run through the arguments
  once. Thanks to Eli Barzilay for the tip.
This commit is contained in:
Andy Wingo 2009-05-21 15:34:29 +02:00
parent 47c8983f08
commit d63927150a
1 changed files with 20 additions and 18 deletions
Download patch file Download diff file Expand all files Collapse all files

38
module/oop/goops.scm
View file

@ -479,23 +479,26 @@
(define-syntax method
(lambda (x)
(define (compute-formals 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 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 '()))
(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 ...))))