From bdcb83296eff967a930738735b8841de1b7cdea9 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Wed, 16 Jul 2014 14:47:25 +0900
Subject: [PATCH] update case-lambda impl

---
 piclib/built-in.scm | 57 +++++++++++++++++----------------------------
 1 file changed, 21 insertions(+), 36 deletions(-)

diff --git a/piclib/built-in.scm b/piclib/built-in.scm
index c3c09059..0b94d488 100644
--- a/piclib/built-in.scm
+++ b/piclib/built-in.scm
@@ -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))