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.

---
 util.lisp | 85 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 85 insertions(+)

(limited to 'util.lisp')

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


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


From 0f7abae8b9525d60685ae3b9ecc2fb4131c766a4 Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <matthias@benkard.de>
Date: Sat, 26 Jul 2008 19:23:28 +0200
Subject: Reader: Support quasiquotation.

---
 util.lisp | 37 +++++++++++++++++++++++++++++++++++++
 1 file changed, 37 insertions(+)

(limited to 'util.lisp')

diff --git a/util.lisp b/util.lisp
index 50688a3..ca1b25a 100644
--- a/util.lisp
+++ b/util.lisp
@@ -134,3 +134,40 @@
                                   (list 'quote (car this-clause))))
                         (cons 'progn (cdr this-clause))
                         (list* 'case object-sym rest)))))))
+
+(%defmacro* sys::quasiquote (object)
+  (if (not (consp object))
+      (list 'quote object)
+      (cond ((eq 'sys::unquote (car object)) (car (cdr object)))
+            ((eq 'sys::quasiquote (car object)) (list 'quote object))
+            ((and (consp (car object))
+                  (eq 'sys::unquote-splicing (car (car object))))
+             (list 'append
+                   (car (cdr (car object)))
+                   (list 'sys::quasiquote (cdr object))))
+            (t (list 'cons
+                     (list 'sys::quasiquote (car object))
+                     (list 'sys::quasiquote (cdr object)))))))
+
+(%defun* list-eqp (list1 list2)
+  "Not really EQUALP (only works on trees of symbols)."
+  (if (and (consp list1) (consp list2))
+      (and (list-eqp (car list1) (car list2))
+           (list-eqp (cdr list1) (cdr list2)))
+      (eq list1 list2)))
+
+(%defun* macroexpand (object . rest)
+  (let* ((env (if rest (car rest) nil))
+         (expansion-1 (macroexpand-1 object env))
+         (expansion-2 (macroexpand-1 expansion-1 env)))
+    (if (list-eqp expansion-1 expansion-2)
+        expansion-1
+        (macroexpand expansion-2))))
+
+(%defun* macroexpand-all (object . rest)
+  (let* ((env (if rest (car rest) nil)))
+    (if (consp object)
+        (let ((expansion (macroexpand object env)))
+          (cons (macroexpand-all (car expansion))
+                (macroexpand-all (cdr expansion))))
+        object)))
-- 
cgit v1.2.3


From 1117690bf46342f1ab704334d818d07ea0640b9f Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <matthias@benkard.de>
Date: Sat, 26 Jul 2008 19:48:40 +0200
Subject: Add APPEND and REVERSE.

---
 util.lisp | 75 +++++++++++++++++++++++++++++++++++++++++----------------------
 1 file changed, 49 insertions(+), 26 deletions(-)

(limited to 'util.lisp')

diff --git a/util.lisp b/util.lisp
index ca1b25a..13877b2 100644
--- a/util.lisp
+++ b/util.lisp
@@ -107,33 +107,32 @@
                          expr-sym
                          (cons 'or (cdr expressions))))))))
 
-(%defun* %member (item list)
-  (and list
-       (or (and (eq item (car list)) list)
-           (%member item (cdr list)))))
+(%defun* %reverse-helper (list stack)
+  (if (null list)
+      stack
+      (%reverse-helper (cdr list) (cons (car list) stack))))
 
-(%defmacro* case (object . clauses)
-  (let ((this-clause (car clauses))
-        (rest (cdr clauses))
-        (object-sym (gensym)))
-    (if (null clauses)
-        nil
-        (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)))))))
+(%defun* reverse (list)
+  (%reverse-helper list nil))
+
+(%defun* %append-helper (reversed-list1 list2)
+  (if (null reversed-list1)
+      list2
+      (%append-helper (cdr reversed-list1) (cons (car reversed-list1) list2))))
+
+(%defun* %append-two-lists (list1 list2)
+  (%append-helper (reverse list1) list2))
+
+(%defun* %append (lists)
+  (if (null (cdr lists))
+      (car lists)
+      (let ((first-list (car lists))
+            (second-list (car (cdr lists)))
+            (rest (cdr (cdr lists))))
+        (%append (list* (%append-two-lists first-list second-list) rest)))))
+
+(%defun append lists
+  (%append lists))
 
 (%defmacro* sys::quasiquote (object)
   (if (not (consp object))
@@ -149,6 +148,30 @@
                      (list 'sys::quasiquote (car object))
                      (list 'sys::quasiquote (cdr object)))))))
 
+(%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))
+        (rest (cdr clauses))
+        (object-sym (gensym)))
+    (if (null clauses)
+        nil
+        (if (and (null rest)
+                 (or (eq (car this-clause) t)
+                     (eq (car this-clause) 'otherwise)))
+            `(progn ,@(cdr this-clause))
+            `(let ((,object-sym ,object))
+               (if ,(if (listp (car this-clause))
+                        `(%member ,object-sym
+                                  (quote ,(car this-clause)))
+                        `(eq ,object-sym
+                             (quote ,(car this-clause))))
+                   (progn ,(cdr this-clause))
+                   (case ,object-sym ,@rest)))))))
+
 (%defun* list-eqp (list1 list2)
   "Not really EQUALP (only works on trees of symbols)."
   (if (and (consp list1) (consp list2))
-- 
cgit v1.2.3


From 25fd890df5305b6f6e95ca6524989bf9d41f14bc Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <matthias@benkard.de>
Date: Sat, 26 Jul 2008 20:01:29 +0200
Subject: Add a prototype of DESTRUCTURING-BIND.

---
 util.lisp | 3 +++
 1 file changed, 3 insertions(+)

(limited to 'util.lisp')

diff --git a/util.lisp b/util.lisp
index 13877b2..3a5320d 100644
--- a/util.lisp
+++ b/util.lisp
@@ -194,3 +194,6 @@
           (cons (macroexpand-all (car expansion))
                 (macroexpand-all (cdr expansion))))
         object)))
+
+(%defmacro* unless (test . body)
+  `(if (not ,test) (progn ,@body) nil))
-- 
cgit v1.2.3


From bcde0dca1696a9f9e754d52776700edc83663453 Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <matthias@benkard.de>
Date: Sat, 26 Jul 2008 22:29:43 +0200
Subject: Make the interpreter capable of a restricted form of minimal
 compilation.

---
 util.lisp | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'util.lisp')

diff --git a/util.lisp b/util.lisp
index 3a5320d..08c7d1c 100644
--- a/util.lisp
+++ b/util.lisp
@@ -169,7 +169,7 @@
                                   (quote ,(car this-clause)))
                         `(eq ,object-sym
                              (quote ,(car this-clause))))
-                   (progn ,(cdr this-clause))
+                   (progn ,@(cdr this-clause))
                    (case ,object-sym ,@rest)))))))
 
 (%defun* list-eqp (list1 list2)
-- 
cgit v1.2.3