From 9f9d3bcede3a4d57fb112011be7023fdd83db369 Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <matthias@benkard.de>
Date: Sat, 26 Jul 2008 11:23:45 +0200
Subject: Add macro %DEFMACRO*, a simple wrapper around %DEFMACRO.

---
 cond.lisp | 29 ----------------------
 init.lisp |  1 -
 util.lisp | 85 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 85 insertions(+), 30 deletions(-)
 delete mode 100644 cond.lisp

diff --git a/cond.lisp b/cond.lisp
deleted file mode 100644
index 7b3d1cc..0000000
--- a/cond.lisp
+++ /dev/null
@@ -1,29 +0,0 @@
-(%defun list* args
-  (if (null (cdr args))
-      (car args)
-      (cons (car args)
-            (apply 'list* (cdr args)))))
-
-(%defmacro let* args
-  (let ((form (car args)))
-    (let ((bindings (car (cdr form)))
-          (body (cdr (cdr form))))
-      (if (null bindings)
-          (list* 'let nil body)
-          (let ((first-binding (car bindings))
-                (rest (cdr bindings)))
-            (list 'let
-                  (list first-binding)
-                  (list* 'let* rest body)))))))
-
-(%defmacro cond args
-  (let* ((form (car args))
-         (clauses (cdr form))
-         (clause (car clauses))
-         (rest (cdr clauses)))
-    (if (null clauses)
-        nil
-        (list 'if
-              (car clause)
-              (cons 'progn (cdr clause))
-              (cons 'cond rest)))))
diff --git a/init.lisp b/init.lisp
index 4c4f5f0..cdd9997 100644
--- a/init.lisp
+++ b/init.lisp
@@ -1,5 +1,4 @@
 (in-package :common-lisp)
 (load "util.lisp")
-(load "cond.lisp")
 (load "list-functions.lisp")
 (in-package :common-lisp-user)
diff --git a/util.lisp b/util.lisp
index ed4c3a0..5fdff4c 100644
--- a/util.lisp
+++ b/util.lisp
@@ -2,3 +2,88 @@
   (list '%fset
         (list 'quote (car (cdr (car args))))
         (cons '%lambda (cdr (cdr (car args))))))
+
+(%defun list* args
+  (if (null (cdr args))
+      (car args)
+      (cons (car args)
+            (apply 'list* (cdr args)))))
+
+(%defmacro let* args
+  (let ((form (car args)))
+    (let ((bindings (car (cdr form)))
+          (body (cdr (cdr form))))
+      (if (null bindings)
+          (list* 'let nil body)
+          (let ((first-binding (car bindings))
+                (rest (cdr bindings)))
+            (list 'let
+                  (list first-binding)
+                  (list* 'let* rest body)))))))
+
+(%defmacro cond args
+  (let* ((form (car args))
+         (clauses (cdr form))
+         (clause (car clauses))
+         (rest (cdr clauses)))
+    (if (null clauses)
+        nil
+        (list 'if
+              (car clause)
+              (cons 'progn (cdr clause))
+              (cons 'cond rest)))))
+
+(%defun not args
+  (if (null (car args)) t nil))
+
+(%defun make-%defmacro*-body args
+  (let ((lambda-list (car args))
+        (lambda-list-name (car (cdr args)))
+        (body (car (cdr (cdr args)))))
+    (cond ((null lambda-list) body)
+          ((not (listp lambda-list))
+           (list
+            (list* 'let
+                   (list (list lambda-list lambda-list-name))
+                   body)))
+          (t (let ((lambda-symbol (car lambda-list))
+                   (rest-lambda-list (cdr lambda-list))
+                   (rest-name (gensym)))
+               (list
+                (list* 'let
+                       (list (list lambda-symbol
+                                   (list 'car lambda-list-name))
+                             (list rest-name
+                                   (list 'cdr lambda-list-name)))
+                       (make-%defmacro*-body (cdr lambda-list)
+                                             rest-name
+                                             body))))))))
+
+(%defmacro %defmacro* 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)))
+          (macro-lambda-list-name (gensym))
+          (lambda-list-name (gensym)))
+      (list '%defmacro
+            name
+            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))))))
+
+(%defmacro* case (object . clauses)
+  (let ((this-clause (car clauses))
+        (rest (cdr clauses))
+        (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))))))
-- 
cgit v1.2.3