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