2
3:- op(1001,xfy,('...')). 4:- op(1200,xfy,('--->')). 5:- op(500,fx,+). 6:- op(500,fx,-). 7
8
10
11:-thread_local tlxgproc:current_xg_module/1. 12:-thread_local tlxgproc:current_xg_filename/1. 13:-dynamic user:current_xg_pred/4. 14:-multifile user:current_xg_pred/4. 15
16
17abolish_xg(Prop):- ignore(tlxgproc:current_xg_module(M)),
18 doall((user:current_xg_pred(M,F,N,Props),member(Prop,Props),member(Prop,Props),
19 ignore((memberchk(xg_pred=P,Props),dmsg(abolising(current_xg_pred(M,F,N,Props))),predicate_property(P,number_of_clauses(NC)),flag(xg_assertions,A,A-NC))),
20 abolish(F,N),retractall(user:current_xg_pred(M,F,N,_)))).
21
22new_pred(P):- dmust(tlxgproc:current_xg_module(M)),new_pred(M,P).
23new_pred(M,P0):- functor(P0,F,A),functor(P,F,A),new_pred(M,P,F,A),!.
24
33
34new_pred(M,_,F,A):- user:current_xg_pred(M,F,A,_),!.
35new_pred(_,P,_,_):- recorded(P,'xg.pred',_), !.
36new_pred(M,P,F,A) :-
37 share_mp(M:F/A),
38 findall(K=V,(((K=xg_source,tlxgproc:current_xg_filename(V));(prolog_load_context(K,V),not(member(K,[stream,directory,variable_names])));((seeing(S),member(G,[(K=file,P=file_name(V)),(K=position,P=position(V))]),G,stream_property(S,P))))),Props),
39 assert_if_new(user:current_xg_pred(M,F,A,[xg_source=F,xg_ctx=M,xg_fa=(F/A),xg_pred=P|Props])),
40 recordz(P,'xg.pred',_),
41 recordz('xg.pred',P,_).
42
43is_file_ext(Ext):-prolog_load_context(file,F),file_name_extension(_,Ext,F).
44:-thread_local tlxgproc:do_xg_process_te/0. 45:-export(xg_process_te_clone/5). 46
47processing_xg :- is_file_ext(xg),!.
48processing_xg :- tlxgproc:do_xg_process_te,!.
49
50xg_process_te_clone(L,R,_Mode,P,Q):- expandlhs(L,S0,S,H0,H,P), expandrhs(R,S0,S,H0,H,Q). 51
52:-export(xg_process_te_clone/3). 53xg_process_te_clone((H ... T --> R),Mode,((P :- Q))) :- !, xg_process_te_clone((H ... T),R,Mode,P,Q).
54xg_process_te_clone((L --> R),Mode,((P :- Q))) :- !,xg_process_te_clone(L,R,Mode,P,Q).
55xg_process_te_clone((L ---> R),Mode,((P :- Q))) :- !,xg_process_te_clone(L,R,Mode,P,Q).
56
57chat80_term_expansion(In,Out):- compound(In),functor(In,'-->',_),trace, dmust(xg_process_te_clone(In,+,Out)).
58chat80_term_expansion((H ... T ---> R),((P :- Q))) :- dmust( xg_process_te_clone((H ... T),R,+,P,Q)).
59chat80_term_expansion((L ---> R), ((P :- Q))) :- dmust(xg_process_te_clone(L,R,+,P,Q)).
60
61
62chat80_term_expansion_now(( :- _) ,_ ):-!,fail.
63chat80_term_expansion_now(H,':-'(ain(O))):- trace, chat80_term_expansion(H,O),!.
64
65xgproc:term_expansion(H, O):- processing_xg->chat80_term_expansion_now(H,O).
66
75
76load_plus_xg_file(CM,F) :- fail,
77 locally(tlxgproc:current_xg_module(CM),
78 locally(tlxgproc:do_xg_process_te,CM:ensure_loaded_no_mpreds(F))),!.
80load_plus_xg_file(CM,F) :-
81 see(user),
82 locally(tlxgproc:current_xg_module(CM),consume0(F,+)),
83 seen.
84
86load_minus_xg_file(CM,F) :-
87 see(user),
88 locally(tlxgproc:current_xg_module(CM),consume0(F,-)),
89 seen.
90
92statistics_heap(H,0):- statistics(clauses,H).
93
94consume0(F,Mode) :-
95 seeing(Old),
96 statistics_heap(H0,Hf0),
97 see(F),
98 tidy_consume(F,Mode),
99 ( (seeing(User)-> User=user), !; seen ),
100 see(Old),
101 statistics_heap(H,Hf),
102 U is H-Hf-H0+Hf0,
103 ttynl,
104 display('** Grammar from file '),
105 display(F),
106 display(' : '),
107 display(U),
108 display(' words **'),
109 ttynl, ttynl.
110
111tidy_consume(F,Mode) :-
112 consume(F,Mode),
113 fail.
114tidy_consume(_,_).
115
116consume(F,Mode) :-
117 flag(read_terms,_,0),
118 repeat,
119 read(X),
120 ( (X=end_of_file, !, xg_complete(F));
121 ((flag(read_terms,T,T+1),xg_process(X,Mode)),
122 fail )).
123
124xg_process((L ---> R),Mode) :- !,
125 expandlhs(L,S0,S,H0,H,P),
126 expandrhs(R,S0,S,H0,H,Q),
127 new_pred(P),
128 usurping(Mode,P),
129 xg_assertz((P :- Q)), !.
130xg_process(( :- G),_) :- !,
131 call_u(G).
132xg_process((P :- Q),Mode) :-
133 usurping(Mode,P),
134 new_pred(P),
135 xg_assertz((P :- Q)).
136xg_process(P,Mode) :-
137 usurping(Mode,P),
138 new_pred(P),
139 xg_assertz(P).
140
141xg_assertz(P):- flag(xg_assertions,A,A+1),dmust((tlxgproc:current_xg_module(M),nop(dmsg(M:xg_assertz(P))),M:assertz(P))),!.
142
143xg_erase_safe(_,H):- erase(H).
144
145xg_complete(_F) :-
146 recorded('xg.usurped',P,R0), xg_erase_safe(recorded('xg.usurped',P,R0),R0),
147 recorded(P,'xg.usurped',R1), xg_erase_safe(recorded(P,'xg.usurped',R1),R1),
148 fail.
149xg_complete(F):- flag(read_terms,T,T),dmsg(info(read(T,F))),nl,nl.
150
151usurping(+,_) :- !.
152usurping(-,P) :-
153 recorded(P,'xg.usurped',_), !.
154usurping(-,P) :-
155 functor(P,F,N),
156 functor(Q,F,N),
157 retractrules(Q),
158 recordz(Q,'xg.usurped',_),
159 recordz('xg.usurped',Q,_).
160
161retractrules(Q) :-
162 clause(Q,B),
163 retractrule(Q,B),
164 fail.
165retractrules(_).
166
167retractrule(_,virtual(_,_,_)) :- !.
168retractrule(Q,B) :- retract((Q :- B)), !.
169
170
172
173expandlhs(T,S0,S,H0,H1,Q) :-
174 xg_flatten0(T,[P|L],[]),
175 front(L,H1,H),
176 tag(P,S0,S,H0,H,Q).
177
178xg_flatten0(X,L0,L) :- nonvar(X),!,
179 xg_flatten(X,L0,L).
180xg_flatten0(_,_,_) :-
181 ttynl,
182 display('! Variable as a non-terminal in the lhs of a grammar rule'),
183 ttynl,
184 fail.
185
186xg_flatten((X...Y),L0,L) :- !,
187 xg_flatten0(X,L0,[gap|L1]),
188 xg_flatten0(Y,L1,L).
189xg_flatten((X,Y),L0,L) :- !,
190 xg_flatten0(X,L0,[nogap|L1]),
191 xg_flatten0(Y,L1,L).
192xg_flatten(X,[X|L],L).
193
194front([],H,H).
195front([K,X|L],H0,H) :-
196 case(X,K,H1,H),
197 front(L,H0,H1).
198
199case([T|Ts],K,H0,x(K,terminal,T,H)) :- !,
200 unwind(Ts,H0,H).
201case(Nt,K,H,x(K,nonterminal,Nt,H)) :- virtualrule(Nt).
202
203
204virtualrule(X) :-
205 functor(X,F,N),
206 functor(Y,F,N),
207 tag(Y,S,S,Hx,Hy,P),
208 ( clause(P,virtual(_,_,_)), !;
209 new_pred(P),
210 asserta((P :- virtual(Y,Hx,Hy))) ).
211
212expandrhs(X,S0,S,H0,H,Y) :- var(X),!,
213 tag(X,S0,S,H0,H,Y).
214expandrhs((X1,X2),S0,S,H0,H,Y) :- !,
215 expandrhs(X1,S0,S1,H0,H1,Y1),
216 expandrhs(X2,S1,S,H1,H,Y2),
217 and(Y1,Y2,Y).
218expandrhs((X1;X2),S0,S,H0,H,(Y1;Y2)) :- !,
219 expandor(X1,S0,S,H0,H,Y1),
220 expandor(X2,S0,S,H0,H,Y2).
221expandrhs({X},S,S,H,H,X) :- !.
222expandrhs(L,S0,S,H0,H,G) :- islist(L), !,
223 expandlist(L,S0,S,H0,H,G).
224expandrhs(X,S0,S,H0,H,Y) :-
225 tag(X,S0,S,H0,H,Y).
226
227expandor(X,S0,S,H0,H,Y) :-
228 expandrhs(X,S0a,S,H0a,H,Ya),
229 ( S\==S0a, !, S0=S0a, Yb=Ya; and(S0=S0a,Ya,Yb) ),
230 ( H\==H0a, !, H0=H0a, Y=Yb; and(H0=H0a,Yb,Y) ).
231
232expandlist([],S,S,H,H,true).
233expandlist([X],S0,S,H0,H,terminal(X,S0,S,H0,H) ) :- !.
234expandlist([X|L],S0,S,H0,H,(terminal(X,S0,S1,H0,H1),Y)) :-
235 expandlist(L,S1,S,H1,H,Y).
236
237tag(P,A1,A2,A3,A4,QQ) :- var(P),!,
238 QQ = phraseXG(P,A1,A2,A3,A4).
239
240tag(P,A1,A2,A3,A4,Q) :-
241 P=..[F|Args0],
242 conc_gx(Args0,[A1,A2,A3,A4],Args),
243 Q=..[F|Args].
244
245and(true,P,P) :- !.
246and(P,true,P) :- !.
247and(P,Q,(P,Q)).
248
249islist([_|_]).
250islist([]).
251
252unwind([],H,H) :- !.
253unwind([T|Ts],H0,x(nogap,terminal,T,H)) :-
254 unwind(Ts,H0,H).
255
256
257conc_gx([],L,L) :- !.
258conc_gx([X|L1],L2,[X|L3]) :-
259 conc_gx(L1,L2,L3).
260
261
262xg_listing(File) :-
263 telling(Old),
264 tell(File),
265 list_clauses,
266 told,
267 tell(Old).
268
271compile_xg_clauses :- !.
274
275list_clauses :-
276 recorded('xg.pred',P,_),
277 functor(P,F,N),
278 listing(F/N),
279 nl,
280 fail.
281list_clauses.
282
283:-export(load_xg/0). 284
285load_xg:-
286 load_plus_xg_file(parser_chat80,'clone.xg'),
287 load_plus_xg_file(parser_chat80,'lex.xg'),
288 compile_xg_clauses.
289
290go_xg :- load_xg, xg_listing('newg.pl')