|
996
|
1 /*
|
|
|
2 * This is an implementation of the Unlambda programming language
|
|
|
3 *
|
|
|
4 * Copyright (C) 2000 Bertram Felgenhauer <b.f.@gmx.de>
|
|
|
5 *
|
|
|
6 * This program is free software; you can redistribute it and/or
|
|
|
7 * modify it under the terms of the GNU General Public License
|
|
|
8 * as published by the Free Software Foundation; either version
|
|
|
9 * 2 of the License, or (at your option) any later version.
|
|
|
10 *
|
|
|
11 * This program is distributed in the hope that it will be useful,
|
|
|
12 * but WITHOUT ANY WARRANTY; without even the implied warranty
|
|
|
13 * of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See
|
|
|
14 * the GNU General Public License for more details.
|
|
|
15 *
|
|
|
16 * You should have received a copy of the GNU General Public License
|
|
|
17 * along with this program; if not, write to the Free Software
|
|
|
18 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
|
|
19 */
|
|
|
20
|
|
|
21 /*
|
|
|
22 * This is more or less a translation of the Haskell version, which is a lot
|
|
|
23 * easier to read than this code; most comments here are actually Haskell code.
|
|
|
24 *
|
|
|
25 * history:
|
|
|
26 * 13-10-2000: initial version, in Haskell
|
|
|
27 * 14-10-2000: initial version in C
|
|
|
28 * xx-10-2000: optimised; gcc is weird: removing code (which was never
|
|
|
29 * executed anyway) can make programs slower. duh.
|
|
|
30 * 31-10-2000: added '/' (use -DUSE_SLASH), which is similar to '|' but
|
|
|
31 * with ?<char> instead of .<char>
|
|
|
32 * 21-12-2000: added some fflush(stdout) code...
|
|
|
33 */
|
|
|
34
|
|
|
35 #include <stdio.h>
|
|
|
36 #include <stdlib.h>
|
|
|
37 #include <ctype.h>
|
|
|
38
|
|
|
39 // note: Be sure to compile with -DNDEBUG if you want optimal performance.
|
|
|
40 #include <assert.h>
|
|
|
41
|
|
|
42 #define BLOCK_SIZE 4096 // allocate BLOCK_SIZE info structs each malloc
|
|
|
43
|
|
|
44 #define _STR(x) #x
|
|
|
45 #define STR(x) _STR(x)
|
|
|
46
|
|
|
47 /*
|
|
|
48 * data Prog = App Prog Prog | At | C | C1 Cont | D | D1 Prog | Dot Char | E
|
|
|
49 * | I | K | K1 Prog | Que Char | S | S1 Prog | S2 Prog Prog | V | VBar
|
|
|
50 * data Cont = App1 Prog Cont | App2 Prog Cont
|
|
|
51 */
|
|
|
52
|
|
|
53 // type tags:
|
|
|
54 enum {
|
|
|
55 At, C, D, Dot, E, I, K, Que, S,
|
|
|
56 #if defined USE_SLASH
|
|
|
57 Slash,
|
|
|
58 #endif
|
|
|
59 V, VBar, T0=VBar, // 0 links
|
|
|
60 C1, D1, K1, S1, T1=S1, // 1 link
|
|
|
61 App, S2, App1, App2 // 2 links
|
|
|
62 };
|
|
|
63
|
|
|
64 #if defined DEBUG_REFCOUNT
|
|
|
65 char* tags[] = {"At", "C", "D", "Dot", "E", "I", "K", "Que", "S",
|
|
|
66 #if defined USE_SLASH
|
|
|
67 "Slash",
|
|
|
68 #endif
|
|
|
69 "V", "VBar",
|
|
|
70 "C1", "D1", "K1", "S1", "App", "S2", "App1", "App2"};
|
|
|
71 #endif
|
|
|
72
|
|
|
73 typedef struct info {
|
|
|
74 int tag; // type tag
|
|
|
75 int ref; // reference count, minus one
|
|
|
76 struct info *l;
|
|
|
77 union {
|
|
|
78 struct info *r;
|
|
|
79 char ch;
|
|
|
80 } u;
|
|
|
81 } info;
|
|
|
82
|
|
|
83 #define L l
|
|
|
84 #define R u.r
|
|
|
85 #define CH u.ch
|
|
|
86
|
|
|
87 // All info records with no link fields can be allocated statically.
|
|
|
88 // "eval" is a continuation which applies its argument to e, which
|
|
|
89 // ends the program, and is used in exec()
|
|
|
90 info at={At}, c={C}, d={D}, e={E}, i={I}, k={K}, vbar={VBar}, s={S}, v={V},
|
|
|
91 #if defined USE_SLASH
|
|
|
92 slash={Slash},
|
|
|
93 #endif
|
|
|
94 eval = {App2, 0, &e, {&e}}, dot[256], que[256];
|
|
|
95
|
|
|
96 info *heap;
|
|
|
97 int heap_idx = 0;
|
|
|
98 info *avail = 0;
|
|
|
99
|
|
|
100 #if defined DEBUG_REFCOUNT
|
|
|
101 int allocated, freed;
|
|
|
102 #endif
|
|
|
103
|
|
|
104 // Get a free info record, with ref field == 0 (reference count == 1).
|
|
|
105 inline info *new_info()
|
|
|
106 {
|
|
|
107 #if defined DEBUG_REFCOUNT
|
|
|
108 allocated++;
|
|
|
109 #endif
|
|
|
110 if (avail) {
|
|
|
111 info *t;
|
|
|
112 t = avail;
|
|
|
113 avail = avail->L;
|
|
|
114 #if defined DEBUG_REFCOUNT
|
|
|
115 t->ref++;
|
|
|
116 #endif
|
|
|
117 assert(t->ref == 0);
|
|
|
118 return t;
|
|
|
119 } else {
|
|
|
120 if (!heap_idx) {
|
|
|
121 if (!(heap = malloc(BLOCK_SIZE * sizeof(info))))
|
|
|
122 perror("new_info"), exit(EXIT_FAILURE);
|
|
|
123 heap_idx = BLOCK_SIZE;
|
|
|
124 }
|
|
|
125 heap[--heap_idx].ref = 0; // Would it be better to use calloc above?
|
|
|
126 return heap + heap_idx;
|
|
|
127 }
|
|
|
128 }
|
|
|
129
|
|
|
130 // Increment the reference count on an info struct.
|
|
|
131 #define add_ref(i) ((i)->ref++)
|
|
|
132
|
|
|
133 // Free an info record without checking any reference counts.
|
|
|
134 inline void free_info_no_ref(info *i)
|
|
|
135 {
|
|
|
136 assert(i->ref == 0);
|
|
|
137 #if defined DEBUG_REFCOUNT
|
|
|
138 freed++;
|
|
|
139 i->ref--;
|
|
|
140 #endif
|
|
|
141 i->L = avail;
|
|
|
142 avail = i;
|
|
|
143 }
|
|
|
144
|
|
|
145 // Free a reference counted info record.
|
|
|
146 inline void free_info(info *i)
|
|
|
147 {
|
|
|
148 assert(i);
|
|
|
149 if (i->ref)
|
|
|
150 i->ref--;
|
|
|
151 else {
|
|
|
152 if (i->tag > T0) {
|
|
|
153 free_info(i->L);
|
|
|
154 if (i->tag > T1)
|
|
|
155 free_info(i->R);
|
|
|
156 }
|
|
|
157 free_info_no_ref(i);
|
|
|
158 }
|
|
|
159 }
|
|
|
160
|
|
|
161 // Initialise the dot[] and que[] arrays.
|
|
|
162 void init()
|
|
|
163 {
|
|
|
164 int i;
|
|
|
165 for (i=0; i<256; i++) {
|
|
|
166 dot[i].tag = Dot;
|
|
|
167 dot[i].CH = i;
|
|
|
168 que[i].tag = Que;
|
|
|
169 que[i].CH = i;
|
|
|
170 }
|
|
|
171 }
|
|
|
172
|
|
|
173 // Execute program.
|
|
|
174 void exec(info *prog)
|
|
|
175 {
|
|
|
176 info *cont, *p, *q, *tmp;
|
|
|
177 int current_char;
|
|
|
178
|
|
|
179 current_char = EOF;
|
|
|
180 tmp = new_info();
|
|
|
181 add_ref(cont = &eval);
|
|
|
182 add_ref(prog);
|
|
|
183 for (;;) {
|
|
|
184 // exec cont prog
|
|
|
185 assert(tmp);
|
|
|
186 assert(tmp->ref == 0);
|
|
|
187 if (prog->tag == App) {
|
|
|
188 // exec c (App p1 p2) = exec (App1 p2 c) p1
|
|
|
189 tmp->tag = App1;
|
|
|
190 tmp->R = cont;
|
|
|
191 cont = tmp;
|
|
|
192 p = prog->L;
|
|
|
193 tmp->L = prog->R;
|
|
|
194 if (prog->ref) {
|
|
|
195 prog->ref--;
|
|
|
196 add_ref(prog->L);
|
|
|
197 add_ref(prog->R);
|
|
|
198 tmp = new_info();
|
|
|
199 } else
|
|
|
200 tmp = prog;
|
|
|
201 prog = p;
|
|
|
202 continue;
|
|
|
203 }
|
|
|
204 if (cont->tag == App1) {
|
|
|
205 if (prog->tag == D) {
|
|
|
206 // exec (App1 p c) D = exec c (D1 p)
|
|
|
207 #if 1
|
|
|
208 assert(prog == &d);
|
|
|
209 d.ref--; // free_info(prog);
|
|
|
210 assert(!cont->ref); // all references were inside prog
|
|
|
211 cont->tag = D1;
|
|
|
212 prog = cont;
|
|
|
213 cont = cont->R;
|
|
|
214 #else
|
|
|
215 tmp->tag = D1;
|
|
|
216 assert(prog == &d);
|
|
|
217 d.ref--; // free_info(prog);
|
|
|
218 prog = tmp;
|
|
|
219 tmp->L = cont->L;
|
|
|
220 p = cont->R;
|
|
|
221 if (cont->ref) {
|
|
|
222 cont->ref--;
|
|
|
223 add_ref(cont->L);
|
|
|
224 add_ref(cont->R);
|
|
|
225 tmp = new_info();
|
|
|
226 } else
|
|
|
227 tmp = cont;
|
|
|
228 cont = p;
|
|
|
229 #endif
|
|
|
230 } else {
|
|
|
231 // exec (App1 p1 c) p2 = exec (App2 p2 c) p1
|
|
|
232 #if 0
|
|
|
233 tmp->tag = App2;
|
|
|
234 tmp->L = prog;
|
|
|
235 tmp->R = cont->R;
|
|
|
236 prog = cont->L;
|
|
|
237 p = tmp;
|
|
|
238 if (cont->ref) {
|
|
|
239 cont->ref--;
|
|
|
240 add_ref(cont->L);
|
|
|
241 add_ref(cont->R);
|
|
|
242 tmp = new_info();
|
|
|
243 } else
|
|
|
244 tmp = cont;
|
|
|
245 cont = p;
|
|
|
246 #else
|
|
|
247 if (cont->ref) {
|
|
|
248 cont->ref--;
|
|
|
249 tmp->tag = App2;
|
|
|
250 tmp->L = prog;
|
|
|
251 add_ref(tmp->R = cont->R);
|
|
|
252 add_ref(prog = cont->L);
|
|
|
253 cont = tmp;
|
|
|
254 tmp = new_info();
|
|
|
255 } else {
|
|
|
256 cont->tag = App2;
|
|
|
257 p = cont->L;
|
|
|
258 cont->L = prog;
|
|
|
259 prog = p;
|
|
|
260 }
|
|
|
261 #endif
|
|
|
262 }
|
|
|
263 continue;
|
|
|
264 }
|
|
|
265 assert(cont->tag == App2);
|
|
|
266 // exec (App2 p1 c) p = case p1 of
|
|
|
267 switch ((q=cont->L)->tag) {
|
|
|
268 case S:
|
|
|
269 // S -> exec c (S1 p)
|
|
|
270 tmp->tag = S1;
|
|
|
271 tmp->L = prog;
|
|
|
272 prog = tmp;
|
|
|
273 p = cont->R;
|
|
|
274 if (cont->ref) {
|
|
|
275 cont->ref--;
|
|
|
276 add_ref(cont->R);
|
|
|
277 tmp = new_info();
|
|
|
278 } else {
|
|
|
279 assert(cont->L == &s);
|
|
|
280 s.ref--; // free_info(q);
|
|
|
281 tmp = cont;
|
|
|
282 }
|
|
|
283 cont = p;
|
|
|
284 break;
|
|
|
285 case S1:
|
|
|
286 // S1 p1 -> exec c (S2 p1 p)
|
|
|
287 tmp->tag = S2;
|
|
|
288 tmp->L = q->L;
|
|
|
289 tmp->R = prog;
|
|
|
290 prog = tmp;
|
|
|
291 p = cont->R;
|
|
|
292 if (cont->ref) {
|
|
|
293 cont->ref--;
|
|
|
294 add_ref(q->L);
|
|
|
295 add_ref(cont->R);
|
|
|
296 tmp = new_info();
|
|
|
297 } else {
|
|
|
298 if (q->ref) {
|
|
|
299 q->ref--;
|
|
|
300 add_ref(q->L);
|
|
|
301 } else
|
|
|
302 free_info_no_ref(q);
|
|
|
303 tmp = cont;
|
|
|
304 }
|
|
|
305 cont = p;
|
|
|
306 break;
|
|
|
307 case S2:
|
|
|
308 // S2 p1 p2 -> exec (App1 p (App1 (App p2 p) c)) p1
|
|
|
309 // **NOTE** This wastes a bit of time, as p1,p,p2,p are evaluated
|
|
|
310 // again, or better, their tag is checked just to find out that
|
|
|
311 // it's not App, which is not necessary as we already knew that.
|
|
|
312 // Some options:
|
|
|
313 // - introduce a tag "App3" meaning "works exactly as App1, but
|
|
|
314 // with all arguments already evaluated"
|
|
|
315 // - consider gotos (yuk) to avoid the prog->tag==App check at the
|
|
|
316 // beginning of the loop
|
|
|
317 // - introduce an AppE program tag meaning "like App, but both
|
|
|
318 // parts already evaluated, transform directly to App3"
|
|
|
319 // - (does not really belong here) swap the two fields of App1 -
|
|
|
320 // to make the right side of an App always go to the ->R field
|
|
|
321 // and maybe save some data movement.
|
|
|
322 // **TODO**: Implement this and check whether it actually makes
|
|
|
323 // the program run faster; I'm not sure about this.
|
|
|
324 p = new_info();
|
|
|
325 p->tag = App;
|
|
|
326 p->L = q->R;
|
|
|
327 add_ref(p->R = prog);
|
|
|
328 tmp->tag = App1;
|
|
|
329 tmp->L = p;
|
|
|
330 tmp->R = cont->R;
|
|
|
331 if (cont->ref) {
|
|
|
332 cont->ref--;
|
|
|
333 add_ref(cont->R);
|
|
|
334 cont = new_info();
|
|
|
335 cont->tag = App1;
|
|
|
336 cont->L = prog;
|
|
|
337 cont->R = tmp;
|
|
|
338 prog = q->L;
|
|
|
339 add_ref(q->R);
|
|
|
340 add_ref(q->L);
|
|
|
341 tmp = new_info();
|
|
|
342 } else {
|
|
|
343 cont->tag = App1;
|
|
|
344 cont->L = prog;
|
|
|
345 cont->R = tmp;
|
|
|
346 prog = q->L;
|
|
|
347 if (q->ref) {
|
|
|
348 q->ref--;
|
|
|
349 add_ref(q->R);
|
|
|
350 add_ref(q->L);
|
|
|
351 tmp = new_info();
|
|
|
352 } else
|
|
|
353 tmp = q;
|
|
|
354 }
|
|
|
355 break;
|
|
|
356 case K:
|
|
|
357 // K -> exec c (K1 p)
|
|
|
358 tmp->tag = K1;
|
|
|
359 tmp->L = prog;
|
|
|
360 prog = tmp;
|
|
|
361 p = cont->R;
|
|
|
362 if (cont->ref) {
|
|
|
363 cont->ref--;
|
|
|
364 add_ref(cont->R);
|
|
|
365 tmp = new_info();
|
|
|
366 } else {
|
|
|
367 assert(cont->L == &k);
|
|
|
368 k.ref--; // free_info(q);
|
|
|
369 tmp = cont;
|
|
|
370 }
|
|
|
371 cont = p;
|
|
|
372 break;
|
|
|
373 case K1:
|
|
|
374 // K1 p1 -> exec c p1
|
|
|
375 free_info(prog);
|
|
|
376 prog = q->L;
|
|
|
377 p = cont->R;
|
|
|
378 assert(!cont->ref); // all references were inside prog
|
|
|
379 if (0 && cont->ref) {
|
|
|
380 cont->ref--;
|
|
|
381 add_ref(q->L);
|
|
|
382 add_ref(cont->R);
|
|
|
383 } else {
|
|
|
384 free_info_no_ref(cont);
|
|
|
385 if (q->ref) {
|
|
|
386 q->ref--;
|
|
|
387 add_ref(q->L);
|
|
|
388 } else
|
|
|
389 free_info_no_ref(q);
|
|
|
390 }
|
|
|
391 cont = p;
|
|
|
392 break;
|
|
|
393 case Dot:
|
|
|
394 // Dot char -> putChar char >> exec c p
|
|
|
395 #if !defined SILENT
|
|
|
396 putchar(q->CH);
|
|
|
397 // fflush(stdout); // slow :-|
|
|
|
398 #endif
|
|
|
399 /* fall through */
|
|
|
400 case I:
|
|
|
401 // I -> exec c p
|
|
|
402 p = cont->R;
|
|
|
403 if (cont->ref) {
|
|
|
404 cont->ref--;
|
|
|
405 add_ref(cont->R);
|
|
|
406 } else {
|
|
|
407 assert(cont->L == &i || (unsigned)(cont->L - dot) < 256);
|
|
|
408 q->ref--; // free_info(q);
|
|
|
409 free_info_no_ref(cont);
|
|
|
410 }
|
|
|
411 cont = p;
|
|
|
412 break;
|
|
|
413 case V:
|
|
|
414 // V -> exec c V
|
|
|
415 free_info(prog);
|
|
|
416 prog = q;
|
|
|
417 p = cont->R;
|
|
|
418 assert(!cont->ref); // all references were inside prog
|
|
|
419 if (0 && cont->ref) {
|
|
|
420 cont->ref--;
|
|
|
421 add_ref(cont->L);
|
|
|
422 add_ref(cont->R);
|
|
|
423 } else
|
|
|
424 free_info_no_ref(cont);
|
|
|
425 cont = p;
|
|
|
426 break;
|
|
|
427 case At:
|
|
|
428 // At -> isEOF >>= \eof ->
|
|
|
429 // if (eof) then current_char=EOF `seq`
|
|
|
430 // exec (App1 V c) p
|
|
|
431 // else getChar >>= \ch ->
|
|
|
432 // current_char=ch `seq`
|
|
|
433 // exec (App1 I c) p
|
|
|
434 // **NOTE** See comment at S2.
|
|
|
435 current_char = getchar();
|
|
|
436 tmp->tag = App1;
|
|
|
437 tmp->R = cont->R;
|
|
|
438 add_ref(tmp->L = (current_char!=EOF) ? &i : &v);
|
|
|
439 p = tmp;
|
|
|
440 if (cont->ref) {
|
|
|
441 cont->ref--;
|
|
|
442 add_ref(cont->R);
|
|
|
443 tmp = new_info();
|
|
|
444 } else {
|
|
|
445 assert(cont->L == &at);
|
|
|
446 at.ref--; // free_info(q);
|
|
|
447 tmp = cont;
|
|
|
448 }
|
|
|
449 cont = p;
|
|
|
450 break;
|
|
|
451 case VBar:
|
|
|
452 // VBar -> exec (App1 (maybe V Dot current_char) c) p
|
|
|
453 // **NOTE** See comment at S2.
|
|
|
454 tmp->tag = App1;
|
|
|
455 tmp->R = cont->R;
|
|
|
456 add_ref(tmp->L = (current_char!=EOF) ? dot+current_char : &v);
|
|
|
457 p = tmp;
|
|
|
458 if (cont->ref) {
|
|
|
459 cont->ref--;
|
|
|
460 add_ref(cont->R);
|
|
|
461 tmp = new_info();
|
|
|
462 } else {
|
|
|
463 assert(cont->L == &vbar);
|
|
|
464 vbar.ref--; // free_info(q);
|
|
|
465 tmp = cont;
|
|
|
466 }
|
|
|
467 cont = p;
|
|
|
468 break;
|
|
|
469 #if defined USE_SLASH
|
|
|
470 case Slash:
|
|
|
471 // Slash -> exec (App1 (maybe V Que current_char) c) p
|
|
|
472 // **NOTE** See comment at S2.
|
|
|
473 tmp->tag = App1;
|
|
|
474 tmp->R = cont->R;
|
|
|
475 add_ref(tmp->L = (current_char!=EOF) ? que+current_char : &v);
|
|
|
476 p = tmp;
|
|
|
477 if (cont->ref) {
|
|
|
478 cont->ref--;
|
|
|
479 add_ref(cont->R);
|
|
|
480 tmp = new_info();
|
|
|
481 } else {
|
|
|
482 assert(cont->L == &slash);
|
|
|
483 slash.ref--; // free_info(q);
|
|
|
484 tmp = cont;
|
|
|
485 }
|
|
|
486 cont = p;
|
|
|
487 break;
|
|
|
488 #endif
|
|
|
489 case Que:
|
|
|
490 // Que char -> exec (App1 (if (Just char) == ch then I else V) c) p
|
|
|
491 // **NOTE** See comment at S2.
|
|
|
492 tmp->tag = App1;
|
|
|
493 tmp->R = cont->R;
|
|
|
494 add_ref(tmp->L = (current_char==q->CH) ? &i : &v);
|
|
|
495 p = tmp;
|
|
|
496 if (cont->ref) {
|
|
|
497 cont->ref--;
|
|
|
498 add_ref(cont->R);
|
|
|
499 tmp = new_info();
|
|
|
500 } else {
|
|
|
501 assert((unsigned)(cont->L - que) < 256);
|
|
|
502 q->ref--; // free_info(q);
|
|
|
503 tmp = cont;
|
|
|
504 }
|
|
|
505 cont = p;
|
|
|
506 break;
|
|
|
507 case D1:
|
|
|
508 // D1 p1 -> exec (App1 p c) p1
|
|
|
509 // **NOTE** See comment at S2.
|
|
|
510 tmp->tag = App1;
|
|
|
511 tmp->L = prog;
|
|
|
512 tmp->R = cont->R;
|
|
|
513 prog = q->L;
|
|
|
514 p = tmp;
|
|
|
515 if (cont->ref) {
|
|
|
516 cont->ref--;
|
|
|
517 add_ref(cont->R);
|
|
|
518 add_ref(q->L);
|
|
|
519 tmp = new_info();
|
|
|
520 } else {
|
|
|
521 if (q->ref) {
|
|
|
522 q->ref--;
|
|
|
523 add_ref(q->L);
|
|
|
524 } else
|
|
|
525 free_info_no_ref(q);
|
|
|
526 tmp = cont;
|
|
|
527 }
|
|
|
528 cont = p;
|
|
|
529 break;
|
|
|
530 case C:
|
|
|
531 // C -> exec (App1 (C1 c) c) p
|
|
|
532 // **NOTE** See comment at S2.
|
|
|
533 tmp->tag = C1;
|
|
|
534 tmp->L = cont->R;
|
|
|
535 if (cont->ref) {
|
|
|
536 cont->ref--;
|
|
|
537 cont->R->ref += 2; // add_ref, twice
|
|
|
538 cont = new_info();
|
|
|
539 } else {
|
|
|
540 add_ref(cont->R);
|
|
|
541 assert(cont->L == &c);
|
|
|
542 c.ref--;
|
|
|
543 }
|
|
|
544 cont->tag = App1;
|
|
|
545 cont->L = tmp;
|
|
|
546 cont->R = tmp->L;
|
|
|
547 tmp = new_info();
|
|
|
548 break;
|
|
|
549 case C1:
|
|
|
550 // C1 c1 -> exec c1 p
|
|
|
551 #if 0
|
|
|
552 // *note*: cont == (App2 (C1 c) c') is equivalent to cont == c,
|
|
|
553 // so we just copy c's values to cont (instead of using c as
|
|
|
554 // the new continuation), thus affecting all references to cont.
|
|
|
555 // This is a clear win for ``ci`.*`cr, regarding both memory
|
|
|
556 // consumption and speed, and it should not hurt most other
|
|
|
557 // programs.
|
|
|
558 // Also, we can now execute ``ci`ci in a limited amount of memory.
|
|
|
559 // *note*: this assumes that all continuations contain two links.
|
|
|
560 free_info(cont->R);
|
|
|
561 cont->tag = q->L->tag;
|
|
|
562 cont->L = q->L->L;
|
|
|
563 cont->R = q->L->R;
|
|
|
564 if (q->ref) {
|
|
|
565 q->ref--;
|
|
|
566 add_ref(q->L->L);
|
|
|
567 add_ref(q->L->R);
|
|
|
568 } else {
|
|
|
569 if (q->L->ref) {
|
|
|
570 q->L->ref--;
|
|
|
571 add_ref(q->L->L);
|
|
|
572 add_ref(q->L->R);
|
|
|
573 } else
|
|
|
574 free_info_no_ref(q->L);
|
|
|
575 free_info_no_ref(q);
|
|
|
576 }
|
|
|
577 #else
|
|
|
578 p = q->L;
|
|
|
579 if (cont->ref) {
|
|
|
580 cont->ref--;
|
|
|
581 add_ref(q->L);
|
|
|
582 } else {
|
|
|
583 if (q->ref) {
|
|
|
584 q->ref--;
|
|
|
585 add_ref(q->L);
|
|
|
586 } else
|
|
|
587 free_info_no_ref(q);
|
|
|
588 free_info(cont->R);
|
|
|
589 free_info_no_ref(cont);
|
|
|
590 }
|
|
|
591 cont = p;
|
|
|
592 #endif
|
|
|
593 break;
|
|
|
594 case E:
|
|
|
595 // E -> return ()
|
|
|
596 #if defined DEBUG_REFCOUNT || defined FREE_ALL
|
|
|
597 free_info(prog);
|
|
|
598 free_info(cont);
|
|
|
599 free_info_no_ref(tmp);
|
|
|
600 #endif
|
|
|
601 return;
|
|
|
602 default:
|
|
|
603 assert(!App & !D);
|
|
|
604 }
|
|
|
605 }
|
|
|
606 }
|
|
|
607
|
|
|
608 // Parse input from file f and return parsed program.
|
|
|
609 info *parse(FILE *f)
|
|
|
610 {
|
|
|
611 info *p, *q, *t;
|
|
|
612 int ch;
|
|
|
613
|
|
|
614 do { // Skip whitespace and comments.
|
|
|
615 while ((ch = getc(f)) == '#')
|
|
|
616 while ((ch = getc(f)) != '\n')
|
|
|
617 ;
|
|
|
618 } while (isspace(ch));
|
|
|
619
|
|
|
620 switch (tolower(ch)) {
|
|
|
621 case '@':
|
|
|
622 // '@' -> (At, s)
|
|
|
623 at.ref++;
|
|
|
624 return &at;
|
|
|
625 case 'c':
|
|
|
626 // 'c' -> (C, s)
|
|
|
627 c.ref++;
|
|
|
628 return &c;
|
|
|
629 case 'd':
|
|
|
630 // 'd' -> (D, s)
|
|
|
631 d.ref++;
|
|
|
632 return &d;
|
|
|
633 case 'e':
|
|
|
634 // 'e' -> (E, s)
|
|
|
635 e.ref++;
|
|
|
636 return &e;
|
|
|
637 case 'i':
|
|
|
638 // 'i' -> (I, s)
|
|
|
639 i.ref++;
|
|
|
640 return &i;
|
|
|
641 case 'k':
|
|
|
642 // 'k' -> (K, s)
|
|
|
643 k.ref++;
|
|
|
644 return &k;
|
|
|
645 case '|':
|
|
|
646 // '|' -> (VBar, s)
|
|
|
647 vbar.ref++;
|
|
|
648 return &vbar;
|
|
|
649 #ifdef USE_SLASH
|
|
|
650 case '/':
|
|
|
651 // '/' -> (Slash, s)
|
|
|
652 slash.ref++;
|
|
|
653 return &slash;
|
|
|
654 #endif
|
|
|
655 case 's':
|
|
|
656 // 's' -> (S, s)
|
|
|
657 s.ref++;
|
|
|
658 return &s;
|
|
|
659 case 'v':
|
|
|
660 // 'v' -> (V, s)
|
|
|
661 v.ref++;
|
|
|
662 return &v;
|
|
|
663 case 'r':
|
|
|
664 // 'r' -> (Dot '\n', s)
|
|
|
665 dot['\n'].ref++;
|
|
|
666 return dot+'\n';
|
|
|
667 case '.':
|
|
|
668 // '.' -> let (c:s1) = s in (Dot c, s1)
|
|
|
669 if ((ch = getc(f))==EOF)
|
|
|
670 return 0;
|
|
|
671 dot[ch].ref++;
|
|
|
672 return dot+ch;
|
|
|
673 case '?':
|
|
|
674 // '?' -> let (c:s1) = s in (Que c, s1)
|
|
|
675 if ((ch = getc(f))==EOF)
|
|
|
676 return 0;
|
|
|
677 que[ch].ref++;
|
|
|
678 return que+ch;
|
|
|
679 case '`':
|
|
|
680 // '`' -> let (p1, s1) = parse_ s in
|
|
|
681 // let (p2, s2) = parse_ s1 in (App p1 p2, s2)
|
|
|
682 if (!(p=parse(f)))
|
|
|
683 return 0;
|
|
|
684 if (!(q=parse(f))) {
|
|
|
685 free_info(p);
|
|
|
686 return 0;
|
|
|
687 }
|
|
|
688 t = new_info();
|
|
|
689 assert(t);
|
|
|
690 t->tag = App;
|
|
|
691 t->L = p;
|
|
|
692 t->R = q;
|
|
|
693 return t;
|
|
|
694 default:
|
|
|
695 // otherwise -> error "Unlambda.parse: parse error"
|
|
|
696 return 0;
|
|
|
697 }
|
|
|
698 }
|
|
|
699
|
|
|
700
|
|
|
701 int main(int argc, char **argv)
|
|
|
702 {
|
|
|
703 FILE *f;
|
|
|
704 info *p;
|
|
|
705
|
|
|
706 init();
|
|
|
707 if (argc<2 || !(f=fopen(argv[1], "r"))) {
|
|
|
708 fprintf(stderr, "Usage: %s <file name>\n", argv[0]);
|
|
|
709 exit(1);
|
|
|
710 }
|
|
|
711 if (!(p=parse(f))) {
|
|
|
712 fprintf(stderr, "%s: file %s: parse error\n", argv[0], argv[1]);
|
|
|
713 fclose(f);
|
|
|
714 exit(1);
|
|
|
715 }
|
|
|
716 fclose(f);
|
|
|
717
|
|
|
718 exec(p);
|
|
|
719
|
|
|
720 #if defined DEBUG_REFCOUNT || defined FREE_ALL
|
|
|
721 free_info(p);
|
|
|
722 #endif
|
|
|
723 #if defined DEBUG_REFCOUNT
|
|
|
724 fflush(stdout);
|
|
|
725 fprintf(stderr, "\n%s: %d allocated; %d freed\n",
|
|
|
726 argv[0], allocated, freed);
|
|
|
727
|
|
|
728 #define CHECK_ATOM(x) \
|
|
|
729 if (x.ref != 0) \
|
|
|
730 fprintf(stderr, #x " ref count is %d\n", x.ref);
|
|
|
731
|
|
|
732 CHECK_ATOM(at);
|
|
|
733 CHECK_ATOM(c);
|
|
|
734 CHECK_ATOM(d);
|
|
|
735 CHECK_ATOM(e);
|
|
|
736 CHECK_ATOM(i);
|
|
|
737 CHECK_ATOM(k);
|
|
|
738 CHECK_ATOM(vbar);
|
|
|
739 CHECK_ATOM(s);
|
|
|
740 CHECK_ATOM(v);
|
|
|
741 {
|
|
|
742 int i;
|
|
|
743 for (i=0; i<256; i++)
|
|
|
744 if (dot[i].ref != 0)
|
|
|
745 fprintf(stderr, ".%c ref count is %d\n", i, dot[i].ref);
|
|
|
746 }
|
|
|
747 while (avail) {
|
|
|
748 avail->ref = -1;
|
|
|
749 avail = avail->L;
|
|
|
750 }
|
|
|
751 // check heap (only last allocated block!) for lost items
|
|
|
752 for (;heap_idx<BLOCK_SIZE;heap_idx++)
|
|
|
753 if (heap[heap_idx].ref != -1) {
|
|
|
754 fprintf(stderr, "heap item left: tag =%2d (%4s), ref =%2d\n",
|
|
|
755 heap[heap_idx].tag, tags[heap[heap_idx].tag],
|
|
|
756 heap[heap_idx].ref);
|
|
|
757 }
|
|
|
758 #endif
|
|
|
759
|
|
|
760 return 0;
|
|
|
761 }
|
