mes.c

   1 /* -*-comment-start: "//";comment-end:""-*-
   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 #define STRING_MAX 2048
  22 #define _GNU_SOURCE
  23 #include <assert.h>
  24 #include <ctype.h>
  25 #include <limits.h>
  26 #include <stdio.h>
  27 #include <string.h>
  28 #include <stdlib.h>
  29 #include <stdbool.h>
  30
  31 #define DEBUG 0
  32 #define QUASIQUOTE 1
  33
  34 enum type {CHAR, MACRO, NUMBER, PAIR, SCM, STRING, SYMBOL, REF, VALUES, VECTOR,
  35            FUNCTION0, FUNCTION1, FUNCTION2, FUNCTION3, FUNCTIONn};
  36 struct scm_t;
  37 typedef struct scm_t* (*function0_t) (void);
  38 typedef struct scm_t* (*function1_t) (struct scm_t*);
  39 typedef struct scm_t* (*function2_t) (struct scm_t*, struct scm_t*);
  40 typedef struct scm_t* (*function3_t) (struct scm_t*, struct scm_t*, struct scm_t*);
  41 typedef struct scm_t* (*functionn_t) (struct scm_t*);
  42
  43 typedef struct scm_t {
  44   enum type type;
  45   union {
  46     char const *name;
  47     struct scm_t* car;
  48     struct scm_t* ref;
  49     int length;
  50   };
  51   union {
  52     int value;
  53     function0_t function0;
  54     function1_t function1;
  55     function2_t function2;
  56     function3_t function3;
  57     functionn_t functionn;
  58     struct scm_t* cdr;
  59     struct scm_t* macro;
  60     struct scm_t* vector;
  61   };
  62 } scm;
  63
  64 scm temp_number = {NUMBER, .name="nul", .value=0};
  65
  66 #include "define.environment.h"
  67 #include "lib.environment.h"
  68 #include "math.environment.h"
  69 #include "mes.environment.h"
  70 #include "quasiquote.environment.h"
  71 #include "string.environment.h"
  72 #include "type.environment.h"
  73
  74 scm *display_ (FILE* f, scm *x);
  75 scm *display_helper (FILE*, scm*, bool, char const*, bool);
  76
  77 scm scm_nil = {SCM, "()"};
  78 scm scm_dot = {SCM, "."};
  79 scm scm_f = {SCM, "#f"};
  80 scm scm_t = {SCM, "#t"};
  81 scm scm_undefined = {SCM, "*undefined*"};
  82 scm scm_unspecified = {SCM, "*unspecified*"};
  83 scm scm_closure = {SCM, "*closure*"};
  84 scm scm_circular = {SCM, "*circular*"};
  85 #if BOOT
  86 scm scm_label = {
  87   SCM, "label"};
  88 #endif
  89 scm scm_lambda = {SCM, "lambda"};
  90
  91 scm symbol_begin = {SCM, "begin"};
  92 scm symbol_if = {SCM, "if"};
  93 scm symbol_define = {SCM, "define"};
  94 scm symbol_define_macro = {SCM, "define-macro"};
  95 scm symbol_set_x = {SCM, "set!"};
  96
  97 scm symbol_quote = {SYMBOL, "quote"};
  98 scm symbol_quasiquote = {SYMBOL, "quasiquote"};
  99 scm symbol_unquote = {SYMBOL, "unquote"};
 100 scm symbol_unquote_splicing = {SYMBOL, "unquote-splicing"};
 101
 102 scm symbol_sc_expand = {SYMBOL, "sc-expand"};
 103 scm symbol_syntax = {SYMBOL, "syntax"};
 104 scm symbol_quasisyntax = {SYMBOL, "quasisyntax"};
 105 scm symbol_unsyntax = {SYMBOL, "unsyntax"};
 106 scm symbol_unsyntax_splicing = {SYMBOL, "unsyntax-splicing"};
 107
 108 scm symbol_call_with_values = {SYMBOL, "call-with-values"};
 109 scm symbol_current_module = {SYMBOL, "current-module"};
 110
 111
 112 scm char_nul = {CHAR, .name="nul", .value=0};
 113 scm char_backspace = {CHAR, .name="backspace", .value=8};
 114 scm char_tab = {CHAR, .name="tab", .value=9};
 115 scm char_newline = {CHAR, .name="newline", .value=10};
 116 scm char_vt = {CHAR, .name="vt", .value=11};
 117 scm char_page = {CHAR, .name="page", .value=12};
 118 scm char_return = {CHAR, .name="return", .value=13};
 119 scm char_space = {CHAR, .name="space", .value=32};
 120
 121 // PRIMITIVES
 122
 123 scm *
 124 car (scm *x)
 125 {
 126   assert (x->type == PAIR);
 127   return x->car;
 128 }
 129
 130 scm *
 131 cdr (scm *x)
 132 {
 133   assert (x->type == PAIR);
 134   return x->cdr;
 135 }
 136
 137 scm *
 138 alloc (int n)
 139 {
 140   return (scm*)malloc (n * sizeof (scm));
 141 }
 142
 143 scm *
 144 cons (scm *x, scm *y)
 145 {
 146   scm *p = alloc (1);
 147   p->type = PAIR;
 148   p->car = x;
 149   p->cdr = y;
 150   return p;
 151 }
 152
 153 scm *
 154 eq_p (scm *x, scm *y)
 155 {
 156   return (x == y
 157           || (x->type == CHAR && y->type == CHAR
 158               && x->value == y->value)
 159           || (x->type == NUMBER && y->type == NUMBER
 160               && x->value == y->value))
 161     ? &scm_t : &scm_f;
 162 }
 163
 164 scm *
 165 set_car_x (scm *x, scm *e)
 166 {
 167   assert (x->type == PAIR);
 168   x->car = e;
 169   return &scm_unspecified;
 170 }
 171
 172 scm *
 173 set_cdr_x (scm *x, scm *e)
 174 {
 175   assert (x->type == PAIR);
 176   cache_invalidate (x->cdr);
 177   x->cdr = e;
 178   return &scm_unspecified;
 179 }
 180
 181 scm *
 182 set_env_x (scm *x, scm *e, scm *a)
 183 {
 184   cache_invalidate (x);
 185   return set_cdr_x (assq (x, a), e);
 186 }
 187
 188 scm *
 189 quote (scm *x)
 190 {
 191   return cons (&symbol_quote, x);
 192 }
 193
 194 scm *
 195 quasiquote (scm *x)
 196 {
 197   return cons (&symbol_quasiquote, x);
 198 }
 199
 200 scm *
 201 quasisyntax (scm *x)
 202 {
 203   return cons (&symbol_quasisyntax, x);
 204 }
 205
 206 scm *
 207 pairlis (scm *x, scm *y, scm *a)
 208 {
 209   if (x == &scm_nil)
 210     return a;
 211   if (pair_p (x) == &scm_f)
 212     return cons (cons (x, y), a);
 213   return cons (cons (car (x), car (y)),
 214                pairlis (cdr (x), cdr (y), a));
 215 }
 216
 217 scm *
 218 assq (scm *x, scm *a)
 219 {
 220   while (a != &scm_nil && eq_p (x, a->car->car) == &scm_f) a = a->cdr;
 221   return a != &scm_nil ? a->car : &scm_f;
 222 }
 223
 224 #define ENV_CACHE 1
 225 #define CACHE_SIZE 30
 226 #define ENV_HEAD 15
 227
 228 #if !ENV_CACHE
 229 scm *
 230 assq_ref_cache (scm *x, scm *a)
 231 {
 232   x = assq (x, a);
 233   if (x == &scm_f) return &scm_f;
 234   return x->cdr;
 235 }
 236 scm*cache_invalidate (scm*x){}
 237 scm*cache_invalidate_range (scm*p,scm*a){}
 238 scm*cache_save (scm*p){}
 239 scm*cache_lookup (scm*x){}
 240
 241 #else // ENV_CACHE
 242
 243 scm *env_cache_cars[CACHE_SIZE];
 244 scm *env_cache_cdrs[CACHE_SIZE];
 245 int cache_threshold = 0;
 246 scm *
 247 cache_save (scm *p)
 248 {
 249   int n = p->car->value;
 250   if (n < cache_threshold) return &scm_unspecified;
 251   int j = -1;
 252   for (int i=0; i < CACHE_SIZE; i++) {
 253     if (!env_cache_cars[i]) {
 254       j = i;
 255       break;
 256     }
 257     if (env_cache_cars[i] == p->car) return &scm_unspecified;
 258     if (n > env_cache_cars[i]->value) {
 259       n = env_cache_cars[i]->value;
 260       j = i;
 261     }
 262   }
 263   if (j >= 0) {
 264     cache_threshold = p->car->value;
 265     env_cache_cars[j] = p->car;
 266     env_cache_cdrs[j] = p->cdr;
 267   }
 268   return &scm_unspecified;
 269 }
 270
 271 scm *
 272 cache_lookup (scm *x)
 273 {
 274   for (int i=0; i < CACHE_SIZE; i++) {
 275     if (!env_cache_cars[i]) break;
 276     if (env_cache_cars[i] == x) return env_cache_cdrs[i];
 277   }
 278   return &scm_undefined;
 279 }
 280
 281 scm *
 282 cache_invalidate (scm *x)
 283 {
 284   for (int i=0; i < CACHE_SIZE; i++) {
 285     if (env_cache_cars[i] == x) {
 286       env_cache_cars[i] = 0;
 287       break;
 288     }
 289   }
 290   return &scm_unspecified;
 291 }
 292
 293 scm *
 294 cache_invalidate_range (scm *p, scm *a)
 295 {
 296   do {
 297     cache_invalidate (p->car->car);
 298     p = p->cdr;
 299   } while (p != a);
 300   return &scm_unspecified;
 301 }
 302
 303 scm *
 304 assq_ref_cache (scm *x, scm *a)
 305 {
 306   x->value++;
 307   scm *c = cache_lookup (x);
 308   if (c != &scm_undefined) return c;
 309   int i = 0;
 310   while (a != &scm_nil && x != a->car->car) {i++;a = a->cdr;}
 311   if (a == &scm_nil) return &scm_undefined;
 312   if (i>ENV_HEAD) cache_save (a->car);
 313   return a->car->cdr;
 314 }
 315 #endif // ENV_CACHE
 316
 317 scm *
 318 evlis_env (scm *m, scm *a)
 319 {
 320   if (m == &scm_nil) return &scm_nil;
 321   if (m->type != PAIR) return builtin_eval (m, a);
 322   scm *e = builtin_eval (car (m), a);
 323   return cons (e, evlis_env (cdr (m), a));
 324 }
 325
 326 scm *
 327 apply_env (scm *fn, scm *x, scm *a)
 328 {
 329   if (fn->type != PAIR)
 330     {
 331       if (fn == &scm_car) return x->car->car;
 332       if (fn == &scm_cdr) return x->car->cdr;
 333       if (builtin_p (fn) == &scm_t)
 334         return call (fn, x);
 335       if (eq_p (fn, &symbol_call_with_values) == &scm_t)
 336         return call (&scm_call_with_values_env, append2 (x, cons (a, &scm_nil)));
 337       if (fn == &symbol_current_module) return a;
 338     }
 339   else if (fn->car == &scm_lambda) {
 340     scm *p = pairlis (cadr (fn), x, a);
 341     cache_invalidate_range (p, a->cdr);
 342     scm *r = begin (cddr (fn), cons (cons (&scm_closure, p), p));
 343     cache_invalidate_range (p, a->cdr);
 344     return r;
 345   }
 346   else if (fn->car == &scm_closure) {
 347     scm *args = caddr (fn);
 348     scm *body = cdddr (fn);
 349     a = cdadr (fn);
 350     a = cdr (a);
 351     scm *p = pairlis (args, x, a);
 352     cache_invalidate_range (p, a->cdr);
 353     scm *r = begin (body, cons (cons (&scm_closure, p), p));
 354     cache_invalidate_range (p, a->cdr);
 355     return r;
 356   }
 357 #if BOOT
 358   else if (fn->car == &scm_label)
 359     return apply_env (caddr (fn), x, cons (cons (cadr (fn), caddr (fn)), a));
 360 #endif
 361   scm *efn = builtin_eval (fn, a);
 362   if (efn == &scm_f || efn == &scm_t) assert (!"apply bool");
 363   if (efn->type == NUMBER) assert (!"apply number");
 364   if (efn->type == STRING) assert (!"apply string");
 365   return apply_env (efn, x, a);
 366 }
 367
 368 scm *
 369 builtin_eval (scm *e, scm *a)
 370 {
 371   if (builtin_p (e) == &scm_t) return e;
 372   if (e->type == SCM) return e;
 373
 374   e = expand_macro_env (e, a);
 375
 376   if (e->type == SYMBOL) {
 377     scm *y = assq_ref_cache (e, a);
 378     if (y == &scm_undefined) {
 379       fprintf (stderr, "eval: unbound variable: %s\n", e->name);
 380       assert (!"unbound variable");
 381     }
 382     return y;
 383   }
 384   else if (e->type != PAIR)
 385     return e;
 386   else if (e->car->type != PAIR)
 387     {
 388       if (e->car == &symbol_quote)
 389         return cadr (e);
 390       if (e->car == &symbol_syntax)
 391         return e;
 392       if (e->car == &symbol_begin)
 393         return begin (e, a);
 394       if (e->car == &scm_lambda)
 395         return make_closure (cadr (e), cddr (e), assq (&scm_closure, a));
 396       if (e->car == &scm_closure)
 397         return e;
 398       if (e->car == &symbol_if)
 399         return builtin_if (cdr (e), a);
 400 #if !BOOT
 401       if (e->car == &symbol_define)
 402         return define (e, a);
 403       if (e->car == &symbol_define_macro)
 404         return define (e, a);
 405 #else
 406       if (e->car == &symbol_define) {
 407         fprintf (stderr, "C DEFINE: %s\n", e->cdr->car->type == SYMBOL
 408                  ? e->cdr->car->name
 409                  : e->cdr->car->car->name);
 410       }
 411       assert (e->car != &symbol_define);
 412       assert (e->car != &symbol_define_macro);
 413 #endif
 414       if (e->car == &symbol_set_x)
 415         return set_env_x (cadr (e), builtin_eval (caddr (e), a), a);
 416 #if QUASIQUOTE
 417       if (e->car == &symbol_unquote)
 418         return builtin_eval (cadr (e), a);
 419       if (e->car == &symbol_quasiquote)
 420         return eval_quasiquote (cadr (e), add_unquoters (a));
 421       if (e->car == &symbol_unsyntax)
 422         return builtin_eval (cadr (e), a);
 423       if (e->car == &symbol_quasisyntax)
 424         return eval_quasisyntax (cadr (e), add_unsyntaxers (a));
 425 #endif //QUASIQUOTE
 426     }
 427   return apply_env (e->car, evlis_env (e->cdr, a), a);
 428 }
 429
 430 scm *
 431 expand_macro_env (scm *e, scm *a)
 432 {
 433   scm *macro;
 434   if (e->type == PAIR
 435       && (macro = lookup_macro (e->car, a)) != &scm_f)
 436     return expand_macro_env (apply_env (macro, e->cdr, a), a);
 437   return e;
 438 }
 439
 440 scm *
 441 begin (scm *e, scm *a)
 442 {
 443   scm *r = &scm_unspecified;
 444   while (e != &scm_nil) {
 445     r = builtin_eval (e->car, a);
 446     e = e->cdr;
 447   }
 448   return r;
 449 }
 450
 451 scm *
 452 builtin_if (scm *e, scm *a)
 453 {
 454   if (builtin_eval (car (e), a) != &scm_f)
 455     return builtin_eval (cadr (e), a);
 456   if (cddr (e) != &scm_nil)
 457     return builtin_eval (caddr (e), a);
 458   return &scm_unspecified;
 459 }
 460
 461 //Helpers
 462
 463 scm *
 464 display (scm *x) ///((args . n))
 465 {
 466   scm *e = car (x);
 467   scm *p = cdr (x);
 468   int fd = 1;
 469   if (p->type == PAIR && p->car->type == NUMBER) fd = p->car->value;
 470   FILE *f = fd == 1 ? stdout : stderr;
 471   return display_helper (f, e, false, "", false);
 472 }
 473
 474 scm *
 475 display_ (FILE* f, scm *x)
 476 {
 477   return display_helper (f, x, false, "", false);
 478 }
 479
 480 scm *
 481 call (scm *fn, scm *x)
 482 {
 483   if (fn->type == FUNCTION0)
 484     return fn->function0 ();
 485   if (x->car->type == VALUES)
 486     x = cons (x->car->cdr->car, &scm_nil);
 487   if (fn->type == FUNCTION1)
 488     return fn->function1 (car (x));
 489   if (fn->type == FUNCTION2)
 490     return fn->function2 (car (x), cadr (x));
 491   if (fn->type == FUNCTION3)
 492     return fn->function3 (car (x), cadr (x), caddr (x));
 493   if (fn->type == FUNCTIONn)
 494     return fn->functionn (x);
 495   return &scm_unspecified;
 496 }
 497
 498 scm *
 499 append2 (scm *x, scm *y)
 500 {
 501   if (x == &scm_nil) return y;
 502   assert (x->type == PAIR);
 503   return cons (car (x), append2 (cdr (x), y));
 504 }
 505
 506 scm *
 507 append (scm *x) ///((args . n))
 508  {
 509   if (x == &scm_nil) return &scm_nil;
 510   return append2 (car (x), append (cdr (x)));
 511  }
 512
 513 scm *
 514 make_char (int x)
 515 {
 516   scm *p = alloc (1);
 517   p->type = CHAR;
 518   p->value = x;
 519   return p;
 520 }
 521
 522 scm *
 523 make_macro (scm *name, scm *x)
 524 {
 525   scm *p = alloc (1);
 526   p->type = MACRO;
 527   p->macro = x;
 528   p->name = name->name;
 529   return p;
 530 }
 531
 532 scm *
 533 make_number (int x)
 534 {
 535   scm *p = alloc (1);
 536   p->type = NUMBER;
 537   p->value = x;
 538   return p;
 539 }
 540
 541 scm *
 542 make_ref (scm *x)
 543 {
 544   scm *p = alloc (1);
 545   p->type = REF;
 546   p->ref = x;
 547   return p;
 548 }
 549
 550 scm *
 551 make_string (char const *s)
 552 {
 553   scm *p = alloc (1);
 554   p->type = STRING;
 555   p->name = strdup (s);
 556   return p;
 557 }
 558
 559 scm *symbols = 0;
 560
 561 scm *
 562 internal_lookup_symbol (char const *s)
 563 {
 564   scm *x = symbols;
 565   while (x && strcmp (s, x->car->name)) x = x->cdr;
 566   if (x) x = x->car;
 567   return x;
 568 }
 569
 570 scm *
 571 internal_make_symbol (char const *s)
 572 {
 573   scm *x = alloc (1);
 574   x->type = SYMBOL;
 575   x->name = strdup (s);
 576   x->value = 0;
 577   symbols = cons (x, symbols);
 578   return x;
 579 }
 580
 581 scm *
 582 make_symbol (char const *s)
 583 {
 584   scm *x = internal_lookup_symbol (s);
 585   return x ? x : internal_make_symbol (s);
 586 }
 587
 588 scm *
 589 make_vector (scm *n)
 590 {
 591   scm *p = alloc (1);
 592   p->type = VECTOR;
 593   p->length = n->value;
 594   p->vector = alloc (n->value);
 595   for (int i=0; i<n->value; i++) p->vector[i] = *vector_entry (&scm_unspecified);
 596   return p;
 597 }
 598
 599 scm *
 600 values (scm *x) ///((args . n))
 601 {
 602   scm *v = cons (0, x);
 603   v->type = VALUES;
 604   return v;
 605 }
 606
 607 scm *
 608 call_with_values_env (scm *producer, scm *consumer, scm *a)
 609 {
 610   scm *v = apply_env (producer, &scm_nil, a);
 611   if (v->type == VALUES)
 612     v = v->cdr;
 613   return apply_env (consumer, v, a);
 614 }
 615
 616 scm *
 617 vector_length (scm *x)
 618 {
 619   assert (x->type == VECTOR);
 620   return make_number (x->length);
 621 }
 622
 623 scm *
 624 vector_ref (scm *x, scm *i)
 625 {
 626   assert (x->type == VECTOR);
 627   assert (i->value < x->length);
 628   scm *e = &x->vector[i->value];
 629   if (e->type == REF) e = e->ref;
 630   if (e->type == CHAR) e = make_char (e->value);
 631   if (e->type == NUMBER) e = make_number (e->value);
 632   return e;
 633 }
 634
 635 scm *
 636 vector_entry (scm *x) {
 637   if (x->type == PAIR || x->type == SCM || x->type == STRING || x->type == SYMBOL || x->type == VECTOR) x = make_ref (x);
 638   return x;
 639 }
 640
 641 scm *
 642 vector_set_x (scm *x, scm *i, scm *e)
 643 {
 644   assert (x->type == VECTOR);
 645   assert (i->value < x->length);
 646   x->vector[i->value] = *vector_entry (e);
 647   return &scm_unspecified;
 648 }
 649
 650 scm *
 651 lookup (char const *s, scm *a)
 652 {
 653   if (isdigit (*s) || (*s == '-' && isdigit (*(s+1))))
 654     return make_number (atoi (s));
 655
 656   scm *x;
 657   x = internal_lookup_symbol (s);
 658   if (x) return x;
 659
 660   if (*s == '\'') return &symbol_quote;
 661   if (*s == '`') return &symbol_quasiquote;
 662   if (*s == ',' && *(s+1) == '@') return &symbol_unquote_splicing;
 663   if (*s == ',') return &symbol_unquote;
 664
 665   if (*s == '#' && *(s+1) == '\'') return &symbol_syntax;
 666   if (*s == '#' && *(s+1) == '`') return &symbol_quasisyntax;
 667   if (*s == '#' && *(s+1) == ',' && *(s+2) == '@') return &symbol_unsyntax_splicing;
 668   if (*s == '#' && *(s+1) == ',') return &symbol_unsyntax;
 669
 670   if (!strcmp (s, "EOF")) {
 671     fprintf (stderr, "mes: got EOF\n");
 672     return &scm_nil; // `EOF': eval program, which may read stdin
 673   }
 674
 675   return internal_make_symbol (s);
 676 }
 677
 678 scm *
 679 lookup_char (int c, scm *a)
 680 {
 681   char buf[2];
 682   buf[0] = c;
 683   buf[1] = 0;
 684   return lookup (buf, a);
 685 }
 686
 687 scm *
 688 list_to_vector (scm *x)
 689 {
 690   temp_number.value = length (x)->value;
 691   scm *v = make_vector (&temp_number);
 692   scm *p = v->vector;
 693   while (x != &scm_nil)
 694     {
 695       *p++ = *vector_entry (car (x));
 696       x = cdr (x);
 697     }
 698   return v;
 699 }
 700
 701 scm *
 702 newline (scm *p) ///((args . n))
 703 {
 704   int fd = 1;
 705   if (p->type == PAIR && p->car->type == NUMBER) fd = p->car->value;
 706   FILE *f = fd == 1 ? stdout : stderr;
 707   fputs ("\n", f);
 708   return &scm_unspecified;
 709 }
 710
 711 scm *
 712 force_output (scm *p) ///((args . n))
 713 {
 714   int fd = 1;
 715   if (p->type == PAIR && p->car->type == NUMBER) fd = p->car->value;
 716   FILE *f = fd == 1 ? stdout : stderr;
 717   fflush (f);
 718 }
 719
 720 scm *
 721 display_helper (FILE* f, scm *x, bool cont, char const *sep, bool quote)
 722 {
 723   scm *r;
 724   fprintf (f, "%s", sep);
 725   if (x->type == CHAR && x->value == char_nul.value) fprintf (f, "#\\%s", char_nul.name);
 726   else if (x->type == CHAR && x->value == char_backspace.value) fprintf (f, "#\\%s", char_backspace.name);
 727   else if (x->type == CHAR && x->value == char_tab.value) fprintf (f, "#\\%s", char_tab.name);
 728   else if (x->type == CHAR && x->value == char_newline.value) fprintf (f, "#\\%s", char_newline.name);
 729   else if (x->type == CHAR && x->value == char_vt.value) fprintf (f, "#\\%s", char_vt.name);
 730   else if (x->type == CHAR && x->value == char_page.value) fprintf (f, "#\\%s", char_page.name);
 731   else if (x->type == CHAR && x->value == char_return.value) fprintf (f, "#\\%s", char_return.name);
 732   else if (x->type == CHAR && x->value == char_space.value) fprintf (f, "#\\%s", char_space.name);
 733   else if (x->type == CHAR) fprintf (f, "#\\%c", x->value);
 734   else if (x->type == MACRO) {
 735     fprintf (f, "(*macro* ");
 736     display_helper (f, x->macro, cont, sep, quote);
 737     fprintf (f, ")");
 738   }
 739   else if (x->type == NUMBER) fprintf (f, "%d", x->value);
 740   else if (x->type == PAIR) {
 741     if (car (x) == &scm_circular) {
 742       fprintf (f, "(*circ* . #-1#)");
 743       return &scm_unspecified;
 744     }
 745     if (car (x) == &scm_closure) {
 746       fprintf (f, "(*closure* . #-1#)");
 747       return &scm_unspecified;
 748     }
 749     if (car (x) == &scm_quote) {
 750       fprintf (f, "'");
 751       return display_helper (f, car (cdr (x)), cont, "", true);
 752     }
 753     if (!cont) fprintf (f, "(");
 754     display_ (f, car (x));
 755     if (cdr (x)->type == PAIR)
 756       display_helper (f, cdr (x), true, " ", false);
 757     else if (cdr (x) != &scm_nil) {
 758       fprintf (f, " . ");
 759       display_ (f, cdr (x));
 760     }
 761     if (!cont) fprintf (f, ")");
 762   }
 763   else if (x->type == VECTOR) {
 764     fprintf (f, "#(", x->length);
 765     for (int i = 0; i < x->length; i++) {
 766       if (x->vector[i].type == VECTOR
 767           || (x->vector[i].type == REF
 768               && x->vector[i].ref->type == VECTOR))
 769         fprintf (f, "%s#(...)", i ? " " : "");
 770       else
 771         display_helper (f, &x->vector[i], false, i ? " " : "", false);
 772     }
 773     fprintf (f, ")");
 774   }
 775   else if (x->type == REF) display_helper (f, x->ref, cont, "", true);
 776   else if (builtin_p (x) == &scm_t) fprintf (f, "#<procedure %s>", x->name);
 777   else if (pair_p (x) == &scm_f) fprintf (f, "%s", x->name);
 778
 779   return &scm_unspecified;
 780 }
 781
 782 // READ
 783
 784 int
 785 ungetchar (int c)
 786 {
 787   return ungetc (c, stdin);
 788 }
 789
 790 int
 791 peekchar ()
 792 {
 793   int c = getchar ();
 794   ungetchar (c);
 795   return c;
 796 }
 797
 798 scm *
 799 peek_char ()
 800 {
 801   return make_char (peekchar ());
 802 }
 803
 804 scm *
 805 read_char ()
 806 {
 807   return make_char (getchar ());
 808 }
 809
 810 scm *
 811 write_char (scm *x) ///((args . n))
 812 {
 813   scm *c = car (x);
 814   scm *p = cdr (x);
 815   int fd = 1;
 816   if (p->type == PAIR && p->car->type == NUMBER) fd = p->car->value;
 817   FILE *f = fd == 1 ? stdout : stderr;
 818   assert (c->type == NUMBER || c->type == CHAR);
 819   fputc (c->value, f);
 820   return c;
 821 }
 822
 823 scm *
 824 unget_char (scm *c)
 825 {
 826   assert (c->type == NUMBER || c->type == CHAR);
 827   ungetchar (c->value);
 828   return c;
 829 }
 830
 831 int
 832 readcomment (int c)
 833 {
 834   if (c == '\n') return c;
 835   return readcomment (getchar ());
 836 }
 837
 838 int
 839 readblock (int c)
 840 {
 841   if (c == '!' && peekchar () == '#') return getchar ();
 842   return readblock (getchar ());
 843 }
 844
 845 scm *
 846 readword (int c, char *w, scm *a)
 847 {
 848   if (c == EOF && !w) return &scm_nil;
 849   if (c == '\n' && !w) return readword (getchar (), w, a);
 850   if (c == '\n' && *w == '.' && w[1] == 0) return &scm_dot;
 851   if (c == EOF || c == '\n') return lookup (w, a);
 852   if (c == ' ') return readword ('\n', w, a);
 853   if (c == '"' && !w) return readstring ();
 854   if (c == '"') {ungetchar (c); return lookup (w, a);}
 855   if (c == '(' && !w) return readlist (a);
 856   if (c == '(') {ungetchar (c); return lookup (w, a);}
 857   if (c == ')' && !w) {ungetchar (c); return &scm_nil;}
 858   if (c == ')') {ungetchar (c); return lookup (w, a);}
 859   if (c == ',' && peekchar () == '@') {getchar (); return cons (lookup (",@", a),
 860                                                                    cons (readword (getchar (), w, a),
 861                                                                          &scm_nil));}
 862   if ((c == '\''
 863        || c == '`'
 864        || c == ',')
 865       && !w) {return cons (lookup_char (c, a),
 866                                      cons (readword (getchar (), w, a),
 867                                            &scm_nil));}
 868   if (c == '#' && peekchar () == ',' && !w) {
 869     getchar ();
 870     if (peekchar () == '@'){getchar (); return cons (lookup ("#,@", a),
 871                                                      cons (readword (getchar (), w, a),
 872                                                            &scm_nil));}
 873     return cons (lookup ("#,", a), cons (readword (getchar (), w, a), &scm_nil));
 874   }
 875   if (c == '#'
 876      && (peekchar () == '\''
 877          || peekchar () == '`')
 878      && !w) {char buf[3] = "#"; buf[1] = getchar (); return cons (lookup (buf, a),
 879                           cons (readword (getchar (), w, a),
 880                                 &scm_nil));}
 881   if (c == ';') {readcomment (c); return readword ('\n', w, a);}
 882   if (c == '#' && peekchar () == 'x') {getchar (); return read_hex ();}
 883   if (c == '#' && peekchar () == '\\') {getchar (); return read_character ();}
 884   if (c == '#' && !w && peekchar () == '(') {getchar (); return list_to_vector (readlist (a));}
 885   if (c == '#' && peekchar () == '(') {ungetchar (c); return lookup (w, a);}
 886   if (c == '#' && peekchar () == '!') {getchar (); readblock (getchar ()); return readword (getchar (), w, a);}
 887   char buf[STRING_MAX] = {0};
 888   char ch = c;
 889   char *p = w ? w + strlen (w) : buf;
 890   *p = ch;
 891   *(p+1) = 0;
 892   return readword (getchar (), w ? w : buf, a);
 893 }
 894
 895 scm *
 896 read_hex ()
 897 {
 898   int n = 0;
 899   int c = peekchar ();
 900   while ((c >= '0' && c <= '9')
 901          || (c >= 'A' && c <= 'F')
 902          || (c >= 'a' && c <= 'f')) {
 903     n <<= 4;
 904     if (c >= 'a') n += c - 'a' + 10;
 905     else if (c >= 'A') n += c - 'A' + 10;
 906     else n+= c - '0';
 907     getchar ();
 908     c = peekchar ();
 909   }
 910   return make_number (n);
 911 }
 912
 913 scm *
 914 read_character ()
 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[STRING_MAX];
 928     char *p = buf;
 929     *p++ = c;
 930     while (peekchar () >= 'a' && peekchar () <= 'z') {
 931       *p++ = getchar ();
 932     }
 933     *p = 0;
 934     if (!strcmp (buf, char_nul.name)) c = char_nul.value;
 935     else if (!strcmp (buf, char_backspace.name)) c = char_backspace.value;
 936     else if (!strcmp (buf, char_tab.name)) c = char_tab.value;
 937     else if (!strcmp (buf, char_newline.name)) c = char_newline.value;
 938     else if (!strcmp (buf, char_vt.name)) c = char_vt.value;
 939     else if (!strcmp (buf, char_page.name)) c = char_page.value;
 940     else if (!strcmp (buf, char_return.name)) c = char_return.value;
 941     else if (!strcmp (buf, char_space.name)) c = char_space.value;
 942     else {
 943       fprintf (stderr, "char not supported: %s\n", buf);
 944       assert (!"char not supported");
 945     }
 946   }
 947   return make_char (c);
 948 }
 949
 950 scm *
 951 readstring ()
 952 {
 953   char buf[STRING_MAX];
 954   char *p = buf;
 955   int c = getchar ();
 956   while (true) {
 957     if (c == '"') break;
 958     if (c == '\\' && peekchar () == '"') *p++ = getchar ();
 959     else if (c == '\\' && peekchar () == 'n') {getchar (); *p++ = '\n';}
 960     else if (c == EOF) assert (!"EOF in string");
 961     else *p++ = c;
 962     c = getchar ();
 963   }
 964   *p = 0;
 965   return make_string (buf);
 966 }
 967
 968 int
 969 eat_whitespace (int c)
 970 {
 971   while (c == ' ' || c == '\t' || c == '\n') c = getchar ();
 972   if (c == ';') return eat_whitespace (readcomment (c));
 973   if (c == '#' && peekchar () == '!') {getchar (); readblock (getchar ()); return eat_whitespace (getchar ());}
 974   return c;
 975 }
 976
 977 scm *
 978 readlist (scm *a)
 979 {
 980   int c = getchar ();
 981   c = eat_whitespace (c);
 982   if (c == ')') return &scm_nil;
 983   scm *w = readword (c, 0, a);
 984   if (w == &scm_dot)
 985     return car (readlist (a));
 986   return cons (w, readlist (a));
 987 }
 988
 989 scm *
 990 read_env (scm *a)
 991 {
 992   return readword (getchar (), 0, a);
 993 }
 994
 995 scm *
 996 add_environment (scm *a, char const *name, scm *x)
 997 {
 998   return cons (cons (make_symbol (name), x), a);
 999 }
1000
1001 scm *
1002 mes_environment () ///((internal))
1003 {
1004   scm *a = &scm_nil;
1005
1006   #include "mes.symbols.i"
1007
1008 #if BOOT
1009   symbols = cons (&scm_label, symbols);
1010   a = cons (cons (&scm_label, &scm_t), a);
1011 #endif
1012
1013 #include "string.environment.i"
1014 #include "math.environment.i"
1015 #include "lib.environment.i"
1016 #include "mes.environment.i"
1017 #include "define.environment.i"
1018 #include "type.environment.i"
1019
1020   a = cons (cons (&scm_closure, a), a);
1021   return a;
1022 }
1023
1024 scm *
1025 make_lambda (scm *args, scm *body)
1026 {
1027   return cons (&scm_lambda, cons (args, body));
1028 }
1029
1030 scm *
1031 make_closure (scm *args, scm *body, scm *a)
1032 {
1033   return cons (&scm_closure, cons (cons (&scm_circular, a), cons (args, body)));
1034 }
1035
1036 scm *
1037 lookup_macro (scm *x, scm *a)
1038 {
1039   if (x->type != SYMBOL) return &scm_f;
1040   scm *m = assq_ref_cache (x, a);
1041   if (macro_p (m) == &scm_t) return m->macro;
1042   return &scm_f;
1043 }
1044
1045 scm *
1046 read_file (scm *e, scm *a)
1047 {
1048   if (e == &scm_nil) return e;
1049 #if DEBUG
1050   scm *x = cons (e, read_file (read_env (a), a));
1051   display_ (stderr, x);
1052 #else
1053   return cons (e, read_file (read_env (a), a));
1054 #endif
1055 }
1056
1057 #include "type.c"
1058 #include "define.c"
1059 #include "lib.c"
1060 #include "math.c"
1061 #include "quasiquote.c"
1062 #include "string.c"
1063
1064 int
1065 main (int argc, char *argv[])
1066 {
1067   if (argc > 1 && !strcmp (argv[1], "--help")) return puts ("Usage: mes < FILE\n");
1068   if (argc > 1 && !strcmp (argv[1], "--version")) return puts ("Mes 0.1\n");
1069   scm *a = mes_environment ();
1070   display_ (stderr, begin (read_file (read_env (a), a), a));
1071   fputs ("", stderr);
1072   return 0;
1073 }