parser.c (16930B)
1 /* See LICENSE file for copyright and license details. */ 2 #include <stdbool.h> 3 #include <stdio.h> 4 #include <stdlib.h> 5 #include <string.h> 6 #include "lexer.h" 7 #include "parser.h" 8 #include "sym.h" 9 #include "util.h" 10 11 enum objtype { 12 OError = -2, 13 OEof = -1, 14 OIdentifier, 15 OBoolean, 16 OInteger, 17 OCharacter, 18 OString, 19 OEmptylist, 20 OPair, 21 OPrimitiveproc, 22 OCompoundproc, 23 }; 24 25 struct object { 26 enum objtype type; 27 union { 28 /* error */ 29 struct { 30 char *s; 31 } err; 32 /* eof */ 33 struct { 34 char *s; 35 } eof; 36 /* identifier */ 37 struct { 38 char *name; 39 } i; 40 /* boolean */ 41 struct { 42 bool v; 43 } b; 44 /* integer */ 45 struct { 46 long v; 47 } n; 48 /* character */ 49 struct { 50 char c; 51 } c; 52 /* string */ 53 struct { 54 char *s; 55 } s; 56 /* pair */ 57 struct { 58 struct object *car; 59 struct object *cdr; 60 } pair; 61 /* proc */ 62 struct { 63 struct object *(*fn)(struct object *); 64 } pproc; 65 /* compound procedures */ 66 struct { 67 struct object *params; 68 struct object *body; 69 } cproc; 70 } d; 71 }; 72 73 /* builtins */ 74 static struct object *evaldefine(struct object *); 75 static struct object *evalif(struct object *); 76 static struct object *evallambda(struct object *); 77 static struct object *evalok(struct object *); 78 static struct object *evalquote(struct object *); 79 static struct object *evalset(struct object *); 80 81 /* primitive procedures */ 82 static struct object *evalboolean(struct object *); 83 static struct object *evalcar(struct object *); 84 static struct object *evalcdr(struct object *); 85 static struct object *evalcons(struct object *); 86 static struct object *evaldiff(struct object *); 87 static struct object *evaleq(struct object *); 88 static struct object *evalgt(struct object *); 89 static struct object *evalinteger(struct object *); 90 static struct object *evallt(struct object *); 91 static struct object *evalnull(struct object *); 92 static struct object *evalplus(struct object *); 93 94 struct { 95 char *name; 96 struct object *o; 97 struct object *(*fn)(struct object *); 98 } builtins[] = { 99 { .name = "define", .fn = evaldefine }, 100 { .name = "if", .fn = evalif }, 101 { .name = "lambda", .fn = evallambda }, 102 { .name = "ok", .fn = evalok }, 103 { .name = "quote", .fn = evalquote }, 104 { .name = "set", .fn = evalset }, 105 }; 106 107 struct { 108 char *name; 109 struct object *o; 110 struct object *(*fn)(struct object *); 111 } procs[] = { 112 { .name = "boolean", .fn = evalboolean }, 113 { .name = "car", .fn = evalcar }, 114 { .name = "cdr", .fn = evalcdr }, 115 { .name = "cons", .fn = evalcons }, 116 { .name = "diff", .fn = evaldiff }, 117 { .name = "eq", .fn = evaleq }, 118 { .name = "gt", .fn = evalgt }, 119 { .name = "integer", .fn = evalinteger }, 120 { .name = "lt", .fn = evallt }, 121 { .name = "null", .fn = evalnull }, 122 { .name = "plus", .fn = evalplus }, 123 }; 124 125 static struct object * 126 newobject(void) 127 { 128 return ecalloc(1, sizeof(struct object)); 129 } 130 131 static struct object * 132 error(char *s) 133 { 134 struct object *o; 135 136 o = newobject(); 137 o->type = OError; 138 o->d.err.s = estrdup(s); 139 return o; 140 } 141 142 static struct object * 143 eof(void) 144 { 145 struct object *o; 146 147 o = newobject(); 148 o->type = OEof; 149 o->d.eof.s = "eof"; 150 return o; 151 } 152 153 static struct object * 154 identifier(char *s) 155 { 156 struct object *o; 157 158 o = newobject(); 159 o->type = OIdentifier; 160 o->d.i.name = estrdup(s); 161 return o; 162 } 163 164 static struct object * 165 boolean(bool v) 166 { 167 struct object *o; 168 169 o = newobject(); 170 o->type = OBoolean; 171 o->d.b.v = v; 172 return o; 173 } 174 175 static struct object * 176 integer(long v) 177 { 178 struct object *o; 179 180 o = newobject(); 181 o->type = OInteger; 182 o->d.n.v = v; 183 return o; 184 } 185 186 static struct object * 187 character(char c) 188 { 189 struct object *o; 190 191 o = newobject(); 192 o->type = OCharacter; 193 o->d.c.c = c; 194 return o; 195 } 196 197 static struct object * 198 string(char *s) 199 { 200 struct object *o; 201 202 o = newobject(); 203 o->type = OString; 204 o->d.s.s = estrdup(s); 205 return o; 206 } 207 208 static struct object * 209 emptylist(void) 210 { 211 struct object *o; 212 213 o = newobject(); 214 o->type = OEmptylist; 215 return o; 216 } 217 218 static struct object * 219 cons(struct object *car, struct object *cdr) 220 { 221 struct object *o; 222 223 o = newobject(); 224 o->type = OPair; 225 o->d.pair.car = car; 226 o->d.pair.cdr = cdr; 227 return o; 228 } 229 230 static struct object * 231 pair(FILE *in) 232 { 233 struct object *car, *cdr; 234 struct tok t; 235 236 t = gettok(in); 237 if (t.type == TRparen) 238 return emptylist(); 239 puttok(t); 240 car = sexpression(in); 241 t = gettok(in); 242 if (t.type != TDot) { 243 puttok(t); 244 cdr = pair(in); 245 return cons(car, cdr); 246 } 247 cdr = sexpression(in); 248 t = gettok(in); 249 if (t.type != TRparen) 250 return error("missing right parenthesis"); 251 return cons(car, cdr); 252 } 253 254 static struct object * 255 pproc(struct object *(*fn)(struct object *)) 256 { 257 struct object *o; 258 259 o = newobject(); 260 o->type = OPrimitiveproc; 261 o->d.pproc.fn = fn; 262 return o; 263 } 264 265 static struct object * 266 cproc(struct object *params, struct object *body) 267 { 268 struct object *o; 269 270 o = newobject(); 271 o->type = OCompoundproc; 272 o->d.cproc.params = params; 273 o->d.cproc.body = body; 274 return o; 275 } 276 277 struct object * 278 sexpression(FILE *in) 279 { 280 struct tok t; 281 char *l; 282 283 t = gettok(in); 284 l = lexeme(&t); 285 switch (t.type) { 286 case TEof: 287 return eof(); 288 case TError: 289 return error(l); 290 case TIdentifier: 291 return identifier(l); 292 case TBoolean: 293 /* #t or #f */ 294 return boolean(l[1] == 't' ? true : false); 295 case TInteger: 296 return integer(strtol(l, 0, 10)); 297 case TCharacter: 298 /* #\c */ 299 return character(l[2]); 300 case TString: 301 return string(l); 302 case TLparen: 303 return pair(in); 304 case TQuote: 305 return cons(lookupsym("quote"), cons(sexpression(in), 306 emptylist())); 307 default: 308 return error("unhandled token"); 309 } 310 /* not reachable */ 311 return NULL; 312 } 313 314 static struct object * 315 car(struct object *o) 316 { 317 return o->d.pair.car; 318 } 319 320 static struct object * 321 cdr(struct object *o) 322 { 323 return o->d.pair.cdr; 324 } 325 326 #define caar(obj) car(car(obj)) 327 #define cadr(obj) car(cdr(obj)) 328 #define cdar(obj) cdr(car(obj)) 329 #define cddr(obj) cdr(cdr(obj)) 330 #define caaar(obj) car(car(car(obj))) 331 #define caadr(obj) car(car(cdr(obj))) 332 #define cadar(obj) car(cdr(car(obj))) 333 #define caddr(obj) car(cdr(cdr(obj))) 334 #define cdaar(obj) cdr(car(car(obj))) 335 #define cdadr(obj) cdr(car(cdr(obj))) 336 #define cddar(obj) cdr(cdr(car(obj))) 337 #define cdddr(obj) cdr(cdr(cdr(obj))) 338 #define caaaar(obj) car(car(car(car(obj)))) 339 #define caaadr(obj) car(car(car(cdr(obj)))) 340 #define caadar(obj) car(car(cdr(car(obj)))) 341 #define caaddr(obj) car(car(cdr(cdr(obj)))) 342 #define cadaar(obj) car(cdr(car(car(obj)))) 343 #define cadadr(obj) car(cdr(car(cdr(obj)))) 344 #define caddar(obj) car(cdr(cdr(car(obj)))) 345 #define cadddr(obj) car(cdr(cdr(cdr(obj)))) 346 #define cdaaar(obj) cdr(car(car(car(obj)))) 347 #define cdaadr(obj) cdr(car(car(cdr(obj)))) 348 #define cdadar(obj) cdr(car(cdr(car(obj)))) 349 #define cdaddr(obj) cdr(car(cdr(cdr(obj)))) 350 #define cddaar(obj) cdr(cdr(car(car(obj)))) 351 #define cddadr(obj) cdr(cdr(car(cdr(obj)))) 352 #define cdddar(obj) cdr(cdr(cdr(car(obj)))) 353 #define cddddr(obj) cdr(cdr(cdr(cdr(obj)))) 354 355 static struct object * 356 evaldefine(struct object *o) 357 { 358 struct object *var, *val; 359 360 if (o->type != OPair) 361 return NULL; 362 if (car(o)->type != OIdentifier) 363 return NULL; 364 var = cadr(o); 365 if (var->type != OIdentifier) 366 return error("expected identifier"); 367 if (!caddr(o)) 368 return error("expected sexpression"); 369 val = eval(caddr(o)); 370 if (val->type == OError) 371 return val; 372 if (cadddr(o)) 373 return error("multiple arguments"); 374 addsym(var->d.i.name, val); 375 return lookupsym("ok"); 376 } 377 378 static struct object * 379 evalif(struct object *o) 380 { 381 struct object *predicate; 382 383 if (o->type != OPair) 384 return NULL; 385 if (car(o)->type != OIdentifier) 386 return NULL; 387 predicate = eval(cadr(o)); 388 if (predicate->type == OError) 389 return predicate; 390 if (predicate->type == OBoolean && 391 predicate->d.b.v == false) 392 return eval(cadddr(o)); 393 return eval(caddr(o)); 394 } 395 396 static struct object * 397 evallambda(struct object *o) 398 { 399 struct object *params, *body; 400 401 if (o->type != OPair) 402 return NULL; 403 if (car(o)->type != OIdentifier) 404 return NULL; 405 params = cadr(o); 406 body = caddr(o); 407 return cproc(params, body); 408 } 409 410 static struct object * 411 evalok(struct object *o) 412 { 413 if (o->type != OIdentifier) 414 return NULL; 415 return o; 416 } 417 418 static struct object * 419 evalquote(struct object *o) 420 { 421 if (o->type != OPair) 422 return NULL; 423 if (car(o)->type != OIdentifier) 424 return NULL; 425 if (caddr(o)) 426 return error("multiple arguments"); 427 return cadr(o); 428 } 429 430 static struct object * 431 evalset(struct object *o) 432 { 433 struct object *var, *val; 434 435 if (o->type != OPair) 436 return NULL; 437 if (car(o)->type != OIdentifier) 438 return NULL; 439 var = cadr(o); 440 if (var->type != OIdentifier) 441 return error("expected identifier"); 442 if (!lookupsym(var->d.i.name)) 443 return error("unbound identifier"); 444 if (!caddr(o)) 445 return error("expected sexpression"); 446 val = eval(caddr(o)); 447 if (val->type == OError) 448 return val; 449 if (cadddr(o)) 450 return error("multiple arguments"); 451 addsym(var->d.i.name, val); 452 return lookupsym("ok"); 453 } 454 455 static struct object * 456 evalboolean(struct object *o) 457 { 458 struct object *arg; 459 460 if (o->type != OPair) 461 return NULL; 462 if (car(o)->type != OIdentifier) 463 return NULL; 464 if (caddr(o)) 465 return error("multiple arguments"); 466 arg = eval(cadr(o)); 467 if (arg->type == OError) 468 return arg; 469 if (arg->type == OBoolean) 470 return boolean(true); 471 return boolean(false); 472 } 473 474 static struct object * 475 evalcar(struct object *o) 476 { 477 struct object *arg; 478 479 if (o->type != OPair) 480 return NULL; 481 if (car(o)->type != OIdentifier) 482 return NULL; 483 if (caddr(o)) 484 return error("multiple arguments"); 485 arg = eval(cadr(o)); 486 if (arg->type == OError) 487 return arg; 488 if (arg->type != OPair) 489 return error("expected pair"); 490 return car(arg); 491 } 492 493 static struct object * 494 evalcdr(struct object *o) 495 { 496 struct object *arg; 497 498 if (o->type != OPair) 499 return NULL; 500 if (car(o)->type != OIdentifier) 501 return NULL; 502 if (caddr(o)) 503 return error("multiple arguments"); 504 arg = eval(cadr(o)); 505 if (arg->type == OError) 506 return arg; 507 if (arg->type != OPair) 508 return error("expected pair"); 509 return cdr(arg); 510 } 511 512 static struct object * 513 evalcons(struct object *o) 514 { 515 if (o->type != OPair) 516 return NULL; 517 if (car(o)->type != OIdentifier) 518 return NULL; 519 if (cadddr(o)) 520 return error("multiple arguments"); 521 return cons(eval(cadr(o)), eval(caddr(o))); 522 } 523 524 static struct object * 525 dodiff(struct object *o, struct object *n) 526 { 527 struct object *arg; 528 529 if (!car(o)) 530 return n; 531 arg = eval(car(o)); 532 if (arg->type == OError) 533 return arg; 534 if (arg->type != OInteger) 535 return error("expected integer"); 536 n->d.n.v -= arg->d.n.v; 537 return dodiff(cdr(o), n); 538 } 539 540 static struct object * 541 evaldiff(struct object *o) 542 { 543 struct object *n, *newn; 544 545 if (o->type != OPair) 546 return NULL; 547 if (car(o)->type != OIdentifier) 548 return NULL; 549 if (!cadr(o)) 550 return integer(0); 551 n = eval(cadr(o)); 552 if (n->type == OError) 553 return n; 554 if (n->type != OInteger) 555 return error("expected integer"); 556 newn = newobject(); 557 memcpy(newn, n, sizeof(*newn)); 558 if (!caddr(o)) { 559 newn->d.n.v *= -1; 560 return newn; 561 } 562 return dodiff(cddr(o), newn); 563 } 564 565 static struct object * 566 evaleq(struct object *o) 567 { 568 struct object *arg1, *arg2; 569 570 if (o->type != OPair) 571 return NULL; 572 if (car(o)->type != OIdentifier) 573 return NULL; 574 if (cadddr(o)) 575 return error("multiple arguments"); 576 arg1 = eval(cadr(o)); 577 if (arg1->type == OError) 578 return arg1; 579 if (arg1->type != OInteger) 580 return error("expected integer"); 581 arg2 = eval(caddr(o)); 582 if (arg2->type == OError) 583 return arg2; 584 if (arg2->type != OInteger) 585 return error("expected integer"); 586 if (arg1->d.n.v == arg2->d.n.v) 587 return boolean(true); 588 return boolean(false); 589 } 590 591 static struct object * 592 evalgt(struct object *o) 593 { 594 struct object *arg1, *arg2; 595 596 if (o->type != OPair) 597 return NULL; 598 if (car(o)->type != OIdentifier) 599 return NULL; 600 if (cadddr(o)) 601 return error("multiple arguments"); 602 arg1 = eval(cadr(o)); 603 if (arg1->type == OError) 604 return arg1; 605 if (arg1->type != OInteger) 606 return error("expected integer"); 607 arg2 = eval(caddr(o)); 608 if (arg2->type == OError) 609 return arg2; 610 if (arg2->type != OInteger) 611 return error("expected integer"); 612 if (arg1->d.n.v > arg2->d.n.v) 613 return boolean(true); 614 return boolean(false); 615 } 616 617 static struct object * 618 evalinteger(struct object *o) 619 { 620 struct object *arg; 621 622 if (o->type != OPair) 623 return NULL; 624 if (car(o)->type != OIdentifier) 625 return NULL; 626 if (caddr(o)) 627 return error("multiple arguments"); 628 arg = eval(cadr(o)); 629 if (arg->type == OError) 630 return arg; 631 if (arg->type == OInteger) 632 return boolean(true); 633 return boolean(false); 634 } 635 636 static struct object * 637 evallt(struct object *o) 638 { 639 struct object *arg1, *arg2; 640 641 if (o->type != OPair) 642 return NULL; 643 if (car(o)->type != OIdentifier) 644 return NULL; 645 if (cadddr(o)) 646 return error("multiple arguments"); 647 arg1 = eval(cadr(o)); 648 if (arg1->type == OError) 649 return arg1; 650 if (arg1->type != OInteger) 651 return error("expected integer"); 652 arg2 = eval(caddr(o)); 653 if (arg2->type == OError) 654 return arg2; 655 if (arg2->type != OInteger) 656 return error("expected integer"); 657 if (arg1->d.n.v < arg2->d.n.v) 658 return boolean(true); 659 return boolean(false); 660 } 661 662 static struct object * 663 evalnull(struct object *o) 664 { 665 struct object *arg; 666 667 if (o->type != OPair) 668 return NULL; 669 if (car(o)->type != OIdentifier) 670 return NULL; 671 if (caddr(o)) 672 return error("multiple arguments"); 673 arg = eval(cadr(o)); 674 if (arg->type == OError) 675 return arg; 676 if (arg->type == OEmptylist) 677 return boolean(true); 678 return boolean(false); 679 } 680 681 static struct object * 682 evalplus(struct object *o) 683 { 684 struct object *arg, *args; 685 struct object *n; 686 687 if (o->type != OPair) 688 return NULL; 689 if (car(o)->type != OIdentifier) 690 return NULL; 691 args = cdr(o); 692 n = integer(0); 693 while (args) { 694 arg = car(args); 695 if (!arg) 696 return n; 697 arg = eval(arg); 698 if (arg->type == OError) 699 return arg; 700 if (arg->type != OInteger) 701 return error("expected integer"); 702 n->d.n.v += arg->d.n.v; 703 args = cdr(args); 704 } 705 return n; 706 } 707 708 static struct object * 709 evalparams(struct object *o) 710 { 711 struct object *params, *pcar, *pcdr; 712 struct object *args, *acar, *acdr; 713 struct object *tmp; 714 715 params = car(lookupsym(car(o)->d.i.name)); 716 args = cdr(o); 717 pcdr = params; 718 acdr = args; 719 while (1) { 720 pcar = car(pcdr); 721 acar = car(acdr); 722 if (!pcar && !acar) 723 break; 724 if (pcar && !acar) 725 return error("not enough arguments"); 726 if (!pcar && acar) 727 return error("too many arguments"); 728 pcdr = cdr(pcdr); 729 acdr = cdr(acdr); 730 if (pcar->type != OIdentifier) 731 return error("expected udentifier"); 732 tmp = eval(acar); 733 addsym(pcar->d.i.name, tmp); 734 } 735 return lookupsym("ok"); 736 } 737 738 static struct object * 739 evalbody(struct object *o) 740 { 741 return eval(cdr(lookupsym(car(o)->d.i.name))); 742 } 743 744 static struct object * 745 evalcproc(struct object *o) 746 { 747 struct object *err, *body; 748 749 if (o->type != OPair) 750 return NULL; 751 752 err = evalparams(o); 753 if (err->type == OError) 754 return err; 755 body = evalbody(o); 756 return body; 757 } 758 759 struct object * 760 eval(struct object *o) 761 { 762 size_t i; 763 struct object *tmp; 764 765 switch (o->type) { 766 case OError: 767 case OEof: 768 case OBoolean: 769 case OInteger: 770 case OCharacter: 771 case OString: 772 /* self-evaluating objects */ 773 return o; 774 case OIdentifier: 775 /* evaluate identifiers */ 776 tmp = lookupsym(o->d.i.name); 777 if (!tmp) 778 return error("unbound identifier"); 779 return tmp; 780 case OPair: 781 /* evaluate builtins and procedures */ 782 tmp = lookupsym(car(o)->d.i.name); 783 if (!tmp) 784 return error("unbound identifier"); 785 switch (tmp->type) { 786 case OIdentifier: 787 for (i = 0; i < LEN(builtins); i++) 788 if (strcmp(tmp->d.i.name, builtins[i].name) == 0) 789 return builtins[i].fn(o); 790 break; 791 case OPrimitiveproc: 792 return tmp->d.pproc.fn(o); 793 case OCompoundproc: 794 pushenv(); 795 tmp = evalcproc(o); 796 popenv(); 797 return tmp; 798 } 799 break; 800 } 801 return error("cannot eval object"); 802 } 803 804 static void 805 printpair(struct object *o) 806 { 807 print(car(o)); 808 switch (cdr(o)->type) { 809 case OPair: 810 putchar(' '); 811 printpair(cdr(o)); 812 case OEmptylist: 813 return; 814 default: 815 putchar(' '); 816 putchar('.'); 817 putchar(' '); 818 print(cdr(o)); 819 } 820 } 821 822 void 823 print(struct object *o) 824 { 825 switch (o->type) { 826 case OError: 827 printf("%s", o->d.err.s); 828 break; 829 case OEof: 830 printf("%s", o->d.eof.s); 831 break; 832 case OIdentifier: 833 printf("%s", o->d.i.name); 834 break; 835 case OBoolean: 836 printf("#%c", o->d.b.v == false ? 'f' : 't'); 837 break; 838 case OInteger: 839 printf("%ld", o->d.n.v); 840 break; 841 case OCharacter: 842 printf("#\\%c", o->d.c.c); 843 break; 844 case OString: 845 printf("%s", o->d.s.s); 846 break; 847 case OEmptylist: 848 printf("()"); 849 break; 850 case OPair: 851 putchar('('); 852 printpair(o); 853 putchar(')'); 854 break; 855 case OPrimitiveproc: 856 printf("#<primitive procedure>"); 857 break; 858 case OCompoundproc: 859 printf("#<compound procedure>"); 860 break; 861 } 862 } 863 864 int 865 init(void) 866 { 867 size_t i; 868 869 initenv(); 870 /* add builtins */ 871 for (i = 0; i < LEN(builtins); i++) { 872 builtins[i].o = identifier(builtins[i].name); 873 addsym(builtins[i].name, builtins[i].o); 874 } 875 /* add primitive procedures */ 876 for (i = 0; i < LEN(procs); i++) { 877 procs[i].o = pproc(procs[i].fn); 878 addsym(procs[i].name, procs[i].o); 879 } 880 return 0; 881 }