This repository has been archived on 2023-08-20. You can view files and clone it, but cannot push or open issues or pull requests.
yap-6.3/pl/control.yap

590 lines
14 KiB
Plaintext
Raw Normal View History

2014-10-05 23:59:34 +01:00
/*************************************************************************
* *
* 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 *
* *
*************************************************************************/
/**
* @file control.yap
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP.lan>
* @date Thu Nov 19 10:26:35 2015
*
* @brief Control Predicates
*
*
*/
2014-04-09 12:39:29 +01:00
:- 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]).
/**
2014-12-24 15:32:29 +00:00
@addtogroup YAPControl
2018-05-22 12:23:52 +01:00
@ingroup builtins
2018-06-05 11:20:39 +01:00
@{
2018-06-05 20:51:49 +01:00
2014-12-24 15:32:29 +00:00
*/
/** @pred forall(: _Cond_,: _Action_)
2018-11-25 13:27:48 +00:00
*
*
2018-10-13 08:45:40 +01:00
* For all alternative bindings of _Cond_ _Action_ can be
* proven. The example verifies that all arithmetic statements in the list
* _L_ are correct. It does not say which is wrong if one proves wrong.
2018-11-25 13:27:48 +00:00
*
2018-10-13 08:45:40 +01:00
* ~~~~~{.prolog}
* ?- forall(member(Result = Formula, [2 = 1 + 1, 4 = 2 * 2]),
* Result =:= Formula).
* ~~~~~
2018-11-25 13:27:48 +00:00
*
*
2018-10-13 08:45:40 +01:00
*/
forall(Cond, Action) :- \+((Cond, \+(Action))).
/** @pred ignore(: _Goal_)
2018-11-25 13:27:48 +00:00
*
*
2018-10-13 08:45:40 +01:00
* Calls _Goal_ as once/1, but succeeds, regardless of whether
* `Goal` succeeded or not. Defined as:
2018-11-25 13:27:48 +00:00
*
2018-10-13 08:45:40 +01:00
* ~~~~~{.prolog}
* ignore(Goal) :-
* Goal, !.
* ignore(_).
* ~~~~~
2018-11-25 13:27:48 +00:00
*
*
2018-10-13 08:45:40 +01:00
*/
ignore(Goal) :- (Goal->true;true).
2014-09-11 20:06:57 +01:00
/** @pred if(? _G_,? _H_,? _I_)
2018-11-25 13:27:48 +00:00
*
2018-10-13 08:45:40 +01:00
* Call goal _H_ once per each solution of goal _H_. If goal
* _H_ has no solutions, call goal _I_.
2018-11-25 13:27:48 +00:00
*
2018-10-13 08:45:40 +01:00
* The built-in `if/3` is similar to `->/3`, with the difference
* that it will backtrack over the test. Consider the following
* small data-base:
2018-11-25 13:27:48 +00:00
*
2018-10-13 08:45:40 +01:00
* ~~~~~{.prolog}
* a(1). b(a). c(x).
* a(2). b(b). c(y).
* ~~~~~
2018-11-25 13:27:48 +00:00
*
2018-10-13 08:45:40 +01:00
* Execution of an `if/3` query will proceed as follows:
2018-11-25 13:27:48 +00:00
*
2018-10-13 08:45:40 +01:00
* ~~~~~{.prolog}
* ?- if(a(X),b(Y),c(Z)).
2018-11-25 13:27:48 +00:00
*
2018-10-13 08:45:40 +01:00
* X = 1,
* Y = a ? ;
2018-11-25 13:27:48 +00:00
*
2018-10-13 08:45:40 +01:00
* X = 1,
* Y = b ? ;
2018-11-25 13:27:48 +00:00
*
2018-10-13 08:45:40 +01:00
* X = 2,
* Y = a ? ;
2018-11-25 13:27:48 +00:00
*
2018-10-13 08:45:40 +01:00
* X = 2,
* Y = b ? ;
2018-11-25 13:27:48 +00:00
*
2018-10-13 08:45:40 +01:00
* no
* ~~~~~
2018-11-25 13:27:48 +00:00
*
2018-10-13 08:45:40 +01:00
* The system will backtrack over the two solutions for `a/1` and the
* two solutions for `b/1`, generating four solutions.
2018-11-25 13:27:48 +00:00
*
2018-10-13 08:45:40 +01:00
* Cuts are allowed inside the first goal _G_, but they will only prune
* over _G_.
2018-11-25 13:27:48 +00:00
*
2018-10-13 08:45:40 +01:00
* If you want _G_ to be deterministic you should use if-then-else, as
* it is both more efficient and more portable.
2018-11-25 13:27:48 +00:00
*
2018-10-13 08:45:40 +01:00
*/
if(X,Y,Z) :-
2018-10-25 13:57:18 +01:00
(
'$$save_by'(CP),
'$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)
).
2018-10-13 08:45:40 +01:00
/** @pred call( Closure,...,? Ai,...) is iso
2018-11-25 13:27:48 +00:00
*
*
2018-10-13 08:45:40 +01:00
* Meta-call with extra pattern arguments, where _Closure_ is a closure
* that is converted into a goal by appending the _Ai_ additional
* arguments. YAP supports up to 10 extra arguments.
2018-11-25 13:27:48 +00:00
*
2018-10-13 08:45:40 +01:00
*/
2018-04-27 13:01:08 +01:00
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).
2014-09-11 20:06:57 +01:00
/** @pred call_cleanup(: _Goal_, : _CleanUpGoal_)
2018-11-25 13:27:48 +00:00
*
2018-10-13 08:45:40 +01:00
* This is similar to call_cleanup/1 but with an additional
* _CleanUpGoal_ which gets called after _Goal_ is finished.
2018-11-25 13:27:48 +00:00
*
2018-10-13 08:45:40 +01:00
*/
call_cleanup(Goal, Cleanup) :-
2017-09-03 00:15:54 +01:00
'$gated_call'( false , Goal,_Catcher, Cleanup) .
call_cleanup(Goal, Catcher, Cleanup) :-
2017-09-03 00:15:54 +01:00
'$gated_call'( false , Goal, Catcher, Cleanup) .
/** @pred setup_call_cleanup(: _Setup_,: _Goal_, : _CleanUpGoal_)
2014-09-11 20:06:57 +01:00
2017-03-23 12:26:43 +00:00
Calls `(Setup, Goal)`. For each sucessful execution of _Setup_,
calling _Goal_, the cleanup handler _Cleanup_ is guaranteed to be
called exactly once. This will happen after _Goal_ completes, either
through failure, deterministic success, commit, or an exception.
_Setup_ will contain the goals that need to be protected from
asynchronous interrupts such as the ones received from
`call_with_time_limit/2` or thread_signal/2. In most uses, _Setup_
will perform temporary side-effects required by _Goal_ that are
finally undone by _Cleanup_.
2014-09-11 20:06:57 +01:00
*/
setup_call_cleanup(Setup,Goal, Cleanup) :-
2016-03-30 01:25:43 +01:00
setup_call_catcher_cleanup(Setup, Goal, _Catcher, Cleanup).
2017-07-30 21:53:07 +01:00
setup_call_catcher_cleanup(Setup, Goal, Catcher, Cleanup) :-
'$setup_call_catcher_cleanup'(Setup),
call_cleanup(Goal, Catcher, Cleanup).
2018-04-27 13:01:08 +01:00
/** @pred call_with_args(+ Name,...,? Ai,...)
2014-09-15 19:10:49 +01:00
Meta-call where _Name_ is the name of the procedure to be called and
the _Ai_ are the arguments. The number of arguments varies between 0
and 10. New code should use `call/N` for better portability.
If _Name_ is a complex term, then call_with_args/n behaves as
call/n:
~~~~~{.prolog}
call(p(X1,...,Xm), Y1,...,Yn) :- p(X1,...,Xm,Y1,...,Yn).
~~~~~
2014-09-15 19:10:49 +01:00
*/
%%% 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
/** @pred grow_heap(+ _Size_)
2014-09-11 20:06:57 +01:00
Increase heap size _Size_ kilobytes.
2014-09-11 20:06:57 +01:00
*/
grow_heap(X) :- '$grow_heap'(X).
/** @pred grow_stack(+ _Size_)
2014-09-11 20:06:57 +01:00
Increase stack size _Size_ kilobytes
*/
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).
/** @pred garbage_collect
2014-09-11 20:06:57 +01:00
The goal `garbage_collect` forces a garbage collection.
2014-09-11 20:06:57 +01:00
*/
garbage_collect :-
'$gc'.
2014-10-05 23:59:34 +01:00
/** @pred gc
2014-09-11 20:06:57 +01:00
The goal `gc` enables garbage collection. The same as
`yap_flag(gc,on)`.
2014-09-11 20:06:57 +01:00
*/
gc :-
yap_flag(gc,on).
/** @pred nogc
2014-09-11 20:06:57 +01:00
The goal `nogc` disables garbage collection. The same as
`yap_flag(gc,off)`.
2014-09-11 20:06:57 +01:00
*/
nogc :-
yap_flag(gc,off).
2014-10-05 23:59:34 +01:00
/** @pred garbage_collect_atoms
2014-09-11 20:06:57 +01:00
The goal `garbage_collect` forces a garbage collection of the atoms
in the data-base. Currently, only atoms are recovered.
2014-09-11 20:06:57 +01:00
*/
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.
/** @pred prolog_initialization( _G_)
2014-09-11 20:06:57 +01:00
Add a goal to be executed on system initialization. This is compatible
with SICStus Prolog's initialization/1.
2014-09-11 20:06:57 +01:00
*/
prolog_initialization(G) :- var(G), !,
'$do_error'(instantiation_error,initialization(G)).
prolog_initialization(T) :- callable(T), !,
'$assert_init'(T).
prolog_initialization(T) :-
2014-10-20 09:20:56 +01:00
'$do_error'(type_error(callable,T),initialization(T)).
'$assert_init'(T) :- recordz('$startup_goal',T,_), fail.
'$assert_init'(_).
2014-09-11 20:06:57 +01:00
/** @pred version
Write YAP's boot message.
2014-09-11 20:06:57 +01:00
*/
version :- '$version'.
2014-09-11 20:06:57 +01:00
/** @pred version(- _Message_)
Add a message to be written when yap boots or after aborting. It is not
possible to remove messages.
2014-09-11 20:06:57 +01:00
*/
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'(_).
2019-01-09 09:32:09 +00:00
query_to_answer(G, V, Status, LGs) :-
gated_call(true,
G,
Status,
true),
'$delayed_goals'(G, V, NV, LVGs, _DCP),
lists:append(NV, LVGs, LGs).
%% @}
%% @addtogroup Global_Variables
2018-10-13 08:45:40 +01:00
%% @{
/** @pred nb_getval(+ _Name_,- _Value_)
2018-11-25 13:27:48 +00:00
*
*
2018-10-13 08:45:40 +01:00
* The nb_getval/2 predicate is a synonym for b_getval/2, introduced for
* compatibility and symmetry. As most scenarios will use a particular
* global variable either using non-backtrackable or backtrackable
* assignment, using nb_getval/2 can be used to document that the
* variable is used non-backtrackable.
2018-11-25 13:27:48 +00:00
*
2018-10-13 08:45:40 +01:00
*/
nb_getval(GlobalVariable, Val) :-
2018-01-18 14:47:27 +00:00
'__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))
).
/** @pred b_getval(+ _Name_, - _Value_)
2018-11-25 13:27:48 +00:00
*
*
2018-10-13 08:45:40 +01:00
* Get the value associated with the global variable _Name_ and unify
* it with _Value_. Note that this unification may further
* instantiate the value of the global variable. If this is undesirable
* the normal precautions (double negation or copy_term/2) must be
* taken. The b_getval/2 predicate generates errors if _Name_ is not
* an atom or the requested variable does not exist.
2018-11-25 13:27:48 +00:00
*
2018-10-13 08:45:40 +01:00
* Notice that for compatibility with other systems _Name_ <em>must</em> be already associated with a term: otherwise the system will generate an error.
2018-11-25 13:27:48 +00:00
*
*
2018-10-13 08:45:40 +01:00
*/
b_getval(GlobalVariable, Val) :-
2018-01-18 14:47:27 +00:00
'__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))
).
%% @}
%% @addtogroup YAPControl
2018-10-13 08:45:40 +01:00
%% @{
/* This is the break predicate,
it saves the importante data about current streams and
debugger state */
2018-11-23 00:01:55 +00:00
'$debug_state'(state(Trace, Debug, State, SPY_GN, GList)) :-
2014-03-06 02:09:48 +00:00
'$init_debugger',
nb_getval('$trace',Trace),
2017-10-27 13:50:40 +01:00
nb_getval('$debug_state',State),
2015-06-19 01:12:05 +01:00
current_prolog_flag(debug, Debug),
2014-03-06 02:09:48 +00:00
nb_getval('$spy_gn',SPY_GN),
2018-11-23 00:01:55 +00:00
b_getval('$spy_glist',GList).
2014-03-06 02:09:48 +00:00
2017-10-27 13:50:40 +01:00
'$debug_stop' :-
nb_setval('$debug_state', state(creep,0,stop)),
2014-03-06 02:09:48 +00:00
b_setval('$trace',off),
2017-10-27 13:50:40 +01:00
set_prolog_flag(debug, false),
2014-03-06 02:09:48 +00:00
b_setval('$spy_glist',[]),
2018-11-03 10:49:35 +00:00
'$disable_debugging'.
2014-03-06 02:09:48 +00:00
2018-11-25 13:27:48 +00:00
'$debug_restore'(state(Trace, Debug, State, SPY_GN, GList)) :-
2014-03-06 02:09:48 +00:00
b_setval('$spy_glist',GList),
b_setval('$spy_gn',SPY_GN),
2015-06-19 01:12:05 +01:00
set_prolog_flag(debug, Debug),
2018-11-23 00:01:55 +00:00
nb_setval('$debug_state',State),
2018-11-03 10:49:35 +00:00
b_setval('$trace',Trace),
'$enable_debugging'.
2014-03-06 02:09:48 +00:00
/** @pred break
2014-09-11 20:06:57 +01:00
Suspends the execution of the current goal and creates a new execution
level similar to the top level, displaying the following message:
~~~~~{.prolog}
[ Break (level <number>) ]
~~~~~
telling the depth of the break level just entered. To return to the
previous level just type the end-of-file character or call the
end_of_file predicate. This predicate is especially useful during
debugging.
2014-09-11 20:06:57 +01:00
*/
break :-
2017-10-27 13:50:40 +01:00
'$debug_state'(DState),
2018-11-24 10:35:19 +00:00
'$debug_stop',
2018-11-23 00:01:55 +00:00
'$break'( true ),
2018-11-03 10:49:35 +00:00
current_output(OutStream), current_input(InpStream),
current_prolog_flag(break_level, BL ),
2017-10-27 13:50:40 +01:00
NBL is BL+1,
2018-11-03 10:49:35 +00:00
set_prolog_flag(break_level, NBL ),
format(user_error, '% Break (level ~w)~n', [NBL]),
2018-11-25 13:27:48 +00:00
live,
2018-11-03 10:49:35 +00:00
!,
set_value('$live','$true'),
2017-10-27 13:50:40 +01:00
'$debug_restore'(DState),
2018-11-03 10:49:35 +00:00
set_input(InpStream),
set_output(OutStream),
set_prolog_flag(break_level, BL ),
'$break'( false ).
2018-05-22 12:23:52 +01:00
/**
2018-04-27 13:01:08 +01:00
* @pred at_halt( G )
*
* Hook predicate: _G_ must be called on exit.
2018-05-22 12:23:52 +01:00
*
* @param _G_: the hook
*
2018-04-27 13:01:08 +01:00
* @return succeeds with side-effect.
*/at_halt(G) :-
recorda('$halt', G, _),
fail.
at_halt(_).
/** @pred halt is iso
2014-09-11 20:06:57 +01:00
Halts Prolog, and exits to the calling application. In YAP,
halt/0 returns the exit code `0`.
*/
halt :-
print_message(informational, halt),
fail.
halt :-
halt(0).
2014-09-11 20:06:57 +01:00
/** @pred halt(+ _I_) is iso
2016-04-14 12:00:09 +01:00
Halts Prolog, and exits to 1the calling application returning the code
2014-09-11 20:06:57 +01:00
given by the integer _I_.
*/
halt(_) :-
recorded('$halt', G, _),
catch(once(G), Error, user:'$Error'(Error)),
fail.
halt(X) :-
'$sync_mmapped_arrays',
set_value('$live','$false'),
'$halt'(X).
2018-05-22 12:23:52 +01:00
/**
2018-04-27 13:01:08 +01:00
* @pred prolog_current_frame(-Env)
*
* reports a reference to the last execution environment _Env_.
* YAP creates an enviroment when a clause contains several sub-goals.
* Facts and simple recursion do not need an environment,
2018-05-22 12:23:52 +01:00
*
* @param Env
*
* @return
2018-04-27 13:01:08 +01:00
*/prolog_current_frame(Env) :-
Env is '$env'.
'$run_atom_goal'(GA) :-
'$current_module'(Module),
2011-02-12 18:42:44 +00:00
atom_to_term(GA, G, _),
2018-11-03 10:49:35 +00:00
catch(once(Module:G), 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).
2014-09-11 20:06:57 +01:00
/**
@}
*/