868 lines
28 KiB
Prolog
868 lines
28 KiB
Prolog
/*************************************************************************
|
|
* *
|
|
* YAP Prolog *
|
|
* *
|
|
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
|
* *
|
|
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
|
* *
|
|
**************************************************************************
|
|
* *
|
|
* File: utils.yap *
|
|
* Last rev: 8/2/88 *
|
|
* mods: *
|
|
* comments: Some utility predicates available in yap *
|
|
* *
|
|
*************************************************************************/
|
|
|
|
once(G) :- '$execute'(G), !.
|
|
|
|
if(X,Y,Z) :-
|
|
CP is '$last_choice_pt',
|
|
'$execute'(X),
|
|
'$clean_ifcp'(CP),
|
|
'$execute'(Y).
|
|
if(X,Y,Z) :-
|
|
'$execute'(Z).
|
|
|
|
|
|
call_with_args(V) :- var(V), !,
|
|
throw(error(instantiation_error,call_with_args(V))).
|
|
call_with_args(M:A) :- !,
|
|
( '$current_module'(M) ->
|
|
call_with_args(A)
|
|
;
|
|
'$current_module'(Old,M),
|
|
( call_with_args(A); '$current_module'(_,Old), fail ),
|
|
( '$current_module'(_,Old); '$current_module'(_,M), fail)
|
|
).
|
|
call_with_args(A) :- atom(A), !,
|
|
'$call_with_args'(A).
|
|
call_with_args(A) :-
|
|
throw(error(type_error(atom,A),call_with_args(A))).
|
|
|
|
|
|
call_with_args(V,A1) :- var(V), !,
|
|
throw(error(instantiation_error,call_with_args(V,A1))).
|
|
call_with_args(M:A,A1) :- !,
|
|
( '$current_module'(M) ->
|
|
call_with_args(A,A1)
|
|
;
|
|
'$current_module'(Old,M),
|
|
( call_with_args(A,A1); '$current_module'(_,Old), fail ),
|
|
( '$current_module'(_,Old); '$current_module'(_,M), fail)
|
|
).
|
|
call_with_args(A,A1) :- atom(A), !,
|
|
'$call_with_args'(A,A1).
|
|
call_with_args(A,A1) :-
|
|
throw(error(type_error(atom,A),call_with_args(A,A1))).
|
|
|
|
call_with_args(V,A1,A2) :- var(V), !,
|
|
throw(error(instantiation_error,call_with_args(V,A1,A2))).
|
|
call_with_args(M:A,A1,A2) :- !,
|
|
( '$current_module'(M) ->
|
|
call_with_args(A,A1,A2)
|
|
;
|
|
'$current_module'(Old,M),
|
|
( call_with_args(A,A1,A2); '$current_module'(_,Old), fail ),
|
|
( '$current_module'(_,Old); '$current_module'(_,M), fail)
|
|
).
|
|
call_with_args(A,A1,A2) :- atom(A), !,
|
|
'$call_with_args'(A,A1,A2).
|
|
call_with_args(A,A1,A2) :-
|
|
throw(error(type_error(atom,A),call_with_args(A,A1,A2))).
|
|
|
|
call_with_args(V,A1,A2,A3) :- var(V), !,
|
|
throw(error(instantiation_error,call_with_args(V,A1,A2,A3))).
|
|
call_with_args(M:A,A1,A2,A3) :- !,
|
|
( '$current_module'(M) ->
|
|
call_with_args(A,A1,A2,A3)
|
|
;
|
|
'$current_module'(Old,M),
|
|
( call_with_args(A,A1,A2,A3); '$current_module'(_,Old), fail ),
|
|
( '$current_module'(_,Old); '$current_module'(_,M), fail)
|
|
).
|
|
call_with_args(A,A1,A2,A3) :- atom(A), !,
|
|
'$call_with_args'(A,A1,A2,A3).
|
|
call_with_args(A,A1,A2,A3) :-
|
|
throw(error(type_error(atom,A),call_with_args(A,A1,A2,A3))).
|
|
|
|
call_with_args(V,A1,A2,A3,A4) :- var(V), !,
|
|
throw(error(instantiation_error,call_with_args(V,A1,A2,A3,A4))).
|
|
call_with_args(M:A,A1,A2,A3,A4) :- !,
|
|
( '$current_module'(M) ->
|
|
call_with_args(A,A1,A2,A3,A4)
|
|
;
|
|
'$current_module'(Old,M),
|
|
( call_with_args(A,A1,A2,A3,A4); '$current_module'(_,Old), fail ),
|
|
( '$current_module'(_,Old); '$current_module'(_,M), fail)
|
|
).
|
|
call_with_args(A,A1,A2,A3,A4) :- atom(A), !,
|
|
'$call_with_args'(A,A1,A2,A3,A4).
|
|
call_with_args(A,A1,A2,A3,A4) :-
|
|
throw(error(type_error(atom,A),call_with_args(A,A1,A2,A3,A4))).
|
|
|
|
call_with_args(V,A1,A2,A3,A4,A5) :- var(V), !,
|
|
throw(error(instantiation_error,call_with_args(V,A1,A2,A3,A4,A5))).
|
|
call_with_args(M:A,A1,A2,A3,A4,A5) :- !,
|
|
( '$current_module'(M) ->
|
|
call_with_args(A,A1,A2,A3,A4,A5)
|
|
;
|
|
'$current_module'(Old,M),
|
|
( call_with_args(A,A1,A2,A3,A4,A5); '$current_module'(_,Old), fail ),
|
|
( '$current_module'(_,Old); '$current_module'(_,M), fail)
|
|
).
|
|
call_with_args(A,A1,A2,A3,A4,A5) :- atom(A), !,
|
|
'$call_with_args'(A,A1,A2,A3,A4,A5).
|
|
call_with_args(A,A1,A2,A3,A4,A5) :-
|
|
throw(error(type_error(atom,A),call_with_args(A,A1,A2,A3,A4,A5))).
|
|
|
|
call_with_args(V,A1,A2,A3,A4,A5,A6) :- var(V), !,
|
|
throw(error(instantiation_error,call_with_args(V,A1,A2,A3,A4,A5,A6))).
|
|
call_with_args(M:A,A1,A2,A3,A4,A5,A6) :- !,
|
|
( '$current_module'(M) ->
|
|
call_with_args(A,A1,A2,A3,A4,A5,A6)
|
|
;
|
|
'$current_module'(Old,M),
|
|
( call_with_args(A,A1,A2,A3,A4,A5,A6); '$current_module'(_,Old), fail ),
|
|
( '$current_module'(_,Old); '$current_module'(_,M), fail)
|
|
).
|
|
call_with_args(A,A1,A2,A3,A4,A5,A6) :- atom(A), !,
|
|
'$call_with_args'(A,A1,A2,A3,A4,A5,A6).
|
|
call_with_args(A,A1,A2,A3,A4,A5,A6) :-
|
|
throw(error(type_error(atom,A),call_with_args(A,A1,A2,A3,A4,A5,A6))).
|
|
|
|
call_with_args(V,A1,A2,A3,A4,A5,A6,A7) :- var(V), !,
|
|
throw(error(instantiation_error,call_with_args(V,A1,A2,A3,A4,A5,A6,A7))).
|
|
call_with_args(M:A,A1,A2,A3,A4,A5,A6,A7) :- !,
|
|
( '$current_module'(M) ->
|
|
call_with_args(A,A1,A2,A3,A4,A5,A6,A7)
|
|
;
|
|
'$current_module'(Old,M),
|
|
( call_with_args(A,A1,A2,A3,A4,A5,A6,A7); '$current_module'(_,Old), fail ),
|
|
( '$current_module'(_,Old); '$current_module'(_,M), fail)
|
|
).
|
|
call_with_args(A,A1,A2,A3,A4,A5,A6,A7) :- atom(A), !,
|
|
'$call_with_args'(A,A1,A2,A3,A4,A5,A6,A7).
|
|
call_with_args(A,A1,A2,A3,A4,A5,A6,A7) :-
|
|
throw(error(type_error(atom,A),call_with_args(A,A1,A2,A3,A4,A5,A6,A7))).
|
|
|
|
call_with_args(V,A1,A2,A3,A4,A5,A6,A7,A8) :- var(V), !,
|
|
throw(error(instantiation_error,call_with_args(V,A1,A2,A3,A4,A5,A6,A7,A8))).
|
|
call_with_args(M:A,A1,A2,A3,A4,A5,A6,A7,A8) :- !,
|
|
( '$current_module'(M) ->
|
|
call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8)
|
|
;
|
|
'$current_module'(Old,M),
|
|
( call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8); '$current_module'(_,Old), fail ),
|
|
( '$current_module'(_,Old); '$current_module'(_,M), fail)
|
|
).
|
|
call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8) :- atom(A), !,
|
|
'$call_with_args'(A,A1,A2,A3,A4,A5,A6,A7,A8).
|
|
call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8) :-
|
|
throw(error(type_error(atom,A),call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8))).
|
|
|
|
call_with_args(V,A1,A2,A3,A4,A5,A6,A7,A8,A9) :- var(V), !,
|
|
throw(error(instantiation_error,call_with_args(V,A1,A2,A3,A4,A5,A6,A7,A8,A9))).
|
|
call_with_args(M:A,A1,A2,A3,A4,A5,A6,A7,A8,A9) :- !,
|
|
( '$current_module'(M) ->
|
|
call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8,A9)
|
|
;
|
|
'$current_module'(Old,M),
|
|
( call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8,A9); '$current_module'(_,Old), fail ),
|
|
( '$current_module'(_,Old); '$current_module'(_,M), fail)
|
|
).
|
|
call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8,A9) :- atom(A), !,
|
|
'$call_with_args'(A,A1,A2,A3,A4,A5,A6,A7,A8,A9).
|
|
call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8,A9) :-
|
|
throw(error(type_error(atom,A),call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8,A9))).
|
|
|
|
|
|
call_with_args(V,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10) :- var(V), !,
|
|
throw(error(instantiation_error,call_with_args(V,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10))).
|
|
call_with_args(M:A,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10) :- !,
|
|
( '$current_module'(M) ->
|
|
call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10)
|
|
;
|
|
'$current_module'(Old,M),
|
|
( call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10); '$current_module'(_,Old), fail ),
|
|
( '$current_module'(_,Old); '$current_module'(_,M), fail)
|
|
).
|
|
call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10) :- atom(A), !,
|
|
'$call_with_args'(A,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10).
|
|
call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10) :-
|
|
throw(error(type_error(atom,A),call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10))).
|
|
|
|
|
|
op(P,T,V) :- var(P), !,
|
|
throw(error(instantiation_error,op(P,T,V))).
|
|
op(P,T,V) :- \+integer(P), !,
|
|
throw(error(type_error(integer,P),op(P,T,V))).
|
|
op(P,T,V) :- (P < 0 ; P > 1200), !,
|
|
throw(error(domain_error(operator_priority,P),op(P,T,V))).
|
|
op(P,T,V) :- var(T), !,
|
|
throw(error(instantiation_error,op(P,T,V))).
|
|
op(P,T,V) :- \+atom(T), !,
|
|
throw(error(type_error(atom,T),op(P,T,V))).
|
|
op(P,T,V) :- var(V), !,
|
|
throw(error(instantiation_error,op(P,T,V))).
|
|
op(P,T,V) :-
|
|
\+ atom(V), \+ '$check_list_of_operators'(V, op(P,T,V)),
|
|
throw(error(type_error(list,V),op(P,T,V))).
|
|
op(P,T,V) :- '$op2'(P,T,V).
|
|
|
|
'$check_list_of_operators'(V, T) :- var(V), !,
|
|
throw(error(instantiation_error,T)).
|
|
'$check_list_of_operators'([], _).
|
|
'$check_list_of_operators'([H|L], T) :-
|
|
'$check_if_operator'(H,T),
|
|
'$check_list_of_operators'(L, T).
|
|
|
|
'$check_if_operator'(H,T) :- var(H), !,
|
|
throw(error(instantiation_error,T)).
|
|
'$check_if_operator'(H,_) :- atom(H), !.
|
|
'$check_if_operator'(H,T) :-
|
|
throw(error(type_error(atom,H),T)).
|
|
|
|
'$op2'(_,_,[]) :- !.
|
|
'$op2'(P,T,[A|L]) :- !, '$op'(P,T,A), '$op2'(P,T,L).
|
|
'$op2'(P,T,A) :- atom(A), '$op'(P,T,A).
|
|
|
|
'$op'(P,T,',') :- !,
|
|
throw(error(permission_error(modify,operator,','),op(P,T,','))).
|
|
'$op'(P,T,A) :- '$opdec'(P,T,A).
|
|
|
|
%%% Operating System utilities
|
|
|
|
cd(A) :- atom(A), !, atom_codes(A,S), '$cd'(S).
|
|
cd(S) :- '$cd'(S).
|
|
|
|
getcwd(D) :- '$getcwd'(SD), atom_codes(D, SD).
|
|
|
|
system(A) :- atom(A), !, atom_codes(A,S), '$system'(S).
|
|
system(S) :- '$system'(S).
|
|
|
|
shell(A) :- atom(A), !, atom_codes(A,S), '$shell'(S).
|
|
shell(S) :- '$shell'(S).
|
|
|
|
rename(Old,New) :- atom(Old), atom(New), !,
|
|
name(Old,SOld), name(New,SNew),
|
|
'$rename'(SOld,SNew).
|
|
|
|
unix(V) :- var(V), !,
|
|
throw(error(instantiation_error,unix(V))).
|
|
unix(argv(L)) :- (var(L) ; atom(L)), !, '$argv'(L).
|
|
unix(argv(V)) :-
|
|
throw(error(type_error(atomic,V),unix(argv(V)))).
|
|
unix(cd) :- cd('~').
|
|
unix(cd(V)) :- var(V), !,
|
|
throw(error(instantiation_error,unix(cd(V)))).
|
|
unix(cd(A)) :- atomic(A), !, cd(A).
|
|
unix(cd(V)) :-
|
|
throw(error(type_error(atomic,V),unix(cd(V)))).
|
|
unix(environ(X,Y)) :- do_environ(X,Y).
|
|
unix(getcwd(X)) :- getcwd(X).
|
|
unix(shell(V)) :- var(V), !,
|
|
throw(error(instantiation_error,unix(shell(V)))).
|
|
unix(shell(A)) :- atomic(A), !, shell(A).
|
|
unix(shell(V)) :-
|
|
throw(error(type_error(atomic,V),unix(shell(V)))).
|
|
unix(system(V)) :- var(V), !,
|
|
throw(error(instantiation_error,unix(system(V)))).
|
|
unix(system(A)) :- atomic(A), !, system(A).
|
|
unix(system(V)) :-
|
|
throw(error(type_error(atomic,V),unix(system(V)))).
|
|
unix(shell) :- sh.
|
|
unix(putenv(X,Y)) :- '$putenv'(X,Y).
|
|
|
|
putenv(Na,Val) :-
|
|
'$putenv'(Na,Val).
|
|
|
|
getenv(Na,Val) :-
|
|
'$getenv'(Na,Val).
|
|
|
|
alarm(_, _, _) :-
|
|
recorded('$alarm_handler',_, Ref), erase(Ref), fail.
|
|
alarm(Interval, Goal, Left) :-
|
|
'$current_module'(M),
|
|
'$recordz'('$alarm_handler',M:Goal,_),
|
|
'$alarm'(Interval, Left).
|
|
|
|
%%% Saving and restoring a computation
|
|
|
|
save(A) :- var(A), !,
|
|
throw(error(instantiation_error,save(A))).
|
|
save(A) :- atom(A), !, name(A,S), '$save'(S).
|
|
save(S) :- '$save'(S).
|
|
|
|
save(A,_) :- var(A), !,
|
|
throw(error(instantiation_error,save(A))).
|
|
save(A,OUT) :- atom(A), !, name(A,S), '$save'(S,OUT).
|
|
save(S,OUT) :- '$save'(S,OUT).
|
|
|
|
save_program(A) :- var(A), !,
|
|
throw(error(instantiation_error,save_program(A))).
|
|
save_program(A) :- atom(A), !, name(A,S), '$save_program'(S).
|
|
save_program(S) :- '$save_program'(S).
|
|
|
|
save_program(A, G) :- var(A), !,
|
|
throw(error(instantiation_error,save_program(A,G))).
|
|
save_program(A, G) :- var(G), !,
|
|
throw(error(instantiation_error,save_program(A,G))).
|
|
save_program(A, G) :- \+ callable(G), !,
|
|
throw(error(type_error(callable,G),save_program(A,G))).
|
|
save_program(A, G) :-
|
|
( atom(A) -> name(A,S) ; A = S),
|
|
'$recorda'('$restore_goal',G,R),
|
|
'$save_program'(S),
|
|
erase(R),
|
|
fail.
|
|
save_program(_,_).
|
|
|
|
restore(A) :- var(A), !,
|
|
throw(error(instantiation_error,restore(A))).
|
|
restore(A) :- atom(A), !, name(A,S), '$restore'(S).
|
|
restore(S) :- '$restore'(S).
|
|
|
|
%%% Data base predicates -> the interface to the external world
|
|
|
|
recorda(Key,Term,Ref) :- '$recorda'(Key,Term,Ref).
|
|
recordz(Key,Term,Ref) :- '$recordz'(Key,Term,Ref).
|
|
|
|
recordaifnot(Key,Term,Ref) :- '$recordaifnot'(Key,Term,Ref).
|
|
recordzifnot(Key,Term,Ref) :- '$recordzifnot'(Key,Term,Ref).
|
|
|
|
%%% Atoms with value
|
|
|
|
get_value(X,Y) :- '$get_value'(X,Y).
|
|
set_value(X,Y) :- '$set_value'(X,Y).
|
|
|
|
%%% current ....
|
|
|
|
current_atom(A) :- % check
|
|
atom(A), !.
|
|
current_atom(A) :- % generate
|
|
'$current_atom'(A).
|
|
|
|
current_predicate(A,T) :-
|
|
var(T), !,
|
|
'$current_predicate2'(A,T).
|
|
current_predicate(A,M:T) :- % module specified
|
|
atom(M), !,
|
|
( '$current_module'(M) ->
|
|
current_predicate(A,T)
|
|
;
|
|
'$mod_switch'(M,current_predicate(A,T))
|
|
).
|
|
current_predicate(A,M:T) :- % module specified
|
|
var(M), !,
|
|
current_module(M),
|
|
'$current_predicate2'(A,T).
|
|
current_predicate(A,T) :-
|
|
'$current_predicate'(A,T).
|
|
|
|
'$current_predicate2'(A,T) :- % only for the predicate
|
|
atom(A), !, '$pred_defined_for'(A,T),
|
|
'$pred_exists'(T).
|
|
'$current_predicate2'(A,T) :- % generate them all
|
|
'$current_predicate'(A,T),
|
|
'$pred_exists'(T).
|
|
|
|
'$system_predicate'(Pred) :-
|
|
'$flags'(Pred,Flags,_),
|
|
Flags /\ 8'40000 =\= 0.
|
|
|
|
system_predicate(P) :- '$system_predicate'(P).
|
|
|
|
system_predicate(A,P) :- % check
|
|
nonvar(P), !,
|
|
'$system_predicate'(P),
|
|
functor(P,A,_).
|
|
|
|
system_predicate(A,P) :- % generate
|
|
'$current_predicate2'(A,P),
|
|
'$system_predicate'(P).
|
|
|
|
%%% User interface for statistics
|
|
|
|
statistics :-
|
|
T is cputime,
|
|
'$statistics_heap_info'(HpSpa, HpInUse),
|
|
write(user_error,'Heap space : '), write(user_error,HpSpa), nl(user_error),
|
|
tab(user_error,8), write(user_error,'Heap in use: '), write(user_error,HpInUse),
|
|
'$statistics_heap_max'(HpMax),
|
|
write(user_error,', max. used: '), write(user_error,HpMax), nl(user_error),
|
|
'$statistics_trail_info'(TrlSpa, TrlInUse),
|
|
write(user_error,'Trail space : '), write(user_error,TrlSpa), nl(user_error),
|
|
tab(user_error,8), write(user_error,'Trail in use: '), write(user_error,TrlInUse),
|
|
'$statistics_trail_max'(TrlMax),
|
|
( TrlMax \= TrlSpa -> write(user_error,', max. used: '), write(user_error,TrlMax) ;
|
|
write(user_error,', maximum used ') ), nl(user_error),
|
|
'$statistics_stacks_info'(StkSpa, GlobInU, LocInU),
|
|
write(user_error,'Stack space : '), write(user_error,StkSpa), nl(user_error),
|
|
tab(user_error,8), write(user_error,'Global in use: '), write(user_error,GlobInU),
|
|
'$statistics_global_max'(GlobMax),
|
|
( GlobMax \= StkSpa ->
|
|
write(user_error,', max. used: '), write(user_error,GlobMax) ;
|
|
true ),
|
|
nl(user_error),
|
|
tab(user_error,8), write(user_error,'Local in use: '), write(user_error,LocInU),
|
|
'$statistics_local_max'(LocMax),
|
|
( LocMax \= StkSpa -> write(user_error,', max. used: '), write(user_error,LocMax) ;
|
|
true ), nl(user_error),
|
|
( GlobMax = StkSpa -> tab(user_error,8),
|
|
write(user_error,'Stack space entirely used'), nl(user_error) ;
|
|
true ),
|
|
nl(user_error),
|
|
nl(user_error),
|
|
'$inform_heap_overflows'(NOfHO,TotHOTime),
|
|
write(user_error,TotHOTime), write(user_error,' msec. for '),
|
|
write(user_error,
|
|
NOfHO),
|
|
write(user_error,' heap overflows.'), nl(user_error),
|
|
'$inform_stack_overflows'(NOfSO,TotSOTime),
|
|
write(user_error,TotSOTime), write(user_error,' msec. for '),
|
|
write(user_error,NOfSO),
|
|
write(user_error,' stack overflows.'), nl(user_error),
|
|
'$inform_trail_overflows'(NOfTO,TotTOTime),
|
|
write(user_error,TotTOTime), write(user_error,' msec. for '),
|
|
write(user_error,NOfTO),
|
|
write(user_error,' trail overflows.'), nl(user_error),
|
|
'$inform_gc'(NOfGC,TotGCTime,TotGCSize),
|
|
write(user_error,TotGCTime), write(user_error,' msec. for '),
|
|
write(user_error,NOfGC),
|
|
write(user_error,' garbage collections which collected '),
|
|
write(user_error,TotGCSize),write(user_error,' bytes.'), nl(user_error),
|
|
write(user_error,'Runtime : '), write(user_error,T),
|
|
'$set_value'('$last_runtime',T),
|
|
write(user_error,' sec.'), nl(user_error).
|
|
|
|
statistics(runtime,[T,L]) :-
|
|
'$runtime'(T,L).
|
|
statistics(cputime,[T,L]) :-
|
|
'$cputime'(T,L).
|
|
statistics(walltime,[T,L]) :-
|
|
'$walltime'(T,L).
|
|
%statistics(core,[_]).
|
|
%statistics(memory,[_]).
|
|
statistics(heap,[Hp,HpF]) :-
|
|
'$statistics_heap_info'(HpM, Hp),
|
|
HpF is HpM-Hp.
|
|
statistics(program,Info) :-
|
|
statistics(heap,Info).
|
|
statistics(global_stack,[GlobInU,GlobFree]) :-
|
|
'$statistics_stacks_info'(StkSpa, GlobInU, LocInU),
|
|
GlobFree is StkSpa-GlobInU-LocInU.
|
|
statistics(local_stack,[LocInU,LocFree]) :-
|
|
'$statistics_stacks_info'(StkSpa, GlobInU, LocInU),
|
|
LocFree is StkSpa-GlobInU-LocInU.
|
|
statistics(trail,[TrlInUse,TrlFree]) :-
|
|
'$statistics_trail_info'(TrlSpa, TrlInUse),
|
|
TrlFree is TrlSpa-TrlInUse.
|
|
statistics(garbage_collection,[NOfGC,TotGCSize,TotGCTime]) :-
|
|
'$inform_gc'(NOfGC,TotGCTime,TotGCSize).
|
|
statistics(stack_shifts,[NOfHO,NOfSO,NOfTO]) :-
|
|
'$inform_heap_overflows'(NOfHO,_),
|
|
'$inform_stack_overflows'(NOfSO,_),
|
|
'$inform_trail_overflows'(NOfTO,_).
|
|
|
|
|
|
%%% The unknown predicate,
|
|
% informs about what the user wants to be done when
|
|
% there are no clauses for a certain predicate */
|
|
|
|
|
|
% query mode
|
|
unknown(V0,V) :- var(V), !,
|
|
'$ask_unknown_flag'(V),
|
|
V = V0.
|
|
% handle modules.
|
|
unknown(V0,Mod:Handler) :-
|
|
( '$current_module'(Mod) ->
|
|
unknown(V0,Handler)
|
|
;
|
|
'$mod_switch'(Mod,unknown(V0,Handler))
|
|
).
|
|
% check if we have one we like.
|
|
unknown(_,New) :-
|
|
'$valid_unknown_handler'(New), fail.
|
|
% clean up previous unknown predicate handlers
|
|
unknown(Old,New) :-
|
|
'$recorded'('$unknown','$unknown'(_,MyOld),Ref), !,
|
|
erase(Ref),
|
|
'$cleanup_unknown_handler'(MyOld,Old),
|
|
'$new_unknown'(New).
|
|
% store the new one.
|
|
unknown(fail,New) :-
|
|
'$new_unknown'(New).
|
|
|
|
'$valid_unknown_handler'(V) :-
|
|
var(V), !,
|
|
throw(error(instantiation_error,yap_flag(unknown,V))).
|
|
'$valid_unknown_handler'(fail) :- !.
|
|
'$valid_unknown_handler'(error) :- !.
|
|
'$valid_unknown_handler'(warning) :- !.
|
|
'$valid_unknown_handler'(S) :-
|
|
functor(S,_,1),
|
|
arg(1,S,A),
|
|
var(A),
|
|
\+ '$undefined'(S),
|
|
!.
|
|
'$valid_unknown_handler'(S) :-
|
|
throw(error(domain_error(flag_value,unknown+S),yap_flag(unknown,S))).
|
|
|
|
'$ask_unknown_flag'(Old) :-
|
|
'$recorded'('$unknown','$unkonwn'(_,MyOld),_), !,
|
|
'$cleanup_unknwon_handler'(MyOld,Old).
|
|
'$ask_unknown_flag'(fail).
|
|
|
|
'$cleanup_unknown_handler'('$unknown_error'(_),error) :- !.
|
|
'$cleanup_unknown_handler'('$unknown_warning'(_),warning) :- !.
|
|
'$cleanup_unknown_handler'(Handler, Handler).
|
|
|
|
'$new_unknown'(fail) :- !.
|
|
'$new_unknown'(error) :- !,
|
|
'$recorda'('$unknown','$unknown'(P,'$unknown_error'(P)),_).
|
|
'$new_unknown'(warning) :- !,
|
|
'$recorda'('$unknown','$unknown'(P,'$unknown_warning'(P)),_).
|
|
'$new_unknown'(X) :-
|
|
arg(1,X,A),
|
|
'$current_module'(M),
|
|
'$recorda'('$unknown','$unknown'(A,M:X),_).
|
|
|
|
'$unknown_error'(P) :-
|
|
throw(error(unknown,P)).
|
|
|
|
'$unknown_warning'(P) :-
|
|
P=M:F,
|
|
functor(F,Na,Ar),
|
|
format(user_error,"[ EXISTENCE ERROR: ~w, procedure ~w:~w/~w undefined ]~n",
|
|
[P,M,Na,Ar]),
|
|
fail.
|
|
|
|
predicate_property(Mod:Pred,Prop) :- !,
|
|
( '$current_module'(Mod) ->
|
|
'$predicate_property2'(Pred,Prop)
|
|
;
|
|
'$mod_switch'(Mod,'$predicate_property2'(Pred,Prop))
|
|
).
|
|
predicate_property(Pred,Prop) :-
|
|
'$predicate_property2'(Pred,Prop).
|
|
|
|
'$predicate_property2'(Pred,Prop) :- var(Pred), !,
|
|
'$current_predicate'(_,Pred),
|
|
'$pred_exists'(Pred),
|
|
'$predicate_property'(Pred,Prop).
|
|
'$predicate_property2'(Pred,Prop) :-
|
|
'$predicate_property'(Pred,Prop),
|
|
'$pred_exists'(Pred).
|
|
|
|
'$predicate_property'(P,built_in) :-
|
|
'$system_predicate'(P), !.
|
|
'$predicate_property'(P,dynamic) :-
|
|
'$is_dynamic'(P).
|
|
'$predicate_property'(P,static) :-
|
|
\+ '$is_dynamic'(P).
|
|
'$predicate_property'(P,meta_predicate(P)) :-
|
|
'$current_module'(M),
|
|
functor(P,Na,Ar),
|
|
recorded('$meta_predicate','$meta_predicate'(M,Na,Ar,P),_).
|
|
'$predicate_property'(P,multifile) :-
|
|
functor(P,N,A),
|
|
'$is_multifile'(N,A).
|
|
'$predicate_property'(P,imported_from(Mod)) :-
|
|
functor(P,N,A),
|
|
'$recorded'($module,$module(_TFN,Mod,Publics),_),
|
|
$member(N/A,Publics). /* defined in modules.yap */
|
|
'$predicate_property'(P,public) :-
|
|
'$is_public'(P).
|
|
'$predicate_property'(P,exported) :-
|
|
functor(P,N,A),
|
|
$current_module(M),
|
|
'$recorded'($module,$module(_TFN,M,Publics),_),
|
|
$member(N/A,Publics). /* defined in modules.yap */
|
|
|
|
%%% Some "dirty" predicates
|
|
|
|
% Only efective if yap compiled with -DDEBUG
|
|
% this predicate shows the code produced by the compiler
|
|
'$show_code' :- '$debug'(0'f).
|
|
|
|
'$pred_exists'(Pred) :- '$is_dynamic'(Pred), !.
|
|
'$pred_exists'(Pred) :- \+ '$undefined'(Pred).
|
|
|
|
|
|
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).
|
|
|
|
'$force_environment_for_gc'.
|
|
|
|
profile_data(P, Parm, Data) :- var(P), !,
|
|
'$profile_data_for_var'(P, Parm, Data).
|
|
profile_data(M:P, Parm, Data) :- var(M), !,
|
|
throw(error(instantiation_error,profile_data(M:P, Parm, Data))).
|
|
profile_data(M:P, Parm, Data) :- var(M), !,
|
|
'$mod_switch'(Mod,'$profile_data'(P, Parm, Data)).
|
|
profile_data(P, Parm, Data) :-
|
|
'$profile_data'(P, Parm, Data).
|
|
|
|
'$profile_data'(Na/Ar,Parm,Data) :-
|
|
'$profile_info'(Na, Ar, Stats),
|
|
'$profile_say'(Stats, Parm, Data).
|
|
|
|
'$profile_data_for_var'(Name/Arity, Parm, Data) :-
|
|
'$current_predicate'(_,P),
|
|
functor(P, Name, Arity),
|
|
'$profile_info'(Name, Arity, Stats),
|
|
'$profile_say'(Stats, Parm, Data).
|
|
|
|
|
|
|
|
'$profile_say'('$profile'(Entries, _, _), calls, Entries).
|
|
'$profile_say'('$profile'(_, _, Backtracks), retries, Backtracks).
|
|
|
|
profile_reset :-
|
|
current_predicate(_,P0),
|
|
functor(P0, Name, Arity),
|
|
'$profile_reset'(Name, Arity),
|
|
fail.
|
|
profile_reset.
|
|
|
|
'$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.
|
|
|
|
atom_concat(X,Y,At) :-
|
|
atom(At), !,
|
|
atom_length(At,Len),
|
|
'$atom_contact_split'(At,0,Len,X,Y).
|
|
/* Let atom_chars do our error handling */
|
|
atom_concat(X,Y,At) :-
|
|
atom_codes(X,S1),
|
|
atom_codes(Y,S2),
|
|
'$append'(S1,S2,S),
|
|
atom_codes(At,S).
|
|
|
|
|
|
|
|
'$atom_contact_split'(At,Len,Len,X,Y) :- !,
|
|
'$atom_split'(At,Len,X,Y).
|
|
'$atom_contact_split'(At,Len1,_,X,Y) :-
|
|
'$atom_split'(At,Len1,X,Y).
|
|
'$atom_contact_split'(At,Len1,Len,X,Y) :-
|
|
Len2 is Len1+1,
|
|
'$atom_contact_split'(At,Len2,Len,X,Y).
|
|
|
|
sub_atom(At, Bef, Size, After, SubAt) :-
|
|
var(At), !,
|
|
throw(error(instantiation_error,sub_atom(At, Bef, Size,After, SubAt))).
|
|
sub_atom(At, Bef, Size, After, SubAt) :-
|
|
\+ atom(At), !,
|
|
throw(error(type_error(atom,At),sub_atom(At, Bef, Size,After, SubAt))).
|
|
sub_atom(At, Bef, Size, After, SubAt) :-
|
|
nonvar(SubAt), \+ atom(SubAt), !,
|
|
throw(error(type_error(atom,SubAt),sub_atom(At, Bef, Size,After, SubAt))).
|
|
sub_atom(At, Bef, Size, After, SubAt) :-
|
|
'$check_type_sub_atom'(Bef, sub_atom(At, Bef, Size,After, SubAt)),
|
|
'$check_type_sub_atom'(Size, sub_atom(At, Bef, Size,After, SubAt)),
|
|
'$check_type_sub_atom'(After, sub_atom(At, Bef, Size,After, SubAt)),
|
|
atom_codes(At, Atl),
|
|
'$$_length1'(Atl,0,Len),
|
|
'$split_len_in_parts'(Atl, Len, Bef, Size, After, SubAtl),
|
|
atom_codes(SubAt, SubAtl).
|
|
|
|
'$check_type_sub_atom'(I, _) :-
|
|
var(I), !.
|
|
'$check_type_sub_atom'(I, P) :-
|
|
integer(I), I < 0, !,
|
|
throw(error(domain_error(not_less_than_zero,I),P)).
|
|
'$check_type_sub_atom'(I, P) :-
|
|
\+ integer(I), !,
|
|
throw(error(type_error(integer,I),P)).
|
|
'$check_type_sub_atom'(_, _).
|
|
|
|
'$split_len_in_parts'(Atl, Len, Bef, Size, After, SubAt) :-
|
|
var(Bef), !,
|
|
'$range_var'(0, Len, Bef),
|
|
'$split_len_in_parts2'(Atl, Len, Bef, Size, After, SubAt).
|
|
'$split_len_in_parts'(Atl, Len, Bef, Size, After, SubAt) :-
|
|
'$split_len_in_parts2'(Atl, Len, Bef, Size, After, SubAt).
|
|
|
|
'$split_len_in_parts2'(Atl, Len, 0, Size, After, SubAt) :- !,
|
|
'$split_len_in_parts3'(Atl, Len, Size, After, SubAt).
|
|
'$split_len_in_parts2'([_|Atl], Len0, Bef0, Size, After, SubAt) :-
|
|
Bef is Bef0-1 ,
|
|
Len is Len0-1,
|
|
'$split_len_in_parts2'(Atl, Len, Bef, Size, After, SubAt).
|
|
|
|
|
|
'$split_len_in_parts3'(Atl, Len, Size, After, SubAt) :-
|
|
var(Size), !,
|
|
'$range_var'(0, Len, Size),
|
|
'$split_len_in_parts4'(Atl, Len, Size, After, SubAt).
|
|
'$split_len_in_parts3'(Atl, Len, Size, After, SubAt) :-
|
|
'$split_len_in_parts4'(Atl, Len, Size, After, SubAt).
|
|
|
|
'$split_len_in_parts4'(_, Len, 0, After, SubAt) :- !,
|
|
After = Len,
|
|
SubAt = [].
|
|
'$split_len_in_parts4'([Code|Atl], Len0, Size0, After, [Code|SubAt]) :-
|
|
Size is Size0-1,
|
|
Len is Len0-1,
|
|
'$split_len_in_parts4'(Atl, Len, Size, After, SubAt).
|
|
|
|
'$range_var'(X,X,S) :- !, S = X.
|
|
'$range_var'(X1,_,X1).
|
|
'$range_var'(X1,X2,XF) :-
|
|
X11 is X1+1,
|
|
'$range_var'(X11,X2,XF).
|
|
|
|
|
|
current_predicate(V) :- var(V), !,
|
|
current_predicate(_,S),
|
|
functor(S,Na,Ar),
|
|
V = Na/Ar.
|
|
current_predicate(Na/Ar) :- !,
|
|
current_predicate(Na,S),
|
|
\+ '$system_predicate'(S),
|
|
functor(S,Na,Ar).
|
|
current_predicate(M:X) :- !,
|
|
'$mod_switch'(M,current_predicate(X)).
|
|
current_predicate(T) :-
|
|
throw(error(type_error(predicate_indicator,T),current_predicate(T))).
|
|
|
|
|
|
'$singletons_in_term'(T,VL) :-
|
|
'$variables_in_term'(T,[],V10),
|
|
'$sort'(V10, V1),
|
|
'$non_singletons_in_term'(T,[],V20),
|
|
'$sort'(V20, V2),
|
|
'$subtract_lists_of_variables'(V2,V1,VL).
|
|
|
|
'$subtract_lists_of_variables'([],VL,VL).
|
|
'$subtract_lists_of_variables'([_|_],[],[]) :- !.
|
|
'$subtract_lists_of_variables'([V1|VL1],[V2|VL2],VL) :-
|
|
V1 == V2, !,
|
|
'$subtract_lists_of_variables'(VL1,VL2,VL).
|
|
'$subtract_lists_of_variables'([V1|VL1],[V2|VL2],[V2|VL]) :-
|
|
'$subtract_lists_of_variables'([V1|VL1],VL2,VL).
|
|
|
|
simple(V) :- var(V), !.
|
|
simple(A) :- atom(A), !.
|
|
simple(N) :- number(N).
|
|
|
|
callable(V) :- var(V), !, fail.
|
|
callable(V) :- atom(V), !.
|
|
callable(V) :- functor(V,_,Ar), Ar > 0.
|
|
|
|
initialization :-
|
|
'$initialisation_goals'.
|
|
|
|
prolog_initialization(G) :- var(G), !,
|
|
throw(error(instantiation_error,initialization(G))).
|
|
prolog_initialization(T) :- callable(T), !,
|
|
'$assert_init'(T).
|
|
prolog_initialization(T) :-
|
|
throw(error(type_error(callable,T),initialization(T))).
|
|
|
|
'$assert_init'(T) :- '$recordz'('$startup_goal',T,_), fail.
|
|
'$assert_init'(_).
|
|
|
|
version :- '$version'.
|
|
|
|
version(V) :- var(V), !,
|
|
throw(error(instantiation_error,version(V))).
|
|
version(T) :- atom(T), !, '$assert_version'(T).
|
|
version(T) :-
|
|
throw(error(type_error(atom,T),version(T))).
|
|
|
|
'$assert_version'(T) :- '$recordz'('$version',T,_), fail.
|
|
'$assert_version'(_).
|
|
|
|
term_variables(Term, L) :-
|
|
'$variables_in_term'(Term, [], L).
|
|
|
|
term_hash(X,Y) :-
|
|
term_hash(X,-1,16'1000000,Y).
|
|
|
|
|
|
|
|
%
|
|
% allow users to define their own directives.
|
|
%
|
|
user_defined_directive(Dir,_) :-
|
|
'$directive'(Dir), !.
|
|
user_defined_directive(Dir,Action) :-
|
|
functor(Dir,Na,Ar),
|
|
functor(NDir,Na,Ar),
|
|
assert_static('$directive'(NDir)),
|
|
assert_static(('$exec_directive'(Dir, _) :- Action)).
|
|
|
|
'$mod_switch'(Mod,Pred) :-
|
|
'$current_module'(Mod), !,
|
|
'$fast_do'(Pred).
|
|
'$mod_switch'(Mod,Pred) :-
|
|
'$current_module'(Old,Mod),
|
|
( '$fast_do'(Pred); '$current_module'(_,Old), fail ),
|
|
( '$current_module'(_,Old); '$current_module'(_,Mod), fail).
|
|
|
|
'$fast_do'('$execute_command'(G,V,O)) :- '$execute_command'(G,V,O).
|
|
'$fast_do'('$go_compile_clause'(G,V,N)) :- '$go_compile_clause'(G,V,N).
|
|
'$fast_do'('$multifile'(P)) :- '$multifile'(P).
|
|
'$fast_do'('$discontiguous'(P)) :- '$discontiguous'(P).
|
|
'$fast_do'('$assert'(C,W,R,P)) :- '$assert'(C,W,R,P).
|
|
'$fast_do'('$assert_dynamic'(C,W,R,P)) :- '$assert_dynamic'(C,W,R,P).
|
|
'$fast_do'('$assert_static'(C,W,R,P)) :- '$assert_static'(C,W,R,P).
|
|
'$fast_do'(clause(P,Q)) :- clause(P,Q).
|
|
'$fast_do'(clause(P,Q,R)) :- clause(P,Q,R).
|
|
'$fast_do'(retract(C)) :- retract(C).
|
|
'$fast_do'(retract(C,R)) :- retract(C,R).
|
|
'$fast_do'(retractall(C)) :- retractall(C).
|
|
'$fast_do'(abolish(N,A)) :- abolish(N,A).
|
|
'$fast_do'('$new_abolish'(P)) :- '$new_abolish'(P).
|
|
'$fast_do'('$old_abolish'(P)) :- '$old_abolish'(P).
|
|
'$fast_do'('$dynamic'(S)) :- '$dynamic'(S).
|
|
'$fast_do'(current_predicate(PS)) :- current_predicate(PS).
|
|
'$fast_do'(current_predicate(A,T)) :- current_predicate(A,T).
|
|
'$fast_do'('$predicate_property2'(P,T)) :- '$predicate_property2'(P,T).
|
|
'$fast_do'(unknown(V,H)) :- unknown(V,H).
|
|
'$fast_do'(listing(PE)) :- listing(PE).
|
|
'$fast_do'('$Error'(E)) :- '$Error'(E).
|
|
'$fast_do'('$LoopError'(E)) :- '$LoopError'(E).
|
|
'$fast_do'('$DebugError'(E)) :- '$DebugError'(E).
|
|
'$fast_do'('$exec_with_expansion2'(G,M)) :- '$exec_with_expansion2'(G,M).
|
|
'$fast_do'('$public'(P)) :- '$public'(P).
|
|
'$fast_do'('$module_u_vars'(H,UVars)) :- '$module_u_vars'(H,UVars).
|
|
'$fast_do'(M:G) :- '$mod_switch'(M,G).
|
|
'$fast_do'('$spycalls'(G,Res)) :- '$spycalls'(G,Res).
|
|
'$fast_do'('$profile_data'(P, Parm, Data)) :- '$profile_data'(P, Parm, Data).
|
|
|
|
|
|
'$set_toplevel_hook'(_) :-
|
|
'$recorded'('$toplevel_hooks',_,R),
|
|
erase(R),
|
|
fail.
|
|
'$set_toplevel_hook'(H) :-
|
|
'$recorda'('$toplevel_hooks',H,_),
|
|
fail.
|
|
'$set_toplevel_hook'(_).
|
|
|
|
|
|
raise_exception(Ball) :- throw(Ball).
|
|
on_exception(Pat, G, H) :- catch(G, Pat, H).
|
|
|