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 / toplevel.pl < prev    next >
Text File  |  1993-02-17  |  7KB  |  319 lines
  1. /*  toplevel.pl,v 1.4 1993/02/17 12:45:49 jan Exp
  2.  
  3.     Copyright (c) 1990 Jan Wielemaker. All rights reserved.
  4.     jan@swi.psy.uva.nl
  5.  
  6.     Purpose: top level user interaction
  7. */
  8.  
  9. :- module($toplevel,
  10.     [ $init/0             % start Prolog (does not return)
  11.     , $init_return/0        % initialise Prolog and return
  12.     , $toplevel/0            % Prolog top-level (re-entrant)
  13.     , $abort/0             % restart after an abort
  14.     , $break/0             % live in a break
  15.     , $compile/0             % `-c' toplevel
  16.     , $welcome/0            % banner
  17.     , prolog/0             % user toplevel predicate
  18.     , time/1            % time query
  19.     , $set_prompt/1            % set the main prompt
  20.     ]).
  21.  
  22.  
  23.         /********************************
  24.         *         INITIALISATION        *
  25.         *********************************/
  26.  
  27. $welcome :-
  28.     $version(Version),
  29.     $ttyformat('Welcome to SWI-Prolog (Version ~w)~n', [Version]),
  30.     $ttyformat('Copyright (c) 1993, University of Amsterdam.  '),
  31.     $ttyformat('All rights reserved.~n~n').
  32.  
  33. $load_init_file(none) :- !.
  34. $load_init_file(Base) :-
  35.     member(Prefix, ['', '~/']),
  36.     concat(Prefix, Base, InitFile), 
  37.     exists_file(InitFile), !, 
  38.     user:ensure_loaded(InitFile).
  39. $load_init_file(_).
  40.  
  41. $check_novice :-
  42.     $novice(on, on), 
  43.     getenv('PROLOGCHILD', _), !, 
  44.     format('Cannot start Prolog from a child process running under Prolog~n'), 
  45.     format('Please type Control-D or `exit'' to return to Prolog~n'), 
  46.     halt.
  47. $check_novice.
  48.  
  49.  
  50. $load_gnu_emacs_interface :-
  51.     getenv('EMACS', t),
  52.     $argv(Args),
  53.     memberchk('+C', Args), !,
  54.     user:ensure_loaded(library(emacs_interface)).
  55. $load_gnu_emacs_interface.
  56.  
  57.  
  58.         /********************************
  59.         *        TOPLEVEL GOALS         *
  60.         *********************************/
  61.  
  62. $init :-
  63.     $init_return,
  64.     $toplevel.
  65.  
  66. $init_return :-
  67.     $check_novice, 
  68.     $clean_history,
  69.     $load_gnu_emacs_interface,
  70.     $option(init_file, File), 
  71.     $load_init_file(File), 
  72.     $option(goal, GoalAtom), 
  73.     term_to_atom(Goal, GoalAtom), 
  74.     ignore(user:Goal).
  75.  
  76. $abort :-
  77.     see(user), 
  78.     tell(user), 
  79.     flag($break_level, _, 0), 
  80.     flag($compilation_level, _, 0),
  81.     $ttyformat('~nExecution Aborted~n~n'),
  82.     $toplevel.
  83.  
  84. $break :-
  85.     flag($break_level, Old, Old), 
  86.     succ(Old, New), 
  87.     flag($break_level, _, New), 
  88.     $ttyformat('Break Level [~w]~n', [New]),
  89.     $toplevel,
  90.     $ttyformat('Exit Break Level [~w]~n', [New]),
  91.     flag($break_level, _, Old), !.
  92.  
  93. $toplevel :-
  94.     $option(top_level, TopLevelAtom), 
  95.     term_to_atom(TopLevel, TopLevelAtom), 
  96.     user:TopLevel.
  97.  
  98. %    $compile
  99. %    Tolpevel called when invoked with -c option.
  100.  
  101. $compile :-
  102.     $compile_wic.
  103.  
  104.  
  105.         /********************************
  106.         *    USER INTERACTIVE LOOP      *
  107.         *********************************/
  108.  
  109. prolog :-
  110.     flag($tracing, _, off), 
  111.     flag($break_level, BreakLev, BreakLev), 
  112.     repeat, 
  113.         (   $module(TypeIn, TypeIn), 
  114.         $system_prompt(TypeIn, BreakLev, Prompt),
  115.         prompt(Old, '|    '), 
  116.         trim_stacks,
  117.         read_history(h, '!h', 
  118.                   [trace, end_of_file], 
  119.                   Prompt, Goal, Bindings), 
  120.         prompt(_, Old)
  121.         ->  $execute(Goal, Bindings)
  122.         ), !.
  123.  
  124.         /********************************
  125.         *            PROMPTING        *
  126.         ********************************/
  127.  
  128. :- dynamic
  129.     $prompt/1.
  130.  
  131. $prompt("%m%l%! ?- ").
  132.  
  133. $set_prompt(P) :-
  134.     name(P, S),
  135.     retractall($prompt(_)),
  136.     assert($prompt(S)).
  137.  
  138.  
  139. $system_prompt(Module, BrekLev, Prompt) :-
  140.     $prompt(P0),
  141.     (    Module \== user
  142.     ->   $substitute("%m", [Module, ": "], P0, P1)
  143.     ;    $substitute("%m", [], P0, P1)
  144.     ),
  145.     (    BrekLev \== 0
  146.     ->   $substitute("%l", ["[", BrekLev, "] "], P1, P2)
  147.     ;    $substitute("%l", [], P1, P2)
  148.     ),
  149.     name(Prompt, P2).
  150.     
  151. $substitute(From, T, Old, New) :-
  152.     convert_to(T, T0),
  153.     flatten(T0, To),
  154.     append(Pre, S0, Old),
  155.     append(From, Post, S0) ->
  156.     append(Pre, To, S1),
  157.     append(S1, Post, New), !.
  158. $substitute(_, _, Old, Old).
  159.     
  160. convert_to([], []).
  161. convert_to([A|T], [S|R]) :-
  162.     atomic(A), !,
  163.     name(A, S),
  164.     convert_to(T, R).
  165. convert_to([S|T], [S|R]) :-
  166.     convert_to(T, R).
  167.  
  168.         /********************************
  169.         *           EXECUTION        *
  170.         ********************************/
  171.  
  172. $execute(Var, _) :-
  173.     var(Var), !,
  174.     $ttyformat('... 1,000,000 ............ 10,000,000 years later~n~n'),
  175.     $ttyformat('~t~8|>> 42 << (last release gives the question)~n'),
  176.     fail.
  177. $execute(end_of_file, _) :-
  178.      $ttyformat('~N'), !.
  179. $execute(Goal, Bindings) :-
  180.     $module(TypeIn, TypeIn), 
  181.     TypeIn:$dwim_correct_goal(Goal, Bindings, Corrected), !, 
  182.     $execute_goal(Corrected, Bindings).
  183. $execute(_, _) :-
  184.     notrace, 
  185.     $ttyformat('~nNo~n'),
  186.     fail.
  187.  
  188. $execute_goal(trace, []) :-
  189.     trace, 
  190.     $ttyformat('~n'),
  191.     $write_bindings([]), !, 
  192.     fail.
  193. $execute_goal(Goal, Bindings) :-
  194.     $module(TypeIn, TypeIn), 
  195.     $user_call(TypeIn:Goal),
  196.     $ttyformat('~n'),
  197.     $write_bindings(Bindings), !, 
  198.     notrace, 
  199.     fail.
  200. $execute_goal(_, _) :-
  201.     notrace, 
  202.     $ttyformat('~nNo~n'),
  203.     fail.
  204.  
  205. $user_call(Goal) :-
  206.     Goal.
  207.  
  208. :- $hide($user_call, 1),
  209.    $show_childs($user_call, 1),
  210.    $predicate_attribute($user_call(_), system, 0).
  211.  
  212. $write_bindings([]) :- !, 
  213.     $ttyformat('Yes~n').
  214. $write_bindings(Bindings) :-
  215.     repeat,
  216.         $output_bindings(Bindings),
  217.         get_respons(Action),
  218.     (   Action == redo
  219.     ->  !, fail
  220.     ;   Action == show_again
  221.     ->  fail
  222.     ;   !, format(user_output, '~n~nYes~n', [])
  223.     ).
  224.  
  225. :- flag($toplevel_print_predicate, _, print).
  226.  
  227. $output_bindings([]) :- !,
  228.     $ttyformat('Yes~n').
  229. $output_bindings([Name = Var]) :- !,
  230.     $output_binding(Name, Var),
  231.     write(user_output, ' '),
  232.     ttyflush.
  233. $output_bindings([Name = Var|Rest]) :-
  234.     $output_binding(Name, Var),
  235.     nl(user_output),
  236.     $output_bindings(Rest).
  237.  
  238. $output_binding(Name, Var) :-
  239.     write(user_output, Name),
  240.     write(user_output, ' = '),
  241.     flag($toplevel_print_predicate, Pred, Pred),
  242.     Goal =.. [Pred, user_output, Var],
  243.     Goal.
  244.  
  245. get_respons(Action) :-
  246.     repeat,
  247.         ttyflush,
  248.         get_single_char(Char),
  249.         answer_respons(Char, Action),
  250.         (   Action == again
  251.         ->  $ttyformat('Action? '),
  252.         fail
  253.         ;   !
  254.         ).
  255.  
  256. answer_respons(Char, again) :-
  257.     memberchk(Char, "?h"), !,
  258.     show_toplevel_usage.
  259. answer_respons(Char, redo) :-
  260.     memberchk(Char, ";nrNR"), !,
  261.     $format_if_tty(';~n').
  262. answer_respons(Char, redo) :-
  263.     memberchk(Char, "tT"), !,
  264.     trace,
  265.     $format_if_tty('; [trace]~n').
  266. answer_respons(Char, continue) :-
  267.     memberchk(Char, [0'c, 0' , 10, 0'y, 0'Y]), !.
  268. answer_respons(0'b, show_again) :- !,
  269.     break.
  270. answer_respons(Char, show_again) :-
  271.     print_predicate(Char, Pred), !,
  272.     $format_if_tty('~w~n', [Pred]),
  273.     flag($toplevel_print_predicate, _, Pred).
  274. answer_respons(_, again) :-
  275.     $ttyformat('~nUnknown action (h for help)~nAction? '),
  276.     ttyflush.
  277.  
  278. print_predicate(0'd, display).
  279. print_predicate(0'w, write).
  280. print_predicate(0'p, print).
  281.  
  282. show_toplevel_usage :-
  283.     $ttyformat('~nActions:~n'),
  284.     $ttyformat('; (n, r):     redo    t:               trace & redo~n'),
  285.     $ttyformat('b:            break   c (ret, space):  continue~n'),
  286.     $ttyformat('d:            display p                print~n'),
  287.     $ttyformat('w:            write   h (?):           help~n').
  288.  
  289. $format_if_tty(Fmt) :-
  290.     $format_if_tty(Fmt, []).
  291. $format_if_tty(Fmt, Args) :-
  292.     $tty, !,
  293.     $ttyformat(Fmt, Args).
  294. $format_if_tty(_, _).
  295.  
  296. :- module_transparent
  297.     time/1, 
  298.     $time_call/2.
  299.  
  300. time(Goal) :-
  301.     statistics(cputime, OldTime), 
  302.     statistics(inferences, OldInferences), 
  303.     $time_call(Goal, Result), 
  304.     statistics(inferences, NewInferences), 
  305.     statistics(cputime, NewTime), 
  306.     UsedTime is NewTime - OldTime, 
  307.     UsedInf  is NewInferences - OldInferences, 
  308.     (   UsedTime =:= 0
  309.     ->  Lips = 'Infinite'
  310.     ;   Lips is integer(UsedInf / UsedTime)
  311.     ), 
  312.     $ttyformat('~D inferences in ~2f seconds (~w Lips)~n',
  313.             [UsedInf, UsedTime, Lips]),
  314.     Result == yes.
  315.  
  316. $time_call(Goal, yes) :-
  317.     Goal, !.
  318. $time_call(_Goal, no).
  319.