conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

update case-lambda impl

This commit is contained in:
Yuichi Nishiwaki 2014-07-16 14:47:25 +09:00
parent 6ee4d49a96
commit bdcb83296e
1 changed files with 21 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
piclib/built-in.scm
View File

@ -1425,42 +1425,27 @@
(define-syntax case-lambda (define-syntax case-lambda
(syntax-rules () (syntax-rules ()
((case-lambda ((case-lambda (params body0 ...) ...)
(?a1 ?e1 ...)
?clause1 ...)
(lambda args (lambda args
(let ((l (length args))) (let ((len (length args)))
(case-lambda "CLAUSE" args l (letrec-syntax
(?a1 ?e1 ...) ((cl (syntax-rules ::: ()
?clause1 ...)))) ((cl)
((case-lambda "CLAUSE" ?args ?l (error "no matching clause"))
((?a1 ...) ?e1 ...) ((cl ((p :::) . body) . rest)
?clause1 ...) (if (= len (length '(p :::)))
(if (= ?l (length '(?a1 ...))) (apply (lambda (p :::)
(apply (lambda (?a1 ...) ?e1 ...) ?args) . body)
(case-lambda "CLAUSE" ?args ?l args)
?clause1 ...))) (cl . rest)))
((case-lambda "CLAUSE" ?args ?l ((cl ((p ::: . tail) . body)
((?a1 . ?ar) ?e1 ...) . rest)
?clause1 ...) (if (>= len (length '(p :::)))
(case-lambda "IMPROPER" ?args ?l 1 (?a1 . ?ar) (?ar ?e1 ...) (apply
?clause1 ...)) (lambda (p ::: . tail)
((case-lambda "CLAUSE" ?args ?l . body)
(?a1 ?e1 ...) args)
?clause1 ...) (cl . rest))))))
(let ((?a1 ?args)) (cl (params body0 ...) ...)))))))
?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 ...)))))
(export case-lambda)) (export case-lambda))