change SWI stuff to swi directory.
This commit is contained in:
675
swi/library/prolog_clause.pl
Normal file
675
swi/library/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>').
|
Reference in New Issue
Block a user