diff options
Diffstat (limited to 'builtins.c')
| -rw-r--r-- | builtins.c | 209 |
1 files changed, 207 insertions, 2 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 |