ref: 2a77288e28f2725b5621c239d2393d49f61993e8
dir: /builtins.c/
#include <u.h>
#include <libc.h>
#include <bio.h>
#include "dat.h"
#include "fns.h"
#define BuiltinProto(name) int name(Term *, Binding **, Module *)
#define Match(X, Y) (runestrcmp(name, X) == 0 && arity == Y)
#define Throw(What) do{\
Goal *g = gmalloc(sizeof(Goal)); \
g->goal = What; \
g->module = usermodule; \
g->catcher = nil; \
g->next = goalstack; \
goalstack = g; \
return 1; \
}while(0)
BuiltinProto(builtintrue);
BuiltinProto(builtinfail);
BuiltinProto(builtincall);
BuiltinProto(builtincut);
BuiltinProto(builtinvar);
BuiltinProto(builtinatom);
BuiltinProto(builtininteger);
BuiltinProto(builtinfloat);
BuiltinProto(builtinatomic);
BuiltinProto(builtincompound);
BuiltinProto(builtinnonvar);
BuiltinProto(builtinnumber);
BuiltinProto(builtincompare);
BuiltinProto(builtinfunctor);
BuiltinProto(builtinarg);
BuiltinProto(builtinuniv);
BuiltinProto(builtincopyterm);
BuiltinProto(builtinis);
BuiltinProto(builtincatch);
BuiltinProto(builtinthrow);
BuiltinProto(builtinsetprologflag);
BuiltinProto(builtincurrentprologflag);
BuiltinProto(builtinopen);
BuiltinProto(builtinclose);
BuiltinProto(builtincurrentinput);
BuiltinProto(builtincurrentoutput);
BuiltinProto(builtinsetinput);
BuiltinProto(builtinsetoutput);
BuiltinProto(builtinreadterm);
BuiltinProto(builtinwriteterm);
BuiltinProto(builtingeq);
BuiltinProto(builtinclause);
BuiltinProto(builtincurrentpredicate);
BuiltinProto(builtinasserta);
BuiltinProto(builtinassertz);
BuiltinProto(builtinretractone);
BuiltinProto(builtinabolish);
BuiltinProto(builtinatomlength);
BuiltinProto(builtinatomcodes);
int compareterms(Term *, Term *);
Builtin
findbuiltin(Term *goal)
{
int arity;
Rune *name;
switch(goal->tag){
case AtomTerm:
arity = 0;
name = goal->text;
break;
case CompoundTerm:
arity = goal->arity;
name = goal->text;
break;
default:
return nil;
}
/* 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))
return builtincall;
if(Match(L"!", 0))
return builtincut;
if(Match(L"var", 1))
return builtinvar;
if(Match(L"atom", 1))
return builtinatom;
if(Match(L"integer", 1))
return builtininteger;
if(Match(L"float", 1))
return builtinfloat;
if(Match(L"atomic", 1))
return builtinatomic;
if(Match(L"compound", 1))
return builtincompound;
if(Match(L"nonvar", 1))
return builtinnonvar;
if(Match(L"number", 1))
return builtinnumber;
if(Match(L"compare", 3))
return builtincompare;
if(Match(L"functor", 3))
return builtinfunctor;
if(Match(L"arg", 3))
return builtinarg;
if(Match(L"=..", 2))
return builtinuniv;
if(Match(L"copy_term", 2))
return builtincopyterm;
if(Match(L"is", 2))
return builtinis;
if(Match(L"catch", 3))
return builtincatch;
if(Match(L"throw", 1))
return builtinthrow;
if(Match(L"set_prolog_flag", 2))
return builtinsetprologflag;
if(Match(L"current_prolog_flag", 2))
return builtincurrentprologflag;
if(Match(L"open", 4))
return builtinopen;
if(Match(L"close", 2))
return builtinclose;
if(Match(L"current_input", 1))
return builtincurrentinput;
if(Match(L"current_output", 1))
return builtincurrentoutput;
if(Match(L"set_input", 1))
return builtinsetinput;
if(Match(L"set_output", 1))
return builtinsetoutput;
if(Match(L"$read_term", 3))
return builtinreadterm;
if(Match(L"write_term", 3))
return builtinwriteterm;
if(Match(L">=", 2))
return builtingeq;
if(Match(L"clause", 3))
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;
if(Match(L"atom_length", 2))
return builtinatomlength;
if(Match(L"atom_codes", 2))
return builtinatomcodes;
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);
USED(bindings);
USED(module);
return 0;
}
int
builtincall(Term *goal, Binding **bindings, Module *module)
{
USED(bindings);
goalstack = addgoals(goalstack, goal->children, module);
return 1;
}
int
builtincut(Term *goal, Binding **bindings, Module *module)
{
USED(bindings);
USED(module);
Choicepoint *cp = choicestack;
/* Cut all choicepoints with an id larger or equal to the goal clause number, since they must have been introduced
after this goal's parent.
*/
while(cp != nil && cp->id >= goal->clausenr)
cp = cp->next;
choicestack = cp;
return 1;
}
int
builtinvar(Term *goal, Binding **bindings, Module *module)
{
USED(bindings);
USED(module);
Term *arg = goal->children;
return (arg->tag == VariableTerm);
}
int
builtinatom(Term *goal, Binding **bindings, Module *module)
{
USED(bindings);
USED(module);
Term *arg = goal->children;
return (arg->tag == AtomTerm);
}
int
builtininteger(Term *goal, Binding **bindings, Module *module)
{
USED(bindings);
USED(module);
Term *arg = goal->children;
return (arg->tag == IntegerTerm);
}
int
builtinfloat(Term *goal, Binding **bindings, Module *module)
{
USED(bindings);
USED(module);
Term *arg = goal->children;
return (arg->tag == FloatTerm);
}
int
builtinatomic(Term *goal, Binding **bindings, Module *module)
{
USED(bindings);
USED(module);
Term *arg = goal->children;
return (arg->tag == AtomTerm || arg->tag == FloatTerm || arg->tag == IntegerTerm);
}
int
builtincompound(Term *goal, Binding **bindings, Module *module)
{
USED(bindings);
USED(module);
Term *arg = goal->children;
return (arg->tag == CompoundTerm);
}
int
builtinnonvar(Term *goal, Binding **bindings, Module *module)
{
USED(bindings);
USED(module);
Term *arg = goal->children;
return (arg->tag != VariableTerm);
}
int
builtinnumber(Term *goal, Binding **bindings, Module *module)
{
USED(bindings);
USED(module);
Term *arg = goal->children;
return (arg->tag == FloatTerm || arg->tag == IntegerTerm);
}
#define Compare(A, B) ((A < B) ? -1 : ((A > B) ? 1 : 0))
int
compareterms(Term *t1, Term *t2)
{
int result = 0;
if(t1->tag != t2->tag)
result = Compare(t1->tag, t2->tag);
else{
/* Same type term */
switch(t1->tag){
case VariableTerm:
if(runestrcmp(t1->text, L"_") == 0 && runestrcmp(t2->text, L"_") == 0)
result = 1; /* Special case since _ and _ are always different */
else if(t1->clausenr == t2->clausenr)
result = runestrcmp(t1->text, t2->text);
else
result = Compare(t1->clausenr, t2->clausenr);
break;
case FloatTerm:
result = Compare(t1->dval, t2->dval);
break;
case IntegerTerm:
result = Compare(t1->ival, t2->ival);
break;
case AtomTerm:
result = runestrcmp(t1->text, t2->text);
break;
case CompoundTerm:
result = Compare(t1->arity, t2->arity);
if(result != 0)
break;
result = runestrcmp(t1->text, t2->text);
if(result != 0)
break;
t1 = t1->children;
t2 = t2->children;
while(t1 != nil && t2 != nil){
result = compareterms(t1, t2);
if(result != 0)
break;
else
t1 = t1->next;
t2 = t2->next;
}
break;
}
}
return result;
}
int
builtincompare(Term *goal, Binding **bindings, Module *module)
{
USED(module);
Term *order = goal->children;
Term *t1 = order->next;
Term *t2 = t1->next;
int result = compareterms(t1, t2);
Term *resultorder;
if(result == -1)
resultorder = mkatom(L"<");
else if(result == 0)
resultorder = mkatom(L"=");
else
resultorder = mkatom(L">");
return unify(order, resultorder, bindings);
}
int
builtinfunctor(Term *goal, Binding **bindings, Module *module)
{
USED(module);
Term *term = goal->children;
Term *name = term->next;
Term *arity = name->next;
if(term->tag == VariableTerm && name->tag == VariableTerm)
Throw(instantiationerror());
if(term->tag == VariableTerm && arity->tag == VariableTerm)
Throw(instantiationerror());
if(term->tag == VariableTerm && !(name->tag == VariableTerm || name->tag == AtomTerm || name->tag == IntegerTerm || name->tag == FloatTerm))
Throw(typeerror(L"atomic", name));
if(term->tag == VariableTerm && !(arity->tag == VariableTerm || arity->tag == IntegerTerm))
Throw(typeerror(L"integer", arity));
if(term->tag == VariableTerm && name->tag != VariableTerm && name->tag != AtomTerm && arity->tag == IntegerTerm && arity->ival > 0)
Throw(typeerror(L"atom", name));
if(term->tag == VariableTerm && arity->tag == IntegerTerm && arity->ival < 0)
Throw(domainerror(L"not_less_than_zero", arity));
if(term->tag == VariableTerm){
if(arity->ival == 0)
return unify(term, name, bindings);
else{
/* Make arity many fresh variables */
int i;
Term *args = nil;
for(i = 0; i < arity->ival; i++){
Term *arg = mkvariable(L"_");
args = appendterm(args, arg);
}
Term *realterm = mkcompound(name->text, arity->ival, args);
return unify(term, realterm, bindings);
}
}else{
Rune *namestr;
int arityint;
if(term->tag == CompoundTerm){
namestr = term->text;
arityint = term->arity;
}else{
namestr = prettyprint(term, 0, 0, 0);
arityint = 0;
}
Term *realname = mkatom(namestr);
Term *realarity = mkinteger(arityint);
if(unify(name, realname, bindings) && unify(arity, realarity, bindings))
return 1;
}
return 0;
}
int
builtinarg(Term *goal, Binding **bindings, Module *module)
{
USED(module);
Term *n = goal->children;
Term *term = n->next;
Term *arg = term->next;
if(n->tag == VariableTerm || term->tag == VariableTerm)
Throw(instantiationerror());
if(n->tag != IntegerTerm)
Throw(typeerror(L"integer", n));
if(term->tag != CompoundTerm)
Throw(typeerror(L"compound", term));
if(n->ival < 0)
Throw(domainerror(L"not_less_than_zero", n));
if(n->ival > term->arity)
return 0;
int i;
Term *t;
for(i = 1, t = term->children; i < n->ival; i++, t = t->next);
return unify(arg, t, bindings);
}
int
listlength(Term *term)
{
if(term->tag == AtomTerm && runestrcmp(term->text, L"[]") == 0)
return 0;
else if(term->tag == CompoundTerm && term->arity == 2 && runestrcmp(term->text, L".") == 0){
int taillength = listlength(term->children->next);
return (taillength == -1) ? -1 : 1 + taillength;
}else
return -1;
}
int
builtinuniv(Term *goal, Binding **bindings, Module *module)
{
USED(module);
Term *term = goal->children;
Term *list = term->next;
if(term->tag == VariableTerm && ispartiallist(list))
Throw(instantiationerror());
if(!(ispartiallist(list) || islist(list)))
Throw(typeerror(L"list", list));
Term *head = listhead(list);
Term *tail = listtail(list);
if(term->tag == VariableTerm && head->tag == VariableTerm)
Throw(instantiationerror());
if(islist(list) && !(head->tag == AtomTerm || head->tag == VariableTerm) && !isemptylist(tail))
Throw(typeerror(L"atom", head));
if(islist(list) && head->tag == CompoundTerm && isemptylist(tail))
Throw(typeerror(L"atomic", head));
if(term->tag == VariableTerm && isemptylist(list))
Throw(domainerror(L"non_empty_list", list));
int len;
if(term->tag == VariableTerm){
Rune *name;
Term *elems = nil;
Term *realterm;
int i;
len = listlength(list);
if(len < 1)
return 0;
if(list->children->tag != AtomTerm)
return 0;
name = list->children->text;
list = list->children->next;
for(i = 1; i < len; i++){
Term *t = copyterm(list->children, nil);
elems = appendterm(elems, t);
list = list->children->next;
}
realterm = mkcompound(name, len-1, elems);
return unify(term, realterm, bindings);
}else if(term->tag == CompoundTerm){
Term *elems = mkatom(term->text);
elems->next = term->children;
Term *reallist = mklist(elems);
return unify(list, reallist, bindings);
}else{
Term *t = copyterm(term, nil);
t->next = mkatom(L"[]");
Term *reallist = mkcompound(L".", 2, t);
return unify(list, reallist, bindings);
}
}
int
builtincopyterm(Term *goal, Binding **bindings, Module *module)
{
USED(module);
Term *term1 = goal->children;
Term *term2 = term1->next;
Term *t = copyterm(term1, &clausenr);
clausenr++;
return unify(term2, t, bindings);
}
int
builtinis(Term *goal, Binding **bindings, Module *module)
{
USED(module);
Term *result = goal->children;
Term *expr = result->next;
int waserror;
Term *realresult = aritheval(expr, &waserror);
if(waserror)
Throw(realresult);
return unify(result, realresult, bindings);
}
int
builtincatch(Term *goal, Binding **bindings, Module *module)
{
USED(bindings);
Term *catchgoal = goal->children;
Term *catcher = catchgoal->next;
Term *recover = catcher->next;
Goal *catchframe = gmalloc(sizeof(Goal));
catchframe->goal = recover;
catchframe->module = module;
catchframe->catcher = catcher;
catchframe->next = goalstack;
goalstack = catchframe;
Goal *g = gmalloc(sizeof(Goal));
g->goal = catchgoal;
g->module = module;
g->catcher = nil;
g->next = goalstack;
goalstack = g;
return 1;
}
int
builtinthrow(Term *goal, Binding **bindings, Module *module)
{
USED(bindings);
USED(module);
Term *ball = goal->children;
print("Throwing: %S\n", prettyprint(ball, 0, 0, 0));
Goal *g;
for(g = goalstack; g != nil; g = g->next){
if(g->catcher == nil)
continue;
if(unify(g->catcher, ball, bindings)){
if(g->goal == nil){
/* As soon as we have print facilities as builtins, we can avoid this by having the protector frame have a unhandled exception handler*/
print("Unhandled exception: %S\n", prettyprint(ball, 0, 0, 0));
exits("exception");
return 0;
}else{
goalstack = g->next;
Goal *newgoal = gmalloc(sizeof(Goal));
newgoal->goal = copyterm(g->goal, nil);
newgoal->module = module;
newgoal->catcher = nil;
newgoal->next = goalstack;
goalstack = newgoal;
applybinding(newgoal->goal, *bindings);
Choicepoint *cp = choicestack;
while(cp != nil && cp->id >= goal->clausenr)
cp = cp->next;
choicestack = cp;
return 1;
}
}
}
return 0;
}
int
builtincurrentprologflag(Term *goal, Binding **bindings, Module *module)
{
USED(goal);
USED(bindings);
USED(module);
return 0;
}
int
builtinsetprologflag(Term *goal, Binding **bindings, Module *module)
{
USED(bindings);
USED(module);
Term *key = goal->children;
Term *value = key->next;
if(key->tag == VariableTerm || value->tag == VariableTerm)
Throw(instantiationerror());
if(key->tag != AtomTerm)
Throw(typeerror(L"atom", key));
Term *error = setflag(key->text, value);
if(error)
Throw(error);
return 1;
}
int
builtinopen(Term *goal, Binding **bindings, Module *module)
{
USED(bindings);
USED(module);
Term *sourcesink = goal->children;
Term *mode = sourcesink->next;
Term *stream = mode->next;
Term *options = stream->next;
if(sourcesink->tag == VariableTerm || mode->tag == VariableTerm || options->tag == VariableTerm)
Throw(instantiationerror());
if(stream->tag != VariableTerm)
Throw(typeerror(L"variable", stream));
if(options->tag != AtomTerm || runestrcmp(options->text, L"[]") != 0)
Throw(typeerror(L"empty_list", options));
if(mode->tag != AtomTerm)
Throw(typeerror(L"atom", mode));
if(sourcesink->tag != AtomTerm)
Throw(domainerror(L"source_sink", sourcesink));
Term *newstream;
int error = openstream(sourcesink->text, mode->text, options, &newstream);
if(error)
Throw(newstream);
else
return unify(stream, newstream, bindings);
return 0;
}
int
builtinclose(Term *goal, Binding **bindings, Module *module)
{
USED(bindings);
USED(module);
Term *stream = goal->children;
Term *options = stream->next;
if(stream->tag == VariableTerm || options->tag == VariableTerm)
Throw(instantiationerror());
if(options->tag != AtomTerm || runestrcmp(options->text, L"[]") != 0)
Throw(typeerror(L"empty_list", options));
if(stream->tag != IntegerTerm && stream->tag != AtomTerm)
Throw(domainerror(L"stream_or_alias", stream));
if(!isopenstream(stream))
Throw(existenceerror(L"stream", stream));
closestream(stream);
return 1;
}
int
builtincurrentinput(Term *goal, Binding **bindings, Module *module)
{
USED(bindings);
USED(module);
Term *stream = goal->children;
if(stream->tag != VariableTerm && stream->tag != IntegerTerm)
Throw(domainerror(L"stream", stream));
Term *current = currentinputstream();
return unify(stream, current, bindings);
}
int
builtincurrentoutput(Term *goal, Binding **bindings, Module *module)
{
USED(bindings);
USED(module);
Term *stream = goal->children;
if(stream->tag != VariableTerm && stream->tag != IntegerTerm)
Throw(domainerror(L"stream", stream));
Term *current = currentoutputstream();
return unify(stream, current, bindings);
}
int
builtinsetinput(Term *goal, Binding **bindings, Module *module)
{
USED(bindings);
USED(module);
Term *stream = goal->children;
if(stream->tag == VariableTerm)
Throw(instantiationerror());
if(stream->tag != IntegerTerm && stream->tag != AtomTerm)
Throw(domainerror(L"stream_or_alias", stream));
if(!isopenstream(stream))
Throw(existenceerror(L"stream", stream));
if(!isinputstream(stream))
Throw(permissionerror(L"input", L"stream", stream));
setcurrentinputstream(stream);
return 1;
}
int
builtinsetoutput(Term *goal, Binding **bindings, Module *module)
{
USED(bindings);
USED(module);
Term *stream = goal->children;
if(stream->tag == VariableTerm)
Throw(instantiationerror());
if(stream->tag != IntegerTerm && stream->tag != AtomTerm)
Throw(domainerror(L"stream_or_alias", stream));
if(!isopenstream(stream))
Throw(existenceerror(L"stream", stream));
if(!isoutputstream(stream))
Throw(permissionerror(L"output", L"stream", stream));
setcurrentoutputstream(stream);
return 1;
}
Term *
readtermvars(Term *t)
{
Term *vars;
switch(t->tag){
case VariableTerm:
vars = copyterm(t, nil);
break;
case CompoundTerm:
vars = nil;
int n = t->arity;
for(t = t->children; n > 0; t = t->next, n--){
Term *childvars = readtermvars(t);
while(childvars){
Term *childvarscopy = copyterm(childvars, nil);
vars = appendterm(vars, childvarscopy);
childvars = childvars->next;
}
}
break;
default:
vars = nil;
}
return vars;
}
Term *
varsandnames(Term *vars)
{
Term *varsnames = nil;
Term *var;
for(var = vars; var != nil; var = var->next){
if(runestrcmp(var->text, L"_") == 0)
continue;
Term *varname = mkatom(var->text);
varname->next = copyterm(var, nil);
Term *pair = mkcompound(L"=", 2, varname);
varsnames = appendterm(varsnames, pair);
}
return varsnames;
}
Term *
singletons(Term *vars)
{
Term *var;
Term *varsnames = varsandnames(vars);
Term *singles = nil;
for(var = varsnames; var != nil; var = var->next){
Term *tmp;
int duplicate = 0;
for(tmp = varsnames; tmp != nil ; tmp = tmp->next){
if(tmp == var)
continue;
if(runestrcmp(var->children->text, tmp->children->text) == 0){
duplicate = 1;
break;
}
}
if(!duplicate)
singles = appendterm(singles, copyterm(var, nil));
}
return singles;
}
int
builtinreadterm(Term *goal, Binding **bindings, Module *module)
{
USED(bindings);
USED(module);
Term *stream = goal->children;
Term *term = stream->next;
Term *options = term->next;
if(stream->tag == VariableTerm)
Throw(instantiationerror());
if(stream->tag != IntegerTerm && stream->tag != AtomTerm)
Throw(domainerror(L"stream_or_alias", stream));
if(!isopenstream(stream))
Throw(existenceerror(L"stream", stream));
if(isoutputstream(stream))
Throw(permissionerror(L"input", L"stream", stream));
if(isbinarystream(stream))
Throw(permissionerror(L"input", L"binary_stream", stream));
Term *realterm;
int error = readterm(stream, &realterm);
if(error)
Throw(realterm);
Term *singlevars = nil;
Term *uniquevars = nil;
Term *varsnames = nil;
if(options->tag == CompoundTerm){
Term *allvars = readtermvars(realterm);
Term *tmp1;
for(tmp1 = allvars; tmp1 != nil; tmp1 = tmp1->next){
Term *tmp2;
int duplicate = 0;
for(tmp2 = uniquevars; tmp2 != nil; tmp2 = tmp2->next){
if(runestrcmp(tmp2->text, tmp1->text) == 0){
duplicate = 1;
break;
}
}
if(!duplicate){
Term *v = copyterm(tmp1, nil);
uniquevars = appendterm(uniquevars, v);
}
}
varsnames = varsandnames(uniquevars);
singlevars = singletons(allvars);
}
Term *op;
for(op = options; op->tag == CompoundTerm; op = op->children->next){
Term *opkey = op->children->children;
Term *opval = opkey->next;
if(runestrcmp(opkey->text, L"variables") == 0){
Term *variablelist = mklist(uniquevars);
if(unify(opval, variablelist, bindings) == 0)
return 0;
}else if(runestrcmp(opkey->text, L"variable_names") == 0){
Term *list = mklist(varsnames);
if(unify(opval, list, bindings) == 0)
return 0;
}else if(runestrcmp(opkey->text, L"singletons") == 0){
Term *list = mklist(singlevars);
if(unify(opval, list, bindings) == 0)
return 0;
}
}
return unify(term, realterm, bindings);
}
int
builtinwriteterm(Term *goal, Binding **bindings, Module *module)
{
USED(bindings);
USED(module);
Term *stream = goal->children;
Term *term = stream->next;
Term *options = term->next;
if(stream->tag == VariableTerm)
Throw(instantiationerror());
if(options->tag != AtomTerm || runestrcmp(options->text, L"[]") != 0)
Throw(typeerror(L"empty_list", options));
if(stream->tag != IntegerTerm && stream->tag != AtomTerm)
Throw(domainerror(L"stream_or_alias", stream));
if(!isopenstream(stream))
Throw(existenceerror(L"stream", stream));
if(isinputstream(stream))
Throw(permissionerror(L"output", L"stream", stream));
if(isbinarystream(stream))
Throw(permissionerror(L"output", L"binary_stream", stream));
writeterm(stream, options, term);
return 1;
}
int
builtingeq(Term *goal, Binding **bindings, Module *module)
{
USED(bindings);
USED(module);
Term *a = goal->children;
Term *b = a->next;
int waserror;
Term *aval = aritheval(a, &waserror);
if(waserror)
Throw(aval);
Term *bval = aritheval(b, &waserror);
if(waserror)
Throw(bval);
if(aval->tag == IntegerTerm && bval->tag == IntegerTerm)
return aval->ival >= bval->ival;
else if(aval->tag == FloatTerm && bval->tag == FloatTerm)
return aval->dval >= bval->dval;
else if(aval->tag == IntegerTerm && bval->tag == FloatTerm)
return aval->ival >= bval->dval;
else if(aval->tag == FloatTerm && bval->tag == IntegerTerm)
return aval->dval >= bval->ival;
else
return 0;
}
int
builtinclause(Term *goal, Binding **bindings, Module *module)
{
Term *head = goal->children;
Term *body = head->next;
Term *clauselist = body->next;
if(head->tag == VariableTerm)
Throw(instantiationerror());
if(head->tag != AtomTerm && head->tag != CompoundTerm)
Throw(typeerror(L"callable", head));
if(body->tag != VariableTerm && body->tag != AtomTerm && body->tag != CompoundTerm)
Throw(typeerror(L"callable", body));
if(clauselist->tag != VariableTerm)
Throw(typeerror(L"variable", clauselist));
Predicate *pred = findpredicate(module->predicates, head);
if(pred == nil)
return 0;
Term *functor = mkatom(pred->name);
functor->next = mkinteger(pred->arity);
Term *pi = mkcompound(L"/", 2, functor);
if(!pred->public)
Throw(permissionerror(L"access", L"private_procedure", pi));
Term *realclauses = nil;
Clause *c = pred->clauses;
while(c != nil){
Binding *bs = nil;
c = findclause(c, head, &bs);
if(c != nil){
/* Append the clause to the realclauselist */
Term *cl = c->head;
if(c->body)
cl->next = c->body;
else
cl->next = mkatom(L"true");
realclauses = appendterm(realclauses, mkcompound(L"clause", 2, cl));
c = c->next;
}
}
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);
}
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;
}
int
builtinatomlength(Term *goal, Binding **bindings, Module *module)
{
USED(module);
Term *atom = goal->children;
Term *length = atom->next;
if(atom->tag == VariableTerm)
Throw(instantiationerror());
if(atom->tag != AtomTerm)
Throw(typeerror(L"atom", atom));
if(length->tag != VariableTerm && length->tag != IntegerTerm)
Throw(typeerror(L"integer", length));
if(length->tag == IntegerTerm && length->ival < 0)
Throw(domainerror(L"not_less_than_zero", length));
int len = runestrlen(atom->text);
Term *reallength = mkinteger(len);
return unify(length, reallength, bindings);
}
int
builtinatomcodes(Term *goal, Binding **bindings, Module *module)
{
USED(module);
Term *atom = goal->children;
Term *list = atom->next;
if(atom->tag == VariableTerm && ispartiallist(list))
Throw(instantiationerror());
if(atom->tag != VariableTerm && atom->tag != AtomTerm)
Throw(typeerror(L"atom", atom));
if(atom->tag == VariableTerm && !(islist(list) || ispartiallist(list)))
Throw(typeerror(L"list", list));
if(atom->tag == AtomTerm){
int oldflag = flagdoublequotes;
flagdoublequotes = DoubleQuotesCodes;
Term *reallist = mkstring(atom->text);
flagdoublequotes = oldflag;
return unify(list, reallist, bindings);
}else{
int bufsize = 2048;
Rune *buf = malloc(sizeof(Rune) * bufsize);
int i = 0;
Term *c;
for(c = list; c->tag == CompoundTerm; c = c->children->next, i++){
if(i >= bufsize){
bufsize += 2048;
buf = realloc(buf, sizeof(Rune) * bufsize);
}
if(c->children->tag == VariableTerm)
Throw(instantiationerror());
if(c->children->tag != IntegerTerm)
Throw(representationerror(L"character_code"));
buf[i] = c->children->ival;
}
buf[i] = '\0';
Term *realatom = mkatom(buf);
return unify(atom, realatom, bindings);
}
}