This repository has been archived on 2023-08-20. You can view files and clone it, but cannot push or open issues or pull requests.
yap-6.3/pl/listing.yap

302 lines
7.7 KiB
Plaintext
Raw Normal View History

/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: listing.pl *
* Last rev: *
* mods: *
* comments: listing a prolog program *
* *
*************************************************************************/
2014-04-09 12:39:29 +01:00
:- system_module( '$_listing', [listing/0,
listing/1,
portray_clause/1,
portray_clause/2], []).
:- use_system_module( '$_errors', ['$do_error'/2]).
:- use_system_module( '$_preds', ['$clause'/4,
'$current_predicate_no_modules'/3]).
/* listing : Listing clauses in the database
*/
2014-09-11 20:06:57 +01:00
/** @pred listing
Lists in the current output stream all the clauses for which source code
is available (these include all clauses for dynamic predicates and
clauses for static predicates compiled when source mode was `on`).
*/
listing :-
current_output(Stream),
'$current_module'(Mod),
Mod \= prolog,
Mod \= system,
\+ '$hidden'( Mod ),
'$current_predicate_no_modules'(Mod,_,Pred),
'$undefined'(Pred, prolog), % skip predicates exported from prolog.
functor(Pred,Name,Arity),
'$listing'(Name/Arity,Mod,Stream),
fail.
listing.
2014-09-11 20:06:57 +01:00
/** @pred listing(+ _P_)
Lists predicate _P_ if its source code is available.
*/
listing(MV) :-
current_output(Stream),
listing(Stream, MV).
listing(Stream, MV) :-
strip_module( MV, M, I),
'$mlisting'(Stream, I, M).
listing(_Stream, []) :- !.
listing(Stream, [MV|MVs]) :- !,
listing(Stream, MV),
listing(Stream, MVs).
'$mlisting'(Stream, MV, M) :-
( var(MV) -> MV = NA, '$do_listing'(Stream, M, NA)
;
atom(MV) -> MV/_ = NA, '$do_listing'(Stream, M, NA)
;
MV = N//Ar -> ( integer(Ar) -> Ar2 is Ar+2, NA is N/Ar2 ; '$do_listing'(Stream, NA/Ar2, M), Ar2 >= 2, Ar is Ar2-2 )
;
MV = N/Ar, ( atom(N) -> true ; var(N) ), ( integer(Ar) -> true ; var(Ar) ) -> '$do_listing'(Stream, M, MV)
;
MV = M1:PP -> '$mlisting'(Stream, PP, M1)
;
'$do_error'(type_error(predicate_indicator,MV),listing(Stream, MV) )
).
'$do_listing'(Stream, M, NA) :-
( '$$current_predicate'(NA, M),
'$listing'(NA,M,Stream),
fail
;
true
).
'$listing'(X, M, Stream) :-
'$funcspec'(X,Name,Arity),
functor(Pred,Name,Arity),
'$list_clauses'(Stream,M,Pred).
'$listing'(_,_,_).
'$funcspec'(Name/Arity,Name,Arity) :- !, atom(Name).
'$funcspec'(Name,Name,_) :- atom(Name), !.
'$funcspec'(Name,_,_) :-
'$do_error'(domain_error(predicate_spec,Name),listing(Name)).
2014-07-16 18:59:03 +01:00
'$list_clauses'(Stream, M, Pred) :-
'$flags'(Pred,M,Flags,Flags),
(Flags /\ 0x48602000 =\= 0
->
nl(Stream),
fail
;
!
).
'$list_clauses'(Stream, M, Pred) :-
( '$is_dynamic'(Pred, M) -> true ; '$is_log_updatable'(Pred, M) ),
2014-07-16 18:59:03 +01:00
functor( Pred, N, Ar ),
'$current_module'(Mod),
(
M == Mod
->
2014-07-16 18:59:03 +01:00
format( Stream, ':- dynamic ~q/~d.~n', [N,Ar])
;
2014-07-16 18:59:03 +01:00
format( Stream, ':- dynamic ~q:~q/~d.~n', [M,N,Ar])
),
fail.
'$list_clauses'(Stream, M, Pred) :-
'$is_thread_local'(Pred, M),
2014-07-16 18:59:03 +01:00
functor( Pred, N, Ar ),
'$current_module'(Mod),
(
M == Mod
->
2014-07-16 18:59:03 +01:00
format( Stream, ':- thread_local ~q/~d.~n', [N,Ar])
;
2014-07-16 18:59:03 +01:00
format( Stream, ':- thread_local ~q:~q/~d.~n', [M,N,Ar])
),
fail.
'$list_clauses'(Stream, M, Pred) :-
'$is_multifile'(Pred, M),
2014-07-16 18:59:03 +01:00
functor( Pred, N, Ar ),
'$current_module'(Mod),
(
M == Mod
->
2014-07-16 18:59:03 +01:00
format( Stream, ':- multifile ~q/~d.~n', [N,Ar])
;
2014-07-16 18:59:03 +01:00
format( Stream, ':- multifile ~q:~q/~d.~n', [M,N,Ar])
),
fail.
'$list_clauses'(Stream, M, Pred) :-
'$is_metapredicate'(Pred, M),
functor( Pred, Name, Arity ),
prolog:'$meta_predicate'(Name,M,Arity,PredDef),
'$current_module'(Mod),
(
M == Mod
->
2014-07-16 18:59:03 +01:00
format( Stream, ':- ~q.~n', [PredDef])
;
2014-10-05 10:22:03 +01:00
format( Stream, ':- ~q:~q.~n', [M,PredDef])
),
fail.
'$list_clauses'(Stream, _M, _Pred) :-
nl( Stream ),
fail.
'$list_clauses'(Stream, M, Pred) :-
2014-07-16 18:59:03 +01:00
'$flags'(Pred,M,Flags,Flags),
% has to be dynamic, source, or log update.
Flags /\ 0x08402000 =\= 0,
'$clause'(Pred, M, Body, _),
'$current_module'(Mod),
( M \= Mod -> H = M:Pred ; H = Pred ),
'$portray_clause'(Stream,(H:-Body)),
fail.
2014-09-11 20:06:57 +01:00
/** @pred portray_clause(+ _S_,+ _C_)
Write clause _C_ on stream _S_ as if written by listing/0.
*/
portray_clause(Stream, Clause) :-
copy_term_nat(Clause, CopiedClause),
'$portray_clause'(Stream, CopiedClause),
fail.
portray_clause(_, _).
2014-09-11 20:06:57 +01:00
/** @pred portray_clause(+ _C_)
Write clause _C_ as if written by listing/0.
*/
portray_clause(Clause) :-
current_output(Stream),
portray_clause(Stream, Clause).
'$portray_clause'(Stream, (Pred :- true)) :- !,
'$beautify_vars'(Pred),
2014-10-06 00:00:42 +01:00
format(Stream, '~q.~n', [Pred]).
'$portray_clause'(Stream, (Pred:-Body)) :- !,
'$beautify_vars'((Pred:-Body)),
2014-10-06 00:00:42 +01:00
format(Stream, '~q :-', [Pred]),
'$write_body'(Body, 3, ',', Stream),
format(Stream, '.~n', []).
2014-10-06 00:00:42 +01:00
'$portray_clause'(Stream, Pred) :-
'$beautify_vars'(Pred),
2014-10-06 00:00:42 +01:00
format(Stream, '~q.~n', [Pred]).
'$write_body'(X,I,T,Stream) :- var(X), !,
'$beforelit'(T,I,Stream),
writeq(Stream, '_').
'$write_body'((P,Q), I, T, Stream) :-
!,
'$write_body'(P,I,T, Stream),
put(Stream, 0',),
'$write_body'(Q,I,',',Stream).
'$write_body'((P->Q;S),I,_, Stream) :-
!,
format(Stream, '~n~*c(',[I,0' ]),
I1 is I+2,
'$write_body'(P,I1,'(',Stream),
format(Stream, '~n~*c->',[I,0' ]),
'$write_disj'((Q;S),I,I1,'->',Stream),
format(Stream, '~n~*c)',[I,0' ]).
'$write_body'((P->Q|S),I,_,Stream) :-
!,
format(Stream, '~n~*c(',[I,0' ]),
I1 is I+2,
'$write_body'(P,I,'(',Stream),
format(Stream, '~n~*c->',[I,0' ]),
'$write_disj'((Q|S),I,I1,'->',Stream),
format(Stream, '~n~*c)',[I,0' ]).
'$write_body'((P->Q),I,_,Stream) :-
!,
format(Stream, '~n~*c(',[I,0' ]),
I1 is I+2,
'$write_body'(P,I1,'(',Stream),
format(Stream, '~n~*c->',[I,0' ]),
'$write_body'(Q,I1,'->',Stream),
format(Stream, '~n~*c)',[I,0' ]).
'$write_body'((P;Q),I,_,Stream) :-
!,
format(Stream, '~n~*c(',[I,0' ]),
I1 is I+2,
'$write_disj'((P;Q),I,I1,'->',Stream),
format(Stream, '~n~*c)',[I,0' ]).
'$write_body'((P|Q),I,_,Stream) :-
!,
format(Stream, '~n~*c(',[I,0' ]),
I1 is I+2,
'$write_disj'((P|Q),I,I1,'->',Stream),
format(Stream, '~n~*c)',[I,0' ]).
'$write_body'(X,I,T,Stream) :-
'$beforelit'(T,I,Stream),
writeq(Stream,X).
2014-10-06 00:00:42 +01:00
'$write_disj'((Q;S),I0,I,C,Stream) :- !,
'$write_body'(Q,I,C,Stream),
format(Stream, '~n~*c;',[I0,0' ]),
'$write_disj'(S,I0,I,';',Stream).
'$write_disj'((Q|S),I0,I,C,Stream) :- !,
'$write_body'(Q,I,C,Stream),
format(Stream, '~n~*c|',[I0,0' ]),
'$write_disj'(S,I0,I,'|',Stream).
'$write_disj'(S,_,I,C,Stream) :-
'$write_body'(S,I,C,Stream).
2014-10-06 00:00:42 +01:00
'$beforelit'('(',_,Stream) :-
!,
format(Stream,' ',[]).
'$beforelit'(_,I,Stream) :- format(Stream,'~n~*c',[I,0' ]).
'$beautify_vars'(T) :-
'$list_get_vars'(T,[],L),
msort(L,SL),
'$list_transform'(SL,0).
'$list_get_vars'(V,L,[V|L] ) :- var(V), !.
'$list_get_vars'(Atomic, M, M) :-
primitive(Atomic), !.
'$list_get_vars'([Arg|Args], M, N) :- !,
'$list_get_vars'(Arg, M, K),
'$list_get_vars'(Args, K, N).
'$list_get_vars'(Term, M, N) :-
Term =.. [_|Args],
'$list_get_vars'(Args, M, N).
'$list_transform'([],_) :- !.
'$list_transform'([X,Y|L],M) :-
X == Y,
X = '$VAR'(M),
!,
N is M+1,
2010-03-27 11:43:03 +00:00
'$list_transform'(L,N).
'$list_transform'('$VAR'(-1).L,M) :- !,
'$list_transform'(L,M).
'$list_transform'(_.L,M) :-
'$list_transform'(L,M).