1055 lines
26 KiB
Prolog
1055 lines
26 KiB
Prolog
/**
|
|
* @file top.yap
|
|
* @author VITOR SANTOS COSTA <vsc@vcosta-laptop.dcc.fc.up.pt>
|
|
* @date Sat Apr 7 03:14:17 2018
|
|
*
|
|
* @brief top-level implementation plus system booting.
|
|
*
|
|
* @addtogroup TopLevel Top-Level and Boot Predicates
|
|
* @ingroup YAPControl
|
|
*
|
|
* [TOC]
|
|
*
|
|
* @{
|
|
*
|
|
*/
|
|
:- '$system_meta_predicates'([gated_call(0, 0, ?, 0), catch(0, ?, 0), log_event(+, :)]).
|
|
|
|
% @pred live
|
|
%
|
|
% start a Prolog engine.
|
|
live :-
|
|
repeat,
|
|
yap_flag(verbose, normal),
|
|
current_source_module(Module, Module),
|
|
( Module==user
|
|
-> true % '$compile_mode'(_,0)
|
|
; format(user_error, '[~w]~n', [Module])
|
|
),
|
|
'$system_catch'('$enter_top_level',
|
|
Module,
|
|
Error,
|
|
'$Error'(Error)).
|
|
|
|
% Start file for yap
|
|
|
|
/* I/O predicates */
|
|
|
|
/* meaning of flags for '$write' is
|
|
1 quote illegal atoms
|
|
2 ignore operator declarations
|
|
4 output '$VAR'(N) terms as A, B, C, ...
|
|
8 use portray(_)
|
|
*/
|
|
|
|
/* main execution loop */
|
|
'$read_toplevel'(Goal, Bindings, Pos) :-
|
|
'$prompt',
|
|
catch(read_term(user_input,
|
|
Goal,
|
|
|
|
[ variable_names(Bindings),
|
|
syntax_errors(dec10),
|
|
term_position(Pos),
|
|
input_closing_blank(true)
|
|
]),
|
|
E,
|
|
'$handle_toplevel_error'(E)).
|
|
|
|
'$handle_toplevel_error'(syntax_error(_)) :-
|
|
!,
|
|
fail.
|
|
'$handle_toplevel_error'(error(io_error(read, user_input), _)) :-
|
|
!.
|
|
'$handle_toplevel_error'(_, E) :-
|
|
throw(E).
|
|
|
|
|
|
% reset alarms when entering top-level.
|
|
'$enter_top_level' :-
|
|
'$alarm'(0, 0, _, _),
|
|
fail.
|
|
'$enter_top_level' :-
|
|
'$clean_up_dead_clauses',
|
|
fail.
|
|
'$enter_top_level' :-
|
|
get_value('$top_level_goal', GA),
|
|
GA\=[],
|
|
!,
|
|
set_value('$top_level_goal', []),
|
|
'$run_atom_goal'(GA),
|
|
fail.
|
|
'$enter_top_level' :-
|
|
flush_output,
|
|
'$run_toplevel_hooks',
|
|
prompt1(' ?- '),
|
|
'$read_toplevel'(Command, Varnames, Pos),
|
|
'$init_debugger',
|
|
'$command'(Command, Varnames, Pos, top),
|
|
current_prolog_flag(break_level, BreakLevel),
|
|
( BreakLevel\=0
|
|
-> true
|
|
; '$pred_exists'(halt(_), user)
|
|
-> halt(0)
|
|
; '$halt'(0)
|
|
).
|
|
|
|
|
|
'$erase_sets' :-
|
|
eraseall($),
|
|
eraseall('$$set'),
|
|
eraseall('$$one'),
|
|
eraseall('$reconsulted'),
|
|
fail.
|
|
'$erase_sets' :-
|
|
\+ recorded('$path', _, _),
|
|
recorda('$path', [], _).
|
|
'$erase_sets'.
|
|
|
|
'$start_corouts' :-
|
|
eraseall('$corout'),
|
|
eraseall('$result'),
|
|
eraseall('$actual'),
|
|
fail.
|
|
'$start_corouts' :- recorda('$actual',main,_),
|
|
recordz('$corout','$corout'(main,main,'$corout'([],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[])),_Ref),
|
|
recorda('$result',going,_).
|
|
|
|
%
|
|
% Hack in case expand_term has created a list of commands.
|
|
%
|
|
'$execute_commands'(V,_,_,_,_,Source) :- var(V), !,
|
|
'$do_error'(instantiation_error,meta_call(Source)).
|
|
'$execute_commands'([],_,_,_,_,_) :- !.
|
|
'$execute_commands'([C|Cs],M,VL,Pos,Con,Source) :-
|
|
!,
|
|
(
|
|
'$system_catch'('$execute_command'(C,M,VL,Pos,Con,Source),prolog,Error,'$LoopError'(Error, Con)),
|
|
fail
|
|
;
|
|
'$execute_commands'(Cs,M,VL,Pos,Con,Source)
|
|
).
|
|
'$execute_commands'(C,M,VL,Pos,Con,Source) :-
|
|
'$execute_command'(C,M,VL,Pos,Con,Source).
|
|
|
|
%
|
|
%
|
|
%
|
|
|
|
'$execute_command'(C,_,_,_,_,Source) :-
|
|
var(C),
|
|
!,
|
|
'$do_error'(instantiation_error,meta_call(Source)).
|
|
'$execute_command'(C,_,_,_,_top,Source) :-
|
|
number(C),
|
|
!,
|
|
'$do_error'(type_error(callable,C),meta_call(Source)).
|
|
'$execute_command'(R,_,_,_,_top,Source) :-
|
|
db_reference(R),
|
|
!,
|
|
'$do_error'(type_error(callable,R),meta_call(Source)).
|
|
'$execute_command'(end_of_file,_,_,_,_,_) :- !.
|
|
'$execute_command'(Command,_,_,_,_,_) :-
|
|
'__NB_getval__'('$if_skip_mode', skip, fail),
|
|
\+ '$if_directive'(Command),
|
|
!.
|
|
'$execute_command'((:-G),M,VL,Pos,Option,_) :-
|
|
Option \= top,
|
|
!, % allow user expansion
|
|
'$expand_term'((:- M:G), O),
|
|
'$yap_strip_module'(O, NM, NO),
|
|
(
|
|
NO = (:- G1)
|
|
->
|
|
'$process_directive'(G1, Option, NM, VL, Pos)
|
|
;
|
|
'$execute_commands'(G1,NM,VL,Pos,Option,O)
|
|
).
|
|
'$execute_command'((?-G), M, VL, Pos, Option, Source) :-
|
|
Option \= top,
|
|
!,
|
|
'$execute_command'(G, M, VL, Pos, top, Source).
|
|
'$execute_command'(G, M, VL, Pos, Option, Source) :-
|
|
'$continue_with_command'(Option, VL, Pos, M:G, Source).
|
|
|
|
'$expand_term'(T,O) :-
|
|
'$expand_term'(T,top,O).
|
|
|
|
'$expand_term'(T,Con,O) :-
|
|
catch( '$expand_term0'(T,Con,O), _,( '$reenter_debugger'(exit), fail) ),
|
|
!.
|
|
|
|
'$expand_term0'(T,consult,O) :-
|
|
expand_term( T, O).
|
|
'$expand_term0'(T,reconsult,O) :-
|
|
expand_term( T, O).
|
|
'$expand_term0'(T,top,O) :-
|
|
expand_term( T, T1),
|
|
!,
|
|
'$expand_term1'(T1,O).
|
|
'$expand_term0'(T,_,T).
|
|
|
|
'$expand_term1'(T,O) :-
|
|
'$expand_meta_call'(T, none, O).
|
|
|
|
'$continue_with_command'(Where,V,'$stream_position'(C,_P,A1,A2,A3),'$source_location'(_F,L):G,Source) :-
|
|
!,
|
|
'$continue_with_command'(Where,V,'$stream_position'(C,L,A1,A2,A3),G,Source).
|
|
'$continue_with_command'(reconsult,V,Pos,G,Source) :-
|
|
% writeln(G),
|
|
'$go_compile_clause'(G,V,Pos,reconsult,Source),
|
|
fail.
|
|
'$continue_with_command'(consult,V,Pos,G,Source) :-
|
|
'$go_compile_clause'(G,V,Pos,consult,Source),
|
|
fail.
|
|
'$continue_with_command'(top,V,_,G,_) :-
|
|
'$query'(G,V).
|
|
|
|
%%
|
|
% @pred '$go_compile_clause'(G,Vs,Pos, Where, Source) is det
|
|
%
|
|
% interfaces the loader and the compiler
|
|
% not 100% compatible with SICStus Prolog, as SICStus Prolog would put
|
|
% module prefixes all over the place, although unnecessarily so.
|
|
%
|
|
% @param [in] _G_ is the clause to compile
|
|
% @param [in] _Vs_ a list of variables and their name
|
|
% @param [in] _Pos_ the source-code position
|
|
% @param [in] _N_ a flag telling whether to add first or last
|
|
% @param [out] _Source_ the user-tranasformed clause
|
|
'$go_compile_clause'(G, _Vs, _Pos, Where, Source) :-
|
|
'$precompile_term'(G, Source, G1),
|
|
!,
|
|
'$$compile'(G1, Where, Source, _).
|
|
'$go_compile_clause'(G,_Vs,_Pos, _Where, _Source) :-
|
|
throw(error(system, compilation_failed(G))).
|
|
|
|
'$$compile'(C, Where, C0, R) :-
|
|
'$head_and_body'( C, H, B ),
|
|
'$yap_strip_module'(H,Mod,H0),
|
|
(
|
|
'$undefined'(H0, Mod)
|
|
->
|
|
'$init_pred'(H0, Mod, Where)
|
|
;
|
|
true
|
|
),
|
|
% writeln(Mod:((H:-B))),
|
|
'$compile'((H0:-B), Where, C0, Mod, R).
|
|
|
|
'$init_pred'(H, Mod, _Where ) :-
|
|
recorded('$import','$import'(NM,Mod,NH,H,_,_),RI),
|
|
% NM \= Mod,
|
|
functor(NH,N,Ar),
|
|
print_message(warning,redefine_imported(Mod,NM,Mod:N/Ar)),
|
|
erase(RI),
|
|
clause(Mod:H,_,R), erase(R),
|
|
fail.
|
|
'$init_pred'(H, Mod, Where ) :-
|
|
'$init_as_dynamic'(Where),
|
|
!,
|
|
functor(H, Na, Ar),
|
|
'$dynamic'(Na/Ar, Mod).
|
|
'$init_pred'(_H, _Mod, _Where ).
|
|
|
|
'$init_as_dynamic'( asserta ).
|
|
'$init_as_dynamic'( assertz ).
|
|
'$init_as_dynamic'( consult ) :-
|
|
'__NB_getval__'('$assert_all',on,fail).
|
|
'$init_as_dynamic'( reconsult ) :-
|
|
'__NB_getval__'('$assert_all',on,fail).
|
|
|
|
'$check_if_reconsulted'(N,A) :-
|
|
once(recorded('$reconsulted',N/A,_)),
|
|
recorded('$reconsulted',X,_),
|
|
( X = N/A , !;
|
|
X = '$', !, fail;
|
|
fail
|
|
).
|
|
|
|
'$inform_as_reconsulted'(N,A) :-
|
|
recorda('$reconsulted',N/A,_).
|
|
|
|
'$clear_reconsulting' :-
|
|
recorded('$reconsulted',X,Ref),
|
|
erase(Ref),
|
|
X == '$',
|
|
!,
|
|
( recorded('$reconsulting',_,R) -> erase(R) ).
|
|
|
|
'$prompt_alternatives_on'(determinism).
|
|
|
|
/* Executing a query */
|
|
|
|
'$query'(end_of_file,_).
|
|
'$query'(G,[]) :-
|
|
'$prompt_alternatives_on'(OPT),
|
|
( OPT = groundness ; OPT = determinism),
|
|
!,
|
|
'$yes_no'(G,(?-)).
|
|
'$query'(G,V) :-
|
|
(
|
|
'$current_module'(M),
|
|
'$current_choice_point'(CP),
|
|
'$user_call'(G, M),
|
|
'$current_choice_point'(NCP),
|
|
'$delayed_goals'(G, V, Vs, LGs, DCP),
|
|
'$write_answer'(Vs, LGs, Written),
|
|
'$write_query_answer_true'(Written),
|
|
(
|
|
yap_flag(prompt_alternatives_on,determinism), CP == NCP, DCP = 0
|
|
->
|
|
format(user_error, '.~n', []),
|
|
!
|
|
;
|
|
'$another',
|
|
!
|
|
),
|
|
fail
|
|
;
|
|
'$out_neg_answer'
|
|
).
|
|
|
|
'$yes_no'(G,C) :-
|
|
'$current_module'(M),
|
|
'$do_yes_no'(G,M),
|
|
'$delayed_goals'(G, [], NV, LGs, _),
|
|
'$write_answer'(NV, LGs, Written),
|
|
( Written = [] ->
|
|
!,'$present_answer'(C, true)
|
|
;
|
|
'$another', !
|
|
),
|
|
fail.
|
|
'$yes_no'(_,_) :-
|
|
'$out_neg_answer'.
|
|
|
|
'$add_env_and_fail' :- fail.
|
|
|
|
|
|
'$process_answer'(Vs, LGs, Bindings) :-
|
|
%'$purge_dontcares'(Vs,IVs),
|
|
'$sort'(Vs, NVs),
|
|
'$prep_answer_var_by_var'(NVs, LAnsw, LGs),
|
|
'$name_vars_in_goals'(LAnsw, Vs, Bindings).
|
|
|
|
%
|
|
% *-> at this point would require compiler support, which does not exist.
|
|
%
|
|
'$delayed_goals'(G, V, NV, LGs, NCP) :-
|
|
(
|
|
'$$save_by'(NCP1),
|
|
attributes:delayed_goals(G, V, NV, LGs),
|
|
'$clean_ifcp'(NCP1),
|
|
'$$save_by'(NCP2),
|
|
NCP is NCP2-NCP1
|
|
;
|
|
copy_term_nat(V, NV),
|
|
LGs = [],
|
|
% term_factorized(V, NV, LGs),
|
|
NCP = 0
|
|
).
|
|
|
|
'$out_neg_answer' :-
|
|
print_message( help, false),
|
|
fail.
|
|
|
|
|
|
'$do_yes_no'([X|L], M) :-
|
|
!,
|
|
'$csult'([X|L], M).
|
|
'$do_yes_no'(G, M) :-
|
|
'$user_call'(G, M).
|
|
|
|
'$write_query_answer_true'([]) :- !,
|
|
format(user_error,true,[]).
|
|
'$write_query_answer_true'(_).
|
|
|
|
|
|
%
|
|
% present_answer has three components. First it flushes the streams,
|
|
% then it presents the goals, and last it shows any goals frozen on
|
|
% the arguments.
|
|
%
|
|
'$present_answer'(_,_):-
|
|
flush_output,
|
|
fail.
|
|
'$present_answer'((?-), Answ) :-
|
|
current_prolog_flag(break_level, BL ),
|
|
( BL \= 0 -> format(user_error, '[~p] ',[BL]) ;
|
|
true ),
|
|
current_prolog_flag(toplevel_print_options, Opts),
|
|
write_term(user_error,Answ,Opts).
|
|
|
|
'$another' :-
|
|
'$clear_input'(user_input),
|
|
prompt1(' ? '),
|
|
get_code(user_input,C),
|
|
'$do_another'(C).
|
|
|
|
'$do_another'(C) :-
|
|
( C=:= ";" ->
|
|
skip(user_input,10),
|
|
% '$add_nl_outside_console',
|
|
fail
|
|
;
|
|
C== 10
|
|
->
|
|
'$add_nl_outside_console',
|
|
(
|
|
'$undefined'(print_message(_,_),prolog)
|
|
->
|
|
format(user_error,'yes~n', [])
|
|
;
|
|
print_message(help,yes)
|
|
)
|
|
;
|
|
C== 13
|
|
->
|
|
get0(user_input,NC),
|
|
'$do_another'(NC)
|
|
;
|
|
C== -1
|
|
->
|
|
halt
|
|
;
|
|
skip(user_input,10), '$ask_again_for_another'
|
|
).
|
|
|
|
%'$add_nl_outside_console' :-
|
|
% '$is_same_tty'(user_input, user_error), !.
|
|
'$add_nl_outside_console' :-
|
|
format(user_error,'~n',[]).
|
|
|
|
'$ask_again_for_another' :-
|
|
format(user_error,'Action (\";\" for more choices, <return> for exit)', []),
|
|
'$another'.
|
|
|
|
'$write_answer'(_,_,_) :-
|
|
flush_output,
|
|
fail.
|
|
'$write_answer'(Vs, LBlk, FLAnsw) :-
|
|
'$process_answer'(Vs, LBlk, NLAnsw),
|
|
'$write_vars_and_goals'(NLAnsw, first, FLAnsw).
|
|
|
|
%% @pred write_query_answer( +Bindings )
|
|
%
|
|
% YAP uses this routine to output the answer to a query.
|
|
% _Bindings_ are
|
|
% - unifications
|
|
% - suspended or floundered goals, representing constraints.
|
|
%
|
|
write_query_answer( Bindings ) :-
|
|
'$write_vars_and_goals'(Bindings, first, _FLAnsw).
|
|
|
|
'$purge_dontcares'([],[]).
|
|
'$purge_dontcares'([Name=_|Vs],NVs) :-
|
|
atom_codes(Name, [C|_]),
|
|
C is "_",
|
|
!,
|
|
'$purge_dontcares'(Vs,NVs).
|
|
'$purge_dontcares'([V|Vs],[V|NVs]) :-
|
|
'$purge_dontcares'(Vs,NVs).
|
|
|
|
|
|
'$prep_answer_var_by_var'([], L, L).
|
|
'$prep_answer_var_by_var'([Name=Value|L], LF, L0) :-
|
|
'$delete_identical_answers'(L, Value, NL, Names),
|
|
'$prep_answer_var'([Name|Names], Value, LF, LI),
|
|
'$prep_answer_var_by_var'(NL, LI, L0).
|
|
|
|
% fetch all cases that have the same solution.
|
|
'$delete_identical_answers'([], _, [], []).
|
|
'$delete_identical_answers'([(Name=Value)|L], Value0, FL, [Name|Names]) :-
|
|
Value == Value0, !,
|
|
'$delete_identical_answers'(L, Value0, FL, Names).
|
|
'$delete_identical_answers'([VV|L], Value0, [VV|FL], Names) :-
|
|
'$delete_identical_answers'(L, Value0, FL, Names).
|
|
|
|
% now create a list of pairs that will look like goals.
|
|
'$prep_answer_var'(Names, Value, LF, L0) :- var(Value), !,
|
|
'$prep_answer_unbound_var'(Names, LF, L0).
|
|
'$prep_answer_var'(Names, Value, [nonvar(Names,Value)|L0], L0).
|
|
|
|
% ignore unbound variables
|
|
'$prep_answer_unbound_var'([_], L, L) :- !.
|
|
'$prep_answer_unbound_var'(Names, [var(Names)|L0], L0).
|
|
|
|
'$gen_name_string'(I,L,[C|L]) :- I < 26, !, C is I+65.
|
|
'$gen_name_string'(I,L0,LF) :-
|
|
I1 is I mod 26,
|
|
I2 is I // 26,
|
|
C is I1+65,
|
|
'$gen_name_string'(I2,[C|L0],LF).
|
|
|
|
'$write_vars_and_goals'([], _, []).
|
|
'$write_vars_and_goals'([nl,G1|LG], First, NG) :- !,
|
|
nl(user_error),
|
|
'$write_goal_output'(G1, First, NG, Next, IG),
|
|
'$write_vars_and_goals'(LG, Next, IG).
|
|
'$write_vars_and_goals'([G1|LG], First, NG) :-
|
|
'$write_goal_output'(G1, First, NG, Next, IG),
|
|
'$write_vars_and_goals'(LG, Next, IG).
|
|
|
|
|
|
'$write_goal_output'(var([V|VL]), First, [var([V|VL])|L], next, L) :- !,
|
|
( First = first -> true ; format(user_error,',~n',[]) ),
|
|
format(user_error,'~a',[V]),
|
|
'$write_output_vars'(VL).
|
|
'$write_goal_output'(nonvar([V|VL],B), First, [nonvar([V|VL],B)|L], next, L) :- !,
|
|
( First = first -> true ; format(user_error,',~n',[]) ),
|
|
format(user_error,'~a',[V]),
|
|
'$write_output_vars'(VL),
|
|
format(user_error,' = ', []),
|
|
( yap_flag(toplevel_print_options, Opts) ->
|
|
write_term(user_error,B,[priority(699)|Opts]) ;
|
|
write_term(user_error,B,[priority(699)])
|
|
).
|
|
'$write_goal_output'(nl, First, NG, First, NG) :- !,
|
|
format(user_error,'~n',[]).
|
|
'$write_goal_output'(Format-G, First, NG, Next, IG) :- !,
|
|
G = [_|_], !,
|
|
% dump on string first so that we can check whether we actually
|
|
% had any output from the solver.
|
|
format(string(String),Format,G),
|
|
( String == `` ->
|
|
% we didn't
|
|
IG = NG, First = Next
|
|
;
|
|
% we did
|
|
format(user_error, '~N~s', [String]),
|
|
NG = [G|IG]
|
|
).
|
|
'$write_goal_output'(_-G, First, [G|NG], next, NG) :- !,
|
|
( First = first -> true ; format(user_error,',~n',[]) ),
|
|
( yap_flag(toplevel_print_options, Opts) ->
|
|
write_term(user_error,G,Opts) ;
|
|
format(user_error,'~w',[G])
|
|
).
|
|
'$write_goal_output'(_M:G, First, [G|NG], next, NG) :- !,
|
|
( First = first -> true ; format(user_error,',~n',[]) ),
|
|
( yap_flag(toplevel_print_options, Opts) ->
|
|
write_term(user_error,G,Opts) ;
|
|
format(user_error,'~w',[G])
|
|
).
|
|
'$write_goal_output'(G0, First, [M:G|NG], next, NG) :-
|
|
'$yap_strip_module'(G0,M,G),
|
|
( First = first -> true ; format(user_error,',~n',[]) ),
|
|
( yap_flag(toplevel_print_options, Opts) ->
|
|
write_term(user_error,G,Opts) ;
|
|
format(user_error,'~w',[G])
|
|
).
|
|
|
|
'$name_vars_in_goals'(G, VL0, G) :-
|
|
'$name_well_known_vars'(VL0),
|
|
'$variables_in_term'(G, [], GVL),
|
|
'$name_vars_in_goals1'(GVL, 0, _).
|
|
|
|
'$name_well_known_vars'([]).
|
|
'$name_well_known_vars'([Name=V|NVL0]) :-
|
|
var(V), !,
|
|
V = '$VAR'(Name),
|
|
'$name_well_known_vars'(NVL0).
|
|
'$name_well_known_vars'([_|NVL0]) :-
|
|
'$name_well_known_vars'(NVL0).
|
|
|
|
'$name_vars_in_goals1'([], I, I).
|
|
'$name_vars_in_goals1'([V|NGVL], I0, IF) :-
|
|
I is I0+1,
|
|
'$gen_name_string'(I0,[],SName), !,
|
|
atom_codes(Name, [95|SName]),
|
|
V = '$VAR'(Name),
|
|
'$name_vars_in_goals1'(NGVL, I, IF).
|
|
'$name_vars_in_goals1'([NV|NGVL], I0, IF) :-
|
|
nonvar(NV),
|
|
'$name_vars_in_goals1'(NGVL, I0, IF).
|
|
|
|
'$write_output_vars'([]).
|
|
'$write_output_vars'([V|VL]) :-
|
|
format(user_error,' = ~a',[V]),
|
|
'$write_output_vars'(VL).
|
|
|
|
|
|
%
|
|
% standard meta-call, called if $execute could not do everything.
|
|
%
|
|
'$meta_call'(G, M) :-
|
|
'$current_choice_point'(CP),
|
|
'$call'(G, CP, G, M).
|
|
|
|
'$user_call'(G, M) :-
|
|
'$current_choice_point'(CP),
|
|
gated_call('$start_user_code',M:G,Port,'$reenter_debugger'(Port)).
|
|
|
|
'$cut_by'(CP) :- '$$cut_by'(CP).
|
|
|
|
%
|
|
% do it in ISO mode.
|
|
%
|
|
'$meta_call'(G,_ISO,M) :-
|
|
'$iso_check_goal'(G,G),
|
|
'$current_choice_point'(CP),
|
|
'$call'(G, CP, G, M).
|
|
|
|
'$meta_call'(G, CP, G0, M) :-
|
|
'$call'(G, CP, G0, M).
|
|
|
|
'$call'(G, CP, G0, _, M) :- /* iso version */
|
|
'$iso_check_goal'(G,G0),
|
|
'$call'(G, CP, G0, M).
|
|
|
|
'$call'(M:G,CP,G0,_M0) :- !,
|
|
expand_goal(M:G, NG),
|
|
must_be_callable(NG),
|
|
|
|
'$yap_strip_module'(M:NG,NM,NC),
|
|
'$call'(NC,CP,G0,NM).
|
|
'$call'((X,Y),CP,G0,M) :- !,
|
|
'$call'(X,CP,G0,M),
|
|
'$call'(Y,CP,G0,M).
|
|
'$call'((X->Y),CP,G0,M) :- !,
|
|
(
|
|
'$call'(X,CP,G0,M)
|
|
->
|
|
'$call'(Y,CP,G0,M)
|
|
).
|
|
'$call'((X*->Y),CP,G0,M) :- !,
|
|
(
|
|
'$call'(X,CP,G0,M)
|
|
*->
|
|
'$call'(Y,CP,G0,M)
|
|
).
|
|
'$call'((X->Y; Z),CP,G0,M) :- !,
|
|
(
|
|
'$call'(X,CP,G0,M)
|
|
->
|
|
'$call'(Y,CP,G0,M)
|
|
;
|
|
'$call'(Z,CP,G0,M)
|
|
).
|
|
'$call'((X*->Y; Z),CP,G0,M) :- !,
|
|
(
|
|
'$current_choice_point'(DCP),
|
|
'$call'(X,CP,G0,M),
|
|
yap_hacks:cut_at(DCP),
|
|
'$call'(Y,CP,G0,M)
|
|
;
|
|
'$call'(Z,CP,G0,M)
|
|
).
|
|
'$call'((A;B),CP,G0,M) :- !,
|
|
(
|
|
'$call'(A,CP,G0,M)
|
|
;
|
|
'$call'(B,CP,G0,M)
|
|
).
|
|
'$call'((X->Y| Z),CP,G0,M) :- !,
|
|
(
|
|
'$call'(X,CP,G0,M)
|
|
->
|
|
'$call'(Y,CP,G0,M)
|
|
;
|
|
'$call'(Z,CP,G0,M)
|
|
).
|
|
|
|
'$call'((X*->Y| Z),CP,G0,M) :- !,
|
|
(
|
|
'$current_choice_point'(DCP),
|
|
'$call'(X,CP,G0,M),
|
|
yap_hacks:cut_at(DCP),
|
|
'$call'(Y,CP,G0,M)
|
|
;
|
|
'$call'(Z,CP,G0,M)
|
|
).
|
|
'$call'((A|B),CP, G0,M) :- !,
|
|
(
|
|
'$call'(A,CP,G0,M)
|
|
;
|
|
'$call'(B,CP,G0,M)
|
|
).
|
|
'$call'(\+ X, _CP, G0, M) :- !,
|
|
\+ ('$current_choice_point'(CP),
|
|
'$call'(X,CP,G0,M) ).
|
|
'$call'(not(X), _CP, G0, M) :- !,
|
|
\+ ('$current_choice_point'(CP),
|
|
'$call'(X,CP,G0,M) ).
|
|
'$call'(!, CP, _G0, _m) :- !,
|
|
'$$cut_by'(CP).
|
|
'$call'(forall(X,Y), CP, _G0, _m) :- !,
|
|
\+ ('$call'(X, CP, G0, M),
|
|
\+ '$call'(Y, CP, G0, M) ).
|
|
'$call'(once(X), CP, G0, M) :- !,
|
|
( '$call'(X, CP, G0, M) -> true).
|
|
'$call'(!, CP, _G0, _m) :- !,
|
|
'$$cut_by'(CP).
|
|
'$call'([X|Y], _, _, M) :-
|
|
(Y == [] ->
|
|
consult(M:X)
|
|
;
|
|
'$csult'([X|Y] ,M)
|
|
).
|
|
'$call'(G, _CP, _G0, CurMod) :-
|
|
% /*
|
|
% (
|
|
% '$is_metapredicate'(G,CurMod)
|
|
% ->
|
|
% '$reenter_debugger'(exit)',
|
|
% ( '$expand_meta_call'(CurMod:G, [], NG) -> true ; true ),
|
|
% '$enable_debugging'
|
|
% ;
|
|
% NG = G
|
|
% ),
|
|
% */
|
|
'$execute0'(G, CurMod).
|
|
|
|
'$loop'(Stream,exo) :-
|
|
prolog_flag(agc_margin,Old,0),
|
|
prompt1(': '), prompt(_,'| '),
|
|
source_module(OldModule,OldModule),
|
|
repeat,
|
|
'$system_catch'(dbload_from_stream(Stream, OldModule, exo), '$db_load', Error,
|
|
user:'$LoopError'(Error, top)),
|
|
prolog_flag(agc_margin,_,Old),
|
|
!.
|
|
'$loop'(Stream,db) :-
|
|
prolog_flag(agc_margin,Old,0),
|
|
prompt1(': '), prompt(_,'| '),
|
|
source_module(OldModule,OldModule),
|
|
repeat,
|
|
'$system_catch'(dbload_from_stream(Stream, OldModule, db), '$db_load', Error, user:'$LoopError'(Error, db)
|
|
),
|
|
prolog_flag(agc_margin,_,Old),
|
|
!.
|
|
'$loop'(Stream,Status) :-
|
|
repeat,
|
|
'$current_module'( OldModule, OldModule ),
|
|
'$system_catch'( '$enter_command'(Stream,OldModule,Status),
|
|
OldModule, Error,
|
|
user:'$LoopError'(Error, Status)
|
|
),
|
|
!.
|
|
|
|
'$boot_loop'(Stream,Where) :-
|
|
repeat,
|
|
source_module( OldModule, OldModule ),
|
|
read_clause(Stream, Command, [module(OldModule), syntax_errors(dec10),variable_names(_Vars), term_position(_Pos)]),
|
|
(Command == end_of_file
|
|
->
|
|
!
|
|
;
|
|
Command = (:- Goal) ->
|
|
'$system_catch'('$boot_execute'(Goal), prolog, Error,
|
|
user:'$LoopError'(Error, consult) ),
|
|
fail
|
|
;
|
|
Command = (H --> B) ->
|
|
'$system_catch'('$boot_dcg'(H,B, Where), prolog, Error,
|
|
user:'$LoopError'(Error, consult) ),
|
|
|
|
fail
|
|
;
|
|
'$system_catch'('$boot_clause'( Command, Where ), prolog, Error,
|
|
user:'$LoopError'(Error, consult) ),
|
|
fail
|
|
).
|
|
|
|
'$boot_execute'( Goal ) :-
|
|
'$execute'( Goal ),
|
|
!.
|
|
'$boot_execute'( Goal ) :-
|
|
format(user_error, ':- ~w failed.~n', [Goal]).
|
|
|
|
'$boot_dcg'( H, B, Where ) :-
|
|
'$translate_rule'((H --> B), (NH :- NB) ),
|
|
'$$compile'((NH :- NB), Where, ( H --> B), _R),
|
|
!.
|
|
'$boot_dcg'( H, B, _ ) :-
|
|
format(user_error, ' ~w --> ~w failed.~n', [H,B]).
|
|
|
|
'$boot_clause'( Command, Where ) :-
|
|
'$$compile'(Command, Where, Command, _R),
|
|
!.
|
|
'$boot_clause'( Command, _ ) :-
|
|
format(user_error, ' ~w failed.~n', [Command]).
|
|
|
|
'$enter_command'(Stream, Mod, Status) :-
|
|
prompt1(': '), prompt(_,' '),
|
|
Options = [module(Mod), syntax_errors(dec10),variable_names(Vars), term_position(Pos)],
|
|
(
|
|
Status == top
|
|
->
|
|
read_term(Stream, Command, Options)
|
|
;
|
|
read_clause(Stream, Command, Options)
|
|
),
|
|
'$command'(Command,Vars,Pos, Status) .
|
|
|
|
/** @pred user:expand_term( _T_,- _X_) is dynamic,multifile.
|
|
|
|
This user-defined predicate is called by YAP after
|
|
reading goals and clauses.
|
|
|
|
- _Module_:`expand_term(` _T_ , _X_) is called first on the
|
|
current source module _Module_ ; if i
|
|
- `user:expand_term(` _T_ , _X_ `)` is available on every module.
|
|
|
|
*/
|
|
|
|
/* General purpose predicates */
|
|
|
|
'$head_and_body'(M:(H:-B),M:H,M:B) :- !.
|
|
'$head_and_body'((H:-B),H,B) :- !.
|
|
'$head_and_body'(H,H,true).
|
|
|
|
|
|
gated_call(Setup, Goal, Catcher, Cleanup) :-
|
|
'$setup_call_catcher_cleanup'(Setup),
|
|
'$gated_call'( true , Goal, Catcher, Cleanup) .
|
|
|
|
'$gated_call'( All , Goal, Catcher, Cleanup) :-
|
|
Task0 = cleanup( All, Catcher, Cleanup, Tag, true, CP0),
|
|
TaskF = cleanup( All, Catcher, Cleanup, Tag, false, CP0),
|
|
'$tag_cleanup'(CP0, Task0),
|
|
call( Goal ),
|
|
'$cleanup_on_exit'(CP0, TaskF).
|
|
|
|
|
|
%
|
|
% split head and body, generate an error if body is unbound.
|
|
%
|
|
'$check_head_and_body'(C,M,H,B,_P) :-
|
|
'$yap_strip_module'(C,M1,(MH:-B0)),
|
|
!,
|
|
'$yap_strip_module'(M1:MH,M,H),
|
|
( M == M1 -> B = B0 ; B = M1:B0),
|
|
must_be_callable(M:H).
|
|
|
|
'$check_head_and_body'(MH, M, H, true, _XsP) :-
|
|
'$yap_strip_module'(MH,M,H),
|
|
must_be_callable(M:H).
|
|
% term expansion
|
|
%
|
|
% return two arguments: Expanded0 is the term after "USER" expansion.
|
|
% Expanded is the final expanded term.
|
|
%
|
|
'$precompile_term'(Term, ExpandedUser, Expanded) :-
|
|
%format('[ ~w~n',[Term]),
|
|
'$expand_clause'(Term, ExpandedUser, ExpandedI),
|
|
!,
|
|
%format(' -> ~w~n',[Expanded0]),
|
|
(
|
|
current_prolog_flag(strict_iso, true) /* strict_iso on */
|
|
->
|
|
Expanded = ExpandedI,
|
|
'$check_iso_strict_clause'(ExpandedUser)
|
|
;
|
|
'$expand_array_accesses_in_term'(ExpandedI,Expanded)
|
|
-> true
|
|
;
|
|
Expanded = ExpandedI
|
|
).
|
|
'$precompile_term'(Term, Term, Term).
|
|
|
|
'$expand_clause'(InputCl, C1, CO) :-
|
|
'$expand_a_clause'( InputCl, C1, CO),
|
|
!.
|
|
'$expand_clause'(Cl, Cl, Cl).
|
|
|
|
/** @pred expand_term( _T_,- _X_)
|
|
|
|
This predicate is used by YAP for preprocessing each top level
|
|
term read when consulting a file and before asserting or executing it.
|
|
It rewrites a term _T_ to a term _X_ according to the following
|
|
rules: first try term_expansion/2 in the current module, and then try to use the user defined predicate user:term_expansion/2`. If this call fails then the translating process
|
|
for DCG rules is applied, together with the arithmetic optimizer
|
|
whenever the compilation of arithmetic expressions is in progress.
|
|
|
|
*/
|
|
expand_term(Term,Expanded) :-
|
|
(
|
|
'$do_term_expansion'(Term,Expanded)
|
|
->
|
|
true
|
|
;
|
|
'$expand_term_grammar'(Term,Expanded)
|
|
).
|
|
|
|
%
|
|
% Grammar Rules expansion
|
|
%
|
|
'$expand_term_grammar'((A-->B), C) :-
|
|
prolog:'$translate_rule'((A-->B),C), !.
|
|
'$expand_term_grammar'(A, A).
|
|
|
|
%
|
|
% Arithmetic expansion
|
|
%
|
|
'$expand_array_accesses_in_term'(Expanded0,ExpandedF) :-
|
|
'$array_refs_compiled',
|
|
'$arrays':'$c_arrays'(Expanded0,ExpandedF), !.
|
|
'$expand_array_accesses_in_term'(Expanded,Expanded).
|
|
|
|
%% @}
|
|
|
|
%% @addtogroup CathThrow Catch and Throw
|
|
% @ingroup YAPControl
|
|
% @{
|
|
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
% catch/throw implementation
|
|
|
|
% at each catch point I need to know:
|
|
% what is ball;
|
|
% where was the previous catch
|
|
|
|
/**
|
|
@pred catch( : _Goal_,+ _Exception_,+ _Action_) is iso
|
|
|
|
|
|
The goal `catch( _Goal_, _Exception_, _Action_)` tries to
|
|
execute goal _Goal_. If during its execution, _Goal_ throws an
|
|
exception _E'_ and this exception unifies with _Exception_, the
|
|
exception is considered to be caught and _Action_ is executed. If
|
|
the exception _E'_ does not unify with _Exception_, control
|
|
again throws the exception.
|
|
|
|
The top-level of YAP maintains a default exception handler that
|
|
is responsible to capture uncaught exceptions.
|
|
|
|
*/
|
|
catch(G, C, A) :-
|
|
'$catch'(G,C,A).
|
|
|
|
% makes sure we have an environment.
|
|
'$true'.
|
|
|
|
|
|
% system_catch is like catch, but it avoids the overhead of a full
|
|
% meta-call by calling '$execute0' instead of $execute.
|
|
% This way it
|
|
% also avoids module preprocessing and goal_expansion
|
|
%
|
|
'$system_catch'(G, M, C, A) :-
|
|
% check current trail
|
|
'$catch'(M:G,C,A).
|
|
|
|
'$catch'(MG,_,_) :-
|
|
'$$save_by'(CP0),
|
|
'$execute'(MG),
|
|
'$$save_by'(CP1),
|
|
% remove catch
|
|
(
|
|
CP0 == CP1
|
|
->
|
|
!
|
|
;
|
|
true
|
|
).
|
|
'$catch'(_,C,A) :-
|
|
'$get_exception'(C0),
|
|
( C = C0 -> '$execute_nonstop'(A, prolog) ; throw(C0) ).
|
|
|
|
% variable throws are user-handled.
|
|
'$run_catch'(G,E) :-
|
|
var(E),
|
|
!,
|
|
call(G ).
|
|
'$run_catch'(abort,_) :-
|
|
abort.
|
|
'$run_catch'('$Error'(E),E) :-
|
|
!,
|
|
'$LoopError'(E, top ).
|
|
'$run_catch'('$LoopError'(E, Where),E) :-
|
|
!,
|
|
'$LoopError'(E, Where).
|
|
'$run_catch'('$TraceError'(E, GoalNumber, G, Module, CalledFromDebugger),E) :-
|
|
!,
|
|
'$TraceError'(E, GoalNumber, G, Module, CalledFromDebugger).
|
|
'$run_catch'(_Signal,E) :-
|
|
functor( E, N, _),
|
|
'$hidden_atom'(N), !,
|
|
throw(E).
|
|
'$run_catch'( Signal, _E) :-
|
|
call( Signal ).
|
|
|
|
|
|
|
|
%
|
|
% throw has to be *exactly* after system catch!
|
|
%
|
|
/** @pred throw(+ _Ball_) is iso
|
|
|
|
|
|
The goal `throw( _Ball_)` throws an exception. Execution is
|
|
stopped, and the exception is sent to the ancestor goals until reaching
|
|
a matching catch/3, or until reaching top-level.
|
|
|
|
*/
|
|
|
|
'$run_toplevel_hooks' :-
|
|
current_prolog_flag(break_level, 0 ),
|
|
recorded('$toplevel_hooks',H,_),
|
|
H \= fail, !,
|
|
( call(user:H) -> true ; true).
|
|
'$run_toplevel_hooks'.
|
|
|
|
'$run_at_thread_start' :-
|
|
recorded('$thread_initialization',M:D,_),
|
|
'$meta_call'(D, M),
|
|
fail.
|
|
'$run_at_thread_start'.
|
|
|
|
log_event( String, Args ) :-
|
|
format( atom( M ), String, Args),
|
|
log_event( M ).
|
|
|
|
'$prompt' :-
|
|
current_prolog_flag(break_level, BreakLevel),
|
|
(
|
|
BreakLevel == 0
|
|
->
|
|
LF = LD
|
|
;
|
|
LF = ['Break (level ', BreakLevel, ')'|LD]
|
|
),
|
|
current_prolog_flag(debug, DBON),
|
|
(
|
|
DBON = true
|
|
->
|
|
(
|
|
'$get_debugger_state'( trace,on),
|
|
(
|
|
var(LF)
|
|
->
|
|
LD = ['trace'|LP]
|
|
;
|
|
LD = [', trace '|LP]
|
|
)
|
|
;
|
|
(var(LF)
|
|
->
|
|
LD = ['debug'|LP]
|
|
;
|
|
LD = [', debug'|LP]
|
|
)
|
|
)
|
|
;
|
|
LD = LP
|
|
),
|
|
(
|
|
var(LF)
|
|
->
|
|
LP = [P]
|
|
;
|
|
LP = [' ',P]
|
|
),
|
|
yap_flag(toplevel_prompt, P),
|
|
atomic_concat(LF, PF),
|
|
prompt1(PF),
|
|
prompt(_,' | '),
|
|
'$ensure_prompting'.
|
|
|
|
|
|
/**
|
|
@}
|
|
*/
|