Move interactive read-eval-print out of runtime
This is not required for a server process like Gerrit Code Review.
Yanking it out of the runtime JAR slims the binary down by a few
hundred KiBs as the interactive debugger and associated code can
also be trimmed out.
Consulting a file in the interactive console now requires using
consult('path/to/file.pl').
instead of the short-hand ["path/to/file.pl"] that many Prolog
implementations honor.
Change-Id: I5c8df131df349d5ca65d5684ed7cc1881247563b
diff --git a/BUCK b/BUCK
index decdbb1..f170833 100644
--- a/BUCK
+++ b/BUCK
@@ -4,6 +4,7 @@
name = 'all',
cmd = ':>all',
deps = [
+ ':cafeteria',
':compiler',
':runtime',
],
@@ -20,7 +21,10 @@
java_library(
name = 'lang',
- srcs = glob([SRC + 'lang/*.java']),
+ srcs = glob(
+ [SRC + 'lang/*.java'],
+ excludes = [SRC + 'lang/PrologMain.java'],
+ ),
)
java_library(
@@ -67,3 +71,27 @@
src = 'src/compiler/am2j.pl',
out = 'am2j.src.zip',
)
+
+java_binary(
+ name = 'cafeteria',
+ main_class = 'com.googlecode.prolog_cafe.lang.PrologMain',
+ deps = [':cafeteria_lib'],
+)
+
+java_library(
+ name = 'cafeteria_lib',
+ srcs = [
+ SRC + 'lang/PrologMain.java',
+ ':cafeteria_srcs',
+ ],
+ deps = [
+ ':builtin',
+ ':lang',
+ ],
+)
+
+pl2j(
+ name = 'cafeteria_srcs',
+ src = 'src/builtin/cafeteria.pl',
+ out = 'cafeteria.src.zip',
+)
diff --git a/src/builtin/builtins.pl b/src/builtin/builtins.pl
index 2d8e6cf..3349f93 100644
--- a/src/builtin/builtins.pl
+++ b/src/builtin/builtins.pl
@@ -48,15 +48,6 @@
'$meta_call'(X, _, _, _, _) :- var(X), !, illarg(var, call(X), 1).
'$meta_call'(X, _, _, _, _) :- closure(X), !, '$call_closure'(X).
'$meta_call'(true, _, _, _, _) :- !.
-'$meta_call'(trace, _, _, _, _) :- !, trace.
-'$meta_call'(debug, _, _, _, _) :- !, debug.
-'$meta_call'(notrace, _, _, _, _) :- !, notrace.
-'$meta_call'(nodebug, _, _, _, _) :- !, nodebug.
-'$meta_call'(spy(L), _, _, _, _) :- !, spy(L).
-'$meta_call'(nospy(L), _, _, _, _) :- !, nospy(L).
-'$meta_call'(nospyall, _, _, _, _) :- !, nospyall.
-'$meta_call'(leash(L), _, _, _, _) :- !, leash(L).
-'$meta_call'([X|Xs], _, _, _, _) :- !, consult([X|Xs]).
'$meta_call'(_^X, P, Cut, Depth, Mode) :- !,
'$meta_call'(X, P, Cut, Depth, Mode).
'$meta_call'(P:X, _, Cut, Depth, Mode) :- !,
@@ -104,7 +95,7 @@
'$meta_call'(trace, Depth, P, X) :- !,
functor(X, F, A),
- '$trace_goal'(X, P, F/A, Depth).
+ '$call'('com.googlecode.prolog_cafe.builtin', '$trace_goal'(X, P, F/A, Depth)).
'$meta_call'(interpret, Depth, P, X) :-
functor(X, F, A),
'$call_internal'(X, P, F/A, Depth, interpret).
@@ -1902,109 +1893,13 @@
:- op(1150, fx, (multifile)).
:- op(1150, fx, (block)).
-:- public cafeteria/0.
-:- public consult/1.
:- public consult_stream/1.
-:- public trace/0, notrace/0.
-:- public debug/0, nodebug/0.
-:- public leash/1.
-:- public spy/1, nospy/1, nospyall/0.
-:- public listing/0.
-:- public listing/1.
-
-:- dynamic '$current_leash'/1.
-:- dynamic '$current_spypoint'/3.
-:- dynamic '$leap_flag'/1.
:- dynamic '$consulted_file'/1.
:- dynamic '$consulted_import'/2.
:- dynamic '$consulted_package'/1.
:- dynamic '$consulted_predicate'/3.
-%%% Main
-cafeteria :-
- '$cafeteria_init',
- repeat,
- '$toplvel_loop',
- on_exception(Msg, '$cafeteria'(Goal), print_message(error, Msg)),
- Goal == end_of_file,
- !,
- nl, '$fast_write'(bye), nl.
-
-'$cafeteria_init' :-
- retractall('$leap_flag'(_)),
- retractall('$current_leash'(_)),
- retractall('$current_spypoint'(_,_,_)),
- retractall('$consulted_file'(_)),
- retractall('$consulted_package'(_)),
- retractall('$consulted_predicate'(_,_,_)),
- assertz('$leap_flag'(no)),
- assertz('$current_leash'(call)),
- assertz('$current_leash'(exit)),
- assertz('$current_leash'(redo)),
- assertz('$current_leash'(fail)),
- !.
-
-'$toplvel_loop' :-
- current_prolog_flag(debug, Mode),
- (Mode == off -> true ; print_message(info,[debug])),
- '$fast_write'('| ?- '),
- flush_output.
-
-'$cafeteria'(Goal) :-
- read_with_variables(Goal, Vars),
- '$process_order'(Goal, Vars).
-
-'$process_order'(G, _) :- var(G), !, illarg(var, (?- G), 1).
-'$process_order'(end_of_file, _) :- !.
-'$process_order'([File|Files], _) :- !, consult([File|Files]).
-'$process_order'(G, Vars) :-
- current_prolog_flag(debug, Mode),
- ( Mode == off -> call(user:G) ; '$trace_goal'(user:G) ), nl,
- '$rm_redundant_vars'(Vars, Vars1),
- '$give_answers_with_prompt'(Vars1),
- !,
- '$fast_write'(yes), nl.
-'$process_order'(_, _) :- nl, '$fast_write'(no), nl.
-
-'$rm_redundant_vars'([], []) :- !.
-'$rm_redundant_vars'(['_'=_|Xs], Vs) :- !,
- '$rm_redundant_vars'(Xs, Vs).
-'$rm_redundant_vars'([X|Xs], [X|Vs]) :-
- '$rm_redundant_vars'(Xs, Vs).
-
-'$give_answers_with_prompt'([]) :- !.
-'$give_answers_with_prompt'(Vs) :-
- '$give_an_answer'(Vs),
- '$fast_write'(' ? '), flush_output,
- read_line(Str),
- Str \== ";",
- nl.
-
-'$give_an_answer'([]) :- !, '$fast_write'(true).
-'$give_an_answer'([X]) :- !, '$print_an answer'(X).
-'$give_an_answer'([X|Xs]) :-
- '$print_an answer'(X), '$fast_write'(','), nl,
- '$give_an_answer'(Xs).
-
-'$print_an answer'(N = V) :-
- write(N), '$fast_write'(' = '), writeq(V).
-
%%% Read Program
-consult(Files) :- var(Files), !, illarg(var, consult(Files), 1).
-consult([]) :- !.
-consult([File|Files]) :- !, consult(File), consult(Files).
-consult(File) :- atom(File), !, '$consult'(File).
-
-'$consult'(F) :-
- '$prolog_file_name'(F, PF),
- open(PF, read, In),
- stream_property(In, file_name(File)),
- print_message(info, [consulting,File,'...']),
- statistics(runtime, _),
- consult_stream(File, In),
- statistics(runtime, [_,T]),
- print_message(info, [File,consulted,T,msec]),
- close(In).
consult_stream(File, In) :-
'$consult_init'(File),
@@ -2014,9 +1909,6 @@
Cl == end_of_file,
!.
-'$prolog_file_name'(File, File) :- sub_atom(File, _, _, After, '.'), After > 0, !.
-'$prolog_file_name'(File0, File) :- atom_concat(File0, '.pl', File).
-
'$consult_init'(File) :-
retractall('$consulted_file'(_)),
retractall('$consulted_package'(_)),
@@ -2069,231 +1961,6 @@
assertz('$consulted_predicate'(P,F/A,File)),
!.
-%%% Trace
-trace :- current_prolog_flag(debug, on), !.
-trace :-
- set_prolog_flag(debug, on),
- '$trace_init',
- '$fast_write'('{Small debugger is switch on}'),
- nl, !.
-
-'$trace_init' :-
- retractall('$leap_flag'(_)),
- retractall('$current_leash'(_)),
- retractall('$current_spypoint'(_,_,_)),
- assertz('$leap_flag'(no)),
- assertz('$current_leash'(call)),
- assertz('$current_leash'(exit)),
- assertz('$current_leash'(redo)),
- assertz('$current_leash'(fail)),
- !.
-
-notrace :- current_prolog_flag(debug, off), !.
-notrace :-
- set_prolog_flag(debug, off),
- '$fast_write'('{Small debugger is switch off}'),
- nl, !.
-
-debug :- trace.
-nodebug :- notrace.
-
-%%% Spy-Points
-spy(T) :-
- '$term_to_predicateindicator'(T, PI, spy(T)),
- trace,
- '$assert_spypoint'(PI),
- '$set_debug_flag'(leap, yes),
- !.
-
-'$assert_spypoint'(P:F/A) :-
- clause('$current_spypoint'(P,F,A), _),
- print_message(info, [spypoint,P:F/A,is,already,added]),
- !.
-'$assert_spypoint'(P:F/A) :-
- clause('$consulted_predicate'(P,F/A,_), _),
- assertz('$current_spypoint'(P,F,A)),
- print_message(info, [spypoint,P:F/A,is,added]),
- !.
-'$assert_spypoint'(P:F/A) :-
- print_message(warning, [no,matching,predicate,for,spy,P:F/A]).
-
-nospy(T) :-
- '$term_to_predicateindicator'(T, PI, nospy(T)),
- '$retract_spypoint'(PI),
- '$set_debug_flag'(leap, no),
- !.
-
-'$retract_spypoint'(P:F/A) :-
- retract('$current_spypoint'(P,F,A)),
- print_message(info, [spypoint,P:F/A,is,removed]),
- !.
-'$retract_spypoint'(_).
-
-nospyall :-
- retractall('$current_spypoint'(_,_,_)),
- '$set_debug_flag'(leap, no).
-
-%%% Leash
-leash(L) :- nonvar(L), '$leash'(L), !.
-leash(L) :- illarg(type('leash_specifier'), leash(L), 1).
-
-'$leash'([]) :- !,
- retractall('$current_leash'(_)),
- print_message(info, [no,leashing]).
-'$leash'(Ms) :-
- retractall('$current_leash'(_)),
- '$assert_leash'(Ms),
- print_message(info,[leashing,stopping,on,Ms]).
-
-'$assert_leash'([]) :- !.
-'$assert_leash'([X|Xs]) :-
- '$leash_specifier'(X),
- assertz('$current_leash'(X)),
- '$assert_leash'(Xs).
-
-'$leash_specifier'(call).
-'$leash_specifier'(exit).
-'$leash_specifier'(redo).
-'$leash_specifier'(fail).
-%'$leash_specifier'(exception).
-
-%%% Trace a Goal
-'$trace_goal'(Term) :-
- '$set_debug_flag'(leap, no),
- '$get_current_B'(Cut),
- '$meta_call'(Term, user, Cut, 0, trace).
-
-'$trace_goal'(X, P, FA, Depth) :-
- print_procedure_box(call, X, P, FA, Depth),
- '$call_internal'(X, P, FA, Depth, trace),
- print_procedure_box(exit, X, P, FA, Depth),
- redo_procedure_box(X, P, FA, Depth).
-'$trace_goal'(X, P, FA, Depth) :-
- print_procedure_box(fail, X, P, FA, Depth),
- fail.
-
-print_procedure_box(Mode, G, P, F/A, Depth) :-
- clause('$current_spypoint'(P, F, A), _),
- !,
- '$builtin_message'(['+',Depth,Mode,':',P:G]),
- '$read_blocked'(print_procedure_box(Mode,G,P,F/A,Depth)).
-print_procedure_box(Mode, G, P, FA, Depth) :-
- clause('$leap_flag'(no), _),
- !,
- '$builtin_message'([' ',Depth,Mode,':',P:G]),
- ( clause('$current_leash'(Mode), _)
- ->
- '$read_blocked'(print_procedure_box(Mode,G,P,FA,Depth))
- ;
- nl
- ).
-print_procedure_box(_, _, _, _, _).
-
-redo_procedure_box(_, _, _, _).
-redo_procedure_box(X, P, FA, Depth) :-
- print_procedure_box(redo, X, P, FA, Depth),
- fail.
-
-'$read_blocked'(G) :-
- '$fast_write'(' ? '),
- flush_output,
- read_line(C),
- (C == [] -> DOP = 99 ; C = [DOP|_]),
- '$debug_option'(DOP, G).
-
-'$debug_option'(97, _) :- !, notrace, abort. % a for abort
-'$debug_option'(99, _) :- !, '$set_debug_flag'(leap, no). % c for creep
-'$debug_option'(108, _) :- !, '$set_debug_flag'(leap, yes). % l for leap
-'$debug_option'(43, print_procedure_box(Mode,G,P,FA,Depth)) :- !, % + for spy this
- spy(P:FA),
- call(print_procedure_box(Mode,G,P,FA,Depth)).
-'$debug_option'(45, print_procedure_box(Mode,G,P,FA,Depth)) :- !, % - for nospy this
- nospy(P:FA),
- call(print_procedure_box(Mode,G,P,FA,Depth)).
-'$debug_option'(63, G) :- !, '$show_debug_option', call(G).
-'$debug_option'(104, G) :- !, '$show_debug_option', call(G).
-'$debug_option'(_, _).
-
-'$show_debug_option' :-
- tab(4), '$fast_write'('Debuggin options:'), nl,
- tab(4), '$fast_write'('a abort'), nl,
- tab(4), '$fast_write'('RET creep'), nl,
- tab(4), '$fast_write'('c creep'), nl,
- tab(4), '$fast_write'('l leap'), nl,
- tab(4), '$fast_write'('+ spy this'), nl,
- tab(4), '$fast_write'('- nospy this'), nl,
- tab(4), '$fast_write'('? help'), nl,
- tab(4), '$fast_write'('h help'), nl.
-
-'$set_debug_flag'(leap, Flag) :-
- clause('$leap_flag'(Flag), _),
- !.
-'$set_debug_flag'(leap, Flag) :-
- retractall('$leap_flag'(_)),
- assertz('$leap_flag'(Flag)).
-
-%%% Listing
-listing :- '$listing'(_, user).
-
-listing(T) :- var(T), !, illarg(var, listing(T), 1).
-listing(P) :- atom(P), !, '$listing'(_, P).
-listing(F/A) :- !, '$listing'(F/A, user).
-listing(P:PI) :- atom(P), !, '$listing'(PI, P).
-listing(T) :- illarg(type(predicate_indicator), listing(T), 1).
-
-'$listing'(PI, P) :- var(PI), !,
- '$listing_dynamic_clause'(P, _).
-'$listing'(F/A, P) :- atom(F), integer(A), !,
- '$listing_dynamic_clause'(P, F/A).
-'$listing'(PI, P) :- illarg(type(predicate_indicator), listing(P:PI), 1).
-
-'$listing_dynamic_clause'(P, PI) :-
- '$new_internal_database'(P),
- hash_keys(P, Keys),
- '$builtin_member'(PI, Keys),
- PI = F/A,
- functor(H, F, A),
- '$clause_internal'(P, PI, H, Cl, _),
- '$write_dynamic_clause'(P, Cl),
- fail.
-'$listing_dynamic_clause'(_, _).
-
-'$write_dynamic_clause'(_, Cl) :- var(Cl), !, fail.
-'$write_dynamic_clause'(P, (H :- true)) :- !,
- numbervars(H, 0, _),
- '$write_dynamic_head'(P, H),
- write('.'), nl.
-'$write_dynamic_clause'(P, (H :- B)) :- !,
- numbervars((H :- B), 0, _),
- '$write_dynamic_head'(P, H),
- write(' :-'), nl,
- '$write_dynamic_body'(B, 8),
- write('.'), nl.
-
-'$write_dynamic_head'(user, H) :- !, writeq(H).
-'$write_dynamic_head'(P, H) :-
- write(P), write(':'), writeq(H).
-
-'$write_dynamic_body'((G1,G2), N) :- !,
- '$write_dynamic_body'(G1, N), write(','), nl,
- '$write_dynamic_body'(G2, N).
-'$write_dynamic_body'((G1;G2), N) :- !,
- N1 is N+4,
- tab(N), write('('), nl,
- '$write_dynamic_body'(G1, N1), nl,
- tab(N), write(';'), nl,
- '$write_dynamic_body'(G2, N1), nl,
- tab(N), write(')').
-'$write_dynamic_body'((G1->G2), N) :- !,
- N1 is N+4,
- tab(N), write('('), nl,
- '$write_dynamic_body'(G1, N1), nl,
- tab(N), write('->'), nl,
- '$write_dynamic_body'(G2, N1), nl,
- tab(N), write(')').
-'$write_dynamic_body'(B, N) :-
- tab(N), writeq(B).
-
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Misc
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
diff --git a/src/builtin/cafeteria.pl b/src/builtin/cafeteria.pl
new file mode 100644
index 0000000..cb63123
--- /dev/null
+++ b/src/builtin/cafeteria.pl
@@ -0,0 +1,341 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Interactive interpreter of Prolog Cafe
+%
+% Mutsunori Banbara (banbara@kobe-u.ac.jp)
+% Naoyuki Tamura (tamura@kobe-u.ac.jp)
+% Kobe University
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+:- package 'com.googlecode.prolog_cafe.builtin'.
+:- public cafeteria/0.
+
+%%% Main
+cafeteria :-
+ '$cafeteria_init',
+ repeat,
+ '$toplvel_loop',
+ on_exception(Msg, '$cafeteria'(Goal), print_message(error, Msg)),
+ Goal == end_of_file,
+ !,
+ nl, '$fast_write'(bye), nl.
+
+'$cafeteria_init' :-
+ '$new_indexing_hash'('com.googlecode.prolog_cafe.builtin','$leap_flag'/1, _),
+ '$new_indexing_hash'('com.googlecode.prolog_cafe.builtin','$current_spypoint'/3, _),
+ '$new_indexing_hash'('com.googlecode.prolog_cafe.builtin','$current_leash'/1, _),
+ retractall('$leap_flag'(_)),
+ retractall('$current_leash'(_)),
+ retractall('$current_spypoint'(_,_,_)),
+ retractall('$consulted_file'(_)),
+ retractall('$consulted_package'(_)),
+ retractall('$consulted_predicate'(_,_,_)),
+ assertz('$leap_flag'(no)),
+ assertz('$current_leash'(call)),
+ assertz('$current_leash'(exit)),
+ assertz('$current_leash'(redo)),
+ assertz('$current_leash'(fail)),
+ !.
+
+'$toplvel_loop' :-
+ current_prolog_flag(debug, Mode),
+ (Mode == off -> true ; print_message(info,[debug])),
+ '$fast_write'('| ?- '),
+ flush_output.
+
+'$cafeteria'(Goal) :-
+ read_with_variables(Goal, Vars),
+ '$process_order'(Goal, Vars).
+
+'$process_order'(G, _) :- var(G), !, illarg(var, (?- G), 1).
+'$process_order'(end_of_file, _) :- !.
+'$process_order'([File|Files], _) :- !, consult([File|Files]).
+'$process_order'(G, Vars) :-
+ current_prolog_flag(debug, Mode),
+ ( Mode == off -> call(user:G) ; '$trace_goal'(user:G) ), nl,
+ '$rm_redundant_vars'(Vars, Vars1),
+ '$give_answers_with_prompt'(Vars1),
+ !,
+ '$fast_write'(yes), nl.
+'$process_order'(_, _) :- nl, '$fast_write'(no), nl.
+
+'$rm_redundant_vars'([], []) :- !.
+'$rm_redundant_vars'(['_'=_|Xs], Vs) :- !,
+ '$rm_redundant_vars'(Xs, Vs).
+'$rm_redundant_vars'([X|Xs], [X|Vs]) :-
+ '$rm_redundant_vars'(Xs, Vs).
+
+'$give_answers_with_prompt'([]) :- !.
+'$give_answers_with_prompt'(Vs) :-
+ '$give_an_answer'(Vs),
+ '$fast_write'(' ? '), flush_output,
+ read_line(Str),
+ Str \== ";",
+ nl.
+
+'$give_an_answer'([]) :- !, '$fast_write'(true).
+'$give_an_answer'([X]) :- !, '$print_an answer'(X).
+'$give_an_answer'([X|Xs]) :-
+ '$print_an answer'(X), '$fast_write'(','), nl,
+ '$give_an_answer'(Xs).
+
+'$print_an answer'(N = V) :-
+ write(N), '$fast_write'(' = '), writeq(V).
+
+%%% Read Program
+:- public consult/1.
+
+consult(Files) :- var(Files), !, illarg(var, consult(Files), 1).
+consult([]) :- !.
+consult([File|Files]) :- !, consult(File), consult(Files).
+consult(File) :- atom(File), !, '$consult'(File).
+
+'$consult'(F) :-
+ '$prolog_file_name'(F, PF),
+ open(PF, read, In),
+ stream_property(In, file_name(File)),
+ print_message(info, [consulting,File,'...']),
+ statistics(runtime, _),
+ consult_stream(File, In),
+ statistics(runtime, [_,T]),
+ print_message(info, [File,consulted,T,msec]),
+ close(In).
+
+'$prolog_file_name'(File, File) :- sub_atom(File, _, _, After, '.'), After > 0, !.
+'$prolog_file_name'(File0, File) :- atom_concat(File0, '.pl', File).
+
+%%% Trace
+:- public trace/0, notrace/0.
+:- public debug/0, nodebug/0.
+
+trace :- current_prolog_flag(debug, on), !.
+trace :-
+ set_prolog_flag(debug, on),
+ '$trace_init',
+ '$fast_write'('{Small debugger is switch on}'),
+ nl, !.
+
+'$trace_init' :-
+ retractall('$leap_flag'(_)),
+ retractall('$current_leash'(_)),
+ retractall('$current_spypoint'(_,_,_)),
+ assertz('$leap_flag'(no)),
+ assertz('$current_leash'(call)),
+ assertz('$current_leash'(exit)),
+ assertz('$current_leash'(redo)),
+ assertz('$current_leash'(fail)),
+ !.
+
+notrace :- current_prolog_flag(debug, off), !.
+notrace :-
+ set_prolog_flag(debug, off),
+ '$fast_write'('{Small debugger is switch off}'),
+ nl, !.
+
+debug :- trace.
+nodebug :- notrace.
+
+%%% Trace a Goal
+'$trace_goal'(Term) :-
+ '$set_debug_flag'(leap, no),
+ '$get_current_B'(Cut),
+ '$meta_call'(Term, user, Cut, 0, trace).
+
+'$trace_goal'(nodebug, _, _, _) :- nodebug.
+'$trace_goal'(notrace, _, _, _) :- notrace.
+'$trace_goal'(X, P, FA, Depth) :-
+ print_procedure_box(call, X, P, FA, Depth),
+ '$call_internal'(X, P, FA, Depth, trace),
+ print_procedure_box(exit, X, P, FA, Depth),
+ redo_procedure_box(X, P, FA, Depth).
+'$trace_goal'(X, P, FA, Depth) :-
+ print_procedure_box(fail, X, P, FA, Depth),
+ fail.
+
+print_procedure_box(Mode, G, P, F/A, Depth) :-
+ clause('$current_spypoint'(P, F, A), _),
+ !,
+ '$builtin_message'(['+',Depth,Mode,':',P:G]),
+ '$read_blocked'(print_procedure_box(Mode,G,P,F/A,Depth)).
+print_procedure_box(Mode, G, P, FA, Depth) :-
+ clause('$leap_flag'(no), _),
+ !,
+ '$builtin_message'([' ',Depth,Mode,':',P:G]),
+ ( clause('$current_leash'(Mode), _)
+ ->
+ '$read_blocked'(print_procedure_box(Mode,G,P,FA,Depth))
+ ;
+ nl
+ ).
+print_procedure_box(_, _, _, _, _).
+
+redo_procedure_box(_, _, _, _).
+redo_procedure_box(X, P, FA, Depth) :-
+ print_procedure_box(redo, X, P, FA, Depth),
+ fail.
+
+'$read_blocked'(G) :-
+ '$fast_write'(' ? '),
+ flush_output,
+ read_line(C),
+ (C == [] -> DOP = 99 ; C = [DOP|_]),
+ '$debug_option'(DOP, G).
+
+'$debug_option'(97, _) :- !, notrace, abort. % a for abort
+'$debug_option'(99, _) :- !, '$set_debug_flag'(leap, no). % c for creep
+'$debug_option'(108, _) :- !, '$set_debug_flag'(leap, yes). % l for leap
+'$debug_option'(43, print_procedure_box(Mode,G,P,FA,Depth)) :- !, % + for spy this
+ spy(P:FA),
+ call(print_procedure_box(Mode,G,P,FA,Depth)).
+'$debug_option'(45, print_procedure_box(Mode,G,P,FA,Depth)) :- !, % - for nospy this
+ nospy(P:FA),
+ call(print_procedure_box(Mode,G,P,FA,Depth)).
+'$debug_option'(63, G) :- !, '$show_debug_option', call(G).
+'$debug_option'(104, G) :- !, '$show_debug_option', call(G).
+'$debug_option'(_, _).
+
+'$show_debug_option' :-
+ tab(4), '$fast_write'('Debugging options:'), nl,
+ tab(4), '$fast_write'('a abort'), nl,
+ tab(4), '$fast_write'('RET creep'), nl,
+ tab(4), '$fast_write'('c creep'), nl,
+ tab(4), '$fast_write'('l leap'), nl,
+ tab(4), '$fast_write'('+ spy this'), nl,
+ tab(4), '$fast_write'('- nospy this'), nl,
+ tab(4), '$fast_write'('? help'), nl,
+ tab(4), '$fast_write'('h help'), nl.
+
+'$set_debug_flag'(leap, Flag) :-
+ clause('$leap_flag'(Flag), _),
+ !.
+'$set_debug_flag'(leap, Flag) :-
+ retractall('$leap_flag'(_)),
+ assertz('$leap_flag'(Flag)).
+
+%%% Spy-Points
+:- public spy/1, nospy/1, nospyall/0.
+
+spy(T) :-
+ '$term_to_predicateindicator'(T, PI, spy(T)),
+ trace,
+ '$assert_spypoint'(PI),
+ '$set_debug_flag'(leap, yes),
+ !.
+
+'$assert_spypoint'(P:F/A) :-
+ clause('$current_spypoint'(P,F,A), _),
+ print_message(info, [spypoint,P:F/A,is,already,added]),
+ !.
+'$assert_spypoint'(P:F/A) :-
+ clause('$consulted_predicate'(P,F/A,_), _),
+ assertz('$current_spypoint'(P,F,A)),
+ print_message(info, [spypoint,P:F/A,is,added]),
+ !.
+'$assert_spypoint'(P:F/A) :-
+ print_message(warning, [no,matching,predicate,for,spy,P:F/A]).
+
+nospy(T) :-
+ '$term_to_predicateindicator'(T, PI, nospy(T)),
+ '$retract_spypoint'(PI),
+ '$set_debug_flag'(leap, no),
+ !.
+
+'$retract_spypoint'(P:F/A) :-
+ retract('$current_spypoint'(P,F,A)),
+ print_message(info, [spypoint,P:F/A,is,removed]),
+ !.
+'$retract_spypoint'(_).
+
+nospyall :-
+ retractall('$current_spypoint'(_,_,_)),
+ '$set_debug_flag'(leap, no).
+
+%%% Leash
+:- public leash/1.
+
+leash(L) :- nonvar(L), '$leash'(L), !.
+leash(L) :- illarg(type('leash_specifier'), leash(L), 1).
+
+'$leash'([]) :- !,
+ retractall('$current_leash'(_)),
+ print_message(info, [no,leashing]).
+'$leash'(Ms) :-
+ retractall('$current_leash'(_)),
+ '$assert_leash'(Ms),
+ print_message(info,[leashing,stopping,on,Ms]).
+
+'$assert_leash'([]) :- !.
+'$assert_leash'([X|Xs]) :-
+ '$leash_specifier'(X),
+ assertz('$current_leash'(X)),
+ '$assert_leash'(Xs).
+
+'$leash_specifier'(call).
+'$leash_specifier'(exit).
+'$leash_specifier'(redo).
+'$leash_specifier'(fail).
+%'$leash_specifier'(exception).
+
+%%% Listing
+:- public listing/0.
+:- public listing/1.
+
+listing :- '$listing'(_, user).
+
+listing(T) :- var(T), !, illarg(var, listing(T), 1).
+listing(P) :- atom(P), !, '$listing'(_, P).
+listing(F/A) :- !, '$listing'(F/A, user).
+listing(P:PI) :- atom(P), !, '$listing'(PI, P).
+listing(T) :- illarg(type(predicate_indicator), listing(T), 1).
+
+'$listing'(PI, P) :- var(PI), !,
+ '$listing_dynamic_clause'(P, _).
+'$listing'(F/A, P) :- atom(F), integer(A), !,
+ '$listing_dynamic_clause'(P, F/A).
+'$listing'(PI, P) :- illarg(type(predicate_indicator), listing(P:PI), 1).
+
+'$listing_dynamic_clause'(P, PI) :-
+ '$new_internal_database'(P),
+ hash_keys(P, Keys),
+ '$builtin_member'(PI, Keys),
+ PI = F/A,
+ functor(H, F, A),
+ '$clause_internal'(P, PI, H, Cl, _),
+ '$write_dynamic_clause'(P, Cl),
+ fail.
+'$listing_dynamic_clause'(_, _).
+
+'$write_dynamic_clause'(_, Cl) :- var(Cl), !, fail.
+'$write_dynamic_clause'(P, (H :- true)) :- !,
+ numbervars(H, 0, _),
+ '$write_dynamic_head'(P, H),
+ write('.'), nl.
+'$write_dynamic_clause'(P, (H :- B)) :- !,
+ numbervars((H :- B), 0, _),
+ '$write_dynamic_head'(P, H),
+ write(' :-'), nl,
+ '$write_dynamic_body'(B, 8),
+ write('.'), nl.
+
+'$write_dynamic_head'(user, H) :- !, writeq(H).
+'$write_dynamic_head'(P, H) :-
+ write(P), write(':'), writeq(H).
+
+'$write_dynamic_body'((G1,G2), N) :- !,
+ '$write_dynamic_body'(G1, N), write(','), nl,
+ '$write_dynamic_body'(G2, N).
+'$write_dynamic_body'((G1;G2), N) :- !,
+ N1 is N+4,
+ tab(N), write('('), nl,
+ '$write_dynamic_body'(G1, N1), nl,
+ tab(N), write(';'), nl,
+ '$write_dynamic_body'(G2, N1), nl,
+ tab(N), write(')').
+'$write_dynamic_body'((G1->G2), N) :- !,
+ N1 is N+4,
+ tab(N), write('('), nl,
+ '$write_dynamic_body'(G1, N1), nl,
+ tab(N), write('->'), nl,
+ '$write_dynamic_body'(G2, N1), nl,
+ tab(N), write(')').
+'$write_dynamic_body'(B, N) :-
+ tab(N), writeq(B).
