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