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 int lisp_length(union value_pointer v)
 271 {
 272         int n;
 273
 274         n = 0;
 275         while (pointer_type(v) == 3 && get_pair(v) != get_pair(constant_nil)) {
 276                 n++;
 277                 v = lisp_cdr(v);
 278         }
 279
 280         return n;
 281 }
 282
 283 union value_pointer lisp_cons(union value_pointer left, union value_pointer right)
 284 {
 285         union value_pointer retval;
 286
 287         retval = pair_new();
 288         get_pair(retval)->car = left;
 289         get_pair(retval)->cdr = right;
 290         pointer_mark(&retval, 3);
 291
 292         if (left.vp_opaque != opaque_builtin_function &&
 293             left.vp_opaque != opaque_builtin_macro) {
 294                 if (left.vp_opaque != opaque_user_function &&
 295                     left.vp_opaque != opaque_user_macro) {
 296                         gc_unprotect(left);
 297                 }
 298                 gc_unprotect(right);
 299         }
 300
 301         return retval;
 302 }
 303
 304 union value_pointer lisp_integer(int n)
 305 {
 306         union value_pointer retval;
 307
 308         retval.vp_int = n << 2;
 309         pointer_mark(&retval, 0);
 310
 311         return retval;
 312 }
 313
 314 union value_pointer lisp_opaque(char const *cookie)
 315 {
 316         union value_pointer retval;
 317
 318         retval.vp_opaque = cookie;
 319
 320         return retval;
 321 }
 322
 323 union value_pointer lisp_builtin(union value_pointer (*builtin)(struct stack_slot *top_of_stack,
 324                                                                 struct environment *env,
 325                                                                 union value_pointer rest))
 326 {
 327         union value_pointer retval;
 328
 329         retval.vp_builtin = builtin;
 330
 331         return retval;
 332 }
 333
 334 struct binding *binding_new(struct environment *env,
 335                             char const *name,
 336                             union value_pointer value)
 337 {
 338         struct binding *b;
 339         int bnum;
 340
 341         bnum = resource_new_i(&bindings);
 342         b = resource_get(&bindings, bnum);
 343         b->resource_num = bnum;
 344         b->name = charseq_new(name, strlen(name), strlen(name), 1);
 345         b->value = value;
 346
 347         resource_add(&env->variables, b);
 348
 349         gc_unprotect(b->name);
 350         gc_unprotect(b->value);
 351
 352         return b;
 353 }
 354
 355 union value_pointer builtin_new(char const *opaque_type,
 356                                 union value_pointer (*builtin)(struct stack_slot *top_of_stack,
 357                                                                struct environment *env,
 358                                                                union value_pointer rest))
 359 {
 360         return lisp_cons(lisp_opaque(opaque_type),
 361                          lisp_builtin(builtin));
 362 }
 363
 364 size_t parse_word(union value_pointer *vp, char const *buf, size_t len)
 365 {
 366         size_t i;
 367         int n;
 368
 369         for (n = 0, i = 0; i < len; i++) {
 370                 if (buf[i] < '0' || buf[i] > '9') {
 371                         break;
 372                 }
 373                 n = n*10 + buf[i] - '0';
 374         }
 375
 376         if (i < len) {
 377                 char *symbol;
 378
 379                 switch (buf[i]) {
 380                 case ')':
 381                 case ' ':
 382                 case '\n':
 383                 case '\t':
 384                         break;
 385                 default:
 386                         for (i++; i < len; i++) {
 387                                 switch (buf[i]) {
 388                                 case ')':
 389                                 case ' ':
 390                                 case '\n':
 391                                 case '\t':
 392                                         len = i + 1;
 393                                         break;
 394                                 default:
 395                                         continue;
 396                                 }
 397                                 break;
 398                         }
 399                         *vp = charseq_new(buf, i, i, 1);
 400                         gc_unprotect(*vp);
 401                         return i;
 402                 }
 403         }
 404         vp->vp_int = n << 2;
 405         pointer_mark(vp, 0);
 406         return i;
 407 }
 408
 409 size_t parse_string(union value_pointer *vp, char const *buf, size_t len)
 410 {
 411         size_t i, n;
 412         char *s;
 413         int backslash;
 414
 415         for (backslash = n = 0, i = 1; i < len; i++) {
 416                 if (backslash) {
 417                         n++;
 418                         backslash = 0;
 419                 } else if (buf[i] == '"') {
 420                         break;
 421                 } else if (buf[i] == '\\') {
 422                         backslash = 1;
 423                 } else {
 424                         n++;
 425                 }
 426         }
 427         len = i;
 428
 429         *vp = charseq_new(buf + 1, n, n, 2);
 430         gc_unprotect(*vp);
 431
 432         for (backslash = 0, i = 1, s = get_charseq_chars(*vp); i < len; i++) {
 433                 if (backslash) {
 434                         switch (buf[i]) {
 435                         case 'n':
 436                                 *s++ = '\n';
 437                                 break;
 438                         default:
 439                                 *s++ = buf[i];
 440                                 break;
 441                         }
 442                         backslash = 0;
 443                 } else if (buf[i] == '\\') {
 444                         backslash = 1;
 445                 } else {
 446                         *s++ = buf[i];
 447                 }
 448         }
 449
 450         return i + 1;
 451 }
 452
 453 size_t parse_forms(char const *buf, size_t len, union value_pointer *form)
 454 {
 455         size_t i, n;
 456         int improper = 0;
 457
 458         for (i = 0; i < len; i++) {
 459                 char const c = buf[i];
 460                 union value_pointer u, v;
 461
 462                 v = constant_nil;
 463
 464                 switch (c) {
 465                 case '(':
 466                         u = constant_nil;
 467                         n = parse_forms(buf + i + 1, len - i - 1, &u) + 1;
 468                         i += n;
 469                         if (improper) {
 470                                 *form = u;
 471                         } else {
 472                                 v = lisp_cons(u, constant_nil);
 473                                 *form = v;
 474                                 gc_unprotect(v);
 475                                 form = &get_pair(*form)->cdr;
 476                         }
 477                         break;
 478                 case ')':
 479                 case ' ':
 480                 case '\n':
 481                 case '\t':
 482                         break;
 483                 case '"':
 484                         v = pair_new();
 485                         n = parse_string(&get_pair(v)->car, buf + i, len - i);
 486                         i += n - 1;
 487                         *form = v;
 488                         gc_unprotect(v);
 489                         pointer_mark(form, 3);
 490                         form = &get_pair(v)->cdr;
 491                         break;
 492                 default:
 493                         n = parse_word(&u, buf + i, len - i);
 494                         if (pointer_type(u) == 1 &&
 495                             strcmp(get_charseq_chars(u), ".") == 0) {
 496                                 improper = 1;
 497                         }
 498                         if (improper) {
 499                                 *form = u;
 500                         } else {
 501                                 *form = lisp_cons(u, constant_nil);
 502                                 gc_unprotect(*form);
 503                                 form = &get_pair(*form)->cdr;
 504                         }
 505                         gc_unprotect(u);
 506                         i += n - 1;
 507                         break;
 508                 }
 509
 510                 if (c == ')') {
 511                         break;
 512                 }
 513         }
 514
 515         return i;
 516 }
 517
 518 void pretty_print(union value_pointer v)
 519 {
 520         union value_pointer i;
 521         struct pair *p;
 522
 523         switch (pointer_type(v)) {
 524         case 0:
 525                 printf("%d", get_integer(v));
 526                 break;
 527         case 1:
 528                 printf("%s", get_charseq_chars(v));
 529                 break;
 530         case 2:
 531                 printf("\"%s\"", get_charseq_chars(v));
 532                 break;
 533         case 3:
 534                 p = get_pair(v);
 535                 if (p != get_pair(constant_nil) &&
 536                     (p->car.vp_opaque == opaque_builtin_function ||
 537                      p->car.vp_opaque == opaque_builtin_macro ||
 538                      p->car.vp_opaque == opaque_user_function ||
 539                      p->car.vp_opaque == opaque_user_macro)) {
 540                         printf("%s", p->car.vp_opaque);
 541                         break;
 542                 }
 543
 544                 printf("(");
 545                 for (i = v;
 546                      pointer_type(i) == 3 && get_pair(i) != get_pair(constant_nil);
 547                      i = lisp_cdr(i)) {
 548                         if (i.vp_pair != v.vp_pair) {
 549                                 printf(" ");
 550                         }
 551                         pretty_print(lisp_car(i));
 552                 }
 553                 if (pointer_type(i) != 3) {
 554                         printf(" . ");
 555                         pretty_print(i);
 556                 }
 557                 printf(")");
 558                 break;
 559         }
 560 }
 561
 562 struct stack_slot *stack_call(struct stack_slot *top_of_stack,
 563                               struct environment *env,
 564                               union value_pointer rest)
 565 {
 566         struct stack_slot *slot;
 567         int slotnum;
 568
 569         slotnum = resource_new_i(&stack_slots);
 570         slot = resource_get(&stack_slots, slotnum);
 571         slot->resource_num = slotnum;
 572         slot->evaluating = 1;
 573         slot->return_path = 4040;
 574         slot->env = env;
 575         slot->rest = rest;
 576         slot->prev = top_of_stack;
 577         slot->gc = 2;
 578
 579         return slot;
 580 }
 581
 582 struct stack_slot *stack_return(struct stack_slot *top_of_stack)
 583 {
 584         struct stack_slot *slot;
 585
 586         slot = top_of_stack->prev;
 587
 588         resource_free(&stack_slots, top_of_stack->resource_num);
 589
 590         return slot;
 591 }
 592
 593 union value_pointer eval_symbol(struct environment *env, union value_pointer sym)
 594 {
 595         char const *symbol_name;
 596         int i;
 597
 598         symbol_name = get_charseq_chars(sym);
 599         do {
 600                 for (i = 0; i < resource_count(&env->variables); i++) {
 601                         struct binding *b;
 602
 603                         b = resource_get(&env->variables, i);
 604                         if (strcmp(get_charseq_chars(b->name), symbol_name) == 0) {
 605                                 return b->value;
 606                         }
 607                 }
 608                 env = env->parent;
 609         } while (env != NULL);
 610
 611         return constant_nil;
 612 }
 613
 614 union value_pointer builtin_eval(struct stack_slot *caller,
 615                                  struct environment *env_toplevel,
 616                                  union value_pointer rest_toplevel)
 617 {
 618         struct stack_slot *top_of_stack;
 619         union value_pointer element;
 620         union value_pointer consequent, alternate;
 621         union value_pointer retval;
 622         struct pair *closure;
 623
 624         top_of_stack = stack_call(caller, env_toplevel, rest_toplevel);
 625         top_of_stack->return_path = 0;
 626
 627         while (1) {
 628                 if (top_of_stack->evaluating) {
 629                         switch (pointer_type(lisp_car(top_of_stack->rest))) {
 630                         case 0:
 631                         case 2:
 632                                 top_of_stack->retval = lisp_car(top_of_stack->rest);
 633                                 break;
 634                         case 1:
 635                                 top_of_stack->retval = eval_symbol(top_of_stack->env,
 636                                                                    lisp_car(top_of_stack->rest));
 637                                 break;
 638                         case 3:
 639                                 top_of_stack->list = lisp_car(top_of_stack->rest);
 640                                 top_of_stack->subeval_arg = lisp_cons(lisp_car(top_of_stack->list), constant_nil);
 641
 642                                 top_of_stack = stack_call(top_of_stack,
 643                                                           top_of_stack->env,
 644                                                           top_of_stack->subeval_arg);
 645                                 top_of_stack->return_path = 3;
 646                                 continue;
 647                         }
 648                 }
 649                 switch (top_of_stack->return_path) {
 650                 case 0:
 651                         retval = top_of_stack->retval;
 652                         stack_return(top_of_stack);
 653                         return retval;
 654                 case 1:
 655                         retval = top_of_stack->retval;
 656                         top_of_stack = stack_return(top_of_stack);
 657                         top_of_stack->retval = retval;
 658                         gc_unprotect(top_of_stack->sexpr);
 659                         top_of_stack->p = lisp_cdr(top_of_stack->p);
 660                         if (get_pair(top_of_stack->p) != get_pair(constant_nil)) {
 661                                 top_of_stack->sexpr = lisp_cons(lisp_car(top_of_stack->p), constant_nil);
 662                                 if (get_pair(lisp_cdr(top_of_stack->p)) == get_pair(constant_nil)) {
 663                                         top_of_stack->env = top_of_stack->call_env;
 664                                         top_of_stack->rest = top_of_stack->sexpr;
 665                                         continue;
 666                                 }
 667                                 top_of_stack = stack_call(top_of_stack,
 668                                                           top_of_stack->call_env,
 669                                                           top_of_stack->sexpr);
 670                                 top_of_stack->return_path = 1;
 671                                 continue;
 672                         }
 673                         environment_free(top_of_stack->call_env);
 674                         gc_unprotect(top_of_stack->list);
 675                         break;
 676                 case 3:
 677                         top_of_stack->prev->args = lisp_cons(top_of_stack->retval, constant_nil);
 678                         top_of_stack = stack_return(top_of_stack);
 679                         gc_unprotect(top_of_stack->subeval_arg);
 680
 681                         if (lisp_car(lisp_car(top_of_stack->args)).vp_opaque == opaque_builtin_function ||
 682                             lisp_car(lisp_car(top_of_stack->args)).vp_opaque == opaque_user_function) {
 683                                 top_of_stack->arglink = &get_pair(top_of_stack->args)->cdr;
 684
 685                                 top_of_stack->list = lisp_cdr(top_of_stack->list);
 686
 687                                 if (0) {
 688                 case 4:
 689                                         element = lisp_cons(top_of_stack->retval, constant_nil);
 690                                         top_of_stack = stack_return(top_of_stack);
 691                                         gc_unprotect(top_of_stack->subeval_arg);
 692
 693                                         *top_of_stack->arglink = element;
 694                                         top_of_stack->arglink = &get_pair(element)->cdr;
 695
 696                                         gc_unprotect(element);
 697                                         top_of_stack->list = lisp_cdr(top_of_stack->list);
 698                                 }
 699                                 if (get_pair(top_of_stack->list) != get_pair(constant_nil)) {
 700                                         top_of_stack->subeval_arg = lisp_cons(lisp_car(top_of_stack->list),
 701                                                                               constant_nil);
 702
 703                                         top_of_stack = stack_call(top_of_stack,
 704                                                                   top_of_stack->env,
 705                                                                   top_of_stack->subeval_arg);
 706                                         top_of_stack->return_path = 4;
 707                                         continue;
 708                                 }
 709                         } else {
 710                                 get_pair(top_of_stack->args)->cdr = lisp_cdr(top_of_stack->list);
 711                         }
 712                 case 5:
 713                         top_of_stack->list = top_of_stack->args;
 714                         top_of_stack->function = lisp_car(top_of_stack->list);
 715                         top_of_stack->args = lisp_cdr(top_of_stack->list);
 716
 717                         closure = get_pair(top_of_stack->function);
 718                         if (closure->car.vp_opaque == opaque_builtin_function ||
 719                             closure->car.vp_opaque == opaque_builtin_macro) {
 720                                 top_of_stack = stack_call(top_of_stack,
 721                                                           top_of_stack->env,
 722                                                           top_of_stack->args);
 723                                 top_of_stack->return_path = 6;
 724                                 top_of_stack->retval = (*closure->cdr.vp_builtin)(top_of_stack,
 725                                                                                   top_of_stack->prev->env,
 726                                                                                   top_of_stack->prev->args);
 727                                 break;
 728                         } else if (closure->car.vp_opaque == opaque_user_function) {
 729                                 union value_pointer function_env;
 730                                 union value_pointer formal_args;
 731                                 union value_pointer function_body;
 732                                 struct environment *lambda_env;
 733
 734                                 top_of_stack->p = closure->cdr;
 735                                 function_env = lisp_car(top_of_stack->p);
 736                                 formal_args = lisp_car(lisp_cdr(top_of_stack->p));
 737                                 function_body = lisp_cdr(lisp_cdr(top_of_stack->p));
 738
 739                                 lambda_env = resource_get(&environments,
 740                                                           get_integer(function_env));
 741                                 top_of_stack->call_env = environment_new(lambda_env);
 742                                 for (top_of_stack->p = formal_args;
 743                                      (pointer_type(top_of_stack->p) == 3 &&
 744                                       get_pair(top_of_stack->p) != get_pair(constant_nil) &&
 745                                       get_pair(top_of_stack->args) != get_pair(constant_nil));
 746                                      top_of_stack->p = lisp_cdr(top_of_stack->p),
 747                                      top_of_stack->args = lisp_cdr(top_of_stack->args)) {
 748                                         binding_new(top_of_stack->call_env,
 749                                                     get_charseq_chars(lisp_car(top_of_stack->p)),
 750                                                     lisp_car(top_of_stack->args));
 751                                 }
 752                                 if (pointer_type(top_of_stack->p) == 1) {
 753                                         binding_new(top_of_stack->call_env,
 754                                                     get_charseq_chars(top_of_stack->p),
 755                                                     top_of_stack->args);
 756                                 }
 757
 758                                 top_of_stack->p = function_body;
 759                                 if (get_pair(top_of_stack->p) != get_pair(constant_nil)) {
 760                                         top_of_stack->sexpr = lisp_cons(lisp_car(top_of_stack->p), constant_nil);
 761                                         if (get_pair(lisp_cdr(top_of_stack->p)) == get_pair(constant_nil)) {
 762                                                 top_of_stack->env = top_of_stack->call_env;
 763                                                 top_of_stack->rest = top_of_stack->sexpr;
 764                                                 continue;
 765                                         }
 766                                         top_of_stack = stack_call(top_of_stack,
 767                                                                   top_of_stack->call_env,
 768                                                                   top_of_stack->sexpr);
 769                                         top_of_stack->return_path = 1;
 770                                         continue;
 771                                 }
 772                                 environment_free(top_of_stack->call_env);
 773                                 break;
 774                         }
 775                         gc_unprotect(top_of_stack->list);
 776                         break;
 777                 case 6:
 778                         retval = top_of_stack->retval;
 779                         top_of_stack = stack_return(top_of_stack);
 780                         top_of_stack->retval = retval;
 781                         gc_unprotect(top_of_stack->list);
 782                         break;
 783                 case 7:
 784                         top_of_stack->return_path = 8;
 785                         top_of_stack->evaluating = 1;
 786                         continue;
 787                 case 8:
 788                         retval = top_of_stack->retval;
 789                         gc_unprotect(top_of_stack->rest);
 790                         top_of_stack = stack_return(top_of_stack);
 791
 792                         consequent = lisp_car(lisp_cdr(lisp_cdr(lisp_car(top_of_stack->rest))));
 793                         alternate = lisp_cdr(lisp_cdr(lisp_cdr(lisp_car(top_of_stack->rest))));
 794                         if (pointer_type(retval) != 1 ||
 795                             retval.vp_charseq != constant_false.vp_charseq) {
 796                                 element = lisp_cons(consequent, constant_nil);
 797                         } else if (get_pair(alternate) != get_pair(constant_nil)) {
 798                                 element = lisp_cons(lisp_car(alternate), constant_nil);
 799                         } else {
 800                                 top_of_stack->retval = constant_nil;
 801                                 break;
 802                         }
 803
 804                         gc_unprotect(retval);
 805                         top_of_stack->rest = element;
 806                         top_of_stack->evaluating = 1;
 807                         continue;
 808                 }
 809                 top_of_stack->evaluating = 0;
 810         }
 811 }
 812
 813 union value_pointer builtin_string_to_list(struct stack_slot *top_of_stack,
 814                                            struct environment *env,
 815                                            union value_pointer rest)
 816 {
 817         union value_pointer retval;
 818         union value_pointer *v;
 819         char const *s;
 820         size_t i, n;
 821
 822         s = get_charseq_chars(lisp_car(rest));
 823         n = get_charseq_len(lisp_car(rest));
 824         retval = lisp_cons(constant_nil, constant_nil);
 825         v = &get_pair(retval)->cdr;
 826         for (i = 0; i < n; i++) {
 827                 *v = lisp_cons(lisp_integer(s[i]), constant_nil);
 828                 gc_unprotect(*v);
 829                 v = &get_pair(*v)->cdr;
 830         }
 831         v = &get_pair(retval)->cdr;
 832         gc_protect(*v);
 833         gc_unprotect(retval);
 834         retval = *v;
 835
 836         return retval;
 837 }
 838
 839 union value_pointer builtin_list_to_string(struct stack_slot *top_of_stack,
 840                                            struct environment *env,
 841                                            union value_pointer rest)
 842 {
 843         union value_pointer retval;
 844         union value_pointer l;
 845         struct charseq *cs;
 846         int i, n;
 847
 848         l = lisp_car(rest);
 849         n = lisp_length(l);
 850         retval = charseq_new("", 0, n, 2);
 851         cs = get_charseq(retval);
 852         for (i = 0; i < n; i++) {
 853                 cs->s[i] = get_integer(lisp_car(l));
 854                 l = lisp_cdr(l);
 855         }
 856         cs->s[i] = 0;
 857
 858         return retval;
 859 }
 860
 861 union value_pointer builtin_car(struct stack_slot *top_of_stack,
 862                                 struct environment *env,
 863                                 union value_pointer rest)
 864 {
 865         return lisp_car(lisp_car(rest));
 866 }
 867
 868 union value_pointer builtin_cdr(struct stack_slot *top_of_stack,
 869                                 struct environment *env,
 870                                 union value_pointer rest)
 871 {
 872         return lisp_cdr(lisp_car(rest));
 873 }
 874
 875 union value_pointer builtin_cons(struct stack_slot *top_of_stack,
 876                                  struct environment *env,
 877                                  union value_pointer rest)
 878 {
 879         return gc_unprotect(lisp_cons(lisp_car(rest), lisp_car(lisp_cdr(rest))));
 880 }
 881
 882 union value_pointer builtin_eq_p(struct stack_slot *top_of_stack,
 883                                  struct environment *env,
 884                                  union value_pointer rest)
 885 {
 886         union value_pointer a, b;
 887
 888         a = lisp_car(rest);
 889         b = lisp_car(lisp_cdr(rest));
 890
 891         if (pointer_type(a) != pointer_type(b)) {
 892                 return constant_false;
 893         }
 894
 895         switch (pointer_type(a)) {
 896         case 0:
 897                 if (get_integer(a) != get_integer(b)) {
 898                         return constant_false;
 899                 }
 900                 break;
 901         case 1:
 902         case 2:
 903                 if (get_charseq(a) != get_charseq(b)) {
 904                         return constant_false;
 905                 }
 906                 break;
 907         case 3:
 908                 if (a.vp_pair != b.vp_pair) {
 909                         return constant_false;
 910                 }
 911                 break;
 912         }
 913
 914         return constant_true;
 915 }
 916
 917 union value_pointer builtin_display(struct stack_slot *top_of_stack,
 918                                     struct environment *env,
 919                                     union value_pointer rest)
 920 {
 921         pretty_print(lisp_car(rest));
 922
 923         return constant_true;
 924 }
 925
 926 union value_pointer builtin_list_p_helper(union value_pointer v)
 927 {
 928         if (pointer_type(v) == 3) {
 929                 if (get_pair(v) == get_pair(constant_nil)) {
 930                         return constant_true;
 931                 } else {
 932                         return builtin_list_p_helper(lisp_cdr(v));
 933                 }
 934         } else {
 935                 return constant_false;
 936         }
 937 }
 938
 939 union value_pointer builtin_list_p(struct stack_slot *top_of_stack,
 940                                    struct environment *env,
 941                                    union value_pointer rest)
 942 {
 943         return builtin_list_p_helper(lisp_car(rest));
 944 }
 945
 946 union value_pointer builtin_define(struct stack_slot *top_of_stack,
 947                                    struct environment *env,
 948                                    union value_pointer rest)
 949 {
 950         union value_pointer name_and_args, definition;
 951         union value_pointer lambda_args, function;
 952
 953         name_and_args = lisp_car(rest);
 954         definition = lisp_car(lisp_cdr(rest));
 955
 956         lambda_args = lisp_cons(lisp_cdr(name_and_args), lisp_cons(definition, constant_nil));
 957
 958         function = builtin_lambda(top_of_stack, env, lambda_args);
 959         gc_unprotect(lambda_args);
 960
 961         binding_new(env, get_charseq_chars(lisp_car(name_and_args)), function);
 962
 963         return constant_nil;
 964 }
 965
 966 union value_pointer builtin_if(struct stack_slot *top_of_stack,
 967                                struct environment *env,
 968                                union value_pointer rest)
 969 {
 970         union value_pointer retval;
 971         union value_pointer condition, consequent, alternate;
 972         union value_pointer v;
 973
 974         retval = constant_nil;
 975
 976         condition = lisp_car(rest);
 977         consequent = lisp_car(lisp_cdr(rest));
 978         alternate = lisp_cdr(lisp_cdr(rest));
 979
 980         v = lisp_cons(condition, constant_nil);
 981
 982         top_of_stack->rest = v;
 983         top_of_stack->return_path = 7;
 984         return;
 985
 986         condition = builtin_eval(top_of_stack, env, v);
 987         gc_unprotect(v);
 988
 989         if (pointer_type(condition) != 1 ||
 990             condition.vp_charseq != constant_false.vp_charseq) {
 991                 v = lisp_cons(consequent, constant_nil);
 992         } else if (get_pair(alternate) != get_pair(constant_nil)) {
 993                 v = lisp_cons(lisp_car(alternate), constant_nil);
 994         } else {
 995                 return retval;
 996         }
 997
 998         gc_unprotect(condition);
 999         retval = builtin_eval(top_of_stack, env, v);
1000         gc_unprotect(v);
1001
1002         return retval;
1003 }
1004
1005 union value_pointer builtin_lambda(struct stack_slot *top_of_stack,
1006                                    struct environment *env,
1007                                    union value_pointer rest)
1008 {
1009         union value_pointer retval;
1010
1011         retval = lisp_cons(lisp_opaque(opaque_user_function),
1012                            lisp_cons(lisp_integer(env->resource_num), rest));
1013         pointer_mark(&retval, 3);
1014
1015         return retval;
1016 }
1017
1018 union value_pointer builtin_quote(struct stack_slot *top_of_stack,
1019                                   struct environment *env,
1020                                   union value_pointer rest)
1021 {
1022         return lisp_car(rest);
1023 }
1024
1025 union value_pointer builtin_plus(struct stack_slot *top_of_stack,
1026                                  struct environment *env,
1027                                  union value_pointer rest)
1028 {
1029         union value_pointer retval;
1030         int sum;
1031
1032         for (sum = 0; get_pair(rest) != get_pair(constant_nil); rest = lisp_cdr(rest)) {
1033                 sum += get_integer(lisp_car(rest));
1034         }
1035
1036         retval.vp_int = sum << 2;
1037         pointer_mark(&retval, 0);
1038
1039         return retval;
1040 }
1041
1042 union value_pointer builtin_minus(struct stack_slot *top_of_stack,
1043                                   struct environment *env,
1044                                   union value_pointer rest)
1045 {
1046         union value_pointer retval;
1047         union value_pointer lhs;
1048         int difference;
1049
1050         lhs = lisp_car(rest);
1051         rest = lisp_cdr(rest);
1052         difference = get_integer(lhs);
1053         if (get_pair(rest) != get_pair(constant_nil)) {
1054                 for (difference = get_integer(lhs);
1055                      get_pair(rest) != get_pair(constant_nil);
1056                      rest = lisp_cdr(rest)) {
1057                         difference -= get_integer(lisp_car(rest));
1058                 }
1059         } else {
1060                 difference = -get_integer(lhs);
1061         }
1062
1063         retval.vp_int = difference << 2;
1064         pointer_mark(&retval, 0);
1065
1066         return retval;
1067 }
1068 void gc_mark(union value_pointer v)
1069 {
1070         switch (pointer_type(v)) {
1071                 struct pair *p;
1072         case 1:
1073         case 2:
1074                 get_charseq(v)->gc |= 1;
1075                 break;
1076         case 3:
1077                 p = get_pair(v);
1078                 if (p->gc & 1) {
1079                         break;
1080                 }
1081                 p->gc |= 1;
1082                 if (p->car.vp_opaque != opaque_builtin_function &&
1083                     p->car.vp_opaque != opaque_builtin_macro) {
1084                         if (p->car.vp_opaque != opaque_user_function &&
1085                             p->car.vp_opaque != opaque_user_macro) {
1086                                 gc_mark(lisp_car(v));
1087                         }
1088                         gc_mark(lisp_cdr(v));
1089                 }
1090                 break;
1091         }
1092 }
1093
1094 void gc_protect(union value_pointer v)
1095 {
1096         switch (pointer_type(v)) {
1097                 struct pair *p;
1098         case 1:
1099         case 2:
1100                 get_charseq(v)->gc |= 2;
1101                 break;
1102         case 3:
1103                 p = get_pair(v);
1104                 p->gc |= 2;
1105                 break;
1106         }
1107         gc_mark(v);
1108 }
1109
1110 union value_pointer gc_unprotect(union value_pointer v)
1111 {
1112         switch (pointer_type(v)) {
1113                 struct pair *p;
1114         case 1:
1115         case 2:
1116                 get_charseq(v)->gc &= ~2;
1117                 break;
1118         case 3:
1119                 p = get_pair(v);
1120                 p->gc &= ~2;
1121                 break;
1122         }
1123
1124         return v;
1125 }
1126
1127 void gc_unmark_all(void)
1128 {
1129         int j;
1130
1131         for (j = 0; j < resource_count(&charseqs); j++) {
1132                 struct charseq *cs = resource_get(&charseqs, j);
1133                 if (cs) {
1134                         cs->gc &= ~1;
1135                 }
1136         }
1137         for (j = 0; j < resource_count(&pairs); j++) {
1138                 struct pair *p = resource_get(&pairs, j);
1139                 if (p) {
1140                         p->gc &= ~1;
1141                 }
1142         }
1143         for (j = 0; j < resource_count(&pairs); j++) {
1144                 struct pair *p = resource_get(&pairs, j);
1145                 if (p && p->gc) {
1146                         if (p->car.vp_opaque != opaque_builtin_function &&
1147                             p->car.vp_opaque != opaque_builtin_macro) {
1148                                 if (p->car.vp_opaque != opaque_user_function &&
1149                                     p->car.vp_opaque != opaque_user_macro) {
1150                                         gc_mark(p->car);
1151                                 }
1152                                 gc_mark(p->cdr);
1153                         }
1154                 }
1155         }
1156 }
1157
1158 void gc_collect(struct environment *env)
1159 {
1160         int j;
1161
1162         gc_unmark_all();
1163
1164         for (; env; env = env->parent) {
1165                 for (j = 0; j < resource_count(&env->variables); j++) {
1166                         struct binding *b = resource_get(&env->variables, j);
1167
1168                         if (b) {
1169                                 gc_mark(b->name);
1170                                 gc_mark(b->value);
1171                         }
1172                 }
1173         }
1174
1175         for (j = 0; j < resource_count(&charseqs); j++) {
1176                 struct charseq *cs = resource_get(&charseqs, j);
1177                 if (cs && cs->gc == 0) {
1178                         free(cs->s);
1179                         resource_free(&charseqs, j);
1180                 }
1181         }
1182         for (j = 0; j < resource_count(&pairs); j++) {
1183                 struct pair *p = resource_get(&pairs, j);
1184                 if (p && p->gc == 0) {
1185                         resource_free(&pairs, j);
1186                 }
1187         }
1188 }
1189
1190 int main()
1191 {
1192         char *buf = NULL;
1193         size_t bufused = 0;
1194         size_t bufsize = 0;
1195         size_t formsize;
1196         union value_pointer i, form;
1197         struct environment *top_env;
1198         int j;
1199
1200         resource_pool_init(&bindings, sizeof (struct binding));
1201         resource_pool_init(&charseqs, sizeof (struct charseq));
1202         resource_pool_init(&environments, sizeof (struct environment));
1203         resource_pool_init(&pairs, sizeof (struct pair));
1204         resource_pool_init(&stack_slots, sizeof (struct stack_slot));
1205
1206         constant_nil = pair_new();
1207         get_pair(constant_nil)->car = constant_nil;
1208         get_pair(constant_nil)->cdr = constant_nil;
1209
1210         while (!feof(stdin) && !ferror(stdin)) {
1211                 size_t n;
1212
1213                 if (bufused >= bufsize) {
1214                         buf = realloc(buf, bufsize * 2 + 16);
1215                         if (buf == NULL) {
1216                                 abort();
1217                         }
1218                         bufsize = bufsize * 2 + 16;
1219                 }
1220                 n = fread(buf + bufused, 1, bufsize - bufused, stdin);
1221                 bufused += n;
1222         }
1223
1224         top_env = environment_new(NULL);
1225
1226         constant_true = charseq_new("#t", 2, 2, 1);
1227         constant_false = charseq_new("#f", 2, 2, 1);
1228
1229         binding_new(top_env, "#t", constant_true);
1230         binding_new(top_env, "#f", constant_false);
1231
1232         binding_new(top_env, "car", builtin_new(opaque_builtin_function, builtin_car));
1233         binding_new(top_env, "cdr", builtin_new(opaque_builtin_function, builtin_cdr));
1234         binding_new(top_env, "cons", builtin_new(opaque_builtin_function, builtin_cons));
1235         binding_new(top_env, "eq?", builtin_new(opaque_builtin_function, builtin_eq_p));
1236         binding_new(top_env, "display", builtin_new(opaque_builtin_function, builtin_display));
1237         binding_new(top_env, "list?", builtin_new(opaque_builtin_function, builtin_list_p));
1238         binding_new(top_env, "primitive-eval", builtin_new(opaque_builtin_function, builtin_eval));
1239         binding_new(top_env, "string->list", builtin_new(opaque_builtin_function, builtin_string_to_list));
1240         binding_new(top_env, "list->string", builtin_new(opaque_builtin_function, builtin_list_to_string));
1241
1242         binding_new(top_env, "define", builtin_new(opaque_builtin_macro, builtin_define));
1243         binding_new(top_env, "if", builtin_new(opaque_builtin_macro, builtin_if));
1244         binding_new(top_env, "lambda", builtin_new(opaque_builtin_macro, builtin_lambda));
1245         binding_new(top_env, "quote", builtin_new(opaque_builtin_macro, builtin_quote));
1246
1247         binding_new(top_env, "+", builtin_new(opaque_builtin_function, builtin_plus));
1248         binding_new(top_env, "-", builtin_new(opaque_builtin_function, builtin_minus));
1249
1250         form = lisp_cons(constant_nil, constant_nil);
1251
1252         formsize = parse_forms(buf, bufused, &get_pair(form)->cdr);
1253         i = form;
1254         form = lisp_cdr(form);
1255         gc_protect(form);
1256         gc_unprotect(i);
1257
1258         if (formsize != bufused) {
1259                 printf("this stuff left over: \"%.*s\"\n",
1260                        bufused - formsize, buf + formsize);
1261         }
1262
1263         for (i = form; get_pair(i) != get_pair(constant_nil); i = form) {
1264                 union value_pointer rest, retval;
1265
1266                 rest = lisp_cons(lisp_car(i), constant_nil);
1267
1268                 pretty_print(lisp_car(i));
1269                 printf(" -> ");
1270                 retval = builtin_eval(NULL, top_env, rest);
1271                 gc_unprotect(rest);
1272                 pretty_print(retval);
1273                 gc_unprotect(retval);
1274                 printf("\n");
1275
1276                 form = lisp_cdr(i);
1277                 gc_protect(form);
1278                 gc_unprotect(i);
1279
1280                 gc_collect(top_env);
1281         }
1282
1283         environment_free(top_env);
1284
1285         gc_unprotect(constant_nil);
1286         gc_collect(NULL);
1287
1288         resource_pool_free(&charseqs);
1289         resource_pool_free(&pairs);
1290         free(bindings.resources);
1291         free(environments.resources);
1292
1293         free(buf);
1294
1295         return 0;
1296 }