%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Logtalk - Open source object-oriented logic programming language % Release 2.30.7 % % Copyright (c) 1998-2007 Paulo Moura. All Rights Reserved. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % 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 as a predicate for unit test context-switching) :- op(400, yfx, <<). % category predicate direct 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 and respective relationships :- dynamic('$lgt_current_protocol_'/3). % '$lgt_current_protocol_'(Ptc, Prefix, Type) :- dynamic('$lgt_current_category_'/4). % '$lgt_current_category_'(Ctg, Prefix, Type, Synchronized) :- dynamic('$lgt_current_object_'/8). % '$lgt_current_object_'(Obj, Prefix, Dcl, Def, Super, Type, Synchronized, Threaded) :- dynamic('$lgt_implements_protocol_'/3). % '$lgt_implements_protocol_'(ObjOrCtg, Ptc, Scope) :- dynamic('$lgt_imports_category_'/3). % '$lgt_imports_category_'(ObjOrCtg, Ctg, Scope) :- dynamic('$lgt_instantiates_class_'/3). % '$lgt_instantiates_class_'(Instance, Class, Scope) :- dynamic('$lgt_specializes_class_'/3). % '$lgt_specializes_class_'(Class, Superclass, Scope) :- dynamic('$lgt_extends_protocol_'/3). % '$lgt_extends_protocol_'(Ptc1, Ptc2, Scope) :- dynamic('$lgt_extends_object_'/3). % '$lgt_extends_object_'(Prototype, Parent, Scope) % table of loaded files :- dynamic('$lgt_loaded_file_'/2). % '$lgt_loaded_file_'(File, Directory) % debugger status and tables :- dynamic('$lgt_debugging_'/1). % '$lgt_debugging_'(Entity) :- 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) % 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) % 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 :- dynamic(logtalk_library_path/2). % logtalk_library_path(Library, Path) % compiler hook goal: :- dynamic('$lgt_hook_goal_'/2). % '$lgt_hook_goal_'(Term, Terms) % 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, Mode) :- dynamic('$lgt_pp_category_'/6). % '$lgt_pp_category_'(Ctg, Prefix, Dcl, Def, Rnm, Mode) :- dynamic('$lgt_pp_protocol_'/5). % '$lgt_pp_protocol_'(Ptc, Prefix, Dcl, Rnm, Mode) :- 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_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_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_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_goal_'/2). % '$lgt_pp_hook_goal_'(Term, Terms) :- dynamic('$lgt_pp_threaded_'/0). % '$lgt_pp_threaded_' :- dynamic('$lgt_pp_synchronized_'/0). % '$lgt_pp_synchronized_' %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % 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_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< 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(ObjArity, '__idcl', TFunctor); atom_concat(ObjArity, '__dcl', TFunctor))), atom_chars(ObjArity, ObjArityChars), '$lgt_append'(FunctorChars, ['_', ArityChar| ArityChars], ObjArityChars), catch(number_chars(Arity, [ArityChar| ArityChars]), _, fail), atom_chars(Functor, FunctorChars), functor(Obj, Functor, Arity), ( '$lgt_instantiates_class_'(_, Obj, _) ; '$lgt_specializes_class_'(_, Obj, _) ; '$lgt_extends_object_'(_, Obj, _) ), \+ '$lgt_current_object_'(Obj, _, _, _, _, _, _, _), throw(error(existence_error(object, Obj), _, _)). '$lgt_runtime_error_handler'(error(existence_error(procedure, TFunctor/7), _)) :- atom_concat(CtgOrPtc, '_0__dcl', TFunctor), ( '$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_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(logtalk_debugger_aborted)) :- nl, write(' Debugging session aborted by user. Debugger still on.'), nl, !, fail. '$lgt_runtime_error_handler'(error(Error, user::Goal, user)) :- throw(error(Error, Goal)). '$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(user, built_in). object_property(debugger, built_in). object_property(logtalk, built_in). object_property(Obj, Prop) :- '$lgt_current_object_'(Obj, _, _, _, _, Prop, _, _). % static/dynamic property object_property(Obj, synchronized) :- '$lgt_current_object_'(Obj, _, _, _, _, _, yes, _). object_property(Obj, threaded) :- '$lgt_current_object_'(Obj, _, _, _, _, _, _, yes). % 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) :- % static/dynamic property '$lgt_current_category_'(Ctg, _, Prop, _). category_property(Ctg, synchronized) :- '$lgt_current_category_'(Ctg, _, _, yes). % 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) :- % static/dynamic property '$lgt_current_protocol_'(Ptc, _, Prop). % create_object(+object_identifier, +list, +list, +list) create_object(Obj, Rels, Dirs, Clauses) :- (var(Obj); var(Rels); var(Dirs); var(Clauses)), throw(error(instantiation_error, create_object(Obj, Rels, Dirs, Clauses))). create_object(Obj, Rels, Dirs, Clauses) :- \+ callable(Obj), throw(error(type_error(object_identifier, Obj), create_object(Obj, Rels, Dirs, Clauses))). create_object(Obj, Rels, Dirs, Clauses) :- '$lgt_current_object_'(Obj, _, _, _, _, _, _, _), throw(error(permission_error(modify, object, Obj), create_object(Obj, Rels, Dirs, Clauses))). create_object(Obj, Rels, Dirs, Clauses) :- '$lgt_current_category_'(Obj, _, _, _), throw(error(permission_error(modify, category, Obj), create_object(Obj, Rels, Dirs, Clauses))). create_object(Obj, Rels, Dirs, Clauses) :- '$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) :- '$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_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(Ctg); var(Rels); var(Dirs); var(Clauses)), throw(error(instantiation_error, create_category(Ctg, Rels, Dirs, Clauses))). create_category(Ctg, Rels, Dirs, Clauses) :- \+ atom(Ctg), throw(error(type_error(category_identifier, Ctg), create_category(Ctg, Rels, Dirs, Clauses))). create_category(Ctg, Rels, Dirs, Clauses) :- '$lgt_current_category_'(Ctg, _, _, _), throw(error(permission_error(modify, category, Ctg), create_category(Ctg, Rels, Dirs, Clauses))). create_category(Ctg, Rels, Dirs, Clauses) :- '$lgt_current_object_'(Ctg, _, _, _, _, _, _, _), throw(error(permission_error(modify, object, Ctg), create_category(Ctg, Rels, Dirs, Clauses))). create_category(Ctg, Rels, Dirs, Clauses) :- '$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) :- '$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_gen_local_def_clauses', '$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(Ptc); var(Rels); var(Dirs)), throw(error(instantiation_error, create_protocol(Ptc, Rels, Dirs))). create_protocol(Ptc, Rels, Dirs) :- \+ atom(Ptc), throw(error(type_error(protocol_identifier, Ptc), create_protocol(Ptc, Rels, Dirs))). create_protocol(Ptc, Rels, Dirs) :- '$lgt_current_protocol_'(Ptc, _, _), throw(error(permission_error(modify, protocol, Ptc), create_protocol(Ptc, Rels, Dirs))). create_protocol(Ptc, Rels, Dirs) :- '$lgt_current_object_'(Ptc, _, _, _, _, _, _, _), throw(error(permission_error(modify, object, Ptc), create_protocol(Ptc, Rels, Dirs))). create_protocol(Ptc, Rels, Dirs) :- '$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) :- '$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'. % 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, _, _, _, Type, _, _) -> ( Type == (dynamic) -> call_with_args(Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Rnm), '$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_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, Type, _) -> ( Type == (dynamic) -> call_with_args(Prefix, Dcl, Def, Rnm), '$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_imports_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, Type) -> ( Type == (dynamic) -> call_with_args(Prefix, Dcl, Rnm), abolish(Dcl/6), abolish(Dcl/7), abolish(Rnm/3), abolish(Prefix/2), retractall('$lgt_current_protocol_'(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(?category_identifier, ?category_identifier) imports_category(ObjOrCtg, Ctg) :- catch( imports_category(ObjOrCtg, Ctg, _), error(Error, _), throw(error(Error, imports_category(ObjOrCtg, Ctg)))). % imports_category(?object_identifier, ?category_identifier, ?atom) % imports_category(?category_identifier, ?category_identifier, ?atom) imports_category(ObjOrCtg, Ctg, Scope) :- nonvar(ObjOrCtg), \+ callable(ObjOrCtg), throw(error(type_error(object_identifier, ObjOrCtg), imports_category(ObjOrCtg, Ctg, Scope))). imports_category(ObjOrCtg, Ctg, Scope) :- nonvar(Ctg), \+ atom(Ctg), throw(error(type_error(category_identifier, Ctg), imports_category(ObjOrCtg, Ctg, Scope))). imports_category(ObjOrCtg, Ctg, Scope) :- nonvar(Scope), Scope \== (public), Scope \== protected, Scope \== private, throw(error(type_error(scope, Scope), imports_category(ObjOrCtg, Ctg, Scope))). imports_category(ObjOrCtg, Ctg, Scope) :- '$lgt_imports_category_'(ObjOrCtg, 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_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). % 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) :- 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)) ) ). 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)). 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)). % 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_', [], _), catch('$lgt_tr_threaded_call'(Goals, MTGoals, Ctx), Error, throw(error(Error, threaded(Goals)))), catch(MTGoals, Error, '$lgt_runtime_error_handler'(Error)). % 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_report_warning_numbers'(logtalk_compile(Files, Flags))), Error, ('$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 '$lgt_expand_library_path'(Library, Path) :- '$lgt_expand_library_path'(Library, Path, 16). % depth bound to prevent loops '$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) :- retractall('$lgt_pp_compiler_flag_'(_, _)), % retract old flag values retractall('$lgt_pp_hook_goal_'(_, _)), % and any old hook goal '$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::Functor) -> % pre-compile hook in order Call =.. [Functor, Term, Terms], % to speed up entity compilation ( Obj == user -> Goal = Call ; '$lgt_tr_msg'(Call, Obj, Goal, user) ), assertz(('$lgt_pp_hook_goal_'(Term, Terms) :- catch(Goal, _, 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). % 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_report_warning_numbers'(logtalk_load(Files, Flags))), Error, ('$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_hook'(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, 30, 7)). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % 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, Prefix, Dcl, Def, _, _, _, _), 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, Prop = meta_predicate(Meta) ; NonTerminal \== no, functor(Pred, Functor, Arity2), Arity is Arity2 - 2, Prop = non_terminal(Functor//Arity) ; Synchronized \== no, Prop = synchronized ; '$lgt_current_object_'(TCtn, _, TCtnDcl, _, _, _, _, _), \+ call_with_args(TCtnDcl, Pred, _, _, _, _, _), '$lgt_alias_pred'(Obj, Prefix, Pred, Pred2), Prop = alias(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, ?term). % % converts between user and system scope terms '$lgt_scope'(private, p). '$lgt_scope'(protected, p(p)). '$lgt_scope'((public), p(p(p))). % '$lgt_alias_pred'(+object_identifier, +atom, +callable, -callable) % % finds the predicate pointed by an alias '$lgt_alias_pred'(Obj, Prefix, Alias, Pred) :- '$lgt_alias_pred'(Obj, Prefix, Alias, Pred, _). '$lgt_alias_pred'(_, Prefix, Alias, Pred, _) :- '$lgt_construct_alias_functor'(Prefix, Functor), call_with_args(Functor, _, Pred, Alias) -> Pred \= Alias, !. '$lgt_alias_pred'(Obj, _, Alias, Pred, _) :- '$lgt_implements_protocol_'(Obj, Ptc, _), '$lgt_current_protocol_'(Ptc, Prefix, _), '$lgt_alias_pred'(Ptc, Prefix, Alias, Pred, _). '$lgt_alias_pred'(Ptc1, _, Alias, Pred, _) :- '$lgt_extends_protocol_'(Ptc1, Ptc2, _), '$lgt_current_protocol_'(Ptc2, Prefix, _), '$lgt_alias_pred'(Ptc2, Prefix, Alias, Pred, _). '$lgt_alias_pred'(Obj, _, Alias, Pred, _) :- '$lgt_imports_category_'(Obj, Ctg, _), '$lgt_current_category_'(Ctg, Prefix, _, _), '$lgt_alias_pred'(Ctg, Prefix, Alias, Pred, _). '$lgt_alias_pred'(Obj, _, Alias, Pred, prototype) :- '$lgt_extends_object_'(Obj, Parent, _), '$lgt_current_object_'(Parent, Prefix, _, _, _, _, _, _), '$lgt_alias_pred'(Parent, Prefix, Alias, Pred, prototype). '$lgt_alias_pred'(Instance, _, Alias, Pred, instance) :- '$lgt_instantiates_class_'(Instance, Class, _), '$lgt_current_object_'(Class, Prefix, _, _, _, _, _, _), '$lgt_alias_pred'(Class, Prefix, Alias, Pred, superclass). '$lgt_alias_pred'(Class, _, Alias, Pred, superclass) :- '$lgt_specializes_class_'(Class, Superclass, _), '$lgt_current_object_'(Superclass, Prefix, _, _, _, _, _, _), '$lgt_alias_pred'(Superclass, Prefix, Alias, Pred, superclass). % 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, Prefix, Dcl, _, _, _, _, _), !, ( functor(Pred, Functor, Arity), call_with_args(Dcl, Pred, PScope, Compilation, _, _, _, SCtn, _) -> ( (\+ \+ PScope = Scope; Sender = SCtn) -> ( Compilation == (dynamic) -> call_with_args(Prefix, _, _, _, _, _, DDcl, DDef, _), ( 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, _, _, _, _, _, _), !, call_with_args(Prefix, Dcl, Def, _, _, _, DDcl, DDef, _), '$lgt_assert_pred_dcl'(Dcl, DDcl, Head, Scope, Type, Meta, SCtn, DclScope), ( Type == (dynamic) -> ( (\+ \+ 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, 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, _, _, _, _, _, _), !, call_with_args(Prefix, Dcl, Def, _, _, _, DDcl, DDef, _), '$lgt_assert_pred_dcl'(Dcl, DDcl, Head, Scope, Type, _, SCtn, DclScope), ( Type == (dynamic) -> ( (\+ \+ 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, DbgCtx))) ; '$lgt_add_db_lookup_cache_entry'(Obj, Head, SCtn, DclScope, 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, _, _, _, _, _, _), !, call_with_args(Prefix, Dcl, Def, _, _, _, DDcl, DDef, _), '$lgt_assert_pred_dcl'(Dcl, DDcl, Head, Scope, Type, Meta, SCtn, DclScope), ( Type == (dynamic) -> ( (\+ \+ 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, 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, _, _, _, _, _, _), !, call_with_args(Prefix, Dcl, Def, _, _, _, DDcl, DDef, _), '$lgt_assert_pred_dcl'(Dcl, DDcl, Head, Scope, Type, _, SCtn, DclScope), ( Type == (dynamic) -> ( (\+ \+ 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, DbgCtx))) ; '$lgt_add_db_lookup_cache_entry'(Obj, Head, SCtn, DclScope, 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::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_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) :- ( call_with_args(Dcl, Pred, Scope, Type, Meta, _, _, SCtn, _) -> true ; % no previous predicate declaration: '$lgt_assert_ddcl_clause'(DDcl, Pred, DclScope), (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, EntityPrefix, 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'(EntityPrefix, Functor, Arity, PredPrefix), GHead =.. [_| GArgs], '$lgt_append'(GArgs, [GSender, GThis, GSelf], TArgs), THead =.. [PredPrefix| 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, Prefix, _, _, _, _, _, _), !, call_with_args(Prefix, Dcl, Def, _, _, _, _, DDef, _), ( call_with_args(Dcl, Head, PScope, Type, _, _, _, SCtn, _) -> ( Type == (dynamic) -> ( (\+ \+ 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, Prefix, _, _, _, _, _, _), !, call_with_args(Prefix, Dcl, Def, _, _, _, _, DDef, _), ( call_with_args(Dcl, Head, PScope, Type, _, _, _, SCtn, _) -> ( Type == (dynamic) -> ( (\+ \+ 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, Prefix, _, _, _, _, _, _), !, call_with_args(Prefix, Dcl, Def, _, _, _, _, DDef, _), ( call_with_args(Dcl, Head, PScope, Type, _, _, _, SCtn, _) -> ( Type == (dynamic) -> ( (\+ \+ 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, Prefix, _, _, _, _, _, _), !, call_with_args(Prefix, Dcl, Def, _, _, _, _, DDef, _), ( call_with_args(Dcl, Head, PScope, Type, _, _, _, SCtn, _) -> ( Type == (dynamic) -> ( (\+ \+ 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, 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, 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, PScope, 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, Prefix, _, _, _, _, _, _), !, call_with_args(Prefix, Dcl, Def, _, _, _, _, DDef, _), ( call_with_args(Dcl, Head, PScope, Type, _, _, _, SCtn, _) -> ( Type == (dynamic) -> ( (\+ \+ 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_add_db_lookup_cache_entry'(Obj, Head, PScope, 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_add_db_lookup_cache_entry'(Obj, Head, PScope, 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, @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, 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)) -> 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, @object_identifier, @callable, +atom, +atom) % % adds a new database lookup cache entry '$lgt_add_db_lookup_cache_entry'(Obj, Head, SCtn, Scope, 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)) -> 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)) -> 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) :- ( '$lgt_current_object_'(Obj, Prefix, Dcl, Def, _, _, _, _) -> NonTerminal =.. [Functor| Args], '$lgt_append'(Args, [Input, Rest], Args2), Pred =.. [Functor| Args2], ( 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(Prefix, _, _, _, _, _, _, DDef, _), 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, Prefix, Dcl, Def, _, _, _, _), ( ( 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(Prefix, _, _, _, _, _, _, DDef, _), call_with_args(DDef, term_expansion(Term, Expansion), Obj, Obj, Obj, Call) ) ), !, once(Call). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % message sending % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % '$lgt_send_to_self'(+object, ?term, +object) '$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, +term, +object) '$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, ?term, +object) '$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, +term, +object) '$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(Call), \+ ('$lgt_after_'(Obj, Pred, Sender, _, ACall), \+ call(ACall)). '$lgt_send_to_object_nv'(Obj, Pred, Sender) :- '$lgt_current_object_'(Obj, _, Dcl, Def, _, _, _, _), !, ( call_with_args(Dcl, Pred, Scope, _, _, _, _, _, _) -> % lookup declaration ( Scope = p(p(_)) -> % 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, _) :- catch(current_module(Obj), _, fail), !, ':'(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, ?term, +object) '$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, +term, +object) '$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, _, _, _, _, _, _) -> % lookup declaration ( Scope = p(p(_)) -> % 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, _) :- catch(current_module(Obj), _, fail), !, ':'(Obj, Pred). '$lgt_send_to_object_ne_nv'(Obj, Pred, Sender) :- throw(error(existence_error(object, Obj), Obj::Pred, Sender)). % '$lgt_send_to_super'(+object, ?term, +object, +object) '$lgt_send_to_super'(_, Pred, This, _) :- var(Pred), throw(error(instantiation_error, ^^Pred, This)). '$lgt_send_to_super'(Self, Pred, This, Sender) :- '$lgt_send_to_super_nv'(Self, Pred, This, Sender). % '$lgt_send_to_super_nv'(+object, +term, +object, +object) '$lgt_send_to_super_nv'(Self, Pred, This, Sender) :- '$lgt_super_lookup_cache_'(Self, Pred, This, Sender, Call), !, call(Call). '$lgt_send_to_super_nv'(Self, Pred, This, Sender) :- '$lgt_current_object_'(Self, _, Dcl, _, _, _, _, _), call_with_args(Dcl, Pred, Scope, _, _, _, _, SCtn, _), !, ( (Scope = p(_); This = SCtn) -> % check scope '$lgt_current_object_'(This, _, _, _, Super, _, _, _), 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) -> % lookup definition ( Ctn \= GThis -> 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 ; throw(error(endless_loop(Pred), ^^Pred, This)) ) ) ; % message is not within the scope of the sender: throw(error(permission_error(access, private_predicate, Pred), ^^Pred, This)) ). '$lgt_send_to_super_nv'(_, Pred, This, _) :- ( '$lgt_built_in'(Pred) -> call(Pred) ; throw(error(existence_error(predicate_declaration, Pred), ^^Pred, This)) ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % meta-calls % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % '$lgt_metacall_in_object'(?term, ?term, ?term, +object, +object, +object) % % 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'(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, +object, +object) % % 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< ( '$lgt_imports_category_'(This, Ctg, _), call_with_args(Def, Pred, Sender, This, Self, Call, Ctg) -> call(Call) ) ; throw(error(existence_error(predicate_declaration, Pred), ':'(Pred), This)) ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % built-in entity tables % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% '$lgt_built_in_object'(logtalk). '$lgt_built_in_object'(user). '$lgt_built_in_object'(debugger). '$lgt_built_in_protocol'(monitoring). '$lgt_built_in_category'(_) :- fail. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % built-in entity table clauses % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% '$lgt_current_object_'(logtalk, '$lgt_bio_logtalk_0_', '$lgt_bio_logtalk_0__dcl', '$lgt_bio_logtalk_0__def', '$lgt_bio_logtalk_0__super', static, no, no). '$lgt_current_object_'(user, '$lgt_bio_user_0_', '$lgt_bio_user_0__dcl', '$lgt_bio_user_0__def', '$lgt_bio_user_0__super', static, no, yes). '$lgt_current_object_'(debugger, '$lgt_bio_debugger_0_', '$lgt_bio_debugger_0__dcl', '$lgt_bio_debugger_0__def', '$lgt_bio_debugger_0__super', static, no, no). '$lgt_current_protocol_'(monitoring, '$lgt_bip_monitoring_0_', static). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % "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_'('$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'). '$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_'('$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'). '$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, p(p(p)), Type, Meta, NonTerminal, Synchronized, user, user) :- '$lgt_bio_user_0__dcl'(Pred, p(p(p)), 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 '$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'). % 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, p(p(p)), Type, Meta, NonTerminal, Synchronized, debugger, debugger) :- '$lgt_bio_debugger_0__dcl'(Pred, p(p(p)), 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_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_'), 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_'), 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_dbg_valid_leash_port'(redo). '$lgt_dbg_valid_leash_port'(fail). '$lgt_dbg_valid_leash_port'(exception). '$lgt_dbg_leash_shortand_ports'(none, []). '$lgt_dbg_leash_shortand_ports'(loose, [fact, rule, call]). '$lgt_dbg_leash_shortand_ports'(half, [fact, rule, call, redo]). '$lgt_dbg_leash_shortand_ports'(tight, [fact, rule, call, redo, fail, exception]). '$lgt_dbg_leash_shortand_ports'(full, [fact, rule, call, exit, redo, fail, exception]). '$lgt_dbg_leashing'(Port, Goal, DbgCtx, Code) :- '$lgt_dbg_leashing_'(Port), ( '$lgt_dbg_tracing_' -> Code = ' ' ; '$lgt_dbg_spying'(Port, Goal, DbgCtx, Code), ( '$lgt_dbg_tracing_' -> true ; assertz('$lgt_dbg_tracing_') ) ). '$lgt_dbg_spying'(_, Goal, _, '+') :- functor(Goal, Functor, Arity), \+ \+ '$lgt_dbg_spying_'(Functor, Arity), !. '$lgt_dbg_spying'(_, Goal, DbgCtx, '*') :- '$lgt_dbg_ctx'(DbgCtx, Sender, This, Self), \+ \+ '$lgt_dbg_spying_'(Sender, This, Self, Goal). '$lgt_dbg_fact'(Fact, DbgCtx) :- '$lgt_dbg_debugging_', \+ '$lgt_dbg_skipping_', !, '$lgt_dbg_port'(fact, Fact, _, DbgCtx, Action), call(Action). '$lgt_dbg_fact'(_, _). '$lgt_dbg_head'(Head, DbgCtx) :- '$lgt_dbg_debugging_', \+ '$lgt_dbg_skipping_', !, '$lgt_dbg_port'(rule, Head, _, DbgCtx, Action), call(Action). '$lgt_dbg_head'(_, _). '$lgt_dbg_goal'(Goal, TGoal, DbgCtx) :- '$lgt_dbg_debugging_', \+ '$lgt_dbg_skipping_', !, ( '$lgt_dbg_port'(call, Goal, _, DbgCtx, CAction), ( CAction = skip -> retractall('$lgt_dbg_skipping_'), assertz('$lgt_dbg_skipping_'), CAction2 = true ; CAction2 = CAction ), ( CAction2 = ignore -> true ; call(CAction2), catch( call(TGoal), Error, ('$lgt_dbg_port'(exception, Goal, Error, DbgCtx, TAction), (TAction = fail -> fail; throw(Error)))), ( '$lgt_dbg_port'(exit, Goal, _, DbgCtx, EAction), call(EAction) ; '$lgt_dbg_port'(redo, Goal, _, DbgCtx, RAction), ( RAction = skip -> retractall('$lgt_dbg_skipping_'), assertz('$lgt_dbg_skipping_') ), RAction = ignore ) ; retractall('$lgt_dbg_skipping_'), '$lgt_dbg_port'(fail, Goal, _, DbgCtx, _), fail ) ), retractall('$lgt_dbg_skipping_'). '$lgt_dbg_goal'(_, TGoal, _) :- call(TGoal). '$lgt_dbg_port'(exception, _, error(logtalk_debugger_aborted), _, true) :- !. '$lgt_dbg_port'(Port, Goal, Error, DbgCtx, Action) :- '$lgt_dbg_debugging_', !, ( '$lgt_dbg_leashing'(Port, Goal, DbgCtx, Code) -> repeat, write(Code), '$lgt_dbg_write_port_name'(Port), writeq(Goal), write(' ? '), catch('$lgt_read_single_char'(Option), _, fail), once('$lgt_dbg_valid_port_option'(Option, Port, Code)), '$lgt_dbg_do_port_option'(Option, Port, Goal, Error, DbgCtx, Action), ! ; ( '$lgt_dbg_tracing_' -> write(' '), '$lgt_dbg_write_port_name'(Port), writeq(Goal), nl ; true ), Action = true ). '$lgt_dbg_port'(_, _, _, _, true). '$lgt_dbg_write_port_name'(fact) :- write(' Fact: '). '$lgt_dbg_write_port_name'(rule) :- write(' Rule: '). '$lgt_dbg_write_port_name'(call) :- write(' Call: '). '$lgt_dbg_write_port_name'(exit) :- write(' Exit: '). '$lgt_dbg_write_port_name'(redo) :- write(' Redo: '). '$lgt_dbg_write_port_name'(fail) :- write(' Fail: '). '$lgt_dbg_write_port_name'(exception) :- write(' Exception: '). '$lgt_dbg_valid_port_option'(' ', _, _). '$lgt_dbg_valid_port_option'(c, _, _). '$lgt_dbg_valid_port_option'(l, _, _). '$lgt_dbg_valid_port_option'(s, _, _). '$lgt_dbg_valid_port_option'(i, call, _). '$lgt_dbg_valid_port_option'(i, redo, _). '$lgt_dbg_valid_port_option'(f, call, _). '$lgt_dbg_valid_port_option'(f, redo, _). '$lgt_dbg_valid_port_option'(n, _, _). '$lgt_dbg_valid_port_option'(!, _, _). '$lgt_dbg_valid_port_option'(@, _, _). '$lgt_dbg_valid_port_option'(b, _, _). '$lgt_dbg_valid_port_option'(a, _, _). '$lgt_dbg_valid_port_option'(q, _, _). '$lgt_dbg_valid_port_option'(d, _, _). '$lgt_dbg_valid_port_option'(x, _, _). '$lgt_dbg_valid_port_option'(h, _, _). '$lgt_dbg_valid_port_option'(?, _, _). '$lgt_dbg_valid_port_option'(=, _, _). '$lgt_dbg_valid_port_option'(*, _, ' '). '$lgt_dbg_valid_port_option'(+, _, ' '). '$lgt_dbg_valid_port_option'(-, _, +). '$lgt_dbg_valid_port_option'(e, exception, _). '$lgt_dbg_do_port_option'(' ', _, _, _, _, true). '$lgt_dbg_do_port_option'(c, _, _, _, _, true). '$lgt_dbg_do_port_option'(l, _, _, _, _, true) :- retractall('$lgt_dbg_tracing_'). '$lgt_dbg_do_port_option'(s, Port, _, _, _, Action) :- '$lgt_dbg_do_port_option_skip'(Port, Action). '$lgt_dbg_do_port_option'(i, _, _, _, _, ignore). '$lgt_dbg_do_port_option'(f, _, _, _, _, fail). '$lgt_dbg_do_port_option'(t, _, _, _, _, _) :- ( '$lgt_dbg_tracing_' -> true ; assertz('$lgt_dbg_tracing_') ), fail. '$lgt_dbg_do_port_option'(n, _, _, _, _, true) :- '$lgt_dbg_nodebug'. '$lgt_dbg_do_port_option'(=, _, _, _, _, _) :- '$lgt_dbg_debugging', fail. '$lgt_dbg_do_port_option'(+, _, Goal, _, _, _) :- ( Goal = (_ :: Pred) -> functor(Pred, Functor, Arity) ; functor(Goal, Functor, Arity) ), '$lgt_dbg_spy'(Functor/Arity), fail. '$lgt_dbg_do_port_option'(-, _, Goal, _, _, true) :- ( Goal = (_ :: Pred) -> functor(Pred, Functor, Arity) ; functor(Goal, Functor, Arity) ), '$lgt_dbg_nospy'(Functor/Arity). '$lgt_dbg_do_port_option'(*, _, Goal, _, _, _) :- functor(Goal, Functor, Arity), functor(CGoal, Functor, Arity), write(' Enter a context spy point term formatted as (Sender, This, Self, Goal): '), read(Spypoint), Spypoint = (Sender, This, Self, CGoal), '$lgt_dbg_spy'(Sender, This, Self, CGoal), fail. '$lgt_dbg_do_port_option'(!, Port, Goal, Error, DbgCtx, Action) :- '$lgt_dbg_do_port_option'(@, Port, Goal, Error, DbgCtx, Action). '$lgt_dbg_do_port_option'(@, _, _, _, _, _) :- write(' ?- '), read(Goal), call(Goal) -> fail. '$lgt_dbg_do_port_option'(b, _, _, _, _, _) :- ( '$lgt_compiler_flag'(break_predicate, true) -> '$lgt_dbg_suspend'(Tracing), break, '$lgt_dbg_resume'(Tracing) ; write(' break no supportd on this Prolog compiler.'), nl ), fail. '$lgt_dbg_do_port_option'(a, _, _, _, _, _) :- throw(error(logtalk_debugger_aborted)). '$lgt_dbg_do_port_option'(q, _, _, _, _, _) :- halt. '$lgt_dbg_do_port_option'(d, _, Goal, _, _, _) :- write(' Current goal: '), write_term(Goal, [ignore_ops(true)]), nl, fail. '$lgt_dbg_do_port_option'(x, _, _, _, DbgCtx, _) :- '$lgt_dbg_ctx'(DbgCtx, Sender, This, Self), write(' Sender: '), writeq(Sender), nl, write(' This: '), writeq(This), nl, write(' Self: '), writeq(Self), nl, fail. '$lgt_dbg_do_port_option'(e, _, _, Error, _, _) :- write(' Exception term: '), writeq(Error), nl, fail. '$lgt_dbg_do_port_option'(h, _, _, _, _, _) :- write(' Available options are:'), nl, write(' c - creep (go on; you may use also the spacebar)'), nl, write(' l - leap (continues execution until the next spy point is found)'), nl, write(' s - skip (skips debugging for the current goal; only meaningful at call and redo ports)'), nl, write(' i - ignore (ignores goal, assumes that it succeeded)'), nl, write(' f - fail (forces backtracking)'), nl, write(' n - nodebug (turns off debugging)'), nl, write(' ! - command (reads and executes a query)'), nl, write(' @ - command (reads and executes a query)'), nl, write(' b - break (suspends execution and starts new interpreter; type end_of_file to terminate)'), nl, write(' a - abort (returns to top level interpreter)'), nl, write(' q - quit (quits Logtalk)'), nl, write(' d - display (writes current goal without using operator notation)'), nl, write(' x - context (prints execution context)'), nl, write(' e - exception (prints exception term thrown by current goal)'), nl, write(' = - debugging (prints debugging information)'), nl, write(' * - add (adds a context spy point for current goal)'), nl, write(' + - add (adds a predicate spy point for current goal)'), nl, write(' - - remove (removes a predicate spy point for current goal)'), nl, write(' h - help (prints this list of options)'), nl, write(' ? - help (prints this list of options)'), nl, fail. '$lgt_dbg_do_port_option'(?, Port, Goal, Error, DbgCtx, Action) :- '$lgt_dbg_do_port_option'(h, Port, Goal, Error, DbgCtx, Action). '$lgt_dbg_do_port_option_skip'(exit, true). '$lgt_dbg_do_port_option_skip'(fail, true). '$lgt_dbg_do_port_option_skip'(fact, true). '$lgt_dbg_do_port_option_skip'(rule, true). '$lgt_dbg_do_port_option_skip'(exception, true). '$lgt_dbg_do_port_option_skip'(call, skip). '$lgt_dbg_do_port_option_skip'(redo, skip). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % "monitoring" built-in protocol % % implements the Logtalk event handlers protocol % % the clauses correspond to a virtual compilation of the protocol % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% '$lgt_bip_monitoring_0_'('$lgt_bip_monitoring_0__dcl', '$lgt_bip_monitoring_0__alias'). '$lgt_bip_monitoring_0__dcl'(before(_, _, _), p(p(p)), static, no, no, no). '$lgt_bip_monitoring_0__dcl'(after(_, _, _), p(p(p)), static, no, no, no). '$lgt_bip_monitoring_0__dcl'(Pred, Scope, Type, Meta, NonTerminal, Synchronized, monitoring) :- '$lgt_bip_monitoring_0__dcl'(Pred, Scope, Type, Meta, NonTerminal, Synchronized). '$lgt_bip_monitoring_0__alias'(_, Pred, Pred). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % pre-processor - compiles Logtalk source files to Prolog % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % '$lgt_load_files'(@source_file_name) % '$lgt_load_files'(@source_file_name_list) % % compiles to disk and then loads to memory a source file or a list of source files '$lgt_load_files'([]) :- !. '$lgt_load_files'([File| Files]) :- !, '$lgt_load_file'(File), '$lgt_load_files'(Files). '$lgt_load_files'(File) :- '$lgt_load_file'(File). % '$lgt_load_file'(@source_file_name) % % compiles to disk and then loads to memory a source file '$lgt_load_file'(Term) :- compound(Term), !, Term =.. [Library, File], '$lgt_expand_library_path'(Library, Path), '$lgt_current_directory'(Current), '$lgt_change_directory'(Path), '$lgt_current_directory'(ExpandedPath), ( Current \== ExpandedPath -> '$lgt_report_working_directory'(ExpandedPath), '$lgt_load_file'(File), '$lgt_change_directory'(Current), '$lgt_report_working_directory'(Current) ; '$lgt_load_file'(File) ). '$lgt_load_file'(File) :- '$lgt_current_directory'(Directory), ( '$lgt_loaded_file_'(File, Directory) -> ( '$lgt_compiler_flag'(reload, skip) -> '$lgt_report_skipping_file'(File) ; '$lgt_report_reloading_file'(File), '$lgt_compile_file'(File), '$lgt_file_name'(prolog, File, PrologFile), '$lgt_load_prolog_code'(PrologFile, File), '$lgt_report_reloaded_file'(File) ) ; '$lgt_report_loading_file'(File), '$lgt_compile_file'(File), '$lgt_file_name'(prolog, File, PrologFile), '$lgt_load_prolog_code'(PrologFile, File), '$lgt_report_loaded_file'(File), assertz('$lgt_loaded_file_'(File, Directory)) ). % '$lgt_redefined_entity'(@entity_identifier, -atom) % % true if an entity of the same name is already loaded; returns entity type '$lgt_redefined_entity'(Entity, object) :- '$lgt_current_object_'(Entity, _, _, _, _, _, _, _), !. '$lgt_redefined_entity'(Entity, protocol) :- '$lgt_current_protocol_'(Entity, _, _), !. '$lgt_redefined_entity'(Entity, category) :- '$lgt_current_category_'(Entity, _, _, _). % '$lgt_report_redefined_entity'(+atom, @entity_identifier) % % prints a warning for redefined entities '$lgt_report_redefined_entity'(Type, Entity) :- ( '$lgt_compiler_flag'(report, on) -> '$lgt_inc_load_warnings_counter', write(' WARNING! Redefining '), write(Type), write(' '), current_output(Output), '$lgt_pretty_print_vars_quoted'(Output, Entity), nl ; true ). % '$lgt_report_compiling_entity'(+atom, +entity_identifier) % % prints a message that an entity is being compiled '$lgt_report_compiling_entity'(Type, Entity) :- retractall('$lgt_pp_entity_warnings_flag_'), ( '$lgt_compiler_flag'(report, on) -> write('compiling '), write(Type), write(' '), current_output(Output), '$lgt_pretty_print_vars_quoted'(Output, Entity), ( '$lgt_compiler_flag'(debug, on) -> write(' in debug mode... ') ; write('... ') ) ; true ). % '$lgt_report_compiled_entity'(+atom, +entity_identifier) % % prints a message that an entity is finished compiling '$lgt_report_compiled_entity'(_, _) :- ( '$lgt_compiler_flag'(report, on) -> ( '$lgt_pp_entity_warnings_flag_' -> nl ; true ), write('compiled'), nl ; true ). % '$lgt_report_loaded_entity'(+entity_identifier) % % prints a message that an entity finished loading '$lgt_report_loaded_entity'(Entity) :- ( '$lgt_compiler_flag'(report, on) -> write('< '), writeq(Entity), write(' loaded'), nl ; true ). % '$lgt_report_working_directory'(+atom) % % prints the working directory being used for compiling/loading source files '$lgt_report_working_directory'(Directory) :- ( '$lgt_compiler_flag'(report, on) -> nl, write('+++ working on directory '), write(Directory), nl ; true ). % '$lgt_report_compiling_file'(+entity_identifier) % % prints a message that an entity is being compiled '$lgt_report_compiling_file'(File) :- ( '$lgt_compiler_flag'(report, on) -> write('>>> compiling source file '), writeq(File), ( '$lgt_compiler_flag'(debug, on) -> write(' in debug mode...') ; write('...') ), nl ; true ). % '$lgt_report_up_to_date_file'(+entity_identifier) % % prints a message that an entity is up-to-date '$lgt_report_up_to_date_file'(File) :- ( '$lgt_compiler_flag'(report, on) -> write('>>> compiling source file '), writeq(File), write('... up-to-date'), nl ; true ). % '$lgt_report_compiled_file'(+atom) % % prints a message that a source file is finished compiling '$lgt_report_compiled_file'(File) :- ( '$lgt_compiler_flag'(report, on) -> write('>>> '), writeq(File), write(' source file compiled'), nl ; true ). % '$lgt_report_loading_file'(+atom) % % prints a message that a file is being loaded '$lgt_report_loading_file'(File) :- ( '$lgt_compiler_flag'(report, on) -> write('<<< loading source file '), writeq(File), write('... '), nl ; true ). % '$lgt_report_reloading_file'(+atom) % % prints a message that a file is being reloaded '$lgt_report_reloading_file'(File) :- ( '$lgt_compiler_flag'(report, on) -> write('<<< reloading source file '), writeq(File), write('... '), nl ; true ). % '$lgt_report_skipping_file'(+atom) % % prints a message that loading a file is being skiped '$lgt_report_skipping_file'(File) :- ( '$lgt_compiler_flag'(report, on) -> write('<<< skipping loading of source file '), writeq(File), write(' (already loaded) '), nl ; true ). % '$lgt_report_loaded_file'(+entity_identifier) % % prints a message that a source file finished loading '$lgt_report_loaded_file'(File) :- ( '$lgt_compiler_flag'(report, on) -> write('<<< '), writeq(File), write(' source file loaded'), nl ; true ). % '$lgt_report_reloaded_file'(+entity_identifier) % % prints a message that a source file finished reloading '$lgt_report_reloaded_file'(File) :- ( '$lgt_compiler_flag'(report, on) -> write('<<< '), writeq(File), write(' source file reloaded'), nl ; true ). % '$lgt_compile_files'(@source_file_name) % '$lgt_compile_files'(@source_file_name_list) % % compiles to disk a source file or a list of source files '$lgt_compile_files'([]) :- !. '$lgt_compile_files'([File| Files]) :- !, '$lgt_compile_file'(File), '$lgt_compile_files'(Files). '$lgt_compile_files'(File) :- '$lgt_compile_file'(File). % '$lgt_compile_file'(@source_file_name) % % compiles to disk a source file '$lgt_compile_file'(Term) :- compound(Term), !, Term =.. [Library, File], '$lgt_expand_library_path'(Library, Path), '$lgt_current_directory'(Current), '$lgt_change_directory'(Path), '$lgt_current_directory'(ExpandedPath), ( Current \== ExpandedPath -> '$lgt_report_working_directory'(ExpandedPath), '$lgt_compile_file'(File), '$lgt_change_directory'(Current), '$lgt_report_working_directory'(Current) ; '$lgt_compile_file'(File) ). '$lgt_compile_file'(File) :- '$lgt_compiler_flag'(smart_compilation, on), \+ '$lgt_needs_recompilation'(File), !, '$lgt_report_up_to_date_file'(File). '$lgt_compile_file'(File) :- '$lgt_report_compiling_file'(File), '$lgt_tr_file'(File), '$lgt_report_compiled_file'(File). % '$lgt_needs_recompilation'(+atom) % % source file needs recompilation '$lgt_needs_recompilation'(File) :- '$lgt_file_name'(prolog, File, Object), \+ '$lgt_file_exists'(Object), !. '$lgt_needs_recompilation'(File) :- '$lgt_file_name'(logtalk, File, Source), '$lgt_file_name'(prolog, File, Object), ( '$lgt_compare_file_mtimes'(Result, Source, Object) -> Result == (>) ; true ). % '$lgt_write_tr_entity'(@stream) % % writes to disk the entity compiled code '$lgt_write_tr_entity'(Stream) :- catch( ('$lgt_write_directives'(Stream), '$lgt_write_prolog_clauses'(Stream), '$lgt_write_logtalk_clauses'(Stream)), Error, '$lgt_compiler_error_handler'(Stream, Error)). % '$lgt_write_entity_doc'(@entity_identifier) % % writes to disk the entity documentation in XML format '$lgt_write_entity_doc'(Entity) :- ( '$lgt_compiler_flag'(xmldocs, on) -> '$lgt_entity_doc_file_name'(Entity, File), catch( (( '$lgt_pp_directive_'(encoding(Encoding)) -> open(File, write, Stream, [encoding(Encoding)]) ; open(File, write, Stream) ), '$lgt_write_xml_file'(Stream), close(Stream)), Error, '$lgt_compiler_error_handler'(Stream, Error)) ; true ). % '$lgt_entity_doc_file_name'(@nonvar, -atom) % % generates the XML file name for an entity using the format _ '$lgt_entity_doc_file_name'(Entity, File) :- functor(Entity, Functor, Arity), number_codes(Arity, Codes), atom_codes(Atom, Codes), atom_concat(Functor, '_', Aux), atom_concat(Aux, Atom, Name), '$lgt_file_name'(xml, Name, File). % '$lgt_file_name'(+atom, +atom, -atom) % % constructs a file name given the file type (logtalk, prolog, or xml) % and the file base name (file name may include a directory path) '$lgt_file_name'(Type, Basename, File) :- '$lgt_file_extension'(Type, Extension), % defined on the Prolog config files ( '$lgt_compiler_flag'(altdirs, on), '$lgt_file_type_alt_directory'(Type, Directory) -> '$lgt_make_directory'(Directory), % succeeds when the directory already exists atom_concat(Basename, Extension, Aux), atom_concat(Directory, Aux, File) % file on the alternate compilation directory ; atom_concat(Basename, Extension, File) % file local to current working directory ). % '$lgt_tr_file'(+atom) % % compiles a source file storing the resulting code in memory '$lgt_tr_file'(File) :- '$lgt_clean_pp_clauses', '$lgt_save_global_op_table', '$lgt_file_name'(logtalk, File, Source), catch( open(Source, read, Input), OpenError, '$lgt_compiler_error_handler'(OpenError)), catch( read_term(Input, Term, [singletons(Singletons)]), InputError, '$lgt_compiler_error_handler'(Input, InputError)), '$lgt_check_for_encoding_directive'(Term, Source, Input, NewInput, OutputOption), % the encoding/1 directive, when present, '$lgt_file_name'(prolog, File, Object), % must be the first term on a source file catch( open(Object, write, Output, OutputOption), OpenError, '$lgt_compiler_error_handler'(NewInput, Output, OpenError)), catch( '$lgt_tr_file'(Term, Singletons, NewInput, Output), Error, '$lgt_compiler_error_handler'(NewInput, Output, Error)), close(NewInput), catch( ('$lgt_write_directives'(Output), % write out any Prolog code that may occur '$lgt_write_prolog_clauses'(Output), % after the last entity on the source file; '$lgt_write_init_call'(Output)), % write initialization/1 directive at the OutputError, % end of the file to improve compatibility '$lgt_compiler_error_handler'(Output, OutputError)), % with non-ISO compliant Prolog compilers close(Output), '$lgt_restore_global_op_table'. % '$lgt_check_for_encoding_directive'(@nonvar, +atom, @stream, -stream, -list) % % encoding/1 directives must be used during entity compilation and for the % encoding of the generated Prolog and XML files '$lgt_check_for_encoding_directive'((:- encoding(Encoding)), Source, Input, NewInput, [encoding(Encoding)]) :- !, ( \+ '$lgt_compiler_flag'(encoding_directive, unsupported) -> close(Input), open(Source, read, NewInput, [encoding(Encoding)]), read_term(NewInput, _, [singletons(_)]) % throw away encoding/1 directive ; throw(error(domain_error(directive, encoding/1), directive(encoding(Encoding)))) ). '$lgt_check_for_encoding_directive'(_, _, Input, Input, []). % assume no encoding/1 directive present on the source file % '$lgt_tr_file'(+term, +list, @stream, @stream) '$lgt_tr_file'(end_of_file, _, _, Output) :- % module definitions start with an opening '$lgt_pp_module_'(Module), % module/1-2 directive and are assumed to '$lgt_pp_object_'(Module, _, _, _, _, _, _, _, _, _, _), % end at the end of a source file; there is '$lgt_tr_entity'(object, Module, Output), % no module closing directive '$lgt_report_compiled_entity'(module, Module), !. '$lgt_tr_file'(end_of_file, _, _, _) :- '$lgt_pp_object_'(Obj, _, _, _, _, _, _, _, _, _, _), throw(entity_ending_directive_missing(object, Obj)). '$lgt_tr_file'(end_of_file, _, _, _) :- '$lgt_pp_protocol_'(Ptc, _, _, _, _), throw(entity_ending_directive_missing(protocol, Ptc)). '$lgt_tr_file'(end_of_file, _, _, _) :- '$lgt_pp_category_'(Ctg, _, _, _, _, _), throw(entity_ending_directive_missing(category, Ctg)). '$lgt_tr_file'(end_of_file, _, _, _) :- !. '$lgt_tr_file'(Term, Singletons, Input, Output) :- '$lgt_report_singletons'(Singletons, Term, Input), '$lgt_tr_term'(Term, Input, Output), read_term(Input, Next, [singletons(NSingletons)]), '$lgt_tr_file'(Next, NSingletons, Input, Output). % '$lgt_report_singletons'(+list, +term, @stream) % % report the singleton variables found while compiling an entity term '$lgt_report_singletons'(TSingletons, Term, Input) :- '$lgt_filter_dont_care_vars'(TSingletons, FSingletons), '$lgt_singleton_var_names'(FSingletons, Names), '$lgt_report_singletons_aux'(Names, Term, Input). '$lgt_report_singletons_aux'([], _, _) :- !. % cut needed to prevent problems with compilers with broken read_term/3 '$lgt_report_singletons_aux'([Name| Names], Term, Stream) :- ( '$lgt_compiler_flag'(singletons, warning), '$lgt_compiler_flag'(report, on) -> '$lgt_inc_compile_warnings_counter', ( '$lgt_pp_entity'(_, _, _, _, _) -> nl ; true ), ( Names == [] -> write(' WARNING! Singleton variable ') ; write(' WARNING! Singleton variables ') ), 'lgt_report_singletons_term'(Term), '$lgt_write_list'([Name| Names]), nl, '$lgt_report_compiler_error_line_number'(Stream), ( '$lgt_pp_entity'(_, _, _, _, _) -> true ; nl ) ; true ). 'lgt_report_singletons_term'((:- Term)) :- !, functor(Term, Functor, Arity), write('in directive '), writeq(Functor/Arity), write(': '). 'lgt_report_singletons_term'((Term :- _)) :- !, functor(Term, Functor, Arity), write('in clause for predicate '), writeq(Functor/Arity), write(': '). 'lgt_report_singletons_term'((Term, _ --> _)) :- !, functor(Term, Functor, Arity), write('in grammar rule for non-terminal '), writeq(Functor//Arity), write(': '). 'lgt_report_singletons_term'((Term --> _)) :- !, functor(Term, Functor, Arity), write('in grammar rule for non-terminal '), writeq(Functor//Arity), write(': '). 'lgt_report_singletons_term'(Term) :- functor(Term, Functor, Arity), write('in clause for predicate '), writeq(Functor/Arity), write(': '). % '$lgt_singleton_var_names'(@list, -list) % % colects singleton variable names into a list '$lgt_singleton_var_names'([], []). '$lgt_singleton_var_names'([Name = _| Singletons], [Name| Names]) :- '$lgt_singleton_var_names'(Singletons, Names). % '$lgt_filter_dont_care_vars'(+list, -list) % % filter variables whose name start with an underscore from a singletons list if % the corresponding compiler flag sets their interpretation to don't care variables '$lgt_filter_dont_care_vars'(List, Result) :- ( '$lgt_compiler_flag'(underscore_variables, dont_care) -> '$lgt_filter_dont_care_vars'(List, [], Result) ; List = Result ). '$lgt_filter_dont_care_vars'([], Result, Result) :- !. % cut needed to prevent problems with compilers with broken read_term/3 '$lgt_filter_dont_care_vars'([Atom = Var| List], Sofar, Result) :- ( atom_concat('_', _, Atom) -> '$lgt_filter_dont_care_vars'(List, Sofar, Result) ; '$lgt_filter_dont_care_vars'(List, [Atom = Var| Sofar], Result) ). % '$lgt_compiler_error_handler'(@stream, @stream, +term) % % closes the streams being used for reading and writing terms, restores % the operator table, and reports the compilation error found '$lgt_compiler_error_handler'(Input, Output, Error) :- '$lgt_report_compiler_error'(Input, Error), '$lgt_clean_pp_clauses', '$lgt_restore_global_op_table', '$lgt_reset_warnings_counter', catch(close(Input), _, true), catch(close(Output), _, true), throw(Error). % '$lgt_compiler_error_handler'(@stream, +term) % % closes the stream being used for reading or writing terms, restores % the operator table, and reports the compilation error found '$lgt_compiler_error_handler'(Stream, Error) :- '$lgt_report_compiler_error'(Stream, Error), '$lgt_clean_pp_clauses', '$lgt_restore_global_op_table', '$lgt_reset_warnings_counter', catch(close(Stream), _, true), throw(Error). % '$lgt_compiler_error_handler'(+term) % % restores the operator table, and reports the compilation error found '$lgt_compiler_error_handler'(Error) :- ('$lgt_pp_entity'(_, _, _, _, _) -> nl; true), write(' ERROR! '), writeq(Error), nl, '$lgt_clean_pp_clauses', '$lgt_restore_global_op_table', '$lgt_reset_warnings_counter', throw(Error). % '$lgt_report_compiler_error'(@stream, +term) % % reports a compilation error '$lgt_report_compiler_error'(Stream, Error) :- '$lgt_report_compiler_error_message'(Error), '$lgt_report_compiler_error_line_number'(Stream), nl. '$lgt_report_compiler_error_message'(error(Error, entity(Type, Entity))) :- !, ('$lgt_pp_entity'(_, _, _, _, _) -> nl; true), write(' ERROR! '), writeq(Error), nl, write(' in '), write(Type), write(': '), writeq(Entity), nl. '$lgt_report_compiler_error_message'(error(Error, directive(Directive))) :- !, ('$lgt_pp_entity'(_, _, _, _, _) -> nl; true), write(' ERROR! '), writeq(Error), nl, write(' in directive: '), writeq((:- Directive)), nl. '$lgt_report_compiler_error_message'(error(Error, clause(Clause))) :- !, ('$lgt_pp_entity'(_, _, _, _, _) -> nl; true), write(' ERROR! '), writeq(Error), nl, write(' in clause: '), writeq(Clause), nl. '$lgt_report_compiler_error_message'(error(Error, dcgrule(Rule))) :- !, ('$lgt_pp_entity'(_, _, _, _, _) -> nl; true), write(' ERROR! '), writeq(Error), nl, write(' in grammar rule: '), writeq((Rule)), nl. '$lgt_report_compiler_error_message'(error(Error, Term)) :- !, ('$lgt_pp_entity'(_, _, _, _, _) -> nl; true), write(' ERROR! '), writeq(Error), nl, write(' in: '), writeq(Term), nl. '$lgt_report_compiler_error_message'(Error) :- ('$lgt_pp_entity'(_, _, _, _, _) -> nl; true), write(' ERROR! '), writeq(Error), nl. '$lgt_report_compiler_error_line_number'(Stream) :- ( catch('$lgt_stream_current_line_number'(Stream, Line), _, fail) -> write(' above line: '), write(Line) ; true ). % '$lgt_tr_entity'(+atom, @entity_identifier, @stream) '$lgt_tr_entity'(Type, Entity, Stream) :- '$lgt_generate_code'(Type), '$lgt_report_problems'(Type), '$lgt_write_tr_entity'(Stream), '$lgt_write_entity_doc'(Entity), '$lgt_restore_file_op_table', '$lgt_clean_pp_entity_clauses'. % clean up all dynamic predicates used during source file compilation % (except any user-defined compiler options specified on the compiling and loading predicates) '$lgt_clean_pp_clauses' :- '$lgt_clean_pp_entity_clauses', retractall('$lgt_pp_global_op_'(_, _, _)), retractall('$lgt_pp_file_op_'(_, _, _)), retractall('$lgt_pp_file_init_'(_)), retractall('$lgt_pp_entity_init_'(_, _, _)). % clean up all dynamic predicates used during entity compilation '$lgt_clean_pp_entity_clauses' :- retractall('$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _)), retractall('$lgt_pp_protocol_'(_, _, _, _, _)), retractall('$lgt_pp_category_'(_, _, _, _, _, _)), retractall('$lgt_pp_module_'(_)), retractall('$lgt_pp_implemented_protocol_'(_, _, _, _)), retractall('$lgt_pp_imported_category_'(_, _, _, _, _)), retractall('$lgt_pp_extended_object_'(_, _, _, _, _, _, _, _, _, _)), retractall('$lgt_pp_instantiated_class_'(_, _, _, _, _, _, _, _, _, _)), retractall('$lgt_pp_specialized_class_'(_, _, _, _, _, _, _, _, _, _)), retractall('$lgt_pp_extended_protocol_'(_, _, _, _)), retractall('$lgt_pp_uses_'(_)), retractall('$lgt_pp_uses_'(_, _, _)), retractall('$lgt_pp_calls_'(_)), retractall('$lgt_pp_info_'(_)), retractall('$lgt_pp_info_'(_, _)), retractall('$lgt_pp_directive_'(_)), retractall('$lgt_pp_synchronized_'(_, _)), retractall('$lgt_pp_pred_mutex_count_'(_)), retractall('$lgt_pp_public_'(_, _)), retractall('$lgt_pp_protected_'(_, _)), retractall('$lgt_pp_private_'(_, _)), retractall('$lgt_pp_dynamic_'(_, _)), retractall('$lgt_pp_discontiguous_'(_, _)), retractall('$lgt_pp_mode_'(_, _)), retractall('$lgt_pp_meta_predicate_'(_)), retractall('$lgt_pp_alias_'(_, _, _)), retractall('$lgt_pp_non_terminal_'(_, _, _)), retractall('$lgt_pp_entity_init_'(_)), retractall('$lgt_pp_fentity_init_'(_)), retractall('$lgt_pp_dcl_'(_)), retractall('$lgt_pp_ddcl_'(_)), retractall('$lgt_pp_def_'(_)), retractall('$lgt_pp_fdef_'(_)), retractall('$lgt_pp_ddef_'(_)), retractall('$lgt_pp_fddef_'(_)), retractall('$lgt_pp_super_'(_)), retractall('$lgt_pp_ppclause_'(_)), retractall('$lgt_pp_rclause_'(_)), retractall('$lgt_pp_eclause_'(_)), retractall('$lgt_pp_feclause_'(_)), retractall('$lgt_pp_redefined_built_in_'(_, _, _, _, _)), retractall('$lgt_pp_defs_pred_'(_, _)), retractall('$lgt_pp_calls_pred_'(_, _, _, _)), retractall('$lgt_non_portable_call_'(_, _)), retractall('$lgt_pp_defs_nt_'(_, _)), retractall('$lgt_pp_calls_nt_'(_, _)), retractall('$lgt_pp_referenced_object_'(_)), retractall('$lgt_pp_referenced_protocol_'(_)), retractall('$lgt_pp_referenced_category_'(_)), retractall('$lgt_pp_entity_op_'(_, _, _)), retractall('$lgt_pp_threaded_'), retractall('$lgt_pp_synchronized_'). % '$lgt_clean_lookup_caches' % % clean lookup caches '$lgt_clean_lookup_caches' :- retractall('$lgt_obj_lookup_cache_'(_, _, _, _)), retractall('$lgt_self_lookup_cache_'(_, _, _, _)), retractall('$lgt_super_lookup_cache_'(_, _, _, _, _)), retractall('$lgt_db_lookup_cache_'(_, _, _, _, _)). % '$lgt_clean_lookup_caches'(@callable) % % clean lookup caches for the matching predicate '$lgt_clean_lookup_caches'(Pred) :- retractall('$lgt_obj_lookup_cache_'(_, Pred, _, _)), retractall('$lgt_self_lookup_cache_'(_, Pred, _, _)), retractall('$lgt_super_lookup_cache_'(_, Pred, _, _, _)), retractall('$lgt_db_lookup_cache_'(_, Pred, _, _, _)). % '$lgt_save_global_op_table' % % saves current operator table '$lgt_save_global_op_table' :- current_op(Pr, Spec, Op), asserta('$lgt_pp_global_op_'(Pr, Spec, Op)), fail. '$lgt_save_global_op_table'. % '$lgt_restore_global_op_table' % % restores current operator table '$lgt_restore_global_op_table' :- retract('$lgt_pp_entity_op_'(_, Spec, Op)), op(0, Spec, Op), fail. '$lgt_restore_global_op_table' :- retractall('$lgt_pp_file_op_'(_, _, ',')), % ','/2 cannot be an argument to op/3 retract('$lgt_pp_file_op_'(_, Spec, Op)), catch(op(0, Spec, Op), _, fail), % some Prolog compilers may define other operators as non-redefinable fail. '$lgt_restore_global_op_table' :- retractall('$lgt_pp_global_op_'(_, _, ',')), % ','/2 cannot be an argument to op/3 retract('$lgt_pp_global_op_'(Pr, Spec, Op)), catch(op(Pr, Spec, Op), _, fail), % some Prolog compilers may define other operators as non-redefinable fail. '$lgt_restore_global_op_table'. % '$lgt_save_file_op_table' % % saves current operator table '$lgt_save_file_op_table' :- current_op(Pr, Spec, Op), asserta('$lgt_pp_file_op_'(Pr, Spec, Op)), fail. '$lgt_save_file_op_table'. % '$lgt_restore_file_op_table' % % restores current operator table '$lgt_restore_file_op_table' :- retract('$lgt_pp_entity_op_'(_, Spec, Op)), op(0, Spec, Op), fail. '$lgt_restore_file_op_table' :- retractall('$lgt_pp_file_op_'(_, _, ',')), % ','/2 cannot be an argument to op/3 retract('$lgt_pp_file_op_'(Pr, Spec, Op)), catch(op(Pr, Spec, Op), _, fail), % some Prolog compilers may define other operators as non-redefinable fail. '$lgt_restore_file_op_table'. % '$lgt_assert_entity_ops'(+integer, +operator_specifier, +atom_or_atom_list) % % asserts local entity operators '$lgt_assert_entity_ops'(_, _, []) :- !. '$lgt_assert_entity_ops'(Pr, Spec, [Op| Ops]) :- !, asserta('$lgt_pp_entity_op_'(Pr, Spec, Op)), '$lgt_assert_entity_ops'(Pr, Spec, Ops). '$lgt_assert_entity_ops'(Pr, Spec, Op) :- asserta('$lgt_pp_entity_op_'(Pr, Spec, Op)). % '$lgt_pp_entity'(?atom, ?entity_identifier, ?atom, ?atom, ?atom) % % provides access to some common used data on the entity being compiled '$lgt_pp_entity'(object, Entity, Prefix, Dcl, Mode) :- '$lgt_pp_object_'(Entity, Prefix, Dcl, _, _, _, _, _, _, _, Mode), !. '$lgt_pp_entity'(category, Entity, Prefix, Dcl, Mode) :- '$lgt_pp_category_'(Entity, Prefix, Dcl, _, _, Mode), !. '$lgt_pp_entity'(protocol, Entity, Prefix, Dcl, Mode) :- '$lgt_pp_protocol_'(Entity, Prefix, Dcl, _, Mode). % '$lgt_pp_rclause'(-compound) % % returns runtime table clauses for the entity being compiled '$lgt_pp_rclause'(Clause) :- '$lgt_pp_rclause_'(Clause). '$lgt_pp_rclause'('$lgt_debugging_'(Entity)) :- '$lgt_compiler_flag'(debug, on), '$lgt_pp_entity'(_, Entity, _, _, _). '$lgt_pp_rclause'('$lgt_current_object_'(Obj, Prefix, Dcl, Def, Super, Mode, Synchronized, Threaded)) :- '$lgt_pp_object_'(Obj, Prefix, Dcl, Def, Super, _, _, _, _, _, Mode), ( '$lgt_pp_synchronized_' -> Synchronized = yes ; Synchronized = no ), ( '$lgt_pp_threaded_' -> Threaded = yes ; Threaded = no ), !. '$lgt_pp_rclause'('$lgt_current_protocol_'(Ptc, Prefix, Mode)) :- '$lgt_pp_protocol_'(Ptc, Prefix, _, _, Mode), !. '$lgt_pp_rclause'('$lgt_current_category_'(Ctg, Prefix, Mode, Synchronized)) :- '$lgt_pp_category_'(Ctg, Prefix, _, _, _, Mode), ( '$lgt_pp_synchronized_' -> Synchronized = yes ; Synchronized = no ). % '$lgt_tr_term'(+term, @stream, @stream) % % translates a source file term (clauses, directives, and grammar rules) '$lgt_tr_term'(Term, Input, Output) :- ( % source-file specific compiler hook: '$lgt_pp_hook_goal_'(Term, Terms) -> '$lgt_tr_expanded_terms'(Terms, Input, Output) ; % default compiler hook: '$lgt_hook_goal_'(Term, Terms) -> '$lgt_tr_expanded_terms'(Terms, Input, Output) ; % no compiler hook defined: '$lgt_tr_expanded_term'(Term, Input, Output) ). % '$lgt_tr_expanded_terms'(+list, @stream, @stream) % % translates a list of source file terms '$lgt_tr_expanded_terms'([], _, _). '$lgt_tr_expanded_terms'([Term| Terms], Input, Output) :- '$lgt_tr_expanded_term'(Term, Input, Output), '$lgt_tr_expanded_terms'(Terms, Input, Output). % '$lgt_tr_expanded_term'(+list, @stream, @stream) % % translates a source file term (clauses, directives, and grammar rules) '$lgt_tr_expanded_term'((Head :- Body), Input, _) :- !, '$lgt_tr_clause'((Head :- Body), Input). '$lgt_tr_expanded_term'((:- Directive), Input, Output) :- !, '$lgt_tr_directive'(Directive, Input, Output). '$lgt_tr_expanded_term'((Head --> Body), Input, _) :- !, '$lgt_dcgrule_to_clause'((Head --> Body), Clause), '$lgt_tr_clause'(Clause, Input). '$lgt_tr_expanded_term'(Fact, Input, _) :- '$lgt_tr_clause'(Fact, Input). % '$lgt_tr_directives'(+list, @stream, @stream) % % translates a list of directives '$lgt_tr_directives'([], _, _). '$lgt_tr_directives'([Dir| Dirs], Input, Output) :- '$lgt_tr_directive'(Dir, Input, Output), '$lgt_tr_directives'(Dirs, Input, Output). % '$lgt_tr_directive'(+term, @stream, @stream) % % translates a directive '$lgt_tr_directive'(Dir, _, _) :- var(Dir), throw(error(instantiantion_error, directive(Dir))). '$lgt_tr_directive'(Dir, _, _) :- % closing entity directive occurs before the opening \+ '$lgt_pp_entity'(_, _, _, _, _), % entity directive; the opening directive is probably functor(Dir, Functor, Arity), % missing or misspelt '$lgt_lgt_closing_directive'(Functor, Arity), throw(error(unmatched_directive, directive(Dir))). '$lgt_tr_directive'(Dir, _, _) :- \+ '$lgt_pp_entity'(_, _, _, _, _), % directive occurs before opening entity directive functor(Dir, Functor, Arity), \+ '$lgt_lgt_opening_directive'(Functor, Arity), !, '$lgt_tr_file_directive'(Dir). % translate it as a source file-level directive '$lgt_tr_directive'(Dir, Input, Output) :- % entity closing directive functor(Dir, Functor, Arity), '$lgt_lgt_closing_directive'(Functor, Arity), Dir =.. [Functor| Args], catch( '$lgt_tr_directive'(Functor, Args, Input, Output), Error, ( '$lgt_pp_entity'(Type, Entity, _, _, _) -> throw(error(Error, entity(Type, Entity))) ; throw(error(Error, directive(Dir))) )), !. '$lgt_tr_directive'(Dir, Input, Output) :- % entity opening directive or entity directive functor(Dir, Functor, Arity), '$lgt_lgt_directive'(Functor, Arity), Dir =.. [Functor| Args], catch( '$lgt_tr_directive'(Functor, Args, Input, Output), Error, throw(error(Error, directive(Dir)))), !. '$lgt_tr_directive'(Dir, Input, _) :- '$lgt_ignore_pl_directive'(Dir), % defined in the Prolog config files !, ( '$lgt_compiler_flag'(portability, warning) -> nl, write(' WARNING! Ignoring Prolog directive: '), writeq(Dir), nl, '$lgt_report_compiler_error_line_number'(Input) ; true ). '$lgt_tr_directive'(Dir, Input, _) :- '$lgt_rewrite_and_copy_pl_directive'(Dir, RWDir), % defined in the Prolog config files assertz('$lgt_pp_directive_'(RWDir)), !, ( '$lgt_compiler_flag'(portability, warning) -> nl, write(' WARNING! Rewriting Prolog directive: '), writeq(Dir), nl, write(' Copying resulting Prolog directive: '), writeq(RWDir), nl, '$lgt_report_compiler_error_line_number'(Input) ; true ). '$lgt_tr_directive'(Dir, Input, Output) :- '$lgt_rewrite_and_recompile_pl_directive'(Dir, RWDir), % defined in the Prolog config files !, ( '$lgt_compiler_flag'(portability, warning) -> nl, write(' WARNING! Rewriting Prolog directive: '), writeq(Dir), nl, write(' Recompiling resulting Prolog directive: '), writeq(RWDir), nl, '$lgt_report_compiler_error_line_number'(Input) ; true ), '$lgt_tr_directive'(RWDir, Input, Output). % try to translate the rewritten directive '$lgt_tr_directive'(Dir, _, _) :- functor(Dir, Functor, Arity), throw(error(domain_error(directive, Functor/Arity), directive(Dir))). % '$lgt_tr_file_directive'(@nonvar) '$lgt_tr_file_directive'(op(Pr, Spec, Ops)) :- % op/3 directives must be used during entity compilation !, ( '$lgt_valid_op_priority'(Pr) -> ( '$lgt_valid_op_specifier'(Spec) -> ( '$lgt_valid_op_names'(Ops) -> assertz('$lgt_pp_directive_'(op(Pr, Spec, Ops))), assertz('$lgt_pp_file_op_'(op(Pr, Spec, Ops))), op(Pr, Spec, Ops) ; throw(type_error(operator_name, Ops)) ) ; throw(type_error(operator_specifier, Spec)) ) ; throw(type_error(operator_priority, Pr)) ). '$lgt_tr_file_directive'(initialization(Goal)) :- !, ( callable(Goal) -> assertz('$lgt_pp_file_init_'(Goal)) ; throw(type_error(callable, Goal)) ). '$lgt_tr_file_directive'(Dir) :- assertz('$lgt_pp_directive_'(Dir)). % directive will be copied to the generated Prolog file % '$lgt_tr_directive'(+atom, +list, @stream, @stream) % % translates a directive and its (possibly empty) list of arguments '$lgt_tr_directive'(object, [Obj| _], _, _) :- var(Obj), throw(instantiation_error). '$lgt_tr_directive'(object, [Obj| _], _, _) :- \+ callable(Obj), throw(type_error(object_identifier, Obj)). '$lgt_tr_directive'(object, [Obj| _], _, _) :- ( '$lgt_built_in_object'(Obj) -> throw(permission_error(modify, object, Obj)) ; '$lgt_built_in_protocol'(Obj) -> throw(permission_error(modify, protocol, Obj)) ; '$lgt_built_in_category'(Obj) -> throw(permission_error(modify, category, Obj)) ). '$lgt_tr_directive'(object, [Obj| Rels], _, _) :- '$lgt_report_compiling_entity'(object, Obj), '$lgt_tr_object_id'(Obj, static), % assume static object '$lgt_tr_object_relations'(Rels, Obj), '$lgt_save_file_op_table'. '$lgt_tr_directive'(end_object, [], _, Output) :- ( '$lgt_pp_object_'(Obj, _, _, _, _, _, _, _, _, _, _) -> '$lgt_tr_entity'(object, Obj, Output), '$lgt_report_compiled_entity'(object, Obj) ; throw(closing_directive_mismatch) ). '$lgt_tr_directive'(protocol, [Ptc| _], _, _) :- var(Ptc), throw(instantiation_error). '$lgt_tr_directive'(protocol, [Ptc| _], _, _) :- \+ atom(Ptc), throw(type_error(protocol_identifier, Ptc)). '$lgt_tr_directive'(protocol, [Ptc| _], _, _) :- ( '$lgt_built_in_object'(Ptc) -> throw(permission_error(modify, object, Ptc)) ; '$lgt_built_in_protocol'(Ptc) -> throw(permission_error(modify, protocol, Ptc)) ; '$lgt_built_in_category'(Ptc) -> throw(permission_error(modify, category, Ptc)) ). '$lgt_tr_directive'(protocol, [Ptc| Rels], _, _) :- '$lgt_report_compiling_entity'(protocol, Ptc), '$lgt_tr_protocol_id'(Ptc, static), % assume static protocol '$lgt_tr_protocol_relations'(Rels, Ptc), '$lgt_save_file_op_table'. '$lgt_tr_directive'(end_protocol, [], _, Output) :- '$lgt_pp_protocol_'(Ptc, _, _, _, _) -> '$lgt_tr_entity'(protocol, Ptc, Output), '$lgt_report_compiled_entity'(protocol, Ptc) ; throw(closing_directive_mismatch). '$lgt_tr_directive'(category, [Ctg| _], _, _) :- var(Ctg), throw(instantiation_error). '$lgt_tr_directive'(category, [Ctg| _], _, _) :- \+ atom(Ctg), throw(type_error(category_identifier, Ctg)). '$lgt_tr_directive'(category, [Ctg| _], _, _) :- ( '$lgt_built_in_object'(Ctg) -> throw(permission_error(modify, object, Ctg)) ; '$lgt_built_in_protocol'(Ctg) -> throw(permission_error(modify, protocol, Ctg)) ; '$lgt_built_in_category'(Ctg) -> throw(permission_error(modify, category, Ctg)) ). '$lgt_tr_directive'(category, [Ctg| Rels], _, _) :- '$lgt_report_compiling_entity'(category, Ctg), '$lgt_tr_category_id'(Ctg, static), % assume static category '$lgt_tr_category_relations'(Rels, Ctg), '$lgt_save_file_op_table'. '$lgt_tr_directive'(end_category, [], _, Output) :- ( '$lgt_pp_category_'(Ctg, _, _, _, _, _) -> '$lgt_tr_entity'(category, Ctg, Output), '$lgt_report_compiled_entity'(category, Ctg) ; throw(closing_directive_mismatch) ). % compile modules as objects '$lgt_tr_directive'(module, [Module], Input, Output) :- !, '$lgt_tr_directive'(module, [Module, []], Input, Output). % empty export list '$lgt_tr_directive'(module, [Module, ExportList], _, _) :- (var(Module); var(ExportList)), throw(instantiation_error). '$lgt_tr_directive'(module, [Module, _], _, _) :- \+ atom(Module), throw(type_error(module_identifier, Module)). '$lgt_tr_directive'(module, [Module, ExportList], Input, Output) :- assertz('$lgt_pp_module_'(Module)), % remeber we are compiling a module '$lgt_report_compiling_entity'(module, Module), '$lgt_tr_object_id'(Module, static), % assume static module/object '$lgt_tr_directive'((public), ExportList, Input, Output), % make the export list public predicates '$lgt_save_file_op_table'. % create a message queue at object initialization '$lgt_tr_directive'(threaded, [], _, _) :- \+ '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _), throw(domain_error(object_directive, threaded/0)). '$lgt_tr_directive'(threaded, [], _, _) :- \+ '$lgt_compiler_flag'(threads, on), throw(error(resource_error(threads), threaded/0)). '$lgt_tr_directive'(threaded, [], _, _) :- !, assertz('$lgt_pp_threaded_'). % make all object (or category) predicates synchronized using the same mutex '$lgt_tr_directive'(synchronized, [], _, _) :- \+ '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _), \+ '$lgt_pp_category_'(_, _, _, _, _, _), throw(domain_error(directive, synchronized/0)). '$lgt_tr_directive'(synchronized, [], _, _) :- !, ( '$lgt_default_flag'(threads, on) -> '$lgt_pp_entity'(_, _, Prefix, _, _), atom_concat(Prefix, 'mutex_', Mutex), assertz('$lgt_pp_synchronized_'), assertz('$lgt_pp_synchronized_'(_, Mutex)) ; true ). % dynamic entity directive '$lgt_tr_directive'((dynamic), [], _, _) :- !, '$lgt_update_entity_comp_mode'. '$lgt_tr_directive'(initialization, [Goal], _, _) :- var(Goal), throw(instantiation_error). '$lgt_tr_directive'(initialization, [Goal], _, _) :- \+ callable(Goal), throw(type_error(callable, Goal)). '$lgt_tr_directive'(initialization, [Goal], _, _) :- '$lgt_pp_entity'(_, Entity, Prefix, _, _), '$lgt_ctx_ctx'(Ctx, _, Entity, Entity, Entity, Prefix, [], _), '$lgt_tr_body'(Goal, TGoal, _, Ctx), assertz('$lgt_pp_entity_init_'(TGoal)). '$lgt_tr_directive'(op, [Pr, Spec, Ops], _, _) :- (var(Pr); var(Spec); var(Ops)), throw(instantiation_error). '$lgt_tr_directive'(op, [Pr, _, _], _, _) :- \+ '$lgt_valid_op_priority'(Pr), throw(type_error(operator_priority, Pr)). '$lgt_tr_directive'(op, [_, Spec, _], _, _) :- \+ '$lgt_valid_op_specifier'(Spec), throw(type_error(operator_specifier, Spec)). '$lgt_tr_directive'(op, [_, _, Ops], _, _) :- \+ '$lgt_valid_op_names'(Ops), throw(type_error(operator_name, Ops)). '$lgt_tr_directive'(op, [Pr, Spec, Ops], _, _) :- op(Pr, Spec, Ops), '$lgt_assert_entity_ops'(Pr, Spec, Ops). '$lgt_tr_directive'(uses, [Obj, Preds], _, _) :- (var(Obj); var(Preds)), throw(instantiation_error). '$lgt_tr_directive'(uses, [Obj, _], _, _) :- \+ callable(Obj), throw(type_error(object_identifier, Obj)). '$lgt_tr_directive'(uses, [_, Preds], _, _) :- \+ '$lgt_is_proper_list'(Preds), throw(type_error(list, Preds)). '$lgt_tr_directive'(uses, [Obj, Preds], _, _) :- !, assertz('$lgt_pp_referenced_object_'(Obj)), assertz('$lgt_pp_uses_'(Obj)), '$lgt_tr_uses_preds'(Preds, Obj). '$lgt_tr_directive'(uses, [Obj], _, _) :- var(Obj), throw(instantiation_error). '$lgt_tr_directive'(uses, [Obj], _, _) :- \+ callable(Obj), throw(type_error(object_identifier, Obj)). '$lgt_tr_directive'(uses, [Obj], _, _) :- assertz('$lgt_pp_referenced_object_'(Obj)), assertz('$lgt_pp_uses_'(Obj)). '$lgt_tr_directive'(use_module, [Module, Preds], Input, Output) :- % module directive ( atom(Module) -> Name = Module ; arg(1, Module, Name) ), '$lgt_tr_directive'(uses, [Name, Preds], Input, Output). '$lgt_tr_directive'(calls, Ptcs, _, _) :- '$lgt_flatten_list'(Ptcs, Ptcs2), '$lgt_tr_calls_directive'(Ptcs2). '$lgt_tr_directive'(info, [List], _, _) :- !, ( '$lgt_valid_entity_info_list'(List) -> assertz('$lgt_pp_info_'(List)) ; throw(type_error(entity_info_list, List)) ). '$lgt_tr_directive'(info, [Pred, List], _, _) :- ( nonvar(Pred) -> ( '$lgt_valid_pred_or_gr_ind'(Pred, Functor, Arity) -> '$lgt_tr_pred_info_list'(List, Functor, Arity), assertz('$lgt_pp_info_'(Pred, List)) ; throw(type_error(predicate_indicator, Pred)) ) ; throw(instantiation_error) ). '$lgt_tr_directive'(synchronized, Preds, Input, _) :- ( '$lgt_default_flag'(threads, on) -> ( '$lgt_pp_synchronized_' -> '$lgt_pp_entity'(Type, _, _, _, _), '$lgt_inc_compile_warnings_counter', nl, write(' WARNING! Ignoring synchronized predicate directive: '), write(Type), write(' already declared as synchronized!'), nl, '$lgt_report_compiler_error_line_number'(Input) ; '$lgt_flatten_list'(Preds, Preds2), '$lgt_tr_synchronized_directive'(Preds2) ) ; true ). '$lgt_tr_directive'((public), Preds, _, _) :- '$lgt_flatten_list'(Preds, Preds2), '$lgt_tr_public_directive'(Preds2). '$lgt_tr_directive'((export), Preds, _, _) :- % module directive '$lgt_flatten_list'(Preds, Preds2), '$lgt_tr_public_directive'(Preds2). '$lgt_tr_directive'(protected, Preds, _, _) :- '$lgt_flatten_list'(Preds, Preds2), '$lgt_tr_protected_directive'(Preds2). '$lgt_tr_directive'(private, Preds, _, _) :- '$lgt_flatten_list'(Preds, Preds2), '$lgt_tr_private_directive'(Preds2). '$lgt_tr_directive'((dynamic), Preds, _, _) :- '$lgt_flatten_list'(Preds, Preds2), '$lgt_tr_dynamic_directive'(Preds2). '$lgt_tr_directive'((discontiguous), Preds, _, _) :- '$lgt_flatten_list'(Preds, Preds2), '$lgt_tr_discontiguous_directive'(Preds2). '$lgt_tr_directive'(metapredicate, Preds, _, _) :- % depracated '$lgt_flatten_list'(Preds, Preds2), '$lgt_normalize_meta_predicate_args'(Preds2, Preds3), '$lgt_tr_meta_predicate_directive'(Preds3). '$lgt_tr_directive'(meta_predicate, Preds, _, _) :- '$lgt_flatten_list'(Preds, Preds2), '$lgt_normalize_meta_predicate_args'(Preds2, Preds3), '$lgt_tr_meta_predicate_directive'(Preds3). '$lgt_tr_directive'((mode), [Mode, Solutions], _, _) :- (var(Mode); var(Solutions)), throw(instantiation_error). '$lgt_tr_directive'((mode), [Mode, _], _, _) :- \+ '$lgt_valid_mode_term'(Mode), throw(type_error(mode_term, Mode)). '$lgt_tr_directive'((mode), [_, Solutions], _, _) :- \+ '$lgt_valid_number_of_solutions'(Solutions), throw(type_error(number_of_solutions, Solutions)). '$lgt_tr_directive'((mode), [Mode, Solutions], _, _) :- assertz('$lgt_pp_mode_'(Mode, Solutions)). '$lgt_tr_directive'(alias, [Entity, PI1, PI2], _, _) :- (var(Entity); var(PI1); var(PI2)), throw(instantiation_error). '$lgt_tr_directive'(alias, [_, PI1, _], _, _) :- \+ '$lgt_valid_pred_ind'(PI1, _, _), \+ '$lgt_valid_gr_ind'(PI1, _, _, _), throw(type_error(predicate_indicator, PI1)). '$lgt_tr_directive'(alias, [_, _, PI2], _, _) :- \+ '$lgt_valid_pred_ind'(PI2, _, _), \+ '$lgt_valid_gr_ind'(PI2, _, _, _), throw(type_error(predicate_indicator, PI2)). '$lgt_tr_directive'(alias, [Entity, _, _], _, _) :- \+ callable(Entity), throw(type_error(entity_identifier, Entity)). '$lgt_tr_directive'(alias, [_, Functor1//Arity1, Functor2//Arity2], _, _) :- Arity1 =\= Arity2, throw(domain_error(arity_mismatch, Functor1//Arity1, Functor2//Arity2)). '$lgt_tr_directive'(alias, [_, Functor1/Arity1, Functor2/Arity2], _, _) :- Arity1 =\= Arity2, throw(domain_error(arity_mismatch, Functor1/Arity1, Functor2/Arity2)). '$lgt_tr_directive'(alias, [_, Functor1/Arity1, Functor2//Arity2], _, _) :- throw(domain_error(indicator_mismatch, Functor1/Arity1, Functor2//Arity2)). '$lgt_tr_directive'(alias, [_, Functor1//Arity1, Functor2/Arity2], _, _) :- throw(domain_error(indicator_mismatch, Functor1//Arity1, Functor2/Arity2)). '$lgt_tr_directive'(alias, [Entity, PI1, PI2], _, _) :- ( '$lgt_pp_extended_protocol_'(Entity, _, _, _) ; '$lgt_pp_implemented_protocol_'(Entity, _, _, _) ; '$lgt_pp_imported_category_'(Entity, _, _, _, _) ; '$lgt_pp_extended_object_'(Entity, _, _, _, _, _, _, _, _, _) ; '$lgt_pp_instantiated_class_'(Entity, _, _, _, _, _, _, _, _, _) ; '$lgt_pp_specialized_class_'(Entity, _, _, _, _, _, _, _, _, _) ), !, '$lgt_tr_alias_directive'(Entity, PI1, PI2). '$lgt_tr_directive'(alias, [Entity, _, _], _, _) :- throw(reference_error(entity_identifier, Entity)). '$lgt_tr_alias_directive'(Entity, Functor1//Arity, Functor2//Arity) :- Arity2 is Arity + 2, '$lgt_tr_alias_directive'(Entity, Functor1/Arity2, Functor2/Arity2). '$lgt_tr_alias_directive'(Entity, Functor1/Arity, Functor2/Arity) :- functor(Pred, Functor1, Arity), Pred =.. [_| Args], Alias =.. [Functor2| Args], assertz('$lgt_pp_alias_'(Entity, Pred, Alias)). '$lgt_tr_calls_directive'([]). '$lgt_tr_calls_directive'([Ptc| _]) :- var(Ptc), throw(instantiation_error). '$lgt_tr_calls_directive'([Ptc| _]) :- \+ atom(Ptc), throw(type_error(protocol_identifier, Ptc)). '$lgt_tr_calls_directive'([Ptc| Ptcs]) :- assertz('$lgt_pp_referenced_protocol_'(Ptc)), assertz('$lgt_pp_calls_'(Ptc)), '$lgt_tr_calls_directive'(Ptcs). '$lgt_tr_synchronized_directive'(Preds) :- '$lgt_gen_pred_mutex'(Mutex), '$lgt_tr_synchronized_directive'(Preds, Mutex). '$lgt_gen_pred_mutex'(Mutex) :- '$lgt_pp_entity'(_, _, Prefix, _, _), retract('$lgt_pp_pred_mutex_count_'(Old)), New is Old + 1, asserta('$lgt_pp_pred_mutex_count_'(New)), number_codes(New, Codes), atom_codes(Atom, Codes), atom_concat(Prefix, 'pred_mutex_', Aux), atom_concat(Aux, Atom, Mutex). '$lgt_tr_synchronized_directive'([], _). '$lgt_tr_synchronized_directive'([Pred| _], _) :- var(Pred), throw(instantiation_error). '$lgt_tr_synchronized_directive'([Pred| Preds], Mutex) :- '$lgt_valid_pred_ind'(Pred, Functor, Arity), !, functor(Head, Functor, Arity), ( '$lgt_pp_calls_pred_'(Functor, Arity, _, _) -> throw(permission_error(modify, predicate_interpretation, Pred)) ; assertz('$lgt_pp_synchronized_'(Head, Mutex)), '$lgt_tr_synchronized_directive'(Preds, Mutex) ). '$lgt_tr_synchronized_directive'([Pred| Preds], Mutex) :- '$lgt_valid_gr_ind'(Pred, Functor, Arity, Arity2), !, functor(Head, Functor, Arity2), ( '$lgt_pp_calls_nt_'(Functor, Arity) -> throw(permission_error(modify, non_terminal_interpretation, Pred)) ; assertz('$lgt_pp_synchronized_'(Head, Mutex)), '$lgt_tr_synchronized_directive'(Preds, Mutex) ). '$lgt_tr_synchronized_directive'([Pred| _], _) :- throw(type_error(predicate_indicator, Pred)). '$lgt_tr_public_directive'([]). '$lgt_tr_public_directive'([Pred| _]) :- var(Pred), throw(instantiation_error). '$lgt_tr_public_directive'([Pred| _]) :- functor(Pred, Functor, Arity), '$lgt_pp_calls_pred_'(Functor, Arity, _, _), throw(permission_error(modify, predicate_interpretation, Pred)). '$lgt_tr_public_directive'([Pred| Preds]) :- '$lgt_valid_pred_ind'(Pred, Functor, Arity), !, \+ '$lgt_duplicated_scope_directives'(Pred, Functor, Arity), assertz('$lgt_pp_public_'(Functor, Arity)), '$lgt_tr_public_directive'(Preds). '$lgt_tr_public_directive'([Pred| Preds]) :- '$lgt_valid_gr_ind'(Pred, Functor, Arity, Arity2), !, \+ '$lgt_duplicated_scope_directives'(Pred, Functor, Arity2), assertz('$lgt_pp_non_terminal_'(Functor, Arity, Arity2)), assertz('$lgt_pp_public_'(Functor, Arity2)), '$lgt_tr_public_directive'(Preds). '$lgt_tr_public_directive'([Pred| _]) :- throw(type_error(predicate_indicator, Pred)). '$lgt_tr_protected_directive'([]). '$lgt_tr_protected_directive'([Pred| _]) :- var(Pred), throw(instantiation_error). '$lgt_tr_protected_directive'([Pred| _]) :- functor(Pred, Functor, Arity), '$lgt_pp_calls_pred_'(Functor, Arity, _, _), throw(permission_error(modify, predicate_interpretation, Pred)). '$lgt_tr_protected_directive'([Pred| Preds]) :- '$lgt_valid_pred_ind'(Pred, Functor, Arity), !, \+ '$lgt_duplicated_scope_directives'(Pred, Functor, Arity), assertz('$lgt_pp_protected_'(Functor, Arity)), '$lgt_tr_protected_directive'(Preds). '$lgt_tr_protected_directive'([Pred| Preds]) :- '$lgt_valid_gr_ind'(Pred, Functor, Arity, Arity2), !, \+ '$lgt_duplicated_scope_directives'(Pred, Functor, Arity2), assertz('$lgt_pp_non_terminal_'(Functor, Arity, Arity2)), assertz('$lgt_pp_protected_'(Functor, Arity2)), '$lgt_tr_protected_directive'(Preds). '$lgt_tr_protected_directive'([Pred| _]) :- throw(type_error(predicate_indicator, Pred)). '$lgt_tr_private_directive'([]). '$lgt_tr_private_directive'([Pred| _]) :- var(Pred), throw(instantiation_error). '$lgt_tr_private_directive'([Pred| _]) :- functor(Pred, Functor, Arity), '$lgt_pp_calls_pred_'(Functor, Arity, _, _), throw(permission_error(modify, predicate_interpretation, Pred)). '$lgt_tr_private_directive'([Pred| Preds]) :- '$lgt_valid_pred_ind'(Pred, Functor, Arity), !, \+ '$lgt_duplicated_scope_directives'(Pred, Functor, Arity), assertz('$lgt_pp_private_'(Functor, Arity)), '$lgt_tr_private_directive'(Preds). '$lgt_tr_private_directive'([Pred| Preds]) :- '$lgt_valid_gr_ind'(Pred, Functor, Arity, Arity2), !, \+ '$lgt_duplicated_scope_directives'(Pred, Functor, Arity2), assertz('$lgt_pp_non_terminal_'(Functor, Arity, Arity2)), assertz('$lgt_pp_private_'(Functor, Arity2)), '$lgt_tr_private_directive'(Preds). '$lgt_tr_private_directive'([Pred| _]) :- throw(type_error(predicate_indicator, Pred)). '$lgt_duplicated_scope_directives'(Pred, Functor, Arity) :- ( '$lgt_pp_public_'(Functor, Arity) ; '$lgt_pp_protected_'(Functor, Arity) ; '$lgt_pp_private_'(Functor, Arity) ), throw(permission_error(modify, predicate_interpretation, Pred)). '$lgt_tr_dynamic_directive'([]). '$lgt_tr_dynamic_directive'([Pred| _]) :- var(Pred), throw(instantiation_error). '$lgt_tr_dynamic_directive'([Pred| _]) :- functor(Pred, Functor, Arity), '$lgt_pp_calls_pred_'(Functor, Arity, _, _), throw(permission_error(modify, predicate_interpretation, Pred)). '$lgt_tr_dynamic_directive'([Pred| Preds]) :- '$lgt_valid_pred_ind'(Pred, Functor, Arity), !, assertz('$lgt_pp_dynamic_'(Functor, Arity)), '$lgt_tr_dynamic_directive'(Preds). '$lgt_tr_dynamic_directive'([Pred| Preds]) :- '$lgt_valid_gr_ind'(Pred, Functor, _, Arity2), !, assertz('$lgt_pp_dynamic_'(Functor, Arity2)), '$lgt_tr_dynamic_directive'(Preds). '$lgt_tr_dynamic_directive'([Pred| _]) :- throw(type_error(predicate_indicator, Pred)). '$lgt_tr_discontiguous_directive'([]). '$lgt_tr_discontiguous_directive'([Pred| _]) :- var(Pred), throw(instantiation_error). '$lgt_tr_discontiguous_directive'([Pred| _]) :- functor(Pred, Functor, Arity), '$lgt_pp_calls_pred_'(Functor, Arity, _, _), throw(permission_error(modify, predicate_interpretation, Pred)). '$lgt_tr_discontiguous_directive'([Pred| Preds]) :- '$lgt_valid_pred_ind'(Pred, Functor, Arity), !, assertz('$lgt_pp_discontiguous_'(Functor, Arity)), '$lgt_tr_discontiguous_directive'(Preds). '$lgt_tr_discontiguous_directive'([Pred| Preds]) :- '$lgt_valid_gr_ind'(Pred, Functor, _, Arity2), !, assertz('$lgt_pp_discontiguous_'(Functor, Arity2)), '$lgt_tr_discontiguous_directive'(Preds). '$lgt_tr_discontiguous_directive'([Pred| _]) :- throw(type_error(predicate_indicator, Pred)). '$lgt_tr_meta_predicate_directive'([]). '$lgt_tr_meta_predicate_directive'([Pred| _]) :- var(Pred), throw(instantiation_error). '$lgt_tr_meta_predicate_directive'([Pred| _]) :- \+ '$lgt_valid_metapred_term'(Pred), throw(type_error(meta_predicate_term, Pred)). '$lgt_tr_meta_predicate_directive'([Pred| _]) :- functor(Pred, Functor, Arity), '$lgt_pp_calls_pred_'(Functor, Arity, _, _), throw(permission_error(modify, predicate_interpretation, Pred)). '$lgt_tr_meta_predicate_directive'([Pred| Preds]) :- assertz('$lgt_pp_meta_predicate_'(Pred)), '$lgt_tr_meta_predicate_directive'(Preds). % '$lgt_tr_uses_preds'(+list, +object_identifier) % % auxiliary predicate for translating uses/2 directives '$lgt_tr_uses_preds'([], _). '$lgt_tr_uses_preds'([Pred| Preds], Obj) :- ( nonvar(Pred) -> true ; throw(instantiation_error) ), ( Pred = (Original::Alias) -> true ; (Original, Alias) = (Pred, Pred) ), ( (nonvar(Original), nonvar(Alias)) -> true ; throw(instantiation_error) ), ( '$lgt_valid_pred_ind'(Original, OFunctor, OArity) -> functor(TOriginal, OFunctor, OArity) ; throw(type_error(predicate_indicator, Original)) ), ( '$lgt_valid_pred_ind'(Alias, AFunctor, AArity) -> functor(TAlias, AFunctor, AArity) ; throw(type_error(predicate_indicator, Alias)) ), ( OArity =:= AArity -> true ; throw(domain_error(arity_mismatch(Original, Alias))) ), ( \+ '$lgt_pp_uses_'(_, _, TAlias) -> TOriginal =.. [_| Args], TAlias =.. [_| Args], % unify args of TOriginal and TAlias assertz('$lgt_pp_uses_'(Obj, TOriginal, TAlias)) ; functor(TAlias, Functor, Arity), throw(permission_error(modify, uses_object_predicate, Functor/Arity)) ), '$lgt_tr_uses_preds'(Preds, Obj). % auxiliary predicate for converting module's meta predicate declarations into % Logtalk ones (: -> ::) '$lgt_normalize_meta_predicate_args'([], []). '$lgt_normalize_meta_predicate_args'([Pred| Preds], [Pred2| Preds2]) :- ( nonvar(Pred) -> true ; throw(instantiation_error) ), Pred =.. [Functor| Args], '$lgt_convert_meta_predicate_mode_spec'(Args, Args2), Pred2 =.. [Functor| Args2], '$lgt_normalize_meta_predicate_args'(Preds, Preds2). '$lgt_convert_meta_predicate_mode_spec'([], []). '$lgt_convert_meta_predicate_mode_spec'([Arg| Args], [Arg2| Args2]) :- ( Arg == (:) -> Arg2 = (::) ; Arg == (::) -> Arg2 = (::) % just to be safe... ; integer(Arg) -> Arg2 = Arg ; Arg2 = (*) ), '$lgt_convert_meta_predicate_mode_spec'(Args, Args2). % '$lgt_tr_object_relations'(+list, +term) % % translates the relations of an object with other entities '$lgt_tr_object_relations'([], _). '$lgt_tr_object_relations'([Relation| Relations], Obj) :- ( var(Relation) -> throw(instantiation_error) ; Relation =.. [Functor| Args], '$lgt_tr_object_relation'(Functor, Args, Obj) -> true ; functor(Relation, Functor, Arity), throw(domain_error(object_relation, Functor/Arity)) ), '$lgt_tr_object_relations'(Relations, Obj). % '$lgt_tr_object_relation'(+atom, +list, +term) % % translates a relation between an object (the last argument) with other entities '$lgt_tr_object_relation'(implements, Ptcs, Obj) :- '$lgt_flatten_list'(Ptcs, List), '$lgt_tr_implements_protocol'(List, Obj). '$lgt_tr_object_relation'(imports, Ctgs, Obj) :- '$lgt_flatten_list'(Ctgs, List), '$lgt_tr_imports_category'(List, Obj). '$lgt_tr_object_relation'(instantiates, Classes, Obj) :- '$lgt_flatten_list'(Classes, List), '$lgt_tr_instantiates_class'(List, Obj). '$lgt_tr_object_relation'(specializes, Superclasses, Class) :- '$lgt_flatten_list'(Superclasses, List), '$lgt_tr_specializes_class'(List, Class). '$lgt_tr_object_relation'(extends, Parents, Prototype) :- '$lgt_flatten_list'(Parents, List), '$lgt_tr_extends_object'(List, Prototype). % '$lgt_tr_protocol_relations'(+list, +term) % % translates the relations of a protocol with other entities '$lgt_tr_protocol_relations'([], _). '$lgt_tr_protocol_relations'([Relation| Relations], Ptc) :- ( var(Relation) -> throw(instantiation_error) ; Relation =.. [Functor| Args], '$lgt_tr_protocol_relation'(Functor, Args, Ptc) -> true ; functor(Relation, Functor, Arity), throw(domain_error(protocol_relation, Functor/Arity)) ), '$lgt_tr_protocol_relations'(Relations, Ptc). % '$lgt_tr_protocol_relation'(+atom, +list, +term) % % translates a relation between a protocol (the last argument) with other entities '$lgt_tr_protocol_relation'(extends, Ptcs, Ptc) :- '$lgt_flatten_list'(Ptcs, List), '$lgt_tr_extends_protocol'(List, Ptc). % '$lgt_tr_category_relations'(+list, +term) % % translates the relations of a category with other entities '$lgt_tr_category_relations'([], _). '$lgt_tr_category_relations'([Relation| Relations], Ptc) :- ( var(Relation) -> throw(instantiation_error) ; Relation =.. [Functor| Args], '$lgt_tr_category_relation'(Functor, Args, Ptc) -> true ; functor(Relation, Functor, Arity), throw(domain_error(category_relation, Functor/Arity)) ), '$lgt_tr_category_relations'(Relations, Ptc). % '$lgt_tr_category_relation'(+atom, +list, +term) % % translates a relation between a category (the last argument) with other entities '$lgt_tr_category_relation'(implements, Ptcs, Ctg) :- '$lgt_flatten_list'(Ptcs, List), '$lgt_tr_implements_protocol'(List, Ctg). '$lgt_tr_category_relation'(imports, Ctgs, Ctg) :- '$lgt_flatten_list'(Ctgs, List), '$lgt_tr_imports_category'(List, Ctg). % '$lgt_valid_entity_info_list'(@list) % % true if the argument is a list of valid key-value pairs '$lgt_valid_entity_info_list'(List) :- var(List), throw(instantiation_error). '$lgt_valid_entity_info_list'(List) :- \+ '$lgt_is_proper_list'(List), throw(type_error(list, List)). '$lgt_valid_entity_info_list'([]). '$lgt_valid_entity_info_list'([Head| _]) :- var(Head), throw(instantiation_error). '$lgt_valid_entity_info_list'([Head| _]) :- Head \= (_ is _), throw(type_error(key_value_info_pair, Head)). '$lgt_valid_entity_info_list'([Key is Value| _]) :- (var(Key); var(Value)), throw(instantiation_error). '$lgt_valid_entity_info_list'([Key is _| _]) :- \+ atom(Key), throw(type_error(atom, Key)). '$lgt_valid_entity_info_list'([Key is Value| Tail]) :- '$lgt_valid_entity_info_key_value'(Key, Value), '$lgt_valid_entity_info_list'(Tail). % '$lgt_valid_entity_info_key_value'(+atom, @nonvar) % % true if the argument is a valid key-value pair '$lgt_valid_entity_info_key_value'(author, Author) :- !, ( (atom(Author); nonvar(Author), Author = {EntityName}, atom(EntityName)) -> true ; throw(type_error(atom, Author)) ). '$lgt_valid_entity_info_key_value'(comment, Comment) :- !, ( atom(Comment) -> true ; throw(type_error(atom, Comment)) ). '$lgt_valid_entity_info_key_value'(date, Date) :- !, ( Date = Year/Month/Day -> ( integer(Year) -> ( integer(Month) -> ( integer(Day) -> true ; throw(type_error(integer, Day)) ) ; throw(type_error(integer, Month)) ) ; throw(type_error(integer, Year)) ) ; throw(type_error(date, Date)) ). '$lgt_valid_entity_info_key_value'(parameters, Parameters) :- !, ( '$lgt_is_proper_list'(Parameters) -> ( '$lgt_member'(Parameter, Parameters), \+ '$lgt_valid_entity_parameter'(Parameter) -> throw(type_error(parameter, Parameter)) ; ( ('$lgt_pp_object_'(Obj, _, _, _, _, _, _, _, _, _, _), \+ \+ Obj =.. [_| Parameters]) -> true ; throw(length_error(parameters_list, Parameters)) ) ) ; throw(type_error(list, Parameters)) ). '$lgt_valid_entity_info_key_value'(parnames, Parnames) :- !, ( '$lgt_is_proper_list'(Parnames) -> ( '$lgt_member'(Name, Parnames), \+ atom(Name) -> throw(type_error(atom, Name)) ; ( '$lgt_pp_object_'(Obj, _, _, _, _, _, _, _, _, _, _), \+ \+ Obj =.. [_| Parnames] -> true ; throw(length_error(parnames_list, Parnames)) ) ) ; throw(type_error(list, Parnames)) ). '$lgt_valid_entity_info_key_value'(version, Version) :- !, ( atomic(Version) -> true ; throw(type_error(atomic, Version)) ). '$lgt_valid_entity_info_key_value'(copyright, Copyright) :- !, ( (atom(Copyright); nonvar(Copyright), Copyright = {EntityName}, atom(EntityName)) -> true ; throw(type_error(atom, Copyright)) ). '$lgt_valid_entity_info_key_value'(license, License) :- !, ( (atom(License); nonvar(License), License = {EntityName}, atom(EntityName)) -> true ; throw(type_error(atom, License)) ). '$lgt_valid_entity_info_key_value'(_, _). % '$lgt_tr_pred_info_list'(@list, +atom, +integer) % % true if the argument is a list of valid key-value pairs '$lgt_tr_pred_info_list'(List, _, _) :- var(List), throw(instantiation_error). '$lgt_tr_pred_info_list'(List, _, _) :- \+ '$lgt_is_proper_list'(List), throw(type_error(list, List)). '$lgt_tr_pred_info_list'([], _, _). '$lgt_tr_pred_info_list'([Head| _], _, _) :- var(Head), throw(instantiation_error). '$lgt_tr_pred_info_list'([Head| _], _, _) :- Head \= (_ is _), throw(type_error(key_value_info_pair, Head)). '$lgt_tr_pred_info_list'([Key is Value| _], _, _) :- (var(Key); var(Value)), throw(instantiation_error). '$lgt_tr_pred_info_list'([Key is _| _], _, _) :- \+ atom(Key), throw(type_error(atom, Key)). '$lgt_tr_pred_info_list'([Key is Value| Tail], Functor, Arity) :- '$lgt_tr_pred_info_key_value'(Key, Value, Functor, Arity), '$lgt_tr_pred_info_list'(Tail, Functor, Arity). % '$lgt_tr_pred_info_key_value'(+atom, @nonvar, +atom, +integer) % % true if the argument is a valid key-value pair '$lgt_tr_pred_info_key_value'(allocation, Allocation, _, _) :- !, ( atom(Allocation) -> ( '$lgt_valid_pred_allocation'(Allocation) -> true ; throw(domain_error(allocation, Allocation)) ) ; throw(type_error(atom, Allocation)) ). '$lgt_tr_pred_info_key_value'(arguments, Arguments, Functor, Arity) :- !, ( '$lgt_is_proper_list'(Arguments) -> ( '$lgt_member'(Argument, Arguments), \+ '$lgt_valid_pred_argument'(Argument) -> throw(type_error(argument, Argument)) ; ( functor(Pred, Functor, Arity), Pred =.. [_| Arguments] -> true ; throw(length_error(arguments_list, Arguments)) ) ) ; throw(type_error(list, Arguments)) ). '$lgt_tr_pred_info_key_value'(argnames, Argnames, Functor, Arity) :- !, ( '$lgt_is_proper_list'(Argnames) -> ( '$lgt_member'(Name, Argnames), \+ atom(Name) -> throw(type_error(atom, Name)) ; ( functor(Pred, Functor, Arity), Pred =.. [_| Argnames] -> true ; throw(length_error(argnames_list, Argnames)) ) ) ; throw(type_error(list, Argnames)) ). '$lgt_tr_pred_info_key_value'(comment, Comment, _, _) :- !, ( atom(Comment) -> true ; throw(type_error(atom, Comment)) ). '$lgt_tr_pred_info_key_value'(exceptions, Exceptions, _, _) :- !, ( '$lgt_is_proper_list'(Exceptions) -> ( '$lgt_member'(Exception, Exceptions), \+ '$lgt_valid_pred_exception'(Exception) -> throw(type_error(exception, Exception)) ; true ) ; throw(type_error(list, Exceptions)) ). '$lgt_tr_pred_info_key_value'(examples, Examples, Functor, Arity) :- !, ( '$lgt_is_proper_list'(Examples) -> ( '$lgt_member'(Example, Examples), \+ '$lgt_valid_pred_call_example'(Example, Functor, Arity) -> throw(type_error(example, Example)) ; true ) ; throw(type_error(list, Examples)) ). '$lgt_tr_pred_info_key_value'(redefinition, Redefinition, _, _) :- !, ( atom(Redefinition) -> ( '$lgt_valid_pred_redefinition'(Redefinition) -> true ; throw(domain_error(redefinition, Redefinition)) ) ; throw(type_error(atom, Redefinition)) ). '$lgt_tr_pred_info_key_value'(_, _, _, _). % '$lgt_tr_clauses'(+list, @stream) '$lgt_tr_clauses'([], _). '$lgt_tr_clauses'([Clause| Clauses], Input) :- '$lgt_tr_clause'(Clause, Input), '$lgt_tr_clauses'(Clauses, Input). % '$lgt_tr_clause'(+clause, @stream) '$lgt_tr_clause'(Clause, _) :- \+ '$lgt_pp_entity'(_, _, _, _, _), % all clause occuring before an opening entity directive !, assertz('$lgt_pp_ppclause_'(Clause)). % are copied unchanged to the generated Prolog file '$lgt_tr_clause'(Clause, Input) :- '$lgt_pp_entity'(Type, Entity, Prefix, _, _), ( Type == object, compound(Entity) -> % if the entity is a parametric object we need '$lgt_ctx_this'(Ctx, Entity) % "this" for inline compilation of parameter/2 ; true ), '$lgt_ctx_prefix'(Ctx, Prefix), catch( '$lgt_tr_clause'(Clause, TClause, DClause, Ctx, Input), Error, throw(error(Error, clause(Clause)))), ( '$lgt_compiler_flag'(debug, on) -> assertz('$lgt_pp_eclause_'(DClause)) ; assertz('$lgt_pp_eclause_'(TClause)) ), !. '$lgt_tr_clause'(Clause, _) :- throw(error(unknown_error, clause(Clause))). % '$lgt_tr_clause'(+clause, -clause, -clause, +term, @stream) '$lgt_tr_clause'(Clause, _, _, _, _) :- var(Clause), throw(instantiation_error). '$lgt_tr_clause'((Head:-Body), _, _, _, _) :- (var(Head); var(Body)), throw(instantiation_error). '$lgt_tr_clause'((Head:-_), _, _, _, _) :- \+ callable(Head), throw(type_error(callable, Head)). '$lgt_tr_clause'((_:-Body), _, _, _, _) :- \+ callable(Body), throw(type_error(callable, Body)). '$lgt_tr_clause'((Head:-Body), (THead:-'$lgt_nop'(Body), SBody), (THead:-'$lgt_nop'(Body),'$lgt_dbg_head'(Head, DbgCtx),DBody), Ctx, Input) :- functor(Head, Functor, Arity), '$lgt_pp_dynamic_'(Functor, Arity), !, '$lgt_pred_meta_vars'(Head, MetaVars), '$lgt_ctx_meta_vars'(Ctx, MetaVars), '$lgt_tr_head'(Head, THead, Ctx, Input), '$lgt_tr_body'(Body, TBody, DBody, Ctx), '$lgt_simplify_body'(TBody, SBody), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx). '$lgt_tr_clause'((Head:-Body), TClause, (THead:-'$lgt_dbg_head'(Head, DbgCtx),DBody), Ctx, Input) :- !, '$lgt_pred_meta_vars'(Head, MetaVars), '$lgt_ctx_meta_vars'(Ctx, MetaVars), '$lgt_tr_head'(Head, THead, Ctx, Input), '$lgt_tr_body'(Body, TBody, DBody, Ctx), '$lgt_simplify_body'(TBody, SBody), ( SBody == true -> TClause = THead ; TClause = (THead:-SBody) ), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx). '$lgt_tr_clause'(Fact, _, _, _, _) :- \+ callable(Fact), throw(type_error(callable, Fact)). '$lgt_tr_clause'(Fact, TFact, (TFact:-'$lgt_dbg_fact'(Fact, DbgCtx)), Ctx, Input) :- '$lgt_tr_head'(Fact, TFact, Ctx, Input), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx). % '$lgt_tr_head'(+callable, -callable, +term, @stream, @stream) % % translates an entity clause head % definition of dynamic predicates inside categories '$lgt_tr_head'(Head, _, _, _) :- '$lgt_pp_category_'(_, _, _, _, _, _), functor(Head, Functor, Arity), '$lgt_pp_dynamic_'(Functor, Arity), throw(permission_error(define, dynamic_predicate, Functor/Arity)). % redefinition of Logtalk message sending and remaining control constructs '$lgt_tr_head'(_::_, _, _, _) :- throw(permission_error(modify, control_construct, (::)/2)). '$lgt_tr_head'(::_, _, _, _) :- throw(permission_error(modify, control_construct, (::)/1)). '$lgt_tr_head'(^^_, _, _, _) :- throw(permission_error(modify, control_construct, (^^)/1)). '$lgt_tr_head'({_}, _, _, _) :- throw(permission_error(modify, control_construct, ({})/1)). '$lgt_tr_head'(_<<_, _, _, _) :- throw(permission_error(modify, control_construct, (<<)/2)). '$lgt_tr_head'(':'(_), _, _, _) :- throw(permission_error(modify, control_construct, (:)/1)). % redefinition of Logtalk built-in methods '$lgt_tr_head'(Head, _, _, _) :- '$lgt_built_in_method'(Head, _), functor(Head, Functor, Arity), throw(permission_error(modify, built_in_method, Functor/Arity)). % conflict with a predicate specified in a uses/2 directive '$lgt_tr_head'(Alias, _, _, _) :- '$lgt_pp_uses_'(_, _, Alias), functor(Alias, Functor, Arity), throw(permission_error(modify, uses_object_predicate, Functor/Arity)). % non-variable meta-argument in clause head of a user-defined meta-predicate '$lgt_tr_head'(Head, _, _, _) :- functor(Head, Functor, Arity), functor(Meta, Functor, Arity), '$lgt_pp_meta_predicate_'(Meta), Head =.. [_| Args], Meta =.. [_| MArgs], '$lgt_nonvar_meta_arg'(Args, MArgs, Arg), throw(type_error(variable, Arg)). % number of extra-arguments less than the minimum required by a closure '$lgt_tr_head'(Head, _, _, _) :- functor(Head, Functor, Arity), functor(Meta, Functor, Arity), '$lgt_pp_meta_predicate_'(Meta), Meta =.. [_| MArgs], '$lgt_insufficient_closure_args'(MArgs), throw(arity_mismatch(closure, Meta)). % redefinition of Logtalk built-in predicates '$lgt_tr_head'(Head, _, _, Input) :- '$lgt_lgt_built_in'(Head), '$lgt_compiler_flag'(lgtredef, warning), '$lgt_compiler_flag'(report, on), \+ '$lgt_pp_redefined_built_in_'(Head, _, _, _, _), % not already reported? functor(Head, Functor, Arity), '$lgt_inc_compile_warnings_counter', nl, write(' WARNING! Redefining a Logtalk built-in predicate: '), writeq(Functor/Arity), nl, '$lgt_report_compiler_error_line_number'(Input), fail. % redefinition of Prolog built-in predicates '$lgt_tr_head'(Head, _, _, Input) :- '$lgt_pl_built_in'(Head), '$lgt_compiler_flag'(plredef, warning), '$lgt_compiler_flag'(report, on), \+ '$lgt_pp_redefined_built_in_'(Head, _, _, _, _), % not already reported? functor(Head, Functor, Arity), '$lgt_inc_compile_warnings_counter', nl, write(' WARNING! Redefining a Prolog built-in predicate: '), writeq(Functor/Arity), nl, '$lgt_report_compiler_error_line_number'(Input), fail. % definition of event handlers without reference to the "monitoring" built-in protocol '$lgt_tr_head'(Head, _, _, Input) :- functor(Head, Functor, 3), once((Functor == before; Functor = after)), \+ '$lgt_pp_implemented_protocol_'(monitoring, _, _, _), '$lgt_compiler_flag'(report, on), '$lgt_inc_compile_warnings_counter', nl, write(' WARNING! Missing reference to the "monitoring" built-in protocol: '), writeq(Functor/3), nl, '$lgt_report_compiler_error_line_number'(Input), fail. % translate the head of a clause of a user defined predicate '$lgt_tr_head'(Head, THead, Ctx, _) :- functor(Head, Functor, Arity), '$lgt_ctx_head'(Ctx, Functor/Arity), ( '$lgt_pp_dynamic_'(Functor, Arity), \+ '$lgt_pp_public_'(Functor, Arity), \+ '$lgt_pp_protected_'(Functor, Arity), \+ '$lgt_pp_private_'(Functor, Arity) -> '$lgt_add_ddef_clause'(Head, Functor, Arity, THead, Ctx) ; '$lgt_add_def_clause'(Head, Functor, Arity, THead, Ctx) ). % look for a non-variable meta-argument '$lgt_nonvar_meta_arg'([Arg| _], [(::)| _], Arg) :- nonvar(Arg). '$lgt_nonvar_meta_arg'([Arg| _], [N| _], Arg) :- integer(N), nonvar(Arg). '$lgt_nonvar_meta_arg'([_| Args], [_| MArgs], Arg) :- '$lgt_nonvar_meta_arg'(Args, MArgs, Arg). % check if there are enough normal arguments for the closure with maximum arity '$lgt_insufficient_closure_args'(Args) :- '$lgt_insufficient_closure_args'(Args, 0, MaxClosure, 0, TotalNormalArgs), TotalNormalArgs < MaxClosure. '$lgt_insufficient_closure_args'([], MaxClosure, MaxClosure, TotalNormalArgs, TotalNormalArgs). '$lgt_insufficient_closure_args'([MArg| MArgs], MaxClosureSoFar, MaxClosure, TotalNormalArgsAcc, TotalNormalArgs) :- ( MArg == (*) -> MaxClosureSoFar2 is MaxClosureSoFar, TotalNormalArgsAcc2 is TotalNormalArgsAcc + 1 ; MArg == (::) -> MaxClosureSoFar2 is MaxClosureSoFar, TotalNormalArgsAcc2 is TotalNormalArgsAcc ; ( MArg > MaxClosureSoFar -> MaxClosureSoFar2 is MArg ; MaxClosureSoFar2 is MaxClosureSoFar ), TotalNormalArgsAcc2 is TotalNormalArgsAcc ), '$lgt_insufficient_closure_args'(MArgs, MaxClosureSoFar2, MaxClosure, TotalNormalArgsAcc2, TotalNormalArgs). % '$lgt_tr_body'(+callable, -callable, -callable, +term) % % translates an entity clause body % meta-calls '$lgt_tr_body'(Pred, TPred, '$lgt_dbg_goal'(Pred, TPred, DbgCtx), Ctx) :- var(Pred), !, '$lgt_ctx_ctx'(Ctx, _, Sender, This, Self, _, MetaVars, MetaCallCtx), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx), ( '$lgt_member_var'(Pred, MetaVars) -> TPred = '$lgt_metacall_in_object'(Pred, MetaCallCtx, Sender, This, Self) ; TPred = '$lgt_metacall_in_object'(Pred, local, Sender, This, Self) ). % pre-processor bypass (call of external code) '$lgt_tr_body'({Pred}, _, _, _) :- nonvar(Pred), \+ callable(Pred), throw(type_error(callable, Pred)). '$lgt_tr_body'({Pred}, call(Pred), '$lgt_dbg_goal'({Pred}, call(Pred), DbgCtx), Ctx) :- var(Pred), !, '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx). '$lgt_tr_body'({Pred}, Pred, '$lgt_dbg_goal'({Pred}, Pred, DbgCtx), Ctx) :- !, '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx). % bagof/3 and setof/3 existential quantifiers '$lgt_tr_body'(Var^Pred, Var^TPred, Var^DPred, Ctx) :- !, '$lgt_tr_body'(Pred, TPred, DPred, Ctx). % control constructs '$lgt_tr_body'((Pred1, Pred2), (TPred1, TPred2), (DPred1, DPred2), Ctx) :- !, '$lgt_tr_body'(Pred1, TPred1, DPred1, Ctx), '$lgt_tr_body'(Pred2, TPred2, DPred2, Ctx). '$lgt_tr_body'((Pred1; Pred2), (TPred1; TPred2), (DPred1; DPred2), Ctx) :- !, '$lgt_tr_body'(Pred1, TPred1, DPred1, Ctx), '$lgt_tr_body'(Pred2, TPred2, DPred2, Ctx). '$lgt_tr_body'((Pred1 -> Pred2), (TPred1 -> TPred2), (DPred1 -> DPred2), Ctx) :- !, '$lgt_tr_body'(Pred1, TPred1, DPred1, Ctx), '$lgt_tr_body'(Pred2, TPred2, DPred2, Ctx). '$lgt_tr_body'(\+ Pred, \+ TPred, \+ DPred, Ctx) :- !, '$lgt_tr_body'(Pred, TPred, DPred, Ctx). '$lgt_tr_body'(!, !, ('$lgt_dbg_goal'(!, true, DbgCtx), !), Ctx) :- !, '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx). '$lgt_tr_body'(true, true, '$lgt_dbg_goal'(true, true, DbgCtx), Ctx) :- !, '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx). '$lgt_tr_body'(fail, fail, '$lgt_dbg_goal'(fail, fail, DbgCtx), Ctx) :- !, '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx). '$lgt_tr_body'(repeat, repeat, '$lgt_dbg_goal'(repeat, repeat, DbgCtx), Ctx) :- !, '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx). '$lgt_tr_body'(call(Pred), TPred, DPred, Ctx) :- !, '$lgt_tr_body'(Pred, TPred, DPred, Ctx). '$lgt_tr_body'(CallN, _, _, _) :- CallN =.. [call, Call| _], nonvar(Call), ( Call = _::Closure ; Call = ::Closure ; Call = ^^Closure ), throw(domain_error(goal, Closure)). '$lgt_tr_body'(CallN, _, _, Ctx) :- CallN =.. [call, Closure| _], '$lgt_ctx_ctx'(Ctx, HeadFunctor/HeadArity, _, _, _, _, MetaVars, _), functor(Meta, HeadFunctor, HeadArity), '$lgt_pp_meta_predicate_'(Meta), % if we're compiling a clause for a meta-predicate '$lgt_member_var'(Closure, MetaVars) -> % and our closure is a meta-argument functor(CallN, _, CallArity), % then check that the call/N call complies with ExtraArgs is CallArity - 1, % the meta-predicate declaration Meta =.. [_| MetaArgs], \+ '$lgt_same_meta_arg_extra_args'(MetaArgs, MetaVars, Closure, ExtraArgs), throw(arity_mismatch(closure, CallN, Meta)). '$lgt_tr_body'(CallN, TPred, DPred, Ctx) :- CallN =.. [call, Closure| Args], !, '$lgt_ctx_ctx'(Ctx, _, Sender, This, Self, _, MetaVars, MetaCallCtx), ( '$lgt_member_var'(Closure, MetaVars) -> TPred = '$lgt_metacall_in_object'(Closure, Args, MetaCallCtx, Sender, This, Self) ; TPred = '$lgt_metacall_in_object'(Closure, Args, local, Sender, This, Self) ), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx), DPred = '$lgt_dbg_goal'(CallN, TPred, DbgCtx). '$lgt_tr_body'(once(Pred), once(TPred), once(DPred), Ctx) :- !, '$lgt_tr_body'(Pred, TPred, DPred, Ctx). '$lgt_tr_body'(catch(Goal, Catcher, Recovery), catch(TGoal, Catcher, TRecovery), '$lgt_dbg_goal'(catch(Goal, Catcher, Recovery), catch(DGoal, Catcher, DRecovery), DbgCtx), Ctx) :- !, '$lgt_tr_body'(Goal, TGoal, DGoal, Ctx), '$lgt_tr_body'(Recovery, TRecovery, DRecovery, Ctx), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx). '$lgt_tr_body'(throw(Error), throw(Error), '$lgt_dbg_goal'(throw(Error), throw(Error), DbgCtx), Ctx) :- !, '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx). % built-in meta-predicates '$lgt_tr_body'(bagof(Term, Pred, List), bagof(Term, TPred, List), '$lgt_dbg_goal'(bagof(Term, Pred, List), bagof(Term, DPred, List), DbgCtx), Ctx) :- !, '$lgt_tr_body'(Pred, TPred, DPred, Ctx), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx). '$lgt_tr_body'(findall(Term, Pred, List), findall(Term, TPred, List), '$lgt_dbg_goal'(findall(Term, Pred, List), findall(Term, DPred, List), DbgCtx), Ctx) :- !, '$lgt_tr_body'(Pred, TPred, DPred, Ctx), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx). '$lgt_tr_body'(forall(Gen, Test), forall(TGen, TTest), '$lgt_dbg_goal'(forall(Gen, Test), forall(DGen, DTest), DbgCtx), Ctx) :- !, '$lgt_tr_body'(Gen, TGen, DGen, Ctx), '$lgt_tr_body'(Test, TTest, DTest, Ctx), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx). '$lgt_tr_body'(setof(Term, Pred, List), setof(Term, TPred, List), '$lgt_dbg_goal'(setof(Term, Pred, List), setof(Term, DPred, List), DbgCtx), Ctx) :- !, '$lgt_tr_body'(Pred, TPred, DPred, Ctx), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx). % multi-threading meta-predicates '$lgt_tr_body'(threaded(_), _, _, _) :- \+ '$lgt_pp_threaded_', '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _), throw(resource_error(threads)). '$lgt_tr_body'(threaded(Goals), _, _, _) :- nonvar(Goals), \+ callable(Goals), throw(type_error(callable, Goals)). '$lgt_tr_body'(threaded(Goals), MTGoals, '$lgt_dbg_goal'(threaded(Goals), MTGoals, DbgCtx), Ctx) :- !, '$lgt_tr_threaded_call'(Goals, MTGoals, Ctx), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx). '$lgt_tr_body'(threaded_call(_, _), _, _, _) :- \+ '$lgt_pp_threaded_', '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _), throw(resource_error(threads)). '$lgt_tr_body'(threaded_call(_, Tag), _, _, _) :- nonvar(Tag), throw(type_error(variable, Tag)). '$lgt_tr_body'(threaded_call(Goal, _), _, _, _) :- nonvar(Goal), \+ callable(Goal), throw(type_error(callable, Goal)). '$lgt_tr_body'(threaded_call(Goal, Tag), MTGoal, '$lgt_dbg_goal'(threaded_call(Goal, Tag), MTGoal, DbgCtx), Ctx) :- !, '$lgt_ctx_ctx'(Ctx, _, Sender, This, Self, _, _, _), '$lgt_tr_body'(Goal, TGoal, _, Ctx), ( '$lgt_pp_object_'(_, Prefix, _, _, _, _, _, _, _, _, _) -> MTGoal = ('$lgt_new_threaded_tag'(Tag), '$lgt_mt_send_goal'(Prefix, TGoal, Sender, This, Self, call(Tag))) ; MTGoal = ('$lgt_new_threaded_tag'(Tag), '$lgt_mt_send_goal'(TGoal, Sender, This, Self, call(Tag))) ), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx). '$lgt_tr_body'(threaded_call(_), _, _, _) :- \+ '$lgt_pp_threaded_', '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _), throw(resource_error(threads)). '$lgt_tr_body'(threaded_call(Goal), _, _, _) :- nonvar(Goal), \+ callable(Goal), throw(type_error(callable, Goal)). '$lgt_tr_body'(threaded_call(Goal), MTGoal, '$lgt_dbg_goal'(threaded_call(Goal), MTGoal, DbgCtx), Ctx) :- !, '$lgt_ctx_ctx'(Ctx, _, Sender, This, Self, _, _, _), '$lgt_tr_body'(Goal, TGoal, _, Ctx), ( '$lgt_pp_object_'(_, Prefix, _, _, _, _, _, _, _, _, _) -> MTGoal = '$lgt_mt_send_goal'(Prefix, TGoal, Sender, This, Self, call([])) ; MTGoal = '$lgt_mt_send_goal'(TGoal, Sender, This, Self, call([])) ), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx). '$lgt_tr_body'(threaded_once(_, _), _, _, _) :- \+ '$lgt_pp_threaded_', '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _), throw(resource_error(threads)). '$lgt_tr_body'(threaded_once(_, Tag), _, _, _) :- nonvar(Tag), throw(type_error(variable, Tag)). '$lgt_tr_body'(threaded_once(Goal, _), _, _, _) :- nonvar(Goal), \+ callable(Goal), throw(type_error(callable, Goal)). '$lgt_tr_body'(threaded_once(Goal, Tag), MTGoal, '$lgt_dbg_goal'(threaded_once(Goal, Tag), MTGoal, DbgCtx), Ctx) :- !, '$lgt_ctx_ctx'(Ctx, _, Sender, This, Self, _, _, _), '$lgt_tr_body'(Goal, TGoal, _, Ctx), ( '$lgt_pp_object_'(_, Prefix, _, _, _, _, _, _, _, _, _) -> MTGoal = ('$lgt_new_threaded_tag'(Tag), '$lgt_mt_send_goal'(Prefix, TGoal, Sender, This, Self, once(Tag))) ; MTGoal = ('$lgt_new_threaded_tag'(Tag), '$lgt_mt_send_goal'(TGoal, Sender, This, Self, once(Tag))) ), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx). '$lgt_tr_body'(threaded_once(_), _, _, _) :- \+ '$lgt_pp_threaded_', '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _), throw(resource_error(threads)). '$lgt_tr_body'(threaded_once(Goal), _, _, _) :- nonvar(Goal), \+ callable(Goal), throw(type_error(callable, Goal)). '$lgt_tr_body'(threaded_once(Goal), MTGoal, '$lgt_dbg_goal'(threaded_once(Goal), MTGoal, DbgCtx), Ctx) :- !, '$lgt_ctx_ctx'(Ctx, _, Sender, This, Self, _, _, _), '$lgt_tr_body'(Goal, TGoal, _, Ctx), ( '$lgt_pp_object_'(_, Prefix, _, _, _, _, _, _, _, _, _) -> MTGoal = '$lgt_mt_send_goal'(Prefix, TGoal, Sender, This, Self, once([])) ; MTGoal = '$lgt_mt_send_goal'(TGoal, Sender, This, Self, once([])) ), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx). '$lgt_tr_body'(threaded_ignore(_), _, _, _) :- \+ '$lgt_pp_threaded_', '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _), throw(resource_error(threads)). '$lgt_tr_body'(threaded_ignore(Goal), _, _, _) :- nonvar(Goal), \+ callable(Goal), throw(type_error(callable, Goal)). '$lgt_tr_body'(threaded_ignore(Goal), MTGoal, '$lgt_dbg_goal'(threaded_ignore(Goal), MTGoal, DbgCtx), Ctx) :- !, '$lgt_ctx_ctx'(Ctx, _, Sender, This, Self, _, _, _), '$lgt_tr_body'(Goal, TGoal, _, Ctx), ( '$lgt_pp_object_'(_, Prefix, _, _, _, _, _, _, _, _, _) -> MTGoal = '$lgt_mt_send_goal'(Prefix, TGoal, Sender, This, Self, ignore) ; MTGoal = '$lgt_mt_send_goal'(TGoal, Sender, This, Self, ignore) ), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx). '$lgt_tr_body'(threaded_exit(_, _), _, _, _) :- \+ '$lgt_pp_threaded_', '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _), throw(resource_error(threads)). '$lgt_tr_body'(threaded_exit(_, Tag), _, _, _) :- var(Tag), throw(instantiation_error). '$lgt_tr_body'(threaded_exit(Goal, _), _, _, _) :- nonvar(Goal), \+ callable(Goal), throw(type_error(callable, Goal)). '$lgt_tr_body'(threaded_exit(Goal, Tag), MTGoal, '$lgt_dbg_goal'(threaded_exit(Goal, Tag), MTGoal, DbgCtx), Ctx) :- !, '$lgt_ctx_ctx'(Ctx, _, Sender, This, Self, _, _, _), '$lgt_tr_body'(Goal, TGoal, _, Ctx), ( '$lgt_pp_object_'(_, Prefix, _, _, _, _, _, _, _, _, _) -> MTGoal = '$lgt_mt_get_reply'(Prefix, TGoal, Sender, This, Self, Tag) ; MTGoal = '$lgt_mt_get_reply'(TGoal, Sender, This, Self, Tag) ), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx). '$lgt_tr_body'(threaded_exit(_), _, _, _) :- \+ '$lgt_pp_threaded_', '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _), throw(resource_error(threads)). '$lgt_tr_body'(threaded_exit(Goal), _, _, _) :- nonvar(Goal), \+ callable(Goal), throw(type_error(callable, Goal)). '$lgt_tr_body'(threaded_exit(Goal), MTGoal, '$lgt_dbg_goal'(threaded_exit(Goal), MTGoal, DbgCtx), Ctx) :- !, '$lgt_ctx_ctx'(Ctx, _, Sender, This, Self, _, _, _), '$lgt_tr_body'(Goal, TGoal, _, Ctx), ( '$lgt_pp_object_'(_, Prefix, _, _, _, _, _, _, _, _, _) -> MTGoal = '$lgt_mt_get_reply'(Prefix, TGoal, Sender, This, Self, []) ; MTGoal = '$lgt_mt_get_reply'(TGoal, Sender, This, Self, []) ), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx). '$lgt_tr_body'(threaded_peek(_, _), _, _, _) :- \+ '$lgt_pp_threaded_', '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _), throw(resource_error(threads)). '$lgt_tr_body'(threaded_peek(_, Tag), _, _, _) :- var(Tag), throw(instantiation_error). '$lgt_tr_body'(threaded_peek(Goal, _), _, _, _) :- nonvar(Goal), \+ callable(Goal), throw(type_error(callable, Goal)). '$lgt_tr_body'(threaded_peek(Goal, Tag), MTGoal, '$lgt_dbg_goal'(threaded_peek(Goal, Tag), MTGoal, DbgCtx), Ctx) :- !, '$lgt_ctx_ctx'(Ctx, _, Sender, This, Self, _, _, _), '$lgt_tr_body'(Goal, TGoal, _, Ctx), ( '$lgt_pp_object_'(_, Prefix, _, _, _, _, _, _, _, _, _) -> MTGoal = '$lgt_mt_peek_reply'(Prefix, TGoal, Sender, This, Self, Tag) ; MTGoal = '$lgt_mt_peek_reply'(TGoal, Sender, This, Self, Tag) ), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx). '$lgt_tr_body'(threaded_peek(_), _, _, _) :- \+ '$lgt_pp_threaded_', '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _), throw(resource_error(threads)). '$lgt_tr_body'(threaded_peek(Goal), _, _, _) :- nonvar(Goal), \+ callable(Goal), throw(type_error(callable, Goal)). '$lgt_tr_body'(threaded_peek(Goal), MTGoal, '$lgt_dbg_goal'(threaded_peek(Goal), MTGoal, DbgCtx), Ctx) :- !, '$lgt_ctx_ctx'(Ctx, _, Sender, This, Self, _, _, _), '$lgt_tr_body'(Goal, TGoal, _, Ctx), ( '$lgt_pp_object_'(_, Prefix, _, _, _, _, _, _, _, _, _) -> MTGoal = '$lgt_mt_peek_reply'(Prefix, TGoal, Sender, This, Self, []) ; MTGoal = '$lgt_mt_peek_reply'(TGoal, Sender, This, Self, []) ), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx). '$lgt_tr_body'(threaded_wait(_), _, _, _) :- \+ '$lgt_pp_threaded_', '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _), throw(resource_error(threads)). '$lgt_tr_body'(threaded_wait(Msg), MTPred, '$lgt_dbg_goal'(threaded_wait(Msg), MTPred, DbgCtx), Ctx) :- !, '$lgt_pp_entity'(Type, _, EntityPrefix, _, _), '$lgt_ctx_ctx'(Ctx, Functor/Arity, _, _, _, EntityPrefix, _, _), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx), functor(Head, Functor, Arity), ( '$lgt_pp_synchronized_'(Head, Mutex) -> ( Type == object -> MTPred = (mutex_unlock(Mutex), '$lgt_thread_get_notifications'(Msg, EntityPrefix), mutex_lock(Mutex)) ; % we're compiling a category predicate '$lgt_ctx_this'(Ctx, This), MTPred = ('$lgt_current_object_'(This, Prefix, _, _, _, _, _, _), mutex_unlock(Mutex), '$lgt_thread_get_notifications'(Msg, Prefix), mutex_lock(Mutex)) ) ; ( Type == object -> MTPred = '$lgt_thread_get_notifications'(Msg, EntityPrefix) ; % we're compiling a category predicate '$lgt_ctx_this'(Ctx, This), MTPred = ('$lgt_current_object_'(This, Prefix, _, _, _, _, _, _), '$lgt_thread_get_notifications'(Msg, Prefix)) ) ). '$lgt_tr_body'(threaded_notify(_), _, _, _) :- \+ '$lgt_pp_threaded_', '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _), throw(resource_error(threads)). '$lgt_tr_body'(threaded_notify(Msg), MTPred, '$lgt_dbg_goal'(threaded_notify(Msg), MTPred, DbgCtx), Ctx) :- !, '$lgt_pp_entity'(Type, _, EntityPrefix, _, _), '$lgt_ctx_ctx'(Ctx, _, _, _, _, EntityPrefix, _, _), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx), ( Type == object -> MTPred = '$lgt_thread_send_notifications'(Msg, EntityPrefix) ; % we're compiling a category predicate '$lgt_ctx_this'(Ctx, This), MTPred = ('$lgt_current_object_'(This, Prefix, _, _, _, _, _, _), '$lgt_thread_send_notifications'(Msg, Prefix)) ). % message sending '$lgt_tr_body'(Obj::Pred, TPred, '$lgt_dbg_goal'(Obj::Pred, TPred, DbgCtx), Ctx) :- !, '$lgt_ctx_this'(Ctx, This), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx), '$lgt_tr_msg'(Pred, Obj, TPred, This). '$lgt_tr_body'(::Pred, TPred, '$lgt_dbg_goal'(::Pred, TPred, DbgCtx), Ctx) :- !, '$lgt_ctx_this'(Ctx, This), '$lgt_ctx_self'(Ctx, Self), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx), '$lgt_tr_self_msg'(Pred, TPred, This, Self). '$lgt_tr_body'(^^Pred, TPred, '$lgt_dbg_goal'(^^Pred, TPred, DbgCtx), Ctx) :- !, '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx), '$lgt_tr_super_call'(Pred, TPred, Ctx). % context-switching '$lgt_tr_body'(Obj<<_, _, _, _) :- var(Obj), throw(instantiation_error). '$lgt_tr_body'(_< true ; Pred = Alias ), '$lgt_ctg_static_binding_cache'(Ctg, Pred, Sender, This, Self, TPred) -> true ; Pred = Alias, '$lgt_pp_object_'(_, _, Dcl, Def, _, IDcl, _, _, _, _, _), ( ('$lgt_pp_instantiated_class_'(_, _, _, _, _, _, _, _, _, _); '$lgt_pp_specialized_class_'(_, _, _, _, _, _, _, _, _, _)) -> TPred = '$lgt_call_ctg_pred'(IDcl, Def, Pred, Sender, This, Self) ; TPred = '$lgt_call_ctg_pred'(Dcl, Def, Pred, Sender, This, Self) ) ). % "reflection" built-in predicates '$lgt_tr_body'(current_predicate(Pred), '$lgt_current_predicate'(This, Pred, This, p(_)), '$lgt_dbg_goal'(current_predicate(Pred), '$lgt_current_predicate'(This, Pred, This, p(_)), DbgCtx), Ctx) :- !, '$lgt_ctx_this'(Ctx, This), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx). '$lgt_tr_body'(predicate_property(Pred, Prop), '$lgt_predicate_property'(This, Pred, Prop, This, p(_)), '$lgt_dbg_goal'(predicate_property(Pred, Prop), '$lgt_predicate_property'(This, Pred, Prop, This, p(_)), DbgCtx), Ctx) :- !, '$lgt_ctx_this'(Ctx, This), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx). % database handling built-in predicates '$lgt_tr_body'(abolish(Pred), TCond, DCond, Ctx) :- !, '$lgt_ctx_this'(Ctx, This), ( '$lgt_runtime_db_pred_ind_chk'(Pred) -> TCond = '$lgt_abolish'(This, Pred, This, p(_)) ; '$lgt_compiler_db_pred_ind_chk'(Pred), TCond = '$lgt_abolish_chk'(This, Pred, This, p(_)) ), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx), DCond = '$lgt_dbg_goal'(abolish(Pred), TCond, DbgCtx). '$lgt_tr_body'(asserta(Pred), TCond, DCond, Ctx) :- !, ( '$lgt_optimizable_local_db_call'(Pred, Ctx, TPred) -> TCond = asserta(TPred) ; '$lgt_ctx_this'(Ctx, This), ( '$lgt_runtime_db_clause_chk'(Pred) -> TCond = '$lgt_asserta'(This, Pred, This, p(_), p) ; '$lgt_compiler_db_clause_chk'(Pred), ( Pred = (Head :- Body) -> ( Body == true -> TCond = '$lgt_asserta_fact_chk'(This, Head, This, p(_), p) ; TCond = '$lgt_asserta_rule_chk'(This, Pred, This, p(_), p) ) ; TCond = '$lgt_asserta_fact_chk'(This, Pred, This, p(_), p) ) ) ), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx), DCond = '$lgt_dbg_goal'(asserta(Pred), TCond, DbgCtx). '$lgt_tr_body'(assertz(Pred), TCond, DCond, Ctx) :- !, ( '$lgt_optimizable_local_db_call'(Pred, Ctx, TPred) -> TCond = assertz(TPred) ; '$lgt_ctx_this'(Ctx, This), ( '$lgt_runtime_db_clause_chk'(Pred) -> TCond = '$lgt_assertz'(This, Pred, This, p(_), p) ; '$lgt_compiler_db_clause_chk'(Pred), ( Pred = (Head :- Body) -> ( Body == true -> TCond = '$lgt_assertz_fact_chk'(This, Head, This, p(_), p) ; TCond = '$lgt_assertz_rule_chk'(This, Pred, This, p(_), p) ) ; TCond = '$lgt_assertz_fact_chk'(This, Pred, This, p(_), p) ) ) ), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx), DCond = '$lgt_dbg_goal'(assertz(Pred), TCond, DbgCtx). '$lgt_tr_body'(clause(Head, Body), TCond, DCond, Ctx) :- !, ( '$lgt_optimizable_local_db_call'(Head, Ctx, THead) -> TCond = (clause(THead, TBody), (TBody = ('$lgt_nop'(Body), _) -> true; TBody = Body)) ; '$lgt_ctx_this'(Ctx, This), ( '$lgt_runtime_db_clause_chk'((Head :- Body)) -> TCond = '$lgt_clause'(This, Head, Body, This, p(_)) ; '$lgt_compiler_db_clause_chk'((Head :- Body)), TCond = '$lgt_clause_chk'(This, Head, Body, This, p(_)) ) ), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx), DCond = '$lgt_dbg_goal'(clause(Head, Body), TCond, DbgCtx). '$lgt_tr_body'(retract(Pred), TCond, DCond, Ctx) :- !, ( '$lgt_optimizable_local_db_call'(Pred, Ctx, TPred) -> TCond = retract(TPred) ; '$lgt_ctx_this'(Ctx, This), ( '$lgt_runtime_db_clause_chk'(Pred) -> TCond = '$lgt_retract'(This, Pred, This, p(_)) ; '$lgt_compiler_db_clause_chk'(Pred), ( Pred = (Head :- Body) -> ( var(Body) -> '$lgt_retract_var_body_chk'(This, Pred, This, p(_)) ; Body == true -> TCond = '$lgt_retract_fact_chk'(This, Head, This, p(_)) ; TCond = '$lgt_retract_rule_chk'(This, Pred, This, p(_)) ) ; TCond = '$lgt_retract_fact_chk'(This, Pred, This, p(_)) ) ) ), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx), DCond = '$lgt_dbg_goal'(retract(Pred), TCond, DbgCtx). '$lgt_tr_body'(retractall(Pred), TCond, DCond, Ctx) :- !, ( '$lgt_optimizable_local_db_call'(Pred, Ctx, TPred) -> TCond = retractall(TPred) ; '$lgt_ctx_this'(Ctx, This), ( '$lgt_runtime_db_clause_chk'(Pred) -> TCond = '$lgt_retractall'(This, Pred, This, p(_)) ; '$lgt_compiler_db_clause_chk'(Pred), TCond = '$lgt_retractall_chk'(This, Pred, This, p(_)) ) ), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx), DCond = '$lgt_dbg_goal'(retractall(Pred), TCond, DbgCtx). % DCG predicates '$lgt_tr_body'(expand_term(Term, Clause), '$lgt_expand_term'(This, Term, Clause, This, p(_)), '$lgt_dbg_goal'(expand_term(Term, Clause), '$lgt_expand_term'(This, Term, Clause, This, p(_)), DbgCtx), Ctx) :- !, '$lgt_ctx_this'(Ctx, This), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx). '$lgt_tr_body'(phrase(GRBody, Input), '$lgt_phrase'(This, GRBody, Input, This, _), '$lgt_dbg_goal'(phrase(GRBody, Input), '$lgt_phrase'(This, GRBody, Input, This, _), DbgCtx), Ctx) :- var(GRBody), !, '$lgt_ctx_this'(Ctx, This), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx). '$lgt_tr_body'(phrase(GRBody, Input), TPred, '$lgt_dbg_goal'(phrase(GRBody, Input), TPred, DbgCtx), Ctx) :- !, '$lgt_dcg_body'(GRBody, S0, S, Pred), '$lgt_tr_body'(Pred, Pred2, _, Ctx), TPred = (Input = S0, [] = S, Pred2), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx). '$lgt_tr_body'(phrase(GRBody, Input, Rest), '$lgt_phrase'(This, GRBody, Input, Rest, This, _), '$lgt_dbg_goal'(phrase(GRBody, Input, Rest), '$lgt_phrase'(This, GRBody, Input, Rest, This, _), DbgCtx), Ctx) :- var(GRBody), !, '$lgt_ctx_this'(Ctx, This), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx). '$lgt_tr_body'(phrase(GRBody, Input, Rest), TPred, '$lgt_dbg_goal'(phrase(GRBody, Input, Rest), TPred, DbgCtx), Ctx) :- !, '$lgt_dcg_body'(GRBody, S0, S, Pred), '$lgt_tr_body'(Pred, Pred2, _, Ctx), TPred = (Input = S0, Rest = S, Pred2), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx). % inline methods (usually translated to a single unification with the corresponding context argument) '$lgt_tr_body'(sender(Sender), true, '$lgt_dbg_goal'(sender(Temp), Sender=Temp, DbgCtx), Ctx) :- !, '$lgt_ctx_sender'(Ctx, Sender), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx). '$lgt_tr_body'(this(This), true, '$lgt_dbg_goal'(this(Temp), This=Temp, DbgCtx), Ctx) :- !, ( '$lgt_ctx_this'(Ctx, This) -> % check for mismatches between the argument of true % this/1 and the parametric object identifier ; throw(domain_error(object_identifier, This)) ), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx). '$lgt_tr_body'(self(Self), true, '$lgt_dbg_goal'(self(Temp), Self=Temp, DbgCtx), Ctx) :- !, '$lgt_ctx_self'(Ctx, Self), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx). '$lgt_tr_body'(parameter(Arg, Value), TPred, '$lgt_dbg_goal'(parameter(Arg, Temp), DPred, DbgCtx), Ctx) :- !, '$lgt_ctx_this'(Ctx, This), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx), ( (var(This); var(Arg)) -> % when using parameter/2 in categories TPred = arg(Arg, This, Value), % or when the first argument will only DPred = (TPred, Temp=Value) % be instantiated at runtime ; functor(This, _, Arity), ( 1 =< Arg, Arg =< Arity -> arg(Arg, This, Value), TPred = true, DPred = (Temp=Value) ; throw(domain_error(out_of_range, Arg)) ) ). % term input predicates that need to be operator aware '$lgt_tr_body'(read_term(Stream, Term, Options), '$lgt_iso_read_term'(Stream, Term, Options, Ops), '$lgt_dbg_goal'(read_term(Stream, Term, Options), '$lgt_iso_read_term'(Stream, Term, Options, Ops), DbgCtx), Ctx) :- bagof(op(Pr, Spec, Op), '$lgt_pp_entity_op_'(Pr, Spec, Op), Ops), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx), !. '$lgt_tr_body'(read_term(Term, Options), '$lgt_iso_read_term'(Term, Options, Ops), '$lgt_dbg_goal'(read_term(Term, Options), '$lgt_iso_read_term'(Term, Options, Ops), DbgCtx), Ctx) :- bagof(op(Pr, Spec, Op), '$lgt_pp_entity_op_'(Pr, Spec, Op), Ops), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx), !. '$lgt_tr_body'(read(Stream, Term), '$lgt_iso_read'(Stream, Term, Ops), '$lgt_dbg_goal'(read(Stream, Term), '$lgt_iso_read'(Stream, Term, Ops), DbgCtx), Ctx) :- bagof(op(Pr, Spec, Op), '$lgt_pp_entity_op_'(Pr, Spec, Op), Ops), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx), !. '$lgt_tr_body'(read(Term), '$lgt_iso_read'(Term, Ops), '$lgt_dbg_goal'(read(Term), '$lgt_iso_read'(Term, Ops), DbgCtx), Ctx) :- bagof(op(Pr, Spec, Op), '$lgt_pp_entity_op_'(Pr, Spec, Op), Ops), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx), !. % term output predicates that need to be operator aware '$lgt_tr_body'(write_term(Stream, Term, Options), '$lgt_iso_write_term'(Stream, Term, Options, Ops), '$lgt_dbg_goal'(write_term(Stream, Term, Options), '$lgt_iso_write_term'(Stream, Term, Options, Ops), DbgCtx), Ctx) :- ('$lgt_member'(ignore_ops(Value), Options) -> Value \== true; true), bagof(op(Pr, Spec, Op), '$lgt_pp_entity_op_'(Pr, Spec, Op), Ops), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx), !. '$lgt_tr_body'(write_term(Term, Options), '$lgt_iso_write_term'(Term, Options, Ops), '$lgt_dbg_goal'(write_term(Term, Options), '$lgt_iso_write_term'(Term, Options, Ops), DbgCtx), Ctx) :- ('$lgt_member'(ignore_ops(Value), Options) -> Value \== true; true), bagof(op(Pr, Spec, Op), '$lgt_pp_entity_op_'(Pr, Spec, Op), Ops), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx), !. '$lgt_tr_body'(write(Stream, Term), '$lgt_iso_write'(Stream, Term, Ops), '$lgt_dbg_goal'(write(Stream, Term), '$lgt_iso_write'(Stream, Term, Ops), DbgCtx), Ctx) :- bagof(op(Pr, Spec, Op), '$lgt_pp_entity_op_'(Pr, Spec, Op), Ops), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx), !. '$lgt_tr_body'(write(Term), '$lgt_iso_write'(Term, Ops), '$lgt_dbg_goal'(write(Term), '$lgt_iso_write'(Term, Ops), DbgCtx), Ctx) :- bagof(op(Pr, Spec, Op), '$lgt_pp_entity_op_'(Pr, Spec, Op), Ops), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx), !. '$lgt_tr_body'(writeq(Stream, Term), '$lgt_iso_writeq'(Stream, Term, Ops), '$lgt_dbg_goal'(writeq(Stream, Term), '$lgt_iso_writeq'(Stream, Term, Ops), DbgCtx), Ctx) :- bagof(op(Pr, Spec, Op), '$lgt_pp_entity_op_'(Pr, Spec, Op), Ops), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx), !. '$lgt_tr_body'(writeq(Term), '$lgt_iso_writeq'(Term, Ops), '$lgt_dbg_goal'(writeq(Term), '$lgt_iso_writeq'(Term, Ops), DbgCtx), Ctx) :- bagof(op(Pr, Spec, Op), '$lgt_pp_entity_op_'(Pr, Spec, Op), Ops), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx), !. % predicates specified in uses/2 directives '$lgt_tr_body'(Alias, TPred, DPred, Ctx) :- '$lgt_pp_uses_'(Obj, Pred, Alias), !, '$lgt_tr_body'(Obj::Pred, TPred, DPred, Ctx). % Logtalk and Prolog built-in (meta-)predicates '$lgt_tr_body'(Pred, _, _, _) :- '$lgt_pl_built_in'(Pred), \+ '$lgt_lgt_built_in'(Pred), \+ '$lgt_iso_spec_pred'(Pred), functor(Pred, Functor, Arity), \+ '$lgt_pp_public_'(Functor, Arity), % not a \+ '$lgt_pp_protected_'(Functor, Arity), % redefined \+ '$lgt_pp_private_'(Functor, Arity), % built-in assertz('$lgt_non_portable_call_'(Functor, Arity)), fail. '$lgt_tr_body'(Pred, TPred, '$lgt_dbg_goal'(Pred, DPred, DbgCtx), Ctx) :- '$lgt_pl_built_in'(Pred), functor(Pred, Functor, Arity), \+ '$lgt_pp_public_'(Functor, Arity), % not a \+ '$lgt_pp_protected_'(Functor, Arity), % redefined \+ '$lgt_pp_private_'(Functor, Arity), % built-in functor(Meta, Functor, Arity), '$lgt_pl_meta_predicate'(Meta), !, Pred =.. [_| Args], Meta =.. [_| MArgs], ( '$lgt_member'(MArg, MArgs), integer(MArg) -> throw(domain_error(closure, Meta)) ; '$lgt_tr_meta_args'(Args, MArgs, Ctx, TArgs, DArgs), TPred =.. [Functor| TArgs], DPred =.. [Functor| DArgs], '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx) ). '$lgt_tr_body'(Pred, '$lgt_call_built_in'(Pred, Ctx), '$lgt_dbg_goal'(Pred, '$lgt_call_built_in'(Pred, Ctx), DbgCtx), Ctx) :- '$lgt_built_in'(Pred), functor(Pred, Functor, Arity), \+ '$lgt_pp_public_'(Functor, Arity), % not a \+ '$lgt_pp_protected_'(Functor, Arity), % redefined \+ '$lgt_pp_private_'(Functor, Arity), % built-in !, '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx). % invalid goal '$lgt_tr_body'(Pred, _, _, _) :- \+ callable(Pred), throw(type_error(callable, Pred)). % goal is a call to a user meta-predicate '$lgt_tr_body'(Pred, TPred, '$lgt_dbg_goal'(Pred, DPred, DbgCtx), Ctx) :- functor(Pred, Functor, Arity), functor(Meta, Functor, Arity), '$lgt_pp_meta_predicate_'(Meta), !, Pred =.. [_| Args], Meta =.. [_| MArgs], '$lgt_ctx_ctx'(Ctx, Head, Sender, This, Self, EntityPrefix, MetaVars, _), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx), '$lgt_construct_predicate_functor'(EntityPrefix, Functor, Arity, PredPrefix), ( '$lgt_pp_synchronized_'(Pred, _), Functor/Arity \= Head -> atom_concat(PredPrefix, '_sync', MPrefix) ; MPrefix = PredPrefix ), ( MetaVars == [] -> % we're not compiling a clause to a meta-predicate, thus we have a local call % to a meta-predicate ( '$lgt_member'(MArg, MArgs), integer(MArg) -> % we're compiling a call to a meta-predicate that expects a closure... '$lgt_append'(Args, [local, Sender, This, Self], TArgs2), DArgs2 = TArgs2 ; % we're compiling a call to a meta-predicate that does not use closures... '$lgt_tr_meta_args'(Args, MArgs, Ctx, TArgs, DArgs), '$lgt_append'(TArgs, [compiled, Sender, This, Self], TArgs2), '$lgt_append'(DArgs, [compiled, Sender, This, Self], DArgs2) ) ; % we have a meta-predicate calling another meta-predicate, the meta-arguments % to be called in the context of the sender will be the ones coming from the % call to the predicate whose body we're compiling '$lgt_append'(Args, [MetaVars, Sender, This, Self], TArgs2), DArgs2 = TArgs2 ), TPred =.. [MPrefix| TArgs2], DPred =.. [MPrefix| DArgs2], Arity4 is Arity + 4, ( '$lgt_pp_calls_pred_'(Functor, Arity, _, _) -> true ; assertz('$lgt_pp_calls_pred_'(Functor, Arity, MPrefix, Arity4)) ). % goal is a call to a user predicate '$lgt_tr_body'(Pred, TPred, '$lgt_dbg_goal'(Pred, TPred, DbgCtx), Ctx) :- Pred =.. [Functor| Args], functor(Pred, Functor, Arity), '$lgt_ctx_ctx'(Ctx, Head, Sender, This, Self, EntityPrefix, _, _), '$lgt_ctx_dbg_ctx'(Ctx, DbgCtx), '$lgt_construct_predicate_functor'(EntityPrefix, Functor, Arity, PredPrefix), ( '$lgt_pp_synchronized_'(Pred, _), Functor/Arity \= Head -> atom_concat(PredPrefix, '_sync', MPrefix) ; MPrefix = PredPrefix ), '$lgt_append'(Args, [Sender, This, Self], Args2), TPred =.. [MPrefix| Args2], Arity3 is Arity + 3, ( '$lgt_pp_calls_pred_'(Functor, Arity, _, _) -> true ; assertz('$lgt_pp_calls_pred_'(Functor, Arity, MPrefix, Arity3)) ). % '$lgt_tr_threaded_call'(+callable, -callable, +callable) % % translates the argument of a built-in predicate threaded/1 call '$lgt_tr_threaded_call'(Goals, (MTCalls, MTExits), Ctx) :- '$lgt_tr_body'(Goals, TGoals, _, Ctx), '$lgt_tr_threaded_call'(TGoals, MTCalls, MTExits, Ctx). '$lgt_tr_threaded_call'((TGoal; TGoals), MTCalls, MTExits, Ctx) :- !, '$lgt_tr_threaded_or_call'((TGoal; TGoals), MTCalls, MTExits, Ctx). '$lgt_tr_threaded_call'((TGoal, TGoals), MTCalls, MTExits, Ctx) :- !, '$lgt_tr_threaded_and_call'((TGoal, TGoals), MTCalls, MTExits, Ctx). '$lgt_tr_threaded_call'(TGoal, once(TGoal), true, _). '$lgt_tr_threaded_and_call'(TGoals, MTCalls, MTExit, Ctx) :- '$lgt_tr_threaded_and_call'(TGoals, Queue, MTCalls0, Tag, Tag, Results), ( '$lgt_pp_object_'(_, Queue, _, _, _, _, _, _, _, _, _) -> MTCalls = MTCalls0 ; '$lgt_ctx_this'(Ctx, This), MTCalls = ('$lgt_current_object_'(This, Queue, _, _, _, _, _, _), !, MTCalls0) ), MTExit = '$lgt_mt_threaded_and_exit'(TGoals, Tag, Queue, Results). '$lgt_tr_threaded_and_call'((TGoal, TGoals), Queue, (MTCall, MTCalls), [Id| Ids], Tag, [Result| Results]) :- !, '$lgt_tr_threaded_and_call'(TGoal, Queue, MTCall, [Id], Tag, [Result]), '$lgt_tr_threaded_and_call'(TGoals, Queue, MTCalls, Ids, Tag, Results). '$lgt_tr_threaded_and_call'(TGoal, Queue, thread_create('$lgt_mt_threaded_and_call'(TGoal, Tag, Id, Queue), Id, [detached(false)]), [Id], Tag, [id(Id, _)]). '$lgt_tr_threaded_or_call'(TGoals, MTCalls, MTExit, Ctx) :- '$lgt_tr_threaded_or_call'(TGoals, Queue, MTCalls0, Tag, Tag, Results), ( '$lgt_pp_object_'(_, Queue, _, _, _, _, _, _, _, _, _) -> MTCalls = MTCalls0 ; '$lgt_ctx_this'(Ctx, This), MTCalls = ('$lgt_current_object_'(This, Queue, _, _, _, _, _, _), !, MTCalls0) ), MTExit = '$lgt_mt_threaded_or_exit'(TGoals, Tag, Queue, Results). '$lgt_tr_threaded_or_call'((TGoal; TGoals), Queue, (MTCall, MTCalls), [Id| Ids], Tag, [Result| Results]) :- !, '$lgt_tr_threaded_or_call'(TGoal, Queue, MTCall, [Id], Tag, [Result]), '$lgt_tr_threaded_or_call'(TGoals, Queue, MTCalls, Ids, Tag, Results). '$lgt_tr_threaded_or_call'(TGoal, Queue, thread_create('$lgt_mt_threaded_or_call'(TGoal, Tag, Id, Queue), Id, [detached(false)]), [Id], Tag, [id(Id, _)]). % '$lgt_thread_get_notifications'(@term, @object_identifier) % % translates the notification argument of a built-in predicate threaded_wait/1 call '$lgt_thread_get_notifications'(Msg, Prefix) :- var(Msg), !, thread_get_message(Prefix, '$lgt_notification'(Msg)). '$lgt_thread_get_notifications'([], _) :- !. '$lgt_thread_get_notifications'([Msg| Msgs], Prefix) :- !, thread_get_message(Prefix, '$lgt_notification'(Msg)), '$lgt_thread_get_notifications'(Msgs, Prefix). '$lgt_thread_get_notifications'(Msg, Prefix) :- thread_get_message(Prefix, '$lgt_notification'(Msg)). % '$lgt_thread_send_notifications'(@term, @object_identifier) % % translates the notification argument of a built-in predicate threaded_notify/1 call '$lgt_thread_send_notifications'(Msg, Prefix) :- var(Msg), !, thread_send_message(Prefix, '$lgt_notification'(Msg)). '$lgt_thread_send_notifications'([], _) :- !. '$lgt_thread_send_notifications'([Msg| Msgs], Prefix) :- !, thread_send_message(Prefix, '$lgt_notification'(Msg)), '$lgt_thread_send_notifications'(Msgs, Prefix). '$lgt_thread_send_notifications'(Msg, Prefix) :- thread_send_message(Prefix, '$lgt_notification'(Msg)). % '$lgt_tr_meta_args'(@list, @list, +term, -list, -list) % % translates the meta-arguments contained in the list of % arguments of a call to a meta-predicate '$lgt_tr_meta_args'([], [], _, [], []). '$lgt_tr_meta_args'([Arg| Args], [MArg| MArgs], Ctx, [TArg| TArgs], [DArg| DArgs]) :- '$lgt_tr_meta_arg'(MArg, Arg, Ctx, TArg, DArg), '$lgt_tr_meta_args'(Args, MArgs, Ctx, TArgs, DArgs). '$lgt_tr_meta_arg'(*, Arg, _, Arg, Arg). '$lgt_tr_meta_arg'(::, Arg, Ctx, TArg, DArg) :- '$lgt_tr_body'(Arg, TArg, DArg, Ctx). % '$lgt_same_meta_arg_extra_args'(@list(nonvar), @list(var), @var, +integer) % % checks that the number of addtional arguments being appended to a closure % in a call/N call matches the corresponding meta-predicate declaration % (the relative ordering of the meta-vars is the same of the corresponding % meta-arguments) '$lgt_same_meta_arg_extra_args'([(*)| MetaArgs], MetaVars, Closure, ExtraArgs) :- !, '$lgt_same_meta_arg_extra_args'(MetaArgs, MetaVars, Closure, ExtraArgs). '$lgt_same_meta_arg_extra_args'([(::)| MetaArgs], MetaVars, Closure, ExtraArgs) :- !, '$lgt_same_meta_arg_extra_args'(MetaArgs, MetaVars, Closure, ExtraArgs). '$lgt_same_meta_arg_extra_args'([MetaArg| _], [MetaVar| _], Closure, ExtraArgs) :- MetaVar == Closure, !, integer(MetaArg), MetaArg =:= ExtraArgs. '$lgt_same_meta_arg_extra_args'([_| MetaArgs], [_| MetaVars], Closure, ExtraArgs) :- '$lgt_same_meta_arg_extra_args'(MetaArgs, MetaVars, Closure, ExtraArgs). % '$lgt_optimizable_local_db_call'(@term, @nonvar, -callable) % % checks if a call to a database built-in method can be optimized by direct % translation to a call to the corresponding Prolog built-in predicate '$lgt_optimizable_local_db_call'(Pred, Ctx, TPred) :- '$lgt_compiler_flag'(debug, off), % not debugging callable(Pred), ( Pred = (Head :- Body) -> % only facts allowed Body == true, Pred2 = Head ; Pred2 = Pred ), functor(Pred2, Functor, Arity), '$lgt_pp_dynamic_'(Functor, Arity), ( '$lgt_pp_public_'(Functor, Arity) % a scope directive must be present ; '$lgt_pp_protected_'(Functor, Arity) ; '$lgt_pp_private_'(Functor, Arity) ), !, Pred2 =.. [Functor| Args], '$lgt_ctx_ctx'(Ctx, _, _, _, _, EntityPrefix, _, _), '$lgt_construct_predicate_functor'(EntityPrefix, Functor, Arity, PredPrefix), '$lgt_append'(Args, [_, _, _], Args2), TPred =.. [PredPrefix| Args2]. % '$lgt_runtime_db_clause_chk'(@term) % % true if the argument forces runtime validity check '$lgt_runtime_db_clause_chk'(Pred) :- var(Pred), !. '$lgt_runtime_db_clause_chk'((Head :- _)) :- var(Head), !. '$lgt_runtime_db_clause_chk'((_ :- Body)) :- var(Body). % '$lgt_compiler_db_clause_chk'(@nonvar) % % throws an error if the argument is invalid '$lgt_compiler_db_clause_chk'((Head :- _)) :- \+ callable(Head), throw(type_error(callable, Head)). '$lgt_compiler_db_clause_chk'((_ :- Body)) :- nonvar(Body), \+ callable(Body), throw(type_error(callable, Body)). '$lgt_compiler_db_clause_chk'(Clause) :- \+ callable(Clause), throw(type_error(callable, Clause)). '$lgt_compiler_db_clause_chk'(_). % '$lgt_runtime_db_pred_ind_chk'(@term) % % true if the argument forces runtime validity check '$lgt_runtime_db_pred_ind_chk'(Pred) :- var(Pred), !. '$lgt_runtime_db_pred_ind_chk'(Functor/_) :- var(Functor), !. '$lgt_runtime_db_pred_ind_chk'(_/Arity) :- var(Arity). % '$lgt_compiler_db_pred_ind_chk'(@nonvar) % % throws an error if the argument is invalid '$lgt_compiler_db_pred_ind_chk'(Term) :- Term \= (_/_), throw(type_error(predicate_indicator, Term)). '$lgt_compiler_db_pred_ind_chk'(Functor/_) :- \+ atom(Functor), throw(type_error(atom, Functor)). '$lgt_compiler_db_pred_ind_chk'(_/Arity) :- \+ integer(Arity), throw(type_error(integer, Arity)). '$lgt_compiler_db_pred_ind_chk'(_/Arity) :- integer(Arity), Arity < 0, throw(domain_error(not_less_than_zero, Arity)). '$lgt_compiler_db_pred_ind_chk'(_). % '$lgt_tr_msg'(@term, @object_identifier, -nonvar, @object_identifier) % % translates the sending of a message to an object '$lgt_tr_msg'(Pred, Obj, TPred, This) :- nonvar(Obj), ( (Obj = (_, _); Obj = (_; _)) -> !, '$lgt_tr_msg_broadcasting'(Obj, Pred, TPred, This) % message broadcasting ; ( \+ callable(Obj) -> throw(type_error(object_identifier, Obj)) % invalid object identifier ; This \== user, % not runtime message translation assertz('$lgt_pp_referenced_object_'(Obj)), % remember object receiving message fail ) ). % translation performed at runtime '$lgt_tr_msg'(Pred, Obj, TPred, This) :- var(Pred), !, ( '$lgt_compiler_flag'(events, on) -> TPred = '$lgt_send_to_object'(Obj, Pred, This) ; TPred = '$lgt_send_to_object_ne'(Obj, Pred, This) ). % invalid message '$lgt_tr_msg'(Pred, _, _, _) :- \+ callable(Pred), throw(type_error(callable, Pred)). % control constructs '$lgt_tr_msg'((Pred1, Pred2), Obj, (TPred1, TPred2), This) :- !, '$lgt_tr_msg'(Pred1, Obj, TPred1, This), '$lgt_tr_msg'(Pred2, Obj, TPred2, This). '$lgt_tr_msg'((Pred1; Pred2), Obj, (TPred1; TPred2), This) :- !, '$lgt_tr_msg'(Pred1, Obj, TPred1, This), '$lgt_tr_msg'(Pred2, Obj, TPred2, This). '$lgt_tr_msg'((Pred1 -> Pred2), Obj, (TPred1 -> TPred2), This) :- !, '$lgt_tr_msg'(Pred1, Obj, TPred1, This), '$lgt_tr_msg'(Pred2, Obj, TPred2, This). '$lgt_tr_msg'(\+ Pred, Obj, \+ TPred, This) :- !, '$lgt_tr_msg'(Pred, Obj, TPred, This). '$lgt_tr_msg'(!, Obj, ('$lgt_obj_exists'(Obj, !, This), !), This) :- !. '$lgt_tr_msg'(true, Obj, ('$lgt_obj_exists'(Obj, true, This), true), This) :- !. '$lgt_tr_msg'(fail, Obj, ('$lgt_obj_exists'(Obj, fail, This), fail), This) :- !. '$lgt_tr_msg'(repeat, Obj, ('$lgt_obj_exists'(Obj, repeat, This), repeat), This) :- !. '$lgt_tr_msg'(call(Pred), Obj, TPred, This) :- !, '$lgt_tr_msg'(Pred, Obj, TPred, This). '$lgt_tr_msg'(CallN, Obj, TPred, This) :- CallN =.. [call, Closure| Args], !, TPred = '$lgt_metacall_in_object'(Closure, Args, local, This, Obj, Obj). '$lgt_tr_msg'(once(Pred), Obj, once(TPred), This) :- !, '$lgt_tr_msg'(Pred, Obj, TPred, This). '$lgt_tr_msg'(catch(Goal, Catcher, Recovery), Obj, catch(TGoal, Catcher, TRecovery), This) :- !, '$lgt_tr_msg'(Goal, Obj, TGoal, This), '$lgt_tr_msg'(Recovery, Obj, TRecovery, This). '$lgt_tr_msg'(throw(Error), Obj, ('$lgt_obj_exists'(Obj, throw(Error), This), throw(Error)), This) :- !. % built-in meta-predicates '$lgt_tr_msg'(bagof(Term, Pred, List), Obj, bagof(Term, TPred, List), This) :- !, '$lgt_tr_msg'(Pred, Obj, TPred, This). '$lgt_tr_msg'(findall(Term, Pred, List), Obj, findall(Term, TPred, List), This) :- !, '$lgt_tr_msg'(Pred, Obj, TPred, This). '$lgt_tr_msg'(forall(Gen, Test), Obj, forall(TGen, TTest), This) :- !, '$lgt_tr_msg'(Gen, Obj, TGen, This), '$lgt_tr_msg'(Test, Obj, TTest, This). '$lgt_tr_msg'(setof(Term, Pred, List), Obj, setof(Term, TPred, List), This) :- !, '$lgt_tr_msg'(Pred, Obj, TPred, This). % "reflection" built-in predicates '$lgt_tr_msg'(current_predicate(Pred), Obj, '$lgt_current_predicate'(Obj, Pred, This, p(p(p))), This) :- !. '$lgt_tr_msg'(predicate_property(Pred, Prop), Obj, '$lgt_predicate_property'(Obj, Pred, Prop, This, p(p(p))), This) :- !. % database handling built-in predicates '$lgt_tr_msg'(abolish(Pred), Obj, TPred, This) :- !, ( '$lgt_runtime_db_pred_ind_chk'(Pred) -> TPred = '$lgt_abolish'(Obj, Pred, This, p(p(p))) ; '$lgt_compiler_db_pred_ind_chk'(Pred), TPred = '$lgt_abolish_chk'(Obj, Pred, This, p(p(p))) ). '$lgt_tr_msg'(asserta(Pred), Obj, TPred, This) :- !, ( '$lgt_runtime_db_clause_chk'(Pred) -> TPred = '$lgt_asserta'(Obj, Pred, This, p(p(_)), p(p(p))) ; '$lgt_compiler_db_clause_chk'(Pred), ( Pred = (Head :- Body) -> ( Body == true -> TPred = '$lgt_asserta_fact_chk'(Obj, Head, This, p(p(_)), p(p(p))) ; TPred = '$lgt_asserta_rule_chk'(Obj, Pred, This, p(p(_)), p(p(p))) ) ; TPred = '$lgt_asserta_fact_chk'(Obj, Pred, This, p(p(_)), p(p(p))) ) ). '$lgt_tr_msg'(assertz(Pred), Obj, TPred, This) :- !, ( '$lgt_runtime_db_clause_chk'(Pred) -> TPred = '$lgt_assertz'(Obj, Pred, This, p(p(_)), p(p(p))) ; '$lgt_compiler_db_clause_chk'(Pred), ( Pred = (Head :- Body) -> ( Body == true -> TPred = '$lgt_assertz_fact_chk'(Obj, Head, This, p(p(_)), p(p(p))) ; TPred = '$lgt_assertz_rule_chk'(Obj, Pred, This, p(p(_)), p(p(p))) ) ; TPred = '$lgt_assertz_fact_chk'(Obj, Pred, This, p(p(_)), p(p(p))) ) ). '$lgt_tr_msg'(clause(Head, Body), Obj, TPred, This) :- !, ( '$lgt_runtime_db_clause_chk'((Head :- Body)) -> TPred = '$lgt_clause'(Obj, Head, Body, This, p(p(p))) ; '$lgt_compiler_db_clause_chk'((Head :- Body)), TPred = '$lgt_clause_chk'(Obj, Head, Body, This, p(p(p))) ). '$lgt_tr_msg'(retract(Pred), Obj, TPred, This) :- !, ( '$lgt_runtime_db_clause_chk'(Pred) -> TPred = '$lgt_retract'(Obj, Pred, This, p(p(p))) ; '$lgt_compiler_db_clause_chk'(Pred), ( Pred = (Head :- Body) -> ( var(Body) -> '$lgt_retract_var_body_chk'(Obj, Pred, This, p(p(p))) ; Body == true -> TPred = '$lgt_retract_fact_chk'(Obj, Head, This, p(p(p))) ; TPred = '$lgt_retract_rule_chk'(Obj, Pred, This, p(p(p))) ) ; TPred = '$lgt_retract_fact_chk'(Obj, Pred, This, p(p(p))) ) ). '$lgt_tr_msg'(retractall(Pred), Obj, TPred, This) :- !, ( '$lgt_runtime_db_clause_chk'(Pred) -> TPred = '$lgt_retractall'(Obj, Pred, This, p(p(p))) ; '$lgt_compiler_db_clause_chk'(Pred), TPred = '$lgt_retractall_chk'(Obj, Pred, This, p(p(p))) ). % DCG predicates '$lgt_tr_msg'(expand_term(Term, Clause), Obj, '$lgt_expand_term'(Obj, Term, Clause, This, p(p(p))), This) :- !. '$lgt_tr_msg'(phrase(GRBody, List), Obj, '$lgt_phrase'(Obj, GRBody, List, This, p(p(p))), This) :- !. '$lgt_tr_msg'(phrase(GRBody, List, Rest), Obj, '$lgt_phrase'(Obj, GRBody, List, Rest, This, p(p(p))), This) :- !. % message is not a built-in control construct or a call to a built-in % (meta-)predicate: translation performed at runtime '$lgt_tr_msg'(Pred, Obj, TPred, This) :- ( var(Obj) -> ( '$lgt_compiler_flag'(events, on) -> TPred = '$lgt_send_to_object'(Obj, Pred, This) ; TPred = '$lgt_send_to_object_ne'(Obj, Pred, This) ) ; ( '$lgt_compiler_flag'(events, on) -> ( '$lgt_obj_static_binding_cache'(Obj, Pred, This, Call) -> TPred = (\+ ('$lgt_before_'(Obj, Pred, This, _, BCall), \+ call(BCall)), Call, \+ ('$lgt_after_'(Obj, Pred, This, _, ACall), \+ call(ACall))) ; TPred = '$lgt_send_to_object_nv'(Obj, Pred, This) ) ; ( '$lgt_obj_static_binding_cache'(Obj, Pred, This, Call) -> TPred = Call ; TPred = '$lgt_send_to_object_ne_nv'(Obj, Pred, This) ) ) ). % '$lgt_tr_self_msg'(@term, -nonvar, @object_identifier, @object_identifier) % % translates the sending of a message to self % translation performed at runtime '$lgt_tr_self_msg'(Pred, '$lgt_send_to_self'(Self, Pred, This), This, Self) :- var(Pred), !. % invalid message '$lgt_tr_self_msg'(Pred, _, _, _) :- \+ callable(Pred), throw(type_error(callable, Pred)). % control constructs '$lgt_tr_self_msg'((Pred1, Pred2), (TPred1, TPred2), This, Self) :- !, '$lgt_tr_self_msg'(Pred1, TPred1, This, Self), '$lgt_tr_self_msg'(Pred2, TPred2, This, Self). '$lgt_tr_self_msg'(((Pred1; Pred2)), (TPred1; TPred2), This, Self) :- !, '$lgt_tr_self_msg'(Pred1, TPred1, This, Self), '$lgt_tr_self_msg'(Pred2, TPred2, This, Self). '$lgt_tr_self_msg'((Pred1 -> Pred2), (TPred1 -> TPred2), This, Self) :- !, '$lgt_tr_self_msg'(Pred1, TPred1, This, Self), '$lgt_tr_self_msg'(Pred2, TPred2, This, Self). '$lgt_tr_self_msg'(\+ Pred, \+ TPred, This, Self) :- !, '$lgt_tr_self_msg'(Pred, TPred, This, Self). '$lgt_tr_self_msg'(!, !, _, _) :- !. '$lgt_tr_self_msg'(true, true, _, _) :- !. '$lgt_tr_self_msg'(fail, fail, _, _) :- !. '$lgt_tr_self_msg'(repeat, repeat, _, _) :- !. '$lgt_tr_self_msg'(call(Pred), TPred, This, Self) :- !, '$lgt_tr_self_msg'(Pred, TPred, This, Self). '$lgt_tr_self_msg'(CallN, TPred, This, Self) :- CallN =.. [call, Closure| Args], !, TPred = '$lgt_metacall_in_object'(Closure, Args, local, This, Self, Self). '$lgt_tr_self_msg'(once(Pred), once(TPred), This, Self) :- !, '$lgt_tr_self_msg'(Pred, TPred, This, Self). '$lgt_tr_self_msg'(catch(Goal, Catcher, Recovery), catch(TGoal, Catcher, TRecovery), This, Self) :- !, '$lgt_tr_self_msg'(Goal, TGoal, This, Self), '$lgt_tr_self_msg'(Recovery, TRecovery, This, Self). '$lgt_tr_self_msg'(throw(Error), throw(Error), _, _) :- !. % built-in meta-predicates '$lgt_tr_self_msg'(bagof(Term, Pred, List), bagof(Term, TPred, List), This, Self) :- !, '$lgt_tr_self_msg'(Pred, TPred, This, Self). '$lgt_tr_self_msg'(findall(Term, Pred, List), findall(Term, TPred, List), This, Self) :- !, '$lgt_tr_self_msg'(Pred, TPred, This, Self). '$lgt_tr_self_msg'(forall(Gen, Test), forall(TGen, TTest), This, Self) :- !, '$lgt_tr_self_msg'(Gen, TGen, This, Self), '$lgt_tr_self_msg'(Test, TTest, This, Self). '$lgt_tr_self_msg'(setof(Term, Pred, List), setof(Term, TPred, List), This, Self) :- !, '$lgt_tr_self_msg'(Pred, TPred, This, Self). % "reflection" built-in predicates '$lgt_tr_self_msg'(current_predicate(Pred), '$lgt_current_predicate'(Self, Pred, This, p(_)), This, Self) :- !. '$lgt_tr_self_msg'(predicate_property(Pred, Prop), '$lgt_predicate_property'(Self, Pred, Prop, This, p(_)), This, Self) :- !. % database handling built-in predicates '$lgt_tr_self_msg'(abolish(Pred), TPred, This, Self) :- !, ( '$lgt_runtime_db_pred_ind_chk'(Pred) -> TPred = '$lgt_abolish'(Self, Pred, This, p(_)) ; '$lgt_compiler_db_pred_ind_chk'(Pred), TPred = '$lgt_abolish_chk'(Self, Pred, This, p(_)) ). '$lgt_tr_self_msg'(asserta(Pred), TPred, This, Self) :- !, ( '$lgt_runtime_db_clause_chk'(Pred) -> TPred = '$lgt_asserta'(Self, Pred, This, p(_), p(p)) ; '$lgt_compiler_db_clause_chk'(Pred), ( Pred = (Head :- Body) -> ( Body == true -> TPred = '$lgt_asserta_fact_chk'(Self, Head, This, p(_), p(p)) ; TPred = '$lgt_asserta_rule_chk'(Self, Pred, This, p(_), p(p)) ) ; TPred = '$lgt_asserta_fact_chk'(Self, Pred, This, p(_), p(p)) ) ). '$lgt_tr_self_msg'(assertz(Pred), TPred, This, Self) :- !, ( '$lgt_runtime_db_clause_chk'(Pred) -> TPred = '$lgt_assertz'(Self, Pred, This, p(_), p(p)) ; '$lgt_compiler_db_clause_chk'(Pred), ( Pred = (Head :- Body) -> ( Body == true -> TPred = '$lgt_assertz_fact_chk'(Self, Head, This, p(_), p(p)) ; TPred = '$lgt_assertz_rule_chk'(Self, Pred, This, p(_), p(p)) ) ; TPred = '$lgt_assertz_fact_chk'(Self, Pred, This, p(_), p(p)) ) ). '$lgt_tr_self_msg'(clause(Head, Body), TPred, This, Self) :- !, ( '$lgt_runtime_db_clause_chk'((Head :- Body)) -> TPred = '$lgt_clause'(Self, Head, Body, This, p(_)) ; '$lgt_compiler_db_clause_chk'((Head :- Body)), TPred = '$lgt_clause_chk'(Self, Head, Body, This, p(_)) ). '$lgt_tr_self_msg'(retract(Pred), TPred, This, Self) :- !, ( '$lgt_runtime_db_clause_chk'(Pred) -> TPred = '$lgt_retract'(Self, Pred, This, p(_)) ; '$lgt_compiler_db_clause_chk'(Pred), ( Pred = (Head :- Body) -> ( var(Body) -> '$lgt_retract_var_body_chk'(Self, Pred, This, p(_)) ; Body == true -> TPred = '$lgt_retract_fact_chk'(Self, Head, This, p(_)) ; TPred = '$lgt_retract_rule_chk'(Self, Pred, This, p(_)) ) ; TPred = '$lgt_retract_fact_chk'(Self, Pred, This, p(_)) ) ). '$lgt_tr_self_msg'(retractall(Pred), TPred, This, Self) :- !, ( '$lgt_runtime_db_clause_chk'(Pred) -> TPred = '$lgt_retractall'(Self, Pred, This, p(_)) ; '$lgt_compiler_db_clause_chk'(Pred), TPred = '$lgt_retractall_chk'(Self, Pred, This, p(_)) ). % DCG predicates '$lgt_tr_self_msg'(expand_term(Term, Clause), '$lgt_expand_term'(Self, Term, Clause, This, p(_)), This, Self) :- !. '$lgt_tr_self_msg'(phrase(GRBody, List), '$lgt_phrase'(Self, GRBody, List, This, p(_)), This, Self) :- !. '$lgt_tr_self_msg'(phrase(GRBody, List, Rest), '$lgt_phrase'(Self, GRBody, List, Rest, This, p(_)), This, Self) :- !. % message is not a built-in control construct or a call to a built-in % (meta-)predicate: translation performed at runtime '$lgt_tr_self_msg'(Pred, '$lgt_send_to_self_nv'(Self, Pred, This), This, Self) :- !. % message broadcasting (sending a message to several objects) '$lgt_tr_msg_broadcasting'((Obj1, Obj2), Pred, (TP1, TP2), This) :- !, '$lgt_tr_msg'(Pred, Obj1, TP1, This), '$lgt_tr_msg'(Pred, Obj2, TP2, This). '$lgt_tr_msg_broadcasting'((Obj1; Obj2), Pred, (TP1; TP2), This) :- !, '$lgt_tr_msg'(Pred, Obj1, TP1, This), '$lgt_tr_msg'(Pred, Obj2, TP2, This). % '$lgt_tr_super_call'(@term, -term, +term) % % translates calling of redefined predicates ("super" calls) '$lgt_tr_super_call'(Pred, _, _) :- % invalid goal (not callable) nonvar(Pred), \+ callable(Pred), throw(type_error(callable, Pred)). '$lgt_tr_super_call'(Pred, TPred, Ctx) :- % translation performed at runtime '$lgt_ctx_ctx'(Ctx, _, Sender, This, Self, _, _, _), ( var(Pred) -> TPred = '$lgt_send_to_super'(Self, Pred, This, Sender) ; TPred = '$lgt_send_to_super_nv'(Self, Pred, This, Sender) ). % '$lgt_pred_meta_vars'(+callable, -list) % % constructs a list of all variables that occur % in a position corresponding to a meta-argument '$lgt_pred_meta_vars'(Pred, MetaVars) :- functor(Pred, Functor, Arity), functor(Meta, Functor, Arity), ( '$lgt_pp_meta_predicate_'(Meta) -> Pred =.. [_| Args], Meta =.. [_| MArgs], '$lgt_extract_meta_vars'(Args, MArgs, MetaVars) ; MetaVars = [] ). % '$lgt_pred_meta_vars'(+callable, +callable, -list) % % constructs a list of all variables that occur % in a position corresponding to a meta-argument '$lgt_pred_meta_vars'(Pred, Meta, MetaVars) :- ( Meta == no -> MetaVars = [] ; Pred =.. [_| Args], Meta =.. [_| MArgs], '$lgt_extract_meta_vars'(Args, MArgs, MetaVars) ). % '$lgt_extract_meta_vars'(+list, +list, -list) '$lgt_extract_meta_vars'([], [], []). '$lgt_extract_meta_vars'([Var| Args], [MArg| MArgs], [Var| MetaVars]) :- var(Var), MArg \== (*), !, '$lgt_extract_meta_vars'(Args, MArgs, MetaVars). '$lgt_extract_meta_vars'([_| Args], [_| MArgs], MetaVars) :- '$lgt_extract_meta_vars'(Args, MArgs, MetaVars). % '$lgt_iso_read_term'(@stream, ?term, +read_options_list, @list) % % wraps read_term/3 call with the necessary operator settings '$lgt_iso_read_term'(Stream, Term, Options, Ops) :- catch( ('$lgt_save_operators'(Ops, Saved), '$lgt_add_operators'(Ops), read_term(Stream, Term, Options), '$lgt_remove_operators'(Ops), '$lgt_add_operators'(Saved)), Error, '$lgt_iso_read_error_handler'(Ops, Saved, Error)). % '$lgt_iso_read_term'(?term, +read_options_list, @list) % % wraps read_term/2 call with the necessary operator settings '$lgt_iso_read_term'(Term, Options, Ops) :- catch( ('$lgt_save_operators'(Ops, Saved), '$lgt_add_operators'(Ops), read_term(Term, Options), '$lgt_remove_operators'(Ops), '$lgt_add_operators'(Saved)), Error, '$lgt_iso_read_error_handler'(Ops, Saved, Error)). % '$lgt_iso_read'(@stream, ?term, @list) % % wraps read/2 call with the necessary operator settings '$lgt_iso_read'(Stream, Term, Ops) :- catch( ('$lgt_save_operators'(Ops, Saved), '$lgt_add_operators'(Ops), read(Stream, Term), '$lgt_remove_operators'(Ops), '$lgt_add_operators'(Saved)), Error, '$lgt_iso_read_error_handler'(Ops, Saved, Error)). % '$lgt_iso_read'(?term, @list) % % wraps read/1 call with the necessary operator settings '$lgt_iso_read'(Term, Ops) :- catch( ('$lgt_save_operators'(Ops, Saved), '$lgt_add_operators'(Ops), read(Term), '$lgt_remove_operators'(Ops), '$lgt_add_operators'(Saved)), Error, '$lgt_iso_read_error_handler'(Ops, Saved, Error)). % '$lgt_iso_write_term'(@stream_or_alias, @term, @write_options_list, @list) % % wraps write_term/3 call with the necessary operator settings '$lgt_iso_write_term'(Stream, Term, Options, Ops) :- catch( ('$lgt_save_operators'(Ops, Saved), '$lgt_add_operators'(Ops), write_term(Stream, Term, Options), '$lgt_remove_operators'(Ops), '$lgt_add_operators'(Saved)), Error, '$lgt_iso_read_error_handler'(Ops, Saved, Error)). % '$lgt_iso_write_term'(@term, @write_options_list, @list) % % wraps write_term/2 call with the necessary operator settings '$lgt_iso_write_term'(Term, Options, Ops) :- catch( ('$lgt_save_operators'(Ops, Saved), '$lgt_add_operators'(Ops), write_term(Term, Options), '$lgt_remove_operators'(Ops), '$lgt_add_operators'(Saved)), Error, '$lgt_iso_read_error_handler'(Ops, Saved, Error)). % '$lgt_iso_write'(@stream_or_alias, @term, @list) % % wraps write/2 call with the necessary operator settings '$lgt_iso_write'(Stream, Term, Ops) :- catch( ('$lgt_save_operators'(Ops, Saved), '$lgt_add_operators'(Ops), write(Stream, Term), '$lgt_remove_operators'(Ops), '$lgt_add_operators'(Saved)), Error, '$lgt_iso_read_error_handler'(Ops, Saved, Error)). % '$lgt_iso_write'(@term, @list) % % wraps write/1 call with the necessary operator settings '$lgt_iso_write'(Term, Ops):- catch( ('$lgt_save_operators'(Ops, Saved), '$lgt_add_operators'(Ops), write(Term), '$lgt_remove_operators'(Ops), '$lgt_add_operators'(Saved)), Error, '$lgt_iso_read_error_handler'(Ops, Saved, Error)). % '$lgt_iso_writeq'(@stream_or_alias, @term, @list) % % wraps writeq/2 call with the necessary operator settings '$lgt_iso_writeq'(Stream, Term, Ops) :- catch( ('$lgt_save_operators'(Ops, Saved), '$lgt_add_operators'(Ops), writeq(Stream, Term), '$lgt_remove_operators'(Ops), '$lgt_add_operators'(Saved)), Error, '$lgt_iso_read_error_handler'(Ops, Saved, Error)). % '$lgt_iso_writeq'(@term, @list) % % wraps writeq/1 call with the necessary operator settings '$lgt_iso_writeq'(Term, Ops) :- catch( ('$lgt_save_operators'(Ops, Saved), '$lgt_add_operators'(Ops), writeq(Term), '$lgt_remove_operators'(Ops), '$lgt_add_operators'(Saved)), Error, '$lgt_iso_read_error_handler'(Ops, Saved, Error)). % '$lgt_save_operators'(@list, -list) % % save currently defined operators that might be % redefined when a list of operators is added '$lgt_save_operators'([], []). '$lgt_save_operators'([op(_, Spec, Op)| Ops], Saved) :- ( current_op(Pr, SCSpec, Op), '$lgt_same_op_class'(Spec, SCSpec) -> Saved = [op(Pr, SCSpec, Op)| Saved2] ; Saved = Saved2 ), '$lgt_save_operators'(Ops, Saved2). % '$lgt_add_operators'(@list) % % adds operators to the global operator table '$lgt_add_operators'([]). '$lgt_add_operators'([op(Pr, Spec, Op)| Ops]) :- op(Pr, Spec, Op), '$lgt_add_operators'(Ops). % '$lgt_remove_operators'(@list) % % remove operators from the global operator table '$lgt_remove_operators'([]). '$lgt_remove_operators'([op(_, Spec, Op)| Ops]) :- op(0, Spec, Op), '$lgt_remove_operators'(Ops). % '$lgt_iso_read_error_handler'(@list, @list, @nonvar) % % restores operator table to the its state before the call % to one of the '$lgt_iso_read...' raised an error '$lgt_iso_read_error_handler'(Ops, Saved, Error) :- '$lgt_remove_operators'(Ops), '$lgt_add_operators'(Saved), throw(Error). % '$lgt_simplify_body'(+callable, -callable) % % remove redundant calls to true/0 from a translated clause body '$lgt_simplify_body'((A;B), (SA;SB)) :- !, '$lgt_simplify_body'(A, SA), '$lgt_simplify_body'(B, SB). '$lgt_simplify_body'((A->B), (SA->SB)) :- !, '$lgt_simplify_body'(A, SA), '$lgt_simplify_body'(B, SB). '$lgt_simplify_body'((true, B), SB) :- !, '$lgt_simplify_body'(B, SB). '$lgt_simplify_body'((B, true), SB) :- !, '$lgt_simplify_body'(B, SB). '$lgt_simplify_body'((A, B), (SA, SB)) :- !, '$lgt_simplify_body'(A, SA), '$lgt_simplify_body'(B, SB). '$lgt_simplify_body'(\+ A, \+ SA) :- !, '$lgt_simplify_body'(A, SA). '$lgt_simplify_body'(B, B). % '$lgt_tr_object_id'(+object_identifier, +atom) % % from the object identifier construct the set of % functor prefixes used in the compiled code clauses '$lgt_tr_object_id'(Obj, Mode) :- assertz('$lgt_pp_referenced_object_'(Obj)), '$lgt_construct_object_functors'(Obj, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Rnm), assertz('$lgt_pp_object_'(Obj, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Rnm, Mode)), asserta('$lgt_pp_pred_mutex_count_'(0)). % '$lgt_tr_category_id'(+category_identifier, +atom) % % from the category identifier construct the set of % functor prefixes used in the compiled code clauses '$lgt_tr_category_id'(Ctg, Mode) :- assertz('$lgt_pp_referenced_category_'(Ctg)), '$lgt_construct_category_functors'(Ctg, Prefix, Dcl, Def, Rnm), assertz('$lgt_pp_category_'(Ctg, Prefix, Dcl, Def, Rnm, Mode)), asserta('$lgt_pp_pred_mutex_count_'(0)). % '$lgt_tr_protocol_id'(+protocol_identifier, +atom) % % from the protocol identifier construct the set of % functor prefixes used in the compiled code clauses '$lgt_tr_protocol_id'(Ptc, Mode) :- assertz('$lgt_pp_referenced_protocol_'(Ptc)), '$lgt_construct_protocol_functors'(Ptc, Prefix, Dcl, Rnm), assertz('$lgt_pp_protocol_'(Ptc, Prefix, Dcl, Rnm, Mode)). % '$lgt_update_entity_comp_mode' % % updates entity compilation mode to "dynamic" (entities are static by default) '$lgt_update_entity_comp_mode' :- retract('$lgt_pp_object_'(Obj, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Rnm, _)), assertz('$lgt_pp_object_'(Obj, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Rnm, (dynamic))), !. '$lgt_update_entity_comp_mode' :- retract('$lgt_pp_protocol_'(Ptc, Prefix, Dcl, Rnm, _)), assertz('$lgt_pp_protocol_'(Ptc, Prefix, Dcl, Rnm, (dynamic))), !. '$lgt_update_entity_comp_mode' :- retract('$lgt_pp_category_'(Ctg, Prefix, Dcl, Def, Rnm, _)), assertz('$lgt_pp_category_'(Ctg, Prefix, Dcl, Def, Rnm, (dynamic))). % '$lgt_tr_implements_protocol'(+list, +object_identifier) % '$lgt_tr_implements_protocol'(+list, +category_identifier) % % translates an "implementents" relation between % a category or an object and a list of protocols '$lgt_tr_implements_protocol'([], _). '$lgt_tr_implements_protocol'([Ref| _], _) :- var(Ref), throw(instantiation_error). '$lgt_tr_implements_protocol'([Scope::Ptc| _], _) :- (var(Scope); var(Ptc)), throw(instantiation_error). '$lgt_tr_implements_protocol'([Ref| Refs], ObjOrCtg) :- ( '$lgt_valid_ref_scope'(Ref, Scope) -> ( '$lgt_valid_protocol_ref'(Ref, Ptc) -> assertz('$lgt_pp_referenced_protocol_'(Ptc)), assertz('$lgt_pp_rclause_'('$lgt_implements_protocol_'(ObjOrCtg, Ptc, Scope))), '$lgt_construct_protocol_functors'(Ptc, Prefix, Dcl, _), assertz('$lgt_pp_implemented_protocol_'(Ptc, Prefix, Dcl, Scope)), '$lgt_tr_implements_protocol'(Refs, ObjOrCtg) ; throw(type_error(protocol_identifier, Ptc)) ) ; throw(type_error(scope, Ref)) ). % '$lgt_tr_imports_category'(+list, +object_identifier) % '$lgt_tr_imports_category'(+list, +category_identifier) % % translates an "imports" relation between % an object/category and a list of categories '$lgt_tr_imports_category'([], _). '$lgt_tr_imports_category'([Ref| _], _) :- var(Ref), throw(instantiation_error). '$lgt_tr_imports_category'([Scope::Ctg| _], _) :- (var(Scope); var(Ctg)), throw(instantiation_error). '$lgt_tr_imports_category'([Ref| Refs], ObjOrCtg) :- ( '$lgt_valid_ref_scope'(Ref, Scope) -> ( '$lgt_valid_category_ref'(Ref, Ctg) -> assertz('$lgt_pp_referenced_category_'(Ctg)), assertz('$lgt_pp_rclause_'('$lgt_imports_category_'(ObjOrCtg, Ctg, Scope))), '$lgt_construct_category_functors'(Ctg, Prefix, Dcl, Def, _), assertz('$lgt_pp_imported_category_'(Ctg, Prefix, Dcl, Def, Scope)), '$lgt_tr_imports_category'(Refs, ObjOrCtg) ; throw(type_error(category_identifier, Ctg)) ) ; throw(type_error(scope, Ref)) ). % '$lgt_tr_instantiates_class'(+list, +object_identifier) % % translates an "instantiates" relation between % an instance and a list of classes '$lgt_tr_instantiates_class'([], _). '$lgt_tr_instantiates_class'([Ref| _], _) :- var(Ref), throw(instantiation_error). '$lgt_tr_instantiates_class'([Scope::Class| _], _) :- (var(Scope); var(Class)), throw(instantiation_error). '$lgt_tr_instantiates_class'([Ref| Refs], Obj) :- ( '$lgt_valid_ref_scope'(Ref, Scope) -> ( '$lgt_valid_object_ref'(Ref, Class) -> assertz('$lgt_pp_referenced_object_'(Class)), assertz('$lgt_pp_rclause_'('$lgt_instantiates_class_'(Obj, Class, Scope))), '$lgt_construct_object_functors'(Class, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, _), assertz('$lgt_pp_instantiated_class_'(Class, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Scope)), '$lgt_tr_instantiates_class'(Refs, Obj) ; throw(type_error(object_identifier, Class)) ) ; throw(type_error(scope, Ref)) ). % '$lgt_tr_specializes_class'(+list, +object_identifier) % % translates a "specializes" relation between % a class and a list of superclasses '$lgt_tr_specializes_class'([], _). '$lgt_tr_specializes_class'([Ref| _], _) :- var(Ref), throw(instantiation_error). '$lgt_tr_specializes_class'([Scope::Superclass| _], _) :- (var(Scope); var(Superclass)), throw(instantiation_error). '$lgt_tr_specializes_class'([Ref| Refs], Class) :- ( '$lgt_valid_ref_scope'(Ref, Scope) -> ( '$lgt_valid_object_ref'(Ref, Superclass) -> assertz('$lgt_pp_referenced_object_'(Superclass)), assertz('$lgt_pp_rclause_'('$lgt_specializes_class_'(Class, Superclass, Scope))), '$lgt_construct_object_functors'(Superclass, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, _), assertz('$lgt_pp_specialized_class_'(Superclass, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Scope)), '$lgt_tr_specializes_class'(Refs, Class) ; throw(type_error(object_identifier, Superclass)) ) ; throw(type_error(scope, Ref)) ). % '$lgt_tr_extends_object'(+list, +object_identifier) % % translates an "extends" relation between % a prototype and a list of parents '$lgt_tr_extends_object'([], _). '$lgt_tr_extends_object'([Ref| _], _) :- var(Ref), throw(instantiation_error). '$lgt_tr_extends_object'([Scope::Parent| _], _) :- (var(Scope); var(Parent)), throw(instantiation_error). '$lgt_tr_extends_object'([Ref| Refs], Obj) :- ( '$lgt_valid_ref_scope'(Ref, Scope) -> ( '$lgt_valid_object_ref'(Ref, Parent) -> assertz('$lgt_pp_referenced_object_'(Parent)), assertz('$lgt_pp_rclause_'('$lgt_extends_object_'(Obj, Parent, Scope))), '$lgt_construct_object_functors'(Parent, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, _), assertz('$lgt_pp_extended_object_'(Parent, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Scope)), '$lgt_tr_extends_object'(Refs, Obj) ; throw(type_error(object_identifier, Parent)) ) ; throw(type_error(scope, Ref)) ). % '$lgt_tr_extends_protocol'(+list, +protocol_identifier) % % translates an "extends" relation between % a protocol and a list of protocols '$lgt_tr_extends_protocol'([], _). '$lgt_tr_extends_protocol'([Ref| _], _) :- var(Ref), throw(instantiation_error). '$lgt_tr_extends_protocol'([Scope::Ptc| _], _) :- (var(Scope); var(Ptc)), throw(instantiation_error). '$lgt_tr_extends_protocol'([Ref| Refs], Ptc1) :- ( '$lgt_valid_ref_scope'(Ref, Scope) -> ( '$lgt_valid_protocol_ref'(Ref, Ptc2) -> assertz('$lgt_pp_referenced_protocol_'(Ptc2)), assertz('$lgt_pp_rclause_'('$lgt_extends_protocol_'(Ptc1, Ptc2, Scope))), '$lgt_construct_protocol_functors'(Ptc2, Prefix, Dcl, _), assertz('$lgt_pp_extended_protocol_'(Ptc2, Prefix, Dcl, Scope)), '$lgt_tr_extends_protocol'(Refs, Ptc1) ; throw(type_error(protocol_identifier, Ptc2)) ) ; throw(type_error(scope, Ref)) ). % '$lgt_report_problems'(+atom) % % reports any potential problem found while compiling an entity '$lgt_report_problems'(protocol) :- ( '$lgt_compiler_flag'(report, on) -> '$lgt_report_unknown_entities' ; true ). '$lgt_report_problems'(object) :- ( '$lgt_compiler_flag'(report, on) -> '$lgt_report_undef_pred_calls', '$lgt_report_misspelt_calls', '$lgt_report_non_portable_calls', '$lgt_report_unknown_entities' ; true ). '$lgt_report_problems'(category) :- '$lgt_report_problems'(object). % '$lgt_report_unknown_entities' % % reports any unknown referenced entities found while compiling an entity '$lgt_report_unknown_entities' :- ( '$lgt_compiler_flag'(unknown, warning) -> '$lgt_report_unknown_objects', '$lgt_report_unknown_protocols', '$lgt_report_unknown_categories' ; true ). % '$lgt_report_unknown_objects' % % report any unknown referenced objects found while compiling an entity '$lgt_report_unknown_objects' :- ( setof(Obj, '$lgt_unknown_object'(Obj), Objs) -> '$lgt_inc_compile_warnings_counter', nl, ( Objs = [_] -> write(' WARNING! Reference to unknown object: ') ; write(' WARNING! References to unknown objects: ') ), '$lgt_writeq_list'(Objs) ; true ). '$lgt_unknown_object'(Obj) :- '$lgt_pp_referenced_object_'(Obj), \+ '$lgt_current_object_'(Obj, _, _, _, _, _, _, _), % not a currently loaded object \+ '$lgt_pp_object_'(Obj, _, _, _, _, _, _, _, _, _, _), % not the object being compiled (self references) \+ '$lgt_pp_entity_init_'(object, Obj, _), % not an object defined in the source file being compiled \+ catch(current_module(Obj), _, fail). % not a currently loaded module; use catch/3 to avoid % errors with Prolog compilers with no module support % '$lgt_report_unknown_protocols' % % report any unknown referenced protocols found while compiling an entity '$lgt_report_unknown_protocols' :- ( setof(Ptc, '$lgt_unknown_protocol'(Ptc), Ptcs) -> '$lgt_inc_compile_warnings_counter', nl, ( Ptcs = [_] -> write(' WARNING! Reference to unknown protocol: ') ; write(' WARNING! References to unknown protocols: ') ), '$lgt_writeq_list'(Ptcs) ; true ). '$lgt_unknown_protocol'(Ptc) :- '$lgt_pp_referenced_protocol_'(Ptc), \+ '$lgt_current_protocol_'(Ptc, _, _), % not a currently loaded protocol \+ '$lgt_pp_protocol_'(Ptc, _, _, _, _), % not the protocol being compiled (self references) \+ '$lgt_pp_entity_init_'(protocol, Ptc, _). % not a protocol defined in the source file being compiled % '$lgt_report_unknown_categories' % % report any unknown referenced categories found while compiling an entity '$lgt_report_unknown_categories' :- ( setof(Ctg, '$lgt_unknown_category'(Ctg), Ctgs) -> '$lgt_inc_compile_warnings_counter', nl, ( Ctgs = [_] -> write(' WARNING! Reference to unknown category: ') ; write(' WARNING! References to unknown categories: ') ), '$lgt_writeq_list'(Ctgs) ; true ). '$lgt_unknown_category'(Ctg) :- '$lgt_pp_referenced_category_'(Ctg), \+ '$lgt_current_category_'(Ctg, _, _, _), % not a currently loaded category \+ '$lgt_pp_category_'(Ctg, _, _, _, _, _), % not the category being compiled (self references) \+ '$lgt_pp_entity_init_'(category, Ctg, _). % not a category defined in the source file being compiled % '$lgt_writeq_list'(+list) % % auxiliary predicate for writing a non-empty list of elements (quoted) '$lgt_writeq_list'([Term]) :- writeq(Term), !. '$lgt_writeq_list'([Term1, Term2| Terms]) :- writeq(Term1), write(', '), '$lgt_writeq_list'([Term2| Terms]). % '$lgt_write_list'(+list) % % auxiliary predicate for writing a non-empty list of elements (non-quoted) '$lgt_write_list'([Term]) :- write(Term), !. '$lgt_write_list'([Term1, Term2| Terms]) :- write(Term1), write(', '), '$lgt_write_list'([Term2| Terms]). % '$lgt_add_def_clause'(+callable, -callable, +atom, +integer, +nonvar) % % adds a "def clause" (used to translate a predicate call) and returns % the translated clause head '$lgt_add_def_clause'(Head, Functor, Arity, HeadDef, Ctx) :- functor(Meta, Functor, Arity), functor(HeadTemplate, Functor, Arity), HeadTemplate =.. [_| HeadTemplateArgs], Head =.. [_| HeadArgs], '$lgt_ctx_ctx'(Ctx, _, Sender, This, Self, EntityPrefix, _, MetaCallCtx), ( '$lgt_pp_meta_predicate_'(Meta) -> '$lgt_pred_meta_vars'(HeadTemplate, Meta, MetaVars), '$lgt_append'(HeadTemplateArgs, [MetaVars, Sender2, This2, Self2], HeadTemplateArgsDef), '$lgt_append'(HeadArgs, [MetaCallCtx, Sender, This, Self], HeadArgsDef) ; '$lgt_append'(HeadTemplateArgs, [Sender2, This2, Self2], HeadTemplateArgsDef), '$lgt_append'(HeadArgs, [Sender, This, Self], HeadArgsDef) ), '$lgt_construct_predicate_functor'(EntityPrefix, Functor, Arity, PredPrefix), HeadTemplateDef =.. [PredPrefix| HeadTemplateArgsDef], HeadDef =.. [PredPrefix| HeadArgsDef], ( '$lgt_pp_object_'(_, _, _, Def, _, _, _, _, _, _, _) -> true ; '$lgt_pp_category_'(_, _, _, Def, _, _) ), Clause =.. [Def, HeadTemplate, Sender2, This2, Self2, HeadTemplateDef], ( '$lgt_pp_def_'(Clause) -> true ; assertz('$lgt_pp_def_'(Clause)) ), ( '$lgt_built_in'(Head) -> ( '$lgt_pp_redefined_built_in_'(HeadTemplate, _, _, _, _) -> true ; assertz('$lgt_pp_redefined_built_in_'(HeadTemplate, Sender2, This2, Self2, HeadTemplateDef)) ) ; true ), ( '$lgt_pp_defs_pred_'(Functor, Arity) -> true ; assertz('$lgt_pp_defs_pred_'(Functor, Arity)) ). % '$lgt_add_ddef_clause'(+callable, +atom, +integer, -callable, +nonvar) % % adds a "ddef clause" (used to translate a predicate call) and returns % the translated clause head '$lgt_add_ddef_clause'(Head, Functor, Arity, HeadDef, Ctx) :- functor(Meta, Functor, Arity), functor(HeadTemplate, Functor, Arity), HeadTemplate =.. [_| HeadTemplateArgs], Head =.. [_| HeadArgs], '$lgt_ctx_ctx'(Ctx, _, Sender, This, Self, EntityPrefix, _, MetaCallCtx), ( '$lgt_pp_meta_predicate_'(Meta) -> '$lgt_pred_meta_vars'(HeadTemplate, Meta, MetaVars), '$lgt_append'(HeadTemplateArgs, [MetaVars, Sender2, This2, Self2], HeadTemplateArgsDef), '$lgt_append'(HeadArgs, [MetaCallCtx, Sender, This, Self], HeadArgsDef) ; '$lgt_append'(HeadTemplateArgs, [Sender2, This2, Self2], HeadTemplateArgsDef), '$lgt_append'(HeadArgs, [Sender, This, Self], HeadArgsDef) ), '$lgt_construct_predicate_functor'(EntityPrefix, Functor, Arity, PredPrefix), HeadTemplateDef =.. [PredPrefix| HeadTemplateArgsDef], HeadDef =.. [PredPrefix| HeadArgsDef], '$lgt_pp_object_'(_, _, _, _, _, _, _, _, DDef, _, _), Clause =.. [DDef, HeadTemplate, Sender2, This2, Self2, HeadTemplateDef], ( '$lgt_pp_ddef_'(Clause) -> true ; assertz('$lgt_pp_ddef_'(Clause)) ), ( '$lgt_built_in'(Head) -> ( '$lgt_pp_redefined_built_in_'(HeadTemplate, _, _, _, _) -> true ; assertz('$lgt_pp_redefined_built_in_'(HeadTemplate, Sender2, This2, Self2, HeadTemplateDef)) ) ; true ), ( '$lgt_pp_defs_pred_'(Functor, Arity) -> true ; assertz('$lgt_pp_defs_pred_'(Functor, Arity)) ). % '$lgt_update_ddef_table'(+atom, +callable, +callable) % % retracts a dynamic "ddef clause" (used to translate a predicate call) % if there are no more clauses for the predicate otherwise does nothing % % this is needed in order to allow definitions in ancestors to be found '$lgt_update_ddef_table'(DDef, Head, Call) :- functor(Call, CFunctor, CArity), functor(GCall, CFunctor, CArity), ( clause(GCall, _) -> true ; functor(Head, HFunctor, HArity), functor(GHead, HFunctor, HArity), Clause =.. [DDef, GHead, _, _, _, _], retractall(Clause), '$lgt_clean_lookup_caches'(GHead) ). % '$lgt_update_ddef_table_opt'(+callable, +callable, +callable) % % retracts a dynamic "ddef clause" (used to translate a predicate call) % if there are no more clauses for the predicate otherwise does nothing % % this is needed in order to allow definitions in ancestors to be found '$lgt_update_ddef_table_opt'(Head, Call, Clause) :- ( clause(Call, _) -> true ; retractall(Clause), '$lgt_clean_lookup_caches'(Head) ). % '$lgt_assert_ddcl_clause'(+atom, +term, +term) % % asserts a dynamic predicate declaration '$lgt_assert_ddcl_clause'(DDcl, Pred, Scope) :- functor(Pred, Functor, Arity), functor(DPred, Functor, Arity), Clause =.. [DDcl, DPred, Scope], assertz(Clause). % '$lgt_generate_code'(+atom) % % generates code for the entity being compiled '$lgt_generate_code'(protocol) :- '$lgt_fix_pred_calls', % needed because of possible initialization goal '$lgt_gen_protocol_clauses', '$lgt_gen_protocol_directives', '$lgt_gen_entity_init_goal'. '$lgt_generate_code'(object) :- '$lgt_gen_local_def_clauses', '$lgt_fix_synchronized_preds', '$lgt_fix_pred_calls', '$lgt_gen_object_clauses', '$lgt_gen_object_directives', '$lgt_gen_entity_init_goal'. '$lgt_generate_code'(category) :- '$lgt_gen_local_def_clauses', '$lgt_fix_synchronized_preds', '$lgt_fix_pred_calls', '$lgt_gen_category_clauses', '$lgt_gen_category_directives', '$lgt_gen_entity_init_goal'. '$lgt_gen_object_directives' :- '$lgt_gen_object_dynamic_directives', '$lgt_gen_object_discontiguous_directives'. '$lgt_gen_category_directives' :- '$lgt_gen_category_dynamic_directives', '$lgt_gen_category_discontiguous_directives'. '$lgt_gen_protocol_directives' :- ( '$lgt_pp_protocol_'(_, Prefix, Dcl, Rnm, (dynamic)) -> assertz('$lgt_pp_directive_'(dynamic(Prefix/2))), assertz('$lgt_pp_directive_'(dynamic(Dcl/6))), assertz('$lgt_pp_directive_'(dynamic(Dcl/7))), assertz('$lgt_pp_directive_'(dynamic(Rnm/3))) ; true ). '$lgt_gen_object_dynamic_directives' :- ( '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, (dynamic)) -> '$lgt_gen_dynamic_object_dynamic_directives' ; '$lgt_gen_static_object_dynamic_directives' ). '$lgt_gen_dynamic_object_dynamic_directives' :- '$lgt_pp_object_'(_, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Rnm, _), assertz('$lgt_pp_directive_'(dynamic(Prefix/8))), assertz('$lgt_pp_directive_'(dynamic(Dcl/6))), assertz('$lgt_pp_directive_'(dynamic(Dcl/8))), assertz('$lgt_pp_directive_'(dynamic(Def/5))), assertz('$lgt_pp_directive_'(dynamic(Def/6))), assertz('$lgt_pp_directive_'(dynamic(Super/6))), assertz('$lgt_pp_directive_'(dynamic(IDcl/8))), assertz('$lgt_pp_directive_'(dynamic(IDef/6))), assertz('$lgt_pp_directive_'(dynamic(DDcl/2))), assertz('$lgt_pp_directive_'(dynamic(DDef/5))), assertz('$lgt_pp_directive_'(dynamic(Rnm/3))), '$lgt_gen_dynamic_entity_dynamic_predicate_directives'. '$lgt_gen_dynamic_entity_dynamic_predicate_directives' :- '$lgt_pp_fdef_'(Clause), Clause \= (_ :- _), % only local table; reject linking clauses arg(5, Clause, Call), functor(Call, Functor, Arity), assertz('$lgt_pp_directive_'(dynamic(Functor/Arity))), fail. '$lgt_gen_dynamic_entity_dynamic_predicate_directives'. '$lgt_gen_static_object_dynamic_directives' :- '$lgt_pp_object_'(_, Prefix, _, _, _, _, _, DDcl, DDef, _, _), assertz('$lgt_pp_directive_'(dynamic(DDcl/2))), assertz('$lgt_pp_directive_'(dynamic(DDef/5))), '$lgt_pp_dynamic_'(Functor, Arity), '$lgt_construct_predicate_functor'(Prefix, Functor, Arity, TFunctor), functor(Meta, Functor, Arity), ( '$lgt_pp_meta_predicate_'(Meta) -> TArity is Arity + 4 ; TArity is Arity + 3 ), assertz('$lgt_pp_directive_'(dynamic(TFunctor/TArity))), fail. '$lgt_gen_static_object_dynamic_directives'. '$lgt_gen_object_discontiguous_directives' :- '$lgt_pp_object_'(_, Prefix, _, _, _, _, _, _, _, _, _), '$lgt_pp_discontiguous_'(Functor, Arity), '$lgt_construct_predicate_functor'(Prefix, Functor, Arity, TFunctor), functor(Meta, Functor, Arity), ( '$lgt_pp_meta_predicate_'(Meta) -> TArity is Arity + 4 ; TArity is Arity + 3 ), assertz('$lgt_pp_directive_'(discontiguous(TFunctor/TArity))), fail. '$lgt_gen_object_discontiguous_directives'. '$lgt_gen_category_dynamic_directives' :- ( '$lgt_pp_category_'(_, Prefix, Dcl, Def, Rnm, (dynamic)) -> assertz('$lgt_pp_directive_'(dynamic(Prefix/3))), assertz('$lgt_pp_directive_'(dynamic(Dcl/6))), assertz('$lgt_pp_directive_'(dynamic(Dcl/7))), assertz('$lgt_pp_directive_'(dynamic(Def/5))), assertz('$lgt_pp_directive_'(dynamic(Rnm/3))), '$lgt_gen_dynamic_entity_dynamic_predicate_directives' ; true ). '$lgt_gen_category_discontiguous_directives' :- '$lgt_pp_category_'(_, Prefix, _, _, _, _), '$lgt_pp_discontiguous_'(Functor, Arity), '$lgt_construct_predicate_functor'(Prefix, Functor, Arity, TFunctor), functor(Meta, Functor, Arity), ( '$lgt_pp_meta_predicate_'(Meta) -> TArity is Arity + 4 ; TArity is Arity + 3 ), assertz('$lgt_pp_directive_'(discontiguous(TFunctor/TArity))), fail. '$lgt_gen_category_discontiguous_directives'. '$lgt_gen_object_clauses' :- ( \+ '$lgt_pp_instantiated_class_'(_, _, _, _, _, _, _, _, _, _), \+ '$lgt_pp_specialized_class_'(_, _, _, _, _, _, _, _, _, _) -> '$lgt_gen_prototype_clauses' ; '$lgt_gen_ic_clauses' ). % '$lgt_gen_local_dcl_clauses'(-atom) % % a (local) predicate declaration is only generated if there is a scope % declaration for the predicate; the single argument returns the atom % "true" if there are local declaration clauses and the atom "fail" otherwise '$lgt_gen_local_dcl_clauses'(_) :- '$lgt_pp_entity'(_, _, _, Dcl, EntityCompilation), ( '$lgt_pp_public_'(Functor, Arity), Scope = p(p(p)) ; '$lgt_pp_protected_'(Functor, Arity), Scope = p(p) ; '$lgt_pp_private_'(Functor, Arity), Scope = p ), functor(Pred, Functor, Arity), ( '$lgt_pp_dynamic_'(Functor, Arity) -> Compilation = (dynamic) ; Compilation = EntityCompilation ), functor(Template, Functor, Arity), ( '$lgt_pp_meta_predicate_'(Template) -> Meta = Template ; Meta = no ), ( '$lgt_pp_non_terminal_'(Functor, _, Arity) -> NonTerminal = yes ; NonTerminal = no ), ( '$lgt_pp_synchronized_'(Pred, _) -> Synchronized = yes ; Synchronized = no ), Fact =.. [Dcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized], assertz('$lgt_pp_dcl_'(Fact)), fail. '$lgt_gen_local_dcl_clauses'(Local) :- ( '$lgt_pp_dcl_'(_) -> Local = true ; Local = fail ). % '$lgt_gen_local_def_clauses' % % generates local def clauses for undefined but declared (via scope or dynamic directives) predicates '$lgt_gen_local_def_clauses' :- '$lgt_pp_entity'(_, _, EntityPrefix, _, _), '$lgt_ctx_prefix'(Ctx, EntityPrefix), '$lgt_pp_dynamic_'(Functor, Arity), \+ '$lgt_pp_defs_pred_'(Functor, Arity), functor(Head, Functor, Arity), ( \+ '$lgt_pp_public_'(Functor, Arity), \+ '$lgt_pp_protected_'(Functor, Arity), \+ '$lgt_pp_private_'(Functor, Arity) -> '$lgt_add_ddef_clause'(Head, Functor, Arity, _, Ctx) ; '$lgt_add_def_clause'(Head, Functor, Arity, _, Ctx) ), fail. '$lgt_gen_local_def_clauses'. '$lgt_gen_protocol_clauses' :- '$lgt_gen_local_dcl_clauses'(Local), '$lgt_gen_protocol_linking_clauses'(Local), '$lgt_gen_protocol_extend_clauses', '$lgt_gen_protocol_catchall_clauses'. '$lgt_gen_protocol_linking_clauses'(true) :- '$lgt_pp_protocol_'(Ptc, _, PDcl, _, _), Head =.. [PDcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, Ptc], Body =.. [PDcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized], assertz('$lgt_pp_dcl_'((Head:-Body))). '$lgt_gen_protocol_linking_clauses'(fail). '$lgt_gen_protocol_extend_clauses' :- '$lgt_pp_protocol_'(_, _, PDcl1, PRnm, _), '$lgt_pp_extended_protocol_'(Ptc2, _, PDcl2, EScope), ( EScope == (public) -> Lookup =.. [PDcl2, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, Ctn] ; ( EScope == protected -> Call =.. [PDcl2, Pred, Scope2, Compilation, Meta, NonTerminal, Synchronized, Ctn], Lookup = (Call, (Scope2 == p -> Scope = p; Scope = p(p))) ; Scope = p, Lookup =.. [PDcl2, Pred, _, Compilation, Meta, NonTerminal, Synchronized, Ctn] ) ), ( '$lgt_pp_alias_'(Ptc2, _, _) -> Head =.. [PDcl1, Alias, Scope, Compilation, Meta, NonTerminal, Synchronized, Ctn], Rename =.. [PRnm, Ptc2, Pred, Alias], assertz('$lgt_pp_dcl_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup))) ; Head =.. [PDcl1, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, Ctn], assertz('$lgt_pp_dcl_'((Head:-Lookup))) ), fail. '$lgt_gen_protocol_extend_clauses'. % when a protocol is empty, i.e. when it does not contain any predicate declarations, and % does not extend other protocols, we need a catchall clause in order to prevent predicate % existence errors when sending a message to an object implementing (directly or % indirectly) the protocol '$lgt_gen_protocol_catchall_clauses' :- ( '$lgt_pp_dcl_'(_) -> true ; % empty, standalone protocol '$lgt_pp_protocol_'(_, _, Dcl, _, _), Head =.. [Dcl, _, _, _, _, _, _, _], assertz('$lgt_pp_dcl_'((Head:-fail))) ). '$lgt_construct_alias_functor'(Prefix, PRen) :- atom_concat(Prefix, '_alias', PRen). '$lgt_gen_category_clauses' :- '$lgt_gen_category_dcl_clauses', '$lgt_gen_category_def_clauses'. '$lgt_gen_category_dcl_clauses' :- '$lgt_gen_local_dcl_clauses'(Local), '$lgt_gen_category_linking_dcl_clauses'(Local), '$lgt_gen_category_implements_dcl_clauses', '$lgt_gen_category_imports_dcl_clauses', '$lgt_gen_category_catchall_dcl_clauses'. '$lgt_gen_category_linking_dcl_clauses'(true) :- '$lgt_pp_category_'(Ctg, _, CDcl, _, _, _), Head =.. [CDcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, Ctg], Body =.. [CDcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized], assertz('$lgt_pp_dcl_'((Head:-Body))). '$lgt_gen_category_linking_dcl_clauses'(fail). '$lgt_gen_category_implements_dcl_clauses' :- '$lgt_pp_category_'(_, _, CDcl, _, PRnm, _), '$lgt_pp_implemented_protocol_'(Ptc, _, PDcl, EScope), ( EScope == (public) -> Lookup =.. [PDcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, Ctn] ; ( EScope == protected -> Call =.. [PDcl, Pred, Scope2, Compilation, Meta, NonTerminal, Synchronized, Ctn], Lookup = (Call, (Scope2 == p -> Scope = p; Scope = p(p))) ; Scope = p, Lookup =.. [PDcl, Pred, _, Compilation, Meta, NonTerminal, Synchronized, Ctn] ) ), ( '$lgt_pp_alias_'(Ptc, _, _) -> Head =.. [CDcl, Alias, Scope, Compilation, Meta, NonTerminal, Synchronized, Ctn], Rename =.. [PRnm, Ptc, Pred, Alias], assertz('$lgt_pp_dcl_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup))) ; Head =.. [CDcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, Ctn], assertz('$lgt_pp_dcl_'((Head:-Lookup))) ), fail. '$lgt_gen_category_implements_dcl_clauses'. '$lgt_gen_category_imports_dcl_clauses' :- '$lgt_pp_category_'(_, _, CDcl, _, PRnm, _), '$lgt_pp_imported_category_'(Ctg, _, ECDcl, _, EScope), ( EScope == (public) -> Lookup =.. [ECDcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, Ctn] ; ( EScope == protected -> Call =.. [ECDcl, Pred, Scope2, Compilation, Meta, NonTerminal, Synchronized, Ctn], Lookup = (Call, (Scope2 == p -> Scope = p; Scope = p(p))) ; Scope = p, Lookup =.. [ECDcl, Pred, _, Compilation, Meta, NonTerminal, Synchronized, Ctn] ) ), ( '$lgt_pp_alias_'(Ctg, _, _) -> Head =.. [CDcl, Alias, Scope, Compilation, Meta, NonTerminal, Synchronized, Ctn], Rename =.. [PRnm, Ctg, Pred, Alias], assertz('$lgt_pp_dcl_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup))) ; Head =.. [CDcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, Ctn], assertz('$lgt_pp_dcl_'((Head:-Lookup))) ), fail. '$lgt_gen_category_imports_dcl_clauses'. % when a category contains no predicate declarations, does not implement any protocol, % and does not import other categories, we need a catchall clause in order to prevent % predicate existence errors when sending a message to an object importing (directly or % indirectly) the category '$lgt_gen_category_catchall_dcl_clauses' :- ( '$lgt_pp_dcl_'(_) -> true ; % standalone category with no local predicate declarations '$lgt_pp_category_'(_, _, Dcl, _, _, _), Head =.. [Dcl, _, _, _, _, _, _, _], assertz('$lgt_pp_dcl_'((Head:-fail))) ). '$lgt_gen_category_def_clauses' :- '$lgt_gen_category_linking_def_clauses', '$lgt_gen_category_imports_def_clauses'. '$lgt_gen_category_linking_def_clauses' :- '$lgt_pp_category_'(Ctg, _, _, Def, _, _), Head =.. [Def, Pred, Sender, This, Self, Call, Ctg], ( '$lgt_pp_fdef_'(_) -> Body =.. [Def, Pred, Sender, This, Self, Call] ; Body = fail ), assertz('$lgt_pp_fdef_'((Head:-Body))). '$lgt_gen_category_imports_def_clauses' :- '$lgt_pp_category_'(Ctg, _, _, Def, PRnm, _), '$lgt_pp_rclause_'('$lgt_imports_category_'(Ctg, Ctg2, _)), % needed for parameter passing '$lgt_pp_imported_category_'(Ctg2, _, _, Def2, _), Lookup =.. [Def2, Pred, Sender, This, Self, Call, Ctn], ( '$lgt_pp_alias_'(Ctg2, _, _) -> Head =.. [Def, Alias, Sender, This, Self, Call, Ctn], Rename =.. [PRnm, Ctg2, Pred, Alias], assertz('$lgt_pp_fdef_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup))) ; Head =.. [Def, Pred, Sender, This, Self, Call, Ctn], assertz('$lgt_pp_fdef_'((Head:-Lookup))) ), fail. '$lgt_gen_category_imports_def_clauses'. % the database built-in methods need to check if a local declaration or a local definition % exists for a predicate; in order to avoid predicate existence errors, we need to generate % catchall clauses when there are no local predicate declarations or no local predicate % definitions '$lgt_gen_object_catchall_dcl_clauses'(true). '$lgt_gen_object_catchall_dcl_clauses'(fail) :- '$lgt_pp_object_'(_, _, Dcl, _, _, _, _, _, _, _, _), % generate a catchall clause for Head =.. [Dcl, _, _, _, _, _, _], % objects that do not contain assertz('$lgt_pp_dcl_'((Head:-fail))). % predicate declarations '$lgt_gen_object_catchall_def_clauses'(true). '$lgt_gen_object_catchall_def_clauses'(fail) :- '$lgt_pp_object_'(_, _, _, Def, _, _, _, _, _, _, _), % generate a catchall clause Head =.. [Def, _, _, _, _, _], % for objects that do not assertz('$lgt_pp_fdef_'((Head:-fail))). % contain predicate definitions '$lgt_gen_prototype_clauses' :- '$lgt_gen_prototype_dcl_clauses', '$lgt_gen_prototype_def_clauses', '$lgt_gen_prototype_super_clauses'. '$lgt_gen_prototype_dcl_clauses' :- '$lgt_gen_local_dcl_clauses'(Local), '$lgt_gen_prototype_linking_dcl_clauses'(Local), '$lgt_gen_prototype_implements_dcl_clauses', '$lgt_gen_prototype_imports_dcl_clauses', '$lgt_gen_prototype_extends_dcl_clauses', '$lgt_gen_object_catchall_dcl_clauses'(Local). '$lgt_gen_prototype_linking_dcl_clauses'(Local) :- '$lgt_pp_object_'(Obj, _, Dcl, _, _, _, _, DDcl, _, _, _), ( call(Local) -> Head =.. [Dcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, Obj, Obj], Body =.. [Dcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized], assertz('$lgt_pp_dcl_'((Head:-Body))) ; true ), Head2 =.. [Dcl, Pred, Scope, (dynamic), no, no, no, Obj, Obj], Body2 =.. [DDcl, Pred, Scope], assertz('$lgt_pp_dcl_'((Head2:-Body2))). '$lgt_gen_prototype_implements_dcl_clauses' :- '$lgt_pp_object_'(Obj, _, ODcl, _, _, _, _, _, _, PRnm, _), '$lgt_pp_implemented_protocol_'(Ptc, _, PDcl, EScope), ( EScope == (public) -> Lookup =.. [PDcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, Ctn] ; ( EScope == protected -> Call =.. [PDcl, Pred, Scope2, Compilation, Meta, NonTerminal, Synchronized, Ctn], Lookup = (Call, (Scope2 == p -> Scope = p; Scope = p(p))) ; Scope = p, Lookup =.. [PDcl, Pred, _, Compilation, Meta, NonTerminal, Synchronized, Ctn] ) ), ( '$lgt_pp_alias_'(Ptc, _, _) -> Head =.. [ODcl, Alias, Scope, Compilation, Meta, NonTerminal, Synchronized, Obj, Ctn], Rename =.. [PRnm, Ptc, Pred, Alias], assertz('$lgt_pp_dcl_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup))) ; Head =.. [ODcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, Obj, Ctn], assertz('$lgt_pp_dcl_'((Head:-Lookup))) ), fail. '$lgt_gen_prototype_implements_dcl_clauses'. '$lgt_gen_prototype_imports_dcl_clauses' :- '$lgt_pp_object_'(Obj, _, ODcl, _, _, _, _, _, _, PRnm, _), '$lgt_pp_imported_category_'(Ctg, _, CDcl, _, EScope), ( EScope == (public) -> Lookup =.. [CDcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, Ctn] ; ( EScope == protected -> Call =.. [CDcl, Pred, Scope2, Compilation, Meta, NonTerminal, Synchronized, Ctn], Lookup = (Call, (Scope2 == p -> Scope = p; Scope = p(p))) ; Scope = p, Lookup =.. [CDcl, Pred, _, Compilation, Meta, NonTerminal, Synchronized, Ctn] ) ), ( '$lgt_pp_alias_'(Ctg, _, _) -> Head =.. [ODcl, Alias, Scope, Compilation, Meta, NonTerminal, Synchronized, Obj, Ctn], Rename =.. [PRnm, Ctg, Pred, Alias], assertz('$lgt_pp_dcl_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup))) ; Head =.. [ODcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, Obj, Ctn], assertz('$lgt_pp_dcl_'((Head:-Lookup))) ), fail. '$lgt_gen_prototype_imports_dcl_clauses'. '$lgt_gen_prototype_extends_dcl_clauses' :- '$lgt_pp_object_'(Obj, _, ODcl, _, _, _, _, _, _, PRnm, _), '$lgt_pp_extended_object_'(Parent, _, PDcl, _, _, _, _, _, _, EScope), ( EScope == (public) -> Lookup =.. [PDcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, SCtn, TCtn] ; ( EScope == protected -> Call =.. [PDcl, Pred, Scope2, Compilation, Meta, NonTerminal, Synchronized, SCtn, TCtn], Lookup = (Call, (Scope2 == p -> Scope = p; Scope = p(p))) ; Scope = p, Call =.. [PDcl, Pred, Scope2, Compilation, Meta, NonTerminal, Synchronized, SCtn2, TCtn], Lookup = (Call, (Scope2 == p -> SCtn = SCtn2; SCtn = Obj)) ) ), ( '$lgt_pp_alias_'(Parent, _, _) -> Head =.. [ODcl, Alias, Scope, Compilation, Meta, NonTerminal, Synchronized, SCtn, TCtn], Rename =.. [PRnm, Parent, Pred, Alias], assertz('$lgt_pp_dcl_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup))) ; Head =.. [ODcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, SCtn, TCtn], assertz('$lgt_pp_dcl_'((Head:-Lookup))) ), fail. '$lgt_gen_prototype_extends_dcl_clauses'. '$lgt_gen_prototype_def_clauses' :- ( '$lgt_pp_fdef_'(_) -> Local = true ; Local = fail ), '$lgt_gen_prototype_linking_def_clauses'(Local), '$lgt_gen_prototype_imports_def_clauses', '$lgt_gen_prototype_extends_def_clauses', '$lgt_gen_object_catchall_def_clauses'(Local). '$lgt_gen_prototype_linking_def_clauses'(Local) :- '$lgt_pp_object_'(Obj, _, _, Def, _, _, _, _, DDef, _, _), Head =.. [Def, Pred, Sender, This, Self, Call, Obj], ( call(Local) -> Body =.. [Def, Pred, Sender, This, Self, Call], assertz('$lgt_pp_fdef_'((Head:-Body))) ; true ), Body2 =.. [DDef, Pred, Sender, This, Self, Call], assertz('$lgt_pp_fdef_'((Head:-Body2))). '$lgt_gen_prototype_imports_def_clauses' :- '$lgt_pp_object_'(Obj, _, _, ODef, _, _, _, _, _, PRnm, _), '$lgt_pp_rclause_'('$lgt_imports_category_'(Obj, Ctg, _)), % needed for parameter passing '$lgt_pp_imported_category_'(Ctg, _, _, CDef, _), Lookup =.. [CDef, Pred, Sender, Obj, Self, Call, Ctn], ( '$lgt_pp_alias_'(Ctg, _, _) -> Head =.. [ODef, Alias, Sender, Obj, Self, Call, Ctn], Rename =.. [PRnm, Ctg, Pred, Alias], assertz('$lgt_pp_fdef_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup))) ; Head =.. [ODef, Pred, Sender, Obj, Self, Call, Ctn], assertz('$lgt_pp_fdef_'((Head:-Lookup))) ), fail. '$lgt_gen_prototype_imports_def_clauses'. '$lgt_gen_prototype_extends_def_clauses' :- '$lgt_pp_object_'(Obj, _, _, ODef, _, _, _, _, _, PRnm, _), '$lgt_pp_rclause_'('$lgt_extends_object_'(Obj, Parent, _)), % needed for parameter passing '$lgt_pp_extended_object_'(Parent, _, _, PDef, _, _, _, _, _, _), Lookup =.. [PDef, Pred, Sender, Parent, Self, Call, Ctn], ( '$lgt_pp_alias_'(Parent, _, _) -> Head =.. [ODef, Alias, Sender, Obj, Self, Call, Ctn], Rename =.. [PRnm, Parent, Pred, Alias], assertz('$lgt_pp_fdef_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup))) ; Head =.. [ODef, Pred, Sender, Obj, Self, Call, Ctn], assertz('$lgt_pp_fdef_'((Head:-Lookup))) ), fail. '$lgt_gen_prototype_extends_def_clauses'. % we can have a root object where super have nowhere to go ... '$lgt_gen_prototype_super_clauses' :- '$lgt_pp_object_'(_, _, _, _, OSuper, _, _, _, _, _, _), \+ '$lgt_pp_extended_object_'(_, _, _, _, _, _, _, _, _, _), Head =.. [OSuper, _, _, _, _, _, _], assertz('$lgt_pp_super_'((Head:-fail))), !. % ... or we may extends some objects '$lgt_gen_prototype_super_clauses' :- '$lgt_pp_object_'(Obj, _, _, _, OSuper, _, _, _, _, PRnm, _), '$lgt_pp_rclause_'('$lgt_extends_object_'(Obj, Parent, _)), % needed for parameter passing '$lgt_pp_extended_object_'(Parent, _, _, PDef, _, _, _, _, _, _), Lookup =.. [PDef, Pred, Sender, Parent, Self, Call, Ctn], ( '$lgt_pp_alias_'(Parent, _, _) -> Head =.. [OSuper, Alias, Sender, Obj, Self, Call, Ctn], Rename =.. [PRnm, Parent, Pred, Alias], assertz('$lgt_pp_super_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup))) ; Head =.. [OSuper, Pred, Sender, Obj, Self, Call, Ctn], assertz('$lgt_pp_super_'((Head:-Lookup))) ), fail. '$lgt_gen_prototype_super_clauses'. '$lgt_gen_ic_clauses' :- '$lgt_gen_ic_dcl_clauses', '$lgt_gen_ic_def_clauses', '$lgt_gen_ic_super_clauses'. '$lgt_gen_ic_dcl_clauses' :- '$lgt_gen_local_dcl_clauses'(Local), '$lgt_gen_ic_idcl_clauses'(Local), '$lgt_gen_ic_hierarchy_dcl_clauses', '$lgt_gen_object_catchall_dcl_clauses'(Local). '$lgt_gen_ic_hierarchy_dcl_clauses' :- \+ '$lgt_pp_instantiated_class_'(_, _, _, _, _, _, _, _, _, _), !, '$lgt_pp_object_'(_, _, ODcl, _, _, _, _, _, _, _, _), Head =.. [ODcl, _, _, _, _, _, _, _, _], assertz('$lgt_pp_dcl_'((Head:-fail))). '$lgt_gen_ic_hierarchy_dcl_clauses' :- '$lgt_pp_object_'(Obj, _, ODcl, _, _, _, _, _, _, PRnm, _), '$lgt_pp_instantiated_class_'(Class, _, _, _, _, CIDcl, _, _, _, EScope), ( EScope == (public) -> Lookup =.. [CIDcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, SCtn, TCtn] ; ( EScope == protected -> Call =.. [CIDcl, Pred, Scope2, Compilation, Meta, NonTerminal, Synchronized, SCtn, TCtn], Lookup = (Call, (Scope2 == p -> Scope = p; Scope = p(p))) ; Scope = p, Call =.. [CIDcl, Pred, Scope2, Compilation, Meta, NonTerminal, Synchronized, SCtn2, TCtn], Lookup = (Call, (Scope2 == p -> SCtn = SCtn2; SCtn = Obj)) ) ), ( '$lgt_pp_alias_'(Class, _, _) -> Head =.. [ODcl, Alias, Scope, Compilation, Meta, NonTerminal, Synchronized, SCtn, TCtn], Rename =.. [PRnm, Class, Pred, Alias], assertz('$lgt_pp_dcl_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup))) ; Head =.. [ODcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, SCtn, TCtn], assertz('$lgt_pp_dcl_'((Head:-Lookup))) ), fail. '$lgt_gen_ic_hierarchy_dcl_clauses'. % generates instance/class inherited declaration clauses '$lgt_gen_ic_idcl_clauses'(Local) :- '$lgt_gen_ic_linking_idcl_clauses'(Local), '$lgt_gen_ic_protocol_idcl_clauses', '$lgt_gen_ic_category_idcl_clauses', '$lgt_gen_ic_hierarchy_idcl_clauses'. '$lgt_gen_ic_linking_idcl_clauses'(Local) :- '$lgt_pp_object_'(Obj, _, Dcl, _, _, IDcl, _, DDcl, _, _, _), ( call(Local) -> Head =.. [IDcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, Obj, Obj], Body =.. [Dcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized], assertz('$lgt_pp_dcl_'((Head:-Body))) ; true ), Head2 =.. [IDcl, Pred, Scope, (dynamic), no, no, no, Obj, Obj], Body2 =.. [DDcl, Pred, Scope], assertz('$lgt_pp_dcl_'((Head2:-Body2))). '$lgt_gen_ic_protocol_idcl_clauses' :- '$lgt_pp_object_'(Obj, _, _, _, _, OIDcl, _, _, _, PRnm, _), '$lgt_pp_implemented_protocol_'(Ptc, _, PDcl, EScope), ( EScope == (public) -> Lookup =.. [PDcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, Ctn] ; ( EScope == protected -> Call =.. [PDcl, Pred, Scope2, Compilation, Meta, NonTerminal, Synchronized, Ctn], Lookup = (Call, (Scope2 == p -> Scope = p; Scope = p(p))) ; Scope = p, Lookup =.. [PDcl, Pred, _, Compilation, Meta, NonTerminal, Synchronized, Ctn] ) ), ( '$lgt_pp_alias_'(Ptc, _, _) -> Head =.. [OIDcl, Alias, Scope, Compilation, Meta, NonTerminal, Synchronized, Obj, Ctn], Rename =.. [PRnm, Ptc, Pred, Alias], assertz('$lgt_pp_dcl_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup))) ; Head =.. [OIDcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, Obj, Ctn], assertz('$lgt_pp_dcl_'((Head:-Lookup))) ), fail. '$lgt_gen_ic_protocol_idcl_clauses'. '$lgt_gen_ic_category_idcl_clauses' :- '$lgt_pp_object_'(Obj, _, _, _, _, OIDcl, _, _, _, PRnm, _), '$lgt_pp_imported_category_'(Ctg, _, CDcl, _, EScope), ( EScope == (public) -> Lookup =.. [CDcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, Ctn] ; ( EScope == protected -> Call =.. [CDcl, Pred, Scope2, Compilation, Meta, NonTerminal, Synchronized, Ctn], Lookup = (Call, (Scope2 == p -> Scope = p; Scope = p(p))) ; Scope = p, Lookup =.. [CDcl, Pred, _, Compilation, Meta, NonTerminal, Synchronized, Ctn] ) ), ( '$lgt_pp_alias_'(Ctg, _, _) -> Head =.. [OIDcl, Alias, Scope, Compilation, Meta, NonTerminal, Synchronized, Obj, Ctn], Rename =.. [PRnm, Ctg, Pred, Alias], assertz('$lgt_pp_dcl_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup))) ; Head =.. [OIDcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, Obj, Ctn], assertz('$lgt_pp_dcl_'((Head:-Lookup))) ), fail. '$lgt_gen_ic_category_idcl_clauses'. '$lgt_gen_ic_hierarchy_idcl_clauses' :- '$lgt_pp_object_'(Obj, _, _, _, _, CIDcl, _, _, _, PRnm, _), '$lgt_pp_specialized_class_'(Super, _, _, _, _, SIDcl, _, _, _, EScope), ( EScope == (public) -> Lookup =.. [SIDcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, SCtn, TCtn] ; ( EScope == protected -> Call =.. [SIDcl, Pred, Scope2, Compilation, Meta, NonTerminal, Synchronized, SCtn, TCtn], Lookup = (Call, (Scope2 == p -> Scope = p; Scope = p(p))) ; Scope = p, Call =.. [SIDcl, Pred, Scope2, Compilation, Meta, NonTerminal, Synchronized, SCtn2, TCtn], Lookup = (Call, (Scope2 == p -> SCtn = SCtn2; SCtn = Obj)) ) ), ( '$lgt_pp_alias_'(Super, _, _) -> Head =.. [CIDcl, Alias, Scope, Compilation, Meta, NonTerminal, Synchronized, SCtn, TCtn], Rename =.. [PRnm, Super, Pred, Alias], assertz('$lgt_pp_dcl_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup))) ; Head =.. [CIDcl, Pred, Scope, Compilation, Meta, NonTerminal, Synchronized, SCtn, TCtn], assertz('$lgt_pp_dcl_'((Head:-Lookup))) ), fail. '$lgt_gen_ic_hierarchy_idcl_clauses'. '$lgt_gen_ic_def_clauses' :- ( '$lgt_pp_fdef_'(_) -> Local = true ; Local = fail ), '$lgt_gen_ic_linking_def_clauses'(Local), '$lgt_gen_ic_imports_def_clauses', '$lgt_gen_ic_hierarchy_def_clauses', '$lgt_gen_ic_idef_clauses'(Local), '$lgt_gen_object_catchall_def_clauses'(Local). '$lgt_gen_ic_linking_def_clauses'(Local) :- '$lgt_pp_object_'(Obj, _, _, Def, _, _, _, _, DDef, _, _), Head =.. [Def, Pred, Sender, This, Self, Call, Obj], ( call(Local) -> Body =.. [Def, Pred, Sender, This, Self, Call], assertz('$lgt_pp_fdef_'((Head:-Body))) ; true ), Body2 =.. [DDef, Pred, Sender, This, Self, Call], assertz('$lgt_pp_fdef_'((Head:-Body2))). '$lgt_gen_ic_imports_def_clauses' :- '$lgt_pp_object_'(Obj, _, _, ODef, _, _, _, _, _, PRnm, _), '$lgt_pp_rclause_'('$lgt_imports_category_'(Obj, Ctg, _)), % needed for parameter passing '$lgt_pp_imported_category_'(Ctg, _, _, CDef, _), Lookup =.. [CDef, Pred, Sender, Obj, Self, Call, Ctn], ( '$lgt_pp_alias_'(Ctg, _, _) -> Head =.. [ODef, Alias, Sender, Obj, Self, Call, Ctn], Rename =.. [PRnm, Ctg, Pred, Alias], assertz('$lgt_pp_fdef_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup))) ; Head =.. [ODef, Pred, Sender, Obj, Self, Call, Ctn], assertz('$lgt_pp_fdef_'((Head:-Lookup))) ), fail. '$lgt_gen_ic_imports_def_clauses'. '$lgt_gen_ic_hierarchy_def_clauses' :- '$lgt_pp_object_'(Obj, _, _, ODef, _, _, _, _, _, PRnm, _), '$lgt_pp_rclause_'('$lgt_instantiates_class_'(Obj, Class, _)), % needed for parameter passing '$lgt_pp_instantiated_class_'(Class, _, _, _, _, _, CIDef, _, _, _), Lookup =.. [CIDef, Pred, Sender, Class, Self, Call, Ctn], ( '$lgt_pp_alias_'(Class, _, _) -> Head =.. [ODef, Alias, Sender, Obj, Self, Call, Ctn], Rename =.. [PRnm, Class, Pred, Alias], assertz('$lgt_pp_fdef_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup))) ; Head =.. [ODef, Pred, Sender, Obj, Self, Call, Ctn], assertz('$lgt_pp_fdef_'((Head:-Lookup))) ), fail. '$lgt_gen_ic_hierarchy_def_clauses'. '$lgt_gen_ic_idef_clauses'(Local) :- '$lgt_gen_ic_linking_idef_clauses'(Local), '$lgt_gen_ic_category_idef_clauses', '$lgt_gen_ic_hierarchy_idef_clauses'. '$lgt_gen_ic_linking_idef_clauses'(Local) :- '$lgt_pp_object_'(Obj, _, _, Def, _, _, IDef, _, DDef, _, _), Head =.. [IDef, Pred, Sender, This, Self, Call, Obj], ( call(Local) -> Body =.. [Def, Pred, Sender, This, Self, Call], assertz('$lgt_pp_fdef_'((Head:-Body))) ; true ), Body2 =.. [DDef, Pred, Sender, This, Self, Call], assertz('$lgt_pp_fdef_'((Head:-Body2))). '$lgt_gen_ic_category_idef_clauses' :- '$lgt_pp_object_'(Obj, _, _, _, _, _, OIDef, _, _, PRnm, _), '$lgt_pp_rclause_'('$lgt_imports_category_'(Obj, Ctg, _)), % needed for parameter passing '$lgt_pp_imported_category_'(Ctg, _, _, CDef, _), Lookup =.. [CDef, Pred, Sender, Obj, Self, Call], ( '$lgt_pp_alias_'(Ctg, _, _) -> Head =.. [OIDef, Alias, Sender, Obj, Self, Call, Ctg], Rename =.. [PRnm, Ctg, Pred, Alias], assertz('$lgt_pp_fdef_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup))) ; Head =.. [OIDef, Pred, Sender, Obj, Self, Call, Ctg], assertz('$lgt_pp_fdef_'((Head:-Lookup))) ), fail. '$lgt_gen_ic_category_idef_clauses'. '$lgt_gen_ic_hierarchy_idef_clauses' :- '$lgt_pp_object_'(Class, _, _, _, _, _, CIDef, _, _, PRnm, _), '$lgt_pp_rclause_'('$lgt_specializes_class_'(Class, Super, _)), % needed for parameter passing '$lgt_pp_specialized_class_'(Super, _, _, _, _, _, SIDef, _, _, _), Lookup =.. [SIDef, Pred, Sender, Super, Self, Call, Ctn], ( '$lgt_pp_alias_'(Super, _, _) -> Head =.. [CIDef, Alias, Sender, Class, Self, Call, Ctn], Rename =.. [PRnm, Super, Pred, Alias], assertz('$lgt_pp_fdef_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup))) ; Head =.. [CIDef, Pred, Sender, Class, Self, Call, Ctn], assertz('$lgt_pp_fdef_'((Head:-Lookup))) ), fail. '$lgt_gen_ic_hierarchy_idef_clauses'. % we can have a root object where super have nowhere to go ... '$lgt_gen_ic_super_clauses' :- '$lgt_pp_object_'(_, _, _, _, OSuper, _, _, _, _, _, _), \+ '$lgt_pp_instantiated_class_'(_, _, _, _, _, _, _, _, _, _), \+ '$lgt_pp_specialized_class_'(_, _, _, _, _, _, _, _, _, _), Head =.. [OSuper, _, _, _, _, _, _], assertz('$lgt_pp_super_'((Head:-fail))), !. % ... or predicates can be redefined in instances... '$lgt_gen_ic_super_clauses' :- '$lgt_pp_object_'(Obj, _, _, _, OSuper, _, _, _, _, PRnm, _), '$lgt_pp_rclause_'('$lgt_instantiates_class_'(Obj, Class, _)), % needed for parameter passing '$lgt_pp_instantiated_class_'(Class, _, _, _, _, _, CIDef, _, _, _), Lookup =.. [CIDef, Pred, Sender, Class, Obj, Call, Ctn], ( '$lgt_pp_alias_'(Class, _, _) -> Head =.. [OSuper, Alias, Sender, Obj, Obj, Call, Ctn], Rename =.. [PRnm, Class, Pred, Alias], assertz('$lgt_pp_super_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup))) ; Head =.. [OSuper, Pred, Sender, Obj, Obj, Call, Ctn], assertz('$lgt_pp_super_'((Head:-Lookup))) ), fail. % ... or/and in subclasses... '$lgt_gen_ic_super_clauses' :- '$lgt_pp_object_'(Class, _, _, _, CSuper, _, _, _, _, PRnm, _), '$lgt_pp_rclause_'('$lgt_specializes_class_'(Class, Super, _)), % needed for parameter passing '$lgt_pp_specialized_class_'(Super, _, _, _, _, _, SIDef, _, _, _), Lookup =.. [SIDef, Pred, Sender, Super, Self, Call, Ctn], ( '$lgt_pp_alias_'(Super, _, _) -> Head =.. [CSuper, Alias, Sender, Class, Self, Call, Ctn], Rename =.. [PRnm, Super, Pred, Alias], assertz('$lgt_pp_super_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup))) ; Head =.. [CSuper, Pred, Sender, Class, Self, Call, Ctn], assertz('$lgt_pp_super_'((Head:-Lookup))) ), fail. '$lgt_gen_ic_super_clauses'. % '$lgt_fix_synchronized_preds' % % add mutex wrappers for calling synchronized predicates; % for Prolog compilers that do not support multi-threading, % synchronized predicates are compiled as normal predicates '$lgt_fix_synchronized_preds' :- \+ '$lgt_default_flag'(threads, on), !. '$lgt_fix_synchronized_preds' :- ( '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _) -> '$lgt_fix_synchronized_pred_defs', '$lgt_fix_synchronized_pred_ddefs' ; '$lgt_pp_category_'(_, _, _, _, _, _) -> '$lgt_fix_synchronized_pred_defs' ; true ). '$lgt_fix_synchronized_pred_defs' :- retract('$lgt_pp_def_'(Old)), Old =.. [Def, Head, Sender, This, Self, THead], ( '$lgt_pp_synchronized_'(Head, Mutex) -> THead =.. [TFunctor| Args], atom_concat(TFunctor, '_sync', MFunctor), MHead =.. [MFunctor| Args], New =.. [Def, Head, Sender, This, Self, MHead], assertz('$lgt_pp_fdef_'(New)), ( functor(Head, Functor, Arity), functor(Mode, Functor, Arity), '$lgt_pp_mode_'(Mode, _), forall('$lgt_pp_mode_'(Mode, Solutions), (Solutions \== zero_or_one, Solutions \== one, Solutions \== zero)) -> assertz('$lgt_pp_feclause_'((MHead:-mutex_lock(Mutex), call_cleanup(THead, mutex_unlock(Mutex))))) ; assertz('$lgt_pp_feclause_'((MHead:-with_mutex(Mutex, THead)))) ) ; assertz('$lgt_pp_fdef_'(Old)) ), fail. '$lgt_fix_synchronized_pred_defs'. '$lgt_fix_synchronized_pred_ddefs' :- retract('$lgt_pp_ddef_'(Old)), Old =.. [DDef, Head, Sender, This, Self, THead], ( '$lgt_pp_synchronized_'(Head, Mutex) -> THead =.. [TFunctor| Args], atom_concat(TFunctor, '_sync', MFunctor), MHead =.. [MFunctor| Args], New =.. [DDef, Head, Sender, This, Self, MHead], assertz('$lgt_pp_fddef_'(New)), ( functor(Head, Functor, Arity), functor(Mode, Functor, Arity), '$lgt_pp_mode_'(Mode, _), forall('$lgt_pp_mode_'(Mode, Solutions), (Solutions \== zero_or_one, Solutions \== one, Solutions \== zero)) -> assertz('$lgt_pp_feclause_'((MHead:-mutex_lock(Mutex), call_cleanup(THead, mutex_unlock(Mutex))))) ; assertz('$lgt_pp_feclause_'((MHead:-with_mutex(Mutex, THead)))) ) ; assertz('$lgt_pp_fddef_'(Old)) ), fail. '$lgt_fix_synchronized_pred_ddefs'. % '$lgt_fix_pred_calls' % % fix predicate calls in entity clauses and initialization goals '$lgt_fix_pred_calls' :- retract('$lgt_pp_eclause_'(Clause)), ( Clause = (Head:-Body) -> '$lgt_fix_pred_calls'(Body, FBody), assertz('$lgt_pp_feclause_'((Head:-FBody))) ; assertz('$lgt_pp_feclause_'(Clause)) ), fail. '$lgt_fix_pred_calls' :- retract('$lgt_pp_entity_init_'(Call)), '$lgt_fix_pred_calls'(Call, Fixed), assertz('$lgt_pp_fentity_init_'(Fixed)), fail. '$lgt_fix_pred_calls'. % '$lgt_fix_pred_calls'(+body, -body) % % fix predicate calls in a clause body '$lgt_fix_pred_calls'(Pred, Pred) :- var(Pred), !. '$lgt_fix_pred_calls'((Pred1, Pred2), (TPred1, TPred2)) :- !, '$lgt_fix_pred_calls'(Pred1, TPred1), '$lgt_fix_pred_calls'(Pred2, TPred2). '$lgt_fix_pred_calls'((Pred1; Pred2), (TPred1; TPred2)) :- !, '$lgt_fix_pred_calls'(Pred1, TPred1), '$lgt_fix_pred_calls'(Pred2, TPred2). '$lgt_fix_pred_calls'((Pred1 -> Pred2), (TPred1 -> TPred2)) :- !, '$lgt_fix_pred_calls'(Pred1, TPred1), '$lgt_fix_pred_calls'(Pred2, TPred2). '$lgt_fix_pred_calls'(\+ Pred, \+ TPred) :- !, '$lgt_fix_pred_calls'(Pred, TPred). '$lgt_fix_pred_calls'(call(Pred), call(TPred)) :- !, '$lgt_fix_pred_calls'(Pred, TPred). '$lgt_fix_pred_calls'(once(Pred), once(TPred)) :- !, '$lgt_fix_pred_calls'(Pred, TPred). '$lgt_fix_pred_calls'(catch(Goal, Catcher, Recovery), catch(TGoal, Catcher, TRecovery)) :- !, '$lgt_fix_pred_calls'(Goal, TGoal), '$lgt_fix_pred_calls'(Recovery, TRecovery). '$lgt_fix_pred_calls'(bagof(Term, Pred, List), bagof(Term, TPred, List)) :- !, '$lgt_fix_pred_calls'(Pred, TPred). '$lgt_fix_pred_calls'(findall(Term, Pred, List), findall(Term, TPred, List)) :- !, '$lgt_fix_pred_calls'(Pred, TPred). '$lgt_fix_pred_calls'(forall(Gen, Test), forall(TGen, TTest)) :- !, '$lgt_fix_pred_calls'(Gen, TGen), '$lgt_fix_pred_calls'(Test, TTest). '$lgt_fix_pred_calls'(setof(Term, Pred, List), setof(Term, TPred, List)) :- !, '$lgt_fix_pred_calls'(Pred, TPred). '$lgt_fix_pred_calls'('$lgt_dbg_goal'(OPred, Pred, DbgCtx), '$lgt_dbg_goal'(OPred, TPred, DbgCtx)) :- !, '$lgt_fix_pred_calls'(Pred, TPred). '$lgt_fix_pred_calls'(Pred, fail) :- % calls to static, declared but undefined predicates; functor(Pred, Functor, Arity), % must fail instead of throwing an exception '$lgt_undef_pred_call'(_, Functor/Arity), !. '$lgt_fix_pred_calls'(Pred, TPred) :- % calls to non-standard Prolog built-in meta-predicates '$lgt_pl_built_in'(Pred), functor(Pred, Functor, Arity), functor(Meta, Functor, Arity), '$lgt_pl_meta_predicate'(Meta), !, Pred =.. [_| Args], Meta =.. [_| MArgs], '$lgt_fix_pred_calls_in_margs'(Args, MArgs, TArgs), TPred =.. [Functor| TArgs]. '$lgt_fix_pred_calls'('$lgt_call_built_in'(Pred, Ctx), TPred) :- !, % calls to redefined Prolog built-in meta-predicates '$lgt_ctx_ctx'(Ctx, _, Sender, This, Self, _, _, _), ( '$lgt_pp_redefined_built_in_'(Pred, Sender, This, Self, TPred) -> true ; '$lgt_fix_pred_calls'(Pred, TPred) ). '$lgt_fix_pred_calls'(Pred, Pred). % '$lgt_fix_pred_calls_in_margs'(@list, @list, -list) % % fix predicate calls in non-standard meta-predicate arguments '$lgt_fix_pred_calls_in_margs'([], [], []). '$lgt_fix_pred_calls_in_margs'([Arg| Args], [MArg| MArgs], [TArg| TArgs]) :- '$lgt_fix_pred_calls_ins_in_marg'(MArg, Arg, TArg), '$lgt_fix_pred_calls_in_margs'(Args, MArgs, TArgs). '$lgt_fix_pred_calls_ins_in_marg'(*, Arg, Arg). '$lgt_fix_pred_calls_ins_in_marg'(::, Arg, TArg) :- '$lgt_fix_pred_calls'(Arg, TArg). % report calls to declared, static but undefined predicates in the body of object and category predicates '$lgt_report_undef_pred_calls' :- '$lgt_compiler_flag'(misspelt, error), '$lgt_undef_pred_call'(Pred), throw(existence_error(procedure, Pred)). '$lgt_report_undef_pred_calls' :- '$lgt_compiler_flag'(misspelt, warning), setof(Pred, '$lgt_undef_pred_call'(Pred), Preds), '$lgt_inc_compile_warnings_counter', nl, ( Preds = [_] -> write(' WARNING! This declared static predicate is called but never defined: ') ; write(' WARNING! These declared static predicates are called but never defined: ') ), '$lgt_writeq_list'(Preds), !. '$lgt_report_undef_pred_calls'. '$lgt_undef_pred_call'(Pred) :- '$lgt_undef_pred_call'(Pred, _). '$lgt_undef_pred_call'(Functor/Arity, TFunctor/TArity) :- '$lgt_pp_calls_pred_'(Functor, Arity, TFunctor, TArity), \+ '$lgt_pp_defs_pred_'(Functor, Arity), % predicate not defined in object/category and \+ '$lgt_pp_dynamic_'(Functor, Arity), % predicate not declared dynamic in in object/category Arity2 is Arity - 2, % (only return predicates that are not the expansion \+ '$lgt_pp_calls_nt_'(Functor, Arity2), % of grammar rules; see second clause) once(( '$lgt_pp_public_'(Functor, Arity) % but there is a scope directive for the predicate ; '$lgt_pp_protected_'(Functor, Arity) ; '$lgt_pp_private_'(Functor, Arity) )). '$lgt_undef_pred_call'(Functor//Arity, _) :- '$lgt_pp_calls_nt_'(Functor, Arity), \+ '$lgt_pp_defs_nt_'(Functor, Arity), % non-terminal not defined in object/category and Arity2 is Arity + 2, \+ '$lgt_pp_defs_pred_'(Functor, Arity2), % no corresponding predicate is defined \+ '$lgt_pp_dynamic_'(Functor, Arity2), % no dynamic directive for the corresponding predicate once(( '$lgt_pp_public_'(Functor, Arity2) % but there is a scope directive for the non-terminal ; '$lgt_pp_protected_'(Functor, Arity2) % or the corresponding predicate ; '$lgt_pp_private_'(Functor, Arity2) )). % report possible misspelt predicate calls in the body of object and category predicates '$lgt_report_misspelt_calls' :- '$lgt_compiler_flag'(misspelt, error), '$lgt_misspelt_call'(Pred), throw(existence_error(predicate, Pred)). '$lgt_report_misspelt_calls' :- '$lgt_compiler_flag'(misspelt, warning), setof(Pred, '$lgt_misspelt_call'(Pred), Preds), '$lgt_inc_compile_warnings_counter', nl, ( Preds = [_] -> write(' WARNING! This predicate is called but never defined: ') ; write(' WARNING! These predicates are called but never defined: ') ), '$lgt_writeq_list'(Preds). '$lgt_report_misspelt_calls'. '$lgt_misspelt_call'(Functor/Arity) :- '$lgt_pp_calls_pred_'(Functor, Arity, _, _), \+ '$lgt_pp_defs_pred_'(Functor, Arity), \+ '$lgt_pp_dynamic_'(Functor, Arity), \+ '$lgt_pp_public_'(Functor, Arity), \+ '$lgt_pp_protected_'(Functor, Arity), \+ '$lgt_pp_private_'(Functor, Arity), Arity2 is Arity - 2, \+ '$lgt_pp_calls_nt_'(Functor, Arity2). '$lgt_misspelt_call'(Functor//Arity) :- '$lgt_pp_calls_nt_'(Functor, Arity), \+ '$lgt_pp_defs_nt_'(Functor, Arity), Arity2 is Arity + 2, \+ '$lgt_pp_defs_pred_'(Functor, Arity2), \+ '$lgt_pp_dynamic_'(Functor, Arity2), \+ '$lgt_pp_public_'(Functor, Arity2), \+ '$lgt_pp_protected_'(Functor, Arity2), \+ '$lgt_pp_private_'(Functor, Arity2). % report non-portable predicate calls in the body of object and category predicates '$lgt_report_non_portable_calls' :- '$lgt_compiler_flag'(portability, warning), setof(Pred, '$lgt_non_portable_call'(Pred), Preds), '$lgt_inc_compile_warnings_counter', nl, ( Preds = [_] -> write(' WARNING! Call to non-standard Prolog built-in predicate: ') ; write(' WARNING! Calls to non-standard Prolog built-in predicates: ') ), '$lgt_writeq_list'(Preds), !. '$lgt_report_non_portable_calls'. '$lgt_non_portable_call'(Functor/Arity) :- '$lgt_non_portable_call_'(Functor, Arity), \+ '$lgt_pp_defs_pred_'(Functor, Arity), functor(Pred, Functor, Arity), \+ '$lgt_pp_redefined_built_in_'(Pred, _, _, _, _). % '$lgt_pp_entity_functors'(-compound) % % constructs the entity functors clause '$lgt_pp_entity_functors'(Clause) :- ( '$lgt_pp_object_'(_, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Rnm, _) -> Clause =.. [Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Rnm] ; '$lgt_pp_category_'(_, Prefix, Dcl, Def, Rnm, _) -> Clause =.. [Prefix, Dcl, Def, Rnm] ; '$lgt_pp_protocol_'(_, Prefix, Dcl, Rnm, _) -> Clause =.. [Prefix, Dcl, Rnm] ). % '$lgt_write_directives'(@stream) % % writes the directives; cumbersome due to the special processing of the encoding/1 directive '$lgt_write_directives'(Stream) :- '$lgt_pp_directive_'(Dir), ( Dir = encoding(_), '$lgt_compiler_flag'(encoding_directive, source) -> true ; write_canonical(Stream, (:- Dir)), write(Stream, '.'), nl(Stream) ), fail. '$lgt_write_directives'(_). % '$lgt_write_prolog_clauses'(@stream) % % writes any Prolog clauses that appear before an entity opening directive '$lgt_write_prolog_clauses'(Stream) :- '$lgt_pp_ppclause_'(Clause), write_canonical(Stream, Clause), write(Stream, '.'), nl(Stream), fail. '$lgt_write_prolog_clauses'(_). % '$lgt_write_logtalk_clauses'(@stream) % % writes Logtalk entity clauses '$lgt_write_logtalk_clauses'(Stream) :- '$lgt_write_functors_clause'(Stream), '$lgt_write_dcl_clauses'(Stream), '$lgt_write_def_clauses'(Stream), '$lgt_write_ddef_clauses'(Stream), '$lgt_write_super_clauses'(Stream), '$lgt_write_alias_clauses'(Stream), '$lgt_write_pred_clauses'(Stream). '$lgt_write_functors_clause'(Stream) :- '$lgt_pp_entity_functors'(Clause), write_canonical(Stream, Clause), write(Stream, '.'), nl(Stream). '$lgt_write_dcl_clauses'(Stream) :- '$lgt_pp_dcl_'(Clause), write_canonical(Stream, Clause), write(Stream, '.'), nl(Stream), fail. '$lgt_write_dcl_clauses'(_). '$lgt_write_def_clauses'(Stream) :- '$lgt_pp_fdef_'(Clause), write_canonical(Stream, Clause), write(Stream, '.'), nl(Stream), fail. '$lgt_write_def_clauses'(_). '$lgt_write_ddef_clauses'(Stream) :- '$lgt_pp_fddef_'(Clause), write_canonical(Stream, Clause), write(Stream, '.'), nl(Stream), fail. '$lgt_write_ddef_clauses'(_). '$lgt_write_super_clauses'(Stream) :- '$lgt_pp_super_'(Clause), write_canonical(Stream, Clause), write(Stream, '.'), nl(Stream), fail. '$lgt_write_super_clauses'(_). '$lgt_write_alias_clauses'(Stream) :- ( '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, Rnm, _) ; '$lgt_pp_category_'(_, _, _, _, Rnm, _) ; '$lgt_pp_protocol_'(_, _, _, Rnm, _) ), !, '$lgt_write_alias_clauses'(Stream, Rnm). '$lgt_write_alias_clauses'(Stream, Rnm) :- '$lgt_pp_alias_'(Entity, Pred, Alias), Clause =.. [Rnm, Entity, Pred, Alias], write_canonical(Stream, Clause), write(Stream, '.'), nl(Stream), fail. '$lgt_write_alias_clauses'(Stream, Rnm) :- Catchall =.. [Rnm, _, Pred, Pred], write_canonical(Stream, Catchall), write(Stream, '.'), nl(Stream). '$lgt_write_pred_clauses'(Stream) :- '$lgt_pp_feclause_'(Clause), write_canonical(Stream, Clause), write(Stream, '.'), nl(Stream), fail. '$lgt_write_pred_clauses'(_). % '$lgt_write_init_call'(@stream) % % writes the initialization call for the compiled source file that will assert % the relation clauses for all defined entities and call any declared entity % initialization goals when the source file is loaded '$lgt_write_init_call'(Stream) :- '$lgt_init_goal'(Goal), ( Goal == true -> true ; write_canonical(Stream, (:- initialization(Goal))), write(Stream, '.'), nl(Stream) ). % '$lgt_init_goal'(-callable) % % source file initialization goal constructed from each entity initialization % goals and from the source file initialization/1 directive if present '$lgt_init_goal'(Goal) :- findall(EGoal, '$lgt_pp_entity_init_'(_, _, EGoal), EGoals), ( '$lgt_pp_file_init_'(FGoal) -> ( EGoals \== [] -> '$lgt_list_to_conjunction'(EGoals, EGoals2), Goal = (EGoals2, FGoal) ; Goal = FGoal ) ; ( EGoals \== [] -> '$lgt_list_to_conjunction'(EGoals, Goal) ; Goal = true ) ). % converts a list of goals into a conjunction of goals '$lgt_list_to_conjunction'([G], G) :- !. '$lgt_list_to_conjunction'([G1, G2| Gs], (G1, R)) :- '$lgt_list_to_conjunction'([G2| Gs], R). % generates and asserts the initialization goal for the entity being compiled '$lgt_gen_entity_init_goal' :- '$lgt_pp_entity'(Type, Entity, Prefix, _, Compilation), findall(Clause, '$lgt_pp_rclause'(Clause), Clauses), Goal1 = '$lgt_assert_runtime_clauses'(Clauses), ( setof(Mutex, Head^'$lgt_pp_synchronized_'(Head, Mutex), Mutexes) -> Goal2 = (Goal1, '$lgt_create_mutexes'(Mutexes)) ; Goal2 = Goal1 ), ( '$lgt_pp_threaded_' -> Goal3 = (Goal2, '$lgt_init_object_message_queue'(Prefix)) ; Goal3 = Goal2 ), ( '$lgt_pp_fentity_init_'(Goal4) -> Goal5 = (Goal3, Goal4) ; Goal5 = Goal3 ), ( Type \== protocol, Compilation == static, '$lgt_compiler_flag'(reload, skip) -> Goal = (Goal5, '$lgt_add_static_binding_cache_entry'(Entity)) ; Goal = Goal5 ), assertz('$lgt_pp_entity_init_'(Type, Entity, Goal)). % '$lgt_assert_tr_entity' % % adds a dynamically created entity to memory '$lgt_assert_tr_entity' :- '$lgt_assert_directives', '$lgt_assert_functors_clause', '$lgt_assert_dcl_clauses', '$lgt_assert_def_clauses', '$lgt_assert_ddef_clauses', '$lgt_assert_super_clauses', '$lgt_assert_pred_clauses', '$lgt_assert_runtime_clauses', '$lgt_assert_init'. '$lgt_assert_directives' :- '$lgt_pp_directive_'(dynamic(Functor/Arity)), functor(Pred, Functor, Arity), asserta(Pred), retract(Pred), fail. '$lgt_assert_directives' :- '$lgt_pp_directive_'(op(Pr, Spec, Ops)), op(Pr, Spec, Ops), fail. '$lgt_assert_directives'. '$lgt_assert_functors_clause' :- '$lgt_pp_entity_functors'(Clause), assertz(Clause). '$lgt_assert_dcl_clauses' :- '$lgt_pp_dcl_'(Clause), assertz(Clause), fail. '$lgt_assert_dcl_clauses'. '$lgt_assert_def_clauses' :- '$lgt_pp_fdef_'(Clause), assertz(Clause), fail. '$lgt_assert_def_clauses'. '$lgt_assert_ddef_clauses' :- '$lgt_pp_fddef_'(Clause), assertz(Clause), fail. '$lgt_assert_ddef_clauses'. '$lgt_assert_super_clauses' :- '$lgt_pp_super_'(Clause), assertz(Clause), fail. '$lgt_assert_super_clauses'. '$lgt_assert_pred_clauses' :- '$lgt_pp_feclause_'(Clause), assertz(Clause), fail. '$lgt_assert_pred_clauses'. '$lgt_assert_runtime_clauses' :- '$lgt_pp_rclause'(Clause), assertz(Clause), fail. '$lgt_assert_runtime_clauses'. % '$lgt_assert_init' % % call any defined initialization goal for a dynamically created entity '$lgt_assert_init' :- ( '$lgt_pp_object_'(_, Prefix, _, _, _, _, _, _, _, _, _), '$lgt_pp_threaded_' -> '$lgt_init_object_message_queue'(Prefix) ; true ), ( '$lgt_pp_fentity_init_'(Goal) -> once(Goal) ; true ). % '$lgt_assert_runtime_clauses'(+list) % % called when loading a compiled Logtalk entity in order to update % Logtalk internal runtime tables % % we may be reloading the entity so we must first retract any old % runtime clauses before asserting the new ones % % this is mostly a workaround for the lack of support of multifile % predicates in some Prolog compilers '$lgt_assert_runtime_clauses'([Clause| Clauses]) :- arg(1, Clause, Entity), ( '$lgt_redefined_entity'(Entity, Type) -> '$lgt_clean_lookup_caches', '$lgt_report_redefined_entity'(Type, Entity) ; true ), '$lgt_retract_old_runtime_clauses'(Entity), '$lgt_assert_new_runtime_clauses'([Clause| Clauses]). '$lgt_retract_old_runtime_clauses'(Entity) :- retractall('$lgt_current_object_'(Entity, _, _, _, _, _, _, _)), retractall('$lgt_current_protocol_'(Entity, _, _)), retractall('$lgt_current_category_'(Entity, _, _, _)), retractall('$lgt_implements_protocol_'(Entity, _, _)), retractall('$lgt_imports_category_'(Entity, _, _)), retractall('$lgt_instantiates_class_'(Entity, _, _)), retractall('$lgt_specializes_class_'(Entity, _, _)), retractall('$lgt_extends_protocol_'(Entity, _, _)), retractall('$lgt_extends_object_'(Entity, _, _)), retractall('$lgt_debugging_'(Entity)). '$lgt_assert_new_runtime_clauses'([]). '$lgt_assert_new_runtime_clauses'([Clause| Clauses]) :- assertz(Clause), '$lgt_assert_new_runtime_clauses'(Clauses). % '$lgt_construct_object_functors'(+object_identifier, -atom, -atom, -atom, -atom, -atom, -atom, -atom, -atom, -atom) % % constructs functors used in the compiled code of an object; % built-in objects use a fixed set of functors that do not depend on the code_prefix/1 compiler flag '$lgt_construct_object_functors'(Obj, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Rnm) :- ( '$lgt_built_in_object'(Obj) -> '$lgt_current_object_'(Obj, Prefix, _, _, _, _, _, _), Call =.. [Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Rnm], once(Call) ; '$lgt_construct_entity_prefix'(Obj, Prefix), atom_concat(Prefix, '_dcl', Dcl), atom_concat(Prefix, '_def', Def), atom_concat(Prefix, '_super', Super), atom_concat(Prefix, '_idcl', IDcl), atom_concat(Prefix, '_idef', IDef), atom_concat(Prefix, '_ddcl', DDcl), atom_concat(Prefix, '_ddef', DDef), atom_concat(Prefix, '_alias', Rnm) ). % '$lgt_construct_protocol_functors'(+protocol_identifier, -atom, -atom, -atom) % % constructs functors used in the compiled code of a protocol; % built-in protocols use a fixed set of functors that do not depend on the code_prefix/1 compiler flag '$lgt_construct_protocol_functors'(Ptc, Prefix, Dcl, Rnm) :- ( '$lgt_built_in_protocol'(Ptc) -> '$lgt_current_protocol_'(Ptc, Prefix, _), Call =.. [Prefix, Dcl, Rnm], once(Call) ; '$lgt_construct_entity_prefix'(Ptc, Prefix), atom_concat(Prefix, '_dcl', Dcl), atom_concat(Prefix, '_alias', Rnm) ). % '$lgt_construct_category_functors'(+category_identifier, -atom, -atom, -atom, -atom) % % constructs functors used in the compiled code of a category; % built-in categories use a fixed set of functors that do not depend on the code_prefix/1 compiler flag '$lgt_construct_category_functors'(Ctg, Prefix, Dcl, Def, Rnm) :- ( '$lgt_built_in_category'(Ctg) -> '$lgt_current_category_'(Ctg, Prefix, _, _), Call =.. [Prefix, Dcl, Def, Rnm], once(Call) ; '$lgt_construct_entity_prefix'(Ctg, Prefix), atom_concat(Prefix, '_dcl', Dcl), atom_concat(Prefix, '_def', Def), atom_concat(Prefix, '_alias', Rnm) ). % '$lgt_construct_entity_prefix'(@entity_identifier, -atom) % % constructs the entity prefix used in the compiled code '$lgt_construct_entity_prefix'(Entity, Prefix) :- '$lgt_compiler_flag'(code_prefix, CodePrefix), functor(Entity, Functor, Arity), atom_concat(CodePrefix, Functor, Aux1), number_codes(Arity, ArityCodes), atom_codes(ArityAtom, ArityCodes), atom_concat(Aux1, '_', Aux2), atom_concat(Aux2, ArityAtom, Aux3), atom_concat(Aux3, '_', Prefix). % '$lgt_construct_predicate_functor'(+atom, +atom, +integer, -atom) % % constructs the functor used for a compiled predicate '$lgt_construct_predicate_functor'(EntityPrefix, Functor, Arity, PredPrefix) :- atom_concat(EntityPrefix, Functor, Aux), atom_concat(Aux, '_', Aux2), number_codes(Arity, Codes), atom_codes(Atom, Codes), atom_concat(Aux2, Atom, PredPrefix). % '$lgt_reverse_predicate_functor'(+atom, +integer, -callable, -atom, -atom, -integer) % % reverses the functor used for a compiled predicate; not completly realiable '$lgt_reverse_predicate_functor'(TFunctor, TArity, Entity, Type, Functor, Arity) :- atom(TFunctor), integer(TArity), ( '$lgt_current_object_'(Entity, Prefix, _, _, _, _, _, _), Type = object ; '$lgt_current_category_'(Entity, Prefix, _, _), Type = category ), atom_concat(Prefix, PredPart, TFunctor), ( Arity is TArity - 3 % subtract message execution context arguments ; Arity is TArity - 4 % for meta-predicates, we use an additional argument ), Arity >= 0, number_codes(Arity, Codes), atom_codes(Atom, Codes), atom_concat('_', Atom, Aux), atom_concat(Functor, Aux, PredPart), !. % '$lgt_reverse_predicate_args'(+integer, @list, -list, -object_identifier, -object_identifier, -object_identifier) '$lgt_reverse_predicate_args'(0, TArgs, [], Sender, This, Self) :- !, '$lgt_append'(_, [Sender, This, Self], TArgs). '$lgt_reverse_predicate_args'(N, [Arg| TArgs], [Arg| Args], Sender, This, Self) :- N > 0, N2 is N - 1, '$lgt_reverse_predicate_args'(N2, TArgs, Args, Sender, This, Self). % '$lgt_compile_hook'(+callable) % % compiles the user-defined compiler hook '$lgt_compile_hook'(Obj::Functor) :- Call =.. [Functor, Term, Terms], ( Obj == user -> Goal = Call ; '$lgt_tr_msg'(Call, Obj, Goal, user) ), retractall('$lgt_hook_goal_'(_, _)), assertz(('$lgt_hook_goal_'(Term, Terms) :- catch(Goal, _, fail))). % '$lgt_built_in'(+callable) % % checks if the argument is either a Prolog or Logtalk built-in predicate '$lgt_built_in'(Pred) :- ( '$lgt_pl_built_in'(Pred) -> true ; '$lgt_lgt_built_in'(Pred) ). % '$lgt_pl_built_in'(+callable) % % either host Prolog native built-ins or missing ISO built-ins % that we have defined in the correspondent config file '$lgt_pl_built_in'(Pred) :- \+ '$lgt_lgt_built_in'(Pred), % Logtalk built-ins may also have the property built_in '$lgt_predicate_property'(Pred, built_in), !. '$lgt_pl_built_in'(Pred) :- '$lgt_iso_predicate'(Pred). % ISO Prolog built-in predicate % logtalk built-in methods % % '$lgt_built_in_method'(+callable, ?scope) '$lgt_built_in_method'(parameter(_, _), p). '$lgt_built_in_method'(self(_), p). '$lgt_built_in_method'(sender(_), p). '$lgt_built_in_method'(this(_), p). '$lgt_built_in_method'(current_predicate(_), p(p(p))). '$lgt_built_in_method'(predicate_property(_, _), p(p(p))). '$lgt_built_in_method'(abolish(_), p(p(p))). '$lgt_built_in_method'(asserta(_), p(p(p))). '$lgt_built_in_method'(assertz(_), p(p(p))). '$lgt_built_in_method'(clause(_, _), p(p(p))). '$lgt_built_in_method'(retract(_), p(p(p))). '$lgt_built_in_method'(retractall(_), p(p(p))). '$lgt_built_in_method'(bagof(_, _, _), p(p(p))). '$lgt_built_in_method'(findall(_, _, _), p(p(p))). '$lgt_built_in_method'(forall(_, _), p(p(p))). '$lgt_built_in_method'(setof(_, _, _), p(p(p))). '$lgt_built_in_method'(expand_term(_, _), p(p(p))). '$lgt_built_in_method'(phrase(_, _), p(p(p))). '$lgt_built_in_method'(phrase(_, _, _), p(p(p))). '$lgt_built_in_method'(Method, p(p(p))) :- compound(Method), functor(Method, call, Arity), Arity > 0. %'$lgt_lgt_directive'(+atom, +integer) % % valid Logtalk directives '$lgt_lgt_directive'(Functor, Arity) :- '$lgt_lgt_opening_directive'(Functor, Arity), !. '$lgt_lgt_directive'(Functor, Arity) :- '$lgt_lgt_closing_directive'(Functor, Arity), !. '$lgt_lgt_directive'(Functor, Arity) :- '$lgt_lgt_entity_directive'(Functor, Arity), !. '$lgt_lgt_directive'(Functor, Arity) :- '$lgt_lgt_predicate_directive'(Functor, Arity). '$lgt_lgt_opening_directive'(object, N) :- N >= 1, N =< 5. '$lgt_lgt_opening_directive'(category, N) :- N >= 1, N =< 3. '$lgt_lgt_opening_directive'(protocol, N) :- N >= 1, N =< 2. '$lgt_lgt_opening_directive'(module, N) :- % Prolog module directives; module/3 directives N >= 1, N =< 3. % are not supported but must be recognized as % entity opening directives '$lgt_lgt_closing_directive'(end_object, 0). '$lgt_lgt_closing_directive'(end_category, 0). '$lgt_lgt_closing_directive'(end_protocol, 0). '$lgt_lgt_entity_directive'(encoding, 1). '$lgt_lgt_entity_directive'(calls, N) :- N >= 1. '$lgt_lgt_entity_directive'(uses, N) :- N >= 1, N =< 2. '$lgt_lgt_entity_directive'(use_module, 2). % Prolog module directive '$lgt_lgt_entity_directive'((initialization), 1). '$lgt_lgt_entity_directive'((dynamic), 0). '$lgt_lgt_entity_directive'(op, 3). '$lgt_lgt_entity_directive'(info, 1). '$lgt_lgt_entity_directive'(synchronized, 0). '$lgt_lgt_entity_directive'(threaded, 0). '$lgt_lgt_predicate_directive'(synchronized, N) :- N >= 1. '$lgt_lgt_predicate_directive'((dynamic), N) :- N >= 1. '$lgt_lgt_predicate_directive'(metapredicate, N) :- % deprecated Logtalk directive N >= 1. '$lgt_lgt_predicate_directive'((meta_predicate), N) :- % Logtalk directive N >= 1. '$lgt_lgt_predicate_directive'((discontiguous), N) :- N >= 1. '$lgt_lgt_predicate_directive'((public), N) :- N >= 1. '$lgt_lgt_predicate_directive'(protected, N) :- N >= 1. '$lgt_lgt_predicate_directive'(private, N) :- N >= 1. '$lgt_lgt_predicate_directive'((export), N) :- % Prolog module directive N >= 1. '$lgt_lgt_predicate_directive'((mode), 2). '$lgt_lgt_predicate_directive'(info, 2). '$lgt_lgt_predicate_directive'(alias, 3). % built-in meta-predicates '$lgt_meta_predicate'(Meta) :- % Logtalk built-in meta-predicate '$lgt_lgt_meta_predicate'(Meta). '$lgt_meta_predicate'(Meta) :- % (non ISO Standard) Prolog meta-predicate '$lgt_pl_meta_predicate'(Meta). % specified in the config files % built-in Logtalk (and Prolog) meta-predicates '$lgt_lgt_meta_predicate'(catch(::, *, ::)). '$lgt_lgt_meta_predicate'(bagof(*, ::, *)). '$lgt_lgt_meta_predicate'(setof(*, ::, *)). '$lgt_lgt_meta_predicate'(findall(*, ::, *)). '$lgt_lgt_meta_predicate'(forall(::, ::)). '$lgt_lgt_meta_predicate'(call(::)). '$lgt_lgt_meta_predicate'(once(::)). '$lgt_lgt_meta_predicate'(\+ (::)). % utility predicates used during compilation of Logtalk entities to store % and access context information which is represented by a compound term '$lgt_ctx_ctx'(ctx(_, _, _, _, _, _, _)). '$lgt_ctx_ctx'(ctx(Head, Sender, This, Self, Prefix, MetaVars, MetaCallCtx), Head, Sender, This, Self, Prefix, MetaVars, MetaCallCtx). '$lgt_ctx_head'(ctx(Head, _, _, _, _, _, _), Head). '$lgt_ctx_sender'(ctx(_, Sender, _, _, _, _, _), Sender). '$lgt_ctx_this'(ctx(_, _, This, _, _, _, _), This). '$lgt_ctx_self'(ctx(_, _, _, Self, _, _, _), Self). '$lgt_ctx_prefix'(ctx(_, _, _, _, Prefix, _, _), Prefix). '$lgt_ctx_meta_vars'(ctx(_, _, _, _, _, MetaVars, _), MetaVars). '$lgt_ctx_meta_call_ctx'(ctx(_, _, _, _, _, _, MetaCallCtx), MetaCallCtx). % utility predicates used during debugging of Logtalk entities to store % and access context information which is represented by a compound term '$lgt_dbg_ctx'(ctx(Sender, This, Self), Sender, This, Self). % construct debug context '$lgt_ctx_dbg_ctx'(ctx(_, Sender, This, Self, _, _, _), ctx(Sender, This, Self)). % '$lgt_flatten_list'(+list, -list) % % flattens a list of terms '$lgt_flatten_list'([[A|B]], [A|B]) :- % list containing a single list !. '$lgt_flatten_list'([[]], []) :- % list containing a single empty list !. '$lgt_flatten_list'([(A, B)], [A|BB]) :- % list containing a single element, !, % which is a sequence: (A, B, ...) '$lgt_flatten_list'([B], BB). '$lgt_flatten_list'([A|B], [A|B]) :- % already flattened list !. '$lgt_flatten_list'([], []). % empty list % '$lgt_valid_pred_ind(+nonvar, -atom, -integer) % % valid predicate indicator '$lgt_valid_pred_ind'(Functor/Arity, Functor, Arity) :- atom(Functor), integer(Arity), Arity >= 0. % '$lgt_valid_gr_ind(+nonvar, -atom, -integer, -integer) % % valid grammar rule indicator; last argument is the arity % of the corresponding predicate '$lgt_valid_gr_ind'(Functor//Arity, Functor, Arity, Arity2) :- atom(Functor), integer(Arity), Arity >= 0, Arity2 is Arity + 2. % '$lgt_valid_pred_or_gr_ind(+nonvar, -atom, -integer) % % valid predicate indicator or grammar rule indicator '$lgt_valid_pred_or_gr_ind'(Functor/Arity, Functor, Arity) :- atom(Functor), integer(Arity), Arity >= 0. '$lgt_valid_pred_or_gr_ind'(Functor//Arity, Functor, Arity) :- atom(Functor), integer(Arity), Arity >= 0. % '$lgt_valid_ref_scope'(@nonvar, -atom) '$lgt_valid_ref_scope'(Ref, Scope) :- ( Ref = (Scope::_) -> '$lgt_scope'(Scope, _) ; Scope = (public) ). % '$lgt_valid_protocol_ref'(@nonvar, -atom) '$lgt_valid_protocol_ref'(Ref, Ptc) :- ( Ref = (_::Ptc) -> true ; Ptc = Ref ), atom(Ptc). % '$lgt_valid_object_ref'(@nonvar, -atom) '$lgt_valid_object_ref'(Ref, Obj) :- ( Ref = (_::Obj) -> true ; Obj = Ref ), callable(Obj). % '$lgt_valid_category_ref'(@nonvar, -atom) '$lgt_valid_category_ref'(Ref, Ctg) :- ( Ref = (_::Ctg) -> true ; Ctg = Ref ), atom(Ctg). % '$lgt_valid_op_priority'(@term) '$lgt_valid_op_priority'(Pr) :- integer(Pr), 0 =< Pr, Pr =< 1200. % '$lgt_valid_op_specifier'(@term) '$lgt_valid_op_specifier'(Spec) :- atom(Spec), '$lgt_op_specifier'(Spec). % '$lgt_op_specifier'(+atom) '$lgt_op_specifier'(fx). '$lgt_op_specifier'(fy). '$lgt_op_specifier'(xfx). '$lgt_op_specifier'(xfy). '$lgt_op_specifier'(yfx). '$lgt_op_specifier'(xf). '$lgt_op_specifier'(yf). % '$lgt_valid_op_names'(@term) % % (an atom or a list of atoms) '$lgt_valid_op_names'(Op) :- atom(Op), !. '$lgt_valid_op_names'(Ops) :- '$lgt_valid_op_names_list'(Ops). '$lgt_valid_op_names_list'([]). '$lgt_valid_op_names_list'([Op| Ops]) :- atom(Op), '$lgt_valid_op_names_list'(Ops). % '$lgt_same_op_class'(?atom, ?atom) '$lgt_same_op_class'(fx, fx). '$lgt_same_op_class'(fx, fy). '$lgt_same_op_class'(fy, fx). '$lgt_same_op_class'(fy, fy). '$lgt_same_op_class'(xf, xf). '$lgt_same_op_class'(xf, yf). '$lgt_same_op_class'(yf, xf). '$lgt_same_op_class'(yf, yf). '$lgt_same_op_class'(xfx, xfx). '$lgt_same_op_class'(xfx, xfy). '$lgt_same_op_class'(xfx, yfx). '$lgt_same_op_class'(xfy, xfx). '$lgt_same_op_class'(xfy, xfy). '$lgt_same_op_class'(xfy, yfx). '$lgt_same_op_class'(yfx, xfx). '$lgt_same_op_class'(yfx, xfy). '$lgt_same_op_class'(yfx, yfx). % '$lgt_valid_metapred_term'(+nonvar) '$lgt_valid_metapred_term'(Pred) :- Pred =.. [_| Args], '$lgt_valid_metapred_term_args'(Args). '$lgt_valid_metapred_term_args'([]). '$lgt_valid_metapred_term_args'([Arg| Args]) :- once((Arg == (::); Arg == (*); integer(Arg), Arg > 0)), '$lgt_valid_metapred_term_args'(Args). % '$lgt_valid_mode_term'(+nonvar) '$lgt_valid_mode_term'(Pred) :- Pred =.. [_| Args], '$lgt_valid_mode_term_args'(Args). '$lgt_valid_mode_term_args'([]). '$lgt_valid_mode_term_args'([Arg| Args]) :- nonvar(Arg), functor(Arg, Functor, Arity), Arity =< 1, '$lgt_pred_arg_instantiation_mode'(Functor), '$lgt_valid_mode_term_args'(Args). % '$lgt_pred_arg_instantiation_mode'(@nonvar) '$lgt_pred_arg_instantiation_mode'(?). '$lgt_pred_arg_instantiation_mode'(+). '$lgt_pred_arg_instantiation_mode'(-). '$lgt_pred_arg_instantiation_mode'(@). % '$lgt_valid_number_of_solutions'(@term) '$lgt_valid_number_of_solutions'(Solutions) :- atom(Solutions), '$lgt_pred_number_of_solutions'(Solutions). % '$lgt_pred_number_of_solutions'(+atom) '$lgt_pred_number_of_solutions'(zero). '$lgt_pred_number_of_solutions'(one). '$lgt_pred_number_of_solutions'(zero_or_one). '$lgt_pred_number_of_solutions'(zero_or_more). '$lgt_pred_number_of_solutions'(one_or_more). '$lgt_pred_number_of_solutions'(error). % '$lgt_valid_pred_property'(@nonvar) '$lgt_valid_pred_property'((public)). '$lgt_valid_pred_property'(protected). '$lgt_valid_pred_property'(private). '$lgt_valid_pred_property'(static). '$lgt_valid_pred_property'((dynamic)). '$lgt_valid_pred_property'(declared_in(_)). '$lgt_valid_pred_property'(defined_in(_)). '$lgt_valid_pred_property'(meta_predicate(_)). '$lgt_valid_pred_property'(built_in). '$lgt_valid_pred_property'(alias(_)). '$lgt_valid_pred_property'(non_terminal(_)). '$lgt_valid_pred_property'(synchronized). % '$lgt_valid_object_property'(@nonvar) '$lgt_valid_object_property'(built_in). '$lgt_valid_object_property'((dynamic)). '$lgt_valid_object_property'(static). '$lgt_valid_object_property'(synchronized). '$lgt_valid_object_property'(threaded). % '$lgt_valid_protocol_property'(@nonvar) '$lgt_valid_protocol_property'(built_in). '$lgt_valid_protocol_property'((dynamic)). '$lgt_valid_protocol_property'(static). % '$lgt_valid_category_property'(@nonvar) '$lgt_valid_category_property'(built_in). '$lgt_valid_category_property'((dynamic)). '$lgt_valid_category_property'(static). '$lgt_valid_category_property'(synchronized). % '$lgt_valid_flag'(@nonvar) % % true if the argument is a valid Logtalk flag name '$lgt_valid_flag'(xmldocs). '$lgt_valid_flag'(xslfile). '$lgt_valid_flag'(xmlspec). '$lgt_valid_flag'(xmlsref). '$lgt_valid_flag'(unknown). '$lgt_valid_flag'(singletons). '$lgt_valid_flag'(misspelt). '$lgt_valid_flag'(lgtredef). '$lgt_valid_flag'(plredef). '$lgt_valid_flag'(portability). '$lgt_valid_flag'(report). '$lgt_valid_flag'(smart_compilation). '$lgt_valid_flag'(reload). '$lgt_valid_flag'(startup_message). '$lgt_valid_flag'(version). '$lgt_valid_flag'(underscore_variables). '$lgt_valid_flag'(code_prefix). '$lgt_valid_flag'(debug). '$lgt_valid_flag'(break_predicate). '$lgt_valid_flag'(events). '$lgt_valid_flag'(altdirs). '$lgt_valid_flag'(tmpdir). '$lgt_valid_flag'(xmldir). '$lgt_valid_flag'(hook). '$lgt_valid_flag'(encoding_directive). '$lgt_valid_flag'(threads). % '$lgt_read_only_flag'(@nonvar) % % true if the argument is a read only Logtalk flag name '$lgt_read_only_flag'(startup_message). '$lgt_read_only_flag'(break_predicate). '$lgt_read_only_flag'(version). '$lgt_read_only_flag'(altdirs). '$lgt_read_only_flag'(encoding_directive). '$lgt_read_only_flag'(threads). '$lgt_read_only_flag'(context_switching_calls). % '$lgt_valid_flag_value'(@atom, @nonvar) '$lgt_valid_flag_value'(xmldocs, on) :- !. '$lgt_valid_flag_value'(xmldocs, off) :- !. '$lgt_valid_flag_value'(xslfile, File) :- atom(File). '$lgt_valid_flag_value'(xmlsref, standalone) :- !. '$lgt_valid_flag_value'(xmlsref, (local)) :- !. '$lgt_valid_flag_value'(xmlsref, web) :- !. '$lgt_valid_flag_value'(xmlspec, dtd) :- !. '$lgt_valid_flag_value'(xmlspec, xsd) :- !. '$lgt_valid_flag_value'(unknown, silent) :- !. '$lgt_valid_flag_value'(unknown, warning) :- !. '$lgt_valid_flag_value'(singletons, silent) :- !. '$lgt_valid_flag_value'(singletons, warning) :- !. '$lgt_valid_flag_value'(misspelt, silent) :- !. '$lgt_valid_flag_value'(misspelt, warning) :- !. '$lgt_valid_flag_value'(misspelt, error) :- !. '$lgt_valid_flag_value'(lgtredef, silent) :- !. '$lgt_valid_flag_value'(lgtredef, warning) :- !. '$lgt_valid_flag_value'(plredef, silent) :- !. '$lgt_valid_flag_value'(plredef, warning) :- !. '$lgt_valid_flag_value'(portability, silent) :- !. '$lgt_valid_flag_value'(portability, warning) :- !. '$lgt_valid_flag_value'(report, on) :- !. '$lgt_valid_flag_value'(report, off) :- !. '$lgt_valid_flag_value'(smart_compilation, on) :- !. '$lgt_valid_flag_value'(smart_compilation, off) :- !. '$lgt_valid_flag_value'(reload, always) :- !. '$lgt_valid_flag_value'(reload, skip) :- !. '$lgt_valid_flag_value'(underscore_variables, dont_care) :- !. '$lgt_valid_flag_value'(underscore_variables, singletons) :- !. '$lgt_valid_flag_value'(code_prefix, Prefix) :- atom(Prefix). '$lgt_valid_flag_value'(debug, on) :- !. '$lgt_valid_flag_value'(debug, off) :- !. '$lgt_valid_flag_value'(events, on) :- !. '$lgt_valid_flag_value'(events, off) :- !. '$lgt_valid_flag_value'(hook, Obj::Functor) :- atom(Functor), callable(Obj). '$lgt_valid_flag_value'(xmldir, Directory) :- atom(Directory). '$lgt_valid_flag_value'(tmpdir, Directory) :- atom(Directory). % '$lgt_valid_entity_parameter'(@term) % % valid predicate argument documentation on info/2 directive '$lgt_valid_entity_parameter'(Name - Description) :- atom(Name), atom(Description). % '$lgt_valid_pred_argument'(@term) % % valid predicate argument documentation on info/2 directive '$lgt_valid_pred_argument'(Name - Description) :- atom(Name), atom(Description). % '$lgt_valid_pred_allocation'(@nonvar) % % valid predicate allocation on info/2 directive '$lgt_valid_pred_allocation'(container). '$lgt_valid_pred_allocation'(descendants). '$lgt_valid_pred_allocation'(instances). '$lgt_valid_pred_allocation'(classes). '$lgt_valid_pred_allocation'(subclasses). '$lgt_valid_pred_allocation'(any). % '$lgt_valid_pred_redefinition'(@nonvar) % % valid predicate redefinition on info/2 directive '$lgt_valid_pred_redefinition'(never). '$lgt_valid_pred_redefinition'(free). '$lgt_valid_pred_redefinition'(specialize). '$lgt_valid_pred_redefinition'(call_super_first). '$lgt_valid_pred_redefinition'(call_super_last). % '$lgt_valid_pred_exception'(@term) % % valid predicate exception documentation on info/2 directive '$lgt_valid_pred_exception'(Description - Term) :- atom(Description), nonvar(Term). % '$lgt_valid_pred_call_example'(@term) % % valid predicate call example documentation on info/1 directive '$lgt_valid_pred_call_example'(Description - Call - {Bindings}) :- atom(Description), callable(Call), nonvar(Bindings), ( Bindings == no -> true ; Bindings == yes -> true ; '$lgt_valid_example_var_bindings'(Bindings) ). % '$lgt_valid_pred_call_example'(@term, +atom, +integer) % % valid predicate call example documentation on info/2 directive '$lgt_valid_pred_call_example'((Description - Call - {Bindings}), Functor, Arity) :- atom(Description), nonvar(Call), functor(Pred, Functor, Arity), Call = Pred, nonvar(Bindings), ( Bindings == no -> true ; Bindings == yes -> true ; '$lgt_valid_example_var_bindings'(Bindings) ). '$lgt_valid_example_var_bindings'((Binding, Bindings)) :- !, '$lgt_valid_example_var_binding'(Binding), '$lgt_valid_example_var_bindings'(Bindings). '$lgt_valid_example_var_bindings'(Binding) :- '$lgt_valid_example_var_binding'(Binding). '$lgt_valid_example_var_binding'(Binding) :- nonvar(Binding), Binding = (Var = _), var(Var). % '$lgt_xml_encoding'(-atom) % % returns the text encoding that should be used on the XML documenting file; % default encoding is UTF-8 '$lgt_xml_encoding'(XMLEncoding) :- ( '$lgt_pp_directive_'(encoding(Encoding)) -> '$lgt_xml_encoding_table'(Encoding, XMLEncoding) ; XMLEncoding = 'utf-8' ). % '$lgt_xml_encoding_table'(?atom, ?atom) % % converts between Prolog stream encoding names and XML encoding names '$lgt_xml_encoding_table'(ascii, 'us-ascii') :- !. '$lgt_xml_encoding_table'(iso_8859_1, 'iso-8859-1') :- !. '$lgt_xml_encoding_table'(iso_latin_1, 'iso-8859-1') :- !. '$lgt_xml_encoding_table'(utf8, 'utf-8') :- !. '$lgt_xml_encoding_table'(unicode_be, 'utf-16') :- !. '$lgt_xml_encoding_table'(unicode_le, 'utf-16') :- !. '$lgt_xml_encoding_table'(Encoding, Encoding). % Logtalk built-in predicates % % '$lgt_lgt_built_in'(?callable) '$lgt_lgt_built_in'(::(_, _)). '$lgt_lgt_built_in'(forall(_, _)). '$lgt_lgt_built_in'(retractall(_)). '$lgt_lgt_built_in'(logtalk_compile(_)). '$lgt_lgt_built_in'(logtalk_compile(_, _)). '$lgt_lgt_built_in'(logtalk_load(_)). '$lgt_lgt_built_in'(logtalk_load(_, _)). '$lgt_lgt_built_in'(protocol_property(_, _)). '$lgt_lgt_built_in'(category_property(_, _)). '$lgt_lgt_built_in'(object_property(_, _)). '$lgt_lgt_built_in'(current_protocol(_)). '$lgt_lgt_built_in'(current_category(_)). '$lgt_lgt_built_in'(current_object(_)). '$lgt_lgt_built_in'(create_object(_, _, _, _)). '$lgt_lgt_built_in'(create_category(_, _, _, _)). '$lgt_lgt_built_in'(create_protocol(_, _, _)). '$lgt_lgt_built_in'(abolish_object(_)). '$lgt_lgt_built_in'(abolish_category(_)). '$lgt_lgt_built_in'(abolish_protocol(_)). '$lgt_lgt_built_in'(implements_protocol(_, _)). '$lgt_lgt_built_in'(implements_protocol(_, _, _)). '$lgt_lgt_built_in'(imports_category(_, _)). '$lgt_lgt_built_in'(imports_category(_, _, _)). '$lgt_lgt_built_in'(instantiates_class(_, _)). '$lgt_lgt_built_in'(instantiates_class(_, _, _)). '$lgt_lgt_built_in'(specializes_class(_, _)). '$lgt_lgt_built_in'(specializes_class(_, _, _)). '$lgt_lgt_built_in'(extends_protocol(_, _)). '$lgt_lgt_built_in'(extends_protocol(_, _, _)). '$lgt_lgt_built_in'(extends_object(_, _)). '$lgt_lgt_built_in'(extends_object(_, _, _)). '$lgt_lgt_built_in'(abolish_events(_, _, _, _, _)). '$lgt_lgt_built_in'(define_events(_, _, _, _, _)). '$lgt_lgt_built_in'(current_event(_, _, _, _, _)). '$lgt_lgt_built_in'(current_logtalk_flag(_, _)). '$lgt_lgt_built_in'(set_logtalk_flag(_, _)). '$lgt_lgt_built_in'(threaded(_)). '$lgt_lgt_built_in'(threaded_call(_, _)). '$lgt_lgt_built_in'(threaded_call(_)). '$lgt_lgt_built_in'(threaded_once(_, _)). '$lgt_lgt_built_in'(threaded_once(_)). '$lgt_lgt_built_in'(threaded_ignore(_)). '$lgt_lgt_built_in'(threaded_exit(_, _)). '$lgt_lgt_built_in'(threaded_exit(_)). '$lgt_lgt_built_in'(threaded_peek(_, _)). '$lgt_lgt_built_in'(threaded_peek(_)). '$lgt_lgt_built_in'(threaded_wait(_)). '$lgt_lgt_built_in'(threaded_notify(_)). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % DCG rule conversion % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % '$lgt_dcgrule_to_clause'(@dcgrule, -clause) % % converts a grammar rule into a normal clause '$lgt_dcgrule_to_clause'(Rule, Clause) :- catch( '$lgt_dcg_rule'(Rule, Clause), Error, throw(error(Error, grammar_rule(Rule)))). % '$lgt_dcg_rule'(@dcgrule, -clause) % % converts a grammar rule into a normal clause: '$lgt_dcg_rule'(Rule, Clause) :- '$lgt_dcg_rule'(Rule, S0, S, Expansion), '$lgt_dcg_simplify'(Expansion, S0, S, Clause). '$lgt_dcg_rule'((RHead --> _), _, _, _) :- var(RHead), throw(instantiation_error). '$lgt_dcg_rule'((RHead, _ --> _), _, _, _) :- var(RHead), throw(instantiation_error). '$lgt_dcg_rule'((_, Terminals --> _), _, _, _) :- var(Terminals), throw(instantiation_error). '$lgt_dcg_rule'((NonTerminal, Terminals --> GRBody), S0, S, (Head :- Body)) :- !, '$lgt_dcg_non_terminal'(NonTerminal, S0, S, Head), '$lgt_dcg_body'(GRBody, S0, S1, Goal1), '$lgt_dcg_terminals'(Terminals, S, S1, Goal2), Body = (Goal1, Goal2), functor(NonTerminal, Functor, Arity), ( '$lgt_pp_defs_nt_'(Functor, Arity) -> true ; assertz('$lgt_pp_defs_nt_'(Functor, Arity)) ). '$lgt_dcg_rule'((NonTerminal --> GRBody), S0, S, (Head :- Body)) :- !, '$lgt_dcg_non_terminal'(NonTerminal, S0, S, Head), '$lgt_dcg_body'(GRBody, S0, S, Body), functor(NonTerminal, Functor, Arity), ( '$lgt_pp_defs_nt_'(Functor, Arity) -> true ; assertz('$lgt_pp_defs_nt_'(Functor, Arity)) ). '$lgt_dcg_rule'(Term, _, _, _) :- throw(type_error(grammar_rule, Term)). % '$lgt_dcg_non_terminal'(+callable, @var, @var, -goal) % % translates a grammar goal non-terminal: '$lgt_dcg_non_terminal'(NonTerminal, _, _, _) :- \+ callable(NonTerminal), throw(type_error(callable, NonTerminal)). '$lgt_dcg_non_terminal'(NonTerminal, S0, S, Goal) :- NonTerminal =.. NonTerminalUniv, '$lgt_append'(NonTerminalUniv, [S0, S], GoalUniv), Goal =.. GoalUniv. % '$lgt_dcg_terminals'(+list, @var, @var, -goal) % % translates a list of terminals: '$lgt_dcg_terminals'(Terminals, _, _, _) :- \+ '$lgt_is_proper_list'(Terminals), throw(type_error(list, Terminals)). '$lgt_dcg_terminals'(Terminals, S0, S, S0 = List) :- '$lgt_append'(Terminals, S, List). % '$lgt_dcg_msg'(@dcgbody, @var, @var, -body) % % translates a grammar rule message to an object into a Prolog message: '$lgt_dcg_msg'(Var, S0, S, phrase(Var, S0, S)) :- var(Var), !. '$lgt_dcg_msg'((GRIf -> GRThen), S0, S, (If -> Then)) :- !, '$lgt_dcg_msg'(GRIf, S0, S1, If), '$lgt_dcg_msg'(GRThen, S1, S, Then). '$lgt_dcg_msg'((GREither; GROr), S0, S, (Either; Or)) :- !, '$lgt_dcg_msg'(GREither, S0, S, Either), '$lgt_dcg_msg'(GROr, S0, S, Or). '$lgt_dcg_msg'((GRFirst, GRSecond), S0, S, (First, Second)) :- !, '$lgt_dcg_msg'(GRFirst, S0, S1, First), '$lgt_dcg_msg'(GRSecond, S1, S, Second). '$lgt_dcg_msg'(!, S0, S, (!, S0 = S)) :- !. '$lgt_dcg_msg'({}, S0, S, (S0 = S)) :- !. '$lgt_dcg_msg'({Goal}, S0, S, (call(Goal), S0 = S)) :- var(Goal), !. '$lgt_dcg_msg'({Goal}, _, _, _) :- \+ callable(Goal), throw(type_error(callable, Goal)). '$lgt_dcg_msg'({Goal}, S0, S, (Goal, S0 = S)) :- !. '$lgt_dcg_msg'(\+ GRBody, S0, S, (\+ Goal, S0 = S)) :- !, '$lgt_dcg_msg'(GRBody, S0, S, Goal). '$lgt_dcg_msg'([], S0, S, (S0=S)) :- !. '$lgt_dcg_msg'([T| Ts], S0, S, Goal) :- !, '$lgt_dcg_terminals'([T| Ts], S0, S, Goal). '$lgt_dcg_msg'(NonTerminal, S0, S, phrase(NonTerminal, S0, S)) :- '$lgt_dcg_non_terminal'(NonTerminal, S0, S, _). % just check validity % '$lgt_dcg_body'(@dcgbody, @var, @var, -body) % % translates a grammar rule body into a Prolog clause body: '$lgt_dcg_body'(Var, S0, S, phrase(Var, S0, S)) :- var(Var), !. '$lgt_dcg_body'(::RGoal, S0, S, ::CGoal) :- !, '$lgt_dcg_msg'(RGoal, S0, S, CGoal). '$lgt_dcg_body'(Object::RGoal, S0, S, Object::CGoal) :- !, '$lgt_dcg_msg'(RGoal, S0, S, CGoal). '$lgt_dcg_body'((GRIf -> GRThen), S0, S, (If -> Then)) :- !, '$lgt_dcg_body'(GRIf, S0, S1, If), '$lgt_dcg_body'(GRThen, S1, S, Then). '$lgt_dcg_body'((GREither; GROr), S0, S, (Either; Or)) :- !, '$lgt_dcg_body'(GREither, S0, S, Either), '$lgt_dcg_body'(GROr, S0, S, Or). '$lgt_dcg_body'((GRFirst, GRSecond), S0, S, (First, Second)) :- !, '$lgt_dcg_body'(GRFirst, S0, S1, First), '$lgt_dcg_body'(GRSecond, S1, S, Second). '$lgt_dcg_body'(!, S0, S, (!, S0 = S)) :- !. '$lgt_dcg_body'({}, S0, S, (S0 = S)) :- !. '$lgt_dcg_body'({Goal}, S0, S, (call(Goal), S0 = S)) :- var(Goal), !. '$lgt_dcg_body'({Goal}, _, _, _) :- \+ callable(Goal), throw(type_error(callable, Goal)). '$lgt_dcg_body'({Goal}, S0, S, (Goal, S0 = S)) :- !. '$lgt_dcg_body'(\+ GRBody, S0, S, (\+ Goal, S0 = S)) :- !, '$lgt_dcg_body'(GRBody, S0, S, Goal). '$lgt_dcg_body'([], S0, S, (S0=S)) :- !. '$lgt_dcg_body'([T| Ts], S0, S, Goal) :- !, '$lgt_dcg_terminals'([T| Ts], S0, S, Goal). '$lgt_dcg_body'(NonTerminal, S0, S, Goal) :- '$lgt_dcg_non_terminal'(NonTerminal, S0, S, Goal), functor(NonTerminal, Functor, Arity), ( '$lgt_pp_calls_nt_'(Functor, Arity) -> true ; assertz('$lgt_pp_calls_nt_'(Functor, Arity)) ). % '$lgt_dcg_simplify'(+clause, @var, @var, -clause) % % simplifies the clause resulting from a grammar rule translation: '$lgt_dcg_simplify'((Head :- Body), _, _, Clause) :- '$lgt_dcg_conjunctions'(Body, Flatted), '$lgt_dcg_fold_left'(Flatted, FoldedLeft), '$lgt_dcg_fold_pairs'(FoldedLeft, FoldedPairs), ( FoldedPairs == true -> Clause = Head ; Clause = (Head :- FoldedPairs) ). % '$lgt_dcg_conjunctions'(+goal, -goal) % % removes redundant calls to true/0 and flattens conjunction of goals: '$lgt_dcg_conjunctions'((Goal1 -> Goal2), (SGoal1 -> SGoal2)) :- !, '$lgt_dcg_conjunctions'(Goal1, SGoal1), '$lgt_dcg_conjunctions'(Goal2, SGoal2). '$lgt_dcg_conjunctions'((Goal1; Goal2), (SGoal1; SGoal2)) :- !, '$lgt_dcg_conjunctions'(Goal1, SGoal1), '$lgt_dcg_conjunctions'(Goal2, SGoal2). '$lgt_dcg_conjunctions'(((Goal1, Goal2), Goal3), Body) :- !, '$lgt_dcg_conjunctions'((Goal1, (Goal2, Goal3)), Body). '$lgt_dcg_conjunctions'((true, Goal), Body) :- !, '$lgt_dcg_conjunctions'(Goal, Body). '$lgt_dcg_conjunctions'((Goal, true), Body) :- !, '$lgt_dcg_conjunctions'(Goal, Body). '$lgt_dcg_conjunctions'((Goal1, Goal2), (Goal1, Goal3)) :- !, '$lgt_dcg_conjunctions'(Goal2, Goal3). '$lgt_dcg_conjunctions'(\+ Goal, \+ SGoal) :- !, '$lgt_dcg_conjunctions'(Goal, SGoal). '$lgt_dcg_conjunctions'(::Goal, ::SGoal) :- !, '$lgt_dcg_conjunctions'(Goal, SGoal). '$lgt_dcg_conjunctions'(Object::Goal, Object::SGoal) :- !, '$lgt_dcg_conjunctions'(Goal, SGoal). '$lgt_dcg_conjunctions'(Goal, Goal). % '$lgt_dcg_fold_left'(+goal, -goal) % % folds left unifications: '$lgt_dcg_fold_left'((Term1 = Term2), true) :- !, Term1 = Term2. '$lgt_dcg_fold_left'(((Term1 = Term2), Goal), Folded) :- !, Term1 = Term2, '$lgt_dcg_fold_left'(Goal, Folded). '$lgt_dcg_fold_left'(Goal, Goal). % '$lgt_dcg_fold_pairs'(+goal, -goal) % % folds pairs of consecutive unifications (T1 = T2, T2 = T3): '$lgt_dcg_fold_pairs'((Goal1 -> Goal2), (SGoal1 -> SGoal2)) :- !, '$lgt_dcg_fold_pairs'(Goal1, SGoal1), '$lgt_dcg_fold_pairs'(Goal2, SGoal2). '$lgt_dcg_fold_pairs'((Goal1; Goal2), (SGoal1; SGoal2)) :- !, '$lgt_dcg_fold_pairs'(Goal1, SGoal1), '$lgt_dcg_fold_pairs'(Goal2, SGoal2). '$lgt_dcg_fold_pairs'(((T1 = T2a), (T2b = T3)), (T1 = T3)) :- T2a == T2b, !. '$lgt_dcg_fold_pairs'(((T1 = T2a), (T2b = T3), Goal), ((T1 = T3), Goal2)) :- T2a == T2b, !, '$lgt_dcg_fold_pairs'(Goal, Goal2). '$lgt_dcg_fold_pairs'((Goal1, Goal2), (Goal1, Goal3)) :- !, '$lgt_dcg_fold_pairs'(Goal2, Goal3). '$lgt_dcg_fold_pairs'(\+ Goal, \+ SGoal) :- !, '$lgt_dcg_fold_pairs'(Goal, SGoal). '$lgt_dcg_fold_pairs'(::Goal, ::SGoal) :- !, '$lgt_dcg_fold_pairs'(Goal, SGoal). '$lgt_dcg_fold_pairs'(Object::Goal, Object::SGoal) :- !, '$lgt_dcg_fold_pairs'(Goal, SGoal). '$lgt_dcg_fold_pairs'(Goal, Goal). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % xml % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % '$lgt_write_xml_file'(@stream) % % writes a XML file containing the documentation of a compiled entity '$lgt_write_xml_file'(Stream) :- '$lgt_write_xml_header'(Stream), '$lgt_write_xml_entity'(Stream), '$lgt_write_xml_relations'(Stream), '$lgt_write_xml_predicates'(Stream), '$lgt_write_xml_remarks'(Stream), '$lgt_write_xml_footer'(Stream). '$lgt_write_xml_header'(Stream) :- '$lgt_compiler_flag'(xmlspec, XMLSpec), '$lgt_compiler_flag'(xmlsref, XMLSRef), '$lgt_write_xml_header'(XMLSRef, XMLSpec, Stream). '$lgt_write_xml_header'(local, XMLSpec, Stream) :- '$lgt_xml_encoding'(Encoding), '$lgt_xml_header_text'('1.0', Encoding, no, Text), '$lgt_write_xml_open_tag'(Stream, Text, []), ( XMLSpec == dtd -> write(Stream, ''), nl(Stream) ; true ), '$lgt_compiler_flag'(xslfile, XSL), write(Stream, ''), nl(Stream), ( XMLSpec == dtd -> '$lgt_write_xml_open_tag'(Stream, logtalk, []) ; '$lgt_write_xml_open_tag'(Stream, logtalk, ['xmlns:xsi'-'http://www.w3.org/2001/XMLSchema-instance', 'xsi:noNamespaceSchemaLocation'-'logtalk.xsd']) ). '$lgt_write_xml_header'(web, XMLSpec, Stream) :- '$lgt_xml_encoding'(Encoding), '$lgt_xml_header_text'('1.0', Encoding, no, Text), '$lgt_write_xml_open_tag'(Stream, Text, []), ( XMLSpec == dtd -> write(Stream, ''), nl(Stream) ; true ), '$lgt_compiler_flag'(xslfile, XSL), write(Stream, ''), nl(Stream), ( XMLSpec == dtd -> '$lgt_write_xml_open_tag'(Stream, logtalk, []) ; '$lgt_write_xml_open_tag'(Stream, logtalk, ['xmlns:xsi'-'http://www.w3.org/2001/XMLSchema-instance', 'xsi:noNamespaceSchemaLocation'-'http://logtalk.org/xml/1.4/logtalk.xsd']) ). '$lgt_write_xml_header'(standalone, _, Stream) :- '$lgt_xml_encoding'(Encoding), '$lgt_xml_header_text'('1.0', Encoding, yes, Text), '$lgt_write_xml_open_tag'(Stream, Text, []), '$lgt_compiler_flag'(xslfile, XSL), write(Stream, ''), nl(Stream), '$lgt_write_xml_open_tag'(Stream, logtalk, []). '$lgt_xml_header_text'(Version, Encoding, Standalone, Text) :- atom_concat('?xml version="', Version, Aux1), atom_concat(Aux1, '" encoding="', Aux2), atom_concat(Aux2, Encoding, Aux3), atom_concat(Aux3, '" standalone="', Aux4), atom_concat(Aux4, Standalone, Aux5), atom_concat(Aux5, '"?', Text). '$lgt_write_xml_footer'(Stream) :- '$lgt_write_xml_close_tag'(Stream, logtalk). '$lgt_write_xml_entity'(Stream) :- '$lgt_pp_entity'(Type, Entity, _, _, Compilation), '$lgt_write_xml_open_tag'(Stream, entity, []), '$lgt_entity_to_xml_term'(Entity), '$lgt_write_xml_cdata_element'(Stream, name, [], Entity), '$lgt_write_xml_element'(Stream, (type), [], Type), '$lgt_write_xml_element'(Stream, compilation, [], Compilation), ( '$lgt_pp_info_'(Info) -> '$lgt_write_xml_entity_info'(Stream, Info) ; true ), '$lgt_write_xml_close_tag'(Stream, entity). '$lgt_write_xml_entity_info'(Stream, Info) :- ( '$lgt_member'(comment is Comment, Info) -> '$lgt_write_xml_cdata_element'(Stream, comment, [], Comment) ; true ), ( '$lgt_member'(parameters is Parameters, Info) -> '$lgt_write_xml_open_tag'(Stream, parameters, []), forall( '$lgt_member'(Parname-Description, Parameters), ('$lgt_write_xml_open_tag'(Stream, parameter, []), '$lgt_write_xml_cdata_element'(Stream, name, [], Parname), '$lgt_write_xml_cdata_element'(Stream, description, [], Description), '$lgt_write_xml_close_tag'(Stream, parameter))), '$lgt_write_xml_close_tag'(Stream, parameters) ; true ), ( '$lgt_member'(author is Author, Info) -> ( atom(Author) -> '$lgt_write_xml_cdata_element'(Stream, author, [], Author) ; '$lgt_entity_name_to_xml_entity'(Author, AuthorEntity), '$lgt_write_xml_element'(Stream, author, [], AuthorEntity) ) ; true ), ( '$lgt_member'(version is Version, Info) -> '$lgt_write_xml_element'(Stream, version, [], Version) ; true ), ( '$lgt_member'(date is Date, Info) -> '$lgt_write_xml_element'(Stream, date, [], Date) ; true ), ( '$lgt_member'(copyright is Copyright, Info) -> ( atom(Copyright) -> '$lgt_write_xml_element'(Stream, copyright, [], Copyright) ; '$lgt_entity_name_to_xml_entity'(Copyright, CopyrightEntity), '$lgt_write_xml_element'(Stream, copyright, [], CopyrightEntity) ) ; true ), ( '$lgt_member'(license is License, Info) -> ( atom(License) -> '$lgt_write_xml_element'(Stream, license, [], License) ; '$lgt_entity_name_to_xml_entity'(License, LicenseEntity), '$lgt_write_xml_element'(Stream, license, [], LicenseEntity) ) ; true ), forall( ('$lgt_member'(Key is Value, Info), \+ '$lgt_member'(Key, [comment, author, version, date, parameters, parnames, copyright, license, remarks])), ('$lgt_write_xml_open_tag'(Stream, info, []), '$lgt_write_xml_element'(Stream, key, [], Key), '$lgt_write_xml_cdata_element'(Stream, value, [], Value), '$lgt_write_xml_close_tag'(Stream, info))). '$lgt_entity_name_to_xml_entity'({EntityName}, XMLEntity) :- atom_concat('&', EntityName, Aux), atom_concat(Aux, ';', XMLEntity). % '$lgt_entity_to_xml_term'(+entity) % % instantiates the parameters in a parametric object to % user defined names or to the atom '_' '$lgt_entity_to_xml_term'(Entity) :- '$lgt_pp_info_'(List), ( '$lgt_member'(parnames is Names, List) -> true ; '$lgt_member'(parameters is Parameters, List), findall(Name, '$lgt_member'(Name - _, Parameters), Names) ), !, Entity =.. [_| Args], '$lgt_vars_to_atoms'(Args, Args, Names). '$lgt_entity_to_xml_term'(Entity) :- Entity =.. [_| Args], '$lgt_vars_to_underscore'(Args). % '$lgt_relation_to_xml_term'(+entity, +entity) % % instantiates the parameters in a related entity taking % in account the parameter sharing with the original entity '$lgt_relation_to_xml_term'(Entity, Relation) :- '$lgt_entity_to_xml_term'(Entity), Relation =.. [_| Args], '$lgt_vars_to_underscore'(Args). % '$lgt_pred_call_to_xml_term'(+atom, +integer, +nonvar, +nonvar, -nonvar, -nonvar) % % instantiates the arguments in a predicate call to user defined names or to the atom '_' '$lgt_pred_call_to_xml_term'(Functor, Arity, Call, Bindings, QCall, QBindings) :- '$lgt_double_quote_atoms'(Call, QCall), '$lgt_double_quote_atoms'(Bindings, QBindings), '$lgt_pred_qcall_to_xml_term'(Functor, Arity, QCall, QBindings). '$lgt_pred_qcall_to_xml_term'(Functor, Arity, Call, Bindings) :- ( '$lgt_pp_info_'(Functor/Arity, List) -> true ; '$lgt_pp_info_'(Functor//Arity, List) ), ( '$lgt_member'(argnames is Names, List) -> true ; '$lgt_member'(arguments is Arguments, List), findall(Name, '$lgt_member'(Name - _, Arguments), Names) ), !, Call =.. [Functor| Args], '$lgt_binding_vars'(Bindings, Vars), '$lgt_vars_to_atoms'(Args, Vars, Names). '$lgt_pred_qcall_to_xml_term'(Functor, _, Call, _) :- Call =.. [Functor| Args], '$lgt_vars_to_underscore'(Args). '$lgt_double_quote_atoms'(Var, Var) :- var(Var), !. '$lgt_double_quote_atoms'((Call1, Call2), (QCall1, QCall2)) :- !, '$lgt_double_quote_atoms'(Call1, QCall1), '$lgt_double_quote_atoms'(Call2, QCall2). '$lgt_double_quote_atoms'((Call1; Call2), (QCall1; QCall2)) :- !, '$lgt_double_quote_atoms'(Call1, QCall1), '$lgt_double_quote_atoms'(Call2, QCall2). '$lgt_double_quote_atoms'((Call1 -> Call2), (QCall1 -> QCall2)) :- !, '$lgt_double_quote_atoms'(Call1, QCall1), '$lgt_double_quote_atoms'(Call2, QCall2). '$lgt_double_quote_atoms'(\+ Call, \+ QCall) :- !, '$lgt_double_quote_atoms'(Call, QCall). '$lgt_double_quote_atoms'([], []) :- !. '$lgt_double_quote_atoms'([Arg| Args], [QArg| QArgs]) :- !, '$lgt_double_quote_atoms'(Arg, QArg), '$lgt_double_quote_atoms'(Args, QArgs). '$lgt_double_quote_atoms'(Atom, QAtom) :- atom(Atom), !, ( '$lgt_atom_needs_quotes'(Atom) -> atom_concat('''', Atom, Aux), atom_concat(Aux, '''', QAtom) ; Atom = QAtom ). '$lgt_double_quote_atoms'(Number, Number) :- number(Number), !. '$lgt_double_quote_atoms'(Term, QTerm) :- Term =.. [Functor| Args], ( '$lgt_built_in'(Term) -> QFunctor = Functor ; '$lgt_double_quote_atoms'(Functor, QFunctor) ), '$lgt_double_quote_atoms'(Args, QArgs), QTerm =.. [QFunctor| QArgs]. '$lgt_atom_needs_quotes'(Atom) :- atom_chars(Atom, [First| Rest]), ( First @< a ; First @> z ; '$lgt_member'(Char, Rest), \+ '$lgt_alpha_numeric_char'(Char) ), !. '$lgt_alpha_numeric_char'('_'). '$lgt_alpha_numeric_char'(Char) :- Char @>= a, Char @=< z. '$lgt_alpha_numeric_char'(Char) :- Char @>= 'A', Char @=< 'Z'. '$lgt_alpha_numeric_char'(Char) :- Char @>= '0', Char @=< '9'. % '$lgt_binding_vars'(@nonvar, -list) % % returns a list of all binding variables '$lgt_binding_vars'(Bindings, Vars) :- ( atom(Bindings) -> % no bindings, just "no", "yes", or equivalent answers Vars = [] ; '$lgt_binding_vars_list'(Bindings, Vars) ). '$lgt_binding_vars_list'((Var = _), [Var]). '$lgt_binding_vars_list'(((Var = _), Bindings), [Var| Vars]) :- '$lgt_binding_vars_list'(Bindings, Vars). % '$lgt_vars_to_atoms'(+list, +list, +list) % % instantiates the variables in the input list to either a name or the atom '_' '$lgt_vars_to_atoms'([], _, []). '$lgt_vars_to_atoms'([Arg| Args], Vars, [Name| Names]) :- ( var(Arg) -> ( '$lgt_member_var'(Arg, Vars) -> Arg = Name ; Arg = '_' ) ; true ), '$lgt_vars_to_atoms'(Args, Vars, Names). % '$lgt_vars_to_underscore'(+list) % % instantiates the variables in the input list to the atom '_' '$lgt_vars_to_underscore'([]). '$lgt_vars_to_underscore'([Arg| Args]) :- ( var(Arg) -> Arg = '_' ; true ), '$lgt_vars_to_underscore'(Args). % '$lgt_relation_to_xml_filename'(+entity, -atom) % % needed to build filenames in links to parametric objects '$lgt_relation_to_xml_filename'(Relation, File) :- functor(Relation, Functor, Arity), number_codes(Arity, Codes), atom_codes(Atom, Codes), atom_concat(Functor, '_', Aux), atom_concat(Aux, Atom, File). % '$lgt_write_xml_predicates'(@stream) % % writes the predicate documentation '$lgt_write_xml_predicates'(Stream) :- '$lgt_write_xml_open_tag'(Stream, predicates, []), '$lgt_write_xml_public_predicates'(Stream), '$lgt_write_xml_protected_predicates'(Stream), '$lgt_write_xml_private_predicates'(Stream), '$lgt_write_xml_close_tag'(Stream, predicates). % '$lgt_write_xml_public_predicates'(@stream) % % writes the documentation of public predicates '$lgt_write_xml_public_predicates'(Stream) :- '$lgt_write_xml_open_tag'(Stream, (public), []), '$lgt_pp_public_'(Functor, Arity), ( '$lgt_pp_non_terminal_'(Functor, Args, Arity) -> '$lgt_write_xml_non_terminal'(Stream, Functor, Args, Arity, (public)) ; '$lgt_write_xml_predicate'(Stream, Functor, Arity, (public)) ), fail. '$lgt_write_xml_public_predicates'(Stream) :- '$lgt_write_xml_close_tag'(Stream, (public)). % '$lgt_write_xml_protected_predicates'(@stream) % % writes the documentation protected predicates '$lgt_write_xml_protected_predicates'(Stream) :- '$lgt_write_xml_open_tag'(Stream, protected, []), '$lgt_pp_protected_'(Functor, Arity), ( '$lgt_pp_non_terminal_'(Functor, Args, Arity) -> '$lgt_write_xml_non_terminal'(Stream, Functor, Args, Arity, protected) ; '$lgt_write_xml_predicate'(Stream, Functor, Arity, protected) ), fail. '$lgt_write_xml_protected_predicates'(Stream) :- '$lgt_write_xml_close_tag'(Stream, protected). % '$lgt_write_xml_private_predicates'(@stream) % % writes the documentation of private predicates '$lgt_write_xml_private_predicates'(Stream) :- '$lgt_write_xml_open_tag'(Stream, private, []), '$lgt_pp_private_'(Functor, Arity), ( '$lgt_pp_non_terminal_'(Functor, Args, Arity) -> '$lgt_write_xml_non_terminal'(Stream, Functor, Args, Arity, private) ; '$lgt_write_xml_predicate'(Stream, Functor, Arity, private) ), fail. '$lgt_write_xml_private_predicates'(Stream) :- '$lgt_write_xml_close_tag'(Stream, private). % '$lgt_write_xml_predicate'(@stream, +atom, +integer, +term) % % writes the documentation of a predicate '$lgt_write_xml_predicate'(Stream, Functor, Arity, Scope) :- '$lgt_write_xml_open_tag'(Stream, predicate, []), '$lgt_write_xml_predicate_data'(Stream, Functor, Arity, Functor/Arity, Scope), '$lgt_write_xml_predicate_meta'(Stream, Functor, Arity), '$lgt_write_xml_predicate_mode'(Stream, Functor, Arity), ( '$lgt_pp_info_'(Functor/Arity, Info) -> '$lgt_write_xml_predicate_info'(Stream, Functor, Arity, Info) ; true ), '$lgt_write_xml_close_tag'(Stream, predicate). '$lgt_write_xml_predicate_data'(Stream, Functor, Arity, Name, Scope) :- '$lgt_write_xml_cdata_element'(Stream, name, [], Name), '$lgt_write_xml_element'(Stream, scope, [], Scope), ( ('$lgt_pp_entity'(_, _, _, _, (dynamic)); '$lgt_pp_dynamic_'(Functor, Arity)) -> Compilation = (dynamic) ; Compilation = static ), '$lgt_write_xml_element'(Stream, compilation, [], Compilation). '$lgt_write_xml_predicate_meta'(Stream, Functor, Arity) :- functor(Meta, Functor, Arity), ( '$lgt_pp_meta_predicate_'(Meta) -> '$lgt_write_xml_cdata_element'(Stream, meta, [], Meta) ; true ). '$lgt_write_xml_predicate_mode'(Stream, Functor, Arity) :- functor(Template, Functor, Arity), forall( '$lgt_pp_mode_'(Template, Solutions), ('$lgt_write_xml_open_tag'(Stream, (mode), []), '$lgt_write_xml_cdata_element'(Stream, template, [], Template), '$lgt_write_xml_element'(Stream, solutions, [], Solutions), '$lgt_write_xml_close_tag'(Stream, (mode)))). '$lgt_write_xml_predicate_info'(Stream, Functor, Arity, Info) :- ( '$lgt_member'(comment is Comment, Info) -> '$lgt_write_xml_cdata_element'(Stream, comment, [], Comment) ; true ), ( '$lgt_member'(arguments is Arguments, Info) -> findall(Name, '$lgt_member'(Name - _, Arguments), Names), Template =.. [Functor| Names], '$lgt_write_xml_cdata_element'(Stream, template, [], Template), '$lgt_write_xml_open_tag'(Stream, arguments, []), forall( '$lgt_member'(Name-Description, Arguments), ('$lgt_write_xml_open_tag'(Stream, argument, []), '$lgt_write_xml_cdata_element'(Stream, name, [], Name), '$lgt_write_xml_cdata_element'(Stream, description, [], Description), '$lgt_write_xml_close_tag'(Stream, argument))), '$lgt_write_xml_close_tag'(Stream, arguments) ; true ), ( '$lgt_member'(argnames is Names, Info) -> Template =.. [Functor| Names], '$lgt_write_xml_cdata_element'(Stream, template, [], Template) ; true ), ( '$lgt_member'(exceptions is Exceptions, Info) -> '$lgt_write_xml_open_tag'(Stream, exceptions, []), forall( '$lgt_member'(Cond-Term, Exceptions), ('$lgt_write_xml_open_tag'(Stream, exception, []), '$lgt_write_xml_cdata_element'(Stream, condition, [], Cond), '$lgt_write_xml_cdata_element'(Stream, term, [], Term), '$lgt_write_xml_close_tag'(Stream, exception))), '$lgt_write_xml_close_tag'(Stream, exceptions) ; true ), forall( ('$lgt_member'(Key is Value, Info), \+ '$lgt_member'(Key, [comment, arguments, argnames, exceptions, examples])), ('$lgt_write_xml_open_tag'(Stream, info, []), '$lgt_write_xml_element'(Stream, key, [], Key), '$lgt_write_xml_cdata_element'(Stream, value, [], Value), '$lgt_write_xml_close_tag'(Stream, info))), ( '$lgt_member'(examples is Examples, Info) -> '$lgt_write_xml_open_tag'(Stream, examples, []), forall( '$lgt_member'((Description - Call - {Bindings}), Examples), ('$lgt_pred_call_to_xml_term'(Functor, Arity, Call, Bindings, QCall, QBindings), '$lgt_write_xml_open_tag'(Stream, example, []), '$lgt_write_xml_cdata_element'(Stream, description, [], Description), '$lgt_write_xml_cdata_element'(Stream, call, [], QCall), '$lgt_write_xml_cdata_element'(Stream, bindings, [], QBindings), '$lgt_write_xml_close_tag'(Stream, example))), '$lgt_write_xml_close_tag'(Stream, examples) ; true ). % '$lgt_write_xml_non_terminal'(@stream, +atom, +atom, +integer, +term) % % writes the documentation of a grammar rule non-terminal '$lgt_write_xml_non_terminal'(Stream, Functor, Args, Arity, Scope) :- '$lgt_write_xml_open_tag'(Stream, predicate, []), '$lgt_write_xml_predicate_data'(Stream, Functor, Arity, Functor//Args, Scope), '$lgt_write_xml_predicate_mode'(Stream, Functor, Args), ( '$lgt_pp_info_'(Functor//Args, Info) -> '$lgt_write_xml_predicate_info'(Stream, Functor, Args, Info) ; true ), '$lgt_write_xml_close_tag'(Stream, predicate). '$lgt_write_xml_relations'(Stream) :- '$lgt_write_xml_open_tag'(Stream, relations, []), fail. '$lgt_write_xml_relations'(Stream) :- '$lgt_pp_rclause_'('$lgt_implements_protocol_'(Entity, Ptc, Scope)), '$lgt_write_xml_relation'(Stream, Entity, Ptc, implements, Scope), fail. '$lgt_write_xml_relations'(Stream) :- '$lgt_pp_rclause_'('$lgt_imports_category_'(Entity, Ctg, Scope)), '$lgt_write_xml_relation'(Stream, Entity, Ctg, imports, Scope), fail. '$lgt_write_xml_relations'(Stream) :- '$lgt_pp_rclause_'('$lgt_extends_object_'(Entity, Parent, Scope)), '$lgt_write_xml_relation'(Stream, Entity, Parent, extends, Scope), fail. '$lgt_write_xml_relations'(Stream) :- '$lgt_pp_rclause_'('$lgt_instantiates_class_'(Entity, Class, Scope)), '$lgt_write_xml_relation'(Stream, Entity, Class, instantiates, Scope), fail. '$lgt_write_xml_relations'(Stream) :- '$lgt_pp_rclause_'('$lgt_specializes_class_'(Entity, Superclass, Scope)), '$lgt_write_xml_relation'(Stream, Entity, Superclass, specializes, Scope), fail. '$lgt_write_xml_relations'(Stream) :- '$lgt_pp_rclause_'('$lgt_extends_protocol_'(Entity, Ptc, Scope)), '$lgt_write_xml_relation'(Stream, Entity, Ptc, extends, Scope), fail. '$lgt_write_xml_relations'(Stream) :- '$lgt_pp_entity'(_, Entity, _, _, _), '$lgt_pp_uses_'(Obj), '$lgt_write_xml_relation'(Stream, Entity, Obj, uses), fail. '$lgt_write_xml_relations'(Stream) :- '$lgt_pp_entity'(_, Entity, _, _, _), '$lgt_pp_calls_'(Ptc), '$lgt_write_xml_relation'(Stream, Entity, Ptc, calls), fail. '$lgt_write_xml_relations'(Stream) :- '$lgt_write_xml_close_tag'(Stream, relations). '$lgt_write_xml_relation'(Stream, Entity, Relation, Tag, Scope) :- '$lgt_relation_to_xml_term'(Entity, Relation), '$lgt_relation_to_xml_filename'(Relation, File), '$lgt_write_xml_open_tag'(Stream, Tag, []), '$lgt_write_xml_cdata_element'(Stream, name, [], Relation), '$lgt_write_xml_element'(Stream, scope, [], Scope), '$lgt_write_xml_cdata_element'(Stream, file, [], File), '$lgt_write_xml_close_tag'(Stream, Tag). '$lgt_write_xml_relation'(Stream, Entity, Relation, Tag) :- '$lgt_relation_to_xml_term'(Entity, Relation), '$lgt_relation_to_xml_filename'(Relation, File), '$lgt_write_xml_open_tag'(Stream, Tag, []), '$lgt_write_xml_cdata_element'(Stream, name, [], Relation), '$lgt_write_xml_cdata_element'(Stream, file, [], File), '$lgt_write_xml_close_tag'(Stream, Tag). '$lgt_write_xml_remarks'(Stream) :- '$lgt_write_xml_open_tag'(Stream, remarks, []), ( '$lgt_pp_info_'(Info), '$lgt_member'(remarks is Remarks, Info) -> forall( '$lgt_member'((Topic - Text), Remarks), ('$lgt_write_xml_open_tag'(Stream, remark, []), '$lgt_write_xml_cdata_element'(Stream, topic, [], Topic), '$lgt_write_xml_cdata_element'(Stream, text, [], Text), '$lgt_write_xml_close_tag'(Stream, remark))) ; true ), '$lgt_write_xml_close_tag'(Stream, remarks). % '$lgt_write_xml_open_tag'(@stream, @atom, @list) % % writes '$lgt_write_xml_open_tag'(Stream, Tag, Atts) :- write(Stream, '<'), write(Stream, Tag), '$lgt_write_xml_tag_attributes'(Stream, Atts), write(Stream, '>'), nl(Stream). % '$lgt_write_xml_element'(@stream, @atom, @list, @term) % % writes Text '$lgt_write_xml_element'(Stream, Tag, Atts, Text) :- write(Stream, '<'), write(Stream, Tag), '$lgt_write_xml_tag_attributes'(Stream, Atts), write(Stream, '>'), write(Stream, Text), write(Stream, ''), nl(Stream). % '$lgt_writeq_xml_cdata_element'(@stream, @atom, @list, @term) % % writes (quoted) '$lgt_writeq_xml_cdata_element'(Stream, Tag, Atts, Text) :- write(Stream, '<'), write(Stream, Tag), '$lgt_write_xml_tag_attributes'(Stream, Atts), write(Stream, '>'), nl(Stream). % '$lgt_write_xml_cdata_element'(@stream, @atom, @list, @term) % % writes '$lgt_write_xml_cdata_element'(Stream, Tag, Atts, Text) :- write(Stream, '<'), write(Stream, Tag), '$lgt_write_xml_tag_attributes'(Stream, Atts), write(Stream, '>'), nl(Stream). % '$lgt_write_xml_tag_attributes'(@stream, @list) '$lgt_write_xml_tag_attributes'(_, []) :- !. '$lgt_write_xml_tag_attributes'(Stream, [Attribute-Value| Rest]) :- write(Stream, ' '), write(Stream, Attribute), write(Stream, '="'), write(Stream, Value), write(Stream, '"'), '$lgt_write_xml_tag_attributes'(Stream, Rest). % '$lgt_write_xml_close_tag'(@stream, @atom) % % writes '$lgt_write_xml_close_tag'(Stream, Tag) :- write(Stream, ''), nl(Stream). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % table of ISO specified predicates % % (used for portability checking) % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% '$lgt_iso_spec_pred'(true). '$lgt_iso_spec_pred'(fail). '$lgt_iso_spec_pred'(call(_)). '$lgt_iso_spec_pred'(!). '$lgt_iso_spec_pred'((_; _)). '$lgt_iso_spec_pred'((_, _)). '$lgt_iso_spec_pred'((_ -> _)). '$lgt_iso_spec_pred'((_ -> _; _)). '$lgt_iso_spec_pred'(catch(_, _, _)). '$lgt_iso_spec_pred'(throw(_)). '$lgt_iso_spec_pred'((_ = _)). '$lgt_iso_spec_pred'((_ \= _)). '$lgt_iso_spec_pred'(unify_with_occurs_check(_, _)). '$lgt_iso_spec_pred'(var(_)). '$lgt_iso_spec_pred'(nonvar(_)). '$lgt_iso_spec_pred'(atom(_)). '$lgt_iso_spec_pred'(atomic(_)). '$lgt_iso_spec_pred'(number(_)). '$lgt_iso_spec_pred'(integer(_)). '$lgt_iso_spec_pred'(float(_)). '$lgt_iso_spec_pred'(compound(_)). '$lgt_iso_spec_pred'((_ @=< _)). '$lgt_iso_spec_pred'((_ @< _)). '$lgt_iso_spec_pred'((_ @>= _)). '$lgt_iso_spec_pred'((_ @> _)). '$lgt_iso_spec_pred'((_ == _)). '$lgt_iso_spec_pred'((_ \== _)). '$lgt_iso_spec_pred'(functor(_, _, _)). '$lgt_iso_spec_pred'(arg(_, _, _)). '$lgt_iso_spec_pred'(_ =.. _). '$lgt_iso_spec_pred'(copy_term(_, _)). '$lgt_iso_spec_pred'(_ is _). '$lgt_iso_spec_pred'((_ =< _)). '$lgt_iso_spec_pred'((_ < _)). '$lgt_iso_spec_pred'((_ >= _)). '$lgt_iso_spec_pred'((_ > _)). '$lgt_iso_spec_pred'((_ =:= _)). '$lgt_iso_spec_pred'((_ =\= _)). '$lgt_iso_spec_pred'(clause(_, _)). '$lgt_iso_spec_pred'(current_predicate(_)). '$lgt_iso_spec_pred'(asserta(_)). '$lgt_iso_spec_pred'(assertz(_)). '$lgt_iso_spec_pred'(retract(_)). '$lgt_iso_spec_pred'(abolish(_)). '$lgt_iso_spec_pred'(findall(_, _, _)). '$lgt_iso_spec_pred'(bagof(_, _, _)). '$lgt_iso_spec_pred'(setof(_, _, _)). '$lgt_iso_spec_pred'(current_input(_)). '$lgt_iso_spec_pred'(current_output(_)). '$lgt_iso_spec_pred'(set_input(_)). '$lgt_iso_spec_pred'(set_output(_)). '$lgt_iso_spec_pred'(open(_, _, _, _)). '$lgt_iso_spec_pred'(open(_, _, _)). '$lgt_iso_spec_pred'(close(_, _)). '$lgt_iso_spec_pred'(close(_)). '$lgt_iso_spec_pred'(flush_output(_)). '$lgt_iso_spec_pred'(flush_output). '$lgt_iso_spec_pred'(stream_property(_, _)). '$lgt_iso_spec_pred'(at_end_of_stream). '$lgt_iso_spec_pred'(at_end_of_stream(_)). '$lgt_iso_spec_pred'(set_stream_position(_, _)). '$lgt_iso_spec_pred'(get_char(_, _)). '$lgt_iso_spec_pred'(get_char(_)). '$lgt_iso_spec_pred'(get_code(_, _)). '$lgt_iso_spec_pred'(get_code(_)). '$lgt_iso_spec_pred'(peek_char(_, _)). '$lgt_iso_spec_pred'(peek_char(_)). '$lgt_iso_spec_pred'(peek_code(_, _)). '$lgt_iso_spec_pred'(peek_code(_)). '$lgt_iso_spec_pred'(put_char(_, _)). '$lgt_iso_spec_pred'(put_char(_)). '$lgt_iso_spec_pred'(put_code(_, _)). '$lgt_iso_spec_pred'(put_code(_)). '$lgt_iso_spec_pred'(nl). '$lgt_iso_spec_pred'(nl(_)). '$lgt_iso_spec_pred'(get_byte(_, _)). '$lgt_iso_spec_pred'(get_byte(_)). '$lgt_iso_spec_pred'(peek_byte(_, _)). '$lgt_iso_spec_pred'(peek_byte(_)). '$lgt_iso_spec_pred'(put_byte(_, _)). '$lgt_iso_spec_pred'(put_byte(_)). '$lgt_iso_spec_pred'(read_term(_, _, _)). '$lgt_iso_spec_pred'(read_term(_, _)). '$lgt_iso_spec_pred'(read(_)). '$lgt_iso_spec_pred'(read(_, _)). '$lgt_iso_spec_pred'(write_term(_, _, _)). '$lgt_iso_spec_pred'(write_term(_, _)). '$lgt_iso_spec_pred'(write(_)). '$lgt_iso_spec_pred'(write(_, _)). '$lgt_iso_spec_pred'(writeq(_)). '$lgt_iso_spec_pred'(writeq(_, _)). '$lgt_iso_spec_pred'(write_canonical(_)). '$lgt_iso_spec_pred'(write_canonical(_, _)). '$lgt_iso_spec_pred'(op(_, _, _)). '$lgt_iso_spec_pred'(current_op(_, _, _)). '$lgt_iso_spec_pred'(char_conversion(_, _)). '$lgt_iso_spec_pred'(current_char_conversion(_, _)). '$lgt_iso_spec_pred'(\+ _). '$lgt_iso_spec_pred'(once(_)). '$lgt_iso_spec_pred'(repeat). '$lgt_iso_spec_pred'(atom_length(_, _)). '$lgt_iso_spec_pred'(atom_concat(_, _, _)). '$lgt_iso_spec_pred'(sub_atom(_, _, _, _, _)). '$lgt_iso_spec_pred'(atom_chars(_, _)). '$lgt_iso_spec_pred'(atom_codes(_, _)). '$lgt_iso_spec_pred'(char_code(_, _)). '$lgt_iso_spec_pred'(number_chars(_, _)). '$lgt_iso_spec_pred'(number_codes(_, _)). '$lgt_iso_spec_pred'(set_prolog_flag(_, _)). '$lgt_iso_spec_pred'(current_prolog_flag(_, _)). '$lgt_iso_spec_pred'(halt). '$lgt_iso_spec_pred'(halt(_)). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Experimental multi-threading support % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % '$lgt_init_object_message_queue'(+atom) % % creates a message queue for an object given its prefix % (assume that any exception generated is due to the fact that the message % queue already exists, which may happen when reloading threaded objects; % there is no standard predicate for testing message queue existence) '$lgt_init_object_message_queue'(ObjPrefix) :- ( '$lgt_predicate_property'(message_queue_create(_, _), built_in) -> catch(message_queue_create(_, [alias(ObjPrefix)]), _, true) ; catch(message_queue_create(ObjPrefix), _, true) ). % '$lgt_start_runtime_dispatcher' % % starts up the dispatcher thread '$lgt_start_runtime_dispatcher' :- thread_create('$lgt_mt_obj_dispatcher', _, [alias(logtalk_dispatcher), detached(false)]). % '$lgt_mt_obj_dispatcher' % % multi-threading message dispatcher processing loop '$lgt_mt_obj_dispatcher' :- repeat, thread_get_message('$lgt_goal'(Queue, Goal, This, Self, Option)), ( Option == ignore -> % don't bother reporting goal success, failure, or exception thread_create(catch(Goal, _, true), _, [detached(true)]) ; Option = once(Tag) -> % make thread goal deterministic thread_create('$lgt_mt_det_goal'(Queue, Goal, This, Self, Tag), _, [detached(true)]) ; Option = call(Tag) -> % make thread goal non-deterministic thread_create('$lgt_mt_non_det_goal'(Queue, Goal, This, Self, Tag), _, [detached(false)]) ), fail. % '$lgt_mt_det_goal'(+atom, +callable, +object_identifier, +object_identifier, @nonvar) % % processes a deterministic message received by an object's message queue '$lgt_mt_det_goal'(Return, Goal, This, Self, Tag) :- thread_self(DetId), thread_send_message(Return, '$lgt_thread_id'(deterministic, Goal, This, Self, Tag, DetId)), % signal that the thread running the goal is ready: thread_send_message(Return, '$lgt_ready'(Goal, This, Self, once(Tag))), ( catch(Goal, Error, (thread_send_message(Return, '$lgt_reply'(Goal, This, Self, Tag, Error, DetId)), Flag = error)), ( var(Flag) -> thread_send_message(Return, '$lgt_reply'(Goal, This, Self, Tag, success, DetId)) ; true ) ; thread_send_message(Return, '$lgt_reply'(Goal, This, Self, Tag, failure, DetId)) ), thread_exit(true). % '$lgt_mt_non_det_goal'(+atom, +callable, +object_identifier, +object_identifier, @nonvar) % % processes a non-deterministic message received by an object's message queue '$lgt_mt_non_det_goal'(Return, Goal, This, Self, Tag) :- thread_self(NonDetId), thread_send_message(Return, '$lgt_thread_id'(non_deterministic, Goal, This, Self, Tag, NonDetId)), % signal that the thread running the goal is ready: thread_send_message(Return, '$lgt_ready'(Goal, This, Self, call(Tag))), ( catch(Goal, Error, (thread_send_message(Return, '$lgt_reply'(Goal, This, Self, Tag, Error, NonDetId)), Flag = error)), var(Flag), thread_send_message(Return, '$lgt_reply'(Goal, This, Self, Tag, success, NonDetId)), thread_get_message(Message), ( Message == '$lgt_next' -> fail % backtrack to the catch(Goal, ...) to try to find an alternative solution ; thread_exit(true) % otherwise assume Message = '$lgt_exit' and terminate thread ) ; nonvar(Flag), !, true ; thread_send_message(Return, '$lgt_reply'(Goal, This, Self, Tag, failure, NonDetId)) ). % '$lgt_mt_send_goal'(@callable, +object_identifier, +object_identifier, +object_identifier, +list) % % sends a goal to the dispatcher thread (this predicate is called from within categories) '$lgt_mt_send_goal'(Goal, Sender, This, Self, Option) :- '$lgt_current_object_'(This, Queue, _, _, _, _, _, _) -> '$lgt_mt_send_goal'(Queue, Goal, Sender, This, Self, Option). % '$lgt_mt_send_goal'(+message_queue, @callable, +object_identifier, +object_identifier, +object_identifier, +list) % % sends a goal to the dispatcher thread '$lgt_mt_send_goal'(Queue, Goal, Sender, This, Self, Option) :- ( thread_property(logtalk_dispatcher, status(running)) -> % ask the Logtalk dispatcher to create a new thread for proving the goal: thread_send_message(logtalk_dispatcher, '$lgt_goal'(Queue, Goal, This, Self, Option)), ( Option == ignore -> true ; % wait until the thread created for proving the goal is ready before proceeding: thread_get_message(Queue, '$lgt_ready'(Goal, This, Self, Option)) ) ; % something went terrible wrong with the dispatcher thread: throw(error(existence_error(logtalk_dispatcher, This), Goal, Sender)) ). % '$lgt_mt_peek_reply'(+callable, +object_identifier, +object_identifier, +object_identifier, @nonvar) % % peeks a reply to a goal sent to the senders object message queue (this predicate is called from within categories) '$lgt_mt_peek_reply'(Goal, Sender, This, Self, Tag) :- '$lgt_current_object_'(This, Queue, _, _, _, _, _, _) -> '$lgt_mt_peek_reply'(Queue, Goal, Sender, This, Self, Tag). % '$lgt_mt_peek_reply'(+atom, +callable, +object_identifier, +object_identifier, +object_identifier, @nonvar) % % peeks a reply to a goal sent to the senders object message queue '$lgt_mt_peek_reply'(Queue, Goal, _, This, Self, Tag) :- thread_peek_message(Queue, '$lgt_reply'(Goal, This, Self, Tag, _, _)). % '$lgt_mt_get_reply'(+callable, +object_identifier, +object_identifier, +object_identifier, @nonvar) % % gets a reply to a goal sent to the senders object message queue (this predicate is called from within categories) '$lgt_mt_get_reply'(Goal, Sender, This, Self, Tag) :- '$lgt_current_object_'(This, Queue, _, _, _, _, _, _) -> '$lgt_mt_get_reply'(Queue, Goal, Sender, This, Self, Tag). % '$lgt_mt_get_reply'(+atom, +callable, +object_identifier, +object_identifier, +object_identifier, @nonvar) % % gets a reply to a goal sent to the senders object message queue '$lgt_mt_get_reply'(Queue, Goal, Sender, This, Self, Tag) :- ( % first check if there is a thread running for proving the goal before proceeding: thread_peek_message(Queue, '$lgt_thread_id'(Type, Goal, This, Self, Tag, Id)) -> % answering thread exists; go ahead and retrieve the solution(s): thread_get_message(Queue, '$lgt_thread_id'(Type, Goal, This, Self, Tag, Id)), call_cleanup( '$lgt_mt_get_reply_aux'(Type, Queue, Goal, This, Self, Tag, Id), ( Type == non_deterministic -> ( thread_property(Id, status(running)) -> % if the thread is still running, it's suspended waiting catch(thread_send_message(Id, '$lgt_exit'), _, true) % for a request to an alternative proof; tell it to exit ; true ), thread_join(Id, _) ; true ) ) ; % answering thread does not exists; generate an exception (failing is not an option as it could simply mean goal failure) throw(error(existence_error(goal_thread, Goal), Sender)) ). '$lgt_mt_get_reply_aux'(deterministic, Queue, Goal, This, Self, Tag, Id) :- '$lgt_mt_det_reply'(Queue, Goal, This, Self, Tag, Id). '$lgt_mt_get_reply_aux'(non_deterministic, Queue, Goal, This, Self, Tag, Id) :- '$lgt_mt_non_det_reply'(Queue, Goal, This, Self, Tag, Id). % return the solution found: '$lgt_mt_det_reply'(Queue, Goal, This, Self, Tag, Id) :- thread_get_message(Queue, '$lgt_reply'(Reply, This, Self, Tag, Result, Id)), ( Result == success -> Goal = Reply ; Result == failure -> fail ; throw(Result) ). % return current solution; on backtracking, ask working thread for and get from it the next solution: '$lgt_mt_non_det_reply'(Queue, Goal, This, Self, Tag, Id) :- thread_get_message(Queue, '$lgt_reply'(Reply, This, Self, Tag, Result, Id)), ( Result == success -> Goal = Reply ; Result == failure -> !, fail ; throw(Result) ). '$lgt_mt_non_det_reply'(Queue, Goal, This, Self, Tag, Id) :- catch(thread_send_message(Id, '$lgt_next'), _, fail), '$lgt_mt_non_det_reply'(Queue, Goal, This, Self, Tag, Id). % '$lgt_mt_threaded_and_call'(+callable, +list(object_identifier), +thread_identifier, +object_identifier) % % proves a goal from a conjunction in a threaded/1 predicate call and sends the result % back to the message queue of the object containing the call '$lgt_mt_threaded_and_call'(TGoal, Tag, Id, Queue) :- thread_self(Id), ( catch(TGoal, Error, (thread_send_message(Queue, '$lgt_and_call'(Tag, Id, error(Error))), throw(Error))) -> thread_send_message(Queue, '$lgt_and_call'(Tag, Id, true(TGoal))) ; thread_send_message(Queue, '$lgt_and_call'(Tag, Id, fail)) ). % '$lgt_mt_threaded_and_exit'(+callable, +list(object_identifier), +object_identifier, +list) % % retrieves the result of proving a conjunction of goals using a threaded/1 predicate call '$lgt_mt_threaded_and_exit'(TGoals, Tag, Queue, Results) :- thread_get_message(Queue, '$lgt_and_call'(Tag, Id, Result)), ( Result = error(Error) -> '$lgt_mt_threaded_and_clean'(Tag, Queue), throw(Error) ; Result = true(Tgoal) -> '$lgt_mt_threaded_and_add_result'(Results, Id, Tgoal, Continue), ( Continue == false -> '$lgt_mt_threaded_and_clean'(Tag, Queue), '$lgt_mt_threaded_and_exit_unify'(TGoals, Results) ; '$lgt_mt_threaded_and_exit'(TGoals, Tag, Queue, Results) ) ; % Result == fail -> '$lgt_mt_threaded_and_clean'(Tag, Queue), fail ). % unifies the successful thread goal results with the original calls '$lgt_mt_threaded_and_exit_unify'((TGoal, TGoals), [id(_, TGoal)| Results]) :- !, '$lgt_mt_threaded_and_exit_unify'(TGoals, Results). '$lgt_mt_threaded_and_exit_unify'(TGoal, [id(_, TGoal)]). % aborts (if needed) and joins all threads, making sure no dangling results % are left on the object message queue '$lgt_mt_threaded_and_clean'([], _). '$lgt_mt_threaded_and_clean'([Id| Ids], Queue) :- catch(thread_signal(Id, thread_exit(abort)), _, true), ( thread_peek_message(Queue, '$lgt_and_call'(_, Id, _)) -> thread_get_message(Queue, '$lgt_and_call'(_, Id, _)) ; true ), thread_join(Id, _), '$lgt_mt_threaded_and_clean'(Ids, Queue). % adds the result of proving a goal and checks if all goals have succeeded: '$lgt_mt_threaded_and_add_result'([id(Id1, Result1)| Ids], Id2, Result2, Continue) :- ( Id1 == Id2 -> Result1 = Result2, ( var(Continue) -> '$lgt_mt_threaded_and_add_result'(Ids, Continue) ; true ) ; var(Result1) -> '$lgt_mt_threaded_and_add_result'(Ids, Id2, Result2, true) ; '$lgt_mt_threaded_and_add_result'(Ids, Id2, Result2, Continue) ). '$lgt_mt_threaded_and_add_result'([], false). '$lgt_mt_threaded_and_add_result'([id(_, Result)| Ids], Continue) :- ( var(Result) -> Continue = true ; '$lgt_mt_threaded_and_add_result'(Ids, Continue) ). % '$lgt_mt_threaded_or_call'(+callable, +list(object_identifier), +thread_identifier, +object_identifier) % % proves a goal from a disjunction in a threaded/1 predicate call and sends the result % back to the message queue of the object containing the call '$lgt_mt_threaded_or_call'(TGoal, Tag, Id, Queue) :- thread_self(Id), ( catch(TGoal, Error, (thread_send_message(Queue, '$lgt_or_call'(Tag, Id, error(Error))), throw(Error))) -> thread_send_message(Queue, '$lgt_or_call'(Tag, Id, true(TGoal))) ; thread_send_message(Queue, '$lgt_or_call'(Tag, Id, fail)) ). % '$lgt_mt_threaded_or_exit'(+callable, +list(object_identifier), +object_identifier, +list) % % retrieves the result of proving a disjunction of goals using a threaded/1 predicate call '$lgt_mt_threaded_or_exit'(TGoals, Tag, Queue, Results) :- thread_get_message(Queue, '$lgt_or_call'(Tag, Id, Result)), ( Result = error(Error) -> '$lgt_mt_threaded_or_clean'(Tag, Queue), throw(Error) ; Result = true(TGoal) -> '$lgt_mt_threaded_or_clean'(Tag, Queue), '$lgt_mt_threaded_or_exit_unify'(TGoals, Tag, Id, TGoal) ; '$lgt_mt_threaded_or_continue'(Results, Id) -> '$lgt_mt_threaded_or_exit'(TGoals, Tag, Queue, Results) ; '$lgt_mt_threaded_or_clean'(Tag, Queue) ). % unifies the successful thread goal result with the original call '$lgt_mt_threaded_or_exit_unify'((TGoal1; TGoals), [Id1| Ids], Id2, TGoal2) :- !, ( Id1 == Id2 -> TGoal1 = TGoal2 ; '$lgt_mt_threaded_or_exit_unify'(TGoals, Ids, Id2, TGoal2) ). '$lgt_mt_threaded_or_exit_unify'(TGoal, [Id], Id, TGoal). % aborts (if needed) and joins all threads, making sure no dangling results % are left on the object message queue '$lgt_mt_threaded_or_clean'([], _). '$lgt_mt_threaded_or_clean'([Id| Ids], Queue) :- catch(thread_signal(Id, thread_exit(abort)), _, true), ( thread_peek_message(Queue, '$lgt_or_call'(_, Id, _)) -> thread_get_message(Queue, '$lgt_or_call'(_, Id, _)) ; true ), thread_join(Id, _), '$lgt_mt_threaded_or_clean'(Ids, Queue). % checks if all goals have failed '$lgt_mt_threaded_or_continue'(Ids, Id) :- '$lgt_mt_threaded_or_continue'(Ids, _, Id). '$lgt_mt_threaded_or_continue'([id(Id1, Result)| Ids], Continue, Id2) :- ( Id1 == Id2 -> Result = fail, ( Continue == true -> true ; '$lgt_mt_threaded_or_continue'(Ids) ) ; var(Result) -> '$lgt_mt_threaded_or_continue'(Ids, true, Id2) ; '$lgt_mt_threaded_or_continue'(Ids, Continue, Id2) ). '$lgt_mt_threaded_or_continue'([id(_, Result)| Ids]) :- ( var(Result) -> true ; '$lgt_mt_threaded_or_continue'(Ids) ). % multi-threading tags '$lgt_threaded_tag_counter'(0). '$lgt_new_threaded_tag'(New) :- with_mutex('$lgt_threaded_tag', (retract('$lgt_threaded_tag_counter'(Old)), New is Old + 1, asserta('$lgt_threaded_tag_counter'(New)))). % create entity mutexes (called when loading an entity) '$lgt_create_mutexes'([]). '$lgt_create_mutexes'([Mutex| Mutexes]) :- ( '$lgt_predicate_property'(mutex_create(_, _), built_in) -> mutex_create(_, [alias(Mutex)]) ; mutex_create(Mutex) ), '$lgt_create_mutexes'(Mutexes). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % static binding supporting predicates % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% '$lgt_add_static_binding_cache_entry'(Entity) :- retractall('$lgt_static_binding_entity_'(Entity)), assertz('$lgt_static_binding_entity_'(Entity)). '$lgt_obj_static_binding_cache'(Obj, Pred, Sender, Call) :- ( '$lgt_obj_static_binding_cache_'(Obj, Pred, Sender, Call) -> true ; '$lgt_static_binding_entity_'(Obj), '$lgt_current_object_'(Obj, _, Dcl, Def, _, _, _, _), call_with_args(Dcl, Pred, p(p(p)), static, _, _, _, _, DclCtn), !, functor(Obj, ObjFunctor, ObjArity), functor(GObj, ObjFunctor, ObjArity), functor(Pred, PredFunctor, PredArity), functor(GPred, PredFunctor, PredArity), call_with_args(Def, GPred, Sender, GObj, GObj, GCall, DefCtn), !, '$lgt_safe_static_binding_paths'(GObj, DclCtn, DefCtn), assertz('$lgt_obj_static_binding_cache_'(GObj, GPred, Sender, GCall)), (Obj, Pred, Call) = (GObj, GPred, GCall) ). '$lgt_ctg_static_binding_cache'(Ctg, Pred, Sender, This, Self, Call) :- ( '$lgt_ctg_static_binding_cache_'(Ctg, Pred, Sender, This, Self, Call) -> true ; '$lgt_static_binding_entity_'(Ctg), '$lgt_current_category_'(Ctg, Prefix, _, _), Clause =.. [Prefix, Dcl, Def, _], call(Clause), call_with_args(Dcl, Pred, _, static, _, _, _, DclCtn), !, functor(Pred, PredFunctor, PredArity), functor(GPred, PredFunctor, PredArity), call_with_args(Def, GPred, Sender, This, Self, GCall, DefCtn), !, '$lgt_safe_static_binding_paths'(Ctg, DclCtn, DefCtn), assertz('$lgt_ctg_static_binding_cache_'(Ctg, GPred, Sender, This, Self, GCall)), (Pred, Call) = (GPred, GCall) ). '$lgt_safe_static_binding_paths'(_, _, _). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Logtalk startup messages (banner and default flags) % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% '$lgt_startup_message' :- '$lgt_default_flag'(startup_message, Flag), '$lgt_startup_message'(Flag). '$lgt_startup_message'(flags(Option)) :- '$lgt_banner', '$lgt_default_flags'(Option). '$lgt_startup_message'(banner) :- '$lgt_banner'. '$lgt_startup_message'(none). '$lgt_banner' :- current_logtalk_flag(version, version(Major, Minor, Patch)), nl, write('Logtalk '), write(Major), write('.'), write(Minor), write('.'), write(Patch), nl, write('Copyright (c) 1998-2007 Paulo Moura'), nl, nl. '$lgt_default_flags'(compact) :- write('Default lint compilation flags: '), nl, '$lgt_default_flag'(unknown, Unknown), write(' unknown: '), write(Unknown), '$lgt_default_flag'(misspelt, Misspelt), write(', misspelt: '), write(Misspelt), '$lgt_default_flag'(lgtredef, Lgtredef), write(', lgtredef: '), write(Lgtredef), '$lgt_default_flag'(plredef, Plredef), write(', plredef: '), write(Plredef), nl, '$lgt_default_flag'(portability, Portability), write(' portability: '), write(Portability), '$lgt_default_flag'(singletons, Singletons), write(', singletons: '), write(Singletons), '$lgt_default_flag'(underscore_variables, Underscore), write(', underscore_variables: '), write(Underscore), nl, write('Default documenting compilation flags:'), nl, '$lgt_default_flag'(xmldocs, XMLDocs), write(' xmldocs: '), write(XMLDocs), '$lgt_default_flag'(xmldir, XMLDir), write(', xmldir: '), write(XMLDir), '$lgt_default_flag'(xmlspec, XMLSpec), write(', xmlspec: '), write(XMLSpec), '$lgt_default_flag'(xmlsref, XMLSRef), write(', xmlsref: '), write(XMLSRef), '$lgt_default_flag'(xslfile, XSLFile), write(', xslfile: '), write(XSLFile), nl, write('Other default compilation flags:'), nl, '$lgt_default_flag'(report, Report), write(' report: '), write(Report), '$lgt_default_flag'(code_prefix, Code), write(', code_prefix: '), writeq(Code), '$lgt_default_flag'(debug, Debug), write(', debug: '), writeq(Debug), '$lgt_default_flag'(smart_compilation, Smart), write(', smart_compilation: '), write(Smart), '$lgt_default_flag'(reload, Reload), write(', reload: '), write(Reload), nl, '$lgt_default_flag'(events, Events), write(' events: '), write(Events), ( '$lgt_default_flag'(hook, Hook) -> true ; Hook = '(none defined)' ), write(', hook: '), write(Hook), '$lgt_default_flag'(tmpdir, TmpDir), write(', tmpdir: '), write(TmpDir), nl, write('Read-only compilation flags:'), '$lgt_default_flag'(break_predicate, Break), write(' break_predicate: '), write(Break), '$lgt_default_flag'(startup_message, Startup), write(', startup_message: '), write(Startup), nl, '$lgt_default_flag'(altdirs, Altdirs), write(' altdirs: '), write(Altdirs), '$lgt_default_flag'(context_switching_calls, ContextCalls), write(' context_switching_calls: '), write(ContextCalls), '$lgt_default_flag'(encoding_directive, Encodings), write(', encoding_directive: '), write(Encodings), '$lgt_default_flag'(threads, Threads), write(', threads: '), write(Threads), nl, nl. '$lgt_default_flags'(verbose) :- write('Default lint compilation flags:'), nl, '$lgt_default_flag'(unknown, Unknown), write(' Unknown entities (unknown): '), write(Unknown), nl, '$lgt_default_flag'(misspelt, Misspelt), write(' Misspelt predicate calls (misspelt): '), write(Misspelt), nl, '$lgt_default_flag'(lgtredef, Lgtredef), write(' Logtalk built-in predicates redefinition (lgtredef): '), write(Lgtredef), nl, '$lgt_default_flag'(plredef, Plredef), write(' Prolog built-in predicates redefinition (plredef): '), write(Plredef), nl, '$lgt_default_flag'(portability, Portability), write(' Non portable calls (portability): '), write(Portability), nl, '$lgt_default_flag'(singletons, Singletons), write(' Singletons variables (singletons): '), write(Singletons), nl, '$lgt_default_flag'(underscore_variables, Underscore), write(' Underscore variables interpretation (underscore_variables): '), write(Underscore), nl, write('Default documenting compilation flags:'), nl, '$lgt_default_flag'(xmldocs, XMLDocs), write(' XML documenting files (xmldocs): '), write(XMLDocs), nl, '$lgt_default_flag'(xmldir, XMLDir), write(' XML documenting files directory (xmldir): '), write(XMLDir), nl, '$lgt_default_flag'(xmlspec, XMLSpec), write(' XML specification file (xmlspec): '), write(XMLSpec), nl, '$lgt_default_flag'(xmlsref, XMLSRef), write(' XML specification reference (xmlsref): '), write(XMLSRef), nl, '$lgt_default_flag'(xslfile, XSLFile), write(' XSL stylesheet file (xslfile): '), write(XSLFile), nl, write('Other default compilation flags:'), nl, '$lgt_default_flag'(report, Report), write(' Compilation report (report): '), write(Report), nl, '$lgt_default_flag'(code_prefix, Code), write(' Compiled code functors prefix (code_prefix): '), writeq(Code), nl, '$lgt_default_flag'(debug, Debug), write(' Compile entities in debug mode (debug): '), writeq(Debug), nl, '$lgt_default_flag'(reload, Reload), write(' Reloading of already loaded source files (reload): '), write(Reload), nl, '$lgt_default_flag'(smart_compilation, Smart), write(' Smart compilation (smart_compilation): '), write(Smart), nl, '$lgt_default_flag'(events, Events), write(' Event-driven programming support (events): '), write(Events), nl, ( '$lgt_default_flag'(hook, Hook) -> true ; Hook = '(none defined)' ), write(' Compiler hook object and hook predicate functor: '), write(Hook), nl, '$lgt_default_flag'(tmpdir, TmpDir), write(' Directory for compiler generated temporary files (tmpdir): '), write(TmpDir), nl, write('Read-only compilation flags:'), nl, '$lgt_default_flag'(break_predicate, Break), write(' Support for break/0 predicate (break_predicate): '), write(Break), nl, '$lgt_default_flag'(startup_message, Startup), write(' Startup message (startup_message): '), write(Startup), nl, '$lgt_default_flag'(altdirs, Altdirs), write(' Alternative compilation directories (altdirs): '), write(Altdirs), nl, '$lgt_default_flag'(context_switching_calls, ContextCalls), write(' Context-switching calls (context_switching_calls): '), write(ContextCalls), nl, '$lgt_default_flag'(encoding_directive, Encodings), write(' Support for encoding/1 directive (encoding_directive): '), write(Encodings), nl, '$lgt_default_flag'(threads, Threads), write(' Multi-threading programming support (threads): '), write(Threads), nl, nl. % '$lgt_assert_default_hook_goal' % % asserts the compiler hook goal specified on the config file '$lgt_assert_default_hook_goal' :- ( '$lgt_default_flag'(hook, Hook) -> '$lgt_compile_hook'(Hook) ; true ). % '$lgt_start_runtime_threading' % % cretes the default "user" runtime thread when running on % Prolog compilers supporting multi-threading programming '$lgt_start_runtime_threading' :- ( '$lgt_default_flag'(threads, on) -> '$lgt_current_object_'(user, Prefix, _, _, _, _, _, _), '$lgt_init_object_message_queue'(Prefix), '$lgt_start_runtime_dispatcher', ( '$lgt_predicate_property'(mutex_create(_, _), built_in) -> mutex_create(_, [alias('$lgt_threaded_tag')]) ; mutex_create('$lgt_threaded_tag') ) ; true ). :- initialization(('$lgt_startup_message', '$lgt_assert_default_hook_goal', '$lgt_start_runtime_threading')). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % end! % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%