f60c97a504
git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@735 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
6024 lines
165 KiB
Prolog
6024 lines
165 KiB
Prolog
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
%
|
|
% Logtalk - Object oriented extension to Prolog
|
|
% Release 2.14.6
|
|
%
|
|
% Copyright (c) 1998-2002 Paulo Moura. All Rights Reserved.
|
|
%
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
|
|
|
|
|
|
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
%
|
|
% operators
|
|
%
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
|
|
|
|
|
|
% message sending operators
|
|
|
|
:- op(600, xfy, ::). % send to object
|
|
:- op(600, fy, ::). % send to self
|
|
|
|
:- op(600, fx, ^^). % 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_'/2). % '$lgt_current_protocol_'(Ptc, Prefix)
|
|
:- dynamic('$lgt_current_category_'/2). % '$lgt_current_category_'(Ctg, Prefix)
|
|
:- dynamic('$lgt_current_object_'/5). % '$lgt_current_object_'(Obj, Prefix, Dcl, Def, Super)
|
|
|
|
:- dynamic('$lgt_implements_protocol_'/3). % '$lgt_implements_protocol_'(ObjOrCtg, Ptc, Scope)
|
|
:- dynamic('$lgt_imports_category_'/3). % '$lgt_imports_category_'(Obj, 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)
|
|
|
|
|
|
|
|
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
%
|
|
% pre-processor directives
|
|
%
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
|
|
|
|
|
|
:- dynamic('$lgt_dcl_'/1). % '$lgt_dcl_'(Clause)
|
|
:- dynamic('$lgt_ddcl_'/1). % '$lgt_ddcl_'(Clause)
|
|
:- dynamic('$lgt_def_'/1). % '$lgt_def_'(Clause)
|
|
:- dynamic('$lgt_ddef_'/1). % '$lgt_ddef_'(Clause)
|
|
:- dynamic('$lgt_super_'/1). % '$lgt_super_'(Clause)
|
|
|
|
:- dynamic('$lgt_dynamic_'/1). % '$lgt_dynamic_'(Functor/Arity)
|
|
:- dynamic('$lgt_discontiguous_'/1). % '$lgt_discontiguous_'(Functor/Arity)
|
|
:- dynamic('$lgt_mode_'/2). % '$lgt_mode_'(Mode, Determinism)
|
|
:- dynamic('$lgt_public_'/1). % '$lgt_public_'(Functor/Arity)
|
|
:- dynamic('$lgt_protected_'/1). % '$lgt_protected_'(Functor/Arity)
|
|
:- dynamic('$lgt_private_'/1). % '$lgt_private_'(Functor/Arity)
|
|
:- dynamic('$lgt_metapredicate_'/1). % '$lgt_metapredicate_'(Pred)
|
|
|
|
:- dynamic('$lgt_object_'/9). % '$lgt_object_'(Obj, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef)
|
|
:- dynamic('$lgt_category_'/4). % '$lgt_category_'(Ctg, Prefix, Dcl, Def)
|
|
:- dynamic('$lgt_protocol_'/3). % '$lgt_protocol_'(Ptc, Prefix, Dcl)
|
|
|
|
:- dynamic('$lgt_uses_'/1). % '$lgt_uses_'(Entity)
|
|
:- dynamic('$lgt_calls_'/1). % '$lgt_calls_'(Entity)
|
|
:- dynamic('$lgt_info_'/1). % '$lgt_info_'(List)
|
|
:- dynamic('$lgt_info_'/2). % '$lgt_info_'(Functor/Arity, List)
|
|
|
|
:- dynamic('$lgt_implemented_protocol_'/4). % '$lgt_implemented_protocol_'(Ptc, Prefix, Dcl, Scope)
|
|
:- dynamic('$lgt_imported_category_'/5). % '$lgt_imported_category_'(Ctg, Prefix, Dcl, Def, Scope)
|
|
:- dynamic('$lgt_extended_object_'/10). % '$lgt_extended_object_'(Parent, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Scope)
|
|
:- dynamic('$lgt_instantiated_class_'/10). % '$lgt_instantiated_class_'(Class, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Scope)
|
|
:- dynamic('$lgt_specialized_class_'/10). % '$lgt_specialized_class_'(Superclass, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef, Scope)
|
|
:- dynamic('$lgt_extended_protocol_'/4). % '$lgt_extended_protocol_'(Ptc2, Prefix, Dcl, Scope)
|
|
|
|
:- dynamic('$lgt_entity_'/4). % '$lgt_entity_'(Type, Entity, Prefix, Dcl)
|
|
:- dynamic('$lgt_entity_functors_'/1). % '$lgt_entity_functors_'(Clause)
|
|
:- dynamic('$lgt_entity_init_'/1). % '$lgt_entity_init_'(Goal)
|
|
:- dynamic('$lgt_fentity_init_'/1). % '$lgt_fentity_init_'(Goal)
|
|
:- dynamic('$lgt_entity_comp_mode_'/1). % '$lgt_entity_comp_mode_'(Type)
|
|
|
|
:- dynamic('$lgt_redefined_built_in_'/3). % '$lgt_redefined_built_in_'(Head, Context, THead)
|
|
|
|
:- dynamic('$lgt_directive_'/1). % '$lgt_directive_'(Dir)
|
|
:- dynamic('$lgt_rclause_'/1). % '$lgt_rclause_'(Clause)
|
|
:- dynamic('$lgt_eclause_'/1). % '$lgt_eclause_'(Clause)
|
|
:- dynamic('$lgt_feclause_'/1). % '$lgt_feclause_'(Clause)
|
|
|
|
:- dynamic('$lgt_defs_pred_'/1). % '$lgt_defs_pred_'(Functor/Arity)
|
|
:- dynamic('$lgt_calls_pred_'/1). % '$lgt_calls_pred_'(Functor/Arity)
|
|
|
|
:- dynamic('$lgt_current_compiler_option_'/2). % '$lgt_current_compiler_option_'(Option, Value)
|
|
:- dynamic('$lgt_flag_'/2). % '$lgt_flag_'(Option, Value)
|
|
|
|
:- dynamic('$lgt_referenced_object_'/1). % '$lgt_referenced_object_'(Object)
|
|
:- dynamic('$lgt_referenced_protocol_'/1). % '$lgt_referenced_protocol_'(Protocol)
|
|
:- dynamic('$lgt_referenced_category_'/1). % '$lgt_referenced_category_'(Category)
|
|
|
|
|
|
|
|
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
%
|
|
% top level runtime predicate for message sending: ::/2
|
|
%
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
|
|
|
|
|
|
Obj::Pred :-
|
|
var(Obj),
|
|
throw(error(instantiation_error, Obj::Pred, user)).
|
|
|
|
Obj::Pred :-
|
|
var(Pred),
|
|
throw(error(instantiation_error, Obj::Pred, user)).
|
|
|
|
Obj::Pred :-
|
|
'$lgt_sender'(Context, user),
|
|
'$lgt_this'(Context, user),
|
|
'$lgt_self'(Context, Obj),
|
|
'$lgt_tr_msg'(Obj, Pred, Call, Context),
|
|
call(Call).
|
|
|
|
|
|
|
|
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
%
|
|
% built-in predicates
|
|
%
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
|
|
|
|
|
|
% current_object(?object_identifier)
|
|
|
|
current_object(Obj) :-
|
|
nonvar(Obj),
|
|
\+ '$lgt_valid_object_id'(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),
|
|
\+ '$lgt_valid_protocol_id'(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),
|
|
\+ '$lgt_valid_category_id'(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),
|
|
\+ '$lgt_valid_object_id'(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(Obj, Prop) :-
|
|
'$lgt_current_object_'(Obj, Prefix, _, _, _),
|
|
functor(Pred, Prefix, 7),
|
|
('$lgt_predicate_property'(Pred, (dynamic)) ->
|
|
Prop = (dynamic)
|
|
;
|
|
Prop = static).
|
|
|
|
|
|
|
|
% category_property(?category_identifier, ?category_property)
|
|
|
|
category_property(Ctg, Prop) :-
|
|
nonvar(Ctg),
|
|
\+ '$lgt_valid_category_id'(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, Prefix),
|
|
functor(Pred, Prefix, 2),
|
|
('$lgt_predicate_property'(Pred, (dynamic)) ->
|
|
Prop = (dynamic)
|
|
;
|
|
Prop = static).
|
|
|
|
|
|
|
|
% protocol_property(?protocol_identifier, ?protocol_property)
|
|
|
|
protocol_property(Ptc, Prop) :-
|
|
nonvar(Ptc),
|
|
\+ '$lgt_valid_protocol_id'(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, Prefix),
|
|
functor(Pred, Prefix, 1),
|
|
('$lgt_predicate_property'(Pred, (dynamic)) ->
|
|
Prop = (dynamic)
|
|
;
|
|
Prop = static).
|
|
|
|
|
|
|
|
% create_object(+object_identifier, +list, +list, +list)
|
|
|
|
create_object(Obj, Rels, Dirs, Clauses) :-
|
|
var(Obj),
|
|
throw(error(instantiation_error, create_object(Obj, Rels, Dirs, Clauses))).
|
|
|
|
create_object(Obj, Rels, Dirs, Clauses) :-
|
|
\+ '$lgt_valid_object_id'(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) :-
|
|
(var(Rels); \+ '$lgt_proper_list'(Rels)),
|
|
throw(error(type_error(list, Rels), create_object(Obj, Rels, Dirs, Clauses))).
|
|
|
|
create_object(Obj, Rels, Dirs, Clauses) :-
|
|
(var(Dirs); \+ '$lgt_proper_list'(Dirs)),
|
|
throw(error(type_error(list, Dirs), create_object(Obj, Rels, Dirs, Clauses))).
|
|
|
|
create_object(Obj, Rels, Dirs, Clauses) :-
|
|
(var(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_up',
|
|
'$lgt_tr_directive'(object, [Obj| Rels]),
|
|
'$lgt_tr_directives'([(dynamic)| Dirs]),
|
|
'$lgt_tr_clauses'(Clauses),
|
|
'$lgt_fix_redef_built_ins',
|
|
'$lgt_gen_object_clauses',
|
|
'$lgt_gen_object_directives',
|
|
'$lgt_assert_tr_entity',
|
|
'$lgt_report_unknown_entities',
|
|
'$lgt_clean_up'.
|
|
|
|
|
|
|
|
% create_category(+category_identifier, +list, +list, +list)
|
|
|
|
create_category(Ctg, Rels, Dirs, Clauses) :-
|
|
var(Ctg),
|
|
throw(error(instantiation_error, create_category(Ctg, Rels, Dirs, Clauses))).
|
|
|
|
create_category(Ctg, Rels, Dirs, Clauses) :-
|
|
\+ '$lgt_valid_category_id'(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) :-
|
|
(var(Rels); \+ '$lgt_proper_list'(Rels)),
|
|
throw(error(type_error(list, Rels), create_category(Ctg, Rels, Dirs, Clauses))).
|
|
|
|
create_category(Ctg, Rels, Dirs, Clauses) :-
|
|
(var(Dirs); \+ '$lgt_proper_list'(Dirs)),
|
|
throw(error(type_error(list, Dirs), create_category(Ctg, Rels, Dirs, Clauses))).
|
|
|
|
create_category(Ctg, Rels, Dirs, Clauses) :-
|
|
(var(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_up',
|
|
'$lgt_tr_directive'(category, [Ctg| Rels]),
|
|
'$lgt_tr_directives'([(dynamic)| Dirs]),
|
|
'$lgt_tr_clauses'(Clauses),
|
|
'$lgt_fix_redef_built_ins',
|
|
'$lgt_gen_category_clauses',
|
|
'$lgt_gen_category_directives',
|
|
'$lgt_assert_tr_entity',
|
|
'$lgt_report_unknown_entities',
|
|
'$lgt_clean_up'.
|
|
|
|
|
|
|
|
% create_protocol(+protocol_identifier, +list, +list)
|
|
|
|
create_protocol(Ptc, Rels, Dirs) :-
|
|
var(Ptc),
|
|
throw(error(instantiation_error, create_protocol(Ptc, Rels, Dirs))).
|
|
|
|
create_protocol(Ptc, Rels, Dirs) :-
|
|
\+ '$lgt_valid_protocol_id'(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) :-
|
|
(var(Rels); \+ '$lgt_proper_list'(Rels)),
|
|
throw(error(type_error(list, Rels), create_protocol(Ptc, Rels, Dirs))).
|
|
|
|
create_protocol(Ptc, Rels, Dirs) :-
|
|
(var(Dirs); \+ '$lgt_proper_list'(Dirs)),
|
|
throw(error(type_error(list, Dirs), create_protocol(Ptc, Rels, Dirs))).
|
|
|
|
create_protocol(Ptc, Rels, Dirs) :-
|
|
'$lgt_clean_up',
|
|
'$lgt_tr_directive'(protocol, [Ptc| Rels]),
|
|
'$lgt_tr_directives'([(dynamic)| Dirs]),
|
|
'$lgt_gen_protocol_clauses',
|
|
'$lgt_gen_protocol_directives',
|
|
'$lgt_assert_tr_entity',
|
|
'$lgt_report_unknown_entities',
|
|
'$lgt_clean_up'.
|
|
|
|
|
|
|
|
% abolish_object(@object_identifier)
|
|
|
|
abolish_object(Obj) :-
|
|
var(Obj),
|
|
throw(error(instantiation_error, abolish_object(Obj))).
|
|
|
|
abolish_object(Obj) :-
|
|
\+ '$lgt_valid_object_id'(Obj),
|
|
throw(error(type_error(object_identifier, Obj), abolish_object(Obj))).
|
|
|
|
abolish_object(Obj) :-
|
|
'$lgt_current_object_'(Obj, Prefix, _, _, _) ->
|
|
(object_property(Obj, (dynamic)) ->
|
|
'$lgt_once'(Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef),
|
|
forall(
|
|
'$lgt_call'(Def, _, _, _, _, Pred),
|
|
(functor(Pred, Functor, Arity),
|
|
abolish(Functor/Arity))),
|
|
forall(
|
|
'$lgt_call'(DDef, _, _, _, _, Pred),
|
|
(functor(Pred, Functor, Arity),
|
|
abolish(Functor/Arity))),
|
|
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, _, _))
|
|
;
|
|
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) :-
|
|
\+ '$lgt_valid_category_id'(Ctg),
|
|
throw(error(type_error(category_identifier, Ctg), abolish_category(Ctg))).
|
|
|
|
abolish_category(Ctg) :-
|
|
'$lgt_current_category_'(Ctg, Prefix) ->
|
|
(category_property(Ctg, (dynamic)) ->
|
|
'$lgt_once'(Prefix, Dcl, Def),
|
|
forall(
|
|
'$lgt_call'(Def, _, _, _, _, Pred),
|
|
(functor(Pred, Functor, Arity),
|
|
abolish(Functor/Arity))),
|
|
abolish(Dcl/4),
|
|
abolish(Dcl/5),
|
|
abolish(Def/5),
|
|
abolish(Prefix/2),
|
|
retractall('$lgt_current_category_'(Ctg, _)),
|
|
retractall('$lgt_implements_protocol_'(Ctg, _, _))
|
|
;
|
|
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) :-
|
|
\+ '$lgt_valid_protocol_id'(Ptc),
|
|
throw(error(type_error(protocol_identifier, Ptc), abolish_protocol(Ptc))).
|
|
|
|
abolish_protocol(Ptc) :-
|
|
'$lgt_current_protocol_'(Ptc, Prefix) ->
|
|
(protocol_property(Ptc, (dynamic)) ->
|
|
'$lgt_once'(Prefix, Dcl),
|
|
abolish(Dcl/4),
|
|
abolish(Dcl/5),
|
|
abolish(Prefix/1),
|
|
retractall('$lgt_current_protocol_'(Ptc, _)),
|
|
retractall('$lgt_extends_protocol_'(Ptc, _, _))
|
|
;
|
|
throw(error(permission_error(modify, static_protocol, Ptc), abolish_protocol(Ptc))))
|
|
;
|
|
throw(error(existence_error(protocol, Ptc), abolish_protocol(Ptc))).
|
|
|
|
|
|
|
|
% implements_protocol(?term, ?atom)
|
|
|
|
implements_protocol(Entity, Ptc) :-
|
|
catch(
|
|
implements_protocol(Entity, Ptc, _),
|
|
error(Error, _),
|
|
throw(error(Error, implements_protocol(Entity, Ptc)))).
|
|
|
|
|
|
|
|
% implements_protocol(?term, ?atom, ?atom)
|
|
|
|
implements_protocol(Entity, Ptc, Scope) :-
|
|
nonvar(Entity),
|
|
\+ '$lgt_valid_object_id'(Entity),
|
|
throw(error(type_error(object_identifier, Entity), implements_protocol(Entity, Ptc, Scope))).
|
|
|
|
implements_protocol(Entity, Ptc, Scope) :-
|
|
nonvar(Ptc),
|
|
\+ '$lgt_valid_protocol_id'(Ptc),
|
|
throw(error(type_error(protocol_identifier, Ptc), implements_protocol(Entity, Ptc, Scope))).
|
|
|
|
implements_protocol(Entity, Ptc, Scope) :-
|
|
nonvar(Scope),
|
|
\+ '$lgt_member'(Scope, [(public), protected, private]),
|
|
throw(error(type_error(scope, Scope), implements_protocol(Entity, Ptc, Scope))).
|
|
|
|
implements_protocol(Entity, Ptc, Scope) :-
|
|
'$lgt_implements_protocol_'(Entity, Ptc, Scope).
|
|
|
|
|
|
|
|
% imports_category(?term, ?term)
|
|
|
|
imports_category(Obj, Ctg) :-
|
|
catch(
|
|
imports_category(Obj, Ctg, _),
|
|
error(Error, _),
|
|
throw(error(Error, imports_category(Obj, Ctg)))).
|
|
|
|
|
|
|
|
% imports_category(?term, ?term, ?atom)
|
|
|
|
imports_category(Obj, Ctg, Scope) :-
|
|
nonvar(Obj),
|
|
\+ '$lgt_valid_object_id'(Obj),
|
|
throw(error(type_error(object_identifier, Obj), imports_category(Obj, Ctg, Scope))).
|
|
|
|
imports_category(Obj, Ctg, Scope) :-
|
|
nonvar(Ctg),
|
|
\+ '$lgt_valid_category_id'(Ctg),
|
|
throw(error(type_error(category_identifier, Ctg), imports_category(Obj, Ctg, Scope))).
|
|
|
|
imports_category(Obj, Ctg, Scope) :-
|
|
nonvar(Scope),
|
|
\+ '$lgt_member'(Scope, [(public), protected, private]),
|
|
throw(error(type_error(scope, Scope), imports_category(Obj, Ctg, Scope))).
|
|
|
|
imports_category(Obj, Ctg, Scope) :-
|
|
'$lgt_imports_category_'(Obj, Ctg, Scope).
|
|
|
|
|
|
|
|
% instantiates_class(?term, ?term)
|
|
|
|
instantiates_class(Obj, Class) :-
|
|
catch(
|
|
instantiates_class(Obj, Class, _),
|
|
error(Error, _),
|
|
throw(error(Error, instantiates_class(Obj, Class)))).
|
|
|
|
|
|
|
|
% instantiates_class(?term, ?term, ?atom)
|
|
|
|
instantiates_class(Obj, Class, Scope) :-
|
|
nonvar(Obj),
|
|
\+ '$lgt_valid_object_id'(Obj),
|
|
throw(error(type_error(object_identifier, Obj), instantiates_class(Obj, Class, Scope))).
|
|
|
|
instantiates_class(Obj, Class, Scope) :-
|
|
nonvar(Class),
|
|
\+ '$lgt_valid_object_id'(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(?term, ?term)
|
|
|
|
specializes_class(Class, Superclass) :-
|
|
catch(
|
|
specializes_class(Class, Superclass, _),
|
|
error(Error, _),
|
|
throw(error(Error, specializes_class(Class, Superclass)))).
|
|
|
|
|
|
|
|
% specializes_class(?term, ?term, ?atom)
|
|
|
|
specializes_class(Class, Superclass, Scope) :-
|
|
nonvar(Class),
|
|
\+ '$lgt_valid_object_id'(Class),
|
|
throw(error(type_error(object_identifier, Class), specializes_class(Class, Superclass, Scope))).
|
|
|
|
specializes_class(Class, Superclass, Scope) :-
|
|
nonvar(Superclass),
|
|
\+ '$lgt_valid_object_id'(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(?atom, ?atom)
|
|
|
|
extends_protocol(Ptc1, Ptc2) :-
|
|
catch(
|
|
extends_protocol(Ptc1, Ptc2, _),
|
|
error(Error, _),
|
|
throw(error(Error, extends_protocol(Ptc1, Ptc2)))).
|
|
|
|
|
|
|
|
% extends_protocol(?atom, ?atom, ?atom)
|
|
|
|
extends_protocol(Ptc1, Ptc2, Scope) :-
|
|
nonvar(Ptc1),
|
|
\+ '$lgt_valid_protocol_id'(Ptc1),
|
|
throw(error(type_error(protocol_identifier, Ptc1), extends_protocol(Ptc1, Ptc2, Scope))).
|
|
|
|
extends_protocol(Ptc1, Ptc2, Scope) :-
|
|
nonvar(Ptc2),
|
|
\+ '$lgt_valid_protocol_id'(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(?term, ?term)
|
|
|
|
extends_object(Prototype, Parent) :-
|
|
catch(
|
|
extends_object(Prototype, Parent, _),
|
|
error(Error, _),
|
|
throw(error(Error, extends_object(Prototype, Parent)))).
|
|
|
|
|
|
|
|
% extends_object(?term, ?term, ?atom)
|
|
|
|
extends_object(Prototype, Parent, Scope) :-
|
|
nonvar(Prototype),
|
|
\+ '$lgt_valid_object_id'(Prototype),
|
|
throw(error(type_error(object_identifier, Prototype), extends_object(Prototype, Parent, Scope))).
|
|
|
|
extends_object(Prototype, Parent, Scope) :-
|
|
nonvar(Parent),
|
|
\+ '$lgt_valid_object_id'(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),
|
|
\+ '$lgt_valid_object_id'(Obj),
|
|
throw(error(type_error(object_identifier, Obj), current_event(Event, Obj, Msg, Sender, Monitor))).
|
|
|
|
current_event(Event, Obj, Msg, Sender, Monitor) :-
|
|
nonvar(Msg),
|
|
\+ '$lgt_callable'(Msg),
|
|
throw(error(type_error(callable, Msg), current_event(Event, Obj, Msg, Sender, Monitor))).
|
|
|
|
current_event(Event, Obj, Msg, Sender, Monitor) :-
|
|
nonvar(Sender),
|
|
\+ '$lgt_valid_object_id'(Sender),
|
|
throw(error(type_error(object_identifier, Sender), current_event(Event, Obj, Msg, Sender, Monitor))).
|
|
|
|
current_event(Event, Obj, Msg, Sender, Monitor) :-
|
|
nonvar(Monitor),
|
|
\+ '$lgt_valid_object_id'(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),
|
|
\+ '$lgt_valid_object_id'(Obj),
|
|
throw(error(type_error(object_identifier, Obj), define_events(Event, Obj, Msg, Sender, Monitor))).
|
|
|
|
define_events(Event, Obj, Msg, Sender, Monitor) :-
|
|
nonvar(Msg),
|
|
\+ '$lgt_callable'(Msg),
|
|
throw(error(type_error(callable, Msg), define_events(Event, Obj, Msg, Sender, Monitor))).
|
|
|
|
define_events(Event, Obj, Msg, Sender, Monitor) :-
|
|
nonvar(Sender),
|
|
\+ '$lgt_valid_object_id'(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),
|
|
\+ '$lgt_valid_object_id'(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),
|
|
\+ '$lgt_valid_object_id'(Obj),
|
|
throw(error(type_error(object_identifier, Obj), abolish_events(Event, Obj, Msg, Sender, Monitor))).
|
|
|
|
abolish_events(Event, Obj, Msg, Sender, Monitor) :-
|
|
nonvar(Msg),
|
|
\+ '$lgt_callable'(Msg),
|
|
throw(error(type_error(callable, Msg), abolish_events(Event, Obj, Msg, Sender, Monitor))).
|
|
|
|
abolish_events(Event, Obj, Msg, Sender, Monitor) :-
|
|
nonvar(Sender),
|
|
\+ '$lgt_valid_object_id'(Sender),
|
|
throw(error(type_error(object_identifier, Sender), abolish_events(Event, Obj, Msg, Sender, Monitor))).
|
|
|
|
abolish_events(Event, Obj, Msg, Sender, Monitor) :-
|
|
nonvar(Monitor),
|
|
\+ '$lgt_valid_object_id'(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_current_compiler_option_'(Option, Value2),
|
|
!,
|
|
Value = Value2.
|
|
|
|
'$lgt_compiler_option'(Option, Value) :-
|
|
'$lgt_flag_'(Option, Value2),
|
|
!,
|
|
Value = Value2.
|
|
|
|
'$lgt_compiler_option'(Option, Value) :-
|
|
'$lgt_default_flag'(Option, Value).
|
|
|
|
|
|
|
|
% logtalk_compile(+list)
|
|
%
|
|
% compiles to disk a list of entities using default options
|
|
|
|
logtalk_compile(Entities) :-
|
|
catch(
|
|
logtalk_compile(Entities, []),
|
|
error(Error, _),
|
|
throw(error(Error, logtalk_compile(Entities)))).
|
|
|
|
|
|
|
|
% logtalk_compile(+list, +list)
|
|
%
|
|
% compiles to disk a list of entities using a list of 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)),
|
|
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(list, 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) :-
|
|
\+ atom(Entity),
|
|
throw(type_error(atom, Entity)).
|
|
|
|
'$lgt_check_compiler_entity'(Entity) :-
|
|
'$lgt_file_name'(logtalk, Entity, File),
|
|
\+ '$lgt_file_exists'(File),
|
|
throw(existence_error(entity, Entity)).
|
|
|
|
'$lgt_check_compiler_entity'(_).
|
|
|
|
|
|
|
|
% '$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_current_compiler_option_'(_, _)),
|
|
'$lgt_assert_compiler_options'(Options).
|
|
|
|
|
|
'$lgt_assert_compiler_options'([]).
|
|
|
|
'$lgt_assert_compiler_options'([Option| Options]) :-
|
|
Option =.. [Key, Value],
|
|
asserta('$lgt_current_compiler_option_'(Key, Value)),
|
|
'$lgt_assert_compiler_options'(Options).
|
|
|
|
|
|
|
|
% logtalk_load(+list)
|
|
%
|
|
% compiles to disk and then loads to memory a
|
|
% list of entities using default options
|
|
|
|
logtalk_load(Entities) :-
|
|
catch(
|
|
logtalk_load(Entities, []),
|
|
error(Error, _),
|
|
throw(error(Error, logtalk_load(Entities)))).
|
|
|
|
|
|
|
|
% logtalk_load(+list, +list)
|
|
%
|
|
% compiles to disk and then loads to memory a
|
|
% list of entities using a list of 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)),
|
|
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(Flag, Value) :-
|
|
retractall('$lgt_flag_'(Flag, _)),
|
|
assertz('$lgt_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_flag_'(Flag, Value).
|
|
|
|
current_logtalk_flag(Flag, Value) :-
|
|
\+ '$lgt_flag_'(Flag, _),
|
|
'$lgt_default_flag'(Flag, Value).
|
|
|
|
current_logtalk_flag(version, version(2, 14, 6)).
|
|
|
|
|
|
|
|
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
%
|
|
% 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, _, _, SContainer, _),
|
|
once((\+ \+ PScope = Scope; Sender = SContainer)).
|
|
|
|
'$lgt_current_predicate'(Obj, Functor/Arity, Sender, Scope) :-
|
|
'$lgt_current_object_'(Obj, _, Dcl, _, _),
|
|
findall(
|
|
Functor/Arity-(PScope, SContainer),
|
|
('$lgt_call'(Dcl, Pred, PScope, _, _, SContainer, _),
|
|
functor(Pred, Functor, Arity)),
|
|
Preds),
|
|
'$lgt_cp_filter'(Preds, Filtered),
|
|
'$lgt_member'(Functor/Arity-(PScope, SContainer), Filtered),
|
|
once((\+ \+ PScope = Scope; Sender = SContainer)).
|
|
|
|
|
|
% '$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_member'(Prop, [(public), protected, private, static, (dynamic), declared_in(_), defined_in(_), metapredicate(_), built_in]),
|
|
throw(error(domain_error(predicate_property, Prop), Obj::predicate_property(Pred, Prop), Sender)).
|
|
|
|
'$lgt_predicate_property'(Obj, Pred, Prop, Sender, _) :-
|
|
\+ '$lgt_callable'(Pred),
|
|
throw(error(type_error(callable, Pred), Obj::predicate_property(Pred, Prop), Sender)).
|
|
|
|
'$lgt_predicate_property'(Obj, Pred, Prop, Sender, _) :-
|
|
\+ '$lgt_current_object_'(Obj, _, _, _, _),
|
|
throw(error(existence_error(object, Obj), Obj::predicate_property(Pred, Prop), Sender)).
|
|
|
|
'$lgt_predicate_property'(Obj, Pred, Prop, Sender, Scope) :-
|
|
'$lgt_current_object_'(Obj, _, Dcl, Def, _),
|
|
'$lgt_once'(Dcl, Pred, PScope, Type, Meta, SContainer, TContainer),
|
|
!,
|
|
once((\+ \+ PScope = Scope; Sender = SContainer)),
|
|
('$lgt_scope'(Prop, PScope);
|
|
Prop = Type;
|
|
Prop = declared_in(TContainer);
|
|
'$lgt_once'(Def, Pred, _, _, _, _, DContainer),
|
|
Prop = defined_in(DContainer);
|
|
Meta \= no,
|
|
Prop = metapredicate(Meta)).
|
|
|
|
'$lgt_predicate_property'(_, Pred, Prop, _, Scope) :-
|
|
'$lgt_built_in_method'(Pred, PScope),
|
|
!,
|
|
\+ \+ PScope = Scope,
|
|
('$lgt_scope'(Prop, PScope);
|
|
Prop = static;
|
|
Prop = built_in).
|
|
|
|
'$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_pl_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))).
|
|
|
|
|
|
|
|
% 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_once'(Dcl, Pred, PScope, Compilation, _, SContainer, _)) ->
|
|
((\+ \+ PScope = Scope; Sender = SContainer) ->
|
|
(Compilation = (dynamic) ->
|
|
'$lgt_once'(Prefix, _, _, _, _, _, DDcl, DDef),
|
|
('$lgt_once'(DDcl, Pred, _) ->
|
|
Clause =.. [DDcl, Pred, _],
|
|
retractall(Clause),
|
|
('$lgt_once'(DDef, Pred, _, _, _, Call) ->
|
|
functor(Call, CFunctor, CArity),
|
|
abolish(CFunctor/CArity),
|
|
Clause2 =.. [DDef, Pred, _, _, _, Call],
|
|
retractall(Clause2)
|
|
;
|
|
true)
|
|
;
|
|
('$lgt_once'(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, (Head:-Body), Sender, _) :-
|
|
var(Head),
|
|
throw(error(instantiation_error, Obj::asserta((Head:-Body)), Sender)).
|
|
|
|
'$lgt_asserta'(Obj, (Head:-Body), Sender, _) :-
|
|
\+ '$lgt_callable'(Head),
|
|
throw(error(type_error(callable, Head), Obj::asserta((Head:-Body)), Sender)).
|
|
|
|
'$lgt_asserta'(Obj, (Head:-Body), Sender, _) :-
|
|
\+ '$lgt_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_once'(Prefix, Dcl, Def, _, _, _, DDcl, DDef),
|
|
('$lgt_once'(Dcl, Head, PScope, Type, Meta, SContainer, _) ->
|
|
true
|
|
;
|
|
'$lgt_convert_test_scope'(Scope, Scope2),
|
|
'$lgt_assert_ddcl_clause'(DDcl, Head, Scope2)),
|
|
(Type = (dynamic) ->
|
|
((\+ \+ PScope = Scope; Sender = SContainer) ->
|
|
(('$lgt_once'(Def, Head, Sender2, This, Self, Call); '$lgt_once'(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_self'(Context, Self),
|
|
'$lgt_this'(Context, This),
|
|
'$lgt_sender'(Context, Sender2),
|
|
'$lgt_prefix'(Context, Prefix),
|
|
(nonvar(Meta) ->
|
|
Head =.. [_| Args],
|
|
Meta =.. [_| MArgs],
|
|
'$lgt_extract_metavars'(Args, MArgs, Metavars)
|
|
;
|
|
Metavars = []),
|
|
'$lgt_metavars'(Context, Metavars),
|
|
asserta((Call:-'$lgt_tr_body'(Body, TBody, Context), call(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_once'(Prefix, Dcl, Def, _, _, _, DDcl, DDef),
|
|
('$lgt_once'(Dcl, Head, PScope, Type, _, SContainer, _) ->
|
|
true
|
|
;
|
|
'$lgt_convert_test_scope'(Scope, Scope2),
|
|
'$lgt_assert_ddcl_clause'(DDcl, Head, Scope2)),
|
|
(Type = (dynamic) ->
|
|
((\+ \+ PScope = Scope; Sender = SContainer) ->
|
|
(('$lgt_once'(Def, Head, _, _, _, Call); '$lgt_once'(DDef, Head, _, _, _, Call)) ->
|
|
true
|
|
;
|
|
functor(Head, Functor, Arity),
|
|
'$lgt_assert_ddef_clause'(Functor, Arity, Prefix, DDef, _),
|
|
'$lgt_once'(DDef, Head, _, _, _, Call)),
|
|
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, (Head:-Body), Sender, _) :-
|
|
var(Head),
|
|
throw(error(instantiation_error, Obj::assertz((Head:-Body)), Sender)).
|
|
|
|
'$lgt_assertz'(Obj, (Head:-Body), Sender, _) :-
|
|
\+ '$lgt_callable'(Head),
|
|
throw(error(type_error(callable, Head), Obj::assertz((Head:-Body)), Sender)).
|
|
|
|
'$lgt_assertz'(Obj, (Head:-Body), Sender, _) :-
|
|
\+ '$lgt_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_once'(Prefix, Dcl, Def, _, _, _, DDcl, DDef),
|
|
('$lgt_once'(Dcl, Head, PScope, Type, Meta, SContainer, _) ->
|
|
true
|
|
;
|
|
'$lgt_convert_test_scope'(Scope, Scope2),
|
|
'$lgt_assert_ddcl_clause'(DDcl, Head, Scope2)),
|
|
(Type = (dynamic) ->
|
|
((\+ \+ PScope = Scope; Sender = SContainer) ->
|
|
(('$lgt_once'(Def, Head, Sender2, This, Self, Call); '$lgt_once'(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_self'(Context, Self),
|
|
'$lgt_this'(Context, This),
|
|
'$lgt_sender'(Context, Sender2),
|
|
'$lgt_prefix'(Context, Prefix),
|
|
(nonvar(Meta) ->
|
|
Head =.. [_| Args],
|
|
Meta =.. [_| MArgs],
|
|
'$lgt_extract_metavars'(Args, MArgs, Metavars)
|
|
;
|
|
Metavars = []),
|
|
'$lgt_metavars'(Context, Metavars),
|
|
assertz((Call:-'$lgt_tr_body'(Body, TBody, Context), call(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_once'(Prefix, Dcl, Def, _, _, _, DDcl, DDef),
|
|
('$lgt_once'(Dcl, Head, PScope, Type, _, SContainer, _) ->
|
|
true
|
|
;
|
|
'$lgt_convert_test_scope'(Scope, Scope2),
|
|
'$lgt_assert_ddcl_clause'(DDcl, Head, Scope2)),
|
|
(Type = (dynamic) ->
|
|
((\+ \+ PScope = Scope; Sender = SContainer) ->
|
|
(('$lgt_once'(Def, Head, _, _, _, Call); '$lgt_once'(DDef, Head, _, _, _, Call)) ->
|
|
true
|
|
;
|
|
functor(Head, Functor, Arity),
|
|
'$lgt_assert_ddef_clause'(Functor, Arity, Prefix, DDef, _),
|
|
'$lgt_once'(DDef, Head, _, _, _, Call)),
|
|
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, _) :-
|
|
\+ '$lgt_callable'(Head),
|
|
throw(error(type_error(callable, Head), Obj::clause(Head, Body), Sender)).
|
|
|
|
'$lgt_clause'(Obj, Head, Body, Sender, _) :-
|
|
nonvar(Body),
|
|
\+ '$lgt_callable'(Body),
|
|
throw(error(type_error(callable, Body), Obj::clause(Head, Body), Sender)).
|
|
|
|
'$lgt_clause'(Obj, Head, Body, Sender, _) :-
|
|
\+ '$lgt_current_object_'(Obj, _, _, _, _),
|
|
throw(error(existence_error(object, Obj), Obj::clause(Head, Body), Sender)).
|
|
|
|
'$lgt_clause'(Obj, Head, Body, Sender, Scope) :-
|
|
'$lgt_current_object_'(Obj, Prefix, _, _, _),
|
|
'$lgt_once'(Prefix, Dcl, Def, _, _, _, _, DDef),
|
|
('$lgt_once'(Dcl, Head, PScope, Type, _, SContainer, _) ->
|
|
(Type = (dynamic) ->
|
|
((\+ \+ PScope = Scope; Sender = SContainer) ->
|
|
once(('$lgt_once'(Def, Head, _, _, _, Call); '$lgt_once'(DDef, Head, _, _, _, Call))),
|
|
clause(Call, TBody),
|
|
(TBody = ('$lgt_tr_body'(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)))
|
|
;
|
|
throw(error(existence_error(predicate_declaration, Head), 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, _) :-
|
|
\+ '$lgt_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_once'(Prefix, Dcl, Def, _, _, _, _, DDef),
|
|
('$lgt_once'(Dcl, Head, PScope, Type, _, SContainer, _) ->
|
|
(Type = (dynamic) ->
|
|
((\+ \+ PScope = Scope; Sender = SContainer) ->
|
|
('$lgt_once'(Def, Head, _, _, _, Call) ->
|
|
retract((Call:-('$lgt_tr_body'(Body, _, _), _)))
|
|
;
|
|
('$lgt_once'(DDef, Head, _, _, _, Call) ->
|
|
retract((Call:-('$lgt_tr_body'(Body, _, _), _))),
|
|
'$lgt_update_ddef_table'(DDef, 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)))
|
|
;
|
|
throw(error(existence_error(predicate_declaration, Head), Obj::retract((Head:-Body)), Sender))).
|
|
|
|
'$lgt_retract'(Obj, Head, Sender, Scope) :-
|
|
'$lgt_current_object_'(Obj, Prefix, _, _, _),
|
|
'$lgt_once'(Prefix, Dcl, Def, _, _, _, _, DDef),
|
|
('$lgt_once'(Dcl, Head, PScope, Type, _, SContainer, _) ->
|
|
(Type = (dynamic) ->
|
|
((\+ \+ PScope = Scope; Sender = SContainer) ->
|
|
('$lgt_once'(Def, Head, _, _, _, Call) ->
|
|
retract(Call)
|
|
;
|
|
('$lgt_once'(DDef, Head, _, _, _, Call) ->
|
|
retract(Call),
|
|
'$lgt_update_ddef_table'(DDef, 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)))
|
|
;
|
|
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, _) :-
|
|
\+ '$lgt_callable'(Head),
|
|
throw(error(type_error(callable, Head), Obj::retractall(Head), Sender)).
|
|
|
|
'$lgt_retractall'(Obj, Head, Sender, _) :-
|
|
\+ '$lgt_current_object_'(Obj, _, _, _, _),
|
|
throw(error(existence_error(object, Obj), Obj::retractall(Head), Sender)).
|
|
|
|
'$lgt_retractall'(Obj, Head, Sender, Scope) :-
|
|
'$lgt_current_object_'(Obj, Prefix, _, _, _),
|
|
'$lgt_once'(Prefix, Dcl, Def, _, _, _, _, DDef),
|
|
('$lgt_once'(Dcl, Head, PScope, Type, _, SContainer, _) ->
|
|
(Type = (dynamic) ->
|
|
((\+ \+ PScope = Scope; Sender = SContainer) ->
|
|
('$lgt_once'(Def, Head, _, _, _, Call) ->
|
|
retractall(Call)
|
|
;
|
|
('$lgt_once'(DDef, Head, _, _, _, Call) ->
|
|
retractall(Call),
|
|
'$lgt_update_ddef_table'(DDef, 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)))
|
|
;
|
|
throw(error(existence_error(predicate_declaration, Head), Obj::retractall(Head), Sender))).
|
|
|
|
|
|
|
|
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
%
|
|
% message sending
|
|
%
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
|
|
|
|
|
|
% '$lgt_send_to_self'(+object, ?term, +object)
|
|
|
|
'$lgt_send_to_self'(Self, Pred, This) :-
|
|
nonvar(Pred) ->
|
|
'$lgt_send_to_self_nv'(Self, Pred, This)
|
|
;
|
|
throw(error(instantiation_error, Self::Pred, This)).
|
|
|
|
|
|
|
|
% '$lgt_send_to_self_nv'(+object, +term, +object)
|
|
|
|
'$lgt_send_to_self_nv'(Self, Pred, This) :-
|
|
'$lgt_current_object_'(Self, _, Dcl, Def, _),
|
|
('$lgt_call'(Dcl, Pred, Scope, _, _, SContainer, _) ->
|
|
((Scope = p(_); This = SContainer) ->
|
|
'$lgt_once'(Def, Pred, This, Self, Self, Call, _),
|
|
call(Call)
|
|
;
|
|
throw(error(permission_error(access, private_predicate, Pred), Self::Pred, This)))
|
|
;
|
|
('$lgt_built_in'(Pred) ->
|
|
call(Pred)
|
|
;
|
|
throw(error(existence_error(predicate_declaration, Pred), Self::Pred, This)))).
|
|
|
|
|
|
|
|
% '$lgt_send_to_object'(@object, ?term, +object)
|
|
|
|
'$lgt_send_to_object'(Obj, Pred, Sender) :-
|
|
nonvar(Obj) ->
|
|
('$lgt_current_object_'(Obj, _, Dcl, Def, _) ->
|
|
(nonvar(Pred) ->
|
|
('$lgt_call'(Dcl, Pred, Scope, _, _, _, _) ->
|
|
(Scope = p(p(_)) ->
|
|
'$lgt_once'(Def, Pred, Sender, Obj, Obj, Call, _),
|
|
\+ ('$lgt_before_'(Obj, Pred, Sender, _, BCall), \+ call(BCall)),
|
|
call(Call),
|
|
\+ ('$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(instantiation_error, Obj::Pred, Sender)))
|
|
;
|
|
throw(error(existence_error(object, Obj), 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_current_object_'(Obj, _, Dcl, Def, _) ->
|
|
('$lgt_call'(Dcl, Pred, Scope, _, _, _, _) ->
|
|
(Scope = p(p(_)) ->
|
|
'$lgt_once'(Def, Pred, Sender, Obj, Obj, Call, _),
|
|
\+ ('$lgt_before_'(Obj, Pred, Sender, _, BCall), \+ call(BCall)),
|
|
call(Call),
|
|
\+ ('$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_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_current_object_'(Self, _, Dcl, _, _),
|
|
('$lgt_call'(Dcl, Pred, Scope, _, _, SContainer, _) ->
|
|
((Scope = p(_); This = SContainer) ->
|
|
'$lgt_current_object_'(This, _, _, _, Super),
|
|
'$lgt_once'(Super, Pred, Sender, This, Self, Call, Container),
|
|
(Container \= This ->
|
|
call(Call)
|
|
;
|
|
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_prefix'(Context, Prefix),
|
|
'$lgt_sender'(Context, Sender),
|
|
'$lgt_this'(Context, Obj),
|
|
'$lgt_self'(Context, Obj),
|
|
'$lgt_tr_body'(Pred, Call, Context),
|
|
call(Call)).
|
|
|
|
|
|
|
|
% '$lgt_call_built_in'(+term, +term)
|
|
%
|
|
% needed for runtime translation of dynamic clauses
|
|
|
|
'$lgt_call_built_in'(Pred, Context) :-
|
|
'$lgt_sender'(Context, Sender),
|
|
'$lgt_this'(Context, This),
|
|
'$lgt_self'(Context, Self),
|
|
'$lgt_current_object_'(This, _, _, Def, _),
|
|
('$lgt_call'(Def, Pred, Sender, This, Self, Call) ->
|
|
call(Call)
|
|
;
|
|
call(Pred)).
|
|
|
|
|
|
|
|
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
%
|
|
% 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_current_object_'(user, user0_, user0__dcl, user0__def, _).
|
|
|
|
user0_(user0__dcl, user0__def, _, _, _, _, _).
|
|
|
|
user0__dcl(Pred, p(p(p)), no, Type) :-
|
|
nonvar(Pred),
|
|
\+ '$lgt_built_in'(Pred),
|
|
functor(Pred, Functor, Arity),
|
|
current_predicate(Functor/Arity),
|
|
('$lgt_predicate_property'(Pred, (dynamic)) ->
|
|
Type = (dynamic)
|
|
;
|
|
Type = static).
|
|
|
|
user0__dcl(Pred, p(p(p)), no, Type) :-
|
|
var(Pred),
|
|
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).
|
|
|
|
user0__dcl(Pred, p(p(p)), Type, Meta, user, user) :-
|
|
user0__dcl(Pred, p(p(p)), Type, Meta).
|
|
|
|
user0__def(Pred, _, _, _, Pred).
|
|
|
|
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).
|
|
|
|
|
|
|
|
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
%
|
|
% pre-processor - compiles Logtalk source files to Prolog
|
|
%
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
|
|
|
|
|
|
% '$lgt_load_entities'(+list)
|
|
%
|
|
% compiles to disk and then loads to memory a list of entities
|
|
|
|
'$lgt_load_entities'([]).
|
|
|
|
'$lgt_load_entities'([Entity| Entities]) :-
|
|
'$lgt_load_entity'(Entity),
|
|
'$lgt_load_entities'(Entities).
|
|
|
|
|
|
|
|
% '$lgt_load_entity'(+atom)
|
|
%
|
|
% compiles to disk and then loads to memory an entity
|
|
|
|
'$lgt_load_entity'(Entity) :-
|
|
'$lgt_compile_entity'(Entity),
|
|
('$lgt_compiler_option'(report, on) ->
|
|
'$lgt_report_redefined_entity'(Entity)
|
|
;
|
|
true),
|
|
'$lgt_file_name'(prolog, Entity, File),
|
|
'$lgt_load_prolog_code'(File),
|
|
('$lgt_compiler_option'(report, on) ->
|
|
write('<<< '), writeq(Entity), write(' loaded'), nl
|
|
;
|
|
true).
|
|
|
|
|
|
|
|
% '$lgt_report_redefined_entity'(+atom)
|
|
%
|
|
% prints a warning if an entity of the same name is already loaded
|
|
|
|
'$lgt_report_redefined_entity'(Entity) :-
|
|
'$lgt_current_object_'(Entity, _, _, _, _),
|
|
!,
|
|
write('WARNING! redefining object '), write(Entity), nl.
|
|
|
|
'$lgt_report_redefined_entity'(Entity) :- % parametric objects
|
|
atom_codes(Entity, Codes),
|
|
'$lgt_append'(Codes1, Codes2, Codes),
|
|
catch(number_codes(Arity, Codes2), _, fail),
|
|
atom_codes(Functor, Codes1),
|
|
functor(Loaded, Functor, Arity),
|
|
'$lgt_current_object_'(Loaded, _, _, _, _),
|
|
!,
|
|
write('WARNING! redefining object '), write(Entity), nl.
|
|
|
|
'$lgt_report_redefined_entity'(Entity) :-
|
|
'$lgt_current_protocol_'(Entity, _),
|
|
!,
|
|
write('WARNING! redefining protocol '), write(Entity), nl.
|
|
|
|
'$lgt_report_redefined_entity'(Entity) :-
|
|
'$lgt_current_category_'(Entity, _),
|
|
!,
|
|
write('WARNING! redefining category '), write(Entity), nl.
|
|
|
|
'$lgt_report_redefined_entity'(_).
|
|
|
|
|
|
|
|
% '$lgt_compile_entities'(+list)
|
|
%
|
|
% compiles to disk a list of entities
|
|
|
|
'$lgt_compile_entities'([]).
|
|
|
|
'$lgt_compile_entities'([Entity| Entities]) :-
|
|
'$lgt_compile_entity'(Entity),
|
|
'$lgt_compile_entities'(Entities).
|
|
|
|
|
|
|
|
% '$lgt_compile_entity'(+atom)
|
|
%
|
|
% compiles to disk an entity
|
|
|
|
'$lgt_compile_entity'(Entity) :-
|
|
'$lgt_compiler_option'(smart_compilation, on),
|
|
\+ '$lgt_needs_recompilation'(Entity),
|
|
!,
|
|
('$lgt_compiler_option'(report, on) ->
|
|
nl, write('>>> compiling '), writeq(Entity),
|
|
nl, write('>>> '), writeq(Entity), write(' is up-to-date'), nl
|
|
;
|
|
true).
|
|
|
|
'$lgt_compile_entity'(Entity) :-
|
|
('$lgt_compiler_option'(report, on) ->
|
|
nl, write('>>> compiling '), writeq(Entity), nl
|
|
;
|
|
true),
|
|
'$lgt_clean_up',
|
|
'$lgt_tr_entity'(Entity),
|
|
'$lgt_write_tr_entity'(Entity),
|
|
'$lgt_write_entity_doc'(Entity),
|
|
'$lgt_report_unknown_entities',
|
|
'$lgt_clean_up',
|
|
('$lgt_compiler_option'(report, on) ->
|
|
write('>>> '), writeq(Entity), write(' compiled'), nl
|
|
;
|
|
true).
|
|
|
|
|
|
|
|
% '$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),
|
|
'$lgt_write_clauses'(Stream),
|
|
'$lgt_write_init_call'(Stream)),
|
|
Error,
|
|
'$lgt_compiler_error_handler'(Stream, Error)),
|
|
close(Stream).
|
|
|
|
|
|
|
|
% '$lgt_write_entity_doc'(+atom)
|
|
%
|
|
% writes to disk the entity documentation in XML format
|
|
|
|
'$lgt_write_entity_doc'(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.
|
|
|
|
|
|
|
|
% '$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),
|
|
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)),
|
|
catch(
|
|
(read_term(Stream, Term, [singletons(Singletons1)]),
|
|
'$lgt_filter_named_anonymous_vars'(Singletons1, Singletons2),
|
|
'$lgt_report_singletons'(Singletons2, Term),
|
|
'$lgt_tr_file'(Stream, Term)),
|
|
Error,
|
|
'$lgt_compiler_error_handler'(Stream, Error)),
|
|
close(Stream),
|
|
'$lgt_fix_redef_built_ins',
|
|
'$lgt_find_misspelt_calls',
|
|
'$lgt_entity_'(Type, _, _, _),
|
|
'$lgt_gen_clauses'(Type),
|
|
'$lgt_gen_directives'(Type).
|
|
|
|
|
|
|
|
% '$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_named_anonymous_vars'(Singletons1, Singletons2),
|
|
'$lgt_report_singletons'(Singletons2, Next),
|
|
'$lgt_tr_file'(Stream, Next).
|
|
|
|
|
|
|
|
% '$lgt_filter_named_anonymous_vars'(+list, -list)
|
|
%
|
|
% filter named anonymous varaibles from a singletons list
|
|
% if the corresponding compiler option is enabled
|
|
|
|
'$lgt_filter_named_anonymous_vars'(List, Result) :-
|
|
'$lgt_compiler_option'(named_anonymous_vars, on) ->
|
|
'$lgt_filter_named_anonymous_vars'(List, [], Result)
|
|
;
|
|
List = Result.
|
|
|
|
|
|
'$lgt_filter_named_anonymous_vars'([], Result, Result).
|
|
|
|
'$lgt_filter_named_anonymous_vars'([Atom = Var| List], Sofar, Result) :-
|
|
sub_atom(Atom, 0, 1, _, '_') ->
|
|
'$lgt_filter_named_anonymous_vars'(List, Sofar, Result)
|
|
;
|
|
'$lgt_filter_named_anonymous_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)
|
|
%
|
|
% close the stream opened for reading the entity
|
|
% file and report the compilation error found
|
|
|
|
'$lgt_compiler_error_handler'(Stream, Error) :-
|
|
(nonvar(Stream) ->
|
|
close(Stream)
|
|
;
|
|
true),
|
|
'$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: '), write((:- Directive)), nl.
|
|
|
|
'$lgt_report_compiler_error'(error(Error, clause(Clause))) :-
|
|
!,
|
|
write('ERROR! '), writeq(Error), nl,
|
|
write(' in clause: '), write(Clause), nl.
|
|
|
|
'$lgt_report_compiler_error'(error(Error, Term)) :-
|
|
!,
|
|
write('ERROR! '), writeq(Error), nl,
|
|
write(' in: '), write(Term), nl.
|
|
|
|
'$lgt_report_compiler_error'(Error) :-
|
|
write('ERROR! '), writeq(Error), nl.
|
|
|
|
|
|
|
|
% clean up all dynamic predicates used during entity compilation
|
|
|
|
'$lgt_clean_up' :-
|
|
retractall('$lgt_object_'(_, _, _, _, _, _, _, _, _)),
|
|
retractall('$lgt_protocol_'(_, _, _)),
|
|
retractall('$lgt_category_'(_, _, _, _)),
|
|
retractall('$lgt_implemented_protocol_'(_, _, _, _)),
|
|
retractall('$lgt_imported_category_'(_, _, _, _, _)),
|
|
retractall('$lgt_extended_object_'(_, _, _, _, _, _, _, _, _, _)),
|
|
retractall('$lgt_instantiated_class_'(_, _, _, _, _, _, _, _, _, _)),
|
|
retractall('$lgt_specialized_class_'(_, _, _, _, _, _, _, _, _, _)),
|
|
retractall('$lgt_extended_protocol_'(_, _, _, _)),
|
|
retractall('$lgt_uses_'(_)),
|
|
retractall('$lgt_calls_'(_)),
|
|
retractall('$lgt_info_'(_)),
|
|
retractall('$lgt_info_'(_, _)),
|
|
retractall('$lgt_directive_'(_)),
|
|
retractall('$lgt_public_'(_)),
|
|
retractall('$lgt_protected_'(_)),
|
|
retractall('$lgt_private_'(_)),
|
|
retractall('$lgt_dynamic_'(_)),
|
|
retractall('$lgt_discontiguous_'(_)),
|
|
retractall('$lgt_mode_'(_, _)),
|
|
retractall('$lgt_metapredicate_'(_)),
|
|
retractall('$lgt_entity_functors_'(_)),
|
|
retractall('$lgt_entity_'(_, _, _, _)),
|
|
retractall('$lgt_entity_init_'(_)),
|
|
retractall('$lgt_fentity_init_'(_)),
|
|
retractall('$lgt_entity_comp_mode_'(_)),
|
|
retractall('$lgt_dcl_'(_)),
|
|
retractall('$lgt_ddcl_'(_)),
|
|
retractall('$lgt_def_'(_)),
|
|
retractall('$lgt_ddef_'(_)),
|
|
retractall('$lgt_super_'(_)),
|
|
retractall('$lgt_rclause_'(_)),
|
|
retractall('$lgt_eclause_'(_)),
|
|
retractall('$lgt_feclause_'(_)),
|
|
retractall('$lgt_redefined_built_in_'(_, _, _)),
|
|
retractall('$lgt_defs_pred_'(_)),
|
|
retractall('$lgt_calls_pred_'(_)),
|
|
retractall('$lgt_referenced_object_'(_)),
|
|
retractall('$lgt_referenced_protocol_'(_)),
|
|
retractall('$lgt_referenced_category_'(_)).
|
|
|
|
|
|
|
|
% dump all dynamic predicates used during entity compilation
|
|
% in the current ouput stream (just a debugging utility)
|
|
%
|
|
% only works on Prolog compilers implementing listing/1
|
|
|
|
'$lgt_dump_all' :-
|
|
listing('$lgt_object_'/9),
|
|
listing('$lgt_protocol_'/3),
|
|
listing('$lgt_category_'/4),
|
|
listing('$lgt_implemented_protocol_'/4),
|
|
listing('$lgt_imported_category_'/5),
|
|
listing('$lgt_extended_object_'/10),
|
|
listing('$lgt_instantiated_class_'/10),
|
|
listing('$lgt_specialized_class_'/10),
|
|
listing('$lgt_extended_protocol_'/4),
|
|
listing('$lgt_uses_'/1),
|
|
listing('$lgt_calls_'/1),
|
|
listing('$lgt_info_'/1),
|
|
listing('$lgt_info_'/2),
|
|
listing('$lgt_directive_'/1),
|
|
listing('$lgt_public_'/1),
|
|
listing('$lgt_protected_'/1),
|
|
listing('$lgt_private_'/1),
|
|
listing('$lgt_dynamic_'/1),
|
|
listing('$lgt_discontiguous_'/1),
|
|
listing('$lgt_mode_'/2),
|
|
listing('$lgt_metapredicate_'/1),
|
|
listing('$lgt_entity_functors_'/1),
|
|
listing('$lgt_entity_'/4),
|
|
listing('$lgt_entity_init_'/1),
|
|
listing('$lgt_fentity_init_'/1),
|
|
listing('$lgt_entity_comp_mode_'/1),
|
|
listing('$lgt_dcl_'/1),
|
|
listing('$lgt_ddcl_'/1),
|
|
listing('$lgt_def_'/1),
|
|
listing('$lgt_ddef_'/1),
|
|
listing('$lgt_super_'/1),
|
|
listing('$lgt_rclause_'/1),
|
|
listing('$lgt_eclause_'/1),
|
|
listing('$lgt_feclause_'/1),
|
|
listing('$lgt_redefined_built_in_'/3),
|
|
listing('$lgt_defs_pred_'/1),
|
|
listing('$lgt_calls_pred_'/1),
|
|
listing('$lgt_current_compiler_option_'/2),
|
|
listing('$lgt_flag_'/2),
|
|
listing('$lgt_referenced_object_'/1),
|
|
listing('$lgt_referenced_protocol_'/1),
|
|
listing('$lgt_referenced_category_'/1).
|
|
|
|
|
|
|
|
% '$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'((:-Dir)) :-
|
|
!,
|
|
'$lgt_tr_directive'(Dir).
|
|
|
|
'$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_entity_'(_, _, _, _), % directive occurs before opening entity directive
|
|
functor(Dir, Functor, Arity),
|
|
'$lgt_lgt_closing_directive'(Functor/Arity), % opening directive missing/missplet
|
|
throw(error(unmatched_directive, directive(Dir))).
|
|
|
|
'$lgt_tr_directive'(Dir) :-
|
|
\+ '$lgt_entity_'(_, _, _, _), % directive occurs before opening entity directive
|
|
functor(Dir, Functor, Arity),
|
|
\+ '$lgt_lgt_opening_directive'(Functor/Arity),
|
|
!,
|
|
assertz('$lgt_directive_'(Dir)).
|
|
|
|
'$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]) :-
|
|
'$lgt_valid_object_id'(Obj) ->
|
|
'$lgt_tr_object_id'(Obj),
|
|
'$lgt_tr_object_relations'(Rels, Obj)
|
|
;
|
|
throw(type_error(object_identifier, Obj)).
|
|
|
|
'$lgt_tr_directive'(end_object, []) :-
|
|
'$lgt_entity_'(object, _, _, _).
|
|
|
|
|
|
'$lgt_tr_directive'(protocol, [Ptc| Rels]) :-
|
|
'$lgt_valid_protocol_id'(Ptc) ->
|
|
'$lgt_tr_protocol_id'(Ptc),
|
|
'$lgt_tr_protocol_relations'(Rels, Ptc)
|
|
;
|
|
throw(type_error(protocol_identifier, Ptc)).
|
|
|
|
|
|
'$lgt_tr_directive'(end_protocol, []) :-
|
|
'$lgt_entity_'(protocol, _, _, _).
|
|
|
|
|
|
'$lgt_tr_directive'(category, [Ctg| Rels]) :-
|
|
'$lgt_valid_category_id'(Ctg) ->
|
|
'$lgt_tr_category_id'(Ctg),
|
|
'$lgt_tr_category_relations'(Rels, Ctg)
|
|
;
|
|
throw(type_error(category_identifier, Ctg)).
|
|
|
|
|
|
'$lgt_tr_directive'(end_category, []) :-
|
|
'$lgt_entity_'(category, _, _, _).
|
|
|
|
|
|
% dynamic entity directive
|
|
|
|
'$lgt_tr_directive'((dynamic), []) :-
|
|
assertz('$lgt_entity_comp_mode_'((dynamic))).
|
|
|
|
|
|
'$lgt_tr_directive'(initialization, [Goal]) :-
|
|
'$lgt_callable'(Goal) ->
|
|
'$lgt_entity_'(_, Entity, Prefix, _),
|
|
'$lgt_prefix'(Context, Prefix),
|
|
'$lgt_metavars'(Context, []),
|
|
'$lgt_sender'(Context, Entity),
|
|
'$lgt_this'(Context, Entity),
|
|
'$lgt_self'(Context, Entity),
|
|
'$lgt_tr_body'(Goal, TGoal, Context),
|
|
assertz('$lgt_entity_init_'(TGoal))
|
|
;
|
|
throw(type_error(callable, Goal)).
|
|
|
|
|
|
'$lgt_tr_directive'(op, [Priority, Specifier, Operators]) :-
|
|
'$lgt_valid_op_priority'(Priority) ->
|
|
('$lgt_valid_op_specifier'(Specifier) ->
|
|
('$lgt_valid_op_names'(Operators) ->
|
|
op(Priority, Specifier, Operators),
|
|
assertz('$lgt_directive_'(op(Priority, Specifier, Operators)))
|
|
;
|
|
throw(type_error(operator_name, Operators)))
|
|
;
|
|
throw(type_error(operator_specifier, Specifier)))
|
|
;
|
|
throw(type_error(operator_priority, Priority)).
|
|
|
|
|
|
'$lgt_tr_directive'(uses, Objs) :-
|
|
'$lgt_convert_to_list'(Objs, Objs2),
|
|
forall(
|
|
'$lgt_member'(Obj, Objs2),
|
|
('$lgt_valid_object_id'(Obj) ->
|
|
'$lgt_add_referenced_object'(Obj),
|
|
assertz('$lgt_uses_'(Obj))
|
|
;
|
|
throw(type_error(object_identifier, Obj)))).
|
|
|
|
|
|
'$lgt_tr_directive'(calls, Ptcs) :-
|
|
'$lgt_convert_to_list'(Ptcs, Ptcs2),
|
|
forall(
|
|
'$lgt_member'(Ptc, Ptcs2),
|
|
('$lgt_valid_protocol_id'(Ptc) ->
|
|
'$lgt_add_referenced_protocol'(Ptc),
|
|
assertz('$lgt_calls_'(Ptc))
|
|
;
|
|
throw(type_error(protocol_identifier, Ptc)))).
|
|
|
|
|
|
'$lgt_tr_directive'(info, [List]) :-
|
|
!,
|
|
('$lgt_valid_info_list'(List) ->
|
|
assertz('$lgt_info_'(List))
|
|
;
|
|
throw(type_error(info_list, List))).
|
|
|
|
|
|
'$lgt_tr_directive'(info, [Pred, List]) :-
|
|
'$lgt_valid_pred_ind'(Pred) ->
|
|
('$lgt_valid_info_list'(List) ->
|
|
assertz('$lgt_info_'(Pred, List))
|
|
;
|
|
throw(type_error(info_list, 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_public_'(Pred))
|
|
;
|
|
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_protected_'(Pred))
|
|
;
|
|
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_private_'(Pred))
|
|
;
|
|
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_dynamic_'(Pred))
|
|
;
|
|
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_discontiguous_'(Pred))
|
|
;
|
|
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_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_mode_'(Mode, Solutions))
|
|
;
|
|
throw(type_error(number_of_solutions, Solutions)))
|
|
;
|
|
throw(type_error(mode_term, Mode)).
|
|
|
|
|
|
|
|
% '$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| Arguments],
|
|
('$lgt_tr_object_relation'(Functor, Arguments, Obj) ->
|
|
'$lgt_tr_object_relations'(Clauses, Obj)
|
|
;
|
|
throw(type_error(relation_clause, 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| Arguments],
|
|
'$lgt_tr_protocol_relation'(Functor, Arguments, Obj),
|
|
'$lgt_tr_protocol_relations'(Clauses, Obj).
|
|
|
|
|
|
|
|
% '$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_protocol_relation'(Unknown, _, _) :-
|
|
throw(directive_error(relation_clause, Unknown)).
|
|
|
|
|
|
|
|
% '$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| Arguments],
|
|
'$lgt_tr_category_relation'(Functor, Arguments, Obj),
|
|
'$lgt_tr_category_relations'(Clauses, Obj).
|
|
|
|
|
|
|
|
% '$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'(Unknown, _, _) :-
|
|
throw(directive_error(relation_clause, Unknown)).
|
|
|
|
|
|
|
|
% '$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_entity_'(_, _, _, _), % clause occurs before opening entity directive
|
|
!,
|
|
assertz('$lgt_feclause_'(Clause)).
|
|
|
|
'$lgt_tr_clause'(Clause) :-
|
|
'$lgt_entity_'(Type, Entity, Prefix, _),
|
|
((Type = object, \+ atom(Entity)) -> % if the entity is a parametric object we need
|
|
'$lgt_this'(Context, Entity) % "this" for inline compilation of parameter/2
|
|
;
|
|
true),
|
|
'$lgt_prefix'(Context, Prefix),
|
|
catch(
|
|
'$lgt_tr_clause'(Clause, TClause, Context),
|
|
Error,
|
|
throw(error(Error, clause(Clause)))),
|
|
assertz('$lgt_eclause_'(TClause)),
|
|
!.
|
|
|
|
'$lgt_tr_clause'(Clause) :-
|
|
throw(error(unknown_error, clause(Clause))).
|
|
|
|
|
|
|
|
% '$lgt_tr_clause'(+clause, +clause, +term)
|
|
|
|
'$lgt_tr_clause'((Head:-_), _, _) :-
|
|
\+ '$lgt_callable'(Head),
|
|
throw(type_error(callable, Head)).
|
|
|
|
'$lgt_tr_clause'((Head:-Body), TClause, Context) :-
|
|
!,
|
|
'$lgt_extract_metavars'(Head, Metavars),
|
|
'$lgt_metavars'(Context, Metavars),
|
|
'$lgt_tr_head'(Head, THead, Context),
|
|
'$lgt_tr_body'(Body, TBody, Context),
|
|
'$lgt_simplify_clause'((THead:-TBody), TClause).
|
|
|
|
'$lgt_tr_clause'(Fact, _, _) :-
|
|
\+ '$lgt_callable'(Fact),
|
|
throw(type_error(callable, Fact)).
|
|
|
|
'$lgt_tr_clause'(Fact, TFact, Context) :-
|
|
'$lgt_tr_head'(Fact, TFact, Context).
|
|
|
|
|
|
|
|
% '$lgt_tr_head'(+callable, -callable, +term)
|
|
%
|
|
% translates an entity clause head
|
|
|
|
|
|
% definition of dynamic predicates inside categories
|
|
|
|
'$lgt_tr_head'(Head, _, _) :-
|
|
'$lgt_entity_'(category, _, _, _),
|
|
functor(Head, Functor, Arity),
|
|
'$lgt_dynamic_'(Functor/Arity),
|
|
throw(permission_error(define, dynamic_predicate, Functor/Arity)).
|
|
|
|
|
|
% redefinition of 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)).
|
|
|
|
|
|
% 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_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_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, Context) :-
|
|
functor(Head, Functor, Arity),
|
|
Head =.. [_| Args],
|
|
'$lgt_prefix'(Context, EPrefix),
|
|
'$lgt_construct_predicate_functor'(EPrefix, Functor, Arity, PPrefix),
|
|
(('$lgt_dynamic_'(Functor/Arity),
|
|
\+ '$lgt_public_'(Functor/Arity),
|
|
\+ '$lgt_protected_'(Functor/Arity),
|
|
\+ '$lgt_private_'(Functor/Arity)) ->
|
|
'$lgt_add_ddef_clause'(Functor, Arity, PPrefix, Context)
|
|
;
|
|
'$lgt_add_def_clause'(Functor, Arity, PPrefix, Context)),
|
|
'$lgt_sender'(Context, Sender),
|
|
'$lgt_this'(Context, This),
|
|
'$lgt_self'(Context, Self),
|
|
'$lgt_append'(Args, [Sender, This, Self], Args2),
|
|
THead =.. [PPrefix| Args2].
|
|
|
|
|
|
|
|
% '$lgt_tr_body'(+callable, -callable, +term)
|
|
%
|
|
% translates an entity clause body
|
|
|
|
|
|
% meta-calls
|
|
|
|
'$lgt_tr_body'(Pred, TPred, Context) :-
|
|
var(Pred),
|
|
!,
|
|
'$lgt_metavars'(Context, Metavars),
|
|
('$lgt_member_var'(Pred, Metavars) ->
|
|
'$lgt_sender'(Context, Sender),
|
|
TPred = '$lgt_metacall_in_object'(Sender, Pred, Sender)
|
|
;
|
|
'$lgt_this'(Context, This),
|
|
TPred = '$lgt_metacall_in_object'(This, Pred, This)).
|
|
|
|
|
|
% pre-processor bypass (call of external code)
|
|
|
|
'$lgt_tr_body'({Pred}, Pred, _) :-
|
|
!.
|
|
|
|
|
|
% bagof/3 and setof/3 existential quantifiers
|
|
|
|
'$lgt_tr_body'(Var^Pred, Var^TPred, Context) :-
|
|
!,
|
|
'$lgt_tr_body'(Pred, TPred, Context).
|
|
|
|
|
|
% control constructs
|
|
|
|
'$lgt_tr_body'((Pred1, Pred2), (TPred1, TPred2), Context) :-
|
|
!,
|
|
'$lgt_tr_body'(Pred1, TPred1, Context),
|
|
'$lgt_tr_body'(Pred2, TPred2, Context).
|
|
|
|
'$lgt_tr_body'((Pred1; Pred2), (TPred1; TPred2), Context) :-
|
|
!,
|
|
'$lgt_tr_body'(Pred1, TPred1, Context),
|
|
'$lgt_tr_body'(Pred2, TPred2, Context).
|
|
|
|
'$lgt_tr_body'((Pred1 -> Pred2), (TPred1 -> TPred2), Context) :-
|
|
!,
|
|
'$lgt_tr_body'(Pred1, TPred1, Context),
|
|
'$lgt_tr_body'(Pred2, TPred2, Context).
|
|
|
|
'$lgt_tr_body'(\+ Pred, \+ TPred, Context) :-
|
|
!,
|
|
'$lgt_tr_body'(Pred, TPred, Context).
|
|
|
|
'$lgt_tr_body'(!, !, _) :-
|
|
!.
|
|
|
|
'$lgt_tr_body'(true, true, _) :-
|
|
!.
|
|
|
|
'$lgt_tr_body'(fail, fail, _) :-
|
|
!.
|
|
|
|
'$lgt_tr_body'(repeat, repeat, _) :-
|
|
!.
|
|
|
|
'$lgt_tr_body'(call(Pred), TPred, Context) :-
|
|
!,
|
|
'$lgt_tr_body'(Pred, TPred, Context).
|
|
|
|
'$lgt_tr_body'(once(Pred), once(TPred), Context) :-
|
|
!,
|
|
'$lgt_tr_body'(Pred, TPred, Context).
|
|
|
|
'$lgt_tr_body'(catch(Goal, Catcher, Recovery), catch(TGoal, Catcher, TRecovery), Context) :-
|
|
!,
|
|
'$lgt_tr_body'(Goal, TGoal, Context),
|
|
'$lgt_tr_body'(Recovery, TRecovery, Context).
|
|
|
|
'$lgt_tr_body'(throw(Error), throw(Error), _) :-
|
|
!.
|
|
|
|
|
|
% built-in metapredicates
|
|
|
|
'$lgt_tr_body'(bagof(Term, Pred, List), bagof(Term, TPred, List), Context) :-
|
|
!,
|
|
'$lgt_tr_body'(Pred, TPred, Context).
|
|
|
|
'$lgt_tr_body'(findall(Term, Pred, List), findall(Term, TPred, List), Context) :-
|
|
!,
|
|
'$lgt_tr_body'(Pred, TPred, Context).
|
|
|
|
'$lgt_tr_body'(forall(Generate, Test), forall(TGenerate, TTest), Context) :-
|
|
!,
|
|
'$lgt_tr_body'(Generate, TGenerate, Context),
|
|
'$lgt_tr_body'(Test, TTest, Context).
|
|
|
|
'$lgt_tr_body'(setof(Term, Pred, List), setof(Term, TPred, List), Context) :-
|
|
!,
|
|
'$lgt_tr_body'(Pred, TPred, Context).
|
|
|
|
|
|
% message sending
|
|
|
|
'$lgt_tr_body'(Obj::Pred, TPred, Context) :-
|
|
!,
|
|
'$lgt_tr_msg'(Obj, Pred, TPred, Context).
|
|
|
|
'$lgt_tr_body'(::Pred, TPred, Context) :-
|
|
!,
|
|
'$lgt_tr_self_msg'(Pred, TPred, Context).
|
|
|
|
'$lgt_tr_body'(^^Pred, TPred, Context) :-
|
|
!,
|
|
'$lgt_tr_super_sending'(Pred, TPred, Context).
|
|
|
|
|
|
% "reflection" built-in predicates
|
|
|
|
'$lgt_tr_body'(current_predicate(Pred), '$lgt_current_predicate'(This, Pred, This, _), Context) :-
|
|
!,
|
|
'$lgt_this'(Context, This).
|
|
|
|
'$lgt_tr_body'(predicate_property(Pred, Property), '$lgt_predicate_property'(This, Pred, Property, This, _), Context) :-
|
|
!,
|
|
'$lgt_this'(Context, This).
|
|
|
|
|
|
% database handling built-in predicates
|
|
|
|
'$lgt_tr_body'(abolish(Pred), '$lgt_abolish'(This, Pred, This, _), Context) :-
|
|
!,
|
|
'$lgt_this'(Context, This).
|
|
|
|
'$lgt_tr_body'(asserta(Pred), '$lgt_asserta'(This, Pred, This, _), Context) :-
|
|
!,
|
|
'$lgt_this'(Context, This).
|
|
|
|
'$lgt_tr_body'(assertz(Pred), '$lgt_assertz'(This, Pred, This, _), Context) :-
|
|
!,
|
|
'$lgt_this'(Context, This).
|
|
|
|
'$lgt_tr_body'(clause(Head, Body), '$lgt_clause'(This, Head, Body, This, _), Context) :-
|
|
!,
|
|
'$lgt_this'(Context, This).
|
|
|
|
'$lgt_tr_body'(retract(Pred), '$lgt_retract'(This, Pred, This, _), Context) :-
|
|
!,
|
|
'$lgt_this'(Context, This).
|
|
|
|
'$lgt_tr_body'(retractall(Pred), '$lgt_retractall'(This, Pred, This, _), Context) :-
|
|
!,
|
|
'$lgt_this'(Context, This).
|
|
|
|
|
|
% inline methods (translated to a single unification with the corresponding context argument)
|
|
|
|
'$lgt_tr_body'(sender(Sender), true, Context) :-
|
|
'$lgt_sender'(Context, Sender),
|
|
!.
|
|
|
|
'$lgt_tr_body'(this(This), true, Context) :-
|
|
'$lgt_this'(Context, This),
|
|
!.
|
|
|
|
'$lgt_tr_body'(self(Self), true, Context) :-
|
|
'$lgt_self'(Context, Self),
|
|
!.
|
|
|
|
'$lgt_tr_body'(parameter(Arg, Value), true, Context) :-
|
|
'$lgt_this'(Context, This),
|
|
arg(Arg, This, Value),
|
|
!.
|
|
|
|
|
|
% Logtalk and Prolog built-in predicates
|
|
|
|
'$lgt_tr_body'(Pred, _, _) :-
|
|
'$lgt_built_in'(Pred),
|
|
\+ '$lgt_iso_def_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, '$lgt_call_built_in'(Pred, Context), Context) :-
|
|
'$lgt_built_in'(Pred),
|
|
!.
|
|
|
|
|
|
% invalid goal
|
|
|
|
'$lgt_tr_body'(Pred, _, _) :-
|
|
\+ '$lgt_callable'(Pred),
|
|
throw(type_error(callable, Pred)).
|
|
|
|
|
|
% goal is a call to a user predicate
|
|
|
|
'$lgt_tr_body'(Condition, TCondition, Context) :-
|
|
Condition =.. [Functor|Args],
|
|
functor(Condition, Functor, Arity),
|
|
'$lgt_prefix'(Context, EPrefix),
|
|
'$lgt_construct_predicate_functor'(EPrefix, Functor, Arity, PPrefix),
|
|
'$lgt_sender'(Context, Sender),
|
|
'$lgt_this'(Context, This),
|
|
'$lgt_self'(Context, Self),
|
|
'$lgt_append'(Args, [Sender, This, Self], Args2),
|
|
TCondition =.. [PPrefix|Args2],
|
|
assertz('$lgt_calls_pred_'(Functor/Arity)).
|
|
|
|
|
|
|
|
% '$lgt_tr_msg'(@object, @term, -term, +term)
|
|
%
|
|
% translates the sending of a message to an object
|
|
|
|
|
|
% message broadcasting
|
|
|
|
'$lgt_tr_msg'(Obj, Pred, TPred, Context) :-
|
|
nonvar(Obj),
|
|
(Obj = (_, _); Obj = (_; _)),
|
|
!,
|
|
'$lgt_tr_msg_broadcasting'(Obj, Pred, TPred, Context).
|
|
|
|
|
|
% invalid object identifier
|
|
|
|
'$lgt_tr_msg'(Obj, _, _, _) :-
|
|
nonvar(Obj),
|
|
\+ '$lgt_valid_object_id'(Obj),
|
|
!,
|
|
throw(type_error(object_identifier, Obj)).
|
|
|
|
|
|
% remember the object receiving the message to later check if it's known
|
|
|
|
'$lgt_tr_msg'(Obj, _, _, Context) :-
|
|
nonvar(Obj),
|
|
\+ '$lgt_sender'(Context, user), % not runtime msg translation
|
|
\+ '$lgt_this'(Context, user),
|
|
'$lgt_add_referenced_object'(Obj),
|
|
fail.
|
|
|
|
|
|
% non-instantiated message: traslation performed at runtime
|
|
|
|
'$lgt_tr_msg'(Obj, Pred, '$lgt_send_to_object'(Obj, Pred, This), Context) :-
|
|
var(Pred),
|
|
!,
|
|
'$lgt_this'(Context, This).
|
|
|
|
|
|
% control constructs
|
|
|
|
'$lgt_tr_msg'(Obj, (Pred1, Pred2), (TPred1, TPred2), Context) :-
|
|
!,
|
|
'$lgt_tr_msg'(Obj, Pred1, TPred1, Context),
|
|
'$lgt_tr_msg'(Obj, Pred2, TPred2, Context).
|
|
|
|
'$lgt_tr_msg'(Obj, (Pred1; Pred2), (TPred1; TPred2), Context) :-
|
|
!,
|
|
'$lgt_tr_msg'(Obj, Pred1, TPred1, Context),
|
|
'$lgt_tr_msg'(Obj, Pred2, TPred2, Context).
|
|
|
|
'$lgt_tr_msg'(Obj, (Pred1 -> Pred2), (TPred1 -> TPred2), Context) :-
|
|
!,
|
|
'$lgt_tr_msg'(Obj, Pred1, TPred1, Context),
|
|
'$lgt_tr_msg'(Obj, Pred2, TPred2, Context).
|
|
|
|
'$lgt_tr_msg'(Obj, \+ Pred, \+ TPred, Context) :-
|
|
!,
|
|
'$lgt_tr_msg'(Obj, Pred, TPred, Context).
|
|
|
|
'$lgt_tr_msg'(Obj, !, ('$lgt_obj_exists'(Obj, !, This), !), Context) :-
|
|
!,
|
|
'$lgt_this'(Context, This).
|
|
|
|
'$lgt_tr_msg'(Obj, true, ('$lgt_obj_exists'(Obj, true, This), true), Context) :-
|
|
!,
|
|
'$lgt_this'(Context, This).
|
|
|
|
'$lgt_tr_msg'(Obj, fail, ('$lgt_obj_exists'(Obj, fail, This), fail), Context) :-
|
|
!,
|
|
'$lgt_this'(Context, This).
|
|
|
|
'$lgt_tr_msg'(Obj, repeat, ('$lgt_obj_exists'(Obj, repeat, This), repeat), Context) :-
|
|
!,
|
|
'$lgt_this'(Context, This).
|
|
|
|
'$lgt_tr_msg'(Obj, call(Pred), TPred, Context) :-
|
|
!,
|
|
'$lgt_tr_msg'(Obj, Pred, TPred, Context).
|
|
|
|
'$lgt_tr_msg'(Obj, once(Pred), once(TPred), Context) :-
|
|
!,
|
|
'$lgt_tr_msg'(Obj, Pred, TPred, Context).
|
|
|
|
'$lgt_tr_msg'(Obj, catch(Goal, Catcher, Recovery), catch(TGoal, Catcher, TRecovery), Context) :-
|
|
!,
|
|
'$lgt_tr_msg'(Obj, Goal, TGoal, Context),
|
|
'$lgt_tr_msg'(Obj, Recovery, TRecovery, Context).
|
|
|
|
'$lgt_tr_msg'(Obj, throw(Error), ('$lgt_obj_exists'(Obj, throw(Error), This), throw(Error)), Context) :-
|
|
!,
|
|
'$lgt_this'(Context, This).
|
|
|
|
|
|
% built-in metapredicates
|
|
|
|
'$lgt_tr_msg'(Obj, bagof(Term, Pred, List), bagof(Term, TPred, List), Context) :-
|
|
!,
|
|
'$lgt_tr_msg'(Obj, Pred, TPred, Context).
|
|
|
|
'$lgt_tr_msg'(Obj, findall(Term, Pred, List), findall(Term, TPred, List), Context) :-
|
|
!,
|
|
'$lgt_tr_msg'(Obj, Pred, TPred, Context).
|
|
|
|
'$lgt_tr_msg'(Obj, forall(Generate, Test), forall(TGenerate, TTest), Context) :-
|
|
!,
|
|
'$lgt_tr_msg'(Obj, Generate, TGenerate, Context),
|
|
'$lgt_tr_msg'(Obj, Test, TTest, Context).
|
|
|
|
'$lgt_tr_msg'(Obj, setof(Term, Pred, List), setof(Term, TPred, List), Context) :-
|
|
!,
|
|
'$lgt_tr_msg'(Obj, Pred, TPred, Context).
|
|
|
|
|
|
% "reflection" built-in predicates
|
|
|
|
'$lgt_tr_msg'(Obj, current_predicate(Pred), '$lgt_current_predicate'(Obj, Pred, This, p(p(p))), Context) :-
|
|
!,
|
|
'$lgt_this'(Context, This).
|
|
|
|
'$lgt_tr_msg'(Obj, predicate_property(Pred, Property), '$lgt_predicate_property'(Obj, Pred, Property, This, p(p(p))), Context) :-
|
|
!,
|
|
'$lgt_this'(Context, This).
|
|
|
|
|
|
% database handling built-in predicates
|
|
|
|
'$lgt_tr_msg'(Obj, abolish(Pred), '$lgt_abolish'(Obj, Pred, This, p(p(p))), Context) :-
|
|
!,
|
|
'$lgt_this'(Context, This).
|
|
|
|
'$lgt_tr_msg'(Obj, asserta(Pred), '$lgt_asserta'(Obj, Pred, This, p(p(p))), Context) :-
|
|
!,
|
|
'$lgt_this'(Context, This).
|
|
|
|
'$lgt_tr_msg'(Obj, assertz(Pred), '$lgt_assertz'(Obj, Pred, This, p(p(p))), Context) :-
|
|
!,
|
|
'$lgt_this'(Context, This).
|
|
|
|
'$lgt_tr_msg'(Obj, clause(Head, Body), '$lgt_clause'(Obj, Head, Body, This, p(p(p))), Context) :-
|
|
!,
|
|
'$lgt_this'(Context, This).
|
|
|
|
'$lgt_tr_msg'(Obj, retract(Pred), '$lgt_retract'(Obj, Pred, This, p(p(p))), Context) :-
|
|
!,
|
|
'$lgt_this'(Context, This).
|
|
|
|
'$lgt_tr_msg'(Obj, retractall(Pred), '$lgt_retractall'(Obj, Pred, This, p(p(p))), Context) :-
|
|
!,
|
|
'$lgt_this'(Context, This).
|
|
|
|
|
|
% invalid goal
|
|
|
|
'$lgt_tr_msg'(_, Pred, _, _) :-
|
|
\+ '$lgt_callable'(Pred),
|
|
throw(type_error(callable, Pred)).
|
|
|
|
|
|
% message is not a built-in control construct or a call to a built-in
|
|
% (meta-)predicate: translation performed at runtime
|
|
|
|
'$lgt_tr_msg'(Obj, Pred, '$lgt_send_to_object'(Obj, Pred, This), Context) :-
|
|
var(Obj),
|
|
!,
|
|
'$lgt_this'(Context, This).
|
|
|
|
'$lgt_tr_msg'(Obj, Pred, '$lgt_send_to_object_nv'(Obj, Pred, This), Context) :-
|
|
!,
|
|
'$lgt_this'(Context, This).
|
|
|
|
|
|
|
|
% '$lgt_tr_self_msg'(@term, -term, +term)
|
|
%
|
|
% translates the sending of a message to self
|
|
|
|
|
|
% non-instantiated message: traslation performed at runtime
|
|
|
|
'$lgt_tr_self_msg'(Pred, '$lgt_send_to_self'(Self, Pred, This), Context) :-
|
|
var(Pred),
|
|
!,
|
|
'$lgt_this'(Context, This),
|
|
'$lgt_self'(Context, Self).
|
|
|
|
|
|
% control constructs
|
|
|
|
'$lgt_tr_self_msg'((Pred1, Pred2), (TPred1, TPred2), Context) :-
|
|
!,
|
|
'$lgt_tr_self_msg'(Pred1, TPred1, Context),
|
|
'$lgt_tr_self_msg'(Pred2, TPred2, Context).
|
|
|
|
'$lgt_tr_self_msg'(((Pred1; Pred2)), (TPred1; TPred2), Context) :-
|
|
!,
|
|
'$lgt_tr_self_msg'(Pred1, TPred1, Context),
|
|
'$lgt_tr_self_msg'(Pred2, TPred2, Context).
|
|
|
|
'$lgt_tr_self_msg'((Pred1 -> Pred2), (TPred1 -> TPred2), Context) :-
|
|
!,
|
|
'$lgt_tr_self_msg'(Pred1, TPred1, Context),
|
|
'$lgt_tr_self_msg'(Pred2, TPred2, Context).
|
|
|
|
'$lgt_tr_self_msg'(\+ Pred, \+ TPred, Context) :-
|
|
!,
|
|
'$lgt_tr_self_msg'(Pred, TPred, Context).
|
|
|
|
'$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, Context) :-
|
|
!,
|
|
'$lgt_tr_self_msg'(Pred, TPred, Context).
|
|
|
|
'$lgt_tr_self_msg'(once(Pred), once(TPred), Context) :-
|
|
!,
|
|
'$lgt_tr_self_msg'(Pred, TPred, Context).
|
|
|
|
'$lgt_tr_self_msg'(catch(Goal, Catcher, Recovery), catch(TGoal, Catcher, TRecovery), Context) :-
|
|
!,
|
|
'$lgt_tr_self_msg'(Goal, TGoal, Context),
|
|
'$lgt_tr_self_msg'(Recovery, TRecovery, Context).
|
|
|
|
'$lgt_tr_self_msg'(throw(Error), throw(Error), _) :-
|
|
!.
|
|
|
|
|
|
% built-in metapredicates
|
|
|
|
'$lgt_tr_self_msg'(bagof(Term, Pred, List), bagof(Term, TPred, List), Context) :-
|
|
!,
|
|
'$lgt_tr_self_msg'(Pred, TPred, Context).
|
|
|
|
'$lgt_tr_self_msg'(findall(Term, Pred, List), findall(Term, TPred, List), Context) :-
|
|
!,
|
|
'$lgt_tr_self_msg'(Pred, TPred, Context).
|
|
|
|
'$lgt_tr_self_msg'(forall(Generate, Test), forall(TGenerate, TTest), Context) :-
|
|
!,
|
|
'$lgt_tr_self_msg'(Generate, TGenerate, Context),
|
|
'$lgt_tr_self_msg'(Test, TTest, Context).
|
|
|
|
'$lgt_tr_self_msg'(setof(Term, Pred, List), setof(Term, TPred, List), Context) :-
|
|
!,
|
|
'$lgt_tr_self_msg'(Pred, TPred, Context).
|
|
|
|
|
|
% "reflection" built-in predicates
|
|
|
|
'$lgt_tr_self_msg'(current_predicate(Pred), '$lgt_current_predicate'(Self, Pred, This, p(_)), Context) :-
|
|
!,
|
|
'$lgt_self'(Context, Self),
|
|
'$lgt_this'(Context, This).
|
|
|
|
'$lgt_tr_self_msg'(predicate_property(Pred, Property), '$lgt_predicate_property'(Self, Pred, Property, This, p(_)), Context) :-
|
|
!,
|
|
'$lgt_self'(Context, Self),
|
|
'$lgt_this'(Context, This).
|
|
|
|
|
|
% database handling built-in predicates
|
|
|
|
'$lgt_tr_self_msg'(abolish(Pred), '$lgt_abolish'(Self, Pred, This, p(_)), Context) :-
|
|
!,
|
|
'$lgt_self'(Context, Self),
|
|
'$lgt_this'(Context, This).
|
|
|
|
'$lgt_tr_self_msg'(asserta(Pred), '$lgt_asserta'(Self, Pred, This, p(_)), Context) :-
|
|
!,
|
|
'$lgt_self'(Context, Self),
|
|
'$lgt_this'(Context, This).
|
|
|
|
'$lgt_tr_self_msg'(assertz(Pred), '$lgt_assertz'(Self, Pred, This, p(_)), Context) :-
|
|
!,
|
|
'$lgt_self'(Context, Self),
|
|
'$lgt_this'(Context, This).
|
|
|
|
'$lgt_tr_self_msg'(clause(Head, Body), '$lgt_clause'(Self, Head, Body, This, p(_)), Context) :-
|
|
!,
|
|
'$lgt_self'(Context, Self),
|
|
'$lgt_this'(Context, This).
|
|
|
|
'$lgt_tr_self_msg'(retract(Pred), '$lgt_retract'(Self, Pred, This, p(_)), Context) :-
|
|
!,
|
|
'$lgt_self'(Context, Self),
|
|
'$lgt_this'(Context, This).
|
|
|
|
'$lgt_tr_self_msg'(retractall(Pred), '$lgt_retractall'(Self, Pred, This, p(_)), Context) :-
|
|
!,
|
|
'$lgt_self'(Context, Self),
|
|
'$lgt_this'(Context, This).
|
|
|
|
|
|
% invalid goal
|
|
|
|
'$lgt_tr_self_msg'(Pred, _, _) :-
|
|
\+ '$lgt_callable'(Pred),
|
|
throw(type_error(callable, Pred)).
|
|
|
|
|
|
% message is not a built-in control construct or a call to a built-in
|
|
% (meta-)predicate: translation performed at runtime
|
|
|
|
'$lgt_tr_self_msg'(Pred, '$lgt_send_to_self_nv'(Self, Pred, This), Context) :-
|
|
!,
|
|
'$lgt_self'(Context, Self),
|
|
'$lgt_this'(Context, This).
|
|
|
|
|
|
|
|
% message broadcasting
|
|
|
|
'$lgt_tr_msg_broadcasting'((Obj1, Obj2), Pred, (TP1, TP2), Context) :-
|
|
!,
|
|
'$lgt_tr_msg'(Obj1, Pred, TP1, Context),
|
|
'$lgt_tr_msg'(Obj2, Pred, TP2, Context).
|
|
|
|
'$lgt_tr_msg_broadcasting'((Obj1; Obj2), Pred, (TP1; TP2), Context) :-
|
|
!,
|
|
'$lgt_tr_msg'(Obj1, Pred, TP1, Context),
|
|
'$lgt_tr_msg'(Obj2, Pred, TP2, Context).
|
|
|
|
|
|
|
|
% '$lgt_tr_super_sending'(@term, -term, +term)
|
|
%
|
|
% translates calling of redefined predicates (super calls)
|
|
|
|
|
|
% invalid goal
|
|
|
|
'$lgt_tr_super_sending'(Pred, _, _) :-
|
|
nonvar(Pred),
|
|
\+ '$lgt_callable'(Pred),
|
|
throw(type_error(callable, Pred)).
|
|
|
|
|
|
% translation performed at runtime
|
|
|
|
'$lgt_tr_super_sending'(Pred, '$lgt_send_to_super'(Self, Pred, This, Sender), Context) :-
|
|
var(Pred),
|
|
!,
|
|
'$lgt_self'(Context, Self),
|
|
'$lgt_this'(Context, This),
|
|
'$lgt_sender'(Context, Sender).
|
|
|
|
'$lgt_tr_super_sending'(Pred, '$lgt_send_to_super_nv'(Self, Pred, This, Sender), Context) :-
|
|
'$lgt_self'(Context, Self),
|
|
'$lgt_this'(Context, This),
|
|
'$lgt_sender'(Context, 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_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_simplify_clause'(+clause, -clause)
|
|
%
|
|
% simplify translated clause by examining clause body
|
|
|
|
'$lgt_simplify_clause'((Head :- true), Head) :-
|
|
!.
|
|
|
|
'$lgt_simplify_clause'((Head :- Body), Clause) :-
|
|
'$lgt_simplify_body'(Body, SBody),
|
|
(SBody == true ->
|
|
Clause = Head
|
|
;
|
|
Clause = (Head :- SBody)).
|
|
|
|
|
|
|
|
% '$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)
|
|
%
|
|
% from the object identifier construct the set of
|
|
% functor prefixes used in the compiled code clauses
|
|
|
|
'$lgt_tr_object_id'(Obj) :-
|
|
'$lgt_add_referenced_object'(Obj),
|
|
'$lgt_construct_object_functors'(Obj, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef),
|
|
assertz('$lgt_object_'(Obj, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef)),
|
|
Term =.. [Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef],
|
|
assertz('$lgt_entity_functors_'(Term)),
|
|
assertz('$lgt_rclause_'('$lgt_current_object_'(Obj, Prefix, Dcl, Def, Super))),
|
|
assertz('$lgt_entity_'(object, Obj, Prefix, Dcl)).
|
|
|
|
|
|
|
|
% '$lgt_tr_category_id'(+category_identifier)
|
|
%
|
|
% from the category identifier construct the set of
|
|
% functor prefixes used in the compiled code clauses
|
|
|
|
'$lgt_tr_category_id'(Ctg) :-
|
|
'$lgt_add_referenced_category'(Ctg),
|
|
'$lgt_construct_category_functors'(Ctg, Prefix, Dcl, Def),
|
|
assertz('$lgt_category_'(Ctg, Prefix, Dcl, Def)),
|
|
Term =.. [Prefix, Dcl, Def],
|
|
assertz('$lgt_entity_functors_'(Term)),
|
|
assertz('$lgt_rclause_'('$lgt_current_category_'(Ctg, Prefix))),
|
|
assertz('$lgt_entity_'(category, Ctg, Prefix, Dcl)).
|
|
|
|
|
|
|
|
% '$lgt_tr_protocol_id'(+protocol_identifier)
|
|
%
|
|
% from the protocol identifier construct the set of
|
|
% functor prefixes used in the compiled code clauses
|
|
|
|
'$lgt_tr_protocol_id'(Ptc) :-
|
|
'$lgt_add_referenced_protocol'(Ptc),
|
|
'$lgt_construct_protocol_functors'(Ptc, Prefix, Dcl),
|
|
assertz('$lgt_protocol_'(Ptc, Prefix, Dcl)),
|
|
Term =.. [Prefix, Dcl],
|
|
assertz('$lgt_entity_functors_'(Term)),
|
|
assertz('$lgt_rclause_'('$lgt_current_protocol_'(Ptc, Prefix))),
|
|
assertz('$lgt_entity_'(protocol, Ptc, Prefix, Dcl)).
|
|
|
|
|
|
|
|
% '$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),
|
|
('$lgt_valid_protocol_id'(Ptc) ->
|
|
'$lgt_add_referenced_protocol'(Ptc),
|
|
assertz('$lgt_rclause_'('$lgt_implements_protocol_'(ObjOrCtg, Ptc, Scope))),
|
|
'$lgt_construct_protocol_functors'(Ptc, Prefix, Dcl),
|
|
assertz('$lgt_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)
|
|
%
|
|
% translates an "imports" relation between
|
|
% an object and a list of categories
|
|
|
|
'$lgt_tr_imports_category'([], _).
|
|
|
|
'$lgt_tr_imports_category'([Ref| Refs], Obj) :-
|
|
'$lgt_valid_scope'(Ref) ->
|
|
('$lgt_scope_id'(Ref, Scope, Ctg),
|
|
('$lgt_valid_category_id'(Ctg) ->
|
|
'$lgt_add_referenced_category'(Ctg),
|
|
assertz('$lgt_rclause_'('$lgt_imports_category_'(Obj, Ctg, Scope))),
|
|
'$lgt_construct_category_functors'(Ctg, Prefix, Dcl, Def),
|
|
assertz('$lgt_imported_category_'(Ctg, Prefix, Dcl, Def, Scope)),
|
|
'$lgt_tr_imports_category'(Refs, Obj)
|
|
;
|
|
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),
|
|
('$lgt_valid_object_id'(Class) ->
|
|
'$lgt_add_referenced_object'(Class),
|
|
assertz('$lgt_rclause_'('$lgt_instantiates_class_'(Obj, Class, Scope))),
|
|
'$lgt_construct_object_functors'(Class, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef),
|
|
assertz('$lgt_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),
|
|
('$lgt_valid_object_id'(Superclass) ->
|
|
'$lgt_add_referenced_object'(Superclass),
|
|
assertz('$lgt_rclause_'('$lgt_specializes_class_'(Class, Superclass, Scope))),
|
|
'$lgt_construct_object_functors'(Superclass, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef),
|
|
assertz('$lgt_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),
|
|
('$lgt_valid_object_id'(Parent) ->
|
|
'$lgt_add_referenced_object'(Parent),
|
|
assertz('$lgt_rclause_'('$lgt_extends_object_'(Obj, Parent, Scope))),
|
|
'$lgt_construct_object_functors'(Parent, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef),
|
|
assertz('$lgt_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),
|
|
('$lgt_valid_protocol_id'(Ptc2) ->
|
|
'$lgt_add_referenced_protocol'(Ptc2),
|
|
assertz('$lgt_rclause_'('$lgt_extends_protocol_'(Ptc1, Ptc2, Scope))),
|
|
'$lgt_construct_protocol_functors'(Ptc2, Prefix, Dcl),
|
|
assertz('$lgt_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_referenced_object_'(Obj) ->
|
|
true
|
|
;
|
|
assertz('$lgt_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_referenced_protocol_'(Ptc) ->
|
|
true
|
|
;
|
|
assertz('$lgt_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_referenced_category_'(Ctg) ->
|
|
true
|
|
;
|
|
assertz('$lgt_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_referenced_object_'(Obj), \+ ('$lgt_current_object_'(Obj, _, _, _, _); '$lgt_entity_'(_, 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_referenced_protocol_'(Ptc), \+ ('$lgt_current_protocol_'(Ptc, _); '$lgt_entity_'(_, 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_referenced_category_'(Ctg), \+ ('$lgt_current_category_'(Ctg, _); '$lgt_entity_'(_, 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, Context) :-
|
|
functor(Head, Functor, Arity),
|
|
Head =.. [_| Args],
|
|
'$lgt_sender'(Context, Sender),
|
|
'$lgt_this'(Context, This),
|
|
'$lgt_self'(Context, Self),
|
|
'$lgt_append'(Args, [Sender, This, Self], TArgs),
|
|
THead =.. [Prefix|TArgs],
|
|
once(
|
|
('$lgt_object_'(_, _, _, Def, _, _, _, _, _);
|
|
'$lgt_category_'(_, _, _, Def))),
|
|
Clause =.. [Def, Head, Sender, This, Self, THead],
|
|
('$lgt_def_'(Clause) ->
|
|
true
|
|
;
|
|
assertz('$lgt_def_'(Clause))),
|
|
('$lgt_built_in'(Head) ->
|
|
assertz('$lgt_redefined_built_in_'(Head, Context, THead))
|
|
;
|
|
true),
|
|
('$lgt_defs_pred_'(Functor/Arity) ->
|
|
true
|
|
;
|
|
assertz('$lgt_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, Context) :-
|
|
functor(Head, Functor, Arity),
|
|
Head =.. [_| Args],
|
|
'$lgt_sender'(Context, Sender),
|
|
'$lgt_this'(Context, This),
|
|
'$lgt_self'(Context, Self),
|
|
'$lgt_append'(Args, [Sender, This, Self], TArgs),
|
|
THead =.. [Prefix|TArgs],
|
|
'$lgt_object_'(_, _, _, _, _, _, _, _, DDef),
|
|
Clause =.. [DDef, Head, Sender, This, Self, THead],
|
|
('$lgt_ddef_'(Clause) ->
|
|
true
|
|
;
|
|
assertz('$lgt_ddef_'(Clause))),
|
|
('$lgt_built_in'(Head) ->
|
|
assertz('$lgt_redefined_built_in_'(Head, Context, THead))
|
|
;
|
|
true),
|
|
('$lgt_defs_pred_'(Functor/Arity) ->
|
|
true
|
|
;
|
|
assertz('$lgt_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_update_ddef_table'(+atom, +callable)
|
|
%
|
|
% retracts a dynamic "ddef clause" (used to translate a predicate call)
|
|
% if there are no more clauses for the predicate otherwise does nothing
|
|
|
|
'$lgt_update_ddef_table'(DDef, Call) :-
|
|
functor(Call, Functor, Arity),
|
|
functor(Call2, Functor, Arity),
|
|
(clause(Call2, _) ->
|
|
true
|
|
;
|
|
Clause =.. [DDef, _, _, _, _, Call2],
|
|
retractall(Clause)).
|
|
|
|
|
|
|
|
% '$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_entity_comp_mode_'((dynamic)) ->
|
|
'$lgt_protocol_'(_, Prefix, Dcl),
|
|
assertz('$lgt_directive_'(dynamic(Prefix/1))),
|
|
assertz('$lgt_directive_'(dynamic(Dcl/4))),
|
|
assertz('$lgt_directive_'(dynamic(Dcl/5)))
|
|
;
|
|
true.
|
|
|
|
|
|
|
|
'$lgt_gen_object_dynamic_directives' :-
|
|
'$lgt_entity_comp_mode_'((dynamic)) ->
|
|
'$lgt_gen_dynamic_object_dynamic_directives'
|
|
;
|
|
'$lgt_gen_static_object_dynamic_directives'.
|
|
|
|
|
|
|
|
'$lgt_gen_dynamic_object_dynamic_directives' :-
|
|
'$lgt_object_'(_, Prefix, Dcl, Def, Super, IDcl, IDef, DDcl, DDef),
|
|
assertz('$lgt_directive_'(dynamic(Prefix/7))),
|
|
assertz('$lgt_directive_'(dynamic(Dcl/4))),
|
|
assertz('$lgt_directive_'(dynamic(Dcl/6))),
|
|
assertz('$lgt_directive_'(dynamic(Def/5))),
|
|
assertz('$lgt_directive_'(dynamic(Def/6))),
|
|
assertz('$lgt_directive_'(dynamic(Super/6))),
|
|
assertz('$lgt_directive_'(dynamic(IDcl/6))),
|
|
assertz('$lgt_directive_'(dynamic(IDef/6))),
|
|
assertz('$lgt_directive_'(dynamic(DDcl/2))),
|
|
assertz('$lgt_directive_'(dynamic(DDef/5))),
|
|
forall(
|
|
('$lgt_def_'(Clause), Clause \= (_ :- _)),
|
|
(arg(5, Clause, Call), functor(Call, Functor, Arity),
|
|
assertz('$lgt_directive_'(dynamic(Functor/Arity))))).
|
|
|
|
|
|
|
|
'$lgt_gen_static_object_dynamic_directives' :-
|
|
'$lgt_object_'(_, _, _, Def, _, _, _, DDcl, DDef),
|
|
assertz('$lgt_directive_'(dynamic(DDcl/2))),
|
|
assertz('$lgt_directive_'(dynamic(DDef/5))),
|
|
'$lgt_dynamic_'(Functor/Arity),
|
|
functor(Pred, Functor, Arity),
|
|
Clause =.. [Def, Pred, _, _, _, TPred],
|
|
'$lgt_def_'(Clause),
|
|
functor(TPred, TFunctor, TArity),
|
|
assertz('$lgt_directive_'(dynamic(TFunctor/TArity))),
|
|
fail.
|
|
|
|
'$lgt_gen_static_object_dynamic_directives'.
|
|
|
|
|
|
|
|
'$lgt_gen_object_discontiguous_directives' :-
|
|
'$lgt_object_'(_, _, _, Def, _, _, _, _, _),
|
|
'$lgt_discontiguous_'(Functor/Arity),
|
|
functor(Pred, Functor, Arity),
|
|
Clause =.. [Def, Pred, _, _, _, TPred],
|
|
'$lgt_def_'(Clause),
|
|
functor(TPred, TFunctor, TArity),
|
|
assertz('$lgt_directive_'(discontiguous(TFunctor/TArity))),
|
|
fail.
|
|
|
|
'$lgt_gen_object_discontiguous_directives'.
|
|
|
|
|
|
|
|
'$lgt_gen_category_dynamic_directives' :-
|
|
'$lgt_entity_comp_mode_'((dynamic)) ->
|
|
'$lgt_category_'(_, Prefix, Dcl, Def),
|
|
assertz('$lgt_directive_'(dynamic(Prefix/2))),
|
|
assertz('$lgt_directive_'(dynamic(Dcl/4))),
|
|
assertz('$lgt_directive_'(dynamic(Dcl/5))),
|
|
assertz('$lgt_directive_'(dynamic(Def/5))),
|
|
forall(
|
|
('$lgt_def_'(Clause), Clause \= (_ :- _)),
|
|
(arg(5, Clause, Call), functor(Call, Functor, Arity),
|
|
assertz('$lgt_directive_'(dynamic(Functor/Arity)))))
|
|
;
|
|
true.
|
|
|
|
|
|
|
|
'$lgt_gen_category_discontiguous_directives' :-
|
|
'$lgt_category_'(_, _, _, Def),
|
|
'$lgt_discontiguous_'(Functor/Arity),
|
|
functor(Pred, Functor, Arity),
|
|
Clause =.. [Def, Pred, _, _, _, TPred],
|
|
'$lgt_def_'(Clause),
|
|
functor(TPred, TFunctor, TArity),
|
|
assertz('$lgt_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_rclause_'('$lgt_instantiates_class_'(_, _, _));
|
|
'$lgt_rclause_'('$lgt_specializes_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_entity_'(_, _, _, Dcl),
|
|
(('$lgt_public_'(Functor/Arity), Scope = p(p(p)));
|
|
('$lgt_protected_'(Functor/Arity), Scope = p(p));
|
|
('$lgt_private_'(Functor/Arity), Scope = p)),
|
|
functor(Meta, Functor, Arity),
|
|
('$lgt_metapredicate_'(Meta) ->
|
|
Meta2 = Meta
|
|
;
|
|
Meta2 = no),
|
|
functor(Pred, Functor, Arity),
|
|
('$lgt_dynamic_'(Functor/Arity)->
|
|
Compilation = (dynamic)
|
|
;
|
|
Compilation = static),
|
|
Fact =.. [Dcl, Pred, Scope, Compilation, Meta2],
|
|
assertz('$lgt_dcl_'(Fact)),
|
|
fail.
|
|
|
|
'$lgt_gen_local_dcl_clauses'.
|
|
|
|
|
|
|
|
'$lgt_gen_catchall_dcl_clause' :-
|
|
\+ '$lgt_dcl_'(_) ->
|
|
'$lgt_entity_'(_, _, _, Dcl),
|
|
Head =.. [Dcl, _, _, _, _],
|
|
assertz('$lgt_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_entity_'(_, _, EPrefix, _),
|
|
'$lgt_dynamic_'(Functor/Arity),
|
|
\+ '$lgt_defs_pred_'(Functor/Arity),
|
|
'$lgt_construct_predicate_functor'(EPrefix, Functor, Arity, PPrefix),
|
|
'$lgt_context'(Context),
|
|
((\+ '$lgt_public_'(Functor/Arity),
|
|
\+ '$lgt_protected_'(Functor/Arity),
|
|
\+ '$lgt_private_'(Functor/Arity)) ->
|
|
'$lgt_add_ddef_clause'(Functor, Arity, PPrefix, Context)
|
|
;
|
|
'$lgt_add_def_clause'(Functor, Arity, PPrefix, Context)),
|
|
fail.
|
|
|
|
'$lgt_gen_local_def_clauses'.
|
|
|
|
|
|
|
|
'$lgt_gen_obj_catchall_def_clause' :-
|
|
\+ '$lgt_def_'(_) ->
|
|
'$lgt_object_'(_, _, _, Def, _, _, _, _, _),
|
|
Head =.. [Def, _, _, _, _, _],
|
|
assertz('$lgt_def_'((Head:-fail)))
|
|
;
|
|
true.
|
|
|
|
|
|
|
|
'$lgt_gen_protocol_clauses' :-
|
|
'$lgt_gen_protocol_local_clauses',
|
|
'$lgt_gen_protocol_linking_clauses',
|
|
'$lgt_gen_protocol_extend_clauses'.
|
|
|
|
|
|
|
|
'$lgt_gen_protocol_local_clauses' :-
|
|
'$lgt_gen_local_dcl_clauses',
|
|
'$lgt_gen_catchall_dcl_clause'.
|
|
|
|
|
|
|
|
'$lgt_gen_protocol_linking_clauses' :-
|
|
'$lgt_protocol_'(Ptc, _, PDcl),
|
|
Head =.. [PDcl, Pred, Scope, Compilation, Meta, Ptc],
|
|
Body =.. [PDcl, Pred, Scope, Compilation, Meta],
|
|
assertz('$lgt_dcl_'((Head:-Body))).
|
|
|
|
|
|
|
|
'$lgt_gen_protocol_extend_clauses' :-
|
|
'$lgt_protocol_'(_, _, PDcl1),
|
|
Head =.. [PDcl1, Pred, Scope, Compilation, Meta, Container],
|
|
'$lgt_extended_protocol_'(_, _, PDcl2, EScope),
|
|
(EScope = (public) ->
|
|
Body =.. [PDcl2, Pred, Scope, Compilation, Meta, Container]
|
|
;
|
|
(EScope = protected ->
|
|
Call =.. [PDcl2, Pred, Scope2, Compilation, Meta, Container],
|
|
Body = (Call, (Scope2 = p -> Scope = p; Scope = p(p)))
|
|
;
|
|
Scope = p,
|
|
Body =.. [PDcl2, Pred, _, Compilation, Meta, Container])),
|
|
assertz('$lgt_dcl_'((Head:-Body))),
|
|
fail.
|
|
|
|
'$lgt_gen_protocol_extend_clauses'.
|
|
|
|
|
|
|
|
'$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_catchall_dcl_clause',
|
|
'$lgt_gen_category_linking_dcl_clauses',
|
|
'$lgt_gen_category_implements_dcl_clauses'.
|
|
|
|
|
|
|
|
'$lgt_gen_category_linking_dcl_clauses' :-
|
|
'$lgt_category_'(Ctg, _, CDcl, _),
|
|
Head =.. [CDcl, Pred, Scope, Compilation, Meta, Ctg],
|
|
Body =.. [CDcl, Pred, Scope, Compilation, Meta],
|
|
assertz('$lgt_dcl_'((Head:-Body))).
|
|
|
|
|
|
|
|
'$lgt_gen_category_implements_dcl_clauses' :-
|
|
'$lgt_category_'(_, _, CDcl, _),
|
|
Head =.. [CDcl, Pred, Scope, Compilation, Meta, Container],
|
|
'$lgt_implemented_protocol_'(_, _, PDcl, EScope),
|
|
(EScope = (public) ->
|
|
Body =.. [PDcl, Pred, Scope, Compilation, Meta, Container]
|
|
;
|
|
(EScope = protected ->
|
|
Call =.. [PDcl, Pred, Scope2, Compilation, Meta, Container],
|
|
Body = (Call, (Scope2 = p -> Scope = p; Scope = p(p)))
|
|
;
|
|
Scope = p,
|
|
Body =.. [PDcl, Pred, _, Compilation, Meta, Container])),
|
|
assertz('$lgt_dcl_'((Head:-Body))),
|
|
fail.
|
|
|
|
'$lgt_gen_category_implements_dcl_clauses'.
|
|
|
|
|
|
|
|
'$lgt_gen_category_def_clauses' :-
|
|
'$lgt_gen_category_catchall_def_clause'.
|
|
|
|
|
|
|
|
'$lgt_gen_category_catchall_def_clause' :-
|
|
\+ '$lgt_def_'(_) ->
|
|
'$lgt_category_'(_, _, _, Def),
|
|
Head =.. [Def, _, _, _, _, _],
|
|
assertz('$lgt_def_'((Head:-fail)))
|
|
;
|
|
true.
|
|
|
|
|
|
|
|
'$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_catchall_dcl_clause',
|
|
'$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_object_'(Obj, _, Dcl, _, _, _, _, DDcl, _),
|
|
Head =.. [Dcl, Pred, Scope, Compilation, Meta, Obj, Obj],
|
|
Body =.. [Dcl, Pred, Scope, Compilation, Meta],
|
|
assertz('$lgt_dcl_'((Head:-Body))),
|
|
Head2 =.. [Dcl, Pred, Scope, (dynamic), no, Obj, Obj],
|
|
Body2 =.. [DDcl, Pred, Scope],
|
|
assertz('$lgt_dcl_'((Head2:-Body2))).
|
|
|
|
|
|
|
|
'$lgt_gen_prototype_implements_dcl_clauses' :-
|
|
'$lgt_object_'(Obj, _, ODcl, _, _, _, _, _, _),
|
|
Head =.. [ODcl, Pred, Scope, Compilation, Meta, Obj, Container],
|
|
'$lgt_implemented_protocol_'(_, _, PDcl, EScope),
|
|
(EScope = (public) ->
|
|
Body =.. [PDcl, Pred, Scope, Compilation, Meta, Container]
|
|
;
|
|
(EScope = protected ->
|
|
Call =.. [PDcl, Pred, Scope2, Compilation, Meta, Container],
|
|
Body = (Call, (Scope2 = p -> Scope = p; Scope = p(p)))
|
|
;
|
|
Scope = p,
|
|
Body =.. [PDcl, Pred, _, Compilation, Meta, Container])),
|
|
assertz('$lgt_dcl_'((Head:-Body))),
|
|
fail.
|
|
|
|
'$lgt_gen_prototype_implements_dcl_clauses'.
|
|
|
|
|
|
|
|
'$lgt_gen_prototype_imports_dcl_clauses' :-
|
|
'$lgt_object_'(Obj, _, ODcl, _, _, _, _, _, _),
|
|
Head =.. [ODcl, Pred, Scope, Compilation, Meta, Obj, Container],
|
|
'$lgt_imported_category_'(_, _, CDcl, _, EScope),
|
|
(EScope = (public) ->
|
|
Body =.. [CDcl, Pred, Scope, Compilation, Meta, Container]
|
|
;
|
|
(EScope = protected ->
|
|
Call =.. [CDcl, Pred, Scope2, Compilation, Meta, Container],
|
|
Body = (Call, (Scope2 = p -> Scope = p; Scope = p(p)))
|
|
;
|
|
Scope = p,
|
|
Body =.. [CDcl, Pred, _, Compilation, Meta, Container])),
|
|
assertz('$lgt_dcl_'((Head:-Body))),
|
|
fail.
|
|
|
|
'$lgt_gen_prototype_imports_dcl_clauses'.
|
|
|
|
|
|
|
|
'$lgt_gen_prototype_extends_dcl_clauses' :-
|
|
'$lgt_object_'(Obj, _, ODcl, _, _, _, _, _, _),
|
|
Head =.. [ODcl, Pred, Scope, Compilation, Meta, SContainer, TContainer],
|
|
'$lgt_extended_object_'(_, _, PDcl, _, _, _, _, _, _, EScope),
|
|
(EScope = (public) ->
|
|
Body =.. [PDcl, Pred, Scope, Compilation, Meta, SContainer, TContainer]
|
|
;
|
|
(EScope = protected ->
|
|
Call =.. [PDcl, Pred, Scope2, Compilation, Meta, SContainer, TContainer],
|
|
Body = (Call, (Scope2 = p -> Scope = p; Scope = p(p)))
|
|
;
|
|
Scope = p,
|
|
Call =.. [PDcl, Pred, Scope2, Compilation, Meta, SContainer2, TContainer],
|
|
Body = (Call, (Scope2 = p -> SContainer = SContainer2; SContainer = Obj)))),
|
|
assertz('$lgt_dcl_'((Head:-Body))),
|
|
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_object_'(Obj, _, _, Def, _, _, _, _, DDef),
|
|
Head =.. [Def, Pred, Sender, This, Self, Call, Obj],
|
|
Body =.. [Def, Pred, Sender, This, Self, Call],
|
|
assertz('$lgt_def_'((Head:-Body))),
|
|
Body2 =.. [DDef, Pred, Sender, This, Self, Call],
|
|
assertz('$lgt_def_'((Head:-Body2))).
|
|
|
|
|
|
|
|
'$lgt_gen_prototype_imports_def_clauses' :-
|
|
'$lgt_object_'(Obj, _, _, ODef, _, _, _, _, _),
|
|
'$lgt_rclause_'('$lgt_imports_category_'(Obj, Ctg, _)),
|
|
Head =.. [ODef, Pred, Sender, Obj, Self, Call, Ctg],
|
|
'$lgt_imported_category_'(Ctg, _, _, CDef, _),
|
|
Body =.. [CDef, Pred, Sender, Obj, Self, Call],
|
|
assertz('$lgt_def_'((Head:-Body))),
|
|
fail.
|
|
|
|
'$lgt_gen_prototype_imports_def_clauses'.
|
|
|
|
|
|
|
|
'$lgt_gen_prototype_extends_def_clauses' :-
|
|
'$lgt_object_'(Obj, _, _, ODef, _, _, _, _, _),
|
|
'$lgt_rclause_'('$lgt_extends_object_'(Obj, Parent, _)),
|
|
Head =.. [ODef, Pred, Sender, Obj, Self, Call, Container],
|
|
'$lgt_extended_object_'(Parent, _, _, PDef, _, _, _, _, _, _),
|
|
Body =.. [PDef, Pred, Sender, Parent, Self, Call, Container],
|
|
assertz('$lgt_def_'((Head:-Body))),
|
|
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_object_'(Obj, _, _, _, OSuper, _, _, _, _),
|
|
\+ '$lgt_rclause_'('$lgt_extends_object_'(Obj, _, _)),
|
|
Head =.. [OSuper, _, _, _, _, _, _],
|
|
assertz('$lgt_def_'((Head:-fail))),
|
|
!.
|
|
|
|
% ... or we may extends some objects
|
|
|
|
'$lgt_gen_prototype_super_clauses' :-
|
|
'$lgt_object_'(Obj, _, _, _, OSuper, _, _, _, _),
|
|
'$lgt_rclause_'('$lgt_extends_object_'(Obj, Parent, _)),
|
|
Head =.. [OSuper, Pred, Sender, Obj, Self, Call, Container],
|
|
'$lgt_extended_object_'(Parent, _, _, PDef, _, _, _, _, _, _),
|
|
Body =.. [PDef, Pred, Sender, Parent, Self, Call, Container],
|
|
assertz('$lgt_def_'((Head:-Body))),
|
|
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_catchall_dcl_clause',
|
|
'$lgt_gen_ic_hierarchy_dcl_clauses'.
|
|
|
|
|
|
|
|
'$lgt_gen_ic_hierarchy_dcl_clauses' :-
|
|
\+ '$lgt_instantiated_class_'(_, _, _, _, _, _, _, _, _, _),
|
|
!,
|
|
'$lgt_object_'(_, _, ODcl, _, _, _, _, _, _),
|
|
Head =.. [ODcl, _, _, _, _, _, _],
|
|
assertz('$lgt_dcl_'((Head:-fail))).
|
|
|
|
'$lgt_gen_ic_hierarchy_dcl_clauses' :-
|
|
'$lgt_object_'(Obj, _, ODcl, _, _, _, _, _, _),
|
|
Head =.. [ODcl, Pred, Scope, Compilation, Meta, SContainer, TContainer],
|
|
'$lgt_instantiated_class_'(_, _, _, _, _, CIDcl, _, _, _, EScope),
|
|
(EScope = (public) ->
|
|
Body =.. [CIDcl, Pred, Scope, Compilation, Meta, SContainer, TContainer]
|
|
;
|
|
(EScope = protected ->
|
|
Call =.. [CIDcl, Pred, Scope2, Compilation, Meta, SContainer, TContainer],
|
|
Body = (Call, (Scope2 = p -> Scope = p; Scope = p(p)))
|
|
;
|
|
Scope = p,
|
|
Call =.. [CIDcl, Pred, Scope2, Compilation, Meta, SContainer2, TContainer],
|
|
Body = (Call, (Scope2 = p -> SContainer = SContainer2; SContainer = Obj)))),
|
|
assertz('$lgt_dcl_'((Head:-Body))),
|
|
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_object_'(Obj, _, Dcl, _, _, IDcl, _, DDcl, _),
|
|
Head =.. [IDcl, Pred, Scope, Compilation, Meta, Obj, Obj],
|
|
Body =.. [Dcl, Pred, Scope, Compilation, Meta],
|
|
assertz('$lgt_dcl_'((Head:-Body))),
|
|
Head2 =.. [IDcl, Pred, Scope, (dynamic), no, Obj, Obj],
|
|
Body2 =.. [DDcl, Pred, Scope],
|
|
assertz('$lgt_dcl_'((Head2:-Body2))).
|
|
|
|
|
|
|
|
|
|
'$lgt_gen_ic_protocol_idcl_clauses' :-
|
|
'$lgt_object_'(Obj, _, _, _, _, OIDcl, _, _, _),
|
|
Head =.. [OIDcl, Pred, Scope, Compilation, Meta, Obj, Container],
|
|
'$lgt_implemented_protocol_'(_, _, PDcl, EScope),
|
|
(EScope = (public) ->
|
|
Body =.. [PDcl, Pred, Scope, Compilation, Meta, Container]
|
|
;
|
|
(EScope = protected ->
|
|
Call =.. [PDcl, Pred, Scope2, Compilation, Meta, Container],
|
|
Body = (Call, (Scope2 = p -> Scope = p; Scope = p(p)))
|
|
;
|
|
Scope = p,
|
|
Body =.. [PDcl, Pred, _, Compilation, Meta, Container])),
|
|
assertz('$lgt_dcl_'((Head:-Body))),
|
|
fail.
|
|
|
|
'$lgt_gen_ic_protocol_idcl_clauses'.
|
|
|
|
|
|
|
|
'$lgt_gen_ic_category_idcl_clauses' :-
|
|
'$lgt_object_'(Obj, _, _, _, _, OIDcl, _, _, _),
|
|
Head =.. [OIDcl, Pred, Scope, Compilation, Meta, Obj, Container],
|
|
'$lgt_imported_category_'(_, _, CDcl, _, EScope),
|
|
(EScope = (public) ->
|
|
Body =.. [CDcl, Pred, Scope, Compilation, Meta, Container]
|
|
;
|
|
(EScope = protected ->
|
|
Call =.. [CDcl, Pred, Scope2, Compilation, Meta, Container],
|
|
Body = (Call, (Scope2 = p -> Scope = p; Scope = p(p)))
|
|
;
|
|
Scope = p,
|
|
Body =.. [CDcl, Pred, _, Compilation, Meta, Container])),
|
|
assertz('$lgt_dcl_'((Head:-Body))),
|
|
fail.
|
|
|
|
'$lgt_gen_ic_category_idcl_clauses'.
|
|
|
|
|
|
|
|
'$lgt_gen_ic_hierarchy_idcl_clauses' :-
|
|
'$lgt_object_'(Obj, _, _, _, _, CIDcl, _, _, _),
|
|
Head =.. [CIDcl, Pred, Scope, Compilation, Meta, SContainer, TContainer],
|
|
'$lgt_specialized_class_'(_, _, _, _, _, SIDcl, _, _, _, EScope),
|
|
(EScope = (public) ->
|
|
Body =.. [SIDcl, Pred, Scope, Compilation, Meta, SContainer, TContainer]
|
|
;
|
|
(EScope = protected ->
|
|
Call =.. [SIDcl, Pred, Scope2, Compilation, Meta, SContainer, TContainer],
|
|
Body = (Call, (Scope2 = p -> Scope = p; Scope = p(p)))
|
|
;
|
|
Scope = p,
|
|
Call =.. [SIDcl, Pred, Scope2, Compilation, Meta, SContainer2, TContainer],
|
|
Body = (Call, (Scope2 = p -> SContainer = SContainer2; SContainer = Obj)))),
|
|
assertz('$lgt_dcl_'((Head:-Body))),
|
|
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_object_'(Obj, _, _, Def, _, _, _, _, DDef),
|
|
Head =.. [Def, Pred, Sender, This, Self, Call, Obj],
|
|
Body =.. [Def, Pred, Sender, This, Self, Call],
|
|
assertz('$lgt_def_'((Head:-Body))),
|
|
Body2 =.. [DDef, Pred, Sender, This, Self, Call],
|
|
assertz('$lgt_def_'((Head:-Body2))).
|
|
|
|
|
|
|
|
'$lgt_gen_ic_imports_def_clauses' :-
|
|
'$lgt_object_'(Obj, _, _, ODef, _, _, _, _, _),
|
|
'$lgt_rclause_'('$lgt_imports_category_'(Obj, Ctg, _)),
|
|
Head =.. [ODef, Pred, Sender, Obj, Self, Call, Ctg],
|
|
'$lgt_imported_category_'(Ctg, _, _, CDef, _),
|
|
Body =.. [CDef, Pred, Sender, Obj, Self, Call],
|
|
assertz('$lgt_def_'((Head:-Body))),
|
|
fail.
|
|
|
|
'$lgt_gen_ic_imports_def_clauses'.
|
|
|
|
|
|
|
|
'$lgt_gen_ic_hierarchy_def_clauses' :-
|
|
'$lgt_object_'(Obj, _, _, ODef, _, _, _, _, _),
|
|
'$lgt_rclause_'('$lgt_instantiates_class_'(Obj, Class, _)),
|
|
Head =.. [ODef, Pred, Sender, Obj, Self, Call, Container],
|
|
'$lgt_instantiated_class_'(Class, _, _, _, _, _, CIDef, _, _, _),
|
|
Body =.. [CIDef, Pred, Sender, Class, Self, Call, Container],
|
|
assertz('$lgt_def_'((Head:-Body))),
|
|
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_object_'(Obj, _, _, Def, _, _, IDef, _, DDef),
|
|
Head =.. [IDef, Pred, Sender, This, Self, Call, Obj],
|
|
Body =.. [Def, Pred, Sender, This, Self, Call],
|
|
assertz('$lgt_def_'((Head:-Body))),
|
|
Body2 =.. [DDef, Pred, Sender, This, Self, Call],
|
|
assertz('$lgt_def_'((Head:-Body2))).
|
|
|
|
|
|
|
|
'$lgt_gen_ic_category_idef_clauses' :-
|
|
'$lgt_object_'(Obj, _, _, _, _, _, OIDef, _, _),
|
|
'$lgt_rclause_'('$lgt_imports_category_'(Obj, Ctg, _)),
|
|
Head =.. [OIDef, Pred, Sender, Obj, Self, Call, Ctg],
|
|
'$lgt_imported_category_'(Ctg, _, _, CDef, _),
|
|
Body =.. [CDef, Pred, Sender, Obj, Self, Call],
|
|
assertz('$lgt_def_'((Head:-Body))),
|
|
fail.
|
|
|
|
|
|
'$lgt_gen_ic_category_idef_clauses'.
|
|
|
|
|
|
|
|
'$lgt_gen_ic_hierarchy_idef_clauses' :-
|
|
'$lgt_object_'(Class, _, _, _, _, _, CIDef, _, _),
|
|
'$lgt_rclause_'('$lgt_specializes_class_'(Class, Super, _)),
|
|
Head =.. [CIDef, Pred, Sender, Class, Self, Call, Container],
|
|
'$lgt_specialized_class_'(Super, _, _, _, _, _, SIDef, _, _, _),
|
|
Body =.. [SIDef, Pred, Sender, Super, Self, Call, Container],
|
|
assertz('$lgt_def_'((Head:-Body))),
|
|
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_object_'(_, _, _, _, OSuper, _, _, _, _),
|
|
\+ '$lgt_rclause_'('$lgt_instantiates_class_'(_, _, _)),
|
|
\+ '$lgt_rclause_'('$lgt_specializes_class_'(_, _, _)),
|
|
Head =.. [OSuper, _, _, _, _, _, _],
|
|
assertz('$lgt_def_'((Head:-fail))),
|
|
!.
|
|
|
|
% ... or predicates can be redefined in instances...
|
|
|
|
'$lgt_gen_ic_super_clauses' :-
|
|
'$lgt_object_'(Obj, _, _, _, OSuper, _, _, _, _),
|
|
'$lgt_rclause_'('$lgt_instantiates_class_'(Obj, Class, _)),
|
|
Head =.. [OSuper, Pred, Sender, Obj, Obj, Call, Container],
|
|
'$lgt_instantiated_class_'(Class, _, _, _, _, _, CIDef, _, _, _),
|
|
Body =.. [CIDef, Pred, Sender, Class, Obj, Call, Container],
|
|
assertz('$lgt_def_'((Head:-Body))),
|
|
fail.
|
|
|
|
% ... or/and in subclasses...
|
|
|
|
'$lgt_gen_ic_super_clauses' :-
|
|
'$lgt_object_'(Class, _, _, _, CSuper, _, _, _, _),
|
|
'$lgt_rclause_'('$lgt_specializes_class_'(Class, Super, _)),
|
|
Head =.. [CSuper, Pred, Sender, Class, Self, Call, Container],
|
|
'$lgt_specialized_class_'(Super, _, _, _, _, _, SIDef, _, _, _),
|
|
Body =.. [SIDef, Pred, Sender, Super, Self, Call, Container],
|
|
assertz('$lgt_def_'((Head:-Body))),
|
|
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' :-
|
|
retract('$lgt_eclause_'(Clause)),
|
|
'$lgt_fix_redef_built_ins'(Clause, Fixed),
|
|
assertz('$lgt_feclause_'(Fixed)),
|
|
fail.
|
|
|
|
'$lgt_fix_redef_built_ins' :-
|
|
retract('$lgt_entity_init_'(Call)),
|
|
'$lgt_fix_redef_built_ins'(Call, Fixed),
|
|
assertz('$lgt_fentity_init_'(Fixed)),
|
|
fail.
|
|
|
|
'$lgt_fix_redef_built_ins'.
|
|
|
|
|
|
|
|
% '$lgt_fix_redef_built_ins'(+clause, -clause)
|
|
|
|
'$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(Generate, Test), forall(TGenerate, TTest)) :-
|
|
!,
|
|
'$lgt_fix_redef_built_ins'(Generate, TGenerate),
|
|
'$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_call_built_in'(Pred, Context), TPred) :-
|
|
!,
|
|
('$lgt_redefined_built_in_'(Pred, Context, TPred) ->
|
|
true
|
|
;
|
|
'$lgt_fix_redef_built_ins'(Pred, TPred)).
|
|
|
|
'$lgt_fix_redef_built_ins'(Pred, Pred).
|
|
|
|
|
|
|
|
% find and report misspelt predicate calls
|
|
% in the body of objects/cartegories predicates
|
|
|
|
'$lgt_find_misspelt_calls' :-
|
|
setof(Pred,
|
|
('$lgt_calls_pred_'(Pred), \+ '$lgt_defs_pred_'(Pred), \+ '$lgt_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_write_directives'(+stream)
|
|
%
|
|
% writes the directives
|
|
|
|
'$lgt_write_directives'(Stream) :-
|
|
'$lgt_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_entity_clauses'(Stream).
|
|
|
|
|
|
|
|
'$lgt_write_functors_clause'(Stream) :-
|
|
'$lgt_entity_functors_'(Clause),
|
|
write_canonical(Stream, Clause),
|
|
write(Stream, '.'),
|
|
nl(Stream).
|
|
|
|
|
|
|
|
'$lgt_write_def_clauses'(Stream) :-
|
|
'$lgt_def_'(Clause),
|
|
write_canonical(Stream, Clause),
|
|
write(Stream, '.'), nl(Stream),
|
|
fail.
|
|
|
|
'$lgt_write_def_clauses'(_).
|
|
|
|
|
|
|
|
'$lgt_write_ddef_clauses'(Stream) :-
|
|
'$lgt_ddef_'(Clause),
|
|
write_canonical(Stream, Clause),
|
|
write(Stream, '.'), nl(Stream),
|
|
fail.
|
|
|
|
'$lgt_write_ddef_clauses'(_).
|
|
|
|
|
|
|
|
'$lgt_write_dcl_clauses'(Stream) :-
|
|
'$lgt_dcl_'(Clause),
|
|
write_canonical(Stream, Clause),
|
|
write(Stream, '.'),
|
|
nl(Stream),
|
|
fail.
|
|
|
|
'$lgt_write_dcl_clauses'(_).
|
|
|
|
|
|
|
|
'$lgt_write_super_clauses'(Stream) :-
|
|
'$lgt_super_'(Clause),
|
|
write_canonical(Stream, Clause),
|
|
write(Stream, '.'),
|
|
nl(Stream),
|
|
fail.
|
|
|
|
'$lgt_write_super_clauses'(_).
|
|
|
|
|
|
|
|
'$lgt_write_entity_clauses'(Stream) :-
|
|
'$lgt_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_compiler_option'(iso_initialization_dir, true),
|
|
!,
|
|
findall(Clause, '$lgt_rclause_'(Clause), Clauses),
|
|
('$lgt_fentity_init_'(Call) ->
|
|
write_canonical(Stream, (:- initialization(('$lgt_assert_relation_clauses'(Clauses), Call))))
|
|
;
|
|
write_canonical(Stream, (:- initialization('$lgt_assert_relation_clauses'(Clauses))))),
|
|
write(Stream, '.'), nl(Stream).
|
|
|
|
'$lgt_write_init_call'(Stream) :-
|
|
findall(Clause, '$lgt_rclause_'(Clause), Clauses),
|
|
write_canonical(Stream, (:- initialization('$lgt_assert_relation_clauses'(Clauses)))),
|
|
write(Stream, '.'), nl(Stream),
|
|
('$lgt_fentity_init_'(Call) ->
|
|
write_canonical(Stream, (:- Call)),
|
|
write(Stream, '.'),
|
|
nl(Stream)
|
|
;
|
|
true).
|
|
|
|
|
|
|
|
% '$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_directive_'((dynamic(Functor/Arity))),
|
|
functor(Pred, Functor, Arity),
|
|
asserta(Pred),
|
|
retractall(Pred),
|
|
fail.
|
|
|
|
'$lgt_assert_directives' :-
|
|
'$lgt_directive_'((op(Priority, Specifier, Operators))),
|
|
op(Priority, Specifier, Operators),
|
|
fail.
|
|
|
|
'$lgt_assert_directives'.
|
|
|
|
|
|
|
|
'$lgt_assert_functors_clause' :-
|
|
'$lgt_entity_functors_'(Clause),
|
|
assertz(Clause).
|
|
|
|
|
|
|
|
'$lgt_assert_dcl_clauses' :-
|
|
'$lgt_dcl_'(Clause),
|
|
assertz(Clause),
|
|
fail.
|
|
|
|
'$lgt_assert_dcl_clauses'.
|
|
|
|
|
|
|
|
'$lgt_assert_def_clauses' :-
|
|
'$lgt_def_'(Clause),
|
|
assertz(Clause),
|
|
fail.
|
|
|
|
'$lgt_assert_def_clauses'.
|
|
|
|
|
|
|
|
'$lgt_assert_ddef_clauses' :-
|
|
'$lgt_ddef_'(Clause),
|
|
assertz(Clause),
|
|
fail.
|
|
|
|
'$lgt_assert_ddef_clauses'.
|
|
|
|
|
|
|
|
'$lgt_assert_super_clauses' :-
|
|
'$lgt_super_'(Clause),
|
|
assertz(Clause),
|
|
fail.
|
|
|
|
'$lgt_assert_super_clauses'.
|
|
|
|
|
|
|
|
'$lgt_assert_entity_clauses' :-
|
|
'$lgt_feclause_'(Clause),
|
|
assertz(Clause),
|
|
fail.
|
|
|
|
'$lgt_assert_entity_clauses'.
|
|
|
|
|
|
|
|
'$lgt_assert_relation_clauses' :-
|
|
'$lgt_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_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, _, _)).
|
|
|
|
|
|
'$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))).
|
|
|
|
|
|
|
|
% Logtalk directives
|
|
%
|
|
% '$lgt_lgt_directive'(+atom/+integer)
|
|
|
|
'$lgt_lgt_directive'(Directive) :-
|
|
'$lgt_lgt_opening_directive'(Directive).
|
|
|
|
'$lgt_lgt_directive'(Directive) :-
|
|
'$lgt_lgt_closing_directive'(Directive).
|
|
|
|
'$lgt_lgt_directive'(Directive) :-
|
|
'$lgt_lgt_entity_directive'(Directive).
|
|
|
|
'$lgt_lgt_directive'(Directive) :-
|
|
'$lgt_lgt_predicate_directive'(Directive).
|
|
|
|
|
|
'$lgt_lgt_opening_directive'(object/1).
|
|
'$lgt_lgt_opening_directive'(object/2).
|
|
'$lgt_lgt_opening_directive'(object/3).
|
|
'$lgt_lgt_opening_directive'(object/4).
|
|
'$lgt_lgt_opening_directive'(object/5).
|
|
|
|
'$lgt_lgt_opening_directive'(category/1).
|
|
'$lgt_lgt_opening_directive'(category/2).
|
|
|
|
'$lgt_lgt_opening_directive'(protocol/1).
|
|
'$lgt_lgt_opening_directive'(protocol/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.
|
|
|
|
'$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).
|
|
|
|
|
|
|
|
% built-in Prolog metapredicates
|
|
|
|
'$lgt_pl_metapredicate'(catch(::, *, ::)).
|
|
|
|
'$lgt_pl_metapredicate'(bagof(*, ::, *)).
|
|
'$lgt_pl_metapredicate'(setof(*, ::, *)).
|
|
'$lgt_pl_metapredicate'(findall(*, ::, *)).
|
|
|
|
'$lgt_pl_metapredicate'(forall(::, ::)).
|
|
|
|
'$lgt_pl_metapredicate'(call(::)).
|
|
'$lgt_pl_metapredicate'(once(::)).
|
|
|
|
'$lgt_pl_metapredicate'(\+ (::)).
|
|
|
|
|
|
|
|
% utility predicates used during compilation of Logtalk
|
|
% entities to store and access context information
|
|
|
|
'$lgt_context'(context(_, _, _, _, _)).
|
|
|
|
'$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_object_id'(@term)
|
|
|
|
'$lgt_valid_object_id'(Term) :-
|
|
once((atom(Term); compound(Term))).
|
|
|
|
|
|
|
|
% '$lgt_valid_category_id'(@term)
|
|
|
|
'$lgt_valid_category_id'(Term) :-
|
|
atom(Term).
|
|
|
|
|
|
|
|
% '$lgt_valid_protocol_id'(@term)
|
|
|
|
'$lgt_valid_protocol_id'(Term) :-
|
|
atom(Term).
|
|
|
|
|
|
|
|
% '$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_callable'(@term)
|
|
|
|
'$lgt_callable'(Term) :-
|
|
nonvar(Term),
|
|
functor(Term, Functor, _),
|
|
atom(Functor).
|
|
|
|
|
|
|
|
% '$lgt_valid_op_priority'(@term)
|
|
|
|
'$lgt_valid_op_priority'(Priority) :-
|
|
integer(Priority),
|
|
Priority >= 0,
|
|
Priority =< 1200.
|
|
|
|
|
|
|
|
% '$lgt_valid_op_specifier'(@term)
|
|
|
|
'$lgt_valid_op_specifier'(Specifier) :-
|
|
nonvar(Specifier),
|
|
once('$lgt_member'(Specifier, [fx, fy, xfx, xfy, yfx, xf, yf])).
|
|
|
|
|
|
|
|
% '$lgt_valid_op_names'(@term)
|
|
|
|
'$lgt_valid_op_names'(Operators) :-
|
|
nonvar(Operators),
|
|
'$lgt_convert_to_list'(Operators, List),
|
|
forall('$lgt_member'(Operator, List), atom(Operator)).
|
|
|
|
|
|
|
|
% '$lgt_valid_metapred_term'(@term)
|
|
|
|
'$lgt_valid_metapred_term'(Pred) :-
|
|
nonvar(Pred),
|
|
Pred =.. [_| Args],
|
|
forall('$lgt_member'(Arg, Args), (nonvar(Arg), (Arg = (::); Arg = (*)))).
|
|
|
|
|
|
|
|
% '$lgt_valid_mode_term'(@term)
|
|
|
|
'$lgt_valid_mode_term'(Pred) :-
|
|
nonvar(Pred),
|
|
Pred =.. [_| Args],
|
|
forall(
|
|
'$lgt_member'(Arg, Args),
|
|
(nonvar(Arg), functor(Arg, Functor, Arity), Arity =< 1, '$lgt_member'(Functor, [?, +, -, @]))).
|
|
|
|
|
|
|
|
% '$lgt_valid_number_of_solutions'(@term)
|
|
|
|
'$lgt_valid_number_of_solutions'(Solutions) :-
|
|
nonvar(Solutions),
|
|
once('$lgt_member'(Solutions, [zero, one, zero_or_one, zero_or_more, one_or_more, error])).
|
|
|
|
|
|
|
|
% '$lgt_valid_info_list'(@list)
|
|
%
|
|
% true if the argument is a list of key-value pairs
|
|
|
|
'$lgt_valid_info_list'([]).
|
|
|
|
'$lgt_valid_info_list'([Head| Tail]) :-
|
|
nonvar(Head),
|
|
Head = (Key is Value),
|
|
nonvar(Key),
|
|
nonvar(Value),
|
|
'$lgt_valid_info_list'(Tail).
|
|
|
|
|
|
|
|
% '$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'(named_anonymous_vars(Option)) :-
|
|
once((Option == on; Option == off)).
|
|
|
|
'$lgt_valid_compiler_option'(code_prefix(Prefix)) :-
|
|
atom(Prefix).
|
|
|
|
'$lgt_valid_compiler_option'(doctype(Option)) :-
|
|
once((Option == standalone; Option == local; Option == web)).
|
|
|
|
|
|
|
|
% '$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'(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'(named_anonymous_vars).
|
|
'$lgt_valid_flag'(code_prefix).
|
|
'$lgt_valid_flag'(doctype).
|
|
|
|
|
|
|
|
% '$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'(startup_message).
|
|
'$lgt_read_only_flag'(version).
|
|
|
|
|
|
|
|
% 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(_, _)).
|
|
|
|
|
|
|
|
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
%
|
|
% 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'(doctype, Doctype),
|
|
'$lgt_write_xml_header'(Doctype, Stream).
|
|
|
|
|
|
|
|
'$lgt_write_xml_header'(local, Stream) :-
|
|
'$lgt_write_xml_open_tag'(Stream, '?xml version="1.0"?', []),
|
|
write(Stream, '<!DOCTYPE logtalk SYSTEM "logtalk.dtd">'), 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, Stream) :-
|
|
'$lgt_write_xml_open_tag'(Stream, '?xml version="1.0"?', []),
|
|
write(Stream, '<!DOCTYPE logtalk SYSTEM "http://www.logtalk.org/xml/1.0/logtalk.dtd">'), 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_entity_'(Type, Entity, _, _),
|
|
('$lgt_entity_comp_mode_'((dynamic)) -> Compilation = (dynamic); Compilation = static),
|
|
'$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_info_'(List) ->
|
|
('$lgt_member'(comment is Comment, List) ->
|
|
'$lgt_write_xml_cdata_element'(Stream, comment, [], Comment)
|
|
;
|
|
true),
|
|
('$lgt_member'(authors is Authors, List) ->
|
|
'$lgt_write_xml_cdata_element'(Stream, authors, [], Authors)
|
|
;
|
|
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, authors, 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_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_public_'(Functor/Arity),
|
|
'$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_protected_'(Functor/Arity),
|
|
'$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_private_'(Functor/Arity),
|
|
'$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_entity_comp_mode_'((dynamic)); '$lgt_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_metapredicate_'(Meta) ->
|
|
'$lgt_write_xml_cdata_element'(Stream, meta, [], Meta)
|
|
;
|
|
true),
|
|
functor(Template, Functor, Arity),
|
|
forall(
|
|
'$lgt_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_info_'(Functor/Arity, List), '$lgt_member'(comment is Comment, List)) ->
|
|
'$lgt_write_xml_cdata_element'(Stream, comment, [], Comment)
|
|
;
|
|
true),
|
|
(('$lgt_info_'(Functor/Arity, List), '$lgt_member'(argnames is Names, List)) ->
|
|
Template =.. [Functor| Names],
|
|
'$lgt_write_xml_cdata_element'(Stream, template, [], Template)
|
|
;
|
|
true),
|
|
forall(
|
|
('$lgt_info_'(Functor/Arity, List),
|
|
'$lgt_member'(Key is Value, List),
|
|
\+ '$lgt_member'(Key, [comment, argnames])),
|
|
('$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_rclause_'('$lgt_implements_protocol_'(Entity, Ptc, Scope)),
|
|
'$lgt_write_xml_relation'(Stream, Entity, Ptc, implements, Scope),
|
|
fail.
|
|
|
|
'$lgt_write_xml_relations'(Stream) :-
|
|
'$lgt_rclause_'('$lgt_imports_category_'(Entity, Ctg, Scope)),
|
|
'$lgt_write_xml_relation'(Stream, Entity, Ctg, imports, Scope),
|
|
fail.
|
|
|
|
'$lgt_write_xml_relations'(Stream) :-
|
|
'$lgt_rclause_'('$lgt_extends_object_'(Entity, Parent, Scope)),
|
|
'$lgt_write_xml_relation'(Stream, Entity, Parent, extends, Scope),
|
|
fail.
|
|
|
|
'$lgt_write_xml_relations'(Stream) :-
|
|
'$lgt_rclause_'('$lgt_instantiates_class_'(Entity, Class, Scope)),
|
|
'$lgt_write_xml_relation'(Stream, Entity, Class, instantiates, Scope),
|
|
fail.
|
|
|
|
'$lgt_write_xml_relations'(Stream) :-
|
|
'$lgt_rclause_'('$lgt_specializes_class_'(Entity, Superclass, Scope)),
|
|
'$lgt_write_xml_relation'(Stream, Entity, Superclass, specializes, Scope),
|
|
fail.
|
|
|
|
'$lgt_write_xml_relations'(Stream) :-
|
|
'$lgt_rclause_'('$lgt_extends_protocol_'(Entity, Ptc, Scope)),
|
|
'$lgt_write_xml_relation'(Stream, Entity, Ptc, extends, Scope),
|
|
fail.
|
|
|
|
'$lgt_write_xml_relations'(Stream) :-
|
|
'$lgt_entity_'(_, Entity, _, _),
|
|
'$lgt_uses_'(Obj),
|
|
'$lgt_write_xml_relation'(Stream, Entity, Obj, uses),
|
|
fail.
|
|
|
|
'$lgt_write_xml_relations'(Stream) :-
|
|
'$lgt_entity_'(_, Entity, _, _),
|
|
'$lgt_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['),
|
|
write(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 defined predicates
|
|
%
|
|
% used in portability checking
|
|
%
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
|
|
|
|
'$lgt_iso_def_pred'(true).
|
|
'$lgt_iso_def_pred'(fail).
|
|
'$lgt_iso_def_pred'(call(_)).
|
|
'$lgt_iso_def_pred'(!).
|
|
'$lgt_iso_def_pred'((_; _)).
|
|
'$lgt_iso_def_pred'((_, _)).
|
|
'$lgt_iso_def_pred'((_ -> _)).
|
|
'$lgt_iso_def_pred'((_ -> _; _)).
|
|
'$lgt_iso_def_pred'(catch(_, _, _)).
|
|
'$lgt_iso_def_pred'(throw(_)).
|
|
|
|
'$lgt_iso_def_pred'((_ = _)).
|
|
'$lgt_iso_def_pred'((_ \= _)).
|
|
'$lgt_iso_def_pred'(unify_with_occurs_check(_, _)).
|
|
|
|
'$lgt_iso_def_pred'(var(_)).
|
|
'$lgt_iso_def_pred'(nonvar(_)).
|
|
'$lgt_iso_def_pred'(atom(_)).
|
|
'$lgt_iso_def_pred'(atomic(_)).
|
|
'$lgt_iso_def_pred'(number(_)).
|
|
'$lgt_iso_def_pred'(integer(_)).
|
|
'$lgt_iso_def_pred'(float(_)).
|
|
'$lgt_iso_def_pred'(compound(_)).
|
|
|
|
'$lgt_iso_def_pred'((_ @=< _)).
|
|
'$lgt_iso_def_pred'((_ @< _)).
|
|
'$lgt_iso_def_pred'((_ @>= _)).
|
|
'$lgt_iso_def_pred'((_ @> _)).
|
|
'$lgt_iso_def_pred'((_ == _)).
|
|
'$lgt_iso_def_pred'((_ \== _)).
|
|
|
|
'$lgt_iso_def_pred'(functor(_, _, _)).
|
|
'$lgt_iso_def_pred'(arg(_, _, _)).
|
|
'$lgt_iso_def_pred'(_ =.. _).
|
|
'$lgt_iso_def_pred'(copy_term(_, _)).
|
|
|
|
'$lgt_iso_def_pred'(_ is _).
|
|
|
|
'$lgt_iso_def_pred'((_ =< _)).
|
|
'$lgt_iso_def_pred'((_ < _)).
|
|
'$lgt_iso_def_pred'((_ >= _)).
|
|
'$lgt_iso_def_pred'((_ > _)).
|
|
'$lgt_iso_def_pred'((_ =:= _)).
|
|
'$lgt_iso_def_pred'((_ =\= _)).
|
|
|
|
'$lgt_iso_def_pred'(clause(_, _)).
|
|
'$lgt_iso_def_pred'(current_predicate(_)).
|
|
|
|
'$lgt_iso_def_pred'(asserta(_)).
|
|
'$lgt_iso_def_pred'(assertz(_)).
|
|
'$lgt_iso_def_pred'(retract(_)).
|
|
'$lgt_iso_def_pred'(abolish(_)).
|
|
|
|
'$lgt_iso_def_pred'(findall(_, _, _)).
|
|
'$lgt_iso_def_pred'(bagof(_, _, _)).
|
|
'$lgt_iso_def_pred'(setof(_, _, _)).
|
|
|
|
'$lgt_iso_def_pred'(current_input(_)).
|
|
'$lgt_iso_def_pred'(current_output(_)).
|
|
'$lgt_iso_def_pred'(set_input(_)).
|
|
'$lgt_iso_def_pred'(set_output(_)).
|
|
'$lgt_iso_def_pred'(open(_, _, _, _)).
|
|
'$lgt_iso_def_pred'(open(_, _, _)).
|
|
'$lgt_iso_def_pred'(close(_, _)).
|
|
'$lgt_iso_def_pred'(close(_)).
|
|
'$lgt_iso_def_pred'(flush_output(_)).
|
|
'$lgt_iso_def_pred'(flush_output).
|
|
'$lgt_iso_def_pred'(stream_property(_, _)).
|
|
'$lgt_iso_def_pred'(at_end_of_stream).
|
|
'$lgt_iso_def_pred'(at_end_of_stream(_)).
|
|
'$lgt_iso_def_pred'(set_stream_position(_, _)).
|
|
|
|
'$lgt_iso_def_pred'(get_char(_, _)).
|
|
'$lgt_iso_def_pred'(get_char(_)).
|
|
'$lgt_iso_def_pred'(get_code(_, _)).
|
|
'$lgt_iso_def_pred'(get_code(_)).
|
|
'$lgt_iso_def_pred'(peek_char(_, _)).
|
|
'$lgt_iso_def_pred'(peek_char(_)).
|
|
'$lgt_iso_def_pred'(peek_code(_, _)).
|
|
'$lgt_iso_def_pred'(peek_code(_)).
|
|
'$lgt_iso_def_pred'(put_char(_, _)).
|
|
'$lgt_iso_def_pred'(put_char(_)).
|
|
'$lgt_iso_def_pred'(put_code(_, _)).
|
|
'$lgt_iso_def_pred'(put_code(_)).
|
|
'$lgt_iso_def_pred'(nl).
|
|
'$lgt_iso_def_pred'(nl(_)).
|
|
|
|
'$lgt_iso_def_pred'(get_byte(_, _)).
|
|
'$lgt_iso_def_pred'(get_byte(_)).
|
|
'$lgt_iso_def_pred'(peek_byte(_, _)).
|
|
'$lgt_iso_def_pred'(peek_byte(_)).
|
|
'$lgt_iso_def_pred'(put_byte(_, _)).
|
|
'$lgt_iso_def_pred'(put_byte(_)).
|
|
|
|
'$lgt_iso_def_pred'(read_term(_, _, _)).
|
|
'$lgt_iso_def_pred'(read_term(_, _)).
|
|
'$lgt_iso_def_pred'(read(_)).
|
|
'$lgt_iso_def_pred'(read(_, _)).
|
|
'$lgt_iso_def_pred'(write_term(_, _, _)).
|
|
'$lgt_iso_def_pred'(write_term(_, _)).
|
|
'$lgt_iso_def_pred'(write(_)).
|
|
'$lgt_iso_def_pred'(write(_, _)).
|
|
'$lgt_iso_def_pred'(writeq(_)).
|
|
'$lgt_iso_def_pred'(writeq(_, _)).
|
|
'$lgt_iso_def_pred'(write_canonical(_)).
|
|
'$lgt_iso_def_pred'(write_canonical(_, _)).
|
|
'$lgt_iso_def_pred'(op(_, _, _)).
|
|
'$lgt_iso_def_pred'(current_op(_, _, _)).
|
|
'$lgt_iso_def_pred'(char_conversion(_, _)).
|
|
'$lgt_iso_def_pred'(current_char_conversion(_, _)).
|
|
|
|
'$lgt_iso_def_pred'(\+ _).
|
|
'$lgt_iso_def_pred'(once(_)).
|
|
'$lgt_iso_def_pred'(repeat).
|
|
|
|
'$lgt_iso_def_pred'(atom_length(_, _)).
|
|
'$lgt_iso_def_pred'(atom_concat(_, _, _)).
|
|
'$lgt_iso_def_pred'(sub_atom(_, _, _, _, _)).
|
|
'$lgt_iso_def_pred'(atom_chars(_, _)).
|
|
'$lgt_iso_def_pred'(atom_codes(_, _)).
|
|
'$lgt_iso_def_pred'(char_code(_, _)).
|
|
'$lgt_iso_def_pred'(number_chars(_, _)).
|
|
'$lgt_iso_def_pred'(number_codes(_, _)).
|
|
|
|
'$lgt_iso_def_pred'(set_prolog_flag(_, _)).
|
|
'$lgt_iso_def_pred'(current_prolog_flag(_, _)).
|
|
'$lgt_iso_def_pred'(halt).
|
|
'$lgt_iso_def_pred'(halt(_)).
|
|
|
|
|
|
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
%
|
|
% Logtalk banner
|
|
%
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
|
|
|
|
'$lgt_startup_message' :-
|
|
'$lgt_default_flag'(startup_message, on) ->
|
|
'$lgt_banner',
|
|
'$lgt_default_flags'
|
|
;
|
|
true.
|
|
|
|
|
|
|
|
'$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-2002 Paulo Moura'), nl, nl.
|
|
|
|
|
|
|
|
'$lgt_default_flags' :-
|
|
write('Default compilation flags:'), nl,
|
|
'$lgt_default_flag'(iso_initialization_dir, ISO),
|
|
write(' ISO initialization/1 directive (iso_initialization_dir): '), write(ISO), nl,
|
|
'$lgt_default_flag'(xml, XML),
|
|
write(' XML documenting files (xml): '), write(XML), nl,
|
|
'$lgt_default_flag'(doctype, Doctype),
|
|
write(' XML doctype reference (doctype): '), write(Doctype), nl,
|
|
'$lgt_default_flag'(xsl, XSL),
|
|
write(' XSL stylesheet (xsl): '), write(XSL), nl,
|
|
'$lgt_default_flag'(unknown, Unknown),
|
|
write(' Unknown entities (unknown): '), write(Unknown), nl,
|
|
'$lgt_default_flag'(misspelt, Misspelt),
|
|
write(' Misspelt predicates (misspelt): '), write(Misspelt), nl,
|
|
'$lgt_default_flag'(singletons, Singletons),
|
|
write(' Singletons variables (singletons): '), write(Singletons), nl,
|
|
'$lgt_default_flag'(lgtredef, Lgtredef),
|
|
write(' Logtalk built-ins redefinition (lgtredef): '), write(Lgtredef), nl,
|
|
'$lgt_default_flag'(plredef, Plredef),
|
|
write(' Prolog built-ins redefinition (plredef): '), write(Plredef), nl,
|
|
'$lgt_default_flag'(portability, Portability),
|
|
write(' Non portable calls (portability): '), write(Portability), nl,
|
|
'$lgt_default_flag'(report, Report),
|
|
write(' Compilation report (report): '), write(Report), nl,
|
|
'$lgt_default_flag'(named_anonymous_vars, Named),
|
|
write(' Named anonymous variables (named_anonymous_vars): '), write(Named), nl,
|
|
'$lgt_default_flag'(code_prefix, Code),
|
|
write(' Compiled code functors prefix (code_prefix): '), writeq(Code), nl,
|
|
'$lgt_default_flag'(smart_compilation, Smart),
|
|
write(' Smart compilation (smart_compilation): '), write(Smart), nl, nl.
|
|
|
|
|
|
|
|
:- initialization('$lgt_startup_message').
|
|
|
|
|
|
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
%
|
|
% end!
|
|
%
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|