yap-6.3/pl/control.yap

/*************************************************************************
*									 *
*	 YAP Prolog 							 *
*									 *
*	Yap Prolog was developed at NCCUP - Universidade do Porto	 *
*									 *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997	 *
*									 *
**************************************************************************
*									 *
* File:		control.yap						 *
* Last rev:     20/08/09						 *
* mods:									 *
* comments:	control predicates available in yap			 *
*									 *
*************************************************************************/

:- system_module( '$_control', [at_halt/1,
        b_getval/2,
        break/0,
        call/2,
        call/3,
        call/4,
        call/5,
        call/6,
        call/7,
        call/8,
        call/9,
        call/10,
        call/11,
        call/12,
        call_cleanup/2,
        call_cleanup/3,
        forall/2,
        garbage_collect/0,
        garbage_collect_atoms/0,
        gc/0,
        grow_heap/1,
        grow_stack/1,
        halt/0,
        halt/1,
        if/3,
        ignore/1,
        nb_getval/2,
        nogc/0,
        notrace/1,
        once/1,
        prolog_current_frame/1,
        prolog_initialization/1,
        setup_call_catcher_cleanup/4,
        setup_call_cleanup/3,
        version/0,
        version/1], ['$run_atom_goal'/1,
        '$set_toplevel_hook'/1]).

:- use_system_module( '$_boot', ['$call'/4,
        '$disable_debugging'/0,
        '$do_live'/0,
        '$enable_debugging'/0,
        '$system_catch'/4,
        '$version'/0]).

:- use_system_module( '$_debug', ['$init_debugger'/0]).

:- use_system_module( '$_errors', ['$do_error'/2]).

:- use_system_module( '$_utils', ['$getval_exception'/3]).

:- use_system_module( '$coroutining', [freeze_goal/2]).

once(G) :- '$execute'(G), !.

forall(Cond, Action) :- \+((Cond, \+(Action))).

ignore(Goal) :- (Goal->true;true).

notrace(G) :-
	 strip_module(G, M, G1),
	 ( '$$save_by'(CP),
	   '$debug_stop'( State ),
	   '$call'(G1, CP, G, M),
	   '$$save_by'(CP2),
	   (CP == CP2 -> ! ; '$debug_state'( NState ), ( true ; '$debug_restart'(NStart), fail ) ),
	   '$debug_restart'( State )
     ;
	'$debug_restart'( State ),
	fail
    ).

if(X,Y,Z) :-
	yap_hacks:env_choice_point(CP0),
	(
	 CP is '$last_choice_pt',
	 '$call'(X,CP,if(X,Y,Z),M),
	 '$execute'(X),
	 '$clean_ifcp'(CP),
	 '$call'(Y,CP,if(X,Y,Z),M)
	;
	 '$call'(Z,CP,if(X,Y,Z),M)
	).

call(X,A) :- '$execute'(X,A).

call(X,A1,A2) :- '$execute'(X,A1,A2).

call(X,A1,A2,A3) :- '$execute'(X,A1,A2,A3).

call(X,A1,A2,A3,A4) :- '$execute'(X,A1,A2,A3,A4).

call(X,A1,A2,A3,A4,A5) :- '$execute'(X,A1,A2,A3,A4,A5).

call(X,A1,A2,A3,A4,A5,A6) :- '$execute'(X,A1,A2,A3,A4,A5,A6).

call(X,A1,A2,A3,A4,A5,A6,A7) :- '$execute'(X,A1,A2,A3,A4,A5,A6,A7).

call(X,A1,A2,A3,A4,A5,A6,A7,A8) :- '$execute'(X,A1,A2,A3,A4,A5,A6,A7,A8).

call(X,A1,A2,A3,A4,A5,A6,A7,A8,A9) :- '$execute'(X,A1,A2,A3,A4,A5,A6,A7,A8,A9).

call(X,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10) :- '$execute'(X,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10).

call(X,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,A11) :- '$execute'(X,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,A11).

call_cleanup(Goal, Cleanup) :-
	setup_call_catcher_cleanup(true, Goal, _Catcher, Cleanup).

call_cleanup(Goal, Catcher, Cleanup) :-
	setup_call_catcher_cleanup(true, Goal, Catcher, Cleanup).

setup_call_cleanup(Setup, Goal, Cleanup) :-
	setup_call_catcher_cleanup(Setup, Goal, _Catcher, Cleanup).

setup_call_catcher_cleanup(Setup, Goal, Catcher, Cleanup) :-
	yap_hacks:disable_interrupts,
	'$check_goal_for_setup_call_cleanup'(Setup, setup_call_cleanup(Setup, Goal, Cleanup)),
	catch('$do_setup'(Setup),Exception,'$handle_broken_setup'(Exception)),
	'$check_goal_for_setup_call_cleanup'(Cleanup, setup_call_cleanup(Setup, Goal, Cleanup)),
	'$safe_call_cleanup'(Goal,Cleanup,Catcher,Exception).

% make sure we don't lose interrupts if we get exceptions
% with setup.
'$handle_broken_setup'(Exception) :-
	yap_hacks:enable_interrupts,
	throw(Exception).

'$check_goal_for_setup_call_cleanup'(Goal, G) :-
	strip_module(Goal, _, MG),
	(
	 var(MG)
	->
	 yap_hacks:enable_interrupts,
	 '$do_error'(instantiation_error,G)
	;
	 true
	).

% this is simple, do nothing
'$do_setup'(A:true) :- atom(A), !.
% this is tricky: please don't forget that interrupts are disabled at this point
% and that they will only be enabled after setting up Cleanup
'$do_setup'(Setup) :-
	(
	 '$execute'(Setup),
	 % we don't need to care about enabling interrupts
	 !
	;
	 % reenable interrupts if Setup failed
	 yap_hacks:enable_interrupts,
	 fail
	).
	 

'$cleanup_exception'(Exception, exception(Exception), Cleanup) :- !,
	% whatever happens, let exception go through 
	catch('$clean_call'(_,Cleanup),_,true),
	throw(Exception).
'$cleanup_exception'(Exception, _, _) :-
	throw(Exception).

'$safe_call_cleanup'(Goal, Cleanup, Catcher, Exception) :-
	'$current_choice_point'(MyCP1),
	'$coroutining':freeze_goal(Catcher, '$clean_call'(Active, Cleanup)),
	(
	 yap_hacks:trail_suspension_marker(Catcher),
	 yap_hacks:enable_interrupts,
	 '$current_choice_point'(CP0),
	 '$execute'(Goal),
	 '$current_choice_point'(CPF),
	 (
	  CP0 =:= CPF
	 ->
	  Catcher = exit,
	  !
	 ;
	  true
	 )
	;
	 Catcher = fail,
	 fail
	).

'$holds_true'.

% The first argument is used by JumpEnv to verify if a throw
% is going to be handled by the cleanup catcher. If it is so,
% clean_call will not be called from JumpToEnv.
'$clean_call'(_, Cleanup) :-
	'$execute'(Cleanup), !.
'$clean_call'(_, _).

'$cc_check_throw' :-
	'$nb_getval'('$catch', Ball, fail),
	throw(Ball).	

%%% Some "dirty" predicates

% Only efective if yap compiled with -DDEBUG
% this predicate shows the code produced by the compiler
'$show_code' :- '$debug'(0'f). %' just make emacs happy

grow_heap(X) :- '$grow_heap'(X).
grow_stack(X) :- '$grow_stack'(X).

%
% gc() expects to be called from "call". Make sure it has an
% environment to return to.
%
%garbage_collect :- save(dump), '$gc',  save(dump2).
garbage_collect :-
	'$gc'.
gc :-
	yap_flag(gc,on).
nogc :-
	yap_flag(gc,off).

garbage_collect_atoms :-
	'$atom_gc'.

'$force_environment_for_gc'.

'$good_list_of_character_codes'(V) :- var(V), !.
'$good_list_of_character_codes'([]).
'$good_list_of_character_codes'([X|L]) :-
	'$good_character_code'(X),
	'$good_list_of_character_codes'(L).

'$good_character_code'(X) :- var(X), !.
'$good_character_code'(X) :- integer(X), X > -2, X < 256.

prolog_initialization(G) :- var(G), !,
	'$do_error'(instantiation_error,initialization(G)).
prolog_initialization(T) :- callable(T), !,
	'$assert_init'(T).
prolog_initialization(T) :-
	'$do_error'(type_error(callable,T),initialization(T)).

'$assert_init'(T) :- recordz('$startup_goal',T,_), fail.
'$assert_init'(_).

version :- '$version'.

version(V) :- var(V),  !,
	'$do_error'(instantiation_error,version(V)).
version(T) :- atom(T), !, '$assert_version'(T).
version(T) :-
	'$do_error'(type_error(atom,T),version(T)).

'$assert_version'(T) :- recordz('$version',T,_), fail.
'$assert_version'(_).

'$set_toplevel_hook'(_) :- 
	recorded('$toplevel_hooks',_,R),
	erase(R),
	fail.
'$set_toplevel_hook'(H) :- 
	recorda('$toplevel_hooks',H,_),
	fail.
'$set_toplevel_hook'(_).

nb_getval(GlobalVariable, Val) :-
	'$nb_getval'(GlobalVariable, Val, Error),
	(var(Error)
	->
	 true
	;
	 '$getval_exception'(GlobalVariable, Val, nb_getval(GlobalVariable, Val)) ->
	 nb_getval(GlobalVariable, Val)
	;
	 '$do_error'(existence_error(variable, GlobalVariable),nb_getval(GlobalVariable, Val))
	).
		    

b_getval(GlobalVariable, Val) :-
	'$nb_getval'(GlobalVariable, Val, Error),
	(var(Error)
	->
	 true
	;
	 '$getval_exception'(GlobalVariable, Val, b_getval(GlobalVariable, Val)) ->
	 true
	;
	 '$do_error'(existence_error(variable, GlobalVariable),b_getval(GlobalVariable, Val))
	).


/* This is the break predicate,
	it saves the importante data about current streams and
	debugger state */

'$debug_state'(state(Trace, Debug, Jump, Run, SPY_GN, GList)) :-
	'$init_debugger',
	nb_getval('$trace',Trace),
	nb_getval('$debug_jump',Jump),
	nb_getval('$debug_run',Run),
	'$swi_current_prolog_flag'(debug, Debug),
	nb_getval('$spy_gn',SPY_GN),
	b_getval('$spy_glist',GList).


'$debug_stop'( State ) :-
        '$debug_state'( State ),
	b_setval('$trace',off),
	'$swi_set_prolog_flag'(debug, false),
	b_setval('$spy_glist',[]),
	'$disable_debugging'.

'$debug_restart'(state(Trace, Debug, Jump, Run, SPY_GN, GList)) :- 
	b_setval('$spy_glist',GList),
	b_setval('$spy_gn',SPY_GN),
	'$swi_set_prolog_flag'(debug, Debug),
	b_setval('$debug_jump',Jump),
	b_setval('$debug_run',Run),
	b_setval('$trace',Trace),
	'$enable_debugging'.

break :-
	'$init_debugger',
	nb_getval('$trace',Trace),
	nb_setval('$trace',off),
	nb_getval('$debug_jump',Jump),
	nb_getval('$debug_run',Run),
	'$swi_current_prolog_flag'(debug, Debug),
	'$swi_set_prolog_flag'(debug, false),
	'$break'( true ),
	nb_getval('$spy_gn',SPY_GN),
	b_getval('$spy_glist',GList),
	b_setval('$spy_glist',[]),
	current_output(OutStream), current_input(InpStream),
	'$swi_current_prolog_flag'(break_level, NBL ),
	format(user_error, '% Break (level ~w)~n', [NBL]),
	'$do_live',
	!,
	set_value('$live','$true'),
	b_setval('$spy_glist',GList),
	nb_setval('$spy_gn',SPY_GN),
	set_input(InpStream), 
	set_output(OutStream),
	'$swi_set_prolog_flag'(debug, Debug),
	nb_setval('$debug_jump',Jump),
	nb_setval('$debug_run',Run),
	nb_setval('$trace',Trace),
	'$break'( false ).


at_halt(G) :-
	recorda('$halt', G, _),
	fail.
at_halt(_).

halt :-
	print_message(informational, halt),
	fail.
halt :-
	'$halt'(0).

halt(_) :-
	recorded('$halt', G, _),
	call(G),
	fail.
halt(X) :-
	'$sync_mmapped_arrays',
	set_value('$live','$false'),
	'$halt'(X).

prolog_current_frame(Env) :-
	Env is '$env'.

'$run_atom_goal'(GA) :-
	'$current_module'(Module),
	atom_to_term(GA, G, _),
	'$system_catch'('$query'(once(G), []),Module,Error,user:'$Error'(Error)).

'$add_dot_to_atom_goal'([],[0'.]) :- !. %'
'$add_dot_to_atom_goal'([0'.],[0'.]) :- !.
'$add_dot_to_atom_goal'([C|Gs0],[C|Gs]) :-
	'$add_dot_to_atom_goal'(Gs0,Gs).