Wip: add ambeval2

Author: codybartfast

src/ambeval.c

@@ -1,11 +1,13 @@
 #include "ambeval.h"
 
-#define AREA "EVAL"
+#define AREA "AMBEVAL"
 
 #include "aneval.h"
 #include "eceval.h"
 #include "environment.h"
+#include "error.h"
 #include "list.h"
+#include "mceval.h"
 #include "parser.h"
 #include "storage.h"
 
@@ -153,8 +155,10 @@ static void init(obj execution_environment)
 		ambenv);
 }
 
-obj ambeval(obj exp, obj exenv)
+static obj ambeval(obj exp, obj exenv, obj succeed, obj fail)
 {
+	(void)succeed, (void)fail;
+
 	static bool haveinit = false;
 
 	bool orig_gc = disable_gc;
@@ -176,3 +180,19 @@ obj ambeval(obj exp, obj exenv)
 
 	return eceval(analyze_execute, exenv);
 }
+
+obj ambeval2(obj exp, obj exenv)
+{
+	obj value = of_identifier("value");
+	obj fail_s = of_identifier("fail");
+	obj succeed =
+		make_procedure(list2(value, fail_s), list1(value), emptylst);
+	obj fail = make_procedure(
+		emptylst,
+		list2(list2(of_identifier("display"),
+			    of_string(
+				    "ERROR: (AMBEVAL) unexpected call to amb2's fail")),
+		      failed),
+		emptylst);
+	return ambeval(exp, exenv, succeed, fail);
+}

src/ambeval.h

@@ -4,6 +4,6 @@
 
 #include "obj.h"
 
-obj ambeval(obj exp, obj env);
+obj ambeval2(obj exp, obj env);
 
 #endif

src/aneval.c

@@ -1,6 +1,6 @@
 #include "aneval.h"
 
-#define AREA "EVAL"
+#define AREA "ANEVAL"
 
 #include "eceval.h"
 #include "environment.h"

src/error.c

@@ -7,6 +7,14 @@
 
 #define AREA "ERROR"
 
+#define OBJ_4(TYPE, STYPE, VTYPE, VALUE)                                       \
+	{                                                                      \
+		TYPE, STYPE,                                                   \
+		{                                                              \
+			.VTYPE = VALUE                                         \
+		}                                                              \
+	}
+
 enum errsbtyp {
 	ERROR_MEMORY = 1,
 	ERROR_ARGUMENT_TYPE, // 2

src/eval.c

@@ -6,11 +6,12 @@
 
 obj (*eval)(obj, obj) = eceval;
 
-void use_ambeval(void){
-	eval = ambeval;
+void use_ambeval(void)
+{
+	eval = ambeval2;
 }
 
-void use_aneval(void){
+void use_aneval(void)
+{
 	eval = aneval;
 }
-

src/obj.c

@@ -249,14 +249,15 @@ obj (*to_function(obj dat))(obj)
 const obj and_s = SYMBOL("and");
 SYMBOL_VAR(uapply)
 const obj __ppapply = SYMBOL("__%%apply");
+const obj arrow = SYMBOL("=>");
 SYMBOL_VAR(begin)
 SYMBOL_VAR(cond)
 const obj cons_s = SYMBOL("cons");
 const obj cons_stream = SYMBOL("cons-stream");
 SYMBOL_VAR(define)
 SYMBOL_VAR(delay)
 const obj else_s = SYMBOL("else");
-const obj arrow = SYMBOL("=>");
+SYMBOL_VAR(failed)
 const obj if_s = SYMBOL("if");
 SYMBOL_VAR(let)
 SYMBOL_VAR(letrec)

src/obj.h

@@ -114,14 +114,15 @@ obj (*to_function(obj dat))(obj);
 extern const obj and_s;
 extern const obj uapply;
 extern const obj __ppapply;
+extern const obj arrow;
 extern const obj begin;
 extern const obj cond;
 extern const obj cons_s;
 extern const obj cons_stream;
 extern const obj define;
 extern const obj delay;
 extern const obj else_s;
-extern const obj arrow;
+extern const obj failed;
 extern const obj if_s;
 extern const obj let;
 extern const obj letrec;