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

various fixes

Browse Source
This commit is contained in:
Mark Thom
2019-04-22 21:28:33 -06:00
parent 535465fcd4
commit a5dc7f2387
7 changed files with 148 additions and 136 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
Cargo.toml
View File

@@ -1,6 +1,6 @@
[package] [package]
name = "scryer-prolog" name = "scryer-prolog"
version = "0.8.59" version = "0.8.60"
authors = ["Mark Thom <markjordanthom@gmail.com>"] authors = ["Mark Thom <markjordanthom@gmail.com>"]
repository = "https://github.com/mthom/scryer-prolog" repository = "https://github.com/mthom/scryer-prolog"
description = "A modern Prolog implementation written mostly in Rust." description = "A modern Prolog implementation written mostly in Rust."

9
src/prolog/lib/between.pl
View File

@@ -5,9 +5,14 @@
:- use_module(library(lists), [length/2]). :- use_module(library(lists), [length/2]).
:- use_module(library(error)). :- use_module(library(error)).
between(Lower, Upper, Lower) :- between(Lower, Upper, X) :-
must_be(integer, Lower),
must_be(integer, Upper),
between_(Lower, Upper, X).
between_(Lower, Upper, Lower) :-
Lower =< Upper. Lower =< Upper.
between(Lower1, Upper, X) :- between_(Lower1, Upper, X) :-
Lower1 < Upper, Lower1 < Upper,
Lower2 is Lower1 + 1, Lower2 is Lower1 + 1,
between(Lower2, Upper, X). between(Lower2, Upper, X).

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

@@ -1,5 +1,10 @@
:- op(400, yfx, /). :- op(400, yfx, /).
/* 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).
:- module(builtins, [(=)/2, (\=)/2, (\+)/1, (^)/2, (\)/1, (+)/1, :- module(builtins, [(=)/2, (\=)/2, (\+)/1, (^)/2, (\)/1, (+)/1,
(+)/2, (**)/2, (*)/2, (-)/1, (-)/2, (/)/2, (/\)/2, (\/)/2, (+)/2, (**)/2, (*)/2, (-)/1, (-)/2, (/)/2, (/\)/2, (\/)/2,
(is)/2, (xor)/2, (div)/2, (//)/2, (rdiv)/2, (<<)/2, (>>)/2, (is)/2, (xor)/2, (div)/2, (//)/2, (rdiv)/2, (<<)/2, (>>)/2,
@@ -7,19 +12,13 @@
(=<)/2, (',')/2, (->)/2, (;)/2, (=..)/2, (==)/2, (\==)/2, (=<)/2, (',')/2, (->)/2, (;)/2, (=..)/2, (==)/2, (\==)/2,
(@=<)/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, abolish/1, asserta/1, assertz/1, atom_chars/2, atom_codes/2,
atom_length/2, bagof/3, bb_b_put/2, bb_get/2, bb_put/2, atom_length/2, bagof/3, call_with_inference_limit/3, catch/3,
call_cleanup/2, call_with_inference_limit/3, catch/3, char_code/2, clause/2, current_op/3, current_predicate/1,
char_code/2, clause/2, current_predicate/1, current_op/3, current_prolog_flag/2, expand_goal/2, expand_term/2, false/0,
current_prolog_flag/2, expand_goal/2, expand_term/2,
findall/3, findall/4, get_char/1, halt/0, once/1, op/3, 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, read_term/2, repeat/0, retract/1, set_prolog_flag/2, setof/3,
setup_call_cleanup/3, term_variables/2, throw/1, true/0, setup_call_cleanup/3, term_variables/2, throw/1, true/0,
false/0, write/1, write_canonical/1, writeq/1, write_term/2]). write/1, write_canonical/1, write_term/2, writeq/1]).
/* 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).
% module resolution operator. % module resolution operator.
:- op(600, xfy, :). :- op(600, xfy, :).
@@ -44,6 +43,12 @@ expand_op_list([Op | OtherOps], Pred, Spec, [(:- op(Pred, Spec, Op)) | OtherResu
% arithmetic comparison operators. % arithmetic comparison operators.
:- op(700, xfx, [>, <, =\=, =:=, >=, =<]). :- op(700, xfx, [>, <, =\=, =:=, >=, =<]).
% term comparison.
:- op(700, xfx, [==, \==, @=<, @>=, @<, @>, =@=, \=@=]).
% the maximum arity flag. needs to be replaced with current_prolog_flag(max_arity, MAX_ARITY).
max_arity(63).
% conditional operators. % conditional operators.
:- op(1050, xfy, ->). :- op(1050, xfy, ->).
:- op(1100, xfy, ;). :- op(1100, xfy, ;).
@@ -52,12 +57,6 @@ expand_op_list([Op | OtherOps], Pred, Spec, [(:- op(Pred, Spec, Op)) | OtherResu
:- op(700, xfx, [=, =.., \=]). :- op(700, xfx, [=, =.., \=]).
:- op(900, fy, \+). :- op(900, fy, \+).
% term comparison.
:- op(700, xfx, [==, \==, @=<, @>=, @<, @>, =@=, \=@=]).
% the maximum arity flag. needs to be replaced with current_prolog_flag(max_arity, MAX_ARITY).
max_arity(63).
% unify. % unify.
X = X. X = X.
@@ -238,7 +237,7 @@ inst_member_or([], Y, Y).
write_term(_, Options) :- write_term(_, Options) :-
var(Options), throw(error(instantiation_error, write_term/2)). var(Options), throw(error(instantiation_error, write_term/2)).
write_term(Term, Options) :- write_term(Term, Options) :-
'$skip_max_list'(_, -1, Options, Options0), '$skip_max_list'(_, -1, Options, Options0),
( var(Options0) -> throw(error(instantiation_error, write_term/2)) ( var(Options0) -> throw(error(instantiation_error, write_term/2))
; Options0 == [] -> true ; Options0 == [] -> true
@@ -286,88 +285,6 @@ term_variables(Term, Vars) :-
can_be_list(Vars, term_variables/2), can_be_list(Vars, term_variables/2),
'$term_variables'(Term, Vars). '$term_variables'(Term, Vars).
% 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 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'.
:- 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'.
call_cleanup(G, C) :- setup_call_cleanup(true, G, C).
% call_with_inference_limit
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)).
:- 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)).
% exceptions. % exceptions.
catch(G,C,R) :- '$get_current_block'(Bb), '$call_with_default_policy'(catch(G,C,R,Bb)). catch(G,C,R) :- '$get_current_block'(Bb), '$call_with_default_policy'(catch(G,C,R,Bb)).
@@ -803,31 +720,14 @@ op(Priority, OpSpec, Op) :-
; throw(error(type_error(list, Op), op/3)) % 8.14.3.3 f) ; throw(error(type_error(list, Op), op/3)) % 8.14.3.3 f)
). ).
%% (non-)backtrackable global variables.
bb_put(Key, Value) :- atom(Key), !, '$store_global_var'(Key, Value).
bb_put(Key, _) :- throw(error(type_error(atom, Key), bb_put/2)).
bb_b_put(Key, NewValue) :-
( bb_get(Key, OldValue) ->
call_cleanup((store_global_var(Key, NewValue) ; false), store_global_var(Key, OldValue))
; call_cleanup((store_global_var(Key, NewValue) ; false), reset_global_var_at_key(Key))
).
store_global_var(Key, Value) :- '$store_global_var'(Key, Value).
reset_global_var_at_key(Key) :- '$reset_global_var_at_key'(Key).
bb_get(Key, Value) :- atom(Key), !, '$fetch_global_var'(Key, Value).
bb_get(Key, _) :- throw(error(type_error(atom, Key), bb_get/2)).
halt :- '$halt'. halt :- '$halt'.
atom_length(Atom, Length) :- atom_length(Atom, Length) :-
( var(Atom) -> throw(error(instantiation_error, atom_length/2)) % 8.16.1.3 a) ( var(Atom) -> throw(error(instantiation_error, atom_length/2)) % 8.16.1.3 a)
; atom(Atom) -> ( var(Length) -> '$atom_length'(Atom, Length) ; atom(Atom) -> ( var(Length) -> '$atom_length'(Atom, Length)
; integer(Length), Length >= 0 -> '$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) ; 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(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)
@@ -835,12 +735,13 @@ atom_length(Atom, Length) :-
no_var_in_list([]). no_var_in_list([]).
no_var_in_list([X|Xs]) :- var(X), !, '$fail'. no_var_in_list([X|Xs]) :- var(X), !, '$fail'.
no_var_in_list([_|Xs]) :- no_var_in_list(Xs). no_var_in_list([_|Xs]) :- nonvar(Xs), no_var_in_list(Xs).
atom_chars(Atom, List) :- atom_chars(Atom, List) :-
( var(Atom) -> ( var(Atom) ->
( var(List) -> throw(error(instantiation_error, atom_chars/2)) ( var(List) -> throw(error(instantiation_error, atom_chars/2))
; can_be_list(List, atom_chars/3), no_var_in_list(List) -> '$atom_chars'(Atom, List) ; can_be_list(List, atom_chars/3), no_var_in_list(List) -> '$atom_chars'(Atom, List)
; throw(error(instantiation_error, atom_chars/2))
) )
; atom(Atom) -> '$atom_chars'(Atom, List) ; atom(Atom) -> '$atom_chars'(Atom, List)
; throw(error(type_error(atom, Atom), atom_chars/2)) ; throw(error(type_error(atom, Atom), atom_chars/2))
@@ -850,6 +751,7 @@ atom_codes(Atom, List) :-
( var(Atom) -> ( var(Atom) ->
( var(List) -> throw(error(instantiation_error, atom_codes/2)) ( var(List) -> throw(error(instantiation_error, atom_codes/2))
; can_be_list(List, atom_codes/3), no_var_in_list(List) -> '$atom_codes'(Atom, List) ; can_be_list(List, atom_codes/3), no_var_in_list(List) -> '$atom_codes'(Atom, List)
; throw(error(instantiation_error, atom_codes/2))
) )
; atom(Atom) -> '$atom_codes'(Atom, List) ; atom(Atom) -> '$atom_codes'(Atom, List)
; throw(error(type_error(atom, Atom), atom_codes/2)) ; throw(error(type_error(atom, Atom), atom_codes/2))
@@ -870,3 +772,83 @@ get_char(C) :-
; atom_length(C, 1) -> '$get_char'(C) ; atom_length(C, 1) -> '$get_char'(C)
; throw(error(type_error(in_character, C), get_char/1)) ; 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)).

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

@@ -3,8 +3,28 @@
%% ?- use_module(library(non_iso)). %% ?- use_module(library(non_iso)).
:- module(non_iso, [forall/2]). :- module(non_iso, [bb_b_put/2, bb_get/2, bb_put/2, call_cleanup/2,
forall/2]).
forall(Generate, Test) :- forall(Generate, Test) :-
\+ (Generate, \+ Test). \+ (Generate, \+ Test).
%% (non-)backtrackable global variables.
bb_put(Key, Value) :- atom(Key), !, '$store_global_var'(Key, Value).
bb_put(Key, _) :- throw(error(type_error(atom, Key), bb_put/2)).
bb_b_put(Key, NewValue) :-
( bb_get(Key, OldValue) ->
call_cleanup((store_global_var(Key, NewValue) ; false), store_global_var(Key, OldValue))
; call_cleanup((store_global_var(Key, NewValue) ; false), reset_global_var_at_key(Key))
).
store_global_var(Key, Value) :- '$store_global_var'(Key, Value).
reset_global_var_at_key(Key) :- '$reset_global_var_at_key'(Key).
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).

2
src/prolog/machine/compile.rs
View File

@@ -123,8 +123,6 @@ fn compile_query(terms: Vec<QueryTerm>, queue: VecDeque<TopLevel>, flags: Machin
let mut code = try!(cg.compile_query(&terms)); let mut code = try!(cg.compile_query(&terms));
compile_appendix(&mut code, &queue, false, flags)?; compile_appendix(&mut code, &queue, false, flags)?;
print_code(&code);
Ok((code, cg.take_vars())) Ok((code, cg.take_vars()))
} }

28
src/prolog/machine/machine_state_impl.rs
View File

@@ -676,19 +676,20 @@ impl MachineState {
}; };
} }
pub(super) fn get_number(&self, at: &ArithmeticTerm) -> Result<Number, MachineStub> { pub(super) fn get_number(&mut self, at: &ArithmeticTerm) -> Result<Number, MachineStub> {
match at { match at {
&ArithmeticTerm::Reg(r) => self.arith_eval_by_metacall(r), &ArithmeticTerm::Reg(r) =>
&ArithmeticTerm::Interm(i) => Ok(self.interms[i-1].clone()), self.arith_eval_by_metacall(r),
&ArithmeticTerm::Number(ref n) => Ok(n.clone()), &ArithmeticTerm::Interm(i) =>
Ok(mem::replace(&mut self.interms[i-1], Number::Integer(Rc::new(BigInt::zero())))),
&ArithmeticTerm::Number(ref n) =>
Ok(n.clone()),
} }
} }
fn get_rational(&self, at: &ArithmeticTerm, caller: &MachineStub) fn rational_from_number(&self, n: Number, caller: &MachineStub)
-> Result<Rc<Ratio<BigInt>>, MachineStub> -> Result<Rc<Ratio<BigInt>>, MachineStub>
{ {
let n = self.get_number(at)?;
match n { match n {
Number::Rational(r) => Ok(r), Number::Rational(r) => Ok(r),
Number::Float(fl) => Number::Float(fl) =>
@@ -701,6 +702,13 @@ impl MachineState {
Ok(Rc::new(Ratio::from_integer((*bi).clone()))) Ok(Rc::new(Ratio::from_integer((*bi).clone())))
} }
} }
fn get_rational(&mut self, at: &ArithmeticTerm, caller: &MachineStub)
-> Result<Rc<Ratio<BigInt>>, MachineStub>
{
let n = self.get_number(at)?;
self.rational_from_number(n, caller)
}
fn signed_bitwise_op<Op>(&self, n1: &BigInt, n2: &BigInt, f: Op) -> Rc<BigInt> fn signed_bitwise_op<Op>(&self, n1: &BigInt, n2: &BigInt, f: Op) -> Rc<BigInt>
where Op: FnOnce(&BigUint, &BigUint) -> BigUint where Op: FnOnce(&BigUint, &BigUint) -> BigUint
@@ -736,8 +744,8 @@ impl MachineState {
"^" => interms.push(self.binary_pow(a1, a2)?), "^" => interms.push(self.binary_pow(a1, a2)?),
"max" => interms.push(self.max(a1, a2)?), "max" => interms.push(self.max(a1, a2)?),
"rdiv" => { "rdiv" => {
let r1 = self.get_rational(&ArithmeticTerm::Number(a1), &caller)?; let r1 = self.rational_from_number(a1, &caller)?;
let r2 = self.get_rational(&ArithmeticTerm::Number(a2), &caller)?; let r2 = self.rational_from_number(a2, &caller)?;
let result = Number::Rational(self.rdiv(r1, r2)?); let result = Number::Rational(self.rdiv(r1, r2)?);
interms.push(result) interms.push(result)

1
src/tests.rs
View File

@@ -1972,7 +1972,6 @@ foo(X) :- call(X) -> call(X).");
} }
#[test] #[test]
fn test_queries_on_setup_call_cleanup() fn test_queries_on_setup_call_cleanup()
{ {