|
0
|
1 /*
|
|
|
2 Copyright (C) 1988,2005, Shinji Kono
|
|
|
3 Everyone is permitted to copy and distribute verbatim copies
|
|
|
4 of this license, but changing it is not allowed. You can also
|
|
|
5 use this wording to make the terms for other programs.
|
|
|
6
|
|
|
7 send your comments to kono@ie.u-ryukyu.ac.jp
|
|
|
8 */
|
|
|
9
|
|
|
10 /*
|
|
|
11 Tokio preprosessor
|
|
|
12 Thu Aug 22 15:52:08 JST 1985
|
|
|
13 Wed Sep 4 16:07:39 JST 1985
|
|
|
14 $Header$
|
|
|
15
|
|
|
16 use 'r_prepr' record to generate new predicate
|
|
|
17
|
|
|
18 */
|
|
|
19
|
|
|
20 read_macro( (A '$clause' B) ) :- !,recordz('r_prepr',(A,B),_).
|
|
|
21 read_macro( A ) :- recordz('r_prepr',(A,true),_).
|
|
|
22
|
|
|
23 read_function( (A '$clause' B ) ) :- !,recordz('r_func',(A,B),_).
|
|
|
24 read_function( A ) :- recordz('r_func',(A,true),_).
|
|
|
25
|
|
|
26 reset_macro :- recorda('r_tmp',0,_),fail.
|
|
|
27 reset_macro :- recorded('r_prepr', X, R), check_init(X),
|
|
|
28 erase(R), fail.
|
|
|
29 reset_macro :- recorded('r_func', X, R), check_init(X),
|
|
|
30 erase(R), fail.
|
|
|
31 reset_macro.
|
|
|
32
|
|
|
33 check_init(('r_initr_',true)) :- !,recorded('r_tmp',_,Ref),erase(Ref),fail.
|
|
|
34 check_init(_) :- recorded('r_tmp',_,_),!,fail.
|
|
|
35 check_init(_).
|
|
|
36
|
|
|
37
|
|
|
38 preprocess((X,Y),(XX,YY)) :- !,preprocess(X,XX),preprocess(Y,YY).
|
|
|
39 % preprosess(( :- X),( :- X) ) :- !.
|
|
|
40 preprocess((H :- B), OUT) :- !,
|
|
|
41 functor(H,HH,NN),
|
|
|
42 (recorded('$mnum',(HH,NN,N),R),erase(R) ; N = 0),!,
|
|
|
43 functor(H1,HH,NN),
|
|
|
44 develop_args(0, NN, N, N1, H, H, H1, OUT1, (H1 :- B0),B0,BB),
|
|
|
45 develop(B, BB, H, N1, N2, OUT, OUT1),
|
|
|
46 recordz('$mnum',(HH,NN,N2),_).
|
|
|
47 preprocess(H,H1) :- preprocess((H :- true),H1).
|
|
|
48
|
|
|
49 /*
|
|
|
50 develop(Original, Head, Base, NextBase, Qhead, Qtail).
|
|
|
51
|
|
|
52 */
|
|
|
53
|
|
|
54
|
|
|
55 develop(A,'tokio_call'(A),_H,N,N,Q,Q) :- var(A),!.
|
|
|
56 develop((A,B),(AA,BB),H,N,N1,Q,Q1) :- !,
|
|
|
57 develop(A,AA,H,N,N2,Q,Q2),
|
|
|
58 develop(B,BB,H,N2,N1,Q2,Q1).
|
|
|
59 develop(@(A),@(AA),H,N,N1,Q,Q1) :- !,
|
|
|
60 develop(A,AA,H,N,N1,Q,Q1).
|
|
|
61 develop(next(A),next(AA),H,N,N1,Q,Q1) :- !,
|
|
|
62 develop(A,AA,H,N,N1,Q,Q1).
|
|
|
63 develop(ifEmpty(A),ifEmpty(AA),H,N,N1,Q,Q1) :- !,
|
|
|
64 develop(A,AA,H,N,N1,Q,Q1).
|
|
|
65 develop(ifNotEmpty(A),ifNotEmpty(AA),H,N,N1,Q,Q1) :- !,
|
|
|
66 develop(A,AA,H,N,N1,Q,Q1).
|
|
|
67 develop((A & B),'$chop'(AA,BBB),H,N,N1,Q3,Q1) :- !,
|
|
|
68 copyv(A,Acopy,V,Vcopy),(
|
|
|
69 V = [],
|
|
|
70 develop(A,AA,H,N,N2,Q,Q2),!
|
|
|
71 ;
|
|
|
72 length(V,VN),VN>8,!,
|
|
|
73 develop(( 'r_eq'(V,Vcopy),Acopy ) ,AA,H,N,N2,Q,Q2)
|
|
|
74 ;
|
|
|
75 V=[V1],Vcopy=[Vc1],!,
|
|
|
76 develop(( 'r_eq'(V1,Vc1),Acopy ) ,AA,H,N,N2,Q,Q2)
|
|
|
77 ;
|
|
|
78 V=[V1,V2],Vcopy=[Vc1,Vc2],!,
|
|
|
79 develop(( 'r_eq'(V1,Vc1),'r_eq'(V2,Vc2),Acopy ) ,AA,H,N,N2,Q,Q2)
|
|
|
80 ;
|
|
|
81 V=[V1,V2,V3],Vcopy=[Vc1,Vc2,Vc3],!,
|
|
|
82 develop(( 'r_eq'(V1,Vc1),'r_eq'(V2,Vc2),'r_eq'(V3,Vc3),
|
|
|
83 Acopy ) ,AA,H,N,N2,Q,Q2)
|
|
|
84 ;
|
|
|
85 develop(( #(V=Vcopy),Acopy ) ,AA,H,N,N2,Q,Q2)),!,
|
|
|
86 develop(B,BB,H,N2,N3,Q2,Q1),!,
|
|
|
87 ( var(BB), !, Q3 = Q, BBB = B, N1 = N3
|
|
|
88 ; get_variable(BB,Vlist,[],_,0,_Vcount),
|
|
|
89 new_head(H,BBB,N3,Vlist), % necessary to reduce variable copy..
|
|
|
90 N1 is N3+1,
|
|
|
91 Q3 = ((BBB :- BB),Q)),!.
|
|
|
92 % single time funcitons
|
|
|
93 develop(A:=B, true, _Root, M, M, Q, Q) :-
|
|
|
94 (A \= *('$CNT'(_)),A \= *(_); var(A)) ,!,
|
|
|
95 c_error((write('assign to non static:'),write(A:=B),nl)).
|
|
|
96 % <= use current value for addressing
|
|
|
97 develop(A<==B, true, _Root, M, M, Q, Q) :-
|
|
|
98 (A \= *_,A \= [_|_]; var(A)) ,!,
|
|
|
99 c_error((write('assign to non static:'),write(A<==B),nl)).
|
|
|
100 develop(*A<==B, C, Root, M, M1, Q, Q1) :- !,
|
|
|
101 d_function(A, AA, M, M2, Root, Q, Q2, C, C2),
|
|
|
102 d_function(B, BB, M2,M1, Root, Q2,Q1, C2,
|
|
|
103 ('$CNT'(YY)=AA,'$CNT'(VV)=BB, 'r_assign'('$CNT'(YY),'$CNT'(VV)))).
|
|
|
104 % develop(*A<=B, C, Root, M, M1, Q, Q1) :- atomic(A),!,
|
|
|
105 % d_function(B, BB, M,M1, Root, Q,Q1, C, 'r_assign'(A,'$CNT'(BB))).
|
|
|
106 develop(*('$CNT'(A)):=B, C, Root, M, M1, Q, Q1) :- !,
|
|
|
107 d_function(A, AA, M, M2, Root, Q, Q2, C2, *('$CNT'(AA)):=BB),!,
|
|
|
108 d_function(B, BB, M2,M1, Root, Q2,Q1, C, C2).
|
|
|
109 develop(*A:=B, C, Root, M, M1, Q, Q1) :- !,
|
|
|
110 d_function(A, AA, M, M2, Root, Q, Q2, C2, *AA:=BB),!,
|
|
|
111 d_function(B, BB, M2,M1, Root, Q2,Q1, C, C2).
|
|
|
112 develop(A=B, C, Root, M, M1, Q, Q1) :- !,
|
|
|
113 d_function(A, AA, M, M2, Root, Q, Q2, C2, AA=BB),!,
|
|
|
114 d_function(B, BB, M2,M1, Root, Q2,Q1, C, C2).
|
|
|
115 develop(A<B, C, Root, M, M1, Q, Q1) :- !,
|
|
|
116 d_function(A, AA, M, M2, Root, Q, Q2, C2, AA<BB),!,
|
|
|
117 d_function(B, BB, M2,M1, Root, Q2,Q1, C, C2).
|
|
|
118 develop(A>B, C, Root, M, M1, Q, Q1) :- !,
|
|
|
119 d_function(A, AA, M, M2, Root, Q, Q2, C2, AA>BB),!,
|
|
|
120 d_function(B, BB, M2,M1, Root, Q2,Q1, C, C2).
|
|
|
121 % full time functions
|
|
|
122 develop(A,AAA,Root,N,N1,Q,Q1) :-
|
|
|
123 recorded('r_prepr', ((A :- AA),Body),_),!,
|
|
|
124 develop_macro(Body,A,AA,AAA,Root,N,N1,Q,Q1).
|
|
|
125 develop(A, C, Root, M, M1, Q, Q1) :- functor(A,H,N),functor(AA,H,N),
|
|
|
126 develop_args(0, N, M, M1, Root, A, AA, Q, Q1, C, AA).
|
|
|
127
|
|
|
128 develop_args(N , N, M, M , _Root, _A, _AA, Q, Q, C, C) :- !.
|
|
|
129 develop_args(N1, N, M, M1, Root, A, AA, Q, Q1, C, C1) :-
|
|
|
130 N2 is N1+1, arg(N2,A,B), arg(N2,AA,BB),
|
|
|
131 d_function(B, BB, M, M2, Root, Q, Q2, C, C2),!, %%% check full time here?
|
|
|
132 develop_args(N2, N, M2, M1, Root, A, AA, Q2, Q1, C2, C1).
|
|
|
133
|
|
|
134 develop_macro(true,_A,AA,AAA,Root,N,N1,Q,Q1) :- !,
|
|
|
135 develop(AA,AAA,Root,N,N1,Q,Q1).
|
|
|
136 develop_macro(Body,A,AA,AAA,Root,N,N1,Q,Q2) :-
|
|
|
137 get_variable(A,Vlist,[],_,0,_Vcount),
|
|
|
138 macro(Body, Root, N, N2, Vlist, Q, Q1),
|
|
|
139 develop(AA,AAA,Root,N2,N1,Q1,Q2),!.
|
|
|
140
|
|
|
141 /* make original head
|
|
|
142
|
|
|
143 Root head
|
|
|
144 New head
|
|
|
145 uniq Id
|
|
|
146 variable list
|
|
|
147 */
|
|
|
148
|
|
|
149 new_head(Root,New,No,Vlist) :-
|
|
|
150 new_head(Root,New,No,Vlist,_,T,T).
|
|
|
151
|
|
|
152 new_head(Root,New,No,Vlist,large,T,T1) :-
|
|
|
153 length(Vlist,N),N>10,!,
|
|
|
154 [A,B,C|T] = Vlist,
|
|
|
155 functor(Root,HH,Arity),
|
|
|
156 name(HH,HL),name(No,NL),name(Arity,NAL),
|
|
|
157 concatenate(["r_",NL,HL,NAL],NewL),
|
|
|
158 name(NewH,NewL),
|
|
|
159 New =.. [NewH,A,B,C,T1].
|
|
|
160 new_head(Root,New,No,Vlist,small,_,_) :- functor(Root,HH,A),
|
|
|
161 name(HH,HL),name(No,NL),name(A,NAL),
|
|
|
162 concatenate(["r_",NL,HL,NAL],NewL),
|
|
|
163 name(NewH,NewL),
|
|
|
164 New =.. [NewH|Vlist].
|
|
|
165
|
|
|
166 /* make variable list */
|
|
|
167
|
|
|
168 get_variable(H,V,V1,VL,N,N1) :-
|
|
|
169 var(H),!,
|
|
|
170 not_vmember(H,V,V1,VL,N,N1).
|
|
|
171 get_variable(H,V,V1,VL,N,N1) :-
|
|
|
172 H = '$CNT'(_),!, % inherit constant
|
|
|
173 not_vmember(H,V,V1,VL,N,N1).
|
|
|
174 get_variable(F,V,V1,VL,N,N1) :-
|
|
|
175 functor(F,_,A),
|
|
|
176 get_variable_arg(0,A,F,V, V1, VL, N,N1).
|
|
|
177
|
|
|
178 get_variable_arg(A,A,_F,V,V,_VL, N,N) :- !.
|
|
|
179 get_variable_arg(A,A1,F,V,V1,VL,N,N1) :-
|
|
|
180 A2 is A+1, arg(A2, F, Arg),
|
|
|
181 get_variable(Arg,V,V2,VL,N, N2),
|
|
|
182 get_variable_arg(A2,A1,F,V2,V1,VL,N2,N1).
|
|
|
183
|
|
|
184 not_vmember(H,[H|T],T,VL,N,N1) :- var(VL),!,VL = [H|_],N1 is N+1.
|
|
|
185 not_vmember(H, T,T,[H1|_VL],N,N) :- H == H1,!.
|
|
|
186 not_vmember(H, T,T,[H1|_VL],N,N) :- H == '$CNT'(H1),!.
|
|
|
187 not_vmember(H, T, T1,[_|VL], N, N1) :- not_vmember(H,T,T1,VL,N,N1).
|
|
|
188
|
|
|
189 /* copyv
|
|
|
190 make copy with new variables
|
|
|
191 and its old variable list and new variable list
|
|
|
192
|
|
|
193 copyv(Old, New, OldVariable, NewVariable)
|
|
|
194
|
|
|
195 a little dum algorithm
|
|
|
196 */
|
|
|
197
|
|
|
198 copyv(O,N,OV,NV) :-
|
|
|
199 get_variable(O,OV,[],_,0,_Vcount),!,
|
|
|
200 copy((O,OV),(N,NV)).
|
|
|
201
|
|
|
202 /*
|
|
|
203 macro
|
|
|
204
|
|
|
205 */
|
|
|
206
|
|
|
207
|
|
|
208 macro((A '$clause' B), Root, N, N1, Vs, Q, Q2) :- !,
|
|
|
209 single_macro(A, Root, N, N2, Vs, Q, Q1),
|
|
|
210 macro(B, Root, N2, N1, Vs, Q1, Q2).
|
|
|
211 macro(A, Root, N, N1, Vs, Q, Q1) :-
|
|
|
212 single_macro(A, Root, N, N1, Vs, Q, Q1).
|
|
|
213
|
|
|
214
|
|
|
215 single_macro(A , Root, N, N1, Vlist, (A,Q), Q) :- var(A),!,
|
|
|
216 new_head(Root,A,N,Vlist),
|
|
|
217 N1 is N+1.
|
|
|
218 single_macro((A :- B), Root, N, N2, Vlist, Q, Q2) :- !,
|
|
|
219 head_optimize(BB,A,Root,Vlist,N,N1,Q,Q1),!,
|
|
|
220 develop(B,BB,Root,N1,N2,Q1,Q2),!.
|
|
|
221 single_macro(A, _Root, N, N, _Vlist, (A,Q), Q).
|
|
|
222
|
|
|
223 head_optimize(BB,A,Root,Vlist,N,N2,((A:-BB),Q),Q) :-
|
|
|
224 var(A),
|
|
|
225 !,
|
|
|
226 new_head(Root,A,N,Vlist),
|
|
|
227 N2 is N+1.
|
|
|
228 head_optimize(BB,A,_Root,_Vlist,N,N,((A:-BB),Q),Q).
|
|
|
229
|
|
|
230 /*
|
|
|
231 functions
|
|
|
232 should be seprated full time function and
|
|
|
233 now only function
|
|
|
234 */
|
|
|
235
|
|
|
236 d_function(A,AA,N,N,_Root,Q,Q,C,C) :- var(A),!, A = AA. % not interval constant
|
|
|
237 d_function(A,R1,N,N1,Root,Q,Q1,(AAA,C1),C) :- % not interval constant
|
|
|
238 recorded('r_func', ((A = R :- AA),Body) ,_),!,
|
|
|
239 d_function(R,R1,N,N2,Root,Q2,Q1,C1,C),
|
|
|
240 d_f_dev(Body,A,AA,AAA,Root,N2,N1,Q,Q2).
|
|
|
241 d_function(cputime, '$CNT'(Value), N,N,_R,Q, Q, ('r_cputime'(Value),C),C) :- !.
|
|
|
242 d_function(A,AA,N,N,_Root,Q,Q,C,C) :- atomic(A),!, A = AA.
|
|
|
243 d_function(@A,@AA,N,N2,Root,Q,Q1,Next,C) :- !, % not interval constant
|
|
|
244 d_function(A,AA,N,N2,Root,Q,Q1,CN,true),
|
|
|
245 d_next_check(CN,Next,C).
|
|
|
246 d_function(*Name,'$CNT'(V),N,N2,Root,Q,Q1,C,C1) :- !, % not interval constant
|
|
|
247 d_function(Name,Name1,N,N2,Root,Q,Q1,C,('r_read_value'(Name1,'$CNT'(V)),C1)).
|
|
|
248 d_function(binary(B), Value, N,N,_R,Q, Q, C,C) :- !,
|
|
|
249 c_binary(B,Value),!.
|
|
|
250 d_function(hex(H), Value, N,N,_R,Q, Q, C,C) :- !,
|
|
|
251 c_hex(H,Value),!.
|
|
|
252 d_function(Exp, '$CNT'(Value), N,N1,R,Q, Q1, C,C1) :- % not interval constant
|
|
|
253 n_function(Exp,A,B,Exp1,AA,BB),!,
|
|
|
254 d_function_exp(A, AA, N,N2,R,Q, Q2,C, C2),
|
|
|
255 d_function_exp(B, BB, N2,N1,R,Q2,Q1,C2,('$CNT'(Value) is Exp1,C1)).
|
|
|
256 d_function(A,AA,N,N1,Root,Q,Q1,C,C1) :- functor(A,H,M),functor(AA,H,M),
|
|
|
257 d_function_args(0,M,A,AA,N,N1,Root,Q,Q1,C,C1),!.
|
|
|
258
|
|
|
259 d_next_check(true,C,C):-!.
|
|
|
260 d_next_check(CN,(next(CN),C),C):-!.
|
|
|
261
|
|
|
262 d_function_args(M,M,_A,_AA,N,N,_Root,Q,Q,C,C) :- !.
|
|
|
263 d_function_args(M1,M,A,AA,N,N1,Root,Q,Q1,C,C1) :-
|
|
|
264 M2 is M1+1, arg(M2,A,B), arg(M2,AA,BB),
|
|
|
265 d_function(B,BB,N,N2,Root,Q,Q2,C,C2),!,
|
|
|
266 d_function_args(M2,M,A,AA,N2,N1,Root,Q2,Q1,C2,C1),!.
|
|
|
267
|
|
|
268 d_function_exp(Exp, Exp1, N,N1,R,Q, Q1, C,C1) :- nonvar(Exp),
|
|
|
269 n_function(Exp,A,B,Exp1,AA,BB),!,
|
|
|
270 d_function_exp(A, AA, N,N2,R,Q, Q2, C,C2),
|
|
|
271 d_function_exp(B, BB, N2,N1,R,Q2, Q1, C2,C1).
|
|
|
272 d_function_exp(Exp, Exp1, N,N1,R,Q, Q1, C,C1) :-
|
|
|
273 d_function(Exp, Exp1, N,N1,R,Q, Q1, C,C1).
|
|
|
274
|
|
|
275 d_f_dev(true,_A,AA,AAA,Root,N,N1,Q,Q1) :-!,
|
|
|
276 develop(AA, AAA, Root, N, N1, Q, Q1).
|
|
|
277 d_f_dev(Body,A,AA,AAA,Root,N,N1,Q,Q1) :-
|
|
|
278 get_variable(A,Vs,[],_,0,_Vcount),!,
|
|
|
279 develop(AA, AAA, Root, N, N2, Q, Q2),!,
|
|
|
280 macro(Body, Root, N2, N1, Vs, Q2, Q1),!.
|
|
|
281
|
|
|
282 /* */
|
