mes.c

   1 /*
   2  * Mes --- Maxwell Equations of Software
   3  * Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
   4  *
   5  * This file is part of Mes.
   6  *
   7  * Mes is free software; you can redistribute it and/or modify it
   8  * under the terms of the GNU General Public License as published by
   9  * the Free Software Foundation; either version 3 of the License, or (at
  10  * your option) any later version.
  11  *
  12  * Mes is distributed in the hope that it will be useful, but
  13  * WITHOUT ANY WARRANTY; without even the implied warranty of
  14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15  * GNU General Public License for more details.
  16  *
  17  * You should have received a copy of the GNU General Public License
  18  * along with Mes.  If not, see <http://www.gnu.org/licenses/>.
  19  */
  20
  21 // (setq comment-start "//")
  22 // (setq comment-end "")
  23 /*
  24  * The Maxwell Equations of Software -- John McCarthy page 13
  25  * http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
  26  */
  27
  28 #define _GNU_SOURCE
  29 #include <assert.h>
  30 #include <ctype.h>
  31 #include <stdio.h>
  32 #include <string.h>
  33 #include <stdlib.h>
  34 #include <stdbool.h>
  35
  36 #define DEBUG 0
  37
  38 #define MACROS 1
  39 #define QUASIQUOTE 1
  40
  41 #ifndef QUOTE_SUGAR
  42 #define QUOTE_SUGAR 1
  43 #endif
  44
  45 enum type {CHAR, NUMBER, PAIR, STRING, SYMBOL, VALUES, VECTOR,
  46            FUNCTION0, FUNCTION1, FUNCTION2, FUNCTION3, FUNCTIONn};
  47 struct scm_t;
  48 typedef struct scm_t* (*function0_t) (void);
  49 typedef struct scm_t* (*function1_t) (struct scm_t*);
  50 typedef struct scm_t* (*function2_t) (struct scm_t*, struct scm_t*);
  51 typedef struct scm_t* (*function3_t) (struct scm_t*, struct scm_t*, struct scm_t*);
  52 typedef struct scm_t* (*functionn_t) (struct scm_t*);
  53
  54 typedef struct scm_t {
  55   enum type type;
  56   union {
  57     char *name;
  58     struct scm_t* car;
  59     int length;
  60   };
  61   union {
  62     int value;
  63     function0_t function0;
  64     function1_t function1;
  65     function2_t function2;
  66     function3_t function3;
  67     functionn_t functionn;
  68     struct scm_t* cdr;
  69     struct scm_t** vector;
  70   };
  71 } scm;
  72
  73 #define MES 1
  74 #include "mes.h"
  75
  76 scm *display_helper (scm*, bool, char*, bool);
  77 bool
  78 symbol_eq (scm *x, char *s)
  79 {
  80   return x->type == SYMBOL && !strcmp (x->name, s);
  81 }
  82
  83 scm scm_nil = {SYMBOL, "()"};
  84 scm scm_dot = {SYMBOL, "."};
  85 scm scm_t = {SYMBOL, "#t"};
  86 scm scm_f = {SYMBOL, "#f"};
  87 scm scm_lambda = {SYMBOL, "lambda"};
  88 scm scm_label = {SYMBOL, "label"};
  89 scm scm_unspecified = {SYMBOL, "*unspecified*"};
  90 scm scm_symbol_cond = {SYMBOL, "cond"};
  91 scm scm_symbol_quote = {SYMBOL, "quote"};
  92 #if QUASIQUOTE
  93 scm scm_symbol_quasiquote = {SYMBOL, "quasiquote"};
  94 scm scm_symbol_unquote = {SYMBOL, "unquote"};
  95 #endif
  96 #if MACROS
  97 scm scm_macro = {SYMBOL, "*macro*"};
  98 #endif
  99
 100 scm scm_symbol_EOF = {SYMBOL, "EOF"};
 101 scm scm_symbol_EOF2 = {SYMBOL, "EOF2"};
 102 scm scm_symbol_call_with_values = {SYMBOL, "call-with-values"};
 103 scm scm_symbol_current_module = {SYMBOL, "current-module"};
 104 scm scm_symbol_define = {SYMBOL, "define"};
 105 scm scm_symbol_define_macro = {SYMBOL, "define-macro"};
 106 scm scm_symbol_eval = {SYMBOL, "eval"};
 107 scm scm_symbol_loop2 = {SYMBOL, "loop2"};
 108 scm scm_symbol_set_x = {SYMBOL, "set!"};
 109 scm scm_symbol_values = {SYMBOL, "values"};
 110
 111 // PRIMITIVES
 112
 113 scm *
 114 atom_p (scm *x)
 115 {
 116   return x->type == PAIR ? &scm_f : &scm_t;
 117 }
 118
 119 scm *
 120 car (scm *x)
 121 {
 122   assert (x->type == PAIR);
 123   return x->car;
 124 }
 125
 126 scm *
 127 cdr (scm *x)
 128 {
 129   assert (x->type == PAIR);
 130   return x->cdr;
 131 }
 132
 133 scm *
 134 cons (scm *x, scm *y)
 135 {
 136   scm *p = malloc (sizeof (scm));
 137   p->type = PAIR;
 138   p->car = x;
 139   p->cdr = y;
 140   return p;
 141 }
 142
 143 scm *
 144 eq_p (scm *x, scm *y)
 145 {
 146   return (x == y
 147           || (x->type == CHAR && y->type == CHAR
 148               && x->value == y->value)
 149           || (x->type == NUMBER && y->type == NUMBER
 150               && x->value == y->value)
 151           // FIXME: alist lookup symbols
 152           || (atom_p (x) == &scm_t
 153               && x->type != CHAR
 154               && y->type != CHAR
 155               && x->type != NUMBER
 156               && y->type != NUMBER
 157               && x->type != VECTOR
 158               && y->type != VECTOR
 159               && atom_p (y) == &scm_t
 160               && !strcmp (x->name, y->name)))
 161     ? &scm_t : &scm_f;
 162 }
 163
 164 scm *
 165 null_p (scm *x)
 166 {
 167   return eq_p (x, &scm_nil);
 168 }
 169
 170 scm *
 171 pair_p (scm *x)
 172 {
 173   return x->type == PAIR ? &scm_t : &scm_f;
 174 }
 175
 176 scm *
 177 set_cdr_x (scm *x, scm *e)
 178 {
 179   assert (x->type == PAIR);
 180   x->cdr = e;
 181   return &scm_unspecified;
 182 }
 183
 184 scm *
 185 set_x (scm *x, scm *e, scm *a)
 186 {
 187   return set_cdr_x (assq (x, a), e);
 188 }
 189
 190 scm *
 191 set_env_x (scm *x, scm *e, scm *a)
 192 {
 193   return set_cdr_x (assq (x, a), e);
 194 }
 195
 196 scm *
 197 quote (scm *x)
 198 {
 199   return cons (&scm_symbol_quote, x);
 200 }
 201
 202 #if QUASIQUOTE
 203 scm *
 204 unquote (scm *x)
 205 {
 206   return cons (&scm_symbol_unquote, x);
 207 }
 208
 209 scm *
 210 quasiquote (scm *x)
 211 {
 212   return cons (&scm_symbol_quasiquote, x);
 213 }
 214 #endif
 215
 216 //Library functions
 217
 218 // Derived, non-primitives
 219 scm *caar (scm *x) {return car (car (x));}
 220 scm *cadr (scm *x) {return car (cdr (x));}
 221 scm *cdar (scm *x) {return cdr (car (x));}
 222 scm *cddr (scm *x) {return cdr (cdr (x));}
 223 scm *caadr (scm *x) {return car (car (cdr (x)));}
 224 scm *caddr (scm *x) {return car (cdr (cdr (x)));}
 225 scm *cdadr (scm *x) {return cdr (car (cdr (x)));}
 226 scm *cadar (scm *x) {return car (cdr (car (x)));}
 227 scm *cddar (scm *x) {return cdr (cdr (car (x)));}
 228 scm *cdddr (scm *x) {return cdr (cdr (cdr (x)));}
 229
 230 scm *
 231 pairlis (scm *x, scm *y, scm *a)
 232 {
 233 #if DEBUG
 234   printf ("pairlis x=");
 235   display (x);
 236   printf (" y=");
 237   display (y);
 238   puts ("");
 239 #endif
 240   if (x == &scm_nil)
 241     return a;
 242   if (atom_p (x) == &scm_t)
 243     return cons (cons (x, y), a);
 244   return cons (cons (car (x), car (y)),
 245                pairlis (cdr (x), cdr (y), a));
 246 }
 247
 248 scm *
 249 assq (scm *x, scm *a)
 250 {
 251   if (a == &scm_nil) {
 252 #if DEBUG
 253     printf ("alist miss: %s\n", x->name);
 254 #endif
 255     return &scm_f;
 256   }
 257   if (eq_p (caar (a), x) == &scm_t)
 258     return car (a);
 259   return assq (x, cdr (a));
 260 }
 261
 262 scm *
 263 apply_env_ (scm *fn, scm *x, scm *a)
 264 {
 265 #if DEBUG
 266   printf ("apply_env fn=");
 267   display (fn);
 268   printf (" x=");
 269   display (x);
 270   puts ("");
 271 #endif
 272   if (atom_p (fn) != &scm_f)
 273     {
 274       if (fn == &scm_symbol_current_module) // FIXME
 275         return a;
 276       if (eq_p (fn, &scm_symbol_call_with_values) == &scm_t)
 277         return call (&scm_call_with_values_env, append2 (x, cons (a, &scm_nil)));
 278       if (builtin_p (fn) == &scm_t)
 279         return call (fn, x);
 280       return apply_env (eval (fn,  a), x, a);
 281     }
 282   else if (car (fn) == &scm_lambda)
 283     return begin_env (cddr (fn), pairlis (cadr (fn), x, a));
 284   else if (car (fn) == &scm_label)
 285     return apply_env (caddr (fn), x, cons (cons (cadr (fn), caddr (fn)), a));
 286   return &scm_unspecified;
 287 }
 288
 289 scm *
 290 begin_env (scm *body, scm *a)
 291 {
 292   if (body == &scm_nil) return &scm_unspecified;
 293   scm *result = eval (car (body), a);
 294   if (cdr (body) == &scm_nil)
 295     return result;
 296   return begin_env (cdr (body), a);
 297 }
 298
 299 scm *
 300 eval_ (scm *e, scm *a)
 301 {
 302 #if DEBUG
 303   printf ("eval e=");
 304   display (e);
 305   puts ("");
 306 #endif
 307   if (e->type == CHAR)
 308     return e;
 309   else if (e->type == NUMBER)
 310     return e;
 311   else if (e->type == STRING)
 312     return e;
 313   else if (e->type == VECTOR)
 314     return e;
 315   else if (atom_p (e) == &scm_t) {
 316     scm *y = assq (e, a);
 317     if (y == &scm_f) {
 318       printf ("eval: no such symbol: %s\n", e->name);
 319       exit (1);
 320     }
 321     return cdr (y);
 322   }
 323   if (builtin_p (e) == &scm_t)
 324     return e;
 325   else if (atom_p (car (e)) == &scm_t)
 326     {
 327 #if MACROS
 328       scm *macro;
 329 #endif // MACROS
 330       if (car (e) == &scm_symbol_quote)
 331         return cadr (e);
 332       if (car (e) == &scm_lambda)
 333         return e;
 334       if (car (e) == &scm_symbol_set_x)
 335         return set_env_x (cadr (e), eval (caddr (e), a), a);
 336 #if QUASIQUOTE
 337       else if (car (e) == &scm_symbol_unquote)
 338         return eval (cadr (e), a);
 339       else if (car (e) == &scm_symbol_quasiquote) {
 340 #if DEBUG
 341         printf ("cadr e:");
 342         display (cadr (e));
 343         puts ("");
 344         printf ("qq:");
 345         display (eval_quasiquote (cadr (e), a));
 346         puts ("");
 347 #endif // DEBUG
 348         return eval_quasiquote (cadr (e), a);
 349       }
 350 #endif // QUASIQUOTE
 351       else if (car (e) == &scm_symbol_cond)
 352         return evcon (cdr (e), a);
 353 #if MACROS
 354       else if ((macro = assq (car (e), cdr (assq (&scm_macro, a)))) != &scm_f)
 355         return eval (apply_env_ (cdr (macro), cdr (e), a), a);
 356 #endif // MACROS
 357       return apply_env (car (e), evlis (cdr (e), a), a);
 358     }
 359   return apply_env (car (e), evlis (cdr (e), a), a);
 360 }
 361
 362 scm *
 363 evcon_ (scm *c, scm *a)
 364 {
 365 #if DEBUG
 366   printf ("evcon_ clause=");
 367   display (car (c));
 368   puts ("");
 369 #endif
 370   if (c == &scm_nil) return &scm_unspecified;
 371   if (eval (caar (c), a) != &scm_f) {
 372 #if DEBUG
 373     //if (fn != &scm_display && fn != &scm_call)
 374     //if (fn != &scm_call)
 375     printf ("#t clause=");
 376     display (car (c));
 377     printf (" cddar=");
 378     display (cddar (c));
 379     printf (" nil=%d", cddar (c) == &scm_nil);
 380     puts ("");
 381 #endif
 382     if (cddar (c) == &scm_nil)
 383       return eval (cadar (c), a);
 384     eval (cadar (c), a);
 385     return evcon_ (cons (cons (&scm_t, cddar (c)), &scm_nil), a);
 386   }
 387   return evcon_ (cdr (c), a);
 388 }
 389
 390 scm *
 391 evcon (scm *c, scm *a)
 392 {
 393 #if DEBUG
 394   printf ("\n****evcon=");
 395   display (c);
 396   puts ("");
 397 #endif
 398   return evcon_ (c, a);
 399 }
 400
 401 scm *
 402 evlis (scm *m, scm *a)
 403 {
 404 #if DEBUG
 405   printf ("evlis m=");
 406   display (m);
 407   puts ("");
 408 #endif
 409   if (m == &scm_nil)
 410     return &scm_nil;
 411   scm *e = eval (car (m), a);
 412   return cons (e, evlis (cdr (m), a));
 413 }
 414
 415 //Helpers
 416
 417 scm *
 418 builtin_p (scm *x)
 419 {
 420   return (x->type == FUNCTION0
 421           || x->type == FUNCTION1
 422           || x->type == FUNCTION2
 423           || x->type == FUNCTION3
 424           || x->type == FUNCTIONn)
 425     ? &scm_t : &scm_f;
 426 }
 427
 428 scm *
 429 char_p (scm *x)
 430 {
 431   return x->type == CHAR ? &scm_t : &scm_f;
 432 }
 433
 434 scm *
 435 number_p (scm *x)
 436 {
 437   return x->type == NUMBER ? &scm_t : &scm_f;
 438 }
 439
 440 scm *
 441 string_p (scm *x)
 442 {
 443   return x->type == STRING ? &scm_t : &scm_f;
 444 }
 445
 446 scm *
 447 symbol_p (scm *x)
 448 {
 449   //TODO: #f,#t,nil also `symbols' atm
 450   return x->type == SYMBOL ? &scm_t : &scm_f;
 451 }
 452
 453 scm *
 454 vector_p (scm *x)
 455 {
 456   return x->type == VECTOR ? &scm_t : &scm_f;
 457 }
 458
 459 scm *
 460 display (scm *x)
 461 {
 462   return display_helper (x, false, "", false);
 463 }
 464
 465 scm *
 466 call (scm *fn, scm *x)
 467 {
 468 #if DEBUG
 469   //if (fn != &scm_display && fn != &scm_call)
 470   //if (fn != &scm_call)
 471   {
 472     printf ("\ncall fn=");
 473     display (fn);
 474     printf (" x=");
 475     display (x);
 476     puts ("");
 477   }
 478 #endif
 479   if (fn->type == FUNCTION0)
 480     return fn->function0 ();
 481   if (x->car->type == VALUES)
 482     x = cons (x->car->cdr->car, &scm_nil);
 483   if (fn->type == FUNCTION1)
 484     return fn->function1 (car (x));
 485   if (fn->type == FUNCTION2)
 486     return fn->function2 (car (x), cadr (x));
 487   if (fn->type == FUNCTION3)
 488     return fn->function3 (car (x), cadr (x), caddr (x));
 489   if (fn->type == FUNCTIONn)
 490     return fn->functionn (x);
 491   return &scm_unspecified;
 492 }
 493
 494 scm *
 495 append2 (scm *x, scm *y)
 496 {
 497   if (x == &scm_nil) return y;
 498   assert (x->type == PAIR);
 499   return cons (car (x), append2 (cdr (x), y));
 500 }
 501
 502 scm *
 503 append (scm *x/*...*/)
 504  {
 505   if (x == &scm_nil) return &scm_nil;
 506   return append2 (car (x), append (cdr (x)));
 507  }
 508
 509 scm *
 510 make_char (int x)
 511 {
 512   scm *p = malloc (sizeof (scm));
 513   p->type = CHAR;
 514   p->value = x;
 515   return p;
 516 }
 517
 518 scm *
 519 make_number (int x)
 520 {
 521   scm *p = malloc (sizeof (scm));
 522   p->type = NUMBER;
 523   p->value = x;
 524   return p;
 525 }
 526
 527 scm *
 528 make_string (char const *s)
 529 {
 530   scm *p = malloc (sizeof (scm));
 531   p->type = STRING;
 532   p->name = strdup (s);
 533   return p;
 534 }
 535
 536 scm *
 537 make_symbol (char const *s)
 538 {
 539   // TODO: alist lookup symbols
 540   scm *p = malloc (sizeof (scm));
 541   p->type = SYMBOL;
 542   p->name = strdup (s);
 543   return p;
 544 }
 545
 546 scm *
 547 make_vector (int n)
 548 {
 549   scm *p = malloc (sizeof (scm));
 550   p->type = VECTOR;
 551   p->length = n;
 552   p->vector = malloc (n * sizeof (scm*));
 553   return p;
 554 }
 555
 556 scm *
 557 string (scm *x/*...*/)
 558 {
 559   char buf[256] = "";
 560   char *p = buf;
 561   while (x != &scm_nil)
 562     {
 563       scm *s = car (x);
 564       assert (s->type == CHAR);
 565       *p++ = s->value;
 566       x = cdr (x);
 567     }
 568   return make_string (buf);
 569 }
 570
 571 scm *
 572 string_append (scm *x/*...*/)
 573 {
 574   char buf[256] = "";
 575
 576   while (x != &scm_nil)
 577     {
 578       scm *s = car (x);
 579       assert (s->type == STRING);
 580       strcat (buf, s->name);
 581       x = cdr (x);
 582     }
 583   return make_string (buf);
 584 }
 585
 586 scm *
 587 string_length (scm *x)
 588 {
 589   assert (x->type == STRING);
 590   return make_number (strlen (x->name));
 591 }
 592
 593 scm *
 594 length (scm *x)
 595 {
 596   int n = 0;
 597   while (x != &scm_nil)
 598     {
 599       n++;
 600       x = cdr (x);
 601     }
 602   return make_number (n);
 603 }
 604
 605 #if 0
 606 scm *
 607 builtin_list (scm *x/*...*/) // int
 608 {
 609   return x;
 610 }
 611
 612 scm *
 613 vector (scm *x/*...*/) // int
 614 {
 615   return list_to_vector (x);
 616 }
 617 #endif
 618
 619 scm *
 620 values (scm *x/*...*/)
 621 {
 622   scm *v = cons (0, x);
 623   v->type = VALUES;
 624   return v;
 625 }
 626
 627 scm *
 628 call_with_values_env (scm *producer, scm *consumer, scm *a)
 629 {
 630   scm *v = apply_env_ (producer, &scm_nil, a);
 631   if (v->type == VALUES)
 632     v = v->cdr;
 633   return apply_env_ (consumer, v, a);
 634 }
 635
 636 scm *
 637 vector_length (scm *x)
 638 {
 639   assert (x->type == VECTOR);
 640   return make_number (x->length);
 641 }
 642
 643 scm *
 644 vector_ref (scm *x, scm *i)
 645 {
 646   assert (x->type == VECTOR);
 647   assert (i->value < x->length);
 648   return x->vector[i->value];
 649 }
 650
 651 scm *
 652 vector_set_x (scm *x, scm *i, scm *e)
 653 {
 654   assert (x->type == VECTOR);
 655   assert (i->value < x->length);
 656   x->vector[i->value] = e;
 657   return &scm_unspecified;
 658 }
 659
 660 scm *
 661 lookup (char *x, scm *a)
 662 {
 663   if (isdigit (*x) || (*x == '-' && isdigit (*(x+1))))
 664     return make_number (atoi (x));
 665   if (*x == '\'') return &scm_symbol_quote;
 666
 667   if (!strcmp (x, scm_unspecified.name)) return &scm_unspecified;
 668   if (!strcmp (x, scm_symbol_cond.name)) return &scm_symbol_cond;
 669   if (!strcmp (x, scm_symbol_quote.name)) return &scm_symbol_quote;
 670   if (!strcmp (x, scm_lambda.name)) return &scm_lambda;
 671   if (!strcmp (x, scm_label.name)) return &scm_label;
 672   if (!strcmp (x, scm_nil.name)) return &scm_nil;
 673   if (!strcmp (x, scm_symbol_set_x.name)) return &scm_symbol_set_x;
 674
 675 #if QUASIQUOTE
 676   if (*x == '`') return &scm_symbol_quasiquote;
 677   if (*x == ',') return &scm_symbol_unquote;
 678   if (!strcmp (x, scm_symbol_unquote.name)) return &scm_symbol_unquote;
 679   if (!strcmp (x, scm_symbol_quasiquote.name)) return &scm_symbol_quasiquote;
 680 #endif
 681
 682   return make_symbol (x);
 683 }
 684
 685 scm *
 686 lookup_char (int c, scm *a)
 687 {
 688   char buf[2];
 689   buf[0] = c;
 690   buf[1] = 0;
 691   return lookup (buf, a);
 692 }
 693
 694 char *
 695 list2str (scm *l) // char*
 696 {
 697   static char buf[256];
 698   char *p = buf;
 699   while (l != &scm_nil) {
 700     scm *c = car (l);
 701     assert (c->type == NUMBER);
 702     *p++ = c->value;
 703     l = cdr (l);
 704   }
 705   *p = 0;
 706   return buf;
 707 }
 708
 709 scm*
 710 list_to_vector (scm *x)
 711 {
 712   int n = length (x)->value;
 713   scm *v = make_vector (n);
 714   scm **p = v->vector;
 715   while (x != &scm_nil)
 716     {
 717       *p++ = car (x);
 718       x = cdr (x);
 719     }
 720   return v;
 721 }
 722
 723 scm*
 724 number_to_string (scm *x)
 725 {
 726   assert (x->type == NUMBER);
 727   char buf[256];
 728   sprintf (buf,"%d", x->value);
 729   return make_string (buf);
 730 }
 731
 732 scm*
 733 string_to_symbol (scm *x)
 734 {
 735   assert (x->type == STRING);
 736   return make_symbol (x->name);
 737 }
 738
 739 scm*
 740 symbol_to_string (scm *x)
 741 {
 742   assert (x->type == SYMBOL);
 743   return make_string (x->name);
 744 }
 745
 746 scm*
 747 vector_to_list (scm *v)
 748 {
 749   scm *x = &scm_nil;
 750   for (int i = 0; i < v->length; i++)
 751     x = append2 (x, cons (v->vector[i], &scm_nil));
 752   return x;
 753 }
 754
 755 scm *
 756 builtin_lookup (scm *l, scm *a)
 757 {
 758   return lookup (list2str (l), a);
 759 }
 760
 761 scm *
 762 cossa (scm *x, scm *a)
 763 {
 764   if (a == &scm_nil) return &scm_f;
 765   if (eq_p (cdar (a), x) == &scm_t)
 766     return car (a);
 767   return cossa (x, cdr (a));
 768 }
 769
 770 scm *
 771 newline ()
 772 {
 773   puts ("");
 774   return &scm_unspecified;
 775 }
 776
 777 scm *
 778 display_helper (scm *x, bool cont, char *sep, bool quote)
 779 {
 780   scm *r;
 781   printf ("%s", sep);
 782   if (x->type == CHAR && x->value == 10) printf ("#\\%s", "newline");
 783   else if (x->type == CHAR && x->value == 32) printf ("#\\%s", "space");
 784   else if (x->type == CHAR) printf ("#\\%c", x->value);
 785   else if (x->type == NUMBER) printf ("%d", x->value);
 786   else if (x->type == PAIR) {
 787 #if QUOTE_SUGAR
 788     if (car (x) == &scm_quote) {
 789       printf ("'");
 790       return display_helper (car (cdr (x)), cont, "", true);
 791     }
 792 #if QUASIQUOTE
 793     if (car (x) == &scm_quasiquote) {
 794       printf ("`");
 795       return display_helper (car (cdr (x)), cont, "", true);
 796     }
 797     if (car (x) == &scm_unquote) {
 798       printf (",");
 799       return display_helper (car (cdr (x)), cont, "", true);
 800     }
 801 #endif
 802 #endif
 803     if (!cont) printf ("(");
 804     display (car (x));
 805     if (cdr (x)->type == PAIR)
 806       display_helper (cdr (x), true, " ", false);
 807     else if (cdr (x) != &scm_nil) {
 808       printf (" . ");
 809       display (cdr (x));
 810     }
 811     if (!cont) printf (")");
 812   }
 813   else if (x->type == VECTOR) {
 814     printf ("#(");
 815     for (int i = 0; i < x->length; i++)
 816       display_helper (x->vector[i], true, i ? " " : "", false);
 817     printf (")");
 818   }
 819   else if (atom_p (x) == &scm_t) printf ("%s", x->name);
 820
 821   return &scm_unspecified;
 822 }
 823
 824 // READ
 825
 826 int
 827 ungetchar (int c) //int
 828 {
 829   return ungetc (c, stdin);
 830 }
 831
 832 int
 833 peekchar () //int
 834 {
 835   int c = getchar ();
 836   ungetchar (c);
 837   return c;
 838 }
 839
 840 scm*
 841 builtin_getchar ()
 842 {
 843   return make_number (getchar ());
 844 }
 845
 846 scm*
 847 builtin_peekchar ()
 848 {
 849   return make_number (peekchar ());
 850 }
 851
 852 scm*
 853 builtin_ungetchar (scm *c)
 854 {
 855   assert (c->type == NUMBER);
 856   ungetchar (c->value);
 857   return c;
 858 }
 859
 860 int
 861 readcomment (int c)
 862 {
 863   if (c == '\n') return c;
 864   return readcomment (getchar ());
 865 }
 866
 867 int
 868 readblock (int c)
 869 {
 870   if (c == '!' && peekchar () == '#') return getchar ();
 871   return readblock (getchar ());
 872 }
 873
 874 scm *
 875 readword (int c, char* w, scm *a)
 876 {
 877   if (c == EOF && !w) return &scm_nil;
 878   if (c == '\n' && !w) return readword (getchar (), w, a);
 879   if (c == '\n' && *w == '.' && w[1] == 0) return &scm_dot;
 880   if (c == EOF || c == '\n') return lookup (w, a);
 881   if (c == ' ') return readword ('\n', w, a);
 882   if (c == '"' && !w) return readstring ();
 883   if (c == '"') {ungetchar (c); return lookup (w, a);}
 884   if (c == '(' && !w) return readlist (a);
 885   if (c == '(') {ungetchar (c); return lookup (w, a);}
 886   if (c == ')' && !w) {ungetchar (c); return &scm_nil;}
 887   if (c == ')') {ungetchar (c); return lookup (w, a);}
 888   if ((c == '\''
 889 #if QUASIQUOTE
 890        || c == '`'
 891        || c == ','
 892 #endif
 893        )
 894       && !w) {return cons (lookup_char (c, a),
 895                                      cons (readword (getchar (), w, a),
 896                                            &scm_nil));}
 897   if (c == ';') {readcomment (c); return readword ('\n', w, a);}
 898   if (c == '#' && peekchar () == '\\') {getchar (); return readchar ();}
 899   if (c == '#' && !w && peekchar () == '(') {getchar (); return list_to_vector (readlist (a));}
 900   if (c == '#' && peekchar () == '(') {ungetchar (c); return lookup (w, a);}
 901   if (c == '#' && peekchar () == '!') {getchar (); readblock (getchar ()); return readword (getchar (), w, a);}
 902   char buf[256] = {0};
 903   char ch = c;
 904   return readword (getchar (), strncat (w ? w : buf, &ch, 1), a);
 905 }
 906
 907 scm *
 908 readchar ()
 909 {
 910   int c = getchar ();
 911   if (c >= '0' && c <= '7'
 912       && peekchar () >= '0' && peekchar () <= '7') {
 913     c = c - '0';
 914     while (peekchar () >= '0' && peekchar () <= '7') {
 915       c <<= 3;
 916       c += getchar () - '0';
 917     }
 918   }
 919   else if (c >= 'a' && c <= 'z'
 920       && peekchar () >= 'a' && peekchar () <= 'z') {
 921     char buf[256];
 922     char *p = buf;
 923     *p++ = c;
 924     while (peekchar () >= 'a' && peekchar () <= 'z') {
 925       *p++ = getchar ();
 926     }
 927     *p = 0;
 928     if (!strcmp (buf, "newline")) c = 10;
 929     else if (!strcmp (buf, "space")) c = 32;
 930     else {
 931       printf ("char not supported: %s", buf);
 932       assert (!"char not supported");
 933     }
 934   }
 935   return make_char (c);
 936 }
 937
 938 scm *
 939 readstring ()
 940 {
 941   char buf[256];
 942   char *p = buf;
 943   int c = getchar ();
 944   while (true) {
 945     if (c == '"') break;
 946     *p++ = c;
 947     if (c == '\\' && peekchar () == '"') *p++ = getchar ();
 948     if (c == EOF) assert (!"EOF in string");
 949     c = getchar ();
 950   }
 951   *p = 0;
 952   return make_string (buf);
 953 }
 954
 955 int
 956 eat_whitespace (int c)
 957 {
 958   while (c == ' ' || c == '\n') c = getchar ();
 959   if (c == ';') return eat_whitespace (readcomment (c));
 960   if (c == '#' && peekchar () == '!') {getchar (); readblock (getchar ()); return eat_whitespace (getchar ());}
 961   return c;
 962 }
 963
 964 scm *
 965 readlist (scm *a)
 966 {
 967   int c = getchar ();
 968   c = eat_whitespace (c);
 969   if (c == ')') return &scm_nil;
 970   scm *w = readword (c, 0, a);
 971   if (w == &scm_dot)
 972     return car (readlist (a));
 973   return cons (w, readlist (a));
 974 }
 975
 976 scm *
 977 readenv (scm *a)
 978 {
 979   return readword (getchar (), 0, a);
 980 }
 981
 982 // Extras to make interesting program
 983
 984 scm *
 985 hello_world ()
 986 {
 987   puts ("c: hello world");
 988   return &scm_unspecified;
 989 }
 990
 991 scm *
 992 less_p (scm *a, scm *b)
 993 {
 994   assert (a->type == NUMBER);
 995   assert (b->type == NUMBER);
 996   return a->value < b->value ? &scm_t : &scm_f;
 997 }
 998
 999 scm *
1000 minus (scm *x/*...*/)
1001 {
1002   scm *a = car (x);
1003   assert (a->type == NUMBER);
1004   int n = a->value;
1005   x = cdr (x);
1006   if (x == &scm_nil)
1007     n = -n;
1008   while (x != &scm_nil)
1009     {
1010       assert (x->car->type == NUMBER);
1011       n -= x->car->value;
1012       x = cdr (x);
1013     }
1014   return make_number (n);
1015 }
1016
1017 scm *
1018 plus (scm *x/*...*/)
1019 {
1020   int n = 0;
1021   while (x != &scm_nil)
1022     {
1023       assert (x->car->type == NUMBER);
1024       n += x->car->value;
1025       x = cdr (x);
1026     }
1027   return make_number (n);
1028 }
1029
1030 scm *
1031 divide (scm *x/*...*/)
1032 {
1033   int n = 1;
1034   while (x != &scm_nil)
1035     {
1036       assert (x->car->type == NUMBER);
1037       n /= x->car->value;
1038       x = cdr (x);
1039     }
1040   return make_number (n);
1041 }
1042
1043 scm *
1044 multiply (scm *x/*...*/)
1045 {
1046   int n = 1;
1047   while (x != &scm_nil)
1048     {
1049       assert (x->car->type == NUMBER);
1050       n *= x->car->value;
1051       x = cdr (x);
1052     }
1053   return make_number (n);
1054 }
1055
1056 scm *
1057 is_p (scm *a, scm *b)
1058 {
1059   assert (a->type == NUMBER);
1060   assert (b->type == NUMBER);
1061   return a->value == b->value ? &scm_t : &scm_f;
1062 }
1063
1064 #if QUASIQUOTE
1065 scm *
1066 eval_quasiquote (scm *e, scm *a)
1067 {
1068 #if DEBUG
1069   printf ("\nc:eval_quasiquote e=");
1070   display (e);
1071   if (pair_p (e) == &scm_t) {
1072     printf ("\ncar (e)=");
1073     display (car (e));
1074     printf (" atom=");
1075     display (atom_p (car (e)));
1076   }
1077   puts ("");
1078 #endif
1079   if (e == &scm_nil) return e;
1080   else if (atom_p (e) == &scm_t) return e;
1081   else if (atom_p (car (e)) == &scm_t)
1082     return cons (car (e), eval_quasiquote (cdr (e), a));
1083   else if (eq_p (caar (e), &scm_symbol_unquote) == &scm_t)
1084     return cons (eval (cadar (e), a), &scm_nil);
1085   else if (eq_p (caar (e), &scm_symbol_quote) == &scm_t)
1086     return cons (cadar (e), &scm_nil);
1087   else if (eq_p (caar (e), &scm_symbol_quasiquote) == &scm_t)
1088     return cdar (e);
1089   return cons (car (e), eval_quasiquote (cdr (e), a));
1090 }
1091 #endif
1092
1093 scm *
1094 add_environment (scm *a, char *name, scm *x)
1095 {
1096   return cons (cons (make_symbol (name), x), a);
1097 }
1098
1099 scm *
1100 mes_environment ()
1101 {
1102   scm *a = &scm_nil;
1103
1104   a = add_environment (a, "()", &scm_nil);
1105   a = add_environment (a, "#t", &scm_t);
1106   a = add_environment (a, "#f", &scm_f);
1107   a = add_environment (a, "*unspecified*", &scm_unspecified);
1108   a = add_environment (a, "label", &scm_label);
1109   a = add_environment (a, "lambda", &scm_lambda);
1110   a = add_environment (a, "*macro*", &scm_nil);
1111   a = add_environment (a, "*dot*", &scm_dot);
1112   a = add_environment (a, "current-module", &scm_symbol_current_module);
1113
1114   a = add_environment (a, "'", &scm_quote);
1115 #if QUASIQUOTE
1116   a = add_environment (a, ",", &scm_unquote);
1117   a = add_environment (a, "`", &scm_quasiquote);
1118 #endif
1119
1120 #include "environment.i"
1121
1122   return a;
1123 }
1124
1125 scm *
1126 define_lambda (scm *x)
1127 {
1128   return cons (caadr (x), cons (&scm_lambda, cons (cdadr (x), cddr (x))));
1129 }
1130
1131 scm *
1132 define (scm *x, scm *a)
1133 {
1134   if (atom_p (cadr (x)) != &scm_f)
1135     return cons (cadr (x), eval (caddr (x), a));
1136   return define_lambda (x);
1137 }
1138
1139 scm *
1140 define_macro (scm *x, scm *a)
1141 {
1142 #if DEBUG
1143   printf ("\nc:define_macro a=");
1144   scm *aa =cons (&scm_macro,
1145                cons (define_lambda (x),
1146                      cdr (assq (&scm_macro, a))));
1147   display (aa);
1148   puts ("");
1149 #endif
1150   if (atom_p (cadr (x)) != &scm_f)
1151     return cons (&scm_macro,
1152                  cons (cons (cadr (x), eval (caddr (x), a)),
1153                        cdr (assq (&scm_macro, a))));
1154   return cons (&scm_macro,
1155                cons (define_lambda (x),
1156                      cdr (assq (&scm_macro, a))));
1157 }
1158
1159 scm *
1160 loop (scm *r, scm *e, scm *a)
1161 {
1162 #if 0//DEBUG
1163   printf ("\nc:loop e=");
1164   display (e);
1165   puts ("");
1166 #endif
1167   if (e == &scm_nil)
1168     return r;
1169   else if (eq_p (e, &scm_symbol_EOF) == &scm_t)
1170     return apply_env (cdr (assq (&scm_symbol_loop2, a)),
1171                   cons (&scm_unspecified, cons (&scm_t, cons (a, &scm_nil))), a);
1172   else if (eq_p (e, &scm_symbol_EOF2) == &scm_t)
1173     return r;
1174   else if (atom_p (e) == &scm_t)
1175     return loop (eval (e, a), readenv (a), a);
1176   else if (eq_p (car (e), &scm_symbol_define) == &scm_t)
1177     return loop (&scm_unspecified,
1178                  readenv (a),
1179                  cons (define (e, a), a));
1180   else if (eq_p (car (e), &scm_symbol_define_macro) == &scm_t)
1181     return loop (&scm_unspecified,
1182                  readenv (a),
1183                  cons (define_macro (e, a), a));
1184   else if (eq_p (car (e), &scm_symbol_set_x) == &scm_t)
1185     return loop (set_env_x (cadr (e), eval (caddr (e), a), a), readenv (a), a);
1186   return loop (eval (e, a), readenv (a), a);
1187 }
1188
1189 int
1190 main (int argc, char *argv[])
1191 {
1192   scm *a = mes_environment ();
1193   display (loop (&scm_unspecified, readenv (a), a));
1194   newline ();
1195   return 0;
1196 }
1197
1198 scm *
1199 apply_env (scm *fn, scm *x, scm *a)
1200 {
1201 #if DEBUG
1202   printf ("\nc:apply_env fn=");
1203   display (fn);
1204   printf (" x=");
1205   display (x);
1206   puts ("");
1207 #endif
1208   if (fn == &scm_apply_env_)
1209     return eval_ (x, a);
1210   return apply_env_ (fn, x, a);
1211 }
1212
1213 bool evalling_p = false;
1214
1215 scm *
1216 eval (scm *e, scm *a)
1217 {
1218 #if DEBUG
1219   printf ("\nc:eval e=");
1220   display (e);
1221   puts ("");
1222 #endif
1223
1224   scm *eval__ = assq (&scm_symbol_eval, a);
1225   assert (eval__ != &scm_f);
1226   eval__ = cdr (eval__);
1227   if (builtin_p (eval__) == &scm_t
1228       || evalling_p)
1229     return eval_ (e, a);
1230   evalling_p = true;
1231   scm *r = apply_env (eval__, cons (e, cons (a, &scm_nil)), a);
1232   evalling_p = false;
1233   return r;
1234 }