mes.c: add syntax, quasisyntax to reader....

GNUmakefile

@@ -53,11 +53,20 @@ syntax.test: syntax.mes syntax-test.mes
 guile-syntax: syntax.test
 	guile -s $^
 
+syntax-case: all
+	cat scm.mes syntax.mes syntax-case-lib.mes syntax-case.mes syntax-case-after.mes syntax-case-test.mes | ./mes
+
+syntax-case.test: syntax.mes syntax-case-lib.mes syntax-case.mes syntax-case-after.mes syntax-case-test.mes
+	cat $^ > $@
+
+guile-syntax-case: syntax-case.test
+	guile -s $^
+
 macro: all
 	cat scm.mes macro.mes | ./mes
 
 peg: all
-	cat scm.mes syntax.mes peg.mes peg/codegen.scm peg/string-peg.scm peg/simplify-tree.scm peg/using-parsers.scm peg/cache.scm peg-test.mes | ./mes
+	cat scm.mes syntax.mes syntax-case-lib.mes syntax-case.mes syntax-case-after.mes peg.mes peg/codegen.scm peg/string-peg.scm peg/simplify-tree.scm peg/using-parsers.scm peg/cache.scm peg-test.mes | ./mes
 
 peg.test: peg/pmatch.scm peg.mes peg/codegen.scm peg/string-peg.scm peg/simplify-tree.scm peg/using-parsers.scm peg/cache.scm peg-test.mes
 	cat $^ | sed 's,\(;; Packages the results of a parser\),(when (guile?) (set! compile-peg-pattern (@@ (ice-9 peg codegen) compile-peg-pattern)))\n\1,' > $@
@@ -72,3 +81,5 @@ clean:
 
 record: all
 	cat scm.mes syntax.mes lib/record.mes lib/record.scm lib/srfi/srfi-9.scm record.mes |./mes
+
+

lib/record.mes

@@ -1,6 +1,6 @@
+(define (unspecific) (if #f #f))
 (define make-record make-vector)
 (define record-set! vector-set!)
 (define record? vector?)
 (define (record-type x) (vector-ref x 0))
 (define record-ref vector-ref)
-

mes.c

@@ -92,6 +92,12 @@ scm symbol_quasiquote = {SYMBOL, "quasiquote"};
 scm symbol_unquote = {SYMBOL, "unquote"};
 scm symbol_unquote_splicing = {SYMBOL, "unquote-splicing"};
 
+scm symbol_sc_expand = {SYMBOL, "sc-expand"};
+scm symbol_syntax = {SYMBOL, "syntax"};
+scm symbol_quasisyntax = {SYMBOL, "quasisyntax"};
+scm symbol_unsyntax = {SYMBOL, "unsyntax"};
+scm symbol_unsyntax_splicing = {SYMBOL, "unsyntax-splicing"};
+
 scm symbol_call_with_values = {SYMBOL, "call-with-values"};
 scm symbol_current_module = {SYMBOL, "current-module"};
 scm symbol_define = {SYMBOL, "define"};
@@ -219,6 +225,35 @@ unquote_splicing (scm *x) //int must not add to environment
 scm *unquote_splicing (scm *x);
 scm scm_unquote_splicing = {FUNCTION1, .name="unquote-splicing", .function1=&unquote_splicing};
 
+scm *
+syntax (scm *x)
+{
+  return cons (&symbol_syntax, x);
+}
+
+scm *
+quasisyntax (scm *x)
+{
+  return cons (&symbol_quasisyntax, x);
+}
+
+scm *
+unsyntax (scm *x) //int must not add to environment
+{
+  return cons (&symbol_unsyntax, x);
+}
+scm *unsyntax (scm *x);
+scm scm_unsyntax = {FUNCTION1, .name="unsyntax", .function1=&unsyntax};
+
+scm *
+unsyntax_splicing (scm *x) //int must not add to environment
+{
+  return cons (&symbol_unsyntax_splicing, x);
+}
+scm *unsyntax_splicing (scm *x);
+scm scm_unsyntax_splicing = {FUNCTION1, .name="unsyntax-splicing", .function1=&unsyntax_splicing};
+
+
 //Library functions
 
 // Derived, non-primitives
@@ -316,7 +351,7 @@ eval (scm *e, scm *a)
     scm *y = assq (e, a);
     if (y == &scm_f) {
       //return e;
-      printf ("eval: no such symbol: %s\n", e->name);
+      fprintf (stderr, "eval: no such symbol: %s\n", e->name);
       assert (!"unknown symbol");
     }
     return cdr (y);
@@ -325,6 +360,8 @@ eval (scm *e, scm *a)
     return e;
   else if (atom_p (car (e)) == &scm_t)
     {
+      if ((macro = lookup_macro (car (e), a)) != &scm_f)
+        return eval (apply_env (macro, cdr (e), a), a);
       if (car (e) == &symbol_quote)
         return cadr (e);
       if (car (e) == &symbol_begin)
@@ -351,10 +388,11 @@ eval (scm *e, scm *a)
         return define (e, a);
       if (eq_p (car (e), &symbol_define_macro) == &scm_t)
         return define (e, a);
-      if ((macro = lookup_macro (car (e), a)) != &scm_f)
-        return eval (apply_env (macro, cdr (e), a), a);
       if (car (e) == &symbol_set_x)
         return set_env_x (cadr (e), eval (caddr (e), a), a);
+      if ((macro = assq (&symbol_sc_expand, a)) != &scm_f)
+        if (cdr (macro) != &scm_f)
+          return eval (apply_env (cdr (macro), e, a), a);
     }
   return apply_env (car (e), evlis (cdr (e), a), a);
 }
@@ -668,22 +706,34 @@ lookup (char *x, scm *a)
   if (!strcmp (x, symbol_cond.name)) return &symbol_cond;
   if (!strcmp (x, symbol_current_module.name)) return &symbol_current_module;
   if (!strcmp (x, symbol_lambda.name)) return &symbol_lambda;
+
   if (!strcmp (x, symbol_quasiquote.name)) return &symbol_quasiquote;
   if (!strcmp (x, symbol_quote.name)) return &symbol_quote;
   if (!strcmp (x, symbol_set_x.name)) return &symbol_set_x;
   if (!strcmp (x, symbol_unquote.name)) return &symbol_unquote;
   if (!strcmp (x, symbol_unquote_splicing.name)) return &symbol_unquote_splicing;
 
-  if (!strcmp (x, scm_car.name)) return &scm_car;
+  if (!strcmp (x, symbol_quasisyntax.name)) return &symbol_quasisyntax;
-  if (!strcmp (x, scm_cdr.name)) return &scm_cdr;
+  if (!strcmp (x, symbol_syntax.name)) return &symbol_syntax;
-  if (!strcmp (x, scm_display.name)) return &scm_display;
+  if (!strcmp (x, symbol_set_x.name)) return &symbol_set_x;
-  if (!strcmp (x, scm_builtin_list.name)) return &scm_builtin_list;
+  if (!strcmp (x, symbol_unsyntax.name)) return &symbol_unsyntax;
+  if (!strcmp (x, symbol_unsyntax_splicing.name)) return &symbol_unsyntax_splicing;
 
   if (*x == '\'') return &symbol_quote;
   if (*x == '`') return &symbol_quasiquote;
   if (*x == ',' && *(x+1) == '@') return &symbol_unquote_splicing;
   if (*x == ',') return &symbol_unquote;
 
+  if (!strcmp (x, scm_car.name)) return &scm_car;
+  if (!strcmp (x, scm_cdr.name)) return &scm_cdr;
+  if (!strcmp (x, scm_display.name)) return &scm_display;
+  if (!strcmp (x, scm_builtin_list.name)) return &scm_builtin_list;
+
+  if (*x == '#' && *(x+1) == '\'') return &symbol_syntax;
+  if (*x == '#' && *(x+1) == '`') return &symbol_quasisyntax;
+  if (*x == '#' && *(x+1) == ',' && *(x+2) == '@') return &symbol_unsyntax_splicing;
+  if (*x == '#' && *(x+1) == ',') return &symbol_unsyntax;
+
   return make_symbol (x);
 }
 
@@ -922,7 +972,20 @@ readword (int c, char* w, scm *a)
       && !w) {return cons (lookup_char (c, a),
                                      cons (readword (getchar (), w, a),
                                            &scm_nil));}
-  if (c == ';') {readcomment (c); return readword ('\n', w, a);}
+  if (c == '#' && peekchar () == ',' && !w) {
+    getchar ();
+    if (peekchar () == '@'){getchar (); return cons (lookup ("#,@", a),
+                                                     cons (readword (getchar (), w, a),
+                                                           &scm_nil));}
+    return cons (lookup ("#,", a), cons (readword (getchar (), w, a), &scm_nil));
+  }
+  if (c == '#'
+     && (peekchar () == '\''
+         || peekchar () == '`')
+     && !w) {char buf[3] = "#"; buf[1] = getchar (); return cons (lookup (buf, a),
+                          cons (readword (getchar (), w, a),
+                                &scm_nil));}
+   if (c == ';') {readcomment (c); return readword ('\n', w, a);}
   if (c == '#' && peekchar () == '\\') {getchar (); return readchar ();}
   if (c == '#' && !w && peekchar () == '(') {getchar (); return list_to_vector (readlist (a));}
   if (c == '#' && peekchar () == '(') {ungetchar (c); return lookup (w, a);}
@@ -1120,6 +1183,7 @@ mes_environment ()
   a = cons (cons (&scm_unspecified, &scm_unspecified), a);
   a = cons (cons (&symbol_begin, &symbol_begin), a);
   a = cons (cons (&symbol_quote, &scm_quote), a);
+  a = cons (cons (&symbol_syntax, &scm_syntax), a);
   
 #if MES_FULL
 #include "environment.i"

scm.mes

@@ -196,11 +196,10 @@
         (set! counter (+ counter 1))
         (string->symbol (string-append "g" value))))))
 
+(define else #t)
+
 ;; srfi-1
 (define (last-pair lst)
   (let loop ((lst lst))
     (if (or (null? lst) (null? (cdr lst))) lst
         (loop (cdr lst)))))
-
-(define else #t)
-(define (unspecific) (if #f #f))

test.mes

@@ -21,15 +21,6 @@
 ;; The Maxwell Equations of Software -- John McCarthy page 13
 ;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
 
-;; haha, broken...lat0r
-;; (define result #f)
-;; (let ((pass 0)
-;;       (fail 0))
-;;   (set! result
-;;     (lambda (. t)
-;;       (cond ((null? t) (list pass fail))
-;;             ((car t) (display ": pass") (newline) (set! pass (+ pass 1)))
-;;             (#t (display ": fail") (newline) (set! fail (+ fail 1)))))))
 (define result
   (let ((pass 0)
         (fail 0))