implement unquote-splicing, cleanup some macros

mes.c

@@ -92,6 +92,7 @@ scm scm_symbol_quote = {SYMBOL, "quote"};
 #if QUASIQUOTE
 scm scm_symbol_quasiquote = {SYMBOL, "quasiquote"};
 scm scm_symbol_unquote = {SYMBOL, "unquote"};
+scm scm_symbol_unquote_splicing = {SYMBOL, "unquote-splicing"};
 #endif
 #if MACROS
 scm scm_macro = {SYMBOL, "*macro*"};
@@ -200,6 +201,12 @@ quote (scm *x)
 }
 
 #if QUASIQUOTE
+scm *
+quasiquote (scm *x)
+{
+  return cons (&scm_symbol_quasiquote, x);
+}
+
 scm *
 unquote (scm *x)
 {
@@ -207,9 +214,9 @@ unquote (scm *x)
 }
 
 scm *
-quasiquote (scm *x)
+unquote_splicing (scm *x)
 {
-  return cons (&scm_symbol_quasiquote, x);
+  return cons (&scm_symbol_unquote_splicing, x);
 }
 #endif
 
@@ -674,9 +681,11 @@ lookup (char *x, scm *a)
 
 #if QUASIQUOTE
   if (*x == '`') return &scm_symbol_quasiquote;
+  if (*x == ',' && *(x+1) == '@') return &scm_symbol_unquote_splicing;
   if (*x == ',') return &scm_symbol_unquote;
-  if (!strcmp (x, scm_symbol_unquote.name)) return &scm_symbol_unquote;
   if (!strcmp (x, scm_symbol_quasiquote.name)) return &scm_symbol_quasiquote;
+  if (!strcmp (x, scm_symbol_unquote.name)) return &scm_symbol_unquote;
+  if (!strcmp (x, scm_symbol_unquote_splicing.name)) return &scm_symbol_unquote_splicing;
 #endif
 
   return make_symbol (x);
@@ -798,6 +807,10 @@ display_helper (scm *x, bool cont, char *sep, bool quote)
       printf (",");
       return display_helper (car (cdr (x)), cont, "", true);
     }
+    if (car (x) == &scm_unquote_splicing) {
+      printf (",@");
+      return display_helper (car (cdr (x)), cont, "", true);
+    }
 #endif
 #endif
     if (!cont) printf ("(");
@@ -885,6 +898,9 @@ readword (int c, char* w, scm *a)
   if (c == '(') {ungetchar (c); return lookup (w, a);}
   if (c == ')' && !w) {ungetchar (c); return &scm_nil;}
   if (c == ')') {ungetchar (c); return lookup (w, a);}
+  if (c == ',' && peekchar () == '@') {getchar (); return cons (lookup (",@", a),
+                                                                cons (readword (getchar (), w, a),
+                                                                      &scm_nil));}
   if ((c == '\''
 #if QUASIQUOTE
        || c == '`'
@@ -976,7 +992,15 @@ readlist (scm *a)
 scm *
 readenv (scm *a)
 {
+#if DEBUG
+  scm *e = readword (getchar (), 0, a);
+  printf ("readenv: ");
+  display (e);
+  puts ("");
+  return e;
+#else
   return readword (getchar (), 0, a);
+#endif
 }
 
 // Extras to make interesting program
@@ -1086,15 +1110,17 @@ eval_quasiquote (scm *e, scm *a)
 #endif
   if (e == &scm_nil) return e;
   else if (atom_p (e) == &scm_t) return e;
+  else if (eq_p (car (e), &scm_symbol_quote) == &scm_t)
+    return e;
+  else if (eq_p (car (e), &scm_symbol_quasiquote) == &scm_t)
+    return cons (e, eval_quasiquote (cdr (e), a));
+  else if (eq_p (car (e), &scm_symbol_unquote) == &scm_t)
+    return eval (cadr (e), a);
   else if (atom_p (car (e)) == &scm_t)
     return cons (car (e), eval_quasiquote (cdr (e), a));
-  else if (eq_p (caar (e), &scm_symbol_unquote) == &scm_t)
+  else if (eq_p (caar (e), &scm_symbol_unquote_splicing) == &scm_t)
-    return cons (eval (cadar (e), a), &scm_nil);
+      return append2 (eval_ (cadar (e), a), eval_quasiquote (cdr (e), a));
-  else if (eq_p (caar (e), &scm_symbol_quote) == &scm_t)
+  return cons (eval_quasiquote (car (e), a), eval_quasiquote (cdr (e), a));
-    return cons (cadar (e), &scm_nil);
-  else if (eq_p (caar (e), &scm_symbol_quasiquote) == &scm_t)
-    return cdar (e);
-  return cons (car (e), eval_quasiquote (cdr (e), a));
 }
 #endif
 

scm.mes

@@ -21,6 +21,16 @@
 ;; The Maxwell Equations of Software -- John McCarthy page 13
 ;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
 
+(define (list . rest) rest)
+
+(define-macro (begin . rest)
+  `((lambda () ,@rest)))
+
+(define (vector . rest) (list->vector rest))
+
+(define (apply f args)
+  (c:eval (cons f args) (current-module)))
+
 (define (defined? x)
   (assq x (current-module)))
 
@@ -29,8 +39,6 @@
         ((pair? p) (eq? (car p) 'lambda))
         (#t #f)))
 
-(define (list . rest) rest)
-(define (vector . rest) (list->vector rest))
 (define assv assq)
 (define (memq x lst)
   (cond ((null? lst) #f)
@@ -39,10 +47,10 @@
 (define memv memq)
 
 (define-macro (or x y)
-  (list 'cond (list x x) (list #t y)))
+  `(cond (,x ,x) (#t ,y)))
 
 (define-macro (and x y)
-  (list 'cond (list x y) (list #t #f)))
+  `(cond (,x ,y) (#t #f)))
 
 (define (split-params bindings params)
   (cond ((null? bindings) params)
@@ -80,19 +88,14 @@
   (cond (x #f)
         (#t #t)))
 
-(define-macro (if expr then else)
+(define-macro (if expr then . else)
-  (list 'cond
+  `(cond
-        (list expr then)
+    (,expr ,then)
-        (list #t else)))
+    (#t (cond (,(pair? else) ((lambda () ,@else)))))))
 
-;;TODO
+(define-macro (when expr . body)
-(define-macro (iif expr then . else)
+  `(if ,expr
-  (list 'cond
+       ((lambda () ,@body))))
-        (list expr then)
-        (list #t
-              (list 'cond
-                    (list (list 'pair? else) (list 'car else))
-                    (list #t '*unspecified*)))))
 
 (define (unspecified-bindings bindings params)
   (cond ((null? bindings) params)
@@ -111,8 +114,3 @@
                     (append (letrec-setters bindings '())
                             body)))  )
 
-(define (begin . rest)
-  (let () rest))
-
-(define (apply f args)
-  (c:eval (cons f args) (current-module)))

syntax.mes

@@ -1,18 +1,18 @@
 
-(display "define-syntax...")
+;; (display "define-syntax...")
 
-(define-macro define-syntax
+;; (define-macro define-syntax
-  (lambda (form expander)
+;;   (lambda (form expander)
-    (expander `(define-macro ,(cadr form)
+;;     (expander `(define-macro ,(cadr form)
-                 (let ((transformer ,(caddr form)))
+;;                  (let ((transformer ,(caddr form)))
-                   (lambda (form expander)
+;;                    (lambda (form expander)
-                     (expander (transformer form
+;;                      (expander (transformer form
-                                            (lambda (x) x)
+;;                                             (lambda (x) x)
-                                            eq?)
+;;                                             eq?)
-                               expander))))
+;;                                expander))))
-              expander)))
+;;               expander)))
 
-(newline)
+;; (newline)
 
 (display "define-syntax when...")
 
@@ -27,68 +27,29 @@
 ;;        (begin ,exp . ,rest)))
 
 
-(define-macro (when clause . rest)
-  (cond
-   ((not (eq? clause #f)) (cons 'let (cons '() rest)))))
-
-(define-macro (ifwhen clause . rest)
-  (if (not (eq? clause #f)) (cons 'let (cons '() rest))))
-
-(define-macro my-when
-  (lambda (test . branch)
-    (list 'if test (cons 'begin branch))))
-
-;; (define-macro (q-when test . branch)
-;;   `(if ,test
-;;        (begin ,@branch)))
-
-;; (define-macro (when clause exp . rest)
-;;   (display "all=")
-;;   (display  (cons exp rest))
-;;   (newline)
-;;   `(if ,clause
-;;        (begin ,(cons exp rest))))
-
 ;; (define-macro (when clause . rest)
-;;   (cond
+;;   (list 'cond (list clause (list 'let '() rest))))
-;;    ((not (eq? clause #f)) (cons 'let (cons '() rest)))))
+
+
+(define-macro (when expr . body)
+  `(if ,expr
+       ((lambda () ,@body))
+       'bah))
 
 (newline)
 
-(ifwhen #t
+(when #t
   (display "true")
   (newline))
 
-(ifwhen #f
+(when #t
-  (display "false")
+  (display "q-when")
   (newline)
   '())
 
-(my-when #t
-  (display "my-when")
-  (newline)
-  '())
-
-
-;; (q-when #t
-;;   (display "q-when")
-;;   (newline)
-;;   '())
-
-
 (define *gensym* 0)
 (define (gensym)
   (set! *gensym* (+ *gensym* 1))
   (string->symbol (string-append "g" (number->string *gensym*))))
 
-(define-macro bla (gensym))
-
-(display bla) (newline)
-(display bla) (newline)
-(display bla) (newline)
-
 (newline)
-'()
-
-;;EOF
-EOF2

test.mes

@@ -137,7 +137,7 @@
 (display (= 3 '3))
 (newline)
 
-(display (if #t 'true 'FIXME))
+(display (if #t 'true))
 (newline)
 (display (if (eq? 0 '0) 'true 'false))
 (newline)
@@ -280,4 +280,29 @@
 (display (gensym))
 (newline)
 
+(display "unquote:")
+(display `,(list 1 2 3 4))
+(newline)
+
+(display `('boo ,@'(bah baz) 1 2))
+(newline)
+
+(display "splice:")
+(display `(1 ,@(list 2 3) 4))
+(newline)
+
+(define s-r '(2 3))
+(display "splice:")
+(display `(1 ,@s-r 4))
+(newline)
+
+(display "when:")
+(when #t
+  (display "true")
+  (newline))
+
+(when #f
+  (display "must not see")
+  (newline))
+
 '()