%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% 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_provider#1'/2).
:- multifile('$logtalk#0.debug_handler#2'/3).
% 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, File, Lines)
:- dynamic('$lgt_pp_dynamic_'/3).
% '$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, File, Lines)
:- dynamic('$lgt_pp_multifile_'/3).
% '$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_parameter_variables_'(ParameterVariables)
:- dynamic('$lgt_pp_parameter_variables_'/1).
% '$lgt_pp_object_alias_'(Obj, Alias, CompilationContext)
:- dynamic('$lgt_pp_object_alias_'/3).
% '$lgt_pp_module_alias_'(Module, Alias, CompilationContext)
:- dynamic('$lgt_pp_module_alias_'/3).
% '$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, Line)
:- dynamic('$lgt_pp_predicate_declaration_location_'/4).
% '$lgt_pp_predicate_definition_location_'(Functor, Arity, File, Line)
:- 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, Line)
:- 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
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% 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'(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, _, _, _, _, Rnm, Flags) :-
'$lgt_entity_property_alias'(Obj, Rnm, Flags, 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'(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, _, _, Rnm, Flags) :-
'$lgt_entity_property_alias'(Ctg, Rnm, Flags, 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'(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, _, Rnm, Flags) :-
'$lgt_entity_property_alias'(Ptc, Rnm, Flags, 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 = File-Line ->
Properties2 = [include(File), line_count(Line)| Properties1]
; Properties2 = [line_count(Location)| 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 = File-Line ->
Properties0 = [include(File), line_count(Line), number_of_clauses(Clauses), number_of_rules(Rules)]
; Location =:= 0 ->
% auxiliary predicate
Properties0 = [number_of_clauses(Clauses), number_of_rules(Rules)]
; Properties0 = [line_count(Location), 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_'(Entity, Functor/Arity, clauses_rules_location_from(Clauses, Rules, Location, From)),
( Location = File-Line ->
LocationProperties = [include(File), line_count(Line)]
; LocationProperties = [line_count(Location)]
),
Properties = [number_of_clauses(Clauses), number_of_rules(Rules)| LocationProperties].
'$lgt_entity_property_provides'(Entity, Functor/Arity, To, Properties) :-
'$lgt_predicate_property_'(To, Functor/Arity, clauses_rules_location_from(Clauses, Rules, Location, Entity)),
( Location = File-Line ->
LocationProperties = [include(File), line_count(Line)]
; LocationProperties = [line_count(Location)]
),
Properties = [number_of_clauses(Clauses), number_of_rules(Rules)| LocationProperties].
'$lgt_entity_property_alias'(Entity, Rnm, Flags, AliasFunctor/Arity, Properties) :-
( Flags /\ 8 =:= 8 ->
% entity compiled with the source_data flag turned on
'$lgt_entity_property_'(Entity, alias(From, OriginalFunctor/Arity, AliasFunctor/Arity, NonTerminalFlag, Location)),
( Location = File-Line ->
LocationProperties = [include(File), line_count(Line)]
; LocationProperties = [line_count(Location)]
),
( NonTerminalFlag =:= 1 ->
Arity2 is Arity - 2,
Properties = [non_terminal(AliasFunctor//Arity2), for(OriginalFunctor/Arity), from(From)| LocationProperties]
; Properties = [for(OriginalFunctor/Arity), from(From)| LocationProperties]
)
; % entity compiled with the source_data flag turned off
call(Rnm, From, Original, Alias),
nonvar(From),
functor(Original, OriginalFunctor, Arity),
functor(Alias, AliasFunctor, Arity),
Properties = [for(OriginalFunctor/Arity), from(From)]
).
'$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 = File-Line ->
LocationProperties = [include(File), line_count(Line)| NonTerminalProperty]
; LocationProperties = [line_count(Location)| 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 = File-Line ->
LocationProperties = [include(File), line_count(Line)| NonTerminalProperty]
; LocationProperties = [line_count(Location)| 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(threads), 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(threads), 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(threads), 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(threads), 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(threads), 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(threads), 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(threads), 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(threads), 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(threads), 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))
; 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'(_).
'$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, 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
( nonvar(Location),
Location = Path-Line ->
% reference found in included file
( integer(Line) ->
StartLine = Line
; % backend Prolog system that doesn't report line numbers
StartLine = -1
)
; % either reference found in main file or dynamically created entity
( '$lgt_entity_property_'(Entity, file_lines(File,Directory,EntityLine,_)) ->
atom_concat(Directory, File, Path)
; % dynamically created entity
Path = '',
EntityLine = -1
),
( integer(Location) ->
StartLine = Location
; % either dynamically created entity or backend Prolog
% system that doesn't report line numbers
StartLine = EntityLine
)
).
% 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(source, SourceFile) :-
'$lgt_pp_file_paths_flags_'(_, _, SourceFile, _, _).
logtalk_load_context(directory, Directory) :-
'$lgt_pp_file_paths_flags_'(_, Directory, _, _, _).
logtalk_load_context(basename, Basename) :-
'$lgt_pp_file_paths_flags_'(Basename, _, _, _, _).
logtalk_load_context(target, ObjectFile) :-
% full path of the generated intermediate Prolog file
'$lgt_pp_file_paths_flags_'(_, _, _, ObjectFile, _).
logtalk_load_context(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).
logtalk_load_context(entity_name, Entity) :-
% deprecated key; use entity_identifier key instead
'$lgt_pp_entity_'(_, Entity, _).
logtalk_load_context(entity_identifier, Entity) :-
'$lgt_pp_entity_'(_, Entity, _).
logtalk_load_context(entity_prefix, Prefix) :-
'$lgt_pp_entity_'(_, _, Prefix).
logtalk_load_context(entity_type, Type) :-
( '$lgt_pp_module_'(_) ->
Type = module
; '$lgt_pp_entity_'(Type, _, _)
).
logtalk_load_context(entity_relation, Relation) :-
'$lgt_logtalk_load_context_entity_relation'(Relation).
logtalk_load_context(term, Term) :-
% full file term being compiled
'$lgt_pp_term_source_data_'(Term, _, _, _, _).
logtalk_load_context(variables, Variables) :-
% variables of the full file term being compiled
'$lgt_pp_term_source_data_'(Term, _, _, _, _),
term_variables(Term, Variables).
logtalk_load_context(variable_names, VariableNames) :-
% variable names for the full file term being compiled
'$lgt_pp_term_source_data_'(_, VariableNames, _, _, _).
logtalk_load_context(variable_names(Term), VariableNames) :-
% variable names for the full file term being compiled
'$lgt_pp_term_source_data_'(Term, VariableNames, _, _, _).
logtalk_load_context(singletons, Singletons) :-
% singleton variables in the full file term being compiled
'$lgt_pp_term_source_data_'(_, _, Singletons, _, _).
logtalk_load_context(singletons(Term), Singletons) :-
% singleton variables in the full file term being compiled
'$lgt_pp_term_source_data_'(Term, _, Singletons, _, _).
logtalk_load_context(parameter_variables, ParameterVariablePairs) :-
% only succeeds when compiling a parametric entity containing parameter variables
'$lgt_pp_parameter_variables_'(ParameterVariablePairs).
logtalk_load_context(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, _).
logtalk_load_context(term_position, Lines) :-
% term position of the full file term being compiled
'$lgt_pp_term_source_data_'(_, _, _, _, Lines).
logtalk_load_context(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, _, _, _).
% 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'(Flag, Value) :-
retractall('$lgt_current_flag_'(Flag, _)),
assertz('$lgt_current_flag_'(Flag, Value)),
% only one of the optimize and debug flags can be turned on at the same time
( Flag == optimize, Value == on ->
retractall('$lgt_current_flag_'(debug, _)),
assertz('$lgt_current_flag_'(debug, off))
; Flag == debug, Value == on ->
retractall('$lgt_current_flag_'(optimize, _)),
assertz('$lgt_current_flag_'(optimize, off))
; true
),
( Flag == hook ->
% pre-compile hook calls for better performance when compiling files
'$lgt_compile_hooks'(Value)
; true
).
% 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, 77, 0, stable)).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% built-in methods
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% '$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, 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 = _-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 = _-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 = _-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_'(DCtn, Functor/Arity, clauses_rules_location_from(N1, _, _, _)), 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_'(DCtn, Functor/Arity, clauses_rules_location_from(_, N1, _, _)), 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, _, _, _) :-
nonvar(Ref),
!,
clause(THead, TBody, Ref),
'$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)
%
% phrase/2 built-in method implementation for calls where the first argument is only known at runtime
'$lgt_phrase'(GRBody, Input, ExCtx) :-
'$lgt_execution_context'(ExCtx, Entity, Sender, This, Self, _, _),
'$lgt_check'(callable, GRBody, logtalk(phrase(GRBody, Input), ExCtx)),
'$lgt_current_object_'(This, Prefix, _, _, _, _, _, _, _, _, Flags),
'$lgt_comp_ctx'(Ctx, _, ExCtx, Entity, Sender, This, Self, Prefix, [], _, ExCtx, runtime, _, _, _),
catch(
'$lgt_dcg_body'(GRBody, S0, S, Pred, Ctx),
Error,
throw(error(Error, logtalk(phrase(GRBody, Input), ExCtx)))
),
'$lgt_compile_body'(Pred, phrase, TPred, DPred, Ctx),
Input = S0, [] = S,
( Flags /\ 512 =:= 512 ->
% object compiled in debug mode
call(DPred)
; call(TPred)
).
% '$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) :-
'$lgt_execution_context'(ExCtx, Entity, Sender, This, Self, _, _),
'$lgt_check'(callable, GRBody, logtalk(phrase(GRBody, Input, Rest), ExCtx)),
'$lgt_current_object_'(This, Prefix, _, _, _, _, _, _, _, _, Flags),
'$lgt_comp_ctx'(Ctx, _, ExCtx, Entity, Sender, This, Self, Prefix, [], _, ExCtx, runtime, _, _, _),
catch(
'$lgt_dcg_body'(GRBody, S0, S, Pred, Ctx),
Error,
throw(error(Error, logtalk(phrase(GRBody, Input, Rest), ExCtx)))
),
'$lgt_compile_body'(Pred, phrase, TPred, DPred, Ctx),
Input = S0, Rest = S,
( Flags /\ 512 =:= 512 ->
% object compiled in debug mode
call(DPred)
; call(TPred)
).
% '$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 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, SenderExCtx)))
; % 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 private built-in method
'$lgt_built_in_method'(Pred, p, _, _) ->
functor(Pred, Functor, Arity),
throw(error(permission_error(access, private_predicate, Functor/Arity), logtalk(Obj::Pred, SenderExCtx)))
; % 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 private built-in method
'$lgt_built_in_method'(Pred, p, _, _) ->
functor(Pred, Functor, Arity),
throw(error(permission_error(access, private_predicate, Functor/Arity), logtalk(Obj::Pred, SenderExCtx)))
; % 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'({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'({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'({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.debug_handler_provider#1'(_, _),
!,
'$logtalk#0.debug_handler#2'(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),
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
; 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, _)),
'$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'([], _) :-
!.
'$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_increment_compiling_warnings_counter',
'$lgt_print_message'(warning(general), 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, _) :-
'$lgt_pp_file_paths_flags_'(Basename, Directory, _, _, _),
( Kind == object ->
'$lgt_pp_referenced_object_'(Entity, _, Start-End)
; Kind == protocol ->
'$lgt_pp_referenced_protocol_'(Entity, _, Start-End)
; % Kind == category,
'$lgt_pp_referenced_category_'(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, Line-_),
'$lgt_property_location'(MainFile, File, Line, 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, Line-_),
'$lgt_property_location'(MainFile, File, Line, 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, Line-_),
'$lgt_property_location'(MainFile, File, Line, 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, Line-_),
'$lgt_property_location'(MainFile, File, Line, 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, Line-_),
'$lgt_property_location'(MainFile, File, Line, 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, Line-_),
'$lgt_updates_property_alias_non_terminal'(Dynamic, Alias, NonTerminal),
'$lgt_property_location'(MainFile, File, Line, 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_predicate_alias_'(For, Original, Alias, NonTerminalFlag, File, Line-_),
'$lgt_property_location'(MainFile, File, Line, Location),
functor(Original, OriginalFunctor, Arity),
functor(Alias, AliasFunctor, Arity),
assertz('$lgt_pp_runtime_clause_'('$lgt_entity_property_'(Entity, 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, Line),
% multifile predicate clauses defined in Entity for Other
'$lgt_property_location'(MainFile, File, Line, Location),
'$lgt_pp_number_of_clauses_rules_'(Other, Functor, Arity, Clauses, Rules),
assertz('$lgt_pp_runtime_clause_'('$lgt_predicate_property_'(Other, Functor/Arity, clauses_rules_location_from(Clauses,Rules,Location,Entity)))),
fail.
'$lgt_add_entity_predicate_properties'(Entity, MainFile) :-
'$lgt_pp_predicate_declaration_location_'(Functor, Arity, File, Line),
% local predicate clauses
'$lgt_property_location'(MainFile, File, Line, 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)))),
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,
Line is 0
; Flags is Flags2,
'$lgt_pp_predicate_definition_location_'(Functor, Arity, File, Line)
),
'$lgt_pp_number_of_clauses_rules_'(Functor, Arity, Clauses, Rules),
'$lgt_property_location'(MainFile, File, Line, 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 just the line when found on the main file
% or a compound term File-Line when found in an included file
'$lgt_property_location'(MainFile, MainFile, Line, Line) :-
!.
'$lgt_property_location'(_, File, Line, File-Line).
% '$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, -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 (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_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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines),
'$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_increment_compiling_warnings_counter',
'$lgt_pp_entity_'(Type, Entity, _),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines),
( '$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines),
( '$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),
% ensure that only the compilation context mode and the entity prefix are
% shared between different clauses but keep the current clause position
'$lgt_comp_ctx'(Ctx, _, _, _, _, _, _, Prefix, _, _, _, Mode, _, Lines, _),
'$lgt_comp_ctx'(NewCtx, _, _, _, _, _, _, Prefix, _, _, _, 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
once(retract('$lgt_pp_referenced_object_'(Module, File, Start-_))),
'$lgt_comp_ctx_lines'(Ctx, _-End),
assertz('$lgt_pp_referenced_object_'(Module, File, 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
once(retract('$lgt_pp_referenced_object_'(Module, File, Start-_))),
'$lgt_comp_ctx_lines'(Ctx, _-End),
assertz('$lgt_pp_referenced_object_'(Module, File, 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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_print_message'(warning(general), 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), Ctx) :-
'$lgt_prolog_feature'(modules, unsupported),
'$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)),
'$lgt_increment_compiling_warnings_counter',
'$lgt_pp_term_source_data_'(_, _, _, File, Lines),
'$lgt_print_message'(
warning(general),
unsupported_directive(File, Lines, use_module(FileSpec))
),
fail.
'$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), Ctx) :-
'$lgt_prolog_feature'(modules, unsupported),
'$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)),
'$lgt_increment_compiling_warnings_counter',
'$lgt_pp_term_source_data_'(_, _, _, File, Lines),
'$lgt_print_message'(
warning(general),
unsupported_directive(File, Lines, use_module(FileSpec, Imports))
),
fail.
'$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(general), 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(general), 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)
; 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
once(retract('$lgt_pp_referenced_object_'(Obj, File, Start-_))),
'$lgt_comp_ctx_lines'(Ctx, _-End),
assertz('$lgt_pp_referenced_object_'(Obj, File, 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
once(retract('$lgt_pp_referenced_protocol_'(Ptc, File, Start-_))),
'$lgt_comp_ctx_lines'(Ctx, _-End),
assertz('$lgt_pp_referenced_protocol_'(Ptc, File, 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
once(retract('$lgt_pp_referenced_category_'(Ctg, File, Start-_))),
'$lgt_comp_ctx_lines'(Ctx, _-End),
assertz('$lgt_pp_referenced_category_'(Ctg, File, 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), Ctx) :-
'$lgt_compile_uses_directive'(Aliases, Aliases, Ctx).
% uses/2 predicate directive
'$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(Aliases), Ctx) :-
'$lgt_prolog_feature'(modules, unsupported),
\+ '$lgt_pp_module_'(_),
% not compiling a module as an object
'$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)),
'$lgt_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$lgt_print_message'(
warning(general),
unsupported_directive(File, Lines, Type, Entity, use_module(Aliases))
),
fail.
'$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), Ctx) :-
'$lgt_prolog_feature'(modules, unsupported),
\+ '$lgt_pp_module_'(_),
% not compiling a module as an object
'$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)),
'$lgt_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$lgt_print_message'(
warning(general),
unsupported_directive(File, Lines, Type, Entity, use_module(Module, Imports))
),
fail.
'$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)
; % we're calling module predicates 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_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)
; % we're calling module predicates 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_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)
; % we're calling module predicates 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_'(_),
% we're compiling a module as an object; assume referenced modules are also compiled as objects
'$lgt_check'(module_identifier, Module),
'$lgt_check'(list, Exports),
'$lgt_compile_reexport_directive'(Exports, Module, Ctx).
% 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_'(_),
% make the export list public resources
'$lgt_compile_logtalk_directive'(public(Exports), Ctx).
% 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_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(reference_error(entity_identifier, 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'(_//Arity1, _//Arity2, _, _) :-
throw(domain_error({Arity1}, Arity2)).
'$lgt_compile_alias_directive_resource'(_/Arity1, _/Arity2, _, _) :-
throw(domain_error({Arity1}, 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))
).
'$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))
).
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
Directive =.. [Scope, op(Priority, Specifier, Operator)],
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
Directive =.. [Scope, op(Priority, Specifier, Operator)],
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
Directive =.. [Scope, Functor/Arity],
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
Directive =.. [Scope, Functor//Arity],
'$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::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_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, 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_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, 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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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::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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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::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)))
; '$lgt_check'(entity_identifier, Entity),
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)))
; '$lgt_check'(entity_identifier, Entity),
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, _, Prefix),
( 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, 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, _, Prefix),
( 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, 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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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),
assertz('$lgt_pp_object_alias_'(Obj, Alias, NewCtx))
).
'$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_add_referenced_object'(Obj, Ctx),
'$lgt_warn_on_alias_same_as_original'(Obj, Alias, Ctx),
( 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))
; assertz('$lgt_pp_object_alias_'(Obj, Alias, _))
)
).
'$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),
!,
( OriginalArity =:= AliasArity ->
'$lgt_warn_on_alias_same_as_original'(Original, Alias, Ctx),
'$lgt_compile_uses_directive_predicate_indicator'(OriginalFunctor, AliasFunctor, OriginalArity, Obj, Flag, Ctx)
; throw(domain_error({OriginalArity}, 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, _),
!,
( OriginalArity =:= AliasArity ->
'$lgt_warn_on_alias_same_as_original'(Original, Alias, Ctx),
'$lgt_compile_uses_directive_non_terminal_indicator'(OriginalFunctor, AliasFunctor, OriginalArity, ExtendedArity, Obj, Flag, Ctx)
; throw(domain_error({OriginalArity}, 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
% 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,
'$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_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),
assertz('$lgt_pp_module_alias_'(Module, Alias, NewCtx))
).
'$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))
; '$lgt_warn_on_alias_same_as_original'(Module, Alias, Ctx),
'$lgt_add_referenced_module'(Module, Ctx),
assertz('$lgt_pp_module_alias_'(Module, Alias, _))
).
'$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),
!,
( OriginalArity =:= AliasArity ->
'$lgt_warn_on_alias_same_as_original'(Original, Alias, Ctx),
'$lgt_compile_use_module_directive_predicate_indicator'(OriginalFunctor, AliasFunctor, OriginalArity, Module, Flag, Ctx)
; throw(domain_error({OriginalArity}, 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, _),
!,
( OriginalArity =:= AliasArity ->
'$lgt_warn_on_alias_same_as_original'(Original, Alias, Ctx),
'$lgt_compile_use_module_directive_non_terminal_indicator'(OriginalFunctor, AliasFunctor, OriginalArity, ExtendedArity, Module, Flag, Ctx)
; throw(domain_error({OriginalArity}, 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
% 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,
'$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, _)))
)
).
% auxiliary predicate for checking that original and alias are distinct
'$lgt_warn_on_alias_same_as_original'(Original, Alias, Ctx) :-
( '$lgt_variant'(Original, Alias),
'$lgt_comp_ctx_mode'(Ctx, compile(user,_,_)) ->
'$lgt_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$lgt_print_message'(
warning(general),
alias_same_as_original(File, Lines, Type, Entity, Original)
)
; true
).
% 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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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, 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, 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], 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, Parameters, Counter1, Arity)
; throw(type_error(pair, Pair))
).
'$lgt_check_entity_info_parameters'([], _, Counter, Arity) :-
!,
( Counter =:= Arity ->
true
; throw(domain_error({Arity}, Counter))
).
'$lgt_check_entity_info_parameters'(_, Parameters, _, _) :-
throw(type_error(list, Parameters)).
'$lgt_check_entity_info_parnames'([Name| Names], Parnames, Counter0, Arity) :-
!,
'$lgt_check'(atom_or_string, Name),
Counter1 is Counter0 + 1,
'$lgt_check_entity_info_parnames'(Names, Parnames, Counter1, Arity).
'$lgt_check_entity_info_parnames'([], _, Counter, Arity) :-
!,
( Counter =:= Arity ->
true
; throw(domain_error({Arity}, Counter))
).
'$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, _, Arity, arguments(Arguments)) :-
!,
'$lgt_check_predicate_info_arguments'(Arguments, Arguments, 0, Arity).
'$lgt_compile_predicate_info_directive_pair'(argnames, Argnames, _, Arity, argnames(Argnames)) :-
!,
'$lgt_check_predicate_info_argnames'(Argnames, Argnames, 0, Arity).
'$lgt_compile_predicate_info_directive_pair'(comment, Comment, _, _, comment(Comment)) :-
!,
'$lgt_check'(atom_or_string, Comment).
'$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, 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, Arity)
; throw(type_error(pair, Pair))
).
'$lgt_check_predicate_info_arguments'([], _, Counter, Arity) :-
!,
( Counter =:= Arity ->
true
; throw(domain_error({Arity}, Counter))
).
'$lgt_check_predicate_info_arguments'(_, Arguments, _, _) :-
throw(type_error(list, Arguments)).
'$lgt_check_predicate_info_argnames'([Name| Names], Arguments, Counter0, Arity) :-
!,
'$lgt_check'(atom_or_string, Name),
Counter1 is Counter0 + 1,
'$lgt_check_predicate_info_argnames'(Names, Arguments, Counter1, Arity).
'$lgt_check_predicate_info_argnames'([], _, Counter, Arity) :-
!,
( Counter =:= Arity ->
true
; throw(domain_error({Arity}, Counter))
).
'$lgt_check_predicate_info_argnames'(_, Arguments, _, _) :-
throw(type_error(list, Arguments)).
% '$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, clause, 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 and 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), 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, 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-_),
( 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, 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, Line, 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, Line))
),
assertz('$lgt_pp_number_of_clauses_rules_'(Other, Functor, Arity, Clauses, Rules)).
'$lgt_clause_number'(Other::Functor/Arity, rule, File, Line, 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, Line))
),
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, Line, Clauses) :-
% pre-compiled predicate clause head
'$lgt_clause_number'(user::Head, Kind, File, Line, Clauses).
'$lgt_clause_number'(Functor/Arity, fact, File, Line, 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, Line))
),
assertz('$lgt_pp_number_of_clauses_rules_'(Functor, Arity, Clauses, Rules)).
'$lgt_clause_number'(Functor/Arity, rule, File, Line, 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, Line))
),
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_pp_module_'(_),
\+ '$lgt_pp_implemented_protocol_'(Protocol, _, _, _, _),
'$lgt_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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'(logtalk::debug_handler_provider(NewProvider), _, _, Ctx) :-
'$lgt_check'(object_identifier, NewProvider),
'$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)),
'$logtalk#0.debug_handler_provider#1'(OldProvider, _),
functor(NewProvider, Functor, Arity),
\+ functor(OldProvider, Functor, Arity),
'$lgt_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$lgt_print_message'(
warning(general),
debug_handler_provider_already_exists(File, Lines, Type, Entity, OldProvider)
),
fail.
'$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_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),
'$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
'$lgt_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$lgt_print_message'(
warning(suspicious_calls),
suspicious_call(File, Lines, Type, Entity, {Pred}, [Pred])
),
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, This, Self, Prefix, MetaVars, MetaCallCtx, ExCtx, Mode, Stack, Lines, Term),
'$lgt_execution_context'(ExCtx, _, Sender, This, _, _, _),
'$lgt_comp_ctx'(NewCtx, Head, _, _, Sender, Sender, Self, Prefix, MetaVars, MetaCallCtx, NewExCtx, Mode, Stack, Lines, Term),
'$lgt_execution_context_this_entity'(NewExCtx, Sender, _),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$lgt_comp_ctx_head'(Ctx, Head),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$lgt_comp_ctx_head'(Ctx, Head),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$lgt_comp_ctx_head'(Ctx, Head),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$lgt_comp_ctx_head'(Ctx, Head),
'$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'(suspicious_calls, 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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$lgt_comp_ctx_head'(Ctx, Head),
'$lgt_print_message'(warning(suspicious_calls), 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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$lgt_comp_ctx_head'(Ctx, Head),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$lgt_comp_ctx_head'(Ctx, Head),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$lgt_comp_ctx_head'(Ctx, Head),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$lgt_comp_ctx_head'(Ctx, Head),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
( '$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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, Domain),
throw(domain_error(Domain, NExtraArgs)).
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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, _), _, _, _, Ctx) :-
nonvar(Key),
'$lgt_comp_ctx_mode'(Ctx, compile(_,_,_)),
\+ '$lgt_member'(Key, [
entity_identifier, entity_prefix, entity_type, entity_relation,
source, file, basename, directory,
stream, target, flags,
term, term_position, variables, parameter_variables,
variable_names, variable_names(_), singletons, singletons(_)
]),
'$lgt_source_file_context'(File, Lines),
( '$lgt_pp_entity_'(Type, Entity, _) ->
'$lgt_print_message'(warning(general), invalid_logtalk_load_context_key(File, Lines, Type, Entity, Key))
; '$lgt_print_message'(warning(general), invalid_logtalk_load_context_key(File, Lines, Key))
),
fail.
'$lgt_compile_body'(logtalk_load_context(Key, Value), _, TPred, DPred, Ctx) :-
'$lgt_comp_ctx'(Ctx, Head, _, _, _, _, _, _, _, _, ExCtx, _, _, _, _),
nonvar(Key),
nonvar(Head),
functor(Head, (:-), 1),
% compiling a directive (usually an initialization/1 directive)
logtalk_load_context(Key, Value),
% expand goal to support embedded applications where the compiled
% code may no longer be loaded using the Logtalk runtime
!,
TPred = true,
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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_exec_ctx'(Ctx, ExCtx),
TPred = '$lgt_phrase'(GRBody, Input, ExCtx).
'$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_exec_ctx'(Ctx, ExCtx),
TPred = '$lgt_phrase'(::GRBody, Input, ExCtx).
'$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_exec_ctx'(Ctx, ExCtx),
TPred = '$lgt_phrase'(Obj::GRBody, Input, ExCtx).
'$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_exec_ctx'(Ctx, ExCtx),
TPred = '$lgt_phrase'(^^GRBody, Input, ExCtx).
'$lgt_compile_body'(phrase(GRBody, Input), _, TPred, '$lgt_debug'(goal(phrase(GRBody, Input), DPred), ExCtx), Ctx) :-
!,
% the '$lgt_dcg_body'/5 predicate already checks that the grammar rule body is callable
'$lgt_dcg_body'(GRBody, S0, S, Pred, Ctx),
'$lgt_check'(list_or_partial_list, Input),
TPred = (Input = S0, [] = S, TPred0),
DPred = (Input = S0, [] = S, DPred0),
'$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx),
'$lgt_compile_body'(Pred, phrase, TPred0, DPred0, Ctx).
'$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_exec_ctx'(Ctx, ExCtx),
TPred = '$lgt_phrase'(GRBody, Input, Rest, ExCtx).
'$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_exec_ctx'(Ctx, ExCtx),
TPred = '$lgt_phrase'(::GRBody, Input, Rest, ExCtx).
'$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_exec_ctx'(Ctx, ExCtx),
TPred = '$lgt_phrase'(Obj::GRBody, Input, Rest, ExCtx).
'$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_exec_ctx'(Ctx, ExCtx),
TPred = '$lgt_phrase'(^^GRBody, Input, Rest, ExCtx).
'$lgt_compile_body'(phrase(GRBody, Input, Rest), _, TPred, '$lgt_debug'(goal(phrase(GRBody, Input, Rest), DPred), ExCtx), Ctx) :-
!,
% the '$lgt_dcg_body'/5 predicate already checks that the grammar rule body is callable
'$lgt_dcg_body'(GRBody, S0, S, Pred, Ctx),
'$lgt_check'(list_or_partial_list, Input),
'$lgt_check'(list_or_partial_list, Rest),
TPred = (Input = S0, Rest = S, TPred0),
DPred = (Input = S0, Rest = S, DPred0),
'$lgt_comp_ctx_exec_ctx'(Ctx, ExCtx),
'$lgt_compile_body'(Pred, phrase, TPred0, DPred0, Ctx).
% execution-context methods
%
% calls to these methods are compiled inline whenever possible by unifying
% the method argument with the corresponding execution context argument;
% with the exception of context/1, calls with instantiated arguments are
% not inlined as the call may be used as e.g. a condition in an if-then-else
% control construct
'$lgt_compile_body'(context(Context), _, true, '$lgt_debug'(goal(context(Context), true), ExCtx), Ctx) :-
!,
'$lgt_check'(var, Context),
'$lgt_comp_ctx_head'(Ctx, Head0),
( 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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines),
( '$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines),
( '$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines),
( '$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines),
( '$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
Closure =.. [Functor| Args],
'$lgt_append'(Args, ExtraArgs, FullArgs),
Goal =.. [Functor| FullArgs],
'$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
( '$lgt_pp_meta_predicate_'(Pred, Meta, _, _) ->
% 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),
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, _, _),
!,
'$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, _, _),
!,
'$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_'(Pred, Meta, _, _),
% local user-defined meta-predicate
Pred =.. [Functor| Args],
Meta =.. [Functor| MArgs],
'$lgt_compile_static_binding_meta_arguments'(Args, MArgs, 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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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)).
% 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'(@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) :-
( 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),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
( call(Goal) ->
'$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_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,_,_), Call, TCall, 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),
Call \= HeadCopy,
% not a recursive call which can originate from a predicate with a single clause
\+ '$lgt_pp_dynamic_'(Call, _, _),
\+ '$lgt_pp_multifile_'(Call, _, _),
% not a dynamic or multifile predicate
\+ '$lgt_pp_entity_term_'(fact(TCall, _), _, _),
\+ '$lgt_pp_entity_term_'(srule(TCall, _, _), _, _),
\+ '$lgt_pp_entity_term_'(dfact(TCall, _, _), _, _),
\+ '$lgt_pp_entity_term_'(dsrule(TCall, _, _, _), _, _),
% not a yet to be compiled user-defined fact or rule
\+ '$lgt_pp_final_entity_term_'(TCall, _),
\+ '$lgt_pp_final_entity_term_'((TCall :- _), _),
% not an already compiled user-defined fact or rule
\+ '$lgt_pp_entity_aux_clause_'(fact(TCall, _)),
\+ '$lgt_pp_entity_aux_clause_'(srule(TCall, _, _)),
\+ '$lgt_pp_entity_aux_clause_'(dfact(TCall, _, _)),
\+ '$lgt_pp_entity_aux_clause_'(dsrule(TCall, _, _, _)),
% not a yet to be compiled auxiliary fact or rule
\+ '$lgt_pp_final_entity_aux_clause_'(TCall),
\+ '$lgt_pp_final_entity_aux_clause_'((TCall :- _)) ->
% not an already compiled auxiliary fact or rule
'$lgt_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$lgt_print_message'(
warning(trivial_goal_fails),
no_matching_clause_for_goal(File, Lines, Type, Entity, Call)
)
; 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))))
; 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
).
'$lgt_compile_prolog_meta_argument'((*), Arg, _, _, Arg, Arg).
'$lgt_compile_prolog_meta_argument'((0), Arg, Caller, Ctx, TArg, DArg) :-
% goal
'$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
).
'$lgt_compile_prolog_meta_argument'((^), Arg, Caller, Ctx, TArg, DArg) :-
% existentially-quantified goal
( 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)
).
'$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).
'$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
).
'$lgt_compile_prolog_meta_argument'((//), Args, Caller, Ctx, TArgs, DArgs) :-
'$lgt_compile_prolog_meta_argument'((/), Args, Caller, Ctx, TArgs, DArgs).
'$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).
'$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, _, _) ->
Goal = Object::Original
; '$lgt_pp_use_module_predicate_'(Module, Original, Alias, Ctx, _, _) ->
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, -compound)
%
% 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, Domain) :-
!,
'$lgt_not_same_meta_arg_extra_args'(MetaArgs, MetaVars, Closure, ExtraArgs, Domain).
'$lgt_not_same_meta_arg_extra_args'([(::)| MetaArgs], MetaVars, Closure, ExtraArgs, Domain) :-
!,
'$lgt_not_same_meta_arg_extra_args'(MetaArgs, MetaVars, Closure, ExtraArgs, Domain).
'$lgt_not_same_meta_arg_extra_args'([0| MetaArgs], MetaVars, Closure, ExtraArgs, Domain) :-
!,
'$lgt_not_same_meta_arg_extra_args'(MetaArgs, MetaVars, Closure, ExtraArgs, Domain).
'$lgt_not_same_meta_arg_extra_args'([MetaArg| _], [MetaVar| _], Closure, ExtraArgs, Domain) :-
MetaVar == Closure,
!,
integer(MetaArg),
MetaArg =\= ExtraArgs,
Domain = {MetaArg}.
'$lgt_not_same_meta_arg_extra_args'([_| MetaArgs], [_| MetaVars], Closure, ExtraArgs, Domain) :-
'$lgt_not_same_meta_arg_extra_args'(MetaArgs, MetaVars, Closure, ExtraArgs, Domain).
% '$lgt_same_number_of_closure_extra_args'(@list, @list, @list, @list)
%
% 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) :-
( 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)
; throw(domain_error({HeadMetaArg}, PredMetaArg))
)
; '$lgt_same_number_of_closure_extra_args'(PredArgs, PredMetaArgs, HeadArgs, HeadMetaArgs)
).
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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 of 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(_,_,_)),
once(logtalk_linter_hook(Obj::Pred, Flag, File, Lines, Type, Entity, Warning)),
nonvar(Flag),
'$lgt_valid_flag'(Flag),
'$lgt_compiler_flag'(Flag, warning),
'$lgt_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_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_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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines),
'$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 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 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 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 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 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) :-
!,
'$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 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 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 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 (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 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_increment_compiling_warnings_counter',
( '$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_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, Line-Line, Type, Entity, Name/Arity)
; '$lgt_name_with_digits_in_the_middle'(Chars),
Warning = predicate_name_with_digits_in_the_middle(File, Line-Line, Type, Entity, Name/Arity)
),
'$lgt_increment_compiling_warnings_counter',
( '$lgt_pp_predicate_declaration_location_'(Name, Arity, File, Line) ->
true
; '$lgt_source_file_context'(File, _),
Line = -1
),
'$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, Line-Line, Type, Entity, Name//Arity)
; '$lgt_name_with_digits_in_the_middle'(Chars),
Warning = non_terminal_name_with_digits_in_the_middle(File, Line-Line, Type, Entity, Name//Arity)
),
'$lgt_increment_compiling_warnings_counter',
( '$lgt_pp_predicate_declaration_location_'(Name, ExtArity, File, Line) ->
true
; '$lgt_source_file_context'(File, _),
Line = -1
),
'$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, Line-Line, Type, Entity, Name/Arity)
; '$lgt_name_with_digits_in_the_middle'(Chars),
Warning = predicate_name_with_digits_in_the_middle(File, Line-Line, Type, Entity, Name/Arity)
),
'$lgt_increment_compiling_warnings_counter',
( '$lgt_pp_predicate_definition_location_'(Name, Arity, File, Line) ->
true
; '$lgt_source_file_context'(File, _),
Line = -1
),
'$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, Line-Line, Type, Entity, Name//Arity)
; '$lgt_name_with_digits_in_the_middle'(Chars),
Warning = non_terminal_name_with_digits_in_the_middle(File, Line-Line, Type, Entity, Name//Arity)
),
'$lgt_increment_compiling_warnings_counter',
( '$lgt_pp_predicate_definition_location_'(Name, ExtArity, File, Line) ->
true
; '$lgt_source_file_context'(File, _),
Line = -1
),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, _, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, _, Type, Entity),
'$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_increment_compiling_warnings_counter',
( '$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_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_increment_compiling_warnings_counter',
( '$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_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_increment_compiling_warnings_counter',
( '$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_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
; % generate a catchall clause for static protocols as the predicate
% implementing the predicate declaration table is 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
; % generate a catchall clause for static categories as the predicate
% implementing the predicate declaration table is 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
; % generate a catchall clause for static objects as the predicate
% implementing the predicate declaration table is 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
; % generate a catchall clause for static objects as the predicate
% implementing the predicate definition table is 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
retract('$lgt_pp_entity_term_'(Term, SourceData, _)),
( SourceData = sd(_, _, OriginalFile, OriginalLines),
'$lgt_pp_entity_'(Type, Entity, _),
'$lgt_clause_from_term'(Term, Clause, Template, OriginalTerm),
'$lgt_pp_entity_term_'(Template, sd(_, _, File, Lines), _),
'$lgt_clause_from_term'(Template, Duplicate, _, _),
'$lgt_variant'(Clause, Duplicate) ->
'$lgt_increment_compiling_warnings_counter',
( OriginalTerm = (_ --> _) ->
'$lgt_print_message'(
warning(duplicated_clauses),
duplicated_grammar_rule(File, Lines, Type, Entity, OriginalTerm, OriginalFile, OriginalLines)
)
; '$lgt_print_message'(
warning(duplicated_clauses),
duplicated_clause(File, Lines, Type, Entity, Duplicate, 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_clause_from_term'(srule(_,Body,Ctx), (Head:-Body), srule(_,_,_), Term) :-
'$lgt_comp_ctx'(Ctx, Head, _, _, _, _, _, _, _, _, _, _, _, _, Term).
'$lgt_clause_from_term'(dsrule(_,_,Body,Ctx), (Head:-Body), dsrule(_,_,_,_), Term) :-
'$lgt_comp_ctx'(Ctx, Head, _, _, _, _, _, _, _, _, _, _, _, _, Term).
'$lgt_clause_from_term'(drule(_,_,Body,Ctx), (Head:-Body), drule(_,_,_,_), Term) :-
'$lgt_comp_ctx'(Ctx, Head, _, _, _, _, _, _, _, _, _, _, _, _, Term).
'$lgt_clause_from_term'(ddrule(_,_,_,Body,Ctx), (Head:-Body), ddrule(_,_,_,_,_), Term) :-
'$lgt_comp_ctx'(Ctx, Head, _, _, _, _, _, _, _, _, _, _, _, _, Term).
'$lgt_clause_from_term'(fact(_,Ctx), Fact, fact(_,_), Term) :-
'$lgt_comp_ctx'(Ctx, Fact, _, _, _, _, _, _, _, _, _, _, _, _, Term).
'$lgt_clause_from_term'(dfact(_,_,Ctx), Fact, dfact(_,_,_), Term) :-
'$lgt_comp_ctx'(Ctx, Fact, _, _, _, _, _, _, _, _, _, _, _, _, Term).
% '$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, File, Lines),
% declared dynamic predicate 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, Functor/Arity)
),
fail.
% reports missing scope directives for multifile predicates
'$lgt_report_missing_directives'(Type, Entity) :-
'$lgt_pp_multifile_'(Head, 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, Functor/Arity)
),
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
; '$lgt_pp_predicate_info_'(Functor/Arity, _, File, Lines),
Directive = info
),
% 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'(assert(_), p(p(p)), assert((::)), 1). % just for compatibility with old code!
'$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'(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'(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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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_increment_compiling_warnings_counter',
'$lgt_source_file_context'(File, Lines, Type, Entity),
'$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(_, _)).
% '$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'((Entity::NonTerminal, Terminals --> GRBody), (Entity::Head :- Body), Ctx) :-
!,
'$lgt_check'(object_identifier, Entity),
'$lgt_dcg_rule'((NonTerminal, Terminals --> GRBody), (Head :- Body), Ctx).
'$lgt_dcg_rule'((':'(Module, NonTerminal), Terminals --> GRBody), (':'(Module, Head) :- Body), Ctx) :-
!,
'$lgt_check'(module_identifier, Module),
'$lgt_dcg_rule'((NonTerminal, Terminals --> GRBody), (Head :- Body), Ctx).
'$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'((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'((Entity::NonTerminal --> GRBody), (Entity::Head :- Body), Ctx) :-
!,
'$lgt_check'(object_identifier, Entity),
'$lgt_dcg_rule'((NonTerminal --> GRBody), (Head :- Body), Ctx).
'$lgt_dcg_rule'((':'(Module, NonTerminal) --> GRBody), (':'(Module, Head) :- Body), Ctx) :-
!,
'$lgt_check'(module_identifier, Module),
'$lgt_dcg_rule'((NonTerminal --> GRBody), (Head :- Body), Ctx).
'$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'((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'(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'(':'(Module, RGoal), S0, S, CGoal, _) :-
!,
( callable(RGoal) ->
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_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_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_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'(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 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 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
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% '$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
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% '$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
; throw(existence_error(file, File))
),
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'(SourceFile, Stream, TermError)
),
catch(
'$lgt_check_for_encoding_directive'(Term, SourceFile, Lines, Stream, NewStream, [], _),
FirstTermError,
'$lgt_read_file_to_terms_error_handler'(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'(SourceFile, NewStream, TermError)
),
'$lgt_close'(NewStream).
'$lgt_read_file_to_terms_error_handler'(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),
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, -nonvar)
%
% 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
'$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 Prolog compiler 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 compilers supporting multi-threading programming
% (currently we use integers for the tag counter, which impose a limitation on
% the maximum number of tags on backend Prolog compilers 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!
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%