#[derive(Copy, Clone, PartialEq)]
pub enum SystemClauseType {
AbolishClause,
+ AbolishModuleClause,
AssertDynamicPredicateToBack,
AssertDynamicPredicateToFront,
+ ModuleAssertDynamicPredicateToFront,
+ ModuleAssertDynamicPredicateToBack,
CheckCutPoint,
CopyToLiftedHeap,
DeleteAttribute,
GetBValue,
GetClause,
GetCurrentPredicateList,
+ GetModuleClause,
GetLiftedHeapFromOffset,
GetLiftedHeapFromOffsetDiff,
GetSCCCleaner,
InstallInferenceCounter,
LiftedHeapLength,
ModuleOf,
+ ModuleRetractClause,
NoSuchPredicate,
RedoAttrVarBindings,
RemoveCallPolicyCheck,
pub fn name(&self) -> ClauseName {
match self {
&SystemClauseType::AbolishClause => clause_name!("$abolish_clause"),
- &SystemClauseType::AssertDynamicPredicateToBack => clause_name!("$asserta"),
- &SystemClauseType::AssertDynamicPredicateToFront => clause_name!("$assertz"),
+ &SystemClauseType::AbolishModuleClause => clause_name!("$abolish_module_clause"),
+ &SystemClauseType::AssertDynamicPredicateToBack => clause_name!("$assertz"),
+ &SystemClauseType::AssertDynamicPredicateToFront => clause_name!("$asserta"),
+ &SystemClauseType::ModuleAssertDynamicPredicateToFront => clause_name!("$module_asserta"),
+ &SystemClauseType::ModuleAssertDynamicPredicateToBack => clause_name!("$module_assertz"),
&SystemClauseType::CheckCutPoint => clause_name!("$check_cp"),
&SystemClauseType::CopyToLiftedHeap => clause_name!("$copy_to_lh"),
&SystemClauseType::DeleteAttribute => clause_name!("$del_attr_non_head"),
&SystemClauseType::GetBValue => clause_name!("$get_b_value"),
&SystemClauseType::GetClause => clause_name!("$get_clause"),
&SystemClauseType::GetDoubleQuotes => clause_name!("$get_double_quotes"),
+ &SystemClauseType::GetModuleClause => clause_name!("$get_module_clause"),
&SystemClauseType::GetSCCCleaner => clause_name!("$get_scc_cleaner"),
&SystemClauseType::HeadIsDynamic => clause_name!("$head_is_dynamic"),
&SystemClauseType::InstallSCCCleaner => clause_name!("$install_scc_cleaner"),
&SystemClauseType::GetCutPoint => clause_name!("$get_cp"),
&SystemClauseType::GetCurrentBlock => clause_name!("$get_current_block"),
&SystemClauseType::InstallNewBlock => clause_name!("$install_new_block"),
+ &SystemClauseType::ModuleRetractClause => clause_name!("$module_retract_clause"),
&SystemClauseType::RetractClause => clause_name!("$retract_clause"),
&SystemClauseType::ResetBlock => clause_name!("$reset_block"),
&SystemClauseType::ReturnFromAttributeGoals => clause_name!("$return_from_attribute_goals"),
&SystemClauseType::WriteTerm => clause_name!("$write_term"),
}
}
-
+
pub fn from(name: &str, arity: usize) -> Option<SystemClauseType> {
match (name, arity) {
("$abolish_clause", 2) => Some(SystemClauseType::AbolishClause),
+ ("$abolish_module_clause", 3) => Some(SystemClauseType::AbolishModuleClause),
+ ("$module_asserta", 5) => Some(SystemClauseType::ModuleAssertDynamicPredicateToFront),
+ ("$module_assertz", 5) => Some(SystemClauseType::ModuleAssertDynamicPredicateToBack),
("$asserta", 4) => Some(SystemClauseType::AssertDynamicPredicateToFront),
("$assertz", 4) => Some(SystemClauseType::AssertDynamicPredicateToBack),
("$check_cp", 1) => Some(SystemClauseType::CheckCutPoint),
("$get_attr_list", 2) => Some(SystemClauseType::GetAttributedVariableList),
("$get_b_value", 1) => Some(SystemClauseType::GetBValue),
("$get_clause", 2) => Some(SystemClauseType::GetClause),
+ ("$get_module_clause", 3) => Some(SystemClauseType::GetModuleClause),
("$get_current_predicate_list", 1) => Some(SystemClauseType::GetCurrentPredicateList),
("$get_lh_from_offset", 2) => Some(SystemClauseType::GetLiftedHeapFromOffset),
("$get_lh_from_offset_diff", 3) => Some(SystemClauseType::GetLiftedHeapFromOffsetDiff),
("$install_inference_counter", 3) => Some(SystemClauseType::InstallInferenceCounter),
("$lh_length", 1) => Some(SystemClauseType::LiftedHeapLength),
("$module_of", 2) => Some(SystemClauseType::ModuleOf),
+ ("$module_retract_clause", 5) => Some(SystemClauseType::ModuleRetractClause),
("$no_such_predicate", 1) => Some(SystemClauseType::NoSuchPredicate),
("$redo_attr_var_bindings", 0) => Some(SystemClauseType::RedoAttrVarBindings),
("$remove_call_policy_check", 1) => Some(SystemClauseType::RemoveCallPolicyCheck),
'$clause_body_is_valid'(B) :-
( var(B) -> true
- ; functor(B, Name, _) -> ( atom(Name), Name \= '.' -> true
+ ; functor(B, Name, _) -> ( atom(Name), Name \== '.' -> true
; throw(error(type_error(callable, B), clause/2))
)
; throw(error(type_error(callable, B), clause/2))
).
+'$module_clause'(H, B, Module) :-
+ ( var(H) -> throw(error(instantiation_error, clause/2))
+ ; functor(H, Name, Arity) -> ( Name == '.' -> throw(error(type_error(callable, H), clause/2))
+ ; '$head_is_dynamic'(H) -> '$clause_body_is_valid'(B),
+ '$get_module_clause'(H, B, Module)
+ ; throw(error(permission_error(access, private_procedure, Name/Arity),
+ clause/2))
+ )
+ ; throw(error(type_error(callable, H), clause/2))
+ ).
+
clause(H, B) :-
( var(H) -> throw(error(instantiation_error, clause/2))
; functor(H, Name, Arity) -> ( Name == '.' -> throw(error(type_error(callable, H), clause/2))
+ ; Name == (:), Arity =:= 2 ->
+ arg(1, H, Module),
+ arg(2, H, F),
+ '$module_clause'(F, B, Module)
%% '$no_such_predicate' fails if H is not callable.
; '$no_such_predicate'(H) -> '$fail'
; '$head_is_dynamic'(H) -> '$clause_body_is_valid'(B),
; throw(error(type_error(callable, H), clause/2))
).
+call_module_asserta(Head, Body, Name, Arity, Module) :-
+ '$clause_body_is_valid'(Body),
+ functor(VarHead, Name, Arity),
+ findall((VarHead :- VarBody), clause(Module:VarHead, VarBody), Clauses),
+ '$module_asserta'((Head :- Body), Clauses, Name, Arity, Module).
+
call_asserta(Head, Body, Name, Arity) :-
'$clause_body_is_valid'(Body),
functor(VarHead, Name, Arity),
findall((VarHead :- VarBody), clause(VarHead, VarBody), Clauses),
'$asserta'((Head :- Body), Clauses, Name, Arity).
+module_asserta_clause(Head, Body, Module) :-
+ ( var(Head) -> throw(error(instantiation_error, asserta/1))
+ ; functor(Head, Name, Arity), atom(Name), Name \== '.' ->
+ ( '$head_is_dynamic'(Head) -> call_module_asserta(Head, Body, Name, Arity, Module)
+ ; throw(error(permission_error(modify, static_procedure, Name/Arity), asserta/1))
+ )
+ ; throw(error(type_error(callable, Head), asserta/1))
+ ).
+
asserta_clause(Head, Body) :-
( var(Head) -> throw(error(instantiation_error, asserta/1))
; functor(Head, Name, Arity), atom(Name), Name \== '.' ->
- ( '$no_such_predicate'(Head) -> call_asserta(Head, Body, Name, Arity)
+ ( Name == (:), Arity =:= 2 ->
+ arg(1, Head, Module),
+ arg(2, Head, F),
+ module_asserta_clause(F, Body, Module)
+ ; '$no_such_predicate'(Head) -> call_asserta(Head, Body, Name, Arity)
; '$head_is_dynamic'(Head) -> call_asserta(Head, Body, Name, Arity)
; throw(error(permission_error(modify, static_procedure, Name/Arity), asserta/1))
)
; Clause = (Head :- Body) -> asserta_clause(Head, Body)
).
+call_module_assertz(Head, Body, Name, Arity, Module) :-
+ '$clause_body_is_valid'(Body),
+ functor(VarHead, Name, Arity),
+ findall((VarHead :- VarBody), clause(Module:VarHead, VarBody), Clauses),
+ '$module_assertz'((Head :- Body), Clauses, Name, Arity, Module).
+
call_assertz(Head, Body, Name, Arity) :-
'$clause_body_is_valid'(Body),
functor(VarHead, Name, Arity),
findall((VarHead :- VarBody), clause(VarHead, VarBody), Clauses),
'$assertz'((Head :- Body), Clauses, Name, Arity).
+module_assertz_clause(Head, Body, Module) :-
+ ( var(Head) -> throw(error(instantiation_error, assertz/1))
+ ; functor(Head, Name, Arity), atom(Name), Name \== '.' ->
+ ( '$head_is_dynamic'(Head) -> call_module_assertz(Head, Body, Name, Arity, Module)
+ ; throw(error(permission_error(modify, static_procedure, Name/Arity), assertz/1))
+ )
+ ; throw(error(type_error(callable, Head), assertz/1))
+ ).
+
assertz_clause(Head, Body) :-
( var(Head) -> throw(error(instantiation_error, assertz/1))
; functor(Head, Name, Arity), atom(Name), Name \== '.' ->
- ( '$no_such_predicate'(Head) -> call_assertz(Head, Body, Name, Arity)
+ ( Name == (:), Arity =:= 2 ->
+ arg(1, Head, Module),
+ arg(2, Head, F),
+ module_assertz_clause(F, Body, Module)
+ ; '$no_such_predicate'(Head) -> call_assertz(Head, Body, Name, Arity)
; '$head_is_dynamic'(Head) -> call_assertz(Head, Body, Name, Arity)
; throw(error(permission_error(modify, static_procedure, Name/Arity), assertz/1))
)
findall((Head :- Body), clause(Head, Body), Clauses),
retract_clauses(Clauses, Head, Body, Name, Arity).
+module_retract_clauses([Clause|Clauses0], Head, Body, Name, Arity, Module) :-
+ functor(VarHead, Name, Arity),
+ findall((VarHead :- VarBody), clause(Module:VarHead, VarBody), Clauses1),
+ first_match_index(Clauses1, (Head :- Body), 0, N),
+ ( Clauses0 == [] -> !
+ ; true
+ ),
+ '$module_retract_clause'(Name, Arity, N, Clauses1, Module).
+module_retract_clauses([_|Clauses0], Head, Body, Name, Arity, Module) :-
+ module_retract_clauses(Clauses0, Head, Body, Name, Arity, Module).
+
+call_module_retract(Head, Body, Name, Arity, Module) :-
+ findall((Head :- Body), clause(Module:Head, Body), Clauses),
+ module_retract_clauses(Clauses, Head, Body, Name, Arity, Module).
+
+retract_module_clause(Head, Body, Module) :-
+ ( var(Head) -> throw(error(instantiation_error, retract/1))
+ ; functor(Head, Name, Arity), atom(Name), Name \== '.' ->
+ ( '$head_is_dynamic'(Head) -> call_module_retract(Head, Body, Name, Arity, Module)
+ ; throw(error(permission_error(modify, static_procedure, Name/Arity), retract/1))
+ )
+ ; throw(error(type_error(callable, Head), retract/1))
+ ).
+
retract_clause(Head, Body) :-
( var(Head) -> throw(error(instantiation_error, retract/1))
; functor(Head, Name, Arity), atom(Name), Name \== '.' ->
- ( '$head_is_dynamic'(Head) -> call_retract(Head, Body, Name, Arity)
+ ( Name == (:), Arity =:= 2 ->
+ arg(1, Head, Module),
+ arg(2, Head, F),
+ retract_module_clause(F, Body, Module)
+ ; '$head_is_dynamic'(Head) -> call_retract(Head, Body, Name, Arity)
; '$no_such_predicate'(Head) -> '$fail'
; throw(error(permission_error(modify, static_procedure, Name/Arity), retract/1))
)
; Clause = (Head :- Body) -> retract_clause(Head, Body)
).
+module_abolish(Pred, Module) :-
+ ( var(Pred) -> throw(error(instantiation_error), abolish/1)
+ ; Pred = Name/Arity ->
+ ( var(Name) -> throw(error(instantiation_error, abolish/1))
+ ; integer(Arity) ->
+ ( \+ atom(Name) -> throw(error(type_error(atom, Name), abolish/1))
+ ; Arity < 0 -> throw(domain_error(not_less_than_zero, Arity), abolish/1)
+ ; max_arity(N), Arity > N -> throw(representation_error(max_arity), abolish/1)
+ ; functor(Head, Name, Arity) ->
+ ( '$head_is_dynamic'(Head) -> '$abolish_module_clause'(Name, Arity, Module)
+ ; throw(error(permission_error(modify, static_procedure, Pred), abolish/1))
+ )
+ )
+ ; throw(error(type_error(integer, Arity), abolish/1))
+ )
+ ; throw(error(type_error(predicate_indicator, Module:Pred), abolish/1))
+ ).
+
abolish(Pred) :-
( var(Pred) -> throw(error(instantiation_error), abolish/1)
+ ; Pred = Module:InnerPred -> module_abolish(InnerPred, Module)
; Pred = Name/Arity ->
( var(Name) -> throw(error(instantiation_error, abolish/1))
; var(Arity) -> throw(error(instantiation_error, abolish/1))
; Arity < 0 -> throw(domain_error(not_less_than_zero, Arity), abolish/1)
; max_arity(N), Arity > N -> throw(representation_error(max_arity), abolish/1)
; functor(Head, Name, Arity) ->
- ( '$no_such_predicate'(Head) -> '$abolish_clause'(Name, Arity)
+ ( '$no_such_predicate'(Head) -> true
; '$head_is_dynamic'(Head) -> '$abolish_clause'(Name, Arity)
; throw(error(permission_error(modify, static_procedure, Pred), abolish/1))
)
_ => self.indices.atom_tbl()
}
}
-
+
fn compile_into_machine<R: Read>(&mut self, src: R, name: ClauseName) -> EvalSession
{
match name.owning_module().as_str() {
self.indices.remove_code_index((name, arity));
}
+ fn abolish_dynamic_clause_in_module(&mut self, name: RegType, arity: RegType, module: RegType)
+ {
+ let (name, arity) = self.get_predicate_key(name, arity);
+ let module_addr = self.machine_st[module].clone();
+
+ let module_name = match self.machine_st.store(self.machine_st.deref(module_addr)) {
+ Addr::Con(Constant::Atom(module, _)) =>
+ match self.indices.modules.get_mut(&module) {
+ Some(ref mut module) => {
+ module.code_dir.remove(&(name.clone(), arity));
+ module.module_decl.name.clone()
+ },
+ _ => {
+ self.machine_st.fail = true;
+ return;
+ }
+ },
+ _ => unreachable!()
+ };
+
+ if let Some(idx) = self.indices.code_dir.get(&(name.clone(), arity)) {
+ if idx.module_name() == module_name {
+ set_code_index!(idx, IndexPtr::Undefined, clause_name!("user"));
+ }
+ }
+
+ self.indices.remove_code_index((name, arity));
+ }
+
fn handle_eval_result_from_dynamic_compile(&mut self, pred_str: String, name: ClauseName,
src: ClauseName)
{
}
}
- fn recompile_dynamic_predicate(&mut self, place: DynamicAssertPlace)
+ fn recompile_dynamic_predicate_impl(&mut self, place: DynamicAssertPlace, name: ClauseName,
+ arity: usize)
{
- let (name, arity) = self.get_predicate_key(temp_v!(3), temp_v!(4));
-
let stub = MachineError::functor_stub(place.predicate_name(), 1);
let pred_str = match self.machine_st.try_from_list(temp_v!(2), stub) {
Ok(addrs) => {
self.handle_eval_result_from_dynamic_compile(pred_str, name, place.predicate_name());
}
- fn retract_from_dynamic_predicate(&mut self)
+ fn set_module_atom_tbl(&mut self, module_addr: Addr, name: &mut ClauseName) -> bool
+ {
+ let atom_tbl = match self.machine_st.store(self.machine_st.deref(module_addr)) {
+ Addr::Con(Constant::Atom(module, _)) =>
+ match self.indices.modules.get(&module) {
+ Some(ref module) => module.atom_tbl.clone(),
+ None => {
+ self.machine_st.fail = true;
+ return false;
+ }
+ },
+ _ => unreachable!()
+ };
+
+ if let &mut ClauseName::User(ref mut rc) = name {
+ rc.table = atom_tbl;
+ }
+
+ true
+ }
+
+ fn recompile_dynamic_predicate_in_module(&mut self, place: DynamicAssertPlace)
+ {
+ let (mut name, arity) = self.get_predicate_key(temp_v!(3), temp_v!(4));
+ let module_addr = self.machine_st[temp_v!(5)].clone();
+
+ if self.set_module_atom_tbl(module_addr, &mut name) {
+ self.recompile_dynamic_predicate_impl(place, name, arity);
+ }
+ }
+
+ fn recompile_dynamic_predicate(&mut self, place: DynamicAssertPlace)
+ {
+ let (name, arity) = self.get_predicate_key(temp_v!(3), temp_v!(4));
+ self.recompile_dynamic_predicate_impl(place, name, arity);
+ }
+
+ fn retract_from_dynamic_predicate_in_module(&mut self)
{
let index = self.machine_st[temp_v!(3)].clone();
let index = match self.machine_st.store(self.machine_st.deref(index)) {
_ => unreachable!()
};
- let stub = MachineError::functor_stub(clause_name!("retract"), 1);
+ let (mut name, arity) = self.get_predicate_key(temp_v!(1), temp_v!(2));
+ let module_addr = self.machine_st[temp_v!(5)].clone();
+
+ if self.set_module_atom_tbl(module_addr, &mut name) {
+ self.retract_from_dynamic_predicate_impl(name, arity, index);
+ }
+ }
+
+ fn retract_from_dynamic_predicate(&mut self)
+ {
+ let index = self.machine_st[temp_v!(3)].clone();
+ let index = match self.machine_st.store(self.machine_st.deref(index)) {
+ Addr::Con(Constant::Number(Number::Integer(n))) => n.to_usize().unwrap(),
+ _ => unreachable!()
+ };
+
let (name, arity) = self.get_predicate_key(temp_v!(1), temp_v!(2));
+ self.retract_from_dynamic_predicate_impl(name, arity, index);
+ }
+
+ fn retract_from_dynamic_predicate_impl(&mut self, name: ClauseName, arity: usize, index: usize)
+ {
+ let stub = MachineError::functor_stub(clause_name!("retract"), 1);
let pred_str = match self.machine_st.try_from_list(temp_v!(4), stub) {
Ok(addrs) => {
let mut addrs = VecDeque::from(addrs);
self.abolish_dynamic_clause(temp_v!(1), temp_v!(2)),
DynamicTransactionType::Assert(place) =>
self.recompile_dynamic_predicate(place),
+ DynamicTransactionType::ModuleAbolish =>
+ self.abolish_dynamic_clause_in_module(temp_v!(1), temp_v!(2), temp_v!(3)),
+ DynamicTransactionType::ModuleAssert(place) =>
+ self.recompile_dynamic_predicate_in_module(place),
+ DynamicTransactionType::ModuleRetract =>
+ self.retract_from_dynamic_predicate_in_module(),
DynamicTransactionType::Retract =>
self.retract_from_dynamic_predicate()
}
projects / scryer-prolog.git / commitdiff