rishi/scryer-prolog
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
dcf2eadcf20f614a93341e81ba2d5d7c66eccb87
scryer-prolog/src/prolog/lib/builtins.pl
Mark Thom dcf2eadcf2 add preliminary multifile declaration support
2020-01-26 20:17:52 -07:00

1001 lines
37 KiB
Prolog
Raw Blame History

:- op(400, yfx, /).
% module resolution operator.
:- op(600, xfy, :).
user:term_expansion((:- op(Pred, Spec, [Op | OtherOps])), OpResults) :-
'$expand_op_list'([Op | OtherOps], Pred, Spec, OpResults).
'$expand_op_list'([], _, _, []).
'$expand_op_list'([Op | OtherOps], Pred, Spec, [(:- op(Pred, Spec, Op)) | OtherResults]) :-
'$expand_op_list'(OtherOps, Pred, Spec, OtherResults).
/* this is an implementation specific declarative operator used to implement call_with_inference_limit/3
and setup_call_cleanup/3. switches to the default trust_me and retry_me_else. Indexing choice
instructions are unchanged. */
:- op(700, fx, non_counted_backtracking).
% arithmetic operators.
:- op(700, xfx, is).
:- op(500, yfx, [+, -]).
:- op(400, yfx, *).
:- op(200, xfy, [**, ^]).
:- op(500, yfx, [/\, \/, xor]).
:- op(400, yfx, [div, //, rdiv, <<, >>, mod, rem]).
:- op(200, fy, [+, -, \]).
% arithmetic comparison operators.
:- op(700, xfx, [>, <, =\=, =:=, >=, =<]).
% term comparison.
:- op(700, xfx, [==, \==, @=<, @>=, @<, @>]).
% conditional operators.
:- op(1050, xfy, ->).
:- op(1100, xfy, ;).
% control.
:- op(700, xfx, [=, =.., \=]).
:- op(900, fy, \+).
:- module(builtins, [(=)/2, (\=)/2, (\+)/1, (',')/2, (->)/2, (;)/2,
(=..)/2, (:)/2, (:)/3, (:)/4, (:)/5, (:)/6,
(:)/7, (:)/8, (:)/9, (:)/10, (:)/11, (:)/12,
abolish/1, asserta/1, assertz/1, atom_chars/2,
atom_codes/2, atom_concat/3, atom_length/2,
bagof/3, catch/3, char_code/2, clause/2,
current_op/3, current_predicate/1,
current_prolog_flag/2, expand_goal/2,
expand_term/2, fail/0, false/0, findall/3,
findall/4, get_char/1, halt/0, max_arity/1,
number_chars/2, number_codes/2, once/1, op/3,
read_term/2, repeat/0, retract/1,
set_prolog_flag/2, setof/3, sub_atom/5,
subsumes_term/2, term_variables/2, throw/1,
true/0, unify_with_occurs_check/2, write/1,
write_canonical/1, write_term/2, writeq/1]).
% the maximum arity flag. needs to be replaced with
% current_prolog_flag(max_arity, MAX_ARITY).
max_arity(255).
% unify.
X = X.
true.
false :- '$fail'.
% dynamic module resolution.
Module : Predicate :-
( atom(Module) -> '$module_call'(Module, Predicate)
; throw(error(type_error(atom, Module), (:)/2))
).
:(Module, Predicate, A1) :-
( atom(Module) -> '$module_call'(A1, Module, Predicate)
; throw(error(type_error(atom, Module), (:)/2))
).
:(Module, Predicate, A1, A2) :-
( atom(Module) -> '$module_call'(A1, A2, Module, Predicate)
; throw(error(type_error(atom, Module), (:)/2))
).
:(Module, Predicate, A1, A2, A3) :-
( atom(Module) -> '$module_call'(A1, A2, A3, Module, Predicate)
; throw(error(type_error(atom, Module), (:)/2))
).
:(Module, Predicate, A1, A2, A3, A4) :-
( atom(Module) -> '$module_call'(A1, A2, A3, A4, Module, Predicate)
; throw(error(type_error(atom, Module), (:)/2))
).
:(Module, Predicate, A1, A2, A3, A4, A5) :-
( atom(Module) -> '$module_call'(A1, A2, A3, A4, A5, Module, Predicate)
; throw(error(type_error(atom, Module), (:)/2))
).
:(Module, Predicate, A1, A2, A3, A4, A5, A6) :-
( atom(Module) -> '$module_call'(A1, A2, A3, A4, A5, A6, Module, Predicate)
; throw(error(type_error(atom, Module), (:)/2))
).
:(Module, Predicate, A1, A2, A3, A4, A5, A6, A7) :-
( atom(Module) -> '$module_call'(A1, A2, A3, A4, A5, A6, A7, Module, Predicate)
; throw(error(type_error(atom, Module), (:)/2))
).
:(Module, Predicate, A1, A2, A3, A4, A5, A6, A7, A8) :-
( atom(Module) -> '$module_call'(A1, A2, A3, A4, A5, A6, A7, A8, Module, Predicate)
; throw(error(type_error(atom, Module), (:)/2))
).
:(Module, Predicate, A1, A2, A3, A4, A5, A6, A7, A8, A9) :-
( atom(Module) -> '$module_call'(A1, A2, A3, A4, A5, A6, A7, A8, A9, Module, Predicate)
; throw(error(type_error(atom, Module), (:)/2))
).
:(Module, Predicate, A1, A2, A3, A4, A5, A6, A7, A8, A9, A10) :-
( atom(Module) -> '$module_call'(A1, A2, A3, A4, A5, A6, A7, A8, A9, A10, Module, Predicate)
; throw(error(type_error(atom, Module), (:)/2))
).
% flags.
current_prolog_flag(Flag, false) :- Flag == bounded, !.
current_prolog_flag(bounded, false).
current_prolog_flag(Flag, toward_zero) :- Flag == integer_rounding_function, !.
current_prolog_flag(integer_rounding_function, toward_zero).
current_prolog_flag(Flag, Value) :- Flag == double_quotes, !, '$get_double_quotes'(Value).
current_prolog_flag(double_quotes, Value) :- '$get_double_quotes'(Value).
current_prolog_flag(Flag, _) :- Flag == max_integer, !, '$fail'.
current_prolog_flag(Flag, _) :- Flag == min_integer, !, '$fail'.
current_prolog_flag(Flag, _) :-
atom(Flag),
throw(error(domain_error(prolog_flag, Flag), current_prolog_flag/2)). % 8.17.2.3 b
current_prolog_flag(Flag, _) :-
nonvar(Flag),
throw(error(type_error(atom, Flag), current_prolog_flag/2)). % 8.17.2.3 a
set_prolog_flag(Flag, Value) :-
(var(Flag) ; var(Value)),
throw(error(instantiation_error, set_prolog_flag/2)). % 8.17.1.3 a, b
set_prolog_flag(bounded, false) :- !. % 7.11.1.1
set_prolog_flag(bounded, true) :- !, '$fail'. % 7.11.1.1
set_prolog_flag(bounded, Value) :-
throw(error(domain_error(flag_value, bounded + Value), set_prolog_flag/2)). % 8.17.1.3 e
set_prolog_flag(max_integer, Value) :- integer(Value), !, '$fail'. % 7.11.1.2
set_prolog_flag(max_integer, Value) :-
throw(error(domain_error(flag_value, max_integer + Value), set_prolog_flag/2)). % 8.17.1.3 e
set_prolog_flag(min_integer, Value) :- integer(Value), !, '$fail'. % 7.11.1.3
set_prolog_flag(min_integer, Value) :-
throw(error(domain_error(flag_value, min_integer + Value), set_prolog_flag/2)). % 8.17.1.3 e
set_prolog_flag(integer_rounding_function, down) :- !. % 7.11.1.4
set_prolog_flag(integer_rounding_function, Value) :-
throw(error(domain_error(flag_value, integer_rounding_function + Value),
set_prolog_flag/2)). % 8.17.1.3 e
set_prolog_flag(double_quotes, chars) :-
!, '$set_double_quotes'(chars). % 7.11.2.5, list of one-char atoms.
set_prolog_flag(double_quotes, atom) :-
!, '$set_double_quotes'(atom). % 7.11.2.5, list of char codes (UTF8).
set_prolog_flag(double_quotes, codes) :-
!, '$set_double_quotes'(codes).
set_prolog_flag(double_quotes, Value) :-
throw(error(domain_error(flag_value, double_quotes + Value),
set_prolog_flag/2)). % 8.17.1.3 e
set_prolog_flag(Flag, _) :-
atom(Flag),
throw(error(domain_error(prolog_flag, Flag), set_prolog_flag/2)). % 8.17.1.3 d
set_prolog_flag(Flag, _) :-
throw(error(type_error(atom, Flag), set_prolog_flag/2)). % 8.17.1.3 c
% control operators.
fail :- '$fail'.
\+ G :- call(G), !, false.
\+ _.
X \= X :- !, false.
_ \= _.
once(G) :- call(G), !.
repeat.
repeat :- repeat.
','(G1, G2) :- '$get_b_value'(B), '$call_with_default_policy'(comma_errors(G1, G2, B)).
:- non_counted_backtracking comma_errors/3.
comma_errors(G1, G2, B) :- var(G1), throw(error(instantiation_error, (',')/2)).
comma_errors(G1, G2, B) :- '$call_with_default_policy'(','(G1, G2, B)).
:- non_counted_backtracking (',')/3.
','(!, CF, B) :- compound(CF),
'$call_with_default_policy'(CF = ','(G1, G2)),
'$set_cp'(B),
'$call_with_default_policy'(comma_errors(G1, G2, B)).
','(!, Atom, B) :- Atom == !, '$set_cp'(B).
','(!, G, B) :- '$set_cp'(B), call(G).
','(G, CF, B) :- compound(CF),
'$call_with_default_policy'(CF = ','(G1, G2)),
!,
call(G),
'$call_with_default_policy'(comma_errors(G1, G2, B)).
','(G, Atom, B) :- Atom == !, !, call(G), '$set_cp'(B).
','(G1, G2, _) :- call(G1), call(G2).
;(G1, G2) :- '$get_b_value'(B), ;(G1, G2, B).
:- non_counted_backtracking (;)/3.
;(G1, G4, B) :- compound(G1),
'$call_with_default_policy'(G1 = ->(G2, G3)),
!,
( call(G2) -> call(G3)
; '$set_cp'(B),
call(G4)
).
;(G1, G2, B) :- G1 == !, '$set_cp'(B), call(G2).
;(G1, G2, B) :- G2 == !, call(G1), '$set_cp'(B).
;(G, _, _) :- call(G).
;(_, G, _) :- call(G).
G1 -> G2 :- '$get_b_value'(B), '$call_with_default_policy'(->(G1, G2, B)).
:- non_counted_backtracking (->)/3.
->(G1, G2, B) :- G2 == !, call(G1), '$set_cp'(B).
->(G1, G2, B) :- call(G1), '$set_cp'(B), call(G2).
% univ.
:- non_counted_backtracking univ_errors/3.
univ_errors(Term, List, N) :-
'$skip_max_list'(N, -1, List, R),
( var(R) ->
( var(Term), throw(error(instantiation_error, (=..)/2)) % 8.5.3.3 a)
; true
)
; R \== [] ->
throw(error(type_error(list, List), (=..)/2)) % 8.5.3.3 b)
; List = [H|T] ->
( var(H), var(Term), % R == [] => List is a proper list.
throw(error(instantiation_error, (=..)/2)) % 8.5.3.3 c)
; T \== [], nonvar(H), \+ atom(H),
throw(error(type_error(atom, H), (=..)/2)) % 8.5.3.3 d)
; compound(H), T == [],
throw(error(type_error(atomic, H), (=..)/2)) % 8.5.3.3 e)
; var(Term), max_arity(M), N - 1 > M,
throw(error(representation_error(max_arity), (=..)/2)) % 8.5.3.3 g)
; true
)
; var(Term) ->
throw(error(domain_error(non_empty_list, List), (=..)/2)) % 8.5.3.3 f)
; true
).
Term =.. List :- '$call_with_default_policy'(univ_errors(Term, List, N)),
'$call_with_default_policy'(univ_worker(Term, List, N)).
:- non_counted_backtracking univ_worker/3.
univ_worker(Term, List, _) :- atomic(Term), !, '$call_with_default_policy'(List = [Term]).
univ_worker(Term, [Name|Args], N) :-
var(Term), !,
'$call_with_default_policy'(Arity is N-1),
'$call_with_default_policy'(functor(Term, Name, Arity)),
'$call_with_default_policy'(get_args(Args, Term, 1, Arity)).
univ_worker(Term, List, _) :-
'$call_with_default_policy'(functor(Term, Name, Arity)),
'$call_with_default_policy'(get_args(Args, Term, 1, Arity)),
'$call_with_default_policy'(List = [Name|Args]).
:- non_counted_backtracking get_args/4.
get_args(Args, _, _, 0) :-
!, '$call_with_default_policy'(Args = []).
get_args([Arg], Func, N, N) :-
!, '$call_with_default_policy'(arg(N, Func, Arg)).
get_args([Arg|Args], Func, I0, N) :-
'$call_with_default_policy'(arg(I0, Func, Arg)),
'$call_with_default_policy'(I1 is I0 + 1),
'$call_with_default_policy'(get_args(Args, Func, I1, N)).
% write, write_canonical, writeq, write_term.
is_write_option(Functor) :-
Functor =.. [Name, Arg],
( Arg == true -> true
; Arg == false -> true
; Name == variable_names -> must_be_var_names_list(Arg)
; var(Arg) -> throw(error(instantiation_error, write_term/2))
; throw(error(domain_error(write_option, Functor), write_term/2))
), % 8.14.2.3 e)
( Name == ignore_ops -> true
; Name == quoted -> true
; Name == numbervars -> true
; Name == variable_names -> true
; throw(error(domain_error(write_option, Functor), write_term/2))
). % 8.14.2.3 e)
inst_member_or([X|Xs], Y, Z) :-
( var(X) -> throw(error(instantiation_error, write_term/2))
; is_write_option(X) -> ( Y = X, ! ; inst_member_or(Xs, Y, Z) )
; throw(error(domain_error(write_option, X), write_term/2))
).
inst_member_or([], Y, Y).
must_be_var_names_list(VarNames) :-
'$skip_max_list'(_, -1, VarNames, Tail),
( Tail == [] -> must_be_var_names_list_(VarNames, VarNames)
; var(Tail) -> throw(error(instantiation_error, write_term/2))
; throw(error(domain_error(write_options, variable_names(VarNames)), write_term/2))
).
must_be_var_names_list_([], List).
must_be_var_names_list_([VarName | VarNames], List) :-
( nonvar(VarName) ->
( VarName = (Atom = _) ->
( atom(Atom) -> must_be_var_names_list_(VarNames, List)
; var(Atom) -> throw(error(instantiation_error, write_term/2))
; throw(error(domain_error(write_options, variable_names(List)), write_term/2))
)
; throw(error(domain_error(write_options, variable_names(List)), write_term/2))
)
; throw(error(instantiation_error, write_term/2)) % throw(error(domain_error(write_options, variable_names(List)), write_term/2))
).
write_term(_, Options) :-
var(Options), throw(error(instantiation_error, write_term/2)).
write_term(Term, Options) :-
'$skip_max_list'(_, -1, Options, Options0),
( var(Options0) -> throw(error(instantiation_error, write_term/2))
; Options0 == [] -> true
; throw(error(type_error(list, Options), write_term/2))
), % 8.14.2.3 c)
inst_member_or(Options, ignore_ops(IgnoreOps), ignore_ops(false)),
inst_member_or(Options, numbervars(NumberVars), numbervars(false)),
inst_member_or(Options, quoted(Quoted), quoted(false)),
inst_member_or(Options, variable_names(VarNames), variable_names([])),
'$write_term'(Term, IgnoreOps, NumberVars, Quoted, VarNames).
write(Term) :- write_term(Term, [numbervars(true)]).
write_canonical(Term) :- write_term(Term, [ignore_ops(true), quoted(true)]).
writeq(Term) :- write_term(Term, [quoted(true), numbervars(true)]).
%% TODO: complete the predicate! Most read options are missing.
read_term(Term, Options) :-
'$skip_max_list'(_, -1, Options, Options0),
( Options0 == [] -> true
; var(Options0) -> throw(error(instantiation_error, read_term/2)) % 8.14.1.3 b)
; throw(error(type_error(list, Options), read_term/2)) % 8.14.1.3 d)
),
( Options = [variable_names(VarList)] -> '$read_term'(Term, VarList)
; Options = [] -> read(Term)
; false
).
% expand_goal.
expand_goal(Term0, Term) :- '$expand_goal'(Term0, Term).
% expand_term.
expand_term(Term0, Term) :- '$expand_term'(Term0, Term).
% term_variables.
% ensures List is either a variable or a list.
can_be_list(List, _) :- var(List), !.
can_be_list(List, _) :- '$skip_max_list'(_, -1, List, Tail), ( var(Tail) -> true ; Tail == []), !.
can_be_list(List, PI) :- throw(error(type_error(list, List), PI)).
term_variables(Term, Vars) :-
can_be_list(Vars, term_variables/2),
'$term_variables'(Term, Vars).
% exceptions.
catch(G,C,R) :- '$get_current_block'(Bb), '$call_with_default_policy'(catch(G,C,R,Bb)).
:- non_counted_backtracking catch/4.
catch(G,C,R,Bb) :-
'$install_new_block'(NBb),
call(G),
'$call_with_default_policy'(end_block(Bb, NBb)).
catch(G,C,R,Bb) :-
'$reset_block'(Bb),
'$get_ball'(Ball),
'$call_with_default_policy'(handle_ball(Ball, C, R)).
:- non_counted_backtracking end_block/2.
end_block(Bb, NBb) :- '$clean_up_block'(NBb), '$reset_block'(Bb).
end_block(Bb, NBb) :- '$reset_block'(NBb), '$fail'.
:- non_counted_backtracking handle_ball/3.
handle_ball(C, C, R) :- !, '$erase_ball', call(R).
handle_ball(_, _, _) :- '$unwind_stack'.
throw(Ball) :- '$set_ball'(Ball), '$unwind_stack'.
:- non_counted_backtracking '$iterate_find_all'/4.
'$iterate_find_all'(Template, Goal, _, LhOffset) :-
call(Goal),
'$copy_to_lh'(LhOffset, Template),
'$fail'.
'$iterate_find_all'(_, _, Solutions, LhOffset) :-
'$truncate_if_no_lh_growth'(LhOffset),
'$get_lh_from_offset'(LhOffset, Solutions).
truncate_lh_to(LhLength) :- '$truncate_lh_to'(LhLength).
findall(Template, Goal, Solutions) :-
error:can_be(list, Solutions),
'$lh_length'(LhLength),
'$call_with_default_policy'(catch('$iterate_find_all'(Template, Goal, Solutions, LhLength),
Error,
( truncate_lh_to(LhLength), throw(Error) ))).
:- non_counted_backtracking '$iterate_find_all_diff'/5.
'$iterate_find_all_diff'(Template, Goal, _, _, LhOffset) :-
call(Goal),
'$copy_to_lh'(LhOffset, Template),
'$fail'.
'$iterate_find_all_diff'(_, _, Solutions0, Solutions1, LhOffset) :-
'$truncate_if_no_lh_growth_diff'(LhOffset, Solutions1),
'$get_lh_from_offset_diff'(LhOffset, Solutions0, Solutions1).
findall(Template, Goal, Solutions0, Solutions1) :-
error:can_be(list, Solutions0),
error:can_be(list, Solutions1),
'$lh_length'(LhLength),
'$call_with_default_policy'(catch('$iterate_find_all_diff'(Template, Goal, Solutions0,
Solutions1, LhLength),
Error,
( truncate_lh_to(LhLength), throw(Error) ))).
set_difference([X|Xs], [Y|Ys], Zs) :-
X == Y, !, set_difference(Xs, [Y|Ys], Zs).
set_difference([X|Xs], [Y|Ys], [X|Zs]) :-
X @< Y, !, set_difference(Xs, [Y|Ys], Zs).
set_difference([X|Xs], [Y|Ys], Zs) :-
X @> Y, !, set_difference([X|Xs], Ys, Zs).
set_difference([], _, []) :- !.
set_difference(Xs, [], Xs).
group_by_variant([V2-S2 | Pairs], V1-S1, [S2 | Solutions], Pairs0) :-
non_iso:variant(V1, V2), !, V1 = V2, group_by_variant(Pairs, V2-S2, Solutions, Pairs0).
group_by_variant(Pairs, _, [], Pairs).
group_by_variants([V-S|Pairs], [V-Solution|Solutions]) :-
group_by_variant([V-S|Pairs], V-S, Solution, Pairs0),
group_by_variants(Pairs0, Solutions).
group_by_variants([], []).
iterate_variants([V-Solution|GroupSolutions], V, Solution).
iterate_variants([_|GroupSolutions], Ws, Solution) :-
iterate_variants(GroupSolutions, Ws, Solution).
rightmost_power(Term, FinalTerm, Xs) :-
( Term = X ^ Y
-> ( var(Y) -> FinalTerm = Y, Xs = [X]
; Xs = [X | Xss], rightmost_power(Y, FinalTerm, Xss)
)
; Xs = [], FinalTerm = Term
).
findall_with_existential(Template, Goal, PairedSolutions, Witnesses0, Witnesses) :-
( nonvar(Goal), Goal = _ ^ _ ->
rightmost_power(Goal, Goal1, ExistentialVars0),
term_variables(ExistentialVars0, ExistentialVars),
set_difference(Witnesses0, ExistentialVars, Witnesses),
findall(Witnesses-Template, Goal1, PairedSolutions)
; Witnesses = Witnesses0,
findall(Witnesses-Template, Goal, PairedSolutions)
).
bagof(Template, Goal, Solution) :-
error:can_be(list, Solution),
term_variables(Template, TemplateVars0),
term_variables(Goal, GoalVars0),
sort(TemplateVars0, TemplateVars),
sort(GoalVars0, GoalVars),
set_difference(GoalVars, TemplateVars, Witnesses0),
findall_with_existential(Template, Goal, PairedSolutions0, Witnesses0, Witnesses),
keysort(PairedSolutions0, PairedSolutions),
group_by_variants(PairedSolutions, GroupedSolutions),
iterate_variants(GroupedSolutions, Witnesses, Solution).
iterate_variants_and_sort([V-Solution0|GroupSolutions], V, Solution) :-
sort(Solution0, Solution).
iterate_variants_and_sort([_|GroupSolutions], Ws, Solution) :-
iterate_variants_and_sort(GroupSolutions, Ws, Solution).
setof(Template, Goal, Solution) :-
error:can_be(list, Solution),
term_variables(Template, TemplateVars0),
term_variables(Goal, GoalVars0),
sort(TemplateVars0, TemplateVars),
sort(GoalVars0, GoalVars),
set_difference(GoalVars, TemplateVars, Witnesses0),
findall_with_existential(Template, Goal, PairedSolutions0, Witnesses0, Witnesses),
keysort(PairedSolutions0, PairedSolutions),
group_by_variants(PairedSolutions, GroupedSolutions),
iterate_variants_and_sort(GroupedSolutions, Witnesses, Solution).
% Clause retrieval and information.
'$clause_body_is_valid'(B) :-
( var(B) -> true
; functor(B, Name, _) -> ( atom(Name), Name \== '.' -> true
; throw(error(type_error(callable, B), clause/2))
)
; throw(error(type_error(callable, B), clause/2))
).
'$module_clause'(H, B, Module) :-
( var(H) -> throw(error(instantiation_error, clause/2))
; functor(H, Name, Arity) -> ( Name == '.' -> throw(error(type_error(callable, H), clause/2))
; '$module_head_is_dynamic'(H, Module) ->
'$clause_body_is_valid'(B),
'$get_module_clause'(H, B, Module)
; throw(error(permission_error(access, private_procedure, Name/Arity),
clause/2))
)
; throw(error(type_error(callable, H), clause/2))
).
clause(H, B) :-
( var(H) -> throw(error(instantiation_error, clause/2))
; functor(H, Name, Arity) -> ( Name == '.' -> throw(error(type_error(callable, H), clause/2))
; Name == (:), Arity =:= 2 ->
arg(1, H, Module),
arg(2, H, F),
'$module_clause'(F, B, Module)
%% '$no_such_predicate' fails if H is not callable.
; '$no_such_predicate'(H) -> '$fail'
; '$head_is_dynamic'(H) -> '$clause_body_is_valid'(B),
'$get_clause'(H, B)
; throw(error(permission_error(access, private_procedure, Name/Arity),
clause/2))
)
; throw(error(type_error(callable, H), clause/2))
).
call_module_asserta(Head, Body, Name, Arity, Module) :-
'$clause_body_is_valid'(Body),
functor(VarHead, Name, Arity),
findall((VarHead :- VarBody), clause(Module:VarHead, VarBody), Clauses),
'$module_asserta'((Head :- Body), Clauses, Name, Arity, Module).
call_asserta(Head, Body, Name, Arity) :-
'$clause_body_is_valid'(Body),
functor(VarHead, Name, Arity),
findall((VarHead :- VarBody), clause(VarHead, VarBody), Clauses),
'$asserta'((Head :- Body), Clauses, Name, Arity).
module_asserta_clause(Head, Body, Module) :-
( var(Head) -> throw(error(instantiation_error, asserta/1))
; functor(Head, Name, Arity), atom(Name), Name \== '.' ->
( '$module_head_is_dynamic'(Head, Module) -> call_module_asserta(Head, Body, Name, Arity, Module)
; throw(error(permission_error(modify, static_procedure, Name/Arity), asserta/1))
)
; throw(error(type_error(callable, Head), asserta/1))
).
asserta_clause(Head, Body) :-
( var(Head) -> throw(error(instantiation_error, asserta/1))
; functor(Head, Name, Arity), atom(Name), Name \== '.' ->
( Name == (:), Arity =:= 2 ->
arg(1, Head, Module),
arg(2, Head, F),
module_asserta_clause(F, Body, Module)
; '$no_such_predicate'(Head) -> call_asserta(Head, Body, Name, Arity)
; '$head_is_dynamic'(Head) -> call_asserta(Head, Body, Name, Arity)
; throw(error(permission_error(modify, static_procedure, Name/Arity), asserta/1))
)
; throw(error(type_error(callable, Head), asserta/1))
).
asserta(Clause) :-
( Clause \= (_ :- _) -> Head = Clause, Body = true, asserta_clause(Head, Body)
; Clause = (Head :- Body) -> asserta_clause(Head, Body)
).
call_module_assertz(Head, Body, Name, Arity, Module) :-
'$clause_body_is_valid'(Body),
functor(VarHead, Name, Arity),
findall((VarHead :- VarBody), clause(Module:VarHead, VarBody), Clauses),
'$module_assertz'((Head :- Body), Clauses, Name, Arity, Module).
call_assertz(Head, Body, Name, Arity) :-
'$clause_body_is_valid'(Body),
functor(VarHead, Name, Arity),
findall((VarHead :- VarBody), clause(VarHead, VarBody), Clauses),
'$assertz'((Head :- Body), Clauses, Name, Arity).
module_assertz_clause(Head, Body, Module) :-
( var(Head) -> throw(error(instantiation_error, assertz/1))
; functor(Head, Name, Arity), atom(Name), Name \== '.' ->
( '$module_head_is_dynamic'(Head, Module) -> call_module_assertz(Head, Body, Name, Arity, Module)
; throw(error(permission_error(modify, static_procedure, Name/Arity), assertz/1))
)
; throw(error(type_error(callable, Head), assertz/1))
).
assertz_clause(Head, Body) :-
( var(Head) -> throw(error(instantiation_error, assertz/1))
; functor(Head, Name, Arity), atom(Name), Name \== '.' ->
( Name == (:), Arity =:= 2 ->
arg(1, Head, Module),
arg(2, Head, F),
module_assertz_clause(F, Body, Module)
; '$no_such_predicate'(Head) ->
call_assertz(Head, Body, Name, Arity)
; '$head_is_dynamic'(Head) ->
call_assertz(Head, Body, Name, Arity)
; throw(error(permission_error(modify, static_procedure, Name/Arity), assertz/1))
)
; throw(error(type_error(callable, Head), assertz/1))
).
assertz(Clause) :-
( Clause \= (_ :- _) -> Head = Clause, Body = true, assertz_clause(Head, Body)
; Clause = (Head :- Body) -> assertz_clause(Head, Body)
).
first_match_index([Clause0 | Clauses], Clause1, N0, N) :-
( Clause0 \= Clause1 ->
N1 is N0 + 1,
first_match_index(Clauses, Clause1, N1, N)
; N0 = N, Clause0 = Clause1
).
retract_clauses([Clause | Clauses0], Head, Body, Name, Arity) :-
functor(VarHead, Name, Arity),
findall((VarHead :- VarBody), clause(VarHead, VarBody), Clauses1),
first_match_index(Clauses1, (Head :- Body), 0, N),
( Clauses0 == [] -> !
; true
),
'$retract_clause'(Name, Arity, N, Clauses1).
retract_clauses([_ | Clauses0], Head, Body, Name, Arity) :-
retract_clauses(Clauses0, Head, Body, Name, Arity).
call_retract(Head, Body, Name, Arity) :-
findall((Head :- Body), clause(Head, Body), Clauses),
retract_clauses(Clauses, Head, Body, Name, Arity).
module_retract_clauses([Clause|Clauses0], Head, Body, Name, Arity, Module) :-
functor(VarHead, Name, Arity),
findall((VarHead :- VarBody), clause(Module:VarHead, VarBody), Clauses1),
first_match_index(Clauses1, (Head :- Body), 0, N),
( Clauses0 == [] -> !
; true
),
'$module_retract_clause'(Name, Arity, N, Clauses1, Module).
module_retract_clauses([_|Clauses0], Head, Body, Name, Arity, Module) :-
module_retract_clauses(Clauses0, Head, Body, Name, Arity, Module).
call_module_retract(Head, Body, Name, Arity, Module) :-
findall((Head :- Body), clause(Module:Head, Body), Clauses),
module_retract_clauses(Clauses, Head, Body, Name, Arity, Module).
retract_module_clause(Head, Body, Module) :-
( var(Head) -> throw(error(instantiation_error, retract/1))
; functor(Head, Name, Arity), atom(Name), Name \== '.' ->
( '$module_head_is_dynamic'(Head, Module) ->
call_module_retract(Head, Body, Name, Arity, Module)
; throw(error(permission_error(modify, static_procedure, Name/Arity), retract/1))
)
; throw(error(type_error(callable, Head), retract/1))
).
retract_clause(Head, Body) :-
( var(Head) -> throw(error(instantiation_error, retract/1))
; functor(Head, Name, Arity), atom(Name), Name \== '.' ->
( Name == (:), Arity =:= 2 ->
arg(1, Head, Module),
arg(2, Head, F),
retract_module_clause(F, Body, Module)
; '$head_is_dynamic'(Head) -> call_retract(Head, Body, Name, Arity)
; '$no_such_predicate'(Head) -> '$fail'
; throw(error(permission_error(modify, static_procedure, Name/Arity), retract/1))
)
; throw(error(type_error(callable, Head), retract/1))
).
retract(Clause) :-
( Clause \= (_ :- _) -> Head = Clause, Body = true, retract_clause(Head, Body)
; Clause = (Head :- Body) -> retract_clause(Head, Body)
).
module_abolish(Pred, Module) :-
( var(Pred) -> throw(error(instantiation_error), abolish/1)
; Pred = Name/Arity ->
( var(Name) -> throw(error(instantiation_error, abolish/1))
; integer(Arity) ->
( \+ atom(Name) -> throw(error(type_error(atom, Name), abolish/1))
; Arity < 0 -> throw(error(domain_error(not_less_than_zero, Arity), abolish/1))
; max_arity(N), Arity > N -> throw(error(representation_error(max_arity), abolish/1))
; functor(Head, Name, Arity) ->
( '$module_head_is_dynamic'(Head, Module) ->
'$abolish_module_clause'(Name, Arity, Module)
; throw(error(permission_error(modify, static_procedure, Pred), abolish/1))
)
)
; throw(error(type_error(integer, Arity), abolish/1))
)
; throw(error(type_error(predicate_indicator, Module:Pred), abolish/1))
).
abolish(Pred) :-
( var(Pred) -> throw(error(instantiation_error), abolish/1)
; Pred = Module:InnerPred -> module_abolish(InnerPred, Module)
; Pred = Name/Arity ->
( var(Name) -> throw(error(instantiation_error, abolish/1))
; var(Arity) -> throw(error(instantiation_error, abolish/1))
; integer(Arity) ->
( \+ atom(Name) -> throw(error(type_error(atom, Name), abolish/1))
; Arity < 0 -> throw(error(domain_error(not_less_than_zero, Arity), abolish/1))
; max_arity(N), Arity > N -> throw(error(representation_error(max_arity), abolish/1))
; functor(Head, Name, Arity) ->
( '$no_such_predicate'(Head) -> true
; '$head_is_dynamic'(Head) -> '$abolish_clause'(Name, Arity)
; throw(error(permission_error(modify, static_procedure, Pred), abolish/1))
)
)
; throw(error(type_error(integer, Arity), abolish/1))
)
; throw(error(type_error(predicate_indicator, Pred), abolish/1))
).
'$iterate_db_refs'(Ref, Name/Arity) :-
'$lookup_db_ref'(Ref, Name, Arity).
'$iterate_db_refs'(Ref, Name/Arity) :-
'$get_next_db_ref'(Ref, NextRef),
'$iterate_db_refs'(NextRef, Name/Arity).
current_predicate(Pred) :-
( nonvar(Pred), Pred \= _ / _
-> throw(error(type_error(predicate_indicator, Pred), current_predicate/1))
; '$get_next_db_ref'(Ref, _),
'$iterate_db_refs'(Ref, Pred)
).
'$iterate_op_db_refs'(Ref, Priority, Spec, Op) :-
'$lookup_op_db_ref'(Ref, Priority, Spec, Op).
'$iterate_op_db_refs'(Ref, Priority, Spec, Op) :-
'$get_next_op_db_ref'(Ref, NextRef),
'$iterate_op_db_refs'(NextRef, Priority, Spec, Op).
can_be_op_priority(Priority) :- var(Priority).
can_be_op_priority(Priority) :- op_priority(Priority).
can_be_op_specifier(Spec) :- var(Spec).
can_be_op_specifier(Spec) :- op_specifier(Spec).
current_op(Priority, Spec, Op) :-
( can_be_op_priority(Priority), can_be_op_specifier(Spec), error:can_be(atom, Op)
-> '$get_next_op_db_ref'(Ref, _),
'$iterate_op_db_refs'(Ref, Priority, Spec, Op)
).
list_of_op_atoms(Var) :-
var(Var), throw(error(instantiation_error, op/3)). % 8.14.3.3 c)
list_of_op_atoms([Atom|Atoms]) :-
( valid_op(Atom) -> list_of_op_atoms(Atoms) % 8.14.3.3 k).
; var(Atom) -> throw(error(instantiation_error, op/3)) % 8.14.3.3 c)
; throw(error(type_error(atom, Atom), op/3)) % 8.14.3.3 g)
).
list_of_op_atoms([]).
op_priority(Priority) :-
integer(Priority), !,
( ( Priority < 0 ; Priority > 1200 ) ->
throw(error(domain_error(operator_priority, Priority))) % 8.14.3.3 h)
; true
).
op_priority(Priority) :-
throw(error(type_error(integer, Priority), op/3)). % 8.14.3.3 d)
op_specifier(OpSpec) :- atom(OpSpec),
( lists:member(OpSpec, [yfx, xfy, xfx, yf, fy, xf, fx]), !
; throw(error(domain_error(operator_specifier, OpSpec), op/3)) % 8.14.3.3 i)
).
op_specifier(OpSpec) :- throw(error(type_error(atom, OpSpec), op/3)).
valid_op(Op) :- atom(Op),
( Op == (',') -> throw(error(permission_error(modify, operator, (',')), op/3)) % 8.14.3.3 j), k).
; Op == {} -> throw(error(permission_error(create, operator, {}), op/3))
; Op == [] -> throw(error(permission_error(create, operator, []), op/3))
; true
).
op_(Priority, OpSpec, Op) :- '$op'(Priority, OpSpec, Op).
op(Priority, OpSpec, Op) :-
( var(Priority) -> throw(error(instantiation_error, op/3)) % 8.14.3.3 a)
; var(OpSpec) -> throw(error(instantiation_error, op/3)) % 8.14.3.3 b)
; var(Op) -> throw(error(instantiation_error, op/3)) % 8.14.3.3 c)
; Op == '|' -> ( op_priority(Priority), op_specifier(OpSpec),
lists:member(OpSpec, [xfx, xfy, yfx]), ( Priority >= 1001 ; Priority == 0 )
-> '$op'(Priority, OpSpec, Op)
; throw(error(permission_error(create, operator, (|)), op/3))) % www.complang.tuwien.ac.at/ulrich/iso-prolog/conformity_testing#72
; valid_op(Op), op_priority(Priority), op_specifier(OpSpec) ->
'$op'(Priority, OpSpec, Op)
; list_of_op_atoms(Op), op_priority(Priority), op_specifier(OpSpec) ->
lists:maplist(op_(Priority, OpSpec), Op), !
; throw(error(type_error(list, Op), op/3)) % 8.14.3.3 f)
).
halt :- '$halt'.
atom_length(Atom, Length) :-
( var(Atom) -> throw(error(instantiation_error, atom_length/2)) % 8.16.1.3 a)
; atom(Atom) -> ( var(Length) -> '$atom_length'(Atom, Length)
; integer(Length), Length >= 0 -> '$atom_length'(Atom, Length)
; integer(Length) -> throw(error(domain_error(not_less_than_zero, Length), atom_length/2))
% 8.16.1.3 d)
; throw(error(type_error(integer, Length), atom_length/2)) % 8.16.1.3 c)
)
; throw(error(type_error(atom, Atom), atom_length/2)) % 8.16.1.3 b)
).
atom_chars(Atom, List) :-
'$skip_max_list'(_, -1, List, Tail),
( ( Tail == [] ; var(Tail) ) -> true
; throw(error(type_error(list, List), atom_chars/2))
),
( var(Atom) ->
( var(Tail) -> throw(error(instantiation_error, atom_chars/2))
; ground(List), Tail == [] -> '$atom_chars'(Atom, List)
; throw(error(instantiation_error, atom_chars/2))
)
; atom(Atom) -> can_be_chars_or_vars(List, atom_chars/2), '$atom_chars'(Atom, List)
; throw(error(type_error(atom, Atom), atom_chars/2))
).
atom_codes(Atom, List) :-
'$skip_max_list'(_, -1, List, Tail),
( ( Tail == [] ; var(Tail) ) -> true
; throw(error(type_error(list, List), atom_codes/2))
),
( var(Atom) ->
( var(Tail) -> throw(error(instantiation_error, atom_codes/2))
; ground(List), Tail == [] -> '$atom_codes'(Atom, List)
; throw(error(instantiation_error, atom_codes/2))
)
; atom(Atom) -> can_be_codes_or_vars(List, atom_codes/2), '$atom_codes'(Atom, List)
; throw(error(type_error(atom, Atom), atom_codes/2))
).
atom_concat(Atom_1, Atom_2, Atom_12) :-
error:can_be(atom, Atom_1),
error:can_be(atom, Atom_2),
error:can_be(atom, Atom_12),
( var(Atom_1) ->
( var(Atom_12) -> throw(error(instantiation_error, atom_concat/3))
; atom_chars(Atom_12, Atom_12_Chars),
lists:append(BeforeChars, AfterChars, Atom_12_Chars),
atom_chars(Atom_1, BeforeChars),
atom_chars(Atom_2, AfterChars)
)
; var(Atom_2) ->
( var(Atom_12) -> throw(error(instantiation_error, atom_concat/3))
; atom_chars(Atom_1, Atom_1_Chars),
atom_chars(Atom_12, Atom_12_Chars),
lists:append(Atom_1_Chars, Atom_2_Chars, Atom_12_Chars),
atom_chars(Atom_2, Atom_2_Chars)
)
; atom_chars(Atom_1, Atom_1_Chars),
atom_chars(Atom_2, Atom_2_Chars),
lists:append(Atom_1_Chars, Atom_2_Chars, Atom_12_Chars),
atom_chars(Atom_12, Atom_12_Chars)
).
sub_atom(Atom, Before, Length, After, Sub_atom) :-
error:must_be(atom, Atom),
error:can_be(atom, Sub_atom),
error:can_be(integer, Before),
error:can_be(integer, Length),
error:can_be(integer, After),
( integer(Before), Before < 0 -> throw(error(domain_error(not_less_than_zero, Before), sub_atom/5))
; integer(Length), Length < 0 -> throw(error(domain_error(not_less_than_zero, Length), sub_atom/5))
; integer(After), After < 0 -> throw(error(domain_error(not_less_than_zero, After), sub_atom/5))
; atom_chars(Atom, AtomChars),
lists:append(BeforeChars, LengthAndAfterChars, AtomChars),
lists:append(LengthChars, AfterChars, LengthAndAfterChars),
'$skip_max_list'(Before, -1, BeforeChars, []),
'$skip_max_list'(Length, -1, LengthChars, []),
'$skip_max_list'(After, -1, AfterChars, []),
atom_chars(Sub_atom, LengthChars)
).
char_code(Char, Code) :-
( var(Char) ->
( var(Code) -> throw(error(instantiation_error, char_code/2))
; integer(Code) -> '$char_code'(Char, Code)
; throw(error(type_error(integer, Code), char_code/2))
)
; atom_length(Char, 1) -> '$char_code'(Char, Code)
; throw(error(type_error(character, Char), char_code/2))
).
get_char(C) :-
( var(C) -> '$get_char'(C)
; C == end_of_file -> '$get_char'(C)
; atom_length(C, 1) -> '$get_char'(C)
; throw(error(type_error(in_character, C), get_char/1))
).
can_be_number(N, PI) :-
( var(N) -> true
; must_be_number(N, PI)
).
must_be_number(N, _) :-
( integer(N)
; float(N)
),
!.
must_be_number(N, PI) :-
( nonvar(N) -> throw(error(type_error(number, N), PI))
; throw(error(instantiation_error, PI))
).
can_be_chars_or_vars(Cs, _) :- var(Cs), !.
can_be_chars_or_vars(Cs, PI) :- chars_or_vars(Cs, PI).
chars_or_vars([], _).
chars_or_vars([C|Cs], PI) :-
( nonvar(C) ->
( catch(atom_length(C, 1), _, false) ->
( nonvar(Cs) -> chars_or_vars(Cs, PI)
; false
)
; throw(error(type_error(character, C), PI))
)
; chars_or_vars(Cs, PI)
).
can_be_codes_or_vars(Cs, _) :- var(Cs), !.
can_be_codes_or_vars(Cs, PI) :- codes_or_vars(Cs, PI).
codes_or_vars([], _).
codes_or_vars([C|Cs], PI) :-
( nonvar(C) ->
( catch(char_code(_, C), _, false) ->
( nonvar(Cs) -> codes_or_vars(Cs, PI)
; false
)
; integer(C) -> throw(error(representation_error(character_code), PI))
; throw(error(type_error(integer, C), PI))
)
; codes_or_vars(Cs, PI)
).
number_chars(N, Chs) :-
( ground(Chs)
-> can_be_number(N, number_chars/2),
can_be_list(Chs, number_chars/2),
'$chars_to_number'(Chs, Nx),
Nx = N
; must_be_number(N, number_chars/2),
( var(Chs) -> true
; can_be_list(Chs, number_chars/2)
, chars_or_vars(Chs, number_chars/2)
),
'$number_to_chars'(N, Chsx),
Chsx = Chs
).
number_codes(N, Chs) :-
( ground(Chs)
-> can_be_number(N, number_codes/2),
can_be_list(Chs, number_codes/2),
'$codes_to_number'(Chs, Nx),
Nx = N
; must_be_number(N, number_codes/2),
( var(Chs) -> true
; can_be_list(Chs, number_codes/2)
, codes_or_vars(Chs, number_codes/2)
),
'$number_to_codes'(N, Chsx),
Chsx = Chs
).
subsumes_term(General, Specific) :-
\+ \+ (
term_variables(Specific, SVs1),
General = Specific,
term_variables(SVs1, SVs2),
SVs1 == SVs2
).
unify_with_occurs_check(X, Y) :- '$unify_with_occurs_check'(X, Y).
Reference in New Issue View Git Blame Copy Permalink