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