diff --git a/mes.c b/mes.c index 52bcfcd1..d6175f63 100644 --- a/mes.c +++ b/mes.c @@ -37,6 +37,7 @@ #define DEBUG 0 #define MACROS 1 +#define QUASIQUOTE 1 #ifndef QUOTE_SUGAR #define QUOTE_SUGAR 1 @@ -74,7 +75,13 @@ scm scm_label = {ATOM, "label"}; scm scm_unspecified = {ATOM, "*unspecified*"}; scm scm_symbol_cond = {ATOM, "cond"}; scm scm_symbol_quote = {ATOM, "quote"}; +#if QUASIQUOTE +scm scm_symbol_quasiquote = {ATOM, "quasiquote"}; +scm scm_symbol_unquote = {ATOM, "unquote"}; +#endif +#if MACROS scm scm_macro = {ATOM, "*macro*"}; +#endif // PRIMITIVES @@ -147,6 +154,25 @@ quote (scm *x) return cons (&scm_quote, x); } +#if QUASIQUOTE +scm scm_unquote; +scm * +unquote (scm *x) +{ + return cons (&scm_unquote, x); +} + +scm scm_quasiquote; +scm * +quasiquote (scm *x) +{ + return cons (&scm_quasiquote, x); +} + +scm *eval_quasiquote (scm *, scm *); + +#endif + //Library functions scm scm_read; @@ -300,6 +326,21 @@ eval_ (scm *e, scm *a) #endif // MACROS if (car (e) == &scm_symbol_quote) return cadr (e); +#if QUASIQUOTE + else if (car (e) == &scm_symbol_unquote) + return eval (cadr (e), a); + else if (car (e) == &scm_symbol_quasiquote) { +#if DEBUG + printf ("cadr e:"); + display (cadr (e)); + puts (""); + printf ("qq:"); + display (eval_quasiquote (cadr (e), a)); + puts (""); +#endif // DEBUG + return eval_quasiquote (cadr (e), a); + } +#endif // QUASIQUOTE else if (car (e) == &scm_symbol_cond) return evcon (cdr (e), a); #if MACROS @@ -376,6 +417,11 @@ scm scm_null_p = {FUNCTION1, "null", .function1 = &null_p}; scm scm_pair_p = {FUNCTION1, "pair", .function1 = &pair_p}; scm scm_quote = {FUNCTION1, "quote", .function1 = "e}; +#if QUASIQUOTE +scm scm_unquote = {FUNCTION1, "unquote", .function1 = &unquote}; +scm scm_quasiquote = {FUNCTION1, "quasiquote", .function1 = &quasiquote}; +#endif + scm scm_eval = {FUNCTION2, .name="eval", .function2 = &eval}; scm scm_apply = {FUNCTION3, .name="apply", .function3 = &apply}; @@ -481,9 +527,25 @@ lookup (char *x, scm *a) if (!strcmp (x, scm_label.name)) return &scm_label; if (!strcmp (x, scm_nil.name)) return &scm_nil; +#if QUASIQUOTE + if (*x == '`') return &scm_symbol_quasiquote; + 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; +#endif + return make_atom (x); } +scm * +lookup_char (int c, scm *a) +{ + char buf[2]; + buf[0] = c; + buf[1] = 0; + return lookup (buf, a); +} + char * list2str (scm *l) { @@ -535,6 +597,18 @@ display_helper (scm *x, bool cont, char *sep, bool quote) printf ("'"); return display_helper (car (cdr (x)), cont, "", true); } +#if QUASIQUOTE + if (car (x) == &scm_symbol_quasiquote + || car (x) == &scm_quasiquote) { + printf ("`"); + return display_helper (car (cdr (x)), cont, "", true); + } + if (car (x) == &scm_symbol_unquote + || car (x) == &scm_unquote) { + printf (","); + return display_helper (car (cdr (x)), cont, "", true); + } +#endif #endif if (!cont) printf ("("); display (car (x)); @@ -618,7 +692,13 @@ 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 == '\'' && !w) {return cons (lookup ("'", a), + if ((c == '\'' +#if QUASIQUOTE + || c == '`' + || c == ',' +#endif + ) + && !w) {return cons (lookup_char (c, a), cons (readword (getchar (), w, a), &scm_nil));} if (c == ';') {readcomment (c); return readword ('\n', w, a);} @@ -690,6 +770,35 @@ minus (scm *a, scm *b) scm scm_less_p = {FUNCTION2, .name="<", .function2 = &less_p}; scm scm_minus = {FUNCTION2, .name="-", .function2 = &minus}; +#if QUASIQUOTE +scm * +eval_quasiquote (scm *e, scm *a) +{ +#if DEBUG + printf ("\nc:eval_quasiquote e="); + display (e); + if (pair_p (e) == &scm_t) { + printf ("\ncar (e)="); + display (car (e)); + printf (" atom="); + display (atom_p (car (e))); + } + puts (""); +#endif + if (e == &scm_nil) return e; + else if (atom_p (e) == &scm_t) return e; + 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) + return cons (eval (cadar (e), a), &scm_nil); + else if (eq_p (caar (e), &scm_symbol_quote) == &scm_t) + 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)); +} +scm scm_eval_quasiquote = {FUNCTION2, .name="c:eval-quasiquote", .function2 = &eval_quasiquote}; +#endif scm * add_environment (scm *a, char *name, scm* x) @@ -722,6 +831,14 @@ initial_environment () a = add_environment (a, "quote", &scm_quote); a = add_environment (a, "'", &scm_quote); +#if QUASIQUOTE + a = add_environment (a, "quasiquote", &scm_quasiquote); + a = add_environment (a, "unquote", &scm_unquote); + a = add_environment (a, ",", &scm_unquote); + a = add_environment (a, "`", &scm_quasiquote); + a = add_environment (a, "eval-quasiquote", &scm_eval_quasiquote); +#endif + a = add_environment (a, "evlis", &scm_evlis); a = add_environment (a, "evcon", &scm_evcon); a = add_environment (a, "pairlis", &scm_pairlis); diff --git a/mes.mes b/mes.mes index 9911546c..902a93ea 100644 --- a/mes.mes +++ b/mes.mes @@ -124,6 +124,8 @@ ((atom (car e)) (cond ((eq (car e) 'quote) (cadr e)) + ((eq (car e) 'unquote) (eval (cadr e) a)) + ((eq (car e) 'quasiquote) (eval-quasiquote (cadr e) a)) ((eq (car e) 'cond) (evcon (cdr e) a)) ((pair (assoc (car e) (cdr (assoc '*macro* a)))) (c:eval @@ -135,6 +137,18 @@ (#t (apply (car e) (evlis (cdr e) a) a)))) (#t (apply (car e) (evlis (cdr e) a) a)))) +(define (eval-quasiquote e a) + ;; (display 'mes-eval-quasiquote:) + ;; (display e) + ;; (newline) + (cond ((null e) e) + ((atom e) e) + ((atom (car e)) (cons (car e) (eval-quasiquote (cdr e) a))) + ((eq (caar e) 'unquote) (cons (eval (cadar e) a) '())) + ((eq (caar e) 'quote) (cons (cadar e) '())) + ((eq (caar e) 'quasiquote) (cons (cadar e) '())) + (#t (cons (car e) (eval-quasiquote (cdr e) a))))) + ;; readenv et al works, but slows down dramatically (define (DISABLED-readenv a) (readword (getchar) '() a)) diff --git a/test.mes b/test.mes index 05a1672c..51b9342c 100644 --- a/test.mes +++ b/test.mes @@ -124,4 +124,8 @@ (display 'let-dun) (newline) +(define c 'b) +`(aa bb ,c) +(display `(pp qq ,c)) +(newline) '()