update case-lambda impl
This commit is contained in:
parent
6ee4d49a96
commit
bdcb83296e
|
@ -1425,42 +1425,27 @@
|
|||
|
||||
(define-syntax case-lambda
|
||||
(syntax-rules ()
|
||||
((case-lambda
|
||||
(?a1 ?e1 ...)
|
||||
?clause1 ...)
|
||||
((case-lambda (params body0 ...) ...)
|
||||
(lambda args
|
||||
(let ((l (length args)))
|
||||
(case-lambda "CLAUSE" args l
|
||||
(?a1 ?e1 ...)
|
||||
?clause1 ...))))
|
||||
((case-lambda "CLAUSE" ?args ?l
|
||||
((?a1 ...) ?e1 ...)
|
||||
?clause1 ...)
|
||||
(if (= ?l (length '(?a1 ...)))
|
||||
(apply (lambda (?a1 ...) ?e1 ...) ?args)
|
||||
(case-lambda "CLAUSE" ?args ?l
|
||||
?clause1 ...)))
|
||||
((case-lambda "CLAUSE" ?args ?l
|
||||
((?a1 . ?ar) ?e1 ...)
|
||||
?clause1 ...)
|
||||
(case-lambda "IMPROPER" ?args ?l 1 (?a1 . ?ar) (?ar ?e1 ...)
|
||||
?clause1 ...))
|
||||
((case-lambda "CLAUSE" ?args ?l
|
||||
(?a1 ?e1 ...)
|
||||
?clause1 ...)
|
||||
(let ((?a1 ?args))
|
||||
?e1 ...))
|
||||
((case-lambda "CLAUSE" ?args ?l)
|
||||
(error "Wrong number of arguments to CASE-LAMBDA."))
|
||||
((case-lambda "IMPROPER" ?args ?l ?k ?al ((?a1 . ?ar) ?e1 ...)
|
||||
?clause1 ...)
|
||||
(case-lambda "IMPROPER" ?args ?l (+ ?k 1) ?al (?ar ?e1 ...)
|
||||
?clause1 ...))
|
||||
((case-lambda "IMPROPER" ?args ?l ?k ?al (?ar ?e1 ...)
|
||||
?clause1 ...)
|
||||
(if (>= ?l ?k)
|
||||
(apply (lambda ?al ?e1 ...) ?args)
|
||||
(case-lambda "CLAUSE" ?args ?l
|
||||
?clause1 ...)))))
|
||||
(let ((len (length args)))
|
||||
(letrec-syntax
|
||||
((cl (syntax-rules ::: ()
|
||||
((cl)
|
||||
(error "no matching clause"))
|
||||
((cl ((p :::) . body) . rest)
|
||||
(if (= len (length '(p :::)))
|
||||
(apply (lambda (p :::)
|
||||
. body)
|
||||
args)
|
||||
(cl . rest)))
|
||||
((cl ((p ::: . tail) . body)
|
||||
. rest)
|
||||
(if (>= len (length '(p :::)))
|
||||
(apply
|
||||
(lambda (p ::: . tail)
|
||||
. body)
|
||||
args)
|
||||
(cl . rest))))))
|
||||
(cl (params body0 ...) ...)))))))
|
||||
|
||||
(export case-lambda))
|
||||
|
|
Loading…
Reference in New Issue