cc4531cd1e
git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@53 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
5133 lines
135 KiB
Prolog
5133 lines
135 KiB
Prolog
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
%
|
|
% Logtalk - Object oriented extension to Prolog
|
|
% Release 2.8.4
|
|
%
|
|
% Copyright (c) 1998-2001 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
|
|
%
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
|
|
|
|
|
|
% 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)
|
|
|
|
|
|
|
|
% 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 declarations
|
|
|
|
:- dynamic(lgt_dcl_/1). % lgt_dcl_(Clause)
|
|
:- dynamic(lgt_def_/1). % lgt_def_(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, SDcl, SDef, 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, SDcl, SDef, DDcl, DDef, Scope)
|
|
:- dynamic(lgt_instantiated_class_/10). % lgt_instantiated_class_(Class, Prefix, Dcl, Def, Super, SDcl, SDef, DDcl, DDef, Scope)
|
|
:- dynamic(lgt_specialized_class_/10). % lgt_specialized_class_(Superclass, Prefix, Dcl, Def, Super, SDcl, SDef, 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)
|
|
|
|
|
|
|
|
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
%
|
|
% top level runtime predicate
|
|
%
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
|
|
|
|
|
|
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(Dirs),
|
|
lgt_tr_clauses(Clauses),
|
|
lgt_fix_redef_built_ins,
|
|
lgt_gen_object_clauses,
|
|
lgt_gen_object_directives,
|
|
lgt_assert_tr_entity.
|
|
|
|
|
|
|
|
% create_category(+category_identifier, +list, +list, +list)
|
|
|
|
create_category(Ctg, Rels, Dirs, Clauses) :-
|
|
var(Ctg),
|
|
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(Dirs),
|
|
lgt_tr_clauses(Clauses),
|
|
lgt_fix_redef_built_ins,
|
|
lgt_gen_category_clauses,
|
|
lgt_gen_category_directives,
|
|
lgt_assert_tr_entity.
|
|
|
|
|
|
|
|
% create_protocol(+protocol_identifier, +list, +list)
|
|
|
|
create_protocol(Ptc, Rels, Dirs) :-
|
|
var(Ptc),
|
|
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(Dirs),
|
|
lgt_gen_protocol_clauses,
|
|
lgt_gen_protocol_directives,
|
|
lgt_assert_tr_entity.
|
|
|
|
|
|
|
|
% abolish_object(@object_identifier)
|
|
|
|
abolish_object(Obj) :-
|
|
var(Obj),
|
|
throw(error(instantiation_error, abolish_object(Obj))).
|
|
|
|
abolish_object(Obj) :-
|
|
\+ 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, SDcl, SDef, 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(SDcl/6),
|
|
abolish(SDef/6),
|
|
abolish(DDcl/4),
|
|
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(entity_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(entity_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(entity_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(entity_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(entity_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(entity_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_default_compiler_option(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)),
|
|
Error,
|
|
throw(error(Error, logtalk_compile(Entities, Options)))),
|
|
lgt_set_compiler_options(Options),
|
|
lgt_compile_entities(Entities).
|
|
|
|
|
|
|
|
% 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(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 load 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 load 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)),
|
|
Error,
|
|
throw(error(Error, logtalk_load(Entities, Options)))),
|
|
lgt_set_compiler_options(Options),
|
|
lgt_load_entities(Entities).
|
|
|
|
|
|
|
|
% logtalk_version(?integer, ?integer, ?integer)
|
|
|
|
logtalk_version(Major, Minor, Patch) :-
|
|
nonvar(Major),
|
|
\+ integer(Major),
|
|
throw(error(type_error(integer, Major), logtalk_version(Major, Minor, Patch))).
|
|
|
|
logtalk_version(Major, Minor, Patch) :-
|
|
nonvar(Minor),
|
|
\+ integer(Minor),
|
|
throw(error(type_error(integer, Minor), logtalk_version(Major, Minor, Patch))).
|
|
|
|
logtalk_version(Major, Minor, Patch) :-
|
|
nonvar(Patch),
|
|
\+ integer(Patch),
|
|
throw(error(type_error(integer, Patch), logtalk_version(Major, Minor, Patch))).
|
|
|
|
logtalk_version(2, 8, 4).
|
|
|
|
|
|
|
|
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
%
|
|
% built-in methods
|
|
%
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
|
|
|
|
|
|
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 predicates and predicates that have been redeclared
|
|
|
|
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).
|
|
|
|
|
|
|
|
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).
|
|
|
|
lgt_scope(private, p).
|
|
lgt_scope(protected, p(p)).
|
|
lgt_scope((public), p(p(p))).
|
|
|
|
|
|
|
|
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, _) :-
|
|
(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, _) :-
|
|
\+ lgt_current_object_(Obj, _, _, _, _),
|
|
throw(error(existence_error(object, Obj), Obj::abolish(Functor/Arity), Sender)).
|
|
|
|
lgt_abolish(Obj, Functor/Arity, Sender, Scope) :-
|
|
functor(Pred, Functor, Arity),
|
|
lgt_current_object_(Obj, Prefix, _, _, _),
|
|
lgt_once(Prefix, Dcl, _, _, _, _, DDcl, DDef),
|
|
(lgt_once(Dcl, Pred, PScope, Type, _, SContainer, _) ->
|
|
(Type = (dynamic) ->
|
|
((\+ \+ PScope = Scope; Sender = SContainer) ->
|
|
(lgt_once(DDcl, Pred, _, _, _) ->
|
|
(lgt_once(DDef, Pred, _, _, _, Call) ->
|
|
functor(Call, CFunctor, CArity),
|
|
abolish(CFunctor/CArity),
|
|
Clause =.. [DDef, Pred, _, _, _, Call],
|
|
retractall(Clause)
|
|
;
|
|
true),
|
|
Clause2 =.. [DDcl, Pred, _, _, _],
|
|
retractall(Clause2)
|
|
;
|
|
throw(error(permission_error(modify, predicate_declaration, 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(permission_error(modify, static_predicate, Pred), Obj::abolish(Functor/Arity), Sender)))
|
|
;
|
|
throw(error(existence_error(predicate_declaration, Pred), Obj::abolish(Functor/Arity), Sender))).
|
|
|
|
|
|
|
|
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_assert_dynamic_dcl_clause(Head, DDcl)),
|
|
(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_dynamic_def_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),
|
|
Head =.. [_| Args],
|
|
Meta =.. [_| MArgs],
|
|
lgt_extract_metavars(Args, MArgs, 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_assert_dynamic_dcl_clause(Head, DDcl)),
|
|
(Type = (dynamic) ->
|
|
((\+ \+ PScope = Scope; Sender = SContainer) ->
|
|
((lgt_once(Def, Head, _, _, _, Call); lgt_once(DDef, Head, _, _, _, Call)) ->
|
|
true
|
|
;
|
|
functor(Head, Functor, Arity),
|
|
lgt_assert_dynamic_def_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))).
|
|
|
|
|
|
|
|
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_assert_dynamic_dcl_clause(Head, DDcl)),
|
|
(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_dynamic_def_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),
|
|
Head =.. [_| Args],
|
|
Meta =.. [_| MArgs],
|
|
lgt_extract_metavars(Args, MArgs, 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_assert_dynamic_dcl_clause(Head, DDcl)),
|
|
(Type = (dynamic) ->
|
|
((\+ \+ PScope = Scope; Sender = SContainer) ->
|
|
((lgt_once(Def, Head, _, _, _, Call); lgt_once(DDef, Head, _, _, _, Call)) ->
|
|
true
|
|
;
|
|
functor(Head, Functor, Arity),
|
|
lgt_assert_dynamic_def_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))).
|
|
|
|
|
|
|
|
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))).
|
|
|
|
|
|
|
|
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); lgt_once(DDef, Head, _, _, _, Call)) ->
|
|
TBody = (lgt_tr_body(Body, _, _), _),
|
|
retract((Call:-TBody))
|
|
;
|
|
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); lgt_once(DDef, Head, _, _, _, Call)) ->
|
|
retract(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))).
|
|
|
|
|
|
|
|
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); lgt_once(DDef, Head, _, _, _, Call)) ->
|
|
retractall(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(Self, Pred, This) :-
|
|
nonvar(Pred) ->
|
|
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))))
|
|
;
|
|
throw(error(instantiation_error, Self::Pred, This)).
|
|
|
|
|
|
|
|
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(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(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(Self, Pred, This, Sender) :-
|
|
nonvar(Pred) ->
|
|
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))))
|
|
;
|
|
throw(error(instantiation_error, ^^Pred, This)).
|
|
|
|
|
|
|
|
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)))).
|
|
|
|
|
|
|
|
% 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)).
|
|
|
|
|
|
|
|
% 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 entities
|
|
%
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
|
|
|
|
|
|
% built-in pseudo-object user (representing the Prolog database)
|
|
|
|
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)
|
|
|
|
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)
|
|
|
|
lgt_load_entities([]).
|
|
|
|
lgt_load_entities([Entity| Entities]) :-
|
|
lgt_load_entity(Entity),
|
|
lgt_load_entities(Entities).
|
|
|
|
|
|
|
|
% lgt_load_entity(+atom)
|
|
|
|
lgt_load_entity(Entity) :-
|
|
lgt_compile_entity(Entity),
|
|
lgt_file_name(prolog, Entity, File),
|
|
lgt_load_prolog_code(File),
|
|
(lgt_compiler_option(report, on) ->
|
|
writeq(Entity),
|
|
lgt_entity_(Type, _, _, _),
|
|
write(' '), write(Type), write(' loaded'), nl
|
|
;
|
|
true).
|
|
|
|
|
|
|
|
% lgt_compile_entities(+list)
|
|
|
|
lgt_compile_entities([]).
|
|
|
|
lgt_compile_entities([Entity| Entities]) :-
|
|
lgt_compile_entity(Entity),
|
|
lgt_compile_entities(Entities).
|
|
|
|
|
|
|
|
% lgt_compile_entity(+atom)
|
|
|
|
lgt_compile_entity(Entity) :-
|
|
lgt_tr_entity(Entity),
|
|
lgt_write_tr_entity(Entity),
|
|
lgt_write_entity_doc(Entity).
|
|
|
|
|
|
|
|
% lgt_write_tr_entity(+atom)
|
|
|
|
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)
|
|
|
|
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)
|
|
|
|
lgt_file_name(Type, Entity, File) :-
|
|
lgt_file_extension(Type, Extension),
|
|
atom_concat(Entity, Extension, File).
|
|
|
|
|
|
|
|
% lgt_tr_entity(+atom)
|
|
|
|
lgt_tr_entity(Entity) :-
|
|
lgt_clean_up,
|
|
lgt_file_name(logtalk, Entity, File),
|
|
catch(
|
|
open(File, read, Stream),
|
|
Error,
|
|
lgt_compiler_error_handler(Stream, Error)),
|
|
catch(
|
|
(read_term(Stream, Term, [singletons(Singletons)]),
|
|
lgt_report_singletons(Singletons, 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(_, end_of_file) :-
|
|
!.
|
|
|
|
lgt_tr_file(Stream, Term) :-
|
|
lgt_tr_term(Term),
|
|
read_term(Stream, Next, [singletons(Singletons)]),
|
|
lgt_report_singletons(Singletons, Next),
|
|
lgt_tr_file(Stream, Next).
|
|
|
|
|
|
|
|
% lgt_report_singletons(+list, +term)
|
|
|
|
lgt_report_singletons([], _).
|
|
|
|
lgt_report_singletons([Singleton| Singletons], Term) :-
|
|
lgt_compiler_option(singletons, warning) ->
|
|
write('Logtalk compiler warning!'), nl,
|
|
\+ \+ ( lgt_report_singletons_aux([Singleton| Singletons], Term, Names),
|
|
write(' singleton variable(s): '), write(Names), nl,
|
|
write(' in term: '), write(Term), nl,
|
|
(lgt_entity_(Type, Entity, _, _) ->
|
|
write(' inside '), write(Type), write(': '),
|
|
writeq(Entity), nl
|
|
;
|
|
true))
|
|
;
|
|
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(Stream, Error) :-
|
|
(nonvar(Stream) ->
|
|
close(Stream)
|
|
;
|
|
true),
|
|
lgt_report_compiler_error(Error),
|
|
fail.
|
|
|
|
|
|
|
|
lgt_report_compiler_error(invalid_directive_arg(Error, Cause, Dir)) :-
|
|
!,
|
|
write('Logtalk compiler error!'), nl,
|
|
write(' invalid argument in directive: '),
|
|
writeq((:-Dir)), nl,
|
|
write(' '), write(Error), write(': '), write(Cause), nl,
|
|
(lgt_entity_(Type, Entity, _, _) ->
|
|
write(' inside '), write(Type), write(': '),
|
|
writeq(Entity), nl
|
|
;
|
|
true).
|
|
|
|
lgt_report_compiler_error(invalid_directive(Error, Dir)) :-
|
|
!,
|
|
write('Logtalk compiler error!'), nl,
|
|
write(' invalid or unsupported directive: '),
|
|
writeq((:-Dir)), nl,
|
|
write(' '), write(Error), nl,
|
|
(lgt_entity_(Type, Entity, _, _) ->
|
|
write(' inside '), write(Type), write(': '),
|
|
writeq(Entity), nl
|
|
;
|
|
true).
|
|
|
|
lgt_report_compiler_error(invalid_clause(Error, Cause, Clause)) :-
|
|
!,
|
|
write('Logtalk compiler error!'), nl,
|
|
write(' invalid clause: '),
|
|
writeq(Clause), nl,
|
|
write(' '), write(Error), write(': '), write(Cause), nl,
|
|
(lgt_entity_(Type, Entity, _, _) ->
|
|
write(' inside '), write(Type), write(': '),
|
|
writeq(Entity), nl
|
|
;
|
|
true).
|
|
|
|
lgt_report_compiler_error(invalid_clause(Error, Clause)) :-
|
|
!,
|
|
write('Logtalk compiler error!'), nl,
|
|
write(' invalid clause: '),
|
|
writeq(Clause), nl,
|
|
write(' '), write(Error), nl,
|
|
(lgt_entity_(Type, Entity, _, _) ->
|
|
write(' inside '), write(Type), write(': '),
|
|
writeq(Entity), nl
|
|
;
|
|
true).
|
|
|
|
lgt_report_compiler_error(invalid_clause(Clause)) :-
|
|
!,
|
|
write('Logtalk compiler error!'), nl,
|
|
write(' could not translate clause: '),
|
|
writeq(Clause), nl,
|
|
(lgt_entity_(Type, Entity, _, _) ->
|
|
write(' inside '), write(Type), write(': '),
|
|
writeq(Entity), nl
|
|
;
|
|
true).
|
|
|
|
lgt_report_compiler_error(Error) :-
|
|
write('Logtalk compiler error!'), nl,
|
|
write(' '), writeq(Error), nl,
|
|
(lgt_entity_(Type, Entity, _, _) ->
|
|
write(' inside '), write(Type), write(': '),
|
|
writeq(Entity), nl
|
|
;
|
|
true).
|
|
|
|
|
|
|
|
% 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_def_(_)),
|
|
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_(_)).
|
|
|
|
|
|
|
|
% dump all dynamic predicates used during entity compilation
|
|
% in the current ouput stream (just a debugging utility)
|
|
|
|
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_def_/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).
|
|
|
|
|
|
|
|
% lgt_tr_terms(+list)
|
|
|
|
lgt_tr_terms([]).
|
|
|
|
lgt_tr_terms([Term| Terms]) :-
|
|
lgt_tr_term(Term),
|
|
lgt_tr_terms(Terms).
|
|
|
|
|
|
|
|
% lgt_tr_term(+term)
|
|
|
|
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)
|
|
|
|
lgt_tr_directives([]).
|
|
|
|
lgt_tr_directives([Dir| Dirs]) :-
|
|
lgt_tr_directive(Dir),
|
|
lgt_tr_directives(Dirs).
|
|
|
|
|
|
|
|
% lgt_tr_directive(+term)
|
|
|
|
lgt_tr_directive(Dir) :-
|
|
var(Dir),
|
|
throw(invalid_directive(instantiation_error, 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(invalid_directive(unmatched_directive_error, 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),
|
|
directive_error(Error, Cause),
|
|
throw(invalid_directive_arg(Error, Cause, Dir))),
|
|
!.
|
|
|
|
lgt_tr_directive(Dir) :-
|
|
throw(invalid_directive(unknown_directive_error, Dir)).
|
|
|
|
|
|
|
|
% lgt_tr_directive(+atom, +list)
|
|
|
|
|
|
lgt_tr_directive(object, [Obj| Rels]) :-
|
|
lgt_valid_object_id(Obj) ->
|
|
lgt_tr_object_id(Obj),
|
|
lgt_tr_object_relations(Rels, Obj)
|
|
;
|
|
throw(directive_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(directive_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(directive_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(directive_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(directive_error(operator_name, Operators)))
|
|
;
|
|
throw(directive_error(operator_specifier, Specifier)))
|
|
;
|
|
throw(directive_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) ->
|
|
assertz(lgt_uses_(Obj))
|
|
;
|
|
throw(directive_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) ->
|
|
assertz(lgt_calls_(Ptc))
|
|
;
|
|
throw(directive_error(protocol_identifier, Ptc)))).
|
|
|
|
|
|
lgt_tr_directive(info, [List]) :-
|
|
!,
|
|
(lgt_valid_info_list(List) ->
|
|
assertz(lgt_info_(List))
|
|
;
|
|
throw(directive_error(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(directive_error(type_error(info_list), List)))
|
|
;
|
|
throw(directive_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(directive_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(directive_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(directive_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(directive_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(directive_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(directive_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(directive_error(number_of_solutions, Solutions)))
|
|
;
|
|
throw(directive_error(mode_term, Mode)).
|
|
|
|
|
|
|
|
% lgt_tr_object_relations(+list, +term)
|
|
|
|
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(directive_error(relation_clause, Functor))).
|
|
|
|
|
|
|
|
% lgt_tr_object_relation(+atom, +list, +term)
|
|
|
|
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)
|
|
|
|
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)
|
|
|
|
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)
|
|
|
|
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)
|
|
|
|
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_(_, _, Prefix, _),
|
|
lgt_prefix(Context, Prefix),
|
|
catch(
|
|
lgt_tr_clause(Clause, TClause, Context),
|
|
clause_error(Error, Cause),
|
|
throw(invalid_clause(Error, Cause, Clause))),
|
|
assertz(lgt_eclause_(TClause)),
|
|
!.
|
|
|
|
lgt_tr_clause(Clause) :-
|
|
throw(invalid_clause(Clause)).
|
|
|
|
|
|
|
|
% lgt_tr_clause(+clause, +clause, +term)
|
|
|
|
lgt_tr_clause((Head:-Body), (THead:-TBody), Context) :-
|
|
!,
|
|
lgt_extract_metavars(Head, Metavars),
|
|
lgt_metavars(Context, Metavars),
|
|
lgt_tr_head(Head, THead, Context),
|
|
lgt_tr_body(Body, Body2, Context),
|
|
lgt_simplify_body(Body2, TBody).
|
|
|
|
lgt_tr_clause(Fact, TFact, Context) :-
|
|
lgt_tr_head(Fact, TFact, Context).
|
|
|
|
|
|
|
|
% lgt_tr_head(+callable, -callable, +term)
|
|
|
|
lgt_tr_head(Head, _, _) :-
|
|
lgt_built_in_method(Head, _),
|
|
functor(Head, Functor, Arity),
|
|
throw(clause_error(built_in_method_redef_error, Functor/Arity)).
|
|
|
|
lgt_tr_head(Head, _, _) :-
|
|
lgt_lgt_built_in(Head),
|
|
lgt_compiler_option(lgtredef, warning),
|
|
\+ lgt_redefined_built_in_(Head, _, _), % not already reported?
|
|
functor(Head, Functor, Arity),
|
|
lgt_entity_(Type, Entity, _, _),
|
|
write('Logtalk compiler warning!'), nl,
|
|
write(' redefining a Logtalk built-in predicate: '),
|
|
writeq(Functor/Arity), nl,
|
|
write(' inside '), write(Type), write(': '),
|
|
writeq(Entity), nl,
|
|
fail.
|
|
|
|
lgt_tr_head(Head, _, _) :-
|
|
lgt_pl_built_in(Head),
|
|
lgt_compiler_option(plredef, warning),
|
|
\+ lgt_redefined_built_in_(Head, _, _), % not already reported?
|
|
functor(Head, Functor, Arity),
|
|
lgt_entity_(Type, Entity, _, _),
|
|
write('Logtalk compiler warning!'), nl,
|
|
write(' redefining a Prolog built-in predicate: '),
|
|
writeq(Functor/Arity), nl,
|
|
write(' inside '), write(Type), write(': '),
|
|
writeq(Entity), nl,
|
|
fail.
|
|
|
|
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_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)
|
|
|
|
|
|
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)).
|
|
|
|
|
|
lgt_tr_body({Pred}, Pred, _) :-
|
|
!.
|
|
|
|
|
|
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
|
|
|
|
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),
|
|
!.
|
|
|
|
|
|
% pre-defined methods
|
|
|
|
lgt_tr_body(parameter(Arg, Value), arg(Arg, This, Value), Context) :-
|
|
lgt_this(Context, This),
|
|
!.
|
|
|
|
|
|
% Logtalk and Prolog built-in predicates
|
|
|
|
lgt_tr_body(Pred, lgt_call_built_in(Pred, Context), Context) :-
|
|
lgt_built_in(Pred),
|
|
!.
|
|
|
|
|
|
lgt_tr_body(Pred, _, _) :-
|
|
\+ lgt_callable(Pred),
|
|
throw(clause_error(callable, Pred)).
|
|
|
|
|
|
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(Obj, Pred, TPred, Context) :-
|
|
nonvar(Obj),
|
|
(Obj = (_, _); Obj = (_; _)),
|
|
!,
|
|
lgt_tr_msg_broadcasting(Obj, Pred, TPred, Context).
|
|
|
|
lgt_tr_msg(Obj, _, _, _) :-
|
|
nonvar(Obj),
|
|
\+ lgt_valid_object_id(Obj),
|
|
!,
|
|
throw(clause_error(object_identifier, Obj)).
|
|
|
|
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(_, !, !, _) :-
|
|
!.
|
|
|
|
lgt_tr_msg(_, true, true, _) :-
|
|
!.
|
|
|
|
lgt_tr_msg(_, fail, fail, _) :-
|
|
!.
|
|
|
|
lgt_tr_msg(_, repeat, repeat, _) :-
|
|
!.
|
|
|
|
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(_, throw(Error), throw(Error), _) :-
|
|
!.
|
|
|
|
|
|
% 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(_))), Context) :-
|
|
!,
|
|
lgt_this(Context, This).
|
|
|
|
lgt_tr_msg(Obj, predicate_property(Pred, Property), lgt_predicate_property(Obj, Pred, Property, This, 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(_))), Context) :-
|
|
!,
|
|
lgt_this(Context, This).
|
|
|
|
lgt_tr_msg(Obj, asserta(Pred), lgt_asserta(Obj, Pred, This, p(p(_))), Context) :-
|
|
!,
|
|
lgt_this(Context, This).
|
|
|
|
lgt_tr_msg(Obj, assertz(Pred), lgt_assertz(Obj, Pred, This, p(p(_))), Context) :-
|
|
!,
|
|
lgt_this(Context, This).
|
|
|
|
lgt_tr_msg(Obj, clause(Head, Body), lgt_clause(Obj, Head, Body, This, p(p(_))), Context) :-
|
|
!,
|
|
lgt_this(Context, This).
|
|
|
|
lgt_tr_msg(Obj, retract(Pred), lgt_retract(Obj, Pred, This, p(p(_))), Context) :-
|
|
!,
|
|
lgt_this(Context, This).
|
|
|
|
lgt_tr_msg(Obj, retractall(Pred), lgt_retractall(Obj, Pred, This, p(p(_))), Context) :-
|
|
!,
|
|
lgt_this(Context, This).
|
|
|
|
|
|
lgt_tr_msg(_, Pred, _, _) :-
|
|
\+ lgt_callable(Pred),
|
|
throw(clause_error(callable, Pred)).
|
|
|
|
|
|
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(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).
|
|
|
|
|
|
lgt_tr_self_msg(Pred, _, _) :-
|
|
\+ lgt_callable(Pred),
|
|
throw(clause_error(callable, Pred)).
|
|
|
|
|
|
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).
|
|
|
|
|
|
|
|
% calling redefined predicates (super)
|
|
|
|
lgt_tr_super_sending(Pred, _, _) :-
|
|
nonvar(Pred),
|
|
\+ lgt_callable(Pred),
|
|
throw(clause_error(callable, Pred)).
|
|
|
|
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)
|
|
|
|
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)
|
|
%
|
|
% constructs a list of all variables that occur
|
|
% in a position corresponding to a meta-argument
|
|
|
|
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).
|
|
|
|
|
|
|
|
% remove redundant calls to true/0 from a clause body
|
|
%
|
|
% lgt_simplify_body(+callable, -callable)
|
|
|
|
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(+callable)
|
|
|
|
lgt_tr_object_id(Obj) :-
|
|
lgt_construct_object_functors(Obj, Prefix, Dcl, Def, Super, SDcl, SDef, DDcl, DDef),
|
|
assertz(lgt_object_(Obj, Prefix, Dcl, Def, Super, SDcl, SDef, DDcl, DDef)),
|
|
Term =.. [Prefix, Dcl, Def, Super, SDcl, SDef, 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(+callable)
|
|
|
|
lgt_tr_category_id(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(+atom)
|
|
|
|
lgt_tr_protocol_id(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, +identifier)
|
|
|
|
lgt_tr_implements_protocol([], _).
|
|
|
|
lgt_tr_implements_protocol([Ref| Refs], ObjOrCtg) :-
|
|
lgt_valid_entity_scope(Ref) ->
|
|
(lgt_scope_id(Ref, Scope, Ptc),
|
|
(lgt_valid_protocol_id(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(directive_error(protocol_identifier, Ptc))))
|
|
;
|
|
throw(directive_error(entity_scope, Ref)).
|
|
|
|
|
|
|
|
% lgt_tr_imports_category(+list, +identifier)
|
|
|
|
lgt_tr_imports_category([], _).
|
|
|
|
lgt_tr_imports_category([Ref| Refs], Obj) :-
|
|
lgt_valid_entity_scope(Ref) ->
|
|
(lgt_scope_id(Ref, Scope, Ctg),
|
|
(lgt_valid_category_id(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(directive_error(category_identifier, Ctg))))
|
|
;
|
|
throw(directive_error(entity_scope, Ref)).
|
|
|
|
|
|
|
|
% lgt_tr_instantiates_class(+list, +identifier)
|
|
|
|
lgt_tr_instantiates_class([], _).
|
|
|
|
lgt_tr_instantiates_class([Ref| Refs], Obj) :-
|
|
lgt_valid_entity_scope(Ref) ->
|
|
(lgt_scope_id(Ref, Scope, Class),
|
|
(lgt_valid_object_id(Class) ->
|
|
assertz(lgt_rclause_(lgt_instantiates_class_(Obj, Class, Scope))),
|
|
lgt_construct_object_functors(Class, Prefix, Dcl, Def, Super, SDcl, SDef, DDcl, DDef),
|
|
assertz(lgt_instantiated_class_(Class, Prefix, Dcl, Def, Super, SDcl, SDef, DDcl, DDef, Scope)),
|
|
lgt_tr_instantiates_class(Refs, Obj)
|
|
;
|
|
throw(directive_error(object_identifier, Class))))
|
|
;
|
|
throw(directive_error(entity_scope, Ref)).
|
|
|
|
|
|
|
|
% lgt_tr_specializes_class(+list, +identifier)
|
|
|
|
lgt_tr_specializes_class([], _).
|
|
|
|
lgt_tr_specializes_class([Ref| Refs], Class) :-
|
|
lgt_valid_entity_scope(Ref) ->
|
|
(lgt_scope_id(Ref, Scope, Superclass),
|
|
(lgt_valid_object_id(Superclass) ->
|
|
assertz(lgt_rclause_(lgt_specializes_class_(Class, Superclass, Scope))),
|
|
lgt_construct_object_functors(Superclass, Prefix, Dcl, Def, Super, SDcl, SDef, DDcl, DDef),
|
|
assertz(lgt_specialized_class_(Superclass, Prefix, Dcl, Def, Super, SDcl, SDef, DDcl, DDef, Scope)),
|
|
lgt_tr_specializes_class(Refs, Class)
|
|
;
|
|
throw(directive_error(object_identifier, Superclass))))
|
|
;
|
|
throw(directive_error(entity_scope, Ref)).
|
|
|
|
|
|
|
|
% lgt_tr_extends_object(+list, +identifier)
|
|
|
|
lgt_tr_extends_object([], _).
|
|
|
|
lgt_tr_extends_object([Ref| Refs], Obj) :-
|
|
lgt_valid_entity_scope(Ref) ->
|
|
(lgt_scope_id(Ref, Scope, Parent),
|
|
(lgt_valid_object_id(Parent) ->
|
|
assertz(lgt_rclause_(lgt_extends_object_(Obj, Parent, Scope))),
|
|
lgt_construct_object_functors(Parent, Prefix, Dcl, Def, Super, SDcl, SDef, DDcl, DDef),
|
|
assertz(lgt_extended_object_(Parent, Prefix, Dcl, Def, Super, SDcl, SDef, DDcl, DDef, Scope)),
|
|
lgt_tr_extends_object(Refs, Obj)
|
|
;
|
|
throw(directive_error(object_identifier, Parent))))
|
|
;
|
|
throw(directive_error(entity_scope, Ref)).
|
|
|
|
|
|
|
|
% lgt_tr_extends_protocol(+list, +identifier)
|
|
|
|
lgt_tr_extends_protocol([], _).
|
|
|
|
lgt_tr_extends_protocol([Ref| Refs], Ptc1) :-
|
|
lgt_valid_entity_scope(Ref) ->
|
|
(lgt_scope_id(Ref, Scope, Ptc2),
|
|
(lgt_valid_protocol_id(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(directive_error(protocol_identifier, Ptc2))))
|
|
;
|
|
throw(directive_error(entity_scope, Ref)).
|
|
|
|
|
|
|
|
% lgt_add_def_clause(+atom, +integer, +atom, +term)
|
|
|
|
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_assert_dynamic_def_clause(+atom, +integer, +atom, +atom, -callable)
|
|
|
|
lgt_assert_dynamic_def_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_assert_dynamic_dcl_clause(+term, +atom)
|
|
|
|
lgt_assert_dynamic_dcl_clause(Pred, DDcl) :-
|
|
functor(Pred, Functor, Arity),
|
|
functor(DPred, Functor, Arity),
|
|
Clause =.. [DDcl, DPred, p(p(p)), (dynamic), no],
|
|
assertz(Clause).
|
|
|
|
|
|
|
|
% lgt_gen_directives(+atom)
|
|
|
|
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_object_(_, Prefix, Dcl, Def, Super, SDcl, SDef, DDcl, DDef),
|
|
assertz(lgt_directive_(dynamic(DDcl/4))),
|
|
assertz(lgt_directive_(dynamic(DDef/5))),
|
|
lgt_entity_comp_mode_((dynamic)),
|
|
!,
|
|
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(SDcl/6))),
|
|
assertz(lgt_directive_(dynamic(SDef/6))),
|
|
forall(
|
|
(lgt_def_(Clause), Clause \= (_ :- _)),
|
|
(arg(5, Clause, Call), functor(Call, Functor, Arity),
|
|
assertz(lgt_directive_(dynamic(Functor/Arity))))).
|
|
|
|
lgt_gen_object_dynamic_directives :-
|
|
lgt_object_(_, _, _, Def, _, _, _, _, _),
|
|
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_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.
|
|
|
|
|
|
|
|
% 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)),
|
|
((lgt_entity_comp_mode_((dynamic)); lgt_dynamic_(Functor/Arity)) -> Compilation = (dynamic); Compilation = static),
|
|
functor(Meta, Functor, Arity),
|
|
(lgt_metapredicate_(Meta) -> Meta2 = Meta; Meta2 = no),
|
|
functor(Pred, Functor, Arity),
|
|
Fact =.. [Dcl, Pred, Scope, Compilation, Meta2],
|
|
assertz(lgt_dcl_(Fact)),
|
|
fail.
|
|
|
|
lgt_gen_local_dcl_clauses.
|
|
|
|
|
|
|
|
lgt_gen_dynamic_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_add_def_clause(Functor, Arity, PPrefix, Context),
|
|
fail.
|
|
|
|
lgt_gen_dynamic_def_clauses.
|
|
|
|
|
|
|
|
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_dcl_(_) ->
|
|
lgt_protocol_(_, _, PDcl),
|
|
Head =.. [PDcl, _, _, _, _],
|
|
assertz(lgt_dcl_((Head:-fail)))
|
|
;
|
|
true).
|
|
|
|
|
|
|
|
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_category_local_dcl_clauses,
|
|
lgt_gen_category_linking_dcl_clauses,
|
|
lgt_gen_category_implements_dcl_clauses.
|
|
|
|
|
|
|
|
lgt_gen_category_local_dcl_clauses :-
|
|
lgt_gen_local_dcl_clauses,
|
|
(\+ lgt_dcl_(_) ->
|
|
lgt_category_(_, _, CDcl, _),
|
|
Head =.. [CDcl, _, _, _, _],
|
|
assertz(lgt_dcl_((Head:-fail)))
|
|
;
|
|
true).
|
|
|
|
|
|
|
|
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_local_def_clauses.
|
|
|
|
|
|
|
|
lgt_gen_category_local_def_clauses :-
|
|
\+ lgt_def_(_) ->
|
|
lgt_category_(_, _, _, CDef),
|
|
Head =.. [CDef, _, _, _, _, _],
|
|
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_prototype_local_dcl_clauses,
|
|
lgt_gen_prototype_linking_dcl_clauses,
|
|
lgt_gen_prototype_implements_dcl_clauses,
|
|
lgt_gen_prototype_imports_dcl_clauses,
|
|
lgt_gen_prototype_extends_dcl_clauses.
|
|
|
|
|
|
|
|
lgt_gen_prototype_local_dcl_clauses :-
|
|
lgt_gen_local_dcl_clauses,
|
|
(\+ lgt_dcl_(_) ->
|
|
lgt_object_(_, _, ODcl, _, _, _, _, _, _),
|
|
Head =.. [ODcl, _, _, _, _],
|
|
assertz(lgt_dcl_((Head:-fail)))
|
|
;
|
|
true).
|
|
|
|
|
|
|
|
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))),
|
|
Body2 =.. [DDcl, Pred, Scope, Compilation, Meta],
|
|
assertz(lgt_dcl_((Head:-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_dynamic_def_clauses,
|
|
lgt_gen_prototype_local_def_clauses,
|
|
lgt_gen_prototype_linking_def_clauses,
|
|
lgt_gen_prototype_imports_def_clauses,
|
|
lgt_gen_prototype_extends_def_clauses.
|
|
|
|
|
|
|
|
lgt_gen_prototype_local_def_clauses :-
|
|
\+ lgt_def_(_) ->
|
|
lgt_object_(_, _, _, Def, _, _, _, _, _),
|
|
Head =.. [Def, _, _, _, _, _],
|
|
assertz(lgt_def_((Head:-fail)))
|
|
;
|
|
true.
|
|
|
|
|
|
|
|
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_sdcl_clauses,
|
|
lgt_gen_ic_def_clauses,
|
|
lgt_gen_ic_sdef_clauses,
|
|
lgt_gen_ic_super_clauses.
|
|
|
|
|
|
|
|
lgt_gen_ic_dcl_clauses :-
|
|
lgt_gen_ic_local_dcl_clauses,
|
|
lgt_gen_ic_hierarchy_dcl_clauses.
|
|
|
|
|
|
|
|
lgt_gen_ic_local_dcl_clauses :-
|
|
lgt_gen_local_dcl_clauses,
|
|
(\+ lgt_dcl_(_) ->
|
|
lgt_object_(_, _, ODcl, _, _, _, _, _, _),
|
|
Head =.. [ODcl, _, _, _, _],
|
|
assertz(lgt_dcl_((Head:-fail)))
|
|
;
|
|
true).
|
|
|
|
|
|
|
|
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_(_, _, _, _, _, CSDcl, _, _, _, EScope),
|
|
(EScope = (public) ->
|
|
Body =.. [CSDcl, Pred, Scope, Compilation, Meta, SContainer, TContainer]
|
|
;
|
|
(EScope = protected ->
|
|
Call =.. [CSDcl, Pred, Scope2, Compilation, Meta, SContainer, TContainer],
|
|
Body = (Call, (Scope2 = p -> Scope = p; Scope = p(p)))
|
|
;
|
|
Scope = p,
|
|
Call =.. [CSDcl, 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.
|
|
|
|
|
|
|
|
lgt_gen_ic_sdcl_clauses :-
|
|
lgt_gen_ic_linking_sdcl_clauses,
|
|
lgt_gen_ic_protocol_sdcl_clauses,
|
|
lgt_gen_ic_category_sdcl_clauses,
|
|
lgt_gen_ic_hierarchy_sdcl_clauses.
|
|
|
|
|
|
|
|
lgt_gen_ic_linking_sdcl_clauses :-
|
|
lgt_object_(Obj, _, Dcl, _, _, SDcl, _, DDcl, _),
|
|
Head =.. [SDcl, Pred, Scope, Compilation, Meta, Obj, Obj],
|
|
Body =.. [Dcl, Pred, Scope, Compilation, Meta],
|
|
assertz(lgt_dcl_((Head:-Body))),
|
|
Body2 =.. [DDcl, Pred, Scope, Compilation, Meta],
|
|
assertz(lgt_dcl_((Head:-Body2))).
|
|
|
|
|
|
|
|
|
|
lgt_gen_ic_protocol_sdcl_clauses :-
|
|
lgt_object_(Obj, _, _, _, _, OSDcl, _, _, _),
|
|
Head =.. [OSDcl, 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_sdcl_clauses.
|
|
|
|
|
|
|
|
lgt_gen_ic_category_sdcl_clauses :-
|
|
lgt_object_(Obj, _, _, _, _, OSDcl, _, _, _),
|
|
Head =.. [OSDcl, 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_sdcl_clauses.
|
|
|
|
|
|
|
|
lgt_gen_ic_hierarchy_sdcl_clauses :-
|
|
lgt_object_(Obj, _, _, _, _, CSDcl, _, _, _),
|
|
Head =.. [CSDcl, Pred, Scope, Compilation, Meta, SContainer, TContainer],
|
|
lgt_specialized_class_(_, _, _, _, _, SSDcl, _, _, _, EScope),
|
|
(EScope = (public) ->
|
|
Body =.. [SSDcl, Pred, Scope, Compilation, Meta, SContainer, TContainer]
|
|
;
|
|
(EScope = protected ->
|
|
Call =.. [SSDcl, Pred, Scope2, Compilation, Meta, SContainer, TContainer],
|
|
Body = (Call, (Scope2 = p -> Scope = p; Scope = p(p)))
|
|
;
|
|
Scope = p,
|
|
Call =.. [SSDcl, Pred, Scope2, Compilation, Meta, SContainer2, TContainer],
|
|
Body = (Call, (Scope2 = p -> SContainer = SContainer2; SContainer = Obj)))),
|
|
assertz(lgt_dcl_((Head:-Body))),
|
|
fail.
|
|
|
|
lgt_gen_ic_hierarchy_sdcl_clauses.
|
|
|
|
|
|
|
|
lgt_gen_ic_def_clauses :-
|
|
lgt_gen_dynamic_def_clauses,
|
|
lgt_gen_ic_local_def_clauses,
|
|
lgt_gen_ic_linking_def_clauses,
|
|
lgt_gen_ic_imports_def_clauses,
|
|
lgt_gen_ic_hierarchy_def_clauses.
|
|
|
|
|
|
|
|
lgt_gen_ic_local_def_clauses :-
|
|
\+ lgt_def_(_) ->
|
|
lgt_object_(_, _, _, Def, _, _, _, _, _),
|
|
Head =.. [Def, _, _, _, _, _],
|
|
assertz(lgt_def_((Head:-fail)))
|
|
;
|
|
true.
|
|
|
|
|
|
|
|
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, _, _, _, _, _, CSDef, _, _, _),
|
|
Body =.. [CSDef, Pred, Sender, Class, Self, Call, Container],
|
|
assertz(lgt_def_((Head:-Body))),
|
|
fail.
|
|
|
|
lgt_gen_ic_hierarchy_def_clauses.
|
|
|
|
|
|
|
|
|
|
lgt_gen_ic_sdef_clauses :-
|
|
lgt_gen_ic_linking_sdef_clauses,
|
|
lgt_gen_ic_category_sdef_clauses,
|
|
lgt_gen_ic_hierarchy_sdef_clauses.
|
|
|
|
|
|
|
|
lgt_gen_ic_linking_sdef_clauses :-
|
|
lgt_object_(Obj, _, _, Def, _, _, SDef, _, DDef),
|
|
Head =.. [SDef, 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_sdef_clauses :-
|
|
lgt_object_(Obj, _, _, _, _, _, OSDef, _, _),
|
|
lgt_rclause_(lgt_imports_category_(Obj, Ctg, _)),
|
|
Head =.. [OSDef, 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_sdef_clauses.
|
|
|
|
|
|
|
|
lgt_gen_ic_hierarchy_sdef_clauses :-
|
|
lgt_object_(Class, _, _, _, _, _, CSDef, _, _),
|
|
lgt_rclause_(lgt_specializes_class_(Class, Super, _)),
|
|
Head =.. [CSDef, Pred, Sender, Class, Self, Call, Container],
|
|
lgt_specialized_class_(Super, _, _, _, _, _, SSDef, _, _, _),
|
|
Body =.. [SSDef, Pred, Sender, Super, Self, Call, Container],
|
|
assertz(lgt_def_((Head:-Body))),
|
|
fail.
|
|
|
|
lgt_gen_ic_hierarchy_sdef_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, _, _, _, _, _, CSDef, _, _, _),
|
|
Body =.. [CSDef, 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, _, _, _, _, _, SSDef, _, _, _),
|
|
Body =.. [SSDef, Pred, Sender, Super, Self, Call, Container],
|
|
assertz(lgt_def_((Head:-Body))),
|
|
fail.
|
|
|
|
lgt_gen_ic_super_clauses.
|
|
|
|
|
|
|
|
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_entity_(Type, Entity, _, _),
|
|
write('Logtalk compiler warning!'), nl,
|
|
write(' these static predicates are called but never defined: '), nl,
|
|
write(' '), writeq([Pred| Preds]), nl,
|
|
write(' inside '), write(Type), write(': '),
|
|
writeq(Entity), nl
|
|
;
|
|
true.
|
|
|
|
|
|
|
|
lgt_write_directives(Stream) :-
|
|
write_term(Stream, ':- ', []),
|
|
write_term(Stream, op(600, xfy, ::), [quoted(true)]),
|
|
write_term(Stream, '.', []), nl(Stream),
|
|
write_term(Stream, ':- ', []),
|
|
write_term(Stream, op(600, fy, ::), [quoted(true)]),
|
|
write_term(Stream, '.', []), nl(Stream),
|
|
write_term(Stream, ':- ', []),
|
|
write_term(Stream, op(600, fx, ^^), [quoted(true)]),
|
|
write_term(Stream, '.', []), nl(Stream),
|
|
lgt_directive_(Dir),
|
|
write_term(Stream, ':- ', []),
|
|
write_term(Stream, Dir, [quoted(true)]),
|
|
write_term(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_super_clauses(Stream),
|
|
lgt_write_entity_clauses(Stream).
|
|
|
|
|
|
|
|
lgt_write_functors_clause(Stream) :-
|
|
lgt_entity_functors_(Clause),
|
|
write_term(Stream, Clause, [quoted(true)]),
|
|
write_term(Stream, '.', []),
|
|
nl(Stream).
|
|
|
|
|
|
|
|
lgt_write_def_clauses(Stream) :-
|
|
lgt_def_(Clause),
|
|
write_term(Stream, Clause, [quoted(true)]),
|
|
write_term(Stream, '.', []), nl(Stream),
|
|
fail.
|
|
|
|
lgt_write_def_clauses(_).
|
|
|
|
|
|
|
|
lgt_write_dcl_clauses(Stream) :-
|
|
lgt_dcl_(Clause),
|
|
write_term(Stream, Clause, [quoted(true)]),
|
|
write_term(Stream, '.', []),
|
|
nl(Stream),
|
|
fail.
|
|
|
|
lgt_write_dcl_clauses(_).
|
|
|
|
|
|
|
|
lgt_write_super_clauses(Stream) :-
|
|
lgt_super_(Clause),
|
|
write_term(Stream, Clause, [quoted(true)]),
|
|
write_term(Stream, '.', []),
|
|
nl(Stream),
|
|
fail.
|
|
|
|
lgt_write_super_clauses(_).
|
|
|
|
|
|
|
|
lgt_write_entity_clauses(Stream) :-
|
|
lgt_feclause_(Clause),
|
|
write_term(Stream, Clause, [quoted(true)]),
|
|
write_term(Stream, '.', []),
|
|
nl(Stream),
|
|
fail.
|
|
|
|
lgt_write_entity_clauses(_).
|
|
|
|
|
|
|
|
lgt_write_init_call(Stream) :-
|
|
lgt_compiler_option(iso_initialization_dir, true),
|
|
!,
|
|
findall(Clause, lgt_rclause_(Clause), Clauses),
|
|
write_term(Stream, ':- initialization((lgt_assert_relation_clauses(', []),
|
|
write_term(Stream, Clauses, [quoted(true)]),
|
|
write_term(Stream, ')', []),
|
|
(lgt_fentity_init_(Call) ->
|
|
write_term(Stream, ', ', []),
|
|
write_term(Stream, Call, [quoted(true)])
|
|
;
|
|
true),
|
|
write_term(Stream, ')).', []), nl(Stream).
|
|
|
|
lgt_write_init_call(Stream) :-
|
|
findall(Clause, lgt_rclause_(Clause), Clauses),
|
|
write_term(Stream, ':- lgt_assert_relation_clauses(', []),
|
|
write_term(Stream, Clauses, [quoted(true)]),
|
|
write_term(Stream, ').', []), nl(Stream),
|
|
(lgt_fentity_init_(Call) ->
|
|
write_term(Stream, ':- ', []),
|
|
write_term(Stream, Call, [quoted(true)]),
|
|
write_term(Stream, '.', []),
|
|
nl(Stream)
|
|
;
|
|
true).
|
|
|
|
|
|
|
|
lgt_assert_tr_entity :-
|
|
lgt_assert_directives,
|
|
lgt_assert_functors_clause,
|
|
lgt_assert_dcl_clauses,
|
|
lgt_assert_def_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_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 :-
|
|
lgt_fentity_init_(Goal) ->
|
|
once(Goal)
|
|
;
|
|
true.
|
|
|
|
|
|
|
|
% lgt_assert_relation_clauses(+list)
|
|
%
|
|
% called when loading a compiled Logtalk
|
|
% entity to update Logtalk internal tables
|
|
|
|
lgt_assert_relation_clauses([]).
|
|
|
|
lgt_assert_relation_clauses([Clause| Clauses]) :-
|
|
lgt_assert_relation_clause(Clause),
|
|
lgt_assert_relation_clauses(Clauses).
|
|
|
|
|
|
|
|
lgt_assert_relation_clause(Clause) :-
|
|
functor(Clause, Functor, Arity),
|
|
arg(1, Clause, Entity),
|
|
functor(Old, Functor, Arity),
|
|
arg(1, Old, Entity),
|
|
retractall(Old),
|
|
assertz(Clause).
|
|
|
|
|
|
|
|
% lgt_construct_object_functors(+compound, -atom, -atom, -atom, -atom, -atom, -atom, -atom, -atom)
|
|
|
|
lgt_construct_object_functors(Obj, Prefix, Dcl, Def, Super, SDcl, SDef, DDcl, DDef) :-
|
|
functor(Obj, Functor, Arity),
|
|
number_codes(Arity, Codes),
|
|
atom_codes(Atom, Codes),
|
|
atom_concat(Functor, Atom, Aux),
|
|
atom_concat(Aux, '_', Prefix),
|
|
atom_concat(Prefix, '_dcl', Dcl),
|
|
atom_concat(Prefix, '_def', Def),
|
|
atom_concat(Prefix, '_super', Super),
|
|
atom_concat(Prefix, '_sdcl', SDcl),
|
|
atom_concat(Prefix, '_sdef', SDef),
|
|
atom_concat(Prefix, '_ddcl', DDcl),
|
|
atom_concat(Prefix, '_ddef', DDef).
|
|
|
|
|
|
|
|
% lgt_construct_protocol_functors(+compound, -atom, -atom)
|
|
|
|
lgt_construct_protocol_functors(Ptc, Prefix, Dcl) :-
|
|
functor(Ptc, Functor, Arity),
|
|
number_codes(Arity, Codes),
|
|
atom_codes(Atom, Codes),
|
|
atom_concat(Functor, Atom, Aux),
|
|
atom_concat(Aux, '_', Prefix),
|
|
atom_concat(Prefix, '_dcl', Dcl).
|
|
|
|
|
|
|
|
% lgt_construct_category_functors(+compound, -atom, -atom, -atom)
|
|
|
|
lgt_construct_category_functors(Ctg, Prefix, Dcl, Def) :-
|
|
functor(Ctg, Functor, Arity),
|
|
number_codes(Arity, Codes),
|
|
atom_codes(Atom, Codes),
|
|
atom_concat(Functor, Atom, Aux),
|
|
atom_concat(Aux, '_', Prefix),
|
|
atom_concat(Prefix, '_dcl', Dcl),
|
|
atom_concat(Prefix, '_def', Def).
|
|
|
|
|
|
|
|
% lgt_construct_predicate_functor(+atom, +atom, +integer, -atom)
|
|
|
|
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(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_entity_directive(info/2).
|
|
|
|
|
|
|
|
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).
|
|
|
|
|
|
|
|
% 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_entity_scope(@term)
|
|
|
|
lgt_valid_entity_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)
|
|
|
|
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(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(report(Option)) :-
|
|
once((Option == on; Option == off)).
|
|
|
|
|
|
|
|
% 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(logtalk_version(_, _, _)).
|
|
|
|
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(_, _, _, _, _)).
|
|
|
|
|
|
|
|
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
%
|
|
% xml
|
|
%
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
|
|
|
|
|
|
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_write_xml_open_tag(Stream, '?xml version="1.0"?', []),
|
|
write_term(Stream, '<!DOCTYPE logtalk SYSTEM "logtalk.dtd">', []), nl(Stream),
|
|
lgt_compiler_option(xsl, XSL),
|
|
write_term(Stream, '<?xml-stylesheet type="text/xsl" href="', []),
|
|
write_term(Stream, XSL, []),
|
|
write_term(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) :-
|
|
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) :-
|
|
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) :-
|
|
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) :-
|
|
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, 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_term(Stream, '<', []),
|
|
write_term(Stream, Tag, []),
|
|
lgt_write_xml_tag_attributes(Stream, Atts),
|
|
write_term(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_term(Stream, '<', []),
|
|
write_term(Stream, Tag, []),
|
|
lgt_write_xml_tag_attributes(Stream, Atts),
|
|
write_term(Stream, '>', []),
|
|
write_term(Stream, Text, []),
|
|
write_term(Stream, '</', []),
|
|
write_term(Stream, Tag, []),
|
|
write_term(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_term(Stream, '<', []),
|
|
write_term(Stream, Tag, []),
|
|
lgt_write_xml_tag_attributes(Stream, Atts),
|
|
write_term(Stream, '><![CDATA[', []),
|
|
write_term(Stream, Text, []),
|
|
write_term(Stream, ']]></', []),
|
|
write_term(Stream, Tag, []),
|
|
write_term(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_term(Stream, ' ', []),
|
|
write_term(Stream, Attribute, []),
|
|
write_term(Stream, '="', []),
|
|
write_term(Stream, Value, []),
|
|
write_term(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_term(Stream, '</', []),
|
|
write_term(Stream, Tag, []),
|
|
write_term(Stream, '>', []),
|
|
nl(Stream).
|
|
|
|
|
|
|
|
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
%
|
|
% Logtalk banner
|
|
%
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
|
|
|
|
lgt_banner :-
|
|
logtalk_version(Major, Minor, Patch),
|
|
write('Logtalk '), write(Major), write('.'), write(Minor), write('.'), write(Patch), nl,
|
|
write('Copyright (c) 1998-2001 Paulo Moura'), nl.
|
|
|
|
|
|
:- initialization(lgt_banner).
|
|
|
|
|
|
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
%
|
|
% end!
|
|
%
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
|