From 58e0109ee9ed3aa6ac2e6b0ed621820118a3d1de Mon Sep 17 00:00:00 2001
From: Peter Mikkelsen <peter@pmikkelsen.com>
Date: Thu, 8 Jul 2021 01:40:24 +0000
Subject: Add clause/2 predicate

---
 builtins.c | 52 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 dat.h      |  2 +-
 eval.c     |  6 +-----
 fns.h      |  2 ++
 lists.pl   |  4 ----
 misc.c     |  1 -
 module.c   |  2 +-
 stdlib.pl  | 10 ++++++++++
 8 files changed, 67 insertions(+), 12 deletions(-)

diff --git a/builtins.c b/builtins.c
index 5e1dc58..bebf0d1 100644
--- a/builtins.c
+++ b/builtins.c
@@ -47,6 +47,7 @@ BuiltinProto(builtinsetoutput);
 BuiltinProto(builtinreadterm);
 BuiltinProto(builtinwriteterm);
 BuiltinProto(builtingeq);
+BuiltinProto(builtinclause);
 
 int compareterms(Term *, Term *);
 
@@ -130,6 +131,8 @@ findbuiltin(Term *goal)
 		return builtinwriteterm;
 	if(Match(L">=", 2))
 		return builtingeq;
+	if(Match(L"clause", 3))
+		return builtinclause;
 
 	return nil;
 }
@@ -808,4 +811,53 @@ builtingeq(Term *goal, Binding **bindings, Module *module)
 		return aval->dval >= bval->ival;
 	else
 		return 0;
+}
+
+int
+builtinclause(Term *goal, Binding **bindings, Module *module)
+{
+	Term *head = goal->children;
+	Term *body = head->next;
+	Term *clauselist = body->next;
+	
+	if(head->tag == VariableTerm)
+		Throw(instantiationerror());
+	if(head->tag != AtomTerm && head->tag != CompoundTerm)
+		Throw(typeerror(L"callable", head));
+	if(body->tag != VariableTerm && body->tag != AtomTerm && body->tag != CompoundTerm)
+		Throw(typeerror(L"callable", body));
+	if(clauselist->tag != VariableTerm)
+		Throw(typeerror(L"variable", clauselist));
+
+	print("Attempting to find clauses in module %S where head unifies with %S\n", module->name, prettyprint(head, 0, 0, 0));
+
+	Predicate *pred = findpredicate(module->predicates, head);
+	if(pred == nil)
+		return 0;
+
+	Term *functor = mkatom(pred->name);
+	functor->next = mkinteger(pred->arity);
+	Term *pi = mkcompound(L"/", 2, functor);
+	if(!pred->public)
+		Throw(permissionerror(L"access", L"private_procedure", pi));
+
+	Term *realclauses = nil;
+	Clause *c = pred->clauses;
+	while(c != nil){
+		Binding *bs = nil;
+		c = findclause(c, head, &bs);
+		if(c != nil){
+			/* Append the clause to the realclauselist */
+			Term *cl = c->head;
+			if(c->body)
+				cl->next = c->body;
+			else
+				cl->next = mkatom(L"true");
+			
+			realclauses = appendterm(realclauses, mkcompound(L"clause", 2, cl));
+			c = c->next;
+		}
+	}
+	Term *realclauselist = mklist(realclauses);
+	return unify(clauselist, realclauselist, bindings);
 }
\ No newline at end of file
diff --git a/dat.h b/dat.h
index 6e93b84..9bbfef0 100644
--- a/dat.h
+++ b/dat.h
@@ -51,7 +51,6 @@ struct Clause
 	Term *head;
 	Term *body;
 	uvlong clausenr;
-	int public;
 	Clause *next;
 };
 
@@ -59,6 +58,7 @@ struct Predicate
 {
 	Rune *name;
 	int arity;
+	int public;
 	Clause *clauses;
 	Predicate *next;
 };
diff --git a/eval.c b/eval.c
index 3201286..d482b7d 100644
--- a/eval.c
+++ b/eval.c
@@ -5,8 +5,6 @@
 #include "dat.h"
 #include "fns.h"
 
-Predicate *findpredicate(Predicate *, Term *);
-Clause *findclause(Clause *, Term *, Binding **);
 int equalterms(Term *, Term *);
 Goal *copygoals(Goal *);
 Builtin findbuiltin(Term *);
@@ -142,9 +140,6 @@ findclause(Clause *clauses, Term *goal, Binding **bindings)
 {
 	Clause *clause;
 	for(; clauses != nil; clauses = clauses->next){
-		if(!clauses->public)
-			continue;
-
 		clause = copyclause(clauses, &clausenr);
 		clausenr++;
 		clause->next = clauses->next;
@@ -209,6 +204,7 @@ unify(Term *a, Term *b, Binding **bindings)
 			b->value = right;
 			b->next = *bindings;
 			*bindings = b;
+
 			Term *t;
 			for(t = leftstack; t != nil; t = t->next)
 				applybinding(t, b);
diff --git a/fns.h b/fns.h
index 2af6b2b..2238d56 100644
--- a/fns.h
+++ b/fns.h
@@ -22,6 +22,8 @@ int evalquery(Term *, Binding **);
 int unify(Term *, Term *, Binding **);
 void applybinding(Term *, Binding *);
 Goal *addgoals(Goal *, Term *, Module *);
+Predicate *findpredicate(Predicate *, Term *);
+Clause *findclause(Clause *, Term *, Binding **);
 
 /* repl.c */
 void repl(void);
diff --git a/lists.pl b/lists.pl
index ee75110..2aad0e5 100644
--- a/lists.pl
+++ b/lists.pl
@@ -7,10 +7,6 @@ length([_|Tail], Length) :-
 	length(Tail, Length0),
 	Length is Length0 + 1.
 
-member(X, [X|_]).
-member(X, [_|Tail]) :-
-	member(X, Tail).
-
 append([], Ys, Ys).
 append([X|Xs], Ys, [X|Rest]) :-
 	append(Xs, Ys, Rest).
diff --git a/misc.c b/misc.c
index 4adfffa..08aa339 100644
--- a/misc.c
+++ b/misc.c
@@ -152,7 +152,6 @@ copyclause(Clause *orig, uvlong *clausenr)
 		new->clausenr = *clausenr;
 	else
 		new->clausenr = orig->clausenr;
-	new->public = orig->public;
 	new->next = nil;
 	return new;
 }
\ No newline at end of file
diff --git a/module.c b/module.c
index f1fb4f2..8325fc9 100644
--- a/module.c
+++ b/module.c
@@ -59,7 +59,6 @@ parsemodule(char *file)
 		Clause *cl = malloc(sizeof(Clause));
 		int arity;
 		cl->clausenr = 0;
-		cl->public = 1; /* everything is public for now */
 		cl->next = nil;
 		if(t->tag == CompoundTerm && runestrcmp(t->text, L":-") == 0 && t->arity == 2){
 			cl->head = t->children;
@@ -83,6 +82,7 @@ parsemodule(char *file)
 			currentpred->name = cl->head->text;
 			currentpred->arity = arity;
 			currentpred->clauses = cl;
+			currentpred->public = 1; /* everything is public for now */
 			currentpred->next = nil;
 		}else
 			currentpred->clauses = appendclause(currentpred->clauses, cl);
diff --git a/stdlib.pl b/stdlib.pl
index b36a851..2b23063 100644
--- a/stdlib.pl
+++ b/stdlib.pl
@@ -150,3 +150,13 @@ E1 > E2 :-
 	E2 < E1.
 
 
+% Clause retrieval and information
+
+clause(Head, Body) :-
+	clause(Head, Body, Clauses),
+	member(clause(Head, Body), Clauses).
+
+% Basic list predicates
+member(X, [X|_]).
+member(X, [_|Tail]) :-
+	member(X, Tail).
-- 
cgit v1.2.3