%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Logtalk - Open source object-oriented logic programming language % Release 2.34.1 % % Copyright (c) 1998-2008 Paulo Moura. All Rights Reserved. % Logtalk is free software. You can redistribute it and/or modify % it under the terms of the "Artistic License 2.0" as published by % The Perl Foundation. Consult the "LICENSE.txt" file for details. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % operator declarations % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % message sending operators :- op(600, xfy, ::). % send to object :- op(600, fy, ::). % send to self :- op(600, fy, ^^). % "super" call (calls an overriden, inherited method definition) % mode operators :- op(200, fy, +). % input argument (instantiated) :- op(200, fy, ?). % input/output argument :- op(200, fy, @). % input argument (not modified by the call) :- op(200, fy, -). % output argument (not instantiated) % bitwise left-shift operator (used for unit test context-switching) :- op(400, yfx, <<). % some Prolog compilers don't declare this operator % imported category predicate call operator :- op(600, fy, :). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % runtime directives (bookkeeping tables) % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % tables of defined events and monitors :- dynamic('$lgt_before_'/5). % '$lgt_before_'(Obj, Msg, Sender, Monitor, Call) :- dynamic('$lgt_after_'/5). % '$lgt_after_'(Obj, Msg, Sender, Monitor, Call) % tables of loaded entities, entity properties, and entity relations :- multifile('$lgt_current_protocol_'/5). % '$lgt_current_protocol_'(Ptc, Prefix, Dcl, Rnm, Type) :- dynamic('$lgt_current_protocol_'/5). :- multifile('$lgt_current_category_'/6). % '$lgt_current_category_'(Ctg, Prefix, Dcl, Def, Rnm, Type) :- dynamic('$lgt_current_category_'/6). :- multifile('$lgt_current_object_'/11). % '$lgt_current_object_'(Obj, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Rnm, Type) :- dynamic('$lgt_current_object_'/11). :- multifile('$lgt_entity_property_'/2). % '$lgt_entity_property_'(Entity, Property) :- dynamic('$lgt_entity_property_'/2). :- multifile('$lgt_implements_protocol_'/3). % '$lgt_implements_protocol_'(ObjOrCtg, Ptc, Scope) :- dynamic('$lgt_implements_protocol_'/3). :- multifile('$lgt_imports_category_'/3). % '$lgt_imports_category_'(Obj, Ctg, Scope) :- dynamic('$lgt_imports_category_'/3). :- multifile('$lgt_instantiates_class_'/3). % '$lgt_instantiates_class_'(Instance, Class, Scope) :- dynamic('$lgt_instantiates_class_'/3). :- multifile('$lgt_specializes_class_'/3). % '$lgt_specializes_class_'(Class, Superclass, Scope) :- dynamic('$lgt_specializes_class_'/3). :- multifile('$lgt_extends_category_'/3). % '$lgt_extends_category_'(Ctg1, Ctg2, Scope) :- dynamic('$lgt_extends_category_'/3). :- multifile('$lgt_extends_object_'/3). % '$lgt_extends_object_'(Prototype, Parent, Scope) :- dynamic('$lgt_extends_object_'/3). :- multifile('$lgt_extends_protocol_'/3). % '$lgt_extends_protocol_'(Ptc1, Ptc2, Scope) :- dynamic('$lgt_extends_protocol_'/3). :- multifile('$lgt_complemented_object_'/5). % '$lgt_complemented_object_'(Obj, Ctg, Dcl, Def, Rnm) :- dynamic('$lgt_complemented_object_'/5). % table of loaded files :- dynamic('$lgt_loaded_file_'/2). % '$lgt_loaded_file_'(File, Directory) % debugger status and tables :- multifile('$lgt_debugging_'/1). % '$lgt_debugging_'(Entity) :- dynamic('$lgt_debugging_'/1). :- dynamic('$lgt_dbg_debugging_'/0). % '$lgt_dbg_debugging_' :- dynamic('$lgt_dbg_tracing_'/0). % '$lgt_dbg_tracing_' :- dynamic('$lgt_dbg_skipping_'/0). % '$lgt_dbg_skipping_' :- dynamic('$lgt_dbg_spying_'/2). % '$lgt_dbg_spying_'(Functor, Arity) :- dynamic('$lgt_dbg_spying_'/4). % '$lgt_dbg_spying_'(Sender, This, Self, Goal) :- dynamic('$lgt_dbg_leashing_'/1). % '$lgt_dbg_leashing_'(Port) :- dynamic('$lgt_dbg_invocation_number_'/1). % '$lgt_dbg_invocation_number_'(N) % runtime flags :- dynamic('$lgt_current_flag_'/2). % '$lgt_current_flag_'(Option, Value) % static binding caches :- dynamic('$lgt_static_binding_entity_'/1). % '$lgt_static_binding_entity_'(Entity) :- dynamic('$lgt_obj_static_binding_cache_'/4). % '$lgt_obj_static_binding_cache_'(Obj, Pred, Sender, Call) :- dynamic('$lgt_ctg_static_binding_cache_'/6). % '$lgt_ctg_static_binding_cache_'(Ctg, Pred, Sender, This, Self, Call) % lookup caches for messages to an object, messages to self, and super calls :- dynamic('$lgt_obj_lookup_cache_'/4). % '$lgt_obj_lookup_cache_'(Obj, Pred, Sender, Call) :- dynamic('$lgt_self_lookup_cache_'/4). % '$lgt_self_lookup_cache_'(Obj, Pred, Sender, Call) :- dynamic('$lgt_super_lookup_cache_'/5). % '$lgt_super_lookup_cache_'(Self, Pred, This, Sender, Call) :- dynamic('$lgt_super_lookup_cache_'/6). % '$lgt_super_lookup_cache_'(Ctg, Pred, Sender, This, Self, Call) % lookup cache for asserting and retracting dynamic facts :- dynamic('$lgt_db_lookup_cache_'/5). % '$lgt_db_lookup_cache_'(Obj, Pred, Sender, Call, UpdateGoal) % table of library paths :- multifile(logtalk_library_path/2). % logtalk_library_path(Library, Path) :- dynamic(logtalk_library_path/2). % compiler hook term and goal expansion: :- dynamic('$lgt_hook_term_expansion_'/2). % '$lgt_hook_term_expansion_'(Term, ExpandedTerm) :- dynamic('$lgt_hook_goal_expansion_'/2). % '$lgt_hook_goal_expansion_'(Term, ExpandedTerm) % multi-threading tags :- dynamic('$lgt_threaded_tag_counter'/1). % '$lgt_threaded_tag_counter'(Tag) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % pre-processor directives (used for source file compilation) % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- dynamic('$lgt_pp_compiler_flag_'/2). % '$lgt_pp_compiler_flag_'(Option, Value) :- dynamic('$lgt_pp_dcl_'/1). % '$lgt_pp_dcl_'(Clause) :- dynamic('$lgt_pp_ddcl_'/1). % '$lgt_pp_ddcl_'(Clause) :- dynamic('$lgt_pp_def_'/1). % '$lgt_pp_def_'(Clause) :- dynamic('$lgt_pp_fdef_'/1). % '$lgt_pp_fdef_'(Clause) :- dynamic('$lgt_pp_ddef_'/1). % '$lgt_pp_ddef_'(Clause) :- dynamic('$lgt_pp_fddef_'/1). % '$lgt_pp_fddef_'(Clause) :- dynamic('$lgt_pp_super_'/1). % '$lgt_pp_super_'(Clause) :- dynamic('$lgt_pp_synchronized_'/2). % '$lgt_pp_synchronized_'(Pred, Mutex) :- dynamic('$lgt_pp_pred_mutex_count_'/1). % '$lgt_pp_pred_mutex_count_'(Count) :- dynamic('$lgt_pp_dynamic_'/2). % '$lgt_pp_dynamic_'(Functor, Arity) :- dynamic('$lgt_pp_discontiguous_'/2). % '$lgt_pp_discontiguous_'(Functor, Arity) :- dynamic('$lgt_pp_mode_'/2). % '$lgt_pp_mode_'(Mode, Determinism) :- dynamic('$lgt_pp_public_'/2). % '$lgt_pp_public_'(Functor, Arity) :- dynamic('$lgt_pp_protected_'/2). % '$lgt_pp_protected_'(Functor, Arity) :- dynamic('$lgt_pp_private_'/2). % '$lgt_pp_private_'(Functor, Arity) :- dynamic('$lgt_pp_meta_predicate_'/1). % '$lgt_pp_meta_predicate_'(Pred) :- dynamic('$lgt_pp_alias_'/3). % '$lgt_pp_alias_'(Entity, Pred, Alias) :- dynamic('$lgt_pp_non_terminal_'/3). % '$lgt_pp_non_terminal_'(Functor, Args, Arity) :- dynamic('$lgt_pp_object_'/11). % '$lgt_pp_object_'(Obj, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Rnm, Type) :- dynamic('$lgt_pp_category_'/6). % '$lgt_pp_category_'(Ctg, Prefix, Dcl, Def, Rnm, Type) :- dynamic('$lgt_pp_protocol_'/5). % '$lgt_pp_protocol_'(Ptc, Prefix, Dcl, Rnm, Type) :- dynamic('$lgt_pp_module_'/1). % '$lgt_pp_module_'(Module) :- dynamic('$lgt_pp_uses_'/1). % '$lgt_pp_uses_'(Obj) :- dynamic('$lgt_pp_uses_'/3). % '$lgt_pp_uses_'(Obj, Predicate, Alias) :- dynamic('$lgt_pp_use_module_'/3). % '$lgt_pp_use_module_'(Module, Predicate, Alias) :- dynamic('$lgt_pp_calls_'/1). % '$lgt_pp_calls_'(Entity) :- dynamic('$lgt_pp_info_'/1). % '$lgt_pp_info_'(List) :- dynamic('$lgt_pp_info_'/2). % '$lgt_pp_info_'(Functor/Arity, List) or '$lgt_pp_info_'(Functor//Args, List) :- dynamic('$lgt_pp_implemented_protocol_'/4). % '$lgt_pp_implemented_protocol_'(Ptc, Prefix, Dcl, Scope) :- dynamic('$lgt_pp_imported_category_'/5). % '$lgt_pp_imported_category_'(Ctg, Prefix, Dcl, Def, Scope) :- dynamic('$lgt_pp_extended_object_'/10). % '$lgt_pp_extended_object_'(Parent, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Scope) :- dynamic('$lgt_pp_instantiated_class_'/10). % '$lgt_pp_instantiated_class_'(Class, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Scope) :- dynamic('$lgt_pp_specialized_class_'/10). % '$lgt_pp_specialized_class_'(Superclass, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Scope) :- dynamic('$lgt_pp_extended_protocol_'/4). % '$lgt_pp_extended_protocol_'(Ptc, Prefix, Dcl, Scope) :- dynamic('$lgt_pp_extended_category_'/5). % '$lgt_pp_extended_category_'(Ctg, Prefix, Dcl, Def, Scope) :- dynamic('$lgt_pp_complemented_object_'/1). % '$lgt_pp_complemented_object_'(Obj) :- dynamic('$lgt_pp_file_init_'/1). % '$lgt_pp_file_init_'(Goal) :- dynamic('$lgt_pp_entity_init_'/3). % '$lgt_pp_entity_init_'(Type, Entity, Goal) :- dynamic('$lgt_pp_entity_init_'/1). % '$lgt_pp_entity_init_'(Goal) :- dynamic('$lgt_pp_fentity_init_'/1). % '$lgt_pp_fentity_init_'(Goal) :- dynamic('$lgt_pp_redefined_built_in_'/5). % '$lgt_pp_redefined_built_in_'(Head, Sender, This, Self, THead) :- dynamic('$lgt_pp_directive_'/1). % '$lgt_pp_directive_'(Dir) :- dynamic('$lgt_pp_ppclause_'/1). % '$lgt_pp_ppclause_'(Clause) :- dynamic('$lgt_pp_rclause_'/1). % '$lgt_pp_rclause_'(Clause) :- dynamic('$lgt_pp_eclause_'/1). % '$lgt_pp_eclause_'(Clause) :- dynamic('$lgt_pp_feclause_'/1). % '$lgt_pp_feclause_'(Clause) :- dynamic('$lgt_pp_defs_pred_'/2). % '$lgt_pp_defs_pred_'(Functor, Arity) :- dynamic('$lgt_pp_calls_pred_'/4). % '$lgt_pp_calls_pred_'(Functor, Arity, TFunctor, TArity) :- dynamic('$lgt_non_portable_call_'/2). % '$lgt_non_portable_call_'(Functor, Arity) :- dynamic('$lgt_non_portable_function_'/2). % '$lgt_non_portable_function_'(Functor, Arity) :- dynamic('$lgt_pp_defs_nt_'/2). % '$lgt_pp_defs_nt_'(Functor, Arity) :- dynamic('$lgt_pp_calls_nt_'/2). % '$lgt_pp_calls_nt_'(Functor, Arity) :- dynamic('$lgt_pp_referenced_object_'/1). % '$lgt_pp_referenced_object_'(Object) :- dynamic('$lgt_pp_referenced_protocol_'/1). % '$lgt_pp_referenced_protocol_'(Protocol) :- dynamic('$lgt_pp_referenced_category_'/1). % '$lgt_pp_referenced_category_'(Category) :- dynamic('$lgt_pp_global_op_'/3). % '$lgt_pp_global_op_'(Priority, Specifier, Operator) :- dynamic('$lgt_pp_file_op_'/3). % '$lgt_pp_file_op_'(Priority, Specifier, Operator) :- dynamic('$lgt_pp_entity_op_'/3). % '$lgt_pp_entity_op_'(Priority, Specifier, Operator) :- dynamic('$lgt_pp_warnings_top_argument_'/1). % '$lgt_pp_warnings_top_argument_'(Term) :- dynamic('$lgt_pp_comp_warnings_counter_'/1). % '$lgt_pp_comp_warnings_counter_'(Counter) :- dynamic('$lgt_pp_load_warnings_counter_'/1). % '$lgt_pp_load_warnings_counter_'(Counter) :- dynamic('$lgt_pp_entity_warnings_flag_'/0). % '$lgt_pp_entity_warnings_flag_' :- dynamic('$lgt_pp_hook_term_expansion_'/2). % '$lgt_pp_hook_term_expansion_'(Term, Terms) :- dynamic('$lgt_pp_hook_goal_expansion_'/2). % '$lgt_pp_hook_goal_expansion_'(Goal, EGoal) :- dynamic('$lgt_pp_threaded_'/0). % '$lgt_pp_threaded_' :- dynamic('$lgt_pp_synchronized_'/0). % '$lgt_pp_synchronized_' :- dynamic('$lgt_pp_file_encoding_'/2). % '$lgt_pp_file_encoding_'(LogtalkEncoding, PrologEncoding) :- dynamic('$lgt_pp_file_bom_'/1). % '$lgt_pp_file_bom_'(BOM) :- dynamic('$lgt_pp_file_path_'/2). % '$lgt_pp_file_path_'(File, Path) :- dynamic('$lgt_pp_file_rclause_'/1). % '$lgt_pp_file_rclause_'(Clause) :- dynamic('$lgt_pp_cc_if_found_'/1). % '$lgt_pp_cc_if_found_'(Goal) :- dynamic('$lgt_pp_cc_skipping_'/0). % '$lgt_pp_cc_skipping_' :- dynamic('$lgt_pp_cc_mode_'/1). % '$lgt_pp_cc_mode_'(Action) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % top-level predicates for message sending and context switching calls % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Obj::Pred :- catch('$lgt_tr_msg'(Pred, Obj, Call, user), Error, '$lgt_runtime_error_handler'(error(Error, Obj::Pred, user))), ( '$lgt_dbg_debugging_', '$lgt_debugging_'(Obj) -> '$lgt_dbg_reset_invocation_number', '$lgt_ctx_ctx'(Ctx, _, user, user, Obj, '$lgt_bio_user_0_', [], _), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx), catch('$lgt_dbg_goal'(Obj::Pred, Call, DbgCtx), Error, '$lgt_runtime_error_handler'(Error)) ; catch(Call, Error, '$lgt_runtime_error_handler'(Error)) ). Obj< '$lgt_ctx_ctx'(Ctx, _, user, user, Obj, '$lgt_bio_user_0_', [], _), catch('$lgt_tr_body'(Obj< '$lgt_dbg_reset_invocation_number', catch(DPred, Error, '$lgt_runtime_error_handler'(Error)) ; catch(TPred, Error, '$lgt_runtime_error_handler'(Error)) ) ; throw(error(resource_error(context_switching_calls), Obj< throw(error(existence_error(goal_thread, Goal), Sender)) ; throw(error(existence_error(goal_thread, Self::Goal), Sender)) ). '$lgt_runtime_error_handler'(error(existence_error(goal_thread, '$lgt_send_to_object_nv'(Self, Goal, Sender)), _)) :- ( Self == user -> throw(error(existence_error(goal_thread, Goal), Sender)) ; throw(error(existence_error(goal_thread, Self::Goal), Sender)) ). '$lgt_runtime_error_handler'(error(existence_error(goal_thread, TGoal), Sender)) :- functor(TGoal, TFunctor, TArity), TGoal =.. [_| TArgs], '$lgt_reverse_predicate_functor'(TFunctor, TArity, _, _, Functor, Arity), '$lgt_reverse_predicate_args'(Arity, TArgs, Args, _, _, Self), Goal =.. [Functor| Args], ( Self == user -> throw(error(existence_error(goal_thread, Goal), Sender)) ; throw(error(existence_error(goal_thread, Self::Goal), Sender)) ). '$lgt_runtime_error_handler'(error(existence_error(procedure, TFunctor/8), _)) :- once(( atom_concat(Prefix, '_idcl', TFunctor) ; atom_concat(Prefix, '_dcl', TFunctor) )), '$lgt_reverse_entity_prefix'(Prefix, Obj), ( '$lgt_instantiates_class_'(_, Obj, _) ; '$lgt_specializes_class_'(_, Obj, _) ; '$lgt_extends_object_'(_, Obj, _) ; '$lgt_complemented_object_'(Obj, _, _, _, _) ), \+ '$lgt_current_object_'(Obj, _, _, _, _, _, _, _, _, _, _), throw(error(existence_error(object, Obj), _, _)). '$lgt_runtime_error_handler'(error(existence_error(procedure, TFunctor/7), _)) :- atom_concat(Prefix, '_dcl', TFunctor), '$lgt_reverse_entity_prefix'(Prefix, CtgOrPtc), ( '$lgt_implements_protocol_'(_, CtgOrPtc, _), \+ '$lgt_current_protocol_'(CtgOrPtc, _, _, _, _) -> throw(error(existence_error(protocol, CtgOrPtc), _, _)) ; '$lgt_extends_protocol_'(_, CtgOrPtc, _), \+ '$lgt_current_protocol_'(CtgOrPtc, _, _, _, _) -> throw(error(existence_error(protocol, CtgOrPtc), _, _)) ; '$lgt_imports_category_'(_, CtgOrPtc, _), \+ '$lgt_current_category_'(CtgOrPtc, _, _, _, _, _) -> throw(error(existence_error(category, CtgOrPtc), _, _)) ; '$lgt_extends_category_'(_, CtgOrPtc, _), \+ '$lgt_current_category_'(CtgOrPtc, _, _, _, _, _) -> throw(error(existence_error(category, CtgOrPtc), _, _)) ). '$lgt_runtime_error_handler'(error(existence_error(procedure, TFunctor1/TArity1), context(':'(_, TFunctor2/TArity2), _))) :- !, '$lgt_runtime_error_handler'(error(existence_error(procedure, TFunctor1/TArity1), context(TFunctor2/TArity2, _))). '$lgt_runtime_error_handler'(error(existence_error(procedure, TFunctor1/TArity1), context(TFunctor2/TArity2, _))) :- % SWI-Prolog '$lgt_reverse_predicate_functor'(TFunctor1, TArity1, Entity, Type, Functor1, Arity1), '$lgt_reverse_predicate_functor'(TFunctor2, TArity2, Entity, Type, Functor2, Arity2), throw(error(existence_error(procedure, Functor1/Arity1), context(Type, Entity, Functor2/Arity2))). '$lgt_runtime_error_handler'(error(existence_error(procedure, TFunctor1/TArity1), TFunctor2/TArity2)) :- % GNU Prolog and B-Prolog '$lgt_reverse_predicate_functor'(TFunctor1, TArity1, Entity, Type, Functor1, Arity1), '$lgt_reverse_predicate_functor'(TFunctor2, TArity2, Entity, Type, Functor2, Arity2), throw(error(existence_error(procedure, Functor1/Arity1), context(Type, Entity, Functor2/Arity2))). '$lgt_runtime_error_handler'(error(existence_error(procedure, ModTFunctor/TArity), _)) :- % CIAO atom_concat('user:', TFunctor, ModTFunctor), '$lgt_reverse_predicate_functor'(TFunctor, TArity, Entity, Type, Functor, Arity), throw(error(existence_error(procedure, Functor/Arity), context(Type, Entity, _))). '$lgt_runtime_error_handler'(error(existence_error(procedure, TFunctor/TArity), _)) :- % K-Prolog and YAP 5.1 or later '$lgt_reverse_predicate_functor'(TFunctor, TArity, Entity, Type, Functor, Arity), throw(error(existence_error(procedure, Functor/Arity), context(Type, Entity, _))). '$lgt_runtime_error_handler'(error(existence_error(procedure, ':'(_, TFunctor/TArity)), _)) :- '$lgt_reverse_predicate_functor'(TFunctor, TArity, Entity, Type, Functor, Arity), throw(error(existence_error(procedure, Functor/Arity), context(Type, Entity, _))). '$lgt_runtime_error_handler'(error(existence_error(_, _, procedure, ':'(_, TFunctor/TArity), _), _)) :- % Quintus, SICStus Prolog '$lgt_reverse_predicate_functor'(TFunctor, TArity, Entity, Type, Functor, Arity), throw(error(existence_error(procedure, Functor/Arity), context(Type, Entity, _))). '$lgt_runtime_error_handler'(error(existence_error(procedure, ':'(_, TFunctor/TArity)), _, _)) :- % XSB '$lgt_reverse_predicate_functor'(TFunctor, TArity, Entity, Type, Functor, Arity), throw(error(existence_error(procedure, Functor/Arity), context(Type, Entity, _))). '$lgt_runtime_error_handler'(error(Variable, _, Sender)) :- var(Variable), throw(error(instantiation_error, throw(_), Sender)). '$lgt_runtime_error_handler'(error(Error, user::Goal, user)) :- throw(error(Error, Goal)). '$lgt_runtime_error_handler'(logtalk_debugger_aborted) :- !, write('Debugging session aborted by user. Debugger still on.'), nl, abort. '$lgt_runtime_error_handler'(Error) :- throw(Error). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % built-in predicates % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % current_object(?object_identifier) current_object(Obj) :- nonvar(Obj), \+ callable(Obj), throw(error(type_error(object_identifier, Obj), current_object(Obj))). current_object(Obj) :- '$lgt_current_object_'(Obj, _, _, _, _, _, _, _, _, _, _). % current_protocol(?protocol_identifier) current_protocol(Ptc) :- nonvar(Ptc), \+ atom(Ptc), throw(error(type_error(protocol_identifier, Ptc), current_protocol(Ptc))). current_protocol(Ptc) :- '$lgt_current_protocol_'(Ptc, _, _, _, _). % current_category(?category_identifier) current_category(Ctg) :- nonvar(Ctg), \+ atom(Ctg), throw(error(type_error(category_identifier, Ctg), current_category(Ctg))). current_category(Ctg) :- '$lgt_current_category_'(Ctg, _, _, _, _, _). % object_property(?object_identifier, ?object_property) object_property(Obj, Prop) :- nonvar(Obj), \+ callable(Obj), throw(error(type_error(object_identifier, Obj), object_property(Obj, Prop))). object_property(Obj, Prop) :- nonvar(Prop), \+ '$lgt_valid_object_property'(Prop), throw(error(domain_error(object_property, Prop), object_property(Obj, Prop))). object_property(Obj, Prop) :- '$lgt_current_object_'(Obj, _, _, _, _, _, _, _, _, _, Type), ( Prop = Type % static/dynamic property ; '$lgt_entity_property_'(Obj, Prop) % other properties ). % category_property(?category_identifier, ?category_property) category_property(Ctg, Prop) :- nonvar(Ctg), \+ atom(Ctg), throw(error(type_error(category_identifier, Ctg), category_property(Ctg, Prop))). category_property(Ctg, Prop) :- nonvar(Prop), \+ '$lgt_valid_category_property'(Prop), throw(error(domain_error(category_property, Prop), category_property(Ctg, Prop))). category_property(Ctg, Prop) :- '$lgt_current_category_'(Ctg, _, _, _, _, Type), ( Prop = Type % static/dynamic property ; '$lgt_entity_property_'(Ctg, Prop) % other properties ). % protocol_property(?protocol_identifier, ?protocol_property) protocol_property(Ptc, Prop) :- nonvar(Ptc), \+ atom(Ptc), throw(error(type_error(protocol_identifier, Ptc), protocol_property(Ptc, Prop))). protocol_property(Ptc, Prop) :- nonvar(Prop), \+ '$lgt_valid_protocol_property'(Prop), throw(error(domain_error(protocol_property, Prop), protocol_property(Ptc, Prop))). protocol_property(Ptc, Prop) :- '$lgt_current_protocol_'(Ptc, _, _, _, Type), ( Prop = Type % static/dynamic property ; '$lgt_entity_property_'(Ptc, Prop) % other properties ). % create_object(?object_identifier, +list, +list, +list) create_object(Obj, Rels, Dirs, Clauses) :- (var(Rels); var(Dirs); var(Clauses)), throw(error(instantiation_error, create_object(Obj, Rels, Dirs, Clauses))). create_object(Obj, Rels, Dirs, Clauses) :- nonvar(Obj), \+ callable(Obj), throw(error(type_error(object_identifier, Obj), create_object(Obj, Rels, Dirs, Clauses))). create_object(Obj, Rels, Dirs, Clauses) :- nonvar(Obj), '$lgt_current_object_'(Obj, _, _, _, _, _, _, _, _, _, _), throw(error(permission_error(modify, object, Obj), create_object(Obj, Rels, Dirs, Clauses))). create_object(Obj, Rels, Dirs, Clauses) :- nonvar(Obj), '$lgt_current_category_'(Obj, _, _, _, _, _), throw(error(permission_error(modify, category, Obj), create_object(Obj, Rels, Dirs, Clauses))). create_object(Obj, Rels, Dirs, Clauses) :- nonvar(Obj), '$lgt_current_protocol_'(Obj, _, _, _, _), throw(error(permission_error(modify, protocol, Obj), create_object(Obj, Rels, Dirs, Clauses))). create_object(Obj, Rels, Dirs, Clauses) :- \+ '$lgt_is_proper_list'(Rels), throw(error(type_error(list, Rels), create_object(Obj, Rels, Dirs, Clauses))). create_object(Obj, Rels, Dirs, Clauses) :- \+ '$lgt_is_proper_list'(Dirs), throw(error(type_error(list, Dirs), create_object(Obj, Rels, Dirs, Clauses))). create_object(Obj, Rels, Dirs, Clauses) :- \+ '$lgt_is_proper_list'(Clauses), throw(error(type_error(list, Clauses), create_object(Obj, Rels, Dirs, Clauses))). create_object(Obj, Rels, Dirs, Clauses) :- ( var(Obj) -> '$lgt_gen_entity_identifier'(0'o, Obj) ; true ), '$lgt_clean_pp_clauses', '$lgt_tr_object_id'(Obj, (dynamic)), '$lgt_tr_object_relations'(Rels, Obj), '$lgt_tr_directives'(Dirs, user_input, _), '$lgt_tr_clauses'(Clauses, user_input), '$lgt_gen_object_local_def_clauses', '$lgt_fix_synchronized_preds', '$lgt_fix_pred_calls', '$lgt_gen_object_clauses', '$lgt_gen_object_directives', '$lgt_assert_tr_entity', '$lgt_clean_pp_clauses'. % create_category(?category_identifier, +list, +list, +list) create_category(Ctg, Rels, Dirs, Clauses) :- (var(Rels); var(Dirs); var(Clauses)), throw(error(instantiation_error, create_category(Ctg, Rels, Dirs, Clauses))). create_category(Ctg, Rels, Dirs, Clauses) :- nonvar(Ctg), \+ atom(Ctg), throw(error(type_error(category_identifier, Ctg), create_category(Ctg, Rels, Dirs, Clauses))). create_category(Ctg, Rels, Dirs, Clauses) :- nonvar(Ctg), '$lgt_current_category_'(Ctg, _, _, _, _, _), throw(error(permission_error(modify, category, Ctg), create_category(Ctg, Rels, Dirs, Clauses))). create_category(Ctg, Rels, Dirs, Clauses) :- nonvar(Ctg), '$lgt_current_object_'(Ctg, _, _, _, _, _, _, _, _, _, _), throw(error(permission_error(modify, object, Ctg), create_category(Ctg, Rels, Dirs, Clauses))). create_category(Ctg, Rels, Dirs, Clauses) :- nonvar(Ctg), '$lgt_current_protocol_'(Ctg, _, _, _, _), throw(error(permission_error(modify, protocol, Ctg), create_category(Ctg, Rels, Dirs, Clauses))). create_category(Ctg, Rels, Dirs, Clauses) :- \+ '$lgt_is_proper_list'(Rels), throw(error(type_error(list, Rels), create_category(Ctg, Rels, Dirs, Clauses))). create_category(Ctg, Rels, Dirs, Clauses) :- \+ '$lgt_is_proper_list'(Dirs), throw(error(type_error(list, Dirs), create_category(Ctg, Rels, Dirs, Clauses))). create_category(Ctg, Rels, Dirs, Clauses) :- \+ '$lgt_is_proper_list'(Clauses), throw(error(type_error(list, Clauses), create_category(Ctg, Rels, Dirs, Clauses))). create_category(Ctg, Rels, Dirs, Clauses) :- ( var(Ctg) -> '$lgt_gen_entity_identifier'(0'c, Ctg) ; true ), '$lgt_clean_pp_clauses', '$lgt_tr_category_id'(Ctg, (dynamic)), '$lgt_tr_category_relations'(Rels, Ctg), '$lgt_tr_directives'(Dirs, user_input, _), '$lgt_tr_clauses'(Clauses, user_input), '$lgt_fix_synchronized_preds', '$lgt_fix_pred_calls', '$lgt_gen_category_clauses', '$lgt_gen_category_directives', '$lgt_assert_tr_entity', '$lgt_clean_pp_clauses'. % create_protocol(?protocol_identifier, +list, +list) create_protocol(Ptc, Rels, Dirs) :- (var(Rels); var(Dirs)), throw(error(instantiation_error, create_protocol(Ptc, Rels, Dirs))). create_protocol(Ptc, Rels, Dirs) :- nonvar(Ptc), \+ atom(Ptc), throw(error(type_error(protocol_identifier, Ptc), create_protocol(Ptc, Rels, Dirs))). create_protocol(Ptc, Rels, Dirs) :- nonvar(Ptc), '$lgt_current_protocol_'(Ptc, _, _, _, _), throw(error(permission_error(modify, protocol, Ptc), create_protocol(Ptc, Rels, Dirs))). create_protocol(Ptc, Rels, Dirs) :- nonvar(Ptc), '$lgt_current_object_'(Ptc, _, _, _, _, _, _, _, _, _, _), throw(error(permission_error(modify, object, Ptc), create_protocol(Ptc, Rels, Dirs))). create_protocol(Ptc, Rels, Dirs) :- nonvar(Ptc), '$lgt_current_category_'(Ptc, _, _, _, _, _), throw(error(permission_error(modify, category, Ptc), create_protocol(Ptc, Rels, Dirs))). create_protocol(Ptc, Rels, Dirs) :- \+ '$lgt_is_proper_list'(Rels), throw(error(type_error(list, Rels), create_protocol(Ptc, Rels, Dirs))). create_protocol(Ptc, Rels, Dirs) :- \+ '$lgt_is_proper_list'(Dirs), throw(error(type_error(list, Dirs), create_protocol(Ptc, Rels, Dirs))). create_protocol(Ptc, Rels, Dirs) :- ( var(Ptc) -> '$lgt_gen_entity_identifier'(0'p, Ptc) ; true ), '$lgt_clean_pp_clauses', '$lgt_tr_protocol_id'(Ptc, (dynamic)), '$lgt_tr_protocol_relations'(Rels, Ptc), '$lgt_tr_directives'(Dirs, user_input, _), '$lgt_gen_protocol_clauses', '$lgt_gen_protocol_directives', '$lgt_assert_tr_entity', '$lgt_clean_pp_clauses'. % '$lgt_gen_entity_identifier'(+char_code, -entity_identifier) '$lgt_gen_entity_identifier'(Base, Id) :- repeat, '$lgt_next_integer'(1, New), number_codes(New, Codes), atom_codes(Id, [Base| Codes]), \+ '$lgt_current_protocol_'(Id, _, _, _, _), \+ '$lgt_current_object_'(Id, _, _, _, _, _, _, _, _, _, _), \+ '$lgt_current_category_'(Id, _, _, _, _, _), !. '$lgt_next_integer'(I, I). '$lgt_next_integer'(I, J) :- I2 is I + 1, '$lgt_next_integer'(I2, J). % abolish_object(@object_identifier) abolish_object(Obj) :- var(Obj), throw(error(instantiation_error, abolish_object(Obj))). abolish_object(Obj) :- \+ callable(Obj), throw(error(type_error(object_identifier, Obj), abolish_object(Obj))). abolish_object(Obj) :- ( '$lgt_current_object_'(Obj, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Rnm, Type) -> ( Type == (dynamic) -> '$lgt_abolish_entity_predicates'(Def), '$lgt_abolish_entity_predicates'(DDef), abolish(Dcl/6), abolish(Dcl/8), abolish(Def/5), abolish(Def/6), abolish(Super/6), abolish(IDcl/8), abolish(IDef/6), abolish(DDcl/2), abolish(DDef/5), abolish(Rnm/3), abolish(Prefix/8), retractall('$lgt_current_object_'(Obj, _, _, _, _, _, _, _, _, _, _)), retractall('$lgt_entity_property_'(Obj, _)), retractall('$lgt_extends_object_'(Obj, _, _)), retractall('$lgt_instantiates_class_'(Obj, _, _)), retractall('$lgt_specializes_class_'(Obj, _, _)), retractall('$lgt_implements_protocol_'(Obj, _, _)), retractall('$lgt_imports_category_'(Obj, _, _)), retractall('$lgt_debugging_'(Obj)), '$lgt_clean_lookup_caches' ; throw(error(permission_error(modify, static_object, Obj), abolish_object(Obj))) ) ; throw(error(existence_error(object, Obj), abolish_object(Obj))) ). % abolish_category(@category_identifier) abolish_category(Ctg) :- var(Ctg), throw(error(instantiation_error, abolish_category(Ctg))). abolish_category(Ctg) :- \+ atom(Ctg), throw(error(type_error(category_identifier, Ctg), abolish_category(Ctg))). abolish_category(Ctg) :- ( '$lgt_current_category_'(Ctg, Prefix, Dcl, Def, Rnm, Type) -> ( Type == (dynamic) -> '$lgt_abolish_entity_predicates'(Def), abolish(Dcl/6), abolish(Dcl/7), abolish(Def/5), abolish(Rnm/3), abolish(Prefix/3), retractall('$lgt_current_category_'(Ctg, _, _, _, _, _)), retractall('$lgt_entity_property_'(Ctg, _)), retractall('$lgt_extends_category_'(Ctg, _, _)), retractall('$lgt_implements_protocol_'(Ctg, _, _)), '$lgt_clean_lookup_caches' ; throw(error(permission_error(modify, static_category, Ctg), abolish_category(Ctg))) ) ; throw(error(existence_error(category, Ctg), abolish_category(Ctg))) ). % abolish_protocol(@protocol_identifier) abolish_protocol(Ptc) :- var(Ptc), throw(error(instantiation_error, abolish_protocol(Ptc))). abolish_protocol(Ptc) :- \+ atom(Ptc), throw(error(type_error(protocol_identifier, Ptc), abolish_protocol(Ptc))). abolish_protocol(Ptc) :- ( '$lgt_current_protocol_'(Ptc, Prefix, Dcl, Rnm, Type) -> ( Type == (dynamic) -> abolish(Dcl/6), abolish(Dcl/7), abolish(Rnm/3), abolish(Prefix/2), retractall('$lgt_current_protocol_'(Ptc, _, _, _, _)), retractall('$lgt_entity_property_'(Ptc, _)), retractall('$lgt_extends_protocol_'(Ptc, _, _)), '$lgt_clean_lookup_caches' ; throw(error(permission_error(modify, static_protocol, Ptc), abolish_protocol(Ptc))) ) ; throw(error(existence_error(protocol, Ptc), abolish_protocol(Ptc))) ). % '$lgt_abolish_entity_predicates'(+atom) '$lgt_abolish_entity_predicates'(Def) :- call_with_args(Def, _, _, _, _, Pred), functor(Pred, Functor, Arity), abolish(Functor/Arity), fail. '$lgt_abolish_entity_predicates'(_). % implements_protocol(?object_identifier, ?protocol_identifier) % implements_protocol(?category_identifier, ?protocol_identifier) implements_protocol(ObjOrCtg, Ptc) :- catch( implements_protocol(ObjOrCtg, Ptc, _), error(Error, _), throw(error(Error, implements_protocol(ObjOrCtg, Ptc)))). % implements_protocol(?object_identifier, ?protocol_identifier, ?atom) % implements_protocol(?category_identifier, ?protocol_identifier, ?atom) implements_protocol(ObjOrCtg, Ptc, Scope) :- nonvar(ObjOrCtg), \+ callable(ObjOrCtg), throw(error(type_error(object_identifier, ObjOrCtg), implements_protocol(ObjOrCtg, Ptc, Scope))). implements_protocol(ObjOrCtg, Ptc, Scope) :- nonvar(Ptc), \+ atom(Ptc), throw(error(type_error(protocol_identifier, Ptc), implements_protocol(ObjOrCtg, Ptc, Scope))). implements_protocol(ObjOrCtg, Ptc, Scope) :- nonvar(Scope), Scope \== (public), Scope \== protected, Scope \== private, throw(error(type_error(scope, Scope), implements_protocol(ObjOrCtg, Ptc, Scope))). implements_protocol(ObjOrCtg, Ptc, Scope) :- '$lgt_implements_protocol_'(ObjOrCtg, Ptc, Scope). % imports_category(?object_identifier, ?category_identifier) imports_category(Obj, Ctg) :- catch( imports_category(Obj, Ctg, _), error(Error, _), throw(error(Error, imports_category(Obj, Ctg)))). % imports_category(?object_identifier, ?category_identifier, ?atom) imports_category(Obj, Ctg, Scope) :- nonvar(Obj), \+ callable(Obj), throw(error(type_error(object_identifier, Obj), imports_category(Obj, Ctg, Scope))). imports_category(Obj, Ctg, Scope) :- nonvar(Ctg), \+ atom(Ctg), throw(error(type_error(category_identifier, Ctg), imports_category(Obj, Ctg, Scope))). imports_category(Obj, Ctg, Scope) :- nonvar(Scope), Scope \== (public), Scope \== protected, Scope \== private, throw(error(type_error(scope, Scope), imports_category(Obj, Ctg, Scope))). imports_category(Obj, Ctg, Scope) :- '$lgt_imports_category_'(Obj, Ctg, Scope). % instantiates_class(?object_identifier, ?object_identifier) instantiates_class(Obj, Class) :- catch( instantiates_class(Obj, Class, _), error(Error, _), throw(error(Error, instantiates_class(Obj, Class)))). % instantiates_class(?object_identifier, ?object_identifier, ?atom) instantiates_class(Obj, Class, Scope) :- nonvar(Obj), \+ callable(Obj), throw(error(type_error(object_identifier, Obj), instantiates_class(Obj, Class, Scope))). instantiates_class(Obj, Class, Scope) :- nonvar(Class), \+ callable(Class), throw(error(type_error(object_identifier, Class), instantiates_class(Obj, Class, Scope))). instantiates_class(Obj, Class, Scope) :- nonvar(Scope), Scope \== (public), Scope \== protected, Scope \== private, throw(error(type_error(scope, Scope), instantiates_class(Obj, Class, Scope))). instantiates_class(Obj, Class, Scope) :- '$lgt_instantiates_class_'(Obj, Class, Scope). % specializes_class(?object_identifier, ?object_identifier) specializes_class(Class, Superclass) :- catch( specializes_class(Class, Superclass, _), error(Error, _), throw(error(Error, specializes_class(Class, Superclass)))). % specializes_class(?object_identifier, ?object_identifier, ?atom) specializes_class(Class, Superclass, Scope) :- nonvar(Class), \+ callable(Class), throw(error(type_error(object_identifier, Class), specializes_class(Class, Superclass, Scope))). specializes_class(Class, Superclass, Scope) :- nonvar(Superclass), \+ callable(Superclass), throw(error(type_error(object_identifier, Superclass), specializes_class(Class, Superclass, Scope))). specializes_class(Class, Superclass, Scope) :- nonvar(Scope), Scope \== (public), Scope \== protected, Scope \== private, throw(error(type_error(scope, Scope), specializes_class(Class, Superclass, Scope))). specializes_class(Class, Superclass, Scope) :- '$lgt_specializes_class_'(Class, Superclass, Scope). % extends_category(?category_identifier, ?category_identifier) extends_category(Ctg1, Ctg2) :- catch( extends_category(Ctg1, Ctg2, _), error(Error, _), throw(error(Error, extends_category(Ctg1, Ctg2)))). % extends_category(?category_identifier, ?category_identifier, ?atom) extends_category(Ctg1, Ctg2, Scope) :- nonvar(Ctg1), \+ atom(Ctg1), throw(error(type_error(category_identifier, Ctg1), extends_category(Ctg1, Ctg2, Scope))). extends_category(Ctg1, Ctg2, Scope) :- nonvar(Ctg2), \+ atom(Ctg2), throw(error(type_error(category_identifier, Ctg2), extends_category(Ctg1, Ctg2, Scope))). extends_category(Ctg1, Ctg2, Scope) :- nonvar(Scope), Scope \== (public), Scope \== protected, Scope \== private, throw(error(type_error(scope, Scope), extends_category(Ctg1, Ctg2, Scope))). extends_category(Ctg1, Ctg2, Scope) :- '$lgt_extends_category_'(Ctg1, Ctg2, Scope). % extends_protocol(?protocol_identifier, ?protocol_identifier) extends_protocol(Ptc1, Ptc2) :- catch( extends_protocol(Ptc1, Ptc2, _), error(Error, _), throw(error(Error, extends_protocol(Ptc1, Ptc2)))). % extends_protocol(?protocol_identifier, ?protocol_identifier, ?atom) extends_protocol(Ptc1, Ptc2, Scope) :- nonvar(Ptc1), \+ atom(Ptc1), throw(error(type_error(protocol_identifier, Ptc1), extends_protocol(Ptc1, Ptc2, Scope))). extends_protocol(Ptc1, Ptc2, Scope) :- nonvar(Ptc2), \+ atom(Ptc2), throw(error(type_error(protocol_identifier, Ptc2), extends_protocol(Ptc1, Ptc2, Scope))). extends_protocol(Ptc1, Ptc2, Scope) :- nonvar(Scope), Scope \== (public), Scope \== protected, Scope \== private, throw(error(type_error(scope, Scope), extends_protocol(Ptc1, Ptc2, Scope))). extends_protocol(Ptc1, Ptc2, Scope) :- '$lgt_extends_protocol_'(Ptc1, Ptc2, Scope). % extends_object(?object_identifier, ?object_identifier) extends_object(Prototype, Parent) :- catch( extends_object(Prototype, Parent, _), error(Error, _), throw(error(Error, extends_object(Prototype, Parent)))). % extends_object(?object_identifier, ?object_identifier, ?atom) extends_object(Prototype, Parent, Scope) :- nonvar(Prototype), \+ callable(Prototype), throw(error(type_error(object_identifier, Prototype), extends_object(Prototype, Parent, Scope))). extends_object(Prototype, Parent, Scope) :- nonvar(Parent), \+ callable(Parent), throw(error(type_error(object_identifier, Parent), extends_object(Prototype, Parent, Scope))). extends_object(Prototype, Parent, Scope) :- nonvar(Scope), Scope \== (public), Scope \== protected, Scope \== private, throw(error(type_error(scope, Scope), extends_object(Prototype, Parent, Scope))). extends_object(Prototype, Parent, Scope) :- '$lgt_extends_object_'(Prototype, Parent, Scope). % complements_object(?category_identifier, ?object_identifier) complements_object(Category, Object) :- nonvar(Category), \+ atom(Category), throw(error(type_error(category_identifier, Category), complements_object(Category, Object))). complements_object(Category, Object) :- nonvar(Object), \+ callable(Object), throw(error(type_error(object_identifier, Object), complements_object(Category, Object))). complements_object(Category, Object) :- '$lgt_complemented_object_'(Object, Category, _, _, _). % current_event(?event, ?object_identifier, ?callable, ?object_identifier, ?object_identifier) current_event(Event, Obj, Msg, Sender, Monitor) :- nonvar(Event), Event \== before, Event \== after, throw(error(type_error(event, Event), current_event(Event, Obj, Msg, Sender, Monitor))). current_event(Event, Obj, Msg, Sender, Monitor) :- nonvar(Obj), \+ callable(Obj), throw(error(type_error(object_identifier, Obj), current_event(Event, Obj, Msg, Sender, Monitor))). current_event(Event, Obj, Msg, Sender, Monitor) :- nonvar(Msg), \+ callable(Msg), throw(error(type_error(callable, Msg), current_event(Event, Obj, Msg, Sender, Monitor))). current_event(Event, Obj, Msg, Sender, Monitor) :- nonvar(Sender), \+ callable(Sender), throw(error(type_error(object_identifier, Sender), current_event(Event, Obj, Msg, Sender, Monitor))). current_event(Event, Obj, Msg, Sender, Monitor) :- nonvar(Monitor), \+ callable(Monitor), throw(error(type_error(object_identifier, Monitor), current_event(Event, Obj, Msg, Sender, Monitor))). current_event(before, Obj, Msg, Sender, Monitor) :- '$lgt_before_'(Obj, Msg, Sender, Monitor, _). current_event(after, Obj, Msg, Sender, Monitor) :- '$lgt_after_'(Obj, Msg, Sender, Monitor, _). %define_events(@event, @object_identifier, @callable, @object_identifier, +object_identifier) define_events(Event, Obj, Msg, Sender, Monitor) :- nonvar(Event), Event \== before, Event \== after, throw(error(type_error(event, Event), define_events(Event, Obj, Msg, Sender, Monitor))). define_events(Event, Obj, Msg, Sender, Monitor) :- nonvar(Obj), \+ callable(Obj), throw(error(type_error(object_identifier, Obj), define_events(Event, Obj, Msg, Sender, Monitor))). define_events(Event, Obj, Msg, Sender, Monitor) :- nonvar(Msg), \+ callable(Msg), throw(error(type_error(callable, Msg), define_events(Event, Obj, Msg, Sender, Monitor))). define_events(Event, Obj, Msg, Sender, Monitor) :- nonvar(Sender), \+ callable(Sender), throw(error(type_error(object_identifier, Sender), define_events(Event, Obj, Msg, Sender, Monitor))). define_events(Event, Obj, Msg, Sender, Monitor) :- var(Monitor), throw(error(instantiation_error, define_events(Event, Obj, Msg, Sender, Monitor))). define_events(Event, Obj, Msg, Sender, Monitor) :- nonvar(Monitor), \+ callable(Monitor), throw(error(type_error(object_identifier, Monitor), define_events(Event, Obj, Msg, Sender, Monitor))). define_events(Event, Obj, Msg, Sender, Monitor) :- \+ '$lgt_current_object_'(Monitor, _, _, _, _, _, _, _, _, _, _), throw(error(existence_error(object, Monitor), define_events(Event, Obj, Msg, Sender, Monitor))). define_events(Event, Obj, Msg, Sender, Monitor) :- var(Event), !, ( '$lgt_current_object_'(Monitor, _, _, Def, _, _, _, _, _, _, _) -> ( call_with_args(Def, before(Obj, Msg, Sender), Monitor, Monitor, Monitor, BCall, _) -> ( call_with_args(Def, after(Obj, Msg, Sender), Monitor, Monitor, Monitor, ACall, _) -> retractall('$lgt_before_'(Obj, Msg, Sender, Monitor, _)), assertz('$lgt_before_'(Obj, Msg, Sender, Monitor, BCall)), retractall('$lgt_after_'(Obj, Msg, Sender, Monitor, _)), assertz('$lgt_after_'(Obj, Msg, Sender, Monitor, ACall)) ; throw(error(existence_error(procedure, after/3), define_events(Event, Obj, Msg, Sender, Monitor))) ) ; throw(error(existence_error(procedure, before/3), define_events(Event, Obj, Msg, Sender, Monitor))) ) ). define_events(before, Obj, Msg, Sender, Monitor) :- '$lgt_current_object_'(Monitor, _, _, Def, _, _, _, _, _, _, _) -> ( call_with_args(Def, before(Obj, Msg, Sender), Monitor, Monitor, Monitor, Call, _) -> retractall('$lgt_before_'(Obj, Msg, Sender, Monitor, _)), assertz('$lgt_before_'(Obj, Msg, Sender, Monitor, Call)) ; throw(error(existence_error(procedure, before/3), define_events(before, Obj, Msg, Sender, Monitor))) ). define_events(after, Obj, Msg, Sender, Monitor) :- '$lgt_current_object_'(Monitor, _, _, Def, _, _, _, _, _, _, _) -> ( call_with_args(Def, after(Obj, Msg, Sender), Monitor, Monitor, Monitor, Call, _) -> retractall('$lgt_after_'(Obj, Msg, Sender, Monitor, _)), assertz('$lgt_after_'(Obj, Msg, Sender, Monitor, Call)) ; throw(error(existence_error(procedure, after/3), define_events(after, Obj, Msg, Sender, Monitor))) ). % abolish_events(@event, @object_identifier, @callable, @object_identifier, @object_identifier) abolish_events(Event, Obj, Msg, Sender, Monitor) :- nonvar(Event), Event \== before, Event \== after, throw(error(type_error(event, Event), abolish_events(Event, Obj, Msg, Sender, Monitor))). abolish_events(Event, Obj, Msg, Sender, Monitor) :- nonvar(Obj), \+ callable(Obj), throw(error(type_error(object_identifier, Obj), abolish_events(Event, Obj, Msg, Sender, Monitor))). abolish_events(Event, Obj, Msg, Sender, Monitor) :- nonvar(Msg), \+ callable(Msg), throw(error(type_error(callable, Msg), abolish_events(Event, Obj, Msg, Sender, Monitor))). abolish_events(Event, Obj, Msg, Sender, Monitor) :- nonvar(Sender), \+ callable(Sender), throw(error(type_error(object_identifier, Sender), abolish_events(Event, Obj, Msg, Sender, Monitor))). abolish_events(Event, Obj, Msg, Sender, Monitor) :- nonvar(Monitor), \+ callable(Monitor), throw(error(type_error(object_identifier, Monitor), abolish_events(Event, Obj, Msg, Sender, Monitor))). abolish_events(Event, Obj, Msg, Sender, Monitor) :- var(Event), !, retractall('$lgt_before_'(Obj, Msg, Sender, Monitor, _)), retractall('$lgt_after_'(Obj, Msg, Sender, Monitor, _)). abolish_events(before, Obj, Msg, Sender, Monitor) :- retractall('$lgt_before_'(Obj, Msg, Sender, Monitor, _)). abolish_events(after, Obj, Msg, Sender, Monitor) :- retractall('$lgt_after_'(Obj, Msg, Sender, Monitor, _)). % built-in multi-threading meta-predicates % threaded(+callable) threaded(Goals) :- \+ '$lgt_compiler_flag'(threads, on), throw(error(resource_error(threads), threaded(Goals))). threaded(Goals) :- var(Goals), throw(error(instantiation_error, threaded(Goals))). threaded(Goals) :- \+ callable(Goals), throw(error(type_error(callable, Goals), threaded(Goals))). threaded(Goals) :- '$lgt_ctx_ctx'(Ctx, _, user, user, user, '$lgt_bio_user_0_', [], _), '$lgt_tr_threaded_wrap_calls'(Goals, WrappedGoals, threaded(Goals)), catch('$lgt_tr_body'(threaded(WrappedGoals), MTGoals, _, Ctx), Error, throw(error(Error, threaded(Goals)))), catch(MTGoals, Error, '$lgt_runtime_error_handler'(Error)). '$lgt_tr_threaded_wrap_calls'(Goal, _, OriginalGoal) :- var(Goal), throw(error(instantiation_error, OriginalGoal)). '$lgt_tr_threaded_wrap_calls'(Goal, _, OriginalGoal) :- \+ callable(Goal), throw(error(type_error(callable, Goal), OriginalGoal)). '$lgt_tr_threaded_wrap_calls'((Goal; Goals), ({Goal}; WrappedGoals), OriginalGoal) :- !, '$lgt_tr_threaded_wrap_calls'(Goals, WrappedGoals, OriginalGoal). '$lgt_tr_threaded_wrap_calls'((Goal, Goals), ({Goal}, WrappedGoals), OriginalGoal) :- !, '$lgt_tr_threaded_wrap_calls'(Goals, WrappedGoals, OriginalGoal). '$lgt_tr_threaded_wrap_calls'(Goal, {Goal}, _). % threaded_call(@callable, -nonvar) threaded_call(Goal, Tag) :- \+ '$lgt_compiler_flag'(threads, on), throw(error(resource_error(threads), threaded_call(Goal, Tag))). threaded_call(Goal, Tag) :- nonvar(Tag), throw(error(type_error(variable, Tag), threaded_call(Goal, Tag))). threaded_call(Goal, Tag) :- var(Goal), throw(error(instantiation_error, threaded_call(Goal, Tag))). threaded_call(Goal, Tag) :- \+ callable(Goal), throw(error(type_error(callable, Goal), threaded_call(Goal, Tag))). threaded_call(Goal, Tag) :- '$lgt_ctx_ctx'(Ctx, _, user, user, user, '$lgt_bio_user_0_', [], _), '$lgt_tr_body'(threaded_call({Goal}, Tag), TGoal, _, Ctx), catch(TGoal, Error, '$lgt_runtime_error_handler'(Error)). % threaded_call(@callable) threaded_call(Goal) :- \+ '$lgt_compiler_flag'(threads, on), throw(error(resource_error(threads), threaded_call(Goal))). threaded_call(Goal) :- var(Goal), throw(error(instantiation_error, threaded_call(Goal))). threaded_call(Goal) :- \+ callable(Goal), throw(error(type_error(callable, Goal), threaded_call(Goal))). threaded_call(Goal) :- '$lgt_ctx_ctx'(Ctx, _, user, user, user, '$lgt_bio_user_0_', [], _), '$lgt_tr_body'(threaded_call({Goal}), TGoal, _, Ctx), catch(TGoal, Error, '$lgt_runtime_error_handler'(Error)). % threaded_once(@callable, -nonvar) threaded_once(Goal, Tag) :- \+ '$lgt_compiler_flag'(threads, on), throw(error(resource_error(threads), threaded_once(Goal, Tag))). threaded_once(Goal, Tag) :- nonvar(Tag), throw(error(type_error(variable, Tag), threaded_once(Goal, Tag))). threaded_once(Goal, Tag) :- var(Goal), throw(error(instantiation_error, threaded_once(Goal, Tag))). threaded_once(Goal, Tag) :- \+ callable(Goal), throw(error(type_error(callable, Goal), threaded_once(Goal, Tag))). threaded_once(Goal, Tag) :- '$lgt_ctx_ctx'(Ctx, _, user, user, user, '$lgt_bio_user_0_', [], _), '$lgt_tr_body'(threaded_once({Goal}, Tag), TGoal, _, Ctx), catch(TGoal, Error, '$lgt_runtime_error_handler'(Error)). % threaded_once(@callable) threaded_once(Goal) :- \+ '$lgt_compiler_flag'(threads, on), throw(error(resource_error(threads), threaded_once(Goal))). threaded_once(Goal) :- var(Goal), throw(error(instantiation_error, threaded_once(Goal))). threaded_once(Goal) :- \+ callable(Goal), throw(error(type_error(callable, Goal), threaded_once(Goal))). threaded_once(Goal) :- '$lgt_ctx_ctx'(Ctx, _, user, user, user, '$lgt_bio_user_0_', [], _), '$lgt_tr_body'(threaded_once({Goal}), TGoal, _, Ctx), catch(TGoal, Error, '$lgt_runtime_error_handler'(Error)). % threaded_ignore(@callable) threaded_ignore(Goal) :- \+ '$lgt_compiler_flag'(threads, on), throw(error(resource_error(threads), threaded_ignore(Goal))). threaded_ignore(Goal) :- var(Goal), throw(error(instantiation_error, threaded_ignore(Goal))). threaded_ignore(Goal) :- \+ callable(Goal), throw(error(type_error(callable, Goal), threaded_ignore(Goal))). threaded_ignore(Goal) :- '$lgt_ctx_ctx'(Ctx, _, user, user, user, '$lgt_bio_user_0_', [], _), '$lgt_tr_body'(threaded_ignore({Goal}), TGoal, _, Ctx), catch(TGoal, Error, '$lgt_runtime_error_handler'(Error)). % threaded_exit(+callable, +nonvar) threaded_exit(Goal, Tag) :- \+ '$lgt_compiler_flag'(threads, on), throw(error(resource_error(threads), threaded_exit(Goal, Tag))). threaded_exit(Goal, Tag) :- var(Tag), throw(error(instantiation_error, threaded_exit(Goal, Tag))). threaded_exit(Goal, Tag) :- var(Goal), throw(error(instantiation_error, threaded_exit(Goal, Tag))). threaded_exit(Goal, Tag) :- \+ callable(Goal), throw(error(type_error(callable, Goal), threaded_exit(Goal, Tag))). threaded_exit(Goal, Tag) :- '$lgt_ctx_ctx'(Ctx, _, user, user, user, '$lgt_bio_user_0_', [], _), '$lgt_tr_body'(threaded_exit({Goal}, Tag), TGoal, _, Ctx), catch(TGoal, Error, '$lgt_runtime_error_handler'(Error)). % threaded_exit(+callable) threaded_exit(Goal) :- \+ '$lgt_compiler_flag'(threads, on), throw(error(resource_error(threads), threaded_exit(Goal))). threaded_exit(Goal) :- var(Goal), throw(error(instantiation_error, threaded_exit(Goal))). threaded_exit(Goal) :- \+ callable(Goal), throw(error(type_error(callable, Goal), threaded_exit(Goal))). threaded_exit(Goal) :- '$lgt_ctx_ctx'(Ctx, _, user, user, user, '$lgt_bio_user_0_', [], _), '$lgt_tr_body'(threaded_exit({Goal}), TGoal, _, Ctx), catch(TGoal, Error, '$lgt_runtime_error_handler'(Error)). % threaded_peek(+callable, +nonvar) threaded_peek(Goal, Tag) :- \+ '$lgt_compiler_flag'(threads, on), throw(error(resource_error(threads), threaded_peek(Goal, Tag))). threaded_peek(Goal, Tag) :- var(Tag), throw(error(instantiation_error, threaded_peek(Goal, Tag))). threaded_peek(Goal, Tag) :- var(Goal), throw(error(instantiation_error, threaded_peek(Goal, Tag))). threaded_peek(Goal, Tag) :- \+ callable(Goal), throw(error(type_error(callable, Goal), threaded_peek(Goal, Tag))). threaded_peek(Goal, Tag) :- '$lgt_ctx_ctx'(Ctx, _, user, user, user, '$lgt_bio_user_0_', [], _), '$lgt_tr_body'(threaded_peek({Goal}, Tag), TGoal, _, Ctx), catch(TGoal, Error, '$lgt_runtime_error_handler'(Error)). % threaded_peek(+callable) threaded_peek(Goal) :- \+ '$lgt_compiler_flag'(threads, on), throw(error(resource_error(threads), threaded_peek(Goal))). threaded_peek(Goal) :- var(Goal), throw(error(instantiation_error, threaded_peek(Goal))). threaded_peek(Goal) :- \+ callable(Goal), throw(error(type_error(callable, Goal), threaded_peek(Goal))). threaded_peek(Goal) :- '$lgt_ctx_ctx'(Ctx, _, user, user, user, '$lgt_bio_user_0_', [], _), '$lgt_tr_body'(threaded_peek({Goal}), TGoal, _, Ctx), catch(TGoal, Error, '$lgt_runtime_error_handler'(Error)). % threaded_wait(?nonvar) threaded_wait(Message) :- \+ '$lgt_compiler_flag'(threads, on), throw(error(resource_error(threads), threaded_wait(Message))). threaded_wait(Message) :- '$lgt_current_object_'(user, Prefix, _, _, _, _, _, _, _, _, _) -> '$lgt_thread_get_notifications'(Message, Prefix). % threaded_notify(@term) threaded_notify(Message) :- var(Message), throw(error(instantiation_error, threaded_notify(Message))). threaded_notify(Message) :- \+ '$lgt_compiler_flag'(threads, on), throw(error(resource_error(threads), threaded_notify(Message))). threaded_notify(Message) :- '$lgt_current_object_'(user, Prefix, _, _, _, _, _, _, _, _, _) -> '$lgt_thread_send_notifications'(Message, Prefix). % compiling and loading built-in predicates % '$lgt_compiler_flag'(+atom, ?atom) % % gets/checks the current value of a compiler flag '$lgt_compiler_flag'(Option, Value) :- ( '$lgt_pp_compiler_flag_'(Option, Value2) -> % flag value as defined in the options argument Value = Value2 % of the compiling and loading predicates ; '$lgt_current_flag_'(Option, Value2) -> % default value for the current Logtalk session, Value = Value2 % set by calls to the set_logtalk_flag/2 predicate ; '$lgt_default_flag'(Option, Value) % default value, defined on the Prolog config files ). % '$lgt_file_type_alt_directory'(+atom, ?atom) % % gets/checks the current value of the alternate compilation directory for the given file type '$lgt_file_type_alt_directory'(xml, Directory) :- '$lgt_compiler_flag'(xmldir, Directory). '$lgt_file_type_alt_directory'(prolog, Directory) :- '$lgt_compiler_flag'(tmpdir, Directory). % logtalk_compile(@source_file_name) % logtalk_compile(@source_file_name_list) % % compiles to disk a source file or list of source files using default options logtalk_compile(Files) :- catch( logtalk_compile(Files, []), error(Error, _), throw(error(Error, logtalk_compile(Files)))). % logtalk_compile(@source_file_name, @list) % logtalk_compile(@source_file_name_list, @list) % % compiles to disk a source file or a list of source files using a list of flag options logtalk_compile(Files, Flags) :- catch( ('$lgt_init_warnings_counter'(logtalk_compile(Files, Flags)), '$lgt_check_source_files'(Files), '$lgt_check_compiler_flags'(Flags), '$lgt_set_compiler_flags'(Flags), '$lgt_compile_files'(Files), '$lgt_clear_compiler_flags', '$lgt_report_warning_numbers'(logtalk_compile(Files, Flags))), Error, ('$lgt_clear_compiler_flags', '$lgt_reset_warnings_counter', throw(error(Error, logtalk_compile(Files, Flags))))). % predicates for compilation warning counting and reporting '$lgt_reset_warnings_counter' :- retractall('$lgt_pp_warnings_top_argument_'(_)), retractall('$lgt_pp_comp_warnings_counter_'(_)), retractall('$lgt_pp_load_warnings_counter_'(_)), retractall('$lgt_pp_entity_warnings_flag_'). '$lgt_init_warnings_counter'(Term) :- ( '$lgt_pp_warnings_top_argument_'(_) -> true ; asserta('$lgt_pp_warnings_top_argument_'(Term)), % remember top compilation/loading goal retractall('$lgt_pp_comp_warnings_counter_'(_)), % initialize compilation warnings counter asserta('$lgt_pp_comp_warnings_counter_'(0)), retractall('$lgt_pp_load_warnings_counter_'(_)), % initialize loading warnings counter asserta('$lgt_pp_load_warnings_counter_'(0)), retractall('$lgt_pp_entity_warnings_flag_') ). '$lgt_inc_compile_warnings_counter' :- retract('$lgt_pp_comp_warnings_counter_'(Old)) -> New is Old + 1, asserta('$lgt_pp_comp_warnings_counter_'(New)), ( '$lgt_pp_entity_warnings_flag_' -> true ; assertz('$lgt_pp_entity_warnings_flag_') ). '$lgt_inc_load_warnings_counter' :- retract('$lgt_pp_load_warnings_counter_'(Old)) -> New is Old + 1, asserta('$lgt_pp_load_warnings_counter_'(New)). '$lgt_report_warning_numbers'(Term) :- ( retract('$lgt_pp_warnings_top_argument_'(Term)), % if top compilation/loading goal then retract('$lgt_pp_comp_warnings_counter_'(CCounter)), % report compilation and loading warnings retract('$lgt_pp_load_warnings_counter_'(LCounter)) -> ( '$lgt_compiler_flag'(report, on) -> ( CCounter + LCounter =:= 0 -> % no warnings write('% (0 warnings)'), nl ; CCounter =:= 0 -> % no compilation warnings write('% ('), write(LCounter), write(' loading '), '$lgt_write_warnings_word'(LCounter), write(')'), nl ; LCounter =:= 0 -> % no loading warnings write('% ('), write(CCounter), write(' compilation '), '$lgt_write_warnings_word'(CCounter), write(')'), nl ; write('% ('), write(CCounter), write(' compilation '), % both compilation and loading warnings '$lgt_write_warnings_word'(CCounter), write(' and '), write(LCounter), write(' loading '), '$lgt_write_warnings_word'(LCounter), write(')'), nl ) ; % report flag is off true ) ; % not top compilation/loading goal true ). '$lgt_write_warnings_word'(Number) :- ( Number =:= 1 -> write(warning) ; write(warnings) ). % '$lgt_check_source_files'(@term) % % check if the source file names are valid and correspond to existing files '$lgt_check_source_files'(Files) :- var(Files), throw(instantiation_error). '$lgt_check_source_files'([]) :- !. '$lgt_check_source_files'([File| Files]) :- !, '$lgt_check_source_file'(File), '$lgt_check_source_files'(Files). '$lgt_check_source_files'(File) :- '$lgt_check_source_file'(File). '$lgt_check_source_file'(File) :- var(File), throw(instantiation_error). '$lgt_check_source_file'(File) :- compound(File), !, '$lgt_check_library_source_file'(File). '$lgt_check_source_file'(File) :- \+ atom(File), throw(type_error(source_file_name, File)). '$lgt_check_source_file'(File) :- '$lgt_file_name'(logtalk, File, FileWithExtension), \+ '$lgt_file_exists'(FileWithExtension), throw(existence_error(file, File)). '$lgt_check_source_file'(_). '$lgt_check_library_source_file'(Term) :- ( Term =.. [Library, File] -> '$lgt_check_library_source_file'(Library, File) ; throw(type_error(source_file_name, Term)) ). '$lgt_check_library_source_file'(Library, File) :- '$lgt_expand_library_path'(Library, Path), '$lgt_directory_exists'(Path), '$lgt_current_directory'(Current), '$lgt_change_directory'(Path), catch( '$lgt_check_source_file'(File), Error, ('$lgt_change_directory'(Current), throw(Error))), '$lgt_change_directory'(Current), !. '$lgt_check_library_source_file'(Library, _) :- throw(existence_error(library, Library)). % '$lgt_expand_library_path'(+atom, -atom) % % converts a library alias into its corresponding path; uses a depth % bound to prevent loops (inspired by similar code in SWI-Prolog) '$lgt_expand_library_path'(Library, Path) :- '$lgt_expand_library_path'(Library, Path, 16). '$lgt_expand_library_path'(Library, Path, N) :- ( logtalk_library_path(Library, Location) -> ( atom(Location) -> Path = Location ; Location =.. [Library2, Location2], N > 0, N2 is N - 1, '$lgt_expand_library_path'(Library2, Path2, N2), atom_concat(Path2, Location2, Path) ) ; atom(Library), Path = Library ). % '$lgt_check_compiler_flags'(@list) % % check if the compiler flags are valid '$lgt_check_compiler_flags'(Flags) :- var(Flags), throw(instantiation_error). '$lgt_check_compiler_flags'(Flags) :- \+ '$lgt_is_proper_list'(Flags), throw(type_error(list, Flags)). '$lgt_check_compiler_flags'(Flags) :- '$lgt_check_compiler_flag_list'(Flags). '$lgt_check_compiler_flag_list'([]). '$lgt_check_compiler_flag_list'([Flag| Flags]) :- ( '$lgt_valid_compiler_flag'(Flag) -> '$lgt_check_compiler_flag_list'(Flags) ; throw(type_error(compiler_flag, Flag)) ). '$lgt_valid_compiler_flag'(Flag) :- compound(Flag), Flag =.. [Name, Value], nonvar(Value), '$lgt_valid_flag_value'(Name, Value). % '$lgt_set_compiler_flags'(@list) % % sets the compiler flag options '$lgt_set_compiler_flags'(Flags) :- '$lgt_assert_compiler_flags'(Flags), ( '$lgt_pp_compiler_flag_'(debug, on) -> % debug flag on requires the retractall('$lgt_pp_compiler_flag_'(smart_compilation, _)), % smart_compilation flag to asserta('$lgt_pp_compiler_flag_'(smart_compilation, off)), % be off and retractall('$lgt_pp_compiler_flag_'(reload, _)), % the reload flag to be set asserta('$lgt_pp_compiler_flag_'(reload, always)) % to always ; true), ( '$lgt_pp_compiler_flag_'(hook, Obj) -> % pre-compile hooks in order ( Obj == user -> % to speed up entity compilation TermExpansionGoal = term_expansion(Term, Terms), GoalExpansionGoal = goal_expansion(Goal, EGoal) ; '$lgt_tr_msg'(term_expansion(Term, Terms), Obj, TermExpansionGoal, user), '$lgt_tr_msg'(goal_expansion(Goal, EGoal), Obj, GoalExpansionGoal, user) ), assertz(('$lgt_pp_hook_term_expansion_'(Term, Terms) :- catch(TermExpansionGoal, _, fail))), assertz(('$lgt_pp_hook_goal_expansion_'(Goal, EGoal) :- catch(GoalExpansionGoal, _, fail))) ; true ). '$lgt_assert_compiler_flags'([]). '$lgt_assert_compiler_flags'([Flag| Flags]) :- Flag =.. [Name, Value], asserta('$lgt_pp_compiler_flag_'(Name, Value)), '$lgt_assert_compiler_flags'(Flags). % '$lgt_clear_compiler_flags'(@list) % % clears the compiler flag options '$lgt_clear_compiler_flags' :- retractall('$lgt_pp_compiler_flag_'(_, _)), % retract flag values retractall('$lgt_pp_hook_term_expansion_'(_, _)), % and any term and retractall('$lgt_pp_hook_goal_expansion_'(_, _)). % goal expansion hooks % logtalk_load(@source_file_name) % logtalk_load(@source_file_name_list) % % compiles to disk and then loads to memory a source file % or a list of source files using default compiler options logtalk_load(Files) :- catch( logtalk_load(Files, []), error(Error, _), throw(error(Error, logtalk_load(Files)))). % logtalk_load(@source_file_name, @list) % logtalk_load(@source_file_name_list, @list) % % compiles to disk and then loads to memory a source file % or a list of source files using a list of compiler options logtalk_load(Files, Flags) :- catch( ('$lgt_init_warnings_counter'(logtalk_load(Files, Flags)), '$lgt_check_source_files'(Files), '$lgt_check_compiler_flags'(Flags), '$lgt_set_compiler_flags'(Flags), '$lgt_load_files'(Files), '$lgt_clear_compiler_flags', '$lgt_report_warning_numbers'(logtalk_load(Files, Flags))), Error, ('$lgt_clear_compiler_flags', '$lgt_reset_warnings_counter', throw(error(Error, logtalk_load(Files, Flags))))). % set_logtalk_flag(+atom, +nonvar) % % sets a Logtalk flag set_logtalk_flag(Flag, Value) :- var(Flag), throw(error(instantiation_error, set_logtalk_flag(Flag, Value))). set_logtalk_flag(Flag, Value) :- var(Value), throw(error(instantiation_error, set_logtalk_flag(Flag, Value))). set_logtalk_flag(Flag, Value) :- nonvar(Flag), \+ atom(Flag), throw(error(type_error(atom, Flag), set_logtalk_flag(Flag, Value))). set_logtalk_flag(Flag, Value) :- atom(Flag), \+ '$lgt_valid_flag'(Flag), throw(error(domain_error(valid_flag, Flag), set_logtalk_flag(Flag, Value))). set_logtalk_flag(Flag, Value) :- '$lgt_read_only_flag'(Flag), throw(error(permission_error(modify, read_only_flag, Flag), set_logtalk_flag(Flag, Value))). set_logtalk_flag(Flag, Value) :- \+ '$lgt_valid_flag_value'(Flag, Value), throw(error(domain_error(valid_flag_value, Value), set_logtalk_flag(Flag, Value))). set_logtalk_flag(Flag, Value) :- retractall('$lgt_current_flag_'(Flag, _)), assertz('$lgt_current_flag_'(Flag, Value)), ( Flag == debug -> retractall('$lgt_current_flag_'(smart_compilation, _)), assertz('$lgt_current_flag_'(smart_compilation, off)) ; Flag == hook -> '$lgt_compile_hooks'(Value) ; true ). % current_logtalk_flag(?atom, ?nonvar) % % tests/gets Logtalk flags current_logtalk_flag(Flag, Value) :- nonvar(Flag), \+ atom(Flag), throw(error(type_error(atom, Flag), current_logtalk_flag(Flag, Value))). current_logtalk_flag(Flag, Value) :- atom(Flag), \+ '$lgt_valid_flag'(Flag), throw(error(domain_error(valid_flag, Flag), current_logtalk_flag(Flag, Value))). current_logtalk_flag(Flag, Value) :- '$lgt_current_flag_'(Flag, Value). current_logtalk_flag(Flag, Value) :- '$lgt_default_flag'(Flag, Value), \+ '$lgt_current_flag_'(Flag, _). current_logtalk_flag(version, version(2, 34, 1)). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % built-in methods % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % checks if an object exists at runtime '$lgt_obj_exists'(Obj, Pred, Sender) :- ( '$lgt_current_object_'(Obj, _, _, _, _, _, _, _, _, _, _) -> true ; throw(error(existence_error(object, Obj), Obj::Pred, Sender)) ). % current_predicate/1 built-in method '$lgt_current_predicate'(Obj, Pred, Sender, _) :- nonvar(Pred), Pred \= _/_, throw(error(type_error(predicate_indicator, Pred), Obj::current_predicate(Pred), Sender)). '$lgt_current_predicate'(Obj, Functor/Arity, Sender, _) :- nonvar(Functor), \+ atom(Functor), throw(error(type_error(predicate_indicator, Functor/Arity), Obj::current_predicate(Functor/Arity), Sender)). '$lgt_current_predicate'(Obj, Functor/Arity, Sender, _) :- nonvar(Arity), \+ (integer(Arity), Arity >= 0), throw(error(type_error(predicate_indicator, Functor/Arity), Obj::current_predicate(Functor/Arity), Sender)). '$lgt_current_predicate'(Obj, Functor/Arity, Sender, _) :- \+ '$lgt_current_object_'(Obj, _, _, _, _, _, _, _, _, _, _), throw(error(existence_error(object, Obj), Obj::current_predicate(Functor/Arity), Sender)). '$lgt_current_predicate'(Obj, Functor/Arity, Sender, Scope) :- nonvar(Functor), nonvar(Arity), !, functor(Pred, Functor, Arity), '$lgt_visible_predicate'(Obj, Pred, Sender, Scope), !. '$lgt_current_predicate'(Obj, Functor/Arity, Sender, Scope) :- setof( Functor/Arity, (Pred, Scope)^('$lgt_visible_predicate'(Obj, Pred, Sender, Scope), functor(Pred, Functor, Arity)), Preds), '$lgt_member'(Functor/Arity, Preds). % '$lgt_visible_predicate'(@object_identifier, ?callable, @object_identifier, @term) % % checks/returns object predicates visible/within the scope of the sender '$lgt_visible_predicate'(Obj, Pred, Sender, Scope) :- '$lgt_current_object_'(Obj, _, Dcl, _, _, _, _, _, _, _, _) -> call_with_args(Dcl, Pred, PScope, _, _, _, _, SCtn, _), once((\+ \+ PScope = Scope; Sender = SCtn)). % predicate_property/2 built-in method '$lgt_predicate_property'(Obj, Pred, Prop, Sender, _) :- var(Pred), throw(error(instantiation_error, Obj::predicate_property(Pred, Prop), Sender)). '$lgt_predicate_property'(Obj, Pred, Prop, Sender, _) :- nonvar(Prop), \+ '$lgt_valid_pred_property'(Prop), throw(error(domain_error(predicate_property, Prop), Obj::predicate_property(Pred, Prop), Sender)). '$lgt_predicate_property'(Obj, Pred, Prop, Sender, _) :- \+ callable(Pred), throw(error(type_error(callable, Pred), Obj::predicate_property(Pred, Prop), Sender)). '$lgt_predicate_property'(Obj, Pred, Prop, Sender, _) :- \+ '$lgt_current_object_'(Obj, _, _, _, _, _, _, _, _, _, _), throw(error(existence_error(object, Obj), Obj::predicate_property(Pred, Prop), Sender)). '$lgt_predicate_property'(Obj, Pred, Prop, Sender, Scope) :- '$lgt_current_object_'(Obj, _, Dcl, Def, _, _, _, _, _, Rnm, _), call_with_args(Dcl, Pred, PScope, Type, Meta, NonTerminal, Synchronized, SCtn, TCtn), !, once((\+ \+ PScope = Scope; Sender = SCtn)), ( '$lgt_scope'(Prop, PScope) ; Prop = Type ; Prop = declared_in(TCtn) ; Meta \== no, Meta =.. [_| MetaArgs], % Pred can be an alias functor(Pred, Functor, _), Meta2 =.. [Functor| MetaArgs], Prop = meta_predicate(Meta2) ; NonTerminal \== no, functor(Pred, Functor, Arity2), Arity is Arity2 - 2, Prop = non_terminal(Functor//Arity) ; Synchronized \== no, Prop = synchronized ; once(( '$lgt_current_object_'(TCtn, _, TCtnDcl, _, _, _, _, _, _, _, _) ; '$lgt_current_category_'(TCtn, _, TCtnDcl, _, _, _) ; '$lgt_current_protocol_'(TCtn, _, TCtnDcl, _, _) )), \+ call_with_args(TCtnDcl, Pred, _, _, _, _, _), '$lgt_alias_pred'(Obj, Rnm, Pred, Pred2), Prop = alias_of(Pred2) ; call_with_args(Def, Pred, _, _, _, _, DCtn) -> % must be the last property checked because Prop = defined_in(DCtn) % of the implicit cut on the ->/2 call ). '$lgt_predicate_property'(_, Pred, Prop, _, Scope) :- '$lgt_built_in_method'(Pred, PScope), !, \+ \+ PScope = Scope, ( Prop = static ; Prop = built_in ; '$lgt_scope'(Prop, PScope) ; functor(Pred, Functor, Arity), functor(Meta, Functor, Arity), ('$lgt_meta_predicate'(Meta) -> Prop = meta_predicate(Meta)) ). '$lgt_predicate_property'(_, Pred, Prop, _, _) :- '$lgt_built_in'(Pred), ( Prop = (public) ; Prop = built_in ; ( '$lgt_predicate_property'(Pred, (dynamic)) -> Prop = (dynamic) ; Prop = static ) ; functor(Pred, Functor, Arity), functor(Meta, Functor, Arity), ('$lgt_meta_predicate'(Meta) -> Prop = meta_predicate(Meta)) ). % '$lgt_scope'(?atom, ?nonvar). % % converts between user and system scope terms '$lgt_scope'(private, p). '$lgt_scope'(protected, p(p)). '$lgt_scope'((public), p(p(p))). % '$lgt_filter_scope'(+nonvar, -nonvar) % % filters predicate scope; % used in the implementation of protected-qualified relations between entities: % public predicates become protected predicates, protected and private predicates % are unaffected '$lgt_filter_scope'(p(_), p(p)). '$lgt_filter_scope'(p, p). % '$lgt_set_scope_container'(+nonvar, +object_identifier, +object_identifier, +object_identifier) % % sets predicate scope container; % used in the implementation of private-qualified relations between entities: % when the predicate is public or protected, the object inheriting the predicate % becomes the scope container; when the predicate is private, the scope container % is the inherited scope container '$lgt_set_scope_container'(p(_), _, SCtn, SCtn). '$lgt_set_scope_container'(p, SCtn, _, SCtn). % '$lgt_alias_pred'(+object_identifier, +atom, +callable, -callable) % % finds the predicate pointed by an alias '$lgt_alias_pred'(Obj, Rnm, Alias, Pred) :- '$lgt_alias_pred'(Obj, Rnm, Alias, Pred, _). '$lgt_alias_pred'(_, Rnm, Alias, Pred, _) :- call_with_args(Rnm, _, Pred, Alias) -> Pred \= Alias, !. '$lgt_alias_pred'(Obj, _, Alias, Pred, _) :- '$lgt_implements_protocol_'(Obj, Ptc, _), '$lgt_current_protocol_'(Ptc, _, _, Rnm, _), '$lgt_alias_pred'(Ptc, Rnm, Alias, Pred, _). '$lgt_alias_pred'(Ptc1, _, Alias, Pred, _) :- '$lgt_extends_protocol_'(Ptc1, Ptc2, _), '$lgt_current_protocol_'(Ptc2, _, _, Rnm, _), '$lgt_alias_pred'(Ptc2, Rnm, Alias, Pred, _). '$lgt_alias_pred'(Ctg1, _, Alias, Pred, _) :- '$lgt_extends_category_'(Ctg1, Ctg2, _), '$lgt_current_category_'(Ctg2, _, _, _, Rnm, _), '$lgt_alias_pred'(Ctg2, Rnm, Alias, Pred, _). '$lgt_alias_pred'(Obj, _, Alias, Pred, _) :- '$lgt_imports_category_'(Obj, Ctg, _), '$lgt_current_category_'(Ctg, _, _, _, Rnm, _), '$lgt_alias_pred'(Ctg, Rnm, Alias, Pred, _). '$lgt_alias_pred'(Obj, _, Alias, Pred, prototype) :- '$lgt_extends_object_'(Obj, Parent, _), '$lgt_current_object_'(Parent, _, _, _, _, _, _, _, _, Rnm, _), '$lgt_alias_pred'(Parent, Rnm, Alias, Pred, prototype). '$lgt_alias_pred'(Instance, _, Alias, Pred, instance) :- '$lgt_instantiates_class_'(Instance, Class, _), '$lgt_current_object_'(Class, _, _, _, _, _, _, _, _, Rnm, _), '$lgt_alias_pred'(Class, Rnm, Alias, Pred, superclass). '$lgt_alias_pred'(Class, _, Alias, Pred, superclass) :- '$lgt_specializes_class_'(Class, Superclass, _), '$lgt_current_object_'(Superclass, _, _, _, _, _, _, _, _, Rnm, _), '$lgt_alias_pred'(Superclass, Rnm, Alias, Pred, superclass). '$lgt_alias_pred'(Obj, _, Alias, Pred, _) :- '$lgt_complemented_object_'(Obj, Ctg, _, _, Rnm), '$lgt_alias_pred'(Ctg, Rnm, Alias, Pred, _). % abolish/1 built-in method '$lgt_abolish'(Obj, Pred, Sender, _) :- var(Pred), throw(error(instantiation_error, Obj::abolish(Pred), Sender)). '$lgt_abolish'(Obj, Pred, Sender, _) :- Pred \= _/_, throw(error(type_error(predicate_indicator, Pred), Obj::abolish(predicate), Sender)). '$lgt_abolish'(Obj, Functor/Arity, Sender, _) :- (var(Functor); var(Arity)), throw(error(instantiation_error, Obj::abolish(Functor/Arity), Sender)). '$lgt_abolish'(Obj, Functor/Arity, Sender, _) :- \+ atom(Functor), throw(error(type_error(atom, Functor), Obj::abolish(Functor/Arity), Sender)). '$lgt_abolish'(Obj, Functor/Arity, Sender, _) :- \+ integer(Arity), throw(error(type_error(integer, Arity), Obj::abolish(Functor/Arity), Sender)). '$lgt_abolish'(Obj, Functor/Arity, Sender, _) :- integer(Arity), Arity < 0, throw(error(domain_error(not_less_than_zero, Arity), Obj::abolish(Functor/Arity), Sender)). '$lgt_abolish'(Obj, Functor/Arity, Sender, Scope) :- '$lgt_abolish_chk'(Obj, Functor/Arity, Sender, Scope). '$lgt_abolish_chk'(Obj, Functor/Arity, Sender, Scope) :- '$lgt_current_object_'(Obj, _, Dcl, _, _, _, _, DDcl, DDef, _, _), !, functor(Pred, Functor, Arity), ( call_with_args(Dcl, Pred, PScope, Compilation, _, _, _, SCtn, _) -> ( (\+ \+ PScope = Scope; Sender = SCtn) -> ( Compilation == (dynamic) -> ( call_with_args(DDcl, Pred, _) -> Clause =.. [DDcl, Pred, _], retractall(Clause), ( call_with_args(DDef, Pred, _, _, _, Call) -> functor(Call, CFunctor, CArity), abolish(CFunctor/CArity), Clause2 =.. [DDef, Pred, _, _, _, Call], retractall(Clause2), '$lgt_clean_lookup_caches'(Pred) ; true ) ; % no dynamic predicate declaration: ( call_with_args(Dcl, Pred, _, _, _, _, _) -> throw(error(permission_error(modify, predicate_declaration, Pred), Obj::abolish(Functor/Arity), Sender)) ; throw(error(existence_error(predicate_declaration, Pred), Obj::abolish(Functor/Arity), Sender)) ) ) ; % predicate is static: throw(error(permission_error(modify, static_predicate, Pred), Obj::abolish(Functor/Arity), Sender)) ) ; % predicate is not within the scope of the sender: ( PScope == p -> throw(error(permission_error(modify, private_predicate, Pred), Obj::abolish(Functor/Arity), Sender)) ; throw(error(permission_error(modify, protected_predicate, Pred), Obj::abolish(Functor/Arity), Sender)) ) ) ; % no predicate declaration: throw(error(existence_error(predicate_declaration, Pred), Obj::abolish(Functor/Arity), Sender)) ). '$lgt_abolish_chk'(Obj, Functor/Arity, Sender, _) :- throw(error(existence_error(object, Obj), Obj::abolish(Functor/Arity), Sender)). % asserta/1 built-in method '$lgt_asserta'(Obj, Clause, Sender, _, _) :- var(Clause), throw(error(instantiation_error, Obj::asserta(Clause), Sender)). '$lgt_asserta'(Obj, Clause, Sender, _, _) :- '$lgt_db_lookup_cache_'(Obj, Clause, Sender, Call, _), !, asserta(Call). '$lgt_asserta'(Obj, (Head:-Body), Sender, _, _) :- var(Head), throw(error(instantiation_error, Obj::asserta((Head:-Body)), Sender)). '$lgt_asserta'(Obj, (Head:-Body), Sender, _, _) :- \+ callable(Head), throw(error(type_error(callable, Head), Obj::asserta((Head:-Body)), Sender)). '$lgt_asserta'(Obj, (Head:-Body), Sender, _, _) :- nonvar(Body), \+ callable(Body), throw(error(type_error(callable, Body), Obj::asserta((Head:-Body)), Sender)). '$lgt_asserta'(Obj, Clause, Sender, _, _) :- Clause \= (_ :- _), \+ callable(Clause), throw(error(type_error(callable, Clause), Obj::asserta(Clause), Sender)). '$lgt_asserta'(Obj, Clause, Sender, TestScope, DclScope) :- ( Clause = (Head :- Body) -> ( Body == true -> '$lgt_asserta_fact_chk'(Obj, Head, Sender, TestScope, DclScope) ; '$lgt_asserta_rule_chk'(Obj, Clause, Sender, TestScope, DclScope) ) ; '$lgt_asserta_fact_chk'(Obj, Clause, Sender, TestScope, DclScope) ). '$lgt_asserta_rule_chk'(Obj, (Head:-Body), Sender, TestScope, DclScope) :- '$lgt_current_object_'(Obj, Prefix, Dcl, Def, _, _, _, DDcl, DDef, _, ObjType), !, '$lgt_assert_pred_dcl'(Dcl, DDcl, Head, Scope, PredType, Meta, SCtn, DclScope, Obj::asserta((Head:-Body)), Sender), ( (PredType == (dynamic); ObjType == (dynamic), Sender = SCtn) -> ( (\+ \+ Scope = TestScope; Sender = SCtn) -> '$lgt_assert_pred_def'(Obj, Def, DDef, Prefix, Head, GSender, GThis, GSelf, THead, _), '$lgt_pred_meta_vars'(Head, Meta, MetaVars), '$lgt_ctx_ctx'(Ctx, _, GSender, GThis, GSelf, Prefix, MetaVars, _), '$lgt_tr_body'(Body, TBody, DBody, Ctx), ( '$lgt_debugging_'(Obj) -> '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx), asserta((THead :- ('$lgt_nop'(Body), '$lgt_dbg_head'(Head, 0, DbgCtx), DBody))) ; asserta((THead :- ('$lgt_nop'(Body), TBody))) ) ; % predicate is not within the scope of the sender: ( Scope == p -> throw(error(permission_error(modify, private_predicate, Head), Obj::asserta((Head:-Body)), Sender)) ; throw(error(permission_error(modify, protected_predicate, Head), Obj::asserta((Head:-Body)), Sender)) ) ) ; % predicate is static: throw(error(permission_error(modify, static_predicate, Head), Obj::asserta((Head:-Body)), Sender)) ). '$lgt_asserta_rule_chk'(Obj, (Head:-Body), Sender, _, _) :- throw(error(existence_error(object, Obj), Obj::asserta((Head:-Body)), Sender)). '$lgt_asserta_fact_chk'(Obj, Head, Sender, _, _) :- '$lgt_db_lookup_cache_'(Obj, Head, Sender, THead, _), !, asserta(THead). '$lgt_asserta_fact_chk'(Obj, Head, Sender, TestScope, DclScope) :- '$lgt_current_object_'(Obj, Prefix, Dcl, Def, _, _, _, DDcl, DDef, _, ObjType), !, '$lgt_assert_pred_dcl'(Dcl, DDcl, Head, Scope, PredType, _, SCtn, DclScope, Obj::asserta(Head), Sender), ( (PredType == (dynamic); ObjType == (dynamic), Sender = SCtn) -> ( (\+ \+ Scope = TestScope; Sender = SCtn) -> '$lgt_assert_pred_def'(Obj, Def, DDef, Prefix, Head, GSender, GThis, GSelf, THead, Update), ( '$lgt_debugging_'(Obj) -> '$lgt_ctx_ctx'(Ctx, _, GSender, GThis, GSelf, Prefix, [], _), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx), asserta((THead :- '$lgt_dbg_fact'(Head, 0, DbgCtx))) ; '$lgt_add_db_lookup_cache_entry'(Obj, Head, SCtn, DclScope, PredType, Sender, THead, DDef, Update), asserta(THead) ) ; % predicate is not within the scope of the sender: ( Scope == p -> throw(error(permission_error(modify, private_predicate, Head), Obj::asserta(Head), Sender)) ; throw(error(permission_error(modify, protected_predicate, Head), Obj::asserta(Head), Sender)) ) ) ; % predicate is static: throw(error(permission_error(modify, static_predicate, Head), Obj::asserta(Head), Sender)) ). '$lgt_asserta_fact_chk'(Obj, Head, Sender, _, _) :- throw(error(existence_error(object, Obj), Obj::asserta(Head), Sender)). % assertz/1 built-in method '$lgt_assertz'(Obj, Clause, Sender, _, _) :- var(Clause), throw(error(instantiation_error, Obj::assertz(Clause), Sender)). '$lgt_assertz'(Obj, Clause, Sender, _, _) :- '$lgt_db_lookup_cache_'(Obj, Clause, Sender, Call, _), !, assertz(Call). '$lgt_assertz'(Obj, (Head:-Body), Sender, _, _) :- var(Head), throw(error(instantiation_error, Obj::assertz((Head:-Body)), Sender)). '$lgt_assertz'(Obj, (Head:-Body), Sender, _, _) :- \+ callable(Head), throw(error(type_error(callable, Head), Obj::assertz((Head:-Body)), Sender)). '$lgt_assertz'(Obj, (Head:-Body), Sender, _, _) :- nonvar(Body), \+ callable(Body), throw(error(type_error(callable, Body), Obj::assertz((Head:-Body)), Sender)). '$lgt_assertz'(Obj, Clause, Sender, _, _) :- Clause \= (_ :- _), \+ callable(Clause), throw(error(type_error(callable, Clause), Obj::assertz(Clause), Sender)). '$lgt_assertz'(Obj, Clause, Sender, TestScope, DclScope) :- ( Clause = (Head :- Body) -> ( Body == true -> '$lgt_assertz_fact_chk'(Obj, Head, Sender, TestScope, DclScope) ; '$lgt_assertz_rule_chk'(Obj, Clause, Sender, TestScope, DclScope) ) ; '$lgt_assertz_fact_chk'(Obj, Clause, Sender, TestScope, DclScope) ). '$lgt_assertz_rule_chk'(Obj, (Head:-Body), Sender, TestScope, DclScope) :- '$lgt_current_object_'(Obj, Prefix, Dcl, Def, _, _, _, DDcl, DDef, _, ObjType), !, '$lgt_assert_pred_dcl'(Dcl, DDcl, Head, Scope, PredType, Meta, SCtn, DclScope, Obj::assertz((Head:-Body)), Sender), ( (PredType == (dynamic); ObjType == (dynamic), Sender = SCtn) -> ( (\+ \+ Scope = TestScope; Sender = SCtn) -> '$lgt_assert_pred_def'(Obj, Def, DDef, Prefix, Head, GSender, GThis, GSelf, THead, _), '$lgt_pred_meta_vars'(Head, Meta, MetaVars), '$lgt_ctx_ctx'(Ctx, _, GSender, GThis, GSelf, Prefix, MetaVars, _), '$lgt_tr_body'(Body, TBody, DBody, Ctx), ( '$lgt_debugging_'(Obj) -> '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx), assertz((THead :- ('$lgt_nop'(Body), '$lgt_dbg_head'(Head, 0, DbgCtx), DBody))) ; assertz((THead :- ('$lgt_nop'(Body), TBody))) ) ; % predicate is not within the scope of the sender: ( Scope == p -> throw(error(permission_error(modify, private_predicate, Head), Obj::assertz((Head:-Body)), Sender)) ; throw(error(permission_error(modify, protected_predicate, Head), Obj::assertz((Head:-Body)), Sender)) ) ) ; % predicate is static: throw(error(permission_error(modify, static_predicate, Head), Obj::assertz((Head:-Body)), Sender)) ). '$lgt_assertz_rule_chk'(Obj, (Head:-Body), Sender, _, _) :- throw(error(existence_error(object, Obj), Obj::assertz((Head:-Body)), Sender)). '$lgt_assertz_fact_chk'(Obj, Head, Sender, _, _) :- '$lgt_db_lookup_cache_'(Obj, Head, Sender, THead, _), !, assertz(THead). '$lgt_assertz_fact_chk'(Obj, Head, Sender, TestScope, DclScope) :- '$lgt_current_object_'(Obj, Prefix, Dcl, Def, _, _, _, DDcl, DDef, _, ObjType), !, '$lgt_assert_pred_dcl'(Dcl, DDcl, Head, Scope, PredType, _, SCtn, DclScope, Obj::assertz(Head), Sender), ( (PredType == (dynamic); ObjType == (dynamic), Sender = SCtn) -> ( (\+ \+ Scope = TestScope; Sender = SCtn) -> '$lgt_assert_pred_def'(Obj, Def, DDef, Prefix, Head, GSender, GThis, GSelf, THead, Update), ( '$lgt_debugging_'(Obj) -> '$lgt_ctx_ctx'(Ctx, _, GSender, GThis, GSelf, Prefix, [], _), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx), assertz((THead :- '$lgt_dbg_fact'(Head, 0, DbgCtx))) ; '$lgt_add_db_lookup_cache_entry'(Obj, Head, SCtn, DclScope, PredType, Sender, THead, DDef, Update), assertz(THead) ) ; % predicate is not within the scope of the sender: ( Scope == p -> throw(error(permission_error(modify, private_predicate, Head), Obj::assertz(Head), Sender)) ; throw(error(permission_error(modify, protected_predicate, Head), Obj::assertz(Head), Sender)) ) ) ; % predicate is static: throw(error(permission_error(modify, static_predicate, Head), Obj::assertz(Head), Sender)) ). '$lgt_assertz_fact_chk'(Obj, Head, Sender, _, _) :- throw(error(existence_error(object, Obj), Obj::assertz(Head), Sender)). % get or set (if doesn't exist) the declaration for an asserted predicate '$lgt_assert_pred_dcl'(Dcl, DDcl, Pred, Scope, Type, Meta, SCtn, DclScope, Goal, Sender) :- ( call_with_args(Dcl, Pred, Scope, Type, Meta, _, _, SCtn, _) -> true ; % no previous predicate declaration: ( DDcl == nil -> % object doesn't supports dynamic declaration of new predicates: throw(error(permission_error(modify, object_protocol, Pred), Goal, Sender)) ; functor(Pred, Functor, Arity), functor(DPred, Functor, Arity), Clause =.. [DDcl, DPred, DclScope], assertz(Clause), (Scope, Type, Meta) = (DclScope, (dynamic), no) ) ). % get or set (if doesn't exist) the compiled call for an asserted predicate '$lgt_assert_pred_def'(Obj, Def, DDef, Prefix, Head, GSender, GThis, GSelf, Call, NeedsUpdate) :- ( % if a definition lookup entry alread exists on the object... call_with_args(Def, Head, GSender, GThis, GSelf, Call, Obj) -> ( % then check if it's a dynamic one that implies an update goal... call_with_args(DDef, Head, GSender, GThis, GSelf, Call) -> NeedsUpdate = true ; % or a static one... NeedsUpdate = false ) ; % else no definition lookup entry exists; construct and assert a dynamic one... functor(Head, Functor, Arity), functor(GHead, Functor, Arity), '$lgt_construct_predicate_functor'(Prefix, Functor, Arity, TFunctor), GHead =.. [_| GArgs], '$lgt_append'(GArgs, [GSender, GThis, GSelf], TArgs), THead =.. [TFunctor| TArgs], DDefClause =.. [DDef, GHead, GSender, GThis, GSelf, THead], assertz(DDefClause), '$lgt_clean_lookup_caches'(GHead), NeedsUpdate = true, (GHead, THead) = (Head, Call) ). % clause/2 built-in method '$lgt_clause'(Obj, Head, Body, Sender, _) :- var(Head), throw(error(instantiation_error, Obj::clause(Head, Body), Sender)). '$lgt_clause'(Obj, Head, Body, Sender, _) :- \+ callable(Head), throw(error(type_error(callable, Head), Obj::clause(Head, Body), Sender)). '$lgt_clause'(Obj, Head, Body, Sender, _) :- nonvar(Body), \+ callable(Body), throw(error(type_error(callable, Body), Obj::clause(Head, Body), Sender)). '$lgt_clause'(Obj, Head, Body, Sender, Scope) :- '$lgt_clause_chk'(Obj, Head, Body, Sender, Scope). '$lgt_clause_chk'(Obj, Head, Body, Sender, _) :- '$lgt_db_lookup_cache_'(Obj, Head, Sender, Call, _), !, clause(Call, TBody), ( TBody = ('$lgt_nop'(Body), _) -> % rules (compiled both in normal and debug mode) true ; TBody = '$lgt_dbg_fact'(_, _, _) -> % facts compiled in debug mode Body = true ; TBody = Body % facts compiled in normal mode ). '$lgt_clause_chk'(Obj, Head, Body, Sender, Scope) :- '$lgt_current_object_'(Obj, _, Dcl, Def, _, _, _, _, DDef, _, ObjType), !, ( call_with_args(Dcl, Head, PScope, PredType, _, _, _, SCtn, _) -> ( (PredType == (dynamic); ObjType == (dynamic), Sender = SCtn) -> ( (\+ \+ PScope = Scope; Sender = SCtn) -> ( (call_with_args(DDef, Head, _, _, _, Call); call_with_args(Def, Head, _, _, _, Call)) -> clause(Call, TBody), ( TBody = ('$lgt_nop'(Body), _) -> true ; TBody = '$lgt_dbg_fact'(_, _, _) -> Body = true ; TBody = Body ) ) ; % predicate is not within the scope of the sender: ( PScope == p -> throw(error(permission_error(access, private_predicate, Head), Obj::clause(Head, Body), Sender)) ; throw(error(permission_error(access, protected_predicate, Head), Obj::clause(Head, Body), Sender)) ) ) ; % predicate is static: throw(error(permission_error(access, static_predicate, Head), Obj::clause(Head, Body), Sender)) ) ; % local dynamic predicate with no scope declaration: ( (Obj = Sender, call_with_args(DDef, Head, _, _, _, Call)) -> clause(Call, TBody), ( TBody = ('$lgt_nop'(Body), _) -> true ; TBody = '$lgt_dbg_fact'(_, _, _) -> Body = true ; TBody = Body ) ; throw(error(existence_error(predicate_declaration, Head), Obj::clause(Head, Body), Sender)) ) ). '$lgt_clause_chk'(Obj, Head, Body, Sender, _) :- throw(error(existence_error(object, Obj), Obj::clause(Head, Body), Sender)). % retract/1 built-in method '$lgt_retract'(Obj, Clause, Sender, _) :- var(Clause), throw(error(instantiation_error, Obj::retract(Clause), Sender)). '$lgt_retract'(Obj, (Head:-Body), Sender, _) :- var(Head), throw(error(instantiation_error, Obj::retract((Head:-Body)), Sender)). '$lgt_retract'(Obj, (Head:-Body), Sender, _) :- \+ callable(Head), throw(error(type_error(callable, Head), Obj::retract((Head:-Body)), Sender)). '$lgt_retract'(Obj, (Head:-Body), Sender, _) :- nonvar(Body), \+ callable(Body), throw(error(type_error(callable, Body), Obj::retract((Head:-Body)), Sender)). '$lgt_retract'(Obj, Clause, Sender, Scope) :- ( Clause = (Head :- Body) -> ( var(Body) -> '$lgt_retract_var_body_chk'(Obj, Clause, Sender, Scope) ; Body == true -> '$lgt_retract_fact_chk'(Obj, Head, Sender, Scope) ; '$lgt_retract_rule_chk'(Obj, Clause, Sender, Scope) ) ; '$lgt_retract_fact_chk'(Obj, Clause, Sender, Scope) ). '$lgt_retract_var_body_chk'(Obj, (Head:-Body), Sender, Scope) :- '$lgt_current_object_'(Obj, _, Dcl, Def, _, _, _, _, DDef, _, ObjType), !, ( call_with_args(Dcl, Head, PScope, PredType, _, _, _, SCtn, _) -> ( (PredType == (dynamic); ObjType == (dynamic), Sender = SCtn) -> ( (\+ \+ PScope = Scope; Sender = SCtn) -> ( call_with_args(DDef, Head, _, _, _, Call) -> retract((Call :- TBody)), ( TBody = ('$lgt_nop'(Body), _) -> true ; TBody = '$lgt_dbg_fact'(_, _, _) -> Body = true ; TBody = Body ), '$lgt_update_ddef_table'(DDef, Head, Call) ; call_with_args(Def, Head, _, _, _, Call) -> retract((Call :- TBody)), ( TBody = ('$lgt_nop'(Body), _) -> true ; TBody = '$lgt_dbg_fact'(_, _, _) -> Body = true ; TBody = Body ) ) ; % predicate is not within the scope of the sender: ( PScope == p -> throw(error(permission_error(modify, private_predicate, Head), Obj::retract((Head:-Body)), Sender)) ; throw(error(permission_error(modify, protected_predicate, Head), Obj::retract((Head:-Body)), Sender)) ) ) ; % predicate is static: throw(error(permission_error(modify, static_predicate, Head), Obj::retract((Head:-Body)), Sender)) ) ; % local dynamic predicate with no scope declaration: ( Obj = Sender, call_with_args(DDef, Head, _, _, _, Call) -> retract((Call :- TBody)), ( TBody = ('$lgt_nop'(Body), _) -> true ; TBody = '$lgt_dbg_fact'(_, _, _) -> Body = true ; TBody = Body ) ; throw(error(existence_error(predicate_declaration, Head), Obj::retract((Head:-Body)), Sender)) ) ). '$lgt_retract_var_body_chk'(Obj, (Head:-Body), Sender, _) :- throw(error(existence_error(object, Obj), Obj::retract((Head:-Body)), Sender)). '$lgt_retract_rule_chk'(Obj, (Head:-Body), Sender, Scope) :- '$lgt_current_object_'(Obj, _, Dcl, Def, _, _, _, _, DDef, _, ObjType), !, ( call_with_args(Dcl, Head, PScope, PredType, _, _, _, SCtn, _) -> ( (PredType == (dynamic); ObjType == (dynamic), Sender = SCtn) -> ( (\+ \+ PScope = Scope; Sender = SCtn) -> ( call_with_args(DDef, Head, _, _, _, Call) -> retract((Call :- ('$lgt_nop'(Body), _))), '$lgt_update_ddef_table'(DDef, Head, Call) ; call_with_args(Def, Head, _, _, _, Call) -> retract((Call :- ('$lgt_nop'(Body), _))) ) ; % predicate is not within the scope of the sender: ( PScope == p -> throw(error(permission_error(modify, private_predicate, Head), Obj::retract((Head:-Body)), Sender)) ; throw(error(permission_error(modify, protected_predicate, Head), Obj::retract((Head:-Body)), Sender)) ) ) ; % predicate is static: throw(error(permission_error(modify, static_predicate, Head), Obj::retract((Head:-Body)), Sender)) ) ; % local dynamic predicate with no scope declaration: ( Obj = Sender, call_with_args(DDef, Head, _, _, _, Call) -> retract((Call :- ('$lgt_nop'(Body), _))) ; throw(error(existence_error(predicate_declaration, Head), Obj::retract((Head:-Body)), Sender)) ) ). '$lgt_retract_rule_chk'(Obj, (Head:-Body), Sender, _) :- throw(error(existence_error(object, Obj), Obj::retract((Head:-Body)), Sender)). '$lgt_retract_fact_chk'(Obj, Head, Sender, _) :- '$lgt_db_lookup_cache_'(Obj, Head, Sender, Call, Update), !, retract(Call), once(Update). '$lgt_retract_fact_chk'(Obj, Head, Sender, Scope) :- '$lgt_current_object_'(Obj, _, Dcl, Def, _, _, _, _, DDef, _, ObjType), !, ( call_with_args(Dcl, Head, PScope, PredType, _, _, _, SCtn, _) -> ( (PredType == (dynamic); ObjType == (dynamic), Sender = SCtn) -> ( (\+ \+ PScope = Scope; Sender = SCtn) -> ( call_with_args(DDef, Head, _, _, _, Call) -> ( '$lgt_debugging_'(Obj) -> retract((Call :- '$lgt_dbg_fact'(_, _, _))) ; '$lgt_add_db_lookup_cache_entry'(Obj, Head, SCtn, PScope, PredType, Sender, Call, DDef, true), retract(Call) ), '$lgt_update_ddef_table'(DDef, Head, Call) ; call_with_args(Def, Head, _, _, _, Call) -> ( '$lgt_debugging_'(Obj) -> retract((Call :- '$lgt_dbg_fact'(_, _, _))) ; '$lgt_add_db_lookup_cache_entry'(Obj, Head, PScope, PredType, Sender, Call), retract(Call) ) ) ; % predicate is not within the scope of the sender: ( PScope == p -> throw(error(permission_error(modify, private_predicate, Head), Obj::retract(Head), Sender)) ; throw(error(permission_error(modify, protected_predicate, Head), Obj::retract(Head), Sender)) ) ) ; % predicate is static: throw(error(permission_error(modify, static_predicate, Head), Obj::retract(Head), Sender)) ) ; % local dynamic predicate with no scope declaration: ( call_with_args(DDef, Head, _, _, _, Call) -> ( '$lgt_debugging_'(Obj) -> retract((Call :- '$lgt_dbg_fact'(_, _, _))) ; '$lgt_add_db_lookup_cache_entry'(Obj, Head, p, (dynamic), Sender, Call), retract(Call) ) ; throw(error(existence_error(predicate_declaration, Head), Obj::retract(Head), Sender)) ) ). '$lgt_retract_fact_chk'(Obj, Head, Sender, _) :- throw(error(existence_error(object, Obj), Obj::retract(Head), Sender)). % retractall/1 built-in method '$lgt_retractall'(Obj, Head, Sender, _) :- var(Head), throw(error(instantiation_error, Obj::retractall(Head), Sender)). '$lgt_retractall'(Obj, Head, Sender, _) :- \+ callable(Head), throw(error(type_error(callable, Head), Obj::retractall(Head), Sender)). '$lgt_retractall'(Obj, Head, Sender, Scope) :- '$lgt_retractall_chk'(Obj, Head, Sender, Scope). '$lgt_retractall_chk'(Obj, Head, Sender, _) :- '$lgt_db_lookup_cache_'(Obj, Head, Sender, Call, Update), !, retractall(Call), once(Update). '$lgt_retractall_chk'(Obj, Head, Sender, Scope) :- '$lgt_current_object_'(Obj, _, Dcl, Def, _, _, _, _, DDef, _, ObjType), !, ( call_with_args(Dcl, Head, PScope, PredType, _, _, _, SCtn, _) -> ( (PredType == (dynamic); ObjType == (dynamic), Sender = SCtn) -> ( (\+ \+ PScope = Scope; Sender = SCtn) -> ( call_with_args(DDef, Head, _, _, _, Call) -> retractall(Call), '$lgt_update_ddef_table'(DDef, Head, Call) ; call_with_args(Def, Head, _, _, _, Call) -> ( '$lgt_debugging_'(Obj) -> true ; '$lgt_add_db_lookup_cache_entry'(Obj, Head, PScope, PredType, Sender, Call) ), retractall(Call) ; true ) ; % predicate is not within the scope of the sender: ( PScope == p -> throw(error(permission_error(modify, private_predicate, Head), Obj::retractall(Head), Sender)) ; throw(error(permission_error(modify, protected_predicate, Head), Obj::retractall(Head), Sender)) ) ) ; % predicate is static: throw(error(permission_error(modify, static_predicate, Head), Obj::retractall(Head), Sender)) ) ; % local dynamic predicate with no scope declaration: ( Obj = Sender, call_with_args(DDef, Head, _, _, _, Call) -> ( '$lgt_debugging_'(Obj) -> true ; '$lgt_add_db_lookup_cache_entry'(Obj, Head, p, (dynamic), Sender, Call) ), retractall(Call) ; throw(error(existence_error(predicate_declaration, Head), Obj::retractall(Head), Sender)) ) ). '$lgt_retractall_chk'(Obj, Head, Sender, _) :- throw(error(existence_error(object, Obj), Obj::retractall(Head), Sender)). % '$lgt_nop'(+goal) % % used in the implementation of the built-in method % clause/2 to store the original clause body '$lgt_nop'(_). % '$lgt_add_db_lookup_cache_entry'(@object_identifier, @callable, @callable, +atom, @object_identifier, @callable) % % adds a new database lookup cache entry (when an update goal is not needed) '$lgt_add_db_lookup_cache_entry'(Obj, Head, Scope, Type, Sender, Call) :- functor(Obj, OFunctor, OArity), functor(GObj, OFunctor, OArity), functor(Head, HFunctor, HArity), functor(GHead, HFunctor, HArity), functor(Call, CFunctor, CArity), functor(GCall, CFunctor, CArity), GHead =.. [_| Args], GCall =.. [_| ExtArgs], '$lgt_unify_args'(Args, ExtArgs), ( (Scope = p(p(p)), Type == (dynamic)) -> asserta('$lgt_db_lookup_cache_'(GObj, GHead, _, GCall, true)) ; functor(Sender, SFunctor, SArity), functor(GSender, SFunctor, SArity), asserta('$lgt_db_lookup_cache_'(GObj, GHead, GSender, GCall, true)) ). % '$lgt_add_db_lookup_cache_entry'(@object_identifier, @callable, @callable, @callable, +atom, @object_identifier, @callable, +atom, +atom) % % adds a new database lookup cache entry '$lgt_add_db_lookup_cache_entry'(Obj, Head, SCtn, Scope, Type, Sender, Call, DDef, NeedsUpdate) :- functor(Obj, OFunctor, OArity), functor(GObj, OFunctor, OArity), functor(Head, HFunctor, HArity), functor(GHead, HFunctor, HArity), functor(Call, CFunctor, CArity), functor(GCall, CFunctor, CArity), GHead =.. [_| Args], GCall =.. [_| ExtArgs], '$lgt_unify_args'(Args, ExtArgs), ( NeedsUpdate == true, Sender \= SCtn -> functor(UHead, HFunctor, HArity), functor(UCall, CFunctor, CArity), UClause =.. [DDef, UHead, _, _, _, _], ( (Scope = p(p(p)), Type == (dynamic)) -> asserta('$lgt_db_lookup_cache_'(GObj, GHead, _, GCall, '$lgt_update_ddef_table_opt'(UHead, UCall, UClause))) ; functor(Sender, SFunctor, SArity), functor(GSender, SFunctor, SArity), asserta('$lgt_db_lookup_cache_'(GObj, GHead, GSender, GCall, '$lgt_update_ddef_table_opt'(UHead, UCall, UClause))) ) ; ( (Scope = p(p(p)), Type == (dynamic)) -> asserta('$lgt_db_lookup_cache_'(GObj, GHead, _, GCall, true)) ; functor(Sender, SFunctor, SArity), functor(GSender, SFunctor, SArity), asserta('$lgt_db_lookup_cache_'(GObj, GHead, GSender, GCall, true)) ) ). '$lgt_unify_args'([], _). '$lgt_unify_args'([Arg| Args], [Arg| ExtArgs]) :- '$lgt_unify_args'(Args, ExtArgs). % '$lgt_phrase'(+object_identifier, +grbody, ?list, +object_identifier, +scope) % % phrase/2 built-in method '$lgt_phrase'(Obj, GRBody, Input, Sender, Scope) :- catch( '$lgt_phrase'(Obj, GRBody, Input, [], Sender, Scope), error(Error, _), throw(error(Error, Obj::phrase(GRBody, Input), Sender))). % '$lgt_phrase'(+object_identifier, +grbody, +list, ?list, +object_identifier, +scope) % % phrase/3 built-in method '$lgt_phrase'(Obj, GRBody, Input, Rest, Sender, _) :- var(GRBody), throw(error(instantiation_error, Obj::phrase(GRBody, Input, Rest), Sender)). '$lgt_phrase'(Obj, GRBody, Input, Rest, Sender, _) :- \+ callable(GRBody), throw(error(type_error(callable, GRBody), Obj::phrase(GRBody, Input, Rest), Sender)). '$lgt_phrase'(Obj, GRBody, Input, Rest, Sender, _) :- nonvar(Input), \+ '$lgt_is_list'(Input), throw(error(type_error(list, Input), Obj::phrase(GRBody, Input, Rest), Sender)). '$lgt_phrase'(Obj, GRBody, Input, Rest, Sender, _) :- nonvar(Rest), \+ '$lgt_is_list'(Rest), throw(error(type_error(list, Rest), Obj::phrase(GRBody, Input, Rest), Sender)). '$lgt_phrase'(Obj, (GRFirst, GRSecond), Input, Rest, Sender, Scope) :- !, '$lgt_phrase'(Obj, GRFirst, Input, Rest1, Sender, Scope), '$lgt_phrase'(Obj, GRSecond, Rest1, Rest, Sender, Scope). '$lgt_phrase'(Obj, (GREither; GROr), Input, Rest, Sender, Scope) :- !, ( '$lgt_phrase'(Obj, GREither, Input, Rest, Sender, Scope) ; '$lgt_phrase'(Obj, GROr, Input, Rest, Sender, Scope) ). '$lgt_phrase'(Obj, (GRIf -> GRThen), Input, Rest, Sender, Scope) :- !, '$lgt_phrase'(Obj, GRIf, Input, Rest1, Sender, Scope), '$lgt_phrase'(Obj, GRThen, Rest1, Rest, Sender, Scope). '$lgt_phrase'(Obj, \+ GRBody, Input, Rest, Sender, Scope) :- !, \+ '$lgt_phrase'(Obj, GRBody, Input, Rest, Sender, Scope), Input = Rest. '$lgt_phrase'(_, [], Input, Rest, _, _) :- !, Input = Rest. '$lgt_phrase'(_, [Head| Tail], Input, Rest, _, _) :- !, '$lgt_append'([Head| Tail], Rest, Input). '$lgt_phrase'(Obj, NonTerminal, Input, Rest, Sender, Scope) :- NonTerminal =.. [Functor| Args], '$lgt_append'(Args, [Input, Rest], Args2), Pred =.. [Functor| Args2], ( '$lgt_current_object_'(Obj, _, Dcl, Def, _, _, _, _, DDef, _, _) -> ( call_with_args(Dcl, Pred, PScope, _, _, _, _, SCtn, _) -> ( (\+ \+ PScope = Scope; Sender = SCtn) -> call_with_args(Def, Pred, Sender, Obj, Obj, Call, _) -> call(Call) ; % non-terminal is not within the scope of the sender: ( PScope == p -> throw(error(permission_error(access, private_non_terminal, NonTerminal), Obj::phrase(NonTerminal, Input, Rest), Sender)) ; throw(error(permission_error(access, protected_non_terminal, NonTerminal), Obj::phrase(NonTerminal, Input, Rest), Sender)) ) ) ; % no declaration found for non-terninal: Obj = Sender, ( call_with_args(Def, Pred, Obj, Obj, Obj, Call) ; call_with_args(DDef, Pred, Obj, Obj, Obj, Call) ) -> call(Call) ; throw(error(existence_error(non_terminal_declaration, NonTerminal), Obj::phrase(NonTerminal, Input, Rest), Sender)) ) ; % not a current object: ( catch(current_module(Obj), _, fail) -> ':'(Obj, Pred) ; throw(error(existence_error(object, Obj), Obj::phrase(NonTerminal, Input, Rest), Sender)) ) ). % '$lgt_expand_term'(+object_identifier, ?term, ?term, +object_identifier, @scope) % % expand_term/2 built-in method '$lgt_expand_term'(Obj, Term, Expansion, Sender, Scope) :- ( var(Term) -> Expansion = Term ; '$lgt_term_expansion'(Obj, Term, Expand, Sender, Scope) -> Expansion = Expand ; Term = (_ --> _) -> '$lgt_dcgrule_to_clause'(Term, Clause), Expansion = Clause ; Expansion = Term ). % '$lgt_term_expansion'(+object_identifier, ?term, ?term, +object_identifier, @scope) % % calls the term_expansion/2 user-defined predicate % % if there is a scope directive, then the call fails if the sender is not within scope; % when there is no scope directive, then we call any local definition when the sender % and the target object are the same '$lgt_term_expansion'(Obj, Term, Expansion, Sender, Scope) :- '$lgt_current_object_'(Obj, _, Dcl, Def, _, _, _, _, DDef, _, _), ( ( call_with_args(Dcl, term_expansion(_, _), PScope, _, _, _, _, SCtn, _) -> ( (\+ \+ PScope = Scope; Sender = SCtn) -> call_with_args(Def, term_expansion(Term, Expansion), Sender, Obj, Obj, Call, _) ) ) ; Obj = Sender, ( call_with_args(Def, term_expansion(Term, Expansion), Obj, Obj, Obj, Call) -> true ; call_with_args(DDef, term_expansion(Term, Expansion), Obj, Obj, Obj, Call) ) ), !, once(Call). % '$lgt_expand_goal'(+object_identifier, ?term, ?term, +object_identifier, @scope) % % expand_goal/2 built-in method '$lgt_expand_goal'(Obj, Goal, EGoal, Sender, Scope) :- ( var(Goal) -> EGoal = Goal ; '$lgt_goal_expansion'(Obj, Goal, Expanded, Sender, Scope) -> '$lgt_expand_goal'(Obj, Expanded, EGoal, Sender, Scope) ; EGoal = Goal ). % '$lgt_goal_expansion'(+object_identifier, ?term, ?term, +object_identifier, @scope) % % calls the goal_expansion/2 user-defined predicate % % if there is a scope directive, then the call fails if the sender is not within scope; % when there is no scope directive, then we call any local definition when the sender % and the target object are the same '$lgt_goal_expansion'(Obj, Goal, Expansion, Sender, Scope) :- '$lgt_current_object_'(Obj, _, Dcl, Def, _, _, _, _, DDef, _, _), ( ( call_with_args(Dcl, goal_expansion(_, _), PScope, _, _, _, _, SCtn, _) -> ( (\+ \+ PScope = Scope; Sender = SCtn) -> call_with_args(Def, goal_expansion(Goal, Expansion), Sender, Obj, Obj, Call, _) ) ) ; Obj = Sender, ( call_with_args(Def, goal_expansion(Goal, Expansion), Obj, Obj, Obj, Call) -> true ; call_with_args(DDef, goal_expansion(Goal, Expansion), Obj, Obj, Obj, Call) ) ), !, once(Call). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % message sending % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % '$lgt_send_to_self'(+object_identifier, ?term, +object_identifier) '$lgt_send_to_self'(Obj, Pred, Sender) :- var(Pred), throw(error(instantiation_error, Obj::Pred, Sender)). '$lgt_send_to_self'(Obj, Pred, Sender) :- '$lgt_send_to_self_nv'(Obj, Pred, Sender). % '$lgt_send_to_self_nv'(+object_identifier, +term, +object_identifier) '$lgt_send_to_self_nv'(Obj, Pred, Sender) :- '$lgt_self_lookup_cache_'(Obj, Pred, Sender, Call), !, call(Call). '$lgt_send_to_self_nv'(Obj, Pred, Sender) :- '$lgt_current_object_'(Obj, _, Dcl, Def, _, _, _, _, _, _, _), !, ( call_with_args(Dcl, Pred, Scope, _, _, _, _, SCtn, _) -> % lookup declaration ( (Scope = p(_); Sender = SCtn) -> % check scope functor(Pred, PFunctor, PArity), functor(GPred, PFunctor, PArity), % construct predicate template functor(Obj, OFunctor, OArity), functor(GObj, OFunctor, OArity), % construct object template functor(Sender, SFunctor, SArity), functor(GSender, SFunctor, SArity), % construct "sender" template ( call_with_args(Def, GPred, GSender, GObj, GObj, GCall, _) -> % lookup definition asserta('$lgt_self_lookup_cache_'(GObj, GPred, GSender, GCall)), % cache lookup result (GObj, GPred, GSender) = (Obj, Pred, Sender), % unify message arguments call(GCall) ) ; % message is not within the scope of the sender: throw(error(permission_error(access, private_predicate, Pred), Obj::Pred, Sender)) ) ; % no predicate declaration, check if it's a built-in predicate: ( '$lgt_built_in'(Pred) -> call(Pred) ; throw(error(existence_error(predicate_declaration, Pred), Obj::Pred, Sender)) ) ). % '$lgt_send_to_object'(@object_identifier, ?term, +object_identifier) '$lgt_send_to_object'(Obj, Pred, Sender) :- var(Obj), throw(error(instantiation_error, Obj::Pred, Sender)). '$lgt_send_to_object'(Obj, Pred, Sender) :- var(Pred), throw(error(instantiation_error, Obj::Pred, Sender)). '$lgt_send_to_object'(Obj, Pred, Sender) :- '$lgt_send_to_object_nv'(Obj, Pred, Sender). % '$lgt_send_to_object_nv'(+object_identifier, +term, +object_identifier) '$lgt_send_to_object_nv'(Obj, Pred, Sender) :- '$lgt_obj_lookup_cache_'(Obj, Pred, Sender, Call), !, \+ ('$lgt_before_'(Obj, Pred, Sender, _, BCall), \+ call(BCall)), % call before event handlers call(Call), % call method \+ ('$lgt_after_'(Obj, Pred, Sender, _, ACall), \+ call(ACall)). % call after event handlers '$lgt_send_to_object_nv'(Obj, Pred, Sender) :- '$lgt_current_object_'(Obj, _, Dcl, Def, _, _, _, _, _, _, _), !, ( call_with_args(Dcl, Pred, Scope, _, _, _, _, SCtn, _) -> % lookup declaration ( (Scope = p(p(_)); Sender = SCtn) -> % check scope functor(Pred, PFunctor, PArity), functor(GPred, PFunctor, PArity), % construct predicate template functor(Obj, OFunctor, OArity), functor(GObj, OFunctor, OArity), % construct object template ( call_with_args(Def, GPred, GSender, GObj, GObj, GCall, _) -> % lookup definition asserta('$lgt_obj_lookup_cache_'(GObj, GPred, GSender, GCall)), % cache lookup result (GObj, GPred, GSender) = (Obj, Pred, Sender), % unify message arguments \+ ('$lgt_before_'(Obj, Pred, Sender, _, BCall), \+ call(BCall)), % call before event handlers call(GCall), % call method \+ ('$lgt_after_'(Obj, Pred, Sender, _, ACall), \+ call(ACall)) % call after event handlers ) ; % message is not within the scope of the sender: ( Scope == p -> throw(error(permission_error(access, private_predicate, Pred), Obj::Pred, Sender)) ; throw(error(permission_error(access, protected_predicate, Pred), Obj::Pred, Sender)) ) ) ; % no predicate declaration, check if it's a built-in predicate: ( '$lgt_built_in'(Pred) -> call(Pred) ; throw(error(existence_error(predicate_declaration, Pred), Obj::Pred, Sender)) ) ). '$lgt_send_to_object_nv'(Obj, Pred, _) :- % allow Obj::Pred to be used as a shortcut catch(current_module(Obj), _, fail), % for calling module predicates !, ':'(Obj, Pred). '$lgt_send_to_object_nv'(Obj, Pred, Sender) :- throw(error(existence_error(object, Obj), Obj::Pred, Sender)). % '$lgt_send_to_object_ne'(@object_identifier, ?term, +object_identifier) '$lgt_send_to_object_ne'(Obj, Pred, Sender) :- var(Obj), throw(error(instantiation_error, Obj::Pred, Sender)). '$lgt_send_to_object_ne'(Obj, Pred, Sender) :- var(Pred), throw(error(instantiation_error, Obj::Pred, Sender)). '$lgt_send_to_object_ne'(Obj, Pred, Sender) :- '$lgt_send_to_object_ne_nv'(Obj, Pred, Sender). % '$lgt_send_to_object_ne_nv'(+object_identifier, +term, +object_identifier) '$lgt_send_to_object_ne_nv'(Obj, Pred, Sender) :- '$lgt_obj_lookup_cache_'(Obj, Pred, Sender, Call), !, call(Call). '$lgt_send_to_object_ne_nv'(Obj, Pred, Sender) :- '$lgt_current_object_'(Obj, _, Dcl, Def, _, _, _, _, _, _, _), !, ( call_with_args(Dcl, Pred, Scope, _, _, _, _, SCtn, _) -> % lookup declaration ( (Scope = p(p(_)); Sender = SCtn) -> % check scope functor(Pred, PFunctor, PArity), functor(GPred, PFunctor, PArity), % construct predicate template functor(Obj, OFunctor, OArity), functor(GObj, OFunctor, OArity), % construct object template ( call_with_args(Def, GPred, GSender, GObj, GObj, GCall, _) -> % lookup definition asserta('$lgt_obj_lookup_cache_'(GObj, GPred, GSender, GCall)), % cache lookup result (GObj, GPred, GSender) = (Obj, Pred, Sender), % unify message arguments call(GCall) % call method ) ; % message is not within the scope of the sender: ( Scope == p -> throw(error(permission_error(access, private_predicate, Pred), Obj::Pred, Sender)) ; throw(error(permission_error(access, protected_predicate, Pred), Obj::Pred, Sender)) ) ) ; % no predicate declaration, check if it's a built-in predicate: ( '$lgt_built_in'(Pred) -> call(Pred) ; throw(error(existence_error(predicate_declaration, Pred), Obj::Pred, Sender))) ). '$lgt_send_to_object_ne_nv'(Obj, Pred, _) :- % allow Obj::Pred to be used as a shortcut catch(current_module(Obj), _, fail), % for calling module predicates !, ':'(Obj, Pred). '$lgt_send_to_object_ne_nv'(Obj, Pred, Sender) :- throw(error(existence_error(object, Obj), Obj::Pred, Sender)). % '$lgt_obj_super_call'(+atom, +callable, +object_identifier, +object_identifier, +object_identifier) '$lgt_obj_super_call'(_, Pred, Sender, This, Self) :- '$lgt_super_lookup_cache_'(Self, Pred, This, Sender, Call), !, call(Call). '$lgt_obj_super_call'(Super, Pred, Sender, This, Self) :- functor(Pred, PFunctor, PArity), functor(GPred, PFunctor, PArity), % construct predicate template functor(This, TFunctor, TArity), functor(GThis, TFunctor, TArity), % construct "this" template functor(Self, SFunctor, SArity), functor(GSelf, SFunctor, SArity), % construct "self" template call_with_args(Super, GPred, GSender, GThis, GSelf, GCall, Ctn), Ctn \= GThis -> % lookup definition asserta('$lgt_super_lookup_cache_'(GSelf, GPred, GThis, GSender, GCall)), % cache lookup result (GSelf, GPred, GThis, GSender) = (Self, Pred, This, Sender), % unify message arguments call(GCall). % call inherited definition % '$lgt_ctg_super_call'(+category_identifier, +atom, +callable, +object_identifier, +object_identifier, +object_identifier) '$lgt_ctg_super_call'(Ctg, _, Pred, Sender, This, Self) :- '$lgt_super_lookup_cache_'(Ctg, Pred, Sender, This, Self, Call), !, call(Call). '$lgt_ctg_super_call'(Ctg, Def, Pred, Sender, This, Self) :- functor(Pred, PFunctor, PArity), functor(GPred, PFunctor, PArity), % construct predicate template functor(This, TFunctor, TArity), functor(GThis, TFunctor, TArity), % construct "this" template functor(Self, SFunctor, SArity), functor(GSelf, SFunctor, SArity), % construct "self" template call_with_args(Def, GPred, GSender, GThis, GSelf, GCall, Ctn), Ctn \= Ctg -> % lookup definition asserta('$lgt_super_lookup_cache_'(Ctg, GPred, GSender, GThis, GSelf, GCall)), % cache lookup result (GPred, GSender, GThis, GSelf) = (Pred, Sender, This, Self), % unify message arguments call(GCall). % call inherited definition %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % meta-calls % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % '$lgt_metacall_in_object'(?term, ?term, ?term, +object_identifier, +object_identifier, +object_identifier) % % performs a meta-call constructed from a closure and a list of addtional arguments '$lgt_metacall_in_object'(Closure, Args, MetaCallCtx, Sender, This, _) :- var(Closure), Goal =.. [call, Closure| Args], ( atom(MetaCallCtx) -> throw(error(instantiation_error, This::Goal, This)) ; throw(error(instantiation_error, Sender::Goal, This)) ). '$lgt_metacall_in_object'(Closure, Args, MetaCallCtx, Sender, This, _) :- \+ callable(Closure), Goal =.. [call, Closure| Args], ( atom(MetaCallCtx) -> throw(error(type_error(callable, Closure), This::Goal, This)) ; throw(error(type_error(callable, Closure), Sender::Goal, This)) ). '$lgt_metacall_in_object'(Closure, ExtraArgs, local, Sender, This, Self) :- !, Closure =.. [Functor| Args], '$lgt_append'(Args, ExtraArgs, FullArgs), Pred =.. [Functor| FullArgs], '$lgt_metacall_in_object'(Pred, local, Sender, This, Self). '$lgt_metacall_in_object'(Obj::Closure, ExtraArgs, _, _, This, _) :- !, Closure =.. [Functor| Args], '$lgt_append'(Args, ExtraArgs, FullArgs), Pred =.. [Functor| FullArgs], '$lgt_tr_msg'(Pred, Obj, Call, This), ( '$lgt_dbg_debugging_', '$lgt_debugging_'(Obj) -> '$lgt_ctx_ctx'(Ctx, _, This, This, Obj, _, [], _), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx), '$lgt_dbg_goal'(Obj::Pred, Call, DbgCtx) ; call(Call) ). '$lgt_metacall_in_object'(':'(Module, Closure), ExtraArgs, _, _, _, _) :- !, Closure =.. [Functor| Args], '$lgt_append'(Args, ExtraArgs, FullArgs), Pred =.. [Functor| FullArgs], ':'(Module, Pred). '$lgt_metacall_in_object'(Closure, ExtraArgs, MetaVars, Sender, This, Self) :- Closure =.. [Functor| Args], '$lgt_append'(Args, ExtraArgs, FullArgs), Pred =.. [Functor| FullArgs], ( \+ '$lgt_member'(Closure, MetaVars) -> '$lgt_metacall_in_object'(Pred, local, Sender, This, Self) ; '$lgt_metacall_in_object'(Pred, [Pred], Sender, This, Self) ). % '$lgt_metacall_in_object'(?term, ?term, +object_identifier, +object_identifier, +object_identifier) % % performs a meta-call at runtime '$lgt_metacall_in_object'(Pred, MetaCallCtx, Sender, This, _) :- var(Pred), ( atom(MetaCallCtx) -> throw(error(instantiation_error, This::call(Pred), This)) ; throw(error(instantiation_error, Sender::call(Pred), This)) ). '$lgt_metacall_in_object'(Pred, compiled, _, _, _) :- !, call(Pred). '$lgt_metacall_in_object'(Pred, local, Sender, This, Self) :- !, '$lgt_current_object_'(This, Prefix, _, _, _, _, _, _, _, _, _), '$lgt_ctx_ctx'(Ctx, _, Sender, This, Self, Prefix, [], _), '$lgt_tr_body'(Pred, Call, DCall, Ctx), !, ( '$lgt_dbg_debugging_', '$lgt_debugging_'(Sender) -> call(DCall) ; call(Call) ). '$lgt_metacall_in_object'(Pred, MetaVars, Sender, This, Self) :- ( \+ '$lgt_member'(Pred, MetaVars) -> '$lgt_current_object_'(This, Prefix, _, _, _, _, _, _, _, _, _), '$lgt_ctx_ctx'(Ctx, _, Sender, This, Self, Prefix, [], _) ; '$lgt_current_object_'(Sender, Prefix, _, _, _, _, _, _, _, _, _), '$lgt_ctx_ctx'(Ctx, _, Sender, Sender, Self, Prefix, [], _) ), '$lgt_tr_body'(Pred, Call, DCall, Ctx), !, ( '$lgt_dbg_debugging_', '$lgt_debugging_'(Sender) -> call(DCall) ; call(Call) ). % '$lgt_call_built_in'(+term, +term) % % needed for runtime translation of dynamic clauses '$lgt_call_built_in'(Pred, Ctx) :- '$lgt_ctx_ctx'(Ctx, _, Sender, This, Self, _, _, _), '$lgt_current_object_'(This, _, _, Def, _, _, _, _, _, _, _) -> ( call_with_args(Def, Pred, Sender, This, Self, Call) -> call(Call) ; call(Pred) ). % '$lgt_call_within_context'(+object_identifier, +callable, +object_identifier) % % calls a goal within the context of the specified object '$lgt_call_within_context'(Obj, Goal, This) :- ( '$lgt_compiler_flag'(context_switching_calls, allow) -> ( '$lgt_current_object_'(Obj, Prefix, _, _, _, _, _, _, _, _, _) -> '$lgt_ctx_ctx'(Ctx, _, Obj, Obj, Obj, Prefix, [], _), '$lgt_tr_body'(Goal, TGoal, DGoal, Ctx), ( '$lgt_dbg_debugging_', '$lgt_debugging_'(Obj) -> call(DGoal) ; call(TGoal) ) ; throw(error(existence_error(object, Obj), Obj< call_with_args(Rnm, Ctg, Pred, Alias), ( '$lgt_imports_category_'(This, Ctg, _), '$lgt_current_category_'(Ctg, _, _, Def, _, _), call_with_args(Def, Pred, Sender, This, Self, Call, _) -> call(Call) ) ; throw(error(existence_error(predicate_declaration, Alias), ':'(Alias), This)) ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % support for categories that complement objects % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % lookup predicate declarations in any category that complements the given object '$lgt_complemented_object'(This, ThisDcl, Alias, Scope, Compilation, Meta, NonTerminal, Synchronized, SCtn, TCtn) :- '$lgt_complemented_object_'(This, _, Dcl, _, Rnm), ( call_with_args(Dcl, Alias, Scope, Compilation, Meta, NonTerminal, Synchronized, TCtn), SCtn = This ; % categories can define aliases for complemented object predicates: call_with_args(Rnm, This, Pred, Alias), Pred \= Alias, call_with_args(ThisDcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, SCtn, TCtn) ). % lookup predicate definitions in any category that complements the given object '$lgt_complemented_object'(ThisDef, Alias, Sender, This, Self, Call, Ctn) :- '$lgt_complemented_object_'(This, _, _, Def, Rnm), ( call_with_args(Def, Alias, Sender, This, Self, Call, Ctn) ; % categories can define aliases for complemented object predicates: call_with_args(Rnm, This, Pred, Alias), Pred \= Alias, call_with_args(ThisDef, Pred, Sender, This, Self, Call, Ctn) ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % built-in entity tables % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% '$lgt_built_in_object'(logtalk). '$lgt_built_in_object'(user). '$lgt_built_in_object'(debugger). '$lgt_built_in_protocol'(expanding). '$lgt_built_in_protocol'(monitoring). '$lgt_built_in_category'(_) :- fail. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % built-in entity runtime table clauses and properties % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% '$lgt_current_object_'(logtalk, '$lgt_bio_logtalk_0_', '$lgt_bio_logtalk_0__dcl', '$lgt_bio_logtalk_0__def', '$lgt_bio_logtalk_0__super', '$lgt_bio_logtalk_0__idcl', '$lgt_bio_logtalk_0__idef', '$lgt_bio_logtalk_0__ddcl', '$lgt_bio_logtalk_0__ddef', '$lgt_bio_logtalk_0__alias', static). '$lgt_current_object_'(user, '$lgt_bio_user_0_', '$lgt_bio_user_0__dcl', '$lgt_bio_user_0__def', '$lgt_bio_user_0__super', '$lgt_bio_user_0__idcl', '$lgt_bio_user_0__idef', '$lgt_bio_user_0__ddcl', '$lgt_bio_user_0__ddef', '$lgt_bio_user_0__alias', static). '$lgt_current_object_'(debugger, '$lgt_bio_debugger_0_', '$lgt_bio_debugger_0__dcl', '$lgt_bio_debugger_0__def', '$lgt_bio_debugger_0__super', '$lgt_bio_debugger_0__idcl', '$lgt_bio_debugger_0__idef', '$lgt_bio_debugger_0__ddcl', '$lgt_bio_debugger_0__ddef', '$lgt_bio_debugger_0__alias', static). '$lgt_current_protocol_'(expanding, '$lgt_bip_expanding_0_', '$lgt_bip_expanding_0__dcl', '$lgt_bip_expanding_0__alias', static). '$lgt_current_protocol_'(monitoring, '$lgt_bip_monitoring_0_', '$lgt_bip_monitoring_0__dcl', '$lgt_bip_monitoring_0__alias', static). '$lgt_entity_property_'(logtalk, built_in). '$lgt_entity_property_'(user, built_in). '$lgt_entity_property_'(user, threaded). '$lgt_entity_property_'(debugger, built_in). '$lgt_entity_property_'(expanding, built_in). '$lgt_entity_property_'(monitoring, built_in). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % "logtalk" built-in object % % empty object, optionally used as root for both prototype and class-based % hierarchies % % its clauses correspond to a virtual compilation of the object % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- dynamic('$lgt_bio_logtalk_0__ddcl'/2). :- dynamic('$lgt_bio_logtalk_0__ddef'/5). '$lgt_bio_logtalk_0__dcl'(_, _, _, _, _, _) :- fail. '$lgt_bio_logtalk_0__dcl'(Pred, Scope, (dynamic), no, no, no, logtalk, logtalk) :- '$lgt_bio_logtalk_0__ddcl'(Pred, Scope). '$lgt_bio_logtalk_0__def'(_, _, _, _, _) :- fail. '$lgt_bio_logtalk_0__super'(_, _, _, _, _, _) :- fail. '$lgt_bio_logtalk_0__def'(Pred, Sender, This, Self, Call, logtalk) :- '$lgt_bio_logtalk_0__ddef'(Pred, Sender, This, Self, Call). '$lgt_bio_logtalk_0__idcl'(Pred, Scope, (dynamic), no, no, no, logtalk, logtalk) :- '$lgt_bio_logtalk_0__ddcl'(Pred, Scope). '$lgt_bio_logtalk_0__idef'(Pred, Sender, This, Self, Call, logtalk) :- '$lgt_bio_logtalk_0__ddef'(Pred, Sender, This, Self, Call). '$lgt_bio_logtalk_0__alias'(_, Pred, Pred). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % "user" built-in pseudo-object % % represents the Prolog database (excluding built-in predicates) % % the clauses correspond to a virtual compilation of the object % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % the following clauses correspond to a virtual compilation of the built-in pseudo-object "user" '$lgt_bio_user_0__dcl'(Pred, p(p(p)), Type, no, no, no) :- ( nonvar(Pred) -> \+ '$lgt_built_in'(Pred), functor(Pred, Functor, Arity), current_predicate(Functor/Arity) ; current_predicate(Functor/Arity), \+ '$lgt_hidden_functor'(Functor), functor(Pred, Functor, Arity), \+ '$lgt_built_in'(Pred) ), ( '$lgt_predicate_property'(Pred, (dynamic)) -> Type = (dynamic) ; Type = static ). '$lgt_bio_user_0__dcl'(Pred, Scope, Type, Meta, NonTerminal, Synchronized, user, user) :- '$lgt_bio_user_0__dcl'(Pred, Scope, Type, Meta, NonTerminal, Synchronized). '$lgt_bio_user_0__def'(Pred, _, _, _, Pred). '$lgt_bio_user_0__def'(Pred, _, _, _, Pred, user). '$lgt_bio_user_0__alias'(_, Pred, Pred). % '$lgt_hidden_functor'(+atom) % % hidden functors include Logtalk pre-processor and runtime internal functors % and those used in the compiled code of objects, protocols, and categories '$lgt_hidden_functor'(Functor) :- atom_concat('$lgt_', _, Functor), !. '$lgt_hidden_functor'(Functor) :- '$lgt_current_category_'(_, Prefix, _, _, _, _), atom_concat(Prefix, _, Functor), !. '$lgt_hidden_functor'(Functor) :- '$lgt_current_object_'(_, Prefix, _, _, _, _, _, _, _, _, _), atom_concat(Prefix, _, Functor), !. '$lgt_hidden_functor'(Functor) :- '$lgt_current_protocol_'(_, Prefix, _, _, _), atom_concat(Prefix, _, Functor), !. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % "debugger" built-in object % % implements the Logtalk buit-in debugging features % % the clauses correspond to a virtual compilation of the object % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % the following clauses correspond to a virtual compilation of the built-in object debugger % debugger public protocol '$lgt_bio_debugger_0__dcl'(reset, p(p(p)), static, no, no, no). '$lgt_bio_debugger_0__dcl'(debug, p(p(p)), static, no, no, no). '$lgt_bio_debugger_0__dcl'(nodebug, p(p(p)), static, no, no, no). '$lgt_bio_debugger_0__dcl'(debugging, p(p(p)), static, no, no, no). '$lgt_bio_debugger_0__dcl'(debugging(_), p(p(p)), static, no, no, no). '$lgt_bio_debugger_0__dcl'(trace, p(p(p)), static, no, no, no). '$lgt_bio_debugger_0__dcl'(notrace, p(p(p)), static, no, no, no). '$lgt_bio_debugger_0__dcl'(spy(_), p(p(p)), static, no, no, no). '$lgt_bio_debugger_0__dcl'(spy(_, _, _, _), p(p(p)), static, no, no, no). '$lgt_bio_debugger_0__dcl'(nospy(_), p(p(p)), static, no, no, no). '$lgt_bio_debugger_0__dcl'(nospy(_, _, _, _), p(p(p)), static, no, no, no). '$lgt_bio_debugger_0__dcl'(nospyall, p(p(p)), static, no, no, no). '$lgt_bio_debugger_0__dcl'(leash(_), p(p(p)), static, no, no, no). '$lgt_bio_debugger_0__dcl'(Pred, Scope, Type, Meta, NonTerminal, Synchronized, debugger, debugger) :- '$lgt_bio_debugger_0__dcl'(Pred, Scope, Type, Meta, NonTerminal, Synchronized). '$lgt_bio_debugger_0__def'(reset, _, _, _, '$lgt_dbg_reset'). '$lgt_bio_debugger_0__def'(debug, _, _, _, '$lgt_dbg_debug'). '$lgt_bio_debugger_0__def'(nodebug, _, _, _, '$lgt_dbg_nodebug'). '$lgt_bio_debugger_0__def'(debugging, _, _, _, '$lgt_dbg_debugging'). '$lgt_bio_debugger_0__def'(debugging(Entity), _, _, _, '$lgt_dbg_debugging'(Entity)). '$lgt_bio_debugger_0__def'(trace, _, _, _, '$lgt_dbg_trace'). '$lgt_bio_debugger_0__def'(notrace, _, _, _, '$lgt_dbg_notrace'). '$lgt_bio_debugger_0__def'(spy(Preds), _, _, _, '$lgt_dbg_spy'(Preds)). '$lgt_bio_debugger_0__def'(nospy(Preds), _, _, _, '$lgt_dbg_nospy'(Preds)). '$lgt_bio_debugger_0__def'(spy(Sender, This, Self, Goal), _, _, _, '$lgt_dbg_spy'(Sender, This, Self, Goal)). '$lgt_bio_debugger_0__def'(nospy(Sender, This, Self, Goal), _, _, _, '$lgt_dbg_nospy'(Sender, This, Self, Goal)). '$lgt_bio_debugger_0__def'(nospyall, _, _, _, '$lgt_dbg_nospyall'). '$lgt_bio_debugger_0__def'(leash(Ports), _, _, _, '$lgt_dbg_leash'(Ports)). '$lgt_bio_debugger_0__def'(Pred, Sender, This, Self, Call, debugger) :- '$lgt_bio_debugger_0__def'(Pred, Sender, This, Self, Call). '$lgt_bio_debugger_0__alias'(_, Pred, Pred). '$lgt_dbg_reset' :- '$lgt_dbg_nospyall', '$lgt_dbg_leash'(full), '$lgt_dbg_nodebug', '$lgt_dbg_reset_invocation_number'. '$lgt_dbg_debug' :- ( '$lgt_dbg_debugging_' -> write('Debugger is on: showing spy points for all objects compiled in debug mode.'), nl ; assertz('$lgt_dbg_debugging_'), retractall('$lgt_dbg_tracing_'), '$lgt_dbg_reset_invocation_number', write('Debugger switched on: showing spy points for all objects compiled in debug mode.'), nl ). '$lgt_dbg_nodebug' :- ( '$lgt_dbg_debugging_' -> retractall('$lgt_dbg_debugging_'), retractall('$lgt_dbg_tracing_'), write('Debugger switched off.'), nl ; write('Debugger is off.'), nl ). '$lgt_dbg_suspend'(Tracing) :- ( '$lgt_dbg_tracing_' -> Tracing = true ; Tracing = false ), retractall('$lgt_dbg_debugging_'), retractall('$lgt_dbg_tracing_'). '$lgt_dbg_resume'(Tracing) :- ( Tracing == true -> retractall('$lgt_dbg_tracing_'), assertz('$lgt_dbg_tracing_') ; true ), retractall('$lgt_dbg_debugging_'), assertz('$lgt_dbg_debugging_'). '$lgt_dbg_trace' :- ( '$lgt_dbg_tracing_' -> write('Debugger is on: tracing everything for all objects compiled in debug mode.'), nl ; assertz('$lgt_dbg_tracing_'), retractall('$lgt_dbg_debugging_'), assertz('$lgt_dbg_debugging_'), '$lgt_dbg_reset_invocation_number', write('Debugger switched on: tracing everything for all objects compiled in debug mode.'), nl ). '$lgt_dbg_notrace' :- ( '$lgt_dbg_tracing_' -> retractall('$lgt_dbg_tracing_'), retractall('$lgt_dbg_debugging_'), write('Debugger switched off.'), nl ; write('Debugger is off.'), nl ). '$lgt_dbg_debugging' :- ( '$lgt_dbg_debugging_' -> write('Debugger is on: '), ( '$lgt_dbg_tracing_' -> write('tracing everything.'), nl ; write('showing spy points.'), nl ) ; write('Debugger is off.'), nl ), nl, ( '$lgt_dbg_spying_'(_, _) -> write('Defined predicate spy points (Functor/Arity):'), nl, forall( '$lgt_dbg_spying_'(Functor, Arity), (write(' '), writeq(Functor), write('/'), write(Arity), nl)) ; write('No predicate spy points are defined.'), nl ), nl, ( '$lgt_dbg_spying_'(_, _, _, _) -> write('Defined context spy points (Sender, This, Self, Goal):'), nl, forall( '$lgt_dbg_spying_'(Sender, This, Self, Goal), (write(' '), '$lgt_dbg_pretty_print_spypoint'(Sender, This, Self, Goal), nl)) ; write('No context spy points are defined.'), nl ), nl, write('Leashed ports:'), nl, write(' '), ( '$lgt_dbg_leashing_'(_) -> forall('$lgt_dbg_leashing_'(Port), (write(Port), write(' '))) ; write('(none)') ), nl. '$lgt_dbg_debugging'(Entity) :- '$lgt_debugging_'(Entity). '$lgt_dbg_pretty_print_spypoint'(Sender, This, Self, Goal) :- current_output(Output), ( var(Sender) -> write('_, ') ; '$lgt_pretty_print_vars_quoted'(Output, Sender), write(', ') ), ( var(This) -> write('_, ') ; '$lgt_pretty_print_vars_quoted'(Output, This), write(', ') ), ( var(Self) -> write('_, ') ; '$lgt_pretty_print_vars_quoted'(Output, Self), write(', ') ), ( var(Goal) -> write('_') ; '$lgt_pretty_print_vars_quoted'(Output, Goal) ). '$lgt_dbg_spy'(Preds) :- nonvar(Preds), '$lgt_dbg_spy_aux'(Preds), write('Predicate spy points set.'), nl, ( '$lgt_dbg_debugging_' -> true ; '$lgt_dbg_debug' ). '$lgt_dbg_spy_aux'([]). '$lgt_dbg_spy_aux'([Functor/Arity| Preds]) :- nonvar(Functor), nonvar(Arity), ( '$lgt_dbg_spying_'(Functor, Arity) -> true ; assertz('$lgt_dbg_spying_'(Functor, Arity)) ), '$lgt_dbg_spy_aux'(Preds). '$lgt_dbg_spy_aux'(Functor/Arity) :- nonvar(Functor), nonvar(Arity), ( '$lgt_dbg_spying_'(Functor, Arity) -> true ; assertz('$lgt_dbg_spying_'(Functor, Arity)) ). '$lgt_dbg_nospy'(Preds) :- '$lgt_dbg_nospy_aux'(Preds), write('All matching predicate spy points removed.'), nl. '$lgt_dbg_nospy_aux'(Preds) :- ( var(Preds) -> retractall('$lgt_dbg_spying_'(_, _)) ; '$lgt_dbg_nospy_aux2'(Preds) ). '$lgt_dbg_nospy_aux2'([]). '$lgt_dbg_nospy_aux2'([Functor/Arity| Preds]) :- retractall('$lgt_dbg_spying_'(Functor, Arity)), '$lgt_dbg_nospy_aux2'(Preds). '$lgt_dbg_nospy_aux2'(Functor/Arity) :- retractall('$lgt_dbg_spying_'(Functor, Arity)). '$lgt_dbg_spy'(Sender, This, Self, Goal) :- asserta('$lgt_dbg_spying_'(Sender, This, Self, Goal)), write('Context spy point set.'), nl, ( '$lgt_dbg_debugging_' -> true ; '$lgt_dbg_debug' ). '$lgt_dbg_nospy'(Sender, This, Self, Goal) :- retractall('$lgt_dbg_spying_'(Sender, This, Self, Goal)), write('All matching context spy points removed.'), nl. '$lgt_dbg_nospyall' :- retractall('$lgt_dbg_spying_'(_, _)), write('All predicate spy points removed.'), nl, retractall('$lgt_dbg_spying_'(_, _, _, _)), write('All context spy points removed.'), nl. '$lgt_dbg_leash'(Value) :- '$lgt_dbg_valid_leash_value'(Value, Ports), retractall('$lgt_dbg_leashing_'(_)), '$lgt_dbg_set_leash_ports'(Ports), write('Debugger leash ports set to '), write(Ports), nl. '$lgt_dbg_set_leash_ports'([]). '$lgt_dbg_set_leash_ports'([Port| Ports]) :- assertz('$lgt_dbg_leashing_'(Port)), '$lgt_dbg_set_leash_ports'(Ports). '$lgt_dbg_leashing_'(fact). '$lgt_dbg_leashing_'(rule). '$lgt_dbg_leashing_'(call). '$lgt_dbg_leashing_'(exit). '$lgt_dbg_leashing_'(redo). '$lgt_dbg_leashing_'(fail). '$lgt_dbg_leashing_'(exception). '$lgt_dbg_valid_leash_value'(Shorthand, Ports) :- atom(Shorthand), Shorthand \== [], !, '$lgt_dbg_leash_shortand_ports'(Shorthand, Ports). '$lgt_dbg_valid_leash_value'(Ports, Ports) :- nonvar(Ports), '$lgt_is_proper_list'(Ports), '$lgt_dbg_valid_leash_ports'(Ports). '$lgt_dbg_valid_leash_ports'([]). '$lgt_dbg_valid_leash_ports'([Port| Ports]) :- nonvar(Port), '$lgt_dbg_valid_leash_port'(Port), '$lgt_dbg_valid_leash_ports'(Ports). '$lgt_dbg_valid_leash_port'(fact). '$lgt_dbg_valid_leash_port'(rule). '$lgt_dbg_valid_leash_port'(call). '$lgt_dbg_valid_leash_port'(exit). '$lgt_