shithub: pprolog

--- a/dat.h

+++ b/dat.h

@@ -3,6 +3,7 @@

 typedef struct Goal Goal;

 typedef struct Choicepoint Choicepoint;

 typedef struct Clause Clause;

+typedef struct Predicate Predicate;

 typedef struct Module Module;

 typedef int (*Builtin)(Term *, Binding **);

@@ -37,7 +38,8 @@

 struct Choicepoint

 	Goal *goalstack;

-	Clause *retryclause;

+	Clause *alternative;

+	Binding *altbindings;

 	uvlong id; /* Unique number for each clause. Used to know where to cut to. */

 	Module *currentmodule;

 	Choicepoint *next;

@@ -52,11 +54,19 @@

 	Clause *next;

};

+struct Predicate

+{

+	Rune *name;

+	int arity;

+	Clause *clauses;

+	Predicate *next;

+};

 struct Module

 	/* What about imports */

 	Rune *name;

-	Clause *clauses;

+	Predicate *predicates;

 	Module *next;

};

--- a/eval.c

+++ b/eval.c

@@ -6,10 +6,12 @@

 #include "fns.h"

 Goal *addgoals(Goal *, Term *);

+Predicate *findpredicate(Predicate *, Term *);

 Clause *findclause(Clause *, Term *, Binding **);

 int equalterms(Term *, Term *);

 Goal *copygoals(Goal *);

 Builtin findbuiltin(Term *);

+void addchoicepoints(Clause *, Term *, Goal *, Module *);

 static uvlong clausenr;

@@ -45,23 +47,17 @@

 	while(goalstack->goal != nil){

-		Clause *startclause;

-		Term *goal;

-		Goal *oldgoalstack;

-		startclause = nil; /* Where to start looking for a matching clause. Used by backtracking */

-Retry:

-		goal = goalstack->goal;

-		oldgoalstack = goalstack;

+		Term *goal = goalstack->goal;

+		Term *catcher = goalstack->catcher;

 		goalstack = goalstack->next;

-		if(oldgoalstack->catcher)

+		if(catcher)

 			continue;

 		if(debug)

 			print("Working goal: %S\n", prettyprint(goal, 0, 0, 0));

-		if(startclause == nil && goal->tag == CompoundTerm && goal->arity == 2 && runestrcmp(goal->text, L":") == 0){

+		if(goal->tag == CompoundTerm && goal->arity == 2 && runestrcmp(goal->text, L":") == 0){

 			Term *module = goal->children;

 			if(module->tag == AtomTerm){

 				Module *m = getmodule(module->text);

@@ -70,16 +66,11 @@

 				else{

 					goal = module->next;

 					currentmodule = m;

-					startclause = m->clauses;

-					oldgoalstack->goal = goal;

 			}else

 				goal = typeerror(L"module", module);

-		if(startclause == nil)

-			startclause = currentmodule->clauses;

 		Binding *bindings = nil;

 		Clause *clause = nil;

@@ -90,20 +81,17 @@

 			if(!success)

 				goto Backtrack;

 		}else{

+			Predicate *pred = findpredicate(currentmodule->predicates, goal);

+			if(pred == nil){

+				print("No predicate matches: %S\n", prettyprint(goal, 0, 0, 0));

+				goto Backtrack;

+			}

 			/* Find a clause where the head unifies with the goal */

-			clause = findclause(startclause, goal, &bindings);

-			if(clause != nil){

-				if(clause->next != nil){

-					/* Add a choicepoint. Note we create a choicepoint every time, so there is room for improvement. */

-					Choicepoint *cp = malloc(sizeof(Choicepoint));

-					cp->goalstack = copygoals(oldgoalstack);

-					cp->next = choicestack;

-					cp->retryclause = clause->next;

-					cp->id = clause->clausenr;

-					cp->currentmodule = currentmodule;

-					choicestack = cp;

-				}

-			}else{

+			clause = findclause(pred->clauses, goal, &bindings);

+			if(clause != nil)

+				addchoicepoints(clause, goal, goalstack, currentmodule);

+			else{

 Backtrack:

 				if(choicestack == nil)

 					return 0;

@@ -111,11 +99,10 @@

 					print("Backtracking..\n");

 				Choicepoint *cp = choicestack;

 				choicestack = cp->next;

-				/* freegoals(goals) */

 				goalstack = cp->goalstack;

 				currentmodule = cp->currentmodule;

-				startclause = cp->retryclause;

-				goto Retry;

+				clause = cp->alternative;

+				bindings = cp->altbindings;

@@ -171,6 +158,26 @@

 	return nil;

+Predicate *

+findpredicate(Predicate *preds, Term *goal)

+{

+	Rune *name;

+	int arity;

+	name = goal->text;

+	if(goal->tag == AtomTerm)

+		arity = 0;

+	else

+		arity = goal->arity;

+	Predicate *p;

+	for(p = preds; p != nil; p = p->next){

+		if(runestrcmp(p->name, name) == 0 && p->arity == arity)

+			return p;

+	}

+	return nil;

+}

int

 unify(Term *a, Term *b, Binding **bindings)

@@ -293,3 +300,40 @@

 	}else

 		return nil;

+void

+addchoicepoints(Clause *clause, Term *goal, Goal *goals, Module *mod){

+	/* Find all alternative clauses that would have matched, and create a choicepoint for them */

+	Choicepoint *cps = nil;

+	Choicepoint *last = nil;

+	Clause *alt = clause->next;

+	while(alt != nil){

+		Binding *altbindings = nil;

+		clause = findclause(alt, goal, &altbindings);

+		if(clause){

+			/* Add choicepoint here */

+			Choicepoint *cp = malloc(sizeof(Choicepoint));

+			cp->goalstack = copygoals(goals);

+			cp->next = nil;

+			cp->alternative = clause;

+			cp->altbindings = altbindings;

+			cp->id = clause->clausenr;

+			cp->currentmodule = mod;

+			if(cps == nil){

+				cps = cp;

+				last = cp;

+			}else{

+				last->next = cp;

+				last = cp;

+			}

+			alt = clause->next;

+		}else

+			alt = nil;

+	}

+	if(last){

+		last->next = choicestack;

+		choicestack = cps;

+	}

+}

\ No newline at end of file

--- a/mkfile

+++ b/mkfile

@@ -19,4 +19,5 @@

 BIN=/$objtype/bin

-</sys/src/cmd/mkone

\ No newline at end of file

+</sys/src/cmd/mkone

--- a/module.c

+++ b/module.c

@@ -7,6 +7,7 @@

 Module *addemptymodule(Rune *);

 Clause *appendclause(Clause *, Clause *);

+Predicate *appendpredicate(Predicate *, Predicate *);

 void

 initmodules(void)

@@ -52,9 +53,11 @@

 		terms = terms->next;

+	Predicate *currentpred = nil;

 	Term *t;

 	for(t = terms; t != nil; t = t->next){

 		Clause *cl = malloc(sizeof(Clause));

+		int arity;

 		cl->clausenr = 0;

 		cl->public = 1; /* everything is public for now */

 		cl->next = nil;

@@ -65,12 +68,29 @@

 			cl->head = t;

 			cl->body = nil;

-		if(m == nil)

-			usermodule->clauses = appendclause(usermodule->clauses, cl);

+		if(cl->head->tag == AtomTerm)

+			arity = 0;

 		else

-			m->clauses = appendclause(m->clauses, cl);

+			arity = cl->head->arity;

+		/* Figure out if this clause goes into the latest predicate, or if it is the start of a new one */

+		if(currentpred == nil || runestrcmp(cl->head->text, currentpred->name) != 0 || arity != currentpred->arity){

+			if(m)

+				m->predicates = appendpredicate(currentpred, m->predicates);

+			else

+				usermodule->predicates = appendpredicate(currentpred, usermodule->predicates);

+			currentpred = malloc(sizeof(Predicate));

+			currentpred->name = cl->head->text;

+			currentpred->arity = arity;

+			currentpred->clauses = cl;

+			currentpred->next = nil;

+		}else

+			currentpred->clauses = appendclause(currentpred->clauses, cl);

+	if(m)

+		m->predicates = appendpredicate(currentpred, m->predicates);

+	else

+		usermodule->predicates = appendpredicate(currentpred, usermodule->predicates);

 	return m;

@@ -94,9 +114,9 @@

 	m->next = modules;

 	if(systemmodule == nil)

-		m->clauses = nil;

+		m->predicates = nil;

 	else

-		m->clauses = systemmodule->clauses; /* Direct access to system clauses for now, but when I figure out imports this will change */

+		m->predicates = systemmodule->predicates; /* Direct access to system clauses for now, but when I figure out imports this will change */

 	modules = m;

 	return m;

@@ -113,4 +133,18 @@

 	tmp->next = new;

 	return clauses;

+}

+Predicate *

+appendpredicate(Predicate *preds, Predicate *new)

+{

+	Predicate *tmp;

+	if(preds == nil)

+		return new;

+	for(tmp = preds; tmp->next != nil; tmp = tmp->next);

+	tmp->next = new;

+	return preds;

\ No newline at end of file

--- a/parser.c

+++ b/parser.c

@@ -660,4 +660,4 @@

 	print("Syntax error: Unexpected %d (%S) token in %s\n", lookahead.tag, lookahead.text, where);

 	exits("syntax error");

-}

\ No newline at end of file

+}

--- a/stdlib.pl

+++ b/stdlib.pl

@@ -128,3 +128,4 @@

 write_canonical(S, Term) :-

 	write_term(S, Term, [quoted(true), ignore_ops(true)]).