lisp/lisp.c

   1 #include <stdio.h>
   2 #include <stdlib.h>
   3 #include <string.h>
   4
   5 struct environment;
   6 struct pair;
   7 struct stack_slot;
   8
   9 struct charseq {
  10         size_t len;
  11         char *s;
  12         int gc;
  13 };
  14
  15 union value_pointer {
  16         int vp_int;
  17         int vp_pair;
  18         int vp_charseq;
  19         union value_pointer (*vp_builtin)(struct stack_slot *top_of_stack,
  20                                           struct environment *env,
  21                                           union value_pointer rest);
  22         char const *vp_opaque;
  23 };
  24
  25 struct binding {
  26         union value_pointer name;
  27         union value_pointer value;
  28         int resource_num;
  29 };
  30
  31 struct resource_pool {
  32         void **resources;
  33         int resources_used;
  34         int resources_size;
  35         size_t alloc_size;
  36 };
  37
  38 struct environment {
  39         struct resource_pool variables;
  40         struct environment *parent;
  41         int resource_num;
  42 };
  43
  44 struct pair {
  45         union value_pointer car;
  46         union value_pointer cdr;
  47         int gc;
  48 };
  49
  50 struct stack_slot {
  51         struct environment *env;
  52         union value_pointer rest;
  53         union value_pointer retval;
  54         union value_pointer function;
  55         union value_pointer sexpr;
  56         union value_pointer args;
  57         union value_pointer list;
  58         union value_pointer p;
  59         union value_pointer subeval_arg;
  60         union value_pointer *arglink;
  61         struct environment *call_env;
  62         int gc;
  63         int resource_num;
  64         int return_path;
  65         int evaluating;
  66         struct stack_slot *prev;
  67 };
  68
  69 void *resource_get(struct resource_pool *rp, int i);
  70 union value_pointer builtin_lambda(struct stack_slot *top_of_stack,
  71                                    struct environment *env,
  72                                    union value_pointer rest);
  73 void gc_protect(union value_pointer v);
  74 union value_pointer gc_unprotect(union value_pointer v);
  75
  76 char const opaque_builtin_function[] = "builtin-function";
  77 char const opaque_builtin_macro[] = "builtin-macro";
  78 char const opaque_user_function[] = "user-function";
  79 char const opaque_user_macro[] = "user-macro";
  80 union value_pointer constant_true, constant_false, constant_nil;
  81
  82 struct resource_pool bindings, charseqs, environments, pairs, stack_slots;
  83
  84 void pointer_mark(union value_pointer *v, int type)
  85 {
  86         int pointer_bits = v->vp_int;
  87
  88         pointer_bits &= ~3;
  89         pointer_bits |= type;
  90
  91         v->vp_int = pointer_bits;
  92 }
  93
  94 int pointer_type(union value_pointer v)
  95 {
  96         return (v.vp_int & 3);
  97 }
  98
  99 int get_integer(union value_pointer v)
 100 {
 101         return (v.vp_int >> 2);
 102 }
 103
 104 struct pair *get_pair(union value_pointer v)
 105 {
 106         return resource_get(&pairs, v.vp_pair >> 2);
 107 }
 108
 109 struct charseq *get_charseq(union value_pointer v)
 110 {
 111         return resource_get(&charseqs, v.vp_charseq >> 2);
 112 }
 113
 114 char *get_charseq_chars(union value_pointer v)
 115 {
 116         struct charseq *cs;
 117
 118         cs = get_charseq(v);
 119
 120         return cs->s;
 121 }
 122
 123 size_t get_charseq_len(union value_pointer v)
 124 {
 125         struct charseq *cs;
 126
 127         cs = get_charseq(v);
 128
 129         return cs->len;
 130 }
 131
 132 void resource_pool_init(struct resource_pool *rp, size_t sz)
 133 {
 134         rp->resources = NULL;
 135         rp->resources_used = 0;
 136         rp->resources_size = 0;
 137         rp->alloc_size = sz;
 138 }
 139
 140 void resource_pool_free(struct resource_pool *rp)
 141 {
 142         int i;
 143
 144         for (i = 0; i < rp->resources_used; i++) {
 145                 free(rp->resources[i]);
 146         }
 147         free(rp->resources);
 148 }
 149
 150 int resource_add(struct resource_pool *rp, void *r)
 151 {
 152         int i;
 153
 154         if (rp->resources_used >= rp->resources_size) {
 155                 int newsize = rp->resources_used * 2 + 16;
 156
 157                 for (i = 0; i < rp->resources_used; i++) {
 158                         if (rp->resources[i] == NULL) {
 159                                 rp->resources[i] = r;
 160                                 return i;
 161                         }
 162                 }
 163
 164                 rp->resources = realloc(rp->resources,
 165                                         sizeof (*rp->resources) * newsize);
 166                 rp->resources_size = newsize;
 167         }
 168
 169         i = rp->resources_used++;
 170         rp->resources[i] = r;
 171
 172         return i;
 173 }
 174
 175 int resource_count(struct resource_pool *rp)
 176 {
 177         return rp->resources_used;
 178 }
 179
 180 void *resource_get(struct resource_pool *rp, int i)
 181 {
 182         return rp->resources[i];
 183 }
 184
 185 void resource_free(struct resource_pool *rp, int i)
 186 {
 187         free(rp->resources[i]);
 188         rp->resources[i] = NULL;
 189 }
 190
 191 int resource_new_i(struct resource_pool *rp)
 192 {
 193         return resource_add(rp, malloc(rp->alloc_size));
 194 }
 195
 196 struct environment *environment_new(struct environment *parent)
 197 {
 198         struct environment *env;
 199         int envnum;
 200
 201         envnum = resource_new_i(&environments);
 202         env = resource_get(&environments, envnum);
 203         env->resource_num = envnum;
 204         resource_pool_init(&env->variables, 0);
 205         env->parent = parent;
 206
 207         return env;
 208 }
 209
 210 void environment_free(struct environment *env)
 211 {
 212         resource_pool_free(&env->variables);
 213         resource_free(&environments, env->resource_num);
 214 }
 215
 216 union value_pointer charseq_new(char const *s, size_t len, size_t size, int kind)
 217 {
 218         union value_pointer retval;
 219         struct charseq *cs;
 220
 221         if (kind == 1) {
 222                 int i;
 223
 224                 for (i = 0; i < resource_count(&charseqs); i++) {
 225                         cs = resource_get(&charseqs, i);
 226                         if (cs && len == cs->len && strncmp(s, cs->s, len) == 0) {
 227                                 retval.vp_charseq = i << 2;
 228                                 pointer_mark(&retval, kind);
 229
 230                                 return retval;
 231                         }
 232                 }
 233         }
 234
 235         retval.vp_charseq = resource_new_i(&charseqs) << 2;
 236         pointer_mark(&retval, kind);
 237
 238         cs = get_charseq(retval);
 239         cs->len = size;
 240         cs->s = malloc(size + 1);
 241         memcpy(cs->s, s, len);
 242         cs->s[len] = 0;
 243         cs->gc = 2;
 244
 245         return retval;
 246 }
 247
 248 union value_pointer pair_new(void)
 249 {
 250         union value_pointer retval;
 251
 252         retval.vp_pair = resource_new_i(&pairs) << 2;
 253         pointer_mark(&retval, 3);
 254         get_pair(retval)->cdr = constant_nil;
 255         get_pair(retval)->gc = 2;
 256
 257         return retval;
 258 }
 259
 260 union value_pointer lisp_car(union value_pointer v)
 261 {
 262         return get_pair(v)->car;
 263 }
 264
 265 union value_pointer lisp_cdr(union value_pointer v)
 266 {
 267         return get_pair(v)->cdr;
 268 }
 269
 270 union value_pointer lisp_cons(union value_pointer left, union value_pointer right)
 271 {
 272         union value_pointer retval;
 273
 274         retval = pair_new();
 275         get_pair(retval)->car = left;
 276         get_pair(retval)->cdr = right;
 277         pointer_mark(&retval, 3);
 278
 279         if (left.vp_opaque != opaque_builtin_function &&
 280             left.vp_opaque != opaque_builtin_macro) {
 281                 if (left.vp_opaque != opaque_user_function &&
 282                     left.vp_opaque != opaque_user_macro) {
 283                         gc_unprotect(left);
 284                 }
 285                 gc_unprotect(right);
 286         }
 287
 288         return retval;
 289 }
 290
 291 union value_pointer lisp_integer(int n)
 292 {
 293         union value_pointer retval;
 294
 295         retval.vp_int = n << 2;
 296         pointer_mark(&retval, 0);
 297
 298         return retval;
 299 }
 300
 301 union value_pointer lisp_opaque(char const *cookie)
 302 {
 303         union value_pointer retval;
 304
 305         retval.vp_opaque = cookie;
 306
 307         return retval;
 308 }
 309
 310 union value_pointer lisp_builtin(union value_pointer (*builtin)(struct stack_slot *top_of_stack,
 311                                                                 struct environment *env,
 312                                                                 union value_pointer rest))
 313 {
 314         union value_pointer retval;
 315
 316         retval.vp_builtin = builtin;
 317
 318         return retval;
 319 }
 320
 321 struct binding *binding_new(struct environment *env,
 322                             char const *name,
 323                             union value_pointer value)
 324 {
 325         struct binding *b;
 326         int bnum;
 327
 328         bnum = resource_new_i(&bindings);
 329         b = resource_get(&bindings, bnum);
 330         b->resource_num = bnum;
 331         b->name = charseq_new(name, strlen(name), strlen(name), 1);
 332         b->value = value;
 333
 334         resource_add(&env->variables, b);
 335
 336         gc_unprotect(b->name);
 337         gc_unprotect(b->value);
 338
 339         return b;
 340 }
 341
 342 union value_pointer builtin_new(char const *opaque_type,
 343                                 union value_pointer (*builtin)(struct stack_slot *top_of_stack,
 344                                                                struct environment *env,
 345                                                                union value_pointer rest))
 346 {
 347         return lisp_cons(lisp_opaque(opaque_type),
 348                          lisp_builtin(builtin));
 349 }
 350
 351 size_t parse_word(union value_pointer *vp, char const *buf, size_t len)
 352 {
 353         size_t i;
 354         int n;
 355
 356         for (n = 0, i = 0; i < len; i++) {
 357                 if (buf[i] < '0' || buf[i] > '9') {
 358                         break;
 359                 }
 360                 n = n*10 + buf[i] - '0';
 361         }
 362
 363         if (i < len) {
 364                 char *symbol;
 365
 366                 switch (buf[i]) {
 367                 case ')':
 368                 case ' ':
 369                 case '\n':
 370                 case '\t':
 371                         break;
 372                 default:
 373                         for (i++; i < len; i++) {
 374                                 switch (buf[i]) {
 375                                 case ')':
 376                                 case ' ':
 377                                 case '\n':
 378                                 case '\t':
 379                                         len = i + 1;
 380                                         break;
 381                                 default:
 382                                         continue;
 383                                 }
 384                                 break;
 385                         }
 386                         *vp = charseq_new(buf, i, i, 1);
 387                         gc_unprotect(*vp);
 388                         return i;
 389                 }
 390         }
 391         vp->vp_int = n << 2;
 392         pointer_mark(vp, 0);
 393         return i;
 394 }
 395
 396 size_t parse_string(union value_pointer *vp, char const *buf, size_t len)
 397 {
 398         size_t i, n;
 399         char *s;
 400         int backslash;
 401
 402         for (backslash = n = 0, i = 1; i < len; i++) {
 403                 if (backslash) {
 404                         n++;
 405                         backslash = 0;
 406                 } else if (buf[i] == '"') {
 407                         break;
 408                 } else if (buf[i] == '\\') {
 409                         backslash = 1;
 410                 } else {
 411                         n++;
 412                 }
 413         }
 414         len = i;
 415
 416         *vp = charseq_new(buf + 1, n, n, 2);
 417         gc_unprotect(*vp);
 418
 419         for (backslash = 0, i = 1, s = get_charseq_chars(*vp); i < len; i++) {
 420                 if (backslash) {
 421                         switch (buf[i]) {
 422                         case 'n':
 423                                 *s++ = '\n';
 424                                 break;
 425                         default:
 426                                 *s++ = buf[i];
 427                                 break;
 428                         }
 429                         backslash = 0;
 430                 } else if (buf[i] == '\\') {
 431                         backslash = 1;
 432                 } else {
 433                         *s++ = buf[i];
 434                 }
 435         }
 436
 437         return i + 1;
 438 }
 439
 440 size_t parse_forms(char const *buf, size_t len, union value_pointer *form)
 441 {
 442         size_t i, n;
 443         int improper = 0;
 444
 445         for (i = 0; i < len; i++) {
 446                 char const c = buf[i];
 447                 union value_pointer u, v;
 448
 449                 v = constant_nil;
 450
 451                 switch (c) {
 452                 case '(':
 453                         u = constant_nil;
 454                         n = parse_forms(buf + i + 1, len - i - 1, &u) + 1;
 455                         i += n;
 456                         if (improper) {
 457                                 *form = u;
 458                         } else {
 459                                 v = lisp_cons(u, constant_nil);
 460                                 *form = v;
 461                                 gc_unprotect(v);
 462                                 form = &get_pair(*form)->cdr;
 463                         }
 464                         break;
 465                 case ')':
 466                 case ' ':
 467                 case '\n':
 468                 case '\t':
 469                         break;
 470                 case '"':
 471                         v = pair_new();
 472                         n = parse_string(&get_pair(v)->car, buf + i, len - i);
 473                         i += n - 1;
 474                         *form = v;
 475                         gc_unprotect(v);
 476                         pointer_mark(form, 3);
 477                         form = &get_pair(v)->cdr;
 478                         break;
 479                 default:
 480                         n = parse_word(&u, buf + i, len - i);
 481                         if (pointer_type(u) == 1 &&
 482                             strcmp(get_charseq_chars(u), ".") == 0) {
 483                                 improper = 1;
 484                         }
 485                         if (improper) {
 486                                 *form = u;
 487                         } else {
 488                                 *form = lisp_cons(u, constant_nil);
 489                                 gc_unprotect(*form);
 490                                 form = &get_pair(*form)->cdr;
 491                         }
 492                         gc_unprotect(u);
 493                         i += n - 1;
 494                         break;
 495                 }
 496
 497                 if (c == ')') {
 498                         break;
 499                 }
 500         }
 501
 502         return i;
 503 }
 504
 505 void pretty_print(union value_pointer v)
 506 {
 507         union value_pointer i;
 508         struct pair *p;
 509
 510         switch (pointer_type(v)) {
 511         case 0:
 512                 printf("%d", get_integer(v));
 513                 break;
 514         case 1:
 515                 printf("%s", get_charseq_chars(v));
 516                 break;
 517         case 2:
 518                 printf("\"%s\"", get_charseq_chars(v));
 519                 break;
 520         case 3:
 521                 p = get_pair(v);
 522                 if (p != get_pair(constant_nil) &&
 523                     (p->car.vp_opaque == opaque_builtin_function ||
 524                      p->car.vp_opaque == opaque_builtin_macro ||
 525                      p->car.vp_opaque == opaque_user_function ||
 526                      p->car.vp_opaque == opaque_user_macro)) {
 527                         printf("%s", p->car.vp_opaque);
 528                         break;
 529                 }
 530
 531                 printf("(");
 532                 for (i = v;
 533                      pointer_type(i) == 3 && get_pair(i) != get_pair(constant_nil);
 534                      i = lisp_cdr(i)) {
 535                         if (i.vp_pair != v.vp_pair) {
 536                                 printf(" ");
 537                         }
 538                         pretty_print(lisp_car(i));
 539                 }
 540                 if (pointer_type(i) != 3) {
 541                         printf(" . ");
 542                         pretty_print(i);
 543                 }
 544                 printf(")");
 545                 break;
 546         }
 547 }
 548
 549 struct stack_slot *stack_call(struct stack_slot *top_of_stack,
 550                               struct environment *env,
 551                               union value_pointer rest)
 552 {
 553         struct stack_slot *slot;
 554         int slotnum;
 555
 556         slotnum = resource_new_i(&stack_slots);
 557         slot = resource_get(&stack_slots, slotnum);
 558         slot->resource_num = slotnum;
 559         slot->evaluating = 1;
 560         slot->return_path = 4040;
 561         slot->env = env;
 562         slot->rest = rest;
 563         slot->prev = top_of_stack;
 564         slot->gc = 2;
 565
 566         return slot;
 567 }
 568
 569 struct stack_slot *stack_return(struct stack_slot *top_of_stack)
 570 {
 571         struct stack_slot *slot;
 572
 573         slot = top_of_stack->prev;
 574
 575         resource_free(&stack_slots, top_of_stack->resource_num);
 576
 577         return slot;
 578 }
 579
 580 union value_pointer eval_symbol(struct environment *env, union value_pointer sym)
 581 {
 582         char const *symbol_name;
 583         int i;
 584
 585         symbol_name = get_charseq_chars(sym);
 586         do {
 587                 for (i = 0; i < resource_count(&env->variables); i++) {
 588                         struct binding *b;
 589
 590                         b = resource_get(&env->variables, i);
 591                         if (strcmp(get_charseq_chars(b->name), symbol_name) == 0) {
 592                                 return b->value;
 593                         }
 594                 }
 595                 env = env->parent;
 596         } while (env != NULL);
 597
 598         return constant_nil;
 599 }
 600
 601 union value_pointer builtin_eval(struct stack_slot *caller,
 602                                  struct environment *env_toplevel,
 603                                  union value_pointer rest_toplevel)
 604 {
 605         struct stack_slot *top_of_stack;
 606         union value_pointer element;
 607         union value_pointer consequent, alternate;
 608         union value_pointer retval;
 609         struct pair *closure;
 610
 611         top_of_stack = stack_call(caller, env_toplevel, rest_toplevel);
 612         top_of_stack->return_path = 0;
 613
 614         while (1) {
 615                 if (top_of_stack->evaluating) {
 616                         switch (pointer_type(lisp_car(top_of_stack->rest))) {
 617                         case 0:
 618                         case 2:
 619                                 top_of_stack->retval = lisp_car(top_of_stack->rest);
 620                                 break;
 621                         case 1:
 622                                 top_of_stack->retval = eval_symbol(top_of_stack->env,
 623                                                                    lisp_car(top_of_stack->rest));
 624                                 break;
 625                         case 3:
 626                                 top_of_stack->list = lisp_car(top_of_stack->rest);
 627                                 top_of_stack->subeval_arg = lisp_cons(lisp_car(top_of_stack->list), constant_nil);
 628
 629                                 top_of_stack = stack_call(top_of_stack,
 630                                                           top_of_stack->env,
 631                                                           top_of_stack->subeval_arg);
 632                                 top_of_stack->return_path = 3;
 633                                 continue;
 634                         }
 635                 }
 636                 switch (top_of_stack->return_path) {
 637                 case 0:
 638                         retval = top_of_stack->retval;
 639                         stack_return(top_of_stack);
 640                         return retval;
 641                 case 1:
 642                         retval = top_of_stack->retval;
 643                         top_of_stack = stack_return(top_of_stack);
 644                         top_of_stack->retval = retval;
 645                         gc_unprotect(top_of_stack->sexpr);
 646                         top_of_stack->p = lisp_cdr(top_of_stack->p);
 647                         if (get_pair(top_of_stack->p) != get_pair(constant_nil)) {
 648                                 top_of_stack->sexpr = lisp_cons(lisp_car(top_of_stack->p), constant_nil);
 649                                 if (get_pair(lisp_cdr(top_of_stack->p)) == get_pair(constant_nil)) {
 650                                         top_of_stack->env = top_of_stack->call_env;
 651                                         top_of_stack->rest = top_of_stack->sexpr;
 652                                         continue;
 653                                 }
 654                                 top_of_stack = stack_call(top_of_stack,
 655                                                           top_of_stack->call_env,
 656                                                           top_of_stack->sexpr);
 657                                 top_of_stack->return_path = 1;
 658                                 continue;
 659                         }
 660                         environment_free(top_of_stack->call_env);
 661                         gc_unprotect(top_of_stack->list);
 662                         break;
 663                 case 3:
 664                         top_of_stack->prev->args = lisp_cons(top_of_stack->retval, constant_nil);
 665                         top_of_stack = stack_return(top_of_stack);
 666                         gc_unprotect(top_of_stack->subeval_arg);
 667
 668                         if (lisp_car(lisp_car(top_of_stack->args)).vp_opaque == opaque_builtin_function ||
 669                             lisp_car(lisp_car(top_of_stack->args)).vp_opaque == opaque_user_function) {
 670                                 top_of_stack->arglink = &get_pair(top_of_stack->args)->cdr;
 671
 672                                 top_of_stack->list = lisp_cdr(top_of_stack->list);
 673
 674                                 if (0) {
 675                 case 4:
 676                                         element = lisp_cons(top_of_stack->retval, constant_nil);
 677                                         top_of_stack = stack_return(top_of_stack);
 678                                         gc_unprotect(top_of_stack->subeval_arg);
 679
 680                                         *top_of_stack->arglink = element;
 681                                         top_of_stack->arglink = &get_pair(element)->cdr;
 682
 683                                         gc_unprotect(element);
 684                                         top_of_stack->list = lisp_cdr(top_of_stack->list);
 685                                 }
 686                                 if (get_pair(top_of_stack->list) != get_pair(constant_nil)) {
 687                                         top_of_stack->subeval_arg = lisp_cons(lisp_car(top_of_stack->list),
 688                                                                               constant_nil);
 689
 690                                         top_of_stack = stack_call(top_of_stack,
 691                                                                   top_of_stack->env,
 692                                                                   top_of_stack->subeval_arg);
 693                                         top_of_stack->return_path = 4;
 694                                         continue;
 695                                 }
 696                         } else {
 697                                 get_pair(top_of_stack->args)->cdr = lisp_cdr(top_of_stack->list);
 698                         }
 699                 case 5:
 700                         top_of_stack->list = top_of_stack->args;
 701                         top_of_stack->function = lisp_car(top_of_stack->list);
 702                         top_of_stack->args = lisp_cdr(top_of_stack->list);
 703
 704                         closure = get_pair(top_of_stack->function);
 705                         if (closure->car.vp_opaque == opaque_builtin_function ||
 706                             closure->car.vp_opaque == opaque_builtin_macro) {
 707                                 top_of_stack = stack_call(top_of_stack,
 708                                                           top_of_stack->env,
 709                                                           top_of_stack->args);
 710                                 top_of_stack->return_path = 6;
 711                                 top_of_stack->retval = (*closure->cdr.vp_builtin)(top_of_stack,
 712                                                                                   top_of_stack->prev->env,
 713                                                                                   top_of_stack->prev->args);
 714                                 break;
 715                         } else if (closure->car.vp_opaque == opaque_user_function) {
 716                                 union value_pointer function_env;
 717                                 union value_pointer formal_args;
 718                                 union value_pointer function_body;
 719                                 struct environment *lambda_env;
 720
 721                                 top_of_stack->p = closure->cdr;
 722                                 function_env = lisp_car(top_of_stack->p);
 723                                 formal_args = lisp_car(lisp_cdr(top_of_stack->p));
 724                                 function_body = lisp_cdr(lisp_cdr(top_of_stack->p));
 725
 726                                 lambda_env = resource_get(&environments,
 727                                                           get_integer(function_env));
 728                                 top_of_stack->call_env = environment_new(lambda_env);
 729                                 for (top_of_stack->p = formal_args;
 730                                      (pointer_type(top_of_stack->p) == 3 &&
 731                                       get_pair(top_of_stack->p) != get_pair(constant_nil) &&
 732                                       get_pair(top_of_stack->args) != get_pair(constant_nil));
 733                                      top_of_stack->p = lisp_cdr(top_of_stack->p),
 734                                      top_of_stack->args = lisp_cdr(top_of_stack->args)) {
 735                                         binding_new(top_of_stack->call_env,
 736                                                     get_charseq_chars(lisp_car(top_of_stack->p)),
 737                                                     lisp_car(top_of_stack->args));
 738                                 }
 739                                 if (pointer_type(top_of_stack->p) == 1) {
 740                                         binding_new(top_of_stack->call_env,
 741                                                     get_charseq_chars(top_of_stack->p),
 742                                                     top_of_stack->args);
 743                                 }
 744
 745                                 top_of_stack->p = function_body;
 746                                 if (get_pair(top_of_stack->p) != get_pair(constant_nil)) {
 747                                         top_of_stack->sexpr = lisp_cons(lisp_car(top_of_stack->p), constant_nil);
 748                                         if (get_pair(lisp_cdr(top_of_stack->p)) == get_pair(constant_nil)) {
 749                                                 top_of_stack->env = top_of_stack->call_env;
 750                                                 top_of_stack->rest = top_of_stack->sexpr;
 751                                                 continue;
 752                                         }
 753                                         top_of_stack = stack_call(top_of_stack,
 754                                                                   top_of_stack->call_env,
 755                                                                   top_of_stack->sexpr);
 756                                         top_of_stack->return_path = 1;
 757                                         continue;
 758                                 }
 759                                 environment_free(top_of_stack->call_env);
 760                                 break;
 761                         }
 762                         gc_unprotect(top_of_stack->list);
 763                         break;
 764                 case 6:
 765                         retval = top_of_stack->retval;
 766                         top_of_stack = stack_return(top_of_stack);
 767                         top_of_stack->retval = retval;
 768                         gc_unprotect(top_of_stack->list);
 769                         break;
 770                 case 7:
 771                         top_of_stack->return_path = 8;
 772                         top_of_stack->evaluating = 1;
 773                         continue;
 774                 case 8:
 775                         retval = top_of_stack->retval;
 776                         gc_unprotect(top_of_stack->rest);
 777                         top_of_stack = stack_return(top_of_stack);
 778
 779                         consequent = lisp_car(lisp_cdr(lisp_cdr(lisp_car(top_of_stack->rest))));
 780                         alternate = lisp_cdr(lisp_cdr(lisp_cdr(lisp_car(top_of_stack->rest))));
 781                         if (pointer_type(retval) != 1 ||
 782                             retval.vp_charseq != constant_false.vp_charseq) {
 783                                 element = lisp_cons(consequent, constant_nil);
 784                         } else if (get_pair(alternate) != get_pair(constant_nil)) {
 785                                 element = lisp_cons(lisp_car(alternate), constant_nil);
 786                         } else {
 787                                 top_of_stack->retval = constant_nil;
 788                                 break;
 789                         }
 790
 791                         gc_unprotect(retval);
 792                         top_of_stack->rest = element;
 793                         top_of_stack->evaluating = 1;
 794                         continue;
 795                 }
 796                 top_of_stack->evaluating = 0;
 797         }
 798 }
 799
 800 union value_pointer builtin_string_to_list(struct stack_slot *top_of_stack,
 801                                            struct environment *env,
 802                                            union value_pointer rest)
 803 {
 804         union value_pointer retval;
 805         union value_pointer *v;
 806         char const *s;
 807         size_t i, n;
 808
 809         s = get_charseq_chars(lisp_car(rest));
 810         n = get_charseq_len(lisp_car(rest));
 811         retval = lisp_cons(constant_nil, constant_nil);
 812         v = &get_pair(retval)->cdr;
 813         for (i = 0; i < n; i++) {
 814                 *v = lisp_cons(lisp_integer(s[i]), constant_nil);
 815                 gc_unprotect(*v);
 816                 v = &get_pair(*v)->cdr;
 817         }
 818         v = &get_pair(retval)->cdr;
 819         gc_protect(*v);
 820         gc_unprotect(retval);
 821         retval = *v;
 822
 823         return retval;
 824 }
 825
 826 union value_pointer builtin_car(struct stack_slot *top_of_stack,
 827                                 struct environment *env,
 828                                 union value_pointer rest)
 829 {
 830         return lisp_car(lisp_car(rest));
 831 }
 832
 833 union value_pointer builtin_cdr(struct stack_slot *top_of_stack,
 834                                 struct environment *env,
 835                                 union value_pointer rest)
 836 {
 837         return lisp_cdr(lisp_car(rest));
 838 }
 839
 840 union value_pointer builtin_cons(struct stack_slot *top_of_stack,
 841                                  struct environment *env,
 842                                  union value_pointer rest)
 843 {
 844         return gc_unprotect(lisp_cons(lisp_car(rest), lisp_car(lisp_cdr(rest))));
 845 }
 846
 847 union value_pointer builtin_eq_p(struct stack_slot *top_of_stack,
 848                                  struct environment *env,
 849                                  union value_pointer rest)
 850 {
 851         union value_pointer a, b;
 852
 853         a = lisp_car(rest);
 854         b = lisp_car(lisp_cdr(rest));
 855
 856         if (pointer_type(a) != pointer_type(b)) {
 857                 return constant_false;
 858         }
 859
 860         switch (pointer_type(a)) {
 861         case 0:
 862                 if (get_integer(a) != get_integer(b)) {
 863                         return constant_false;
 864                 }
 865                 break;
 866         case 1:
 867         case 2:
 868                 if (get_charseq(a) != get_charseq(b)) {
 869                         return constant_false;
 870                 }
 871                 break;
 872         case 3:
 873                 if (a.vp_pair != b.vp_pair) {
 874                         return constant_false;
 875                 }
 876                 break;
 877         }
 878
 879         return constant_true;
 880 }
 881
 882 union value_pointer builtin_display(struct stack_slot *top_of_stack,
 883                                     struct environment *env,
 884                                     union value_pointer rest)
 885 {
 886         pretty_print(lisp_car(rest));
 887
 888         return constant_true;
 889 }
 890
 891 union value_pointer builtin_list_p_helper(union value_pointer v)
 892 {
 893         if (pointer_type(v) == 3) {
 894                 if (get_pair(v) == get_pair(constant_nil)) {
 895                         return constant_true;
 896                 } else {
 897                         return builtin_list_p_helper(lisp_cdr(v));
 898                 }
 899         } else {
 900                 return constant_false;
 901         }
 902 }
 903
 904 union value_pointer builtin_list_p(struct stack_slot *top_of_stack,
 905                                    struct environment *env,
 906                                    union value_pointer rest)
 907 {
 908         return builtin_list_p_helper(lisp_car(rest));
 909 }
 910
 911 union value_pointer builtin_define(struct stack_slot *top_of_stack,
 912                                    struct environment *env,
 913                                    union value_pointer rest)
 914 {
 915         union value_pointer name_and_args, definition;
 916         union value_pointer lambda_args, function;
 917
 918         name_and_args = lisp_car(rest);
 919         definition = lisp_car(lisp_cdr(rest));
 920
 921         lambda_args = lisp_cons(lisp_cdr(name_and_args), lisp_cons(definition, constant_nil));
 922
 923         function = builtin_lambda(top_of_stack, env, lambda_args);
 924         gc_unprotect(lambda_args);
 925
 926         binding_new(env, get_charseq_chars(lisp_car(name_and_args)), function);
 927
 928         return constant_nil;
 929 }
 930
 931 union value_pointer builtin_if(struct stack_slot *top_of_stack,
 932                                struct environment *env,
 933                                union value_pointer rest)
 934 {
 935         union value_pointer retval;
 936         union value_pointer condition, consequent, alternate;
 937         union value_pointer v;
 938
 939         retval = constant_nil;
 940
 941         condition = lisp_car(rest);
 942         consequent = lisp_car(lisp_cdr(rest));
 943         alternate = lisp_cdr(lisp_cdr(rest));
 944
 945         v = lisp_cons(condition, constant_nil);
 946
 947         top_of_stack->rest = v;
 948         top_of_stack->return_path = 7;
 949         return;
 950
 951         condition = builtin_eval(top_of_stack, env, v);
 952         gc_unprotect(v);
 953
 954         if (pointer_type(condition) != 1 ||
 955             condition.vp_charseq != constant_false.vp_charseq) {
 956                 v = lisp_cons(consequent, constant_nil);
 957         } else if (get_pair(alternate) != get_pair(constant_nil)) {
 958                 v = lisp_cons(lisp_car(alternate), constant_nil);
 959         } else {
 960                 return retval;
 961         }
 962
 963         gc_unprotect(condition);
 964         retval = builtin_eval(top_of_stack, env, v);
 965         gc_unprotect(v);
 966
 967         return retval;
 968 }
 969
 970 union value_pointer builtin_lambda(struct stack_slot *top_of_stack,
 971                                    struct environment *env,
 972                                    union value_pointer rest)
 973 {
 974         union value_pointer retval;
 975
 976         retval = lisp_cons(lisp_opaque(opaque_user_function),
 977                            lisp_cons(lisp_integer(env->resource_num), rest));
 978         pointer_mark(&retval, 3);
 979
 980         return retval;
 981 }
 982
 983 union value_pointer builtin_quote(struct stack_slot *top_of_stack,
 984                                   struct environment *env,
 985                                   union value_pointer rest)
 986 {
 987         return lisp_car(rest);
 988 }
 989
 990 union value_pointer builtin_plus(struct stack_slot *top_of_stack,
 991                                  struct environment *env,
 992                                  union value_pointer rest)
 993 {
 994         union value_pointer retval;
 995         int sum;
 996
 997         for (sum = 0; get_pair(rest) != get_pair(constant_nil); rest = lisp_cdr(rest)) {
 998                 sum += get_integer(lisp_car(rest));
 999         }
1000
1001         retval.vp_int = sum << 2;
1002         pointer_mark(&retval, 0);
1003
1004         return retval;
1005 }
1006
1007 union value_pointer builtin_minus(struct stack_slot *top_of_stack,
1008                                   struct environment *env,
1009                                   union value_pointer rest)
1010 {
1011         union value_pointer retval;
1012         union value_pointer lhs;
1013         int difference;
1014
1015         lhs = lisp_car(rest);
1016         rest = lisp_cdr(rest);
1017         difference = get_integer(lhs);
1018         if (get_pair(rest) != get_pair(constant_nil)) {
1019                 for (difference = get_integer(lhs);
1020                      get_pair(rest) != get_pair(constant_nil);
1021                      rest = lisp_cdr(rest)) {
1022                         difference -= get_integer(lisp_car(rest));
1023                 }
1024         } else {
1025                 difference = -get_integer(lhs);
1026         }
1027
1028         retval.vp_int = difference << 2;
1029         pointer_mark(&retval, 0);
1030
1031         return retval;
1032 }
1033 void gc_mark(union value_pointer v)
1034 {
1035         switch (pointer_type(v)) {
1036                 struct pair *p;
1037         case 1:
1038         case 2:
1039                 get_charseq(v)->gc |= 1;
1040                 break;
1041         case 3:
1042                 p = get_pair(v);
1043                 if (p->gc & 1) {
1044                         break;
1045                 }
1046                 p->gc |= 1;
1047                 if (p->car.vp_opaque != opaque_builtin_function &&
1048                     p->car.vp_opaque != opaque_builtin_macro) {
1049                         if (p->car.vp_opaque != opaque_user_function &&
1050                             p->car.vp_opaque != opaque_user_macro) {
1051                                 gc_mark(lisp_car(v));
1052                         }
1053                         gc_mark(lisp_cdr(v));
1054                 }
1055                 break;
1056         }
1057 }
1058
1059 void gc_protect(union value_pointer v)
1060 {
1061         switch (pointer_type(v)) {
1062                 struct pair *p;
1063         case 1:
1064         case 2:
1065                 get_charseq(v)->gc |= 2;
1066                 break;
1067         case 3:
1068                 p = get_pair(v);
1069                 p->gc |= 2;
1070                 break;
1071         }
1072         gc_mark(v);
1073 }
1074
1075 union value_pointer gc_unprotect(union value_pointer v)
1076 {
1077         switch (pointer_type(v)) {
1078                 struct pair *p;
1079         case 1:
1080         case 2:
1081                 get_charseq(v)->gc &= ~2;
1082                 break;
1083         case 3:
1084                 p = get_pair(v);
1085                 p->gc &= ~2;
1086                 break;
1087         }
1088
1089         return v;
1090 }
1091
1092 void gc_unmark_all(void)
1093 {
1094         int j;
1095
1096         for (j = 0; j < resource_count(&charseqs); j++) {
1097                 struct charseq *cs = resource_get(&charseqs, j);
1098                 if (cs) {
1099                         cs->gc &= ~1;
1100                 }
1101         }
1102         for (j = 0; j < resource_count(&pairs); j++) {
1103                 struct pair *p = resource_get(&pairs, j);
1104                 if (p) {
1105                         p->gc &= ~1;
1106                 }
1107         }
1108         for (j = 0; j < resource_count(&pairs); j++) {
1109                 struct pair *p = resource_get(&pairs, j);
1110                 if (p && p->gc) {
1111                         if (p->car.vp_opaque != opaque_builtin_function &&
1112                             p->car.vp_opaque != opaque_builtin_macro) {
1113                                 if (p->car.vp_opaque != opaque_user_function &&
1114                                     p->car.vp_opaque != opaque_user_macro) {
1115                                         gc_mark(p->car);
1116                                 }
1117                                 gc_mark(p->cdr);
1118                         }
1119                 }
1120         }
1121 }
1122
1123 void gc_collect(struct environment *env)
1124 {
1125         int j;
1126
1127         gc_unmark_all();
1128
1129         for (; env; env = env->parent) {
1130                 for (j = 0; j < resource_count(&env->variables); j++) {
1131                         struct binding *b = resource_get(&env->variables, j);
1132
1133                         if (b) {
1134                                 gc_mark(b->name);
1135                                 gc_mark(b->value);
1136                         }
1137                 }
1138         }
1139
1140         for (j = 0; j < resource_count(&charseqs); j++) {
1141                 struct charseq *cs = resource_get(&charseqs, j);
1142                 if (cs && cs->gc == 0) {
1143                         free(cs->s);
1144                         resource_free(&charseqs, j);
1145                 }
1146         }
1147         for (j = 0; j < resource_count(&pairs); j++) {
1148                 struct pair *p = resource_get(&pairs, j);
1149                 if (p && p->gc == 0) {
1150                         resource_free(&pairs, j);
1151                 }
1152         }
1153 }
1154
1155 int main()
1156 {
1157         char *buf = NULL;
1158         size_t bufused = 0;
1159         size_t bufsize = 0;
1160         size_t formsize;
1161         union value_pointer i, form;
1162         struct environment *top_env;
1163         int j;
1164
1165         resource_pool_init(&bindings, sizeof (struct binding));
1166         resource_pool_init(&charseqs, sizeof (struct charseq));
1167         resource_pool_init(&environments, sizeof (struct environment));
1168         resource_pool_init(&pairs, sizeof (struct pair));
1169         resource_pool_init(&stack_slots, sizeof (struct stack_slot));
1170
1171         constant_nil = pair_new();
1172         get_pair(constant_nil)->car = constant_nil;
1173         get_pair(constant_nil)->cdr = constant_nil;
1174
1175         while (!feof(stdin) && !ferror(stdin)) {
1176                 size_t n;
1177
1178                 if (bufused >= bufsize) {
1179                         buf = realloc(buf, bufsize * 2 + 16);
1180                         if (buf == NULL) {
1181                                 abort();
1182                         }
1183                         bufsize = bufsize * 2 + 16;
1184                 }
1185                 n = fread(buf + bufused, 1, bufsize - bufused, stdin);
1186                 bufused += n;
1187         }
1188
1189         top_env = environment_new(NULL);
1190
1191         constant_true = charseq_new("#t", 2, 2, 1);
1192         constant_false = charseq_new("#f", 2, 2, 1);
1193
1194         binding_new(top_env, "#t", constant_true);
1195         binding_new(top_env, "#f", constant_false);
1196
1197         binding_new(top_env, "car", builtin_new(opaque_builtin_function, builtin_car));
1198         binding_new(top_env, "cdr", builtin_new(opaque_builtin_function, builtin_cdr));
1199         binding_new(top_env, "cons", builtin_new(opaque_builtin_function, builtin_cons));
1200         binding_new(top_env, "eq?", builtin_new(opaque_builtin_function, builtin_eq_p));
1201         binding_new(top_env, "display", builtin_new(opaque_builtin_function, builtin_display));
1202         binding_new(top_env, "list?", builtin_new(opaque_builtin_function, builtin_list_p));
1203         binding_new(top_env, "primitive-eval", builtin_new(opaque_builtin_function, builtin_eval));
1204         binding_new(top_env, "string->list", builtin_new(opaque_builtin_function, builtin_string_to_list));
1205
1206         binding_new(top_env, "define", builtin_new(opaque_builtin_macro, builtin_define));
1207         binding_new(top_env, "if", builtin_new(opaque_builtin_macro, builtin_if));
1208         binding_new(top_env, "lambda", builtin_new(opaque_builtin_macro, builtin_lambda));
1209         binding_new(top_env, "quote", builtin_new(opaque_builtin_macro, builtin_quote));
1210
1211         binding_new(top_env, "+", builtin_new(opaque_builtin_function, builtin_plus));
1212         binding_new(top_env, "-", builtin_new(opaque_builtin_function, builtin_minus));
1213
1214         form = lisp_cons(constant_nil, constant_nil);
1215
1216         formsize = parse_forms(buf, bufused, &get_pair(form)->cdr);
1217         i = form;
1218         form = lisp_cdr(form);
1219         gc_protect(form);
1220         gc_unprotect(i);
1221
1222         if (formsize != bufused) {
1223                 printf("this stuff left over: \"%.*s\"\n",
1224                        bufused - formsize, buf + formsize);
1225         }
1226
1227         for (i = form; get_pair(i) != get_pair(constant_nil); i = form) {
1228                 union value_pointer rest, retval;
1229
1230                 rest = lisp_cons(lisp_car(i), constant_nil);
1231
1232                 pretty_print(lisp_car(i));
1233                 printf(" -> ");
1234                 retval = builtin_eval(NULL, top_env, rest);
1235                 gc_unprotect(rest);
1236                 pretty_print(retval);
1237                 gc_unprotect(retval);
1238                 printf("\n");
1239
1240                 form = lisp_cdr(i);
1241                 gc_protect(form);
1242                 gc_unprotect(i);
1243
1244                 gc_collect(top_env);
1245         }
1246
1247         environment_free(top_env);
1248
1249         gc_unprotect(constant_nil);
1250         gc_collect(NULL);
1251
1252         resource_pool_free(&charseqs);
1253         resource_pool_free(&pairs);
1254         free(bindings.resources);
1255         free(environments.resources);
1256
1257         free(buf);
1258
1259         return 0;
1260 }