lisp/lisp.c

   1 #include <stdio.h>
   2 #include <stdlib.h>
   3 #include <string.h>
   4
   5 struct pair;
   6
   7 struct charseq {
   8         size_t len;
   9         char *s;
  10 };
  11
  12 union value_pointer {
  13         int vp_int;
  14         struct pair *vp_pair;
  15         struct charseq *vp_charseq;
  16         union value_pointer (*vp_builtin)(union value_pointer rest);
  17 };
  18
  19 struct binding {
  20         struct charseq *name;
  21         union value_pointer type_dot_value;
  22 };
  23
  24 struct environment {
  25         struct binding **variables;
  26         int variables_used;
  27         int variables_size;
  28         struct environment *parent;
  29 };
  30
  31 struct pair {
  32         union value_pointer car;
  33         union value_pointer cdr;
  34 };
  35
  36 void pointer_mark(union value_pointer *v, int type)
  37 {
  38         int pointer_bits = v->vp_int;
  39
  40         pointer_bits &= ~3;
  41         pointer_bits |= type;
  42
  43         v->vp_int = pointer_bits;
  44 }
  45
  46 int pointer_type(union value_pointer v)
  47 {
  48         return (v.vp_int & 3);
  49 }
  50
  51 int get_integer(union value_pointer v)
  52 {
  53         return (v.vp_int >> 2);
  54 }
  55
  56 struct pair *get_pair(union value_pointer v)
  57 {
  58         v.vp_int &= ~3;
  59         return v.vp_pair;
  60 }
  61
  62 struct charseq *get_charseq(union value_pointer v)
  63 {
  64         v.vp_int &= ~3;
  65         return v.vp_charseq;
  66 }
  67
  68 size_t get_charseq_length(union value_pointer v)
  69 {
  70         struct charseq *cs;
  71
  72         cs = get_charseq(v);
  73
  74         return cs->len;
  75 }
  76
  77 char *get_charseq_chars(union value_pointer v)
  78 {
  79         struct charseq *cs;
  80
  81         cs = get_charseq(v);
  82
  83         return cs->s;
  84 }
  85
  86 struct charseq *charseq_new(void)
  87 {
  88         return malloc(sizeof (struct charseq));
  89 }
  90
  91 struct pair *pair_new(void)
  92 {
  93         return malloc(sizeof (struct pair));
  94 }
  95
  96 struct binding *binding_new(char const *name,
  97                             union value_pointer type_dot_value)
  98 {
  99         struct binding *b;
 100
 101         b = malloc(sizeof (*b));
 102
 103         b->name = charseq_new();
 104         b->name->len = strlen(name);
 105         b->name->s = strdup(name);
 106
 107         b->type_dot_value = type_dot_value;
 108
 109         return b;
 110 }
 111
 112 void binding_builtin(struct environment *env,
 113                      char const *name,
 114                      union value_pointer (*builtin)(union value_pointer rest))
 115 {
 116         union value_pointer v;
 117         struct pair *type_dot_value;
 118
 119         if (env->variables_used >= env->variables_size) {
 120                 int newsize = env->variables_used * 2 + 16;
 121
 122                 env->variables = realloc(env->variables,
 123                                          sizeof (*env->variables) * newsize);
 124                 env->variables_size = newsize;
 125         }
 126
 127         type_dot_value = pair_new();
 128         type_dot_value->car.vp_int = 1 << 2;
 129         pointer_mark(&type_dot_value->car, 0);
 130         type_dot_value->cdr.vp_builtin = builtin;
 131         v.vp_pair = type_dot_value;
 132         pointer_mark(&v, 3);
 133
 134         env->variables[env->variables_used++] = binding_new(name, v);
 135 }
 136
 137 size_t parse_word(union value_pointer *vp, char const *buf, size_t len)
 138 {
 139         size_t i;
 140         int n;
 141
 142         for (n = 0, i = 0; i < len; i++) {
 143                 if (buf[i] < '0' || buf[i] > '9') {
 144                         break;
 145                 }
 146                 n = n*10 + buf[i] - '0';
 147         }
 148
 149         if (i < len) {
 150                 char *symbol;
 151
 152                 switch (buf[i]) {
 153                 case ')':
 154                 case ' ':
 155                 case '\n':
 156                 case '\t':
 157                         break;
 158                 default:
 159                         for (i++; i < len; i++) {
 160                                 switch (buf[i]) {
 161                                 case ')':
 162                                 case ' ':
 163                                 case '\n':
 164                                 case '\t':
 165                                         len = i + 1;
 166                                         break;
 167                                 }
 168                         }
 169                         vp->vp_charseq = charseq_new();
 170                         vp->vp_charseq->len = i;
 171                         vp->vp_charseq->s = malloc(i + 1);
 172                         memcpy(vp->vp_charseq->s, buf, i);
 173                         vp->vp_charseq->s[i] = 0;
 174                         pointer_mark(vp, 1);
 175                         return i;
 176                 }
 177         }
 178         vp->vp_int = n << 2;
 179         pointer_mark(vp, 0);
 180         return i;
 181 }
 182
 183 size_t parse_string(union value_pointer *vp, char const *buf, size_t len)
 184 {
 185         size_t i;
 186
 187         for (i = 1; i < len; i++) {
 188                 if (buf[i] == '"') {
 189                         break;
 190                 }
 191         }
 192
 193         vp->vp_charseq = charseq_new();
 194         vp->vp_charseq->len = i - 1;
 195         vp->vp_charseq->s = malloc(i);
 196         memcpy(vp->vp_charseq->s, buf + 1, i - 1);
 197         vp->vp_charseq->s[i-1] = 0;
 198         pointer_mark(vp, 2);
 199
 200         return i + 1;
 201 }
 202
 203 size_t parse_form(char const *buf, size_t len, union value_pointer *form)
 204 {
 205         size_t i, n;
 206         int word_start = -1;
 207
 208         for (i = 0; i < len; i++) {
 209                 char const c = buf[i];
 210                 union value_pointer u, v;
 211
 212                 switch (c) {
 213                 case '(':
 214                         v.vp_pair = pair_new();
 215                         v.vp_pair->car.vp_pair = NULL;
 216                         pointer_mark(&v.vp_pair->car, 3);
 217                         i += parse_form(buf + i + 1, len - i - 1, &v.vp_pair->car) + 1;
 218                         v.vp_pair->cdr.vp_pair = NULL;
 219                         pointer_mark(&v.vp_pair->cdr, 3);
 220                         *form = v;
 221                         pointer_mark(form, 3);
 222                         form = &v.vp_pair->cdr;
 223                         break;
 224                 case ')':
 225                 case ' ':
 226                 case '\n':
 227                 case '\t':
 228                         if (word_start != -1) {
 229                                 v.vp_pair = pair_new();
 230                                 parse_word(&v.vp_pair->car, buf + word_start, i - word_start);
 231                                 v.vp_pair->cdr.vp_pair = NULL;
 232                                 pointer_mark(&v.vp_pair->cdr, 3);
 233                                 *form = v;
 234                                 pointer_mark(form, 3);
 235                                 form = &v.vp_pair->cdr;
 236                         }
 237                         word_start = -1;
 238                         break;
 239                 case '"':
 240                         v.vp_pair = pair_new();
 241                         n = parse_string(&v.vp_pair->car, buf + i, len - i);
 242                         i += n;
 243                         v.vp_pair->cdr.vp_pair = NULL;
 244                         pointer_mark(&v.vp_pair->cdr, 3);
 245                         *form = v;
 246                         pointer_mark(form, 3);
 247                         form = &v.vp_pair->cdr;
 248                         break;
 249                 default:
 250                         if (word_start == -1) {
 251                                 word_start = i;
 252                         }
 253                         break;
 254                 }
 255
 256                 if (c == ')') {
 257                         break;
 258                 }
 259         }
 260
 261         return i;
 262 }
 263
 264 void pretty_print(union value_pointer v)
 265 {
 266         union value_pointer i;
 267
 268         switch (pointer_type(v)) {
 269         case 0:
 270                 printf("%d", get_integer(v));
 271                 break;
 272         case 1:
 273                 printf("%s", get_charseq_chars(v));
 274                 break;
 275         case 2:
 276                 printf("\"%s\"", get_charseq_chars(v));
 277                 break;
 278         case 3:
 279                 printf("(");
 280                 for (i = v; i.vp_int != 3; i = get_pair(i)->cdr) {
 281                         if (i.vp_pair != v.vp_pair) {
 282                                 printf(" ");
 283                         }
 284                         pretty_print(get_pair(i)->car);
 285                 }
 286                 printf(")");
 287                 break;
 288         }
 289 }
 290
 291 union value_pointer eval(struct environment *env, union value_pointer v)
 292 {
 293         union value_pointer retval, function, rest;
 294         union value_pointer *args;
 295         char const *symbol_name;
 296         struct pair *list, *closure;
 297         int i;
 298
 299         switch (pointer_type(v)) {
 300         case 0:
 301         case 2:
 302                 retval = v;
 303                 break;
 304         case 1:
 305                 symbol_name = get_charseq_chars(v);
 306                 do {
 307                         for (i = 0; i < env->variables_used; i++) {
 308                                 if (strcmp(env->variables[i]->name->s,
 309                                            symbol_name) == 0) {
 310                                         return env->variables[i]->type_dot_value;
 311                                 }
 312                         }
 313                         env = env->parent;
 314                 } while (env != NULL);
 315                 break;
 316         case 3:
 317                 rest.vp_pair = NULL;
 318                 pointer_mark(&rest, 3);
 319                 args = &rest;
 320                 for (list = get_pair(v); list != NULL; list = get_pair(list->cdr)) {
 321                         union value_pointer element;
 322
 323                         element.vp_pair = pair_new();
 324                         element.vp_pair->car = eval(env, list->car);
 325                         element.vp_pair->cdr.vp_pair = NULL;
 326                         pointer_mark(&element.vp_pair->cdr, 3);
 327
 328                         *args = element;
 329                         pointer_mark(args, 3);
 330                         args = &element.vp_pair->cdr;
 331                 }
 332
 333                 list = get_pair(rest);
 334                 function = list->car;
 335                 rest = list->cdr;
 336
 337                 closure = get_pair(function);
 338                 switch (get_integer(closure->car)) {
 339                 case 1:
 340                         retval = (*closure->cdr.vp_builtin)(rest);
 341                         break;
 342                 }
 343
 344                 break;
 345         }
 346
 347         return retval;
 348 }
 349
 350 union value_pointer builtin_plus(union value_pointer rest)
 351 {
 352         struct pair *i;
 353         union value_pointer retval;
 354         int sum;
 355
 356         for (sum = 0, i = get_pair(rest); i != NULL; i = get_pair(i->cdr)) {
 357                 sum += get_integer(i->car);
 358         }
 359
 360         retval.vp_int = sum << 2;
 361         pointer_mark(&retval, 0);
 362
 363         return retval;
 364 }
 365
 366 int main()
 367 {
 368         char *buf = NULL;
 369         size_t bufused = 0;
 370         size_t bufsize = 0;
 371         size_t formsize;
 372         union value_pointer form;
 373         struct pair *i;
 374         struct environment top_env;
 375
 376         while (!feof(stdin) && !ferror(stdin)) {
 377                 size_t n;
 378
 379                 if (bufused >= bufsize) {
 380                         buf = realloc(buf, bufsize * 2 + 16);
 381                         if (buf == NULL) {
 382                                 abort();
 383                         }
 384                         bufsize = bufsize * 2 + 16;
 385                 }
 386                 n = fread(buf + bufused, 1, bufsize - bufused, stdin);
 387                 bufused += n;
 388         }
 389
 390         top_env.variables = NULL;
 391         top_env.variables_used = 0;
 392         top_env.variables_size = 0;
 393         top_env.parent = NULL;
 394
 395         binding_builtin(&top_env, "+", builtin_plus);
 396         form.vp_pair = pair_new();
 397         pointer_mark(&form, 3);
 398
 399         formsize = parse_form(buf, bufused, &form);
 400
 401         if (formsize != bufused) {
 402                 printf("this stuff left over: \"%.*s\"\n",
 403                        bufused - formsize, buf + formsize);
 404         }
 405
 406         for (i = get_pair(form); i != NULL; i = get_pair(i->cdr)) {
 407                 pretty_print(i->car);
 408                 printf(" -> ");
 409                 pretty_print(eval(&top_env, i->car));
 410                 printf("\n");
 411         }
 412
 413         return 0;
 414 }