From 83a18a658ac925b589d36e37ae150ec986d5eba8 Mon Sep 17 00:00:00 2001
From: Rose Hogenson <rhogenson@posteo.net>
Date: Fri, 5 Aug 2022 21:04:49 -0700
Subject: Add more of the standard library.

---
 lib/scheme/base/30-if.csc | 29 ++++++++++++++++++++++++++++-
 1 file changed, 28 insertions(+), 1 deletion(-)

(limited to 'lib/scheme/base/30-if.csc')

diff --git a/lib/scheme/base/30-if.csc b/lib/scheme/base/30-if.csc
index 09012fa..6262f5a 100644
--- a/lib/scheme/base/30-if.csc
+++ b/lib/scheme/base/30-if.csc
@@ -1,5 +1,6 @@
 (export
   and
+  case-lambda
   cond
   if
   or
@@ -73,4 +74,30 @@
     (syntax-rules ()
       ((unless test result1 result2 ...)
         (if (not test)
-          (begin result1 result2 ...))))))
+          (begin result1 result2 ...)))))
+
+
+  (define-syntax case-lambda
+    (syntax-rules ()
+      ((case-lambda (params body0 ...) ...)
+        (lambda args
+          (let ((len (length args)))
+            (let-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 ...) ...))))))))
-- 
cgit v1.3.1