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

move setup_call_cleanup/3 and call_with_inference_limit/3 to non_iso

Browse Source
This commit is contained in:
Mark Thom
2019-04-23 08:40:10 -06:00
parent a5dc7f2387
commit b102749220
4 changed files with 99 additions and 91 deletions
Download Patch File Download Diff File Expand all files Collapse all files

94
src/prolog/lib/builtins.pl
View File

@@ -12,13 +12,13 @@
(=<)/2, (',')/2, (->)/2, (;)/2, (=..)/2, (==)/2, (\==)/2,
(@=<)/2, (@>=)/2, (@<)/2, (@>)/2, (=@=)/2, (\=@=)/2, (:)/2,
abolish/1, asserta/1, assertz/1, atom_chars/2, atom_codes/2,
atom_length/2, bagof/3, call_with_inference_limit/3, catch/3,
char_code/2, clause/2, current_op/3, current_predicate/1,
current_prolog_flag/2, expand_goal/2, expand_term/2, false/0,
findall/3, findall/4, get_char/1, halt/0, once/1, op/3,
read_term/2, repeat/0, retract/1, set_prolog_flag/2, setof/3,
setup_call_cleanup/3, term_variables/2, throw/1, true/0,
write/1, write_canonical/1, write_term/2, writeq/1]).
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, false/0, findall/3, findall/4,
get_char/1, halt/0, once/1, op/3, read_term/2, repeat/0,
retract/1, set_prolog_flag/2, setof/3, term_variables/2,
throw/1, true/0, write/1, write_canonical/1, write_term/2,
writeq/1]).
% module resolution operator.
:- op(600, xfy, :).
@@ -772,83 +772,3 @@ get_char(C) :-
; atom_length(C, 1) -> '$get_char'(C)
; throw(error(type_error(in_character, C), get_char/1))
).
% setup_call_cleanup.
setup_call_cleanup(S, G, C) :- '$get_b_value'(B),
S, '$set_cp_by_default'(B), '$get_current_block'(Bb),
( '$call_with_default_policy'(var(C)) -> throw(error(instantiation_error, setup_call_cleanup/3))
; '$call_with_default_policy'(scc_helper(C, G, Bb)) ).
:- non_counted_backtracking run_cleaners_with_handling/0.
run_cleaners_with_handling :-
'$get_scc_cleaner'(C), '$get_level'(B),
'$call_with_default_policy'(catch(C, _, true)),
'$set_cp_by_default'(B),
'$call_with_default_policy'(run_cleaners_with_handling).
run_cleaners_with_handling :-
'$restore_cut_policy'.
:- non_counted_backtracking run_cleaners_without_handling/1.
run_cleaners_without_handling(Cp) :-
'$get_scc_cleaner'(C), '$get_level'(B), C, '$set_cp_by_default'(B),
'$call_with_default_policy'(run_cleaners_without_handling(Cp)).
run_cleaners_without_handling(Cp) :-
'$set_cp_by_default'(Cp), '$restore_cut_policy'.
:- non_counted_backtracking scc_helper/3.
scc_helper(C, G, Bb) :-
'$get_cp'(Cp), '$install_scc_cleaner'(C, NBb), call(G),
( '$check_cp'(Cp) -> '$reset_block'(Bb),
'$call_with_default_policy'(run_cleaners_without_handling(Cp))
; '$call_with_default_policy'(true)
; '$reset_block'(NBb), '$fail').
scc_helper(_, _, Bb) :-
'$reset_block'(Bb), '$get_ball'(Ball),
'$call_with_default_policy'(run_cleaners_with_handling),
'$erase_ball',
'$call_with_default_policy'(throw(Ball)).
scc_helper(_, _, _) :-
'$get_cp'(Cp),
'$call_with_default_policy'(run_cleaners_without_handling(Cp)),
'$fail'.
% call_with_inference_limit
:- non_counted_backtracking end_block/4.
end_block(_, Bb, NBb, L) :-
'$clean_up_block'(NBb),
'$reset_block'(Bb).
end_block(B, Bb, NBb, L) :-
'$install_inference_counter'(B, L, _),
'$reset_block'(NBb),
'$fail'.
:- non_counted_backtracking handle_ile/3.
handle_ile(B, inference_limit_exceeded(B), inference_limit_exceeded) :- !.
handle_ile(B, E, _) :-
'$remove_call_policy_check'(B),
'$call_with_default_policy'(throw(E)).
call_with_inference_limit(G, L, R) :-
'$get_current_block'(Bb),
'$get_b_value'(B),
'$call_with_default_policy'(call_with_inference_limit(G, L, R, Bb, B)),
'$remove_call_policy_check'(B).
:- non_counted_backtracking call_with_inference_limit/5.
call_with_inference_limit(G, L, R, Bb, B) :-
'$install_new_block'(NBb),
'$install_inference_counter'(B, L, Count0),
call(G),
'$inference_level'(R, B),
'$remove_inference_counter'(B, Count1),
'$call_with_default_policy'(is(Diff, L - (Count1 - Count0))),
'$call_with_default_policy'(end_block(B, Bb, NBb, Diff)).
call_with_inference_limit(_, _, R, Bb, B) :-
'$reset_block'(Bb),
'$remove_inference_counter'(B, _),
( '$get_ball'(Ball), '$get_level'(Cp), '$set_cp_by_default'(Cp)
; '$remove_call_policy_check'(B), '$fail' ),
'$erase_ball',
'$call_with_default_policy'(handle_ile(B, Ball, R)).

84
src/prolog/lib/non_iso.pl
View File

@@ -4,7 +4,8 @@
%% ?- use_module(library(non_iso)).
:- module(non_iso, [bb_b_put/2, bb_get/2, bb_put/2, call_cleanup/2,
forall/2]).
call_with_inference_limit/3, forall/2,
setup_call_cleanup/3]).
forall(Generate, Test) :-
\+ (Generate, \+ Test).
@@ -28,3 +29,84 @@ bb_get(Key, Value) :- atom(Key), !, '$fetch_global_var'(Key, Value).
bb_get(Key, _) :- throw(error(type_error(atom, Key), bb_get/2)).
call_cleanup(G, C) :- setup_call_cleanup(true, G, C).
% setup_call_cleanup.
setup_call_cleanup(S, G, C) :- '$get_b_value'(B),
S, '$set_cp_by_default'(B), '$get_current_block'(Bb),
( '$call_with_default_policy'(var(C)) -> throw(error(instantiation_error, setup_call_cleanup/3))
; '$call_with_default_policy'(scc_helper(C, G, Bb)) ).
:- non_counted_backtracking run_cleaners_with_handling/0.
run_cleaners_with_handling :-
'$get_scc_cleaner'(C), '$get_level'(B),
'$call_with_default_policy'(catch(C, _, true)),
'$set_cp_by_default'(B),
'$call_with_default_policy'(run_cleaners_with_handling).
run_cleaners_with_handling :-
'$restore_cut_policy'.
:- non_counted_backtracking run_cleaners_without_handling/1.
run_cleaners_without_handling(Cp) :-
'$get_scc_cleaner'(C), '$get_level'(B), C, '$set_cp_by_default'(B),
'$call_with_default_policy'(run_cleaners_without_handling(Cp)).
run_cleaners_without_handling(Cp) :-
'$set_cp_by_default'(Cp), '$restore_cut_policy'.
:- non_counted_backtracking scc_helper/3.
scc_helper(C, G, Bb) :-
'$get_cp'(Cp), '$install_scc_cleaner'(C, NBb), call(G),
( '$check_cp'(Cp) -> '$reset_block'(Bb),
'$call_with_default_policy'(run_cleaners_without_handling(Cp))
; '$call_with_default_policy'(true)
; '$reset_block'(NBb), '$fail').
scc_helper(_, _, Bb) :-
'$reset_block'(Bb), '$get_ball'(Ball),
'$call_with_default_policy'(run_cleaners_with_handling),
'$erase_ball',
'$call_with_default_policy'(throw(Ball)).
scc_helper(_, _, _) :-
'$get_cp'(Cp),
'$call_with_default_policy'(run_cleaners_without_handling(Cp)),
'$fail'.
% call_with_inference_limit
:- non_counted_backtracking end_block/4.
end_block(_, Bb, NBb, L) :-
'$clean_up_block'(NBb),
'$reset_block'(Bb).
end_block(B, Bb, NBb, L) :-
'$install_inference_counter'(B, L, _),
'$reset_block'(NBb),
'$fail'.
:- non_counted_backtracking handle_ile/3.
handle_ile(B, inference_limit_exceeded(B), inference_limit_exceeded) :- !.
handle_ile(B, E, _) :-
'$remove_call_policy_check'(B),
'$call_with_default_policy'(throw(E)).
call_with_inference_limit(G, L, R) :-
'$get_current_block'(Bb),
'$get_b_value'(B),
'$call_with_default_policy'(call_with_inference_limit(G, L, R, Bb, B)),
'$remove_call_policy_check'(B).
:- non_counted_backtracking call_with_inference_limit/5.
call_with_inference_limit(G, L, R, Bb, B) :-
'$install_new_block'(NBb),
'$install_inference_counter'(B, L, Count0),
call(G),
'$inference_level'(R, B),
'$remove_inference_counter'(B, Count1),
'$call_with_default_policy'(is(Diff, L - (Count1 - Count0))),
'$call_with_default_policy'(end_block(B, Bb, NBb, Diff)).
call_with_inference_limit(_, _, R, Bb, B) :-
'$reset_block'(Bb),
'$remove_inference_counter'(B, _),
( '$get_ball'(Ball), '$get_level'(Cp), '$set_cp_by_default'(Cp)
; '$remove_call_policy_check'(B), '$fail' ),
'$erase_ball',
'$call_with_default_policy'(handle_ile(B, Ball, R)).

6
src/prolog/machine/machine_indices.rs
View File

@@ -528,10 +528,10 @@ impl IndexStore {
let r_w_h = clause_name!("run_cleaners_with_handling");
let r_wo_h = clause_name!("run_cleaners_without_handling");
let builtins = clause_name!("builtins");
let non_iso = clause_name!("non_iso");
let r_w_h = self.get_internal(r_w_h, 0, builtins.clone()).and_then(|item| item.local());
let r_wo_h = self.get_internal(r_wo_h, 1, builtins).and_then(|item| item.local());
let r_w_h = self.get_internal(r_w_h, 0, non_iso.clone()).and_then(|item| item.local());
let r_wo_h = self.get_internal(r_wo_h, 1, non_iso).and_then(|item| item.local());
if let Some(r_w_h) = r_w_h {
if let Some(r_wo_h) = r_wo_h {

6
src/tests.rs
View File

@@ -1669,6 +1669,8 @@ fn test_queries_on_builtins()
assert_prolog_success!(&mut wam, "call(((G = 2 ; fail), B=3, !)).",
[["G = 2", "B = 3"]]);
submit(&mut wam, ":- use_module(library(non_iso)).");
assert_prolog_success!(&mut wam, "call_with_inference_limit((setup_call_cleanup(S=1,(G=2;fail),writeq(S+G>B)), B=3, !), 100, R).",
[["G = 2", "B = 3", "R = !", "S = 1"]]);
assert_prolog_success!(&mut wam, "call_with_inference_limit((setup_call_cleanup(S=1,(G=2;fail),writeq(S+G>B)), B=3, !), 10, R).",
@@ -1977,6 +1979,8 @@ fn test_queries_on_setup_call_cleanup()
{
let mut wam = Machine::new(readline::input_stream());
submit(&mut wam, ":- use_module(library(non_iso)).");
// Test examples from the ISO Prolog page for setup_call_catch.
assert_prolog_failure!(&mut wam, "setup_call_cleanup(false, _, _).");
assert_prolog_success!(&mut wam, "catch(setup_call_cleanup(true, throw(unthrown), _), error(instantiation_error, _), true).");
@@ -2037,6 +2041,8 @@ fn test_queries_on_call_with_inference_limit()
{
let mut wam = Machine::new(readline::input_stream());
submit(&mut wam, ":- use_module(library(non_iso)).");
assert_prolog_success!(&mut wam, "call_with_inference_limit(throw(error), 0, R).",
[["R = inference_limit_exceeded"]]);
assert_prolog_success!(&mut wam, "catch(call_with_inference_limit(throw(error), 1, R), error, true).");