home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-387-Vol-3of3.iso / p / plbin.zip / pl / boot / listing.pl < prev    next >
Text File  |  1992-10-21  |  6KB  |  226 lines
  1. /*  listing.pl,v 1.2 1992/10/21 10:42:24 jan Exp
  2.  
  3.     Copyright (c) 1990 Jan Wielemaker. All rights reserved.
  4.     jan@swi.psy.uva.nl
  5.  
  6.     Purpose: listing/1
  7. */
  8.  
  9. :- module($listing,
  10.     [ listing/0
  11.     , listing/1
  12.     , portray_clause/1
  13.     ]).
  14.  
  15. :- module_transparent
  16.     listing/0, 
  17.     listing/1, 
  18.     $listing/2, 
  19.     $listing2/3, 
  20.     $list_clauses/1.
  21.  
  22.  
  23. %   calls listing(Pred) for each current_predicate Pred.
  24.  
  25. listing :-
  26.     current_predicate(_, Pred), 
  27.     \+ predicate_property(Pred, built_in), 
  28.     nl, 
  29.     functor(Pred, Name, Arity),
  30.     $listing2(Name, Pred, Arity),
  31.     fail.
  32. listing.
  33.  
  34.  
  35. %   listing(PredSpecs)
  36.  
  37. listing(V) :-
  38.     var(V), !.       % ignore variables
  39. listing([]) :- !.
  40. listing([X|Rest]) :- !, 
  41.         listing(X), 
  42.         listing(Rest).
  43. listing(X) :-
  44.     $find_predicate(X, Preds), 
  45.     $listing(Preds, X).
  46.  
  47. $listing(Preds, _) :-
  48.     member(Pred, Preds),
  49.     nl, 
  50.     $strip_module(Pred, _, Head), 
  51.     functor(Head, Name, Arity), 
  52.         $listing2(Name, Pred, Arity), 
  53.         fail.
  54. $listing(_, _).
  55.  
  56. $listing2(Name, Pred, Arity) :-
  57.     predicate_property(Pred, undefined), !, 
  58.     format('%   Undefined: ~w/~w~n', [Name, Arity]).
  59. $listing2(Name, Pred, Arity) :-
  60.     predicate_property(Pred, foreign), !, 
  61.     format('%   Foreign: ~w/~w~n', [Name, Arity]).
  62. $listing2(Name, Pred, Arity) :-
  63.     $strip_module(Pred, Module, Head),
  64.     notify_changed(Module, Head),
  65.     $list_declarations(Name, Pred, Arity, []), 
  66.     $list_clauses(Pred).
  67.  
  68. $list_declarations(Name, Pred, Arity, Sofar) :-
  69.     \+ member((dynamic Name/Arity), Sofar), 
  70.     predicate_property(Pred, (dynamic)), !, 
  71.     $list_declarations(Name, Pred, Arity, [(dynamic Name/Arity)|Sofar]).
  72. $list_declarations(Name, Pred, Arity, Sofar) :-
  73.     \+ member((multifile Name/Arity), Sofar), 
  74.     predicate_property(Pred, (multifile)), !, 
  75.     $list_declarations(Name, Pred, Arity, [(multifile Name/Arity)|Sofar]).
  76. $list_declarations(Name, Pred, Arity, Sofar) :-
  77.     \+ member((module_transparent Name/Arity), Sofar), 
  78.     predicate_property(Pred, (transparent)), !, 
  79.     $list_declarations(Name, Pred, Arity, [(module_transparent Name/Arity)|Sofar]).
  80. $list_declarations(_, _, _, []) :- !.
  81. $list_declarations(_, _, _, List) :-
  82.     $write_declarations(List), nl.
  83.  
  84. $write_declarations([]) :- !.
  85. $write_declarations([H|T]) :-
  86.     format(':- ~q.~n', [H]),
  87.     $write_declarations(T).
  88.  
  89. $list_clauses(Pred) :-
  90.     context_module(Source), 
  91.     $strip_module(Pred, Module, Head), 
  92.     clause(Pred, Body), 
  93.         $list_module(Module, Source), 
  94.         portray_clause((Head:-Body)), 
  95.     fail.
  96.  
  97. $list_module(system, _) :- !.
  98. $list_module(Module, Module) :- !.
  99. $list_module(Module, _) :-
  100.     format('~q:', [Module]).
  101.  
  102. notify_changed(user, Head) :-
  103.     current_predicate(_, system:Head),
  104.     \+ ( predicate_property(user:Head, imported_from(System)),
  105.          (System == system ; $default_module(System, system, system))
  106.        ),
  107.     \+ predicate_property(system:Head, (dynamic)), !,
  108.     functor(Head, Name, Arity),
  109.     format('%   NOTE: system definition has been overruled for ~w/~w~n~n',
  110.                 [Name, Arity]).
  111. notify_changed(_, _).
  112.  
  113. %    portray_clause(+Clause)
  114. %    Portray `Clause' on the current output stream.   Layout  of  the
  115. %    clause  is  to our best standards.  As the actual variable names
  116. %    are not available we use A, B, ... Deals with ';', '|',  '->'  and
  117. %    various calls via meta-call predicates.
  118.  
  119. portray_clause(Term) :-
  120.     numbervars(Term, $$VAR, 0, _), 
  121.     $portray_clause(Term), 
  122.     fail.                    % undo bindings        
  123. portray_clause(_).
  124.  
  125. $portray_clause((Head :- true)) :- !, 
  126.     $portray_head(Head), 
  127.     put(0'.), nl.
  128. $portray_clause((Head :- Body)) :- !, 
  129.     $portray_head(Head), 
  130.     write(' :-'), 
  131.     $portray_body(Body, 2, indent), 
  132.     put(0'.), nl.
  133. $portray_clause(Fact) :-
  134.     $portray_clause((Fact :- true)).
  135.  
  136. $portray_head(Head) :-
  137.     pprint(Head).
  138.  
  139. $portray_body(!, _, _) :- !, 
  140.     write(' !').
  141. $portray_body((!, Clause), Indent, _) :- !, 
  142.     write(' !,'), 
  143.     $portray_body(Clause, Indent, indent).
  144. $portray_body(Term, Indent, indent) :- !, 
  145.     nl, $portray_indent(Indent), 
  146.     $portray_body(Term, Indent, noindent).
  147. $portray_body((A, B), Indent, _) :- !, 
  148.     $portray_body(A, Indent, noindent), 
  149.     write(','), 
  150.     $portray_body(B, Indent, indent).
  151. $portray_body(Or, Indent, _) :-
  152.     memberchk(Or, [(_;_), (_|_), (_->_)]), !, 
  153.     write('(   '), 
  154.     $portray_or(Or, Indent), 
  155.     nl, $portray_indent(Indent), 
  156.     write(')').
  157. $portray_body(Meta, Indent, _) :-
  158.     $meta_call(Meta, N), !, 
  159.     $portray_meta(Meta, N, Indent).
  160. $portray_body(Clause, _, _) :-
  161.     pprint(Clause).
  162.  
  163. $portray_or((If -> Then ; Else), Indent) :- !, 
  164.     succ(Indent, NestIndent), 
  165.     $portray_body(If, NestIndent, noindent),     
  166.     nl, $portray_indent(Indent),
  167.     write('->  '), 
  168.     $portray_body(Then, NestIndent, noindent), 
  169.     nl, $portray_indent(Indent), 
  170.     write(';   '), 
  171.     $portray_or(Else, Indent).
  172. $portray_or((If -> Then), Indent) :- !, 
  173.     succ(Indent, NestIndent), 
  174.     $portray_body(If, NestIndent, noindent),     
  175.     nl, $portray_indent(Indent), 
  176.     write('->  '), 
  177.     $portray_or(Then, Indent).
  178. $portray_or((A;B), Indent) :- !, 
  179.     succ(Indent, OrIndent), 
  180.     $portray_body(A, OrIndent, noindent), 
  181.     nl, $portray_indent(Indent), 
  182.     write(';   '), 
  183.     $portray_or(B, Indent).
  184. $portray_or((A|B), Indent) :- !, 
  185.     succ(Indent, OrIndent), 
  186.     $portray_body(A, OrIndent, noindent),     
  187.     nl, $portray_indent(Indent), 
  188.     write('|   '), 
  189.     $portray_or(B, Indent).
  190. $portray_or(A, Indent) :-
  191.     succ(Indent, OrIndent), 
  192.     $portray_body(A, OrIndent, noindent).
  193.  
  194. $meta_call(call(_), 1).
  195. $meta_call(once(_), 1).
  196. $meta_call(not(_), 1).
  197. $meta_call(\+(_), 1).
  198. $meta_call(ignore(_), 1).
  199.  
  200. $portray_meta(Term, N, Indent) :-
  201.     arg(N, Term, Arg), 
  202.     memberchk(Arg, [(_, _), (_;_), (_|_), (_->_)]), !, 
  203.     functor(Term, Name, _), 
  204.     write(Name), write('(('), 
  205.     succ(Indent, CallIndent), 
  206.     $portray_body(Arg, CallIndent, indent), 
  207.     nl, $portray_indent(CallIndent), 
  208.     write('))').    
  209. $portray_meta(Term, _, _) :-
  210.     pprint(Term).    
  211.  
  212. $portray_indent(N) :-
  213.     Tab is N // 2, 
  214.     Space is (N mod 2) * 4, 
  215.     $n_times(Tab, put(9)), 
  216.     tab(Space).
  217.  
  218. $n_times(N, Goal) :-
  219.     between(1, N, _), 
  220.     Goal, 
  221.     fail.
  222. $n_times(_, _).    
  223.  
  224. pprint(Term) :-
  225.     $print(Term, $portray_variable).
  226.