diogo/yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
This repository has been archived on 2023-08-20. You can view files and clone it, but cannot push or open issues or pull requests.
5d09011015
yap-6.3/library/logtalk/logtalk.pl
pmoura a920e364c3 Logtalk 2.22.4 files. 
git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@1232 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
2005-01-13 12:22:42 +00:00

8570 lines
244 KiB
Prolog
Raw Blame History

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Logtalk - Object oriented extension to Prolog
% Release 2.22.4
%
% Copyright (c) 1998-2005 Paulo Moura. All Rights Reserved.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% operators
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% message sending operators
:- op(600, xfy, ::). % send to object
:- op(600, fy, ::). % send to self
:- op(600, fy, ^^). % super call
% mode operators
:- op(200, fy, +). % input argument (instantiated)
:- op(200, fy, ?). % input/output argument
:- op(200, fy, @). % input argument (not modified by the call)
:- op(200, fy, -). % output argument (not instantiated)
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% runtime directives
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% tables of defined events and monitors
:- dynamic('$lgt_before_'/5). % '$lgt_before_'(Obj, Msg, Sender, Monitor, Call)
:- dynamic('$lgt_after_'/5). % '$lgt_after_'(Obj, Msg, Sender, Monitor, Call)
% tables of loaded entities and respective relationships
:- dynamic('$lgt_current_protocol_'/3). % '$lgt_current_protocol_'(Ptc, Prefix, Type)
:- dynamic('$lgt_current_category_'/3). % '$lgt_current_category_'(Ctg, Prefix, Type)
:- dynamic('$lgt_current_object_'/6). % '$lgt_current_object_'(Obj, Prefix, Dcl, Def, Super, Type)
:- dynamic('$lgt_implements_protocol_'/3). % '$lgt_implements_protocol_'(ObjOrCtg, Ptc, Scope)
:- dynamic('$lgt_imports_category_'/3). % '$lgt_imports_category_'(ObjOrCtg, Ctg, Scope)
:- dynamic('$lgt_instantiates_class_'/3). % '$lgt_instantiates_class_'(Instance, Class, Scope)
:- dynamic('$lgt_specializes_class_'/3). % '$lgt_specializes_class_'(Class, Superclass, Scope)
:- dynamic('$lgt_extends_protocol_'/3). % '$lgt_extends_protocol_'(Ptc1, Ptc2, Scope)
:- dynamic('$lgt_extends_object_'/3). % '$lgt_extends_object_'(Prototype, Parent, Scope)
% debugger status and tables
:- dynamic('$lgt_debugging_'/1). % '$lgt_debugging_'(Entity)
:- dynamic('$lgt_dbg_debugging_'/0). % '$lgt_dbg_debugging_'
:- dynamic('$lgt_dbg_tracing_'/0). % '$lgt_dbg_tracing_'
:- dynamic('$lgt_dbg_skipping_'/0). % '$lgt_dbg_skipping_'
:- dynamic('$lgt_dbg_spying_'/1). % '$lgt_dbg_spying_'(Functor/Arity)
:- dynamic('$lgt_dbg_spying_'/4). % '$lgt_dbg_spying_'(Sender, This, Self, Goal)
:- dynamic('$lgt_dbg_leashing_'/1). % '$lgt_dbg_leashing_'(Port)
% runtime flags
:- dynamic('$lgt_current_flag_'/2). % '$lgt_current_flag_'(Option, Value)
% lookup caches for messages to an object, messages to self, and super calls
:- dynamic('$lgt_obj_lookup_cache_'/4). % '$lgt_obj_lookup_cache_'(Obj, Pred, Sender, Call)
:- dynamic('$lgt_self_lookup_cache_'/4). % '$lgt_self_lookup_cache_'(Obj, Pred, Sender, Call)
:- dynamic('$lgt_super_lookup_cache_'/5). % '$lgt_super_lookup_cache_'(Self, Pred, This, Sender, Call)
% table of library paths
:- dynamic(logtalk_library_path/2). % logtalk_library_path(Library, Path)
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% pre-processor directives (used for entity compilation)
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- dynamic('$lgt_pp_compiler_option_'/2). % '$lgt_pp_compiler_option_'(Option, Value)
:- dynamic('$lgt_pp_dcl_'/1). % '$lgt_pp_dcl_'(Clause)
:- dynamic('$lgt_pp_ddcl_'/1). % '$lgt_pp_ddcl_'(Clause)
:- dynamic('$lgt_pp_def_'/1). % '$lgt_pp_def_'(Clause)
:- dynamic('$lgt_pp_ddef_'/1). % '$lgt_pp_ddef_'(Clause)
:- dynamic('$lgt_pp_super_'/1). % '$lgt_pp_super_'(Clause)
:- dynamic('$lgt_pp_dynamic_'/1). % '$lgt_pp_dynamic_'(Functor/Arity)
:- dynamic('$lgt_pp_discontiguous_'/1). % '$lgt_pp_discontiguous_'(Functor/Arity)
:- dynamic('$lgt_pp_mode_'/2). % '$lgt_pp_mode_'(Mode, Determinism)
:- dynamic('$lgt_pp_public_'/1). % '$lgt_pp_public_'(Functor/Arity)
:- dynamic('$lgt_pp_protected_'/1). % '$lgt_pp_protected_'(Functor/Arity)
:- dynamic('$lgt_pp_private_'/1). % '$lgt_pp_private_'(Functor/Arity)
:- dynamic('$lgt_pp_metapredicate_'/1). % '$lgt_pp_metapredicate_'(Pred)
:- dynamic('$lgt_pp_alias_'/3). % '$lgt_pp_alias_'(Entity, Pred1, Pred2)
:- dynamic('$lgt_pp_non_terminal_'/3). % '$lgt_pp_non_terminal_'(Functor, Args, Arity)
:- dynamic('$lgt_pp_object_'/10). % '$lgt_pp_object_'(Obj, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Mode)
:- dynamic('$lgt_pp_category_'/5). % '$lgt_pp_category_'(Ctg, Prefix, Dcl, Def, Mode)
:- dynamic('$lgt_pp_protocol_'/4). % '$lgt_pp_protocol_'(Ptc, Prefix, Dcl, Mode)
:- dynamic('$lgt_pp_uses_'/1). % '$lgt_pp_uses_'(Obj)
:- dynamic('$lgt_pp_uses_'/2). % '$lgt_pp_uses_'(Obj, Predicate)
:- dynamic('$lgt_pp_calls_'/1). % '$lgt_pp_calls_'(Entity)
:- dynamic('$lgt_pp_info_'/1). % '$lgt_pp_info_'(List)
:- dynamic('$lgt_pp_info_'/2). % '$lgt_pp_info_'(Functor/Arity, List)
:- dynamic('$lgt_pp_implemented_protocol_'/4). % '$lgt_pp_implemented_protocol_'(Ptc, Prefix, Dcl, Scope)
:- dynamic('$lgt_pp_imported_category_'/5). % '$lgt_pp_imported_category_'(Ctg, Prefix, Dcl, Def, Scope)
:- dynamic('$lgt_pp_extended_object_'/10). % '$lgt_pp_extended_object_'(Parent, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Scope)
:- dynamic('$lgt_pp_instantiated_class_'/10). % '$lgt_pp_instantiated_class_'(Class, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Scope)
:- dynamic('$lgt_pp_specialized_class_'/10). % '$lgt_pp_specialized_class_'(Superclass, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Scope)
:- dynamic('$lgt_pp_extended_protocol_'/4). % '$lgt_pp_extended_protocol_'(Ptc, Prefix, Dcl, Scope)
:- dynamic('$lgt_pp_entity_init_'/1). % '$lgt_pp_entity_init_'(Goal)
:- dynamic('$lgt_pp_fentity_init_'/1). % '$lgt_pp_fentity_init_'(Goal)
:- dynamic('$lgt_pp_redefined_built_in_'/3). % '$lgt_pp_redefined_built_in_'(Head, Context, THead)
:- dynamic('$lgt_pp_directive_'/1). % '$lgt_pp_directive_'(Dir)
:- dynamic('$lgt_pp_rclause_'/1). % '$lgt_pp_rclause_'(Clause)
:- dynamic('$lgt_pp_eclause_'/1). % '$lgt_pp_eclause_'(Clause)
:- dynamic('$lgt_pp_feclause_'/1). % '$lgt_pp_feclause_'(Clause)
:- dynamic('$lgt_pp_defs_pred_'/1). % '$lgt_pp_defs_pred_'(Functor/Arity)
:- dynamic('$lgt_pp_calls_pred_'/1). % '$lgt_pp_calls_pred_'(Functor/Arity)
:- dynamic('$lgt_pp_referenced_object_'/1). % '$lgt_pp_referenced_object_'(Object)
:- dynamic('$lgt_pp_referenced_protocol_'/1). % '$lgt_pp_referenced_protocol_'(Protocol)
:- dynamic('$lgt_pp_referenced_category_'/1). % '$lgt_pp_referenced_category_'(Category)
:- dynamic('$lgt_pp_global_op_'/3). % '$lgt_pp_global_op_'(Priority, Specifier, Operator)
:- dynamic('$lgt_pp_local_op_'/3). % '$lgt_pp_local_op_'(Priority, Specifier, Operator)
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% top level runtime predicate for message sending: ::/2
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Obj::Pred :-
'$lgt_context'(Ctx, user, user, Obj, '$lgt_po_user0_', []),
'$lgt_tr_msg'(Pred, Obj, Call, Ctx),
(('$lgt_dbg_debugging_', '$lgt_debugging_'(Obj)) ->
catch(
'$lgt_dbg_goal'(Obj::Pred, Call, Ctx),
error(logtalk_debugger_aborted),
(write('Debugging session aborted by user. Debugger still on.'), nl, fail))
;
call(Call)).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% built-in predicates
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% current_object(?object_identifier)
current_object(Obj) :-
nonvar(Obj),
\+ callable(Obj),
throw(error(type_error(object_identifier, Obj), current_object(Obj))).
current_object(Obj) :-
'$lgt_current_object_'(Obj, _, _, _, _, _).
% current_protocol(?protocol_identifier)
current_protocol(Ptc) :-
nonvar(Ptc),
\+ atom(Ptc),
throw(error(type_error(protocol_identifier, Ptc), current_protocol(Ptc))).
current_protocol(Ptc) :-
'$lgt_current_protocol_'(Ptc, _, _).
% current_category(?category_identifier)
current_category(Ctg) :-
nonvar(Ctg),
\+ atom(Ctg),
throw(error(type_error(category_identifier, Ctg), current_category(Ctg))).
current_category(Ctg) :-
'$lgt_current_category_'(Ctg, _, _).
% object_property(?object_identifier, ?object_property)
object_property(Obj, Prop) :-
nonvar(Obj),
\+ callable(Obj),
throw(error(type_error(object_identifier, Obj), object_property(Obj, Prop))).
object_property(Obj, Prop) :-
nonvar(Prop),
\+ '$lgt_member'(Prop, [(dynamic), static, built_in]),
throw(error(domain_error(object_property, Prop), object_property(Obj, Prop))).
object_property(user, built_in).
object_property(debugger, built_in).
object_property(Obj, Prop) :-
'$lgt_current_object_'(Obj, _, _, _, _, Prop).
% category_property(?category_identifier, ?category_property)
category_property(Ctg, Prop) :-
nonvar(Ctg),
\+ atom(Ctg),
throw(error(type_error(category_identifier, Ctg), category_property(Ctg, Prop))).
category_property(Ctg, Prop) :-
nonvar(Prop),
\+ '$lgt_member'(Prop, [(dynamic), static, built_in]),
throw(error(domain_error(category_property, Prop), category_property(Ctg, Prop))).
category_property(Ctg, Prop) :-
'$lgt_current_category_'(Ctg, _, Prop).
% protocol_property(?protocol_identifier, ?protocol_property)
protocol_property(Ptc, Prop) :-
nonvar(Ptc),
\+ atom(Ptc),
throw(error(type_error(protocol_identifier, Ptc), protocol_property(Ptc, Prop))).
protocol_property(Ptc, Prop) :-
nonvar(Prop),
\+ '$lgt_member'(Prop, [(dynamic), static, built_in]),
throw(error(domain_error(protocol_property, Prop), protocol_property(Ptc, Prop))).
protocol_property(Ptc, Prop) :-
'$lgt_current_protocol_'(Ptc, _, Prop).
% create_object(+object_identifier, +list, +list, +list)
create_object(Obj, Rels, Dirs, Clauses) :-
(var(Obj); var(Rels); var(Dirs); var(Clauses)),
throw(error(instantiation_error, create_object(Obj, Rels, Dirs, Clauses))).
create_object(Obj, Rels, Dirs, Clauses) :-
\+ callable(Obj),
throw(error(type_error(object_identifier, Obj), create_object(Obj, Rels, Dirs, Clauses))).
create_object(Obj, Rels, Dirs, Clauses) :-
'$lgt_current_object_'(Obj, _, _, _, _, _),
throw(error(permission_error(replace, object, Obj), create_object(Obj, Rels, Dirs, Clauses))).
create_object(Obj, Rels, Dirs, Clauses) :-
'$lgt_current_category_'(Obj, _, _),
throw(error(permission_error(replace, category, Obj), create_object(Obj, Rels, Dirs, Clauses))).
create_object(Obj, Rels, Dirs, Clauses) :-
'$lgt_current_protocol_'(Obj, _, _),
throw(error(permission_error(replace, protocol, Obj), create_object(Obj, Rels, Dirs, Clauses))).
create_object(Obj, Rels, Dirs, Clauses) :-
\+ '$lgt_proper_list'(Rels),
throw(error(type_error(list, Rels), create_object(Obj, Rels, Dirs, Clauses))).
create_object(Obj, Rels, Dirs, Clauses) :-
\+ '$lgt_proper_list'(Dirs),
throw(error(type_error(list, Dirs), create_object(Obj, Rels, Dirs, Clauses))).
create_object(Obj, Rels, Dirs, Clauses) :-
\+ '$lgt_proper_list'(Clauses),
throw(error(type_error(list, Clauses), create_object(Obj, Rels, Dirs, Clauses))).
create_object(Obj, Rels, Dirs, Clauses) :-
'$lgt_clean_pp_clauses',
'$lgt_tr_object_id'(Obj, (dynamic)),
'$lgt_tr_object_relations'(Rels, Obj),
'$lgt_tr_directives'(Dirs),
'$lgt_tr_clauses'(Clauses),
'$lgt_fix_redef_built_ins',
'$lgt_gen_object_clauses',
'$lgt_gen_object_directives',
'$lgt_assert_tr_entity'.
% create_category(+category_identifier, +list, +list, +list)
create_category(Ctg, Rels, Dirs, Clauses) :-
(var(Ctg); var(Rels); var(Dirs); var(Clauses)),
throw(error(instantiation_error, create_category(Ctg, Rels, Dirs, Clauses))).
create_category(Ctg, Rels, Dirs, Clauses) :-
\+ atom(Ctg),
throw(error(type_error(category_identifier, Ctg), create_category(Ctg, Rels, Dirs, Clauses))).
create_category(Ctg, Rels, Dirs, Clauses) :-
'$lgt_current_category_'(Ctg, _, _),
throw(error(permission_error(replace, category, Ctg), create_category(Ctg, Rels, Dirs, Clauses))).
create_category(Ctg, Rels, Dirs, Clauses) :-
'$lgt_current_object_'(Ctg, _, _, _, _, _),
throw(error(permission_error(replace, object, Ctg), create_category(Ctg, Rels, Dirs, Clauses))).
create_category(Ctg, Rels, Dirs, Clauses) :-
'$lgt_current_protocol_'(Ctg, _, _),
throw(error(permission_error(replace, protocol, Ctg), create_category(Ctg, Rels, Dirs, Clauses))).
create_category(Ctg, Rels, Dirs, Clauses) :-
\+ '$lgt_proper_list'(Rels),
throw(error(type_error(list, Rels), create_category(Ctg, Rels, Dirs, Clauses))).
create_category(Ctg, Rels, Dirs, Clauses) :-
\+ '$lgt_proper_list'(Dirs),
throw(error(type_error(list, Dirs), create_category(Ctg, Rels, Dirs, Clauses))).
create_category(Ctg, Rels, Dirs, Clauses) :-
\+ '$lgt_proper_list'(Clauses),
throw(error(type_error(list, Clauses), create_category(Ctg, Rels, Dirs, Clauses))).
create_category(Ctg, Rels, Dirs, Clauses) :-
'$lgt_clean_pp_clauses',
'$lgt_tr_category_id'(Ctg, (dynamic)),
'$lgt_tr_category_relations'(Rels, Ctg),
'$lgt_tr_directives'(Dirs),
'$lgt_tr_clauses'(Clauses),
'$lgt_fix_redef_built_ins',
'$lgt_gen_category_clauses',
'$lgt_gen_category_directives',
'$lgt_assert_tr_entity'.
% create_protocol(+protocol_identifier, +list, +list)
create_protocol(Ptc, Rels, Dirs) :-
(var(Ptc); var(Rels); var(Dirs)),
throw(error(instantiation_error, create_protocol(Ptc, Rels, Dirs))).
create_protocol(Ptc, Rels, Dirs) :-
\+ atom(Ptc),
throw(error(type_error(protocol_identifier, Ptc), create_protocol(Ptc, Rels, Dirs))).
create_protocol(Ptc, Rels, Dirs) :-
'$lgt_current_protocol_'(Ptc, _, _),
throw(error(permission_error(replace, protocol, Ptc), create_protocol(Ptc, Rels, Dirs))).
create_protocol(Ptc, Rels, Dirs) :-
'$lgt_current_object_'(Ptc, _, _, _, _, _),
throw(error(permission_error(replace, object, Ptc), create_protocol(Ptc, Rels, Dirs))).
create_protocol(Ptc, Rels, Dirs) :-
'$lgt_current_category_'(Ptc, _, _),
throw(error(permission_error(replace, category, Ptc), create_protocol(Ptc, Rels, Dirs))).
create_protocol(Ptc, Rels, Dirs) :-
\+ '$lgt_proper_list'(Rels),
throw(error(type_error(list, Rels), create_protocol(Ptc, Rels, Dirs))).
create_protocol(Ptc, Rels, Dirs) :-
\+ '$lgt_proper_list'(Dirs),
throw(error(type_error(list, Dirs), create_protocol(Ptc, Rels, Dirs))).
create_protocol(Ptc, Rels, Dirs) :-
'$lgt_clean_pp_clauses',
'$lgt_tr_protocol_id'(Ptc, (dynamic)),
'$lgt_tr_protocol_relations'(Rels, Ptc),
'$lgt_tr_directives'(Dirs),
'$lgt_gen_protocol_clauses',
'$lgt_gen_protocol_directives',
'$lgt_assert_tr_entity'.
% abolish_object(@object_identifier)
abolish_object(Obj) :-
var(Obj),
throw(error(instantiation_error, abolish_object(Obj))).
abolish_object(Obj) :-
\+ callable(Obj),
throw(error(type_error(object_identifier, Obj), abolish_object(Obj))).
abolish_object(Obj) :-
'$lgt_current_object_'(Obj, Prefix, _, _, _, Type) ->
(Type = (dynamic) ->
'$lgt_call'(Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef),
'$lgt_abolish_entity_predicates'(Def),
'$lgt_abolish_entity_predicates'(DDef),
abolish(Dcl/4),
abolish(Dcl/6),
abolish(Def/5),
abolish(Def/6),
abolish(Super/6),
abolish(IDcl/6),
abolish(IDef/6),
abolish(DDcl/2),
abolish(DDef/5),
abolish(Prefix/7),
retractall('$lgt_current_object_'(Obj, _, _, _, _, _)),
retractall('$lgt_extends_object_'(Obj, _, _)),
retractall('$lgt_instantiates_class_'(Obj, _, _)),
retractall('$lgt_specializes_class_'(Obj, _, _)),
retractall('$lgt_implements_protocol_'(Obj, _, _)),
retractall('$lgt_imports_category_'(Obj, _, _)),
retractall('$lgt_debugging_'(Obj)),
'$lgt_clean_lookup_caches'
;
throw(error(permission_error(modify, static_object, Obj), abolish_object(Obj))))
;
throw(error(existence_error(object, Obj), abolish_object(Obj))).
% abolish_category(@category_identifier)
abolish_category(Ctg) :-
var(Ctg),
throw(error(instantiation_error, abolish_category(Ctg))).
abolish_category(Ctg) :-
\+ atom(Ctg),
throw(error(type_error(category_identifier, Ctg), abolish_category(Ctg))).
abolish_category(Ctg) :-
'$lgt_current_category_'(Ctg, Prefix, Type) ->
(Type = (dynamic) ->
'$lgt_call'(Prefix, Dcl, Def),
'$lgt_abolish_entity_predicates'(Def),
abolish(Dcl/4),
abolish(Dcl/5),
abolish(Def/5),
abolish(Prefix/2),
retractall('$lgt_current_category_'(Ctg, _, _)),
retractall('$lgt_imports_category_'(Ctg, _, _)),
retractall('$lgt_implements_protocol_'(Ctg, _, _)),
'$lgt_clean_lookup_caches'
;
throw(error(permission_error(modify, static_category, Ctg), abolish_category(Ctg))))
;
throw(error(existence_error(category, Ctg), abolish_category(Ctg))).
% abolish_protocol(@protocol_identifier)
abolish_protocol(Ptc) :-
var(Ptc),
throw(error(instantiation_error, abolish_protocol(Ptc))).
abolish_protocol(Ptc) :-
\+ atom(Ptc),
throw(error(type_error(protocol_identifier, Ptc), abolish_protocol(Ptc))).
abolish_protocol(Ptc) :-
'$lgt_current_protocol_'(Ptc, Prefix, Type) ->
(Type = (dynamic) ->
'$lgt_call'(Prefix, Dcl),
abolish(Dcl/4),
abolish(Dcl/5),
abolish(Prefix/1),
retractall('$lgt_current_protocol_'(Ptc, _, _)),
retractall('$lgt_extends_protocol_'(Ptc, _, _)),
'$lgt_clean_lookup_caches'
;
throw(error(permission_error(modify, static_protocol, Ptc), abolish_protocol(Ptc))))
;
throw(error(existence_error(protocol, Ptc), abolish_protocol(Ptc))).
% '$lgt_abolish_entity_predicates'(+atom)
'$lgt_abolish_entity_predicates'(Def) :-
'$lgt_call'(Def, _, _, _, _, Pred),
functor(Pred, Functor, Arity),
abolish(Functor/Arity),
fail.
'$lgt_abolish_entity_predicates'(_).
% implements_protocol(?object_identifier, ?protocol_identifier)
% implements_protocol(?category_identifier, ?protocol_identifier)
implements_protocol(ObjOrCtg, Ptc) :-
catch(
implements_protocol(ObjOrCtg, Ptc, _),
error(Error, _),
throw(error(Error, implements_protocol(ObjOrCtg, Ptc)))).
% implements_protocol(?object_identifier, ?protocol_identifier, ?atom)
% implements_protocol(?category_identifier, ?protocol_identifier, ?atom)
implements_protocol(ObjOrCtg, Ptc, Scope) :-
nonvar(ObjOrCtg),
\+ callable(ObjOrCtg),
throw(error(type_error(object_identifier, ObjOrCtg), implements_protocol(ObjOrCtg, Ptc, Scope))).
implements_protocol(ObjOrCtg, Ptc, Scope) :-
nonvar(Ptc),
\+ atom(Ptc),
throw(error(type_error(protocol_identifier, Ptc), implements_protocol(ObjOrCtg, Ptc, Scope))).
implements_protocol(ObjOrCtg, Ptc, Scope) :-
nonvar(Scope),
\+ '$lgt_member'(Scope, [(public), protected, private]),
throw(error(type_error(scope, Scope), implements_protocol(ObjOrCtg, Ptc, Scope))).
implements_protocol(ObjOrCtg, Ptc, Scope) :-
'$lgt_implements_protocol_'(ObjOrCtg, Ptc, Scope).
% imports_category(?object_identifier, ?category_identifier)
% imports_category(?category_identifier, ?category_identifier)
imports_category(ObjOrCtg, Ctg) :-
catch(
imports_category(ObjOrCtg, Ctg, _),
error(Error, _),
throw(error(Error, imports_category(ObjOrCtg, Ctg)))).
% imports_category(?object_identifier, ?category_identifier, ?atom)
% imports_category(?category_identifier, ?category_identifier, ?atom)
imports_category(ObjOrCtg, Ctg, Scope) :-
nonvar(ObjOrCtg),
\+ callable(ObjOrCtg),
throw(error(type_error(object_identifier, ObjOrCtg), imports_category(ObjOrCtg, Ctg, Scope))).
imports_category(ObjOrCtg, Ctg, Scope) :-
nonvar(Ctg),
\+ atom(Ctg),
throw(error(type_error(category_identifier, Ctg), imports_category(ObjOrCtg, Ctg, Scope))).
imports_category(ObjOrCtg, Ctg, Scope) :-
nonvar(Scope),
\+ '$lgt_member'(Scope, [(public), protected, private]),
throw(error(type_error(scope, Scope), imports_category(ObjOrCtg, Ctg, Scope))).
imports_category(ObjOrCtg, Ctg, Scope) :-
'$lgt_imports_category_'(ObjOrCtg, Ctg, Scope).
% instantiates_class(?object_identifier, ?object_identifier)
instantiates_class(Obj, Class) :-
catch(
instantiates_class(Obj, Class, _),
error(Error, _),
throw(error(Error, instantiates_class(Obj, Class)))).
% instantiates_class(?object_identifier, ?object_identifier, ?atom)
instantiates_class(Obj, Class, Scope) :-
nonvar(Obj),
\+ callable(Obj),
throw(error(type_error(object_identifier, Obj), instantiates_class(Obj, Class, Scope))).
instantiates_class(Obj, Class, Scope) :-
nonvar(Class),
\+ callable(Class),
throw(error(type_error(object_identifier, Class), instantiates_class(Obj, Class, Scope))).
instantiates_class(Obj, Class, Scope) :-
nonvar(Scope),
\+ '$lgt_member'(Scope, [(public), protected, private]),
throw(error(type_error(scope, Scope), instantiates_class(Obj, Class, Scope))).
instantiates_class(Obj, Class, Scope) :-
'$lgt_instantiates_class_'(Obj, Class, Scope).
% specializes_class(?object_identifier, ?object_identifier)
specializes_class(Class, Superclass) :-
catch(
specializes_class(Class, Superclass, _),
error(Error, _),
throw(error(Error, specializes_class(Class, Superclass)))).
% specializes_class(?object_identifier, ?object_identifier, ?atom)
specializes_class(Class, Superclass, Scope) :-
nonvar(Class),
\+ callable(Class),
throw(error(type_error(object_identifier, Class), specializes_class(Class, Superclass, Scope))).
specializes_class(Class, Superclass, Scope) :-
nonvar(Superclass),
\+ callable(Superclass),
throw(error(type_error(object_identifier, Superclass), specializes_class(Class, Superclass, Scope))).
specializes_class(Class, Superclass, Scope) :-
nonvar(Scope),
\+ '$lgt_member'(Scope, [(public), protected, private]),
throw(error(type_error(scope, Scope), specializes_class(Class, Superclass, Scope))).
specializes_class(Class, Superclass, Scope) :-
'$lgt_specializes_class_'(Class, Superclass, Scope).
% extends_protocol(?protocol_identifier, ?protocol_identifier)
extends_protocol(Ptc1, Ptc2) :-
catch(
extends_protocol(Ptc1, Ptc2, _),
error(Error, _),
throw(error(Error, extends_protocol(Ptc1, Ptc2)))).
% extends_protocol(?protocol_identifier, ?protocol_identifier, ?atom)
extends_protocol(Ptc1, Ptc2, Scope) :-
nonvar(Ptc1),
\+ atom(Ptc1),
throw(error(type_error(protocol_identifier, Ptc1), extends_protocol(Ptc1, Ptc2, Scope))).
extends_protocol(Ptc1, Ptc2, Scope) :-
nonvar(Ptc2),
\+ atom(Ptc2),
throw(error(type_error(protocol_identifier, Ptc2), extends_protocol(Ptc1, Ptc2, Scope))).
extends_protocol(Ptc1, Ptc2, Scope) :-
nonvar(Scope),
\+ '$lgt_member'(Scope, [(public), protected, private]),
throw(error(type_error(scope, Scope), extends_protocol(Ptc1, Ptc2, Scope))).
extends_protocol(Ptc1, Ptc2, Scope) :-
'$lgt_extends_protocol_'(Ptc1, Ptc2, Scope).
% extends_object(?object_identifier, ?object_identifier)
extends_object(Prototype, Parent) :-
catch(
extends_object(Prototype, Parent, _),
error(Error, _),
throw(error(Error, extends_object(Prototype, Parent)))).
% extends_object(?object_identifier, ?object_identifier, ?atom)
extends_object(Prototype, Parent, Scope) :-
nonvar(Prototype),
\+ callable(Prototype),
throw(error(type_error(object_identifier, Prototype), extends_object(Prototype, Parent, Scope))).
extends_object(Prototype, Parent, Scope) :-
nonvar(Parent),
\+ callable(Parent),
throw(error(type_error(object_identifier, Parent), extends_object(Prototype, Parent, Scope))).
extends_object(Prototype, Parent, Scope) :-
nonvar(Scope),
\+ '$lgt_member'(Scope, [(public), protected, private]),
throw(error(type_error(scope, Scope), extends_object(Prototype, Parent, Scope))).
extends_object(Prototype, Parent, Scope) :-
'$lgt_extends_object_'(Prototype, Parent, Scope).
% current_event(?event, ?object_identifier, ?callable, ?object_identifier, ?object_identifier)
current_event(Event, Obj, Msg, Sender, Monitor) :-
nonvar(Event),
Event \= before,
Event \= after,
throw(error(type_error(event, Event), current_event(Event, Obj, Msg, Sender, Monitor))).
current_event(Event, Obj, Msg, Sender, Monitor) :-
nonvar(Obj),
\+ callable(Obj),
throw(error(type_error(object_identifier, Obj), current_event(Event, Obj, Msg, Sender, Monitor))).
current_event(Event, Obj, Msg, Sender, Monitor) :-
nonvar(Msg),
\+ callable(Msg),
throw(error(type_error(callable, Msg), current_event(Event, Obj, Msg, Sender, Monitor))).
current_event(Event, Obj, Msg, Sender, Monitor) :-
nonvar(Sender),
\+ callable(Sender),
throw(error(type_error(object_identifier, Sender), current_event(Event, Obj, Msg, Sender, Monitor))).
current_event(Event, Obj, Msg, Sender, Monitor) :-
nonvar(Monitor),
\+ callable(Monitor),
throw(error(type_error(object_identifier, Monitor), current_event(Event, Obj, Msg, Sender, Monitor))).
current_event(before, Obj, Msg, Sender, Monitor) :-
'$lgt_before_'(Obj, Msg, Sender, Monitor, _).
current_event(after, Obj, Msg, Sender, Monitor) :-
'$lgt_after_'(Obj, Msg, Sender, Monitor, _).
%define_events(@event, @object_identifier, @callable, @object_identifier, +object_identifier)
define_events(Event, Obj, Msg, Sender, Monitor) :-
nonvar(Event),
Event \= before,
Event \= after,
throw(error(type_error(event, Event), define_events(Event, Obj, Msg, Sender, Monitor))).
define_events(Event, Obj, Msg, Sender, Monitor) :-
nonvar(Obj),
\+ callable(Obj),
throw(error(type_error(object_identifier, Obj), define_events(Event, Obj, Msg, Sender, Monitor))).
define_events(Event, Obj, Msg, Sender, Monitor) :-
nonvar(Msg),
\+ callable(Msg),
throw(error(type_error(callable, Msg), define_events(Event, Obj, Msg, Sender, Monitor))).
define_events(Event, Obj, Msg, Sender, Monitor) :-
nonvar(Sender),
\+ callable(Sender),
throw(error(type_error(object_identifier, Sender), define_events(Event, Obj, Msg, Sender, Monitor))).
define_events(Event, Obj, Msg, Sender, Monitor) :-
var(Monitor),
throw(error(instantiation_error, define_events(Event, Obj, Msg, Sender, Monitor))).
define_events(Event, Obj, Msg, Sender, Monitor) :-
nonvar(Monitor),
\+ callable(Monitor),
throw(error(type_error(object_identifier, Monitor), define_events(Event, Obj, Msg, Sender, Monitor))).
define_events(Event, Obj, Msg, Sender, Monitor) :-
var(Event),
!,
'$lgt_current_object_'(Monitor, _, _, Def, _, _),
'$lgt_call'(Def, before(Obj, Msg, Sender), Monitor, Monitor, Monitor, BCall, _),
'$lgt_call'(Def, after(Obj, Msg, Sender), Monitor, Monitor, Monitor, ACall, _),
retractall('$lgt_before_'(Obj, Msg, Sender, Monitor, _)),
assertz('$lgt_before_'(Obj, Msg, Sender, Monitor, BCall)),
retractall('$lgt_after_'(Obj, Msg, Sender, Monitor, _)),
assertz('$lgt_after_'(Obj, Msg, Sender, Monitor, ACall)).
define_events(before, Obj, Msg, Sender, Monitor) :-
'$lgt_current_object_'(Monitor, _, _, Def, _, _),
'$lgt_call'(Def, before(Obj, Msg, Sender), Monitor, Monitor, Monitor, Call, _),
retractall('$lgt_before_'(Obj, Msg, Sender, Monitor, _)),
assertz('$lgt_before_'(Obj, Msg, Sender, Monitor, Call)).
define_events(after, Obj, Msg, Sender, Monitor) :-
'$lgt_current_object_'(Monitor, _, _, Def, _, _),
'$lgt_call'(Def, after(Obj, Msg, Sender), Monitor, Monitor, Monitor, Call, _),
retractall('$lgt_after_'(Obj, Msg, Sender, Monitor, _)),
assertz('$lgt_after_'(Obj, Msg, Sender, Monitor, Call)).
% abolish_events(@event, @object_identifier, @callable, @object_identifier, @object_identifier)
abolish_events(Event, Obj, Msg, Sender, Monitor) :-
nonvar(Event),
Event \= before,
Event \= after,
throw(error(type_error(event, Event), abolish_events(Event, Obj, Msg, Sender, Monitor))).
abolish_events(Event, Obj, Msg, Sender, Monitor) :-
nonvar(Obj),
\+ callable(Obj),
throw(error(type_error(object_identifier, Obj), abolish_events(Event, Obj, Msg, Sender, Monitor))).
abolish_events(Event, Obj, Msg, Sender, Monitor) :-
nonvar(Msg),
\+ callable(Msg),
throw(error(type_error(callable, Msg), abolish_events(Event, Obj, Msg, Sender, Monitor))).
abolish_events(Event, Obj, Msg, Sender, Monitor) :-
nonvar(Sender),
\+ callable(Sender),
throw(error(type_error(object_identifier, Sender), abolish_events(Event, Obj, Msg, Sender, Monitor))).
abolish_events(Event, Obj, Msg, Sender, Monitor) :-
nonvar(Monitor),
\+ callable(Monitor),
throw(error(type_error(object_identifier, Monitor), abolish_events(Event, Obj, Msg, Sender, Monitor))).
abolish_events(Event, Obj, Msg, Sender, Monitor) :-
var(Event),
!,
retractall('$lgt_before_'(Obj, Msg, Sender, Monitor, _)),
retractall('$lgt_after_'(Obj, Msg, Sender, Monitor, _)).
abolish_events(before, Obj, Msg, Sender, Monitor) :-
retractall('$lgt_before_'(Obj, Msg, Sender, Monitor, _)).
abolish_events(after, Obj, Msg, Sender, Monitor) :-
retractall('$lgt_after_'(Obj, Msg, Sender, Monitor, _)).
% compiling and loading built-in predicates
% '$lgt_compiler_option'(+atom, ?atom)
%
% gets/check the current value of a compiler option
'$lgt_compiler_option'(Option, Value) :-
'$lgt_pp_compiler_option_'(Option, Value2),
!,
Value = Value2.
'$lgt_compiler_option'(Option, Value) :-
'$lgt_current_flag_'(Option, Value2),
!,
Value = Value2.
'$lgt_compiler_option'(Option, Value) :-
'$lgt_default_flag'(Option, Value).
% logtalk_compile(@atom_or_atom_list)
%
% compiles to disk an entity or list of entities using default options
logtalk_compile(Entities) :-
catch(
logtalk_compile(Entities, []),
error(Error, _),
throw(error(Error, logtalk_compile(Entities)))).
% logtalk_compile(@atom_or_atom_list, @list)
%
% compiles to disk an entity or a list of entities using a list of options
logtalk_compile(Entity, Options) :-
(atom(Entity), Entity \= []; compound(Entity), Entity \= [_| _]),
!,
catch(
('$lgt_check_compiler_entity'(Entity),
'$lgt_check_compiler_options'(Options),
'$lgt_set_compiler_options'(Options),
'$lgt_compile_entity'(Entity, Options)),
Error,
throw(error(Error, logtalk_compile(Entity, Options)))).
logtalk_compile(Entities, Options) :-
catch(
('$lgt_check_compiler_entities'(Entities),
'$lgt_check_compiler_options'(Options),
'$lgt_set_compiler_options'(Options),
'$lgt_compile_entities'(Entities, Options)),
Error,
throw(error(Error, logtalk_compile(Entities, Options)))).
% '$lgt_check_compiler_entities'(@list)
%
% check if the entities names are valid and if the corresponding
% files exist in the current working directory
'$lgt_check_compiler_entities'(Entities) :-
var(Entities),
throw(instantiation_error).
'$lgt_check_compiler_entities'(Entities) :-
\+ '$lgt_proper_list'(Entities),
throw(type_error(entity_file_names, Entities)).
'$lgt_check_compiler_entities'(Entities) :-
'$lgt_check_compiler_entity_list'(Entities).
'$lgt_check_compiler_entity_list'([]).
'$lgt_check_compiler_entity_list'([Entity| Entities]) :-
'$lgt_check_compiler_entity'(Entity),
'$lgt_check_compiler_entity_list'(Entities).
'$lgt_check_compiler_entity'(Entity) :-
var(Entity),
throw(instantiation_error).
'$lgt_check_compiler_entity'(Entity) :-
compound(Entity),
!,
'$lgt_check_compiler_library_entity'(Entity).
'$lgt_check_compiler_entity'(Entity) :-
\+ atom(Entity),
throw(type_error(entity_file_name, Entity)).
'$lgt_check_compiler_entity'(Entity) :-
'$lgt_file_name'(metafile, Entity, Metafile),
\+ '$lgt_file_exists'(Metafile),
'$lgt_file_name'(logtalk, Entity, File),
\+ '$lgt_file_exists'(File),
throw(existence_error(entity, Entity)).
'$lgt_check_compiler_entity'(_).
'$lgt_check_compiler_library_entity'(Term) :-
\+ Term =.. [_, _],
throw(type_error(library_entity_file_name, Term)).
'$lgt_check_compiler_library_entity'(Term) :-
Term =.. [Library, Entity],
'$lgt_check_compiler_library_entity'(Library, Entity).
'$lgt_check_compiler_library_entity'(Library, _) :-
\+ logtalk_library_path(Library, _),
throw(existence_error(library, Library)).
'$lgt_check_compiler_library_entity'(Library, Entity) :-
once(logtalk_library_path(Library, Path)),
'$lgt_current_directory'(Current),
'$lgt_change_directory'(Path),
catch(
'$lgt_check_compiler_entity'(Entity),
Error,
('$lgt_change_directory'(Current), throw(Error))),
'$lgt_change_directory'(Current).
% '$lgt_check_compiler_options'(@list)
%
% check if the compiler options are valid
'$lgt_check_compiler_options'(Options) :-
var(Options),
throw(instantiation_error).
'$lgt_check_compiler_options'(Options) :-
\+ '$lgt_proper_list'(Options),
throw(type_error(list, Options)).
'$lgt_check_compiler_options'(Options) :-
'$lgt_check_compiler_option_list'(Options).
'$lgt_check_compiler_option_list'([]).
'$lgt_check_compiler_option_list'([Option| Options]) :-
'$lgt_check_compiler_option'(Option),
'$lgt_check_compiler_option_list'(Options).
'$lgt_check_compiler_option'(Option) :-
'$lgt_valid_compiler_option'(Option) ->
true
;
throw(type_error(compiler_option, Option)).
% '$lgt_set_compiler_options'(@list)
%
% sets the compiler options
'$lgt_set_compiler_options'(Options) :-
retractall('$lgt_pp_compiler_option_'(_, _)),
'$lgt_assert_compiler_options'(Options),
('$lgt_pp_compiler_option_'(debug, on) ->
retractall('$lgt_pp_compiler_option_'(smart_compilation, _)),
asserta('$lgt_pp_compiler_option_'(smart_compilation, off))
;
true).
'$lgt_assert_compiler_options'([]).
'$lgt_assert_compiler_options'([Option| Options]) :-
Option =.. [Key, Value],
asserta('$lgt_pp_compiler_option_'(Key, Value)),
'$lgt_assert_compiler_options'(Options).
% logtalk_load(@atom_or_atom_list)
%
% compiles to disk and then loads to memory an entity
% or a list of entities using default options
logtalk_load(Entities) :-
catch(
logtalk_load(Entities, []),
error(Error, _),
throw(error(Error, logtalk_load(Entities)))).
% logtalk_load(@atom_or_atom_list, @list)
%
% compiles to disk and then loads to memory an entity
% or a list of entities using a list of options
logtalk_load(Entity, Options) :-
(atom(Entity), Entity \= []; compound(Entity), Entity \= [_| _]),
!,
catch(
('$lgt_check_compiler_entity'(Entity),
'$lgt_check_compiler_options'(Options),
'$lgt_set_compiler_options'(Options),
'$lgt_load_entity'(Entity, Options)),
Error,
throw(error(Error, logtalk_load(Entity, Options)))).
logtalk_load(Entities, Options) :-
catch(
('$lgt_check_compiler_entities'(Entities),
'$lgt_check_compiler_options'(Options),
'$lgt_set_compiler_options'(Options),
'$lgt_load_entities'(Entities, Options)),
Error,
throw(error(Error, logtalk_load(Entities, Options)))).
% set_logtalk_flag(+atom, +nonvar)
%
% sets a Logtalk flag
set_logtalk_flag(Flag, Value) :-
var(Flag),
throw(error(instantiation_error, set_logtalk_flag(Flag, Value))).
set_logtalk_flag(Flag, Value) :-
var(Value),
throw(error(instantiation_error, set_logtalk_flag(Flag, Value))).
set_logtalk_flag(Flag, Value) :-
nonvar(Flag),
\+ atom(Flag),
throw(error(type_error(atom, Flag), set_logtalk_flag(Flag, Value))).
set_logtalk_flag(Flag, Value) :-
atom(Flag),
\+ '$lgt_valid_flag'(Flag),
throw(error(domain_error(valid_flag, Flag), set_logtalk_flag(Flag, Value))).
set_logtalk_flag(Flag, Value) :-
'$lgt_read_only_flag'(Flag),
throw(error(permission_error(modify, read_only_flag, Flag), set_logtalk_flag(Flag, Value))).
set_logtalk_flag(Flag, Value) :-
\+ '$lgt_valid_flag'(Flag, Value),
throw(error(domain_error(valid_flag_value, Value), set_logtalk_flag(Flag, Value))).
set_logtalk_flag(debug, on) :-
!,
retractall('$lgt_current_flag_'(debug, _)),
assertz('$lgt_current_flag_'(debug, on)),
retractall('$lgt_current_flag_'(smart_compilation, _)),
assertz('$lgt_current_flag_'(smart_compilation, off)).
set_logtalk_flag(Flag, Value) :-
retractall('$lgt_current_flag_'(Flag, _)),
assertz('$lgt_current_flag_'(Flag, Value)).
% current_logtalk_flag(?atom, ?nonvar)
%
% tests/gets Logtalk flags
current_logtalk_flag(Flag, Value) :-
nonvar(Flag),
\+ atom(Flag),
throw(error(type_error(atom, Flag), current_logtalk_flag(Flag, Value))).
current_logtalk_flag(Flag, Value) :-
atom(Flag),
\+ '$lgt_valid_flag'(Flag),
throw(error(domain_error(valid_flag, Flag), current_logtalk_flag(Flag, Value))).
current_logtalk_flag(Flag, Value) :-
'$lgt_current_flag_'(Flag, Value).
current_logtalk_flag(Flag, Value) :-
'$lgt_default_flag'(Flag, Value),
\+ '$lgt_current_flag_'(Flag, _).
current_logtalk_flag(version, version(2, 22, 4)).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% built-in methods
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% checks if an object exists at runtime
'$lgt_obj_exists'(Obj, Pred, Sender) :-
\+ '$lgt_current_object_'(Obj, _, _, _, _, _) ->
throw(error(existence_error(object, Obj), Obj::Pred, Sender))
;
true.
% current_predicate/1 built-in method
'$lgt_current_predicate'(Obj, Pred, Sender, _) :-
nonvar(Pred),
Pred \= _/_,
throw(error(type_error(predicate_indicator, Pred), Obj::current_predicate(Pred), Sender)).
'$lgt_current_predicate'(Obj, Functor/Arity, Sender, _) :-
nonvar(Functor),
\+ atom(Functor),
throw(error(type_error(predicate_indicator, Functor/Arity), Obj::current_predicate(Functor/Arity), Sender)).
'$lgt_current_predicate'(Obj, Functor/Arity, Sender, _) :-
nonvar(Arity),
\+ (integer(Arity), Arity >= 0),
throw(error(type_error(predicate_indicator, Functor/Arity), Obj::current_predicate(Functor/Arity), Sender)).
'$lgt_current_predicate'(Obj, Functor/Arity, Sender, _) :-
\+ '$lgt_current_object_'(Obj, _, _, _, _, _),
throw(error(existence_error(object, Obj), Obj::current_predicate(Functor/Arity), Sender)).
'$lgt_current_predicate'(Obj, Functor/Arity, Sender, Scope) :-
nonvar(Functor),
nonvar(Arity),
!,
functor(Pred, Functor, Arity),
'$lgt_current_object_'(Obj, _, Dcl, _, _, _),
'$lgt_once'(Dcl, Pred, PScope, _, _, SCtn, _),
once((\+ \+ PScope = Scope; Sender = SCtn)).
'$lgt_current_predicate'(Obj, Functor/Arity, Sender, Scope) :-
'$lgt_current_object_'(Obj, _, Dcl, _, _, _),
findall(
Functor/Arity - (PScope, SCtn),
('$lgt_call'(Dcl, Pred, PScope, _, _, SCtn, _),
once((\+ \+ PScope = Scope; Sender = SCtn)),
functor(Pred, Functor, Arity)),
Preds),
'$lgt_cp_filter'(Preds, Filtered),
'$lgt_member'(Functor/Arity - (PScope, SCtn), Filtered).
% '$lgt_cp_filter'(+list, -list)
%
% removes duplicated and redeclared predicates
'$lgt_cp_filter'([], []).
'$lgt_cp_filter'([Data| Rest], [Data| Rest2]) :-
'$lgt_cp_remove_all'(Rest, Data, Aux),
'$lgt_cp_filter'(Aux, Rest2).
'$lgt_cp_remove_all'([], _, []).
'$lgt_cp_remove_all'([F/A-_| Rest], F/A-D, List) :-
!,
'$lgt_cp_remove_all'(Rest, F/A-D, List).
'$lgt_cp_remove_all'([Data| Rest], Filter, [Data| Rest2]) :-
!,
'$lgt_cp_remove_all'(Rest, Filter, Rest2).
% predicate_property/2 built-in method
'$lgt_predicate_property'(Obj, Pred, Prop, Sender, _) :-
var(Pred),
throw(error(instantiation_error, Obj::predicate_property(Pred, Prop), Sender)).
'$lgt_predicate_property'(Obj, Pred, Prop, Sender, _) :-
nonvar(Prop),
\+ '$lgt_pred_property'(Prop),
throw(error(domain_error(predicate_property, Prop), Obj::predicate_property(Pred, Prop), Sender)).
'$lgt_predicate_property'(Obj, Pred, Prop, Sender, _) :-
\+ callable(Pred),
throw(error(type_error(callable, Pred), Obj::predicate_property(Pred, Prop), Sender)).
'$lgt_predicate_property'(Obj, Pred, Prop, Sender, _) :-
\+ '$lgt_current_object_'(Obj, _, _, _, _, _),
throw(error(existence_error(object, Obj), Obj::predicate_property(Pred, Prop), Sender)).
'$lgt_predicate_property'(Obj, Pred, Prop, Sender, Scope) :-
'$lgt_current_object_'(Obj, Prefix, Dcl, Def, _, _),
'$lgt_once'(Dcl, Pred, PScope, Type, Meta, SCtn, TCtn),
!,
once((\+ \+ PScope = Scope; Sender = SCtn)),
('$lgt_scope'(Prop, PScope);
Prop = Type;
Prop = declared_in(TCtn);
'$lgt_once'(Def, Pred, _, _, _, _, DCtn),
Prop = defined_in(DCtn);
Meta \= no, Prop = metapredicate(Meta);
'$lgt_current_object_'(TCtn, _, TCtnDcl, _, _, _),
\+ '$lgt_call'(TCtnDcl, Pred, _, _, _),
'$lgt_alias_pred'(Obj, Prefix, Pred, Pred2),
Prop = alias(Pred2)).
'$lgt_predicate_property'(_, Pred, Prop, _, Scope) :-
'$lgt_built_in_method'(Pred, PScope),
!,
functor(Pred, Functor, Arity),
functor(Meta, Functor, Arity),
\+ \+ PScope = Scope,
('$lgt_scope'(Prop, PScope);
Prop = static;
Prop = built_in;
('$lgt_metapredicate'(Meta) -> Prop = metapredicate(Meta))).
'$lgt_predicate_property'(_, Pred, Prop, _, _) :-
'$lgt_built_in'(Pred),
functor(Pred, Functor, Arity),
functor(Meta, Functor, Arity),
(Prop = (public);
('$lgt_predicate_property'(Pred, (dynamic)) -> Prop = (dynamic); Prop = static);
Prop = built_in;
('$lgt_metapredicate'(Meta) -> Prop = metapredicate(Meta))).
% '$lgt_scope'(?atom, ?term).
%
% converts between user and system scope terms
'$lgt_scope'(private, p).
'$lgt_scope'(protected, p(p)).
'$lgt_scope'((public), p(p(p))).
% '$lgt_alias_pred'(+object_identifier, +atom, +callable, -callable)
%
% finds the predicate pointed by an alias
'$lgt_alias_pred'(Obj, Prefix, Alias, Pred) :-
'$lgt_alias_pred'(Obj, Prefix, Alias, Pred, _).
'$lgt_alias_pred'(_, Prefix, Alias, Pred, _) :-
'$lgt_construct_alias_functor'(Prefix, Functor),
'$lgt_once'(Functor, _, Pred, Alias),
Pred \= Alias,
!.
'$lgt_alias_pred'(Obj, _, Alias, Pred, _) :-
'$lgt_implements_protocol_'(Obj, Ptc, _),
'$lgt_current_protocol_'(Ptc, Prefix, _),
'$lgt_alias_pred'(Ptc, Prefix, Alias, Pred, _).
'$lgt_alias_pred'(Ptc1, _, Alias, Pred, _) :-
'$lgt_extends_protocol_'(Ptc1, Ptc2, _),
'$lgt_current_protocol_'(Ptc2, Prefix, _),
'$lgt_alias_pred'(Ptc2, Prefix, Alias, Pred, _).
'$lgt_alias_pred'(Obj, _, Alias, Pred, _) :-
'$lgt_imports_category_'(Obj, Ctg, _),
'$lgt_current_category_'(Ctg, Prefix, _),
'$lgt_alias_pred'(Ctg, Prefix, Alias, Pred, _).
'$lgt_alias_pred'(Obj, _, Alias, Pred, prototype) :-
'$lgt_extends_object_'(Obj, Parent, _),
'$lgt_current_object_'(Parent, Prefix, _, _, _, _),
'$lgt_alias_pred'(Parent, Prefix, Alias, Pred, prototype).
'$lgt_alias_pred'(Instance, _, Alias, Pred, instance) :-
'$lgt_instantiates_class_'(Instance, Class, _),
'$lgt_current_object_'(Class, Prefix, _, _, _, _),
'$lgt_alias_pred'(Class, Prefix, Alias, Pred, superclass).
'$lgt_alias_pred'(Class, _, Alias, Pred, superclass) :-
'$lgt_specializes_class_'(Class, Superclass, _),
'$lgt_current_object_'(Superclass, Prefix, _, _, _, _),
'$lgt_alias_pred'(Superclass, Prefix, Alias, Pred, superclass).
% abolish/1 built-in method
'$lgt_abolish'(Obj, Pred, Sender, _) :-
var(Pred),
throw(error(instantiation_error, Obj::abolish(Pred), Sender)).
'$lgt_abolish'(Obj, Pred, Sender, _) :-
Pred \= _/_,
throw(error(type_error(predicate_indicator, Pred), Obj::abolish(predicate), Sender)).
'$lgt_abolish'(Obj, Functor/Arity, Sender, _) :-
(var(Functor); var(Arity)),
throw(error(instantiation_error, Obj::abolish(Functor/Arity), Sender)).
'$lgt_abolish'(Obj, Functor/Arity, Sender, _) :-
\+ atom(Functor),
throw(error(type_error(atom, Functor), Obj::abolish(Functor/Arity), Sender)).
'$lgt_abolish'(Obj, Functor/Arity, Sender, _) :-
\+ integer(Arity),
throw(error(type_error(integer, Arity), Obj::abolish(Functor/Arity), Sender)).
'$lgt_abolish'(Obj, Functor/Arity, Sender, Scope) :-
'$lgt_current_object_'(Obj, Prefix, Dcl, _, _, _) ->
((functor(Pred, Functor, Arity),
'$lgt_call'(Dcl, Pred, PScope, Compilation, _, SCtn, _)) ->
((\+ \+ PScope = Scope; Sender = SCtn) ->
(Compilation = (dynamic) ->
'$lgt_call'(Prefix, _, _, _, _, _, DDcl, DDef),
('$lgt_call'(DDcl, Pred, _) ->
Clause =.. [DDcl, Pred, _],
retractall(Clause),
('$lgt_call'(DDef, Pred, _, _, _, Call) ->
functor(Call, CFunctor, CArity),
abolish(CFunctor/CArity),
Clause2 =.. [DDef, Pred, _, _, _, Call],
retractall(Clause2),
'$lgt_clean_lookup_caches'(Pred)
;
true)
;
('$lgt_call'(Dcl, Pred, _, _, _) ->
throw(error(permission_error(modify, predicate_declaration, Pred), Obj::abolish(Functor/Arity), Sender))
;
throw(error(existence_error(predicate_declaration, Pred), Obj::abolish(Functor/Arity), Sender))))
;
throw(error(permission_error(modify, static_predicate, Pred), Obj::abolish(Functor/Arity), Sender)))
;
(PScope = p ->
throw(error(permission_error(modify, private_predicate, Pred), Obj::abolish(Functor/Arity), Sender))
;
throw(error(permission_error(modify, protected_predicate, Pred), Obj::abolish(Functor/Arity), Sender))))
;
throw(error(existence_error(predicate_declaration, Pred), Obj::abolish(Functor/Arity), Sender)))
;
throw(error(existence_error(object, Obj), Obj::abolish(Functor/Arity), Sender)).
% asserta/1 built-in method
'$lgt_asserta'(Obj, Clause, Sender, _) :-
var(Clause),
throw(error(instantiation_error, Obj::asserta(Clause), Sender)).
'$lgt_asserta'(Obj, Clause, Sender, _) :-
Clause \= (_ :- _),
\+ callable(Clause),
throw(error(type_error(callable, Clause), Obj::asserta(Clause), Sender)).
'$lgt_asserta'(Obj, (Head:-Body), Sender, _) :-
var(Head),
throw(error(instantiation_error, Obj::asserta((Head:-Body)), Sender)).
'$lgt_asserta'(Obj, (Head:-Body), Sender, _) :-
\+ callable(Head),
throw(error(type_error(callable, Head), Obj::asserta((Head:-Body)), Sender)).
'$lgt_asserta'(Obj, (Head:-Body), Sender, _) :-
\+ callable(Body),
throw(error(type_error(callable, Body), Obj::asserta((Head:-Body)), Sender)).
'$lgt_asserta'(Obj, Clause, Sender, _) :-
\+ '$lgt_current_object_'(Obj, _, _, _, _, _),
throw(error(existence_error(object, Obj), Obj::asserta(Clause), Sender)).
'$lgt_asserta'(Obj, (Head:-Body), Sender, Scope) :-
!,
'$lgt_current_object_'(Obj, Prefix, _, _, _, _),
'$lgt_call'(Prefix, Dcl, Def, _, _, _, DDcl, DDef),
('$lgt_call'(Dcl, Head, PScope, Type, Meta, SCtn, _) ->
true
;
'$lgt_convert_test_scope'(Scope, Scope2),
'$lgt_assert_ddcl_clause'(DDcl, Head, Scope2)),
(Type = (dynamic) ->
((\+ \+ PScope = Scope; Sender = SCtn) ->
(('$lgt_call'(Def, Head, Sender2, This, Self, Call); '$lgt_call'(DDef, Head, Sender2, This, Self, Call)) ->
true
;
functor(Head, Functor, Arity),
'$lgt_assert_ddef_clause'(Functor, Arity, Prefix, DDef, _),
'$lgt_once'(DDef, Head, Sender2, This, Self, Call)),
(compound(Meta) ->
Head =.. [_| Args],
Meta =.. [_| MArgs],
'$lgt_extract_metavars'(Args, MArgs, Metavars)
;
Metavars = []),
'$lgt_context'(Ctx, Sender2, This, Self, Prefix, Metavars),
'$lgt_tr_body'(Body, TBody, DBody, Ctx),
('$lgt_debugging_'(Obj) ->
asserta((Call :- ('$lgt_nop'(Body), '$lgt_dbg_head'(Head, Ctx), DBody)))
;
asserta((Call :- ('$lgt_nop'(Body), TBody))))
;
(PScope = p ->
throw(error(permission_error(modify, private_predicate, Head), Obj::asserta((Head:-Body)), Sender))
;
throw(error(permission_error(modify, protected_predicate, Head), Obj::asserta((Head:-Body)), Sender))))
;
throw(error(permission_error(modify, static_predicate, Head), Obj::asserta((Head:-Body)), Sender))).
'$lgt_asserta'(Obj, Head, Sender, Scope) :-
'$lgt_current_object_'(Obj, Prefix, _, _, _, _),
'$lgt_call'(Prefix, Dcl, Def, _, _, _, DDcl, DDef),
('$lgt_call'(Dcl, Head, PScope, Type, _, SCtn, _) ->
true
;
'$lgt_convert_test_scope'(Scope, Scope2),
'$lgt_assert_ddcl_clause'(DDcl, Head, Scope2)),
(Type = (dynamic) ->
((\+ \+ PScope = Scope; Sender = SCtn) ->
(('$lgt_call'(Def, Head, Sender2, This, Self, Call); '$lgt_call'(DDef, Head, Sender2, This, Self, Call)) ->
true
;
functor(Head, Functor, Arity),
'$lgt_assert_ddef_clause'(Functor, Arity, Prefix, DDef, _),
'$lgt_once'(DDef, Head, Sender2, This, Self, Call)),
('$lgt_debugging_'(Obj) ->
'$lgt_context'(Ctx, Sender2, This, Self, Prefix, []),
asserta((Call :- '$lgt_dbg_fact'(Head, Ctx)))
;
asserta(Call))
;
(PScope = p ->
throw(error(permission_error(modify, private_predicate, Head), Obj::asserta(Head), Sender))
;
throw(error(permission_error(modify, protected_predicate, Head), Obj::asserta(Head), Sender))))
;
throw(error(permission_error(modify, static_predicate, Head), Obj::asserta(Head), Sender))).
% assertz/1 built-in method
'$lgt_assertz'(Obj, Clause, Sender, _) :-
var(Clause),
throw(error(instantiation_error, Obj::assertz(Clause), Sender)).
'$lgt_assertz'(Obj, Clause, Sender, _) :-
Clause \= (_ :- _),
\+ callable(Clause),
throw(error(type_error(callable, Clause), Obj::asserta(Clause), Sender)).
'$lgt_assertz'(Obj, (Head:-Body), Sender, _) :-
var(Head),
throw(error(instantiation_error, Obj::assertz((Head:-Body)), Sender)).
'$lgt_assertz'(Obj, (Head:-Body), Sender, _) :-
\+ callable(Head),
throw(error(type_error(callable, Head), Obj::assertz((Head:-Body)), Sender)).
'$lgt_assertz'(Obj, (Head:-Body), Sender, _) :-
\+ callable(Body),
throw(error(type_error(callable, Body), Obj::assertz((Head:-Body)), Sender)).
'$lgt_assertz'(Obj, Clause, Sender, _) :-
\+ '$lgt_current_object_'(Obj, _, _, _, _, _),
throw(error(existence_error(object, Obj), Obj::assertz(Clause), Sender)).
'$lgt_assertz'(Obj, (Head:-Body), Sender, Scope) :-
!,
'$lgt_current_object_'(Obj, Prefix, _, _, _, _),
'$lgt_call'(Prefix, Dcl, Def, _, _, _, DDcl, DDef),
('$lgt_call'(Dcl, Head, PScope, Type, Meta, SCtn, _) ->
true
;
'$lgt_convert_test_scope'(Scope, Scope2),
'$lgt_assert_ddcl_clause'(DDcl, Head, Scope2)),
(Type = (dynamic) ->
((\+ \+ PScope = Scope; Sender = SCtn) ->
(('$lgt_call'(Def, Head, Sender2, This, Self, Call); '$lgt_call'(DDef, Head, Sender2, This, Self, Call)) ->
true
;
functor(Head, Functor, Arity),
'$lgt_assert_ddef_clause'(Functor, Arity, Prefix, DDef, _),
'$lgt_once'(DDef, Head, Sender2, This, Self, Call)),
(compound(Meta) ->
Head =.. [_| Args],
Meta =.. [_| MArgs],
'$lgt_extract_metavars'(Args, MArgs, Metavars)
;
Metavars = []),
'$lgt_context'(Ctx, Sender2, This, Self, Prefix, Metavars),
'$lgt_tr_body'(Body, TBody, DBody, Ctx),
('$lgt_debugging_'(Obj) ->
assertz((Call :- ('$lgt_nop'(Body), '$lgt_dbg_head'(Head, Ctx), DBody)))
;
assertz((Call :- ('$lgt_nop'(Body), TBody))))
;
(PScope = p ->
throw(error(permission_error(modify, private_predicate, Head), Obj::assertz((Head:-Body)), Sender))
;
throw(error(permission_error(modify, protected_predicate, Head), Obj::assertz((Head:-Body)), Sender))))
;
throw(error(permission_error(modify, static_predicate, Head), Obj::assertz((Head:-Body)), Sender))).
'$lgt_assertz'(Obj, Head, Sender, Scope) :-
'$lgt_current_object_'(Obj, Prefix, _, _, _, _),
'$lgt_call'(Prefix, Dcl, Def, _, _, _, DDcl, DDef),
('$lgt_call'(Dcl, Head, PScope, Type, _, SCtn, _) ->
true
;
'$lgt_convert_test_scope'(Scope, Scope2),
'$lgt_assert_ddcl_clause'(DDcl, Head, Scope2)),
(Type = (dynamic) ->
((\+ \+ PScope = Scope; Sender = SCtn) ->
(('$lgt_call'(Def, Head, Sender2, This, Self, Call); '$lgt_call'(DDef, Head, Sender2, This, Self, Call)) ->
true
;
functor(Head, Functor, Arity),
'$lgt_assert_ddef_clause'(Functor, Arity, Prefix, DDef, _),
'$lgt_once'(DDef, Head, Sender2, This, Self, Call)),
('$lgt_debugging_'(Obj) ->
'$lgt_context'(Ctx, Sender2, This, Self, Prefix, []),
assertz((Call :- '$lgt_dbg_fact'(Head, Ctx)))
;
assertz(Call))
;
(PScope = p ->
throw(error(permission_error(modify, private_predicate, Head), Obj::assertz(Head), Sender))
;
throw(error(permission_error(modify, protected_predicate, Head), Obj::assertz(Head), Sender))))
;
throw(error(permission_error(modify, static_predicate, Head), Obj::assertz(Head), Sender))).
% clause/2 built-in method
'$lgt_clause'(Obj, Head, Body, Sender, _) :-
var(Head),
throw(error(instantiation_error, Obj::clause(Head, Body), Sender)).
'$lgt_clause'(Obj, Head, Body, Sender, _) :-
\+ callable(Head),
throw(error(type_error(callable, Head), Obj::clause(Head, Body), Sender)).
'$lgt_clause'(Obj, Head, Body, Sender, _) :-
nonvar(Body),
\+ callable(Body),
throw(error(type_error(callable, Body), Obj::clause(Head, Body), Sender)).
'$lgt_clause'(Obj, Head, Body, Sender, Scope) :-
'$lgt_current_object_'(Obj, Prefix, _, _, _, _) ->
'$lgt_call'(Prefix, Dcl, Def, _, _, _, _, DDef),
('$lgt_call'(Dcl, Head, PScope, Type, _, SCtn, _) ->
(Type = (dynamic) ->
((\+ \+ PScope = Scope; Sender = SCtn) ->
once(('$lgt_call'(Def, Head, _, _, _, Call); '$lgt_call'(DDef, Head, _, _, _, Call))),
clause(Call, TBody),
(TBody = ('$lgt_nop'(Body), _) ->
true
;
Body = TBody)
;
(PScope = p ->
throw(error(permission_error(access, private_predicate, Head), Obj::clause(Head, Body), Sender))
;
throw(error(permission_error(access, protected_predicate, Head), Obj::clause(Head, Body), Sender))))
;
throw(error(permission_error(access, static_predicate, Head), Obj::clause(Head, Body), Sender)))
;
('$lgt_call'(DDef, Head, _, _, _, Call) -> % local dynamic predicate with no scope declaration
clause(Call, TBody),
(TBody = ('$lgt_nop'(Body), _) ->
true
;
Body = TBody)
;
throw(error(existence_error(predicate_declaration, Head), Obj::clause(Head, Body), Sender))))
;
throw(error(existence_error(object, Obj), Obj::clause(Head, Body), Sender)).
% retract/1 built-in method
'$lgt_retract'(Obj, Clause, Sender, _) :-
var(Clause),
throw(error(instantiation_error, Obj::retract(Clause), Sender)).
'$lgt_retract'(Obj, (Head:-Body), Sender, _) :-
var(Head),
throw(error(instantiation_error, Obj::retract((Head:-Body)), Sender)).
'$lgt_retract'(Obj, (Head:-Body), Sender, _) :-
\+ callable(Head),
throw(error(type_error(callable, Head), Obj::retract((Head:-Body)), Sender)).
'$lgt_retract'(Obj, Clause, Sender, _) :-
\+ '$lgt_current_object_'(Obj, _, _, _, _, _),
throw(error(existence_error(object, Obj), Obj::retract(Clause), Sender)).
'$lgt_retract'(Obj, (Head:-Body), Sender, Scope) :-
!,
'$lgt_current_object_'(Obj, Prefix, _, _, _, _),
'$lgt_call'(Prefix, Dcl, Def, _, _, _, _, DDef),
('$lgt_call'(Dcl, Head, PScope, Type, _, SCtn, _) ->
(Type = (dynamic) ->
((\+ \+ PScope = Scope; Sender = SCtn) ->
('$lgt_call'(Def, Head, _, _, _, Call) ->
retract((Call :- ('$lgt_nop'(Body), _)))
;
('$lgt_call'(DDef, Head, _, _, _, Call) ->
retract((Call :- ('$lgt_nop'(Body), _))),
'$lgt_update_ddef_table'(DDef, Head, Call)
;
fail))
;
(PScope = p ->
throw(error(permission_error(modify, private_predicate, Head), Obj::retract((Head:-Body)), Sender))
;
throw(error(permission_error(modify, protected_predicate, Head), Obj::retract((Head:-Body)), Sender))))
;
throw(error(permission_error(modify, static_predicate, Head), Obj::retract((Head:-Body)), Sender)))
;
('$lgt_call'(DDef, Head, _, _, _, Call) -> % local dynamic predicate with no scope declaration
retract((Call :- ('$lgt_nop'(Body), _)))
;
throw(error(existence_error(predicate_declaration, Head), Obj::retract((Head:-Body)), Sender)))).
'$lgt_retract'(Obj, Head, Sender, Scope) :-
'$lgt_current_object_'(Obj, Prefix, _, _, _, _),
'$lgt_call'(Prefix, Dcl, Def, _, _, _, _, DDef),
('$lgt_call'(Dcl, Head, PScope, Type, _, SCtn, _) ->
(Type = (dynamic) ->
((\+ \+ PScope = Scope; Sender = SCtn) ->
('$lgt_call'(Def, Head, _, _, _, Call) ->
('$lgt_debugging_'(Obj) ->
retract((Call :- '$lgt_dbg_fact'(_, _)))
;
retract(Call))
;
('$lgt_call'(DDef, Head, _, _, _, Call) ->
('$lgt_debugging_'(Obj) ->
retract((Call :- '$lgt_dbg_fact'(_, _)))
;
retract(Call)),
'$lgt_update_ddef_table'(DDef, Head, Call)
;
fail))
;
(PScope = p ->
throw(error(permission_error(modify, private_predicate, Head), Obj::retract(Head), Sender))
;
throw(error(permission_error(modify, protected_predicate, Head), Obj::retract(Head), Sender))))
;
throw(error(permission_error(modify, static_predicate, Head), Obj::retract(Head), Sender)))
;
('$lgt_call'(DDef, Head, _, _, _, Call) -> % local dynamic predicate with no scope declaration
('$lgt_debugging_'(Obj) ->
retract((Call :- '$lgt_dbg_fact'(_, _)))
;
retract(Call))
;
throw(error(existence_error(predicate_declaration, Head), Obj::retract(Head), Sender)))).
% retractall/1 built-in method
'$lgt_retractall'(Obj, Head, Sender, _) :-
var(Head),
throw(error(instantiation_error, Obj::retractall(Head), Sender)).
'$lgt_retractall'(Obj, Head, Sender, _) :-
\+ callable(Head),
throw(error(type_error(callable, Head), Obj::retractall(Head), Sender)).
'$lgt_retractall'(Obj, Head, Sender, Scope) :-
'$lgt_current_object_'(Obj, Prefix, _, _, _, _) ->
'$lgt_call'(Prefix, Dcl, Def, _, _, _, _, DDef),
('$lgt_call'(Dcl, Head, PScope, Type, _, SCtn, _) ->
(Type = (dynamic) ->
((\+ \+ PScope = Scope; Sender = SCtn) ->
('$lgt_call'(Def, Head, _, _, _, Call) ->
retractall(Call)
;
('$lgt_call'(DDef, Head, _, _, _, Call) ->
retractall(Call),
'$lgt_update_ddef_table'(DDef, Head, Call)
;
true))
;
(PScope = p ->
throw(error(permission_error(modify, private_predicate, Head), Obj::retractall(Head), Sender))
;
throw(error(permission_error(modify, protected_predicate, Head), Obj::retractall(Head), Sender))))
;
throw(error(permission_error(modify, static_predicate, Head), Obj::retractall(Head), Sender)))
;
('$lgt_call'(DDef, Head, _, _, _, Call) -> % local dynamic predicate with no scope declaration
retractall(Call)
;
throw(error(existence_error(predicate_declaration, Head), Obj::retractall(Head), Sender))))
;
throw(error(existence_error(object, Obj), Obj::retractall(Head), Sender)).
% '$lgt_nop'(+goal)
%
% used in the implementation of the built-in
% method clause/2 to store original clause body
'$lgt_nop'(_).
% '$lgt_phrase'(+object_identifier, +ruleset, ?list, +object_identifier, +scope)
%
% phrase/2 built-in method
'$lgt_phrase'(Obj, Ruleset, Input, Sender, Scope) :-
catch(
'$lgt_phrase'(Obj, Ruleset, Input, [], Sender, Scope),
error(Error, _),
throw(error(Error, Obj::phrase(Ruleset, Input), Sender))).
% '$lgt_phrase'(+object_identifier, +ruleset, +list, ?list, +object_identifier, +scope)
%
% phrase/3 built-in method
'$lgt_phrase'(Obj, Ruleset, Input, Rest, Sender, _) :-
var(Ruleset),
throw(error(instantiation_error, Obj::phrase(Ruleset, Input, Rest), Sender)).
'$lgt_phrase'(Obj, Ruleset, Input, Rest, Sender, _) :-
\+ callable(Ruleset),
throw(error(type_error(callable, Ruleset), Obj::phrase(Ruleset, Input, Rest), Sender)).
'$lgt_phrase'(Obj, Ruleset, Input, Rest, Sender, _) :-
nonvar(Input),
\+ '$lgt_proper_list'(Input),
throw(error(type_error(list, Input), Obj::phrase(Ruleset, Input, Rest), Sender)).
'$lgt_phrase'(Obj, Ruleset, Input, Rest, Sender, _) :-
nonvar(Rest),
\+ '$lgt_proper_list'(Rest),
throw(error(type_error(list, Rest), Obj::phrase(Ruleset, Input, Rest), Sender)).
'$lgt_phrase'(Obj, (Ruleset1, Ruleset2), Input, Rest, Sender, Scope) :-
!,
'$lgt_phrase'(Obj, Ruleset1, Input, Rest1, Sender, Scope),
'$lgt_phrase'(Obj, Ruleset2, Rest1, Rest, Sender, Scope).
'$lgt_phrase'(Obj, (Ruleset1; Ruleset2), Input, Rest, Sender, Scope) :-
!,
('$lgt_phrase'(Obj, Ruleset1, Input, Rest, Sender, Scope)
;
'$lgt_phrase'(Obj, Ruleset2, Input, Rest, Sender, Scope)).
'$lgt_phrase'(Obj, (Ruleset1 -> Ruleset2), Input, Rest, Sender, Scope) :-
!,
'$lgt_phrase'(Obj, Ruleset1, Input, Rest1, Sender, Scope),
'$lgt_phrase'(Obj, Ruleset2, Rest1, Rest, Sender, Scope).
'$lgt_phrase'(_, !, Input, Rest, _, _) :-
!,
Input = Rest.
'$lgt_phrase'(Obj, \+ Ruleset, Input, Rest, Sender, Scope) :-
!,
\+ '$lgt_phrase'(Obj, Ruleset, Input, Rest, Sender, Scope).
'$lgt_phrase'(_, [], Input, Rest, _, _) :-
!,
Input = Rest.
'$lgt_phrase'(_, [Head| Tail], Input, Rest, _, _) :-
!,
'$lgt_append'([Head| Tail], Rest, Input).
'$lgt_phrase'(Obj, Ruleset, Input, Rest, Sender, Scope) :-
'$lgt_current_object_'(Obj, Prefix, Dcl, Def, _, _) ->
Ruleset =.. [Functor| Args],
'$lgt_append'(Args, [Input, Rest], Args2),
Pred =.. [Functor| Args2],
('$lgt_call'(Dcl, Pred, PScope, _, _, SCtn, _) ->
((\+ \+ PScope = Scope; Sender = SCtn) ->
'$lgt_once'(Def, Pred, Sender, Obj, Obj, Call, _),
call(Call)
;
(PScope = p ->
throw(error(permission_error(access, private_non_terminal, Ruleset), Obj::phrase(Ruleset, Input, Rest), Sender))
;
throw(error(permission_error(access, protected_non_terminal, Ruleset), Obj::phrase(Ruleset, Input, Rest), Sender))))
;
((Obj = Sender,
('$lgt_call'(Def, Pred, Obj, Obj, Obj, Call)
;
'$lgt_call'(Prefix, _, _, _, _, _, _, DDef), '$lgt_call'(DDef, Pred, Obj, Obj, Obj, Call))) ->
call(Call)
;
throw(error(existence_error(non_terminal_declaration, Ruleset), Obj::phrase(Ruleset, Input, Rest), Sender))))
;
throw(error(existence_error(object, Obj), Obj::phrase(Ruleset, Input, Rest), Sender)).
% '$lgt_expand_term'(+object_identifier, @term, -clause, +object_identifier, +scope)
%
% expand_term/2 built-in method
'$lgt_expand_term'(_, Term, Clause, _, _) :-
nonvar(Term),
Term = (_ --> _),
!,
'$lgt_dcgrule_to_clause'(Term, Clause).
'$lgt_expand_term'(_, Term, Term, _, _).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% message sending
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% '$lgt_send_to_self'(+object, ?term, +object)
'$lgt_send_to_self'(Obj, Pred, Sender) :-
nonvar(Pred) ->
'$lgt_send_to_self_nv'(Obj, Pred, Sender)
;
throw(error(instantiation_error, Obj::Pred, Sender)).
% '$lgt_send_to_self_nv'(+object, +term, +object)
'$lgt_send_to_self_nv'(Obj, Pred, Sender) :-
'$lgt_self_lookup_cache_'(Obj, Pred, Sender, Call) ->
call(Call)
;
('$lgt_current_object_'(Obj, _, Dcl, Def, _, _),
('$lgt_call'(Dcl, Pred, Scope, _, _, SCtn, _) ->
((Scope = p(_); Sender = SCtn) ->
functor(Pred, PFunctor, PArity), functor(GPred, PFunctor, PArity),
functor(Obj, OFunctor, OArity), functor(GObj, OFunctor, OArity),
functor(Sender, SFunctor, SArity), functor(GSender, SFunctor, SArity),
'$lgt_once'(Def, GPred, GSender, GObj, GObj, GCall, _),
asserta('$lgt_self_lookup_cache_'(GObj, GPred, GSender, GCall)),
GObj = Obj, GPred = Pred, GSender = Sender,
call(GCall)
;
throw(error(permission_error(access, private_predicate, Pred), Obj::Pred, Sender)))
;
('$lgt_built_in'(Pred) ->
call(Pred)
;
throw(error(existence_error(predicate_declaration, Pred), Obj::Pred, Sender))))).
% '$lgt_send_to_object'(@object, ?term, +object)
'$lgt_send_to_object'(Obj, Pred, Sender) :-
(nonvar(Obj), nonvar(Pred)) ->
'$lgt_send_to_object_nv'(Obj, Pred, Sender)
;
throw(error(instantiation_error, Obj::Pred, Sender)).
% '$lgt_send_to_object_nv'(+object, +term, +object)
'$lgt_send_to_object_nv'(Obj, Pred, Sender) :-
'$lgt_obj_lookup_cache_'(Obj, Pred, Sender, Call) ->
\+ ('$lgt_before_'(Obj, Pred, Sender, _, BCall), \+ call(BCall)),
call(Call),
\+ ('$lgt_after_'(Obj, Pred, Sender, _, ACall), \+ call(ACall))
;
('$lgt_current_object_'(Obj, _, Dcl, Def, _, _) ->
('$lgt_call'(Dcl, Pred, Scope, _, _, _, _) ->
(Scope = p(p(_)) ->
functor(Pred, Functor, Arity), functor(GPred, Functor, Arity),
functor(Obj, OName, OArity), functor(GObj, OName, OArity),
'$lgt_once'(Def, GPred, GSender, GObj, GObj, GCall, _),
asserta('$lgt_obj_lookup_cache_'(GObj, GPred, GSender, GCall)),
GObj = Obj, GPred = Pred, GSender = Sender,
\+ ('$lgt_before_'(Obj, Pred, Sender, _, BCall), \+ call(BCall)),
call(GCall),
\+ ('$lgt_after_'(Obj, Pred, Sender, _, ACall), \+ call(ACall))
;
(Scope = p ->
throw(error(permission_error(access, private_predicate, Pred), Obj::Pred, Sender))
;
throw(error(permission_error(access, protected_predicate, Pred), Obj::Pred, Sender))))
;
('$lgt_built_in'(Pred) ->
call(Pred)
;
throw(error(existence_error(predicate_declaration, Pred), Obj::Pred, Sender))))
;
throw(error(existence_error(object, Obj), Obj::Pred, Sender))).
% '$lgt_send_to_object_ne'(@object, ?term, +object)
'$lgt_send_to_object_ne'(Obj, Pred, Sender) :-
(nonvar(Obj), nonvar(Pred)) ->
'$lgt_send_to_object_ne_nv'(Obj, Pred, Sender)
;
throw(error(instantiation_error, Obj::Pred, Sender)).
% '$lgt_send_to_object_ne_nv'(+object, +term, +object)
'$lgt_send_to_object_ne_nv'(Obj, Pred, Sender) :-
'$lgt_obj_lookup_cache_'(Obj, Pred, Sender, Call) ->
call(Call)
;
('$lgt_current_object_'(Obj, _, Dcl, Def, _, _) ->
('$lgt_call'(Dcl, Pred, Scope, _, _, _, _) ->
(Scope = p(p(_)) ->
functor(Pred, Functor, Arity), functor(GPred, Functor, Arity),
functor(Obj, OName, OArity), functor(GObj, OName, OArity),
'$lgt_once'(Def, GPred, GSender, GObj, GObj, GCall, _),
asserta('$lgt_obj_lookup_cache_'(GObj, GPred, GSender, GCall)),
GObj = Obj, GPred = Pred, GSender = Sender,
call(GCall)
;
(Scope = p ->
throw(error(permission_error(access, private_predicate, Pred), Obj::Pred, Sender))
;
throw(error(permission_error(access, protected_predicate, Pred), Obj::Pred, Sender))))
;
('$lgt_built_in'(Pred) ->
call(Pred)
;
throw(error(existence_error(predicate_declaration, Pred), Obj::Pred, Sender))))
;
throw(error(existence_error(object, Obj), Obj::Pred, Sender))).
% '$lgt_send_to_super'(+object, ?term, +object, +object)
'$lgt_send_to_super'(Self, Pred, This, Sender) :-
nonvar(Pred) ->
'$lgt_send_to_super_nv'(Self, Pred, This, Sender)
;
throw(error(instantiation_error, ^^Pred, This)).
% '$lgt_send_to_super_nv'(+object, +term, +object, +object)
'$lgt_send_to_super_nv'(Self, Pred, This, Sender) :-
'$lgt_super_lookup_cache_'(Self, Pred, This, Sender, Call) ->
call(Call)
;
('$lgt_current_object_'(Self, _, Dcl, _, _, _),
('$lgt_call'(Dcl, Pred, Scope, _, _, SCtn, _) ->
((Scope = p(_); This = SCtn) ->
'$lgt_current_object_'(This, _, _, _, Super, _),
functor(Pred, Functor, Arity), functor(GPred, Functor, Arity),
functor(This, TName, TArity), functor(GThis, TName, TArity),
functor(Self, SName, SArity), functor(GSelf, SName, SArity),
'$lgt_once'(Super, GPred, GSender, GThis, GSelf, GCall, Ctn),
(Ctn \= GThis ->
asserta('$lgt_super_lookup_cache_'(GSelf, GPred, GThis, GSender, GCall)),
GSelf = Self, GPred = Pred, GThis = This, GSender = Sender,
call(GCall)
;
throw(error(endless_loop(Pred), ^^Pred, This)))
;
throw(error(permission_error(access, private_predicate, Pred), ^^Pred, This)))
;
('$lgt_built_in'(Pred) ->
call(Pred)
;
throw(error(existence_error(predicate_declaration, Pred), ^^Pred, This))))).
% '$lgt_metacall_in_object'(+object, ?term, +object)
%
% metacalls in predicate definitions
'$lgt_metacall_in_object'(Obj, Pred, Sender) :-
var(Pred) ->
throw(error(instantiation_error, Obj::call(Pred), Sender))
;
(Obj = user ->
call(Pred)
;
'$lgt_current_object_'(Obj, Prefix, _, _, _, _),
'$lgt_context'(Ctx, Sender, Obj, Obj, Prefix, _),
'$lgt_tr_body'(Pred, Call, DCall, Ctx),
(('$lgt_dbg_debugging_', '$lgt_debugging_'(Obj)) ->
call(DCall)
;
call(Call))).
% '$lgt_call_built_in'(+term, +term)
%
% needed for runtime translation of dynamic clauses
'$lgt_call_built_in'(Pred, Ctx) :-
'$lgt_context'(Ctx, Sender, This, Self, _, _),
'$lgt_current_object_'(This, _, _, Def, _, _),
('$lgt_call'(Def, Pred, Sender, This, Self, Call) ->
call(Call)
;
call(Pred)).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% built-in pseudo-object object table clauses
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
'$lgt_current_object_'(user, '$lgt_po_user0_', '$lgt_po_user0__dcl', '$lgt_po_user0__def', _, static).
'$lgt_current_object_'(debugger, '$lgt_po_debugger0_', '$lgt_po_debugger0__dcl', '$lgt_po_debugger0__def', _, static).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% built-in pseudo-object user
%
% represents the Prolog database (excluding built-in predicates)
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% the following clauses correspond to a virtual
% compilation of the pseudo-object user
'$lgt_po_user0_'('$lgt_po_user0__dcl', '$lgt_po_user0__def', _, _, _, _, _).
'$lgt_po_user0__dcl'(Pred, p(p(p)), Type, no) :-
(nonvar(Pred) ->
\+ '$lgt_built_in'(Pred),
functor(Pred, Functor, Arity),
current_predicate(Functor/Arity)
;
current_predicate(Functor/Arity),
\+ '$lgt_hidden_functor'(Functor),
functor(Pred, Functor, Arity),
\+ '$lgt_built_in'(Pred)),
('$lgt_predicate_property'(Pred, (dynamic)) ->
Type = (dynamic)
;
Type = static).
'$lgt_po_user0__dcl'(Pred, p(p(p)), Type, Meta, user, user) :-
'$lgt_po_user0__dcl'(Pred, p(p(p)), Type, Meta).
'$lgt_po_user0__def'(Pred, _, _, _, Pred).
'$lgt_po_user0__def'(Pred, _, _, _, Pred, user).
% '$lgt_hidden_functor'(+atom)
%
% hidden functors include Logtalk pre-processor and runtime internal functors
% and those used in the compiled code of objects, protocols, and categories
'$lgt_hidden_functor'(Functor) :-
atom_concat('$lgt_', _, Functor),
!.
'$lgt_hidden_functor'(Functor) :-
'$lgt_current_category_'(_, Prefix, _),
atom_concat(Prefix, _, Functor),
!.
'$lgt_hidden_functor'(Functor) :-
'$lgt_current_object_'(_, Prefix, _, _, _, _),
atom_concat(Prefix, _, Functor),
!.
'$lgt_hidden_functor'(Functor) :-
'$lgt_current_protocol_'(_, Prefix, _),
atom_concat(Prefix, _, Functor).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% built-in pseudo-object debugger
%
% implements the Logtalk buit-in debugging features
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% the following clauses correspond to a virtual
% compilation of the pseudo-object debugger
'$lgt_po_debugger0_'('$lgt_po_debugger0__dcl', '$lgt_po_debugger0__def', _, _, _, _, _).
% debugger public protocol
'$lgt_po_debugger0__dcl'(reset, p(p(p)), static, no).
'$lgt_po_debugger0__dcl'(debug, p(p(p)), static, no).
'$lgt_po_debugger0__dcl'(nodebug, p(p(p)), static, no).
'$lgt_po_debugger0__dcl'(debugging, p(p(p)), static, no).
'$lgt_po_debugger0__dcl'(trace, p(p(p)), static, no).
'$lgt_po_debugger0__dcl'(notrace, p(p(p)), static, no).
'$lgt_po_debugger0__dcl'(spy(_), p(p(p)), static, no).
'$lgt_po_debugger0__dcl'(spy(_, _, _, _), p(p(p)), static, no).
'$lgt_po_debugger0__dcl'(nospy(_), p(p(p)), static, no).
'$lgt_po_debugger0__dcl'(nospy(_, _, _, _), p(p(p)), static, no).
'$lgt_po_debugger0__dcl'(nospyall, p(p(p)), static, no).
'$lgt_po_debugger0__dcl'(leash(_), p(p(p)), static, no).
'$lgt_po_debugger0__dcl'(Pred, p(p(p)), Type, Meta, debugger, debugger) :-
'$lgt_po_debugger0__dcl'(Pred, p(p(p)), Type, Meta).
'$lgt_po_debugger0__def'(reset, _, _, _, '$lgt_dbg_reset').
'$lgt_po_debugger0__def'(debug, _, _, _, '$lgt_dbg_debug').
'$lgt_po_debugger0__def'(debugging, _, _, _, '$lgt_dbg_debugging').
'$lgt_po_debugger0__def'(nodebug, _, _, _, '$lgt_dbg_nodebug').
'$lgt_po_debugger0__def'(trace, _, _, _, '$lgt_dbg_trace').
'$lgt_po_debugger0__def'(notrace, _, _, _, '$lgt_dbg_notrace').
'$lgt_po_debugger0__def'(spy(Preds), _, _, _, '$lgt_dbg_spy'(Preds)).
'$lgt_po_debugger0__def'(nospy(Preds), _, _, _, '$lgt_dbg_nospy'(Preds)).
'$lgt_po_debugger0__def'(spy(Sender, This, Self, Goal), _, _, _, '$lgt_dbg_spy'(Sender, This, Self, Goal)).
'$lgt_po_debugger0__def'(nospy(Sender, This, Self, Goal), _, _, _, '$lgt_dbg_nospy'(Sender, This, Self, Goal)).
'$lgt_po_debugger0__def'(nospyall, _, _, _, '$lgt_dbg_nospyall').
'$lgt_po_debugger0__def'(leash(Ports), _, _, _, '$lgt_dbg_leash'(Ports)).
'$lgt_po_debugger0__def'(Pred, _, _, _, Call, debugger) :-
'$lgt_po_debugger0__def'(Pred, _, _, _, Call).
'$lgt_dbg_reset' :-
'$lgt_dbg_nospyall',
'$lgt_dbg_leash'(full),
'$lgt_dbg_nodebug'.
'$lgt_dbg_debug' :-
'$lgt_dbg_debugging_' ->
write('Debugger is on: showing spy points for all objects compiled in debug mode.'), nl
;
assertz('$lgt_dbg_debugging_'),
retractall('$lgt_dbg_tracing_'),
write('Debugger switched on: showing spy points for all objects compiled in debug mode.'), nl.
'$lgt_dbg_nodebug' :-
'$lgt_dbg_debugging_' ->
retractall('$lgt_dbg_debugging_'),
retractall('$lgt_dbg_tracing_'),
write('Debugger switched off.'), nl
;
write('Debugger is off.'), nl.
'$lgt_dbg_trace' :-
'$lgt_dbg_tracing_' ->
write('Debugger is on: tracing everything for all objects compiled in debug mode.'), nl
;
assertz('$lgt_dbg_tracing_'),
retractall('$lgt_dbg_debugging_'),
assertz('$lgt_dbg_debugging_'),
write('Debugger switched on: tracing everything for all objects compiled in debug mode.'), nl.
'$lgt_dbg_notrace' :-
'$lgt_dbg_tracing_' ->
retractall('$lgt_dbg_tracing_'),
retractall('$lgt_dbg_debugging_'),
write('Debugger switched off.'), nl
;
write('Debugger is off.'), nl.
'$lgt_dbg_debugging' :-
('$lgt_dbg_debugging_' ->
write('Debugger is on: '),
('$lgt_dbg_tracing_' ->
write('tracing everything.'), nl
;
write('showing spy points.'), nl)
;
write('Debugger is off.'), nl), nl,
('$lgt_dbg_spying_'(_) ->
write('Defined predicate spy points (Functor/Arity):'), nl,
forall(
'$lgt_dbg_spying_'(Functor/Arity),
(write(' '), writeq(Functor), write('/'), write(Arity), nl))
;
write('No predicate spy points are defined.'), nl), nl,
('$lgt_dbg_spying_'(_, _, _, _) ->
write('Defined context spy points (Sender, This, Self, Goal):'), nl,
forall(
'$lgt_dbg_spying_'(Sender, This, Self, Goal),
(write(' '), '$lgt_dbg_pretty_print_spypoint'(Sender, This, Self, Goal), nl))
;
write('No context spy points are defined.'), nl), nl,
write('Leashed ports:'), nl, write(' '),
('$lgt_dbg_leashing_'(_) ->
forall(
'$lgt_dbg_leashing_'(Port),
(write(Port), write(' ')))
;
write('(none)')),
nl.
'$lgt_dbg_pretty_print_spypoint'(Sender, This, Self, Goal) :-
current_output(Output),
(var(Sender) -> write('_, '); '$lgt_pretty_print_vars_quoted'(Output, Sender), write(', ')),
(var(This) -> write('_, '); '$lgt_pretty_print_vars_quoted'(Output, This), write(', ')),
(var(Self) -> write('_, '); '$lgt_pretty_print_vars_quoted'(Output, Self), write(', ')),
(var(Goal) -> write('_'); '$lgt_pretty_print_vars_quoted'(Output, Goal)).
'$lgt_dbg_spy'(Preds) :-
nonvar(Preds),
'$lgt_dbg_spy_aux'(Preds),
write('Predicate spy points set.'), nl,
('$lgt_dbg_debugging_' ->
true
;
'$lgt_dbg_debug').
'$lgt_dbg_spy_aux'([]).
'$lgt_dbg_spy_aux'([Functor/Arity| Preds]) :-
nonvar(Functor),
nonvar(Arity),
('$lgt_dbg_spying_'(Functor/Arity) ->
true
;
assertz('$lgt_dbg_spying_'(Functor/Arity))),
'$lgt_dbg_spy_aux'(Preds).
'$lgt_dbg_spy_aux'(Functor/Arity) :-
nonvar(Functor),
nonvar(Arity),
('$lgt_dbg_spying_'(Functor/Arity) ->
true
;
assertz('$lgt_dbg_spying_'(Functor/Arity))).
'$lgt_dbg_nospy'(Preds) :-
'$lgt_dbg_nospy_aux'(Preds),
write('All matching predicate spy points removed.'), nl.
'$lgt_dbg_nospy_aux'(Preds) :-
var(Preds) ->
retractall('$lgt_dbg_spying_'(_))
;
'$lgt_dbg_nospy_aux2'(Preds).
'$lgt_dbg_nospy_aux2'([]).
'$lgt_dbg_nospy_aux2'([Functor/Arity| Preds]) :-
retractall('$lgt_dbg_spying_'(Functor/Arity)),
'$lgt_dbg_nospy_aux2'(Preds).
'$lgt_dbg_nospy_aux2'(Functor/Arity) :-
retractall('$lgt_dbg_spying_'(Functor/Arity)).
'$lgt_dbg_spy'(Sender, This, Self, Goal) :-
asserta('$lgt_dbg_spying_'(Sender, This, Self, Goal)),
write('Context spy point set.'), nl,
('$lgt_dbg_debugging_' ->
true
;
'$lgt_dbg_debug').
'$lgt_dbg_nospy'(Sender, This, Self, Goal) :-
retractall('$lgt_dbg_spying_'(Sender, This, Self, Goal)),
write('All matching context spy points removed.'), nl.
'$lgt_dbg_nospyall' :-
retractall('$lgt_dbg_spying_'(_)),
write('All predicate spy points removed.'), nl,
retractall('$lgt_dbg_spying_'(_, _, _, _)),
write('All context spy points removed.'), nl.
'$lgt_dbg_leash'(Value) :-
'$lgt_dbg_valid_leash_value'(Value, Ports),
retractall('$lgt_dbg_leashing_'(_)),
'$lgt_dbg_set_leash_ports'(Ports),
write('Debugger leash ports set to '), write(Ports), nl.
'$lgt_dbg_set_leash_ports'([]).
'$lgt_dbg_set_leash_ports'([Port| Ports]) :-
assertz('$lgt_dbg_leashing_'(Port)),
'$lgt_dbg_set_leash_ports'(Ports).
'$lgt_dbg_leashing_'(fact).
'$lgt_dbg_leashing_'(rule).
'$lgt_dbg_leashing_'(call).
'$lgt_dbg_leashing_'(exit).
'$lgt_dbg_leashing_'(redo).
'$lgt_dbg_leashing_'(fail).
'$lgt_dbg_leashing_'(exception).
'$lgt_dbg_valid_leash_value'(Shorthand, Ports) :-
atom(Shorthand),
!,
'$lgt_dbg_leash_shortand_ports'(Shorthand, Ports).
'$lgt_dbg_valid_leash_value'(Ports, Ports) :-
'$lgt_proper_list'(Ports),
'$lgt_dbg_valid_leash_ports'(Ports).
'$lgt_dbg_valid_leash_ports'([]).
'$lgt_dbg_valid_leash_ports'([Port| Ports]) :-
atom(Port),
'$lgt_dbg_valid_leash_port'(Port),
'$lgt_dbg_valid_leash_ports'(Ports).
'$lgt_dbg_valid_leash_port'(fact).
'$lgt_dbg_valid_leash_port'(rule).
'$lgt_dbg_valid_leash_port'(call).
'$lgt_dbg_valid_leash_port'(exit).
'$lgt_dbg_valid_leash_port'(redo).
'$lgt_dbg_valid_leash_port'(fail).
'$lgt_dbg_valid_leash_port'(exception).
'$lgt_dbg_leash_shortand_ports'(none, []).
'$lgt_dbg_leash_shortand_ports'(loose, [fact, rule, call]).
'$lgt_dbg_leash_shortand_ports'(half, [fact, rule, call, redo]).
'$lgt_dbg_leash_shortand_ports'(tight, [fact, rule, call, redo, fail, exception]).
'$lgt_dbg_leash_shortand_ports'(full, [fact, rule, call, exit, redo, fail, exception]).
'$lgt_dbg_leashing'(Port, Goal, Ctx, Code) :-
'$lgt_dbg_leashing_'(Port),
('$lgt_dbg_tracing_' ->
Code = ' '
;
'$lgt_dbg_spying'(Port, Goal, Ctx, Code)).
'$lgt_dbg_spying'(_, Goal, _, '+') :-
functor(Goal, Functor, Arity),
\+ \+ '$lgt_dbg_spying_'(Functor/Arity),
!.
'$lgt_dbg_spying'(_, Goal, Ctx, '*') :-
'$lgt_context'(Ctx, Sender, This, Self, _, _),
\+ \+ '$lgt_dbg_spying_'(Sender, This, Self, Goal).
'$lgt_dbg_fact'(Fact, Ctx) :-
'$lgt_dbg_debugging_',
\+ '$lgt_dbg_skipping_',
!,
'$lgt_dbg_port'(fact, Fact, _, Ctx, Action),
call(Action).
'$lgt_dbg_fact'(_, _).
'$lgt_dbg_head'(Head, Ctx) :-
'$lgt_dbg_debugging_',
\+ '$lgt_dbg_skipping_',
!,
'$lgt_dbg_port'(rule, Head, _, Ctx, Action),
call(Action).
'$lgt_dbg_head'(_, _).
'$lgt_dbg_goal'(Goal, TGoal, Ctx) :-
'$lgt_dbg_debugging_',
\+ '$lgt_dbg_skipping_',
!,
( '$lgt_dbg_port'(call, Goal, _, Ctx, CAction),
(CAction = skip ->
retractall('$lgt_dbg_skipping_'),
assertz('$lgt_dbg_skipping_'),
CAction2 = true
;
CAction2 = CAction),
call(CAction2),
catch(
call(TGoal),
Error,
('$lgt_dbg_port'(exception, Goal, Error, Ctx, TAction),
(TAction = fail -> fail; throw(Error)))),
( '$lgt_dbg_port'(exit, Goal, _, Ctx, EAction),
call(EAction)
;
'$lgt_dbg_port'(redo, Goal, _, Ctx, RAction),
(RAction = skip ->
retractall('$lgt_dbg_skipping_'),
assertz('$lgt_dbg_skipping_')),
fail
)
;
retractall('$lgt_dbg_skipping_'),
'$lgt_dbg_port'(fail, Goal, _, Ctx, _), fail
),
retractall('$lgt_dbg_skipping_').
'$lgt_dbg_goal'(_, TGoal, _) :-
call(TGoal).
'$lgt_dbg_port'(Port, Goal, Error, Ctx, Action) :-
'$lgt_dbg_debugging_',
!,
('$lgt_dbg_leashing'(Port, Goal, Ctx, Code) ->
repeat,
write(Code), '$lgt_dbg_write_port_name'(Port), writeq(Goal), write(' ? '),
catch('$lgt_read_single_char'(Option), _, fail),
'$lgt_dbg_valid_port_option'(Option, Port, Code),
catch('$lgt_dbg_do_port_option'(Option, Goal, Error, Ctx, Action), _, fail)
;
('$lgt_dbg_tracing_' ->
write(' '), '$lgt_dbg_write_port_name'(Port), writeq(Goal), nl
;
true),
Action = true
),
!.
'$lgt_dbg_port'(_, _, _, _, true).
'$lgt_dbg_write_port_name'(fact) :-
write(' Fact: ').
'$lgt_dbg_write_port_name'(rule) :-
write(' Rule: ').
'$lgt_dbg_write_port_name'(call) :-
write(' Call: ').
'$lgt_dbg_write_port_name'(exit) :-
write(' Exit: ').
'$lgt_dbg_write_port_name'(redo) :-
write(' Redo: ').
'$lgt_dbg_write_port_name'(fail) :-
write(' Fail: ').
'$lgt_dbg_write_port_name'(exception) :-
write(' Exception: ').
'$lgt_dbg_valid_port_option'(' ', _, _).
'$lgt_dbg_valid_port_option'(c, _, _).
'$lgt_dbg_valid_port_option'(l, _, _).
'$lgt_dbg_valid_port_option'(s, call, _).
'$lgt_dbg_valid_port_option'(s, redo, _).
'$lgt_dbg_valid_port_option'(f, _, _).
'$lgt_dbg_valid_port_option'(n, _, _).
'$lgt_dbg_valid_port_option'(@, _, _).
'$lgt_dbg_valid_port_option'(b, _, _).
'$lgt_dbg_valid_port_option'(a, _, _).
'$lgt_dbg_valid_port_option'(d, _, _).
'$lgt_dbg_valid_port_option'(x, _, _).
'$lgt_dbg_valid_port_option'(h, _, _).
'$lgt_dbg_valid_port_option'(?, _, _).
'$lgt_dbg_valid_port_option'(=, _, _).
'$lgt_dbg_valid_port_option'(*, _, ' ').
'$lgt_dbg_valid_port_option'(+, _, ' ').
'$lgt_dbg_valid_port_option'(-, _, +).
'$lgt_dbg_valid_port_option'(e, exception, _).
'$lgt_dbg_do_port_option'(' ', _, _, _, true).
'$lgt_dbg_do_port_option'(c, _, _, _, true).
'$lgt_dbg_do_port_option'(l, _, _, _, true) :-
retractall('$lgt_dbg_tracing_').
'$lgt_dbg_do_port_option'(s, _, _, _, skip).
'$lgt_dbg_do_port_option'(f, _, _, _, fail).
'$lgt_dbg_do_port_option'(n, _, _, _, true) :-
'$lgt_dbg_nodebug'.
'$lgt_dbg_do_port_option'(=, _, _, _, true) :-
'$lgt_dbg_debugging'.
'$lgt_dbg_do_port_option'(+, Goal, _, _, _) :-
(Goal = (_ :: Pred) ->
functor(Pred, Functor, Arity)
;
functor(Goal, Functor, Arity)),
'$lgt_dbg_spy'(Functor/Arity),
fail.
'$lgt_dbg_do_port_option'(-, Goal, _, _, true) :-
(Goal = (_ :: Pred) ->
functor(Pred, Functor, Arity)
;
functor(Goal, Functor, Arity)),
'$lgt_dbg_nospy'(Functor/Arity).
'$lgt_dbg_do_port_option'(*, Goal, _, _, true) :-
functor(Goal, Functor, Arity),
functor(CGoal, Functor, Arity),
write(' Enter a context spy point term formatted as (Sender, This, Self, Goal): '),
read(Spypoint),
Spypoint = (Sender, This, Self, CGoal),
'$lgt_dbg_spy'(Sender, This, Self, CGoal).
'$lgt_dbg_do_port_option'(@, _, _, _, _) :-
write(' ?- '),
read(Goal),
once((Goal; true)),
fail.
'$lgt_dbg_do_port_option'(b, _, _, _, _) :-
('$lgt_compiler_option'(supports_break_predicate, true) ->
break
;
write(' break no supportd on this Prolog compiler.'), nl),
fail.
'$lgt_dbg_do_port_option'(a, _, _, _, _) :-
throw(error(logtalk_debugger_aborted)).
'$lgt_dbg_do_port_option'(d, Goal, _, _, _) :-
write(' Current goal: '), write_term(Goal, [ignore_ops(true)]), nl,
fail.
'$lgt_dbg_do_port_option'(x, _, _, Ctx, _) :-
'$lgt_context'(Ctx, Sender, This, Self, _, _),
write(' Sender: '), writeq(Sender), nl,
write(' This: '), writeq(This), nl,
write(' Self: '), writeq(Self), nl,
fail.
'$lgt_dbg_do_port_option'(e, _, Error, _, _) :-
write(' Exception term: '), writeq(Error), nl,
fail.
'$lgt_dbg_do_port_option'(h, _, _, _, _) :-
write(' Available options are:'), nl,
write(' c - creep (go on; you may use the spacebar in alternative)'), nl,
write(' l - leep (continues execution until the next spy point is found)'), nl,
write(' s - skip (skips debugging for the current goal; only valid at call and redo ports)'), nl,
write(' f - fail (forces backtracking)'), nl,
write(' n - nodebug (turns off debugging)'), nl,
write(' @ - command (reads and executes a query)'), nl,
write(' b - break (suspends execution and starts new interpreter; type end_of_file to terminate)'), nl,
write(' a - abort (returns to top level interpreter)'), nl,
write(' d - display (writes current goal without using operator notation)'), nl,
write(' x - context (prints execution context)'), nl,
write(' e - exception (prints exception term thrown by current goal)'), nl,
write(' = - debugging (prints debugging information)'), nl,
write(' * - add (adds a context spy point for current goal)'), nl,
write(' + - add (adds a predicate spy point for current goal)'), nl,
write(' - - remove (removes a predicate spy point for current goal)'), nl,
write(' h - help (prints this list of options)'), nl,
fail.
'$lgt_dbg_do_port_option'(?, Goal, Error, Ctx, Action) :-
'$lgt_dbg_do_port_option'(h, Goal, Error, Ctx, Action).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% pre-processor - compiles Logtalk source files to Prolog
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% '$lgt_split_metafile'(+atom, +list, -atom, -atom)
%
% splits a metafile into individual entity files plus a loading
% and a compiling helper files (returning their names)
'$lgt_split_metafile'(Source, Options, Loader, Compiler) :-
atom_concat(Source, '_load', Loader),
atom_concat(Source, '_compile', Compiler),
'$lgt_split_metafile_aux'(Source, Options, Loader, Compiler).
'$lgt_split_metafile_aux'(Source, _, Loader, Compiler) :-
'$lgt_compiler_option'(smart_compilation, on),
\+ '$lgt_needs_resplitting'(Source, Loader, Compiler),
!.
'$lgt_split_metafile_aux'(Source, Options, Loader, Compiler) :-
('$lgt_compiler_option'(report, on) ->
write('>>> splitting metafile '), writeq(Source), write('...'), nl
;
true),
'$lgt_file_name'(metafile, Source, Metafile),
catch(
(open(Metafile, read, Stream),
read_term(Stream, Term, []),
'$lgt_copy_metafile_term'(Stream, Term, Cache, Entities)),
Error,
'$lgt_compiler_error_handler'(Stream, Error)),
'$lgt_create_aux_files'(Source, Options, Loader, Compiler, Cache, Entities),
('$lgt_compiler_option'(report, on) ->
write('>>> metafile '), writeq(Source), write(' split'), nl
;
true).
% '$lgt_needs_resplitting'(+atom, +atom, +atom)
%
% true when a source metafile needs resplitting; assumes that the user does
% not temper with the files generated by the splitting of the metafile
'$lgt_needs_resplitting'(_, Loader, _) :-
'$lgt_file_name'(logtalk, Loader, LoaderFile),
\+ '$lgt_file_exists'(LoaderFile),
!.
'$lgt_needs_resplitting'(Source, _, Compiler) :-
'$lgt_file_name'(logtalk, Compiler, CompilerFile),
(\+ '$lgt_file_exists'(CompilerFile) ->
true
;
'$lgt_file_name'(metafile, Source, Metafile),
('$lgt_compare_file_mtimes'(Result, Metafile, CompilerFile) ->
Result = (>)
;
true)).
% '$lgt_create_aux_files'(+atom, +atom, +atom, +list, +list)
%
% creates a loading and a compiling helper files given a list of entities
'$lgt_create_aux_files'(Source, Options, Loader, Compiler, Cache, Names) :-
'$lgt_file_name'(metafile, Source, Metafile),
'$lgt_file_name'(logtalk, Loader, LoaderFile),
'$lgt_file_name'(logtalk, Compiler, CompilerFile),
'$lgt_reverse'(Names, Names2),
'$lgt_reverse'(Cache, Cache2),
('$lgt_compiler_option'(report, on) ->
write('> creating loading helper file '), write(Loader), write('...'), nl
;
true),
catch(
(open(LoaderFile, write, LoaderStream),
write_term(LoaderStream, '% loader file automatically generated from source metafile ', []),
write_term(LoaderStream, Metafile, []), nl(LoaderStream), nl(LoaderStream),
write_canonical(LoaderStream, (:- initialization(logtalk_load(Names2, Options)))),
write_term(LoaderStream, '.', []), nl(LoaderStream),
'$lgt_copy_cached_metafile_terms'(Cache2, LoaderStream)),
Error,
'$lgt_compiler_error_handler'(LoaderStream, Error)),
close(LoaderStream),
('$lgt_compiler_option'(report, on) ->
write('> loading helper file '), write(Loader), write(' created'), nl,
write('> creating compiling helper file '), write(Compiler), write('...'), nl
;
true),
catch(
(open(CompilerFile, write, CompilerStream),
write_term(CompilerStream, '% compiler file automatically generated from source metafile ', []),
write_term(CompilerStream, Metafile, []), nl(CompilerStream), nl(CompilerStream),
write_canonical(CompilerStream, (:- initialization(logtalk_compile(Names2, Options)))),
write_term(CompilerStream, '.', []), nl(CompilerStream)),
Error,
'$lgt_compiler_error_handler'(CompilerStream, Error)),
close(CompilerStream),
('$lgt_compiler_option'(report, on) ->
write('> compiling helper file '), write(Compiler), write(' created'), nl
;
true).
% '$lgt_copy_cached_metafile_terms'(+list, +atom)
%
% copies cached terms which occurs before an entity
% definition to the entity source file
'$lgt_copy_cached_metafile_terms'([], _).
'$lgt_copy_cached_metafile_terms'([Term| Terms], Stream) :-
write_canonical(Stream, Term),
write_term(Stream, '.', []), nl(Stream),
'$lgt_copy_cached_metafile_terms'(Terms, Stream).
% '$lgt_copy_metafile_term'(+atom, @term, -list,-list)
%
% copies a term to either a cache or to an entity source file
% returning cached read terms and a list of extracted entities
'$lgt_copy_metafile_term'(Input, Term, Cache, Names) :-
'$lgt_copy_metafile_term'(Input, Term, [], Cache, [], Names).
'$lgt_copy_metafile_term'(Input, end_of_file, Cache, Cache, Names, Names) :-
!,
close(Input).
'$lgt_copy_metafile_term'(_, Term, _, _, _, _) :-
Term =.. [(:-), Directive],
'$lgt_closing_entity_directive'(Directive, Type),
throw(entity_opening_directive_missing(Type)).
'$lgt_copy_metafile_term'(Input, Term, CacheAcc, Cache, Acc, Names) :-
Term =.. [(:-), Directive],
'$lgt_opening_entity_directive'(Directive, Type, Entity),
!,
('$lgt_compiler_option'(report, on) ->
write('> extracting '), write(Type), write(' '),
current_output(Current), '$lgt_pretty_print_vars_quoted'(Current, Entity),
write('...'), nl
;
true),
(atom(Entity) ->
Name = Entity
;
functor(Entity, Functor, Arity),
number_codes(Arity, Codes),
atom_codes(Atom, Codes),
atom_concat(Functor, Atom, Name)),
'$lgt_file_name'(logtalk, Name, File),
open(File, write, Output),
'$lgt_copy_cached_metafile_terms'(CacheAcc, Output),
write_canonical(Output, Term),
write_term(Output, '.', []), nl(Output),
'$lgt_copy_metafile_entity_terms'(Input, Output, Type),
('$lgt_compiler_option'(report, on) ->
write('> '), '$lgt_pretty_print_vars_quoted'(Current, Entity),
write(' extracted '), nl
;
true),
read_term(Input, Next, []),
'$lgt_copy_metafile_term'(Input, Next, [], Cache, [Name| Acc], Names).
'$lgt_copy_metafile_term'(Input, Term, CacheAcc, Cache, Acc, Names) :-
read_term(Input, Next, []),
'$lgt_copy_metafile_term'(Input, Next, [Term| CacheAcc], Cache, Acc, Names).
% '$lgt_copy_metafile_entity_terms'(+atom, +atom, +atom)
%
% copies entity terms from the source metafile to an entity source file
'$lgt_copy_metafile_entity_terms'(Input, Output, Type) :-
read_term(Input, Term, []),
(Term = end_of_file ->
throw(entity_closing_directive_missing(Type))
;
write_canonical(Output, Term),
write_term(Output, '.', []), nl(Output),
((Term =.. [(:-), Directive], '$lgt_closing_entity_directive'(Directive, Type2)) ->
(Type = Type2 ->
close(Output)
;
throw(entity_enclosing_directives_mismatch(Type, Type2)))
;
'$lgt_copy_metafile_entity_terms'(Input, Output, Type))).
% '$lgt_copy_metafile_entity_terms'(+directive, -atom, -entity_identifier)
'$lgt_opening_entity_directive'(object(Entity), object, Entity).
'$lgt_opening_entity_directive'(object(Entity, _), object, Entity).
'$lgt_opening_entity_directive'(object(Entity, _, _), object, Entity).
'$lgt_opening_entity_directive'(object(Entity, _, _, _), object, Entity).
'$lgt_opening_entity_directive'(object(Entity, _, _, _, _), object, Entity).
'$lgt_opening_entity_directive'(protocol(Entity), protocol, Entity).
'$lgt_opening_entity_directive'(protocol(Entity, _), protocol, Entity).
'$lgt_opening_entity_directive'(category(Entity), category, Entity).
'$lgt_opening_entity_directive'(category(Entity, _), category, Entity).
% '$lgt_closing_entity_directive'(+directive, -entity_identifier)
'$lgt_closing_entity_directive'(end_object, object).
'$lgt_closing_entity_directive'(end_protocol, protocol).
'$lgt_closing_entity_directive'(end_category, category).
% '$lgt_load_entities'(+list, +list)
%
% compiles to disk and then loads to memory a list of entities
'$lgt_load_entities'([], _).
'$lgt_load_entities'([Entity| Entities], Options) :-
'$lgt_load_entity'(Entity, Options),
'$lgt_load_entities'(Entities, Options).
% '$lgt_load_entity'(+atom, +list)
%
% compiles to disk and then loads to memory an entity
'$lgt_load_entity'(Term, Options) :-
compound(Term),
!,
Term =.. [Library, Entity],
once(logtalk_library_path(Library, Path)),
'$lgt_current_directory'(Current),
'$lgt_change_directory'(Path),
'$lgt_load_entity'(Entity, Options),
'$lgt_change_directory'(Current).
'$lgt_load_entity'(Entity, Options) :-
'$lgt_file_name'(metafile, Entity, Metafile),
'$lgt_file_exists'(Metafile),
!,
'$lgt_split_metafile'(Entity, Options, Loader, _),
'$lgt_load_entity'(Loader, Options).
'$lgt_load_entity'(Entity, Options) :-
'$lgt_compile_entity'(Entity, Options),
('$lgt_redefined_entity'(Entity, Type, Identifier) ->
'$lgt_clean_redefined_entity'(Type, Identifier),
'$lgt_report_redefined_entity'(Type, Identifier)
;
true),
'$lgt_file_name'(prolog, Entity, File),
'$lgt_load_prolog_code'(File),
'$lgt_report_loaded_entity'(Entity),
'$lgt_clean_lookup_caches'.
% '$lgt_redefined_entity'(+atom, -atom)
%
% true if an entity of the same name is already loaded
'$lgt_redefined_entity'(Entity, object, Entity) :- % non-parametric objects
'$lgt_current_object_'(Entity, _, _, _, _, _),
!.
'$lgt_redefined_entity'(Entity, object, Identifier) :- % parametric objects
'$lgt_compiler_option'(code_prefix, Atom), % (assuming that the code_prefix
atom_concat(Atom, Entity, Aux), % does not change between entity
atom_concat(Aux, '_', Prefix), % compilations)
'$lgt_current_object_'(Identifier, Prefix, _, _, _, _),
!.
'$lgt_redefined_entity'(Entity, protocol, Entity) :-
'$lgt_current_protocol_'(Entity, _, _),
!.
'$lgt_redefined_entity'(Entity, category, Entity) :-
'$lgt_current_category_'(Entity, _, _).
% '$lgt_clean_redefined_entity'(+atom, +entity_identifier)
%
% retract all clauses for all local dynamic
% predicates from a redefined entity
'$lgt_clean_redefined_entity'(object, Entity) :-
'$lgt_current_object_'(Entity, Prefix, _, _, _, _),
'$lgt_call'(Prefix, _, Def, _, _, _, _, DDef),
forall(
('$lgt_call'(Def, _, _, _, _, Head),
'$lgt_predicate_property'(Head, (dynamic))),
retractall(Head)),
forall(
('$lgt_call'(DDef, _, _, _, _, Head2),
'$lgt_predicate_property'(Head2, (dynamic))),
retractall(Head2)).
'$lgt_clean_redefined_entity'(protocol, _).
'$lgt_clean_redefined_entity'(category, _).
% '$lgt_report_redefined_entity'(+atom, +entity_identifier)
%
% prints a warning for redefined entities
'$lgt_report_redefined_entity'(Type, Entity) :-
'$lgt_compiler_option'(report, on) ->
write('> WARNING! redefining '), write(Type), write(' '),
current_output(Output), '$lgt_pretty_print_vars'(Output, Entity), nl
;
true.
% '$lgt_report_up_to_date_entity'(+entity_identifier)
%
% prints a message that an entity is up-to-date
'$lgt_report_up_to_date_entity'(Entity) :-
'$lgt_compiler_option'(report, on) ->
nl, write('>>> compiling '), writeq(Entity), write('... up-to-date'), nl
;
true.
% '$lgt_report_compiling_entity'(+entity_identifier)
%
% prints a message that an entity is being compiled
'$lgt_report_compiling_entity'(Entity) :-
'$lgt_compiler_option'(report, on) ->
nl, write('>>> compiling '), writeq(Entity),
('$lgt_compiler_option'(debug, on) ->
write(' in debug mode...')
;
write('...')),
nl
;
true.
% '$lgt_report_compiled_entity'(+entity_identifier)
%
% prints a message that an entity is finished compiling
'$lgt_report_compiled_entity'(Entity) :-
'$lgt_compiler_option'(report, on) ->
write('>>> '), writeq(Entity), write(' compiled'), nl
;
true.
% '$lgt_report_loaded_entity'(+entity_identifier)
%
% prints a message that an entity finished loading
'$lgt_report_loaded_entity'(Entity) :-
'$lgt_compiler_option'(report, on) ->
write('<<< '), writeq(Entity), write(' loaded'), nl
;
true.
% '$lgt_compile_entities'(+list, +list)
%
% compiles to disk a list of entities
'$lgt_compile_entities'([], _).
'$lgt_compile_entities'([Entity| Entities], Options) :-
'$lgt_compile_entity'(Entity, Options),
'$lgt_compile_entities'(Entities, Options).
% '$lgt_compile_entity'(+atom, +list)
%
% compiles to disk an entity
'$lgt_compile_entity'(Term, Options) :-
compound(Term),
!,
Term =.. [Library, Entity],
once(logtalk_library_path(Library, Path)),
'$lgt_current_directory'(Current),
'$lgt_change_directory'(Path),
'$lgt_compile_entity'(Entity, Options),
'$lgt_change_directory'(Current).
'$lgt_compile_entity'(Entity, Options) :-
'$lgt_file_name'(metafile, Entity, Metafile),
'$lgt_file_exists'(Metafile),
!,
'$lgt_split_metafile'(Entity, Options, _, Compiler),
'$lgt_compile_entity'(Compiler, Options),
'$lgt_file_name'(prolog, Compiler, File),
'$lgt_load_prolog_code'(File).
'$lgt_compile_entity'(Entity, _) :-
'$lgt_compiler_option'(smart_compilation, on),
\+ '$lgt_needs_recompilation'(Entity),
!,
'$lgt_report_up_to_date_entity'(Entity).
'$lgt_compile_entity'(Entity, _) :-
'$lgt_report_compiling_entity'(Entity),
'$lgt_clean_pp_clauses',
'$lgt_tr_entity'(Entity),
'$lgt_write_tr_entity'(Entity),
'$lgt_write_entity_doc'(Entity),
'$lgt_report_unknown_entities',
'$lgt_report_compiled_entity'(Entity).
% '$lgt_needs_recompilation'(+atom)
%
% source file needs recompilation
'$lgt_needs_recompilation'(Entity) :-
'$lgt_file_name'(prolog, Entity, File),
\+ '$lgt_file_exists'(File),
!.
'$lgt_needs_recompilation'(Entity) :-
'$lgt_file_name'(xml, Entity, File),
'$lgt_compiler_option'(xml, on),
\+ '$lgt_file_exists'(File),
!.
'$lgt_needs_recompilation'(Entity) :-
'$lgt_file_name'(logtalk, Entity, Source),
'$lgt_file_name'(prolog, Entity, Object),
('$lgt_compare_file_mtimes'(Result, Source, Object) ->
Result = (>)
;
true).
% '$lgt_write_tr_entity'(+atom)
%
% writes to disk the entity compiled code
'$lgt_write_tr_entity'(Entity) :-
'$lgt_file_name'(prolog, Entity, File),
catch(
open(File, write, Stream),
Error,
'$lgt_compiler_error_handler'(Stream, Error)),
catch(
'$lgt_write_directives'(Stream),
Error,
'$lgt_compiler_error_handler'(Stream, Error)),
('$lgt_pp_entity'(_, _, _, _, _) ->
catch(
('$lgt_write_clauses'(Stream),
'$lgt_write_init_call'(Stream)),
Error,
'$lgt_compiler_error_handler'(Stream, Error))
;
true),
close(Stream).
% '$lgt_write_entity_doc'(+atom)
%
% writes to disk the entity documentation in XML format
'$lgt_write_entity_doc'(Entity) :-
'$lgt_pp_entity'(_, _, _, _, _) ->
('$lgt_compiler_option'(xml, on) ->
'$lgt_file_name'(xml, Entity, File),
catch(
open(File, write, Stream),
Error,
'$lgt_compiler_error_handler'(Stream, Error)),
catch(
'$lgt_write_xml_file'(Stream),
Error,
'$lgt_compiler_error_handler'(Stream, Error)),
close(Stream)
;
true)
;
true.
% '$lgt_file_name'(+atom, +atom, -atom)
%
% constructs a filename given the type of file and the entity name
'$lgt_file_name'(Type, Entity, File) :-
'$lgt_file_extension'(Type, Extension),
(('$lgt_compiler_option'(altdirs, on), '$lgt_alt_directory'(Type, Directory)) ->
'$lgt_make_directory'(Directory),
atom_concat(Entity, Extension, Aux),
atom_concat(Directory, Aux, File)
;
atom_concat(Entity, Extension, File)).
% '$lgt_tr_entity'(+atom)
%
% compiles an entity storing the resulting code in memory
'$lgt_tr_entity'(Entity) :-
'$lgt_file_name'(logtalk, Entity, File),
catch(
open(File, read, Stream),
Error,
'$lgt_compiler_error_handler'(Stream, Error)),
'$lgt_save_op_table',
catch(
(read_term(Stream, Term, [singletons(Singletons1)]),
'$lgt_filter_dont_care_vars'(Singletons1, Singletons2),
'$lgt_report_singletons'(Singletons2, Term),
'$lgt_tr_file'(Stream, Term)),
Error,
'$lgt_compiler_error_handler'(Stream, Error)),
'$lgt_restores_op_table',
close(Stream),
'$lgt_fix_redef_built_ins',
'$lgt_find_misspelt_calls',
('$lgt_pp_entity'(Type, _, _, _, _) ->
'$lgt_gen_clauses'(Type),
'$lgt_gen_directives'(Type)
;
true). % source file containing no entity definition
% '$lgt_tr_file'(+stream, +term)
'$lgt_tr_file'(_, end_of_file) :-
!.
'$lgt_tr_file'(Stream, Term) :-
'$lgt_tr_term'(Term),
read_term(Stream, Next, [singletons(Singletons1)]),
'$lgt_filter_dont_care_vars'(Singletons1, Singletons2),
'$lgt_report_singletons'(Singletons2, Next),
'$lgt_tr_file'(Stream, Next).
% '$lgt_filter_dont_care_vars'(+list, -list)
%
% filter variables whose name start with an underscore from a
% singletons list if the corresponding compiler option sets their
% interpretation to don't care variables
'$lgt_filter_dont_care_vars'(List, Result) :-
'$lgt_compiler_option'(underscore_vars, dont_care) ->
'$lgt_filter_dont_care_vars'(List, [], Result)
;
List = Result.
'$lgt_filter_dont_care_vars'([], Result, Result).
'$lgt_filter_dont_care_vars'([Atom = Var| List], Sofar, Result) :-
sub_atom(Atom, 0, 1, _, '_') ->
'$lgt_filter_dont_care_vars'(List, Sofar, Result)
;
'$lgt_filter_dont_care_vars'(List, [Atom = Var| Sofar], Result).
% '$lgt_report_singletons'(+list, +term)
%
% report the singleton variables found while compiling an entity term
'$lgt_report_singletons'([], _).
'$lgt_report_singletons'([Singleton| Singletons], Term) :-
('$lgt_compiler_option'(singletons, warning),
'$lgt_compiler_option'(report, on)) ->
write('> WARNING!'),
\+ \+ ( '$lgt_report_singletons_aux'([Singleton| Singletons], Term, Names),
write(' singleton variables: '), write(Names), nl,
(Term = (:- _) ->
write('> in directive: ')
;
write('> in clause: ')),
write(Term), nl)
;
true.
'$lgt_report_singletons_aux'([], _, []).
'$lgt_report_singletons_aux'([Name = Var| Singletons], Term, [Name| Names]) :-
Name = Var,
'$lgt_report_singletons_aux'(Singletons, Term, Names).
% '$lgt_compiler_error_handler'(@term, +term)
%
% closes the stream opened for reading the entity file, restores
% the operator table, and reports the compilation error found
'$lgt_compiler_error_handler'(Stream, Error) :-
(nonvar(Stream) ->
close(Stream)
;
true),
'$lgt_restores_op_table',
'$lgt_report_compiler_error'(Error),
throw(Error).
% '$lgt_report_compiler_error'(+term)
%
% reports a compilation error
'$lgt_report_compiler_error'(error(Error, directive(Directive))) :-
!,
write('> ERROR! '), writeq(Error), nl,
write('> in directive: '), writeq((:- Directive)), nl.
'$lgt_report_compiler_error'(error(Error, clause(Clause))) :-
!,
write('> ERROR! '), writeq(Error), nl,
write('> in clause: '), writeq(Clause), nl.
'$lgt_report_compiler_error'(error(Error, dcgrule(Rule))) :-
!,
write('> ERROR! '), writeq(Error), nl,
write('> in grammar rule: '), writeq((Rule)), nl.
'$lgt_report_compiler_error'(error(Error, Term)) :-
!,
write('> ERROR! '), writeq(Error), nl,
write('> in: '), writeq(Term), nl.
'$lgt_report_compiler_error'(Error) :-
write('> ERROR! '), writeq(Error), nl.
% clean up all dynamic predicates used during entity compilation
'$lgt_clean_pp_clauses' :-
retractall('$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _)),
retractall('$lgt_pp_protocol_'(_, _, _, _)),
retractall('$lgt_pp_category_'(_, _, _, _, _)),
retractall('$lgt_pp_implemented_protocol_'(_, _, _, _)),
retractall('$lgt_pp_imported_category_'(_, _, _, _, _)),
retractall('$lgt_pp_extended_object_'(_, _, _, _, _, _, _, _, _, _)),
retractall('$lgt_pp_instantiated_class_'(_, _, _, _, _, _, _, _, _, _)),
retractall('$lgt_pp_specialized_class_'(_, _, _, _, _, _, _, _, _, _)),
retractall('$lgt_pp_extended_protocol_'(_, _, _, _)),
retractall('$lgt_pp_uses_'(_)),
retractall('$lgt_pp_uses_'(_, _)),
retractall('$lgt_pp_calls_'(_)),
retractall('$lgt_pp_info_'(_)),
retractall('$lgt_pp_info_'(_, _)),
retractall('$lgt_pp_directive_'(_)),
retractall('$lgt_pp_public_'(_)),
retractall('$lgt_pp_protected_'(_)),
retractall('$lgt_pp_private_'(_)),
retractall('$lgt_pp_dynamic_'(_)),
retractall('$lgt_pp_discontiguous_'(_)),
retractall('$lgt_pp_mode_'(_, _)),
retractall('$lgt_pp_metapredicate_'(_)),
retractall('$lgt_pp_alias_'(_, _, _)),
retractall('$lgt_pp_non_terminal_'(_, _, _)),
retractall('$lgt_pp_entity_init_'(_)),
retractall('$lgt_pp_fentity_init_'(_)),
retractall('$lgt_pp_dcl_'(_)),
retractall('$lgt_pp_ddcl_'(_)),
retractall('$lgt_pp_def_'(_)),
retractall('$lgt_pp_ddef_'(_)),
retractall('$lgt_pp_super_'(_)),
retractall('$lgt_pp_rclause_'(_)),
retractall('$lgt_pp_eclause_'(_)),
retractall('$lgt_pp_feclause_'(_)),
retractall('$lgt_pp_redefined_built_in_'(_, _, _)),
retractall('$lgt_pp_defs_pred_'(_)),
retractall('$lgt_pp_calls_pred_'(_)),
retractall('$lgt_pp_referenced_object_'(_)),
retractall('$lgt_pp_referenced_protocol_'(_)),
retractall('$lgt_pp_referenced_category_'(_)),
retractall('$lgt_pp_global_op_'(_, _, _)),
retractall('$lgt_pp_local_op_'(_, _, _)).
% '$lgt_clean_lookup_caches'
%
% clean method lookup caches
'$lgt_clean_lookup_caches' :-
retractall('$lgt_obj_lookup_cache_'(_, _, _, _)),
retractall('$lgt_self_lookup_cache_'(_, _, _, _)),
retractall('$lgt_super_lookup_cache_'(_, _, _, _, _)).
% '$lgt_clean_lookup_caches'(+callable)
%
% clean method lookup caches for the matching predicate
'$lgt_clean_lookup_caches'(Pred) :-
retractall('$lgt_obj_lookup_cache_'(_, Pred, _, _)),
retractall('$lgt_self_lookup_cache_'(_, Pred, _, _)),
retractall('$lgt_super_lookup_cache_'(_, Pred, _, _, _)).
% '$lgt_save_op_table'
%
% saves current operator table
'$lgt_save_op_table' :-
current_op(Pr, Spec, Op),
asserta('$lgt_pp_global_op_'(Pr, Spec, Op)),
fail.
'$lgt_save_op_table'.
% '$lgt_restores_op_table'
%
% restores current operator table
'$lgt_restores_op_table' :-
retract('$lgt_pp_local_op_'(_, Spec, Op)),
op(0, Spec, Op),
fail.
'$lgt_restores_op_table' :-
retractall('$lgt_pp_global_op_'(_, _, ',')), % ','/2 cannot be an argument to op/3
retract('$lgt_pp_global_op_'(Pr, Spec, Op)),
op(Pr, Spec, Op),
fail.
'$lgt_restores_op_table'.
% '$lgt_assert_local_ops'(+integer, +operator_specifier, +atom_or_atom_list)
%
% asserts local operators
'$lgt_assert_local_ops'(_, _, []) :-
!.
'$lgt_assert_local_ops'(Pr, Spec, [Op| Ops]) :-
!,
asserta('$lgt_pp_local_op_'(Pr, Spec, Op)),
'$lgt_assert_local_ops'(Pr, Spec, Ops).
'$lgt_assert_local_ops'(Pr, Spec, Op) :-
asserta('$lgt_pp_local_op_'(Pr, Spec, Op)).
% '$lgt_pp_entity'(?atom, ?entity_identifier, ?atom, ?atom, ?atom)
%
% provides access to some common used data on the entity being compiled
'$lgt_pp_entity'(object, Entity, Prefix, Dcl, Mode) :-
'$lgt_pp_object_'(Entity, Prefix, Dcl, _, _, _, _, _, _, Mode),
!.
'$lgt_pp_entity'(category, Entity, Prefix, Dcl, Mode) :-
'$lgt_pp_category_'(Entity, Prefix, Dcl, _, Mode),
!.
'$lgt_pp_entity'(protocol, Entity, Prefix, Dcl, Mode) :-
'$lgt_pp_protocol_'(Entity, Prefix, Dcl, Mode).
% '$lgt_pp_rclause'(-compound)
%
% returns runtime relation clauses for the entity being compiled
'$lgt_pp_rclause'(Clause) :-
'$lgt_pp_rclause_'(Clause).
'$lgt_pp_rclause'('$lgt_current_object_'(Obj, Prefix, Dcl, Def, Super, Mode)) :-
'$lgt_pp_object_'(Obj, Prefix, Dcl, Def, Super, _, _, _, _, Mode),
!.
'$lgt_pp_rclause'('$lgt_current_protocol_'(Ptc, Prefix, Mode)) :-
'$lgt_pp_protocol_'(Ptc, Prefix, _, Mode),
!.
'$lgt_pp_rclause'('$lgt_current_category_'(Ctg, Prefix, Mode)) :-
'$lgt_pp_category_'(Ctg, Prefix, _, _, Mode).
% '$lgt_tr_terms'(+list)
%
% translates a list of entity terms (clauses and/or directives)
'$lgt_tr_terms'([]).
'$lgt_tr_terms'([Term| Terms]) :-
'$lgt_tr_term'(Term),
'$lgt_tr_terms'(Terms).
% '$lgt_tr_term'(+term)
%
% translates an entity term (either a clause or a directive)
'$lgt_tr_term'((Head :- Body)) :-
!,
'$lgt_tr_clause'((Head :- Body)).
'$lgt_tr_term'((:- Directive)) :-
!,
'$lgt_tr_directive'(Directive).
'$lgt_tr_term'((Head --> Body)) :-
!,
'$lgt_dcgrule_to_clause'((Head --> Body), Clause),
'$lgt_tr_clause'(Clause).
'$lgt_tr_term'(Fact) :-
'$lgt_tr_clause'(Fact).
% '$lgt_tr_directives'(+list)
%
% translates a list of entity directives
'$lgt_tr_directives'([]).
'$lgt_tr_directives'([Dir| Dirs]) :-
'$lgt_tr_directive'(Dir),
'$lgt_tr_directives'(Dirs).
% '$lgt_tr_directive'(+term)
%
% translates an entity directive
'$lgt_tr_directive'(Dir) :-
var(Dir),
throw(error(instantiantion_error, directive(Dir))).
'$lgt_tr_directive'(Dir) :-
\+ '$lgt_pp_entity'(_, _, _, _, _), % directive occurs before opening entity directive
functor(Dir, Functor, Arity),
'$lgt_lgt_closing_directive'(Functor, Arity), % opening directive missing/misspelt
throw(error(unmatched_directive, directive(Dir))).
'$lgt_tr_directive'(Dir) :-
\+ '$lgt_pp_entity'(_, _, _, _, _), % directive occurs before opening entity directive
functor(Dir, Functor, Arity),
\+ '$lgt_lgt_opening_directive'(Functor, Arity),
!,
assertz('$lgt_pp_directive_'(Dir)), % directive will be copied to the generated Prolog file
(Dir = op(Pr, Spec, Ops) -> % op/3 directives must be used during entity compilation
op(Pr, Spec, Ops)
;
true).
'$lgt_tr_directive'(Dir) :-
functor(Dir, Functor, Arity),
'$lgt_lgt_directive'(Functor, Arity),
Dir =.. [Functor| Args],
catch(
'$lgt_tr_directive'(Functor, Args),
Error,
throw(error(Error, directive(Dir)))),
!.
'$lgt_tr_directive'(Dir) :-
throw(error(domain_error(directive, Dir), directive(Dir))).
% '$lgt_tr_directive'(+atom, +list)
%
% translates a directive and its (possibly empty) list of arguments
'$lgt_tr_directive'(object, [Obj| Rels]) :-
callable(Obj) ->
'$lgt_tr_object_id'(Obj, static), % assume static category
'$lgt_tr_object_relations'(Rels, Obj)
;
throw(type_error(object_identifier, Obj)).
'$lgt_tr_directive'(end_object, []) :-
'$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, _) ->
true
;
throw(closing_directive_mismatch).
'$lgt_tr_directive'(protocol, [Ptc| Rels]) :-
atom(Ptc) ->
'$lgt_tr_protocol_id'(Ptc, static), % assume static category
'$lgt_tr_protocol_relations'(Rels, Ptc)
;
throw(type_error(protocol_identifier, Ptc)).
'$lgt_tr_directive'(end_protocol, []) :-
'$lgt_pp_protocol_'(_, _, _, _) ->
true
;
throw(closing_directive_mismatch).
'$lgt_tr_directive'(category, [Ctg| Rels]) :-
atom(Ctg) ->
'$lgt_tr_category_id'(Ctg, static), % assume static category
'$lgt_tr_category_relations'(Rels, Ctg)
;
throw(type_error(category_identifier, Ctg)).
'$lgt_tr_directive'(end_category, []) :-
'$lgt_pp_category_'(_, _, _, _, _) ->
true
;
throw(closing_directive_mismatch).
% dynamic entity directive
'$lgt_tr_directive'((dynamic), []) :-
!,
'$lgt_update_entity_comp_mode'.
'$lgt_tr_directive'(initialization, [Goal]) :-
callable(Goal) ->
'$lgt_pp_entity'(_, Entity, Prefix, _, _),
'$lgt_context'(Ctx, Entity, Entity, Entity, Prefix, []),
'$lgt_tr_body'(Goal, TGoal, _, Ctx),
assertz('$lgt_pp_entity_init_'(TGoal))
;
throw(type_error(callable, Goal)).
'$lgt_tr_directive'(op, [Pr, Spec, Ops]) :-
'$lgt_valid_op_priority'(Pr) ->
('$lgt_valid_op_specifier'(Spec) ->
('$lgt_valid_op_names'(Ops) ->
op(Pr, Spec, Ops),
'$lgt_assert_local_ops'(Pr, Spec, Ops)
;
throw(type_error(operator_name, Ops)))
;
throw(type_error(operator_specifier, Spec)))
;
throw(type_error(operator_priority, Pr)).
'$lgt_tr_directive'(uses, [Obj, Preds]) :-
!,
(callable(Obj) ->
'$lgt_add_referenced_object'(Obj),
assertz('$lgt_pp_uses_'(Obj)),
('$lgt_proper_list'(Preds) ->
forall(
'$lgt_member'(Pred, Preds),
('$lgt_valid_pred_ind'(Pred) ->
Pred = Functor/Arity,
functor(Template, Functor, Arity),
(\+ '$lgt_pp_uses_'(_, Template) ->
assertz('$lgt_pp_uses_'(Obj, Template))
;
throw(permission_error(modify, uses_object_predicate, Functor/Arity)))
;
throw(type_error(predicate_indicator, Pred))))
;
throw(type_error(list, Preds)))
;
throw(type_error(object_identifier, Obj))).
'$lgt_tr_directive'(uses, [Obj]) :-
callable(Obj) ->
'$lgt_add_referenced_object'(Obj),
assertz('$lgt_pp_uses_'(Obj))
;
throw(type_error(object_identifier, Obj)).
'$lgt_tr_directive'(calls, Ptcs) :-
'$lgt_convert_to_list'(Ptcs, Ptcs2),
forall(
'$lgt_member'(Ptc, Ptcs2),
(atom(Ptc) ->
'$lgt_add_referenced_protocol'(Ptc),
assertz('$lgt_pp_calls_'(Ptc))
;
throw(type_error(protocol_identifier, Ptc)))).
'$lgt_tr_directive'(info, [List]) :-
!,
('$lgt_tr_entity_info_list'(List) ->
assertz('$lgt_pp_info_'(List))
;
throw(type_error(entity_info_list, List))).
'$lgt_tr_directive'(info, [Pred, List]) :-
once(('$lgt_valid_pred_ind'(Pred); '$lgt_valid_gr_ind'(Pred))) ->
'$lgt_tr_pred_info_list'(List, Pred),
assertz('$lgt_pp_info_'(Pred, List))
;
throw(type_error(predicate_indicator, Pred)).
'$lgt_tr_directive'((public), Preds) :-
'$lgt_convert_to_list'(Preds, Preds2),
forall(
'$lgt_member'(Pred, Preds2),
('$lgt_valid_pred_ind'(Pred) ->
assertz('$lgt_pp_public_'(Pred))
;
('$lgt_valid_gr_ind'(Pred) ->
Pred = Functor//Arity,
Arity2 is Arity + 2,
assertz('$lgt_pp_non_terminal_'(Functor, Arity, Arity2)),
assertz('$lgt_pp_public_'(Functor/Arity2))
;
throw(type_error(predicate_indicator, Pred))))).
'$lgt_tr_directive'(protected, Preds) :-
'$lgt_convert_to_list'(Preds, Preds2),
forall(
'$lgt_member'(Pred, Preds2),
('$lgt_valid_pred_ind'(Pred) ->
assertz('$lgt_pp_protected_'(Pred))
;
('$lgt_valid_gr_ind'(Pred) ->
Pred = Functor//Arity,
Arity2 is Arity + 2,
assertz('$lgt_pp_non_terminal_'(Functor, Arity, Arity2)),
assertz('$lgt_pp_protected_'(Functor/Arity2))
;
throw(type_error(predicate_indicator, Pred))))).
'$lgt_tr_directive'(private, Preds) :-
'$lgt_convert_to_list'(Preds, Preds2),
forall(
'$lgt_member'(Pred, Preds2),
('$lgt_valid_pred_ind'(Pred) ->
assertz('$lgt_pp_private_'(Pred))
;
('$lgt_valid_gr_ind'(Pred) ->
Pred = Functor//Arity,
Arity2 is Arity + 2,
assertz('$lgt_pp_non_terminal_'(Functor, Arity, Arity2)),
assertz('$lgt_pp_private_'(Functor/Arity2))
;
throw(type_error(predicate_indicator, Pred))))).
'$lgt_tr_directive'((dynamic), Preds) :-
'$lgt_convert_to_list'(Preds, Preds2),
forall(
'$lgt_member'(Pred, Preds2),
('$lgt_valid_pred_ind'(Pred) ->
assertz('$lgt_pp_dynamic_'(Pred))
;
('$lgt_valid_gr_ind'(Pred) ->
Pred = Functor//Arity,
Arity2 is Arity + 2,
assertz('$lgt_pp_dynamic_'(Functor/Arity2))
;
throw(type_error(predicate_indicator, Pred))))).
'$lgt_tr_directive'((discontiguous), Preds) :-
'$lgt_convert_to_list'(Preds, Preds2),
forall(
'$lgt_member'(Pred, Preds2),
('$lgt_valid_pred_ind'(Pred) ->
assertz('$lgt_pp_discontiguous_'(Pred))
;
('$lgt_valid_gr_ind'(Pred) ->
Pred = Functor//Arity,
Arity2 is Arity + 2,
assertz('$lgt_pp_discontiguous_'(Functor/Arity2))
;
throw(type_error(predicate_indicator, Pred))))).
'$lgt_tr_directive'(metapredicate, Preds) :-
'$lgt_convert_to_list'(Preds, Preds2),
forall(
'$lgt_member'(Pred, Preds2),
('$lgt_valid_metapred_term'(Pred) ->
assertz('$lgt_pp_metapredicate_'(Pred))
;
throw(type_error(metapredicate_term, Pred)))).
'$lgt_tr_directive'((mode), [Mode, Solutions]) :-
'$lgt_valid_mode_term'(Mode) ->
('$lgt_valid_number_of_solutions'(Solutions) ->
assertz('$lgt_pp_mode_'(Mode, Solutions))
;
throw(type_error(number_of_solutions, Solutions)))
;
throw(type_error(mode_term, Mode)).
'$lgt_tr_directive'(alias, [_, PI1, _]) :-
\+ '$lgt_valid_pred_ind'(PI1),
throw(type_error(predicate_indicator, PI1)).
'$lgt_tr_directive'(alias, [_, _, PI2]) :-
\+ '$lgt_valid_pred_ind'(PI2),
throw(type_error(predicate_indicator, PI2)).
'$lgt_tr_directive'(alias, [Entity, _, _]) :-
\+ callable(Entity),
throw(type_error(entity_identifier, Entity)).
'$lgt_tr_directive'(alias, [_, Functor1/Arity1, Functor2/Arity2]) :-
Arity1 =\= Arity2,
throw(domain_error(arity_mismatch, Functor1/Arity1, Functor2/Arity2)).
'$lgt_tr_directive'(alias, [Entity, PI1, PI2]) :-
('$lgt_pp_extended_protocol_'(Entity, _, _, _);
'$lgt_pp_implemented_protocol_'(Entity, _, _, _);
'$lgt_pp_imported_category_'(Entity, _, _, _, _);
'$lgt_pp_extended_object_'(Entity, _, _, _, _, _, _, _, _, _);
'$lgt_pp_instantiated_class_'(Entity, _, _, _, _, _, _, _, _, _);
'$lgt_pp_specialized_class_'(Entity, _, _, _, _, _, _, _, _, _)),
!,
'$lgt_tr_alias_directive'(Entity, PI1, PI2).
'$lgt_tr_directive'(alias, [Entity, _, _]) :-
throw(reference_error(entity_identifier, Entity)).
'$lgt_tr_alias_directive'(Entity, Functor1/Arity, Functor2/Arity) :-
functor(Pred, Functor1, Arity),
Pred =.. [_| Args],
Alias =.. [Functor2| Args],
assertz('$lgt_pp_alias_'(Entity, Pred, Alias)).
% '$lgt_tr_object_relations'(+list, +term)
%
% translates the relations of an object with other entities
'$lgt_tr_object_relations'([], _).
'$lgt_tr_object_relations'([Clause| Clauses], Obj) :-
Clause =.. [Functor| Args],
('$lgt_tr_object_relation'(Functor, Args, Obj) ->
'$lgt_tr_object_relations'(Clauses, Obj)
;
throw(domain_error(object_relation, Functor))).
% '$lgt_tr_object_relation'(+atom, +list, +term)
%
% translates a relation between an object (the last argument) with other entities
'$lgt_tr_object_relation'(implements, Ptcs, Obj) :-
'$lgt_convert_to_list'(Ptcs, List),
'$lgt_tr_implements_protocol'(List, Obj).
'$lgt_tr_object_relation'(imports, Ctgs, Obj) :-
'$lgt_convert_to_list'(Ctgs, List),
'$lgt_tr_imports_category'(List, Obj).
'$lgt_tr_object_relation'(instantiates, Classes, Obj) :-
'$lgt_convert_to_list'(Classes, List),
'$lgt_tr_instantiates_class'(List, Obj).
'$lgt_tr_object_relation'(specializes, Superclasses, Class) :-
'$lgt_convert_to_list'(Superclasses, List),
'$lgt_tr_specializes_class'(List, Class).
'$lgt_tr_object_relation'(extends, Parents, Prototype) :-
'$lgt_convert_to_list'(Parents, List),
'$lgt_tr_extends_object'(List, Prototype).
% '$lgt_tr_protocol_relations'(+list, +term)
%
% translates the relations of a protocol with other entities
'$lgt_tr_protocol_relations'([], _).
'$lgt_tr_protocol_relations'([Clause| Clauses], Obj) :-
Clause =.. [Functor| Args],
('$lgt_tr_protocol_relation'(Functor, Args, Obj) ->
'$lgt_tr_protocol_relations'(Clauses, Obj)
;
throw(domain_error(protocol_relation, Functor))).
% '$lgt_tr_protocol_relation'(+atom, +list, +term)
%
% translates a relation between a protocol (the last argument) with other entities
'$lgt_tr_protocol_relation'(extends, Ptcs, Ptc) :-
'$lgt_convert_to_list'(Ptcs, List),
'$lgt_tr_extends_protocol'(List, Ptc).
% '$lgt_tr_category_relations'(+list, +term)
%
% translates the relations of a category with other entities
'$lgt_tr_category_relations'([], _).
'$lgt_tr_category_relations'([Clause| Clauses], Obj) :-
Clause =.. [Functor| Args],
('$lgt_tr_category_relation'(Functor, Args, Obj) ->
'$lgt_tr_category_relations'(Clauses, Obj)
;
throw(domain_error(category_relation, Functor))).
% '$lgt_tr_category_relation'(+atom, +list, +term)
%
% translates a relation between a category (the last argument) with other entities
'$lgt_tr_category_relation'(implements, Ptcs, Ctg) :-
'$lgt_convert_to_list'(Ptcs, List),
'$lgt_tr_implements_protocol'(List, Ctg).
'$lgt_tr_category_relation'(imports, Ctgs, Ctg) :-
'$lgt_convert_to_list'(Ctgs, List),
'$lgt_tr_imports_category'(List, Ctg).
% '$lgt_tr_entity_info_list'(@list)
%
% true if the argument is a list of valid key-value pairs
'$lgt_tr_entity_info_list'(List) :-
var(List),
throw(instantiation_error).
'$lgt_tr_entity_info_list'(List) :-
\+ '$lgt_proper_list'(List),
throw(type_error(list, List)).
'$lgt_tr_entity_info_list'([]).
'$lgt_tr_entity_info_list'([Head| _]) :-
var(Head),
throw(instantiation_error).
'$lgt_tr_entity_info_list'([Head| _]) :-
Head \= (_ is _),
throw(type_error(key_value_info_pair, Head)).
'$lgt_tr_entity_info_list'([Key is Value| _]) :-
(var(Key); var(Value)),
throw(instantiation_error).
'$lgt_tr_entity_info_list'([Key is _| _]) :-
\+ atom(Key),
throw(type_error(atom, Key)).
'$lgt_tr_entity_info_list'([Key is Value| Tail]) :-
'$lgt_tr_entity_info_key_value'(Key, Value),
'$lgt_tr_entity_info_list'(Tail).
% '$lgt_tr_entity_info_key_value'(+atom, @nonvar)
%
% true if the argument is a valid key-value pair
'$lgt_tr_entity_info_key_value'(author, Author) :-
!,
(atom(Author) ->
true
;
throw(type_error(atom, Author))).
'$lgt_tr_entity_info_key_value'(comment, Comment) :-
!,
(atom(Comment) ->
true
;
throw(type_error(atom, Comment))).
'$lgt_tr_entity_info_key_value'(date, Date) :-
!,
(Date = Year/Month/Day ->
(integer(Year) ->
(integer(Month) ->
(integer(Day) ->
true
;
throw(type_error(integer, Day)))
;
throw(type_error(integer, Month)))
;
throw(type_error(integer, Year)))
;
throw(type_error(date, Date))).
'$lgt_tr_entity_info_key_value'(parnames, Parnames) :-
!,
('$lgt_proper_list'(Parnames) ->
(('$lgt_member'(Name, Parnames), \+ atom(Name)) ->
throw(type_error(atom, Name))
;
(('$lgt_pp_object_'(Obj, _, _, _, _, _, _, _, _, _),
\+ \+ Obj =.. [_| Parnames]) ->
true
;
throw(length_error(parnames_list, Parnames))))
;
throw(type_error(list, Parnames))).
'$lgt_tr_entity_info_key_value'(version, Version) :-
!,
(atomic(Version) ->
true
;
throw(type_error(atomic, Version))).
'$lgt_tr_entity_info_key_value'(_, _).
% '$lgt_tr_pred_info_list'(@list, @predicate_indicator)
%
% true if the argument is a list of valid key-value pairs
'$lgt_tr_pred_info_list'(List, _) :-
var(List),
throw(instantiation_error).
'$lgt_tr_pred_info_list'(List, _) :-
\+ '$lgt_proper_list'(List),
throw(type_error(list, List)).
'$lgt_tr_pred_info_list'([], _).
'$lgt_tr_pred_info_list'([Head| _], _) :-
var(Head),
throw(instantiation_error).
'$lgt_tr_pred_info_list'([Head| _], _) :-
Head \= (_ is _),
throw(type_error(key_value_info_pair, Head)).
'$lgt_tr_pred_info_list'([Key is Value| _], _) :-
(var(Key); var(Value)),
throw(instantiation_error).
'$lgt_tr_pred_info_list'([Key is _| _], _) :-
\+ atom(Key),
throw(type_error(atom, Key)).
'$lgt_tr_pred_info_list'([Key is Value| Tail], Pred) :-
'$lgt_tr_pred_info_key_value'(Key, Value, Pred),
'$lgt_tr_pred_info_list'(Tail, Pred).
% '$lgt_tr_pred_info_key_value'(+atom, @nonvar, @predicate_indicator)
%
% true if the argument is a valid key-value pair
'$lgt_tr_pred_info_key_value'(allocation, Allocation, _) :-
!,
(atom(Allocation) ->
('$lgt_member'(Allocation, [container, descendants, instances, classes, subclasses, any]) ->
true
;
throw(domain_error(allocation, Allocation)))
;
throw(type_error(atom, Allocation))).
'$lgt_tr_pred_info_key_value'(argnames, Argnames, Pred) :-
!,
once((Pred = Functor/Arity; Pred = Functor//Arity)),
('$lgt_proper_list'(Argnames) ->
(('$lgt_member'(Name, Argnames), \+ atom(Name)) ->
throw(type_error(atom, Name))
;
((functor(Pred2, Functor, Arity), Pred2 =.. [_| Argnames]) ->
true
;
throw(length_error(argnames_list, Argnames))))
;
throw(type_error(list, Argnames))).
'$lgt_tr_pred_info_key_value'(comment, Comment, _) :-
!,
(atom(Comment) ->
true
;
throw(type_error(atom, Comment))).
'$lgt_tr_pred_info_key_value'(exceptions, Exceptions, _) :-
!,
('$lgt_proper_list'(Exceptions) ->
(('$lgt_member'(Exception, Exceptions),
\+ (Exception = (Description - Term), atom(Description), nonvar(Term))) ->
throw(type_error(exception, Exception))
;
true)
;
throw(type_error(list, Exceptions))).
'$lgt_tr_pred_info_key_value'(redefinition, Redefinition, _) :-
!,
(atom(Redefinition) ->
('$lgt_member'(Redefinition, [never, free, specialize, call_super_first, call_super_last]) ->
true
;
throw(domain_error(redefinition, Redefinition)))
;
throw(type_error(atom, Redefinition))).
'$lgt_tr_pred_info_key_value'(_, _, _).
% '$lgt_tr_clauses'(+list)
'$lgt_tr_clauses'([]).
'$lgt_tr_clauses'([Clause| Clauses]) :-
'$lgt_tr_clause'(Clause),
'$lgt_tr_clauses'(Clauses).
% '$lgt_tr_clause'(+clause)
'$lgt_tr_clause'(Clause) :-
\+ '$lgt_pp_entity'(_, _, _, _, _), % clause occurs before opening entity directive
!,
assertz('$lgt_pp_feclause_'(Clause)).
'$lgt_tr_clause'(Clause) :-
'$lgt_pp_entity'(Type, Entity, Prefix, _, _),
((Type = object, compound(Entity)) -> % if the entity is a parametric object we need
'$lgt_this'(Ctx, Entity) % "this" for inline compilation of parameter/2
;
true),
'$lgt_prefix'(Ctx, Prefix),
catch(
'$lgt_tr_clause'(Clause, TClause, DClause, Ctx),
Error,
throw(error(Error, clause(Clause)))),
('$lgt_compiler_option'(debug, on) ->
assertz('$lgt_pp_eclause_'(DClause))
;
assertz('$lgt_pp_eclause_'(TClause))),
!.
'$lgt_tr_clause'(Clause) :-
throw(error(unknown_error, clause(Clause))).
% '$lgt_tr_clause'(+clause, -clause, -clause, +term)
'$lgt_tr_clause'((Head:-_), _, _, _) :-
\+ callable(Head),
throw(type_error(callable, Head)).
'$lgt_tr_clause'((Head:-Body), TClause, (THead:-'$lgt_dbg_head'(Head, Ctx),DBody), Ctx) :-
functor(Head, Functor, Arity),
'$lgt_pp_dynamic_'(Functor/Arity),
!,
'$lgt_extract_metavars'(Head, Metavars),
'$lgt_metavars'(Ctx, Metavars),
'$lgt_tr_head'(Head, THead, Ctx),
'$lgt_tr_body'(Body, TBody, DBody, Ctx),
'$lgt_simplify_body'(TBody, SBody),
TClause = (THead:-'$lgt_nop'(Body), SBody).
'$lgt_tr_clause'((Head:-Body), TClause, (THead:-'$lgt_dbg_head'(Head, Ctx),DBody), Ctx) :-
!,
'$lgt_extract_metavars'(Head, Metavars),
'$lgt_metavars'(Ctx, Metavars),
'$lgt_tr_head'(Head, THead, Ctx),
'$lgt_tr_body'(Body, TBody, DBody, Ctx),
'$lgt_simplify_body'(TBody, SBody),
(SBody == true ->
TClause = THead
;
TClause = (THead:-SBody)).
'$lgt_tr_clause'(Fact, _, _, _) :-
\+ callable(Fact),
throw(type_error(callable, Fact)).
'$lgt_tr_clause'(Fact, TFact, (TFact:-'$lgt_dbg_fact'(Fact, Ctx)), Ctx) :-
'$lgt_tr_head'(Fact, TFact, Ctx).
% '$lgt_tr_head'(+callable, -callable, +term)
%
% translates an entity clause head
% definition of dynamic predicates inside categories
'$lgt_tr_head'(Head, _, _) :-
'$lgt_pp_category_'(_, _, _, _, _),
functor(Head, Functor, Arity),
'$lgt_pp_dynamic_'(Functor/Arity),
throw(permission_error(define, dynamic_predicate, Functor/Arity)).
% redefinition of Logtalk message sending and external call control constructs
'$lgt_tr_head'(Term1::Term2, _, _) :-
throw(permission_error(modify, control_construct, Term1::Term2)).
'$lgt_tr_head'(::Term, _, _) :-
throw(permission_error(modify, control_construct, ::Term)).
'$lgt_tr_head'(^^Term, _, _) :-
throw(permission_error(modify, control_construct, ^^Term)).
'$lgt_tr_head'({Term}, _, _) :-
throw(permission_error(modify, control_construct, {Term})).
% redefinition of Logtalk built-in methods
'$lgt_tr_head'(Head, _, _) :-
'$lgt_built_in_method'(Head, _),
functor(Head, Functor, Arity),
throw(permission_error(modify, built_in_method, Functor/Arity)).
% conflict with a predicate specified in a uses/2 directive
'$lgt_tr_head'(Head, _, _) :-
'$lgt_pp_uses_'(_, Head),
functor(Head, Functor, Arity),
throw(permission_error(modify, uses_object_predicate, Functor/Arity)).
% redefinition of Logtalk built-in predicates
'$lgt_tr_head'(Head, _, _) :-
'$lgt_lgt_built_in'(Head),
'$lgt_compiler_option'(lgtredef, warning),
'$lgt_compiler_option'(report, on),
\+ '$lgt_pp_redefined_built_in_'(Head, _, _), % not already reported?
functor(Head, Functor, Arity),
write('> WARNING! redefining a Logtalk built-in predicate: '),
writeq(Functor/Arity), nl,
fail.
% redefinition of Prolog built-in predicates
'$lgt_tr_head'(Head, _, _) :-
'$lgt_pl_built_in'(Head),
'$lgt_compiler_option'(plredef, warning),
'$lgt_compiler_option'(report, on),
\+ '$lgt_pp_redefined_built_in_'(Head, _, _), % not already reported?
functor(Head, Functor, Arity),
write('> WARNING! redefining a Prolog built-in predicate: '),
writeq(Functor/Arity), nl,
fail.
% translate the head of a clause of a user defined predicate
'$lgt_tr_head'(Head, THead, Ctx) :-
functor(Head, Functor, Arity),
Head =.. [_| Args],
'$lgt_prefix'(Ctx, EPrefix),
'$lgt_construct_predicate_functor'(EPrefix, Functor, Arity, PPrefix),
(('$lgt_pp_dynamic_'(Functor/Arity),
\+ '$lgt_pp_public_'(Functor/Arity),
\+ '$lgt_pp_protected_'(Functor/Arity),
\+ '$lgt_pp_private_'(Functor/Arity)) ->
'$lgt_add_ddef_clause'(Functor, Arity, PPrefix, Ctx)
;
'$lgt_add_def_clause'(Functor, Arity, PPrefix, Ctx)),
'$lgt_context'(Ctx, Sender, This, Self, _, _),
'$lgt_append'(Args, [Sender, This, Self], Args2),
THead =.. [PPrefix| Args2].
% '$lgt_tr_body'(+callable, -callable, -callable, +term)
%
% translates an entity clause body
% meta-calls
'$lgt_tr_body'(Pred, TPred, '$lgt_dbg_goal'(Pred, TPred, Ctx), Ctx) :-
var(Pred),
!,
'$lgt_metavars'(Ctx, Metavars),
('$lgt_member_var'(Pred, Metavars) ->
'$lgt_sender'(Ctx, Sender),
TPred = '$lgt_metacall_in_object'(Sender, Pred, Sender)
;
'$lgt_this'(Ctx, This),
TPred = '$lgt_metacall_in_object'(This, Pred, This)).
% pre-processor bypass (call of external code)
'$lgt_tr_body'({Pred}, _, _, _) :-
var(Pred),
throw(instantiation_error).
'$lgt_tr_body'({Pred}, _, _, _) :-
\+ callable(Pred),
throw(type_error(callable, Pred)).
'$lgt_tr_body'({Pred}, Pred, '$lgt_dbg_goal'({Pred}, Pred, Ctx), Ctx) :-
!.
% bagof/3 and setof/3 existential quantifiers
'$lgt_tr_body'(Var^Pred, Var^TPred, Var^DPred, Ctx) :-
!,
'$lgt_tr_body'(Pred, TPred, DPred, Ctx).
% control constructs
'$lgt_tr_body'((Pred1, Pred2), (TPred1, TPred2), (DPred1, DPred2), Ctx) :-
!,
'$lgt_tr_body'(Pred1, TPred1, DPred1, Ctx),
'$lgt_tr_body'(Pred2, TPred2, DPred2, Ctx).
'$lgt_tr_body'((Pred1; Pred2), (TPred1; TPred2), (DPred1; DPred2), Ctx) :-
!,
'$lgt_tr_body'(Pred1, TPred1, DPred1, Ctx),
'$lgt_tr_body'(Pred2, TPred2, DPred2, Ctx).
'$lgt_tr_body'((Pred1 -> Pred2), (TPred1 -> TPred2), (DPred1 -> DPred2), Ctx) :-
!,
'$lgt_tr_body'(Pred1, TPred1, DPred1, Ctx),
'$lgt_tr_body'(Pred2, TPred2, DPred2, Ctx).
'$lgt_tr_body'(\+ Pred, \+ TPred, \+ DPred, Ctx) :-
!,
'$lgt_tr_body'(Pred, TPred, DPred, Ctx).
'$lgt_tr_body'(!, !, ('$lgt_dbg_goal'(!, true, Ctx), !), Ctx) :-
!.
'$lgt_tr_body'(true, true, '$lgt_dbg_goal'(true, true, Ctx), Ctx) :-
!.
'$lgt_tr_body'(fail, fail, '$lgt_dbg_goal'(fail, fail, Ctx), Ctx) :-
!.
'$lgt_tr_body'(repeat, repeat, '$lgt_dbg_goal'(repeat, repeat, Ctx), Ctx) :-
!.
'$lgt_tr_body'(call(Pred), TPred, DPred, Ctx) :-
!,
'$lgt_tr_body'(Pred, TPred, DPred, Ctx).
'$lgt_tr_body'(once(Pred), once(TPred), once(DPred), Ctx) :-
!,
'$lgt_tr_body'(Pred, TPred, DPred, Ctx).
'$lgt_tr_body'(catch(Goal, Catcher, Recovery), catch(TGoal, Catcher, TRecovery), '$lgt_dbg_goal'(catch(Goal, Catcher, Recovery), catch(DGoal, Catcher, DRecovery)), Ctx) :-
!,
'$lgt_tr_body'(Goal, TGoal, DGoal, Ctx),
'$lgt_tr_body'(Recovery, TRecovery, DRecovery, Ctx).
'$lgt_tr_body'(throw(Error), throw(Error), '$lgt_dbg_goal'(throw(Error), throw(Error), Ctx), Ctx) :-
!.
% built-in metapredicates
'$lgt_tr_body'(bagof(Term, Pred, List), bagof(Term, TPred, List), '$lgt_dbg_goal'(bagof(Term, Pred, List), bagof(Term, DPred, List), Ctx), Ctx) :-
!,
'$lgt_tr_body'(Pred, TPred, DPred, Ctx).
'$lgt_tr_body'(findall(Term, Pred, List), findall(Term, TPred, List), '$lgt_dbg_goal'(findall(Term, Pred, List), findall(Term, DPred, List), Ctx), Ctx) :-
!,
'$lgt_tr_body'(Pred, TPred, DPred, Ctx).
'$lgt_tr_body'(forall(Gen, Test), forall(TGen, TTest), '$lgt_dbg_goal'(forall(Gen, Test), forall(DGen, DTest), Ctx), Ctx) :-
!,
'$lgt_tr_body'(Gen, TGen, DGen, Ctx),
'$lgt_tr_body'(Test, TTest, DTest, Ctx).
'$lgt_tr_body'(setof(Term, Pred, List), setof(Term, TPred, List), '$lgt_dbg_goal'(setof(Term, Pred, List), setof(Term, DPred, List), Ctx), Ctx) :-
!,
'$lgt_tr_body'(Pred, TPred, DPred, Ctx).
% message sending
'$lgt_tr_body'(Obj::Pred, TPred, '$lgt_dbg_goal'(Obj::Pred, TPred, Ctx), Ctx) :-
!,
'$lgt_tr_msg'(Pred, Obj, TPred, Ctx).
'$lgt_tr_body'(::Pred, TPred, '$lgt_dbg_goal'(::Pred, TPred, Ctx), Ctx) :-
!,
'$lgt_tr_self_msg'(Pred, TPred, Ctx).
'$lgt_tr_body'(^^Pred, TPred, '$lgt_dbg_goal'(^^Pred, TPred, Ctx), Ctx) :-
!,
'$lgt_tr_super_sending'(Pred, TPred, Ctx).
% "reflection" built-in predicates
'$lgt_tr_body'(current_predicate(Pred), '$lgt_current_predicate'(This, Pred, This, _), '$lgt_dbg_goal'(current_predicate(Pred), '$lgt_current_predicate'(This, Pred, This, _), Ctx), Ctx) :-
!,
'$lgt_this'(Ctx, This).
'$lgt_tr_body'(predicate_property(Pred, Prop), '$lgt_predicate_property'(This, Pred, Prop, This, _), '$lgt_dbg_goal'(predicate_property(Pred, Prop), '$lgt_predicate_property'(This, Pred, Prop, This, _), Ctx), Ctx) :-
!,
'$lgt_this'(Ctx, This).
% database handling built-in predicates
'$lgt_tr_body'(abolish(Pred), '$lgt_abolish'(This, Pred, This, _), '$lgt_dbg_goal'(abolish(Pred), '$lgt_abolish'(This, Pred, This, _), Ctx), Ctx) :-
!,
'$lgt_this'(Ctx, This).
'$lgt_tr_body'(asserta(Pred), '$lgt_asserta'(This, Pred, This, _), '$lgt_dbg_goal'(asserta(Pred), '$lgt_asserta'(This, Pred, This, _), Ctx), Ctx) :-
!,
'$lgt_this'(Ctx, This).
'$lgt_tr_body'(assertz(Pred), '$lgt_assertz'(This, Pred, This, _), '$lgt_dbg_goal'(assertz(Pred), '$lgt_assertz'(This, Pred, This, _), Ctx), Ctx) :-
!,
'$lgt_this'(Ctx, This).
'$lgt_tr_body'(clause(Head, Body), '$lgt_clause'(This, Head, Body, This, _), '$lgt_dbg_goal'(clause(Head, Body), '$lgt_clause'(This, Head, Body, This, _), Ctx), Ctx) :-
!,
'$lgt_this'(Ctx, This).
'$lgt_tr_body'(retract(Pred), '$lgt_retract'(This, Pred, This, _), '$lgt_dbg_goal'(retract(Pred), '$lgt_retract'(This, Pred, This, _), Ctx), Ctx) :-
!,
'$lgt_this'(Ctx, This).
'$lgt_tr_body'(retractall(Pred), '$lgt_retractall'(This, Pred, This, _), '$lgt_dbg_goal'(retractall(Pred), '$lgt_retractall'(This, Pred, This, _), Ctx), Ctx) :-
!,
'$lgt_this'(Ctx, This).
% DCG predicates
'$lgt_tr_body'(expand_term(Term, Clause), '$lgt_expand_term'(This, Term, Clause, This, _), '$lgt_dbg_goal'(expand_term(Term, Clause), '$lgt_expand_term'(This, Term, Clause, This, _), Ctx), Ctx) :-
!,
'$lgt_this'(Ctx, This).
'$lgt_tr_body'(phrase(Ruleset, Input), '$lgt_phrase'(This, Ruleset, Input, This, _), '$lgt_dbg_goal'(phrase(Ruleset, Input), '$lgt_phrase'(This, Ruleset, Input, This, _), Ctx), Ctx) :-
!,
'$lgt_this'(Ctx, This).
'$lgt_tr_body'(phrase(Ruleset, Input, Rest), '$lgt_phrase'(This, Ruleset, Input, Rest, This, _), '$lgt_dbg_goal'(phrase(Ruleset, Input, Rest), '$lgt_phrase'(This, Ruleset, Input, Rest, This, _), Ctx), Ctx) :-
!,
'$lgt_this'(Ctx, This).
% inline methods (translated to a single unification with the corresponding context argument)
'$lgt_tr_body'(sender(Sender), true, '$lgt_dbg_goal'(sender(Temp), Sender=Temp, Ctx), Ctx) :-
!,
'$lgt_sender'(Ctx, Sender).
'$lgt_tr_body'(this(This), true, '$lgt_dbg_goal'(this(Temp), This=Temp, Ctx), Ctx) :-
!,
'$lgt_this'(Ctx, This).
'$lgt_tr_body'(self(Self), true, '$lgt_dbg_goal'(self(Temp), Self=Temp, Ctx), Ctx) :-
!,
'$lgt_self'(Ctx, Self).
'$lgt_tr_body'(parameter(Arg, Value), TPred, '$lgt_dbg_goal'(parameter(Arg, Temp), DPred, Ctx), Ctx) :-
!,
'$lgt_this'(Ctx, This),
(var(This) ->
TPred = arg(Arg, This, Value), % when using parameter/2 in categories
DPred = (TPred, Temp=Value)
;
arg(Arg, This, Value),
TPred = true,
DPred = (Temp=Value)).
% term input predicates that need to be operator aware
'$lgt_tr_body'(read_term(Stream, Term, Options), '$lgt_iso_read_term'(Stream, Term, Options, Ops), '$lgt_dbg_goal'(read_term(Stream, Term, Options), '$lgt_iso_read_term'(Stream, Term, Options, Ops), Ctx), Ctx) :-
bagof(op(Pr, Spec, Op), '$lgt_pp_local_op_'(Pr, Spec, Op), Ops),
!.
'$lgt_tr_body'(read_term(Term, Options), '$lgt_iso_read_term'(Term, Options, Ops), '$lgt_dbg_goal'(read_term(Term, Options), '$lgt_iso_read_term'(Term, Options, Ops), Ctx), Ctx) :-
bagof(op(Pr, Spec, Op), '$lgt_pp_local_op_'(Pr, Spec, Op), Ops),
!.
'$lgt_tr_body'(read(Stream, Term), '$lgt_iso_read'(Stream, Term, Ops), '$lgt_dbg_goal'(read(Stream, Term), '$lgt_iso_read'(Stream, Term, Ops), Ctx), Ctx) :-
bagof(op(Pr, Spec, Op), '$lgt_pp_local_op_'(Pr, Spec, Op), Ops),
!.
'$lgt_tr_body'(read(Term), '$lgt_iso_read'(Term, Ops), '$lgt_dbg_goal'(read(Term), '$lgt_iso_read'(Term, Ops), Ctx), Ctx) :-
bagof(op(Pr, Spec, Op), '$lgt_pp_local_op_'(Pr, Spec, Op), Ops),
!.
% term output predicates that need to be operator aware
'$lgt_tr_body'(write_term(Stream, Term, Options), '$lgt_iso_write_term'(Stream, Term, Options, Ops), '$lgt_dbg_goal'(write_term(Stream, Term, Options), '$lgt_iso_write_term'(Stream, Term, Options, Ops), Ctx), Ctx) :-
('$lgt_member'(ignore_ops(Value), Options) -> Value \== true; true),
bagof(op(Pr, Spec, Op), '$lgt_pp_local_op_'(Pr, Spec, Op), Ops),
!.
'$lgt_tr_body'(write_term(Term, Options), '$lgt_iso_write_term'(Term, Options, Ops), '$lgt_dbg_goal'(write_term(Term, Options), '$lgt_iso_write_term'(Term, Options, Ops), Ctx), Ctx) :-
('$lgt_member'(ignore_ops(Value), Options) -> Value \== true; true),
bagof(op(Pr, Spec, Op), '$lgt_pp_local_op_'(Pr, Spec, Op), Ops),
!.
'$lgt_tr_body'(write(Stream, Term), '$lgt_iso_write'(Stream, Term, Ops), '$lgt_dbg_goal'(write(Stream, Term), '$lgt_iso_write'(Stream, Term, Ops), Ctx), Ctx) :-
bagof(op(Pr, Spec, Op), '$lgt_pp_local_op_'(Pr, Spec, Op), Ops),
!.
'$lgt_tr_body'(write(Term), '$lgt_iso_write'(Term, Ops), '$lgt_dbg_goal'(write(Term), '$lgt_iso_write'(Term, Ops), Ctx), Ctx) :-
bagof(op(Pr, Spec, Op), '$lgt_pp_local_op_'(Pr, Spec, Op), Ops),
!.
'$lgt_tr_body'(writeq(Stream, Term), '$lgt_iso_writeq'(Stream, Term, Ops), '$lgt_dbg_goal'(writeq(Stream, Term), '$lgt_iso_writeq'(Stream, Term, Ops), Ctx), Ctx) :-
bagof(op(Pr, Spec, Op), '$lgt_pp_local_op_'(Pr, Spec, Op), Ops),
!.
'$lgt_tr_body'(writeq(Term), '$lgt_iso_writeq'(Term, Ops), '$lgt_dbg_goal'(writeq(Term), '$lgt_iso_writeq'(Term, Ops), Ctx), Ctx) :-
bagof(op(Pr, Spec, Op), '$lgt_pp_local_op_'(Pr, Spec, Op), Ops),
!.
% predicates specified in uses/2 directives
'$lgt_tr_body'(Pred, TPred, DPred, Ctx) :-
'$lgt_pp_uses_'(Obj, Pred),
!,
'$lgt_tr_body'(Obj::Pred, TPred, DPred, Ctx).
% Logtalk and Prolog built-in predicates
'$lgt_tr_body'(Pred, _, _, _) :-
'$lgt_pl_built_in'(Pred),
\+ '$lgt_iso_spec_pred'(Pred),
'$lgt_compiler_option'(portability, warning),
'$lgt_compiler_option'(report, on),
functor(Pred, Functor, Arity),
write('> WARNING! non-ISO defined built-in predicate call: '),
writeq(Functor/Arity), nl,
fail.
'$lgt_tr_body'(Pred, TPred, '$lgt_dbg_goal'(Pred, TPred, Ctx), Ctx) :-
'$lgt_pl_built_in'(Pred),
functor(Pred, Functor, Arity),
functor(Meta, Functor, Arity),
'$lgt_pl_metapredicate'(Meta),
!,
Pred =.. [_| Args],
Meta =.. [_| MArgs],
'$lgt_tr_margs'(Args, MArgs, Ctx, TArgs),
TPred =.. [Functor| TArgs].
'$lgt_tr_body'(Pred, '$lgt_call_built_in'(Pred, Ctx), '$lgt_dbg_goal'(Pred, '$lgt_call_built_in'(Pred, Ctx), Ctx), Ctx) :-
'$lgt_built_in'(Pred),
!.
% invalid goal
'$lgt_tr_body'(Pred, _, _, _) :-
\+ callable(Pred),
throw(type_error(callable, Pred)).
% goal is a call to a user predicate
'$lgt_tr_body'(Cond, TCond, '$lgt_dbg_goal'(Cond, TCond, Ctx), Ctx) :-
Cond =.. [Functor| Args],
functor(Cond, Functor, Arity),
'$lgt_context'(Ctx, Sender, This, Self, EPrefix, _),
'$lgt_construct_predicate_functor'(EPrefix, Functor, Arity, PPrefix),
'$lgt_append'(Args, [Sender, This, Self], Args2),
TCond =.. [PPrefix| Args2],
assertz('$lgt_pp_calls_pred_'(Functor/Arity)).
% '$lgt_tr_margs'(@list, @list, +term, -list)
%
% translates the meta-arguments contained in the list of
% arguments of a call to a metapredicate
'$lgt_tr_margs'([], [], _, []).
'$lgt_tr_margs'([Arg| Args], [MArg| MArgs], Ctx, [TArg| TArgs]) :-
'$lgt_tr_marg'(MArg, Arg, Ctx, TArg),
'$lgt_tr_margs'(Args, MArgs, Ctx, TArgs).
'$lgt_tr_marg'(*, Arg, _, Arg).
'$lgt_tr_marg'(::, Arg, Ctx, TArg) :-
'$lgt_tr_body'(Arg, TArg, _, Ctx).
% '$lgt_tr_msg'(@term, @object, -term, +term)
%
% translates the sending of a message to an object
'$lgt_tr_msg'(Pred, Obj, TPred, Ctx) :-
nonvar(Obj),
((Obj = (_, _); Obj = (_; _)) ->
!,
'$lgt_tr_msg_broadcasting'(Obj, Pred, TPred, Ctx) % message broadcasting
;
(\+ callable(Obj) ->
throw(type_error(object_identifier, Obj)) % invalid object identifier
;
\+ '$lgt_context'(Ctx, user, user, _, _, _), % not runtime message translation
'$lgt_add_referenced_object'(Obj), % remember object receiving message
fail)).
'$lgt_tr_msg'(Pred, Obj, TPred, Ctx) :-
var(Pred) -> % translation performed at runtime
!,
'$lgt_this'(Ctx, This),
('$lgt_compiler_option'(events, on) ->
TPred = '$lgt_send_to_object'(Obj, Pred, This)
;
TPred = '$lgt_send_to_object_ne'(Obj, Pred, This))
;
\+ callable(Pred), % invalid message
throw(type_error(callable, Pred)).
% control constructs
'$lgt_tr_msg'((Pred1, Pred2), Obj, (TPred1, TPred2), Ctx) :-
!,
'$lgt_tr_msg'(Pred1, Obj, TPred1, Ctx),
'$lgt_tr_msg'(Pred2, Obj, TPred2, Ctx).
'$lgt_tr_msg'((Pred1; Pred2), Obj, (TPred1; TPred2), Ctx) :-
!,
'$lgt_tr_msg'(Pred1, Obj, TPred1, Ctx),
'$lgt_tr_msg'(Pred2, Obj, TPred2, Ctx).
'$lgt_tr_msg'((Pred1 -> Pred2), Obj, (TPred1 -> TPred2), Ctx) :-
!,
'$lgt_tr_msg'(Pred1, Obj, TPred1, Ctx),
'$lgt_tr_msg'(Pred2, Obj, TPred2, Ctx).
'$lgt_tr_msg'(\+ Pred, Obj, \+ TPred, Ctx) :-
!,
'$lgt_tr_msg'(Pred, Obj, TPred, Ctx).
'$lgt_tr_msg'(!, Obj, ('$lgt_obj_exists'(Obj, !, This), !), Ctx) :-
!,
'$lgt_this'(Ctx, This).
'$lgt_tr_msg'(true, Obj, ('$lgt_obj_exists'(Obj, true, This), true), Ctx) :-
!,
'$lgt_this'(Ctx, This).
'$lgt_tr_msg'(fail, Obj, ('$lgt_obj_exists'(Obj, fail, This), fail), Ctx) :-
!,
'$lgt_this'(Ctx, This).
'$lgt_tr_msg'(repeat, Obj, ('$lgt_obj_exists'(Obj, repeat, This), repeat), Ctx) :-
!,
'$lgt_this'(Ctx, This).
'$lgt_tr_msg'(call(Pred), Obj, TPred, Ctx) :-
!,
'$lgt_tr_msg'(Pred, Obj, TPred, Ctx).
'$lgt_tr_msg'(once(Pred), Obj, once(TPred), Ctx) :-
!,
'$lgt_tr_msg'(Pred, Obj, TPred, Ctx).
'$lgt_tr_msg'(catch(Goal, Catcher, Recovery), Obj, catch(TGoal, Catcher, TRecovery), Ctx) :-
!,
'$lgt_tr_msg'(Goal, Obj, TGoal, Ctx),
'$lgt_tr_msg'(Recovery, Obj, TRecovery, Ctx).
'$lgt_tr_msg'(throw(Error), Obj, ('$lgt_obj_exists'(Obj, throw(Error), This), throw(Error)), Ctx) :-
!,
'$lgt_this'(Ctx, This).
% built-in metapredicates
'$lgt_tr_msg'(bagof(Term, Pred, List), Obj, bagof(Term, TPred, List), Ctx) :-
!,
'$lgt_tr_msg'(Pred, Obj, TPred, Ctx).
'$lgt_tr_msg'(findall(Term, Pred, List), Obj, findall(Term, TPred, List), Ctx) :-
!,
'$lgt_tr_msg'(Pred, Obj, TPred, Ctx).
'$lgt_tr_msg'(forall(Gen, Test), Obj, forall(TGen, TTest), Ctx) :-
!,
'$lgt_tr_msg'(Gen, Obj, TGen, Ctx),
'$lgt_tr_msg'(Test, Obj, TTest, Ctx).
'$lgt_tr_msg'(setof(Term, Pred, List), Obj, setof(Term, TPred, List), Ctx) :-
!,
'$lgt_tr_msg'(Pred, Obj, TPred, Ctx).
% "reflection" built-in predicates
'$lgt_tr_msg'(current_predicate(Pred), Obj, '$lgt_current_predicate'(Obj, Pred, This, p(p(p))), Ctx) :-
!,
'$lgt_this'(Ctx, This).
'$lgt_tr_msg'(predicate_property(Pred, Prop), Obj, '$lgt_predicate_property'(Obj, Pred, Prop, This, p(p(p))), Ctx) :-
!,
'$lgt_this'(Ctx, This).
% database handling built-in predicates
'$lgt_tr_msg'(abolish(Pred), Obj, '$lgt_abolish'(Obj, Pred, This, p(p(p))), Ctx) :-
!,
'$lgt_this'(Ctx, This).
'$lgt_tr_msg'(asserta(Pred), Obj, '$lgt_asserta'(Obj, Pred, This, p(p(p))), Ctx) :-
!,
'$lgt_this'(Ctx, This).
'$lgt_tr_msg'(assertz(Pred), Obj, '$lgt_assertz'(Obj, Pred, This, p(p(p))), Ctx) :-
!,
'$lgt_this'(Ctx, This).
'$lgt_tr_msg'(clause(Head, Body), Obj, '$lgt_clause'(Obj, Head, Body, This, p(p(p))), Ctx) :-
!,
'$lgt_this'(Ctx, This).
'$lgt_tr_msg'(retract(Pred), Obj, '$lgt_retract'(Obj, Pred, This, p(p(p))), Ctx) :-
!,
'$lgt_this'(Ctx, This).
'$lgt_tr_msg'(retractall(Pred), Obj, '$lgt_retractall'(Obj, Pred, This, p(p(p))), Ctx) :-
!,
'$lgt_this'(Ctx, This).
% DCG predicates
'$lgt_tr_msg'(expand_term(Term, Clause), Obj, '$lgt_expand_term'(Obj, Term, Clause, This, p(p(p))), Ctx) :-
!,
'$lgt_this'(Ctx, This).
'$lgt_tr_msg'(phrase(Ruleset, List), Obj, '$lgt_phrase'(Obj, Ruleset, List, This, p(p(p))), Ctx) :-
!,
'$lgt_this'(Ctx, This).
'$lgt_tr_msg'(phrase(Ruleset, List, Rest), Obj, '$lgt_phrase'(Obj, Ruleset, List, Rest, This, p(p(p))), Ctx) :-
!,
'$lgt_this'(Ctx, This).
% message is not a built-in control construct or a call to a built-in
% (meta-)predicate: translation performed at runtime
'$lgt_tr_msg'(Pred, Obj, TPred, Ctx) :-
'$lgt_this'(Ctx, This),
(var(Obj) ->
('$lgt_compiler_option'(events, on) ->
TPred = '$lgt_send_to_object'(Obj, Pred, This)
;
TPred = '$lgt_send_to_object_ne'(Obj, Pred, This))
;
('$lgt_compiler_option'(events, on) ->
TPred = '$lgt_send_to_object_nv'(Obj, Pred, This)
;
TPred = '$lgt_send_to_object_ne_nv'(Obj, Pred, This))).
% '$lgt_tr_self_msg'(@term, -term, +term)
%
% translates the sending of a message to self
'$lgt_tr_self_msg'(Pred, '$lgt_send_to_self'(Self, Pred, This), Ctx) :-
var(Pred) -> % translation performed at runtime
!,
'$lgt_this'(Ctx, This),
'$lgt_self'(Ctx, Self)
;
(\+ callable(Pred) -> % invalid message
throw(type_error(callable, Pred))).
% control constructs
'$lgt_tr_self_msg'((Pred1, Pred2), (TPred1, TPred2), Ctx) :-
!,
'$lgt_tr_self_msg'(Pred1, TPred1, Ctx),
'$lgt_tr_self_msg'(Pred2, TPred2, Ctx).
'$lgt_tr_self_msg'(((Pred1; Pred2)), (TPred1; TPred2), Ctx) :-
!,
'$lgt_tr_self_msg'(Pred1, TPred1, Ctx),
'$lgt_tr_self_msg'(Pred2, TPred2, Ctx).
'$lgt_tr_self_msg'((Pred1 -> Pred2), (TPred1 -> TPred2), Ctx) :-
!,
'$lgt_tr_self_msg'(Pred1, TPred1, Ctx),
'$lgt_tr_self_msg'(Pred2, TPred2, Ctx).
'$lgt_tr_self_msg'(\+ Pred, \+ TPred, Ctx) :-
!,
'$lgt_tr_self_msg'(Pred, TPred, Ctx).
'$lgt_tr_self_msg'(!, !, _) :-
!.
'$lgt_tr_self_msg'(true, true, _) :-
!.
'$lgt_tr_self_msg'(fail, fail, _) :-
!.
'$lgt_tr_self_msg'(repeat, repeat, _) :-
!.
'$lgt_tr_self_msg'(call(Pred), TPred, Ctx) :-
!,
'$lgt_tr_self_msg'(Pred, TPred, Ctx).
'$lgt_tr_self_msg'(once(Pred), once(TPred), Ctx) :-
!,
'$lgt_tr_self_msg'(Pred, TPred, Ctx).
'$lgt_tr_self_msg'(catch(Goal, Catcher, Recovery), catch(TGoal, Catcher, TRecovery), Ctx) :-
!,
'$lgt_tr_self_msg'(Goal, TGoal, Ctx),
'$lgt_tr_self_msg'(Recovery, TRecovery, Ctx).
'$lgt_tr_self_msg'(throw(Error), throw(Error), _) :-
!.
% built-in metapredicates
'$lgt_tr_self_msg'(bagof(Term, Pred, List), bagof(Term, TPred, List), Ctx) :-
!,
'$lgt_tr_self_msg'(Pred, TPred, Ctx).
'$lgt_tr_self_msg'(findall(Term, Pred, List), findall(Term, TPred, List), Ctx) :-
!,
'$lgt_tr_self_msg'(Pred, TPred, Ctx).
'$lgt_tr_self_msg'(forall(Gen, Test), forall(TGen, TTest), Ctx) :-
!,
'$lgt_tr_self_msg'(Gen, TGen, Ctx),
'$lgt_tr_self_msg'(Test, TTest, Ctx).
'$lgt_tr_self_msg'(setof(Term, Pred, List), setof(Term, TPred, List), Ctx) :-
!,
'$lgt_tr_self_msg'(Pred, TPred, Ctx).
% "reflection" built-in predicates
'$lgt_tr_self_msg'(current_predicate(Pred), '$lgt_current_predicate'(Self, Pred, This, p(_)), Ctx) :-
!,
'$lgt_self'(Ctx, Self),
'$lgt_this'(Ctx, This).
'$lgt_tr_self_msg'(predicate_property(Pred, Prop), '$lgt_predicate_property'(Self, Pred, Prop, This, p(_)), Ctx) :-
!,
'$lgt_self'(Ctx, Self),
'$lgt_this'(Ctx, This).
% database handling built-in predicates
'$lgt_tr_self_msg'(abolish(Pred), '$lgt_abolish'(Self, Pred, This, p(_)), Ctx) :-
!,
'$lgt_self'(Ctx, Self),
'$lgt_this'(Ctx, This).
'$lgt_tr_self_msg'(asserta(Pred), '$lgt_asserta'(Self, Pred, This, p(_)), Ctx) :-
!,
'$lgt_self'(Ctx, Self),
'$lgt_this'(Ctx, This).
'$lgt_tr_self_msg'(assertz(Pred), '$lgt_assertz'(Self, Pred, This, p(_)), Ctx) :-
!,
'$lgt_self'(Ctx, Self),
'$lgt_this'(Ctx, This).
'$lgt_tr_self_msg'(clause(Head, Body), '$lgt_clause'(Self, Head, Body, This, p(_)), Ctx) :-
!,
'$lgt_self'(Ctx, Self),
'$lgt_this'(Ctx, This).
'$lgt_tr_self_msg'(retract(Pred), '$lgt_retract'(Self, Pred, This, p(_)), Ctx) :-
!,
'$lgt_self'(Ctx, Self),
'$lgt_this'(Ctx, This).
'$lgt_tr_self_msg'(retractall(Pred), '$lgt_retractall'(Self, Pred, This, p(_)), Ctx) :-
!,
'$lgt_self'(Ctx, Self),
'$lgt_this'(Ctx, This).
% DCG predicates
'$lgt_tr_self_msg'(expand_term(Term, Clause), '$lgt_expand_term'(Self, Term, Clause, This, p(_)), Ctx) :-
!,
'$lgt_self'(Ctx, Self),
'$lgt_this'(Ctx, This).
'$lgt_tr_self_msg'(phrase(Ruleset, List), '$lgt_phrase'(Self, Ruleset, List, This, p(_)), Ctx) :-
!,
'$lgt_self'(Ctx, Self),
'$lgt_this'(Ctx, This).
'$lgt_tr_self_msg'(phrase(Ruleset, List, Rest), '$lgt_phrase'(Self, Ruleset, List, Rest, This, p(_)), Ctx) :-
!,
'$lgt_self'(Ctx, Self),
'$lgt_this'(Ctx, This).
% message is not a built-in control construct or a call to a built-in
% (meta-)predicate: translation performed at runtime
'$lgt_tr_self_msg'(Pred, '$lgt_send_to_self_nv'(Self, Pred, This), Ctx) :-
!,
'$lgt_self'(Ctx, Self),
'$lgt_this'(Ctx, This).
% message broadcasting
'$lgt_tr_msg_broadcasting'((Obj1, Obj2), Pred, (TP1, TP2), Ctx) :-
!,
'$lgt_tr_msg'(Pred, Obj1, TP1, Ctx),
'$lgt_tr_msg'(Pred, Obj2, TP2, Ctx).
'$lgt_tr_msg_broadcasting'((Obj1; Obj2), Pred, (TP1; TP2), Ctx) :-
!,
'$lgt_tr_msg'(Pred, Obj1, TP1, Ctx),
'$lgt_tr_msg'(Pred, Obj2, TP2, Ctx).
% '$lgt_tr_super_sending'(@term, -term, +term)
%
% translates calling of redefined predicates (super calls)
% invalid goal (not callable)
'$lgt_tr_super_sending'(Pred, _, _) :-
nonvar(Pred),
\+ callable(Pred),
throw(type_error(callable, Pred)).
% translation performed at runtime
'$lgt_tr_super_sending'(Pred, TPred, Ctx) :-
'$lgt_context'(Ctx, Sender, This, Self, _, _),
(var(Pred) ->
TPred = '$lgt_send_to_super'(Self, Pred, This, Sender)
;
TPred = '$lgt_send_to_super_nv'(Self, Pred, This, Sender)).
% '$lgt_extract_metavars'(+callable, -list)
%
% constructs a list of all variables that occur
% in a position corresponding to a meta-argument
'$lgt_extract_metavars'(Pred, Metavars) :-
functor(Pred, Functor, Arity),
functor(Meta, Functor, Arity),
('$lgt_pp_metapredicate_'(Meta) ->
Pred =.. [_| Args],
Meta =.. [_| MArgs],
'$lgt_extract_metavars'(Args, MArgs, Metavars)
;
Metavars = []).
% '$lgt_extract_metavars'(+list, +list, -list)
'$lgt_extract_metavars'([], [], []).
'$lgt_extract_metavars'([Var| Args], [MArg| MArgs], [Var| Metavars]) :-
var(Var),
MArg = (::),
!,
'$lgt_extract_metavars'(Args, MArgs, Metavars).
'$lgt_extract_metavars'([_| Args], [_| MArgs], Metavars) :-
'$lgt_extract_metavars'(Args, MArgs, Metavars).
% '$lgt_iso_read_term'(@stream, ?term, +read_options_list, @list)
%
% wraps read_term/3 call with the necessary operator settings
'$lgt_iso_read_term'(Stream, Term, Options, Ops) :-
catch(
('$lgt_save_operators'(Ops, Saved),
'$lgt_add_operators'(Ops),
read_term(Stream, Term, Options),
'$lgt_remove_operators'(Ops),
'$lgt_add_operators'(Saved)),
Error,
'$lgt_iso_read_error_handler'(Ops, Saved, Error)).
% '$lgt_iso_read_term'(?term, +read_options_list, @list)
%
% wraps read_term/2 call with the necessary operator settings
'$lgt_iso_read_term'(Term, Options, Ops) :-
catch(
('$lgt_save_operators'(Ops, Saved),
'$lgt_add_operators'(Ops),
read_term(Term, Options),
'$lgt_remove_operators'(Ops),
'$lgt_add_operators'(Saved)),
Error,
'$lgt_iso_read_error_handler'(Ops, Saved, Error)).
% '$lgt_iso_read'(@stream, ?term, @list)
%
% wraps read/2 call with the necessary operator settings
'$lgt_iso_read'(Stream, Term, Ops) :-
catch(
('$lgt_save_operators'(Ops, Saved),
'$lgt_add_operators'(Ops),
read(Stream, Term),
'$lgt_remove_operators'(Ops),
'$lgt_add_operators'(Saved)),
Error,
'$lgt_iso_read_error_handler'(Ops, Saved, Error)).
% '$lgt_iso_read'(?term, @list)
%
% wraps read/1 call with the necessary operator settings
'$lgt_iso_read'(Term, Ops) :-
catch(
('$lgt_save_operators'(Ops, Saved),
'$lgt_add_operators'(Ops),
read(Term),
'$lgt_remove_operators'(Ops),
'$lgt_add_operators'(Saved)),
Error,
'$lgt_iso_read_error_handler'(Ops, Saved, Error)).
% '$lgt_iso_write_term'(@stream_or_alias, @term, @write_options_list, @list)
%
% wraps write_term/3 call with the necessary operator settings
'$lgt_iso_write_term'(Stream, Term, Options, Ops) :-
catch(
('$lgt_save_operators'(Ops, Saved),
'$lgt_add_operators'(Ops),
write_term(Stream, Term, Options),
'$lgt_remove_operators'(Ops),
'$lgt_add_operators'(Saved)),
Error,
'$lgt_iso_read_error_handler'(Ops, Saved, Error)).
% '$lgt_iso_write_term'(@term, @write_options_list, @list)
%
% wraps write_term/2 call with the necessary operator settings
'$lgt_iso_write_term'(Term, Options, Ops) :-
catch(
('$lgt_save_operators'(Ops, Saved),
'$lgt_add_operators'(Ops),
write_term(Term, Options),
'$lgt_remove_operators'(Ops),
'$lgt_add_operators'(Saved)),
Error,
'$lgt_iso_read_error_handler'(Ops, Saved, Error)).
% '$lgt_iso_write'(@stream_or_alias, @term, @list)
%
% wraps write/2 call with the necessary operator settings
'$lgt_iso_write'(Stream, Term, Ops) :-
catch(
('$lgt_save_operators'(Ops, Saved),
'$lgt_add_operators'(Ops),
write(Stream, Term),
'$lgt_remove_operators'(Ops),
'$lgt_add_operators'(Saved)),
Error,
'$lgt_iso_read_error_handler'(Ops, Saved, Error)).
% '$lgt_iso_write'(@term, @list)
%
% wraps write/1 call with the necessary operator settings
'$lgt_iso_write'(Term, Ops):-
catch(
('$lgt_save_operators'(Ops, Saved),
'$lgt_add_operators'(Ops),
write(Term),
'$lgt_remove_operators'(Ops),
'$lgt_add_operators'(Saved)),
Error,
'$lgt_iso_read_error_handler'(Ops, Saved, Error)).
% '$lgt_iso_writeq'(@stream_or_alias, @term, @list)
%
% wraps writeq/2 call with the necessary operator settings
'$lgt_iso_writeq'(Stream, Term, Ops) :-
catch(
('$lgt_save_operators'(Ops, Saved),
'$lgt_add_operators'(Ops),
writeq(Stream, Term),
'$lgt_remove_operators'(Ops),
'$lgt_add_operators'(Saved)),
Error,
'$lgt_iso_read_error_handler'(Ops, Saved, Error)).
% '$lgt_iso_writeq'(@term, @list)
%
% wraps writeq/1 call with the necessary operator settings
'$lgt_iso_writeq'(Term, Ops) :-
catch(
('$lgt_save_operators'(Ops, Saved),
'$lgt_add_operators'(Ops),
writeq(Term),
'$lgt_remove_operators'(Ops),
'$lgt_add_operators'(Saved)),
Error,
'$lgt_iso_read_error_handler'(Ops, Saved, Error)).
% '$lgt_save_operators'(@list, -list)
%
% save currently defined operators that might be
% redefined when a list of operators is added
'$lgt_save_operators'(Ops, Saved) :-
findall(
op(Pr, Spec, Op),
('$lgt_member'(op(_, _, Op), Ops), current_op(Pr, Spec, Op)),
Saved).
% '$lgt_add_operators'(@list)
%
% adds operators to the global operator table
'$lgt_add_operators'([]).
'$lgt_add_operators'([op(Pr, Spec, Op)| Ops]) :-
op(Pr, Spec, Op),
'$lgt_add_operators'(Ops).
% '$lgt_remove_operators'(@list)
%
% remove operators from the global operator table
'$lgt_remove_operators'([]).
'$lgt_remove_operators'([op(_, Spec, Op)| Ops]) :-
op(0, Spec, Op),
'$lgt_remove_operators'(Ops).
% '$lgt_iso_read_error_handler'(@list, @list, @nonvar)
%
% restores operator table to the its state before the call
% to one of the '$lgt_iso_read...' raised an error
'$lgt_iso_read_error_handler'(Ops, Saved, Error) :-
'$lgt_remove_operators'(Ops),
'$lgt_add_operators'(Saved),
throw(Error).
% '$lgt_simplify_body'(+callable, -callable)
%
% remove redundant calls to true/0 from a translated clause body
'$lgt_simplify_body'((A;B), (SA;SB)) :-
!,
'$lgt_simplify_body'(A, SA),
'$lgt_simplify_body'(B, SB).
'$lgt_simplify_body'((A->B), (SA->SB)) :-
!,
'$lgt_simplify_body'(A, SA),
'$lgt_simplify_body'(B, SB).
'$lgt_simplify_body'((true, B), SB) :-
!,
'$lgt_simplify_body'(B, SB).
'$lgt_simplify_body'((B, true), SB) :-
!,
'$lgt_simplify_body'(B, SB).
'$lgt_simplify_body'((A, B), (SA, SB)) :-
!,
'$lgt_simplify_body'(A, SA),
'$lgt_simplify_body'(B, SB).
'$lgt_simplify_body'(B, B).
% '$lgt_tr_object_id'(+object_identifier, +atom)
%
% from the object identifier construct the set of
% functor prefixes used in the compiled code clauses
'$lgt_tr_object_id'(Obj, Mode) :-
'$lgt_add_referenced_object'(Obj),
'$lgt_construct_object_functors'(Obj, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef),
assertz('$lgt_pp_object_'(Obj, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Mode)).
% '$lgt_tr_category_id'(+category_identifier, +atom)
%
% from the category identifier construct the set of
% functor prefixes used in the compiled code clauses
'$lgt_tr_category_id'(Ctg, Mode) :-
'$lgt_add_referenced_category'(Ctg),
'$lgt_construct_category_functors'(Ctg, Prefix, Dcl, Def),
assertz('$lgt_pp_category_'(Ctg, Prefix, Dcl, Def, Mode)).
% '$lgt_tr_protocol_id'(+protocol_identifier, +atom)
%
% from the protocol identifier construct the set of
% functor prefixes used in the compiled code clauses
'$lgt_tr_protocol_id'(Ptc, Mode) :-
'$lgt_add_referenced_protocol'(Ptc),
'$lgt_construct_protocol_functors'(Ptc, Prefix, Dcl),
assertz('$lgt_pp_protocol_'(Ptc, Prefix, Dcl, Mode)).
% '$lgt_update_entity_comp_mode'
%
% updates entity compilation mode to "dynamic" (entities are static by default)
'$lgt_update_entity_comp_mode' :-
retract('$lgt_pp_object_'(Obj, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, _)),
assertz('$lgt_pp_object_'(Obj, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, (dynamic))),
!.
'$lgt_update_entity_comp_mode' :-
retract('$lgt_pp_protocol_'(Ptc, Prefix, Dcl, _)),
assertz('$lgt_pp_protocol_'(Ptc, Prefix, Dcl, (dynamic))),
!.
'$lgt_update_entity_comp_mode' :-
retract('$lgt_pp_category_'(Ctg, Prefix, Dcl, Def, _)),
assertz('$lgt_pp_category_'(Ctg, Prefix, Dcl, Def, (dynamic))).
% '$lgt_tr_implements_protocol'(+list, +object_identifier)
% '$lgt_tr_implements_protocol'(+list, +category_identifier)
%
% translates an "implementents" relation between
% a category or an object and a list of protocols
'$lgt_tr_implements_protocol'([], _).
'$lgt_tr_implements_protocol'([Ref| Refs], ObjOrCtg) :-
'$lgt_valid_scope'(Ref) ->
('$lgt_scope_id'(Ref, Scope, Ptc),
(atom(Ptc) ->
'$lgt_add_referenced_protocol'(Ptc),
assertz('$lgt_pp_rclause_'('$lgt_implements_protocol_'(ObjOrCtg, Ptc, Scope))),
'$lgt_construct_protocol_functors'(Ptc, Prefix, Dcl),
assertz('$lgt_pp_implemented_protocol_'(Ptc, Prefix, Dcl, Scope)),
'$lgt_tr_implements_protocol'(Refs, ObjOrCtg)
;
throw(type_error(protocol_identifier, Ptc))))
;
throw(type_error(scope, Ref)).
% '$lgt_tr_imports_category'(+list, +object_identifier)
% '$lgt_tr_imports_category'(+list, +category_identifier)
%
% translates an "imports" relation between
% an object/category and a list of categories
'$lgt_tr_imports_category'([], _).
'$lgt_tr_imports_category'([Ref| Refs], ObjOrCtg) :-
'$lgt_valid_scope'(Ref) ->
('$lgt_scope_id'(Ref, Scope, Ctg),
(atom(Ctg) ->
'$lgt_add_referenced_category'(Ctg),
assertz('$lgt_pp_rclause_'('$lgt_imports_category_'(ObjOrCtg, Ctg, Scope))),
'$lgt_construct_category_functors'(Ctg, Prefix, Dcl, Def),
assertz('$lgt_pp_imported_category_'(Ctg, Prefix, Dcl, Def, Scope)),
'$lgt_tr_imports_category'(Refs, ObjOrCtg)
;
throw(type_error(category_identifier, Ctg))))
;
throw(type_error(scope, Ref)).
% '$lgt_tr_instantiates_class'(+list, +object_identifier)
%
% translates an "instantiates" relation between
% an instance and a list of classes
'$lgt_tr_instantiates_class'([], _).
'$lgt_tr_instantiates_class'([Ref| Refs], Obj) :-
'$lgt_valid_scope'(Ref) ->
('$lgt_scope_id'(Ref, Scope, Class),
(callable(Class) ->
'$lgt_add_referenced_object'(Class),
assertz('$lgt_pp_rclause_'('$lgt_instantiates_class_'(Obj, Class, Scope))),
'$lgt_construct_object_functors'(Class, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef),
assertz('$lgt_pp_instantiated_class_'(Class, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Scope)),
'$lgt_tr_instantiates_class'(Refs, Obj)
;
throw(type_error(object_identifier, Class))))
;
throw(type_error(scope, Ref)).
% '$lgt_tr_specializes_class'(+list, +object_identifier)
%
% translates a "specializes" relation between
% a class and a list of superclasses
'$lgt_tr_specializes_class'([], _).
'$lgt_tr_specializes_class'([Ref| Refs], Class) :-
'$lgt_valid_scope'(Ref) ->
('$lgt_scope_id'(Ref, Scope, Superclass),
(callable(Superclass) ->
'$lgt_add_referenced_object'(Superclass),
assertz('$lgt_pp_rclause_'('$lgt_specializes_class_'(Class, Superclass, Scope))),
'$lgt_construct_object_functors'(Superclass, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef),
assertz('$lgt_pp_specialized_class_'(Superclass, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Scope)),
'$lgt_tr_specializes_class'(Refs, Class)
;
throw(type_error(object_identifier, Superclass))))
;
throw(type_error(scope, Ref)).
% '$lgt_tr_extends_object'(+list, +object_identifier)
%
% translates an "extends" relation between
% a prototype and a list of parents
'$lgt_tr_extends_object'([], _).
'$lgt_tr_extends_object'([Ref| Refs], Obj) :-
'$lgt_valid_scope'(Ref) ->
('$lgt_scope_id'(Ref, Scope, Parent),
(callable(Parent) ->
'$lgt_add_referenced_object'(Parent),
assertz('$lgt_pp_rclause_'('$lgt_extends_object_'(Obj, Parent, Scope))),
'$lgt_construct_object_functors'(Parent, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef),
assertz('$lgt_pp_extended_object_'(Parent, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Scope)),
'$lgt_tr_extends_object'(Refs, Obj)
;
throw(type_error(object_identifier, Parent))))
;
throw(type_error(scope, Ref)).
% '$lgt_tr_extends_protocol'(+list, +protocol_identifier)
%
% translates an "extends" relation between
% a protocol and a list of protocols
'$lgt_tr_extends_protocol'([], _).
'$lgt_tr_extends_protocol'([Ref| Refs], Ptc1) :-
'$lgt_valid_scope'(Ref) ->
('$lgt_scope_id'(Ref, Scope, Ptc2),
(atom(Ptc2) ->
'$lgt_add_referenced_protocol'(Ptc2),
assertz('$lgt_pp_rclause_'('$lgt_extends_protocol_'(Ptc1, Ptc2, Scope))),
'$lgt_construct_protocol_functors'(Ptc2, Prefix, Dcl),
assertz('$lgt_pp_extended_protocol_'(Ptc2, Prefix, Dcl, Scope)),
'$lgt_tr_extends_protocol'(Refs, Ptc1)
;
throw(type_error(protocol_identifier, Ptc2))))
;
throw(type_error(scope, Ref)).
% '$lgt_add_referenced_object'(+object_identifier)
%
% assert the name of an object referenced by the entity that we are compiling
'$lgt_add_referenced_object'(Obj) :-
'$lgt_pp_referenced_object_'(Obj) ->
true
;
assertz('$lgt_pp_referenced_object_'(Obj)).
% '$lgt_add_referenced_protocol'(+protocol_identifier)
%
% assert the name of a protocol referenced by the entity that we are compiling
'$lgt_add_referenced_protocol'(Ptc) :-
'$lgt_pp_referenced_protocol_'(Ptc) ->
true
;
assertz('$lgt_pp_referenced_protocol_'(Ptc)).
% '$lgt_add_referenced_category'(+category_identifier)
%
% assert the name of a category referenced by the entity that we are compiling
'$lgt_add_referenced_category'(Ctg) :-
'$lgt_pp_referenced_category_'(Ctg) ->
true
;
assertz('$lgt_pp_referenced_category_'(Ctg)).
% '$lgt_report_unknown_entities'
%
% report any unknown referenced entities found while compiling an entity
% (if the corresponding compiler option is not set to "silent")
'$lgt_report_unknown_entities' :-
('$lgt_compiler_option'(unknown, warning),
'$lgt_compiler_option'(report, on)) ->
'$lgt_report_unknown_objects',
'$lgt_report_unknown_protocols',
'$lgt_report_unknown_categories'
;
true.
% '$lgt_report_unknown_objects'
%
% report any unknown referenced objects found while compiling an entity
'$lgt_report_unknown_objects' :-
findall(
Obj,
('$lgt_pp_referenced_object_'(Obj),
\+ ('$lgt_current_object_'(Obj, _, _, _, _, _);
'$lgt_pp_object_'(Obj, _, _, _, _, _, _, _, _, _))),
Objs),
(Objs \= [] ->
write('> WARNING! references to unknown objects: '), writeq(Objs), nl
;
true).
% '$lgt_report_unknown_protocols'
%
% report any unknown referenced protocols found while compiling an entity
'$lgt_report_unknown_protocols' :-
findall(
Ptc,
('$lgt_pp_referenced_protocol_'(Ptc),
\+ ('$lgt_current_protocol_'(Ptc, _, _);
'$lgt_pp_protocol_'(Ptc, _, _, _))),
Ptcs),
(Ptcs \= [] ->
write('> WARNING! references to unknown protocols: '), writeq(Ptcs), nl
;
true).
% '$lgt_report_unknown_categories'
%
% report any unknown referenced categories found while compiling an entity
'$lgt_report_unknown_categories' :-
findall(
Ctg,
('$lgt_pp_referenced_category_'(Ctg),
\+ ('$lgt_current_category_'(Ctg, _, _);
'$lgt_pp_category_'(Ctg, _, _, _, _))),
Ctgs),
(Ctgs \= [] ->
write('> WARNING! references to unknown categories: '), writeq(Ctgs), nl
;
true).
% '$lgt_add_def_clause'(+atom, +integer, +atom, +term)
%
% adds a "def clause" (used to translate a predicate call)
'$lgt_add_def_clause'(Functor, Arity, Prefix, Ctx) :-
functor(Head, Functor, Arity),
Head =.. [_| Args],
'$lgt_context'(Ctx, Sender, This, Self, _, _),
'$lgt_append'(Args, [Sender, This, Self], TArgs),
THead =.. [Prefix|TArgs],
once(
('$lgt_pp_object_'(_, _, _, Def, _, _, _, _, _, _);
'$lgt_pp_category_'(_, _, _, Def, _))),
Clause =.. [Def, Head, Sender, This, Self, THead],
('$lgt_pp_def_'(Clause) ->
true
;
assertz('$lgt_pp_def_'(Clause))),
('$lgt_built_in'(Head) ->
assertz('$lgt_pp_redefined_built_in_'(Head, Ctx, THead))
;
true),
('$lgt_pp_defs_pred_'(Functor/Arity) ->
true
;
assertz('$lgt_pp_defs_pred_'(Functor/Arity))).
% '$lgt_add_ddef_clause'(+atom, +integer, +atom, +term)
%
% adds a "ddef clause" (used to translate a predicate call)
'$lgt_add_ddef_clause'(Functor, Arity, Prefix, Ctx) :-
functor(Head, Functor, Arity),
Head =.. [_| Args],
'$lgt_context'(Ctx, Sender, This, Self, _, _),
'$lgt_append'(Args, [Sender, This, Self], TArgs),
THead =.. [Prefix|TArgs],
'$lgt_pp_object_'(_, _, _, _, _, _, _, _, DDef, _),
Clause =.. [DDef, Head, Sender, This, Self, THead],
('$lgt_pp_ddef_'(Clause) ->
true
;
assertz('$lgt_pp_ddef_'(Clause))),
('$lgt_built_in'(Head) ->
assertz('$lgt_pp_redefined_built_in_'(Head, Ctx, THead))
;
true),
('$lgt_pp_defs_pred_'(Functor/Arity) ->
true
;
assertz('$lgt_pp_defs_pred_'(Functor/Arity))).
% '$lgt_assert_ddef_clause'(+atom, +integer, +atom, +atom, -callable)
%
% asserts a dynamic "ddef clause" (used to translate a predicate call)
'$lgt_assert_ddef_clause'(Functor, Arity, OPrefix, DDef, Call) :-
'$lgt_construct_predicate_functor'(OPrefix, Functor, Arity, PPrefix),
functor(Pred, Functor, Arity),
Pred =.. [_| Args],
'$lgt_append'(Args, [Sender, This, Self], TArgs),
Call =.. [PPrefix| TArgs],
Clause =.. [DDef, Pred, Sender, This, Self, Call],
assertz(Clause),
'$lgt_clean_lookup_caches'(Pred).
% '$lgt_update_ddef_table'(+atom, +callable, +callable)
%
% retracts a dynamic "ddef clause" (used to translate a predicate call)
% if there are no more clauses for the predicate otherwise does nothing
%
% this is needed in order to allow definitions in ancestors to be found
'$lgt_update_ddef_table'(DDef, Head, Call) :-
functor(Call, Functor, Arity),
functor(GCall, Functor, Arity),
(clause(GCall, _) ->
true
;
Clause =.. [DDef, Head, _, _, _, _],
retractall(Clause),
'$lgt_clean_lookup_caches'(Head)).
% '$lgt_convert_test_scope'(@term, +term),
%
% convert asserta/z test scope to predicate declaration scope
'$lgt_convert_test_scope'(Scope, Scope2) :-
var(Scope) ->
Scope2 = p
;
((Scope = p(V), var(V)) ->
Scope2 = p(p)
;
Scope2 = p(p(p))).
% '$lgt_assert_ddcl_clause'(+atom, +term, +term)
%
% asserts a dynamic predicate declaration
'$lgt_assert_ddcl_clause'(DDcl, Pred, Scope) :-
functor(Pred, Functor, Arity),
functor(DPred, Functor, Arity),
Clause =.. [DDcl, DPred, Scope],
assertz(Clause).
% '$lgt_gen_directives'(+atom)
%
% generates entity directives
'$lgt_gen_directives'(object) :-
'$lgt_gen_object_directives'.
'$lgt_gen_directives'(category) :-
'$lgt_gen_category_directives'.
'$lgt_gen_directives'(protocol) :-
'$lgt_gen_protocol_directives'.
'$lgt_gen_object_directives' :-
'$lgt_gen_object_dynamic_directives',
'$lgt_gen_object_discontiguous_directives'.
'$lgt_gen_category_directives' :-
'$lgt_gen_category_dynamic_directives',
'$lgt_gen_category_discontiguous_directives'.
'$lgt_gen_protocol_directives' :-
'$lgt_pp_protocol_'(_, Prefix, Dcl, (dynamic)) ->
assertz('$lgt_pp_directive_'(dynamic(Prefix/1))),
assertz('$lgt_pp_directive_'(dynamic(Dcl/4))),
assertz('$lgt_pp_directive_'(dynamic(Dcl/5)))
;
true.
'$lgt_gen_object_dynamic_directives' :-
'$lgt_pp_object_'(_, _, _, _, _, _, _, _, _, (dynamic)) ->
'$lgt_gen_dynamic_object_dynamic_directives'
;
'$lgt_gen_static_object_dynamic_directives'.
'$lgt_gen_dynamic_object_dynamic_directives' :-
'$lgt_pp_object_'(_, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, _),
assertz('$lgt_pp_directive_'(dynamic(Prefix/7))),
assertz('$lgt_pp_directive_'(dynamic(Dcl/4))),
assertz('$lgt_pp_directive_'(dynamic(Dcl/6))),
assertz('$lgt_pp_directive_'(dynamic(Def/5))),
assertz('$lgt_pp_directive_'(dynamic(Def/6))),
assertz('$lgt_pp_directive_'(dynamic(Super/6))),
assertz('$lgt_pp_directive_'(dynamic(IDcl/6))),
assertz('$lgt_pp_directive_'(dynamic(IDef/6))),
assertz('$lgt_pp_directive_'(dynamic(DDcl/2))),
assertz('$lgt_pp_directive_'(dynamic(DDef/5))),
'$lgt_gen_dynamic_entity_dynamic_predicate_directives'.
'$lgt_gen_dynamic_entity_dynamic_predicate_directives' :-
'$lgt_pp_def_'(Clause),
Clause \= (_ :- _),
arg(5, Clause, Call),
functor(Call, Functor, Arity),
assertz('$lgt_pp_directive_'(dynamic(Functor/Arity))),
fail.
'$lgt_gen_dynamic_entity_dynamic_predicate_directives'.
'$lgt_gen_static_object_dynamic_directives' :-
'$lgt_pp_object_'(_, Prefix, _, _, _, _, _, DDcl, DDef, _),
assertz('$lgt_pp_directive_'(dynamic(DDcl/2))),
assertz('$lgt_pp_directive_'(dynamic(DDef/5))),
'$lgt_pp_dynamic_'(Functor/Arity),
'$lgt_construct_predicate_functor'(Prefix, Functor, Arity, TFunctor),
TArity is Arity + 3,
assertz('$lgt_pp_directive_'(dynamic(TFunctor/TArity))),
fail.
'$lgt_gen_static_object_dynamic_directives'.
'$lgt_gen_object_discontiguous_directives' :-
'$lgt_pp_object_'(_, Prefix, _, _, _, _, _, _, _, _),
'$lgt_pp_discontiguous_'(Functor/Arity),
'$lgt_construct_predicate_functor'(Prefix, Functor, Arity, TFunctor),
TArity is Arity + 3,
assertz('$lgt_pp_directive_'(discontiguous(TFunctor/TArity))),
fail.
'$lgt_gen_object_discontiguous_directives'.
'$lgt_gen_category_dynamic_directives' :-
'$lgt_pp_category_'(_, Prefix, _, Def, (dynamic)) ->
assertz('$lgt_pp_directive_'(dynamic(Prefix/2))),
assertz('$lgt_pp_directive_'(dynamic(Dcl/4))),
assertz('$lgt_pp_directive_'(dynamic(Dcl/5))),
assertz('$lgt_pp_directive_'(dynamic(Def/5))),
'$lgt_gen_dynamic_entity_dynamic_predicate_directives'
;
true.
'$lgt_gen_category_discontiguous_directives' :-
'$lgt_pp_category_'(_, Prefix, _, _, _),
'$lgt_pp_discontiguous_'(Functor/Arity),
'$lgt_construct_predicate_functor'(Prefix, Functor, Arity, TFunctor),
TArity is Arity + 3,
assertz('$lgt_pp_directive_'(discontiguous(TFunctor/TArity))),
fail.
'$lgt_gen_category_discontiguous_directives'.
% '$lgt_gen_clauses'(+atom)
'$lgt_gen_clauses'(object) :-
'$lgt_gen_object_clauses'.
'$lgt_gen_clauses'(protocol) :-
'$lgt_gen_protocol_clauses'.
'$lgt_gen_clauses'(category) :-
'$lgt_gen_category_clauses'.
'$lgt_gen_object_clauses' :-
('$lgt_pp_instantiated_class_'(_, _, _, _, _, _, _, _, _, _);
'$lgt_pp_specialized_class_'(_, _, _, _, _, _, _, _, _, _)) ->
'$lgt_gen_ic_clauses'
;
'$lgt_gen_prototype_clauses'.
% '$lgt_gen_local_dcl_clauses'
%
% a (local) predicate declaration is only generated
% if there is a scope declaration for the predicate
'$lgt_gen_local_dcl_clauses' :-
'$lgt_pp_entity'(_, _, _, 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(Meta, Functor, Arity),
('$lgt_pp_metapredicate_'(Meta) ->
Meta2 = Meta
;
Meta2 = no),
functor(Pred, Functor, Arity),
('$lgt_pp_dynamic_'(Functor/Arity)->
Compilation = (dynamic)
;
Compilation = static),
Fact =.. [Dcl, Pred, Scope, Compilation, Meta2],
assertz('$lgt_pp_dcl_'(Fact)),
fail.
'$lgt_gen_local_dcl_clauses' :- % generate a catchall clause if needed
\+ '$lgt_pp_dcl_'(_) ->
'$lgt_pp_entity'(_, _, _, Dcl, _),
Head =.. [Dcl, _, _, _, _],
assertz('$lgt_pp_dcl_'((Head:-fail)))
;
true.
% '$lgt_gen_local_def_clauses'
%
% generates local def clauses for undefined but declared (via scope or
% dynamic directives) predicates
'$lgt_gen_local_def_clauses' :-
'$lgt_pp_entity'(_, _, EPrefix, _, _),
'$lgt_pp_dynamic_'(Functor/Arity),
\+ '$lgt_pp_defs_pred_'(Functor/Arity),
'$lgt_construct_predicate_functor'(EPrefix, Functor, Arity, PPrefix),
'$lgt_context'(Ctx),
((\+ '$lgt_pp_public_'(Functor/Arity),
\+ '$lgt_pp_protected_'(Functor/Arity),
\+ '$lgt_pp_private_'(Functor/Arity)) ->
'$lgt_add_ddef_clause'(Functor, Arity, PPrefix, Ctx)
;
'$lgt_add_def_clause'(Functor, Arity, PPrefix, Ctx)),
fail.
'$lgt_gen_local_def_clauses'.
'$lgt_gen_obj_catchall_def_clause' :-
\+ '$lgt_pp_def_'(_) ->
'$lgt_pp_object_'(_, _, _, Def, _, _, _, _, _, _),
Head =.. [Def, _, _, _, _, _],
assertz('$lgt_pp_def_'((Head:-fail)))
;
true.
'$lgt_gen_protocol_clauses' :-
'$lgt_gen_local_dcl_clauses',
'$lgt_gen_protocol_linking_clauses',
'$lgt_gen_protocol_extend_clauses'.
'$lgt_gen_protocol_linking_clauses' :-
'$lgt_pp_protocol_'(Ptc, _, PDcl, _),
Head =.. [PDcl, Pred, Scope, Compilation, Meta, Ptc],
Body =.. [PDcl, Pred, Scope, Compilation, Meta],
assertz('$lgt_pp_dcl_'((Head:-Body))).
'$lgt_gen_protocol_extend_clauses' :-
'$lgt_pp_protocol_'(_, Prefix, PDcl1, _),
'$lgt_pp_extended_protocol_'(Ptc2, _, PDcl2, EScope),
(EScope = (public) ->
Lookup =.. [PDcl2, Pred, Scope, Compilation, Meta, Ctn]
;
(EScope = protected ->
Call =.. [PDcl2, Pred, Scope2, Compilation, Meta, Ctn],
Lookup = (Call, (Scope2 == p -> Scope = p; Scope = p(p)))
;
Scope = p,
Lookup =.. [PDcl2, Pred, _, Compilation, Meta, Ctn])),
('$lgt_pp_alias_'(Ptc2, _, _) ->
Head =.. [PDcl1, Alias, Scope, Compilation, Meta, Ctn],
'$lgt_construct_alias_functor'(Prefix, PRnm),
Rename =.. [PRnm, Ptc2, Pred, Alias],
assertz('$lgt_pp_dcl_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup)))
;
Head =.. [PDcl1, Pred, Scope, Compilation, Meta, Ctn],
assertz('$lgt_pp_dcl_'((Head:-Lookup)))),
fail.
'$lgt_gen_protocol_extend_clauses'.
'$lgt_construct_alias_functor'(Prefix, PRen) :-
atom_concat(Prefix, '_alias', PRen).
'$lgt_gen_category_clauses' :-
'$lgt_gen_category_dcl_clauses',
'$lgt_gen_category_def_clauses'.
'$lgt_gen_category_dcl_clauses' :-
'$lgt_gen_local_dcl_clauses',
'$lgt_gen_category_linking_dcl_clauses',
'$lgt_gen_category_implements_dcl_clauses',
'$lgt_gen_category_imports_dcl_clauses'.
'$lgt_gen_category_linking_dcl_clauses' :-
'$lgt_pp_category_'(Ctg, _, CDcl, _, _),
Head =.. [CDcl, Pred, Scope, Compilation, Meta, Ctg],
Body =.. [CDcl, Pred, Scope, Compilation, Meta],
assertz('$lgt_pp_dcl_'((Head:-Body))).
'$lgt_gen_category_implements_dcl_clauses' :-
'$lgt_pp_category_'(_, Prefix, CDcl, _, _),
'$lgt_pp_implemented_protocol_'(Ptc, _, PDcl, EScope),
(EScope = (public) ->
Lookup =.. [PDcl, Pred, Scope, Compilation, Meta, Ctn]
;
(EScope = protected ->
Call =.. [PDcl, Pred, Scope2, Compilation, Meta, Ctn],
Lookup = (Call, (Scope2 == p -> Scope = p; Scope = p(p)))
;
Scope = p,
Lookup =.. [PDcl, Pred, _, Compilation, Meta, Ctn])),
('$lgt_pp_alias_'(Ptc, _, _) ->
Head =.. [CDcl, Alias, Scope, Compilation, Meta, Ctn],
'$lgt_construct_alias_functor'(Prefix, PRnm),
Rename =.. [PRnm, Ptc, Pred, Alias],
assertz('$lgt_pp_dcl_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup)))
;
Head =.. [CDcl, Pred, Scope, Compilation, Meta, Ctn],
assertz('$lgt_pp_dcl_'((Head:-Lookup)))),
fail.
'$lgt_gen_category_implements_dcl_clauses'.
'$lgt_gen_category_imports_dcl_clauses' :-
'$lgt_pp_category_'(_, Prefix, CDcl, _, _),
'$lgt_pp_imported_category_'(Ctg, _, ECDcl, _, EScope),
(EScope = (public) ->
Lookup =.. [ECDcl, Pred, Scope, Compilation, Meta, Ctn]
;
(EScope = protected ->
Call =.. [ECDcl, Pred, Scope2, Compilation, Meta, Ctn],
Lookup = (Call, (Scope2 == p -> Scope = p; Scope = p(p)))
;
Scope = p,
Lookup =.. [ECDcl, Pred, _, Compilation, Meta, Ctn])),
('$lgt_pp_alias_'(Ctg, _, _) ->
Head =.. [CDcl, Alias, Scope, Compilation, Meta, Ctn],
'$lgt_construct_alias_functor'(Prefix, PRnm),
Rename =.. [PRnm, Ctg, Pred, Alias],
assertz('$lgt_pp_dcl_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup)))
;
Head =.. [CDcl, Pred, Scope, Compilation, Meta, Ctn],
assertz('$lgt_pp_dcl_'((Head:-Lookup)))),
fail.
'$lgt_gen_category_imports_dcl_clauses'.
'$lgt_gen_category_def_clauses' :-
'$lgt_gen_category_catchall_def_clause',
'$lgt_gen_category_linking_def_clauses',
'$lgt_gen_category_imports_def_clauses'.
'$lgt_gen_category_catchall_def_clause' :-
\+ '$lgt_pp_def_'(_) ->
'$lgt_pp_category_'(_, _, _, Def, _),
Head =.. [Def, _, _, _, _, _],
assertz('$lgt_pp_def_'((Head:-fail)))
;
true.
'$lgt_gen_category_linking_def_clauses' :-
'$lgt_pp_category_'(Ctg, _, _, Def, _),
Head =.. [Def, Pred, Sender, This, Self, Call, Ctg],
Body =.. [Def, Pred, Sender, This, Self, Call],
assertz('$lgt_pp_def_'((Head:-Body))).
'$lgt_gen_category_imports_def_clauses' :-
'$lgt_pp_category_'(Ctg, Prefix, _, Def, _),
'$lgt_pp_rclause_'('$lgt_imports_category_'(Ctg, Ctg2, _)), % needed for parameter passing
'$lgt_pp_imported_category_'(Ctg2, _, _, Def2, _),
Lookup =.. [Def2, Pred, Sender, This, Self, Call, Ctn],
('$lgt_pp_alias_'(Ctg2, _, _) ->
Head =.. [Def, Alias, Sender, This, Self, Call, Ctn],
'$lgt_construct_alias_functor'(Prefix, PRnm),
Rename =.. [PRnm, Ctg2, Pred, Alias],
assertz('$lgt_pp_def_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup)))
;
Head =.. [Def, Pred, Sender, This, Self, Call, Ctn],
assertz('$lgt_pp_def_'((Head:-Lookup)))),
fail.
'$lgt_gen_category_imports_def_clauses'.
'$lgt_gen_prototype_clauses' :-
'$lgt_gen_prototype_dcl_clauses',
'$lgt_gen_prototype_def_clauses',
'$lgt_gen_prototype_super_clauses'.
'$lgt_gen_prototype_dcl_clauses' :-
'$lgt_gen_local_dcl_clauses',
'$lgt_gen_prototype_linking_dcl_clauses',
'$lgt_gen_prototype_implements_dcl_clauses',
'$lgt_gen_prototype_imports_dcl_clauses',
'$lgt_gen_prototype_extends_dcl_clauses'.
'$lgt_gen_prototype_linking_dcl_clauses' :-
'$lgt_pp_object_'(Obj, _, Dcl, _, _, _, _, DDcl, _, _),
Head =.. [Dcl, Pred, Scope, Compilation, Meta, Obj, Obj],
Body =.. [Dcl, Pred, Scope, Compilation, Meta],
assertz('$lgt_pp_dcl_'((Head:-Body))),
Head2 =.. [Dcl, Pred, Scope, (dynamic), no, Obj, Obj],
Body2 =.. [DDcl, Pred, Scope],
assertz('$lgt_pp_dcl_'((Head2:-Body2))).
'$lgt_gen_prototype_implements_dcl_clauses' :-
'$lgt_pp_object_'(Obj, Prefix, ODcl, _, _, _, _, _, _, _),
'$lgt_pp_implemented_protocol_'(Ptc, _, PDcl, EScope),
(EScope = (public) ->
Lookup =.. [PDcl, Pred, Scope, Compilation, Meta, Ctn]
;
(EScope = protected ->
Call =.. [PDcl, Pred, Scope2, Compilation, Meta, Ctn],
Lookup = (Call, (Scope2 == p -> Scope = p; Scope = p(p)))
;
Scope = p,
Lookup =.. [PDcl, Pred, _, Compilation, Meta, Ctn])),
('$lgt_pp_alias_'(Ptc, _, _) ->
Head =.. [ODcl, Alias, Scope, Compilation, Meta, Obj, Ctn],
'$lgt_construct_alias_functor'(Prefix, PRnm),
Rename =.. [PRnm, Ptc, Pred, Alias],
assertz('$lgt_pp_dcl_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup)))
;
Head =.. [ODcl, Pred, Scope, Compilation, Meta, Obj, Ctn],
assertz('$lgt_pp_dcl_'((Head:-Lookup)))),
fail.
'$lgt_gen_prototype_implements_dcl_clauses'.
'$lgt_gen_prototype_imports_dcl_clauses' :-
'$lgt_pp_object_'(Obj, Prefix, ODcl, _, _, _, _, _, _, _),
'$lgt_pp_imported_category_'(Ctg, _, CDcl, _, EScope),
(EScope = (public) ->
Lookup =.. [CDcl, Pred, Scope, Compilation, Meta, Ctn]
;
(EScope = protected ->
Call =.. [CDcl, Pred, Scope2, Compilation, Meta, Ctn],
Lookup = (Call, (Scope2 == p -> Scope = p; Scope = p(p)))
;
Scope = p,
Lookup =.. [CDcl, Pred, _, Compilation, Meta, Ctn])),
('$lgt_pp_alias_'(Ctg, _, _) ->
Head =.. [ODcl, Alias, Scope, Compilation, Meta, Obj, Ctn],
'$lgt_construct_alias_functor'(Prefix, PRnm),
Rename =.. [PRnm, Ctg, Pred, Alias],
assertz('$lgt_pp_dcl_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup)))
;
Head =.. [ODcl, Pred, Scope, Compilation, Meta, Obj, Ctn],
assertz('$lgt_pp_dcl_'((Head:-Lookup)))),
fail.
'$lgt_gen_prototype_imports_dcl_clauses'.
'$lgt_gen_prototype_extends_dcl_clauses' :-
'$lgt_pp_object_'(Obj, Prefix, ODcl, _, _, _, _, _, _, _),
'$lgt_pp_extended_object_'(Parent, _, PDcl, _, _, _, _, _, _, EScope),
(EScope = (public) ->
Lookup =.. [PDcl, Pred, Scope, Compilation, Meta, SCtn, TCtn]
;
(EScope = protected ->
Call =.. [PDcl, Pred, Scope2, Compilation, Meta, SCtn, TCtn],
Lookup = (Call, (Scope2 == p -> Scope = p; Scope = p(p)))
;
Scope = p,
Call =.. [PDcl, Pred, Scope2, Compilation, Meta, SCtn2, TCtn],
Lookup = (Call, (Scope2 == p -> SCtn = SCtn2; SCtn = Obj)))),
('$lgt_pp_alias_'(Parent, _, _) ->
Head =.. [ODcl, Alias, Scope, Compilation, Meta, SCtn, TCtn],
'$lgt_construct_alias_functor'(Prefix, PRnm),
Rename =.. [PRnm, Parent, Pred, Alias],
assertz('$lgt_pp_dcl_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup)))
;
Head =.. [ODcl, Pred, Scope, Compilation, Meta, SCtn, TCtn],
assertz('$lgt_pp_dcl_'((Head:-Lookup)))),
fail.
'$lgt_gen_prototype_extends_dcl_clauses'.
'$lgt_gen_prototype_def_clauses' :-
'$lgt_gen_local_def_clauses',
'$lgt_gen_obj_catchall_def_clause',
'$lgt_gen_prototype_linking_def_clauses',
'$lgt_gen_prototype_imports_def_clauses',
'$lgt_gen_prototype_extends_def_clauses'.
'$lgt_gen_prototype_linking_def_clauses' :-
'$lgt_pp_object_'(Obj, _, _, Def, _, _, _, _, DDef, _),
Head =.. [Def, Pred, Sender, This, Self, Call, Obj],
Body =.. [Def, Pred, Sender, This, Self, Call],
assertz('$lgt_pp_def_'((Head:-Body))),
Body2 =.. [DDef, Pred, Sender, This, Self, Call],
assertz('$lgt_pp_def_'((Head:-Body2))).
'$lgt_gen_prototype_imports_def_clauses' :-
'$lgt_pp_object_'(Obj, Prefix, _, ODef, _, _, _, _, _, _),
'$lgt_pp_rclause_'('$lgt_imports_category_'(Obj, Ctg, _)), % needed for parameter passing
'$lgt_pp_imported_category_'(Ctg, _, _, CDef, _),
Lookup =.. [CDef, Pred, Sender, Obj, Self, Call, Ctn],
('$lgt_pp_alias_'(Ctg, _, _) ->
Head =.. [ODef, Alias, Sender, Obj, Self, Call, Ctn],
'$lgt_construct_alias_functor'(Prefix, PRnm),
Rename =.. [PRnm, Ctg, Pred, Alias],
assertz('$lgt_pp_def_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup)))
;
Head =.. [ODef, Pred, Sender, Obj, Self, Call, Ctn],
assertz('$lgt_pp_def_'((Head:-Lookup)))),
fail.
'$lgt_gen_prototype_imports_def_clauses'.
'$lgt_gen_prototype_extends_def_clauses' :-
'$lgt_pp_object_'(Obj, Prefix, _, ODef, _, _, _, _, _, _),
'$lgt_pp_rclause_'('$lgt_extends_object_'(Obj, Parent, _)), % needed for parameter passing
'$lgt_pp_extended_object_'(Parent, _, _, PDef, _, _, _, _, _, _),
Lookup =.. [PDef, Pred, Sender, Parent, Self, Call, Ctn],
('$lgt_pp_alias_'(Parent, _, _) ->
Head =.. [ODef, Alias, Sender, Obj, Self, Call, Ctn],
'$lgt_construct_alias_functor'(Prefix, PRnm),
Rename =.. [PRnm, Parent, Pred, Alias],
assertz('$lgt_pp_def_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup)))
;
Head =.. [ODef, Pred, Sender, Obj, Self, Call, Ctn],
assertz('$lgt_pp_def_'((Head:-Lookup)))),
fail.
'$lgt_gen_prototype_extends_def_clauses'.
% we can have a root object where super have nowhere to go ...
'$lgt_gen_prototype_super_clauses' :-
'$lgt_pp_object_'(_, _, _, _, OSuper, _, _, _, _, _),
\+ '$lgt_pp_extended_object_'(_, _, _, _, _, _, _, _, _, _),
Head =.. [OSuper, _, _, _, _, _, _],
assertz('$lgt_pp_def_'((Head:-fail))),
!.
% ... or we may extends some objects
'$lgt_gen_prototype_super_clauses' :-
'$lgt_pp_object_'(Obj, Prefix, _, _, OSuper, _, _, _, _, _),
'$lgt_pp_rclause_'('$lgt_extends_object_'(Obj, Parent, _)), % needed for parameter passing
'$lgt_pp_extended_object_'(Parent, _, _, PDef, _, _, _, _, _, _),
Lookup =.. [PDef, Pred, Sender, Parent, Self, Call, Ctn],
('$lgt_pp_alias_'(Parent, _, _) ->
Head =.. [OSuper, Alias, Sender, Obj, Self, Call, Ctn],
'$lgt_construct_alias_functor'(Prefix, PRnm),
Rename =.. [PRnm, Parent, Pred, Alias],
assertz('$lgt_pp_def_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup)))
;
Head =.. [OSuper, Pred, Sender, Obj, Self, Call, Ctn],
assertz('$lgt_pp_def_'((Head:-Lookup)))),
fail.
'$lgt_gen_prototype_super_clauses'.
'$lgt_gen_ic_clauses' :-
'$lgt_gen_ic_dcl_clauses',
'$lgt_gen_ic_idcl_clauses',
'$lgt_gen_ic_def_clauses',
'$lgt_gen_ic_idef_clauses',
'$lgt_gen_ic_super_clauses'.
'$lgt_gen_ic_dcl_clauses' :-
'$lgt_gen_local_dcl_clauses',
'$lgt_gen_ic_hierarchy_dcl_clauses'.
'$lgt_gen_ic_hierarchy_dcl_clauses' :-
\+ '$lgt_pp_instantiated_class_'(_, _, _, _, _, _, _, _, _, _),
!,
'$lgt_pp_object_'(_, _, ODcl, _, _, _, _, _, _, _),
Head =.. [ODcl, _, _, _, _, _, _],
assertz('$lgt_pp_dcl_'((Head:-fail))).
'$lgt_gen_ic_hierarchy_dcl_clauses' :-
'$lgt_pp_object_'(Obj, Prefix, ODcl, _, _, _, _, _, _, _),
'$lgt_pp_instantiated_class_'(Class, _, _, _, _, CIDcl, _, _, _, EScope),
(EScope = (public) ->
Lookup =.. [CIDcl, Pred, Scope, Compilation, Meta, SCtn, TCtn]
;
(EScope = protected ->
Call =.. [CIDcl, Pred, Scope2, Compilation, Meta, SCtn, TCtn],
Lookup = (Call, (Scope2 == p -> Scope = p; Scope = p(p)))
;
Scope = p,
Call =.. [CIDcl, Pred, Scope2, Compilation, Meta, SCtn2, TCtn],
Lookup = (Call, (Scope2 == p -> SCtn = SCtn2; SCtn = Obj)))),
('$lgt_pp_alias_'(Class, _, _) ->
Head =.. [ODcl, Alias, Scope, Compilation, Meta, SCtn, TCtn],
'$lgt_construct_alias_functor'(Prefix, PRnm),
Rename =.. [PRnm, Class, Pred, Alias],
assertz('$lgt_pp_dcl_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup)))
;
Head =.. [ODcl, Pred, Scope, Compilation, Meta, SCtn, TCtn],
assertz('$lgt_pp_dcl_'((Head:-Lookup)))),
fail.
'$lgt_gen_ic_hierarchy_dcl_clauses'.
% generates instance/class inherited declaration clauses
'$lgt_gen_ic_idcl_clauses' :-
'$lgt_gen_ic_linking_idcl_clauses',
'$lgt_gen_ic_protocol_idcl_clauses',
'$lgt_gen_ic_category_idcl_clauses',
'$lgt_gen_ic_hierarchy_idcl_clauses'.
'$lgt_gen_ic_linking_idcl_clauses' :-
'$lgt_pp_object_'(Obj, _, Dcl, _, _, IDcl, _, DDcl, _, _),
Head =.. [IDcl, Pred, Scope, Compilation, Meta, Obj, Obj],
Body =.. [Dcl, Pred, Scope, Compilation, Meta],
assertz('$lgt_pp_dcl_'((Head:-Body))),
Head2 =.. [IDcl, Pred, Scope, (dynamic), no, Obj, Obj],
Body2 =.. [DDcl, Pred, Scope],
assertz('$lgt_pp_dcl_'((Head2:-Body2))).
'$lgt_gen_ic_protocol_idcl_clauses' :-
'$lgt_pp_object_'(Obj, Prefix, _, _, _, OIDcl, _, _, _, _),
'$lgt_pp_implemented_protocol_'(Ptc, _, PDcl, EScope),
(EScope = (public) ->
Lookup =.. [PDcl, Pred, Scope, Compilation, Meta, Ctn]
;
(EScope = protected ->
Call =.. [PDcl, Pred, Scope2, Compilation, Meta, Ctn],
Lookup = (Call, (Scope2 == p -> Scope = p; Scope = p(p)))
;
Scope = p,
Lookup =.. [PDcl, Pred, _, Compilation, Meta, Ctn])),
('$lgt_pp_alias_'(Ptc, _, _) ->
Head =.. [OIDcl, Alias, Scope, Compilation, Meta, Obj, Ctn],
'$lgt_construct_alias_functor'(Prefix, PRnm),
Rename =.. [PRnm, Ptc, Pred, Alias],
assertz('$lgt_pp_dcl_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup)))
;
Head =.. [OIDcl, Pred, Scope, Compilation, Meta, Obj, Ctn],
assertz('$lgt_pp_dcl_'((Head:-Lookup)))),
fail.
'$lgt_gen_ic_protocol_idcl_clauses'.
'$lgt_gen_ic_category_idcl_clauses' :-
'$lgt_pp_object_'(Obj, Prefix, _, _, _, OIDcl, _, _, _, _),
'$lgt_pp_imported_category_'(Ctg, _, CDcl, _, EScope),
(EScope = (public) ->
Lookup =.. [CDcl, Pred, Scope, Compilation, Meta, Ctn]
;
(EScope = protected ->
Call =.. [CDcl, Pred, Scope2, Compilation, Meta, Ctn],
Lookup = (Call, (Scope2 == p -> Scope = p; Scope = p(p)))
;
Scope = p,
Lookup =.. [CDcl, Pred, _, Compilation, Meta, Ctn])),
('$lgt_pp_alias_'(Ctg, _, _) ->
Head =.. [OIDcl, Alias, Scope, Compilation, Meta, Obj, Ctn],
'$lgt_construct_alias_functor'(Prefix, PRnm),
Rename =.. [PRnm, Ctg, Pred, Alias],
assertz('$lgt_pp_dcl_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup)))
;
Head =.. [OIDcl, Pred, Scope, Compilation, Meta, Obj, Ctn],
assertz('$lgt_pp_dcl_'((Head:-Lookup)))),
fail.
'$lgt_gen_ic_category_idcl_clauses'.
'$lgt_gen_ic_hierarchy_idcl_clauses' :-
'$lgt_pp_object_'(Obj, Prefix, _, _, _, CIDcl, _, _, _, _),
'$lgt_pp_specialized_class_'(Super, _, _, _, _, SIDcl, _, _, _, EScope),
(EScope = (public) ->
Lookup =.. [SIDcl, Pred, Scope, Compilation, Meta, SCtn, TCtn]
;
(EScope = protected ->
Call =.. [SIDcl, Pred, Scope2, Compilation, Meta, SCtn, TCtn],
Lookup = (Call, (Scope2 == p -> Scope = p; Scope = p(p)))
;
Scope = p,
Call =.. [SIDcl, Pred, Scope2, Compilation, Meta, SCtn2, TCtn],
Lookup = (Call, (Scope2 == p -> SCtn = SCtn2; SCtn = Obj)))),
('$lgt_pp_alias_'(Super, _, _) ->
Head =.. [CIDcl, Alias, Scope, Compilation, Meta, SCtn, TCtn],
'$lgt_construct_alias_functor'(Prefix, PRnm),
Rename =.. [PRnm, Super, Pred, Alias],
assertz('$lgt_pp_dcl_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup)))
;
Head =.. [CIDcl, Pred, Scope, Compilation, Meta, SCtn, TCtn],
assertz('$lgt_pp_dcl_'((Head:-Lookup)))),
fail.
'$lgt_gen_ic_hierarchy_idcl_clauses'.
'$lgt_gen_ic_def_clauses' :-
'$lgt_gen_local_def_clauses',
'$lgt_gen_obj_catchall_def_clause',
'$lgt_gen_ic_linking_def_clauses',
'$lgt_gen_ic_imports_def_clauses',
'$lgt_gen_ic_hierarchy_def_clauses'.
'$lgt_gen_ic_linking_def_clauses' :-
'$lgt_pp_object_'(Obj, _, _, Def, _, _, _, _, DDef, _),
Head =.. [Def, Pred, Sender, This, Self, Call, Obj],
Body =.. [Def, Pred, Sender, This, Self, Call],
assertz('$lgt_pp_def_'((Head:-Body))),
Body2 =.. [DDef, Pred, Sender, This, Self, Call],
assertz('$lgt_pp_def_'((Head:-Body2))).
'$lgt_gen_ic_imports_def_clauses' :-
'$lgt_pp_object_'(Obj, Prefix, _, ODef, _, _, _, _, _, _),
'$lgt_pp_rclause_'('$lgt_imports_category_'(Obj, Ctg, _)), % needed for parameter passing
'$lgt_pp_imported_category_'(Ctg, _, _, CDef, _),
Lookup =.. [CDef, Pred, Sender, Obj, Self, Call, Ctn],
('$lgt_pp_alias_'(Ctg, _, _) ->
Head =.. [ODef, Alias, Sender, Obj, Self, Call, Ctn],
'$lgt_construct_alias_functor'(Prefix, PRnm),
Rename =.. [PRnm, Ctg, Pred, Alias],
assertz('$lgt_pp_def_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup)))
;
Head =.. [ODef, Pred, Sender, Obj, Self, Call, Ctn],
assertz('$lgt_pp_def_'((Head:-Lookup)))),
fail.
'$lgt_gen_ic_imports_def_clauses'.
'$lgt_gen_ic_hierarchy_def_clauses' :-
'$lgt_pp_object_'(Obj, Prefix, _, ODef, _, _, _, _, _, _),
'$lgt_pp_rclause_'('$lgt_instantiates_class_'(Obj, Class, _)), % needed for parameter passing
'$lgt_pp_instantiated_class_'(Class, _, _, _, _, _, CIDef, _, _, _),
Lookup =.. [CIDef, Pred, Sender, Class, Self, Call, Ctn],
('$lgt_pp_alias_'(Class, _, _) ->
Head =.. [ODef, Alias, Sender, Obj, Self, Call, Ctn],
'$lgt_construct_alias_functor'(Prefix, PRnm),
Rename =.. [PRnm, Class, Pred, Alias],
assertz('$lgt_pp_def_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup)))
;
Head =.. [ODef, Pred, Sender, Obj, Self, Call, Ctn],
assertz('$lgt_pp_def_'((Head:-Lookup)))),
fail.
'$lgt_gen_ic_hierarchy_def_clauses'.
'$lgt_gen_ic_idef_clauses' :-
'$lgt_gen_ic_linking_idef_clauses',
'$lgt_gen_ic_category_idef_clauses',
'$lgt_gen_ic_hierarchy_idef_clauses'.
'$lgt_gen_ic_linking_idef_clauses' :-
'$lgt_pp_object_'(Obj, _, _, Def, _, _, IDef, _, DDef, _),
Head =.. [IDef, Pred, Sender, This, Self, Call, Obj],
Body =.. [Def, Pred, Sender, This, Self, Call],
assertz('$lgt_pp_def_'((Head:-Body))),
Body2 =.. [DDef, Pred, Sender, This, Self, Call],
assertz('$lgt_pp_def_'((Head:-Body2))).
'$lgt_gen_ic_category_idef_clauses' :-
'$lgt_pp_object_'(Obj, Prefix, _, _, _, _, OIDef, _, _, _),
'$lgt_pp_rclause_'('$lgt_imports_category_'(Obj, Ctg, _)), % needed for parameter passing
'$lgt_pp_imported_category_'(Ctg, _, _, CDef, _),
Lookup =.. [CDef, Pred, Sender, Obj, Self, Call],
('$lgt_pp_alias_'(Ctg, _, _) ->
Head =.. [OIDef, Alias, Sender, Obj, Self, Call, Ctg],
'$lgt_construct_alias_functor'(Prefix, PRnm),
Rename =.. [PRnm, Ctg, Pred, Alias],
assertz('$lgt_pp_def_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup)))
;
Head =.. [OIDef, Pred, Sender, Obj, Self, Call, Ctg],
assertz('$lgt_pp_def_'((Head:-Lookup)))),
fail.
'$lgt_gen_ic_category_idef_clauses'.
'$lgt_gen_ic_hierarchy_idef_clauses' :-
'$lgt_pp_object_'(Class, Prefix, _, _, _, _, CIDef, _, _, _),
'$lgt_pp_rclause_'('$lgt_specializes_class_'(Class, Super, _)), % needed for parameter passing
'$lgt_pp_specialized_class_'(Super, _, _, _, _, _, SIDef, _, _, _),
Lookup =.. [SIDef, Pred, Sender, Super, Self, Call, Ctn],
('$lgt_pp_alias_'(Super, _, _) ->
Head =.. [CIDef, Alias, Sender, Class, Self, Call, Ctn],
'$lgt_construct_alias_functor'(Prefix, PRnm),
Rename =.. [PRnm, Super, Pred, Alias],
assertz('$lgt_pp_def_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup)))
;
Head =.. [CIDef, Pred, Sender, Class, Self, Call, Ctn],
assertz('$lgt_pp_def_'((Head:-Lookup)))),
fail.
'$lgt_gen_ic_hierarchy_idef_clauses'.
% we can have a root object where super have nowhere to go ...
'$lgt_gen_ic_super_clauses' :-
'$lgt_pp_object_'(_, _, _, _, OSuper, _, _, _, _, _),
\+ '$lgt_pp_instantiated_class_'(_, _, _, _, _, _, _, _, _, _),
\+ '$lgt_pp_specialized_class_'(_, _, _, _, _, _, _, _, _, _),
Head =.. [OSuper, _, _, _, _, _, _],
assertz('$lgt_pp_def_'((Head:-fail))),
!.
% ... or predicates can be redefined in instances...
'$lgt_gen_ic_super_clauses' :-
'$lgt_pp_object_'(Obj, Prefix, _, _, OSuper, _, _, _, _, _),
'$lgt_pp_rclause_'('$lgt_instantiates_class_'(Obj, Class, _)), % needed for parameter passing
'$lgt_pp_instantiated_class_'(Class, _, _, _, _, _, CIDef, _, _, _),
Lookup =.. [CIDef, Pred, Sender, Class, Obj, Call, Ctn],
('$lgt_pp_alias_'(Class, _, _) ->
Head =.. [OSuper, Alias, Sender, Obj, Obj, Call, Ctn],
'$lgt_construct_alias_functor'(Prefix, PRnm),
Rename =.. [PRnm, Class, Pred, Alias],
assertz('$lgt_pp_def_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup)))
;
Head =.. [OSuper, Pred, Sender, Obj, Obj, Call, Ctn],
assertz('$lgt_pp_def_'((Head:-Lookup)))),
fail.
% ... or/and in subclasses...
'$lgt_gen_ic_super_clauses' :-
'$lgt_pp_object_'(Class, Prefix, _, _, CSuper, _, _, _, _, _),
'$lgt_pp_rclause_'('$lgt_specializes_class_'(Class, Super, _)), % needed for parameter passing
'$lgt_pp_specialized_class_'(Super, _, _, _, _, _, SIDef, _, _, _),
Lookup =.. [SIDef, Pred, Sender, Super, Self, Call, Ctn],
('$lgt_pp_alias_'(Super, _, _) ->
Head =.. [CSuper, Alias, Sender, Class, Self, Call, Ctn],
'$lgt_construct_alias_functor'(Prefix, PRnm),
Rename =.. [PRnm, Super, Pred, Alias],
assertz('$lgt_pp_def_'((Head :- var(Alias) -> Lookup, Rename; Rename, Lookup)))
;
Head =.. [CSuper, Pred, Sender, Class, Self, Call, Ctn],
assertz('$lgt_pp_def_'((Head:-Lookup)))),
fail.
'$lgt_gen_ic_super_clauses'.
% '$lgt_fix_redef_built_ins'
%
% fix the calls of any redefined built-in predicate in all entity clauses
% and initialization goals
'$lgt_fix_redef_built_ins' :-
\+ '$lgt_pp_redefined_built_in_'(_, _, _),
assertz(('$lgt_pp_feclause_'(Clause) :- '$lgt_pp_eclause_'(Clause))),
assertz(('$lgt_pp_fentity_init_'(Goal) :- '$lgt_pp_entity_init_'(Goal))),
!.
'$lgt_fix_redef_built_ins' :-
retract('$lgt_pp_eclause_'(Clause)),
'$lgt_fix_redef_built_ins'(Clause, Fixed),
assertz('$lgt_pp_feclause_'(Fixed)),
fail.
'$lgt_fix_redef_built_ins' :-
retract('$lgt_pp_entity_init_'(Call)),
'$lgt_fix_redef_built_ins'(Call, Fixed),
assertz('$lgt_pp_fentity_init_'(Fixed)),
fail.
'$lgt_fix_redef_built_ins'.
% '$lgt_fix_redef_built_ins'(+clause, -clause)
%
% fix calls to redefined built-in predicates
'$lgt_fix_redef_built_ins'(Pred, Pred) :-
var(Pred),
!.
'$lgt_fix_redef_built_ins'((Head:-Body), (Head:-Fixed)) :-
!,
'$lgt_fix_redef_built_ins'(Body, Fixed).
'$lgt_fix_redef_built_ins'((Pred1, Pred2), (TPred1, TPred2)) :-
!,
'$lgt_fix_redef_built_ins'(Pred1, TPred1),
'$lgt_fix_redef_built_ins'(Pred2, TPred2).
'$lgt_fix_redef_built_ins'((Pred1; Pred2), (TPred1; TPred2)) :-
!,
'$lgt_fix_redef_built_ins'(Pred1, TPred1),
'$lgt_fix_redef_built_ins'(Pred2, TPred2).
'$lgt_fix_redef_built_ins'((Pred1 -> Pred2), (TPred1 -> TPred2)) :-
!,
'$lgt_fix_redef_built_ins'(Pred1, TPred1),
'$lgt_fix_redef_built_ins'(Pred2, TPred2).
'$lgt_fix_redef_built_ins'(\+ Pred, \+ TPred) :-
!,
'$lgt_fix_redef_built_ins'(Pred, TPred).
'$lgt_fix_redef_built_ins'(call(Pred), call(TPred)) :-
!,
'$lgt_fix_redef_built_ins'(Pred, TPred).
'$lgt_fix_redef_built_ins'(once(Pred), once(TPred)) :-
!,
'$lgt_fix_redef_built_ins'(Pred, TPred).
'$lgt_fix_redef_built_ins'(catch(Goal, Catcher, Recovery), catch(TGoal, Catcher, TRecovery)) :-
!,
'$lgt_fix_redef_built_ins'(Goal, TGoal),
'$lgt_fix_redef_built_ins'(Recovery, TRecovery).
'$lgt_fix_redef_built_ins'(bagof(Term, Pred, List), bagof(Term, TPred, List)) :-
!,
'$lgt_fix_redef_built_ins'(Pred, TPred).
'$lgt_fix_redef_built_ins'(findall(Term, Pred, List), findall(Term, TPred, List)) :-
!,
'$lgt_fix_redef_built_ins'(Pred, TPred).
'$lgt_fix_redef_built_ins'(forall(Gen, Test), forall(TGen, TTest)) :-
!,
'$lgt_fix_redef_built_ins'(Gen, TGen),
'$lgt_fix_redef_built_ins'(Test, TTest).
'$lgt_fix_redef_built_ins'(setof(Term, Pred, List), setof(Term, TPred, List)) :-
!,
'$lgt_fix_redef_built_ins'(Pred, TPred).
'$lgt_fix_redef_built_ins'('$lgt_dbg_goal'(OPred, Pred, Ctx), '$lgt_dbg_goal'(OPred, TPred, Ctx)) :-
!,
'$lgt_fix_redef_built_ins'(Pred, TPred).
'$lgt_fix_redef_built_ins'(Pred, TPred) :-
'$lgt_pl_built_in'(Pred),
functor(Pred, Functor, Arity),
functor(Meta, Functor, Arity),
'$lgt_pl_metapredicate'(Meta),
!,
Pred =.. [_| Args],
Meta =.. [_| MArgs],
'$lgt_fix_redef_built_ins_in_margs'(Args, MArgs, TArgs),
TPred =.. [Functor| TArgs].
'$lgt_fix_redef_built_ins'('$lgt_call_built_in'(Pred, Ctx), TPred) :-
!,
('$lgt_pp_redefined_built_in_'(Pred, Ctx, TPred) ->
true
;
'$lgt_fix_redef_built_ins'(Pred, TPred)).
'$lgt_fix_redef_built_ins'(Pred, Pred).
% '$lgt_fix_redef_built_ins_in_margs'(@list, @list, -list)
%
% fix calls to redefined built-in predicates in non-standard
% metapredicate arguments
'$lgt_fix_redef_built_ins_in_margs'([], [], []).
'$lgt_fix_redef_built_ins_in_margs'([Arg| Args], [MArg| MArgs], [TArg| TArgs]) :-
'$lgt_fix_redef_built_ins_in_marg'(MArg, Arg, TArg),
'$lgt_fix_redef_built_ins_in_margs'(Args, MArgs, TArgs).
'$lgt_fix_redef_built_ins_in_marg'(*, Arg, Arg).
'$lgt_fix_redef_built_ins_in_marg'(::, Arg, TArg) :-
'$lgt_fix_redef_built_ins'(Arg, TArg).
% find and report misspelt predicate calls
% in the body of objects/cartegories predicates
'$lgt_find_misspelt_calls' :-
setof(Pred,
('$lgt_pp_calls_pred_'(Pred), \+ '$lgt_pp_defs_pred_'(Pred), \+ '$lgt_pp_dynamic_'(Pred)),
Preds) ->
'$lgt_report_misspelt_calls'(Preds)
;
true.
% '$lgt_report_misspelt_calls'(+list)
'$lgt_report_misspelt_calls'([]).
'$lgt_report_misspelt_calls'([Pred| Preds]) :-
('$lgt_compiler_option'(misspelt, warning),
'$lgt_compiler_option'(report, on)) ->
write('> WARNING! these static predicates are called but never defined: '),
writeq([Pred| Preds]), nl
;
true.
% '$lgt_pp_entity_functors'(-compound)
'$lgt_pp_entity_functors'(Clause) :-
'$lgt_pp_object_'(_, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, _),
Clause =.. [Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef],
!.
'$lgt_pp_entity_functors'(Clause) :-
'$lgt_pp_category_'(_, Prefix, Dcl, Def, _),
Clause =.. [Prefix, Dcl, Def],
!.
'$lgt_pp_entity_functors'(Clause) :-
'$lgt_pp_protocol_'(_, Prefix, Dcl, _),
Clause =.. [Prefix, Dcl].
% '$lgt_write_directives'(+stream)
%
% writes the directives
'$lgt_write_directives'(Stream) :-
'$lgt_pp_directive_'(Dir),
write_canonical(Stream, (:- Dir)),
write(Stream, '.'),
nl(Stream),
fail.
'$lgt_write_directives'(_).
'$lgt_write_clauses'(Stream) :-
'$lgt_write_functors_clause'(Stream),
'$lgt_write_dcl_clauses'(Stream),
'$lgt_write_def_clauses'(Stream),
'$lgt_write_ddef_clauses'(Stream),
'$lgt_write_super_clauses'(Stream),
'$lgt_write_alias_clauses'(Stream),
'$lgt_write_entity_clauses'(Stream).
'$lgt_write_functors_clause'(Stream) :-
'$lgt_pp_entity_functors'(Clause),
write_canonical(Stream, Clause),
write(Stream, '.'),
nl(Stream).
'$lgt_write_def_clauses'(Stream) :-
'$lgt_pp_def_'(Clause),
write_canonical(Stream, Clause),
write(Stream, '.'), nl(Stream),
fail.
'$lgt_write_def_clauses'(_).
'$lgt_write_ddef_clauses'(Stream) :-
'$lgt_pp_ddef_'(Clause),
write_canonical(Stream, Clause),
write(Stream, '.'), nl(Stream),
fail.
'$lgt_write_ddef_clauses'(_).
'$lgt_write_dcl_clauses'(Stream) :-
'$lgt_pp_dcl_'(Clause),
write_canonical(Stream, Clause),
write(Stream, '.'),
nl(Stream),
fail.
'$lgt_write_dcl_clauses'(_).
'$lgt_write_super_clauses'(Stream) :-
'$lgt_pp_super_'(Clause),
write_canonical(Stream, Clause),
write(Stream, '.'),
nl(Stream),
fail.
'$lgt_write_super_clauses'(_).
'$lgt_write_alias_clauses'(Stream) :-
'$lgt_pp_entity'(_, _, Prefix, _, _),
'$lgt_construct_alias_functor'(Prefix, PRnm),
'$lgt_write_alias_clauses'(Stream, PRnm).
'$lgt_write_alias_clauses'(Stream, Rnm) :-
'$lgt_pp_alias_'(Entity, Pred, Alias),
Clause =.. [Rnm, Entity, Pred, Alias],
write_canonical(Stream, Clause),
write(Stream, '.'),
nl(Stream),
fail.
'$lgt_write_alias_clauses'(Stream, Rnm) :-
Catchall =.. [Rnm, _, Pred, Pred],
write_canonical(Stream, Catchall),
write(Stream, '.'),
nl(Stream).
'$lgt_write_entity_clauses'(Stream) :-
'$lgt_pp_feclause_'(Clause),
write_canonical(Stream, Clause),
write(Stream, '.'),
nl(Stream),
fail.
'$lgt_write_entity_clauses'(_).
% '$lgt_write_init_call'(+stream)
%
% writes the initialization call for the compiled entity that will assert
% the relation clauses and call any declared initialization goal when the
% entity is loaded
'$lgt_write_init_call'(Stream) :-
'$lgt_pp_entity'(_, Entity, _, _, _),
findall(Clause, '$lgt_pp_rclause'(Clause), Clauses),
('$lgt_compiler_option'(debug, on) ->
Goal1 = ('$lgt_assert_relation_clauses'(Clauses), assertz('$lgt_debugging_'(Entity)))
;
Goal1 = '$lgt_assert_relation_clauses'(Clauses)),
('$lgt_pp_fentity_init_'(Goal2) ->
Goal = (Goal1, Goal2)
;
Goal = Goal1),
('$lgt_compiler_option'(iso_initialization_dir, true) ->
write_canonical(Stream, (:- initialization(Goal)))
;
write_canonical(Stream, (:- Goal))),
write(Stream, '.'), nl(Stream).
% '$lgt_assert_tr_entity'
%
% adds a dynamically created entity to memory
'$lgt_assert_tr_entity' :-
'$lgt_assert_directives',
'$lgt_assert_functors_clause',
'$lgt_assert_dcl_clauses',
'$lgt_assert_def_clauses',
'$lgt_assert_ddef_clauses',
'$lgt_assert_super_clauses',
'$lgt_assert_entity_clauses',
'$lgt_assert_relation_clauses',
'$lgt_assert_init'.
'$lgt_assert_directives' :-
'$lgt_pp_directive_'((dynamic(Functor/Arity))),
functor(Pred, Functor, Arity),
asserta(Pred),
retract(Pred),
fail.
'$lgt_assert_directives' :-
'$lgt_pp_directive_'((op(Pr, Spec, Ops))),
op(Pr, Spec, Ops),
fail.
'$lgt_assert_directives'.
'$lgt_assert_functors_clause' :-
'$lgt_pp_entity_functors'(Clause),
assertz(Clause).
'$lgt_assert_dcl_clauses' :-
'$lgt_pp_dcl_'(Clause),
assertz(Clause),
fail.
'$lgt_assert_dcl_clauses'.
'$lgt_assert_def_clauses' :-
'$lgt_pp_def_'(Clause),
assertz(Clause),
fail.
'$lgt_assert_def_clauses'.
'$lgt_assert_ddef_clauses' :-
'$lgt_pp_ddef_'(Clause),
assertz(Clause),
fail.
'$lgt_assert_ddef_clauses'.
'$lgt_assert_super_clauses' :-
'$lgt_pp_super_'(Clause),
assertz(Clause),
fail.
'$lgt_assert_super_clauses'.
'$lgt_assert_entity_clauses' :-
'$lgt_pp_feclause_'(Clause),
assertz(Clause),
fail.
'$lgt_assert_entity_clauses'.
'$lgt_assert_relation_clauses' :-
'$lgt_pp_rclause'(Clause),
assertz(Clause),
fail.
'$lgt_assert_relation_clauses'.
% '$lgt_assert_init'
%
% call any defined initialization goal for a dynamically created entity
'$lgt_assert_init' :-
('$lgt_compiler_option'(debug, on) ->
'$lgt_pp_entity'(_, Entity, _, _, _),
assertz('$lgt_debugging_'(Entity))
;
true),
('$lgt_pp_fentity_init_'(Goal) ->
once(Goal)
;
true).
% '$lgt_assert_relation_clauses'(+list)
%
% called when loading a compiled Logtalk entity to update Logtalk
% internal tables
%
% we may be reloading the entity so we must first retract any old
% relation clauses before asserting the new ones
'$lgt_assert_relation_clauses'([Clause| Clauses]) :-
arg(1, Clause, Entity),
'$lgt_retract_old_relation_clauses'(Entity),
'$lgt_assert_new_relation_clauses'([Clause| Clauses]).
'$lgt_retract_old_relation_clauses'(Entity) :-
retractall('$lgt_current_object_'(Entity, _, _, _, _, _)),
retractall('$lgt_current_protocol_'(Entity, _, _)),
retractall('$lgt_current_category_'(Entity, _, _)),
retractall('$lgt_implements_protocol_'(Entity, _, _)),
retractall('$lgt_imports_category_'(Entity, _, _)),
retractall('$lgt_instantiates_class_'(Entity, _, _)),
retractall('$lgt_specializes_class_'(Entity, _, _)),
retractall('$lgt_extends_protocol_'(Entity, _, _)),
retractall('$lgt_extends_object_'(Entity, _, _)),
retractall('$lgt_debugging_'(Entity)).
'$lgt_assert_new_relation_clauses'([]).
'$lgt_assert_new_relation_clauses'([Clause| Clauses]) :-
assertz(Clause),
'$lgt_assert_new_relation_clauses'(Clauses).
% '$lgt_construct_object_functors'(+compound, -atom, -atom, -atom, -atom, -atom, -atom, -atom, -atom)
%
% constructs all the functors used in the compiled code of an object
'$lgt_construct_object_functors'(Obj, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef) :-
'$lgt_compiler_option'(code_prefix, Code),
functor(Obj, Functor, Arity),
number_codes(Arity, Codes),
atom_codes(Atom, Codes),
atom_concat(Functor, Atom, Aux),
atom_concat(Code, Aux, Aux2),
atom_concat(Aux2, '_', 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).
% '$lgt_construct_protocol_functors'(+compound, -atom, -atom)
%
% constructs all the functors used in the compiled code of a protocol
'$lgt_construct_protocol_functors'(Ptc, Prefix, Dcl) :-
'$lgt_compiler_option'(code_prefix, Code),
functor(Ptc, Functor, Arity),
number_codes(Arity, Codes),
atom_codes(Atom, Codes),
atom_concat(Functor, Atom, Aux),
atom_concat(Code, Aux, Aux2),
atom_concat(Aux2, '_', Prefix),
atom_concat(Prefix, '_dcl', Dcl).
% '$lgt_construct_category_functors'(+compound, -atom, -atom, -atom)
%
% constructs all the functors used in the compiled code of a category
'$lgt_construct_category_functors'(Ctg, Prefix, Dcl, Def) :-
'$lgt_compiler_option'(code_prefix, Code),
functor(Ctg, Functor, Arity),
number_codes(Arity, Codes),
atom_codes(Atom, Codes),
atom_concat(Functor, Atom, Aux),
atom_concat(Code, Aux, Aux2),
atom_concat(Aux2, '_', Prefix),
atom_concat(Prefix, '_dcl', Dcl),
atom_concat(Prefix, '_def', Def).
% '$lgt_construct_predicate_functor'(+atom, +atom, +integer, -atom)
%
% constructs the functor used for a compiled predicate
'$lgt_construct_predicate_functor'(EPrefix, Functor, Arity, PPrefix) :-
atom_concat(EPrefix, Functor, Aux),
number_codes(Arity, Codes),
atom_codes(Atom, Codes),
atom_concat(Aux, Atom, PPrefix).
% '$lgt_built_in'(+callable)
%
% checks if the argument is either a Prolog or Logtalk built-in predicate
'$lgt_built_in'(Pred) :-
'$lgt_pl_built_in'(Pred),
!.
'$lgt_built_in'(Pred) :-
'$lgt_lgt_built_in'(Pred).
% '$lgt_pl_built_in'(+callable)
%
% either host Prolog native built-ins or missing ISO built-ins
% that we have defined in the correspondent config file
'$lgt_pl_built_in'(Pred) :-
'$lgt_predicate_property'(Pred, built_in),
!.
'$lgt_pl_built_in'(Pred) :-
'$lgt_iso_predicate'(Pred).
% logtalk built-in methods
%
% '$lgt_built_in_method'(?callable, ?scope)
'$lgt_built_in_method'(parameter(_, _), p).
'$lgt_built_in_method'(self(_), p).
'$lgt_built_in_method'(sender(_), p).
'$lgt_built_in_method'(this(_), p).
'$lgt_built_in_method'(current_predicate(_), p(p(p))).
'$lgt_built_in_method'(predicate_property(_, _), p(p(p))).
'$lgt_built_in_method'(abolish(_), p(p(p))).
'$lgt_built_in_method'(asserta(_), p(p(p))).
'$lgt_built_in_method'(assertz(_), p(p(p))).
'$lgt_built_in_method'(clause(_, _), p(p(p))).
'$lgt_built_in_method'(retract(_), p(p(p))).
'$lgt_built_in_method'(retractall(_), p(p(p))).
'$lgt_built_in_method'(bagof(_, _, _), p(p(p))).
'$lgt_built_in_method'(findall(_, _, _), p(p(p))).
'$lgt_built_in_method'(forall(_, _), p(p(p))).
'$lgt_built_in_method'(setof(_, _, _), p(p(p))).
'$lgt_built_in_method'(expand_term(_, _), p(p(p))).
'$lgt_built_in_method'(phrase(_, _), p(p(p))).
'$lgt_built_in_method'(phrase(_, _, _), p(p(p))).
% Logtalk directives
%
% '$lgt_lgt_directive'(+atom, +integer)
'$lgt_lgt_directive'(Functor, Arity) :-
'$lgt_lgt_opening_directive'(Functor, Arity),
!.
'$lgt_lgt_directive'(Functor, Arity) :-
'$lgt_lgt_closing_directive'(Functor, Arity),
!.
'$lgt_lgt_directive'(Functor, Arity) :-
'$lgt_lgt_entity_directive'(Functor, Arity),
!.
'$lgt_lgt_directive'(Functor, Arity) :-
'$lgt_lgt_predicate_directive'(Functor, Arity).
'$lgt_lgt_opening_directive'(object, N) :-
N >= 1, N =< 5.
'$lgt_lgt_opening_directive'(category, N) :-
N >= 1, N =< 3.
'$lgt_lgt_opening_directive'(protocol, N) :-
N =:= 1; N =:= 2.
'$lgt_lgt_closing_directive'(end_object, 0).
'$lgt_lgt_closing_directive'(end_category, 0).
'$lgt_lgt_closing_directive'(end_protocol, 0).
'$lgt_lgt_entity_directive'(calls, N) :-
N >= 1.
'$lgt_lgt_entity_directive'(uses, N) :-
N =:= 1; N =:= 2.
'$lgt_lgt_entity_directive'((initialization), 1).
'$lgt_lgt_entity_directive'((dynamic), N) :-
N =:= 0.
'$lgt_lgt_entity_directive'(op, 3).
'$lgt_lgt_entity_directive'(info, 1).
'$lgt_lgt_predicate_directive'((dynamic), N) :-
N >= 1.
'$lgt_lgt_predicate_directive'(metapredicate, N) :-
N >= 1.
'$lgt_lgt_predicate_directive'((discontiguous), N) :-
N >= 1.
'$lgt_lgt_predicate_directive'((public), N) :-
N >= 1.
'$lgt_lgt_predicate_directive'(protected, N) :-
N >= 1.
'$lgt_lgt_predicate_directive'(private, N) :-
N >= 1.
'$lgt_lgt_predicate_directive'((mode), 2).
'$lgt_lgt_predicate_directive'(info, 2).
'$lgt_lgt_predicate_directive'(alias, 3).
% built-in metapredicates
'$lgt_metapredicate'(Meta) :- % Logtalk built-in metapredicate
'$lgt_lgt_metapredicate'(Meta).
'$lgt_metapredicate'(Meta) :- % (non ISO Standard) Prolog metapredicate
'$lgt_pl_metapredicate'(Meta). % specified in the config files
% built-in Logtalk (and Prolog) metapredicates
'$lgt_lgt_metapredicate'(catch(::, *, ::)).
'$lgt_lgt_metapredicate'(bagof(*, ::, *)).
'$lgt_lgt_metapredicate'(setof(*, ::, *)).
'$lgt_lgt_metapredicate'(findall(*, ::, *)).
'$lgt_lgt_metapredicate'(forall(::, ::)).
'$lgt_lgt_metapredicate'(call(::)).
'$lgt_lgt_metapredicate'(once(::)).
'$lgt_lgt_metapredicate'(\+ (::)).
% utility predicates used during compilation of Logtalk entities to store
% and access context information which is represented by a compound term
'$lgt_context'(context(_, _, _, _, _)).
'$lgt_context'(context(Sender, This, Self, Prefix, Metavars), Sender, This, Self, Prefix, Metavars).
'$lgt_sender'(context(Sender, _, _, _, _), Sender).
'$lgt_this'(context(_, This, _, _, _), This).
'$lgt_self'(context(_, _, Self, _, _), Self).
'$lgt_prefix'(context(_, _, _, Prefix, _), Prefix).
'$lgt_metavars'(context(_, _, _, _, Metavars), Metavars).
% '$lgt_convert_to_list'(+pi_or_pi_list, -pi_list)
'$lgt_convert_to_list'([[A|B]], [A|B]) :- % predicate indicator list
!.
'$lgt_convert_to_list'([A|B], [A|B]) :- % predicate indicator sequence
!.
'$lgt_convert_to_list'(A, [A]). % single predicate indicator
% '$lgt_valid_pred_ind(@term)
'$lgt_valid_pred_ind'(Term) :-
nonvar(Term),
Term = Functor/Arity,
atom(Functor),
integer(Arity),
Arity >= 0.
% '$lgt_valid_gr_ind(@term)
'$lgt_valid_gr_ind'(Term) :-
nonvar(Term),
Term = Functor//Arity,
atom(Functor),
integer(Arity),
Arity >= 0.
% '$lgt_valid_pred_or_gr_ind(@term)
'$lgt_valid_pred_or_gr_ind'(Term) :-
nonvar(Term),
once((Term = Functor/Arity; Term = Functor//Arity)),
atom(Functor),
integer(Arity),
Arity >= 0.
% '$lgt_valid_scope'(@term)
'$lgt_valid_scope'(Term) :-
nonvar(Term),
(Term = (Scope::_) ->
nonvar(Scope),
once('$lgt_member'(Scope, [(public), protected, private]))
;
true).
% '$lgt_scope_id'(+term, -atom, -term)
'$lgt_scope_id'(Scope::Entity, Scope, Entity) :-
!.
'$lgt_scope_id'(Entity, (public), Entity).
% '$lgt_valid_op_priority'(@term)
'$lgt_valid_op_priority'(Pr) :-
integer(Pr),
Pr >= 0,
Pr =< 1200.
% '$lgt_valid_op_specifier'(@term)
'$lgt_valid_op_specifier'(Spec) :-
nonvar(Spec),
'$lgt_op_specifier'(Spec).
% '$lgt_op_specifier'(@nonvar)
'$lgt_op_specifier'(fx).
'$lgt_op_specifier'(fy).
'$lgt_op_specifier'(xfx).
'$lgt_op_specifier'(xfy).
'$lgt_op_specifier'(yfx).
'$lgt_op_specifier'(xf).
'$lgt_op_specifier'(yf).
% '$lgt_valid_op_names'(@term)
'$lgt_valid_op_names'(Ops) :-
nonvar(Ops),
'$lgt_convert_to_list'(Ops, List),
'$lgt_valid_op_names_aux'(List).
'$lgt_valid_op_names_aux'([]).
'$lgt_valid_op_names_aux'([Op| Ops]) :-
atom(Op),
'$lgt_valid_op_names_aux'(Ops).
% '$lgt_valid_metapred_term'(@term)
'$lgt_valid_metapred_term'(Pred) :-
nonvar(Pred),
Pred =.. [_| Args],
'$lgt_valid_metapred_term_args'(Args).
'$lgt_valid_metapred_term_args'([]).
'$lgt_valid_metapred_term_args'([Arg| Args]) :-
nonvar(Arg),
once((Arg = (::); Arg = (*))),
'$lgt_valid_metapred_term_args'(Args).
% '$lgt_valid_mode_term'(@term)
'$lgt_valid_mode_term'(Pred) :-
nonvar(Pred),
Pred =.. [_| Args],
'$lgt_valid_mode_term_args'(Args).
'$lgt_valid_mode_term_args'([]).
'$lgt_valid_mode_term_args'([Arg| Args]) :-
nonvar(Arg),
functor(Arg, Functor, Arity),
Arity =< 1,
'$lgt_pred_arg_instantiation_mode'(Functor),
'$lgt_valid_mode_term_args'(Args).
% '$lgt_pred_arg_instantiation_mode'(@nonvar)
'$lgt_pred_arg_instantiation_mode'(?).
'$lgt_pred_arg_instantiation_mode'(+).
'$lgt_pred_arg_instantiation_mode'(-).
'$lgt_pred_arg_instantiation_mode'(@).
% '$lgt_valid_number_of_solutions'(@term)
'$lgt_valid_number_of_solutions'(Solutions) :-
nonvar(Solutions),
'$lgt_pred_number_of_solutions'(Solutions).
% '$lgt_pred_number_of_solutions'(@nonvar)
'$lgt_pred_number_of_solutions'(zero).
'$lgt_pred_number_of_solutions'(one).
'$lgt_pred_number_of_solutions'(zero_or_one).
'$lgt_pred_number_of_solutions'(zero_or_more).
'$lgt_pred_number_of_solutions'(one_or_more).
'$lgt_pred_number_of_solutions'(error).
% '$lgt_pred_property'(@nonvar)
'$lgt_pred_property'((public)).
'$lgt_pred_property'(protected).
'$lgt_pred_property'(private).
'$lgt_pred_property'(static).
'$lgt_pred_property'((dynamic)).
'$lgt_pred_property'(declared_in(_)).
'$lgt_pred_property'(defined_in(_)).
'$lgt_pred_property'(metapredicate(_)).
'$lgt_pred_property'(built_in).
'$lgt_pred_property'(alias(_)).
% '$lgt_valid_compiler_options'(@list)
%
% true if all compiler options are valid
'$lgt_valid_compiler_options'([]).
'$lgt_valid_compiler_options'([Option| Options]) :-
nonvar(Option),
'$lgt_valid_compiler_option'(Option),
'$lgt_valid_compiler_options'(Options).
% '$lgt_valid_compiler_option'(@nonvar)
'$lgt_valid_compiler_option'(iso_initialization_dir(Option)) :-
once((Option == true; Option == false)).
'$lgt_valid_compiler_option'(xml(Option)) :-
once((Option == on; Option == off)).
'$lgt_valid_compiler_option'(xsl(File)) :-
atom(File).
'$lgt_valid_compiler_option'(unknown(Option)) :-
once((Option == silent; Option == warning)).
'$lgt_valid_compiler_option'(singletons(Option)) :-
once((Option == silent; Option == warning)).
'$lgt_valid_compiler_option'(misspelt(Option)) :-
once((Option == silent; Option == warning)).
'$lgt_valid_compiler_option'(lgtredef(Option)) :-
once((Option == silent; Option == warning)).
'$lgt_valid_compiler_option'(plredef(Option)) :-
once((Option == silent; Option == warning)).
'$lgt_valid_compiler_option'(portability(Option)) :-
once((Option == silent; Option == warning)).
'$lgt_valid_compiler_option'(report(Option)) :-
once((Option == on; Option == off)).
'$lgt_valid_compiler_option'(smart_compilation(Option)) :-
once((Option == on; Option == off)).
'$lgt_valid_compiler_option'(underscore_vars(Option)) :-
once((Option == dont_care; Option == singletons)).
'$lgt_valid_compiler_option'(code_prefix(Prefix)) :-
atom(Prefix).
'$lgt_valid_compiler_option'(doctype(Option)) :-
once((Option == standalone; Option == (local); Option == web)).
'$lgt_valid_compiler_option'(xmlspec(Option)) :-
once((Option == dtd; Option == xsd)).
'$lgt_valid_compiler_option'(debug(Option)) :-
once((Option == on; Option == off)).
'$lgt_valid_compiler_option'(events(Option)) :-
once((Option == on; Option == off)).
% '$lgt_valid_flag'(@nonvar)
%
% true if the argument is a valid Logtalk flag
'$lgt_valid_flag'(iso_initialization_dir).
'$lgt_valid_flag'(xml).
'$lgt_valid_flag'(xsl).
'$lgt_valid_flag'(xmlspec).
'$lgt_valid_flag'(doctype).
'$lgt_valid_flag'(unknown).
'$lgt_valid_flag'(singletons).
'$lgt_valid_flag'(misspelt).
'$lgt_valid_flag'(lgtredef).
'$lgt_valid_flag'(plredef).
'$lgt_valid_flag'(portability).
'$lgt_valid_flag'(report).
'$lgt_valid_flag'(smart_compilation).
'$lgt_valid_flag'(startup_message).
'$lgt_valid_flag'(version).
'$lgt_valid_flag'(underscore_vars).
'$lgt_valid_flag'(code_prefix).
'$lgt_valid_flag'(debug).
'$lgt_valid_flag'(supports_break_predicate).
'$lgt_valid_flag'(events).
'$lgt_valid_flag'(altdirs).
% '$lgt_valid_flag'(@term, @term)
%
% true if the argument is a valid Logtalk flag-value pair
'$lgt_valid_flag'(Flag, Value) :-
atom(Flag),
Option =.. [Flag, Value],
'$lgt_valid_compiler_option'(Option).
% '$lgt_read_only_flag'(@nonvar)
%
% true if the argument is a read only Logtalk flag
'$lgt_read_only_flag'(iso_initialization_dir).
'$lgt_read_only_flag'(startup_message).
'$lgt_read_only_flag'(supports_break_predicate).
'$lgt_read_only_flag'(version).
'$lgt_read_only_flag'(altdirs).
% Logtalk built-in predicates
%
% '$lgt_lgt_built_in'(?callable)
'$lgt_lgt_built_in'(::(_, _)).
'$lgt_lgt_built_in'(forall(_, _)).
'$lgt_lgt_built_in'(retractall(_)).
'$lgt_lgt_built_in'(logtalk_compile(_)).
'$lgt_lgt_built_in'(logtalk_compile(_, _)).
'$lgt_lgt_built_in'(logtalk_load(_)).
'$lgt_lgt_built_in'(logtalk_load(_, _)).
'$lgt_lgt_built_in'(protocol_property(_, _)).
'$lgt_lgt_built_in'(category_property(_, _)).
'$lgt_lgt_built_in'(object_property(_, _)).
'$lgt_lgt_built_in'(current_protocol(_)).
'$lgt_lgt_built_in'(current_category(_)).
'$lgt_lgt_built_in'(current_object(_)).
'$lgt_lgt_built_in'(create_object(_, _, _, _)).
'$lgt_lgt_built_in'(create_category(_, _, _, _)).
'$lgt_lgt_built_in'(create_protocol(_, _, _)).
'$lgt_lgt_built_in'(abolish_object(_)).
'$lgt_lgt_built_in'(abolish_category(_)).
'$lgt_lgt_built_in'(abolish_protocol(_)).
'$lgt_lgt_built_in'(implements_protocol(_, _)).
'$lgt_lgt_built_in'(implements_protocol(_, _, _)).
'$lgt_lgt_built_in'(imports_category(_, _)).
'$lgt_lgt_built_in'(imports_category(_, _, _)).
'$lgt_lgt_built_in'(instantiates_class(_, _)).
'$lgt_lgt_built_in'(instantiates_class(_, _, _)).
'$lgt_lgt_built_in'(specializes_class(_, _)).
'$lgt_lgt_built_in'(specializes_class(_, _, _)).
'$lgt_lgt_built_in'(extends_protocol(_, _)).
'$lgt_lgt_built_in'(extends_protocol(_, _, _)).
'$lgt_lgt_built_in'(extends_object(_, _)).
'$lgt_lgt_built_in'(extends_object(_, _, _)).
'$lgt_lgt_built_in'(abolish_events(_, _, _, _, _)).
'$lgt_lgt_built_in'(define_events(_, _, _, _, _)).
'$lgt_lgt_built_in'(current_event(_, _, _, _, _)).
'$lgt_lgt_built_in'(current_logtalk_flag(_, _)).
'$lgt_lgt_built_in'(set_logtalk_flag(_, _)).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% DCG rule conversion
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% '$lgt_dcgrule_to_clause'(@dcgrule, -clause)
%
% converts a DCG rule to a normal clause
'$lgt_dcgrule_to_clause'(Rule, Clause) :-
catch(
'$lgt_dcg_rule'(Rule, Clause),
Error,
throw(error(Error, dcgrule(Rule)))).
% '$lgt_dcg_rule'(@dcgrule, -clause)
%
% converts a DCG rule to a normal clause
'$lgt_dcg_rule'((RHead --> RBody), CHead) :-
RBody == [],
!,
'$lgt_dcg_head'(RHead, CHead, _, _, S, S, _).
'$lgt_dcg_rule'((RHead --> RBody), (CHead :- CBody)) :-
'$lgt_dcg_head'(RHead, CHead, Body, Body2, S0, S1, S),
'$lgt_dcg_body'(RBody, Body, S0, S1),
'$lgt_dcg_fold_unifications'(Body2, CBody, S0, S).
% '$lgt_dcg_head'(@dcghead, -head, @goal, -goal, @var, @var, @var)
%
% translates DCG rule head to a Prolog clause head
% (the last argument returns the variable representing the ouput list)
'$lgt_dcg_head'(RHead, _, _, _, _, _, _) :-
var(RHead),
throw(instantiation_error).
'$lgt_dcg_head'((_, Terminals), _, _, _, _, _, _) :-
\+ '$lgt_proper_list'(Terminals),
throw(type_error(list, Terminals)).
'$lgt_dcg_head'((RHead, Terminals), CHead, Body, (Body,Goal), S0, S1, S) :-
!,
'$lgt_dcg_goal'(RHead, CHead, S0, S),
'$lgt_dcg_terminals'(Terminals, Goal, S, S1).
'$lgt_dcg_head'(RHead, CHead, Body, Body, S0, S, S) :-
'$lgt_dcg_goal'(RHead, CHead, S0, S).
% '$lgt_dcg_body'(@dcgbody, -body, @var, @var)
%
% translates DCG rule body to a Prolog clause body
'$lgt_dcg_body'(Var, phrase(Var, S0, S), S0, S) :-
var(Var),
!.
'$lgt_dcg_body'(::RGoal, ::CGoal, S0, S) :-
!,
'$lgt_dcg_body'(RGoal, CGoal, S0, S).
'$lgt_dcg_body'(Object::RGoal, Object::CGoal, S0, S) :-
!,
'$lgt_dcg_body'(RGoal, CGoal, S0, S).
'$lgt_dcg_body'((RGoal,RGoals), (CGoal,CGoals), S0, S) :-
!,
'$lgt_dcg_body'(RGoal, CGoal, S0, S1),
'$lgt_dcg_body'(RGoals, CGoals, S1, S).
'$lgt_dcg_body'((RGoal1 -> RGoal2), (CGoal1 -> CGoal2), S0, S) :-
!,
'$lgt_dcg_body'(RGoal1, CGoal1, S0, S1),
'$lgt_dcg_body'(RGoal2, CGoal2, S1, S).
'$lgt_dcg_body'((RGoal1;RGoal2), (CGoal1;CGoal2), S0, S) :-
!,
'$lgt_dcg_body'(RGoal1, CGoal1, S0, S),
'$lgt_dcg_body'(RGoal2, CGoal2, S0, S).
'$lgt_dcg_body'({Goal}, (CGoal, S0=S), S0, S) :-
!,
(var(Goal) -> CGoal = call(Goal); CGoal = Goal).
'$lgt_dcg_body'(!, (!, S0=S), S0, S) :-
!.
'$lgt_dcg_body'(\+ RGoal, \+ CGoal, S0, S0) :-
!,
'$lgt_dcg_body'(RGoal, CGoal, S0, _).
'$lgt_dcg_body'([], (S0=S), S0, S) :-
!.
'$lgt_dcg_body'([Terminal| Terminals], CGoal, S0, S) :-
!,
'$lgt_dcg_terminals'([Terminal| Terminals], CGoal, S0, S).
'$lgt_dcg_body'(RGoal, CGoal, S0, S) :-
'$lgt_dcg_goal'(RGoal, CGoal, S0, S).
% '$lgt_dcg_goal'(@goal, -goal, @var, @var)
%
% translates DCG goal to Prolog goal
'$lgt_dcg_goal'(RGoal, _, _, _) :-
\+ callable(RGoal),
throw(type_error(callable, RGoal)).
'$lgt_dcg_goal'(RGoal, CGoal, S0, S) :-
RGoal =.. RList,
'$lgt_append'(RList, [S0, S], CList),
CGoal =.. CList.
% '$lgt_dcg_terminals'(+list, -goal, @var, @var)
%
% translate list of terminals
'$lgt_dcg_terminals'(Terminals, S0=List, S0, S) :-
'$lgt_dcg_terminals'(Terminals, S, List).
'$lgt_dcg_terminals'([], S, S) :-
!. % make predicate determinist when first argument is [Var1| Var2]
'$lgt_dcg_terminals'([Terminal| Terminals], S, [Terminal| Rest]) :-
'$lgt_dcg_terminals'(Terminals, S, Rest).
% '$lgt_dcg_fold_unifications'(+goal, -goal, @var, @var)
%
% folds redundant calls to =/2 by calling the unification
% goals except for output unifications
'$lgt_dcg_fold_unifications'((Goal1 -> Goal2), (SGoal1 -> SGoal2), S0, S) :-
!,
'$lgt_dcg_fold_unifications'(Goal1, SGoal1, S0, S),
'$lgt_dcg_fold_unifications'(Goal2, SGoal2, S0, S).
'$lgt_dcg_fold_unifications'((Goal1;Goal2), (SGoal1;SGoal2), S0, S) :-
!,
'$lgt_dcg_fold_unifications'(Goal1, SGoal1, S0, S),
'$lgt_dcg_fold_unifications'(Goal2, SGoal2, S0, S).
'$lgt_dcg_fold_unifications'((Goal1,Goal2), SGoal, S0, S) :-
!,
'$lgt_dcg_fold_unifications'(Goal1, SGoal1, S0, S),
'$lgt_dcg_fold_unifications'(Goal2, SGoal2, S0, S),
'$lgt_dcg_simplify_and'((SGoal1,SGoal2), SGoal).
'$lgt_dcg_fold_unifications'(S1=S2, S1=S2, _, S) :-
(S1 == S; S2 == S), % avoid output unifications
!.
'$lgt_dcg_fold_unifications'(S1=S2, true, _, _) :-
var(S2), % avoid unification with list of terminals
!,
S1 = S2.
'$lgt_dcg_fold_unifications'(Goal, Goal, _, _).
% '$lgt_dcg_simplify_and'(+goal, -goal)
%
% removes redundant calls to true/0 and flats conjunction of goals
'$lgt_dcg_simplify_and'((Goal1 -> Goal2), (SGoal1 -> SGoal2)) :-
!,
'$lgt_dcg_simplify_and'(Goal1, SGoal1),
'$lgt_dcg_simplify_and'(Goal2, SGoal2).
'$lgt_dcg_simplify_and'((Goal1;Goal2), (SGoal1;SGoal2)) :-
!,
'$lgt_dcg_simplify_and'(Goal1, SGoal1),
'$lgt_dcg_simplify_and'(Goal2, SGoal2).
'$lgt_dcg_simplify_and'(((Goal1,Goal2),Goal3), Body) :-
!,
'$lgt_dcg_simplify_and'((Goal1,(Goal2,Goal3)), Body).
'$lgt_dcg_simplify_and'((true,Goal), Body) :-
!,
'$lgt_dcg_simplify_and'(Goal, Body).
'$lgt_dcg_simplify_and'((Goal,true), Body) :-
!,
'$lgt_dcg_simplify_and'(Goal, Body).
'$lgt_dcg_simplify_and'((Goal1,Goal2), (Goal1,Goal3)) :-
!,
'$lgt_dcg_simplify_and'(Goal2, Goal3).
'$lgt_dcg_simplify_and'(\+ Goal, \+ SGoal) :-
!,
'$lgt_dcg_simplify_and'(Goal, SGoal).
'$lgt_dcg_simplify_and'(Goal, Goal).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% xml
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% '$lgt_write_xml_file'(+stream)
%
% writes a XML file containing the documentation of a compiled entity
'$lgt_write_xml_file'(Stream) :-
'$lgt_write_xml_header'(Stream),
'$lgt_write_xml_entity'(Stream),
'$lgt_write_xml_relations'(Stream),
'$lgt_write_xml_predicates'(Stream),
'$lgt_write_xml_footer'(Stream).
'$lgt_write_xml_header'(Stream) :-
'$lgt_compiler_option'(xmlspec, XMLSpec),
'$lgt_compiler_option'(doctype, Doctype),
'$lgt_write_xml_header'(Doctype, XMLSpec, Stream).
'$lgt_write_xml_header'(local, XMLSpec, Stream) :-
'$lgt_write_xml_open_tag'(Stream, '?xml version="1.0" standalone="no"?', []),
write(Stream, '<!DOCTYPE logtalk SYSTEM "logtalk.'),
write(Stream, XMLSpec), write(Stream, '">'), nl(Stream),
'$lgt_compiler_option'(xsl, XSL),
write(Stream, '<?xml-stylesheet type="text/xsl" href="'),
write(Stream, XSL),
write(Stream, '"?>'), nl(Stream),
'$lgt_write_xml_open_tag'(Stream, logtalk, []).
'$lgt_write_xml_header'(web, XMLSpec, Stream) :-
'$lgt_write_xml_open_tag'(Stream, '?xml version="1.0" standalone="no"?', []),
write(Stream, '<!DOCTYPE logtalk SYSTEM "http://www.logtalk.org/xml/1.2/logtalk.'),
write(Stream, XMLSpec), write(Stream, '">'), nl(Stream),
'$lgt_compiler_option'(xsl, XSL),
write(Stream, '<?xml-stylesheet type="text/xsl" href="'),
write(Stream, XSL),
write(Stream, '"?>'), nl(Stream),
'$lgt_write_xml_open_tag'(Stream, logtalk, []).
'$lgt_write_xml_header'(standalone, _, Stream) :-
'$lgt_write_xml_open_tag'(Stream, '?xml version="1.0" standalone="yes"?', []),
'$lgt_compiler_option'(xsl, XSL),
write(Stream, '<?xml-stylesheet type="text/xsl" href="'),
write(Stream, XSL),
write(Stream, '"?>'), nl(Stream),
'$lgt_write_xml_open_tag'(Stream, logtalk, []).
'$lgt_write_xml_footer'(Stream) :-
'$lgt_write_xml_close_tag'(Stream, logtalk).
'$lgt_write_xml_entity'(Stream) :-
'$lgt_pp_entity'(Type, Entity, _, _, Compilation),
'$lgt_write_xml_open_tag'(Stream, entity, []),
'$lgt_entity_to_xml_name'(Entity, Name),
'$lgt_write_xml_cdata_element'(Stream, name, [], Name),
'$lgt_write_xml_element'(Stream, (type), [], Type),
'$lgt_write_xml_element'(Stream, compilation, [], Compilation),
('$lgt_pp_info_'(List) ->
('$lgt_member'(comment is Comment, List) ->
'$lgt_write_xml_cdata_element'(Stream, comment, [], Comment)
;
true),
('$lgt_member'(author is Author, List) ->
'$lgt_write_xml_cdata_element'(Stream, author, [], Author)
;
true),
('$lgt_member'(version is Version, List) ->
'$lgt_write_xml_element'(Stream, version, [], Version)
;
true),
('$lgt_member'(date is Date, List) ->
'$lgt_write_xml_element'(Stream, date, [], Date)
;
true),
forall(
('$lgt_member'(Key is Value, List),
\+ '$lgt_member'(Key, [comment, author, version, date, parnames])),
('$lgt_write_xml_open_tag'(Stream, info, []),
'$lgt_write_xml_element'(Stream, key, [], Key),
'$lgt_write_xml_cdata_element'(Stream, value, [], Value),
'$lgt_write_xml_close_tag'(Stream, info)))
;
true),
'$lgt_write_xml_close_tag'(Stream, entity).
% '$lgt_entity_to_xml_name'(+entity, -nonvar)
%
% instantiates the parameters in a parametric object to
% user defined names or to the atom '_'
'$lgt_entity_to_xml_name'(Entity, Name) :-
'$lgt_pp_info_'(List),
'$lgt_member'(parnames is Names, List),
!,
Entity =.. [Functor| Names],
Name =.. [Functor| Names].
'$lgt_entity_to_xml_name'(Entity, Name) :-
Entity =.. [Functor| Args],
'$lgt_vars_to_underscore'(Args, Names),
Name =.. [Functor| Names].
% '$lgt_relation_to_xml_name'(+entity, +entity, -atom)
%
% instantiates the parameters in a related entity taking
% in account the parameter sharing with the original entity
'$lgt_relation_to_xml_name'(Entity, Relation, Name) :-
'$lgt_entity_to_xml_name'(Entity, _),
Relation =.. [Functor| Args],
'$lgt_vars_to_underscore'(Args, Names),
Name =.. [Functor| Names].
% '$lgt_vars_to_underscore'(+list, -list)
%
% instantiates the variables in the input list to the atom '_'
'$lgt_vars_to_underscore'([], []).
'$lgt_vars_to_underscore'([Arg| Args], [Name| Names]) :-
(var(Arg) -> Name = '_'; Name = Arg),
'$lgt_vars_to_underscore'(Args, Names).
% '$lgt_relation_to_xml_filename'(+entity, -atom)
%
% needed to build filenames in links to parametric objects
'$lgt_relation_to_xml_filename'(Relation, File) :-
atom(Relation) ->
File = Relation
;
functor(Relation, Functor, Arity),
number_codes(Arity, Codes),
atom_codes(Atom, Codes),
atom_concat(Functor, Atom, File).
% '$lgt_write_xml_predicates'(+stream)
%
% writes the predicate documentation
'$lgt_write_xml_predicates'(Stream) :-
'$lgt_write_xml_open_tag'(Stream, predicates, []),
'$lgt_write_xml_public_predicates'(Stream),
'$lgt_write_xml_protected_predicates'(Stream),
'$lgt_write_xml_private_predicates'(Stream),
'$lgt_write_xml_close_tag'(Stream, predicates).
% '$lgt_write_xml_public_predicates'(+stream)
%
% writes the documentation of public predicates
'$lgt_write_xml_public_predicates'(Stream) :-
'$lgt_write_xml_open_tag'(Stream, (public), []),
'$lgt_pp_public_'(Functor/Arity),
('$lgt_pp_non_terminal_'(Functor, Args, Arity) ->
'$lgt_write_xml_non_terminal'(Stream, Functor, Args, Arity, (public))
;
'$lgt_write_xml_predicate'(Stream, Functor, Arity, (public))),
fail.
'$lgt_write_xml_public_predicates'(Stream) :-
'$lgt_write_xml_close_tag'(Stream, (public)).
% '$lgt_write_xml_protected_predicates'(+stream)
%
% writes the documentation protected predicates
'$lgt_write_xml_protected_predicates'(Stream) :-
'$lgt_write_xml_open_tag'(Stream, protected, []),
'$lgt_pp_protected_'(Functor/Arity),
('$lgt_pp_non_terminal_'(Functor, Args, Arity) ->
'$lgt_write_xml_non_terminal'(Stream, Functor, Args, Arity, protected)
;
'$lgt_write_xml_predicate'(Stream, Functor, Arity, protected)),
fail.
'$lgt_write_xml_protected_predicates'(Stream) :-
'$lgt_write_xml_close_tag'(Stream, protected).
% '$lgt_write_xml_private_predicates'(+stream)
%
% writes the documentation of private predicates
'$lgt_write_xml_private_predicates'(Stream) :-
'$lgt_write_xml_open_tag'(Stream, private, []),
'$lgt_pp_private_'(Functor/Arity),
('$lgt_pp_non_terminal_'(Functor, Args, Arity) ->
'$lgt_write_xml_non_terminal'(Stream, Functor, Args, Arity, private)
;
'$lgt_write_xml_predicate'(Stream, Functor, Arity, private)),
fail.
'$lgt_write_xml_private_predicates'(Stream) :-
'$lgt_write_xml_close_tag'(Stream, private).
% '$lgt_write_xml_predicate'(+stream, +atom, +integer, +term)
%
% writes the documentation of a predicate
'$lgt_write_xml_predicate'(Stream, Functor, Arity, Scope) :-
(('$lgt_pp_entity'(_, _, _, _, (dynamic)); '$lgt_pp_dynamic_'(Functor/Arity)) ->
Compilation = (dynamic)
;
Compilation = static),
'$lgt_write_xml_open_tag'(Stream, predicate, []),
'$lgt_write_xml_cdata_element'(Stream, name, [], Functor/Arity),
'$lgt_write_xml_element'(Stream, scope, [], Scope),
'$lgt_write_xml_element'(Stream, compilation, [], Compilation),
functor(Meta, Functor, Arity),
('$lgt_pp_metapredicate_'(Meta) ->
'$lgt_write_xml_cdata_element'(Stream, meta, [], Meta)
;
true),
functor(Template, Functor, Arity),
forall(
'$lgt_pp_mode_'(Template, Solutions),
('$lgt_write_xml_open_tag'(Stream, (mode), []),
'$lgt_write_xml_cdata_element'(Stream, template, [], Template),
'$lgt_write_xml_element'(Stream, solutions, [], Solutions),
'$lgt_write_xml_close_tag'(Stream, (mode)))),
(('$lgt_pp_info_'(Functor/Arity, List), '$lgt_member'(comment is Comment, List)) ->
'$lgt_write_xml_cdata_element'(Stream, comment, [], Comment)
;
true),
(('$lgt_pp_info_'(Functor/Arity, List), '$lgt_member'(argnames is Names, List)) ->
Template =.. [Functor| Names],
'$lgt_write_xml_cdata_element'(Stream, template, [], Template)
;
true),
(('$lgt_pp_info_'(Functor/Arity, List), '$lgt_member'(exceptions is Terms, List), Terms \= []) ->
'$lgt_write_xml_open_tag'(Stream, exceptions, []),
forall(
'$lgt_member'(Cond-Term, Terms),
('$lgt_write_xml_open_tag'(Stream, exception, []),
'$lgt_write_xml_cdata_element'(Stream, condition, [], Cond),
'$lgt_write_xml_cdata_element'(Stream, term, [], Term),
'$lgt_write_xml_close_tag'(Stream, exception))),
'$lgt_write_xml_close_tag'(Stream, exceptions)
;
true),
forall(
('$lgt_pp_info_'(Functor/Arity, List),
'$lgt_member'(Key is Value, List),
\+ '$lgt_member'(Key, [comment, argnames, exceptions])),
('$lgt_write_xml_open_tag'(Stream, info, []),
'$lgt_write_xml_element'(Stream, key, [], Key),
'$lgt_write_xml_cdata_element'(Stream, value, [], Value),
'$lgt_write_xml_close_tag'(Stream, info))),
'$lgt_write_xml_close_tag'(Stream, predicate).
% '$lgt_write_xml_non_terminal'(+stream, +atom, +atom, +integer, +term)
%
% writes the documentation of a grammar rule non-terminal
'$lgt_write_xml_non_terminal'(Stream, Functor, Args, Arity, Scope) :-
(('$lgt_pp_entity'(_, _, _, _, (dynamic)); '$lgt_pp_dynamic_'(Functor/Arity)) ->
Compilation = (dynamic)
;
Compilation = static),
'$lgt_write_xml_open_tag'(Stream, predicate, []),
'$lgt_write_xml_cdata_element'(Stream, name, [], Functor//Args),
'$lgt_write_xml_element'(Stream, scope, [], Scope),
'$lgt_write_xml_element'(Stream, compilation, [], Compilation),
functor(Template, Functor, Args),
forall(
'$lgt_pp_mode_'(Template, Solutions),
('$lgt_write_xml_open_tag'(Stream, (mode), []),
'$lgt_write_xml_cdata_element'(Stream, template, [], Template),
'$lgt_write_xml_element'(Stream, solutions, [], Solutions),
'$lgt_write_xml_close_tag'(Stream, (mode)))),
(('$lgt_pp_info_'(Functor//Args, List), '$lgt_member'(comment is Comment, List)) ->
'$lgt_write_xml_cdata_element'(Stream, comment, [], Comment)
;
true),
(('$lgt_pp_info_'(Functor//Args, List), '$lgt_member'(argnames is Names, List)) ->
Template =.. [Functor| Names],
'$lgt_write_xml_cdata_element'(Stream, template, [], Template)
;
true),
forall(
('$lgt_pp_info_'(Functor//Args, List),
'$lgt_member'(Key is Value, List),
\+ '$lgt_member'(Key, [comment, argnames, exceptions])),
('$lgt_write_xml_open_tag'(Stream, info, []),
'$lgt_write_xml_element'(Stream, key, [], Key),
'$lgt_write_xml_cdata_element'(Stream, value, [], Value),
'$lgt_write_xml_close_tag'(Stream, info))),
'$lgt_write_xml_close_tag'(Stream, predicate).
'$lgt_write_xml_relations'(Stream) :-
'$lgt_write_xml_open_tag'(Stream, relations, []),
fail.
'$lgt_write_xml_relations'(Stream) :-
'$lgt_pp_rclause_'('$lgt_implements_protocol_'(Entity, Ptc, Scope)),
'$lgt_write_xml_relation'(Stream, Entity, Ptc, implements, Scope),
fail.
'$lgt_write_xml_relations'(Stream) :-
'$lgt_pp_rclause_'('$lgt_imports_category_'(Entity, Ctg, Scope)),
'$lgt_write_xml_relation'(Stream, Entity, Ctg, imports, Scope),
fail.
'$lgt_write_xml_relations'(Stream) :-
'$lgt_pp_rclause_'('$lgt_extends_object_'(Entity, Parent, Scope)),
'$lgt_write_xml_relation'(Stream, Entity, Parent, extends, Scope),
fail.
'$lgt_write_xml_relations'(Stream) :-
'$lgt_pp_rclause_'('$lgt_instantiates_class_'(Entity, Class, Scope)),
'$lgt_write_xml_relation'(Stream, Entity, Class, instantiates, Scope),
fail.
'$lgt_write_xml_relations'(Stream) :-
'$lgt_pp_rclause_'('$lgt_specializes_class_'(Entity, Superclass, Scope)),
'$lgt_write_xml_relation'(Stream, Entity, Superclass, specializes, Scope),
fail.
'$lgt_write_xml_relations'(Stream) :-
'$lgt_pp_rclause_'('$lgt_extends_protocol_'(Entity, Ptc, Scope)),
'$lgt_write_xml_relation'(Stream, Entity, Ptc, extends, Scope),
fail.
'$lgt_write_xml_relations'(Stream) :-
'$lgt_pp_entity'(_, Entity, _, _, _),
'$lgt_pp_uses_'(Obj),
'$lgt_write_xml_relation'(Stream, Entity, Obj, uses),
fail.
'$lgt_write_xml_relations'(Stream) :-
'$lgt_pp_entity'(_, Entity, _, _, _),
'$lgt_pp_calls_'(Ptc),
'$lgt_write_xml_relation'(Stream, Entity, Ptc, calls),
fail.
'$lgt_write_xml_relations'(Stream) :-
'$lgt_write_xml_close_tag'(Stream, relations).
'$lgt_write_xml_relation'(Stream, Entity, Relation, Tag, Scope) :-
'$lgt_relation_to_xml_name'(Entity, Relation, Name),
'$lgt_relation_to_xml_filename'(Relation, File),
'$lgt_write_xml_open_tag'(Stream, Tag, []),
'$lgt_write_xml_cdata_element'(Stream, name, [], Name),
'$lgt_write_xml_element'(Stream, scope, [], Scope),
'$lgt_write_xml_cdata_element'(Stream, file, [], File),
'$lgt_write_xml_close_tag'(Stream, Tag).
'$lgt_write_xml_relation'(Stream, Entity, Relation, Tag) :-
'$lgt_relation_to_xml_name'(Entity, Relation, Name),
'$lgt_relation_to_xml_filename'(Relation, File),
'$lgt_write_xml_open_tag'(Stream, Tag, []),
'$lgt_write_xml_cdata_element'(Stream, name, [], Name),
'$lgt_write_xml_cdata_element'(Stream, file, [], File),
'$lgt_write_xml_close_tag'(Stream, Tag).
% '$lgt_write_xml_open_tag'(@stream, @atom, @list)
%
% writes <Tag Att1="V1" Att2="V2" ...>
'$lgt_write_xml_open_tag'(Stream, Tag, Atts) :-
write(Stream, '<'),
write(Stream, Tag),
'$lgt_write_xml_tag_attributes'(Stream, Atts),
write(Stream, '>'), nl(Stream).
% '$lgt_write_xml_element'(@stream, @atom, @list, @term)
%
% writes <Tag Att1="V1" Att2="V2" ...>Text</Tag>
'$lgt_write_xml_element'(Stream, Tag, Atts, Text) :-
write(Stream, '<'),
write(Stream, Tag),
'$lgt_write_xml_tag_attributes'(Stream, Atts),
write(Stream, '>'),
write(Stream, Text),
write(Stream, '</'),
write(Stream, Tag),
write(Stream, '>'), nl(Stream).
% '$lgt_write_xml_cdata_element'(@stream, @atom, @list, @term)
%
% writes <Tag Att1="V1" Att2="V2" ...><![CDATA[Text]]></Tag>
'$lgt_write_xml_cdata_element'(Stream, Tag, Atts, Text) :-
write(Stream, '<'),
write(Stream, Tag),
'$lgt_write_xml_tag_attributes'(Stream, Atts),
write(Stream, '><![CDATA['),
'$lgt_pretty_print_vars'(Stream, Text),
write(Stream, ']]></'),
write(Stream, Tag),
write(Stream, '>'), nl(Stream).
% '$lgt_write_xml_tag_attributes'(@stream, @list)
'$lgt_write_xml_tag_attributes'(_, []) :-
!.
'$lgt_write_xml_tag_attributes'(Stream, [Attribute-Value| Rest]) :-
write(Stream, ' '),
write(Stream, Attribute),
write(Stream, '="'),
write(Stream, Value),
write(Stream, '"'),
'$lgt_write_xml_tag_attributes'(Stream, Rest).
% '$lgt_write_xml_close_tag'(@stream, @atom)
%
% writes </Tag>
'$lgt_write_xml_close_tag'(Stream, Tag) :-
write(Stream, '</'),
write(Stream, Tag),
write(Stream, '>'),
nl(Stream).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% table of ISO specified predicates
%
% used for portability checking
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
'$lgt_iso_spec_pred'(true).
'$lgt_iso_spec_pred'(fail).
'$lgt_iso_spec_pred'(call(_)).
'$lgt_iso_spec_pred'(!).
'$lgt_iso_spec_pred'((_; _)).
'$lgt_iso_spec_pred'((_, _)).
'$lgt_iso_spec_pred'((_ -> _)).
'$lgt_iso_spec_pred'((_ -> _; _)).
'$lgt_iso_spec_pred'(catch(_, _, _)).
'$lgt_iso_spec_pred'(throw(_)).
'$lgt_iso_spec_pred'((_ = _)).
'$lgt_iso_spec_pred'((_ \= _)).
'$lgt_iso_spec_pred'(unify_with_occurs_check(_, _)).
'$lgt_iso_spec_pred'(var(_)).
'$lgt_iso_spec_pred'(nonvar(_)).
'$lgt_iso_spec_pred'(atom(_)).
'$lgt_iso_spec_pred'(atomic(_)).
'$lgt_iso_spec_pred'(number(_)).
'$lgt_iso_spec_pred'(integer(_)).
'$lgt_iso_spec_pred'(float(_)).
'$lgt_iso_spec_pred'(compound(_)).
'$lgt_iso_spec_pred'((_ @=< _)).
'$lgt_iso_spec_pred'((_ @< _)).
'$lgt_iso_spec_pred'((_ @>= _)).
'$lgt_iso_spec_pred'((_ @> _)).
'$lgt_iso_spec_pred'((_ == _)).
'$lgt_iso_spec_pred'((_ \== _)).
'$lgt_iso_spec_pred'(functor(_, _, _)).
'$lgt_iso_spec_pred'(arg(_, _, _)).
'$lgt_iso_spec_pred'(_ =.. _).
'$lgt_iso_spec_pred'(copy_term(_, _)).
'$lgt_iso_spec_pred'(_ is _).
'$lgt_iso_spec_pred'((_ =< _)).
'$lgt_iso_spec_pred'((_ < _)).
'$lgt_iso_spec_pred'((_ >= _)).
'$lgt_iso_spec_pred'((_ > _)).
'$lgt_iso_spec_pred'((_ =:= _)).
'$lgt_iso_spec_pred'((_ =\= _)).
'$lgt_iso_spec_pred'(clause(_, _)).
'$lgt_iso_spec_pred'(current_predicate(_)).
'$lgt_iso_spec_pred'(asserta(_)).
'$lgt_iso_spec_pred'(assertz(_)).
'$lgt_iso_spec_pred'(retract(_)).
'$lgt_iso_spec_pred'(abolish(_)).
'$lgt_iso_spec_pred'(findall(_, _, _)).
'$lgt_iso_spec_pred'(bagof(_, _, _)).
'$lgt_iso_spec_pred'(setof(_, _, _)).
'$lgt_iso_spec_pred'(current_input(_)).
'$lgt_iso_spec_pred'(current_output(_)).
'$lgt_iso_spec_pred'(set_input(_)).
'$lgt_iso_spec_pred'(set_output(_)).
'$lgt_iso_spec_pred'(open(_, _, _, _)).
'$lgt_iso_spec_pred'(open(_, _, _)).
'$lgt_iso_spec_pred'(close(_, _)).
'$lgt_iso_spec_pred'(close(_)).
'$lgt_iso_spec_pred'(flush_output(_)).
'$lgt_iso_spec_pred'(flush_output).
'$lgt_iso_spec_pred'(stream_property(_, _)).
'$lgt_iso_spec_pred'(at_end_of_stream).
'$lgt_iso_spec_pred'(at_end_of_stream(_)).
'$lgt_iso_spec_pred'(set_stream_position(_, _)).
'$lgt_iso_spec_pred'(get_char(_, _)).
'$lgt_iso_spec_pred'(get_char(_)).
'$lgt_iso_spec_pred'(get_code(_, _)).
'$lgt_iso_spec_pred'(get_code(_)).
'$lgt_iso_spec_pred'(peek_char(_, _)).
'$lgt_iso_spec_pred'(peek_char(_)).
'$lgt_iso_spec_pred'(peek_code(_, _)).
'$lgt_iso_spec_pred'(peek_code(_)).
'$lgt_iso_spec_pred'(put_char(_, _)).
'$lgt_iso_spec_pred'(put_char(_)).
'$lgt_iso_spec_pred'(put_code(_, _)).
'$lgt_iso_spec_pred'(put_code(_)).
'$lgt_iso_spec_pred'(nl).
'$lgt_iso_spec_pred'(nl(_)).
'$lgt_iso_spec_pred'(get_byte(_, _)).
'$lgt_iso_spec_pred'(get_byte(_)).
'$lgt_iso_spec_pred'(peek_byte(_, _)).
'$lgt_iso_spec_pred'(peek_byte(_)).
'$lgt_iso_spec_pred'(put_byte(_, _)).
'$lgt_iso_spec_pred'(put_byte(_)).
'$lgt_iso_spec_pred'(read_term(_, _, _)).
'$lgt_iso_spec_pred'(read_term(_, _)).
'$lgt_iso_spec_pred'(read(_)).
'$lgt_iso_spec_pred'(read(_, _)).
'$lgt_iso_spec_pred'(write_term(_, _, _)).
'$lgt_iso_spec_pred'(write_term(_, _)).
'$lgt_iso_spec_pred'(write(_)).
'$lgt_iso_spec_pred'(write(_, _)).
'$lgt_iso_spec_pred'(writeq(_)).
'$lgt_iso_spec_pred'(writeq(_, _)).
'$lgt_iso_spec_pred'(write_canonical(_)).
'$lgt_iso_spec_pred'(write_canonical(_, _)).
'$lgt_iso_spec_pred'(op(_, _, _)).
'$lgt_iso_spec_pred'(current_op(_, _, _)).
'$lgt_iso_spec_pred'(char_conversion(_, _)).
'$lgt_iso_spec_pred'(current_char_conversion(_, _)).
'$lgt_iso_spec_pred'(\+ _).
'$lgt_iso_spec_pred'(once(_)).
'$lgt_iso_spec_pred'(repeat).
'$lgt_iso_spec_pred'(atom_length(_, _)).
'$lgt_iso_spec_pred'(atom_concat(_, _, _)).
'$lgt_iso_spec_pred'(sub_atom(_, _, _, _, _)).
'$lgt_iso_spec_pred'(atom_chars(_, _)).
'$lgt_iso_spec_pred'(atom_codes(_, _)).
'$lgt_iso_spec_pred'(char_code(_, _)).
'$lgt_iso_spec_pred'(number_chars(_, _)).
'$lgt_iso_spec_pred'(number_codes(_, _)).
'$lgt_iso_spec_pred'(set_prolog_flag(_, _)).
'$lgt_iso_spec_pred'(current_prolog_flag(_, _)).
'$lgt_iso_spec_pred'(halt).
'$lgt_iso_spec_pred'(halt(_)).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Logtalk banner
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
'$lgt_startup_message' :-
'$lgt_default_flag'(startup_message, Flag),
'$lgt_startup_message'(Flag).
'$lgt_startup_message'(flags) :-
'$lgt_banner',
'$lgt_default_flags'.
'$lgt_startup_message'(banner) :-
'$lgt_banner'.
'$lgt_startup_message'(none).
'$lgt_banner' :-
current_logtalk_flag(version, version(Major, Minor, Patch)),
nl, write('Logtalk '), write(Major), write('.'), write(Minor), write('.'), write(Patch), nl,
write('Copyright (c) 1998-2005 Paulo Moura'), nl, nl.
'$lgt_default_flags' :-
write('Default lint compilation flags:'), nl,
'$lgt_default_flag'(unknown, Unknown),
write(' Unknown entities (unknown): '), write(Unknown), nl,
'$lgt_default_flag'(misspelt, Misspelt),
write(' Misspelt predicate calls (misspelt): '), write(Misspelt), nl,
'$lgt_default_flag'(lgtredef, Lgtredef),
write(' Logtalk built-in predicates redefinition (lgtredef): '), write(Lgtredef), nl,
'$lgt_default_flag'(plredef, Plredef),
write(' Prolog built-in predicates redefinition (plredef): '), write(Plredef), nl,
'$lgt_default_flag'(portability, Portability),
write(' Non portable calls (portability): '), write(Portability), nl,
'$lgt_default_flag'(singletons, Singletons),
write(' Singletons variables (singletons): '), write(Singletons), nl,
'$lgt_default_flag'(underscore_vars, Underscore),
write(' Underscore variables interpretation (underscore_vars): '), write(Underscore), nl,
write('Default documenting compilation flags:'), nl,
'$lgt_default_flag'(xml, XML),
write(' XML documenting files (xml): '), write(XML), nl,
'$lgt_default_flag'(xmlspec, XMLSpec),
write(' XML specification file extension (xmlspec): '), write(XMLSpec), nl,
'$lgt_default_flag'(doctype, Doctype),
write(' XML specification file location (doctype): '), write(Doctype), nl,
'$lgt_default_flag'(xsl, XSL),
write(' XSL stylesheet (xsl): '), write(XSL), nl,
write('Other default compilation flags:'), nl,
'$lgt_default_flag'(report, Report),
write(' Compilation report (report): '), write(Report), nl,
'$lgt_default_flag'(code_prefix, Code),
write(' Compiled code functors prefix (code_prefix): '), writeq(Code), nl,
'$lgt_default_flag'(debug, Debug),
write(' Compile entities in debug mode (debug): '), writeq(Debug), nl,
'$lgt_default_flag'(smart_compilation, Smart),
write(' Smart compilation (smart_compilation): '), write(Smart), nl,
'$lgt_default_flag'(events, Events),
write(' Event-driven programming support (events): '), write(Events), nl,
write('Read-only compilation flags:'), nl,
'$lgt_default_flag'(supports_break_predicate, Break),
write(' Support for break/0 predicate (supports_break_predicate): '), writeq(Break), nl,
'$lgt_default_flag'(iso_initialization_dir, ISO),
write(' ISO initialization/1 directive (iso_initialization_dir): '), write(ISO), nl,
'$lgt_default_flag'(startup_message, Startup),
write(' Startup message (startup_message): '), write(Startup), nl,
'$lgt_default_flag'(altdirs, Altdirs),
write(' Alternative directories (altdirs): '), write(Altdirs), nl, nl.
:- initialization((
'$lgt_clean_lookup_caches',
'$lgt_startup_message')).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% end!
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Reference in New Issue View Git Blame Copy Permalink