shithub: pprolog

ref: 2bf351a2f4a0e364d137f50fc67e3eadbdf22e7e
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 = getmodule(L"user"); \
	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(builtincurrentprologflags);
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(builtininsertclause);
BuiltinProto(builtinretractone);
BuiltinProto(builtinabolish);
BuiltinProto(builtinatomlength);
BuiltinProto(builtinatomcodes);
BuiltinProto(builtingetchar);
BuiltinProto(builtinpeekchar);
BuiltinProto(builtinputchar);
BuiltinProto(builtincharcode);
BuiltinProto(builtinchoicestacksize);
BuiltinProto(builtincollectgarbage);
BuiltinProto(builtinflushoutput);
BuiltinProto(builtinstreamproperties);
BuiltinProto(builtinsetstreamposition);
BuiltinProto(builtinop);
BuiltinProto(builtincurrentops);
BuiltinProto(builtinnewemptymodule);
BuiltinProto(builtindeletemodule);
BuiltinProto(builtinactivatesystemmodule);
BuiltinProto(builtinhalt);

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_flags", 1))
		return builtincurrentprologflags;
	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"$insert_clause", 1))
		return builtininsertclause;
	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;
	if(Match(L"get_char", 2))
		return builtingetchar;
	if(Match(L"peek_char", 2))
		return builtinpeekchar;
	if(Match(L"put_char", 2))
		return builtinputchar;
	if(Match(L"char_code", 2))
		return builtincharcode;
	if(Match(L"$choicestack_size", 1))
		return builtinchoicestacksize;
	if(Match(L"$collect_garbage", 0))
		return builtincollectgarbage;
	if(Match(L"flush_output", 1))
		return builtinflushoutput;
	if(Match(L"stream_properties", 1))
		return builtinstreamproperties;
	if(Match(L"set_stream_position", 2))
		return builtinsetstreamposition;
	if(Match(L"$op", 3))
		return builtinop;
	if(Match(L"current_ops", 1))
		return builtincurrentops;
	if(Match(L"$new_empty_module", 1))
		return builtinnewemptymodule;
	if(Match(L"$delete_module", 1))
		return builtindeletemodule;
	if(Match(L"$activate_system_module", 0))
		return builtinactivatesystemmodule;
	if(Match(L"$halt", 1))
		return builtinhalt;

	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
canbecalled(Term *t)
{
	if(t->tag == VariableTerm || t->tag == AtomTerm)
		return 1;
	if(t->tag != CompoundTerm)
		return 0;

	if(t->arity == 2 && (runestrcmp(t->text, L",") == 0 || runestrcmp(t->text, L";") == 0))
		return canbecalled(t->children) && canbecalled(t->children->next);
	else
		return 1;
}

void
updateclausenr(Term *t, uvlong nr)
{
	/* Change the clause number on the term and its subterms, unless it is a variable */
	if(t->tag == VariableTerm)
		return;

	t->clausenr = nr;
	if(t->tag == CompoundTerm){
		Term *child;
		for(child = t->children; child != nil; child = child->next)
			updateclausenr(child, nr);
	}
}

int
builtincall(Term *goal, Binding **bindings, Module *module)
{
	USED(bindings);
	Term *callgoal = goal->children;

	if(!canbecalled(callgoal))
		Throw(typeerror(L"callable", callgoal));

	updateclausenr(callgoal, clausenr);
	clausenr++;

	goalstack = addgoals(goalstack, callgoal, 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)
{
	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, module);
			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;

	goalstack = addgoals(goalstack, catchgoal, module);
	return 1;
}

int
builtinthrow(Term *goal, Binding **bindings, Module *module)
{
	USED(bindings);
	USED(module);

	Term *ball = goal->children;

	Goal *g;
	for(g = goalstack; g != nil; g = g->next){
		if(g->catcher == nil)
			continue;

		if(unify(g->catcher, ball, bindings)){
			goalstack = g->next;
			Goal *newgoal = gmalloc(sizeof(Goal));
			newgoal->goal = copyterm(g->goal, nil);
			newgoal->module = g->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
builtincurrentprologflags(Term *goal, Binding **bindings, Module *module)
{
	USED(module);
	Term *flagsandvals = goal->children;
	Term *list = getallflags();
	Term *realflagsandvals = mklist(list);
	return unify(flagsandvals, realflagsandvals, bindings);
}

int
builtinsetprologflag(Term *goal, Binding **bindings, Module *module)
{
	USED(bindings);
	USED(module);
	Term *key = goal->children;
	Term *value = key->next;

	setflag(key->text, value);
	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);

	if(realterm == nil)
		Throw(syntaxerror(L"end of stream"));

	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(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, module);
	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, int dynamic)
{
	/* 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(head->tag == VariableTerm)
		Throw(instantiationerror());
	if(head->tag != AtomTerm && head->tag != CompoundTerm)
		Throw(typeerror(L"callable", head));
	if(body->tag != AtomTerm && body->tag != CompoundTerm && body->tag != VariableTerm)
		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 && 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 = dynamic;
	p->builtin = 0;
	p->dynamic = dynamic;
	p->next = nil;
	module->predicates = appendpredicate(p, module->predicates);

	return 1;
}

int
builtinasserta(Term *goal, Binding **bindings, Module *module)
{
	USED(bindings);
	return assertclause(goal->children, module, 0, 1);
}

int
builtinassertz(Term *goal, Binding **bindings, Module *module)
{
	USED(bindings);
	return assertclause(goal->children, module, 1, 1);
}

int
builtininsertclause(Term *goal, Binding **bindings, Module *module)
{
	USED(bindings);
	return assertclause(goal->children, module, 1, 0);
}

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

int
builtingetchar(Term *goal, Binding **bindings, Module *module)
{
	USED(module);
	Term *s = goal->children;
	Term *ch = s->next;

	if(s->tag == VariableTerm)
		Throw(instantiationerror());
	if(ch->tag != VariableTerm && !(ch->tag == AtomTerm && runestrlen(ch->text) == 1))
		Throw(typeerror(L"in_character", ch));
	if(s->tag != IntegerTerm && s->tag != AtomTerm)
		Throw(domainerror(L"stream_or_alias", s));
	if(!isopenstream(s))
		Throw(existenceerror(L"stream", s));
	if(isoutputstream(s))
		Throw(permissionerror(L"input", L"stream", s));
	if(isbinarystream(s))
		Throw(permissionerror(L"input", L"binary_stream", s));

	Rune r = getchar(s);
	Term *realch;
	if(r == Beof)
		realch = mkatom(L"end_of_file");
	else
		realch = mkatom(runesmprint("%C", r));
	return unify(ch, realch, bindings);
}

int
builtinpeekchar(Term *goal, Binding **bindings, Module *module)
{
	USED(module);
	Term *s = goal->children;
	Term *ch = s->next;

	if(s->tag == VariableTerm)
		Throw(instantiationerror());
	if(ch->tag != VariableTerm && !(ch->tag == AtomTerm && runestrlen(ch->text) == 1))
		Throw(typeerror(L"in_character", ch));
	if(s->tag != IntegerTerm && s->tag != AtomTerm)
		Throw(domainerror(L"stream_or_alias", s));
	if(!isopenstream(s))
		Throw(existenceerror(L"stream", s));
	if(isoutputstream(s))
		Throw(permissionerror(L"input", L"stream", s));
	if(isbinarystream(s))
		Throw(permissionerror(L"input", L"binary_stream", s));

	Rune r = peekchar(s);
	Term *realch;
	if(r == Beof)
		realch = mkatom(L"end_of_file");
	else
		realch = mkatom(runesmprint("%C", r));
	return unify(ch, realch, bindings);
}

int
builtinputchar(Term *goal, Binding **bindings, Module *module)
{
	USED(module);
	USED(bindings);
	Term *s = goal->children;
	Term *ch = s->next;

	if(s->tag == VariableTerm || ch->tag == VariableTerm)
		Throw(instantiationerror());
	if(ch->tag != AtomTerm || runestrlen(ch->text) != 1)
		Throw(typeerror(L"character", ch));
	if(s->tag != IntegerTerm && s->tag != AtomTerm)
		Throw(domainerror(L"stream_or_alias", s));
	if(!isopenstream(s))
		Throw(existenceerror(L"stream", s));
	if(!isoutputstream(s))
		Throw(permissionerror(L"output", L"stream", s));
	if(isbinarystream(s))
		Throw(permissionerror(L"output", L"binary_stream", s));

	putchar(s, ch->text[0]);
	return 1;
}

int
builtincharcode(Term *goal, Binding **bindings, Module *module)
{
	USED(module);
	Term *ch = goal->children;
	Term *code = ch->next;

	if(ch->tag == VariableTerm && code->tag == VariableTerm)
		Throw(instantiationerror());
	if(ch->tag != VariableTerm && !(ch->tag == AtomTerm && runestrlen(ch->text) == 1))
		Throw(typeerror(L"character", ch));
	if(code->tag != VariableTerm && code->tag != IntegerTerm)
		Throw(typeerror(L"integer", code));
	if(code->ival < 0)
		Throw(representationerror(L"character_code"));

	if(ch->tag == VariableTerm){
		Term *realch = mkatom(runesmprint("%C", (Rune)code->ival));
		return unify(ch, realch, bindings);
	}else{
		Term *realcode = mkinteger(ch->text[0]);
		return unify(code, realcode, bindings);
	}
}

int
builtinchoicestacksize(Term *goal, Binding **bindings, Module *module)
{
	USED(bindings);
	USED(module);
	Term *size = goal->children;
	
	vlong i = 0;
	Choicepoint *cp;
	for(cp = choicestack; cp != nil; cp = cp->next)
		i++;
	Term *realsize = mkinteger(i);
	return unify(size, realsize, bindings);
}

int
builtincollectgarbage(Term *goal, Binding **bindings, Module *module)
{
	USED(goal);
	USED(bindings);
	USED(module);
	vlong amount = collectgarbage();
	if(amount != 0 & flagdebug)
		print("Collected %lld bytes of garbage\n", amount);
	return 1;
}

int
builtinflushoutput(Term *goal, Binding **bindings, Module *module)
{
	USED(bindings);
	USED(module);
	Term *s = goal->children;

	if(s->tag == VariableTerm)
		Throw(instantiationerror());
	if(s->tag != IntegerTerm && s->tag != AtomTerm)
		Throw(domainerror(L"stream_or_alias", s));
	if(!isopenstream(s))
		Throw(existenceerror(L"stream", s));
	if(!isoutputstream(s))
		Throw(permissionerror(L"output", L"stream", s));

	flushstream(s);
	return 1;
}

int
builtinstreamproperties(Term *goal, Binding **bindings, Module *module)
{
	USED(module);
	USED(bindings);
	Term *props = goal->children;
	Term *list = streamsproperties();
	Term *realprops = mklist(list);
	return unify(props, realprops, bindings);
}

int
builtinsetstreamposition(Term *goal, Binding **bindings, Module *module)
{
	USED(module);
	USED(bindings);
	Term *s = goal->children;
	Term *pos = s->next;

	if(s->tag == VariableTerm || pos->tag == VariableTerm)
		Throw(instantiationerror());
	if(s->tag != IntegerTerm && s->tag != AtomTerm)
		Throw(domainerror(L"stream_or_alias", s));
	if(pos->tag != IntegerTerm || pos->ival < 0)
		Throw(domainerror(L"stream_position", pos));
	if(!isopenstream(s))
		Throw(existenceerror(L"stream", s));
	if(!canreposition(s))
		Throw(permissionerror(L"reposition", L"stream", s));

	reposition(s, pos->ival);
	return 1;
}

int
builtinop(Term *goal, Binding **bindings, Module *module)
{
	USED(bindings);
	Term *priority = goal->children;
	Term *specifier = priority->next;
	Term *operator = specifier->next;

	if(runestrcmp(operator->text, L",") == 0 && runestrcmp(module->name, L"system") != 0)
		Throw(permissionerror(L"modify", L"operator", operator));

	int type = 0;
	if(runestrcmp(specifier->text, L"xf") == 0)
		type = Xf;
	else if(runestrcmp(specifier->text, L"yf") == 0)
		type = Yf;
	else if(runestrcmp(specifier->text, L"xfx") == 0)
		type = Xfx;
	else if(runestrcmp(specifier->text, L"xfy") == 0)
		type = Xfy;
	else if(runestrcmp(specifier->text, L"yfx") == 0)
		type = Yfx;
	else if(runestrcmp(specifier->text, L"fy") == 0)
		type = Fy;
	else if(runestrcmp(specifier->text, L"fx") == 0)
		type = Fx;

	addoperator(priority->ival, type, operator->text, module);
	return 1;
}

int
builtincurrentops(Term *goal, Binding **bindings, Module *module)
{
	Term *ops = goal->children;
	Term *oplist = nil;

	int level;
	for(level = 0; level < PrecedenceLevels; level++){
		Operator *o;
		for(o = module->operators[level]; o != nil; o = o->next){
			int type = o->type;
			while(type != 0){
				Term *args = mkinteger(o->level);
				if(type & Xf){
					args->next = mkatom(L"xf");
					type = type^Xf;
				}else if(type & Yf){
					args->next = mkatom(L"yf");
					type = type^Yf;
				}else if(type & Xfx){
					args->next = mkatom(L"xfx");
					type = type^Xfx;
				}else if(type & Xfy){
					args->next = mkatom(L"xfy");
					type = type^Xfy;
				}else if(type & Yfx){
					args->next = mkatom(L"yfx");
					type = type^Yfx;
				}else if(type & Fx){
					args->next = mkatom(L"fx");
					type = type^Fx;
				}else if(type & Fy){
					args->next = mkatom(L"fy");
					type = type^Fy;
				}
				args->next->next = mkatom(o->spelling);
				Term *op = mkcompound(L"op", 3, args);
				oplist = appendterm(oplist, op);
			}
		}
	}

	Term *realops = mklist(oplist);
	return unify(ops, realops, bindings);
}

int
builtinnewemptymodule(Term *goal, Binding **bindings, Module *module)
{
	USED(bindings);
	USED(module);
	Rune *name = goal->children->text;
	addemptymodule(name);
	return 1;
}

int
builtindeletemodule(Term *goal, Binding **bindings, Module *module)
{
	USED(bindings);
	USED(module);
	Rune *name = goal->children->text;
	removemodule(name);
	return 1;
}

int
builtinactivatesystemmodule(Term *goal, Binding **bindings, Module *module)
{
	USED(bindings);
	USED(module);
	USED(goal);
	systemmoduleloaded = 1;
	return 1;
}

int
builtinhalt(Term *goal, Binding **bindings, Module *module)
{
	USED(bindings);
	USED(module);
	vlong exitcode = goal->children->ival;
	char *msg = nil;
	if(exitcode != 0)
		msg = smprint("pprolog exit code: %lld\n", exitcode);

	exits(msg);
	return 1;
}