Merge pull request #1885 from mthom/setof_bagof_fixes

Fix group_by_variants/4 and keysort in setof/3
2023-07-18 12:35:10 -06:00
parent 56f6772422 ff5e9a793b
commit 1ba040c24d
9 changed files with 213 additions and 23 deletions
--- a/build/instructions_template.rs
+++ b/build/instructions_template.rs
@@ -408,6 +408,8 @@ enum SystemClauseType {
    GetCutPoint,
    #[strum_discriminants(strum(props(Arity = "1", Name = "$get_double_quotes")))]
    GetDoubleQuotes,
+    #[strum_discriminants(strum(props(Arity = "1", Name = "$get_unknown")))]
+    GetUnknown,
    #[strum_discriminants(strum(props(Arity = "1", Name = "$install_new_block")))]
    InstallNewBlock,
    #[strum_discriminants(strum(props(Arity = "0", Name = "$maybe")))]
@@ -438,6 +440,8 @@ enum SystemClauseType {
    SetCutPointByDefault(RegType),
    #[strum_discriminants(strum(props(Arity = "1", Name = "$set_double_quotes")))]
    SetDoubleQuotes,
+    #[strum_discriminants(strum(props(Arity = "1", Name = "$set_unknown")))]
+    SetUnknown,
    #[strum_discriminants(strum(props(Arity = "1", Name = "$set_seed")))]
    SetSeed,
    #[strum_discriminants(strum(props(Arity = "4", Name = "$skip_max_list")))]
@@ -584,6 +588,8 @@ enum SystemClauseType {
    UnattributedVar,
    #[strum_discriminants(strum(props(Arity = "4", Name = "$get_db_refs")))]
    GetDBRefs,
+    #[strum_discriminants(strum(props(Arity = "2", Name = "$keysort_with_constant_var_ordering")))]
+    KeySortWithConstantVarOrdering,
    REPL(REPLCodePtr),
 }

@@ -1649,6 +1655,7 @@ fn generate_instruction_preface() -> TokenStream {
                    &Instruction::CallDeleteAllAttributesFromVar |
                    &Instruction::CallUnattributedVar |
                    &Instruction::CallGetDBRefs |
+                    &Instruction::CallKeySortWithConstantVarOrdering |
                    &Instruction::CallFetchGlobalVar |
                    &Instruction::CallFirstStream |
                    &Instruction::CallFlushOutput |
@@ -1716,6 +1723,7 @@ fn generate_instruction_preface() -> TokenStream {
                    &Instruction::CallGetCurrentSCCBlock |
                    &Instruction::CallGetCutPoint |
                    &Instruction::CallGetDoubleQuotes |
+                    &Instruction::CallGetUnknown |
                    &Instruction::CallInstallNewBlock |
                    &Instruction::CallMaybe |
                    &Instruction::CallCpuNow |
@@ -1742,6 +1750,7 @@ fn generate_instruction_preface() -> TokenStream {
                    &Instruction::CallPopFromBallStack |
                    &Instruction::CallSetCutPointByDefault(..) |
                    &Instruction::CallSetDoubleQuotes |
+                    &Instruction::CallSetUnknown |
                    &Instruction::CallSetSeed |
                    &Instruction::CallSkipMaxList |
                    &Instruction::CallSleep |
@@ -1874,6 +1883,7 @@ fn generate_instruction_preface() -> TokenStream {
                    &Instruction::ExecuteDeleteAllAttributesFromVar |
                    &Instruction::ExecuteUnattributedVar |
                    &Instruction::ExecuteGetDBRefs |
+                    &Instruction::ExecuteKeySortWithConstantVarOrdering |
                    &Instruction::ExecuteFetchGlobalVar |
                    &Instruction::ExecuteFirstStream |
                    &Instruction::ExecuteFlushOutput |
@@ -1941,6 +1951,7 @@ fn generate_instruction_preface() -> TokenStream {
                    &Instruction::ExecuteGetCurrentSCCBlock |
                    &Instruction::ExecuteGetCutPoint |
                    &Instruction::ExecuteGetDoubleQuotes |
+                    &Instruction::ExecuteGetUnknown |
                    &Instruction::ExecuteInstallNewBlock |
                    &Instruction::ExecuteMaybe |
                    &Instruction::ExecuteCpuNow |
@@ -1967,6 +1978,7 @@ fn generate_instruction_preface() -> TokenStream {
                    &Instruction::ExecutePopFromBallStack |
                    &Instruction::ExecuteSetCutPointByDefault(_) |
                    &Instruction::ExecuteSetDoubleQuotes |
+                    &Instruction::ExecuteSetUnknown |
                    &Instruction::ExecuteSetSeed |
                    &Instruction::ExecuteSkipMaxList |
                    &Instruction::ExecuteSleep |
--- a/src/forms.rs
+++ b/src/forms.rs
@@ -55,6 +55,12 @@ impl AppendOrPrepend {
    }
 }

+#[derive(Debug, Clone, Copy)]
+pub enum VarComparison {
+    Indistinct,
+    Distinct
+}
+
 #[derive(Debug, Clone, Copy, PartialEq, Eq, Hash)]
 pub enum Level {
    Deep,
--- a/src/lib/builtins.pl
+++ b/src/lib/builtins.pl
@@ -140,7 +140,9 @@ call(_, _, _, _, _, _, _, _, _).
 %  * `occurs_check`: Returns if the occurs check is enabled. The occurs check prevents the creation cyclic terms.
 %    Historically the Prolog unification algorithm didn't do that check so changing the value modifies how Prolog
 %    operates in the low-level. Possible values are `false`  (default), `true` (unification has this check
-%    enabled) and `error` which throws an exception when a cylic term is created. Read ans write.
+%    enabled) and `error` which throws an exception when a cylic term is created. Read and write.
+%  * `unknown`: How undefined predicates are handled when called. Possible values are `error` (the default, an error is thrown),
+%    `fail` (the call silently fails) and `warn` (the call fails and a warning about the undefined predicate is printed).
 %
 current_prolog_flag(Flag, Value) :- Flag == max_arity, !, Value = 1023.
 current_prolog_flag(max_arity, 1023).
@@ -150,6 +152,8 @@ current_prolog_flag(Flag, Value) :- Flag == integer_rounding_function, !, Value
 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, Value) :- Flag == unknown, !, '$get_unknown'(Value).
+current_prolog_flag(unknown, Value) :- '$get_unknown'(Value).
 current_prolog_flag(Flag, _) :- Flag == max_integer, !, '$fail'.
 current_prolog_flag(Flag, _) :- Flag == min_integer, !, '$fail'.
 current_prolog_flag(Flag, OccursCheckEnabled) :-
@@ -190,6 +194,12 @@ 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(unknown, error) :-
+    !, '$set_unknown'(error).
+set_prolog_flag(unknown, warning) :-
+    !, '$set_unknown'(warning).
+set_prolog_flag(unknown, fail) :-
+    !, '$set_unknown'(fail).
 set_prolog_flag(occurs_check, true) :-
    !, '$set_sto_as_unify'.
 set_prolog_flag(occurs_check, false) :-
@@ -908,12 +918,45 @@ set_difference([X|Xs], [Y|Ys], Zs) :-
 set_difference([], _, []) :- !.
 set_difference(Xs, [], Xs).

+
+% variant/2 checks whether X is a variant of Y per the definition in
+% 7.1.6.1 of the ISO standard.
+
+:- non_counted_backtracking variant/4.
+
+variant(X,Y,VPs,VPs0) :-
+    (  var(X) ->
+       var(Y),
+       VPs = [X-Y|VPs0]
+    ;  var(Y) ->
+       false
+    ;  X =.. [FX | XArgs],
+       Y =.. [FX | YArgs],
+       lists:foldl('$call'(builtins:variant), XArgs, YArgs, VPs, VPs0)
+    ).
+
+:- non_counted_backtracking variant/2.
+
+singleton([_]).
+
+variant(X, Y) :-
+    variant(X,Y, VPs, []),
+    keysort(VPs, SVPs),
+    pairs:group_pairs_by_key(SVPs, SVPKs),
+    pairs:pairs_values(SVPKs, Vals),
+    lists:maplist('$call'(builtins:term_variables), Vals, Vs),
+    lists:maplist('$call'(builtins:singleton), Vs),
+    term_variables(Vs, YVars),
+    lists:length(SVPKs, N),
+    lists:length(YVars, N).
+
+
 :- non_counted_backtracking group_by_variant/4.

 group_by_variant([V2-S2 | Pairs], V1-S1, [S2 | Solutions], Pairs0) :-
-    V1 = V2, % \+ \+ (V1 = V2), % (2) % iso_ext:variant(V1, V2), % (1)
+    variant(V1, V2),
    !,
-    % V1 = V2, % (3)
+    V1 = V2,
    group_by_variant(Pairs, V2-S2, Solutions, Pairs0).
 group_by_variant(Pairs, _, [], Pairs).

@@ -1033,7 +1076,7 @@ setof(Template, Goal, Solution) :-
    term_variables(TemplateVars+GoalVars, TGVs),
    lists:append(TemplateVars, Witnesses0, TGVs),
    findall_with_existential(Template, Goal, PairedSolutions0, Witnesses0, Witnesses),
-    keysort(PairedSolutions0, PairedSolutions),
+    '$keysort_with_constant_var_ordering'(PairedSolutions0, PairedSolutions), % see 7.2.1
    group_by_variants(PairedSolutions, GroupedSolutions),
    iterate_variants_and_sort(GroupedSolutions, Witnesses, Solution).

--- a/src/machine/dispatch.rs
+++ b/src/machine/dispatch.rs
@@ -141,7 +141,7 @@ impl MachineState {
        Ok(())
    }

-    fn keysort(&mut self) -> CallResult {
+    fn keysort(&mut self, var_comparison: VarComparison) -> CallResult {
        self.check_keysort_errors()?;

        let stub_gen = || functor_stub(atom!("keysort"), 2);
@@ -155,7 +155,7 @@ impl MachineState {
        }

        key_pairs.sort_by(|a1, a2| {
-            compare_term_test!(self, a1.0, a2.0).unwrap_or(Ordering::Less)
+            compare_term_test!(self, a1.0, a2.0, var_comparison).unwrap_or(Ordering::Less)
        });

        let key_pairs = key_pairs.into_iter().map(|kp| kp.1);
@@ -1396,11 +1396,11 @@ impl Machine {
                    step_or_fail!(self, self.machine_st.p = self.machine_st.cp);
                }
                &Instruction::DefaultCallKeySort => {
-                    try_or_throw!(self.machine_st, self.machine_st.keysort());
+                    try_or_throw!(self.machine_st, self.machine_st.keysort(VarComparison::Distinct));
                    step_or_fail!(self, self.machine_st.p += 1);
                }
                &Instruction::DefaultExecuteKeySort => {
-                    try_or_throw!(self.machine_st, self.machine_st.keysort());
+                    try_or_throw!(self.machine_st, self.machine_st.keysort(VarComparison::Distinct));

                    if self.machine_st.fail {
                        self.machine_st.backtrack();
@@ -1801,7 +1801,7 @@ impl Machine {
                    }
                }
                &Instruction::CallKeySort => {
-                    try_or_throw!(self.machine_st, self.machine_st.keysort());
+                    try_or_throw!(self.machine_st, self.machine_st.keysort(VarComparison::Distinct));

                    if self.machine_st.fail {
                        self.machine_st.backtrack();
@@ -1815,7 +1815,35 @@ impl Machine {
                    }
                }
                &Instruction::ExecuteKeySort => {
-                    try_or_throw!(self.machine_st, self.machine_st.keysort());
+                    try_or_throw!(self.machine_st, self.machine_st.keysort(VarComparison::Distinct));
+
+                    if self.machine_st.fail {
+                        self.machine_st.backtrack();
+                    } else {
+                        try_or_throw!(
+                            self.machine_st,
+                            (self.machine_st.increment_call_count_fn)(&mut self.machine_st)
+                        );
+
+                        self.machine_st.p = self.machine_st.cp;
+                    }
+                }
+                &Instruction::CallKeySortWithConstantVarOrdering => {
+                    try_or_throw!(self.machine_st, self.machine_st.keysort(VarComparison::Indistinct));
+
+                    if self.machine_st.fail {
+                        self.machine_st.backtrack();
+                    } else {
+                        try_or_throw!(
+                            self.machine_st,
+                            (self.machine_st.increment_call_count_fn)(&mut self.machine_st)
+                        );
+
+                        self.machine_st.p += 1;
+                    }
+                }
+                &Instruction::ExecuteKeySortWithConstantVarOrdering => {
+                    try_or_throw!(self.machine_st, self.machine_st.keysort(VarComparison::Indistinct));

                    if self.machine_st.fail {
                        self.machine_st.backtrack();
@@ -4097,6 +4125,14 @@ impl Machine {
                    self.get_double_quotes();
                    step_or_fail!(self, self.machine_st.p = self.machine_st.cp);
                }
+                &Instruction::CallGetUnknown => {
+                    self.get_unknown();
+                    step_or_fail!(self, self.machine_st.p += 1);
+                }
+                &Instruction::ExecuteGetUnknown => {
+                    self.get_unknown();
+                    step_or_fail!(self, self.machine_st.p = self.machine_st.cp);
+                }
                &Instruction::CallInstallNewBlock => {
                    self.machine_st.install_new_block(self.machine_st.registers[1]);
                    step_or_fail!(self, self.machine_st.p += 1);
@@ -4285,6 +4321,14 @@ impl Machine {
                    self.set_double_quotes();
                    step_or_fail!(self, self.machine_st.p = self.machine_st.cp);
                }
+                &Instruction::CallSetUnknown => {
+                    self.set_unknown();
+                    step_or_fail!(self, self.machine_st.p += 1);
+                }
+                &Instruction::ExecuteSetUnknown => {
+                    self.set_unknown();
+                    step_or_fail!(self, self.machine_st.p = self.machine_st.cp);
+                }
                &Instruction::CallSetSeed => {
                    self.set_seed();
                    step_or_fail!(self, self.machine_st.p += 1);
--- a/src/machine/machine_state_impl.rs
+++ b/src/machine/machine_state_impl.rs
@@ -435,7 +435,7 @@ impl MachineState {
        }
    }

-    pub fn compare_term_test(&mut self) -> Option<Ordering> {
+    pub fn compare_term_test(&mut self, var_comparison: VarComparison) -> Option<Ordering> {
        let mut tabu_list = IndexSet::new();

        while !self.pdl.is_empty() {
@@ -462,12 +462,14 @@ impl MachineState {

            match order_cat_v1 {
                Some(TermOrderCategory::Variable) => {
-                    let v1 = v1.as_var().unwrap();
-                    let v2 = v2.as_var().unwrap();
+                    if let VarComparison::Distinct = var_comparison {
+                        let v1 = v1.as_var().unwrap();
+                        let v2 = v2.as_var().unwrap();

-                    if v1 != v2 {
-                        self.pdl.clear();
-                        return Some(v1.cmp(&v2));
+                        if v1 != v2 {
+                            self.pdl.clear();
+                            return Some(v1.cmp(&v2));
+                        }
                    }
                }
                Some(TermOrderCategory::FloatingPoint) => {
--- a/src/machine/mod.rs
+++ b/src/machine/mod.rs
@@ -1026,6 +1026,24 @@ impl Machine {
        self.machine_st.heap.truncate(target_h);
    }

+    #[inline(always)]
+    fn undefined_procedure(&mut self, name: Atom, arity: usize) -> CallResult {
+        match self.machine_st.flags.unknown {
+            Unknown::Error => {
+                Err(self.machine_st.throw_undefined_error(name, arity))
+            }
+            Unknown::Fail => {
+                self.machine_st.fail = true;
+                Ok(())
+            }
+            Unknown::Warn => {
+                println!("warning: predicate {}/{} is undefined", name.as_str(), arity);
+                self.machine_st.fail = true;
+                Ok(())
+            }
+        }
+    }
+
    #[inline(always)]
    fn try_call(&mut self, name: Atom, arity: usize, idx: IndexPtr) -> CallResult {
        let compiled_tl_index = idx.p() as usize;
@@ -1035,7 +1053,7 @@ impl Machine {
                self.machine_st.fail = true;
            }
            IndexPtrTag::Undefined => {
-                return Err(self.machine_st.throw_undefined_error(name, arity));
+                return self.undefined_procedure(name, arity);
            }
            IndexPtrTag::DynamicIndex => {
                self.machine_st.dynamic_mode = FirstOrNext::First;
@@ -1058,7 +1076,7 @@ impl Machine {
                self.machine_st.fail = true;
            }
            IndexPtrTag::Undefined => {
-                return Err(self.machine_st.throw_undefined_error(name, arity));
+                return self.undefined_procedure(name, arity);
            }
            IndexPtrTag::DynamicIndex => {
                self.machine_st.dynamic_mode = FirstOrNext::First;
@@ -1087,7 +1105,7 @@ impl Machine {
                if let Some(idx) = module.code_dir.get(&(name, arity)).cloned() {
                    self.try_call(name, arity, idx.get())
                } else {
-                    Err(self.machine_st.throw_undefined_error(name, arity))
+                    self.undefined_procedure(name, arity)
                }
            } else {
                let stub = functor_stub(name, arity);
@@ -1106,14 +1124,14 @@ impl Machine {
            if let Some(idx) = self.indices.code_dir.get(&(name, arity)).cloned() {
                self.try_execute(name, arity, idx.get())
            } else {
-                Err(self.machine_st.throw_undefined_error(name, arity))
+                self.undefined_procedure(name, arity)
            }
        } else {
            if let Some(module) = self.indices.modules.get(&module_name) {
                if let Some(idx) = module.code_dir.get(&(name, arity)).cloned() {
                    self.try_execute(name, arity, idx.get())
                } else {
-                    Err(self.machine_st.throw_undefined_error(name, arity))
+                    self.undefined_procedure(name, arity)
                }
            } else {
                let stub = functor_stub(name, arity);
--- a/src/machine/system_calls.rs
+++ b/src/machine/system_calls.rs
@@ -5192,6 +5192,20 @@ impl Machine {
        );
    }

+    #[inline(always)]
+    pub(crate) fn get_unknown(&mut self) {
+        let a1 = self.deref_register(1);
+
+        self.machine_st.unify_atom(
+            match self.machine_st.flags.unknown {
+                Unknown::Error => atom!("error"),
+                Unknown::Fail => atom!("fail"),
+                Unknown::Warn => atom!("warning"),
+            },
+            a1,
+        );
+    }
+
    #[inline(always)]
    pub(crate) fn get_scc_cleaner(&mut self) {
        let dest = self.machine_st.registers[1];
@@ -5534,7 +5548,7 @@ impl Machine {

    #[inline(always)]
    pub(crate) fn set_double_quotes(&mut self) {
-        let atom = cell_as_atom!(self.machine_st.registers[1]);
+        let atom = cell_as_atom!(self.deref_register(1));

        self.machine_st.flags.double_quotes = match atom {
            atom!("atom") => DoubleQuotes::Atom,
@@ -5547,6 +5561,21 @@ impl Machine {
        };
    }

+    #[inline(always)]
+    pub(crate) fn set_unknown(&mut self) {
+        let atom = cell_as_atom!(self.deref_register(1));
+
+        self.machine_st.flags.unknown = match atom {
+            atom!("error") => Unknown::Error,
+            atom!("fail") => Unknown::Fail,
+            atom!("warning") => Unknown::Warn,
+            _ => {
+                self.machine_st.fail = true;
+                return;
+            }
+        };
+    }
+
    #[inline(always)]
    pub(crate) fn inference_level(&mut self) {
        let a1 = self.deref_register(1);
--- a/src/macros.rs
+++ b/src/macros.rs
@@ -625,6 +625,12 @@ macro_rules! compare_term_test {
        $machine_st.pdl.push($e2);
        $machine_st.pdl.push($e1);

-        $machine_st.compare_term_test()
+        $machine_st.compare_term_test(VarComparison::Distinct)
+    }};
+    ($machine_st:expr, $e1:expr, $e2:expr, $var_comparison:expr) => {{
+        $machine_st.pdl.push($e2);
+        $machine_st.pdl.push($e1);
+
+        $machine_st.compare_term_test($var_comparison)
    }};
 }
--- a/src/parser/ast.rs
+++ b/src/parser/ast.rs
@@ -303,12 +303,14 @@ pub type OpDir = IndexMap<(Atom, Fixity), OpDesc, FxBuildHasher>;
 #[derive(Debug, Clone, Copy)]
 pub struct MachineFlags {
    pub double_quotes: DoubleQuotes,
+    pub unknown: Unknown,
 }

 impl Default for MachineFlags {
    fn default() -> Self {
        MachineFlags {
            double_quotes: DoubleQuotes::default(),
+            unknown: Unknown::default(),
        }
    }
 }
@@ -340,6 +342,34 @@ impl Default for DoubleQuotes {
    }
 }

+#[derive(Debug, Clone, Copy)]
+pub enum Unknown {
+    Error,
+    Fail,
+    Warn,
+}
+
+impl Unknown {
+    pub fn is_error(self) -> bool {
+        matches!(self, Unknown::Error)
+    }
+
+    pub fn is_fail(self) -> bool {
+        matches!(self, Unknown::Fail)
+    }
+
+    pub fn is_warn(self) -> bool {
+        matches!(self, Unknown::Warn)
+    }
+}
+
+impl Default for Unknown {
+    #[inline]
+    fn default() -> Self {
+        Unknown::Error
+    }
+}
+
 pub fn default_op_dir() -> OpDir {
    let mut op_dir = OpDir::with_hasher(FxBuildHasher::default());