From 063a52c437f579bccc49d93dba1804f13104ec6c Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <matthias@benkard.de>
Date: Sat, 26 Jul 2008 14:46:18 +0200
Subject: Add AND, CASE, %DEFUN*, %MEMBER, and OR.

---
 util.lisp | 63 +++++++++++++++++++++++++++++++++++++++++++++++++++++++--------
 1 file changed, 55 insertions(+), 8 deletions(-)

(limited to 'util.lisp')

diff --git a/util.lisp b/util.lisp
index 5fdff4c..50688a3 100644
--- a/util.lisp
+++ b/util.lisp
@@ -72,8 +72,45 @@
             macro-lambda-list-name
             (list* 'let
                    (list (list lambda-list-name
-                               (list 'car macro-lambda-list-name)))
-             (make-%defmacro*-body lambda-list lambda-list-name body))))))
+                               (list 'cdr
+                                     (list 'car macro-lambda-list-name))))
+                   (make-%defmacro*-body lambda-list lambda-list-name body))))))
+
+(%defmacro %defun* args
+  (let* ((form (car args))
+         (real-args (cdr form)))
+    (let ((name (car real-args))
+          (lambda-list (car (cdr real-args)))
+          (body (cdr (cdr real-args)))
+          (lambda-list-name (gensym)))
+      (list* '%defun
+             name
+             lambda-list-name
+             (make-%defmacro*-body lambda-list lambda-list-name body)))))
+
+(%defmacro* and expressions
+  (cond ((null expressions) t)
+        ((null (cdr expressions)) (car expressions))
+        (t (list 'if
+                 (car expressions)
+                 (cons 'and (cdr expressions))
+                 nil))))
+
+(%defmacro* or expressions
+  (cond ((null expressions) nil)
+        ((null (cdr expressions)) (car expressions))
+        (t (let ((expr-sym (gensym)))
+             (list 'let
+                   (list (list expr-sym (car expressions)))
+                   (list 'if
+                         expr-sym
+                         expr-sym
+                         (cons 'or (cdr expressions))))))))
+
+(%defun* %member (item list)
+  (and list
+       (or (and (eq item (car list)) list)
+           (%member item (cdr list)))))
 
 (%defmacro* case (object . clauses)
   (let ((this-clause (car clauses))
@@ -81,9 +118,19 @@
         (object-sym (gensym)))
     (if (null clauses)
         nil
-        (list 'let
-              (list (list object-sym object))
-              (list 'if
-                    (list 'eq object-sym (list 'quote (car this-clause)))
-                    (cons 'progn (cdr this-clause))
-                    (cons 'case object-sym rest))))))
+        (if (and (null rest)
+                 (or (eq (car this-clause) t)
+                     (eq (car this-clause) 'otherwise)))
+            (cons 'progn (cdr this-clause))
+            (list 'let
+                  (list (list object-sym object))
+                  (list 'if
+                        (if (listp (car this-clause))
+                            (list '%member
+                                  object-sym
+                                  (list 'quote (car this-clause)))
+                            (list 'eq
+                                  object-sym
+                                  (list 'quote (car this-clause))))
+                        (cons 'progn (cdr this-clause))
+                        (list* 'case object-sym rest)))))))
-- 
cgit v1.2.3