rishi/scryer-prolog
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge pull request #932 from pmoura/fix_abolish_bug_with_no_existing_predicates

Browse Source 
Fix abolish/1 to succeed on non-existing predicates as per standard
This commit is contained in:
Mark Thom
2021-05-08 12:39:28 -06:00
committed by GitHub
parent b968b2c438 d8c0af7ded
commit 56eaf883dc
1 changed files with 84 additions and 82 deletions
Download Patch File Download Diff File Expand all files Collapse all files

166
src/lib/builtins.pl
View File

@@ -161,7 +161,7 @@ set_prolog_flag(min_integer, Value) :-
set_prolog_flag(integer_rounding_function, down) :- !. % 7.11.1.4 set_prolog_flag(integer_rounding_function, down) :- !. % 7.11.1.4
set_prolog_flag(integer_rounding_function, Value) :- set_prolog_flag(integer_rounding_function, Value) :-
throw(error(domain_error(flag_value, 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/2)). % 8.17.1.3 e
set_prolog_flag(double_quotes, chars) :- set_prolog_flag(double_quotes, chars) :-
!, '$set_double_quotes'(chars). % 7.11.2.5, list of one-char atoms. !, '$set_double_quotes'(chars). % 7.11.2.5, list of one-char atoms.
set_prolog_flag(double_quotes, atom) :- set_prolog_flag(double_quotes, atom) :-
@@ -176,7 +176,7 @@ set_prolog_flag(occurs_check, error) :-
!, '$set_sto_with_error_as_unify'. !, '$set_sto_with_error_as_unify'.
set_prolog_flag(double_quotes, Value) :- set_prolog_flag(double_quotes, Value) :-
throw(error(domain_error(flag_value, double_quotes + Value), throw(error(domain_error(flag_value, double_quotes + Value),
set_prolog_flag/2)). % 8.17.1.3 e set_prolog_flag/2)). % 8.17.1.3 e
set_prolog_flag(Flag, _) :- set_prolog_flag(Flag, _) :-
atom(Flag), atom(Flag),
throw(error(domain_error(prolog_flag, Flag), set_prolog_flag/2)). % 8.17.1.3 d throw(error(domain_error(prolog_flag, Flag), set_prolog_flag/2)). % 8.17.1.3 d
@@ -359,18 +359,18 @@ univ_errors(Term, List, N) :-
; List = [H|T] -> ; List = [H|T] ->
( var(H), ( var(H),
var(Term), % R == [] => List is a proper list. var(Term), % R == [] => List is a proper list.
throw(error(instantiation_error, (=..)/2)) % 8.5.3.3 c) throw(error(instantiation_error, (=..)/2)) % 8.5.3.3 c)
; T \== [], ; T \== [],
nonvar(H), nonvar(H),
\+ atom(H), \+ atom(H),
throw(error(type_error(atom, H), (=..)/2)) % 8.5.3.3 d) throw(error(type_error(atom, H), (=..)/2)) % 8.5.3.3 d)
; compound(H), ; compound(H),
T == [], T == [],
throw(error(type_error(atomic, H), (=..)/2)) % 8.5.3.3 e) throw(error(type_error(atomic, H), (=..)/2)) % 8.5.3.3 e)
; var(Term), ; var(Term),
max_arity(M), max_arity(M),
N - 1 > M, N - 1 > M,
throw(error(representation_error(max_arity), (=..)/2)) % 8.5.3.3 g) throw(error(representation_error(max_arity), (=..)/2)) % 8.5.3.3 g)
; true ; true
) )
; var(Term) -> ; var(Term) ->
@@ -380,7 +380,7 @@ univ_errors(Term, List, N) :-
Term =.. List :- Term =.. List :-
'$call_with_default_policy'(univ_errors(Term, List, N)), '$call_with_default_policy'(univ_errors(Term, List, N)),
'$call_with_default_policy'(univ_worker(Term, List, N)). '$call_with_default_policy'(univ_worker(Term, List, N)).
:- non_counted_backtracking univ_worker/3. :- non_counted_backtracking univ_worker/3.
@@ -482,12 +482,12 @@ must_be_var_names_list_([], List).
must_be_var_names_list_([VarName | VarNames], List) :- must_be_var_names_list_([VarName | VarNames], List) :-
( nonvar(VarName) -> ( nonvar(VarName) ->
( VarName = (Atom = _) -> ( VarName = (Atom = _) ->
( atom(Atom) -> ( atom(Atom) ->
must_be_var_names_list_(VarNames, List) must_be_var_names_list_(VarNames, List)
; var(Atom) -> ; var(Atom) ->
throw(error(instantiation_error, write_term/2)) throw(error(instantiation_error, write_term/2))
; throw(error(domain_error(write_option, variable_names(List)), write_term/2)) ; throw(error(domain_error(write_option, variable_names(List)), write_term/2))
) )
; throw(error(domain_error(write_option, variable_names(List)), write_term/2)) ; throw(error(domain_error(write_option, variable_names(List)), write_term/2))
) )
; throw(error(instantiation_error, write_term/2)) ; throw(error(instantiation_error, write_term/2))
@@ -638,8 +638,8 @@ findall(Template, Goal, Solutions) :-
'$lh_length'(LhLength), '$lh_length'(LhLength),
'$call_with_default_policy'( '$call_with_default_policy'(
catch(builtins:'$iterate_find_all'(Template, Goal, Solutions, LhLength), catch(builtins:'$iterate_find_all'(Template, Goal, Solutions, LhLength),
Error, Error,
( builtins:truncate_lh_to(LhLength), builtins:throw(Error) )) ( builtins:truncate_lh_to(LhLength), builtins:throw(Error) ))
). ).
@@ -662,9 +662,9 @@ findall(Template, Goal, Solutions0, Solutions1) :-
'$lh_length'(LhLength), '$lh_length'(LhLength),
'$call_with_default_policy'( '$call_with_default_policy'(
catch(builtins:'$iterate_find_all_diff'(Template, Goal, Solutions0, catch(builtins:'$iterate_find_all_diff'(Template, Goal, Solutions0,
Solutions1, LhLength), Solutions1, LhLength),
Error, Error,
( builtins:truncate_lh_to(LhLength), builtins:throw(Error) )) ( builtins:truncate_lh_to(LhLength), builtins:throw(Error) ))
). ).
set_difference([X|Xs], [Y|Ys], Zs) :- set_difference([X|Xs], [Y|Ys], Zs) :-
@@ -768,8 +768,8 @@ setof(Template, Goal, Solution) :-
( var(B) -> true ( var(B) -> true
; functor(B, Name, _) -> ; functor(B, Name, _) ->
( atom(Name), Name \== '.' -> true ( atom(Name), Name \== '.' -> true
; throw(error(type_error(callable, B), clause/2)) ; throw(error(type_error(callable, B), clause/2))
) )
; throw(error(type_error(callable, B), clause/2)) ; throw(error(type_error(callable, B), clause/2))
). ).
@@ -778,13 +778,13 @@ setof(Template, Goal, Solution) :-
throw(error(instantiation_error, clause/2)) throw(error(instantiation_error, clause/2))
; callable(H), functor(H, Name, Arity) -> ; callable(H), functor(H, Name, Arity) ->
( '$head_is_dynamic'(Module, H) -> ( '$head_is_dynamic'(Module, H) ->
'$clause_body_is_valid'(B), '$clause_body_is_valid'(B),
Module:'$clause'(H, B) Module:'$clause'(H, B)
; '$no_such_predicate'(Module, H) -> ; '$no_such_predicate'(Module, H) ->
'$fail' '$fail'
; throw(error(permission_error(access, private_procedure, Name/Arity), ; throw(error(permission_error(access, private_procedure, Name/Arity),
clause/2)) clause/2))
) )
; throw(error(type_error(callable, H), clause/2)) ; throw(error(type_error(callable, H), clause/2))
). ).
@@ -795,18 +795,18 @@ clause(H, B) :-
; callable(H), functor(H, Name, Arity) -> ; callable(H), functor(H, Name, Arity) ->
( Name == (:), ( Name == (:),
Arity =:= 2 -> Arity =:= 2 ->
arg(1, H, Module), arg(1, H, Module),
arg(2, H, F), arg(2, H, F),
'$module_clause'(F, B, Module) '$module_clause'(F, B, Module)
; '$head_is_dynamic'(user, H) -> ; '$head_is_dynamic'(user, H) ->
'$clause_body_is_valid'(B), '$clause_body_is_valid'(B),
'$clause'(H, B) '$clause'(H, B)
; '$no_such_predicate'(user, H) -> %% '$no_such_predicate' fails if ; '$no_such_predicate'(user, H) -> %% '$no_such_predicate' fails if
%% H is not callable. %% H is not callable.
'$fail' '$fail'
; throw(error(permission_error(access, private_procedure, Name/Arity), ; throw(error(permission_error(access, private_procedure, Name/Arity),
clause/2)) clause/2))
) )
; throw(error(type_error(callable, H), clause/2)) ; throw(error(type_error(callable, H), clause/2))
). ).
@@ -833,14 +833,14 @@ asserta_clause(Head, Body) :-
; callable(Head), functor(Head, Name, Arity) -> ; callable(Head), functor(Head, Name, Arity) ->
( Name == (:), ( Name == (:),
Arity =:= 2 -> Arity =:= 2 ->
arg(1, Head, Module), arg(1, Head, Module),
arg(2, Head, HeadAndBody), arg(2, Head, HeadAndBody),
( HeadAndBody = (F :- Body1) -> ( HeadAndBody = (F :- Body1) ->
true true
; F = HeadAndBody, ; F = HeadAndBody,
Body1 = true Body1 = true
), ),
module_asserta_clause(F, Body1, Module) module_asserta_clause(F, Body1, Module)
; '$head_is_dynamic'(user, Head) -> ; '$head_is_dynamic'(user, Head) ->
call_asserta(Head, Body, Name, Arity, user) call_asserta(Head, Body, Name, Arity, user)
; '$no_such_predicate'(user, Head) -> ; '$no_such_predicate'(user, Head) ->
@@ -868,7 +868,7 @@ module_assertz_clause(Head, Body, Module) :-
( '$head_is_dynamic'(Module, Head) -> ( '$head_is_dynamic'(Module, Head) ->
call_assertz(Head, Body, Name, Arity, Module) call_assertz(Head, Body, Name, Arity, Module)
; '$no_such_predicate'(Module, Head) -> ; '$no_such_predicate'(Module, Head) ->
call_assertz(Head, Body, Name, Arity, Module) call_assertz(Head, Body, Name, Arity, Module)
; throw(error(permission_error(modify, static_procedure, Name/Arity), ; throw(error(permission_error(modify, static_procedure, Name/Arity),
assertz/1)) assertz/1))
) )
@@ -887,18 +887,18 @@ assertz_clause(Head, Body) :-
; callable(Head), functor(Head, Name, Arity) -> ; callable(Head), functor(Head, Name, Arity) ->
( Name == (:), ( Name == (:),
Arity =:= 2 -> Arity =:= 2 ->
arg(1, Head, Module), arg(1, Head, Module),
arg(2, Head, HeadAndBody), arg(2, Head, HeadAndBody),
( HeadAndBody = (F :- Body1) -> ( HeadAndBody = (F :- Body1) ->
true true
; F = HeadAndBody, ; F = HeadAndBody,
Body1 = true Body1 = true
), ),
module_assertz_clause(F, Body1, Module) module_assertz_clause(F, Body1, Module)
; '$head_is_dynamic'(user, Head) -> ; '$head_is_dynamic'(user, Head) ->
call_assertz(Head, Body, Name, Arity, user) call_assertz(Head, Body, Name, Arity, user)
; '$no_such_predicate'(user, Head) -> ; '$no_such_predicate'(user, Head) ->
call_assertz(Head, Body, Name, Arity, user) call_assertz(Head, Body, Name, Arity, user)
; throw(error(permission_error(modify, static_procedure, Name/Arity), ; throw(error(permission_error(modify, static_procedure, Name/Arity),
assertz/1)) assertz/1))
) )
@@ -982,14 +982,14 @@ retract_clause(Head, Body) :-
; callable(Head), functor(Head, Name, Arity) -> ; callable(Head), functor(Head, Name, Arity) ->
( Name == (:), ( Name == (:),
Arity =:= 2 -> Arity =:= 2 ->
arg(1, Head, Module), arg(1, Head, Module),
arg(2, Head, HeadAndBody), arg(2, Head, HeadAndBody),
( HeadAndBody = (F :- Body1) -> ( HeadAndBody = (F :- Body1) ->
true true
; F = HeadAndBody, ; F = HeadAndBody,
Body1 = true Body1 = true
), ),
retract_module_clause(F, Body1, Module) retract_module_clause(F, Body1, Module)
; '$no_such_predicate'(user, Head) -> ; '$no_such_predicate'(user, Head) ->
'$fail' '$fail'
; '$head_is_dynamic'(user, Head) -> ; '$head_is_dynamic'(user, Head) ->
@@ -1026,18 +1026,20 @@ module_abolish(Pred, Module) :-
( var(Name) -> ( var(Name) ->
throw(error(instantiation_error, abolish/1)) throw(error(instantiation_error, abolish/1))
; integer(Arity) -> ; integer(Arity) ->
( \+ atom(Name) -> ( \+ atom(Name) ->
throw(error(type_error(atom, Name), abolish/1)) throw(error(type_error(atom, Name), abolish/1))
; Arity < 0 -> ; Arity < 0 ->
throw(error(domain_error(not_less_than_zero, Arity), abolish/1)) throw(error(domain_error(not_less_than_zero, Arity), abolish/1))
; max_arity(N), Arity > N -> ; max_arity(N), Arity > N ->
throw(error(representation_error(max_arity), abolish/1)) throw(error(representation_error(max_arity), abolish/1))
; functor(Head, Name, Arity) -> ; functor(Head, Name, Arity) ->
( '$head_is_dynamic'(Module, Head) -> ( '$head_is_dynamic'(Module, Head) ->
'$abolish_clause'(Module, Name, Arity) '$abolish_clause'(Module, Name, Arity)
; throw(error(permission_error(modify, static_procedure, Pred), abolish/1)) ; '$no_such_predicate'(Module, Head) ->
) true
) ; throw(error(permission_error(modify, static_procedure, Pred), abolish/1))
)
)
; throw(error(type_error(integer, Arity), abolish/1)) ; throw(error(type_error(integer, Arity), abolish/1))
) )
; throw(error(type_error(predicate_indicator, Module:Pred), abolish/1)) ; throw(error(type_error(predicate_indicator, Module:Pred), abolish/1))
@@ -1057,20 +1059,20 @@ abolish(Pred) :-
; var(Arity) -> ; var(Arity) ->
throw(error(instantiation_error, abolish/1)) throw(error(instantiation_error, abolish/1))
; integer(Arity) -> ; integer(Arity) ->
( \+ atom(Name) -> ( \+ atom(Name) ->
throw(error(type_error(atom, Name), abolish/1)) throw(error(type_error(atom, Name), abolish/1))
; Arity < 0 -> ; Arity < 0 ->
throw(error(domain_error(not_less_than_zero, Arity), abolish/1)) throw(error(domain_error(not_less_than_zero, Arity), abolish/1))
; max_arity(N), Arity > N -> ; max_arity(N), Arity > N ->
throw(error(representation_error(max_arity), abolish/1)) throw(error(representation_error(max_arity), abolish/1))
; functor(Head, Name, Arity) -> ; functor(Head, Name, Arity) ->
( '$head_is_dynamic'(user, Head) -> ( '$head_is_dynamic'(user, Head) ->
'$abolish_clause'(user, Name, Arity) '$abolish_clause'(user, Name, Arity)
; '$no_such_predicate'(user, Head) -> ; '$no_such_predicate'(user, Head) ->
true true
; throw(error(permission_error(modify, static_procedure, Pred), abolish/1)) ; throw(error(permission_error(modify, static_procedure, Pred), abolish/1))
) )
) )
; throw(error(type_error(integer, Arity), abolish/1)) ; throw(error(type_error(integer, Arity), abolish/1))
) )
; throw(error(type_error(predicate_indicator, Pred), abolish/1)) ; throw(error(type_error(predicate_indicator, Pred), abolish/1))
@@ -1162,10 +1164,10 @@ op(Priority, OpSpec, Op) :-
; Op == '|' -> ; Op == '|' ->
( op_priority(Priority), ( op_priority(Priority),
op_specifier(OpSpec), op_specifier(OpSpec),
lists:member(OpSpec, [xfx, xfy, yfx]), lists:member(OpSpec, [xfx, xfy, yfx]),
( Priority >= 1001 ; Priority == 0 ) ( Priority >= 1001 ; Priority == 0 )
-> '$op'(Priority, OpSpec, Op) -> '$op'(Priority, OpSpec, Op)
; throw(error(permission_error(create, operator, (|)), op/3))) % www.complang.tuwien.ac.at/ulrich/iso-prolog/conformity_testing#72 ; 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) -> ; valid_op(Op), op_priority(Priority), op_specifier(OpSpec) ->
'$op'(Priority, OpSpec, Op) '$op'(Priority, OpSpec, Op)
; list_of_op_atoms(Op), op_priority(Priority), op_specifier(OpSpec) -> ; list_of_op_atoms(Op), op_priority(Priority), op_specifier(OpSpec) ->
@@ -1190,13 +1192,13 @@ atom_length(Atom, Length) :-
; atom(Atom) -> ; atom(Atom) ->
( var(Length) -> ( var(Length) ->
'$atom_length'(Atom, Length) '$atom_length'(Atom, Length)
; integer(Length), Length >= 0 -> ; integer(Length), Length >= 0 ->
'$atom_length'(Atom, Length) '$atom_length'(Atom, Length)
; integer(Length) -> ; integer(Length) ->
throw(error(domain_error(not_less_than_zero, Length), atom_length/2)) throw(error(domain_error(not_less_than_zero, Length), atom_length/2))
% 8.16.1.3 d) % 8.16.1.3 d)
; throw(error(type_error(integer, Length), atom_length/2)) % 8.16.1.3 c) ; 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) ; throw(error(type_error(atom, Atom), atom_length/2)) % 8.16.1.3 b)
). ).
@@ -1244,16 +1246,16 @@ atom_concat(Atom_1, Atom_2, Atom_12) :-
( var(Atom_12) -> ( var(Atom_12) ->
throw(error(instantiation_error, atom_concat/3)) throw(error(instantiation_error, atom_concat/3))
; atom_chars(Atom_12, Atom_12_Chars), ; atom_chars(Atom_12, Atom_12_Chars),
lists:append(BeforeChars, AfterChars, Atom_12_Chars), lists:append(BeforeChars, AfterChars, Atom_12_Chars),
atom_chars(Atom_1, BeforeChars), atom_chars(Atom_1, BeforeChars),
atom_chars(Atom_2, AfterChars) atom_chars(Atom_2, AfterChars)
) )
; var(Atom_2) -> ; var(Atom_2) ->
( var(Atom_12) -> throw(error(instantiation_error, atom_concat/3)) ( var(Atom_12) -> throw(error(instantiation_error, atom_concat/3))
; atom_chars(Atom_1, Atom_1_Chars), ; atom_chars(Atom_1, Atom_1_Chars),
atom_chars(Atom_12, Atom_12_Chars), atom_chars(Atom_12, Atom_12_Chars),
lists:append(Atom_1_Chars, Atom_2_Chars, Atom_12_Chars), lists:append(Atom_1_Chars, Atom_2_Chars, Atom_12_Chars),
atom_chars(Atom_2, Atom_2_Chars) atom_chars(Atom_2, Atom_2_Chars)
) )
; atom_chars(Atom_1, Atom_1_Chars), ; atom_chars(Atom_1, Atom_1_Chars),
atom_chars(Atom_2, Atom_2_Chars), atom_chars(Atom_2, Atom_2_Chars),
@@ -1325,10 +1327,10 @@ chars_or_vars([], _).
chars_or_vars([C|Cs], PI) :- chars_or_vars([C|Cs], PI) :-
( nonvar(C) -> ( nonvar(C) ->
( catch(builtins:atom_length(C, 1), _, false) -> ( catch(builtins:atom_length(C, 1), _, false) ->
( nonvar(Cs) -> ( nonvar(Cs) ->
chars_or_vars(Cs, PI) chars_or_vars(Cs, PI)
; false ; false
) )
; throw(error(type_error(character, C), PI)) ; throw(error(type_error(character, C), PI))
) )
; chars_or_vars(Cs, PI) ; chars_or_vars(Cs, PI)
@@ -1341,9 +1343,9 @@ codes_or_vars([], _).
codes_or_vars([C|Cs], PI) :- codes_or_vars([C|Cs], PI) :-
( nonvar(C) -> ( nonvar(C) ->
( catch(builtins:char_code(_, C), _, false) -> ( catch(builtins:char_code(_, C), _, false) ->
( nonvar(Cs) -> codes_or_vars(Cs, PI) ( nonvar(Cs) -> codes_or_vars(Cs, PI)
; false ; false
) )
; integer(C) -> ; integer(C) ->
throw(error(representation_error(character_code), PI)) throw(error(representation_error(character_code), PI))
; throw(error(type_error(integer, C), PI)) ; throw(error(type_error(integer, C), PI))