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