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 eval_quote (scm *fn, scm *x)
 264 {
 265   return apply (fn, x, &scm_nil);
 266 }
 267
 268 scm *
 269 apply_ (scm *fn, scm *x, scm *a)
 270 {
 271 #if DEBUG
 272   printf ("apply fn=");
 273   display (fn);
 274   printf (" x=");
 275   display (x);
 276   puts ("");
 277 #endif
 278   if (atom_p (fn) != &scm_f)
 279     {
 280       if (fn == &scm_symbol_current_module) // FIXME
 281         return a;
 282       if (eq_p (fn, &scm_symbol_call_with_values) == &scm_t)
 283         return call (&scm_call_with_values_env, append2 (x, cons (a, &scm_nil)));
 284       if (builtin_p (fn) == &scm_t)
 285         return call (fn, x);
 286       return apply (eval (fn,  a), x, a);
 287     }
 288   else if (car (fn) == &scm_lambda)
 289     return begin_env (cddr (fn), pairlis (cadr (fn), x, a));
 290   else if (car (fn) == &scm_label)
 291     return apply (caddr (fn), x, cons (cons (cadr (fn), caddr (fn)), a));
 292   return &scm_unspecified;
 293 }
 294
 295 scm *
 296 begin_env (scm *body, scm *a)
 297 {
 298   if (body == &scm_nil) return &scm_unspecified;
 299   scm *result = eval (car (body), a);
 300   if (cdr (body) == &scm_nil)
 301     return result;
 302   return begin_env (cdr (body), a);
 303 }
 304
 305 scm *
 306 eval_ (scm *e, scm *a)
 307 {
 308 #if DEBUG
 309   printf ("eval e=");
 310   display (e);
 311   puts ("");
 312 #endif
 313   if (e->type == CHAR)
 314     return e;
 315   else if (e->type == NUMBER)
 316     return e;
 317   else if (e->type == STRING)
 318     return e;
 319   else if (e->type == VECTOR)
 320     return e;
 321   else if (atom_p (e) == &scm_t) {
 322     scm *y = assq (e, a);
 323     if (y == &scm_f) {
 324       printf ("eval: no such symbol: %s\n", e->name);
 325       exit (1);
 326     }
 327     return cdr (y);
 328   }
 329   if (builtin_p (e) == &scm_t)
 330     return e;
 331   else if (atom_p (car (e)) == &scm_t)
 332     {
 333 #if MACROS
 334       scm *macro;
 335 #endif // MACROS
 336       if (car (e) == &scm_symbol_quote)
 337         return cadr (e);
 338       if (car (e) == &scm_lambda)
 339         return e;
 340       if (car (e) == &scm_symbol_set_x)
 341         return set_env_x (cadr (e), eval (caddr (e), a), a);
 342 #if QUASIQUOTE
 343       else if (car (e) == &scm_symbol_unquote)
 344         return eval (cadr (e), a);
 345       else if (car (e) == &scm_symbol_quasiquote) {
 346 #if DEBUG
 347         printf ("cadr e:");
 348         display (cadr (e));
 349         puts ("");
 350         printf ("qq:");
 351         display (eval_quasiquote (cadr (e), a));
 352         puts ("");
 353 #endif // DEBUG
 354         return eval_quasiquote (cadr (e), a);
 355       }
 356 #endif // QUASIQUOTE
 357       else if (car (e) == &scm_symbol_cond)
 358         return evcon (cdr (e), a);
 359 #if MACROS
 360       else if ((macro = assq (car (e), cdr (assq (&scm_macro, a)))) != &scm_f)
 361         return eval (apply_ (cdr (macro), cdr (e), a), a);
 362 #endif // MACROS
 363       return apply (car (e), evlis (cdr (e), a), a);
 364     }
 365   return apply (car (e), evlis (cdr (e), a), a);
 366 }
 367
 368 scm *
 369 evcon_ (scm *c, scm *a)
 370 {
 371 #if DEBUG
 372   printf ("evcon_ clause=");
 373   display (car (c));
 374   puts ("");
 375 #endif
 376   if (c == &scm_nil) return &scm_unspecified;
 377   if (eval (caar (c), a) != &scm_f) {
 378 #if DEBUG
 379     //if (fn != &scm_display && fn != &scm_call)
 380     //if (fn != &scm_call)
 381     printf ("#t clause=");
 382     display (car (c));
 383     printf (" cddar=");
 384     display (cddar (c));
 385     printf (" nil=%d", cddar (c) == &scm_nil);
 386     puts ("");
 387 #endif
 388     if (cddar (c) == &scm_nil)
 389       return eval (cadar (c), a);
 390     eval (cadar (c), a);
 391     return evcon_ (cons (cons (&scm_t, cddar (c)), &scm_nil), a);
 392   }
 393   return evcon_ (cdr (c), a);
 394 }
 395
 396 scm *
 397 evcon (scm *c, scm *a)
 398 {
 399 #if DEBUG
 400   printf ("\n****evcon=");
 401   display (c);
 402   puts ("");
 403 #endif
 404   return evcon_ (c, a);
 405 }
 406
 407 scm *
 408 evlis (scm *m, scm *a)
 409 {
 410 #if DEBUG
 411   printf ("evlis m=");
 412   display (m);
 413   puts ("");
 414 #endif
 415   if (m == &scm_nil)
 416     return &scm_nil;
 417   scm *e = eval (car (m), a);
 418   return cons (e, evlis (cdr (m), a));
 419 }
 420
 421 //Helpers
 422
 423 scm *
 424 builtin_p (scm *x)
 425 {
 426   return (x->type == FUNCTION0
 427           || x->type == FUNCTION1
 428           || x->type == FUNCTION2
 429           || x->type == FUNCTION3
 430           || x->type == FUNCTIONn)
 431     ? &scm_t : &scm_f;
 432 }
 433
 434 scm *
 435 char_p (scm *x)
 436 {
 437   return x->type == CHAR ? &scm_t : &scm_f;
 438 }
 439
 440 scm *
 441 number_p (scm *x)
 442 {
 443   return x->type == NUMBER ? &scm_t : &scm_f;
 444 }
 445
 446 scm *
 447 string_p (scm *x)
 448 {
 449   return x->type == STRING ? &scm_t : &scm_f;
 450 }
 451
 452 scm *
 453 symbol_p (scm *x)
 454 {
 455   //TODO: #f,#t,nil also `symbols' atm
 456   return x->type == SYMBOL ? &scm_t : &scm_f;
 457 }
 458
 459 scm *
 460 vector_p (scm *x)
 461 {
 462   return x->type == VECTOR ? &scm_t : &scm_f;
 463 }
 464
 465 scm *
 466 display (scm *x)
 467 {
 468   return display_helper (x, false, "", false);
 469 }
 470
 471 scm *
 472 call (scm *fn, scm *x)
 473 {
 474 #if DEBUG
 475   //if (fn != &scm_display && fn != &scm_call)
 476   //if (fn != &scm_call)
 477   {
 478     printf ("\ncall fn=");
 479     display (fn);
 480     printf (" x=");
 481     display (x);
 482     puts ("");
 483   }
 484 #endif
 485   if (fn->type == FUNCTION0)
 486     return fn->function0 ();
 487   if (x->car->type == VALUES)
 488     x = cons (x->car->cdr->car, &scm_nil);
 489   if (fn->type == FUNCTION1)
 490     return fn->function1 (car (x));
 491   if (fn->type == FUNCTION2)
 492     return fn->function2 (car (x), cadr (x));
 493   if (fn->type == FUNCTION3)
 494     return fn->function3 (car (x), cadr (x), caddr (x));
 495   if (fn->type == FUNCTIONn)
 496     return fn->functionn (x);
 497   return &scm_unspecified;
 498 }
 499
 500 scm *
 501 append2 (scm *x, scm *y)
 502 {
 503   if (x == &scm_nil) return y;
 504   assert (x->type == PAIR);
 505   return cons (car (x), append2 (cdr (x), y));
 506 }
 507
 508 scm *
 509 append (scm *x/*...*/)
 510  {
 511   if (x == &scm_nil) return &scm_nil;
 512   return append2 (car (x), append (cdr (x)));
 513  }
 514
 515 scm *
 516 make_char (int x)
 517 {
 518   scm *p = malloc (sizeof (scm));
 519   p->type = CHAR;
 520   p->value = x;
 521   return p;
 522 }
 523
 524 scm *
 525 make_number (int x)
 526 {
 527   scm *p = malloc (sizeof (scm));
 528   p->type = NUMBER;
 529   p->value = x;
 530   return p;
 531 }
 532
 533 scm *
 534 make_string (char const *s)
 535 {
 536   scm *p = malloc (sizeof (scm));
 537   p->type = STRING;
 538   p->name = strdup (s);
 539   return p;
 540 }
 541
 542 scm *
 543 make_symbol (char const *s)
 544 {
 545   // TODO: alist lookup symbols
 546   scm *p = malloc (sizeof (scm));
 547   p->type = SYMBOL;
 548   p->name = strdup (s);
 549   return p;
 550 }
 551
 552 scm *
 553 make_vector (int n)
 554 {
 555   scm *p = malloc (sizeof (scm));
 556   p->type = VECTOR;
 557   p->length = n;
 558   p->vector = malloc (n * sizeof (scm*));
 559   return p;
 560 }
 561
 562 scm *
 563 string (scm *x/*...*/)
 564 {
 565   char buf[256] = "";
 566   char *p = buf;
 567   while (x != &scm_nil)
 568     {
 569       scm *s = car (x);
 570       assert (s->type == CHAR);
 571       *p++ = s->value;
 572       x = cdr (x);
 573     }
 574   return make_string (buf);
 575 }
 576
 577 scm *
 578 string_append (scm *x/*...*/)
 579 {
 580   char buf[256] = "";
 581
 582   while (x != &scm_nil)
 583     {
 584       scm *s = car (x);
 585       assert (s->type == STRING);
 586       strcat (buf, s->name);
 587       x = cdr (x);
 588     }
 589   return make_string (buf);
 590 }
 591
 592 scm *
 593 string_length (scm *x)
 594 {
 595   assert (x->type == STRING);
 596   return make_number (strlen (x->name));
 597 }
 598
 599 scm *
 600 length (scm *x)
 601 {
 602   int n = 0;
 603   while (x != &scm_nil)
 604     {
 605       n++;
 606       x = cdr (x);
 607     }
 608   return make_number (n);
 609 }
 610
 611 #if 0
 612 scm *
 613 builtin_list (scm *x/*...*/) // int
 614 {
 615   return x;
 616 }
 617
 618 scm *
 619 vector (scm *x/*...*/) // int
 620 {
 621   return list_to_vector (x);
 622 }
 623 #endif
 624
 625 scm *
 626 values (scm *x/*...*/)
 627 {
 628   scm *v = cons (0, x);
 629   v->type = VALUES;
 630   return v;
 631 }
 632
 633 scm *
 634 call_with_values_env (scm *producer, scm *consumer, scm *a)
 635 {
 636   scm *v = apply_ (producer, &scm_nil, a);
 637   if (v->type == VALUES)
 638     v = v->cdr;
 639   return apply_ (consumer, v, a);
 640 }
 641
 642 scm *
 643 vector_length (scm *x)
 644 {
 645   assert (x->type == VECTOR);
 646   return make_number (x->length);
 647 }
 648
 649 scm *
 650 vector_ref (scm *x, scm *i)
 651 {
 652   assert (x->type == VECTOR);
 653   assert (i->value < x->length);
 654   return x->vector[i->value];
 655 }
 656
 657 scm *
 658 vector_set_x (scm *x, scm *i, scm *e)
 659 {
 660   assert (x->type == VECTOR);
 661   assert (i->value < x->length);
 662   x->vector[i->value] = e;
 663   return &scm_unspecified;
 664 }
 665
 666 scm *
 667 lookup (char *x, scm *a)
 668 {
 669   if (isdigit (*x) || (*x == '-' && isdigit (*(x+1))))
 670     return make_number (atoi (x));
 671   if (*x == '\'') return &scm_symbol_quote;
 672
 673   if (!strcmp (x, scm_unspecified.name)) return &scm_unspecified;
 674   if (!strcmp (x, scm_symbol_cond.name)) return &scm_symbol_cond;
 675   if (!strcmp (x, scm_symbol_quote.name)) return &scm_symbol_quote;
 676   if (!strcmp (x, scm_lambda.name)) return &scm_lambda;
 677   if (!strcmp (x, scm_label.name)) return &scm_label;
 678   if (!strcmp (x, scm_nil.name)) return &scm_nil;
 679   if (!strcmp (x, scm_symbol_set_x.name)) return &scm_symbol_set_x;
 680
 681 #if QUASIQUOTE
 682   if (*x == '`') return &scm_symbol_quasiquote;
 683   if (*x == ',') return &scm_symbol_unquote;
 684   if (!strcmp (x, scm_symbol_unquote.name)) return &scm_symbol_unquote;
 685   if (!strcmp (x, scm_symbol_quasiquote.name)) return &scm_symbol_quasiquote;
 686 #endif
 687
 688   return make_symbol (x);
 689 }
 690
 691 scm *
 692 lookup_char (int c, scm *a)
 693 {
 694   char buf[2];
 695   buf[0] = c;
 696   buf[1] = 0;
 697   return lookup (buf, a);
 698 }
 699
 700 char *
 701 list2str (scm *l) // char*
 702 {
 703   static char buf[256];
 704   char *p = buf;
 705   while (l != &scm_nil) {
 706     scm *c = car (l);
 707     assert (c->type == NUMBER);
 708     *p++ = c->value;
 709     l = cdr (l);
 710   }
 711   *p = 0;
 712   return buf;
 713 }
 714
 715 scm*
 716 list_to_vector (scm *x)
 717 {
 718   int n = length (x)->value;
 719   scm *v = make_vector (n);
 720   scm **p = v->vector;
 721   while (x != &scm_nil)
 722     {
 723       *p++ = car (x);
 724       x = cdr (x);
 725     }
 726   return v;
 727 }
 728
 729 scm*
 730 number_to_string (scm *x)
 731 {
 732   assert (x->type == NUMBER);
 733   char buf[256];
 734   sprintf (buf,"%d", x->value);
 735   return make_string (buf);
 736 }
 737
 738 scm*
 739 string_to_symbol (scm *x)
 740 {
 741   assert (x->type == STRING);
 742   return make_symbol (x->name);
 743 }
 744
 745 scm*
 746 symbol_to_string (scm *x)
 747 {
 748   assert (x->type == SYMBOL);
 749   return make_string (x->name);
 750 }
 751
 752 scm*
 753 vector_to_list (scm *v)
 754 {
 755   scm *x = &scm_nil;
 756   for (int i = 0; i < v->length; i++)
 757     x = append2 (x, cons (v->vector[i], &scm_nil));
 758   return x;
 759 }
 760
 761 scm *
 762 builtin_lookup (scm *l, scm *a)
 763 {
 764   return lookup (list2str (l), a);
 765 }
 766
 767 scm *
 768 cossa (scm *x, scm *a)
 769 {
 770   if (a == &scm_nil) return &scm_f;
 771   if (eq_p (cdar (a), x) == &scm_t)
 772     return car (a);
 773   return cossa (x, cdr (a));
 774 }
 775
 776 scm *
 777 newline ()
 778 {
 779   puts ("");
 780   return &scm_unspecified;
 781 }
 782
 783 scm *
 784 display_helper (scm *x, bool cont, char *sep, bool quote)
 785 {
 786   scm *r;
 787   printf ("%s", sep);
 788   if (x->type == CHAR && x->value == 10) printf ("#\\%s", "newline");
 789   else if (x->type == CHAR && x->value == 32) printf ("#\\%s", "space");
 790   else if (x->type == CHAR) printf ("#\\%c", x->value);
 791   else if (x->type == NUMBER) printf ("%d", x->value);
 792   else if (x->type == PAIR) {
 793 #if QUOTE_SUGAR
 794     if (car (x) == &scm_quote) {
 795       printf ("'");
 796       return display_helper (car (cdr (x)), cont, "", true);
 797     }
 798 #if QUASIQUOTE
 799     if (car (x) == &scm_quasiquote) {
 800       printf ("`");
 801       return display_helper (car (cdr (x)), cont, "", true);
 802     }
 803     if (car (x) == &scm_unquote) {
 804       printf (",");
 805       return display_helper (car (cdr (x)), cont, "", true);
 806     }
 807 #endif
 808 #endif
 809     if (!cont) printf ("(");
 810     display (car (x));
 811     if (cdr (x)->type == PAIR)
 812       display_helper (cdr (x), true, " ", false);
 813     else if (cdr (x) != &scm_nil) {
 814       printf (" . ");
 815       display (cdr (x));
 816     }
 817     if (!cont) printf (")");
 818   }
 819   else if (x->type == VECTOR) {
 820     printf ("#(");
 821     for (int i = 0; i < x->length; i++)
 822       display_helper (x->vector[i], true, i ? " " : "", false);
 823     printf (")");
 824   }
 825   else if (atom_p (x) == &scm_t) printf ("%s", x->name);
 826
 827   return &scm_unspecified;
 828 }
 829
 830 // READ
 831
 832 int
 833 ungetchar (int c) //int
 834 {
 835   return ungetc (c, stdin);
 836 }
 837
 838 int
 839 peekchar () //int
 840 {
 841   int c = getchar ();
 842   ungetchar (c);
 843   return c;
 844 }
 845
 846 scm*
 847 builtin_getchar ()
 848 {
 849   return make_number (getchar ());
 850 }
 851
 852 scm*
 853 builtin_peekchar ()
 854 {
 855   return make_number (peekchar ());
 856 }
 857
 858 scm*
 859 builtin_ungetchar (scm *c)
 860 {
 861   assert (c->type == NUMBER);
 862   ungetchar (c->value);
 863   return c;
 864 }
 865
 866 int
 867 readcomment (int c)
 868 {
 869   if (c == '\n') return c;
 870   return readcomment (getchar ());
 871 }
 872
 873 int
 874 readblock (int c)
 875 {
 876   if (c == '!' && peekchar () == '#') return getchar ();
 877   return readblock (getchar ());
 878 }
 879
 880 scm *
 881 readword (int c, char* w, scm *a)
 882 {
 883   if (c == EOF && !w) return &scm_nil;
 884   if (c == '\n' && !w) return readword (getchar (), w, a);
 885   if (c == '\n' && *w == '.' && w[1] == 0) return &scm_dot;
 886   if (c == EOF || c == '\n') return lookup (w, a);
 887   if (c == ' ') return readword ('\n', w, a);
 888   if (c == '"' && !w) return readstring ();
 889   if (c == '"') {ungetchar (c); return lookup (w, a);}
 890   if (c == '(' && !w) return readlist (a);
 891   if (c == '(') {ungetchar (c); return lookup (w, a);}
 892   if (c == ')' && !w) {ungetchar (c); return &scm_nil;}
 893   if (c == ')') {ungetchar (c); return lookup (w, a);}
 894   if ((c == '\''
 895 #if QUASIQUOTE
 896        || c == '`'
 897        || c == ','
 898 #endif
 899        )
 900       && !w) {return cons (lookup_char (c, a),
 901                                      cons (readword (getchar (), w, a),
 902                                            &scm_nil));}
 903   if (c == ';') {readcomment (c); return readword ('\n', w, a);}
 904   if (c == '#' && peekchar () == '\\') {getchar (); return readchar ();}
 905   if (c == '#' && !w && peekchar () == '(') {getchar (); return list_to_vector (readlist (a));}
 906   if (c == '#' && peekchar () == '(') {ungetchar (c); return lookup (w, a);}
 907   if (c == '#' && peekchar () == '!') {getchar (); readblock (getchar ()); return readword (getchar (), w, a);}
 908   char buf[256] = {0};
 909   char ch = c;
 910   return readword (getchar (), strncat (w ? w : buf, &ch, 1), a);
 911 }
 912
 913 scm *
 914 readchar ()
 915 {
 916   int c = getchar ();
 917   if (c >= '0' && c <= '7'
 918       && peekchar () >= '0' && peekchar () <= '7') {
 919     c = c - '0';
 920     while (peekchar () >= '0' && peekchar () <= '7') {
 921       c <<= 3;
 922       c += getchar () - '0';
 923     }
 924   }
 925   else if (c >= 'a' && c <= 'z'
 926       && peekchar () >= 'a' && peekchar () <= 'z') {
 927     char buf[256];
 928     char *p = buf;
 929     *p++ = c;
 930     while (peekchar () >= 'a' && peekchar () <= 'z') {
 931       *p++ = getchar ();
 932     }
 933     *p = 0;
 934     if (!strcmp (buf, "newline")) c = 10;
 935     else if (!strcmp (buf, "space")) c = 32;
 936     else {
 937       printf ("char not supported: %s", buf);
 938       assert (!"char not supported");
 939     }
 940   }
 941   return make_char (c);
 942 }
 943
 944 scm *
 945 readstring ()
 946 {
 947   char buf[256];
 948   char *p = buf;
 949   int c = getchar ();
 950   while (true) {
 951     if (c == '"') break;
 952     *p++ = c;
 953     if (c == '\\' && peekchar () == '"') *p++ = getchar ();
 954     if (c == EOF) assert (!"EOF in string");
 955     c = getchar ();
 956   }
 957   *p = 0;
 958   return make_string (buf);
 959 }
 960
 961 int
 962 eat_whitespace (int c)
 963 {
 964   while (c == ' ' || c == '\n') c = getchar ();
 965   if (c == ';') return eat_whitespace (readcomment (c));
 966   if (c == '#' && peekchar () == '!') {getchar (); readblock (getchar ()); return eat_whitespace (getchar ());}
 967   return c;
 968 }
 969
 970 scm *
 971 readlist (scm *a)
 972 {
 973   int c = getchar ();
 974   c = eat_whitespace (c);
 975   if (c == ')') return &scm_nil;
 976   scm *w = readword (c, 0, a);
 977   if (w == &scm_dot)
 978     return car (readlist (a));
 979   return cons (w, readlist (a));
 980 }
 981
 982 scm *
 983 readenv (scm *a)
 984 {
 985   return readword (getchar (), 0, a);
 986 }
 987
 988 // Extras to make interesting program
 989
 990 scm *
 991 hello_world ()
 992 {
 993   puts ("c: hello world");
 994   return &scm_unspecified;
 995 }
 996
 997 scm *
 998 less_p (scm *a, scm *b)
 999 {
1000   assert (a->type == NUMBER);
1001   assert (b->type == NUMBER);
1002   return a->value < b->value ? &scm_t : &scm_f;
1003 }
1004
1005 scm *
1006 minus (scm *x/*...*/)
1007 {
1008   scm *a = car (x);
1009   assert (a->type == NUMBER);
1010   int n = a->value;
1011   x = cdr (x);
1012   if (x == &scm_nil)
1013     n = -n;
1014   while (x != &scm_nil)
1015     {
1016       assert (x->car->type == NUMBER);
1017       n -= x->car->value;
1018       x = cdr (x);
1019     }
1020   return make_number (n);
1021 }
1022
1023 scm *
1024 plus (scm *x/*...*/)
1025 {
1026   int n = 0;
1027   while (x != &scm_nil)
1028     {
1029       assert (x->car->type == NUMBER);
1030       n += x->car->value;
1031       x = cdr (x);
1032     }
1033   return make_number (n);
1034 }
1035
1036 scm *
1037 divide (scm *x/*...*/)
1038 {
1039   int n = 1;
1040   while (x != &scm_nil)
1041     {
1042       assert (x->car->type == NUMBER);
1043       n /= x->car->value;
1044       x = cdr (x);
1045     }
1046   return make_number (n);
1047 }
1048
1049 scm *
1050 multiply (scm *x/*...*/)
1051 {
1052   int n = 1;
1053   while (x != &scm_nil)
1054     {
1055       assert (x->car->type == NUMBER);
1056       n *= x->car->value;
1057       x = cdr (x);
1058     }
1059   return make_number (n);
1060 }
1061
1062 scm *
1063 is_p (scm *a, scm *b)
1064 {
1065   assert (a->type == NUMBER);
1066   assert (b->type == NUMBER);
1067   return a->value == b->value ? &scm_t : &scm_f;
1068 }
1069
1070 #if QUASIQUOTE
1071 scm *
1072 eval_quasiquote (scm *e, scm *a)
1073 {
1074 #if DEBUG
1075   printf ("\nc:eval_quasiquote e=");
1076   display (e);
1077   if (pair_p (e) == &scm_t) {
1078     printf ("\ncar (e)=");
1079     display (car (e));
1080     printf (" atom=");
1081     display (atom_p (car (e)));
1082   }
1083   puts ("");
1084 #endif
1085   if (e == &scm_nil) return e;
1086   else if (atom_p (e) == &scm_t) return e;
1087   else if (atom_p (car (e)) == &scm_t)
1088     return cons (car (e), eval_quasiquote (cdr (e), a));
1089   else if (eq_p (caar (e), &scm_symbol_unquote) == &scm_t)
1090     return cons (eval (cadar (e), a), &scm_nil);
1091   else if (eq_p (caar (e), &scm_symbol_quote) == &scm_t)
1092     return cons (cadar (e), &scm_nil);
1093   else if (eq_p (caar (e), &scm_symbol_quasiquote) == &scm_t)
1094     return cdar (e);
1095   return cons (car (e), eval_quasiquote (cdr (e), a));
1096 }
1097 #endif
1098
1099 scm *
1100 add_environment (scm *a, char *name, scm *x)
1101 {
1102   return cons (cons (make_symbol (name), x), a);
1103 }
1104
1105 scm *
1106 mes_environment ()
1107 {
1108   scm *a = &scm_nil;
1109
1110   a = add_environment (a, "()", &scm_nil);
1111   a = add_environment (a, "#t", &scm_t);
1112   a = add_environment (a, "#f", &scm_f);
1113   a = add_environment (a, "*unspecified*", &scm_unspecified);
1114   a = add_environment (a, "label", &scm_label);
1115   a = add_environment (a, "lambda", &scm_lambda);
1116   a = add_environment (a, "*macro*", &scm_nil);
1117   a = add_environment (a, "*dot*", &scm_dot);
1118   a = add_environment (a, "current-module", &scm_symbol_current_module);
1119
1120   a = add_environment (a, "'", &scm_quote);
1121 #if QUASIQUOTE
1122   a = add_environment (a, ",", &scm_unquote);
1123   a = add_environment (a, "`", &scm_quasiquote);
1124 #endif
1125
1126 #include "environment.i"
1127
1128   return a;
1129 }
1130
1131 scm *
1132 define_lambda (scm *x)
1133 {
1134   return cons (caadr (x), cons (&scm_lambda, cons (cdadr (x), cddr (x))));
1135 }
1136
1137 scm *
1138 define (scm *x, scm *a)
1139 {
1140   if (atom_p (cadr (x)) != &scm_f)
1141     return cons (cadr (x), eval (caddr (x), a));
1142   return define_lambda (x);
1143 }
1144
1145 scm *
1146 define_macro (scm *x, scm *a)
1147 {
1148 #if DEBUG
1149   printf ("\nc:define_macro a=");
1150   scm *aa =cons (&scm_macro,
1151                cons (define_lambda (x),
1152                      cdr (assq (&scm_macro, a))));
1153   display (aa);
1154   puts ("");
1155 #endif
1156   if (atom_p (cadr (x)) != &scm_f)
1157     return cons (&scm_macro,
1158                  cons (cons (cadr (x), eval (caddr (x), a)),
1159                        cdr (assq (&scm_macro, a))));
1160   return cons (&scm_macro,
1161                cons (define_lambda (x),
1162                      cdr (assq (&scm_macro, a))));
1163 }
1164
1165 scm *
1166 loop (scm *r, scm *e, scm *a)
1167 {
1168 #if 0//DEBUG
1169   printf ("\nc:loop e=");
1170   display (e);
1171   puts ("");
1172 #endif
1173   if (e == &scm_nil)
1174     return r;
1175   else if (eq_p (e, &scm_symbol_EOF) == &scm_t)
1176     return apply (cdr (assq (&scm_symbol_loop2, a)),
1177                   cons (&scm_unspecified, cons (&scm_t, cons (a, &scm_nil))), a);
1178   else if (eq_p (e, &scm_symbol_EOF2) == &scm_t)
1179     return r;
1180   else if (atom_p (e) == &scm_t)
1181     return loop (eval (e, a), readenv (a), a);
1182   else if (eq_p (car (e), &scm_symbol_define) == &scm_t)
1183     return loop (&scm_unspecified,
1184                  readenv (a),
1185                  cons (define (e, a), a));
1186   else if (eq_p (car (e), &scm_symbol_define_macro) == &scm_t)
1187     return loop (&scm_unspecified,
1188                  readenv (a),
1189                  cons (define_macro (e, a), a));
1190   else if (eq_p (car (e), &scm_symbol_set_x) == &scm_t)
1191     return loop (set_env_x (cadr (e), eval (caddr (e), a), a), readenv (a), a);
1192   return loop (eval (e, a), readenv (a), a);
1193 }
1194
1195 int
1196 main (int argc, char *argv[])
1197 {
1198   scm *a = mes_environment ();
1199   display (loop (&scm_unspecified, readenv (a), a));
1200   newline ();
1201   return 0;
1202 }
1203
1204 scm *
1205 apply (scm *fn, scm *x, scm *a)
1206 {
1207 #if DEBUG
1208   printf ("\nc:apply fn=");
1209   display (fn);
1210   printf (" x=");
1211   display (x);
1212   puts ("");
1213 #endif
1214   if (fn == &scm_apply_)
1215     return eval_ (x, a);
1216   return apply_ (fn, x, a);
1217 }
1218
1219 bool evalling_p = false;
1220
1221 scm *
1222 eval (scm *e, scm *a)
1223 {
1224 #if DEBUG
1225   printf ("\nc:eval e=");
1226   display (e);
1227   puts ("");
1228 #endif
1229
1230   scm *eval__ = assq (&scm_symbol_eval, a);
1231   assert (eval__ != &scm_f);
1232   eval__ = cdr (eval__);
1233   if (builtin_p (eval__) == &scm_t
1234       || evalling_p)
1235     return eval_ (e, a);
1236   evalling_p = true;
1237   scm *r = apply (eval__, cons (e, cons (a, &scm_nil)), a);
1238   evalling_p = false;
1239   return r;
1240 }