add case-lambda

2014-07-15 17:51:27 +09:00
parent bb427cf275
commit 1d5fa803aa
2 changed files with 69 additions and 25 deletions
@@ -1397,3 +1397,48 @@

 (import (picrin syntax-rules))
 (export syntax-rules)
+
+(define-library (scheme case-lambda)
+  (import (scheme base))
+
+  (define-syntax case-lambda
+    (syntax-rules ()
+      ((case-lambda
+        (?a1 ?e1 ...)
+        ?clause1 ...)
+       (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 ...)))))
+
+  (export case-lambda))