Mercurial > repo

comparison interps/lazyk/lazy.cpp @ 996:859f9b4339e6

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
<Gregor> tar xf egobot.tar.xz
author HackBot
date Sun, 09 Dec 2012 19:30:08 +0000
parents
children
comparison
equal deleted inserted replaced
995:6883f5911eb7 996:859f9b4339e6
1 // Lazy K interpreter in C++.
2 // For usage see usage() function below.
3 // Copyright 2002 Ben Rudiak-Gould. Distributed under the GPL.
4 //
5 // Implementation notes:
6 // - When Sxyz is reduced to (xz)(yz), both "copies" of z
7 // point to the same expression tree. When z (or any of
8 // its subexpressions) is reduced, the old tree nodes are
9 // overwritten with their newly reduced versions, so that
10 // any other pointers to the node get the benefit of the
11 // change. This is critical to the performance of any
12 // lazy evaluator. Despite this destructive update, the
13 // meaning (i.e. behavior) of the function described by
14 // any subtree never changes (until the nodes are
15 // garbage-collected and reassigned, that is).
16 // - I actually got stack overflows in the evaluator when
17 // running complicated programs (e.g. prime_numbers.unl
18 // inside the Unlambda interpreter), so I rewrote it to
19 // eliminate recursion from partial_eval() and free().
20 // These functions now use relatively abstruse iterative
21 // algorithms which borrow expression tree pointers for
22 // temporary storage, and restore the original values
23 // where necessary before returning. Other than that, the
24 // interpreter is pretty simple to understand. The only
25 // recursion left (I think) is in the parser and in the
26 // Inc case of partial_eval_primitive_application; the
27 // former will only bite you if you have really deep
28 // nesting in your source code, and the latter only if
29 // you return a ridiculously large number in the output
30 // stream.
31 //
32
33
34 #include <stdio.h>
35 #include <fcntl.h>
36 #include <stdlib.h>
37 #include <ctype.h>
38 #include <sys/stat.h>
39 #include <sys/types.h>
40 #include <unistd.h>
41
42 #ifdef __WIN32
43 #include <io.h>
44 #else
45 #define O_BINARY 0
46 #endif
47
48 class Expr {
49 private:
50 int refcnt;
51 union {
52 Expr* arg1;
53 int numeric_arg1;
54 };
55 Expr* arg2;
56
57 static Expr* free_list;
58 static Expr* alloc();
59 void free();
60
61 void partial_eval_primitive_application();
62
63 public:
64 enum Type { A, K, K1, S, S1, S2, I1, LazyRead, Inc, Num, Free } type;
65
66 static void* operator new(size_t) {
67 Expr* result = free_list;
68 if (result) {
69 free_list = result->arg1;
70 return result;
71 } else {
72 return alloc();
73 }
74 }
75
76 // caller keeps original ref plus returned ref
77 Expr* dup() {
78 ++refcnt;
79 return this;
80 }
81 // caller loses original ref
82 void deref() {
83 if (--refcnt == 0) {
84 free();
85 }
86 }
87
88 // caller keeps original ref
89 Type gettype() { return type; }
90
91 // caller loses refs to a1 and a2, gets ref to new object
92 Expr(Type t, Expr* a1 =0, Expr* a2 =0) {
93 refcnt = 1;
94 type = t;
95 arg1 = a1; arg2 = a2;
96 }
97
98 // caller loses original ref, gets returned ref
99 Expr* partial_eval();
100
101 // caller loses original ref, gets returned ref
102 static Expr* partial_apply(Expr* lhs, Expr* rhs) {
103 // You could do something more complicated here,
104 // but I tried it and it didn't seem to improve
105 // execution speed.
106 return new Expr(A, lhs, rhs);
107 }
108
109 // caller loses original ref
110 int to_number() {
111 int result = (type == Num) ? numeric_arg1 : -1;
112 deref();
113 return result;
114 }
115 #if 0
116 void print(Expr*);
117 #endif
118 // caller loses original ref, gets returned ref
119 Expr* drop_i1() {
120 Expr* cur = this;
121 if (type == I1) {
122 do {
123 cur = cur->arg1;
124 } while (cur->type == I1);
125 cur = cur->dup();
126 this->deref();
127 }
128 return cur;
129 }
130 };
131
132
133 Expr* Expr::free_list = 0;
134
135
136 Expr K(Expr::K);
137 Expr S(Expr::S);
138 Expr I(Expr::S2, &K, &K);
139 Expr KI(Expr::K1, &I);
140
141 Expr SI(Expr::S1, &I);
142 Expr KS(Expr::K1, &S);
143 Expr KK(Expr::K1, &K);
144 Expr SKSK(Expr::S2, &KS, &K);
145 Expr SIKS(Expr::S2, &I, &KS);
146 Expr Iota(Expr::S2, &SIKS, &KK);
147
148 Expr Inc(Expr::Inc);
149 Expr Zero(Expr::Num);
150
151
152 Expr* Expr::alloc() {
153 enum { blocksize = 10000 };
154 static Expr* p = 0;
155 static Expr* end = 0;
156 if (p >= end) {
157 p = (Expr*)malloc(blocksize*sizeof(Expr));
158 if (p == 0) {
159 fputs("Out of memory!\n", stderr);
160 exit(2);
161 }
162 end = p + blocksize;
163 }
164 return p++;
165 }
166
167 #if 0
168 void Expr::print(Expr* highlight) {
169 if (this == highlight) {
170 fputs("###", stdout);
171 }
172 switch (type) {
173 case A:
174 putchar('(');
175 arg1->print(highlight);
176 putchar(' ');
177 arg2->print(highlight);
178 putchar(')');
179 break;
180 case K:
181 putchar('K');
182 break;
183 case K1:
184 fputs("[K ", stdout);
185 arg1->print(highlight);
186 putchar(']');
187 break;
188 case S:
189 putchar('S');
190 break;
191 case S1:
192 fputs("[s ", stdout);
193 arg1->print(highlight);
194 putchar(']');
195 break;
196 case S2:
197 fputs("[S ", stdout);
198 arg1->print(highlight);
199 putchar(' ');
200 arg2->print(highlight);
201 putchar(']');
202 break;
203 case I1:
204 putchar('.');
205 arg1->print(highlight);
206 break;
207 case LazyRead:
208 fputs("LazyRead", stdout);
209 break;
210 case Inc:
211 fputs("Inc", stdout);
212 break;
213 case Num:
214 printf("%d", numeric_arg1);
215 break;
216 default:
217 putchar('?');
218 }
219 if (this == highlight) {
220 fputs("###", stdout);
221 }
222 }
223 #endif
224
225 Expr* make_church_char(int ch) {
226 if (ch < 0 || ch > 256) {
227 ch = 256;
228 }
229
230 static Expr* cached_church_chars[257] = { KI.dup(), I.dup() };
231
232 if (cached_church_chars[ch] == 0) {
233 cached_church_chars[ch] = new Expr(Expr::S2, SKSK.dup(), make_church_char(ch-1));
234 }
235 return cached_church_chars[ch]->dup();
236 }
237
238
239 Expr* g_expr;
240
241
242 // This function modifies the object in-place so that
243 // all references to it see the new version.
244
245 void Expr::partial_eval_primitive_application() {
246 Expr* lhs = arg1;
247 Expr* rhs = arg2->drop_i1();
248
249 // arg1 and arg2 are now uninitialized space
250
251 switch (lhs->type) {
252 case K:
253 type = K1;
254 arg1 = rhs;
255 arg2 = 0;
256 break;
257 case K1:
258 type = I1;
259 arg1 = lhs->arg1->dup();
260 arg2 = 0;
261 rhs->deref();
262 break;
263 case S:
264 type = S1;
265 arg1 = rhs;
266 arg2 = 0;
267 break;
268 case S1:
269 type = S2;
270 arg1 = lhs->arg1->dup();
271 arg2 = rhs;
272 break;
273 case LazyRead:
274 lhs->type = S2;
275 lhs->arg1 = new Expr(S2, I.dup(), new Expr(K1, make_church_char(getchar())));
276 lhs->arg2 = new Expr(K1, new Expr(LazyRead));
277 // fall thru
278 case S2:
279 //type = A;
280 arg1 = partial_apply(lhs->arg1->dup(), rhs->dup());
281 arg2 = partial_apply(lhs->arg2->dup(), rhs);
282 break;
283 case Inc:
284 rhs = rhs->partial_eval();
285 type = Num;
286 numeric_arg1 = rhs->to_number() + 1;
287 if (numeric_arg1 == 0) {
288 fputs("Runtime error: invalid output format (attempted to apply inc to a non-number)\n", stderr);
289 exit(3);
290 }
291 arg2 = 0;
292 break;
293 case Num:
294 fputs("Runtime error: invalid output format (attempted to apply a number)\n", stderr);
295 exit(3);
296 default:
297 fprintf(stderr, "INTERNAL ERROR: invalid type in partial_eval_primitive_application (%d)\n", lhs->type);
298 exit(4);
299 }
300 lhs->deref();
301 }
302
303
304 Expr* Expr::partial_eval() {
305 Expr* prev = 0;
306 Expr* cur = this;
307 for (;;) {
308 cur = cur->drop_i1();
309 while (cur->type == A) {
310 Expr* next = cur->arg1->drop_i1();
311 cur->arg1 = prev;
312 prev = cur; cur = next;
313 }
314 if (!prev) {
315 return cur;
316 }
317 Expr* next = cur; cur = prev;
318 prev = cur->arg1;
319 cur->arg1 = next;
320 cur->partial_eval_primitive_application();
321 }
322 }
323
324
325 /*
326 void Expr::free() {
327 if (type != Num) {
328 if (arg1) arg1->deref();
329 if (arg2) arg2->deref();
330 }
331 type = Free;
332 arg1 = free_list;
333 free_list = this;
334 }
335 */
336
337 void Expr::free() {
338 Expr* cur = this;
339 Expr* partially_free_list = 0;
340 for (;;) {
341 while (--cur->refcnt <= 0 && cur->arg1 != 0 && cur->type != Num) {
342 Expr* next = cur->arg1;
343 if (cur->arg2 != 0) {
344 cur->arg1 = partially_free_list;
345 partially_free_list = cur;
346 } else {
347 cur->arg1 = free_list;
348 free_list = cur;
349 }
350 cur = next;
351 }
352 if (partially_free_list == 0) {
353 break;
354 }
355 cur = partially_free_list;
356 partially_free_list = partially_free_list->arg1;
357 cur->arg1 = free_list;
358 free_list = cur;
359 cur = cur->arg2;
360 }
361 }
362
363
364 class Stream {
365 public:
366 virtual int getch() = 0;
367 virtual void ungetch(int ch) = 0;
368 virtual void error(const char* msg) = 0;
369 };
370
371 class File : public Stream {
372 FILE* f;
373 const char* filename;
374 enum { circular_buf_size = 256 };
375 char circular_buf[circular_buf_size];
376 int last_newline, cur_pos;
377 public:
378 File(FILE* _f, const char* _filename) {
379 f = _f; filename = _filename;
380 last_newline = cur_pos = 0;
381 }
382 int getch();
383 void ungetch(int ch);
384 void error(const char* msg);
385 };
386
387 int File::getch() {
388 int ch;
389 do {
390 ch = getc(f);
391 circular_buf[(cur_pos++)%circular_buf_size] = ch;
392 if (ch == '#') {
393 do {
394 ch = getc(f);
395 } while (ch != '\n' && ch != EOF);
396 }
397 if (ch == '\n') {
398 last_newline = cur_pos;
399 }
400 } while (isspace(ch));
401 return ch;
402 }
403
404 void File::ungetch(int ch) {
405 ungetc(ch, f);
406 --cur_pos;
407 }
408
409 void File::error(const char* msg) {
410 fprintf(stderr, "While parsing \"%s\": %s\n", filename, msg);
411 int from;
412 if (cur_pos-last_newline < circular_buf_size) {
413 from = last_newline;
414 } else {
415 from = cur_pos-circular_buf_size+1;
416 fputs("...", stdout);
417 }
418 for (int i=from; i < cur_pos; ++i) {
419 putc(circular_buf[i%circular_buf_size], stderr);
420 }
421 fputs(" <--\n", stderr);
422 exit(1);
423 }
424
425 class StringStream : public Stream {
426 const char* str;
427 const char* p;
428 public:
429 StringStream(const char* s) {
430 str = s; p = s;
431 }
432 int getch() {
433 return *p ? *p++ : EOF;
434 }
435 void ungetch(int ch) {
436 if (ch != EOF) --p;
437 }
438 void error(const char* msg) {
439 fprintf(stderr, "While parsing command line: %s\n%s\n", msg, str);
440 for (const char* q = str+1; q < p; ++q) {
441 putc(' ', stderr);
442 }
443 fputs("^\n", stderr);
444 exit(1);
445 }
446 };
447
448
449 Expr* parse_expr(Stream* f, int ch, bool i_is_iota);
450
451 Expr* parse_manual_close(Stream* f, int expected_terminator);
452
453
454 Expr* parse_expr(Stream* f, int ch, bool i_is_iota) {
455 switch (ch) {
456 case '`': case '*':
457 {
458 Expr* p = parse_expr(f, f->getch(), ch=='*');
459 Expr* q = parse_expr(f, f->getch(), ch=='*');
460 return Expr::partial_apply(p, q);
461 }
462 case '(':
463 return parse_manual_close(f, ')');
464 case ')':
465 f->error("Mismatched close-parenthesis!");
466 case 'k': case 'K':
467 return K.dup();
468 case 's': case 'S':
469 return S.dup();
470 case 'i':
471 if (i_is_iota)
472 return Iota.dup();
473 // else fall thru
474 case 'I':
475 return I.dup();
476 case '0': case '1':
477 {
478 Expr* e = I.dup();
479 do {
480 if (ch == '0') {
481 e = Expr::partial_apply(Expr::partial_apply(e, S.dup()), K.dup());
482 } else {
483 e = Expr::partial_apply(S.dup(), Expr::partial_apply(K.dup(), e));
484 }
485 ch = f->getch();
486 } while (ch == '0' || ch == '1');
487 f->ungetch(ch);
488 return e;
489 }
490 default:
491 f->error("Invalid character!");
492 }
493 return 0;
494 }
495
496
497 Expr* parse_manual_close(Stream* f, int expected_terminator) {
498 Expr* e = 0;
499 int peek;
500 while (peek = f->getch(), peek != ')' && peek != EOF) {
501 Expr* e2 = parse_expr(f, peek, false);
502 e = e ? Expr::partial_apply(e, e2) : e2;
503 }
504 if (peek != expected_terminator) {
505 f->error(peek == EOF ? "Premature end of program!" : "Unmatched trailing close-parenthesis!");
506 }
507 if (e == 0) {
508 e = I.dup();
509 }
510 return e;
511 }
512
513
514 static Expr* car(Expr* list) {
515 return Expr::partial_apply(list, K.dup());
516 }
517
518 static Expr* cdr(Expr* list) {
519 return Expr::partial_apply(list, KI.dup());
520 }
521
522 static int church2int(Expr* church) {
523 Expr* e = Expr::partial_apply(Expr::partial_apply(church, Inc.dup()), Zero.dup());
524 g_expr = e;
525 int result = e->partial_eval()->to_number();
526 if (result == -1) {
527 fputs("Runtime error: invalid output format (result was not a number)\n", stderr);
528 exit(3);
529 }
530 return result;
531 }
532
533
534 Expr* compose(Expr* f, Expr* g) {
535 return new Expr(Expr::S2, new Expr(Expr::K1, f), g);
536 }
537
538
539 Expr* append_program(Expr* old, Stream* stream) {
540 return compose(parse_manual_close(stream, EOF), old);
541 }
542
543
544 void usage() {
545 fputs(
546 "usage: lazy [-b] { -e program | program-file.lazy } *\n"
547 "\n"
548 " -b puts stdin and stdout into binary mode on systems that care\n"
549 " (i.e. Windows)\n"
550 "\n"
551 " -e program takes program code from the command line (like Perl's -e\n"
552 " switch)\n"
553 "\n"
554 " program-file.lazy name of file containing program code\n"
555 "\n"
556 " If more than one -e or filename argument is given, the programs will be\n"
557 " combined by functional composition (but in Unix pipe order, not mathematical-\n"
558 " notation order). If no -e or filename argument is given, the result is a\n"
559 " degenerate composition, i.e. the identity function.\n", stdout);
560 exit(0);
561 }
562
563
564 int main(int argc, char** argv) {
565 Expr* e = I.dup();
566 for (int i=1; i<argc; ++i) {
567 if (argv[i][0] == '-') {
568 switch (argv[i][1]) {
569 case 0:
570 {
571 File f = File(stdin, "(standard input)");
572 e = append_program(e, &f);
573 break;
574 }
575 case 'b':
576 #ifdef __WIN32
577 setmode(fileno(stdin), O_BINARY);
578 setmode(fileno(stdout), O_BINARY);
579 #endif
580 break;
581 case 'e':
582 {
583 ++i;
584 if (i == argc) {
585 usage();
586 }
587 StringStream s = StringStream(argv[i]);
588 e = append_program(e, &s);
589 break;
590 }
591 default:
592 usage();
593 }
594 } else {
595 FILE* f = fopen(argv[i], "r");
596 if (!f) {
597 fprintf(stderr, "Unable to open the file \"%s\".\n", argv[i]);
598 exit(1);
599 }
600 File ff = File(f, argv[i]);
601 e = append_program(e, &ff);
602 }
603 }
604 e = Expr::partial_apply(e, new Expr(Expr::LazyRead));
605 for (;;) {
606 int ch = church2int(car(e->dup()));
607 if (ch >= 256)
608 return ch-256;
609 putchar(ch);
610 e = cdr(e);
611 }
612 }