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/utils.yap

378 lines
8.5 KiB
Plaintext
Raw Normal View History

2010-09-27 22:31:06 +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: utils.yap *
* Last rev: 8/2/88 *
* mods: *
* comments: Some utility predicates available in yap *
* *
*************************************************************************/
2014-04-09 12:39:29 +01:00
:- 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]).
2016-07-31 16:38:36 +01:00
/** @pred op(+ _P_,+ _T_,+ _A_) is iso
2014-09-11 20:06:57 +01:00
Defines the operator _A_ or the list of operators _A_ with type
_T_ (which must be one of `xfx`, `xfy`,`yfx`,
`xf`, `yf`, `fx` or `fy`) and precedence _P_
(see appendix iv for a list of predefined operators).
Note that if there is a preexisting operator with the same name and
type, this operator will be discarded. Also, `,` may not be defined
as an operator, and it is not allowed to have the same for an infix and
a postfix operator.
2016-07-31 16:38:36 +01:00
2014-09-11 20:06:57 +01:00
*/
2010-09-27 22:31:06 +01:00
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'(_,T,_,G) :-
\+ atom(T), !,
'$do_error'(type_error(atom,T),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) :- !,
2016-04-14 12:00:09 +01:00
'$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).
2010-09-27 22:31:06 +01:00
'$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,M),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)
2016-07-31 16:38:36 +01:00
).
'$check_ops'(_P, _T, Ops, G) :-
'$do_error'(type_error(list,Ops),G).
'$check_op_name'(_,_,V,G) :-
2010-09-27 22:31:06 +01:00
var(V), !,
'$do_error'(instantiation_error,G).
'$check_op_name'(_,_,',',G) :- !,
2010-09-27 22:31:06 +01:00
'$do_error'(permission_error(modify,operator,','),G).
'$check_op_name'(_,_,'[]',G) :- T \= yf, T\= xf, !,
2012-03-22 22:12:13 +00:00
'$do_error'(permission_error(create,operator,'[]'),G).
'$check_op_name'(_,_,'{}',G) :- T \= yf, T\= xf, !,
2010-09-27 22:31:06 +01:00
'$do_error'(permission_error(create,operator,'{}'),G).
'$check_op_name'(P,T,'|',G) :-
2010-09-27 22:31:06 +01:00
(
integer(P),
2012-03-22 22:10:23 +00:00
P < 1001, P > 0
2010-09-27 22:31:06 +01:00
;
atom_codes(T,[_,_])
), !,
2010-09-27 22:31:06 +01:00
'$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).
2016-07-31 16:38:36 +01:00
/** @pred current_op( _P_, _T_, _F_) is iso
2014-09-11 20:06:57 +01:00
Defines the relation: _P_ is a currently defined operator of type
_T_ and precedence _P_.
2014-09-11 20:06:57 +01:00
2016-07-31 16:38:36 +01:00
2014-09-11 20:06:57 +01:00
*/
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) :-
2010-02-26 12:03:32 +00:00
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 ....
2016-07-31 16:38:36 +01:00
/** @pred callable( _T_) is iso
2014-09-11 20:06:57 +01:00
Checks whether _T_ is a callable term, that is, an atom or a
compound term.
2016-07-31 16:38:36 +01:00
2014-09-11 20:06:57 +01:00
*/
2012-02-13 09:40:57 +00:00
callable(A) :-
( var(A) -> fail ; number(A) -> fail ; true ).
2016-07-31 16:38:36 +01:00
/** @pred simple( _T_)
2014-09-11 20:06:57 +01:00
Checks whether _T_ is unbound, an atom, or a number.
2016-07-31 16:38:36 +01:00
2014-09-11 20:06:57 +01:00
*/
simple(V) :- var(V), !.
simple(A) :- atom(A), !.
simple(N) :- number(N).
2016-07-31 16:38:36 +01:00
/** @pred nth_instance(? _Key_,? _Index_,? _R_)
2014-09-11 20:06:57 +01:00
Fetches the _Index_nth entry in the internal database under the key
_Key_. Entries are numbered from one. If the key _Key_ or the
_Index_ are bound, a reference is unified with _R_. Otherwise,
the reference _R_ must be given, and YAP will find
the matching key and index.
2016-07-31 16:38:36 +01:00
2014-09-11 20:06:57 +01:00
*/
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).
2014-09-11 20:06:57 +01:00
/** @pred nth_instance(? _Key_,? _Index_, _T_,? _R_)
Fetches the _Index_nth entry in the internal database under the key
_Key_. Entries are numbered from one. If the key _Key_ or the
_Index_ are bound, a reference is unified with _R_. Otherwise,
the reference _R_ must be given, and YAP will find
the matching key and index.
2016-07-31 16:38:36 +01:00
2014-09-11 20:06:57 +01:00
*/
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).
2016-07-31 16:38:36 +01:00
/** @pred nb_current(? _Name_, ? _Value_)
2014-09-11 20:06:57 +01:00
Enumerate all defined variables with their value. The order of
2016-07-31 16:38:36 +01:00
enumeration is undefined.
2014-09-11 20:06:57 +01:00
*/
2016-07-31 16:38:36 +01:00
/** @pred nb_current(? _Name_,? _Value_)
2014-09-11 20:06:57 +01:00
Enumerate all defined variables with their value. The order of
enumeration is undefined.
2016-07-31 16:38:36 +01:00
2014-09-11 20:06:57 +01:00
*/
nb_current(GlobalVariable, Val) :-
'$nb_current'(GlobalVariable),
2011-09-15 15:50:41 +01:00
'$nb_getval'(GlobalVariable, Val, _).
2014-10-11 14:10:35 +01:00
'$getval_exception'(GlobalVariable, _Val, Caller) :-
2010-03-01 22:32:40 +00:00
user:exception(undefined_global_variable, GlobalVariable, Action),
!,
(
Action == fail
->
fail
;
Action == retry
->
2014-10-11 14:10:35 +01:00
true
2010-03-01 22:32:40 +00:00
;
Action == error
->
'$do_error'(existence_error(variable, GlobalVariable),Caller)
;
'$do_error'(type_error(atom, Action),Caller)
).
2016-07-31 16:38:36 +01:00
/** @pred subsumes_term(? _Subsumer_, ? _Subsumed_)
2014-09-11 20:06:57 +01:00
Succeed if _Submuser_ subsumes _Subsuned_ but does not bind any
variable in _Subsumer_.
2016-07-31 16:38:36 +01:00
2014-09-11 20:06:57 +01:00
*/
subsumes_term(A,B) :-
\+ \+ terms:subsumes(A,B).
2016-07-31 16:38:36 +01:00
term_string( T, S, Opts) :-
var( T ),
!,
memory_file:open_mem_read_stream( S, Stream ),
read_term( Stream, T, Opts ),
close( Stream ).
term_string( T, S, _Opts) :-
format(string(S), '~q.~n', [T]).