Add: quasiquote

Author: codybartfast

src/ambeval.c

@@ -67,6 +67,7 @@ static void init(obj execution_environment)
 		"  (cond ((self-evaluating? exp) "
 		"         (analyze-self-evaluating exp))"
 		"        ((quoted? exp) (analyze-quoted exp))"
+		"        ((quasiquote? exp) (analyze (quasi->combination exp)))"
 		"        ((variable? exp) (analyze-variable exp))"
 		"        ((assignment? exp) (analyze-assignment exp))"
 		"        ((definition? exp) (analyze-definition exp))"

src/aneval.c

@@ -263,6 +263,16 @@ static obj is_quoted_p(obj args)
 	return is_quoted(car(args)) ? true_o : false_o;
 }
 
+static obj is_quasiquote_p(obj args)
+{
+	return is_quasiquote(car(args)) ? true_o : false_o;
+}
+
+static obj quasi_to_combination_p(obj args)
+{
+	return quasi_to_combination(car(args));
+}
+
 static obj rest_exps_p(obj args)
 {
 	return rest_exps(car(args));
@@ -403,6 +413,10 @@ void add_primprocs(obj env)
 			of_function(procedure_parameters_p), env);
 	define_variable(of_identifier("quoted?"), of_function(is_quoted_p),
 			env);
+	define_variable(of_identifier("quasiquote?"),
+			of_function(is_quasiquote_p), env);
+	define_variable(of_identifier("quasi->combination"),
+			of_function(quasi_to_combination_p), env);
 	define_variable(of_identifier("rest-exps"), of_function(rest_exps_p),
 			env);
 	define_variable(of_identifier("reverse"), of_function(reverse_p), env);
@@ -454,6 +468,7 @@ static void init(obj execution_environment)
 		"  (cond ((self-evaluating? exp) "
 		"         (analyze-self-evaluating exp))"
 		"        ((quoted? exp) (analyze-quoted exp))"
+		"        ((quasiquote? exp) (analyze (quasi->combination exp)))"
 		"        ((variable? exp) (analyze-variable exp))"
 		"        ((assignment? exp) (analyze-assignment exp))"
 		"        ((definition? exp) (analyze-definition exp))"

src/eceval.c

@@ -268,6 +268,8 @@ obj eceval(obj expression, obj _environment)
 		goto ev_variable;
 	if (is_quoted(expr))
 		goto ev_quoted;
+	if (is_quasiquote(expr))
+		goto ev_quasiquoted;
 	if (is_assignment(expr))
 		goto ev_assignment;
 	if (is_definition(expr))
@@ -316,6 +318,9 @@ obj eceval(obj expression, obj _environment)
 ev_quoted:
 	val = text_of_quotation(expr);
 	goto go_cont;
+ev_quasiquoted:
+	expr = quasi_to_combination(expr);
+	goto eval_dispatch;
 ev_lambda:
 	unev = lambda_parameters(expr);
 	expr = lambda_body(expr);

src/lexer.c

@@ -86,6 +86,14 @@ static enum token_type scan(struct inport *in)
 		sb_addc(sb, '\'');
 		return TKN_QUOTE;
 	}
+	if (c == '`') {
+		sb_addc(sb, '`');
+		return TKN_QUASIQUOTE;
+	}
+	if (c == ',') {
+		sb_addc(sb, ',');
+		return TKN_UNQUOTE;
+	}
 	if (is_peculiar_identifier(c)) {
 		return peculiar(c, in);
 	}

src/lexer.h

@@ -14,7 +14,9 @@ enum token_type {
 	TKN_NUMBER, // 5
 	TKN_STRING, // 6
 	TKN_DOT, // 7
-	TKN_QUOTE // 8
+	TKN_QUOTE, // 8
+	TKN_QUASIQUOTE, // 9
+	TKN_UNQUOTE // 10
 };
 
 struct location {

src/mceval.c

@@ -560,7 +560,57 @@ obj cons_stream_to_cons(obj exp)
 			   delay_to_lambda(list2(delay, caddr(exp)))));
 }
 
+// new - amb
+
 bool is_amb(obj exp)
 {
 	return is_tagged_list(exp, amb);
 }
+
+// new - quasiquoted
+
+static bool is_unquote(obj exp)
+{
+	return is_tagged_list(exp, unquote);
+}
+
+static obj quasi_list(obj lst)
+{
+	obj qlst = emptylst;
+
+	if (is_quasiquote(lst)) {
+		return error_syntax(AREA,
+				    "Nested '`' (quasiquote) is not supported");
+	}
+
+	for (lst = reverse(lst); is_pair(lst); lst = cdr(lst)) {
+		obj item = car(lst);
+		if (is_unquote(item)) {
+			item = cadr(item);
+		} else if (is_pair(item)) {
+			item = quasi_list(item);
+		} else {
+			item = list2(quote, item);
+		}
+		qlst = cons(item, qlst);
+	}
+	return cons(of_identifier("list"), qlst);
+}
+
+static obj quasi_dat(obj dat)
+{
+	if (is_pair(dat)) {
+		return quasi_list(dat);
+	}
+	return list2(quote, dat);
+}
+
+bool is_quasiquote(obj exp)
+{
+	return is_tagged_list(exp, quasiquote);
+}
+
+obj quasi_to_combination(obj exp)
+{
+	return quasi_dat(cadr(exp));
+}

src/mceval.h

@@ -67,4 +67,7 @@ obj cons_stream_to_cons(obj exp);
 
 bool is_amb(obj exp);
 
+bool is_quasiquote(obj exp);
+obj quasi_to_combination(obj exp);
+
 #endif

src/obj.c

@@ -257,9 +257,11 @@ const obj letstar = SYMBOL("let*");
 const obj memo_proc = SYMBOL("memo-proc");
 SYMBOL_VAR(lambda)
 const obj or_s = SYMBOL("or");
+SYMBOL_VAR(quasiquote)
 SYMBOL_VAR(quote)
 const obj set = SYMBOL("set!");
 const obj time_s = SYMBOL("time");
+SYMBOL_VAR(unquote)
 
 // TAGS
 SYMBOL_VAR(procedure)

src/obj.h

@@ -139,9 +139,11 @@ extern const obj letstar;
 extern const obj lambda;
 extern const obj memo_proc;
 extern const obj or_s;
+extern const obj quasiquote;
 extern const obj quote;
 extern const obj set;
 extern const obj time_s;
+extern const obj unquote;
 
 // EVAL TAGS
 extern const obj procedure;

src/parser.c

@@ -21,8 +21,9 @@ obj read(void)
 	return readp(dfltin());
 }
 
-obj read_p(obj args){
-	if(is_err(args = chkarity("read", 0, args)))
+obj read_p(obj args)
+{
+	if (is_err(args = chkarity("read", 0, args)))
 		return args;
 	return read();
 }
@@ -74,7 +75,7 @@ static obj string(struct token *tkn)
 	return of_string(str);
 }
 
-static obj quote_(struct inport *port)
+static obj mark_to_list(struct inport *port, obj keyword, char *msg)
 {
 	obj dat = readp(port);
 	if (is_err(dat))
@@ -86,14 +87,33 @@ static obj quote_(struct inport *port)
 	case TYPE_PAIRPTR:
 	case TYPE_STRING:
 	case TYPE_SYMBOL:
-		return list2(quote, dat);
+		return list2(keyword, dat);
 	default:
-		return error_parser(
-			AREA, "Expected a datum after quote ', but got \"%s\"",
-			errstr(dat));
+		return error_parser(AREA, msg, errstr(dat));
 	}
 }
 
+static obj quote_(struct inport *port)
+{
+	return mark_to_list(
+		port, quote,
+		"Expected a datum after \"'\" (quote), but got \"%s\"");
+}
+
+static obj quasiquote_(struct inport *port)
+{
+	return mark_to_list(
+		port, quasiquote,
+		"Expected a datum after '`' (quasiquote), but got \"%s\"");
+}
+
+static obj unquote_(struct inport *port)
+{
+	return mark_to_list(
+		port, unquote,
+		"Expected a datum after ',' (unquote), but got \"%s\"");
+}
+
 static obj parse_list(obj, struct inport *);
 static obj parse(struct token *tkn, struct inport *port)
 {
@@ -110,6 +130,10 @@ static obj parse(struct token *tkn, struct inport *port)
 		return string(tkn);
 	case TKN_QUOTE:
 		return quote_(port);
+	case TKN_QUASIQUOTE:
+		return quasiquote_(port);
+	case TKN_UNQUOTE:
+		return unquote_(port);
 	case TKN_EOF:
 		return check_eof();
 	default: