From c5a3ec3ba8afb3504bf0a955f6e5078667d4ba6d Mon Sep 17 00:00:00 2001 From: Mark Date: Mon, 24 Apr 2023 23:23:19 -0600 Subject: [PATCH] fix current_predicate/1 (#1761) --- build/instructions_template.rs | 12 +++-- src/lib/builtins.pl | 37 ++++++--------- src/machine/dispatch.rs | 16 +++++-- src/machine/system_calls.rs | 84 +++++++++++++++++++++++----------- 4 files changed, 92 insertions(+), 57 deletions(-) diff --git a/build/instructions_template.rs b/build/instructions_template.rs index e9ba3a38..bec70e7e 100644 --- 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 759c60b6..0005d395 100644 --- 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 e366dc81..3067ecb9 100644 --- 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 674fc54f..e457a611 100644 --- 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]); } } -- 2.54.0