shithub: pprolog

Info  •  Files  •  Log

Add current_predicate/1 builtin

--- a/builtins.c

+++ b/builtins.c

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

 BuiltinProto(builtinwriteterm);

 BuiltinProto(builtingeq);

 BuiltinProto(builtinclause);

+BuiltinProto(builtincurrentpredicate);

 int compareterms(Term *, Term *);

@@ -133,6 +134,8 @@

 		return builtingeq;

 	if(Match(L"clause", 3))

 		return builtinclause;

+	if(Match(L"current_predicate", 2))

+		return builtincurrentpredicate;

 	return nil;

 }

@@ -860,4 +863,43 @@

 	}

 	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

--- a/dat.h

+++ b/dat.h

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

 	Rune *name;

 	int arity;

 	int public;

+	int builtin; /* All the predicates from the system module are builtin */

 	Clause *clauses;

 	Predicate *next;

 };

--- a/fns.h

+++ b/fns.h

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

 int ispartiallist(Term *t);

 int isemptylist(Term *);

 int isnonemptylist(Term *);

+int ispredicateindicator(Term *, int);

 Term *listhead(Term *);

 Term *listtail(Term *);

--- a/module.c

+++ b/module.c

@@ -18,6 +18,11 @@

 		exits(nil);

 	}

+	Predicate *p;

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

+		p->builtin = 1;

+	}

+

 	usermodule = addemptymodule(L"user");

 }

@@ -83,6 +88,7 @@

 			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);

--- a/stdlib.pl

+++ b/stdlib.pl

@@ -156,6 +156,10 @@

 	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]) :-

--- a/types.c

+++ b/types.c

@@ -38,6 +38,20 @@

 		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)