Permalink
Browse files

quasiquote support

  • Loading branch information...
1 parent bbf7209 commit 9ca52065ea5d7974425d93a58381170a8d638a72 @cpylua committed Apr 15, 2012
Showing with 177 additions and 1 deletion.
  1. +105 −1 eval.c
  2. +3 −0 gc.c
  3. +48 −0 reader.c
  4. +18 −0 sform.c
  5. +3 −0 sform.h
View
106 eval.c
@@ -35,7 +35,7 @@ static int is_tagged_list(object *exp, object *tag) {
return 0;
}
-/* eval quote */
+/* quote functions */
static int is_quoted(object *exp) {
return is_tagged_list(exp, get_quote_symbol());
}
@@ -44,6 +44,108 @@ static object* eval_quote(object *exp) {
return cadr(exp);
}
+static int is_quasiquote(object *exp) {
+ return is_tagged_list(exp, get_quasiquote_symbol());
+}
+
+static int is_unquote(object *exp) {
+ return is_tagged_list(exp, get_unquote_symbol());
+}
+
+static int is_unquotesplicing(object *exp) {
+ return is_tagged_list(exp, get_unquotesplicing_symbol());
+}
+
+static object* get_last_pair(object *list) {
+ object *rest = list;
+ while (!is_empty_list(cdr(rest))) {
+ rest = cdr(rest);
+ }
+ return rest;
+}
+
+static object* eval_quasiquote_rec(object *exp, object *env, int level, int outmost) {
+ object *obj, *cdr_obj, *car_obj;
+ int unquote_level;
+
+ if (is_pair(exp)) {
+ obj = car(exp);
+ if (is_unquote(obj)) {
+ unquote_level = level - 1;
+ /* unquote only at the same nesting level as the outermost backquote */
+ if (unquote_level == 0) {
+ car_obj = sc_eval(cadr(obj), env);
+ } else {
+ car_obj = eval_quasiquote_rec(obj, env, unquote_level, 0);
+ }
+ gc_protect(car_obj);
+ cdr_obj = eval_quasiquote_rec(cdr(exp), env, level, outmost);
+ gc_protect(cdr_obj);
+ obj = cons(car_obj, cdr_obj);
+ gc_abandon();
+ gc_abandon();
+ return obj;
+ } else if (is_unquotesplicing(obj)) {
+ unquote_level = level - 1;
+ /* unquote only at the same nesting level as the outermost backquote */
+ if (unquote_level == 0) {
+ car_obj = sc_eval(cadr(obj), env);
+ } else {
+ car_obj = eval_quasiquote_rec(obj, env, unquote_level, 0);
+ }
+ gc_protect(car_obj);
+ cdr_obj = eval_quasiquote_rec(cdr(exp), env, level, outmost);
+ gc_abandon();
+ if (is_empty_list(car_obj)) {
+ return cdr_obj;
+ } else {
+ object *last = get_last_pair(car_obj);
+ set_cdr(last, cdr_obj);
+ return car_obj;
+ }
+ } else if (is_quasiquote(obj)) {
+ car_obj = eval_quasiquote_rec(obj, env, level+1, 0);
+ gc_protect(car_obj);
+ cdr_obj = eval_quasiquote_rec(cdr(exp), env, level, outmost);
+ gc_protect(cdr_obj);
+ obj = cons(car_obj, cdr_obj);
+ gc_abandon();
+ gc_abandon();
+ return obj;
+ } else {
+ /* handle improper list special case */
+ /* e.g `(1 . ,(+ 1 2)) */
+ if (obj == get_unquote_symbol() && level == 1 && outmost) {
+ obj = cadr(exp);
+ if (obj == NULL) {
+ return exp;
+ }
+ return sc_eval(obj, env);
+ } else if (obj == get_unquotesplicing_symbol() && level == 1 && outmost) {
+ obj = cadr(exp);
+ if (obj == NULL) {
+ return exp;
+ }
+ return sc_eval(obj, env);
+ } else {
+ car_obj = eval_quasiquote_rec(obj, env, level, 0);
+ gc_protect(car_obj);
+ cdr_obj = eval_quasiquote_rec(cdr(exp), env, level, outmost);
+ gc_protect(cdr_obj);
+ obj = cons(car_obj, cdr_obj);
+ gc_abandon();
+ gc_abandon();
+ return obj;
+ }
+ }
+ }
+ return exp;
+}
+
+static object* eval_quasiquote(object *exp, object *env) {
+ return eval_quasiquote_rec(cadr(exp), env, 1, 1);
+}
+
/* assignment functions */
static int is_assignment(object *exp) {
return is_tagged_list(exp, get_set_symbol());
@@ -678,6 +780,8 @@ object* sc_eval(object *exp, object *env) {
val = eval_variable(exp, env);
} else if (is_quoted(exp)) {
val = eval_quote(exp);
+ } else if (is_quasiquote(exp)) {
+ val = eval_quasiquote(exp, env);
} else if (is_assignment(exp)) {
val = eval_assignment(exp, env);
} else if (is_definition(exp)) {
View
3 gc.c
@@ -355,6 +355,9 @@ static void mark_stack_root(stack_elem elem) {
static void mark_sform(void) {
mark_active(get_quote_symbol());
+ mark_active(get_quasiquote_symbol());
+ mark_active(get_unquote_symbol());
+ mark_active(get_unquotesplicing_symbol());
mark_active(get_set_symbol());
mark_active(get_define_symbol());
mark_active(get_nrv_symbol());
View
@@ -476,6 +476,50 @@ static object* parse_quote_form(FILE *in) {
return obj;
}
+static int is_quasiquote_start(int c) {
+ return c == '`';
+}
+
+static object* parse_quasiquote_form(FILE *in) {
+ object *quasiquote, *obj, *cdr_obj;
+
+ cdr_obj = sc_read(in);
+ if (cdr_obj == NULL) {
+ obj = NULL;
+ } else {
+ quasiquote = get_quasiquote_symbol();
+ gc_protect(cdr_obj);
+ obj = cons(quasiquote, cons(cdr_obj, get_empty_list()));
+ gc_abandon();
+ }
+ return obj;
+}
+
+static int is_unquote_start(int c) {
+ return c == ',';
+}
+
+static object* parse_unquote_form(FILE *in) {
+ int c = peek(in);
+ object *unquote, *obj, *cdr_obj;
+
+ if (c == '@') {
+ unquote = get_unquotesplicing_symbol();
+ getc(in);
+ } else {
+ unquote = get_unquote_symbol();
+ }
+ cdr_obj = sc_read(in);
+ if (cdr_obj == NULL) {
+ obj = NULL;
+ } else {
+ gc_protect(cdr_obj);
+ obj = cons(unquote, cons(cdr_obj, get_empty_list()));
+ gc_abandon();
+ }
+ return obj;
+}
+
int is_vector_start(int c, int ahead) {
return c == '#' && ahead == '(';
}
@@ -556,6 +600,10 @@ object* sc_read(FILE *in) {
obj = parse_symbol(in);
} else if (is_quote_start(c)) {
obj = parse_quote_form(in);
+ } else if (is_quasiquote_start(c)) {
+ obj = parse_quasiquote_form(in);
+ } else if (is_unquote_start(c)) {
+ obj = parse_unquote_form(in);
} else if (c == EOF) {
obj = get_eof_object();
} else {
View
18 sform.c
@@ -3,6 +3,9 @@
#include "sform.h"
static object *g_quote_symbol;
+static object *g_quasiquote_symbol;
+static object *g_unquote_symbol;
+static object *g_unquotesplicing_symbol;
static object *g_set_symbol;
static object *g_define_symbol;
static object *g_nrv_symbol; /* No Return Value symbol */
@@ -42,6 +45,9 @@ int sform_init(void) {
DEFINE_SYMBOL(g_or_symbol, "or");
DEFINE_SYMBOL(g_callwcc_symbol, "call-with-current-continuation");
DEFINE_SYMBOL(g_definemacro_symbol, "define-macro");
+ DEFINE_SYMBOL(g_quasiquote_symbol, "quasiquote");
+ DEFINE_SYMBOL(g_unquote_symbol, "unquote");
+ DEFINE_SYMBOL(g_unquotesplicing_symbol, "unquote-splicing");
return 0;
}
@@ -102,3 +108,15 @@ object* get_definemacro_symbol(void) {
return g_definemacro_symbol;
}
+object* get_quasiquote_symbol(void) {
+ return g_quasiquote_symbol;
+}
+
+object* get_unquote_symbol(void) {
+ return g_unquote_symbol;
+}
+
+object* get_unquotesplicing_symbol(void) {
+ return g_unquotesplicing_symbol;
+}
+
View
@@ -6,6 +6,9 @@
int sform_init(void);
object* get_quote_symbol(void);
+object* get_quasiquote_symbol(void);
+object* get_unquote_symbol(void);
+object* get_unquotesplicing_symbol(void);
object* get_set_symbol(void);
object* get_define_symbol(void);
object* get_if_symbol(void);

0 comments on commit 9ca5206

Please sign in to comment.