From 48da622d4ad0b4acfe9005dd318ac3f20b4e8672 Mon Sep 17 00:00:00 2001 From: Peter Mikkelsen Date: Thu, 22 Jul 2021 21:54:46 +0000 Subject: Big commit changing the way the system is loaded at startup. 1) The loader and system modules are loaded by the C directly into the user module 2) The system module is then loaded with the loader from the user module 3) The loader module is then loaded with the loader from the user module 4) The repl is then loaded with the loader from the loader module 5) The user module is cleared --- builtins.c | 54 ++--- dat.h | 4 +- eval.c | 11 +- fns.h | 3 +- loader.pl | 44 ++-- main.c | 9 +- mkfile | 2 +- module.c | 86 +++----- parser.c | 23 +- prettyprint.c | 2 +- stdlib.pl | 699 ---------------------------------------------------------- system.pl | 699 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 12 files changed, 812 insertions(+), 824 deletions(-) delete mode 100644 stdlib.pl create mode 100644 system.pl diff --git a/builtins.c b/builtins.c index 79c71f0..6dda64f 100644 --- a/builtins.c +++ b/builtins.c @@ -10,7 +10,7 @@ #define Throw(What) do{\ Goal *g = gmalloc(sizeof(Goal)); \ g->goal = What; \ - g->module = usermodule; \ + g->module = getmodule(L"user"); \ g->catcher = nil; \ g->next = goalstack; \ goalstack = g; \ @@ -63,13 +63,14 @@ BuiltinProto(builtinputchar); BuiltinProto(builtincharcode); BuiltinProto(builtinchoicestacksize); BuiltinProto(builtincollectgarbage); -BuiltinProto(builtinloadmodulefromfile); BuiltinProto(builtinflushoutput); BuiltinProto(builtinstreamproperties); BuiltinProto(builtinsetstreamposition); BuiltinProto(builtinop); BuiltinProto(builtincurrentops); BuiltinProto(builtinnewemptymodule); +BuiltinProto(builtindeletemodule); +BuiltinProto(builtinactivatesystemmodule); BuiltinProto(builtinhalt); int compareterms(Term *, Term *); @@ -186,8 +187,6 @@ findbuiltin(Term *goal) return builtinchoicestacksize; if(Match(L"$collect_garbage", 0)) return builtincollectgarbage; - if(Match(L"$load_module_from_file", 1)) - return builtinloadmodulefromfile; if(Match(L"flush_output", 1)) return builtinflushoutput; if(Match(L"stream_properties", 1)) @@ -200,6 +199,10 @@ findbuiltin(Term *goal) 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; @@ -1491,27 +1494,6 @@ builtincollectgarbage(Term *goal, Binding **bindings, Module *module) return 1; } -int -builtinloadmodulefromfile(Term *goal, Binding **bindings, Module *module) -{ - USED(bindings); - USED(module); - Term *file = goal->children; - - if(file->tag == VariableTerm) - Throw(instantiationerror()); - if(file->tag != AtomTerm) - Throw(typeerror(L"atom", file)); - - char *filestr = smprint("%S", file->text); - Module *m = parsemodule(filestr); - free(filestr); - if(m) - return 1; - else - return 0; -} - int builtinflushoutput(Term *goal, Binding **bindings, Module *module) { @@ -1574,7 +1556,7 @@ builtinop(Term *goal, Binding **bindings, Module *module) Term *specifier = priority->next; Term *operator = specifier->next; - if(runestrcmp(operator->text, L",") == 0) + if(runestrcmp(operator->text, L",") == 0 && runestrcmp(module->name, L"system") != 0) Throw(permissionerror(L"modify", L"operator", operator)); int type = 0; @@ -1653,6 +1635,26 @@ builtinnewemptymodule(Term *goal, Binding **bindings, Module *module) 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) { diff --git a/dat.h b/dat.h index 72a95b5..d6adb18 100644 --- a/dat.h +++ b/dat.h @@ -154,7 +154,5 @@ int flagdoublequotes; Choicepoint *choicestack; Goal *goalstack; Module *modules; -Module *systemmodule; /* The module for the builtins. Everything has access to those */ -Module *usermodule; /* The default module for user defined predicates */ uvlong clausenr; - +int systemmoduleloaded; /* Is the module "system" ready to be used */ diff --git a/eval.c b/eval.c index e57f28f..4391110 100644 --- a/eval.c +++ b/eval.c @@ -14,7 +14,7 @@ int evalquery(Term *query) { Binding *replbindings = nil; - goalstack = addgoals(goalstack, query, usermodule); + goalstack = addgoals(goalstack, query, getmodule(L"user")); while(goalstack->goal != nil){ Term *goal = goalstack->goal; @@ -44,6 +44,15 @@ evalquery(Term *query) goto Backtrack; }else{ Predicate *pred = findpredicate(module->predicates, goal); + if(pred == nil){ + /* To to find it in the system module */ + Module *sysmod; + if(systemmoduleloaded) + sysmod = getmodule(L"system"); + else + sysmod = getmodule(L"user"); + pred = findpredicate(sysmod->predicates, goal); + } if(pred == nil){ Rune *name; int arity; diff --git a/fns.h b/fns.h index f3d9ebd..e2785ac 100644 --- a/fns.h +++ b/fns.h @@ -69,9 +69,10 @@ void reposition(Term *, vlong); /* module.c */ void initmodules(void); -Module *parsemodule(char *); +int addtousermod(char *); Module *getmodule(Rune *); Module *addemptymodule(Rune *); +void removemodule(Rune *); Clause *appendclause(Clause *, Clause *); Predicate *appendpredicate(Predicate *, Predicate *); Operator *getoperator(Rune *, Module *); diff --git a/loader.pl b/loader.pl index 99478d0..d688e46 100644 --- a/loader.pl +++ b/loader.pl @@ -1,14 +1,29 @@ :- module(loader, []). start(Args) :- - catch((load_module_from_file('/sys/lib/prolog/repl.pl'), ReplLoaded = true), E, (print_exception(E), ReplLoaded = false)), - !, - ( ReplLoaded = true - -> repl:repl(Args) + ( bootstrap([system, loader, repl]) + -> call(repl:repl(Args)) + ; write('Booting pprolog failed..'), halt ). -print_exception(E) :- - write('Caught exception while loading /sys/lib/prolog/repl.pl: '), +bootstrap([]) :- '$delete_module'(user), '$new_empty_module'(user). +bootstrap([Mod|Mods]) :- + system_mod_path(Mod, File), + catch(load_module_from_file(File), E, (print_exception(File, E), fail)), + ( Mod == system + -> '$activate_system_module' + ; true + ), + bootstrap(Mods). + +system_mod_path(Mod, Path) :- + atom_concat('/sys/lib/prolog/', Mod, Path0), + atom_concat(Path0, '.pl', Path). + +print_exception(File, E) :- + write('Caught exception while loading '), + write(File), + write(': '), write(E), nl. @@ -25,7 +40,8 @@ load_module_from_file(File) :- run_initialization_goals(Module) :- ( retract(initialization_goals(Module, Goal)), catch(Module:Goal, E, print_initialization_goal_error(Module, Goal, E)), - fail % Backtrack to find more goals + !, + run_initialization_goals(Module) ; true ). @@ -89,7 +105,7 @@ handle_term(Head, Singles, Module, Module) :- handle_clause(Head, Body, Singletons, Module) :- functor(Head, Name, Arity), PredicateIndicator = Name / Arity, - warn_singletons(PredicateIndicator, Singletons), + warn_singletons(PredicateIndicator, Module, Singletons), Module:'$insert_clause'(Head :- Body). handle_directive(dynamic(PI), Module, Module) :- @@ -125,15 +141,17 @@ handle_directive(D, Module, Module) :- write(D), nl. -warn_singletons(_, []). -warn_singletons(PI, Singles) :- - write('Warning: singleton variables in '), - write(PI), - write(': '), +warn_singletons(_, Module, []). +warn_singletons(PI, Module, Singles) :- + write('Warning: singleton variables '), write(Singles), + write(' in '), + write(Module:PI), write('.'), nl. + +:- dynamic(ensure_loads/1). ensure_loads(_) :- fail. ensure_load(F) :- diff --git a/main.c b/main.c index 826ff45..cdaf137 100644 --- a/main.c +++ b/main.c @@ -11,7 +11,6 @@ void repl(int, char **); void main(int argc, char *argv[]) { - clausenr = 2; /* Start at two since 0 is for the facts in the database, and 1 is for queries */ initflags(); initstreams(); initmodules(); @@ -37,10 +36,6 @@ repl(int argc, char *argv[]) argc--; } args = mklist(args); - Term *mod = mkatom(L"loader"); - Term *pred = mkcompound(L"start", 1, args); - - mod->next = pred; - Term *goal = mkcompound(L":", 2, mod); - evalquery(goal); + Term *start = mkcompound(L"start", 1, args); + evalquery(start); } \ No newline at end of file diff --git a/mkfile b/mkfile index 812369b..2a1832f 100644 --- a/mkfile +++ b/mkfile @@ -22,7 +22,7 @@ HFILES=dat.h fns.h BIN=/$objtype/bin PROLOGFILES=\ - stdlib.pl\ + system.pl\ repl.pl\ loader.pl diff --git a/module.c b/module.c index 07786c2..48c2978 100644 --- a/module.c +++ b/module.c @@ -8,55 +8,29 @@ void initmodules(void) { - systemmodule = parsemodule("/sys/lib/prolog/stdlib.pl"); - if(systemmodule == nil){ - print("Can't load /sys/lib/prolog/stdlib.pl\n"); + addemptymodule(L"user"); + if(!addtousermod("/sys/lib/prolog/system.pl")){ + print("Can't load /sys/lib/prolog/system.pl\n"); exits(nil); } - - Predicate *p; - for(p = systemmodule->predicates; p != nil; p = p->next){ - p->builtin = 1; - p->dynamic = 0; + if(!addtousermod("/sys/lib/prolog/loader.pl")){ + print("Can't load /sys/lib/prolog/loader.pl\n"); + exits(nil); } - - usermodule = addemptymodule(L"user"); - parsemodule("/sys/lib/prolog/loader.pl"); } -Module * -parsemodule(char *file) +int +addtousermod(char *file) { - Module *m = nil; - int fd = open(file, OREAD); if(fd < 0) - return nil; + return 0; + Module *usermodule = getmodule(L"user"); Term *terms = parse(fd, nil, 0); if(terms == nil) - return nil; - - /* Actually look at the terms and convert ':-'/2 terms into clauses. - The only directives (terms of type ':-'/1 there should be in the list are - the module specific ones, as the other are handled by parse itself. - */ - if(terms->tag == CompoundTerm && runestrcmp(terms->text, L":-") == 0 && terms->arity == 1){ - Term *directive = terms->children; - if(directive->tag == CompoundTerm && runestrcmp(directive->text, L"module") == 0 && directive->arity == 2){ - Term *modulename = directive->children; - Term *publiclist = modulename->next; - if(modulename->tag != AtomTerm){ - print("Module name should be an atom in: %S\n", prettyprint(directive, 0, 0, 0, nil)); - return nil; - } - if(flagdebug) - print("Public list for module '%S': %S\n", modulename->text, prettyprint(publiclist, 0, 0, 0, nil)); - m = getmodule(modulename->text); - } - terms = terms->next; - } + return 0; Predicate *currentpred = nil; Term *t; @@ -79,10 +53,7 @@ parsemodule(char *file) /* Figure out if this clause goes into the latest predicate, or if it is the start of a new one */ if(currentpred == nil || runestrcmp(cl->head->text, currentpred->name) != 0 || arity != currentpred->arity){ - if(m) - m->predicates = appendpredicate(currentpred, m->predicates); - else - usermodule->predicates = appendpredicate(currentpred, usermodule->predicates); + usermodule->predicates = appendpredicate(currentpred, usermodule->predicates); currentpred = gmalloc(sizeof(Predicate)); currentpred->name = cl->head->text; currentpred->arity = arity; @@ -94,12 +65,8 @@ parsemodule(char *file) }else currentpred->clauses = appendclause(currentpred->clauses, cl); } - if(m) - m->predicates = appendpredicate(currentpred, m->predicates); - else - usermodule->predicates = appendpredicate(currentpred, usermodule->predicates); - - return m; + usermodule->predicates = appendpredicate(currentpred, usermodule->predicates); + return 1; } Module * @@ -119,12 +86,11 @@ addemptymodule(Rune *name) Module *m = gmalloc(sizeof(Module)); m->name = name; m->next = modules; + m->predicates = nil; memset(m->operators, 0, sizeof(m->operators)); - if(systemmodule == nil) - m->predicates = nil; - else{ - m->predicates = systemmodule->predicates; /* Direct access to system clauses for now, but when I figure out imports this will change */ + Module *systemmodule = getmodule(L"system"); + if(systemmodule != nil){ int level; Operator *op; for(level = 0; level < PrecedenceLevels; level++){ @@ -136,6 +102,24 @@ addemptymodule(Rune *name) return m; } +void +removemodule(Rune *name) +{ + Module *m; + Module *prev = nil; + for(m = modules; m != nil; m = m->next){ + if(runestrcmp(m->name, name) != 0) + prev = m; + else{ + if(prev == nil) + modules = m->next; + else + prev->next = m->next; + return; + } + } +} + Clause * appendclause(Clause *clauses, Clause *new) { diff --git a/parser.c b/parser.c index 773a0a2..04b2b68 100644 --- a/parser.c +++ b/parser.c @@ -70,7 +70,7 @@ parse(int fd, Biobuf *bio, int querymode) parsein = bio; nexttoken(); - currentmod = usermodule; + currentmod = getmodule(L"user"); Term *result = prologtext(querymode); if(querymode && result){ @@ -101,12 +101,7 @@ prologtext(int querymode) if(t->tag == CompoundTerm && runestrcmp(t->text, L":-") == 0 && t->arity == 1){ Term *body = t->children; - if(runestrcmp(body->text, L"module") == 0 && body->arity == 2){ - handlemoduledirective(body->children); - t->next = prologtext(querymode); - return t; - } - else if(runestrcmp(body->text, L"op") == 0 && body->arity == 3) + if(runestrcmp(body->text, L"op") == 0 && body->arity == 3) handleopdirective(body->children); t = prologtext(querymode); @@ -578,20 +573,6 @@ syntaxerror_parser(char *where) exits("syntax error"); } -void -handlemoduledirective(Term *args) -{ - Term *modulename = args; - Term *publiclist = modulename->next; - USED(publiclist); - - if(modulename->tag != AtomTerm){ - print("Module name should be an atom in: %S\n", prettyprint(modulename, 0, 0, 0, currentmod)); - return; - } - currentmod = addemptymodule(modulename->text); -} - void handleopdirective(Term *args) { diff --git a/prettyprint.c b/prettyprint.c index ec00583..b980f1e 100644 --- a/prettyprint.c +++ b/prettyprint.c @@ -16,7 +16,7 @@ prettyprint(Term *t, int quoted, int ignoreops, int numbervars, Module *mod) Rune *result; Rune *args; if(mod == nil) - mod = usermodule; + mod = getmodule(L"user"); switch(t->tag){ case CompoundTerm: diff --git a/stdlib.pl b/stdlib.pl deleted file mode 100644 index 19b20d0..0000000 --- a/stdlib.pl +++ /dev/null @@ -1,699 +0,0 @@ -:-(module(system, [])). - -% Insert the standard operators - -:-(op(1200, fx, :-)). -:- op(1200, fx, ?-). -:- op(1200, xfx, :-). -:- op(1200, xfx, -->). -:- op(1100, xfy, ;). -:- op(1050, xfy, ->). -:- op(1000, xfy, ','). -:- op(900, fy, \+). -:- op(700, xfx, =). -:- op(700, xfx, \=). -:- op(700, xfx, ==). -:- op(700, xfx, \==). -:- op(700, xfx, @<). -:- op(700, xfx, @=<). -:- op(700, xfx, @>). -:- op(700, xfx, @>=). -:- op(700, xfx, =..). -:- op(700, xfx, is). -:- op(700, xfx, =:=). -:- op(700, xfx, =\=). -:- op(700, xfx, <). -:- op(700, xfx, =<). -:- op(700, xfx, >). -:- op(700, xfx, >=). -:- op(600, xfy, :). -:- op(500, yfx, +). -:- op(500, yfx, -). -:- op(500, yfx, /\). -:- op(500, yfx, \/). -:- op(400, yfx, *). -:- op(400, yfx, /). -:- op(400, yfx, //). -:- op(400, yfx, rem). -:- op(400, yfx, mod). -:- op(400, yfx, <<). -:- op(400, yfx, >>). -:- op(200, xfx, **). -:- op(200, xfy, ^). -:- op(200, fy, -). -:- op(200, fy, \). - -% Logic and control predicates -\+ Goal :- call(Goal), !, fail. -\+ Goal. - -once(Goal) :- - call(Goal), - !. - -repeat :- true ; repeat. - -% Control structures. - -If -> Then :- - If, !, Then. - -If -> Then ; _ :- - If, !, Then. - -_ -> _ ; Else :- - !, Else. - -If ; _ :- - If. - -_ ; Else :- - Else. - -A , B :- A , B. - -% Term unification -A = A. - -A \= B :- - \+ A = B. - -% Comparison of terms using the standard order - -A == B :- - compare(=, A, B). - -A \== B :- - \+ A == B. - -A @< B :- - compare(<, A, B). - -A @=< B :- - A == B. -A @=< B :- - A @< B. - -A @> B :- - compare(>, A, B). - -A @>= B :- - A == B. -A @>= B :- - A @> B. - -% Input output - -open(SourceSink, Mode, Stream) :- - open(SourceSink, Mode, Stream, []). - -close(StreamOrAlias) :- - close(StreamOrAlias, []). - -flush_output :- - current_output(S), - flush_output(S). - -stream_property(S, P) :- - stream_properties(Props), - member(prop(S,P), Props). - -at_end_of_stream :- - current_input(S), - stream_property(S, end_of_stream(E)), - !, - (E = at ; E = past), - !. - -at_end_of_stream(S_or_a) :- - ( atom(S_or_a) - -> stream_property(S, alias(S_or_a)) - ; S = S_or_a - ), - stream_property(S, end_of_stream(E)), - !, - (E = at; E = past), - !. - -% Standard exceptions - -instantiation_error :- - throw(error(instantiation_error, _)). - -type_error(ValidType, Culprit) :- - throw(error(type_error(ValidType, Culprit), _)). - -domain_error(ValidDomain, Culprit) :- - throw(error(domain_error(ValidDomain, Culprit), _)). - -existence_error(ObjectType, Culprit) :- - throw(error(existence_error(ObjectType, Culprit), _)). - -permission_error(Operation, PermissionType, Culprit) :- - throw(error(permission_error(Operation, PermissionType, Culprit), _)). - -representation_error(Flag) :- - throw(error(representation_error(Flag), _)). - -evaluation_error(Error) :- - throw(error(evaluation_error(Error), _)). - -resource_error(Resource) :- - throw(error(resource_error(Resource), _)). - -syntax_error(Error) :- - throw(error(syntax_error(Error), _)). - -% Input and output -parse_read_option(variables(Vs), options(variables, Vs)). -parse_read_option(variable_names(VNames), option(variable_names, VNames)). -parse_read_option(singletons(S), options(singletons, S)). - -parse_read_options([], []). -parse_read_options([Op|Rest], [OpParsed|RestParsed]) :- - is_nonvar(Op), - parse_read_options(Rest, RestParsed), - ( parse_read_option(Op, OpParsed) - -> true - ; domain_error(read_option, Op) - ). - -read_term(S, Term, Options) :- - is_nonvar(Options), - is_list(Options), - parse_read_options(Options, ParsedOptions), - '$read_term'(S, Term, ParsedOptions). - -read_term(Term, Options) :- - current_input(S), - read_term(S, Term, Options). - -read(Term) :- - current_input(S), - read_term(S, Term, []). - -read(S, Term) :- - read_term(S, Term, []). - -parse_write_option(quoted(true), option(quoted, 1)). -parse_write_option(quoted(false), option(quoted, 0)). -parse_write_option(ignore_ops(true), option(ignore_ops, 1)). -parse_write_option(ignore_ops(false), option(ignore_ops, 0)). -parse_write_option(numbervars(true), option(numbervars, 1)). -parse_write_option(numbervars(false), option(numbervars, 0)). - -parse_write_options([], []). -parse_write_options([Op|Rest], [OpParsed|RestParsed]) :- - is_nonvar(Op), - parse_write_options(Rest, RestParsed), - ( parse_write_option(Op, OpParsed) - -> true - ; domain_error(write_option, Op) - ). -write_term(S, Term, Options) :- - is_nonvar(Options), - is_list(Options), - parse_write_options(Options, ParsedOptions), - '$write_term'(S, Term, ParsedOptions). - - -write_term(Term, Options) :- - current_output(S), - write_term(S, Term, Options). - -write(Term) :- - current_output(S), - write_term(S, Term, [numbervars(true)]). - -write(S, Term) :- - write_term(S, Term, [numbervars(true)]). - -writeq(Term) :- - current_output(S), - write_term(S, Term, [quoted(true), numbervars(true)]). - -writeq(S, Term) :- - write_term(S, Term, [quoted(true), numbervars(true)]). - -write_canonical(Term) :- - current_output(S), - write_term(S, Term, [quoted(true), ignore_ops(true)]). - -write_canonical(S, Term) :- - write_term(S, Term, [quoted(true), ignore_ops(true)]). - -% Arithmetic comparisons defined in terms of >=. This is not the most effective way, -% but it is fine for now. - -E1 =:= E2 :- - E1 >= E2, - E2 >= E1. - -E1 =\= E2 :- - \+ E1 =:= E2. - -E1 < E2 :- - E2 >= E1, - E1 =\= E2. - -E1 =< E2 :- - E2 >= E1. - -E1 > E2 :- - E2 < E1. - - -% Clause retrieval and information and removal - -clause(Head, Body) :- - clause(Head, Body, Clauses), - member(clause(Head, Body), Clauses). - -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]) :- - member(X, Tail). - -append([], Ys, Ys). -append([X|Xs], Ys, [X|Zs]) :- - append(Xs, Ys, Zs). - -length([], 0). -length([_|T], Len) :- - length(T, Len0), - Len is Len0 + 1. - -unique([], []). -unique([H|T], [H|Rest]) :- - findall(_, (member(X, T), X == H), []), - !, - unique(T, Rest). -unique([H|T], Rest) :- - unique(T, Rest). - -union(A, B, C) :- - append(A, B, C0), - unique(C0, C). - -difference(A, B, Diff) :- - append(A, B, AB), - unique_in(AB, AB, Diff). - -unique_in([], _, []). -unique_in([H|T], L, [H|Rest]) :- - findall(_, (member(X, L), X == H), [_]), - !, - unique_in(T, L, Rest). -unique_in([H|T], L, Rest) :- - unique_in(T, L, Rest). - -include(_, [], []). -include(Goal, [X|Xs], Included) :- - Goal =.. L, - append(L, [X], L1), - G =.. L1, - ( call(G) - -> Included = [X|Included0] - ; Included = Included0 - ), - include(Goal, Xs, Included0). - -% Additional type tests - -callable(T) :- atom(T) ; compound(T). - -list([]). -list([_|T]) :- list(T). - -partial_list(T) :- var(T). -partial_list([_|T]) :- partial_list(T). - -atomic(T) :- atom(T) ; integer(T) ; float(T). - -% type assertions (throws an error if false) - -is_atom(T) :- atom(T), ! ; type_error(atom, T). - -is_atom_or_var(T) :- (atom(T) ; var(T)), ! ; type_error(atom, T). - -is_callable(T) :- callable(T), ! ; type_error(callable, T). - -is_nonvar(T) :- nonvar(T), ! ; instantiation_error. - -is_list_or_partial_list(T) :- (list(T) ; partial_list(T)), ! ; type_error(list, T). - -is_list(T) :- list(T), ! ; type_error(list, T). - -is_integer(T) :- integer(T), ! ; type_error(integer, T). - -is_predicate_indicator(T) :- (nonvar(T), T = N/A, integer(A), atom(N), !) ; type_error(predicate_indicator, T). - -% All solutions - -findall(Template, Goal, Instances) :- - is_nonvar(Goal), - is_callable(Goal), - is_list_or_partial_list(Instances), - system:asserta('find all'([])), - call(Goal), - system:asserta('find all'(solution(Template))), - fail. -findall(Template, Goal, Instances) :- - findall_collect([], Instances). - -findall_collect(Acc, Instances) :- - system:retract('find all'(Item)), - !, - findall_collect(Item, Acc, Instances). -findall_collect([], Instances, Instances). -findall_collect(solution(T), Acc, Instances) :- - findall_collect([T|Acc], Instances). - -bagof(Template, Goal, Instances) :- - free_variable_set(Goal, Template, Witness), - iterated_goal(Goal, G), - findall(Witness+Template, G, S), - bagof_loop(Witness, S, Instances). - -bagof_loop(Witness, S, Instances) :- - [W+T|_] = S, - bagof_wt_list(S, W+T, WT_list), - bagof_split(WT_list, W_list, T_list), - ( bagof_unify_list(Witness, W_list), Instances = T_list - ; bagof_next_s(S, WT_list, S_next), bagof_loop(Witness, S_next, Instances) - ). - -bagof_wt_list([], _, []). -bagof_wt_list([W+T|Tail], W0+T0, Rest) :- - copy_term(W+T, W1+T1), - bagof_wt_list(Tail, W0+T0, Rest0), - ( variant(W1, W0) - -> Rest = [W1+T1|Rest0] - ; Rest = Rest0 - ). - -copy_terms_list([], []). -copy_terms_list([H|T], [HH|TT]) :- - copy_term(H, HH), - copy_terms_list(T, TT). -bagof_split([], [], []). -bagof_split([WW+TT|RestWT], [WW|RestW], [TT|RestT]) :- - bagof_split(RestWT, RestW, RestT). - -bagof_unify_list(W, []). -bagof_unify_list(W, [W|T]) :- bagof_unify_list(W, T). - -bagof_next_s([], _, []). -bagof_next_s([H|T], WT_list, Rest) :- - bagof_next_s(T, WT_list, Rest0), - ( findall(_, (member(X, WT_list), variant(X, H)), []) - -> Rest = [H|Rest0] - ; Rest = Rest0 - ). - -setof(Template, Goal, Instances) :- - bagof(Template, Goal, Instances_list), - sort(Instances_list, Instances). - -% misc helpers - -variable_set(Term, []) :- - atomic(Term). -variable_set(Term, [Term]) :- - var(Term). -variable_set(Term, Vars) :- - compound(Term), - Term =.. [_|Args], - variable_set(Args, [], Vars0), - unique(Vars0, Vars). - -variable_set([], Acc, Acc). -variable_set([Arg|Rest], Acc0, Result) :- - variable_set(Arg, VarSet), - append(Acc0, VarSet, Acc), - variable_set(Rest, Acc, Result). - -existential_variable_set(Term, []) :- - (atomic(Term) ; var(Term)), - !. -existential_variable_set(V^G, Vars) :- - !, - existential_variable_set(G, Vars0), - variable_set(V, Vars1), - union(Vars0, Vars1, Vars). -existential_variable_set(_, []). - -free_variable_set(T, V, Vars) :- - variable_set(T, TVars), - variable_set(V, VVars), - existential_variable_set(T, TExVars), - union(VVars, TExVars, BV), - difference(TVars, BV, Vars). - -iterated_goal(Goal, T) :- - compound(Goal), - _^G = Goal, - !, - iterated_goal(G, T). -iterated_goal(G, G). - -variant(T1, T2) :- - var(T1), var(T2), !. -variant(T1, T2) :- - compound(T1), - compound(T2), - !, - T1 =.. [Name|Args1], - T2 =.. [Name|Args2], - variant_list(Args1, Args2). -variant(T1, T2) :- - T1 == T2. - -variant_list([], []). -variant_list([H1|T1], [H2|T2]) :- - variant(H1, H2), - variant_list(T1, T2). - -% Sorting, which also removes duplicates (should be implemented in C for speed I think). - -sort(Ls0, Ls) :- - append(Lefts, [A,B|Rights], Ls0), - A @> B, - !, - append(Lefts, [B,A|Rights], Ls1), - sort(Ls1, Ls). -sort(Ls0, Ls) :- - append(Lefts, [A,B|Rights], Ls0), - A == B, - !, - append(Lefts, [A|Rights], Ls1), - sort(Ls1, Ls). -sort(Ls, Ls). - -% Atomic term processing - -atom_concat(A1, A2, A3) :- - is_atom_or_var(A1), - is_atom_or_var(A2), - is_atom_or_var(A3), - atom(A1), atom(A2), - !, - atom_codes(A1, Codes1), - atom_codes(A2, Codes2), - append(Codes1, Codes2, Codes), - atom_codes(A3, Codes). -atom_concat(A1, A2, A3) :- - is_atom_or_var(A1), - is_atom_or_var(A2), - is_atom_or_var(A3), - atom(A3), - !, - atom_codes(A3, Codes), - append(Codes1, Codes2, Codes), - atom_codes(A1, Codes1), - atom_codes(A2, Codes2). -atom_concat(A1, A2, A3) :- - instantiation_error. - -% Character input/output - -get_char(Char) :- - current_input(S), - get_char(S, Char). - -get_code(Code) :- - current_input(S), - get_code(S, Code). - -get_code(S, Code) :- - get_char(S, Char), - ( Char = end_of_file - -> Code = -1 - ; char_code(Char, Code) - ). - -peek_char(Char) :- - current_input(S), - peek_char(S, Char). - -peek_code(Code) :- - current_input(S), - peek_code(S, Code). - -peek_code(S, Code) :- - peek_char(S, Char), - ( Char = end_of_file - -> Code = -1 - ; char_code(Char, Code) - ). - -put_char(Char) :- - current_output(S), - put_char(S, Char). - -put_code(Code) :- - current_output(S), - put_code(S, Code). - -put_code(S, Code) :- - char_code(Char, Code), - put_char(S, Char). - -nl :- - current_output(S), - nl(S). - -nl(S) :- - put_char(S, ' -'). % This should really be \n - -% flags -set_prolog_flag(Flag, Value) :- - is_nonvar(Flag), - is_nonvar(Value), - is_atom(Flag), - is_prolog_flag(Flag), - is_appropriate_flag_value(Flag, Value), - is_modifiable_flag(Flag), - '$set_prolog_flag'(Flag, Value). - -current_prolog_flag(Flag, Value) :- - is_atom_or_var(Flag), - ( atom(Flag) - -> is_prolog_flag(Flag) - ; true - ), - current_prolog_flags(FlagsAndValues), - member(flag(Flag, Value), FlagsAndValues). - -is_prolog_flag(Flag) :- - member(Flag, - [ bounded - , max_integer - , min_integer - , integer_rounding_function - , char_conversion - , debug - , max_arity - , unknown - , double_quotes]), - ! - ; domain_error(prolog_flag, Flag). - -is_modifiable_flag(Flag) :- - member(Flag, [char_conversion, debug, unknown, double_quotes]), - ! - ; permission_error(modify, flag, Flag). - -is_appropriate_flag_value(Flag, Value) :- - appropriate_flag_values(Flag, Values), - member(Value, Values), - ! - ; domain_error(flag_value, Flag + Value). - -appropriate_flag_values(bounded, [true, false]). -appropriate_flag_values(max_integer, [Val]) :- - current_prolog_flag(max_integer, Val). -appropriate_flag_values(min_integer, [Val]) :- - current_prolog_flag(min_integer, Val). -appropriate_flag_values(integer_rounding_function, [down, toward_zero]). -appropriate_flag_values(char_conversion, [on, off]). -appropriate_flag_values(debug, [on, off]). -appropriate_flag_values(max_arity, [Val]) :- - current_prolog_flag(max_arity). -appropriate_flag_values(unknown, [error, fail, warning]). -appropriate_flag_values(double_quotes, [chars, codes, atom]). - -% Operator table modification and inspection - -op(Priority, Op_specifier, Operator) :- - is_nonvar(Priority), - is_integer(Priority), - is_nonvar(Op_specifier), - is_atom(Op_specifier), - ( operator_priority(Priority), ! - ; domain_error(operator_priority, Priority) - ), - ( operator_specifier(Op_specifier), ! - ; domain_error(operator_specifier, Op_specifier) - ), - is_nonvar(Operator), - ( atom(Operator) - -> Ops = [Operator] - ; Ops = Operator - ), - is_list(Ops), - op_helper(Priority, Op_specifier, Ops). - -op_helper(Priority, Op_specifier, []). -op_helper(Priority, Op_specifier, [Op|Ops]) :- - is_nonvar(Op), - is_atom(Op), - '$op'(Priority, Op_specifier, Op), - op_helper(Priority, Op_specifier, Ops). - -operator_priority(P) :- - integer(P), - P >= 0, - P =< 1200. - -operator_specifier(S) :- - member(S, [xf, yf, xfx, xfy, yfx, fx, fy]). - -current_op(Priority, Op_specifier, Operator) :- - ( (var(Priority) ; operator_priority(Priority)), ! - ; domain_error(operator_priority, Priority) - ), - ( (var(Op_specifier) ; operator_specifier(Op_specifier)), ! - ; domain_error(operator_specifier, Op_specifier) - ), - is_atom_or_var(Operator), - current_ops(Operators), - member(op(Priority, Op_specifier, Operator), Operators). - -% Halting - -halt(X) :- - is_nonvar(X), - is_integer(X), - '$halt'(X). - -halt :- - halt(0). - -% Loading prolog text - -consult(File) :- - loader:load_module_from_file(File). diff --git a/system.pl b/system.pl new file mode 100644 index 0000000..9009ff6 --- /dev/null +++ b/system.pl @@ -0,0 +1,699 @@ +:-(module(system, [])). + +% Insert the standard operators + +:-(op(1200, fx, :-)). +:- op(1200, fx, ?-). +:- op(1200, xfx, :-). +:- op(1200, xfx, -->). +:- op(1100, xfy, ;). +:- op(1050, xfy, ->). +:- op(1000, xfy, ','). +:- op(900, fy, \+). +:- op(700, xfx, =). +:- op(700, xfx, \=). +:- op(700, xfx, ==). +:- op(700, xfx, \==). +:- op(700, xfx, @<). +:- op(700, xfx, @=<). +:- op(700, xfx, @>). +:- op(700, xfx, @>=). +:- op(700, xfx, =..). +:- op(700, xfx, is). +:- op(700, xfx, =:=). +:- op(700, xfx, =\=). +:- op(700, xfx, <). +:- op(700, xfx, =<). +:- op(700, xfx, >). +:- op(700, xfx, >=). +:- op(600, xfy, :). +:- op(500, yfx, +). +:- op(500, yfx, -). +:- op(500, yfx, /\). +:- op(500, yfx, \/). +:- op(400, yfx, *). +:- op(400, yfx, /). +:- op(400, yfx, //). +:- op(400, yfx, rem). +:- op(400, yfx, mod). +:- op(400, yfx, <<). +:- op(400, yfx, >>). +:- op(200, xfx, **). +:- op(200, xfy, ^). +:- op(200, fy, -). +:- op(200, fy, \). + +% Logic and control predicates +\+ Goal :- call(Goal), !, fail. +\+ Goal. + +once(Goal) :- + call(Goal), + !. + +repeat :- true ; repeat. + +% Control structures. + +If -> Then :- + If, !, Then. + +If -> Then ; _ :- + If, !, Then. + +_ -> _ ; Else :- + !, Else. + +If ; _ :- + If. + +_ ; Else :- + Else. + +A , B :- A , B. + +% Term unification +A = A. + +A \= B :- + \+ A = B. + +% Comparison of terms using the standard order + +A == B :- + compare(=, A, B). + +A \== B :- + \+ A == B. + +A @< B :- + compare(<, A, B). + +A @=< B :- + A == B. +A @=< B :- + A @< B. + +A @> B :- + compare(>, A, B). + +A @>= B :- + A == B. +A @>= B :- + A @> B. + +% Input output + +open(SourceSink, Mode, Stream) :- + open(SourceSink, Mode, Stream, []). + +close(StreamOrAlias) :- + close(StreamOrAlias, []). + +flush_output :- + current_output(S), + flush_output(S). + +stream_property(S, P) :- + stream_properties(Props), + member(prop(S,P), Props). + +at_end_of_stream :- + current_input(S), + stream_property(S, end_of_stream(E)), + !, + (E = at ; E = past), + !. + +at_end_of_stream(S_or_a) :- + ( atom(S_or_a) + -> stream_property(S, alias(S_or_a)) + ; S = S_or_a + ), + stream_property(S, end_of_stream(E)), + !, + (E = at; E = past), + !. + +% Standard exceptions + +instantiation_error :- + throw(error(instantiation_error, _)). + +type_error(ValidType, Culprit) :- + throw(error(type_error(ValidType, Culprit), _)). + +domain_error(ValidDomain, Culprit) :- + throw(error(domain_error(ValidDomain, Culprit), _)). + +existence_error(ObjectType, Culprit) :- + throw(error(existence_error(ObjectType, Culprit), _)). + +permission_error(Operation, PermissionType, Culprit) :- + throw(error(permission_error(Operation, PermissionType, Culprit), _)). + +representation_error(Flag) :- + throw(error(representation_error(Flag), _)). + +evaluation_error(Error) :- + throw(error(evaluation_error(Error), _)). + +resource_error(Resource) :- + throw(error(resource_error(Resource), _)). + +syntax_error(Error) :- + throw(error(syntax_error(Error), _)). + +% Input and output +parse_read_option(variables(Vs), options(variables, Vs)). +parse_read_option(variable_names(VNames), option(variable_names, VNames)). +parse_read_option(singletons(S), options(singletons, S)). + +parse_read_options([], []). +parse_read_options([Op|Rest], [OpParsed|RestParsed]) :- + is_nonvar(Op), + parse_read_options(Rest, RestParsed), + ( parse_read_option(Op, OpParsed) + -> true + ; domain_error(read_option, Op) + ). + +read_term(S, Term, Options) :- + is_nonvar(Options), + is_list(Options), + parse_read_options(Options, ParsedOptions), + '$read_term'(S, Term, ParsedOptions). + +read_term(Term, Options) :- + current_input(S), + read_term(S, Term, Options). + +read(Term) :- + current_input(S), + read_term(S, Term, []). + +read(S, Term) :- + read_term(S, Term, []). + +parse_write_option(quoted(true), option(quoted, 1)). +parse_write_option(quoted(false), option(quoted, 0)). +parse_write_option(ignore_ops(true), option(ignore_ops, 1)). +parse_write_option(ignore_ops(false), option(ignore_ops, 0)). +parse_write_option(numbervars(true), option(numbervars, 1)). +parse_write_option(numbervars(false), option(numbervars, 0)). + +parse_write_options([], []). +parse_write_options([Op|Rest], [OpParsed|RestParsed]) :- + is_nonvar(Op), + parse_write_options(Rest, RestParsed), + ( parse_write_option(Op, OpParsed) + -> true + ; domain_error(write_option, Op) + ). +write_term(S, Term, Options) :- + is_nonvar(Options), + is_list(Options), + parse_write_options(Options, ParsedOptions), + '$write_term'(S, Term, ParsedOptions). + + +write_term(Term, Options) :- + current_output(S), + write_term(S, Term, Options). + +write(Term) :- + current_output(S), + write_term(S, Term, [numbervars(true)]). + +write(S, Term) :- + write_term(S, Term, [numbervars(true)]). + +writeq(Term) :- + current_output(S), + write_term(S, Term, [quoted(true), numbervars(true)]). + +writeq(S, Term) :- + write_term(S, Term, [quoted(true), numbervars(true)]). + +write_canonical(Term) :- + current_output(S), + write_term(S, Term, [quoted(true), ignore_ops(true)]). + +write_canonical(S, Term) :- + write_term(S, Term, [quoted(true), ignore_ops(true)]). + +% Arithmetic comparisons defined in terms of >=. This is not the most effective way, +% but it is fine for now. + +E1 =:= E2 :- + E1 >= E2, + E2 >= E1. + +E1 =\= E2 :- + \+ E1 =:= E2. + +E1 < E2 :- + E2 >= E1, + E1 =\= E2. + +E1 =< E2 :- + E2 >= E1. + +E1 > E2 :- + E2 < E1. + + +% Clause retrieval and information and removal + +clause(Head, Body) :- + clause(Head, Body, Clauses), + member(clause(Head, Body), Clauses). + +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]) :- + member(X, Tail). + +append([], Ys, Ys). +append([X|Xs], Ys, [X|Zs]) :- + append(Xs, Ys, Zs). + +length([], 0). +length([_|T], Len) :- + length(T, Len0), + Len is Len0 + 1. + +unique([], []). +unique([H|T], [H|Rest]) :- + findall(_, (member(X, T), X == H), []), + !, + unique(T, Rest). +unique([H|T], Rest) :- + unique(T, Rest). + +union(A, B, C) :- + append(A, B, C0), + unique(C0, C). + +difference(A, B, Diff) :- + append(A, B, AB), + unique_in(AB, AB, Diff). + +unique_in([], _, []). +unique_in([H|T], L, [H|Rest]) :- + findall(_, (member(X, L), X == H), [_]), + !, + unique_in(T, L, Rest). +unique_in([H|T], L, Rest) :- + unique_in(T, L, Rest). + +include(_, [], []). +include(Goal, [X|Xs], Included) :- + Goal =.. L, + append(L, [X], L1), + G =.. L1, + ( call(G) + -> Included = [X|Included0] + ; Included = Included0 + ), + include(Goal, Xs, Included0). + +% Additional type tests + +callable(T) :- atom(T) ; compound(T). + +list([]). +list([_|T]) :- list(T). + +partial_list(T) :- var(T). +partial_list([_|T]) :- partial_list(T). + +atomic(T) :- atom(T) ; integer(T) ; float(T). + +% type assertions (throws an error if false) + +is_atom(T) :- (atom(T) ; type_error(atom, T)), !. + +is_atom_or_var(T) :- (atom(T) ; var(T) ; type_error(atom, T)), !. + +is_callable(T) :- (callable(T) ; type_error(callable, T)), !. + +is_nonvar(T) :- (nonvar(T) ; instantiation_error), !. + +is_list_or_partial_list(T) :- (list(T) ; partial_list(T) ; type_error(list, T)), !. + +is_list(T) :- (list(T) ; type_error(list, T)), !. + +is_integer(T) :- (integer(T) ; type_error(integer, T)), !. + +is_predicate_indicator(T) :- ((nonvar(T), T = N/A, integer(A), atom(N)) ; type_error(predicate_indicator, T)), !. + +% All solutions + +findall(Template, Goal, Instances) :- + is_nonvar(Goal), + is_callable(Goal), + is_list_or_partial_list(Instances), + system:asserta('find all'([])), + call(Goal), + system:asserta('find all'(solution(Template))), + fail. +findall(Template, Goal, Instances) :- + findall_collect([], Instances). + +findall_collect(Acc, Instances) :- + system:retract('find all'(Item)), + !, + findall_collect(Item, Acc, Instances). +findall_collect([], Instances, Instances). +findall_collect(solution(T), Acc, Instances) :- + findall_collect([T|Acc], Instances). + +bagof(Template, Goal, Instances) :- + free_variable_set(Goal, Template, Witness), + iterated_goal(Goal, G), + findall(Witness+Template, G, S), + bagof_loop(Witness, S, Instances). + +bagof_loop(Witness, S, Instances) :- + [W+T|_] = S, + bagof_wt_list(S, W+T, WT_list), + bagof_split(WT_list, W_list, T_list), + ( bagof_unify_list(Witness, W_list), Instances = T_list + ; bagof_next_s(S, WT_list, S_next), bagof_loop(Witness, S_next, Instances) + ). + +bagof_wt_list([], _, []). +bagof_wt_list([W+T|Tail], W0+T0, Rest) :- + copy_term(W+T, W1+T1), + bagof_wt_list(Tail, W0+T0, Rest0), + ( variant(W1, W0) + -> Rest = [W1+T1|Rest0] + ; Rest = Rest0 + ). + +copy_terms_list([], []). +copy_terms_list([H|T], [HH|TT]) :- + copy_term(H, HH), + copy_terms_list(T, TT). +bagof_split([], [], []). +bagof_split([WW+TT|RestWT], [WW|RestW], [TT|RestT]) :- + bagof_split(RestWT, RestW, RestT). + +bagof_unify_list(W, []). +bagof_unify_list(W, [W|T]) :- bagof_unify_list(W, T). + +bagof_next_s([], _, []). +bagof_next_s([H|T], WT_list, Rest) :- + bagof_next_s(T, WT_list, Rest0), + ( findall(_, (member(X, WT_list), variant(X, H)), []) + -> Rest = [H|Rest0] + ; Rest = Rest0 + ). + +setof(Template, Goal, Instances) :- + bagof(Template, Goal, Instances_list), + sort(Instances_list, Instances). + +% misc helpers + +variable_set(Term, []) :- + atomic(Term). +variable_set(Term, [Term]) :- + var(Term). +variable_set(Term, Vars) :- + compound(Term), + Term =.. [_|Args], + variable_set(Args, [], Vars0), + unique(Vars0, Vars). + +variable_set([], Acc, Acc). +variable_set([Arg|Rest], Acc0, Result) :- + variable_set(Arg, VarSet), + append(Acc0, VarSet, Acc), + variable_set(Rest, Acc, Result). + +existential_variable_set(Term, []) :- + (atomic(Term) ; var(Term)), + !. +existential_variable_set(V^G, Vars) :- + !, + existential_variable_set(G, Vars0), + variable_set(V, Vars1), + union(Vars0, Vars1, Vars). +existential_variable_set(_, []). + +free_variable_set(T, V, Vars) :- + variable_set(T, TVars), + variable_set(V, VVars), + existential_variable_set(T, TExVars), + union(VVars, TExVars, BV), + difference(TVars, BV, Vars). + +iterated_goal(Goal, T) :- + compound(Goal), + _^G = Goal, + !, + iterated_goal(G, T). +iterated_goal(G, G). + +variant(T1, T2) :- + var(T1), var(T2), !. +variant(T1, T2) :- + compound(T1), + compound(T2), + !, + T1 =.. [Name|Args1], + T2 =.. [Name|Args2], + variant_list(Args1, Args2). +variant(T1, T2) :- + T1 == T2. + +variant_list([], []). +variant_list([H1|T1], [H2|T2]) :- + variant(H1, H2), + variant_list(T1, T2). + +% Sorting, which also removes duplicates (should be implemented in C for speed I think). + +sort(Ls0, Ls) :- + append(Lefts, [A,B|Rights], Ls0), + A @> B, + !, + append(Lefts, [B,A|Rights], Ls1), + sort(Ls1, Ls). +sort(Ls0, Ls) :- + append(Lefts, [A,B|Rights], Ls0), + A == B, + !, + append(Lefts, [A|Rights], Ls1), + sort(Ls1, Ls). +sort(Ls, Ls). + +% Atomic term processing + +atom_concat(A1, A2, A3) :- + is_atom_or_var(A1), + is_atom_or_var(A2), + is_atom_or_var(A3), + atom(A1), atom(A2), + !, + atom_codes(A1, Codes1), + atom_codes(A2, Codes2), + append(Codes1, Codes2, Codes), + atom_codes(A3, Codes). +atom_concat(A1, A2, A3) :- + is_atom_or_var(A1), + is_atom_or_var(A2), + is_atom_or_var(A3), + atom(A3), + !, + atom_codes(A3, Codes), + append(Codes1, Codes2, Codes), + atom_codes(A1, Codes1), + atom_codes(A2, Codes2). +atom_concat(A1, A2, A3) :- + instantiation_error. + +% Character input/output + +get_char(Char) :- + current_input(S), + get_char(S, Char). + +get_code(Code) :- + current_input(S), + get_code(S, Code). + +get_code(S, Code) :- + get_char(S, Char), + ( Char = end_of_file + -> Code = -1 + ; char_code(Char, Code) + ). + +peek_char(Char) :- + current_input(S), + peek_char(S, Char). + +peek_code(Code) :- + current_input(S), + peek_code(S, Code). + +peek_code(S, Code) :- + peek_char(S, Char), + ( Char = end_of_file + -> Code = -1 + ; char_code(Char, Code) + ). + +put_char(Char) :- + current_output(S), + put_char(S, Char). + +put_code(Code) :- + current_output(S), + put_code(S, Code). + +put_code(S, Code) :- + char_code(Char, Code), + put_char(S, Char). + +nl :- + current_output(S), + nl(S). + +nl(S) :- + put_char(S, ' +'). % This should really be \n + +% flags +set_prolog_flag(Flag, Value) :- + is_nonvar(Flag), + is_nonvar(Value), + is_atom(Flag), + is_prolog_flag(Flag), + is_appropriate_flag_value(Flag, Value), + is_modifiable_flag(Flag), + '$set_prolog_flag'(Flag, Value). + +current_prolog_flag(Flag, Value) :- + is_atom_or_var(Flag), + ( atom(Flag) + -> is_prolog_flag(Flag) + ; true + ), + current_prolog_flags(FlagsAndValues), + member(flag(Flag, Value), FlagsAndValues). + +is_prolog_flag(Flag) :- + member(Flag, + [ bounded + , max_integer + , min_integer + , integer_rounding_function + , char_conversion + , debug + , max_arity + , unknown + , double_quotes]), + ! + ; domain_error(prolog_flag, Flag). + +is_modifiable_flag(Flag) :- + member(Flag, [char_conversion, debug, unknown, double_quotes]), + ! + ; permission_error(modify, flag, Flag). + +is_appropriate_flag_value(Flag, Value) :- + appropriate_flag_values(Flag, Values), + member(Value, Values), + ! + ; domain_error(flag_value, Flag + Value). + +appropriate_flag_values(bounded, [true, false]). +appropriate_flag_values(max_integer, [Val]) :- + current_prolog_flag(max_integer, Val). +appropriate_flag_values(min_integer, [Val]) :- + current_prolog_flag(min_integer, Val). +appropriate_flag_values(integer_rounding_function, [down, toward_zero]). +appropriate_flag_values(char_conversion, [on, off]). +appropriate_flag_values(debug, [on, off]). +appropriate_flag_values(max_arity, [Val]) :- + current_prolog_flag(max_arity). +appropriate_flag_values(unknown, [error, fail, warning]). +appropriate_flag_values(double_quotes, [chars, codes, atom]). + +% Operator table modification and inspection + +op(Priority, Op_specifier, Operator) :- + is_nonvar(Priority), + is_integer(Priority), + is_nonvar(Op_specifier), + is_atom(Op_specifier), + ( operator_priority(Priority), ! + ; domain_error(operator_priority, Priority) + ), + ( operator_specifier(Op_specifier), ! + ; domain_error(operator_specifier, Op_specifier) + ), + is_nonvar(Operator), + ( atom(Operator) + -> Ops = [Operator] + ; Ops = Operator + ), + is_list(Ops), + op_helper(Priority, Op_specifier, Ops). + +op_helper(Priority, Op_specifier, []). +op_helper(Priority, Op_specifier, [Op|Ops]) :- + is_nonvar(Op), + is_atom(Op), + '$op'(Priority, Op_specifier, Op), + op_helper(Priority, Op_specifier, Ops). + +operator_priority(P) :- + integer(P), + P >= 0, + P =< 1200. + +operator_specifier(S) :- + member(S, [xf, yf, xfx, xfy, yfx, fx, fy]). + +current_op(Priority, Op_specifier, Operator) :- + ( (var(Priority) ; operator_priority(Priority)), ! + ; domain_error(operator_priority, Priority) + ), + ( (var(Op_specifier) ; operator_specifier(Op_specifier)), ! + ; domain_error(operator_specifier, Op_specifier) + ), + is_atom_or_var(Operator), + current_ops(Operators), + member(op(Priority, Op_specifier, Operator), Operators). + +% Halting + +halt(X) :- + is_nonvar(X), + is_integer(X), + '$halt'(X). + +halt :- + halt(0). + +% Loading prolog text + +consult(File) :- + loader:load_module_from_file(File). -- cgit v1.2.3