lisp/lisp.c

   1 #include <stdio.h>
   2 #include <stdlib.h>
   3 #include <string.h>
   4
   5 struct environment;
   6 struct pair;
   7
   8 struct charseq {
   9         size_t len;
  10         char *s;
  11 };
  12
  13 union value_pointer {
  14         int vp_int;
  15         struct pair *vp_pair;
  16         struct charseq *vp_charseq;
  17         union value_pointer (*vp_builtin)(struct environment *env,
  18                                           struct pair *rest);
  19         char const *vp_opaque;
  20 };
  21
  22 struct binding {
  23         struct charseq *name;
  24         union value_pointer value;
  25 };
  26
  27 struct environment {
  28         struct binding **variables;
  29         int variables_used;
  30         int variables_size;
  31         struct environment *parent;
  32 };
  33
  34 struct pair {
  35         union value_pointer car;
  36         union value_pointer cdr;
  37 };
  38
  39 char const opaque_builtin_function[] = "builtin-function";
  40 char const opaque_builtin_macro[] = "builtin-macro";
  41 char const opaque_user_function[] = "user-function";
  42 char const opaque_user_macro[] = "user-macro";
  43 union value_pointer constant_true, constant_false;
  44
  45 void pointer_mark(union value_pointer *v, int type)
  46 {
  47         int pointer_bits = v->vp_int;
  48
  49         pointer_bits &= ~3;
  50         pointer_bits |= type;
  51
  52         v->vp_int = pointer_bits;
  53 }
  54
  55 int pointer_type(union value_pointer v)
  56 {
  57         return (v.vp_int & 3);
  58 }
  59
  60 int get_integer(union value_pointer v)
  61 {
  62         return (v.vp_int >> 2);
  63 }
  64
  65 struct pair *get_pair(union value_pointer v)
  66 {
  67         v.vp_int &= ~3;
  68         return v.vp_pair;
  69 }
  70
  71 struct charseq *get_charseq(union value_pointer v)
  72 {
  73         v.vp_int &= ~3;
  74         return v.vp_charseq;
  75 }
  76
  77 size_t get_charseq_length(union value_pointer v)
  78 {
  79         struct charseq *cs;
  80
  81         cs = get_charseq(v);
  82
  83         return cs->len;
  84 }
  85
  86 char *get_charseq_chars(union value_pointer v)
  87 {
  88         struct charseq *cs;
  89
  90         cs = get_charseq(v);
  91
  92         return cs->s;
  93 }
  94
  95 struct environment *environment_new(struct environment *parent)
  96 {
  97         struct environment *env;
  98
  99         env = malloc(sizeof (*env));
 100         env->variables = NULL;
 101         env->variables_used = 0;
 102         env->variables_size = 0;
 103         env->parent = parent;
 104
 105         return env;
 106 }
 107
 108 struct charseq *charseq_new(char const *s, size_t len)
 109 {
 110         struct charseq *cs;
 111
 112         cs = malloc(sizeof (*cs));
 113         cs->len = len;
 114         cs->s = malloc(len + 1);
 115         memcpy(cs->s, s, len);
 116         cs->s[len] = 0;
 117
 118         return cs;
 119 }
 120
 121 struct pair *pair_new(void)
 122 {
 123         struct pair *p;
 124
 125         p = malloc(sizeof (*p));
 126         p->cdr.vp_pair = NULL;
 127         pointer_mark(&p->cdr, 3);
 128
 129         return p;
 130 }
 131
 132 void pair_free(struct pair *p)
 133 {
 134         free(p);
 135 }
 136
 137 union value_pointer lisp_car(union value_pointer v)
 138 {
 139         return get_pair(v)->car;
 140 }
 141
 142 struct binding *binding_new(struct environment *env,
 143                             char const *name,
 144                             union value_pointer value)
 145 {
 146         struct binding *b;
 147
 148         b = malloc(sizeof (*b));
 149
 150         b->name = charseq_new(name, strlen(name));
 151
 152         b->value = value;
 153
 154         if (env->variables_used >= env->variables_size) {
 155                 int newsize = env->variables_used * 2 + 16;
 156
 157                 env->variables = realloc(env->variables,
 158                                          sizeof (*env->variables) * newsize);
 159                 env->variables_size = newsize;
 160         }
 161
 162         env->variables[env->variables_used++] = b;
 163
 164         return b;
 165 }
 166
 167 void binding_builtin(struct environment *env,
 168                      char const *name,
 169                      char const *opaque_type,
 170                      union value_pointer (*builtin)(struct environment *env,
 171                                                     struct pair *rest))
 172 {
 173         union value_pointer v;
 174         struct pair *type_dot_value;
 175
 176         type_dot_value = pair_new();
 177         type_dot_value->car.vp_opaque = opaque_type;
 178         type_dot_value->cdr.vp_builtin = builtin;
 179         v.vp_pair = type_dot_value;
 180         pointer_mark(&v, 3);
 181
 182         binding_new(env, name, v);
 183 }
 184
 185 size_t parse_word(union value_pointer *vp, char const *buf, size_t len)
 186 {
 187         size_t i;
 188         int n;
 189
 190         for (n = 0, i = 0; i < len; i++) {
 191                 if (buf[i] < '0' || buf[i] > '9') {
 192                         break;
 193                 }
 194                 n = n*10 + buf[i] - '0';
 195         }
 196
 197         if (i < len) {
 198                 char *symbol;
 199
 200                 switch (buf[i]) {
 201                 case ')':
 202                 case ' ':
 203                 case '\n':
 204                 case '\t':
 205                         break;
 206                 default:
 207                         for (i++; i < len; i++) {
 208                                 switch (buf[i]) {
 209                                 case ')':
 210                                 case ' ':
 211                                 case '\n':
 212                                 case '\t':
 213                                         len = i + 1;
 214                                         break;
 215                                 default:
 216                                         continue;
 217                                 }
 218                                 break;
 219                         }
 220                         vp->vp_charseq = charseq_new(buf, i);
 221                         pointer_mark(vp, 1);
 222                         return i;
 223                 }
 224         }
 225         vp->vp_int = n << 2;
 226         pointer_mark(vp, 0);
 227         return i;
 228 }
 229
 230 size_t parse_string(union value_pointer *vp, char const *buf, size_t len)
 231 {
 232         size_t i;
 233
 234         for (i = 1; i < len; i++) {
 235                 if (buf[i] == '"') {
 236                         break;
 237                 }
 238         }
 239
 240         vp->vp_charseq = charseq_new(buf + 1, i - 1);
 241         pointer_mark(vp, 2);
 242
 243         return i + 1;
 244 }
 245
 246 size_t parse_forms(char const *buf, size_t len, union value_pointer *form)
 247 {
 248         size_t i, n;
 249
 250         for (i = 0; i < len; i++) {
 251                 char const c = buf[i];
 252                 union value_pointer u, v;
 253
 254                 v.vp_pair = NULL;
 255                 pointer_mark(&v, 3);
 256
 257                 switch (c) {
 258                 case '(':
 259                         v.vp_pair = pair_new();
 260                         u.vp_pair = NULL;
 261                         pointer_mark(&u, 3);
 262                         n = parse_forms(buf + i + 1, len - i - 1, &u) + 1;
 263                         i += n;
 264                         v.vp_pair->car = u;
 265                         *form = v;
 266                         pointer_mark(form, 3);
 267                         form = &v.vp_pair->cdr;
 268                         break;
 269                 case ')':
 270                 case ' ':
 271                 case '\n':
 272                 case '\t':
 273                         break;
 274                 case '"':
 275                         v.vp_pair = pair_new();
 276                         n = parse_string(&v.vp_pair->car, buf + i, len - i);
 277                         i += n - 1;
 278                         *form = v;
 279                         pointer_mark(form, 3);
 280                         form = &v.vp_pair->cdr;
 281                         break;
 282                 default:
 283                         v.vp_pair = pair_new();
 284                         n = parse_word(&v.vp_pair->car, buf + i, len - i);
 285                         i += n - 1;
 286                         *form = v;
 287                         pointer_mark(form, 3);
 288                         form = &v.vp_pair->cdr;
 289                         break;
 290                 }
 291
 292                 if (c == ')') {
 293                         break;
 294                 }
 295         }
 296
 297         return i;
 298 }
 299
 300 void pretty_print(union value_pointer v)
 301 {
 302         union value_pointer i;
 303         struct pair *p;
 304
 305         switch (pointer_type(v)) {
 306         case 0:
 307                 printf("%d", get_integer(v));
 308                 break;
 309         case 1:
 310                 printf("%s", get_charseq_chars(v));
 311                 break;
 312         case 2:
 313                 printf("\"%s\"", get_charseq_chars(v));
 314                 break;
 315         case 3:
 316                 p = get_pair(v);
 317                 if (p != NULL &&
 318                     (p->car.vp_opaque == opaque_builtin_function ||
 319                      p->car.vp_opaque == opaque_builtin_macro ||
 320                      p->car.vp_opaque == opaque_user_function ||
 321                      p->car.vp_opaque == opaque_user_macro)) {
 322                         printf("%s", p->car.vp_opaque);
 323                         break;
 324                 }
 325
 326                 printf("(");
 327                 for (i = v; pointer_type(i) == 3 && get_pair(i) != NULL; i = get_pair(i)->cdr) {
 328                         if (i.vp_pair != v.vp_pair) {
 329                                 printf(" ");
 330                         }
 331                         pretty_print(lisp_car(i));
 332                 }
 333                 if (pointer_type(i) != 3) {
 334                         printf(" . ");
 335                         pretty_print(i);
 336                 }
 337                 printf(")");
 338                 break;
 339         }
 340 }
 341
 342 union value_pointer builtin_eval(struct environment *env,
 343                                  struct pair *rest)
 344 {
 345         union value_pointer retval, function, args;
 346         union value_pointer *arglink;
 347         char const *symbol_name;
 348         struct pair *list, *closure;
 349         struct pair *subeval_arg;
 350         int i;
 351
 352         switch (pointer_type(rest->car)) {
 353         case 0:
 354         case 2:
 355                 retval = rest->car;
 356                 break;
 357         case 1:
 358                 symbol_name = get_charseq_chars(rest->car);
 359                 do {
 360                         for (i = 0; i < env->variables_used; i++) {
 361                                 if (strcmp(env->variables[i]->name->s,
 362                                            symbol_name) == 0) {
 363                                         return env->variables[i]->value;
 364                                 }
 365                         }
 366                         env = env->parent;
 367                 } while (env != NULL);
 368                 break;
 369         case 3:
 370                 list = get_pair(rest->car);
 371                 subeval_arg = pair_new();
 372                 subeval_arg->car = list->car;
 373
 374                 args.vp_pair = pair_new();
 375                 args.vp_pair->car = builtin_eval(env, subeval_arg);
 376
 377                 if (lisp_car(args.vp_pair->car).vp_opaque == opaque_builtin_function) {
 378                         arglink = &args.vp_pair->cdr;
 379
 380                         for (list = get_pair(list->cdr); list != NULL; list = get_pair(list->cdr)) {
 381                                 union value_pointer element;
 382
 383                                 subeval_arg = pair_new();
 384                                 subeval_arg->car = list->car;
 385
 386                                 element.vp_pair = pair_new();
 387                                 element.vp_pair->car = builtin_eval(env, subeval_arg);
 388                                 pair_free(subeval_arg);
 389
 390                                 *arglink = element;
 391                                 pointer_mark(arglink, 3);
 392                                 arglink = &element.vp_pair->cdr;
 393                         }
 394                 } else {
 395                         args.vp_pair->cdr = list->cdr;
 396                 }
 397
 398                 pointer_mark(&args, 3);
 399                 list = get_pair(args);
 400                 function = list->car;
 401                 args = list->cdr;
 402
 403                 closure = get_pair(function);
 404                 if (closure->car.vp_opaque == opaque_builtin_function ||
 405                     closure->car.vp_opaque == opaque_builtin_macro) {
 406                         retval = (*closure->cdr.vp_builtin)(env, get_pair(args));
 407                 } else if (closure->car.vp_opaque == opaque_user_function) {
 408                         union value_pointer formal_args, function_body;
 409                         struct pair *p, *sexpr;
 410                         struct environment *call_env;
 411
 412                         p = get_pair(closure->cdr);
 413                         formal_args = p->car;
 414                         function_body = p->cdr;
 415
 416                         call_env = environment_new(env);
 417                         for (p = get_pair(formal_args), rest = get_pair(args);
 418                              p != NULL && rest != NULL;
 419                              p = get_pair(p->cdr), rest = get_pair(rest->cdr)) {
 420                                 binding_new(call_env, get_charseq_chars(p->car), rest->car);
 421                         }
 422
 423                         for (p = get_pair(function_body); p != NULL; p = get_pair(p->cdr)) {
 424                                 sexpr = pair_new();
 425                                 sexpr->car = p->car;
 426                                 retval = builtin_eval(call_env, sexpr);
 427                         }
 428                 }
 429
 430                 break;
 431         }
 432
 433         return retval;
 434 }
 435
 436 union value_pointer builtin_car(struct environment *env,
 437                                 struct pair *rest)
 438 {
 439         union value_pointer retval;
 440
 441         retval = lisp_car(rest->car);
 442
 443         return retval;
 444 }
 445
 446 union value_pointer builtin_cdr(struct environment *env,
 447                                 struct pair *rest)
 448 {
 449         union value_pointer retval;
 450
 451         retval = get_pair(rest->car)->cdr;
 452
 453         return retval;
 454 }
 455
 456 union value_pointer builtin_cons(struct environment *env,
 457                                  struct pair *rest)
 458 {
 459         union value_pointer retval;
 460
 461         retval.vp_pair = pair_new();
 462         retval.vp_pair->car = rest->car;
 463         retval.vp_pair->cdr = lisp_car(rest->cdr);
 464         pointer_mark(&retval, 3);
 465
 466         return retval;
 467 }
 468
 469 union value_pointer builtin_eq_p(struct environment *env,
 470                                  struct pair *rest)
 471 {
 472         union value_pointer a, b;
 473
 474         a = rest->car;
 475         b = lisp_car(rest->cdr);
 476
 477         if (pointer_type(a) != pointer_type(b)) {
 478                 return constant_false;
 479         }
 480
 481         switch (pointer_type(a)) {
 482         case 0:
 483                 if (get_integer(a) != get_integer(b)) {
 484                         return constant_false;
 485                 }
 486                 break;
 487         case 1:
 488                 if (strcmp(get_charseq_chars(a), get_charseq_chars(b))) {
 489                         return constant_false;
 490                 }
 491                 break;
 492         case 2:
 493                 if (get_charseq(a) != get_charseq(b)) {
 494                         return constant_false;
 495                 }
 496                 break;
 497         case 3:
 498                 if (a.vp_pair != b.vp_pair) {
 499                         return constant_false;
 500                 }
 501                 break;
 502         }
 503
 504         return constant_true;
 505 }
 506
 507 union value_pointer builtin_if(struct environment *env,
 508                                struct pair *rest)
 509 {
 510         union value_pointer retval;
 511         union value_pointer condition, consequent, alternate;
 512         struct pair *p;
 513
 514         retval.vp_pair = NULL;
 515         pointer_mark(&retval, 3);
 516
 517         condition = rest->car;
 518         consequent = lisp_car(rest->cdr);
 519         alternate = get_pair(rest->cdr)->cdr;
 520
 521         p = pair_new();
 522         p->car = condition;
 523         condition = builtin_eval(env, p);
 524
 525         if (pointer_type(condition) != 1 ||
 526             condition.vp_charseq != constant_false.vp_charseq) {
 527                 p->car = consequent;
 528         } else if (get_pair(alternate) != NULL) {
 529                 p->car = lisp_car(alternate);
 530         } else {
 531                 pair_free(p);
 532                 return retval;
 533         }
 534
 535         retval = builtin_eval(env, p);
 536         pair_free(p);
 537
 538         return retval;
 539 }
 540
 541 union value_pointer builtin_lambda(struct environment *env,
 542                                    struct pair *rest)
 543 {
 544         union value_pointer retval;
 545
 546         retval.vp_pair = pair_new();
 547         retval.vp_pair->car.vp_opaque = opaque_user_function;
 548         retval.vp_pair->cdr.vp_pair = rest;
 549         pointer_mark(&retval.vp_pair->cdr, 3);
 550         pointer_mark(&retval, 3);
 551
 552         return retval;
 553 }
 554
 555 union value_pointer builtin_quote(struct environment *env,
 556                                   struct pair *rest)
 557 {
 558         union value_pointer retval;
 559
 560         retval = rest->car;
 561
 562         return retval;
 563 }
 564
 565 union value_pointer builtin_plus(struct environment *env,
 566                                  struct pair *rest)
 567 {
 568         union value_pointer retval;
 569         int sum;
 570
 571         for (sum = 0; rest != NULL; rest = get_pair(rest->cdr)) {
 572                 sum += get_integer(rest->car);
 573         }
 574
 575         retval.vp_int = sum << 2;
 576         pointer_mark(&retval, 0);
 577
 578         return retval;
 579 }
 580
 581 int main()
 582 {
 583         char *buf = NULL;
 584         size_t bufused = 0;
 585         size_t bufsize = 0;
 586         size_t formsize;
 587         union value_pointer form;
 588         struct pair *i;
 589         struct environment *top_env;
 590
 591         while (!feof(stdin) && !ferror(stdin)) {
 592                 size_t n;
 593
 594                 if (bufused >= bufsize) {
 595                         buf = realloc(buf, bufsize * 2 + 16);
 596                         if (buf == NULL) {
 597                                 abort();
 598                         }
 599                         bufsize = bufsize * 2 + 16;
 600                 }
 601                 n = fread(buf + bufused, 1, bufsize - bufused, stdin);
 602                 bufused += n;
 603         }
 604
 605         top_env = environment_new(NULL);
 606
 607         constant_true.vp_charseq = charseq_new("#t", 2);
 608         pointer_mark(&constant_true, 1);
 609
 610         constant_false.vp_charseq = charseq_new("#f", 2);
 611         pointer_mark(&constant_false, 1);
 612
 613         binding_new(top_env, "#t", constant_true);
 614         binding_new(top_env, "#f", constant_false);
 615
 616         binding_builtin(top_env, "car", opaque_builtin_function, builtin_car);
 617         binding_builtin(top_env, "cdr", opaque_builtin_function, builtin_cdr);
 618         binding_builtin(top_env, "cons", opaque_builtin_function, builtin_cons);
 619         binding_builtin(top_env, "eq?", opaque_builtin_function, builtin_eq_p);
 620
 621         binding_builtin(top_env, "if", opaque_builtin_macro, builtin_if);
 622         binding_builtin(top_env, "lambda", opaque_builtin_macro, builtin_lambda);
 623         binding_builtin(top_env, "quote", opaque_builtin_macro, builtin_quote);
 624
 625         binding_builtin(top_env, "+", opaque_builtin_function, builtin_plus);
 626
 627         form.vp_pair = NULL;
 628         pointer_mark(&form, 3);
 629
 630         formsize = parse_forms(buf, bufused, &form);
 631
 632         if (formsize != bufused) {
 633                 printf("this stuff left over: \"%.*s\"\n",
 634                        bufused - formsize, buf + formsize);
 635         }
 636
 637         for (i = get_pair(form); i != NULL; i = get_pair(i->cdr)) {
 638                 struct pair *rest;
 639
 640                 rest = pair_new();
 641                 rest->car = i->car;
 642
 643                 pretty_print(i->car);
 644                 printf(" -> ");
 645                 pretty_print(builtin_eval(top_env, rest));
 646                 printf("\n");
 647         }
 648
 649         return 0;
 650 }