Fix reducing bigtime

2 files changed, 112 insertions, 56 deletions

diff --git a/environment.cpp b/environment.cpp
index e36031b..3ca55b1 100644
--- a/environment.cpp
+++ b/environment.cpp
@@ -153,6 +153,44 @@ static void singlify(AST &ast){
 	}
 }
 
+bool Environment::resolve(AST &ast){
+	if(ast.quoted){
+		return false;
+	}
+
+	bool ret=false;
+
+	switch(ast.type){
+		case AST::Type::number:
+		case AST::Type::string:
+		case AST::Type::index:
+		case AST::Type::native:
+			break;
+
+		case AST::Type::name:
+			try {
+				ast=get(ast.nameval);
+				resolve(ast);
+				ret=true;
+			} catch(NameError){
+				// just leave an unknown name as it is
+			}
+			break;
+
+		case AST::Type::tuple:
+			for(AST &term : ast.terms){
+				ret=resolve(term)||ret;
+			}
+			break;
+
+		case AST::Type::lambda:
+			ret=resolve(*ast.lambdaval.body)||ret;
+			break;
+	}
+
+	return ret;
+}
+
 
 AST Environment::run(const AST &astinput){
 	AST ast(astinput);
@@ -160,10 +198,6 @@ AST Environment::run(const AST &astinput){
 #ifdef DEBUG
 	cerr<<"indexify gave "<<ast<<endl;
 #endif
-	singlify(ast);
-#ifdef DEBUG
-	cerr<<"singlify gave "<<ast<<endl;
-#endif
 	reduce(ast);
 	return ast;
 }
@@ -283,6 +317,9 @@ bool Environment::betareduce(AST &ast,i64 depth){
 	if(ast.terms.size()!=2){
 		return false;
 	}
+	if(ast.terms[0].type!=AST::Type::lambda){
+		return false;
+	}
 
 #ifdef DEBUG
 	cerr<<indent(depth)<<"Betareducing "<<ast<<endl;
@@ -290,37 +327,25 @@ bool Environment::betareduce(AST &ast,i64 depth){
 
 	bool success;
 
-	if(ast.terms[0].type==AST::Type::lambda){
-		// cerr<<"=== β-REDUCE LAMBDA ==="<<endl;
-		// cerr<<"ast = "<<ast<<endl;
-		AST newterm=*ast.terms[0].lambdaval.body;
-		ast.terms[0]=newterm;
-		// cerr<<"ast = "<<ast<<endl;
-
-		vector<pair<AST*,Index>> repl;
-		recursiveFindLevel(ast.terms[0],1,repl);
-		// cerr<<"Level 2:"; for(i64 i=0;i<(i64)repl.size();i++)cerr<<" {"<<*repl[i].first<<','<<repl[i].second<<'}'; cerr<<endl;
-
-		increaseFree(ast.terms[0],-1,2);
-		
-		for(const pair<AST*,Index> &p : repl){
-			*p.first=ast.terms[1];
-			increaseFree(*p.first,p.second-1,1);
-		}
-		newterm=ast.terms[0];
-		ast=newterm;
-		success=true;
-	} else if(ast.terms[0].type==AST::Type::native){
-		reduce(ast.terms[1],depth+1);
-		ast=ast.terms[0].nativeval(ast.terms[1]);
-		success=true;
-	} else if(ast.terms[0].type==AST::Type::name&&ast.terms[0].nameval=="do"){
-		reduce(ast.terms[1],depth+1);
-		ast=ast.terms[0];
-		success=true;
-	} else {
-		success=false;
+	// cerr<<"=== β-REDUCE LAMBDA ==="<<endl;
+	// cerr<<"ast = "<<ast<<endl;
+	AST newterm=*ast.terms[0].lambdaval.body;
+	ast.terms[0]=newterm;
+	// cerr<<"ast = "<<ast<<endl;
+
+	vector<pair<AST*,Index>> repl;
+	recursiveFindLevel(ast.terms[0],1,repl);
+	// cerr<<"Level 2:"; for(i64 i=0;i<(i64)repl.size();i++)cerr<<" {"<<*repl[i].first<<','<<repl[i].second<<'}'; cerr<<endl;
+
+	increaseFree(ast.terms[0],-1,2);
+
+	for(const pair<AST*,Index> &p : repl){
+		*p.first=ast.terms[1];
+		increaseFree(*p.first,p.second-1,1);
 	}
+	newterm=ast.terms[0];
+	ast=newterm;
+	success=true;
 
 #ifdef DEBUG
 	cerr<<indent(depth)<<"'=> "<<ast<<endl;
@@ -339,14 +364,16 @@ static bool etareduce(AST &ast){
 }
 
 
-void Environment::reduce(AST &ast,i64 depth){
+bool Environment::reduce(AST &ast,i64 depth){
 #ifdef DEBUG
 	cerr<<indent(depth)<<"Reducing "<<ast<<endl;
 #endif
 	if(ast.quoted){
-		return;
+		return false;
 	}
 
+	bool ret=false;
+
 	switch(ast.type){
 		case AST::Type::number:
 		case AST::Type::string:
@@ -355,34 +382,51 @@ void Environment::reduce(AST &ast,i64 depth){
 			break;
 
 		case AST::Type::name:
-			if(ast.nameval!="do"){
-				ast=get(ast.nameval);
-				indexify(ast);
-			}
+			ret=resolve(ast);
 			break;
 
 		case AST::Type::lambda:
-			reduce(*ast.lambdaval.body,depth+1);
-			etareduce(ast);
+			ret=reduce(*ast.lambdaval.body,depth+1);
+			ret=etareduce(ast)||ret;
 			break;
 
 		case AST::Type::tuple:
-			// reduce(ast.terms[0],depth+1);
-			// reduce(ast.terms[1],depth+1); // TODO: this is dodgy
-			// while(betareduce(ast,depth+1)){}
-			do {
-				reduce(ast.terms[0],depth+1);
-				if(!betareduce(ast,depth+1)){
-					break;
+			if(ast.terms.size()==0){
+				break;
+			}
+			if(ast.terms.size()==1){
+				AST newast=ast.terms[0];
+				ast=newast;
+				ret=true;
+				break;
+			}
+			if(ast.terms.size()>2){
+				singlify(ast);
+			}
+			ret=reduce(ast.terms[0],depth+1);
+			if(ast.terms[0].type==AST::Type::lambda){
+				bool brret=betareduce(ast,depth+1);
+				ret=ret||brret;
+				if(brret){
+					ret=reduce(ast,depth+1)||ret;
+				}
+			} else if(ast.terms[0].type==AST::Type::native){
+#ifdef DEBUG
+				cerr<<indent(depth+1)<<"Preparation for native call, reducing argument"<<endl;
+#endif
+				ret=reduce(ast.terms[1],depth+1)||ret;
+				if(!hasFree(ast.terms[1],1)){
+					ast=ast.terms[0].nativeval(ast.terms[1]);
+					ret=true;
+				} else {
+					cerr<<indent(depth+1)<<"Argument contained free indices, not calling"<<endl;
 				}
-			} while(ast.type==AST::Type::tuple&&ast.terms.size()>0);
-			if(ast.type==AST::Type::name){
-				// TODO: this is really dodgy; why is this necessary?
-				reduce(ast,depth+1);
 			}
 			break;
 	}
+
 #ifdef DEBUG
-	cerr<<indent(depth)<<"'-> "<<ast<<endl;
+	cerr<<indent(depth)<<"'-> "<<ast<<" (ret="<<ret<<")"<<endl;
 #endif
+	return ret;
 }
diff --git a/prelude.cpp b/prelude.cpp
index eb503b0..cd51cad 100644
--- a/prelude.cpp
+++ b/prelude.cpp
@@ -18,6 +18,14 @@ const AST afterBootstrap=AST(R"RAW(
 	(def 'print (. putstr repr)))
 )RAW");
 
+static AST dofunction(const AST&);
+
+const AST doNative=AST::makeNative(dofunction);
+
+static AST dofunction(const AST&){
+	return doNative;
+}
+
 class PreludeInit{
 public:
 	PreludeInit(Environment &intoEnv){
@@ -46,8 +54,12 @@ public:
 			});
 		});
 
-		intoEnv.define("do",AST::makeNative([](const AST&) -> AST {
-			throw logic_error("'do' stub called; this should not happen");
+		intoEnv.define("do",doNative);
+
+		intoEnv.define("unquote",AST::makeNative([](const AST &ast) -> AST {
+			AST res(ast);
+			res.quoted=false;
+			return res;
 		}));
 
 		intoEnv.define2("+",[](Environment&,const AST &arg1,const AST &arg2) -> AST {