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 / syspred.pl < prev    next >
Text File  |  1992-06-19  |  12KB  |  494 lines
  1. /*  syspred.pl,v 1.3 1992/06/19 13:25:27 jan Exp
  2.  
  3.     Copyright (c) 1990 Jan Wielemaker. All rights reserved.
  4.     jan@swi.psy.uva.nl
  5.  
  6.     Purpose: Prolog system predicate definitions
  7. */
  8.  
  9. :- module($syspreds,
  10.     [ leash/1
  11.     , visible/1
  12.     , style_check/1
  13.     , please/3
  14.     , (spy)/1
  15.     , (nospy)/1
  16.     , nospyall/0
  17.     , debugging/0
  18.     , concat_atom/2
  19.     , term_to_atom/2
  20.     , atom_to_term/3
  21.     , int_to_atom/2
  22.     , gensym/2
  23.     , dwim_match/2
  24.     , source_file/1
  25.     , source_file/2
  26.     , current_predicate/2
  27.     , predicate_property/2
  28.     , $predicate_property/2
  29.     , clause/2
  30.     , clause/3
  31.     , recorda/2
  32.     , recordz/2
  33.     , recorded/2
  34.     , retractall/1
  35.     , current_module/1
  36.     , current_module/2
  37.     , module/1
  38.     , statistics/0
  39.     , shell/2
  40.     , shell/1
  41.     , shell/0
  42.     , format/1
  43.     , sformat/2
  44.     , sformat/3
  45.     , garbage_collect/0
  46.     , arithmetic_function/1
  47.         , default_module/2
  48.     , save_program/1
  49.     , save_program/2
  50.     , save/1
  51.     ]).    
  52.  
  53.         /********************************
  54.         *           DEBUGGER            *
  55.         *********************************/
  56.  
  57. $map_bits(_, [], Bits, Bits) :- !.
  58. $map_bits(Pred, [H|T], Old, New) :-
  59.     $map_bits(Pred, H, Old, New0),
  60.     $map_bits(Pred, T, New0, New).
  61. $map_bits(Pred, +Name, Old, New) :- !,         % set a bit
  62.     $apply(Pred, [Name, Bits]), !,
  63.     New is Old \/ Bits.
  64. $map_bits(Pred, -Name, Old, New) :- !,         % clear a bit
  65.     $apply(Pred, [Name, Bits]), !,
  66.     New is Old /\ (\Bits).
  67. $map_bits(Pred, ?Name, Old, Old) :-        % ask a bit
  68.     $apply(Pred, [Name, Bits]), !,
  69.     Old /\ Bits > 0.
  70.  
  71. $port_bit(  call, 2'00001).
  72. $port_bit(  exit, 2'00010).
  73. $port_bit(  fail, 2'00100).
  74. $port_bit(  redo, 2'01000).
  75. $port_bit( unify, 2'10000).
  76. $port_bit(   all, 2'11111).
  77. $port_bit(  full, 2'01111).
  78. $port_bit(  half, 2'01101).
  79.  
  80. leash(Ports) :-
  81.     $leash(Old, Old),
  82.     $map_bits($port_bit, Ports, Old, New),
  83.     $leash(_, New).
  84.  
  85. visible(Ports) :-
  86.     $visible(Old, Old),
  87.     $map_bits($port_bit, Ports, Old, New),
  88.     $visible(_, New).
  89.  
  90. $map_style_check(atom,            2'00001).
  91. $map_style_check(singleton,        2'00010).
  92. $map_style_check(dollar,          2'00100).
  93. $map_style_check((discontiguous),  2'01000).
  94. $map_style_check(string,       2'10000).
  95.  
  96. style_check(Spec) :-
  97.     $style_check(Old, Old),
  98.     $map_bits($map_style_check, Spec, Old, New),
  99.     $style_check(_, New).
  100.  
  101. please(autoload, Old, New) :- !,
  102.     flag($enable_autoload, Old, New).
  103. please(verbose_autoload, Old, New) :- !,
  104.     flag($verbose_autoload, Old, New).
  105. please(Key, Old, New) :-
  106.     $please(Key, Old, New).
  107.  
  108. :- module_transparent
  109.     spy/1,
  110.     nospy/1.
  111.  
  112. spy([]) :- !.
  113. spy([H|T]) :- !,
  114.     spy(H),
  115.     spy(T).
  116. spy(Spec) :-
  117.     $find_predicate(Spec, Preds),
  118.     member(Head, Preds),
  119.         $spy(Head),
  120.         $predicate_name(Head, Name),
  121.         $ttyformat('Spy point on ~w~n', [Name]),
  122.     fail.
  123. spy(_).
  124.  
  125. nospy([]) :- !.
  126. nospy([H|T]) :- !,
  127.     nospy(H),
  128.     nospy(T).
  129. nospy(Spec) :-
  130.     $find_predicate(Spec, Preds),
  131.     member(Head, Preds),
  132.         $nospy(Head),
  133.         $predicate_name(Head, Name),
  134.         $ttyformat('Spy point removed from ~w~n', [Name]),
  135.     fail.
  136. nospy(_).
  137.  
  138. nospyall :-
  139.     current_predicate(_, Module:Head),
  140.         $nospy(Module:Head),
  141.     fail.
  142. nospyall.
  143.  
  144. debugging :-
  145.     $debugging, !,
  146.     format('Debug mode is on; spy points on:~n'),
  147.     $show_spy_points.
  148. debugging :-
  149.     format('Debug mode is off~n').
  150.  
  151. $show_spy_points :-
  152.     current_predicate(_, Module:Head),
  153.     $predicate_attribute(Module:Head, spy, True),
  154.     True == 1,
  155.     \+ predicate_property(Module:Head, imported_from(_)),
  156.     $predicate_name(Module:Head, Name),
  157.     format('~t~8|~w~n', [Name]),
  158.     fail.
  159. $show_spy_points.
  160.  
  161.  
  162.         /********************************
  163.         *             ATOMS             *
  164.         *********************************/
  165.  
  166. concat_atom([A, B], C) :- !,
  167.     concat(A, B, C).
  168. concat_atom(L, Atom) :-
  169.     $concat_atom(L, Atom).
  170.  
  171. term_to_atom(Term, Atom) :-
  172.     $term_to_atom(Term, Atom, 0).
  173.  
  174. atom_to_term(Atom, Term, Bindings) :-
  175.     var(Bindings),
  176.     $term_to_atom(Term, Atom, Bindings).
  177.  
  178. int_to_atom(Int, Atom) :-
  179.     int_to_atom(Int, 10, Atom).
  180.  
  181. gensym(Base, Atom) :-
  182.     concat($gs_, Base, Key),
  183.     flag(Key, Old, Old),
  184.     succ(Old, New),
  185.     flag(Key, _, New),
  186.     concat(Base, New, Atom).
  187.  
  188. dwim_match(A1, A2) :-
  189.     dwim_match(A1, A2, _).
  190.  
  191.         /********************************
  192.         *             SOURCE            *
  193.         *********************************/
  194.  
  195. :- module_transparent
  196.     source_file/2.
  197.  
  198. source_file(Pred, File) :-
  199.     current_predicate(_, Pred),
  200.     $source_file(Pred, File).
  201.  
  202. source_file(File) :-
  203.     $time_source_file(File, _).
  204. source_file(File) :-
  205.     atom(File),
  206.     $time_source_file(LoadedFile, _),
  207.     same_file(LoadedFile, File), !.
  208.  
  209.         /********************************
  210.         *           DATA BASE           *
  211.         *********************************/
  212.  
  213. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  214. The predicate current_predicate/2 is   a  difficult subject since  the
  215. introduction  of defaulting     modules   and   dynamic     libraries.
  216. current_predicate/2 is normally  called with instantiated arguments to
  217. verify some  predicate can   be called without trapping   an undefined
  218. predicate.  In this case we must  perform the search algorithm used by
  219. the prolog system itself.
  220.  
  221. If the pattern is not fully specified, we only generate the predicates
  222. actually available in this  module.   This seems the best for listing,
  223. etc.
  224. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  225.  
  226.  
  227. :- module_transparent
  228.     current_predicate/2,
  229.     $defined_predicate/1.
  230.  
  231. current_predicate(Name, Head) :-
  232.     var(Head), !,
  233.     context_module(Module),
  234.     generate_current_predicate(Name, Module, Head).
  235. current_predicate(Name, Module:Head) :-
  236.     (var(Module) ; var(Head)), !,
  237.     generate_current_predicate(Name, Module, Head).
  238. current_predicate(Name, Term) :-
  239.     $c_current_predicate(Name, Term),
  240.     $defined_predicate(Term), !.
  241. current_predicate(Name, Term) :-
  242.     $strip_module(Term, Module, Head),
  243.     default_module(Module, DefModule),
  244.     $c_current_predicate(Name, DefModule:Head),
  245.     $defined_predicate(DefModule:Head), !.
  246. current_predicate(Name, Term) :-
  247.     flag($enable_autoload, on, on),
  248.     $strip_module(Term, Module, Head),
  249.     functor(Head, Name, Arity),
  250.     $find_library(Module, Name, Arity, _LoadModule, _Library), !.
  251.  
  252. generate_current_predicate(Name, Module, Head) :-
  253.     current_module(Module),
  254.     $c_current_predicate(Name, Module:Head),
  255.     $defined_predicate(Module:Head).
  256.  
  257. $defined_predicate(Head) :-
  258.     $predicate_attribute(Head, defined, 1), !.
  259. $defined_predicate(Head) :-
  260.     $predicate_attribute(Head, (dynamic), True),
  261.     True == 1.
  262.  
  263. :- module_transparent
  264.     predicate_property/2,
  265.     $predicate_property/2.
  266.  
  267. predicate_property(Pred, Property) :-
  268.     Property == undefined, !,
  269.     (   Pred = Module:Head,
  270.         var(Module)
  271.     ;   $strip_module(Pred, Module, Head)
  272.     ), !,
  273.     current_module(Module),
  274.     Term = Module:Head,
  275.     $c_current_predicate(_, Term),
  276.     \+ $defined_predicate(Term),        % Speed up a bit
  277.     \+ current_predicate(_, Term).
  278. predicate_property(Pred, Property) :-
  279.     current_predicate(_, Pred),
  280.     $predicate_property(Pred, Property).
  281.  
  282. :- index($predicate_property(0, 1)).
  283.  
  284. $predicate_property(Pred, interpreted) :-
  285.     $predicate_attribute(Pred, foreign, True),
  286.     True == 0.
  287. $predicate_property(Pred, built_in) :-
  288.     $predicate_attribute(Pred, system, True),
  289.     True == 1.
  290. $predicate_property(Pred, exported) :-
  291.     $predicate_attribute(Pred, exported, True),
  292.     True == 1.
  293. $predicate_property(Pred, foreign) :-
  294.     $predicate_attribute(Pred, foreign, True),
  295.     True == 1.
  296. $predicate_property(Pred, (dynamic)) :-
  297.     $predicate_attribute(Pred, (dynamic), True),
  298.     True == 1.
  299. $predicate_property(Pred, (multifile)) :-
  300.     $predicate_attribute(Pred, (multifile), True),
  301.     True == 1.
  302. $predicate_property(Pred, imported_from(Module)) :-
  303.     $predicate_attribute(Pred, imported, Module).
  304. $predicate_property(Pred, transparent) :-
  305.     $predicate_attribute(Pred, transparent, True),
  306.     True == 1.
  307. $predicate_property(Pred, indexed(Pattern)) :-
  308.     $predicate_attribute(Pred, indexed, Pattern).
  309.  
  310. :- module_transparent
  311.     clause/2,
  312.     clause/3,
  313.     retractall/1.
  314.  
  315. clause(Head, Body, Ref) :-
  316.     nonvar(Ref), !,
  317.     $clause(Head, Clause, Ref),
  318.     $strip_module(Head, _, H),
  319.     $clause2(H, Body, Clause).
  320. clause(Head, Body, Ref) :-
  321.     current_predicate(_, Head),
  322.     $clause(Head, Clause, Ref),
  323.     $strip_module(Head, _, H),
  324.     $clause2(H, Body, Clause).
  325.  
  326. clause(Head, Body) :-
  327.     current_predicate(_, Head),
  328.     $clause(Head, Clause, _),
  329.     $strip_module(Head, _, H),
  330.     $clause2(H, Body, Clause).
  331.  
  332. $clause2(Head, Body, (Head :- Body)) :- !.
  333. $clause2(Head, true, Head).
  334.  
  335. recorda(Key, Value) :-
  336.     recorda(Key, Value, _).
  337. recordz(Key, Value) :-
  338.     recordz(Key, Value, _).
  339. recorded(Key, Value) :-
  340.     recorded(Key, Value, _).
  341.  
  342. retractall(Term) :-
  343.     retract(Term),
  344.     fail.
  345. retractall(_).
  346.  
  347.  
  348.         /********************************
  349.         *            MODULES            *
  350.         *********************************/
  351.  
  352. current_module(Module) :-
  353.     $current_module(Module, _).
  354.  
  355. current_module(Module, File) :-
  356.     $current_module(Module, File),
  357.     File \== [].
  358.  
  359. module(Module) :-
  360.     atom(Module),
  361.     current_module(Module), !,
  362.     $module(_, Module).
  363. module(Module) :-
  364.     $break($warning('~w is not a current module', [Module])),
  365.     $module(_, Module).
  366.  
  367.         /********************************
  368.         *          STATISTICS           *
  369.         *********************************/
  370.  
  371. statistics :-
  372.     statistics(trail, Trail),
  373.     statistics(trailused, TrailUsed),
  374.     statistics(local, Local),
  375.     statistics(localused, LocalUsed),
  376.     statistics(global, Global),
  377.     statistics(globalused, GlobalUsed),
  378.     statistics(cputime, Cputime),
  379.     statistics(inferences, Inferences),
  380.     statistics(heapused, Heapused),
  381.     statistics(atoms, Atoms),
  382.     statistics(functors, Functors),
  383.     statistics(predicates, Predicates),
  384.     statistics(modules, Modules),
  385.     statistics(codes, Codes),
  386.     statistics(externals, Externals),
  387.     statistics(locallimit, LocalLimit),
  388.     statistics(globallimit, GlobalLimit),
  389.     statistics(traillimit, TrailLimit),
  390.  
  391.     format('~2f seconds cpu time for ~D inferences~n',
  392.                     [Cputime, Inferences]),
  393.     format('~D atoms, ~D functors, ~D predicates, ~D modules~n',
  394.                     [Atoms, Functors, Predicates, Modules]),
  395.     format('~D byte codes; ~D external references~n~n',
  396.                     [Codes, Externals]),
  397.     format('                      Limit    Allocated       In use~n'),
  398.     format('Heap         :                  ~t~D~53| Bytes~n', [Heapused]),
  399.     format('Local  stack :~t~D~27| ~t~D~40| ~t~D~53| Bytes~n', [LocalLimit, Local, LocalUsed]),
  400.     format('Global stack :~t~D~27| ~t~D~40| ~t~D~53| Bytes~n', [GlobalLimit, Global, GlobalUsed]),
  401.     format('Trail  stack :~t~D~27| ~t~D~40| ~t~D~53| Bytes~n', [TrailLimit, Trail, TrailUsed]),
  402.  
  403.     gc_statistics.
  404.  
  405. gc_statistics :-
  406.     statistics(collections, Collections),
  407.     Collections > 0, !,
  408.     statistics(collected, Collected),
  409.     statistics(gctime, GcTime),
  410.  
  411.     format('~n~D garbage collections gained ~D bytes in ~2f seconds.~n', [Collections, Collected, GcTime]).
  412. gc_statistics.
  413.  
  414.         /********************************
  415.         *      SYSTEM INTERACTION       *
  416.         *********************************/
  417.  
  418. shell(Command, Status) :-
  419.     $shell(Command, Status).
  420.  
  421. shell(Command) :-
  422.     shell(Command, 0).
  423.  
  424. shell :-
  425.     getenv('SHELL', Shell), !,
  426.     shell(Shell).
  427. shell :-
  428.     shell('/bin/sh').
  429.  
  430.  
  431.         /********************************
  432.         *              I/O              *
  433.         *********************************/
  434.  
  435. format(Fmt) :-
  436.     format(Fmt, []).
  437.  
  438. sformat(String, Format, Arguments) :-
  439.     $write_on_string(format(Format, Arguments), String).
  440. sformat(String, Format) :-
  441.     $write_on_string(format(Format), String).
  442.  
  443.         /********************************
  444.         *         MISCELLENEOUS         *
  445.         *********************************/
  446.  
  447. %    Invoke the garbage collector.  The argument is the debugging level
  448. %    to use during garbage collection.  This only works if the system
  449. %    is compiled with the -DODEBUG cpp flag.  Only to simplify maintenance.
  450.  
  451. garbage_collect :-
  452.     $garbage_collect(0).
  453.  
  454. %    save_program(+Name[, +Options])
  455. %    Save the currently running image in file
  456.  
  457. save_program(Name) :-
  458.     save_program(Name, []).
  459.  
  460. save_program(Name, Options) :-
  461.     $autoload:clear_library_index,
  462.     $save_program(Name, Options).
  463.  
  464. %    save(+File)
  465. %    Create saved-state in file
  466.  
  467. save(File) :-
  468.     save(File, _).
  469.  
  470. %    arithmetic_function(Spec)
  471. %    Register a predicate as an arithmetic function.  Takes Name/Arity
  472. %    and a term as argument.
  473.  
  474. :- module_transparent
  475.     arithmetic_function/1.
  476.  
  477. arithmetic_function(Spec) :-
  478.     $strip_module(Spec, Module, Term),
  479.     (   Term = Name/Arity
  480.     ;   functor(Term, Name, Arity)
  481.     ), !,
  482.     PredArity is Arity + 1,
  483.     functor(Head, Name, PredArity),
  484.     $arithmetic_function(Module:Head).
  485.  
  486. %    default_module(+Me, -Super)
  487. %    Is true if `Super' is `Me' or a super (auto import) module of `Me'.
  488.  
  489. default_module(Me, Me).
  490. default_module(Me, Super) :-
  491.     $default_module(Me, S, S),
  492.     S \== [],
  493.     default_module(S, Super).
  494.