676 lines
20 KiB
Prolog
676 lines
20 KiB
Prolog
/* $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>').
|