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