fix current_predicate/1 (#1761)

diff --git a/build/instructions_template.rs b/build/instructions_template.rs
index e9ba3a381d005f34822b3b8725fda574f8c348b2..bec70e7e3101522146a7a93fbd645e72bad18d9c 100644 (file)
--- a/build/instructions_template.rs
+++ b/build/instructions_template.rs
@@ -306,10 +306,10 @@ enum SystemClauseType {
     GetBValue,
     #[strum_discriminants(strum(props(Arity = "3", Name = "$get_cont_chunk")))]
     GetContinuationChunk,
-    #[strum_discriminants(strum(props(Arity = "4", Name = "$get_next_db_ref")))]
-    GetNextDBRef,
     #[strum_discriminants(strum(props(Arity = "7", Name = "$get_next_op_db_ref")))]
     GetNextOpDBRef,
+    #[strum_discriminants(strum(props(Arity = "2", Name = "$lookup_db_ref")))]
+    LookupDBRef,
     #[strum_discriminants(strum(props(Arity = "1", Name = "$is_partial_string")))]
     IsPartialString,
     #[strum_discriminants(strum(props(Arity = "1", Name = "$halt")))]
@@ -578,6 +578,8 @@ enum SystemClauseType {
     DeleteAllAttributesFromVar,
     #[strum_discriminants(strum(props(Arity = "1", Name = "$unattributed_var")))]
     UnattributedVar,
+    #[strum_discriminants(strum(props(Arity = "3", Name = "$get_db_refs")))]
+    GetDBRefs,
     REPL(REPLCodePtr),
 }
 
@@ -1641,6 +1643,7 @@ fn generate_instruction_preface() -> TokenStream {
                     &Instruction::CallDeleteFromAttributedVarList(_) |
                     &Instruction::CallDeleteAllAttributesFromVar(_) |
                     &Instruction::CallUnattributedVar(_) |
+                    &Instruction::CallGetDBRefs(_) |
                     &Instruction::CallFetchGlobalVar(_) |
                     &Instruction::CallFirstStream(_) |
                     &Instruction::CallFlushOutput(_) |
@@ -1656,8 +1659,8 @@ fn generate_instruction_preface() -> TokenStream {
                     &Instruction::CallGetAttrVarQueueBeyond(_) |
                     &Instruction::CallGetBValue(_) |
                     &Instruction::CallGetContinuationChunk(_) |
-                    &Instruction::CallGetNextDBRef(_) |
                     &Instruction::CallGetNextOpDBRef(_) |
+                    &Instruction::CallLookupDBRef(_) |
                     &Instruction::CallIsPartialString(_) |
                     &Instruction::CallHalt(_) |
                     &Instruction::CallGetLiftedHeapFromOffset(_) |
@@ -1862,6 +1865,7 @@ fn generate_instruction_preface() -> TokenStream {
                     &Instruction::ExecuteDeleteFromAttributedVarList(_) |
                     &Instruction::ExecuteDeleteAllAttributesFromVar(_) |
                     &Instruction::ExecuteUnattributedVar(_) |
+                    &Instruction::ExecuteGetDBRefs(_) |
                     &Instruction::ExecuteFetchGlobalVar(_) |
                     &Instruction::ExecuteFirstStream(_) |
                     &Instruction::ExecuteFlushOutput(_) |
@@ -1877,8 +1881,8 @@ fn generate_instruction_preface() -> TokenStream {
                     &Instruction::ExecuteGetAttrVarQueueBeyond(_) |
                     &Instruction::ExecuteGetBValue(_) |
                     &Instruction::ExecuteGetContinuationChunk(_) |
-                    &Instruction::ExecuteGetNextDBRef(_) |
                     &Instruction::ExecuteGetNextOpDBRef(_) |
+                    &Instruction::ExecuteLookupDBRef(_) |
                     &Instruction::ExecuteIsPartialString(_) |
                     &Instruction::ExecuteHalt(_) |
                     &Instruction::ExecuteGetLiftedHeapFromOffset(_) |

diff --git a/src/lib/builtins.pl b/src/lib/builtins.pl
index 759c60b64e283f8d8329d0aed652819296d6d338..0005d39570a652255e61a25a3776a4e95286ca7f 100644 (file)
--- a/src/lib/builtins.pl
+++ b/src/lib/builtins.pl
@@ -1205,7 +1205,6 @@ module_abolish(Pred, Module) :-
     ;  throw(error(type_error(predicate_indicator, Module:Pred), abolish/1))
     ).
 
-
 :- meta_predicate abolish(:).
 
 %% abolish(Pred).
@@ -1246,13 +1245,6 @@ abolish(Pred) :-
     ;  throw(error(type_error(predicate_indicator, Pred), abolish/1))
     ).
 
-
-'$iterate_db_refs'(Name, Arity, Name/Arity). % :-
-%   '$lookup_db_ref'(Ref, Name, Arity).
-'$iterate_db_refs'(RName, RArity, Name/Arity) :-
-    '$get_next_db_ref'(RName, RArity, RRName, RRArity),
-    '$iterate_db_refs'(RRName, RRArity, Name/Arity).
-
 %% current_predicate(Pred).
 %
 % Pred must satisfy: `Pred = Name/Arity`.
@@ -1260,27 +1252,28 @@ abolish(Pred) :-
 % It can be used to check for existence of a predicate or to enumerate all loaded predicates
 current_predicate(Pred) :-
     (  var(Pred) ->
-       '$get_next_db_ref'(RN, RA, _, _),
-       '$iterate_db_refs'(RN, RA, Pred)
-    ;  Pred \= _/_ ->
-       throw(error(type_error(predicate_indicator, Pred), current_predicate/1))
-    ;  Pred = Name/Arity,
-       (  nonvar(Name), \+ atom(Name)
-       ;  nonvar(Arity), \+ integer(Arity)
-       ;  integer(Arity), Arity < 0
-       ) ->
-       throw(error(type_error(predicate_indicator, Pred), current_predicate/1))
-    ;  '$get_next_db_ref'(RN, RA, _, _),
-       '$iterate_db_refs'(RN, RA, Pred)
+       '$get_db_refs'(_, _, PIs),
+       lists:member(Pred, PIs)
+    ;  Pred = Name/Arity ->
+       (  (  nonvar(Name), \+ atom(Name)
+          ;  nonvar(Arity), \+ integer(Arity)
+          ;  integer(Arity), Arity < 0
+          ) ->
+          throw(error(type_error(predicate_indicator, Pred), current_predicate/1))
+       ;  nonvar(Name),
+          nonvar(Arity) ->
+          '$lookup_db_ref'(Name, Arity)
+       ;  '$get_db_refs'(Name, Arity, PIs),
+          lists:member(Pred, PIs)
+       )
+    ;  throw(error(type_error(predicate_indicator, Pred), current_predicate/1))
     ).
 
-
 '$iterate_op_db_refs'(RPriority, RSpec, ROp, _, RPriority, RSpec, ROp).
 '$iterate_op_db_refs'(RPriority, RSpec, ROp, OssifiedOpDir, Priority, Spec, Op) :-
     '$get_next_op_db_ref'(RPriority, RSpec, ROp, OssifiedOpDir, RRPriority, RRSpec, RROp),
     '$iterate_op_db_refs'(RRPriority, RRSpec, RROp, OssifiedOpDir, Priority, Spec, Op).
 
-
 can_be_op_priority(Priority) :- var(Priority).
 can_be_op_priority(Priority) :- op_priority(Priority).
 

diff --git a/src/machine/dispatch.rs b/src/machine/dispatch.rs
index e366dc81d9703cfbef6939bc402b3b2d249218d8..3067ecb9e3e2fc0f7200155cc5d58409d3087e0b 100644 (file)
--- a/src/machine/dispatch.rs
+++ b/src/machine/dispatch.rs
@@ -3720,12 +3720,12 @@ impl Machine {
                     self.get_continuation_chunk();
                     step_or_fail!(self, self.machine_st.p = self.machine_st.cp);
                 }
-                &Instruction::CallGetNextDBRef(_) => {
-                    self.get_next_db_ref();
+                &Instruction::CallLookupDBRef(_) => {
+                    self.lookup_db_ref();
                     step_or_fail!(self, self.machine_st.p += 1);
                 }
-                &Instruction::ExecuteGetNextDBRef(_) => {
-                    self.get_next_db_ref();
+                &Instruction::ExecuteLookupDBRef(_) => {
+                    self.lookup_db_ref();
                     step_or_fail!(self, self.machine_st.p = self.machine_st.cp);
                 }
                 &Instruction::CallGetNextOpDBRef(_) => {
@@ -5255,6 +5255,14 @@ impl Machine {
                     self.machine_st.unattributed_var();
                     step_or_fail!(self, self.machine_st.p = self.machine_st.cp);
                 }
+                &Instruction::CallGetDBRefs(_) => {
+                    self.get_db_refs();
+                    step_or_fail!(self, self.machine_st.p += 1);
+                }
+                &Instruction::ExecuteGetDBRefs(_) => {
+                    self.get_db_refs();
+                    step_or_fail!(self, self.machine_st.p = self.machine_st.cp);
+                }
             }
         }
 

diff --git a/src/machine/system_calls.rs b/src/machine/system_calls.rs
index 674fc54fda54991375312863933a5922ffb320cd..e457a611cafeb0cbe1e1b2046bf649556354cfde 100644 (file)
--- a/src/machine/system_calls.rs
+++ b/src/machine/system_calls.rs
@@ -3660,44 +3660,74 @@ impl Machine {
     }
 
     #[inline(always)]
-    pub(crate) fn get_next_db_ref(&mut self) {
-        let a1 = self.deref_register(1);
+    pub(crate) fn lookup_db_ref(&mut self) {
+        let name = cell_as_atom!(self.deref_register(1));
+        let arity = cell_as_fixnum!(self.deref_register(2)).get_num() as usize;
+
+        if self.indices.code_dir.get(&(name, arity)).is_none() {
+            self.machine_st.fail = true;
+        }
+    }
+
+    #[inline(always)]
+    pub(crate) fn get_db_refs(&mut self) {
+        let name_match: fn(Atom, Atom) -> bool;
+        let arity_match: fn(usize, usize) -> bool;
+
+        let atom = self.deref_register(1);
 
-        if let Some(name_var) = a1.as_var() {
-            let mut iter = self.indices.code_dir.iter();
+        let pred_atom = if atom.is_var() {
+            name_match = |_, _| true;
+            atom!("")
+        } else {
+            name_match = |atom_1, atom_2| atom_1 == atom_2;
+            cell_as_atom!(atom)
+        };
 
-            while let Some(((name, arity), _)) = iter.next() {
-                let arity_var = self.machine_st.deref(self.machine_st.registers[2])
-                    .as_var().unwrap();
+        let arity = self.deref_register(2);
+
+        let pred_arity = if arity.is_var() {
+            arity_match = |_, _| true;
+            0
+        } else {
+            arity_match = |arity_1, arity_2| arity_1 == arity_2;
 
-                self.machine_st.bind(name_var, atom_as_cell!(name));
-                self.machine_st.bind(arity_var, fixnum_as_cell!(Fixnum::build_with(*arity as i64)));
+            let arity = match Number::try_from(arity) {
+                Ok(Number::Fixnum(n)) => Some(n.get_num() as usize),
+                Ok(Number::Integer(n)) => n.to_usize(),
+                _ => None,
+            };
 
+            if let Some(arity) = arity {
+                arity
+            } else {
+                self.machine_st.fail = true;
                 return;
             }
+        };
 
-            self.machine_st.fail = true;
-        } else if a1.get_tag() == HeapCellValueTag::Atom {
-            let name = cell_as_atom!(a1);
-            let arity = cell_as_fixnum!(self.deref_register(2)).get_num() as usize;
-
-            match self.machine_st.get_next_db_ref(&self.indices, &DBRef::NamedPred(name, arity)) {
-                Some(DBRef::NamedPred(name, arity)) => {
-                    let atom_var = self.machine_st.deref(self.machine_st.registers[3])
-                        .as_var().unwrap();
+        let h = self.machine_st.heap.len();
+        let mut num_functors = 0;
 
-                    let arity_var = self.machine_st.deref(self.machine_st.registers[4])
-                        .as_var().unwrap();
+        for (name, arity) in self.indices.code_dir.keys() {
+            if name_match(pred_atom, *name) && arity_match(pred_arity, *arity) {
+                self.machine_st.heap.extend(
+                    functor!(atom!("/"), [cell(atom_as_cell!(name)), fixnum(*arity)]),
+                );
 
-                    self.machine_st.bind(atom_var, atom_as_cell!(name));
-                    self.machine_st.bind(arity_var, fixnum_as_cell!(Fixnum::build_with(arity as i64)));
-                }
-                Some(DBRef::Op(..)) | None => {
-                    self.machine_st.fail = true;
-                }
+                num_functors += 1;
             }
+        }
+
+        if num_functors > 0 {
+            let h = iter_to_heap_list(
+                &mut self.machine_st.heap,
+                (0 .. num_functors).map(|i| str_loc_as_cell!(h + 3 * i)),
+            );
+
+            unify!(self.machine_st, heap_loc_as_cell!(h), self.machine_st.registers[3]);
         } else {
-            self.machine_st.fail = true;
+            unify!(self.machine_st, empty_list_as_cell!(), self.machine_st.registers[3]);
         }
     }