tisp

commit c245f59b0d0a07317361074049f6cb4a28441523
parent 99d76c4b1c33899c5de4e2aaad12d602381dcd21
Author: Ed van Bruggen <edvb@uw.edu>
Date:   Tue, 27 Oct 2020 22:14:05 -0700

Implment unquote-splice

Diffstat:
tib/core.tsp
 | 
60
+++++++++++++++++++++++++++++++++++++++++++++++-------------
tib/doc.tsp
 | 
4
+++-
tisp.c
 | 
27
+++++++++++++--------------
tisp.h
 | 
1
+

4 files changed, 64 insertions(+), 28 deletions(-)
diff --git a/tib/core.tsp b/tib/core.tsp
@@ -127,10 +127,16 @@
                  body)))
 
 ; TODO allow for improper lists
-(defmacro (quasiquote x)
-  (def (check x)
-    (unless (and (pair? (cdr x)) (nil? (cddr x)))
-      (error (car x) "invalid form " x)))
+; TODO `(0 ,@1) => (0 . 1)
+(defmacro (quasiquote expr)
+  "Recursively quote the given expression
+  Automatically quotes each element in the expression, but evaluates the
+  element if it is labeled with the unquoted macro.
+  Can be shortened with the ` prefix.
+  Also see quote, unquote, and unquote-splice"
+  (def (check form)
+    (unless (and (pair? (cdr form)) (nil? (cddr form)))
+      (error (car form) "invalid form " form)))
   (def (quasicons a d)
     (if (pair? d)
       (if (= (car d) 'quote)
@@ -143,15 +149,43 @@
           (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"))
+  (recur f ((expr expr) (n 0))
+    (cond
+      ((atom? expr) (list 'quote expr))
+      ((= (car expr) 'quasiquote)
+       (check expr)
+       (quasicons ''quasiquote (f (cdr x) (+ n 1))))
+      ((= (car expr) 'unquote)
+       (check expr)
+       (if (= n 0)
+         (cadr expr)
+         (quasicons ''unquote (f (cdr expr) (- n 1)))))
+      ((= (car expr) 'unquote-splice)
+       (check expr)
+       (if (= n 0)
+         (error 'unquote-splice "invalid context for " (cadr expr))
+         (quasicons ''unquote-splice (f (cdr expr) (- n 1)))))
+      ((and (= n 0) (and (pair? (car expr)) (= (caar expr) 'unquote-splice)))
+       (check (car expr))
+       (let ((d (f (cdr expr) n)))
+         (if (= d '(quote nil))
+           (cadar expr)
+           (list 'append (cadar expr) d))))
+      (else (quasicons (f (car expr) n) (f (cdr expr) n))))))
+
+(defmacro (unquote expr)
+  "Unquote expression so its evaluated before placed into the quasiquote
+  Can be shortened with the , prefix
+  Errors if called outside quasiquote
+  Also see quote, unquote, and unquote-splice"
+  (error 'unquote "called outside of quasiquote"))
+(defmacro (unquote-splice expr)
+  "Unquote and splice the expression into the quasiquote
+  If the value evaluated is a list, embedded each element into the quasiquote
+  Can be shortened with the ,@ prefix
+  Errors if called outside a quasiquote of a list
+  Also see quote, unquote, and unquote-splice"
+  (error 'unquote-splice "called outside of quasiquote"))
 
 ;;; Logic
 
diff --git a/tib/doc.tsp b/tib/doc.tsp
@@ -10,7 +10,9 @@
       "Create new pair with a car of a and cdr of d")
     (quote
       "(quote expr)"
-      "Return expression unevaluated")
+      "Return expression unevaluated"
+      "  Can be shortened with the ' prefix"
+      "  Also see quote, unquote, and unquote-splice")
     (Void
       "(Void)"
       "Return nothing"
diff --git a/tisp.c b/tisp.c
@@ -559,33 +559,32 @@ Val
 tisp_read(Tsp st)
 {
 	char *shorthands[] = {
-		"'", "quote",
-		"`", "quasiquote",
-		",", "unquote",
+		"'",  "quote",
+		"`",  "quasiquote",
+		",@", "unquote-splice", /* always check before , */
+		",",  "unquote",
 	};
 	skip_ws(st, 1);
-	if (strlen(st->file+st->filec) == 0)
+	if (strlen(st->file+st->filec) == 0) /* empty list */
 		return st->none;
-	if (isnum(st->file+st->filec))
+	if (isnum(st->file+st->filec)) /* number */
 		return read_num(st);
 	/* TODO support | for symbols */
-	if (tsp_fget(st) == '"')
+	if (tsp_fget(st) == '"') /* strings */
 		return read_str(st);
-	for (int i = 0; i < LEN(shorthands); i += 2) {
-		if (tsp_fget(st) == *shorthands[i]) {
+	for (int i = 0; i < LEN(shorthands); i += 2) { /* character prefixes */
+		if (!strncmp(st->file+st->filec, shorthands[i], strlen(shorthands[i]))) {
 			Val v;
-			tsp_finc(st);
+			tsp_fincn(st, strlen(shorthands[i]));
 			if (!(v = tisp_read(st)))
 				return NULL;
 			return mk_list(st, 2, mk_sym(st, shorthands[i+1]), v);
 		}
 	}
-	if (issym(tsp_fget(st)))
+	if (issym(tsp_fget(st))) /* symbols */
 		return read_sym(st);
-	if (tsp_fget(st) == '(') {
-		tsp_finc(st);
-		return read_pair(st);
-	}
+	if (tsp_fget(st) == '(')
+		return tsp_finc(st), read_pair(st, ')');
 	tsp_warnf("could not read given input '%c'", st->file[st->filec]);
 }
 
diff --git a/tisp.h b/tisp.h
@@ -57,6 +57,7 @@
 #define tsp_include_tib(NAME)       void tib_env_##NAME(Tsp)
 
 #define tsp_finc(ST) ST->filec++
+#define tsp_fincn(ST, N) ST->filec += N
 #define tsp_fgetat(ST, O) ST->file[ST->filec+O]
 #define tsp_fget(ST) tsp_fgetat(ST,0)