From: Mark Thom Date: Tue, 23 Apr 2019 14:40:10 +0000 (-0600) Subject: move setup_call_cleanup/3 and call_with_inference_limit/3 to non_iso X-Git-Tag: v0.8.110~90 X-Git-Url: https://git.sagredo.dev/?a=commitdiff_plain;h=b1027492200e4016cceb5b41c728644f16b45847;p=scryer-prolog.git move setup_call_cleanup/3 and call_with_inference_limit/3 to non_iso --- diff --git a/src/prolog/lib/builtins.pl b/src/prolog/lib/builtins.pl index 03c00757..b13fcf5a 100644 --- a/src/prolog/lib/builtins.pl +++ b/src/prolog/lib/builtins.pl @@ -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)). diff --git a/src/prolog/lib/non_iso.pl b/src/prolog/lib/non_iso.pl index 43695038..f23c2d8e 100644 --- a/src/prolog/lib/non_iso.pl +++ b/src/prolog/lib/non_iso.pl @@ -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)). diff --git a/src/prolog/machine/machine_indices.rs b/src/prolog/machine/machine_indices.rs index 07b1f25c..11e65a99 100644 --- a/src/prolog/machine/machine_indices.rs +++ b/src/prolog/machine/machine_indices.rs @@ -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 { diff --git a/src/tests.rs b/src/tests.rs index 97eb7556..13f73315 100644 --- a/src/tests.rs +++ b/src/tests.rs @@ -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).");