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 ++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 42 insertions(+)

(limited to 'builtins.c')

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
-- 
cgit v1.2.3