shithub: pprolog

Download patch

ref: a37ae2f0170499be1a95031d24ff86aac5cf46f1
parent: d2a0828140c31514c514b8e4fb9a4d52c389d8fe
author: Peter Mikkelsen <peter@pmikkelsen.com>
date: Fri Jul 9 16:09:22 EDT 2021 

Add asserta/1, assertz/1, retract/1, abolish/1 (and retract_one/1, which is retract/1 but doesn't backtrack)


--- a/builtins.c
+++ b/builtins.c
@@ -17,6 +17,7 @@
 	return 1; \
 }while(0)
 
+BuiltinProto(builtintrue);
 BuiltinProto(builtinfail);
 BuiltinProto(builtincall);
 BuiltinProto(builtincut);
@@ -49,6 +50,10 @@
 BuiltinProto(builtingeq);
 BuiltinProto(builtinclause);
 BuiltinProto(builtincurrentpredicate);
+BuiltinProto(builtinasserta);
+BuiltinProto(builtinassertz);
+BuiltinProto(builtinretractone);
+BuiltinProto(builtinabolish);
 
 int compareterms(Term *, Term *);
 
@@ -72,6 +77,8 @@
 	}
 
 	/* Rewrite this so its not just a long if chain */
+	if(Match(L"true", 0))
+		return builtintrue;
 	if(Match(L"fail", 0))
 		return builtinfail;
 	if(Match(L"call", 1))
@@ -136,11 +143,28 @@
 		return builtinclause;
 	if(Match(L"current_predicate", 2))
 		return builtincurrentpredicate;
+	if(Match(L"asserta", 1))
+		return builtinasserta;
+	if(Match(L"assertz", 1))
+		return builtinassertz;
+	if(Match(L"retract_one", 1))
+		return builtinretractone;
+	if(Match(L"abolish", 1))
+		return builtinabolish;
 
 	return nil;
 }
 
 int
+builtintrue(Term *goal, Binding **bindings, Module *module)
+{
+	USED(goal);
+	USED(bindings);
+	USED(module);
+	return 1;
+}
+
+int
 builtinfail(Term *goal, Binding **bindings, Module *module)
 {
 	USED(goal);
@@ -832,8 +856,6 @@
 	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;
@@ -902,4 +924,187 @@
 	}
 	Term *reallist = mklist(pilist);
 	return unify(list, reallist, bindings);
+}
+
+int
+assertclause(Term *clause, Module *module, int after)
+{
+	/* If after=0 then this is asserta, else it is assertz */
+	Term *head;
+	Term *body;
+
+	if(clause->tag == CompoundTerm && runestrcmp(clause->text, L":-") == 0 && clause->arity == 2){
+		head = clause->children;
+		body = head->next;
+	}else{
+		head = clause;
+		body = mkatom(L"true");
+	}
+
+	if(body->tag == VariableTerm)
+		body = mkcompound(L"call", 1, body);
+
+	if(head->tag == VariableTerm)
+		Throw(instantiationerror());
+	if(head->tag != AtomTerm && head->tag != CompoundTerm)
+		Throw(typeerror(L"callable", head));
+	if(body->tag != AtomTerm && body->tag != CompoundTerm)
+		Throw(typeerror(L"callable", body));
+
+	Rune *name = head->text;
+	int arity;
+	if(head->tag == CompoundTerm)
+		arity = head->arity;
+	else
+		arity = 0;
+
+	uvlong id = 0;
+	Clause *cl = gmalloc(sizeof(Clause));
+	cl->head = copyterm(head, &id);
+	cl->body = copyterm(body, &id);
+	cl->clausenr = id;
+	cl->next = nil;
+
+	Predicate *p;
+	for(p = module->predicates; p != nil; p = p->next){
+		if(p->arity == arity && runestrcmp(p->name, name) == 0){
+			if(!p->dynamic){
+				Term *t = mkatom(name);
+				t->next = mkinteger(arity);
+				Term *pi = mkcompound(L"/", 2, t);
+				Throw(permissionerror(L"modify", L"static_procedure", pi));
+			}
+			if(after)
+				p->clauses = appendclause(p->clauses, cl);
+			else
+				p->clauses = appendclause(cl, p->clauses);
+			return 1;
+		}
+	}
+
+	/* If we get here, create a new predicate in the module */
+	p = gmalloc(sizeof(Predicate));
+	p->name = name;
+	p->arity = arity;
+	p->clauses = cl;
+	p->public = 1;
+	p->builtin = 0;
+	p->dynamic = 1;
+	p->next = nil;
+	module->predicates = appendpredicate(module->predicates, p);
+
+	return 1;
+}
+
+int
+builtinasserta(Term *goal, Binding **bindings, Module *module)
+{
+	USED(bindings);
+	return assertclause(goal->children, module, 0);
+}
+
+int
+builtinassertz(Term *goal, Binding **bindings, Module *module)
+{
+	USED(bindings);
+	return assertclause(goal->children, module, 1);
+}
+
+int
+builtinretractone(Term *goal, Binding **bindings, Module *module)
+{
+	Term *clause = goal->children;
+	Term *head;
+	Term *body;
+
+	if(clause->tag == CompoundTerm && runestrcmp(clause->text, L":-") == 0 && clause->arity == 2){
+		head = clause->children;
+		body = head->next;
+	}else{
+		head = clause;
+		body = mkatom(L"true");
+	}
+
+	if(head->tag == VariableTerm)
+		Throw(instantiationerror());
+	if(head->tag != AtomTerm && head->tag != CompoundTerm)
+		Throw(typeerror(L"callable", head));
+
+	Predicate *pred = findpredicate(module->predicates, head);
+	if(pred == nil)
+		return 0;
+	if(!pred->dynamic){
+		Rune *name = head->text;
+		int arity = 0;
+		if(head->tag == CompoundTerm)
+			arity = head->arity;
+		Term *t = mkatom(name);
+		t->next = mkinteger(arity);
+		Term *pi = mkcompound(L"/", 2, t);
+		Throw(permissionerror(L"access", L"static_procedure", pi));
+	}
+
+	Clause *cl;
+	for(cl = pred->clauses; cl != nil; cl = cl->next){
+		if(!unify(cl->head, head, bindings))
+			continue;
+		if(!unify(cl->body, body, bindings))
+			continue;
+
+		if(cl == pred->clauses)
+			pred->clauses = cl->next;
+		else{
+			Clause *tmp;
+			for(tmp = pred->clauses; tmp->next != cl; tmp = tmp->next);
+			tmp->next = tmp->next->next;
+		}
+		return 1;
+	}
+	return 0;
+}
+
+int
+builtinabolish(Term *goal, Binding **bindings, Module *module)
+{
+	USED(goal);
+	USED(bindings);
+	USED(module);
+	Term *pi = goal->children;
+
+	if(pi->tag == VariableTerm)
+		Throw(instantiationerror());
+	if(pi->tag != CompoundTerm || runestrcmp(pi->text, L"/") != 0 || pi->arity != 2)
+		Throw(typeerror(L"predicate_indicator", pi));
+	
+	Term *nameterm = pi->children;
+	Term *arityterm = nameterm->next;
+	if(nameterm->tag == VariableTerm || arityterm->tag == VariableTerm)
+		Throw(instantiationerror());
+	if(arityterm->tag != IntegerTerm)
+		Throw(typeerror(L"integer", arityterm));
+	if(nameterm->tag != AtomTerm)
+		Throw(typeerror(L"atom", nameterm));
+	Rune *name = nameterm->text;
+	int arity = arityterm->ival;
+
+	if(arity < 0)
+		Throw(domainerror(L"not_less_than_zero", arityterm));
+
+	Predicate *p = module->predicates;
+	if(p->arity == arity && runestrcmp(p->name, name) == 0){
+		module->predicates = p->next;
+		return 1;
+	}
+	for(p = module->predicates; p != nil; p = p->next){
+		if(p->arity != arity || runestrcmp(p->name, name) != 0)
+			continue;
+		if(p == module->predicates)
+			module->predicates = p->next;
+		else{
+			Predicate *tmp;
+			for(tmp = module->predicates; tmp->next != p; tmp = tmp->next);
+			tmp->next = tmp->next->next;
+		}
+	}
+	return 1;
 }
\ No newline at end of file
--- a/dat.h
+++ b/dat.h
@@ -60,6 +60,7 @@
 	int arity;
 	int public;
 	int builtin; /* All the predicates from the system module are builtin */
+	int dynamic;
 	Clause *clauses;
 	Predicate *next;
 };
--- a/fns.h
+++ b/fns.h
@@ -66,6 +66,8 @@
 void initmodules(void);
 Module *parsemodule(char *);
 Module *getmodule(Rune *);
+Clause *appendclause(Clause *, Clause *);
+Predicate *appendpredicate(Predicate *, Predicate *);
 
 /* types.c */
 int islist(Term *);
--- a/module.c
+++ b/module.c
@@ -6,8 +6,6 @@
 #include "fns.h"
 
 Module *addemptymodule(Rune *);
-Clause *appendclause(Clause *, Clause *);
-Predicate *appendpredicate(Predicate *, Predicate *);
 
 void
 initmodules(void)
@@ -21,6 +19,7 @@
 	Predicate *p;
 	for(p = systemmodule->predicates; p != nil; p = p->next){
 		p->builtin = 1;
+		p->dynamic = 0;
 	}
 
 	usermodule = addemptymodule(L"user");
@@ -70,7 +69,7 @@
 			cl->body = t->children->next;
 		}else{
 			cl->head = t;
-			cl->body = nil;
+			cl->body = mkatom(L"true");
 		}
 		if(cl->head->tag == AtomTerm)
 			arity = 0;
@@ -89,6 +88,7 @@
 			currentpred->clauses = cl;
 			currentpred->public = 1; /* everything is public for now */
 			currentpred->builtin = 0;
+			currentpred->dynamic = 1; /* everything is dynamic for now */
 			currentpred->next = nil;
 		}else
 			currentpred->clauses = appendclause(currentpred->clauses, cl);
--- a/stdlib.pl
+++ b/stdlib.pl
@@ -10,8 +10,7 @@
 
 repeat :- true ; repeat.
 
-% Control structures. 
-true.
+% Control structures.
 
 If -> Then :-
 	If, !, Then.
@@ -150,7 +149,7 @@
 	E2 < E1.
 
 
-% Clause retrieval and information
+% Clause retrieval and information and removal
 
 clause(Head, Body) :-
 	clause(Head, Body, Clauses),
@@ -159,6 +158,13 @@
 current_predicate(PI) :-
 	current_predicate(PI, Predicates),
 	member(PI, Predicates).
+
+retract(Clause) :-
+	copy_term(Clause, ClauseCopy),
+	retract_one(ClauseCopy),
+	( Clause = ClauseCopy
+	; retract(Clause)
+	).
 
 % Basic list predicates
 member(X, [X|_]).