Mercurial > hg > Applications > Tokio
comparison to.pl @ 0:cfb7c6b24319
Initial revision
author | kono |
---|---|
date | Thu, 30 Aug 2007 14:57:44 +0900 |
parents | |
children |
comparison
equal
deleted
inserted
replaced
-1:000000000000 | 0:cfb7c6b24319 |
---|---|
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 | |
12 Tokio compiler to prolog | |
13 Thu Aug 15 12:17:04 JST 1985 | |
14 Fri Jan 10 16:11:31 JST 1986 | |
15 Fri Sep 5 09:51:36 JST 1986 for 1.2a | |
16 Thu Mar 26 16:19:10 JST 1987 | |
17 Wed Oct 14 13:35:54 JST 1987 full time F | |
18 Fri Oct 16 11:28:26 JST 1987 Sicstus | |
19 $Header$ | |
20 compiler main routine | |
21 */ | |
22 | |
23 com(X) :- reset_macro,tokiocompile(X). | |
24 com(X,Y) :- reset_macro,tokiocompile(X, Y), | |
25 (Y = user,!;reconsult(Y)). | |
26 | |
27 tokiocompile(S) :- | |
28 tokiocompile(S, '#temp.tokio'), | |
29 % reconsult('#temp.tokio'). | |
30 compile0('#temp.tokio'). | |
31 | |
32 tokiocompile(S, O) :- | |
33 cputime(Time), | |
34 init_tokiocomp, | |
35 tell(O), | |
36 tokiocomp(S, [], _L), told, | |
37 cputime(Time1),Time0 is Time1-Time, | |
38 c_error((write('END '), nl, write(Time0), write(' sec.'),nl)). | |
39 | |
40 init_tokiocomp :- recorded('$uskel', _X, R), erase(R), fail. | |
41 init_tokiocomp :- recorded('$mnum', _X, R), erase(R), fail. | |
42 init_tokiocomp. | |
43 | |
44 tokiocomp([], L, L) :- !. | |
45 tokiocomp([H|T], L0, L) :- !, tokiocomp(H, L0, L1), tokiocomp(T, L1, L). | |
46 tokiocomp(F, _L0, _L) :- | |
47 seeing(O), nofileerrors, tokiofile(F,F1),see(F1), !, | |
48 tokiocomp1('$$$$'), seen, see(O), !. | |
49 tokiocomp(F, _, _) :- | |
50 fileerrors, | |
51 c_error((write('Cannot open file: '), write(F), nl)), !, fail. | |
52 | |
53 tokiofile(F,F). | |
54 tokiofile(F,F1) :- name(F,FL),concatenate([FL,".tokio"],NewL),name(F1,NewL). | |
55 tokiofile(F,F1) :- name(F,FL),concatenate([FL,".t"],NewL),name(F1,NewL). | |
56 | |
57 | |
58 /* tokiocomp1 | |
59 read loop (fail loop) | |
60 */ | |
61 | |
62 tokiocomp1(X) :- tokiocomp2(X). | |
63 tokiocomp1(_) :- | |
64 read(Next), !, tokiocomp1(Next). | |
65 tokiocomp1(_) :- c_error((nl,write('read error'),nl)). | |
66 | |
67 /* tokocomp2 | |
68 compiler directive | |
69 this predicate never success except file end. | |
70 */ | |
71 | |
72 tokiocomp2(end_of_file) :- !. | |
73 tokiocomp2('$$$$') :- !,fail. | |
74 tokiocomp2('$define'(Macro)) :- | |
75 read_macro(Macro),!,fail. | |
76 tokiocomp2('$function'(Function)) :- | |
77 read_function(Function),!,fail. | |
78 tokiocomp2((:- X)) :- | |
79 call(X), write_clause((:- X)),!,fail. | |
80 tokiocomp2((?- X)) :- | |
81 call(X), write_clause((:- X)),!,fail. | |
82 tokiocomp2(Head) :- compiling_message(Head),fail. | |
83 tokiocomp2(X) :- preprocess(X,X1),!,tokiocomp3(X1). | |
84 | |
85 compiling_message((Head :- _Body)) :- !,compiling_message(Head). | |
86 compiling_message(Head) :- | |
87 (systemp(Head);Head = (_,_);Head = [_|_];functor(Head,'{}',_)),!, | |
88 functor(Head,H,A), | |
89 c_error(( | |
90 write('Compiling System Predicate: '), | |
91 write(H/A),nl)),!. | |
92 compiling_message(Head) :- | |
93 functor(Head,H,A), | |
94 c_error(( | |
95 write('Compiling: '), | |
96 write(H/A),nl)),!,!. | |
97 | |
98 /* tokiocomp3 | |
99 if end_of_file then success otherwise fail | |
100 */ | |
101 | |
102 tokiocomp3((X,_Y)) :- tokiocomp3(X),fail. % fail and fall into next line | |
103 tokiocomp3((_X,Y)) :- !,tokiocomp3(Y). | |
104 tokiocomp3(X) :- | |
105 c_clause(X, C), write_clause(C),!, fail. % to reduce stack | |
106 tokiocomp3(X) :- | |
107 c_error((nl,write('compiler error on '),write(X),nl)),fail. | |
108 | |
109 % preprocess(X,X). % no development | |
110 | |
111 display_fa(F/A) :- display(F), display('/'), display(A), display(','). | |
112 | |
113 writel([]) :- !. | |
114 writel([X|L]) :- writel(L), write(X), write(', '). | |
115 | |
116 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% | |
117 % | |
118 % varialble type | |
119 % | |
120 % '$REF' full referenced variable | |
121 % '$TMP' both now and next are referenced | |
122 % '$NOW','$NXT' either now or next is referenced | |
123 % '$CNT' this variable is constnat in time transition | |
124 % | |
125 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% | |
126 | |
127 variable(X) :- var(X), !. | |
128 variable('$REF'(_)) :- !. | |
129 variable('$CNT'(_)) :- !. | |
130 variable('$NOW'(_,_)) :- !. | |
131 variable('$NXT'(_,_)) :- !. | |
132 variable('$TMP'(_,_,_)). | |
133 | |
134 | |
135 % c_post(Vname, Vname, V0, V) :- | |
136 % var(Vname),!, V is V0+1,name(V0,Lv),name(Vname,[95|Lv]). %%% _001 | |
137 c_post(Vname, Vname, V0, V) :- | |
138 var(Vname),!, V is V0+1,Vname = '$VAR'(V0). %%% _001 | |
139 c_post('$VAR'(X), '$VAR'(X), V, V) :- !. | |
140 c_post('$CNT'(X), XX, V0, V) :- !, c_post(X, XX, V0, V). | |
141 c_post('$REF'(X), XX, V0, V) :- !, c_post(X, XX, V0, V). | |
142 c_post('$TMP'(X,Now,Nxt), XX, V0, V) :- !, c_post_tvar(X,Now,Nxt, XX, V0, V). | |
143 c_post('$NOW'(X,Now), XX, V0, V) :- !, c_post_tvar(X,Now,_Nxt, XX, V0, V). | |
144 c_post('$NXT'(X,Nxt), XX, V0, V) :- !, c_post_tvar(X,_Now,Nxt, XX, V0, V). | |
145 c_post(Atomic,Qatomic,V,V) :- atomic(Atomic),!, | |
146 c_post_atomic(Atomic,Qatomic). | |
147 c_post([A|B],[AA|BB], V0, V) :- !, | |
148 c_post(A,AA,V0,V1),c_post(B,BB,V1,V). | |
149 c_post((A,B),(AA,BB), V0, V) :- !, | |
150 c_post(A,AA,V0,V1),c_post(B,BB,V1,V). | |
151 % Special Hack.... ( nonvar for C-Prolog) | |
152 c_post('r_eq'(A,B,Q1,Q2), B1=A1, V0, V) :- nonvar(A),nonvar(B), | |
153 functor(A,'$CNT',_),functor(B,'$CNT',_),!, | |
154 c_post(A,A1,V0,V1),c_post(B,B1,V1,V2), | |
155 c_post(Q1,Q11,V2,V3),c_post(Q2,Q12,V3,V),Q11=Q12. | |
156 c_post('r_eq'(A,B,Q1,Q2), 'r_eqn'(B1,A1,Q11,Q12), V0, V) :- nonvar(A), | |
157 functor(A,'$CNT',_),!, | |
158 c_post(A,A1,V0,V1),c_post(B,B1,V1,V2), | |
159 c_post(Q1,Q11,V2,V3),c_post(Q2,Q12,V3,V). | |
160 c_post('r_eq'(A,B,Q1,Q2), 'r_eqn'(A1,B1,Q11,Q12), V0, V) :- nonvar(B), | |
161 functor(B,'$CNT',_),!, | |
162 c_post(A,A1,V0,V1),c_post(B,B1,V1,V2), | |
163 c_post(Q1,Q11,V2,V3),c_post(Q2,Q12,V3,V). | |
164 c_post('r_eq'(A,B,Q1,Q2), 'r_eq'(A1,B1,Q11,Q12), V0, V) :- !, | |
165 c_post(A,A1,V0,V1),c_post(B,B1,V1,V2), | |
166 c_post(Q1,Q11,V2,V3),c_post(Q2,Q12,V3,V). | |
167 c_post(X, XX, V0, V) :- | |
168 functor(X, F, A), c_post_atomic(F,F1),!, functor(XX, F1, A), | |
169 c_post_args(0, A, X, XX, V0, V). | |
170 | |
171 c_post_atomic(X,X). | |
172 % c_post_atomic([],[]) :- !. | |
173 % c_post_atomic(Number,Number) :- number(Number),!. | |
174 % c_post_atomic(Atomic,Qatomic):- | |
175 % name(Atomic,La),La=[H|_],[H]\="'",[H]\="_",!, | |
176 % concatenate(["'",La,"'"],Nla),name(Qatomic,Nla). | |
177 % c_post_atomic(Atomic,Atomic). | |
178 | |
179 c_post_args(N, N, _, _, V, V) :- !. | |
180 c_post_args(K, N, X, XX, V0, V) :- | |
181 K1 is K+1, arg(K1, X, XK), c_post(XK, XXK, V0, V1), arg(K1, XX, XXK), | |
182 c_post_args(K1, N, X, XX, V1, V). | |
183 | |
184 c_post_tvar(X, Now, Nxt, '$t'(Now1,Nxt1), V0, V) :- var(X),!, | |
185 X='$TMP'(_,Now,Nxt), | |
186 c_post(Now, Now1, V0, V1), | |
187 c_post(Nxt, Nxt1, V1, V). | |
188 c_post_tvar('$REF'(X), _Now, _Nxt, XX, V0, V) :- !, | |
189 c_post(X, XX, V0, V). | |
190 c_post_tvar('$CNT'(X), _Now, _Nxt, XX, V0, V) :- !, | |
191 c_post(X, XX, V0, V). | |
192 c_post_tvar('$TMP'(X,Now,Nxt), Now, Nxt, XX, V0, V) :- !, | |
193 c_post_tvar(X, Now, Nxt, XX, V0, V). | |
194 | |
195 write_clause(X) :- recorded('r_assert',_,_),assert_clause0(X). | |
196 write_clause(_) :- recorded('r_assert',_,_). | |
197 write_clause(X) :- write_clause0(X). | |
198 write_clause(_). | |
199 | |
200 write_clause0((X:-true)) :- | |
201 c_post(X, XX, 0, _), | |
202 write_term(XX,[numbervars(true),quoted(true)]), | |
203 % writeq(XX), | |
204 put("."), nl,!,fail. %%% writeq --> write | |
205 write_clause0(X) :- | |
206 c_post(X, XX, 0, _), writeq1(XX), put("."), nl,!,fail. %%% writeq --> write | |
207 | |
208 % a little pretty print | |
209 writeq1((A,B)) :- !,writeq1(A),put("."), nl, | |
210 writeq1(B). | |
211 writeq1((H:-B)) :- !, | |
212 % writeq(H), | |
213 write_term(H,[numbervars(true),quoted(true)]), | |
214 write((:-)), | |
215 writeq2(B). | |
216 writeq1(X) :- | |
217 % writeq(X). | |
218 write_term(X,[numbervars(true),quoted(true)]). | |
219 writeq2((A,B)) :- !,nl,tab(4), | |
220 % writeq(A), | |
221 write_term(A,[numbervars(true),quoted(true)]), | |
222 put(","),writeq2(B). | |
223 writeq2(X) :- nl,tab(4), | |
224 write_term(X,[numbervars(true),quoted(true)]). | |
225 % writeq(X). | |
226 | |
227 | |
228 assert_clause(X) :- assert_clause0(X). | |
229 assert_clause(_). | |
230 | |
231 %assert_clause0((X:-true)) :- | |
232 % c_post(X, XX, 0, _), c_melt(XX,XXX,_), | |
233 % recorda('r_run',XXX,Ref),assertz(XXX), !,fail. | |
234 assert_clause0(X) :- | |
235 c_post(X, XX, 0, _), c_melt(XX,((XXX:-Y)),_), | |
236 recorda('r_run',((XXX:-_)),_Ref),assertz((XXX:-Y)), !,fail. | |
237 | |
238 /* end */ |