35
36:- module('$dcg',
37 [ dcg_translate_rule/2, 38 dcg_translate_rule/4, 39 phrase/2, 40 phrase/3, 41 call_dcg/3 42 ]). 43
44 47
68
69dcg_translate_rule(Rule, Clause) :-
70 dcg_translate_rule(Rule, _, Clause, _).
71
72dcg_translate_rule(((LP,MNT)-->RP), Pos0, (H:-B0,B1), Pos) :-
73 !,
74 f2_pos(Pos0, PosH0, PosRP0, Pos, PosH, PosRP),
75 f2_pos(PosH0, PosLP0, PosMNT0, PosH, PosLP, PosMNT),
76 '$current_source_module'(M),
77 Qualify = q(M,M,_),
78 dcg_extend(LP, PosLP0, S0, SR, H, PosLP),
79 dcg_body(RP, PosRP0, Qualify, S0, S1, B0, PosRP),
80 dcg_body(MNT, PosMNT0, Qualify, SR, S1, B1, PosMNT).
81dcg_translate_rule((LP-->RP), Pos0, (H:-B), Pos) :-
82 f2_pos(Pos0, PosLP0, PosRP0, Pos, PosLP, PosRP),
83 dcg_extend(LP, PosLP0, S0, S, H, PosLP),
84 '$current_source_module'(M),
85 Qualify = q(M,M,_),
86 dcg_body(RP, PosRP0, Qualify, S0, S, B, PosRP).
92dcg_body(Var, P0, Q, S, SR, phrase(QVar, S, SR), P) :-
93 var(Var),
94 !,
95 qualify(Q, Var, P0, QVar, P).
96dcg_body(M:X, Pos0, q(_,C,_), S, SR, Ct, Pos) :-
97 !,
98 f2_pos(Pos0, _, XP0, _, _, _),
99 dcg_body(X, XP0, q(M,C,Pos0), S, SR, Ct, Pos).
100dcg_body([], P0, _, S, SR, S=SR, P) :- 101 !,
102 dcg_terminal_pos(P0, P).
103dcg_body(List, P0, _, S, SR, C, P) :-
104 ( List = [_|_]
105 -> !,
106 ( is_list(List)
107 -> '$append'(List, SR, OL), 108 C = (S = OL)
109 ; '$skip_list'(_, List, Tail),
110 var(Tail)
111 -> C = '$append'(List, SR, S) 112 ; '$type_error'(list_or_partial_list, List)
113 )
114 ; string(List) 115 -> !,
116 string_codes(List, Codes),
117 '$append'(Codes, SR, OL),
118 C = (S = OL)
119 ),
120 dcg_terminal_pos(P0, P).
121dcg_body(!, P0, _, S, SR, (!, SR = S), P) :-
122 !,
123 dcg_cut_pos(P0, P).
124dcg_body({}, P, _, S, S, true, P) :- !.
125dcg_body({T}, P0, Q, S, SR, (QT, SR = S), P) :-
126 !,
127 dcg_bt_pos(P0, P1),
128 qualify(Q, T, P1, QT, P).
129dcg_body((T,R), P0, Q, S, SR, (Tt, Rt), P) :-
130 !,
131 f2_pos(P0, PA0, PB0, P, PA, PB),
132 dcg_body(T, PA0, Q, S, SR1, Tt, PA),
133 dcg_body(R, PB0, Q, SR1, SR, Rt, PB).
134dcg_body((T;R), P0, Q, S, SR, (Tt;Rt), P) :-
135 !,
136 f2_pos(P0, PA0, PB0, P, PA, PB),
137 dcg_body(T, PA0, Q, S, S1, T1, PA), or_delay_bind(S, SR, S1, T1, Tt),
138 dcg_body(R, PB0, Q, S, S2, R1, PB), or_delay_bind(S, SR, S2, R1, Rt).
139dcg_body((T|R), P0, Q, S, SR, (Tt;Rt), P) :-
140 !,
141 f2_pos(P0, PA0, PB0, P, PA, PB),
142 dcg_body(T, PA0, Q, S, S1, T1, PA), or_delay_bind(S, SR, S1, T1, Tt),
143 dcg_body(R, PB0, Q, S, S2, R1, PB), or_delay_bind(S, SR, S2, R1, Rt).
144dcg_body((C->T), P0, Q, S, SR, (Ct->Tt), P) :-
145 !,
146 f2_pos(P0, PA0, PB0, P, PA, PB),
147 dcg_body(C, PA0, Q, S, SR1, Ct, PA),
148 dcg_body(T, PB0, Q, SR1, SR, Tt, PB).
149dcg_body((C*->T), P0, Q, S, SR, (Ct*->Tt), P) :-
150 !,
151 f2_pos(P0, PA0, PB0, P, PA, PB),
152 dcg_body(C, PA0, Q, S, SR1, Ct, PA),
153 dcg_body(T, PB0, Q, SR1, SR, Tt, PB).
154dcg_body((\+ C), P0, Q, S, SR, (\+ Ct, SR = S), P) :-
155 !,
156 f1_pos(P0, PA0, P, PA),
157 dcg_body(C, PA0, Q, S, _, Ct, PA).
158dcg_body(T, P0, Q, S, SR, QTt, P) :-
159 dcg_extend(T, P0, S, SR, Tt, P1),
160 qualify(Q, Tt, P1, QTt, P).
161
162or_delay_bind(S, SR, S1, T, (T, SR=S)) :-
163 S1 == S,
164 !.
165or_delay_bind(_S, SR, SR, T, T).
173qualify(q(M,C,_), X0, Pos0, X, Pos) :-
174 M == C,
175 !,
176 X = X0,
177 Pos = Pos0.
178qualify(q(M,_,MP), X, Pos0, M:X, Pos) :-
179 dcg_qualify_pos(Pos0, MP, Pos).
189:- dynamic dcg_extend_cache/4. 190:- volatile dcg_extend_cache/4. 191
192dcg_no_extend([]).
193dcg_no_extend([_|_]).
194dcg_no_extend({_}).
195dcg_no_extend({}).
196dcg_no_extend(!).
197dcg_no_extend((\+_)).
198dcg_no_extend((_,_)).
199dcg_no_extend((_;_)).
200dcg_no_extend((_|_)).
201dcg_no_extend((_->_)).
202dcg_no_extend((_*->_)).
203dcg_no_extend((_-->_)).
212dcg_extend(V, _, _, _, _, _) :-
213 var(V),
214 !,
215 throw(error(instantiation_error,_)).
216dcg_extend(M:OldT, Pos0, A1, A2, M:NewT, Pos) :-
217 !,
218 f2_pos(Pos0, MPos, P0, Pos, MPos, P),
219 dcg_extend(OldT, P0, A1, A2, NewT, P).
220dcg_extend(OldT, P0, A1, A2, NewT, P) :-
221 dcg_extend_cache(OldT, A1, A2, NewT),
222 !,
223 extended_pos(P0, P).
224dcg_extend(OldT, P0, A1, A2, NewT, P) :-
225 ( callable(OldT)
226 -> true
227 ; throw(error(type_error(callable,OldT),_))
228 ),
229 ( dcg_no_extend(OldT)
230 -> throw(error(permission_error(define,dcg_nonterminal,OldT),_))
231 ; true
232 ),
233 ( compound(OldT)
234 -> compound_name_arity(OldT, Name, Arity),
235 compound_name_arity(CopT, Name, Arity)
236 ; CopT = OldT,
237 Name = OldT,
238 Arity = 0
239 ),
240 NewArity is Arity+2,
241 functor(NewT, Name, NewArity),
242 copy_args(1, Arity, CopT, NewT),
243 A1Pos is Arity+1,
244 A2Pos is Arity+2,
245 arg(A1Pos, NewT, A1C),
246 arg(A2Pos, NewT, A2C),
247 assert(dcg_extend_cache(CopT, A1C, A2C, NewT)),
248 OldT = CopT,
249 A1C = A1,
250 A2C = A2,
251 extended_pos(P0, P).
252
253copy_args(I, Arity, Old, New) :-
254 I =< Arity,
255 !,
256 arg(I, Old, A),
257 arg(I, New, A),
258 I2 is I + 1,
259 copy_args(I2, Arity, Old, New).
260copy_args(_, _, _, _).
261
262
263 266
267extended_pos(Pos0, Pos) :-
268 '$expand':extended_pos(Pos0, 2, Pos).
269f2_pos(Pos0, A0, B0, Pos, A, B) :- '$expand':f2_pos(Pos0, A0, B0, Pos, A, B).
270f1_pos(Pos0, A0, Pos, A) :- '$expand':f1_pos(Pos0, A0, Pos, A).
276dcg_bt_pos(Var, Var) :-
277 var(Var),
278 !.
279dcg_bt_pos(brace_term_position(F,T,P0),
280 term_position(F,T,F,F,
281 [ P0,
282 term_position(T,T,T,T,_)
283 ])) :- !.
284dcg_bt_pos(Pos, _) :-
285 expected_layout(brace_term, Pos).
286
287dcg_cut_pos(Var, Var) :-
288 var(Var),
289 !.
290dcg_cut_pos(F-T, term_position(F,T,F,T,
291 [ F-T,
292 term_position(T,T,T,T,_)
293 ])).
294dcg_cut_pos(Pos, _) :-
295 expected_layout(atomic, Pos).
299dcg_terminal_pos(Pos, _) :-
300 var(Pos),
301 !.
302dcg_terminal_pos(list_position(F,T,_Elms,_Tail),
303 term_position(F,T,_,_,_)).
304dcg_terminal_pos(F-T,
305 term_position(F,T,_,_,_)).
306dcg_terminal_pos(Pos, _) :-
307 expected_layout(terminal, Pos).
311dcg_qualify_pos(Var, _, _) :-
312 var(Var),
313 !.
314dcg_qualify_pos(Pos,
315 term_position(F,T,FF,FT,[MP,_]),
316 term_position(F,T,FF,FT,[MP,Pos])) :- !.
317dcg_qualify_pos(_, Pos, _) :-
318 expected_layout(f2, Pos).
319
320expected_layout(Expected, Found) :-
321 '$expand':expected_layout(Expected, Found).
322
323
324
333:- meta_predicate
334 phrase(//, ?),
335 phrase(//, ?, ?),
336 call_dcg(//, ?, ?). 337:- noprofile((phrase/2,
338 phrase/3,
339 call_dcg/3)). 340:- '$iso'((phrase/2, phrase/3)). 341
342phrase(RuleSet, Input) :-
343 phrase(RuleSet, Input, []).
344phrase(RuleSet, Input, Rest) :-
345 phrase_input(Input),
346 phrase_input(Rest),
347 call_dcg(RuleSet, Input, Rest).
348
349call_dcg(RuleSet, Input, Rest) :-
350 ( strip_module(RuleSet, M, Plain),
351 nonvar(Plain),
352 dcg_special(Plain)
353 -> dcg_body(Plain, _, q(M,M,_), S0, S, Body, _),
354 Input = S0, Rest = S,
355 call(M:Body)
356 ; call(RuleSet, Input, Rest)
357 ).
358
359phrase_input(Var) :- var(Var), !.
360phrase_input([_|_]) :- !.
361phrase_input([]) :- !.
362phrase_input(Data) :-
363 throw(error(type_error(list, Data), _)).
364
365dcg_special(S) :-
366 string(S).
367dcg_special((_,_)).
368dcg_special((_;_)).
369dcg_special((_|_)).
370dcg_special((_->_)).
371dcg_special(!).
372dcg_special({_}).
373dcg_special([]).
374dcg_special([_|_]).
375dcg_special(\+_)