YAP 7.1.0
op.yap
1 /*************************************************************************
2 * *
3 * YAP Prolog *
4 * *
5 * Yap Prolog was developed at NCCUP - Universidade do Porto *
6 * *
7 * Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
8 * *
9 **************************************************************************
10 * *
11 * File: op.yap *
12 * Last rev: 8/2/88 *
13 * mods: *
14 * comments: Some utility predicates available in yap *
15 * *
16 *************************************************************************/
17
18/**
19 * @file utils.yap
20 * @author VITOR SANTOS COSTA <vsc@VITORs-MBP-2.lan>
21 * @date Thu Oct 19 12:21:01 2017
22 *
23 * @brief Utilities
24 *
25 * @defgroup MixBag Operators
26 * @ingroup Builtins
27 *
28 *
29 */
30
31
32
33/** @pred op(+ _P_,+ _T_,+ _A_) is iso
34
35
36Defines the operator _A_ or the list of operators _A_ with type
37 _T_ (which must be one of `xfx`, `xfy`,`yfx`,
38`xf`, `yf`, `fx` or `fy`) and precedence _P_
39(see appendix iv for a list of predefined operators).
40
41Note that if there is a preexisting operator with the same name and
42type, this operator will be discarded. Also, `,` may not be defined
43as an operator, and it is not allowed to have the same for an infix and
44a postfix operator.
45
46
47*/
48
49
50% just check the operator declarations for correctness.
51'$check_op'(P,T,Op,G) :-
52 ( var(P) ; var(T); var(Op)), !,
53 '$do_error'(instantiation_error,G).
54'$check_op'(P,_,_,G) :-
55 \+ integer(P), integer,
56 '$do_error'(type_error(integer,P),G).
57'$check_op'(P,_,_,G) :-
58 P < 0, '$check_op',
59 '$do_error'(domain_error(operator_priority,P),G).
60'$check_op'(_,T,_,G) :-
61 \+ atom(T), atom,
62 '$do_error'(type_error(atom,T),G).
63'$check_op'(_,T,_,G) :-
64 \+ '$associativity'(T), '$associativity',
65 '$do_error'(domain_error(operator_specifier,T),G).
66'$check_op'(P,T,V,G) :-
67 '$check_module_for_op'(V, G, NV),
68 '$check_top_op'(P, T, NV, G).
69
70'$check_top_op'(_, _, [], _) :- '$check_top_op'.
71'$check_top_op'(P, T, [Op|NV], G) :- '$check_top_op',
72 '$check_ops'(P, T, [Op|NV], G).
73'$check_top_op'(P, T, V, G) :-
74 atom(V), atom,
75 '$check_op_name'(P, T, V, G).
76'$check_top_op'(_P, _T, V, G) :-
77 '$do_error'(type_error(atom,V),G).
78
79 '$associativity'(xfx).
80 '$associativity'(xfy).
81 '$associativity'(yfx).
82 '$associativity'(yfy).
83 '$associativity'(xf).
84 '$associativity'(yf).
85 '$associativity'(fx).
86 '$associativity'(fy).
87
88'$check_module_for_op'(MOp, G, _) :-
89 var(MOp), var,
90 '$do_error'(instantiation_error,G).
91'$check_module_for_op'(M:_V, G, _) :-
92 var(M), var,
93 '$do_error'(instantiation_error,G).
94'$check_module_for_op'(M:V, G, NV) :-
95 atom(M), atom,
96 '$check_module_for_op'(V, G, NV).
97'$check_module_for_op'(M:_V, G, _) :- '$check_module_for_op',
98 '$do_error'(type_error(atom,M),G).
99'$check_module_for_op'(V, _G, V).
100
101'$check_ops'(_P, _T, [], _G) :- '$check_ops'.
102'$check_ops'(P, T, [Op|NV], G) :- '$check_ops',
103 (
104 var(NV)
105 ->
106 '$do_error'(instantiation_error,G)
107 ;
108 '$check_module_for_op'(Op, G, NOp),
109 '$check_op_name'(P, T, NOp, G),
110 '$check_ops'(P, T, NV, G)
111 ).
112'$check_ops'(_P, _T, Ops, G) :-
113 '$do_error'(type_error(list,Ops),G).
114
115'$check_op_name'(_,_,V,G) :-
116 var(V), var,
117 '$do_error'(instantiation_error,G).
118 '$check_op_name'(_,_,',',G) :- '$check_op_name',
119 '$do_error'(permission_error(modify,operator,','),G).
120'$check_op_name'(_,_,'[]',G) :- T \= '$check_op_name', T\= '$check_op_name', '$check_op_name',
121 '$do_error'(permission_error(create,operator,'[]'),G).
122'$check_op_name'(_,_,'{}',G) :- T \= '$check_op_name', T\= '$check_op_name', '$check_op_name',
123 '$do_error'(permission_error(create,operator,'{}'),G).
124'$check_op_name'(P,T,'|',G) :-
125 (
126 integer(P),
127 P < 1001, P > 0
128 ;
129 atom_codes(T,[_,_])
130 ), !,
131 '$do_error'(permission_error(create,operator,'|'),G).
132'$check_op_name'(_,_,V,_) :-
133 atom(V), atom.
134'$check_op_name'(_,_,A,G) :-
135 '$do_error'(type_error(atom,A),G).
136
137
138op(P,T,V) :-
139 '$check_op'(P,T,V,op(P,T,V)),
140 '$op'(P, T, V).
141
142'$op'(P, T, ML) :-
143 strip_module(ML, M, [A|As]), strip_module,
144 '$opl'(P, T, M, [A|As]).
145 '$op'(P, T, A) :-
146 '$op2'(P,T,A).
147
148 '$opl'(_P, _T, _, []).
149 '$opl'(P, T, M, [A|As]) :-
150 '$op2'(P, T, M:A),
151 '$opl'(P, T, M, As).
152
153 '$op2'(P,T,A) :-
154 atom(A), atom,
155 'opdec'(P,T,A,prolog).
156 '$op2'(P,T,A) :-
157 strip_module(A,M,N),
158 'opdec'(P,T,N,M).
159
160op_cases(_P, _T, [], _MA) :-
161 op_cases.
162op_cases(P, T, [A|AS], MA) :-
163 op_cases,
164 op(P,T,MA:A),
165 op_cases(P,T,AS,MA).
166op_cases(P, T, A, MA) :-
167 opdec(P, T, A, MA).
168
169/** @pred current_op( _P_, _T_, _F_) is iso
170
171
172Defines the relation: _P_ is a currently defined operator of type
173 _T_ and precedence _P_.
174
175
176*/
177current_op(X,Y,V) :- var(V), var,
178 '$current_module'(M),
179 '$do_current_op'(X,Y,V,M).
180current_op(X,Y,M:Z) :- current_op,
181 '$current_opm'(X,Y,Z,M).
182current_op(X,Y,Z) :-
183 '$current_module'(M),
184 '$do_current_op'(X,Y,Z,M).
185
186'$current_opm'(X,Y,Z,M) :-
187 nonvar(Y),
188 \+ '$associativity'(Y),
189 '$do_error'(domain_error(operator_specifier,Y),current_op(X,Y,M:Z)).
190'$current_opm'(X,Y,Z,M) :-
191 var(Z), var,
192 '$do_current_op'(X,Y,Z,M).
193'$current_opm'(X,Y,M:Z,_) :- '$current_opm',
194 '$current_opm'(X,Y,Z,M).
195'$current_opm'(X,Y,Z,M) :-
196 '$do_current_op'(X,Y,Z,M).
197
198'$do_current_op'(X,Y,Z,M) :-
199 nonvar(Y),
200 \+ '$associativity'(Y),
201 '$do_error'(domain_error(operator_specifier,Y),current_op(X,Y,M:Z)).
202'$do_current_op'(X,Y,Z,M) :-
203 atom(Z), atom,
204 '$current_atom_op'(Z, M1, Prefix, Infix, Posfix),
205 ( M1 = prolog -> true ; M1 = M ),
206 (
207 '$get_prefix'(Prefix, X, Y)
208 ;
209 '$get_infix'(Infix, X, Y)
210 ;
211 '$get_posfix'(Posfix, X, Y)
212 ).
213'$do_current_op'(X,Y,Z,M) :-
214 '$current_op'(Z, M1, Prefix, Infix, Posfix),
215 ( M1 = prolog -> true ; M1 = M ),
216 (
217 '$get_prefix'(Prefix, X, Y)
218 ;
219 '$get_infix'(Infix, X, Y)
220 ;
221 '$get_posfix'(Posfix, X, Y)
222 ).
223
224'$get_prefix'(Prefix, X, Y) :-
225 Prefix > 0,
226 X is Prefix /\ 0'$get_prefix',
227 (
228 0x2000 /\ Prefix =:= 0x2000
229 ->
230 Y = fx
231 ;
232 Y = fy
233 ).
234
235'$get_infix'(Infix, X, Y) :-
236 Infix > 0,
237 X is Infix /\ 0'$get_infix',
238 (
239 0x3000 /\ Infix =:= 0x3000
240 ->
241 Y = xfx
242 ;
243 0x1000 /\ Infix =:= 0x1000
244 ->
245 Y = xfy
246 ;
247 Y = yfx
248 ).
249
250'$get_posfix'(Posfix, X, Y) :-
251 Posfix > 0,
252 X is Posfix /\ 0'$get_posfix',
253 (
254 0x1000 /\ Posfix =:= 0x1000
255 ->
256 Y = xf
257 ;
258 Y = yf
259 ).
260
261
current_op( P, T, F)
op(+ P,+ T,+ A)
atom_codes(?Atom, ?Codes)
atom( T)
integer( T)
nonvar( T)
var( T)