308 lines
6.8 KiB
Prolog
308 lines
6.8 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 *
|
|
* *
|
|
*************************************************************************/
|
|
|
|
:- system_module( '$_utils', [callable/1,
|
|
current_op/3,
|
|
nb_current/2,
|
|
nth_instance/3,
|
|
nth_instance/4,
|
|
op/3,
|
|
prolog/0,
|
|
recordaifnot/3,
|
|
recordzifnot/3,
|
|
simple/1,
|
|
subsumes_term/2], ['$getval_exception'/3]).
|
|
|
|
:- use_system_module( '$_boot', ['$live'/0]).
|
|
|
|
:- use_system_module( '$_errors', ['$do_error'/2]).
|
|
|
|
|
|
op(P,T,V) :-
|
|
'$check_op'(P,T,V,op(P,T,V)),
|
|
'$op'(P, T, V).
|
|
|
|
% just check the operator declarations for correctness.
|
|
'$check_op'(P,T,Op,G) :-
|
|
( var(P) ; var(T); var(Op)), !,
|
|
'$do_error'(instantiation_error,G).
|
|
'$check_op'(P,_,_,G) :-
|
|
\+ integer(P), !,
|
|
'$do_error'(type_error(integer,P),G).
|
|
'$check_op'(P,_,_,G) :-
|
|
P < 0, !,
|
|
'$do_error'(domain_error(operator_priority,P),G).
|
|
'$check_op'(P,_,_,G) :-
|
|
P > 1200, !,
|
|
'$do_error'(domain_error(operator_priority,P),G).
|
|
'$check_op'(_,T,_,G) :-
|
|
\+ atom(T), !,
|
|
'$do_error'(type_error(atom,P),G).
|
|
'$check_op'(_,T,_,G) :-
|
|
\+ '$associativity'(T), !,
|
|
'$do_error'(domain_error(operator_specifier,T),G).
|
|
'$check_op'(P,T,V,G) :-
|
|
'$check_module_for_op'(V, G, NV),
|
|
'$check_top_op'(P, T, NV, G).
|
|
|
|
'$check_top_op'(_, _, [], _).
|
|
'$check_top_op'(P, T, Op.NV, G) :- !,
|
|
'$check_ops'(P, T, Op.NV, G).
|
|
'$check_top_op'(P, T, V, G) :-
|
|
atom(V), !,
|
|
'$check_op_name'(P, T, V, G).
|
|
'$check_top_op'(P, T, V, G) :-
|
|
'$do_error'(type_error(atom,V),G).
|
|
|
|
'$associativity'(xfx).
|
|
'$associativity'(xfy).
|
|
'$associativity'(yfx).
|
|
'$associativity'(yfy).
|
|
'$associativity'(xf).
|
|
'$associativity'(yf).
|
|
'$associativity'(fx).
|
|
'$associativity'(fy).
|
|
|
|
'$check_module_for_op'(MOp, G, _) :-
|
|
var(MOp), !,
|
|
'$do_error'(instantiation_error,G).
|
|
'$check_module_for_op'(M:V, G, _) :-
|
|
var(M), !,
|
|
'$do_error'(instantiation_error,G).
|
|
'$check_module_for_op'(M:V, G, NV) :-
|
|
atom(M), !,
|
|
'$check_module_for_op'(V, G, NV).
|
|
'$check_module_for_op'(M:V, G, _) :- !,
|
|
'$do_error'(type_error(atom,P),G).
|
|
'$check_module_for_op'(V, G, V).
|
|
|
|
'$check_ops'(P, T, [], G) :- !.
|
|
'$check_ops'(P, T, Op.NV, G) :- !,
|
|
(
|
|
var(NV)
|
|
->
|
|
'$do_error'(instantiation_error,G)
|
|
;
|
|
'$check_module_for_op'(Op, G, NOp),
|
|
'$check_op_name'(P, T, NOp, G),
|
|
'$check_ops'(P, T, NV, G)
|
|
).
|
|
'$check_ops'(P, T, Ops, G) :-
|
|
'$do_error'(type_error(list,Ops),G).
|
|
|
|
'$check_op_name'(_,_,V,G) :-
|
|
var(V), !,
|
|
'$do_error'(instantiation_error,G).
|
|
'$check_op_name'(_,_,',',G) :- !,
|
|
'$do_error'(permission_error(modify,operator,','),G).
|
|
'$check_op_name'(_,_,'[]',G) :- T \= yf, T\= xf, !,
|
|
'$do_error'(permission_error(create,operator,'[]'),G).
|
|
'$check_op_name'(_,_,'{}',G) :- T \= yf, T\= xf, !,
|
|
'$do_error'(permission_error(create,operator,'{}'),G).
|
|
'$check_op_name'(P,T,'|',G) :-
|
|
(
|
|
integer(P),
|
|
P < 1001, P > 0
|
|
;
|
|
atom_codes(T,[_,_])
|
|
), !,
|
|
'$do_error'(permission_error(create,operator,'|'),G).
|
|
'$check_op_name'(_,_,V,_) :-
|
|
atom(V), !.
|
|
'$check_op_name'(_,_,A,G) :-
|
|
'$do_error'(type_error(atom,A),G).
|
|
|
|
'$op'(P, T, ML) :-
|
|
strip_module(ML, M, [A|As]), !,
|
|
'$opl'(P, T, M, [A|As]).
|
|
'$op'(P, T, A) :-
|
|
'$op2'(P,T,A).
|
|
|
|
'$opl'(P, T, _, []).
|
|
'$opl'(P, T, M, [A|As]) :-
|
|
'$op2'(P, T, M:A),
|
|
'$opl'(P, T, M, As).
|
|
|
|
'$op2'(P,T,A) :-
|
|
atom(A), !,
|
|
'$opdec'(P,T,A,prolog).
|
|
'$op2'(P,T,A) :-
|
|
strip_module(A,M,N),
|
|
'$opdec'(P,T,N,M).
|
|
|
|
current_op(X,Y,V) :- var(V), !,
|
|
'$current_module'(M),
|
|
'$do_current_op'(X,Y,V,M).
|
|
current_op(X,Y,M:Z) :- !,
|
|
'$current_opm'(X,Y,Z,M).
|
|
current_op(X,Y,Z) :-
|
|
'$current_module'(M),
|
|
'$do_current_op'(X,Y,Z,M).
|
|
|
|
|
|
'$current_opm'(X,Y,Z,M) :-
|
|
nonvar(Y),
|
|
\+ '$associativity'(Y),
|
|
'$do_error'(domain_error(operator_specifier,Y),current_op(X,Y,M:Z)).
|
|
'$current_opm'(X,Y,Z,M) :-
|
|
var(Z), !,
|
|
'$do_current_op'(X,Y,Z,M).
|
|
'$current_opm'(X,Y,M:Z,_) :- !,
|
|
'$current_opm'(X,Y,Z,M).
|
|
'$current_opm'(X,Y,Z,M) :-
|
|
'$do_current_op'(X,Y,Z,M).
|
|
|
|
'$do_current_op'(X,Y,Z,M) :-
|
|
nonvar(Y),
|
|
\+ '$associativity'(Y),
|
|
'$do_error'(domain_error(operator_specifier,Y),current_op(X,Y,M:Z)).
|
|
'$do_current_op'(X,Y,Z,M) :-
|
|
atom(Z), !,
|
|
'$current_atom_op'(Z, M1, Prefix, Infix, Posfix),
|
|
( M1 = prolog -> true ; M1 = M ),
|
|
(
|
|
'$get_prefix'(Prefix, X, Y)
|
|
;
|
|
'$get_infix'(Infix, X, Y)
|
|
;
|
|
'$get_posfix'(Posfix, X, Y)
|
|
).
|
|
'$do_current_op'(X,Y,Z,M) :-
|
|
'$current_op'(Z, M1, Prefix, Infix, Posfix),
|
|
( M1 = prolog -> true ; M1 = M ),
|
|
(
|
|
'$get_prefix'(Prefix, X, Y)
|
|
;
|
|
'$get_infix'(Infix, X, Y)
|
|
;
|
|
'$get_posfix'(Posfix, X, Y)
|
|
).
|
|
|
|
'$get_prefix'(Prefix, X, Y) :-
|
|
Prefix > 0,
|
|
X is Prefix /\ 0xfff,
|
|
(
|
|
0x2000 /\ Prefix =:= 0x2000
|
|
->
|
|
Y = fx
|
|
;
|
|
Y = fy
|
|
).
|
|
|
|
'$get_infix'(Infix, X, Y) :-
|
|
Infix > 0,
|
|
X is Infix /\ 0xfff,
|
|
(
|
|
0x3000 /\ Infix =:= 0x3000
|
|
->
|
|
Y = xfx
|
|
;
|
|
0x1000 /\ Infix =:= 0x1000
|
|
->
|
|
Y = xfy
|
|
;
|
|
Y = yfx
|
|
).
|
|
|
|
'$get_posfix'(Posfix, X, Y) :-
|
|
Posfix > 0,
|
|
X is Posfix /\ 0xfff,
|
|
(
|
|
0x1000 /\ Posfix =:= 0x1000
|
|
->
|
|
Y = xf
|
|
;
|
|
Y = yf
|
|
).
|
|
|
|
|
|
prolog :-
|
|
'$live'.
|
|
|
|
%%% current ....
|
|
|
|
recordaifnot(K,T,R) :-
|
|
recorded(K,T,R), % force non-det binding to R.
|
|
'$still_variant'(R,T),
|
|
!,
|
|
fail.
|
|
recordaifnot(K,T,R) :-
|
|
recorda(K,T,R).
|
|
|
|
recordzifnot(K,T,R) :-
|
|
recorded(K,T,R),
|
|
'$still_variant'(R,T),
|
|
!,
|
|
fail.
|
|
recordzifnot(K,T,R) :-
|
|
recordz(K,T,R).
|
|
|
|
callable(A) :-
|
|
( var(A) -> fail ; number(A) -> fail ; true ).
|
|
|
|
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.
|
|
|
|
nth_instance(Key,Index,Ref) :-
|
|
nonvar(Key), var(Index), var(Ref), !,
|
|
recorded(Key,_,Ref),
|
|
'$nth_instance'(_,Index,Ref).
|
|
nth_instance(Key,Index,Ref) :-
|
|
'$nth_instance'(Key,Index,Ref).
|
|
|
|
nth_instance(Key,Index,T,Ref) :-
|
|
nonvar(Key), var(Index), var(Ref), !,
|
|
recorded(Key,T,Ref),
|
|
'$nth_instance'(_,Index,Ref).
|
|
nth_instance(Key,Index,T,Ref) :-
|
|
'$nth_instance'(Key,Index,Ref),
|
|
instance(Ref,T).
|
|
|
|
nb_current(GlobalVariable, Val) :-
|
|
'$nb_current'(GlobalVariable),
|
|
'$nb_getval'(GlobalVariable, Val, _).
|
|
|
|
'$getval_exception'(GlobalVariable, Val, Caller) :-
|
|
user:exception(undefined_global_variable, GlobalVariable, Action),
|
|
!,
|
|
(
|
|
Action == fail
|
|
->
|
|
fail
|
|
;
|
|
Action == retry
|
|
->
|
|
b_getval(GlobalVariable, Val)
|
|
;
|
|
Action == error
|
|
->
|
|
'$do_error'(existence_error(variable, GlobalVariable),Caller)
|
|
;
|
|
'$do_error'(type_error(atom, Action),Caller)
|
|
).
|
|
|
|
|
|
subsumes_term(A,B) :-
|
|
\+ \+ terms:subsumes(A,B).
|
|
|
|
|