%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % core compiler and runtime % % This file is part of Logtalk % SPDX-FileCopyrightText: 1998-2024 Paulo Moura % SPDX-License-Identifier: Apache-2.0 % % Licensed under the Apache License, Version 2.0 (the "License"); % you may not use this file except in compliance with the License. % You may obtain a copy of the License at % % http://www.apache.org/licenses/LICENSE-2.0 % % Unless required by applicable law or agreed to in writing, software % distributed under the License is distributed on an "AS IS" BASIS, % WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. % See the License for the specific language governing permissions and % limitations under the License. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % operator declarations % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % message-sending and super call operators % message-sending to an explicit object :- op(600, xfy, ::). % message-sending to "self" :- op(600, fy, ::). % "super" call (calls an inherited or imported method definition) :- op(600, fy, ^^). % mode operators % input argument (instantiated); ISO Prolog standard operator :- op(200, fy, (+)). % input/output argument :- op(200, fy, (?)). % input argument (not modified by the call) :- op(200, fy, (@)). % output argument (not instantiated); ISO Prolog standard operator :- op(200, fy, (-)). % ground argument :- op(200, fy, ++). % unbound argument (typically when returning an opaque term) :- op(200, fy, --). % bitwise left-shift operator (used for context-switching calls) % some backend Prolog compilers don't declare this ISO Prolog standard operator! :- op(400, yfx, <<). % bitwise right-shift operator (used for lambda expressions) % some backend Prolog compilers don't declare this ISO Prolog standard operator! :- op(400, yfx, >>). % predicate alias operator (alternative to the ::/2 or :/2 operators depending on the context) % first introduced in SWI-Prolog and YAP also for defining aliases to module predicates :- op(700, xfx, as). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % runtime directives (bookkeeping tables) % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % tables of defined events and monitors % '$lgt_before_event_'(Obj, Msg, Sender, Monitor, Call) :- dynamic('$lgt_before_event_'/5). % '$lgt_after_event_'(Obj, Msg, Sender, Monitor, Call) :- dynamic('$lgt_after_event_'/5). % tables of loaded entities, entity and predicate properties, plus entity relations % '$lgt_current_protocol_'(Ptc, Prefix, Dcl, Rnm, Flags) :- multifile('$lgt_current_protocol_'/5). :- dynamic('$lgt_current_protocol_'/5). % '$lgt_current_category_'(Ctg, Prefix, Dcl, Def, Rnm, Flags) :- multifile('$lgt_current_category_'/6). :- dynamic('$lgt_current_category_'/6). % '$lgt_current_object_'(Obj, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Rnm, Flags) :- multifile('$lgt_current_object_'/11). :- dynamic('$lgt_current_object_'/11). % '$lgt_entity_property_'(Entity, Property) :- multifile('$lgt_entity_property_'/2). :- dynamic('$lgt_entity_property_'/2). % '$lgt_predicate_property_'(Entity, Functor/Arity, Property) :- multifile('$lgt_predicate_property_'/3). :- dynamic('$lgt_predicate_property_'/3). % '$lgt_implements_protocol_'(ObjOrCtg, Ptc, Scope) :- multifile('$lgt_implements_protocol_'/3). :- dynamic('$lgt_implements_protocol_'/3). % '$lgt_imports_category_'(Obj, Ctg, Scope) :- multifile('$lgt_imports_category_'/3). :- dynamic('$lgt_imports_category_'/3). % '$lgt_instantiates_class_'(Instance, Class, Scope) :- multifile('$lgt_instantiates_class_'/3). :- dynamic('$lgt_instantiates_class_'/3). % '$lgt_specializes_class_'(Class, Superclass, Scope) :- multifile('$lgt_specializes_class_'/3). :- dynamic('$lgt_specializes_class_'/3). % '$lgt_extends_category_'(Ctg, ExtCtg, Scope) :- multifile('$lgt_extends_category_'/3). :- dynamic('$lgt_extends_category_'/3). % '$lgt_extends_object_'(Prototype, Parent, Scope) :- multifile('$lgt_extends_object_'/3). :- dynamic('$lgt_extends_object_'/3). % '$lgt_extends_protocol_'(Ptc, ExtPtc, Scope) :- multifile('$lgt_extends_protocol_'/3). :- dynamic('$lgt_extends_protocol_'/3). % '$lgt_complemented_object_'(Obj, Ctg, Dcl, Def, Rnm) :- dynamic('$lgt_complemented_object_'/5). % '$lgt_uses_predicate_'(Entity, Obj, Original, Alias, Ctx) :- multifile('$lgt_uses_predicate_'/5). % '$lgt_use_module_predicate_'(Entity, Module, Original, Alias, Ctx) :- multifile('$lgt_use_module_predicate_'/5). % table of loaded files % '$lgt_loaded_file_'(Basename, Directory, Mode, Flags, TextProperties, ObjectFile, TimeStamp) :- multifile('$lgt_loaded_file_'/7). :- dynamic('$lgt_loaded_file_'/7). % '$lgt_included_file_'(File, MainBasename, MainDirectory, TimeStamp) :- multifile('$lgt_included_file_'/4). :- dynamic('$lgt_included_file_'/4). % '$lgt_failed_file_'(SourceFile) :- dynamic('$lgt_failed_file_'/1). % '$lgt_parent_file_'(SourceFile, ParentSourceFile) :- dynamic('$lgt_parent_file_'/2). % '$lgt_file_loading_stack_'(SourceFile, Directory) :- dynamic('$lgt_file_loading_stack_'/2). % runtime flag values % '$lgt_current_flag_'(Name, Value) :- dynamic('$lgt_current_flag_'/2). % static binding caches % '$lgt_send_to_obj_static_binding_'(Obj, Pred, ExCtx, Call) :- dynamic('$lgt_send_to_obj_static_binding_'/4). % dynamic binding lookup caches for messages and super calls % '$lgt_send_to_obj_'(Obj, Pred, ExCtx) :- dynamic('$lgt_send_to_obj_'/3). % '$lgt_send_to_obj_ne_'(Obj, Pred, ExCtx) :- dynamic('$lgt_send_to_obj_ne_'/3). % '$lgt_send_to_self_'(Obj, Pred, ExCtx) :- dynamic('$lgt_send_to_self_'/3). % '$lgt_obj_super_call_'(Super, Pred, ExCtx) :- dynamic('$lgt_obj_super_call_'/3). % '$lgt_ctg_super_call_'(Ctg, Pred, ExCtx) :- dynamic('$lgt_ctg_super_call_'/3). % dynamic binding lookup cache for asserting and retracting dynamic facts % '$lgt_db_lookup_cache_'(Obj, Fact, Sender, TFact, UpdateData) :- dynamic('$lgt_db_lookup_cache_'/5). % table of library paths % logtalk_library_path(Library, Path) :- multifile(logtalk_library_path/2). :- dynamic(logtalk_library_path/2). % extension point for logtalk_make/1 % logtalk_make_target_action(Target) :- multifile(logtalk_make_target_action/1). :- dynamic(logtalk_make_target_action/1). % extension point for the linter % logtalk_linter_hook(Goal, Flag, File, Lines, Type, Entity, Warning) :- multifile(logtalk_linter_hook/7). % term- and goal-expansion default compiler hooks % '$lgt_hook_term_expansion_'(Term, ExpandedTerms) :- dynamic('$lgt_hook_term_expansion_'/2). % '$lgt_hook_goal_expansion_'(Goal, ExpandedGoal) :- dynamic('$lgt_hook_goal_expansion_'/2). % engines % '$lgt_current_engine_'(Object, Engine, TermQueue, Id) :- dynamic('$lgt_current_engine_'/4). % counters % '$lgt_dynamic_entity_counter_'(Kind, Base, Count) :- dynamic('$lgt_dynamic_entity_counter_'/3). % '$lgt_threaded_tag_counter_'(Tag) :- dynamic('$lgt_threaded_tag_counter_'/1). % '$lgt_threaded_engine_tag_counter_'(Tag) :- dynamic('$lgt_threaded_engine_tag_counter_'/1). % debugging hook predicates :- multifile('$logtalk#0.trace_event#2'/3). :- dynamic('$logtalk#0.trace_event#2'/3). :- multifile('$logtalk#0.debug_handler#1'/2). :- multifile('$logtalk#0.debug_handler#3'/4). % internal initialization flags :- dynamic('$lgt_built_in_entities_loaded_'/0). :- dynamic('$lgt_runtime_initialization_completed_'/0). % user-defined flags % '$lgt_user_defined_flag_'(Flag, Access, Type) :- dynamic('$lgt_user_defined_flag_'/3). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % compiler directives % % (used for source file compilation and runtime creation of new entities) % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % '$lgt_pp_file_compiler_flag_'(Name, Value) :- dynamic('$lgt_pp_file_compiler_flag_'/2). % '$lgt_pp_entity_compiler_flag_'(Name, Value) :- dynamic('$lgt_pp_entity_compiler_flag_'/2). % '$lgt_pp_dcl_'(Clause) :- dynamic('$lgt_pp_dcl_'/1). % '$lgt_pp_def_'(Clause) :- dynamic('$lgt_pp_def_'/1). % '$lgt_pp_ddef_'(Clause) :- dynamic('$lgt_pp_ddef_'/1). % '$lgt_pp_super_'(Clause) :- dynamic('$lgt_pp_super_'/1). % '$lgt_pp_synchronized_'(Head, Mutex, File, Lines) :- dynamic('$lgt_pp_synchronized_'/4). % '$lgt_pp_predicate_mutex_counter_'(Count) :- dynamic('$lgt_pp_predicate_mutex_counter_'/1). % '$lgt_pp_dynamic_'(Head, Original, File, Lines) :- dynamic('$lgt_pp_dynamic_'/4). % '$lgt_pp_discontiguous_'(Head, File, Lines) :- dynamic('$lgt_pp_discontiguous_'/3). % '$lgt_pp_mode_'(Mode, Determinism, File, Lines) :- dynamic('$lgt_pp_mode_'/4). % '$lgt_pp_public_'(Functor, Arity, File, Lines) :- dynamic('$lgt_pp_public_'/4). % '$lgt_pp_protected_'(Functor, Arity, File, Lines) :- dynamic('$lgt_pp_protected_'/4). % '$lgt_pp_private_'(Functor, Arity, File, Lines) :- dynamic('$lgt_pp_private_'/4). % '$lgt_pp_meta_predicate_'(PredTemplate, MetaTemplate, File, Lines) :- dynamic('$lgt_pp_meta_predicate_'/4). % '$lgt_pp_predicate_alias_'(Entity, Pred, Alias, NonTerminalFlag, File, Lines) :- dynamic('$lgt_pp_predicate_alias_'/6). % '$lgt_pp_non_terminal_'(Functor, Arity, ExtArity) :- dynamic('$lgt_pp_non_terminal_'/3). % '$lgt_pp_multifile_'(Head, Original, File, Lines) :- dynamic('$lgt_pp_multifile_'/4). % '$lgt_pp_coinductive_'(Head, TestHead, HeadExCtx, TCHead, BodyExCtx, THead, DHead, File, Lines) :- dynamic('$lgt_pp_coinductive_'/9). % '$lgt_pp_coinductive_head_'(Head, HeadExCtx, TCHead) :- dynamic('$lgt_pp_coinductive_head_'/3). % '$lgt_pp_object_'(Obj, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Rnm, Flags) :- dynamic('$lgt_pp_object_'/11). % '$lgt_pp_category_'(Ctg, Prefix, Dcl, Def, Rnm, Flags) :- dynamic('$lgt_pp_category_'/6). % '$lgt_pp_protocol_'(Ptc, Prefix, Dcl, Rnm, Flags) :- dynamic('$lgt_pp_protocol_'/5). % '$lgt_pp_entity_'(Type, Entity, Prefix) :- dynamic('$lgt_pp_entity_'/3). % '$lgt_pp_module_'(Module) :- dynamic('$lgt_pp_module_'/1). % '$lgt_pp_entity_lines_'(Entity, Lines) :- dynamic('$lgt_pp_entity_lines_'/2). % '$lgt_pp_parameter_variables_'(ParameterVariables) :- dynamic('$lgt_pp_parameter_variables_'/1). % '$lgt_pp_object_alias_'(Obj, Alias, CompilationContext, File, Lines) :- dynamic('$lgt_pp_object_alias_'/5). % '$lgt_pp_module_alias_'(Module, Alias, CompilationContext, File, Lines) :- dynamic('$lgt_pp_module_alias_'/5). % '$lgt_pp_uses_predicate_'(Obj, Predicate, Alias, CompilationContext, File, Lines) :- dynamic('$lgt_pp_uses_predicate_'/6). % '$lgt_pp_uses_non_terminal_'(Obj, NonTerminal, NonTerminalAlias, Predicate, PredicateAlias, CompilationContext, File, Lines) :- dynamic('$lgt_pp_uses_non_terminal_'/8). % '$lgt_pp_use_module_predicate_'(Module, Predicate, Alias, CompilationContext, File, Lines) :- dynamic('$lgt_pp_use_module_predicate_'/6). % '$lgt_pp_use_module_non_terminal_'(Module, NonTerminal, NonTerminalAlias, Predicate, PredicateAlias, CompilationContext, File, Lines) :- dynamic('$lgt_pp_use_module_non_terminal_'/8). % '$lgt_pp_entity_info_'(List, File, Lines) :- dynamic('$lgt_pp_entity_info_'/3). % '$lgt_pp_predicate_info_'(Predicate, List, File, Lines) :- dynamic('$lgt_pp_predicate_info_'/4). % '$lgt_pp_implemented_protocol_'(Ptc, ObjOrCtg, Prefix, Dcl, Scope) :- dynamic('$lgt_pp_implemented_protocol_'/5). % '$lgt_pp_imported_category_'(Ctg, Obj, Prefix, Dcl, Def, Scope) :- dynamic('$lgt_pp_imported_category_'/6). % '$lgt_pp_extended_object_'(Parent, Obj, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Scope) :- dynamic('$lgt_pp_extended_object_'/11). % '$lgt_pp_instantiated_class_'(Class, Obj, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Scope) :- dynamic('$lgt_pp_instantiated_class_'/11). % '$lgt_pp_specialized_class_'(Superclass, Class, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Scope) :- dynamic('$lgt_pp_specialized_class_'/11). % '$lgt_pp_extended_protocol_'(ExtPtc, Ptc, Prefix, Dcl, Scope) :- dynamic('$lgt_pp_extended_protocol_'/5). % '$lgt_pp_extended_category_'(ExtCtg, Ctg, Prefix, Dcl, Def, Scope) :- dynamic('$lgt_pp_extended_category_'/6). % '$lgt_pp_complemented_object_'(Obj, Ctg, Dcl, Def, Rnm) :- dynamic('$lgt_pp_complemented_object_'/5). % '$lgt_pp_file_initialization_'(Goal, Lines) :- dynamic('$lgt_pp_file_initialization_'/2). % '$lgt_pp_file_entity_initialization_'(Object, Goal, Lines) :- dynamic('$lgt_pp_file_entity_initialization_'/3). % '$lgt_pp_object_initialization_'(Goal, SourceData, Lines) :- dynamic('$lgt_pp_object_initialization_'/3). % '$lgt_pp_final_object_initialization_'(Goal, Lines) :- dynamic('$lgt_pp_final_object_initialization_'/2). % '$lgt_pp_entity_meta_directive_'(Directive, SourceData, Lines) :- dynamic('$lgt_pp_entity_meta_directive_'/3). % '$lgt_pp_redefined_built_in_'(Head, ExCtx, THead) :- dynamic('$lgt_pp_redefined_built_in_'/3). % '$lgt_pp_directive_'(Directive) :- dynamic('$lgt_pp_directive_'/1). % '$lgt_pp_prolog_term_'(Term, Lines) :- dynamic('$lgt_pp_prolog_term_'/2). % '$lgt_pp_entity_term_'(Term, SourceData, Lines) :- dynamic('$lgt_pp_entity_term_'/3). % '$lgt_pp_final_entity_term_'(Term, Lines) :- dynamic('$lgt_pp_final_entity_term_'/2). % '$lgt_pp_entity_aux_clause_'(Clause) :- dynamic('$lgt_pp_entity_aux_clause_'/1). % '$lgt_pp_final_entity_aux_clause_'(Clause) :- dynamic('$lgt_pp_final_entity_aux_clause_'/1). % '$lgt_pp_number_of_clauses_rules_'(Functor, Arity, NumberOfClauses, NumberOfRules) :- dynamic('$lgt_pp_number_of_clauses_rules_'/4). % '$lgt_pp_number_of_clauses_rules_'(Other, Functor, Arity, NumberOfClauses, NumberOfRules) :- dynamic('$lgt_pp_number_of_clauses_rules_'/5). % '$lgt_pp_predicate_declaration_location_'(Functor, Arity, File, Lines) :- dynamic('$lgt_pp_predicate_declaration_location_'/4). % '$lgt_pp_predicate_definition_location_'(Functor, Arity, File, Lines) :- dynamic('$lgt_pp_predicate_definition_location_'/4). % '$lgt_pp_defines_predicate_'(Head, Functor/Arity, ExCtx, THead, Mode, Origin) :- dynamic('$lgt_pp_defines_predicate_'/6). % '$lgt_pp_inline_predicate_'(Functor/Arity) :- dynamic('$lgt_pp_inline_predicate_'/1). % '$lgt_pp_predicate_definition_location_'(Other, Functor, Arity, File, Lines) :- dynamic('$lgt_pp_predicate_definition_location_'/5). % '$lgt_pp_non_tail_recursive_predicate_'(Functor, Arity, File, Lines) :- dynamic('$lgt_pp_non_tail_recursive_predicate_'/4). % '$lgt_pp_predicate_recursive_calls_'(Functor, Arity, Counter) :- dynamic('$lgt_pp_predicate_recursive_calls_'/3). % '$lgt_pp_calls_predicate_'(Functor/Arity, TFunctor/TArity, HeadFunctor/HeadArity, File, Lines) :- dynamic('$lgt_pp_calls_predicate_'/5). % '$lgt_pp_calls_self_predicate_'(Functor/Arity, HeadFunctor/HeadArity, File, Lines) :- dynamic('$lgt_pp_calls_self_predicate_'/4). % '$lgt_pp_calls_super_predicate_'(Functor/Arity, HeadFunctor/HeadArity, File, Lines) :- dynamic('$lgt_pp_calls_super_predicate_'/4). % '$lgt_pp_updates_predicate_'(Dynamic, HeadFunctor/HeadArity, File, Lines) :- dynamic('$lgt_pp_updates_predicate_'/4). % '$lgt_pp_non_portable_predicate_'(Head, File, Lines) :- dynamic('$lgt_pp_non_portable_predicate_'/3). % '$lgt_pp_non_portable_function_'(Function, File, Lines) :- dynamic('$lgt_pp_non_portable_function_'/3). % '$lgt_pp_missing_function_'(Function, File, Lines) :- dynamic('$lgt_pp_missing_function_'/3). % '$lgt_pp_missing_meta_predicate_directive_'(Head, File, Lines) :- dynamic('$lgt_pp_missing_meta_predicate_directive_'/3). % '$lgt_pp_missing_dynamic_directive_'(Head, File, Lines) :- dynamic('$lgt_pp_missing_dynamic_directive_'/3). % '$lgt_pp_missing_discontiguous_directive_'(Head, File, Lines) :- dynamic('$lgt_pp_missing_discontiguous_directive_'/3). % '$lgt_pp_missing_multifile_directive_'(PI, File, Lines) :- dynamic('$lgt_pp_missing_multifile_directive_'/3). % '$lgt_pp_missing_use_module_directive_'(Module, Functor/Arity) :- dynamic('$lgt_pp_missing_use_module_directive_'/2). % '$lgt_pp_previous_predicate_'(Head, Mode) :- dynamic('$lgt_pp_previous_predicate_'/2). % '$lgt_pp_defines_non_terminal_'(Functor, Arity, ExtArity) :- dynamic('$lgt_pp_defines_non_terminal_'/3). % '$lgt_pp_calls_non_terminal_'(Functor, Arity, ExtArity, Lines) :- dynamic('$lgt_pp_calls_non_terminal_'/4). % '$lgt_pp_referenced_object_'(Object, File, Lines) :- dynamic('$lgt_pp_referenced_object_'/3). % '$lgt_pp_referenced_protocol_'(Protocol, File, Lines) :- dynamic('$lgt_pp_referenced_protocol_'/3). % '$lgt_pp_referenced_category_'(Category, File, Lines) :- dynamic('$lgt_pp_referenced_category_'/3). % '$lgt_pp_referenced_module_'(Module, File, Lines) :- dynamic('$lgt_pp_referenced_module_'/3). % '$lgt_pp_referenced_object_message_'(Object, Functor/Arity, AliasFunctor/AliasArity, HeadFunctor/HeadArity, File, Lines) :- dynamic('$lgt_pp_referenced_object_message_'/6). % '$lgt_pp_referenced_module_predicate_'(Module, Functor/Arity, AliasFunctor/AliasArity, HeadFunctor/HeadArity, File, Lines) :- dynamic('$lgt_pp_referenced_module_predicate_'/6). % '$lgt_pp_global_operator_'(Priority, Specifier, Operator) :- dynamic('$lgt_pp_global_operator_'/3). % '$lgt_pp_file_operator_'(Priority, Specifier, Operator) :- dynamic('$lgt_pp_file_operator_'/3). % '$lgt_pp_entity_operator_'(Priority, Specifier, Operator, Scope, File, Lines) :- dynamic('$lgt_pp_entity_operator_'/6). % '$lgt_pp_warnings_top_goal_'(Goal) :- dynamic('$lgt_pp_warnings_top_goal_'/1). % '$lgt_pp_compiling_warnings_counter_'(Counter) :- dynamic('$lgt_pp_compiling_warnings_counter_'/1). % '$lgt_pp_loading_warnings_counter_'(Counter) :- dynamic('$lgt_pp_loading_warnings_counter_'/1). % '$lgt_pp_hook_term_expansion_'(Term, Terms) :- dynamic('$lgt_pp_hook_term_expansion_'/2). % '$lgt_pp_hook_goal_expansion_'(Goal, ExpandedGoal) :- dynamic('$lgt_pp_hook_goal_expansion_'/2). % '$lgt_pp_built_in_' :- dynamic('$lgt_pp_built_in_'/0). % '$lgt_pp_dynamic_' :- dynamic('$lgt_pp_dynamic_'/0). % '$lgt_pp_threaded_' :- dynamic('$lgt_pp_threaded_'/0). % '$lgt_pp_file_encoding_'(SourceFile, LogtalkEncoding, PrologEncoding, Line) :- dynamic('$lgt_pp_file_encoding_'/4). % '$lgt_pp_file_bom_'(SourceFile, BOM) :- dynamic('$lgt_pp_file_bom_'/2). % '$lgt_pp_file_paths_flags_'(Basename, Directory, SourceFile, ObjectFile, Flags) :- dynamic('$lgt_pp_file_paths_flags_'/5). % '$lgt_pp_runtime_clause_'(Clause) :- dynamic('$lgt_pp_runtime_clause_'/1). % '$lgt_pp_cc_if_found_'(Goal) :- dynamic('$lgt_pp_cc_if_found_'/1). % '$lgt_pp_cc_skipping_' :- dynamic('$lgt_pp_cc_skipping_'/0). % '$lgt_pp_cc_mode_'(Action) :- dynamic('$lgt_pp_cc_mode_'/1). % '$lgt_pp_term_source_data_'(Term, VariableNames, Singletons, File, Lines) :- dynamic('$lgt_pp_term_source_data_'/5). % '$lgt_pp_aux_predicate_counter_'(Counter) :- dynamic('$lgt_pp_aux_predicate_counter_'/1). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % top-level interpreter versions of the message-sending and context % switching call control constructs % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % top-level interpreter message-sending calls Obj::Pred :- var(Obj), '$lgt_execution_context'(ExCtx, user, user, user, Obj, [], []), throw(error(instantiation_error, logtalk(Obj::Pred, ExCtx))). {Obj}::Pred :- !, % use current default value of the "events" flag '$lgt_current_flag_'(events, Events), '$lgt_comp_ctx'(Ctx, _, _, user, user, user, Obj, _, [], [], ExCtx, runtime, [], _, _), '$lgt_execution_context'(ExCtx, user, user, user, Obj, [], []), catch( '$lgt_compile_message_to_object'(Pred, {Obj}, Call, Events, Ctx), Error, '$lgt_runtime_error_handler'(error(Error, logtalk({Obj}::Pred, ExCtx))) ), ( nonvar(Obj), '$lgt_current_object_'(Obj, _, _, _, _, _, _, _, _, _, Flags), Flags /\ 512 =:= 512 -> % object compiled in debug mode catch('$lgt_debug'(top_goal({Obj}::Pred, Call), ExCtx), Error, '$lgt_runtime_error_handler'(Error)) ; % object not compiled in debug mode or non-existing object or invalid object identifier catch(Call, Error, '$lgt_runtime_error_handler'(Error)) ). Obj::Pred :- % use current default value of the "events" flag '$lgt_current_flag_'(events, Events), '$lgt_comp_ctx'(Ctx, _, _, user, user, user, Obj, _, [], [], ExCtx, runtime, [], _, _), '$lgt_execution_context'(ExCtx, user, user, user, Obj, [], []), catch( '$lgt_compile_message_to_object'(Pred, Obj, Call, Events, Ctx), Error, '$lgt_runtime_error_handler'(error(Error, logtalk(Obj::Pred, ExCtx))) ), ( '$lgt_current_object_'(Obj, _, _, _, _, _, _, _, _, _, Flags), Flags /\ 512 =:= 512 -> % object compiled in debug mode catch('$lgt_debug'(top_goal(Obj::Pred, Call), ExCtx), Error, '$lgt_runtime_error_handler'(Error)) ; % object not compiled in debug mode or non-existing object catch(Call, Error, '$lgt_runtime_error_handler'(Error)) ). % top-level interpreter context-switch calls (debugging control construct) Obj< % object compiled in debug mode catch('$lgt_debug'(top_goal({Obj}< % object compiled in debug mode catch('$lgt_debug'(top_goal(Obj< '$lgt_runtime_normalized_error_handler'(NormalizedError) ; '$lgt_runtime_normalized_error_handler'(Error) ). '$lgt_runtime_normalized_error_handler'(error(existence_error(procedure, ':'(Module,PI)), Context)) :- % assuming we're running with a backend compiler supporting modules, % check that the error is the context of the module where Logtalk is loaded atom(Module), '$lgt_user_module_qualification'(xx, ':'(Module,xx)), !, '$lgt_runtime_normalized_error_handler'(error(existence_error(procedure, PI), Context)). '$lgt_runtime_normalized_error_handler'(error(existence_error(procedure, TFunctor/6), _)) :- ( atom_concat(Prefix, '_idcl', TFunctor) -> true ; atom_concat(Prefix, '_dcl', TFunctor) ), '$lgt_prefix_to_entity'(Prefix, Obj), ( '$lgt_instantiates_class_'(_, Obj, _) ; '$lgt_specializes_class_'(_, Obj, _) ; '$lgt_extends_object_'(_, Obj, _) ; '$lgt_complemented_object_'(Obj, _, _, _, _) ), \+ '$lgt_current_object_'(Obj, _, _, _, _, _, _, _, _, _, _), throw(error(existence_error(object, Obj), logtalk(_, _))). '$lgt_runtime_normalized_error_handler'(error(existence_error(procedure, TFunctor/5), _)) :- atom_concat(Prefix, '_dcl', TFunctor), '$lgt_prefix_to_entity'(Prefix, CtgOrPtc), ( '$lgt_implements_protocol_'(_, CtgOrPtc, _), \+ '$lgt_current_protocol_'(CtgOrPtc, _, _, _, _), throw(error(existence_error(protocol, CtgOrPtc), logtalk(_, _))) ; '$lgt_extends_protocol_'(_, CtgOrPtc, _), \+ '$lgt_current_protocol_'(CtgOrPtc, _, _, _, _), throw(error(existence_error(protocol, CtgOrPtc), logtalk(_, _))) ; '$lgt_imports_category_'(_, CtgOrPtc, _), \+ '$lgt_current_category_'(CtgOrPtc, _, _, _, _, _), throw(error(existence_error(category, CtgOrPtc), logtalk(_, _))) ; '$lgt_extends_category_'(_, CtgOrPtc, _), \+ '$lgt_current_category_'(CtgOrPtc, _, _, _, _, _), throw(error(existence_error(category, CtgOrPtc), logtalk(_, _))) ). '$lgt_runtime_normalized_error_handler'(error(existence_error(procedure, TFunctor/TArity), logtalk(Goal, ExCtx))) :- '$lgt_decompile_predicate_indicators'(TFunctor/TArity, _, _, Functor/Arity), throw(error(existence_error(procedure, Functor/Arity), logtalk(Goal, ExCtx))). '$lgt_runtime_normalized_error_handler'(error(existence_error(procedure, TFunctor/TArity), _)) :- '$lgt_decompile_predicate_indicators'(TFunctor/TArity, _, _, Functor/Arity), throw(error(existence_error(procedure, Functor/Arity), logtalk(_, _))). '$lgt_runtime_normalized_error_handler'(Error) :- throw(Error). '$lgt_runtime_thread_error_handler_helper'(logtalk(threaded_exit(TGoal),ExCtx), logtalk(threaded_exit(Goal),ExCtx)) :- !, '$lgt_runtime_thread_error_tgoal_goal'(TGoal, Goal). '$lgt_runtime_thread_error_handler_helper'(logtalk(threaded_exit(TGoal,Tag),ExCtx), logtalk(threaded_exit(Goal,Tag),ExCtx)) :- !, '$lgt_runtime_thread_error_tgoal_goal'(TGoal, Goal). '$lgt_runtime_thread_error_handler_helper'(Context, Context). '$lgt_runtime_thread_error_tgoal_goal'('$lgt_send_to_obj_ne_nv'(Self,Goal0,_), Goal) :- !, ( Self == user -> Goal = Goal0 ; Goal = Self::Goal0 ). '$lgt_runtime_thread_error_tgoal_goal'('$lgt_send_to_obj_nv'(Self,Goal0,_), Goal) :- !, ( Self == user -> Goal = Goal0 ; Goal = Self::Goal0 ). '$lgt_runtime_thread_error_tgoal_goal'(TGoal, Goal) :- functor(TGoal, TFunctor, TArity), '$lgt_decompile_predicate_indicators'(TFunctor/TArity, _, _, Functor/Arity), functor(Goal, Functor, Arity), '$lgt_unify_head_thead_arguments'(Goal, TGoal, _). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % built-in predicates % % in general, two main clauses are provided: one for calls in "user", e.g. % calls at the top-level, and one for compiled calls % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % current_object(?object_identifier) current_object(Obj) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_current_object'(Obj, ExCtx). '$lgt_current_object'(Obj, ExCtx) :- '$lgt_check'(var_or_object_identifier, Obj, logtalk(current_object(Obj), ExCtx)), '$lgt_current_object_'(Obj, _, _, _, _, _, _, _, _, _, _). % current_protocol(?protocol_identifier) current_protocol(Ptc) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_current_protocol'(Ptc, ExCtx). '$lgt_current_protocol'(Ptc, ExCtx) :- '$lgt_check'(var_or_protocol_identifier, Ptc, logtalk(current_protocol(Ptc), ExCtx)), '$lgt_current_protocol_'(Ptc, _, _, _, _). % current_category(?category_identifier) current_category(Ctg) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_current_category'(Ctg, ExCtx). '$lgt_current_category'(Ctg, ExCtx) :- '$lgt_check'(var_or_category_identifier, Ctg, logtalk(current_category(Ctg), ExCtx)), '$lgt_current_category_'(Ctg, _, _, _, _, _). % object_property(?object_identifier, ?object_property) % % the implementation ensures that no spurious choice-points are % created when the predicate is called with a bound property argument object_property(Obj, Prop) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_object_property'(Obj, Prop, ExCtx). '$lgt_object_property'(Obj, Prop, ExCtx) :- '$lgt_check'(var_or_object_identifier, Obj, logtalk(object_property(Obj, Prop), ExCtx)), '$lgt_check'(var_or_object_property, Prop, logtalk(object_property(Obj, Prop), ExCtx)), '$lgt_current_object_'(Obj, _, Dcl, Def, _, _, _, DDcl, DDef, Rnm, Flags), '$lgt_object_property'(Prop, Obj, Dcl, Def, DDcl, DDef, Rnm, Flags). '$lgt_object_property'(module, _, _, _, _, _, _, Flags) :- Flags /\ 1024 =:= 1024. '$lgt_object_property'(debugging, _, _, _, _, _, _, Flags) :- Flags /\ 512 =:= 512. '$lgt_object_property'(context_switching_calls, _, _, _, _, _, _, Flags) :- Flags /\ 256 =:= 256. '$lgt_object_property'(dynamic_declarations, _, _, _, _, _, _, Flags) :- Flags /\ 128 =:= 128. '$lgt_object_property'(complements(Complements), _, _, _, _, _, _, Flags) :- ( Flags /\ 64 =:= 64 -> Complements = allow ; Flags /\ 32 =:= 32, Complements = restrict ). '$lgt_object_property'(complements, _, _, _, _, _, _, Flags) :- % deprecated Logtalk 2.x object property ( Flags /\ 64 =:= 64 -> true ; Flags /\ 32 =:= 32 ). '$lgt_object_property'(events, Obj, _, _, _, _, _, Flags) :- ( Obj == user -> % depends on the current default value of the flag '$lgt_current_flag_'(events, allow) ; % fixed value (at compilation time) for all other objects Flags /\ 16 =:= 16 ). '$lgt_object_property'(source_data, _, _, _, _, _, _, Flags) :- Flags /\ 8 =:= 8. '$lgt_object_property'(threaded, _, _, _, _, _, _, Flags) :- Flags /\ 4 =:= 4. '$lgt_object_property'((dynamic), _, _, _, _, _, _, Flags) :- Flags /\ 2 =:= 2. '$lgt_object_property'(static, _, _, _, _, _, _, Flags) :- Flags /\ 2 =:= 0. '$lgt_object_property'(built_in, _, _, _, _, _, _, Flags) :- Flags /\ 1 =:= 1. '$lgt_object_property'(file(Path), Obj, _, _, _, _, _, _) :- ( '$lgt_entity_property_'(Obj, file_lines(Basename, Directory, _, _)) -> atom_concat(Directory, Basename, Path) ; fail ). '$lgt_object_property'(file(Basename, Directory), Obj, _, _, _, _, _, _) :- ( '$lgt_entity_property_'(Obj, file_lines(Basename, Directory, _, _)) -> true ; fail ). '$lgt_object_property'(lines(Start, End), Obj, _, _, _, _, _, _) :- ( '$lgt_entity_property_'(Obj, file_lines(_, _, Start, End)) -> true ; fail ). '$lgt_object_property'(directive(Start, End), Obj, _, _, _, _, _, _) :- ( '$lgt_entity_property_'(Obj, directive(Start, End)) -> true ; fail ). '$lgt_object_property'(info(Info), Obj, _, _, _, _, _, _) :- ( '$lgt_entity_property_'(Obj, info(Info)) -> true ; fail ). '$lgt_object_property'(public(Resources), Obj, Dcl, _, DDcl, _, _, Flags) :- '$lgt_object_property_resources'(Obj, Dcl, DDcl, Flags, p(p(p)), Resources). '$lgt_object_property'(protected(Resources), Obj, Dcl, _, DDcl, _, _, Flags) :- '$lgt_object_property_resources'(Obj, Dcl, DDcl, Flags, p(p), Resources). '$lgt_object_property'(private(Resources), Obj, Dcl, _, DDcl, _, _, Flags) :- '$lgt_object_property_resources'(Obj, Dcl, DDcl, Flags, p, Resources). '$lgt_object_property'(declares(Predicate, Properties), Obj, Dcl, _, DDcl, _, _, Flags) :- '$lgt_object_property_declares'(Obj, Dcl, DDcl, Flags, Predicate, Properties). '$lgt_object_property'(defines(Predicate, Properties), Obj, _, Def, _, DDef, _, Flags) :- '$lgt_object_property_defines'(Obj, Def, DDef, Predicate, Flags, Properties). '$lgt_object_property'(includes(Predicate, From, Properties), Obj, _, _, _, _, _, _) :- '$lgt_entity_property_includes'(Obj, Predicate, From, Properties). '$lgt_object_property'(provides(Predicate, To, Properties), Obj, _, _, _, _, _, _) :- '$lgt_entity_property_provides'(Obj, Predicate, To, Properties). '$lgt_object_property'(alias(Alias, Properties), Obj, _, _, _, _, _, _) :- '$lgt_entity_property_alias'(Obj, Alias, Properties). '$lgt_object_property'(calls(Predicate, Properties), Obj, _, _, _, _, _, _) :- '$lgt_entity_property_calls'(Obj, Predicate, Properties). '$lgt_object_property'(updates(Predicate, Properties), Obj, _, _, _, _, _, _) :- '$lgt_entity_property_updates'(Obj, Predicate, Properties). '$lgt_object_property'(number_of_clauses(Total), Obj, _, _, _, _, _, _) :- ( '$lgt_entity_property_'(Obj, number_of_clauses(Total, _)) -> true ; fail ). '$lgt_object_property'(number_of_rules(Total), Obj, _, _, _, _, _, _) :- ( '$lgt_entity_property_'(Obj, number_of_rules(Total, _)) -> true ; fail ). '$lgt_object_property'(number_of_user_clauses(TotalUser), Obj, _, _, _, _, _, _) :- ( '$lgt_entity_property_'(Obj, number_of_clauses(_, TotalUser)) -> true ; fail ). '$lgt_object_property'(number_of_user_rules(TotalUser), Obj, _, _, _, _, _, _) :- ( '$lgt_entity_property_'(Obj, number_of_rules(_, TotalUser)) -> true ; fail ). '$lgt_object_property_resources'(Obj, Dcl, DDcl, Flags, Scope, Resources) :- % the caller uses this predicate to group object resources by scope findall( Resource, '$lgt_object_property_resource'(Obj, Dcl, DDcl, Flags, Scope, Resource), Resources ). '$lgt_object_property_resource'(_, Dcl, _, _, Scope, Functor/Arity) :- call(Dcl, Predicate, Scope, _, _), functor(Predicate, Functor, Arity). '$lgt_object_property_resource'(_, _, DDcl, Flags, Scope, Functor/Arity) :- Flags /\ 128 =:= 128, % dynamic predicate declarations are allowed call(DDcl, Predicate, Scope), functor(Predicate, Functor, Arity). '$lgt_object_property_resource'(Obj, _, _, _, Scope, op(Priority, Specifier, Operator)) :- '$lgt_entity_property_'(Obj, op(Priority, Specifier, Operator, Scope)). % category_property(?category_identifier, ?category_property) % % the implementation ensures that no spurious choice-points are % created when the predicate is called with a bound property argument category_property(Ctg, Prop) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_category_property'(Ctg, Prop, ExCtx). '$lgt_category_property'(Ctg, Prop, ExCtx) :- '$lgt_check'(var_or_category_identifier, Ctg, logtalk(category_property(Ctg, Prop), ExCtx)), '$lgt_check'(var_or_category_property, Prop, logtalk(category_property(Ctg, Prop), ExCtx)), '$lgt_current_category_'(Ctg, _, Dcl, Def, Rnm, Flags), '$lgt_category_property'(Prop, Ctg, Dcl, Def, Rnm, Flags). '$lgt_category_property'(debugging, _, _, _, _, Flags) :- Flags /\ 512 =:= 512. '$lgt_category_property'(events, _, _, _, _, Flags) :- Flags /\ 16 =:= 16. '$lgt_category_property'(source_data, _, _, _, _, Flags) :- Flags /\ 8 =:= 8. '$lgt_category_property'((dynamic), _, _, _, _, Flags) :- Flags /\ 2 =:= 2. '$lgt_category_property'(static, _, _, _, _, Flags) :- Flags /\ 2 =:= 0. '$lgt_category_property'(built_in, _, _, _, _, Flags) :- Flags /\ 1 =:= 1. '$lgt_category_property'(file(Path), Ctg, _, _, _, _) :- ( '$lgt_entity_property_'(Ctg, file_lines(Basename, Directory, _, _)) -> atom_concat(Directory, Basename, Path) ; fail ). '$lgt_category_property'(file(Basename, Directory), Ctg, _, _, _, _) :- ( '$lgt_entity_property_'(Ctg, file_lines(Basename, Directory, _, _)) -> true ; fail ). '$lgt_category_property'(lines(Start, End), Ctg, _, _, _, _) :- ( '$lgt_entity_property_'(Ctg, file_lines(_, _, Start, End)) -> true ; fail ). '$lgt_category_property'(directive(Start, End), Ctg, _, _, _, _) :- ( '$lgt_entity_property_'(Ctg, directive(Start, End)) -> true ; fail ). '$lgt_category_property'(info(Info), Ctg, _, _, _, _) :- ( '$lgt_entity_property_'(Ctg, info(Info)) -> true ; fail ). '$lgt_category_property'(public(Resources), Ctg, Dcl, _, _, Flags) :- '$lgt_category_property_resources'(Ctg, Dcl, Flags, p(p(p)), Resources). '$lgt_category_property'(protected(Resources), Ctg, Dcl, _, _, Flags) :- '$lgt_category_property_resources'(Ctg, Dcl, Flags, p(p), Resources). '$lgt_category_property'(private(Resources), Ctg, Dcl, _, _, Flags) :- '$lgt_category_property_resources'(Ctg, Dcl, Flags, p, Resources). '$lgt_category_property'(declares(Predicate, Properties), Ctg, Dcl, _, _, _) :- '$lgt_category_property_declares'(Ctg, Dcl, Predicate, Properties). '$lgt_category_property'(defines(Predicate, Properties), Ctg, _, Def, _, Flags) :- '$lgt_category_property_defines'(Ctg, Def, Predicate, Flags, Properties). '$lgt_category_property'(includes(Predicate, From, Properties), Ctg, _, _, _, _) :- '$lgt_entity_property_includes'(Ctg, Predicate, From, Properties). '$lgt_category_property'(provides(Predicate, To, Properties), Ctg, _, _, _, _) :- '$lgt_entity_property_provides'(Ctg, Predicate, To, Properties). '$lgt_category_property'(calls(Predicate, Properties), Ctg, _, _, _, _) :- '$lgt_entity_property_calls'(Ctg, Predicate, Properties). '$lgt_category_property'(updates(Predicate, Properties), Ctg, _, _, _, _) :- '$lgt_entity_property_updates'(Ctg, Predicate, Properties). '$lgt_category_property'(alias(Alias, Properties), Ctg, _, _, _, _) :- '$lgt_entity_property_alias'(Ctg, Alias, Properties). '$lgt_category_property'(number_of_clauses(Total), Ctg, _, _, _, _) :- ( '$lgt_entity_property_'(Ctg, number_of_clauses(Total, _)) -> true ; fail ). '$lgt_category_property'(number_of_rules(Total), Ctg, _, _, _, _) :- ( '$lgt_entity_property_'(Ctg, number_of_rules(Total, _)) -> true ; fail ). '$lgt_category_property'(number_of_user_clauses(TotalUser), Ctg, _, _, _, _) :- ( '$lgt_entity_property_'(Ctg, number_of_clauses(_, TotalUser)) -> true ; fail ). '$lgt_category_property'(number_of_user_rules(TotalUser), Ctg, _, _, _, _) :- ( '$lgt_entity_property_'(Ctg, number_of_rules(_, TotalUser)) -> true ; fail ). '$lgt_category_property_resources'(Ctg, Dcl, Flags, Scope, Resources) :- % the caller uses this predicate to group object resources by scope findall( Resource, '$lgt_category_property_resource'(Ctg, Dcl, Flags, Scope, Resource), Resources ). '$lgt_category_property_resource'(Ctg, Dcl, _, Scope, Functor/Arity) :- call(Dcl, Predicate, Scope, _, _, Ctg), functor(Predicate, Functor, Arity). '$lgt_category_property_resource'(Ctg, _, _, Scope, op(Priority, Specifier, Operator)) :- '$lgt_entity_property_'(Ctg, op(Priority, Specifier, Operator, Scope)). % protocol_property(?protocol_identifier, ?protocol_property) % % the implementation ensures that no spurious choice-points are % created when the predicate is called with a bound property argument protocol_property(Ptc, Prop) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_protocol_property'(Ptc, Prop, ExCtx). '$lgt_protocol_property'(Ptc, Prop, ExCtx) :- '$lgt_check'(var_or_protocol_identifier, Ptc, logtalk(protocol_property(Ptc, Prop), ExCtx)), '$lgt_check'(var_or_protocol_property, Prop, logtalk(protocol_property(Ptc, Prop), ExCtx)), '$lgt_current_protocol_'(Ptc, _, Dcl, Rnm, Flags), '$lgt_protocol_property'(Prop, Ptc, Dcl, Rnm, Flags). '$lgt_protocol_property'(debugging, _, _, _, Flags) :- Flags /\ 512 =:= 512. '$lgt_protocol_property'(source_data, _, _, _, Flags) :- Flags /\ 8 =:= 8. '$lgt_protocol_property'((dynamic), _, _, _, Flags) :- Flags /\ 2 =:= 2. '$lgt_protocol_property'(static, _, _, _, Flags) :- Flags /\ 2 =:= 0. '$lgt_protocol_property'(built_in, _, _, _, Flags) :- Flags /\ 1 =:= 1. '$lgt_protocol_property'(file(Path), Ptc, _, _, _) :- ( '$lgt_entity_property_'(Ptc, file_lines(Basename, Directory, _, _)) -> atom_concat(Directory, Basename, Path) ; fail ). '$lgt_protocol_property'(file(Basename, Directory), Ptc, _, _, _) :- ( '$lgt_entity_property_'(Ptc, file_lines(Basename, Directory, _, _)) -> true ; fail ). '$lgt_protocol_property'(lines(Start, End), Ptc, _, _, _) :- ( '$lgt_entity_property_'(Ptc, file_lines(_, _, Start, End)) -> true ; fail ). '$lgt_protocol_property'(directive(Start, End), Ptc, _, _, _) :- ( '$lgt_entity_property_'(Ptc, directive(Start, End)) -> true ; fail ). '$lgt_protocol_property'(info(Info), Ptc, _, _, _) :- ( '$lgt_entity_property_'(Ptc, info(Info)) -> true ; fail ). '$lgt_protocol_property'(public(Resources), Ptc, Dcl, _, Flags) :- '$lgt_protocol_property_resources'(Ptc, Dcl, Flags, p(p(p)), Resources). '$lgt_protocol_property'(protected(Resources), Ptc, Dcl, _, Flags) :- '$lgt_protocol_property_resources'(Ptc, Dcl, Flags, p(p), Resources). '$lgt_protocol_property'(private(Resources), Ptc, Dcl, _, Flags) :- '$lgt_protocol_property_resources'(Ptc, Dcl, Flags, p, Resources). '$lgt_protocol_property'(declares(Predicate, Properties), Ptc, Dcl, _, _) :- '$lgt_protocol_property_declares'(Ptc, Dcl, Predicate, Properties). '$lgt_protocol_property'(alias(Alias, Properties), Ptc, _, _, _) :- '$lgt_entity_property_alias'(Ptc, Alias, Properties). '$lgt_protocol_property_resources'(Ptc, Dcl, Flags, Scope, Resources) :- % the caller uses this predicate to group object resources by scope findall( Resource, '$lgt_protocol_property_resource'(Ptc, Dcl, Flags, Scope, Resource), Resources ). '$lgt_protocol_property_resource'(Ptc, Dcl, _, Scope, Functor/Arity) :- call(Dcl, Predicate, Scope, _, _, Ptc), functor(Predicate, Functor, Arity). '$lgt_protocol_property_resource'(Ptc, _, _, Scope, op(Priority, Specifier, Operator)) :- '$lgt_entity_property_'(Ptc, op(Priority, Specifier, Operator, Scope)). '$lgt_object_property_declares'(Obj, Dcl, DDcl, EntityFlags, Functor/Arity, Properties) :- ( call(Dcl, Predicate, Scope, Meta, Flags) ; EntityFlags /\ 128 =:= 128, % dynamic predicate declarations are allowed call(DDcl, Predicate, Scope), Meta = no, Flags = 2 ), functor(Predicate, Functor, Arity), '$lgt_scope'(ScopeAsAtom, Scope), '$lgt_entity_property_declares'(Obj, Functor/Arity, ScopeAsAtom, Meta, Flags, Properties). '$lgt_category_property_declares'(Ctg, Dcl, Functor/Arity, Properties) :- call(Dcl, Predicate, Scope, Meta, Flags, Ctg), functor(Predicate, Functor, Arity), '$lgt_scope'(ScopeAsAtom, Scope), '$lgt_entity_property_declares'(Ctg, Functor/Arity, ScopeAsAtom, Meta, Flags, Properties). '$lgt_protocol_property_declares'(Ptc, Dcl, Functor/Arity, Properties) :- call(Dcl, Predicate, Scope, Meta, Flags, Ptc), functor(Predicate, Functor, Arity), '$lgt_scope'(ScopeAsAtom, Scope), '$lgt_entity_property_declares'(Ptc, Functor/Arity, ScopeAsAtom, Meta, Flags, Properties). '$lgt_entity_property_declares'(Entity, Functor/Arity, Scope, Meta, Flags, Properties) :- ( '$lgt_predicate_property_'(Entity, Functor/Arity, info(Info)) -> Properties0 = [info(Info)] ; Properties0 = [] ), findall(mode(Mode, Solutions), '$lgt_predicate_property_'(Entity, Functor/Arity, mode(Mode, Solutions)), Modes), '$lgt_append'(Modes, Properties0, Properties1), ( '$lgt_predicate_property_'(Entity, Functor/Arity, declaration_location(Location)) -> ( Location = include(File, BeginLine-EndLine) -> Properties2 = [include(File), lines(BeginLine,EndLine), line_count(BeginLine)| Properties1] ; Location = BeginLine-EndLine, Properties2 = [lines(BeginLine,EndLine), line_count(BeginLine)| Properties1] ) ; Properties2 = Properties1 ), ( %Flags /\ 64 =:= 64, Meta == no -> Properties7 = Properties6 ; Properties7 = [meta_predicate(Meta)| Properties6] ), ( Flags /\ 32 =:= 32, '$lgt_predicate_property_'(Entity, Functor/Arity, coinductive(Template)) -> Properties3 = [coinductive(Template)| Properties2] ; Properties3 = Properties2 ), ( Flags /\ 16 =:= 16 -> Properties4 = [(multifile)| Properties3] ; Properties4 = Properties3 ), ( Flags /\ 8 =:= 8 -> Arity2 is Arity - 2, Properties5 = [non_terminal(Functor//Arity2)| Properties4] ; Properties5 = Properties4 ), ( Flags /\ 4 =:= 4 -> Properties6 = [synchronized| Properties5] ; Properties6 = Properties5 ), ( Flags /\ 2 =:= 2 -> Properties = [Scope, scope(Scope), (dynamic)| Properties7] ; Properties = [Scope, scope(Scope), static| Properties7] ). '$lgt_object_property_defines'(Obj, Def, DDef, Functor/Arity, Flags, Properties) :- ( call(Def, Predicate, _, _) ; call(DDef, Predicate, _, _) ), functor(Predicate, Functor, Arity), '$lgt_entity_property_defines'(Obj, Functor/Arity, Flags, Properties). '$lgt_category_property_defines'(Ctg, Def, Functor/Arity, Flags, Properties) :- call(Def, Predicate, _, _, Ctg), functor(Predicate, Functor, Arity), '$lgt_entity_property_defines'(Ctg, Functor/Arity, Flags, Properties). '$lgt_entity_property_defines'(Entity, Functor/Arity, _, Properties) :- '$lgt_predicate_property_'(Entity, Functor/Arity, flags_clauses_rules_location(Flags, Clauses, Rules, Location)), !, ( Location = include(File, BeginLine-EndLine) -> Properties0 = [include(File), lines(BeginLine,EndLine), line_count(BeginLine), number_of_clauses(Clauses), number_of_rules(Rules)] ; Location == 0-0 -> % auxiliary predicate Properties0 = [number_of_clauses(Clauses), number_of_rules(Rules)] ; Location = BeginLine-EndLine, Properties0 = [lines(BeginLine,EndLine), line_count(BeginLine), number_of_clauses(Clauses), number_of_rules(Rules)] ), ( Flags /\ 8 =:= 8 -> Properties1 = [recursive| Properties0] ; Properties1 = Properties0 ), ( Flags /\ 4 =:= 4 -> Properties2 = [inline| Properties1] ; Properties2 = Properties1 ), ( Flags /\ 2 =:= 2 -> Arity2 is Arity - 2, Properties3 = [non_terminal(Functor//Arity2)| Properties2] ; Properties3 = Properties2 ), ( Flags /\ 1 =:= 1 -> Properties = [auxiliary| Properties3] ; Properties = Properties3 ). % likely a dynamic or a multifile predicate with no local clauses '$lgt_entity_property_defines'(_, _, Flags, [number_of_clauses(0), number_of_rules(0)]) :- Flags /\ 2 =:= 0, % static entity !. % dynamically created entity '$lgt_entity_property_defines'(_, _, _, []). '$lgt_entity_property_includes'(Entity, Functor/Arity, From, Properties) :- '$lgt_predicate_property_'(From, Functor/Arity, clauses_rules_location_to(Clauses, Rules, Location, Entity)), ( Location = include(File, BeginLine-EndLine) -> LocationProperties = [include(File), lines(BeginLine,EndLine), line_count(BeginLine)] ; Location = BeginLine-EndLine, LocationProperties = [lines(BeginLine,EndLine), line_count(BeginLine)] ), Properties = [number_of_clauses(Clauses), number_of_rules(Rules)| LocationProperties]. '$lgt_entity_property_provides'(Entity, Functor/Arity, To, Properties) :- '$lgt_predicate_property_'(Entity, Functor/Arity, clauses_rules_location_to(Clauses, Rules, Location, To)), ( Location = include(File, BeginLine-EndLine) -> LocationProperties = [include(File), lines(BeginLine,EndLine), line_count(BeginLine)] ; Location = BeginLine-EndLine, LocationProperties = [lines(BeginLine,EndLine), line_count(BeginLine)] ), Properties = [number_of_clauses(Clauses), number_of_rules(Rules)| LocationProperties]. '$lgt_entity_property_alias'(Entity, Alias, Properties) :- '$lgt_entity_property_'(Entity, object_alias(Original, Alias, Location)), ( Location = include(File, BeginLine-EndLine) -> Properties = [object, for(Original), include(File), lines(BeginLine,EndLine), line_count(BeginLine)] ; Location = BeginLine-EndLine, Properties = [object, for(Original), lines(BeginLine,EndLine), line_count(BeginLine)] ). '$lgt_entity_property_alias'(Entity, Alias, Properties) :- '$lgt_entity_property_'(Entity, module_alias(Original, Alias, Location)), ( Location = include(File, BeginLine-EndLine) -> Properties = [module, for(Original), include(File), lines(BeginLine,EndLine), line_count(BeginLine)] ; Location = BeginLine-EndLine, Properties = [module, for(Original), lines(BeginLine,EndLine), line_count(BeginLine)] ). '$lgt_entity_property_alias'(Entity, AliasFunctor/Arity, Properties) :- '$lgt_entity_property_'(Entity, predicate_alias(From, OriginalFunctor/Arity, AliasFunctor/Arity, NonTerminalFlag, Location)), ( Location = include(File, BeginLine-EndLine) -> LocationProperties = [include(File), lines(BeginLine,EndLine), line_count(BeginLine)] ; Location = BeginLine-EndLine, LocationProperties = [lines(BeginLine,EndLine), line_count(BeginLine)] ), ( NonTerminalFlag =:= 1 -> Arity2 is Arity - 2, Properties = [predicate, for(OriginalFunctor/Arity), from(From), non_terminal(AliasFunctor//Arity2)| LocationProperties] ; Properties = [predicate, for(OriginalFunctor/Arity), from(From)| LocationProperties] ). '$lgt_entity_property_calls'(Entity, Call, Properties) :- '$lgt_entity_property_'(Entity, calls(Call, Caller, Alias, NonTerminal, Location)), ( NonTerminal == no -> NonTerminalProperty = [] ; NonTerminalProperty = [non_terminal(NonTerminal)] ), ( Location = include(File, BeginLine-EndLine) -> LocationProperties = [include(File), lines(BeginLine,EndLine), line_count(BeginLine)| NonTerminalProperty] ; Location = BeginLine-EndLine, LocationProperties = [lines(BeginLine,EndLine), line_count(BeginLine)| NonTerminalProperty] ), ( Alias == no -> OtherProperties = LocationProperties ; OtherProperties = [alias(Alias)| LocationProperties] ), Properties = [caller(Caller)| OtherProperties]. '$lgt_entity_property_updates'(Entity, Predicate, Properties) :- '$lgt_entity_property_'(Entity, updates(Predicate, Updater, Alias, NonTerminal, Location)), ( NonTerminal == no -> NonTerminalProperty = [] ; NonTerminalProperty = [non_terminal(NonTerminal)] ), ( Location = include(File, BeginLine-EndLine) -> LocationProperties = [include(File), lines(BeginLine,EndLine), line_count(BeginLine)| NonTerminalProperty] ; Location = BeginLine-EndLine, LocationProperties = [lines(BeginLine,EndLine), line_count(BeginLine)| NonTerminalProperty] ), ( Alias == no -> OtherProperties = LocationProperties ; OtherProperties = [alias(Alias)| LocationProperties] ), Properties = [updater(Updater)| OtherProperties]. % create_object(?object_identifier, +list, +list, +list) create_object(Obj, Relations, Directives, Clauses) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_create_object'(Obj, Relations, Directives, Clauses, ExCtx). '$lgt_create_object'(Obj, Relations, Directives, Clauses, ExCtx) :- nonvar(Obj), ( \+ callable(Obj), throw(error(type_error(object_identifier, Obj), logtalk(create_object(Obj, Relations, Directives, Clauses), ExCtx))) ; '$lgt_current_object_'(Obj, _, _, _, _, _, _, _, _, _, _), throw(error(permission_error(modify, object, Obj), logtalk(create_object(Obj, Relations, Directives, Clauses), ExCtx))) ; '$lgt_current_category_'(Obj, _, _, _, _, _), throw(error(permission_error(modify, category, Obj), logtalk(create_object(Obj, Relations, Directives, Clauses), ExCtx))) ; '$lgt_current_protocol_'(Obj, _, _, _, _), throw(error(permission_error(modify, protocol, Obj), logtalk(create_object(Obj, Relations, Directives, Clauses), ExCtx))) ; functor(Obj, '{}', 1), throw(error(permission_error(create, object, Obj), logtalk(create_object(Obj, Relations, Directives, Clauses), ExCtx))) ). '$lgt_create_object'(Obj, Relations, Directives, Clauses, ExCtx) :- '$lgt_check'(list, Relations, logtalk(create_object(Obj, Relations, Directives, Clauses), ExCtx)), '$lgt_check'(list, Directives, logtalk(create_object(Obj, Relations, Directives, Clauses), ExCtx)), '$lgt_check'(list, Clauses, logtalk(create_object(Obj, Relations, Directives, Clauses), ExCtx)), catch( '$lgt_create_object_checked'(Obj, Relations, Directives, Clauses), Error, '$lgt_create_entity_error_handler'(Error, create_object(Obj, Relations, Directives, Clauses), ExCtx) ). '$lgt_create_object_checked'(Obj, Relations, Directives, Clauses) :- ( var(Obj) -> '$lgt_generate_entity_identifier'(object, Obj) ; true ), % set the initial compilation context for compiling the object directives and clauses '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, _, _, _, _, runtime, _, '-'(-1, -1), _), % we need to compile the object relations first as we need to know if we are compiling % a prototype or an instance/class when compiling the object identifier as the generated % internal functors are different for each case '$lgt_compile_object_relations'(Relations, Obj, Ctx), '$lgt_compile_object_identifier'(Obj, Ctx), assertz('$lgt_pp_dynamic_'), '$lgt_compile_logtalk_directives'(Directives, Ctx), % the list of clauses may also include grammar rules '$lgt_compile_runtime_terms'(Clauses), '$lgt_generate_def_table_clauses'(Ctx), '$lgt_compile_predicate_calls'(runtime), '$lgt_generate_object_clauses', '$lgt_generate_object_directives', '$lgt_assert_dynamic_entity'(object), '$lgt_restore_global_operator_table', '$lgt_clean_pp_cc_clauses', '$lgt_clean_pp_object_clauses', '$lgt_clean_pp_runtime_clauses'. % create_category(?category_identifier, +list, +list, +list) create_category(Ctg, Relations, Directives, Clauses) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_create_category'(Ctg, Relations, Directives, Clauses, ExCtx). '$lgt_create_category'(Ctg, Relations, Directives, Clauses, ExCtx) :- nonvar(Ctg), ( \+ callable(Ctg), throw(error(type_error(category_identifier, Ctg), logtalk(create_category(Ctg, Relations, Directives, Clauses), ExCtx))) ; '$lgt_current_category_'(Ctg, _, _, _, _, _), throw(error(permission_error(modify, category, Ctg), logtalk(create_category(Ctg, Relations, Directives, Clauses), ExCtx))) ; '$lgt_current_object_'(Ctg, _, _, _, _, _, _, _, _, _, _), throw(error(permission_error(modify, object, Ctg), logtalk(create_category(Ctg, Relations, Directives, Clauses), ExCtx))) ; '$lgt_current_protocol_'(Ctg, _, _, _, _), throw(error(permission_error(modify, protocol, Ctg), logtalk(create_category(Ctg, Relations, Directives, Clauses), ExCtx))) ). '$lgt_create_category'(Ctg, Relations, Directives, Clauses, ExCtx) :- '$lgt_check'(list, Relations, logtalk(create_category(Ctg, Relations, Directives, Clauses), ExCtx)), '$lgt_check'(list, Directives, logtalk(create_category(Ctg, Relations, Directives, Clauses), ExCtx)), '$lgt_check'(list, Clauses, logtalk(create_category(Ctg, Relations, Directives, Clauses), ExCtx)), catch( '$lgt_create_category_checked'(Ctg, Relations, Directives, Clauses), Error, '$lgt_create_entity_error_handler'(Error, create_category(Ctg, Relations, Directives, Clauses), ExCtx) ). '$lgt_create_category_checked'(Ctg, Relations, Directives, Clauses) :- ( var(Ctg) -> '$lgt_generate_entity_identifier'(category, Ctg) ; true ), % set the initial compilation context for compiling the category directives and clauses '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, _, _, _, _, runtime, _, '-'(-1, -1), _), '$lgt_compile_category_identifier'(Ctg, Ctx), '$lgt_compile_category_relations'(Relations, Ctg, Ctx), assertz('$lgt_pp_dynamic_'), '$lgt_compile_logtalk_directives'(Directives, Ctx), % the list of clauses may also include grammar rules '$lgt_compile_runtime_terms'(Clauses), '$lgt_generate_def_table_clauses'(Ctx), '$lgt_compile_predicate_calls'(runtime), '$lgt_generate_category_clauses', '$lgt_generate_category_directives', '$lgt_assert_dynamic_entity'(category), '$lgt_restore_global_operator_table', '$lgt_clean_pp_cc_clauses', '$lgt_clean_pp_category_clauses', '$lgt_clean_pp_runtime_clauses', % complementing categories can invalidate dynamic binding cache entries ( '$lgt_member'(Relation, Relations), functor(Relation, complements, _) -> '$lgt_clean_lookup_caches' ; true ). % create_protocol(?protocol_identifier, +list, +list) create_protocol(Ptc, Relations, Directives) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_create_protocol'(Ptc, Relations, Directives, ExCtx). '$lgt_create_protocol'(Ptc, Relations, Directives, ExCtx) :- nonvar(Ptc), ( \+ atom(Ptc), throw(error(type_error(protocol_identifier, Ptc), logtalk(create_protocol(Ptc, Relations, Directives), ExCtx))) ; '$lgt_current_protocol_'(Ptc, _, _, _, _), throw(error(permission_error(modify, protocol, Ptc), logtalk(create_protocol(Ptc, Relations, Directives), ExCtx))) ; '$lgt_current_object_'(Ptc, _, _, _, _, _, _, _, _, _, _), throw(error(permission_error(modify, object, Ptc), logtalk(create_protocol(Ptc, Relations, Directives), ExCtx))) ; '$lgt_current_category_'(Ptc, _, _, _, _, _), throw(error(permission_error(modify, category, Ptc), logtalk(create_protocol(Ptc, Relations, Directives), ExCtx))) ). '$lgt_create_protocol'(Ptc, Relations, Directives, ExCtx) :- '$lgt_check'(list, Relations, logtalk(create_protocol(Ptc, Relations, Directives), ExCtx)), '$lgt_check'(list, Directives, logtalk(create_protocol(Ptc, Relations, Directives), ExCtx)), catch( '$lgt_create_protocol_checked'(Ptc, Relations, Directives), Error, '$lgt_create_entity_error_handler'(Error, create_protocol(Ptc, Relations, Directives), ExCtx) ). '$lgt_create_protocol_checked'(Ptc, Relations, Directives) :- ( var(Ptc) -> '$lgt_generate_entity_identifier'(protocol, Ptc) ; true ), % set the initial compilation context for compiling the protocol directives '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, _, _, _, _, runtime, _, '-'(-1, -1), _), '$lgt_compile_protocol_identifier'(Ptc, Ctx), '$lgt_compile_protocol_relations'(Relations, Ptc, Ctx), assertz('$lgt_pp_dynamic_'), '$lgt_compile_logtalk_directives'(Directives, Ctx), '$lgt_generate_protocol_clauses', '$lgt_generate_protocol_directives', '$lgt_assert_dynamic_entity'(protocol), '$lgt_restore_global_operator_table', '$lgt_clean_pp_cc_clauses', '$lgt_clean_pp_protocol_clauses', '$lgt_clean_pp_runtime_clauses'. % '$lgt_generate_entity_identifier'(+atom, -entity_identifier) % % generates a new, unique, entity identifier by appending an integer to a base char % % note that it's possible to run out of (generated) entity identifiers when using a % backend Prolog compiler with bounded integer support '$lgt_generate_entity_identifier'(Kind, Identifier) :- retract('$lgt_dynamic_entity_counter_'(Kind, Base, Count)), char_code(Base, Code), repeat, '$lgt_next_integer'(Count, New), number_codes(New, Codes), atom_codes(Identifier, [Code| Codes]), % objects, protocols, and categories share a single namespace and there's % no guarantee that a user named entity will not clash with the generated % identifier despite the use of a per-entity type base character \+ '$lgt_current_protocol_'(Identifier, _, _, _, _), \+ '$lgt_current_object_'(Identifier, _, _, _, _, _, _, _, _, _, _), \+ '$lgt_current_category_'(Identifier, _, _, _, _, _), asserta('$lgt_dynamic_entity_counter_'(Kind, Base, New)), !. '$lgt_next_integer'(I, I). '$lgt_next_integer'(I, K) :- J is I + 1, '$lgt_next_integer'(J, K). % '$lgt_create_entity_error_handler'(@nonvar, @callable, @execution_context) % % error handler for the dynamic entity creation built-in predicates; % handles both compiler first stage and second stage errors '$lgt_create_entity_error_handler'(error(Error,_), Goal, ExCtx) :- !, % compiler second stage error; unwrap the error '$lgt_create_entity_error_handler'(Error, Goal, ExCtx). '$lgt_create_entity_error_handler'(Error, Goal, ExCtx) :- '$lgt_restore_global_operator_table', '$lgt_clean_pp_file_clauses', '$lgt_clean_pp_entity_clauses', throw(error(Error, logtalk(Goal, ExCtx))). % abolish_object(+object_identifier) abolish_object(Obj) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_abolish_object'(Obj, ExCtx). '$lgt_abolish_object'(Obj, ExCtx) :- '$lgt_check'(object_identifier, Obj, logtalk(abolish_object(Obj), ExCtx)), '$lgt_abolish_object_checked'(Obj, ExCtx). '$lgt_abolish_object_checked'(Obj, ExCtx) :- ( '$lgt_current_object_'(Obj, _, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Rnm, Flags) -> ( Flags /\ 2 =:= 2 -> % dynamic object '$lgt_abolish_entity_predicates'(Def), '$lgt_abolish_entity_predicates'(DDef), abolish(Dcl/4), abolish(Dcl/6), abolish(Def/3), abolish(Def/5), abolish(Super/5), abolish(IDcl/6), abolish(IDef/5), abolish(DDcl/2), abolish(DDef/3), abolish(Rnm/3), retractall('$lgt_current_object_'(Obj, _, _, _, _, _, _, _, _, _, _)), retractall('$lgt_entity_property_'(Obj, _)), retractall('$lgt_predicate_property_'(Obj, _, _)), retractall('$lgt_extends_object_'(Obj, _, _)), retractall('$lgt_instantiates_class_'(Obj, _, _)), retractall('$lgt_specializes_class_'(Obj, _, _)), retractall('$lgt_implements_protocol_'(Obj, _, _)), retractall('$lgt_imports_category_'(Obj, _, _)), forall( '$lgt_current_engine_'(Obj, Engine, _, _), '$lgt_threaded_engine_destroy'(Engine, ExCtx) ), '$lgt_clean_lookup_caches' ; throw(error(permission_error(modify, static_object, Obj), logtalk(abolish_object(Obj), ExCtx))) ) ; throw(error(existence_error(object, Obj), logtalk(abolish_object(Obj), ExCtx))) ). % abolish_category(+category_identifier) abolish_category(Ctg) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_abolish_category'(Ctg, ExCtx). '$lgt_abolish_category'(Ctg, ExCtx) :- '$lgt_check'(category_identifier, Ctg, logtalk(abolish_category(Ctg), ExCtx)), '$lgt_abolish_category_checked'(Ctg, ExCtx). '$lgt_abolish_category_checked'(Ctg, ExCtx) :- ( '$lgt_current_category_'(Ctg, _, Dcl, Def, Rnm, Flags) -> ( Flags /\ 2 =:= 2 -> % dynamic category '$lgt_abolish_entity_predicates'(Def), abolish(Dcl/4), abolish(Dcl/5), abolish(Def/3), abolish(Def/4), abolish(Rnm/3), retractall('$lgt_current_category_'(Ctg, _, _, _, _, _)), retractall('$lgt_entity_property_'(Ctg, _)), retractall('$lgt_predicate_property_'(Ctg, _, _)), retractall('$lgt_extends_category_'(Ctg, _, _)), retractall('$lgt_implements_protocol_'(Ctg, _, _)), retractall('$lgt_complemented_object_'(_, Ctg, _, _, _)), '$lgt_clean_lookup_caches' ; throw(error(permission_error(modify, static_category, Ctg), logtalk(abolish_category(Ctg), ExCtx))) ) ; throw(error(existence_error(category, Ctg), logtalk(abolish_category(Ctg), ExCtx))) ). % abolish_protocol(@protocol_identifier) abolish_protocol(Ptc) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_abolish_protocol'(Ptc, ExCtx). '$lgt_abolish_protocol'(Ptc, ExCtx) :- '$lgt_check'(protocol_identifier, Ptc, logtalk(abolish_protocol(Ptc), ExCtx)), '$lgt_abolish_protocol_checked'(Ptc, ExCtx). '$lgt_abolish_protocol_checked'(Ptc, ExCtx) :- ( '$lgt_current_protocol_'(Ptc, _, Dcl, Rnm, Flags) -> ( Flags /\ 2 =:= 2 -> % dynamic protocol abolish(Dcl/4), abolish(Dcl/5), abolish(Rnm/3), retractall('$lgt_current_protocol_'(Ptc, _, _, _, _)), retractall('$lgt_entity_property_'(Ptc, _)), retractall('$lgt_predicate_property_'(Ptc, _, _)), retractall('$lgt_extends_protocol_'(Ptc, _, _)), '$lgt_clean_lookup_caches' ; throw(error(permission_error(modify, static_protocol, Ptc), logtalk(abolish_protocol(Ptc), ExCtx))) ) ; throw(error(existence_error(protocol, Ptc), logtalk(abolish_protocol(Ptc), ExCtx))) ). % '$lgt_abolish_entity_predicates'(+atom) % % auxiliary predicate used when abolishing objects and categories '$lgt_abolish_entity_predicates'(Def) :- call(Def, _, _, Call), '$lgt_unwrap_compiled_head'(Call, 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) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_implements_protocol'(ObjOrCtg, Ptc, ExCtx). '$lgt_implements_protocol'(ObjOrCtg, Ptc, ExCtx) :- '$lgt_check'(var_or_object_identifier, ObjOrCtg, logtalk(implements_protocol(ObjOrCtg, Ptc), ExCtx)), '$lgt_check'(var_or_protocol_identifier, Ptc, logtalk(implements_protocol(ObjOrCtg, Ptc), ExCtx)), '$lgt_implements_protocol_'(ObjOrCtg, Ptc, _). % implements_protocol(?object_identifier, ?protocol_identifier, ?atom) % implements_protocol(?category_identifier, ?protocol_identifier, ?atom) implements_protocol(ObjOrCtg, Ptc, Scope) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_implements_protocol'(ObjOrCtg, Ptc, Scope, ExCtx). '$lgt_implements_protocol'(ObjOrCtg, Ptc, Scope, ExCtx) :- '$lgt_check'(var_or_object_identifier, ObjOrCtg, logtalk(implements_protocol(ObjOrCtg, Ptc, Scope), ExCtx)), '$lgt_check'(var_or_protocol_identifier, Ptc, logtalk(implements_protocol(ObjOrCtg, Ptc, Scope), ExCtx)), '$lgt_check'(var_or_scope, Scope, logtalk(implements_protocol(ObjOrCtg, Ptc, Scope), ExCtx)), '$lgt_implements_protocol_'(ObjOrCtg, Ptc, Scope). % imports_category(?object_identifier, ?category_identifier) imports_category(Obj, Ctg) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_imports_category'(Obj, Ctg, ExCtx). '$lgt_imports_category'(Obj, Ctg, ExCtx) :- '$lgt_check'(var_or_object_identifier, Obj, logtalk(imports_category(Obj, Ctg), ExCtx)), '$lgt_check'(var_or_category_identifier, Ctg, logtalk(imports_category(Obj, Ctg), ExCtx)), '$lgt_imports_category_'(Obj, Ctg, _). % imports_category(?object_identifier, ?category_identifier, ?atom) imports_category(Obj, Ctg, Scope) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_imports_category'(Obj, Ctg, Scope, ExCtx). '$lgt_imports_category'(Obj, Ctg, Scope, ExCtx) :- '$lgt_check'(var_or_object_identifier, Obj, logtalk(imports_category(Obj, Ctg, Scope), ExCtx)), '$lgt_check'(var_or_category_identifier, Ctg, logtalk(imports_category(Obj, Ctg, Scope), ExCtx)), '$lgt_check'(var_or_scope, Scope, logtalk(imports_category(Obj, Ctg, Scope), ExCtx)), '$lgt_imports_category_'(Obj, Ctg, Scope). % instantiates_class(?object_identifier, ?object_identifier) instantiates_class(Obj, Class) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_instantiates_class'(Obj, Class, ExCtx). '$lgt_instantiates_class'(Obj, Class, ExCtx) :- '$lgt_check'(var_or_object_identifier, Obj, logtalk(instantiates_class(Obj, Class), ExCtx)), '$lgt_check'(var_or_object_identifier, Class, logtalk(instantiates_class(Obj, Class), ExCtx)), '$lgt_instantiates_class_'(Obj, Class, _). % instantiates_class(?object_identifier, ?object_identifier, ?atom) instantiates_class(Obj, Class, Scope) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_instantiates_class'(Obj, Class, Scope, ExCtx). '$lgt_instantiates_class'(Obj, Class, Scope, ExCtx) :- '$lgt_check'(var_or_object_identifier, Obj, logtalk(instantiates_class(Obj, Class, Scope), ExCtx)), '$lgt_check'(var_or_object_identifier, Class, logtalk(instantiates_class(Obj, Class, Scope), ExCtx)), '$lgt_check'(var_or_scope, Scope, logtalk(instantiates_class(Obj, Class, Scope), ExCtx)), '$lgt_instantiates_class_'(Obj, Class, Scope). % specializes_class(?object_identifier, ?object_identifier) specializes_class(Class, Superclass) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_specializes_class'(Class, Superclass, ExCtx). '$lgt_specializes_class'(Class, Superclass, ExCtx) :- '$lgt_check'(var_or_object_identifier, Class, logtalk(specializes_class(Class, Superclass), ExCtx)), '$lgt_check'(var_or_object_identifier, Superclass, logtalk(specializes_class(Class, Superclass), ExCtx)), '$lgt_specializes_class_'(Class, Superclass, _). % specializes_class(?object_identifier, ?object_identifier, ?atom) specializes_class(Class, Superclass, Scope) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_specializes_class'(Class, Superclass, Scope, ExCtx). '$lgt_specializes_class'(Class, Superclass, Scope, ExCtx) :- '$lgt_check'(var_or_object_identifier, Class, logtalk(specializes_class(Class, Superclass, Scope), ExCtx)), '$lgt_check'(var_or_object_identifier, Superclass, logtalk(specializes_class(Class, Superclass, Scope), ExCtx)), '$lgt_check'(var_or_scope, Scope, logtalk(specializes_class(Class, Superclass, Scope), ExCtx)), '$lgt_specializes_class_'(Class, Superclass, Scope). % extends_category(?category_identifier, ?category_identifier) extends_category(Ctg, ExtCtg) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_extends_category'(Ctg, ExtCtg, ExCtx). '$lgt_extends_category'(Ctg, ExtCtg, ExCtx) :- '$lgt_check'(var_or_category_identifier, Ctg, logtalk(extends_category(Ctg, ExtCtg), ExCtx)), '$lgt_check'(var_or_category_identifier, ExtCtg, logtalk(extends_category(Ctg, ExtCtg), ExCtx)), '$lgt_extends_category_'(Ctg, ExtCtg, _). % extends_category(?category_identifier, ?category_identifier, ?atom) extends_category(Ctg, ExtCtg, Scope) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_extends_category'(Ctg, ExtCtg, Scope, ExCtx). '$lgt_extends_category'(Ctg, ExtCtg, Scope, ExCtx) :- '$lgt_check'(var_or_category_identifier, Ctg, logtalk(extends_category(Ctg, ExtCtg, Scope), ExCtx)), '$lgt_check'(var_or_category_identifier, ExtCtg, logtalk(extends_category(Ctg, ExtCtg, Scope), ExCtx)), '$lgt_check'(var_or_scope, Scope, logtalk(extends_category(Ctg, ExtCtg, Scope), ExCtx)), '$lgt_extends_category_'(Ctg, ExtCtg, Scope). % extends_protocol(?protocol_identifier, ?protocol_identifier) extends_protocol(Ptc, ExtPtc) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_extends_protocol'(Ptc, ExtPtc, ExCtx). '$lgt_extends_protocol'(Ptc, ExtPtc, ExCtx) :- '$lgt_check'(var_or_protocol_identifier, Ptc, logtalk(extends_protocol(Ptc, ExtPtc), ExCtx)), '$lgt_check'(var_or_protocol_identifier, ExtPtc, logtalk(extends_protocol(Ptc, ExtPtc), ExCtx)), '$lgt_extends_protocol_'(Ptc, ExtPtc, _). % extends_protocol(?protocol_identifier, ?protocol_identifier, ?atom) extends_protocol(Ptc, ExtPtc, Scope) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_extends_protocol'(Ptc, ExtPtc, Scope, ExCtx). '$lgt_extends_protocol'(Ptc, ExtPtc, Scope, ExCtx) :- '$lgt_check'(var_or_protocol_identifier, Ptc, logtalk(extends_protocol(Ptc, ExtPtc, Scope), ExCtx)), '$lgt_check'(var_or_protocol_identifier, ExtPtc, logtalk(extends_protocol(Ptc, ExtPtc, Scope), ExCtx)), '$lgt_check'(var_or_scope, Scope, logtalk(extends_protocol(Ptc, ExtPtc, Scope), ExCtx)), '$lgt_extends_protocol_'(Ptc, ExtPtc, Scope). % extends_object(?object_identifier, ?object_identifier) extends_object(Prototype, Parent) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_extends_object'(Prototype, Parent, ExCtx). '$lgt_extends_object'(Prototype, Parent, ExCtx) :- '$lgt_check'(var_or_object_identifier, Prototype, logtalk(extends_object(Prototype, Parent), ExCtx)), '$lgt_check'(var_or_object_identifier, Parent, logtalk(extends_object(Prototype, Parent), ExCtx)), '$lgt_extends_object_'(Prototype, Parent, _). % extends_object(?object_identifier, ?object_identifier, ?atom) extends_object(Prototype, Parent, Scope) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_extends_object'(Prototype, Parent, Scope, ExCtx). '$lgt_extends_object'(Prototype, Parent, Scope, ExCtx) :- '$lgt_check'(var_or_object_identifier, Prototype, logtalk(extends_object(Prototype, Parent, Scope), ExCtx)), '$lgt_check'(var_or_object_identifier, Parent, logtalk(extends_object(Prototype, Parent, Scope), ExCtx)), '$lgt_check'(var_or_scope, Scope, logtalk(extends_object(Prototype, Parent, Scope), ExCtx)), '$lgt_extends_object_'(Prototype, Parent, Scope). % complements_object(?category_identifier, ?object_identifier) complements_object(Category, Object) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_complements_object'(Category, Object, ExCtx). '$lgt_complements_object'(Category, Object, ExCtx) :- '$lgt_check'(var_or_category_identifier, Category, logtalk(complements_object(Category, Object), ExCtx)), '$lgt_check'(var_or_object_identifier, Object, logtalk(complements_object(Category, Object), ExCtx)), '$lgt_complemented_object_'(Object, Category, _, _, _). % conforms_to_protocol(?object_identifier, ?protocol_identifier) % conforms_to_protocol(?category_identifier, ?protocol_identifier) conforms_to_protocol(ObjOrCtg, Protocol) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_conforms_to_protocol'(ObjOrCtg, Protocol, ExCtx). '$lgt_conforms_to_protocol'(ObjOrCtg, Protocol, ExCtx) :- '$lgt_check'(var_or_object_identifier, ObjOrCtg, logtalk(conforms_to_protocol(ObjOrCtg, Protocol), ExCtx)), '$lgt_check'(var_or_protocol_identifier, Protocol, logtalk(conforms_to_protocol(ObjOrCtg, Protocol), ExCtx)), ( var(ObjOrCtg) -> '$lgt_conforms_to_protocol_checked'(ObjOrCtg, Protocol, _) ; var(Protocol) -> '$lgt_conforms_to_protocol_checked'(ObjOrCtg, Protocol, _) ; % deterministic query '$lgt_conforms_to_protocol_checked'(ObjOrCtg, Protocol, _), ! ). % conforms_to_protocol(?object_identifier, ?protocol_identifier, ?atom) % conforms_to_protocol(?category_identifier, ?protocol_identifier, ?atom) conforms_to_protocol(ObjOrCtg, Protocol, Scope) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_conforms_to_protocol'(ObjOrCtg, Protocol, Scope, ExCtx). '$lgt_conforms_to_protocol'(ObjOrCtg, Protocol, Scope, ExCtx) :- '$lgt_check'(var_or_object_identifier, ObjOrCtg, logtalk(conforms_to_protocol(ObjOrCtg, Protocol, Scope), ExCtx)), '$lgt_check'(var_or_protocol_identifier, Protocol, logtalk(conforms_to_protocol(ObjOrCtg, Protocol, Scope), ExCtx)), '$lgt_check'(var_or_scope, Scope, logtalk(conforms_to_protocol(ObjOrCtg, Protocol, Scope), ExCtx)), ( var(ObjOrCtg) -> '$lgt_conforms_to_protocol_checked'(ObjOrCtg, Protocol, Scope) ; var(Protocol) -> '$lgt_conforms_to_protocol_checked'(ObjOrCtg, Protocol, Scope) ; % deterministic query '$lgt_conforms_to_protocol_checked'(ObjOrCtg, Protocol, Scope), ! ). '$lgt_conforms_to_protocol_checked'(Object, Protocol, Scope) :- '$lgt_current_object_'(Object, _, _, _, _, _, _, _, _, _, _), ( \+ '$lgt_instantiates_class_'(Object, _, _), \+ '$lgt_specializes_class_'(Object, _, _) -> '$lgt_prototype_conforms_to_protocol'(Object, Protocol, Scope) ; '$lgt_instance_conforms_to_protocol'(Object, Protocol, Scope) ). '$lgt_conforms_to_protocol_checked'(Category, Protocol, Scope) :- '$lgt_current_category_'(Category, _, _, _, _, _), '$lgt_category_conforms_to_protocol'(Category, Protocol, Scope). '$lgt_prototype_conforms_to_protocol'(Prototype, Protocol, Scope) :- '$lgt_complemented_object_'(Prototype, Category, _, _, _), '$lgt_category_conforms_to_protocol'(Category, Protocol, Scope). '$lgt_prototype_conforms_to_protocol'(Prototype, Protocol, Scope) :- '$lgt_implements_protocol_'(Prototype, Protocol0, ImplementationScope), ( Protocol = Protocol0, Scope = ImplementationScope ; '$lgt_protocol_conforms_to_protocol'(Protocol0, Protocol, InheritedScope), '$lgt_filter_scope'(ImplementationScope, InheritedScope, Scope) ). '$lgt_prototype_conforms_to_protocol'(Prototype, Protocol, Scope) :- '$lgt_imports_category_'(Prototype, Category, ImportScope), '$lgt_category_conforms_to_protocol'(Category, Protocol, InheritedScope), '$lgt_filter_scope'(ImportScope, InheritedScope, Scope). '$lgt_prototype_conforms_to_protocol'(Prototype, Protocol, Scope) :- '$lgt_extends_object_'(Prototype, Parent, ExtensionScope), '$lgt_prototype_conforms_to_protocol'(Parent, Protocol, InheritedScope), '$lgt_filter_scope'(ExtensionScope, InheritedScope, Scope). '$lgt_instance_conforms_to_protocol'(Instance, Protocol, Scope) :- '$lgt_instantiates_class_'(Instance, Class, InstantiationScope), '$lgt_class_conforms_to_protocol'(Class, Protocol, InheritedScope), '$lgt_filter_scope'(InstantiationScope, InheritedScope, Scope). '$lgt_class_conforms_to_protocol'(Class, Protocol, Scope) :- '$lgt_complemented_object_'(Class, Category, _, _, _), '$lgt_category_conforms_to_protocol'(Category, Protocol, Scope). '$lgt_class_conforms_to_protocol'(Class, Protocol, Scope) :- '$lgt_implements_protocol_'(Class, Protocol0, ImplementationScope), ( Protocol = Protocol0, Scope = ImplementationScope ; '$lgt_protocol_conforms_to_protocol'(Protocol0, Protocol, InheritedScope), '$lgt_filter_scope'(ImplementationScope, InheritedScope, Scope) ). '$lgt_class_conforms_to_protocol'(Class, Protocol, Scope) :- '$lgt_imports_category_'(Class, Category, ImportScope), '$lgt_category_conforms_to_protocol'(Category, Protocol, InheritedScope), '$lgt_filter_scope'(ImportScope, InheritedScope, Scope). '$lgt_class_conforms_to_protocol'(Class, Protocol, Scope) :- '$lgt_specializes_class_'(Class, Superclass, SpecializationScope), '$lgt_class_conforms_to_protocol'(Superclass, Protocol, InheritedScope), '$lgt_filter_scope'(SpecializationScope, InheritedScope, Scope). '$lgt_protocol_conforms_to_protocol'(Protocol0, Protocol, Scope) :- '$lgt_extends_protocol_'(Protocol0, Protocol1, ExtensionScope), ( Protocol = Protocol1, Scope = ExtensionScope ; '$lgt_protocol_conforms_to_protocol'(Protocol1, Protocol, InheritedScope), '$lgt_filter_scope'(ExtensionScope, InheritedScope, Scope) ). '$lgt_category_conforms_to_protocol'(Category, Protocol, Scope) :- '$lgt_implements_protocol_'(Category, Protocol0, ImplementationScope), ( Protocol = Protocol0, Scope = ImplementationScope ; '$lgt_protocol_conforms_to_protocol'(Protocol0, Protocol, InheritedScope), '$lgt_filter_scope'(ImplementationScope, InheritedScope, Scope) ). '$lgt_category_conforms_to_protocol'(Category, Protocol, Scope) :- '$lgt_extends_category_'(Category, ExtendedCategory, ExtensionScope), '$lgt_category_conforms_to_protocol'(ExtendedCategory, Protocol, InheritedScope), '$lgt_filter_scope'(ExtensionScope, InheritedScope, Scope). % public relations don't change predicate scopes '$lgt_filter_scope'((public), Scope, Scope). % protected relations change public predicates to protected predicates '$lgt_filter_scope'(protected, Scope, protected) :- Scope \= (private). % current_event(?event, ?term, ?term, ?term, ?object_identifier) current_event(Event, Obj, Msg, Sender, Monitor) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_current_event'(Event, Obj, Msg, Sender, Monitor, ExCtx). '$lgt_current_event'(Event, Obj, Msg, Sender, Monitor, ExCtx) :- '$lgt_check'(var_or_event, Event, logtalk(current_event(Event, Obj, Msg, Sender, Monitor), ExCtx)), '$lgt_check'(var_or_object_identifier, Obj, logtalk(current_event(Event, Obj, Msg, Sender, Monitor), ExCtx)), '$lgt_check'(var_or_callable, Msg, logtalk(current_event(Event, Obj, Msg, Sender, Monitor), ExCtx)), '$lgt_check'(var_or_object_identifier, Sender, logtalk(current_event(Event, Obj, Msg, Sender, Monitor), ExCtx)), '$lgt_check'(var_or_object_identifier, Monitor, logtalk(current_event(Event, Obj, Msg, Sender, Monitor), ExCtx)), '$lgt_current_event_checked'(Event, Obj, Msg, Sender, Monitor). '$lgt_current_event_checked'(before, Obj, Msg, Sender, Monitor) :- '$lgt_before_event_'(Obj, Msg, Sender, Monitor, _). '$lgt_current_event_checked'(after, Obj, Msg, Sender, Monitor) :- '$lgt_after_event_'(Obj, Msg, Sender, Monitor, _). % define_events(@term, @term, @term, @term, +object_identifier) define_events(Event, Obj, Msg, Sender, Monitor) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_define_events'(Event, Obj, Msg, Sender, Monitor, ExCtx). '$lgt_define_events'(Event, Obj, Msg, Sender, Monitor, ExCtx) :- '$lgt_check'(var_or_event, Event, logtalk(define_events(Event, Obj, Msg, Sender, Monitor), ExCtx)), '$lgt_check'(var_or_object_identifier, Obj, logtalk(define_events(Event, Obj, Msg, Sender, Monitor), ExCtx)), '$lgt_check'(var_or_callable, Msg, logtalk(define_events(Event, Obj, Msg, Sender, Monitor), ExCtx)), '$lgt_check'(var_or_object_identifier, Sender, logtalk(define_events(Event, Obj, Msg, Sender, Monitor), ExCtx)), '$lgt_check'(object_identifier, Monitor, logtalk(define_events(Event, Obj, Msg, Sender, Monitor), ExCtx)), ( '$lgt_current_object_'(Monitor, _, _, Def, _, _, _, _, _, _, _) -> '$lgt_execution_context'(MonitorExCtx, _, Monitor, Monitor, Monitor, [], []), ( var(Event) -> '$lgt_define_events'(before, Obj, Msg, Sender, Monitor, Def, MonitorExCtx), '$lgt_define_events'(after, Obj, Msg, Sender, Monitor, Def, MonitorExCtx) ; Event == before -> '$lgt_define_events'(before, Obj, Msg, Sender, Monitor, Def, MonitorExCtx) ; % Event == after '$lgt_define_events'(after, Obj, Msg, Sender, Monitor, Def, MonitorExCtx) ) ; throw(error(existence_error(object, Monitor), logtalk(define_events(Event, Obj, Msg, Sender, Monitor), ExCtx))) ). '$lgt_define_events'(before, Obj, Msg, Sender, Monitor, Def, ExCtx) :- ( call(Def, before(Obj, Msg, Sender), ExCtx, Call, _, _) -> retractall('$lgt_before_event_'(Obj, Msg, Sender, Monitor, _)), assertz('$lgt_before_event_'(Obj, Msg, Sender, Monitor, Call)) ; throw(error(existence_error(procedure, before/3), logtalk(define_events(before, Obj, Msg, Sender, Monitor), ExCtx))) ). '$lgt_define_events'(after, Obj, Msg, Sender, Monitor, Def, ExCtx) :- ( call(Def, after(Obj, Msg, Sender), ExCtx, Call, _, _) -> retractall('$lgt_after_event_'(Obj, Msg, Sender, Monitor, _)), assertz('$lgt_after_event_'(Obj, Msg, Sender, Monitor, Call)) ; throw(error(existence_error(procedure, after/3), logtalk(define_events(after, Obj, Msg, Sender, Monitor), ExCtx))) ). % abolish_events(@term, @term, @term, @term, @term) abolish_events(Event, Obj, Msg, Sender, Monitor) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_abolish_events'(Event, Obj, Msg, Sender, Monitor, ExCtx). '$lgt_abolish_events'(Event, Obj, Msg, Sender, Monitor, ExCtx) :- '$lgt_check'(var_or_event, Event, logtalk(abolish_events(Event, Obj, Msg, Sender, Monitor), ExCtx)), '$lgt_check'(var_or_object_identifier, Obj, logtalk(abolish_events(Event, Obj, Msg, Sender, Monitor), ExCtx)), '$lgt_check'(var_or_callable, Msg, logtalk(abolish_events(Event, Obj, Msg, Sender, Monitor), ExCtx)), '$lgt_check'(var_or_object_identifier, Sender, logtalk(abolish_events(Event, Obj, Msg, Sender, Monitor), ExCtx)), '$lgt_check'(var_or_object_identifier, Monitor, logtalk(abolish_events(Event, Obj, Msg, Sender, Monitor), ExCtx)), ( var(Event) -> retractall('$lgt_before_event_'(Obj, Msg, Sender, Monitor, _)), retractall('$lgt_after_event_'(Obj, Msg, Sender, Monitor, _)) ; Event == before -> retractall('$lgt_before_event_'(Obj, Msg, Sender, Monitor, _)) ; % Event == after retractall('$lgt_after_event_'(Obj, Msg, Sender, Monitor, _)) ). % built-in multi-threading meta-predicates % threaded(+callable) threaded(Goals) :- \+ '$lgt_prolog_feature'(threads, supported), '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), throw(error(resource_error(threads), logtalk(threaded(Goals), ExCtx))). threaded(Goals) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_check'(qualified_callable, Goals, logtalk(threaded(Goals), ExCtx)), '$lgt_compile_threaded_call'(Goals, MTGoals), catch(MTGoals, Error, '$lgt_runtime_error_handler'(Error)). % threaded_call(@callable, -nonvar) threaded_call(Goal, Tag) :- \+ '$lgt_prolog_feature'(threads, supported), '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), throw(error(resource_error(threads), logtalk(threaded_call(Goal, Tag), ExCtx))). threaded_call(Goal, Tag) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), catch('$lgt_threaded_call_tagged'(Goal, Goal, ExCtx, Tag), Error, '$lgt_runtime_error_handler'(Error)). % threaded_call(@callable) threaded_call(Goal) :- \+ '$lgt_prolog_feature'(threads, supported), '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), throw(error(resource_error(threads), logtalk(threaded_call(Goal), ExCtx))). threaded_call(Goal) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), catch('$lgt_threaded_call'(Goal, Goal, ExCtx), Error, '$lgt_runtime_error_handler'(Error)). % threaded_once(@callable, -nonvar) threaded_once(Goal, Tag) :- \+ '$lgt_prolog_feature'(threads, supported), '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), throw(error(resource_error(threads), logtalk(threaded_once(Goal, Tag), ExCtx))). threaded_once(Goal, Tag) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), catch('$lgt_threaded_once_tagged'(Goal, Goal, ExCtx, Tag), Error, '$lgt_runtime_error_handler'(Error)). % threaded_once(@callable) threaded_once(Goal) :- \+ '$lgt_prolog_feature'(threads, supported), '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), throw(error(resource_error(threads), logtalk(threaded_once(Goal), ExCtx))). threaded_once(Goal) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), catch('$lgt_threaded_once'(Goal, Goal, ExCtx), Error, '$lgt_runtime_error_handler'(Error)). % threaded_ignore(@callable) threaded_ignore(Goal) :- \+ '$lgt_prolog_feature'(threads, supported), '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), throw(error(resource_error(threads), logtalk(threaded_ignore(Goal), ExCtx))). threaded_ignore(Goal) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), catch('$lgt_threaded_ignore'(Goal, Goal, ExCtx), Error, '$lgt_runtime_error_handler'(Error)). % threaded_exit(+callable, +nonvar) threaded_exit(Goal, Tag) :- \+ '$lgt_prolog_feature'(threads, supported), '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), throw(error(resource_error(threads), logtalk(threaded_exit(Goal, Tag), ExCtx))). threaded_exit(Goal, Tag) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), catch('$lgt_threaded_exit_tagged'(Goal, ExCtx, Tag), Error, '$lgt_runtime_error_handler'(Error)). % threaded_exit(+callable) threaded_exit(Goal) :- \+ '$lgt_prolog_feature'(threads, supported), '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), throw(error(resource_error(threads), logtalk(threaded_exit(Goal), ExCtx))). threaded_exit(Goal) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), catch('$lgt_threaded_exit'(Goal, ExCtx), Error, '$lgt_runtime_error_handler'(Error)). % threaded_peek(+callable, +nonvar) threaded_peek(Goal, Tag) :- \+ '$lgt_prolog_feature'(threads, supported), '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), throw(error(resource_error(threads), logtalk(threaded_peek(Goal, Tag), ExCtx))). threaded_peek(Goal, Tag) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), catch('$lgt_threaded_peek_tagged'(Goal, ExCtx, Tag), Error, '$lgt_runtime_error_handler'(Error)). % threaded_peek(+callable) threaded_peek(Goal) :- \+ '$lgt_prolog_feature'(threads, supported), '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), throw(error(resource_error(threads), logtalk(threaded_peek(Goal), ExCtx))). threaded_peek(Goal) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), catch('$lgt_threaded_peek'(Goal, ExCtx), Error, '$lgt_runtime_error_handler'(Error)). % threaded_cancel(+nonvar) threaded_cancel(Tag) :- \+ '$lgt_prolog_feature'(threads, supported), '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), throw(error(resource_error(threads), logtalk(threaded_cancel(Tag), ExCtx))). threaded_cancel(Tag) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), catch('$lgt_threaded_cancel_tagged'(Tag, ExCtx), Error, '$lgt_runtime_error_handler'(Error)). % threaded_engine_create(@term, @callable, ?nonvar) threaded_engine_create(AnswerTemplate, Goal, Engine) :- \+ '$lgt_prolog_feature'(engines, supported), '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), throw(error(resource_error(engines), logtalk(threaded_engine_create(AnswerTemplate, Goal, Engine), ExCtx))). threaded_engine_create(AnswerTemplate, Goal, Engine) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), catch('$lgt_threaded_engine_create'(AnswerTemplate, Goal, Goal, ExCtx, Engine), Error, '$lgt_runtime_error_handler'(Error)). % threaded_engine_self(?nonvar) threaded_engine_self(Engine) :- \+ '$lgt_prolog_feature'(engines, supported), '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), throw(error(resource_error(engines), logtalk(threaded_engine_self(Engine), ExCtx))). threaded_engine_self(Engine) :- '$lgt_threaded_engine_self'(user, Engine). % threaded_engine(?nonvar) threaded_engine(Engine) :- \+ '$lgt_prolog_feature'(engines, supported), '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), throw(error(resource_error(engines), logtalk(threaded_engine(Engine), ExCtx))). threaded_engine(Engine) :- '$lgt_current_engine'(user, Engine). % threaded_engine_next(@nonvar, ?term) threaded_engine_next(Engine, Answer) :- \+ '$lgt_prolog_feature'(engines, supported), '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), throw(error(resource_error(engines), logtalk(threaded_engine_next(Engine, Answer), ExCtx))). threaded_engine_next(Engine, Answer) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), catch('$lgt_threaded_engine_next'(Engine, Answer, ExCtx), Error, '$lgt_runtime_error_handler'(Error)). % threaded_engine_next_reified(@nonvar, ?term) threaded_engine_next_reified(Engine, Answer) :- \+ '$lgt_prolog_feature'(engines, supported), '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), throw(error(resource_error(engines), logtalk(threaded_engine_next_reified(Engine, Answer), ExCtx))). threaded_engine_next_reified(Engine, Answer) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), catch('$lgt_threaded_engine_next_reified'(Engine, Answer, ExCtx), Error, '$lgt_runtime_error_handler'(Error)). % threaded_engine_yield(@term) threaded_engine_yield(Answer) :- \+ '$lgt_prolog_feature'(engines, supported), '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), throw(error(resource_error(engines), logtalk(threaded_engine_yield(Answer), ExCtx))). threaded_engine_yield(Answer) :- catch('$lgt_threaded_engine_yield'(Answer, user), Error, '$lgt_runtime_error_handler'(Error)). % threaded_engine_post(@nonvar, @term) threaded_engine_post(Engine, Term) :- \+ '$lgt_prolog_feature'(engines, supported), '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), throw(error(resource_error(engines), logtalk(threaded_engine_post(Engine, Term), ExCtx))). threaded_engine_post(Engine, Term) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), catch('$lgt_threaded_engine_post'(Engine, Term, ExCtx), Error, '$lgt_runtime_error_handler'(Error)). % threaded_engine_fetch(?term) threaded_engine_fetch(Term) :- \+ '$lgt_prolog_feature'(engines, supported), '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), throw(error(resource_error(engines), logtalk(threaded_engine_fetch(Term), ExCtx))). threaded_engine_fetch(Term) :- catch('$lgt_threaded_engine_fetch'(Term, user), Error, '$lgt_runtime_error_handler'(Error)). % threaded_engine_destroy(+nonvar) threaded_engine_destroy(Engine) :- \+ '$lgt_prolog_feature'(engines, supported), '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), throw(error(resource_error(engines), logtalk(threaded_engine_destroy(Engine), ExCtx))). threaded_engine_destroy(Engine) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), catch('$lgt_threaded_engine_destroy'(Engine, ExCtx), Error, '$lgt_runtime_error_handler'(Error)). % threaded_wait(?nonvar) threaded_wait(Message) :- \+ '$lgt_prolog_feature'(threads, supported), '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), throw(error(resource_error(threads), logtalk(threaded_wait(Message), ExCtx))). threaded_wait(Message) :- '$lgt_current_object_'(user, Prefix, _, _, _, _, _, _, _, _, _), '$lgt_threaded_wait'(Message, Prefix). % threaded_notify(@term) threaded_notify(Message) :- \+ '$lgt_prolog_feature'(threads, supported), '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), throw(error(resource_error(threads), logtalk(threaded_notify(Message), ExCtx))). threaded_notify(Message) :- '$lgt_current_object_'(user, Prefix, _, _, _, _, _, _, _, _, _), '$lgt_threaded_notify'(Message, Prefix). % compiling and loading built-in predicates % '$lgt_compiler_flag'(+atom, ?nonvar) % % gets/checks the current value of a compiler flag; the default flag % values and the backend Prolog feature flags are cached at startup '$lgt_compiler_flag'(Name, Value) :- ( '$lgt_pp_entity_compiler_flag_'(Name, CurrentValue) -> % flag value as defined within the entity being compiled Value = CurrentValue ; '$lgt_pp_file_compiler_flag_'(Name, CurrentValue) -> % flag value as defined in the flags argument of the % compiling/loading predicates or in the source file Value = CurrentValue ; '$lgt_current_flag_'(Name, Value) % default value for the current Logtalk session, % cached or set by calls to the set_logtalk_flag/2 predicate ). % logtalk_compile(@source_file_name) % logtalk_compile(@list(source_file_name)) % % compiles to disk a source file or list of source files using default flags % % top-level calls use the current working directory for resolving any relative % source file paths while compiled calls in a source file use the source file % directory by default logtalk_compile(Files) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_current_directory'(Directory), '$lgt_logtalk_compile'(Files, Directory, ExCtx). '$lgt_logtalk_compile'(Files, Directory, ExCtx) :- catch( '$lgt_logtalk_compile_files'(Files, Directory), error(Error, _), '$lgt_logtalk_compile_error_handler'(Error, Files, ExCtx) ). '$lgt_logtalk_compile_files'(Files, Directory) :- '$lgt_init_warnings_counter'(logtalk_compile(Files)), '$lgt_check_and_expand_source_files'(Files, ExpandedFiles), '$lgt_compile_files'(ExpandedFiles, ['$relative_to'(Directory)]), '$lgt_report_warning_numbers'(logtalk_compile(Files)), '$lgt_clean_pp_file_clauses'. '$lgt_logtalk_compile_error_handler'(Error, Files, ExCtx) :- '$lgt_clean_pp_file_clauses', '$lgt_clean_pp_entity_clauses', '$lgt_reset_warnings_counter', throw(error(Error, logtalk(logtalk_compile(Files), ExCtx))). % logtalk_compile(@source_file_name, @list(compiler_flag)) % logtalk_compile(@list(source_file_name), @list(compiler_flag)) % % compiles to disk a source file or a list of source files using a list of flags % % top-level calls use the current working directory for resolving any relative % source file paths while compiled calls in a source file use the source file % directory by default % % note that we can only clean the compiler flags after reporting warning numbers as the % report/1 flag might be included in the list of flags but we cannot test for it as its % value should only be used in the default code for printing messages logtalk_compile(Files, Flags) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_current_directory'(Directory), '$lgt_logtalk_compile'(Files, Flags, Directory, ExCtx). '$lgt_logtalk_compile'(Files, Flags, Directory, ExCtx) :- catch( '$lgt_logtalk_compile_files'(Files, Flags, Directory), error(Error, _), '$lgt_logtalk_compile_error_handler'(Error, Files, Flags, ExCtx) ). '$lgt_logtalk_compile_files'(Files, Flags, Directory) :- '$lgt_init_warnings_counter'(logtalk_compile(Files, Flags)), '$lgt_check_and_expand_source_files'(Files, ExpandedFiles), '$lgt_check_compiler_flags'(Flags), ( '$lgt_member'(relative_to(_), Flags) -> '$lgt_compile_files'(ExpandedFiles, Flags) ; '$lgt_compile_files'(ExpandedFiles, ['$relative_to'(Directory)| Flags]) ), '$lgt_report_warning_numbers'(logtalk_compile(Files, Flags)), '$lgt_clean_pp_file_clauses'. '$lgt_logtalk_compile_error_handler'(Error, Files, Flags, ExCtx) :- '$lgt_clean_pp_file_clauses', '$lgt_clean_pp_entity_clauses', '$lgt_reset_warnings_counter', throw(error(Error, logtalk(logtalk_compile(Files, Flags), ExCtx))). % predicates for compilation warning counting and reporting '$lgt_reset_warnings_counter' :- retractall('$lgt_pp_warnings_top_goal_'(_)), retractall('$lgt_pp_compiling_warnings_counter_'(_)), retractall('$lgt_pp_loading_warnings_counter_'(_)). '$lgt_init_warnings_counter'(Goal) :- ( '$lgt_pp_warnings_top_goal_'(_) -> % not top compilation/loading goal; do nothing true ; % remember top compilation/loading goal assertz('$lgt_pp_warnings_top_goal_'(Goal)), % initialize compilation warnings counter retractall('$lgt_pp_compiling_warnings_counter_'(_)), assertz('$lgt_pp_compiling_warnings_counter_'(0)), % initialize loading warnings counter retractall('$lgt_pp_loading_warnings_counter_'(_)), assertz('$lgt_pp_loading_warnings_counter_'(0)) ). '$lgt_increment_compiling_warnings_counter' :- once(retract('$lgt_pp_compiling_warnings_counter_'(Old))), New is Old + 1, assertz('$lgt_pp_compiling_warnings_counter_'(New)). '$lgt_increment_loading_warnings_counter' :- once(retract('$lgt_pp_loading_warnings_counter_'(Old))), New is Old + 1, assertz('$lgt_pp_loading_warnings_counter_'(New)). '$lgt_report_warning_numbers'(Goal) :- ( retract('$lgt_pp_warnings_top_goal_'(Goal)), % top compilation/loading goal retract('$lgt_pp_compiling_warnings_counter_'(CCounter)), retract('$lgt_pp_loading_warnings_counter_'(LCounter)) -> % report compilation and loading warnings '$lgt_print_message'( comment(warnings), compilation_and_loading_warnings(CCounter, LCounter) ) ; % not top compilation/loading goal true ). % '$lgt_check_and_expand_source_files'(@nonvar, -nonvar) % '$lgt_check_and_expand_source_files'(@list, -list) % % check if the source file names are valid (but not if the file exists) % and return their absolute paths when using library notation or when % they start with an environment variable (assumes environment variables % use POSIX syntax in Prolog internal file paths) '$lgt_check_and_expand_source_files'([File| Files], [Path| Paths]) :- !, '$lgt_check_and_expand_source_file'(File, Path), '$lgt_check_and_expand_source_files'(Files, Paths). '$lgt_check_and_expand_source_files'([], []) :- !. '$lgt_check_and_expand_source_files'(File, Path) :- '$lgt_check_and_expand_source_file'(File, Path). '$lgt_check_and_expand_source_file'(File, Path) :- ( atom(File) -> '$lgt_prolog_os_file_name'(NormalizedFile, File), ( sub_atom(NormalizedFile, 0, 1, _, '$') -> '$lgt_expand_path'(NormalizedFile, Path) ; Path = NormalizedFile ) ; compound(File), File =.. [Library, Basename], atom(Basename) -> % library notation '$lgt_prolog_os_file_name'(NormalizedBasename, Basename), ( '$lgt_expand_library_alias'(Library, Directory) -> atom_concat(Directory, NormalizedBasename, Path) ; throw(error(existence_error(library, Library), _)) ) ; % invalid source file specification ground(File) -> throw(error(type_error(source_file_name, File), _)) ; throw(error(instantiation_error, _)) ). % '$lgt_expand_library_alias'(+atom, -atom) % % converts a library alias into its corresponding path; uses a depth % bound to prevent loops (inspired by similar code in SWI-Prolog) '$lgt_expand_library_alias'(Library, Path) :- '$lgt_expand_library_alias'(Library, Path0, 16), % expand the library path into an absolute path as it may % contain environment variables that need to be expanded ( sub_atom(Path0, 0, 1, _, '/') -> % this covers the case of embedded applications created in a POSIX system % and being run on a Windows system where a path starting with a slash % would not be recognized as an absolute path by '$lgt_expand_path'/2 Path1 = Path0 ; '$lgt_expand_path'(Path0, Path1) ), % make sure that the library path ends with a slash ( sub_atom(Path1, _, 1, 0, '/') -> Path = Path1 ; atom_concat(Path1, '/', Path) ). '$lgt_expand_library_alias'(Library, Path, Depth) :- logtalk_library_path(Library, Location), !, ( compound(Location), Location =.. [Prefix, Directory], atom(Directory) -> % assume library notation (a compound term) Depth > 0, NewDepth is Depth - 1, '$lgt_expand_library_alias'(Prefix, PrefixPath0, NewDepth), % make sure that the prefix path ends with a slash ( sub_atom(PrefixPath0, _, 1, 0, '/') -> atom_concat(PrefixPath0, Directory, Path) ; atom_concat(PrefixPath0, '/', PrefixPath1), atom_concat(PrefixPath1, Directory, Path) ) ; atom(Location) -> % assume the final component of the library path Path = Location ; ground(Location) -> throw(error(type_error(library_path, Location), _)) ; throw(error(instantiation_error, _)) ). % '$lgt_check_compiler_flags'(@list) % % checks if the compiler flags are valid '$lgt_check_compiler_flags'([Flag| Flags]) :- !, ( var(Flag) -> throw(error(instantiation_error, _)) ; Flag =.. [Name, Value] -> '$lgt_check'(read_write_flag, Name, _), '$lgt_check'(flag_value, Name+Value, _) ; % invalid flag syntax compound(Flag) -> throw(error(domain_error(compiler_flag, Flag), _)) ; throw(error(type_error(compound, Flag), _)) ), '$lgt_check_compiler_flags'(Flags). '$lgt_check_compiler_flags'([]) :- !. '$lgt_check_compiler_flags'(Flags) :- throw(error(type_error(list, Flags), _)). % '$lgt_set_compiler_flags'(@list) % % sets the compiler flags '$lgt_set_compiler_flags'(Flags) :- '$lgt_assert_compiler_flags'(Flags), % only one of the optimize and debug flags can be turned on at the same time ( '$lgt_member'(optimize(on), Flags) -> retractall('$lgt_pp_file_compiler_flag_'(debug, _)), assertz('$lgt_pp_file_compiler_flag_'(debug, off)) ; '$lgt_member'(debug(on), Flags) -> retractall('$lgt_pp_file_compiler_flag_'(optimize, _)), assertz('$lgt_pp_file_compiler_flag_'(optimize, off)) ; '$lgt_member'(linter(Linter), Flags) -> '$lgt_set_compiler_linter_flag'(Linter) ; true ), ( '$lgt_pp_file_compiler_flag_'(hook, HookEntity) -> % pre-compile hooks in order to speed up entity compilation ( current_object(HookEntity) -> '$lgt_comp_ctx'(Ctx, _, _, user, user, user, HookEntity, _, [], [], ExCtx, runtime, [], _, _), '$lgt_execution_context'(ExCtx, user, user, user, HookEntity, [], []), '$lgt_current_flag_'(events, Events), '$lgt_compile_message_to_object'(term_expansion(Term, Terms), HookEntity, TermExpansionGoal, Events, Ctx), '$lgt_compile_message_to_object'(goal_expansion(Goal, ExpandedGoal), HookEntity, GoalExpansionGoal, Events, Ctx) ; atom(HookEntity), '$lgt_prolog_feature'(modules, supported), current_module(HookEntity) -> TermExpansionGoal = ':'(HookEntity, term_expansion(Term, Terms)), GoalExpansionGoal = ':'(HookEntity, goal_expansion(Goal, ExpandedGoal)) ; throw(error(existence_error(object, HookEntity), _)) ), retractall('$lgt_pp_hook_term_expansion_'(_, _)), assertz(( '$lgt_pp_hook_term_expansion_'(Term, Terms) :- catch(TermExpansionGoal, Error, '$lgt_term_expansion_error'(HookEntity, Term, Error)) )), retractall('$lgt_pp_hook_goal_expansion_'(_, _)), assertz(( '$lgt_pp_hook_goal_expansion_'(Goal, ExpandedGoal) :- catch(GoalExpansionGoal, Error, '$lgt_goal_expansion_error'(HookEntity, Goal, Error)) )) ; true ). % term-expansion errors result in a warning message and a failure '$lgt_term_expansion_error'(HookEntity, Term, Error) :- '$lgt_source_file_context'(File, Lines), '$lgt_increment_loading_warnings_counter', ( '$lgt_pp_entity_'(Type, Entity, _) -> '$lgt_print_message'( warning(expansion), term_expansion_error(File, Lines, Type, Entity, HookEntity, Term, Error) ) ; '$lgt_print_message'( warning(expansion), term_expansion_error(File, Lines, HookEntity, Term, Error) ) ), fail. % goal-expansion errors result in a warning message and a failure '$lgt_goal_expansion_error'(HookEntity, Goal, Error) :- '$lgt_source_file_context'(File, Lines), '$lgt_increment_loading_warnings_counter', ( '$lgt_pp_entity_'(Type, Entity, _) -> '$lgt_print_message'( warning(expansion), goal_expansion_error(File, Lines, Type, Entity, HookEntity, Goal, Error) ) ; '$lgt_print_message'( warning(expansion), goal_expansion_error(File, Lines, HookEntity, Goal, Error) ) ), fail. '$lgt_assert_compiler_flags'([]). '$lgt_assert_compiler_flags'([Flag| Flags]) :- Flag =.. [Name, Value], retractall('$lgt_pp_file_compiler_flag_'(Name, _)), assertz('$lgt_pp_file_compiler_flag_'(Name, Value)), '$lgt_assert_compiler_flags'(Flags). % logtalk_load(@source_file_name) % logtalk_load(@list(source_file_name)) % % compiles to disk and then loads to memory a source file or a list of source % files using default compiler flags % % top-level calls use the current working directory for resolving any relative % source file paths while compiled calls in a source file use the source file % directory by default logtalk_load(Files) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_current_directory'(Directory), '$lgt_logtalk_load'(Files, Directory, ExCtx). '$lgt_logtalk_load'(Files, Directory, ExCtx) :- catch( '$lgt_logtalk_load_files'(Files, Directory), error(Error, _), '$lgt_logtalk_load_error_handler'(Error, Files, ExCtx) ). '$lgt_logtalk_load_files'(Files, Directory) :- '$lgt_init_warnings_counter'(logtalk_load(Files)), '$lgt_check_and_expand_source_files'(Files, ExpandedFiles), '$lgt_load_files'(ExpandedFiles, ['$relative_to'(Directory)]), '$lgt_report_warning_numbers'(logtalk_load(Files)), '$lgt_clean_pp_file_clauses'. '$lgt_logtalk_load_error_handler'(Error, Files, ExCtx) :- '$lgt_clean_pp_file_clauses', '$lgt_clean_pp_entity_clauses', '$lgt_reset_warnings_counter', throw(error(Error, logtalk(logtalk_load(Files), ExCtx))). % logtalk_load(@source_file_name, @list(compiler_flag)) % logtalk_load(@list(source_file_name), @list(compiler_flag)) % % compiles to disk and then loads to memory a source file or a list of source % files using a list of compiler flags % % top-level calls use the current working directory for resolving any relative % source file paths while compiled calls in a source file use the source file % directory by default % % note that we can only clean the compiler flags after reporting warning % numbers as the report/1 flag might be in the list of flags but we cannot % test for it as its value should only be used in the default code for % printing messages logtalk_load(Files, Flags) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_current_directory'(Directory), '$lgt_logtalk_load'(Files, Flags, Directory, ExCtx). '$lgt_logtalk_load'(Files, Flags, Directory, ExCtx) :- catch( '$lgt_logtalk_load_files'(Files, Flags, Directory), error(Error, _), '$lgt_logtalk_load_error_handler'(Error, Files, Flags, ExCtx) ). '$lgt_logtalk_load_files'(Files, Flags, Directory) :- '$lgt_init_warnings_counter'(logtalk_load(Files, Flags)), '$lgt_check_and_expand_source_files'(Files, ExpandedFiles), '$lgt_check_compiler_flags'(Flags), ( '$lgt_member'(relative_to(_), Flags) -> '$lgt_load_files'(ExpandedFiles, Flags) ; '$lgt_load_files'(ExpandedFiles, ['$relative_to'(Directory)| Flags]) ), '$lgt_report_warning_numbers'(logtalk_load(Files, Flags)), '$lgt_clean_pp_file_clauses'. '$lgt_logtalk_load_error_handler'(Error, Files, Flags, ExCtx) :- '$lgt_clean_pp_file_clauses', '$lgt_clean_pp_entity_clauses', '$lgt_reset_warnings_counter', throw(error(Error, logtalk(logtalk_load(Files, Flags), ExCtx))). % logtalk_make % % reloads all Logtalk source files that have been modified since the % time they are last loaded logtalk_make :- logtalk_make(all). % logtalk_make(+atom) % % performs a make target logtalk_make(Target) :- ( var(Target) -> '$lgt_print_message'(warning(make), no_make_target_specified), fail ; '$lgt_valid_logtalk_make_target'(Target) -> '$lgt_logtalk_make'(Target), '$lgt_logtalk_make_target_actions'(Target) ; '$lgt_print_message'(warning(make), invalid_make_target(Target)), fail ). % reload of changed Logtalk source files '$lgt_valid_logtalk_make_target'(all). % recompile files in debug mode '$lgt_valid_logtalk_make_target'(debug). % recompile files in normal mode '$lgt_valid_logtalk_make_target'(normal). % recompile files in optimal mode '$lgt_valid_logtalk_make_target'(optimal). % clean all intermediate Prolog files '$lgt_valid_logtalk_make_target'(clean). % list missing entities and missing predicates '$lgt_valid_logtalk_make_target'(check). % list circular entity references '$lgt_valid_logtalk_make_target'(circular). % generate documentation '$lgt_valid_logtalk_make_target'(documentation). % clean dynamic binding caches '$lgt_valid_logtalk_make_target'(caches). '$lgt_logtalk_make_target_actions'(Target) :- logtalk_make_target_action(Target), fail. '$lgt_logtalk_make_target_actions'(_). % recompilation of source files that failed to load '$lgt_logtalk_make'(all) :- '$lgt_failed_file_'(Path), % the following predicate may no longer be defined depending on what caused the failure '$lgt_pp_file_paths_flags_'(_, _, Path, _, Flags), '$lgt_file_exists'(Path), logtalk_load(Path, Flags), fail. '$lgt_logtalk_make'(all) :- '$lgt_failed_file_'(Path), '$lgt_decompose_file_name'(Path, Directory, Name, Extension), atom_concat(Name, Extension, Basename), '$lgt_loaded_file_'(Basename, Directory, _, Flags, _, _, _), % typically a descendant file failure propagated to a parent file '$lgt_file_exists'(Path), logtalk_load(Path, Flags), fail. % recompilation of changed source files since last loaded '$lgt_logtalk_make'(all) :- '$lgt_loaded_file_'(Basename, Directory, _, Flags, _, _, LoadingTimeStamp), atom_concat(Directory, Basename, Path), '$lgt_file_exists'(Path), '$lgt_file_modification_time'(Path, CurrentTimeStamp), LoadingTimeStamp @< CurrentTimeStamp, \+ '$lgt_member'(reload(skip), Flags), logtalk_load(Path, Flags), fail. % recompilation of included source files since last loaded '$lgt_logtalk_make'(all) :- '$lgt_included_file_'(Path, MainBasename, MainDirectory, LoadingTimeStamp), '$lgt_file_exists'(Path), '$lgt_file_modification_time'(Path, CurrentTimeStamp), LoadingTimeStamp @< CurrentTimeStamp, % force reloading by marking the main file loading as failed atom_concat(MainDirectory, MainBasename, MainPath), assertz('$lgt_failed_file_'(MainPath)), '$lgt_loaded_file_'(MainBasename, MainDirectory, _, Flags, _, ObjectFile, _), % ensure that the main file is recompiled so that it % includes the contents of the modified include file ( '$lgt_file_exists'(ObjectFile) -> '$lgt_delete_file'(ObjectFile) ; true ), '$lgt_file_exists'(MainPath), logtalk_load(MainPath, Flags), fail. % recompilation due to a change to the compilation mode (e.g., from "normal" to "debug") '$lgt_logtalk_make'(all) :- % find all files impacted by a change to compilation mode (this excludes all files % that are compiled with an explicit compilation mode set using the corresponding % compiler option) findall( file(Path, Flags), ( '$lgt_loaded_file_'(Basename, Directory, Mode, Flags, _, _, _), '$lgt_changed_compilation_mode'(Mode, Flags), atom_concat(Directory, Basename, Path) ), Files ), % filter files that will be reloaded by a parent file that will also be reloaded '$lgt_member'(file(Path,Flags), Files), \+ ( '$lgt_parent_file_'(Path, Parent), '$lgt_member'(file(Parent,_), Files) ), '$lgt_file_exists'(Path), logtalk_load(Path, Flags), fail. '$lgt_logtalk_make'(all) :- '$lgt_print_message'(comment(make), modified_files_reloaded). '$lgt_logtalk_make'(debug) :- '$lgt_print_message'(comment(make), reload_files_in_mode(debug)), '$lgt_set_compiler_flag'(debug, on), '$lgt_logtalk_make'(all). '$lgt_logtalk_make'(normal) :- '$lgt_print_message'(comment(make), reload_files_in_mode(normal)), '$lgt_set_compiler_flag'(debug, off), '$lgt_set_compiler_flag'(optimize, off), '$lgt_logtalk_make'(all). '$lgt_logtalk_make'(optimal) :- '$lgt_print_message'(comment(make), reload_files_in_mode(optimal)), '$lgt_set_compiler_flag'(optimize, on), '$lgt_logtalk_make'(all). '$lgt_logtalk_make'(clean) :- '$lgt_loaded_file_'(_, _, _, _, _, ObjectFile, _), '$lgt_delete_intermediate_files'(ObjectFile), fail. '$lgt_logtalk_make'(clean) :- '$lgt_print_message'(comment(make), intermediate_files_deleted). '$lgt_logtalk_make'(check) :- '$lgt_print_message'(comment(make), scanning_for_missing_entities_predicates), setof(Protocol, '$lgt_missing_protocol'(Protocol), Protocols), '$lgt_print_message'(warning(make), missing_protocols(Protocols)), fail. '$lgt_logtalk_make'(check) :- setof(Category, '$lgt_missing_category'(Category), Categories), '$lgt_print_message'(warning(make), missing_categories(Categories)), fail. '$lgt_logtalk_make'(check) :- setof(Object, '$lgt_missing_object'(Object), Objects), '$lgt_print_message'(warning(make), missing_objects(Objects)), fail. '$lgt_logtalk_make'(check) :- '$lgt_prolog_feature'(modules, supported), setof(Module, '$lgt_missing_module'(Module), Modules), '$lgt_print_message'(warning(make), missing_modules(Modules)), fail. '$lgt_logtalk_make'(check) :- setof(Predicate, '$lgt_missing_predicate'(Predicate), Predicates), '$lgt_print_message'(warning(make), missing_predicates(Predicates)), fail. '$lgt_logtalk_make'(check) :- '$lgt_print_message'(comment(make), completed_scanning_for_missing_entities_predicates), fail. '$lgt_logtalk_make'(check) :- '$lgt_print_message'(comment(make), scanning_for_duplicated_library_aliases), findall(Alias, logtalk_library_path(Alias, _), Aliases), setof(Duplicate, Rest^('$lgt_select'(Duplicate, Aliases, Rest), '$lgt_member'(Duplicate, Rest)), Duplicates), '$lgt_print_message'(warning(make), duplicated_library_aliases(Duplicates)), fail. '$lgt_logtalk_make'(check) :- '$lgt_print_message'(comment(make), scanning_for_library_paths_end_slash), findall(Alias-Path, (logtalk_library_path(Alias, Path), atom(Path), \+ sub_atom(Path, _, 1, 0, '/')), Paths), Paths \== [], '$lgt_print_message'(warning(make), library_paths_dont_end_with_slash(Paths)), fail. '$lgt_logtalk_make'(check) :- '$lgt_print_message'(comment(make), completed_scanning_of_library_alias_definitions). '$lgt_logtalk_make'(circular) :- '$lgt_print_message'(comment(make), scanning_for_circular_dependencies), setof(CircularReference, '$lgt_circular_reference'(CircularReference), CircularReferences), '$lgt_print_message'(warning(make), circular_references(CircularReferences)), fail. '$lgt_logtalk_make'(circular) :- '$lgt_print_message'(comment(make), completed_scanning_for_circular_dependencies). '$lgt_logtalk_make'(documentation) :- '$lgt_print_message'(comment(make), running_all_defined_documentation_actions). '$lgt_logtalk_make'(caches) :- '$lgt_clean_lookup_caches', '$lgt_print_message'(comment(make), dynamic_binding_caches_deleted). % deal with changes to the default compilation mode % when no explicit compilation mode as specified '$lgt_changed_compilation_mode'(debug, Flags) :- \+ '$lgt_member'(debug(_), Flags), \+ '$lgt_compiler_flag'(debug, on). '$lgt_changed_compilation_mode'(optimal, Flags) :- \+ '$lgt_member'(optimize(_), Flags), \+ '$lgt_compiler_flag'(optimize, on). '$lgt_changed_compilation_mode'(normal, _) :- ( '$lgt_compiler_flag'(debug, on) -> true ; '$lgt_compiler_flag'(optimize, on) ). % find missing entities for logtalk_make(check) '$lgt_missing_protocol'(Protocol-Reference) :- '$lgt_implements_protocol_'(Entity, Protocol, _), \+ '$lgt_current_protocol_'(Protocol, _, _, _, _), '$lgt_missing_reference'(Entity, Reference). '$lgt_missing_protocol'(Protocol-Reference) :- '$lgt_extends_protocol_'(Entity, Protocol, _), \+ '$lgt_current_protocol_'(Protocol, _, _, _, _), '$lgt_missing_reference'(Entity, Reference). '$lgt_missing_category'(Category-Reference) :- '$lgt_imports_category_'(Entity, Category, _), \+ '$lgt_current_category_'(Category, _, _, _, _, _), '$lgt_missing_reference'(Entity, Reference). '$lgt_missing_category'(Category-Reference) :- '$lgt_extends_category_'(Entity, Category, _), \+ '$lgt_current_category_'(Category, _, _, _, _, _), '$lgt_missing_reference'(Entity, Reference). '$lgt_missing_object'(Object-Reference) :- '$lgt_extends_object_'(Entity, Object, _), \+ '$lgt_current_object_'(Object, _, _, _, _, _, _, _, _, _, _), '$lgt_missing_reference'(Entity, Reference). '$lgt_missing_object'(Object-Reference) :- '$lgt_instantiates_class_'(Entity, Object, _), \+ '$lgt_current_object_'(Object, _, _, _, _, _, _, _, _, _, _), '$lgt_missing_reference'(Entity, Reference). '$lgt_missing_object'(Object-Reference) :- '$lgt_specializes_class_'(Entity, Object, _), \+ '$lgt_current_object_'(Object, _, _, _, _, _, _, _, _, _, _), '$lgt_missing_reference'(Entity, Reference). '$lgt_missing_object'(Object-Reference) :- '$lgt_complemented_object_'(Object, Entity, _, _, _), \+ '$lgt_current_object_'(Object, _, _, _, _, _, _, _, _, _, _), '$lgt_missing_reference'(Entity, Reference). '$lgt_missing_object'(Object-Reference) :- '$lgt_entity_property_'(Entity, calls(Object::_, _, _, _, Location)), % note that the next call always fails when Object is not bound \+ '$lgt_current_object_'(Object, _, _, _, _, _, _, _, _, _, _), '$lgt_missing_reference'(Entity, Location, Reference). '$lgt_missing_module'(Module-Reference) :- '$lgt_entity_property_'(Entity, calls(':'(Module,_), _, _, _, Location)), % note that the next call always fails when Module is not bound; % given the call, assume that the backend compiler supports modules \+ current_module(Module), '$lgt_missing_reference'(Entity, Location, Reference). % find missing predicates for logtalk_make(check) '$lgt_missing_predicate'((Object::Predicate)-Reference) :- '$lgt_entity_property_'(Entity, calls(Object::Predicate, _, _, _, Location)), % the object may only be known at runtime; reject those cases nonvar(Object), % require loaded objects as the missing objects are already listed '$lgt_current_object_'(Object, _, _, _, _, _, _, _, _, _, _), % ignore objects that can forward the predicates calls \+ '$lgt_implements_protocol_'(Object, forwarding, _), \+ '$lgt_current_predicate'(Object, Predicate, Entity, p(p(p)), _), '$lgt_missing_reference'(Entity, Location, Reference). '$lgt_missing_predicate'((^^Functor/Arity)-Reference) :- '$lgt_entity_property_'(Entity, calls(^^Functor/Arity, _, _, _, Location)), functor(Template, Functor, Arity), ( '$lgt_current_object_'(Entity, _, Dcl, _, _, IDcl, _, _, _, _, _) -> ( \+ '$lgt_instantiates_class_'(Entity, _, _), \+ '$lgt_specializes_class_'(Entity, _, _) -> % prototype \+ call(Dcl, Template, _, _, _, _, _) ; % instance and/or class \+ call(Dcl, Template, _, _, _, _, _), \+ call(IDcl, Template, _, _, _, _, _) ) ; '$lgt_current_category_'(Entity, _, Dcl, _, _, _), \+ call(Dcl, Template, _, _, _, _) ), '$lgt_missing_reference'(Entity, Location, Reference). '$lgt_missing_predicate'((::Functor/Arity)-Reference) :- '$lgt_entity_property_'(Entity, calls(::Functor/Arity, _, _, _, Location)), functor(Template, Functor, Arity), ( '$lgt_current_object_'(Entity, _, Dcl, _, _, IDcl, _, _, _, _, _) -> ( \+ '$lgt_instantiates_class_'(Entity, _, _), \+ '$lgt_specializes_class_'(Entity, _, _) -> % prototype \+ call(Dcl, Template, _, _, _, _, _) ; % instance and/or class \+ call(Dcl, Template, _, _, _, _, _), \+ call(IDcl, Template, _, _, _, _, _) ) ; '$lgt_current_category_'(Entity, _, Dcl, _, _, _), \+ call(Dcl, Template, _, _, _, _) ), '$lgt_missing_reference'(Entity, Location, Reference). '$lgt_missing_predicate'((Functor/Arity)-Reference) :- '$lgt_entity_property_'(Entity, calls(Functor/Arity, _, _, _, Location)), ( '$lgt_current_object_'(Entity, _, Dcl, Def, _, _, _, DDcl, DDef, _, Flags) -> \+ '$lgt_object_property_declares'(Entity, Dcl, DDcl, Flags, Functor/Arity, _), \+ '$lgt_object_property_defines'(Entity, Def, DDef, Functor/Arity, Flags, _) ; '$lgt_current_category_'(Entity, _, Dcl, Def, _, Flags), \+ '$lgt_category_property_declares'(Entity, Dcl, Functor/Arity, _), \+ '$lgt_category_property_defines'(Entity, Def, Functor/Arity, Flags, _) ), '$lgt_missing_reference'(Entity, Location, Reference). '$lgt_missing_predicate'((':'(Module,Predicate))-Reference) :- '$lgt_prolog_feature'(modules, supported), '$lgt_entity_property_'(Entity, calls(':'(Module,Predicate), _, _, _, Location)), % the module may only be known at runtime; reject those cases nonvar(Module), % require loaded modules as the missing modules are already listed current_module(Module), \+ '$lgt_current_module_predicate'(Module, Predicate), '$lgt_missing_reference'(Entity, Location, Reference). % construct reference term for missing entities and predicates '$lgt_missing_reference'(Entity, reference(Kind,Entity,Path,StartLine)) :- % find the entity type ( '$lgt_current_protocol_'(Entity, _, _, _, _) -> Kind = protocol ; '$lgt_current_category_'(Entity, _, _, _, _, _) -> Kind = category ; '$lgt_current_object_'(Entity, _, _, _, _, _, _, _, _, _, _), Kind = object ), % find the reference file and line ( '$lgt_entity_property_'(Entity, file_lines(File, Directory, StartLine, _)) -> atom_concat(Directory, File, Path) ; % dynamically created entity Path = '', StartLine = -1 ). '$lgt_missing_reference'(Entity, Location, reference(Kind,Entity,Path,StartLine)) :- % find the entity type ( '$lgt_current_protocol_'(Entity, _, _, _, _) -> Kind = protocol ; '$lgt_current_category_'(Entity, _, _, _, _, _) -> Kind = category ; '$lgt_current_object_'(Entity, _, _, _, _, _, _, _, _, _, _), Kind = object ), % find the reference file and line ( Location = include(Path, StartLine-_) -> % reference found in included file true ; Location = StartLine-_, ( '$lgt_entity_property_'(Entity, file_lines(File, Directory, _, _)) -> atom_concat(Directory, File, Path) ; % dynamically created entity Path = '' ) ). % find circular dependencies for logtalk_make(circular); we only check % for mutual and triangular dependencies due to the computational cost '$lgt_circular_reference'((Object1-Object2)-references([Path1-Line1,Path2-Line2])) :- '$lgt_current_object_'(Object1, _, _, _, _, _, _, _, _, _, _), '$lgt_current_object_'(Object2, _, _, _, _, _, _, _, _, _, _), Object1 \== Object2, functor(Object1, Functor1, Arity1), functor(Object2, Functor2, Arity2), Functor1-Arity1 @< Functor2-Arity2, ( '$lgt_entity_property_'(Object1, calls(Entity2::_, _, _, _, Line1)), nonvar(Entity2), Entity2 = Object2, '$lgt_entity_property_'(Object2, calls(Entity1::_, _, _, _, Line2)), nonvar(Entity1), Entity1 = Object1 -> true ; fail ), '$lgt_circular_reference_object_path'(Object1, Path1), '$lgt_circular_reference_object_path'(Object2, Path2). '$lgt_circular_reference'((Object1-Object2-Object3)-references([Path1-Line1,Path2-Line2,Path3-Line3])) :- '$lgt_current_object_'(Object1, _, _, _, _, _, _, _, _, _, _), '$lgt_current_object_'(Object2, _, _, _, _, _, _, _, _, _, _), Object1 \== Object2, '$lgt_current_object_'(Object3, _, _, _, _, _, _, _, _, _, _), Object1 \== Object3, Object2 \== Object3, functor(Object1, Functor1, Arity1), functor(Object2, Functor2, Arity2), Functor1-Arity1 @< Functor2-Arity2, functor(Object3, Functor3, Arity3), Functor2-Arity2 @< Functor3-Arity3, ( '$lgt_entity_property_'(Object1, calls(Entity2::_, _, _, _, Line1)), nonvar(Entity2), Entity2 = Object2, '$lgt_entity_property_'(Object2, calls(Entity3::_, _, _, _, Line2)), nonvar(Entity3), Entity3 = Object3, '$lgt_entity_property_'(Object3, calls(Entity1::_, _, _, _, Line3)), nonvar(Entity1), Entity1 = Object1 -> true ; fail ), '$lgt_circular_reference_object_path'(Object1, Path1), '$lgt_circular_reference_object_path'(Object2, Path2), '$lgt_circular_reference_object_path'(Object3, Path3). '$lgt_circular_reference_object_path'(Object, Path) :- ( '$lgt_entity_property_'(Object, file_lines(File, Directory, _, _)) -> atom_concat(Directory, File, Path) ; Path = '' ). % logtalk_load_context(?atom, ?nonvar) % % provides access to the compilation/loading context % % this predicate is the Logtalk version of the prolog_load_context/2 % predicate found on some compilers such as Quintus Prolog, SICStus % Prolog, SWI-Prolog, and YAP % % when called from initialization/1 directives, calls to this predicate % are resolved at compile-time when the key is instantiated logtalk_load_context(Key, Value) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_logtalk_load_context'(Key, Value, ExCtx). '$lgt_logtalk_load_context'(Key, Value, ExCtx) :- ( var(Key) -> '$lgt_logtalk_load_context_checked'(Key, Value) ; '$lgt_valid_logtalk_load_context_key'(Key) -> '$lgt_logtalk_load_context_checked'(Key, Value) ; callable(Key) -> throw(error(domain_error(logtalk_load_context_key, Key), logtalk(logtalk_load_context(Key, Value), ExCtx))) ; throw(error(type_error(callable, Key), logtalk(logtalk_load_context(Key, Value), ExCtx))) ). '$lgt_logtalk_load_context_checked'(source, SourceFile) :- '$lgt_pp_file_paths_flags_'(_, _, SourceFile, _, _). '$lgt_logtalk_load_context_checked'(directory, Directory) :- '$lgt_pp_file_paths_flags_'(_, Directory, _, _, _). '$lgt_logtalk_load_context_checked'(basename, Basename) :- '$lgt_pp_file_paths_flags_'(Basename, _, _, _, _). '$lgt_logtalk_load_context_checked'(target, ObjectFile) :- % full path of the generated intermediate Prolog file '$lgt_pp_file_paths_flags_'(_, _, _, ObjectFile, _). '$lgt_logtalk_load_context_checked'(flags, Flags) :- % only returns the explicit flags passed in the second argument % of the logtalk_compile/2 and logtalk_load/2 predicates '$lgt_pp_file_paths_flags_'(_, _, _, _, Flags). '$lgt_logtalk_load_context_checked'(entity_name, Entity) :- % deprecated key; use entity_identifier key instead '$lgt_pp_entity_'(_, Entity, _). '$lgt_logtalk_load_context_checked'(entity_identifier, Entity) :- '$lgt_pp_entity_'(_, Entity, _). '$lgt_logtalk_load_context_checked'(entity_prefix, Prefix) :- '$lgt_pp_entity_'(_, _, Prefix). '$lgt_logtalk_load_context_checked'(entity_type, Type) :- ( '$lgt_pp_module_'(_) -> Type = module ; '$lgt_pp_entity_'(Type, _, _) ). '$lgt_logtalk_load_context_checked'(entity_relation, Relation) :- '$lgt_logtalk_load_context_entity_relation'(Relation). '$lgt_logtalk_load_context_checked'(term, Term) :- % full file term being compiled '$lgt_pp_term_source_data_'(Term, _, _, _, _). '$lgt_logtalk_load_context_checked'(variables, Variables) :- % variables of the full file term being compiled '$lgt_pp_term_source_data_'(Term, _, _, _, _), term_variables(Term, Variables). '$lgt_logtalk_load_context_checked'(variable_names, VariableNames) :- % variable names for the full file term being compiled '$lgt_pp_term_source_data_'(_, VariableNames, _, _, _). '$lgt_logtalk_load_context_checked'(variable_names(Term), VariableNames) :- % variable names for the full file term being compiled '$lgt_pp_term_source_data_'(Term, VariableNames, _, _, _). '$lgt_logtalk_load_context_checked'(singletons, Singletons) :- % singleton variables in the full file term being compiled '$lgt_pp_term_source_data_'(_, _, Singletons, _, _). '$lgt_logtalk_load_context_checked'(singletons(Term), Singletons) :- % singleton variables in the full file term being compiled '$lgt_pp_term_source_data_'(Term, _, Singletons, _, _). '$lgt_logtalk_load_context_checked'(parameter_variables, ParameterVariablePairs) :- % only succeeds when compiling a parametric entity containing parameter variables '$lgt_pp_parameter_variables_'(ParameterVariablePairs). '$lgt_logtalk_load_context_checked'(file, File) :- % when compiling terms from an included file, this key returns the full % path of the included file unlike the "source" key which always returns % the full path of the main file '$lgt_pp_term_source_data_'(_, _, _, File, _). '$lgt_logtalk_load_context_checked'(term_position, Lines) :- % term position of the full file term being compiled '$lgt_pp_term_source_data_'(_, _, _, _, Lines). '$lgt_logtalk_load_context_checked'(stream, Stream) :- % avoid a spurious choice-point with some backend Prolog compilers stream_property(Stream, alias(logtalk_compiler_input)), !. '$lgt_logtalk_load_context_entity_relation'(extends_protocol(Ptc, ExtPtc, Scope)) :- '$lgt_pp_extended_protocol_'(ExtPtc, Ptc, _, _, Scope). '$lgt_logtalk_load_context_entity_relation'(implements_protocol(ObjOrCtg, Ptc, Scope)) :- '$lgt_pp_implemented_protocol_'(Ptc, ObjOrCtg, _, _, Scope). '$lgt_logtalk_load_context_entity_relation'(extends_category(Ctg, ExtCtg, Scope)) :- '$lgt_pp_extended_category_'(ExtCtg, Ctg, _, _, _, Scope). '$lgt_logtalk_load_context_entity_relation'(imports_category(Obj, Ctg, Scope)) :- '$lgt_pp_imported_category_'(Ctg, Obj, _, _, _, Scope). '$lgt_logtalk_load_context_entity_relation'(extends_object(Prototype, Parent, Scope)) :- '$lgt_pp_extended_object_'(Parent, Prototype, _, _, _, _, _, _, _, _, Scope). '$lgt_logtalk_load_context_entity_relation'(instantiates_class(Obj, Class, Scope)) :- '$lgt_pp_instantiated_class_'(Class, Obj, _, _, _, _, _, _, _, _, Scope). '$lgt_logtalk_load_context_entity_relation'(specializes_class(Class, Superclass, Scope)) :- '$lgt_pp_specialized_class_'(Superclass, Class, _, _, _, _, _, _, _, _, Scope). '$lgt_logtalk_load_context_entity_relation'(complements_object(Ctg, Obj)) :- '$lgt_pp_complemented_object_'(Obj, Ctg, _, _, _). % lgt_valid_logtalk_load_context_key(@nonvar) '$lgt_valid_logtalk_load_context_key'(entity_identifier). '$lgt_valid_logtalk_load_context_key'(entity_prefix). '$lgt_valid_logtalk_load_context_key'(entity_type). '$lgt_valid_logtalk_load_context_key'(entity_relation). '$lgt_valid_logtalk_load_context_key'(source). '$lgt_valid_logtalk_load_context_key'(file). '$lgt_valid_logtalk_load_context_key'(basename). '$lgt_valid_logtalk_load_context_key'(directory). '$lgt_valid_logtalk_load_context_key'(stream). '$lgt_valid_logtalk_load_context_key'(target). '$lgt_valid_logtalk_load_context_key'(flags). '$lgt_valid_logtalk_load_context_key'(term). '$lgt_valid_logtalk_load_context_key'(term_position). '$lgt_valid_logtalk_load_context_key'(variables). '$lgt_valid_logtalk_load_context_key'(parameter_variables). '$lgt_valid_logtalk_load_context_key'(variable_names). '$lgt_valid_logtalk_load_context_key'(variable_names(_)). '$lgt_valid_logtalk_load_context_key'(singletons). '$lgt_valid_logtalk_load_context_key'(singletons(_)). % set_logtalk_flag(+atom, +nonvar) % % sets a global flag value % % global flag values can always be overridden when compiling and loading source % files by using either a set_logtalk_flag/2 directive (whose scope is local to % the file or the entity containing it) or by passing a list of flag values in % the calls to the logtalk_compile/2 and logtalk_load/2 predicates set_logtalk_flag(Flag, Value) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_set_logtalk_flag'(Flag, Value, ExCtx). '$lgt_set_logtalk_flag'(Flag, Value, ExCtx) :- '$lgt_check'(read_write_flag, Flag, logtalk(set_logtalk_flag(Flag, Value), ExCtx)), '$lgt_check'(flag_value, Flag + Value, logtalk(set_logtalk_flag(Flag, Value), ExCtx)), '$lgt_set_compiler_flag'(Flag, Value). '$lgt_set_compiler_flag'(optimize, Value) :- !, retractall('$lgt_current_flag_'(optimize, _)), assertz('$lgt_current_flag_'(optimize, Value)), '$lgt_clean_lookup_caches', % only one of the optimize and debug flags can be turned on at the same time ( Value == on -> retractall('$lgt_current_flag_'(debug, _)), assertz('$lgt_current_flag_'(debug, off)) ; true ). '$lgt_set_compiler_flag'(debug, Value) :- !, retractall('$lgt_current_flag_'(debug, _)), assertz('$lgt_current_flag_'(debug, Value)), '$lgt_clean_lookup_caches', % only one of the optimize and debug flags can be turned on at the same time ( Value == on -> retractall('$lgt_current_flag_'(optimize, _)), assertz('$lgt_current_flag_'(optimize, off)) ; true ). '$lgt_set_compiler_flag'(hook, Value) :- !, retractall('$lgt_current_flag_'(hook, _)), assertz('$lgt_current_flag_'(hook, Value)), % pre-compile hook calls for better performance when compiling files '$lgt_compile_hooks'(Value). '$lgt_set_compiler_flag'(linter, Value) :- !, '$lgt_set_compiler_linter_flag'(Value). '$lgt_set_compiler_flag'(Flag, Value) :- retractall('$lgt_current_flag_'(Flag, _)), assertz('$lgt_current_flag_'(Flag, Value)). '$lgt_set_compiler_linter_flag'(on) :- forall( '$lgt_linter_flag'(Flag), '$lgt_set_compiler_flag'(Flag, warning) ). '$lgt_set_compiler_linter_flag'(default) :- forall( '$lgt_linter_flag'(Flag), ( '$lgt_default_flag'(Flag, Default), '$lgt_set_compiler_flag'(Flag, Default) ) ). '$lgt_set_compiler_linter_flag'(off) :- forall( '$lgt_linter_flag'(Flag), '$lgt_set_compiler_flag'(Flag, silent) ). % current_logtalk_flag(?atom, ?nonvar) % % tests/gets flag values current_logtalk_flag(Flag, Value) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_current_logtalk_flag'(Flag, Value, ExCtx). '$lgt_current_logtalk_flag'(Flag, Value, ExCtx) :- ( var(Flag) -> % enumerate, by backtracking, existing flags ( '$lgt_valid_flag'(Flag) ; '$lgt_user_defined_flag_'(Flag, _, _) ), '$lgt_compiler_flag'(Flag, Value) ; '$lgt_valid_flag'(Flag) -> '$lgt_compiler_flag'(Flag, Value) ; '$lgt_user_defined_flag_'(Flag, _, _) -> '$lgt_compiler_flag'(Flag, Value) ; % invalid flag; generate error '$lgt_check'(flag, Flag, logtalk(current_logtalk_flag(Flag, Value), ExCtx)) ). % create_logtalk_flag(+atom, +ground, +list) % % creates a new flag % % based on the specification of the create_prolog_flag/3 % built-in predicate of SWI-Prolog create_logtalk_flag(Flag, Value, Options) :- '$lgt_execution_context'(ExCtx, user, user, user, user, [], []), '$lgt_create_logtalk_flag'(Flag, Value, Options, ExCtx). '$lgt_create_logtalk_flag'(Flag, Value, Options, ExCtx) :- '$lgt_check'(atom, Flag, logtalk(create_logtalk_flag(Flag, Value, Options), ExCtx)), '$lgt_check'(ground, Value, logtalk(create_logtalk_flag(Flag, Value, Options), ExCtx)), '$lgt_check'(ground, Options, logtalk(create_logtalk_flag(Flag, Value, Options), ExCtx)), '$lgt_check'(list, Options, logtalk(create_logtalk_flag(Flag, Value, Options), ExCtx)), fail. '$lgt_create_logtalk_flag'(Flag, Value, Options, ExCtx) :- '$lgt_valid_flag'(Flag), throw(error(permission_error(modify,flag,Flag), logtalk(create_logtalk_flag(Flag, Value, Options), ExCtx))). '$lgt_create_logtalk_flag'(Flag, Value, Options, ExCtx) :- '$lgt_member'(Option, Options), Option \= access(_), Option \= keep(_), Option \= type(_), throw(error(domain_error(flag_option,Option), logtalk(create_logtalk_flag(Flag, Value, Options), ExCtx))). '$lgt_create_logtalk_flag'(Flag, Value, Options, ExCtx) :- '$lgt_member'(access(Access), Options), Access \== read_write, Access \== read_only, throw(error(domain_error(flag_option,access(Access)), logtalk(create_logtalk_flag(Flag, Value, Options), ExCtx))). '$lgt_create_logtalk_flag'(Flag, Value, Options, ExCtx) :- '$lgt_member'(keep(Keep), Options), Keep \== true, Keep \== false, throw(error(domain_error(flag_option,keep(Keep)), logtalk(create_logtalk_flag(Flag, Value, Options), ExCtx))). '$lgt_create_logtalk_flag'(Flag, Value, Options, ExCtx) :- '$lgt_member'(type(Type0), Options), ( '$lgt_map_user_defined_flag_type'(Type0, Type) -> ( call(Type, Value) -> fail ; throw(error(type_error(Type0,Value), logtalk(create_logtalk_flag(Flag, Value, Options), ExCtx))) ) ; throw(error(domain_error(flag_option,type(Type0)), logtalk(create_logtalk_flag(Flag, Value, Options), ExCtx))) ). '$lgt_create_logtalk_flag'(Flag, _, Options, _) :- '$lgt_user_defined_flag_'(Flag, _, _), '$lgt_member'(keep(true), Options), !. '$lgt_create_logtalk_flag'(Flag, Value, Options, _) :- ( '$lgt_member'(access(Access), Options) -> true ; Access = read_write ), ( '$lgt_member'(type(Type0), Options) -> '$lgt_map_user_defined_flag_type'(Type0, Type) ; % infer type from the initial value Value == true -> Type = '$lgt_is_boolean' ; Value == false -> Type = '$lgt_is_boolean' ; atom(Value) -> Type = atom ; integer(Value) -> Type = integer ; float(Value) -> Type = float ; % catchall Type = ground ), retractall('$lgt_user_defined_flag_'(Flag, _, _)), assertz('$lgt_user_defined_flag_'(Flag, Access, Type)), retractall('$lgt_current_flag_'(Flag, _)), assertz('$lgt_current_flag_'(Flag, Value)). % map the flag type to a closure that can be called with the flag % value as argument for type-checking '$lgt_map_user_defined_flag_type'(boolean, '$lgt_is_boolean'). '$lgt_map_user_defined_flag_type'(atom, atom). '$lgt_map_user_defined_flag_type'(integer, integer). '$lgt_map_user_defined_flag_type'(float, float). '$lgt_map_user_defined_flag_type'(term, ground). % '$lgt_version_data'(?compound) % % current Logtalk version for use with the current_logtalk_flag/2 predicate % % the last argument is an atom: 'aNN' for alpha versions, 'bNN' for beta % versions, 'rcNN' for release candidates (with N being a decimal digit), % and 'stable' for stable versions '$lgt_version_data'(logtalk(3, 86, 0, stable)). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % built-in methods % % calls to these methods are always compiled % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % '$lgt_object_exists'(@var, +callable, +execution_context) % '$lgt_object_exists'(+object_identifier, +callable, +execution_context) % % checks if an object exists at runtime; this is necessary in order to % prevent trivial messages such as true/0 or repeat/0 from succeeding % when the target object doesn't exist; used in the compilation of ::/2 % calls '$lgt_object_exists'(Obj, Pred, ExCtx) :- ( var(Obj) -> throw(error(instantiation_error, logtalk(Obj::Pred, ExCtx))) ; '$lgt_current_object_'(Obj, _, _, _, _, _, _, _, _, _, _) -> true ; % we have already verified that we have is a valid object identifier % when we generated calls to this predicate throw(error(existence_error(object, Obj), logtalk(Obj::Pred, ExCtx))) ). % '$lgt_current_op'(+object_identifier, ?operator_priority, ?operator_specifier, ?atom, +object_identifier, +scope, @execution_context) % % current_op/3 built-in method % % local operator declarations without a scope declaration are invisible '$lgt_current_op'(Obj, Priority, Specifier, Operator, Sender, Scope, ExCtx) :- '$lgt_check'(object, Obj, logtalk(Obj::current_op(Priority, Specifier, Operator), ExCtx)), '$lgt_check'(var_or_operator_priority, Priority, logtalk(current_op(Priority, Specifier, Operator), ExCtx)), '$lgt_check'(var_or_operator_specifier, Specifier, logtalk(current_op(Priority, Specifier, Operator), ExCtx)), '$lgt_check'(var_or_atom, Operator, logtalk(current_op(Priority, Specifier, Operator), ExCtx)), ( Obj == user -> current_op(Priority, Specifier, Operator) ; '$lgt_entity_property_'(Obj, op(Priority, Specifier, Operator, OpScope)), % don't return local operator declarations OpScope \== l, % check that the operator declaration is within the scope of the caller \+ \+ (OpScope = Scope; Obj = Sender) ; % also return global operators that aren't overridden by entity operators current_op(Priority, Specifier, Operator), \+ ( '$lgt_entity_property_'(Obj, op(_, OtherSpecifier, Operator, _)), '$lgt_same_operator_class'(Specifier, OtherSpecifier) ) ). % '$lgt_current_predicate'(+object_identifier, ?predicate_indicator, +object_identifier, +scope, @execution_context) % % current_predicate/1 built-in method % % local predicates without a scope declaration are invisible '$lgt_current_predicate'(Obj, Pred, _, _, ExCtx) :- '$lgt_check'(var_or_predicate_indicator, Pred, logtalk(current_predicate(Pred), ExCtx)), '$lgt_check'(object, Obj, logtalk(Obj::current_predicate(Pred), ExCtx)), fail. '$lgt_current_predicate'(user, Pred, _, _, _) :- !, current_predicate(Pred). '$lgt_current_predicate'(Obj, Functor/Arity, Obj, _, ExCtx) :- ground(Functor/Arity), functor(Head, Functor, Arity), '$lgt_comp_ctx'(Ctx, _, _, Entity, _, _, _, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, _, Entity), ( '$lgt_uses_predicate_'(Entity, _, _, Head, Ctx) ; '$lgt_use_module_predicate_'(Entity, _, _, Head, Ctx) ), !. '$lgt_current_predicate'(Obj, Functor/Arity, Sender, LookupScope, _) :- ground(Functor/Arity), !, % make the current_predicate/1 method deterministic when its argument is ground '$lgt_current_object_'(Obj, _, Dcl, _, _, _, _, _, _, _, _), ( call(Dcl, Pred, PredScope, _, _, SCtn, _), functor(Pred, Functor, Arity) -> % commit to the first solution found as an inherited % predicate can always be re-declared ( \+ \+ PredScope = LookupScope -> true ; Sender = SCtn ) ; fail ). '$lgt_current_predicate'(Obj, Functor/Arity, Sender, LookupScope, _) :- '$lgt_current_object_'(Obj, _, Dcl, _, _, _, _, _, _, _, _), % use findall/3 + sort/2 to avoid a setof/3 call with five % existentially-qualified variables or an auxiliary predicate findall(Functor/Arity, (call(Dcl, Pred, _, _, _, _, _), functor(Pred, Functor, Arity)), Preds), sort(Preds, SortedPreds), '$lgt_member'(Functor/Arity, SortedPreds), functor(Pred, Functor, Arity), ( call(Dcl, Pred, PredScope, _, _, SCtn, _) -> % commit to the first solution found as an inherited % predicate can always be re-declared ( \+ \+ PredScope = LookupScope -> true ; Sender = SCtn ) ; fail ). '$lgt_current_predicate'(Obj, Functor/Arity, Obj, _, ExCtx) :- '$lgt_comp_ctx'(Ctx, _, _, Entity, _, _, _, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, _, Entity), ( '$lgt_uses_predicate_'(Entity, _, _, Head, Ctx) ; '$lgt_use_module_predicate_'(Entity, _, _, Head, Ctx) ), functor(Head, Functor, Arity). % '$lgt_predicate_property'(+object_identifier, @callable, ?predicate_property, +object_identifier, +scope, @execution_context) % % predicate_property/2 built-in method % % local predicates without a scope declaration are invisible and Prolog % built-in predicates are interpreted as private predicates % % the implementation ensures that no spurious choice-points are created when % the method is called with a bound and deterministic property argument '$lgt_predicate_property'(Obj, Pred, Prop, _, _, ExCtx) :- '$lgt_check'(callable, Pred, logtalk(predicate_property(Pred, Prop), ExCtx)), '$lgt_check'(var_or_predicate_property, Prop, logtalk(predicate_property(Pred, Prop), ExCtx)), '$lgt_check'(object, Obj, logtalk(Obj::predicate_property(Pred, Prop), ExCtx)), fail. '$lgt_predicate_property'(user, Pred, Prop, _, _, _) :- !, '$lgt_predicate_property'(Pred, Prop). '$lgt_predicate_property'(Obj, Pred, Prop, Obj, _, ExCtx) :- '$lgt_comp_ctx'(Ctx, _, _, Entity, _, _, _, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, _, Entity), '$lgt_uses_predicate_'(Entity, Other, Original, Pred, Ctx), !, '$lgt_predicate_property'(Other, Original, Prop, Obj, p(p(p)), ExCtx). '$lgt_predicate_property'(Obj, Pred, Prop, Obj, _, ExCtx) :- '$lgt_comp_ctx'(Ctx, _, _, Entity, _, _, _, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, _, Entity), '$lgt_use_module_predicate_'(Entity, Module, Original, Pred, Ctx), !, '$lgt_predicate_property'(':'(Module, Original), Prop). '$lgt_predicate_property'(Obj, Pred, Prop, Sender, LookupScope, _) :- '$lgt_current_object_'(Obj, _, Dcl, Def, _, _, _, _, _, Rnm, ObjFlags), call(Dcl, Pred, PredScope, Meta, PredFlags, SCtn, TCtn), % predicate declaration found !, ( \+ \+ PredScope = LookupScope -> true ; Sender = SCtn ), % query is within scope '$lgt_scope'(ScopeAsAtom, PredScope), ( '$lgt_current_object_'(TCtn, _, TCtnDcl, _, _, _, _, _, _, _, _) -> true ; '$lgt_current_protocol_'(TCtn, _, TCtnDcl, _, _) -> true ; '$lgt_current_category_'(TCtn, _, TCtnDcl, _, _, _) ), ( call(TCtnDcl, Pred, _, _, _) -> % found static declaration for the predicate '$lgt_predicate_property_user'(Prop, Pred, Pred, Obj, ScopeAsAtom, Meta, PredFlags, TCtn, Obj, Def, Rnm) ; PredFlags /\ 2 =:= 2 -> % dynamically declared predicate; aliases can only be defined for statically declared predicates '$lgt_predicate_property_user'(Prop, Pred, Pred, Obj, ScopeAsAtom, Meta, PredFlags, TCtn, Obj, Def, Rnm) ; % no predicate declaration; we may be querying properties of a predicate alias '$lgt_find_original_predicate'(Obj, Rnm, ObjFlags, Pred, Original, Entity), '$lgt_predicate_property_user'(Prop, Pred, Original, Entity, ScopeAsAtom, Meta, PredFlags, TCtn, Obj, Def, Rnm) ). '$lgt_predicate_property'(Obj, Pred, Prop, Sender, LookupScope, _) :- '$lgt_built_in_method'(Pred, PredScope, Meta, Flags), !, ( \+ \+ PredScope = LookupScope -> true ; Sender = Obj ), '$lgt_scope'(ScopeAsAtom, PredScope), '$lgt_predicate_property_built_in_method'(Prop, Pred, ScopeAsAtom, Meta, Flags). '$lgt_predicate_property'(Obj, Pred, Prop, Obj, _, _) :- '$lgt_logtalk_built_in_predicate'(Pred, Meta), !, '$lgt_predicate_property_logtalk_built_in'(Prop, Meta). '$lgt_predicate_property'(Obj, Pred, Prop, Obj, _, _) :- '$lgt_prolog_built_in_predicate'(Pred), !, '$lgt_predicate_property_prolog_built_in'(Prop, Pred). '$lgt_predicate_property_user'(alias_of(Original), Alias, Original, _, _, _, _, _, _, _, _) :- Alias \= Original. '$lgt_predicate_property_user'(alias_declared_in(Entity), Alias, Original, Entity, _, _, _, _, _, _, _) :- Alias \= Original. '$lgt_predicate_property_user'(alias_declared_in(Entity, Line), Alias, Original, Entity, _, _, _, _, _, _, _) :- Alias \= Original, functor(Original, OriginalFunctor, Arity), functor(Alias, AliasFunctor, Arity), '$lgt_entity_property_'(Entity, predicate_alias(_, OriginalFunctor/Arity, AliasFunctor/Arity, _, Line)). '$lgt_predicate_property_user'(logtalk, _, _, _, _, _, _, _, _, _, _). '$lgt_predicate_property_user'(scope(Scope), _, _, _, Scope, _, _, _, _, _, _). '$lgt_predicate_property_user'((public), _, _, _, (public), _, _, _, _, _, _). '$lgt_predicate_property_user'(protected, _, _, _, protected, _, _, _, _, _, _). '$lgt_predicate_property_user'((private), _, _, _, (private), _, _, _, _, _, _). '$lgt_predicate_property_user'((dynamic), _, _, _, _, _, Flags, _, _, _, _) :- Flags /\ 2 =:= 2. '$lgt_predicate_property_user'(static, _, _, _, _, _, Flags, _, _, _, _) :- Flags /\ 2 =\= 2. '$lgt_predicate_property_user'(declared_in(TCtn), _, _, _, _, _, _, TCtn, _, _, _). '$lgt_predicate_property_user'(declared_in(TCtn, Line), _, Original, _, _, _, _, TCtn, _, _, _) :- functor(Original, Functor, Arity), ( '$lgt_predicate_property_'(TCtn, Functor/Arity, declaration_location(Location)) -> ( Location = include(_, Line-_) -> true ; Location = Line-_ ) ; fail ). '$lgt_predicate_property_user'(meta_predicate(Meta), Alias, _, _, _, Meta0, _, _, _, _, _) :- Meta0 \== no, functor(Alias, AliasFunctor, _), Meta0 =.. [_| MetaArgs], Meta =.. [AliasFunctor| MetaArgs]. '$lgt_predicate_property_user'(coinductive(Template), Alias, Original, _, _, _, _, TCtn, _, _, _) :- functor(Original, Functor, Arity), ( '$lgt_predicate_property_'(TCtn, Functor/Arity, coinductive(Template0)) -> functor(Alias, AliasFunctor, _), Template0 =.. [_| ModeArgs], Template =.. [AliasFunctor| ModeArgs] ; fail ). '$lgt_predicate_property_user'((multifile), _, _, _, _, _, PredFlags, _, _, _, _) :- PredFlags /\ 16 =:= 16. '$lgt_predicate_property_user'(non_terminal(Functor//Arity), Alias, _, _, _, _, PredFlags, _, _, _, _) :- PredFlags /\ 8 =:= 8, functor(Alias, Functor, ExtArity), Arity is ExtArity - 2. '$lgt_predicate_property_user'(synchronized, _, _, _, _, _, PredFlags, _, _, _, _) :- PredFlags /\ 4 =:= 4. '$lgt_predicate_property_user'(defined_in(DCtn), Alias, _, _, _, _, _, _, _, Def, _) :- ( call(Def, Alias, _, _, _, DCtn) -> true ; fail ). '$lgt_predicate_property_user'(defined_in(DCtn, Line), Alias, Original, _, _, _, _, _, _, Def, _) :- ( call(Def, Alias, _, _, _, DCtn) -> ( functor(Original, Functor, Arity), '$lgt_predicate_property_'(DCtn, Functor/Arity, flags_clauses_rules_location(_, _, _, Location)) -> ( Location = include(_, Line-_) -> true ; Location = Line-_ ) ; fail ) ; fail ). '$lgt_predicate_property_user'(recursive, Alias, Original, _, _, _, _, _, _, Def, _) :- ( call(Def, Alias, _, _, _, DCtn) -> ( functor(Original, Functor, Arity), '$lgt_predicate_property_'(DCtn, Functor/Arity, flags_clauses_rules_location(Flags, _, _, _)) -> Flags /\ 8 =:= 8 ; fail ) ; fail ). '$lgt_predicate_property_user'(inline, Alias, Original, _, _, _, _, _, _, Def, _) :- ( call(Def, Alias, _, _, _, DCtn) -> ( functor(Original, Functor, Arity), '$lgt_predicate_property_'(DCtn, Functor/Arity, flags_clauses_rules_location(Flags, _, _, _)) -> Flags /\ 4 =:= 4 ; fail ) ; fail ). '$lgt_predicate_property_user'(redefined_from(Super), Alias, _, _, _, _, _, _, Obj, Def, _) :- ( call(Def, Alias, _, _, _, DCtn) -> '$lgt_find_overridden_predicate'(DCtn, Obj, Alias, Super) ; fail ). '$lgt_predicate_property_user'(redefined_from(Super, Line), Alias, Original, _, _, _, _, _, Obj, Def, _) :- ( call(Def, Alias, _, _, _, DCtn) -> ( '$lgt_find_overridden_predicate'(DCtn, Obj, Alias, Super), functor(Original, Functor, Arity), '$lgt_predicate_property_'(Super, Functor/Arity, flags_clauses_rules_location(_, _, _, Location)) -> ( Location = include(_, Line-_) -> true ; Location = Line-_ ) ; fail ) ; fail ). '$lgt_predicate_property_user'(info(Info), _, Original, _, _, _, _, TCtn, _, _, _) :- functor(Original, Functor, Arity), ( '$lgt_predicate_property_'(TCtn, Functor/Arity, info(Info)) -> true ; fail ). '$lgt_predicate_property_user'(mode(Mode, Solutions), Alias, Original, _, _, _, _, TCtn, _, _, _) :- functor(Original, Functor, Arity), % we cannot make the mode/2 property deterministic as a predicate can support several different modes '$lgt_predicate_property_'(TCtn, Functor/Arity, mode(Mode0, Solutions)), functor(Alias, AliasFunctor, _), Mode0 =.. [_| ModeArgs], Mode =.. [AliasFunctor| ModeArgs]. '$lgt_predicate_property_user'(number_of_clauses(N), Alias, Original, _, _, _, PredFlags, _, Obj, Def, _) :- '$lgt_current_object_'(Obj, _, _, _, _, _, _, _, _, _, Flags), Flags /\ 2 =:= 0, % static object ( call(Def, Alias, _, _, _, DCtn) -> functor(Original, Functor, Arity), ( '$lgt_predicate_property_'(DCtn, Functor/Arity, flags_clauses_rules_location(_, N0, _, _)) -> true ; N0 is 0 ), ( PredFlags /\ 16 =:= 16 -> % multifile predicate findall(N1, '$lgt_predicate_property_'(_, Functor/Arity, clauses_rules_location_to(N1, _, _, DCtn)), N1s), '$lgt_sum_list'([N0| N1s], N) ; N is N0 ) ; fail ). '$lgt_predicate_property_user'(number_of_rules(N), Alias, Original, _, _, _, PredFlags, _, Obj, Def, _) :- '$lgt_current_object_'(Obj, _, _, _, _, _, _, _, _, _, Flags), Flags /\ 2 =:= 0, % static object ( call(Def, Alias, _, _, _, DCtn) -> functor(Original, Functor, Arity), ( '$lgt_predicate_property_'(DCtn, Functor/Arity, flags_clauses_rules_location(_, _, N0, _)) -> true ; N0 is 0 ), ( PredFlags /\ 16 =:= 16 -> % multifile predicate findall(N1, '$lgt_predicate_property_'(_, Functor/Arity, clauses_rules_location_to(_, N1, _, DCtn)), N1s), '$lgt_sum_list'([N0| N1s], N) ; N is N0 ) ; fail ). '$lgt_predicate_property_built_in_method'(logtalk, _, _, _, _). '$lgt_predicate_property_built_in_method'(scope(Scope), _, Scope, _, _). '$lgt_predicate_property_built_in_method'((public), _, (public), _, _). '$lgt_predicate_property_built_in_method'(protected, _, protected, _, _). '$lgt_predicate_property_built_in_method'((private), _, (private), _, _). '$lgt_predicate_property_built_in_method'(built_in, _, _, _, _). %Flags /\ 1 =:= 1. '$lgt_predicate_property_built_in_method'((dynamic), _, _, _, Flags) :- Flags /\ 2 =:= 2. '$lgt_predicate_property_built_in_method'(static, _, _, _, Flags) :- Flags /\ 2 =\= 2. '$lgt_predicate_property_built_in_method'(meta_predicate(Meta), _, _, Meta, _) :- Meta \== no. '$lgt_predicate_property_built_in_method'((multifile), _, _, _, Flags) :- Flags /\ 16 =:= 16. '$lgt_predicate_property_built_in_method'(non_terminal(Functor//Arity), Pred, _, _, Flags) :- Flags /\ 8 =:= 8, functor(Pred, Functor, ExtArity), Arity is ExtArity - 2. '$lgt_predicate_property_built_in_method'(synchronized, _, _, _, Flags) :- Flags /\ 4 =:= 4. '$lgt_predicate_property_logtalk_built_in'(logtalk, _). '$lgt_predicate_property_logtalk_built_in'(scope(private), _). '$lgt_predicate_property_logtalk_built_in'((private), _). '$lgt_predicate_property_logtalk_built_in'(built_in, _). '$lgt_predicate_property_logtalk_built_in'(static, _). '$lgt_predicate_property_logtalk_built_in'(meta_predicate(Meta), Meta) :- Meta \== no. '$lgt_predicate_property_prolog_built_in'(foreign, Pred) :- catch('$lgt_predicate_property'(Pred, foreign), _, fail). '$lgt_predicate_property_prolog_built_in'(prolog, Pred) :- \+ catch('$lgt_predicate_property'(Pred, foreign), _, fail). '$lgt_predicate_property_prolog_built_in'(scope(private), _). '$lgt_predicate_property_prolog_built_in'((private), _). '$lgt_predicate_property_prolog_built_in'(meta_predicate(Meta), Pred) :- '$lgt_prolog_meta_predicate'(Pred, Meta0, _), Meta0 =.. [_| MetaArgs0], '$lgt_prolog_to_logtalk_meta_argument_specifiers'(MetaArgs0, MetaArgs), Meta =.. [_| MetaArgs]. '$lgt_predicate_property_prolog_built_in'(built_in, _). '$lgt_predicate_property_prolog_built_in'((dynamic), Pred) :- '$lgt_predicate_property'(Pred, (dynamic)). '$lgt_predicate_property_prolog_built_in'(static, Pred) :- '$lgt_predicate_property'(Pred, static). '$lgt_predicate_property_prolog_built_in'((multifile), Pred) :- '$lgt_predicate_property'(Pred, (multifile)). % '$lgt_scope'(?atom, ?nonvar). % % converts between user and internal scope representation; % this representation was chosen as it allows testing if a scope is either % public or protected by a single unification step with the p(_) term '$lgt_scope'((private), p). '$lgt_scope'(protected, p(p)). '$lgt_scope'((public), p(p(p))). % '$lgt_filter_scope'(@nonvar, -nonvar) % % filters the predicate scope; % used in the implementation of protected-qualified relations between entities; % public predicates become protected predicates, protected and private predicates % are unaffected '$lgt_filter_scope'(p(_), p(p)). '$lgt_filter_scope'(p, p). % '$lgt_filter_scope_container'(@nonvar, @object_identifier, @object_identifier, -object_identifier) % % filters the predicate scope container; % used in the implementation of private-qualified relations between entities; % when the predicate is public or protected, the object inheriting the predicate % becomes the scope container; when the predicate is private, the scope container % is the inherited scope container '$lgt_filter_scope_container'(p(_), _, SCtn, SCtn). '$lgt_filter_scope_container'(p, SCtn, _, SCtn). % '$lgt_find_original_predicate'(+object_identifier, +atom, +integer, +callable, -callable, -entity_identifier) % % finds the predicate pointed by an alias and the entity where the alias is declared '$lgt_find_original_predicate'(Obj, Rnm, Flags, Alias, Pred, Entity) :- % we add a fifth argument to properly handle class hierarchies if necessary '$lgt_find_original_predicate'(Obj, Rnm, Flags, Alias, Pred, Entity, _), !. '$lgt_find_original_predicate'(Obj, _, Flags, Alias, Pred, Entity, _) :- Flags /\ 64 =:= 64, % "complements" flag set to "allow" '$lgt_complemented_object_'(Obj, Ctg, _, _, Rnm), '$lgt_find_original_predicate'(Ctg, Rnm, 0, Alias, Pred, Entity, _). '$lgt_find_original_predicate'(Entity, Rnm, _, Alias, Pred, Entity, _) :- once(call(Rnm, _, Pred, Alias)), Pred \= Alias, !. '$lgt_find_original_predicate'(Obj, _, Flags, Alias, Pred, Entity, _) :- Flags /\ 32 =:= 32, % "complements" flag set to "restrict" '$lgt_complemented_object_'(Obj, Ctg, _, _, Rnm), '$lgt_find_original_predicate'(Ctg, Rnm, 0, Alias, Pred, Entity, _). '$lgt_find_original_predicate'(Obj, _, _, Alias, Pred, Entity, _) :- '$lgt_implements_protocol_'(Obj, Ptc, _), '$lgt_current_protocol_'(Ptc, _, _, Rnm, _), '$lgt_find_original_predicate'(Ptc, Rnm, 0, Alias, Pred, Entity, _). '$lgt_find_original_predicate'(Ptc, _, _, Alias, Pred, Entity, _) :- '$lgt_extends_protocol_'(Ptc, ExtPtc, _), '$lgt_current_protocol_'(ExtPtc, _, _, Rnm, _), '$lgt_find_original_predicate'(ExtPtc, Rnm, 0, Alias, Pred, Entity, _). '$lgt_find_original_predicate'(Ctg, _, _, Alias, Pred, Entity, _) :- '$lgt_extends_category_'(Ctg, ExtCtg, _), '$lgt_current_category_'(ExtCtg, _, _, _, Rnm, _), '$lgt_find_original_predicate'(ExtCtg, Rnm, 0, Alias, Pred, Entity, _). '$lgt_find_original_predicate'(Obj, _, _, Alias, Pred, Entity, _) :- '$lgt_imports_category_'(Obj, Ctg, _), '$lgt_current_category_'(Ctg, _, _, _, Rnm, _), '$lgt_find_original_predicate'(Ctg, Rnm, 0, Alias, Pred, Entity, _). '$lgt_find_original_predicate'(Obj, _, _, Alias, Pred, Entity, prototype) :- '$lgt_extends_object_'(Obj, Parent, _), '$lgt_current_object_'(Parent, _, _, _, _, _, _, _, _, Rnm, Flags), '$lgt_find_original_predicate'(Parent, Rnm, Flags, Alias, Pred, Entity, prototype). '$lgt_find_original_predicate'(Instance, _, _, Alias, Pred, Entity, instance) :- '$lgt_instantiates_class_'(Instance, Class, _), '$lgt_current_object_'(Class, _, _, _, _, _, _, _, _, Rnm, Flags), '$lgt_find_original_predicate'(Class, Rnm, Flags, Alias, Pred, Entity, superclass). '$lgt_find_original_predicate'(Class, _, _, Alias, Pred, Entity, superclass) :- '$lgt_specializes_class_'(Class, Superclass, _), '$lgt_current_object_'(Superclass, _, _, _, _, _, _, _, _, Rnm, Flags), '$lgt_find_original_predicate'(Superclass, Rnm, Flags, Alias, Pred, Entity, superclass). % '$lgt_find_overridden_predicate'(+entity_identifier, +entity_identifier, +callable, -entity_identifier) % % finds the entity containing the overridden predicate definition (assuming that the % start lookup entity contains a overriding definition for the predicate) '$lgt_find_overridden_predicate'(Obj, Self, Pred, DefCtn) :- '$lgt_current_object_'(Obj, _, _, _, Super, _, _, _, _, _, _), % for classes, we need to be sure we use the correct clause for "super" by looking into "self" '$lgt_execution_context'(ExCtx, _, _, _, Self, _, _), call(Super, Pred, ExCtx, _, _, DefCtn), DefCtn \= Obj, !. '$lgt_find_overridden_predicate'(Ctg, _, Pred, DefCtn) :- '$lgt_current_category_'(Ctg, _, _, Def, _, _), call(Def, Pred, _, _, DefCtn), DefCtn \= Ctg, !. % '$lgt_abolish'(+object_identifier, +predicate_indicator, +object_identifier, +scope, @execution_context) % % abolish/1 built-in method '$lgt_abolish'(Obj, Pred, Sender, TestScope, ExCtx) :- '$lgt_check'(object_identifier, Obj, logtalk(Obj::abolish(Pred), ExCtx)), '$lgt_check'(predicate_indicator, Pred, logtalk(abolish(Pred), ExCtx)), '$lgt_abolish_checked'(Obj, Pred, Sender, TestScope, ExCtx). '$lgt_abolish_checked'(user, Functor/Arity, _, _, _) :- !, abolish(Functor/Arity). '$lgt_abolish_checked'(Obj, Functor/Arity, Obj, _, ExCtx) :- '$lgt_comp_ctx'(Ctx, _, _, Entity, _, _, _, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, _, Entity), functor(Head, Functor, Arity), ( '$lgt_uses_predicate_'(Entity, Other, Original, Head, Ctx) -> functor(Original, OriginalFunctor, OriginalArity), '$lgt_abolish_checked'(Other, OriginalFunctor/OriginalArity, Obj, p(p(p)), ExCtx) ; '$lgt_use_module_predicate_'(Entity, Module, Original, Head, Ctx) -> abolish(':'(Module, (Original/Arity))) ; fail ), !. '$lgt_abolish_checked'(Obj, Functor/Arity, Sender, TestScope, ExCtx) :- '$lgt_current_object_'(Obj, Prefix, Dcl, _, _, _, _, DDcl, DDef, _, ObjFlags), !, functor(Pred, Functor, Arity), ( call(Dcl, Pred, Scope, _, PredFlags) -> % local static predicate declaration found ( (Scope = TestScope; Sender = Obj) -> % predicate is within the scope of the sender ( PredFlags /\ 2 =:= 2 -> % static declaration for a dynamic predicate throw(error(permission_error(modify, predicate_declaration, Functor/Arity), logtalk(abolish(Functor/Arity), ExCtx))) ; % predicate is static throw(error(permission_error(modify, static_predicate, Functor/Arity), logtalk(abolish(Functor/Arity), ExCtx))) ) ; % predicate is not within the scope of the sender ( Scope == p -> throw(error(permission_error(modify, private_predicate, Functor/Arity), logtalk(abolish(Functor/Arity), ExCtx))) ; throw(error(permission_error(modify, protected_predicate, Functor/Arity), logtalk(abolish(Functor/Arity), ExCtx))) ) ) ; % no static predicate declaration... ObjFlags /\ 128 =:= 128, % ... but dynamic declarations are allowed DDclClause =.. [DDcl, Pred, _], call(DDclClause) -> % dynamic predicate declaration found retractall(DDclClause), DDefClause =.. [DDef, Pred, _, TPred0], ( call(DDefClause) -> % predicate clauses exist '$lgt_unwrap_compiled_head'(TPred0, TPred), functor(TPred, TFunctor, TArity), abolish(TFunctor/TArity), retractall(DDefClause), '$lgt_clean_lookup_caches'(Pred) ; % no predicate clauses currently exist but may have existed in the past '$lgt_compile_predicate_indicator'(Prefix, Functor/Arity, TFunctor/TArity), abolish(TFunctor/TArity) ) ; % no dynamic predicate declaration found DDefClause =.. [DDef, Pred, _, TPred0], call(DDefClause) -> % local dynamic predicate '$lgt_unwrap_compiled_head'(TPred0, TPred), functor(TPred, TFunctor, TArity), abolish(TFunctor/TArity), retractall(DDefClause), '$lgt_clean_lookup_caches'(Pred) ; % no predicate declaration throw(error(existence_error(predicate_declaration, Functor/Arity), logtalk(abolish(Functor/Arity), ExCtx))) ). '$lgt_abolish_checked'(Obj, Pred, _, _, ExCtx) :- throw(error(existence_error(object, Obj), logtalk(Obj::abolish(Pred), ExCtx))). % '$lgt_asserta'(+object_identifier, @clause, +object_identifier, +scope, +scope, @execution_context) % % asserta/1 built-in method % % asserting facts uses a caching mechanism that saves the compiled form of the % facts to improve performance '$lgt_asserta'(Obj, Clause, Sender, _, _, _) :- nonvar(Obj), nonvar(Clause), '$lgt_db_lookup_cache_'(Obj, Clause, Sender, TClause, _), !, asserta(TClause). '$lgt_asserta'(Obj, Clause, Sender, TestScope, DclScope, ExCtx) :- '$lgt_check'(object_identifier, Obj, logtalk(Obj::asserta(Clause), ExCtx)), '$lgt_check'(clause, Clause, logtalk(asserta(Clause), ExCtx)), ( Clause = (Head :- Body) -> ( Body == true -> '$lgt_asserta_fact_checked'(Obj, Head, Sender, TestScope, DclScope, ExCtx) ; '$lgt_asserta_rule_checked'(Obj, Clause, Sender, TestScope, DclScope, ExCtx) ) ; '$lgt_asserta_fact_checked'(Obj, Clause, Sender, TestScope, DclScope, ExCtx) ). '$lgt_asserta_rule_checked'(Obj, (Head:-Body), Obj, _, _, ExCtx) :- '$lgt_comp_ctx'(Ctx, _, _, Entity, _, _, _, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, _, Entity), ( '$lgt_uses_predicate_'(Entity, Other, Original, Head, Ctx) -> '$lgt_asserta_rule_checked'(Other, (Original:-Body), Obj, p(p(_)), p(p(p)), ExCtx) ; '$lgt_use_module_predicate_'(Entity, Module, Original, Head, Ctx) -> asserta(':'(Module, (Original:-Body))) ; fail ), !. '$lgt_asserta_rule_checked'(Obj, (Head:-Body), Sender, TestScope, DclScope, ExCtx) :- '$lgt_current_object_'(Obj, Prefix, Dcl, Def, _, _, _, DDcl, DDef, _, Flags), !, '$lgt_assert_pred_dcl'(Obj, Dcl, DDcl, DDef, Flags, Head, Scope, Type, Meta, SCtn, DclScope, asserta((Head:-Body)), ExCtx), ( (Type == (dynamic); Flags /\ 2 =:= 2, Sender = SCtn) -> % either a dynamic predicate or a dynamic object that is both the sender and the predicate scope container ( (Scope = TestScope; Sender = SCtn) -> '$lgt_assert_pred_def'(Def, DDef, Flags, Prefix, Head, GExCtx, THead, _), '$lgt_goal_meta_arguments'(Meta, Head, MetaArgs), '$lgt_comp_ctx'(Ctx, Head, GExCtx, _, _, _, _, Prefix, MetaArgs, _, GExCtx, runtime, _, _, _), '$lgt_compile_body'(Body, _, TBody, DBody, Ctx), ( Flags /\ 512 =:= 512 -> % object compiled in debug mode asserta((THead :- ('$lgt_nop'(Body), '$lgt_debug'(rule(Obj, Head, 0, nil, 0), GExCtx), DBody))) ; asserta((THead :- ('$lgt_nop'(Body), TBody))) ) ; % predicate is not within the scope of the sender functor(Head, Functor, Arity), ( Scope == p -> throw(error(permission_error(modify, private_predicate, Functor/Arity), logtalk(asserta((Head:-Body)), ExCtx))) ; throw(error(permission_error(modify, protected_predicate, Functor/Arity), logtalk(asserta((Head:-Body)), ExCtx))) ) ) ; % predicate is static functor(Head, Functor, Arity), throw(error(permission_error(modify, static_predicate, Functor/Arity), logtalk(asserta((Head:-Body)), ExCtx))) ). '$lgt_asserta_rule_checked'(Obj, Clause, _, _, _, ExCtx) :- throw(error(existence_error(object, Obj), Obj::asserta(Clause), ExCtx)). '$lgt_asserta_fact_checked'(Obj, Head, Sender, _, _, _) :- '$lgt_db_lookup_cache_'(Obj, Head, Sender, THead, _), !, asserta(THead). '$lgt_asserta_fact_checked'(Obj, Head, Obj, _, _, ExCtx) :- '$lgt_comp_ctx'(Ctx, _, _, Entity, _, _, _, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, _, Entity), ( '$lgt_uses_predicate_'(Entity, Other, Original, Head, Ctx) -> '$lgt_asserta_fact_checked'(Other, Original, Obj, p(p(_)), p(p(p)), ExCtx) ; '$lgt_use_module_predicate_'(Entity, Module, Original, Head, Ctx) -> asserta(':'(Module, Original)) ; fail ), !. '$lgt_asserta_fact_checked'(Obj, Head, Sender, TestScope, DclScope, ExCtx) :- '$lgt_current_object_'(Obj, Prefix, Dcl, Def, _, _, _, DDcl, DDef, _, Flags), !, '$lgt_assert_pred_dcl'(Obj, Dcl, DDcl, DDef, Flags, Head, Scope, Type, _, SCtn, DclScope, asserta(Head), ExCtx), ( (Type == (dynamic); Flags /\ 2 =:= 2, Sender = SCtn) -> % either a dynamic predicate or a dynamic object that is both the sender and the predicate scope container ( (Scope = TestScope; Sender = SCtn) -> '$lgt_assert_pred_def'(Def, DDef, Flags, Prefix, Head, GExCtx, THead, Update), ( Flags /\ 512 =:= 512 -> % object compiled in debug mode asserta((THead :- '$lgt_debug'(fact(Obj, Head, 0, nil, 0), GExCtx))) ; '$lgt_add_db_lookup_cache_entry'(Obj, Head, SCtn, DclScope, Type, Sender, THead, DDef, Update), asserta(THead) ) ; % predicate is not within the scope of the sender functor(Head, Functor, Arity), ( Scope == p -> throw(error(permission_error(modify, private_predicate, Functor/Arity), logtalk(asserta(Head), ExCtx))) ; throw(error(permission_error(modify, protected_predicate, Functor/Arity), logtalk(asserta(Head), ExCtx))) ) ) ; % predicate is static functor(Head, Functor, Arity), throw(error(permission_error(modify, static_predicate, Functor/Arity), logtalk(asserta(Head), ExCtx))) ). '$lgt_asserta_fact_checked'(Obj, Head, _, _, _, ExCtx) :- throw(error(existence_error(object, Obj), logtalk(Obj::asserta(Head), ExCtx))). % '$lgt_assertz'(+object_identifier, @clause, +object_identifier, +scope, +scope, @execution_context) % % assertz/1 built-in method % % asserting facts uses a caching mechanism that saves the compiled form of the % facts to improve performance '$lgt_assertz'(Obj, Clause, Sender, _, _, _) :- nonvar(Obj), nonvar(Clause), '$lgt_db_lookup_cache_'(Obj, Clause, Sender, TClause, _), !, assertz(TClause). '$lgt_assertz'(Obj, Clause, Sender, TestScope, DclScope, ExCtx) :- '$lgt_check'(object_identifier, Obj, logtalk(Obj::assertz(Clause), ExCtx)), '$lgt_check'(clause, Clause, logtalk(assertz(Clause), ExCtx)), ( Clause = (Head :- Body) -> ( Body == true -> '$lgt_assertz_fact_checked'(Obj, Head, Sender, TestScope, DclScope, ExCtx) ; '$lgt_assertz_rule_checked'(Obj, Clause, Sender, TestScope, DclScope, ExCtx) ) ; '$lgt_assertz_fact_checked'(Obj, Clause, Sender, TestScope, DclScope, ExCtx) ). '$lgt_assertz_rule_checked'(Obj, (Head:-Body), Obj, _, _, ExCtx) :- '$lgt_comp_ctx'(Ctx, _, _, Entity, _, _, _, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, _, Entity), ( '$lgt_uses_predicate_'(Entity, Other, Original, Head, Ctx) -> '$lgt_assertz_rule_checked'(Other, (Original:-Body), Obj, p(p(_)), p(p(p)), ExCtx) ; '$lgt_use_module_predicate_'(Entity, Module, Original, Head, Ctx) -> assertz(':'(Module, (Original:-Body))) ; fail ), !. '$lgt_assertz_rule_checked'(Obj, (Head:-Body), Sender, TestScope, DclScope, ExCtx) :- '$lgt_current_object_'(Obj, Prefix, Dcl, Def, _, _, _, DDcl, DDef, _, Flags), !, '$lgt_assert_pred_dcl'(Obj, Dcl, DDcl, DDef, Flags, Head, Scope, Type, Meta, SCtn, DclScope, assertz((Head:-Body)), ExCtx), ( (Type == (dynamic); Flags /\ 2 =:= 2, Sender = SCtn) -> % either a dynamic predicate or a dynamic object that is both the sender and the predicate scope container ( (Scope = TestScope; Sender = SCtn) -> '$lgt_assert_pred_def'(Def, DDef, Flags, Prefix, Head, GExCtx, THead, _), '$lgt_goal_meta_arguments'(Meta, Head, MetaArgs), '$lgt_comp_ctx'(Ctx, Head, GExCtx, _, _, _, _, Prefix, MetaArgs, _, GExCtx, runtime, _, _, _), '$lgt_compile_body'(Body, _, TBody, DBody, Ctx), ( Flags /\ 512 =:= 512 -> % object compiled in debug mode assertz((THead :- ('$lgt_nop'(Body), '$lgt_debug'(rule(Obj, Head, 0, nil, 0), GExCtx), DBody))) ; assertz((THead :- ('$lgt_nop'(Body), TBody))) ) ; % predicate is not within the scope of the sender functor(Head, Functor, Arity), ( Scope == p -> throw(error(permission_error(modify, private_predicate, Functor/Arity), logtalk(assertz((Head:-Body)), ExCtx))) ; throw(error(permission_error(modify, protected_predicate, Functor/Arity), logtalk(assertz((Head:-Body)), ExCtx))) ) ) ; % predicate is static functor(Head, Functor, Arity), throw(error(permission_error(modify, static_predicate, Functor/Arity), logtalk(assertz((Head:-Body)), ExCtx))) ). '$lgt_assertz_rule_checked'(Obj, Clause, _, _, _, ExCtx) :- throw(error(existence_error(object, Obj), logtalk(Obj::assertz(Clause), ExCtx))). '$lgt_assertz_fact_checked'(Obj, Head, Sender, _, _, _) :- '$lgt_db_lookup_cache_'(Obj, Head, Sender, THead, _), !, assertz(THead). '$lgt_assertz_fact_checked'(Obj, Head, Obj, _, _, ExCtx) :- '$lgt_comp_ctx'(Ctx, _, _, Entity, _, _, _, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, _, Entity), ( '$lgt_uses_predicate_'(Entity, Other, Original, Head, Ctx) -> '$lgt_assertz_fact_checked'(Other, Original, Obj, p(p(_)), p(p(p)), ExCtx) ; '$lgt_use_module_predicate_'(Entity, Module, Original, Head, Ctx) -> assertz(':'(Module, Original)) ; fail ), !. '$lgt_assertz_fact_checked'(Obj, Head, Sender, TestScope, DclScope, ExCtx) :- '$lgt_current_object_'(Obj, Prefix, Dcl, Def, _, _, _, DDcl, DDef, _, Flags), !, '$lgt_assert_pred_dcl'(Obj, Dcl, DDcl, DDef, Flags, Head, Scope, Type, _, SCtn, DclScope, assertz(Head), ExCtx), ( (Type == (dynamic); Flags /\ 2 =:= 2, Sender = SCtn) -> % either a dynamic predicate or a dynamic object that is both the sender and the predicate scope container ( (Scope = TestScope; Sender = SCtn) -> '$lgt_assert_pred_def'(Def, DDef, Flags, Prefix, Head, GExCtx, THead, Update), ( Flags /\ 512 =:= 512 -> % object compiled in debug mode assertz((THead :- '$lgt_debug'(fact(Obj, Head, 0, nil, 0), GExCtx))) ; '$lgt_add_db_lookup_cache_entry'(Obj, Head, SCtn, DclScope, Type, Sender, THead, DDef, Update), assertz(THead) ) ; % predicate is not within the scope of the sender functor(Head, Functor, Arity), ( Scope == p -> throw(error(permission_error(modify, private_predicate, Functor/Arity), logtalk(assertz(Head), ExCtx))) ; throw(error(permission_error(modify, protected_predicate, Functor/Arity), logtalk(assertz(Head), ExCtx))) ) ) ; % predicate is static functor(Head, Functor, Arity), throw(error(permission_error(modify, static_predicate, Functor/Arity), logtalk(assertz(Head), ExCtx))) ). '$lgt_assertz_fact_checked'(Obj, Head, _, _, _, ExCtx) :- throw(error(existence_error(object, Obj), logtalk(Obj::assertz(Head), ExCtx))). % gets or sets (if it doesn't exist) the declaration for an asserted predicate (but we must % not add a scope declaration when asserting clauses for a *local* dynamic predicate) '$lgt_assert_pred_dcl'(Obj, Dcl, DDcl, DDef, ObjFlags, Pred, Scope, Type, Meta, SCtn, DclScope, Goal, ExCtx) :- ( call(Dcl, Pred, Scope, Meta, PredFlags, SCtn, _) -> % predicate declaration found; get predicate type ( PredFlags /\ 2 =:= 2 -> Type = (dynamic) ; Type = (static) ) ; % no predicate declaration; check for a local dynamic predicate if we're asserting locally (DclScope == p, call(DDef, Pred, _, _)) -> Scope = DclScope, Type = (dynamic), Meta = no, SCtn = Obj ; % not a declared predicate and not a local dynamic predicate ( DclScope == p % object asserting a new predicate in itself ; ObjFlags /\ 128 =:= 128 % dynamic declaration of new predicates allowed ) -> '$lgt_term_template'(Pred, DPred), Clause =.. [DDcl, DPred, DclScope], assertz(Clause), Scope = DclScope, Type = (dynamic), Meta = no, SCtn = Obj ; % object doesn't allow dynamic declaration of new predicates functor(Pred, Functor, Arity), throw(error(permission_error(create, predicate_declaration, Functor/Arity), logtalk(Goal, ExCtx))) ). % gets or sets (if it doesn't exist) the compiled call for an asserted predicate '$lgt_assert_pred_def'(Def, DDef, Flags, Prefix, Head, ExCtx, THead, NeedsUpdate) :- ( call(Def, Head, ExCtx, THead0) -> % static definition lookup entries don't require update goals '$lgt_unwrap_compiled_head'(THead0, THead), NeedsUpdate = false ; call(DDef, Head, ExCtx, THead0) -> % dynamic definition lookup entries always require update goals '$lgt_unwrap_compiled_head'(THead0, THead), NeedsUpdate = true ; % no definition lookup entry exists; construct and assert a dynamic one functor(Head, Functor, Arity), functor(GHead, Functor, Arity), '$lgt_compile_predicate_indicator'(Prefix, Functor/Arity, TFunctor/TArity), functor(THead, TFunctor, TArity), '$lgt_unify_head_thead_arguments'(GHead, THead, ExCtx), ( Flags /\ 512 =:= 512 -> % object compiled in debug mode DDefClause =.. [DDef, GHead, ExCtx, '$lgt_debug'(goal(GHead,THead), ExCtx)] ; DDefClause =.. [DDef, GHead, ExCtx, THead] ), assertz(DDefClause), '$lgt_clean_lookup_caches'(GHead), NeedsUpdate = true, GHead = Head ). % '$lgt_clause'(+object_identifier, +callable, ?callable, +object_identifier, +scope, @execution_context) % % clause/2 built-in method '$lgt_clause'(Obj, Head, Body, Sender, TestScope, ExCtx) :- '$lgt_check'(object_identifier, Obj, logtalk(Obj::clause(Head, Body), ExCtx)), '$lgt_check'(clause, (Head:-Body), logtalk(clause(Head, Body), ExCtx)), '$lgt_clause_checked'(Obj, Head, Body, Sender, TestScope, ExCtx). '$lgt_clause_checked'(Obj, Head, Body, Sender, _, _) :- '$lgt_db_lookup_cache_'(Obj, Head, Sender, THead, _), !, clause(THead, TBody), ( TBody = ('$lgt_nop'(Body), _) -> % rules (compiled both in normal and debug mode) true ; TBody = '$lgt_debug'(fact(_, _, _, _, _), _) -> % facts compiled in debug mode Body = true ; % facts compiled in normal mode TBody = Body ). '$lgt_clause_checked'(Obj, Head, Body, Obj, _, ExCtx) :- '$lgt_comp_ctx'(Ctx, _, _, Entity, _, _, _, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, _, Entity), '$lgt_uses_predicate_'(Entity, Other, Original, Head, Ctx), Obj \== Other, !, '$lgt_clause_checked'(Other, Original, Body, Obj, p(p(p)), ExCtx). '$lgt_clause_checked'(_, Head, Body, _, _, ExCtx) :- '$lgt_comp_ctx'(Ctx, _, _, Entity, _, _, _, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, _, Entity), '$lgt_use_module_predicate_'(Entity, Module, Original, Head, Ctx), !, clause(':'(Module,Original), Body). '$lgt_clause_checked'(Obj, Head, Body, Sender, TestScope, ExCtx) :- '$lgt_current_object_'(Obj, _, Dcl, Def, _, _, _, _, DDef, _, ObjFlags), !, ( call(Dcl, Head, Scope, _, PredFlags, SCtn, _) -> ( (PredFlags /\ 2 =:= 2; ObjFlags /\ 2 =:= 2, Sender = SCtn) -> % either a dynamic predicate or a dynamic object that is both the sender and the predicate scope container ( (Scope = TestScope; Sender = SCtn) -> ( (call(DDef, Head, _, THead0); call(Def, Head, _, THead0)) -> '$lgt_unwrap_compiled_head'(THead0, THead), clause(THead, TBody), ( TBody = ('$lgt_nop'(Body), _) -> true ; TBody = '$lgt_debug'(fact(_, _, _, _, _), _) -> Body = true ; TBody = Body ) ) ; % predicate is not within the scope of the sender functor(Head, Functor, Arity), ( Scope == p -> throw(error(permission_error(access, private_predicate, Functor/Arity), logtalk(clause(Head, Body), ExCtx))) ; throw(error(permission_error(access, protected_predicate, Functor/Arity), logtalk(clause(Head, Body), ExCtx))) ) ) ; % predicate is static functor(Head, Functor, Arity), throw(error(permission_error(access, static_predicate, Functor/Arity), logtalk(clause(Head, Body), ExCtx))) ) ; Obj = Sender, (call(DDef, Head, _, THead0); call(Def, Head, _, THead0)) -> % local dynamic predicate with no scope declaration '$lgt_unwrap_compiled_head'(THead0, THead), clause(THead, TBody), ( TBody = ('$lgt_nop'(Body), _) -> true ; TBody = '$lgt_debug'(fact(_, _, _, _, _), _) -> Body = true ; TBody = Body ) ; % unknown predicate functor(Head, Functor, Arity), throw(error(existence_error(predicate_declaration, Functor/Arity), logtalk(clause(Head, Body), ExCtx))) ). '$lgt_clause_checked'(Obj, Head, Body, _, _, ExCtx) :- throw(error(existence_error(object, Obj), logtalk(Obj::clause(Head, Body), ExCtx))). % '$lgt_retract'(+object_identifier, @clause, +object_identifier, +scope, @execution_context) % % retract/1 built-in method % % the implementation must ensure that retracting the last clause for a % predicate allows any inherited clauses to be found again as they are % no longer being overridden '$lgt_retract'(Obj, Clause, Sender, _, _) :- nonvar(Obj), nonvar(Clause), '$lgt_db_lookup_cache_'(Obj, Clause, Sender, TClause, UpdateData), !, retract(TClause), '$lgt_update_ddef_table_opt'(UpdateData). '$lgt_retract'(Obj, Clause, Sender, TestScope, ExCtx) :- '$lgt_check'(object_identifier, Obj, logtalk(Obj::retract(Clause), ExCtx)), '$lgt_check'(clause, Clause, logtalk(retract(Clause), ExCtx)), ( Clause = (Head :- Body) -> ( var(Body) -> '$lgt_retract_var_body_checked'(Obj, Clause, Sender, TestScope, ExCtx) ; Body == true -> '$lgt_retract_fact_checked'(Obj, Head, Sender, TestScope, ExCtx) ; '$lgt_retract_rule_checked'(Obj, Clause, Sender, TestScope, ExCtx) ) ; '$lgt_retract_fact_checked'(Obj, Clause, Sender, TestScope, ExCtx) ). '$lgt_retract_var_body_checked'(Obj, (Head:-Body), Obj, _, ExCtx) :- '$lgt_comp_ctx'(Ctx, _, _, Entity, _, _, _, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, _, Entity), '$lgt_uses_predicate_'(Entity, Other, Original, Head, Ctx), Obj \== Other, !, '$lgt_retract_var_body_checked'(Other, (Original:-Body), Obj, p(p(p)), ExCtx). '$lgt_retract_var_body_checked'(_, (Head:-Body), _, _, ExCtx) :- '$lgt_comp_ctx'(Ctx, _, _, Entity, _, _, _, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, _, Entity), '$lgt_use_module_predicate_'(Entity, Module, Original, Head, Ctx), !, retract((':'(Module,Original) :- Body)). '$lgt_retract_var_body_checked'(Obj, (Head:-Body), Sender, TestScope, ExCtx) :- '$lgt_current_object_'(Obj, _, Dcl, Def, _, _, _, _, DDef, _, ObjFlags), !, ( call(Dcl, Head, Scope, _, PredFlags, SCtn, _) -> ( (PredFlags /\ 2 =:= 2; ObjFlags /\ 2 =:= 2, Sender = SCtn) -> % either a dynamic predicate or a dynamic object that is both the sender and the predicate scope container ( (Scope = TestScope; Sender = SCtn) -> ( call(DDef, Head, _, THead0) -> '$lgt_unwrap_compiled_head'(THead0, THead), retract((THead :- TBody)), ( TBody = ('$lgt_nop'(Body), _) -> true ; TBody = '$lgt_debug'(fact(_, _, _, _, _), _) -> Body = true ; TBody = Body ), '$lgt_update_ddef_table'(DDef, Head, THead) ; call(Def, Head, _, THead0) -> '$lgt_unwrap_compiled_head'(THead0, THead), retract((THead :- TBody)), ( TBody = ('$lgt_nop'(Body), _) -> true ; TBody = '$lgt_debug'(fact(_, _, _, _, _), _) -> Body = true ; TBody = Body ) ) ; % predicate is not within the scope of the sender functor(Head, Functor, Arity), ( Scope == p -> throw(error(permission_error(modify, private_predicate, Functor/Arity), logtalk(retract((Head:-Body)), ExCtx))) ; throw(error(permission_error(modify, protected_predicate, Functor/Arity), logtalk(retract((Head:-Body)), ExCtx))) ) ) ; % predicate is static functor(Head, Functor, Arity), throw(error(permission_error(modify, static_predicate, Functor/Arity), logtalk(retract((Head:-Body)), ExCtx))) ) ; Obj = Sender, call(DDef, Head, _, THead0) -> % local dynamic predicate with no scope declaration '$lgt_unwrap_compiled_head'(THead0, THead), retract((THead :- TBody)), ( TBody = ('$lgt_nop'(Body), _) -> true ; TBody = '$lgt_debug'(fact(_, _, _, _, _), _) -> Body = true ; TBody = Body ) ; % unknown predicate functor(Head, Functor, Arity), throw(error(existence_error(predicate_declaration, Functor/Arity), logtalk(retract((Head:-Body)), ExCtx))) ). '$lgt_retract_var_body_checked'(Obj, (Head:-Body), _, _, ExCtx) :- throw(error(existence_error(object, Obj), logtalk(Obj::retract((Head:-Body)), ExCtx))). '$lgt_retract_rule_checked'(Obj, (Head:-Body), Obj, _, ExCtx) :- '$lgt_comp_ctx'(Ctx, _, _, Entity, _, _, _, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, _, Entity), '$lgt_uses_predicate_'(Entity, Other, Original, Head, Ctx), Obj \== Other, !, '$lgt_retract_rule_checked'(Other, (Original:-Body), Obj, p(p(p)), ExCtx). '$lgt_retract_rule_checked'(_, (Head:-Body), _, _, ExCtx) :- '$lgt_comp_ctx'(Ctx, _, _, Entity, _, _, _, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, _, Entity), '$lgt_use_module_predicate_'(Entity, Module, Original, Head, Ctx), !, retract((':'(Module,Original) :- Body)). '$lgt_retract_rule_checked'(Obj, (Head:-Body), Sender, TestScope, ExCtx) :- '$lgt_current_object_'(Obj, _, Dcl, Def, _, _, _, _, DDef, _, ObjFlags), !, ( call(Dcl, Head, Scope, _, PredFlags, SCtn, _) -> ( (PredFlags /\ 2 =:= 2; ObjFlags /\ 2 =:= 2, Sender = SCtn) -> % either a dynamic predicate or a dynamic object that is both the sender and the predicate scope container ( (Scope = TestScope; Sender = SCtn) -> ( call(DDef, Head, _, THead0) -> '$lgt_unwrap_compiled_head'(THead0, THead), retract((THead :- ('$lgt_nop'(Body), _))), '$lgt_update_ddef_table'(DDef, Head, THead) ; call(Def, Head, _, THead0) -> '$lgt_unwrap_compiled_head'(THead0, THead), retract((THead :- ('$lgt_nop'(Body), _))) ) ; % predicate is not within the scope of the sender functor(Head, Functor, Arity), ( Scope == p -> throw(error(permission_error(modify, private_predicate, Functor/Arity), logtalk(retract((Head:-Body)), ExCtx))) ; throw(error(permission_error(modify, protected_predicate, Functor/Arity), logtalk(retract((Head:-Body)), ExCtx))) ) ) ; % predicate is static functor(Head, Functor, Arity), throw(error(permission_error(modify, static_predicate, Functor/Arity), logtalk(retract((Head:-Body)), ExCtx))) ) ; Obj = Sender, call(DDef, Head, _, THead0) -> % local dynamic predicate with no scope declaration '$lgt_unwrap_compiled_head'(THead0, THead), retract((THead :- ('$lgt_nop'(Body), _))) ; % unknown predicate functor(Head, Functor, Arity), throw(error(existence_error(predicate_declaration, Functor/Arity), logtalk(retract((Head:-Body)), ExCtx))) ). '$lgt_retract_rule_checked'(Obj, (Head:-Body), _, _, ExCtx) :- throw(error(existence_error(object, Obj), logtalk(Obj::retract((Head:-Body)), ExCtx))). '$lgt_retract_fact_checked'(Obj, Head, Sender, _, _) :- '$lgt_db_lookup_cache_'(Obj, Head, Sender, THead, UpdateData), !, retract(THead), '$lgt_update_ddef_table_opt'(UpdateData). '$lgt_retract_fact_checked'(Obj, Head, Obj, _, ExCtx) :- '$lgt_comp_ctx'(Ctx, _, _, Entity, _, _, _, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, _, Entity), '$lgt_uses_predicate_'(Entity, Other, Original, Head, Ctx), Obj \== Other, !, '$lgt_retract_fact_checked'(Other, Original, Obj, p(p(p)), ExCtx). '$lgt_retract_fact_checked'(_, Head, _, _, ExCtx) :- '$lgt_comp_ctx'(Ctx, _, _, Entity, _, _, _, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, _, Entity), '$lgt_use_module_predicate_'(Entity, Module, Original, Head, Ctx), !, retract(':'(Module,Original)). '$lgt_retract_fact_checked'(Obj, Head, Sender, TestScope, ExCtx) :- '$lgt_current_object_'(Obj, _, Dcl, Def, _, _, _, _, DDef, _, ObjFlags), !, ( call(Dcl, Head, Scope, _, PredFlags, SCtn, _) -> ( (PredFlags /\ 2 =:= 2; ObjFlags /\ 2 =:= 2, Sender = SCtn) -> % either a dynamic predicate or a dynamic object that is both the sender and the predicate scope container Type = (dynamic), ( (Scope = TestScope; Sender = SCtn) -> ( call(DDef, Head, _, THead0) -> '$lgt_unwrap_compiled_head'(THead0, THead), ( ObjFlags /\ 512 =:= 512 -> % object compiled in debug mode retract((THead :- '$lgt_debug'(fact(_, _, _, _, _), _))) ; '$lgt_add_db_lookup_cache_entry'(Obj, Head, SCtn, Scope, Type, Sender, THead, DDef, true), retract(THead) ), '$lgt_update_ddef_table'(DDef, Head, THead) ; call(Def, Head, _, THead0) -> '$lgt_unwrap_compiled_head'(THead0, THead), ( ObjFlags /\ 512 =:= 512 -> % object compiled in debug mode retract((THead :- '$lgt_debug'(fact(_, _, _, _, _), _))) ; '$lgt_add_db_lookup_cache_entry'(Obj, Head, Scope, Type, Sender, THead), retract(THead) ) ) ; % predicate is not within the scope of the sender functor(Head, Functor, Arity), ( Scope == p -> throw(error(permission_error(modify, private_predicate, Functor/Arity), logtalk(retract(Head), ExCtx))) ; throw(error(permission_error(modify, protected_predicate, Functor/Arity), logtalk(retract(Head), ExCtx))) ) ) ; % predicate is static functor(Head, Functor, Arity), throw(error(permission_error(modify, static_predicate, Functor/Arity), logtalk(retract(Head), ExCtx))) ) ; Obj = Sender, call(DDef, Head, _, THead0) -> % local dynamic predicate with no scope declaration '$lgt_unwrap_compiled_head'(THead0, THead), ( ObjFlags /\ 512 =:= 512 -> % object compiled in debug mode retract((THead :- '$lgt_debug'(fact(_, _, _, _, _), _))) ; '$lgt_add_db_lookup_cache_entry'(Obj, Head, p, (dynamic), Sender, THead), retract(THead) ) ; % unknown predicate functor(Head, Functor, Arity), throw(error(existence_error(predicate_declaration, Functor/Arity), logtalk(retract(Head), ExCtx))) ). '$lgt_retract_fact_checked'(Obj, Head, _, _, ExCtx) :- throw(error(existence_error(object, Obj), logtalk(Obj::retract(Head), ExCtx))). % '$lgt_retractall'(+object_identifier, @callable, +object_identifier, +scope, @execution_context) % % retractall/1 built-in method % % the implementation must ensure that retracting the last clause for a % predicate allows any inherited clauses to be found again as they are % no longer being overridden '$lgt_retractall'(Obj, Head, Sender, _, _) :- nonvar(Obj), nonvar(Head), '$lgt_db_lookup_cache_'(Obj, Head, Sender, THead, UpdateData), !, retractall(THead), '$lgt_update_ddef_table_opt'(UpdateData). '$lgt_retractall'(Obj, Head, Sender, TestScope, ExCtx) :- '$lgt_check'(object_identifier, Obj, logtalk(Obj::retractall(Head), ExCtx)), '$lgt_check'(callable, Head, logtalk(retractall(Head), ExCtx)), '$lgt_retractall_checked'(Obj, Head, Sender, TestScope, ExCtx). '$lgt_retractall_checked'(Obj, Head, Sender, _, _) :- '$lgt_db_lookup_cache_'(Obj, Head, Sender, THead, UpdateData), !, retractall(THead), '$lgt_update_ddef_table_opt'(UpdateData). '$lgt_retractall_checked'(Obj, Head, Obj, _, ExCtx) :- '$lgt_comp_ctx'(Ctx, _, _, Entity, _, _, _, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, _, Entity), ( '$lgt_uses_predicate_'(Entity, Other, Original, Head, Ctx) -> '$lgt_retractall_checked'(Other, Original, Obj, p(p(p)), ExCtx) ; '$lgt_use_module_predicate_'(Entity, Module, Original, Head, Ctx) -> retractall(':'(Module,Original)) ; fail ), !. '$lgt_retractall_checked'(Obj, Head, Sender, TestScope, ExCtx) :- '$lgt_current_object_'(Obj, _, Dcl, Def, _, _, _, _, DDef, _, ObjFlags), !, ( call(Dcl, Head, Scope, _, PredFlags, SCtn, _) -> % predicate scope declaration found ( (PredFlags /\ 2 =:= 2; ObjFlags /\ 2 =:= 2, Sender = SCtn) -> % either a dynamic predicate or a dynamic object that is both the sender and the predicate scope container Type = (dynamic), ( (Scope = TestScope; Sender = SCtn) -> ( call(DDef, Head, _, THead0) -> '$lgt_unwrap_compiled_head'(THead0, THead), retractall(THead), '$lgt_update_ddef_table'(DDef, Head, THead) ; call(Def, Head, _, THead0) -> '$lgt_unwrap_compiled_head'(THead0, THead), ( ObjFlags /\ 512 =:= 512 -> % object compiled in debug mode true ; '$lgt_add_db_lookup_cache_entry'(Obj, Head, Scope, Type, Sender, THead) ), retractall(THead) ; true ) ; % predicate is not within the scope of the sender functor(Head, Functor, Arity), ( Scope == p -> throw(error(permission_error(modify, private_predicate, Functor/Arity), logtalk(retractall(Head), ExCtx))) ; throw(error(permission_error(modify, protected_predicate, Functor/Arity), logtalk(retractall(Head), ExCtx))) ) ) ; % predicate is static functor(Head, Functor, Arity), throw(error(permission_error(modify, static_predicate, Functor/Arity), logtalk(retractall(Head), ExCtx))) ) ; Obj = Sender, call(DDef, Head, _, THead0) -> % local dynamic predicate with no scope declaration '$lgt_unwrap_compiled_head'(THead0, THead), ( ObjFlags /\ 512 =:= 512 -> % object compiled in debug mode true ; '$lgt_add_db_lookup_cache_entry'(Obj, Head, p, (dynamic), Sender, THead) ), retractall(THead) ; % unknown predicate functor(Head, Functor, Arity), throw(error(existence_error(predicate_declaration, Functor/Arity), logtalk(retractall(Head), ExCtx))) ). '$lgt_retractall_checked'(Obj, Head, _, _, ExCtx) :- throw(error(existence_error(object, Obj), logtalk(Obj::retractall(Head), ExCtx))). % '$lgt_asserta'(+object_identifier, @clause, @term, +object_identifier, +scope, +scope, @execution_context) % % asserta/2 built-in method that takes a clause reference if supported % as built-in predicates by the backend Prolog compiler % % asserting facts uses a caching mechanism that saves the compiled form of the % facts to improve performance '$lgt_asserta'(Obj, Clause, Ref, Sender, _, _, _) :- nonvar(Obj), nonvar(Clause), '$lgt_db_lookup_cache_'(Obj, Clause, Sender, TClause, _), !, asserta(TClause, Ref). '$lgt_asserta'(Obj, Clause, Ref, Sender, TestScope, DclScope, ExCtx) :- '$lgt_check'(object_identifier, Obj, logtalk(Obj::asserta(Clause, Ref), ExCtx)), '$lgt_check'(clause, Clause, logtalk(asserta(Clause, Ref), ExCtx)), ( Clause = (Head :- Body) -> ( Body == true -> '$lgt_asserta_fact_checked'(Obj, Head, Ref, Sender, TestScope, DclScope, ExCtx) ; '$lgt_asserta_rule_checked'(Obj, Clause, Ref, Sender, TestScope, DclScope, ExCtx) ) ; '$lgt_asserta_fact_checked'(Obj, Clause, Ref, Sender, TestScope, DclScope, ExCtx) ). '$lgt_asserta_rule_checked'(Obj, (Head:-Body), Ref, Obj, _, _, ExCtx) :- '$lgt_comp_ctx'(Ctx, _, _, Entity, _, _, _, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, _, Entity), ( '$lgt_uses_predicate_'(Entity, Other, Original, Head, Ctx) -> '$lgt_asserta_rule_checked'(Other, (Original:-Body), Ref, Obj, p(p(_)), p(p(p)), ExCtx) ; '$lgt_use_module_predicate_'(Entity, Module, Original, Head, Ctx) -> asserta(':'(Module, (Original:-Body)), Ref) ; fail ), !. '$lgt_asserta_rule_checked'(Obj, (Head:-Body), Ref, Sender, TestScope, DclScope, ExCtx) :- '$lgt_current_object_'(Obj, Prefix, Dcl, Def, _, _, _, DDcl, DDef, _, Flags), !, '$lgt_assert_pred_dcl'(Obj, Dcl, DDcl, DDef, Flags, Head, Scope, Type, Meta, SCtn, DclScope, asserta((Head:-Body), Ref), ExCtx), ( (Type == (dynamic); Flags /\ 2 =:= 2, Sender = SCtn) -> % either a dynamic predicate or a dynamic object that is both the sender and the predicate scope container ( (Scope = TestScope; Sender = SCtn) -> '$lgt_assert_pred_def'(Def, DDef, Flags, Prefix, Head, GExCtx, THead, _), '$lgt_goal_meta_arguments'(Meta, Head, MetaArgs), '$lgt_comp_ctx'(Ctx, Head, GExCtx, _, _, _, _, Prefix, MetaArgs, _, GExCtx, runtime, _, _, _), '$lgt_compile_body'(Body, _, TBody, DBody, Ctx), ( Flags /\ 512 =:= 512 -> % object compiled in debug mode asserta((THead :- ('$lgt_nop'(Body), '$lgt_debug'(rule(Obj, Head, 0, nil, 0), GExCtx), DBody)), Ref) ; asserta((THead :- ('$lgt_nop'(Body), TBody)), Ref) ) ; % predicate is not within the scope of the sender functor(Head, Functor, Arity), ( Scope == p -> throw(error(permission_error(modify, private_predicate, Functor/Arity), logtalk(asserta((Head:-Body), Ref), ExCtx))) ; throw(error(permission_error(modify, protected_predicate, Functor/Arity), logtalk(asserta((Head:-Body), Ref), ExCtx))) ) ) ; % predicate is static functor(Head, Functor, Arity), throw(error(permission_error(modify, static_predicate, Functor/Arity), logtalk(asserta((Head:-Body), Ref), ExCtx))) ). '$lgt_asserta_rule_checked'(Obj, Clause, Ref, _, _, _, ExCtx) :- throw(error(existence_error(object, Obj), Obj::asserta(Clause, Ref), ExCtx)). '$lgt_asserta_fact_checked'(Obj, Head, Ref, Sender, _, _, _) :- '$lgt_db_lookup_cache_'(Obj, Head, Sender, THead, _), !, asserta(THead, Ref). '$lgt_asserta_fact_checked'(Obj, Head, Ref, Obj, _, _, ExCtx) :- '$lgt_comp_ctx'(Ctx, _, _, Entity, _, _, _, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, _, Entity), ( '$lgt_uses_predicate_'(Entity, Other, Original, Head, Ctx) -> '$lgt_asserta_fact_checked'(Other, Original, Ref, Obj, p(p(_)), p(p(p)), ExCtx) ; '$lgt_use_module_predicate_'(Entity, Module, Original, Head, Ctx) -> asserta(':'(Module, Original), Ref) ; fail ), !. '$lgt_asserta_fact_checked'(Obj, Head, Ref, Sender, TestScope, DclScope, ExCtx) :- '$lgt_current_object_'(Obj, Prefix, Dcl, Def, _, _, _, DDcl, DDef, _, Flags), !, '$lgt_assert_pred_dcl'(Obj, Dcl, DDcl, DDef, Flags, Head, Scope, Type, _, SCtn, DclScope, asserta(Head, Ref), ExCtx), ( (Type == (dynamic); Flags /\ 2 =:= 2, Sender = SCtn) -> % either a dynamic predicate or a dynamic object that is both the sender and the predicate scope container ( (Scope = TestScope; Sender = SCtn) -> '$lgt_assert_pred_def'(Def, DDef, Flags, Prefix, Head, GExCtx, THead, Update), ( Flags /\ 512 =:= 512 -> % object compiled in debug mode asserta((THead :- '$lgt_debug'(fact(Obj, Head, 0, nil, 0), GExCtx)), Ref) ; '$lgt_add_db_lookup_cache_entry'(Obj, Head, SCtn, DclScope, Type, Sender, THead, DDef, Update), asserta(THead, Ref) ) ; % predicate is not within the scope of the sender functor(Head, Functor, Arity), ( Scope == p -> throw(error(permission_error(modify, private_predicate, Functor/Arity), logtalk(asserta(Head, Ref), ExCtx))) ; throw(error(permission_error(modify, protected_predicate, Functor/Arity), logtalk(asserta(Head, Ref), ExCtx))) ) ) ; % predicate is static functor(Head, Functor, Arity), throw(error(permission_error(modify, static_predicate, Functor/Arity), logtalk(asserta(Head, Ref), ExCtx))) ). '$lgt_asserta_fact_checked'(Obj, Head, Ref, _, _, _, ExCtx) :- throw(error(existence_error(object, Obj), logtalk(Obj::asserta(Head, Ref), ExCtx))). % '$lgt_assertz'(+object_identifier, @clause, @term, +object_identifier, +scope, +scope, @execution_context) % % assertz/2 built-in method that takes a clause reference if supported % as built-in predicates by the backend Prolog compiler % % asserting facts uses a caching mechanism that saves the compiled form of the % facts to improve performance '$lgt_assertz'(Obj, Clause, Ref, Sender, _, _, _) :- nonvar(Obj), nonvar(Clause), '$lgt_db_lookup_cache_'(Obj, Clause, Sender, TClause, _), !, assertz(TClause, Ref). '$lgt_assertz'(Obj, Clause, Ref, Sender, TestScope, DclScope, ExCtx) :- '$lgt_check'(object_identifier, Obj, logtalk(Obj::assertz(Clause, Ref), ExCtx)), '$lgt_check'(clause, Clause, logtalk(assertz(Clause, Ref), ExCtx)), ( Clause = (Head :- Body) -> ( Body == true -> '$lgt_assertz_fact_checked'(Obj, Head, Ref, Sender, TestScope, DclScope, ExCtx) ; '$lgt_assertz_rule_checked'(Obj, Clause, Ref, Sender, TestScope, DclScope, ExCtx) ) ; '$lgt_assertz_fact_checked'(Obj, Clause, Ref, Sender, TestScope, DclScope, ExCtx) ). '$lgt_assertz_rule_checked'(Obj, (Head:-Body), Ref, Obj, _, _, ExCtx) :- '$lgt_comp_ctx'(Ctx, _, _, Entity, _, _, _, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, _, Entity), ( '$lgt_uses_predicate_'(Entity, Other, Original, Head, Ctx) -> '$lgt_assertz_rule_checked'(Other, (Original:-Body), Ref, Obj, p(p(_)), p(p(p)), ExCtx) ; '$lgt_use_module_predicate_'(Entity, Module, Original, Head, Ctx) -> assertz(':'(Module, (Original:-Body)), Ref) ; fail ), !. '$lgt_assertz_rule_checked'(Obj, (Head:-Body), Ref, Sender, TestScope, DclScope, ExCtx) :- '$lgt_current_object_'(Obj, Prefix, Dcl, Def, _, _, _, DDcl, DDef, _, Flags), !, '$lgt_assert_pred_dcl'(Obj, Dcl, DDcl, DDef, Flags, Head, Scope, Type, Meta, SCtn, DclScope, assertz((Head:-Body), Ref), ExCtx), ( (Type == (dynamic); Flags /\ 2 =:= 2, Sender = SCtn) -> % either a dynamic predicate or a dynamic object that is both the sender and the predicate scope container ( (Scope = TestScope; Sender = SCtn) -> '$lgt_assert_pred_def'(Def, DDef, Flags, Prefix, Head, GExCtx, THead, _), '$lgt_goal_meta_arguments'(Meta, Head, MetaArgs), '$lgt_comp_ctx'(Ctx, Head, GExCtx, _, _, _, _, Prefix, MetaArgs, _, GExCtx, runtime, _, _, _), '$lgt_compile_body'(Body, _, TBody, DBody, Ctx), ( Flags /\ 512 =:= 512 -> % object compiled in debug mode assertz((THead :- ('$lgt_nop'(Body), '$lgt_debug'(rule(Obj, Head, 0, nil, 0), GExCtx), DBody)), Ref) ; assertz((THead :- ('$lgt_nop'(Body), TBody)), Ref) ) ; % predicate is not within the scope of the sender functor(Head, Functor, Arity), ( Scope == p -> throw(error(permission_error(modify, private_predicate, Functor/Arity), logtalk(assertz((Head:-Body), Ref), ExCtx))) ; throw(error(permission_error(modify, protected_predicate, Functor/Arity), logtalk(assertz((Head:-Body), Ref), ExCtx))) ) ) ; % predicate is static functor(Head, Functor, Arity), throw(error(permission_error(modify, static_predicate, Functor/Arity), logtalk(assertz((Head:-Body), Ref), ExCtx))) ). '$lgt_assertz_rule_checked'(Obj, Clause, Ref, _, _, _, ExCtx) :- throw(error(existence_error(object, Obj), logtalk(Obj::assertz(Clause, Ref), ExCtx))). '$lgt_assertz_fact_checked'(Obj, Head, Ref, Sender, _, _, _) :- '$lgt_db_lookup_cache_'(Obj, Head, Sender, THead, _), !, assertz(THead, Ref). '$lgt_assertz_fact_checked'(Obj, Head, Ref, Obj, _, _, ExCtx) :- '$lgt_comp_ctx'(Ctx, _, _, Entity, _, _, _, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, _, Entity), ( '$lgt_uses_predicate_'(Entity, Other, Original, Head, Ctx) -> '$lgt_assertz_fact_checked'(Other, Original, Ref, Obj, p(p(_)), p(p(p)), ExCtx) ; '$lgt_use_module_predicate_'(Entity, Module, Original, Head, Ctx) -> assertz(':'(Module, Original), Ref) ; fail ), !. '$lgt_assertz_fact_checked'(Obj, Head, Ref, Sender, TestScope, DclScope, ExCtx) :- '$lgt_current_object_'(Obj, Prefix, Dcl, Def, _, _, _, DDcl, DDef, _, Flags), !, '$lgt_assert_pred_dcl'(Obj, Dcl, DDcl, DDef, Flags, Head, Scope, Type, _, SCtn, DclScope, assertz(Head, Ref), ExCtx), ( (Type == (dynamic); Flags /\ 2 =:= 2, Sender = SCtn) -> % either a dynamic predicate or a dynamic object that is both the sender and the predicate scope container ( (Scope = TestScope; Sender = SCtn) -> '$lgt_assert_pred_def'(Def, DDef, Flags, Prefix, Head, GExCtx, THead, Update), ( Flags /\ 512 =:= 512 -> % object compiled in debug mode assertz((THead :- '$lgt_debug'(fact(Obj, Head, 0, nil, 0), GExCtx)), Ref) ; '$lgt_add_db_lookup_cache_entry'(Obj, Head, SCtn, DclScope, Type, Sender, THead, DDef, Update), assertz(THead, Ref) ) ; % predicate is not within the scope of the sender functor(Head, Functor, Arity), ( Scope == p -> throw(error(permission_error(modify, private_predicate, Functor/Arity), logtalk(assertz(Head, Ref), ExCtx))) ; throw(error(permission_error(modify, protected_predicate, Functor/Arity), logtalk(assertz(Head, Ref), ExCtx))) ) ) ; % predicate is static functor(Head, Functor, Arity), throw(error(permission_error(modify, static_predicate, Functor/Arity), logtalk(assertz(Head, Ref), ExCtx))) ). '$lgt_assertz_fact_checked'(Obj, Head, Ref, _, _, _, ExCtx) :- throw(error(existence_error(object, Obj), logtalk(Obj::assertz(Head, Ref), ExCtx))). % '$lgt_clause'(+object_identifier, +callable, ?callable, +object_identifier, +scope, @execution_context) % % clause/3 built-in method that takes a clause reference if supported % as built-in predicates by the backend Prolog compiler '$lgt_clause'(Obj, Head, Body, Ref, Sender, TestScope, ExCtx) :- '$lgt_check'(object_identifier, Obj, logtalk(Obj::clause(Head, Body, Ref), ExCtx)), ( var(Ref) -> '$lgt_check'(clause, (Head:-Body), logtalk(clause(Head, Body, Ref), ExCtx)) ; '$lgt_check'(var_or_callable, Head, logtalk(clause(Head, Body, Ref), ExCtx)), '$lgt_check'(var_or_callable, Body, logtalk(clause(Head, Body, Ref), ExCtx)) ), '$lgt_clause_checked'(Obj, Head, Body, Ref, Sender, TestScope, ExCtx). '$lgt_clause_checked'(Obj, Head, Body, Ref, Obj, _, ExCtx) :- '$lgt_comp_ctx'(Ctx, _, _, Entity, _, _, _, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, _, Entity), '$lgt_uses_predicate_'(Entity, Other, Original, Head, Ctx), Obj \== Other, !, '$lgt_clause_checked'(Other, Original, Body, Ref, Obj, p(p(p)), ExCtx). '$lgt_clause_checked'(_, Head, Body, Ref, _, _, ExCtx) :- '$lgt_comp_ctx'(Ctx, _, _, Entity, _, _, _, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, _, Entity), '$lgt_use_module_predicate_'(Entity, Module, Original, Head, Ctx), !, clause(':'(Module,Original), Body, Ref). '$lgt_clause_checked'(Obj, Head, Body, Ref, _, _, ExCtx) :- nonvar(Ref), !, clause(THead0, TBody, Ref), '$lgt_wrap_compiled_head'(Head, THead0, ExCtx, THead), '$lgt_current_object_'(Obj, _, _, Def, _, _, _, _, DDef, _, _), once((call(DDef, Head, _, THead); call(Def, Head, _, THead))), ( TBody = ('$lgt_nop'(Body), _) -> % rules (compiled both in normal and debug mode) true ; TBody = '$lgt_debug'(fact(_, _, _, _, _), _) -> % facts compiled in debug mode Body = true ; % facts compiled in normal mode TBody = Body ). '$lgt_clause_checked'(Obj, Head, Body, Ref, Sender, _, _) :- '$lgt_db_lookup_cache_'(Obj, Head, Sender, THead, _), !, clause(THead, TBody, Ref), ( TBody = ('$lgt_nop'(Body), _) -> % rules (compiled both in normal and debug mode) true ; TBody = '$lgt_debug'(fact(_, _, _, _, _), _) -> % facts compiled in debug mode Body = true ; % facts compiled in normal mode TBody = Body ). '$lgt_clause_checked'(Obj, Head, Body, Ref, Sender, TestScope, ExCtx) :- '$lgt_current_object_'(Obj, _, Dcl, Def, _, _, _, _, DDef, _, ObjFlags), !, ( call(Dcl, Head, Scope, _, PredFlags, SCtn, _) -> ( (PredFlags /\ 2 =:= 2; ObjFlags /\ 2 =:= 2, Sender = SCtn) -> % either a dynamic predicate or a dynamic object that is both the sender and the predicate scope container ( (Scope = TestScope; Sender = SCtn) -> ( (call(DDef, Head, _, THead0); call(Def, Head, _, THead0)) -> '$lgt_unwrap_compiled_head'(THead0, THead), clause(THead, TBody, Ref), ( TBody = ('$lgt_nop'(Body), _) -> true ; TBody = '$lgt_debug'(fact(_, _, _, _, _), _) -> Body = true ; TBody = Body ) ) ; % predicate is not within the scope of the sender functor(Head, Functor, Arity), ( Scope == p -> throw(error(permission_error(access, private_predicate, Functor/Arity), logtalk(clause(Head, Body, Ref), ExCtx))) ; throw(error(permission_error(access, protected_predicate, Functor/Arity), logtalk(clause(Head, Body, Ref), ExCtx))) ) ) ; % predicate is static functor(Head, Functor, Arity), throw(error(permission_error(access, static_predicate, Functor/Arity), logtalk(clause(Head, Body, Ref), ExCtx))) ) ; Obj = Sender, (call(DDef, Head, _, THead0); call(Def, Head, _, THead0)) -> % local dynamic predicate with no scope declaration '$lgt_unwrap_compiled_head'(THead0, THead), clause(THead, TBody, Ref), ( TBody = ('$lgt_nop'(Body), _) -> true ; TBody = '$lgt_debug'(fact(_, _, _, _, _), _) -> Body = true ; TBody = Body ) ; % unknown predicate functor(Head, Functor, Arity), throw(error(existence_error(predicate_declaration, Functor/Arity), logtalk(clause(Head, Body, Ref), ExCtx))) ). '$lgt_clause_checked'(Obj, Head, Body, Ref, _, _, ExCtx) :- throw(error(existence_error(object, Obj), logtalk(Obj::clause(Head, Body, Ref), ExCtx))). % '$lgt_nop'(+clause) % % used as the first goal in the body of asserted predicate clauses that are % rules to save the original clause body and thus support the implementation % of the clause/2 built-in method '$lgt_nop'(_). % '$lgt_add_db_lookup_cache_entry'(@object_identifier, @callable, @callable, +atom, @object_identifier, @callable) % % adds a new database lookup cache entry (when an update goal is not required) '$lgt_add_db_lookup_cache_entry'(Obj, Head, Scope, Type, Sender, THead) :- '$lgt_term_template'(Obj, GObj), '$lgt_term_template'(Head, GHead), '$lgt_term_template'(THead, GTHead), '$lgt_unify_head_thead_arguments'(GHead, GTHead, _), ( (Scope = p(p(p)), Type == (dynamic)) -> asserta('$lgt_db_lookup_cache_'(GObj, GHead, _, GTHead, true)) ; '$lgt_term_template'(Sender, GSender), asserta('$lgt_db_lookup_cache_'(GObj, GHead, GSender, GTHead, true)) ). % '$lgt_add_db_lookup_cache_entry'(@object_identifier, @callable, @callable, @callable, +atom, @object_identifier, @callable, +atom, +atom) % % adds a new database lookup cache entry '$lgt_add_db_lookup_cache_entry'(Obj, Head, SCtn, Scope, Type, Sender, THead, DDef, NeedsUpdate) :- '$lgt_term_template'(Obj, GObj), '$lgt_term_template'(Head, GHead), '$lgt_term_template'(THead, GTHead), '$lgt_unify_head_thead_arguments'(GHead, GTHead, _), ( NeedsUpdate == true, Sender \= SCtn -> '$lgt_term_template'(Head, UHead), '$lgt_term_template'(THead, UTHead), UClause =.. [DDef, UHead, _, _], ( (Scope = p(p(p)), Type == (dynamic)) -> asserta('$lgt_db_lookup_cache_'(GObj, GHead, _, GTHead, update(UHead, UTHead, UClause))) ; '$lgt_term_template'(Sender, GSender), asserta('$lgt_db_lookup_cache_'(GObj, GHead, GSender, GTHead, update(UHead, UTHead, UClause))) ) ; ( (Scope = p(p(p)), Type == (dynamic)) -> asserta('$lgt_db_lookup_cache_'(GObj, GHead, _, GTHead, true)) ; '$lgt_term_template'(Sender, GSender), asserta('$lgt_db_lookup_cache_'(GObj, GHead, GSender, GTHead, true)) ) ). % '$lgt_unify_head_thead_arguments'(+callable, +callable, @term) % % compiled clause heads use an extra argument for passing the execution context '$lgt_unify_head_thead_arguments'(Head, THead, ExCtx) :- Head =.. [_| Args], THead =.. [_| TArgs], '$lgt_append'(Args, [ExCtx], TArgs). % '$lgt_phrase'(+grbody, ?list, +execution_context, +atom) % % phrase/2 built-in method implementation for calls where the first argument is only known at runtime '$lgt_phrase'(GRBody, Input, ExCtx, _) :- var(GRBody), throw(error(instantiation_error, logtalk(phrase(GRBody, Input), ExCtx))). '$lgt_phrase'('$lgt_local'(GRBody), Input, ExCtx, _) :- !, '$lgt_phrase'(GRBody, Input, ExCtx, local). '$lgt_phrase'(GRBody, Input, ExCtx, Where) :- '$lgt_comp_ctx_mode'(Ctx, runtime), catch( '$lgt_dcg_body'(GRBody, S0, S, Pred, Ctx), Error, throw(error(Error, logtalk(phrase(GRBody, Input), ExCtx))) ), Input = S0, [] = S, '$lgt_metacall'(Pred, ExCtx, Where). % '$lgt_phrase'(+grbody, ?list, ?list, +execution_context) % % phrase/3 built-in method implementation for calls where the first argument is only known at runtime '$lgt_phrase'(GRBody, Input, Rest, ExCtx, _) :- var(GRBody), throw(error(instantiation_error, logtalk(phrase(GRBody, Input, Rest), ExCtx))). '$lgt_phrase'('$lgt_local'(GRBody), Input, Rest, ExCtx, _) :- !, '$lgt_phrase'(GRBody, Input, Rest, ExCtx, local). '$lgt_phrase'(GRBody, Input, Rest, ExCtx, Where) :- '$lgt_comp_ctx_mode'(Ctx, runtime), catch( '$lgt_dcg_body'(GRBody, S0, S, Pred, Ctx), Error, throw(error(Error, logtalk(phrase(GRBody, Input, Rest), ExCtx))) ), Input = S0, Rest = S, '$lgt_metacall'(Pred, ExCtx, Where). % '$lgt_expand_term_local'(+object_identifier, ?term, ?term, @execution_context) % '$lgt_expand_term_local'(+category_identifier, ?term, ?term, @execution_context) % % expand_term/2 local calls % % calls the term_expansion/2 user-defined hook predicate if defined and within scope '$lgt_expand_term_local'(Entity, Term, Expansion, ExCtx) :- ( var(Term) -> Expansion = Term ; '$lgt_term_expansion_local'(Entity, Term, Expand, ExCtx) -> Expansion = Expand ; Term = (_ --> _) -> % default grammar rule expansion '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, _, [], _, _, runtime, _, _, _), catch( '$lgt_dcg_rule'(Term, Clause, Ctx), Error, throw(error(Error, logtalk(expand_term(Term,_), ExCtx))) ), ( Clause = (Head :- Body), '$lgt_compiler_flag'(optimize, on) -> '$lgt_simplify_goal'(Body, SBody), ( SBody == true -> Expansion = Head ; Expansion = (Head :- SBody) ) ; % fact and/or optimization disabled Expansion = Clause ) ; Expansion = Term ). % '$lgt_term_expansion_local'(+object_identifier, ?term, ?term, +execution_context) % % to avoid failures when the call is made from a multifile predicate clause, % first the term_expansion/2 definition container is located and then the % call is reduced to a local call '$lgt_term_expansion_local'(Obj, Term, Expansion, ExCtx) :- '$lgt_current_object_'(Obj, _, Dcl, Def, _, _, _, _, DDef, _, _), !, ( call(Dcl, term_expansion(_, _), Scope, _, _, SCtn, _) -> ( (Scope = p(_); Obj = SCtn) -> ( call(Def, term_expansion(_, _), _, _, _, DCtn) -> ( '$lgt_current_object_'(DCtn, _, _, DCtnDef, _, _, _, _, DCtnDDef, _, _) -> ( call(DCtnDef, term_expansion(Term, Expansion), ExCtx, Call) -> true ; call(DCtnDDef, term_expansion(Term, Expansion), ExCtx, Call) ) ; '$lgt_current_category_'(DCtn, _, _, DCtnDef, _, _), call(DCtnDef, term_expansion(Term, Expansion), ExCtx, Call) ) ; % no definition found fail ) ; % declaration is out of scope but we can still try a local definition call(Def, term_expansion(Term, Expansion), ExCtx, Call) -> true ; call(DDef, term_expansion(Term, Expansion), ExCtx, Call) ) ; % no declaration for the term_expansion/2 hook predicate found; % check for a local definition call(Def, term_expansion(Term, Expansion), ExCtx, Call) -> true ; call(DDef, term_expansion(Term, Expansion), ExCtx, Call) ), !, once(Call). '$lgt_term_expansion_local'(Ctg, Term, Expansion, ExCtx) :- '$lgt_current_category_'(Ctg, _, Dcl, Def, _, _), ( call(Dcl, term_expansion(_, _), Scope, _, _, DclCtn) -> ( (Scope = p(_); Ctg = DclCtn) -> ( call(Def, term_expansion(_, _), _, _, DCtn) -> '$lgt_current_category_'(DCtn, _, _, DCtnDef, _, _), call(DCtnDef, term_expansion(Term, Expansion), ExCtx, Call) ; % no definition found fail ) ; % declaration is out of scope but we can still try a local definition call(Def, term_expansion(Term, Expansion), ExCtx, Call) ) ; % no declaration for the term_expansion/2 hook predicate found; % check for a local definition call(Def, term_expansion(Term, Expansion), ExCtx, Call) ), !, once(Call). % '$lgt_expand_term_message'(+object_identifier, ?term, ?term, +object_identifier, @scope, @execution_context) % % expand_term/2 messages % % calls the term_expansion/2 user-defined hook predicate if defined and within scope '$lgt_expand_term_message'(Entity, Term, Expansion, Sender, Scope, ExCtx) :- ( var(Term) -> Expansion = Term ; '$lgt_term_expansion_message'(Entity, Term, Expand, Sender, Scope) -> Expansion = Expand ; Term = (_ --> _) -> % default grammar rule expansion '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, _, [], _, _, runtime, _, _, _), catch( '$lgt_dcg_rule'(Term, Clause, Ctx), Error, throw(error(Error, logtalk(expand_term(Term,_), ExCtx))) ), ( Clause = (Head :- Body), '$lgt_compiler_flag'(optimize, on) -> '$lgt_simplify_goal'(Body, SBody), ( SBody == true -> Expansion = Head ; Expansion = (Head :- SBody) ) ; % fact and/or optimization disabled Expansion = Clause ) ; Expansion = Term ). % '$lgt_term_expansion_message'(+object_identifier, ?term, ?term, +object_identifier, @scope) '$lgt_term_expansion_message'(Obj, Term, Expansion, Sender, LookupScope) :- '$lgt_current_object_'(Obj, _, Dcl, Def, _, _, _, _, _, _, _), ( call(Dcl, term_expansion(_, _), PredScope, _, _, SCtn, _) -> ( (PredScope = LookupScope; Sender = SCtn) -> '$lgt_execution_context'(ExCtx, Obj, Sender, Obj, Obj, [], []), call(Def, term_expansion(Term, Expansion), ExCtx, Call, _, _) ; % message is out of scope fail ) ; % no declaration for the term_expansion/2 hook predicate found fail ), !, once(Call). % '$lgt_expand_goal_local'(+object_identifier, ?term, ?term, @execution_context) % '$lgt_expand_goal_local'(+category_identifier, ?term, ?term, @execution_context) % % expand_goal/2 local calls % % calls the goal_expansion/2 user-defined hook predicate if defined and within scope '$lgt_expand_goal_local'(Obj, Goal, ExpandedGoal, ExCtx) :- '$lgt_current_object_'(Obj, _, Dcl, Def, _, _, _, _, DDef, _, _), !, ( call(Dcl, goal_expansion(_, _), Scope, _, _, SCtn, _) -> ( (Scope = p(_); Obj = SCtn) -> '$lgt_expand_goal_object_scoped'(Goal, ExpandedGoal, Def, ExCtx) ; % declaration is out of scope but we can still try a local definition '$lgt_expand_goal_object_local'(Goal, ExpandedGoal, Def, DDef, ExCtx, []) ) ; % no declaration for the goal_expansion/2 hook predicate found; % try to use a local definition if it exists '$lgt_expand_goal_object_local'(Goal, ExpandedGoal, Def, DDef, ExCtx, []) ). '$lgt_expand_goal_local'(Ctg, Goal, ExpandedGoal, ExCtx) :- '$lgt_current_category_'(Ctg, _, Dcl, Def, _, _), ( call(Dcl, goal_expansion(_, _), Scope, _, _, DclCtn) -> ( (Scope = p(_); Ctg = DclCtn) -> '$lgt_expand_goal_category_scoped'(Goal, ExpandedGoal, Def, ExCtx) ; % declaration is out of scope but we can still try a local definition '$lgt_expand_goal_category_local'(Goal, ExpandedGoal, Def, ExCtx, []) ) ; % no declaration for the goal_expansion/2 hook predicate found; % try to use a local definition if it exists '$lgt_expand_goal_category_local'(Goal, ExpandedGoal, Def, ExCtx, []) ). % '$lgt_expand_goal_object_scoped'(?term, ?term, +atom, +execution_context) % % to avoid failures when the call is made from a multifile predicate clause, % first the goal_expansion/2 definition container is located and then the % call is reduced to a local call '$lgt_expand_goal_object_scoped'(Goal, ExpandedGoal, Def, ExCtx) :- ( call(Def, goal_expansion(_, _), _, _, _, DCtn) -> ( '$lgt_current_object_'(DCtn, _, _, DCtnDef, _, _, _, _, DCtnDDef, _, _) -> '$lgt_expand_goal_object_local'(Goal, ExpandedGoal, DCtnDef, DCtnDDef, ExCtx, []) ; '$lgt_current_category_'(DCtn, _, _, DCtnDef, _, _), '$lgt_expand_goal_category_local'(Goal, ExpandedGoal, DCtnDef, ExCtx, []) ) ; % no goal_expansion/2 hook predicate definition found ExpandedGoal = Goal ). % '$lgt_expand_goal_object_local'(?term, ?term, +atom, +atom, +execution_context, +list) '$lgt_expand_goal_object_local'(Goal, ExpandedGoal, Def, DDef, ExCtx, ExpandedGoals) :- ( var(Goal) -> ExpandedGoal = Goal ; '$lgt_push_if_new'(ExpandedGoals, Goal, NewExpandedGoals), % lookup local goal_expansion/2 hook predicate definition ( call(Def, goal_expansion(Goal, ExpandedGoal0), ExCtx, Call) ; call(DDef, goal_expansion(Goal, ExpandedGoal0), ExCtx, Call) ) -> ( call(Call), Goal \== ExpandedGoal0 -> '$lgt_expand_goal_object_local'(ExpandedGoal0, ExpandedGoal, Def, DDef, ExCtx, NewExpandedGoals) ; % fixed-point found ExpandedGoal = Goal ) ; % no local goal_expansion/2 hook predicate definition found ExpandedGoal = Goal ). % '$lgt_expand_goal_category_scoped'(?term, ?term, +atom, +execution_context) % % to avoid failures when the call is made from a multifile predicate clause, % first the goal_expansion/2 definition container is located and then the % call is reduced to a local call '$lgt_expand_goal_category_scoped'(Goal, ExpandedGoal, Def, ExCtx) :- ( call(Def, goal_expansion(_, _), _, _, DCtn) -> '$lgt_current_category_'(DCtn, _, _, DCtnDef, _, _), '$lgt_expand_goal_category_local'(Goal, ExpandedGoal, DCtnDef, ExCtx, []) ; % no local goal_expansion/2 hook predicate definition found ExpandedGoal = Goal ). % '$lgt_expand_goal_object_local'(?term, ?term, +atom, +execution_context, +list) '$lgt_expand_goal_category_local'(Goal, ExpandedGoal, Def, ExCtx, ExpandedGoals) :- ( var(Goal) -> ExpandedGoal = Goal ; '$lgt_push_if_new'(ExpandedGoals, Goal, NewExpandedGoals), % lookup local goal_expansion/2 hook predicate definition call(Def, goal_expansion(Goal, ExpandedGoal0), ExCtx, Call) -> ( call(Call), Goal \== ExpandedGoal0 -> '$lgt_expand_goal_category_local'(ExpandedGoal0, ExpandedGoal, Def, ExCtx, NewExpandedGoals) ; % fixed-point found ExpandedGoal = Goal ) ; % no local goal_expansion/2 hook predicate definition found ExpandedGoal = Goal ). % '$lgt_expand_goal_message'(+object_identifier, ?term, ?term, +object_identifier, @scope) % % expand_goal/2 messages % % calls the goal_expansion/2 user-defined hook predicate if defined and within scope '$lgt_expand_goal_message'(Obj, Goal, ExpandedGoal, Sender, LookupScope) :- '$lgt_current_object_'(Obj, _, Dcl, Def, _, _, _, _, _, _, _), ( % lookup visible goal_expansion/2 hook predicate declaration call(Dcl, goal_expansion(_, _), PredScope, _, _, SCtn, _) -> ( (PredScope = LookupScope; Sender = SCtn) -> '$lgt_execution_context'(ExCtx, Obj, Sender, Obj, Obj, [], []), '$lgt_expand_goal_message_aux'(Goal, ExpandedGoal, Def, ExCtx, []) ; % message is out of scope ExpandedGoal = Goal ) ; % no declaration for the goal_expansion/2 hook predicate found ExpandedGoal = Goal ). % '$lgt_expand_goal_message_aux'(?term, ?term, +atom, +execution_context, +list) '$lgt_expand_goal_message_aux'(Goal, ExpandedGoal, Def, ExCtx, ExpandedGoals) :- ( var(Goal) -> ExpandedGoal = Goal ; '$lgt_push_if_new'(ExpandedGoals, Goal, NewExpandedGoals), % lookup visible goal_expansion/2 hook predicate definition call(Def, goal_expansion(Goal, ExpandedGoal0), ExCtx, Call, _, _) -> ( call(Call), Goal \== ExpandedGoal0 -> '$lgt_expand_goal_message_aux'(ExpandedGoal0, ExpandedGoal, Def, ExCtx, NewExpandedGoals) ; % fixed-point found ExpandedGoal = Goal ) ; % no visible goal_expansion/2 hook predicate definition found ExpandedGoal = Goal ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % message-sending % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % '$lgt_send_to_self'(?term, +compilation_context) % % runtime processing of a message-sending call when the message is not % known at compile-time '$lgt_send_to_self'(Pred, Ctx) :- % we must ensure that the argument is valid before compiling the message % sending goal otherwise there would be a potential for an endless loop '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), '$lgt_check'(callable, Pred, logtalk(::Pred, ExCtx)), catch('$lgt_compile_message_to_self'(Pred, TPred, Ctx), Error, throw(error(Error, logtalk(::Pred, ExCtx)))), call(TPred). % '$lgt_send_to_self_'(+object_identifier, +callable, +execution_context) % % the last clause of this dynamic binding cache predicate must always exist % and must call the predicate that generates the missing cache entry '$lgt_send_to_self_'(Obj, Pred, SenderExCtx) :- '$lgt_send_to_self_nv'(Obj, Pred, SenderExCtx). % '$lgt_send_to_self_nv'(+object_identifier, +callable, +execution_context) % % runtime processing of a message-sending call when the arguments have already % been type-checked; generates a cache entry to speed up future calls '$lgt_send_to_self_nv'(Obj, Pred, SenderExCtx) :- '$lgt_current_object_'(Obj, _, Dcl, Def, _, _, _, _, _, _, _), '$lgt_execution_context'(SenderExCtx, _, _, Sender, _, _, _), ( % lookup predicate declaration call(Dcl, Pred, Scope, Meta, _, SCtn, _) -> ( % check scope (Scope = p(_); Sender = SCtn) -> ( % construct predicate, object, and "sender" templates '$lgt_term_template'(Pred, GPred), '$lgt_term_template'(Obj, GObj), '$lgt_term_template'(Sender, GSender), % get the execution context for meta-calls '$lgt_goal_meta_call_context'(Meta, GSenderExCtx, GSender, GMetaCallCtx), % lookup predicate definition '$lgt_execution_context'(GExCtx, _, GSender, GObj, GObj, GMetaCallCtx, []), call(Def, GPred, GExCtx, GCall, _, _) -> % cache lookup result (the cut prevents backtracking into the catchall clause) asserta(('$lgt_send_to_self_'(GObj, GPred, GSenderExCtx) :- !, GCall)), % unify message arguments and call method GObj = Obj, GPred = Pred, GSender = Sender, GSenderExCtx = SenderExCtx, call(GCall) ; % no definition found; fail as per closed-world assumption fail ) ; % message is not within the scope of the sender functor(Pred, Functor, Arity), throw(error(permission_error(access, private_predicate, Functor/Arity), logtalk(::Pred, SenderExCtx))) ) ; % no predicate declaration, check if it's a built-in method '$lgt_built_in_method'(Pred, Scope, _, _) -> ( Scope == p -> functor(Pred, Functor, Arity), throw(error(permission_error(access, private_predicate, Functor/Arity), logtalk(::Pred, SenderExCtx))) ; % Scope == p(p(p)), '$lgt_comp_ctx'(Ctx, _, _, _, Sender, Obj, Obj, _, [], _, _, runtime, _, _, _), '$lgt_compile_message_to_self'(Pred, Call, Ctx), call(Call) ) ; % message not understood; check for a message forwarding handler call(Def, forward(Pred), ExCtx, Call, _, _) -> '$lgt_execution_context'(ExCtx, _, Sender, Obj, Obj, [], []), call(Call) ; % give up and throw an existence error functor(Pred, Functor, Arity), throw(error(existence_error(predicate_declaration, Functor/Arity), logtalk(::Pred, SenderExCtx))) ). % '$lgt_send_to_obj_rt'(?term, ?term, +atom, +compilation_context) % % runtime processing of a message-sending call when the message and % possibly the receiver object are not known at compile-time '$lgt_send_to_obj_rt'(Obj, Pred, Events, Ctx) :- % we must ensure that the message is valid before compiling the % message-sending goal otherwise an endless loop could result '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), '$lgt_check'(callable, Pred, logtalk(Obj::Pred, ExCtx)), catch( '$lgt_compile_message_to_object'(Pred, Obj, TPred, Events, Ctx), Error, throw(error(Error, logtalk(Obj::Pred, ExCtx))) ), call(TPred). % '$lgt_send_to_obj'(+object_identifier, +callable, +execution_context) % % runtime processing of an event-aware message-sending call when the % receiver object is not known at compile-time; as using the cache % only requires a bound first argument, we delay errors other than an % instantiation error for a small performance gain '$lgt_send_to_obj'(Obj, Pred, SenderExCtx) :- ( nonvar(Obj) -> '$lgt_send_to_obj_'(Obj, Pred, SenderExCtx) ; throw(error(instantiation_error, logtalk(Obj::Pred, SenderExCtx))) ). % '$lgt_send_to_obj_'(+object_identifier, +callable, +execution_context) % % the last clause of this dynamic binding cache predicate must always exist % and must call the predicate that generates the missing cache entry '$lgt_send_to_obj_'(Obj, Pred, SenderExCtx) :- '$lgt_send_to_obj_nv'(Obj, Pred, SenderExCtx). % '$lgt_send_to_obj_nv'(+object_identifier, +callable, +execution_context) % % runtime processing of an event-aware message-sending call when the arguments % have already been type-checked; generates a cache entry to speed up future calls '$lgt_send_to_obj_nv'(Obj, Pred, SenderExCtx) :- '$lgt_execution_context'(SenderExCtx, _, _, Sender, _, _, _), % call all before event handlers \+ ('$lgt_before_event_'(Obj, Pred, Sender, _, Before), \+ Before), % process the message; we cannot simply call '$lgt_send_to_obj_ne'/3 % as the generated cache entries are different '$lgt_send_to_obj_nv_inner'(Obj, Pred, Sender, SenderExCtx), % call all after event handlers \+ ('$lgt_after_event_'(Obj, Pred, Sender, _, After), \+ After). '$lgt_send_to_obj_nv_inner'(Obj, Pred, Sender, SenderExCtx) :- '$lgt_current_object_'(Obj, _, Dcl, Def, _, _, _, _, _, _, _), !, ( % lookup predicate declaration call(Dcl, Pred, Scope, Meta, _, SCtn, _) -> ( % check public scope Scope = p(p(_)) -> ( % construct predicate and object templates '$lgt_term_template'(Pred, GPred), '$lgt_term_template'(Obj, GObj), % get the execution context for meta-calls '$lgt_goal_meta_call_context'(Meta, GSenderExCtx, GSender, GMetaCallCtx), % lookup predicate definition '$lgt_execution_context'(GExCtx, _, GSender, GObj, GObj, GMetaCallCtx, []), call(Def, GPred, GExCtx, GCall, _, _) -> GGCall = '$lgt_guarded_method_call'(GObj, GPred, GSender, GCall), % cache lookup result (the cut prevents backtracking into the catchall clause) asserta(('$lgt_send_to_obj_'(GObj, GPred, GSenderExCtx) :- !, GGCall)), % unify message arguments and call method GObj = Obj, GPred = Pred, GSender = Sender, GSenderExCtx = SenderExCtx, call(GCall) ; % no definition found; fail as per closed-world assumption fail ) ; % protected or private scope: check if sender and scope container are the same; % do not cache the lookup result as it's only valid when the sender unifies with % the scope container Sender = SCtn -> ( '$lgt_execution_context'(ExCtx, _, Sender, Obj, Obj, _, []), % lookup predicate definition call(Def, Pred, ExCtx, Call, _, _) -> '$lgt_guarded_method_call'(Obj, Pred, Sender, Call) ; % no definition found; fail as per closed-world assumption fail ) ; % message is not within the scope of the sender functor(Pred, Functor, Arity), ( Scope == p -> throw(error(permission_error(access, private_predicate, Functor/Arity), logtalk(Obj::Pred, SenderExCtx))) ; throw(error(permission_error(access, protected_predicate, Functor/Arity), logtalk(Obj::Pred, SenderExCtx))) ) ) ; % no predicate declaration, check if it's a built-in method '$lgt_built_in_method'(Pred, Scope, _, _) -> ( Scope == p -> functor(Pred, Functor, Arity), throw(error(permission_error(access, private_predicate, Functor/Arity), logtalk(Obj::Pred, SenderExCtx))) ; % Scope == p(p(p)), '$lgt_comp_ctx'(Ctx, _, _, _, Sender, Obj, Obj, _, _, _, _, runtime, _, _, _), '$lgt_compile_message_to_object'(Pred, Obj, Call, allow, Ctx), call(Call) ) ; % message not understood; check for a message forwarding handler call(Def, forward(Pred), ExCtx, Call, _, _) -> '$lgt_execution_context'(ExCtx, _, Sender, Obj, Obj, [], []), call(Call) ; % give up and throw an existence error functor(Pred, Functor, Arity), throw(error(existence_error(predicate_declaration, Functor/Arity), logtalk(Obj::Pred, SenderExCtx))) ). '$lgt_send_to_obj_nv_inner'({Proxy}, Pred, _, SenderExCtx) :- !, % parametric object proxy catch(Proxy, error(Error, _), throw(error(Error, logtalk({Proxy}::Pred, SenderExCtx)))), '$lgt_send_to_obj_'(Proxy, Pred, SenderExCtx). '$lgt_send_to_obj_nv_inner'(Obj, Pred, _, _) :- atom(Obj), '$lgt_prolog_feature'(modules, supported), current_module(Obj), !, % allow Obj::Pred to be used as a shortcut for calling module predicates ':'(Obj, Pred). '$lgt_send_to_obj_nv_inner'(Obj, Pred, _, SenderExCtx) :- \+ callable(Obj), throw(error(type_error(object_identifier, Obj), logtalk(Obj::Pred, SenderExCtx))). '$lgt_send_to_obj_nv_inner'(Obj, Pred, _, SenderExCtx) :- throw(error(existence_error(object, Obj), logtalk(Obj::Pred, SenderExCtx))). % '$lgt_guarded_method_call'(+object_identifier, +callable, +object_identifier, +callable) % % wraps the method call with the before and after event handler calls; the "before" event handler % may prevent a method from being executed by failing and an "after" event handler may prevent a % method from succeeding by failing; however, event handlers cannot modify the method call '$lgt_guarded_method_call'(Obj, Msg, Sender, Method) :- % call before event handlers \+ ('$lgt_before_event_'(Obj, Msg, Sender, _, Before), \+ Before), % call method call(Method), % call after event handlers \+ ('$lgt_after_event_'(Obj, Msg, Sender, _, After), \+ After). % '$lgt_send_to_obj_ne'(+object_identifier, +callable, +execution_context) % % runtime processing of an event-transparent message-sending call when % the receiver object is not known at compile-time; as using the cache % only requires a bound first argument, we delay errors other than an % instantiation error for a small performance gain '$lgt_send_to_obj_ne'(Obj, Pred, SenderExCtx) :- ( nonvar(Obj) -> '$lgt_send_to_obj_ne_'(Obj, Pred, SenderExCtx) ; throw(error(instantiation_error, logtalk(Obj::Pred, SenderExCtx))) ). % '$lgt_send_to_obj_ne_'(+object_identifier, +callable, +execution_context) % % the last clause of this dynamic binding cache predicate must always exist % and must call the predicate that generates the missing cache entry '$lgt_send_to_obj_ne_'(Obj, Pred, SenderExCtx) :- '$lgt_send_to_obj_ne_nv'(Obj, Pred, SenderExCtx). % '$lgt_send_to_obj_ne_nv'(+object_identifier, +term, +execution_context) % % runtime processing of an event-transparent message-sending call when the arguments % have already been type-checked; generates a cache entry to speed up future calls '$lgt_send_to_obj_ne_nv'(Obj, Pred, SenderExCtx) :- '$lgt_current_object_'(Obj, _, Dcl, Def, _, _, _, _, _, _, _), !, '$lgt_execution_context'(SenderExCtx, _, _, Sender, _, _, _), ( % lookup predicate declaration call(Dcl, Pred, Scope, Meta, _, SCtn, _) -> ( % check public scope Scope = p(p(_)) -> ( % construct predicate and object templates '$lgt_term_template'(Pred, GPred), '$lgt_term_template'(Obj, GObj), % get the execution context for meta-calls '$lgt_goal_meta_call_context'(Meta, GSenderExCtx, GSender, GMetaCallCtx), % lookup predicate definition '$lgt_execution_context'(GExCtx, _, GSender, GObj, GObj, GMetaCallCtx, []), call(Def, GPred, GExCtx, GCall, _, _) -> % cache lookup result (the cut prevents backtracking into the catchall clause) asserta(('$lgt_send_to_obj_ne_'(GObj, GPred, GSenderExCtx) :- !, GCall)), % unify message arguments and call method GObj = Obj, GPred = Pred, GSender = Sender, GSenderExCtx = SenderExCtx, call(GCall) ; % no definition found; fail as per closed-world assumption fail ) ; % protected or private scope: check if sender and scope container are the same; % do not cache the lookup result as it's only valid when the sender unifies with % the scope container Sender = SCtn -> ( % lookup predicate definition '$lgt_execution_context'(ExCtx, _, Sender, Obj, Obj, _, []), call(Def, Pred, ExCtx, Call, _, _) -> call(Call) ; % no definition found; fail as per closed-world assumption fail ) ; % message is not within the scope of the sender functor(Pred, Functor, Arity), ( Scope == p -> throw(error(permission_error(access, private_predicate, Functor/Arity), logtalk(Obj::Pred, SenderExCtx))) ; throw(error(permission_error(access, protected_predicate, Functor/Arity), logtalk(Obj::Pred, SenderExCtx))) ) ) ; % no predicate declaration, check if it's a built-in method '$lgt_built_in_method'(Pred, Scope, _, _) -> ( Scope == p -> functor(Pred, Functor, Arity), throw(error(permission_error(access, private_predicate, Functor/Arity), logtalk(Obj::Pred, SenderExCtx))) ; % Scope == p(p(p)), '$lgt_comp_ctx'(Ctx, _, _, _, Sender, Obj, Obj, _, _, _, _, runtime, _, _, _), '$lgt_compile_message_to_object'(Pred, Obj, Call, deny, Ctx), call(Call) ) ; % message not understood; check for a message forwarding handler call(Def, forward(Pred), ExCtx, Call, _, _) -> '$lgt_execution_context'(ExCtx, _, Sender, Obj, Obj, [], []), call(Call) ; % give up and throw an existence error functor(Pred, Functor, Arity), throw(error(existence_error(predicate_declaration, Functor/Arity), logtalk(Obj::Pred, SenderExCtx))) ). '$lgt_send_to_obj_ne_nv'({Proxy}, Pred, SenderExCtx) :- !, % parametric object proxy catch(Proxy, error(Error, _), throw(error(Error, logtalk({Proxy}::Pred, SenderExCtx)))), '$lgt_send_to_obj_ne_'(Proxy, Pred, SenderExCtx). '$lgt_send_to_obj_ne_nv'(Obj, Pred, _) :- atom(Obj), '$lgt_prolog_feature'(modules, supported), current_module(Obj), !, % allow Obj::Pred to be used as a shortcut for calling module predicates ':'(Obj, Pred). '$lgt_send_to_obj_ne_nv'(Obj, Pred, SenderExCtx) :- \+ callable(Obj), throw(error(type_error(object_identifier, Obj), logtalk(Obj::Pred, SenderExCtx))). '$lgt_send_to_obj_ne_nv'(Obj, Pred, SenderExCtx) :- throw(error(existence_error(object, Obj), logtalk(Obj::Pred, SenderExCtx))). % '$lgt_obj_super_call'(+atom, +term, +execution_context) % % runtime processing of an object "super" call when the predicate called is % not known at compile-time; as using the cache only requires a bound first % argument, we delay errors other than an instantiation error for a small % performance gain '$lgt_obj_super_call'(Super, Pred, ExCtx) :- ( nonvar(Pred) -> '$lgt_obj_super_call_'(Super, Pred, ExCtx) ; throw(error(instantiation_error, logtalk(^^Pred, ExCtx))) ). % '$lgt_obj_super_call_'(+atom, +callable, +execution_context) % % the last clause of this dynamic binding cache predicate must always exist % and must call the predicate that generates the missing cache entry '$lgt_obj_super_call_'(Super, Pred, ExCtx) :- '$lgt_obj_super_call_nv'(Super, Pred, ExCtx). % '$lgt_obj_super_call_nv'(+atom, +callable, +execution_context) % % runtime processing of an object "super" call when the arguments have already % been type-checked; generates a cache entry to speed up future calls % % we may need to pass "self" when looking for the inherited predicate definition % in order to be able to select the correct "super" clause for those cases where % "this" both instantiates and specializes other objects '$lgt_obj_super_call_nv'(Super, Pred, ExCtx) :- '$lgt_execution_context'(ExCtx, _, _, This, Self, _, _), '$lgt_current_object_'(Self, _, Dcl, _, _, _, _, _, _, _, _), ( % lookup predicate declaration (the predicate must not be % declared in the same entity making the "super" call) call(Dcl, Pred, Scope, _, _, SCtn, TCtn), TCtn \= This -> ( % check scope (Scope = p(_); This = SCtn) -> ( % construct predicate, "this", and "self" templates '$lgt_term_template'(Pred, GPred), '$lgt_term_template'(This, GThis), '$lgt_term_template'(Self, GSelf), % check if we have a dependency on "self" to select the correct "super" clause ( '$lgt_extends_object_'(GThis, _, _) -> true ; '$lgt_execution_context'(GExCtx, _, _, GThis, GSelf, _, _) ), % lookup predicate definition (the predicate must not be % defined in the same entity making the "super" call) call(Super, GPred, GExCtx, GCall, _, DefCtn), DefCtn \= GThis -> % cache lookup result (the cut prevents backtracking into the catchall clause) asserta(('$lgt_obj_super_call_'(Super, GPred, GExCtx) :- !, GCall)), % unify message arguments and call inherited definition GPred = Pred, GExCtx = ExCtx, call(GCall) ; % no definition found; fail as per closed-world assumption fail ) ; % predicate is not within the scope of the sender functor(Pred, Functor, Arity), throw(error(permission_error(access, private_predicate, Functor/Arity), logtalk(^^Pred, ExCtx))) ) ; % no predicate declaration, check if it's a private built-in method '$lgt_built_in_method'(Pred, p, _, _) -> functor(Pred, Functor, Arity), throw(error(permission_error(access, private_predicate, Functor/Arity), logtalk(^^Pred, ExCtx))) ; % non-callable term error \+ callable(Pred) -> throw(error(type_error(callable, Pred), logtalk(^^Pred, ExCtx))) ; % give up and throw an existence error functor(Pred, Functor, Arity), throw(error(existence_error(predicate_declaration, Functor/Arity), logtalk(^^Pred, ExCtx))) ). % '$lgt_ctg_super_call'(+category_identifier, +term, +execution_context) % % runtime processing of a category "super" call when the predicate called % is not known at compile-time; as using the cache only requires a bound % first argument, we delay errors other than an instantiation error for a % small performance gain '$lgt_ctg_super_call'(Ctg, Pred, ExCtx) :- ( nonvar(Pred) -> '$lgt_ctg_super_call_'(Ctg, Pred, ExCtx) ; throw(error(instantiation_error, logtalk(^^Pred, ExCtx))) ). % '$lgt_ctg_super_call_'(+category_identifier, +callable, +execution_context) % % the last clause of this dynamic binding cache predicate must always exist % and must call the predicate that generates the missing cache entry '$lgt_ctg_super_call_'(Ctg, Pred, ExCtx) :- '$lgt_ctg_super_call_nv'(Ctg, Pred, ExCtx). % '$lgt_ctg_super_call_nv'(+category_identifier, +callable, +execution_context) % % runtime processing of a category "super" call when the arguments have already % been type-checked; generates a cache entry to speed up future calls '$lgt_ctg_super_call_nv'(Ctg, Pred, ExCtx) :- '$lgt_current_category_'(Ctg, _, Dcl, Def, _, _), ( % lookup predicate declaration (the predicate must not be % declared in the same entity making the "super" call) call(Dcl, Pred, Scope, _, _, DclCtn), DclCtn \= Ctg -> ( % check that the call is within scope (i.e., public or protected) Scope = p(_) -> ( % construct category and predicate templates '$lgt_term_template'(Ctg, GCtg), '$lgt_term_template'(Pred, GPred), % lookup predicate definition (the predicate must not be % defined in the same entity making the "super" call) call(Def, GPred, GExCtx, GCall, DefCtn), DefCtn \= Ctg -> % cache lookup result (the cut prevents backtracking into the catchall clause) asserta(('$lgt_ctg_super_call_'(GCtg, GPred, GExCtx) :- !, GCall)), % unify message arguments and call inherited definition GCtg = Ctg, GPred = Pred, GExCtx = ExCtx, call(GCall) ; % no definition found; fail as per closed-world assumption fail ) ; % predicate is not within the scope of the sender functor(Pred, Functor, Arity), throw(error(permission_error(access, private_predicate, Functor/Arity), logtalk(^^Pred, ExCtx))) ) ; % no predicate declaration, check if it's a private built-in method '$lgt_built_in_method'(Pred, p, _, _) -> functor(Pred, Functor, Arity), throw(error(permission_error(access, private_predicate, Functor/Arity), logtalk(^^Pred, ExCtx))) ; % non-callable term error \+ callable(Pred) -> throw(error(type_error(callable, Pred), logtalk(^^Pred, ExCtx))) ; % give up and throw an existence error functor(Pred, Functor, Arity), throw(error(existence_error(predicate_declaration, Functor/Arity), logtalk(^^Pred, ExCtx))) ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % meta-calls % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % '$lgt_lambda'(+curly_bracketed_term, @callable) % % calls a lambda-call with free variables but no parameters (Free/Goal) where the % arguments are already checked and compiled; typically used in bagof/3 and setof/3 % as an alternative to the enumeration of all existentially quantified variables '$lgt_lambda'(Free, Goal) :- '$lgt_copy_term_without_constraints'(Free/Goal, Free/GoalCopy), call(GoalCopy). % '$lgt_metacall'(?term, +list, +execution_context, +atom) % % performs a runtime meta-call constructed from a closure and a list % of additional arguments % % the last argument is either "local", in case of a local meta-call, % or "runtime", in case the decision between a local meta-call or a % meta-call in the sender is decided at runtime '$lgt_metacall'(Closure, ExtraArgs, ExCtx, _) :- var(Closure), Call =.. [call, Closure| ExtraArgs], throw(error(instantiation_error, logtalk(Call, ExCtx))). '$lgt_metacall'('$lgt_closure'(TFunctor, TArgs, ExCtx), ExtraArgs, _, _) :- % pre-compiled closure (note that the closure may be called from a mapping % predicate, which prevents us to use a difference list based solution to % avoid the calls to append/3 and =../2 as that would fix the extra arguments % in the goal on the first closure call and thus break the followup calls) !, '$lgt_append'(TArgs, ExtraArgs, FullArgs), TGoal =.. [TFunctor| FullArgs], call(TGoal, ExCtx). '$lgt_metacall'('$lgt_local'(Closure), ExtraArgs, ExCtx, _) :- !, '$lgt_metacall'(Closure, ExtraArgs, ExCtx, local). '$lgt_metacall'({Closure}, ExtraArgs, ExCtx, _) :- !, % compiler bypass (call of external code) ( atom(Closure) -> Goal =.. [Closure| ExtraArgs], call(Goal) ; compound(Closure) -> Closure =.. [Functor| Args], '$lgt_append'(Args, ExtraArgs, FullArgs), Goal =.. [Functor| FullArgs], call(Goal) ; var(Closure) -> Call =.. [call, {Closure}| ExtraArgs], throw(error(instantiation_error, logtalk(Call, ExCtx))) ; Call =.. [call, {Closure}| ExtraArgs], throw(error(type_error(callable, Closure), logtalk(Call, ExCtx))) ). '$lgt_metacall'(::Closure, ExtraArgs, ExCtx, Where) :- !, '$lgt_execution_context'(ExCtx, _, _, _, Self0, CallerExCtx, _), ( CallerExCtx == [] -> Self = Self0, SelfExCtx = ExCtx ; Where == (local) -> Self = Self0, SelfExCtx = ExCtx ; '$lgt_execution_context'(CallerExCtx, _, _, _, Self, _, _), SelfExCtx = CallerExCtx ), ( atom(Closure) -> Goal =.. [Closure| ExtraArgs], '$lgt_send_to_self_'(Self, Goal, SelfExCtx) ; compound(Closure) -> Closure =.. [Functor| Args], '$lgt_append'(Args, ExtraArgs, FullArgs), Goal =.. [Functor| FullArgs], '$lgt_send_to_self_'(Self, Goal, SelfExCtx) ; var(Closure) -> Call =.. [call, ::Closure| ExtraArgs], throw(error(instantiation_error, logtalk(Call, ExCtx))) ; Call =.. [call, ::Closure| ExtraArgs], throw(error(type_error(callable, ::Closure), logtalk(Call, ExCtx))) ). '$lgt_metacall'(^^Closure, ExtraArgs, ExCtx, Where) :- !, '$lgt_execution_context'(ExCtx, Entity0, _, _, _, CallerExCtx, _), ( CallerExCtx == [] -> Entity = Entity0, SuperExCtx = ExCtx ; Where == (local) -> Entity = Entity0, SuperExCtx = ExCtx ; '$lgt_execution_context'(CallerExCtx, Entity, _, _, _, _, _), SuperExCtx = CallerExCtx ), ( atom(Closure) -> Goal =.. [Closure| ExtraArgs] ; compound(Closure) -> Closure =.. [Functor| Args], '$lgt_append'(Args, ExtraArgs, FullArgs), Goal =.. [Functor| FullArgs] ; var(Closure) -> Call =.. [call, ^^Closure| ExtraArgs], throw(error(instantiation_error, logtalk(Call, ExCtx))) ; Call =.. [call, ^^Closure| ExtraArgs], throw(error(type_error(callable, Closure), logtalk(Call, ExCtx))) ), ( '$lgt_current_object_'(Entity, _, _, _, Super, _, _, _, _, _, _) -> '$lgt_obj_super_call_'(Super, Goal, SuperExCtx) ; '$lgt_current_category_'(Entity, _, _, _, _, _), '$lgt_ctg_super_call_'(Entity, Goal, SuperExCtx) ). '$lgt_metacall'(Obj::Closure, ExtraArgs, ExCtx, Where) :- !, '$lgt_execution_context'(ExCtx, _, Sender0, This, _, CallerExCtx0, _), ( CallerExCtx0 == [] -> CallerExCtx = ExCtx, Sender = This ; Where == (local) -> CallerExCtx = ExCtx, Sender = This ; CallerExCtx = CallerExCtx0, Sender = Sender0 ), ( callable(Obj), callable(Closure) -> Closure =.. [Functor| Args], '$lgt_append'(Args, ExtraArgs, FullArgs), Goal =.. [Functor| FullArgs], ( '$lgt_current_object_'(Sender, _, _, _, _, _, _, _, _, _, Flags), Flags /\ 16 =:= 16 -> '$lgt_send_to_obj_'(Obj, Goal, CallerExCtx) ; '$lgt_send_to_obj_ne_'(Obj, Goal, CallerExCtx) ) ; var(Obj) -> Call =.. [call, Obj::Closure| ExtraArgs], throw(error(instantiation_error, logtalk(Call, ExCtx))) ; var(Closure) -> Call =.. [call, Obj::Closure| ExtraArgs], throw(error(instantiation_error, logtalk(Call, ExCtx))) ; \+ callable(Closure) -> Call =.. [call, Obj::Closure| ExtraArgs], throw(error(type_error(callable, Closure), logtalk(Call, ExCtx))) ; Call =.. [call, Obj::Closure| ExtraArgs], throw(error(type_error(object_identifier, Obj), logtalk(Call, ExCtx))) ). '$lgt_metacall'([Obj::Closure], ExtraArgs, ExCtx, Where) :- !, '$lgt_execution_context'(ExCtx, _, Sender0, _, _, CallerExCtx0, _), ( CallerExCtx0 == [] -> CallerExCtx1 = ExCtx, Sender = Sender0 ; Where == (local) -> CallerExCtx1 = ExCtx, Sender = Sender0 ; '$lgt_execution_context'(CallerExCtx0, _, Sender, _, _, _, _), CallerExCtx1 = CallerExCtx0 ), ( callable(Obj), callable(Closure), Obj \= Sender -> Closure =.. [Functor| Args], '$lgt_append'(Args, ExtraArgs, FullArgs), Goal =.. [Functor| FullArgs], % prevent the original sender, which is preserved when delegating a message, to be reset to "this" '$lgt_execution_context'(CallerExCtx1, Entity, Sender, _, Self, MetaCallCtx, Stack), '$lgt_execution_context'(CallerExCtx, Entity, Sender, Sender, Self, MetaCallCtx, Stack), ( '$lgt_current_object_'(Sender, _, _, _, _, _, _, _, _, _, Flags), Flags /\ 16 =:= 16 -> '$lgt_send_to_obj_'(Obj, Goal, CallerExCtx) ; '$lgt_send_to_obj_ne_'(Obj, Goal, CallerExCtx) ) ; var(Obj) -> Call =.. [call, [Obj::Closure]| ExtraArgs], throw(error(instantiation_error, logtalk(Call, ExCtx))) ; var(Closure) -> Call =.. [call, [Obj::Closure]| ExtraArgs], throw(error(instantiation_error, logtalk(Call, ExCtx))) ; \+ callable(Closure) -> Call =.. [call, [Obj::Closure]| ExtraArgs], throw(error(type_error(callable, Closure), logtalk(Call, ExCtx))) ; \+ callable(Obj) -> Call =.. [call, [Obj::Closure]| ExtraArgs], throw(error(type_error(object_identifier, Obj), logtalk(Call, ExCtx))) ; % Obj = Sender -> Call =.. [call, [Obj::Closure]| ExtraArgs], throw(error(permission_error(access, object, Sender), logtalk(Call, ExCtx))) ). '$lgt_metacall'(Obj< Closure =.. [Functor| Args], '$lgt_append'(Args, ExtraArgs, FullArgs), Goal =.. [Functor| FullArgs], '$lgt_call_within_context_nv'(Obj, Goal, ExCtx) ; var(Obj) -> Call =.. [call, Obj< Call =.. [call, Obj< Call =.. [call, Obj< Closure =.. [Functor| Args], '$lgt_append'(Args, ExtraArgs, FullArgs), Goal =.. [Functor| FullArgs], ':'(Module, Goal) ; var(Module) -> Call =.. [call, ':'(Module, Closure)| ExtraArgs], throw(error(instantiation_error, logtalk(Call, ExCtx))) ; var(Closure) -> Call =.. [call, ':'(Module, Closure)| ExtraArgs], throw(error(instantiation_error, logtalk(Call, ExCtx))) ; \+ atom(Module) -> Call =.. [call, ':'(Module, Closure)| ExtraArgs], throw(error(type_error(module_identifier, Module), logtalk(Call, ExCtx))) ; Call =.. [call, ':'(Module, Closure)| ExtraArgs], throw(error(type_error(callable, Closure), logtalk(Call, ExCtx))) ). '$lgt_metacall'(Free/Lambda, ExtraArgs, ExCtx, Where) :- !, '$lgt_check'(curly_bracketed_term, Free, logtalk(Free/Lambda, ExCtx)), '$lgt_execution_context'(ExCtx, Entity, Sender, This, Self, MetaCallCtx, Stack), '$lgt_copy_term_without_constraints'(Free/Lambda+MetaCallCtx, Free/LambdaCopy+MetaCallCtxCopy), '$lgt_execution_context'(NewExCtx, Entity, Sender, This, Self, MetaCallCtxCopy, Stack), '$lgt_metacall'(LambdaCopy, ExtraArgs, NewExCtx, Where). '$lgt_metacall'(Free/Parameters>>Lambda, ExtraArgs, ExCtx, Where) :- !, '$lgt_check'(curly_bracketed_term, Free, logtalk(Free/Parameters>>Lambda, ExCtx)), '$lgt_execution_context'(ExCtx, Entity, Sender, This, Self, MetaCallCtx, Stack), '$lgt_copy_term_without_constraints'(Free/Parameters>>Lambda+MetaCallCtx, Free/ParametersCopy>>LambdaCopy+MetaCallCtxCopy), '$lgt_unify_lambda_parameters'(ParametersCopy, ExtraArgs, Rest, Free/Parameters>>Lambda, This), '$lgt_execution_context'(NewExCtx, Entity, Sender, This, Self, MetaCallCtxCopy, Stack), '$lgt_metacall'(LambdaCopy, Rest, NewExCtx, Where). '$lgt_metacall'(Parameters>>Lambda, ExtraArgs, ExCtx, Where) :- !, '$lgt_execution_context'(ExCtx, Entity, Sender, This, Self, MetaCallCtx, Stack), '$lgt_copy_term_without_constraints'(Parameters>>Lambda+MetaCallCtx, ParametersCopy>>LambdaCopy+MetaCallCtxCopy), '$lgt_unify_lambda_parameters'(ParametersCopy, ExtraArgs, Rest, Parameters>>Lambda, ExCtx), '$lgt_execution_context'(NewExCtx, Entity, Sender, This, Self, MetaCallCtxCopy, Stack), '$lgt_metacall'(LambdaCopy, Rest, NewExCtx, Where). '$lgt_metacall'(Closure, ExtraArgs, ExCtx, Where) :- ( atom(Closure) -> Goal =.. [Closure| ExtraArgs] ; compound(Closure) -> Closure =.. [Functor| Args], '$lgt_append'(Args, ExtraArgs, FullArgs), Goal =.. [Functor| FullArgs] ; Call =.. [call, Closure| ExtraArgs], throw(error(type_error(callable, Closure), logtalk(Call, ExCtx))) ), '$lgt_execution_context'(ExCtx, _, _, _, _, CallerExCtx, _), ( CallerExCtx == [] -> '$lgt_metacall_local'(Goal, ExCtx) ; Where == (local) -> '$lgt_metacall_local'(Goal, ExCtx) ; '$lgt_metacall_sender'(Goal, ExCtx, CallerExCtx, ExtraArgs) ). '$lgt_unify_lambda_parameters'((-), _, _, Lambda, ExCtx) :- % catch variables and lists with unbound tails ( Lambda = _/Parameters>>_ ; Lambda = Parameters>>_ ), throw(error(type_error(list, Parameters), logtalk(Lambda, ExCtx))). '$lgt_unify_lambda_parameters'([], ExtraArguments, ExtraArguments, _, _) :- !. '$lgt_unify_lambda_parameters'([Parameter| Parameters], [Argument| Arguments], ExtraArguments, Lambda, ExCtx) :- !, Parameter = Argument, '$lgt_unify_lambda_parameters'(Parameters, Arguments, ExtraArguments, Lambda, ExCtx). '$lgt_unify_lambda_parameters'(_, _, _, Lambda, ExCtx) :- throw(error(representation_error(lambda_parameters), logtalk(Lambda, ExCtx))). % '$lgt_metacall'(?term, +execution_context, +atom) % % performs a meta-call at runtime % % the last argument is either "local", in case of a local meta-call, % or "runtime", in case the decision between a local meta-call or a % meta-call in the sender is decided at runtime '$lgt_metacall'(Goal, ExCtx, _) :- var(Goal), throw(error(instantiation_error, logtalk(call(Goal), ExCtx))). '$lgt_metacall'('$lgt_local'(Goal), ExCtx, _) :- !, '$lgt_metacall'(Goal, ExCtx, local). '$lgt_metacall'({Goal}, ExCtx, _) :- % pre-compiled meta-calls or calls in "user" (compiler bypass) !, ( callable(Goal) -> call(Goal) ; var(Goal) -> throw(error(instantiation_error, logtalk({Goal}, ExCtx))) ; throw(error(type_error(callable, Goal), logtalk({Goal}, ExCtx))) ). '$lgt_metacall'(Goal, ExCtx, Where) :- '$lgt_execution_context'(ExCtx, _, _, _, _, CallerExCtx, _), ( CallerExCtx == [] -> '$lgt_metacall_local'(Goal, ExCtx) ; Where == (local) -> '$lgt_metacall_local'(Goal, ExCtx) ; '$lgt_metacall_sender'(Goal, ExCtx, CallerExCtx, []) ). % '$lgt_quantified_metacall'(?term, +execution_context, +atom) % % performs a possibly qualified meta-call at runtime for goals within bagof/3 and setof/3 calls % % the first argument is the original goal in the bagof/3 or setof/3 call and it's used to check % in which context the meta-call should take place % % the second argument is the original goal without existential variables that will be meta-called '$lgt_quantified_metacall'(Goal, ExCtx, _) :- var(Goal), throw(error(instantiation_error, logtalk(call(Goal), ExCtx))). '$lgt_quantified_metacall'('$lgt_local'(Goal), ExCtx, _) :- !, '$lgt_quantified_metacall'(Goal, ExCtx, local). '$lgt_quantified_metacall'({Goal}, ExCtx, _) :- % pre-compiled meta-calls or calls in "user" (compiler bypass) !, ( callable(Goal) -> call(Goal) ; var(Goal) -> throw(error(instantiation_error, logtalk({Goal}, ExCtx))) ; throw(error(type_error(callable, Goal), logtalk({Goal}, ExCtx))) ). '$lgt_quantified_metacall'(Goal, ExCtx, Where) :- '$lgt_execution_context'(ExCtx, _, _, _, _, CallerExCtx, _), ( CallerExCtx == [] -> '$lgt_metacall_local'(Goal, ExCtx) ; Where == (local) -> '$lgt_metacall_local'(Goal, ExCtx) ; '$lgt_metacall_sender'(Goal, ExCtx, CallerExCtx, []) ). % '$lgt_metacall_local'(+callable, +execution_context) % % performs a local meta-call at runtime '$lgt_metacall_local'(Pred, ExCtx) :- '$lgt_execution_context'(ExCtx, Entity, Sender, This, Self, _, Stack), ( '$lgt_current_object_'(Entity, Prefix, _, Def, _, _, _, _, DDef, _, Flags) -> ( % in the most common case we're meta-calling a user defined static predicate call(Def, Pred, ExCtx, TPred) -> call(TPred) ; % or a user defined dynamic predicate call(DDef, Pred, ExCtx, TPred) -> call(TPred) ; % in the worst case we need to compile the meta-call '$lgt_comp_ctx'(Ctx, _, ExCtx, Entity, Sender, This, Self, Prefix, [], _, ExCtx, runtime, Stack, _, _), catch('$lgt_compile_body'(Pred, _, TPred, DPred, Ctx), Error, throw(error(Error, logtalk(call(Pred), ExCtx)))), ( Flags /\ 512 =:= 512 -> % object compiled in debug mode catch(DPred, error(Error,_), throw(error(Error, logtalk(call(Pred), ExCtx)))) ; catch(TPred, error(Error,_), throw(error(Error, logtalk(call(Pred), ExCtx)))) ) ) ; '$lgt_current_category_'(Entity, Prefix, _, Def, _, Flags), ( % in the most common case we're meta-calling a user defined predicate call(Def, Pred, ExCtx, TPred) -> call(TPred) ; % in the worst case we need to compile the meta-call '$lgt_comp_ctx'(Ctx, _, ExCtx, Entity, Sender, This, Self, Prefix, [], _, ExCtx, runtime, [], _, _), catch('$lgt_compile_body'(Pred, _, TPred, DPred, Ctx), Error, throw(error(Error, logtalk(call(Pred), ExCtx)))), ( Flags /\ 512 =:= 512 -> % category compiled in debug mode catch(DPred, error(Error,_), throw(error(Error, logtalk(call(Pred), ExCtx)))) ; catch(TPred, error(Error,_), throw(error(Error, logtalk(call(Pred), ExCtx)))) ) ) ). % '$lgt_metacall_sender'(+callable, +execution_context, +execution_context, +list) % % performs a meta-call in "sender" at runtime % % we must pass any extra arguments (a non-empty list when processing closures) % as compilation context meta-variables to properly compile calls to control % constructs (e.g., conjunctions) where those extra arguments must be called in % the correct context '$lgt_metacall_sender'(Pred, ExCtx, CallerExCtx, ExtraArgs) :- '$lgt_execution_context'(CallerExCtx, CallerEntity, Sender, This, Self, _, Stack), ( CallerEntity == user -> catch(Pred, error(Error,_), throw(error(Error, logtalk(call(Pred), CallerExCtx)))) ; '$lgt_current_object_'(CallerEntity, CallerPrefix, _, Def, _, _, _, _, DDef, _, Flags) -> ( % in the most common case we're meta-calling a user defined static predicate call(Def, Pred, CallerExCtx, TPred) -> call(TPred) ; % or a user defined dynamic predicate call(DDef, Pred, CallerExCtx, TPred) -> call(TPred) ; % in the worst case we have a control construct or a built-in predicate ( ExtraArgs == [] -> MetaCallCtx = [] ; MetaCallCtx = ExCtx ), '$lgt_execution_context'(NewCallerExCtx, CallerEntity, Sender, This, Self, MetaCallCtx, Stack), '$lgt_comp_ctx'(Ctx, _, NewCallerExCtx, CallerEntity, Sender, This, Self, CallerPrefix, ExtraArgs, MetaCallCtx, NewCallerExCtx, runtime, Stack, _, _), catch('$lgt_compile_body'(Pred, _, TPred, DPred, Ctx), Error, throw(error(Error, logtalk(call(Pred), CallerExCtx)))), ( Flags /\ 512 =:= 512 -> % object compiled in debug mode catch(DPred, error(Error,_), throw(error(Error, logtalk(call(Pred), CallerExCtx)))) ; catch(TPred, error(Error,_), throw(error(Error, logtalk(call(Pred), CallerExCtx)))) ) ) ; '$lgt_current_category_'(CallerEntity, CallerPrefix, _, Def, _, Flags), ( % in the most common case we're meta-calling a user defined static predicate call(Def, Pred, CallerExCtx, TPred) -> call(TPred) ; % in the worst case we have a control construct or a built-in predicate ( ExtraArgs == [] -> MetaCallCtx = [] ; MetaCallCtx = ExCtx ), '$lgt_execution_context'(NewCallerExCtx, CallerEntity, Sender, This, Self, MetaCallCtx, Stack), '$lgt_comp_ctx'(Ctx, _, NewCallerExCtx, CallerEntity, Sender, This, Self, CallerPrefix, ExtraArgs, MetaCallCtx, NewCallerExCtx, runtime, Stack, _, _), catch('$lgt_compile_body'(Pred, _, TPred, DPred, Ctx), Error, throw(error(Error, logtalk(call(Pred), CallerExCtx)))), ( Flags /\ 512 =:= 512 -> % object compiled in debug mode catch(DPred, error(Error,_), throw(error(Error, logtalk(call(Pred), CallerExCtx)))) ; catch(TPred, error(Error,_), throw(error(Error, logtalk(call(Pred), CallerExCtx)))) ) ) ). % '$lgt_call_within_context'(?term, ?term, +object_identifier) % % calls a goal within the context of the specified object when the object and/or the % goal are only known at runtime % % used mostly for debugging and for writing unit tests, the permission to perform a % context-switching call can be disabled in a per-object basis by using the compiler % flag "context_switching_calls" '$lgt_call_within_context'(Obj, Goal, ExCtx) :- '$lgt_check'(object_identifier, Obj, logtalk(Obj< catch(Goal, Error, '$lgt_runtime_error_handler'(error(Error, logtalk(user< ( Flags /\ 256 =:= 256 -> % object compiled with context-switching calls allowed '$lgt_execution_context'(ObjExCtx, Obj, Obj, Obj, Obj, [], []), ( % in the most common case we're calling a user defined static predicate call(Def, Goal, ObjExCtx, TGoal) -> catch(TGoal, Error, '$lgt_runtime_error_handler'(error(Error, logtalk(Obj< catch(TGoal, Error, '$lgt_runtime_error_handler'(error(Error, logtalk(Obj< % object compiled in debug mode catch(DGoal, Error, '$lgt_runtime_error_handler'(error(Error, logtalk(Obj< call(TPred) ; % or the clauses for the predicate may be defined only at runtime call(DDef, Pred, ExCtx, TPred) -> call(TPred) ; % no definition found; fail as per closed-world assumption fail ). % '$lgt_call_in_this'(+callable, +execution_context) % % calls a dynamic predicate in "this" from within a category at runtime; % also used to call overridden predicate definitions from complementing categories '$lgt_call_in_this'(Pred, ExCtx) :- '$lgt_execution_context_this_entity'(ExCtx, This, _), '$lgt_current_object_'(This, _, Dcl, Def, _, _, _, _, DDef, _, _), ( \+ call(Dcl, Pred, _, _, _, _, _) -> % unknown predicate functor(Pred, Functor, Arity), throw(error(existence_error(predicate_declaration, Functor/Arity), logtalk(Pred, ExCtx))) ; % the object definition may include some initial clauses for the predicate call(Def, Pred, ExCtx, TPred) -> call(TPred) ; % or the clauses for the predicate may be defined only at runtime call(DDef, Pred, ExCtx, TPred) -> call(TPred) ; % no definition found; fail as per closed-world assumption fail ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % support for categories that complement objects (hot patching) % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % lookup predicate declarations in any category that complements the given object '$lgt_complemented_object'(This, ThisDcl, Alias, Scope, Meta, Flags, SCtn, TCtn) :- '$lgt_complemented_object_'(This, _, Dcl, _, Rnm), ( call(Dcl, Alias, Scope, Meta, Flags, TCtn), SCtn = This ; % categories can define aliases for complemented object predicates call(Rnm, This, Pred, Alias), Pred \= Alias, call(ThisDcl, Pred, Scope, Meta, Flags, SCtn, TCtn) ). % lookup predicate definitions in any category that complements the given object '$lgt_complemented_object'(This, ThisDef, Alias, OExCtx, Call, Ctn) :- '$lgt_complemented_object_'(This, Ctg, _, Def, Rnm), '$lgt_execution_context_update_this_entity'(OExCtx, This, This, CExCtx, This, Ctg), ( call(Def, Alias, CExCtx, Call, Ctn) ; % categories may also define aliases for complemented object predicates call(Rnm, This, Pred, Alias), Pred \= Alias, call(ThisDef, Pred, OExCtx, Call, _, Ctn) ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % debugging base support % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % '$lgt_debug'(+compound, @execution_context) % % calls all defined trace event handlers and either use a loaded debug % handler provider for the debug event or simply call the debugging goals % to prevent execution of code compiled in debug mode to simply fail % % we can have multiple trace event handlers but only one debug handler % (the compiler prints a warning when attempting to load a second handler) '$lgt_debug'(Event, ExCtx) :- '$logtalk#0.trace_event#2'(Event, ExCtx, _), fail. '$lgt_debug'(Event, ExCtx) :- '$logtalk#0.active_debug_handler_#1'(Provider, _), !, '$logtalk#0.debug_handler#3'(Provider, Event, ExCtx, _). % top_goal(Goal, TGoal) '$lgt_debug'(top_goal(_, TGoal), _) :- call(TGoal). % goal(Goal, TGoal) '$lgt_debug'(goal(_, TGoal), _) :- call(TGoal). % fact(Entity, Fact, ClauseNumber, File, BeginLine) '$lgt_debug'(fact(_, _, _, _, _), _). % rule(Entity, Head, ClauseNumber, File, BeginLine) '$lgt_debug'(rule(_, _, _, _, _), _). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % message printing support % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % '$lgt_print_message'(+atom_or_compound, +atom, +nonvar) % % internal predicate used by the compiler and runtime to print a message; % we fake the execution context argument to call the corresponding method % in the "logtalk" built-in object '$lgt_print_message'(Kind, Message) :- ( '$lgt_built_in_entities_loaded_' -> % "logtalk" built-in object loaded '$lgt_execution_context'(ExCtx, logtalk, logtalk, logtalk, logtalk, [], []), '$logtalk#0.print_message#3'(Kind, core, Message, ExCtx) ; % still compiling the default built-in entities '$lgt_compiler_flag'(report, off) -> % no message printing required true ; % bare-bones message printing write('core '), write(Kind), write(': '), writeq(Message), nl ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % compiler % % compiles Logtalk source files into intermediate Prolog source files % and calls the backend Prolog compiler on the generated files % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % '$lgt_load_files'(@source_file_name, @list(compiler_flag)) % '$lgt_load_files'(@list(source_file_name), @list(compiler_flag)) % % compiles to disk and then loads to memory a source file or a list of source files % % a call to this predicate can trigger other calls to it, therefore we *must* clean % the compilation auxiliary predicates *before* compiling a file '$lgt_load_files'([], _) :- !. '$lgt_load_files'([File| Files], Flags) :- !, '$lgt_clean_pp_file_clauses', '$lgt_set_compiler_flags'(Flags), '$lgt_load_file'(File, Flags), '$lgt_load_files'(Files, Flags). '$lgt_load_files'(File, Flags) :- '$lgt_load_files'([File], Flags). % '$lgt_load_file'(@source_file_name, @list) % % compiles to disk and then loads to memory a source file '$lgt_load_file'(File, [RelativeTo| Flags]) :- ( '$lgt_source_file_name'(File, [RelativeTo| Flags], Directory, Name, Extension, SourceFile), \+ '$lgt_file_loading_stack_'(SourceFile, Directory), atom_concat(Name, Extension, Basename), ( '$lgt_loaded_file_'(Basename, Directory, _, _, _, _, _) % file already loaded; possibly an embedded application in which case we % don't want to throw a file existence error as the original source file % may not exist, or no longer exist, on the system where we are running ; '$lgt_file_exists'(SourceFile) ) -> true ; '$lgt_source_file_name'(File, [RelativeTo| Flags], Directory, Name, Extension, SourceFile), '$lgt_file_loading_stack_'(SourceFile, Directory) -> % file trying to recursively load itself throw(error(permission_error(load, file, File), _)) ; throw(error(existence_error(file, File), _)) ), ( '$lgt_loaded_file_'(Basename, Directory, PreviousMode, PreviousFlags, _, _, LoadingTimeStamp), \+ '$lgt_failed_file_'(SourceFile) -> % we're attempting to reload a file ( '$lgt_member'(reload(Reload), PreviousFlags) -> true ; '$lgt_compiler_flag'(reload, Reload) ), ( Reload == skip -> % skip reloading already loaded files '$lgt_print_message'(comment(loading), skipping_reloading_file(SourceFile, Flags)), % but save the file loading dependency on a parent file if it exists '$lgt_save_file_loading_dependency'(SourceFile) ; Reload == changed, PreviousFlags == Flags, \+ '$lgt_changed_compilation_mode'(PreviousMode, PreviousFlags), '$lgt_file_modification_time'(SourceFile, CurrentTimeStamp), CurrentTimeStamp @=< LoadingTimeStamp -> % file was not modified since loaded and same explicit flags and compilation mode as before '$lgt_print_message'(comment(loading), skipping_reloading_file(SourceFile, Flags)), % but save the file loading dependency on a parent file if it exists '$lgt_save_file_loading_dependency'(SourceFile) ; % we're reloading a source file '$lgt_print_message'(silent(loading), reloading_file(SourceFile, Flags)), '$lgt_compile_and_load_file'(Directory, Name, Extension, Basename, SourceFile, Flags, reloading), '$lgt_print_message'(comment(loading), reloaded_file(SourceFile, Flags)) ) ; % first time loading this source file or previous attempt failed due to compilation error '$lgt_print_message'(silent(loading), loading_file(SourceFile, Flags)), '$lgt_compile_and_load_file'(Directory, Name, Extension, Basename, SourceFile, Flags, loading), '$lgt_print_message'(comment(loading), loaded_file(SourceFile, Flags)) ). '$lgt_compile_and_load_file'(Directory, Name, Extension, Basename, SourceFile, Flags, Action) :- '$lgt_object_file_names'(Directory, Name, Extension, ObjectFilePid, ObjectFileDialect), retractall('$lgt_pp_file_paths_flags_'(_, _, _, _, _)), ( '$lgt_compiler_flag'(clean, on) -> ObjectFile = ObjectFilePid ; ObjectFile = ObjectFileDialect ), assertz('$lgt_pp_file_paths_flags_'(Basename, Directory, SourceFile, ObjectFile, Flags)), retractall('$lgt_failed_file_'(SourceFile)), % save the file loading dependency on a parent file if it exists '$lgt_save_file_loading_dependency'(SourceFile), retractall('$lgt_file_loading_stack_'(SourceFile, Directory)), asserta('$lgt_file_loading_stack_'(SourceFile, Directory)), % compile the source file to an intermediate Prolog file on disk; % a syntax error while reading the terms in a source file results % in a printed message and failure instead of an exception but we % need to pass the failure up to the caller ( '$lgt_compile_file'(SourceFile, Flags, ObjectFile, Action) -> true ; retractall('$lgt_file_loading_stack_'(SourceFile, Directory)), '$lgt_propagate_failure_to_parent_files'(SourceFile), fail ), % compile and load the intermediate Prolog file '$lgt_load_compiled_file'(SourceFile, ObjectFile), retractall('$lgt_file_loading_stack_'(SourceFile, _)), retractall('$lgt_pp_file_paths_flags_'(_, _, _, _, _)), % cleanup intermediate files if necessary ( '$lgt_compiler_flag'(clean, on) -> '$lgt_delete_intermediate_files'(ObjectFilePid), '$lgt_delete_intermediate_files'(ObjectFileDialect) ; true ). '$lgt_save_file_loading_dependency'(SourceFile) :- ( '$lgt_file_loading_stack_'(ParentSourceFile, _), SourceFile \== ParentSourceFile -> % as a file can have multiple parents, we only % ensure that there aren't duplicated entries retractall('$lgt_parent_file_'(SourceFile, ParentSourceFile)), asserta('$lgt_parent_file_'(SourceFile, ParentSourceFile)) ; % no parent file true ). '$lgt_load_compiled_file'(SourceFile, ObjectFile) :- % retrieve the backend Prolog specific file loading options '$lgt_compiler_flag'(prolog_loader, DefaultOptions), % loading a file can result in the redefinition of existing % entities thus potentially invalidating cache entries '$lgt_clean_lookup_caches', '$lgt_report_redefined_entities', ( '$lgt_pp_file_encoding_'(SourceFile, _, Encoding, _) -> % use the same encoding as the original source file but do not use the inferred % bom/1 option as it would only work with some backend Prolog compilers Options = [encoding(Encoding)| DefaultOptions] ; Options = DefaultOptions ), % clean all runtime clauses as an initialization goal in the intermediate Prolog file % that is loaded next may create dynamic entities '$lgt_clean_pp_runtime_clauses', % load the generated intermediate Prolog file but cope with unexpected error or failure ( ( catch('$lgt_load_prolog_code'(ObjectFile, SourceFile, Options), Error, true) -> ( var(Error) -> true ; % an error while loading the generated intermediate Prolog files is usually % caused by backend write_canonical/2 and/or read_term/3 predicate bugs '$lgt_print_message'(error, loading_error(SourceFile, Error)), fail ) ; '$lgt_print_message'(error, loading_failure(SourceFile)), fail ) -> true ; % loading of the intermediate Prolog file failed retractall('$lgt_file_loading_stack_'(SourceFile, _)), retractall('$lgt_pp_file_paths_flags_'(_, _, _, _, _)), '$lgt_propagate_failure_to_parent_files'(SourceFile), '$lgt_delete_intermediate_files'(ObjectFile), fail ). '$lgt_delete_intermediate_files'(ObjectFile) :- % try to delete the intermediate Prolog file (ignore failure or error) '$lgt_file_exists'(ObjectFile), catch('$lgt_delete_file'(ObjectFile), _, true), fail. '$lgt_delete_intermediate_files'(ObjectFile) :- % try to delete any Prolog dialect specific auxiliary files (ignore failure or error) '$lgt_file_extension'(object, ObjectExtension), atom_concat(Name, ObjectExtension, ObjectFile), '$lgt_file_extension'(tmp, TmpExtension), atom_concat(Name, TmpExtension, TmpFile), '$lgt_file_exists'(TmpFile), catch('$lgt_delete_file'(TmpFile), _, true), fail. '$lgt_delete_intermediate_files'(_). % '$lgt_report_redefined_entities' % % prints a warning for all entities that are about to be redefined % % also retracts old runtime clauses for the entity being redefined for safety '$lgt_report_redefined_entities' :- ( '$lgt_pp_runtime_clause_'('$lgt_current_protocol_'(Entity, _, _, _, _)) ; '$lgt_pp_runtime_clause_'('$lgt_current_category_'(Entity, _, _, _, _, _)) ; '$lgt_pp_runtime_clause_'('$lgt_current_object_'(Entity, _, _, _, _, _, _, _, _, _, _)) ), '$lgt_redefined_entity'(Entity, Type, OldFile, NewFile, Lines), '$lgt_report_redefined_entity'(Type, Entity, OldFile, NewFile, Lines), '$lgt_retract_old_runtime_clauses'(Type, Entity), fail. '$lgt_report_redefined_entities'. % '$lgt_redefined_entity'(@entity_identifier, -atom, -atom, -atom, -pair(integer)) % % true if an entity of the same name is already loaded; returns entity type '$lgt_redefined_entity'(Entity, Type, OldFile, NewFile, Lines) :- % check that an entity with the same identifier is already loaded ( '$lgt_current_object_'(Entity, _, _, _, _, _, _, _, _, _, Flags) -> Type = object ; '$lgt_current_protocol_'(Entity, _, _, _, Flags) -> Type = protocol ; '$lgt_current_category_'(Entity, _, _, _, _, Flags), Type = category ), ( Flags /\ 1 =:= 1 -> % built-in entity; no redefinition allowed throw(permission_error(modify, Type, Entity)) ; % redefinable entity but, in the presence of entity dynamic predicates, when % using some backend Prolog compilers, some old dynamic clauses may persist true ), ( % check file information using the file_lines/4 entity property, if available '$lgt_entity_property_'(Entity, file_lines(OldBasename, OldDirectory, _, _)), '$lgt_pp_runtime_clause_'('$lgt_entity_property_'(Entity, file_lines(NewBasename, NewDirectory, Start, End))) -> atom_concat(OldDirectory, OldBasename, OldFile), atom_concat(NewDirectory, NewBasename, NewFile), Lines = Start-End ; % no file_lines/4 entity property (due to compilation with the source_data flag turned off) OldFile = nil, NewFile = nil, Lines = '-'(-1, -1) ). % '$lgt_report_redefined_entity'(+atom, @entity_identifier, +atom, +atom, +pair(integer)) % % prints an informative message or a warning for a redefined entity '$lgt_report_redefined_entity'(Type, Entity, OldFile, NewFile, Lines) :- ( OldFile == NewFile -> % either reloading the same source file or no source file data is available; assume entity redefinition normal '$lgt_print_message'(comment(loading), redefining_entity(Type, Entity)) ; % we've conflicting entity definitions coming from different source files '$lgt_increment_loading_warnings_counter', '$lgt_print_message'(warning(loading), redefining_entity_from_file(NewFile, Lines, Type, Entity, OldFile)) ). % '$lgt_retract_old_runtime_clauses'(+atom, @entity_identifier) % % cleans all references to an entity that is about to be redefined % from the runtime tables '$lgt_retract_old_runtime_clauses'(object, Entity) :- retractall('$lgt_before_event_'(_, _, _, Entity, _)), retractall('$lgt_after_event_'(_, _, _, Entity, _)), retractall('$lgt_current_object_'(Entity, _, _, _, _, _, _, _, _, _, _)), retractall('$lgt_entity_property_'(Entity, _)), retractall('$lgt_predicate_property_'(Entity, _, _)), retractall('$lgt_implements_protocol_'(Entity, _, _)), retractall('$lgt_imports_category_'(Entity, _, _)), retractall('$lgt_instantiates_class_'(Entity, _, _)), retractall('$lgt_specializes_class_'(Entity, _, _)), retractall('$lgt_extends_object_'(Entity, _, _)), retractall('$lgt_current_engine_'(Entity, _, _, _)). '$lgt_retract_old_runtime_clauses'(protocol, Entity) :- retractall('$lgt_current_protocol_'(Entity, _, _, _, _)), retractall('$lgt_entity_property_'(Entity, _)), retractall('$lgt_predicate_property_'(Entity, _, _)), retractall('$lgt_extends_protocol_'(Entity, _, _)). '$lgt_retract_old_runtime_clauses'(category, Entity) :- retractall('$lgt_current_category_'(Entity, _, _, _, _, _)), retractall('$lgt_entity_property_'(Entity, _)), retractall('$lgt_predicate_property_'(Entity, _, _)), retractall('$lgt_implements_protocol_'(Entity, _, _)), retractall('$lgt_extends_category_'(Entity, _, _)), retractall('$lgt_complemented_object_'(_, Entity, _, _, _)). % '$lgt_compile_files'(@source_file_name, @list(compiler_flag)) % '$lgt_compile_files'(@list(source_file_name), @list(compiler_flag)) % % compiles to disk a source file or a list of source files % % a call to this predicate can trigger other calls to it, therefore we *must* % clean the compilation auxiliary predicates *before* compiling a file '$lgt_compile_files'([], _) :- !, retractall('$lgt_pp_file_paths_flags_'(_, _, _, _, _)). '$lgt_compile_files'([File| Files], [RelativeTo| Flags]) :- !, '$lgt_clean_pp_file_clauses', '$lgt_set_compiler_flags'(Flags), ( '$lgt_source_file_name'(File, [RelativeTo| Flags], Directory, Name, Extension, SourceFile), '$lgt_file_exists'(SourceFile) -> true ; throw(error(existence_error(file, File), _)) ), '$lgt_object_file_names'(Directory, Name, Extension, ObjectFilePid, ObjectFileDialect), atom_concat(Name, Extension, Basename), retractall('$lgt_pp_file_paths_flags_'(_, _, _, _, _)), ( '$lgt_compiler_flag'(clean, on) -> ObjectFile = ObjectFilePid ; ObjectFile = ObjectFileDialect ), assertz('$lgt_pp_file_paths_flags_'(Basename, Directory, SourceFile, ObjectFile, Flags)), '$lgt_compile_file'(SourceFile, Flags, ObjectFile, compiling), '$lgt_compile_files'(Files, [RelativeTo| Flags]). '$lgt_compile_files'(File, Flags) :- '$lgt_compile_files'([File], Flags). % '$lgt_compile_file'(@source_file_name, @list, @source_file_name, +atom) % % compiles to disk a source file '$lgt_compile_file'(SourceFile, Flags, ObjectFile, Action) :- ( % ensure that we disregard any existing the intermediate Prolog file % if we're reloading as that may be required due to different flags Action \== reloading, % interpret a clean(on) setting as (also) meaning that any % existing intermediate Prolog files should be disregarded '$lgt_compiler_flag'(clean, off), '$lgt_file_exists'(ObjectFile), '$lgt_up_to_date_object_file'(SourceFile, ObjectFile) -> '$lgt_print_message'(silent(compiling), up_to_date_file(SourceFile, Flags)) ; % the intermediate Prolog file doesn't exist or it's outdated '$lgt_print_message'(silent(compiling), compiling_file(SourceFile, Flags)), '$lgt_compile_file'(SourceFile, ObjectFile), '$lgt_compiler_flag'(prolog_compiler, Options), '$lgt_compile_prolog_code'(ObjectFile, SourceFile, Options), ( Action == loading -> '$lgt_print_message'(silent(compiling), compiled_file(SourceFile, Flags)) ; % Action == compiling, '$lgt_print_message'(comment(compiling), compiled_file(SourceFile, Flags)) ) ). % a file can be loaded by a loader file that, in turn, may also be loaded by % another loader file; propagating a file loading failure to its parent files % provides better top-level usability allowing reloading of fixed files by % simply reloading the loader files, which also ensures loading of any files % to be loaded after the broken file that were not loaded in the previous % attempt '$lgt_propagate_failure_to_parent_files'(File) :- ( '$lgt_parent_file_'(File, Parent) -> '$lgt_propagate_failure_to_parent_files'(Parent) ; assertz('$lgt_failed_file_'(File)) ). % '$lgt_up_to_date_object_file'(+atom, +atom) % % Check that the object file is up-to-date '$lgt_up_to_date_object_file'(SourceFile, ObjectFile) :- '$lgt_file_modification_time'(SourceFile, SourceFileTime), '$lgt_file_modification_time'(ObjectFile, ObjectFileTime), SourceFileTime @=< ObjectFileTime. % '$lgt_write_entity_code'(+atom, @entity_identifier) % % writes to disk the entity compiled code '$lgt_write_entity_code'(object, Obj) :- '$lgt_pp_object_'(Obj, _, _, _, _, _, _, _, _, Rnm, _), '$lgt_write_entity_code'(Rnm). '$lgt_write_entity_code'(protocol, Ptc) :- '$lgt_pp_protocol_'(Ptc, _, _, Rnm, _), '$lgt_write_entity_code'(Rnm). '$lgt_write_entity_code'(category, Ctg) :- '$lgt_pp_category_'(Ctg, _, _, _, Rnm, _), '$lgt_write_entity_code'(Rnm). '$lgt_write_entity_code'(Rnm) :- '$lgt_pp_file_paths_flags_'(_, _, Path, _, _), % avoid a spurious choice-point with some backend Prolog compilers stream_property(Output, alias(logtalk_compiler_output)), !, catch( '$lgt_write_entity_code'(Output, Path, Rnm), Error, '$lgt_compiler_output_stream_error_handler'(Output, Error) ). '$lgt_write_entity_code'(Output, Path, Rnm) :- % write any plain Prolog terms that may precede the entity definition '$lgt_write_prolog_terms'(Output, Path), '$lgt_write_entity_directives'(Output, Path), '$lgt_write_entity_clauses'(Output, Path, Rnm). % '$lgt_source_file_name'(+atom, +list(callable), -atom, -atom, -atom, -atom) % % converts a source file specification into a source file directory, basename, % and full path % % the source file specification can be either absolute or relative and may or % may not include a file name extension % % when the source file specification doesn't include a file extension, this % predicate provides a solution for each defined Logtalk and Prolog source % file extension; callers should test if the returned full path exists and % commit to that solution when not simply generating all possible solutions '$lgt_source_file_name'(FilePath, Flags, Directory, Name, Extension, SourceFile) :- ( ( sub_atom(FilePath, 0, 1, _, '/') % this covers the case of embedded applications created in a POSIX system % and being run on a Windows system where a path starting with a slash % would not be recognized as an absolute path by '$lgt_expand_path'/2 ; '$lgt_expand_path'(FilePath, FilePath) ) -> % assume full path SourceFile0 = FilePath ; % assume relative path and try possible alternatives ( once('$lgt_file_loading_stack_'(_, ParentDirectory)), % parent file exists; try first a path relative to its directory atom_concat(ParentDirectory, FilePath, SourceFile0) ; ( '$lgt_member'(relative_to(BasePath), Flags) ; '$lgt_member'('$relative_to'(BasePath), Flags) ), ( sub_atom(BasePath, _, 1, 0, '/') -> atom_concat(BasePath, FilePath, SourceFile0) ; atom_concat(BasePath, '/', BasePathSlash), atom_concat(BasePathSlash, FilePath, SourceFile0) ) ; % we may have a relative file path without any parent file % (e.g., when the user changes the working directory to the % directory containing the file to be loaded) '$lgt_expand_path'(FilePath, SourceFile0) ) ), '$lgt_decompose_file_name'(SourceFile0, Directory, Name0, Extension0), ( % file extensions are defined in the Prolog adapter files (there % might be multiple extensions defined for the same type of file) '$lgt_file_extension'(logtalk, Extension0) -> % declared extension for this type of file is present SourceFile = SourceFile0, Name = Name0, Extension = Extension0 ; '$lgt_file_extension'(prolog, Extension0) -> % assume Prolog file being compiled as a Logtalk file SourceFile = SourceFile0, Name = Name0, Extension = Extension0 ; % no Logtalk or Prolog extension for this type of file; generate possible % basenames starting with Logtalk extensions followed by Prolog extensions ( '$lgt_file_extension'(logtalk, Extension) ; '$lgt_file_extension'(prolog, Extension) ), atom_concat(SourceFile0, Extension, SourceFile), atom_concat(Name0, Extension0, Name) ; % use basename as-is SourceFile = SourceFile0, atom_concat(Name0, Extension0, Name), Extension = '' ). % '$lgt_object_file_names'(+atom, +atom, +atom, -atom) % % converts a source file full path into two object file full paths: one that % includes the process identifier for use when the clean flag is turned on % (to allow parallel Logtalk processes) and one that includes the backend % identifier for use when the clean flag is turned off (to avoid file name % conflicts when running with backends generate the same directory hashes) '$lgt_object_file_names'(SourceDirectory, SourceName, SourceExtension, ObjectFilePid, ObjectFileDialect) :- % temporary files are stored in the defined scratch directory '$lgt_compiler_flag'(scratch_directory, ScratchDirectory0), % allow using library notation to specify the scratch directory '$lgt_check_and_expand_source_file'(ScratchDirectory0, ScratchDirectory1), % make sure that the scratch directory path ends with a slash ( sub_atom(ScratchDirectory1, _, _, 0, '/') -> ScratchDirectory = ScratchDirectory1 ; atom_concat(ScratchDirectory1, '/', ScratchDirectory) ), ( sub_atom(ScratchDirectory, 0, 2, _, './') -> % relative directory path sub_atom(ScratchDirectory, 2, _, 0, ScratchDirectorySuffix), atom_concat(SourceDirectory, ScratchDirectorySuffix, ObjectDirectory) ; % assume absolute directory path ObjectDirectory = ScratchDirectory ), % add a suffix based on the original extension to the file name to avoid % intermediate and temporary file name conflicts when compiling two or % more source files that share the same name but use different extensions ( '$lgt_source_extension_suffix'(SourceExtension, Suffix) -> true ; sub_atom(SourceExtension, 1, _, 0, Suffix0) -> atom_concat('_', Suffix0, Suffix) ), % append (if supported by the backend compiler) a directory hash value to the % intermediate Prolog file name to try to avoid file name collisions when % collecting all the intermediate files in the same directory (possibly for % embedding); when compiling with the "clean" flag turned on (its default % value), also include in the file name the process identifier to avoid file % name clashes when running parallel Logtalk processes '$lgt_directory_hashes'(SourceDirectory, HashDialect, HashPid), '$lgt_object_file_name'(ObjectDirectory, SourceName, HashDialect, Suffix, ObjectFileDialect), '$lgt_object_file_name'(ObjectDirectory, SourceName, HashPid, Suffix, ObjectFilePid). '$lgt_object_file_name'(ObjectDirectory, SourceName, Hash, Suffix, ObjectFile) :- atom_concat(SourceName, Hash, ObjectName0), atom_concat(ObjectName0, Suffix, ObjectName), % there must be a single object file extension defined in the Prolog adapter files '$lgt_file_extension'(object, ObjectExtension), atom_concat(ObjectName, ObjectExtension, ObjectBasename), atom_concat(ObjectDirectory, ObjectBasename, ObjectFile), % make sure the scratch directory exists '$lgt_make_directory'(ObjectDirectory). % common source extensions and corresponding precomputed suffixes '$lgt_source_extension_suffix'('.lgt', '_lgt'). '$lgt_source_extension_suffix'('.logtalk', '_logtalk'). '$lgt_source_extension_suffix'('.pl', '_pl'). '$lgt_source_extension_suffix'('.pro', '_pro'). '$lgt_source_extension_suffix'('.prolog', '_prolog'). '$lgt_source_extension_suffix'('', ''). % '$lgt_compile_file'(+atom, +atom) % % compiles a source file storing the resulting code in memory '$lgt_compile_file'(SourceFile, ObjectFile) :- % open the Logtalk source code file for reading catch( '$lgt_open'(SourceFile, read, Input, [alias(logtalk_compiler_input)]), OpenError, '$lgt_compiler_stream_error_handler'(OpenError) ), % look for an encoding/1 directive that, when present, must be the first term on a source file catch( '$lgt_read_file_term'(SourceFile, Input, Term, Singletons, Lines), InputError, '$lgt_compiler_first_term_error_handler'(SourceFile, Lines, InputError) ), catch( '$lgt_check_for_encoding_directive'(Term, SourceFile, Lines, Input, NewInput, [alias(logtalk_compiler_input)], OutputOptions), FirstTermError, '$lgt_compiler_first_term_error_handler'(SourceFile, Lines, FirstTermError) ), % open a Prolog file for writing the generated code using any found encoding/1 directive catch( '$lgt_open'(ObjectFile, write, Output, [alias(logtalk_compiler_output)| OutputOptions]), OpenError, '$lgt_compiler_stream_error_handler'(OpenError) ), catch( '$lgt_write_encoding_directive'(Output, SourceFile), WriteError, '$lgt_compiler_stream_error_handler'(WriteError) ), % generate a begin_of_file term for use by the term-expansion mechanism '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, _, _, _, _, compile(user,_,_), _, 0-0, _), catch( '$lgt_compile_file_term'(begin_of_file, Ctx), Error, '$lgt_compiler_error_handler'(Error) ), % read and compile the remaining terms in the Logtalk source file catch( '$lgt_compile_file_term'(Term, Singletons, Lines, SourceFile, NewInput), Error, '$lgt_compiler_error_handler'(Error) ), '$lgt_close'(NewInput), % finish writing the generated Prolog file catch( '$lgt_write_runtime_tables'(Output), OutputError, '$lgt_compiler_output_stream_error_handler'(Output, OutputError) ), '$lgt_close'(Output), '$lgt_restore_global_operator_table', '$lgt_check_file_naming'. '$lgt_write_runtime_tables'(Output) :- '$lgt_generate_loaded_file_table_entry'(SourceFile), % write out any Prolog code occurring after the last source file entity '$lgt_write_prolog_terms'(Output, SourceFile), % write entity runtime directives and clauses '$lgt_write_runtime_clauses'(Output, SourceFile), % write initialization/1 directive at the end of the file to improve % compatibility with non-ISO compliant Prolog compilers '$lgt_write_initialization_directive'(Output, SourceFile). '$lgt_generate_loaded_file_table_entry'(SourceFile) :- '$lgt_pp_file_paths_flags_'(Basename, Directory, SourceFile, ObjectFile, Flags), % the make predicate will reload a file if the compilation mode changed ... ( '$lgt_compiler_flag'(debug, on) -> Mode = debug ; '$lgt_compiler_flag'(optimize, on) -> Mode = optimal ; Mode = normal ), % ... or if the file modification date changed (e.g., to fix compilation errors) '$lgt_file_modification_time'(SourceFile, TimeStamp), % compute text properties that are only available after successful file compilation ( '$lgt_pp_file_encoding_'(SourceFile, Encoding, _, _) -> ( '$lgt_pp_file_bom_'(SourceFile, BOM) -> TextProperties = [encoding(Encoding), BOM] ; TextProperties = [encoding(Encoding)] ) ; TextProperties = [] ), assertz('$lgt_pp_runtime_clause_'('$lgt_loaded_file_'(Basename, Directory, Mode, Flags, TextProperties, ObjectFile, TimeStamp))). % '$lgt_check_for_encoding_directive'(?term, +atom, +pair(integer), @stream, -stream, +list, -list) % % encoding/1 directives must be used during entity compilation and for the % encoding of the generated Prolog files; a BOM present in the source file % is inherited by the generated Prolog file '$lgt_check_for_encoding_directive'(Term, _, _, _, _, _, _) :- var(Term), throw(error(instantiation_error, term)). '$lgt_check_for_encoding_directive'((:- Term), _, _, _, _, _, _) :- var(Term), throw(error(instantiation_error, directive(Term))). '$lgt_check_for_encoding_directive'((:- encoding(Encoding)), SourceFile, BeginLine-EndLine, Input, NewInput, InputOptions, [encoding(PrologEncoding)|BOM]) :- !, ( var(Encoding) -> throw(error(instantiation_error, directive(encoding(Encoding)))) ; '$lgt_prolog_feature'(encoding_directive, EncodingDirective), % avoid a trivial failure warning with some Prolog backends % by checking the flag value in a separate goal EncodingDirective == unsupported -> throw(error(resource_error(text_encoding_support), directive(encoding(Encoding)))) ; % the conversion between Logtalk and Prolog encodings is defined in the adapter files ( '$lgt_decompose_file_name'(SourceFile, _, _, Extension), '$lgt_file_extension'(prolog, Extension), '$lgt_logtalk_prolog_encoding'(LogtalkEncoding, Encoding, Input) -> % converted Prolog specific encoding to Logtalk encoding; % possibly compiling a module as an object PrologEncoding = Encoding ; LogtalkEncoding = Encoding, '$lgt_logtalk_prolog_encoding'(LogtalkEncoding, PrologEncoding, Input) ) -> assertz('$lgt_pp_file_encoding_'(SourceFile, LogtalkEncoding, PrologEncoding, BeginLine)), % check that the encoding/1 directive is found in the first line ( BeginLine =:= 1 -> true ; '$lgt_compiler_flag'(encodings, silent) -> true ; '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'(warning(encodings), misplaced_encoding_directive(SourceFile, BeginLine-EndLine)) ), % close and reopen the source file using the specified encoding '$lgt_close'(Input), '$lgt_open'(SourceFile, read, NewInput, [encoding(PrologEncoding)| InputOptions]), ( ( catch(stream_property(NewInput, bom(Boolean)), _, fail) % SWI-Prolog and YAP ; catch(stream_property(NewInput, encoding_signature(Boolean)), _, fail) % SICStus Prolog ) -> BOM = [bom(Boolean)], assertz('$lgt_pp_file_bom_'(SourceFile, bom(Boolean))) ; BOM = [] ), % throw away the already processed encoding/1 directive '$lgt_read_file_term'(SourceFile, NewInput, _, _, _) ; % encoding not recognized atom(Encoding) -> throw(error(domain_error(text_encoding, Encoding), directive(encoding(Encoding)))) ; throw(error(type_error(atom, Encoding), directive(encoding(Encoding)))) ). % assume no encoding/1 directive present on the source file '$lgt_check_for_encoding_directive'(_, _, _, Input, Input, _, []). % as per coding guidelines, the basename of a file that defines a single % entity should by the name of the entity or, in the case of parametric % entities, the name of the entity concatenated with the number of the % parameters, possible separated by an underscore '$lgt_check_file_naming' :- ( '$lgt_compiler_flag'(naming, warning), findall( Entity, ( '$lgt_pp_runtime_clause_'('$lgt_current_protocol_'(Entity, _, _, _, _)) ; '$lgt_pp_runtime_clause_'('$lgt_current_category_'(Entity, _, _, _, _, _)) ; '$lgt_pp_runtime_clause_'('$lgt_current_object_'(Entity, _, _, _, _, _, _, _, _, _, _)) ), [Single] ) -> '$lgt_pp_file_paths_flags_'(Basename, _, SourceFile, _, _), ( functor(Single, Name, Arity), ( Expected = Name ; number_codes(Arity, ArityCodes), ( atom_codes(ArityAtom, [95| ArityCodes]) ; atom_codes(ArityAtom, ArityCodes) ), atom_concat(Name, ArityAtom, Expected) ), '$lgt_file_extension'(logtalk, Extension), atom_concat(Expected, Extension, Basename) -> true ; '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'(warning(naming), file_and_entity_names_differ(SourceFile, Single)) ) ; true ). % '$lgt_compile_file_term'(@term, +list, +pair(integer), +atom, @stream) '$lgt_compile_file_term'((-), _, _, _, _) :- % catch variables throw(error(instantiation_error, term)). '$lgt_compile_file_term'(end_of_file, _, Lines, _, _) :- !, % set the initial compilation context and the position for compiling the end_of_file term '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, _, _, _, _, compile(user,_,_), _, Lines, _), % allow for term-expansion of the end_of_file term '$lgt_compile_file_term'(end_of_file, Ctx). '$lgt_compile_file_term'(Term, _, _, File, Input) :- '$lgt_pp_cc_skipping_', % we're performing conditional compilation and skipping terms ... \+ '$lgt_is_conditional_compilation_directive'(Term), % ... except for conditional compilation directives !, '$lgt_read_file_term'(File, Input, Next, NextSingletons, NextLines), '$lgt_compile_file_term'(Next, NextSingletons, NextLines, File, Input). '$lgt_compile_file_term'(Term, Singletons, Lines, File, Input) :- '$lgt_report_singleton_variables'(Singletons, Term, File, Lines), % set the initial compilation context and the position for compiling the term '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, _, _, _, _, compile(user,_,_), _, Lines, _), '$lgt_compile_file_term'(Term, Ctx), '$lgt_read_file_term'(File, Input, Next, NextSingletons, NextLines), '$lgt_compile_file_term'(Next, NextSingletons, NextLines, File, Input). % '$lgt_add_referenced_object'(@object_identifier, @compilation_context) % % adds referenced object for later checking of references to unknown objects; % we also save the line numbers for the first reference to the object % % the definition is optimized to minimize the number of inferences for % runtime resolved ::/2 calls '$lgt_add_referenced_object'(Obj, Ctx) :- '$lgt_comp_ctx_mode'(Ctx, Mode), ( Mode == runtime -> true ; Mode = compile(aux,_,_) -> true ; % compiling a reference in a source file '$lgt_pp_referenced_object_'(Obj, _, _) -> % not the first reference to this object true ; atom(Obj) -> '$lgt_source_file_context'(File, Lines), assertz('$lgt_pp_referenced_object_'(Obj, File, Lines)) ; % parametric object '$lgt_term_template'(Obj, Template), '$lgt_source_file_context'(File, Lines), assertz('$lgt_pp_referenced_object_'(Template, File, Lines)) ). % '$lgt_add_referenced_protocol'(@protocol_identifier, @compilation_context) % % adds referenced protocol for later checking of references to unknown protocols % we also save the line numbers for the first reference to the protocol '$lgt_add_referenced_protocol'(Ptc, Ctx) :- '$lgt_comp_ctx_mode'(Ctx, Mode), ( Mode == runtime -> true ; Mode = compile(aux,_,_) -> true ; % compiling a reference in a source file '$lgt_pp_referenced_protocol_'(Ptc, _, _) -> % not the first reference to this protocol true ; '$lgt_source_file_context'(File, Lines), assertz('$lgt_pp_referenced_protocol_'(Ptc, File, Lines)) ). % '$lgt_add_referenced_category'(@category_identifier, @compilation_context) % % adds referenced category for later checking of references to unknown categories % we also save the line numbers for the first reference to the category '$lgt_add_referenced_category'(Ctg, Ctx) :- '$lgt_comp_ctx_mode'(Ctx, Mode), ( Mode == runtime -> true ; Mode = compile(aux,_,_) -> true ; % compiling a reference in a source file '$lgt_pp_referenced_category_'(Ctg, _, _) -> % not the first reference to this category true ; atom(Ctg) -> '$lgt_source_file_context'(File, Lines), assertz('$lgt_pp_referenced_category_'(Ctg, File, Lines)) ; % parametric category '$lgt_term_template'(Ctg, Template), '$lgt_source_file_context'(File, Lines), assertz('$lgt_pp_referenced_category_'(Template, File, Lines)) ). % '$lgt_add_referenced_module'(@term, @compilation_context) % % adds referenced module for later checking of references to unknown modules; % we also save the line numbers for the first reference to the module '$lgt_add_referenced_module'(Module, Ctx) :- '$lgt_comp_ctx_mode'(Ctx, Mode), ( Mode == runtime -> true ; Mode = compile(aux,_,_) -> true ; % compiling a reference in a source file var(Module) -> % module instantiated only at runtime true ; '$lgt_pp_referenced_module_'(Module, _, _) -> % not the first reference to this module true ; '$lgt_source_file_context'(File, Lines), assertz('$lgt_pp_referenced_module_'(Module, File, Lines)) ). % '$lgt_add_referenced_object_message'(@compilation_mode, @term, @callable, @callable, @term) % % adds referenced object and message for supporting using reflection to % retrieve cross-reference information '$lgt_add_referenced_object_message'(runtime, _, _, _, _). '$lgt_add_referenced_object_message'(compile(aux,_,_), _, _, _, _) :- !. '$lgt_add_referenced_object_message'(compile(user,_,_), Obj, Pred, Alias, Head) :- ( var(Head) -> % not compiling a clause true ; % add reference if first but be careful to not instantiate the object argument which may only be known at runtime functor(Pred, PredFunctor, PredArity), functor(Head, HeadFunctor, HeadArity), '$lgt_source_file_context'(File, Lines), ( \+ \+ '$lgt_pp_referenced_object_message_'(Obj, PredFunctor/PredArity, _, HeadFunctor/HeadArity, File, Lines) -> true ; functor(Alias, AliasFunctor, AliasArity), ( compound(Obj) -> % compile-time parametric object '$lgt_term_template'(Obj, Template), assertz('$lgt_pp_referenced_object_message_'(Template, PredFunctor/PredArity, AliasFunctor/AliasArity, HeadFunctor/HeadArity, File, Lines)) ; % runtime instantiated object or non-parametric object assertz('$lgt_pp_referenced_object_message_'(Obj, PredFunctor/PredArity, AliasFunctor/AliasArity, HeadFunctor/HeadArity, File, Lines)) ) ) ). % '$lgt_add_referenced_module_predicate'(@compilation_mode, @term, @callable, @callable, @term) % % adds referenced module for later checking of references to unknown modules % we also save the line numbers for the first reference to the module '$lgt_add_referenced_module_predicate'(runtime, _, _, _, _). '$lgt_add_referenced_module_predicate'(compile(aux,_,_), _, _, _, _) :- !. '$lgt_add_referenced_module_predicate'(compile(user,_,_), Module, Pred, Alias, Head) :- ( var(Head) -> % not compiling a clause true ; % add reference if first but be careful to not instantiate the module argument which may only be known at runtime functor(Pred, PredFunctor, PredArity), functor(Head, HeadFunctor, HeadArity), '$lgt_source_file_context'(File, Lines), ( \+ \+ '$lgt_pp_referenced_module_predicate_'(Module, PredFunctor/PredArity, _, HeadFunctor/HeadArity, File, Lines) -> true ; functor(Alias, AliasFunctor, AliasArity), assertz('$lgt_pp_referenced_module_predicate_'(Module, PredFunctor/PredArity, AliasFunctor/AliasArity, HeadFunctor/HeadArity, File, Lines)) ) ). % '$lgt_add_entity_source_data'(@atom, @entity_identifier) % % adds entity source data when the corresponding flag is turned on '$lgt_add_entity_source_data'(Kind, Entity) :- ( '$lgt_compiler_flag'(source_data, on) -> '$lgt_pp_file_paths_flags_'(_, _, MainFile, _, _), '$lgt_add_entity_properties'(Kind, Entity, MainFile), '$lgt_add_entity_predicate_properties'(Entity, MainFile) ; true ). % '$lgt_add_entity_properties'(@atom, @entity_identifier, +atom) % % adds entity properties related to the entity source file '$lgt_add_entity_properties'(Kind, Entity, _) :- ( Kind == object -> '$lgt_pp_referenced_object_'(Entity, _, StartDirective-EndDirective) ; Kind == protocol -> '$lgt_pp_referenced_protocol_'(Entity, _, StartDirective-EndDirective) ; % Kind == category, '$lgt_pp_referenced_category_'(Entity, _, StartDirective-EndDirective) ), assertz('$lgt_pp_runtime_clause_'('$lgt_entity_property_'(Entity, directive(StartDirective, EndDirective)))), '$lgt_pp_file_paths_flags_'(Basename, Directory, _, _, _), '$lgt_pp_entity_lines_'(Entity, Start-End), assertz('$lgt_pp_runtime_clause_'('$lgt_entity_property_'(Entity, file_lines(Basename, Directory, Start, End)))), fail. '$lgt_add_entity_properties'(_, Entity, MainFile) :- '$lgt_pp_referenced_object_message_'(Object, PredicateFunctor/PredicateArity, AliasFunctor/AliasArity, Caller, File, Lines), '$lgt_property_location'(MainFile, File, Lines, Location), functor(Predicate, PredicateFunctor, PredicateArity), ( '$lgt_pp_uses_non_terminal_'(Object, _, _, Predicate, _, _, _, _) -> PredicateArity2 is PredicateArity - 2, NonTerminal = PredicateFunctor//PredicateArity2 ; NonTerminal = no ), ( PredicateFunctor/PredicateArity == AliasFunctor/AliasArity -> assertz('$lgt_pp_runtime_clause_'('$lgt_entity_property_'(Entity, calls(Object::PredicateFunctor/PredicateArity, Caller, no, NonTerminal, Location)))) ; assertz('$lgt_pp_runtime_clause_'('$lgt_entity_property_'(Entity, calls(Object::PredicateFunctor/PredicateArity, Caller, AliasFunctor/AliasArity, NonTerminal, Location)))) ), fail. '$lgt_add_entity_properties'(_, Entity, MainFile) :- '$lgt_pp_referenced_module_predicate_'(Module, PredicateFunctor/PredicateArity, AliasFunctor/AliasArity, Caller, File, Lines), '$lgt_property_location'(MainFile, File, Lines, Location), functor(Predicate, PredicateFunctor, PredicateArity), ( '$lgt_pp_use_module_non_terminal_'(Module, _, _, Predicate, _, _, _, _) -> PredicateArity2 is PredicateArity - 2, NonTerminal = PredicateFunctor//PredicateArity2 ; NonTerminal = no ), ( PredicateFunctor/PredicateArity == AliasFunctor/AliasArity -> assertz('$lgt_pp_runtime_clause_'('$lgt_entity_property_'(Entity, calls(':'(Module,PredicateFunctor/PredicateArity), Caller, no, NonTerminal, Location)))) ; assertz('$lgt_pp_runtime_clause_'('$lgt_entity_property_'(Entity, calls(':'(Module,PredicateFunctor/PredicateArity), Caller, AliasFunctor/AliasArity, NonTerminal, Location)))) ), fail. '$lgt_add_entity_properties'(_, Entity, MainFile) :- '$lgt_pp_calls_self_predicate_'(Predicate, Caller, File, Lines), '$lgt_property_location'(MainFile, File, Lines, Location), assertz('$lgt_pp_runtime_clause_'('$lgt_entity_property_'(Entity, calls(::Predicate, Caller, no, no, Location)))), fail. '$lgt_add_entity_properties'(_, Entity, MainFile) :- '$lgt_pp_calls_super_predicate_'(Predicate, Caller, File, Lines), '$lgt_property_location'(MainFile, File, Lines, Location), assertz('$lgt_pp_runtime_clause_'('$lgt_entity_property_'(Entity, calls(^^Predicate, Caller, no, no, Location)))), fail. '$lgt_add_entity_properties'(_, Entity, MainFile) :- '$lgt_pp_calls_predicate_'(Predicate, _, Caller, File, Lines), '$lgt_property_location'(MainFile, File, Lines, Location), assertz('$lgt_pp_runtime_clause_'('$lgt_entity_property_'(Entity, calls(Predicate, Caller, no, no, Location)))), fail. '$lgt_add_entity_properties'(_, Entity, MainFile) :- '$lgt_pp_updates_predicate_'(Dynamic, Updater, File, Lines), '$lgt_updates_property_alias_non_terminal'(Dynamic, Alias, NonTerminal), '$lgt_property_location'(MainFile, File, Lines, Location), assertz('$lgt_pp_runtime_clause_'('$lgt_entity_property_'(Entity, updates(Dynamic, Updater, Alias, NonTerminal, Location)))), fail. '$lgt_add_entity_properties'(_, Entity, _) :- '$lgt_pp_entity_info_'(Info, _, _), assertz('$lgt_pp_runtime_clause_'('$lgt_entity_property_'(Entity, info(Info)))), fail. '$lgt_add_entity_properties'(_, Entity, _) :- findall(Define, '$lgt_pp_number_of_clauses_rules_'(_, _, Define, _), Defines), '$lgt_sum_list'(Defines, TotalDefines), findall( AuxDefine, ( '$lgt_pp_defines_predicate_'(_, Functor/Arity, _, _, _, aux), '$lgt_pp_number_of_clauses_rules_'(Functor, Arity, AuxDefine, _) ), AuxDefines ), '$lgt_sum_list'(AuxDefines, TotalAuxDefines), findall(Provide, '$lgt_pp_number_of_clauses_rules_'(_, _, _, Provide, _), Provides), '$lgt_sum_list'(Provides, TotalProvides), Total is TotalDefines + TotalProvides, TotalUser is Total - TotalAuxDefines, assertz('$lgt_pp_runtime_clause_'('$lgt_entity_property_'(Entity, number_of_clauses(Total, TotalUser)))), fail. '$lgt_add_entity_properties'(_, Entity, _) :- findall(Define, '$lgt_pp_number_of_clauses_rules_'(_, _, _, Define), Defines), '$lgt_sum_list'(Defines, TotalDefines), findall( AuxDefine, ( '$lgt_pp_defines_predicate_'(_, Functor/Arity, _, _, _, aux), '$lgt_pp_number_of_clauses_rules_'(Functor, Arity, _, AuxDefine) ), AuxDefines ), '$lgt_sum_list'(AuxDefines, TotalAuxDefines), findall(Provide, '$lgt_pp_number_of_clauses_rules_'(_, _, _, _, Provide), Provides), '$lgt_sum_list'(Provides, TotalProvides), Total is TotalDefines + TotalProvides, TotalUser is Total - TotalAuxDefines, assertz('$lgt_pp_runtime_clause_'('$lgt_entity_property_'(Entity, number_of_rules(Total, TotalUser)))), fail. '$lgt_add_entity_properties'(_, Entity, MainFile) :- '$lgt_pp_object_alias_'(Original, Alias, _, File, Lines), '$lgt_property_location'(MainFile, File, Lines, Location), assertz('$lgt_pp_runtime_clause_'('$lgt_entity_property_'(Entity, object_alias(Original, Alias, Location)))), fail. '$lgt_add_entity_properties'(_, Entity, MainFile) :- '$lgt_pp_module_alias_'(Original, Alias, _, File, Lines), '$lgt_property_location'(MainFile, File, Lines, Location), assertz('$lgt_pp_runtime_clause_'('$lgt_entity_property_'(Entity, module_alias(Original, Alias, Location)))), fail. '$lgt_add_entity_properties'(_, Entity, MainFile) :- '$lgt_pp_predicate_alias_'(For, Original, Alias, NonTerminalFlag, File, Lines), '$lgt_property_location'(MainFile, File, Lines, Location), functor(Original, OriginalFunctor, Arity), functor(Alias, AliasFunctor, Arity), assertz('$lgt_pp_runtime_clause_'('$lgt_entity_property_'(Entity, predicate_alias(For, OriginalFunctor/Arity, AliasFunctor/Arity, NonTerminalFlag, Location)))), fail. '$lgt_add_entity_properties'(_, _, _). % auxiliary predicate to compute the updates/2 object/category property % alias and non-terminal indicators for the update predicate '$lgt_updates_property_alias_non_terminal'(Object::PredicateFunctor/PredicateArity, AliasIndicator, NonTerminalIndicator) :- !, functor(Predicate, PredicateFunctor, PredicateArity), ( '$lgt_pp_uses_predicate_'(Object, Predicate, Alias, _, _, _) -> functor(Alias, AliasFunctor, AliasArity), AliasIndicator = AliasFunctor/AliasArity ; AliasIndicator = no ), ( '$lgt_pp_uses_non_terminal_'(Object, _, _, Predicate, _, _, _, _) -> NonTerminalArity is PredicateArity - 2, NonTerminalIndicator = PredicateFunctor//NonTerminalArity ; NonTerminalIndicator = no ). '$lgt_updates_property_alias_non_terminal'(':'(Module,PredicateFunctor/PredicateArity), AliasIndicator, NonTerminalIndicator) :- !, functor(Predicate, PredicateFunctor, PredicateArity), ( '$lgt_pp_use_module_predicate_'(Module, Predicate, Alias, _, _, _) -> functor(Alias, AliasFunctor, AliasArity), AliasIndicator = AliasFunctor/AliasArity ; AliasIndicator = no ), ( '$lgt_pp_use_module_non_terminal_'(Module, _, _, Predicate, _, _, _, _) -> NonTerminalArity is PredicateArity - 2, NonTerminalIndicator = PredicateFunctor//NonTerminalArity ; NonTerminalIndicator = no ). '$lgt_updates_property_alias_non_terminal'(_, no, no). % '$lgt_add_entity_predicate_properties'(@entity_identifier, +atom) % % saves all entity predicate properties (at the end of entity compilation) % for use with the reflection built-in predicates and methods '$lgt_add_entity_predicate_properties'(Entity, MainFile) :- '$lgt_pp_predicate_definition_location_'(Other, Functor, Arity, File, Lines), % multifile predicate clauses defined in Entity for Other '$lgt_property_location'(MainFile, File, Lines, Location), '$lgt_pp_number_of_clauses_rules_'(Other, Functor, Arity, Clauses, Rules), assertz('$lgt_pp_runtime_clause_'('$lgt_predicate_property_'(Entity, Functor/Arity, clauses_rules_location_to(Clauses,Rules,Location,Other)))), fail. '$lgt_add_entity_predicate_properties'(Entity, MainFile) :- '$lgt_pp_predicate_declaration_location_'(Functor, Arity, File, Lines), % local predicate clauses '$lgt_property_location'(MainFile, File, Lines, Location), assertz('$lgt_pp_runtime_clause_'('$lgt_predicate_property_'(Entity, Functor/Arity, declaration_location(Location)))), \+ '$lgt_pp_defines_predicate_'(_, Functor/Arity, _, _, _, _), assertz('$lgt_pp_runtime_clause_'('$lgt_predicate_property_'(Entity, Functor/Arity, flags_clauses_rules_location(0, 0, 0, 0-0)))), fail. '$lgt_add_entity_predicate_properties'(Entity, MainFile) :- '$lgt_pp_defines_predicate_'(_, Functor/Arity, _, _, _, Origin), ( '$lgt_pp_predicate_recursive_calls_'(Functor, Arity, _) -> Flags0 is 8 ; Flags0 is 0 ), ( '$lgt_pp_inline_predicate_'(Functor/Arity) -> Flags1 is Flags0 + 4 ; Flags1 is Flags0 ), ( '$lgt_pp_defines_non_terminal_'(Functor, _, Arity) -> Flags2 is Flags1 + 2 ; Flags2 is Flags1 ), ( Origin == aux -> Flags is Flags2 + 1, File = MainFile, Lines = 0-0 ; Flags is Flags2, '$lgt_pp_predicate_definition_location_'(Functor, Arity, File, Lines) ), '$lgt_pp_number_of_clauses_rules_'(Functor, Arity, Clauses, Rules), '$lgt_property_location'(MainFile, File, Lines, Location), assertz('$lgt_pp_runtime_clause_'('$lgt_predicate_property_'(Entity, Functor/Arity, flags_clauses_rules_location(Flags, Clauses, Rules, Location)))), fail. '$lgt_add_entity_predicate_properties'(Entity, _) :- '$lgt_pp_mode_'(Mode, Solutions, _, _), functor(Mode, Functor, Arity), ( '$lgt_pp_non_terminal_'(Functor, Arity, ExtArity) -> assertz('$lgt_pp_runtime_clause_'('$lgt_predicate_property_'(Entity, Functor/ExtArity, mode(Mode, Solutions)))) ; assertz('$lgt_pp_runtime_clause_'('$lgt_predicate_property_'(Entity, Functor/Arity, mode(Mode, Solutions)))) ), fail. '$lgt_add_entity_predicate_properties'(Entity, _) :- '$lgt_pp_predicate_info_'(Predicate, Info, _, _), assertz('$lgt_pp_runtime_clause_'('$lgt_predicate_property_'(Entity, Predicate, info(Info)))), fail. '$lgt_add_entity_predicate_properties'(_, _). % the property location is the lines pair when found on the main file % or a include(File,Lines) term when found in an included file '$lgt_property_location'(MainFile, MainFile, Lines, Lines) :- !. '$lgt_property_location'(_, File, Lines, include(File, Lines)). % '$lgt_report_singleton_variables'(+compilation_mode, @list, @term, +atom, @pair(integer)) % % reports the singleton variables found while compiling an entity term in the given mode '$lgt_report_singleton_variables'(runtime, _, _, _, _). '$lgt_report_singleton_variables'(compile(_,_,_), Singletons, Term, File, Lines) :- '$lgt_report_singleton_variables'(Singletons, Term, File, Lines). % '$lgt_report_singleton_variables'(@list, @term, +atom, @pair(integer)) % % reports the singleton variables found while compiling an entity term '$lgt_report_singleton_variables'([], _, _, _). '$lgt_report_singleton_variables'([Singleton| Singletons], Term, File, Lines) :- ( '$lgt_compiler_flag'(singleton_variables, warning), '$lgt_filter_singleton_variable_names'([Singleton| Singletons], Term, Names), Names \== [] -> '$lgt_increment_compiling_warnings_counter', ( '$lgt_pp_entity_'(Type, Entity, _) -> '$lgt_print_message'( warning(singleton_variables), singleton_variables(File, Lines, Type, Entity, Names, Term) ) ; '$lgt_print_message'( warning(singleton_variables), singleton_variables(File, Lines, Names, Term) ) ) ; true ). % '$lgt_filter_singleton_variable_names'(@list, @term, -list(atom)) % % filters 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_singleton_variable_names'(Singletons, Term, Names) :- ( '$lgt_compiler_flag'(underscore_variables, dont_care) -> '$lgt_filter_dont_care_variables'(Singletons, SingletonsFiltered) ; SingletonsFiltered = Singletons ), ( '$lgt_pp_parameter_variables_'(ParameterVariables) -> '$lgt_filter_parameter_variables'(SingletonsFiltered, ParameterVariables, Names) ; Term = (:- Directive), nonvar(Directive), '$lgt_logtalk_opening_directive'(Directive) -> '$lgt_filter_parameter_variables'(SingletonsFiltered, Names) ; '$lgt_singleton_variable_names'(SingletonsFiltered, Names) ). '$lgt_singleton_variable_names'([], []). '$lgt_singleton_variable_names'([Name = _| Singletons], [Name| Names]) :- '$lgt_singleton_variable_names'(Singletons, Names). '$lgt_filter_dont_care_variables'([], []). '$lgt_filter_dont_care_variables'([Name = Variable| VariableNames], FilteredVariableNames) :- ( '$lgt_parameter_variable_name'(Name) -> FilteredVariableNames = [Name = Variable| Rest], '$lgt_filter_dont_care_variables'(VariableNames, Rest) ; sub_atom(Name, 0, 1, _, '_') -> '$lgt_filter_dont_care_variables'(VariableNames, FilteredVariableNames) ; FilteredVariableNames = [Name = Variable| Rest], '$lgt_filter_dont_care_variables'(VariableNames, Rest) ). '$lgt_filter_parameter_variables'([], _, []). '$lgt_filter_parameter_variables'([Name = _| VariableNames], ParameterVariables, Names) :- ( '$lgt_member'(Name-_, ParameterVariables) -> '$lgt_filter_parameter_variables'(VariableNames, ParameterVariables, Names) ; Names = [Name| Rest], '$lgt_filter_parameter_variables'(VariableNames, ParameterVariables, Rest) ). '$lgt_filter_parameter_variables'([], []). '$lgt_filter_parameter_variables'([Name = _| VariableNames], Names) :- ( '$lgt_parameter_variable_name'(Name) -> '$lgt_filter_parameter_variables'(VariableNames, Names) ; Names = [Name| Rest], '$lgt_filter_parameter_variables'(VariableNames, Rest) ). % '$lgt_compiler_error_handler'(+atom, +atom, +pair(integer), @compound) % % closes the streams being used for reading and writing terms, restores % the operator table, reports the compilation error found, and, finally, % fails in order to abort the compilation process '$lgt_compiler_error_handler'(SourceFile, ObjectFile, Lines, Error) :- stream_property(Input, alias(logtalk_compiler_input)), stream_property(Output, alias(logtalk_compiler_output)), !, '$lgt_print_message'(error, compiler_error(SourceFile, Lines, Error)), '$lgt_restore_global_operator_table', '$lgt_clean_pp_file_clauses', '$lgt_clean_pp_entity_clauses', '$lgt_reset_warnings_counter', catch('$lgt_close'(Input), _, true), ( nonvar(Output) -> catch('$lgt_close'(Output), _, true), % try to delete the intermediate Prolog files in order to prevent % problems by mistaken the broken files by good ones '$lgt_delete_intermediate_files'(ObjectFile) ; true ), !, fail. % '$lgt_compiler_error_handler'(@compound) '$lgt_compiler_error_handler'(Error) :- '$lgt_pp_file_paths_flags_'(_, _, MainSourceFile, ObjectFile, _), ( '$lgt_source_file_context'(SourceFile, Lines) -> true ; % no file context information available for last term read; likely % due to a syntax error when trying to read a main file term as syntax % errors in included files are handled when reading a file to terms SourceFile = MainSourceFile, ( stream_property(Input, alias(logtalk_compiler_input)), '$lgt_stream_current_line_number'(Input, Line) -> Lines = Line-Line ; % some backend Prolog compilers do not support, or do not always support % (e.g., when a syntax error occurs) querying a stream line number Lines = '-'(-1, -1) ) ), '$lgt_compiler_error_handler'(SourceFile, ObjectFile, Lines, Error). % '$lgt_compiler_first_term_error_handler'(+atom, +pair(integer), @compound) % % closes the stream being used for reading, restores the operator table, % reports the compilation error found, and, finally, fails in order to % abort the compilation process '$lgt_compiler_first_term_error_handler'(SourceFile, Lines, Error) :- ( nonvar(Lines) -> true ; % no line information available likely due to a syntax error stream_property(Input, alias(logtalk_compiler_input)), '$lgt_stream_current_line_number'(Input, Line) -> Lines = Line-Line ; % some backend Prolog compilers do not support, or do not always support % (e.g., when a syntax error occurs) querying a stream line number Lines = '-'(-1, -1) ), '$lgt_print_message'(error, compiler_error(SourceFile, Lines, Error)), '$lgt_restore_global_operator_table', '$lgt_clean_pp_file_clauses', '$lgt_clean_pp_entity_clauses', '$lgt_reset_warnings_counter', stream_property(Input, alias(logtalk_compiler_input)), catch('$lgt_close'(Input), _, true), !, fail. % '$lgt_compiler_output_stream_error_handler'(@stream, @compound) % % closes the stream being used for writing compiled terms, restores % the operator table, reports the compilation error found, and, finally, % fails in order to abort the compilation process '$lgt_compiler_output_stream_error_handler'(Stream, Error) :- '$lgt_print_message'(error, compiler_stream_error(Error)), '$lgt_restore_global_operator_table', '$lgt_clean_pp_file_clauses', '$lgt_clean_pp_entity_clauses', '$lgt_reset_warnings_counter', catch('$lgt_close'(Stream), _, true), !, fail. % '$lgt_compiler_stream_error_handler'(@compound) % % closes input and output streams if open, restores the operator table, % reports the compilation error found, and, finally, fails in order to % abort the compilation process '$lgt_compiler_stream_error_handler'(Error) :- ( stream_property(Input, alias(logtalk_compiler_input)) -> catch('$lgt_close'(Input), _, true) ; true ), ( stream_property(Output, alias(logtalk_compiler_output)) -> catch('$lgt_close'(Output), _, true) ; true ), '$lgt_print_message'(error, compiler_stream_error(Error)), '$lgt_restore_global_operator_table', '$lgt_clean_pp_file_clauses', '$lgt_clean_pp_entity_clauses', '$lgt_reset_warnings_counter', !, fail. % '$lgt_read_file_term'(+atom, @stream, -term, @list(var), -pair(integer)) % % remember term position and variable names in order to support the % logtalk_load_context/2 predicate and more informative compiler warning % and error messages '$lgt_read_file_term'(File, Stream, Term, Singletons, Lines) :- % we retract first the position and variable names for the previous % read term as we may get a syntax error while reading the next term; % this will allow us to use the stream position if necessary to find % the approximated position of the error retractall('$lgt_pp_term_source_data_'(_, _, _, _, _)), % the actual read term predicate is defined in the adapter files as % there's no standard option for returning the read term position '$lgt_read_term'(Stream, Term, [variable_names(VariableNames), singletons(Singletons)], Lines), '$lgt_report_variable_naming_issues'(VariableNames, File, Lines), assertz('$lgt_pp_term_source_data_'(Term, VariableNames, Singletons, File, Lines)). % '$lgt_second_stage'(+atom, @entity_identifier, +compilation_context) % % compiler second stage % % the first stage collected data on all directives, clause heads, and % grammar rules heads thus enabling the compilation of initialization/1 % goals and clause body goals '$lgt_second_stage'(Type, Entity, Ctx) :- catch( '$lgt_compile_entity'(Type, Entity, Ctx), Error, '$lgt_second_stage_error_handler'(Error) ). '$lgt_compile_entity'(Type, Entity, Ctx) :- '$lgt_generate_entity_code'(Type, Ctx), '$lgt_inline_calls'(Type), '$lgt_report_lint_issues'(Type, Entity), '$lgt_write_entity_code'(Type, Entity), '$lgt_add_entity_source_data'(Type, Entity), '$lgt_save_entity_runtime_clause'(Type), '$lgt_restore_file_operator_table', '$lgt_clean_pp_entity_clauses'(Type). '$lgt_second_stage_error_handler'(Error) :- '$lgt_pp_file_paths_flags_'(_, _, _, ObjectFile, _), % get the source file from the context as we may be reporting % an error in an included file instead of in the main file ( '$lgt_source_file_context'(SourceFile, Lines) -> true ; % assume auxiliary clause and thus not part of the source file '$lgt_pp_file_paths_flags_'(_, _, SourceFile, _, _), Lines = '-'(0, 0) ), '$lgt_compiler_error_handler'(SourceFile, ObjectFile, Lines, Error). % '$lgt_compile_entity_flags'(+atom, -integer) % % defines the entity flags value when compiling or dynamically creating a new entity % % we use integers in decimal notation instead of binary notation to avoid standards % compliance issues with some Prolog compilers '$lgt_compile_entity_flags'(protocol, Flags) :- ( '$lgt_compiler_flag'(debug, on) -> Debug = 512 ; Debug = 0 ), ( '$lgt_compiler_flag'(source_data, on) -> SourceData = 8 ; SourceData = 0 ), ( '$lgt_pp_dynamic_' -> Dynamic = 2 ; Dynamic = 0 ), ( '$lgt_pp_built_in_' -> BuiltIn = 1 ; BuiltIn = 0 ), Flags is Debug + SourceData + Dynamic + BuiltIn. '$lgt_compile_entity_flags'(category, Flags) :- ( '$lgt_compiler_flag'(debug, on) -> Debug = 512 ; Debug = 0 ), ( '$lgt_compiler_flag'(events, allow) -> Events = 16 ; Events = 0 ), ( '$lgt_compiler_flag'(source_data, on) -> SourceData = 8 ; SourceData = 0 ), ( '$lgt_pp_dynamic_' -> Dynamic = 2 ; Dynamic = 0 ), ( '$lgt_pp_built_in_' -> BuiltIn = 1 ; BuiltIn = 0 ), Flags is Debug + Events + SourceData + Dynamic + BuiltIn. '$lgt_compile_entity_flags'(object, Flags) :- ( '$lgt_pp_module_'(_) -> Module = 1024 ; Module = 0 ), ( '$lgt_compiler_flag'(debug, on) -> Debug = 512 ; Debug = 0 ), ( '$lgt_compiler_flag'(context_switching_calls, allow) -> ContextSwitchingCalls = 256 ; ContextSwitchingCalls = 0 ), ( '$lgt_compiler_flag'(dynamic_declarations, allow) -> DynamicDeclarations = 128 ; DynamicDeclarations = 0 ), '$lgt_compiler_flag'(complements, ComplementsFlag), ( ComplementsFlag == deny -> Complements = 0 ; ComplementsFlag == allow -> Complements = 64 ; % ComplementsFlag == restrict, Complements = 32 ), ( '$lgt_compiler_flag'(events, allow) -> Events = 16 ; Events = 0 ), ( '$lgt_compiler_flag'(source_data, on) -> SourceData = 8 ; SourceData = 0 ), ( '$lgt_pp_threaded_' -> Threaded = 4 ; Threaded = 0 ), ( '$lgt_pp_dynamic_' -> Dynamic = 2 ; Dynamic = 0 ), ( '$lgt_pp_built_in_' -> BuiltIn = 1 ; BuiltIn = 0 ), Flags is Module + Debug + ContextSwitchingCalls + DynamicDeclarations + Complements + Events + SourceData + Threaded + Dynamic + BuiltIn. % saves the entity runtime clause after computing the final value of its flags '$lgt_save_entity_runtime_clause'(object) :- '$lgt_pp_object_'(Obj, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Rnm, _), '$lgt_compile_entity_flags'(object, Flags), assertz('$lgt_pp_runtime_clause_'('$lgt_current_object_'(Obj, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Rnm, Flags))). '$lgt_save_entity_runtime_clause'(protocol) :- '$lgt_pp_protocol_'(Ptc, Prefix, Dcl, Rnm, _), '$lgt_compile_entity_flags'(protocol, Flags), assertz('$lgt_pp_runtime_clause_'('$lgt_current_protocol_'(Ptc, Prefix, Dcl, Rnm, Flags))). '$lgt_save_entity_runtime_clause'(category) :- '$lgt_pp_category_'(Ctg, Prefix, Dcl, Def, Rnm, _), '$lgt_compile_entity_flags'(category, Flags), assertz('$lgt_pp_runtime_clause_'('$lgt_current_category_'(Ctg, Prefix, Dcl, Def, Rnm, Flags))). % cleans up all dynamic predicates used during source file compilation '$lgt_clean_pp_file_clauses' :- retractall('$lgt_pp_file_initialization_'(_, _)), retractall('$lgt_pp_file_entity_initialization_'(_, _, _)), retractall('$lgt_pp_file_encoding_'(_, _, _, _)), retractall('$lgt_pp_file_bom_'(_, _)), retractall('$lgt_pp_file_compiler_flag_'(_, _)), retractall('$lgt_pp_term_source_data_'(_, _, _, _, _)), % a Logtalk source file may contain only plain Prolog terms % instead of plain Prolog terms intermixed between entities % definitions; there might also be plain Prolog terms after % the last entity definition retractall('$lgt_pp_prolog_term_'(_, _)), % retract all file-specific flag values retractall('$lgt_pp_file_compiler_flag_'(_, _)), % retract all file-specific term and goal expansion hooks retractall('$lgt_pp_hook_term_expansion_'(_, _)), retractall('$lgt_pp_hook_goal_expansion_'(_, _)), '$lgt_clean_pp_cc_clauses', '$lgt_clean_pp_runtime_clauses'. % cleans up all dynamic predicates used for conditional compilation '$lgt_clean_pp_cc_clauses' :- retractall('$lgt_pp_cc_if_found_'(_)), retractall('$lgt_pp_cc_skipping_'), retractall('$lgt_pp_cc_mode_'(_)). % cleans up the dynamic predicate used for entity runtime clauses '$lgt_clean_pp_runtime_clauses' :- retractall('$lgt_pp_runtime_clause_'(_)). % cleans up all dynamic predicates used during entity compilation '$lgt_clean_pp_entity_clauses' :- '$lgt_clean_pp_object_clauses', '$lgt_clean_pp_protocol_clauses', '$lgt_clean_pp_category_clauses'. '$lgt_clean_pp_entity_clauses'(object) :- '$lgt_clean_pp_object_clauses'. '$lgt_clean_pp_entity_clauses'(protocol) :- '$lgt_clean_pp_protocol_clauses'. '$lgt_clean_pp_entity_clauses'(category) :- '$lgt_clean_pp_category_clauses'. '$lgt_clean_pp_object_clauses' :- retractall('$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _)), retractall('$lgt_pp_module_'(_)), retractall('$lgt_pp_object_initialization_'(_, _, _)), retractall('$lgt_pp_final_object_initialization_'(_, _)), retractall('$lgt_pp_imported_category_'(_, _, _, _, _, _)), retractall('$lgt_pp_extended_object_'(_, _, _, _, _, _, _, _, _, _, _)), retractall('$lgt_pp_instantiated_class_'(_, _, _, _, _, _, _, _, _, _, _)), retractall('$lgt_pp_specialized_class_'(_, _, _, _, _, _, _, _, _, _, _)), retractall('$lgt_pp_threaded_'), '$lgt_clean_pp_common_object_category_clauses', '$lgt_clean_pp_common_entity_clauses'. '$lgt_clean_pp_protocol_clauses' :- retractall('$lgt_pp_protocol_'(_, _, _, _, _)), retractall('$lgt_pp_extended_protocol_'(_, _, _, _, _)), '$lgt_clean_pp_common_entity_clauses'. '$lgt_clean_pp_category_clauses' :- retractall('$lgt_pp_category_'(_, _, _, _, _, _)), retractall('$lgt_pp_complemented_object_'(_, _, _, _, _)), retractall('$lgt_pp_extended_category_'(_, _, _, _, _, _)), '$lgt_clean_pp_common_object_category_clauses', '$lgt_clean_pp_common_entity_clauses'. '$lgt_clean_pp_common_object_category_clauses' :- retractall('$lgt_pp_implemented_protocol_'(_, _, _, _, _)), retractall('$lgt_pp_parameter_variables_'(_)), retractall('$lgt_pp_object_alias_'(_, _, _, _, _)), retractall('$lgt_pp_module_alias_'(_, _, _, _, _)), retractall('$lgt_pp_uses_predicate_'(_, _, _, _, _, _)), retractall('$lgt_pp_uses_non_terminal_'(_, _, _, _, _, _, _, _)), retractall('$lgt_pp_use_module_predicate_'(_, _, _, _, _, _)), retractall('$lgt_pp_use_module_non_terminal_'(_, _, _, _, _, _, _, _)), retractall('$lgt_pp_def_'(_)), retractall('$lgt_pp_ddef_'(_)), retractall('$lgt_pp_super_'(_)), retractall('$lgt_pp_number_of_clauses_rules_'(_, _, _, _)), retractall('$lgt_pp_number_of_clauses_rules_'(_, _, _, _, _)), retractall('$lgt_pp_predicate_definition_location_'(_, _, _, _)), retractall('$lgt_pp_predicate_definition_location_'(_, _, _, _, _)), retractall('$lgt_pp_redefined_built_in_'(_, _, _)), retractall('$lgt_pp_defines_predicate_'(_, _, _, _, _, _)), retractall('$lgt_pp_inline_predicate_'(_)), retractall('$lgt_pp_non_tail_recursive_predicate_'(_, _, _, _)), retractall('$lgt_pp_predicate_recursive_calls_'(_, _, _)), retractall('$lgt_pp_calls_predicate_'(_, _, _, _, _)), retractall('$lgt_pp_calls_self_predicate_'(_, _, _, _)), retractall('$lgt_pp_calls_super_predicate_'(_, _, _, _)), retractall('$lgt_pp_updates_predicate_'(_, _, _, _)), retractall('$lgt_pp_non_portable_predicate_'(_, _, _)), retractall('$lgt_pp_non_portable_function_'(_, _, _)), retractall('$lgt_pp_missing_function_'(_, _, _)), retractall('$lgt_pp_missing_meta_predicate_directive_'(_, _, _)), retractall('$lgt_pp_missing_dynamic_directive_'(_, _, _)), retractall('$lgt_pp_missing_discontiguous_directive_'(_, _, _)), retractall('$lgt_pp_missing_multifile_directive_'(_, _, _)), retractall('$lgt_pp_missing_use_module_directive_'(_, _)), retractall('$lgt_pp_previous_predicate_'(_, _)), retractall('$lgt_pp_defines_non_terminal_'(_, _, _)), retractall('$lgt_pp_calls_non_terminal_'(_, _, _, _)), retractall('$lgt_pp_referenced_object_'(_, _, _)), retractall('$lgt_pp_referenced_category_'(_, _, _)), retractall('$lgt_pp_referenced_module_'(_, _, _)), retractall('$lgt_pp_referenced_object_message_'(_, _, _, _, _, _)), retractall('$lgt_pp_referenced_module_predicate_'(_, _, _, _, _, _)). '$lgt_clean_pp_common_entity_clauses' :- retractall('$lgt_pp_entity_lines_'(_, _)), retractall('$lgt_pp_entity_compiler_flag_'(_, _)), retractall('$lgt_pp_entity_'(_, _, _)), retractall('$lgt_pp_entity_info_'(_, _, _)), retractall('$lgt_pp_predicate_info_'(_, _, _, _)), retractall('$lgt_pp_directive_'(_)), retractall('$lgt_pp_synchronized_'(_, _, _, _)), retractall('$lgt_pp_predicate_mutex_counter_'(_)), retractall('$lgt_pp_public_'(_, _, _, _)), retractall('$lgt_pp_protected_'(_, _, _, _)), retractall('$lgt_pp_private_'(_, _, _, _)), retractall('$lgt_pp_dynamic_'(_, _, _, _)), retractall('$lgt_pp_discontiguous_'(_, _, _)), retractall('$lgt_pp_multifile_'(_, _, _, _)), retractall('$lgt_pp_coinductive_'(_, _, _, _, _, _, _, _, _)), retractall('$lgt_pp_coinductive_head_'(_, _, _)), retractall('$lgt_pp_mode_'(_, _, _, _)), retractall('$lgt_pp_meta_predicate_'(_, _, _, _)), retractall('$lgt_pp_predicate_alias_'(_, _, _, _, _, _)), retractall('$lgt_pp_non_terminal_'(_, _, _)), retractall('$lgt_pp_entity_meta_directive_'(_, _, _)), retractall('$lgt_pp_dcl_'(_)), % clean any plain Prolog terms appearing before an entity definition retractall('$lgt_pp_prolog_term_'(_, _)), retractall('$lgt_pp_entity_term_'(_, _, _)), retractall('$lgt_pp_final_entity_term_'(_, _)), retractall('$lgt_pp_entity_aux_clause_'(_)), retractall('$lgt_pp_final_entity_aux_clause_'(_)), retractall('$lgt_pp_predicate_declaration_location_'(_, _, _, _)), retractall('$lgt_pp_referenced_protocol_'(_, _, _)), retractall('$lgt_pp_built_in_'), retractall('$lgt_pp_dynamic_'), retractall('$lgt_pp_aux_predicate_counter_'(_)). % '$lgt_clean_lookup_caches' % % cleans all entries for all dynamic binding lookup caches % % this also have the side-effect of removing the catchall clauses % that generate the cache entries which we must then re-assert '$lgt_clean_lookup_caches' :- retractall('$lgt_send_to_obj_'(_, _, _)), retractall('$lgt_send_to_obj_ne_'(_, _, _)), retractall('$lgt_send_to_self_'(_, _, _)), retractall('$lgt_obj_super_call_'(_, _, _)), retractall('$lgt_ctg_super_call_'(_, _, _)), retractall('$lgt_db_lookup_cache_'(_, _, _, _, _)), '$lgt_reassert_lookup_cache_catchall_clauses'. % '$lgt_clean_lookup_caches'(@callable) % % cleans all entries for a given predicate for all dynamic % binding lookup caches % % this also have the side-effect of removing the catchall clauses % that generate the cache entries which we must then re-assert '$lgt_clean_lookup_caches'(Pred) :- retractall('$lgt_send_to_obj_'(_, Pred, _)), retractall('$lgt_send_to_obj_ne_'(_, Pred, _)), retractall('$lgt_send_to_self_'(_, Pred, _)), retractall('$lgt_obj_super_call_'(_, Pred, _)), retractall('$lgt_ctg_super_call_'(_, Pred, _)), retractall('$lgt_db_lookup_cache_'(_, Pred, _, _, _)), '$lgt_reassert_lookup_cache_catchall_clauses'. % '$lgt_reassert_lookup_cache_catchall_clauses' % % reasserts the catchall clauses for the dynamic binding % lookup cache predicates that generate the cache entries '$lgt_reassert_lookup_cache_catchall_clauses' :- assertz(('$lgt_send_to_obj_'(Obj, Pred, ExCtx) :- '$lgt_send_to_obj_nv'(Obj, Pred, ExCtx))), assertz(('$lgt_send_to_obj_ne_'(Obj, Pred, ExCtx) :- '$lgt_send_to_obj_ne_nv'(Obj, Pred, ExCtx))), assertz(('$lgt_send_to_self_'(Obj, Pred, ExCtx) :- '$lgt_send_to_self_nv'(Obj, Pred, ExCtx))), assertz(('$lgt_obj_super_call_'(Super, Pred, ExCtx) :- '$lgt_obj_super_call_nv'(Super, Pred, ExCtx))), assertz(('$lgt_ctg_super_call_'(Ctg, Pred, ExCtx) :- '$lgt_ctg_super_call_nv'(Ctg, Pred, ExCtx))), % support runtime resolved database messages to the "user" pseudo-object assertz('$lgt_db_lookup_cache_'(user, Clause, _, Clause, true)). % '$lgt_restore_global_operator_table' % % restores the global operator table % % called after compiling a source file or after dynamically creating a new entity '$lgt_restore_global_operator_table' :- retract('$lgt_pp_entity_operator_'(_, Specifier, Operator, _, _, _)), op(0, Specifier, Operator), fail. '$lgt_restore_global_operator_table' :- retract('$lgt_pp_file_operator_'(_, Specifier, Operator)), op(0, Specifier, Operator), fail. '$lgt_restore_global_operator_table' :- retract('$lgt_pp_global_operator_'(Priority, Specifier, Operator)), op(Priority, Specifier, Operator), fail. '$lgt_restore_global_operator_table'. % '$lgt_restore_file_operator_table' % % restores the file operator table % % called after compiling a source file entity '$lgt_restore_file_operator_table' :- retract('$lgt_pp_entity_operator_'(_, Specifier, Operator, _, _, _)), op(0, Specifier, Operator), fail. '$lgt_restore_file_operator_table' :- retract('$lgt_pp_file_operator_'(Priority, Specifier, Operator)), op(Priority, Specifier, Operator), fail. '$lgt_restore_file_operator_table'. % '$lgt_activate_file_operators'(+integer, +operator_specifier, +atom_or_atom_list, +compilation_mode) % % activates local file operator definitions % % any conflicting global operator is saved so that it can be restored later '$lgt_activate_file_operators'(_, _, [], _) :- !. '$lgt_activate_file_operators'(Priority, Specifier, [Operator| Operators], Mode) :- !, '$lgt_activate_file_operator'(Priority, Specifier, Operator, Mode), '$lgt_activate_file_operators'(Priority, Specifier, Operators, Mode). '$lgt_activate_file_operators'(Priority, Specifier, Operator, Mode) :- '$lgt_activate_file_operator'(Priority, Specifier, Operator, Mode). '$lgt_activate_file_operator'(Priority, Specifier, Operator, compile(_,_,_)) :- '$lgt_compiler_flag'(redefined_operators, warning), ( '$lgt_iso_spec_operator'(Operator, OriginalSpecifier, OriginalPriority) ; '$lgt_logtalk_spec_operator'(Operator, OriginalSpecifier, OriginalPriority) ), '$lgt_same_operator_class'(Specifier, OriginalSpecifier), once(( Priority \== OriginalPriority ; Specifier \== OriginalSpecifier )), '$lgt_source_file_context'(File, Lines), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(redefined_operators), redefined_operator(File, Lines, op(OriginalPriority,OriginalSpecifier,Operator), op(Priority,Specifier,Operator)) ), fail. '$lgt_activate_file_operator'(Priority, Specifier, Operator, _) :- ( current_op(OriginalPriority, OriginalSpecifier, Operator), '$lgt_same_operator_class'(Specifier, OriginalSpecifier) -> assertz('$lgt_pp_global_operator_'(OriginalPriority, OriginalSpecifier, Operator)) ; true ), op(Priority, Specifier, Operator), assertz('$lgt_pp_file_operator_'(Priority, Specifier, Operator)). % '$lgt_activate_entity_operators'(+integer, +operator_specifier, +atom_or_atom_list, +scope, +atom, +pair(integer), +compilation_mode) % % activates local entity operator definitions % % any conflicting file operator is saved so that it can be restored later '$lgt_activate_entity_operators'(_, _, [], _, _, _, _) :- !. '$lgt_activate_entity_operators'(Priority, Specifier, [Operator| Operators], Scope, File, Lines, Mode) :- !, '$lgt_activate_entity_operator'(Priority, Specifier, Operator, Scope, File, Lines, Mode), '$lgt_activate_entity_operators'(Priority, Specifier, Operators, Scope, File, Lines, Mode). '$lgt_activate_entity_operators'(Priority, Specifier, Operator, Scope, File, Lines, Mode) :- '$lgt_activate_entity_operator'(Priority, Specifier, Operator, Scope, File, Lines, Mode). '$lgt_activate_entity_operator'(Priority, Specifier, Operator, _, File, Lines, compile(_,_,_)) :- '$lgt_compiler_flag'(redefined_operators, warning), ( '$lgt_iso_spec_operator'(Operator, OriginalSpecifier, OriginalPriority) ; '$lgt_logtalk_spec_operator'(Operator, OriginalSpecifier, OriginalPriority) ), '$lgt_same_operator_class'(Specifier, OriginalSpecifier), once(( Priority \== OriginalPriority ; Specifier \== OriginalSpecifier )), '$lgt_pp_entity_'(Type, Entity, _), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(redefined_operators), redefined_operator(File, Lines, Type, Entity, op(OriginalPriority,OriginalSpecifier,Operator), op(Priority,Specifier,Operator)) ), fail. '$lgt_activate_entity_operator'(Priority, Specifier, Operator, Scope, File, Lines, _) :- ( current_op(OriginalPriority, OriginalSpecifier, Operator), '$lgt_same_operator_class'(Specifier, OriginalSpecifier) -> assertz('$lgt_pp_file_operator_'(OriginalPriority, OriginalSpecifier, Operator)) ; true ), op(Priority, Specifier, Operator), assertz('$lgt_pp_entity_operator_'(Priority, Specifier, Operator, Scope, File, Lines)), '$lgt_pp_entity_'(_, Entity, _), % save entity operator property ( '$lgt_pp_runtime_clause_'('$lgt_entity_property_'(Entity, op(Priority, Specifier, Operator, p(p(p))))) -> % handle the case where there is already a public declaration for the operator true ; '$lgt_pp_runtime_clause_'('$lgt_entity_property_'(Entity, op(Priority, Specifier, Operator, Scope))) -> % duplicated operator declarations may originate from e.g. included files % or when compiling modules (as objects) that reexport other modules true ; assertz('$lgt_pp_runtime_clause_'('$lgt_entity_property_'(Entity, op(Priority, Specifier, Operator, Scope)))) ). % '$lgt_expand_file_directive_goal'(+callable, -callable) % % expands a file directive goal % % used to expand file level initialization/1 goals and conditional % compilation directive goals (if/1 and elif/1) and deal with some % special cases '$lgt_expand_file_directive_goal'(Goal, ExpandedGoal) :- '$lgt_expand_file_directive_goal'(Goal, ExpandedGoal, []). '$lgt_expand_file_directive_goal'(Goal, call(Goal), _) :- var(Goal), !. '$lgt_expand_file_directive_goal'({Goal}, Goal, _) :- !. '$lgt_expand_file_directive_goal'(Goal, ExpandedGoal, ExpandedGoals) :- '$lgt_push_if_new'(ExpandedGoals, Goal, NewExpandedGoals), '$lgt_expand_file_goal'(Goal, ExpandedGoal0), Goal \== ExpandedGoal0, !, '$lgt_expand_file_directive_goal'(ExpandedGoal0, ExpandedGoal, NewExpandedGoals). '$lgt_expand_file_directive_goal'((Goal1, Goal2), (ExpandedGoal1, ExpandedGoal2), ExpandedGoals) :- !, '$lgt_expand_file_directive_goal'(Goal1, ExpandedGoal1, ExpandedGoals), '$lgt_expand_file_directive_goal'(Goal2, ExpandedGoal2, ExpandedGoals). '$lgt_expand_file_directive_goal'((IfThen; Else), (TIf -> TThen; TElse), ExpandedGoals) :- nonvar(IfThen), IfThen = (If -> Then), !, '$lgt_expand_file_directive_goal'(If, TIf, ExpandedGoals), '$lgt_expand_file_directive_goal'(Then, TThen, ExpandedGoals), '$lgt_expand_file_directive_goal'(Else, TElse, ExpandedGoals). '$lgt_expand_file_directive_goal'((IfThen; Else), ('*->'(TIf, TThen); TElse), ExpandedGoals) :- nonvar(IfThen), IfThen = '*->'(If, Then), '$lgt_predicate_property'('*->'(_, _), built_in), !, '$lgt_expand_file_directive_goal'(If, TIf, ExpandedGoals), '$lgt_expand_file_directive_goal'(Then, TThen, ExpandedGoals), '$lgt_expand_file_directive_goal'(Else, TElse, ExpandedGoals). '$lgt_expand_file_directive_goal'((Goal1; Goal2), (ExpandedGoal1; ExpandedGoal2), ExpandedGoals) :- !, '$lgt_expand_file_directive_goal'(Goal1, ExpandedGoal0, ExpandedGoals), '$lgt_fix_disjunction_left_side'(ExpandedGoal0, ExpandedGoal1), '$lgt_expand_file_directive_goal'(Goal2, ExpandedGoal2, ExpandedGoals). '$lgt_expand_file_directive_goal'('*->'(Goal1, Goal2), '*->'(ExpandedGoal1, ExpandedGoal2), ExpandedGoals) :- '$lgt_predicate_property'('*->'(_, _), built_in), !, '$lgt_expand_file_directive_goal'(Goal1, ExpandedGoal1, ExpandedGoals), '$lgt_expand_file_directive_goal'(Goal2, ExpandedGoal2, ExpandedGoals). '$lgt_expand_file_directive_goal'((Goal1 -> Goal2), (ExpandedGoal1 -> ExpandedGoal2), ExpandedGoals) :- !, '$lgt_expand_file_directive_goal'(Goal1, ExpandedGoal1, ExpandedGoals), '$lgt_expand_file_directive_goal'(Goal2, ExpandedGoal2, ExpandedGoals). '$lgt_expand_file_directive_goal'(\+ Goal, \+ ExpandedGoal, ExpandedGoals) :- !, '$lgt_expand_file_directive_goal'(Goal, ExpandedGoal, ExpandedGoals). '$lgt_expand_file_directive_goal'(catch(Goal, Catcher, Recovery), catch(ExpandedGoal, Catcher, ExpandedRecovery), ExpandedGoals) :- !, '$lgt_expand_file_directive_goal'(Goal, ExpandedGoal, ExpandedGoals), '$lgt_expand_file_directive_goal'(Recovery, ExpandedRecovery, ExpandedGoals). % workaround lack of compliance by some backend Prolog compilers '$lgt_expand_file_directive_goal'(predicate_property(Pred, Prop), '$lgt_predicate_property'(Pred, Prop), _) :- !. % expand calls to set_logtalk_flag/2 when possible to avoid the need of runtime type-checking '$lgt_expand_file_directive_goal'(set_logtalk_flag(Flag, Value), '$lgt_set_compiler_flag'(Flag, Value), _) :- nonvar(Flag), nonvar(Value), !, '$lgt_check'(read_write_flag, Flag), '$lgt_check'(flag_value, Flag + Value). % expand calls to the logtalk_compile/1-2 and logtalk_load/1-2 predicates to % add a directory argument for default resolving of relative file paths '$lgt_expand_file_directive_goal'(logtalk_compile(Files), '$lgt_logtalk_compile'(Files, Directory, ExCtx), _) :- !, '$lgt_pp_file_paths_flags_'(_, Directory, _, _, _), '$lgt_execution_context'(ExCtx, user, user, user, user, [], []). '$lgt_expand_file_directive_goal'(logtalk_compile(Files, Flags), '$lgt_logtalk_compile'(Files, Flags, Directory, ExCtx), _) :- !, '$lgt_pp_file_paths_flags_'(_, Directory, _, _, _), '$lgt_execution_context'(ExCtx, user, user, user, user, [], []). '$lgt_expand_file_directive_goal'(logtalk_load(Files), '$lgt_logtalk_load'(Files, Directory, ExCtx), _) :- !, '$lgt_pp_file_paths_flags_'(_, Directory, _, _, _), '$lgt_execution_context'(ExCtx, user, user, user, user, [], []). '$lgt_expand_file_directive_goal'(logtalk_load(Files, Flags), '$lgt_logtalk_load'(Files, Flags, Directory, ExCtx), _) :- !, '$lgt_pp_file_paths_flags_'(_, Directory, _, _, _), '$lgt_execution_context'(ExCtx, user, user, user, user, [], []). % expand if possible calls to the logtalk_load_context/2 predicate to support % embedded applications where the compiled code may no longer be loaded using % the Logtalk runtime '$lgt_expand_file_directive_goal'(logtalk_load_context(Key, Value), true, _) :- nonvar(Key), logtalk_load_context(Key, Value), !. % when the directive is found inside an entity, use any applicable uses/2 or % use_module/2 directive; this is mainly useful when compiling Prolog modules % as objects as the user can always write a (::)/2 or (:)/2 goal instead '$lgt_expand_file_directive_goal'(Goal, Obj::Goal, _) :- '$lgt_pp_entity_'(_, _, _), '$lgt_pp_uses_predicate_'(Obj, _, Goal, _, _, _), !. '$lgt_expand_file_directive_goal'(Goal, ':'(Module,Goal), _) :- '$lgt_pp_entity_'(_, _, _), '$lgt_pp_use_module_predicate_'(Module, _, Goal, _, _, _), !. % catchall clause '$lgt_expand_file_directive_goal'(Goal, Goal, _). % '$lgt_expand_file_goal'(+callable, -callable) % % expands a goal; fails if no goal expansion hook is defined % % the callers of this predicate must ensure that a goal % is repeatedly expanded until a fixed-point is reached % % the callers must also take care of the case where the % goal is wrapped with the {}/1 control construct '$lgt_expand_file_goal'(Goal, ExpandedGoal) :- ( % source-file specific compiler hook '$lgt_pp_hook_goal_expansion_'(Goal, ExpandedGoal) -> true ; % default compiler hook '$lgt_hook_goal_expansion_'(Goal, ExpandedGoal) -> true ; % dialect specific expansion '$lgt_prolog_goal_expansion'(Goal, ExpandedGoal) -> '$lgt_prolog_goal_expansion_portability_warnings'(Goal, ExpandedGoal) ; % no compiler hook defined fail ), % the following check means that an expanded goal is checked twice but that % allows us to distinguish between user errors and goal-expansion errors '$lgt_check'(callable, ExpandedGoal, goal_expansion(Goal, ExpandedGoal)). '$lgt_prolog_goal_expansion_portability_warnings'(Goal, ExpandedGoal) :- ( '$lgt_compiler_flag'(portability, warning) -> '$lgt_source_file_context'(File, Lines), '$lgt_increment_compiling_warnings_counter', ( '$lgt_pp_entity_'(Type, Entity, _) -> '$lgt_print_message'( warning(portability), prolog_dialect_goal_expansion(File, Lines, Type, Entity, Goal, ExpandedGoal) ) ; '$lgt_print_message'( warning(portability), prolog_dialect_goal_expansion(File, Lines, Goal, ExpandedGoal) ) ) ; true ). % '$lgt_push_if_new'(@term, @callable, -list) % % auxiliary predicate to prevent going into an infinite loop when % goal-expansion results in a goal that contains the expanded goal % % calls to this predicate fail if the goal about to be expanded was % the result of a previous goal expansion (tested using term equality) '$lgt_push_if_new'(ExpandedGoals, Pred, NewExpandedGoals) :- var(ExpandedGoals), !, NewExpandedGoals = [Pred]. '$lgt_push_if_new'(ExpandedGoals, Pred, _) :- '$lgt_member_var'(Pred, ExpandedGoals), !, fail. '$lgt_push_if_new'(ExpandedGoals, Pred, [Pred| ExpandedGoals]). % '$lgt_compile_include_file_terms'(@list(term), +atom, +compilation_context) % % compiles a list of file terms (directives, clauses, or grammar rules) % found in an included file '$lgt_compile_include_file_terms'([Term-_| Terms], File, Ctx) :- '$lgt_pp_cc_skipping_', % we're performing conditional compilation and skipping terms ... \+ '$lgt_is_conditional_compilation_directive'(Term), % ... except for conditional compilation directives !, '$lgt_compile_include_file_terms'(Terms, File, Ctx). '$lgt_compile_include_file_terms'([Term-sd(VariableNames,Singletons,Lines)| Terms], File, Ctx) :- retractall('$lgt_pp_term_source_data_'(_, _, _, _, _)), assertz('$lgt_pp_term_source_data_'(Term, VariableNames, Singletons, File, Lines)), '$lgt_check'(nonvar, Term, term), % only the compilation context mode should be shared between different terms '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, _, _, _, _, Mode, _, _, _), '$lgt_comp_ctx'(NewCtx, _, _, _, _, _, _, _, _, _, _, Mode, _, Lines, _), '$lgt_compile_file_term'(Term, NewCtx), '$lgt_compile_include_file_terms'(Terms, File, Ctx). '$lgt_compile_include_file_terms'([], _, _). % '$lgt_compile_file_term'(@nonvar, +compilation_context) % % compiles a source file term (clause, directive, or grammar rule) % % we allow non-callable terms to be term-expanded; only if that fails % we throw an error '$lgt_compile_file_term'(Term, Ctx) :- % we must unify any parameter variables used in the term with % the corresponding entity parameters before any expansion '$lgt_unify_parameter_variables'(Term, Ctx), ( Term = {_} -> % bypass control construct; skip term-expansion '$lgt_compile_expanded_term'(Term, Term, Ctx) ; '$lgt_pp_hook_term_expansion_'(Term, ExpandedTerms) -> % source-file specific compiler hook '$lgt_compile_expanded_terms'(ExpandedTerms, Term, Ctx) ; '$lgt_hook_term_expansion_'(Term, ExpandedTerms) -> % default compiler hook '$lgt_compile_expanded_terms'(ExpandedTerms, Term, Ctx) ; '$lgt_prolog_term_expansion'(Term, ExpandedTerms) -> % dialect specific expansion '$lgt_prolog_term_expansion_portability_warnings'(Term, ExpandedTerms), '$lgt_compile_expanded_terms'(ExpandedTerms, Term, Ctx) ; % no compiler hook defined '$lgt_compile_non_expanded_term'(Term, Ctx) ). '$lgt_prolog_term_expansion_portability_warnings'(Term, ExpandedTerms) :- ( Term \== ExpandedTerms, '$lgt_compiler_flag'(portability, warning) -> '$lgt_source_file_context'(File, Lines), '$lgt_increment_compiling_warnings_counter', ( '$lgt_pp_entity_'(Type, Entity, _) -> '$lgt_print_message'( warning(portability), prolog_dialect_term_expansion(File, Lines, Type, Entity, Term, ExpandedTerms) ) ; '$lgt_print_message'( warning(portability), prolog_dialect_term_expansion(File, Lines, Term, ExpandedTerms) ) ) ; true ). % '$lgt_compile_expanded_terms'(@list(term), @term, +compilation_context) % '$lgt_compile_expanded_terms'(@term, @term, +compilation_context) % % compiles the expanded terms (which can be a list of terms); % the second argument is the original term and is used for more % informative exception terms in case of error % % note that the clause order ensures that instantiation errors will be % caught by the call to the '$lgt_compile_expanded_term'/3 predicate '$lgt_compile_expanded_terms'([ExpandedTerm| ExpandedTerms], Term, Ctx) :- !, '$lgt_compile_expanded_term'(ExpandedTerm, Term, Ctx), ( ExpandedTerm \== (:- end_object), ExpandedTerm \== (:- end_protocol), ExpandedTerm \== (:- end_category) -> % ensure that only the compilation context mode and the entity prefix are % shared between different terms but keep the current term position '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, Prefix, _, _, _, Mode, _, Lines, _), '$lgt_comp_ctx'(NewCtx, _, _, _, _, _, _, Prefix, _, _, _, Mode, _, Lines, _) ; % share only the compilation context mode and the current term position '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, _, _, _, _, Mode, _, Lines, _), '$lgt_comp_ctx'(NewCtx, _, _, _, _, _, _, _, _, _, _, Mode, _, Lines, _) ), '$lgt_compile_expanded_terms'(ExpandedTerms, Term, NewCtx). '$lgt_compile_expanded_terms'([], _, _) :- !. '$lgt_compile_expanded_terms'(ExpandedTerm, Term, Ctx) :- '$lgt_compile_expanded_term'(ExpandedTerm, Term, Ctx). % '$lgt_compile_expanded_term'(@term, @term, +compilation_context) % % compiles a source file term (a clause, directive, or grammar rule); % the second argument is the original term and is used for more % informative exception terms in case of error '$lgt_compile_expanded_term'((-), Term, _) :- % catch variables throw(error(instantiation_error, term_expansion(Term, _))). '$lgt_compile_expanded_term'(begin_of_file, _, _) :- !. '$lgt_compile_expanded_term'(end_of_file, _, Ctx) :- '$lgt_pp_module_'(Module), !, % module definitions start with an opening module/1-2 directive and are assumed % to end at the end of a source file; there is no module closing directive; set % the initial compilation context and the position for compiling the end_of_file term '$lgt_pp_referenced_object_'(Module, _, Start-_), '$lgt_comp_ctx_lines'(Ctx, _-End), assertz('$lgt_pp_entity_lines_'(Module, Start-End)), '$lgt_second_stage'(object, Module, Ctx), '$lgt_print_message'(silent(compiling), compiled_entity(module, Module)). '$lgt_compile_expanded_term'(end_of_file, Term, _) :- '$lgt_pp_entity_'(Type, _, _), % unexpected end-of-file while compiling an entity ( Type == object -> throw(error(existence_error(directive, end_object/0), term_expansion(Term, end_of_file))) ; Type == protocol -> throw(error(existence_error(directive, end_protocol/0), term_expansion(Term, end_of_file))) ; % Type == category, throw(error(existence_error(directive, end_category/0), term_expansion(Term, end_of_file))) ). '$lgt_compile_expanded_term'(end_of_file, Term, _) :- '$lgt_pp_cc_if_found_'(_), % unexpected end-of-file while compiling a conditional compilation block throw(error(existence_error(directive, endif/0), term_expansion(Term, end_of_file))). '$lgt_compile_expanded_term'(end_of_file, _, _) :- !. '$lgt_compile_expanded_term'({ExpandedTerm}, Term, _) :- % bypass control construct; expanded term is final !, ( callable(ExpandedTerm) -> ( '$lgt_pp_term_source_data_'(Term, VariableNames, Singletons, File, Lines) -> SourceData = sd(Term, VariableNames, Singletons, File, Lines) ; SourceData = nil, Lines = '-'(-1, -1) ), ( '$lgt_pp_entity_'(_, _, _) -> % ensure that the relative order of the entity terms is kept assertz('$lgt_pp_entity_term_'({ExpandedTerm}, SourceData, Lines)) ; % non-entity terms assertz('$lgt_pp_prolog_term_'(ExpandedTerm, Lines)) ) ; var(ExpandedTerm) -> throw(error(instantiation_error, term_expansion(Term, {ExpandedTerm}))) ; throw(error(type_error(callable, Term), term_expansion(Term, {ExpandedTerm}))) ). '$lgt_compile_expanded_term'((Head :- Body), _, Ctx) :- !, '$lgt_comp_ctx_term'(Ctx, (Head :- Body)), '$lgt_compile_clause'((Head :- Body), Ctx). '$lgt_compile_expanded_term'((:- Directive), _, Ctx) :- !, '$lgt_comp_ctx_term'(Ctx, (:- Directive)), '$lgt_compile_directive'(Directive, Ctx). '$lgt_compile_expanded_term'((Head --> Body), _, Ctx) :- !, '$lgt_comp_ctx_term'(Ctx, (Head --> Body)), '$lgt_compile_grammar_rule'((Head --> Body), Ctx). '$lgt_compile_expanded_term'(ExpandedTerm, Term, Ctx) :- ( callable(ExpandedTerm) -> % fact '$lgt_comp_ctx_term'(Ctx, ExpandedTerm), '$lgt_compile_clause'(ExpandedTerm, Ctx) ; throw(error(type_error(callable, ExpandedTerm), term_expansion(Term, ExpandedTerm))) ). % '$lgt_compile_non_expanded_term'(@nonvar, +compilation_context) % % compiles a source file term (a clause, directive, or grammar rule); % the second argument is the original term and is used for more % informative exception terms in case of error '$lgt_compile_non_expanded_term'(begin_of_file, _) :- !. '$lgt_compile_non_expanded_term'(end_of_file, Ctx) :- '$lgt_pp_module_'(Module), !, % module definitions start with an opening module/1-2 directive and are assumed % to end at the end of a source file; there is no module closing directive; set % the initial compilation context and the position for compiling the end_of_file term '$lgt_pp_referenced_object_'(Module, _, Start-_), '$lgt_comp_ctx_lines'(Ctx, _-End), assertz('$lgt_pp_entity_lines_'(Module, Start-End)), '$lgt_second_stage'(object, Module, Ctx), '$lgt_print_message'(silent(compiling), compiled_entity(module, Module)). '$lgt_compile_non_expanded_term'(end_of_file, _) :- '$lgt_pp_entity_'(Type, _, _), % unexpected end-of-file while compiling an entity ( Type == object -> throw(error(existence_error(directive, end_object/0), term(end_of_file))) ; Type == protocol -> throw(error(existence_error(directive, end_protocol/0), term(end_of_file))) ; % Type == category, throw(error(existence_error(directive, end_category/0), term(end_of_file))) ). '$lgt_compile_non_expanded_term'(end_of_file, _) :- '$lgt_pp_cc_if_found_'(_), % unexpected end-of-file while compiling a conditional compilation block throw(error(existence_error(directive, endif/0), term(end_of_file))). '$lgt_compile_non_expanded_term'(end_of_file, _) :- !. '$lgt_compile_non_expanded_term'({Term}, _) :- % bypass control construct; term is final !, ( callable(Term) -> ( '$lgt_pp_term_source_data_'({Term}, VariableNames, Singletons, File, Lines) -> SourceData = sd(Term, VariableNames, Singletons, File, Lines) ; SourceData = nil, Lines = '-'(-1, -1) ), ( '$lgt_pp_entity_'(_, _, _) -> % ensure that the relative order of the entity terms is kept assertz('$lgt_pp_entity_term_'({Term}, SourceData, Lines)) ; % non-entity terms assertz('$lgt_pp_prolog_term_'(Term, Lines)) ) ; var(Term) -> throw(error(instantiation_error, term({Term}))) ; throw(error(type_error(callable, Term), term({Term}))) ). '$lgt_compile_non_expanded_term'((Head :- Body), Ctx) :- !, '$lgt_comp_ctx_term'(Ctx, (Head :- Body)), '$lgt_compile_clause'((Head :- Body), Ctx). '$lgt_compile_non_expanded_term'((:- Directive), Ctx) :- !, '$lgt_comp_ctx_term'(Ctx, (:- Directive)), '$lgt_compile_directive'(Directive, Ctx). '$lgt_compile_non_expanded_term'((Head --> Body), Ctx) :- !, '$lgt_comp_ctx_term'(Ctx, (Head --> Body)), '$lgt_compile_grammar_rule'((Head --> Body), Ctx). '$lgt_compile_non_expanded_term'(Term, Ctx) :- ( callable(Term) -> '$lgt_compile_clause'(Term, Ctx) ; throw(error(type_error(callable, Term), term(Term))) ). % '$lgt_compile_runtime_include_file_terms'(@list(term), +atom) % % compiles a list of runtime terms (clauses, directives, or grammar rules) % found in an included file % % note that the clause order ensures that instantiation errors will be caught % by the call to the '$lgt_compile_runtime_term'/2 predicate '$lgt_compile_runtime_include_file_terms'([Term-_| Terms], File) :- '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, _, _, _, _, runtime, _, '-'(-1, -1), _), '$lgt_compile_runtime_term'(Term, Ctx), '$lgt_compile_runtime_include_file_terms'(Terms, File). '$lgt_compile_runtime_include_file_terms'([], _). % '$lgt_compile_runtime_terms'(@list(term)) % % compiles a list of runtime terms (clauses, directives, or grammar rules) % % note that the clause order ensures that instantiation errors will be caught % by the call to the '$lgt_compile_runtime_term'/2 predicate '$lgt_compile_runtime_terms'([Term| Terms]) :- '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, _, _, _, _, runtime, _, '-'(-1, -1), _), '$lgt_compile_runtime_term'(Term, Ctx), '$lgt_compile_runtime_terms'(Terms). '$lgt_compile_runtime_terms'([]). % '$lgt_compile_runtime_term'(@term, +compilation_context) % % compiles a runtime term (a clause, directive, or grammar rule) '$lgt_compile_runtime_term'((-), _) :- % catch variables throw(error(instantiation_error, term)). '$lgt_compile_runtime_term'(begin_of_file, _) :- !. '$lgt_compile_runtime_term'(end_of_file, _) :- !. '$lgt_compile_runtime_term'({Term}, _) :- % bypass control construct; term is final !, ( callable(Term) -> assertz('$lgt_pp_entity_term_'({Term}, nil, '-'(-1, -1))) ; var(Term) -> throw(error(instantiation_error, term({Term}))) ; throw(error(type_error(callable, Term), term({Term}))) ). '$lgt_compile_runtime_term'((Head :- Body), Ctx) :- !, '$lgt_compile_clause'((Head :- Body), Ctx). '$lgt_compile_runtime_term'((:- Directive), Ctx) :- !, '$lgt_compile_directive'(Directive, Ctx). '$lgt_compile_runtime_term'((Head --> Body), Ctx) :- !, '$lgt_compile_grammar_rule'((Head --> Body), Ctx). '$lgt_compile_runtime_term'(Term, _) :- \+ callable(Term), throw(error(type_error(callable, Term), term(Term))). '$lgt_compile_runtime_term'(Term, Ctx) :- % fact '$lgt_compile_clause'(Term, Ctx). % '$lgt_compile_directive'(@term, +compilation_context) % % compiles a directive '$lgt_compile_directive'((-), _) :- % catch variables throw(error(instantiation_error, directive(_))). % conditional compilation directives '$lgt_compile_directive'(if(Goal), Ctx) :- ( Goal = {UserGoal} -> % final goal '$lgt_check'(callable, UserGoal, directive(if(Goal))), fail ; '$lgt_check'(callable, Goal, directive(if(Goal))), % only expand goals when compiling a source file '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_expand_file_directive_goal'(Goal, ExpandedGoal), Goal \== ExpandedGoal, !, '$lgt_compile_directive'(if({ExpandedGoal}), Ctx) ). '$lgt_compile_directive'(if(Goal), _) :- '$lgt_pp_cc_mode_'(Value), % not top-level if/1 directive !, asserta('$lgt_pp_cc_if_found_'(Goal)), ( Value == ignore -> % another if ... endif to ignore asserta('$lgt_pp_cc_mode_'(ignore)) ; Value == seek_else -> % we're looking for an else; ignore this if ... endif asserta('$lgt_pp_cc_mode_'(ignore)) ; Value == skip_all -> asserta('$lgt_pp_cc_mode_'(ignore)) ; % Value == skip_else, ( ( Goal = {UserGoal} -> catch(UserGoal, Error, '$lgt_compiler_error_handler'(Error)) ; catch(Goal, Error, '$lgt_compiler_error_handler'(Error)) ) -> asserta('$lgt_pp_cc_mode_'(skip_else)) ; asserta('$lgt_pp_cc_mode_'(seek_else)), retractall('$lgt_pp_cc_skipping_'), assertz('$lgt_pp_cc_skipping_') ) ). '$lgt_compile_directive'(if(Goal), _) :- % top-level if !, asserta('$lgt_pp_cc_if_found_'(Goal)), ( ( Goal = {UserGoal} -> catch(UserGoal, Error, '$lgt_compiler_error_handler'(Error)) ; catch(Goal, Error, '$lgt_compiler_error_handler'(Error)) ) -> asserta('$lgt_pp_cc_mode_'(skip_else)) ; asserta('$lgt_pp_cc_mode_'(seek_else)), retractall('$lgt_pp_cc_skipping_'), assertz('$lgt_pp_cc_skipping_') ). '$lgt_compile_directive'(elif(Goal), _) :- \+ '$lgt_pp_cc_if_found_'(_), throw(error(existence_error(directive, if/1), directive(elif(Goal)))). '$lgt_compile_directive'(elif(Goal), Ctx) :- ( Goal = {UserGoal} -> % final goal '$lgt_check'(callable, UserGoal, directive(elif(Goal))), fail ; '$lgt_check'(callable, Goal, directive(elif(Goal))), % only expand goals when compiling a source file '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_expand_file_directive_goal'(Goal, ExpandedGoal), Goal \== ExpandedGoal, !, '$lgt_compile_directive'(elif({ExpandedGoal}), Ctx) ). '$lgt_compile_directive'(elif(Goal), _) :- '$lgt_pp_cc_mode_'(Mode), ( Mode == ignore -> % we're inside an if ... endif that we're ignoring true ; Mode == skip_else -> % the corresponding if is true so we must skip this elif retractall('$lgt_pp_cc_skipping_'), assertz('$lgt_pp_cc_skipping_'), retract('$lgt_pp_cc_mode_'(_)), asserta('$lgt_pp_cc_mode_'(skip_all)) ; Mode == skip_all -> true ; % Mode == seek_else, % the corresponding if is false retract('$lgt_pp_cc_mode_'(_)), ( ( Goal = {UserGoal} -> catch(UserGoal, Error, '$lgt_compiler_error_handler'(Error)) ; catch(Goal, Error, '$lgt_compiler_error_handler'(Error)) ) -> retractall('$lgt_pp_cc_skipping_'), asserta('$lgt_pp_cc_mode_'(skip_else)) ; asserta('$lgt_pp_cc_mode_'(seek_else)) ) ), !. '$lgt_compile_directive'(else, _) :- \+ '$lgt_pp_cc_if_found_'(_), throw(error(existence_error(directive, if/1), directive(else))). '$lgt_compile_directive'(else, _) :- '$lgt_pp_cc_mode_'(Mode), ( Mode == ignore -> % we're inside an if ... endif that we're ignoring true ; Mode == skip_else -> % the corresponding if is true so we must skip this else % and any enclose if ... endif retractall('$lgt_pp_cc_skipping_'), assertz('$lgt_pp_cc_skipping_'), retract('$lgt_pp_cc_mode_'(_)), asserta('$lgt_pp_cc_mode_'(skip_all)) ; Mode == skip_all -> true ; % Mode == seek_else -> % the corresponding if is false retract('$lgt_pp_cc_mode_'(_)), asserta('$lgt_pp_cc_mode_'(compile)), retractall('$lgt_pp_cc_skipping_') ), !. '$lgt_compile_directive'(endif, _) :- \+ '$lgt_pp_cc_if_found_'(_), throw(error(existence_error(directive, if/1), directive(endif))). '$lgt_compile_directive'(endif, _) :- retract('$lgt_pp_cc_if_found_'(_)), retract('$lgt_pp_cc_mode_'(Mode)), ( Mode \== ignore -> retractall('$lgt_pp_cc_skipping_') ; \+ '$lgt_pp_cc_if_found_'(_) -> retractall('$lgt_pp_cc_skipping_'), retractall('$lgt_pp_cc_mode_'(_)) ; true ), !. % remaining directives '$lgt_compile_directive'(Directive, Ctx) :- \+ '$lgt_pp_entity_'(_, _, _), % not compiling an entity \+ '$lgt_logtalk_opening_directive'(Directive), % directive occurs before opening entity directive !, ( '$lgt_logtalk_closing_directive'(Directive) -> % closing entity directive occurs before the opening entity directive; % the opening directive is probably missing or misspelt ( Directive == end_object -> throw(error(existence_error(directive, object/1), directive(Directive))) ; Directive == end_protocol -> throw(error(existence_error(directive, protocol/1), directive(Directive))) ; % Directive == end_category -> throw(error(existence_error(directive, category/1), directive(Directive))) ) ; % compile it as a source file-level directive catch( '$lgt_compile_file_directive'(Directive, Ctx), Error, throw(error(Error, directive(Directive))) ) ). '$lgt_compile_directive'(Directive, Ctx) :- '$lgt_logtalk_directive'(Directive), !, catch( '$lgt_compile_logtalk_directive'(Directive, Ctx), Error, throw(error(Error, directive(Directive))) ). '$lgt_compile_directive'(Directive, Ctx) :- '$lgt_prolog_meta_directive'(Directive, Meta), % as defined in the Prolog adapter files !, ( '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(portability, warning) -> '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(portability), compiling_proprietary_prolog_directive(File, Lines, Type, Entity, Directive) ) ; true ), % save the source data information for use in the second compiler stage % (where it might be required by calls to the logtalk_load_context/2 % predicate during goal expansion) ( '$lgt_pp_term_source_data_'(Term, VariableNames, Singletons, File, Lines) -> SourceData = sd(Term, VariableNames, Singletons, File, Lines) ; SourceData = nil, Lines = '-'(-1, -1) ), assertz('$lgt_pp_entity_meta_directive_'(directive(Directive, Meta), SourceData, Lines)). '$lgt_compile_directive'(Directive, Ctx) :- '$lgt_pp_module_'(Current), % we're compiling a module as an object Directive \= use_module(_), Directive \= ensure_loaded(_), % but not unsupported directives that the backend Prolog compiler adapter % file failed to expand into supported use_module/2 directives ( '$lgt_pp_defines_predicate_'(Directive, _, _, _, _, _) ; '$lgt_pp_uses_predicate_'(_, _, Directive, _, _, _) % directive is a query for a locally defined predicate ; '$lgt_pp_use_module_predicate_'(_, _, Directive, _, _, _) % or a predicate referenced in a use_module/2 directive ; '$lgt_built_in_predicate'(Directive) % or a built-in predicate ; \+ '$lgt_control_construct'(Directive), '$lgt_find_visible_module_predicate'(Current, Module, Directive), % or an implicit call to a module predicate with a missing use_module/2 directive; % in practice, this only occurs in backend systems with an autoload mechanism functor(Directive, Functor, Arity), '$lgt_comp_ctx_mode'(Ctx, Mode), '$lgt_remember_missing_use_module_directive'(Mode, Module, Functor/Arity) ), !, % compile query as an initialization goal ( '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(portability, warning) -> '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(portability), compiling_query_as_initialization_goal(File, Lines, Type, Entity, Directive) ) ; true ), '$lgt_compile_logtalk_directive'(initialization(Directive), Ctx). '$lgt_compile_directive'(encoding(Encoding), Ctx) :- '$lgt_source_file_context'(Path, _), '$lgt_pp_runtime_clause_'('$lgt_included_file_'(Path, _, _, _)), % encoding/1 directives may be used in included % files but not as entity directives !, '$lgt_compile_file_directive'(encoding(Encoding), Ctx). '$lgt_compile_directive'(Directive, _) :- functor(Directive, Functor, Arity), throw(error(domain_error(directive, Functor/Arity), directive(Directive))). % '$lgt_compile_file_directive'(@nonvar, +compilation_context) % % compiles file-level directives, i.e. directives that are not encapsulated in a Logtalk % entity; error-checking is delegated in most cases to the backend Prolog compiler '$lgt_compile_file_directive'(encoding(Encoding), Ctx) :- !, '$lgt_source_file_context'(File, Lines), ( '$lgt_pp_file_encoding_'(File, Encoding, _, Line), % encoding/1 directive already found and processed ... '$lgt_comp_ctx_lines'(Ctx, Line-_) -> % ... same encoding/1 directive that was found and processed true ; % out-of-place encoding/1 directive, which must be the first term in a source file '$lgt_compiler_flag'(encodings, silent) -> true ; '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'(warning(encodings), ignored_encoding_directive(File, Lines)) ). '$lgt_compile_file_directive'(ensure_loaded(FileSpec), _) :- !, % perform basic error checking '$lgt_check'(ground, FileSpec), % try to expand the file spec as the directive may be found in an included file '$lgt_expand_module_file_specification'(FileSpec, ExpandedFile), % try to call ensure_loaded/1 as a built-in predicate but ignore any errors catch(ensure_loaded(ExpandedFile), _, true), '$lgt_pp_term_source_data_'(_, _, _, _, Lines), assertz('$lgt_pp_prolog_term_'((:- ensure_loaded(ExpandedFile)), Lines)). '$lgt_compile_file_directive'(use_module(FileSpec), _) :- '$lgt_prolog_feature'(modules, unsupported), throw(error(domain_error(directive, use_module/1), directive(use_module(FileSpec)))). '$lgt_compile_file_directive'(use_module(FileSpec), _) :- !, % perform basic error checking '$lgt_check'(ground, FileSpec), % try to expand the file spec as the directive may be found in an included file '$lgt_expand_module_file_specification'(FileSpec, ExpandedFile), % try to call use_module/1 as a built-in predicate but ignore any errors catch(use_module(ExpandedFile), _, true), '$lgt_pp_term_source_data_'(_, _, _, _, Lines), assertz('$lgt_pp_prolog_term_'((:- use_module(ExpandedFile)), Lines)). '$lgt_compile_file_directive'(use_module(FileSpec, Imports), _) :- '$lgt_prolog_feature'(modules, unsupported), throw(error(domain_error(directive, use_module/2), directive(use_module(FileSpec, Imports)))). '$lgt_compile_file_directive'(use_module(FileSpec, Imports), _) :- !, % perform basic error checking '$lgt_check'(ground, FileSpec), '$lgt_check'(ground, Imports), % try to expand the file spec as the directive may be found in an included file '$lgt_expand_module_file_specification'(FileSpec, ExpandedFile), % try to call use_module/2 as a built-in predicate but ignore any errors catch(use_module(ExpandedFile, Imports), _, true), '$lgt_pp_term_source_data_'(_, _, _, _, Lines), assertz('$lgt_pp_prolog_term_'((:- use_module(ExpandedFile, Imports)), Lines)). % handling of this Prolog directive is necessary to % support the Logtalk term-expansion mechanism '$lgt_compile_file_directive'(include(File), Ctx) :- !, % read the file terms for compilation '$lgt_comp_ctx_mode'(Ctx, Mode), '$lgt_read_file_to_terms'(File, Directory, Path, Terms, Mode), % save the dependency in the main file to support make '$lgt_pp_file_paths_flags_'(MainBasename, MainDirectory, _, _, _), '$lgt_file_modification_time'(Path, TimeStamp), assertz('$lgt_pp_runtime_clause_'('$lgt_included_file_'(Path, MainBasename, MainDirectory, TimeStamp))), % save loading stack to deal with failed compilation retractall('$lgt_file_loading_stack_'(Path, Directory)), asserta('$lgt_file_loading_stack_'(Path, Directory)), % compile the included file terms catch( '$lgt_compile_include_file_terms'(Terms, Path, Ctx), Error, (retract('$lgt_file_loading_stack_'(Path, Directory)), throw(Error)) ), retractall('$lgt_file_loading_stack_'(Path, Directory)). '$lgt_compile_file_directive'(initialization(Goal), Ctx) :- !, % perform basic error checking '$lgt_check'(callable, Goal), % initialization directives are collected and moved to the end of file % to minimize compatibility issues with backend Prolog compilers '$lgt_source_file_context'(_File, Lines), ( Goal = {UserGoal} -> % final goal '$lgt_check'(callable, UserGoal), assertz('$lgt_pp_file_initialization_'(Goal, Lines)) ; '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), % goals are only expanded when compiling a source file '$lgt_expand_file_directive_goal'(Goal, ExpandedGoal), Goal \== ExpandedGoal -> assertz('$lgt_pp_file_initialization_'(ExpandedGoal, Lines)) ; assertz('$lgt_pp_file_initialization_'(Goal, Lines)) ). '$lgt_compile_file_directive'(op(Priority, Specifier, Operators), Ctx) :- !, '$lgt_check'(operator_specification, op(Priority, Specifier, Operators)), '$lgt_comp_ctx_mode'(Ctx, Mode), '$lgt_activate_file_operators'(Priority, Specifier, Operators, Mode), '$lgt_pp_term_source_data_'(_, _, _, _, Lines), assertz('$lgt_pp_prolog_term_'((:- op(Priority, Specifier, Operators)), Lines)). '$lgt_compile_file_directive'(set_logtalk_flag(Name, Value), _) :- !, '$lgt_check'(read_write_flag, Name), '$lgt_check'(flag_value, Name+Value), % local scope (restricted to the source file being compiled) Flag =.. [Name, Value], '$lgt_set_compiler_flags'([Flag]). '$lgt_compile_file_directive'(set_prolog_flag(Flag, Value), Ctx) :- !, % perform basic error and portability checking '$lgt_compile_body'(set_prolog_flag(Flag, Value), _, _, _, Ctx), % require a bound value '$lgt_check'(nonvar, Value), % setting the flag during compilation may or may not work as expected % depending on the flag and on the backend Prolog compiler set_prolog_flag(Flag, Value), % we also copy the directive to the generated intermediate Prolog file '$lgt_pp_term_source_data_'(_, _, _, _, Lines), assertz('$lgt_pp_prolog_term_'((:- set_prolog_flag(Flag, Value)), Lines)). '$lgt_compile_file_directive'(multifile(Preds), _) :- % perform basic error checking '$lgt_flatten_to_list'(Preds, PredsFlatted), '$lgt_check_file_predicate_directive_arguments'(PredsFlatted, (multifile)), fail. '$lgt_compile_file_directive'(dynamic(Preds), _) :- % perform basic error checking '$lgt_flatten_to_list'(Preds, PredsFlatted), '$lgt_check_file_predicate_directive_arguments'(PredsFlatted, (dynamic)), fail. '$lgt_compile_file_directive'(discontiguous(Preds), _) :- % perform basic error checking '$lgt_flatten_to_list'(Preds, PredsFlatted), '$lgt_check_file_predicate_directive_arguments'(PredsFlatted, (discontiguous)), fail. '$lgt_compile_file_directive'(Directive, Ctx) :- '$lgt_logtalk_built_in_predicate'(Directive, _), % Logtalk built-in predicate being used as a directive !, % directive will be copied to the generated Prolog file '$lgt_pp_term_source_data_'(_, _, _, File, Lines), assertz('$lgt_pp_prolog_term_'((:- Directive), Lines)), ( '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)) -> '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'(warning(portability), logtalk_built_in_predicate_as_directive(File, Lines, Directive)) ; true ). '$lgt_compile_file_directive'(Directive, Ctx) :- ( Directive = {_} ; Directive = [_| _] ), % assume Logtalk or Prolog top-level shortcut being used as a directive !, % directive will be copied to the generated Prolog file '$lgt_pp_term_source_data_'(_, _, _, File, Lines), assertz('$lgt_pp_prolog_term_'((:- Directive), Lines)), ( '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)) -> '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'(warning(portability), top_level_shortcut_as_directive(File, Lines, Directive)) ; true ). '$lgt_compile_file_directive'(Directive, Ctx) :- % directive will be copied to the generated Prolog file '$lgt_pp_term_source_data_'(_, _, _, File, Lines), assertz('$lgt_pp_prolog_term_'((:- Directive), Lines)), % report a possible portability issue if warranted ( '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(portability, warning), \+ '$lgt_file_directive'(Directive) -> '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'(warning(portability), non_standard_file_directive(File, Lines, Directive)) ; true ). % auxiliary predicate for performing basic error checking of file level % predicate directive arguments '$lgt_check_file_predicate_directive_arguments'([Pred| Preds], Property) :- !, '$lgt_check_file_predicate_directive_argument'(Pred, Property), '$lgt_check_file_predicate_directive_arguments'(Preds, Property). '$lgt_check_file_predicate_directive_arguments'([], _). '$lgt_check_file_predicate_directive_argument'(Obj::Pred, Property) :- % Logtalk entity predicates must be defined within an entity but be % sure there aren't instantiation or type errors in the directive !, '$lgt_check'(object_identifier, Obj), '$lgt_check'(predicate_or_non_terminal_indicator, Pred), throw(permission_error(declare, Property, Obj::Pred)). '$lgt_check_file_predicate_directive_argument'(':'(Module,Pred), _) :- !, '$lgt_check'(module_identifier, Module), '$lgt_check'(predicate_or_non_terminal_indicator, Pred). '$lgt_check_file_predicate_directive_argument'(Pred, _) :- '$lgt_check'(predicate_or_non_terminal_indicator, Pred). '$lgt_expand_module_file_specification'(FileSpec, ExpandedFile) :- ( atom(FileSpec), % try to expand to an existing Prolog file '$lgt_source_file_name'(FileSpec, [], _, _, Extension, ExpandedFile), '$lgt_file_extension'(prolog, Extension), '$lgt_file_exists'(ExpandedFile) -> true ; % otherwise try the file spec as-is ExpandedFile = FileSpec ). % '$lgt_compile_logtalk_directives'(+list(term), +compilation_context) % % compiles a list of Logtalk directives when dynamically creating an entity '$lgt_compile_logtalk_directives'([Directive| Directives], Ctx) :- ( var(Directive) -> throw(instantiation_error) ; '$lgt_logtalk_directive'(Directive) -> '$lgt_compile_logtalk_directive'(Directive, Ctx), % only the compilation context mode and lines should be shared between different directives '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, _, _, _, _, Mode, _, Lines, _), '$lgt_comp_ctx'(NewCtx, _, _, _, _, _, _, _, _, _, _, Mode, _, Lines, _), '$lgt_compile_logtalk_directives'(Directives, NewCtx) ; '$lgt_prolog_meta_directive'(Directive, _) -> '$lgt_compile_directive'(Directive, Ctx) ; functor(Directive, Functor, Arity), throw(domain_error(directive, Functor/Arity)) ). '$lgt_compile_logtalk_directives'([], _). % '$lgt_compile_logtalk_directive'(@term, +compilation_context) % % compiles a Logtalk directive and its (possibly empty) list of arguments '$lgt_compile_logtalk_directive'((-), _) :- % catch variables throw(instantiation_error). '$lgt_compile_logtalk_directive'(include(File), Ctx) :- % read the file terms for compilation '$lgt_comp_ctx_mode'(Ctx, Mode), '$lgt_read_file_to_terms'(File, Directory, Path, Terms, Mode), % save the dependency in the main file to support make if compiling a source file ( Mode == runtime -> true ; '$lgt_pp_file_paths_flags_'(MainBasename, MainDirectory, _, _, _), '$lgt_file_modification_time'(Path, TimeStamp), assertz('$lgt_pp_runtime_clause_'('$lgt_included_file_'(Path, MainBasename, MainDirectory, TimeStamp))) ), % save loading stack to deal with failed compilation retractall('$lgt_file_loading_stack_'(Path, Directory)), asserta('$lgt_file_loading_stack_'(Path, Directory)), % compile the included file terms catch( ( Mode == runtime -> '$lgt_compile_runtime_include_file_terms'(Terms, Path) ; '$lgt_compile_include_file_terms'(Terms, Path, Ctx) ), Error, (retract('$lgt_file_loading_stack_'(Path, Directory)), throw(Error)) ), retractall('$lgt_file_loading_stack_'(Path, Directory)). % object opening and closing directives '$lgt_compile_logtalk_directive'(object(Obj), Ctx) :- '$lgt_compile_logtalk_directive'(object_(Obj, []), Ctx). '$lgt_compile_logtalk_directive'(object(Obj, Relation), Ctx) :- '$lgt_compile_logtalk_directive'(object_(Obj, [Relation]), Ctx). '$lgt_compile_logtalk_directive'(object(Obj, Relation1, Relation2), Ctx) :- '$lgt_compile_logtalk_directive'(object_(Obj, [Relation1, Relation2]), Ctx). '$lgt_compile_logtalk_directive'(object(Obj, Relation1, Relation2, Relation3), Ctx) :- '$lgt_compile_logtalk_directive'(object_(Obj, [Relation1, Relation2, Relation3]), Ctx). '$lgt_compile_logtalk_directive'(object(Obj, Relation1, Relation2, Relation3, Relation4), Ctx) :- '$lgt_compile_logtalk_directive'(object_(Obj, [Relation1, Relation2, Relation3, Relation4]), Ctx). % auxiliary predicate to compile all variants to the object opening directive '$lgt_compile_logtalk_directive'(object_(Obj, Relations), Ctx) :- ( var(Obj) -> throw(instantiation_error) ; \+ callable(Obj) -> throw(type_error(object_identifier, Obj)) ; '$lgt_pp_runtime_clause_'('$lgt_current_object_'(Obj, _, _, _, _, _, _, _, _, _, _)) -> % an object with the same identifier was defined earlier in the same source file throw(permission_error(modify, object, Obj)) ; '$lgt_pp_runtime_clause_'('$lgt_current_protocol_'(Obj, _, _, _, _)) -> % a protocol with the same identifier was defined earlier in the same source file throw(permission_error(modify, protocol, Obj)) ; '$lgt_pp_runtime_clause_'('$lgt_current_category_'(Obj, _, _, _, _, _)) -> % a category with the same identifier was defined earlier in the same source file throw(permission_error(modify, category, Obj)) ; functor(Obj, '{}', 1) -> % reserved syntax for object proxies throw(permission_error(create, object, Obj)) ; '$lgt_pp_entity_'(Type, _, _) -> % opening object directive found while still compiling the previous entity ( Type == object -> throw(existence_error(directive, end_object/0)) ; Type == protocol -> throw(existence_error(directive, end_protocol/0)) ; % Type == category, throw(existence_error(directive, end_category/0)) ) ; '$lgt_print_message'(silent(compiling), compiling_entity(object, Obj)), '$lgt_compile_object_relations'(Relations, Obj, Ctx), '$lgt_compile_object_identifier'(Obj, Ctx), '$lgt_save_parameter_variables'(Obj) ). '$lgt_compile_logtalk_directive'(end_object, Ctx) :- ( '$lgt_pp_object_'(Obj, _, _, _, _, _, _, _, _, _, _) -> % we're indeed compiling an object '$lgt_pp_referenced_object_'(Obj, _, Start-_), '$lgt_comp_ctx_lines'(Ctx, _-End), assertz('$lgt_pp_entity_lines_'(Obj, Start-End)), '$lgt_second_stage'(object, Obj, Ctx), '$lgt_print_message'(silent(compiling), compiled_entity(object, Obj)) ; % entity ending directive mismatch throw(existence_error(directive, object/1)) ). % protocol opening and closing directives '$lgt_compile_logtalk_directive'(protocol(Ptc), Ctx) :- '$lgt_compile_logtalk_directive'(protocol_(Ptc, []), Ctx). '$lgt_compile_logtalk_directive'(protocol(Ptc, Relation), Ctx) :- '$lgt_compile_logtalk_directive'(protocol_(Ptc, [Relation]), Ctx). % auxiliary predicate to compile all variants to the protocol opening directive '$lgt_compile_logtalk_directive'(protocol_(Ptc, Relations), Ctx) :- ( var(Ptc) -> throw(instantiation_error) ; \+ atom(Ptc) -> throw(type_error(protocol_identifier, Ptc)) ; '$lgt_pp_runtime_clause_'('$lgt_current_object_'(Ptc, _, _, _, _, _, _, _, _, _, _)) -> % an object with the same identifier was defined earlier in the same source file throw(permission_error(modify, object, Ptc)) ; '$lgt_pp_runtime_clause_'('$lgt_current_protocol_'(Ptc, _, _, _, _)) -> % a protocol with the same identifier was defined earlier in the same source file throw(permission_error(modify, protocol, Ptc)) ; '$lgt_pp_runtime_clause_'('$lgt_current_category_'(Ptc, _, _, _, _, _)) -> % a category with the same identifier was defined earlier in the same source file throw(permission_error(modify, category, Ptc)) ; '$lgt_pp_entity_'(Type, _, _) -> % opening protocol directive found while still compiling the previous entity ( Type == object -> throw(existence_error(directive, end_object/0)) ; Type == protocol -> throw(existence_error(directive, end_protocol/0)) ; % Type == category, throw(existence_error(directive, end_category/0)) ) ; '$lgt_print_message'(silent(compiling), compiling_entity(protocol, Ptc)), '$lgt_compile_protocol_identifier'(Ptc, Ctx), '$lgt_compile_protocol_relations'(Relations, Ptc, Ctx) ). '$lgt_compile_logtalk_directive'(end_protocol, Ctx) :- ( '$lgt_pp_protocol_'(Ptc, _, _, _, _) -> % we're indeed compiling a protocol '$lgt_pp_referenced_protocol_'(Ptc, _, Start-_), '$lgt_comp_ctx_lines'(Ctx, _-End), assertz('$lgt_pp_entity_lines_'(Ptc, Start-End)), '$lgt_second_stage'(protocol, Ptc, Ctx), '$lgt_print_message'(silent(compiling), compiled_entity(protocol, Ptc)) ; % entity ending directive mismatch throw(existence_error(directive, protocol/1)) ). % category opening and closing directives '$lgt_compile_logtalk_directive'(category(Ctg), Ctx) :- '$lgt_compile_logtalk_directive'(category_(Ctg, []), Ctx). '$lgt_compile_logtalk_directive'(category(Ctg, Relation), Ctx) :- '$lgt_compile_logtalk_directive'(category_(Ctg, [Relation]), Ctx). '$lgt_compile_logtalk_directive'(category(Ctg, Relation1, Relation2), Ctx) :- '$lgt_compile_logtalk_directive'(category_(Ctg, [Relation1, Relation2]), Ctx). '$lgt_compile_logtalk_directive'(category(Ctg, Relation1, Relation2, Relation3), Ctx) :- '$lgt_compile_logtalk_directive'(category_(Ctg, [Relation1, Relation2, Relation3]), Ctx). % auxiliary predicate to compile all variants to the category opening directive '$lgt_compile_logtalk_directive'(category_(Ctg, Relations), Ctx) :- ( var(Ctg) -> throw(instantiation_error) ; \+ callable(Ctg) -> throw(type_error(category_identifier, Ctg)) ; '$lgt_pp_runtime_clause_'('$lgt_current_object_'(Ctg, _, _, _, _, _, _, _, _, _, _)) -> % an object with the same identifier was defined earlier in the same source file throw(permission_error(modify, object, Ctg)) ; '$lgt_pp_runtime_clause_'('$lgt_current_protocol_'(Ctg, _, _, _, _)) -> % a protocol with the same identifier was defined earlier in the same source file throw(permission_error(modify, protocol, Ctg)) ; '$lgt_pp_runtime_clause_'('$lgt_current_category_'(Ctg, _, _, _, _, _)) -> % a category with the same identifier was defined earlier in the same source file throw(permission_error(modify, category, Ctg)) ; '$lgt_pp_entity_'(Type, _, _) -> % opening protocol directive found while still compiling the previous entity ( Type == object -> throw(existence_error(directive, end_object/0)) ; Type == protocol -> throw(existence_error(directive, end_protocol/0)) ; % Type == category, throw(existence_error(directive, end_category/0)) ) ; '$lgt_print_message'(silent(compiling), compiling_entity(category, Ctg)), '$lgt_compile_category_identifier'(Ctg, Ctx), '$lgt_compile_category_relations'(Relations, Ctg, Ctx), '$lgt_save_parameter_variables'(Ctg) ). '$lgt_compile_logtalk_directive'(end_category, Ctx) :- ( '$lgt_pp_category_'(Ctg, _, _, _, _, _) -> % we're indeed compiling a category '$lgt_pp_referenced_category_'(Ctg, _, Start-_), '$lgt_comp_ctx_lines'(Ctx, _-End), assertz('$lgt_pp_entity_lines_'(Ctg, Start-End)), '$lgt_second_stage'(category, Ctg, Ctx), '$lgt_print_message'(silent(compiling), compiled_entity(category, Ctg)) ; % entity ending directive mismatch throw(existence_error(directive, category/1)) ). % compile modules as objects '$lgt_compile_logtalk_directive'(module(Module), Ctx) :- % empty export list '$lgt_compile_logtalk_directive'(module(Module, []), Ctx). '$lgt_compile_logtalk_directive'(module(Module, Exports), Ctx) :- '$lgt_check'(module_identifier, Module), '$lgt_check'(list, Exports), % remember we are compiling a module assertz('$lgt_pp_module_'(Module)), '$lgt_print_message'(silent(compiling), compiling_entity(module, Module)), '$lgt_compile_object_identifier'(Module, Ctx), % make the export list the public resources list '$lgt_compile_logtalk_directive'(public(Exports), Ctx). % set_logtalk_flag/2 entity directive '$lgt_compile_logtalk_directive'(set_logtalk_flag(Flag, Value), _) :- '$lgt_check'(read_write_flag, Flag), '$lgt_check'(flag_value, Flag+Value), retractall('$lgt_pp_entity_compiler_flag_'(Flag, _)), assertz('$lgt_pp_entity_compiler_flag_'(Flag, Value)). % declare an entity as built-in '$lgt_compile_logtalk_directive'(built_in, Ctx) :- ( ( '$lgt_pp_dynamic_' ; '$lgt_comp_ctx_mode'(Ctx, runtime) ) -> '$lgt_pp_entity_'(_, Entity, _), throw(permission_error(declare, built_in, Entity)) ; assertz('$lgt_pp_built_in_') ). % create a message queue at object initialization '$lgt_compile_logtalk_directive'(threaded, _) :- '$lgt_pp_entity_'(Type, _, _), ( '$lgt_prolog_feature'(engines, unsupported), '$lgt_prolog_feature'(threads, unsupported) -> throw(resource_error(threads)) ; Type == object -> assertz('$lgt_pp_threaded_') ; Type == protocol -> throw(domain_error(protocol_directive, threaded/0)) ; % Type == category, throw(domain_error(category_directive, threaded/0)) ). % dynamic/0 entity directive % % (entities are static by default but can be declared dynamic using this directive) '$lgt_compile_logtalk_directive'((dynamic), _) :- ( '$lgt_pp_built_in_' -> '$lgt_pp_entity_'(_, Entity, _), throw(permission_error(declare, (dynamic), Entity)) ; assertz('$lgt_pp_dynamic_') ). % initialization/1 object directive % % this directive cannot be used in categories and protocols as it's not always % possible to correctly compile initialization goals as there's no valid % compilation context values for "sender", "this", and "self" '$lgt_compile_logtalk_directive'(initialization(Goal), Ctx) :- '$lgt_pp_entity_'(Type, Entity, Prefix), ( Type == object -> % MetaVars = [] as we're compiling a local call '$lgt_comp_ctx'(Ctx, (:- initialization(Goal)), _, Entity, Entity, Entity, Entity, Prefix, [], _, ExCtx, _, [], Lines, _), '$lgt_execution_context'(ExCtx, Entity, Entity, Entity, Entity, [], []), % save the source data information for use in the second compiler stage % (where it might be required by calls to the logtalk_load_context/2 % predicate during goal expansion) ( '$lgt_pp_term_source_data_'(Term, VariableNames, Singletons, File, Lines) -> SourceData = sd(Term, VariableNames, Singletons, File, Lines) ; SourceData = nil ), ( '$lgt_compiler_flag'(debug, on) -> assertz('$lgt_pp_object_initialization_'(dgoal(Goal,Ctx), SourceData, Lines)) ; assertz('$lgt_pp_object_initialization_'(goal(Goal,Ctx), SourceData, Lines)) ) ; Type == protocol -> throw(domain_error(protocol_directive, (initialization)/1)) ; % Type == category, throw(domain_error(category_directive, (initialization)/1)) ). % op/3 entity directive (operators are local to entities) '$lgt_compile_logtalk_directive'(op(Priority, Specifier, Operators), Ctx) :- '$lgt_check'(operator_specification, op(Priority, Specifier, Operators)), '$lgt_source_file_context'(Ctx, File, Lines), '$lgt_comp_ctx_mode'(Ctx, Mode), '$lgt_activate_entity_operators'(Priority, Specifier, Operators, l, File, Lines, Mode). % uses/1 entity directive '$lgt_compile_logtalk_directive'(uses(Aliases), _) :- '$lgt_pp_entity_'(protocol, _, _), throw(error(domain_error(directive, uses/1), directive(uses(Aliases)))). '$lgt_compile_logtalk_directive'(uses(Aliases), Ctx) :- '$lgt_compile_uses_directive'(Aliases, Aliases, Ctx). % uses/2 predicate directive '$lgt_compile_logtalk_directive'(uses(Obj, Resources), _) :- '$lgt_pp_entity_'(protocol, _, _), throw(error(domain_error(directive, uses/2), directive(uses(Obj, Resources)))). '$lgt_compile_logtalk_directive'(uses(Obj, _), _) :- callable(Obj), '$lgt_pp_entity_'(object, Obj, _), % recursive reference to the object being compiled throw(permission_error(uses, self, Obj)). '$lgt_compile_logtalk_directive'(uses(Obj, Resources), Ctx) :- term_variables(Obj, [ObjVariable| ObjVariables]), '$lgt_pp_term_source_data_'((:- uses(Obj,Resources)), VariableNames, _, _, _), '$lgt_member'(VariableName=Variable, VariableNames), '$lgt_member_var'(Variable, [ObjVariable| ObjVariables]), '$lgt_pp_parameter_variables_'(ParameterVariablePairs), '$lgt_member'(VariableName-_, ParameterVariablePairs), % object argument is or contains a parameter variable !, '$lgt_compile_uses_directive'(Resources, Resources, Obj, true, Ctx). '$lgt_compile_logtalk_directive'(uses(Obj, Resources), Ctx) :- '$lgt_comp_ctx_entity'(Ctx, Entity), term_variables(Entity, [EntityVariable| EntityVariables]), '$lgt_pp_term_source_data_'((:- uses(Obj,Resources)), VariableNames, _, _, _), '$lgt_member'(VariableName=Variable, VariableNames), '$lgt_member_var'(Variable, [EntityVariable| EntityVariables]), '$lgt_pp_parameter_variables_'(ParameterVariablePairs), '$lgt_member'(VariableName-_, ParameterVariablePairs), % directive uses an entity parameter variable !, '$lgt_compile_uses_directive'(Resources, Resources, Obj, true, Ctx). '$lgt_compile_logtalk_directive'(uses(Obj, Resources), Ctx) :- '$lgt_check'(object_identifier, Obj), '$lgt_add_referenced_object'(Obj, Ctx), '$lgt_compile_uses_directive'(Resources, Resources, Obj, false, Ctx). % use_module/1 entity directive '$lgt_compile_logtalk_directive'(use_module(FileSpec), _) :- '$lgt_pp_module_'(_), % compiling a module as an object but Logtalk only supports use_module/2 directives throw(error(domain_error(directive, use_module/1), directive(use_module(FileSpec)))). '$lgt_compile_logtalk_directive'(use_module(Aliases), _) :- '$lgt_prolog_feature'(modules, unsupported), throw(error(domain_error(directive, use_module/1), directive(use_module(Aliases)))). '$lgt_compile_logtalk_directive'(use_module(Aliases), _) :- '$lgt_pp_entity_'(protocol, _, _), throw(error(domain_error(directive, use_module/1), directive(use_module(Aliases)))). '$lgt_compile_logtalk_directive'(use_module(Aliases), Ctx) :- '$lgt_compile_use_module_directive'(Aliases, Aliases, Ctx). % use_module/2 predicate directive % % the first argument must be a module identifier; when a file specification % is used, as it's usual in Prolog, it must be expanded at the adapter file % level into a module identifier '$lgt_compile_logtalk_directive'(use_module(Module, Imports), _) :- '$lgt_pp_entity_'(protocol, _, _), throw(error(domain_error(directive, use_module/2), directive(use_module(Module, Imports)))). '$lgt_compile_logtalk_directive'(use_module(Module, _), _) :- atom(Module), '$lgt_pp_module_'(Module), % recursive reference to the module being compiled as an object throw(permission_error(use_module, self, Module)). '$lgt_compile_logtalk_directive'(use_module(Module, Imports), Ctx) :- var(Module), '$lgt_pp_term_source_data_'((:- use_module(Module,Imports)), VariableNames, _, _, _), '$lgt_member'(VariableName=Variable, VariableNames), Module == Variable, '$lgt_pp_parameter_variables_'(ParameterVariablePairs), '$lgt_member'(VariableName-_, ParameterVariablePairs), % module argument is a parameter variable !, ( '$lgt_pp_module_'(_) -> % we're compiling a module as an object; assume referenced modules are also compiled as objects '$lgt_compile_uses_directive'(Imports, Imports, Module, true, Ctx) ; '$lgt_prolog_feature'(modules, unsupported) -> % use_module/2 directives in objects or categories require a backend supporting modules throw(error(domain_error(directive, use_module/2), directive(use_module(Module, Imports)))) ; % we're calling module predicates from within an object or a category '$lgt_compile_use_module_directive'(Imports, Imports, Module, true, Ctx) ). '$lgt_compile_logtalk_directive'(use_module(Module, Imports), Ctx) :- '$lgt_check'(module_identifier, Module), '$lgt_comp_ctx_entity'(Ctx, Entity), term_variables(Entity, [EntityVariable| EntityVariables]), '$lgt_pp_term_source_data_'((:- use_module(Module,Imports)), VariableNames, _, _, _), '$lgt_member'(VariableName=Variable, VariableNames), '$lgt_member_var'(Variable, [EntityVariable| EntityVariables]), '$lgt_pp_parameter_variables_'(ParameterVariablePairs), '$lgt_member'(VariableName-_, ParameterVariablePairs), % directive uses an entity parameter variable !, ( '$lgt_pp_module_'(_) -> % we're compiling a module as an object; assume referenced modules are also compiled as objects '$lgt_compile_uses_directive'(Imports, Imports, Module, true, Ctx) ; '$lgt_prolog_feature'(modules, unsupported) -> % use_module/2 directives in objects or categories require a backend supporting modules throw(error(domain_error(directive, use_module/2), directive(use_module(Module, Imports)))) ; % we're calling module predicates from within an object or a category '$lgt_compile_use_module_directive'(Imports, Imports, Module, true, Ctx) ). '$lgt_compile_logtalk_directive'(use_module(Module, Imports), Ctx) :- ( '$lgt_pp_module_'(_) -> % we're compiling a module as an object; assume referenced modules are also compiled as objects '$lgt_compile_uses_directive'(Imports, Imports, Module, false, Ctx) ; '$lgt_prolog_feature'(modules, unsupported) -> % use_module/2 directives in objects or categories require a backend supporting modules throw(error(domain_error(directive, use_module/2), directive(use_module(Module, Imports)))) ; % we're calling module predicates from within an object or a category '$lgt_add_referenced_module'(Module, Ctx), '$lgt_compile_use_module_directive'(Imports, Imports, Module, false, Ctx) ). % reexport/2 module directive % % the first argument must be a module identifier; when a file specification % is used, as it's usual in Prolog, it must be expanded at the adapter file % level into a module identifier '$lgt_compile_logtalk_directive'(reexport(Module, Exports), Ctx) :- % we must be compiling a module as an object ( '$lgt_pp_module_'(_) -> % assume referenced modules are also compiled as objects '$lgt_check'(module_identifier, Module), '$lgt_check'(list, Exports), '$lgt_compile_reexport_directive'(Exports, Module, Ctx) ; throw(error(domain_error(directive, (reexport)/2), directive(reexport(Module, Exports)))) ). % info/1 entity directive '$lgt_compile_logtalk_directive'(info(Pairs), Ctx) :- '$lgt_compile_entity_info_directive'(Pairs, TPairs), '$lgt_source_file_context'(Ctx, File, Lines), assertz('$lgt_pp_entity_info_'(TPairs, File, Lines)), ( '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(deprecated, warning), '$lgt_pp_entity_'(Type, Entity, _) -> ( '$lgt_member'(date is Year/Month/Day, Pairs) -> '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(deprecated), deprecated_date_format(File, Lines, Type, Entity, Year/Month/Day, Year-Month-Day) ) ; true ), ( '$lgt_member'(version is Version, Pairs), Version \= ':'(_, ':'(_, _)) -> '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(deprecated), deprecated_version_format(File, Lines, Type, Entity, Version) ) ; true ) ; true ). % info/2 predicate directive '$lgt_compile_logtalk_directive'(info(Pred, Pairs), Ctx) :- '$lgt_source_file_context'(Ctx, File, Lines), ( '$lgt_valid_predicate_indicator'(Pred, Functor, Arity) -> '$lgt_compile_predicate_info_directive'(Pairs, Functor, Arity, TPairs), assertz('$lgt_pp_predicate_info_'(Functor/Arity, TPairs, File, Lines)) ; '$lgt_valid_non_terminal_indicator'(Pred, Functor, Arity, ExtArity) -> '$lgt_compile_predicate_info_directive'(Pairs, Functor, Arity, TPairs), assertz('$lgt_pp_predicate_info_'(Functor/ExtArity, TPairs, File, Lines)) ; var(Pred) -> throw(instantiation_error) ; throw(type_error(predicate_indicator, Pred)) ). % synchronized/1 predicate directive '$lgt_compile_logtalk_directive'(synchronized(Resources), Ctx) :- '$lgt_flatten_to_list'(Resources, ResourcesFlatted), '$lgt_compile_synchronized_directive'(ResourcesFlatted, Ctx). % scope directives '$lgt_compile_logtalk_directive'(public(Resources), Ctx) :- '$lgt_flatten_to_list'(Resources, ResourcesFlatted), '$lgt_source_file_context'(Ctx, File, Lines), '$lgt_compile_scope_directive'(ResourcesFlatted, (public), File, Lines, Ctx). '$lgt_compile_logtalk_directive'(protected(Resources), Ctx) :- '$lgt_flatten_to_list'(Resources, ResourcesFlatted), '$lgt_source_file_context'(Ctx, File, Lines), '$lgt_compile_scope_directive'(ResourcesFlatted, protected, File, Lines, Ctx). '$lgt_compile_logtalk_directive'(private(Resources), Ctx) :- '$lgt_flatten_to_list'(Resources, ResourcesFlatted), '$lgt_source_file_context'(Ctx, File, Lines), '$lgt_compile_scope_directive'(ResourcesFlatted, (private), File, Lines, Ctx). % export/1 module directive % % module exported directives are compiled as object public directives '$lgt_compile_logtalk_directive'(export(Exports), Ctx) :- % we must be compiling a module as an object ( '$lgt_pp_module_'(_) -> '$lgt_compile_logtalk_directive'(public(Exports), Ctx) ; throw(error(domain_error(directive, (export)/1), directive(export(Exports)))) ). % dynamic/1 and discontiguous/1 predicate directives '$lgt_compile_logtalk_directive'(dynamic(Resources), Ctx) :- '$lgt_flatten_to_list'(Resources, ResourcesFlatted), '$lgt_compile_dynamic_directive'(ResourcesFlatted, Ctx). '$lgt_compile_logtalk_directive'(discontiguous(Resources), Ctx) :- '$lgt_flatten_to_list'(Resources, ResourcesFlatted), '$lgt_compile_discontiguous_directive'(ResourcesFlatted, Ctx). % meta_predicate/2 and meta_non_terminal/1 predicate directives '$lgt_compile_logtalk_directive'(meta_predicate(Preds), Ctx) :- '$lgt_flatten_to_list'(Preds, PredsFlatted), ( '$lgt_pp_module_'(_) -> % we're compiling a module as an object '$lgt_compile_module_meta_predicate_directive'(PredsFlatted, TPredsFlatted) ; % we're compiling a Logtalk entity TPredsFlatted = PredsFlatted ), '$lgt_compile_meta_predicate_directive'(TPredsFlatted, Ctx). '$lgt_compile_logtalk_directive'(meta_non_terminal(Preds), Ctx) :- '$lgt_flatten_to_list'(Preds, PredsFlatted), '$lgt_compile_meta_non_terminal_directive'(PredsFlatted, Ctx). % mode/2 predicate directive '$lgt_compile_logtalk_directive'(mode(Mode, Solutions), _) :- (var(Mode); var(Solutions)), throw(instantiation_error). '$lgt_compile_logtalk_directive'(mode(Mode, _), _) :- \+ '$lgt_valid_mode_template'(Mode), throw(type_error(mode_term, Mode)). '$lgt_compile_logtalk_directive'(mode(_, Solutions), _) :- \+ '$lgt_valid_number_of_proofs'(Solutions), throw(type_error(number_of_proofs, Solutions)). '$lgt_compile_logtalk_directive'(mode(Mode, Solutions), Ctx) :- '$lgt_source_file_context'(Ctx, File, Lines), assertz('$lgt_pp_mode_'(Mode, Solutions, File, Lines)). % multifile/2 predicate directive '$lgt_compile_logtalk_directive'(multifile(Preds), Ctx) :- '$lgt_flatten_to_list'(Preds, PredsFlatted), '$lgt_compile_multifile_directive'(PredsFlatted, Ctx). % coinductive/1 predicate directive '$lgt_compile_logtalk_directive'(coinductive(Preds), Ctx) :- ( '$lgt_prolog_feature'(coinduction, supported) -> '$lgt_flatten_to_list'(Preds, PredsFlatted), '$lgt_compile_coinductive_directive'(PredsFlatted, Ctx) ; throw(resource_error(coinduction)) ). % alias/2 entity directive '$lgt_compile_logtalk_directive'(alias(Entity, Resources), Ctx) :- '$lgt_check'(entity_identifier, Entity), '$lgt_compile_alias_directive'(Resources, Resources, Entity, Ctx). % '$lgt_compile_alias_directive'(+list, +list, @entity_identifier, +compilation_context) % % auxiliary predicate for compiling alias/2 directives '$lgt_compile_alias_directive'(_, _, Entity, _) :- '$lgt_pp_entity_'(_, Entity, _), throw(permission_error(reference, self, Entity)). '$lgt_compile_alias_directive'(_, _, Entity, _) :- \+ '$lgt_pp_extended_protocol_'(Entity, _, _, _, _), \+ '$lgt_pp_implemented_protocol_'(Entity, _, _, _, _), \+ '$lgt_pp_extended_category_'(Entity, _, _, _, _, _), \+ '$lgt_pp_imported_category_'(Entity, _, _, _, _, _), \+ '$lgt_pp_extended_object_'(Entity, _, _, _, _, _, _, _, _, _, _), \+ '$lgt_pp_instantiated_class_'(Entity, _, _, _, _, _, _, _, _, _, _), \+ '$lgt_pp_specialized_class_'(Entity, _, _, _, _, _, _, _, _, _, _), \+ '$lgt_pp_complemented_object_'(Entity, _, _, _, _), throw(domain_error(ancestor, Entity)). '$lgt_compile_alias_directive'([Resource| Resources], Argument, Entity, Ctx) :- !, '$lgt_check'(ground, Resource), '$lgt_compile_alias_directive_resource'(Resource, Entity, Ctx), '$lgt_compile_alias_directive'(Resources, Argument, Entity, Ctx). '$lgt_compile_alias_directive'([], _, _, _) :- !. '$lgt_compile_alias_directive'(_, Argument, _, _) :- throw(type_error(list, Argument)). '$lgt_compile_alias_directive_resource'(as(Original,Alias), Entity, Ctx) :- !, '$lgt_compile_alias_directive_resource'(Original::Alias, Entity, Ctx). '$lgt_compile_alias_directive_resource'(Original::Alias, Entity, Ctx) :- !, '$lgt_check'(predicate_or_non_terminal_indicator, Original), '$lgt_check'(predicate_or_non_terminal_indicator, Alias), '$lgt_compile_alias_directive_resource'(Original, Alias, Entity, Ctx). '$lgt_compile_alias_directive_resource'(Resource, _, _) :- throw(type_error(predicate_alias_specification, Resource)). '$lgt_compile_alias_directive_resource'(Functor1/Arity, Functor2/Arity, Entity, Ctx) :- !, functor(Pred, Functor1, Arity), Pred =.. [Functor1| Args], Alias =.. [Functor2| Args], '$lgt_source_file_context'(Ctx, File, Lines), assertz('$lgt_pp_predicate_alias_'(Entity, Pred, Alias, 0, File, Lines)). '$lgt_compile_alias_directive_resource'(Functor1//Arity, Functor2//Arity, Entity, Ctx) :- !, ExtArity is Arity + 2, functor(Pred, Functor1, ExtArity), Pred =.. [Functor1| Args], Alias =.. [Functor2| Args], '$lgt_source_file_context'(Ctx, File, Lines), assertz('$lgt_pp_predicate_alias_'(Entity, Pred, Alias, 1, File, Lines)). '$lgt_compile_alias_directive_resource'(Functor1//Arity1, Functor2//Arity2, _, _) :- throw(consistency_error(same_arity, Functor1//Arity1, Functor2//Arity2)). '$lgt_compile_alias_directive_resource'(Functor1/Arity1, Functor2/Arity2, _, _) :- throw(consistency_error(same_arity, Functor1/Arity1, Functor2/Arity2)). '$lgt_compile_alias_directive_resource'(_/_, Functor2//Arity2, _, _) :- throw(type_error(predicate_indicator, Functor2//Arity2)). '$lgt_compile_alias_directive_resource'(_//_, Functor2/Arity2, _, _) :- throw(type_error(non_terminal_indicator, Functor2/Arity2)). % '$lgt_compile_synchronized_directive'(+list, +compilation_context) % % auxiliary predicate for compiling synchronized/1 directives '$lgt_compile_synchronized_directive'(Resources, Ctx) :- '$lgt_new_predicate_mutex'(Mutex), '$lgt_compile_synchronized_directive'(Resources, Mutex, Ctx). '$lgt_new_predicate_mutex'(Mutex) :- '$lgt_pp_entity_'(_, _, Prefix), once(retract('$lgt_pp_predicate_mutex_counter_'(Old))), New is Old + 1, asserta('$lgt_pp_predicate_mutex_counter_'(New)), number_codes(New, Codes), atom_codes(Atom, Codes), atom_concat(Prefix, 'pred_mutex_', Aux), atom_concat(Aux, Atom, Mutex). % note that the clause order ensures that instantiation errors will be caught by % the call to the '$lgt_compile_synchronized_directive_resource'/1 predicate '$lgt_compile_synchronized_directive'([Resource| Resources], Mutex, Ctx) :- '$lgt_compile_synchronized_directive_resource'(Resource, Mutex, Ctx), '$lgt_compile_synchronized_directive'(Resources, Mutex, Ctx). '$lgt_compile_synchronized_directive'([], _, _). '$lgt_compile_synchronized_directive_resource'(Pred, Mutex, Ctx) :- '$lgt_valid_predicate_indicator'(Pred, Functor, Arity), !, functor(Head, Functor, Arity), ( '$lgt_pp_dynamic_'(Head, _, _, _) -> % synchronized predicates must be static throw(permission_error(modify, dynamic_predicate, Functor/Arity)) ; '$lgt_pp_defines_predicate_'(Head, _, _, _, _, _) -> % synchronized/1 directives must precede the definitions for the declared predicates throw(permission_error(modify, predicate_interpretation, Functor/Arity)) ; '$lgt_source_file_context'(Ctx, File, Lines), assertz('$lgt_pp_synchronized_'(Head, Mutex, File, Lines)) ). '$lgt_compile_synchronized_directive_resource'(NonTerminal, Mutex, Ctx) :- '$lgt_valid_non_terminal_indicator'(NonTerminal, Functor, Arity, ExtArity), !, functor(Head, Functor, ExtArity), ( '$lgt_pp_dynamic_'(Head, _, _, _) -> % synchronized non-terminals must be static throw(permission_error(modify, dynamic_non_terminal, Functor//Arity)) ; '$lgt_pp_defines_non_terminal_'(Functor, Arity, _) -> throw(permission_error(modify, non_terminal_interpretation, Functor//Arity)) ; '$lgt_pp_defines_predicate_'(Head, _, _, _, _, _) -> % synchronized/1 directives must precede the definitions for the declared non-terminals throw(permission_error(modify, non_terminal_interpretation, Functor//Arity)) ; '$lgt_source_file_context'(Ctx, File, Lines), assertz('$lgt_pp_synchronized_'(Head, Mutex, File, Lines)) ). '$lgt_compile_synchronized_directive_resource'(Resource, _, _) :- ground(Resource), throw(type_error(predicate_indicator, Resource)). '$lgt_compile_synchronized_directive_resource'(_, _, _) :- throw(instantiation_error). % '$lgt_compile_scope_directive'(+list, @scope, +atom, +integer, +compilation_context) % % auxiliary predicate for compiling scope directives % % note that the clause order ensures that instantiation errors will be caught % by the call to the '$lgt_compile_scope_directive_resource'/1 predicate '$lgt_compile_scope_directive'([Resource| Resources], Scope, File, Lines, Ctx) :- '$lgt_compile_scope_directive_resource'(Resource, Scope, File, Lines, Ctx), '$lgt_compile_scope_directive'(Resources, Scope, File, Lines, Ctx). '$lgt_compile_scope_directive'([], _, _, _, _). % '$lgt_compile_scope_directive_resource'(@term, @scope, +integer, +compilation_context) % % auxiliary predicate for compiling scope directive resources '$lgt_compile_scope_directive_resource'(op(Priority, Specifier, Operators), Scope, File, Lines, Ctx) :- '$lgt_check'(operator_specification, op(Priority, Specifier, Operators)), !, '$lgt_check_for_duplicated_scope_directives'(op(Priority, Specifier, Operators), Scope), '$lgt_scope'(Scope, InternalScope), '$lgt_comp_ctx_mode'(Ctx, Mode), '$lgt_activate_entity_operators'(Priority, Specifier, Operators, InternalScope, File, Lines, Mode). '$lgt_compile_scope_directive_resource'(Functor/Arity, Scope, File, StartLine-EndLine, _) :- '$lgt_valid_predicate_indicator'(Functor/Arity, Functor, Arity), functor(Pred, Functor, Arity), ( '$lgt_built_in_method'(Pred, _, _, _) -> % clash with a built-in method, whose scope cannot be changed throw(permission_error(modify, built_in_method, Functor/Arity)) ; !, '$lgt_check_for_duplicated_scope_directives'(Functor/Arity, Scope), '$lgt_add_predicate_scope_directive'(Scope, Functor, Arity, File, StartLine-EndLine), assertz('$lgt_pp_predicate_declaration_location_'(Functor, Arity, File, StartLine-EndLine)) ). '$lgt_compile_scope_directive_resource'(Functor//Arity, Scope, File, StartLine-EndLine, _) :- '$lgt_valid_non_terminal_indicator'(Functor//Arity, Functor, Arity, ExtArity), functor(Pred, Functor, ExtArity), ( '$lgt_built_in_method'(Pred, _, _, _) -> % clash with a built-in method, whose scope cannot be changed throw(permission_error(modify, built_in_method, Functor//Arity)) ; !, '$lgt_check_for_duplicated_scope_directives'(Functor//Arity+ExtArity, Scope), assertz('$lgt_pp_non_terminal_'(Functor, Arity, ExtArity)), '$lgt_add_predicate_scope_directive'(Scope, Functor, ExtArity, File, StartLine-EndLine), assertz('$lgt_pp_predicate_declaration_location_'(Functor, ExtArity, File, StartLine-EndLine)) ). '$lgt_compile_scope_directive_resource'(Resource, _, _, _, _) :- ground(Resource), throw(type_error(predicate_indicator, Resource)). '$lgt_compile_scope_directive_resource'(_, _, _, _, _) :- throw(instantiation_error). '$lgt_add_predicate_scope_directive'((public), Functor, Arity, File, Lines) :- assertz('$lgt_pp_public_'(Functor, Arity, File, Lines)). '$lgt_add_predicate_scope_directive'(protected, Functor, Arity, File, Lines) :- assertz('$lgt_pp_protected_'(Functor, Arity, File, Lines)). '$lgt_add_predicate_scope_directive'((private), Functor, Arity, File, Lines) :- assertz('$lgt_pp_private_'(Functor, Arity, File, Lines)). '$lgt_check_for_duplicated_scope_directives'(op(_, _, []), _) :- !. '$lgt_check_for_duplicated_scope_directives'(op(Priority, Specifier, [Operator| Operators]), Scope) :- !, ( '$lgt_pp_entity_operator_'(Priority, Specifier, Operator, Scope, OriginalFile, OriginalLines) -> ( '$lgt_compiler_flag'(duplicated_directives, warning) -> '$lgt_source_file_context'(File, Lines, Type, Entity), Directive =.. [Scope, op(Priority, Specifier, Operator)], '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(duplicated_directives), duplicated_directive(File, Lines, Type, Entity, Directive, OriginalFile, OriginalLines) ) ; true ) ; % allow a local operator to also be declared in a scope directive to simplify % compilation of included files and compilation of modules as objects '$lgt_pp_entity_operator_'(Priority, Specifier, Operator, OriginalScope, _, _), OriginalScope \== l -> throw(permission_error(modify, operator_scope, op(Priority, Specifier, Operator))) ; '$lgt_check_for_duplicated_scope_directives'(op(Priority, Specifier, Operators), Scope) ). '$lgt_check_for_duplicated_scope_directives'(op(Priority, Specifier, Operator), Scope) :- ( '$lgt_pp_entity_operator_'(Priority, Specifier, Operator, Scope, OriginalFile, OriginalLines) -> ( '$lgt_compiler_flag'(duplicated_directives, warning) -> '$lgt_source_file_context'(File, Lines, Type, Entity), Directive =.. [Scope, op(Priority, Specifier, Operator)], '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(duplicated_directives), duplicated_directive(File, Lines, Type, Entity, Directive, OriginalFile, OriginalLines) ) ; true ) ; % allow a local operator to also be declared in a scope directive to simplify % compilation of included files and compilation of modules as objects '$lgt_pp_entity_operator_'(Priority, Specifier, Operator, OriginalScope, _, _), OriginalScope \== l -> throw(permission_error(modify, operator_scope, op(Priority, Specifier, Operator))) ; true ). '$lgt_check_for_duplicated_scope_directives'(Functor/Arity, Scope) :- ( ( Scope == (public), '$lgt_pp_public_'(Functor, Arity, OriginalFile, OriginalLines) ; Scope == protected, '$lgt_pp_protected_'(Functor, Arity, OriginalFile, OriginalLines) ; Scope == (private), '$lgt_pp_private_'(Functor, Arity, OriginalFile, OriginalLines) ) -> ( '$lgt_compiler_flag'(duplicated_directives, warning) -> '$lgt_source_file_context'(File, Lines, Type, Entity), Directive =.. [Scope, Functor/Arity], '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(duplicated_directives), duplicated_directive(File, Lines, Type, Entity, Directive, OriginalFile, OriginalLines) ) ; true ) ; ( '$lgt_pp_public_'(Functor, Arity, _, _) ; '$lgt_pp_protected_'(Functor, Arity, _, _) ; '$lgt_pp_private_'(Functor, Arity, _, _) ) -> throw(permission_error(modify, predicate_scope, Functor/Arity)) ; true ). '$lgt_check_for_duplicated_scope_directives'(Functor//Arity+ExtArity, Scope) :- ( ( Scope == (public), '$lgt_pp_public_'(Functor, ExtArity, OriginalFile, OriginalLines) ; Scope == protected, '$lgt_pp_protected_'(Functor, ExtArity, OriginalFile, OriginalLines) ; Scope == (private), '$lgt_pp_private_'(Functor, ExtArity, OriginalFile, OriginalLines) ) -> ( '$lgt_compiler_flag'(duplicated_directives, warning) -> '$lgt_source_file_context'(File, Lines, Type, Entity), Directive =.. [Scope, Functor//Arity], '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(duplicated_directives), duplicated_directive(File, Lines, Type, Entity, Directive, OriginalFile, OriginalLines) ) ; true ) ; ( '$lgt_pp_public_'(Functor, ExtArity, _, _) ; '$lgt_pp_protected_'(Functor, ExtArity, _, _) ; '$lgt_pp_private_'(Functor, ExtArity, _, _) ) -> throw(permission_error(modify, non_terminal_scope, Functor//Arity)) ; true ). % '$lgt_compile_dynamic_directive'(+list, +compilation_context) % % auxiliary predicate for compiling dynamic/1 directives % % note that the clause order ensures that instantiation errors will be caught % by the call to the '$lgt_compile_dynamic_directive_resource'/1 predicate '$lgt_compile_dynamic_directive'([Resource| Resources], Ctx) :- '$lgt_compile_dynamic_directive_resource'(Resource, Ctx), '$lgt_compile_dynamic_directive'(Resources, Ctx). '$lgt_compile_dynamic_directive'([], _). '$lgt_compile_dynamic_directive_resource'(Entity::Resource, Ctx) :- '$lgt_check'(entity_identifier, Entity), nonvar(Resource), '$lgt_pp_entity_'(_, Entity0, _), '$lgt_variant'(Entity, Entity0), ( '$lgt_comp_ctx_mode'(Ctx, compile(user,_,_)), '$lgt_compiler_flag'(general, warning) -> '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(general), redundant_entity_qualifier_in_predicate_directive(File, Lines, Type, Entity, Entity::Resource) ) ; true ), '$lgt_compile_dynamic_directive_resource'(Resource, Ctx). '$lgt_compile_dynamic_directive_resource'(Entity::Pred, _) :- '$lgt_valid_predicate_indicator'(Pred, Functor, Arity), !, ( Entity == user -> '$lgt_check_for_duplicated_directive'(dynamic(Functor/Arity), dynamic(Entity::Pred)), assertz('$lgt_pp_directive_'(dynamic(Functor/Arity))) ; '$lgt_check'(entity_identifier, Entity), functor(Template, Functor, Arity), '$lgt_check_primary_dynamic_declaration'(Entity, Template) -> '$lgt_entity_to_prefix'(Entity, Prefix), '$lgt_compile_predicate_indicator'(Prefix, Functor/Arity, TFunctor/TArity), '$lgt_check_for_duplicated_directive'(dynamic(TFunctor/TArity), dynamic(Entity::Pred)), assertz('$lgt_pp_directive_'(dynamic(TFunctor/TArity))) ; throw(permission_error(modify, predicate_declaration, Entity::Pred)) ). '$lgt_compile_dynamic_directive_resource'(Entity::NonTerminal, _) :- '$lgt_valid_non_terminal_indicator'(NonTerminal, Functor, _, ExtArity), !, ( Entity == user -> '$lgt_check_for_duplicated_directive'(dynamic(Functor/ExtArity), dynamic(Entity::NonTerminal)), assertz('$lgt_pp_directive_'(dynamic(Functor/ExtArity))) ; '$lgt_check'(entity_identifier, Entity), functor(Template, Functor, ExtArity), '$lgt_check_primary_dynamic_declaration'(Entity, Template) -> '$lgt_entity_to_prefix'(Entity, Prefix), '$lgt_compile_predicate_indicator'(Prefix, Functor/ExtArity, TFunctor/TArity), '$lgt_check_for_duplicated_directive'(dynamic(TFunctor/TArity), dynamic(Entity::NonTerminal)), assertz('$lgt_pp_directive_'(dynamic(TFunctor/TArity))) ; throw(permission_error(modify, non_terminal_declaration, Entity::NonTerminal)) ). '$lgt_compile_dynamic_directive_resource'(':'(Module, Pred), _) :- '$lgt_valid_predicate_indicator'(Pred, Functor, Arity), !, ( Module == user -> '$lgt_check_for_duplicated_directive'(dynamic(Functor/Arity), dynamic(':'(Module, Pred))), assertz('$lgt_pp_directive_'(dynamic(Functor/Arity))) ; '$lgt_check'(module_identifier, Module), '$lgt_check_for_duplicated_directive'(dynamic(':'(Module, Functor/Arity)), dynamic(':'(Module, Pred))), assertz('$lgt_pp_directive_'(dynamic(':'(Module, Functor/Arity)))) ). '$lgt_compile_dynamic_directive_resource'(':'(Module, NonTerminal), _) :- '$lgt_valid_non_terminal_indicator'(NonTerminal, Functor, _, ExtArity), !, ( Module == user -> '$lgt_check_for_duplicated_directive'(dynamic(Functor/ExtArity), dynamic(':'(Module, NonTerminal))), assertz('$lgt_pp_directive_'(dynamic(Functor/ExtArity))) ; '$lgt_check'(module_identifier, Module), '$lgt_check_for_duplicated_directive'(dynamic(':'(Module, Functor/ExtArity)), dynamic(':'(Module, NonTerminal))), assertz('$lgt_pp_directive_'(dynamic(':'(Module, Functor/ExtArity)))) ). '$lgt_compile_dynamic_directive_resource'(Pred, Ctx) :- '$lgt_valid_predicate_indicator'(Pred, Functor, Arity), !, functor(Head, Functor, Arity), '$lgt_check_predicate_name_conflict'((dynamic), Head, Functor/Arity), ( '$lgt_pp_entity_'(category, _, _), ( '$lgt_pp_multifile_'(Head, _, _, _) -> % categories cannot contain predicates that are both multifile and dynamic throw(permission_error(declare, (dynamic), Functor/Arity)) ; '$lgt_pp_defines_predicate_'(Head, _, _, _, _, _) -> % predicate definition occurs before the directive throw(permission_error(declare, (dynamic), Functor/Arity)) ) ; '$lgt_pp_synchronized_'(Head, _, _, _) -> % synchronized predicates must be static throw(permission_error(modify, synchronized_predicate, Functor/Arity)) ; '$lgt_check_for_duplicated_dynamic_directive'(Head, Pred), '$lgt_source_file_context'(Ctx, File, Lines), assertz('$lgt_pp_dynamic_'(Head, Functor/Arity, File, Lines)) ). '$lgt_compile_dynamic_directive_resource'(NonTerminal, Ctx) :- '$lgt_valid_non_terminal_indicator'(NonTerminal, Functor, Arity, ExtArity), !, functor(Head, Functor, ExtArity), '$lgt_check_predicate_name_conflict'((dynamic), Head, Functor//Arity), ( '$lgt_pp_entity_'(category, _, _), ( '$lgt_pp_multifile_'(Head, _, _, _) -> % categories cannot contain non-terminals that are both multifile and dynamic throw(permission_error(declare, (dynamic), Functor//Arity)) ; '$lgt_pp_defines_predicate_'(Head, _, _, _, _, _) -> % predicate definition occurs before the directive throw(permission_error(declare, (dynamic), Functor//Arity)) ) ; '$lgt_pp_synchronized_'(Head, _, _, _) -> % synchronized non-terminals must be static throw(permission_error(modify, synchronized_non_terminal, Functor//Arity)) ; '$lgt_check_for_duplicated_dynamic_directive'(Head, NonTerminal), '$lgt_source_file_context'(Ctx, File, Lines), assertz('$lgt_pp_dynamic_'(Head, Functor//Arity, File, Lines)) ). '$lgt_compile_dynamic_directive_resource'(Resource, _) :- ground(Resource), throw(type_error(predicate_indicator, Resource)). '$lgt_compile_dynamic_directive_resource'(_, _) :- throw(instantiation_error). '$lgt_check_for_duplicated_dynamic_directive'(Head, PI) :- ( '$lgt_pp_dynamic_'(Head, _, OriginalFile, OriginalLines), '$lgt_compiler_flag'(duplicated_directives, warning) -> '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(duplicated_directives), duplicated_directive(File, Lines, Type, Entity, dynamic(PI), OriginalFile, OriginalLines) ) ; true ). '$lgt_check_primary_dynamic_declaration'(Entity, Pred) :- % the object or category holding the primary declaration must be loaded ( '$lgt_current_object_'(Entity, _, Dcl, _, _, _, _, _, _, _, _) ; '$lgt_current_category_'(Entity, _, Dcl, _, _, _) ), !, % the predicate must be declared (i.e., have a scope directive) and dynamic ( call(Dcl, Pred, Scope, _, Flags) -> functor(Scope, p, _), Flags /\ 2 =:= 2 ; fail ). % '$lgt_compile_discontiguous_directive'(+list, +compilation_context) % % auxiliary predicate for compiling discontiguous/1 directives % % note that the clause order ensures that instantiation errors will be caught by % the call to the '$lgt_compile_discontiguous_directive_resource'/1 predicate '$lgt_compile_discontiguous_directive'([Resource| Resources], Ctx) :- '$lgt_compile_discontiguous_directive_resource'(Resource, Ctx), '$lgt_compile_discontiguous_directive'(Resources, Ctx). '$lgt_compile_discontiguous_directive'([], _). '$lgt_compile_discontiguous_directive_resource'(Entity::Resource, Ctx) :- '$lgt_check'(entity_identifier, Entity), nonvar(Resource), '$lgt_pp_entity_'(_, Entity0, _), '$lgt_variant'(Entity, Entity0), ( '$lgt_comp_ctx_mode'(Ctx, compile(user,_,_)), '$lgt_compiler_flag'(general, warning) -> '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(general), redundant_entity_qualifier_in_predicate_directive(File, Lines, Type, Entity, Entity::Resource) ) ; true ), '$lgt_compile_discontiguous_directive_resource'(Resource, Ctx). '$lgt_compile_discontiguous_directive_resource'(Entity::Pred, _) :- '$lgt_valid_predicate_indicator'(Pred, Functor, Arity), !, ( Entity == user -> '$lgt_check_for_duplicated_directive'(discontiguous(Functor/Arity), discontiguous(Entity::Pred)), assertz('$lgt_pp_directive_'(discontiguous(Functor/Arity))) ; '$lgt_check'(entity_identifier, Entity), '$lgt_entity_to_prefix'(Entity, Prefix), '$lgt_compile_predicate_indicator'(Prefix, Functor/Arity, TFunctor/TArity), '$lgt_check_for_duplicated_directive'(discontiguous(TFunctor/TArity), discontiguous(Entity::Pred)), assertz('$lgt_pp_directive_'(discontiguous(TFunctor/TArity))) ). '$lgt_compile_discontiguous_directive_resource'(Entity::NonTerminal, _) :- '$lgt_valid_non_terminal_indicator'(NonTerminal, Functor, _, ExtArity), !, ( Entity == user -> '$lgt_check_for_duplicated_directive'(discontiguous(Functor/ExtArity), discontiguous(Entity::NonTerminal)), assertz('$lgt_pp_directive_'(discontiguous(Functor/ExtArity))) ; '$lgt_check'(entity_identifier, Entity), '$lgt_entity_to_prefix'(Entity, Prefix), '$lgt_compile_predicate_indicator'(Prefix, Functor/ExtArity, TFunctor/TArity), '$lgt_check_for_duplicated_directive'(discontiguous(TFunctor/TArity), discontiguous(Entity::NonTerminal)), assertz('$lgt_pp_directive_'(discontiguous(TFunctor/TArity))) ). '$lgt_compile_discontiguous_directive_resource'(':'(Module, Pred), _) :- '$lgt_valid_predicate_indicator'(Pred, Functor, Arity), !, ( Module == user -> '$lgt_check_for_duplicated_directive'(discontiguous(Functor/Arity), discontiguous(':'(Module, Pred))), assertz('$lgt_pp_directive_'(discontiguous(Functor/Arity))) ; '$lgt_check'(module_identifier, Module), '$lgt_check_for_duplicated_directive'(discontiguous(':'(Module, Functor/Arity)), discontiguous(':'(Module, Pred))), assertz('$lgt_pp_directive_'(discontiguous(':'(Module, Functor/Arity)))) ). '$lgt_compile_discontiguous_directive_resource'(':'(Module, NonTerminal), _) :- '$lgt_valid_non_terminal_indicator'(NonTerminal, Functor, _, ExtArity), !, ( Module == user -> '$lgt_check_for_duplicated_directive'(discontiguous(Functor/ExtArity), discontiguous(':'(Module, NonTerminal))), assertz('$lgt_pp_directive_'(discontiguous(Functor/ExtArity))) ; '$lgt_check'(module_identifier, Module), '$lgt_check_for_duplicated_directive'(discontiguous(':'(Module, Functor/ExtArity)), discontiguous(':'(Module, NonTerminal))), assertz('$lgt_pp_directive_'(discontiguous(':'(Module, Functor/ExtArity)))) ). '$lgt_compile_discontiguous_directive_resource'(Pred, Ctx) :- '$lgt_valid_predicate_indicator'(Pred, Functor, Arity), !, functor(Head, Functor, Arity), '$lgt_check_for_duplicated_discontiguous_directive'(Head, Pred), '$lgt_source_file_context'(Ctx, File, Lines), assertz('$lgt_pp_discontiguous_'(Head, File, Lines)). '$lgt_compile_discontiguous_directive_resource'(NonTerminal, Ctx) :- '$lgt_valid_non_terminal_indicator'(NonTerminal, Functor, _, ExtArity), !, functor(Head, Functor, ExtArity), '$lgt_check_for_duplicated_discontiguous_directive'(Head, NonTerminal), '$lgt_source_file_context'(Ctx, File, Lines), assertz('$lgt_pp_discontiguous_'(Head, File, Lines)). '$lgt_compile_discontiguous_directive_resource'(Resource, _) :- ground(Resource), throw(type_error(predicate_indicator, Resource)). '$lgt_compile_discontiguous_directive_resource'(_, _) :- throw(instantiation_error). '$lgt_check_for_duplicated_discontiguous_directive'(Head, PI) :- ( '$lgt_pp_discontiguous_'(Head, OriginalFile, OriginalLines), '$lgt_compiler_flag'(duplicated_directives, warning) -> '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(duplicated_directives), duplicated_directive(File, Lines, Type, Entity, discontiguous(PI), OriginalFile, OriginalLines) ) ; true ). % '$lgt_compile_meta_predicate_directive'(+list, +compilation_context) % % auxiliary predicate for compiling meta_predicate/1 directives % % note that the clause order ensures that instantiation errors will be caught by % the call to the '$lgt_compile_meta_predicate_directive_resource'/1 predicate '$lgt_compile_meta_predicate_directive'([Meta| Metas], Ctx) :- '$lgt_compile_meta_predicate_directive_resource'(Meta, Ctx), '$lgt_compile_meta_predicate_directive'(Metas, Ctx). '$lgt_compile_meta_predicate_directive'([], _). '$lgt_compile_meta_predicate_directive_resource'(Entity::Meta, Ctx) :- '$lgt_valid_meta_predicate_template'(Meta), !, '$lgt_check'(entity_identifier, Entity), '$lgt_term_template'(Meta, Template), '$lgt_check_for_duplicated_meta_predicate_directive'(Entity::Template, Entity::Meta), '$lgt_source_file_context'(Ctx, File, Lines), assertz('$lgt_pp_meta_predicate_'(Entity::Template, Entity::Meta, File, Lines)). '$lgt_compile_meta_predicate_directive_resource'(':'(Module, Meta), Ctx) :- '$lgt_valid_meta_predicate_template'(Meta), !, '$lgt_check'(module_identifier, Module), '$lgt_term_template'(Meta, Template), '$lgt_check_for_duplicated_meta_predicate_directive'(':'(Module,Template), ':'(Module,Meta)), '$lgt_source_file_context'(Ctx, File, Lines), assertz('$lgt_pp_meta_predicate_'(':'(Module,Template), ':'(Module,Meta), File, Lines)). '$lgt_compile_meta_predicate_directive_resource'(Meta, Ctx) :- '$lgt_valid_meta_predicate_template'(Meta), !, '$lgt_term_template'(Meta, Template), '$lgt_check_for_duplicated_meta_predicate_directive'(Template, Meta), '$lgt_source_file_context'(Ctx, File, Lines), assertz('$lgt_pp_meta_predicate_'(Template, Meta, File, Lines)). '$lgt_compile_meta_predicate_directive_resource'(Meta, _) :- ground(Meta), throw(type_error(meta_predicate_template, Meta)). '$lgt_compile_meta_predicate_directive_resource'(_, _) :- throw(instantiation_error). '$lgt_check_for_duplicated_meta_predicate_directive'(Template, Meta) :- ( '$lgt_pp_meta_predicate_'(Template, Meta, OriginalFile, OriginalLines) -> ( '$lgt_compiler_flag'(duplicated_directives, warning) -> '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(duplicated_directives), duplicated_directive(File, Lines, Type, Entity, meta_predicate(Meta), OriginalFile, OriginalLines) ) ; true ) ; '$lgt_pp_meta_predicate_'(Template, _, _, _) -> throw(permission_error(modify, meta_predicate_template, Meta)) ; true ). % '$lgt_compile_meta_non_terminal_directive'(+list, +compilation_context) % % auxiliary predicate for compiling meta_non_terminal/1 directives % % note that the clause order ensures that instantiation errors will be caught by % the call to the '$lgt_compile_meta_non_terminal_directive_resource'/1 predicate '$lgt_compile_meta_non_terminal_directive'([Meta| Metas], Ctx) :- '$lgt_compile_meta_non_terminal_directive_resource'(Meta, Ctx), '$lgt_compile_meta_non_terminal_directive'(Metas, Ctx). '$lgt_compile_meta_non_terminal_directive'([], _). '$lgt_compile_meta_non_terminal_directive_resource'(Entity::Meta, Ctx) :- '$lgt_valid_meta_predicate_template'(Meta), !, '$lgt_check'(entity_identifier, Entity), '$lgt_extend_meta_non_terminal_template'(Meta, ExtendedMeta), '$lgt_term_template'(ExtendedMeta, Template), '$lgt_check_for_duplicated_meta_non_terminal_directive'(Entity::Template, Entity::ExtendedMeta, Entity::Meta), '$lgt_source_file_context'(Ctx, File, Lines), assertz('$lgt_pp_meta_predicate_'(Entity::Template, Entity::ExtendedMeta, File, Lines)). '$lgt_compile_meta_non_terminal_directive_resource'(':'(Module, Meta), Ctx) :- '$lgt_valid_meta_predicate_template'(Meta), !, '$lgt_check'(module_identifier, Module), '$lgt_extend_meta_non_terminal_template'(Meta, ExtendedMeta), '$lgt_term_template'(ExtendedMeta, Template), '$lgt_check_for_duplicated_meta_non_terminal_directive'(':'(Module, Template), ':'(Module, ExtendedMeta), ':'(Module, Meta)), '$lgt_source_file_context'(Ctx, File, Lines), assertz('$lgt_pp_meta_predicate_'(':'(Module, Template), ':'(Module, ExtendedMeta), File, Lines)). '$lgt_compile_meta_non_terminal_directive_resource'(Meta, Ctx) :- '$lgt_valid_meta_predicate_template'(Meta), !, '$lgt_extend_meta_non_terminal_template'(Meta, ExtendedMeta), '$lgt_term_template'(ExtendedMeta, Template), '$lgt_check_for_duplicated_meta_non_terminal_directive'(Template, ExtendedMeta, Meta), '$lgt_source_file_context'(Ctx, File, Lines), assertz('$lgt_pp_meta_predicate_'(Template, ExtendedMeta, File, Lines)). '$lgt_compile_meta_non_terminal_directive_resource'(Meta, _) :- ground(Meta), throw(type_error(meta_non_terminal_template, Meta)). '$lgt_compile_meta_non_terminal_directive_resource'(_, _) :- throw(instantiation_error). '$lgt_extend_meta_non_terminal_template'(Meta, ExtendedMeta) :- Meta =.. [Functor| Args], '$lgt_compile_meta_non_terminal_directive_args'(Args, ExtendedArgs), ExtendedMeta =.. [Functor| ExtendedArgs]. '$lgt_compile_meta_non_terminal_directive_args'([], [*, *]). '$lgt_compile_meta_non_terminal_directive_args'([Arg| Args], [ExtendedArg| ExtendedArgs]) :- ( integer(Arg) -> ExtendedArg is Arg + 2 ; ExtendedArg = Arg ), '$lgt_compile_meta_non_terminal_directive_args'(Args, ExtendedArgs). '$lgt_check_for_duplicated_meta_non_terminal_directive'(Template, ExtendedMeta, Meta) :- ( '$lgt_pp_meta_predicate_'(Template, ExtendedMeta, OriginalFile, OriginalLines) -> ( '$lgt_compiler_flag'(duplicated_directives, warning) -> '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(duplicated_directives), duplicated_directive(File, Lines, Type, Entity, meta_non_terminal(Meta), OriginalFile, OriginalLines) ) ; true ) ; '$lgt_pp_meta_predicate_'(Template, _, _, _) -> throw(permission_error(modify, meta_non_terminal_template, Meta)) ; true ). % '$lgt_compile_multifile_directive'(+list, +compilation_context) % % auxiliary predicate for compiling multifile/1 directives % % when the multifile predicate (or non-terminal) is declared for the module % "user", the module prefix is removed to ensure code portability when using % backend Prolog compilers without a module system % % note that the clause order ensures that instantiation errors will be caught % by the call to the '$lgt_compile_multifile_directive_resource'/1 predicate '$lgt_compile_multifile_directive'([Resource| Resources], Ctx) :- '$lgt_compile_multifile_directive_resource'(Resource, Ctx), '$lgt_compile_multifile_directive'(Resources, Ctx). '$lgt_compile_multifile_directive'([], _). '$lgt_compile_multifile_directive_resource'(Entity::Resource, Ctx) :- '$lgt_check'(entity_identifier, Entity), nonvar(Resource), '$lgt_pp_entity_'(_, Entity0, _), '$lgt_variant'(Entity, Entity0), ( '$lgt_comp_ctx_mode'(Ctx, compile(user,_,_)), '$lgt_compiler_flag'(general, warning) -> '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(general), redundant_entity_qualifier_in_predicate_directive(File, Lines, Type, Entity, Entity::Resource) ) ; true ), '$lgt_compile_multifile_directive_resource'(Resource, Ctx). '$lgt_compile_multifile_directive_resource'(Entity::Pred, _) :- '$lgt_valid_predicate_indicator'(Pred, Functor, Arity), !, ( Entity == user -> '$lgt_check_for_duplicated_directive'(multifile(Functor/Arity), multifile(Entity::Pred)), assertz('$lgt_pp_directive_'(multifile(Functor/Arity))) ; functor(Template, Functor, Arity), '$lgt_check_primary_multifile_declaration'(Entity, Template) -> '$lgt_entity_to_prefix'(Entity, Prefix), '$lgt_compile_predicate_indicator'(Prefix, Functor/Arity, TFunctor/TArity), '$lgt_check_for_duplicated_directive'(multifile(TFunctor/TArity), multifile(Entity::Pred)), assertz('$lgt_pp_directive_'(multifile(TFunctor/TArity))) ; throw(permission_error(modify, predicate_declaration, Entity::Pred)) ). '$lgt_compile_multifile_directive_resource'(Entity::NonTerminal, _) :- '$lgt_valid_non_terminal_indicator'(NonTerminal, Functor, _, ExtArity), !, ( Entity == user -> '$lgt_check_for_duplicated_directive'(multifile(Functor/ExtArity), multifile(Entity::NonTerminal)), assertz('$lgt_pp_directive_'(multifile(Functor/ExtArity))) ; functor(Template, Functor, ExtArity), '$lgt_check_primary_multifile_declaration'(Entity, Template) -> '$lgt_entity_to_prefix'(Entity, Prefix), '$lgt_compile_predicate_indicator'(Prefix, Functor/ExtArity, TFunctor/TArity), '$lgt_check_for_duplicated_directive'(multifile(TFunctor/TArity), multifile(Entity::NonTerminal)), assertz('$lgt_pp_directive_'(multifile(TFunctor/TArity))) ; throw(permission_error(modify, non_terminal_declaration, Entity::NonTerminal)) ). '$lgt_compile_multifile_directive_resource'(':'(Module, Pred), _) :- '$lgt_valid_predicate_indicator'(Pred, Functor, Arity), !, ( Module == user -> '$lgt_check_for_duplicated_directive'(multifile(Functor/Arity), multifile(':'(Module, Pred))), assertz('$lgt_pp_directive_'(multifile(Functor/Arity))) ; '$lgt_check'(module_identifier, Module), '$lgt_check_for_duplicated_directive'(multifile(':'(Module, Functor/Arity)), multifile(':'(Module, Pred))), assertz('$lgt_pp_directive_'(multifile(':'(Module, Functor/Arity)))) ). '$lgt_compile_multifile_directive_resource'(':'(Module, NonTerminal), _) :- '$lgt_valid_non_terminal_indicator'(NonTerminal, Functor, _, ExtArity), !, ( Module == user -> '$lgt_check_for_duplicated_directive'(multifile(Functor/ExtArity), multifile(':'(Module, NonTerminal))), assertz('$lgt_pp_directive_'(multifile(Functor/ExtArity))) ; '$lgt_check'(module_identifier, Module), '$lgt_check_for_duplicated_directive'(multifile(':'(Module, Functor/ExtArity)), multifile(':'(Module, NonTerminal))), assertz('$lgt_pp_directive_'(multifile(':'(Module, Functor/ExtArity)))) ). '$lgt_compile_multifile_directive_resource'(Pred, Ctx) :- '$lgt_valid_predicate_indicator'(Pred, Functor, Arity), !, functor(Head, Functor, Arity), '$lgt_pp_entity_'(Type, Entity, Prefix), ( Entity == user -> '$lgt_check_for_duplicated_directive'(multifile(Functor/Arity), multifile(Pred)), assertz('$lgt_pp_directive_'(multifile(Functor/Arity))) ; Type == protocol -> % protocols cannot contain predicate definitions throw(permission_error(declare, (multifile), Functor/Arity)) ; Type == category, '$lgt_pp_dynamic_'(Head, _, _, _) -> % categories cannot contain predicates that are both multifile and dynamic throw(permission_error(declare, (multifile), Functor/Arity)) ; '$lgt_check_for_duplicated_multifile_directive'(Head, Pred), '$lgt_source_file_context'(Ctx, File, Lines), assertz('$lgt_pp_multifile_'(Head, Functor/Arity, File, Lines)), '$lgt_compile_predicate_indicator'(Prefix, Functor/Arity, TFunctor/TArity), assertz('$lgt_pp_directive_'(multifile(TFunctor/TArity))) ). '$lgt_compile_multifile_directive_resource'(NonTerminal, Ctx) :- '$lgt_valid_non_terminal_indicator'(NonTerminal, Functor, Arity, ExtArity), !, functor(Head, Functor, ExtArity), '$lgt_pp_entity_'(Type, Entity, Prefix), ( Entity == user -> '$lgt_check_for_duplicated_directive'(multifile(Functor/ExtArity), multifile(NonTerminal)), assertz('$lgt_pp_directive_'(multifile(Functor/ExtArity))) ; Type == protocol -> % protocols cannot contain non-terminal definitions throw(permission_error(declare, (multifile), Functor//Arity)) ; Type == category, '$lgt_pp_dynamic_'(Head, _, _, _) -> % categories cannot contain non-terminals that are both multifile and dynamic throw(permission_error(declare, (multifile), Functor//Arity)) ; '$lgt_check_for_duplicated_multifile_directive'(Head, NonTerminal), '$lgt_source_file_context'(Ctx, File, Lines), assertz('$lgt_pp_multifile_'(Head, Functor//Arity, File, Lines)), '$lgt_compile_predicate_indicator'(Prefix, Functor/ExtArity, TFunctor/TArity), assertz('$lgt_pp_directive_'(multifile(TFunctor/TArity))) ). '$lgt_compile_multifile_directive_resource'(Resource, _) :- ground(Resource), throw(type_error(predicate_indicator, Resource)). '$lgt_compile_multifile_directive_resource'(_, _) :- throw(instantiation_error). '$lgt_check_primary_multifile_declaration'(Entity, Pred) :- % the object or category holding the primary declaration must be loaded ( '$lgt_current_object_'(Entity, _, Dcl, _, _, _, _, _, _, _, _) ; '$lgt_current_category_'(Entity, _, Dcl, _, _, _) ), !, % the predicate must be declared (i.e., have a scope directive) and multifile ( call(Dcl, Pred, Scope, _, Flags) -> functor(Scope, p, _), Flags /\ 16 =:= 16 ; fail ). '$lgt_check_for_duplicated_multifile_directive'(Head, PI) :- ( '$lgt_pp_multifile_'(Head, _, OriginalFile, OriginalLines), '$lgt_compiler_flag'(duplicated_directives, warning) -> '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(duplicated_directives), duplicated_directive(File, Lines, Type, Entity, multifile(PI), OriginalFile, OriginalLines) ) ; true ). % '$lgt_compile_coinductive_directive'(+list, +compilation_context) % % auxiliary predicate for compiling coinductive/1 directives % % note that the clause order ensures that instantiation errors will be caught by % the call to the '$lgt_compile_coinductive_directive_resource'/1 predicate '$lgt_compile_coinductive_directive'([Pred| Preds], Ctx) :- '$lgt_compile_coinductive_directive_resource'(Pred, Ctx), '$lgt_compile_coinductive_directive'(Preds, Ctx). '$lgt_compile_coinductive_directive'([], _). '$lgt_compile_coinductive_directive_resource'(Pred, Ctx) :- '$lgt_valid_coinductive_template'(Pred, Functor, Arity, Head, TestHead, Template), !, ( '$lgt_pp_defines_predicate_'(Head, _, _, _, _, _) -> % coinductive/1 directives must precede the definitions for the declared predicates throw(permission_error(modify, predicate_interpretation, Functor/Arity)) ; true ), % construct functor for the auxiliary predicate atom_concat(Functor, '__coinductive', CFunctor), % construct functor for debugging calls to the auxiliary predicate atom_concat(Functor, '__coinduction_preflight', DFunctor), functor(DHead, DFunctor, Arity), Head =.. [_| Args], DHead =.. [_| Args], '$lgt_pp_entity_'(_, Entity, Prefix), '$lgt_compile_predicate_indicator'(Prefix, CFunctor/Arity, TCFunctor/TCArity), functor(TCHead, TCFunctor, TCArity), '$lgt_unify_head_thead_arguments'(Head, TCHead, HeadExCtx), '$lgt_compile_predicate_indicator'(Prefix, Functor/Arity, TFunctor/TArity), functor(THead, TFunctor, TArity), '$lgt_unify_head_thead_arguments'(Head, THead, BodyExCtx), '$lgt_source_file_context'(Ctx, File, Lines), assertz('$lgt_pp_coinductive_'(Head, TestHead, HeadExCtx, TCHead, BodyExCtx, THead, DHead, File, Lines)), assertz('$lgt_pp_coinductive_head_'(Head, HeadExCtx, TCHead)), assertz('$lgt_pp_runtime_clause_'('$lgt_predicate_property_'(Entity, Functor/Arity, coinductive(Template)))). '$lgt_compile_coinductive_directive_resource'(Pred, _) :- ground(Pred), throw(type_error(predicate_indicator, Pred)). '$lgt_compile_coinductive_directive_resource'(_, _) :- throw(instantiation_error). % coinductive success is achieved when the current hypothesis is already % present in the stack of previous hypothesis '$lgt_check_coinductive_success'(Hypothesis, [Hypothesis| _], Hypothesis). '$lgt_check_coinductive_success'(TestHead, [_| Stack], Hypothesis) :- '$lgt_check_coinductive_success'(TestHead, Stack, Hypothesis). '$lgt_valid_coinductive_template'(PredicateIndicator, Functor, Arity, Head, Head, Template) :- '$lgt_valid_predicate_indicator'(PredicateIndicator, Functor, Arity), !, functor(Head, Functor, Arity), '$lgt_construct_extended_coinductive_template'(Functor, Arity, Template). '$lgt_valid_coinductive_template'(NonTerminal, Functor, ExtendedArity, Head, Head, Template) :- '$lgt_valid_non_terminal_indicator'(NonTerminal, Functor, _, ExtendedArity), !, functor(Head, Functor, ExtendedArity), '$lgt_construct_extended_coinductive_template'(Functor, ExtendedArity, Template). '$lgt_valid_coinductive_template'(Template, Functor, Arity, Head, TestHead, Template) :- '$lgt_check'(callable, Template), '$lgt_check'(ground, Template), functor(Template, Functor, Arity), functor(Head, Functor, Arity), Template =.. [Functor| TemplateArgs], Head =.. [Functor| HeadArgs], '$lgt_map_coinductive_template_args'(TemplateArgs, HeadArgs, TestHeadArgs), TestHead =.. [Functor| TestHeadArgs]. % when the argument of the directive is a predicate (or non-terminal) indicator, % we construct an extended template for the predicate by making all arguments % relevant for testing for coinductive success '$lgt_construct_extended_coinductive_template'(Functor, Arity, Template) :- functor(Template, Functor, Arity), Template =.. [Functor| Args], '$lgt_construct_extended_coinductive_template_args'(Args). '$lgt_construct_extended_coinductive_template_args'([]). '$lgt_construct_extended_coinductive_template_args'([(+)| Args]) :- '$lgt_construct_extended_coinductive_template_args'(Args). % when only some arguments are relevant for testing for coinductive success, % we must construct a test head where non-relevant arguments are replaced by % anonymous variables as these will always unify with any term and thus prevent % these arguments of causing a failure when checking for coinductive success '$lgt_map_coinductive_template_args'([], [], []). '$lgt_map_coinductive_template_args'([(+)| TemplateArgs], [Arg| HeadArgs], [Arg| TestHeadArgs]) :- !, '$lgt_map_coinductive_template_args'(TemplateArgs, HeadArgs, TestHeadArgs). '$lgt_map_coinductive_template_args'([(-)| TemplateArgs], [_| HeadArgs], [_| TestHeadArgs]) :- '$lgt_map_coinductive_template_args'(TemplateArgs, HeadArgs, TestHeadArgs). % '$lgt_compile_uses_directive'(Aliases, Aliases, Ctx) % % auxiliary predicate for compiling uses/1 directives '$lgt_compile_uses_directive'([Alias| Aliases], Argument, Ctx) :- !, '$lgt_compile_uses_directive_alias'(Alias, Argument, Ctx), '$lgt_compile_uses_directive'(Aliases, Argument, Ctx). '$lgt_compile_uses_directive'([], _, _) :- !. '$lgt_compile_uses_directive'(_, Argument, _) :- throw(type_error(list, Argument)). '$lgt_compile_uses_directive_alias'(Obj as Alias, Argument, Ctx) :- var(Obj), '$lgt_pp_term_source_data_'((:- uses(Argument)), VariableNames, _, _, _), '$lgt_member'(VariableName=Variable, VariableNames), Obj == Variable, '$lgt_pp_parameter_variables_'(ParameterVariablePairs), '$lgt_member'(VariableName-_, ParameterVariablePairs), % object argument is a parameter variable !, '$lgt_check'(object_identifier, Alias), ( \+ \+ ('$lgt_pp_object_alias_'(Other, Alias, _, _, _), Obj == Other) -> throw(permission_error(repeat, object_alias, Alias)) ; \+ \+ '$lgt_pp_object_alias_'(_, Alias, _, _, _) -> throw(permission_error(modify, object_alias, Alias)) ; % use a minimal compilation-context to preserve the binding % between the parameter variable and the object argument '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), '$lgt_comp_ctx_exec_ctx'(NewCtx, ExCtx), '$lgt_source_file_context'(Ctx, File, Lines), assertz('$lgt_pp_object_alias_'(Obj, Alias, NewCtx, File, Lines)) ). '$lgt_compile_uses_directive_alias'(Obj as Alias, Argument, Ctx) :- !, '$lgt_check'(object_identifier, Obj), '$lgt_check'(object_identifier, Alias), ( \+ \+ '$lgt_pp_object_alias_'(Obj, Alias, _, _, _) -> throw(permission_error(repeat, object_alias, Alias)) ; \+ \+ '$lgt_pp_object_alias_'(_, Alias, _, _, _) -> throw(permission_error(modify, object_alias, Alias)) ; \+ \+ '$lgt_pp_object_alias_'(_, Obj, _, _, _) -> throw(permission_error(create, alias_alias, Alias)) ; '$lgt_variant'(Obj, Alias) -> throw(consistency_error(alias_different_from_original, Obj, Alias)) ; '$lgt_add_referenced_object'(Obj, Ctx), '$lgt_source_file_context'(Ctx, File, Lines), ( term_variables(Obj, Variables), '$lgt_pp_term_source_data_'((:- uses(Argument)), VariableNames, _, _, _), '$lgt_member'(VariableName=Variable, VariableNames), '$lgt_member_var'(Variable, Variables), '$lgt_pp_parameter_variables_'(ParameterVariablePairs), '$lgt_member'(VariableName-_, ParameterVariablePairs) -> % at least one of the object arguments is a parameter variable; % use a minimal compilation-context to preserve the binding % between the parameter variable and the object argument '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), '$lgt_comp_ctx_exec_ctx'(NewCtx, ExCtx), assertz('$lgt_pp_object_alias_'(Obj, Alias, NewCtx, File, Lines)) ; assertz('$lgt_pp_object_alias_'(Obj, Alias, _, File, Lines)) ) ). '$lgt_compile_uses_directive_alias'(Term, _, _) :- throw(type_error(object_alias, Term)). % '$lgt_compile_uses_directive'(+list, +list, @object_identifier, +boolean, +compilation_context) % % auxiliary predicate for compiling uses/2 directives; the boolean flag is true when the % object argument is or contains parameter variables '$lgt_compile_uses_directive'([Resource| Resources], Argument, Obj, Flag, Ctx) :- !, '$lgt_check'(nonvar, Resource), '$lgt_compile_uses_directive_resource'(Resource, Obj, Flag, Ctx), '$lgt_compile_uses_directive'(Resources, Argument, Obj, Flag, Ctx). '$lgt_compile_uses_directive'([], _, _, _, _) :- !. '$lgt_compile_uses_directive'(_, Argument, _, _, _) :- throw(type_error(list, Argument)). '$lgt_compile_uses_directive_resource'(op(Priority, Specifier, Operators), _, _, Ctx) :- '$lgt_check'(operator_specification, op(Priority, Specifier, Operators)), !, '$lgt_source_file_context'(Ctx, File, Lines), '$lgt_comp_ctx_mode'(Ctx, Mode), '$lgt_activate_entity_operators'(Priority, Specifier, Operators, l, File, Lines, Mode). '$lgt_compile_uses_directive_resource'(as(Original,Alias), Obj, Flag, Ctx) :- !, '$lgt_compile_uses_directive_resource'(Original::Alias, Obj, Flag, Ctx). '$lgt_compile_uses_directive_resource'(Original::Alias, Obj, Flag, Ctx) :- '$lgt_valid_predicate_indicator'(Original, OriginalFunctor, OriginalArity), '$lgt_valid_predicate_indicator'(Alias, AliasFunctor, AliasArity), !, ( Original == Alias -> throw(consistency_error(alias_different_from_original, Original, Alias)) ; OriginalArity =:= AliasArity -> '$lgt_compile_uses_directive_predicate_indicator'(OriginalFunctor, AliasFunctor, OriginalArity, Obj, Flag, Ctx) ; throw(consistency_error(same_arity, OriginalFunctor/OriginalArity, AliasFunctor/AliasArity)) ). '$lgt_compile_uses_directive_resource'(Original::Alias, Obj, Flag, Ctx) :- '$lgt_valid_non_terminal_indicator'(Original, OriginalFunctor, OriginalArity, ExtendedArity), '$lgt_valid_non_terminal_indicator'(Alias, AliasFunctor, AliasArity, _), !, ( Original == Alias -> throw(consistency_error(alias_different_from_original, Original, Alias)) ; OriginalArity =:= AliasArity -> '$lgt_compile_uses_directive_non_terminal_indicator'(OriginalFunctor, AliasFunctor, OriginalArity, ExtendedArity, Obj, Flag, Ctx) ; throw(consistency_error(same_arity, OriginalFunctor//OriginalArity, AliasFunctor//AliasArity)) ). '$lgt_compile_uses_directive_resource'(Original::Alias, Obj, Flag, Ctx) :- callable(Original), callable(Alias), !, '$lgt_compile_uses_directive_predicate_call'(Original, Alias, Obj, Flag, Ctx). '$lgt_compile_uses_directive_resource'(Pred, Obj, Flag, Ctx) :- '$lgt_valid_predicate_indicator'(Pred, Functor, Arity), !, '$lgt_compile_uses_directive_predicate_indicator'(Functor, Functor, Arity, Obj, Flag, Ctx). '$lgt_compile_uses_directive_resource'(NonTerminal, Obj, Flag, Ctx) :- '$lgt_valid_non_terminal_indicator'(NonTerminal, Functor, Arity, ExtArity), !, '$lgt_compile_uses_directive_non_terminal_indicator'(Functor, Functor, Arity, ExtArity, Obj, Flag, Ctx). '$lgt_compile_uses_directive_resource'(Resource, _, _, _) :- throw(type_error(predicate_indicator, Resource)). '$lgt_compile_uses_directive_predicate_indicator'(OriginalFunctor, AliasFunctor, Arity, Obj, Flag, Ctx) :- functor(Original, OriginalFunctor, Arity), functor(Alias, AliasFunctor, Arity), '$lgt_source_file_context'(Ctx, File, Lines, Type, Entity), ( '$lgt_pp_uses_predicate_'(Obj, Original, Alias, _, OriginalFile, OriginalLines) -> % predicate already listed in another uses/2 directive ( '$lgt_comp_ctx_mode'(Ctx, compile(user,_,_)), '$lgt_compiler_flag'(duplicated_directives, warning) -> '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(duplicated_directives), duplicated_predicate_reference(File, Lines, Type, Entity, Obj::AliasFunctor/Arity, OriginalFile, OriginalLines) ) ; true ) ; '$lgt_check_predicate_name_conflict'(uses, Alias, AliasFunctor/Arity), % unify arguments of TOriginal and TAlias Original =.. [_| Args], Alias =.. [_| Args], % allow for runtime use by adding a local definition that calls the remote definition % except when the remote is a built-in predicate in "user" with no alias being defined % or a built-in method that would clash with the local definition ( Obj == user, OriginalFunctor == AliasFunctor, '$lgt_predicate_property'(Original, built_in) -> % no need for a local definition true ; % add local definition '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, Prefix, _, _, ExCtx, _, _, Lines, _), '$lgt_comp_ctx'(AuxCtx, _, _, _, _, _, _, Prefix, _, _, ExCtx, compile(aux,_,_), _, Lines, _), '$lgt_compile_clause'((Alias :- Obj::Original), AuxCtx) ), % ensure that this uses/2 directive is found when looking for senders of this message '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), '$lgt_add_referenced_object_message'(Mode, Obj, Original, Alias, Alias), ( Flag == true -> % shared parameter variables; use a minimal compilation-context to preserve % the binding between any parameter variable and the object argument '$lgt_comp_ctx_exec_ctx'(NewCtx, ExCtx), assertz('$lgt_pp_uses_predicate_'(Obj, Original, Alias, NewCtx, File, Lines)), assertz('$lgt_pp_runtime_clause_'('$lgt_uses_predicate_'(Entity, Obj, Original, Alias, NewCtx))) ; assertz('$lgt_pp_uses_predicate_'(Obj, Original, Alias, _, File, Lines)), assertz('$lgt_pp_runtime_clause_'('$lgt_uses_predicate_'(Entity, Obj, Original, Alias, _))) ) ). '$lgt_compile_uses_directive_non_terminal_indicator'(OriginalFunctor, AliasFunctor, Arity, ExtArity, Obj, Flag, Ctx) :- functor(Original, OriginalFunctor, Arity), functor(Alias, AliasFunctor, Arity), '$lgt_source_file_context'(Ctx, File, Lines, Type, Entity), ( '$lgt_pp_uses_non_terminal_'(Obj, Original, Alias, _, _, _, OriginalFile, OriginalLines) -> % predicate already listed in another uses/2 directive ( '$lgt_comp_ctx_mode'(Ctx, compile(user,_,_)), '$lgt_compiler_flag'(duplicated_directives, warning) -> '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(duplicated_directives), duplicated_non_terminal_reference(File, Lines, Type, Entity, Obj::AliasFunctor//Arity, OriginalFile, OriginalLines) ) ; true ) ; functor(Pred, OriginalFunctor, ExtArity), functor(PredAlias, AliasFunctor, ExtArity), '$lgt_check_predicate_name_conflict'(uses, PredAlias, AliasFunctor//Arity), % unify arguments of TOriginal and TAlias Original =.. [_| Args], Alias =.. [_| Args], % allow for runtime use by adding a local definition that calls the remote definition % except when the remote is a built-in predicate in "user" with no alias being defined % or a built-in method that would clash with the local definition ( Obj == user, OriginalFunctor == AliasFunctor, '$lgt_predicate_property'(Pred, built_in) -> % no need for a local definition true ; % add local definition '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, Prefix, _, _, ExCtx, _, _, Lines, _), '$lgt_comp_ctx'(AuxCtx, _, _, _, _, _, _, Prefix, _, _, ExCtx, compile(aux,_,_), _, Lines, _), '$lgt_compile_grammar_rule'((Alias --> Obj::Original), AuxCtx) ), % ensure that the this uses/2 directive is found when looking for senders of this message '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), '$lgt_add_referenced_object_message'(Mode, Obj, Pred, PredAlias, PredAlias), ( Flag == true -> % shared parameter variables; use a minimal compilation-context to preserve % the binding between the parameter variable and the object argument '$lgt_comp_ctx_exec_ctx'(NewCtx, ExCtx), assertz('$lgt_pp_uses_non_terminal_'(Obj, Original, Alias, Pred, PredAlias, NewCtx, File, Lines)), assertz('$lgt_pp_runtime_clause_'('$lgt_uses_predicate_'(Entity, Obj, Pred, PredAlias, NewCtx))) ; assertz('$lgt_pp_uses_non_terminal_'(Obj, Original, Alias, Pred, PredAlias, _, File, Lines)), assertz('$lgt_pp_runtime_clause_'('$lgt_uses_predicate_'(Entity, Obj, Pred, PredAlias, _))) ) ). '$lgt_compile_uses_directive_predicate_call'(Original, Alias, Obj, Flag, Ctx) :- functor(Alias, AliasFunctor, Arity), '$lgt_source_file_context'(Ctx, File, Lines, Type, Entity), ( '$lgt_pp_uses_predicate_'(Obj, Original, Alias, _, OriginalFile, OriginalLines) -> % predicate already listed in another uses/2 directive ( '$lgt_comp_ctx_mode'(Ctx, compile(user,_,_)), '$lgt_compiler_flag'(duplicated_directives, warning) -> '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(duplicated_directives), duplicated_predicate_reference(File, Lines, Type, Entity, Obj::AliasFunctor/Arity, OriginalFile, OriginalLines) ) ; true ) ; '$lgt_check_predicate_name_conflict'(uses, Alias, AliasFunctor/Arity), % allow for runtime use by adding a local definition that calls the remote definition '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, Prefix, _, _, ExCtx, _, _, Lines, _), '$lgt_comp_ctx'(AuxCtx, _, _, _, _, _, _, Prefix, _, _, ExCtx, compile(aux,_,_), _, Lines, _), ( Obj == user -> '$lgt_compile_clause'((Alias :- {Original}), AuxCtx) ; '$lgt_compile_clause'((Alias :- Obj::Original), AuxCtx) ), % ensure that this uses/2 directive is found when looking for senders of this message '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), '$lgt_add_referenced_object_message'(Mode, Obj, Original, Alias, Alias), ( Flag == true -> % shared parameter variables; use a minimal compilation-context to preserve % the binding between any parameter variable and the object argument '$lgt_comp_ctx_exec_ctx'(NewCtx, ExCtx), assertz('$lgt_pp_uses_predicate_'(Obj, Original, Alias, NewCtx, File, Lines)), assertz('$lgt_pp_runtime_clause_'('$lgt_uses_predicate_'(Entity, Obj, Original, Alias, NewCtx))) ; assertz('$lgt_pp_uses_predicate_'(Obj, Original, Alias, _, File, Lines)), assertz('$lgt_pp_runtime_clause_'('$lgt_uses_predicate_'(Entity, Obj, Original, Alias, _))) ) ). % '$lgt_compile_use_module_directive'(Aliases, Aliases, Ctx) % % auxiliary predicate for compiling use_module/1 directives '$lgt_compile_use_module_directive'([Alias| Aliases], Argument, Ctx) :- !, '$lgt_compile_use_module_directive_alias'(Alias, Argument, Ctx), '$lgt_compile_use_module_directive'(Aliases, Argument, Ctx). '$lgt_compile_use_module_directive'([], _, _) :- !. '$lgt_compile_use_module_directive'(_, Argument, _) :- throw(type_error(list, Argument)). '$lgt_compile_use_module_directive_alias'(Module as Alias, Argument, Ctx) :- var(Module), '$lgt_pp_term_source_data_'((:- use_module(Argument)), VariableNames, _, _, _), '$lgt_member'(VariableName=Variable, VariableNames), Module == Variable, '$lgt_pp_parameter_variables_'(ParameterVariablePairs), '$lgt_member'(VariableName-_, ParameterVariablePairs), % module argument is a parameter variable !, '$lgt_check'(module_identifier, Alias), ( \+ \+ ('$lgt_pp_module_alias_'(Other, Alias, _, _, _), Module == Other) -> throw(permission_error(repeat, module_alias, Alias)) ; \+ \+ '$lgt_pp_module_alias_'(_, Alias, _, _, _) -> throw(permission_error(modify, module_alias, Alias)) ; % use a minimal compilation-context to preserve the binding % between the parameter variable and the module argument '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), '$lgt_comp_ctx_exec_ctx'(NewCtx, ExCtx), '$lgt_source_file_context'(Ctx, File, Lines), assertz('$lgt_pp_module_alias_'(Module, Alias, NewCtx, File, Lines)) ). '$lgt_compile_use_module_directive_alias'(Module as Alias, _, Ctx) :- !, '$lgt_check'(module_identifier, Module), '$lgt_check'(module_identifier, Alias), ( \+ \+ '$lgt_pp_module_alias_'(Module, Alias, _, _, _) -> throw(permission_error(repeat, module_alias, Alias)) ; \+ \+ '$lgt_pp_module_alias_'(_, Alias, _, _, _) -> throw(permission_error(modify, module_alias, Alias)) ; \+ \+ '$lgt_pp_module_alias_'(_, Module, _, _, _) -> throw(permission_error(create, module_alias, Alias)) ; Module == Alias -> throw(consistency_error(alias_different_from_original, Module, Alias)) ; '$lgt_add_referenced_module'(Module, Ctx), '$lgt_source_file_context'(Ctx, File, Lines), assertz('$lgt_pp_module_alias_'(Module, Alias, _, File, Lines)) ). '$lgt_compile_use_module_directive_alias'(Term, _, _) :- throw(type_error(module_alias, Term)). % '$lgt_compile_use_module_directive'(+list, +list, +atom, +compilation_context) % % auxiliary predicate for compiling use_module/2 directives in objects or categories; % the boolean flag is true when the module argument is a parameter variable '$lgt_compile_use_module_directive'([Resource| Resources], Argument, Module, Flag, Ctx) :- !, '$lgt_check'(nonvar, Resource), '$lgt_compile_use_module_directive_resource'(Resource, Module, Flag, Ctx), '$lgt_compile_use_module_directive'(Resources, Argument, Module, Flag, Ctx). '$lgt_compile_use_module_directive'([], _, _, _, _) :- !. '$lgt_compile_use_module_directive'(_, Argument, _, _, _) :- throw(type_error(list, Argument)). '$lgt_compile_use_module_directive_resource'(op(Priority, Specifier, Operators), _, _, Ctx) :- '$lgt_check'(operator_specification, op(Priority, Specifier, Operators)), !, '$lgt_source_file_context'(Ctx, File, Lines), '$lgt_comp_ctx_mode'(Ctx, Mode), '$lgt_activate_entity_operators'(Priority, Specifier, Operators, l, File, Lines, Mode). '$lgt_compile_use_module_directive_resource'(as(Original, Alias), Module, Flag, Ctx) :- !, '$lgt_compile_use_module_directive_resource'(':'(Original, Alias), Module, Flag, Ctx). '$lgt_compile_use_module_directive_resource'(':'(Original, Alias), Module, Flag, Ctx) :- '$lgt_valid_predicate_indicator'(Original, OriginalFunctor, OriginalArity), '$lgt_valid_predicate_indicator'(Alias, AliasFunctor, AliasArity), !, ( Original == Alias -> throw(consistency_error(alias_different_from_original, Original, Alias)) ; OriginalArity =:= AliasArity -> '$lgt_compile_use_module_directive_predicate_indicator'(OriginalFunctor, AliasFunctor, OriginalArity, Module, Flag, Ctx) ; throw(consistency_error(same_arity, OriginalFunctor/OriginalArity, AliasFunctor/AliasArity)) ). '$lgt_compile_use_module_directive_resource'(':'(Original, Alias), Module, Flag, Ctx) :- '$lgt_valid_non_terminal_indicator'(Original, OriginalFunctor, OriginalArity, ExtendedArity), '$lgt_valid_non_terminal_indicator'(Alias, AliasFunctor, AliasArity, _), !, ( Original == Alias -> throw(consistency_error(alias_different_from_original, Original, Alias)) ; OriginalArity =:= AliasArity -> '$lgt_compile_use_module_directive_non_terminal_indicator'(OriginalFunctor, AliasFunctor, OriginalArity, ExtendedArity, Module, Flag, Ctx) ; throw(consistency_error(same_arity, OriginalFunctor//OriginalArity, AliasFunctor//AliasArity)) ). '$lgt_compile_use_module_directive_resource'(':'(Original, Alias), Module, Flag, Ctx) :- callable(Original), callable(Alias), !, '$lgt_compile_use_module_directive_predicate_call'(Original, Alias, Module, Flag, Ctx). '$lgt_compile_use_module_directive_resource'(Pred, Module, Flag, Ctx) :- '$lgt_valid_predicate_indicator'(Pred, Functor, Arity), !, '$lgt_compile_use_module_directive_predicate_indicator'(Functor, Functor, Arity, Module, Flag, Ctx). '$lgt_compile_use_module_directive_resource'(NonTerminal, Module, Flag, Ctx) :- '$lgt_valid_non_terminal_indicator'(NonTerminal, Functor, Arity, ExtArity), !, '$lgt_compile_use_module_directive_non_terminal_indicator'(Functor, Functor, Arity, ExtArity, Module, Flag, Ctx). '$lgt_compile_use_module_directive_resource'(Resource, _, _, _) :- throw(type_error(predicate_indicator, Resource)). '$lgt_compile_use_module_directive_predicate_indicator'(OriginalFunctor, AliasFunctor, Arity, Module, Flag, Ctx) :- functor(Original, OriginalFunctor, Arity), functor(Alias, AliasFunctor, Arity), '$lgt_source_file_context'(Ctx, File, Lines, Type, Entity), ( '$lgt_pp_use_module_predicate_'(Module, Original, Alias, _, OriginalFile, OriginalLines) -> % predicate already listed in another uses/2 directive ( '$lgt_comp_ctx_mode'(Ctx, compile(user,_,_)), '$lgt_compiler_flag'(duplicated_directives, warning) -> '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(duplicated_directives), duplicated_predicate_reference(File, Lines, Type, Entity, ':'(Module, AliasFunctor/Arity), OriginalFile, OriginalLines) ) ; true ) ; '$lgt_check_predicate_name_conflict'(use_module, Alias, AliasFunctor/Arity), % unify arguments of TOriginal and TAlias Original =.. [_| Args], Alias =.. [_| Args], % allow for runtime use by adding a local definition that calls the remote definition % except when the remote is a built-in predicate in "user" with no alias being defined % or a built-in method that would clash with the local definition ( Module == user, OriginalFunctor == AliasFunctor, '$lgt_predicate_property'(Original, built_in) -> % no need for a local definition true ; % add local definition '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, Prefix, _, _, ExCtx, _, _, Lines, _), '$lgt_comp_ctx'(AuxCtx, _, _, _, _, _, _, Prefix, _, _, ExCtx, compile(aux,_,_), _, Lines, _), '$lgt_compile_clause'((Alias :- ':'(Module,Original)), AuxCtx) ), '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), % ensure that this use_module/2 directive is found when looking for callers of this module predicate '$lgt_add_referenced_module_predicate'(Mode, Module, Original, Alias, Alias), ( Flag == true -> % parameter variable; use a minimal compilation-context to preserve % the binding between the parameter variable and the module argument '$lgt_comp_ctx_exec_ctx'(NewCtx, ExCtx), assertz('$lgt_pp_use_module_predicate_'(Module, Original, Alias, NewCtx, File, Lines)), assertz('$lgt_pp_runtime_clause_'('$lgt_use_module_predicate_'(Entity, Module, Original, Alias, NewCtx))) ; assertz('$lgt_pp_use_module_predicate_'(Module, Original, Alias, _, File, Lines)), assertz('$lgt_pp_runtime_clause_'('$lgt_use_module_predicate_'(Entity, Module, Original, Alias, _))) ) ). '$lgt_compile_use_module_directive_non_terminal_indicator'(OriginalFunctor, AliasFunctor, Arity, ExtArity, Module, Flag, Ctx) :- functor(Original, OriginalFunctor, Arity), functor(Alias, AliasFunctor, Arity), '$lgt_source_file_context'(Ctx, File, Lines, Type, Entity), ( '$lgt_pp_use_module_non_terminal_'(Module, Original, Alias, _, _, _, OriginalFile, OriginalLines) -> % predicate already listed in another uses/2 directive ( '$lgt_comp_ctx_mode'(Ctx, compile(user,_,_)), '$lgt_compiler_flag'(duplicated_directives, warning) -> '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(duplicated_directives), duplicated_non_terminal_reference(File, Lines, Type, Entity, ':'(Module, AliasFunctor//Arity), OriginalFile, OriginalLines) ) ; true ) ; functor(Pred, AliasFunctor, ExtArity), functor(PredAlias, AliasFunctor, ExtArity), '$lgt_check_predicate_name_conflict'(use_module, PredAlias, AliasFunctor//Arity), % unify arguments of TOriginal and TAlias Original =.. [_| Args], Alias =.. [_| Args], % allow for runtime use by adding a local definition that calls the remote definition % except when the remote is a built-in predicate in "user" with no alias being defined % or a built-in method that would clash with the local definition ( Module == user, OriginalFunctor == AliasFunctor, '$lgt_predicate_property'(Pred, built_in) -> % no need for a local definition true ; % add local definition '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, Prefix, _, _, ExCtx, _, _, Lines, _), '$lgt_comp_ctx'(AuxCtx, _, _, _, _, _, _, Prefix, _, _, ExCtx, compile(aux,_,_), _, Lines, _), '$lgt_compile_grammar_rule'((Alias --> ':'(Module,Original)), AuxCtx) ), % ensure that the this use_module/2 directive is found when looking for callers of this module non-terminal '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), '$lgt_add_referenced_module_predicate'(Mode, Module, Pred, PredAlias, PredAlias), ( Flag == true -> % parameter variable; use a minimal compilation-context to preserve % the binding between the parameter variable and the object argument '$lgt_comp_ctx_exec_ctx'(NewCtx, ExCtx), assertz('$lgt_pp_use_module_non_terminal_'(Module, Original, Alias, Pred, PredAlias, NewCtx, File, Lines)), assertz('$lgt_pp_runtime_clause_'('$lgt_uses_predicate_'(Entity, Module, Pred, PredAlias, NewCtx))) ; assertz('$lgt_pp_use_module_non_terminal_'(Module, Original, Alias, Pred, PredAlias, _, File, Lines)), assertz('$lgt_pp_runtime_clause_'('$lgt_uses_predicate_'(Entity, Module, Pred, PredAlias, _))) ) ). '$lgt_compile_use_module_directive_predicate_call'(Original, Alias, Module, Flag, Ctx) :- functor(Alias, AliasFunctor, Arity), '$lgt_source_file_context'(Ctx, File, Lines, Type, Entity), ( '$lgt_pp_use_module_predicate_'(Module, Original, Alias, _, OriginalFile, OriginalLines) -> % predicate already listed in another uses/2 directive ( '$lgt_comp_ctx_mode'(Ctx, compile(user,_,_)), '$lgt_compiler_flag'(duplicated_directives, warning) -> '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(duplicated_directives), duplicated_predicate_reference(File, Lines, Type, Entity, ':'(Module, AliasFunctor/Arity), OriginalFile, OriginalLines) ) ; true ) ; '$lgt_check_predicate_name_conflict'(use_module, Alias, AliasFunctor/Arity), % allow for runtime use by adding a local definition that calls the remote definition '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, Prefix, _, _, ExCtx, _, _, Lines, _), '$lgt_comp_ctx'(AuxCtx, _, _, _, _, _, _, Prefix, _, _, ExCtx, compile(aux,_,_), _, Lines, _), ( Module == user -> '$lgt_compile_clause'((Alias :- {Original}), AuxCtx) ; '$lgt_compile_clause'((Alias :- ':'(Module,Original)), AuxCtx) ), '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), % ensure that this use_module/2 directive is found when looking for callers of this module predicate '$lgt_add_referenced_module_predicate'(Mode, Module, Original, Alias, Alias), ( Flag == true -> % parameter variable; use a minimal compilation-context to preserve % the binding between the parameter variable and the module argument '$lgt_comp_ctx_exec_ctx'(NewCtx, ExCtx), assertz('$lgt_pp_use_module_predicate_'(Module, Original, Alias, NewCtx, File, Lines)), assertz('$lgt_pp_runtime_clause_'('$lgt_use_module_predicate_'(Entity, Module, Original, Alias, NewCtx))) ; assertz('$lgt_pp_use_module_predicate_'(Module, Original, Alias, _, File, Lines)), assertz('$lgt_pp_runtime_clause_'('$lgt_use_module_predicate_'(Entity, Module, Original, Alias, _))) ) ). % auxiliary predicate for checking predicate name conflicts between % predicates listed in uses/2, use_module/2, and dynamic/1 directives '$lgt_check_predicate_name_conflict'(Directive, Alias, Culprit) :- ( '$lgt_built_in_method'(Alias, _, _, _) -> % clash with a built-in method, which cannot be redefined throw(permission_error(modify, built_in_method, Culprit)) ; '$lgt_pp_uses_predicate_'(Obj, _, Alias, _, _, _) -> % clash with an earlier uses/2 directive predicate throw(permission_error(modify, uses_object_predicate, Obj::Culprit)) ; '$lgt_pp_uses_non_terminal_'(Obj, _, _, _, Alias, _, _, _) -> % clash with an earlier uses/2 directive non-terminal throw(permission_error(modify, uses_object_non_terminal, Obj::Culprit)) ; '$lgt_pp_use_module_predicate_'(Module, _, Alias, _, _, _) -> % clash with an earlier use_module/2 directive predicate throw(permission_error(modify, uses_module_predicate, ':'(Module,Culprit))) ; '$lgt_pp_use_module_non_terminal_'(Module, _, _, _, Alias, _, _, _) -> % clash with an earlier use_module/2 directive non-terminal throw(permission_error(modify, uses_module_non_terminal, ':'(Module,Culprit))) ; Directive \== (dynamic), '$lgt_pp_dynamic_'(Alias, _, _, _) -> % clash with an earlier dynamic/1 directive (but allow duplicated dynamic/1 directives) throw(permission_error(modify, dynamic_predicate, Culprit)) ; true ). % '$lgt_compile_reexport_directive'(+list, +atom, +compilation_context) % % auxiliary predicate for compiling module reexport/2 directives; % the predicate renaming operator as/2 found on SWI-Prolog and YAP % is also supported (iff we're compiling a module as an object) '$lgt_compile_reexport_directive'([], _, _). '$lgt_compile_reexport_directive'([Resource| Resources], Module, Ctx) :- '$lgt_compile_reexport_directive_resource'(Resource, Module, Ctx), '$lgt_compile_reexport_directive'(Resources, Module, Ctx). '$lgt_compile_reexport_directive_resource'(op(Priority, Specifier, Operators), _, Ctx) :- '$lgt_check'(operator_specification, op(Priority, Specifier, Operators)), !, '$lgt_source_file_context'(Ctx, File, Lines), '$lgt_comp_ctx_mode'(Ctx, Mode), '$lgt_activate_entity_operators'(Priority, Specifier, Operators, l, File, Lines, Mode). '$lgt_compile_reexport_directive_resource'(as(Original, Alias), Module, Ctx) :- !, '$lgt_compile_reexport_directive_resource'(':'(Original, Alias), Module, Ctx). '$lgt_compile_reexport_directive_resource'(':'(Original, Alias), Module, Ctx) :- '$lgt_valid_predicate_indicator'(Original, OriginalFunctor, Arity), '$lgt_valid_predicate_indicator'(Alias, AliasFunctor, Arity), !, '$lgt_compile_logtalk_directive'(public(AliasFunctor/Arity), Ctx), functor(OriginalHead, OriginalFunctor, Arity), functor(AliasHead, AliasFunctor, Arity), % unify arguments of original and alias OriginalHead =.. [_| Args], AliasHead =.. [_| Args], % add local definition '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, Prefix, _, _, ExCtx, _, _, Lines, _), '$lgt_comp_ctx'(AuxCtxOriginal, _, _, _, _, _, _, Prefix, _, _, ExCtx, compile(aux,_,_), _, Lines, _), '$lgt_comp_ctx'(AuxCtxAlias, _, _, _, _, _, _, Prefix, _, _, ExCtx, compile(aux,_,_), _, Lines, _), '$lgt_compile_clause'((OriginalHead :- Module::OriginalHead), AuxCtxOriginal), '$lgt_compile_clause'((AliasHead :- Module::OriginalHead), AuxCtxAlias). '$lgt_compile_reexport_directive_resource'(':'(Original, Alias), Module, Ctx) :- '$lgt_valid_non_terminal_indicator'(Original, OriginalFunctor, Arity, _), '$lgt_valid_predicate_indicator'(Alias, AliasFunctor, Arity), !, '$lgt_compile_logtalk_directive'(public(AliasFunctor//Arity), Ctx), functor(OriginalHead, OriginalFunctor, Arity), functor(AliasHead, AliasFunctor, Arity), % unify arguments of original and alias OriginalHead =.. [_| Args], AliasHead =.. [_| Args], % add local definition '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, Prefix, _, _, ExCtx, _, _, Lines, _), '$lgt_comp_ctx'(AuxCtxOriginal, _, _, _, _, _, _, Prefix, _, _, ExCtx, compile(aux,_,_), _, Lines, _), '$lgt_comp_ctx'(AuxCtxAlias, _, _, _, _, _, _, Prefix, _, _, ExCtx, compile(aux,_,_), _, Lines, _), '$lgt_compile_grammar_rule'((OriginalHead --> Module::OriginalHead), AuxCtxOriginal), '$lgt_compile_grammar_rule'((AliasHead --> Module::OriginalHead), AuxCtxAlias). '$lgt_compile_reexport_directive_resource'(Pred, Module, Ctx) :- '$lgt_valid_predicate_indicator'(Pred, Functor, Arity), !, '$lgt_compile_logtalk_directive'(public(Pred), Ctx), functor(Head, Functor, Arity), % add local definition '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, Prefix, _, _, ExCtx, _, _, Lines, _), '$lgt_comp_ctx'(AuxCtx, _, _, _, _, _, _, Prefix, _, _, ExCtx, compile(aux,_,_), _, Lines, _), '$lgt_compile_clause'((Head :- Module::Head), AuxCtx). '$lgt_compile_reexport_directive_resource'(NonTerminal, Module, Ctx) :- '$lgt_valid_non_terminal_indicator'(NonTerminal, Functor, Arity, _), !, '$lgt_compile_logtalk_directive'(public(NonTerminal), Ctx), functor(Head, Functor, Arity), % add local definition '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, Prefix, _, _, ExCtx, _, _, Lines, _), '$lgt_comp_ctx'(AuxCtx, _, _, _, _, _, _, Prefix, _, _, ExCtx, compile(aux,_,_), _, Lines, _), '$lgt_compile_grammar_rule'((Head --> Module::Head), AuxCtx). '$lgt_compile_reexport_directive_resource'(Resource, _, _) :- ground(Resource), throw(type_error(predicate_indicator, Resource)). '$lgt_compile_reexport_directive_resource'(_, _, _) :- throw(instantiation_error). % auxiliary predicate for compiling module's meta predicate directives % into Logtalk ones by translating the meta-argument specifiers '$lgt_compile_module_meta_predicate_directive'([Template| Templates], [ConvertedTemplate| ConvertedTemplates]) :- '$lgt_compile_module_meta_predicate_directive_template'(Template, ConvertedTemplate), '$lgt_compile_module_meta_predicate_directive'(Templates, ConvertedTemplates). '$lgt_compile_module_meta_predicate_directive'([], []). '$lgt_compile_module_meta_predicate_directive_template'(':'(Module,Template), ':'(Module,ConvertedTemplate)) :- !, '$lgt_check'(module_identifier, Module), '$lgt_compile_module_meta_predicate_directive_template'(Template, ConvertedTemplate). '$lgt_compile_module_meta_predicate_directive_template'(Template, ConvertedTemplate) :- '$lgt_check'(callable, Template), Template =.. [Functor| Args], '$lgt_prolog_to_logtalk_meta_argument_specifiers'(Args, ConvertedArgs), ConvertedTemplate =.. [Functor| ConvertedArgs]. % '$lgt_check_for_duplicated_directive'(@callable, @callable) '$lgt_check_for_duplicated_directive'(TDirective, Directive) :- ( '$lgt_pp_directive_'(TDirective), '$lgt_compiler_flag'(duplicated_directives, warning) -> '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(duplicated_directives), duplicated_directive(File, Lines, Type, Entity, Directive) ) ; true ). % auxiliary predicate for translating Prolog dialect meta-argument % predicate specifiers into Logtalk specifiers '$lgt_prolog_to_logtalk_meta_argument_specifiers'([], []). '$lgt_prolog_to_logtalk_meta_argument_specifiers'([Arg| Args], [TArg| TArgs]) :- ( \+ ground(Arg) -> throw(instantiation_error) ; '$lgt_prolog_to_logtalk_meta_argument_specifier_hook'(Arg, TArg) -> true ; '$lgt_prolog_to_logtalk_meta_argument_specifier'(Arg, TArg) -> true ; throw(domain_error(meta_argument_specifier, Arg)) ), '$lgt_prolog_to_logtalk_meta_argument_specifiers'(Args, TArgs). % goals and closures are denoted by integers >= 0 '$lgt_prolog_to_logtalk_meta_argument_specifier'(N, N) :- integer(N), !. % Prolog to Logtalk notation; this is fragile due to the lack of standardization '$lgt_prolog_to_logtalk_meta_argument_specifier'((:), (::)). % mixed-up notation or overriding meta-predicate template being used '$lgt_prolog_to_logtalk_meta_argument_specifier'((::), (::)). % predicate indicator '$lgt_prolog_to_logtalk_meta_argument_specifier'((/), (/)). % non-terminal indicator '$lgt_prolog_to_logtalk_meta_argument_specifier'((//), (//)). % list of goals/closures '$lgt_prolog_to_logtalk_meta_argument_specifier'([N], [N]) :- integer(N), !. % list of predicate indicators '$lgt_prolog_to_logtalk_meta_argument_specifier'([/], [/]) :- !. % list of non-terminal indicators '$lgt_prolog_to_logtalk_meta_argument_specifier'([//], [//]) :- !. % goal with possible existential variables qualification '$lgt_prolog_to_logtalk_meta_argument_specifier'((^), (^)). % instantiation modes (non meta-arguments) '$lgt_prolog_to_logtalk_meta_argument_specifier'((@), (*)). '$lgt_prolog_to_logtalk_meta_argument_specifier'((+), (*)). '$lgt_prolog_to_logtalk_meta_argument_specifier'((-), (*)). '$lgt_prolog_to_logtalk_meta_argument_specifier'((?), (*)). % non meta-arguments '$lgt_prolog_to_logtalk_meta_argument_specifier'((*), (*)). % '$lgt_compile_object_relations'(@list(term), @object_identifier, @compilation_context) % % compiles the relations of an object with other entities '$lgt_compile_object_relations'([Relation| Relations], Obj, Ctx) :- ( var(Relation) -> throw(instantiation_error) ; '$lgt_compile_object_relation'(Relation, Obj, Ctx) -> true ; callable(Relation) -> functor(Relation, Functor, Arity), throw(domain_error(object_relation, Functor/Arity)) ; throw(type_error(callable, Relation)) ), '$lgt_compile_object_relations'(Relations, Obj, Ctx). '$lgt_compile_object_relations'([], _, _). % '$lgt_compile_object_relation'(@nonvar, @object_identifier, @compilation_context) % % compiles a relation between an object (the last argument) with other entities '$lgt_compile_object_relation'(implements(_), _, _) :- '$lgt_pp_implemented_protocol_'(_, _, _, _, _), throw(permission_error(repeat, entity_relation, implements/1)). '$lgt_compile_object_relation'(implements(Ptcs), Obj, Ctx) :- '$lgt_flatten_to_list'(Ptcs, FlattenedPtcs), '$lgt_compile_implements_protocol_relation'(FlattenedPtcs, Obj, Ctx). '$lgt_compile_object_relation'(imports(_), _, _) :- '$lgt_pp_imported_category_'(_, _, _, _, _, _), throw(permission_error(repeat, entity_relation, imports/1)). '$lgt_compile_object_relation'(imports(Ctgs), Obj, Ctx) :- '$lgt_flatten_to_list'(Ctgs, FlattenedCtgs), '$lgt_compile_imports_category_relation'(FlattenedCtgs, Obj, Ctx). '$lgt_compile_object_relation'(instantiates(_), _, _) :- '$lgt_pp_instantiated_class_'(_, _, _, _, _, _, _, _, _, _, _), throw(permission_error(repeat, entity_relation, instantiates/1)). '$lgt_compile_object_relation'(instantiates(Classes), Instance, Ctx) :- '$lgt_flatten_to_list'(Classes, FlattenedClasses), '$lgt_compile_instantiates_class_relation'(FlattenedClasses, Instance, Ctx). '$lgt_compile_object_relation'(specializes(_), _, _) :- '$lgt_pp_specialized_class_'(_, _, _, _, _, _, _, _, _, _, _), throw(permission_error(repeat, entity_relation, specializes/1)). '$lgt_compile_object_relation'(specializes(Superclasses), Class, Ctx) :- '$lgt_flatten_to_list'(Superclasses, FlattenedSuperclasses), '$lgt_compile_specializes_class_relation'(FlattenedSuperclasses, Class, Ctx). '$lgt_compile_object_relation'(extends(_), _, _) :- '$lgt_pp_extended_object_'(_, _, _, _, _, _, _, _, _, _, _), throw(permission_error(repeat, entity_relation, extends/1)). '$lgt_compile_object_relation'(extends(Parents), Prototype, Ctx) :- '$lgt_flatten_to_list'(Parents, FlattenedParents), '$lgt_compile_extends_object_relation'(FlattenedParents, Prototype, Ctx). % '$lgt_compile_protocol_relations'(@list(term), @protocol_identifier, @compilation_context) % % compiles the relations of a protocol with other entities '$lgt_compile_protocol_relations'([Relation| Relations], Ptc, Ctx) :- ( var(Relation) -> throw(instantiation_error) ; '$lgt_compile_protocol_relation'(Relation, Ptc, Ctx) -> true ; callable(Relation) -> functor(Relation, Functor, Arity), throw(domain_error(protocol_relation, Functor/Arity)) ; throw(type_error(callable, Relation)) ), '$lgt_compile_protocol_relations'(Relations, Ptc, Ctx). '$lgt_compile_protocol_relations'([], _, _). % '$lgt_compile_protocol_relation'(@nonvar, @protocol_identifier, @compilation_context) % % compiles a relation between a protocol (the last argument) with other entities '$lgt_compile_protocol_relation'(extends(_), _, _) :- '$lgt_pp_extended_protocol_'(_, _, _, _, _), throw(permission_error(repeat, entity_relation, extends/1)). '$lgt_compile_protocol_relation'(extends(Ptcs), Ptc, Ctx) :- '$lgt_flatten_to_list'(Ptcs, FlattenedPtcs), '$lgt_compile_extends_protocol_relation'(FlattenedPtcs, Ptc, Ctx). % '$lgt_compile_category_relations'(@list(term), @category_identifier, @compilation_context) % % compiles the relations of a category with other entities '$lgt_compile_category_relations'([Relation| Relations], Ctg, Ctx) :- ( var(Relation) -> throw(instantiation_error) ; '$lgt_compile_category_relation'(Relation, Ctg, Ctx) -> true ; callable(Relation) -> functor(Relation, Functor, Arity), throw(domain_error(category_relation, Functor/Arity)) ; throw(type_error(callable, Relation)) ), '$lgt_compile_category_relations'(Relations, Ctg, Ctx). '$lgt_compile_category_relations'([], _, _). % '$lgt_compile_category_relation'(@nonvar, @category_identifier, @compilation_context) % % compiles a relation between a category (the last argument) with other entities '$lgt_compile_category_relation'(implements(_), _, _) :- '$lgt_pp_implemented_protocol_'(_, _, _, _, _), throw(permission_error(repeat, entity_relation, implements/1)). '$lgt_compile_category_relation'(implements(Ptcs), Ctg, Ctx) :- '$lgt_flatten_to_list'(Ptcs, FlattenedPtcs), '$lgt_compile_implements_protocol_relation'(FlattenedPtcs, Ctg, Ctx). '$lgt_compile_category_relation'(extends(_), _, _) :- '$lgt_pp_extended_category_'(_, _, _, _, _, _), throw(permission_error(repeat, entity_relation, extends/1)). '$lgt_compile_category_relation'(extends(Ctgs), Ctg, Ctx) :- '$lgt_flatten_to_list'(Ctgs, FlattenedCtgs), '$lgt_compile_extends_category_relation'(FlattenedCtgs, Ctg, Ctx). '$lgt_compile_category_relation'(complements(_), _, _) :- '$lgt_pp_complemented_object_'(_, _, _, _, _), throw(permission_error(repeat, entity_relation, complements/1)). '$lgt_compile_category_relation'(complements(Objs), Ctg, Ctx) :- '$lgt_flatten_to_list'(Objs, FlattenedObjs), '$lgt_compile_complements_object_relation'(FlattenedObjs, Ctg, Ctx). % '$lgt_compile_entity_info_directive'(@list(term), -list(pair)) % % compiles the entity info/1 directive key-value pairs '$lgt_compile_entity_info_directive'([Pair| Pairs], [TPair| TPairs]) :- ( '$lgt_valid_info_key_value_pair'(Pair, Key, Value) -> '$lgt_compile_entity_info_directive_pair'(Key, Value, TPair), '$lgt_compile_entity_info_directive'(Pairs, TPairs) ; % non-valid pair; generate an error '$lgt_check'(key_value_info_pair, Pair) ). '$lgt_compile_entity_info_directive'([], []). % '$lgt_compile_entity_info_directive_pair'(+atom, @nonvar, -compound) % % compiles an entity info/1 directive key-value pair '$lgt_compile_entity_info_directive_pair'(author, Author, author(Author)) :- !, ( Author = {EntityName}, atom(EntityName) -> true ; '$lgt_check'(atom_or_string, Author) ). '$lgt_compile_entity_info_directive_pair'(comment, Comment, comment(Comment)) :- !, '$lgt_check'(atom_or_string, Comment). '$lgt_compile_entity_info_directive_pair'(date, Date, date(Date)) :- !, ( Date = Year-Month-Day -> % ISO 8601 standard format '$lgt_check'(non_negative_integer, Year), '$lgt_check'(non_negative_integer, Month), '$lgt_check'(non_negative_integer, Day) ; Date = Year/Month/Day -> % deprecated format '$lgt_check'(non_negative_integer, Year), '$lgt_check'(non_negative_integer, Month), '$lgt_check'(non_negative_integer, Day) ; throw(type_error(date, Date)) ). '$lgt_compile_entity_info_directive_pair'(parameters, Parameters, parameters(Parameters)) :- !, '$lgt_pp_entity_'(_, Entity, _), functor(Entity, _, Arity), '$lgt_check_entity_info_parameters'(Parameters, Entity, Parameters, 0, Arity). '$lgt_compile_entity_info_directive_pair'(parnames, Parnames, parnames(Parnames)) :- !, '$lgt_pp_entity_'(_, Entity, _), functor(Entity, _, Arity), '$lgt_check_entity_info_parnames'(Parnames, Entity, Parnames, 0, Arity). '$lgt_compile_entity_info_directive_pair'(remarks, Remarks, remarks(Remarks)) :- !, '$lgt_check'(list, Remarks), ( '$lgt_member'(Remark, Remarks), \+ '$lgt_valid_remark'(Remark) -> throw(type_error(remark, Remark)) ; true ). '$lgt_compile_entity_info_directive_pair'(see_also, References, see_also(References)) :- !, '$lgt_check'(list(entity_identifier), References). '$lgt_compile_entity_info_directive_pair'(version, Version, version(Version)) :- !, ( Version = ':'(Major, ':'(Minor, Patch)) -> '$lgt_check'(non_negative_integer, Major), '$lgt_check'(non_negative_integer, Minor), '$lgt_check'(non_negative_integer, Patch) ; % deprecated format '$lgt_check'(atomic_or_string, Version) ). '$lgt_compile_entity_info_directive_pair'(copyright, Copyright, copyright(Copyright)) :- !, ( Copyright = {EntityName}, atom(EntityName) -> true ; '$lgt_check'(atom_or_string, Copyright) ). '$lgt_compile_entity_info_directive_pair'(license, License, license(License)) :- !, ( License = {EntityName}, atom(EntityName) -> true ; '$lgt_check'(atom_or_string, License) ). % user-defined entity info pair; no checking '$lgt_compile_entity_info_directive_pair'(Key, Value, TPair) :- TPair =.. [Key, Value]. '$lgt_check_entity_info_parameters'([Pair| Pairs], Entity, Parameters, Counter0, Arity) :- !, ( Pair = Name - Description -> '$lgt_check'(atom_or_string, Name), '$lgt_check'(atom_or_string, Description), Counter1 is Counter0 + 1, '$lgt_check_entity_info_parameters'(Pairs, Entity, Parameters, Counter1, Arity) ; throw(type_error(pair, Pair)) ). '$lgt_check_entity_info_parameters'([], Entity, Parameters, Counter, Arity) :- !, ( Counter =:= Arity -> true ; throw(consistency_error(same_number_of_parameters, Entity, Parameters)) ). '$lgt_check_entity_info_parameters'(_, _, Parameters, _, _) :- throw(type_error(list, Parameters)). '$lgt_check_entity_info_parnames'([Name| Names], Entity, Parnames, Counter0, Arity) :- !, '$lgt_check'(atom_or_string, Name), Counter1 is Counter0 + 1, '$lgt_check_entity_info_parnames'(Names, Entity, Parnames, Counter1, Arity). '$lgt_check_entity_info_parnames'([], Entity, Parnames, Counter, Arity) :- !, ( Counter =:= Arity -> true ; throw(consistency_error(same_number_of_parameters, Entity, Parnames)) ). '$lgt_check_entity_info_parnames'(_, _, Parnames, _, _) :- throw(type_error(list, Parnames)). % '$lgt_compile_predicate_info_directive'(@list(term), +atom, +integer, -list(pair)) % % compiles the predicate info/2 directive key-value pairs '$lgt_compile_predicate_info_directive'([Pair| Pairs], Functor, Arity, [TPair| TPairs]) :- ( '$lgt_valid_info_key_value_pair'(Pair, Key, Value) -> '$lgt_compile_predicate_info_directive_pair'(Key, Value, Functor, Arity, TPair), '$lgt_compile_predicate_info_directive'(Pairs, Functor, Arity, TPairs) ; % non-valid pair; generate an error '$lgt_check'(key_value_info_pair, Pair) ). '$lgt_compile_predicate_info_directive'([], _, _, []). % '$lgt_compile_predicate_info_directive_pair'(+atom, @nonvar, +atom, +integer, -compound) % % compiles a predicate info/2 directive key-value pair '$lgt_compile_predicate_info_directive_pair'(allocation, Allocation, _, _, allocation(Allocation)) :- !, '$lgt_check'(atom, Allocation), ( '$lgt_valid_predicate_allocation'(Allocation) -> true ; throw(domain_error(allocation, Allocation)) ). '$lgt_compile_predicate_info_directive_pair'(arguments, Arguments, Functor, Arity, arguments(Arguments)) :- !, '$lgt_check_predicate_info_arguments'(Arguments, Arguments, 0, Functor, Arity). '$lgt_compile_predicate_info_directive_pair'(argnames, Argnames, Functor, Arity, argnames(Argnames)) :- !, '$lgt_check_predicate_info_argnames'(Argnames, Argnames, 0, Functor, Arity). '$lgt_compile_predicate_info_directive_pair'(comment, Comment, _, _, comment(Comment)) :- !, '$lgt_check'(atom_or_string, Comment). '$lgt_compile_predicate_info_directive_pair'(fails_if, FailsIf, _, _, fails_if(FailsIf)) :- !, '$lgt_check'(atom_or_string, FailsIf). '$lgt_compile_predicate_info_directive_pair'(exceptions, Exceptions, _, _, exceptions(Exceptions)) :- !, '$lgt_check'(list, Exceptions), ( '$lgt_member'(Exception, Exceptions), \+ '$lgt_valid_predicate_exception'(Exception) -> throw(type_error(exception, Exception)) ; true ). '$lgt_compile_predicate_info_directive_pair'(remarks, Remarks, _, _, remarks(Remarks)) :- !, '$lgt_check'(list, Remarks), ( '$lgt_member'(Remark, Remarks), \+ '$lgt_valid_remark'(Remark) -> throw(type_error(remark, Remark)) ; true ). '$lgt_compile_predicate_info_directive_pair'(examples, Examples, Functor, Arity, examples(Examples)) :- !, '$lgt_check'(list, Examples), ( '$lgt_member'(Example, Examples), \+ '$lgt_valid_predicate_call_example'(Example, Functor, Arity) -> throw(type_error(example, Example)) ; true ). '$lgt_compile_predicate_info_directive_pair'(redefinition, Redefinition, _, _, redefinition(Redefinition)) :- !, '$lgt_check'(atom, Redefinition), ( '$lgt_valid_predicate_redefinition'(Redefinition) -> true ; throw(domain_error(redefinition, Redefinition)) ). '$lgt_compile_predicate_info_directive_pair'(see_also, References, _, _, see_also(References)) :- !, '$lgt_check'(list(predicate_or_non_terminal_indicator), References). '$lgt_compile_predicate_info_directive_pair'(since, Version, _, _, since(Version)) :- !, ( Version = ':'(Major, ':'(Minor, Patch)) -> '$lgt_check'(non_negative_integer, Major), '$lgt_check'(non_negative_integer, Minor), '$lgt_check'(non_negative_integer, Patch) ; throw(domain_error(since, Version)) ). % user-defined predicate info pair; no checking '$lgt_compile_predicate_info_directive_pair'(Key, Value, _, _, TPair) :- TPair =.. [Key, Value]. '$lgt_check_predicate_info_arguments'([Pair| Pairs], Arguments, Counter0, Functor, Arity) :- !, ( Pair = Name - Description -> '$lgt_check'(atom_or_string, Name), '$lgt_check'(atom_or_string, Description), Counter1 is Counter0 + 1, '$lgt_check_predicate_info_arguments'(Pairs, Arguments, Counter1, Functor, Arity) ; throw(type_error(pair, Pair)) ). '$lgt_check_predicate_info_arguments'([], Arguments, Counter, Functor, Arity) :- !, ( Counter =:= Arity -> true ; throw(consistency_error(same_number_of_arguments, Functor/Arity, Arguments)) ). '$lgt_check_predicate_info_arguments'(_, Arguments, _, _, _) :- throw(type_error(list, Arguments)). '$lgt_check_predicate_info_argnames'([Name| Names], Argnames, Counter0, Functor, Arity) :- !, '$lgt_check'(atom_or_string, Name), Counter1 is Counter0 + 1, '$lgt_check_predicate_info_argnames'(Names, Argnames, Counter1, Functor, Arity). '$lgt_check_predicate_info_argnames'([], Argnames, Counter, Functor, Arity) :- !, ( Counter =:= Arity -> true ; throw(consistency_error(same_number_of_arguments, Functor/Arity, Argnames)) ). '$lgt_check_predicate_info_argnames'(_, Argnames, _, _, _) :- throw(type_error(list, Argnames)). % '$lgt_compile_grammar_rule'(+grammar_rule, +compilation_context) '$lgt_compile_grammar_rule'(GrammarRule, Ctx) :- catch( '$lgt_dcg_rule'(GrammarRule, Clause, Ctx), Error, throw(error(Error, grammar_rule(GrammarRule))) ), '$lgt_compile_clause'(Clause, Ctx). % '$lgt_compile_clause'(+clause, +compilation_context) % % compiles a source file clause '$lgt_compile_clause'(Clause, Ctx) :- '$lgt_pp_entity_'(Type, Entity, Prefix), % compiling an entity clause ( Type == protocol -> % protocols cannot contain predicate definitions throw(error(permission_error(define, predicate, Entity), clause(Clause))) ; true ), '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, Prefix, _, _, _, Mode, _, Lines, _), catch( '$lgt_compile_clause'(Clause, Entity, TClause, DClause, Ctx), Error, throw(error(Error, clause(Clause))) ), % successful first stage compilation; save the source data information for % use in the second compiler stage (where it might be required by calls % to the logtalk_load_context/2 predicate during goal expansion or when % checking for duplicated clauses) ( '$lgt_pp_term_source_data_'(Term, VariableNames, Singletons, File, Lines) -> SourceData = sd(Term, VariableNames, Singletons, File, Lines) ; SourceData = nil ), % check which compile clause to save (normal/optimal or debug) and % if we have a clause defined by the user or an auxiliary clause ( '$lgt_compiler_flag'(debug, on) -> ( Mode = compile(aux,_,_) -> assertz('$lgt_pp_entity_aux_clause_'(DClause)) ; assertz('$lgt_pp_entity_term_'(DClause, SourceData, Lines)) ) ; ( Mode = compile(aux,_,_) -> assertz('$lgt_pp_entity_aux_clause_'(TClause)) ; assertz('$lgt_pp_entity_term_'(TClause, SourceData, Lines)) ) ), !. '$lgt_compile_clause'(Clause, _) :- \+ '$lgt_pp_entity_'(_, _, _), % clause occurs before an opening entity directive !, ( '$lgt_pp_term_source_data_'(_, _, _, _, Lines) -> true ; Lines = '-'(-1, -1) ), % copy the clause unchanged to the generated Prolog file assertz('$lgt_pp_prolog_term_'(Clause, Lines)). '$lgt_compile_clause'(Clause, _) :- % deal with unexpected clause translation failures throw(error(system_error, clause(Clause))). % '$lgt_compile_clause'(+clause, +entity_identifier, -clause, -clause, +compilation_context) % % compiles an entity clause into a normal clause and a debug clause % % in this first compiler stage only the clause heads are compiled, which % allows collecting information about all entity defined predicates; the % compilation of clause bodies is delayed to the compiler second stage to % take advantage of the collected information to notably simplify handling % of redefined built-in predicates % % in the case of a clause rule for a multifile predicate, the clause body % is compiled in the context of the entity defining the clause; still, any % calls to the parameter/2 method in the clause body will access parameters % for the defining entity; parameters for the entity for which the clause % is defined can be accessed through simple unification at the clause head '$lgt_compile_clause'((Head :- Body), _, _, _, Ctx) :- ( '$lgt_variant'(Body, Head) -> true ; Body = (Goal, _), '$lgt_variant'(Goal, Head) ), '$lgt_comp_ctx_term'(Ctx, Term), callable(Term), \+ functor(Term, (-->), 2), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(left_recursion, warning), \+ '$lgt_pp_coinductive_'(Head, _, _, _, _, _, _, _, _), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(left_recursion), left_recursion(File, Lines, Type, Entity, (Head :- Body)) ), fail. '$lgt_compile_clause'((Head:-Body), Entity, TClause, DClause, Ctx) :- !, '$lgt_check'(callable, Head, clause((Head:-Body))), '$lgt_head_meta_variables'(Head, MetaVars), '$lgt_comp_ctx'(Ctx, Head, ExCtx, _, Sender, This, Self, Prefix, MetaVars, MetaCallCtx, ExCtx, Mode, Stack, _, Term), '$lgt_source_file_context'(Ctx, File, BeginLine-EndLine), '$lgt_compile_head'(Head, PI, THead, Ctx), ( Head = {UserHead} -> % clause for a multifile predicate in "user" DHead = '$lgt_debug'(rule(Entity, user::UserHead, N, File, BeginLine), ExCtx), '$lgt_comp_ctx'(BodyCtx, Head, ExCtx, _, _, _, _, Prefix, MetaVars, _, BodyExCtx, Mode, _, BeginLine-EndLine, Term), '$lgt_execution_context_this_entity'(ExCtx, _, user), % ensure that ::/1-2 and ^^/2 calls are compiled in the correct context ( '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _) -> '$lgt_execution_context'(BodyExCtx, Entity, Entity, Entity, Entity, [], []) ; % category '$lgt_execution_context'(BodyExCtx, Entity, Sender, This, Self, MetaCallCtx, Stack) ) ; Head = Other::OtherHead -> % clause for an object or category multifile predicate DHead = '$lgt_debug'(rule(Entity, Head, N, File, BeginLine), ExCtx), '$lgt_comp_ctx'(BodyCtx, Head, ExCtx, _, _, _, _, Prefix, MetaVars, _, BodyExCtx, Mode, _, BeginLine-EndLine, Term), term_variables(Other, OtherVars), term_variables((OtherHead:-Body), ClauseVars), '$lgt_intersection'(OtherVars, ClauseVars, CommonVars), ( CommonVars == [] -> true ; % parametric entity sharing variables with the clause '$lgt_execution_context_this_entity'(ExCtx, _, Other) ), % ensure that ::/1-2 and ^^/2 calls are compiled in the correct context ( '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _) -> '$lgt_execution_context'(BodyExCtx, Entity, Entity, Entity, Entity, [], []) ; % category '$lgt_execution_context'(BodyExCtx, Entity, Sender, This, Self, MetaCallCtx, Stack) ) ; Head = ':'(_, _) -> % clause for a module multifile predicate DHead = '$lgt_debug'(rule(Entity, Head, N, File, BeginLine), ExCtx), '$lgt_comp_ctx'(BodyCtx, Head, ExCtx, _, _, _, _, Prefix, MetaVars, _, BodyExCtx, Mode, _, BeginLine-EndLine, Term), % ensure that ::/1-2 and ^^/2 calls are compiled in the correct context ( '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _) -> '$lgt_execution_context'(BodyExCtx, Entity, Entity, Entity, Entity, [], []) ; % category '$lgt_execution_context'(BodyExCtx, Entity, Sender, This, Self, MetaCallCtx, Stack) ) ; % clause for a local predicate DHead = '$lgt_debug'(rule(Entity, Head, N, File, BeginLine), ExCtx), BodyCtx = Ctx ), ( '$lgt_pp_dynamic_'(Head, _, _, _) -> TClause = drule(THead, '$lgt_nop'(Body), Body, BodyCtx), DClause = ddrule(THead, '$lgt_nop'(Body), DHead, Body, BodyCtx) ; TClause = srule(THead, Body, BodyCtx), DClause = dsrule(THead, DHead, Body, BodyCtx) ), '$lgt_clause_number'(PI, rule, File, BeginLine-EndLine, N). '$lgt_compile_clause'(Fact, Entity, fact(TFact,Ctx), dfact(TFact,DHead,Ctx), Ctx) :- '$lgt_check'(callable, Fact, clause(Fact)), '$lgt_compile_head'(Fact, PI, TFact, Ctx), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), '$lgt_source_file_context'(Ctx, File, BeginLine-EndLine), ( Fact = {UserFact} -> % fact for a multifile predicate in "user" DHead = '$lgt_debug'(fact(Entity, user::UserFact, N, File, BeginLine), ExCtx) ; Fact = Other::OtherFact -> % fact for an entity multifile predicate DHead = '$lgt_debug'(fact(Entity, Fact, N, File, BeginLine), ExCtx), term_variables(Other, OtherVars), term_variables(OtherFact, OtherFactVars), '$lgt_intersection'(OtherVars, OtherFactVars, CommonVars), ( CommonVars == [] -> true ; % parametric entity sharing variables with the fact '$lgt_comp_ctx'(Ctx, _, _, Other, _, _, _, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, _, Other) ) ; Fact = ':'(_, _) -> % fact for a module multifile predicate DHead = '$lgt_debug'(fact(Entity, Fact, N, File, BeginLine), ExCtx) ; var(ExCtx) -> % local fact DHead = '$lgt_debug'(fact(Entity, Fact, N, File, BeginLine), ExCtx) ; % parameter variables shared via the execution context '$lgt_unify_head_thead_arguments'(Fact, TFact, ExCtx), DHead = '$lgt_debug'(fact(Entity, Fact, N, File, BeginLine), ExCtx) ), '$lgt_clause_number'(PI, fact, File, BeginLine-EndLine, N). % '$lgt_clause_number'(@callable, +atom, +atom, +integer, -integer) % % returns the clause number for a compiled predicate; when the clause is the % first one for the predicate, we also save the definition line in the source % file (assuming that we're not compiling a clause for a dynamically created % entity) for use with the reflection built-in predicates and methods '$lgt_clause_number'(Other::Functor/Arity, fact, File, Lines, Clauses) :- !, % object or category multifile predicate ( retract('$lgt_pp_number_of_clauses_rules_'(Other, Functor, Arity, Clauses0, Rules)) -> Clauses is Clauses0 + 1 ; % first clause found for this predicate Clauses = 1, Rules = 0, assertz('$lgt_pp_predicate_definition_location_'(Other, Functor, Arity, File, Lines)) ), assertz('$lgt_pp_number_of_clauses_rules_'(Other, Functor, Arity, Clauses, Rules)). '$lgt_clause_number'(Other::Functor/Arity, rule, File, Lines, Clauses) :- % object or category multifile predicate ( retract('$lgt_pp_number_of_clauses_rules_'(Other, Functor, Arity, Clauses0, Rules0)) -> Clauses is Clauses0 + 1, Rules is Rules0 + 1 ; % first clause found for this predicate Clauses = 1, Rules = 1, assertz('$lgt_pp_predicate_definition_location_'(Other, Functor, Arity, File, Lines)) ), assertz('$lgt_pp_number_of_clauses_rules_'(Other, Functor, Arity, Clauses, Rules)). % module multifile predicate clause '$lgt_clause_number'(':'(_, _), _, _, _, 0). '$lgt_clause_number'({Head}, Kind, File, Lines, Clauses) :- % pre-compiled predicate clause head '$lgt_clause_number'(user::Head, Kind, File, Lines, Clauses). '$lgt_clause_number'(Functor/Arity, fact, File, Lines, Clauses) :- !, % predicate clause for the entity being compiled ( retract('$lgt_pp_number_of_clauses_rules_'(Functor, Arity, Clauses0, Rules)) -> Clauses is Clauses0 + 1 ; % first clause found for this predicate Clauses = 1, Rules = 0, assertz('$lgt_pp_predicate_definition_location_'(Functor, Arity, File, Lines)) ), assertz('$lgt_pp_number_of_clauses_rules_'(Functor, Arity, Clauses, Rules)). '$lgt_clause_number'(Functor/Arity, rule, File, Lines, Clauses) :- % predicate clause for the entity being compiled ( retract('$lgt_pp_number_of_clauses_rules_'(Functor, Arity, Clauses0, Rules0)) -> Clauses is Clauses0 + 1, Rules is Rules0 + 1 ; % first clause found for this predicate Clauses = 1, Rules = 1, assertz('$lgt_pp_predicate_definition_location_'(Functor, Arity, File, Lines)) ), assertz('$lgt_pp_number_of_clauses_rules_'(Functor, Arity, Clauses, Rules)). % '$lgt_compile_head'(+callable, -callable, -callable, +compilation_context) % % compiles an entity clause head; also returns a term constructed from the % head predicate indicator to be used as key to compute the clause number % pre-compiled clause head (we only check for basic instantiation and type errors) '$lgt_compile_head'({Head}, {Functor/Arity}, Head, _) :- !, '$lgt_check'(callable, Head), functor(Head, Functor, Arity). % not the first clause for this predicate; reuse the compiled head template % % we must ensure that Mode is the same to prevent that the auxiliary clauses % created for uses/2 and use_module/2 directives would result in a cached % template being reused for a conflicting user-defined predicate '$lgt_compile_head'(Head, Functor/Arity, THead, Ctx) :- '$lgt_pp_defines_predicate_'(Head, Functor/Arity, ExCtx, THead, Mode, Origin), '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), !, % only check for a discontiguous predicate for user-defined predicates ( '$lgt_pp_previous_predicate_'(Head, Origin) -> true ; Origin == aux -> true ; % clauses for the predicate are discontiguous '$lgt_check_discontiguous_directive'(Head, Ctx) ). % definition of dynamic predicates inside categories is not allowed '$lgt_compile_head'(Head, _, _, _) :- '$lgt_pp_category_'(_, _, _, _, _, _), '$lgt_pp_dynamic_'(Head, _, _, _), functor(Head, Functor, Arity), throw(permission_error(define, dynamic_predicate, Functor/Arity)). % redefinition of Logtalk built-in methods is not allowed '$lgt_compile_head'(Head, _, _, _) :- '$lgt_built_in_method'(Head, _, _, Flags), Head \= _::_, Head \= ':'(_, _), % not a clause for a multifile predicate Flags /\ 2 =\= 2, % not a (user defined) dynamic built-in predicate functor(Head, Functor, Arity), throw(permission_error(modify, built_in_method, Functor/Arity)). % conflict with a predicate specified in a uses/2 directive '$lgt_compile_head'(Alias, _, _, _) :- '$lgt_pp_uses_predicate_'(Obj, _, Alias, _, _, _), functor(Alias, Functor, Arity), throw(permission_error(modify, uses_object_predicate, Obj::Functor/Arity)). % conflict with a predicate specified in a use_module/2 directive '$lgt_compile_head'(Alias, _, _, _) :- '$lgt_pp_use_module_predicate_'(Module, _, Alias, _, _, _), functor(Alias, Functor, Arity), throw(permission_error(modify, uses_module_predicate, ':'(Module,Functor/Arity))). % definition of a reserved predicate without reference to the built-in protocol declaring it '$lgt_compile_head'(Head, _, _, Ctx) :- '$lgt_reserved_predicate_protocol'(Head, Protocol), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(general, warning), \+ '$lgt_pp_module_'(_), \+ '$lgt_pp_implemented_protocol_'(Protocol, _, _, _, _), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(general), missing_reference_to_built_in_protocol(File, Lines, Type, Entity, Protocol) ), fail. % compile the head of a clause of another entity predicate (which we check if declared multifile) '$lgt_compile_head'(Other::Head, _, _, _) :- '$lgt_check'(entity_identifier, Other), '$lgt_check'(callable, Head), fail. '$lgt_compile_head'(user::Head, user::Functor/Arity, Head, _) :- !, functor(Head, Functor, Arity), ( '$lgt_pp_directive_'(multifile(Functor/Arity)) -> true ; '$lgt_pp_missing_multifile_directive_'(user::Functor/Arity, _, _) -> true ; '$lgt_source_file_context'(File, Lines), assertz('$lgt_pp_missing_multifile_directive_'(user::Functor/Arity, File, Lines)) ). '$lgt_compile_head'(Other::Head, Other::Functor/Arity, THead, Ctx) :- !, functor(Head, Functor, Arity), '$lgt_entity_to_prefix'(Other, Prefix), '$lgt_compile_predicate_indicator'(Prefix, Functor/Arity, TFunctor/TArity), ( '$lgt_pp_directive_'(multifile(TFunctor/TArity)) -> true ; throw(existence_error(directive, multifile(Other::Functor/Arity))) ), functor(THead, TFunctor, TArity), '$lgt_unify_head_thead_arguments'(Head, THead, ExCtx), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx). % compile the head of a clause of a module predicate (which we check if declared multifile) '$lgt_compile_head'(':'(Module, Head), ':'(Module, Functor/Arity), THead, _) :- !, '$lgt_check'(callable, Head), functor(Head, Functor, Arity), ( Module == user -> THead = Head ; '$lgt_check'(module_identifier, Module), THead = ':'(Module, Head) ), ( Module == user, '$lgt_pp_directive_'(multifile(Functor/Arity)) -> true ; '$lgt_pp_directive_'(multifile(':'(Module, Functor/Arity))) -> true ; '$lgt_pp_missing_multifile_directive_'(':'(Module,Functor/Arity), _, _) -> true ; '$lgt_source_file_context'(File, Lines), assertz('$lgt_pp_missing_multifile_directive_'(':'(Module,Functor/Arity), File, Lines)) ). % compile the head of a clause of a user defined predicate '$lgt_compile_head'(Head, Functor/Arity, THead, Ctx) :- % first clause for this predicate functor(Head, Functor, Arity), ( '$lgt_pp_dynamic_'(Head, _, _, _), \+ '$lgt_pp_public_'(Functor, Arity, _, _), \+ '$lgt_pp_protected_'(Functor, Arity, _, _), \+ '$lgt_pp_private_'(Functor, Arity, _, _) -> % dynamic predicate without a scope directive; can be abolished if declared % in an object and the abolish message sender is the object itself '$lgt_add_ddef_clause'(Head, Functor, Arity, THead, Ctx) ; % static predicate and/or scoped dynamic predicate; cannot be abolished '$lgt_add_def_clause'(Head, Functor, Arity, THead, Ctx) ). % '$lgt_compile_body'(@term, @callable, -callable, -callable, +compilation_context) % % compiles an entity clause body % runtime resolved meta-calls '$lgt_compile_body'(Pred, Caller, TPred, '$lgt_debug'(goal(Pred, TPred), HeadExCtx), Ctx) :- var(Pred), !, '$lgt_comp_ctx'(Ctx, Head, HeadExCtx, _, _, _, _, _, MetaVars, _, _, Mode, _, _, _), '$lgt_check_for_meta_predicate_directive'(Mode, Head, Pred), ( '$lgt_member_var'(Pred, MetaVars) -> TPred = '$lgt_metacall'(Pred, HeadExCtx, runtime) ; TPred = '$lgt_metacall'(Pred, HeadExCtx, local) ), ( Caller == rule, '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(suspicious_calls, warning), '$lgt_source_file_context'(File, Lines, Type, Entity) -> '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(suspicious_calls), suspicious_call(File, Lines, Type, Entity, Pred, [call(Pred)]) ) ; true ). % compiler bypass control construct (opaque to cuts) '$lgt_compile_body'({Pred}, _, _, _, Ctx) :- callable(Pred), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(suspicious_calls, warning), ( Pred = call(Goal) -> % redundant call/1 wrapper Alternatives = [{Goal}] ; '$lgt_iso_spec_predicate'(Pred), \+ '$lgt_built_in_method'(Pred, _, _, _), % not a Logtalk built-in method that have a Prolog counterpart \+ '$lgt_control_construct'(Pred), \+ '$lgt_pp_defines_predicate_'(Pred, _, _, _, _, _), % call to a standard Prolog predicate that is not being locally redefined, Alternatives = [Pred] ), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(suspicious_calls), suspicious_call(File, Lines, Type, Entity, {Pred}, Alternatives) ), fail. '$lgt_compile_body'({Pred}, _, TPred, '$lgt_debug'(goal({Pred}, TPred), ExCtx), Ctx) :- !, '$lgt_check'(var_or_callable, Pred), '$lgt_comp_ctx'(Ctx, Head, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), ( var(Pred) -> TPred = call(Pred), '$lgt_check_for_meta_predicate_directive'(Mode, Head, Pred) ; Pred == ! -> TPred = true ; '$lgt_cut_transparent_control_construct'(Pred) -> % we need to keep the call/1 wrapper to preserve {}/1 cut-opaque semantics TPred = call(Pred) ; TPred = Pred ). % protect goal from further goal expansion % %'$lgt_compile_body'(@Pred, _, TPred, DPred, Ctx) :- % !, % '$lgt_check'(var_or_callable, Pred), % '$lgt_comp_ctx_mode'(Ctx, Mode), % ( Mode == runtime -> % '$lgt_compile_body'(Pred, _, TPred, DPred, Ctx) % ; Mode = compile(How, Cut, _), % '$lgt_comp_ctx'(Ctx, Head, HeadExCtx, Entity, Sender, This, Self, Prefix, MetaVars, MetaCallCtx, ExCtx, _, Stack, Lines, Term), % '$lgt_comp_ctx'(NewCtx, Head, HeadExCtx, Entity, Sender, This, Self, Prefix, MetaVars, MetaCallCtx, ExCtx, compile(How,Cut,[Pred]), Stack, Lines, Term), % '$lgt_compile_body'(Pred, _, TPred, DPred, NewCtx) % ). % goal expansion (only applied at compile-time) '$lgt_compile_body'(Pred, Caller, TPred, DPred, Ctx) :- '$lgt_comp_ctx'(Ctx, Head, HeadExCtx, Entity, Sender, This, Self, Prefix, MetaVars, MetaCallCtx, ExCtx, compile(How,Cut,ExpandedGoals), Stack, Lines, Term), '$lgt_push_if_new'(ExpandedGoals, Pred, NewExpandedGoals), '$lgt_expand_file_goal'(Pred, ExpandedPred), Pred \== ExpandedPred, !, '$lgt_comp_ctx'(NewCtx, Head, HeadExCtx, Entity, Sender, This, Self, Prefix, MetaVars, MetaCallCtx, ExCtx, compile(How,Cut,NewExpandedGoals), Stack, Lines, Term), '$lgt_compile_body'(ExpandedPred, Caller, TPred, DPred, NewCtx). % message delegation (send a message while preserving the original sender) '$lgt_compile_body'([Goal], _, _, _, _) :- '$lgt_check'(callable, Goal), \+ functor(Goal, (::), 2), throw(domain_error(message_sending_goal, Goal)). '$lgt_compile_body'([Alias::Pred], Caller, TPred, DPred, Ctx) :- callable(Alias), '$lgt_pp_object_alias_'(Obj, Alias, Ctx, _, _), !, '$lgt_compile_body'([Obj::Pred], Caller, TPred, DPred, Ctx). '$lgt_compile_body'([Obj::Pred], _, TPred, '$lgt_debug'(goal([Obj::Pred], TPred), ExCtx), Ctx) :- !, % as delegation keeps the original sender, we cannot use a recursive call % to the '$lgt_compile_body'/4 predicate to compile the ::/2 goal as that % would reset the sender to "this" '$lgt_comp_ctx'(Ctx, Head, _, _, Sender, _, Self, Prefix, MetaVars, MetaCallCtx, ExCtx, Mode, Stack, Lines, Term), ( '$lgt_pp_meta_predicate_'(Head, _, _, _) -> '$lgt_execution_context'(ExCtx, _, Sender, _, _, MetaCallCtx, _), '$lgt_comp_ctx'(NewCtx, Head, _, _, Sender, Sender, Self, Prefix, MetaVars, _, MetaCallCtx, Mode, Stack, Lines, Term) ; '$lgt_comp_ctx'(Ctx, Head, _, _, Sender, This, Self, Prefix, MetaVars, MetaCallCtx, ExCtx, Mode, Stack, Lines, Term), '$lgt_execution_context'(ExCtx, Entity, Sender, This, Self, MetaCallCtx, Stack), '$lgt_comp_ctx'(NewCtx, Head, _, _, Sender, Sender, Self, Prefix, MetaVars, MetaCallCtx, NewExCtx, Mode, Stack, Lines, Term), '$lgt_execution_context'(NewExCtx, Entity, Sender, Sender, Self, MetaCallCtx, Stack) ), '$lgt_compiler_flag'(events, Events), '$lgt_compile_message_to_object'(Pred, Obj, TPred0, Events, NewCtx), % ensure that this control construct cannot be used to break object encapsulation TPred = (Obj \= Sender -> TPred0; throw(error(permission_error(access,object,Sender), logtalk([Obj::Pred],ExCtx)))). % existential quantifier outside bagof/3 and setof/3 calls '$lgt_compile_body'(_^_, _, _, _, _) :- % in some unusual cases, the user may be defining a (^)/2 predicate ... \+ '$lgt_pp_defines_predicate_'(_^_, _, _, _, _, _), % ... but otherwise (^)/2 cannot be used outside bagof/3 and setof/3 calls throw(existence_error(procedure, (^)/2)). % control constructs '$lgt_compile_body'((Pred, _), _, _, _, Ctx) :- callable(Pred), '$lgt_comp_ctx'(Ctx, Head, _, _, _, _, _, _, _, _, _, compile(_,_,_), _, _, _), callable(Head), % ignore multifile predicates Head \= ':'(_, _), Head \= _::_, functor(Pred, Functor, Arity), functor(Head, Functor, Arity), % non-tail recursive predicate definition ( '$lgt_pp_non_tail_recursive_predicate_'(Functor, Arity, _, _) -> true ; '$lgt_source_file_context'(File, Lines), assertz('$lgt_pp_non_tail_recursive_predicate_'(Functor, Arity, File, Lines)) ), fail. '$lgt_compile_body'((Pred1, Pred2), Caller, (TPred1, TPred2), (DPred1, DPred2), Ctx) :- !, '$lgt_compile_body'(Pred1, Caller, TPred1, DPred1, Ctx), ( TPred1 == repeat, % check if the repeat loop ends with a cut if compiling a source file '$lgt_comp_ctx'(Ctx, Head, HeadExCtx, Entity, Sender, This, Self, Prefix, MetaVars, MetaCallCtx, ExCtx, compile(How,_,ExpandedGoals), Stack, Lines, Term) -> '$lgt_comp_ctx'(NewCtx, Head, HeadExCtx, Entity, Sender, This, Self, Prefix, MetaVars, MetaCallCtx, ExCtx, compile(How,Cut,ExpandedGoals), Stack, Lines, Term), '$lgt_compile_body'(Pred2, Caller, TPred2, DPred2, NewCtx), ( var(Cut), % no cut found; note that this lint check is limited to conjunctions where % the left side is a call to repeat/0 and the right side contains a cut '$lgt_compiler_flag'(suspicious_calls, warning), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(suspicious_calls), suspicious_call(File, Lines, Type, Entity, repeat, reason(repeat(Head))) ) -> true ; % cut found true ) ; '$lgt_compile_body'(Pred2, Caller, TPred2, DPred2, Ctx) ). '$lgt_compile_body'((If -> _; _), _, _, _, Ctx) :- nonvar(If), once((If = (Term1 = Term2); If = (Term1 \= Term2))), once((number(Term1); number(Term2))), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(suspicious_calls, warning), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(arithmetic_expressions), suspicious_call(File, Lines, Type, Entity, If, reason(comparing_numbers_using_unification)) ), fail. '$lgt_compile_body'((If -> _; _), _, _, _, Ctx) :- nonvar(If), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(conditionals, warning), ( If == ! -> Message = suspicious_cut_in_if_then_else(File, Lines, Type, Entity, Head) ; If = (Goal, _), Goal == !, Message = suspicious_cut_in_if_then_else(File, Lines, Type, Entity, Head, If) ), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_comp_ctx_head'(Ctx, Head), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'(warning(conditionals), Message), fail. '$lgt_compile_body'((If -> _; _), _, _, _, Ctx) :- nonvar(If), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(conditionals, warning), If = (Term1 = Term2), ( var(Term1), ground(Term2) -> true ; ground(Term1), var(Term2) ), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_comp_ctx_head'(Ctx, Head), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(conditionals), suspicious_if_then_else_test(File, Lines, Type, Entity, Head, If) ), fail. '$lgt_compile_body'((IfThen; Else), Caller, (TIf -> TThen; TElse), (DIf -> DThen; DElse), Ctx) :- nonvar(IfThen), IfThen = (If -> Then), !, '$lgt_compile_body'(If, meta, TIf, DIf, Ctx), '$lgt_compile_body'(Then, Caller, TThen, DThen, Ctx), '$lgt_compile_body'(Else, Caller, TElse, DElse, Ctx). '$lgt_compile_body'((SoftCut; _), _, _, _, Ctx) :- nonvar(SoftCut), SoftCut = '*->'(If, _), nonvar(If), '$lgt_predicate_property'('*->'(_, _), built_in), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(conditionals, warning), ( If == ! -> Message = suspicious_cut_in_soft_cut(File, Lines, Type, Entity, Head) ; If = (Goal, _), Goal == !, Message = suspicious_cut_in_soft_cut(File, Lines, Type, Entity, Head, If) ), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_comp_ctx_head'(Ctx, Head), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'(warning(conditionals), Message), fail. '$lgt_compile_body'((SoftCut; _), _, _, _, Ctx) :- nonvar(SoftCut), SoftCut = '*->'(If, _), nonvar(If), '$lgt_predicate_property'('*->'(_, _), built_in), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(conditionals, warning), If = (Term1 = Term2), ( var(Term1), ground(Term2) -> true ; ground(Term1), var(Term2) ), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_comp_ctx_head'(Ctx, Head), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(conditionals), suspicious_soft_cut_test(File, Lines, Type, Entity, Head, If) ), fail. '$lgt_compile_body'((SoftCut; Else), _, ('*->'(TIf, TThen); TElse), ('*->'(DIf, DThen); DElse), Ctx) :- nonvar(SoftCut), SoftCut = '*->'(If, Then), '$lgt_predicate_property'('*->'(_, _), built_in), !, '$lgt_compile_body'(If, meta, TIf, DIf, Ctx), '$lgt_compile_body'(Then, Caller, TThen, DThen, Ctx), '$lgt_compile_body'(Else, Caller, TElse, DElse, Ctx). '$lgt_compile_body'((Pred1; Pred2), _, _, _, Ctx) :- nonvar(Pred1), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(disjunctions, warning), ( Pred1 == ! -> Message = suspicious_cut_in_disjunction(File, Lines, Type, Entity, Head) ; Pred1 = (Goal, _), Goal == !, Message = suspicious_cut_in_disjunction(File, Lines, Type, Entity, Head, (Pred1; Pred2)) ), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_comp_ctx_head'(Ctx, Head), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'(warning(disjunctions), Message), fail. '$lgt_compile_body'((Pred1; Pred2), _, _, _, Ctx) :- '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(disjunctions, warning), '$lgt_comp_ctx_term'(Ctx, (Head :- (Pred11; Pred22))), (Pred1; Pred2) == (Pred11; Pred22), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(disjunctions), disjunction_as_body(File, Lines, Type, Entity, Head, (Pred1; Pred2)) ), fail. '$lgt_compile_body'((Pred1; Pred2), Caller, (TPred1; TPred2), (DPred1; DPred2), Ctx) :- !, '$lgt_compile_body'(Pred1, Caller, TPred10, DPred10, Ctx), '$lgt_fix_disjunction_left_side'(TPred10, TPred1), '$lgt_fix_disjunction_left_side'(DPred10, DPred1), '$lgt_compile_body'(Pred2, Caller, TPred2, DPred2, Ctx). '$lgt_compile_body'('*->'(Pred1, Pred2), Caller, TPred2, DPred2, Ctx) :- Pred1 == otherwise, '$lgt_predicate_property'(otherwise, built_in), '$lgt_predicate_property'('*->'(_, _), built_in), !, ( '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(deprecated, warning) -> '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(deprecated), deprecated_construct(File, Lines, Type, Entity, '*->'(Pred1, Pred2), Pred2) ) ; true ), '$lgt_compile_body'(Pred2, Caller, TPred2, DPred2, Ctx). '$lgt_compile_body'('*->'(If, _), _, _, _, Ctx) :- '$lgt_predicate_property'('*->'(_, _), built_in), nonvar(If), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(conditionals, warning), ( If == ! -> Message = suspicious_cut_in_soft_cut(File, Lines, Type, Entity, Head) ; If = (Goal, _), Goal == !, Message = suspicious_cut_in_soft_cut(File, Lines, Type, Entity, Head, If) ), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_comp_ctx_head'(Ctx, Head), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'(warning(conditionals), Message), fail. '$lgt_compile_body'('*->'(If, _), _, _, _, Ctx) :- '$lgt_predicate_property'('*->'(_, _), built_in), nonvar(If), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(conditionals, warning), If = (Term1 = Term2), ( var(Term1), ground(Term2) -> true ; ground(Term1), var(Term2) ), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_comp_ctx_head'(Ctx, Head), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(conditionals), suspicious_soft_cut_test(File, Lines, Type, Entity, Head, If) ), fail. '$lgt_compile_body'('*->'(Pred1, Pred2), _, _, _, Ctx) :- '$lgt_predicate_property'('*->'(_, _), built_in), callable(Pred1), callable(Pred2), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(conditionals, warning), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(conditionals), missing_else_part(File, Lines, Type, Entity, '*->'(Pred1, Pred2)) ), fail. '$lgt_compile_body'('*->'(Pred1, Pred2), Caller, '*->'(TPred1, TPred2), '*->'(DPred1, DPred2), Ctx) :- '$lgt_predicate_property'('*->'(_, _), built_in), !, '$lgt_compile_body'(Pred1, meta, TPred1, DPred1, Ctx), '$lgt_compile_body'(Pred2, Caller, TPred2, DPred2, Ctx). '$lgt_compile_body'((Pred1 -> Pred2), Caller, TPred2, DPred2, Ctx) :- Pred1 == otherwise, '$lgt_predicate_property'(otherwise, built_in), !, ( '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(deprecated, warning) -> '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(deprecated), deprecated_construct(File, Lines, Type, Entity, (Pred1 -> Pred2), Pred2) ) ; true ), '$lgt_compile_body'(Pred2, Caller, TPred2, DPred2, Ctx). '$lgt_compile_body'((If -> _), _, _, _, Ctx) :- nonvar(If), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(conditionals, warning), ( If == ! -> Message = suspicious_cut_in_if_then_else(File, Lines, Type, Entity, Head) ; If = (Goal, _), Goal == !, Message = suspicious_cut_in_if_then_else(File, Lines, Type, Entity, Head, If) ), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_comp_ctx_head'(Ctx, Head), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'(warning(conditionals), Message), fail. '$lgt_compile_body'((If -> _), _, _, _, Ctx) :- nonvar(If), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(conditionals, warning), If = (Term1 = Term2), ( var(Term1), ground(Term2) -> true ; ground(Term1), var(Term2) ), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_comp_ctx_head'(Ctx, Head), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(conditionals), suspicious_if_then_else_test(File, Lines, Type, Entity, Head, If) ), fail. '$lgt_compile_body'((Pred1 -> Pred2), _, _, _, Ctx) :- callable(Pred1), callable(Pred2), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(conditionals, warning), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(conditionals), missing_else_part(File, Lines, Type, Entity, (Pred1 -> Pred2)) ), fail. '$lgt_compile_body'((Pred1 -> Pred2), Caller, (TPred1 -> TPred2), (DPred1 -> DPred2), Ctx) :- !, '$lgt_compile_body'(Pred1, meta, TPred1, DPred1, Ctx), '$lgt_compile_body'(Pred2, Caller, TPred2, DPred2, Ctx). '$lgt_compile_body'(not(Pred), Caller, TPred, DPred, Ctx) :- '$lgt_prolog_built_in_predicate'(not(_)), \+ '$lgt_pp_defines_predicate_'(not(_), _, _, _, _, _), !, ( '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(deprecated, warning), '$lgt_source_file_context'(File, Lines), '$lgt_pp_entity_'(Type, Entity, _) -> '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(deprecated), deprecated_predicate(File, Lines, Type, Entity, (not)/1, (\+)/1) ) ; true ), '$lgt_compile_body'(\+ Pred, Caller, TPred, DPred, Ctx). '$lgt_compile_body'(fail_if(Pred), Caller, TPred, DPred, Ctx) :- '$lgt_prolog_built_in_predicate'(fail_if(_)), \+ '$lgt_pp_defines_predicate_'(fail_if(_), _, _, _, _, _), !, ( '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(deprecated, warning), '$lgt_source_file_context'(File, Lines), '$lgt_pp_entity_'(Type, Entity, _) -> '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(deprecated), deprecated_predicate(File, Lines, Type, Entity, fail_if/1, (\+)/1) ) ; true ), '$lgt_compile_body'(\+ Pred, Caller, TPred, DPred, Ctx). '$lgt_compile_body'(\+ Pred, _, _, _, Ctx) :- callable(Pred), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_negated_goal_alternative'(Pred, Alt), '$lgt_compiler_flag'(suspicious_calls, warning), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(suspicious_calls), suspicious_call(File, Lines, Type, Entity, \+ Pred, [Alt]) ), fail. '$lgt_compile_body'(\+ Pred, _, \+ TPred, '$lgt_debug'(goal(\+ Pred, \+ DPred), ExCtx), Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), '$lgt_compile_body'(Pred, meta, TPred, DPred, Ctx). % warning on cuts on clauses for multifile predicates '$lgt_compile_body'(!, _, _, _, Ctx) :- '$lgt_comp_ctx'(Ctx, Head, _, _, _, _, _, _, _, _, _, compile(_,_,_), _, Lines, _), callable(Head), ( Head = _::_ -> true ; Head = ':'(_, _) -> true ; '$lgt_pp_multifile_'(Head, _, _, _) ), % clause for a multifile predicate '$lgt_compiler_flag'(suspicious_calls, warning), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(suspicious_calls), suspicious_call(File, Lines, Type, Entity, !, reason(multifile(Head))) ), fail. % warning on cuts on clauses with variable aliasing in the head '$lgt_compile_body'(!, _, _, _, Ctx) :- '$lgt_comp_ctx'(Ctx, Head, _, _, _, _, _, _, _, _, _, compile(_,_,_), _, Lines, _), '$lgt_compiler_flag'(steadfastness, warning), '$lgt_variable_aliasing'(Head), functor(Head, Functor, Arity), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', ( '$lgt_pp_defines_non_terminal_'(Functor, Arity2, Arity) -> '$lgt_print_message'( warning(steadfastness), possible_non_steadfast_non_terminal(File, Lines, Type, Entity, Functor//Arity2) ) ; '$lgt_print_message'( warning(steadfastness), possible_non_steadfast_predicate(File, Lines, Type, Entity, Functor/Arity) ) ), fail. % when processing the debug event, the compiled goal is meta-called but % this would make the cut local, changing the semantics of the user code; % the solution is to use a conjunction for the debug goal of the debug % event with a cut '$lgt_compile_body'(!, _, !, ('$lgt_debug'(goal(!, true), ExCtx), !), Ctx) :- !, '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), ( Mode == runtime -> true ; % remember that we found a cut to enable lint checks on repeat loops Mode = compile(_, true, _) ). '$lgt_compile_body'(true, _, true, '$lgt_debug'(goal(true, true), ExCtx), Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx). '$lgt_compile_body'(fail, _, fail, '$lgt_debug'(goal(fail, fail), ExCtx), Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx). '$lgt_compile_body'(false, _, false, '$lgt_debug'(goal(false, false), ExCtx), Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx). '$lgt_compile_body'(repeat, _, repeat, '$lgt_debug'(goal(repeat, repeat), ExCtx), Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx). '$lgt_compile_body'(call(Goal), _, _, _, Ctx) :- callable(Goal), \+ '$lgt_cut_transparent_control_construct'(Goal), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(suspicious_calls, warning), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(suspicious_calls), suspicious_call(File, Lines, Type, Entity, call(Goal), [Goal]) ), fail. '$lgt_compile_body'(call(Goal), _, TPred, '$lgt_debug'(goal(call(Goal), DPred), ExCtx), Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), '$lgt_compile_body'(Goal, meta, TGoal, DGoal, Ctx), ( functor(TGoal, '$lgt_metacall', _) -> TPred = TGoal, DPred = DGoal ; '$lgt_cut_transparent_control_construct'(TGoal) -> % we need to keep the call/1 wrapper to preserve call/1 cut-opaque semantics TPred = call(TGoal), DPred = call(DGoal) ; TPred = TGoal, DPred = DGoal ). '$lgt_compile_body'('$lgt_callN'(Closure, ExtraArgs), _, _, _, Ctx) :- var(Closure), '$lgt_comp_ctx'(Ctx, Head, _, _, _, _, _, _, MetaVars, _, _, _, _, _, _), nonvar(Head), % ignore multifile predicates Head \= ':'(_, _), Head \= _::_, '$lgt_pp_meta_predicate_'(Head, Meta, _, _), % we're compiling a clause for a meta-predicate once('$lgt_member_var'(Closure, MetaVars)), % the closure is a meta-argument '$lgt_length'(ExtraArgs, 0, NExtraArgs), Meta =.. [_| MetaArgs], % check that the call/N call complies with the meta-predicate declaration '$lgt_not_same_meta_arg_extra_args'(MetaArgs, MetaVars, Closure, NExtraArgs), % generate the call/N meta template findall('*', '$lgt_between'(1, NExtraArgs, _), Stars), CallN =.. [call, NExtraArgs| Stars], throw(consistency_error(same_closure_specification, CallN, Meta)). '$lgt_compile_body'('$lgt_callN'(Closure, ExtraArgs), _, TPred, DPred, Ctx) :- !, '$lgt_comp_ctx'(Ctx, Head, HeadExCtx, _, _, _, _, _, MetaVars, _, _, Mode, _, _, _), ( var(Closure) -> % we're compiling a runtime meta-call '$lgt_check_for_meta_predicate_directive'(Mode, Head, Closure), ( '$lgt_member_var'(Closure, MetaVars) -> TPred = '$lgt_metacall'(Closure, ExtraArgs, HeadExCtx, runtime) ; TPred = '$lgt_metacall'(Closure, ExtraArgs, HeadExCtx, local) ) ; '$lgt_extend_closure'(Closure, ExtraArgs, Goal, Ctx), \+ (functor(Goal, call, Arity), Arity >= 2) -> % not a call to call/2-N itself; safe to compile it '$lgt_compile_body'(Goal, meta, TPred0, _, Ctx), ( '$lgt_cut_transparent_control_construct'(TPred0) -> % we need to keep the call/1 wrapper to preserve call/2-N cut-opaque semantics TPred = call(TPred0) ; TPred = TPred0 ) ; % runtime resolved meta-call (e.g., a lambda expression) TPred = '$lgt_metacall'(Closure, ExtraArgs, HeadExCtx, local) ), CallN =.. [call, Closure| ExtraArgs], DPred = '$lgt_debug'(goal(CallN, TPred), HeadExCtx). '$lgt_compile_body'(once(Goal), _, (TGoal -> true), '$lgt_debug'(goal(once(Goal), (DGoal -> true)), ExCtx), Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), '$lgt_compile_body'(Goal, meta, TGoal, DGoal, Ctx). '$lgt_compile_body'(ignore(Goal), _, (TGoal -> true; true), '$lgt_debug'(goal(ignore(Goal), (DGoal -> true; true)), ExCtx), Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), '$lgt_compile_body'(Goal, meta, TGoal, DGoal, Ctx). % error handling and throwing predicates '$lgt_compile_body'(catch(Goal, Catcher, Recovery), _, _, _, Ctx) :- var(Catcher), term_variables(Recovery, Variables), \+ '$lgt_member_var'(Catcher, Variables), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(catchall_catch, warning), % reinstate relation between term variables and their names '$lgt_comp_ctx_term'(Ctx, OriginalTerm), '$lgt_pp_term_source_data_'(OriginalTerm, VariableNames, _, _, _), \+ ( '$lgt_member'(_=Var, VariableNames), Catcher == Var ), % assume that Catcher is an anonymous variable '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(catchall_catch), catchall_catch(File, Lines, Type, Entity, catch(Goal, Catcher, Recovery)) ), fail. '$lgt_compile_body'(catch(Goal, Catcher, Recovery), _, catch(TGoal, Catcher, TRecovery), '$lgt_debug'(goal(catch(Goal, Catcher, Recovery), catch(DGoal, Catcher, DRecovery)), ExCtx), Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), '$lgt_compile_body'(Goal, meta, TGoal, DGoal, Ctx), '$lgt_compile_body'(Recovery, meta, TRecovery, DRecovery, Ctx). '$lgt_compile_body'(throw(Error), _, throw(Error), '$lgt_debug'(goal(throw(Error), throw(Error)), ExCtx), Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx). '$lgt_compile_body'(Pred, _, TPred, DPred, Ctx) :- '$lgt_built_in_error_method'(Pred), !, '$lgt_compile_error_method'(Pred, TPred, DPred, Ctx). % type testing (only lint warnings) '$lgt_compile_body'(var(Var), _, _, _, Ctx) :- var(Var), '$lgt_comp_ctx_mode'(Ctx, compile(user,_,_)), '$lgt_compiler_flag'(always_true_or_false_goals, warning), % reinstate relation between term variables and their names '$lgt_comp_ctx_term'(Ctx, OriginalTerm), '$lgt_pp_term_source_data_'(OriginalTerm, VariableNames, Singletons, _, _), '$lgt_anonymous_or_singleton_variable'(Var, VariableNames, Singletons), % var/1 predicate argument is either an anonymous or a % singleton variable and thus can never be bound '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(always_true_or_false_goals), goal_is_always_true(File, Lines, Type, Entity, var(Var)) ), fail. '$lgt_compile_body'(nonvar(Var), _, _, _, Ctx) :- var(Var), '$lgt_comp_ctx_mode'(Ctx, compile(user,_,_)), '$lgt_compiler_flag'(always_true_or_false_goals, warning), % reinstate relation between term variables and their names '$lgt_comp_ctx_term'(Ctx, OriginalTerm), '$lgt_pp_term_source_data_'(OriginalTerm, VariableNames, Singletons, _, _), '$lgt_anonymous_or_singleton_variable'(Var, VariableNames, Singletons), % nonvar/1 predicate argument is either an anonymous or a % singleton variable and thus can never be bound '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(always_true_or_false_goals), goal_is_always_false(File, Lines, Type, Entity, nonvar(Var)) ), fail. '$lgt_compile_body'(ground(Ground), _, _, _, Ctx) :- \+ ground(Ground), '$lgt_comp_ctx_mode'(Ctx, compile(user,_,_)), '$lgt_compiler_flag'(always_true_or_false_goals, warning), term_variables(Ground, Variables), % reinstate relation between term variables and their names '$lgt_comp_ctx_term'(Ctx, OriginalTerm), '$lgt_pp_term_source_data_'(OriginalTerm, VariableNames, Singletons, _, _), '$lgt_anonymous_or_singleton_variables'(Variables, VariableNames, Singletons), % all variables in the ground/1 predicate argument are either % anonymous or singleton variables and thus can never be bound '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(always_true_or_false_goals), goal_is_always_false(File, Lines, Type, Entity, ground(Ground)) ), fail. % term comparison (only lint warnings) '$lgt_compile_body'(Exp1 == Exp2, _, _, _, Ctx) :- once((float(Exp1); float(Exp2))), '$lgt_comp_ctx_mode'(Ctx, compile(user,_,_)), '$lgt_compiler_flag'(suspicious_calls, warning), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(arithmetic_expressions), suspicious_call(File, Lines, Type, Entity, Exp1 == Exp2, reason(float_comparison)) ), fail. '$lgt_compile_body'(Exp1 \== Exp2, _, _, _, Ctx) :- once((float(Exp1); float(Exp2))), '$lgt_comp_ctx_mode'(Ctx, compile(user,_,_)), '$lgt_compiler_flag'(suspicious_calls, warning), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(arithmetic_expressions), suspicious_call(File, Lines, Type, Entity, Exp1 \== Exp2, reason(float_comparison)) ), fail. % unification (only lint warnings) '$lgt_compile_body'(Term1 = Term2, _, _, _, Ctx) :- '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_prolog_feature'(coinduction, supported), % backend provides minimal support for cyclic terms; calling the next goal % while using a backend that doesn't support cyclic terms would end badly \+ \+ ( Term1 = Term2, \+ acyclic_term(Term1) ), '$lgt_compiler_flag'(suspicious_calls, warning), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(suspicious_calls), suspicious_call(File, Lines, Type, Entity, Term1 = Term2, reason(cyclic_terms)) ), fail. '$lgt_compile_body'(Term1 = Term2, _, _, _, Ctx) :- '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), ( Term1 \= Term2 -> % unification fails; further instantiation of Term1 or Term2 will not make it succeed '$lgt_compiler_flag'(always_true_or_false_goals, warning), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(always_true_or_false_goals), goal_is_always_false(File, Lines, Type, Entity, Term1 = Term2) ) ; \+ ground(Term1), \+ ground(Term2), \+ \+ ( term_variables(Term1-Term2, Vars0), unify_with_occurs_check(Term1, Term2), term_variables(Term1-Term2, Vars), Vars0 == Vars ), % unification will not bind any variables in the unified terms '$lgt_compiler_flag'(suspicious_calls, warning), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(suspicious_calls), suspicious_call(File, Lines, Type, Entity, Term1 = Term2, reason(no_variable_bindings_after_unification)) ) ), fail. '$lgt_compile_body'(unify_with_occurs_check(Term1, Term2), _, _, _, Ctx) :- '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), ( \+ unify_with_occurs_check(Term1, Term2) -> % unification fails; further instantiation of Term1 or Term2 will not make it succeed '$lgt_compiler_flag'(always_true_or_false_goals, warning), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(always_true_or_false_goals), goal_is_always_false(File, Lines, Type, Entity, unify_with_occurs_check(Term1, Term2)) ) ; \+ ground(Term1), \+ ground(Term2), \+ \+ ( term_variables(Term1-Term2, Vars0), unify_with_occurs_check(Term1, Term2), term_variables(Term1-Term2, Vars), Vars0 == Vars ), % unification will not bind any variables in the unified terms '$lgt_compiler_flag'(suspicious_calls, warning), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(suspicious_calls), suspicious_call(File, Lines, Type, Entity, unify_with_occurs_check(Term1, Term2), reason(no_variable_bindings_after_unification)) ) ), fail. '$lgt_compile_body'(Term1 \= Term2, _, _, _, Ctx) :- once((number(Term1); number(Term2))), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(suspicious_calls, warning), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(arithmetic_expressions), suspicious_call(File, Lines, Type, Entity, Term1 \= Term2, reason(comparing_numbers_using_unification)) ), fail. '$lgt_compile_body'(Term1 \= Term2, _, _, _, Ctx) :- '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), Term1 \= Term2, % goal succeeds; further instantiation of Term1 or Term2 will not make it fail '$lgt_compiler_flag'(always_true_or_false_goals, warning), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(always_true_or_false_goals), goal_is_always_true(File, Lines, Type, Entity, Term1 \= Term2) ), fail. % atomic term processing predicates (only lint warnings) '$lgt_compile_body'(atom_concat(Prefix, Var, Atom), _, _, _, Ctx) :- atom(Prefix), var(Var), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(suspicious_calls, warning), % reinstate relation between term variables and their names '$lgt_comp_ctx_term'(Ctx, OriginalTerm), '$lgt_pp_term_source_data_'(OriginalTerm, VariableNames, _, _, _), \+ ( '$lgt_member'(_=Var0, VariableNames), Var0 == Var ), % assume that Var is an anonymous variable '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(suspicious_calls), suspicious_call(File, Lines, Type, Entity, atom_concat(Prefix, Var, Atom), [sub_atom(Atom, 0, _, _, Prefix)]) ), fail. % term creation and decomposition predicates (only lint warnings) '$lgt_compile_body'(Term =.. List, _, _, _, Ctx) :- '$lgt_is_list'(List), % closed list (compound term with know arity) List = [Functor| _], nonvar(Functor), % with a bound functor '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(suspicious_calls, warning), ListTerm =.. List, '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(suspicious_calls), suspicious_call(File, Lines, Type, Entity, Term =.. List, [Term = ListTerm]) ), fail. '$lgt_compile_body'(Term =.. List, _, _, _, Ctx) :- nonvar(List), List = [Functor| Args], var(Args), % open list (compound term with unknown arity) '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(suspicious_calls, warning), % reinstate relation between term variables and their names '$lgt_comp_ctx_term'(Ctx, OriginalTerm), '$lgt_pp_term_source_data_'(OriginalTerm, VariableNames, _, _, _), once(( '$lgt_member'(_=Functor0, VariableNames), Functor0 == Functor )), % assume that functor is not an anonymous variable \+ ( '$lgt_member'(_=Args0, VariableNames), Args0 == Args ), % assume that the list tail is an anonymous variable '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(suspicious_calls), suspicious_call(File, Lines, Type, Entity, Term =.. List, [functor(Term, Functor, _)]) ), fail. '$lgt_compile_body'(Term =.. List, _, _, _, Ctx) :- nonvar(List), List = [Functor| Args], var(Functor), nonvar(Args), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(suspicious_calls, warning), % reinstate relation between term variables and their names '$lgt_comp_ctx_term'(Ctx, OriginalTerm), '$lgt_pp_term_source_data_'(OriginalTerm, VariableNames, _, _, _), \+ ( '$lgt_member'(_=Functor0, VariableNames), Functor0 == Functor ), % assume that the functor argument is an anonymous variable '$lgt_position_relevant_argument_pairs'(Args, 1, VariableNames, [N-Arg], open, Tail), \+ ( '$lgt_member'(_=Tail0, VariableNames), Tail0 == Tail ), % assume a single bound argument or non-anonymous variable argument in the compound term % arguments; we also require an open list with an anonymous variable as tail for this as % otherwise the =../2 call may also being used e.g. to verify the compound term arity '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(suspicious_calls), suspicious_call(File, Lines, Type, Entity, Term =.. List, [arg(N, Term, Arg)]) ), fail. % lambda expressions '$lgt_compile_body'(Parameters>>Lambda, _, _, _, Ctx) :- '$lgt_check_lambda_expression'(Parameters>>Lambda, Ctx), fail. '$lgt_compile_body'(Free/Parameters>>Lambda, Caller, TPred, DPred, Ctx) :- nonvar(Parameters), !, ( Parameters == [] -> '$lgt_compile_body'(Free/Lambda, Caller, TPred, DPred, Ctx) ; throw(representation_error(lambda_parameters)) ). '$lgt_compile_body'(Free/Parameters>>Lambda, _, TPred, DPred, Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), % lambda expressions are handled as meta-calls TPred = '$lgt_metacall'(Free/Parameters>>Lambda, [], ExCtx, local), DPred = '$lgt_debug'(goal(Free/Parameters>>Lambda, TPred), ExCtx). '$lgt_compile_body'(Parameters>>Lambda, Caller, TPred, DPred, Ctx) :- nonvar(Parameters), !, ( Parameters == [] -> '$lgt_compile_body'(Lambda, Caller, TPred, DPred, Ctx) ; throw(representation_error(lambda_parameters)) ). '$lgt_compile_body'(Parameters>>Lambda, _, TPred, DPred, Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), % lambda expressions are handled as meta-calls TPred = '$lgt_metacall'(Parameters>>Lambda, [], ExCtx, local), DPred = '$lgt_debug'(goal(Parameters>>Lambda, TPred), ExCtx). '$lgt_compile_body'(Free/Lambda, _, _, _, Ctx) :- '$lgt_check_lambda_expression'(Free/Lambda, Ctx), fail. '$lgt_compile_body'(Free/Lambda, Caller, TPred, DPred, Ctx) :- nonvar(Free), nonvar(Lambda), !, ( '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_comp_ctx_meta_vars'(Ctx, []) -> % generate an auxiliary predicate to replace the lambda expression '$lgt_generate_aux_predicate_functor'('_lambda_', Functor), ( Free = {Terms} -> '$lgt_conjunction_to_list'(Terms, Args) ; Args = [] ), Head =.. [Functor| Args], '$lgt_compile_aux_clauses'([(Head :- Lambda)]), '$lgt_compile_body'(Head, Caller, TPred, DPred, Ctx) ; % either runtime translation or the lambda expression appears in the % body of a meta-predicate clause '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), '$lgt_compile_body'(Lambda, Caller, TLambda, DLambda, Ctx), TPred = '$lgt_lambda'(Free, TLambda), DPred = '$lgt_debug'(goal(Free/Lambda, '$lgt_lambda'(Free, DLambda)), ExCtx) ). '$lgt_compile_body'(Free/Lambda, _, TPred, DPred, Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), % lambda expressions are handled as meta-calls TPred = '$lgt_metacall'(Free/Lambda, [], ExCtx, local), DPred = '$lgt_debug'(goal(Free/Lambda, TPred), ExCtx). % built-in meta-predicates '$lgt_compile_body'(bagof(Term, QGoal, List), _, _, _, Ctx) :- callable(QGoal), \+ ground(Term), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(suspicious_calls, warning), '$lgt_decompose_quantified_body'(QGoal, _, Goal), term_variables(Goal, GoalVariables), term_variables(Term, TermVariables), '$lgt_intersection'(TermVariables, GoalVariables, []), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(suspicious_calls), suspicious_call(File, Lines, Type, Entity, bagof(Term,QGoal,List), reason(no_shared_variables(bagof))) ), fail. '$lgt_compile_body'(bagof(_, QGoal, _), _, _, _, Ctx) :- callable(QGoal), QGoal = _^_, '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(suspicious_calls, warning), '$lgt_missing_existential_variables'(QGoal, [Variable| Variables], Goal), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(suspicious_calls), suspicious_call(File, Lines, Type, Entity, QGoal, reason(existential_variables([Variable|Variables],Goal))) ), fail. '$lgt_compile_body'(bagof(_, QGoal, _), _, _, _, Ctx) :- callable(QGoal), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(suspicious_calls, warning), '$lgt_singleton_variables_in_meta_argument'(QGoal, Singletons, Ctx), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(suspicious_calls), suspicious_call(File, Lines, Type, Entity, QGoal, reason(singleton_variables(bagof/3,QGoal,Singletons))) ), fail. '$lgt_compile_body'(bagof(Term, QGoal, List), _, TPred, DPred, Ctx) :- !, '$lgt_comp_ctx'(Ctx, Head, HeadExCtx, _, _, _, _, _, MetaVars, _, ExCtx, Mode, _, _, _), ( var(QGoal) -> % runtime meta-call '$lgt_check_for_meta_predicate_directive'(Mode, Head, QGoal), ( '$lgt_member_var'(QGoal, MetaVars) -> TPred = '$lgt_bagof'(Term, QGoal, List, HeadExCtx, runtime) ; TPred = '$lgt_bagof'(Term, QGoal, List, HeadExCtx, local) ), DPred = '$lgt_debug'(goal(bagof(Term, QGoal, List), TPred), HeadExCtx) ; % compile-time local call '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), '$lgt_compile_quantified_body'(QGoal, meta, TGoal, DGoal, Ctx), TPred = bagof(Term, TGoal, List), DPred = '$lgt_debug'(goal(bagof(Term, QGoal, List), bagof(Term, DGoal, List)), ExCtx) ). '$lgt_compile_body'(findall(Term, Goal, List), _, _, _, Ctx) :- nonvar(Goal), \+ ground(Term), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(suspicious_calls, warning), term_variables(Term, TermVariables), term_variables(Goal, GoalVariables), '$lgt_intersection'(TermVariables, GoalVariables, []), % reinstate relation between term variables and their names '$lgt_comp_ctx_term'(Ctx, OriginalTerm), '$lgt_pp_term_source_data_'(OriginalTerm, VariableNames, _, _, _), once(( '$lgt_member'(_=Term0, VariableNames), Term0 == Term )), % assume that Term is not an anonymous variable '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(suspicious_calls), suspicious_call(File, Lines, Type, Entity, findall(Term,Goal,List), reason(no_shared_variables(findall))) ), fail. '$lgt_compile_body'(findall(Term, Goal, List), _, _, _, Ctx) :- var(Term), var(List), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(suspicious_calls, warning), % reinstate relation between term variables and their names '$lgt_comp_ctx_term'(Ctx, OriginalTerm), '$lgt_pp_term_source_data_'(OriginalTerm, VariableNames, _, _, _), \+ ( '$lgt_member'(_=List0, VariableNames), List0 == List ), % assume that List is an anonymous variable '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(suspicious_calls), suspicious_call(File, Lines, Type, Entity, findall(Term, Goal, List), [(Goal, fail; true)]) ), fail. '$lgt_compile_body'(findall(Term, Goal, List), _, findall(Term, TGoal, List), '$lgt_debug'(goal(findall(Term, Goal, List), findall(Term, DGoal, List)), ExCtx), Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), '$lgt_compile_body'(Goal, meta, TGoal, DGoal, Ctx). '$lgt_compile_body'(findall(Term, Goal, List, Tail), _, _, _, Ctx) :- nonvar(Goal), \+ ground(Term), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(suspicious_calls, warning), term_variables(Term, TermVariables), term_variables(Goal, GoalVariables), '$lgt_intersection'(TermVariables, GoalVariables, []), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(suspicious_calls), suspicious_call(File, Lines, Type, Entity, findall(Term,Goal,List,Tail), reason(no_shared_variables(findall))) ), fail. '$lgt_compile_body'(findall(Term, Goal, List, Tail), _, findall(Term, TGoal, List, Tail), '$lgt_debug'(goal(findall(Term, Goal, List, Tail), findall(Term, DGoal, List, Tail)), ExCtx), Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), '$lgt_compile_body'(Goal, meta, TGoal, DGoal, Ctx). '$lgt_compile_body'(forall(Gen, Test), _, _, _, Ctx) :- callable(Gen), callable(Test), \+ ground(Gen), \+ ground(Test), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(suspicious_calls, warning), term_variables(Gen, GenVariables), term_variables(Test, TestVariables), '$lgt_intersection'(GenVariables, TestVariables, []), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(suspicious_calls), suspicious_call(File, Lines, Type, Entity, forall(Gen,Test), reason(no_shared_variables(forall))) ), fail. '$lgt_compile_body'(forall(Gen, Test), _, \+ (TGen, \+ TTest), '$lgt_debug'(goal(forall(Gen, Test), \+ (DGen, \+ DTest)), ExCtx), Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), '$lgt_compile_body'(Gen, meta, TGen, DGen, Ctx), '$lgt_compile_body'(Test, meta, TTest, DTest, Ctx). '$lgt_compile_body'(setof(Term, QGoal, List), _, _, _, Ctx) :- callable(QGoal), \+ ground(Term), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(suspicious_calls, warning), '$lgt_decompose_quantified_body'(QGoal, _, Goal), term_variables(Goal, GoalVariables), term_variables(Term, TermVariables), '$lgt_intersection'(TermVariables, GoalVariables, []), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(suspicious_calls), suspicious_call(File, Lines, Type, Entity, setof(Term,QGoal,List), reason(no_shared_variables(setof))) ), fail. '$lgt_compile_body'(setof(_, QGoal, _), _, _, _, Ctx) :- callable(QGoal), QGoal = _^_, '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(suspicious_calls, warning), '$lgt_missing_existential_variables'(QGoal, [Variable| Variables], Goal), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(suspicious_calls), suspicious_call(File, Lines, Type, Entity, QGoal, reason(existential_variables([Variable|Variables],Goal))) ), fail. '$lgt_compile_body'(setof(_, QGoal, _), _, _, _, Ctx) :- callable(QGoal), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(suspicious_calls, warning), '$lgt_singleton_variables_in_meta_argument'(QGoal, Singletons, Ctx), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(suspicious_calls), suspicious_call(File, Lines, Type, Entity, QGoal, reason(singleton_variables(setof/3,QGoal,Singletons))) ), fail. '$lgt_compile_body'(setof(Term, QGoal, List), _, TPred, DPred, Ctx) :- !, '$lgt_comp_ctx'(Ctx, Head, HeadExCtx, _, _, _, _, _, MetaVars, _, ExCtx, Mode, _, _, _), ( var(QGoal) -> % runtime meta-call '$lgt_check_for_meta_predicate_directive'(Mode, Head, QGoal), ( '$lgt_member_var'(QGoal, MetaVars) -> TPred = '$lgt_setof'(Term, QGoal, List, HeadExCtx, runtime) ; TPred = '$lgt_setof'(Term, QGoal, List, HeadExCtx, local) ), DPred = '$lgt_debug'(goal(setof(Term, QGoal, List), TPred), HeadExCtx) ; % compile-time local call '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), '$lgt_compile_quantified_body'(QGoal, meta, TGoal, DGoal, Ctx), TPred = setof(Term, TGoal, List), DPred = '$lgt_debug'(goal(setof(Term, QGoal, List), setof(Term, DGoal, List)), ExCtx) ). % file compilation and loading predicates '$lgt_compile_body'(logtalk_compile(Files), _, TPred, DPred, Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), '$lgt_pp_file_paths_flags_'(_, Directory, _, _, _), TPred = '$lgt_logtalk_compile'(Files, Directory, ExCtx), DPred = '$lgt_debug'(goal(logtalk_compile(Files), TPred), ExCtx). '$lgt_compile_body'(logtalk_compile(Files, Flags), _, TPred, DPred, Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), '$lgt_pp_file_paths_flags_'(_, Directory, _, _, _), TPred = '$lgt_logtalk_compile'(Files, Flags, Directory, ExCtx), DPred = '$lgt_debug'(goal(logtalk_compile(Files, Flags), TPred), ExCtx). '$lgt_compile_body'(logtalk_load(Files), _, TPred, DPred, Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), '$lgt_pp_file_paths_flags_'(_, Directory, _, _, _), TPred = '$lgt_logtalk_load'(Files, Directory, ExCtx), DPred = '$lgt_debug'(goal(logtalk_load(Files), TPred), ExCtx). '$lgt_compile_body'(logtalk_load(Files, Flags), _, TPred, DPred, Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), '$lgt_pp_file_paths_flags_'(_, Directory, _, _, _), TPred = '$lgt_logtalk_load'(Files, Flags, Directory, ExCtx), DPred = '$lgt_debug'(goal(logtalk_load(Files, Flags), TPred), ExCtx). % file compilation/loading context '$lgt_compile_body'(logtalk_load_context(Key, Value), _, TPred, DPred, Ctx) :- !, '$lgt_comp_ctx'(Ctx, Head, _, _, _, _, _, _, _, _, ExCtx, _, _, _, _), ( var(Key) -> TPred = '$lgt_logtalk_load_context'(Key, Value, ExCtx) ; '$lgt_valid_logtalk_load_context_key'(Key) -> ( nonvar(Head), functor(Head, (:-), 1), % compiling a directive an initialization/1 directive '$lgt_logtalk_load_context_checked'(Key, Value) -> % expand goal to support embedded applications where the compiled % code may no longer be loaded using the Logtalk runtime TPred = true ; TPred = '$lgt_logtalk_load_context_checked'(Key, Value) ) ; callable(Key) -> throw(domain_error(logtalk_load_context_key, Key)) ; throw(type_error(callable, Key)) ), DPred = '$lgt_debug'(goal(logtalk_load_context(Key, Value), TPred), ExCtx). % entity enumeration predicates '$lgt_compile_body'(current_object(Obj), _, TPred, DPred, Ctx) :- !, '$lgt_check'(var_or_object_identifier, Obj), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), ( var(Obj) -> TPred = '$lgt_current_object'(Obj, ExCtx) ; TPred = '$lgt_current_object_'(Obj, _, _, _, _, _, _, _, _, _, _) ), DPred = '$lgt_debug'(goal(current_object(Obj), TPred), ExCtx). '$lgt_compile_body'(current_protocol(Ptc), _, TPred, DPred, Ctx) :- !, '$lgt_check'(var_or_protocol_identifier, Ptc), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), ( var(Ptc) -> TPred = '$lgt_current_protocol'(Ptc, ExCtx) ; TPred = '$lgt_current_protocol_'(Ptc, _, _, _, _) ), DPred = '$lgt_debug'(goal(current_protocol(Ptc), TPred), ExCtx). '$lgt_compile_body'(current_category(Ctg), _, TPred, DPred, Ctx) :- !, '$lgt_check'(var_or_category_identifier, Ctg), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), ( var(Ctg) -> TPred = '$lgt_current_category'(Ctg, ExCtx) ; TPred = '$lgt_current_category_'(Ctg, _, _, _, _, _) ), DPred = '$lgt_debug'(goal(current_category(Ctg), TPred), ExCtx). % entity property predicates '$lgt_compile_body'(object_property(Obj, Prop), _, TPred, DPred, Ctx) :- !, '$lgt_check'(var_or_object_identifier, Obj), '$lgt_check'(var_or_object_property, Prop), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), TPred = '$lgt_object_property'(Obj, Prop, ExCtx), DPred = '$lgt_debug'(goal(object_property(Obj, Prop), TPred), ExCtx). '$lgt_compile_body'(protocol_property(Ptc, Prop), _, TPred, DPred, Ctx) :- !, '$lgt_check'(var_or_protocol_identifier, Ptc), '$lgt_check'(var_or_protocol_property, Prop), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), TPred = '$lgt_protocol_property'(Ptc, Prop, ExCtx), DPred = '$lgt_debug'(goal(protocol_property(Ptc, Prop), TPred), ExCtx). '$lgt_compile_body'(category_property(Ctg, Prop), _, TPred, DPred, Ctx) :- !, '$lgt_check'(var_or_category_identifier, Ctg), '$lgt_check'(var_or_category_property, Prop), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), TPred = '$lgt_category_property'(Ctg, Prop, ExCtx), DPred = '$lgt_debug'(goal(category_property(Ctg, Prop), TPred), ExCtx). % dynamic entity creation predicates '$lgt_compile_body'(create_object(Obj, Relations, Directives, Clauses), _, TPred, DPred, Ctx) :- !, '$lgt_check'(var_or_object_identifier, Obj), '$lgt_check'(list_or_partial_list, Relations), '$lgt_check'(list_or_partial_list, Directives), '$lgt_check'(list_or_partial_list, Clauses), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), TPred = '$lgt_create_object'(Obj, Relations, Directives, Clauses, ExCtx), DPred = '$lgt_debug'(goal(create_object(Obj, Relations, Directives, Clauses), TPred), ExCtx). '$lgt_compile_body'(create_protocol(Ptc, Relations, Directives), _, TPred, DPred, Ctx) :- !, '$lgt_check'(var_or_protocol_identifier, Ptc), '$lgt_check'(list_or_partial_list, Relations), '$lgt_check'(list_or_partial_list, Directives), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), TPred = '$lgt_create_protocol'(Ptc, Relations, Directives, ExCtx), DPred = '$lgt_debug'(goal(create_protocol(Ptc, Relations, Directives), TPred), ExCtx). '$lgt_compile_body'(create_category(Ctg, Relations, Directives, Clauses), _, TPred, DPred, Ctx) :- !, '$lgt_check'(var_or_category_identifier, Ctg), '$lgt_check'(list_or_partial_list, Relations), '$lgt_check'(list_or_partial_list, Directives), '$lgt_check'(list_or_partial_list, Clauses), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), TPred = '$lgt_create_category'(Ctg, Relations, Directives, Clauses, ExCtx), DPred = '$lgt_debug'(goal(create_category(Ctg, Relations, Directives, Clauses), TPred), ExCtx). % dynamic entity abolishing predicates '$lgt_compile_body'(abolish_object(Obj), _, TPred, DPred, Ctx) :- !, '$lgt_check'(var_or_object_identifier, Obj), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), ( var(Obj) -> TPred = '$lgt_abolish_object'(Obj, ExCtx) ; TPred = '$lgt_abolish_object_checked'(Obj, ExCtx) ), DPred = '$lgt_debug'(goal(abolish_object(Obj), TPred), ExCtx). '$lgt_compile_body'(abolish_protocol(Ptc), _, TPred, DPred, Ctx) :- !, '$lgt_check'(var_or_protocol_identifier, Ptc), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), ( var(Ptc) -> TPred = '$lgt_abolish_protocol'(Ptc, ExCtx) ; TPred = '$lgt_abolish_protocol_checked'(Ptc, ExCtx) ), DPred = '$lgt_debug'(goal(abolish_protocol(Ptc), TPred), ExCtx). '$lgt_compile_body'(abolish_category(Ctg), _, TPred, DPred, Ctx) :- !, '$lgt_check'(var_or_category_identifier, Ctg), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), ( var(Ctg) -> TPred = '$lgt_abolish_category'(Ctg, ExCtx) ; TPred = '$lgt_abolish_category_checked'(Ctg, ExCtx) ), DPred = '$lgt_debug'(goal(abolish_category(Ctg), TPred), ExCtx). % entity relations predicates '$lgt_compile_body'(extends_protocol(Ptc, ExtPtc), _, TPred, DPred, Ctx) :- !, '$lgt_check'(var_or_protocol_identifier, Ptc), '$lgt_check'(var_or_protocol_identifier, ExtPtc), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), TPred = '$lgt_extends_protocol'(Ptc, ExtPtc, ExCtx), DPred = '$lgt_debug'(goal(extends_protocol(Ptc, ExtPtc), TPred), ExCtx). '$lgt_compile_body'(extends_protocol(Ptc, ExtPtc, Scope), _, TPred, DPred, Ctx) :- !, '$lgt_check'(var_or_protocol_identifier, Ptc), '$lgt_check'(var_or_protocol_identifier, ExtPtc), '$lgt_check'(var_or_scope, Scope), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), TPred = '$lgt_extends_protocol'(Ptc, ExtPtc, Scope, ExCtx), DPred = '$lgt_debug'(goal(extends_protocol(Ptc, ExtPtc, Scope), TPred), ExCtx). '$lgt_compile_body'(implements_protocol(ObjOrCtg, Ptc), _, TPred, DPred, Ctx) :- !, '$lgt_check'(var_or_object_identifier, ObjOrCtg), '$lgt_check'(var_or_protocol_identifier, Ptc), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), TPred = '$lgt_implements_protocol'(ObjOrCtg, Ptc, ExCtx), DPred = '$lgt_debug'(goal(implements_protocol(ObjOrCtg, Ptc), TPred), ExCtx). '$lgt_compile_body'(implements_protocol(ObjOrCtg, Ptc, Scope), _, TPred, DPred, Ctx) :- !, '$lgt_check'(var_or_object_identifier, ObjOrCtg), '$lgt_check'(var_or_protocol_identifier, Ptc), '$lgt_check'(var_or_scope, Scope), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), TPred = '$lgt_implements_protocol'(ObjOrCtg, Ptc, Scope, ExCtx), DPred = '$lgt_debug'(goal(implements_protocol(ObjOrCtg, Ptc, Scope), TPred), ExCtx). '$lgt_compile_body'(imports_category(Obj, Ctg), _, TPred, DPred, Ctx) :- !, '$lgt_check'(var_or_object_identifier, Obj), '$lgt_check'(var_or_category_identifier, Ctg), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), TPred = '$lgt_imports_category'(Obj, Ctg, ExCtx), DPred = '$lgt_debug'(goal(imports_category(Obj, Ctg), TPred), ExCtx). '$lgt_compile_body'(imports_category(Obj, Ctg, Scope), _, TPred, DPred, Ctx) :- !, '$lgt_check'(var_or_object_identifier, Obj), '$lgt_check'(var_or_category_identifier, Ctg), '$lgt_check'(var_or_scope, Scope), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), TPred = '$lgt_imports_category'(Obj, Ctg, Scope, ExCtx), DPred = '$lgt_debug'(goal(imports_category(Obj, Ctg, Scope), TPred), ExCtx). '$lgt_compile_body'(instantiates_class(Obj, Class), _, TPred, DPred, Ctx) :- !, '$lgt_check'(var_or_object_identifier, Obj), '$lgt_check'(var_or_object_identifier, Class), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), TPred = '$lgt_instantiates_class'(Obj, Class, ExCtx), DPred = '$lgt_debug'(goal(instantiates_class(Obj, Class), TPred), ExCtx). '$lgt_compile_body'(instantiates_class(Obj, Class, Scope), _, TPred, DPred, Ctx) :- !, '$lgt_check'(var_or_object_identifier, Obj), '$lgt_check'(var_or_object_identifier, Class), '$lgt_check'(var_or_scope, Scope), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), TPred = '$lgt_instantiates_class'(Obj, Class, Scope, ExCtx), DPred = '$lgt_debug'(goal(instantiates_class(Obj, Class, Scope), TPred), ExCtx). '$lgt_compile_body'(specializes_class(Class, Superclass), _, TPred, DPred, Ctx) :- !, '$lgt_check'(var_or_object_identifier, Class), '$lgt_check'(var_or_object_identifier, Superclass), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), TPred = '$lgt_specializes_class'(Class, Superclass, ExCtx), DPred = '$lgt_debug'(goal(specializes_class(Class, Superclass), TPred), ExCtx). '$lgt_compile_body'(specializes_class(Class, Superclass, Scope), _, TPred, DPred, Ctx) :- !, '$lgt_check'(var_or_object_identifier, Class), '$lgt_check'(var_or_object_identifier, Superclass), '$lgt_check'(var_or_scope, Scope), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), TPred = '$lgt_specializes_class'(Class, Superclass, Scope, ExCtx), DPred = '$lgt_debug'(goal(specializes_class(Class, Superclass, Scope), TPred), ExCtx). '$lgt_compile_body'(extends_category(Ctg, ExtCtg), _, TPred, DPred, Ctx) :- !, '$lgt_check'(var_or_category_identifier, Ctg), '$lgt_check'(var_or_category_identifier, ExtCtg), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), TPred = '$lgt_extends_category'(Ctg, ExtCtg, ExCtx), DPred = '$lgt_debug'(goal(extends_category(Ctg, ExtCtg), TPred), ExCtx). '$lgt_compile_body'(extends_category(Ctg, ExtCtg, Scope), _, TPred, DPred, Ctx) :- !, '$lgt_check'(var_or_category_identifier, Ctg), '$lgt_check'(var_or_category_identifier, ExtCtg), '$lgt_check'(var_or_scope, Scope), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), TPred = '$lgt_extends_category'(Ctg, ExtCtg, Scope, ExCtx), DPred = '$lgt_debug'(goal(extends_category(Ctg, ExtCtg, Scope), TPred), ExCtx). '$lgt_compile_body'(extends_object(Prototype, Parent), _, TPred, DPred, Ctx) :- !, '$lgt_check'(var_or_object_identifier, Prototype), '$lgt_check'(var_or_object_identifier, Parent), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), TPred = '$lgt_extends_object'(Prototype, Parent, ExCtx), DPred = '$lgt_debug'(goal(extends_object(Prototype, Parent), TPred), ExCtx). '$lgt_compile_body'(extends_object(Prototype, Parent, Scope), _, TPred, DPred, Ctx) :- !, '$lgt_check'(var_or_object_identifier, Prototype), '$lgt_check'(var_or_object_identifier, Parent), '$lgt_check'(var_or_scope, Scope), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), TPred = '$lgt_extends_object'(Prototype, Parent, Scope, ExCtx), DPred = '$lgt_debug'(goal(extends_object(Prototype, Parent, Scope), TPred), ExCtx). '$lgt_compile_body'(complements_object(Category, Object), _, TPred, DPred, Ctx) :- !, '$lgt_check'(var_or_category_identifier, Category), '$lgt_check'(var_or_object_identifier, Object), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), TPred = '$lgt_complements_object'(Category, Object, ExCtx), DPred = '$lgt_debug'(goal(complements_object(Category, Object), TPred), ExCtx). '$lgt_compile_body'(conforms_to_protocol(ObjOrCtg, Protocol), _, TPred, DPred, Ctx) :- !, '$lgt_check'(var_or_object_identifier, ObjOrCtg), '$lgt_check'(var_or_protocol_identifier, Protocol), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), TPred = '$lgt_conforms_to_protocol'(ObjOrCtg, Protocol, ExCtx), DPred = '$lgt_debug'(goal(conforms_to_protocol(ObjOrCtg, Protocol), TPred), ExCtx). '$lgt_compile_body'(conforms_to_protocol(ObjOrCtg, Protocol, Scope), _, TPred, DPred, Ctx) :- !, '$lgt_check'(var_or_object_identifier, ObjOrCtg), '$lgt_check'(var_or_protocol_identifier, Protocol), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), TPred = '$lgt_conforms_to_protocol'(ObjOrCtg, Protocol, Scope, ExCtx), DPred = '$lgt_debug'(goal(conforms_to_protocol(ObjOrCtg, Protocol), TPred), ExCtx). % events predicates '$lgt_compile_body'(current_event(Event, Obj, Msg, Sender, Monitor), _, TPred, DPred, Ctx) :- !, '$lgt_check'(var_or_event, Event), '$lgt_check'(var_or_object_identifier, Obj), '$lgt_check'(var_or_callable, Msg), '$lgt_check'(var_or_object_identifier, Sender), '$lgt_check'(var_or_object_identifier, Monitor), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), TPred = '$lgt_current_event'(Event, Obj, Msg, Sender, Monitor, ExCtx), DPred = '$lgt_debug'(goal(current_event(Event, Obj, Msg, Sender, Monitor), TPred), ExCtx). '$lgt_compile_body'(define_events(Event, Obj, Msg, Sender, Monitor), _, TPred, DPred, Ctx) :- !, '$lgt_check'(var_or_event, Event), '$lgt_check'(var_or_object_identifier, Obj), '$lgt_check'(var_or_callable, Msg), '$lgt_check'(var_or_object_identifier, Sender), '$lgt_check'(var_or_object_identifier, Monitor), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), TPred = '$lgt_define_events'(Event, Obj, Msg, Sender, Monitor, ExCtx), DPred = '$lgt_debug'(goal(define_events(Event, Obj, Msg, Sender, Monitor), TPred), ExCtx). '$lgt_compile_body'(abolish_events(Event, Obj, Msg, Sender, Monitor), _, TPred, DPred, Ctx) :- !, '$lgt_check'(var_or_event, Event), '$lgt_check'(var_or_object_identifier, Obj), '$lgt_check'(var_or_callable, Msg), '$lgt_check'(var_or_object_identifier, Sender), '$lgt_check'(var_or_object_identifier, Monitor), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), TPred = '$lgt_abolish_events'(Event, Obj, Msg, Sender, Monitor, ExCtx), DPred = '$lgt_debug'(goal(abolish_events(Event, Obj, Msg, Sender, Monitor), TPred), ExCtx). % multi-threading meta-predicates '$lgt_compile_body'(threaded(_), _, _, _, _) :- \+ '$lgt_pp_threaded_', '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _), throw(resource_error(threads)). '$lgt_compile_body'(threaded(Goals), _, TGoal, '$lgt_debug'(goal(threaded(Goals), TGoal), ExCtx), Ctx) :- var(Goals), !, '$lgt_comp_ctx'(Ctx, Head, HeadExCtx, _, _, _, _, _, MetaVars, _, _, Mode, _, _, _), '$lgt_check_for_meta_predicate_directive'(Mode, Head, Goals), ( '$lgt_member_var'(Goals, MetaVars) -> TGoal = '$lgt_threaded'(Goals, HeadExCtx, runtime) ; TGoal = '$lgt_threaded'(Goals, HeadExCtx, local) ), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx). '$lgt_compile_body'(threaded(Goals), _, MTGoals, '$lgt_debug'(goal(threaded(Goals), MDGoals), ExCtx), Ctx) :- !, '$lgt_compile_body'(Goals, meta, TGoals, DGoals, Ctx), '$lgt_compile_threaded_call'(TGoals, MTGoals), '$lgt_compile_threaded_call'(DGoals, MDGoals), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx). '$lgt_compile_body'(threaded_call(_, _), _, _, _, _) :- \+ '$lgt_pp_threaded_', '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _), throw(resource_error(threads)). '$lgt_compile_body'(threaded_call(Goal, Tag), _, MTGoal, '$lgt_debug'(goal(threaded_call(Goal, Tag), MDGoal), ExCtx), Ctx) :- !, '$lgt_check'(var, Tag), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), '$lgt_compile_body'(Goal, meta, TGoal, DGoal, Ctx), MTGoal = '$lgt_threaded_call_tagged'(Goal, TGoal, ExCtx, Tag), MDGoal = '$lgt_threaded_call_tagged'(Goal, DGoal, ExCtx, Tag). '$lgt_compile_body'(threaded_call(_), _, _, _, _) :- \+ '$lgt_pp_threaded_', '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _), throw(resource_error(threads)). '$lgt_compile_body'(threaded_call(Goal), _, MTGoal, '$lgt_debug'(goal(threaded_call(Goal), MDGoal), ExCtx), Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), '$lgt_compile_body'(Goal, meta, TGoal, DGoal, Ctx), MTGoal = '$lgt_threaded_call'(Goal, TGoal, ExCtx), MDGoal = '$lgt_threaded_call'(Goal, DGoal, ExCtx). '$lgt_compile_body'(threaded_once(_, _), _, _, _, _) :- \+ '$lgt_pp_threaded_', '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _), throw(resource_error(threads)). '$lgt_compile_body'(threaded_once(Goal, Tag), _, MTGoal, '$lgt_debug'(goal(threaded_once(Goal, Tag), MDGoal), ExCtx), Ctx) :- !, '$lgt_check'(var, Tag), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), '$lgt_compile_body'(Goal, meta, TGoal, DGoal, Ctx), MTGoal = '$lgt_threaded_once_tagged'(Goal, TGoal, ExCtx, Tag), MDGoal = '$lgt_threaded_once_tagged'(Goal, DGoal, ExCtx, Tag). '$lgt_compile_body'(threaded_once(_), _, _, _, _) :- \+ '$lgt_pp_threaded_', '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _), throw(resource_error(threads)). '$lgt_compile_body'(threaded_once(Goal), _, MTGoal, '$lgt_debug'(goal(threaded_once(Goal), MDGoal), ExCtx), Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), '$lgt_compile_body'(Goal, meta, TGoal, DGoal, Ctx), MTGoal = '$lgt_threaded_once'(Goal, TGoal, ExCtx), MDGoal = '$lgt_threaded_once'(Goal, DGoal, ExCtx). '$lgt_compile_body'(threaded_ignore(_), _, _, _, _) :- \+ '$lgt_pp_threaded_', '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _), throw(resource_error(threads)). '$lgt_compile_body'(threaded_ignore(Goal), _, MTGoal, '$lgt_debug'(goal(threaded_ignore(Goal), MDGoal), ExCtx), Ctx) :- !, '$lgt_compile_body'(Goal, meta, TGoal, DGoal, Ctx), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), MTGoal = '$lgt_threaded_ignore'(Goal, TGoal, ExCtx), MDGoal = '$lgt_threaded_ignore'(Goal, DGoal, ExCtx). '$lgt_compile_body'(threaded_exit(_, _), _, _, _, _) :- \+ '$lgt_pp_threaded_', '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _), throw(resource_error(threads)). '$lgt_compile_body'(threaded_exit(Goal, Tag), _, TGoal, '$lgt_debug'(goal(threaded_exit(Goal, Tag), TGoal), ExCtx), Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), % compile the goal just for type-checking and collecting source data '$lgt_compile_body'(Goal, meta, _, _, Ctx), TGoal = '$lgt_threaded_exit_tagged'(Goal, ExCtx, Tag). '$lgt_compile_body'(threaded_exit(_), _, _, _, _) :- \+ '$lgt_pp_threaded_', '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _), throw(resource_error(threads)). '$lgt_compile_body'(threaded_exit(Goal), _, TGoal, '$lgt_debug'(goal(threaded_exit(Goal), TGoal), ExCtx), Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), % compile the goal just for type-checking and collecting source data '$lgt_compile_body'(Goal, meta, _, _, Ctx), TGoal = '$lgt_threaded_exit'(Goal, ExCtx). '$lgt_compile_body'(threaded_peek(_, _), _, _, _, _) :- \+ '$lgt_pp_threaded_', '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _), throw(resource_error(threads)). '$lgt_compile_body'(threaded_peek(Goal, Tag), _, TGoal, '$lgt_debug'(goal(threaded_peek(Goal, Tag), TGoal), ExCtx), Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), % compile the goal just for type-checking and collecting source data '$lgt_compile_body'(Goal, meta, _, _, Ctx), TGoal = '$lgt_threaded_peek_tagged'(Goal, ExCtx, Tag). '$lgt_compile_body'(threaded_peek(_), _, _, _, _) :- \+ '$lgt_pp_threaded_', '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _), throw(resource_error(threads)). '$lgt_compile_body'(threaded_peek(Goal), _, TGoal, '$lgt_debug'(goal(threaded_peek(Goal), TGoal), ExCtx), Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), % compile the goal just for type-checking and collecting source data '$lgt_compile_body'(Goal, meta, _, _, Ctx), TGoal = '$lgt_threaded_peek'(Goal, ExCtx). '$lgt_compile_body'(threaded_cancel(_), _, _, _, _) :- \+ '$lgt_pp_threaded_', '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _), throw(resource_error(threads)). '$lgt_compile_body'(threaded_cancel(Tag), _, TGoal, '$lgt_debug'(goal(threaded_cancel(Tag), TGoal), ExCtx), Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), TGoal = '$lgt_threaded_cancel_tagged'(Tag, ExCtx). '$lgt_compile_body'(threaded_engine_create(_, _, _), _, _, _, _) :- \+ '$lgt_pp_threaded_', '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _), throw(resource_error(threads)). '$lgt_compile_body'(threaded_engine_create(AnswerTemplate, Goal, Engine), _, MTGoal, '$lgt_debug'(goal(threaded_engine_create(AnswerTemplate, Goal, Engine), MDGoal), ExCtx), Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), '$lgt_compile_body'(Goal, meta, TGoal, DGoal, Ctx), MTGoal = '$lgt_threaded_engine_create'(AnswerTemplate, Goal, TGoal, ExCtx, Engine), MDGoal = '$lgt_threaded_engine_create'(AnswerTemplate, Goal, DGoal, ExCtx, Engine). '$lgt_compile_body'(threaded_engine_self(_), _, _, _, _) :- \+ '$lgt_pp_threaded_', '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _), throw(resource_error(threads)). '$lgt_compile_body'(threaded_engine_self(Engine), _, MTGoal, '$lgt_debug'(goal(threaded_engine_self(Engine), MTGoal), ExCtx), Ctx) :- !, '$lgt_comp_ctx'(Ctx, _, _, _, _, This, _, _, _, _, ExCtx, _, _, _, _), MTGoal = '$lgt_threaded_engine_self'(This, Engine), '$lgt_execution_context'(ExCtx, _, _, This, _, _, _). '$lgt_compile_body'(threaded_engine(_), _, _, _, _) :- \+ '$lgt_pp_threaded_', '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _), throw(resource_error(threads)). '$lgt_compile_body'(threaded_engine(Engine), _, MTGoal, '$lgt_debug'(goal(threaded_engine(Engine), MTGoal), ExCtx), Ctx) :- !, '$lgt_comp_ctx'(Ctx, _, _, _, _, This, _, _, _, _, ExCtx, _, _, _, _), MTGoal = '$lgt_current_engine'(This, Engine), '$lgt_execution_context'(ExCtx, _, _, This, _, _, _). '$lgt_compile_body'(threaded_engine_next(_, _), _, _, _, _) :- \+ '$lgt_pp_threaded_', '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _), throw(resource_error(threads)). '$lgt_compile_body'(threaded_engine_next(Engine, Answer), _, MTGoal, '$lgt_debug'(goal(threaded_engine_next_reified(Engine, Answer), MTGoal), ExCtx), Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), MTGoal = '$lgt_threaded_engine_next'(Engine, Answer, ExCtx). '$lgt_compile_body'(threaded_engine_next_reified(_, _), _, _, _, _) :- \+ '$lgt_pp_threaded_', '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _), throw(resource_error(threads)). '$lgt_compile_body'(threaded_engine_next_reified(Engine, Answer), _, MTGoal, '$lgt_debug'(goal(threaded_engine_next_reified(Engine, Answer), MTGoal), ExCtx), Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), MTGoal = '$lgt_threaded_engine_next_reified'(Engine, Answer, ExCtx). '$lgt_compile_body'(threaded_engine_yield(_), _, _, _, _) :- \+ '$lgt_pp_threaded_', '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _), throw(resource_error(threads)). '$lgt_compile_body'(threaded_engine_yield(Answer), _, MTGoal, '$lgt_debug'(goal(threaded_engine_yield(Answer), MTGoal), ExCtx), Ctx) :- !, '$lgt_comp_ctx'(Ctx, _, _, _, _, This, _, _, _, _, ExCtx, _, _, _, _), MTGoal = '$lgt_threaded_engine_yield'(Answer, This), '$lgt_execution_context'(ExCtx, _, _, This, _, _, _). '$lgt_compile_body'(threaded_engine_post(_, _), _, _, _, _) :- \+ '$lgt_pp_threaded_', '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _), throw(resource_error(threads)). '$lgt_compile_body'(threaded_engine_post(Engine, Message), _, MTGoal, '$lgt_debug'(goal(threaded_engine_post(Engine, Message), MTGoal), ExCtx), Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), MTGoal = '$lgt_threaded_engine_post'(Engine, Message, ExCtx). '$lgt_compile_body'(threaded_engine_fetch(_), _, _, _, _) :- \+ '$lgt_pp_threaded_', '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _), throw(resource_error(threads)). '$lgt_compile_body'(threaded_engine_fetch(Message), _, MTGoal, '$lgt_debug'(goal(threaded_engine_fetch(Message), MTGoal), ExCtx), Ctx) :- !, '$lgt_comp_ctx'(Ctx, _, _, _, _, This, _, _, _, _, ExCtx, _, _, _, _), MTGoal = '$lgt_threaded_engine_fetch'(Message, This), '$lgt_execution_context'(ExCtx, _, _, This, _, _, _). '$lgt_compile_body'(threaded_engine_destroy(_), _, _, _, _) :- \+ '$lgt_pp_threaded_', '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _), throw(resource_error(threads)). '$lgt_compile_body'(threaded_engine_destroy(Engine), _, MTGoal, '$lgt_debug'(goal(threaded_engine_destroy(Engine), MTGoal), ExCtx), Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), MTGoal = '$lgt_threaded_engine_destroy'(Engine, ExCtx). '$lgt_compile_body'(threaded_wait(_), _, _, _, _) :- \+ '$lgt_pp_threaded_', '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _), throw(resource_error(threads)). '$lgt_compile_body'(threaded_wait(Msg), _, MTPred, '$lgt_debug'(goal(threaded_wait(Msg), MTPred), ExCtx), Ctx) :- !, ( '$lgt_pp_entity_'(Type, _, Prefix) -> true ; Type = object % < ( Type == object -> % we're compiling an object predicate MTPred = '$lgt_threaded_wait_synch'(Mutex, Msg, Prefix) ; % we're compiling a category predicate '$lgt_comp_ctx_this'(Ctx, This), '$lgt_execution_context_this_entity'(ExCtx, This, _), MTPred = '$lgt_threaded_wait_synch_ctg'(Mutex, Msg, This) ) ; ( Type == object -> % we're compiling an object predicate MTPred = '$lgt_threaded_wait'(Msg, Prefix) ; % we're compiling a category predicate '$lgt_comp_ctx_this'(Ctx, This), '$lgt_execution_context_this_entity'(ExCtx, This, _), MTPred = '$lgt_threaded_wait_ctg'(Msg, This) ) ). '$lgt_compile_body'(threaded_notify(_), _, _, _, _) :- \+ '$lgt_pp_threaded_', '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _, _), throw(resource_error(threads)). '$lgt_compile_body'(threaded_notify(Msg), _, MTPred, '$lgt_debug'(goal(threaded_notify(Msg), MTPred), ExCtx), Ctx) :- !, ( '$lgt_pp_entity_'(Type, _, Prefix) -> true ; Type = object % < % we're compiling an object predicate MTPred = '$lgt_threaded_notify'(Msg, Prefix) ; % we're compiling a category predicate '$lgt_comp_ctx_this'(Ctx, This), '$lgt_execution_context_this_entity'(ExCtx, This, _), MTPred = '$lgt_threaded_notify_ctg'(Msg, This) ). % message-sending '$lgt_compile_body'(Alias::Pred, _, TPred, '$lgt_debug'(goal(Alias::Pred, TPred), ExCtx), Ctx) :- callable(Alias), '$lgt_pp_object_alias_'(Obj, Alias, Ctx, _, _), !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), '$lgt_compiler_flag'(events, Events), '$lgt_compile_message_to_object'(Pred, Obj, TPred, Events, Ctx). '$lgt_compile_body'(Obj::Pred, _, TPred, '$lgt_debug'(goal(Obj::Pred, TPred), ExCtx), Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), '$lgt_compiler_flag'(events, Events), '$lgt_compile_message_to_object'(Pred, Obj, TPred, Events, Ctx). '$lgt_compile_body'(::Pred, _, TPred, '$lgt_debug'(goal(::Pred, TPred), ExCtx), Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), '$lgt_compile_message_to_self'(Pred, TPred, Ctx). '$lgt_compile_body'(^^Pred, _, TPred, '$lgt_debug'(goal(^^Pred, TPred), ExCtx), Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), '$lgt_compile_super_call'(Pred, TPred, Ctx). % context-switching '$lgt_compile_body'(Obj< % no scope directive TPred = '$lgt_call_in_this'(Pred, ExCtx) ; TPred = '$lgt_call_in_this_checked'(Pred, ExCtx) ). '$lgt_compile_body'(@Pred, Caller, TPred, DPred, Ctx) :- !, '$lgt_check'(callable, Pred), '$lgt_compile_body'(Pred, Caller, TPred, DPred, Ctx). % calling explicitly qualified module predicates '$lgt_compile_body'(':'(_, Callable), Caller, TPred, DPred, Ctx) :- nonvar(Callable), Callable = ':'(Module, Pred), % in a module predicate call with multiple prefixes (e.g., m1:m2:m3:goal), % only the one that immediately precedes the predicate is relevant !, '$lgt_compile_body'(':'(Module, Pred), Caller, TPred, DPred, Ctx). '$lgt_compile_body'(':'(Alias, Pred), Caller, TPred, '$lgt_debug'(goal(':'(Alias, Pred), TPred), ExCtx), Ctx) :- atom(Alias), '$lgt_pp_module_alias_'(Module, Alias, Ctx, _, _), !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), '$lgt_compile_body'(':'(Module, Pred), Caller, TPred, _, Ctx). '$lgt_compile_body'(':'(Module, Pred), _, _, _, Ctx) :- '$lgt_prolog_feature'(modules, unsupported), \+ '$lgt_pp_module_'(_), % not compiling a module as an object % likely typo where a message-sending goal is intended '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(suspicious_calls, warning), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(suspicious_calls), suspicious_call(File, Lines, Type, Entity, ':'(Module, Pred), [Module::Pred]) ), fail. '$lgt_compile_body'(':'(Module, Pred), _, _, _, Ctx) :- atom(Module), callable(Pred), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), logtalk_linter_hook(':'(Module, Pred), Flag, File, Lines, Type, Entity, Warning), nonvar(Flag), '$lgt_valid_flag'(Flag), '$lgt_compiler_flag'(Flag, warning), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'(warning(Flag), Warning), fail. '$lgt_compile_body'(':'(Module, Pred), Caller, TPred, DPred, Ctx) :- !, '$lgt_check'(var_or_module_identifier, Module), '$lgt_check'(var_or_callable, Pred), ( '$lgt_pp_module_'(_) -> % we're compiling a module as an object; assume referenced modules are also compiled as objects '$lgt_compile_body'(Module::Pred, Caller, TPred, DPred, Ctx) ; var(Module) -> '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), TPred = ':'(Module, Pred), DPred = '$lgt_debug'(goal(':'(Module, Pred), TPred), ExCtx) ; var(Pred) -> '$lgt_add_referenced_module'(Module, Ctx), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), TPred = ':'(Module, Pred), DPred = '$lgt_debug'(goal(':'(Module, Pred), TPred), ExCtx) ; \+ '$lgt_prolog_built_in_database_predicate'(Pred), % the meta-predicate templates for the backend Prolog database predicates are usually % not usable from Logtalk due the ambiguity of the ":" meta-argument qualifier but they % pose no problems when operating in a module database; in this particular case, the % explicit-qualified call can be compiled as-is ( '$lgt_pp_meta_predicate_'(':'(Module, Pred), ':'(Module, Meta), _, _) % we're either overriding the original meta-predicate template or working around a % backend Prolog compiler limitation in providing access to meta-predicate templates ; catch('$lgt_predicate_property'(':'(Module, Pred), meta_predicate(Meta)), _, fail) ) -> % we're compiling a call to a module meta-predicate '$lgt_add_referenced_module'(Module, Ctx), '$lgt_comp_ctx'(Ctx, Head, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), '$lgt_add_referenced_module_predicate'(Mode, Module, Pred, Pred, Head), Pred =.. [Functor| Args], Meta =.. [Functor| MArgs], '$lgt_prolog_to_logtalk_meta_argument_specifiers'(MArgs, CMArgs), ( '$lgt_member'(CMArg, CMArgs), CMArg == (::) -> % the "::" meta-argument specifier is ambiguous in this context throw(domain_error(meta_argument_specifier, Meta)) ; ( '$lgt_prolog_phrase_predicate'(':'(Module, Pred)) -> NewCaller = phrase ; NewCaller = meta ), '$lgt_compile_prolog_meta_arguments'(Args, CMArgs, NewCaller, Ctx, TArgs, DArgs) -> TPred0 =.. [Functor| TArgs], TPred = ':'(Module, TPred0), DPred0 =.. [Functor| DArgs], DPred = '$lgt_debug'(goal(':'(Module, Pred), ':'(Module, DPred0)), ExCtx) ; throw(domain_error(meta_directive_template, Meta)) ) ; % we're compiling a call to a module predicate '$lgt_add_referenced_module'(Module, Ctx), '$lgt_comp_ctx'(Ctx, Head, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), '$lgt_add_referenced_module_predicate'(Mode, Module, Pred, Pred, Head), TPred = ':'(Module, Pred), DPred = '$lgt_debug'(goal(':'(Module, Pred), TPred), ExCtx) ). % reflection built-in predicates '$lgt_compile_body'(current_op(Priority, Specifier, Operator), _, TPred, DPred, Ctx) :- '$lgt_comp_ctx'(Ctx, _, _, Entity, _, _, _, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, _, Entity), Entity == user, % usually a call from an initialization or conditional compilation directive !, TPred = current_op(Priority, Specifier, Operator), DPred = '$lgt_debug'(goal(current_op(Priority, Specifier, Operator), TPred), ExCtx). '$lgt_compile_body'(current_op(Priority, Specifier, Operator), _, TPred, DPred, Ctx) :- !, '$lgt_check'(var_or_operator_priority, Priority), '$lgt_check'(var_or_operator_specifier, Specifier), '$lgt_check'(var_or_atom, Operator), '$lgt_comp_ctx'(Ctx, _, _, Entity, _, This, _, _, _, _, ExCtx, _, _, _, _), '$lgt_db_call_database_execution_context'(Entity, This, Database, ExCtx), TPred = '$lgt_current_op'(Database, Priority, Specifier, Operator, Database, p(_), ExCtx), DPred = '$lgt_debug'(goal(current_op(Priority, Specifier, Operator), TPred), ExCtx). '$lgt_compile_body'(current_predicate(Term), _, TPred, DPred, Ctx) :- '$lgt_comp_ctx'(Ctx, _, _, Entity, _, _, _, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, _, Entity), Entity == user, % usually a call from an initialization or conditional compilation directive !, TPred = current_predicate(Term), DPred = '$lgt_debug'(goal(current_predicate(Term), TPred), ExCtx). '$lgt_compile_body'(current_predicate(Term), Caller, TPred, DPred, Ctx) :- nonvar(Term), Term = ':'(Module, Pred), !, '$lgt_check'(var_or_module_identifier, Module), '$lgt_check'(var_or_callable, Pred), ( '$lgt_pp_module_'(_) -> % we're compiling a module as an object; assume referenced modules are also compiled as objects '$lgt_compile_body'(Module::current_predicate(Pred), Caller, TPred, DPred, Ctx) ; % we're using modules together with objects '$lgt_add_referenced_module'(Module, Ctx), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), TPred = current_predicate(':'(Module, Pred)), DPred = '$lgt_debug'(goal(current_predicate(':'(Module, Pred)), TPred), ExCtx) ). '$lgt_compile_body'(current_predicate(Term), Caller, TPred, DPred, Ctx) :- '$lgt_valid_predicate_indicator'(Term, AliasFunctor, Arity), functor(Alias, AliasFunctor, Arity), ( '$lgt_pp_uses_predicate_'(Obj, Head, Alias, Ctx, _, _) -> functor(Head, HeadFunctor, Arity), '$lgt_compile_body'(Obj::current_predicate(HeadFunctor/Arity), Caller, TPred, DPred, Ctx) ; '$lgt_pp_use_module_predicate_'(Module, Head, Alias, Ctx, _, _) -> functor(Head, HeadFunctor, Arity), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), TPred = current_predicate(':'(Module, HeadFunctor/Arity)), DPred = '$lgt_debug'(goal(current_predicate(':'(Module, HeadFunctor/Arity)), TPred), ExCtx) ; fail ), !. '$lgt_compile_body'(current_predicate(Pred), _, TPred, DPred, Ctx) :- !, '$lgt_check'(var_or_predicate_indicator, Pred), '$lgt_comp_ctx'(Ctx, _, _, Entity, _, This, _, _, _, _, ExCtx, _, _, _, _), '$lgt_db_call_database_execution_context'(Entity, This, Database, ExCtx), TPred = '$lgt_current_predicate'(Database, Pred, Database, p(_), ExCtx), DPred = '$lgt_debug'(goal(current_predicate(Pred), TPred), ExCtx). '$lgt_compile_body'(predicate_property(Term, Prop), _, TPred, DPred, Ctx) :- '$lgt_comp_ctx'(Ctx, _, _, Entity, _, _, _, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, _, Entity), Entity == user, % usually a call from an initialization or conditional compilation directive !, TPred = '$lgt_predicate_property'(Term, Prop), DPred = '$lgt_debug'(goal(predicate_property(Term, Prop), TPred), ExCtx). '$lgt_compile_body'(predicate_property(Term, Prop), Caller, TPred, DPred, Ctx) :- nonvar(Term), Term = ':'(Module, Head), !, '$lgt_check'(var_or_module_identifier, Module), '$lgt_check'(var_or_callable, Head), ( '$lgt_pp_module_'(_) -> % we're compiling a module as an object; assume referenced modules are also compiled as objects '$lgt_compile_body'(Module::predicate_property(Head, Prop), Caller, TPred, DPred, Ctx) ; % we're using modules together with objects '$lgt_add_referenced_module'(Module, Ctx), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), TPred = predicate_property(':'(Module, Head), Prop), DPred = '$lgt_debug'(goal(predicate_property(':'(Module,Head), Prop), TPred), ExCtx) ). '$lgt_compile_body'(predicate_property(Alias, Prop), Caller, TPred, DPred, Ctx) :- nonvar(Alias), ( '$lgt_pp_uses_predicate_'(Obj, Head, Alias, Ctx, _, _) -> '$lgt_compile_body'(Obj::predicate_property(Head, Prop), Caller, TPred, DPred, Ctx) ; '$lgt_pp_use_module_predicate_'(Module, Head, Alias, Ctx, _, _) -> '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), TPred = predicate_property(':'(Module, Head), Prop), DPred = '$lgt_debug'(goal(predicate_property(':'(Module,Head), Prop), TPred), ExCtx) ; fail ), !. '$lgt_compile_body'(predicate_property(Pred, Prop), _, TPred, DPred, Ctx) :- !, '$lgt_check'(var_or_callable, Pred), '$lgt_check'(var_or_predicate_property, Prop), '$lgt_comp_ctx'(Ctx, _, _, Entity, _, This, _, _, _, _, ExCtx, _, _, _, _), '$lgt_db_call_database_execution_context'(Entity, This, Database, ExCtx), TPred = '$lgt_predicate_property'(Database, Pred, Prop, Database, p(_), ExCtx), DPred = '$lgt_debug'(goal(predicate_property(Pred, Prop), TPred), ExCtx). % database handling built-in predicates '$lgt_compile_body'(abolish(Functor, Arity), Caller, TCond, DCond, Ctx) :- '$lgt_prolog_built_in_predicate'(abolish(_, _)), \+ '$lgt_pp_defines_predicate_'(abolish(_, _), _, _, _, _, _), !, ( '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(deprecated, warning), '$lgt_source_file_context'(File, Lines), '$lgt_pp_entity_'(Type, Entity, _) -> '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(deprecated), deprecated_predicate(File, Lines, Type, Entity, abolish/2, abolish/1) ) ; true ), '$lgt_compile_body'(abolish(Functor/Arity), Caller, TCond, DCond, Ctx). '$lgt_compile_body'(abolish(Term), Caller, TCond, DCond, Ctx) :- nonvar(Term), Term = ':'(Module, Pred), !, '$lgt_check'(var_or_module_identifier, Module), '$lgt_check'(var_or_callable, Pred), ( '$lgt_pp_module_'(_) -> % we're compiling a module as an object; assume referenced modules are also compiled as objects '$lgt_compile_body'(Module::abolish(Pred), Caller, TCond, DCond, Ctx) ; % we're using modules together with objects '$lgt_add_referenced_module'(Module, Ctx), '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), TCond = abolish(':'(Module, Pred)), DCond = '$lgt_debug'(goal(abolish(':'(Module, Pred)), TCond), ExCtx), ( ground(Term) -> '$lgt_remember_updated_predicate'(Mode, ':'(Module, Pred), CallerHead) ; true ) ). '$lgt_compile_body'(abolish(Pred), Caller, TCond, DCond, Ctx) :- '$lgt_valid_predicate_indicator'(Pred, AliasFunctor, Arity), functor(Alias, AliasFunctor, Arity), ( '$lgt_pp_uses_predicate_'(Obj, Head, Alias, Ctx, _, _) -> functor(Head, HeadFunctor, Arity), '$lgt_compile_body'(Obj::abolish(HeadFunctor/Arity), Caller, TCond, DCond, Ctx), '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, _, _, _, _, _, _, Mode, _, _, _), '$lgt_remember_updated_predicate'(Mode, Obj::HeadFunctor/Arity, CallerHead) ; '$lgt_pp_use_module_predicate_'(Module, Head, Alias, Ctx, _, _) -> functor(Head, HeadFunctor, Arity), '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), TCond = abolish(':'(Module, HeadFunctor/Arity)), DCond = '$lgt_debug'(goal(abolish(':'(Module, HeadFunctor/Arity)), TCond), ExCtx), '$lgt_remember_updated_predicate'(Mode, ':'(Module, HeadFunctor/Arity), CallerHead) ; % proceed to next clause fail ), !. '$lgt_compile_body'(abolish(Pred), _, TCond, DCond, Ctx) :- !, '$lgt_comp_ctx'(Ctx, Head, _, Entity, _, This, _, _, _, _, ExCtx, Mode, _, _, _), '$lgt_db_call_database_execution_context'(Entity, This, Database, ExCtx), '$lgt_check'(var_or_predicate_indicator, Pred), '$lgt_check_dynamic_directive'(Mode, Pred), ( ground(Pred) -> TCond = '$lgt_abolish_checked'(Database, Pred, Database, p(_), ExCtx), '$lgt_remember_updated_predicate'(Mode, Pred, Head) ; % partially instantiated predicate indicator; runtime check required TCond = '$lgt_abolish'(Database, Pred, Database, p(_), ExCtx) ), DCond = '$lgt_debug'(goal(abolish(Pred), TCond), ExCtx). '$lgt_compile_body'(assert(Clause), Caller, TCond, DCond, Ctx) :- '$lgt_prolog_built_in_predicate'(assert(_)), \+ '$lgt_pp_defines_predicate_'(assert(_), _, _, _, _, _), !, ( '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(deprecated, warning), '$lgt_source_file_context'(File, Lines), '$lgt_pp_entity_'(Type, Entity, _) -> '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(deprecated), deprecated_predicate(File, Lines, Type, Entity, assert/1, assertz/1) ) ; true ), '$lgt_compile_body'(assertz(Clause), Caller, TCond, DCond, Ctx). '$lgt_compile_body'(asserta(QClause), Caller, TCond, DCond, Ctx) :- nonvar(QClause), '$lgt_module_qualified_clause'(QClause, Module, Clause, Head, Body), !, '$lgt_check'(var_or_module_identifier, Module), '$lgt_check'(var_or_callable, Head), '$lgt_check'(var_or_callable, Body), ( '$lgt_pp_module_'(_) -> % we're compiling a module as an object; assume referenced modules are also compiled as objects '$lgt_compile_body'(Module::asserta(Clause), Caller, TCond, DCond, Ctx) ; % we're using modules together with objects '$lgt_add_referenced_module'(Module, Ctx), '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), TCond = asserta(QClause), DCond = '$lgt_debug'(goal(asserta(QClause), TCond), ExCtx), ( ground(QClause) -> functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, ':'(Module, Functor/Arity), CallerHead) ; true ) ). '$lgt_compile_body'(asserta(Clause), Caller, TCond, DCond, Ctx) :- nonvar(Clause), ( Clause = (Alias :- Body) -> nonvar(Alias), ( '$lgt_pp_uses_predicate_'(Obj, Head, Alias, Ctx, _, _) -> '$lgt_compile_body'(Obj::asserta((Head :- Body)), Caller, TCond, DCond, Ctx), '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, _, _, _, _, _, _, Mode, _, _, _), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Obj::Functor/Arity, CallerHead) ; '$lgt_pp_use_module_predicate_'(Module, Head, Alias, Ctx, _, _) -> '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), TCond = asserta((':'(Module,Head) :- Body)), DCond = '$lgt_debug'(goal(asserta((':'(Module,Head) :- Body)), TCond), ExCtx), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, ':'(Module, Functor/Arity), CallerHead) ; % proceed to next clause fail ) ; Clause = Alias, ( '$lgt_pp_uses_predicate_'(Obj, Head, Alias, Ctx, _, _) -> '$lgt_compile_body'(Obj::asserta(Head), Caller, TCond, DCond, Ctx), '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, _, _, _, _, _, _, Mode, _, _, _), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Obj::Functor/Arity, CallerHead) ; '$lgt_pp_use_module_predicate_'(Module, Head, Alias, Ctx, _, _) -> '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), TCond = asserta(':'(Module,Head)), DCond = '$lgt_debug'(goal(asserta(':'(Module,Head)), TCond), ExCtx), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, ':'(Module, Functor/Arity), CallerHead) ; % proceed to next clause fail ) ), !. '$lgt_compile_body'(asserta(Clause), _, TCond, DCond, Ctx) :- !, '$lgt_comp_ctx'(Ctx, CallerHead, _, Entity, _, This, _, _, _, _, ExCtx, Mode, _, _, _), ( '$lgt_optimizable_local_db_call'(Clause, TClause) -> TCond = asserta(TClause), functor(Clause, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Functor/Arity, CallerHead) ; '$lgt_db_call_database_execution_context'(Entity, This, Database, ExCtx), ( '$lgt_runtime_checked_db_clause'(Clause) -> TCond = '$lgt_asserta'(Database, Clause, Database, p(_), p, ExCtx) ; '$lgt_check'(clause, Clause), ( Clause = (Head :- Body) -> ( Body == true -> TCond = '$lgt_asserta_fact_checked'(Database, Head, Database, p(_), p, ExCtx) ; TCond = '$lgt_asserta_rule_checked'(Database, Clause, Database, p(_), p, ExCtx) ), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Functor/Arity, CallerHead) ; TCond = '$lgt_asserta_fact_checked'(Database, Clause, Database, p(_), p, ExCtx), functor(Clause, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Functor/Arity, CallerHead) ) ), '$lgt_check_dynamic_directive'(Mode, Clause) ), DCond = '$lgt_debug'(goal(asserta(Clause), TCond), ExCtx). '$lgt_compile_body'(assertz(QClause), Caller, TCond, DCond, Ctx) :- nonvar(QClause), '$lgt_module_qualified_clause'(QClause, Module, Clause, Head, Body), !, '$lgt_check'(var_or_module_identifier, Module), '$lgt_check'(var_or_callable, Head), '$lgt_check'(var_or_callable, Body), ( '$lgt_pp_module_'(_) -> % we're compiling a module as an object; assume referenced modules are also compiled as objects '$lgt_compile_body'(Module::assertz(Clause), Caller, TCond, DCond, Ctx) ; % we're using modules together with objects '$lgt_add_referenced_module'(Module, Ctx), '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), TCond = assertz(QClause), DCond = '$lgt_debug'(goal(assertz(QClause), TCond), ExCtx), ( ground(QClause) -> functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, ':'(Module, Functor/Arity), CallerHead) ; true ) ). '$lgt_compile_body'(assertz(Clause), Caller, TCond, DCond, Ctx) :- nonvar(Clause), ( Clause = (Alias :- Body) -> nonvar(Alias), ( '$lgt_pp_uses_predicate_'(Obj, Head, Alias, Ctx, _, _) -> '$lgt_compile_body'(Obj::assertz((Head :- Body)), Caller, TCond, DCond, Ctx), '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, _, _, _, _, _, _, Mode, _, _, _), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Obj::Functor/Arity, CallerHead) ; '$lgt_pp_use_module_predicate_'(Module, Head, Alias, Ctx, _, _) -> '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), TCond = assertz((':'(Module,Head) :- Body)), DCond = '$lgt_debug'(goal(assertz((':'(Module,Head) :- Body)), TCond), ExCtx), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, ':'(Module, Functor/Arity), CallerHead) ; % proceed to next clause fail ) ; Clause = Alias, ( '$lgt_pp_uses_predicate_'(Obj, Head, Alias, Ctx, _, _) -> '$lgt_compile_body'(Obj::assertz(Head), Caller, TCond, DCond, Ctx), '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, _, _, _, _, _, _, Mode, _, _, _), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Obj::Functor/Arity, CallerHead) ; '$lgt_pp_use_module_predicate_'(Module, Head, Alias, Ctx, _, _) -> '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), TCond = assertz(':'(Module,Head)), DCond = '$lgt_debug'(goal(assertz(':'(Module,Head)), TCond), ExCtx), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, ':'(Module, Functor/Arity), CallerHead) ; % proceed to next clause fail ) ), !. '$lgt_compile_body'(assertz(Clause), _, TCond, DCond, Ctx) :- !, '$lgt_comp_ctx'(Ctx, CallerHead, _, Entity, _, This, _, _, _, _, ExCtx, Mode, _, _, _), ( '$lgt_optimizable_local_db_call'(Clause, TClause) -> TCond = assertz(TClause), functor(Clause, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Functor/Arity, CallerHead) ; '$lgt_db_call_database_execution_context'(Entity, This, Database, ExCtx), ( '$lgt_runtime_checked_db_clause'(Clause) -> TCond = '$lgt_assertz'(Database, Clause, Database, p(_), p, ExCtx) ; '$lgt_check'(clause, Clause), ( Clause = (Head :- Body) -> ( Body == true -> TCond = '$lgt_assertz_fact_checked'(Database, Head, Database, p(_), p, ExCtx) ; TCond = '$lgt_assertz_rule_checked'(Database, Clause, Database, p(_), p, ExCtx) ), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Functor/Arity, CallerHead) ; TCond = '$lgt_assertz_fact_checked'(Database, Clause, Database, p(_), p, ExCtx), functor(Clause, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Functor/Arity, CallerHead) ) ), '$lgt_check_dynamic_directive'(Mode, Clause) ), DCond = '$lgt_debug'(goal(assertz(Clause), TCond), ExCtx). '$lgt_compile_body'(clause(QHead, Body), Caller, TCond, DCond, Ctx) :- nonvar(QHead), QHead = ':'(Module, Head), !, '$lgt_check'(var_or_module_identifier, Module), '$lgt_check'(var_or_callable, Head), '$lgt_check'(var_or_callable, Body), ( '$lgt_pp_module_'(_) -> % we're compiling a module as an object; assume referenced modules are also compiled as objects '$lgt_compile_body'(Module::clause(Head, Body), Caller, TCond, DCond, Ctx) ; % we're using modules together with objects '$lgt_add_referenced_module'(Module, Ctx), '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), TCond = clause(QHead, Body), DCond = '$lgt_debug'(goal(clause(QHead, Body), TCond), ExCtx), ( ground(QHead) -> functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, ':'(Module, Functor/Arity), CallerHead) ; true ) ). '$lgt_compile_body'(clause(Alias, Body), Caller, TCond, DCond, Ctx) :- nonvar(Alias), ( '$lgt_pp_uses_predicate_'(Obj, Head, Alias, Ctx, _, _) -> '$lgt_compile_body'(Obj::clause(Head, Body), Caller, TCond, DCond, Ctx), '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, _, _, _, _, _, _, Mode, _, _, _), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Obj::Functor/Arity, CallerHead) ; '$lgt_pp_use_module_predicate_'(Module, Head, Alias, Ctx, _, _) -> '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), TCond = clause(':'(Module,Head), Body), DCond = '$lgt_debug'(goal(clause(':'(Module,Head), Body), TCond), ExCtx), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, ':'(Module, Functor/Arity), CallerHead) ; fail ), !. '$lgt_compile_body'(clause(Head, Body), _, TCond, DCond, Ctx) :- !, '$lgt_comp_ctx'(Ctx, CallerHead, _, Entity, _, This, _, _, _, _, ExCtx, Mode, _, _, _), ( '$lgt_optimizable_local_db_call'(Head, THead) -> '$lgt_check'(var_or_callable, Body), TCond = (clause(THead, TBody), (TBody = ('$lgt_nop'(Body), _) -> true; TBody = Body)), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Functor/Arity, CallerHead) ; '$lgt_db_call_database_execution_context'(Entity, This, Database, ExCtx), ( '$lgt_runtime_checked_db_clause'((Head :- Body)) -> TCond = '$lgt_clause'(Database, Head, Body, Database, p(_), ExCtx) ; '$lgt_check'(clause, (Head :- Body)), TCond = '$lgt_clause_checked'(Database, Head, Body, Database, p(_), ExCtx), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Functor/Arity, CallerHead) ), '$lgt_check_dynamic_directive'(Mode, Head) ), DCond = '$lgt_debug'(goal(clause(Head, Body), TCond), ExCtx). '$lgt_compile_body'(retract(QClause), Caller, TCond, DCond, Ctx) :- nonvar(QClause), '$lgt_module_qualified_clause'(QClause, Module, Clause, Head, Body), !, '$lgt_check'(var_or_module_identifier, Module), '$lgt_check'(var_or_callable, Head), '$lgt_check'(var_or_callable, Body), ( '$lgt_pp_module_'(_) -> % we're compiling a module as an object; assume referenced modules are also compiled as objects '$lgt_compile_body'(Module::retract(Clause), Caller, TCond, DCond, Ctx) ; % we're using modules together with objects '$lgt_add_referenced_module'(Module, Ctx), '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), TCond = retract(QClause), DCond = '$lgt_debug'(goal(retract(QClause), TCond), ExCtx), ( ground(QClause) -> functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, ':'(Module, Functor/Arity), CallerHead) ; true ) ). '$lgt_compile_body'(retract(Clause), Caller, TCond, DCond, Ctx) :- nonvar(Clause), ( Clause = (Alias :- Body) -> nonvar(Alias), ( '$lgt_pp_uses_predicate_'(Obj, Head, Alias, Ctx, _, _) -> '$lgt_compile_body'(Obj::retract((Head :- Body)), Caller, TCond, DCond, Ctx), '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, _, _, _, _, _, _, Mode, _, _, _), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Obj::Functor/Arity, CallerHead) ; '$lgt_pp_use_module_predicate_'(Module, Head, Alias, Ctx, _, _) -> '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), TCond = retract((':'(Module,Head) :- Body)), DCond = '$lgt_debug'(goal(retract((':'(Module,Head) :- Body)), TCond), ExCtx), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, ':'(Module, Functor/Arity), CallerHead) ; % proceed to next clause fail ) ; Clause = Alias, ( '$lgt_pp_uses_predicate_'(Obj, Head, Alias, Ctx, _, _) -> '$lgt_compile_body'(Obj::retract(Head), Caller, TCond, DCond, Ctx), '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, _, _, _, _, _, _, Mode, _, _, _), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Obj::Functor/Arity, CallerHead) ; '$lgt_pp_use_module_predicate_'(Module, Head, Alias, Ctx, _, _) -> '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), TCond = retract(':'(Module,Head)), DCond = '$lgt_debug'(goal(retract(':'(Module,Head)), TCond), ExCtx), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, ':'(Module, Functor/Arity), CallerHead) ; % proceed to next clause fail ) ), !. '$lgt_compile_body'(retract(Clause), _, TCond, DCond, Ctx) :- !, '$lgt_comp_ctx'(Ctx, CallerHead, _, Entity, _, This, _, _, _, _, ExCtx, Mode, _, _, _), ( '$lgt_optimizable_local_db_call'(Clause, TClause) -> TCond = retract(TClause), functor(Clause, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Functor/Arity, CallerHead) ; '$lgt_db_call_database_execution_context'(Entity, This, Database, ExCtx), ( '$lgt_runtime_checked_db_clause'(Clause) -> TCond = '$lgt_retract'(Database, Clause, Database, p(_), ExCtx) ; '$lgt_check'(clause, Clause), ( Clause = (Head :- Body) -> ( var(Body) -> TCond = '$lgt_retract_var_body_checked'(Database, Clause, Database, p(_), ExCtx) ; Body == true -> TCond = '$lgt_retract_fact_checked'(Database, Head, Database, p(_), ExCtx) ; TCond = '$lgt_retract_rule_checked'(Database, Clause, Database, p(_), ExCtx) ), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Functor/Arity, CallerHead) ; TCond = '$lgt_retract_fact_checked'(Database, Clause, Database, p(_), ExCtx), functor(Clause, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Functor/Arity, CallerHead) ) ), '$lgt_check_dynamic_directive'(Mode, Clause) ), DCond = '$lgt_debug'(goal(retract(Clause), TCond), ExCtx). '$lgt_compile_body'(retractall(QHead), Caller, TCond, DCond, Ctx) :- nonvar(QHead), QHead = ':'(Module, Head), !, '$lgt_check'(var_or_module_identifier, Module), '$lgt_check'(var_or_callable, Head), ( '$lgt_pp_module_'(_) -> % we're compiling a module as an object; assume referenced modules are also compiled as objects '$lgt_compile_body'(Module::retractall(Head), Caller, TCond, DCond, Ctx) ; % we're using modules together with objects '$lgt_add_referenced_module'(Module, Ctx), '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), TCond = retractall(QHead), DCond = '$lgt_debug'(goal(retractall(QHead), TCond), ExCtx), ( ground(QHead) -> functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, ':'(Module, Functor/Arity), CallerHead) ; true ) ). '$lgt_compile_body'(retractall(Alias), Caller, TCond, DCond, Ctx) :- nonvar(Alias), ( '$lgt_pp_uses_predicate_'(Obj, Head, Alias, Ctx, _, _) -> '$lgt_compile_body'(Obj::retractall(Head), Caller, TCond, DCond, Ctx), '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, _, _, _, _, _, _, Mode, _, _, _), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Obj::Functor/Arity, CallerHead) ; '$lgt_pp_use_module_predicate_'(Module, Head, Alias, Ctx, _, _) -> '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), TCond = retractall(':'(Module,Head)), DCond = '$lgt_debug'(goal(retractall(':'(Module,Head)), TCond), ExCtx), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, ':'(Module, Functor/Arity), CallerHead) ; % proceed to next clause fail ), !. '$lgt_compile_body'(retractall(Head), _, TCond, DCond, Ctx) :- !, '$lgt_comp_ctx'(Ctx, CallerHead, _, Entity, _, This, _, _, _, _, ExCtx, Mode, _, _, _), ( '$lgt_optimizable_local_db_call'(Head, THead) -> TCond = retractall(THead), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Functor/Arity, CallerHead) ; '$lgt_db_call_database_execution_context'(Entity, This, Database, ExCtx), ( var(Head) -> TCond = '$lgt_retractall'(Database, Head, Database, p(_), ExCtx) ; '$lgt_check'(callable, Head), TCond = '$lgt_retractall_checked'(Database, Head, Database, p(_), ExCtx), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Functor/Arity, CallerHead) ), '$lgt_check_dynamic_directive'(Mode, Head) ), DCond = '$lgt_debug'(goal(retractall(Head), TCond), ExCtx). % database handling built-in predicates that take a clause reference % if supported as built-in predicates by the backend Prolog compiler '$lgt_compile_body'(assert(Clause, Ref), Caller, TCond, DCond, Ctx) :- '$lgt_prolog_built_in_predicate'(assert(_, _)), \+ '$lgt_pp_defines_predicate_'(assert(_, _), _, _, _, _, _), !, ( '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(deprecated, warning), '$lgt_source_file_context'(File, Lines), '$lgt_pp_entity_'(Type, Entity, _) -> '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(deprecated), deprecated_predicate(File, Lines, Type, Entity, assert/2, assertz/2) ) ; true ), '$lgt_compile_body'(assertz(Clause, Ref), Caller, TCond, DCond, Ctx). '$lgt_compile_body'(asserta(QClause, Ref), Caller, TCond, DCond, Ctx) :- '$lgt_prolog_built_in_predicate'(asserta(_, _)), \+ '$lgt_pp_defines_predicate_'(asserta(_, _), _, _, _, _, _), nonvar(QClause), '$lgt_module_qualified_clause'(QClause, Module, Clause, Head, Body), !, '$lgt_check'(var_or_module_identifier, Module), '$lgt_check'(var_or_callable, Head), '$lgt_check'(var_or_callable, Body), ( '$lgt_pp_module_'(_) -> % we're compiling a module as an object; assume referenced modules are also compiled as objects '$lgt_compile_body'(Module::asserta(Clause, Ref), Caller, TCond, DCond, Ctx) ; % we're using modules together with objects '$lgt_add_referenced_module'(Module, Ctx), '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), TCond = asserta(QClause, Ref), DCond = '$lgt_debug'(goal(asserta(QClause, Ref), TCond), ExCtx), ( ground(QClause) -> functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, ':'(Module, Functor/Arity), CallerHead) ; true ) ). '$lgt_compile_body'(asserta(Clause, Ref), Caller, TCond, DCond, Ctx) :- '$lgt_prolog_built_in_predicate'(asserta(_, _)), \+ '$lgt_pp_defines_predicate_'(asserta(_, _), _, _, _, _, _), nonvar(Clause), ( Clause = (Alias :- Body) -> nonvar(Alias), ( '$lgt_pp_uses_predicate_'(Obj, Head, Alias, Ctx, _, _) -> '$lgt_compile_body'(Obj::asserta((Head :- Body), Ref), Caller, TCond, DCond, Ctx), '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, _, _, _, _, _, _, Mode, _, _, _), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Obj::Functor/Arity, CallerHead) ; '$lgt_pp_use_module_predicate_'(Module, Head, Alias, Ctx, _, _) -> '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), TCond = asserta((':'(Module,Head) :- Body), Ref), DCond = '$lgt_debug'(goal(asserta((':'(Module,Head) :- Body), Ref), TCond), ExCtx), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, ':'(Module, Functor/Arity), CallerHead) ; % proceed to next clause fail ) ; Clause = Alias, ( '$lgt_pp_uses_predicate_'(Obj, Head, Alias, Ctx, _, _) -> '$lgt_compile_body'(Obj::asserta(Head, Ref), Caller, TCond, DCond, Ctx), '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, _, _, _, _, _, _, Mode, _, _, _), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Obj::Functor/Arity, CallerHead) ; '$lgt_pp_use_module_predicate_'(Module, Head, Alias, Ctx, _, _) -> '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), TCond = asserta(':'(Module,Head), Ref), DCond = '$lgt_debug'(goal(asserta(':'(Module,Head), Ref), TCond), ExCtx), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, ':'(Module, Functor/Arity), CallerHead) ; % proceed to next clause fail ) ), !. '$lgt_compile_body'(asserta(Clause, Ref), _, TCond, DCond, Ctx) :- '$lgt_prolog_built_in_predicate'(asserta(_, _)), \+ '$lgt_pp_defines_predicate_'(asserta(_, _), _, _, _, _, _), !, '$lgt_comp_ctx'(Ctx, CallerHead, _, Entity, _, This, _, _, _, _, ExCtx, Mode, _, _, _), ( '$lgt_optimizable_local_db_call'(Clause, TClause) -> TCond = asserta(TClause, Ref), functor(Clause, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Functor/Arity, CallerHead) ; '$lgt_db_call_database_execution_context'(Entity, This, Database, ExCtx), ( '$lgt_runtime_checked_db_clause'(Clause) -> TCond = '$lgt_asserta'(Database, Clause, Ref, Database, p(_), p) ; '$lgt_check'(clause, Clause), ( Clause = (Head :- Body) -> ( Body == true -> TCond = '$lgt_asserta_fact_checked'(Database, Head, Ref, Database, p(_), p, ExCtx) ; TCond = '$lgt_asserta_rule_checked'(Database, Clause, Ref, Database, p(_), p, ExCtx) ), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Functor/Arity, CallerHead) ; TCond = '$lgt_asserta_fact_checked'(Database, Clause, Ref, Database, p(_), p, ExCtx), functor(Clause, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Functor/Arity, CallerHead) ) ), '$lgt_check_dynamic_directive'(Mode, Clause) ), DCond = '$lgt_debug'(goal(asserta(Clause, Ref), TCond), ExCtx). '$lgt_compile_body'(assertz(QClause, Ref), Caller, TCond, DCond, Ctx) :- '$lgt_prolog_built_in_predicate'(assertz(_, _)), \+ '$lgt_pp_defines_predicate_'(assertz(_, _), _, _, _, _, _), nonvar(QClause), '$lgt_module_qualified_clause'(QClause, Module, Clause, Head, Body), !, '$lgt_check'(var_or_module_identifier, Module), '$lgt_check'(var_or_callable, Head), '$lgt_check'(var_or_callable, Body), ( '$lgt_pp_module_'(_) -> % we're compiling a module as an object; assume referenced modules are also compiled as objects '$lgt_compile_body'(Module::assertz(Clause, Ref), Caller, TCond, DCond, Ctx) ; % we're using modules together with objects '$lgt_add_referenced_module'(Module, Ctx), '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), TCond = assertz(QClause), DCond = '$lgt_debug'(goal(assertz(QClause, Ref), TCond), ExCtx), ( ground(QClause) -> functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, ':'(Module, Functor/Arity), CallerHead) ; true ) ). '$lgt_compile_body'(assertz(Clause, Ref), Caller, TCond, DCond, Ctx) :- '$lgt_prolog_built_in_predicate'(assertz(_, _)), \+ '$lgt_pp_defines_predicate_'(assertz(_, _), _, _, _, _, _), nonvar(Clause), ( Clause = (Alias :- Body) -> nonvar(Alias), ( '$lgt_pp_uses_predicate_'(Obj, Head, Alias, Ctx, _, _) -> '$lgt_compile_body'(Obj::assertz((Head :- Body), Ref), Caller, TCond, DCond, Ctx), '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, _, _, _, _, _, _, Mode, _, _, _), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Obj::Functor/Arity, CallerHead) ; '$lgt_pp_use_module_predicate_'(Module, Head, Alias, Ctx, _, _) -> '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), TCond = assertz((':'(Module,Head) :- Body), Ref), DCond = '$lgt_debug'(goal(assertz((':'(Module,Head) :- Body), Ref), TCond), ExCtx), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, ':'(Module, Functor/Arity), CallerHead) ; % proceed to next clause fail ) ; Clause = Alias, ( '$lgt_pp_uses_predicate_'(Obj, Head, Alias, Ctx, _, _) -> '$lgt_compile_body'(Obj::assertz(Head, Ref), Caller, TCond, DCond, Ctx), '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, _, _, _, _, _, _, Mode, _, _, _), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Obj::Functor/Arity, CallerHead) ; '$lgt_pp_use_module_predicate_'(Module, Head, Alias, Ctx, _, _) -> '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), TCond = assertz(':'(Module,Head), Ref), DCond = '$lgt_debug'(goal(assertz(':'(Module,Head), Ref), TCond), ExCtx), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, ':'(Module, Functor/Arity), CallerHead) ; % proceed to next clause fail ) ), !. '$lgt_compile_body'(assertz(Clause, Ref), _, TCond, DCond, Ctx) :- '$lgt_prolog_built_in_predicate'(assertz(_, _)), \+ '$lgt_pp_defines_predicate_'(assertz(_, _), _, _, _, _, _), !, '$lgt_comp_ctx'(Ctx, CallerHead, _, Entity, _, This, _, _, _, _, ExCtx, Mode, _, _, _), ( '$lgt_optimizable_local_db_call'(Clause, TClause) -> TCond = assertz(TClause, Ref), functor(Clause, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Functor/Arity, CallerHead) ; '$lgt_db_call_database_execution_context'(Entity, This, Database, ExCtx), ( '$lgt_runtime_checked_db_clause'(Clause) -> TCond = '$lgt_assertz'(Database, Clause, Ref, Database, p(_), p, ExCtx) ; '$lgt_check'(clause, Clause), ( Clause = (Head :- Body) -> ( Body == true -> TCond = '$lgt_assertz_fact_checked'(Database, Head, Ref, Database, p(_), p, ExCtx) ; TCond = '$lgt_assertz_rule_checked'(Database, Clause, Ref, Database, p(_), p, ExCtx) ), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Functor/Arity, CallerHead) ; TCond = '$lgt_assertz_fact_checked'(Database, Clause, Ref, Database, p(_), p, ExCtx), functor(Clause, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Functor/Arity, CallerHead) ) ), '$lgt_check_dynamic_directive'(Mode, Clause) ), DCond = '$lgt_debug'(goal(assertz(Clause, Ref), TCond), ExCtx). '$lgt_compile_body'(clause(QHead, Body, Ref), Caller, TCond, DCond, Ctx) :- '$lgt_prolog_built_in_predicate'(clause(_, _, _)), \+ '$lgt_pp_defines_predicate_'(clause(_, _, _), _, _, _, _, _), nonvar(QHead), QHead = ':'(Module, Head), !, '$lgt_check'(var_or_module_identifier, Module), '$lgt_check'(var_or_callable, Head), '$lgt_check'(var_or_callable, Body), ( '$lgt_pp_module_'(_) -> % we're compiling a module as an object; assume referenced modules are also compiled as objects '$lgt_compile_body'(Module::clause(Head, Body, Ref), Caller, TCond, DCond, Ctx) ; % we're using modules together with objects '$lgt_add_referenced_module'(Module, Ctx), '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), TCond = clause(QHead, Body, Ref), DCond = '$lgt_debug'(goal(clause(QHead, Body, Ref), TCond), ExCtx), ( ground(QHead) -> functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, ':'(Module, Functor/Arity), CallerHead) ; true ) ). '$lgt_compile_body'(clause(Alias, Body, Ref), Caller, TCond, DCond, Ctx) :- '$lgt_prolog_built_in_predicate'(clause(_, _, _)), \+ '$lgt_pp_defines_predicate_'(clause(_, _, _), _, _, _, _, _), nonvar(Alias), ( '$lgt_pp_uses_predicate_'(Obj, Head, Alias, Ctx, _, _) -> '$lgt_compile_body'(Obj::clause(Head, Body, Ref), Caller, TCond, DCond, Ctx), '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, _, _, _, _, _, _, Mode, _, _, _), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Obj::Functor/Arity, CallerHead) ; '$lgt_pp_use_module_predicate_'(Module, Head, Alias, Ctx, _, _) -> '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), TCond = clause(':'(Module,Head), Body, Ref), DCond = '$lgt_debug'(goal(clause(':'(Module,Head), Body), TCond), ExCtx), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, ':'(Module, Functor/Arity), CallerHead) ; fail ), !. '$lgt_compile_body'(clause(Head, Body, Ref), _, TCond, DCond, Ctx) :- '$lgt_prolog_built_in_predicate'(clause(_, _, _)), \+ '$lgt_pp_defines_predicate_'(clause(_, _, _), _, _, _, _, _), !, '$lgt_comp_ctx'(Ctx, CallerHead, _, Entity, _, This, _, _, _, _, ExCtx, Mode, _, _, _), ( '$lgt_optimizable_local_db_call'(Head, THead) -> '$lgt_check'(var_or_callable, Body), TCond = (clause(THead, TBody, Ref), (TBody = ('$lgt_nop'(Body), _) -> true; TBody = Body)), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Functor/Arity, CallerHead) ; '$lgt_db_call_database_execution_context'(Entity, This, Database, ExCtx), ( '$lgt_runtime_checked_db_clause'((Head :- Body)) -> TCond = '$lgt_clause'(Database, Head, Body, Ref, Database, p(_), ExCtx) ; '$lgt_check'(clause, (Head :- Body)), TCond = '$lgt_clause_checked'(Database, Head, Body, Ref, Database, p(_), ExCtx), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Functor/Arity, CallerHead) ), '$lgt_check_dynamic_directive'(Mode, Head) ), DCond = '$lgt_debug'(goal(clause(Head, Body, Ref), TCond), ExCtx). '$lgt_compile_body'(erase(Ref), _, erase(Ref), '$lgt_debug'(goal(erase(Ref), erase(Ref)), ExCtx), Ctx) :- '$lgt_prolog_built_in_predicate'(erase(_)), \+ '$lgt_pp_defines_predicate_'(erase(_), _, _, _, _, _), !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx). % term and goal expansion predicates '$lgt_compile_body'(expand_term(Term, Expansion), _, TPred, '$lgt_debug'(goal(expand_term(Term, Expansion), TPred), ExCtx), Ctx) :- !, '$lgt_comp_ctx'(Ctx, _, _, Entity, _, _, _, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, _, Entity), TPred = '$lgt_expand_term_local'(Entity, Term, Expansion, ExCtx). '$lgt_compile_body'(expand_goal(Goal, ExpandedGoal), _, TPred, '$lgt_debug'(goal(expand_goal(Goal, ExpandedGoal), TPred), ExCtx), Ctx) :- !, '$lgt_comp_ctx'(Ctx, _, _, Entity, _, _, _, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, _, Entity), TPred = '$lgt_expand_goal_local'(Entity, Goal, ExpandedGoal, ExCtx). % DCG predicates % % defer to runtime compilation of variable grammar rule % body arguments to prevent a compilation endless loop '$lgt_compile_body'(phrase(GRBody, Input), _, TPred, '$lgt_debug'(goal(phrase(GRBody, Input), TPred), ExCtx), Ctx) :- var(GRBody), !, '$lgt_check'(list_or_partial_list, Input), '$lgt_comp_ctx'(Ctx, _, HeadExCtx, _, _, _, _, _, MetaVars, _, ExCtx, _, _, _, _), ( '$lgt_member_var'(GRBody, MetaVars) -> TPred = '$lgt_phrase'(GRBody, Input, HeadExCtx, runtime) ; TPred = '$lgt_phrase'(GRBody, Input, HeadExCtx, local) ). '$lgt_compile_body'(phrase(::GRBody, Input), _, TPred, '$lgt_debug'(goal(phrase(GRBody, Input), TPred), ExCtx), Ctx) :- var(GRBody), !, '$lgt_check'(list_or_partial_list, Input), '$lgt_comp_ctx'(Ctx, _, HeadExCtx, _, _, _, _, _, _, _, ExCtx, _, _, _, _), TPred = '$lgt_phrase'(::GRBody, Input, HeadExCtx, local). '$lgt_compile_body'(phrase(Obj::GRBody, Input), _, TPred, '$lgt_debug'(goal(phrase(GRBody, Input), TPred), ExCtx), Ctx) :- var(GRBody), !, '$lgt_check'(list_or_partial_list, Input), '$lgt_comp_ctx'(Ctx, _, HeadExCtx, _, _, _, _, _, _, _, ExCtx, _, _, _, _), TPred = '$lgt_phrase'(Obj::GRBody, Input, HeadExCtx, local). '$lgt_compile_body'(phrase(^^GRBody, Input), _, TPred, '$lgt_debug'(goal(phrase(GRBody, Input), TPred), ExCtx), Ctx) :- var(GRBody), !, '$lgt_check'(list_or_partial_list, Input), '$lgt_comp_ctx'(Ctx, _, HeadExCtx, _, _, _, _, _, _, _, ExCtx, _, _, _, _), TPred = '$lgt_phrase'(^^GRBody, Input, HeadExCtx, local). '$lgt_compile_body'(phrase(Obj< TPred = '$lgt_phrase'(GRBody, Input, Rest, HeadExCtx, runtime) ; TPred = '$lgt_phrase'(GRBody, Input, Rest, HeadExCtx, local) ). '$lgt_compile_body'(phrase(::GRBody, Input, Rest), _, TPred, '$lgt_debug'(goal(phrase(GRBody, Input, Rest), TPred), ExCtx), Ctx) :- var(GRBody), !, '$lgt_check'(list_or_partial_list, Input), '$lgt_check'(list_or_partial_list, Rest), '$lgt_comp_ctx'(Ctx, _, HeadExCtx, _, _, _, _, _, _, _, ExCtx, _, _, _, _), TPred = '$lgt_phrase'(::GRBody, Input, Rest, HeadExCtx, local). '$lgt_compile_body'(phrase(Obj::GRBody, Input, Rest), _, TPred, '$lgt_debug'(goal(phrase(GRBody, Input, Rest), TPred), ExCtx), Ctx) :- var(GRBody), !, '$lgt_check'(list_or_partial_list, Input), '$lgt_check'(list_or_partial_list, Rest), '$lgt_comp_ctx'(Ctx, _, HeadExCtx, _, _, _, _, _, _, _, ExCtx, _, _, _, _), TPred = '$lgt_phrase'(Obj::GRBody, Input, Rest, HeadExCtx, local). '$lgt_compile_body'(phrase(^^GRBody, Input, Rest), _, TPred, '$lgt_debug'(goal(phrase(GRBody, Input, Rest), TPred), ExCtx), Ctx) :- var(GRBody), !, '$lgt_check'(list_or_partial_list, Input), '$lgt_check'(list_or_partial_list, Rest), '$lgt_comp_ctx'(Ctx, _, HeadExCtx, _, _, _, _, _, _, _, ExCtx, _, _, _, _), TPred = '$lgt_phrase'(^^GRBody, Input, Rest, HeadExCtx, local). '$lgt_compile_body'(phrase(Obj< throw(representation_error(acyclic_term)) ; Head0 = _::Head -> % multifile predicate true ; Head0 = ':'(_,Head) -> % assume Prolog module multifile predicate true ; Head0 = Head ), '$lgt_comp_ctx_head_exec_ctx'(Ctx, ExCtx), Context = logtalk(Head, ExCtx). '$lgt_compile_body'(sender(Sender), _, TPred, '$lgt_debug'(goal(sender(DSender), DPred), ExCtx), Ctx) :- !, '$lgt_comp_ctx_head_exec_ctx'(Ctx, ExCtx), '$lgt_execution_context'(ExCtx, _, Sender0, _, _, _, _), ( var(Sender) -> % compile-time unification Sender0 = Sender, TPred = true, DPred = (DSender = Sender) ; % we must delay unification to runtime TPred = (Sender0 = Sender), DPred = TPred, DSender = Sender ). '$lgt_compile_body'(this(This), _, TPred, '$lgt_debug'(goal(this(DThis), DPred), ExCtx), Ctx) :- !, '$lgt_comp_ctx_head_exec_ctx'(Ctx, ExCtx), '$lgt_execution_context_this_entity'(ExCtx, This0, _), ( var(This) -> % compile-time unification This0 = This, TPred = true, DPred = (DThis = This) ; % we must delay unification to runtime TPred = (This0 = This), DPred = TPred, DThis = This ). '$lgt_compile_body'(self(Self), _, TPred, '$lgt_debug'(goal(self(DSelf), DPred), ExCtx), Ctx) :- !, '$lgt_comp_ctx_head_exec_ctx'(Ctx, ExCtx), '$lgt_execution_context'(ExCtx, _, _, _, Self0, _, _), ( var(Self) -> % compile-time unification Self0 = Self, TPred = true, DPred = (DSelf = Self) ; % we must delay unification to runtime TPred = (Self0 = Self), DPred = TPred, DSelf = Self ). '$lgt_compile_body'(parameter(Arg, _), _, _, _, Ctx) :- '$lgt_check'(integer, Arg), ( '$lgt_pp_entity_'(_, Entity, _) -> % compile-time true ; % runtime < % compile-time; instantiate the Entity argument in the compilation context true ; % runtime < arg(Arg, Entity, Value0), ( var(Value) -> % parameter compile-time unification Value0 = Value, TPred = true, DPred = (DValue = Value) ; % we must delay unification to runtime TPred = (Value0 = Value), DPred = TPred, DValue = Value ) ; throw(domain_error([1,Arity], Arg)) ). % open/4 portability lint warnings only '$lgt_compile_body'(open(_, _, _, Options), _, _, _, Ctx) :- '$lgt_comp_ctx_mode'(Ctx, Mode), '$lgt_check_open_stream_options'(Mode, open/4, Options), fail. % term input predicates that need to be operator aware % (these translations are only applied if there are local entity operators declared) '$lgt_compile_body'(read_term(Stream, Term, Options), _, '$lgt_iso_read_term'(Stream, Term, Options, Ops), '$lgt_debug'(goal(read_term(Stream, Term, Options), '$lgt_iso_read_term'(Stream, Term, Options, Ops)), ExCtx), Ctx) :- '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), '$lgt_check_read_term_options'(Mode, read_term/3, Options), bagof(op(Pr, Spec, Op), Scope^File^Lines^'$lgt_pp_entity_operator_'(Pr, Spec, Op, Scope, File, Lines), Ops), !. '$lgt_compile_body'(read_term(Term, Options), _, '$lgt_iso_read_term'(Term, Options, Ops), '$lgt_debug'(goal(read_term(Term, Options), '$lgt_iso_read_term'(Term, Options, Ops)), ExCtx), Ctx) :- '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), '$lgt_check_read_term_options'(Mode, read_term/2, Options), bagof(op(Pr, Spec, Op), Scope^File^Lines^'$lgt_pp_entity_operator_'(Pr, Spec, Op, Scope, File, Lines), Ops), !. '$lgt_compile_body'(read(Stream, Term), _, '$lgt_iso_read'(Stream, Term, Ops), '$lgt_debug'(goal(read(Stream, Term), '$lgt_iso_read'(Stream, Term, Ops)), ExCtx), Ctx) :- bagof(op(Pr, Spec, Op), Scope^File^Lines^'$lgt_pp_entity_operator_'(Pr, Spec, Op, Scope, File, Lines), Ops), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), !. '$lgt_compile_body'(read(Term), _, '$lgt_iso_read'(Term, Ops), '$lgt_debug'(goal(read(Term), '$lgt_iso_read'(Term, Ops)), ExCtx), Ctx) :- bagof(op(Pr, Spec, Op), Scope^File^Lines^'$lgt_pp_entity_operator_'(Pr, Spec, Op, Scope, File, Lines), Ops), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), !. % term output predicates that need to be operator aware % (these translations are only applied if there are local entity operators declared) '$lgt_compile_body'(write_term(Stream, Term, Options), _, '$lgt_iso_write_term'(Stream, Term, Options, Ops), '$lgt_debug'(goal(write_term(Stream, Term, Options), '$lgt_iso_write_term'(Stream, Term, Options, Ops)), ExCtx), Ctx) :- '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), '$lgt_check_write_term_options'(Mode, write_term/3, Options), ('$lgt_member'(ignore_ops(Value), Options) -> Value \== true; true), bagof(op(Pr, Spec, Op), Scope^File^Lines^'$lgt_pp_entity_operator_'(Pr, Spec, Op, Scope, File, Lines), Ops), !. '$lgt_compile_body'(write_term(Term, Options), _, '$lgt_iso_write_term'(Term, Options, Ops), '$lgt_debug'(goal(write_term(Term, Options), '$lgt_iso_write_term'(Term, Options, Ops)), ExCtx), Ctx) :- '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), '$lgt_check_write_term_options'(Mode, write_term/2, Options), ('$lgt_member'(ignore_ops(Value), Options) -> Value \== true; true), bagof(op(Pr, Spec, Op), Scope^File^Lines^'$lgt_pp_entity_operator_'(Pr, Spec, Op, Scope, File, Lines), Ops), !. '$lgt_compile_body'(write(Stream, Term), _, '$lgt_iso_write'(Stream, Term, Ops), '$lgt_debug'(goal(write(Stream, Term), '$lgt_iso_write'(Stream, Term, Ops)), ExCtx), Ctx) :- bagof(op(Pr, Spec, Op), Scope^File^Lines^'$lgt_pp_entity_operator_'(Pr, Spec, Op, Scope, File, Lines), Ops), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), !. '$lgt_compile_body'(write(Term), _, '$lgt_iso_write'(Term, Ops), '$lgt_debug'(goal(write(Term), '$lgt_iso_write'(Term, Ops)), ExCtx), Ctx) :- bagof(op(Pr, Spec, Op), Scope^File^Lines^'$lgt_pp_entity_operator_'(Pr, Spec, Op, Scope, File, Lines), Ops), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), !. '$lgt_compile_body'(writeq(Stream, Term), _, '$lgt_iso_writeq'(Stream, Term, Ops), '$lgt_debug'(goal(writeq(Stream, Term), '$lgt_iso_writeq'(Stream, Term, Ops)), ExCtx), Ctx) :- bagof(op(Pr, Spec, Op), Scope^File^Lines^'$lgt_pp_entity_operator_'(Pr, Spec, Op, Scope, File, Lines), Ops), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), !. '$lgt_compile_body'(writeq(Term), _, '$lgt_iso_writeq'(Term, Ops), '$lgt_debug'(goal(writeq(Term), '$lgt_iso_writeq'(Term, Ops)), ExCtx), Ctx) :- bagof(op(Pr, Spec, Op), Scope^File^Lines^'$lgt_pp_entity_operator_'(Pr, Spec, Op, Scope, File, Lines), Ops), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), !. % Logtalk flag predicates '$lgt_compile_body'(set_logtalk_flag(Flag, Value), _, TPred, '$lgt_debug'(goal(DPred, TPred), ExCtx), Ctx) :- nonvar(Flag), nonvar(Value), !, '$lgt_check'(read_write_flag, Flag), '$lgt_check'(flag_value, Flag + Value), TPred = '$lgt_set_compiler_flag'(Flag, Value), DPred = set_logtalk_flag(Flag, Value), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx). '$lgt_compile_body'(set_logtalk_flag(Flag, Value), _, TPred, '$lgt_debug'(goal(DPred, TPred), ExCtx), Ctx) :- !, '$lgt_check'(var_or_read_write_flag, Flag), TPred = '$lgt_set_logtalk_flag'(Flag, Value, ExCtx), DPred = set_logtalk_flag(Flag, Value), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx). '$lgt_compile_body'(current_logtalk_flag(Flag, Value), _, TPred, '$lgt_debug'(goal(DPred, TPred), ExCtx), Ctx) :- nonvar(Flag), nonvar(Value), !, '$lgt_check'(flag, Flag), '$lgt_check'(flag_value, Flag + Value), TPred = '$lgt_compiler_flag'(Flag, Value), DPred = current_logtalk_flag(Flag, Value), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx). '$lgt_compile_body'(current_logtalk_flag(Flag, Value), _, TPred, '$lgt_debug'(goal(DPred, TPred), ExCtx), Ctx) :- !, '$lgt_check'(var_or_flag, Flag), TPred = '$lgt_current_logtalk_flag'(Flag, Value, ExCtx), DPred = current_logtalk_flag(Flag, Value), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx). '$lgt_compile_body'(create_logtalk_flag(Flag, Value, Options), _, TPred, '$lgt_debug'(goal(DPred, TPred), ExCtx), Ctx) :- !, '$lgt_check'(atom, Flag), '$lgt_check'(ground, Value), '$lgt_check'(ground, Options), '$lgt_check'(list, Options), TPred = '$lgt_create_logtalk_flag'(Flag, Value, Options, ExCtx), DPred = create_logtalk_flag(Flag, Value, Options), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx). % Prolog flag predicates (just basic error and portability checking) '$lgt_compile_body'(set_prolog_flag(Flag, _), _, _, _, Ctx) :- '$lgt_check'(var_or_atom, Flag), nonvar(Flag), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(portability, warning), \+ '$lgt_iso_spec_flag'(Flag), '$lgt_source_file_context'(File, Lines), '$lgt_increment_compiling_warnings_counter', ( '$lgt_pp_entity_'(Type, Entity, _) -> '$lgt_print_message'(warning(portability), non_standard_prolog_flag(File, Lines, Type, Entity, Flag)) ; '$lgt_print_message'(warning(portability), non_standard_prolog_flag(File, Lines, Flag)) ), fail. '$lgt_compile_body'(set_prolog_flag(Flag, Value), _, _, _, Ctx) :- nonvar(Flag), nonvar(Value), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(portability, warning), '$lgt_iso_spec_flag'(Flag), \+ '$lgt_iso_spec_flag_value'(Flag, Value), '$lgt_source_file_context'(File, Lines), '$lgt_increment_compiling_warnings_counter', ( '$lgt_pp_entity_'(Type, Entity, _) -> '$lgt_print_message'(warning(portability), non_standard_prolog_flag_value(File, Lines, Type, Entity, Flag, Value)) ; '$lgt_print_message'(warning(portability), non_standard_prolog_flag_value(File, Lines, Flag, Value)) ), fail. '$lgt_compile_body'(current_prolog_flag(Flag, _), _, _, _, Ctx) :- '$lgt_check'(var_or_atom, Flag), nonvar(Flag), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(portability, warning), \+ '$lgt_iso_spec_flag'(Flag), '$lgt_source_file_context'(File, Lines), '$lgt_increment_compiling_warnings_counter', ( '$lgt_pp_entity_'(Type, Entity, _) -> '$lgt_print_message'(warning(portability), non_standard_prolog_flag(File, Lines, Type, Entity, Flag)) ; '$lgt_print_message'(warning(portability), non_standard_prolog_flag(File, Lines, Flag)) ), fail. '$lgt_compile_body'(current_prolog_flag(Flag, Value), _, _, _, Ctx) :- nonvar(Flag), nonvar(Value), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(portability, warning), '$lgt_iso_spec_flag'(Flag), \+ '$lgt_iso_spec_flag_value'(Flag, Value), '$lgt_source_file_context'(File, Lines), '$lgt_increment_compiling_warnings_counter', ( '$lgt_pp_entity_'(Type, Entity, _) -> '$lgt_print_message'(warning(portability), non_standard_prolog_flag_value(File, Lines, Type, Entity, Flag, Value)) ; '$lgt_print_message'(warning(portability), non_standard_prolog_flag_value(File, Lines, Flag, Value)) ), fail. % arithmetic predicates (portability and trivial fail checks) '$lgt_compile_body'(Term is Exp, _, _, _, _) :- nonvar(Term), once(( integer(Term), '$lgt_float_expression'(Exp) % integers and floats do not unify (per standard) ; float(Term), '$lgt_integer_expression'(Exp) % integers and floats do not unify (per standard) ; \+ number(Term) % the standard allows any term in the left side )), '$lgt_compiler_flag'(always_true_or_false_goals, warning), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'(warning(always_true_or_false_goals), goal_is_always_false(File, Lines, Type, Entity, Term is Exp)), fail. '$lgt_compile_body'(Term is Exp, _, _, _, _) :- var(Term), Term \== Exp, term_variables(Exp, ExpVariables), once('$lgt_member_var'(Term, ExpVariables)), % this could also be a "goal is always false" warning '$lgt_compiler_flag'(suspicious_calls, warning), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(suspicious_calls), suspicious_call(File, Lines, Type, Entity, Term is Exp, reason(shared_variable(Term))) ), fail. '$lgt_compile_body'(_ is Exp, _, _, _, Ctx) :- '$lgt_comp_ctx_mode'(Ctx, compile(user,_,_)), '$lgt_compiler_flag'(portability, warning), '$lgt_check_non_portable_functions'(Exp, Ctx), fail. '$lgt_compile_body'(Exp1 =:= Exp2, _, _, _, Ctx) :- once(( '$lgt_float_expression'(Exp1) ; '$lgt_float_expression'(Exp2) )), '$lgt_comp_ctx_mode'(Ctx, compile(user,_,_)), '$lgt_compiler_flag'(suspicious_calls, warning), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(arithmetic_expressions), suspicious_call(File, Lines, Type, Entity, Exp1 =:= Exp2, reason(float_comparison)) ), fail. '$lgt_compile_body'(Exp1 =:= Exp2, _, _, _, Ctx) :- '$lgt_comp_ctx_mode'(Ctx, compile(user,_,_)), '$lgt_compiler_flag'(portability, warning), '$lgt_check_non_portable_functions'(Exp1, Ctx), '$lgt_check_non_portable_functions'(Exp2, Ctx), fail. '$lgt_compile_body'(Exp1 =\= Exp2, _, _, _, Ctx) :- once((float(Exp1); float(Exp2))), '$lgt_comp_ctx_mode'(Ctx, compile(user,_,_)), '$lgt_compiler_flag'(suspicious_calls, warning), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(arithmetic_expressions), suspicious_call(File, Lines, Type, Entity, Exp1 =\= Exp2, reason(float_comparison)) ), fail. '$lgt_compile_body'(Exp1 =\= Exp2, _, _, _, Ctx) :- '$lgt_comp_ctx_mode'(Ctx, compile(user,_,_)), '$lgt_compiler_flag'(portability, warning), '$lgt_check_non_portable_functions'(Exp1, Ctx), '$lgt_check_non_portable_functions'(Exp2, Ctx), fail. '$lgt_compile_body'(Exp1 < Exp2, _, _, _, Ctx) :- '$lgt_comp_ctx_mode'(Ctx, compile(user,_,_)), '$lgt_compiler_flag'(portability, warning), '$lgt_check_non_portable_functions'(Exp1, Ctx), '$lgt_check_non_portable_functions'(Exp2, Ctx), fail. '$lgt_compile_body'(Exp1 =< Exp2, _, _, _, Ctx) :- '$lgt_comp_ctx_mode'(Ctx, compile(user,_,_)), '$lgt_compiler_flag'(portability, warning), '$lgt_check_non_portable_functions'(Exp1, Ctx), '$lgt_check_non_portable_functions'(Exp2, Ctx), fail. '$lgt_compile_body'(Exp1 > Exp2, _, _, _, Ctx) :- '$lgt_comp_ctx_mode'(Ctx, compile(user,_,_)), '$lgt_compiler_flag'(portability, warning), '$lgt_check_non_portable_functions'(Exp1, Ctx), '$lgt_check_non_portable_functions'(Exp2, Ctx), fail. '$lgt_compile_body'(Exp1 >= Exp2, _, _, _, Ctx) :- '$lgt_comp_ctx_mode'(Ctx, compile(user,_,_)), '$lgt_compiler_flag'(portability, warning), '$lgt_check_non_portable_functions'(Exp1, Ctx), '$lgt_check_non_portable_functions'(Exp2, Ctx), fail. % blackboard predicates (requires a backend Prolog compiler natively supporting these built-in predicates) '$lgt_compile_body'(bb_put(Key, Term), _, TPred, DPred, Ctx) :- '$lgt_prolog_built_in_predicate'(bb_put(_, _)), \+ '$lgt_pp_defines_predicate_'(bb_put(_, _), _, _, _, _, _), !, '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, Prefix, _, _, ExCtx, _, _, _, _), ( atomic(Key) -> '$lgt_compile_bb_key'(Key, Prefix, TKey), TPred = bb_put(TKey, Term), DPred = '$lgt_debug'(goal(bb_put(Key, Term), TPred), ExCtx) ; var(Key) -> % runtime key translation TPred = ('$lgt_compile_bb_key'(Key, Prefix, TKey, bb_put(Key, Term)), bb_put(TKey, Term)), DPred = '$lgt_debug'(goal(bb_put(Key, Term), TPred), ExCtx) ; throw(type_error(atomic, Key)) ). '$lgt_compile_body'(bb_get(Key, Term), _, TPred, DPred, Ctx) :- '$lgt_prolog_built_in_predicate'(bb_get(_, _)), \+ '$lgt_pp_defines_predicate_'(bb_get(_, _), _, _, _, _, _), !, '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, Prefix, _, _, ExCtx, _, _, _, _), ( atomic(Key) -> '$lgt_compile_bb_key'(Key, Prefix, TKey), TPred = bb_get(TKey, Term), DPred = '$lgt_debug'(goal(bb_get(Key, Term), TPred), ExCtx) ; var(Key) -> % runtime key translation TPred = ('$lgt_compile_bb_key'(Key, Prefix, TKey, bb_get(Key, Term)), bb_get(TKey, Term)), DPred = '$lgt_debug'(goal(bb_get(Key, Term), TPred), ExCtx) ; throw(type_error(atomic, Key)) ). '$lgt_compile_body'(bb_delete(Key, Term), _, TPred, DPred, Ctx) :- '$lgt_prolog_built_in_predicate'(bb_delete(_, _)), \+ '$lgt_pp_defines_predicate_'(bb_delete(_, _), _, _, _, _, _), !, '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, Prefix, _, _, ExCtx, _, _, _, _), ( atomic(Key) -> '$lgt_compile_bb_key'(Key, Prefix, TKey), TPred = bb_delete(TKey, Term), DPred = '$lgt_debug'(goal(bb_delete(Key, Term), TPred), ExCtx) ; var(Key) -> % runtime key translation TPred = ('$lgt_compile_bb_key'(Key, Prefix, TKey, bb_delete(Key, Term)), bb_delete(TKey, Term)), DPred = '$lgt_debug'(goal(bb_delete(Key, Term), TPred), ExCtx) ; throw(type_error(atomic, Key)) ). '$lgt_compile_body'(bb_update(Key, Term, New), _, TPred, DPred, Ctx) :- '$lgt_prolog_built_in_predicate'(bb_update(_, _, _)), \+ '$lgt_pp_defines_predicate_'(bb_update(_, _, _), _, _, _, _, _), !, '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, Prefix, _, _, ExCtx, _, _, _, _), ( atomic(Key) -> '$lgt_compile_bb_key'(Key, Prefix, TKey), TPred = bb_update(TKey, Term, New), DPred = '$lgt_debug'(goal(bb_update(Key, Term, New), TPred), ExCtx) ; var(Key) -> % runtime key translation TPred = ('$lgt_compile_bb_key'(Key, Prefix, TKey, bb_update(Key, Term, New)), bb_update(TKey, Term, New)), DPred = '$lgt_debug'(goal(bb_update(Key, Term, New), TPred), ExCtx) ; throw(type_error(atomic, Key)) ). % call/2-N built-in control construct '$lgt_compile_body'(CallN, Caller, TPred, DPred, Ctx) :- functor(CallN, call, Arity), Arity >= 2, CallN =.. [call, Closure| ExtraArgs], !, ( callable(Closure), \+ '$lgt_logtalk_control_construct'(Closure), Closure \= ':'(_, _), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(suspicious_calls, warning) -> '$lgt_source_file_context'(File, Lines, Type, Entity), Closure =.. [Functor| Args], '$lgt_append'(Args, ExtraArgs, FullArgs), Goal =.. [Functor| FullArgs], '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(suspicious_calls), suspicious_call(File, Lines, Type, Entity, CallN, [Goal]) ) ; true ), '$lgt_check_closure'(Closure, Ctx), '$lgt_compile_body'('$lgt_callN'(Closure, ExtraArgs), Caller, TPred, DPred, Ctx). % call to a meta-predicate from a user-defined meta-predicate; % must check the number of arguments for shared closures % % note that getting the meta-predicate template for non-declared % built-in meta-predicates or for module meta-predicates is fragile % due to lack of standardization of meta-predicate specifications '$lgt_compile_body'(Pred, _, _, _, Ctx) :- '$lgt_comp_ctx'(Ctx, Head, _, _, _, _, _, _, [_| _], _, _, compile(_,_,_), _, _, _), % we're compiling a clause for a meta-predicate as the list of meta-variables is not empty functor(Pred, Name, Arity), \+ functor(Head, Name, Arity), % not a recursive call ( '$lgt_pp_meta_predicate_'(Pred, Meta, _, _) -> % local user-defined meta-predicate true ; '$lgt_prolog_meta_predicate'(Pred, Meta, predicate) -> % proprietary built-in meta-predicate declared in the adapter files true ; '$lgt_predicate_property'(Pred, built_in), catch('$lgt_predicate_property'(Pred, meta_predicate(Meta)), _, fail) -> % non-declared proprietary built-in meta-predicate true ; '$lgt_pp_use_module_predicate_'(Module, Original, Pred, _, _, _), nonvar(Module), catch('$lgt_predicate_property'(':'(Module, Original), meta_predicate(Meta)), _, fail) -> % meta-predicates specified in a use_module/2 directive true ; '$lgt_pp_uses_predicate_'(Obj, Original, Pred, _, _, _), Obj == user, catch('$lgt_predicate_property'(Original, meta_predicate(Meta)), _, fail) -> % Prolog meta-predicate undeclared in the adapter file (may not be a built-in) true ; fail ), Pred =.. [_| PredArgs], Meta =.. [_| MetaArgs], '$lgt_prolog_to_logtalk_meta_argument_specifiers'(MetaArgs, CMetaArgs), nonvar(Head), % ignore multifile predicates Head \= ':'(_, _), Head \= _::_, '$lgt_pp_meta_predicate_'(Head, HeadMeta, _, _), Head =.. [_| HeadArgs], HeadMeta =.. [_| HeadMetaArgs], '$lgt_same_number_of_closure_extra_args'(PredArgs, CMetaArgs, HeadArgs, HeadMetaArgs, HeadMeta, Meta), fail. % predicates specified in use_module/2 directives '$lgt_compile_body'(Alias, Caller, TPred, '$lgt_debug'(goal(Alias, TPred), ExCtx), Ctx) :- '$lgt_pp_use_module_predicate_'(Module, Pred, Alias, Ctx, _, _), ( Pred == Alias -> % no alias is defined true ; % check that we're renaming a predicate but not (also) changing its argument order as that % would break using the closure as a meta-argument when appending the additional arguments Pred =.. [_| PredArguments], Alias =.. [_| AliasArguments], PredArguments == AliasArguments -> true ; % we're renaming a predicate; use instead the generated auxiliary predicate fail ), !, '$lgt_comp_ctx'(Ctx, Head, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), '$lgt_add_referenced_module_predicate'(Mode, Module, Pred, Alias, Head), '$lgt_compile_body'(':'(Module,Pred), Caller, TPred, _, Ctx). % predicates specified in uses/2 directives % % in the case of predicates defined in the pseudo-object "user", the uses/2 % directive is typically used to help document dependencies on Prolog-defined % predicates (usually, but not necessarily, built-in predicates) '$lgt_compile_body'(Alias, Caller, TPred, DPred, Ctx) :- '$lgt_pp_uses_predicate_'(Obj, Pred, Alias, Ctx, _, _), ( Pred == Alias -> % no alias is defined true ; % check that we're renaming a predicate but not (also) changing its argument order as that % would break using the closure as a meta-argument when appending the additional arguments Pred =.. [_| PredArguments], Alias =.. [_| AliasArguments], PredArguments == AliasArguments -> true ; % we're renaming a predicate; use instead the generated auxiliary predicate fail ), !, '$lgt_comp_ctx'(Ctx, Head, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), ( Obj == user -> ( ( '$lgt_prolog_meta_predicate'(Pred, Meta, Type) % built-in Prolog meta-predicate declared in the adapter file in use ; catch('$lgt_predicate_property'(Pred, meta_predicate(Meta)), _, fail) % Prolog meta-predicate undeclared in the adapter file (may not be a built-in) ; '$lgt_pp_meta_predicate_'(user::Pred, user::Meta, _, _) % we're either providing a meta-predicate template or overriding the original % meta-predicate template ) -> % meta-predicate Pred =.. [Functor| Args], Meta =.. [Functor| MArgs], ( '$lgt_prolog_to_logtalk_meta_argument_specifiers'(MArgs, CMArgs), '$lgt_compile_prolog_meta_arguments'(Args, CMArgs, meta, Ctx, TArgs, DArgs) -> TPred =.. [Functor| TArgs], DGoal =.. [Functor| DArgs], ( Type == control_construct -> DPred = DGoal ; DPred = '$lgt_debug'(goal(Alias, DGoal), ExCtx) ) ; % meta-predicate template is not usable throw(domain_error(meta_predicate_template, Meta)) ) ; % non meta-predicate TPred = Pred, DPred = '$lgt_debug'(goal(Alias, Pred), ExCtx), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx) ), '$lgt_add_referenced_object_message'(Mode, Obj, Pred, Alias, Head) ; % objects other than the pseudo-object "user" '$lgt_add_referenced_object_message'(Mode, Obj, Pred, Alias, Head), '$lgt_compile_body'(Obj::Pred, Caller, TPred, _, Ctx), DPred = '$lgt_debug'(goal(Alias, TPred), ExCtx) ). % call to a dynamic predicate from within a category; the predicate % is called instead in the context of the object importing the category % that received the message under processing (implicit dynamic binding) '$lgt_compile_body'(Pred, _, TPred, '$lgt_debug'(goal(Pred, TPred), ExCtx), Ctx) :- '$lgt_pp_category_'(_, _, _, _, _, _), '$lgt_pp_dynamic_'(Pred, _, _, _), !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), ( functor(Pred, Functor, Arity), \+ '$lgt_pp_public_'(Functor, Arity, _, _), \+ '$lgt_pp_protected_'(Functor, Arity, _, _), \+ '$lgt_pp_private_'(Functor, Arity, _, _) -> % no scope directive TPred = '$lgt_call_in_this'(Pred, ExCtx) ; TPred = '$lgt_call_in_this_checked'(Pred, ExCtx) ). % non-callable terms '$lgt_compile_body'(Pred, _, _, _, _) :- \+ callable(Pred), throw(type_error(callable, Pred)). % runtime compilation of a call (usually a meta-call) to a user-defined predicate % % required to deal with meta-calls instantiated at runtime '$lgt_compile_body'(Pred, _, TPred, '$lgt_debug'(goal(Pred, TPred), ExCtx), Ctx) :- '$lgt_comp_ctx'(Ctx, _, _, Entity, Sender, This, Self, _, MetaVars, MetaCallCtx, ExCtx, runtime, Stack, _, _), nonvar(Entity), % in the most common case, we're meta-calling the predicate '$lgt_execution_context'(ExCtx, Entity, Sender, This, Self, MetaCallCtx, Stack), ( '$lgt_member_var'(Pred, MetaVars) -> % goal is a call to a user-defined predicate in sender (i.e., a meta-argument) TPred = '$lgt_metacall_sender'(Pred, ExCtx, MetaCallCtx, []) ; % goal is a local call to a user-defined predicate '$lgt_current_object_'(Entity, _, _, Def, _, _, _, _, DDef, _, _) -> ( call(Def, Pred, ExCtx, TPred) ; call(DDef, Pred, ExCtx, TPred) ) ; '$lgt_current_category_'(Entity, _, _, Def, _, _), call(Def, Pred, ExCtx, TPred) ), !. % call to a local user-defined predicate '$lgt_compile_body'(Pred, Caller, _, _, Ctx) :- '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, _, _, _, _, compile(user,_,_), _, Lines, Term), Caller \== phrase, Term \= (_ --> _), functor(Pred, Functor, ExtArity), '$lgt_pp_defines_non_terminal_'(Functor, Arity, ExtArity), \+ '$lgt_pp_calls_non_terminal_'(Functor, Arity, ExtArity, Lines), '$lgt_compiler_flag'(grammar_rules, warning), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(grammar_rules), calls_non_terminal_as_predicate(File, Lines, Type, Entity, Functor//Arity) ), fail. '$lgt_compile_body'(Pred, _, TPred, DPred, Ctx) :- '$lgt_comp_ctx'(Ctx, _, _, Entity, _, _, _, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, _, Entity), Entity == user, % usually a call from an initialization or conditional compilation directive !, TPred = Pred, DPred = '$lgt_debug'(goal(Pred, TPred), ExCtx). '$lgt_compile_body'(Pred, _, TPred, '$lgt_debug'(goal(DPred, TPred), ExCtx), Ctx) :- '$lgt_pp_coinductive_'(Pred, _, ExCtx, TCPred, _, _, DCPred, _, _), !, '$lgt_comp_ctx'(Ctx, Head, _, _, _, _, _, Prefix, _, _, ExCtx, Mode, _, Lines, _), ( '$lgt_pp_defines_predicate_'(Pred, Functor/Arity, _, TPred0, _, _) -> '$lgt_check_for_trivial_fails'(Mode, Pred, TPred0, Head), % convert the call to the original coinductive predicate into a call to the auxiliary % predicate whose compiled normal and debug forms are already computed functor(TCPred, TCFunctor, TCArity), '$lgt_remember_called_predicate'(Mode, Functor/Arity, TCFunctor/TCArity, Head), TPred = TCPred, DPred = DCPred ; % undefined coinductive predicate functor(Pred, Functor, Arity), '$lgt_compile_predicate_indicator'(Prefix, Functor/Arity, TFunctor/TArity), '$lgt_remember_called_predicate'(Mode, Functor/Arity, TFunctor/TArity, Head), % closed-world assumption: calls to static, declared but undefined % predicates must fail instead of throwing an exception, '$lgt_report_undefined_predicate_call'(Mode, Functor/Arity, Lines), TPred = fail, DPred = Pred ). '$lgt_compile_body'(Pred, _, TPred, '$lgt_debug'(goal(Pred, TPred), ExCtx), Ctx) :- '$lgt_pp_synchronized_'(Pred, Mutex, _, _), '$lgt_comp_ctx'(Ctx, Head, _, _, _, _, _, Prefix, _, _, ExCtx, Mode, _, Lines, _), functor(Pred, Functor, Arity), \+ (nonvar(Head), functor(Head, Functor, Arity)), % not a recursive call !, ( '$lgt_pp_defines_predicate_'(Pred, _, ExCtx, TPred0, _, _) -> '$lgt_check_for_trivial_fails'(Mode, Pred, TPred0, Head), ( '$lgt_prolog_feature'(threads, supported) -> TPred = with_mutex(Mutex, TPred0) ; % in single-threaded systems, with_mutex/2 is equivalent to once/1 TPred = once(TPred0) ), functor(TPred0, TFunctor, TArity) ; % undefined synchronized predicate '$lgt_compile_predicate_indicator'(Prefix, Functor/Arity, TFunctor/TArity), % closed-world assumption: calls to static, declared but undefined % predicates must fail instead of throwing an exception, '$lgt_report_undefined_predicate_call'(Mode, Functor/Arity, Lines), TPred = fail ), '$lgt_remember_called_predicate'(Mode, Functor/Arity, TFunctor/TArity, Head). '$lgt_compile_body'(Pred, Caller, TPred, '$lgt_debug'(goal(Pred, TPred), ExCtx), Ctx) :- '$lgt_pp_defines_predicate_'(Pred, Functor/Arity, ExCtx, TPred0, _, _), !, '$lgt_comp_ctx'(Ctx, Head, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), '$lgt_check_for_trivial_fails'(Mode, Pred, TPred0, Head), functor(TPred0, TFunctor, TArity), ( ( '$lgt_pp_meta_predicate_'(Head, _, _, _) -> HeadIsMeta = true ; HeadIsMeta = false ), '$lgt_pp_meta_predicate_'(Pred, Meta, _, _), % local user-defined meta-predicate Pred =.. [Functor| Args], Meta =.. [Functor| MArgs], '$lgt_wrap_local_meta_arguments'(MArgs, Args, HeadIsMeta, Caller, Ctx, TArgs0) -> '$lgt_append'(TArgs0, [ExCtx], TArgs), TPred =.. [TFunctor| TArgs] ; % non meta-predicate or runtime compilation of meta-arguments TPred = TPred0 ), '$lgt_remember_called_predicate'(Mode, Functor/Arity, TFunctor/TArity, Head). % call to a foreign predicate but only when compiling a module as an object; % this is fragile due to the lack of standards for Prolog foreign language interfaces; % moreover, not all backend Prolog systems support a "foreign" predicate property '$lgt_compile_body'(Pred, _, Pred, '$lgt_debug'(goal(Pred, Pred), ExCtx), Ctx) :- '$lgt_pp_module_'(_), % not all backend Prolog systems support a "foreign" predicate property catch('$lgt_predicate_property'(Pred, foreign), _, fail), \+ '$lgt_prolog_built_in_predicate'(Pred), !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx). % implicit call to a module predicate with a missing use_module/2 directive % but only when compiling a module as an object; in practice, this is only % usable from backend systems with an autoload mechanism '$lgt_compile_body'(Pred, _, ':'(Module,Pred), '$lgt_debug'(goal(Pred, ':'(Module,Pred)), ExCtx), Ctx) :- '$lgt_pp_module_'(Current), \+ '$lgt_prolog_built_in_predicate'(Pred), '$lgt_find_visible_module_predicate'(Current, Module, Pred), !, functor(Pred, Functor, Arity), '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), '$lgt_remember_missing_use_module_directive'(Mode, Module, Functor/Arity). % call to a declared but undefined predicate '$lgt_compile_body'(Pred, _, TPred, '$lgt_debug'(goal(Pred, TPred), ExCtx), Ctx) :- ( '$lgt_pp_dynamic_'(Pred, _, _, _) ; '$lgt_pp_multifile_'(Pred, _, _, _) ), !, '$lgt_comp_ctx'(Ctx, Head, _, _, _, _, _, Prefix, _, _, ExCtx, Mode, _, _, _), functor(Pred, Functor, Arity), '$lgt_compile_predicate_indicator'(Prefix, Functor/Arity, TFunctor/TArity), functor(TPred, TFunctor, TArity), '$lgt_unify_head_thead_arguments'(Pred, TPred, ExCtx), '$lgt_remember_called_predicate'(Mode, Functor/Arity, TFunctor/TArity, Head). '$lgt_compile_body'(Pred, _, fail, '$lgt_debug'(goal(Pred, fail), ExCtx), Ctx) :- % take into account the common practice of defining % Prolog modules that export built-in predicates ( '$lgt_pp_module_'(_) -> % compiling a module as an object \+ '$lgt_built_in_predicate'(Pred) ; true ), functor(Pred, Functor, Arity), ( '$lgt_pp_public_'(Functor, Arity, _, _) ; '$lgt_pp_protected_'(Functor, Arity, _, _) ; '$lgt_pp_private_'(Functor, Arity, _, _) ; '$lgt_pp_synchronized_'(Pred, _, _, _) ; '$lgt_pp_coinductive_head_'(Pred, _, _) ; '$lgt_pp_discontiguous_'(Pred, _, _) ), !, % closed-world assumption: calls to static, non-multifile, declared % but undefined predicates must fail instead of throwing an exception '$lgt_comp_ctx'(Ctx, Head, _, _, _, _, _, Prefix, _, _, ExCtx, Mode, _, Lines, _), '$lgt_compile_predicate_indicator'(Prefix, Functor/Arity, TFunctor/TArity), '$lgt_remember_called_predicate'(Mode, Functor/Arity, TFunctor/TArity, Head), '$lgt_report_undefined_predicate_call'(Mode, Functor/Arity, Lines). % call to a deprecated Prolog built-in predicate '$lgt_compile_body'(Pred, Caller, TPred, DPred, Ctx) :- ( '$lgt_prolog_deprecated_built_in_predicate_hook'(Pred, RPred) -> true ; '$lgt_prolog_deprecated_built_in_predicate'(Pred, RPred) ), '$lgt_prolog_built_in_predicate'(Pred), \+ '$lgt_pp_defines_predicate_'(Pred, _, _, _, _, _), !, % replace it with a call to the standard alternative '$lgt_compile_body'(RPred, Caller, TPred, DPred, Ctx), ( '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(deprecated, warning), '$lgt_source_file_context'(File, Lines), '$lgt_pp_entity_'(Type, Entity, _) -> functor(Pred, Functor, Arity), functor(RPred, RFunctor, RArity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(deprecated), deprecated_predicate(File, Lines, Type, Entity, Functor/Arity, RFunctor/RArity) ) ; true ). '$lgt_compile_body'(Pred, _, _, _, Ctx) :- ( '$lgt_prolog_deprecated_built_in_predicate_hook'(Pred) -> true ; '$lgt_prolog_deprecated_built_in_predicate'(Pred) ), '$lgt_prolog_built_in_predicate'(Pred), \+ '$lgt_pp_defines_predicate_'(Pred, _, _, _, _, _), % no standard alternative; just print a warning '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(deprecated, warning), '$lgt_source_file_context'(File, Lines), '$lgt_pp_entity_'(Type, Entity, _), functor(Pred, Functor, Arity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(deprecated), deprecated_predicate(File, Lines, Type, Entity, Functor/Arity) ), fail. % call to a Prolog built-in predicate '$lgt_compile_body'(Pred, _, _, _, Ctx) :- '$lgt_prolog_built_in_predicate'(Pred), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), logtalk_linter_hook(Pred, Flag, File, Lines, Type, Entity, Warning), nonvar(Flag), '$lgt_valid_flag'(Flag), '$lgt_compiler_flag'(Flag, warning), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'(warning(Flag), Warning), fail. '$lgt_compile_body'(Pred, _, TPred, DPred, Ctx) :- '$lgt_prolog_built_in_predicate'(Pred), !, ( ( '$lgt_pp_meta_predicate_'(Pred, Meta, _, _), Type = predicate % we're either overriding the original meta-predicate template or working around a % backend Prolog compiler limitation in providing access to meta-predicate templates ; '$lgt_prolog_meta_predicate'(Pred, Meta, Type) % built-in Prolog meta-predicate declared in the adapter file in use ; % lack of standardization of the predicate_property/2 predicate % means that the next call may fail to recognize the predicate as % a meta-predicate and retrieve a usable meta-predicate template catch('$lgt_predicate_property'(Pred, meta_predicate(Meta)), _, fail), Type = predicate ) -> % meta-predicate Pred =.. [Functor| Args], Meta =.. [Functor| MArgs], ( '$lgt_prolog_to_logtalk_meta_argument_specifiers'(MArgs, CMArgs), ( '$lgt_prolog_phrase_predicate'(Pred) -> NewCaller = phrase ; NewCaller = meta ), '$lgt_compile_prolog_meta_arguments'(Args, CMArgs, NewCaller, Ctx, TArgs, DArgs) -> TGoal =.. [Functor| TArgs], DGoal =.. [Functor| DArgs], '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), TPred = TGoal, ( Type == control_construct -> DPred = DGoal ; DPred = '$lgt_debug'(goal(Pred, DGoal), ExCtx) ), '$lgt_check_non_portable_prolog_built_in_call'(Mode, Pred) ; % meta-predicate template is not usable throw(domain_error(meta_predicate_template, Meta)) ) ; % non meta-predicate TPred = Pred, DPred = '$lgt_debug'(goal(Pred, Pred), ExCtx), '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), '$lgt_check_non_portable_prolog_built_in_call'(Mode, Pred), '$lgt_check_for_tautology_or_falsehood_goal'(Mode, Pred) ). % call to a Logtalk built-in predicate (that is not already handled) '$lgt_compile_body'(Pred, _, Pred, '$lgt_debug'(goal(Pred, Pred), ExCtx), Ctx) :- '$lgt_logtalk_built_in_predicate'(Pred, _), !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx). % call to a unknown predicate '$lgt_compile_body'(Pred, _, TPred, '$lgt_debug'(goal(Pred, TPred), ExCtx), Ctx) :- '$lgt_comp_ctx'(Ctx, Head, _, _, _, _, _, Prefix, _, _, ExCtx, Mode, _, Lines, _), functor(Pred, Functor, Arity), '$lgt_compile_predicate_indicator'(Prefix, Functor/Arity, TFunctor/TArity), functor(TPred, TFunctor, TArity), '$lgt_unify_head_thead_arguments'(Pred, TPred, ExCtx), '$lgt_remember_called_predicate'(Mode, Functor/Arity, TFunctor/TArity, Head), '$lgt_report_unknown_predicate_call'(Mode, Functor/Arity, Lines), !. % unexpected compilation failure '$lgt_compile_body'(Pred, _, _, _, _) :- throw(domain_error(goal, Pred)). % wrap meta-arguments when a meta-predicate calls another local meta-predicate % with meta-arguments that are not meta-arguments of the caller % % when the caller is not a meta-predicate, no wrapping is required as the % meta-call context is empty % % also optimize bound meta-arguments, which are calls to local predicates, % when not compiling in debug mode '$lgt_wrap_local_meta_arguments'([], [], _, _, _, []). '$lgt_wrap_local_meta_arguments'([MArg| MArgs], [Arg| Args], HeadIsMeta, Caller, Ctx, [WArg| WArgs]) :- ( var(Arg) -> WArg = Arg ; '$lgt_wrap_local_meta_argument'(MArg, Arg, HeadIsMeta, Caller, Ctx, WArg) ), '$lgt_wrap_local_meta_arguments'(MArgs, Args, HeadIsMeta, Caller, Ctx, WArgs). '$lgt_wrap_local_meta_argument'((*), Arg, _, _, _, Arg) :- !. '$lgt_wrap_local_meta_argument'((::), Arg, _, _, _, Arg) :- !. '$lgt_wrap_local_meta_argument'(MArg, Arg, HeadIsMeta, Caller, Ctx, WArg) :- ( '$lgt_compiler_flag'(debug, off), '$lgt_compile_static_binding_meta_argument'(MArg, Arg, Caller, Ctx, WArg) -> true ; HeadIsMeta == true -> WArg = '$lgt_local'(Arg) ; WArg = Arg ). % bagof/3 and setof/3 existential quantifiers '$lgt_compile_quantified_body'(Term^Pred, Caller, Term^TPred, Term^DPred, Ctx) :- !, ( var(Pred) -> % meta-call resolved at runtime '$lgt_compile_body'(Pred, Caller, TPred, DPred, Ctx) ; % we can have Term1^Term2^...^Pred '$lgt_compile_quantified_body'(Pred, Caller, TPred, DPred, Ctx) ). '$lgt_compile_quantified_body'(Pred, Caller, TPred, DPred, Ctx) :- '$lgt_compile_body'(Pred, Caller, TPred, DPred, Ctx). % compute list of existentially qualified variables not occurring in the qualified goal '$lgt_missing_existential_variables'(QGoal, Variables, Goal) :- '$lgt_decompose_quantified_body'(QGoal, Terms, Goal), term_variables(Terms, ExistentialVariables), term_variables(Goal, GoalVariables), '$lgt_filter_missing_existential_variables'(ExistentialVariables, GoalVariables, Variables). '$lgt_decompose_quantified_body'(Term^Pred, [Term| Terms], Goal) :- !, ( var(Pred) -> !, fail ; '$lgt_decompose_quantified_body'(Pred, Terms, Goal) ). '$lgt_decompose_quantified_body'(Goal, [], Goal). '$lgt_filter_missing_existential_variables'([], _, []). '$lgt_filter_missing_existential_variables'([Variable| ExistentialVariables], GoalVariables, Variables) :- '$lgt_member_var'(Variable, GoalVariables), !, '$lgt_filter_missing_existential_variables'(ExistentialVariables, GoalVariables, Variables). '$lgt_filter_missing_existential_variables'([Variable| ExistentialVariables], GoalVariables, [Variable| Variables]) :- '$lgt_filter_missing_existential_variables'(ExistentialVariables, GoalVariables, Variables). % auxiliary predicate to find a singleton variable in the goal argument of % bagof/3 and setof/3 calls '$lgt_singleton_variables_in_meta_argument'(Goal, Singletons, Ctx) :- Goal \= _/_, % not a lambda expression term_variables(Goal, Variables), '$lgt_comp_ctx_term'(Ctx, Term), bagof( Singleton, '$lgt_singleton_variable_in_meta_argument'(Variables, Term, Singleton), Singletons ). '$lgt_singleton_variable_in_meta_argument'([Variable| _], Term, Variable) :- '$lgt_count_variable_occurrences'(Term, Variable, 1). '$lgt_singleton_variable_in_meta_argument'([_| Variables], Term, Variable) :- '$lgt_singleton_variable_in_meta_argument'(Variables, Term, Variable). % '$lgt_fix_disjunction_left_side'(@var_or_callable, -callable) % % check if the compilation of the disjunction left-side produced an if-then or % a soft-cut (e.g., due to goal-expansion) and fix it if necessary to avoid % converting the disjunction into an if-then-else or a soft-cut with an else part '$lgt_fix_disjunction_left_side'(Goal0, Goal) :- ( var(Goal0) -> Goal = Goal0 ; Goal0 = (_ -> _) -> Goal = (Goal0, true) ; Goal0 = '*->'(_, _), '$lgt_predicate_property'('*->'(_, _), built_in) -> Goal = (Goal0, true) ; Goal = Goal0 ). % '$lgt_negated_goal_alternative'(Pred, Alt) % % auxiliary table for \+ Goal linter warnings '$lgt_negated_goal_alternative'(call(Goal), \+ Goal). '$lgt_negated_goal_alternative'(once(Goal), \+ Goal). '$lgt_negated_goal_alternative'(Term1 = Term2, Term1 \= Term2). '$lgt_negated_goal_alternative'(Term1 == Term2, Term1 \== Term2). '$lgt_negated_goal_alternative'(Term1 =:= Term2, Term1 =\= Term2). '$lgt_negated_goal_alternative'(var(Term), nonvar(Term)). % '$lgt_module_qualified_clause'(@nonvar, -atom, -clause, -term, -term) % % decomposes a an explicitly module qualified clause '$lgt_module_qualified_clause'(QClause, Module, Clause, Head, Body) :- ( QClause = (QHead :- Body), nonvar(QHead), QHead = ':'(Module,Head) -> Clause = (Head :- Body) ; QClause = ':'(Module,Head), Clause = Head, Body = true ). % '$lgt_compile_error_method'(+compilation_context, -compound) % % compiles a call to one of the built-in error methods; % these methods are shorthands to context/1 + throw/1 '$lgt_compile_error_method'(Exception, TPred, DPred, Ctx) :- '$lgt_comp_ctx_head'(Ctx, Head0), ( Head0 = _::Head -> % object (or category) multifile predicate clause true ; Head0 = ':'(_,Head) -> % module multifile predicate clause true ; % non-multifile predicate Head0 = Head ), '$lgt_comp_ctx_head_exec_ctx'(Ctx, ExCtx), TPred = throw(error(Exception, logtalk(Head, ExCtx))), DPred = '$lgt_debug'(goal(Exception, TPred), ExCtx). % '$lgt_check_read_term_options'(@compilation_mode, @predicate_indicator, @term) % % check read term options portability '$lgt_check_read_term_options'(runtime, _, _). '$lgt_check_read_term_options'(compile(_,_,_), Predicate, Options) :- ( '$lgt_is_list'(Options), '$lgt_compiler_flag'(portability, warning), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_member'(Option, Options), nonvar(Option), \+ '$lgt_iso_spec_read_term_option'(Option) -> '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(portability), non_standard_predicate_option(File, Lines, Type, Entity, Predicate, Option) ) ; true ). % '$lgt_check_write_term_options'(@compilation_mode, @predicate_indicator, @term) % % check write term options portability '$lgt_check_write_term_options'(runtime, _, _). '$lgt_check_write_term_options'(compile(_,_,_), Predicate, Options) :- ( '$lgt_is_list'(Options), '$lgt_compiler_flag'(portability, warning), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_member'(Option, Options), nonvar(Option), \+ '$lgt_iso_spec_write_term_option'(Option) -> '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(portability), non_standard_predicate_option(File, Lines, Type, Entity, Predicate, Option) ) ; true ). % '$lgt_check_open_stream_options'(@compilation_mode, @predicate_indicator, @term) % % check open stream options portability '$lgt_check_open_stream_options'(runtime, _, _). '$lgt_check_open_stream_options'(compile(_,_,_), Predicate, Options) :- '$lgt_is_list'(Options), '$lgt_compiler_flag'(portability, warning), '$lgt_source_file_context'(File, Lines, Type, Entity), ( '$lgt_member'(Option, Options), nonvar(Option), \+ '$lgt_iso_spec_open_stream_option'(Option) -> '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(portability), non_standard_predicate_option(File, Lines, Type, Entity, Predicate, Option) ) ; true ). % '$lgt_check_for_meta_predicate_directive'(@compilation_mode, @callable, @term) % % remember missing meta_predicate/1 directives '$lgt_check_for_meta_predicate_directive'(runtime, _, _). '$lgt_check_for_meta_predicate_directive'(compile(aux,_,_), _, _) :- !. '$lgt_check_for_meta_predicate_directive'(compile(user,_,_), _::_, _) :- % clause for multifile object predicate !. '$lgt_check_for_meta_predicate_directive'(compile(user,_,_), ':'(_, _), _) :- % clause for multifile module predicate !. '$lgt_check_for_meta_predicate_directive'(compile(user,_,_), Head, MetaArg) :- '$lgt_term_template'(Head, Template), ( '$lgt_pp_meta_predicate_'(Template, _, _, _) -> % meta_predicate/1 directive is present true ; '$lgt_pp_missing_meta_predicate_directive_'(Template, _, _) -> % missing meta_predicate/1 directive already recorded true ; term_variables(MetaArg, MetaArgVars), term_variables(Head, HeadVars), '$lgt_member'(MetaArgVar, MetaArgVars), '$lgt_member_var'(MetaArgVar, HeadVars) -> % the meta-argument is a head argument '$lgt_source_file_context'(File, Lines), % delay reporting to the end of entity compilation to avoid repeated reports for % the same missing directive when a meta-predicate have two or more clauses assertz('$lgt_pp_missing_meta_predicate_directive_'(Template, File, Lines)) ; true ). % '$lgt_check_non_portable_prolog_built_in_call'(@compilation_mode, @callable) % % remember non-portable Prolog built-in predicate calls '$lgt_check_non_portable_prolog_built_in_call'(runtime, _). '$lgt_check_non_portable_prolog_built_in_call'(compile(aux,_,_), _) :- !. '$lgt_check_non_portable_prolog_built_in_call'(compile(user,_,_), Pred) :- ( \+ '$lgt_pp_non_portable_predicate_'(Pred, _, _), % not already recorded as a non portable call \+ '$lgt_iso_spec_predicate'(Pred) -> % bona fide non-portable Prolog built-in predicate '$lgt_term_template'(Pred, Template), '$lgt_source_file_context'(File, Lines), assertz('$lgt_pp_non_portable_predicate_'(Template, File, Lines)) ; true ). % '$lgt_check_for_tautology_or_falsehood_goal'(@compilation_mode, @callable) % % check for likely typos in ground calls to some Prolog built-in predicates % that result in either tautologies or falsehoods '$lgt_check_for_tautology_or_falsehood_goal'(runtime, _). '$lgt_check_for_tautology_or_falsehood_goal'(compile(aux,_,_), _) :- !. '$lgt_check_for_tautology_or_falsehood_goal'(compile(user,_,_), Goal) :- ( ground(Goal), % exclude already handled linter check for (\=)/2 goals \+ functor(Goal, (\=), 2), '$lgt_compiler_flag'(always_true_or_false_goals, warning), ( '$lgt_candidate_tautology_or_falsehood_goal'(Goal) ; '$lgt_candidate_tautology_or_falsehood_goal_hook'(Goal) ) -> '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', ( catch(Goal, Error, true) -> ( var(Error) -> '$lgt_print_message'( warning(always_true_or_false_goals), goal_is_always_true(File, Lines, Type, Entity, Goal) ) ; '$lgt_print_message'( warning(always_true_or_false_goals), goal_is_always_error(File, Lines, Type, Entity, Goal, Error) ) ) ; '$lgt_print_message'( warning(always_true_or_false_goals), goal_is_always_false(File, Lines, Type, Entity, Goal) ) ) ; true ). % '$lgt_check_for_trivial_fails'(@compilation_mode, @callable, @callable, @callable) % % check for trivial fails due to no matching local clause being available for a goal; % this check is only performed for local static predicates as dynamic or multifile % predicates can get new clauses at runtime '$lgt_check_for_trivial_fails'(runtime, _, _, _). '$lgt_check_for_trivial_fails'(compile(aux,_,_), _, _, _) :- !. '$lgt_check_for_trivial_fails'(compile(user,_,_), Goal, TGoal, Head) :- ( '$lgt_compiler_flag'(trivial_goal_fails, warning), % workaround possible creation of a cyclic term with some backend % Prolog compilers implementation of the \=2 predicate copy_term(Head, HeadCopy), Goal \= HeadCopy, % not a recursive call which can originate from a predicate with a single clause \+ '$lgt_pp_dynamic_'(Goal, _, _, _), \+ '$lgt_pp_multifile_'(Goal, _, _, _), % not a dynamic or multifile predicate \+ '$lgt_pp_entity_term_'(fact(TGoal, _), _, _), \+ '$lgt_pp_entity_term_'(srule(TGoal, _, _), _, _), \+ '$lgt_pp_entity_term_'(dfact(TGoal, _, _), _, _), \+ '$lgt_pp_entity_term_'(dsrule(TGoal, _, _, _), _, _), % not a yet to be compiled user-defined fact or rule \+ '$lgt_pp_final_entity_term_'(TGoal, _), \+ '$lgt_pp_final_entity_term_'((TGoal :- _), _), % not an already compiled user-defined fact or rule \+ '$lgt_pp_entity_aux_clause_'(fact(TGoal, _)), \+ '$lgt_pp_entity_aux_clause_'(srule(TGoal, _, _)), \+ '$lgt_pp_entity_aux_clause_'(dfact(TGoal, _, _)), \+ '$lgt_pp_entity_aux_clause_'(dsrule(TGoal, _, _, _)), % not a yet to be compiled auxiliary fact or rule \+ '$lgt_pp_final_entity_aux_clause_'(TGoal), \+ '$lgt_pp_final_entity_aux_clause_'((TGoal :- _)) -> % not an already compiled auxiliary fact or rule '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', ( functor(Goal, Functor, Arity), '$lgt_pp_calls_non_terminal_'(Functor, _, Arity, _) -> Goal =.. [Functor| GoalArgs], '$lgt_append'(NonTerminalArgs, [_, _], GoalArgs), !, NonTerminal =.. [Functor| NonTerminalArgs], Message = no_matching_clause_for_non_terminal_goal(File, Lines, Type, Entity, NonTerminal) ; Message = no_matching_clause_for_predicate_goal(File, Lines, Type, Entity, Goal) ), '$lgt_print_message'(warning(trivial_goal_fails), Message) ; true ). % '$lgt_candidate_tautology_or_falsehood_goal'(@callable) % % valid candidates are standard built-in predicates with % no side-effects when called with ground arguments % unification '$lgt_candidate_tautology_or_falsehood_goal'(_ = _). '$lgt_candidate_tautology_or_falsehood_goal'(unify_with_occurs_check(_, _)). '$lgt_candidate_tautology_or_falsehood_goal'(_ \= _). % term comparison '$lgt_candidate_tautology_or_falsehood_goal'(_ == _). '$lgt_candidate_tautology_or_falsehood_goal'(_ \== _). '$lgt_candidate_tautology_or_falsehood_goal'(_ @< _). '$lgt_candidate_tautology_or_falsehood_goal'(_ @=< _). '$lgt_candidate_tautology_or_falsehood_goal'(_ @> _). '$lgt_candidate_tautology_or_falsehood_goal'(_ @>= _). % arithmetic comparison '$lgt_candidate_tautology_or_falsehood_goal'(_ < _). '$lgt_candidate_tautology_or_falsehood_goal'(_ =< _). '$lgt_candidate_tautology_or_falsehood_goal'(_ > _). '$lgt_candidate_tautology_or_falsehood_goal'(_ >= _). '$lgt_candidate_tautology_or_falsehood_goal'(_ =:= _). '$lgt_candidate_tautology_or_falsehood_goal'(_ =\= _). '$lgt_candidate_tautology_or_falsehood_goal'(compare(_, _, _)). % type testing '$lgt_candidate_tautology_or_falsehood_goal'(acyclic_term(_)). '$lgt_candidate_tautology_or_falsehood_goal'(atom(_)). '$lgt_candidate_tautology_or_falsehood_goal'(atomic(_)). '$lgt_candidate_tautology_or_falsehood_goal'(callable(_)). '$lgt_candidate_tautology_or_falsehood_goal'(compound(_)). '$lgt_candidate_tautology_or_falsehood_goal'(float(_)). '$lgt_candidate_tautology_or_falsehood_goal'(ground(_)). '$lgt_candidate_tautology_or_falsehood_goal'(integer(_)). '$lgt_candidate_tautology_or_falsehood_goal'(nonvar(_)). '$lgt_candidate_tautology_or_falsehood_goal'(number(_)). '$lgt_candidate_tautology_or_falsehood_goal'(var(_)). % term creation and decomposition '$lgt_candidate_tautology_or_falsehood_goal'(_ =.. _). '$lgt_candidate_tautology_or_falsehood_goal'(arg(_, _, _)). '$lgt_candidate_tautology_or_falsehood_goal'(copy_term(_, _)). '$lgt_candidate_tautology_or_falsehood_goal'(functor(_, _, _)). '$lgt_candidate_tautology_or_falsehood_goal'(subsumes_term(_, _)). % atomic term processing '$lgt_candidate_tautology_or_falsehood_goal'(atom_length(_, _)). '$lgt_candidate_tautology_or_falsehood_goal'(atom_concat(_, _, _)). '$lgt_candidate_tautology_or_falsehood_goal'(sub_atom(_, _, _, _, _)). '$lgt_candidate_tautology_or_falsehood_goal'(atom_chars(_, _)). '$lgt_candidate_tautology_or_falsehood_goal'(atom_codes(_, _)). '$lgt_candidate_tautology_or_falsehood_goal'(char_code(_, _)). '$lgt_candidate_tautology_or_falsehood_goal'(number_chars(_, _)). '$lgt_candidate_tautology_or_falsehood_goal'(number_codes(_, _)). % '$lgt_remember_called_predicate'(@compilation_mode, +predicate_indicator, +predicate_indicator, @callable) % % used for checking calls to undefined predicates and for collecting cross-referencing information '$lgt_remember_called_predicate'(runtime, _, _, _). '$lgt_remember_called_predicate'(compile(_,_,_), Functor/Arity, TFunctor/TArity, Head) :- % currently, the returned line numbers are for the start and end lines of the clause containing the call ( Head = Object::Predicate -> % call from the body of a Logtalk multifile predicate clause Caller = Object::HeadFunctor/HeadArity ; Head = ':'(Module,Predicate) -> % call from the body of a Prolog module multifile predicate clause Caller = ':'(Module,HeadFunctor/HeadArity) ; % call from the body of a local entity clause Head = Predicate, Caller = HeadFunctor/HeadArity ), functor(Predicate, HeadFunctor, HeadArity), ( '$lgt_source_file_context'(File, Lines) -> true ; '$lgt_pp_file_paths_flags_'(_, _, File, _, _), Lines = '-'(0, 0) ), ( Caller == Functor/Arity -> % recursive call ( retract('$lgt_pp_predicate_recursive_calls_'(Functor, Arity, Count0)) -> Count is Count0 + 1, assertz('$lgt_pp_predicate_recursive_calls_'(Functor, Arity, Count)) ; assertz('$lgt_pp_predicate_recursive_calls_'(Functor, Arity, 1)) ) ; '$lgt_pp_calls_predicate_'(Functor/Arity, _, Caller, File, Lines) -> % already recorded for the current clause being compiled true ; assertz('$lgt_pp_calls_predicate_'(Functor/Arity, TFunctor/TArity, Caller, File, Lines)) ). % '$lgt_remember_called_self_predicate'(@compilation_mode, +predicate_indicator, @callable) % % used for checking calls to undefined predicates and for collecting cross-referencing information '$lgt_remember_called_self_predicate'(runtime, _, _). '$lgt_remember_called_self_predicate'(compile(aux,_,_), _, _) :- !. '$lgt_remember_called_self_predicate'(compile(user,_,_), Functor/Arity, Head) :- % currently, the returned line numbers are for the start and end lines of the clause containing the call ( Head = Object::Predicate -> % call from the body of a Logtalk multifile predicate clause Caller = Object::HeadFunctor/HeadArity ; Head = ':'(Module,Predicate) -> % call from the body of a Prolog module multifile predicate clause Caller = ':'(Module,HeadFunctor/HeadArity) ; % call from the body of a local entity clause Head = Predicate, Caller = HeadFunctor/HeadArity ), functor(Predicate, HeadFunctor, HeadArity), '$lgt_source_file_context'(File, Lines), ( '$lgt_pp_calls_self_predicate_'(Functor/Arity, Caller, File, Lines) -> % already recorded for the current clause being compiled (however unlikely!) true ; assertz('$lgt_pp_calls_self_predicate_'(Functor/Arity, Caller, File, Lines)) ). % '$lgt_remember_called_super_predicate'(@compilation_mode, +predicate_indicator, @callable) % % used for checking calls to undefined predicates and for collecting cross-referencing information '$lgt_remember_called_super_predicate'(runtime, _, _). '$lgt_remember_called_super_predicate'(compile(aux,_,_), _, _) :- !. '$lgt_remember_called_super_predicate'(compile(user,_,_), Functor/Arity, Head) :- % currently, the returned line numbers are for the start and end lines of the clause containing the call ( Head = Object::Predicate -> % call from the body of a Logtalk multifile predicate clause Caller = Object::HeadFunctor/HeadArity ; Head = ':'(Module,Predicate) -> % call from the body of a Prolog module multifile predicate clause Caller = ':'(Module,HeadFunctor/HeadArity) ; % call from the body of a local entity clause Head = Predicate, Caller = HeadFunctor/HeadArity ), functor(Predicate, HeadFunctor, HeadArity), '$lgt_source_file_context'(File, Lines), ( '$lgt_pp_calls_super_predicate_'(Functor/Arity, Caller, File, Lines) -> % already recorded for the current clause being compiled (however unlikely!) true ; assertz('$lgt_pp_calls_super_predicate_'(Functor/Arity, Caller, File, Lines)) ). % '$lgt_remember_missing_use_module_directive'(@compilation_mode, +atom, +predicate_indicator) % % used only for reporting implicit calls to module predicates with missing use_module/2 % directives when compiling modules as objects '$lgt_remember_missing_use_module_directive'(runtime, _, _). '$lgt_remember_missing_use_module_directive'(compile(aux,_,_), _, _) :- !. '$lgt_remember_missing_use_module_directive'(compile(user,_,_), Module, Functor/Arity) :- ( '$lgt_pp_missing_use_module_directive_'(Module, Functor/Arity) -> % already recorded true ; assertz('$lgt_pp_missing_use_module_directive_'(Module, Functor/Arity)) ). % '$lgt_remember_updated_predicate'(@compilation_mode, @term, @callable) % % used for collecting cross-referencing information '$lgt_remember_updated_predicate'(runtime, _, _). '$lgt_remember_updated_predicate'(compile(aux,_,_), _, _) :- !. '$lgt_remember_updated_predicate'(compile(user,_,_), Dynamic, Head) :- % currently, the returned line numbers are for the start and end lines of the clause containing the call ( Head = Object::Predicate -> % update from the body of a Logtalk multifile predicate clause Updater = Object::HeadFunctor/HeadArity ; Head = ':'(Module,Predicate) -> % update from the body of a Prolog module multifile predicate clause Updater = ':'(Module,HeadFunctor/HeadArity) ; % update from the body of a local entity clause Head = Predicate, Updater = HeadFunctor/HeadArity ), functor(Predicate, HeadFunctor, HeadArity), '$lgt_source_file_context'(File, Lines), ( '$lgt_pp_updates_predicate_'(Dynamic, Updater, File, Lines) -> % already recorded for the current clause being compiled (however unlikely!) true ; assertz('$lgt_pp_updates_predicate_'(Dynamic, Updater, File, Lines)) ). % '$lgt_bagof'(?term, ?term, ?term, +execution_context, +atom) % % handles bagof/3 calls with goals only known at runtime '$lgt_bagof'(Term, QGoal, List, ExCtx, Where) :- '$lgt_convert_quantified_goal'(QGoal, Goal, '$lgt_quantified_metacall'(Goal, ExCtx, Where), TQGoal), bagof(Term, TQGoal, List). % '$lgt_setof'(?term, ?term, ?term, +execution_context) % % handles setof/3 calls with goals only known at runtime '$lgt_setof'(Term, QGoal, List, ExCtx, Where) :- '$lgt_convert_quantified_goal'(QGoal, Goal, '$lgt_quantified_metacall'(Goal, ExCtx, Where), TQGoal), setof(Term, TQGoal, List). % '$lgt_convert_quantified_goal'(@callable, -callable, +callable, -callable) % % converts a ^/2 goal at runtime (used with bagof/3 and setof/3 calls) % % returns both the original goal without existential variables and the compiled % goal that will be used as the argument for the bagof/3 and setof/3 calls '$lgt_convert_quantified_goal'(Goal, Goal, TGoal, TGoal) :- var(Goal), !. '$lgt_convert_quantified_goal'(Var^Term, Goal, TGoal, Var^TTerm) :- !, '$lgt_convert_quantified_goal'(Term, Goal, TGoal, TTerm). '$lgt_convert_quantified_goal'(Goal, Goal, TGoal, TGoal). % '$lgt_generate_aux_predicate_functor'(+atom, -atom) % % generates a new functor for an auxiliary predicate % based on a base atom and an entity global counter '$lgt_generate_aux_predicate_functor'(Base, Functor) :- ( retract('$lgt_pp_aux_predicate_counter_'(Old)) -> New is Old + 1 ; New is 1 ), asserta('$lgt_pp_aux_predicate_counter_'(New)), number_codes(New, NewCodes), atom_codes(NewAtom, NewCodes), atom_concat(Base, NewAtom, Functor). % '$lgt_compile_bb_key'(@term, +atom, -atom) % % compile-time translation of a blackboard key '$lgt_compile_bb_key'(Key, Prefix, TKey) :- ( atom(Key) -> atom_concat(Prefix, Key, TKey) ; integer(Key) -> number_codes(Key, KeyCodes), atom_codes(AtomKey, KeyCodes), atom_concat(Prefix, AtomKey, TKey) ; throw(type_error(atomic, Key)) ). % '$lgt_compile_bb_key'(@term, +atom, -atom, @callable) % % runtime translation of a blackboard key '$lgt_compile_bb_key'(Key, Prefix, TKey, Goal) :- ( var(Key) -> throw(error(instantiation_error, Goal)) ; atomic(Key) -> '$lgt_compile_bb_key'(Key, Prefix, TKey) ; throw(error(type_error(atomic, Key), Goal)) ). % '$lgt_threaded'(+callable, +execution_context, +atom) % % handling of threaded/1 calls when the argument is only bound at runtime '$lgt_threaded'(Goals, ExCtx, Where) :- ( var(Goals) -> throw(error(instantiation_error, threaded(Goals))) ; \+ callable(Goals) -> throw(error(type_error(callable, Goals), threaded(Goals))) ; '$lgt_runtime_threaded_call'(Goals, MTGoals, ExCtx, Where), call(MTGoals) ). % '$lgt_runtime_threaded_call'(+callable, -callable, +execution_context, +atom) % % runtime compilation of the argument of a call to the built-in predicate threaded/1 '$lgt_runtime_threaded_call'((Goal; Goals), '$lgt_threaded_or'(Queue, MTGoals, Results), ExCtx, Where) :- !, '$lgt_runtime_threaded_or_call'((Goal; Goals), Queue, MTGoals, Results, ExCtx, Where). '$lgt_runtime_threaded_call'((Goal, Goals), '$lgt_threaded_and'(Queue, MTGoals, Results), ExCtx, Where) :- !, '$lgt_runtime_threaded_and_call'((Goal, Goals), Queue, MTGoals, Results, ExCtx, Where). '$lgt_runtime_threaded_call'(Goal, ('$lgt_metacall'(Goal, ExCtx, Where) -> true; fail), ExCtx, Where). '$lgt_runtime_threaded_or_call'((Goal; Goals), Queue, (MTGoal, MTGoals), [Result| Results], ExCtx, Where) :- !, '$lgt_runtime_threaded_goal'(Goal, Queue, MTGoal, Result, ExCtx, Where), '$lgt_runtime_threaded_or_call'(Goals, Queue, MTGoals, Results, ExCtx, Where). '$lgt_runtime_threaded_or_call'(Goal, Queue, MTGoal, [Result], ExCtx, Where) :- '$lgt_runtime_threaded_goal'(Goal, Queue, MTGoal, Result, ExCtx, Where). '$lgt_runtime_threaded_and_call'((Goal, Goals), Queue, (MTGoal, MTGoals), [Result| Results], ExCtx, Where) :- !, '$lgt_runtime_threaded_goal'(Goal, Queue, MTGoal, Result, ExCtx, Where), '$lgt_runtime_threaded_and_call'(Goals, Queue, MTGoals, Results, ExCtx, Where). '$lgt_runtime_threaded_and_call'(Goal, Queue, MTGoal, [Result], ExCtx, Where) :- '$lgt_runtime_threaded_goal'(Goal, Queue, MTGoal, Result, ExCtx, Where). '$lgt_runtime_threaded_goal'(Goal, Queue, '$lgt_threaded_goal'('$lgt_metacall'(Goal, ExCtx, Where), TVars, Queue, Id), id(Id, TVars, _), ExCtx, Where). % '$lgt_compile_threaded_call'(+callable, -callable) % % compiles the argument of a call to the built-in predicate threaded/1 '$lgt_compile_threaded_call'((TGoal; TGoals), '$lgt_threaded_or'(Queue, MTGoals, Results)) :- !, '$lgt_compile_threaded_or_call'((TGoal; TGoals), Queue, MTGoals, Results). '$lgt_compile_threaded_call'((TGoal, TGoals), '$lgt_threaded_and'(Queue, MTGoals, Results)) :- !, '$lgt_compile_threaded_and_call'((TGoal, TGoals), Queue, MTGoals, Results). '$lgt_compile_threaded_call'(TGoal, (TGoal -> true; fail)). '$lgt_compile_threaded_or_call'((TGoal; TGoals), Queue, (MTGoal, MTGoals), [Result| Results]) :- !, '$lgt_compile_threaded_goal'(TGoal, Queue, MTGoal, Result), '$lgt_compile_threaded_or_call'(TGoals, Queue, MTGoals, Results). '$lgt_compile_threaded_or_call'(TGoal, Queue, MTGoal, [Result]) :- '$lgt_compile_threaded_goal'(TGoal, Queue, MTGoal, Result). '$lgt_compile_threaded_and_call'((TGoal, TGoals), Queue, (MTGoal, MTGoals), [Result| Results]) :- !, '$lgt_compile_threaded_goal'(TGoal, Queue, MTGoal, Result), '$lgt_compile_threaded_and_call'(TGoals, Queue, MTGoals, Results). '$lgt_compile_threaded_and_call'(TGoal, Queue, MTGoal, [Result]) :- '$lgt_compile_threaded_goal'(TGoal, Queue, MTGoal, Result). '$lgt_compile_threaded_goal'(TGoal, Queue, '$lgt_threaded_goal'(TGoal, TVars, Queue, Id), id(Id, TVars, _)). % '$lgt_compile_prolog_meta_arguments'(@list, @list, +callable, +compilation_context, -list, -list) % % compiles the meta-arguments contained in the list of arguments of a call to a Prolog % meta-predicate or meta-directive (assumes Logtalk meta-predicate notation) % % this predicate fails when meta-arguments other than goal and closures are not % sufficiently instantiated or a meta-argument mode indicator is not supported '$lgt_compile_prolog_meta_arguments'([], [], _, _, [], []). '$lgt_compile_prolog_meta_arguments'([Arg| Args], [MArg| MArgs], Caller, Ctx, [TArg| TArgs], [DArg| DArgs]) :- ( nonvar(Arg), '$lgt_module_meta_argument'(MArg, Arg), '$lgt_prolog_feature'(modules, supported) -> % explicitly-qualified meta-argument TArg = Arg, DArg = Arg ; integer(MArg), MArg > 0 -> % closure meta-argument '$lgt_compile_prolog_meta_argument'(closure(MArg), Arg, Caller, Ctx, TArg, DArg) ; % remaining cases '$lgt_compile_prolog_meta_argument'(MArg, Arg, Caller, Ctx, TArg, DArg) ), '$lgt_compile_prolog_meta_arguments'(Args, MArgs, Caller, Ctx, TArgs, DArgs). '$lgt_module_meta_argument'(0, ':'(_,_)). '$lgt_module_meta_argument'(1, ':'(_)). '$lgt_compile_prolog_meta_argument'(closure(N), Arg, Caller, Ctx, TArg, DArg) :- % closure '$lgt_check'(var_or_callable, Arg), '$lgt_length'(ExtArgs, 0, N), ( var(Arg) -> ExtArg =.. [call, Arg| ExtArgs] ; '$lgt_extend_closure'(Arg, ExtArgs, ExtArg, Ctx) -> true ; throw(domain_error(closure, Arg)) ), '$lgt_compile_body'(ExtArg, Caller, TArg0, DArg0, Ctx), % generate an auxiliary predicate to allow the meta-predicate to extend % the closure without clashing with the execution-context argument '$lgt_generate_aux_predicate_functor'('_closure_', HelperFunctor), '$lgt_pp_entity_'(_, _, Prefix), atom_concat(Prefix, HelperFunctor, THelperFunctor), '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), THelper =.. [THelperFunctor, Arg, ExCtx], TExtHelper =.. [THelperFunctor, Arg, ExCtx| ExtArgs], ( '$lgt_compiler_flag'(debug, on) -> assertz('$lgt_pp_entity_aux_clause_'({(TExtHelper :- DArg0)})) ; assertz('$lgt_pp_entity_aux_clause_'({(TExtHelper :- TArg0)})) ), ( '$lgt_pp_object_'(Entity, _, _, Def, _, _, _, _, _, _, _) -> true ; '$lgt_pp_category_'(Entity, _, _, Def, _, _) ), % add a def clause to ensure that we don't loose track of the auxiliary clause Arity is N + 2, '$lgt_length'(TemplateArgs, 0, Arity), ExtHelperTemplate =.. [HelperFunctor| TemplateArgs], TExtHelperTemplate =.. [THelperFunctor| TemplateArgs], Clause =.. [Def, ExtHelperTemplate, _, TExtHelperTemplate], assertz('$lgt_pp_def_'(Clause)), % add, if applicable, source data information for the auxiliary clause ( '$lgt_compiler_flag'(source_data, on) -> assertz('$lgt_pp_runtime_clause_'('$lgt_predicate_property_'(Entity, HelperFunctor/Arity, flags_clauses_rules_location(1,1,1,0-0)))) ; true ), ( '$lgt_prolog_feature'(modules, supported) -> % make sure the calls are made in the correct context '$lgt_user_module_qualification'(THelper, TArg), '$lgt_user_module_qualification'(THelper, DArg) ; TArg = THelper, DArg = THelper ). % normal (non-meta) argument '$lgt_compile_prolog_meta_argument'((*), Arg, _, _, Arg, Arg). % goal '$lgt_compile_prolog_meta_argument'((0), Arg, Caller, Ctx, TArg, DArg) :- '$lgt_compile_body'(Arg, Caller, TArg0, DArg0, Ctx), ( TArg0 = ':'(_, _) -> % the compiled call is already explicitly-qualified TArg = TArg0, DArg = DArg0 ; '$lgt_prolog_feature'(modules, supported) -> % make sure the calls are made in the correct context '$lgt_user_module_qualification'(TArg0, TArg), '$lgt_user_module_qualification'(DArg0, DArg) ; TArg = TArg0, DArg = DArg0 ). % existentially-quantified goal '$lgt_compile_prolog_meta_argument'((^), Arg, Caller, Ctx, TArg, DArg) :- ( Arg = Vars^Arg0 -> '$lgt_compile_body'(Arg0, Caller, TArg0, DArg0, Ctx), TArg = Vars^TArg0, DArg = Vars^DArg0 ; '$lgt_compile_body'(Arg, Caller, TArg, DArg, Ctx) ). % list of goals '$lgt_compile_prolog_meta_argument'([0], [], _, _, [], []) :- !. '$lgt_compile_prolog_meta_argument'([0], [Arg| Args], Caller, Ctx, [TArg| TArgs], [DArg| DArgs]) :- !, '$lgt_compile_prolog_meta_argument'((0), Arg, Caller, Ctx, TArg, DArg), '$lgt_compile_prolog_meta_argument'([0], Args, Caller, Ctx, TArgs, DArgs). % predicate indicator '$lgt_compile_prolog_meta_argument'((/), [Arg| Args], Caller, Ctx, [TArg| TArgs], [DArg| DArgs]) :- !, nonvar(Arg), '$lgt_compile_prolog_meta_argument'((/), Arg, Caller, Ctx, TArg, DArg), '$lgt_compile_prolog_meta_argument'([/], Args, Caller, Ctx, TArgs, DArgs). '$lgt_compile_prolog_meta_argument'((/), (Arg, Args), Caller, Ctx, (TArg, TArgs), (DArg, DArgs)) :- !, nonvar(Arg), '$lgt_compile_prolog_meta_argument'((/), Arg, Caller, Ctx, TArg, DArg), '$lgt_compile_prolog_meta_argument'((/), Args, Caller, Ctx, TArgs, DArgs). '$lgt_compile_prolog_meta_argument'((/), Arg, _, _, TArg, TArg) :- '$lgt_compile_predicate_indicators'(Arg, _, TArg0), ( '$lgt_prolog_feature'(modules, supported) -> % make sure the predicate indicator refers to the correct context '$lgt_user_module_qualification'(TArg0, TArg) ; TArg = TArg0 ). % non-terminal indicator '$lgt_compile_prolog_meta_argument'((//), Args, Caller, Ctx, TArgs, DArgs) :- '$lgt_compile_prolog_meta_argument'((/), Args, Caller, Ctx, TArgs, DArgs). % list of predicate indicators '$lgt_compile_prolog_meta_argument'([/], [], _, _, [], []) :- !. '$lgt_compile_prolog_meta_argument'([/], [Arg| Args], Caller, Ctx, [TArg| TArgs], [DArg| DArgs]) :- !, nonvar(Arg), '$lgt_compile_prolog_meta_argument'((/), Arg, Caller, Ctx, TArg, DArg), '$lgt_compile_prolog_meta_argument'([/], Args, Caller, Ctx, TArgs, DArgs). % list of non-terminal indicators '$lgt_compile_prolog_meta_argument'([//], Args, Caller, Ctx, TArgs, DArgs) :- '$lgt_compile_prolog_meta_argument'([/], Args, Caller, Ctx, TArgs, DArgs). % '$lgt_extend_closure'(@callable, @list(term), -callable, +compilation_context) % % extends a closure by appending a list of arguments to construct a goal % % this predicate fails if the closure can only be extended at runtime '$lgt_extend_closure'(Closure, _, _, _) :- var(Closure), !, fail. '$lgt_extend_closure'(Obj::Closure, ExtArgs, Goal, Ctx) :- Obj == user, !, '$lgt_extend_closure'({Closure}, ExtArgs, Goal, Ctx). '$lgt_extend_closure'(Obj::Closure, ExtArgs, Obj::Msg, _) :- !, '$lgt_extend_closure_basic'(Closure, ExtArgs, Msg). '$lgt_extend_closure'([Obj::Closure], ExtArgs, [Obj::Msg], _) :- !, '$lgt_extend_closure_basic'(Closure, ExtArgs, Msg). '$lgt_extend_closure'(::Closure, ExtArgs, ::Msg, _) :- !, '$lgt_extend_closure_basic'(Closure, ExtArgs, Msg). '$lgt_extend_closure'(^^Closure, ExtArgs, ^^Msg, _) :- !, '$lgt_extend_closure_basic'(Closure, ExtArgs, Msg). '$lgt_extend_closure'(Obj<>Lambda, ExtArgs, Goal, _) :- !, Goal =.. [call, Parameters>>Lambda| ExtArgs]. '$lgt_extend_closure'(':'(Module,Closure), ExtArgs, ':'(Module,Goal), _) :- !, '$lgt_extend_closure_basic'(Closure, ExtArgs, Goal). '$lgt_extend_closure'(Closure, ExtArgs, Goal, Ctx) :- '$lgt_extend_closure_basic'(Closure, ExtArgs, Alias), ( '$lgt_pp_uses_predicate_'(Object, Original, Alias, Ctx, _, _), ( Original == Alias -> % no alias is defined true ; % check that we're renaming a predicate but not (also) changing its argument order as that % would break using the closure as a meta-argument when appending the additional arguments Original =.. [_| OriginalArguments], Alias =.. [_| AliasArguments], OriginalArguments == AliasArguments ) -> Goal = Object::Original ; '$lgt_pp_use_module_predicate_'(Module, Original, Alias, Ctx, _, _), ( Original == Alias -> % no alias is defined true ; % check that we're renaming a predicate but not (also) changing its argument order as that % would break using the closure as a meta-argument when appending the additional arguments Original =.. [_| OriginalArguments], Alias =.. [_| AliasArguments], OriginalArguments == AliasArguments ) -> Goal = ':'(Module, Original) ; Goal = Alias ). '$lgt_extend_closure_basic'(Closure, ExtArgs, Goal) :- callable(Closure), % compile-time closure extension possible Closure =.. [Functor| Args], '$lgt_append'(Args, ExtArgs, FullArgs), Goal =.. [Functor| FullArgs]. % '$lgt_not_same_meta_arg_extra_args'(@list(nonvar), @list(var), @var, +integer) % % checks that the number of additional 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; assumes Logtalk meta-predicate notation) '$lgt_not_same_meta_arg_extra_args'([(*)| MetaArgs], MetaVars, Closure, ExtraArgs) :- !, '$lgt_not_same_meta_arg_extra_args'(MetaArgs, MetaVars, Closure, ExtraArgs). '$lgt_not_same_meta_arg_extra_args'([(::)| MetaArgs], MetaVars, Closure, ExtraArgs) :- !, '$lgt_not_same_meta_arg_extra_args'(MetaArgs, MetaVars, Closure, ExtraArgs). '$lgt_not_same_meta_arg_extra_args'([0| MetaArgs], MetaVars, Closure, ExtraArgs) :- !, '$lgt_not_same_meta_arg_extra_args'(MetaArgs, MetaVars, Closure, ExtraArgs). '$lgt_not_same_meta_arg_extra_args'([MetaArg| _], [MetaVar| _], Closure, ExtraArgs) :- MetaVar == Closure, !, integer(MetaArg), MetaArg =\= ExtraArgs. '$lgt_not_same_meta_arg_extra_args'([_| MetaArgs], [_| MetaVars], Closure, ExtraArgs) :- '$lgt_not_same_meta_arg_extra_args'(MetaArgs, MetaVars, Closure, ExtraArgs). % '$lgt_same_number_of_closure_extra_args'(@list, @list, @list, @list, @callable, @callable) % % checks that the number of additional arguments being appended to a closure is kept % when passing a closure from the clause head to a meta-predicate call in the body '$lgt_same_number_of_closure_extra_args'([], _, _, _, _, _). '$lgt_same_number_of_closure_extra_args'([PredArg| PredArgs], [PredMetaArg| PredMetaArgs], HeadArgs, HeadMetaArgs, HeadMeta, PredMeta) :- ( var(PredArg), integer(PredMetaArg), PredMetaArg > 0, % argument is a closure '$lgt_shared_closure_arg'(PredArg, HeadArgs, HeadMetaArgs, HeadMetaArg) -> % shared closure argument ( PredMetaArg = HeadMetaArg -> % same number of closure extra args '$lgt_same_number_of_closure_extra_args'(PredArgs, PredMetaArgs, HeadArgs, HeadMetaArgs, HeadMeta, PredMeta) ; throw(consistency_error(same_closure_specification, HeadMeta, PredMeta)) ) ; '$lgt_same_number_of_closure_extra_args'(PredArgs, PredMetaArgs, HeadArgs, HeadMetaArgs, HeadMeta, PredMeta) ). '$lgt_shared_closure_arg'(PredArg, [HeadArg| _], [HeadMetaArg| _], HeadMetaArg) :- PredArg == HeadArg. '$lgt_shared_closure_arg'(PredArg, [_| HeadArgs], [_| HeadMetaArgs], HeadMetaArg) :- '$lgt_shared_closure_arg'(PredArg, HeadArgs, HeadMetaArgs, HeadMetaArg). % '$lgt_check_dynamic_directive'(@compilation_mode, @term) % % checks for a dynamic/1 directive for a predicate that is an argument to the % database built-in methods; the predicate may be non-instantiated or only % partially instantiated but must be valid '$lgt_check_dynamic_directive'(runtime, _). '$lgt_check_dynamic_directive'(compile(_,_,_), Term) :- '$lgt_check_dynamic_directive'(Term). '$lgt_check_dynamic_directive'(Term) :- var(Term), % runtime binding argument !. '$lgt_check_dynamic_directive'((Head :- _)) :- !, '$lgt_check_dynamic_directive'(Head). '$lgt_check_dynamic_directive'(Functor/Arity) :- !, ( ground(Functor/Arity) -> functor(Head, Functor, Arity), '$lgt_check_dynamic_directive'(Head) ; true ). '$lgt_check_dynamic_directive'(Head) :- ( '$lgt_pp_dynamic_'(Head, _, _, _) -> % dynamic/1 directive is present true ; '$lgt_pp_missing_dynamic_directive_'(Head, _, _) -> % missing dynamic/1 directive already recorded true ; '$lgt_pp_entity_'(category, _, _), % database predicates act only on objects functor(Head, Functor, Arity), \+ '$lgt_pp_public_'(Functor, Arity, _, _), \+ '$lgt_pp_protected_'(Functor, Arity, _, _), \+ '$lgt_pp_private_'(Functor, Arity, _, _) -> % no scope directive true ; '$lgt_term_template'(Head, Template), '$lgt_source_file_context'(File, Lines), % delay reporting to the end of entity compilation to avoid repeated reports for % the same missing directive when a dynamic predicate have two or more clauses assertz('$lgt_pp_missing_dynamic_directive_'(Template, File, Lines)) ). % '$lgt_check_discontiguous_directive'(@callable, @compilation_context) % % checks for a discontiguous/1 directive for a predicate '$lgt_check_discontiguous_directive'(Head, Ctx) :- '$lgt_term_template'(Head, Template), retractall('$lgt_pp_previous_predicate_'(_, user)), assertz('$lgt_pp_previous_predicate_'(Template, user)), ( '$lgt_pp_discontiguous_'(Template, _, _) -> % discontiguous directive present true ; '$lgt_pp_missing_discontiguous_directive_'(Template, _, _) -> % missing discontiguous/1 directive already recorded true ; '$lgt_comp_ctx_mode'(Ctx, compile(user,_,_)) -> % compiling a source file clause; record missing discontiguous directive '$lgt_source_file_context'(File, Lines), % delay reporting to the end of entity compilation to avoid repeated reports for the same % missing directive when there multiple discontiguous blocks for the same predicate assertz('$lgt_pp_missing_discontiguous_directive_'(Template, File, Lines)) ; % runtime compilation or compiling an auxiliary predicate clause true ). % '$lgt_optimizable_local_db_call'(@term, -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, TPred) :- nonvar(Pred), % only for objects '$lgt_pp_entity_'(object, _, Prefix), % only for facts ( Pred = (Head :- Body) -> Body == true ; Head = Pred ), callable(Head), % a dynamic directive must be present '$lgt_pp_dynamic_'(Head, _, _, _), % a scope directive must be present functor(Head, Functor, Arity), ( '$lgt_pp_public_'(Functor, Arity, _, _) ; '$lgt_pp_protected_'(Functor, Arity, _, _) ; '$lgt_pp_private_'(Functor, Arity, _, _) ), !, % not compiled in debug mode '$lgt_compiler_flag'(debug, off), % compile the fact '$lgt_compile_predicate_indicator'(Prefix, Functor/Arity, TFunctor/TArity), functor(TPred, TFunctor, TArity), '$lgt_unify_head_thead_arguments'(Head, TPred, _). % '$lgt_db_call_database_execution_context'(@term, @term, -term, +execution_context) % % returns the database where a database method call should take place and sets the % execution context accordingly % % this auxiliary predicate ensures that, when calling database methods in the body % of a multifile predicate clause defined in an object, the object database will be % used instead of the database of the entity holding the multifile predicate primary % declaration (which could be a category, making the calls invalid) '$lgt_db_call_database_execution_context'(Entity, This, Database, ExCtx) :- ( '$lgt_pp_entity_'(object, _, _) -> Database = Entity, '$lgt_execution_context_this_entity'(ExCtx, _, Entity) ; % category Database = This, '$lgt_execution_context_this_entity'(ExCtx, This, _) ). % '$lgt_runtime_checked_db_clause'(@term) % % true if the argument forces runtime validity check '$lgt_runtime_checked_db_clause'(Pred) :- var(Pred), !. '$lgt_runtime_checked_db_clause'((Head :- Body)) :- var(Head), !, '$lgt_check'(var_or_callable, Body). '$lgt_runtime_checked_db_clause'((Head :- Body)) :- var(Body), '$lgt_check'(var_or_callable, Head). % '$lgt_check_non_portable_functions'(@term, @compilation_context) % % checks an arithmetic expression for calls to non-standard Prolog functions '$lgt_check_non_portable_functions'(Exp, _) :- number(Exp), !. '$lgt_check_non_portable_functions'(Exp, _) :- var(Exp), !. '$lgt_check_non_portable_functions'(Exp, Ctx) :- '$lgt_prolog_deprecated_built_in_function'(Exp, Alt), % standard alternative once('$lgt_predicate_property'(evaluable_property(_, _), _)), evaluable_property(Exp, built_in), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(deprecated, warning), '$lgt_source_file_context'(File, Lines), '$lgt_pp_entity_'(Type, Entity, _), functor(Exp, Functor, Arity), functor(Alt, AltFunctor, AltArity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(deprecated), deprecated_function(File, Lines, Type, Entity, Functor/Arity, AltFunctor/AltArity) ), fail. '$lgt_check_non_portable_functions'(Exp, Ctx) :- '$lgt_prolog_deprecated_built_in_function'(Exp), % no standard alternative once('$lgt_predicate_property'(evaluable_property(_, _), _)), evaluable_property(Exp, built_in), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(deprecated, warning), '$lgt_source_file_context'(File, Lines), '$lgt_pp_entity_'(Type, Entity, _), functor(Exp, Functor, Arity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(deprecated), deprecated_function(File, Lines, Type, Entity, Functor/Arity) ), fail. '$lgt_check_non_portable_functions'(Exp, Ctx) :- ( '$lgt_pp_missing_function_'(Exp, _, _) -> % missing function already recorded true ; '$lgt_predicate_property'(evaluable_property(_, _), _), \+ evaluable_property(Exp, _) -> % first occurrence of this missing function; record it '$lgt_term_template'(Exp, Template), '$lgt_source_file_context'(File, Lines), assertz('$lgt_pp_missing_function_'(Template, File, Lines)) ; % no reliable way of checking if the function is missing true ), ( '$lgt_iso_spec_function'(Exp) -> % portable call (we assume...!) true ; '$lgt_pp_non_portable_function_'(Exp, _, _) -> % non-portable function already recorded true ; % first occurrence of this non-portable function; record it '$lgt_term_template'(Exp, Template), '$lgt_source_file_context'(File, Lines), assertz('$lgt_pp_non_portable_function_'(Template, File, Lines)) ), ( Exp = [_|_] -> % avoid duplicated warnings with the Prolog legacy use of a list % with a single character to represent the code of the character true ; Exp =.. [_| Exps], '$lgt_check_non_portable_function_args'(Exps, Ctx) ). '$lgt_check_non_portable_function_args'([], _). '$lgt_check_non_portable_function_args'([Exp| Exps], Ctx) :- '$lgt_check_non_portable_functions'(Exp, Ctx), '$lgt_check_non_portable_function_args'(Exps, Ctx). % '$lgt_compile_message_to_object'(@term, @object_identifier, -callable, +atom, +compilation_context) % % compiles a message-sending call % messages to the pseudo-object "user" '$lgt_compile_message_to_object'(Pred, Obj, _, _, Ctx) :- Obj == user, '$lgt_check'(var_or_callable, Pred), callable(Pred), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(suspicious_calls, warning), '$lgt_iso_spec_predicate'(Pred), \+ '$lgt_built_in_method'(Pred, _, _, _), \+ '$lgt_pp_defines_predicate_'(Pred, _, _, _, _, _), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(suspicious_calls), suspicious_call(File, Lines, Type, Entity, user::Pred, [Pred]) ), fail. '$lgt_compile_message_to_object'(Pred, Obj, TPred, _, Ctx) :- Obj == user, callable(Pred), !, ( \+ '$lgt_prolog_built_in_database_predicate'(Pred), % the meta-predicate templates for the backend Prolog database predicates are % usually not usable from Logtalk due the ambiguity of the ":" meta-argument % qualifier but they pose no problems when operating in "user"; in this % particular case, the call can be compiled as-is ( '$lgt_prolog_meta_predicate'(Pred, Meta, _) % built-in Prolog meta-predicate declared in the adapter file in use ; catch('$lgt_predicate_property'(Pred, meta_predicate(Meta)), _, fail) % Prolog meta-predicate undeclared in the adapter file (may not be a built-in) ; '$lgt_pp_meta_predicate_'(user::Pred, user::Meta, _, _) % we're either providing a meta-predicate template or overriding the original % meta-predicate template ) -> % meta-predicate Pred =.. [Functor| Args], Meta =.. [Functor| MArgs], ( '$lgt_prolog_to_logtalk_meta_argument_specifiers'(MArgs, CMArgs), '$lgt_compile_prolog_meta_arguments'(Args, CMArgs, meta, Ctx, TArgs, _) -> TPred =.. [Functor| TArgs] ; % meta-predicate template is not usable throw(domain_error(meta_predicate_template, Meta)) ) ; % non meta-predicate TPred = Pred ), '$lgt_comp_ctx'(Ctx, Head, _, _, _, _, _, _, _, _, _, Mode, _, _, _), ( '$lgt_prolog_built_in_database_predicate'(Pred) -> % update to a dynamic predicate in "user" declared in a uses/2 directive true ; '$lgt_add_referenced_object_message'(Mode, Obj, Pred, Pred, Head) ). % suppress debug messages when compiling in optimized mode '$lgt_compile_message_to_object'(Pred, Obj, true, _, _) :- Obj == logtalk, Pred = print_message(Kind, _, _), callable(Kind), functor(Kind, debug, _), '$lgt_compiler_flag'(optimize, on), !. % convenient access to parametric object proxies '$lgt_compile_message_to_object'(Pred, Obj, (CallProxy, TPred), Events, Ctx) :- nonvar(Obj), Obj = {Proxy}, !, ( var(Proxy) -> CallProxy = call(Proxy) ; callable(Proxy) -> CallProxy = Proxy ; throw(type_error(callable, Proxy)) ), '$lgt_comp_ctx'(Ctx, _, _, _, _, This, _, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, This, _), '$lgt_compile_message_to_object'(Pred, Proxy, TPred, Events, Ctx). % type and lint checks '$lgt_compile_message_to_object'(_, Obj, _, _, Ctx) :- ( callable(Obj) -> % remember the object receiving the message '$lgt_add_referenced_object'(Obj, Ctx), fail ; nonvar(Obj), % invalid object identifier throw(type_error(object_identifier, Obj)) ). % suspicious use of ::/2 instead of ::/1 to send a message to "self" '$lgt_compile_message_to_object'(Pred, Obj, _, _, Ctx) :- '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, _, _, _, ExCtx, compile(_,_,_), _, _, _), '$lgt_compiler_flag'(suspicious_calls, warning), '$lgt_execution_context'(ExCtx, _, _, _, Self, _, _), Self == Obj, '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(suspicious_calls), suspicious_call(File, Lines, Type, Entity, Obj::Pred, [::Pred]) ), fail. % suspicious use of ::/2 in objects to call a local predicate '$lgt_compile_message_to_object'(Pred, Obj, _, _, Ctx) :- '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, _, _, _, ExCtx, compile(_,_,_), _, _, _), '$lgt_pp_entity_'(object, _, _), '$lgt_compiler_flag'(suspicious_calls, warning), '$lgt_execution_context'(ExCtx, _, _, This, _, _, _), This == Obj, % message sent from an object to itself nonvar(Pred), '$lgt_pp_defines_predicate_'(Pred, _, _, _, _, _), % local predicate '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(suspicious_calls), suspicious_call(File, Lines, Type, Entity, Obj::Pred, [Pred]) ), fail. % translation performed at runtime '$lgt_compile_message_to_object'(Pred, Obj, '$lgt_send_to_obj_rt'(Obj, Pred, Events, NewCtx), Events, Ctx) :- var(Pred), !, '$lgt_comp_ctx'(Ctx, Head, _, Entity, Sender, This, Self, Prefix, MetaVars, MetaCallCtx, ExCtx, _, Stack, Lines, _), '$lgt_comp_ctx'(NewCtx, Head, _, Entity, Sender, This, Self, Prefix, MetaVars, MetaCallCtx, ExCtx, runtime, Stack, Lines, _). % broadcasting control constructs '$lgt_compile_message_to_object'((Pred1, Pred2), Obj, (TPred1, TPred2), Events, Ctx) :- !, '$lgt_compile_message_to_object'(Pred1, Obj, TPred1, Events, Ctx), '$lgt_compile_message_to_object'(Pred2, Obj, TPred2, Events, Ctx). '$lgt_compile_message_to_object'((Pred1; Pred2), Obj, (TPred1; TPred2), Events, Ctx) :- !, '$lgt_compile_message_to_object'(Pred1, Obj, TPred1, Events, Ctx), '$lgt_compile_message_to_object'(Pred2, Obj, TPred2, Events, Ctx). '$lgt_compile_message_to_object'((Pred1 -> Pred2), Obj, (TPred1 -> TPred2), Events, Ctx) :- !, '$lgt_compile_message_to_object'(Pred1, Obj, TPred1, Events, Ctx), '$lgt_compile_message_to_object'(Pred2, Obj, TPred2, Events, Ctx). '$lgt_compile_message_to_object'('*->'(Pred1, Pred2), Obj, '*->'(TPred1, TPred2), Events, Ctx) :- '$lgt_predicate_property'('*->'(_, _), built_in), !, '$lgt_compile_message_to_object'(Pred1, Obj, TPred1, Events, Ctx), '$lgt_compile_message_to_object'(Pred2, Obj, TPred2, Events, Ctx). % built-in methods that cannot be redefined '$lgt_compile_message_to_object'(!, Obj, ('$lgt_object_exists'(Obj, !, ExCtx), !), _, Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx). '$lgt_compile_message_to_object'(true, Obj, ('$lgt_object_exists'(Obj, true, ExCtx), true), _, Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx). '$lgt_compile_message_to_object'(fail, Obj, ('$lgt_object_exists'(Obj, fail, ExCtx), fail), _, Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx). '$lgt_compile_message_to_object'(false, Obj, ('$lgt_object_exists'(Obj, false, ExCtx), false), _, Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx). '$lgt_compile_message_to_object'(repeat, Obj, ('$lgt_object_exists'(Obj, repeat, ExCtx), repeat), _, Ctx) :- !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx). % reflection built-in predicates '$lgt_compile_message_to_object'(current_op(Priority, Specifier, Operator), Obj, '$lgt_current_op'(Obj, Priority, Specifier, Operator, This, p(p(p)), ExCtx), _, Ctx) :- !, '$lgt_check'(var_or_operator_priority, Priority), '$lgt_check'(var_or_operator_specifier, Specifier), '$lgt_check'(var_or_atom, Operator), '$lgt_comp_ctx'(Ctx, _, _, _, _, This, _, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, This, _). '$lgt_compile_message_to_object'(current_predicate(Pred), Obj, '$lgt_current_predicate'(Obj, Pred, This, p(p(p)), ExCtx), _, Ctx) :- !, '$lgt_check'(var_or_predicate_indicator, Pred), '$lgt_comp_ctx'(Ctx, _, _, _, _, This, _, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, This, _). '$lgt_compile_message_to_object'(predicate_property(Pred, Prop), Obj, '$lgt_predicate_property'(Obj, Pred, Prop, This, p(p(p)), ExCtx), _, Ctx) :- !, '$lgt_check'(var_or_callable, Pred), '$lgt_check'(var_or_predicate_property, Prop), '$lgt_comp_ctx'(Ctx, _, _, _, _, This, _, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, This, _). % database handling built-in predicates '$lgt_compile_message_to_object'(abolish(Functor, Arity), Obj, TPred, Events, Ctx) :- '$lgt_prolog_built_in_predicate'(abolish(_, _)), \+ '$lgt_pp_defines_predicate_'(abolish(_, _), _, _, _, _, _), !, ( '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(deprecated, warning), '$lgt_source_file_context'(File, Lines), '$lgt_pp_entity_'(Type, Entity, _) -> '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(deprecated), deprecated_predicate(File, Lines, Type, Entity, abolish/2, abolish/1) ) ; true ), '$lgt_compile_message_to_object'(abolish(Functor/Arity), Obj, TPred, Events, Ctx). '$lgt_compile_message_to_object'(abolish(Pred), Obj, TPred, _, Ctx) :- !, '$lgt_check'(var_or_predicate_indicator, Pred), '$lgt_comp_ctx'(Ctx, Head, _, _, _, This, _, _, _, _, ExCtx, Mode, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, This, _), ( var(Obj) -> TPred = '$lgt_abolish'(Obj, Pred, This, p(p(p)), ExCtx) ; ground(Pred) -> TPred = '$lgt_abolish_checked'(Obj, Pred, This, p(p(p)), ExCtx), '$lgt_remember_updated_predicate'(Mode, Obj::Pred, Head) ; % partially instantiated predicate indicator; runtime check required TPred = '$lgt_abolish'(Obj, Pred, This, p(p(p)), ExCtx) ). '$lgt_compile_message_to_object'(assert(Clause), Obj, TPred, Events, Ctx) :- '$lgt_prolog_built_in_predicate'(assert(_)), \+ '$lgt_pp_defines_predicate_'(assert(_), _, _, _, _, _), !, ( '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(deprecated, warning), '$lgt_source_file_context'(File, Lines), '$lgt_pp_entity_'(Type, Entity, _) -> '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(deprecated), deprecated_predicate(File, Lines, Type, Entity, assert/1, assertz/1) ) ; true ), '$lgt_compile_message_to_object'(assertz(Clause), Obj, TPred, Events, Ctx). '$lgt_compile_message_to_object'(asserta(Clause), Obj, TPred, _, Ctx) :- !, '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, This, _, _, _, _, ExCtx, Mode, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, This, _), ( '$lgt_runtime_checked_db_clause'(Clause) -> TPred = '$lgt_asserta'(Obj, Clause, This, p(p(_)), p(p(p)), ExCtx) ; var(Obj) -> '$lgt_check'(clause, Clause), TPred = '$lgt_asserta'(Obj, Clause, This, p(p(_)), p(p(p)), ExCtx) ; '$lgt_check'(clause, Clause), ( (Clause = (Head :- Body) -> Body == true; Clause = Head) -> ( '$lgt_compiler_flag'(optimize, on), '$lgt_send_to_obj_db_msg_static_binding'(Obj, Head, THead) -> TPred = asserta(THead) ; TPred = '$lgt_asserta_fact_checked'(Obj, Head, This, p(p(_)), p(p(p)), ExCtx) ), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Obj::Functor/Arity, CallerHead) ; TPred = '$lgt_asserta_rule_checked'(Obj, Clause, This, p(p(_)), p(p(p)), ExCtx), Clause = (Head :- _), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Obj::Functor/Arity, CallerHead) ) ). '$lgt_compile_message_to_object'(assertz(Clause), Obj, TPred, _, Ctx) :- !, '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, This, _, _, _, _, ExCtx, Mode, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, This, _), ( '$lgt_runtime_checked_db_clause'(Clause) -> TPred = '$lgt_assertz'(Obj, Clause, This, p(p(_)), p(p(p)), ExCtx) ; var(Obj) -> '$lgt_check'(clause, Clause), TPred = '$lgt_assertz'(Obj, Clause, This, p(p(_)), p(p(p)), ExCtx) ; '$lgt_check'(clause, Clause), ( (Clause = (Head :- Body) -> Body == true; Clause = Head) -> ( '$lgt_compiler_flag'(optimize, on), '$lgt_send_to_obj_db_msg_static_binding'(Obj, Head, THead) -> TPred = assertz(THead) ; TPred = '$lgt_assertz_fact_checked'(Obj, Head, This, p(p(_)), p(p(p)), ExCtx) ), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Obj::Functor/Arity, CallerHead) ; TPred = '$lgt_assertz_rule_checked'(Obj, Clause, This, p(p(_)), p(p(p)), ExCtx), Clause = (Head :- _), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Obj::Functor/Arity, CallerHead) ) ). '$lgt_compile_message_to_object'(clause(Head, Body), Obj, TPred, _, Ctx) :- !, '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, This, _, _, _, _, ExCtx, Mode, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, This, _), ( '$lgt_runtime_checked_db_clause'((Head :- Body)) -> TPred = '$lgt_clause'(Obj, Head, Body, This, p(p(p)), ExCtx) ; '$lgt_check'(clause, (Head :- Body)), ( var(Obj) -> TPred = '$lgt_clause'(Obj, Head, Body, This, p(p(p)), ExCtx) ; TPred = '$lgt_clause_checked'(Obj, Head, Body, This, p(p(p)), ExCtx), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Obj::Functor/Arity, CallerHead) ) ). '$lgt_compile_message_to_object'(retract(Clause), Obj, TPred, _, Ctx) :- !, '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, This, _, _, _, _, ExCtx, Mode, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, This, _), ( '$lgt_runtime_checked_db_clause'(Clause) -> TPred = '$lgt_retract'(Obj, Clause, This, p(p(p)), ExCtx) ; var(Obj) -> '$lgt_check'(clause, Clause), TPred = '$lgt_retract'(Obj, Clause, This, p(p(p)), ExCtx) ; '$lgt_check'(clause, Clause), ( Clause = (Head :- Body) -> ( var(Body) -> TPred = '$lgt_retract_var_body_checked'(Obj, Clause, This, p(p(p)), ExCtx) ; Body == true -> ( '$lgt_compiler_flag'(optimize, on), '$lgt_send_to_obj_db_msg_static_binding'(Obj, Head, THead) -> TPred = retract(THead) ; TPred = '$lgt_retract_fact_checked'(Obj, Head, This, p(p(p)), ExCtx) ) ; TPred = '$lgt_retract_rule_checked'(Obj, Clause, This, p(p(p)), ExCtx) ), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Obj::Functor/Arity, CallerHead) ; TPred = '$lgt_retract_fact_checked'(Obj, Clause, This, p(p(p)), ExCtx), functor(Clause, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Obj::Functor/Arity, CallerHead) ) ). '$lgt_compile_message_to_object'(retractall(Head), Obj, TPred, _, Ctx) :- !, '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, This, _, _, _, _, ExCtx, Mode, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, This, _), ( var(Head) -> TPred = '$lgt_retractall'(Obj, Head, This, p(p(p)), ExCtx) ; var(Obj) -> '$lgt_check'(callable, Head), TPred = '$lgt_retractall'(Obj, Head, This, p(p(p)), ExCtx) ; '$lgt_check'(callable, Head), ( '$lgt_compiler_flag'(optimize, on), '$lgt_send_to_obj_db_msg_static_binding'(Obj, Head, THead) -> TPred = retractall(THead) ; TPred = '$lgt_retractall_checked'(Obj, Head, This, p(p(p)), ExCtx) ), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Obj::Functor/Arity, CallerHead) ). % database handling built-in predicates that take a clause reference % if supported as built-in predicates by the backend Prolog compiler '$lgt_compile_message_to_object'(assert(Clause, Ref), Obj, TPred, Events, Ctx) :- '$lgt_prolog_built_in_predicate'(assert(_, _)), \+ '$lgt_pp_defines_predicate_'(assert(_, _), _, _, _, _, _), !, ( '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(deprecated, warning), '$lgt_source_file_context'(File, Lines), '$lgt_pp_entity_'(Type, Entity, _) -> '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(deprecated), deprecated_predicate(File, Lines, Type, Entity, assert/2, assertz/2) ) ; true ), '$lgt_compile_message_to_object'(assertz(Clause, Ref), Obj, TPred, Events, Ctx). '$lgt_compile_message_to_object'(asserta(Clause, Ref), Obj, TPred, _, Ctx) :- '$lgt_prolog_built_in_predicate'(asserta(_, _)), \+ '$lgt_pp_defines_predicate_'(asserta(_, _), _, _, _, _, _), !, '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, This, _, _, _, _, ExCtx, Mode, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, This, _), ( '$lgt_runtime_checked_db_clause'(Clause) -> TPred = '$lgt_asserta'(Obj, Clause, Ref, This, p(p(_)), p(p(p)), ExCtx) ; var(Obj) -> '$lgt_check'(clause, Clause), TPred = '$lgt_asserta'(Obj, Clause, Ref, This, p(p(_)), p(p(p)), ExCtx) ; '$lgt_check'(clause, Clause), ( (Clause = (Head :- Body) -> Body == true; Clause = Head) -> ( '$lgt_compiler_flag'(optimize, on), '$lgt_send_to_obj_db_msg_static_binding'(Obj, Head, THead) -> TPred = asserta(THead, Ref) ; TPred = '$lgt_asserta_fact_checked'(Obj, Head, Ref, This, p(p(_)), p(p(p)), ExCtx) ), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Obj::Functor/Arity, CallerHead) ; TPred = '$lgt_asserta_rule_checked'(Obj, Clause, Ref, This, p(p(_)), p(p(p)), ExCtx), Clause = (Head :- _), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Obj::Functor/Arity, CallerHead) ) ). '$lgt_compile_message_to_object'(assertz(Clause, Ref), Obj, TPred, _, Ctx) :- '$lgt_prolog_built_in_predicate'(assertz(_, _)), \+ '$lgt_pp_defines_predicate_'(assertz(_, _), _, _, _, _, _), !, '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, This, _, _, _, _, ExCtx, Mode, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, This, _), ( '$lgt_runtime_checked_db_clause'(Clause) -> TPred = '$lgt_assertz'(Obj, Clause, Ref, Ref, This, p(p(_)), p(p(p)), ExCtx) ; var(Obj) -> '$lgt_check'(clause, Clause), TPred = '$lgt_assertz'(Obj, Clause, Ref, This, p(p(_)), p(p(p)), ExCtx) ; '$lgt_check'(clause, Clause), ( (Clause = (Head :- Body) -> Body == true; Clause = Head) -> ( '$lgt_compiler_flag'(optimize, on), '$lgt_send_to_obj_db_msg_static_binding'(Obj, Head, THead) -> TPred = assertz(THead, Ref) ; TPred = '$lgt_assertz_fact_checked'(Obj, Head, Ref, This, p(p(_)), p(p(p)), ExCtx) ), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Obj::Functor/Arity, CallerHead) ; TPred = '$lgt_assertz_rule_checked'(Obj, Clause, Ref, This, p(p(_)), p(p(p)), ExCtx), Clause = (Head :- _), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Obj::Functor/Arity, CallerHead) ) ). '$lgt_compile_message_to_object'(clause(Head, Body, Ref), Obj, TPred, _, Ctx) :- '$lgt_prolog_built_in_predicate'(clause(_, _, _)), \+ '$lgt_pp_defines_predicate_'(clause(_, _, _), _, _, _, _, _), !, '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, This, _, _, _, _, ExCtx, Mode, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, This, _), ( '$lgt_runtime_checked_db_clause'((Head :- Body)) -> TPred = '$lgt_clause'(Obj, Head, Body, Ref, This, p(p(p)), ExCtx) ; '$lgt_check'(clause, (Head :- Body)), ( var(Obj) -> TPred = '$lgt_clause'(Obj, Head, Body, Ref, This, p(p(p)), ExCtx) ; TPred = '$lgt_clause_checked'(Obj, Head, Body, Ref, This, p(p(p)), ExCtx), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, Obj::Functor/Arity, CallerHead) ) ). % term and goal expansion predicates '$lgt_compile_message_to_object'(expand_term(Term, Expansion), Obj, '$lgt_expand_term_message'(Obj, Term, Expansion, This, p(p(p)), ExCtx), _, Ctx) :- !, '$lgt_comp_ctx'(Ctx, _, _, _, _, This, _, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, This, _). '$lgt_compile_message_to_object'(expand_goal(Goal, ExpandedGoal), Obj, '$lgt_expand_goal_message'(Obj, Goal, ExpandedGoal, This, p(p(p))), _, Ctx) :- !, '$lgt_comp_ctx'(Ctx, _, _, _, _, This, _, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context_this_entity'(ExCtx, This, _). % compiler bypass control construct '$lgt_compile_message_to_object'({Goal}, _, call(Goal), _, _) :- !, '$lgt_check'(var_or_callable, Goal). % invalid message '$lgt_compile_message_to_object'(Pred, _, _, _, _) :- \+ callable(Pred), throw(type_error(callable, Pred)). % message is not a built-in control construct or a call to a built-in (meta-)predicate '$lgt_compile_message_to_object'(Pred, Obj, TPred, Events, Ctx) :- var(Obj), % translation performed at runtime !, '$lgt_comp_ctx'(Ctx, Head, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), '$lgt_add_referenced_object_message'(Mode, Obj, Pred, Pred, Head), ( Events == allow -> TPred = '$lgt_send_to_obj'(Obj, Pred, ExCtx) ; TPred = '$lgt_send_to_obj_ne'(Obj, Pred, ExCtx) ). % special case where an object sends a message to itself; the practical % case is parametric objects where one or more parameters are updated by % the object predicates '$lgt_compile_message_to_object'(Pred, Obj, TPred, Events, Ctx) :- '$lgt_pp_entity_'(object, Entity, _), functor(Obj, Functor, Arity), functor(Entity, Functor, Arity), '$lgt_pp_defines_predicate_'(Pred, _, _, _, _, _), % local predicate !, '$lgt_comp_ctx'(Ctx, Head, HeadExCtx, Entity, _, This, _, Prefix, MetaVars, _, ExCtx, Mode, _, Lines, Term), '$lgt_comp_ctx'(NewCtx, Head, HeadExCtx, Obj, Entity, Obj, Obj, Prefix, MetaVars, _, NewExCtx, Mode, _, Lines, Term), '$lgt_execution_context_this_entity'(ExCtx, This, Entity), '$lgt_execution_context'(NewExCtx, Obj, This, Obj, Obj, [], []), '$lgt_compile_body'(Pred, message, TPred0, _, NewCtx), ( Events == allow -> TPred = '$lgt_guarded_method_call'(Obj, Pred, This, TPred0) ; TPred = TPred0 ). '$lgt_compile_message_to_object'(Pred, Obj, _, _, Ctx) :- '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), % check for a user-defined linter warning once(logtalk_linter_hook(Obj::Pred, Flag, File, Lines, Type, Entity, Warning)), nonvar(Flag), '$lgt_valid_flag'(Flag), '$lgt_compiler_flag'(Flag, warning), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'(warning(Flag), Warning), fail. '$lgt_compile_message_to_object'(Pred, Obj, _, _, Ctx) :- '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_current_object_'(Obj, _, Dcl, _, _, _, _, _, _, _, _), \+ call(Dcl, forward(_), _, _, _, _, _), \+ call(Dcl, Pred, _, _, _, _, _), '$lgt_compiler_flag'(unknown_predicates, warning), '$lgt_source_file_context'(File, Lines), '$lgt_increment_compiling_warnings_counter', ( '$lgt_pp_entity_'(Type, Entity, _) -> Message = message_not_understood(File, Lines, Type, Entity, Obj, Pred) ; Message = message_not_understood(File, Lines, Obj, Pred) ), '$lgt_print_message'(warning(unknown_predicates), Message), fail. '$lgt_compile_message_to_object'(Pred, Obj, TPred, Events, Ctx) :- '$lgt_comp_ctx'(Ctx, Head, _, _, _, This, _, _, _, _, ExCtx, Mode, _, _, _), '$lgt_add_referenced_object_message'(Mode, Obj, Pred, Pred, Head), ( Events == allow -> ( '$lgt_compiler_flag'(optimize, on), '$lgt_send_to_obj_static_binding'(Obj, Pred, Call, Ctx) -> '$lgt_execution_context_this_entity'(ExCtx, This, _), TPred = '$lgt_guarded_method_call'(Obj, Pred, This, Call) ; TPred = '$lgt_send_to_obj_'(Obj, Pred, ExCtx) ) ; ( '$lgt_compiler_flag'(optimize, on), '$lgt_send_to_obj_static_binding'(Obj, Pred, TPred, Ctx) -> true ; TPred = '$lgt_send_to_obj_ne_'(Obj, Pred, ExCtx) ) ). % '$lgt_compile_message_to_self'(@term, -callable, @execution_context) % % compiles the sending of a message to self % translation performed at runtime '$lgt_compile_message_to_self'(Pred, '$lgt_send_to_self'(Pred, NewCtx), Ctx) :- var(Pred), !, '$lgt_comp_ctx'(Ctx, Head, _, Entity, Sender, This, Self, Prefix, MetaVars, MetaCallCtx, ExCtx, _, Stack, Lines, _), '$lgt_comp_ctx'(NewCtx, Head, _, Entity, Sender, This, Self, Prefix, MetaVars, MetaCallCtx, ExCtx, runtime, Stack, Lines, _). % suspicious use of ::/1 instead of a local predicate call in clauses that % apparently are meant to implement recursive predicate definitions where % the user intention is to call the local predicate; the user may also % intend to make a "super" call instead of a message to "self" '$lgt_compile_message_to_self'(Pred, _, Ctx) :- '$lgt_comp_ctx'(Ctx, Head, _, _, _, _, _, _, _, _, _, compile(_,_,_), _, _, _), '$lgt_compiler_flag'(suspicious_calls, warning), functor(Pred, Functor, Arity), functor(Head, Functor, Arity), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(suspicious_calls), suspicious_call(File, Lines, Type, Entity, ::Pred, [Pred, ^^Pred]) ), fail. % broadcasting control constructs '$lgt_compile_message_to_self'((Pred1, Pred2), (TPred1, TPred2), Ctx) :- !, '$lgt_compile_message_to_self'(Pred1, TPred1, Ctx), '$lgt_compile_message_to_self'(Pred2, TPred2, Ctx). '$lgt_compile_message_to_self'((Pred1; Pred2), (TPred1; TPred2), Ctx) :- !, '$lgt_compile_message_to_self'(Pred1, TPred1, Ctx), '$lgt_compile_message_to_self'(Pred2, TPred2, Ctx). '$lgt_compile_message_to_self'((Pred1 -> Pred2), (TPred1 -> TPred2), Ctx) :- !, '$lgt_compile_message_to_self'(Pred1, TPred1, Ctx), '$lgt_compile_message_to_self'(Pred2, TPred2, Ctx). '$lgt_compile_message_to_self'('*->'(Pred1, Pred2), '*->'(TPred1, TPred2), Ctx) :- '$lgt_predicate_property'('*->'(_, _), built_in), !, '$lgt_compile_message_to_self'(Pred1, TPred1, Ctx), '$lgt_compile_message_to_self'(Pred2, TPred2, Ctx). % built-in methods that cannot be redefined '$lgt_compile_message_to_self'(!, !, _) :- !. '$lgt_compile_message_to_self'(true, true, _) :- !. '$lgt_compile_message_to_self'(false, false, _) :- !. '$lgt_compile_message_to_self'(fail, fail, _) :- !. '$lgt_compile_message_to_self'(repeat, repeat, _) :- !. % reflection built-in predicates '$lgt_compile_message_to_self'(current_op(Priority, Specifier, Operator), '$lgt_current_op'(Self, Priority, Specifier, Operator, This, p(_), ExCtx), Ctx) :- !, '$lgt_check'(var_or_operator_priority, Priority), '$lgt_check'(var_or_operator_specifier, Specifier), '$lgt_check'(var_or_atom, Operator), '$lgt_comp_ctx'(Ctx, _, _, _, _, This, Self, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context'(ExCtx, _, _, This, Self, _, _). '$lgt_compile_message_to_self'(current_predicate(Pred), '$lgt_current_predicate'(Self, Pred, This, p(_), ExCtx), Ctx) :- !, '$lgt_check'(var_or_predicate_indicator, Pred), '$lgt_comp_ctx'(Ctx, _, _, _, _, This, Self, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context'(ExCtx, _, _, This, Self, _, _). '$lgt_compile_message_to_self'(predicate_property(Pred, Prop), '$lgt_predicate_property'(Self, Pred, Prop, This, p(_), ExCtx), Ctx) :- !, '$lgt_check'(var_or_callable, Pred), '$lgt_check'(var_or_predicate_property, Prop), '$lgt_comp_ctx'(Ctx, _, _, _, _, This, Self, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context'(ExCtx, _, _, This, Self, _, _). % database handling built-in predicates '$lgt_compile_message_to_self'(abolish(Functor, Arity), TPred, Ctx) :- '$lgt_prolog_built_in_predicate'(abolish(_, _)), \+ '$lgt_pp_defines_predicate_'(abolish(_, _), _, _, _, _, _), !, ( '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(deprecated, warning), '$lgt_source_file_context'(File, Lines), '$lgt_pp_entity_'(Type, Entity, _) -> '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(deprecated), deprecated_predicate(File, Lines, Type, Entity, abolish/2, abolish/1) ) ; true ), '$lgt_compile_message_to_self'(abolish(Functor/Arity), TPred, Ctx). '$lgt_compile_message_to_self'(abolish(Pred), TPred, Ctx) :- !, '$lgt_check'(var_or_predicate_indicator, Pred), '$lgt_comp_ctx'(Ctx, Head, _, _, _, This, Self, _, _, _, ExCtx, Mode, _, _, _), '$lgt_execution_context'(ExCtx, _, _, This, Self, _, _), ( ground(Pred) -> TPred = '$lgt_abolish_checked'(Self, Pred, This, p(_), ExCtx), '$lgt_remember_updated_predicate'(Mode, ::Pred, Head) ; % partially instantiated predicate indicator; runtime check required TPred = '$lgt_abolish'(Self, Pred, This, p(_), ExCtx) ). '$lgt_compile_message_to_self'(assert(Clause), TPred, Ctx) :- '$lgt_prolog_built_in_predicate'(assert(_)), \+ '$lgt_pp_defines_predicate_'(assert(_), _, _, _, _, _), !, ( '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(deprecated, warning), '$lgt_source_file_context'(File, Lines), '$lgt_pp_entity_'(Type, Entity, _) -> '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(deprecated), deprecated_predicate(File, Lines, Type, Entity, assert/1, assertz/1) ) ; true ), '$lgt_compile_message_to_self'(assertz(Clause), TPred, Ctx). '$lgt_compile_message_to_self'(asserta(Clause), TPred, Ctx) :- !, '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, This, Self, _, _, _, ExCtx, Mode, _, _, _), '$lgt_execution_context'(ExCtx, _, _, This, Self, _, _), ( '$lgt_runtime_checked_db_clause'(Clause) -> TPred = '$lgt_asserta'(Self, Clause, This, p(_), p(p), ExCtx) ; '$lgt_check'(clause, Clause), ( Clause = (Head :- Body) -> ( Body == true -> TPred = '$lgt_asserta_fact_checked'(Self, Head, This, p(_), p(p), ExCtx) ; TPred = '$lgt_asserta_rule_checked'(Self, Clause, This, p(_), p(p), ExCtx) ), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, ::Functor/Arity, CallerHead) ; TPred = '$lgt_asserta_fact_checked'(Self, Clause, This, p(_), p(p), ExCtx), functor(Clause, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, ::Functor/Arity, CallerHead) ) ). '$lgt_compile_message_to_self'(assertz(Clause), TPred, Ctx) :- !, '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, This, Self, _, _, _, ExCtx, Mode, _, _, _), '$lgt_execution_context'(ExCtx, _, _, This, Self, _, _), ( '$lgt_runtime_checked_db_clause'(Clause) -> TPred = '$lgt_assertz'(Self, Clause, This, p(_), p(p), ExCtx) ; '$lgt_check'(clause, Clause), ( Clause = (Head :- Body) -> ( Body == true -> TPred = '$lgt_assertz_fact_checked'(Self, Head, This, p(_), p(p), ExCtx) ; TPred = '$lgt_assertz_rule_checked'(Self, Clause, This, p(_), p(p), ExCtx) ), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, ::Functor/Arity, CallerHead) ; TPred = '$lgt_assertz_fact_checked'(Self, Clause, This, p(_), p(p), ExCtx), functor(Clause, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, ::Functor/Arity, CallerHead) ) ). '$lgt_compile_message_to_self'(clause(Head, Body), TPred, Ctx) :- !, '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, This, Self, _, _, _, ExCtx, Mode, _, _, _), '$lgt_execution_context'(ExCtx, _, _, This, Self, _, _), ( '$lgt_runtime_checked_db_clause'((Head :- Body)) -> TPred = '$lgt_clause'(Self, Head, Body, This, p(_), ExCtx) ; '$lgt_check'(clause, (Head :- Body)), TPred = '$lgt_clause_checked'(Self, Head, Body, This, p(_), ExCtx), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, ::Functor/Arity, CallerHead) ). '$lgt_compile_message_to_self'(retract(Clause), TPred, Ctx) :- !, '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, This, Self, _, _, _, ExCtx, Mode, _, _, _), '$lgt_execution_context'(ExCtx, _, _, This, Self, _, _), ( '$lgt_runtime_checked_db_clause'(Clause) -> TPred = '$lgt_retract'(Self, Clause, This, p(_), ExCtx) ; '$lgt_check'(clause, Clause), ( Clause = (Head :- Body) -> ( var(Body) -> TPred = '$lgt_retract_var_body_checked'(Self, Clause, This, p(_), ExCtx) ; Body == true -> TPred = '$lgt_retract_fact_checked'(Self, Head, This, p(_), ExCtx) ; TPred = '$lgt_retract_rule_checked'(Self, Clause, This, p(_), ExCtx) ), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, ::Functor/Arity, CallerHead) ; TPred = '$lgt_retract_fact_checked'(Self, Clause, This, p(_), ExCtx), functor(Clause, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, ::Functor/Arity, CallerHead) ) ). '$lgt_compile_message_to_self'(retractall(Head), TPred, Ctx) :- !, '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, This, Self, _, _, _, ExCtx, Mode, _, _, _), '$lgt_execution_context'(ExCtx, _, _, This, Self, _, _), ( var(Head) -> TPred = '$lgt_retractall'(Self, Head, This, p(_), ExCtx) ; '$lgt_check'(callable, Head), TPred = '$lgt_retractall_checked'(Self, Head, This, p(_), ExCtx), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, ::Functor/Arity, CallerHead) ). % database handling built-in predicates that take a clause reference % if supported as built-in predicates by the backend Prolog compiler '$lgt_compile_message_to_self'(assert(Clause, Ref), TPred, Ctx) :- '$lgt_prolog_built_in_predicate'(assert(_, _)), \+ '$lgt_pp_defines_predicate_'(assert(_, _), _, _, _, _, _), !, ( '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(deprecated, warning), '$lgt_source_file_context'(File, Lines), '$lgt_pp_entity_'(Type, Entity, _) -> '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(deprecated), deprecated_predicate(File, Lines, Type, Entity, assert/2, assertz/2) ) ; true ), '$lgt_compile_message_to_self'(assertz(Clause, Ref), TPred, Ctx). '$lgt_compile_message_to_self'(asserta(Clause, Ref), TPred, Ctx) :- '$lgt_prolog_built_in_predicate'(asserta(_, _)), \+ '$lgt_pp_defines_predicate_'(asserta(_, _), _, _, _, _, _), !, '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, This, Self, _, _, _, ExCtx, Mode, _, _, _), '$lgt_execution_context'(ExCtx, _, _, This, Self, _, _), ( '$lgt_runtime_checked_db_clause'(Clause) -> TPred = '$lgt_asserta'(Self, Clause, Ref, This, p(_), p(p), ExCtx) ; '$lgt_check'(clause, Clause), ( Clause = (Head :- Body) -> ( Body == true -> TPred = '$lgt_asserta_fact_checked'(Self, Head, Ref, This, p(_), p(p), ExCtx) ; TPred = '$lgt_asserta_rule_checked'(Self, Clause, Ref, This, p(_), p(p), ExCtx) ), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, ::Functor/Arity, CallerHead) ; TPred = '$lgt_asserta_fact_checked'(Self, Clause, Ref, This, p(_), p(p), ExCtx), functor(Clause, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, ::Functor/Arity, CallerHead) ) ). '$lgt_compile_message_to_self'(assertz(Clause, Ref), TPred, Ctx) :- '$lgt_prolog_built_in_predicate'(assertz(_, _)), \+ '$lgt_pp_defines_predicate_'(assertz(_, _), _, _, _, _, _), !, '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, This, Self, _, _, _, ExCtx, Mode, _, _, _), '$lgt_execution_context'(ExCtx, _, _, This, Self, _, _), ( '$lgt_runtime_checked_db_clause'(Clause) -> TPred = '$lgt_assertz'(Self, Clause, Ref, This, p(_), p(p), ExCtx) ; '$lgt_check'(clause, Clause), ( Clause = (Head :- Body) -> ( Body == true -> TPred = '$lgt_assertz_fact_checked'(Self, Head, Ref, This, p(_), p(p), ExCtx) ; TPred = '$lgt_assertz_rule_checked'(Self, Clause, Ref, This, p(_), p(p), ExCtx) ), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, ::Functor/Arity, CallerHead) ; TPred = '$lgt_assertz_fact_checked'(Self, Clause, Ref, This, p(_), p(p), ExCtx), functor(Clause, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, ::Functor/Arity, CallerHead) ) ). '$lgt_compile_message_to_self'(clause(Head, Body, Ref), TPred, Ctx) :- '$lgt_prolog_built_in_predicate'(clause(_, _, _)), \+ '$lgt_pp_defines_predicate_'(clause(_, _, _), _, _, _, _, _), !, '$lgt_comp_ctx'(Ctx, CallerHead, _, _, _, This, Self, _, _, _, ExCtx, Mode, _, _, _), '$lgt_execution_context'(ExCtx, _, _, This, Self, _, _), ( '$lgt_runtime_checked_db_clause'((Head :- Body)) -> TPred = '$lgt_clause'(Self, Head, Body, Ref, This, p(_), ExCtx) ; '$lgt_check'(clause, (Head :- Body)), TPred = '$lgt_clause_checked'(Self, Head, Body, Ref, This, p(_), ExCtx), functor(Head, Functor, Arity), '$lgt_remember_updated_predicate'(Mode, ::Functor/Arity, CallerHead) ). % term and goal expansion predicates '$lgt_compile_message_to_self'(expand_term(Term, Expansion), '$lgt_expand_term_message'(Self, Term, Expansion, This, p(_), ExCtx), Ctx) :- !, '$lgt_comp_ctx'(Ctx, _, _, _, _, This, Self, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context'(ExCtx, _, _, This, Self, _, _). '$lgt_compile_message_to_self'(expand_goal(Goal, ExpandedGoal), '$lgt_expand_goal_message'(Self, Goal, ExpandedGoal, This, p(_)), Ctx) :- !, '$lgt_comp_ctx'(Ctx, _, _, _, _, This, Self, _, _, _, ExCtx, _, _, _, _), '$lgt_execution_context'(ExCtx, _, _, This, Self, _, _). % compiler bypass control construct '$lgt_compile_message_to_self'({Goal}, call(Goal), _) :- !, '$lgt_check'(var_or_callable, Goal). % invalid message '$lgt_compile_message_to_self'(Pred, _, _) :- \+ callable(Pred), throw(type_error(callable, Pred)). % message is not a built-in control construct or a call to a built-in % (meta-)predicate: translation performed at runtime '$lgt_compile_message_to_self'(Pred, '$lgt_send_to_self_'(Self, Pred, ExCtx), Ctx) :- '$lgt_comp_ctx'(Ctx, Head, _, _, _, _, Self, _, _, _, ExCtx, Mode, _, _, _), '$lgt_execution_context'(ExCtx, _, _, _, Self, _, _), functor(Pred, Functor, Arity), '$lgt_remember_called_self_predicate'(Mode, Functor/Arity, Head), !. % '$lgt_compile_super_call'(@term, -callable, +compilation_context) % % compiles calling of redefined predicates ("super" calls) '$lgt_compile_super_call'(Pred, TPred, Ctx) :- '$lgt_pp_object_'(Obj, _, _, _, Super, _, _, _, _, _, _), !, '$lgt_comp_ctx'(Ctx, Head, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), ( \+ '$lgt_pp_extended_object_'(_, _, _, _, _, _, _, _, _, _, _), \+ '$lgt_pp_instantiated_class_'(_, _, _, _, _, _, _, _, _, _, _), \+ '$lgt_pp_specialized_class_'(_, _, _, _, _, _, _, _, _, _, _), \+ '$lgt_pp_imported_category_'(_, _, _, _, _, _) -> % invalid goal (no ancestor entity) throw(existence_error(ancestor, object)) ; var(Pred) -> % translation performed at runtime '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), TPred = '$lgt_obj_super_call'(Super, Pred, ExCtx) ; callable(Pred) -> ( '$lgt_compiler_flag'(optimize, on), '$lgt_obj_related_entities_are_static', '$lgt_obj_super_call_static_binding'(Obj, Pred, ExCtx, TPred) -> true ; TPred = '$lgt_obj_super_call_'(Super, Pred, ExCtx) ), functor(Pred, Functor, Arity), '$lgt_remember_called_super_predicate'(Mode, Functor/Arity, Head) ; throw(type_error(callable, Pred)) ). '$lgt_compile_super_call'(Pred, TPred, Ctx) :- '$lgt_pp_complemented_object_'(Obj, _, _, _, _), % super calls from predicates defined in complementing categories % lookup inherited definitions in the complemented object ancestors !, '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), ( var(Pred) -> TPred = ( '$lgt_current_object_'(Obj, _, _, _, Super, _, _, _, _, _, _), '$lgt_obj_super_call'(Super, Pred, ExCtx) ) ; callable(Pred) -> TPred = ( '$lgt_current_object_'(Obj, _, _, _, Super, _, _, _, _, _, _), '$lgt_obj_super_call_'(Super, Pred, ExCtx) ) ; throw(type_error(callable, Pred)) ). '$lgt_compile_super_call'(Pred, TPred, Ctx) :- '$lgt_pp_category_'(Ctg, _, _, _, _, _), !, ( \+ '$lgt_pp_extended_category_'(_, _, _, _, _, _) -> % invalid goal (not an extended category) throw(existence_error(ancestor, category)) ; var(Pred) -> % translation performed at runtime '$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx), TPred = '$lgt_ctg_super_call'(Ctg, Pred, ExCtx) ; callable(Pred) -> '$lgt_comp_ctx'(Ctx, Head, _, _, _, _, _, _, _, _, ExCtx, Mode, _, _, _), ( '$lgt_compiler_flag'(optimize, on), '$lgt_ctg_related_entities_are_static', '$lgt_ctg_super_call_static_binding'(Ctg, Pred, ExCtx, TPred) -> true ; TPred = '$lgt_ctg_super_call_'(Ctg, Pred, ExCtx) ), functor(Pred, Functor, Arity), '$lgt_remember_called_super_predicate'(Mode, Functor/Arity, Head) ; throw(type_error(callable, Pred)) ). '$lgt_compile_super_call'(Pred, TPred, Ctx) :- '$lgt_comp_ctx'(Ctx, _, _, _, _, This, _, _, _, _, ExCtx, runtime, _, _, _), callable(This), '$lgt_current_object_'(This, _, _, _, Super, _, _, _, _, _, _), TPred = '$lgt_obj_super_call'(Super, Pred, ExCtx). '$lgt_obj_related_entities_are_static' :- forall( '$lgt_pp_extended_object_'(Obj, _, _, _, _, _, _, _, _, _, _), ('$lgt_current_object_'(Obj, _, _, _, _, _, _, _, _, _, Flags), Flags /\ 2 =:= 0) ), forall( '$lgt_pp_instantiated_class_'(Obj, _, _, _, _, _, _, _, _, _, _), ('$lgt_current_object_'(Obj, _, _, _, _, _, _, _, _, _, Flags), Flags /\ 2 =:= 0) ), forall( '$lgt_pp_specialized_class_'(Obj, _, _, _, _, _, _, _, _, _, _), ('$lgt_current_object_'(Obj, _, _, _, _, _, _, _, _, _, Flags), Flags /\ 2 =:= 0) ), forall( '$lgt_pp_imported_category_'(Ctg, _, _, _, _, _), ('$lgt_current_category_'(Ctg, _, _, _, _, Flags), Flags /\ 2 =:= 0) ), forall( '$lgt_pp_implemented_protocol_'(Ptc, _, _, _, _), ('$lgt_current_protocol_'(Ptc, _, _, _, Flags), Flags /\ 2 =:= 0) ). '$lgt_ctg_related_entities_are_static' :- forall( '$lgt_pp_extended_category_'(Ctg, _, _, _, _, _), ('$lgt_current_category_'(Ctg, _, _, _, _, Flags), Flags /\ 2 =:= 0) ), forall( '$lgt_pp_implemented_protocol_'(Ptc, _, _, _, _), ('$lgt_current_protocol_'(Ptc, _, _, _, Flags), Flags /\ 2 =:= 0) ). % '$lgt_compile_context_switch_call'(@term, @term, -callable, @execution_context) % % compiles context-switching calls '$lgt_compile_context_switch_call'(Obj, Goal, TGoal, ExCtx) :- ( var(Obj) -> '$lgt_check'(var_or_callable, Goal), TGoal = '$lgt_call_within_context'(Obj, Goal, ExCtx) ; Obj = {Proxy} -> '$lgt_check'(var_or_callable, Proxy), ( var(Proxy) -> CallProxy = call(Proxy) ; CallProxy = Proxy ), '$lgt_compile_context_switch_call'(Proxy, Goal, TGoal0, ExCtx), TGoal = (CallProxy, TGoal0) ; var(Goal) -> '$lgt_check'(var_or_object_identifier, Obj), TGoal = '$lgt_call_within_context'(Obj, Goal, ExCtx) ; '$lgt_check'(object_identifier, Obj), '$lgt_check'(callable, Goal), TGoal = '$lgt_call_within_context_nv'(Obj, Goal, ExCtx) ). % '$lgt_head_meta_variables'(+callable, -list(variable)) % % constructs a list of all variables that occur in a position corresponding % to a meta-argument in the head of clause being compiled '$lgt_head_meta_variables'(Head, MetaVars) :- ( '$lgt_find_head_meta_predicate_template'(Head, Pred, Template) -> Pred =.. [_| Args], Template =.. [_| MArgs], '$lgt_extract_meta_variables'(Args, MArgs, MetaVars) ; MetaVars = [] ). '$lgt_find_head_meta_predicate_template'(Entity::Pred, Pred, Template) :- ( '$lgt_pp_meta_predicate_'(Entity::Pred, Entity::Template, _, _) ; '$lgt_current_object_'(Entity, _, Dcl, _, _, _, _, _, _, _, _), call(Dcl, Pred, _, Template, _), Template \== no ; '$lgt_current_category_'(Entity, _, Dcl, _, _, _), call(Dcl, Pred, _, Template, _), Template \== no ), !. '$lgt_find_head_meta_predicate_template'(':'(Module, Pred), Pred, Template) :- '$lgt_pp_meta_predicate_'(':'(Module, Pred), ':'(Module, Template), _, _), !. '$lgt_find_head_meta_predicate_template'(Head, Head, Meta) :- '$lgt_pp_meta_predicate_'(Head, Meta, _, _). '$lgt_extract_meta_variables'([], [], []). '$lgt_extract_meta_variables'([Arg| Args], [MArg| MArgs], MetaVars) :- ( MArg == (*) -> % normal argument '$lgt_extract_meta_variables'(Args, MArgs, MetaVars) ; MArg == (::) -> term_variables(Arg, MetaVars0), '$lgt_append'(MetaVars0, MetaVars1, MetaVars), '$lgt_extract_meta_variables'(Args, MArgs, MetaVars1) ; integer(MArg), % meta-argument (closure or goal) nonvar(Arg) -> throw(type_error(variable, Arg)) ; var(Arg) -> % meta-argument MetaVars = [Arg| RestMetaVars], '$lgt_extract_meta_variables'(Args, MArgs, RestMetaVars) ; % bound argument and thus not a meta-variable '$lgt_extract_meta_variables'(Args, MArgs, MetaVars) ). % '$lgt_goal_meta_arguments'(+callable, +callable, -list(term)) % % constructs a list of all meta-arguments in a goal '$lgt_goal_meta_arguments'(no, _, []) :- !. '$lgt_goal_meta_arguments'(Meta, Goal, MetaArgs) :- % don't require the same predicate name for the meta-predicate % template and the goal as the goal may be an alias Meta =.. [_| MArgs], Goal =.. [_| Args], '$lgt_extract_meta_arguments'(MArgs, Args, MetaArgs). '$lgt_extract_meta_arguments'([], [], []). '$lgt_extract_meta_arguments'([MArg| MArgs], [Arg| Args], MetaArgs) :- ( MArg == (*) -> % normal argument '$lgt_extract_meta_arguments'(MArgs, Args, MetaArgs) ; % meta-argument MetaArgs = [Arg| RestMetaArgs], '$lgt_extract_meta_arguments'(MArgs, Args, RestMetaArgs) ). % '$lgt_goal_meta_call_context'(+callable, @term, @term, -callable) % % returns the meta-call execution context: an empty list for local % meta-calls or the sender execution context when the message is for % a meta-predicate '$lgt_goal_meta_call_context'(no, ExCtx, This, []) :- !, '$lgt_execution_context_this_entity'(ExCtx, This, _). '$lgt_goal_meta_call_context'(_, ExCtx, This, ExCtx) :- '$lgt_execution_context_this_entity'(ExCtx, This, _). % '$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, Operators) :- catch( ( '$lgt_save_operators'(Operators, Saved), '$lgt_add_operators'(Operators), read_term(Stream, Term, Options), '$lgt_remove_operators'(Operators), '$lgt_add_operators'(Saved) ), Error, '$lgt_iso_stream_input_output_error_handler'(Operators, 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, Operators) :- catch( ( '$lgt_save_operators'(Operators, Saved), '$lgt_add_operators'(Operators), read_term(Term, Options), '$lgt_remove_operators'(Operators), '$lgt_add_operators'(Saved) ), Error, '$lgt_iso_stream_input_output_error_handler'(Operators, Saved, Error) ). % '$lgt_iso_read'(@stream, ?term, @list) % % wraps read/2 call with the necessary operator settings '$lgt_iso_read'(Stream, Term, Operators) :- catch( ( '$lgt_save_operators'(Operators, Saved), '$lgt_add_operators'(Operators), read(Stream, Term), '$lgt_remove_operators'(Operators), '$lgt_add_operators'(Saved) ), Error, '$lgt_iso_stream_input_output_error_handler'(Operators, Saved, Error) ). % '$lgt_iso_read'(?term, @list) % % wraps read/1 call with the necessary operator settings '$lgt_iso_read'(Term, Operators) :- catch( ( '$lgt_save_operators'(Operators, Saved), '$lgt_add_operators'(Operators), read(Term), '$lgt_remove_operators'(Operators), '$lgt_add_operators'(Saved) ), Error, '$lgt_iso_stream_input_output_error_handler'(Operators, 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, Operators) :- catch( ( '$lgt_save_operators'(Operators, Saved), '$lgt_add_operators'(Operators), write_term(Stream, Term, Options), '$lgt_remove_operators'(Operators), '$lgt_add_operators'(Saved) ), Error, '$lgt_iso_stream_input_output_error_handler'(Operators, 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, Operators) :- catch( ( '$lgt_save_operators'(Operators, Saved), '$lgt_add_operators'(Operators), write_term(Term, Options), '$lgt_remove_operators'(Operators), '$lgt_add_operators'(Saved) ), Error, '$lgt_iso_stream_input_output_error_handler'(Operators, Saved, Error) ). % '$lgt_iso_write'(@stream_or_alias, @term, @list) % % wraps write/2 call with the necessary operator settings '$lgt_iso_write'(Stream, Term, Operators) :- catch( ( '$lgt_save_operators'(Operators, Saved), '$lgt_add_operators'(Operators), write(Stream, Term), '$lgt_remove_operators'(Operators), '$lgt_add_operators'(Saved) ), Error, '$lgt_iso_stream_input_output_error_handler'(Operators, Saved, Error) ). % '$lgt_iso_write'(@term, @list) % % wraps write/1 call with the necessary operator settings '$lgt_iso_write'(Term, Operators) :- catch( ( '$lgt_save_operators'(Operators, Saved), '$lgt_add_operators'(Operators), write(Term), '$lgt_remove_operators'(Operators), '$lgt_add_operators'(Saved) ), Error, '$lgt_iso_stream_input_output_error_handler'(Operators, Saved, Error) ). % '$lgt_iso_writeq'(@stream_or_alias, @term, @list) % % wraps writeq/2 call with the necessary operator settings '$lgt_iso_writeq'(Stream, Term, Operators) :- catch( ( '$lgt_save_operators'(Operators, Saved), '$lgt_add_operators'(Operators), writeq(Stream, Term), '$lgt_remove_operators'(Operators), '$lgt_add_operators'(Saved) ), Error, '$lgt_iso_stream_input_output_error_handler'(Operators, Saved, Error) ). % '$lgt_iso_writeq'(@term, @list) % % wraps writeq/1 call with the necessary operator settings '$lgt_iso_writeq'(Term, Operators) :- catch( ( '$lgt_save_operators'(Operators, Saved), '$lgt_add_operators'(Operators), writeq(Term), '$lgt_remove_operators'(Operators), '$lgt_add_operators'(Saved) ), Error, '$lgt_iso_stream_input_output_error_handler'(Operators, Saved, Error) ). % '$lgt_save_operators'(@list, -list) % % saves currently defined operators that might be % redefined when a list of operators is added '$lgt_save_operators'([], []). '$lgt_save_operators'([op(_, Specifier, Operator)| Operators], Saved) :- ( current_op(Priority, SCSpecifier, Operator), '$lgt_same_operator_class'(Specifier, SCSpecifier) -> Saved = [op(Priority, SCSpecifier, Operator)| Saved2] ; Saved = Saved2 ), '$lgt_save_operators'(Operators, Saved2). % '$lgt_add_operators'(@list) % % adds operators to the global operator table '$lgt_add_operators'([]). '$lgt_add_operators'([op(Priority, Specifier, Operator)| Operators]) :- op(Priority, Specifier, Operator), '$lgt_add_operators'(Operators). % '$lgt_remove_operators'(@list) % % removes operators from the global operator table '$lgt_remove_operators'([]). '$lgt_remove_operators'([op(_, Specifier, Operator)| Operators]) :- op(0, Specifier, Operator), '$lgt_remove_operators'(Operators). % '$lgt_iso_stream_input_output_error_handler'(@list, @list, @nonvar) % % restores operator table to its state before the call % to one of the '$lgt_iso_read...' that raised an error '$lgt_iso_stream_input_output_error_handler'(Operators, Saved, Error) :- '$lgt_remove_operators'(Operators), '$lgt_add_operators'(Saved), throw(Error). % '$lgt_simplify_goal'(+callable, -callable) % % simplify the body of a compiled clause by folding left unifications (usually % resulting from the compilation of grammar rules or from inlined calls to the % execution-context built-in methods) and by removing redundant calls to true/0 % (but we must be careful with control constructs that are opaque to cuts such % as call/1 and once/1) '$lgt_simplify_goal'(Goal, SGoal) :- '$lgt_flatten_conjunctions'(Goal, SGoal0), '$lgt_fold_left_unifications'(SGoal0, SGoal1), '$lgt_remove_redundant_calls'(SGoal1, SGoal). % '$lgt_flatten_conjunctions'(+callable, -callable) % % flattens conjunction of goals % % only standard or de facto standard control constructs are traversed to avoid % compiler performance penalties '$lgt_flatten_conjunctions'(Goal, Goal) :- var(Goal), !. '$lgt_flatten_conjunctions'('*->'(Goal1, Goal2), '*->'(SGoal1, SGoal2)) :- '$lgt_predicate_property'('*->'(_, _), built_in), !, '$lgt_flatten_conjunctions'(Goal1, SGoal1), '$lgt_flatten_conjunctions'(Goal2, SGoal2). '$lgt_flatten_conjunctions'((Goal1 -> Goal2), (SGoal1 -> SGoal2)) :- !, '$lgt_flatten_conjunctions'(Goal1, SGoal1), '$lgt_flatten_conjunctions'(Goal2, SGoal2). '$lgt_flatten_conjunctions'((Goal1; Goal2), (SGoal1; SGoal2)) :- !, '$lgt_flatten_conjunctions'(Goal1, SGoal1), '$lgt_flatten_conjunctions'(Goal2, SGoal2). '$lgt_flatten_conjunctions'((Goal1, Goal2), (Goal1, SGoal2)) :- var(Goal1), !, '$lgt_flatten_conjunctions'(Goal2, SGoal2). '$lgt_flatten_conjunctions'(((Goal1, Goal2), Goal3), Body) :- !, '$lgt_flatten_conjunctions'((Goal1, (Goal2, Goal3)), Body). '$lgt_flatten_conjunctions'((Goal1, Goal2), (Goal1, Goal3)) :- !, '$lgt_flatten_conjunctions'(Goal2, Goal3). '$lgt_flatten_conjunctions'(\+ Goal, \+ SGoal) :- !, '$lgt_flatten_conjunctions'(Goal, SGoal). '$lgt_flatten_conjunctions'(Goal, Goal). % '$lgt_fold_left_unifications'(+goal, -goal) % % folds left unifications; right unifications cannot be folded otherwise % we may loose steadfastness; the left unifications are typically produced % when compiling grammar rules to clauses % % as the clauses containing the goals being simplified will be asserted % between the compiler stages, we must be careful to not create cyclic % terms when performing term unification '$lgt_fold_left_unifications'(Goal, Goal) :- var(Goal), !. '$lgt_fold_left_unifications'((Term1 = Term2), true) :- unify_with_occurs_check(Term1, Term2), !. '$lgt_fold_left_unifications'(((Term1 = Term2), Goal), Folded) :- unify_with_occurs_check(Term1, Term2), !, '$lgt_fold_left_unifications'(Goal, Folded). '$lgt_fold_left_unifications'(Goal, Goal). % '$lgt_remove_redundant_calls'(+callable, -callable) % % removes redundant calls to true/0 from a compiled clause body (we must % be careful with control constructs that are opaque to cuts such as call/1 % and once/1) and folds pairs of consecutive variable unifications % (Var1 = Var2, Var2 = Var3) that are usually generated as a by-product of % the compilation of grammar rules; only standard or de facto standard control % constructs and meta-predicates are traversed '$lgt_remove_redundant_calls'(Goal, Goal) :- var(Goal), !. '$lgt_remove_redundant_calls'(catch(Goal0, Error, Goal2), SGoal) :- nonvar(Goal0), Goal0 = call(Goal1), !, '$lgt_remove_redundant_calls'(catch(Goal1, Error, Goal2), SGoal). '$lgt_remove_redundant_calls'(catch(Goal1, Error, Goal2), catch(SGoal1, Error, SGoal2)) :- !, '$lgt_remove_redundant_calls'(Goal1, SGoal1), '$lgt_remove_redundant_calls'(Goal2, SGoal2). '$lgt_remove_redundant_calls'(call(Goal), true) :- Goal == !, !. '$lgt_remove_redundant_calls'(call(Goal), SGoal) :- callable(Goal), functor(Goal, Functor, _), sub_atom(Functor, 0, _, _, '$lgt_'), % e.g. '$lgt_metacall' !, '$lgt_remove_redundant_calls'(Goal, SGoal). '$lgt_remove_redundant_calls'(call(Goal), call(SGoal)) :- !, '$lgt_remove_redundant_calls'(Goal, SGoal). '$lgt_remove_redundant_calls'(once(Goal), true) :- Goal == !, !. '$lgt_remove_redundant_calls'(once(Goal), once(SGoal)) :- !, '$lgt_remove_redundant_calls'(Goal, SGoal). '$lgt_remove_redundant_calls'(ignore(Goal), ignore(SGoal)) :- !, '$lgt_remove_redundant_calls'(Goal, SGoal). '$lgt_remove_redundant_calls'(bagof(Term, Goal, List), bagof(Term, SGoal, List)) :- !, '$lgt_remove_redundant_calls'(Goal, SGoal). '$lgt_remove_redundant_calls'(setof(Term, Goal, List), setof(Term, SGoal, List)) :- !, '$lgt_remove_redundant_calls'(Goal, SGoal). '$lgt_remove_redundant_calls'(findall(Term, Goal, List), findall(Term, SGoal, List)) :- !, '$lgt_remove_redundant_calls'(Goal, SGoal). '$lgt_remove_redundant_calls'(findall(Term, Goal, List, Tail), findall(Term, SGoal, List, Tail)) :- !, '$lgt_remove_redundant_calls'(Goal, SGoal). '$lgt_remove_redundant_calls'(forall(Goal1, Goal2), forall(SGoal1, SGoal2)) :- !, '$lgt_remove_redundant_calls'(Goal1, SGoal1), '$lgt_remove_redundant_calls'(Goal2, SGoal2). '$lgt_remove_redundant_calls'((IfThen; Else), (SIf -> SThen; SElse)) :- nonvar(IfThen), IfThen = (If -> Then), !, '$lgt_remove_redundant_calls'(If, SIf), '$lgt_remove_redundant_calls'(Then, SThen), '$lgt_remove_redundant_calls'(Else, SElse). '$lgt_remove_redundant_calls'((IfThen; Else), ('*->'(SIf, SThen); SElse)) :- nonvar(IfThen), IfThen = '*->'(If, Then), '$lgt_predicate_property'('*->'(_, _), built_in), !, '$lgt_remove_redundant_calls'(If, SIf), '$lgt_remove_redundant_calls'(Then, SThen), '$lgt_remove_redundant_calls'(Else, SElse). '$lgt_remove_redundant_calls'((Goal1; Goal2), (SGoal1; SGoal2)) :- !, '$lgt_remove_redundant_calls'(Goal1, SGoal10), '$lgt_fix_disjunction_left_side'(SGoal10, SGoal1), '$lgt_remove_redundant_calls'(Goal2, SGoal2). '$lgt_remove_redundant_calls'((Goal1 -> Goal2), (SGoal1 -> SGoal2)) :- !, '$lgt_remove_redundant_calls'(Goal1, SGoal1), '$lgt_remove_redundant_calls'(Goal2, SGoal2). '$lgt_remove_redundant_calls'('*->'(Goal1, Goal2), '*->'(SGoal1, SGoal2)) :- '$lgt_predicate_property'('*->'(_, _), built_in), !, '$lgt_remove_redundant_calls'(Goal1, SGoal1), '$lgt_remove_redundant_calls'(Goal2, SGoal2). '$lgt_remove_redundant_calls'((Goal1, Goal2), (Goal1, SGoal2)) :- var(Goal1), !, '$lgt_remove_redundant_calls'(Goal2, SGoal2). '$lgt_remove_redundant_calls'((Goal1, Goal2), (SGoal1, Goal2)) :- var(Goal2), !, '$lgt_remove_redundant_calls'(Goal1, SGoal1). '$lgt_remove_redundant_calls'((Var1 = Var2a, Var2b = Var3, Goal), SGoal) :- Var2a == Var2b, '$lgt_remove_redundant_calls'((Var1 = Var3, Goal), SGoal), !. '$lgt_remove_redundant_calls'((Var1 = Var2a, Var2b = Var3), (Var1 = Var3)) :- Var2a == Var2b, !. '$lgt_remove_redundant_calls'((Var1 = Var2, Goal), (Var1 = Var2, SGoal)) :- !, '$lgt_remove_redundant_calls'(Goal, SGoal). '$lgt_remove_redundant_calls'((true, Goal), SGoal) :- !, '$lgt_remove_redundant_calls'(Goal, SGoal). '$lgt_remove_redundant_calls'((Goal, true), SGoal) :- % make sure that we don't arrive here while simplifying a (((If->Then),true);Goal) goal (or a % as (((If*->Then),true);Goal) goal) as removing the call to true/0 would wrongly convert the % disjunction into an if-then-else goal (or a soft-cut goal with an else part) Goal \= (_ -> _), ( '$lgt_predicate_property'('*->'(_, _), built_in) -> Goal \= '*->'(_, _) ; true ), !, '$lgt_remove_redundant_calls'(Goal, SGoal). '$lgt_remove_redundant_calls'((Goal1, Goal2), (SGoal1, SGoal2)) :- !, '$lgt_remove_redundant_calls'(Goal1, SGoal1), '$lgt_remove_redundant_calls'(Goal2, SGoal2). '$lgt_remove_redundant_calls'(\+ Goal, \+ SGoal) :- !, '$lgt_remove_redundant_calls'(Goal, SGoal). '$lgt_remove_redundant_calls'(Goal, Goal). % '$lgt_save_parameter_variables'(@object_identifier) % '$lgt_save_parameter_variables'(@category_identifier) % % saves the parameter variable names and positions found % in parametric entity identifiers for later processing '$lgt_save_parameter_variables'(Entity) :- atom(Entity), % non-parametric entity !. '$lgt_save_parameter_variables'(Entity) :- % all parameters must be variables Entity =.. [_| Parameters], '$lgt_member'(Parameter, Parameters), nonvar(Parameter), throw(type_error(variable, Parameter)). '$lgt_save_parameter_variables'(_) :- '$lgt_pp_term_source_data_'(_, VariableNames, _, _, _), '$lgt_parameter_variable_pairs'(VariableNames, 1, ParameterVariablePairs), ParameterVariablePairs \== [], !, % only save a non-empty list of parameter % variables to improve compiler performance assertz('$lgt_pp_parameter_variables_'(ParameterVariablePairs)). '$lgt_save_parameter_variables'(_). '$lgt_parameter_variable_pairs'([], _, []). '$lgt_parameter_variable_pairs'([VariableName=_| VariableNames], Position, [VariableName-Position| ParameterVariablePairs]) :- '$lgt_parameter_variable_name'(VariableName), !, NextPosition is Position + 1, '$lgt_parameter_variable_pairs'(VariableNames, NextPosition, ParameterVariablePairs). '$lgt_parameter_variable_pairs'([_| VariableNames], Position, ParameterVariablePairs) :- NextPosition is Position + 1, '$lgt_parameter_variable_pairs'(VariableNames, NextPosition, ParameterVariablePairs). % '$lgt_parameter_variable_name'(+atom) % % checks if a variable name is a parameter variable name (i.e., if the variable % name starts and ends with an underscore and have at least three characters) '$lgt_parameter_variable_name'(VariableName) :- sub_atom(VariableName, Before, 1, 0, '_'), Before >= 2, sub_atom(VariableName, 0, 1, _, '_'). % '$lgt_unify_parameter_variables'(+callable, +compilation_context) % % unifies any parameter variables found in a parametric entity term % with the corresponding entity parameters '$lgt_unify_parameter_variables'(Term, Ctx) :- '$lgt_pp_parameter_variables_'(ParameterVariables), '$lgt_pp_term_source_data_'(Term, VariableNames, _, _, _), VariableNames \== [], ( '$lgt_pp_entity_'(_, Entity, _) -> % compile-time; instantiate the Entity argument in the compilation context true ; % runtime < GObj = Obj ; % parametric object '$lgt_term_template'(Obj, GObj) ), '$lgt_add_referenced_object'(GObj, Ctx), ( '$lgt_pp_instantiated_class_'(_, _, _, _, _, _, _, _, _, _, _) -> '$lgt_construct_ic_functors'(GObj, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Rnm) ; '$lgt_pp_specialized_class_'(_, _, _, _, _, _, _, _, _, _, _) -> '$lgt_construct_ic_functors'(GObj, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Rnm) ; '$lgt_construct_prototype_functors'(GObj, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Rnm) ), % the object flags are only computed at the end of the entity compilation assertz('$lgt_pp_object_'(GObj, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Rnm, _)), % provide quick access to some common used data on the entity being compiled assertz('$lgt_pp_entity_'(object, Obj, Prefix)), % initialize the predicate mutex counter asserta('$lgt_pp_predicate_mutex_counter_'(0)). % '$lgt_compile_category_identifier'(@category_identifier, @compilation_context) % % from the category identifier construct the set of % functor prefixes used in the compiled code clauses '$lgt_compile_category_identifier'(Ctg, Ctx) :- ( atom(Ctg) -> GCtg = Ctg ; % parametric category '$lgt_term_template'(Ctg, GCtg) ), '$lgt_add_referenced_category'(GCtg, Ctx), '$lgt_construct_category_functors'(GCtg, Prefix, Dcl, Def, Rnm), % the category flags are only computed at the end of the entity compilation assertz('$lgt_pp_category_'(GCtg, Prefix, Dcl, Def, Rnm, _)), % provide quick access to some common used data on the entity being compiled assertz('$lgt_pp_entity_'(category, Ctg, Prefix)), % initialize the predicate mutex counter asserta('$lgt_pp_predicate_mutex_counter_'(0)). % '$lgt_compile_protocol_identifier'(@protocol_identifier, @compilation_context) % % from the protocol identifier construct the set of % functor prefixes used in the compiled code clauses '$lgt_compile_protocol_identifier'(Ptc, Ctx) :- '$lgt_add_referenced_protocol'(Ptc, Ctx), '$lgt_construct_protocol_functors'(Ptc, Prefix, Dcl, Rnm), % the protocol flags are only computed at the end of the entity compilation assertz('$lgt_pp_protocol_'(Ptc, Prefix, Dcl, Rnm, _)), % provide quick access to some common used data on the entity being compiled assertz('$lgt_pp_entity_'(protocol, Ptc, Prefix)), % initialize the predicate mutex counter; necessary in order to be able to % save synchronized predicate properties asserta('$lgt_pp_predicate_mutex_counter_'(0)). % '$lgt_compile_implements_protocol_relation('+list, @object_identifier, @compilation_context) % '$lgt_compile_implements_protocol_relation'(+list, @category_identifier, @compilation_context) % % compiles an "implements" relation between a category or an object and a list of protocols % % note that the clause order ensures that instantiation errors will be caught by the call to % the '$lgt_check_entity_reference'/4 predicate '$lgt_compile_implements_protocol_relation'([Ref| Refs], ObjOrCtg, Ctx) :- '$lgt_check_entity_reference'(protocol, Ref, Scope, Ptc), ( ObjOrCtg == Ptc -> throw(permission_error(implement, self, ObjOrCtg)) ; '$lgt_is_object'(Ptc) -> throw(type_error(protocol, Ptc)) ; '$lgt_is_category'(Ptc) -> throw(type_error(protocol, Ptc)) ; '$lgt_add_referenced_protocol'(Ptc, Ctx), assertz('$lgt_pp_runtime_clause_'('$lgt_implements_protocol_'(ObjOrCtg, Ptc, Scope))), '$lgt_construct_protocol_functors'(Ptc, Prefix, Dcl, _), assertz('$lgt_pp_implemented_protocol_'(Ptc, ObjOrCtg, Prefix, Dcl, Scope)), '$lgt_compile_implements_protocol_relation'(Refs, ObjOrCtg, Ctx) ). '$lgt_compile_implements_protocol_relation'([], _, _). % '$lgt_compile_imports_category_relation'(+list, @object_identifier, @compilation_context) % % compiles an "imports" relation between an object and a list of categories % % note that the clause order ensures that instantiation errors will be caught by the call to % the '$lgt_check_entity_reference'/4 predicate '$lgt_compile_imports_category_relation'([Ref| Refs], Obj, Ctx) :- '$lgt_check_entity_reference'(category, Ref, Scope, Ctg), ( '$lgt_term_template'(Obj, Ctg) -> throw(permission_error(import, self, Obj)) ; '$lgt_is_object'(Ctg) -> throw(type_error(category, Ctg)) ; '$lgt_is_protocol'(Ctg) -> throw(type_error(category, Ctg)) ; '$lgt_add_referenced_category'(Ctg, Ctx), assertz('$lgt_pp_runtime_clause_'('$lgt_imports_category_'(Obj, Ctg, Scope))), '$lgt_construct_category_functors'(Ctg, Prefix, Dcl, Def, _), assertz('$lgt_pp_imported_category_'(Ctg, Obj, Prefix, Dcl, Def, Scope)), '$lgt_compile_imports_category_relation'(Refs, Obj, Ctx) ). '$lgt_compile_imports_category_relation'([], _, _). % '$lgt_compile_instantiates_class_relation'(+list, @object_identifier, @compilation_context) % % compiles an "instantiates" relation between an instance and a list of classes % % note that the clause order ensures that instantiation errors will be caught by the call to % the '$lgt_check_entity_reference'/4 predicate '$lgt_compile_instantiates_class_relation'([Ref| Refs], Obj, Ctx) :- '$lgt_check_entity_reference'(object, Ref, Scope, Class), ( '$lgt_is_protocol'(Class) -> throw(type_error(object, Class)) ; '$lgt_is_category'(Class) -> throw(type_error(object, Class)) ; '$lgt_is_prototype'(Class) -> throw(domain_error(class, Class)) ; '$lgt_pp_extended_object_'(_, _, _, _, _, _, _, _, _, _, _) -> throw(permission_error(instantiate, class, Class)) ; '$lgt_add_referenced_object'(Class, Ctx), assertz('$lgt_pp_runtime_clause_'('$lgt_instantiates_class_'(Obj, Class, Scope))), '$lgt_construct_ic_functors'(Class, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, _), assertz('$lgt_pp_instantiated_class_'(Class, Obj, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Scope)), '$lgt_compile_instantiates_class_relation'(Refs, Obj, Ctx) ). '$lgt_compile_instantiates_class_relation'([], _, _). % '$lgt_compile_specializes_class_relation'(+list, @object_identifier, @compilation_context) % % compiles a "specializes" relation between a class and a list of superclasses % % note that the clause order ensures that instantiation errors will be caught by the call to % the '$lgt_check_entity_reference'/4 predicate '$lgt_compile_specializes_class_relation'([Ref| Refs], Class, Ctx) :- '$lgt_check_entity_reference'(object, Ref, Scope, Superclass), ( '$lgt_term_template'(Class, Superclass) -> throw(permission_error(specialize, self, Class)) ; '$lgt_is_protocol'(Superclass) -> throw(type_error(object, Superclass)) ; '$lgt_is_category'(Superclass) -> throw(type_error(object, Superclass)) ; '$lgt_is_prototype'(Superclass) -> throw(domain_error(class, Superclass)) ; '$lgt_pp_extended_object_'(_, _, _, _, _, _, _, _, _, _, _) -> throw(permission_error(specialize, class, Superclass)) ; '$lgt_add_referenced_object'(Superclass, Ctx), assertz('$lgt_pp_runtime_clause_'('$lgt_specializes_class_'(Class, Superclass, Scope))), '$lgt_construct_ic_functors'(Superclass, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, _), assertz('$lgt_pp_specialized_class_'(Superclass, Class, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Scope)), '$lgt_compile_specializes_class_relation'(Refs, Class, Ctx) ). '$lgt_compile_specializes_class_relation'([], _, _). % '$lgt_compile_extends_object_relation'(+list, @object_identifier, @compilation_context) % % compiles an "extends" relation between a prototype and a list of parents % % note that the clause order ensures that instantiation errors will be caught by the call to % the '$lgt_check_entity_reference'/4 predicate '$lgt_compile_extends_object_relation'([Ref| Refs], Obj, Ctx) :- '$lgt_check_entity_reference'(object, Ref, Scope, Parent), ( '$lgt_term_template'(Obj, Parent) -> throw(permission_error(extend, self, Obj)) ; '$lgt_is_protocol'(Parent) -> throw(type_error(object, Parent)) ; '$lgt_is_category'(Parent) -> throw(type_error(object, Parent)) ; '$lgt_is_class'(Parent) -> throw(domain_error(prototype, Parent)) ; '$lgt_pp_instantiated_class_'(_, _, _, _, _, _, _, _, _, _, _) -> throw(permission_error(extend, prototype, Parent)) ; '$lgt_pp_specialized_class_'(_, _, _, _, _, _, _, _, _, _, _) -> throw(permission_error(extend, prototype, Parent)) ; '$lgt_add_referenced_object'(Parent, Ctx), assertz('$lgt_pp_runtime_clause_'('$lgt_extends_object_'(Obj, Parent, Scope))), '$lgt_construct_prototype_functors'(Parent, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, _), assertz('$lgt_pp_extended_object_'(Parent, Obj, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Scope)), '$lgt_compile_extends_object_relation'(Refs, Obj, Ctx) ). '$lgt_compile_extends_object_relation'([], _, _). % '$lgt_compile_extends_protocol_relation'(+list, @protocol_identifier, @compilation_context) % % compiles an "extends" relation between a protocol and a list of protocols % % note that the clause order ensures that instantiation errors will be caught by the call to % the '$lgt_check_entity_reference'/4 predicate '$lgt_compile_extends_protocol_relation'([Ref| Refs], Ptc, Ctx) :- '$lgt_check_entity_reference'(protocol, Ref, Scope, ExtPtc), ( Ptc == ExtPtc -> throw(permission_error(extend, self, Ptc)) ; '$lgt_is_object'(ExtPtc) -> throw(type_error(protocol, ExtPtc)) ; '$lgt_is_category'(ExtPtc) -> throw(type_error(protocol, ExtPtc)) ; '$lgt_add_referenced_protocol'(ExtPtc, Ctx), assertz('$lgt_pp_runtime_clause_'('$lgt_extends_protocol_'(Ptc, ExtPtc, Scope))), '$lgt_construct_protocol_functors'(ExtPtc, Prefix, Dcl, _), assertz('$lgt_pp_extended_protocol_'(ExtPtc, Ptc, Prefix, Dcl, Scope)), '$lgt_compile_extends_protocol_relation'(Refs, Ptc, Ctx) ). '$lgt_compile_extends_protocol_relation'([], _, _). % '$lgt_compile_extends_category_relation'(+list, @category_identifier, @compilation_context) % % compiles an "extends" relation between a category and a list of categories % % note that the clause order ensures that instantiation errors will be caught by the call to % the '$lgt_check_entity_reference'/4 predicate '$lgt_compile_extends_category_relation'([Ref| Refs], Ctg, Ctx) :- '$lgt_check_entity_reference'(category, Ref, Scope, ExtCtg), ( '$lgt_term_template'(Ctg, ExtCtg) -> throw(permission_error(extend, self, Ctg)) ; '$lgt_is_object'(ExtCtg) -> throw(type_error(category, ExtCtg)) ; '$lgt_is_protocol'(ExtCtg) -> throw(type_error(category, ExtCtg)) ; '$lgt_add_referenced_category'(ExtCtg, Ctx), assertz('$lgt_pp_runtime_clause_'('$lgt_extends_category_'(Ctg, ExtCtg, Scope))), '$lgt_construct_category_functors'(ExtCtg, Prefix, Dcl, Def, _), assertz('$lgt_pp_extended_category_'(ExtCtg, Ctg, Prefix, Dcl, Def, Scope)), '$lgt_compile_extends_category_relation'(Refs, Ctg, Ctx) ). '$lgt_compile_extends_category_relation'([], _, _). % '$lgt_compile_complements_object_relation'(+list, @category_identifier, @compilation_context) % % compiles a "complements" relation between a category and a list of objects % % note that the clause order ensures that instantiation errors will be caught by the call to % the '$lgt_check_entity_reference'/4 predicate '$lgt_compile_complements_object_relation'(Objs, Ctg, Ctx) :- '$lgt_pp_category_'(Ctg, _, Dcl, Def, Rnm, _), '$lgt_compile_complements_object_relation'(Objs, Ctg, Dcl, Def, Rnm, Ctx). '$lgt_compile_complements_object_relation'([Obj| _], Ctg, _, _, _, _) :- '$lgt_check'(object_identifier, Obj), ( '$lgt_term_template'(Obj, Ctg) -> throw(permission_error(complement, self, Ctg)) ; '$lgt_is_protocol'(Obj) -> throw(type_error(object, Obj)) ; '$lgt_is_category'(Obj) -> throw(type_error(object, Obj)) ; fail ). '$lgt_compile_complements_object_relation'([Obj| _], Ctg, _, _, _, Ctx) :- '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(general, warning), ( '$lgt_current_object_'(Obj, _, _, _, _, _, _, _, _, _, Flags) -> % loaded object true ; '$lgt_pp_runtime_clause_'('$lgt_current_object_'(Obj, _, _, _, _, _, _, _, _, _, Flags)) % object being redefined in the same file as the complementing category; % possible but unlikely in practice (except, maybe, in classroom examples) ), Flags /\ 64 =\= 64, Flags /\ 32 =\= 32, % object compiled with complementing categories support disabled '$lgt_source_file_context'(File, Lines), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'(warning(general), complementing_category_ignored(File, Lines, Ctg, Obj)), fail. '$lgt_compile_complements_object_relation'([Obj| Objs], Ctg, Dcl, Def, Rnm, Ctx) :- '$lgt_add_referenced_object'(Obj, Ctx), % ensure that a new complementing category will take preference over % any previously loaded complementing category for the same object '$lgt_comp_ctx_lines'(Ctx, Lines), asserta('$lgt_pp_file_initialization_'(asserta('$lgt_complemented_object_'(Obj, Ctg, Dcl, Def, Rnm)), Lines)), assertz('$lgt_pp_complemented_object_'(Obj, Ctg, Dcl, Def, Rnm)), '$lgt_compile_complements_object_relation'(Objs, Ctg, Dcl, Def, Rnm, Ctx). '$lgt_compile_complements_object_relation'([], _, _, _, _, _). % '$lgt_is_prototype'(+entity_identifier) % % true if the argument is a defined prototype or a prototype being compiled '$lgt_is_prototype'(Obj) :- ( '$lgt_current_object_'(Obj, _, _, _, _, _, _, _, _, _, _) -> % existing object; first, check that is not being compiled as a different kind of entity \+ '$lgt_pp_runtime_clause_'('$lgt_current_protocol_'(Obj, _, _, _, _)), \+ '$lgt_pp_runtime_clause_'('$lgt_current_category_'(Obj, _, _, _, _, _)), % second, check that it's a prototype \+ '$lgt_instantiates_class_'(Obj, _, _), \+ '$lgt_instantiates_class_'(_, Obj, _), \+ '$lgt_specializes_class_'(Obj, _, _), \+ '$lgt_specializes_class_'(_, Obj, _) ; '$lgt_pp_runtime_clause_'('$lgt_current_object_'(Obj, _, _, _, _, _, _, _, _, _, _)) -> % object defined earlier in the same file we're compiling; check that it's a prototype \+ '$lgt_pp_runtime_clause_'('$lgt_instantiates_class_'(Obj, _, _)), \+ '$lgt_pp_runtime_clause_'('$lgt_instantiates_class_'(_, Obj, _)), \+ '$lgt_pp_runtime_clause_'('$lgt_specializes_class_'(Obj, _, _)), \+ '$lgt_pp_runtime_clause_'('$lgt_specializes_class_'(_, Obj, _)) ; fail ). % '$lgt_is_class'(+entity_identifier) % % true if the argument is a defined class or a class being compiled '$lgt_is_class'(Obj) :- ( '$lgt_current_object_'(Obj, _, _, _, _, _, _, _, _, _, _) -> % existing object; first, check that is not being compiled as a different kind of entity \+ '$lgt_pp_runtime_clause_'('$lgt_current_protocol_'(Obj, _, _, _, _)), \+ '$lgt_pp_runtime_clause_'('$lgt_current_category_'(Obj, _, _, _, _, _)), % second, check that it's an instance or a class ( '$lgt_instantiates_class_'(Obj, _, _) ; '$lgt_instantiates_class_'(_, Obj, _) ; '$lgt_specializes_class_'(Obj, _, _) ; '$lgt_specializes_class_'(_, Obj, _) ), ! ; '$lgt_pp_runtime_clause_'('$lgt_current_object_'(Obj, _, _, _, _, _, _, _, _, _, _)) -> % object defined earlier in the same file we're compiling; check that it's an instance or a class ( '$lgt_pp_runtime_clause_'('$lgt_instantiates_class_'(Obj, _, _)) ; '$lgt_pp_runtime_clause_'('$lgt_instantiates_class_'(_, Obj, _)) ; '$lgt_pp_runtime_clause_'('$lgt_specializes_class_'(Obj, _, _)) ; '$lgt_pp_runtime_clause_'('$lgt_specializes_class_'(_, Obj, _)) ), ! ; fail ). % '$lgt_is_object'(+entity_identifier) % % true if the argument is a defined object or an object being compiled '$lgt_is_object'(Obj) :- ( '$lgt_current_object_'(Obj, _, _, _, _, _, _, _, _, _, _) -> % existing object; check that is not being compiled as a different kind of entity \+ '$lgt_pp_runtime_clause_'('$lgt_current_protocol_'(Obj, _, _, _, _)), \+ '$lgt_pp_runtime_clause_'('$lgt_current_category_'(Obj, _, _, _, _, _)) ; '$lgt_pp_object_'(Obj, _, _, _, _, _, _, _, _, _, _) -> % object being compiled true ; '$lgt_pp_runtime_clause_'('$lgt_current_object_'(Obj, _, _, _, _, _, _, _, _, _, _)) -> % object defined earlier in the same file we're compiling true ; fail ). % '$lgt_is_protocol'(+entity_identifier) % % true if the argument is a defined protocol or a protocol being compiled '$lgt_is_protocol'(Ptc) :- ( '$lgt_current_protocol_'(Ptc, _, _, _, _) -> % existing protocol; check that is not being compiled as a different kind of entity \+ '$lgt_pp_runtime_clause_'('$lgt_current_object_'(Ptc, _, _, _, _, _, _, _, _, _, _)), \+ '$lgt_pp_runtime_clause_'('$lgt_current_category_'(Ptc, _, _, _, _, _)) ; '$lgt_pp_protocol_'(Ptc, _, _, _, _) -> % protocol being compiled true ; '$lgt_pp_runtime_clause_'('$lgt_current_protocol_'(Ptc, _, _, _, _)) -> % protocol defined earlier in the same file we're compiling true ; fail ). % '$lgt_is_category'(+entity_identifier) % % true if the argument is a defined category or a category being compiled '$lgt_is_category'(Ctg) :- ( '$lgt_current_category_'(Ctg, _, _, _, _, _) -> % existing category; check that is not being compiled as a different kind of entity \+ '$lgt_pp_runtime_clause_'('$lgt_current_object_'(Ctg, _, _, _, _, _, _, _, _, _, _)), \+ '$lgt_pp_runtime_clause_'('$lgt_current_protocol_'(Ctg, _, _, _, _)) ; '$lgt_pp_category_'(Ctg, _, _, _, _, _) -> % category being compiled true ; '$lgt_pp_runtime_clause_'('$lgt_current_category_'(Ctg, _, _, _, _, _)) -> % category defined earlier in the same file we're compiling true ; fail ). % '$lgt_inline_calls'(+atom) % % inline calls in linking clauses to Prolog module, built-in, and % foreign predicates when compiling source files in optimal mode % % predicate definitions are only inlined when the clause body does % not contain anonymous variables, which would break the predicate % semantics (compared with the non-inlined definition) when calling % the predicate from a bagof/3 or setof/3 goals '$lgt_inline_calls'(protocol). '$lgt_inline_calls'(category) :- '$lgt_pp_category_'(_, _, _, Def, _, _), '$lgt_inline_calls_def'(Def). '$lgt_inline_calls'(object) :- '$lgt_pp_object_'(_, _, _, Def, _, _, _, _, _, _, _), '$lgt_inline_calls_def'(Def). '$lgt_inline_calls_def'(Def) :- '$lgt_compiler_flag'(optimize, on), \+ '$lgt_pp_dynamic_', % static entity '$lgt_pp_number_of_clauses_rules_'(Functor, Arity, 1, _), % predicate with a single clause functor(Head, Functor, Arity), \+ '$lgt_pp_dynamic_'(Head, _, _, _), \+ '$lgt_pp_multifile_'(Head, _, _, _), \+ '$lgt_pp_synchronized_'(Head, _, _, _), % static, non-multifile, and no synchronization wrapper '$lgt_pp_defines_predicate_'(Head, _, ExCtx, THead, _, user), % source file user-defined predicate '$lgt_pp_final_entity_term_'((THead :- TBody), _), Head =.. [_| HeadArguments], term_variables(HeadArguments, HeadVariables), HeadArguments == HeadVariables, % all head arguments are variables \+ '$lgt_variable_aliasing'(Head), % don't inline predicate definitions with variable aliasing in the clause % head as this can result in optimization bugs when compiling predicate % calls due to compile-time variable bindings propagating to previous goals % in the same clause body '$lgt_inlining_candidate'(TBody, Functor/Arity), % valid candidate for inlining term_variables(THead, THeadVariables), term_variables(TBody, TBodyVariables), forall( '$lgt_member'(TBodyVariable, TBodyVariables), '$lgt_member_var'(TBodyVariable, THeadVariables) ), % no anonymous variables in the body as this would change % semantics for calls from bagof/3 and setof/3 goals DefClauseOld =.. [Def, Head, _, _], retractall('$lgt_pp_def_'(DefClauseOld)), DefClauseNew =.. [Def, Head, ExCtx, TBody], asserta('$lgt_pp_def_'(DefClauseNew)), assertz('$lgt_pp_inline_predicate_'(Functor/Arity)), % next candidate predicate fail. '$lgt_inline_calls_def'(_). '$lgt_inlining_candidate'(':'(Module, Body), _) :- % call to a Prolog module predicate !, atom(Module), callable(Body). '$lgt_inlining_candidate'(TBody, _) :- '$lgt_control_construct'(TBody), % don't inline control constructs !, fail. '$lgt_inlining_candidate'(TBody, _) :- '$lgt_logtalk_meta_predicate'(TBody, _, _), % don't inline Logtalk built-in meta-predicates !, fail. '$lgt_inlining_candidate'(TBody, _) :- '$lgt_predicate_property'(TBody, built_in), % Prolog built-in predicate !. '$lgt_inlining_candidate'(TBody, _) :- % not all backend Prolog systems support a "foreign" predicate property catch('$lgt_predicate_property'(TBody, foreign), _, fail), % Prolog foreign predicate !. '$lgt_inlining_candidate'(TBody, Functor/Arity) :- functor(TBody, TFunctor, TArity), '$lgt_pp_referenced_object_message_'(Object, TFunctor/TArity, _, Functor/Arity, _, _), Object == user, % message to the "user" pseudo-object !. '$lgt_inlining_candidate'(TBody, _) :- '$lgt_pp_defines_predicate_'(_, _, _, TBody, _, user), % call to a local user-defined predicate !. % '$lgt_logtalk_control_construct'(@callable) % % table of Logtalk own control constructs % % when these control constructs are used as closures, the additional % arguments must be appended to the arguments of the goal argument of % the control construct, not as additional arguments of the control % construct itself '$lgt_logtalk_control_construct'(_ :: _). '$lgt_logtalk_control_construct'(:: _). '$lgt_logtalk_control_construct'(^^ _). '$lgt_logtalk_control_construct'(_ << _). '$lgt_logtalk_control_construct'({_}). '$lgt_logtalk_control_construct'([_]). % lambda expressions '$lgt_logtalk_control_construct'(_ >> _). '$lgt_logtalk_control_construct'(_ / _). % '$lgt_control_construct'(?callable) % % partial table of control constructs; mainly used to help decide % if a predicate definition should be compiled inline '$lgt_control_construct'((_ , _)). '$lgt_control_construct'((_ ; _)). '$lgt_control_construct'((_ -> _)). '$lgt_control_construct'(\+ _). '$lgt_control_construct'(^^ _). '$lgt_control_construct'(_ :: _). '$lgt_control_construct'(:: _). '$lgt_control_construct'(_ / _). '$lgt_control_construct'(_ >> _). '$lgt_control_construct'(_ << _). '$lgt_control_construct'({_}). '$lgt_control_construct'(':'(_, _)). '$lgt_control_construct'(throw(_)). '$lgt_control_construct'('*->'(_, _)) :- '$lgt_prolog_built_in_predicate'('*->'(_, _)). % '$lgt_cut_transparent_control_construct'(?callable) % % table of cut-transparent control constructs; used during % compilation to check if call/1-N wrappers need to be keep % for preserving source code semantics when the goal/closure % argument is bound '$lgt_cut_transparent_control_construct'(!). '$lgt_cut_transparent_control_construct'((_ , _)). '$lgt_cut_transparent_control_construct'((_ ; _)). '$lgt_cut_transparent_control_construct'((_ -> _)). '$lgt_cut_transparent_control_construct'('*->'(_, _)) :- '$lgt_prolog_built_in_predicate'('*->'(_, _)). % '$lgt_report_lint_issues'(+atom, @entity_identifier) % % reports detected lint issues found while compiling an entity % (note that some lint issues are reported during compilation) '$lgt_report_lint_issues'(Type, Entity) :- '$lgt_report_missing_directives'(Type, Entity), '$lgt_report_non_portable_calls'(Type, Entity), '$lgt_report_missing_functions'(Type, Entity), '$lgt_report_predicates_called_as_non_terminals'(Type, Entity), '$lgt_report_non_tail_recursive_predicates'(Type, Entity), '$lgt_report_unknown_entities'(Type, Entity), '$lgt_report_unknown_messages'(Type, Entity), '$lgt_report_naming_issues'(Type, Entity). % '$lgt_source_file_context'(-atom, -pair(integer), -atom, -entity_identifier) % % returns file, lines, and entity source context for the last term read; % it fails if the last attempt to read a term resulted in a syntax error '$lgt_source_file_context'(File, Lines, Type, Entity) :- '$lgt_pp_term_source_data_'(_, _, _, File, Lines), '$lgt_pp_entity_'(Type, Entity, _). % '$lgt_source_file_context'(-atom, -pair(integer)) % % returns file and lines source context for the last term read; % it fails if the last attempt to read a term resulted in a syntax error '$lgt_source_file_context'(File, Lines) :- '$lgt_pp_term_source_data_'(_, _, _, File, Lines). % '$lgt_source_file_context'(@compilation_context, -atom, -pair(integer), -atom, -entity_identifier) % % returns file, lines, and entity source context for the last term read; % it fails if the last attempt to read a term resulted in a syntax error; % in the context of runtime compilation, returns dummy file and line values '$lgt_source_file_context'(Ctx, File, Lines, Type, Entity) :- '$lgt_source_file_context'(Ctx, File, Lines), '$lgt_pp_entity_'(Type, Entity, _). % '$lgt_source_file_context'(@compilation_context, -atom, -pair(integer)) % % in the context of compiling a file, returns file and lines source context % for the last term read and fails if the last attempt to read a term % resulted in a syntax error; in the context of runtime compilation, returns % dummy file and line values '$lgt_source_file_context'(Ctx, File, Lines) :- ( '$lgt_comp_ctx_mode'(Ctx, runtime) -> File = nil, Lines = '-'(-1, -1) ; '$lgt_pp_term_source_data_'(_, _, _, File, Lines) -> true ; % e.g. when compiling auxiliary clauses at runtime File = nil, Lines = 0-0 ). % '$lgt_report_unknown_entities'(+atom, @entity_identifier, +atom) % % reports any unknown referenced entities found while compiling an entity '$lgt_report_unknown_entities'(_, _) :- '$lgt_compiler_flag'(unknown_entities, silent), !. '$lgt_report_unknown_entities'(protocol, Entity) :- % protocols can only reference other protocols !, '$lgt_report_unknown_protocols'(protocol, Entity). '$lgt_report_unknown_entities'(Type, Entity) :- '$lgt_report_unknown_objects'(Type, Entity), '$lgt_report_unknown_protocols'(Type, Entity), '$lgt_report_unknown_categories'(Type, Entity), '$lgt_report_unknown_modules'(Type, Entity). % '$lgt_report_unknown_objects'(+atom, @entity_identifier) % % reports any references to unknown objects found while compiling an entity '$lgt_report_unknown_objects'(Type, Entity) :- '$lgt_pp_referenced_object_'(Object, File, Lines), % not a currently loaded object \+ '$lgt_current_object_'(Object, _, _, _, _, _, _, _, _, _, _), % not the object being compiled (self reference) \+ '$lgt_pp_object_'(Object, _, _, _, _, _, _, _, _, _, _), % not an object defined earlier in the source file being compiled \+ '$lgt_pp_runtime_clause_'('$lgt_current_object_'(Object, _, _, _, _, _, _, _, _, _, _)), '$lgt_increment_compiling_warnings_counter', ( atom(Object), '$lgt_prolog_feature'(modules, supported), current_module(Object) -> '$lgt_print_message'(warning(unknown_entities), module_used_as_object(File, Lines, Type, Entity, Object)) ; '$lgt_print_message'(warning(unknown_entities), reference_to_unknown_object(File, Lines, Type, Entity, Object)) ), fail. '$lgt_report_unknown_objects'(_, _). % '$lgt_report_unknown_protocols'(+atom, @entity_identifier) % % reports any references to unknown protocols found while compiling an entity '$lgt_report_unknown_protocols'(Type, Entity) :- '$lgt_pp_referenced_protocol_'(Protocol, File, Lines), % not a currently loaded protocol \+ '$lgt_current_protocol_'(Protocol, _, _, _, _), % not the protocol being compiled (self reference) \+ '$lgt_pp_protocol_'(Protocol, _, _, _, _), % not a protocol defined earlier in the source file being compiled \+ '$lgt_pp_runtime_clause_'('$lgt_current_protocol_'(Protocol, _, _, _, _)), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(unknown_entities), reference_to_unknown_protocol(File, Lines, Type, Entity, Protocol) ), fail. '$lgt_report_unknown_protocols'(_, _). % '$lgt_report_unknown_categories'(+atom, @entity_identifier) % % reports any references to unknown categories found while compiling an entity '$lgt_report_unknown_categories'(Type, Entity) :- '$lgt_pp_referenced_category_'(Category, File, Lines), % not a currently loaded category \+ '$lgt_current_category_'(Category, _, _, _, _, _), % not the category being compiled (self reference) \+ '$lgt_pp_category_'(Category, _, _, _, _, _), % not a category defined earlier in the source file being compiled \+ '$lgt_pp_runtime_clause_'('$lgt_current_category_'(Category, _, _, _, _, _)), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(unknown_entities), reference_to_unknown_category(File, Lines, Type, Entity, Category) ), fail. '$lgt_report_unknown_categories'(_, _). % '$lgt_report_unknown_modules'(+atom, @entity_identifier) % % reports any references to unknown modules found while compiling an entity '$lgt_report_unknown_modules'(Type, Entity) :- '$lgt_prolog_feature'(modules, supported), '$lgt_pp_referenced_module_'(Module, File, Lines), % not a currently loaded module \+ current_module(Module), % not the module being compiled as an object (self reference) \+ '$lgt_pp_module_'(Module), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(unknown_entities), reference_to_unknown_module(File, Lines, Type, Entity, Module) ), fail. '$lgt_report_unknown_modules'(_, _). % '$lgt_report_unknown_messages'(+atom, @entity_identifier) % % reports any unknown messages for loaded objects (including built-in objects) and % calls to unknown predicates for loaded modules found while compiling an entity '$lgt_report_unknown_messages'(_, _) :- '$lgt_compiler_flag'(unknown_predicates, silent), !. '$lgt_report_unknown_messages'(Type, Entity) :- '$lgt_pp_uses_predicate_'(Obj, Original, _, _, File, Lines), nonvar(Obj), functor(Original, Functor, Arity), '$lgt_check_predicate_availability'(uses, Obj, Original, Original, Functor, Arity, Type, Entity, File, Lines), fail. '$lgt_report_unknown_messages'(Type, Entity) :- '$lgt_pp_uses_non_terminal_'(Obj, Original, _, Pred, _, _, File, Lines), nonvar(Obj), functor(Pred, Functor, Arity), '$lgt_check_predicate_availability'(uses, Obj, Original, Pred, Functor, Arity, Type, Entity, File, Lines), fail. '$lgt_report_unknown_messages'(Type, Entity) :- '$lgt_prolog_feature'(modules, supported), '$lgt_pp_use_module_predicate_'(Module, Original, _, _, File, Lines), nonvar(Module), functor(Original, Functor, Arity), '$lgt_check_predicate_availability'(use_module, Module, Original, Original, Functor, Arity, Type, Entity, File, Lines), fail. '$lgt_report_unknown_messages'(Type, Entity) :- '$lgt_prolog_feature'(modules, supported), '$lgt_pp_use_module_non_terminal_'(Module, Original, _, Pred, _, _, File, Lines), nonvar(Module), functor(Pred, Functor, Arity), '$lgt_check_predicate_availability'(use_module, Module, Original, Pred, Functor, Arity, Type, Entity, File, Lines), fail. '$lgt_report_unknown_messages'(_, _). % auxiliary predicate for checking predicate availability for predicates % listed in uses/2 and use_module/2 directives but only when the objects % and modules are loaded '$lgt_check_predicate_availability'(uses, Obj, Original, Pred, Functor, Arity, Type, Entity, File, Lines) :- ( \+ current_object(Obj) -> true ; Obj::current_predicate(Functor/Arity) -> true ; Obj == user, ( '$lgt_predicate_property'(Pred, built_in) ; catch('$lgt_predicate_property'(Pred, foreign), _, fail) ; catch('$lgt_predicate_property'(Pred, imported_from(_)), _, fail) ; '$lgt_pp_directive_'(dynamic(Functor/Arity)) ; '$lgt_pp_directive_'(multifile(Functor/Arity)) ) -> true ; '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(unknown_predicates), message_not_understood(File, Lines, Type, Entity, Obj, Original) ) ). '$lgt_check_predicate_availability'(use_module, Module, Original, Pred, Functor, Arity, Type, Entity, File, Lines) :- ( \+ current_module(Module) -> true ; '$lgt_current_module_predicate'(Module, Functor/Arity) -> true ; Module == user, ( '$lgt_predicate_property'(Pred, built_in) ; catch('$lgt_predicate_property'(Pred, foreign), _, fail) ; catch('$lgt_predicate_property'(Pred, imported_from(_)), _, fail) ; '$lgt_pp_directive_'(dynamic(Functor/Arity)) ; '$lgt_pp_directive_'(multifile(Functor/Arity)) ) -> true ; '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(unknown_predicates), unknown_module_predicate(File, Lines, Type, Entity, Module, Original) ) ). % '$lgt_report_naming_issues'(Type, Entity) % % reports names not following official coding guidelines '$lgt_report_naming_issues'(Type, Entity) :- ( '$lgt_compiler_flag'(naming, warning) -> '$lgt_report_entity_naming_issues'(Type, Entity), '$lgt_report_predicate_naming_issues'(Type, Entity) ; true ). '$lgt_report_entity_naming_issues'(Type, Entity) :- functor(Entity, Name, _), atom_chars(Name, Chars), ( '$lgt_camel_case_name'(Chars), Warning = camel_case_entity_name(File, Lines, Type, Entity) ; '$lgt_name_with_digits_in_the_middle'(Chars), Warning = entity_name_with_digits_in_the_middle(File, Lines, Type, Entity) ), ( '$lgt_pp_referenced_object_'(Entity, File, Lines) -> true ; '$lgt_pp_referenced_protocol_'(Entity, File, Lines) -> true ; '$lgt_pp_referenced_category_'(Entity, File, Lines) -> true ; '$lgt_pp_file_paths_flags_'(_, _, File, _, _), Lines = '-'(-1, -1) ), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'(warning(naming), Warning), fail. '$lgt_report_entity_naming_issues'(_, _). '$lgt_report_predicate_naming_issues'(Type, Entity) :- ( '$lgt_pp_public_'(Name, Arity, _, _) ; '$lgt_pp_protected_'(Name, Arity, _, _) ; '$lgt_pp_private_'(Name, Arity, _, _) ), % backtrack over all declared predicates \+ '$lgt_pp_non_terminal_'(Name, _, Arity), % not declared as non-terminals functor(Template, Name, Arity), \+ '$lgt_pp_defines_predicate_'(Template, _, _, _, _, _), % not defined atom_chars(Name, Chars), ( '$lgt_camel_case_name'(Chars), Warning = camel_case_predicate_name(File, Lines, Type, Entity, Name/Arity) ; '$lgt_name_with_digits_in_the_middle'(Chars), Warning = predicate_name_with_digits_in_the_middle(File, Lines, Type, Entity, Name/Arity) ), ( '$lgt_pp_predicate_declaration_location_'(Name, Arity, File, Lines) -> true ; '$lgt_source_file_context'(File, _), Lines = '-'(-1, -1) ), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'(warning(naming), Warning), fail. '$lgt_report_predicate_naming_issues'(Type, Entity) :- '$lgt_pp_non_terminal_'(Name, Arity, ExtArity), % declared non-terminal (in a scope directive) functor(Template, Name, ExtArity), \+ '$lgt_pp_defines_predicate_'(Template, _, _, _, _, _), % not defined atom_chars(Name, Chars), ( '$lgt_camel_case_name'(Chars), Warning = camel_case_non_terminal_name(File, Lines, Type, Entity, Name//Arity) ; '$lgt_name_with_digits_in_the_middle'(Chars), Warning = non_terminal_name_with_digits_in_the_middle(File, Lines, Type, Entity, Name//Arity) ), ( '$lgt_pp_predicate_declaration_location_'(Name, ExtArity, File, Lines) -> true ; '$lgt_source_file_context'(File, _), Lines = '-'(-1, -1) ), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'(warning(naming), Warning), fail. '$lgt_report_predicate_naming_issues'(Type, Entity) :- '$lgt_pp_defines_predicate_'(_, Name/Arity, _, _, _, user), \+ '$lgt_pp_defines_non_terminal_'(Name, _, Arity), \+ '$lgt_pp_public_'(Name, Arity, _, _), \+ '$lgt_pp_protected_'(Name, Arity, _, _), \+ '$lgt_pp_private_'(Name, Arity, _, _), \+ '$lgt_pp_non_terminal_'(Name, _, Arity), % user-defined local predicate atom_chars(Name, Chars), ( '$lgt_camel_case_name'(Chars), Warning = camel_case_predicate_name(File, Lines, Type, Entity, Name/Arity) ; '$lgt_name_with_digits_in_the_middle'(Chars), Warning = predicate_name_with_digits_in_the_middle(File, Lines, Type, Entity, Name/Arity) ), ( '$lgt_pp_predicate_definition_location_'(Name, Arity, File, Lines) -> true ; '$lgt_source_file_context'(File, _), Lines = '-'(-1, -1) ), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'(warning(naming), Warning), fail. '$lgt_report_predicate_naming_issues'(Type, Entity) :- '$lgt_pp_defines_non_terminal_'(Name, Arity, ExtArity), '$lgt_pp_defines_predicate_'(_, Name/ExtArity, _, _, _, user), \+ '$lgt_pp_public_'(Name, ExtArity, _, _), \+ '$lgt_pp_protected_'(Name, ExtArity, _, _), \+ '$lgt_pp_private_'(Name, ExtArity, _, _), \+ '$lgt_pp_non_terminal_'(Name, Arity, ExtArity), % user-defined local non-terminal atom_chars(Name, Chars), ( '$lgt_camel_case_name'(Chars), Warning = camel_case_non_terminal_name(File, Lines, Type, Entity, Name//Arity) ; '$lgt_name_with_digits_in_the_middle'(Chars), Warning = non_terminal_name_with_digits_in_the_middle(File, Lines, Type, Entity, Name//Arity) ), ( '$lgt_pp_predicate_definition_location_'(Name, ExtArity, File, Lines) -> true ; '$lgt_source_file_context'(File, _), Lines = '-'(-1, -1) ), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'(warning(naming), Warning), fail. '$lgt_report_predicate_naming_issues'(_, _). '$lgt_camel_case_name'(Chars) :- '$lgt_append'([_| _], [Char1, Char2| _], Chars), a @=< Char1, Char1 @=< z, 'A' @=< Char2, Char2 @=< 'Z', !. '$lgt_name_with_digits_in_the_middle'(Chars) :- '$lgt_append'([_| _], [Char1, Char2| _], Chars), '0' @=< Char1, Char1 @=< '9', ('0' @> Char2; Char2 @> '9'), !. % '$lgt_add_def_clause'(+callable, +atom, +integer, -callable, +compilation_context) % % adds a "def" clause (used to translate between user predicate names and internal names) % and returns the compiled clause head '$lgt_add_def_clause'(Head, Functor, Arity, THead, Ctx) :- functor(HeadTemplate, Functor, Arity), '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, Prefix, _, _, ExCtx, Mode, _, Lines, _), '$lgt_compile_predicate_indicator'(Prefix, Functor/Arity, TFunctor/TArity), functor(THeadTemplate, TFunctor, TArity), '$lgt_unify_head_thead_arguments'(HeadTemplate, THeadTemplate, ExCtxTemplate), ( '$lgt_pp_object_'(_, _, _, Def, _, _, _, _, _, _, _) -> true ; '$lgt_pp_category_'(_, _, _, Def, _, _) ), '$lgt_construct_def_clause'(Def, HeadTemplate, ExCtxTemplate, THeadTemplate, Clause), assertz('$lgt_pp_def_'(Clause)), % the following two calls have side effects, thus ... '$lgt_check_for_redefined_built_in'(Mode, HeadTemplate, ExCtxTemplate, THeadTemplate, Lines), '$lgt_remember_defined_predicate'(Mode, HeadTemplate, Functor/Arity, ExCtxTemplate, THeadTemplate), % ... we need to delay output unifications to after they succeed Head = HeadTemplate, ExCtx = ExCtxTemplate, THead = THeadTemplate. % '$lgt_add_ddef_clause'(+callable, +atom, +integer, -callable, +compilation_context) % % adds a "ddef" clause (used to translate between user predicate names and internal names) % and returns the compiled clause head '$lgt_add_ddef_clause'(Head, Functor, Arity, THead, Ctx) :- functor(HeadTemplate, Functor, Arity), '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, Prefix, _, _, ExCtx, Mode, _, Lines, _), '$lgt_compile_predicate_indicator'(Prefix, Functor/Arity, TFunctor/TArity), functor(THeadTemplate, TFunctor, TArity), '$lgt_unify_head_thead_arguments'(HeadTemplate, THeadTemplate, ExCtxTemplate), % only objects can define clauses for dynamic predicates '$lgt_pp_object_'(_, _, _, _, _, _, _, _, DDef, _, _), '$lgt_construct_def_clause'(DDef, HeadTemplate, ExCtxTemplate, THeadTemplate, Clause), assertz('$lgt_pp_ddef_'(Clause)), % the following two calls have side effects, thus ... '$lgt_check_for_redefined_built_in'(Mode, HeadTemplate, ExCtxTemplate, THeadTemplate, Lines), '$lgt_remember_defined_predicate'(Mode, HeadTemplate, Functor/Arity, ExCtxTemplate, THeadTemplate), % ... we need to delay output unifications to after they succeed Head = HeadTemplate, ExCtx = ExCtxTemplate, THead = THeadTemplate. % '$lgt_construct_def_clause'(+callable, +callable, +execution_context, +callable, -clause) % % constructs a "def" or "ddef" clause (used to translate between user predicate names and internal names) '$lgt_construct_def_clause'(Def, Head, ExCtx, THead, Clause) :- ( '$lgt_pp_synchronized_'(Head, Mutex, _, _) -> '$lgt_wrap_compiled_head'(Head, THead, ExCtx, Call), ( '$lgt_prolog_feature'(threads, supported) -> Clause =.. [Def, Head, ExCtx, with_mutex(Mutex,Call)] ; % in single-threaded systems, with_mutex/2 is equivalent to once/1 Clause =.. [Def, Head, ExCtx, once(Call)] ) ; '$lgt_pp_coinductive_head_'(Head, ExCtx, TCHead) -> '$lgt_wrap_compiled_head'(Head, TCHead, ExCtx, Call), Clause =.. [Def, Head, ExCtx, Call] ; '$lgt_wrap_compiled_head'(Head, THead, ExCtx, Call), Clause =.. [Def, Head, ExCtx, Call] ). % predicates for wrapping/unwrapping compiled predicate heads to deal with % compilation in debug mode % % the wrapping when in compilation mode ensures that indirect predicate calls % (e.g., when sending a message) can also be intercepted by debug handlers '$lgt_wrap_compiled_head'(Head, THead, ExCtx, Call) :- ( '$lgt_compiler_flag'(debug, on) -> Call = '$lgt_debug'(goal(Head,THead), ExCtx) ; Call = THead ). '$lgt_unwrap_compiled_head'('$lgt_debug'(goal(_,THead), _), THead) :- !. '$lgt_unwrap_compiled_head'(THead, THead). % '$lgt_add_def_fail_clause'(@callable, @compilation_context) % % adds a "def clause" (used to translate a predicate call) where the % definition is simply fail due to the predicate being declared, static, % but undefined (as per closed-world assumption) '$lgt_add_def_fail_clause'(Head, Ctx) :- ( '$lgt_pp_object_'(_, _, _, Def, _, _, _, _, _, _, _) -> true ; '$lgt_pp_category_'(_, _, _, Def, _, _) ), Clause =.. [Def, Head, _, fail], assertz('$lgt_pp_def_'(Clause)), '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, _, _, _, _, Mode, _, Lines, _), '$lgt_check_for_redefined_built_in'(Mode, Head, _, fail, Lines). % '$lgt_check_for_redefined_built_in'(@compilation_mode, @callable, @execution_context, @callable, @pair) % % this predicate is called when adding a def/ddef clause after finding the first clause % for a predicate or when no clauses are defined for a declared predicate '$lgt_check_for_redefined_built_in'(runtime, _, _, _, _). '$lgt_check_for_redefined_built_in'(compile(_,_,_), Head, ExCtx, THead, Lines) :- '$lgt_logtalk_built_in_predicate'(Head, _), !, assertz('$lgt_pp_redefined_built_in_'(Head, ExCtx, THead)), retractall('$lgt_pp_non_portable_predicate_'(Head, _, _)), ( '$lgt_compiler_flag'(redefined_built_ins, warning) -> functor(Head, Functor, Arity), '$lgt_source_file_context'(File, _, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(redefined_built_ins), redefined_logtalk_built_in_predicate(File, Lines, Type, Entity, Functor/Arity) ) ; true ). '$lgt_check_for_redefined_built_in'(compile(_,_,_), Head, ExCtx, THead, Lines) :- '$lgt_prolog_built_in_predicate'(Head), !, assertz('$lgt_pp_redefined_built_in_'(Head, ExCtx, THead)), retractall('$lgt_pp_non_portable_predicate_'(Head, _, _)), ( '$lgt_compiler_flag'(redefined_built_ins, warning) -> functor(Head, Functor, Arity), '$lgt_source_file_context'(File, _, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(redefined_built_ins), redefined_prolog_built_in_predicate(File, Lines, Type, Entity, Functor/Arity) ) ; true ). '$lgt_check_for_redefined_built_in'(compile(_,_,_), _, _, _, _). % '$lgt_remember_defined_predicate'(@compilation_mode, @callable, +predicate_indicator, +execution_context, @callable) % % it's necessary to remember which predicates are defined in order to deal with % redefinition of built-in predicates, detect missing predicate directives, and % speed up compilation of other clauses for the same predicates '$lgt_remember_defined_predicate'(Mode, Head, PI, ExCtx, THead) :- ( Mode = compile(aux,_,_) -> assertz('$lgt_pp_defines_predicate_'(Head, PI, ExCtx, THead, Mode, aux)), retractall('$lgt_pp_previous_predicate_'(_, aux)), assertz('$lgt_pp_previous_predicate_'(Head, aux)) ; % compile(user,_,_) or runtime assertz('$lgt_pp_defines_predicate_'(Head, PI, ExCtx, THead, Mode, user)), retractall('$lgt_pp_previous_predicate_'(_, user)), assertz('$lgt_pp_previous_predicate_'(Head, user)) ). % '$lgt_report_variable_naming_issues'(+list, +atom, +compound) % % reports variable naming issues as per official coding guidelines '$lgt_report_variable_naming_issues'([], _, _) :- !. '$lgt_report_variable_naming_issues'(_, _, _) :- '$lgt_compiler_flag'(naming, silent), !. '$lgt_report_variable_naming_issues'(Names, File, Lines) :- '$lgt_member'(Name=_, Names), '$lgt_non_camel_case_name'(Name), ( '$lgt_pp_entity_'(Type, Entity, _) -> Warning = non_camel_case_variable_name(File, Lines, Type, Entity, Name) ; Warning = non_camel_case_variable_name(File, Lines, Name) ), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'(warning(naming), Warning), fail. '$lgt_report_variable_naming_issues'(Names, File, Lines) :- '$lgt_member'(Name=_, Names), atom_chars(Name, Chars), '$lgt_name_with_digits_in_the_middle'(Chars), ( '$lgt_pp_entity_'(Type, Entity, _) -> Warning = variable_name_with_digits_in_the_middle(File, Lines, Type, Entity, Name) ; Warning = variable_name_with_digits_in_the_middle(File, Lines, Name) ), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'(warning(naming), Warning), fail. '$lgt_report_variable_naming_issues'(Names, File, Lines) :- '$lgt_name_pair'(Names, Name, OtherName), '$lgt_similar_names'(Name, OtherName), ( '$lgt_pp_entity_'(Type, Entity, _) -> Warning = variable_names_differ_only_on_case(File, Lines, Type, Entity, Name, OtherName) ; Warning = variable_names_differ_only_on_case(File, Lines, Name, OtherName) ), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'(warning(naming), Warning), fail. '$lgt_report_variable_naming_issues'(_, _, _). '$lgt_non_camel_case_name'(Name) :- atom_chars(Name, Chars), '$lgt_append'(_, [Char1, '_', Char2| _], Chars), Char1 \== '_', Char2 \== '_', !. '$lgt_name_pair'([Name=_| Names], Name, OtherName) :- '$lgt_member'(OtherName=_, Names). '$lgt_name_pair'([_| Names], Name, OtherName) :- '$lgt_name_pair'(Names, Name, OtherName). '$lgt_similar_names'(Name, OtherName) :- atom_length(Name, Length), atom_length(OtherName, Length), % same length sub_atom(Name, _, 1, 0, Last), \+ ('0' @=< Last, Last @=< '9'), sub_atom(OtherName, _, 1, 0, OtherLast), \+ ('0' @=< OtherLast, OtherLast @=< '9'), % not ending with a digit '$lgt_to_lower_case'(Name, NameLowerCase), '$lgt_to_lower_case'(OtherName, OtherNameLowerCase), NameLowerCase == OtherNameLowerCase. '$lgt_to_lower_case'(Name, NameLowerCase) :- atom_codes(Name, Codes), '$lgt_to_lower_case_codes'(Codes, CodesLowerCase), atom_codes(NameLowerCase, CodesLowerCase). '$lgt_to_lower_case_codes'([], []). '$lgt_to_lower_case_codes'([Code| Codes], [LowerCode| LowerCodes]) :- 65 =< Code, Code @=< 90, !, LowerCode is 97 + Code - 65, '$lgt_to_lower_case_codes'(Codes, LowerCodes). '$lgt_to_lower_case_codes'([Code| Codes], [Code| LowerCodes]) :- '$lgt_to_lower_case_codes'(Codes, LowerCodes). % '$lgt_update_ddef_table'(+atom, @callable, @callable) % % retracts a dynamic "ddef clause" (used to translate a predicate call) % and updated the predicate lookup caches if there are no more (local) % clauses for the predicate otherwise does nothing; this is required in % order to allow definitions in ancestor entities to be found '$lgt_update_ddef_table'(DDef, Head, THead) :- '$lgt_term_template'(THead, GTHead), ( clause(GTHead, _) -> true ; DDefClause =.. [DDef, Head, _, _], retractall(DDefClause), '$lgt_clean_lookup_caches'(Head) ). % '$lgt_update_ddef_table_opt'(+callable) % % retracts a dynamic "ddef clause" (used to translate a predicate call) % and updates the predicate lookup caches if there are no more (local) % clauses for the predicate otherwise does nothing; this is required in % order to allow definitions in ancestor entities to be found when all % the overriding clauses in an intermediate object are retracted '$lgt_update_ddef_table_opt'(true). '$lgt_update_ddef_table_opt'(update(Head, THead, Clause)) :- ( clause(THead, _) -> true ; retractall(Clause), '$lgt_clean_lookup_caches'(Head) ). % '$lgt_generate_entity_code'(+atom, +compilation_context) % % generates code for the entity being compiled '$lgt_generate_entity_code'(protocol, _) :- '$lgt_generate_protocol_clauses', '$lgt_generate_protocol_directives'. '$lgt_generate_entity_code'(object, Ctx) :- '$lgt_generate_def_table_clauses'(Ctx), '$lgt_compile_predicate_calls'(compile_time), '$lgt_generate_object_clauses', '$lgt_generate_object_directives', '$lgt_generate_file_object_initialization_goal'. '$lgt_generate_entity_code'(category, Ctx) :- '$lgt_generate_def_table_clauses'(Ctx), '$lgt_compile_predicate_calls'(compile_time), '$lgt_generate_category_clauses', '$lgt_generate_category_directives', '$lgt_generate_file_category_initialization_goal'. '$lgt_generate_object_directives' :- '$lgt_generate_object_dynamic_directives', '$lgt_generate_object_discontiguous_directives'. '$lgt_generate_category_directives' :- '$lgt_generate_category_dynamic_directives', '$lgt_generate_category_discontiguous_directives'. '$lgt_generate_protocol_directives' :- ( '$lgt_pp_dynamic_' -> % add the necessary directives to allow abolishing the protocol '$lgt_pp_protocol_'(_, _, Dcl, Rnm, _), assertz('$lgt_pp_directive_'(dynamic(Dcl/4))), assertz('$lgt_pp_directive_'(dynamic(Dcl/5))), assertz('$lgt_pp_directive_'(dynamic(Rnm/3))) ; true ). '$lgt_generate_object_dynamic_directives' :- ( '$lgt_pp_dynamic_' -> % add the necessary directives to allow abolishing the object '$lgt_generate_dynamic_object_dynamic_directives' ; '$lgt_generate_static_object_dynamic_directives' ). '$lgt_generate_dynamic_object_dynamic_directives' :- '$lgt_pp_object_'(_, _, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Rnm, _), assertz('$lgt_pp_directive_'(dynamic(Dcl/4))), assertz('$lgt_pp_directive_'(dynamic(Dcl/6))), assertz('$lgt_pp_directive_'(dynamic(Def/3))), assertz('$lgt_pp_directive_'(dynamic(Def/5))), assertz('$lgt_pp_directive_'(dynamic(Super/5))), assertz('$lgt_pp_directive_'(dynamic(IDcl/6))), assertz('$lgt_pp_directive_'(dynamic(IDef/5))), ( '$lgt_compiler_flag'(dynamic_declarations, allow) -> assertz('$lgt_pp_directive_'(dynamic(DDcl/2))) ; true ), assertz('$lgt_pp_directive_'(dynamic(DDef/3))), assertz('$lgt_pp_directive_'(dynamic(Rnm/3))), '$lgt_generate_dynamic_entity_dynamic_predicate_directives'. '$lgt_generate_dynamic_entity_dynamic_predicate_directives' :- '$lgt_pp_def_'(Clause), % only local table; reject linking clauses Clause \= (_ :- _), arg(3, Clause, Call), '$lgt_unwrap_compiled_head'(Call, Pred), functor(Pred, Functor, Arity), assertz('$lgt_pp_directive_'(dynamic(Functor/Arity))), fail. '$lgt_generate_dynamic_entity_dynamic_predicate_directives' :- '$lgt_pp_ddef_'(Clause), % only local table; reject linking clauses Clause \= (_ :- _), arg(3, Clause, Call), '$lgt_unwrap_compiled_head'(Call, Pred), functor(Pred, Functor, Arity), assertz('$lgt_pp_directive_'(dynamic(Functor/Arity))), fail. '$lgt_generate_dynamic_entity_dynamic_predicate_directives'. '$lgt_generate_static_object_dynamic_directives' :- '$lgt_pp_object_'(_, Prefix, _, _, _, _, _, DDcl, DDef, _, _), ( '$lgt_compiler_flag'(dynamic_declarations, allow) -> assertz('$lgt_pp_directive_'(dynamic(DDcl/2))) ; true ), assertz('$lgt_pp_directive_'(dynamic(DDef/3))), '$lgt_pp_dynamic_'(Head, _, _, _), functor(Head, Functor, Arity), '$lgt_compile_predicate_indicator'(Prefix, Functor/Arity, TFunctor/TArity), assertz('$lgt_pp_directive_'(dynamic(TFunctor/TArity))), fail. '$lgt_generate_static_object_dynamic_directives'. '$lgt_generate_object_discontiguous_directives' :- '$lgt_pp_object_'(_, Prefix, _, _, _, _, _, _, _, _, _), '$lgt_pp_discontiguous_'(Head, _, _), functor(Head, Functor, Arity), '$lgt_compile_predicate_indicator'(Prefix, Functor/Arity, TFunctor/TArity), assertz('$lgt_pp_directive_'(discontiguous(TFunctor/TArity))), fail. '$lgt_generate_object_discontiguous_directives'. '$lgt_generate_category_dynamic_directives' :- ( '$lgt_pp_dynamic_' -> % add the necessary directives to allow abolishing the category '$lgt_pp_category_'(_, _, Dcl, Def, Rnm, _), assertz('$lgt_pp_directive_'(dynamic(Dcl/4))), assertz('$lgt_pp_directive_'(dynamic(Dcl/5))), assertz('$lgt_pp_directive_'(dynamic(Def/3))), assertz('$lgt_pp_directive_'(dynamic(Rnm/3))), '$lgt_generate_dynamic_entity_dynamic_predicate_directives' ; true ). '$lgt_generate_category_discontiguous_directives' :- '$lgt_pp_category_'(_, Prefix, _, _, _, _), '$lgt_pp_discontiguous_'(Head, _, _), functor(Head, Functor, Arity), '$lgt_compile_predicate_indicator'(Prefix, Functor/Arity, TFunctor/TArity), assertz('$lgt_pp_directive_'(discontiguous(TFunctor/TArity))), fail. '$lgt_generate_category_discontiguous_directives'. '$lgt_generate_object_clauses' :- ( '$lgt_pp_specialized_class_'(_, _, _, _, _, _, _, _, _, _, _) -> % object plays the role of a class '$lgt_generate_ic_clauses' ; '$lgt_pp_instantiated_class_'(_, _, _, _, _, _, _, _, _, _, _) -> % object plays the role of a class '$lgt_generate_ic_clauses' ; % objects without an instantiation or specialization relation % play the role of prototypes '$lgt_generate_prototype_clauses' ). % '$lgt_generate_dcl_table_clauses'(+atom, -atom) % % a predicate declaration table clause is only generated if there is a % scope declaration for the predicate; the second argument returns the % atom "true" if there are local clauses and the atom "false" otherwise % % the table clauses use a bit pattern representation for the predicate % properties for compactness and access performance '$lgt_generate_dcl_table_clauses'(Dcl, _) :- ( '$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_meta_predicate_'(Pred, Template, _, _) -> Meta = Template, MetaPredicate = 64 % 0b01000000 ; Meta = no, MetaPredicate = 0 ), ( '$lgt_pp_coinductive_head_'(Pred, _, _) -> Coinductive = 32 % 0b00100000 ; Coinductive = 0 ), ( '$lgt_pp_multifile_'(Pred, _, _, _) -> Multifile = 16 % 0b00010000 ; Multifile = 0 ), ( '$lgt_pp_non_terminal_'(Functor, _, Arity) -> NonTerminal = 8 % 0b00001000 ; NonTerminal = 0 ), ( '$lgt_pp_synchronized_'(Pred, _, _, _) -> Synchronized = 4 % 0b00000100 ; Synchronized = 0 ), ( '$lgt_pp_dynamic_' -> Dynamic = 2 % 0b00000010 ; '$lgt_pp_dynamic_'(Pred, _, _, _) -> Dynamic = 2 % 0b00000010 ; Dynamic = 0 ), Flags is MetaPredicate + Coinductive + Multifile + NonTerminal + Synchronized + Dynamic, Fact =.. [Dcl, Pred, Scope, Meta, Flags], assertz('$lgt_pp_dcl_'(Fact)), fail. '$lgt_generate_dcl_table_clauses'(_, Local) :- ( '$lgt_pp_dcl_'(_) -> Local = true ; Local = false ). % '$lgt_generate_def_table_clauses'(+compilation_context) % % generates predicate definition table clauses for undefined but % declared (using a predicate directive) predicates '$lgt_generate_def_table_clauses'(Ctx) :- \+ '$lgt_pp_dynamic_', % static entities only otherwise abolishing the dynamic entity would result % in an attempt to retract a clause for the fail/0 built-in control construct ( '$lgt_pp_complemented_object_'(_, _, _, _, _) -> '$lgt_compiler_flag'(complements, restrict) ; true ), % complementing categories can add a scope directive for predicates that % are defined in the complemented objects; for objects compiled with the % complements flag set to allow, we must allow lookup of the predicate % definition in the object itself (and elsewhere in its ancestors) ( '$lgt_pp_public_'(Functor, Arity, _, _) ; '$lgt_pp_protected_'(Functor, Arity, _, _) ; '$lgt_pp_private_'(Functor, Arity, _, _) ; '$lgt_pp_synchronized_'(Head, _, _, _) ; '$lgt_pp_coinductive_head_'(Head, _, _) ; '$lgt_pp_discontiguous_'(Head, _, _) ), functor(Head, Functor, Arity), \+ '$lgt_pp_multifile_'(Head, _, _, _), \+ '$lgt_pp_dynamic_'(Head, _, _, _), \+ '$lgt_pp_defines_predicate_'(Head, _, _, _, _, _), % declared, static, but undefined predicate; % local calls must fail (as per closed-world assumption) '$lgt_add_def_fail_clause'(Head, Ctx), fail. '$lgt_generate_def_table_clauses'(Ctx) :- '$lgt_pp_entity_'(Type, _, Prefix), ( Type == object, % categories cannot contain clauses for dynamic predicates '$lgt_pp_dynamic_'(Head, _, _, _) ; '$lgt_pp_multifile_'(Head, _, _, _), \+ '$lgt_pp_dynamic_'(Head, _, _, _) ), \+ '$lgt_pp_defines_predicate_'(Head, _, _, _, _, _), % dynamic and/or multifile predicate with no initial set of clauses '$lgt_comp_ctx_prefix'(Ctx, Prefix), functor(Head, Functor, Arity), ( \+ '$lgt_pp_public_'(Functor, Arity, _, _), \+ '$lgt_pp_protected_'(Functor, Arity, _, _), \+ '$lgt_pp_private_'(Functor, Arity, _, _), \+ '$lgt_pp_synchronized_'(Head, _, _, _), \+ '$lgt_pp_coinductive_head_'(Head, _, _), \+ '$lgt_pp_multifile_'(Head, _, _, _) -> '$lgt_add_ddef_clause'(Head, Functor, Arity, _, Ctx) ; '$lgt_add_def_clause'(Head, Functor, Arity, _, Ctx) ), fail. '$lgt_generate_def_table_clauses'(_). '$lgt_generate_protocol_clauses' :- '$lgt_pp_protocol_'(Ptc, _, Dcl, Rnm, _), % first, generate the local table of predicate declarations '$lgt_generate_dcl_table_clauses'(Dcl, Local), % second, generate linking clauses for accessing both local % declarations and declarations in related entities (some % linking clauses depend on the existence of local predicate % declarations) '$lgt_generate_protocol_local_clauses'(Local, Ptc, Dcl), '$lgt_generate_protocol_extends_clauses'(Dcl, Rnm), % third, add a catchall clause if necessary '$lgt_generate_protocol_catchall_clauses'(Dcl). '$lgt_generate_protocol_local_clauses'(true, Ptc, PDcl) :- Head =.. [PDcl, Pred, Scope, Meta, Flags, Ptc], Body =.. [PDcl, Pred, Scope, Meta, Flags], assertz('$lgt_pp_dcl_'((Head:-Body))). '$lgt_generate_protocol_local_clauses'(false, _, _). '$lgt_generate_protocol_extends_clauses'(Dcl, Rnm) :- '$lgt_pp_extended_protocol_'(ExtPtc, _, _, ExtDcl, RelationScope), ( RelationScope == (public) -> Lookup =.. [ExtDcl, Pred, Scope, Meta, Flags, Ctn] ; RelationScope == protected -> Lookup0 =.. [ExtDcl, Pred, Scope2, Meta, Flags, Ctn], Lookup = (Lookup0, '$lgt_filter_scope'(Scope2, Scope)) ; Scope = p, Lookup =.. [ExtDcl, Pred, _, Meta, Flags, Ctn] ), ( '$lgt_pp_predicate_alias_'(ExtPtc, _, _, _, _, _) -> Head =.. [Dcl, Alias, Scope, Meta, Flags, Ctn], Rename =.. [Rnm, ExtPtc, Pred, Alias], assertz('$lgt_pp_dcl_'((Head :- Rename, Lookup))) ; Head =.. [Dcl, Pred, Scope, Meta, Flags, Ctn], assertz('$lgt_pp_dcl_'((Head:-Lookup))) ), fail. '$lgt_generate_protocol_extends_clauses'(_, _). % when a static 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_generate_protocol_catchall_clauses'(Dcl) :- ( '$lgt_pp_dcl_'(_) -> % local or inherited predicate declarations exist true ; % empty, standalone protocol '$lgt_pp_dynamic_' -> % dynamic protocol; calls to the dynamic predicate implementing the % predicate declaration table fail when there are no clauses true ; % static protocol; generate a catchall clause as the predicate % implementing the predicate declaration table is also static functor(Head, Dcl, 5), assertz('$lgt_pp_dcl_'((Head:-fail))) ). '$lgt_generate_category_clauses' :- '$lgt_pp_category_'(Ctg, _, Dcl, Def, Rnm, _), '$lgt_generate_category_dcl_clauses'(Ctg, Dcl, Rnm), '$lgt_generate_category_def_clauses'(Ctg, Def, Rnm). '$lgt_generate_category_dcl_clauses'(Ctg, Dcl, Rnm) :- % first, generate the local table of predicate declarations '$lgt_generate_dcl_table_clauses'(Dcl, Local), % second, generate linking clauses for accessing both local % declarations and declarations in related entities (some % linking clauses depend on the existence of local predicate % declarations) '$lgt_generate_category_local_dcl_clauses'(Local, Ctg, Dcl), '$lgt_generate_category_implements_dcl_clauses'(Dcl, Rnm), '$lgt_generate_category_extends_dcl_clauses'(Dcl, Rnm), % third, add a catchall clause if necessary '$lgt_generate_category_catchall_dcl_clauses'(Dcl). '$lgt_generate_category_local_dcl_clauses'(true, Ctg, CDcl) :- Head =.. [CDcl, Pred, Scope, Meta, Flags, Ctg], Body =.. [CDcl, Pred, Scope, Meta, Flags], assertz('$lgt_pp_dcl_'((Head:-Body))). '$lgt_generate_category_local_dcl_clauses'(false, _, _). '$lgt_generate_category_implements_dcl_clauses'(CDcl, Rnm) :- '$lgt_pp_implemented_protocol_'(Ptc, _, _, PDcl, RelationScope), ( RelationScope == (public) -> Lookup =.. [PDcl, Pred, Scope, Meta, Flags, Ctn] ; RelationScope == protected -> Lookup0 =.. [PDcl, Pred, Scope2, Meta, Flags, Ctn], Lookup = (Lookup0, '$lgt_filter_scope'(Scope2, Scope)) ; Scope = p, Lookup =.. [PDcl, Pred, _, Meta, Flags, Ctn] ), ( '$lgt_pp_predicate_alias_'(Ptc, _, _, _, _, _) -> Head =.. [CDcl, Alias, Scope, Meta, Flags, Ctn], Rename =.. [Rnm, Ptc, Pred, Alias], assertz('$lgt_pp_dcl_'((Head :- Rename, Lookup))) ; Head =.. [CDcl, Pred, Scope, Meta, Flags, Ctn], assertz('$lgt_pp_dcl_'((Head:-Lookup))) ), fail. '$lgt_generate_category_implements_dcl_clauses'(_, _). '$lgt_generate_category_extends_dcl_clauses'(CDcl, Rnm) :- '$lgt_pp_extended_category_'(Ctg, _, _, ECDcl, _, RelationScope), ( RelationScope == (public) -> Lookup =.. [ECDcl, Pred, Scope, Meta, Flags, Ctn] ; RelationScope == protected -> Lookup0 =.. [ECDcl, Pred, Scope2, Meta, Flags, Ctn], Lookup = (Lookup0, '$lgt_filter_scope'(Scope2, Scope)) ; Scope = p, Lookup =.. [ECDcl, Pred, _, Meta, Flags, Ctn] ), ( '$lgt_pp_predicate_alias_'(Ctg, _, _, _, _, _) -> Head =.. [CDcl, Alias, Scope, Meta, Flags, Ctn], Rename =.. [Rnm, Ctg, Pred, Alias], assertz('$lgt_pp_dcl_'((Head :- Rename, Lookup))) ; Head =.. [CDcl, Pred, Scope, Meta, Flags, Ctn], assertz('$lgt_pp_dcl_'((Head:-Lookup))) ), fail. '$lgt_generate_category_extends_dcl_clauses'(_, _). % when a static category contains no predicate declarations, does not implement any % protocol, and does not extend 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_generate_category_catchall_dcl_clauses'(Dcl) :- ( '$lgt_pp_dcl_'(_) -> % local or inherited predicate declarations exist true ; % standalone category with no local or inherited predicate declarations '$lgt_pp_dynamic_' -> % dynamic category; calls to the dynamic predicate implementing the % predicate declaration table fail when there are no clauses true ; % static category; generate a catchall clause as the predicate % implementing the predicate declaration table is also static functor(Head, Dcl, 5), assertz('$lgt_pp_dcl_'((Head:-fail))) ). '$lgt_generate_category_def_clauses'(Ctg, Def, Rnm) :- '$lgt_generate_category_local_def_clauses'(Ctg, Def), '$lgt_generate_category_extends_def_clauses'(Def, Rnm). '$lgt_generate_category_local_def_clauses'(Ctg, Def) :- '$lgt_execution_context_this_entity'(ExCtx, _, Ctg), Head =.. [Def, Pred, ExCtx, Call, Ctg], ( '$lgt_pp_def_'(_) -> Body =.. [Def, Pred, ExCtx, Call] ; Body = fail ), assertz('$lgt_pp_def_'((Head:-Body))). '$lgt_generate_category_extends_def_clauses'(Def, Rnm) :- '$lgt_pp_extended_category_'(ExtCtg, Ctg, _, _, ExtDef, _), '$lgt_execution_context_update_this_entity'(CExCtx, This, Ctg, EExCtx, This, ExtCtg), Lookup =.. [ExtDef, Pred, EExCtx, Call, Ctn], ( '$lgt_pp_predicate_alias_'(ExtCtg, _, _, _, _, _) -> Head =.. [Def, Alias, CExCtx, Call, Ctn], Rename =.. [Rnm, ExtCtg, Pred, Alias], assertz('$lgt_pp_def_'((Head :- Rename, Lookup))) ; Head =.. [Def, Pred, CExCtx, Call, Ctn], assertz('$lgt_pp_def_'((Head:-Lookup))) ), fail. '$lgt_generate_category_extends_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 % a catchall clause for static objects when there are no local predicate declarations or no % local predicate definitions '$lgt_generate_object_catchall_local_dcl_clause'(true, _). '$lgt_generate_object_catchall_local_dcl_clause'(false, Dcl) :- ( '$lgt_pp_dynamic_' -> % dynamic object; calls to the dynamic predicate implementing the % predicate declaration table fail when there are no clauses true ; % static object; generate a catchall clause as the predicate % implementing the predicate declaration table is also static functor(Head, Dcl, 4), assertz('$lgt_pp_dcl_'((Head:-fail))) ). '$lgt_generate_object_catchall_def_clauses'(true, _). '$lgt_generate_object_catchall_def_clauses'(false, Def) :- ( '$lgt_pp_dynamic_' -> % dynamic object; calls to the dynamic predicate implementing the % predicate definition table fail when there are no clauses true ; % static object; generate a catchall clause as the predicate % implementing the predicate definition table is also static functor(Head, Def, 3), assertz('$lgt_pp_def_'((Head:-fail))) ). '$lgt_generate_prototype_clauses' :- '$lgt_pp_object_'(Obj, _, Dcl, Def, Super, _, _, DDcl, DDef, Rnm, _), '$lgt_compiler_flag'(complements, Complements), '$lgt_generate_prototype_dcl_clauses'(Obj, Dcl, DDcl, Rnm, Complements), '$lgt_generate_prototype_def_clauses'(Obj, Def, DDef, Rnm, Complements), '$lgt_generate_prototype_super_clauses'(Super, Rnm). '$lgt_generate_prototype_dcl_clauses'(Obj, Dcl, DDcl, Rnm, Complements) :- % first, generate the local table of predicate declarations: '$lgt_generate_dcl_table_clauses'(Dcl, Local), % second, generate linking clauses for accessing both local % declarations and declarations in related entities (some % linking clauses depend on the existence of local predicate % declarations ( Complements == allow -> % complementing categories are allowed to override local predicate declarations '$lgt_generate_prototype_complements_dcl_clauses'(Obj, Dcl), '$lgt_generate_prototype_local_dcl_clauses'(Local, Complements, Obj, Dcl, DDcl) ; Complements == restrict -> % complementing categories can add to but not override local predicate declarations '$lgt_generate_prototype_local_dcl_clauses'(Local, Complements, Obj, Dcl, DDcl), '$lgt_generate_prototype_complements_dcl_clauses'(Obj, Dcl) ; % Complements == deny, '$lgt_generate_prototype_local_dcl_clauses'(Local, Complements, Obj, Dcl, DDcl) ), '$lgt_generate_prototype_implements_dcl_clauses'(Dcl, Rnm), '$lgt_generate_prototype_imports_dcl_clauses'(Dcl, Rnm), '$lgt_generate_prototype_extends_dcl_clauses'(Dcl, Rnm), % third, add a catchall clause if necessary '$lgt_generate_object_catchall_local_dcl_clause'(Local, Dcl). '$lgt_generate_prototype_complements_dcl_clauses'(Obj, Dcl) :- Head =.. [Dcl, Pred, Scope, Meta, Flags, SCtn, TCtn], Lookup = '$lgt_complemented_object'(Obj, Dcl, Pred, Scope, Meta, Flags, SCtn, TCtn), assertz('$lgt_pp_dcl_'((Head:-Lookup))). '$lgt_generate_prototype_local_dcl_clauses'(true, _, Obj, Dcl, DDcl) :- % there are local (compile-time) predicate declarations HeadDcl =.. [Dcl, Pred, Scope, Meta, Flags, Obj, Obj], BodyDcl =.. [Dcl, Pred, Scope, Meta, Flags], % lookup access to local, static, predicate declarations assertz('$lgt_pp_dcl_'((HeadDcl:-BodyDcl))), ( '$lgt_compiler_flag'(dynamic_declarations, allow) -> HeadDDcl =.. [Dcl, Pred, Scope, no, 2, Obj, Obj], BodyDDcl =.. [DDcl, Pred, Scope], % lookup access to local, dynamic, (runtime) predicate declarations assertz('$lgt_pp_dcl_'((HeadDDcl:-BodyDDcl))) ; true ). '$lgt_generate_prototype_local_dcl_clauses'(false, Complements, Obj, Dcl, DDcl) :- % no local (compile-time) predicate declarations ( '$lgt_compiler_flag'(dynamic_declarations, allow) -> HeadDDcl =.. [Dcl, Pred, Scope, no, 2, Obj, Obj], BodyDDcl =.. [DDcl, Pred, Scope], % lookup access to local, dynamic, (runtime) predicate declarations assertz('$lgt_pp_dcl_'((HeadDDcl:-BodyDDcl))) ; Complements == deny, \+ '$lgt_pp_implemented_protocol_'(_, _, _, _, _), \+ '$lgt_pp_imported_category_'(_, _, _, _, _, _), \+ '$lgt_pp_extended_object_'(_, _, _, _, _, _, _, _, _, _, _) -> % standalone prototype with no access to predicate declarations functor(HeadDDcl, Dcl, 6), % catchall clause to avoid lookup errors assertz('$lgt_pp_dcl_'((HeadDDcl:-fail))) ; true ). '$lgt_generate_prototype_implements_dcl_clauses'(ODcl, Rnm) :- '$lgt_pp_implemented_protocol_'(Ptc, Obj, _, PDcl, RelationScope), ( RelationScope == (public) -> Lookup =.. [PDcl, Pred, Scope, Meta, Flags, TCtn] ; RelationScope == protected -> Lookup0 =.. [PDcl, Pred, Scope2, Meta, Flags, TCtn], Lookup = (Lookup0, '$lgt_filter_scope'(Scope2, Scope)) ; Scope = p, Lookup =.. [PDcl, Pred, _, Meta, Flags, TCtn] ), ( '$lgt_pp_predicate_alias_'(Ptc, _, _, _, _, _) -> Head =.. [ODcl, Alias, Scope, Meta, Flags, Obj, TCtn], Rename =.. [Rnm, Ptc, Pred, Alias], assertz('$lgt_pp_dcl_'((Head :- Rename, Lookup))) ; Head =.. [ODcl, Pred, Scope, Meta, Flags, Obj, TCtn], assertz('$lgt_pp_dcl_'((Head:-Lookup))) ), fail. '$lgt_generate_prototype_implements_dcl_clauses'(_, _). '$lgt_generate_prototype_imports_dcl_clauses'(ODcl, Rnm) :- '$lgt_pp_imported_category_'(Ctg, Obj, _, CDcl, _, RelationScope), ( RelationScope == (public) -> Lookup =.. [CDcl, Pred, Scope, Meta, Flags, TCtn] ; RelationScope == protected -> Lookup0 =.. [CDcl, Pred, Scope2, Meta, Flags, TCtn], Lookup = (Lookup0, '$lgt_filter_scope'(Scope2, Scope)) ; Scope = p, Lookup =.. [CDcl, Pred, _, Meta, Flags, TCtn] ), ( '$lgt_pp_predicate_alias_'(Ctg, _, _, _, _, _) -> Head =.. [ODcl, Alias, Scope, Meta, Flags, Obj, TCtn], Rename =.. [Rnm, Ctg, Pred, Alias], assertz('$lgt_pp_dcl_'((Head :- Rename, Lookup))) ; Head =.. [ODcl, Pred, Scope, Meta, Flags, Obj, TCtn], assertz('$lgt_pp_dcl_'((Head:-Lookup))) ), fail. '$lgt_generate_prototype_imports_dcl_clauses'(_, _). '$lgt_generate_prototype_extends_dcl_clauses'(ODcl, Rnm) :- '$lgt_pp_extended_object_'(Parent, Obj, _, PDcl, _, _, _, _, _, _, RelationScope), ( RelationScope == (public) -> Lookup =.. [PDcl, Pred, Scope, Meta, Flags, SCtn, TCtn] ; RelationScope == protected -> Lookup0 =.. [PDcl, Pred, Scope2, Meta, Flags, SCtn, TCtn], Lookup = (Lookup0, '$lgt_filter_scope'(Scope2, Scope)) ; Scope = p, Lookup0 =.. [PDcl, Pred, Scope2, Meta, Flags, SCtn2, TCtn], Lookup = (Lookup0, '$lgt_filter_scope_container'(Scope2, SCtn2, Obj, SCtn)) ), ( '$lgt_pp_predicate_alias_'(Parent, _, _, _, _, _) -> Head =.. [ODcl, Alias, Scope, Meta, Flags, SCtn, TCtn], Rename =.. [Rnm, Parent, Pred, Alias], assertz('$lgt_pp_dcl_'((Head :- Rename, Lookup))) ; Head =.. [ODcl, Pred, Scope, Meta, Flags, SCtn, TCtn], assertz('$lgt_pp_dcl_'((Head:-Lookup))) ), fail. '$lgt_generate_prototype_extends_dcl_clauses'(_, _). '$lgt_generate_prototype_def_clauses'(Obj, Def, DDef, Rnm, Complements) :- % some linking clauses depend on the existence of local predicate definitions ( '$lgt_pp_def_'(_) -> Local = true ; Local = false ), ( Complements == allow -> % complementing categories are allowed to override local predicate definitions '$lgt_generate_prototype_complements_def_clauses'(Obj, Def), '$lgt_generate_prototype_local_def_clauses'(Local, Obj, Def, DDef) ; Complements == restrict -> % complementing categories can add to but not override local predicate definitions '$lgt_generate_prototype_local_def_clauses'(Local, Obj, Def, DDef), '$lgt_generate_prototype_complements_def_clauses'(Obj, Def) ; % Complements == deny, '$lgt_generate_prototype_local_def_clauses'(Local, Obj, Def, DDef) ), '$lgt_generate_prototype_imports_def_clauses'(Def, Rnm), '$lgt_generate_prototype_extends_def_clauses'(Def, Rnm), % add a catchall clause if necessary '$lgt_generate_object_catchall_def_clauses'(Local, Def). '$lgt_generate_prototype_complements_def_clauses'(Obj, Def) :- Head =.. [Def, Pred, ExCtx, Call, Obj, TCtn], Lookup = '$lgt_complemented_object'(Obj, Def, Pred, ExCtx, Call, TCtn), assertz('$lgt_pp_def_'((Head:-Lookup))). '$lgt_generate_prototype_local_def_clauses'(true, Obj, Def, DDef) :- % there are local (compile-time) predicate definitions '$lgt_execution_context_this_entity'(ExCtx, Obj, Obj), Head =.. [Def, Pred, ExCtx, Call, Obj, Obj], BodyDef =.. [Def, Pred, ExCtx, Call], % lookup access to local, static, predicate definitions assertz('$lgt_pp_def_'((Head:-BodyDef))), BodyDDef =.. [DDef, Pred, ExCtx, Call], % lookup access to local, dynamic, (runtime) predicate definitions assertz('$lgt_pp_def_'((Head:-BodyDDef))). '$lgt_generate_prototype_local_def_clauses'(false, Obj, Def, DDef) :- % no local (compile-time) predicate definitions '$lgt_execution_context_this_entity'(ExCtx, Obj, Obj), Head =.. [Def, Pred, ExCtx, Call, Obj, Obj], BodyDDef =.. [DDef, Pred, ExCtx, Call], % lookup access to local, dynamic, (runtime) predicate definitions assertz('$lgt_pp_def_'((Head:-BodyDDef))). '$lgt_generate_prototype_imports_def_clauses'(ODef, Rnm) :- '$lgt_pp_imported_category_'(Ctg, Obj, _, _, CDef, _), '$lgt_execution_context_update_this_entity'(OExCtx, Obj, Obj, CExCtx, Obj, Ctg), Lookup =.. [CDef, Pred, CExCtx, Call, TCtn], ( '$lgt_pp_predicate_alias_'(Ctg, _, _, _, _, _) -> Head =.. [ODef, Alias, OExCtx, Call, Obj, TCtn], Rename =.. [Rnm, Ctg, Pred, Alias], assertz('$lgt_pp_def_'((Head :- Rename, Lookup))) ; Head =.. [ODef, Pred, OExCtx, Call, Obj, TCtn], assertz('$lgt_pp_def_'((Head:-Lookup))) ), fail. '$lgt_generate_prototype_imports_def_clauses'(_, _). '$lgt_generate_prototype_extends_def_clauses'(ODef, Rnm) :- '$lgt_pp_extended_object_'(Parent, Obj, _, _, PDef, _, _, _, _, _, _), '$lgt_execution_context_update_this_entity'(OExCtx, Obj, Obj, PExCtx, Parent, Parent), Lookup =.. [PDef, Pred, PExCtx, Call, SCtn, TCtn], ( '$lgt_pp_predicate_alias_'(Parent, _, _, _, _, _) -> Head =.. [ODef, Alias, OExCtx, Call, SCtn, TCtn], Rename =.. [Rnm, Parent, Pred, Alias], assertz('$lgt_pp_def_'((Head :- Rename, Lookup))) ; Head =.. [ODef, Pred, OExCtx, Call, SCtn, TCtn], assertz('$lgt_pp_def_'((Head:-Lookup))) ), fail. '$lgt_generate_prototype_extends_def_clauses'(_, _). % we can have a root object where super have nowhere to go ... '$lgt_generate_prototype_super_clauses'(Super, _) :- \+ '$lgt_pp_imported_category_'(_, _, _, _, _, _), \+ '$lgt_pp_extended_object_'(_, _, _, _, _, _, _, _, _, _, _), functor(Head, Super, 5), assertz('$lgt_pp_super_'((Head:-fail))), !. % ... or we may import some categories '$lgt_generate_prototype_super_clauses'(Super, Rnm) :- '$lgt_pp_imported_category_'(Ctg, Obj, _, _, CDef, _), % the entity in the object execution context is usually the object itself % but it can also be a complementing category; thus, the argument must be % left uninstantiated but it will be bound by the runtime '$lgt_execution_context_update_this_entity'(OExCtx, Obj, _, CExCtx, Obj, Ctg), Lookup =.. [CDef, Pred, CExCtx, Call, TCtn], ( '$lgt_pp_predicate_alias_'(Ctg, _, _, _, _, _) -> Head =.. [Super, Alias, OExCtx, Call, Obj, TCtn], Rename =.. [Rnm, Ctg, Pred, Alias], assertz('$lgt_pp_super_'((Head :- Rename, Lookup))) ; Head =.. [Super, Pred, OExCtx, Call, Obj, TCtn], assertz('$lgt_pp_super_'((Head:-Lookup))) ), fail. % ... or we may extend some objects '$lgt_generate_prototype_super_clauses'(Super, Rnm) :- '$lgt_pp_extended_object_'(Parent, Obj, _, _, PDef, _, _, _, _, _, _), % the entity in the object execution context is usually the object itself % but it can also be a complementing category; thus, the argument must be % left uninstantiated but it will be bound by the runtime '$lgt_execution_context_update_this_entity'(OExCtx, Obj, _, PExCtx, Parent, Parent), Lookup =.. [PDef, Pred, PExCtx, Call, SCtn, TCtn], ( '$lgt_pp_predicate_alias_'(Parent, _, _, _, _, _) -> Head =.. [Super, Alias, OExCtx, Call, SCtn, TCtn], Rename =.. [Rnm, Parent, Pred, Alias], assertz('$lgt_pp_super_'((Head :- Rename, Lookup))) ; Head =.. [Super, Pred, OExCtx, Call, SCtn, TCtn], assertz('$lgt_pp_super_'((Head:-Lookup))) ), fail. '$lgt_generate_prototype_super_clauses'(_, _). '$lgt_generate_ic_clauses' :- '$lgt_pp_object_'(Obj, _, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Rnm, _), '$lgt_compiler_flag'(complements, Complements), '$lgt_generate_ic_dcl_clauses'(Obj, Dcl, IDcl, DDcl, Rnm, Complements), '$lgt_generate_ic_def_clauses'(Obj, Def, IDef, DDef, Rnm, Complements), '$lgt_generate_ic_super_clauses'(Obj, Super, Rnm). '$lgt_generate_ic_dcl_clauses'(Obj, Dcl, IDcl, DDcl, Rnm, Complements) :- % first, generate the local table of predicate declarations: '$lgt_generate_dcl_table_clauses'(Dcl, Local), % second, generate linking clauses for accessing declarations % in related entities (for an instance, the lookup for a predicate % declaration always start at its classes) '$lgt_generate_ic_instantiates_dcl_clauses'(Dcl, Rnm), % third, add a catchall clause if necessary '$lgt_generate_object_catchall_local_dcl_clause'(Local, Dcl), % finaly, generate linking clauses for accessing declarations % when we reach the class being compiled during a lookup % from a descendant instance '$lgt_generate_ic_idcl_clauses'(Local, Obj, Dcl, IDcl, DDcl, Rnm, Complements). '$lgt_generate_ic_instantiates_dcl_clauses'(ODcl, _) :- \+ '$lgt_pp_instantiated_class_'(_, _, _, _, _, _, _, _, _, _, _), % no meta-class for the class we're compiling !, functor(Head, ODcl, 6), assertz('$lgt_pp_dcl_'((Head:-fail))). '$lgt_generate_ic_instantiates_dcl_clauses'(ODcl, Rnm) :- '$lgt_pp_instantiated_class_'(Class, Obj, _, _, _, _, CIDcl, _, _, _, RelationScope), ( RelationScope == (public) -> Lookup =.. [CIDcl, Pred, Scope, Meta, Flags, SCtn, TCtn] ; RelationScope == protected -> Lookup0 =.. [CIDcl, Pred, Scope2, Meta, Flags, SCtn, TCtn], Lookup = (Lookup0, '$lgt_filter_scope'(Scope2, Scope)) ; Scope = p, Lookup0 =.. [CIDcl, Pred, Scope2, Meta, Flags, SCtn2, TCtn], Lookup = (Lookup0, '$lgt_filter_scope_container'(Scope2, SCtn2, Obj, SCtn)) ), ( '$lgt_pp_predicate_alias_'(Class, _, _, _, _, _) -> Head =.. [ODcl, Alias, Scope, Meta, Flags, SCtn, TCtn], Rename =.. [Rnm, Class, Pred, Alias], assertz('$lgt_pp_dcl_'((Head :- Rename, Lookup))) ; Head =.. [ODcl, Pred, Scope, Meta, Flags, SCtn, TCtn], assertz('$lgt_pp_dcl_'((Head:-Lookup))) ), fail. '$lgt_generate_ic_instantiates_dcl_clauses'(_, _). % generates the declaration linking clauses that are used % when traversing specialization links in order to lookup % a predicate declaration for a descendant instance '$lgt_generate_ic_idcl_clauses'(Local, Obj, Dcl, IDcl, DDcl, Rnm, Complements) :- % generate linking clauses for accessing declarations in related entities ( Complements == allow -> % complementing categories are allowed to override local predicate declarations '$lgt_generate_ic_complements_idcl_clauses'(Obj, IDcl), '$lgt_generate_ic_local_idcl_clauses'(Local, Complements, Obj, Dcl, IDcl, DDcl) ; Complements == restrict -> % complementing categories can add to but not override local predicate declarations '$lgt_generate_ic_local_idcl_clauses'(Local, Complements, Obj, Dcl, IDcl, DDcl), '$lgt_generate_ic_complements_idcl_clauses'(Obj, IDcl) ; % Complements == deny, '$lgt_generate_ic_local_idcl_clauses'(Local, Complements, Obj, Dcl, IDcl, DDcl) ), '$lgt_generate_ic_implements_idcl_clauses'(IDcl, Rnm), '$lgt_generate_ic_imports_idcl_clauses'(IDcl, Rnm), '$lgt_generate_ic_specializes_idcl_clauses'(IDcl, Rnm). '$lgt_generate_ic_complements_idcl_clauses'(Obj, IDcl) :- Head =.. [IDcl, Pred, Scope, Meta, Flags, SCtn, TCtn], Lookup = '$lgt_complemented_object'(Obj, IDcl, Pred, Scope, Meta, Flags, SCtn, TCtn), assertz('$lgt_pp_dcl_'((Head:-Lookup))). '$lgt_generate_ic_local_idcl_clauses'(true, _, Obj, Dcl, IDcl, DDcl) :- % there are local (compile-time) predicate declarations HeadDcl =.. [IDcl, Pred, Scope, Meta, Flags, Obj, Obj], BodyDcl =.. [Dcl, Pred, Scope, Meta, Flags], % lookup access to local, static, predicate declarations assertz('$lgt_pp_dcl_'((HeadDcl:-BodyDcl))), ( '$lgt_compiler_flag'(dynamic_declarations, allow) -> HeadDDcl =.. [IDcl, Pred, Scope, no, 2, Obj, Obj], BodyDDcl =.. [DDcl, Pred, Scope], % lookup access to local, dynamic, (runtime) predicate declarations assertz('$lgt_pp_dcl_'((HeadDDcl:-BodyDDcl))) ; true ). '$lgt_generate_ic_local_idcl_clauses'(false, Complements, Obj, _, IDcl, DDcl) :- % no local (compile-time) predicate declarations ( '$lgt_compiler_flag'(dynamic_declarations, allow) -> HeadDDcl =.. [IDcl, Pred, Scope, no, 2, Obj, Obj], BodyDDcl =.. [DDcl, Pred, Scope], % lookup access to local, dynamic, (runtime) predicate declarations assertz('$lgt_pp_dcl_'((HeadDDcl:-BodyDDcl))) ; Complements == deny, \+ '$lgt_pp_implemented_protocol_'(_, _, _, _, _), \+ '$lgt_pp_imported_category_'(_, _, _, _, _, _), \+ '$lgt_pp_specialized_class_'(_, _, _, _, _, _, _, _, _, _, _) -> % standalone class with no access to predicate declarations functor(HeadDDcl, IDcl, 6), % catchall clause to avoid lookup errors assertz('$lgt_pp_dcl_'((HeadDDcl:-fail))) ; true ). '$lgt_generate_ic_implements_idcl_clauses'(OIDcl, Rnm) :- '$lgt_pp_implemented_protocol_'(Ptc, Obj, _, PDcl, RelationScope), ( RelationScope == (public) -> Lookup =.. [PDcl, Pred, Scope, Meta, Flags, TCtn] ; RelationScope == protected -> Lookup0 =.. [PDcl, Pred, Scope2, Meta, Flags, TCtn], Lookup = (Lookup0, '$lgt_filter_scope'(Scope2, Scope)) ; Scope = p, Lookup =.. [PDcl, Pred, _, Meta, Flags, TCtn] ), ( '$lgt_pp_predicate_alias_'(Ptc, _, _, _, _, _) -> Head =.. [OIDcl, Alias, Scope, Meta, Flags, Obj, TCtn], Rename =.. [Rnm, Ptc, Pred, Alias], assertz('$lgt_pp_dcl_'((Head :- Rename, Lookup))) ; Head =.. [OIDcl, Pred, Scope, Meta, Flags, Obj, TCtn], assertz('$lgt_pp_dcl_'((Head:-Lookup))) ), fail. '$lgt_generate_ic_implements_idcl_clauses'(_, _). '$lgt_generate_ic_imports_idcl_clauses'(OIDcl, Rnm) :- '$lgt_pp_imported_category_'(Ctg, Obj, _, CDcl, _, RelationScope), ( RelationScope == (public) -> Lookup =.. [CDcl, Pred, Scope, Meta, Flags, TCtn] ; RelationScope == protected -> Lookup0 =.. [CDcl, Pred, Scope2, Meta, Flags, TCtn], Lookup = (Lookup0, '$lgt_filter_scope'(Scope2, Scope)) ; Scope = p, Lookup =.. [CDcl, Pred, _, Meta, Flags, TCtn] ), ( '$lgt_pp_predicate_alias_'(Ctg, _, _, _, _, _) -> Head =.. [OIDcl, Alias, Scope, Meta, Flags, Obj, TCtn], Rename =.. [Rnm, Ctg, Pred, Alias], assertz('$lgt_pp_dcl_'((Head :- Rename, Lookup))) ; Head =.. [OIDcl, Pred, Scope, Meta, Flags, Obj, TCtn], assertz('$lgt_pp_dcl_'((Head:-Lookup))) ), fail. '$lgt_generate_ic_imports_idcl_clauses'(_, _). '$lgt_generate_ic_specializes_idcl_clauses'(CIDcl, Rnm) :- '$lgt_pp_specialized_class_'(Super, Obj, _, _, _, _, SIDcl, _, _, _, RelationScope), ( RelationScope == (public) -> Lookup =.. [SIDcl, Pred, Scope, Meta, Flags, SCtn, TCtn] ; RelationScope == protected -> Lookup0 =.. [SIDcl, Pred, Scope2, Meta, Flags, SCtn, TCtn], Lookup = (Lookup0, '$lgt_filter_scope'(Scope2, Scope)) ; Scope = p, Lookup0 =.. [SIDcl, Pred, Scope2, Meta, Flags, SCtn2, TCtn], Lookup = (Lookup0, '$lgt_filter_scope_container'(Scope2, SCtn2, Obj, SCtn)) ), ( '$lgt_pp_predicate_alias_'(Super, _, _, _, _, _) -> Head =.. [CIDcl, Alias, Scope, Meta, Flags, SCtn, TCtn], Rename =.. [Rnm, Super, Pred, Alias], assertz('$lgt_pp_dcl_'((Head :- Rename, Lookup))) ; Head =.. [CIDcl, Pred, Scope, Meta, Flags, SCtn, TCtn], assertz('$lgt_pp_dcl_'((Head:-Lookup))) ), fail. '$lgt_generate_ic_specializes_idcl_clauses'(_, _). % lookup of predicate definitions start at the instance itself % (not at its classes as it's the case for predicate declarations) '$lgt_generate_ic_def_clauses'(Obj, Def, IDef, DDef, Rnm, Complements) :- % some linking clauses depend on the existence of local predicate definitions ( '$lgt_pp_def_'(_) -> Local = true ; Local = false ), ( Complements == allow -> % complementing categories are allowed to override local predicate definitions '$lgt_generate_ic_complements_def_clauses'(Obj, Def), '$lgt_generate_ic_local_def_clauses'(Local, Obj, Def, DDef) ; Complements == restrict -> % complementing categories can add to but not override local predicate definitions '$lgt_generate_ic_local_def_clauses'(Local, Obj, Def, DDef), '$lgt_generate_ic_complements_def_clauses'(Obj, Def) ; % Complements == deny, '$lgt_generate_ic_local_def_clauses'(Local, Obj, Def, DDef) ), '$lgt_generate_ic_imports_def_clauses'(Def, Rnm), '$lgt_generate_ic_instantiates_def_clauses'(Def, Rnm), % add a catchall clause if necessary '$lgt_generate_object_catchall_def_clauses'(Local, Def), % generate linking clauses for accessing definitions when % we reach the class being compiled during a lookup from % a descendant instance '$lgt_generate_ic_idef_clauses'(Local, Obj, Def, IDef, DDef, Rnm, Complements). '$lgt_generate_ic_complements_def_clauses'(Obj, Def) :- Head =.. [Def, Pred, ExCtx, Call, Obj, TCtn], Lookup = '$lgt_complemented_object'(Obj, Def, Pred, ExCtx, Call, TCtn), assertz('$lgt_pp_def_'((Head:-Lookup))). '$lgt_generate_ic_local_def_clauses'(true, Obj, Def, DDef) :- % there are local (compile-time) predicate definitions '$lgt_execution_context_this_entity'(ExCtx, Obj, Obj), Head =.. [Def, Pred, ExCtx, Call, Obj, Obj], BodyDef =.. [Def, Pred, ExCtx, Call], % lookup access to local, static, predicate definitions assertz('$lgt_pp_def_'((Head:-BodyDef))), BodyDDef =.. [DDef, Pred, ExCtx, Call], % lookup access to local, dynamic, (runtime) predicate definitions assertz('$lgt_pp_def_'((Head:-BodyDDef))). '$lgt_generate_ic_local_def_clauses'(false, Obj, Def, DDef) :- % no local (compile-time) predicate definitions '$lgt_execution_context_this_entity'(ExCtx, Obj, Obj), Head =.. [Def, Pred, ExCtx, Call, Obj, Obj], BodyDDef =.. [DDef, Pred, ExCtx, Call], % lookup access to local, dynamic, (runtime) predicate definitions assertz('$lgt_pp_def_'((Head:-BodyDDef))). '$lgt_generate_ic_imports_def_clauses'(ODef, Rnm) :- '$lgt_pp_imported_category_'(Ctg, Obj, _, _, CDef, _), '$lgt_execution_context_update_this_entity'(OExCtx, Obj, Obj, CExCtx, Obj, Ctg), Lookup =.. [CDef, Pred, CExCtx, Call, TCtn], ( '$lgt_pp_predicate_alias_'(Ctg, _, _, _, _, _) -> Head =.. [ODef, Alias, OExCtx, Call, Obj, TCtn], Rename =.. [Rnm, Ctg, Pred, Alias], assertz('$lgt_pp_def_'((Head :- Rename, Lookup))) ; Head =.. [ODef, Pred, OExCtx, Call, Obj, TCtn], assertz('$lgt_pp_def_'((Head:-Lookup))) ), fail. '$lgt_generate_ic_imports_def_clauses'(_, _). '$lgt_generate_ic_instantiates_def_clauses'(ODef, Rnm) :- '$lgt_pp_instantiated_class_'(Class, Obj, _, _, _, _, _, CIDef, _, _, _), '$lgt_execution_context_update_this_entity'(OExCtx, Obj, Obj, CExCtx, Class, Class), Lookup =.. [CIDef, Pred, CExCtx, Call, SCtn, TCtn], ( '$lgt_pp_predicate_alias_'(Class, _, _, _, _, _) -> Head =.. [ODef, Alias, OExCtx, Call, SCtn, TCtn], Rename =.. [Rnm, Class, Pred, Alias], assertz('$lgt_pp_def_'((Head :- Rename, Lookup))) ; Head =.. [ODef, Pred, OExCtx, Call, SCtn, TCtn], assertz('$lgt_pp_def_'((Head:-Lookup))) ), fail. '$lgt_generate_ic_instantiates_def_clauses'(_, _). % generates the definition linking clauses that are used % when traversing specialization links in order to lookup % a predicate definition for a descendant instance '$lgt_generate_ic_idef_clauses'(Local, Obj, Def, IDef, DDef, Rnm, Complements) :- ( Complements == allow -> % complementing categories are allowed to override local predicate definitions '$lgt_generate_ic_complements_idef_clauses'(Obj, IDef), '$lgt_generate_ic_local_idef_clauses'(Local, Obj, Def, IDef, DDef) ; Complements == restrict -> % complementing categories can add to but not override local predicate definitions '$lgt_generate_ic_local_idef_clauses'(Local, Obj, Def, IDef, DDef), '$lgt_generate_ic_complements_idef_clauses'(Obj, IDef) ; % Complements == deny, '$lgt_generate_ic_local_idef_clauses'(Local, Obj, Def, IDef, DDef) ), '$lgt_generate_ic_complements_idef_clauses'(Obj, IDef), '$lgt_generate_ic_local_idef_clauses'(Local, Obj, Def, IDef, DDef), '$lgt_generate_ic_imports_idef_clauses'(IDef, Rnm), '$lgt_generate_ic_specializes_idef_clauses'(IDef, Rnm). '$lgt_generate_ic_complements_idef_clauses'(Obj, IDef) :- Head =.. [IDef, Pred, ExCtx, Call, Obj, TCtn], Lookup = '$lgt_complemented_object'(Obj, IDef, Pred, ExCtx, Call, TCtn), assertz('$lgt_pp_def_'((Head:-Lookup))). '$lgt_generate_ic_local_idef_clauses'(true, Obj, Def, IDef, DDef) :- % there are local (compile-time) predicate definitions '$lgt_execution_context_this_entity'(ExCtx, Obj, Obj), Head =.. [IDef, Pred, ExCtx, Call, Obj, Obj], BodyDef =.. [Def, Pred, ExCtx, Call], % lookup access to local, static, predicate definitions assertz('$lgt_pp_def_'((Head:-BodyDef))), BodyDDef =.. [DDef, Pred, ExCtx, Call], % lookup access to local, dynamic, (runtime) predicate definitions assertz('$lgt_pp_def_'((Head:-BodyDDef))). '$lgt_generate_ic_local_idef_clauses'(false, Obj, _, IDef, DDef) :- % no local (compile-time) predicate definitions '$lgt_execution_context_this_entity'(ExCtx, Obj, Obj), Head =.. [IDef, Pred, ExCtx, Call, Obj, Obj], BodyDDef =.. [DDef, Pred, ExCtx, Call], % lookup access to local, dynamic, (runtime) predicate definitions assertz('$lgt_pp_def_'((Head:-BodyDDef))). '$lgt_generate_ic_imports_idef_clauses'(OIDef, Rnm) :- '$lgt_pp_imported_category_'(Ctg, Obj, _, _, CDef, _), '$lgt_execution_context_update_this_entity'(OExCtx, Obj, Obj, CExCtx, Obj, Ctg), Lookup =.. [CDef, Pred, CExCtx, Call, TCtn], ( '$lgt_pp_predicate_alias_'(Ctg, _, _, _, _, _) -> Head =.. [OIDef, Alias, OExCtx, Call, Obj, TCtn], Rename =.. [Rnm, Ctg, Pred, Alias], assertz('$lgt_pp_def_'((Head :- Rename, Lookup))) ; Head =.. [OIDef, Pred, OExCtx, Call, Obj, TCtn], assertz('$lgt_pp_def_'((Head:-Lookup))) ), fail. '$lgt_generate_ic_imports_idef_clauses'(_, _). '$lgt_generate_ic_specializes_idef_clauses'(CIDef, Rnm) :- '$lgt_pp_specialized_class_'(Super, Class, _, _, _, _, _, SIDef, _, _, _), '$lgt_execution_context_update_this_entity'(CExCtx, Class, Class, SExCtx, Super, Super), Lookup =.. [SIDef, Pred, SExCtx, Call, SCtn, TCtn], ( '$lgt_pp_predicate_alias_'(Super, _, _, _, _, _) -> Head =.. [CIDef, Alias, CExCtx, Call, SCtn, TCtn], Rename =.. [Rnm, Super, Pred, Alias], assertz('$lgt_pp_def_'((Head :- Rename, Lookup))) ; Head =.. [CIDef, Pred, CExCtx, Call, SCtn, TCtn], assertz('$lgt_pp_def_'((Head:-Lookup))) ), fail. '$lgt_generate_ic_specializes_idef_clauses'(_, _). % we can have a root object where "super" have nowhere to go ... '$lgt_generate_ic_super_clauses'(Obj, Super, _) :- \+ '$lgt_pp_imported_category_'(_, _, _, _, _, _), \+ '$lgt_pp_specialized_class_'(_, _, _, _, _, _, _, _, _, _, _), \+ ('$lgt_pp_instantiated_class_'(Class, _, _, _, _, _, _, _, _, _, _), Class \= Obj), functor(Head, Super, 5), assertz('$lgt_pp_super_'((Head:-fail))), !. % ... or we may import some categories '$lgt_generate_ic_super_clauses'(Obj, Super, Rnm) :- '$lgt_pp_imported_category_'(Ctg, Obj, _, _, CDef, _), % the entity in the object execution context is usually the object itself % but it can also be a complementing category; thus, the argument must be % left uninstantiated but it will be bound by the runtime '$lgt_execution_context_update_this_entity'(OExCtx, _, Obj, CExCtx, Obj, Ctg), Lookup =.. [CDef, Pred, CExCtx, Call, TCtn], ( '$lgt_pp_predicate_alias_'(Ctg, _, _, _, _, _) -> Head =.. [Super, Alias, OExCtx, Call, Obj, TCtn], Rename =.. [Rnm, Ctg, Pred, Alias], assertz('$lgt_pp_super_'((Head :- Rename, Lookup))) ; Head =.. [Super, Pred, OExCtx, Call, Obj, TCtn], assertz('$lgt_pp_super_'((Head:-Lookup))) ), fail. % ... or predicates can be redefined in instances... '$lgt_generate_ic_super_clauses'(Obj, Super, Rnm) :- '$lgt_pp_instantiated_class_'(Class, Obj, _, _, _, _, _, CIDef, _, _, _), % we can ignore class self-instantiation, which is often used in reflective designs Class \= Obj, % the entity in the object execution context is usually the object itself % but it can also be a complementing category; thus, the argument must be % left uninstantiated but it will be bound by the runtime '$lgt_execution_context_update_this_entity'(OExCtx, _, Obj, CExCtx, Class, Class), Lookup =.. [CIDef, Pred, CExCtx, Call, SCtn, TCtn], % the following restriction allows us to distinguish the two "super" clauses that % are generated when an object both instantiates and specializes other objects '$lgt_execution_context'(OExCtx, _, _, Obj, Obj, _, _), ( '$lgt_pp_predicate_alias_'(Class, _, _, _, _, _) -> Head =.. [Super, Alias, OExCtx, Call, SCtn, TCtn], Rename =.. [Rnm, Class, Pred, Alias], assertz('$lgt_pp_super_'((Head :- Rename, Lookup))) ; Head =.. [Super, Pred, OExCtx, Call, SCtn, TCtn], assertz('$lgt_pp_super_'((Head:-Lookup))) ), fail. % ... or/and in subclasses... '$lgt_generate_ic_super_clauses'(Class, Super, Rnm) :- '$lgt_pp_specialized_class_'(Superclass, Class, _, _, _, _, _, SIDef, _, _, _), % the entity in the object execution context is usually the class itself % but it can also be a complementing category; thus, the argument must be % left uninstantiated but it will be bound by the runtime '$lgt_execution_context_update_this_entity'(CExCtx, _, Class, SExCtx, Superclass, Superclass), Lookup =.. [SIDef, Pred, SExCtx, Call, SCtn, TCtn], ( '$lgt_pp_predicate_alias_'(Superclass, _, _, _, _, _) -> Head =.. [Super, Alias, CExCtx, Call, SCtn, TCtn], Rename =.. [Rnm, Superclass, Pred, Alias], assertz('$lgt_pp_super_'((Head :- Rename, Lookup))) ; Head =.. [Super, Pred, CExCtx, Call, SCtn, TCtn], assertz('$lgt_pp_super_'((Head:-Lookup))) ), fail. '$lgt_generate_ic_super_clauses'(_, _, _). % '$lgt_compile_predicate_calls'(+atom) % % compiles predicate calls in entity clause rules and in initialization goals % % all predicate calls are compiled on this compiler second stage to take advantage % of the information about declared and defined predicates collected on the first % stage, thus making predicate declaration and definition order irrelevant; this % allows us to deal with e.g. meta-predicate directives and redefined built-in % predicates which may be textually defined in an entity after their calls '$lgt_compile_predicate_calls'(runtime) :- % avoid querying the optimize flag for each compiled term '$lgt_compiler_flag'(optimize, Optimize), '$lgt_compile_predicate_calls_loop'(silent, Optimize). '$lgt_compile_predicate_calls'(compile_time) :- % avoid querying the duplicated_clauses and optimize flags for each compiled term '$lgt_compiler_flag'(duplicated_clauses, DuplicatedClauses), '$lgt_compiler_flag'(optimize, Optimize), '$lgt_compile_predicate_calls_loop'(DuplicatedClauses, Optimize). % compilation of auxiliary clauses can result in the % creation of e.g. new auxiliary clauses or directives '$lgt_compile_predicate_calls_loop'(DuplicatedClauses, Optimize) :- '$lgt_compile_predicate_calls'(DuplicatedClauses, Optimize), fail. '$lgt_compile_predicate_calls_loop'(DuplicatedClauses, Optimize) :- ( ( '$lgt_pp_entity_aux_clause_'(_) ; '$lgt_pp_coinductive_'(_, _, _, _, _, _, _, _, _) ; '$lgt_pp_object_initialization_'(_, _, _) ; '$lgt_pp_entity_meta_directive_'(_, _, _) ) -> '$lgt_compile_predicate_calls_loop'(DuplicatedClauses, Optimize) ; true ). '$lgt_compile_predicate_calls'(warning, Optimize) :- % user-defined terms; as SourceData may be nil, we cannot perform the % unification in the retract/1 goal otherwise we could skip terms retract('$lgt_pp_entity_term_'(Term, SourceData, _)), ( SourceData = sd(Original, _, _, OriginalFile, OriginalLines), % exclude directives Original \= (:- _), '$lgt_pp_entity_'(Type, Entity, _), '$lgt_internal_term_template'(Term, Template), '$lgt_pp_entity_term_'(Template, sd(Duplicate, _, _, File, Lines), _), '$lgt_variant'(Original, Duplicate) -> '$lgt_increment_compiling_warnings_counter', ( Original = (_ --> _) -> '$lgt_print_message'( warning(duplicated_clauses), duplicated_grammar_rule(File, Lines, Type, Entity, Original, OriginalFile, OriginalLines) ) ; '$lgt_print_message'( warning(duplicated_clauses), duplicated_clause(File, Lines, Type, Entity, Original, OriginalFile, OriginalLines) ) ) ; true ), '$lgt_compile_predicate_calls'(Term, SourceData, Optimize, TTerm), assertz('$lgt_pp_final_entity_term_'(TTerm, Lines)), fail. '$lgt_compile_predicate_calls'(silent, Optimize) :- % user-defined terms retract('$lgt_pp_entity_term_'(Term, SourceData, Lines)), '$lgt_compile_predicate_calls'(Term, SourceData, Optimize, TTerm), assertz('$lgt_pp_final_entity_term_'(TTerm, Lines)), fail. '$lgt_compile_predicate_calls'(_, _) :- retract('$lgt_pp_coinductive_'(Head, TestHead, HeadExCtx, TCHead, BodyExCtx, THead, DHead, _, _)), '$lgt_pp_defines_predicate_'(Head, _, _, _, _, _), '$lgt_add_coinductive_predicate_aux_clause'(Head, TestHead, HeadExCtx, TCHead, BodyExCtx, THead, DHead), fail. '$lgt_compile_predicate_calls'(_, Optimize) :- % other auxiliary clauses retract('$lgt_pp_entity_aux_clause_'(Clause)), '$lgt_compile_predicate_calls'(Clause, nil, Optimize, TClause), assertz('$lgt_pp_final_entity_aux_clause_'(TClause)), fail. '$lgt_compile_predicate_calls'(_, Optimize) :- % initialization/1 goals retract('$lgt_pp_object_initialization_'(Goal, SourceData, Lines)), '$lgt_compile_predicate_calls'(Goal, SourceData, Optimize, TGoal), assertz('$lgt_pp_final_object_initialization_'(TGoal, Lines)), fail. '$lgt_compile_predicate_calls'(_, Optimize) :- % other initialization goals found on proprietary Prolog directives retract('$lgt_pp_entity_meta_directive_'(Directive, SourceData, _)), '$lgt_compile_predicate_calls'(Directive, SourceData, Optimize, TDirective), assertz('$lgt_pp_directive_'(TDirective)), fail. '$lgt_compile_predicate_calls'(_, _). % auxiliary predicate used when checking for duplicated clauses '$lgt_internal_term_template'(srule(_,_,_), srule(_,_,_)). '$lgt_internal_term_template'(dsrule(_,_,_,_), dsrule(_,_,_,_)). '$lgt_internal_term_template'(drule(_,_,_,_), drule(_,_,_,_)). '$lgt_internal_term_template'(ddrule(_,_,_,_,_), ddrule(_,_,_,_,_)). '$lgt_internal_term_template'(fact(_,_), fact(_,_)). '$lgt_internal_term_template'(dfact(_,_,_), dfact(_,_,_)). % '$lgt_compile_predicate_calls'(+callable, +compound, +atom, -callable) % entity term is final '$lgt_compile_predicate_calls'({Term}, _, _, Term). '$lgt_compile_predicate_calls'(fact(TFact,_), _, _, TFact). % debug version of a predicate fact '$lgt_compile_predicate_calls'(dfact(TFact,DHead,_), _, _, (TFact:-DHead)). % static predicate rule '$lgt_compile_predicate_calls'(srule(THead,Body,Ctx), SourceData, Optimize, TClause) :- '$lgt_add_source_data'(SourceData), catch( '$lgt_compile_body'(Body, rule, FBody, _, Ctx), Error, ('$lgt_comp_ctx_head'(Ctx,Head), throw(error(Error,clause((Head:-Body))))) ), ( Optimize == on -> '$lgt_simplify_goal'(FBody, SBody) ; SBody = FBody ), ( SBody == true -> TClause = THead ; TClause = (THead:-SBody) ). % debug version of static predicate rule '$lgt_compile_predicate_calls'(dsrule(THead,DHead,Body,Ctx), SourceData, _, (THead:-DHead,DBody)) :- '$lgt_add_source_data'(SourceData), catch( '$lgt_compile_body'(Body, rule, _, DBody, Ctx), Error, ('$lgt_comp_ctx_head'(Ctx,Head), throw(error(Error,clause((Head:-Body))))) ). % dynamic predicate rule '$lgt_compile_predicate_calls'(drule(THead,Nop,Body,Ctx), SourceData, Optimize, TClause) :- '$lgt_add_source_data'(SourceData), catch( '$lgt_compile_body'(Body, rule, TBody0, _, Ctx), Error, ('$lgt_comp_ctx_head'(Ctx,Head), throw(error(Error,clause((Head:-Body))))) ), ( Optimize == on -> '$lgt_simplify_goal'(TBody0, TBody) ; TBody = TBody0 ), ( TBody == true -> TClause = (THead:-Nop) ; TClause = (THead:-Nop,TBody) ). % debug version of dynamic predicate rule '$lgt_compile_predicate_calls'(ddrule(THead,Nop,DHead,Body,Ctx), SourceData, _, (THead:-Nop,DHead,DBody)) :- '$lgt_add_source_data'(SourceData), catch( '$lgt_compile_body'(Body, rule, _, DBody, Ctx), Error, ('$lgt_comp_ctx_head'(Ctx,Head), throw(error(Error,clause((Head:-Body))))) ). % initialization goal '$lgt_compile_predicate_calls'(goal(Body,Ctx), SourceData, Optimize, TBody) :- '$lgt_add_source_data'(SourceData), catch( '$lgt_compile_body'(Body, directive, TBody0, _, Ctx), Error, throw(error(Error, directive(initialization(Body)))) ), ( Optimize == on -> '$lgt_simplify_goal'(TBody0, TBody) ; TBody = TBody0 ). % debug version of initialization goal '$lgt_compile_predicate_calls'(dgoal(Body,Ctx), SourceData, _, DBody) :- '$lgt_add_source_data'(SourceData), catch( '$lgt_compile_body'(Body, directive, _, DBody, Ctx), Error, throw(error(Error, directive(initialization(Body)))) ). % supported Prolog meta-directives (specified in the adapter files) '$lgt_compile_predicate_calls'(directive(Directive,Meta), SourceData, _, TDirective) :- '$lgt_add_source_data'(SourceData), Directive =.. [Functor| Args], Meta =.. [Functor| MArgs], '$lgt_pp_entity_'(_, Entity, Prefix), % MetaVars = [] as we're compiling a local call '$lgt_comp_ctx'(Ctx, _, _, Entity, Entity, Entity, Entity, Prefix, [], _, _, _, [], _, _), ( catch( '$lgt_compile_prolog_meta_arguments'(Args, MArgs, meta, Ctx, TArgs, DArgs), Error, throw(error(Error, directive(Directive))) ) -> ( '$lgt_compiler_flag'(debug, on) -> TDirective =.. [Functor| DArgs] ; TDirective =.. [Functor| TArgs] ) ; % the meta-directive template is not usable, report it as an error throw(error(domain_error(meta_directive_template, Meta), directive(Directive))) ). '$lgt_add_source_data'(nil) :- retractall('$lgt_pp_term_source_data_'(_, _, _, _, _)). '$lgt_add_source_data'(sd(Term, VariableNames, Singletons, File, Lines)) :- retractall('$lgt_pp_term_source_data_'(_, _, _, _, _)), assertz('$lgt_pp_term_source_data_'(Term, VariableNames, Singletons, File, Lines)). '$lgt_add_coinductive_predicate_aux_clause'(Head, TestHead, HeadExCtx, TCHead, BodyExCtx, THead, DHead) :- '$lgt_execution_context'(HeadExCtx, Entity, Sender, This, Self, MetaCallCtx, HeadStack), '$lgt_execution_context'(BodyExCtx, Entity, Sender, This, Self, MetaCallCtx, BodyStack), '$lgt_coinductive_success_hook'(Head, Hypothesis, HeadExCtx, HeadStack, BodyStack, Hook), ( '$lgt_compiler_flag'(debug, on) -> Header = '$lgt_debug'(rule(Entity, DHead, 0, nil, 0), BodyExCtx), If = '$lgt_debug'(goal(check_coinductive_success(TestHead, HeadStack), '$lgt_check_coinductive_success'(TestHead, HeadStack, Hypothesis)), BodyExCtx), Then = '$lgt_debug'(goal(coinductive_success_hook(Head, Hypothesis), Hook), BodyExCtx), Else = ( '$lgt_debug'(goal(push_coinductive_hypothesis(TestHead, HeadStack, BodyStack), BodyStack = [Head| HeadStack]), BodyExCtx), '$lgt_debug'(goal(Head, THead), BodyExCtx) ) ; Header = true, If = '$lgt_check_coinductive_success'(TestHead, HeadStack, Hypothesis), Then = Hook, Else = (BodyStack = [Head| HeadStack], THead) ), ( '$lgt_prolog_built_in_predicate'('*->'(_, _)) -> % backend Prolog compiler supports the soft-cut control construct assertz('$lgt_pp_entity_aux_clause_'({(TCHead :- Header, ('*->'(If, Then); Else))})) ; '$lgt_prolog_built_in_predicate'(if(_, _, _)) -> % backend Prolog compiler supports the if/3 soft-cut built-in meta-predicate assertz('$lgt_pp_entity_aux_clause_'({(TCHead :- Header, if(If, Then, Else))})) ; % the adapter file for the backend Prolog compiler declares that coinduction % is supported but it seems to be missing the necessary declaration for the % soft-cut control construct or meta-predicate throw(resource_error(soft_cut_support)) ). '$lgt_coinductive_success_hook'(Head, Hypothesis, ExCtx, HeadStack, BodyStack, Hook) :- % ensure zero performance penalties when defining coinductive predicates without a definition % for the coinductive success hook predicates ( '$lgt_pp_defines_predicate_'(coinductive_success_hook(Head,Hypothesis), _, ExCtx, THead, _, _), \+ \+ ( '$lgt_pp_final_entity_term_'(THead, _) ; '$lgt_pp_final_entity_term_'((THead :- _), _) ) -> % ... with at least one clause for this particular coinductive predicate head Hook = ((HeadStack = BodyStack), THead) ; % we only consider coinductive_success_hook/1 clauses if no coinductive_success_hook/2 clause applies '$lgt_pp_defines_predicate_'(coinductive_success_hook(Head), _, ExCtx, THead, _, _), \+ \+ ( '$lgt_pp_final_entity_term_'(THead, _) ; '$lgt_pp_final_entity_term_'((THead :- _), _) ) -> % ... with at least one clause for this particular coinductive predicate head Hook = ((HeadStack = BodyStack), THead) ; % no hook predicates defined or defined but with no clauses for this particular coinductive predicate head Hook = (HeadStack = BodyStack) ). % reports missing predicate directives '$lgt_report_missing_directives'(_, _) :- '$lgt_compiler_flag'(missing_directives, silent), !. % reports missing scope directives for dynamic predicates '$lgt_report_missing_directives'(category, Entity) :- '$lgt_pp_dynamic_'(Head, Original, File, Lines), % declared dynamic predicate or non-terminal in a category are for objects functor(Head, Functor, Arity), \+ '$lgt_pp_public_'(Functor, Arity, _, _), \+ '$lgt_pp_protected_'(Functor, Arity, _, _), \+ '$lgt_pp_private_'(Functor, Arity, _, _), % but missing corresponding scope directive \+ '$lgt_pp_implemented_protocol_'(_, _, _, _, _), \+ '$lgt_pp_extended_category_'(_, _, _, _, _, _), % nowhere from inheriting a predicate scope declaration '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(missing_directives), missing_scope_directive(File, Lines, category, Entity, (dynamic)/1, Original) ), fail. % reports missing scope directives for multifile predicates '$lgt_report_missing_directives'(Type, Entity) :- '$lgt_pp_multifile_'(Head, Original, File, Lines), % declared multifile predicate functor(Head, Functor, Arity), \+ '$lgt_pp_public_'(Functor, Arity, _, _), \+ '$lgt_pp_protected_'(Functor, Arity, _, _), \+ '$lgt_pp_private_'(Functor, Arity, _, _), % but missing corresponding scope directive '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(missing_directives), missing_scope_directive(File, Lines, Type, Entity, (multifile)/1, Original) ), fail. % reports missing meta_predicate/1 directives for meta-predicates '$lgt_report_missing_directives'(Type, Entity) :- '$lgt_pp_missing_meta_predicate_directive_'(Head, File, Lines), functor(Head, Functor, Arity), '$lgt_increment_compiling_warnings_counter', ( '$lgt_pp_defines_non_terminal_'(Functor, NonTerminalArity, Arity) -> '$lgt_print_message'( warning(missing_directives), missing_predicate_directive(File, Lines, Type, Entity, (meta_non_terminal)/1, Functor//NonTerminalArity) ) ; '$lgt_print_message'( warning(missing_directives), missing_predicate_directive(File, Lines, Type, Entity, (meta_predicate)/1, Functor/Arity) ) ), fail. % reports missing multifile/1 directives '$lgt_report_missing_directives'(Type, Entity) :- '$lgt_pp_missing_multifile_directive_'(PI, File, Lines), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(missing_directives), missing_predicate_directive(File, Lines, Type, Entity, (multifile)/1, PI) ), fail. % reports missing dynamic/1 directives '$lgt_report_missing_directives'(Type, Entity) :- '$lgt_pp_missing_dynamic_directive_'(Head, File, Lines), functor(Head, Functor, Arity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(missing_directives), missing_predicate_directive(File, Lines, Type, Entity, (dynamic)/1, Functor/Arity) ), fail. % reports missing discontiguous/1 directives '$lgt_report_missing_directives'(Type, Entity) :- '$lgt_pp_missing_discontiguous_directive_'(Head, File, Lines), functor(Head, Functor, Arity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(missing_directives), missing_predicate_directive(File, Lines, Type, Entity, (discontiguous)/1, Functor/Arity) ), fail. % reports missing scope directives for mode2 and info/2 directives '$lgt_report_missing_directives'(Type, Entity) :- ( '$lgt_pp_mode_'(Mode, _, File, Lines), functor(Mode, Functor, Arity), Directive = (mode)/2 ; '$lgt_pp_predicate_info_'(Functor/Arity, _, File, Lines), Directive = info/2 ), % documented predicate or non-terminal \+ '$lgt_pp_non_terminal_'(Functor, Arity, _), \+ '$lgt_pp_public_'(Functor, Arity, _, _), \+ '$lgt_pp_protected_'(Functor, Arity, _, _), \+ '$lgt_pp_private_'(Functor, Arity, _, _), % but missing scope directive '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(missing_directives), missing_scope_directive(File, Lines, Type, Entity, Directive, Functor/Arity) ), fail. '$lgt_report_missing_directives'(Type, Entity) :- ( Type == object -> '$lgt_pp_referenced_object_'(Entity, File, Lines) ; Type == category -> '$lgt_pp_referenced_category_'(Entity, File, Lines) ; % Type == protocol fail ), setof(Predicate, '$lgt_pp_missing_use_module_directive_'(Module, Predicate), Predicates), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(missing_directives), missing_predicate_directive(File, Lines, Type, Entity, (:- use_module(Module,Predicates))) ), fail. '$lgt_report_missing_directives'(_, _). % '$lgt_report_unknown_predicate_call'(@compilation_mode, @callable, @lines) % % reports unknown predicates and non-terminals '$lgt_report_unknown_predicate_call'(runtime, _, _). '$lgt_report_unknown_predicate_call'(compile(_,_,_), Pred, Lines) :- '$lgt_compiler_flag'(unknown_predicates, Value), '$lgt_report_unknown_predicate_call_aux'(Value, Pred, Lines). '$lgt_report_unknown_predicate_call_aux'(silent, _, _). '$lgt_report_unknown_predicate_call_aux'(error, Functor/Arity, _) :- ( '$lgt_pp_calls_non_terminal_'(Functor, Arity2, Arity, _) -> throw(existence_error(non_terminal, Functor//Arity2)) ; throw(existence_error(predicate, Functor/Arity)) ). '$lgt_report_unknown_predicate_call_aux'(warning, Functor/Arity, Lines) :- % we may be compiling an auxiliary clause and thus unable % to use the '$lgt_source_file_context'/4 predicate ( '$lgt_source_file_context'(File, Lines, Type, Entity) -> true ; '$lgt_pp_file_paths_flags_'(_, _, File, _, _), '$lgt_pp_entity_'(Type, Entity, _) ), '$lgt_increment_compiling_warnings_counter', ( '$lgt_pp_calls_non_terminal_'(Functor, Arity2, Arity, _) -> '$lgt_print_message'( warning(unknown_predicates), unknown_non_terminal_called_but_not_defined(File, Lines, Type, Entity, Functor//Arity2) ) ; '$lgt_print_message'( warning(unknown_predicates), unknown_predicate_called_but_not_defined(File, Lines, Type, Entity, Functor/Arity) ) ). % '$lgt_report_undefined_predicate_call'(@compilation_mode, @callable, @lines) % % reports calls to declared, static, but undefined predicates and non-terminals '$lgt_report_undefined_predicate_call'(runtime, _, _). '$lgt_report_undefined_predicate_call'(compile(_,_,_), Pred, Lines) :- '$lgt_compiler_flag'(undefined_predicates, Value), '$lgt_report_undefined_predicate_call_aux'(Value, Pred, Lines). '$lgt_report_undefined_predicate_call_aux'(silent, _, _). '$lgt_report_undefined_predicate_call_aux'(error, Functor/Arity, _) :- ( '$lgt_pp_calls_non_terminal_'(Functor, Arity2, Arity, _) -> throw(existence_error(procedure, Functor//Arity2)) ; throw(existence_error(procedure, Functor/Arity)) ). '$lgt_report_undefined_predicate_call_aux'(warning, Functor/Arity, Lines) :- % we may be compiling an auxiliary clause and thus unable % to use the '$lgt_source_file_context'/4 predicate ( '$lgt_source_file_context'(File, Lines, Type, Entity) -> true ; '$lgt_pp_file_paths_flags_'(_, _, File, _, _), '$lgt_pp_entity_'(Type, Entity, _) ), '$lgt_increment_compiling_warnings_counter', ( '$lgt_pp_calls_non_terminal_'(Functor, Arity2, Arity, _) -> '$lgt_print_message'( warning(undefined_predicates), declared_static_non_terminal_called_but_not_defined(File, Lines, Type, Entity, Functor//Arity2) ) ; '$lgt_print_message'( warning(undefined_predicates), declared_static_predicate_called_but_not_defined(File, Lines, Type, Entity, Functor/Arity) ) ). % '$lgt_report_non_portable_calls'(@entity_type, @entity_identifier) % % reports non-portable predicate and function calls in the body of object and category predicates '$lgt_report_non_portable_calls'(protocol, _) :- !. '$lgt_report_non_portable_calls'(_, _) :- '$lgt_compiler_flag'(portability, silent), !. '$lgt_report_non_portable_calls'(Type, Entity) :- '$lgt_pp_non_portable_predicate_'(Head, File, Lines), functor(Head, Functor, Arity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(portability), non_standard_predicate_call(File, Lines, Type, Entity, Functor/Arity) ), fail. '$lgt_report_non_portable_calls'(Type, Entity) :- '$lgt_pp_non_portable_function_'(Function, File, Lines), functor(Function, Functor, Arity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(portability), non_standard_arithmetic_function_call(File, Lines, Type, Entity, Functor/Arity) ), fail. '$lgt_report_non_portable_calls'(_, _). % '$lgt_report_missing_functions'(@entity_type, @entity_identifier) % % reports non-portable predicate and function calls in the body of object and category predicates '$lgt_report_missing_functions'(protocol, _) :- !. '$lgt_report_missing_functions'(_, _) :- '$lgt_compiler_flag'(portability, silent), !. '$lgt_report_missing_functions'(Type, Entity) :- '$lgt_pp_missing_function_'(Function, File, Lines), functor(Function, Functor, Arity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(portability), missing_function(File, Lines, Type, Entity, Functor/Arity) ), fail. '$lgt_report_missing_functions'(_, _). % '$lgt_report_predicates_called_as_non_terminals'(@entity_type, @entity_identifier) % % reports calls to predicates as non-terminals from grammar rules '$lgt_report_predicates_called_as_non_terminals'(protocol, _) :- !. '$lgt_report_predicates_called_as_non_terminals'(_, _) :- '$lgt_compiler_flag'(grammar_rules, silent), !. '$lgt_report_predicates_called_as_non_terminals'(Type, Entity) :- '$lgt_pp_calls_non_terminal_'(Functor, Arity, ExtArity, Lines), \+ '$lgt_pp_defines_non_terminal_'(Functor, Arity, ExtArity), '$lgt_pp_defines_predicate_'(_, Functor/ExtArity, _, _, _, _), % actually require at least one clause to be defined as the predicate may be dynamic '$lgt_pp_number_of_clauses_rules_'(Functor, ExtArity, _, _), '$lgt_pp_file_paths_flags_'(_, _, File, _, _), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(grammar_rules), calls_predicate_as_non_terminal(File, Lines, Type, Entity, Functor/ExtArity) ), fail. '$lgt_report_predicates_called_as_non_terminals'(_, _). % '$lgt_report_non_tail_recursive_predicates'(@entity_type, @entity_identifier) % % reports non-tail recursive predicate definitions '$lgt_report_non_tail_recursive_predicates'(protocol, _) :- !. '$lgt_report_non_tail_recursive_predicates'(Type, Entity) :- '$lgt_compiler_flag'(tail_recursive, warning), '$lgt_pp_non_tail_recursive_predicate_'(Functor, Arity, File, Lines), '$lgt_pp_predicate_recursive_calls_'(Functor, Arity, Count), Count =:= 1, '$lgt_increment_compiling_warnings_counter', ( '$lgt_pp_defines_non_terminal_'(Functor, Arity2, Arity) -> '$lgt_print_message'( warning(tail_recursive), non_tail_recursive_non_terminal(File, Lines, Type, Entity, Functor//Arity2) ) ; '$lgt_print_message'( warning(tail_recursive), non_tail_recursive_predicate(File, Lines, Type, Entity, Functor/Arity) ) ), fail. '$lgt_report_non_tail_recursive_predicates'(_, _). % '$lgt_write_encoding_directive'(@stream, +atom) % % writes the encoding/1 directive (if supported in generated code); % it must be the first term in the file '$lgt_write_encoding_directive'(Stream, Path) :- ( '$lgt_prolog_feature'(encoding_directive, full), '$lgt_pp_file_encoding_'(Path, _, Encoding, _) -> '$lgt_write_compiled_term'(Stream, (:- encoding(Encoding)), runtime, Path, 1) ; true ). % '$lgt_write_entity_directives'(@stream, +atom) % % writes the compiled entity directives '$lgt_write_entity_directives'(Stream, Path) :- '$lgt_pp_directive_'(Directive), '$lgt_write_compiled_term'(Stream, (:- Directive), runtime, Path, 1), fail. '$lgt_write_entity_directives'(_, _). % '$lgt_write_prolog_terms'(@stream, atom) % % writes any Prolog clauses that appear before an entity opening directive '$lgt_write_prolog_terms'(Stream, Path) :- '$lgt_pp_prolog_term_'(Term, Line-_), '$lgt_write_compiled_term'(Stream, Term, user, Path, Line), fail. '$lgt_write_prolog_terms'(_, _). % '$lgt_write_entity_clauses'(@stream, +atom, +atom) % % writes Logtalk entity clauses '$lgt_write_entity_clauses'(Stream, Path, _) :- '$lgt_pp_dcl_'(Clause), '$lgt_write_compiled_term'(Stream, Clause, runtime, Path, 1), fail. '$lgt_write_entity_clauses'(Stream, Path, _) :- '$lgt_pp_def_'(Clause), '$lgt_write_compiled_term'(Stream, Clause, runtime, Path, 1), fail. '$lgt_write_entity_clauses'(Stream, Path, _) :- '$lgt_pp_ddef_'(Clause), '$lgt_write_compiled_term'(Stream, Clause, runtime, Path, 1), fail. '$lgt_write_entity_clauses'(Stream, Path, _) :- '$lgt_pp_super_'(Clause), '$lgt_write_compiled_term'(Stream, Clause, runtime, Path, 1), fail. '$lgt_write_entity_clauses'(Stream, Path, Rnm) :- '$lgt_pp_predicate_alias_'(Entity, Pred, Alias, _, _, _), Clause =.. [Rnm, Entity, Pred, Alias], '$lgt_write_compiled_term'(Stream, Clause, runtime, Path, 1), fail. '$lgt_write_entity_clauses'(Stream, Path, Rnm) :- Catchall =.. [Rnm, _, Pred, Pred], '$lgt_write_compiled_term'(Stream, Catchall, runtime, Path, 1), fail. '$lgt_write_entity_clauses'(Stream, Path, _) :- '$lgt_pp_final_entity_term_'(Clause, Line-_), '$lgt_write_compiled_term'(Stream, Clause, user, Path, Line), fail. '$lgt_write_entity_clauses'(Stream, Path, _) :- '$lgt_pp_final_entity_aux_clause_'(Clause), '$lgt_write_compiled_term'(Stream, Clause, aux, Path, 1), fail. '$lgt_write_entity_clauses'(_, _, _). % '$lgt_write_runtime_clauses'(@stream, +atom) % % writes the entity runtime multifile and dynamic directives and the entity % runtime clauses for all defined entities '$lgt_write_runtime_clauses'(Stream, Path) :- '$lgt_write_runtime_dynamic_clauses'(Stream, Path, '$lgt_current_protocol_'/5), '$lgt_write_runtime_dynamic_clauses'(Stream, Path, '$lgt_current_category_'/6), '$lgt_write_runtime_dynamic_clauses'(Stream, Path, '$lgt_current_object_'/11), '$lgt_write_runtime_dynamic_clauses'(Stream, Path, '$lgt_entity_property_'/2), '$lgt_write_runtime_dynamic_clauses'(Stream, Path, '$lgt_predicate_property_'/3), '$lgt_write_runtime_dynamic_clauses'(Stream, Path, '$lgt_implements_protocol_'/3), '$lgt_write_runtime_dynamic_clauses'(Stream, Path, '$lgt_imports_category_'/3), '$lgt_write_runtime_dynamic_clauses'(Stream, Path, '$lgt_instantiates_class_'/3), '$lgt_write_runtime_dynamic_clauses'(Stream, Path, '$lgt_specializes_class_'/3), '$lgt_write_runtime_dynamic_clauses'(Stream, Path, '$lgt_extends_category_'/3), '$lgt_write_runtime_dynamic_clauses'(Stream, Path, '$lgt_extends_object_'/3), '$lgt_write_runtime_dynamic_clauses'(Stream, Path, '$lgt_extends_protocol_'/3), '$lgt_write_runtime_static_clauses'(Stream, Path, '$lgt_uses_predicate_'/5), '$lgt_write_runtime_static_clauses'(Stream, Path, '$lgt_use_module_predicate_'/5), '$lgt_write_runtime_dynamic_clauses'(Stream, Path, '$lgt_loaded_file_'/7), '$lgt_write_runtime_dynamic_clauses'(Stream, Path, '$lgt_included_file_'/4). '$lgt_write_runtime_dynamic_clauses'(Stream, Path, Functor/Arity) :- functor(Clause, Functor, Arity), ( \+ '$lgt_pp_runtime_clause_'(Clause) -> true ; '$lgt_write_compiled_term'(Stream, (:- multifile(Functor/Arity)), runtime, Path, 1), '$lgt_write_compiled_term'(Stream, (:- dynamic(Functor/Arity)), runtime, Path, 1), ( '$lgt_pp_runtime_clause_'(Clause), '$lgt_write_compiled_term'(Stream, Clause, runtime, Path, 1), fail ; true ) ). '$lgt_write_runtime_static_clauses'(Stream, Path, Functor/Arity) :- functor(Clause, Functor, Arity), ( \+ '$lgt_pp_runtime_clause_'(Clause) -> true ; '$lgt_write_compiled_term'(Stream, (:- multifile(Functor/Arity)), runtime, Path, 1), ( '$lgt_pp_runtime_clause_'(Clause), '$lgt_write_compiled_term'(Stream, Clause, runtime, Path, 1), fail ; true ) ). % '$lgt_write_initialization_directive'(@stream, +atom) % % writes the initialization directive for the compiled source file, % a conjunction of the initialization goals of the defined entities '$lgt_write_initialization_directive'(Stream, Path) :- '$lgt_initialization_goal'(Goal), ( Goal == true -> true ; '$lgt_write_compiled_term'(Stream, (:- initialization(Goal)), runtime, Path, 1) ). % '$lgt_initialization_goal'(-callable) % % source file initialization goal constructed from object initialization % directives and from source file initialization/1 directives if present '$lgt_initialization_goal'(InitializationGoal) :- findall( Line-Goal, ( '$lgt_pp_file_entity_initialization_'(_, Goal, Line-_) ; '$lgt_pp_file_initialization_'(Goal, Line-_) ), LineGoals ), % ensure source file textual order for the initialization goals % (this assumes that the backend Prolog system provides access to % read term position...) keysort(LineGoals, SortedLineGoals), findall( Goal, '$lgt_member'(_-Goal, SortedLineGoals), Goals ), '$lgt_list_to_conjunction'(Goals, InitializationGoal). % converts a list of goals into a conjunction of goals '$lgt_list_to_conjunction'([], true). '$lgt_list_to_conjunction'([Goal| Goals], Conjunction) :- '$lgt_list_to_conjunction'(Goals, Goal, Conjunction). '$lgt_list_to_conjunction'([], Conjunction, Conjunction). '$lgt_list_to_conjunction'([Next| Goals], Goal, (Goal,Conjunction)) :- '$lgt_list_to_conjunction'(Goals, Next, Conjunction). % converts a conjunction into a list of terms '$lgt_conjunction_to_list'(Term, [Term]) :- var(Term), !. '$lgt_conjunction_to_list'((Term, Conjunction), [Term| Terms]) :- !, '$lgt_conjunction_to_list'(Conjunction, Terms). '$lgt_conjunction_to_list'(Term, [Term]). % generates and asserts the initialization goal for the object being compiled '$lgt_generate_file_object_initialization_goal' :- '$lgt_pp_entity_'(_, Object, Prefix), ( '$lgt_prolog_feature'(threads, supported), setof(Mutex, Head^File^Lines^'$lgt_pp_synchronized_'(Head, Mutex, File, Lines), Mutexes) -> Goal1 = '$lgt_create_mutexes'(Mutexes) ; Goal1 = true ), ( '$lgt_pp_threaded_' -> Goal2 = '$lgt_init_object_message_queue'(Prefix) ; Goal2 = true ), % an object may contain multiple initialization/1 directives ( bagof(ObjectInitGoal, Lines^'$lgt_pp_final_object_initialization_'(ObjectInitGoal, Lines), ObjectInitGoals) -> '$lgt_list_to_conjunction'(ObjectInitGoals, Goal3), '$lgt_remove_redundant_calls'((Goal1, Goal2, Goal3), Goal) ; '$lgt_remove_redundant_calls'((Goal1, Goal2), Goal) ), ( Goal == true -> true ; '$lgt_pp_referenced_object_'(Object, _File, Lines), assertz('$lgt_pp_file_entity_initialization_'(Object, Goal, Lines)) ). % generates and asserts the initialization goal for the category being compiled '$lgt_generate_file_category_initialization_goal' :- ( '$lgt_prolog_feature'(threads, supported), setof(Mutex, Head^File^Lines^'$lgt_pp_synchronized_'(Head, Mutex, File, Lines), Mutexes) -> '$lgt_pp_referenced_category_'(Category, _File, Lines), assertz('$lgt_pp_file_entity_initialization_'(Category, '$lgt_create_mutexes'(Mutexes), Lines)) ; true ). % '$lgt_assert_dynamic_entity'(+atom) % % adds a dynamically created entity to memory '$lgt_assert_dynamic_entity'(object) :- '$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, Rnm, _), '$lgt_assert_dynamic_entity'(object, Rnm), '$lgt_call_initialization_goal'. '$lgt_assert_dynamic_entity'(protocol) :- '$lgt_pp_protocol_'(_, _, _, Rnm, _), '$lgt_assert_dynamic_entity'(protocol, Rnm), '$lgt_call_initialization_goal'. '$lgt_assert_dynamic_entity'(category) :- '$lgt_pp_category_'(_, _, _, _, Rnm, _), '$lgt_assert_dynamic_entity'(category, Rnm), '$lgt_call_initialization_goal'. '$lgt_assert_dynamic_entity'(_, _) :- '$lgt_pp_directive_'(dynamic(Functor/Arity)), functor(Pred, Functor, Arity), asserta(Pred), retract(Pred), fail. '$lgt_assert_dynamic_entity'(_, _) :- '$lgt_pp_dcl_'(Clause), '$lgt_assertz_entity_clause'(Clause, aux), fail. '$lgt_assert_dynamic_entity'(_, _) :- '$lgt_pp_def_'(Clause), '$lgt_assertz_entity_clause'(Clause, aux), fail. '$lgt_assert_dynamic_entity'(_, _) :- '$lgt_pp_ddef_'(Clause), '$lgt_assertz_entity_clause'(Clause, aux), fail. '$lgt_assert_dynamic_entity'(_, _) :- '$lgt_pp_super_'(Clause), '$lgt_assertz_entity_clause'(Clause, aux), fail. '$lgt_assert_dynamic_entity'(_, Rnm) :- '$lgt_pp_predicate_alias_'(Entity, Pred, Alias, _, _, _), Clause =.. [Rnm, Entity, Pred, Alias], '$lgt_assertz_entity_clause'(Clause, aux), fail. '$lgt_assert_dynamic_entity'(_, Rnm) :- Catchall =.. [Rnm, _, Pred, Pred], '$lgt_assertz_entity_clause'(Catchall, aux), fail. '$lgt_assert_dynamic_entity'(_, _) :- '$lgt_pp_final_entity_term_'(Clause, _), '$lgt_assertz_entity_clause'(Clause, user), fail. '$lgt_assert_dynamic_entity'(_, _) :- '$lgt_pp_final_entity_aux_clause_'(Clause), '$lgt_assertz_entity_clause'(Clause, aux), fail. '$lgt_assert_dynamic_entity'(Type, _) :- '$lgt_save_entity_runtime_clause'(Type), fail. '$lgt_assert_dynamic_entity'(_, _) :- '$lgt_pp_runtime_clause_'(Clause), '$lgt_assertz_entity_clause'(Clause, aux), fail. '$lgt_assert_dynamic_entity'(_, _). % '$lgt_call_initialization_goal' % % calls any defined initialization goals for a dynamically created entity '$lgt_call_initialization_goal' :- ( '$lgt_prolog_feature'(threads, supported), setof(Mutex, Head^File^Lines^'$lgt_pp_synchronized_'(Head, Mutex, File, Lines), Mutexes) -> '$lgt_create_mutexes'(Mutexes) ; true ), ( '$lgt_pp_object_'(_, Prefix, _, _, _, _, _, _, _, _, _), '$lgt_pp_threaded_' -> '$lgt_init_object_message_queue'(Prefix) ; true ), % an object may contain multiple initialization/1 directives ( bagof(Goal, Lines^'$lgt_pp_final_object_initialization_'(Goal, Lines), GoalList) -> '$lgt_list_to_conjunction'(GoalList, Goals), once(Goals) ; true ), % complementing categories add a file initialization goal ( '$lgt_pp_file_initialization_'(InitializationGoal, _) -> once(InitializationGoal) ; true ). % '$lgt_construct_prototype_functors'(+object_identifier, -atom, -atom, -atom, -atom, -atom, -atom, -atom, -atom, -atom) % % constructs functors used in the compiled code of an object playing the role of a prototype '$lgt_construct_prototype_functors'(Obj, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Rnm) :- ( '$lgt_current_object_'(Obj, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Rnm, Flags), Flags /\ 1 =:= 1 -> % loaded, built-in object true ; '$lgt_construct_entity_prefix'(Obj, Prefix), atom_concat(Prefix, '_dcl', Dcl), atom_concat(Prefix, '_def', Def), atom_concat(Prefix, '_super', Super), IDcl = Dcl, IDef = Def, atom_concat(Prefix, '_ddcl', DDcl), atom_concat(Prefix, '_ddef', DDef), atom_concat(Prefix, '_alias', Rnm) ). % '$lgt_construct_ic_functors'(+object_identifier, -atom, -atom, -atom, -atom, -atom, -atom, -atom, -atom, -atom) % % constructs functors used in the compiled code of an object playing the role of a class or an instance '$lgt_construct_ic_functors'(Obj, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Rnm) :- ( '$lgt_current_object_'(Obj, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Rnm, Flags), Flags /\ 1 =:= 1 -> % loaded, built-in object true ; '$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 '$lgt_construct_protocol_functors'(Ptc, Prefix, Dcl, Rnm) :- ( '$lgt_current_protocol_'(Ptc, Prefix, Dcl, Rnm, Flags), Flags /\ 1 =:= 1 -> % loaded, built-in protocol true ; '$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 '$lgt_construct_category_functors'(Ctg, Prefix, Dcl, Def, Rnm) :- ( '$lgt_current_category_'(Ctg, Prefix, Dcl, Def, Rnm, Flags), Flags /\ 1 =:= 1 -> % loaded, built-in category true ; '$lgt_construct_entity_prefix'(Ctg, Prefix), atom_concat(Prefix, '_dcl', Dcl), atom_concat(Prefix, '_def', Def), atom_concat(Prefix, '_alias', Rnm) ). % '$lgt_entity_to_prefix'(@entity_identifier, -atom) % % converts an entity identifier into an entity prefix (used in the compiled code) % note that objects, categories, and protocols share the same namespace '$lgt_entity_to_prefix'(Entity, Prefix) :- ( '$lgt_current_object_'(Entity, Prefix, _, _, _, _, _, _, _, _, _) -> true ; '$lgt_current_protocol_'(Entity, Prefix, _, _, _) -> true ; '$lgt_current_category_'(Entity, Prefix, _, _, _, _) -> true ; '$lgt_construct_entity_prefix'(Entity, Prefix) ). % '$lgt_prefix_to_entity'(+atom, -entity_identifier) % % reverses the entity prefix used in the compiled code % note that objects, categories, and protocols share the same namespace '$lgt_prefix_to_entity'(Prefix, Entity) :- ( '$lgt_current_object_'(Entity, Prefix, _, _, _, _, _, _, _, _, _) -> true ; '$lgt_current_protocol_'(Entity, Prefix, _, _, _) -> true ; '$lgt_current_category_'(Entity, Prefix, _, _, _, _) -> true ; '$lgt_deconstruct_entity_prefix'(Prefix, Entity) -> true ; throw(representation_error(entity_prefix)) ). % '$lgt_construct_entity_prefix'(@entity_identifier, -atom) % % constructs the entity prefix used in the compiled code from the entity identifier % % prefix = code prefix + entity functor + "#" + entity arity + "." '$lgt_construct_entity_prefix'(Entity, Prefix) :- '$lgt_compiler_flag'(code_prefix, CodePrefix), % the functor code prefix can be used to hide internal predicates (by % defining it as '$' when using most backend Prolog compilers) and to % avoid conflicts with other predicates functor(Entity, Functor, Arity), atom_concat(CodePrefix, Functor, Prefix0), ( '$lgt_arity_#atom.'(Arity, ArityAtom) -> true ; number_codes(Arity, ArityCodes), atom_codes(ArityAtom0, ArityCodes), atom_concat('#', ArityAtom0, ArityAtom1), atom_concat(ArityAtom1, '.', ArityAtom) ), atom_concat(Prefix0, ArityAtom, Prefix). % avoid costly atom computations for the most common cases '$lgt_arity_#atom.'(0, '#0.'). '$lgt_arity_#atom.'(1, '#1.'). '$lgt_arity_#atom.'(2, '#2.'). '$lgt_arity_#atom.'(3, '#3.'). '$lgt_arity_#atom.'(4, '#4.'). '$lgt_arity_#atom.'(5, '#5.'). '$lgt_arity_#atom.'(6, '#6.'). '$lgt_arity_#atom.'(7, '#7.'). '$lgt_arity_#atom.'(8, '#8.'). '$lgt_arity_#atom.'(9, '#9.'). % '$lgt_deconstruct_entity_prefix'(+atom, -entity_identifier) % % deconstructs the entity prefix used in the compiled code % returning the corresponding entity identifier template '$lgt_deconstruct_entity_prefix'(Prefix, Entity) :- % valid values of the code_prefix flag are single character atoms sub_atom(Prefix, 1, _, 0, Entity0), atom_concat(Entity1, '.', Entity0), % locate the rightmost # sub_atom(Entity1, Before, 1, After, '#'), Lines is Before + 1, sub_atom(Entity1, Lines, _, 0, Rest), \+ sub_atom(Rest, _, 1, _, '#'), !, sub_atom(Entity1, 0, Before, _, Functor), sub_atom(Entity1, _, After, 0, ArityAtom), atom_codes(ArityAtom, ArityCodes), number_codes(Arity, ArityCodes), functor(Entity, Functor, Arity). % '$lgt_compile_aux_clauses'(@list(clause)) % % compiles a list of auxiliary predicate clauses; % used mainly in conjunction with term_expansion/2 and goal_expansion/2 hook predicates '$lgt_compile_aux_clauses'([Clause| Clauses]) :- % avoid making a predicate discontiguous by accident by using a % compilation mode that ensures that the auxiliary clauses will % be written after the user clauses '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, _, _, _, _, compile(aux,_,_), _, '-'(0,0), _), '$lgt_compile_clause'(Clause, Ctx), '$lgt_compile_aux_clauses'(Clauses). '$lgt_compile_aux_clauses'([]). % '$lgt_entity_prefix'(?entity_identifier, ?atom) % % converts between entity identifiers and internal entity prefixes; % used mainly in hook objects for processing proprietary directives '$lgt_entity_prefix'(Entity, Prefix) :- ( var(Entity), var(Prefix) -> '$lgt_pp_entity_'(_, Entity, Prefix) ; callable(Entity) -> '$lgt_entity_to_prefix'(Entity, Prefix) ; atom(Prefix), '$lgt_prefix_to_entity'(Prefix, Entity) ). % '$lgt_compile_predicate_heads'(@list(callable), ?entity_identifier, -list(callable), @compilation_context) % '$lgt_compile_predicate_heads'(@callable, ?entity_identifier, -callable, @term) % % compiles a single predicate head, a conjunction of predicate heads, or a list of % predicate heads; used mainly in hook objects for processing proprietary directives % % the predicate heads are compiled in the context of the specified entity or in the context % of the entity being compiled when the entity argument is not instantiated '$lgt_compile_predicate_heads'(Heads, Entity, THeads, Ctx) :- '$lgt_check'(var_or_entity_identifier, Entity), '$lgt_entity_prefix'(Entity, Prefix), '$lgt_compile_predicate_heads_aux'(Heads, Prefix, THeads, Ctx). '$lgt_compile_predicate_heads_aux'(Heads, _, _, _) :- var(Heads), throw(instantiation_error). '$lgt_compile_predicate_heads_aux'([], _, [], _) :- !. '$lgt_compile_predicate_heads_aux'([Head| Heads], Prefix, [THead| THeads], Ctx) :- !, '$lgt_compile_predicate_heads_aux'(Head, Prefix, THead, Ctx), '$lgt_compile_predicate_heads_aux'(Heads, Prefix, THeads, Ctx). '$lgt_compile_predicate_heads_aux'((Head, Heads), Prefix, (THead, THeads), Ctx) :- !, '$lgt_compile_predicate_heads_aux'(Head, Prefix, THead, Ctx), '$lgt_compile_predicate_heads_aux'(Heads, Prefix, THeads, Ctx). '$lgt_compile_predicate_heads_aux'(Head, Prefix, THead, Ctx) :- '$lgt_check'(callable, Head), functor(Head, Functor, Arity), '$lgt_compile_predicate_indicator'(Prefix, Functor/Arity, TFunctor/TArity), functor(THead, TFunctor, TArity), '$lgt_unify_head_thead_arguments'(Head, THead, Ctx). % '$lgt_decompile_predicate_heads'(+list(callable), ?entity_identifier, ?atom, -list(callable)) % '$lgt_decompile_predicate_heads'(+callable, ?entity_identifier, ?atom, -callable) % % decompiles the predicate heads used for compiled predicates; % % all the compiled predicate heads must refer to the same entity % (which must be loaded) in order for this predicate to succeed '$lgt_decompile_predicate_heads'(THeads, Entity, Type, Heads) :- '$lgt_check'(var_or_entity_identifier, Entity), '$lgt_decompile_predicate_heads'(THeads, Entity, Type, _, Heads). '$lgt_decompile_predicate_heads'(THeads, _, _, _, _) :- var(THeads), throw(instantiation_error). '$lgt_decompile_predicate_heads'([], _, _, _, []) :- !. '$lgt_decompile_predicate_heads'([THead| THeads], Entity, Type, Prefix, [Head| Heads]) :- !, '$lgt_decompile_predicate_heads'(THead, Entity, Type, Prefix, Head), '$lgt_decompile_predicate_heads'(THeads, Entity, Type, Prefix, Heads). '$lgt_decompile_predicate_heads'(':'(Module,THead), Entity, Type, Prefix, Head) :- atom(Module), '$lgt_user_module_qualification'(xx, ':'(Module,xx)), !, '$lgt_decompile_predicate_heads'(THead, Entity, Type, Prefix, Head). '$lgt_decompile_predicate_heads'(THead, Entity, Type, Prefix, Head) :- callable(THead), functor(THead, TFunctor, TArity), ( var(Prefix) -> ( '$lgt_current_object_'(Entity, Prefix, _, _, _, _, _, _, _, _, _), Type = object ; '$lgt_current_category_'(Entity, Prefix, _, _, _, _), Type = category ; '$lgt_current_protocol_'(Entity, Prefix, _, _, _), Type = protocol ) ; true ), '$lgt_decompile_predicate_indicator'(Prefix, TFunctor/TArity, Functor/Arity), functor(Head, Functor, Arity), '$lgt_unify_head_thead_arguments'(Head, THead, _), !. % '$lgt_compile_predicate_indicators'(+list(predicate_indicator), ?entity_identifier, -list(predicate_indicator)) % '$lgt_compile_predicate_indicators'(+predicate_indicator, ?entity_identifier, -predicate_indicator) % % compiles a single predicate indicator, a conjunction of predicate indicators, or a list % of predicate indicators; used mainly in hook objects for processing proprietary directives % % the predicate indicators are compiled in the context of the specified entity or in the context % of the entity being compiled when the entity argument is not instantiated '$lgt_compile_predicate_indicators'(PIs, Entity, TPIs) :- '$lgt_check'(var_or_entity_identifier, Entity), '$lgt_entity_prefix'(Entity, Prefix), '$lgt_compile_predicate_indicators_aux'(PIs, Prefix, TPIs). '$lgt_compile_predicate_indicators_aux'(PIs, _, _) :- var(PIs), throw(instantiation_error). '$lgt_compile_predicate_indicators_aux'([], _, []) :- !. '$lgt_compile_predicate_indicators_aux'([PI| PIs], Prefix, [TPI| TPIs]) :- !, '$lgt_compile_predicate_indicators_aux'(PI, Prefix, TPI), '$lgt_compile_predicate_indicators_aux'(PIs, Prefix, TPIs). '$lgt_compile_predicate_indicators_aux'((PI, PIs), Prefix, (TPI, TPIs)) :- !, '$lgt_compile_predicate_indicators_aux'(PI, Prefix, TPI), '$lgt_compile_predicate_indicators_aux'(PIs, Prefix, TPIs). '$lgt_compile_predicate_indicators_aux'(PI, Prefix, TFunctor/TArity) :- ( '$lgt_valid_predicate_indicator'(PI, Functor, Arity) -> '$lgt_compile_predicate_indicator'(Prefix, Functor/Arity, TFunctor/TArity) ; '$lgt_valid_non_terminal_indicator'(PI, Functor, _, ExtArity) -> '$lgt_compile_predicate_indicator'(Prefix, Functor/ExtArity, TFunctor/TArity) ; throw(type_error(predicate_indicator, PI)) ). % '$lgt_compile_predicate_indicator'(+atom, +predicate_indicator, -predicate_indicator) % % compiles the user predicate indicator using the encoding entity prefix + functor + # + arity '$lgt_compile_predicate_indicator'(Prefix, Functor/Arity, TFunctor/TArity) :- atom_concat(Prefix, Functor, TFunctor0), ( '$lgt_arity_#atom'(Arity, ArityAtom) -> true ; number_codes(Arity, ArityCodes), atom_codes(ArityAtom0, ArityCodes), atom_concat('#', ArityAtom0, ArityAtom) ), atom_concat(TFunctor0, ArityAtom, TFunctor), % add execution context argument TArity is Arity + 1. % avoid costly atom computations for the most common cases '$lgt_arity_#atom'(0, '#0'). '$lgt_arity_#atom'(1, '#1'). '$lgt_arity_#atom'(2, '#2'). '$lgt_arity_#atom'(3, '#3'). '$lgt_arity_#atom'(4, '#4'). '$lgt_arity_#atom'(5, '#5'). '$lgt_arity_#atom'(6, '#6'). '$lgt_arity_#atom'(7, '#7'). '$lgt_arity_#atom'(8, '#8'). '$lgt_arity_#atom'(9, '#9'). % '$lgt_decompile_predicate_indicator'(+atom, +predicate_indicator, -predicate_indicator) % % decompiles an internal predicate indicator used for a user predicate '$lgt_decompile_predicate_indicator'(Prefix, TFunctor/TArity, Functor/Arity) :- atom_concat(Prefix, Predicate, TFunctor), % locate the rightmost # by looking for occurences left-to-right and % backtracking until the rest of the atom no longer contains a # sub_atom(Predicate, Before, 1, _, '#'), Parsed is Before + 1, sub_atom(Predicate, Parsed, _, 0, Rest), \+ sub_atom(Rest, _, 1, _, '#'), sub_atom(Predicate, 0, Before, _, Functor), % subtract execution context argument Arity is TArity - 1, Arity >= 0, !. % '$lgt_decompile_predicate_indicators'(+list(predicate_indicator), ?entity_identifier, ?atom, -list(predicate_indicator)) % '$lgt_decompile_predicate_indicators'(+predicate_indicator, ?entity_identifier, ?atom, -predicate_indicator) % % reverses the predicate indicator used for a compiled predicate or a list of compiled predicates; % % all the compiled predicate indicators must refer to the same entity % (which must be loaded) in order for this predicate to succeed '$lgt_decompile_predicate_indicators'(TPIs, Entity, Type, PIs) :- '$lgt_check'(var_or_entity_identifier, Entity), '$lgt_decompile_predicate_indicators'(TPIs, Entity, Type, _, PIs). '$lgt_decompile_predicate_indicators'(TPIs, _, _, _, _) :- var(TPIs), throw(instantiation_error). '$lgt_decompile_predicate_indicators'([], _, _, _, []) :- !. '$lgt_decompile_predicate_indicators'([TPI| TPIs], Entity, Type, Prefix, [PI| PIs]) :- !, '$lgt_decompile_predicate_indicators'(TPI, Entity, Type, Prefix, PI), '$lgt_decompile_predicate_indicators'(TPIs, Entity, Type, Prefix, PIs). '$lgt_decompile_predicate_indicators'(':'(Module,TFunctor/TArity), Entity, Type, Prefix, Functor/Arity) :- atom(Module), '$lgt_user_module_qualification'(xx, ':'(Module,xx)), !, '$lgt_decompile_predicate_indicators'(TFunctor/TArity, Entity, Type, Prefix, Functor/Arity). '$lgt_decompile_predicate_indicators'(TFunctor/TArity, Entity, Type, Prefix, Functor/Arity) :- ( var(Prefix) -> ( '$lgt_current_object_'(Entity, Prefix, _, _, _, _, _, _, _, _, _), Type = object ; '$lgt_current_category_'(Entity, Prefix, _, _, _, _), Type = category ; '$lgt_current_protocol_'(Entity, Prefix, _, _, _), Type = protocol ) ; true ), '$lgt_decompile_predicate_indicator'(Prefix, TFunctor/TArity, Functor/Arity), !. % '$lgt_compile_hooks'(+callable) % % compiles the user-defined default compiler hooks % (replacing any existing defined hooks) '$lgt_compile_hooks'(HookEntity) :- '$lgt_comp_ctx'(Ctx, _, _, user, user, user, HookEntity, _, [], [], ExCtx, runtime, [], _, _), '$lgt_execution_context'(ExCtx, user, user, user, HookEntity, [], []), '$lgt_current_flag_'(events, Events), '$lgt_compile_message_to_object'(term_expansion(Term, ExpandedTerm), HookEntity, TermExpansionGoal, Events, Ctx), '$lgt_compile_message_to_object'(goal_expansion(Term, ExpandedTerm), HookEntity, GoalExpansionGoal, Events, Ctx), retractall('$lgt_hook_term_expansion_'(_, _)), assertz(( '$lgt_hook_term_expansion_'(Term, ExpandedTerm) :- catch(TermExpansionGoal, Error, '$lgt_term_expansion_error'(HookEntity, Term, Error)) )), retractall('$lgt_hook_goal_expansion_'(_, _)), assertz(( '$lgt_hook_goal_expansion_'(Term, ExpandedTerm) :- catch(GoalExpansionGoal, Error, '$lgt_goal_expansion_error'(HookEntity, Term, Error)) )). % '$lgt_built_in_predicate'(@callable) % % checks if the argument is either a Logtalk or a Prolog built-in predicate '$lgt_built_in_predicate'(Pred) :- '$lgt_logtalk_built_in_predicate'(Pred, _), !. '$lgt_built_in_predicate'(Pred) :- '$lgt_predicate_property'(Pred, built_in), !. '$lgt_built_in_predicate'(Pred) :- '$lgt_iso_predicate'(Pred), % hack for missing ISO standard predicate defined in the used adapter file !. % '$lgt_prolog_built_in_predicate'(@callable) % % either host Prolog native built-ins or missing ISO built-ins % that we have defined in the correspondent adapter file '$lgt_prolog_built_in_predicate'(Pred) :- '$lgt_predicate_property'(Pred, built_in), % Logtalk built-in predicates may also have the property "built_in" % depending on the used backend Prolog compiler \+ '$lgt_logtalk_built_in_predicate'(Pred, _), !. '$lgt_prolog_built_in_predicate'(Pred) :- % ISO Prolog built-in predicate (defined in the adapter files) '$lgt_iso_predicate'(Pred). % '$lgt_prolog_built_in_database_predicate'(@callable) % % ISO Prolog standard and proprietary database predicates '$lgt_prolog_built_in_database_predicate'(Term) :- '$lgt_iso_database_predicate'(Term), % ISO Prolog standard database predicate !. '$lgt_prolog_built_in_database_predicate'(Term) :- '$lgt_prolog_database_predicate'(Term), % proprietary database predicate (declared in the adapter files) !. % '$lgt_prolog_deprecated_built_in_predicate'(@callable, -callable) % % Prolog deprecated predicate that can be replaced by a call to a % standard predicate; callers must check that the predicate is a % built-in predicate that is not being locally redefined '$lgt_prolog_deprecated_built_in_predicate'(current_predicate(Name, Template), current_predicate(Name/Arity)) :- callable(Template), Template \= ':'(_, _), functor(Template, Name, Arity). '$lgt_prolog_deprecated_built_in_predicate'(fail_if(Pred), \+ Pred). '$lgt_prolog_deprecated_built_in_predicate'(get0(Code), get_code(Code)). '$lgt_prolog_deprecated_built_in_predicate'(get0(Stream, Code), get_code(Stream, Code)). '$lgt_prolog_deprecated_built_in_predicate'(put(Code), put_code(Code)). '$lgt_prolog_deprecated_built_in_predicate'(put(Stream, Code), put_code(Stream, Code)). '$lgt_prolog_deprecated_built_in_predicate'(name(Atomic, Codes), Goal) :- ( number(Atomic) -> Goal = number_codes(Atomic, Codes) ; atom(Atomic), ( atom_length(Atomic, 1) -> Goal = char_code(Atomic, Code), Codes = [Code] ; Goal = atom_codes(Atomic, Codes) ) ). '$lgt_prolog_deprecated_built_in_predicate'(not(Pred), \+ Pred). '$lgt_prolog_deprecated_built_in_predicate'(otherwise, true). '$lgt_prolog_deprecated_built_in_predicate'(prolog_flag(Flag, Value), current_prolog_flag(Flag, Value)) :- atom(Flag), '$lgt_iso_spec_flag'(Flag). '$lgt_prolog_deprecated_built_in_predicate'(prolog_flag(Flag, Old, New), set_prolog_flag(Flag, New)) :- var(Old), atom(Flag), '$lgt_iso_spec_flag'(Flag). '$lgt_prolog_deprecated_built_in_predicate'(on_exception(Error, Goal, Handler), catch(Goal, Error, Handler)). '$lgt_prolog_deprecated_built_in_predicate'(raise_exception(Error), throw(Error)). % Quintus Prolog predicates for arithmetic functions '$lgt_prolog_deprecated_built_in_predicate'(sin(X, Y), Y is sin(X)). '$lgt_prolog_deprecated_built_in_predicate'(cos(X, Y), Y is cos(X)). '$lgt_prolog_deprecated_built_in_predicate'(tan(X, Y), Y is tan(X)). '$lgt_prolog_deprecated_built_in_predicate'(log(X, Y), Y is log(X)). '$lgt_prolog_deprecated_built_in_predicate'(pow(X, Y, Z), Z is X**Y). '$lgt_prolog_deprecated_built_in_predicate'(ceiling(X, Y), Y is ceiling(X)). '$lgt_prolog_deprecated_built_in_predicate'(floor(X, Y), Y is floor(X)). '$lgt_prolog_deprecated_built_in_predicate'(round(X, Y), Y is round(X)). '$lgt_prolog_deprecated_built_in_predicate'(sqrt(X, Y), Y is sqrt(X)). '$lgt_prolog_deprecated_built_in_predicate'(acos(X, Y), Y is acos(X)). '$lgt_prolog_deprecated_built_in_predicate'(asin(X, Y), Y is asin(X)). '$lgt_prolog_deprecated_built_in_predicate'(atan(X, Y), Y is atan(X)). '$lgt_prolog_deprecated_built_in_predicate'(atan2(X, Y, Z), Z is atan2(X, Y)). '$lgt_prolog_deprecated_built_in_predicate'(sign(X, Y), Y is sign(X)). % '$lgt_prolog_deprecated_built_in_predicate'(@callable) % % Prolog deprecated built-in predicate; callers must check that the % predicate is a built-in predicate that is not being locally redefined '$lgt_prolog_deprecated_built_in_predicate'(current_predicate(_, _)). '$lgt_prolog_deprecated_built_in_predicate'(get(_)). '$lgt_prolog_deprecated_built_in_predicate'(get(_, _)). '$lgt_prolog_deprecated_built_in_predicate'(name(_, _)). '$lgt_prolog_deprecated_built_in_predicate'(prolog_flag(_, _)). '$lgt_prolog_deprecated_built_in_predicate'(prolog_flag(_, _, _)). '$lgt_prolog_deprecated_built_in_predicate'(skip(_)). '$lgt_prolog_deprecated_built_in_predicate'(skip(_, _)). '$lgt_prolog_deprecated_built_in_predicate'(tab(_)). '$lgt_prolog_deprecated_built_in_predicate'(tab(_, _)). '$lgt_prolog_deprecated_built_in_predicate'(ttynl). '$lgt_prolog_deprecated_built_in_predicate'(ttyflush). '$lgt_prolog_deprecated_built_in_predicate'(ttyget0(_)). '$lgt_prolog_deprecated_built_in_predicate'(ttyget(_)). '$lgt_prolog_deprecated_built_in_predicate'(ttyskip(_)). '$lgt_prolog_deprecated_built_in_predicate'(ttyput(_)). '$lgt_prolog_deprecated_built_in_predicate'(ttytab(_)). % DEC-10 Prolog and C-Prolog legacy predicates '$lgt_prolog_deprecated_built_in_predicate'(simple(_)). '$lgt_prolog_deprecated_built_in_predicate'(reconsult(_)). '$lgt_prolog_deprecated_built_in_predicate'(display(_)). '$lgt_prolog_deprecated_built_in_predicate'(unknown(_, _)). '$lgt_prolog_deprecated_built_in_predicate'(fileerrors). '$lgt_prolog_deprecated_built_in_predicate'(nofileerrors). '$lgt_prolog_deprecated_built_in_predicate'(see(_)). '$lgt_prolog_deprecated_built_in_predicate'(tell(_)). '$lgt_prolog_deprecated_built_in_predicate'(append(_)). '$lgt_prolog_deprecated_built_in_predicate'(seeing(_)). '$lgt_prolog_deprecated_built_in_predicate'(telling(_)). '$lgt_prolog_deprecated_built_in_predicate'(seen). '$lgt_prolog_deprecated_built_in_predicate'(told). % Quintus Prolog predicates for arithmetic functions '$lgt_prolog_deprecated_built_in_predicate'(log10(_, _)). % '$lgt_prolog_deprecated_built_in_function'(@callable, -callable) % % Prolog deprecated function that can be replaced by a call to a % standard function; callers must check that the function is a % built-in function '$lgt_prolog_deprecated_built_in_function'(ceil(Float), ceiling(Float)). '$lgt_prolog_deprecated_built_in_function'(integer(Float), round(Float)). % '$lgt_prolog_deprecated_built_in_function'(@callable) % % Prolog deprecated built-in function; callers must check that the % function is a built-in function '$lgt_prolog_deprecated_built_in_function'(_) :- fail. % Logtalk built-in methods % % '$lgt_built_in_method'(@callable, ?scope, ?callable, ?integer) '$lgt_built_in_method'(Method, Scope, Meta, Flags) :- ( '$lgt_built_in_method_spec'(Method, Scope, Meta, Flags) -> true ; % check if call/2-N functor(Method, call, Arity), Arity > 1, Scope = p, functor(Meta, call, Arity), Closure is Arity - 1, arg(1, Meta, Closure), '$lgt_built_in_method_call_n_args'(Arity, Meta), Flags = 1 ). '$lgt_built_in_method_call_n_args'(1, _) :- !. '$lgt_built_in_method_call_n_args'(N, Meta) :- arg(N, Meta, *), N2 is N - 1, '$lgt_built_in_method_call_n_args'(N2, Meta). % control constructs '$lgt_built_in_method_spec'(_::_, p, '::'(*, *), 1). '$lgt_built_in_method_spec'(::_, p, '::'(*), 1). '$lgt_built_in_method_spec'([_], p, [*], 1). '$lgt_built_in_method_spec'(^^_, p, '^^'(*), 1). '$lgt_built_in_method_spec'(_<<_, p, '<<'(*, 0), 1). '$lgt_built_in_method_spec'(_>>_, p, '>>'(*, 0), 1). '$lgt_built_in_method_spec'(':'(_,_), p, ':'(*, 0), 1) :- '$lgt_prolog_feature'(modules, supported). '$lgt_built_in_method_spec'({_}, p(p(p)), '{}'(0), 1). '$lgt_built_in_method_spec'((_,_), p(p(p)), ','(0, 0), 1). '$lgt_built_in_method_spec'((_;_), p(p(p)), ';'(0, 0), 1). '$lgt_built_in_method_spec'((_->_), p(p(p)), '->'(0, 0), 1). '$lgt_built_in_method_spec'('*->'(_,_), p(p(p)), '*->'(0, 0), 1) :- '$lgt_prolog_built_in_predicate'('*->'(_, _)). % reflection methods '$lgt_built_in_method_spec'(current_op(_,_,_), p(p(p)), current_op(*, *, (::)), 1). '$lgt_built_in_method_spec'(current_predicate(_), p(p(p)), current_predicate((::)), 1). '$lgt_built_in_method_spec'(predicate_property(_,_), p(p(p)), predicate_property((::), *), 1). % database methods '$lgt_built_in_method_spec'(abolish(_), p(p(p)), abolish((::)), 1). '$lgt_built_in_method_spec'(asserta(_), p(p(p)), asserta((::)), 1). '$lgt_built_in_method_spec'(assertz(_), p(p(p)), assertz((::)), 1). '$lgt_built_in_method_spec'(clause(_,_), p(p(p)), clause((::), *), 1). '$lgt_built_in_method_spec'(retract(_), p(p(p)), retract((::)), 1). '$lgt_built_in_method_spec'(retractall(_), p(p(p)), retractall((::)), 1). % term expansion methods '$lgt_built_in_method_spec'(expand_term(_,_), p(p(p)), no, 1). '$lgt_built_in_method_spec'(expand_goal(_,_), p(p(p)), no, 1). % DCGs methods '$lgt_built_in_method_spec'(phrase(_,_,_), p, phrase(2, *, *), 1). '$lgt_built_in_method_spec'(phrase(_,_), p, phrase(2, *), 1). % meta-calls plus logic and control methods '$lgt_built_in_method_spec'(\+ _, p, \+ 0, 1). '$lgt_built_in_method_spec'(call(_), p, call(0), 1). '$lgt_built_in_method_spec'(once(_), p, once(0), 1). '$lgt_built_in_method_spec'(ignore(_), p, ignore(0), 1). '$lgt_built_in_method_spec'(!, p(p(p)), no, 1). '$lgt_built_in_method_spec'(true, p(p(p)), no, 1). '$lgt_built_in_method_spec'(fail, p(p(p)), no, 1). '$lgt_built_in_method_spec'(false, p(p(p)), no, 1). '$lgt_built_in_method_spec'(repeat, p(p(p)), no, 1). % exception handling methods '$lgt_built_in_method_spec'(catch(_,_,_), p, catch(0, *, 0), 1). '$lgt_built_in_method_spec'(throw(_), p, no, 1). % error predicates '$lgt_built_in_method_spec'(instantiation_error, p, no, 1). '$lgt_built_in_method_spec'(uninstantiation_error(_), p, no, 1). '$lgt_built_in_method_spec'(type_error(_,_), p, no, 1). '$lgt_built_in_method_spec'(domain_error(_,_), p, no, 1). '$lgt_built_in_method_spec'(consistency_error(_,_,_), p, no, 1). '$lgt_built_in_method_spec'(existence_error(_,_), p, no, 1). '$lgt_built_in_method_spec'(permission_error(_,_,_), p, no, 1). '$lgt_built_in_method_spec'(representation_error(_), p, no, 1). '$lgt_built_in_method_spec'(evaluation_error(_), p, no, 1). '$lgt_built_in_method_spec'(resource_error(_), p, no, 1). '$lgt_built_in_method_spec'(syntax_error(_), p, no, 1). '$lgt_built_in_method_spec'(system_error, p, no, 1). % execution context methods '$lgt_built_in_method_spec'(context(_), p, no, 1). '$lgt_built_in_method_spec'(parameter(_,_), p, no, 1). '$lgt_built_in_method_spec'(self(_), p, no, 1). '$lgt_built_in_method_spec'(sender(_), p, no, 1). '$lgt_built_in_method_spec'(this(_), p, no, 1). % all solutions methods '$lgt_built_in_method_spec'(bagof(_,_,_), p, bagof(*, ^, *), 1). '$lgt_built_in_method_spec'(findall(_,_,_), p, findall(*, 0, *), 1). '$lgt_built_in_method_spec'(findall(_,_,_,_), p, findall(*, 0, *, *), 1). '$lgt_built_in_method_spec'(forall(_,_), p, forall(0, 0), 1). '$lgt_built_in_method_spec'(setof(_,_,_), p, setof(*, ^, *), 1). % Logtalk built-in error methods % % '$lgt_built_in_error_method'(@callable) '$lgt_built_in_error_method'(instantiation_error). '$lgt_built_in_error_method'(uninstantiation_error(_)). '$lgt_built_in_error_method'(type_error(_, _)). '$lgt_built_in_error_method'(domain_error(_, _)). '$lgt_built_in_error_method'(consistency_error(_, _, _)). '$lgt_built_in_error_method'(existence_error(_, _)). '$lgt_built_in_error_method'(permission_error(_, _, _)). '$lgt_built_in_error_method'(representation_error(_)). '$lgt_built_in_error_method'(evaluation_error(_)). '$lgt_built_in_error_method'(resource_error(_)). '$lgt_built_in_error_method'(syntax_error(_)). '$lgt_built_in_error_method'(system_error). % Logtalk built-in meta-predicates % % '$lgt_logtalk_meta_predicate'(+callable, ?callable, ?atom) '$lgt_logtalk_meta_predicate'(Pred, Meta, predicate) :- '$lgt_built_in_method'(Pred, _, Meta, _), Meta \== no. % '$lgt_reserved_predicate_protocol'(?callable, ?atom) % % table of reserved predicate names and the built-in protocols % where they are declared '$lgt_reserved_predicate_protocol'(before(_, _, _), monitoring). '$lgt_reserved_predicate_protocol'(after(_, _, _), monitoring). '$lgt_reserved_predicate_protocol'(term_expansion(_, _), expanding). '$lgt_reserved_predicate_protocol'(goal_expansion(_, _), expanding). '$lgt_reserved_predicate_protocol'(forward(_), forwarding). %'$lgt_logtalk_directive'(@callable) % % valid Logtalk directives; a common subset of Prolog module directives are % also included as modules can be compiled as objects (but the specific case % of the use_module/1 directive is handled at the Prolog adapter file level) '$lgt_logtalk_directive'(Directive) :- '$lgt_logtalk_opening_directive'(Directive), !. '$lgt_logtalk_directive'(Directive) :- '$lgt_logtalk_closing_directive'(Directive), !. '$lgt_logtalk_directive'(Directive) :- '$lgt_logtalk_entity_directive'(Directive), !. '$lgt_logtalk_directive'(Directive) :- '$lgt_logtalk_predicate_directive'(Directive), !. % objects '$lgt_logtalk_opening_directive'(object(_)). '$lgt_logtalk_opening_directive'(object(_, _)). '$lgt_logtalk_opening_directive'(object(_, _, _)). '$lgt_logtalk_opening_directive'(object(_, _, _, _)). '$lgt_logtalk_opening_directive'(object(_, _, _, _, _)). % categories '$lgt_logtalk_opening_directive'(category(_)). '$lgt_logtalk_opening_directive'(category(_, _)). '$lgt_logtalk_opening_directive'(category(_, _, _)). '$lgt_logtalk_opening_directive'(category(_, _, _, _)). % protocols '$lgt_logtalk_opening_directive'(protocol(_)). '$lgt_logtalk_opening_directive'(protocol(_, _)). % Prolog module directives '$lgt_logtalk_opening_directive'(module(_)). '$lgt_logtalk_opening_directive'(module(_, _)). % module/3 directives are currently not supported but must % be recognized as entity opening directives '$lgt_logtalk_opening_directive'(module(_, _, _)). '$lgt_logtalk_closing_directive'(end_object). '$lgt_logtalk_closing_directive'(end_category). '$lgt_logtalk_closing_directive'(end_protocol). '$lgt_logtalk_entity_directive'(built_in). '$lgt_logtalk_entity_directive'(include(_)). '$lgt_logtalk_entity_directive'(initialization(_)). '$lgt_logtalk_entity_directive'((dynamic)). '$lgt_logtalk_entity_directive'(op(_, _, _)). '$lgt_logtalk_entity_directive'(info(_)). '$lgt_logtalk_entity_directive'(threaded). '$lgt_logtalk_entity_directive'(set_logtalk_flag(_, _)). '$lgt_logtalk_entity_directive'(uses(_)). '$lgt_logtalk_entity_directive'(use_module(_)). '$lgt_logtalk_predicate_directive'(synchronized(_)). '$lgt_logtalk_predicate_directive'(dynamic(_)). '$lgt_logtalk_predicate_directive'(meta_predicate(_)). '$lgt_logtalk_predicate_directive'(meta_non_terminal(_)). '$lgt_logtalk_predicate_directive'(discontiguous(_)). '$lgt_logtalk_predicate_directive'(public(_)). '$lgt_logtalk_predicate_directive'(protected(_)). '$lgt_logtalk_predicate_directive'(private(_)). '$lgt_logtalk_predicate_directive'(mode(_, _)). '$lgt_logtalk_predicate_directive'(info(_, _)). '$lgt_logtalk_predicate_directive'(alias(_, _)). '$lgt_logtalk_predicate_directive'(multifile(_)). '$lgt_logtalk_predicate_directive'(coinductive(_)). '$lgt_logtalk_predicate_directive'(uses(_, _)). '$lgt_logtalk_predicate_directive'(use_module(_, _)). % Prolog module directives that are recognized when compiling modules as objects '$lgt_logtalk_predicate_directive'(export(_)). '$lgt_logtalk_predicate_directive'(reexport(_, _)). '$lgt_conditional_compilation_directive'(if(_)). '$lgt_conditional_compilation_directive'(elif(_)). '$lgt_conditional_compilation_directive'(else). '$lgt_conditional_compilation_directive'(endif). '$lgt_is_conditional_compilation_directive'((:- Directive)) :- nonvar(Directive), '$lgt_conditional_compilation_directive'(Directive). % '$lgt_file_directive'(@callable) % % standard file-level directives (used for portability checking) '$lgt_file_directive'(discontiguous(_)). '$lgt_file_directive'(dynamic(_)). '$lgt_file_directive'(multifile(_)). '$lgt_file_directive'(encoding(_)). '$lgt_file_directive'(include(_)). '$lgt_file_directive'(use_module(_)). '$lgt_file_directive'(use_module(_, _)). '$lgt_file_directive'(ensure_loaded(_)). '$lgt_file_directive'(set_prolog_flag(_, _)). '$lgt_file_directive'(set_logtalk_flag(_, _)). '$lgt_file_directive'(initialization(_)). '$lgt_file_directive'(op(_, _, _)). % utility predicates used during compilation of Logtalk entities to store and % access compilation context information (represented by a compound term) '$lgt_comp_ctx'(ctx(_, _, _, _, _, _, _, _, _, _, _, _, _, _)). '$lgt_comp_ctx'( ctx(Head, HeadExCtx, Entity, Sender, This, Self, Prefix, MetaVars, MetaCallCtx, ExCtx, Mode, Stack, Lines, Term), Head, HeadExCtx, Entity, Sender, This, Self, Prefix, MetaVars, MetaCallCtx, ExCtx, Mode, Stack, Lines, Term ). % head of the clause being compiled '$lgt_comp_ctx_head'(ctx(Head, _, _, _, _, _, _, _, _, _, _, _, _, _), Head). % head execution context of the clause being compiled '$lgt_comp_ctx_head_exec_ctx'(ctx(_, HeadExCtx, _, _, _, _, _, _, _, _, _, _, _, _), HeadExCtx). % entity containing the clause being compiled (either a category or an object) '$lgt_comp_ctx_entity'(ctx(_, _, Entity, _, _, _, _, _, _, _, _, _, _, _), Entity). '$lgt_comp_ctx_sender'(ctx(_, _, _, Sender, _, _, _, _, _, _, _, _, _, _), Sender). '$lgt_comp_ctx_this'(ctx(_, _, _, _, This, _, _, _, _, _, _, _, _, _), This). '$lgt_comp_ctx_self'(ctx(_, _, _, _, _, Self, _, _, _, _, _, _, _, _), Self). % entity prefix used to avoid predicate name conflicts '$lgt_comp_ctx_prefix'(ctx(_, _, _, _, _, _, Prefix, _, _, _, _, _, _, _), Prefix). '$lgt_comp_ctx_meta_vars'(ctx(_, _, _, _, _, _, _, MetaVars, _, _, _, _, _, _), MetaVars). '$lgt_comp_ctx_meta_call_ctx'(ctx(_, _, _, _, _, _, _, _, MetaCallCtx, _, _, _, _, _), MetaCallCtx). '$lgt_comp_ctx_exec_ctx'(ctx(_, _, _, _, _, _, _, _, _, ExCtx, _, _, _, _), ExCtx). % compilation mode; possible values are "compile(user,_,_)", "compile(aux,_,_)", and "runtime" '$lgt_comp_ctx_mode'(ctx(_, _, _, _, _, _, _, _, _, _, Mode, _, _, _), Mode). % stack of coinductive hypothesis (ancestor goals) '$lgt_comp_ctx_stack'(ctx(_, _, _, _, _, _, _, _, _, _, _, Stack, _, _), Stack). % begin line and end line (a pair of integers) of the term being compiled '$lgt_comp_ctx_lines'(ctx(_, _, _, _, _, _, _, _, _, _, _, _, Lines, _), Lines). % term being compiled '$lgt_comp_ctx_term'(ctx(_, _, _, _, _, _, _, _, _, _, _, _, _, Term), Term). % utility predicates used to access execution context terms '$lgt_execution_context'(c(This, Entity, r(Sender, Self, MetaCallContext, Stack)), Entity, Sender, This, Self, MetaCallContext, Stack). % inheritance only requires updating "this" and "entity" '$lgt_execution_context_update_this_entity'(c(OldThis, OldEntity, Rest), OldThis, OldEntity, c(NewThis, NewEntity, Rest), NewThis, NewEntity). '$lgt_execution_context_this_entity'(c(This, Entity, _), This, Entity). % '$lgt_term_template'(@callable, -callable) % % constructs a template for a callable term '$lgt_term_template'(Term, Template) :- functor(Term, Functor, Arity), functor(Template, Functor, Arity). % '$lgt_flatten_to_list'(+term, -list) % % flattens an item, a list of items, or a conjunction of items into a list '$lgt_flatten_to_list'([A| B], [A| B]) :- !. '$lgt_flatten_to_list'([], []) :- !. '$lgt_flatten_to_list'((A, B), [A| BB]) :- !, '$lgt_flatten_to_list'(B, BB). '$lgt_flatten_to_list'(A, [A]). % '$lgt_valid_scope'(@nonvar). % % valid (user-level) scope '$lgt_valid_scope'((private)). '$lgt_valid_scope'(protected). '$lgt_valid_scope'((public)). % '$lgt_valid_predicate_indicator'(@term, -atom, -integer) % % valid predicate indicator '$lgt_valid_predicate_indicator'(Functor/Arity, Functor, Arity) :- atom(Functor), integer(Arity), Arity >= 0. % '$lgt_valid_non_terminal_indicator'(@term, -atom, -integer, -integer) % % valid grammar rule non-terminal indicator; the last argument is the % arity of the corresponding predicate '$lgt_valid_non_terminal_indicator'(Functor//Arity, Functor, Arity, ExtArity) :- atom(Functor), integer(Arity), Arity >= 0, ExtArity is Arity + 2. % '$lgt_valid_predicate_or_non_terminal_indicator'(@term, -atom, -integer) % % valid predicate indicator or grammar rule indicator '$lgt_valid_predicate_or_non_terminal_indicator'(Functor/Arity, Functor, Arity) :- atom(Functor), integer(Arity), Arity >= 0. '$lgt_valid_predicate_or_non_terminal_indicator'(Functor//Arity, Functor, Arity) :- atom(Functor), integer(Arity), Arity >= 0. % '$lgt_valid_info_key_value_pair'(@term, -atom, -integer) % % valid info/1-2 key-value pair '$lgt_valid_info_key_value_pair'(Key is Value, Key, Value) :- atom(Key), nonvar(Value). % '$lgt_check_entity_reference'(+atom, @term, -atom, -entity_identifier) '$lgt_check_entity_reference'(object, Ref, Scope, Object) :- ( Ref = Scope::Object -> '$lgt_check'(scope, Scope), '$lgt_check'(object_identifier, Object) ; Ref = Object, Scope = (public), '$lgt_check'(object_identifier, Object) ). '$lgt_check_entity_reference'(protocol, Ref, Scope, Protocol) :- ( Ref = Scope::Protocol -> '$lgt_check'(scope, Scope), '$lgt_check'(protocol_identifier, Protocol) ; Ref = Protocol, Scope = (public), '$lgt_check'(protocol_identifier, Protocol) ). '$lgt_check_entity_reference'(category, Ref, Scope, Category) :- ( Ref = Scope::Category -> '$lgt_check'(scope, Scope), '$lgt_check'(category_identifier, Category) ; Ref = Category, Scope = (public), '$lgt_check'(category_identifier, Category) ). % '$lgt_check_closure'(@nonvar, @compilation_context) % % checks that a closure meta-argument is valid '$lgt_check_closure'(Closure, _) :- var(Closure), !. '$lgt_check_closure'(Free/Goal, Ctx) :- !, '$lgt_check_lambda_expression'(Free/Goal, Ctx). '$lgt_check_closure'(Parameters>>Goal, Ctx) :- !, '$lgt_check_lambda_expression'(Parameters>>Goal, Ctx). '$lgt_check_closure'({Closure}, _) :- !, '$lgt_check'(var_or_callable, Closure). '$lgt_check_closure'(Object::Closure, _) :- !, '$lgt_check'(var_or_object_identifier, Object), '$lgt_check'(var_or_callable, Closure). '$lgt_check_closure'(::Closure, _) :- !, '$lgt_check'(var_or_callable, Closure). '$lgt_check_closure'(^^Closure, _) :- !, '$lgt_check'(var_or_callable, Closure). '$lgt_check_closure'(Object<>Goal, Ctx) :- !, % first, check for errors '$lgt_check'(var_or_curly_bracketed_term, Free), '$lgt_check'(list_or_partial_list, Parameters), '$lgt_check'(var_or_callable, Goal), % second, check for likely errors if compiling a source file ( '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), nonvar(Free), nonvar(Parameters), nonvar(Goal) -> '$lgt_check_lambda_expression_parameters'(Parameters, Free/Parameters>>Goal, Ctx), '$lgt_check_lambda_expression_unclassified_variables'(Free/Parameters>>Goal, Ctx), '$lgt_check_lambda_expression_mixed_up_variables'(Free/Parameters>>Goal, Ctx) ; true ). '$lgt_check_lambda_expression'(Free/Goal, Ctx) :- '$lgt_check'(var_or_curly_bracketed_term, Free), '$lgt_check'(var_or_callable, Goal), % second, check for likely errors if compiling a source file ( '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), nonvar(Free), nonvar(Goal) -> '$lgt_check_lambda_expression_unclassified_variables'(Free/Goal, Ctx) ; true ). '$lgt_check_lambda_expression'(Parameters>>Goal, Ctx) :- % first, check for errors '$lgt_check'(list_or_partial_list, Parameters), '$lgt_check'(var_or_callable, Goal), % second, check for likely errors if compiling a source file ( '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), nonvar(Parameters), nonvar(Goal) -> '$lgt_check_lambda_expression_parameters'(Parameters, Parameters>>Goal, Ctx), '$lgt_check_lambda_expression_unclassified_variables'(Parameters>>Goal, Ctx) ; true ). % '$lgt_check_lambda_expression_parameters'(@list, @callable, +compilation_context) '$lgt_check_lambda_expression_parameters'(Parameters, Lambda, Ctx) :- term_variables(Parameters, Variables), '$lgt_comp_ctx_term'(Ctx, Clause), '$lgt_check_lambda_expression_parameter_variables'(Variables, Lambda, Clause, Ctx). '$lgt_check_lambda_expression_parameter_variables'([], _, _, _). '$lgt_check_lambda_expression_parameter_variables'([Variable| Variables], Lambda, Clause, Ctx) :- '$lgt_check_lambda_expression_parameter_variable'(Variable, Lambda, Clause, Ctx), '$lgt_check_lambda_expression_parameter_variables'(Variables, Lambda, Clause, Ctx). '$lgt_check_lambda_expression_parameter_variable'(Variable, Lambda, Clause, _) :- '$lgt_count_variable_occurrences'(Lambda, Variable, InLambda), '$lgt_count_variable_occurrences'(Clause, Variable, InClause), ( InClause > InLambda, '$lgt_compiler_flag'(lambda_variables, warning) -> '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(lambda_variables), parameter_variable_used_elsewhere(File, Lines, Type, Entity, Lambda, Variable) ) ; true ). '$lgt_contains_variable'(Term, Variable) :- Term == Variable. '$lgt_contains_variable'(Term, Variable) :- compound(Term), functor(Term, _, Arity), '$lgt_between'(1, Arity, N), arg(N, Term, Argument), '$lgt_contains_variable'(Argument, Variable). '$lgt_count_variable_occurrences'(Term, Variable, N) :- findall(1, '$lgt_contains_variable'(Term, Variable), L), '$lgt_length'(L, 0, N). % each lambda goal variable should be either a lambda free variable or a lambda parameter '$lgt_check_lambda_expression_unclassified_variables'(Free/Goal, Ctx) :- % take into account currying to avoid false positives '$lgt_check_lambda_expression_goal_variables'(Goal, GoalVars, Ctx), term_variables(Free, FreeVars), '$lgt_var_subtract'(GoalVars, FreeVars, UnclassifiedVars0), ( UnclassifiedVars0 \== [], '$lgt_compiler_flag'(lambda_variables, warning), % reinstate relation between term variables and their names '$lgt_comp_ctx_term'(Ctx, OriginalTerm), '$lgt_pp_term_source_data_'(OriginalTerm, VariableNames, Singletons, _, _), % ignore singleton (and anonymous) variables '$lgt_filter_singleton_variables'(UnclassifiedVars0, VariableNames, Singletons, UnclassifiedVars), UnclassifiedVars \== [] -> '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(lambda_variables), unclassified_variables_in_lambda_expression(File, Lines, Type, Entity, UnclassifiedVars, Free/Goal) ) ; true ). '$lgt_check_lambda_expression_unclassified_variables'(Parameters>>Goal, Ctx) :- % take into account currying to avoid false positives '$lgt_check_lambda_expression_goal_variables'(Goal, GoalVars, Ctx), term_variables(Parameters, ParameterVars), '$lgt_var_subtract'(GoalVars, ParameterVars, UnclassifiedVars), ( UnclassifiedVars \== [], '$lgt_compiler_flag'(lambda_variables, warning) -> '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(lambda_variables), unclassified_variables_in_lambda_expression(File, Lines, Type, Entity, UnclassifiedVars, Parameters>>Goal) ) ; true ). '$lgt_filter_singleton_variables'([], _, _, []). '$lgt_filter_singleton_variables'([UnclassifiedVar0| UnclassifiedVars0], VariableNames, Singletons, [UnclassifiedVar0| UnclassifiedVars]) :- '$lgt_member'(_Name0=Variable0, VariableNames), Variable0 == UnclassifiedVar0, \+ ( '$lgt_member'(Name1=Variable1, Singletons), Variable1 == UnclassifiedVar0, % parameter variables may be singletons in the clause but still need to be classified \+ '$lgt_parameter_variable_name'(Name1) ), !, '$lgt_filter_singleton_variables'(UnclassifiedVars0, VariableNames, Singletons, UnclassifiedVars). '$lgt_filter_singleton_variables'([_| UnclassifiedVars0], VariableNames, Singletons, UnclassifiedVars) :- '$lgt_filter_singleton_variables'(UnclassifiedVars0, VariableNames, Singletons, UnclassifiedVars). '$lgt_check_lambda_expression_goal_variables'(Parameters>>Goal, UnqualifiedVars, Ctx) :- !, '$lgt_check_lambda_expression_goal_variables'(Goal, GoalVars, Ctx), term_variables(Parameters, ParameterVars), '$lgt_var_subtract'(GoalVars, ParameterVars, UnqualifiedVars). '$lgt_check_lambda_expression_goal_variables'(Goal, UnqualifiedVars, Ctx) :- '$lgt_check_closure'(Goal, Ctx), term_variables(Goal, UnqualifiedVars). % no lambda goal variable should be both a lambda free variable and a lambda parameter '$lgt_check_lambda_expression_mixed_up_variables'(Free/Parameters>>Goal, _) :- term_variables(Free, FreeVars), term_variables(Parameters, ParameterVars), '$lgt_intersection'(FreeVars, ParameterVars, MixedUpVars), ( MixedUpVars \== [], '$lgt_compiler_flag'(lambda_variables, warning) -> '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(lambda_variables), variables_with_dual_role_in_lambda_expression(File, Lines, Type, Entity, MixedUpVars, Free/Parameters>>Goal) ) ; true ). % '$lgt_same_operator_class'(+atom, +atom) % % this utility predicate is used when defining new operators using op/3 % in order to know if there's an operator of the same class that should % be backed up '$lgt_same_operator_class'(fx, fx). '$lgt_same_operator_class'(fx, fy). '$lgt_same_operator_class'(fy, fx). '$lgt_same_operator_class'(fy, fy). '$lgt_same_operator_class'(xf, xf). '$lgt_same_operator_class'(xf, yf). '$lgt_same_operator_class'(yf, xf). '$lgt_same_operator_class'(yf, yf). '$lgt_same_operator_class'(xfx, xfx). '$lgt_same_operator_class'(xfx, xfy). '$lgt_same_operator_class'(xfx, yfx). '$lgt_same_operator_class'(xfy, xfx). '$lgt_same_operator_class'(xfy, xfy). '$lgt_same_operator_class'(xfy, yfx). '$lgt_same_operator_class'(yfx, xfx). '$lgt_same_operator_class'(yfx, xfy). '$lgt_same_operator_class'(yfx, yfx). % '$lgt_valid_meta_predicate_template'(@term) '$lgt_valid_meta_predicate_template'(Pred) :- callable(Pred), Pred =.. [_| Args], '$lgt_valid_meta_predicate_template_args'(Args). '$lgt_valid_meta_predicate_template_args'([]). '$lgt_valid_meta_predicate_template_args'([Arg| Args]) :- ground(Arg), '$lgt_valid_meta_predicate_template_arg'(Arg), '$lgt_valid_meta_predicate_template_args'(Args). % meta-argument but not called '$lgt_valid_meta_predicate_template_arg'((::)) :- !. % non meta-argument '$lgt_valid_meta_predicate_template_arg'(*) :- !. % goal with possible existential variables qualification '$lgt_valid_meta_predicate_template_arg'(^) :- !. % goal or closure '$lgt_valid_meta_predicate_template_arg'(Arg) :- integer(Arg), Arg >= 0. % '$lgt_valid_mode_template'(@nonvar) '$lgt_valid_mode_template'(Pred) :- Pred =.. [_| Args], '$lgt_valid_mode_template_args'(Args). '$lgt_valid_mode_template_args'([]). '$lgt_valid_mode_template_args'([Arg| Args]) :- ( ground(Arg) -> '$lgt_valid_mode_template_arg'(Arg) ; throw(instantiation_error) ), '$lgt_valid_mode_template_args'(Args). % '$lgt_valid_mode_template_arg'(@nonvar) % unspecified argument, can be input, output, or both input and output '$lgt_valid_mode_template_arg'((?)). '$lgt_valid_mode_template_arg'('?'(_)). % instantiated argument on predicate call, can be further instantiated by the predicate call '$lgt_valid_mode_template_arg'((+)). '$lgt_valid_mode_template_arg'('+'(_)). % non-instantiated argument (i.e., a variable) on predicate call '$lgt_valid_mode_template_arg'((-)). '$lgt_valid_mode_template_arg'('-'(_)). % not modified argument (i.e., not further instantiated) by the predicate call '$lgt_valid_mode_template_arg'((@)). '$lgt_valid_mode_template_arg'('@'(_)). % ground argument '$lgt_valid_mode_template_arg'((++)). '$lgt_valid_mode_template_arg'('++'(_)). % unbound argument '$lgt_valid_mode_template_arg'((--)). '$lgt_valid_mode_template_arg'('--'(_)). % '$lgt_valid_number_of_proofs'(@nonvar) % calling the predicate using the specified mode always fails '$lgt_valid_number_of_proofs'(zero). % calling the predicate using the specified mode always succeeds once '$lgt_valid_number_of_proofs'(one). % calling the predicate using the specified mode may succeed once or fail '$lgt_valid_number_of_proofs'(zero_or_one). % calling the predicate using the specified mode may fail or succeed multiple times '$lgt_valid_number_of_proofs'(zero_or_more). % calling the predicate using the specified mode always succeed at least once '$lgt_valid_number_of_proofs'(one_or_more). % calling the predicate using the specified mode either succeeds once or throws an error '$lgt_valid_number_of_proofs'(zero_or_error). % calling the predicate using the specified mode either fails or throws an error '$lgt_valid_number_of_proofs'(one_or_error). % calling the predicate using the specified mode either succeeds once or fails or throws an error '$lgt_valid_number_of_proofs'(zero_or_one_or_error). % calling the predicate using the specified mode may fail or succeed multiple times or throw an error '$lgt_valid_number_of_proofs'(zero_or_more_or_error). % calling the predicate using the specified mode may succeed one or more times or throw an error '$lgt_valid_number_of_proofs'(one_or_more_or_error). % calling the predicate using the specified mode throws an error '$lgt_valid_number_of_proofs'(error). % '$lgt_valid_predicate_property'(@nonvar) % predicate scope (public, protected, or private) '$lgt_valid_predicate_property'(scope(_)). % public predicate '$lgt_valid_predicate_property'((public)). % protected predicate '$lgt_valid_predicate_property'(protected). % private predicate '$lgt_valid_predicate_property'((private)). % dynamic predicate '$lgt_valid_predicate_property'((dynamic)). % static predicate '$lgt_valid_predicate_property'(static). % predicate is defined in Logtalk source code '$lgt_valid_predicate_property'(logtalk). % predicate is defined in Prolog source code '$lgt_valid_predicate_property'(prolog). % predicate is defined in foreign source code (e.g., C) '$lgt_valid_predicate_property'(foreign). % entity containing the predicate scope directive '$lgt_valid_predicate_property'(declared_in(_)). % object or category containing the predicate definition '$lgt_valid_predicate_property'(defined_in(_)). % object or category containing the inherited but overridden predicate definition '$lgt_valid_predicate_property'(redefined_from(_)). % meta-predicate template '$lgt_valid_predicate_property'(meta_predicate(_)). % coinductive predicate template '$lgt_valid_predicate_property'(coinductive(_)). % built-in predicate '$lgt_valid_predicate_property'(built_in). % predicate is an alias of another predicate '$lgt_valid_predicate_property'(alias_of(_)). % entity where the predicate alias is declared '$lgt_valid_predicate_property'(alias_declared_in(_)). % clauses for the predicate can be defined within multiple entities '$lgt_valid_predicate_property'((multifile)). % predicate version of a non-terminal '$lgt_valid_predicate_property'(non_terminal(_)). % calls to the predicate are synchronized '$lgt_valid_predicate_property'(synchronized). % the remaining properties are available only when the entities are compiled with the "source_data" flag turned on % mode/2 predicate information (predicates can have more than one mode) '$lgt_valid_predicate_property'(mode(_, _)). % info/2 predicate information '$lgt_valid_predicate_property'(info(_)). % number of predicate clauses '$lgt_valid_predicate_property'(number_of_clauses(_)). % number of predicate rules '$lgt_valid_predicate_property'(number_of_rules(_)). % entity containing the predicate scope directive plus declaration line '$lgt_valid_predicate_property'(declared_in(_, _)). % object or category containing the predicate definition plus definition line '$lgt_valid_predicate_property'(defined_in(_, _)). % object or category containing the inherited but overridden predicate definition plus definition line '$lgt_valid_predicate_property'(redefined_from(_, _)). % entity where the predicate alias is declared plus declaration line '$lgt_valid_predicate_property'(alias_declared_in(_, _)). % predicate is an auxiliary predicate '$lgt_valid_predicate_property'(auxiliary). % predicate definition is inlined '$lgt_valid_predicate_property'(inline). % predicate definition is recursive '$lgt_valid_predicate_property'(recursive). % '$lgt_valid_protocol_property'(@nonvar) % built-in entity '$lgt_valid_protocol_property'(built_in). % dynamic entity (can be abolished at runtime) '$lgt_valid_protocol_property'((dynamic)). % static entity '$lgt_valid_protocol_property'(static). % entity compiled in debug mode '$lgt_valid_protocol_property'(debugging). % list of predicate indicators of public predicates declared in the entity '$lgt_valid_protocol_property'(public(_)). % list of predicate indicators of protected predicates declared in the entity '$lgt_valid_protocol_property'(protected(_)). % list of predicate indicators of private predicates declared in the entity '$lgt_valid_protocol_property'(private(_)). % list of declaration properties for a predicate declared in the entity '$lgt_valid_protocol_property'(declares(_, _)). % list of properties for a predicate alias declared in the entity '$lgt_valid_protocol_property'(alias(_, _)). % source data available for the entity '$lgt_valid_protocol_property'(source_data). % the remaining properties are available only when the entities are compiled with the "source_data" flag turned on % list of pairs with user-defined protocol documentation '$lgt_valid_protocol_property'(info(_)). % source file absolute path '$lgt_valid_protocol_property'(file(_)). % source file basename and directory '$lgt_valid_protocol_property'(file(_, _)). % start and end lines in a source file '$lgt_valid_protocol_property'(lines(_, _)). % start and end lines in a source file of the entity opening directive '$lgt_valid_protocol_property'(directive(_, _)). % '$lgt_valid_category_property'(@nonvar) % category properties include all protocol properties '$lgt_valid_category_property'(Property) :- '$lgt_valid_protocol_property'(Property), !. % messages sent from the object using the ::/2 control construct generate events '$lgt_valid_category_property'(events). % list of definition properties for a predicate defined in the category '$lgt_valid_category_property'(defines(_, _)). % list of definition properties for a multifile predicate defined in contributing entities '$lgt_valid_category_property'(includes(_, _, _)). % list of definition properties for a multifile predicate defined for other entities '$lgt_valid_category_property'(provides(_, _, _)). % list of calling properties for a predicate called in the entity '$lgt_valid_category_property'(calls(_, _)). % list of updating properties for a dynamic predicate updated in the entity '$lgt_valid_category_property'(updates(_, _)). % number of predicate clauses (including both user-defined and auxiliary clauses) '$lgt_valid_category_property'(number_of_clauses(_)). % number of predicate rules (including both user-defined and auxiliary clauses) '$lgt_valid_category_property'(number_of_rules(_)). % number of user-defined predicate clauses '$lgt_valid_category_property'(number_of_user_clauses(_)). % number of user-defined predicate rules '$lgt_valid_category_property'(number_of_user_rules(_)). % '$lgt_valid_object_property'(@nonvar) % object properties include all category and protocol properties '$lgt_valid_object_property'(Property) :- '$lgt_valid_category_property'(Property), !. % object contains calls to the built-in multi-threading predicates '$lgt_valid_object_property'(threaded). % object allows the use of the < true ; Bindings == yes -> true ; Bindings == false -> true ; Bindings == true -> 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). % Logtalk built-in predicates % % '$lgt_logtalk_built_in_predicate'(?callable, ?callable) % % the second argument is either a meta-predicate template % (when aplicable) or the atom "no" % message-sending and context-switching control constructs '$lgt_logtalk_built_in_predicate'(_ :: _, no). '$lgt_logtalk_built_in_predicate'(_ << _, no). % compiling and loading predicates '$lgt_logtalk_built_in_predicate'(logtalk_compile(_,_,_), no). '$lgt_logtalk_built_in_predicate'(logtalk_compile(_, _), no). '$lgt_logtalk_built_in_predicate'(logtalk_load(_), no). '$lgt_logtalk_built_in_predicate'(logtalk_load(_, _), no). '$lgt_logtalk_built_in_predicate'(logtalk_make, no). '$lgt_logtalk_built_in_predicate'(logtalk_make(_), no). '$lgt_logtalk_built_in_predicate'(logtalk_load_context(_, _), no). '$lgt_logtalk_built_in_predicate'(logtalk_library_path(_, _), no). '$lgt_logtalk_built_in_predicate'(logtalk_make_target_action(_), no). % entity properties '$lgt_logtalk_built_in_predicate'(protocol_property(_, _), no). '$lgt_logtalk_built_in_predicate'(category_property(_, _), no). '$lgt_logtalk_built_in_predicate'(object_property(_, _), no). % entity enumeration '$lgt_logtalk_built_in_predicate'(current_protocol(_), no). '$lgt_logtalk_built_in_predicate'(current_category(_), no). '$lgt_logtalk_built_in_predicate'(current_object(_), no). % entity creation predicates '$lgt_logtalk_built_in_predicate'(create_object(_, _, _, _), no). '$lgt_logtalk_built_in_predicate'(create_category(_, _, _, _), no). '$lgt_logtalk_built_in_predicate'(create_protocol(_, _, _), no). % entity abolishing predicates '$lgt_logtalk_built_in_predicate'(abolish_object(_), no). '$lgt_logtalk_built_in_predicate'(abolish_category(_), no). '$lgt_logtalk_built_in_predicate'(abolish_protocol(_), no). % entity relations '$lgt_logtalk_built_in_predicate'(implements_protocol(_, _), no). '$lgt_logtalk_built_in_predicate'(implements_protocol(_, _, _), no). '$lgt_logtalk_built_in_predicate'(imports_category(_, _), no). '$lgt_logtalk_built_in_predicate'(imports_category(_, _, _), no). '$lgt_logtalk_built_in_predicate'(instantiates_class(_, _), no). '$lgt_logtalk_built_in_predicate'(instantiates_class(_, _, _), no). '$lgt_logtalk_built_in_predicate'(specializes_class(_, _), no). '$lgt_logtalk_built_in_predicate'(specializes_class(_, _, _), no). '$lgt_logtalk_built_in_predicate'(extends_protocol(_, _), no). '$lgt_logtalk_built_in_predicate'(extends_protocol(_, _, _), no). '$lgt_logtalk_built_in_predicate'(extends_object(_, _), no). '$lgt_logtalk_built_in_predicate'(extends_object(_, _, _), no). '$lgt_logtalk_built_in_predicate'(extends_category(_, _), no). '$lgt_logtalk_built_in_predicate'(extends_category(_, _, _), no). '$lgt_logtalk_built_in_predicate'(complements_object(_, _), no). % protocol conformance '$lgt_logtalk_built_in_predicate'(conforms_to_protocol(_, _), no). '$lgt_logtalk_built_in_predicate'(conforms_to_protocol(_, _, _), no). % events '$lgt_logtalk_built_in_predicate'(abolish_events(_, _, _, _, _), no). '$lgt_logtalk_built_in_predicate'(define_events(_, _, _, _, _), no). '$lgt_logtalk_built_in_predicate'(current_event(_, _, _, _, _), no). % flags '$lgt_logtalk_built_in_predicate'(current_logtalk_flag(_, _), no). '$lgt_logtalk_built_in_predicate'(set_logtalk_flag(_, _), no). '$lgt_logtalk_built_in_predicate'(create_logtalk_flag(_, _, _), no). % multi-threading predicates '$lgt_logtalk_built_in_predicate'(threaded(_), threaded(0)). '$lgt_logtalk_built_in_predicate'(threaded_call(_, _), threaded_call(0, *)). '$lgt_logtalk_built_in_predicate'(threaded_call(_), threaded_call(0)). '$lgt_logtalk_built_in_predicate'(threaded_once(_, _), threaded_once(0, *)). '$lgt_logtalk_built_in_predicate'(threaded_once(_), threaded_once(0)). '$lgt_logtalk_built_in_predicate'(threaded_ignore(_), threaded_ignore(0)). '$lgt_logtalk_built_in_predicate'(threaded_exit(_, _), threaded_exit((::), *)). '$lgt_logtalk_built_in_predicate'(threaded_exit(_), threaded_exit((::))). '$lgt_logtalk_built_in_predicate'(threaded_peek(_, _), threaded_peek((::), *)). '$lgt_logtalk_built_in_predicate'(threaded_peek(_), threaded_peek((::))). '$lgt_logtalk_built_in_predicate'(threaded_cancel(_), threaded_cancel(*)). '$lgt_logtalk_built_in_predicate'(threaded_wait(_), no). '$lgt_logtalk_built_in_predicate'(threaded_notify(_), no). % threaded engines predicates '$lgt_logtalk_built_in_predicate'(threaded_engine_create(_, _, _), threaded_engine_create(*, 0, *)). '$lgt_logtalk_built_in_predicate'(threaded_engine_destroy(_), threaded_engine_destroy(*)). '$lgt_logtalk_built_in_predicate'(threaded_engine_self(_), threaded_engine_self(*)). '$lgt_logtalk_built_in_predicate'(threaded_engine(_), threaded_engine(*)). '$lgt_logtalk_built_in_predicate'(threaded_engine_next(_, _), threaded_engine_next(*, *)). '$lgt_logtalk_built_in_predicate'(threaded_engine_next_reified(_, _), threaded_engine_next_reified(*, *)). '$lgt_logtalk_built_in_predicate'(threaded_engine_yield(_), threaded_engine_yield(*)). '$lgt_logtalk_built_in_predicate'(threaded_engine_post(_, _), threaded_engine_post(*, *)). '$lgt_logtalk_built_in_predicate'(threaded_engine_fetch(_), threaded_engine_fetch(*)). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % DCG rule conversion % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % '$lgt_dcg_rule'(@grammar_rule, -clause, @compilation_context) % % converts a grammar rule into a normal clause '$lgt_dcg_rule'((RHead --> _), _, _) :- var(RHead), throw(instantiation_error). '$lgt_dcg_rule'((RHead, _ --> _), _, _) :- var(RHead), throw(instantiation_error). '$lgt_dcg_rule'((phrase(_), _ --> _), _, _) :- throw(permission_error(modify, built_in_non_terminal, phrase//1)). '$lgt_dcg_rule'((NonTerminal, _ --> _), _, _) :- functor(NonTerminal, call, Arity), Arity >= 1, throw(permission_error(modify, built_in_non_terminal, call//Arity)). '$lgt_dcg_rule'((Entity::NonTerminal, Terminals --> GRBody), (Entity::Head :- Body), Ctx) :- !, '$lgt_check'(object_identifier, Entity), '$lgt_dcg_non_terminal'(NonTerminal, S0, S, Head), '$lgt_dcg_body'(GRBody, S0, S1, Goal1, Ctx), '$lgt_dcg_terminals'(Terminals, S, S1, Goal2), Body = (Goal1, Goal2). '$lgt_dcg_rule'((':'(Module, NonTerminal), Terminals --> GRBody), (':'(Module, Head) :- Body), Ctx) :- !, '$lgt_check'(module_identifier, Module), '$lgt_dcg_non_terminal'(NonTerminal, S0, S, Head), '$lgt_dcg_body'(GRBody, S0, S1, Goal1, Ctx), '$lgt_dcg_terminals'(Terminals, S, S1, Goal2), Body = (Goal1, Goal2). '$lgt_dcg_rule'((NonTerminal, Terminals --> GRBody), _, Ctx) :- once(( '$lgt_variant'(GRBody, NonTerminal) ; GRBody = (GRFirst, _), '$lgt_variant'(GRFirst, NonTerminal) )), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(left_recursion, warning), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(left_recursion), left_recursion(File, Lines, Type, Entity, (NonTerminal, Terminals --> GRBody)) ), fail. '$lgt_dcg_rule'((NonTerminal, Terminals --> GRBody), (Head :- Body), Ctx) :- !, '$lgt_dcg_non_terminal'(NonTerminal, S0, S, Head), '$lgt_dcg_body'(GRBody, S0, S1, Goal1, Ctx), '$lgt_dcg_terminals'(Terminals, S, S1, Goal2), Body = (Goal1, Goal2), functor(NonTerminal, Functor, Arity), ( '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), \+ '$lgt_pp_defines_non_terminal_'(Functor, Arity, _) -> ExtArity is Arity + 2, assertz('$lgt_pp_defines_non_terminal_'(Functor, Arity, ExtArity)) ; true ). '$lgt_dcg_rule'((phrase(_) --> _), _, _) :- throw(permission_error(modify, built_in_non_terminal, phrase//1)). '$lgt_dcg_rule'((NonTerminal --> _), _, _) :- functor(NonTerminal, call, Arity), Arity >= 1, throw(permission_error(modify, built_in_non_terminal, call//Arity)). '$lgt_dcg_rule'((eos --> _), _, _) :- throw(permission_error(modify, built_in_non_terminal, eos//0)). '$lgt_dcg_rule'((Entity::NonTerminal --> GRBody), (Entity::Head :- Body), Ctx) :- !, '$lgt_check'(object_identifier, Entity), '$lgt_dcg_non_terminal'(NonTerminal, S0, S, Head), '$lgt_dcg_body'(GRBody, S0, S, Body, Ctx). '$lgt_dcg_rule'((':'(Module, NonTerminal) --> GRBody), (':'(Module, Head) :- Body), Ctx) :- !, '$lgt_check'(module_identifier, Module), '$lgt_dcg_non_terminal'(NonTerminal, S0, S, Head), '$lgt_dcg_body'(GRBody, S0, S, Body, Ctx). '$lgt_dcg_rule'((NonTerminal --> GRBody), _, Ctx) :- once(( '$lgt_variant'(GRBody, NonTerminal) ; GRBody = (GRFirst, _), '$lgt_variant'(GRFirst, NonTerminal) )), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(left_recursion, warning), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(left_recursion), left_recursion(File, Lines, Type, Entity, (NonTerminal --> GRBody)) ), fail. '$lgt_dcg_rule'((NonTerminal --> GRBody), (Head :- Body), Ctx) :- !, '$lgt_dcg_non_terminal'(NonTerminal, S0, S, Head), '$lgt_dcg_body'(GRBody, S0, S, Body, Ctx), functor(NonTerminal, Functor, Arity), ( '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), \+ '$lgt_pp_defines_non_terminal_'(Functor, Arity, _) -> ExtArity is Arity + 2, assertz('$lgt_pp_defines_non_terminal_'(Functor, Arity, ExtArity)) ; true ). '$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, _, _, _) :- '$lgt_check'(callable, NonTerminal), '$lgt_pp_protocol_'(_, _, _, _, _), % protocols cannot contain non-terminal definitions functor(NonTerminal, Functor, Arity), throw(permission_error(define, non_terminal, Functor//Arity)). '$lgt_dcg_non_terminal'((_ ; _), _, _, _) :- throw(permission_error(modify, control_construct, (;)/2)). '$lgt_dcg_non_terminal'((_ -> _), _, _, _) :- throw(permission_error(modify, control_construct, (->)/2)). '$lgt_dcg_non_terminal'('*->'(_, _), _, _, _) :- '$lgt_predicate_property'('*->'(_, _), built_in), throw(permission_error(modify, control_construct, (*->)/2)). '$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, S0, S, S0 = List) :- '$lgt_check'(list, Terminals), '$lgt_append'(Terminals, S, List). % '$lgt_dcg_msg'(@dcgbody @object_identifier, @var, @var, -body) % % translates a grammar rule message to an object into a predicate message '$lgt_dcg_msg'(Var, Obj, S0, S, phrase(Obj::Var, S0, S)) :- var(Var), !. '$lgt_dcg_msg'('*->'(GRIf, GRThen), Obj, S0, S, '*->'(If, Then)) :- '$lgt_predicate_property'('*->'(_, _), built_in), !, '$lgt_dcg_msg'(GRIf, Obj, S0, S1, If), '$lgt_dcg_msg'(GRThen, Obj, S1, S, Then). '$lgt_dcg_msg'((GRIf -> GRThen), Obj, S0, S, (If -> Then)) :- !, '$lgt_dcg_msg'(GRIf, Obj, S0, S1, If), '$lgt_dcg_msg'(GRThen, Obj, S1, S, Then). '$lgt_dcg_msg'((GREither; GROr), Obj, S0, S, (Either; Or)) :- !, '$lgt_dcg_msg'(GREither, Obj, S0, S, Either), '$lgt_dcg_msg'(GROr, Obj, S0, S, Or). '$lgt_dcg_msg'((GRFirst, GRSecond), Obj, S0, S, (First, Second)) :- !, '$lgt_dcg_msg'(GRFirst, Obj, S0, S1, First), '$lgt_dcg_msg'(GRSecond, Obj, S1, S, Second). '$lgt_dcg_msg'(!, _, S0, S, (!, (S0 = S))) :- !. '$lgt_dcg_msg'(NonTerminal, Obj, S0, S, Obj::Pred) :- '$lgt_dcg_non_terminal'(NonTerminal, S0, S, Pred). % '$lgt_dcg_self_msg'(@dcgbody, @var, @var, -body, -body) % % translates a grammar rule message to an object into a predicate message '$lgt_dcg_self_msg'(Var, S0, S, phrase(::Var, S0, S)) :- var(Var), !. '$lgt_dcg_self_msg'('*->'(GRIf, GRThen), S0, S, '*->'(If, Then)) :- '$lgt_predicate_property'('*->'(_, _), built_in), !, '$lgt_dcg_self_msg'(GRIf, S0, S1, If), '$lgt_dcg_self_msg'(GRThen, S1, S, Then). '$lgt_dcg_self_msg'((GRIf -> GRThen), S0, S, (If -> Then)) :- !, '$lgt_dcg_self_msg'(GRIf, S0, S1, If), '$lgt_dcg_self_msg'(GRThen, S1, S, Then). '$lgt_dcg_self_msg'((GREither; GROr), S0, S, (Either; Or)) :- !, '$lgt_dcg_self_msg'(GREither, S0, S, Either), '$lgt_dcg_self_msg'(GROr, S0, S, Or). '$lgt_dcg_self_msg'((GRFirst, GRSecond), S0, S, (First, Second)) :- !, '$lgt_dcg_self_msg'(GRFirst, S0, S1, First), '$lgt_dcg_self_msg'(GRSecond, S1, S, Second). '$lgt_dcg_self_msg'(!, S0, S, (!, (S0 = S))) :- !. '$lgt_dcg_self_msg'(NonTerminal, S0, S, ::Pred) :- '$lgt_dcg_non_terminal'(NonTerminal, S0, S, Pred). % '$lgt_dcg_super_call'(@dcgbody, @var, @var, -body) % % translates a super call to a grammar rule in an ancestor entity '$lgt_dcg_super_call'(Var, S0, S, phrase(^^Var, S0, S)) :- var(Var), !. '$lgt_dcg_super_call'(NonTerminal, S0, S, ^^Pred) :- '$lgt_dcg_non_terminal'(NonTerminal, S0, S, Pred). % '$lgt_dcg_body'(@dcgbody, @var, @var, -body, @compilation_context) % % 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'('$lgt_closure'(TFunctor, TArgs, ExCtx), S0, S, {TGoal}, _) :- % pre-compiled closure (note that the closure may be called from a mapping % predicate, which prevents us to use a difference list based solution to % avoid the calls to append/3 and =../2 as that would fix the extra arguments % in the goal on the first closure call and thus break the followup calls) !, '$lgt_append'(TArgs, [S0, S, ExCtx], FullArgs), TGoal =.. [TFunctor| FullArgs]. '$lgt_dcg_body'(Free/Parameters>>Lambda, S0, S, call(Free/Parameters>>Lambda, S0, S), Ctx) :- !, '$lgt_check_lambda_expression'(Free/Parameters>>Lambda, Ctx), ( \+ Parameters \= [_, _] -> true ; throw(representation_error(lambda_parameters)) ). '$lgt_dcg_body'(Parameters>>Lambda, S0, S, call(Parameters>>Lambda, S0, S), Ctx) :- !, '$lgt_check_lambda_expression'(Parameters>>Lambda, Ctx), ( \+ Parameters \= [_, _] -> true ; throw(representation_error(lambda_parameters)) ). '$lgt_dcg_body'(Free/Lambda, S0, S, call(Free/Lambda, S0, S), Ctx) :- !, '$lgt_check_lambda_expression'(Free/Lambda, Ctx). '$lgt_dcg_body'(Obj::RGoal, S0, S, CGoal, _) :- !, '$lgt_dcg_msg'(RGoal, Obj, S0, S, CGoal). '$lgt_dcg_body'(::RGoal, S0, S, CGoal, _) :- !, '$lgt_dcg_self_msg'(RGoal, S0, S, CGoal). '$lgt_dcg_body'(^^RGoal, S0, S, CGoal, _) :- !, '$lgt_dcg_super_call'(RGoal, S0, S, CGoal). '$lgt_dcg_body'(Obj< RGoal =.. RGoalUniv, '$lgt_append'(RGoalUniv, [S0, S], GoalUniv), Goal =.. GoalUniv, CGoal = ':'(Module, Goal) ; CGoal = call(':'(Module,RGoal), S0, S) ). '$lgt_dcg_body'((GRIfThen; GRElse), S0, S, (If -> Then; Else), Ctx) :- nonvar(GRIfThen), GRIfThen = (GRIf -> GRThen), !, '$lgt_dcg_body'(GRIf, S0, S1, If, Ctx), '$lgt_dcg_body'(GRThen, S1, S, Then, Ctx), '$lgt_dcg_body'(GRElse, S0, S, Else, Ctx). '$lgt_dcg_body'((GRIfThen; GRElse), S0, S, ('*->'(If, Then); Else), Ctx) :- nonvar(GRIfThen), GRIfThen = '*->'(GRIf, GRThen), '$lgt_predicate_property'('*->'(_, _), built_in), !, '$lgt_dcg_body'(GRIf, S0, S1, If, Ctx), '$lgt_dcg_body'(GRThen, S1, S, Then, Ctx), '$lgt_dcg_body'(GRElse, S0, S, Else, Ctx). '$lgt_dcg_body'((GREither; GROr), S0, S, (Either; Or), Ctx) :- !, '$lgt_dcg_body'(GREither, S0, S, Either0, Ctx), '$lgt_fix_disjunction_left_side'(Either0, Either), '$lgt_dcg_body'(GROr, S0, S, Or, Ctx). '$lgt_dcg_body'('|'(GREither, GROr), S0, S, (Either; Or), Ctx) :- !, '$lgt_dcg_body'(GREither, S0, S, Either0, Ctx), '$lgt_fix_disjunction_left_side'(Either0, Either), '$lgt_dcg_body'(GROr, S0, S, Or, Ctx). '$lgt_dcg_body'('*->'(GRIf, GRThen), _, _, _, Ctx) :- '$lgt_predicate_property'('*->'(_, _), built_in), nonvar(GRIf), \+ functor(GRIf, {}, 1), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(grammar_rules, warning), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(grammar_rules), unsound_construct_in_grammar_rule(File, Lines, Type, Entity, '*->'(GRIf, GRThen)) ), fail. '$lgt_dcg_body'('*->'(GRIf, GRThen), S0, S, '*->'(If, Then), Ctx) :- '$lgt_predicate_property'('*->'(_, _), built_in), !, '$lgt_dcg_body'(GRIf, S0, S1, If, Ctx), '$lgt_dcg_body'(GRThen, S1, S, Then, Ctx). '$lgt_dcg_body'((GRIf -> GRThen), _, _, _, Ctx) :- nonvar(GRIf), \+ functor(GRIf, {}, 1), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(grammar_rules, warning), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(grammar_rules), unsound_construct_in_grammar_rule(File, Lines, Type, Entity, (GRIf -> GRThen)) ), fail. '$lgt_dcg_body'((GRIf -> GRThen), S0, S, (If -> Then), Ctx) :- !, '$lgt_dcg_body'(GRIf, S0, S1, If, Ctx), '$lgt_dcg_body'(GRThen, S1, S, Then, Ctx). '$lgt_dcg_body'((GRFirst, GRSecond), S0, S, (First, Second), Ctx) :- !, '$lgt_dcg_body'(GRFirst, S0, S1, First, Ctx), '$lgt_dcg_body'(GRSecond, S1, S, Second, Ctx). '$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}, S0, S, (Goal, (S0 = S)), _) :- !, '$lgt_check'(callable, Goal). '$lgt_dcg_body'(\+ GRBody, _, _, _, Ctx) :- nonvar(GRBody), \+ functor(GRBody, {}, 1), '$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)), '$lgt_compiler_flag'(grammar_rules, warning), '$lgt_source_file_context'(File, Lines, Type, Entity), '$lgt_increment_compiling_warnings_counter', '$lgt_print_message'( warning(grammar_rules), unsound_construct_in_grammar_rule(File, Lines, Type, Entity, \+ GRBody) ), fail. '$lgt_dcg_body'(\+ GRBody, S0, S, (\+ Goal, (S0 = S)), Ctx) :- !, '$lgt_dcg_body'(GRBody, S0, _, Goal, Ctx). '$lgt_dcg_body'(catch(GRGoal, Catcher, GRRecovery), S0, S, catch(Goal, Catcher, Recovery), Ctx) :- !, '$lgt_dcg_body'(GRGoal, S0, S, Goal, Ctx), '$lgt_dcg_body'(GRRecovery, S0, S, Recovery, Ctx). '$lgt_dcg_body'(phrase(GRBody), S0, S, phrase(GRBody, S0, S), _) :- !. '$lgt_dcg_body'(eos, S0, S, (S0 = [], S = []), _) :- !. '$lgt_dcg_body'(GRBody, S0, S, Goal, _) :- functor(GRBody, call, Arity), Arity >= 1, !, GRBody =.. [call, Closure| ExtraArgs], '$lgt_check'(var_or_callable, Closure), '$lgt_append'(ExtraArgs, [S0, S], FullArgs), % translate to the internal '$lgt_callN'/2 predicate instead of the call/N control % construct to avoid lint warnings about redundant uses of the control construct Goal = '$lgt_callN'(Closure, FullArgs). '$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'(String, S0, S, Goal, _) :- '$lgt_string'(String), !, '$lgt_string_codes'(String, Codes), '$lgt_dcg_terminals'(Codes, S0, S, Goal). '$lgt_dcg_body'(Alias, S0, S, Goal, Ctx) :- '$lgt_pp_uses_non_terminal_'(Obj, Original, Alias, Pred, PredAlias, Ctx, _, _), !, % we must register here otherwise the non-terminal alias information would be lost '$lgt_comp_ctx'(Ctx, Head, _, _, _, _, _, _, _, _, _, Mode, _, _, _), '$lgt_add_referenced_object_message'(Mode, Obj, Pred, PredAlias, Head), '$lgt_dcg_body'(Obj::Original, S0, S, Goal, Ctx). '$lgt_dcg_body'(Alias, S0, S, Goal, Ctx) :- '$lgt_pp_use_module_non_terminal_'(Module, Original, Alias, Pred, PredAlias, Ctx, _, _), !, % we must register here otherwise the non-terminal alias information would be lost '$lgt_comp_ctx'(Ctx, Head, _, _, _, _, _, _, _, _, _, Mode, _, _, _), '$lgt_add_referenced_module_predicate'(Mode, Module, Pred, PredAlias, Head), '$lgt_dcg_body'(':'(Module, Original), S0, S, Goal, Ctx). '$lgt_dcg_body'(NonTerminal, S0, S, Goal, Ctx) :- '$lgt_dcg_non_terminal'(NonTerminal, S0, S, Goal), functor(NonTerminal, Functor, Arity), '$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, _, _, _, _, Mode, _, Lines, _), ( Mode = compile(_,_,_), \+ '$lgt_pp_calls_non_terminal_'(Functor, Arity, _, Lines) -> ExtArity is Arity + 2, assertz('$lgt_pp_calls_non_terminal_'(Functor, Arity, ExtArity, Lines)) ; true ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % table of ISO Prolog specified built-in predicates % % (used for portability checking) % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % '$lgt_iso_spec_predicate'(?callable) % control constructs '$lgt_iso_spec_predicate'(true). '$lgt_iso_spec_predicate'(fail). '$lgt_iso_spec_predicate'(false). '$lgt_iso_spec_predicate'(call(_)). '$lgt_iso_spec_predicate'(call(_, _)). '$lgt_iso_spec_predicate'(call(_, _, _)). '$lgt_iso_spec_predicate'(call(_, _, _, _)). '$lgt_iso_spec_predicate'(call(_, _, _, _, _)). '$lgt_iso_spec_predicate'(call(_, _, _, _, _, _)). '$lgt_iso_spec_predicate'(call(_, _, _, _, _, _, _)). '$lgt_iso_spec_predicate'(call(_, _, _, _, _, _, _, _)). '$lgt_iso_spec_predicate'(!). '$lgt_iso_spec_predicate'((Goal; _)) :- ( var(Goal) -> true ; Goal \= '*->'(_, _) ). '$lgt_iso_spec_predicate'((_, _)). '$lgt_iso_spec_predicate'((_ -> _)). '$lgt_iso_spec_predicate'(catch(_, _, _)). '$lgt_iso_spec_predicate'(throw(_)). % term unification '$lgt_iso_spec_predicate'((_ = _)). '$lgt_iso_spec_predicate'((_ \= _)). '$lgt_iso_spec_predicate'(unify_with_occurs_check(_, _)). '$lgt_iso_spec_predicate'(subsumes_term(_, _)). % term testing '$lgt_iso_spec_predicate'(var(_)). '$lgt_iso_spec_predicate'(nonvar(_)). '$lgt_iso_spec_predicate'(atom(_)). '$lgt_iso_spec_predicate'(atomic(_)). '$lgt_iso_spec_predicate'(number(_)). '$lgt_iso_spec_predicate'(integer(_)). '$lgt_iso_spec_predicate'(float(_)). '$lgt_iso_spec_predicate'(compound(_)). '$lgt_iso_spec_predicate'(acyclic_term(_)). '$lgt_iso_spec_predicate'(callable(_)). '$lgt_iso_spec_predicate'(ground(_)). % term comparison '$lgt_iso_spec_predicate'((_ @=< _)). '$lgt_iso_spec_predicate'((_ @< _)). '$lgt_iso_spec_predicate'((_ @>= _)). '$lgt_iso_spec_predicate'((_ @> _)). '$lgt_iso_spec_predicate'((_ == _)). '$lgt_iso_spec_predicate'((_ \== _)). '$lgt_iso_spec_predicate'(compare(_, _, _)). % term creation and decomposition '$lgt_iso_spec_predicate'(functor(_, _, _)). '$lgt_iso_spec_predicate'(arg(_, _, _)). '$lgt_iso_spec_predicate'(_ =.. _). '$lgt_iso_spec_predicate'(copy_term(_, _)). '$lgt_iso_spec_predicate'(term_variables(_, _)). % arithmetic evaluation '$lgt_iso_spec_predicate'(_ is _). % arithmetic comparison '$lgt_iso_spec_predicate'((_ =< _)). '$lgt_iso_spec_predicate'((_ < _)). '$lgt_iso_spec_predicate'((_ >= _)). '$lgt_iso_spec_predicate'((_ > _)). '$lgt_iso_spec_predicate'((_ =:= _)). '$lgt_iso_spec_predicate'((_ =\= _)). % database '$lgt_iso_spec_predicate'(clause(_, _)). '$lgt_iso_spec_predicate'(current_predicate(_)). '$lgt_iso_spec_predicate'(asserta(_)). '$lgt_iso_spec_predicate'(assertz(_)). '$lgt_iso_spec_predicate'(retract(_)). '$lgt_iso_spec_predicate'(retractall(_)). '$lgt_iso_spec_predicate'(abolish(_)). % all solutions '$lgt_iso_spec_predicate'(findall(_, _, _)). '$lgt_iso_spec_predicate'(bagof(_, _, _)). '$lgt_iso_spec_predicate'(setof(_, _, _)). % stream selection and control '$lgt_iso_spec_predicate'(current_input(_)). '$lgt_iso_spec_predicate'(current_output(_)). '$lgt_iso_spec_predicate'(set_input(_)). '$lgt_iso_spec_predicate'(set_output(_)). '$lgt_iso_spec_predicate'(open(_, _, _, _)). '$lgt_iso_spec_predicate'(open(_, _, _)). '$lgt_iso_spec_predicate'(close(_, _)). '$lgt_iso_spec_predicate'(close(_)). '$lgt_iso_spec_predicate'(flush_output(_)). '$lgt_iso_spec_predicate'(flush_output). '$lgt_iso_spec_predicate'(stream_property(_, _)). '$lgt_iso_spec_predicate'(at_end_of_stream). '$lgt_iso_spec_predicate'(at_end_of_stream(_)). '$lgt_iso_spec_predicate'(set_stream_position(_, _)). % character and byte input/output '$lgt_iso_spec_predicate'(get_char(_, _)). '$lgt_iso_spec_predicate'(get_char(_)). '$lgt_iso_spec_predicate'(get_code(_, _)). '$lgt_iso_spec_predicate'(get_code(_)). '$lgt_iso_spec_predicate'(peek_char(_, _)). '$lgt_iso_spec_predicate'(peek_char(_)). '$lgt_iso_spec_predicate'(peek_code(_, _)). '$lgt_iso_spec_predicate'(peek_code(_)). '$lgt_iso_spec_predicate'(put_char(_, _)). '$lgt_iso_spec_predicate'(put_char(_)). '$lgt_iso_spec_predicate'(put_code(_, _)). '$lgt_iso_spec_predicate'(put_code(_)). '$lgt_iso_spec_predicate'(nl). '$lgt_iso_spec_predicate'(nl(_)). '$lgt_iso_spec_predicate'(get_byte(_, _)). '$lgt_iso_spec_predicate'(get_byte(_)). '$lgt_iso_spec_predicate'(peek_byte(_, _)). '$lgt_iso_spec_predicate'(peek_byte(_)). '$lgt_iso_spec_predicate'(put_byte(_, _)). '$lgt_iso_spec_predicate'(put_byte(_)). % term input/output '$lgt_iso_spec_predicate'(read_term(_, _, _)). '$lgt_iso_spec_predicate'(read_term(_, _)). '$lgt_iso_spec_predicate'(read(_)). '$lgt_iso_spec_predicate'(read(_, _)). '$lgt_iso_spec_predicate'(write_term(_, _, _)). '$lgt_iso_spec_predicate'(write_term(_, _)). '$lgt_iso_spec_predicate'(write(_)). '$lgt_iso_spec_predicate'(write(_, _)). '$lgt_iso_spec_predicate'(writeq(_)). '$lgt_iso_spec_predicate'(writeq(_, _)). '$lgt_iso_spec_predicate'(write_canonical(_)). '$lgt_iso_spec_predicate'(write_canonical(_, _)). '$lgt_iso_spec_predicate'(op(_, _, _)). '$lgt_iso_spec_predicate'(current_op(_, _, _)). '$lgt_iso_spec_predicate'(char_conversion(_, _)). '$lgt_iso_spec_predicate'(current_char_conversion(_, _)). % logic and control '$lgt_iso_spec_predicate'(\+ _). '$lgt_iso_spec_predicate'(once(_)). '$lgt_iso_spec_predicate'(repeat). % atomic term processing '$lgt_iso_spec_predicate'(atom_length(_, _)). '$lgt_iso_spec_predicate'(atom_concat(_, _, _)). '$lgt_iso_spec_predicate'(sub_atom(_, _, _, _, _)). '$lgt_iso_spec_predicate'(atom_chars(_, _)). '$lgt_iso_spec_predicate'(atom_codes(_, _)). '$lgt_iso_spec_predicate'(char_code(_, _)). '$lgt_iso_spec_predicate'(number_chars(_, _)). '$lgt_iso_spec_predicate'(number_codes(_, _)). % implementation defined hooks functions '$lgt_iso_spec_predicate'(set_prolog_flag(_, _)). '$lgt_iso_spec_predicate'(current_prolog_flag(_, _)). '$lgt_iso_spec_predicate'(halt). '$lgt_iso_spec_predicate'(halt(_)). % sorting '$lgt_iso_spec_predicate'(keysort(_, _)). '$lgt_iso_spec_predicate'(sort(_, _)). % the following predicates are not part of the ISO/IEC 13211-1 Prolog standard % but can be found either on Core Revision standardization proposals or, % more important, these predicates are or are becoming de facto standards % term creation and decomposition '$lgt_iso_spec_predicate'(numbervars(_, _, _)). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % table of ISO Prolog specified arithmetic functions % % (used by the linter for portability checking) % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % '$lgt_iso_spec_function'(?callable) '$lgt_iso_spec_function'(pi). '$lgt_iso_spec_function'('+'(_)). '$lgt_iso_spec_function'('-'(_)). '$lgt_iso_spec_function'('+'(_, _)). '$lgt_iso_spec_function'('-'(_, _)). '$lgt_iso_spec_function'('*'(_, _)). '$lgt_iso_spec_function'('/'(_, _)). '$lgt_iso_spec_function'('//'(_, _)). '$lgt_iso_spec_function'(rem(_, _)). '$lgt_iso_spec_function'(mod(_, _)). '$lgt_iso_spec_function'(div(_, _)). '$lgt_iso_spec_function'('/\\'(_, _)). '$lgt_iso_spec_function'('\\/'(_, _)). '$lgt_iso_spec_function'('\\'(_)). '$lgt_iso_spec_function'('<<'(_, _)). '$lgt_iso_spec_function'('>>'(_, _)). '$lgt_iso_spec_function'(xor(_, _)). '$lgt_iso_spec_function'('**'(_, _)). '$lgt_iso_spec_function'('^'(_, _)). '$lgt_iso_spec_function'(abs(_)). '$lgt_iso_spec_function'(sign(_)). '$lgt_iso_spec_function'(sqrt(_)). '$lgt_iso_spec_function'(acos(_)). '$lgt_iso_spec_function'(asin(_)). '$lgt_iso_spec_function'(atan(_)). '$lgt_iso_spec_function'(atan2(_, _)). '$lgt_iso_spec_function'(cos(_)). '$lgt_iso_spec_function'(sin(_)). '$lgt_iso_spec_function'(tan(_)). '$lgt_iso_spec_function'(exp(_)). '$lgt_iso_spec_function'(log(_)). '$lgt_iso_spec_function'(float(_)). '$lgt_iso_spec_function'(ceiling(_)). '$lgt_iso_spec_function'(floor(_)). '$lgt_iso_spec_function'(round(_)). '$lgt_iso_spec_function'(truncate(_)). '$lgt_iso_spec_function'(float_fractional_part(_)). '$lgt_iso_spec_function'(float_integer_part(_)). '$lgt_iso_spec_function'(max(_, _)). '$lgt_iso_spec_function'(min(_, _)). % the following functions are not part of the ISO/IEC 13211-1 Prolog standard % but can be found either on Core Revision standardization proposals or, % more important, these functions are or are becoming de facto standards '$lgt_iso_spec_function'(e). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % auxiliary predicates checking for float and integer arithmetic % expressions (used for linter checks) % % these checks also recognize de facto standard arithmetic constants % and functions % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % '$lgt_float_expression'(@term) '$lgt_float_expression'(Exp) :- var(Exp), !, fail. '$lgt_float_expression'(Exp) :- float(Exp), !. % basic arithmetic functions '$lgt_float_expression'(Exp1 + Exp2) :- ( '$lgt_float_expression'(Exp1) -> true ; '$lgt_float_expression'(Exp2) ). '$lgt_float_expression'(Exp1 - Exp2) :- ( '$lgt_float_expression'(Exp1) -> true ; '$lgt_float_expression'(Exp2) ). '$lgt_float_expression'(Exp1 * Exp2) :- ( '$lgt_float_expression'(Exp1) -> true ; '$lgt_float_expression'(Exp2) ). '$lgt_float_expression'(_ / _). '$lgt_float_expression'(_ ** _). % other functions '$lgt_float_expression'(abs(Exp)) :- '$lgt_float_expression'(Exp). '$lgt_float_expression'(sign(Exp)) :- '$lgt_float_expression'(Exp). '$lgt_float_expression'(max(Exp1, Exp2)) :- ( '$lgt_float_expression'(Exp1) -> true ; '$lgt_float_expression'(Exp2) ). '$lgt_float_expression'(min(Exp1, Exp2)) :- ( '$lgt_float_expression'(Exp1) -> true ; '$lgt_float_expression'(Exp2) ). '$lgt_float_expression'(float_integer_part(_)). '$lgt_float_expression'(float_fractional_part(_)). '$lgt_float_expression'(sqrt(_)). '$lgt_float_expression'(exp(_)). '$lgt_float_expression'(log(_)). '$lgt_float_expression'(log(_, _)). '$lgt_float_expression'(log10(_)). % trignometric functions '$lgt_float_expression'(acos(_)). '$lgt_float_expression'(asin(_)). '$lgt_float_expression'(atan(_)). '$lgt_float_expression'(atan2(_, _)). '$lgt_float_expression'(cos(_)). '$lgt_float_expression'(sin(_)). '$lgt_float_expression'(tan(_)). % hyperbolic functions '$lgt_float_expression'(sinh(_)). '$lgt_float_expression'(cosh(_)). '$lgt_float_expression'(tanh(_)). '$lgt_float_expression'(asinh(_)). '$lgt_float_expression'(acosh(_)). '$lgt_float_expression'(atanh(_)). % float arithmetic constants '$lgt_float_expression'(e). '$lgt_float_expression'(pi). '$lgt_float_expression'(epsilon). % '$lgt_integer_expression'(@term) '$lgt_integer_expression'(Exp) :- var(Exp), !, fail. '$lgt_integer_expression'(Exp) :- integer(Exp), !. % basic arithmetic functions '$lgt_integer_expression'(Exp1 + Exp2) :- '$lgt_integer_expression'(Exp1), '$lgt_integer_expression'(Exp2). '$lgt_integer_expression'(Exp1 - Exp2) :- '$lgt_integer_expression'(Exp1), '$lgt_integer_expression'(Exp2). '$lgt_integer_expression'(Exp1 * Exp2) :- '$lgt_integer_expression'(Exp1), '$lgt_integer_expression'(Exp2). '$lgt_integer_expression'(_ // _). % other functions '$lgt_integer_expression'(rem(_, _)). '$lgt_integer_expression'(div(_, _)). '$lgt_integer_expression'(mod(_, _)). '$lgt_integer_expression'(gcd(_, _)). '$lgt_integer_expression'(round(_)). '$lgt_integer_expression'(truncate(_)). '$lgt_integer_expression'(abs(Exp)) :- '$lgt_integer_expression'(Exp). '$lgt_integer_expression'(sign(Exp)) :- '$lgt_integer_expression'(Exp). '$lgt_integer_expression'(max(Exp1, Exp2)) :- '$lgt_integer_expression'(Exp1), '$lgt_integer_expression'(Exp2). '$lgt_integer_expression'(min(Exp1, Exp2)) :- '$lgt_integer_expression'(Exp1), '$lgt_integer_expression'(Exp2). % bitwise functions '$lgt_integer_expression'(_ << _). '$lgt_integer_expression'(_ >> _). '$lgt_integer_expression'(_ /\ _). '$lgt_integer_expression'(_ \/ _). '$lgt_integer_expression'(xor(_, _)). '$lgt_integer_expression'(\ _). '$lgt_integer_expression'(lsb(_)). '$lgt_integer_expression'(msb(_)). '$lgt_integer_expression'(popcount(_)). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % table of ISO Prolog operators % % (used by the linter for portability checking) % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % '$lgt_iso_spec_operator'(?atom, ?atom, ?integer) '$lgt_iso_spec_operator'((:-), xfx, 1200). '$lgt_iso_spec_operator'((-->), xfx, 1200). '$lgt_iso_spec_operator'((:-), fx, 1200). '$lgt_iso_spec_operator'((?-), fx, 1200). '$lgt_iso_spec_operator'((;), xfy, 1100). '$lgt_iso_spec_operator'((->), xfy, 1050). '$lgt_iso_spec_operator'((','), xfy, 1000). '$lgt_iso_spec_operator'((\+), fy, 900). '$lgt_iso_spec_operator'((=), xfx, 700). '$lgt_iso_spec_operator'((\=), xfx, 700). '$lgt_iso_spec_operator'((==), xfx, 700). '$lgt_iso_spec_operator'((\==), xfx, 700). '$lgt_iso_spec_operator'((@<), xfx, 700). '$lgt_iso_spec_operator'((@=<), xfx, 700). '$lgt_iso_spec_operator'((@>), xfx, 700). '$lgt_iso_spec_operator'((@>=), xfx, 700). '$lgt_iso_spec_operator'((=..), xfx, 700). '$lgt_iso_spec_operator'((is), xfx, 700). '$lgt_iso_spec_operator'((=:=), xfx, 700). '$lgt_iso_spec_operator'((=\=), xfx, 700). '$lgt_iso_spec_operator'((<), xfx, 700). '$lgt_iso_spec_operator'((=<), xfx, 700). '$lgt_iso_spec_operator'((>), xfx, 700). '$lgt_iso_spec_operator'((>=), xfx, 700). '$lgt_iso_spec_operator'((:), xfy, 600). '$lgt_iso_spec_operator'((+), yfx, 500). '$lgt_iso_spec_operator'((-), yfx, 500). '$lgt_iso_spec_operator'((/\), yfx, 500). '$lgt_iso_spec_operator'((\/), yfx, 500). '$lgt_iso_spec_operator'((*), yfx, 400). '$lgt_iso_spec_operator'((/), yfx, 400). '$lgt_iso_spec_operator'((//), yfx, 400). '$lgt_iso_spec_operator'((rem), yfx, 400). '$lgt_iso_spec_operator'((mod), yfx, 400). '$lgt_iso_spec_operator'((<<), yfx, 400). '$lgt_iso_spec_operator'((>>), yfx, 400). '$lgt_iso_spec_operator'((**), xfx, 200). '$lgt_iso_spec_operator'((^), xfy, 200). '$lgt_iso_spec_operator'((+), fy, 200). '$lgt_iso_spec_operator'((-), fy, 200). '$lgt_iso_spec_operator'((\), fy, 200). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % table of ISO Prolog specified flags % % (used for portability checking) % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % '$lgt_iso_spec_flag'(?atom) '$lgt_iso_spec_flag'(bounded). '$lgt_iso_spec_flag'(max_integer). '$lgt_iso_spec_flag'(min_integer). '$lgt_iso_spec_flag'(integer_rounding_function). '$lgt_iso_spec_flag'(max_arity). '$lgt_iso_spec_flag'(char_conversion). '$lgt_iso_spec_flag'(debug). '$lgt_iso_spec_flag'(double_quotes). '$lgt_iso_spec_flag'(unknown). % the following flags are not part of the ISO/IEC 13211-1 Prolog standard % but can be found either on the Core Revision standardization proposal or, % more important, these flags are de facto standard '$lgt_iso_spec_flag'(dialect). '$lgt_iso_spec_flag'(version_data). % '$lgt_iso_spec_flag_value'(+atom, @nonvar) '$lgt_iso_spec_flag_value'(bounded, true) :- !. '$lgt_iso_spec_flag_value'(bounded, false) :- !. '$lgt_iso_spec_flag_value'(max_integer, Value) :- integer(Value). '$lgt_iso_spec_flag_value'(min_integer, Value) :- integer(Value). '$lgt_iso_spec_flag_value'(integer_rounding_function, toward_zero) :- !. '$lgt_iso_spec_flag_value'(integer_rounding_function, down) :- !. '$lgt_iso_spec_flag_value'(max_arity, Value) :- integer(Value). '$lgt_iso_spec_flag_value'(char_conversion, on) :- !. '$lgt_iso_spec_flag_value'(char_conversion, off) :- !. '$lgt_iso_spec_flag_value'(debug, on) :- !. '$lgt_iso_spec_flag_value'(debug, off) :- !. '$lgt_iso_spec_flag_value'(double_quotes, atom) :- !. '$lgt_iso_spec_flag_value'(double_quotes, chars) :- !. '$lgt_iso_spec_flag_value'(double_quotes, codes) :- !. '$lgt_iso_spec_flag_value'(unknown, error) :- !. '$lgt_iso_spec_flag_value'(unknown, warning) :- !. '$lgt_iso_spec_flag_value'(unknown, fail) :- !. '$lgt_iso_spec_flag_value'(dialect, Value) :- atom(Value). '$lgt_iso_spec_flag_value'(version_data, Value) :- compound(Value). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % tables of ISO Prolog specified read and write term options % % (used for portability checking) % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % '$lgt_iso_spec_open_stream_option'(@nonvar) '$lgt_iso_spec_open_stream_option'(type(Type)) :- ( var(Type) -> true ; Type == text -> true ; Type == binary ). '$lgt_iso_spec_open_stream_option'(reposition(Boolean)) :- ( var(Boolean) -> true ; Boolean == true -> true ; Boolean == false ). '$lgt_iso_spec_open_stream_option'(alias(Alias)) :- ( var(Alias) -> true ; atom(Alias) ). '$lgt_iso_spec_open_stream_option'(eof_action(Action)) :- ( var(Action) -> true ; Action == error -> true ; Action == eof_code -> true ; Action == reset ). % '$lgt_iso_spec_read_term_option'(@nonvar) '$lgt_iso_spec_read_term_option'(variables(_)). '$lgt_iso_spec_read_term_option'(variable_names(_)). '$lgt_iso_spec_read_term_option'(singletons(_)). % '$lgt_iso_spec_write_term_option'(@nonvar) '$lgt_iso_spec_write_term_option'(quoted(Boolean)) :- ( var(Boolean) -> true ; Boolean == true -> true ; Boolean == false ). '$lgt_iso_spec_write_term_option'(ignore_ops(Boolean)) :- ( var(Boolean) -> true ; Boolean == true -> true ; Boolean == false ). '$lgt_iso_spec_write_term_option'(numbervars(Boolean)) :- ( var(Boolean) -> true ; Boolean == true -> true ; Boolean == false ). '$lgt_iso_spec_write_term_option'(variable_names(Pairs)) :- '$lgt_is_list'(Pairs), forall( '$lgt_member'(Pair, Pairs), (Pair = (Name = Variable), atom(Name), var(Variable)) ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % table of ISO Prolog specified built-in database predicates % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % '$lgt_iso_database_predicate'(@callble) '$lgt_iso_database_predicate'(abolish(_)). '$lgt_iso_database_predicate'(asserta(_)). '$lgt_iso_database_predicate'(assertz(_)). '$lgt_iso_database_predicate'(clause(_, _)). '$lgt_iso_database_predicate'(retract(_)). '$lgt_iso_database_predicate'(retractall(_)). '$lgt_iso_database_predicate'(current_predicate(_)). '$lgt_iso_database_predicate'(predicate_property(_, _)). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % table of Logtalk operators % % (used for portability checking) % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % '$lgt_logtalk_spec_operator'(?atom, ?atom, ?integer) % message-sending operators '$lgt_logtalk_spec_operator'((::), xfy, 600). '$lgt_logtalk_spec_operator'((::), fy, 600). % "super" call operator '$lgt_logtalk_spec_operator'((^^), fy, 600). % mode operators '$lgt_logtalk_spec_operator'((?), fy, 200). '$lgt_logtalk_spec_operator'((@), fy, 200). '$lgt_logtalk_spec_operator'((++), fy, 200). '$lgt_logtalk_spec_operator'((--), fy, 200). % alias operator '$lgt_logtalk_spec_operator'((as), xfx, 700). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % 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) :- catch(message_queue_create(_, [alias(ObjPrefix)]), _, true). % '$lgt_threaded_wait_synch_ctg'(+mutex_identifier, @term, @object_identifier) % % calls to the threaded_wait/1 predicate from synchronized category predicates '$lgt_threaded_wait_synch_ctg'(Mutex, Msg, This) :- '$lgt_current_object_'(This, Prefix, _, _, _, _, _, _, _, _, _), mutex_unlock(Mutex), '$lgt_threaded_wait'(Msg, Prefix), mutex_lock(Mutex). % '$lgt_threaded_wait_synch'(+mutex_identifier, @term, +entity_prefix) % % calls to the threaded_wait/1 predicate from synchronized object predicates '$lgt_threaded_wait_synch'(Mutex, Msg, Prefix) :- mutex_unlock(Mutex), '$lgt_threaded_wait'(Msg, Prefix), mutex_lock(Mutex). % '$lgt_threaded_wait_ctg'(@term, @object_identifier) '$lgt_threaded_wait_ctg'(Msg, This) :- '$lgt_current_object_'(This, Prefix, _, _, _, _, _, _, _, _, _), '$lgt_threaded_wait'(Msg, Prefix). % '$lgt_threaded_wait'(@term, +entity_prefix) '$lgt_threaded_wait'(Msg, Prefix) :- var(Msg), !, thread_get_message(Prefix, '$lgt_notification'(Msg)). '$lgt_threaded_wait'([], _) :- !. '$lgt_threaded_wait'([Msg| Msgs], Prefix) :- !, thread_get_message(Prefix, '$lgt_notification'(Msg)), '$lgt_threaded_wait'(Msgs, Prefix). '$lgt_threaded_wait'(Msg, Prefix) :- thread_get_message(Prefix, '$lgt_notification'(Msg)). % '$lgt_threaded_notify_ctg'(@term, @object_identifier) '$lgt_threaded_notify_ctg'(Msg, This) :- '$lgt_current_object_'(This, Prefix, _, _, _, _, _, _, _, _, _), '$lgt_threaded_notify'(Msg, Prefix). % '$lgt_threaded_notify'(@term, +entity_prefix) '$lgt_threaded_notify'(Msg, Prefix) :- var(Msg), !, thread_send_message(Prefix, '$lgt_notification'(Msg)). '$lgt_threaded_notify'([], _) :- !. '$lgt_threaded_notify'([Msg| Msgs], Prefix) :- !, thread_send_message(Prefix, '$lgt_notification'(Msg)), '$lgt_threaded_notify'(Msgs, Prefix). '$lgt_threaded_notify'(Msg, Prefix) :- thread_send_message(Prefix, '$lgt_notification'(Msg)). % '$lgt_threaded_ignore'(@term, @callable, @execution_context) % % the thread is only created if the original goal is callable; % this prevents programming errors going unnoticed '$lgt_threaded_ignore'(Goal, TGoal, ExCtx) :- '$lgt_check'(qualified_callable, Goal, logtalk(threaded_ignore(Goal), ExCtx)), thread_create(catch(TGoal, _, true), _, [detached(true)]). % '$lgt_threaded_call'(@term, @callable, @execution_context) % % the thread is only created if the original goal is callable; this prevents % programming errors going unnoticed until we try to retrieve the first answer '$lgt_threaded_call'(Goal, TGoal, ExCtx) :- '$lgt_check'(qualified_callable, Goal, logtalk(threaded_call(Goal), ExCtx)), '$lgt_execution_context'(ExCtx, _, _, This, Self, _, _), '$lgt_current_object_'(This, Queue, _, _, _, _, _, _, _, _, _), thread_create('$lgt_mt_non_det_goal'(Queue, Goal, TGoal, This, Self, []), Id, []), thread_send_message(Queue, '$lgt_thread_id'(call, Goal, This, Self, [], Id)). % '$lgt_threaded_once'(@term, @callable, @execution_context) % % the thread is only created if the original goal is callable; this prevents % programming errors going unnoticed until we try to retrieve the first answer '$lgt_threaded_once'(Goal, TGoal, ExCtx) :- '$lgt_check'(qualified_callable, Goal, logtalk(threaded_once(Goal), ExCtx)), '$lgt_execution_context'(ExCtx, _, _, This, Self, _, _), '$lgt_current_object_'(This, Queue, _, _, _, _, _, _, _, _, _), thread_create('$lgt_mt_det_goal'(Queue, Goal, TGoal, This, Self, []), Id, []), thread_send_message(Queue, '$lgt_thread_id'(once, Goal, This, Self, [], Id)). % '$lgt_threaded_call_tagged'(@term, @callable, @execution_context, -nonvar) % % the thread is only created if the original goal is callable and the tag is unbound; % this prevents programming errors going unnoticed until we try to retrieve the first answer '$lgt_threaded_call_tagged'(Goal, TGoal, ExCtx, Tag) :- '$lgt_check'(qualified_callable, Goal, logtalk(threaded_call(Goal, Tag), ExCtx)), '$lgt_check'(var, Tag, logtalk(threaded_call(Goal, Tag), ExCtx)), '$lgt_execution_context'(ExCtx, _, _, This, Self, _, _), '$lgt_current_object_'(This, Queue, _, _, _, _, _, _, _, _, _), '$lgt_new_threaded_tag'(Tag), thread_create('$lgt_mt_non_det_goal'(Queue, Goal, TGoal, This, Self, Tag), Id, []), thread_send_message(Queue, '$lgt_thread_id'(call, Goal, This, Self, Tag, Id)). % '$lgt_threaded_once_tagged'(@term, @callable, @execution_context, -nonvar) % % the thread is only created if the original goal is callable and the tag is unbound; % this programming errors going unnoticed until we try to retrieve the answer '$lgt_threaded_once_tagged'(Goal, TGoal, ExCtx, Tag) :- '$lgt_check'(qualified_callable, Goal, logtalk(threaded_once(Goal, Tag), ExCtx)), '$lgt_check'(var, Tag, logtalk(threaded_once(Goal, Tag), ExCtx)), '$lgt_execution_context'(ExCtx, _, _, This, Self, _, _), '$lgt_current_object_'(This, Queue, _, _, _, _, _, _, _, _, _), '$lgt_new_threaded_tag'(Tag), thread_create('$lgt_mt_det_goal'(Queue, Goal, TGoal, This, Self, Tag), Id, []), thread_send_message(Queue, '$lgt_thread_id'(once, Goal, This, Self, Tag, Id)). % '$lgt_mt_det_goal'(+message_queue_identifier, +callable, +callable, +object_identifier, +object_identifier, @nonvar) % % processes a deterministic message received by an object's message queue '$lgt_mt_det_goal'(Queue, Goal, TGoal, This, Self, Tag) :- thread_self(Id), ( catch(TGoal, Error, true) -> ( var(Error) -> thread_send_message(Queue, '$lgt_reply'(Goal, This, Self, Tag, success, Id)) ; thread_send_message(Queue, '$lgt_reply'(Goal, This, Self, Tag, Error, Id)) ) ; thread_send_message(Queue, '$lgt_reply'(Goal, This, Self, Tag, failure, Id)) ). % '$lgt_mt_non_det_goal'(+atom, +callable, +callable, +object_identifier, +object_identifier, @nonvar) % % processes a non-deterministic message received by an object's message queue '$lgt_mt_non_det_goal'(Queue, Goal, TGoal, This, Self, Tag) :- thread_self(Id), ( catch(TGoal, Error, true), ( var(Error) -> thread_send_message(Queue, '$lgt_reply'(Goal, This, Self, Tag, success, Id)), thread_get_message(Message), ( Message == '$lgt_next' -> % backtrack to the catch(Goal, ...) to try to find an alternative solution fail ; % otherwise assume Message = '$lgt_exit' and terminate thread true ) ; thread_send_message(Queue, '$lgt_reply'(Goal, This, Self, Tag, Error, Id)) ) ; % no (more) solutions thread_send_message(Queue, '$lgt_reply'(Goal, This, Self, Tag, failure, Id)) ). % '$lgt_threaded_peek'(+callable, @execution_context) '$lgt_threaded_peek'(Goal, ExCtx) :- '$lgt_check'(qualified_callable, Goal, logtalk(threaded_peek(Goal), ExCtx)), '$lgt_execution_context'(ExCtx, _, _, This, Self, _, _), '$lgt_current_object_'(This, Queue, _, _, _, _, _, _, _, _, _), ( % first check if there is a thread running for proving the goal before proceeding thread_peek_message(Queue, '$lgt_thread_id'(_, Goal, This, Self, [], Id)) -> % answering thread exists; go ahead and peek a solution thread_peek_message(Queue, '$lgt_reply'(Goal, This, Self, [], _, Id)) ; % answering thread don't exist; generate an exception throw(error(existence_error(thread, This), logtalk(threaded_peek(Goal), ExCtx))) ). % '$lgt_threaded_peek_tagged'(+callable, @execution_context, @nonvar) '$lgt_threaded_peek_tagged'(Goal, ExCtx, Tag) :- '$lgt_check'(qualified_callable, Goal, logtalk(threaded_peek(Goal, Tag), ExCtx)), '$lgt_check'(nonvar, Tag, logtalk(threaded_peek(Goal, Tag), ExCtx)), '$lgt_execution_context'(ExCtx, _, _, This, Self, _, _), '$lgt_current_object_'(This, Queue, _, _, _, _, _, _, _, _, _), ( % first check if there is a thread running for proving the goal before proceeding thread_peek_message(Queue, '$lgt_thread_id'(_, Goal, This, Self, Tag, Id)) -> % answering thread exists; go ahead and peek a solution thread_peek_message(Queue, '$lgt_reply'(Goal, This, Self, Tag, _, Id)) ; % answering thread don't exist; generate an exception throw(error(existence_error(thread, This), logtalk(threaded_peek(Goal, Tag), ExCtx))) ). % '$lgt_threaded_cancel_tagged'(@nonvar, @execution_context) '$lgt_threaded_cancel_tagged'(Tag, ExCtx) :- '$lgt_check'(nonvar, Tag, logtalk(threaded_cancel(Tag), ExCtx)), '$lgt_execution_context'(ExCtx, _, _, This, Self, _, _), '$lgt_current_object_'(This, Queue, _, _, _, _, _, _, _, _, _), ( thread_peek_message(Queue, '$lgt_thread_id'(_, _, This, Self, Tag, Id)) -> % answering thread exists; go ahead and cancel it thread_get_message(Queue, '$lgt_thread_id'(_, _, This, Self, Tag, Id)), % the thread may be suspended waiting for a request for an alternative proof; tell it to exit thread_send_message(Id, '$lgt_exit'), % but the thread may also be busy computing a solution; cancel it catch(thread_signal(Id, throw('$lgt_aborted')), _, true), thread_join(Id, _), % delete any thread reply that is pending retrievel forall( thread_peek_message(Queue, '$lgt_reply'(_, This, Self, Tag, _, Id)), thread_get_message(Queue, '$lgt_reply'(_, This, Self, Tag, _, Id)) ) ; % assume thread already canceled true ). % '$lgt_threaded_exit'(+callable, @execution_context) '$lgt_threaded_exit'(Goal, ExCtx) :- '$lgt_check'(qualified_callable, Goal, logtalk(threaded_exit(Goal), ExCtx)), '$lgt_execution_context'(ExCtx, _, _, This, Self, _, _), '$lgt_current_object_'(This, Queue, _, _, _, _, _, _, _, _, _), ( % 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, [], Id)) -> % answering thread exists; go ahead and retrieve the solution(s) thread_get_message(Queue, '$lgt_thread_id'(Type, Goal, This, Self, [], Id)), ( Type == (once) -> setup_call_cleanup( true, '$lgt_mt_det_reply'(Queue, Goal, This, Self, [], Id), thread_join(Id, _) ) ; setup_call_cleanup( true, '$lgt_mt_non_det_reply'(Queue, Goal, This, Self, [], Id), (( thread_property(Id, status(running)) -> % thread still running, suspended waiting for a request to an alternative proof; tell it to exit thread_send_message(Id, '$lgt_exit') ; true ), thread_join(Id, _)) ) ) ; % answering thread don't exist; generate an exception (failing is not an option as it could simply mean goal failure) throw(error(existence_error(thread, This), logtalk(threaded_exit(Goal), ExCtx))) ). % '$lgt_threaded_exit_tagged'(+callable, @execution_context, @nonvar) '$lgt_threaded_exit_tagged'(Goal, ExCtx, Tag) :- '$lgt_check'(qualified_callable, Goal, logtalk(threaded_exit(Goal, Tag), ExCtx)), '$lgt_check'(nonvar, Tag, logtalk(threaded_exit(Goal, Tag), ExCtx)), '$lgt_execution_context'(ExCtx, _, _, This, Self, _, _), '$lgt_current_object_'(This, Queue, _, _, _, _, _, _, _, _, _), ( % 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)), ( Type == (once) -> setup_call_cleanup( true, '$lgt_mt_det_reply'(Queue, Goal, This, Self, Tag, Id), thread_join(Id, _) ) ; setup_call_cleanup( true, '$lgt_mt_non_det_reply'(Queue, Goal, This, Self, Tag, Id), (( thread_property(Id, status(running)) -> % thread still running, suspended waiting for a request to an alternative proof; tell it to exit thread_send_message(Id, '$lgt_exit') ; true ), thread_join(Id, _)) ) ) ; % answering thread don't exist; generate an exception (failing is not an option as it could simply mean goal failure) throw(error(existence_error(thread, This), logtalk(threaded_exit(Goal, Tag), ExCtx))) ). % 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_threaded_engine_create'(@term, @term, @callable, +object_identifier, ?nonvar) % % the engine thread is only created if the original goal is callable; this prevents % programming errors going unnoticed until we try to retrieve the first answer '$lgt_threaded_engine_create'(AnswerTemplate, Goal, TGoal, ExCtx, Engine) :- '$lgt_check'(qualified_callable, Goal, logtalk(threaded_engine_create(AnswerTemplate, Goal, Engine), ExCtx)), with_mutex( '$lgt_engines', '$lgt_threaded_engine_create_protected'(AnswerTemplate, Goal, TGoal, ExCtx, Engine) ). '$lgt_threaded_engine_create_protected'(AnswerTemplate, Goal, TGoal, ExCtx, Engine) :- '$lgt_execution_context'(ExCtx, _, _, This, _, _, _), ( var(Engine) -> '$lgt_new_threaded_engine_tag'(Engine) ; '$lgt_current_engine_'(This, Engine, _, _) -> throw(error(permission_error(create, engine, Engine), logtalk(threaded_engine_create(AnswerTemplate, Goal, Engine), ExCtx))) ; true ), '$lgt_current_object_'(This, ThisQueue, _, _, _, _, _, _, _, _, _), message_queue_create(TermQueue), thread_create('$lgt_mt_engine_goal'(ThisQueue, TermQueue, AnswerTemplate, TGoal, Engine, Id), Id, []), assertz('$lgt_current_engine_'(This, Engine, TermQueue, Id)). % compute a solution for the engine goal and return it; note that the thread % always terminates with a status of "true" when an exception occurs or there % aren't any more solutions for the engine goal % % we use the object queue to store a '$lgt_engine_term_queue'/3 term with the % engine name and the engine term queue to workaround random timing issues when % accessing the '$lgt_current_engine_'/4 dynamic predicate that can result in % unexpected errors '$lgt_mt_engine_goal'(ThisQueue, TermQueue, Answer, Goal, Engine, Id) :- thread_send_message(ThisQueue, '$lgt_engine_term_queue'(Engine, TermQueue, Id)), ( setup_call_cleanup(true, catch(Goal, Error, true), Deterministic = true), ( var(Error) -> ( var(Deterministic) -> thread_send_message(ThisQueue, '$lgt_answer'(Engine, Id, Answer, success)), thread_get_message(Message), % if Message = '$lgt_next', backtrack to try to find an alternative solution Message == '$lgt_aborted' ; % no (more) solutions after this one thread_send_message(ThisQueue, '$lgt_answer'(Engine, Id, Answer, final)) ) ; Error == '$lgt_aborted' -> % we are destroying the engine true ; % engine goal error thread_send_message(ThisQueue, '$lgt_answer'(Engine, Id, _, error(Error))) ) ; % no (more) solutions thread_send_message(ThisQueue, '$lgt_answer'(Engine, Id, _, failure)) ). % '$lgt_current_engine'(@object_identifier, ?nonvar) % % we cannot compile threaded_engine/1 calls into '$lgt_current_engine_'/2 calls % as the last two arguments would cause problems with bagof/3 and setof/3 calls '$lgt_current_engine'(This, Engine) :- '$lgt_current_engine_'(This, Engine, _, _). % '$lgt_threaded_engine_next'(@nonvar, ?term, @execution_context) % % blocks until an answer (either an engine goal solution or a solution % posted by a call to threaded_engine_yield/1) becomes available '$lgt_threaded_engine_next'(Engine, Answer, ExCtx) :- ( var(Engine) -> throw(error(instantiation_error, logtalk(threaded_engine_next(Engine, Answer), ExCtx))) ; '$lgt_execution_context'(ExCtx, _, _, This, _, _, _), '$lgt_current_object_'(This, Queue, _, _, _, _, _, _, _, _, _), % first check if the engine is running '$lgt_current_engine_'(This, Engine, _, Id) -> % engine exists; go ahead and retrieve an answer '$lgt_mt_engine_reply'(Queue, Answer, Engine, Id, ExCtx) ; % engine does not exist throw(error(existence_error(engine, Engine), logtalk(threaded_engine_next(Engine, Answer), ExCtx))) ). % return current answer and start computing the next one % if the engine goal succeeded non-deterministically % % after all solutions are consumed, or in case of error, % ensure that the all next calls will fail '$lgt_mt_engine_reply'(Queue, Answer, Engine, Id, ExCtx) :- thread_get_message(Queue, '$lgt_answer'(Engine, Id, Reply, Result)), ( Result == success -> thread_send_message(Id, '$lgt_next'), Answer = Reply ; Result == final -> thread_send_message(Queue, '$lgt_answer'(Engine, Id, '$lgt_done'(final), failure)), Answer = Reply ; Result == failure -> thread_send_message(Queue, '$lgt_answer'(Engine, Id, '$lgt_done'(failure), failure)), fail ; Result = error(Error), thread_send_message(Queue, '$lgt_answer'(Engine, Id, '$lgt_done'(error), failure)), throw(error(Error, logtalk(threaded_engine_next(Engine,Answer),ExCtx))) ). % '$lgt_threaded_engine_next_reified'(@nonvar, ?term, @execution_context) % % blocks until an answer (either an engine goal solution or a solution % posted by a call to threaded_engine_yield/1) becomes available '$lgt_threaded_engine_next_reified'(Engine, Answer, ExCtx) :- ( var(Engine) -> throw(error(instantiation_error, logtalk(threaded_engine_next_reified(Engine, Answer), ExCtx))) ; '$lgt_execution_context'(ExCtx, _, _, This, _, _, _), '$lgt_current_object_'(This, Queue, _, _, _, _, _, _, _, _, _), % first check if the engine is running '$lgt_current_engine_'(This, Engine, _, Id) -> % engine exists; go ahead and retrieve an answer '$lgt_mt_engine_reply_reified'(Queue, Answer, Engine, Id) ; % engine does not exist throw(error(existence_error(engine, Engine), logtalk(threaded_engine_next_reified(Engine, Answer), ExCtx))) ). % return current answer and start computing the next one % if the engine goal succeeded non-deterministically % % after all solutions are consumed, or in case of error, % ensure that the all next calls will fail '$lgt_mt_engine_reply_reified'(Queue, Answer, Engine, Id) :- thread_get_message(Queue, '$lgt_answer'(Engine, Id, Reply, Result)), ( Result == success -> thread_send_message(Id, '$lgt_next'), Answer = the(Reply) ; Result == final -> thread_send_message(Queue, '$lgt_answer'(Engine, Id, '$lgt_done'(final), failure)), Answer = the(Reply) ; Result == failure -> thread_send_message(Queue, '$lgt_answer'(Engine, Id, '$lgt_done'(failure), failure)), Answer = no ; Result = error(Error), thread_send_message(Queue, '$lgt_answer'(Engine, Id, '$lgt_done'(error), failure)), Answer = exception(Error) ). % '$lgt_threaded_engine_self'(@object_identifier, ?nonvar) % % fails if not called from within an engine '$lgt_threaded_engine_self'(This, Engine) :- thread_self(Id), '$lgt_current_object_'(This, Queue, _, _, _, _, _, _, _, _, _), thread_peek_message(Queue, '$lgt_engine_term_queue'(Engine0, _, Id)), !, Engine = Engine0. % '$lgt_threaded_engine_yield'(@term, @object_identifier) % % fails if not called from within an engine; % blocks until the returned answer is consumed '$lgt_threaded_engine_yield'(Answer, This) :- thread_self(Id), '$lgt_current_object_'(This, Queue, _, _, _, _, _, _, _, _, _), thread_peek_message(Queue, '$lgt_engine_term_queue'(Engine, _, Id)), thread_send_message(Queue, '$lgt_answer'(Engine, Id, Answer, success)), thread_get_message(_). % '$lgt_threaded_engine_post'(@nonvar, @term, @execution_context) '$lgt_threaded_engine_post'(Engine, Term, ExCtx) :- '$lgt_execution_context'(ExCtx, _, _, This, _, _, _), ( var(Engine) -> throw(error(instantiation_error, logtalk(threaded_engine_post(Engine, Term), ExCtx))) ; % first check if the engine is running '$lgt_current_engine_'(This, Engine, TermQueue, _) -> % engine exists; go ahead and post the message in its mailbox thread_send_message(TermQueue, Term) ; % engine does not exist throw(error(existence_error(engine, Engine), logtalk(threaded_engine_post(Engine, Term), ExCtx))) ). % '$lgt_threaded_engine_fetch'(?term, @object_identifier) % % fails if not called from within an engine or if we are % destroying a running engine '$lgt_threaded_engine_fetch'(Term, This) :- thread_self(Id), '$lgt_current_object_'(This, Queue, _, _, _, _, _, _, _, _, _), ( % check if calling from within an engine thread_peek_message(Queue, '$lgt_engine_term_queue'(_, TermQueue, Id)) -> % engine exists; go ahead and retrieve a message from its mailbox thread_get_message(TermQueue, Term), Term \== '$lgt_aborted' ; % engine does not exist fail ). % '$lgt_threaded_engine_destroy'(@nonvar, @execution_context) % % when the engine thread is still running, we first put a throw/1 goal in the % thread signal queue and then send messages to both the thread queue and the % engine term queue to resume the engine goal if suspended waiting for either % a request for the next solution or a term to be processed '$lgt_threaded_engine_destroy'(Engine, ExCtx) :- with_mutex( '$lgt_engines', '$lgt_threaded_engine_destroy_protected'(Engine, ExCtx) ). '$lgt_threaded_engine_destroy_protected'(Engine, ExCtx) :- ( var(Engine) -> throw(error(instantiation_error, logtalk(threaded_engine_destroy(Engine), ExCtx))) ; '$lgt_execution_context'(ExCtx, _, _, This, _, _, _), '$lgt_current_object_'(This, Queue, _, _, _, _, _, _, _, _, _), retract('$lgt_current_engine_'(This, Engine, TermQueue, Id)) -> ( thread_property(Id, status(running)) -> % the engine thread may be suspended waiting for a client request to % compute the next solution; send it a '$lgt_aborted' term to prevent % further requests for backtracking into the next solution; note that % the engine thread and therefore its queue may no longer exist catch(thread_send_message(Id, '$lgt_aborted'), _, true), % send the '$lgt_aborted' term to the engine term queue to make any further % threaded_engine_fetch/1 calls fail; this queue is explicitly created and % destroyed and thus we can be sure it exists thread_send_message(TermQueue, '$lgt_aborted') ; true ), % ensure that thread is terminated catch(thread_signal(Id, throw('$lgt_aborted')), _, true), thread_join(Id, _), message_queue_destroy(TermQueue), % remove any non-consumed answer ( thread_peek_message(Queue, '$lgt_answer'(Engine, Id, _, _)) -> thread_get_message(Queue, '$lgt_answer'(Engine, Id, _, _)) ; true ), % remove the answer that ensures threaded_engine_next/2 and threaded_engine_next_reified/2 % return failures after consuming all solutions if present ( thread_peek_message(Queue, '$lgt_answer'(Engine, Id, _, failure)) -> thread_get_message(Queue, '$lgt_answer'(Engine, Id, _, failure)) ; true ), % remove the cache entry for the engine term queue handle ( thread_peek_message(Queue, '$lgt_engine_term_queue'(Engine, _, Id)) -> thread_get_message(Queue, '$lgt_engine_term_queue'(Engine, _, Id)) ; true ) ; % engine doesn't exist throw(error(existence_error(engine, Engine), logtalk(threaded_engine_destroy(Engine), ExCtx))) ). % '$lgt_threaded_and'(-var, +callable, +list) % % implements the threaded/1 built-in predicate when the argument is a conjunction % % each call uses a dedicated message queue that is destroyed after joining the % threads that are created to run the individual goals '$lgt_threaded_and'(Queue, MTGoals, Results) :- message_queue_create(Queue), call(MTGoals), '$lgt_mt_threaded_and_exit'(Queue, Results). % '$lgt_threaded_or'(-var, +callable, +list) % % implements the threaded/1 built-in predicate when the argument is a disjunction % % each call uses a dedicated message queue that is destroyed after joining the % threads that are created to run the individual goals '$lgt_threaded_or'(Queue, MTGoals, Results) :- message_queue_create(Queue), call(MTGoals), '$lgt_mt_threaded_or_exit'(Queue, Results). % '$lgt_threaded_goal'(+callable, -list(var), +message_queue_identifier, --thread_identifier) % % implements the call to an individual goal by the threaded/1 built-in predicate % % the at_exit/1 is used to ensure that the individual thread result is sent to % the dedicated message queue of the parent threaded/1 predicate call '$lgt_threaded_goal'(TGoal, TVars, Queue, Id) :- term_variables(TGoal, TVars), thread_create( '$lgt_mt_threaded_call'(TGoal, TVars, Queue, Id), Id, [at_exit('$lgt_mt_exit_handler'(Id, Queue))] ). % '$lgt_mt_threaded_call'(+callable, +list(var), +message_queue_identifier) % % proves an individual goal from a threaded/1 predicate call and sends the % result back to the message queue associated to the call; assuming that % the thread is not interrupted, its final status is set to "true"; if the % thread is interrupted before sending its result, its at_exit/1 option goal % ensures that a result is still sent to the parent threaded/1 predicate call % dedicated message queue '$lgt_mt_threaded_call'(TGoal, TVars, Queue, Id) :- ( call(TGoal) -> thread_send_message(Queue, '$lgt_result'(Id, true(TVars))) ; thread_send_message(Queue, '$lgt_result'(Id, false)) ). % '$lgt_mt_exit_handler'(@thread_identifier, +message_queue_identifier) % % exit handler for threaded/1 individual thread calls; an error generated % by the thread_send_message/2 call is interpreted as meaning that the % master/parent thread queue no longer exists leading to the detaching of % the worker thread '$lgt_mt_exit_handler'(Id, Queue) :- ( thread_property(Id, status(exception(Error))) -> catch(thread_send_message(Queue, '$lgt_result'(Id, exception(Error))), _, thread_detach(Id)) ; true ). % '$lgt_mt_threaded_and_exit'(+message_queue_identifier, +list) % % retrieves the result of proving a conjunction of goals using a threaded/1 predicate call % by collecting the individual thread results posted to the master thread message queue % until all individual goals succeeds or one them fails or throws an exception '$lgt_mt_threaded_and_exit'(Queue, Results) :- thread_get_message(Queue, '$lgt_result'(Id, Result)), '$lgt_mt_threaded_and_exit'(Result, Id, Queue, Results). '$lgt_mt_threaded_and_exit'(exception(Error), Id, Queue, Results) :- '$lgt_mt_threaded_and_record_result'(Results, Id, exception(Error)), '$lgt_mt_threaded_call_cancel'(Queue, Results), throw(Error). '$lgt_mt_threaded_and_exit'(true(TVars), Id, Queue, Results) :- ( '$lgt_mt_threaded_and_add_result'(Results, Id, TVars, Continue) -> ( Continue == false -> % all thread goals succeeded '$lgt_mt_threaded_call_join'(Results, Queue) ; % some thread goal results are still pending '$lgt_mt_threaded_and_exit'(Queue, Results) ) ; % adding a successful result can fail if the individual thread goals % are not independent (i.e., they share variables with the same or % partially the same role leading to unification failures) '$lgt_mt_threaded_and_exit'(false, Id, Queue, Results) ). '$lgt_mt_threaded_and_exit'(false, Id, Queue, Results) :- '$lgt_mt_threaded_and_record_result'(Results, Id, false), '$lgt_mt_threaded_call_cancel'(Queue, Results), fail. % '$lgt_mt_threaded_and_add_result'(+list, +thread_identifier, +list, -atom) % % adds the result of proving a goal and checks if all other goals have succeeded '$lgt_mt_threaded_and_add_result'([id(Id, TVars, true)| Results], Id, TVars, Continue) :- !, ( var(Continue) -> % we still don't know if there are any pending results '$lgt_mt_threaded_continue'(Results, Continue) ; true ). '$lgt_mt_threaded_and_add_result'([id(_, _, Done)| Results], Id, TVars, Continue) :- ( var(Done) -> % we found a thread whose result is still pending Continue = true ; % otherwise continue examining the remaining thread results true ), '$lgt_mt_threaded_and_add_result'(Results, Id, TVars, Continue). % '$lgt_mt_threaded_and_record_result'(+list, +thread_identifier, +callable) % % records a thread goal result '$lgt_mt_threaded_and_record_result'([id(Id, _, Result)| _], Id, Result) :- !. '$lgt_mt_threaded_and_record_result'([_| Results], Id, Result) :- '$lgt_mt_threaded_and_record_result'(Results, Id, Result). % '$lgt_mt_threaded_or_exit'(+list) % % retrieves the result of proving a disjunction of goals using a threaded/1 predicate % call by collecting the individual thread results posted to the call message queue % until one of the individual goals succeeds or all goals fail or throw an exception '$lgt_mt_threaded_or_exit'(Queue, Results) :- thread_get_message(Queue, '$lgt_result'(Id, Result)), '$lgt_mt_threaded_or_exit'(Result, Id, Queue, Results). '$lgt_mt_threaded_or_exit'(exception(Error), Id, Queue, Results) :- '$lgt_mt_threaded_or_record_exception'(Results, Id, exception(Error), Continue), ( Continue == true -> % some thread goal results are still pending '$lgt_mt_threaded_or_exit'(Queue, Results) ; % no thread goal succeeded and at least one thread resulted in an exception '$lgt_mt_threaded_call_join'(Results, Queue), throw(Error) ). '$lgt_mt_threaded_or_exit'(true(TVars), Id, Queue, Results) :- '$lgt_mt_threaded_or_exit_unify'(Results, Id, TVars), '$lgt_mt_threaded_call_cancel'(Queue, Results). '$lgt_mt_threaded_or_exit'(false, Id, Queue, Results) :- '$lgt_mt_threaded_or_record_failure'(Results, Id, Continue), ( Continue == true -> % some thread goal results are still pending '$lgt_mt_threaded_or_exit'(Queue, Results) ; % all goals terminated '$lgt_mt_threaded_call_join'(Results, Queue), ( '$lgt_member'(id(_, _, exception(Error)), Results) -> throw(Error) ; % all threads failed fail ) ). % unifies the successful thread goal result with the original call '$lgt_mt_threaded_or_exit_unify'([id(Id, TVars, true)| _], Id, TVars) :- !. '$lgt_mt_threaded_or_exit_unify'([_| Results], Id, TVars) :- '$lgt_mt_threaded_or_exit_unify'(Results, Id, TVars). % '$lgt_mt_threaded_or_record_exception'(+list, +thread_identifier, @nonvar, -atom) % % records a thread goal exception and checks if all other thread goals have % failed or thrown exceptions '$lgt_mt_threaded_or_record_exception'([id(Id, _, Result)| Results], Id, Exception, Continue) :- !, ( var(Result) -> Result = Exception ; % assume thread cancel exception; ignore it as the thread terminated % before receiving the signal with its result already recorded true ), ( var(Continue) -> % we still don't know if there are any pending results '$lgt_mt_threaded_continue'(Results, Continue) ; true ). '$lgt_mt_threaded_or_record_exception'([id(_, _, Done)| Results], Id, Exception, Continue) :- ( var(Done) -> % we found a thread whose result is still pending Continue = true ; % otherwise continue examining the remaining thread results true ), '$lgt_mt_threaded_or_record_exception'(Results, Id, Exception, Continue). % '$lgt_mt_threaded_or_record_failure'(+list, +thread_identifier, -atom) % % records a thread goal failure and checks if all other thread goals have failed '$lgt_mt_threaded_or_record_failure'([id(Id, _, false)| Results], Id, Continue) :- !, ( var(Continue) -> % we still don't know if there are any pending results '$lgt_mt_threaded_continue'(Results, Continue) ; true ). '$lgt_mt_threaded_or_record_failure'([id(_, _, Done)| Results], Id, Continue) :- ( var(Done) -> % we found a thread whose result is still pending Continue = true ; % otherwise continue examining the remaining thread results true ), '$lgt_mt_threaded_or_record_failure'(Results, Id, Continue). % '$lgt_mt_threaded_continue'(+list, -atom) % % checks if there are results still pending for a threaded/1 call '$lgt_mt_threaded_continue'([], false). '$lgt_mt_threaded_continue'([id(_, _, Done)| Results], Continue) :- ( var(Done) -> % we found a thread whose result is still pending Continue = true ; % otherwise continue looking for a thread with a still pending result '$lgt_mt_threaded_continue'(Results, Continue) ). % '$lgt_mt_threaded_call_cancel'(+message_queue_identifier, +list) % % aborts a threaded call by aborting and joining all individual threads; % we must use catch/3 as some threads may already be terminated '$lgt_mt_threaded_call_cancel'(Queue, Results) :- '$lgt_mt_threaded_call_abort'(Results, Queue), '$lgt_mt_threaded_call_join'(Results, Queue). % '$lgt_mt_threaded_call_abort'(+list) % % signals individual threads to abort if their result is not yet registered; % we must use catch/3 as some threads may no longer exist '$lgt_mt_threaded_call_abort'([], _). '$lgt_mt_threaded_call_abort'([id(Id, _, Result)| Ids], Queue) :- ( var(Result) -> catch(thread_signal(Id, throw('$lgt_aborted')), _, true) ; true ), '$lgt_mt_threaded_call_abort'(Ids, Queue). % '$lgt_mt_threaded_call_join'(+list, +message_queue_identifier) % % joins all individual threads; we must use catch/3 as some threads may no longer exist '$lgt_mt_threaded_call_join'([], Queue) :- message_queue_destroy(Queue). '$lgt_mt_threaded_call_join'([id(Id, _, _)| Results], Queue) :- catch(thread_join(Id, _), _, true), '$lgt_mt_threaded_call_join'(Results, Queue). % '$lgt_new_threaded_tag'(-integer) % % generates a new multi-threading tag; used in the built-in asynchronous % multi-threading predicates '$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)) ) ). % '$lgt_new_threaded_engine_tag'(-integer) % % generates a new threading engine tag (already protected by the '$lgt_engines' mutex) '$lgt_new_threaded_engine_tag'(New) :- retract('$lgt_threaded_engine_tag_counter_'(Old)), !, New is Old + 1, asserta('$lgt_threaded_engine_tag_counter_'(New)). % '$lgt_create_mutexes'(+list(mutex_identifier)) % % creates entity mutexes (called when loading an entity); we may % be reloading an entity and the mutex may be already created '$lgt_create_mutexes'([]). '$lgt_create_mutexes'([Mutex| Mutexes]) :- ( mutex_property(_, alias(Mutex)) -> true ; mutex_create(_, [alias(Mutex)]) ), '$lgt_create_mutexes'(Mutexes). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % static binding supporting predicates % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % '$lgt_send_to_obj_static_binding'(@object_identifier, @callable, @object_identifier, -callable) % % static binding is only used for the (::)/2 control construct when the object receiving the % message is static and the support for complementing categories is disallowed (unfortunately, % allowing hot patching of an object would easily lead to inconsistencies as there isn't any % portable solution for updating in-place the definition of patched object predicates that % were already directly called due to the previous use of static binding) '$lgt_send_to_obj_static_binding'(Obj, Pred, Call, Ctx) :- '$lgt_comp_ctx'(Ctx, _, _, _, _, This, _, _, _, _, CallerExCtx, _, _, _, _), ( '$lgt_send_to_obj_static_binding_'(Obj, Pred, CallerExCtx, Call) -> true ; '$lgt_current_object_'(Obj, _, Dcl, Def, _, _, _, _, _, _, ObjFlags), ObjFlags /\ 512 =\= 512, % object is not compiled in debug mode ObjFlags /\ 2 =:= 0, % object is static ObjFlags /\ 64 =\= 64, % complementing categories flag not set to "allow" '$lgt_term_template'(Pred, GPred), call(Dcl, GPred, p(p(p)), Meta, PredFlags, _, DclCtn), !, % get the execution context for meta-calls '$lgt_goal_meta_call_context'(Meta, GCallerExCtx, GThis, GMetaCallCtx), '$lgt_term_template'(Obj, GObj), '$lgt_execution_context'(GExCtx, _, GThis, GObj, GObj, GMetaCallCtx, []), call(Def, GPred, GExCtx, GCall, _, DefCtn), !, ( PredFlags /\ 2 =:= 0 -> % Type == static true ; % Type == (dynamic) GObj = DclCtn -> % local declaration true ; GObj = DefCtn % local definition ), ( GObj \= DefCtn -> % inherited definition; complementing categories % flag must also not be set to "restrict" ObjFlags /\ 32 =\= 32 ; % local definition true ), % predicate definition found; use it only if it's safe '$lgt_static_binding_safe_paths'(GObj, DclCtn, DefCtn), ( Meta == no -> % cache only normal predicates assertz('$lgt_send_to_obj_static_binding_'(GObj, GPred, GCallerExCtx, GCall)), Obj = GObj, Pred = GPred, This = GThis, CallerExCtx = GCallerExCtx, Call = GCall ; % meta-predicates cannot be cached as they require translation of % the meta-arguments, which must succeed to allow static binding % (don't require the predicate and the meta-predicate template to % share the name as we may be using a predicate alias) Meta =.. [_| MArgs], Pred =.. [PredFunctor| Args], '$lgt_compile_static_binding_meta_arguments'(Args, MArgs, _, Ctx, TArgs), TPred =.. [PredFunctor| TArgs], Obj = GObj, TPred = GPred, This = GThis, CallerExCtx = GCallerExCtx, Call = GCall ) ). '$lgt_compile_static_binding_meta_arguments'([], [], _, _, []). '$lgt_compile_static_binding_meta_arguments'([Arg| Args], [MArg| MArgs], Caller, Ctx, [TArg| TArgs]) :- '$lgt_compile_static_binding_meta_argument'(MArg, Arg, Caller, Ctx, TArg), '$lgt_compile_static_binding_meta_arguments'(Args, MArgs, Caller, Ctx, TArgs). '$lgt_compile_static_binding_meta_argument'((*), Arg, _, _, Arg) :- !. '$lgt_compile_static_binding_meta_argument'(N, Closure, _, Ctx, {UserClosure}) :- integer(N), % goal or closure nonvar(Closure), ( Closure = Obj::UserClosure, Obj == user ; Closure = {UserClosure} ; '$lgt_comp_ctx_entity'(Ctx, Entity), Entity == user, \+ '$lgt_control_construct'(Closure), UserClosure = Closure ), % goal or closure called in "user" !, '$lgt_check'(var_or_callable, UserClosure). '$lgt_compile_static_binding_meta_argument'(N, Closure, _, Ctx, TClosure) :- integer(N), N > 0, % closure !, '$lgt_check'(var_or_callable, Closure), '$lgt_length'(ExtArgs, 0, N), '$lgt_extend_closure'(Closure, ExtArgs, Goal, Ctx), % compiling the meta-argument allows predicate cross-referencing information % to be collected even if the compilation result cannot be used '$lgt_compile_body'(Goal, meta, TGoal, _, Ctx), functor(TGoal, TFunctor, _), ( Goal == TGoal -> \+ '$lgt_control_construct'(TGoal), % either a built-in predicate or a predicate called in "user" TClosure = {Closure} ; sub_atom(TFunctor, 0, 5, _, '$lgt_') -> % in some backend Prolog systems, internal Logtalk compiler/runtime % predicates may be marked as built-in predicates fail ; '$lgt_built_in_predicate'(TGoal) -> \+ '$lgt_control_construct'(TGoal), % built-in predicates may result from goal-expansion during % compilation or from inlining of user predicate definitions '$lgt_built_in_goal_to_closure'(N, TGoal, TFunctor, TArgs), TClosure0 =.. [TFunctor| TArgs], TClosure = {TClosure0} ; '$lgt_user_goal_to_closure'(N, TGoal, TFunctor, TArgs, ExCtx) -> TClosure = '$lgt_closure'(TFunctor, TArgs, ExCtx) ; % runtime resolved meta-call fail ). '$lgt_compile_static_binding_meta_argument'(0, Goal, _, Ctx, {TGoal}) :- % the {}/1 construct signals a pre-compiled metacall '$lgt_compile_body'(Goal, meta, TGoal, _, Ctx). '$lgt_built_in_goal_to_closure'(N, TGoal, TFunctor, TArgs) :- functor(TGoal, TFunctor, TArity), TGoal =.. [TFunctor| TAllArgs], % subtract the number of extra arguments Arity is TArity - N, Arity >= 0, % unify the compiled closure arguments from the compiled goal arguments '$lgt_length'(TArgs, 0, Arity), '$lgt_append'(TArgs, _, TAllArgs), !. '$lgt_user_goal_to_closure'(N, TGoal, TFunctor, TArgs, ExCtx) :- functor(TGoal, TFunctor, TArity), TGoal =.. [TFunctor| TAllArgs], % subtract the number of extra arguments and the execution context argument Arity is TArity - N - 1, Arity >= 0, % unify the compiled closure arguments from the compiled goal arguments '$lgt_length'(TArgs, 0, Arity), '$lgt_append'(TArgs, _, TAllArgs), % unify the execution context argument using the compiled goal arg(TArity, TGoal, ExCtx), !. % '$lgt_obj_super_call_static_binding'(@object_identifier, @callable, @execution_context, -callable) % % static binding for the (^^)/1 control construct (used within objects) '$lgt_obj_super_call_static_binding'(Obj, Pred, ExCtx, Call) :- ( '$lgt_pp_imported_category_'(_, _, _, _, _, _), '$lgt_obj_super_call_static_binding_category'(Obj, Pred, ExCtx, Call) -> true ; '$lgt_pp_extended_object_'(_, _, _, _, _, _, _, _, _, _, _) -> '$lgt_obj_super_call_static_binding_prototype'(Obj, Pred, ExCtx, Call) ; '$lgt_pp_instantiated_class_'(_, _, _, _, _, _, _, _, _, _, _), '$lgt_pp_specialized_class_'(_, _, _, _, _, _, _, _, _, _, _) -> '$lgt_obj_super_call_static_binding_instance_class'(Obj, Pred, ExCtx, Call) ; '$lgt_pp_instantiated_class_'(_, _, _, _, _, _, _, _, _, _, _) -> '$lgt_obj_super_call_static_binding_instance'(Obj, Pred, ExCtx, Call) ; '$lgt_pp_specialized_class_'(_, _, _, _, _, _, _, _, _, _, _) -> '$lgt_obj_super_call_static_binding_class'(Obj, Pred, ExCtx, Call) ; fail ). '$lgt_obj_super_call_static_binding_category'(Obj, Alias, OExCtx, Call) :- % when working with parametric entities, we must connect the parameters % between related entities '$lgt_pp_runtime_clause_'('$lgt_imports_category_'(Obj, Ctg, _)), '$lgt_current_category_'(Ctg, _, Dcl, Def, _, _), % we may be aliasing the predicate ( '$lgt_pp_predicate_alias_'(Ctg, Pred, Alias, _, _, _) -> true ; Pred = Alias ), % lookup predicate declaration call(Dcl, Pred, _, _, Flags, DclCtn), !, % the predicate must be static Flags /\ 2 =:= 0, % unify execution context arguments '$lgt_execution_context_update_this_entity'(OExCtx, Obj, Obj, CExCtx, Obj, Ctg), % lookup predicate definition call(Def, Pred, CExCtx, Call, DefCtn), !, % predicate definition found; use it only if it's safe '$lgt_static_binding_safe_paths'(Obj, DclCtn, DefCtn). '$lgt_obj_super_call_static_binding_prototype'(Obj, Alias, OExCtx, Call) :- % when working with parametric entities, we must connect the parameters % between related entities '$lgt_pp_runtime_clause_'('$lgt_extends_object_'(Obj, Parent, RelationScope)), '$lgt_current_object_'(Parent, _, Dcl, Def, _, _, _, _, _, _, _), % we may be aliasing the predicate ( '$lgt_pp_predicate_alias_'(Parent, Pred, Alias, _, _, _) -> true ; Pred = Alias ), % lookup predicate declaration ( RelationScope == (public) -> call(Dcl, Pred, Scope, _, Flags, SCtn, TCtn) ; RelationScope == protected -> call(Dcl, Pred, PredScope, _, Flags, SCtn, TCtn), '$lgt_filter_scope'(PredScope, Scope) ; Scope = p, call(Dcl, Pred, PredScope, _, Flags, SCtn0, TCtn), '$lgt_filter_scope_container'(PredScope, SCtn0, Obj, SCtn) ), !, % check that the call is within scope (i.e., public or protected) ( Scope = p(_) -> true ; Obj = SCtn ), % the predicate must be static Flags /\ 2 =:= 0, % unify execution context arguments '$lgt_execution_context_update_this_entity'(OExCtx, Obj, Obj, PExCtx, Parent, Parent), % lookup predicate definition call(Def, Pred, PExCtx, Call, _, DefCtn), !, % predicate definition found; use it only if it's safe '$lgt_static_binding_safe_paths'(Obj, TCtn, DefCtn). '$lgt_obj_super_call_static_binding_instance'(Obj, Alias, OExCtx, Call) :- % when working with parametric entities, we must connect the parameters % between related entities '$lgt_pp_runtime_clause_'('$lgt_instantiates_class_'(Obj, Class, RelationScope)), '$lgt_current_object_'(Class, _, _, _, _, IDcl, IDef, _, _, _, _), % we may be aliasing the predicate ( '$lgt_pp_predicate_alias_'(Class, Pred, Alias, _, _, _) -> true ; Pred = Alias ), % lookup predicate declaration ( RelationScope == (public) -> call(IDcl, Pred, Scope, _, Flags, SCtn, TCtn) ; RelationScope == protected -> call(IDcl, Pred, PredScope, _, Flags, SCtn, TCtn), '$lgt_filter_scope'(PredScope, Scope) ; Scope = p, call(IDcl, Pred, PredScope, _, Flags, SCtn0, TCtn), '$lgt_filter_scope_container'(PredScope, SCtn0, Obj, SCtn) ), !, % check that the call is within scope (i.e., public or protected) ( Scope = p(_) -> true ; Obj = SCtn ), % the predicate must be static Flags /\ 2 =:= 0, % unify execution context arguments '$lgt_execution_context_update_this_entity'(OExCtx, Obj, Obj, CExCtx, Class, Class), % lookup predicate definition call(IDef, Pred, CExCtx, Call, _, DefCtn), !, % predicate definition found; use it only if it's safe '$lgt_static_binding_safe_paths'(Obj, TCtn, DefCtn). '$lgt_obj_super_call_static_binding_class'(Obj, Alias, OExCtx, Call) :- % when working with parametric entities, we must connect the parameters % between related entities '$lgt_pp_runtime_clause_'('$lgt_specializes_class_'(Obj, Superclass, RelationScope)), '$lgt_current_object_'(Superclass, _, _, _, _, IDcl, IDef, _, _, _, _), % we may be aliasing the predicate ( '$lgt_pp_predicate_alias_'(Superclass, Pred, Alias, _, _, _) -> true ; Pred = Alias ), % lookup predicate declaration ( RelationScope == (public) -> call(IDcl, Pred, Scope, _, Flags, SCtn, TCtn) ; RelationScope == protected -> call(IDcl, Pred, PredScope, _, Flags, SCtn, TCtn), '$lgt_filter_scope'(PredScope, Scope) ; Scope = p, call(IDcl, Pred, PredScope, _, Flags, SCtn0, TCtn), '$lgt_filter_scope_container'(PredScope, SCtn0, Obj, SCtn) ), !, % check that the call is within scope (i.e., public or protected) ( Scope = p(_) -> true ; Obj = SCtn ), % the predicate must be static Flags /\ 2 =:= 0, % unify execution context arguments '$lgt_execution_context_update_this_entity'(OExCtx, Obj, Obj, SExCtx, Superclass, Superclass), % lookup predicate definition call(IDef, Pred, SExCtx, Call, _, DefCtn), !, % predicate definition found; use it only if it's safe '$lgt_static_binding_safe_paths'(Obj, TCtn, DefCtn). '$lgt_obj_super_call_static_binding_instance_class'(Obj, Pred, ExCtx, Call) :- ( '$lgt_obj_super_call_static_binding_instance'(Obj, Pred, ExCtx, ICall), '$lgt_obj_super_call_static_binding_class'(Obj, Pred, ExCtx, CCall) -> ( ICall == CCall -> Call = ICall ; '$lgt_execution_context'(ExCtx, _, _, _, Self, _, _), Call = (Obj = Self -> ICall; CCall) ) ; '$lgt_obj_super_call_static_binding_instance'(Obj, Pred, ExCtx, Call) -> true ; '$lgt_obj_super_call_static_binding_class'(Obj, Pred, ExCtx, Call) ). % '$lgt_ctg_super_call_static_binding'(@category_identifier, @callable, @execution_context, -callable) % % static binding for the (^^)/1 control construct (used within categories) '$lgt_ctg_super_call_static_binding'(Ctg, Alias, CExCtx, Call) :- % when working with parametric entities, we must connect the parameters % between related entities '$lgt_pp_runtime_clause_'('$lgt_extends_category_'(Ctg, ExtCtg, RelationScope)), '$lgt_current_category_'(ExtCtg, _, Dcl, Def, _, _), % we may be aliasing the predicate ( '$lgt_pp_predicate_alias_'(ExtCtg, Pred, Alias, _, _, _) -> true ; Pred = Alias ), % lookup predicate declaration ( RelationScope == (public) -> call(Dcl, Pred, Scope, _, Flags, DclCtn) ; RelationScope == protected, call(Dcl, Pred, Scope0, _, Flags, DclCtn), '$lgt_filter_scope'(Scope0, Scope) ), !, % check that the call is within scope Scope = p(_), % the predicate must be static Flags /\ 2 =:= 0, % unify execution context arguments '$lgt_execution_context_update_this_entity'(CExCtx, This, Ctg, EExCtx, This, ExtCtg), % lookup predicate definition call(Def, Pred, EExCtx, Call, DefCtn), !, % predicate definition found; use it only if it's safe '$lgt_static_binding_safe_paths'(Ctg, DclCtn, DefCtn). % '$lgt_send_to_obj_db_msg_static_binding'(@category_identifier, @callable, -callable) % % static binding for selected database messages sent to an object '$lgt_send_to_obj_db_msg_static_binding'(Obj, Head, THead) :- '$lgt_current_object_'(Obj, _, Dcl, Def, _, _, _, _, _, _, ObjFlags), % check that the object is not compiled in debug mode ObjFlags /\ 512 =\= 512, % check that the object is static ObjFlags /\ 2 =:= 0, call(Dcl, Head, Scope, _, PredFlags, SCtn, DCtn), !, % check that the call is within scope Scope = p(p(_)), % check that the predicate is dynamic PredFlags /\ 2 =:= 2, % check that we're acting on the same entity that declares the predicate dynamic SCtn = Obj, % lookup local predicate definition call(Def, Head, _, THead), !, % predicate definition found; use it only if it's safe '$lgt_static_binding_entity'(DCtn). % '$lgt_static_binding_safe_paths'(@entity_identifier, @entity_identifier, @entity_identifier) % % all ancestor entities up to the starting point for both the declaration % container and the definition container must be static-binding entities '$lgt_static_binding_safe_paths'(Entity, DclEntity, DefEntity) :- ( DclEntity \= Entity -> '$lgt_static_binding_entity'(DclEntity) ; true ), ( DefEntity \= Entity -> '$lgt_static_binding_entity'(DefEntity) ; true ), '$lgt_static_binding_safe_declaration_ancestors'(Entity, DclEntity), '$lgt_static_binding_safe_definition_ancestors'(Entity, DefEntity). '$lgt_static_binding_entity'(Entity) :- ( '$lgt_current_object_'(Entity, _, _, _, _, _, _, _, _, _, Flags) -> Flags /\ 64 =\= 64, Flags /\ 32 =\= 32 % support for complementing categories is disabled ; '$lgt_current_protocol_'(Entity, _, _, _, Flags) -> true ; '$lgt_current_category_'(Entity, _, _, _, _, Flags) ), Flags /\ 512 =\= 512, % entity is not compiled in debug mode Flags /\ 2 =:= 0. % entity is static '$lgt_static_binding_entity'(object, Object) :- '$lgt_current_object_'(Object, _, _, _, _, _, _, _, _, _, Flags), Flags /\ 512 =\= 512, % object is not compiled in debug mode Flags /\ 2 =:= 0, % object is static Flags /\ 64 =\= 64, Flags /\ 32 =\= 32. % support for complementing categories is disallowed '$lgt_static_binding_entity'(protocol, Protocol) :- '$lgt_current_protocol_'(Protocol, _, _, _, Flags), Flags /\ 512 =\= 512, % protocol is not compiled in debug mode Flags /\ 2 =:= 0. % protocol is static '$lgt_static_binding_entity'(category, Category) :- '$lgt_current_category_'(Category, _, _, _, _, Flags), Flags /\ 512 =\= 512, % category is not compiled in debug mode Flags /\ 2 =:= 0. % category is static '$lgt_static_binding_safe_declaration_ancestors'(Entity, DclEntity) :- ( Entity = DclEntity -> % local predicate declaration true ; % we add a third argument to properly handle class hierarchies if necessary '$lgt_static_binding_safe_declaration_ancestors'(Entity, DclEntity, _) -> % ensure no spurious choice-points true ; fail ). '$lgt_static_binding_safe_declaration_ancestors'(Entity, DclEntity, Kind) :- '$lgt_entity_ancestor'(Entity, Type, Ancestor, Kind, NextKind), ( '$lgt_static_binding_entity'(Type, Ancestor) -> ( Ancestor = DclEntity -> true ; % move up, implementing the same depth-first strategy used by the predicate % declaration lookup algorithm '$lgt_static_binding_safe_declaration_ancestors'(Ancestor, DclEntity, NextKind) ) ; % ancestor can be later modified, rendering the static binding optimization invalid !, fail ). '$lgt_static_binding_safe_definition_ancestors'(Entity, DefEntity) :- ( Entity = DefEntity -> % local predicate definition true ; % we add a third argument to properly handle class hierarchies if necessary '$lgt_static_binding_safe_definition_ancestors'(Entity, DefEntity, _) -> % ensure no spurious choice-points true ; fail ). '$lgt_static_binding_safe_definition_ancestors'(Entity, DefEntity, Kind) :- '$lgt_entity_ancestor'(Entity, Type, Ancestor, Kind, NextKind), % protocols cannot contain predicate definitions Type \== protocol, ( '$lgt_static_binding_entity'(Type, Ancestor) -> ( Ancestor = DefEntity -> true ; % move up, implementing the same depth-first strategy used by the predicate % definition lookup algorithm '$lgt_static_binding_safe_definition_ancestors'(Ancestor, DefEntity, NextKind) ) ; % ancestor can be later modified, rendering the static binding optimization invalid !, fail ). % entity ancestors are generated on backtracking in the same order % used by the predicate declaration and definition lookup algorithms '$lgt_entity_ancestor'(Entity, protocol, Protocol, Kind, Kind) :- '$lgt_implements_protocol_'(Entity, Protocol, _). '$lgt_entity_ancestor'(Entity, protocol, Protocol, Kind, Kind) :- '$lgt_pp_runtime_clause_'('$lgt_implements_protocol_'(Entity, Protocol, _)). '$lgt_entity_ancestor'(Entity, protocol, Protocol, protocol, protocol) :- '$lgt_extends_protocol_'(Entity, Protocol, _). '$lgt_entity_ancestor'(Entity, protocol, Protocol, protocol, protocol) :- '$lgt_pp_runtime_clause_'('$lgt_extends_protocol_'(Entity, Protocol, _)). '$lgt_entity_ancestor'(Entity, category, Category, category, category) :- '$lgt_extends_category_'(Entity, Category, _). '$lgt_entity_ancestor'(Entity, category, Category, category, category) :- '$lgt_pp_runtime_clause_'('$lgt_extends_category_'(Entity, Category, _)). '$lgt_entity_ancestor'(Entity, category, Category, Kind, Kind) :- '$lgt_imports_category_'(Entity, Category, _). '$lgt_entity_ancestor'(Entity, category, Category, Kind, Kind) :- '$lgt_pp_runtime_clause_'('$lgt_imports_category_'(Entity, Category, _)). '$lgt_entity_ancestor'(Entity, object, Parent, prototype, prototype) :- '$lgt_extends_object_'(Entity, Parent, _). '$lgt_entity_ancestor'(Entity, object, Parent, prototype, prototype) :- '$lgt_pp_runtime_clause_'('$lgt_extends_object_'(Entity, Parent, _)). '$lgt_entity_ancestor'(Entity, object, Class, instance, superclass) :- '$lgt_instantiates_class_'(Entity, Class, _). '$lgt_entity_ancestor'(Entity, object, Class, instance, superclass) :- '$lgt_pp_runtime_clause_'('$lgt_instantiates_class_'(Entity, Class, _)). '$lgt_entity_ancestor'(Entity, object, Superclass, superclass, superclass) :- '$lgt_specializes_class_'(Entity, Superclass, _). '$lgt_entity_ancestor'(Entity, object, Superclass, superclass, superclass) :- '$lgt_pp_runtime_clause_'('$lgt_specializes_class_'(Entity, Superclass, _)). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % utility predicates % % although usually provided as either built-in or library predicates by the % backends, it's simpler and more portable to define our own versions % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % '$lgt_length'(+list, +integer, -integer) % '$lgt_length'(-list, +integer, +integer) '$lgt_length'([], Length, Length) :- !. '$lgt_length'([_| Tail], Length0, Length) :- Length1 is Length0 + 1, '$lgt_length'(Tail, Length1, Length). '$lgt_append'([], List, List). '$lgt_append'([Head| Tail], List, [Head| Tail2]) :- '$lgt_append'(Tail, List, Tail2). '$lgt_member'(Head, [Head| _]). '$lgt_member'(Head, [_| Tail]) :- '$lgt_member'(Head, Tail). '$lgt_member_var'(V, [H| _]) :- V == H. '$lgt_member_var'(V, [_| T]) :- nonvar(T), '$lgt_member_var'(V, T). '$lgt_memberchk_var'(Element, [Head| Tail]) :- ( Element == Head -> true ; '$lgt_memberchk_var'(Element, Tail) ). '$lgt_sub_term_var'(SubTerm, Term) :- SubTerm == Term, !. '$lgt_sub_term_var'(SubTerm, Term) :- compound(Term), functor(Term, _, Arity), '$lgt_between'(1, Arity, N), arg(N, Term, Argument), '$lgt_sub_term_var'(SubTerm, Argument), !. '$lgt_anonymous_or_singleton_variable'(Variable, VariableNames, Singletons) :- ( '$lgt_member'(Name0=Variable0, Singletons), Variable0 == Variable, \+ '$lgt_parameter_variable_name'(Name0) -> true ; \+ ( '$lgt_member'(_=Variable0, VariableNames), Variable0 == Variable ) ). '$lgt_anonymous_or_singleton_variables'([], _, _). '$lgt_anonymous_or_singleton_variables'([Variable| Variables], VariableNames, Singletons) :- '$lgt_anonymous_or_singleton_variable'(Variable, VariableNames, Singletons), '$lgt_anonymous_or_singleton_variables'(Variables, VariableNames, Singletons). % find position-relevant argument pairs for =../2 lint checks where a relevant % argument is either a bound argument or a named variable argument; the last % argument returns the type of list (open or closed) '$lgt_position_relevant_argument_pairs'([], _, _, [], closed, []). '$lgt_position_relevant_argument_pairs'([Argument| Arguments], N, VariableNames, [N-Argument| Pairs], Type, Tail) :- once(( nonvar(Argument) ; '$lgt_member'(_=Argument0, VariableNames), Argument0 == Argument )), !, ( var(Arguments) -> % open list Pairs = [], Type = open, Tail = Arguments ; M is N + 1, '$lgt_position_relevant_argument_pairs'(Arguments, M, VariableNames, Pairs, Type, Tail) ). '$lgt_position_relevant_argument_pairs'([_| Arguments], N, VariableNames, Pairs, Type, Tail) :- ( var(Arguments) -> % open list Pairs = [], Type = open, Tail = Arguments ; M is N + 1, '$lgt_position_relevant_argument_pairs'(Arguments, M, VariableNames, Pairs, Type, Tail) ). '$lgt_between'(Lower, Upper, N) :- Lower =< Upper, '$lgt_between_aux'(Lower, Upper, N). '$lgt_between_aux'(Lower, _, Lower). '$lgt_between_aux'(Lower, Upper, N) :- Lower < Upper, Next is Lower + 1, '$lgt_between_aux'(Next, Upper, N). '$lgt_is_list_or_partial_list'(Var) :- var(Var), !. '$lgt_is_list_or_partial_list'([]). '$lgt_is_list_or_partial_list'([_| Tail]) :- '$lgt_is_list_or_partial_list'(Tail). '$lgt_is_list'((-)) :- !, fail. '$lgt_is_list'([]). '$lgt_is_list'([_| Tail]) :- '$lgt_is_list'(Tail). '$lgt_is_boolean'((-)) :- !, fail. '$lgt_is_boolean'(true). '$lgt_is_boolean'(false). '$lgt_intersection'(_, [], []) :- !. '$lgt_intersection'([], _, []) :- !. '$lgt_intersection'([Head1| Tail1], List2, Intersection) :- ( '$lgt_memberchk_var'(Head1, List2) -> Intersection = [Head1| IntersectionRest], '$lgt_intersection'(Tail1, List2, IntersectionRest) ; '$lgt_intersection'(Tail1, List2, Intersection) ). '$lgt_var_subtract'([], _, []). '$lgt_var_subtract'([Head| Tail], List, Rest) :- ( '$lgt_memberchk_var'(Head, List) -> '$lgt_var_subtract'(Tail, List, Rest) ; Rest = [Head| Tail2], '$lgt_var_subtract'(Tail, List, Tail2) ). '$lgt_sum_list'(List, Sum) :- '$lgt_sum_list'(List, 0, Sum). '$lgt_sum_list'([], Sum, Sum). '$lgt_sum_list'([Value| Values], Sum0, Sum) :- Sum1 is Sum0 + Value, '$lgt_sum_list'(Values, Sum1, Sum). '$lgt_select'(Head, [Head| Tail], Tail). '$lgt_select'(Head, [Head2| Tail], [Head2| Tail2]) :- '$lgt_select'(Head, Tail, Tail2). % definition taken from the SWI-Prolog documentation '$lgt_variant'(Term1, Term2) :- % avoid trouble in any shared variables copy_term(Term1, Term1Copy), copy_term(Term2, Term2Copy), % ground and compare the term copies numbervars(Term1Copy, 0, N), numbervars(Term2Copy, 0, N), Term1Copy == Term2Copy. % variable aliasing occurs in a head of a clause % when two or more arguments share variables '$lgt_variable_aliasing'(Head) :- compound(Head), Head =.. [_| Arguments], '$lgt_select'(Argument1, Arguments, OtherArguments), '$lgt_member'(Argument2, OtherArguments), term_variables(Argument1, Variables1), term_variables(Argument2, Variables2), '$lgt_intersection'(Variables1, Variables2, [_| _]), % at least one variable in common !. '$lgt_read_file_to_terms'(File, Directory, SourceFile, Terms, Mode) :- % check file specification and expand library notation or environment variable if used catch( '$lgt_check_and_expand_source_file'(File, ExpandedFile), error(FileError, _), throw(FileError) ), % find the full file name as the extension may be missing ( '$lgt_source_file_name'(ExpandedFile, [], Directory, _, _, SourceFile), % avoid a loading loop by checking that the file name is different % from the name of the file containing the include/1 directive \+ '$lgt_pp_file_paths_flags_'(_, _, SourceFile, _, _), '$lgt_file_exists'(SourceFile) -> true ; '$lgt_source_file_name'(ExpandedFile, [], Directory, _, _, SourceFile), '$lgt_pp_file_paths_flags_'(_, _, SourceFile, _, _) -> throw(permission_error(include, file, File)) ; throw(existence_error(file, File)) ), ( Mode = compile(_,_,_) -> '$lgt_print_message'(silent(compiling), compiling_file(SourceFile, [])) ; true ), catch( '$lgt_open'(SourceFile, read, Stream, []), error(OpenError, _), throw(OpenError) ), % look for an encoding/1 directive that, when present, must be the first term on a source file catch( '$lgt_read_term'(Stream, Term, [variable_names(VariableNames), singletons(Singletons)], Lines), error(TermError, _), '$lgt_read_file_to_terms_error_handler'(Mode, SourceFile, Stream, TermError) ), catch( '$lgt_check_for_encoding_directive'(Term, SourceFile, Lines, Stream, NewStream, [], _), FirstTermError, '$lgt_read_file_to_terms_error_handler'(Mode, SourceFile, Stream, FirstTermError) ), % read the reamining terms catch( '$lgt_read_stream_to_terms'(Term, VariableNames, Singletons, Lines, SourceFile, NewStream, Terms, Mode), error(TermError, _), '$lgt_read_file_to_terms_error_handler'(Mode, SourceFile, NewStream, TermError) ), '$lgt_close'(NewStream). '$lgt_read_file_to_terms_error_handler'(runtime, _, Stream, Error) :- '$lgt_close'(Stream), throw(Error). '$lgt_read_file_to_terms_error_handler'(compile(_,_,_), SourceFile, Stream, Error) :- '$lgt_pp_file_paths_flags_'(_, _, _, ObjectFile, _), ( '$lgt_stream_current_line_number'(Stream, Line) -> true ; Line = -1 ), '$lgt_close'(Stream), '$lgt_compiler_error_handler'(SourceFile, ObjectFile, Line-Line, Error). '$lgt_read_stream_to_terms'(Term, VariableNames, Singletons, Lines, File, Stream, [Term-sd(VariableNames,Singletons,Lines)| Terms], Mode) :- var(Term), % delay the instantiation error !, '$lgt_read_term'(Stream, NextTerm, [variable_names(NextVariableNames), singletons(NextSingletons)], NextLines), '$lgt_read_stream_to_terms'(NextTerm, NextVariableNames, NextSingletons, NextLines, File, Stream, Terms, Mode). '$lgt_read_stream_to_terms'(end_of_file, _, _, _, _, _, [], _) :- !. '$lgt_read_stream_to_terms'((:- op(Priority, Specifier, Operators)), VariableNames, Singletons, Lines, File, Stream, [(:- op(Priority, Specifier, Operators))-sd(VariableNames,Singletons,Lines)| Terms], Mode) :- !, '$lgt_check'(operator_specification, op(Priority, Specifier, Operators)), ( '$lgt_pp_entity_'(_, _, _) -> '$lgt_activate_entity_operators'(Priority, Specifier, Operators, l, File, Lines, Mode) ; '$lgt_activate_file_operators'(Priority, Specifier, Operators, Mode) ), '$lgt_read_term'(Stream, NextTerm, [variable_names(NextVariableNames), singletons(NextSingletons)], NextLines), '$lgt_read_stream_to_terms'(NextTerm, NextVariableNames, NextSingletons, NextLines, File, Stream, Terms, Mode). '$lgt_read_stream_to_terms'(Term, VariableNames, Singletons, Lines, File, Stream, [Term-sd(VariableNames,Singletons,Lines)| Terms], Mode) :- '$lgt_report_singleton_variables'(Mode, Singletons, Term, File, Lines), '$lgt_read_term'(Stream, NextTerm, [variable_names(NextVariableNames), singletons(NextSingletons)], NextLines), '$lgt_read_stream_to_terms'(NextTerm, NextVariableNames, NextSingletons, NextLines, File, Stream, Terms, Mode). % '$lgt_check'(+atom, @term, @callable) % % type-checking for built-in directive and predicate arguments '$lgt_check'(var, Term, Context) :- ( var(Term) -> true ; throw(error(uninstantiation_error(Term), Context)) ). '$lgt_check'(nonvar, Term, Context) :- ( nonvar(Term) -> true ; throw(error(instantiation_error, Context)) ). '$lgt_check'(ground, Term, Context) :- ( ground(Term) -> true ; throw(error(instantiation_error, Context)) ). '$lgt_check'(atom, Term, Context) :- ( atom(Term) -> true ; var(Term) -> throw(error(instantiation_error, Context)) ; throw(error(type_error(atom, Term), Context)) ). '$lgt_check'(var_or_atom, Term, Context) :- ( var(Term) -> true ; atom(Term) -> true ; throw(error(type_error(atom, Term), Context)) ). '$lgt_check'(boolean, Term, Context) :- ( Term == true -> true ; Term == false -> true ; var(Term) -> throw(error(instantiation_error, Context)) ; atom(Term) -> throw(error(domain_error(boolean, Term), Context)) ; throw(error(type_error(atom, Term), Context)) ). '$lgt_check'(var_or_boolean, Term, Context) :- ( var(Term) -> true ; \+ atom(Term) -> throw(error(type_error(atom, Term), Context)) ; Term \== true, Term \== false, throw(error(domain_error(boolean, Term), Context)) ). '$lgt_check'(atom_or_string, Term, Context) :- ( atom(Term) -> true ; '$lgt_string'(Term) -> true ; var(Term) -> throw(error(instantiation_error, Context)) ; throw(error(type_error(atom_or_string, Term), Context)) ). '$lgt_check'(integer, Term, Context) :- ( integer(Term) -> true ; var(Term) -> throw(error(instantiation_error, Context)) ; throw(error(type_error(integer, Term), Context)) ). '$lgt_check'(var_or_integer, Term, Context) :- ( var(Term) -> true ; integer(Term) -> true ; throw(error(type_error(integer, Term), Context)) ). '$lgt_check'(non_negative_integer, Term, Context) :- ( var(Term) -> throw(error(instantiation_error, Context)) ; \+ integer(Term) -> throw(error(type_error(integer, Term), Context)) ; Term < 0 -> throw(error(domain_error(not_less_than_zero, Term), Context)) ; true ). '$lgt_check'(var_or_non_negative_integer, Term, Context) :- ( var(Term) -> true ; \+ integer(Term) -> throw(error(type_error(integer, Term), Context)) ; Term < 0 -> throw(error(domain_error(not_less_than_zero, Term), Context)) ; true ). '$lgt_check'(float, Term, Context) :- ( float(Term) -> true ; var(Term) -> throw(error(instantiation_error, Context)) ; throw(error(type_error(float, Term), Context)) ). '$lgt_check'(atomic, Term, Context) :- ( atomic(Term) -> true ; var(Term) -> throw(error(instantiation_error, Context)) ; throw(error(type_error(atomic, Term), Context)) ). '$lgt_check'(atomic_or_string, Term, Context) :- ( atomic(Term) -> true ; '$lgt_string'(Term) -> true ; var(Term) -> throw(error(instantiation_error, Context)) ; throw(error(type_error(atomic_or_string, Term), Context)) ). '$lgt_check'(curly_bracketed_term, Term, Context) :- ( var(Term) -> throw(error(instantiation_error, Context)) ; Term = {_} -> true ; Term == '{}' -> true ; throw(error(type_error(curly_bracketed_term, Term), Context)) ). '$lgt_check'(var_or_curly_bracketed_term, Term, Context) :- ( var(Term) -> true ; Term = {_} -> true ; Term == '{}' -> true ; throw(error(type_error(curly_bracketed_term, Term), Context)) ). '$lgt_check'(callable, Term, Context) :- ( callable(Term) -> true ; var(Term) -> throw(error(instantiation_error, Context)) ; throw(error(type_error(callable, Term), Context)) ). '$lgt_check'(var_or_callable, Term, Context) :- ( var(Term) -> true ; callable(Term) -> true ; throw(error(type_error(callable, Term), Context)) ). '$lgt_check'(qualified_callable, Term, Context) :- ( '$lgt_prolog_feature'(modules, supported) -> '$lgt_check'(qualified_callable_, Term, Context) ; '$lgt_check'(callable, Term, Context) ). '$lgt_check'(qualified_callable_, Term, Context) :- ( var(Term) -> throw(error(instantiation_error, Context)) ; Term = ':'(Module, Goal) -> '$lgt_check'(module_identifier, Module, Context), '$lgt_check'(qualified_callable_, Goal, Context) ; callable(Term) -> true ; throw(error(type_error(callable, Term), Context)) ). '$lgt_check'(clause, Term, Context) :- ( Term = (Head :- Body) -> '$lgt_check'(callable, Head, Context), '$lgt_check'(var_or_callable, Body, Context) ; callable(Term) -> true ; throw(error(type_error(callable, Term), Context)) ). '$lgt_check'(list, Term, Context) :- '$lgt_check_list'(list, Term, Term, Context). '$lgt_check'(list_or_partial_list, Term, Context) :- ( var(Term) -> true ; '$lgt_is_list_or_partial_list'(Term) -> true ; throw(error(type_error(list, Term), Context)) ). '$lgt_check'(list(Type), Term, Context) :- '$lgt_check_list'(list(Type), Term, Term, Context), forall('$lgt_member'(Item, Term), '$lgt_check'(Type, Item, Context)). '$lgt_check'(object, Term, Context) :- ( var(Term) -> throw(error(instantiation_error, Context)) ; '$lgt_current_object_'(Term, _, _, _, _, _, _, _, _, _, _) -> true ; callable(Term) -> throw(error(existence_error(object, Term), Context)) ; throw(error(type_error(object_identifier, Term), Context)) ). '$lgt_check'(object_identifier, Term, Context) :- ( callable(Term) -> true ; var(Term) -> throw(error(instantiation_error, Context)) ; throw(error(type_error(object_identifier, Term), Context)) ). '$lgt_check'(var_or_object_identifier, Term, Context) :- ( var(Term) -> true ; callable(Term) -> true ; throw(error(type_error(object_identifier, Term), Context)) ). '$lgt_check'(protocol, Term, Context) :- ( var(Term) -> throw(error(instantiation_error, Context)) ; '$lgt_current_protocol_'(Term, _, _, _, _) -> true ; atom(Term) -> throw(error(existence_error(protocol, Term), Context)) ; throw(error(type_error(protocol_identifier, Term), Context)) ). '$lgt_check'(protocol_identifier, Term, Context) :- ( atom(Term) -> true ; var(Term) -> throw(error(instantiation_error, Context)) ; throw(error(type_error(protocol_identifier, Term), Context)) ). '$lgt_check'(var_or_protocol_identifier, Term, Context) :- ( var(Term) -> true ; atom(Term) -> true ; throw(error(type_error(protocol_identifier, Term), Context)) ). '$lgt_check'(category, Term, Context) :- ( var(Term) -> throw(error(instantiation_error, Context)) ; '$lgt_current_category_'(Term, _, _, _, _, _) -> true ; callable(Term) -> throw(error(existence_error(category, Term), Context)) ; throw(error(type_error(category_identifier, Term), Context)) ). '$lgt_check'(category_identifier, Term, Context) :- ( callable(Term) -> true ; var(Term) -> throw(error(instantiation_error, Context)) ; throw(error(type_error(category_identifier, Term), Context)) ). '$lgt_check'(var_or_category_identifier, Term, Context) :- ( var(Term) -> true ; callable(Term) -> true ; throw(error(type_error(category_identifier, Term), Context)) ). '$lgt_check'(entity_identifier, Term, Context) :- ( callable(Term) -> true ; var(Term) -> throw(error(instantiation_error, Context)) ; throw(error(type_error(entity_identifier, Term), Context)) ). '$lgt_check'(var_or_entity_identifier, Term, Context) :- ( var(Term) -> true ; callable(Term) -> true ; throw(error(type_error(entity_identifier, Term), Context)) ). '$lgt_check'(module_identifier, Term, Context) :- ( atom(Term) -> true ; var(Term) -> throw(error(instantiation_error, Context)) ; throw(error(type_error(module_identifier, Term), Context)) ). '$lgt_check'(var_or_module_identifier, Term, Context) :- ( var(Term) -> true ; atom(Term) -> true ; throw(error(type_error(module_identifier, Term), Context)) ). '$lgt_check'(predicate_indicator, Term, Context) :- ( Term = Functor/Arity -> '$lgt_check'(atom, Functor, Context), '$lgt_check'(non_negative_integer, Arity, Context) ; throw(error(type_error(predicate_indicator, Term), Context)) ). '$lgt_check'(var_or_predicate_indicator, Term, Context) :- ( var(Term) -> true ; Term = Functor/Arity -> '$lgt_check'(var_or_atom, Functor, Context), '$lgt_check'(var_or_non_negative_integer, Arity, Context) ; throw(error(type_error(predicate_indicator, Term), Context)) ). '$lgt_check'(predicate_or_non_terminal_indicator, Term, Context) :- ( Term = Functor/Arity -> '$lgt_check'(atom, Functor, Context), '$lgt_check'(non_negative_integer, Arity, Context) ; Term = Functor//Arity -> '$lgt_check'(atom, Functor, Context), '$lgt_check'(non_negative_integer, Arity, Context) ; throw(error(type_error(predicate_indicator, Term), Context)) ). '$lgt_check'(scope, Term, Context) :- ( var(Term) -> throw(error(instantiation_error, Context)) ; '$lgt_valid_scope'(Term) -> true ; atom(Term) -> throw(error(domain_error(scope, Term), Context)) ; throw(error(type_error(atom, Term), Context)) ). '$lgt_check'(var_or_scope, Term, Context) :- ( var(Term) -> true ; '$lgt_valid_scope'(Term) -> true ; atom(Term) -> throw(error(domain_error(scope, Term), Context)) ; throw(error(type_error(atom, Term), Context)) ). '$lgt_check'(var_or_event, Term, Context) :- ( var(Term) -> true ; Term \== before, Term \== after -> throw(error(type_error(event, Term), Context)) ; true ). '$lgt_check'(operator_specification, Term, Context) :- ( Term = op(Priority, Specifier, Operators) -> '$lgt_check'(operator_priority, Priority, Context), '$lgt_check'(operator_specifier, Specifier, Context), '$lgt_check'(operator_names, Operators, Context) ; throw(error(type_error(operator_specification, Term), Context)) ). '$lgt_check'(operator_priority, Priority, Context) :- ( var(Priority) -> throw(error(instantiation_error, Context)) ; \+ integer(Priority), throw(error(type_error(integer, Priority), Context)) ; (Priority < 0; Priority > 1200) -> throw(error(domain_error(operator_priority, Priority), Context)) ; true ). '$lgt_check'(var_or_operator_priority, Priority, Context) :- ( var(Priority) -> true ; '$lgt_check'(operator_priority, Priority, Context) ). '$lgt_check'(operator_specifier, Term, Context) :- ( var(Term) -> throw(error(instantiation_error, Context)) ; \+ atom(Term) -> throw(error(type_error(atom, Term), Context)) ; '$lgt_member'(Term, [fx, fy, xfx, xfy, yfx, xf, yf]) -> true ; throw(error(domain_error(operator_specifier, Term), Context)) ). '$lgt_check'(var_or_operator_specifier, Term, Context) :- ( var(Term) -> true ; '$lgt_check'(operator_specifier, Term, Context) ). '$lgt_check'(operator_names, Term, Context) :- ( var(Term) -> throw(error(instantiation_error, Context)) ; Term == (',') -> throw(error(permission_error(modify, operator, ','), Context)) ; atom(Term) -> true ; \+ '$lgt_is_list'(Term) -> throw(type_error(list, Term)) ; \+ ('$lgt_member'(Operator, Term), \+ '$lgt_check'(operator_name, Operator, Context)) ). '$lgt_check'(operator_name, Term, Context) :- ( var(Term) -> throw(error(instantiation_error, Context)) ; Term == (',') -> throw(error(permission_error(modify, operator, ','), Context)) ; atom(Term) -> true ; throw(error(type_error(atom, Term), Context)) ). '$lgt_check'(var_or_object_property, Term, Context) :- ( var(Term) -> true ; '$lgt_valid_object_property'(Term) -> true ; callable(Term) -> throw(error(domain_error(object_property, Term), Context)) ; throw(error(type_error(callable, Term), Context)) ). '$lgt_check'(var_or_category_property, Term, Context) :- ( var(Term) -> true ; '$lgt_valid_category_property'(Term) -> true ; callable(Term) -> throw(error(domain_error(category_property, Term), Context)) ; throw(error(type_error(callable, Term), Context)) ). '$lgt_check'(var_or_protocol_property, Term, Context) :- ( var(Term) -> true ; '$lgt_valid_protocol_property'(Term) -> true ; callable(Term) -> throw(error(domain_error(protocol_property, Term), Context)) ; throw(error(type_error(callable, Term), Context)) ). '$lgt_check'(flag, Term, Context) :- ( var(Term) -> throw(error(instantiation_error, Context)) ; '$lgt_valid_flag'(Term) -> true ; '$lgt_user_defined_flag_'(Term, _, _) -> true ; atom(Term) -> throw(error(domain_error(flag, Term), Context)) ; throw(error(type_error(atom, Term), Context)) ). '$lgt_check'(var_or_flag, Term, Context) :- ( var(Term) -> true ; '$lgt_valid_flag'(Term) -> true ; '$lgt_user_defined_flag_'(Term, _, _) -> true ; atom(Term) -> throw(error(domain_error(flag, Term), Context)) ; throw(error(type_error(atom, Term), Context)) ). '$lgt_check'(read_write_flag, Term, Context) :- ( var(Term) -> throw(error(instantiation_error, Context)) ; \+ atom(Term) -> throw(error(type_error(atom, Term), Context)) ; \+ '$lgt_valid_flag'(Term), \+ '$lgt_user_defined_flag_'(Term, _, _) -> throw(error(domain_error(flag, Term), Context)) ; '$lgt_read_only_flag'(Term) -> throw(error(permission_error(modify, flag, Term), Context)) ; '$lgt_user_defined_flag_'(Term, read_only, _) -> throw(error(permission_error(modify, flag, Term), Context)) ; true ). '$lgt_check'(var_or_read_write_flag, Term, Context) :- ( var(Term) -> true ; \+ atom(Term) -> throw(error(type_error(atom, Term), Context)) ; \+ '$lgt_valid_flag'(Term), \+ '$lgt_user_defined_flag_'(Term, _, _) -> throw(error(domain_error(flag, Term), Context)) ; '$lgt_read_only_flag'(Term) -> throw(error(permission_error(modify, flag, Term), Context)) ; '$lgt_user_defined_flag_'(Term, read_only, _) -> throw(error(permission_error(modify, flag, Term), Context)) ; true ). '$lgt_check'(flag_value, Term1+Term2, Context) :- ( var(Term2) -> throw(error(instantiation_error, Context)) ; '$lgt_valid_flag_value'(Term1, Term2) -> true ; '$lgt_user_defined_flag_'(Term1, _, Type), call(Type, Term2) -> true ; throw(error(domain_error(flag_value, Term1 + Term2), Context)) ). '$lgt_check'(var_or_flag_value, Term1+Term2, Context) :- ( var(Term2) -> true ; '$lgt_valid_flag_value'(Term1, Term2) -> true ; '$lgt_user_defined_flag_'(Term1, _, Type), call(Type, Term2) -> true ; throw(error(domain_error(flag_value, Term1 + Term2), Context)) ). '$lgt_check'(predicate_property, Term, Context) :- ( var(Term) -> throw(error(instantiation_error, Context)) ; '$lgt_valid_predicate_property'(Term) -> true ; '$lgt_prolog_predicate_property'(Term) -> true ; throw(error(domain_error(predicate_property, Term), Context)) ). '$lgt_check'(var_or_predicate_property, Term, Context) :- ( var(Term) -> true ; '$lgt_valid_predicate_property'(Term) -> true ; '$lgt_prolog_predicate_property'(Term) -> true ; throw(error(domain_error(predicate_property, Term), Context)) ). '$lgt_check'(key_value_info_pair, Term, Context) :- ( Term = (Key is Value) -> '$lgt_check'(atom, Key, Context), '$lgt_check'(nonvar, Value, Context) ; throw(error(type_error(key_value_info_pair, Term), Context)) ). '$lgt_check_list'(Type, Term, Original, Context) :- ( var(Term) -> throw(error(instantiation_error, Context)) ; Term == [] -> true ; Term = [_| Tail] -> '$lgt_check_list'(Type, Tail, Original, Context) ; throw(error(type_error(Type, Original), Context)) ). % '$lgt_check'(+atom, @term) % % this simpler version of the predicate is mainly used when compiling source files '$lgt_check'(Type, Term) :- catch('$lgt_check'(Type, Term, _), error(Error, _), throw(Error)). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Logtalk startup initialization % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % dynamic entity counters initial definitions % % counters used when generating identifiers for dynamically created entities '$lgt_dynamic_entity_counter_'(object, o, 1). '$lgt_dynamic_entity_counter_'(protocol, p, 1). '$lgt_dynamic_entity_counter_'(category, c, 1). % '$lgt_load_built_in_entities'(-atom) % % loads all built-in entities if not already loaded (when embedding % Logtalk, the pre-compiled entities are loaded prior to this file) '$lgt_load_built_in_entities'(ScratchDirectory) :- ( '$lgt_expand_library_alias'(scratch_directory, ScratchDirectory) -> % user override for the default scratch directory '$lgt_set_compiler_flag'(scratch_directory, ScratchDirectory) ; % use default scratch directory '$lgt_expand_library_alias'(logtalk_user, LogtalkUserDirectory), atom_concat(LogtalkUserDirectory, 'scratch/', ScratchDirectory) ), '$lgt_load_built_in_entity'(expanding, protocol, 'expanding', ScratchDirectory), '$lgt_load_built_in_entity'(monitoring, protocol, 'monitoring', ScratchDirectory), '$lgt_load_built_in_entity'(forwarding, protocol, 'forwarding', ScratchDirectory), '$lgt_load_built_in_entity'(user, object, 'user', ScratchDirectory), '$lgt_load_built_in_entity'(logtalk, object, 'logtalk', ScratchDirectory), '$lgt_load_built_in_entity'(core_messages, category, 'core_messages', ScratchDirectory), % remember that all built-in entities are loaded and thus tokenization for % compiler and runtime error and warning messages is available assertz('$lgt_built_in_entities_loaded_'). '$lgt_load_built_in_entity'(Entity, Type, File, ScratchDirectory) :- ( Type == protocol, '$lgt_current_protocol_'(Entity, _, _, _, _) -> true ; Type == category, '$lgt_current_category_'(Entity, _, _, _, _, _) -> true ; Type == object, '$lgt_current_object_'(Entity, _, _, _, _, _, _, _, _, _, _) -> true ; % not an embedded entity; compile and load it logtalk_load( core(File), [ % we need a fixed code prefix as some of the entity predicates may need % to be called directly by the compiler/runtime code_prefix('$'), % delete the generated intermediate files as they may be non-portable % between backend Prolog compilers clean(on), % use a scratch directory where we expect to have writing permission scratch_directory(ScratchDirectory), % optimize entity code, allowing static binding to this entity resources optimize(on), % don't print any messages on the compilation and loading of these entities report(off), % prevent any attempts of logtalk_make(all) to reload this file reload(skip) ] ) ). % '$lgt_load_settings_file'(+atom, -callable) % % loads any settings file defined by the user; settings files are compiled % and loaded silently, ignoring any errors; the intermediate Prolog files % are deleted using the clean/1 compiler flag in order to prevent problems % when switching between backend Prolog compilers; returns the result from % the loading attempt for printing after banner and default flags '$lgt_load_settings_file'(ScratchDirectory, Result) :- '$lgt_default_flag'(settings_file, Value), Options = [ % delete the generated intermediate file as it may be non-portable % between backend Prolog compilers clean(on), % use a scratch directory where we expect to have writing permission scratch_directory(ScratchDirectory), % optimize any entity code present, allowing static binding to % entity resources, and preventing their redefinition optimize(on), reload(skip), % don't print any compilation or loading messages report(off) ], '$lgt_load_settings_file'(Value, Options, Result). '$lgt_load_settings_file'(deny, _, disabled). '$lgt_load_settings_file'(restrict, Options, Result) :- ( '$lgt_settings_file_search_directory'(restrict, Directory), '$lgt_load_settings_file_from_directory'(Directory, Options, Result) -> true ; % no settings file found Result = none(restrict) ). '$lgt_load_settings_file'(allow, Options, Result) :- ( '$lgt_settings_file_search_directory'(allow, Directory), '$lgt_load_settings_file_from_directory'(Directory, Options, Result) -> true ; % no settings file found Result = none(allow) ). '$lgt_settings_file_search_directory'(allow, Directory) :- '$lgt_expand_library_alias'(startup, Directory). '$lgt_settings_file_search_directory'(allow, Directory) :- '$lgt_settings_file_search_directory'(restrict, Directory). '$lgt_settings_file_search_directory'(restrict, Directory) :- '$lgt_expand_library_alias'(logtalk_user, Directory). '$lgt_settings_file_search_directory'(restrict, Directory) :- '$lgt_expand_library_alias'(home, Directory). '$lgt_settings_file_search_directory'(restrict, Directory) :- '$lgt_environment_variable'('COMSPEC', _), % Windows systems define this environment variable but not POSIX systems '$lgt_environment_variable'('APPDATA', APPDATA), atom_concat(APPDATA, '\\Logtalk\\', Directory). '$lgt_settings_file_search_directory'(restrict, Directory) :- '$lgt_environment_variable'('XDG_CONFIG_HOME', XDG_CONFIG_HOME), atom_concat(XDG_CONFIG_HOME, '/logtalk/', Directory). '$lgt_settings_file_search_directory'(restrict, Directory) :- '$lgt_expand_library_alias'(home, Home), atom_concat(Home, '.config/logtalk/', Directory). '$lgt_load_settings_file_from_directory'(Directory, Options, Result) :- ( '$lgt_file_extension'(logtalk, Extension), % more than one possible extension may be listed in the used adapter file atom_concat(settings, Extension, SettingsFile), % construct full path to the possible settings file; directories resulting % from library alias expansion are guaranteed to end with a slash atom_concat(Directory, SettingsFile, SettingsPath), '$lgt_file_exists'(SettingsPath) -> % settings file found; compile and load it ( catch(logtalk_load(SettingsPath, Options), _, fail) -> Result = loaded(Directory) ; Result = error(Directory) ) ; % no settings file in this directory fail ). % '$lgt_report_settings_file'(@nonvar) % % reports result of the attempt to load a settings file defined by the user '$lgt_report_settings_file'(loaded(Path)) :- '$lgt_print_message'(comment(settings), loaded_settings_file(Path)). '$lgt_report_settings_file'(disabled) :- '$lgt_print_message'(comment(settings), settings_file_disabled). '$lgt_report_settings_file'(error(Path)) :- '$lgt_print_message'(error, error_loading_settings_file(Path)). '$lgt_report_settings_file'(none(Flag)) :- '$lgt_print_message'(comment(settings), no_settings_file_found(Flag)). % cache default and read-only compiler flags to improve the performance % of the compiler by reducing the potential number of flag levels that % need to be checked for finding the value of a flag in a given context % % although there should be no clauses for the '$lgt_current_flag_'/2 % predicate when this predicate is called at runtime initialization, a % wrong file order when embedding Logtalk or a Logtalk application can % falsify this assumption; therefore, we test for a flag definition % before caching its default value '$lgt_cache_compiler_flags' :- '$lgt_default_flag'(Name, Value), \+ '$lgt_current_flag_'(Name, _), assertz('$lgt_current_flag_'(Name, Value)), fail. '$lgt_cache_compiler_flags' :- '$lgt_prolog_feature'(Name, Value), \+ '$lgt_current_flag_'(Name, _), assertz('$lgt_current_flag_'(Name, Value)), fail. '$lgt_cache_compiler_flags' :- '$lgt_version_data'(VersionData), assertz('$lgt_current_flag_'(version_data, VersionData)). % '$lgt_compile_default_hooks' % % compiles the default hooks specified on the backend adapter file or % settings file for better performance when compiling source files '$lgt_compile_default_hooks' :- ( '$lgt_compiler_flag'(hook, Hook) -> '$lgt_compile_hooks'(Hook) ; true ). % '$lgt_start_runtime_threading' % % initializes the engines mutex plus the asynchronous threaded calls mutex % and tag counter support for backends supporting multi-threading programming % (currently we use integers for the tag counter, which impose a limitation on % the maximum number of tags on backends with bounded integers) '$lgt_start_runtime_threading' :- ( '$lgt_prolog_feature'(engines, supported) -> mutex_create(_, [alias('$lgt_engines')]), ( current_prolog_flag(bounded, true) -> current_prolog_flag(min_integer, Min), assertz('$lgt_threaded_engine_tag_counter_'(Min)) ; assertz('$lgt_threaded_engine_tag_counter_'(0)) ) ; true ), ( '$lgt_prolog_feature'(threads, supported) -> mutex_create(_, [alias('$lgt_threaded_tag')]), ( current_prolog_flag(bounded, true) -> current_prolog_flag(min_integer, Min), assertz('$lgt_threaded_tag_counter_'(Min)) ; assertz('$lgt_threaded_tag_counter_'(0)) ) ; true ). % '$lgt_check_prolog_version' % % checks for a compatible backend Prolog compiler version % % note, however, that an old and incompatible backend Prolog version may % break Logtalk initialization before this checking predicate is called '$lgt_check_prolog_version' :- '$lgt_prolog_feature'(prolog_version, Current), '$lgt_prolog_feature'(prolog_compatible_version, Check), functor(Check, Operator, 1), arg(1, Check, Compatible), ( call(Operator, Current, Compatible) -> true ; '$lgt_print_message'( warning(compatibility), possibly_incompatible_prolog_version(Current, Compatible) ) ). % Logtalk runtime initialization % % when embedding Logtalk in a saved state created by a backend Prolog % compiler, the runtime initialization may be triggered again when % running the saved state; we use a dynamic predicate as a flag to % prevent redoing this initialization % % we write the initialization/1 directive at the end of the file to % avoid issues with backend Prolog compilers that fail to fully support % ISO Prolog specified semantics for this directive '$lgt_runtime_initialization' :- '$lgt_runtime_initialization_completed_', !. '$lgt_runtime_initialization' :- '$lgt_cache_compiler_flags', '$lgt_load_built_in_entities'(ScratchDirectory), '$lgt_load_settings_file'(ScratchDirectory, Result), '$lgt_print_message'(banner, banner), '$lgt_print_message'(comment(settings), default_flags), '$lgt_compile_default_hooks', '$lgt_start_runtime_threading', '$lgt_report_settings_file'(Result), '$lgt_print_message'(comment(help), help), '$lgt_check_prolog_version', assertz('$lgt_runtime_initialization_completed_'). :- initialization('$lgt_runtime_initialization'). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % end! % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%