|
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 %% Tokio to Prolog compiler
|
|
|
11 %%
|
|
|
12 %% variable classification and head compile
|
|
|
13 %%
|
|
|
14 %%
|
|
|
15 %% Sat Jan 11 11:31:10 JST 1986
|
|
|
16 %% $Header$
|
|
|
17
|
|
|
18 c_equate(EE,EE) :-!.
|
|
|
19 c_equate('$CNT'(EE),EE) :-!.
|
|
|
20 c_equate(EE,'$CNT'(EE)) :-!.
|
|
|
21
|
|
|
22 %% variable separation for temporality
|
|
|
23
|
|
|
24 c_seperate(Var,Now,Next) :- Var = '$TMP'(_,Now,Next),!.
|
|
|
25 c_seperate(Var,Var,'$CNT'(Var1)) :- Var = '$CNT'(Var1),!.
|
|
|
26 c_seperate(Var,Now,Next) :- Var = '$NOW'(Var1,Now),!,
|
|
|
27 c_seperate(Var1,Now,Next).
|
|
|
28 c_seperate(Var,Now,Next) :- Var = '$NXT'(Var1,Next),!,
|
|
|
29 c_seperate(Var1,Now,Next).
|
|
|
30 c_seperate(Atomic,Atomic,Atomic) :- atomic(Atomic),!.
|
|
|
31 c_seperate(Op, Op1, Op2) :-
|
|
|
32 functor(Op, H, N),functor(Op1, H, N),functor(Op2, H, N),
|
|
|
33 c_seperate_arg(0, N, Op, Op1, Op2).
|
|
|
34
|
|
|
35 c_seperate_arg(N, N, _, _, _) :- !.
|
|
|
36 c_seperate_arg(M, N, Op, Op1, Op2) :-
|
|
|
37 M1 is M+1,arg(M1, Op, A), arg(M1, Op1, A1),arg(M1, Op2, A2),
|
|
|
38 c_seperate(A,A1,A2),
|
|
|
39 c_seperate_arg(M1, N, Op, Op1, Op2).
|
|
|
40
|
|
|
41
|
|
|
42 c_seperate_now(Var,Now) :- Var = '$NOW'(_,Now),!.
|
|
|
43 c_seperate_now(Var,Var) :- Var = '$CNT'(_Var1),!.
|
|
|
44 c_seperate_now(Var,Now) :- Var = '$TMP'(_,Now,_Next),!.
|
|
|
45 c_seperate_now(Var,Now) :- Var = '$NXT'(Var1,Next),!,
|
|
|
46 c_seperate(Var1,Now,Next).
|
|
|
47 c_seperate_now(Atomic,Atomic) :- atomic(Atomic),!.
|
|
|
48 c_seperate_now(Op, Op1) :-
|
|
|
49 functor(Op, H, N),functor(Op1, H, N),
|
|
|
50 c_seperate_now_arg(0, N, Op, Op1).
|
|
|
51
|
|
|
52 c_seperate_now_arg(N, N, _, _) :- !.
|
|
|
53 c_seperate_now_arg(M, N, Op, Op1) :-
|
|
|
54 M1 is M+1,arg(M1, Op, A), arg(M1, Op1, A1),
|
|
|
55 c_seperate_now(A,A1),
|
|
|
56 c_seperate_now_arg(M1, N, Op, Op1).
|
|
|
57
|
|
|
58 c_seperate_next(Var,Next) :- Var = '$NXT'(_,Next),!.
|
|
|
59 c_seperate_next(Var,'$CNT'(Var1)) :- Var = '$CNT'(Var1),!.
|
|
|
60 c_seperate_next(Var,Next) :- Var = '$TMP'(_,_Now,Next),!.
|
|
|
61 c_seperate_next(Var,Next) :- Var = '$NOW'(Var1,Now),!,
|
|
|
62 c_seperate(Var1,Now,Next).
|
|
|
63 c_seperate_next(Atomic,Atomic) :- atomic(Atomic),!.
|
|
|
64 c_seperate_next(Op, Op1) :-
|
|
|
65 functor(Op, H, N),functor(Op1, H, N),
|
|
|
66 c_seperate_next_arg(0, N, Op, Op1).
|
|
|
67
|
|
|
68 c_seperate_next_arg(N, N, _, _) :- !.
|
|
|
69 c_seperate_next_arg(M, N, Op, Op1) :-
|
|
|
70 M1 is M+1,arg(M1, Op, A), arg(M1, Op1, A1),
|
|
|
71 c_seperate_next(A,A1),
|
|
|
72 c_seperate_next_arg(M1, N, Op, Op1).
|
|
|
73
|
|
|
74 % c_unify(Original_argument, Generated_argument, Unification_code, ItsBase,
|
|
|
75 % Level).
|
|
|
76 % Tokio has same problem as ghc. f(X,X) must be comipled into
|
|
|
77 % f(X, Y) :- unify(X, Y).
|
|
|
78 c_unify(X, Y, Q, Q, _) :-
|
|
|
79 var(X), !, X= '$REF'(Y). % mark X as "used!"
|
|
|
80 c_unify('$REF'(X), Y, (unifyAll(X, Y),Q), Q, _) :- !.
|
|
|
81 % c_unify('$CNT'(X), X, Q, Q, _) :- !.
|
|
|
82 c_unify('$CNT'(X), Y, (uconst(Y,X),Q), Q, _) :- !.
|
|
|
83 c_unify('$TMP'(Org,Now,Next), Org1, Q1, Q, L) :- !,
|
|
|
84 c_nownext(Org, Org1, Now, Next, Q1, Q, L).
|
|
|
85 c_unify('$NOW'(Org,Now), Org1, Q1, Q, L) :- !,
|
|
|
86 c_now(Org, Org1, Now, Q1, Q, L).
|
|
|
87 c_unify('$NXT'(Org,Next), Org1, Q1, Q, L) :- !,
|
|
|
88 c_next(Org, Org1, Next, Q1, Q, L).
|
|
|
89 c_unify([], X, (unil(X),Q), Q, _) :- !.
|
|
|
90 c_unify(A, X, (uatom(X, A),Q), Q, _) :- atomic(A), !.
|
|
|
91 c_unify(X, Y, (unifyAll(X, Y),Q), Q, 0) :- !. % Stop expansion at given level
|
|
|
92 c_unify([H|T], X, (ulist(X, H0, T0), Q1), Q, L) :- !,
|
|
|
93 L1 is L-1, c_unify(H, H0, Q1, Q2, L1),
|
|
|
94 c_unify(T, T0, Q2, Q, L1).
|
|
|
95 c_unify(S, X, Q1, Q, L) :- % compile unification
|
|
|
96 functor(S, F, A), A < 4, !, functor(S0, F, A),
|
|
|
97 make_skel_name(F, Us, A),
|
|
|
98 c_skel(Us, S0, X, F, A, Q1, Q2, L),
|
|
|
99 L1 is L-1,
|
|
|
100 c_unify_args(0, A, S, S0, Q2, Q, L1).
|
|
|
101 c_unify(S, X, (uskel(X, S0), Q1), Q, L) :- !,
|
|
|
102 L1 is L-1, functor(S, F, A), functor(S0, F, A),
|
|
|
103 c_unify_args(0, A, S, S0, Q1, Q, L1).
|
|
|
104
|
|
|
105 c_unify_args(N, N, _, _, Q, Q, _) :- !.
|
|
|
106 c_unify_args(K, N, S, X, Q1, Q, L) :-
|
|
|
107 K1 is K+1, arg(K1, S, SK), arg(K1, X, XK),
|
|
|
108 c_unify(SK, XK, Q1, Q2, L),
|
|
|
109 c_unify_args(K1, N, S, X, Q2, Q, L).
|
|
|
110
|
|
|
111 % compile skelton unifications
|
|
|
112 %
|
|
|
113 % f(_,_,_) ---> 'r_f3'
|
|
|
114
|
|
|
115 make_skel_name(F, U, A) :-
|
|
|
116 name(A, AL), name(F, FL),
|
|
|
117 % concatenate(["'r_",FL,AL,"'"], UL),
|
|
|
118 concatenate(["r_",FL,AL], UL), %%%%%%%%%%%%%%%%%
|
|
|
119 name(U, UL).
|
|
|
120
|
|
|
121 concatenate([],[]).
|
|
|
122 concatenate([H|T],X) :- concatenate(T,X1),append(H,X1,X).
|
|
|
123
|
|
|
124 c_skel(U, S, X, _F, A, (Uc,Q), Q, _L) :- recorded('$uskel',U,_),!,
|
|
|
125 A1 is A+1, functor(Uc, U, A1),
|
|
|
126 arg(1, Uc, X),
|
|
|
127 c_skel_copy_arg(0, 1, A1, S, Uc).
|
|
|
128 c_skel(U, S, X, F, A, (Uc,Q), Q, _L) :- recordz('$uskel',U,_),!,
|
|
|
129 A1 is A+1, functor(Uc, U, A1),
|
|
|
130 arg(1, Uc, X),
|
|
|
131 c_skel_copy_arg(0, 1, A1, S, Uc),
|
|
|
132 functor(U1, U, A1), functor(Us, F, A),
|
|
|
133 c_skel_copy_arg(0, 1, A1, Us, U1),
|
|
|
134 arg(1, U1, Us),
|
|
|
135 write_clause((U1 :- !)),
|
|
|
136 functor(U2, U, A1), functor(Us2, F, A), functor(Un, U, A1),
|
|
|
137 c_skel_copy_arg_tmp(0, 1, A1, Us2, U2, Un),
|
|
|
138 arg(1, U2, '$t'(Us2, N)),
|
|
|
139 arg(1, Un, N),
|
|
|
140 write_clause((U2 :- Un)).
|
|
|
141
|
|
|
142
|
|
|
143 c_skel_copy_arg(_L, N, N, _A, _B) :- !.
|
|
|
144 c_skel_copy_arg(L, N, M, A, B) :-
|
|
|
145 L1 is L+1, N1 is N+1,
|
|
|
146 arg(L1, A, Arg), arg(N1, B, Arg),
|
|
|
147 c_skel_copy_arg(L1, N1, M, A, B).
|
|
|
148
|
|
|
149 c_skel_copy_arg_tmp(_L, N, N, _A, _B, _C) :- !.
|
|
|
150 c_skel_copy_arg_tmp(L, N, M, A, B, C) :-
|
|
|
151 L1 is L+1, N1 is N+1,
|
|
|
152 arg(L1, A, Now), arg(N1, B, '$t'(Now,Next)), arg(N1, C, Next),
|
|
|
153 c_skel_copy_arg_tmp(L1, N1, M, A, B, C).
|
|
|
154 % optimiser check variables
|
|
|
155 % now only referenced unifyNow
|
|
|
156 % next only referenced unifyNext
|
|
|
157 % both referenced unifyNowNext
|
|
|
158 %
|
|
|
159 % if already referenced then product unifyAll code
|
|
|
160 %
|
|
|
161 % c_now/next(Org, Modyfied, Now/Next, Q1, Q),
|
|
|
162
|
|
|
163 c_nownext(Org, Org1, Now, Next, (unifyNowNext(Org1,Now,Next1),Q1), Q, L) :-
|
|
|
164 var(Org),!,Org = '$REF'(Org1),
|
|
|
165 c_unify(Next,Next1, Q1, Q, L).
|
|
|
166 c_nownext('$REF'(O2), O, _Now, _Next, (unifyAll(O2,O),Q), Q, _L).
|
|
|
167
|
|
|
168 c_now(Var, Var1, Now, (unifyNow(Var1,Now), Q), Q, _L) :- var(Var),!,
|
|
|
169 Var = '$REF'(Var1).
|
|
|
170 c_now('$REF'(O2), O, _Now, (unifyAll(O2,O),Q), Q, _L) :- !.
|
|
|
171 c_now('$TMP'(O,Now,Next), O1, Now, Q, Q1, L) :-
|
|
|
172 c_nownext(O, O1, Now, Next, Q, Q1, L).
|
|
|
173
|
|
|
174 c_next(Var, Var, Next, (unifyNext(Var1,Next1), Q), Q1, L) :- var(Var),!,
|
|
|
175 Var = '$REF'(Var1),
|
|
|
176 c_unify(Next,Next1, Q, Q1, L).
|
|
|
177 c_next('$REF'(O2), O, _Next, (unifyAll(O2,O),Q), Q, _L) :- !.
|
|
|
178 c_next('$TMP'(O,Now,Next), O1, Next, Q, Q1, L) :-
|
|
|
179 c_nownext(O, O1, Now, Next, Q, Q1, L).
|
|
|
180
|
|
|
181
|
|
|
182 % c_opt(Before, After, Optimized_or_not)
|
|
|
183 c_opt(X,X,0) :- var(X),!.
|
|
|
184 c_opt((true, X), Y, 1) :- !, c_opt(X, Y, _).
|
|
|
185 c_opt((X0, true), X, 1) :- !, c_opt(X0, X, _).
|
|
|
186 c_opt((X0, Y0), R, C) :- !,
|
|
|
187 c_opt(X0, X1, CX), c_opt(Y0, Y1, CY), C0 is CX\/CY,
|
|
|
188 ( C0 =:= 0, !, C is C0, R = (X1, Y1);
|
|
|
189 c_opt((X1, Y1), R, C) ). % X1/Y1 may be optimized to 'true'
|
|
|
190 c_opt(X, X, 0).
|
|
|
191
|
|
|
192 /* end of compiler */
|
