1:- style_check(-singleton). 2:- style_check(-discontiguous). 4:-multifile(user:string_prolog_flag/1). 5:-thread_local(user:string_prolog_flag/1). 6:-current_prolog_flag(double_quotes, WAS),asserta(user:string_prolog_flag(WAS)). 7:- set_prolog_flag(double_quotes, codes).
8
32
33:- set_prolog_flag(double_quotes, codes).
34
35
37
38ip([ip, N]) :- number(N), !.
39mp([mp, N]) :- number(N), !.
40
41s(X, Y) :- reduce_star(X, Z), obs(Z, Y).
42
43p_cal([unknown, _]) :- !.
44p_cal([uncaught_exception, V]) :- v(V), !.
45p_cal([store, S, ES]) :- sf_s(S), es(ES), !.
46
47a_cal([unknown, _]) :- !.
48a_cal([uncaught_exception, V]) :- v(V), !.
49a_cal([store, S, [values|V]]) :- sf_s(S), v_s(V), !.
50
51r_cal(exception) :- !.
52r_cal(unknown) :- !.
53r_cal([values|Rv]) :- rv_cal_s(Rv), !.
54
55rv_cal(pair) :- !.
56rv_cal(null) :- !.
57rv_cal([quote, Sym]) :- sym(Sym), !.
58rv_cal(Sqv) :- sqv(Sqv), !.
59rv_cal(condition) :- !.
60rv_cal(procedure) :- !.
61rv_cal_s([]) :- !.
62rv_cal_s([X|Y]) :- rv_cal(X), rv_cal_s(Y), !.
63
64sf([X, V]) :- x(X), v(V), !.
65sf([X, bh]) :- x(X), !.
66sf([PP, [cons, V1, V2]]) :- pp(PP), v(V1), v(V2), !.
67sf_s([]) :- !.
68sf_s([X|Y]) :- sf(X), sf_s(Y), !.
69
70es([quote, Seq]) :- seq(Seq), !.
71es([quote, Sqv]) :- sqv(Sqv), !.
72es([quote, [] ]) :- !.
73es([begin, Es|Ess]) :- es(Es), es_s(Ess), !.
74es([begin0, Es|Ess]) :- es(Es), es_s(Ess), !.
75es([Es|Ess]) :- es(Es), es_s(Ess), !.
76es([if, Es1, Es2, Es3]) :- es(Es1), es(Es2), es(Es3), !.
77es(['set!', X, Es]) :- x(X), es(Es), !.
78es(X) :- x(X), !.
79es(N) :- nonproc(N), !.
80es(P) :- pproc(P), !.
81es([lambda, F, Es|Ess]) :- f(F), es(Es), es_s(Ess), !.
82es([letrec, Binds, Es|Ess]) :- bind_s(Binds), es(Es), es_s(Ess), !.
83es(['letrec*', Binds, Es|Ess]) :- bind_s(Binds), es(Es), es_s(Ess), !.
84es([dw, X, Es1, Es2, Es3]) :- x(X), es(Es1), es(Es2), es(Es3), !.
85es([throw, X, Es]) :- x(X), es(Es), !.
86es(unspecified) :- !.
87es([handlers, Es1|Ess_Es]) :-
88 es(Es1), append(Ess,[Es],Ess_Es), es_s(Ess), es(Es), !.
89es([l, X, Es]) :- x(X), es(Es), !.
90es([reinit, X]) :- x(X), !.
91es_s([]) :- !.
92es_s([X|Y]) :- es(X), es_s(Y), !.
93
94bind([X, Es]) :- x(X), es(Es), !.
95bind_s([]) :- !.
96bind_s([X|Y]) :- bind(X), bind_s(Y), !.
97no_quote_bind([X, E]) :- x(X), e(E), !.
98no_quote_bind_s([]) :- !.
99no_quote_bind_s([X|Y]) :- no_quote_bind(X), no_quote_bind_s(Y), !.
100
101binds_split([], [], []) :- !.
102binds_split([[V,E]|T], [V|Vr], [E|Er]) :-
103 binds_split(T, Vr, Er), !.
104
105
106f(Xs) :- x_s(Xs), !.
107f([X|Xs_dot_x]) :- x(X), append(Xs,['.', X2], Xs_dot_x), x_s(Xs), x(X2), !.
108f(X) :- x(X), !.
109
110s(Seq) :- seq(Seq), !.
111s( [] ) :- !.
112s(Sqv) :- sqv(Sqv), !.
113s(Sym) :- sym(Sym), !.
114s_s([]) :- !.
115s_s([X|Y]) :- s(X), s_s(Y), !.
116
117seq([S|Ss]) :- s(S), s_s(Ss), !.
118seq([S|Ss_dot_Sqv]) :-
119 s(S), append(Ss, ['.', Sqv], Ss_dot_Sqv), s_s(Ss), sqv(Sqv), !.
120seq([S|Ss_dot_Sym]) :-
121 s(S), append(Ss, ['.', Sym], Ss_dot_Sym), s_s(Ss), sym(Sym), !.
122
123sqv(N) :- number(N), !.
124sqv('#t') :- !.
125sqv('#f') :- !.
126
127p([store, Sfs, E]) :- sf_s(Sfs), e(E), !.
128
129e([begin, E|Es]) :- e(E), e_s(Es), !.
130e([begin0, E|Es]) :- e(E), e_s(Es), !.
131e([E|Es]) :- e(E), e_s(Es), !.
132e([if, E1, E2, E3]) :- e(E1), e(E2), e(E3), !.
133e(['set!', X, E]) :- x(X), e(E), !.
134e([handlers, E|Es_E]) :- e(E), append(Es,[E2],Es_E), e_s(Es), e(E2), !.
135e(X) :- x(X), !.
136e(N) :- nonproc(N), !.
137e(P) :- proc(P), !.
138e([dw, X, E1, E2, E3]) :- x(X), e(E1), e(E2), e(E3), !.
139e(unspecified) :- !.
140e(['l!', X, Es]) :- x(X), es(Es), !.
141e([reinit, X]) :- x(X), !.
142e_s([]) :- !.
143e_s([X|Y]) :- e(X), e_s(Y), !.
144
145v(N) :- nonproc(N), !.
146v(P) :- proc(P), !.
147v_s([]) :- !.
148v_s([X|Y]) :- v(X), v_s(Y), !.
149
150nonproc(Pp) :- pp(Pp), !.
151nonproc(null) :- !.
152nonproc([quote, Sym]) :- sym(Sym), !.
153nonproc(Sqv) :- sqv(Sqv), !.
154nonproc(['make-cond', _]) :- !.
155
156proc([lambda, F, E|Es]) :- f(F), e(E), e_s(Es), !.
157proc(Ppr) :- pproc(Ppr), !.
158proc([throw, X, E]) :- x(X), e(E), !.
159proc_s([]) :- !.
160proc_s([X|Y]) :- proc(X), proc_s(Y), !.
161
162pproc(X) :- aproc(X), !.
163pproc(X) :- proc1(X), !.
164pproc(X) :- proc2(X), !.
165pproc(list) :- !.
166pproc('dynamic-wind') :- !.
167pproc(apply) :- !.
168pproc(values) :- !.
169
170proc1('null?') :- !.
171proc1('pair?') :- !.
172proc1(car) :- !.
173proc1(cdr) :- !.
174proc1('call/cc') :- !.
175proc1('procedure?') :- !.
176proc1('condition?') :- !.
177proc1(X) :- raise_star(X), !.
178
179proc2(cons) :- !.
180proc2(consi) :- !.
181proc2('set-car!') :- !.
182proc2('set-cdr!') :- !.
183proc2('eqv?') :- !.
184proc2('call-with-values') :- !.
185proc2('with-exception-handler') :- !.
186
187aproc('+') :- !.
188aproc('-') :- !.
189aproc('*') :- !.
190aproc('/') :- !.
191
192raise_star('raise-continuable') :- !.
193raise_star(raise) :- !.
194
195pp(I) :- ip(I), !.
196pp(M) :- mp(M), !.
197
198sym('.') :- !, fail.
199sym(X) :- atom(X), !.
200
201x(X) :- keyword(X), !, fail.
202x('.') :- !, fail.
203x(X) :- atom(X), !.
204x_s([]) :- !.
205x_s([X|Y]) :- x(X), x_s(Y), !.
206
207keyword(quote) :- !.
208keyword(values) :- !.
209keyword(throw) :- !.
210keyword(mp) :- !.
211keyword(ip) :- !.
212keyword(lambda) :- !.
213keyword(begin) :- !.
214keyword(begin0) :- !.
215keyword(if) :- !.
216keyword(dw) :- !.
217keyword('set!') :- !.
218keyword(handlers) :- !.
219keyword(uncaught_exception) :- !.
220keyword('make-cond') :- !.
221keyword(letrec) :- !.
222keyword('letrec*') :- !.
223keyword('l!') :- !.
224keyword(reinit) :-!.
225
226n(N) :- number(N), !.
227n_s([]) :- !.
228n_s([X|Y]) :- n(X), n_s(Y), !.
229
230
232
233ctx_p([store, Sfs, E], Hole, [store, Sfs, Next], NextHole, T) :-
234 sf_s(Sfs), ctx_e_star(E, Hole, Next, NextHole, T).
235
236ctx_e_star(X, X, Y, Y, multiple). 237ctx_e_star(E, Hole, Next, NextHole, T) :-
238 ctx_e(E, Hole, Next, NextHole, T).
239
240ctx_e_circle(X, X, Y, Y, single). 241ctx_e_circle(E, Hole, Next, NextHole, T) :-
242 ctx_e(E, Hole, Next, NextHole, T).
243
244ctx_e(F, Hole, Next, NextHole, T) :-
245 ctx_f(F, [handlers|Procs_E], Next, [handlers|Procs_ENext], normal),
246 append(Procs, [E], Procs_E), proc_s(Procs),
247 ctx_e_star(E, Hole, ENext, NextHole, T),
248 append(Procs, [ENext], Procs_ENext).
249ctx_e(F, Hole, Next, NextHole, T) :-
250 ctx_f(F, [dw, X, E1, E, E2], Next, [dw, X, E1, ENext, E2], normal),
251 x(X), e(E1), e(E2),
252 ctx_e_star(E, Hole, ENext, NextHole, T).
253ctx_e(F, Hole, Next, NextHole, T) :-
254 ctx_f(F, Hole, Next, NextHole, T).
255
256ctx_pg([store, Sfs, G], Hole, [store, Sfs, Next1], NextHole, T) :-
257 sf_s(Sfs), ctx_g(G, Hole, Next1, NextHole, T).
258
259ctx_g(F, Hole, Next, NextHole, T) :-
260 ctx_f(F, [dw, X, E1, G, E2], Next, [dw, X, E1, GNext, E2], T),
261 x(X), e(E1), e(E2),
262 ctx_g(G, Hole, GNext, NextHole, T).
263ctx_g(F, Hole, Next, NextHole, T) :-
264 ctx_f(F, Hole, Next, NextHole, T).
265
266ctx_h(F, Hole, Next, NextHole, T) :-
267 ctx_f(F, [handlers|Procs_H], Next, [handlers|Procs_HNext], T),
268 append(Procs, [H], Procs_H), proc_s(Procs),
269 ctx_h(H, Hole, HNext, NextHole, T),
270 append(Procs, [HNext], Procs_HNext).
271ctx_h(F, Hole, Next, NextHole, T) :-
272 ctx_f(F, Hole, Next, NextHole, T).
273
274ctx_f(X, X, Y, Y, normal).
275ctx_f(Vs_F_Vs, Hole, Z, NextHole, T) :-
276 append(Vs, [F|Vs2], Vs_F_Vs), v_s(Vs), v_s(Vs2),
277 ctx_f_circle(F, Hole, Next1, NextHole, T),
278 append(Vs, [Next1|Vs2], Z).
279ctx_f([if, F, E1, E2], Hole, [if, Next1, E1, E2], NextHole, T) :-
280 e(E1), e(E2), ctx_f_circle(F, Hole, Next1, NextHole, T).
281ctx_f(['set!', X, F], Hole, ['set!', X, Next1], NextHole, T) :-
282 x(X), ctx_f_circle(F, Hole, Next1, NextHole, T).
283ctx_f([begin, F, E|Es], Hole, [begin, Next1, E|Es], NextHole, T) :-
284 e(E), e_s(Es), ctx_f_star(F, Hole, Next1, NextHole, T).
285ctx_f([begin0, F, E|Es], Hole, [begin0, Next1, E|Es], NextHole, T) :-
286 e(E), e_s(Es), ctx_f_star(F, Hole, Next1, NextHole, T).
287ctx_f([begin0, [values|Vs], F|Es], Hole,
288 [begin0, [values|Vs], Next1|Es], NextHole, T) :-
289 v_s(Vs), e_s(Es), ctx_f_star(F, Hole, Next1, NextHole, T).
290ctx_f([begin0, unspecified, F|Es], Hole,
291 [begin0, unspecified, Next1|Es], NextHole, T) :-
292 e_s(Es), ctx_f_star(F, Hole, Next1, NextHole, T).
293ctx_f(['call-with-values', [lambda,[],F|Es], V], Hole,
294 ['call-with-values', [lambda,[],Next1|Es], V], NextHole, T) :-
295 e_s(Es), v(V), ctx_f_star(F, Hole, Next1, NextHole, T).
296ctx_f(['l!', X, F], Hole, ['l!', X, Next1], NextHole, T) :-
297 x(X), ctx_f_circle(F, Hole, Next1, NextHole, T).
298
299ctx_f_circle(X, X, Y, Y, single).
300ctx_f_circle(F, Hole, Next, NextHole, T) :-
301 ctx_f(F, Hole, Next, NextHole, T).
302
303ctx_f_star(X, X, Y, Y, multiple).
304ctx_f_star(F, Hole, Next, NextHole, T) :-
305 ctx_f(F, Hole, Next, NextHole, T).
306
307ctx_u(Vs_Hole_Vs2, Hole, Next, NextHole, normal) :-
308 append(Vs, [Hole|Vs2], Vs_Hole_Vs2), v_s(Vs), v_s(Vs2),
309 append(Vs, [NextHole|Vs2], Next).
310ctx_u([if, Hole, E1, E2], Hole, [if, NextHole, E1, E2], NextHole, normal) :-
311 e(E1), e(E2).
312ctx_u(['set!', X, Hole], Hole, ['set!', X, NextHole], NextHole, normal) :-
313 x(X).
314ctx_u(['call-with-values',[lambda,[],Hole],V], Hole,
315 ['call-with-values',[lambda,[],NextHole],V], NextHole, normal) :-
316 v(V).
317
318ctx_s(X, X, Y, Y, normal).
319ctx_s([begin, E|Es_S_Ess], Hole, [begin, E|Z], NextHole, T) :-
320 e(E), append(Es, [S|Ess], Es_S_Ess), e_s(Es), es_s(Ess),
321 ctx_s(S, Hole, Next1, NextHole, T),
322 append(Es, [Next1|Ess], Z).
323ctx_s([begin, S|Ess], Hole, [begin, Next1|Ess], NextHole, T) :-
324 ctx_s(S, Hole, Next1, NextHole, T).
325ctx_s([begin0, E|Es_S_Ess], Hole, [begin0, E|Z], NextHole, T) :-
326 e(E), append(Es, [S|Ess], Es_S_Ess), e_s(Es), es_s(Ess),
327 ctx_s(S, Hole, Next1, NextHole, T),
328 append(Es, [Next1|Ess], Z).
329ctx_s([begin0, S|Ess], Hole, [begin0, Next1|Ess], NextHole, T) :-
330 ctx_s(S, Hole, Next1, NextHole, T).
331ctx_s(Es_S_Ess, Hole, Z, NextHole, T) :-
332 append(Es, [S|Ess], Es_S_Ess), e_s(Es), es_s(Ess),
333 ctx_s(S, Hole, Next1, NextHole, T),
334 append(Es, [Next1|Ess], Z).
335ctx_s([if, S, Es1, Es2], Hole, [if, Next1, Es1, Es2], NextHole, T) :-
336 es(Es1), es(Es2),
337 ctx_s(S, Hole, Next1, NextHole, T).
338ctx_s([if, E, S, Es], Hole, [if, E, Next1, Es], NextHole, T) :-
339 e(E), es(Es),
340 ctx_s(S, Hole, Next1, NextHole, T).
341ctx_s([if, E1, E2, S], Hole, [if, E1, E2, Next1], NextHole, T) :-
342 e(E1), e(E2),
343 ctx_s(S, Hole, Next1, NextHole, T).
344ctx_s(['set!', X, S], Hole, ['set!', X, Next1], NextHole, T) :-
345 x(X), ctx_s(S, Hole, Next1, NextHole, T).
346ctx_s([handlers|Ss_S_Ess], Hole, [handlers|Z], NextHole, T) :-
347 append(Ss, [S|Ess], Ss_S_Ess), s_s(Ss), es_s(Ess),
348 ctx_s(S, Hole, Next1, NextHole, T),
349 append(Ss, [Next1|Ess], Z).
350ctx_s([handlers|Ss_S], Hole, [handlers|Z], NextHole, T) :-
351 append(Ss, [S], Ss_S), s_s(Ss),
352 ctx_s(S, Hole, Next1, NextHole, T),
353 append(Ss, [Next1], Z).
354ctx_s([throw, X, E], [throw, X, E], Y, Y, _) :-
355 x(X), e(E).
356ctx_s([lambda, F, S|Ess], Hole, [lambda, F, Next1|Ess], NextHole, T) :-
357 f(F), es_s(Ess),
358 ctx_s(S, Hole, Next1, NextHole, T).
359ctx_s([lambda, F, E|Es_S_Ess], Hole, [lambda, F, E|Z], NextHole, T) :-
360 f(F), e(E), append(Es, [S|Ess], Es_S_Ess), e_s(Es), es_s(Ess),
361 ctx_s(S, Hole, Next1, NextHole, T),
362 append(Es, [Next1|Ess], Z).
363ctx_s([letrec, Binds, Es|Ess], Hole, [letrec, Z, Es|Ess], NextHole, T) :-
364 es(Es), es_s(Ess), append(NQBs, [[X, S]|Bs], Binds),
365 no_quote_bind_s(NQBs), x(X), bind_s(Bs),
366 ctx_s(S, Hole, Next1, NextHole, T),
367 append(NQBs, [[X, Next1]|Bs], Z).
368ctx_s([letrec, NQBs, S|Ess], Hole, [letrec, NQBs, Next1|Ess], NextHole, T) :-
369 no_quote_bind_s(NQBs), es_s(Ess),
370 ctx_s(S, Hole, Next1, NextHole, T).
371ctx_s([letrec, NQBs, E|Es_S_Ess], Hole, [letrec, NQBs, E|Z], NextHole, T) :-
372 e(E), append(Es, [S|Ess], Es_S_Ess), e_s(Es), es_s(Ess),
373 ctx_s(S, Hole, Next1, NextHole, T),
374 append(Es, [Next1|Ess], Z).
375ctx_s(['letrec*', Binds, Es|Ess], Hole, ['letrec*', Z, Es|Ess], NextHole, T) :-
376 es(Es), es_s(Ess), append(NQBs, [[X, S]|Bs], Binds),
377 no_quote_bind_s(NQBs), x(X), bind_s(Bs),
378 ctx_s(S, Hole, Next1, NextHole, T),
379 append(NQBs, [[X, Next1]|Bs], Z).
380ctx_s(['letrec*', NQBs, S|Ess], Hole,
381 ['letrec*', NQBs, Next1|Ess], NextHole, T) :-
382 no_quote_bind_s(NQBs), es_s(Ess),
383 ctx_s(S, Hole, Next1, NextHole, T).
384ctx_s(['letrec*', NQBs, E|Es_S_Ess], Hole,
385 ['letrec*', NQBs, E|Z], NextHole, T) :-
386 e(E), append(Es, [S|Ess], Es_S_Ess), e_s(Es), es_s(Ess),
387 ctx_s(S, Hole, Next1, NextHole, T),
388 append(Es, [Next1|Ess], Z).
389
390
394reduce(P1, Next) :-
395 ctx_p(P1, [begin, [values|Vs], E|Es], Next, [begin, E|Es], normal),
396 v_s(Vs), e_s(Es), e(E).
397reduce(P1, Next) :-
398 ctx_p(P1, [begin, E], Next, E, normal), e(E).
399reduce(P1, Next) :- 400 ctx_p(P1, [begin, unspecified, E|Es], Next, [begin, E|Es], normal),
401 e_s(Es), e(E).
404reduce(P1, Next) :-
405 ctx_p(P1, [begin0, [values|Vs1], [values|Vs2] | Es],
406 Next, [begin0, [values|Vs1] | Es], normal),
407 v_s(Vs1), v_s(Vs2), e_s(Es).
408reduce(P1, Next) :-
409 ctx_p(P1, [begin0, E], Next, E, normal), e(E).
412reduce([store, Sfs, S1], [store, Sfs, Next]) :-
413 sf_s(Sfs), ctx_s(S1, [quote, Sqv], Next, Sqv, normal), sqv(Sqv).
414reduce([store, Sfs, S1], [store, Sfs, Next]) :-
415 sf_s(Sfs), ctx_s(S1, [quote, [] ], Next, null, normal).
416reduce([store, Sfs, S1], [store, Sfs, [[lambda, [QP], Next1], Z]]) :-
417 sf_s(Sfs), gen_atom(QP), ctx_s(S1, [quote, Seq], Next1, QP, normal),
418 seq(Seq), bif_lm(Seq, Z).
421reduce(P1, Next) :-
422 ctx_p(P1, V, Next, [values, V], multiple), v(V).
423reduce(P1, Next) :-
424 ctx_p(P1, [values, V], Next, V, single), v(V).
427reduce(P1, Next) :-
428 ctx_p(P1, ['call-with-values', [lambda,[],[values|Vs]],V], Next,
429 [V|Vs], normal),
430 v(V), v_s(Vs).
431reduce(P1, Next) :-
432 ctx_p(P1, ['call-with-values', V1, V2], Next,
433 ['call-with-values', [lambda,[],[V1]], V2], normal),
434 v(V1), v(V2), not(V1 = [lambda,[],_]).
437reduce(P1, Next) :-
438 ctx_p(P1, [+], Next, 0, normal).
439reduce(P1, Next) :-
440 ctx_p(P1, [+, N|Ns], Next, Z, normal),
441 n(N), n_s(Ns), sum([N|Ns], Z).
442reduce(P1, Next) :-
443 ctx_p(P1, ['-'], Next, [raise, ['make-cond','arity mismatch']], normal).
444reduce(P1, Next) :-
445 ctx_p(P1, ['-', N], Next, Z, normal),
446 n(N), Z is -N.
447reduce(P1, Next) :-
448 ctx_p(P1, ['-', N1, N2|Ns], Next, Z, normal),
449 n(N1), n(N2), n_s(Ns), sum([N2|Ns], Y), Z is N1 - Y.
450reduce(P1, Next) :-
451 ctx_p(P1, ['*'], Next, 1, normal).
452reduce(P1, Next) :-
453 ctx_p(P1, ['*', N|Ns], Next, Z, normal),
454 n(N), n_s(Ns), product([N|Ns], Z).
455reduce(P1, Next) :-
456 ctx_p(P1, ['/'], Next, [raise, ['make-cond','arity mismatch']], normal).
457reduce(P1, Next) :-
458 ctx_p(P1, ['/', N], Next, Z, normal),
459 n(N), (not(N == 0)), Z is 1 // N.
460reduce(P1, Next) :-
461 ctx_p(P1, ['/', N1, N2|Ns], Next, Z, normal),
462 n(N1), n(N2), n_s(Ns), not(member(0, [N2|Ns])),
463 product([N2|Ns], Y), Z is N1 // Y.
464reduce(P1, Next) :-
465 ctx_p(P1, ['/', N1, N2|Ns], Next,
466 [raise, ['make-cond','divison by zero']], normal),
467 n(N1), n(N2), n_s(Ns), member(0, [N2|Ns]).
468reduce(P1, Next) :-
469 ctx_p(P1, [Aproc|Vs], Next,
470 [raise, ['make-cond','arith-op applied to non-number']], normal),
471 aproc(Aproc), v_s(Vs), not(n_s(Vs)).
474reduce(P1, Next) :-
475 ctx_p(P1, [if, V, E1, E2], Next, E1, normal),
476 v(V), e(E1), e(E2), not(V == '#f').
477reduce(P1, Next) :-
478 ctx_p(P1, [if, '#f', E1, E2], Next, E2, normal),
479 e(E1), e(E2).
482reduce(P1, Next) :-
483 ctx_p(P1, [list], Next, null, normal).
484reduce(P1, Next) :-
485 ctx_p(P1, [list, V|Vs], Next, [cons, V, [list|Vs]], normal),
486 v(V), v_s(Vs).
489reduce([store, Sfs, E1], [store, [[[mp,Mp],[cons,V1,V2]]|Sfs], Next1]) :-
490 sf_s(Sfs), gen_num(Mp),
491 ctx_e(E1, [cons, V1, V2], Next1, [mp, Mp], normal),
492 v(V1), v(V2).
493reduce([store, Sfs, E1], [store, [[[ip,Ip],[cons,V1,V2]]|Sfs], Next1]) :-
494 sf_s(Sfs), gen_num(Ip),
495 ctx_e(E1, [consi, V1, V2], Next1, [ip, Ip], normal),
496 v(V1), v(V2).
499reduce([store, St, E1], [store, St, Next1]) :-
500 ctx_e(E1, [car, Pp], Next1, V1, normal),
501 pp(Pp), append(Sfs, [[Pp,[cons,V1,V2]]|Sfs2], St),
502 sf_s(Sfs), sf_s(Sfs2), v(V1), v(V2).
503reduce([store, St, E1], [store, St, Next1]) :-
504 ctx_e(E1, [cdr, Pp], Next1, V2, normal),
505 pp(Pp), append(Sfs, [[Pp,[cons,V1,V2]]|Sfs2], St),
506 sf_s(Sfs), sf_s(Sfs2), v(V1), v(V2).
507reduce(P1, Next) :-
508 ctx_p(P1, [car, V], Next,
509 [raise, ['make-cond','can\'t take car of non-pair']], normal),
510 v(V), not(pp(V)).
511reduce(P1, Next) :-
512 ctx_p(P1, [cdr, V], Next,
513 [raise, ['make-cond','can\'t take cdr of non-pair']], normal),
514 v(V), not(pp(V)).
517reduce([store, St, E1], [store, St2, Next1]) :-
518 ctx_e(E1, ['set-car!', Mp, V], Next1, unspecified, normal),
519 mp(Mp), v(V), append(Sfs, [[Mp,[cons,V1,V2]]|Sfs2], St),
520 sf_s(Sfs), sf_s(Sfs2), v(V1), v(V2),
521 append(Sfs, [[Mp,[cons,V,V2]]|Sfs2], St2).
522reduce([store, St, E1], [store, St2, Next1]) :-
523 ctx_e(E1, ['set-cdr!', Mp, V], Next1, unspecified, normal),
524 mp(Mp), v(V), append(Sfs, [[Mp,[cons,V1,V2]]|Sfs2], St),
525 sf_s(Sfs), sf_s(Sfs2), v(V1), v(V2),
526 append(Sfs, [[Mp,[cons,V1,V]]|Sfs2], St2).
527reduce(P1, Next) :-
528 ctx_p(
529 P1, ['set-car!', V1, V2], Next,
530 [raise, ['make-cond','can\'t set-car! on non-pair or an immutable pair']],
531 normal),
532 v(V1), v(V2), not(mp(V1)).
533reduce(P1, Next) :-
534 ctx_p(
535 P1, ['set-cdr!', V1, V2], Next,
536 [raise, ['make-cond','can\'t set-cdr! on non-pair or an immutable pair']],
537 normal),
538 v(V1), v(V2), not(mp(V1)).
541reduce(P1, Next) :-
542 ctx_p(P1, ['null?', null], Next, '#t', normal).
543reduce(P1, Next) :-
544 ctx_p(P1, ['null?', V], Next, '#f', normal),
545 v(V), not(V = null).
548reduce(P1, Next) :-
549 ctx_p(P1, ['pair?', Pp], Next, '#t', normal),
550 pp(Pp).
551reduce(P1, Next) :-
552 ctx_p(P1, ['pair?', V], Next, '#f', normal),
553 v(V), not(pp(V)).
556reduce(P1, Next) :-
557 ctx_p(P1, ['eqv?', V, V], Next, '#t', normal),
558 v(V), not(proc(V)).
559reduce(P1, Next) :-
560 ctx_p(P1, ['eqv?', V1, V2], Next, '#f', normal),
561 v(V1), v(V2), not(V1 = V2).
564reduce(P1, Next) :-
565 ctx_p(P1, Es_E_Es, Next, [[lambda,[X],Z],E], normal),
566 append(Es, [E|Es2], Es_E_Es), e_s(Es), e_s(Es2), e(E), not(v(E)),
567 exist_e(Es, Es2),
568 gen_atom(X), append(Es, [X|Es2], Z).
571reduce(P1, Next) :-
572 ctx_p(P1, [[lambda,[], E|Es]], Next, [begin, E|Es], normal),
573 e(E), e_s(Es).
576reduce(P1, Next) :-
577 ctx_p(P1, [[lambda,[X|Xs], E|Es], V|Vs], Next,
578 [[lambda,Xs, Z|Zs] | Vs], normal),
579 x(X), x_s(Xs), e(E), e_s(Es), v(V), v_s(Vs),
580 length(Xs, Len), length(Vs, Len),
581 not(bir_v(X, [lambda,Xs, E|Es])),
582 replace(E, X, V, Z), replace(Es, X, V, Zs).
585reduce([store, Sfs, E1], [store, [[BP, V]|Sfs], Next1]) :-
586 sf_s(Sfs),
587 ctx_e(E1, [[lambda,[X|Xs], E|Es], V|Vs], Next1,
588 [[lambda,Xs, Z|Zs] | Vs], normal),
589 x(X), x_s(Xs), e(E), e_s(Es), v(V), v_s(Vs),
590 length(Xs, Len), length(Vs, Len),
591 bir_v(X, [lambda,Xs, E|Es]), gen_atom(BP),
592 replace(E, X, BP, Z), replace(Es, X, BP, Zs).
595reduce(P1, Next) :-
596 ctx_p(P1, [[lambda,Xs, E|Es] | Vs], Next,
597 [raise, ['make-cond','arity mismatch']], normal),
598 x_s(Xs), e(E), e_s(Es), v_s(Vs),
599 length(Xs, Len1), length(Vs, Len2),
600 not(Len1 == Len2).
603reduce(P1, Next) :-
604 ctx_p(P1, [[lambda,[X|Xs_dot_Xr], E|Es], V|Vs1_Vs2], Next,
605 [[lambda,[X|Xs_Xr], E|Es], V|Vs1_Vs3], normal),
606 x(X), e(E), e_s(Es), v(V),
607 append(Xs, ['.'|[Xr]], Xs_dot_Xr), x_s(Xs), x(Xr),
608 append(Vs1, Vs2, Vs1_Vs2), v_s(Vs1), v_s(Vs2),
609 length(Xs, Len), length(Vs1, Len),
610 append(Vs1, [[list|Vs2]], Vs1_Vs3), append(Xs, [Xr], Xs_Xr).
613reduce(P1, Next) :-
614 ctx_p(P1, [[lambda, X, E|Es] | Vs], Next,
615 [[lambda, [X], E|Es], [list|Vs]], normal),
616 x(X), e(E), e_s(Es), v_s(Vs).
619reduce(P1, Next) :-
620 ctx_p(P1, [[lambda,Xs_dot_Xr, E|Es] | Vs1_Vs2], Next,
621 [raise, ['make-cond','arity mismatch']], normal),
622 e(E), e_s(Es), v_s(Vs1_Vs2),
623 append(Xs, ['.'|[Xr]], Xs_dot_Xr), x_s(Xs), x(Xr),
624 length(Xs, Len1), length(Vs1_Vs2, Len2),
625 Len2 < Len1.
628reduce([store, Sfs, E1], [store, Sfs, Next1]) :-
629 sf_s(Sfs),
630 ctx_e(E1, ['call/cc', V1], Next1, [V1, [throw, X, Next2]], normal),
631 v(V1),
632 ctx_e(E1, ['call/cc', V1], Next2, X, normal),
633 gen_atom(X).
636reduce([store, Sfs, E1], [store, Sfs, Next1]) :-
637 sf_s(Sfs),
638 ctx_e(E1, [[throw, X, E2]|Vs], _, _, normal),
639 x(X), v_s(Vs), bif_t(E1, E2, X, Next1, [values|Vs]).
642reduce(P1, Next) :-
643 ctx_p(P1, ['dynamic-wind', Proc1, Proc2, Proc3], Next,
644 [begin,[Proc1],[begin0,[dw,X,[Proc1],[Proc2],[Proc3]],[Proc3]]],
645 normal),
646 proc(Proc1), proc(Proc2), proc(Proc3), gen_atom(X).
647
648reduce(P1, Next) :-
649 ctx_p(P1, [dw, X, E1, [values|Vs], E2], Next, [values|Vs], normal),
650 x(X), e(E1), v_s(Vs), e(E2).
653reduce([store, Sfs_bind_Sfs, E1], [store, Sfs_bind_Sfs, Next1]) :-
654 append(Sfs, [[X,V]|Sfs2], Sfs_bind_Sfs),
655 sf_s(Sfs), x(X), v(V), sf_s(Sfs2),
656 ctx_e(E1, X, Next1, V, normal).
659reduce([store, Sfs_bind_Sfs, E1], [store, Sfs_bind2_Sfs, Next1]) :-
660 ctx_e(E1, ['set!', X, V2], Next1, unspecified, normal),
661 append(Sfs, [[X,V]|Sfs2], Sfs_bind_Sfs),
662 sf_s(Sfs), v(V), sf_s(Sfs2), x(X),
663 v(V2), append(Sfs, [[X,V2]|Sfs2], Sfs_bind2_Sfs).
666reduce(P1, Next) :-
667 ctx_p(P1, ['procedure?', Proc], Next, '#t', normal),
668 proc(Proc).
669reduce(P1, Next) :-
670 ctx_p(P1, ['procedure?', Nonproc], Next, '#f', normal),
671 nonproc(Nonproc).
674reduce(P1, Next) :- 675 ctx_p(P1, [Nonproc|Vs], Next,
676 [raise, ['make-cond','can\'t call non-procedure']], normal),
677 nonproc(Nonproc), v_s(Vs).
678reduce(P1, Next) :- 679 ctx_p(P1, [Proc1|Vs], Next,
680 [raise, ['make-cond','arity mismatch']], normal),
681 proc1(Proc1), v_s(Vs), length(Vs, Len), not(Len == 1).
682reduce(P1, Next) :- 683 ctx_p(P1, [Proc2|Vs], Next,
684 [raise, ['make-cond','arity mismatch']], normal),
685 proc2(Proc2), v_s(Vs), length(Vs, Len), not(Len == 2).
688reduce(P1, Next) :-
689 ctx_p(P1, [apply, Proc|Vs_null], Next, [Proc|Vs], normal),
690 proc(Proc), append(Vs, [null], Vs_null), v_s(Vs).
691reduce([store, St, E1], [store, St, Next1]) :-
692 ctx_e(E1, [apply, Proc|Vs_Pp], Next1, [apply, Proc|Vs_V1_V2], normal),
693 proc(Proc), append(Vs, [Pp], Vs_Pp),
694 append(Sfs, [[Pp,[cons,V1,V2]]|Sfs2], St),
695 sf_s(Sfs), pp(Pp), v(V1), v(V2), sf_s(Sfs2),
696 append(Vs, [V1, V2], Vs_V1_V2).
699reduce(P1, Next) :-
700 ctx_p(P1, [apply, Nonproc|Vs], Next,
701 [raise, ['make-cond','can\'t apply non-procedure']], normal),
702 'format'('~p~n',[Nonproc]),
703 nonproc(Nonproc), v_s(Vs).
704reduce(P1, Next) :-
705 ctx_p(P1, [apply, Proc|Vs_V], Next,
706 [raise, ['make-cond','apply\'s last argument non-list']], normal),
707 proc(Proc), append(Vs, [V], Vs_V), v_s(Vs), v(V),
708 not(V = null), not(pp(V)).
709reduce(P1, Next) :-
710 ctx_p(P1, [apply], Next,
711 [raise, ['make-cond','arity mismatch']], normal).
712reduce(P1, Next) :-
713 ctx_p(P1, [apply, V], Next,
714 [raise, ['make-cond','arity mismatch']], normal),
715 v(V).
718reduce(PG1, Next) :-
719 ctx_pg(PG1, ['with-exception-handler', Proc1, Proc2],
720 Next, [handlers, Proc1, [Proc2]], normal),
721 proc(Proc1), proc(Proc2).
722reduce(PG1, Next) :- 723 ctx_pg(PG1, ['with-exception-handler', V1, V2],
724 Next, [raise, ['make-cond','with-exception-handler expects procs']],
725 normal),
726 v(V1), v(V2), or(V1, V2, V12), not(proc(V12)).
729reduce(P1, Next) :-
730 ctx_p(P1, [handlers|Procs_G], Next, [handlers|Procs_GNext], normal),
731 append(Procs, [G], Procs_G), proc_s(Procs),
732 ctx_g(G, ['with-exception-handler', Proc1, Proc2], GNext,
733 [handlers|Z], normal),
734 proc(Proc1), proc(Proc2), append(Procs, [Proc1|[[Proc2]]], Z),
735 append(Procs, [GNext], Procs_GNext).
736reduce(P1, Next) :- 737 ctx_p(P1, [handlers|Procs_G], Next, [handlers|Procs_GNext], normal),
738 append(Procs, [G], Procs_G), proc_s(Procs),
739 ctx_g(G, ['with-exception-handler', V1, V2], GNext,
740 [raise, ['make-cond','with-exception-handler expects procs']], normal),
741 v(V1), v(V2), or(V1,V2,V12), not(proc(V12)),
742 append(Procs, [GNext], Procs_GNext).
745reduce(P1, Next) :-
746 ctx_p(P1, [handlers|Procs_Proc_G], Next,
747 [handlers|Procs_GNext], normal),
748 append(Procs, [Proc|[G]], Procs_Proc_G), proc_s(Procs), proc(Proc),
749 ctx_g(G, ['raise-continuable', V], GNext, Z, normal),
750 v(V), append(Procs, [Proc, V], Z),
751 append(Procs, [GNext], Procs_GNext).
754reduce(P1, Next) :-
755 ctx_p(P1, [handlers|Procs_Proc_G], Next,
756 [handlers|Procs_Proc_GNext], normal),
757 append(Procs, [Proc|[G]], Procs_Proc_G), proc_s(Procs), proc(Proc),
758 ctx_g(G, [raise, V], GNext, Z, normal),
759 v(V),
760 append(Procs,
761 [begin, [Proc, V], [raise,['make-cond','handler returned']]], Z),
762 append(Procs, [GNext], Procs_Proc_GNext).
765reduce(P1, Next) :-
766 ctx_p(P1, [handlers|Procs_Values], Next, [values|Vs], normal),
767 append(Procs, [[values|Vs]], Procs_Values),
768 proc_s(Procs), v_s(Vs).
771reduce(P1, Next) :-
772 ctx_p(P1, ['condition?', ['make-cond', _]], Next, '#t', normal).
773reduce(P1, Next) :-
774 ctx_p(P1, ['condition?', X], Next, '#f', normal),
775 not(X = ['make-cond', _]).
778reduce(PG1, [uncaught_exception, V]) :-
779 ctx_pg(PG1, [Raise, V], _, _, normal),
780 raise_star(Raise), v(V).
781reduce(P1, [uncaught_exception, V]) :-
782 ctx_p(P1, [handlers, G], _, _, normal),
783 ctx_g(G, [Raise, V], _, _, normal),
784 raise_star(Raise), v(V).
787reduce([store, Sfs, E1], [store, Sfs2, Next1]) :-
788 sf_s(Sfs),
789 ctx_e(E1, [letrec, Binds, E|Es], Next1,
790 [[lambda, Vars | Body] | Args], normal),
791 no_quote_bind_s(Binds), e(E), e_s(Es),
792 binds_split(Binds, Vars, Exps),
793 length(Vars, Len), make_vars(Len, LVars), make_vars(Len, RVars),
794 make_inits(LVars, Vars, Inits),
795 multi_replace([E|Es], Vars, LVars, Z),
796 make_letrec_args(Exps, Vars, LVars, RVars, Args),
797 append(Inits, Z, Body),
798 make_letrec_store(LVars, RVars, Sfs, Sfs2).
801reduce([store, Sfs, E1], [store, Sfs2, Next1]) :-
802 sf_s(Sfs),
803 ctx_e(E1, ['letrec*', Binds, E|Es], Next1, [begin|Body], normal),
804 no_quote_bind_s(Binds), e(E), e_s(Es),
805 binds_split(Binds, Vars, Exps),
806 length(Vars, Len), make_vars(Len, LVars), make_vars(Len, RVars),
807 make_star_inits(Exps, LVars, RVars, Inits),
808 append(Inits, [E|Es], Body1),
809 multi_replace(Body1, Vars, LVars, Body),
810 make_letrec_store(LVars, RVars, Sfs, Sfs2).
811
812reduce([store, St, E1], [store, St2, Next1]) :- 813 sf_s(St), ctx_e(E1, ['l!', X, V], Next1, unspecified, normal),
814 x(X), v(V),
815 append(Sfs, [[X, bh]|Sfs2], St), sf_s(Sfs), sf_s(Sfs2),
816 append(Sfs, [[X, V]|Sfs2], St2).
817reduce([store, St, E1], [store, St2, Next1]) :- 818 sf_s(St), ctx_e(E1, ['l!', X, V], Next1, unspecified, normal),
819 x(X), v(V),
820 append(Sfs, [[X, V0]|Sfs2], St), sf_s(Sfs), sf_s(Sfs2), v(V0),
821 append(Sfs, [[X, V]|Sfs2], St2).
822reduce([store, St, E1], [store, St2, Next1]) :- 823 sf_s(St), ctx_e(E1, ['set!', X, V], Next1, unspecified, normal),
824 x(X), v(V),
825 append(Sfs, [[X, bh]|Sfs2], St), sf_s(Sfs), sf_s(Sfs2),
826 append(Sfs, [[X, V]|Sfs2], St2).
827reduce([store, St, E1], [store, St, Next1]) :- 828 sf_s(St), ctx_e(E1, X, Next1,
829 [raise, ['make-cond','letrec variable touched']], normal),
830 x(X),
831 append(Sfs, [[X, bh]|Sfs2], St), sf_s(Sfs), sf_s(Sfs2).
832reduce([store, St, E1], [store, St2, Next1]) :- 833 sf_s(St), ctx_e(E1, [reinit, X], Next1, [quote,ignore], normal),
834 x(X),
835 append(Sfs, [[X, '#f']|Sfs2], St), sf_s(Sfs), sf_s(Sfs2),
836 append(Sfs, [[X, '#t']|Sfs2], St2).
837reduce([store, St, E1], [store, St, Next1]) :- 838 sf_s(St), ctx_e(E1, [reinit, X], Next1,
839 [raise,['make-cond','reinvoked continuation of letrec init']], normal),
840 x(X),
841 append(Sfs, [[X, '#t']|Sfs2], St), sf_s(Sfs), sf_s(Sfs2).
846reduce([store, Sfs, unspecified], [unknown, 'unspecified result']) :-
847 sf_s(Sfs).
848reduce(P1, [unknown, 'unspecified result']) :-
849 ctx_p(P1, U, _, _, normal),
850 ctx_u(U, unspecified, _, _, normal).
851reduce(P1, [unknown, 'equivalence of procedures']) :-
852 ctx_p(P1, ['eqv?', Proc, Proc], _, _, normal),
853 proc(Proc).
854reduce(P1, [unknown, 'context expected one value']) :-
855 ctx_p(P1, [values, V1, V2|Vs], _, _, single),
856 v(V1), v(V2), v_s(Vs).
857reduce(P1, Next) :-
858 ctx_p(P1, [handlers|Vs_unspecified], Next, unspecified, normal),
859 append(Vs, [unspecified], Vs_unspecified), v_s(Vs).
860reduce(P1, Next) :-
861 ctx_p(P1, [dw,X,E1,unspecified,E2], Next, unspecified, normal),
862 x(X), e(E1), e(E2).
863reduce(P1, Next) :-
864 ctx_p(P1, [begin0, [values|Vs1], unspecified | Es],
865 Next, [begin0, [values|Vs1] | Es], normal),
866 v_s(Vs1), e_s(Es).
867reduce(P1, Next) :-
868 ctx_p(P1, [begin0, unspecified, [values|Vs2] | Es],
869 Next, [begin0, unspecified | Es], normal),
870 v_s(Vs2), e_s(Es).
871reduce(P1, Next) :-
872 ctx_p(P1, [begin0, unspecified, unspecified | Es],
873 Next, [begin0, unspecified | Es], normal),
874 e_s(Es).
875
876
877reduce(X, X).
881replace([], _, _, []) :- !.
882replace(X, X, Y, Y) :- !.
883replace([lambda,Xs|Es], X, _, [lambda,Xs|Es]) :-
884 member(X, Xs), !. 885replace([lambda,X|Es], X, _, [lambda,X|Es]) :- !.
886replace([H|T], X, Y, [Z1|Z2]) :-
887 replace(H, X, Y, Z1),
888 replace(T, X, Y, Z2), !.
889replace(H, _, _, H) :- !.
890
891sum([], 0).
892sum([X|Y], Z) :- sum(Y, W), Z is X + W.
893
894product([], 1).
895product([X|Y], Z) :- product(Y, W), Z is X * W.
896
897exist_e([], []) :- fail.
898exist_e([], [H|_]) :- e(H), not(v(H)).
899exist_e([], [_|T]) :- exist_e([], T).
900exist_e([H|_], _) :- e(H), not(v(H)).
901exist_e([_|T], X) :- exist_e(T, X).
902
903make_vars(0, []) :- !.
904make_vars(N, [H|T]) :-
905 M is N - 1,
906 gen_atom(H), make_vars(M, T).
907
908make_inits([], [], []).
909make_inits([L|Ls], [V|Vs], [['l!', L, V]|T]) :-
910 make_inits(Ls, Vs, T).
911
912make_star_inits([], [], [], []).
913make_star_inits([E|Es], [L|Ls], [R|Rs], [[begin,['l!',L,E],[reinit,R]]|T]) :-
914 make_star_inits(Es, Ls, Rs, T).
915
916multi_replace(L, [], [], L).
917multi_replace(L, [X|Xs], [Y|Ys], Result) :-
918 replace(L, X, Y, Result1),
919 multi_replace(Result1, Xs, Ys, Result).
920
921make_letrec_args([], _, _, [], []).
922make_letrec_args([E|Es], Vars, LVars, [R|Rs], [[begin0, E2, [reinit, R]]|T]) :-
923 multi_replace(E, Vars, LVars, E2),
924 make_letrec_args(Es, Vars, LVars, Rs, T).
925
926make_letrec_store([], [], Sfs, Sfs).
927make_letrec_store([L|Ls], [R|Rs], Sfs, [[L,bh]|[[R,'#f']|T]]) :-
928 make_letrec_store(Ls, Rs, Sfs, T).
929
930or(X, _, X).
931or(_, Y, Y).
932
933eval(X, Y) :- reduce(X, Z), not(X==Z), eval(Z, Y), !.
934eval(X, X) :- reduce(X, X), !.
935
936eval_step(X, Y) :-
937 reduce(X, Z), not(X==Z), 'format'('~p~n',[Z]), eval_step(Z, Y), !.
938eval_step(X, X) :- reduce(X, X), !.
939
940
942
943bif_li( [] , null) :- !.
944bif_li([S|Ss], [cons, Y, Z]) :-
945 s(S), s_s(Ss), bif_li(S, Y), bif_li(Ss, Z).
946bif_li([S, '.', Sqv], [cons, Y, Sqv]) :-
947 s(S), sqv(Sqv), bif_li(S, Y).
948bif_li([S1, S2|Ss_dot_Sqv], [cons, Y, Z]) :-
949 s(S1), s(S2), append(Ss, ['.', Sqv], Ss_dot_Sqv), s_s(Ss), sqv(Sqv),
950 bif_li(S1, Y), bif_li([S2|Ss_dot_Sqv], Z).
951bif_li([S, '.', Sym], [cons, Y, [quote, Sym]]) :-
952 s(S), sym(Sym), bif_li(S, Y).
953bif_li([S1, S2|Ss_dot_Sym], [cons, Y, Z]) :-
954 s(S1), s(S2), append(Ss, ['.', Sym], Ss_dot_Sym), s_s(Ss), sym(Sym),
955 bif_li(S1, Y), bif_li([S2|Ss_dot_Sym], Z).
956bif_li(Sym, [quote, Sym]) :- sym(Sym).
957bif_li(Sqv, Sqv) :- sqv(Sqv).
958
959bif_lm( [] , null) :- !.
960bif_lm([S|Ss], [consi, Y, Z]) :-
961 s(S), s_s(Ss), bif_lm(S, Y), bif_lm(Ss, Z).
962bif_lm([S, '.', Sqv], [consi, Y, Sqv]) :-
963 s(S), sqv(Sqv), bif_lm(S, Y).
964bif_lm([S1, S2|Ss_dot_Sqv], [consi, Y, Z]) :-
965 s(S1), s(S2), append(Ss, ['.', Sqv], Ss_dot_Sqv), s_s(Ss), sqv(Sqv),
966 bif_lm(S1, Y), bif_lm([S2|Ss_dot_Sqv], Z).
967bif_lm([S, '.', Sym], [consi, Y, [quote, Sym]]) :-
968 s(S), sym(Sym), bif_lm(S, Y).
969bif_lm([S1, S2|Ss_dot_Sym], [consi, Y, Z]) :-
970 s(S1), s(S2), append(Ss, ['.', Sym], Ss_dot_Sym), s_s(Ss), sym(Sym),
971 bif_lm(S1, Y), bif_lm([S2|Ss_dot_Sym], Z).
972bif_lm(Sym, [quote, Sym]) :- sym(Sym).
973bif_lm(Sqv, Sqv) :- sqv(Sqv).
974
975bif_t(H1, H2, Hole, Result, NextHole) :-
976 ctx_h(H1, [dw,X,E1,E_1,E2], _, _, normal),
977 e(E1), e(E2), x(X),
978 ctx_h(H2, [dw,X,E1,E_2,E2], Result, [dw,X,E1,T,E2], normal),
979 bif_t(E_1, E_2, Hole, T, NextHole), !.
980bif_t(E1, E2, Hole, [begin, S, K], NextHole) :-
981 bif_s(E1, S, 1), bif_r(E2, Hole, K, NextHole), !.
982
983bif_r(H1, Hole, Result, NextHole) :-
984 ctx_h(H1, [dw,X,E1,E,E2], Result,
985 [begin, E1, [dw,X,E1,K,E2]], normal),
986 x(X), e(E1), e(E2),
987 bif_r(E, Hole, K, NextHole), !.
988bif_r(H1, Hole, Result, NextHole) :-
989 ctx_h(H1, Hole, Result, NextHole, normal), !.
990
991bif_s(E, Result, NextHole) :-
992 ctx_e(E, [dw,X,E1,H2,E2], _, _, normal),
993 x(X), e(E1), e(E2),
994 bif_s(H2, Result, [begin0, [dw,X,E1,NextHole,E2], E2]), !.
995bif_s(_, X, X) :- !.
996
997
1000
1001bir_v(X, ['set!', X, E]) :-
1002 e(E), !.
1003bir_v(X1, ['set!', X2, E]) :-
1004 x(X2), e(E), bir_v(X1, E), !.
1005bir_v(X, [begin, E1, E2|Es]) :-
1006 e(E1), e(E2), e_s(Es),
1007 bir_v(X, E1), !.
1008bir_v(X, [begin, E1, E2|Es]) :-
1009 e(E1), e(E2), e_s(Es),
1010 bir_v(X, [begin, E2|Es]), !.
1011bir_v(X, [begin, E]) :-
1012 e(E), bir_v(X, E), !.
1013bir_v(X, [E|Es]) :-
1014 e(E), e_s(es), bif_v(X, [begin | [E|Es]]), !.
1015bir_v(X, [if, E1, E2, E3]) :-
1016 e(E1), e(E2), e(E3),
1017 bir_v_3(X, [E1, E2, E3]), !.
1018bir_v(X, [begin0, E|Es]) :-
1019 e(E), e_s(Es), bir_v(X, [begin, E|Es]), !.
1020bir_v(X, [lambda, Xs, E|Es]) :-
1021 x_s(Xs), e(E), e_s(Es),
1022 not(member(X, Xs)), bir_v(X, [begin, E|Es]), !.
1023bir_v(X, [lambda, Xs_dot_X2, E|Es]) :-
1024 append(Xs, ['.'|[X2]], Xs_dot_X2), x_s(Xs), x(X2),
1025 e(E), e_s(Es),
1026 not(member(X, Xs)), not(X = X2), bir_v(X, [begin, E|Es]), !.
1027bir_v(X, [lambda, X2, E|Es]) :-
1028 x(X2), e(E), e_s(Es), not(X = X2), bir_v(X, [begin, E|Es]), !.
1029bir_v(X, [letrec, Binds, E|Es]) :-
1030 no_quote_bind_s(Binds), e(E), e_s(Es),
1031 binds_split(Binds, Vars, Exps),
1032 not(member(X, Vars)), append(Exps, [E|Es], Z),
1033 bir_v(X, [begin|Z]), !.
1034bir_v(X, ['letrec*', Binds, E|Es]) :-
1035 no_quote_bind_s(Binds), e(E), e_s(Es),
1036 binds_split(Binds, Vars, Exps),
1037 not(member(X, Vars)), append(Exps, [E|Es], Z),
1038 bir_v(X, [begin|Z]), !.
1039bir_v(X, ['l!', X2, E]) :-
1040 x(X2), e(E), bir_v(X, ['set!', X2, E]), !.
1041bir_v(X, [reinit, X2, E]) :-
1042 x(X2), e(E), bir_v(X, ['set!', X2, E]), !.
1043bir_v(X, [dw, X2, E1, E2, E3]) :-
1044 x(X2), e(E1), e(E2), e(E3), bir_v_3(X, [E1, E2, E3]), !.
1045
1046bir_v_3(X, [E1, _, _]) :-
1047 e(E1), bir_v(X, E1), !.
1048bir_v_3(X, [_, E2, _]) :-
1049 e(E2), bir_v(X, E2), !.
1050bir_v_3(X, [_, _, E3]) :-
1051 e(E3), bir_v(X, E3), !.
1052
1053
1055evaluate(Str) :-
1056 parse(Str, Obj),
1057 eval([store,[[x,0]],Obj], Ret),
1058 print_program(Ret).
1059
1060
1062parse(Str, Obj) :-
1063 str_to_obj(Str, Obj, _).
1064
1065remove_space([], []) :- !.
1066remove_space([N|T], Z) :-
1067 char_type(N, space),
1068 remove_space(T, Z), !.
1069remove_space([N|T], [N|T]) :- !.
1070
1071next_token(Str, Token, Rest) :-
1072 remove_space(Str, [H|T]),
1073 not(delimiter(H)),
1074 next_token_sub([H|T], [Token,[]], Rest), !.
1075next_token(Str, H, T) :-
1076 remove_space(Str, [H|T]), !.
1077
1078next_token_sub([], [X,X], []) :- !.
1079next_token_sub([H|T], [X,X], [H|T]) :-
1080 delimiter(H), !.
1081next_token_sub([H|T], [[H|X],Y], Rest) :-
1082 next_token_sub(T, [X,Y], Rest).
1083
1084str_to_obj(Str, Obj, Rest) :-
1085 next_token(Str, Token, Rest1),
1086 token_to_obj(Token, Rest1, Obj, Rest), !.
1087
1088token_to_obj(LP, Rest, Obj, NextRest) :-
1089 number(LP), char_code('(', LP),
1090 str_to_list(Rest, [Obj,[]], NextRest), !.
1091token_to_obj(QT, Rest, [quote, Obj1], NextRest) :-
1092 number(QT), char_code('\'', QT),
1093 str_to_obj(Rest, Obj1, NextRest), !.
1094token_to_obj(Token, Rest, Obj, Rest) :-
1095 numstr(Token),
1096 numstr_to_number(Token, Obj, 0), !.
1097token_to_obj(Token, Rest, Obj, Rest) :-
1098 atom_codes(Obj, Token), !.
1099
1100str_to_list(Str, [X,Y], Rest) :-
1101 next_token(Str, Token, Rest1),
1102 str_to_list1(Token, Rest1, [X,Y], Rest).
1103str_to_list1(N, Rest, [X,X], Rest):-
1104 number(N), char_code(')', N), !.
1105str_to_list1(".", Rest1, [['.'|X],Y], Rest) :-
1106 next_token(Rest1, Token, Rest2),
1107 str_to_list1(Token, Rest2, [X,Y], Rest), !.
1108str_to_list1(Token, Rest1, [[Obj|X],Y], Rest) :-
1109 token_to_obj(Token, Rest1, Obj, Rest2),
1110 next_token(Rest2, Token2, Rest3),
1111 str_to_list1(Token2, Rest3, [X,Y], Rest), !.
1112
1113numstr_to_number([], Acc, Acc).
1114numstr_to_number([H|T], Result, Acc) :-
1115 char_code('0', Base),
1116 Acc1 is (H - Base) + (Acc * 10),
1117 numstr_to_number(T, Result, Acc1).
1118
1119
1120delimiter(N) :- char_type(N, space).
1121delimiter(N) :- char_code('\'', N).
1122delimiter(N) :- char_code('(', N).
1123delimiter(N) :- char_code(')', N).
1124
1125numstr([]).
1126numstr([H|T]) :- char_type(H, digit), numstr(T).
1127
1128
1130
1131print_program([unknown, Msg]) :-
1132 'format'('unknown: ~p~n', [Msg]).
1133print_program([uncaught_exception, ['make-cond', Msg]]) :-
1134 'format'('uncaught exception: ~p~n',[Msg]).
1135print_program([store, Sfs, [values|Vs]]) :-
1136 print_values(Sfs, [values|Vs]).
1137print_values(Sfs, [values, V]) :-
1138 v(V), print_obj(Sfs, V), !.
1139print_values(Sfs, [values, V|Vs]) :-
1140 v(V), v_s(Vs),
1141 'format'('(values '),
1142 print_values1(Sfs, [V|Vs]),
1143 'format'(')'), !.
1144print_values1(_, []) :- !.
1145print_values1(Sfs, [V|Vs]) :-
1146 v(V), v_s(Vs),
1147 print_obj(Sfs, V),
1148 'format'(' '),
1149 print_values1(Sfs, Vs), !.
1150
1151print_obj(_, null) :-
1152 'format'('()'), !.
1153print_obj(_, Sqv) :-
1154 sqv(Sqv), 'format'('~p', [Sqv]), !.
1155print_obj(_, [quote,Sym]) :-
1156 sym(Sym), 'format'('~p', [Sym]), !.
1157print_obj(_, [lambda,_|_]) :-
1158 'format'('<closure>'), !.
1159print_obj(St, Pp) :-
1160 pp(Pp), append(Sfs, [[Pp,[cons,V1,V2]]|Sfs2], St),
1161 sf_s(Sfs), sf_s(Sfs2), v(V1), v(V2),
1162 'format'('('),
1163 print_list(St, V1, V2),
1164 'format'(')'), !.
1165print_list(St, CAR, null) :-
1166 print_obj(St, CAR), !.
1167print_list(St, CAR, Pp) :-
1168 pp(Pp), append(Sfs, [[Pp,[cons,V1,V2]]|Sfs2], St),
1169 sf_s(Sfs), sf_s(Sfs2), v(V1), v(V2),
1170 print_obj(St, CAR),
1171 'format'(' '),
1172 print_list(St, V1, V2), !.
1173print_list(St, CAR, CDR) :-
1174 print_obj(St, CAR),
1175 'format'(' . '),
1176 print_obj(St, CDR), !.
1177
1178
1179gen_atom(X) :- (atom(X)->true;gensym('#:G', X)).
1180gen_num(X) :- gensym('', Y), atom_number(Y, X).
1193:- evaluate("(car '(a b c))"). 1194
1195
1196:-evaluate("(define-syntax define-macro
1197 (lambda (x)
1198 \"Define a defmacro.\"
1199 (syntax-case x ()
1200 ((_ (macro . args) doc body1 body ...)
1201 (string? (syntax->datum #'doc))
1202 #'(define-macro macro doc (lambda args body1 body ...)))
1203 ((_ (macro . args) body ...)
1204 #'(define-macro macro #f (lambda args body ...)))
1205 ((_ macro transformer)
1206 #'(define-macro macro #f transformer))
1207 ((_ macro doc transformer)
1208 (or (string? (syntax->datum #'doc))
1209 (not (syntax->datum #'doc)))
1210 #'(define-syntax macro
1211 (lambda (y)
1212 doc
1213 #((macro-type . defmacro)
1214 (defmacro-args args))
1215 (syntax-case y ()
1216 ((_ . args)
1217 (let ((v (syntax->datum #'args)))
1218 (datum->syntax y (apply transformer v)))))))))))"). 1219
1220
1221:- evaluate("(define is-quote-expression?
1222 (lambda (v)
1223 (equal? (car v) 'quote)
1224 (is-quotation? (cdr v)))))"). 1225
1226
1227
1228:- evaluate("(define is-quotation?
1229 (lambda (v)
1230 (or (number? v)
1231 (boolean? v)
1232 (char? v)
1233 (string? v)
1234 (symbol? v)
1235 (null? v)
1236 (and (pair? v)
1237 (is-quotation? (car v))
1238 (is-quotation? (cdr v)))))"). 1239:-evaluate(" (is-quote-expression? (quote (quote 42))))"). 1240
1241:-evaluate(
1242"(define-syntax define-macro
1243 (lambda (x)
1244 (syntax-case x ()
1245 ((_ (macro . args) body ...)
1246 #'(define-macro macro (lambda args body ...)))
1247 ((_ macro transformer)
1248 #'(define-syntax macro
1249 (lambda (y)
1250 (syntax-case y ()
1251 ((_ . args)
1252 (let ((v (syntax->datum #'args)))
1253 (datum->syntax y (apply transformer v)))))))))))"
1254 ). 1255
1256
1257
1258:- retract(user:string_prolog_flag(WAS))->set_prolog_flag(string,WAS);true.