tisp

commit dbb4734098491cfd4aa43e698830432a4ff699cf
parent ae26a50533f019d67bd620f6bec0c7703ae3eb8b
Author: Ed van Bruggen <edvb@uw.edu>
Date:   Tue, 31 Dec 2019 01:45:32 -0800

Add basic quasiquote macro

Diffstat:
test.c
 | 
14
++++++++++++++
tibs/lib.tsp
 | 
40
+++++++++++++++++++++++++++++++++-------

2 files changed, 47 insertions(+), 7 deletions(-)
diff --git a/test.c b/test.c
@@ -308,6 +308,20 @@ char *tests[][2] = {
 	{ "(member \"quux\" (list 4.2 3 'quux))",           "()"                             },
 	{ "(member 'qux '(foo bar baz))",                   "()"                             },
 
+	{ "quasiquote",          NULL              },
+	{ "`7.2",                "7.2"             },
+	{ "`cory",               "cory"            },
+	{ "`,foo",               "9"               },
+	{ "`(1 2 3)",            "(1 2 3)"         },
+	{ "`(\"sunnyvale\")",    "(\"sunnyvale\")" },
+	{ "`(1/2 . 2/1)",        "(1/2 . 2)"       },
+	{ "`(cory trevor)",      "(cory trevor)"   },
+	{ "`(foo bar quax)",     "(foo bar quax)"  },
+	{ "`(,foo ,bar)",        "(9 4)"           },
+	{ "`(,foo . ,bar)",      "(9 . 4)"         },
+	{ "`(,foo . ,bar)",      "(9 . 4)"         },
+	{ "`(foo bar ,foo fry)", "(foo bar 9 fry)" },
+
 	{ "stack",                                   NULL                   },
 	{ "(peek '(1 2 3 4 5 6))",                   "1"                    },
 	{ "(peek (list 'a 'b 'c))",                  "a"                    },
diff --git a/tibs/lib.tsp b/tibs/lib.tsp
@@ -85,6 +85,32 @@
           vars)
         (list* proc (map car vars))))
 
+(defmacro (quasiquote x)
+  (define (check x)
+    (unless (and (pair? (cdr x)) (nil? (cddr x)))
+      (error (car x) "invalid form " x)))
+  (define (quasicons a d)
+    (if (pair? d)
+      (if (= (car d) 'quote)
+        (if (and (pair? a) (= (car a) 'quote))
+          (list 'quote (list* (cadr a) (cadr d)))
+          (if (nil? (cadr d))
+            (list 'list a)
+            (list list* a d)))
+        (if (member (car d) '(list list*))
+          (list* (car d) a (cdr d))
+          (list list* a d)))
+      (list list* a d)))
+  (recur f ((x x))
+         (cond
+           ((atom? x) (list 'quote x))
+           ((= (car x) 'unquote)
+            (check x)
+            (cadr x))
+           (else (quasicons (f (car x)) (f (cdr x)))))))
+
+(defmacro (unquote x) (list error ''unquote "called outside of quasiquote"))
+
 ;;; Logic
 (define true t)
 (define false ())
@@ -203,14 +229,14 @@
   (cons val stack))
 
 (defmacro (push! stack val)
-  (list set! stack (list push stack val)))
+  `(set! ,stack (push ,stack ,val)))
 
 (define pop cdr)
 
 (defmacro (pop! stack)
-  (list do0
-        (list peek stack)
-        (list set! stack (list pop stack))))
+  `(do0
+     (peek ,stack)
+     (set! ,stack (pop ,stack))))
 
 (define peek car)
 
@@ -221,9 +247,9 @@
 
 ; TODO swap! use gen sym instead of x and y ?
 (defmacro (swap! stack)
-  (list let (list (list 'x (list pop! stack))
-                  (list 'y (list pop! stack)))
-        (list set! stack (list push (list push stack 'x) 'y))))
+  `(let ((x (pop! ,stack))
+         (y (pop! ,stack)))
+     (set! ,stack (push (push ,stack x) y))))
 
 ;;; Math
 (define pi (* 4 (arctan 1.)))