add more SWI files.
This commit is contained in:
Vítor Santos Costa
parent
7c2ba414a3
commit
8af7ad47bf
165
LGPL/pairs.pl
Normal file
165
LGPL/pairs.pl
Normal file
@ -0,0 +1,165 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: wielemak@science.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2006, University of Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- module(pairs,
|
||||
[ pairs_keys_values/3,
|
||||
pairs_values/2,
|
||||
pairs_keys/2,
|
||||
group_pairs_by_key/2,
|
||||
transpose_pairs/2,
|
||||
map_list_to_pairs/3
|
||||
]).
|
||||
|
||||
/** <module> Operations on key-value lists
|
||||
|
||||
This module implements common operations on Key-Value lists, also known
|
||||
as _Pairs_. Pairs have great practical value, especially due to
|
||||
keysort/2 and the library assoc.pl.
|
||||
|
||||
This library is based on disussion in the SWI-Prolog mailinglist,
|
||||
including specifications from Quintus and a library proposal by Richard
|
||||
O'Keefe.
|
||||
|
||||
@see keysort/2, library(assoc)
|
||||
@author Jan Wielemaker
|
||||
*/
|
||||
|
||||
%% pairs_keys_values(?Pairs, ?Keys, ?Values) is det.
|
||||
%
|
||||
% True if Keys holds the keys of Pairs and Values the values.
|
||||
%
|
||||
% Deterministic if any argument is instantiated to a finite list
|
||||
% and the others are either free or finite lists. All three lists
|
||||
% are in the same order.
|
||||
%
|
||||
% @see pairs_values/2 and pairs_keys/2.
|
||||
|
||||
pairs_keys_values(Pairs, Keys, Values) :-
|
||||
( nonvar(Pairs) ->
|
||||
pairs_keys_values_(Pairs, Keys, Values)
|
||||
; nonvar(Keys) ->
|
||||
keys_values_pairs(Keys, Values, Pairs)
|
||||
; values_keys_pairs(Values, Keys, Pairs)
|
||||
).
|
||||
|
||||
pairs_keys_values_([], [], []).
|
||||
pairs_keys_values_([K-V|Pairs], [K|Keys], [V|Values]) :-
|
||||
pairs_keys_values_(Pairs, Keys, Values).
|
||||
|
||||
keys_values_pairs([], [], []).
|
||||
keys_values_pairs([K|Ks], [V|Vs], [K-V|Pairs]) :-
|
||||
keys_values_pairs(Ks, Vs, Pairs).
|
||||
|
||||
values_keys_pairs([], [], []).
|
||||
values_keys_pairs([V|Vs], [K|Ks], [K-V|Pairs]) :-
|
||||
values_keys_pairs(Vs, Ks, Pairs).
|
||||
|
||||
%% pairs_values(+Pairs, -Values) is det.
|
||||
%
|
||||
% Remove the keys from a list of Key-Value pairs. Same as
|
||||
% pairs_keys_values(Pairs, _, Values)
|
||||
|
||||
pairs_values([], []).
|
||||
pairs_values([_-V|T0], [V|T]) :-
|
||||
pairs_values(T0, T).
|
||||
|
||||
|
||||
%% pairs_keys(+Pairs, -Keys) is det.
|
||||
%
|
||||
% Remove the values from a list of Key-Value pairs. Same as
|
||||
% pairs_keys_values(Pairs, Keys, _)
|
||||
|
||||
pairs_keys([], []).
|
||||
pairs_keys([K-_|T0], [K|T]) :-
|
||||
pairs_keys(T0, T).
|
||||
|
||||
|
||||
%% group_pairs_by_key(+Pairs, -Joined:list(Key-Values)) is det.
|
||||
%
|
||||
% Group values with the same key. Pairs must be a key-sorted list.
|
||||
% For example:
|
||||
%
|
||||
% ==
|
||||
% ?- group_pairs_by_key([a-2, a-1, b-4], X).
|
||||
%
|
||||
% X = [a-[2,1], b-[4]]
|
||||
% ==
|
||||
%
|
||||
% @param Pairs Key-Value list, sorted to the standard order
|
||||
% of terms (as keysort/2 does)
|
||||
% @param Joined List of Key-Group, where Group is the
|
||||
% list of Values associated with Key.
|
||||
|
||||
group_pairs_by_key([], []).
|
||||
group_pairs_by_key([M-N|T0], [M-[N|TN]|T]) :-
|
||||
same_key(M, T0, TN, T1),
|
||||
group_pairs_by_key(T1, T).
|
||||
|
||||
same_key(M, [M-N|T0], [N|TN], T) :- !,
|
||||
same_key(M, T0, TN, T).
|
||||
same_key(_, L, [], L).
|
||||
|
||||
|
||||
%% transpose_pairs(+Pairs, -Transposed) is det.
|
||||
%
|
||||
% Swap Key-Value to Value-Key and sort the result on Value
|
||||
% (the new key) using keysort/2.
|
||||
|
||||
transpose_pairs(Pairs, Transposed) :-
|
||||
flip_pairs(Pairs, Flipped),
|
||||
keysort(Flipped, Transposed).
|
||||
|
||||
flip_pairs([], []).
|
||||
flip_pairs([Key-Val|Pairs], [Val-Key|Flipped]) :-
|
||||
flip_pairs(Pairs, Flipped).
|
||||
|
||||
|
||||
%% map_list_to_pairs(:Function, +List, -Keyed)
|
||||
%
|
||||
% Create a key-value list by mapping each element of List.
|
||||
% For example, if we have a list of lists we can create a
|
||||
% list of Length-List using
|
||||
%
|
||||
% ==
|
||||
% map_list_to_pairs(length, ListOfLists, Pairs),
|
||||
% ==
|
||||
|
||||
:- meta_predicate
|
||||
map_list_to_pairs(2, +, -).
|
||||
|
||||
map_list_to_pairs(Function, List, Pairs) :-
|
||||
map_list_to_pairs2(List, Function, Pairs).
|
||||
|
||||
map_list_to_pairs2([], _, []).
|
||||
map_list_to_pairs2([H|T0], Pred, [K-H|T]) :-
|
||||
call(Pred, H, K),
|
||||
map_list_to_pairs2(T0, Pred, T).
|
||||
|
||||
912
LGPL/predicate_options.pl
Normal file
912
LGPL/predicate_options.pl
Normal file
@ -0,0 +1,912 @@
|
||||
/* Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: J.Wielemaker@cs.vu.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2011, VU University Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- module(predicate_options,
|
||||
[ predicate_options/3, % +PI, +Arg, +Options
|
||||
assert_predicate_options/4, % +PI, +Arg, +Options, ?New
|
||||
|
||||
current_option_arg/2, % ?PI, ?Arg
|
||||
current_predicate_option/3, % ?PI, ?Arg, ?Option
|
||||
check_predicate_option/3, % +PI, +Arg, +Option
|
||||
% Create declarations
|
||||
current_predicate_options/3, % ?PI, ?Arg, ?Options
|
||||
retractall_predicate_options/0,
|
||||
derived_predicate_options/3, % :PI, ?Arg, ?Options
|
||||
derived_predicate_options/1, % +Module
|
||||
% Checking
|
||||
check_predicate_options/0,
|
||||
derive_predicate_options/0,
|
||||
check_predicate_options/1 % :PredicateIndicator
|
||||
]).
|
||||
:- use_module(library(lists)).
|
||||
:- use_module(library(pairs)).
|
||||
:- use_module(library(error)).
|
||||
:- use_module(library(lists)).
|
||||
:- use_module(library(debug)).
|
||||
:- use_module(library(prolog_clause)).
|
||||
|
||||
:- meta_predicate
|
||||
predicate_options(:, +, +),
|
||||
assert_predicate_options(:, +, +, ?),
|
||||
current_predicate_option(:, ?, ?),
|
||||
check_predicate_option(:, ?, ?),
|
||||
current_predicate_options(:, ?, ?),
|
||||
current_option_arg(:, ?),
|
||||
pred_option(:,-),
|
||||
derived_predicate_options(:,?,?),
|
||||
check_predicate_options(:).
|
||||
|
||||
/** <module> Access and analyse predicate options
|
||||
|
||||
This module provides the developers interface for the directive
|
||||
predicate_options/3. This directive allows us to specify that e.g.,
|
||||
open/4 processes options using the 4th argument and supports the option
|
||||
=type= using the values =text= and =binary=. Declaring options that are
|
||||
processed allows for more reliable handling of predicate options and
|
||||
simplifies porting applications. This libarry provides the following
|
||||
functionality:
|
||||
|
||||
* Query supported options through current_predicate_option/3
|
||||
or current_predicate_options/3. This is intended to support
|
||||
conditional compilation and an IDE.
|
||||
* Derive additional declarations through dataflow analysis using
|
||||
derive_predicate_options/0.
|
||||
* Perform a compile-time analysis of the entire loaded program using
|
||||
check_predicate_options/0.
|
||||
|
||||
Below, we describe some use-cases.
|
||||
|
||||
$ Quick check of a program :
|
||||
This scenario is useful as an occasional check or to assess problems
|
||||
with option-handling for porting an application to SWI-Prolog. It
|
||||
consists of three steps: loading the program (1 and 2), deriving
|
||||
option handling for application predicates (3) and running the
|
||||
checker (4).
|
||||
|
||||
==
|
||||
1 ?- [load].
|
||||
2 ?- autoload.
|
||||
3 ?- derive_predicate_options.
|
||||
4 ?- check_predicate_options.
|
||||
==
|
||||
|
||||
$ Add declaations to your program :
|
||||
Adding declarations about option processes improves the quality of
|
||||
the checking. The analysis of derive_predicate_options/0 may miss
|
||||
options and does not derive the types for options that are processed
|
||||
in Prolog code. The process is similar to the above. In steps 4 and
|
||||
further, the inferred declarations are listed, inspected and added to
|
||||
the source-code of the module.
|
||||
|
||||
==
|
||||
1 ?- [load].
|
||||
2 ?- autoload.
|
||||
3 ?- derive_predicate_options.
|
||||
4 ?- derived_predicate_options(module_1).
|
||||
5 ?- derived_predicate_options(module_2).
|
||||
6 ?- ...
|
||||
==
|
||||
|
||||
$ Declare option processing requirements :
|
||||
If an application requires that open/4 needs to support lock(write),
|
||||
it may do so using the derective below. This directive raises an
|
||||
exception when loaded on a Prolog implementation that does not support
|
||||
this option.
|
||||
|
||||
==
|
||||
:- current_predicate_option(open/4, 4, lock(write)).
|
||||
==
|
||||
|
||||
@see library(option) for accessing options in Prolog code.
|
||||
*/
|
||||
|
||||
:- multifile option_decl/3, pred_option/3.
|
||||
:- dynamic dyn_option_decl/3.
|
||||
|
||||
%% predicate_options(:PI, +Arg, +Options) is det.
|
||||
%
|
||||
% Declare that the predicate PI processes options on Arg. Options
|
||||
% is a list of options processed. Each element is one of:
|
||||
%
|
||||
% * Option(ModeAndType)
|
||||
% PI processes Option. The option-value must comply to
|
||||
% ModeAndType. Mode is one of + or - and Type is a type as
|
||||
% accepted by must_be/2.
|
||||
%
|
||||
% * pass_to(:PI,Arg)
|
||||
% The option-list is passed to the indicated predicate.
|
||||
%
|
||||
% Below is an example that processes the option header(boolean)
|
||||
% and passes all options to open/4:
|
||||
%
|
||||
% ==
|
||||
% :- predicate_options(write_xml_file/3, 3,
|
||||
% [ header(boolean),
|
||||
% pass_to(open/4, 4)
|
||||
% ]).
|
||||
%
|
||||
% write_xml_file(File, XMLTerm, Options) :-
|
||||
% open(File, write, Out, Options),
|
||||
% ( option(header(true), Option, true)
|
||||
% -> write_xml_header(Out)
|
||||
% ; true
|
||||
% ),
|
||||
% ...
|
||||
% ==
|
||||
%
|
||||
% This predicate may only be used as a _directive_ and is
|
||||
% processed by expand_term/2. Option processing can be be
|
||||
% specified at runtime using assert_predicate_options/3, which is
|
||||
% intended to support program analysis.
|
||||
|
||||
predicate_options(PI, Arg, Options) :-
|
||||
throw(error(context_error(nodirective,
|
||||
predicate_options(PI, Arg, Options)), _)).
|
||||
|
||||
|
||||
%% assert_predicate_options(:PI, +Arg, +Options, ?New) is semidet.
|
||||
%
|
||||
% As predicate_options(:PI, +Arg, +Options). New is a boolean
|
||||
% indicating whether the declarations have changed. If new is
|
||||
% provided and =false=, the predicate becomes semidet and fails
|
||||
% without modifications if modifications are required.
|
||||
|
||||
assert_predicate_options(PI, Arg, Options, New) :-
|
||||
canonical_pi(PI, M:Name/Arity),
|
||||
functor(Head, Name, Arity),
|
||||
( dyn_option_decl(Head, M, Arg)
|
||||
-> true
|
||||
; New = true,
|
||||
assertz(dyn_option_decl(Head, M, Arg))
|
||||
),
|
||||
phrase('$predopts':option_clauses(Options, Head, M, Arg),
|
||||
OptionClauses),
|
||||
forall(member(Clause, OptionClauses),
|
||||
assert_option_clause(Clause, New)),
|
||||
( var(New)
|
||||
-> New = false
|
||||
; true
|
||||
).
|
||||
|
||||
assert_option_clause(Clause, New) :-
|
||||
rename_clause(Clause, NewClause,
|
||||
'$pred_option'(A,B,C,D), '$dyn_pred_option'(A,B,C,D)),
|
||||
clause_head(NewClause, NewHead),
|
||||
( clause(NewHead, _)
|
||||
-> true
|
||||
; New = true,
|
||||
assertz(NewClause)
|
||||
).
|
||||
|
||||
clause_head(M:(Head:-_Body), M:Head) :- !.
|
||||
clause_head((M:Head :-_Body), M:Head) :- !.
|
||||
clause_head(Head, Head).
|
||||
|
||||
rename_clause(M:Clause, M:NewClause, Head, NewHead) :- !,
|
||||
rename_clause(Clause, NewClause, Head, NewHead).
|
||||
rename_clause((Head :- Body), (NewHead :- Body), Head, NewHead) :- !.
|
||||
rename_clause(Head, NewHead, Head, NewHead) :- !.
|
||||
rename_clause(Head, Head, _, _).
|
||||
|
||||
|
||||
|
||||
/*******************************
|
||||
* QUERY OPTIONS *
|
||||
*******************************/
|
||||
|
||||
%% current_option_arg(:PI, ?Arg) is nondet.
|
||||
%
|
||||
% True when Arg of PI processes predicate options. Which options
|
||||
% are processed can be accessed using current_predicate_option/3.
|
||||
|
||||
current_option_arg(Module:Name/Arity, Arg) :-
|
||||
current_option_arg(Module:Name/Arity, Arg, _DefM).
|
||||
|
||||
current_option_arg(Module:Name/Arity, Arg, DefM) :-
|
||||
atom(Name), integer(Arity), !,
|
||||
resolve_module(Module:Name/Arity, DefM:Name/Arity),
|
||||
functor(Head, Name, Arity),
|
||||
( option_decl(Head, DefM, Arg)
|
||||
; dyn_option_decl(Head, DefM, Arg)
|
||||
).
|
||||
current_option_arg(M:Name/Arity, Arg, M) :-
|
||||
( option_decl(Head, M, Arg)
|
||||
; dyn_option_decl(Head, M, Arg)
|
||||
),
|
||||
functor(Head, Name, Arity).
|
||||
|
||||
%% current_predicate_option(:PI, ?Arg, ?Option) is nondet.
|
||||
%
|
||||
% True when Arg of PI processes Option. For example, the following
|
||||
% is true:
|
||||
%
|
||||
% ==
|
||||
% ?- current_predicate_option(open/4, 4, type(text)).
|
||||
% true.
|
||||
% ==
|
||||
%
|
||||
% This predicate is intended to support conditional compilation
|
||||
% using if/1 ... endif/0. The predicate
|
||||
% current_predicate_options/3 can be used to access the full
|
||||
% capabilities of a predicate.
|
||||
|
||||
current_predicate_option(Module:PI, Arg, Option) :-
|
||||
current_option_arg(Module:PI, Arg, DefM),
|
||||
PI = Name/Arity,
|
||||
functor(Head, Name, Arity),
|
||||
catch(pred_option(DefM:Head, Option),
|
||||
error(type_error(_,_),_),
|
||||
fail).
|
||||
|
||||
%% check_predicate_option(:PI, +Arg, +Option) is det.
|
||||
%
|
||||
% Similar to current_predicate_option/3, but intended to support
|
||||
% runtime checking.
|
||||
%
|
||||
% @error existence_error(option, OptionName) if the option is not
|
||||
% supported by PI.
|
||||
% @error type_error(Type, Value) if the option is supported but
|
||||
% the value does not match the option type. See must_be/2.
|
||||
|
||||
check_predicate_option(Module:PI, Arg, Option) :-
|
||||
define_predicate(Module:PI),
|
||||
current_option_arg(Module:PI, Arg, DefM),
|
||||
PI = Name/Arity,
|
||||
functor(Head, Name, Arity),
|
||||
( pred_option(DefM:Head, Option)
|
||||
-> true
|
||||
; existence_error(option, Option)
|
||||
).
|
||||
|
||||
|
||||
pred_option(M:Head, Option) :-
|
||||
pred_option(M:Head, Option, []).
|
||||
|
||||
pred_option(M:Head, Option, Seen) :-
|
||||
( has_static_option_decl(M),
|
||||
M:'$pred_option'(Head, _, Option, Seen)
|
||||
; has_dynamic_option_decl(M),
|
||||
M:'$dyn_pred_option'(Head, _, Option, Seen)
|
||||
).
|
||||
|
||||
has_static_option_decl(M) :-
|
||||
'$c_current_predicate'(_, M:'$pred_option'(_,_,_,_)).
|
||||
has_dynamic_option_decl(M) :-
|
||||
'$c_current_predicate'(_, M:'$dyn_pred_option'(_,_,_,_)).
|
||||
|
||||
|
||||
/*******************************
|
||||
* TYPE&MODE CONSTRAINTS *
|
||||
*******************************/
|
||||
|
||||
:- public
|
||||
system:predicate_option_mode/2,
|
||||
system:predicate_option_type/2.
|
||||
|
||||
add_attr(Var, Value) :-
|
||||
( get_attr(Var, predicate_options, Old)
|
||||
-> put_attr(Var, predicate_options, [Value|Old])
|
||||
; put_attr(Var, predicate_options, [Value])
|
||||
).
|
||||
|
||||
system:predicate_option_type(Type, Arg) :-
|
||||
var(Arg), !,
|
||||
add_attr(Arg, option_type(Type)).
|
||||
system:predicate_option_type(Type, Arg) :-
|
||||
must_be(Type, Arg).
|
||||
|
||||
system:predicate_option_mode(Mode, Arg) :-
|
||||
var(Arg), !,
|
||||
add_attr(Arg, option_mode(Mode)).
|
||||
system:predicate_option_mode(Mode, Arg) :-
|
||||
check_mode(Mode, Arg).
|
||||
|
||||
check_mode(input, Arg) :-
|
||||
( nonvar(Arg)
|
||||
-> true
|
||||
; instantiation_error(Arg)
|
||||
).
|
||||
check_mode(output, Arg) :-
|
||||
( var(Arg)
|
||||
-> true
|
||||
; instantiation_error(Arg) % TBD: Uninstantiated
|
||||
).
|
||||
|
||||
attr_unify_hook([], _).
|
||||
attr_unify_hook([H|T], Var) :-
|
||||
option_hook(H, Var),
|
||||
attr_unify_hook(T, Var).
|
||||
|
||||
option_hook(option_type(Type), Value) :-
|
||||
is_of_type(Type, Value).
|
||||
option_hook(option_mode(Mode), Value) :-
|
||||
check_mode(Mode, Value).
|
||||
|
||||
|
||||
attribute_goals(Var) -->
|
||||
{ get_attr(Var, predicate_options, Attrs) },
|
||||
option_goals(Attrs, Var).
|
||||
|
||||
option_goals([], _) --> [].
|
||||
option_goals([H|T], Var) -->
|
||||
option_goal(H, Var),
|
||||
option_goals(T, Var).
|
||||
|
||||
option_goal(option_type(Type), Var) --> [predicate_option_type(Type, Var)].
|
||||
option_goal(option_mode(Mode), Var) --> [predicate_option_mode(Mode, Var)].
|
||||
|
||||
|
||||
/*******************************
|
||||
* OUTPUT DECLARATIONS *
|
||||
*******************************/
|
||||
|
||||
%% current_predicate_options(:PI, ?Arg, ?Options) is nondet.
|
||||
%
|
||||
% True when Options is the current active option declaration for
|
||||
% PI on Arg. See predicate_options/3 for the argument
|
||||
% descriptions. If PI is ground and refers to an undefined
|
||||
% predicate, the autoloader is used to obtain a definition of the
|
||||
% predicate.
|
||||
|
||||
current_predicate_options(PI, Arg, Options) :-
|
||||
define_predicate(PI),
|
||||
setof(Arg-Option,
|
||||
current_predicate_option_decl(PI, Arg, Option),
|
||||
Options0),
|
||||
group_pairs_by_key(Options0, Grouped),
|
||||
member(Arg-Options, Grouped).
|
||||
|
||||
current_predicate_option_decl(PI, Arg, Option) :-
|
||||
current_predicate_option(PI, Arg, Option0),
|
||||
Option0 =.. [Name|Values],
|
||||
maplist(mode_and_type, Values, Types),
|
||||
Option =.. [Name|Types].
|
||||
|
||||
mode_and_type(Value, ModeAndType) :-
|
||||
copy_term(Value,_,Goals),
|
||||
( memberchk(predicate_option_mode(output, _), Goals)
|
||||
-> ModeAndType = -(Type)
|
||||
; ModeAndType = Type
|
||||
),
|
||||
( memberchk(predicate_option_type(Type, _), Goals)
|
||||
-> true
|
||||
; Type = any
|
||||
).
|
||||
|
||||
define_predicate(PI) :-
|
||||
ground(PI), !,
|
||||
PI = M:Name/Arity,
|
||||
functor(Head, Name, Arity),
|
||||
once(predicate_property(M:Head, _)).
|
||||
define_predicate(_).
|
||||
|
||||
%% derived_predicate_options(:PI, ?Arg, ?Options) is nondet.
|
||||
%
|
||||
% True when Options is the current _derived_ active option
|
||||
% declaration for PI on Arg.
|
||||
|
||||
derived_predicate_options(PI, Arg, Options) :-
|
||||
define_predicate(PI),
|
||||
setof(Arg-Option,
|
||||
derived_predicate_option(PI, Arg, Option),
|
||||
Options0),
|
||||
group_pairs_by_key(Options0, Grouped),
|
||||
member(Arg-Options1, Grouped),
|
||||
PI = M:_,
|
||||
phrase(expand_pass_to_options(Options1, M), Options2),
|
||||
sort(Options2, Options).
|
||||
|
||||
derived_predicate_option(PI, Arg, Decl) :-
|
||||
current_option_arg(PI, Arg, DefM),
|
||||
PI = _:Name/Arity,
|
||||
functor(Head, Name, Arity),
|
||||
has_dynamic_option_decl(DefM),
|
||||
( has_static_option_decl(DefM),
|
||||
DefM:'$pred_option'(Head, Decl, _, [])
|
||||
; DefM:'$dyn_pred_option'(Head, Decl, _, [])
|
||||
).
|
||||
|
||||
%% expand_pass_to_options(+OptionsIn, +Module, -OptionsOut)// is det.
|
||||
%
|
||||
% Expand the options of pass_to(PI,Arg) if PI does not refer to a
|
||||
% public predicate.
|
||||
|
||||
expand_pass_to_options([], _) --> [].
|
||||
expand_pass_to_options([H|T], M) -->
|
||||
expand_pass_to(H, M),
|
||||
expand_pass_to_options(T, M).
|
||||
|
||||
expand_pass_to(pass_to(PI, Arg), Module) -->
|
||||
{ strip_module(Module:PI, M, Name/Arity),
|
||||
functor(Head, Name, Arity),
|
||||
\+ ( predicate_property(M:Head, exported)
|
||||
; predicate_property(M:Head, public)
|
||||
; M == system
|
||||
), !,
|
||||
current_predicate_options(M:Name/Arity, Arg, Options)
|
||||
},
|
||||
list(Options).
|
||||
expand_pass_to(Option, _) -->
|
||||
[Option].
|
||||
|
||||
list([]) --> [].
|
||||
list([H|T]) --> [H], list(T).
|
||||
|
||||
%% derived_predicate_options(+Module) is det.
|
||||
%
|
||||
% Derive predicate option declarations for the given module and
|
||||
% print them to the current output.
|
||||
|
||||
derived_predicate_options(Module) :-
|
||||
var(Module), !,
|
||||
forall(current_module(Module),
|
||||
derived_predicate_options(Module)).
|
||||
derived_predicate_options(Module) :-
|
||||
findall(predicate_options(Module:PI, Arg, Options),
|
||||
( derived_predicate_options(Module:PI, Arg, Options),
|
||||
PI = Name/Arity,
|
||||
functor(Head, Name, Arity),
|
||||
( predicate_property(Module:Head, exported)
|
||||
-> true
|
||||
; predicate_property(Module:Head, public)
|
||||
)
|
||||
),
|
||||
Decls0),
|
||||
maplist(qualify_decl(Module), Decls0, Decls1),
|
||||
sort(Decls1, Decls),
|
||||
( Decls \== []
|
||||
-> format('~N~n~n% Predicate option declarations for module ~q~n~n',
|
||||
[Module]),
|
||||
forall(member(Decl, Decls),
|
||||
portray_clause((:-Decl)))
|
||||
; true
|
||||
).
|
||||
|
||||
qualify_decl(M,
|
||||
predicate_options(PI0, Arg, Options0),
|
||||
predicate_options(PI1, Arg, Options1)) :-
|
||||
qualify(PI0, M, PI1),
|
||||
maplist(qualify_option(M), Options0, Options1).
|
||||
|
||||
qualify_option(M, pass_to(PI0, Arg), pass_to(PI1, Arg)) :- !,
|
||||
qualify(PI0, M, PI1).
|
||||
qualify_option(_, Opt, Opt).
|
||||
|
||||
qualify(M:Term, M, Term) :- !.
|
||||
qualify(QTerm, _, QTerm).
|
||||
|
||||
|
||||
/*******************************
|
||||
* CLEANUP *
|
||||
*******************************/
|
||||
|
||||
%% retractall_predicate_options is det.
|
||||
%
|
||||
% Remove all dynamically (derived) predicate options.
|
||||
|
||||
retractall_predicate_options :-
|
||||
forall(retract(dyn_option_decl(_,M,_)),
|
||||
abolish(M:'$dyn_pred_option'/4)).
|
||||
|
||||
|
||||
/*******************************
|
||||
* COMPILE-TIME CHECKER *
|
||||
*******************************/
|
||||
|
||||
|
||||
:- thread_local
|
||||
new_decl/1.
|
||||
|
||||
%% check_predicate_options is det.
|
||||
%
|
||||
% Analyse loaded program for errornous options. This predicate
|
||||
% decompiles the current program and searches for calls to
|
||||
% predicates that process options. For each option list, it
|
||||
% validates whether the provided options are supported and
|
||||
% validates the argument type. This predicate performs partial
|
||||
% dataflow analysis to track option-lists inside a clause.
|
||||
%
|
||||
% @see derive_predicate_options/0 can be used to derive
|
||||
% declarations for predicates that pass options. This
|
||||
% predicate should normally be called before
|
||||
% check_predicate_options/0.
|
||||
|
||||
check_predicate_options :-
|
||||
forall(current_module(Module),
|
||||
check_predicate_options_module(Module)).
|
||||
|
||||
%% derive_predicate_options is det.
|
||||
%
|
||||
% Derive new predicate option declarations. This predicate
|
||||
% analyses the loaded program to find clauses that process options
|
||||
% using one of the predicates from library(option) or passes
|
||||
% options to other predicates that are known to process options.
|
||||
% The process is repeated until no new declarations are retrieved.
|
||||
%
|
||||
% @see autoload/0 may be used to complete the loaded program.
|
||||
|
||||
derive_predicate_options :-
|
||||
derive_predicate_options(NewDecls),
|
||||
( NewDecls == []
|
||||
-> true
|
||||
; print_message(informational, check_options(new(NewDecls))),
|
||||
new_decls(NewDecls),
|
||||
derive_predicate_options
|
||||
).
|
||||
|
||||
new_decls([]).
|
||||
new_decls([predicate_options(PI, A, O)|T]) :-
|
||||
assert_predicate_options(PI, A, O, _),
|
||||
new_decls(T).
|
||||
|
||||
|
||||
derive_predicate_options(NewDecls) :-
|
||||
call_cleanup(
|
||||
( forall(
|
||||
current_module(Module),
|
||||
forall(
|
||||
( predicate_in_module(Module, PI),
|
||||
PI = Name/Arity,
|
||||
functor(Head, Name, Arity),
|
||||
catch(Module:clause(Head, Body, Ref), _, fail)
|
||||
),
|
||||
check_clause((Head:-Body), Module, Ref, decl))),
|
||||
( setof(Decl, retract(new_decl(Decl)), NewDecls)
|
||||
-> true
|
||||
; NewDecls = []
|
||||
)
|
||||
),
|
||||
retractall(new_decl(_))).
|
||||
|
||||
|
||||
check_predicate_options_module(Module) :-
|
||||
forall(predicate_in_module(Module, PI),
|
||||
check_predicate_options(Module:PI)).
|
||||
|
||||
predicate_in_module(Module, PI) :-
|
||||
current_predicate(Module:PI),
|
||||
PI = Name/Arity,
|
||||
functor(Head, Name, Arity),
|
||||
\+ predicate_property(Module:Head, imported_from(_)).
|
||||
|
||||
%% check_predicate_options(:PredicateIndicator) is det.
|
||||
%
|
||||
% Verify calls to predicates that have options in all clauses of
|
||||
% the predicate indicated by PredicateIndicator.
|
||||
|
||||
check_predicate_options(Module:Name/Arity) :-
|
||||
debug(predicate_options, 'Checking ~q', [Module:Name/Arity]),
|
||||
functor(Head, Name, Arity),
|
||||
forall(catch(Module:clause(Head, Body, Ref), _, fail),
|
||||
check_clause((Head:-Body), Module, Ref, check)).
|
||||
|
||||
%% check_clause(+Clause, +Module, +Ref, +Action) is det.
|
||||
%
|
||||
% Action is one of
|
||||
%
|
||||
% * decl
|
||||
% Create additional declarations
|
||||
% * check
|
||||
% Produce error messages
|
||||
|
||||
check_clause((Head:-Body), M, ClauseRef, Action) :- !,
|
||||
catch(check_body(Body, M, _, Action), E, true),
|
||||
( var(E)
|
||||
-> option_decl(M:Head, Action)
|
||||
; ( clause_info(ClauseRef, File, TermPos, _NameOffset),
|
||||
TermPos = term_position(_,_,_,_,[_,BodyPos]),
|
||||
catch(check_body(Body, M, BodyPos, Action),
|
||||
error(Formal, ArgPos), true),
|
||||
compound(ArgPos),
|
||||
arg(1, ArgPos, CharCount),
|
||||
integer(CharCount)
|
||||
-> Location = file_char_count(File, CharCount)
|
||||
; Location = clause(ClauseRef),
|
||||
E = error(Formal, _)
|
||||
),
|
||||
print_message(error, predicate_option_error(Formal, Location))
|
||||
).
|
||||
|
||||
|
||||
%% check_body(+Body, +Module, +TermPos, +Action)
|
||||
|
||||
check_body(Var, _, _, _) :-
|
||||
var(Var), !.
|
||||
check_body(M:G, _, term_position(_,_,_,_,[_,Pos]), Action) :- !,
|
||||
check_body(G, M, Pos, Action).
|
||||
check_body((A,B), M, term_position(_,_,_,_,[PA,PB]), Action) :- !,
|
||||
check_body(A, M, PA, Action),
|
||||
check_body(B, M, PB, Action).
|
||||
check_body(A=B, _, _, _) :- % partial evaluation
|
||||
unify_with_occurs_check(A,B), !.
|
||||
check_body(Goal, M, term_position(_,_,_,_,ArgPosList), Action) :-
|
||||
callable(Goal),
|
||||
functor(Goal, Name, Arity),
|
||||
( '$get_predicate_attribute'(M:Goal, imported, DefM)
|
||||
-> true
|
||||
; DefM = M
|
||||
),
|
||||
( eval_option_pred(DefM:Goal)
|
||||
-> true
|
||||
; current_option_arg(DefM:Name/Arity, OptArg), !,
|
||||
arg(OptArg, Goal, Options),
|
||||
nth1(OptArg, ArgPosList, ArgPos),
|
||||
check_options(DefM:Name/Arity, OptArg, Options, ArgPos, Action)
|
||||
).
|
||||
check_body(Goal, M, _, Action) :-
|
||||
prolog:called_by(Goal, Called), !,
|
||||
check_called_by(Called, M, Action).
|
||||
check_body(Meta, M, term_position(_,_,_,_,ArgPosList), Action) :-
|
||||
'$get_predicate_attribute'(M:Meta, meta_predicate, Head), !,
|
||||
check_meta_args(1, Head, Meta, M, ArgPosList, Action).
|
||||
check_body(_, _, _, _).
|
||||
|
||||
check_meta_args(I, Head, Meta, M, [ArgPos|ArgPosList], Action) :-
|
||||
arg(I, Head, AS), !,
|
||||
( AS == 0
|
||||
-> arg(I, Meta, MA),
|
||||
check_body(MA, M, ArgPos, Action)
|
||||
; true
|
||||
),
|
||||
succ(I, I2),
|
||||
check_meta_args(I2, Head, Meta, M, ArgPosList, Action).
|
||||
check_meta_args(_,_,_,_, _, _).
|
||||
|
||||
%% check_called_by(+CalledBy, +M, +Action) is det.
|
||||
%
|
||||
% Handle results from prolog:called_by/2.
|
||||
|
||||
check_called_by([], _, _).
|
||||
check_called_by([H|T], M, Action) :-
|
||||
( H = G+N
|
||||
-> ( extend(G, N, G2)
|
||||
-> check_body(G2, M, _, Action)
|
||||
; true
|
||||
)
|
||||
; check_body(H, M, _, Action)
|
||||
),
|
||||
check_called_by(T, M, Action).
|
||||
|
||||
extend(Goal, N, GoalEx) :-
|
||||
callable(Goal),
|
||||
Goal =.. List,
|
||||
length(Extra, N),
|
||||
append(List, Extra, ListEx),
|
||||
GoalEx =.. ListEx.
|
||||
|
||||
|
||||
%% check_options(:Predicate, +OptionArg, +Options, +ArgPos, +Action)
|
||||
%
|
||||
% Verify the list Options, that is passed into Predicate on
|
||||
% argument OptionArg. ArgPos is a term-position term describing
|
||||
% the location of the Options list. If Options is a partial list,
|
||||
% the tail is annotated with pass_to(PI, OptArg).
|
||||
|
||||
check_options(PI, OptArg, QOptions, ArgPos, Action) :-
|
||||
debug(predicate_options, '\tChecking call to ~q', [PI]),
|
||||
remove_qualifier(QOptions, Options),
|
||||
must_be(list_or_partial_list, Options),
|
||||
check_option_list(Options, PI, OptArg, Options, ArgPos, Action).
|
||||
|
||||
remove_qualifier(X, X) :-
|
||||
var(X), !.
|
||||
remove_qualifier(_:X, X) :- !.
|
||||
remove_qualifier(X, X).
|
||||
|
||||
check_option_list(Var, PI, OptArg, _, _, _) :-
|
||||
var(Var), !,
|
||||
annotate(Var, pass_to(PI, OptArg)).
|
||||
check_option_list([], _, _, _, _, _).
|
||||
check_option_list([H|T], PI, OptArg, Options, ArgPos, Action) :-
|
||||
check_option(PI, OptArg, H, ArgPos, Action),
|
||||
check_option_list(T, PI, OptArg, Options, ArgPos, Action).
|
||||
|
||||
check_option(_, _, _, _, decl) :- !.
|
||||
check_option(PI, OptArg, Opt, ArgPos, _) :-
|
||||
catch(check_predicate_option(PI, OptArg, Opt), E, true), !,
|
||||
( var(E)
|
||||
-> true
|
||||
; E = error(Formal,_),
|
||||
throw(error(Formal,ArgPos))
|
||||
).
|
||||
|
||||
|
||||
/*******************************
|
||||
* ANNOTATIONS *
|
||||
*******************************/
|
||||
|
||||
%% annotate(+Var, +Term) is det.
|
||||
%
|
||||
% Use constraints to accumulate annotations about variables. If
|
||||
% two annotated variables are unified, the attributes are joined.
|
||||
|
||||
annotate(Var, Term) :-
|
||||
( get_attr(Var, predopts_analysis, Old)
|
||||
-> put_attr(Var, predopts_analysis, [Term|Old])
|
||||
; var(Var)
|
||||
-> put_attr(Var, predopts_analysis, [Term])
|
||||
; true
|
||||
).
|
||||
|
||||
annotations(Var, Annotations) :-
|
||||
get_attr(Var, predopts_analysis, Annotations).
|
||||
|
||||
predopts_analysis:attr_unify_hook(Opts, Value) :-
|
||||
get_attr(Value, predopts_analysis, Others), !,
|
||||
append(Opts, Others, All),
|
||||
put_attr(Value, predopts_analysis, All).
|
||||
predopts_analysis:attr_unify_hook(_, _).
|
||||
|
||||
|
||||
/*******************************
|
||||
* PARTIAL EVAL *
|
||||
*******************************/
|
||||
|
||||
eval_option_pred(swi_option:option(Opt, Options)) :-
|
||||
processes(Opt, Spec),
|
||||
annotate(Options, Spec).
|
||||
eval_option_pred(swi_option:option(Opt, Options, _Default)) :-
|
||||
processes(Opt, Spec),
|
||||
annotate(Options, Spec).
|
||||
eval_option_pred(swi_option:select_option(Opt, Options, Rest)) :-
|
||||
ignore(unify_with_occurs_check(Rest, Options)),
|
||||
processes(Opt, Spec),
|
||||
annotate(Options, Spec).
|
||||
eval_option_pred(swi_option:select_option(Opt, Options, Rest, _Default)) :-
|
||||
ignore(unify_with_occurs_check(Rest, Options)),
|
||||
processes(Opt, Spec),
|
||||
annotate(Options, Spec).
|
||||
eval_option_pred(swi_option:meta_options(_Cond, QOptionsIn, QOptionsOut)) :-
|
||||
remove_qualifier(QOptionsIn, OptionsIn),
|
||||
remove_qualifier(QOptionsOut, OptionsOut),
|
||||
ignore(unify_with_occurs_check(OptionsIn, OptionsOut)).
|
||||
|
||||
processes(Opt, Spec) :-
|
||||
compound(Opt),
|
||||
functor(Opt, OptName, 1),
|
||||
Spec =.. [OptName,any].
|
||||
|
||||
|
||||
/*******************************
|
||||
* NEW DECLARTIONS *
|
||||
*******************************/
|
||||
|
||||
%% option_decl(:Head, +Action) is det.
|
||||
%
|
||||
% Add new declarations based on attributes left by the analysis
|
||||
% pass. We do not add declarations for system modules or modules
|
||||
% that already contain static declarations.
|
||||
%
|
||||
% @tbd Should we add a mode to include generating declarations
|
||||
% for system modules and modules with static declarations?
|
||||
|
||||
option_decl(_, check) :- !.
|
||||
option_decl(M:_, _) :-
|
||||
system_module(M), !.
|
||||
option_decl(M:_, _) :-
|
||||
has_static_option_decl(M), !.
|
||||
option_decl(M:Head, _) :-
|
||||
arg(AP, Head, QA),
|
||||
remove_qualifier(QA, A),
|
||||
annotations(A, Annotations0),
|
||||
functor(Head, Name, Arity),
|
||||
PI = M:Name/Arity,
|
||||
delete(Annotations0, pass_to(PI,AP), Annotations),
|
||||
Annotations \== [],
|
||||
Decl = predicate_options(PI, AP, Annotations),
|
||||
( new_decl(Decl)
|
||||
-> true
|
||||
; assert_predicate_options(M:Name/Arity, AP, Annotations, false)
|
||||
-> true
|
||||
; assertz(new_decl(Decl)),
|
||||
debug(predicate_options(decl), '~q', [Decl])
|
||||
),
|
||||
fail.
|
||||
option_decl(_, _).
|
||||
|
||||
system_module(system) :- !.
|
||||
system_module(Module) :-
|
||||
sub_atom(Module, 0, _, _, $).
|
||||
|
||||
|
||||
/*******************************
|
||||
* MISC *
|
||||
*******************************/
|
||||
|
||||
canonical_pi(M:Name//Arity, M:Name/PArity) :-
|
||||
integer(Arity),
|
||||
PArity is Arity+2.
|
||||
canonical_pi(PI, PI).
|
||||
|
||||
%% resolve_module(:PI, -DefPI) is det.
|
||||
%
|
||||
% Find the real predicate indicator pointing to the definition
|
||||
% module of PI. This is similar to using predicate_property/3 with
|
||||
% the property imported_from, but using
|
||||
% '$get_predicate_attribute'/3 avoids auto-importing the
|
||||
% predicate.
|
||||
|
||||
resolve_module(Module:Name/Arity, DefM:Name/Arity) :-
|
||||
functor(Head, Name, Arity),
|
||||
( '$get_predicate_attribute'(Module:Head, imported, M)
|
||||
-> DefM = M
|
||||
; DefM = Module
|
||||
).
|
||||
|
||||
|
||||
/*******************************
|
||||
* MESSAGES *
|
||||
*******************************/
|
||||
:- multifile
|
||||
prolog:message//1.
|
||||
|
||||
prolog:message(predicate_option_error(Formal, Location)) -->
|
||||
error_location(Location),
|
||||
'$messages':term_message(Formal). % TBD: clean interface
|
||||
prolog:message(check_options(new(Decls))) -->
|
||||
[ 'Inferred declarations:'-[], nl ],
|
||||
new_decls(Decls).
|
||||
|
||||
error_location(file_char_count(File, CharPos)) -->
|
||||
{ filepos_line(File, CharPos, Line, LinePos) },
|
||||
[ '~w:~d:~d: '-[File, Line, LinePos] ].
|
||||
error_location(clause(ClauseRef)) -->
|
||||
{ clause_property(ClauseRef, file(File)),
|
||||
clause_property(ClauseRef, line_count(Line))
|
||||
}, !,
|
||||
[ '~w:~d: '-[File, Line] ].
|
||||
error_location(clause(ClauseRef)) -->
|
||||
[ 'Clause ~q: '-[ClauseRef] ].
|
||||
|
||||
filepos_line(File, CharPos, Line, LinePos) :-
|
||||
setup_call_cleanup(
|
||||
( open(File, read, In),
|
||||
open_null_stream(Out)
|
||||
),
|
||||
( Skip is CharPos-1,
|
||||
copy_stream_data(In, Out, Skip),
|
||||
stream_property(In, position(Pos)),
|
||||
stream_position_data(line_count, Pos, Line),
|
||||
stream_position_data(line_position, Pos, LinePos)
|
||||
),
|
||||
( close(Out),
|
||||
close(In)
|
||||
)).
|
||||
|
||||
new_decls([]) --> [].
|
||||
new_decls([H|T]) -->
|
||||
[ ' :- ~q'-[H], nl ],
|
||||
new_decls(T).
|
||||
|
||||
|
||||
/*******************************
|
||||
* SYSTEM DECLARATIONS *
|
||||
*******************************/
|
||||
|
||||
:- use_module(library(dialect/swi/syspred_options)).
|
||||
141
LGPL/predopts.pl
Normal file
141
LGPL/predopts.pl
Normal file
@ -0,0 +1,141 @@
|
||||
/* Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: J.Wielemaker@cs.vu.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2011, VU University Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
:- module('$predopts',
|
||||
[
|
||||
]).
|
||||
|
||||
:- multifile
|
||||
predicate_options:option_decl/3,
|
||||
predicate_options:pred_option/3.
|
||||
:- multifile % provided by library(predicate_options)
|
||||
system:predicate_option_type/2,
|
||||
system:predicate_option_mode/2.
|
||||
|
||||
:- public
|
||||
option_clauses//4.
|
||||
|
||||
%% expand_predicate_options(:PI, +Arg, +OptionList, -Clauses) is det.
|
||||
%
|
||||
% Term-expansion code for predicate_options(PI, Arg, OptionList).
|
||||
|
||||
expand_predicate_options(PI, Arg, Options,
|
||||
[ predicate_options:option_decl(Head, M, Arg),
|
||||
(:-multifile(M:'$pred_option'/4))
|
||||
| OptionClauses
|
||||
]) :-
|
||||
canonical_pi(PI, CPI),
|
||||
prolog_load_context(module, M0),
|
||||
strip_module(M0:CPI, M, Name/Arity),
|
||||
functor(Head, Name, Arity),
|
||||
( is_list(Options)
|
||||
-> true
|
||||
; throw(error(type_error(list, Options), _))
|
||||
),
|
||||
phrase(option_clauses(Options, Head, M, Arg), OptionClauses0),
|
||||
qualify_list(OptionClauses0, M0, OptionClauses).
|
||||
|
||||
qualify_list([], _, []).
|
||||
qualify_list([H0|T0], M, [H|T]) :-
|
||||
qualify(H0, M, H),
|
||||
qualify_list(T0, M, T).
|
||||
|
||||
qualify(M:Term, M, Term) :- !.
|
||||
qualify(QTerm, _, QTerm).
|
||||
|
||||
|
||||
option_clauses([], _, _, _) --> [].
|
||||
option_clauses([H|T], Head, M, A) -->
|
||||
option_clause(H, Head, M),
|
||||
option_clauses(T, Head, M, A).
|
||||
|
||||
option_clause(Var, _, _) -->
|
||||
{ var(Var), !,
|
||||
throw(error(instantiation_error, _))
|
||||
}.
|
||||
option_clause(pass_to(PI0, Arg), Head, M) --> !,
|
||||
{ canonical_pi(PI0, PI),
|
||||
strip_module(M:PI, TM, Name/Arity),
|
||||
functor(THead, Name, Arity),
|
||||
Clause = ('$pred_option'(Head, pass_to(PI0, Arg), Opt, Seen) :-
|
||||
\+ memberchk(PI-Arg, Seen),
|
||||
predicate_options:pred_option(TM:THead, Opt, [PI-Arg|Seen]))
|
||||
},
|
||||
[ M:Clause ].
|
||||
option_clause(Option, Head, M) -->
|
||||
{ Option =.. [Name|ModeAndTypes], !,
|
||||
modes_and_types(ModeAndTypes, Args, Body),
|
||||
Opt =.. [Name|Args],
|
||||
Clause = ('$pred_option'(Head, Option, Opt, _) :- Body)
|
||||
},
|
||||
[ M:Clause ].
|
||||
option_clause(Option, _, _) -->
|
||||
{ throw(error(type_error(option_specifier, Option)))
|
||||
}.
|
||||
|
||||
modes_and_types([], [], true).
|
||||
modes_and_types([H|T], [A|AT], Body) :-
|
||||
mode_and_type(H, A, Body0),
|
||||
( T == []
|
||||
-> Body = Body0,
|
||||
AT = []
|
||||
; Body0 == true
|
||||
-> modes_and_types(T, AT, Body)
|
||||
; Body = (Body0,Body1),
|
||||
modes_and_types(T, AT, Body1)
|
||||
).
|
||||
|
||||
|
||||
mode_and_type(-Type, A, (predicate_option_mode(output, A), Body)) :- !,
|
||||
type_goal(Type, A, Body).
|
||||
mode_and_type(+Type, A, Body) :- !,
|
||||
type_goal(Type, A, Body).
|
||||
mode_and_type(Type, A, Body) :-
|
||||
type_goal(Type, A, Body).
|
||||
|
||||
type_goal(Type, A, predicate_option_type(Type, A)).
|
||||
|
||||
|
||||
%% canonical_pi(+PIIn, -PIout)
|
||||
|
||||
canonical_pi(M:Name//Arity, M:Name/PArity) :-
|
||||
integer(Arity), !,
|
||||
PArity is Arity+2.
|
||||
canonical_pi(Name//Arity, Name/PArity) :-
|
||||
integer(Arity), !,
|
||||
PArity is Arity+2.
|
||||
canonical_pi(PI, PI).
|
||||
|
||||
|
||||
/*******************************
|
||||
* EXPAND *
|
||||
*******************************/
|
||||
|
||||
%system:term_expansion((:- predicate_options(PI, Arg, Options)), Clauses) :-
|
||||
% expand_predicate_options(PI, Arg, Options, Clauses).
|
||||
675
LGPL/prolog_clause.pl
Normal file
675
LGPL/prolog_clause.pl
Normal file
@ -0,0 +1,675 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: J.Wielemaker@vu.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2011, University of Amsterdam
|
||||
VU University Amsterdam
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public License
|
||||
as published by the Free Software Foundation; either version 2
|
||||
of the License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||||
|
||||
As a special exception, if you link this library with other files,
|
||||
compiled with a Free Software compiler, to produce an executable, this
|
||||
library does not by itself cause the resulting executable to be covered
|
||||
by the GNU General Public License. This exception does not however
|
||||
invalidate any other reasons why the executable file might be covered by
|
||||
the GNU General Public License.
|
||||
*/
|
||||
|
||||
|
||||
:- module(prolog_clause,
|
||||
[ clause_info/4, % +ClauseRef, -File, -TermPos, -VarNames
|
||||
predicate_name/2, % +Head, -Name
|
||||
clause_name/2 % +ClauseRef, -Name
|
||||
]).
|
||||
:- use_module(library(lists), [append/3]).
|
||||
:- use_module(library(occurs), [sub_term/2]).
|
||||
:- use_module(library(debug)).
|
||||
:- use_module(library(listing)).
|
||||
:- use_module(library(prolog_source)).
|
||||
|
||||
|
||||
:- public % called from library(trace/clause)
|
||||
unify_term/2,
|
||||
make_varnames/5,
|
||||
do_make_varnames/3.
|
||||
|
||||
:- multifile
|
||||
make_varnames_hook/5.
|
||||
|
||||
/** <module> Get detailed source-information about a clause
|
||||
|
||||
This module started life as part of the GUI tracer. As it is generally
|
||||
useful for debugging purposes it has moved to the general Prolog
|
||||
library.
|
||||
|
||||
The tracer library library(trace/clause) adds caching and dealing with
|
||||
dynamic predicates using listing to XPCE objects to this. Note that
|
||||
clause_info/4 as below can be slow.
|
||||
*/
|
||||
|
||||
%% clause_info(+ClauseRef, -File, -TermPos, -VarNames)
|
||||
%
|
||||
% Fetches source information for the given clause. File is the
|
||||
% file from which the clause was loaded. TermPos describes the
|
||||
% source layout in a format compatible to the subterm_positions
|
||||
% option of read_term/2. VarNames provides access to the variable
|
||||
% allocation in a stack-frame. See make_varnames/5 for details.
|
||||
|
||||
clause_info(ClauseRef, File, TermPos, NameOffset) :-
|
||||
( debugging(clause_info)
|
||||
-> clause_name(ClauseRef, Name),
|
||||
debug(clause_info, 'clause_info(~w) (~w)... ',
|
||||
[ClauseRef, Name])
|
||||
; true
|
||||
),
|
||||
clause_property(ClauseRef, file(File)),
|
||||
'$clause'(Head, Body, ClauseRef, VarOffset),
|
||||
( Body == true
|
||||
-> DecompiledClause = Head
|
||||
; DecompiledClause = (Head :- Body)
|
||||
),
|
||||
File \== user, % loaded using ?- [user].
|
||||
clause_property(ClauseRef, line_count(LineNo)),
|
||||
( module_property(Module, file(File))
|
||||
-> true
|
||||
; strip_module(user:Head, Module, _)
|
||||
),
|
||||
debug(clause_info, 'from ~w:~d ... ', [File, LineNo]),
|
||||
read_term_at_line(File, LineNo, Module, Clause, TermPos0, VarNames),
|
||||
debug(clause_info, 'read ...', []),
|
||||
unify_clause(Clause, DecompiledClause, Module, TermPos0, TermPos),
|
||||
debug(clause_info, 'unified ...', []),
|
||||
make_varnames(Clause, DecompiledClause, VarOffset, VarNames, NameOffset),
|
||||
debug(clause_info, 'got names~n', []), !.
|
||||
|
||||
%% unify_term(+T1, +T2)
|
||||
%
|
||||
% Unify the two terms, where T2 is created by writing the term and
|
||||
% reading it back in, but be aware that rounding problems may
|
||||
% cause floating point numbers not to unify. Also, if the initial
|
||||
% term has a string object, it is written as "..." and read as a
|
||||
% code-list. We compensate for that.
|
||||
%
|
||||
% NOTE: Called directly from library(trace/clause) for the GUI
|
||||
% tracer.
|
||||
|
||||
unify_term(X, X) :- !.
|
||||
unify_term(X1, X2) :-
|
||||
compound(X1),
|
||||
compound(X2),
|
||||
functor(X1, F, Arity),
|
||||
functor(X2, F, Arity), !,
|
||||
unify_args(0, Arity, X1, X2).
|
||||
unify_term(X, Y) :-
|
||||
float(X), float(Y), !.
|
||||
unify_term(X, Y) :-
|
||||
string(X),
|
||||
is_list(Y),
|
||||
string_to_list(X, Y), !.
|
||||
unify_term(_, Y) :-
|
||||
Y == '...', !. % elipses left by max_depth
|
||||
unify_term(_:X, Y) :-
|
||||
unify_term(X, Y), !.
|
||||
unify_term(X, _:Y) :-
|
||||
unify_term(X, Y), !.
|
||||
unify_term(X, Y) :-
|
||||
format('[INTERNAL ERROR: Diff:~n'),
|
||||
portray_clause(X),
|
||||
format('~N*** <->~n'),
|
||||
portray_clause(Y),
|
||||
break.
|
||||
|
||||
unify_args(N, N, _, _) :- !.
|
||||
unify_args(I, Arity, T1, T2) :-
|
||||
A is I + 1,
|
||||
arg(A, T1, A1),
|
||||
arg(A, T2, A2),
|
||||
unify_term(A1, A2),
|
||||
unify_args(A, Arity, T1, T2).
|
||||
|
||||
|
||||
%% read_term_at_line(+File, +Line, +Module,
|
||||
%% -Clause, -TermPos, -VarNames) is semidet.
|
||||
%
|
||||
% Read a term from File at Line.
|
||||
|
||||
read_term_at_line(File, Line, Module, Clause, TermPos, VarNames) :-
|
||||
catch(open(File, read, In), _, fail),
|
||||
call_cleanup(
|
||||
read_source_term_at_location(
|
||||
In, Clause,
|
||||
[ line(Line),
|
||||
module(Module),
|
||||
subterm_positions(TermPos),
|
||||
variable_names(VarNames)
|
||||
]),
|
||||
close(In)).
|
||||
|
||||
|
||||
%% make_varnames(+ReadClause, +DecompiledClause,
|
||||
%% +Offsets, +Names, -Term) is det.
|
||||
%
|
||||
% Create a Term varnames(...) where each argument contains the name
|
||||
% of the variable at that offset. If the read Clause is a DCG rule,
|
||||
% name the two last arguments <DCG_list> and <DCG_tail>
|
||||
%
|
||||
% This predicate calles the multifile predicate
|
||||
% make_varnames_hook/5 with the same arguments to allow for user
|
||||
% extensions. Extending this predicate is needed if a compiler
|
||||
% adds additional arguments to the clause head that must be made
|
||||
% visible in the GUI tracer.
|
||||
%
|
||||
% @param Offsets List of Offset=Var
|
||||
% @param Names List of Name=Var
|
||||
|
||||
make_varnames(ReadClause, DecompiledClause, Offsets, Names, Term) :-
|
||||
make_varnames_hook(ReadClause, DecompiledClause, Offsets, Names, Term), !.
|
||||
make_varnames((Head --> _Body), _, Offsets, Names, Bindings) :- !,
|
||||
functor(Head, _, Arity),
|
||||
In is Arity,
|
||||
memberchk(In=IVar, Offsets),
|
||||
Names1 = ['<DCG_list>'=IVar|Names],
|
||||
Out is Arity + 1,
|
||||
memberchk(Out=OVar, Offsets),
|
||||
Names2 = ['<DCG_tail>'=OVar|Names1],
|
||||
make_varnames(xx, xx, Offsets, Names2, Bindings).
|
||||
make_varnames(_, _, Offsets, Names, Bindings) :-
|
||||
length(Offsets, L),
|
||||
functor(Bindings, varnames, L),
|
||||
do_make_varnames(Offsets, Names, Bindings).
|
||||
|
||||
do_make_varnames([], _, _).
|
||||
do_make_varnames([N=Var|TO], Names, Bindings) :-
|
||||
( find_varname(Var, Names, Name)
|
||||
-> true
|
||||
; Name = '_'
|
||||
),
|
||||
AN is N + 1,
|
||||
arg(AN, Bindings, Name),
|
||||
do_make_varnames(TO, Names, Bindings).
|
||||
|
||||
find_varname(Var, [Name = TheVar|_], Name) :-
|
||||
Var == TheVar, !.
|
||||
find_varname(Var, [_|T], Name) :-
|
||||
find_varname(Var, T, Name).
|
||||
|
||||
%% unify_clause(+Read, +Decompiled, +Module, +ReadTermPos,
|
||||
%% -RecompiledTermPos).
|
||||
%
|
||||
% What you read isn't always what goes into the database. The task
|
||||
% of this predicate is to establish the relation between the term
|
||||
% read from the file and the result from decompiling the clause.
|
||||
%
|
||||
% This predicate calls the multifile predicate unify_clause_hook/5
|
||||
% with the same arguments to support user extensions.
|
||||
%
|
||||
% @tbd This really must be more flexible, dealing with much
|
||||
% more complex source-translations, falling back to a
|
||||
% heuristic method locating as much as possible.
|
||||
|
||||
:- multifile
|
||||
unify_clause_hook/5.
|
||||
|
||||
unify_clause(Read, Read, _, TermPos, TermPos) :- !.
|
||||
% XPCE send-methods
|
||||
unify_clause(Read, Decompiled, Module, TermPoso, TermPos) :-
|
||||
unify_clause_hook(Read, Decompiled, Module, TermPoso, TermPos), !.
|
||||
unify_clause(:->(Head, Body), (PlHead :- PlBody), _, TermPos0, TermPos) :- !,
|
||||
pce_method_clause(Head, Body, PlHead, PlBody, TermPos0, TermPos).
|
||||
% XPCE get-methods
|
||||
unify_clause(:<-(Head, Body), (PlHead :- PlBody), _, TermPos0, TermPos) :- !,
|
||||
pce_method_clause(Head, Body, PlHead, PlBody, TermPos0, TermPos).
|
||||
% Unit test clauses
|
||||
unify_clause((TH :- Body),
|
||||
(_:'unit body'(_, _) :- !, Body), _,
|
||||
TP0, TP) :-
|
||||
( TH = test(_,_)
|
||||
; TH = test(_)
|
||||
), !,
|
||||
TP0 = term_position(F,T,FF,FT,[HP,BP]),
|
||||
TP = term_position(F,T,FF,FT,[HP,term_position(0,0,0,0,[FF-FT,BP])]).
|
||||
% module:head :- body
|
||||
unify_clause((Head :- Read),
|
||||
(Head :- _M:Compiled), Module, TermPos0, TermPos) :-
|
||||
unify_clause((Head :- Read), (Head :- Compiled), Module, TermPos0, TermPos1),
|
||||
TermPos1 = term_position(TA,TZ,FA,FZ,[PH,PB]),
|
||||
TermPos = term_position(TA,TZ,FA,FZ,
|
||||
[ PH,
|
||||
term_position(0,0,0,0,[0-0,PB])
|
||||
]).
|
||||
unify_clause(Read, Compiled1, Module, TermPos0, TermPos) :-
|
||||
Read = (_ --> List, _),
|
||||
is_list(List),
|
||||
ci_expand(Read, Compiled2, Module),
|
||||
Compiled2 = (DH :- _),
|
||||
functor(DH, _, Arity),
|
||||
DArg is Arity - 1,
|
||||
arg(DArg, DH, List),
|
||||
nonvar(List),
|
||||
TermPos0 = term_position(F,T,FF,FT,[ HP,
|
||||
term_position(_,_,_,_,[_,BP])
|
||||
]), !,
|
||||
TermPos1 = term_position(F,T,FF,FT,[ HP, BP ]),
|
||||
match_module(Compiled2, Compiled1, TermPos1, TermPos).
|
||||
% general term-expansion
|
||||
unify_clause(Read, Compiled1, Module, TermPos0, TermPos) :-
|
||||
ci_expand(Read, Compiled2, Module),
|
||||
match_module(Compiled2, Compiled1, TermPos0, TermPos).
|
||||
% I don't know ...
|
||||
unify_clause(_, _, _, _, _) :-
|
||||
debug(clause_info, 'Could not unify clause', []),
|
||||
fail.
|
||||
|
||||
unify_clause_head(H1, H2) :-
|
||||
strip_module(H1, _, H),
|
||||
strip_module(H2, _, H).
|
||||
|
||||
ci_expand(Read, Compiled, Module) :-
|
||||
catch(setup_call_cleanup('$set_source_module'(Old, Module),
|
||||
expand_term(Read, Compiled),
|
||||
'$set_source_module'(_, Old)),
|
||||
E,
|
||||
expand_failed(E, Read)).
|
||||
|
||||
match_module((H1 :- B1), (H2 :- B2), Pos0, Pos) :- !,
|
||||
unify_clause_head(H1, H2),
|
||||
unify_body(B1, B2, Pos0, Pos).
|
||||
match_module(H1, H2, Pos, Pos) :- % deal with facts
|
||||
unify_clause_head(H1, H2).
|
||||
|
||||
%% expand_failed(+Exception, +Term)
|
||||
%
|
||||
% When debugging, indicate that expansion of the term failed.
|
||||
|
||||
expand_failed(E, Read) :-
|
||||
debugging(clause_info),
|
||||
message_to_string(E, Msg),
|
||||
debug(clause_info, 'Term-expand ~p failed: ~w', [Read, Msg]),
|
||||
fail.
|
||||
|
||||
%% unify_body(+Read, +Decompiled, +Pos0, -Pos)
|
||||
%
|
||||
% Deal with translations implied by the compiler. For example,
|
||||
% compiling (a,b),c yields the same code as compiling a,b,c.
|
||||
%
|
||||
% Pos0 and Pos still include the term-position of the head.
|
||||
|
||||
unify_body(B, B, Pos, Pos) :-
|
||||
does_not_dcg_after_binding(B, Pos), !.
|
||||
unify_body(R, D,
|
||||
term_position(F,T,FF,FT,[HP,BP0]),
|
||||
term_position(F,T,FF,FT,[HP,BP])) :-
|
||||
ubody(R, D, BP0, BP).
|
||||
|
||||
%% does_not_dcg_after_binding(+ReadBody, +ReadPos) is semidet.
|
||||
%
|
||||
% True if ReadPos/ReadPos does not contain DCG delayed
|
||||
% unifications.
|
||||
%
|
||||
% @tbd We should pass that we are in a DCG; if we are not there
|
||||
% is no reason for this test.
|
||||
|
||||
does_not_dcg_after_binding(B, Pos) :-
|
||||
acyclic_term(B), % X = call(X)
|
||||
\+ sub_term(brace_term_position(_,_,_), Pos),
|
||||
\+ (sub_term((Cut,_=_), B), Cut == !), !.
|
||||
|
||||
|
||||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
Some remarks.
|
||||
|
||||
a --> { x, y, z }.
|
||||
This is translated into "(x,y),z), X=Y" by the DCG translator, after
|
||||
which the compiler creates "a(X,Y) :- x, y, z, X=Y".
|
||||
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||||
|
||||
%% ubody(+Read, +Decompiled, +TermPosRead, -TermPosForDecompiled)
|
||||
%
|
||||
% @param Read Clause read _after_ expand_term/2
|
||||
% @param Decompiled Decompiled clause
|
||||
% @param TermPosRead Sub-term positions of source
|
||||
|
||||
ubody(B, B, P, P) :-
|
||||
does_not_dcg_after_binding(B, P), !.
|
||||
ubody(X, call(X), % X = call(X)
|
||||
From-To,
|
||||
term_position(From, To, From, To, [From-To])) :- !.
|
||||
ubody(B0, B,
|
||||
brace_term_position(F,T,A0),
|
||||
Pos) :-
|
||||
B0 = (_,_=_), !,
|
||||
T1 is T - 1,
|
||||
ubody(B0, B,
|
||||
term_position(F,T,
|
||||
F,T,
|
||||
[A0,T1-T]),
|
||||
Pos).
|
||||
ubody(B0, B,
|
||||
brace_term_position(F,T,A0),
|
||||
term_position(F,T,F,T,[A])) :- !,
|
||||
ubody(B0, B, A0, A).
|
||||
ubody(C0, C, P0, P) :-
|
||||
nonvar(C0), nonvar(C),
|
||||
C0 = (_,_), C = (_,_), !,
|
||||
conj(C0, P0, GL, PL),
|
||||
mkconj(C, P, GL, PL).
|
||||
ubody(X0, X,
|
||||
term_position(F,T,FF,TT,PA0),
|
||||
term_position(F,T,FF,TT,PA)) :-
|
||||
meta(X0), !,
|
||||
X0 =.. [_|A0],
|
||||
X =.. [_|A],
|
||||
ubody_list(A0, A, PA0, PA).
|
||||
% 5.7.X optimizations
|
||||
ubody(_=_, true, % singleton = Any
|
||||
term_position(F,T,_FF,_TT,_PA),
|
||||
F-T) :- !.
|
||||
ubody(_==_, fail, % singleton/firstvar == Any
|
||||
term_position(F,T,_FF,_TT,_PA),
|
||||
F-T) :- !.
|
||||
ubody(A1=B1, B2=A2, % Term = Var --> Var = Term
|
||||
term_position(F,T,FF,TT,[PA1,PA2]),
|
||||
term_position(F,T,FF,TT,[PA2,PA1])) :-
|
||||
(A1==B1) =@= (B2==A2), !,
|
||||
A1 = A2, B1=B2.
|
||||
ubody(A1==B1, B2==A2, % const == Var --> Var == const
|
||||
term_position(F,T,FF,TT,[PA1,PA2]),
|
||||
term_position(F,T,FF,TT,[PA2,PA1])) :-
|
||||
(A1==B1) =@= (B2==A2), !,
|
||||
A1 = A2, B1=B2.
|
||||
ubody(A is B - C, A is B + C2, Pos, Pos) :-
|
||||
integer(C),
|
||||
C2 =:= -C, !.
|
||||
|
||||
ubody_list([], [], [], []).
|
||||
ubody_list([G0|T0], [G|T], [PA0|PAT0], [PA|PAT]) :-
|
||||
ubody(G0, G, PA0, PA),
|
||||
ubody_list(T0, T, PAT0, PAT).
|
||||
|
||||
|
||||
conj(Goal, Pos, GoalList, PosList) :-
|
||||
conj(Goal, Pos, GoalList, [], PosList, []).
|
||||
|
||||
conj((A,B), term_position(_,_,_,_,[PA,PB]), GL, TG, PL, TP) :- !,
|
||||
conj(A, PA, GL, TGA, PL, TPA),
|
||||
conj(B, PB, TGA, TG, TPA, TP).
|
||||
conj((A,B), brace_term_position(_,T,PA), GL, TG, PL, TP) :-
|
||||
B = (_=_), !,
|
||||
conj(A, PA, GL, TGA, PL, TPA),
|
||||
T1 is T - 1,
|
||||
conj(B, T1-T, TGA, TG, TPA, TP).
|
||||
conj((!,(S=SR)), F-T, [!,S=SR|TG], TG, [F-T,F1-T1|TP], TP) :-
|
||||
F1 is F+1,
|
||||
T1 is T+1.
|
||||
conj(A, P, [A|TG], TG, [P|TP], TP).
|
||||
|
||||
|
||||
mkconj(Goal, Pos, GoalList, PosList) :-
|
||||
mkconj(Goal, Pos, GoalList, [], PosList, []).
|
||||
|
||||
mkconj(Conj, term_position(0,0,0,0,[PA,PB]), GL, TG, PL, TP) :-
|
||||
nonvar(Conj),
|
||||
Conj = (A,B), !,
|
||||
mkconj(A, PA, GL, TGA, PL, TPA),
|
||||
mkconj(B, PB, TGA, TG, TPA, TP).
|
||||
mkconj(A0, P0, [A|TG], TG, [P|TP], TP) :-
|
||||
ubody(A, A0, P, P0).
|
||||
|
||||
|
||||
/*******************************
|
||||
* PCE STUFF (SHOULD MOVE) *
|
||||
*******************************/
|
||||
|
||||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
<method>(Receiver, ... Arg ...) :->
|
||||
Body
|
||||
|
||||
mapped to:
|
||||
|
||||
send_implementation(Id, <method>(...Arg...), Receiver)
|
||||
|
||||
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||||
|
||||
pce_method_clause(Head, Body, _:PlHead, PlBody, TermPos0, TermPos) :- !,
|
||||
pce_method_clause(Head, Body, PlBody, PlHead, TermPos0, TermPos).
|
||||
pce_method_clause(Head, Body,
|
||||
send_implementation(_Id, Msg, Receiver), PlBody,
|
||||
TermPos0, TermPos) :- !,
|
||||
debug(clause_info, 'send method ...', []),
|
||||
arg(1, Head, Receiver),
|
||||
functor(Head, _, Arity),
|
||||
pce_method_head_arguments(2, Arity, Head, Msg),
|
||||
debug(clause_info, 'head ...', []),
|
||||
pce_method_body(Body, PlBody, TermPos0, TermPos).
|
||||
pce_method_clause(Head, Body,
|
||||
get_implementation(_Id, Msg, Receiver, Result), PlBody,
|
||||
TermPos0, TermPos) :- !,
|
||||
debug(clause_info, 'get method ...', []),
|
||||
arg(1, Head, Receiver),
|
||||
debug(clause_info, 'receiver ...', []),
|
||||
functor(Head, _, Arity),
|
||||
arg(Arity, Head, PceResult),
|
||||
debug(clause_info, '~w?~n', [PceResult = Result]),
|
||||
pce_unify_head_arg(PceResult, Result),
|
||||
Ar is Arity - 1,
|
||||
pce_method_head_arguments(2, Ar, Head, Msg),
|
||||
debug(clause_info, 'head ...', []),
|
||||
pce_method_body(Body, PlBody, TermPos0, TermPos).
|
||||
|
||||
pce_method_head_arguments(N, Arity, Head, Msg) :-
|
||||
N =< Arity, !,
|
||||
arg(N, Head, PceArg),
|
||||
PLN is N - 1,
|
||||
arg(PLN, Msg, PlArg),
|
||||
pce_unify_head_arg(PceArg, PlArg),
|
||||
debug(clause_info, '~w~n', [PceArg = PlArg]),
|
||||
NextArg is N+1,
|
||||
pce_method_head_arguments(NextArg, Arity, Head, Msg).
|
||||
pce_method_head_arguments(_, _, _, _).
|
||||
|
||||
pce_unify_head_arg(V, A) :-
|
||||
var(V), !,
|
||||
V = A.
|
||||
pce_unify_head_arg(A:_=_, A) :- !.
|
||||
pce_unify_head_arg(A:_, A).
|
||||
|
||||
% pce_method_body(+SrcBody, +DbBody, +TermPos0, -TermPos
|
||||
%
|
||||
% Unify the body of an XPCE method. Goal-expansion makes this
|
||||
% rather tricky, especially as we cannot call XPCE's expansion
|
||||
% on an isolated method.
|
||||
%
|
||||
% TermPos0 is the term-position term of the whole clause!
|
||||
%
|
||||
% Further, please note that the body of the method-clauses reside
|
||||
% in another module than pce_principal, and therefore the body
|
||||
% starts with an I_CONTEXT call. This implies we need a
|
||||
% hypothetical term-position for the module-qualifier.
|
||||
|
||||
pce_method_body(A0, A, TermPos0, TermPos) :-
|
||||
TermPos0 = term_position(F, T, FF, FT,
|
||||
[ HeadPos,
|
||||
BodyPos0
|
||||
]),
|
||||
TermPos = term_position(F, T, FF, FT,
|
||||
[ HeadPos,
|
||||
term_position(0,0,0,0, [0-0,BodyPos])
|
||||
]),
|
||||
pce_method_body2(A0, A, BodyPos0, BodyPos).
|
||||
|
||||
|
||||
pce_method_body2(::(_,A0), A, TermPos0, TermPos) :- !,
|
||||
TermPos0 = term_position(_, _, _, _, [_Cmt,BodyPos0]),
|
||||
TermPos = BodyPos,
|
||||
expand_goal(A0, A, BodyPos0, BodyPos).
|
||||
pce_method_body2(A0, A, TermPos0, TermPos) :-
|
||||
A0 =.. [Func,B0,C0],
|
||||
control_op(Func), !,
|
||||
A =.. [Func,B,C],
|
||||
TermPos0 = term_position(F, T, FF, FT,
|
||||
[ BP0,
|
||||
CP0
|
||||
]),
|
||||
TermPos = term_position(F, T, FF, FT,
|
||||
[ BP,
|
||||
CP
|
||||
]),
|
||||
pce_method_body2(B0, B, BP0, BP),
|
||||
expand_goal(C0, C, CP0, CP).
|
||||
pce_method_body2(A0, A, TermPos0, TermPos) :-
|
||||
expand_goal(A0, A, TermPos0, TermPos).
|
||||
|
||||
control_op(',').
|
||||
control_op((;)).
|
||||
control_op((->)).
|
||||
control_op((*->)).
|
||||
|
||||
/*******************************
|
||||
* EXPAND_GOAL SUPPORT *
|
||||
*******************************/
|
||||
|
||||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
With the introduction of expand_goal, it is increasingly hard to relate
|
||||
the clause from the database to the actual source. For one thing, we do
|
||||
not know the compilation module of the clause (unless we want to
|
||||
decompile it).
|
||||
|
||||
Goal expansion can translate goals into control-constructs, multiple
|
||||
clauses, or delete a subgoal.
|
||||
|
||||
To keep track of the source-locations, we have to redo the analysis of
|
||||
the clause as defined in init.pl
|
||||
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||||
|
||||
expand_goal(G, call(G), P, term_position(0,0,0,0,[P])) :-
|
||||
var(G), !.
|
||||
expand_goal(G, G, P, P) :-
|
||||
var(G), !.
|
||||
expand_goal(M0, M, P0, P) :-
|
||||
meta(M0), !,
|
||||
P0 = term_position(F,T,FF,FT,PL0),
|
||||
P = term_position(F,T,FF,FT,PL),
|
||||
functor(M0, Functor, Arity),
|
||||
functor(M, Functor, Arity),
|
||||
expand_meta_args(PL0, PL, 1, M0, M).
|
||||
expand_goal(A, B, P0, P) :-
|
||||
goal_expansion(A, B0, P0, P1), !,
|
||||
expand_goal(B0, B, P1, P).
|
||||
expand_goal(A, A, P, P).
|
||||
|
||||
expand_meta_args([], [], _, _, _).
|
||||
expand_meta_args([P0|T0], [P|T], I, M0, M) :-
|
||||
arg(I, M0, A0),
|
||||
arg(I, M, A),
|
||||
expand_goal(A0, A, P0, P),
|
||||
NI is I + 1,
|
||||
expand_meta_args(T0, T, NI, M0, M).
|
||||
|
||||
meta((_ , _)).
|
||||
meta((_ ; _)).
|
||||
meta((_ -> _)).
|
||||
meta((_ *-> _)).
|
||||
meta((\+ _)).
|
||||
meta((not(_))).
|
||||
meta((call(_))).
|
||||
meta((once(_))).
|
||||
meta((ignore(_))).
|
||||
meta((forall(_, _))).
|
||||
|
||||
goal_expansion(send(R, Msg), send_class(R, _, SuperMsg), P, P) :-
|
||||
compound(Msg),
|
||||
Msg =.. [send_super, Selector | Args], !,
|
||||
SuperMsg =.. [Selector|Args].
|
||||
goal_expansion(get(R, Msg, A), get_class(R, _, SuperMsg, A), P, P) :-
|
||||
compound(Msg),
|
||||
Msg =.. [get_super, Selector | Args], !,
|
||||
SuperMsg =.. [Selector|Args].
|
||||
goal_expansion(send_super(R, Msg), send_class(R, _, Msg), P, P).
|
||||
goal_expansion(get_super(R, Msg, V), get_class(R, _, Msg, V), P, P).
|
||||
goal_expansion(SendSuperN, send_class(R, _, Msg), P, P) :-
|
||||
compound(SendSuperN),
|
||||
SendSuperN =.. [send_super, R, Sel | Args],
|
||||
Msg =.. [Sel|Args].
|
||||
goal_expansion(SendN, send(R, Msg), P, P) :-
|
||||
compound(SendN),
|
||||
SendN =.. [send, R, Sel | Args],
|
||||
atom(Sel), Args \== [],
|
||||
Msg =.. [Sel|Args].
|
||||
goal_expansion(GetSuperN, get_class(R, _, Msg, Answer), P, P) :-
|
||||
compound(GetSuperN),
|
||||
GetSuperN =.. [get_super, R, Sel | AllArgs],
|
||||
append(Args, [Answer], AllArgs),
|
||||
Msg =.. [Sel|Args].
|
||||
goal_expansion(GetN, get(R, Msg, Answer), P, P) :-
|
||||
compound(GetN),
|
||||
GetN =.. [get, R, Sel | AllArgs],
|
||||
append(Args, [Answer], AllArgs),
|
||||
atom(Sel), Args \== [],
|
||||
Msg =.. [Sel|Args].
|
||||
goal_expansion(G0, G, P, P) :-
|
||||
user:goal_expansion(G0, G), % TBD: we need the module!
|
||||
G0 \== G. % \=@=?
|
||||
|
||||
|
||||
/*******************************
|
||||
* PRINTABLE NAMES *
|
||||
*******************************/
|
||||
|
||||
:- module_transparent
|
||||
predicate_name/2.
|
||||
:- multifile
|
||||
user:prolog_predicate_name/2,
|
||||
user:prolog_clause_name/2.
|
||||
|
||||
hidden_module(user).
|
||||
hidden_module(system).
|
||||
hidden_module(pce_principal). % should be config
|
||||
hidden_module(Module) :- % SWI-Prolog specific
|
||||
import_module(Module, system).
|
||||
|
||||
thaffix(1, st) :- !.
|
||||
thaffix(2, nd) :- !.
|
||||
thaffix(_, th).
|
||||
|
||||
%% predicate_name(:Head, -PredName:string) is det.
|
||||
%
|
||||
% Describe a predicate as [Module:]Name/Arity.
|
||||
|
||||
predicate_name(Predicate, PName) :-
|
||||
strip_module(Predicate, Module, Head),
|
||||
( user:prolog_predicate_name(Module:Head, PName)
|
||||
-> true
|
||||
; functor(Head, Name, Arity),
|
||||
( hidden_module(Module)
|
||||
-> format(string(PName), '~q/~d', [Name, Arity])
|
||||
; format(string(PName), '~q:~q/~d', [Module, Name, Arity])
|
||||
)
|
||||
).
|
||||
|
||||
%% clause_name(+Ref, -Name)
|
||||
%
|
||||
% Provide a suitable description of the indicated clause.
|
||||
|
||||
clause_name(Ref, Name) :-
|
||||
user:prolog_clause_name(Ref, Name), !.
|
||||
clause_name(Ref, Name) :-
|
||||
nth_clause(Head, N, Ref), !,
|
||||
predicate_name(Head, PredName),
|
||||
thaffix(N, Th),
|
||||
format(string(Name), '~d-~w clause of ~w', [N, Th, PredName]).
|
||||
clause_name(_, '<meta-call>').
|
||||
1508
LGPL/prolog_colour.pl
Normal file
1508
LGPL/prolog_colour.pl
Normal file
File diff suppressed because it is too large
Load Diff
Reference in New Issue
Block a user