diff options
| -rw-r--r-- | builtins.c | 209 | ||||
| -rw-r--r-- | dat.h | 1 | ||||
| -rw-r--r-- | fns.h | 2 | ||||
| -rw-r--r-- | module.c | 6 | ||||
| -rw-r--r-- | stdlib.pl | 12 |
5 files changed, 222 insertions, 8 deletions
@@ -17,6 +17,7 @@ return 1; \ }while(0) +BuiltinProto(builtintrue); BuiltinProto(builtinfail); BuiltinProto(builtincall); BuiltinProto(builtincut); @@ -49,6 +50,10 @@ BuiltinProto(builtinwriteterm); BuiltinProto(builtingeq); BuiltinProto(builtinclause); BuiltinProto(builtincurrentpredicate); +BuiltinProto(builtinasserta); +BuiltinProto(builtinassertz); +BuiltinProto(builtinretractone); +BuiltinProto(builtinabolish); int compareterms(Term *, Term *); @@ -72,6 +77,8 @@ findbuiltin(Term *goal) } /* 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 @@ findbuiltin(Term *goal) 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 @@ builtinclause(Term *goal, Binding **bindings, Module *module) 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 @@ builtincurrentpredicate(Term *goal, Binding **bindings, Module *module) } 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 @@ -60,6 +60,7 @@ struct Predicate int arity; int public; int builtin; /* All the predicates from the system module are builtin */ + int dynamic; Clause *clauses; Predicate *next; }; @@ -66,6 +66,8 @@ void writeterm(Term *, Term *, Term *); void initmodules(void); Module *parsemodule(char *); Module *getmodule(Rune *); +Clause *appendclause(Clause *, Clause *); +Predicate *appendpredicate(Predicate *, Predicate *); /* types.c */ int islist(Term *); @@ -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 @@ initmodules(void) 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 @@ parsemodule(char *file) 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 @@ parsemodule(char *file) 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); @@ -10,8 +10,7 @@ once(Goal) :- repeat :- true ; repeat. -% Control structures. -true. +% Control structures. If -> Then :- If, !, Then. @@ -150,7 +149,7 @@ E1 > E2 :- E2 < E1. -% Clause retrieval and information +% Clause retrieval and information and removal clause(Head, Body) :- clause(Head, Body, Clauses), @@ -160,6 +159,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|_]). member(X, [_|Tail]) :- |