From d2a0828140c31514c514b8e4fb9a4d52c389d8fe Mon Sep 17 00:00:00 2001
From: Peter Mikkelsen <peter@pmikkelsen.com>
Date: Thu, 8 Jul 2021 21:54:27 +0000
Subject: Add current_predicate/1 builtin

---
 builtins.c | 42 ++++++++++++++++++++++++++++++++++++++++++
 dat.h      |  1 +
 fns.h      |  1 +
 module.c   |  6 ++++++
 stdlib.pl  |  4 ++++
 types.c    | 14 ++++++++++++++
 6 files changed, 68 insertions(+)

diff --git a/builtins.c b/builtins.c
index 56576a8..6f5a6bf 100644
--- a/builtins.c
+++ b/builtins.c
@@ -48,6 +48,7 @@ BuiltinProto(builtinreadterm);
 BuiltinProto(builtinwriteterm);
 BuiltinProto(builtingeq);
 BuiltinProto(builtinclause);
+BuiltinProto(builtincurrentpredicate);
 
 int compareterms(Term *, Term *);
 
@@ -133,6 +134,8 @@ findbuiltin(Term *goal)
 		return builtingeq;
 	if(Match(L"clause", 3))
 		return builtinclause;
+	if(Match(L"current_predicate", 2))
+		return builtincurrentpredicate;
 
 	return nil;
 }
@@ -860,4 +863,43 @@ builtinclause(Term *goal, Binding **bindings, Module *module)
 	}
 	Term *realclauselist = mklist(realclauses);
 	return unify(clauselist, realclauselist, bindings);
+}
+
+int
+builtincurrentpredicate(Term *goal, Binding **bindings, Module *module)
+{
+	Term *pi = goal->children;
+	Term *list = pi->next;
+
+	if(pi->tag != VariableTerm && !ispredicateindicator(pi, 1))
+		Throw(typeerror(L"predicate_indicator", pi));
+
+	Rune *predname = nil;
+	int arity = -1;
+	if(ispredicateindicator(pi, 1)){
+		Term *functor = pi->children;
+		Term *arityterm = functor->next;
+		if(functor->tag == AtomTerm)
+			predname = functor->text;
+		if(arityterm->tag == IntegerTerm)
+			arity = arityterm->ival;
+	}
+
+	Term *pilist = nil;
+	Predicate *pred;
+	for(pred = module->predicates; pred != nil; pred = pred->next){
+		if(pred->builtin)
+			continue;
+		if(predname && runestrcmp(pred->name, predname) != 0)
+			continue;
+		if(arity != -1 && pred->arity != arity)
+			continue;
+
+		Term *functor = mkatom(pred->name);
+		functor->next = mkinteger(pred->arity);
+		Term *t = mkcompound(L"/", 2, functor);
+		pilist = appendterm(t, pilist);
+	}
+	Term *reallist = mklist(pilist);
+	return unify(list, reallist, bindings);
 }
\ No newline at end of file
diff --git a/dat.h b/dat.h
index e085acd..e01276d 100644
--- a/dat.h
+++ b/dat.h
@@ -59,6 +59,7 @@ struct Predicate
 	Rune *name;
 	int arity;
 	int public;
+	int builtin; /* All the predicates from the system module are builtin */
 	Clause *clauses;
 	Predicate *next;
 };
diff --git a/fns.h b/fns.h
index 4c8b682..dd3745b 100644
--- a/fns.h
+++ b/fns.h
@@ -72,6 +72,7 @@ int islist(Term *);
 int ispartiallist(Term *t);
 int isemptylist(Term *);
 int isnonemptylist(Term *);
+int ispredicateindicator(Term *, int);
 Term *listhead(Term *);
 Term *listtail(Term *);
 
diff --git a/module.c b/module.c
index 45d0797..bd7ca22 100644
--- a/module.c
+++ b/module.c
@@ -18,6 +18,11 @@ initmodules(void)
 		exits(nil);
 	}
 
+	Predicate *p;
+	for(p = systemmodule->predicates; p != nil; p = p->next){
+		p->builtin = 1;
+	}
+
 	usermodule = addemptymodule(L"user");
 }
 
@@ -83,6 +88,7 @@ parsemodule(char *file)
 			currentpred->arity = arity;
 			currentpred->clauses = cl;
 			currentpred->public = 1; /* everything is public for now */
+			currentpred->builtin = 0;
 			currentpred->next = nil;
 		}else
 			currentpred->clauses = appendclause(currentpred->clauses, cl);
diff --git a/stdlib.pl b/stdlib.pl
index 2b23063..a972ae0 100644
--- a/stdlib.pl
+++ b/stdlib.pl
@@ -156,6 +156,10 @@ clause(Head, Body) :-
 	clause(Head, Body, Clauses),
 	member(clause(Head, Body), Clauses).
 
+current_predicate(PI) :-
+	current_predicate(PI, Predicates),
+	member(PI, Predicates).
+
 % Basic list predicates
 member(X, [X|_]).
 member(X, [_|Tail]) :-
diff --git a/types.c b/types.c
index 6f2b33d..0e70abf 100644
--- a/types.c
+++ b/types.c
@@ -38,6 +38,20 @@ isnonemptylist(Term *t)
 		return 0;	
 }
 
+int
+ispredicateindicator(Term *t, int allowvars)
+{
+	if(t->tag == CompoundTerm && runestrcmp(t->text, L"/") == 0 && t->arity == 2){
+		Term *f = t->children;
+		Term *a = f->next;
+		if(allowvars)
+			return (f->tag == VariableTerm || f->tag == AtomTerm) && (a->tag == VariableTerm || a->tag == IntegerTerm);
+		else
+			return (f->tag == AtomTerm) && (a->tag == IntegerTerm);
+	}else
+		return 0;
+}
+
 /* Other functions */
 Term *
 listhead(Term *t)
-- 
cgit v1.2.3