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 BUILTIN_QUASIQUOTE 1 // 6x speedup for mescc
  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 "mes.environment.h"
  66
  67 scm *display_ (FILE* f, scm *x);
  68 scm *display_helper (FILE*, scm*, bool, char const*, bool);
  69
  70 scm scm_nil = {SCM, "()"};
  71 scm scm_dot = {SCM, "."};
  72 scm scm_f = {SCM, "#f"};
  73 scm scm_t = {SCM, "#t"};
  74 scm scm_undefined = {SCM, "*undefined*"};
  75 scm scm_unspecified = {SCM, "*unspecified*"};
  76 scm scm_closure = {SCM, "*closure*"};
  77 scm scm_circular = {SCM, "*circular*"};
  78 #if BOOT
  79 scm scm_label = {
  80   SCM, "label"};
  81 #endif
  82 scm scm_lambda = {SCM, "lambda"};
  83
  84 scm symbol_begin = {SCM, "begin"};
  85 scm symbol_if = {SCM, "if"};
  86 scm symbol_define = {SCM, "define"};
  87 scm symbol_define_macro = {SCM, "define-macro"};
  88 scm symbol_set_x = {SCM, "set!"};
  89
  90 scm symbol_quote = {SYMBOL, "quote"};
  91 scm symbol_quasiquote = {SYMBOL, "quasiquote"};
  92 scm symbol_unquote = {SYMBOL, "unquote"};
  93 scm symbol_unquote_splicing = {SYMBOL, "unquote-splicing"};
  94
  95 scm symbol_sc_expand = {SYMBOL, "sc-expand"};
  96 scm symbol_syntax = {SYMBOL, "syntax"};
  97 scm symbol_quasisyntax = {SYMBOL, "quasisyntax"};
  98 scm symbol_unsyntax = {SYMBOL, "unsyntax"};
  99 scm symbol_unsyntax_splicing = {SYMBOL, "unsyntax-splicing"};
 100
 101 scm symbol_call_with_values = {SYMBOL, "call-with-values"};
 102 scm symbol_current_module = {SYMBOL, "current-module"};
 103
 104
 105 scm char_nul = {CHAR, .name="nul", .value=0};
 106 scm char_backspace = {CHAR, .name="backspace", .value=8};
 107 scm char_tab = {CHAR, .name="tab", .value=9};
 108 scm char_newline = {CHAR, .name="newline", .value=10};
 109 scm char_vt = {CHAR, .name="vt", .value=11};
 110 scm char_page = {CHAR, .name="page", .value=12};
 111 scm char_return = {CHAR, .name="return", .value=13};
 112 scm char_space = {CHAR, .name="space", .value=32};
 113
 114 // PRIMITIVES
 115
 116 #define ATOM_P(x) (x->type == PAIR ? &scm_f : &scm_t)
 117 scm *
 118 atom_p (scm *x)
 119 {
 120   return ATOM_P(x);
 121 }
 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 cons (scm *x, scm *y)
 139 {
 140   scm *p = (scm*)malloc (sizeof (scm));
 141   p->type = PAIR;
 142   p->car = x;
 143   p->cdr = y;
 144   return p;
 145 }
 146
 147 #define EQ_P(x, y)\
 148   ((x == y                                              \
 149     || (x->type == CHAR && y->type == CHAR              \
 150         && x->value == y->value)                        \
 151     || (x->type == NUMBER && y->type == NUMBER          \
 152         && x->value == y->value))                       \
 153    ? &scm_t : &scm_f)
 154
 155 scm *
 156 eq_p (scm *x, scm *y)
 157 {
 158   return EQ_P (x, y);
 159 }
 160
 161 scm *
 162 macro_p (scm *x)
 163 {
 164   return x->type == MACRO ? &scm_t : &scm_f;
 165 }
 166
 167 scm *
 168 null_p (scm *x)
 169 {
 170   return x == &scm_nil ? &scm_t : &scm_f;
 171 }
 172
 173 #define PAIR_P(x) (x->type == PAIR ? &scm_t : &scm_f)
 174 scm *
 175 pair_p (scm *x)
 176 {
 177   return PAIR_P(x);
 178 }
 179
 180 scm *
 181 set_car_x (scm *x, scm *e)
 182 {
 183   assert (x->type == PAIR);
 184   x->car = e;
 185   return &scm_unspecified;
 186 }
 187
 188 scm *
 189 set_cdr_x (scm *x, scm *e)
 190 {
 191   assert (x->type == PAIR);
 192   cache_invalidate (x->cdr);
 193   x->cdr = e;
 194   return &scm_unspecified;
 195 }
 196
 197 scm *
 198 set_env_x (scm *x, scm *e, scm *a)
 199 {
 200   cache_invalidate (x);
 201   return set_cdr_x (assq (x, a), e);
 202 }
 203
 204 scm *
 205 quote (scm *x)
 206 {
 207   return cons (&symbol_quote, x);
 208 }
 209
 210 scm *
 211 quasiquote (scm *x)
 212 {
 213   return cons (&symbol_quasiquote, x);
 214 }
 215
 216 scm *
 217 quasisyntax (scm *x)
 218 {
 219   return cons (&symbol_quasisyntax, x);
 220 }
 221
 222 #if BUILTIN_QUASIQUOTE
 223 scm *
 224 unquote (scm *x) ///((no-environment))
 225 {
 226   return cons (&symbol_unquote, x);
 227 }
 228
 229 scm *
 230 unquote_splicing (scm *x) ///((no-environment))
 231 {
 232   return cons (&symbol_unquote_splicing, x);
 233 }
 234
 235 scm *
 236 syntax (scm *x)
 237 {
 238   return cons (&symbol_syntax, x);
 239 }
 240
 241 scm *
 242 unsyntax (scm *x) ///((no-environment))
 243 {
 244   return cons (&symbol_unsyntax, x);
 245 }
 246
 247 scm *
 248 unsyntax_splicing (scm *x) ///((no-environment))
 249 {
 250   return cons (&symbol_unsyntax_splicing, x);
 251 }
 252 #endif // BUILTIN_QUASIQUOTE
 253
 254 //Library functions
 255
 256 // Derived, non-primitives
 257 scm *caar (scm *x) {return car (car (x));}
 258 scm *cadr (scm *x) {return car (cdr (x));}
 259 scm *cdar (scm *x) {return cdr (car (x));}
 260 scm *cddr (scm *x) {return cdr (cdr (x));}
 261 scm *caaar (scm *x) {return car (car (car (x)));}
 262 scm *caadr (scm *x) {return car (car (cdr (x)));}
 263 scm *caddr (scm *x) {return car (cdr (cdr (x)));}
 264 scm *cdadr (scm *x) {return cdr (car (cdr (x)));}
 265 scm *cadar (scm *x) {return car (cdr (car (x)));}
 266 scm *cddar (scm *x) {return cdr (cdr (car (x)));}
 267 scm *cdddr (scm *x) {return cdr (cdr (cdr (x)));}
 268
 269 scm *
 270 pairlis (scm *x, scm *y, scm *a)
 271 {
 272   if (x == &scm_nil)
 273     return a;
 274   if (atom_p (x) == &scm_t)
 275     return cons (cons (x, y), a);
 276   return cons (cons (car (x), car (y)),
 277                pairlis (cdr (x), cdr (y), a));
 278 }
 279
 280 scm *
 281 assq (scm *x, scm *a)
 282 {
 283   while (a != &scm_nil && EQ_P (x, a->car->car) == &scm_f) a = a->cdr;
 284   return a != &scm_nil ? a->car : &scm_f;
 285 }
 286
 287 #define ENV_CACHE 1
 288 #define CACHE_SIZE 30
 289 #define ENV_HEAD 15
 290
 291 #if !ENV_CACHE
 292 scm *
 293 assq_ref_cache (scm *x, scm *a)
 294 {
 295   x = assq (x, a);
 296   if (x == &scm_f) return &scm_f;
 297   return x->cdr;
 298 }
 299 scm*cache_invalidate (scm*x){}
 300 scm*cache_invalidate_range (scm*p,scm*a){}
 301 scm*cache_save (scm*p){}
 302 scm*cache_lookup (scm*x){}
 303
 304 #else // ENV_CACHE
 305
 306 scm *env_cache_cars[CACHE_SIZE];
 307 scm *env_cache_cdrs[CACHE_SIZE];
 308 int cache_threshold = 0;
 309 scm *
 310 cache_save (scm *p)
 311 {
 312   int n = p->car->value;
 313   if (n < cache_threshold) return &scm_unspecified;
 314   int j = -1;
 315   for (int i=0; i < CACHE_SIZE; i++) {
 316     if (!env_cache_cars[i]) {
 317       j = i;
 318       break;
 319     }
 320     if (env_cache_cars[i] == p->car) return &scm_unspecified;
 321     if (n > env_cache_cars[i]->value) {
 322       n = env_cache_cars[i]->value;
 323       j = i;
 324     }
 325   }
 326   if (j >= 0) {
 327     cache_threshold = p->car->value;
 328     env_cache_cars[j] = p->car;
 329     env_cache_cdrs[j] = p->cdr;
 330   }
 331   return &scm_unspecified;
 332 }
 333
 334 scm *
 335 cache_lookup (scm *x)
 336 {
 337   for (int i=0; i < CACHE_SIZE; i++) {
 338     if (!env_cache_cars[i]) break;
 339     if (env_cache_cars[i] == x) return env_cache_cdrs[i];
 340   }
 341   return &scm_undefined;
 342 }
 343
 344 scm *
 345 cache_invalidate (scm *x)
 346 {
 347   for (int i=0; i < CACHE_SIZE; i++) {
 348     if (env_cache_cars[i] == x) {
 349       env_cache_cars[i] = 0;
 350       break;
 351     }
 352   }
 353   return &scm_unspecified;
 354 }
 355
 356 scm *
 357 cache_invalidate_range (scm *p, scm *a)
 358 {
 359   do {
 360     cache_invalidate (p->car->car);
 361     p = p->cdr;
 362   } while (p != a);
 363   return &scm_unspecified;
 364 }
 365
 366 scm *
 367 assq_ref_cache (scm *x, scm *a)
 368 {
 369   x->value++;
 370   scm *c = cache_lookup (x);
 371   if (c != &scm_undefined) return c;
 372   int i = 0;
 373   while (a != &scm_nil && x != a->car->car) {i++;a = a->cdr;}
 374   if (a == &scm_nil) return &scm_undefined;
 375   if (i>ENV_HEAD) cache_save (a->car);
 376   return a->car->cdr;
 377 }
 378 #endif // ENV_CACHE
 379
 380 scm *
 381 evlis_env (scm *m, scm *a)
 382 {
 383   if (m == &scm_nil) return &scm_nil;
 384   if (m->type != PAIR) return builtin_eval (m, a);
 385   scm *e = builtin_eval (car (m), a);
 386   return cons (e, evlis_env (cdr (m), a));
 387 }
 388
 389 scm *
 390 apply_env (scm *fn, scm *x, scm *a)
 391 {
 392   if (fn->type != PAIR)
 393     {
 394       if (fn == &scm_car) return x->car->car;
 395       if (fn == &scm_cdr) return x->car->cdr;
 396       if (builtin_p (fn) == &scm_t)
 397         return call (fn, x);
 398       if (eq_p (fn, &symbol_call_with_values) == &scm_t)
 399         return call (&scm_call_with_values_env, append2 (x, cons (a, &scm_nil)));
 400       if (fn == &symbol_current_module) return a;
 401     }
 402   else if (fn->car == &scm_lambda) {
 403     scm *p = pairlis (cadr (fn), x, a);
 404     cache_invalidate_range (p, a->cdr);
 405     scm *r = builtin_eval (cons (&symbol_begin, cddr (fn)), cons (cons (&scm_closure, p), p));
 406     cache_invalidate_range (p, a->cdr);
 407     return r;
 408   }
 409   else if (fn->car == &scm_closure) {
 410     scm *args = caddr (fn);
 411     scm *body = cdddr (fn);
 412     a = cdadr (fn);
 413     a = cdr (a);
 414     scm *p = pairlis (args, x, a);
 415     cache_invalidate_range (p, a->cdr);
 416     scm *r = builtin_eval (cons (&symbol_begin, body), cons (cons (&scm_closure, p), p));
 417     cache_invalidate_range (p, a->cdr);
 418     return r;
 419   }
 420 #if BOOT
 421   else if (fn->car == &scm_label)
 422     return apply_env (caddr (fn), x, cons (cons (cadr (fn), caddr (fn)), a));
 423 #endif
 424   scm *efn = builtin_eval (fn, a);
 425   if (efn == &scm_f || efn == &scm_t) assert (!"apply bool");
 426   if (efn->type == NUMBER) assert (!"apply number");
 427   if (efn->type == STRING) assert (!"apply string");
 428   return apply_env (efn, x, a);
 429 }
 430
 431 scm *
 432 builtin_eval (scm *e, scm *a)
 433 {
 434   if (builtin_p (e) == &scm_t) return e;
 435   if (internal_p (e) == &scm_t) return e;
 436
 437   e = expand_macro_env (e, a);
 438
 439   if (e->type == SYMBOL) {
 440     scm *y = assq_ref_cache (e, a);
 441     if (y == &scm_undefined) {
 442       fprintf (stderr, "eval: unbound variable: %s\n", e->name);
 443       assert (!"unbound variable");
 444     }
 445     return y;
 446   }
 447   else if (e->type != PAIR)
 448     return e;
 449   else if (e->car->type != PAIR)
 450     {
 451       if (e->car == &symbol_quote)
 452         return cadr (e);
 453       if (e->car == &symbol_syntax)
 454         return e;
 455       if (e->car == &symbol_begin)
 456         return begin (e, a);
 457       if (e->car == &scm_lambda)
 458         return make_closure (cadr (e), cddr (e), assq (&scm_closure, a));
 459       if (e->car == &scm_closure)
 460         return e;
 461       if (e->car == &symbol_if)
 462         return builtin_if (cdr (e), a);
 463 #if !BOOT
 464       if (e->car == &symbol_define)
 465         return define (e, a);
 466       if (e->car == &symbol_define_macro)
 467         return define (e, a);
 468 #else
 469       if (e->car == &symbol_define) {
 470         fprintf (stderr, "C DEFINE: %s\n", e->cdr->car->type == SYMBOL
 471                  ? e->cdr->car->name
 472                  : e->cdr->car->car->name);
 473       }
 474       assert (e->car != &symbol_define);
 475       assert (e->car != &symbol_define_macro);
 476 #endif
 477       if (e->car == &symbol_set_x)
 478         return set_env_x (cadr (e), builtin_eval (caddr (e), a), a);
 479 #if BUILTIN_QUASIQUOTE
 480       if (e->car == &symbol_unquote)
 481         return builtin_eval (cadr (e), a);
 482       if (e->car == &symbol_quasiquote)
 483         return eval_quasiquote (cadr (e), add_unquoters (a));
 484       if (e->car == &symbol_unsyntax)
 485         return builtin_eval (cadr (e), a);
 486       if (e->car == &symbol_quasisyntax)
 487         return eval_quasisyntax (cadr (e), add_unsyntaxers (a));
 488 #endif //BUILTIN_QUASIQUOTE
 489     }
 490   return apply_env (e->car, evlis_env (e->cdr, a), a);
 491 }
 492
 493 scm *
 494 expand_macro_env (scm *e, scm *a)
 495 {
 496   scm *macro;
 497   if (e->type == PAIR
 498       && (macro = lookup_macro (e->car, a)) != &scm_f)
 499     return expand_macro_env (apply_env (macro, e->cdr, a), a);
 500   return e;
 501 }
 502
 503 scm *
 504 begin (scm *e, scm *a)
 505 {
 506   scm *r = &scm_unspecified;
 507   while (e != &scm_nil) {
 508     r = builtin_eval (e->car, a);
 509     e = e->cdr;
 510   }
 511   return r;
 512 }
 513
 514 scm *
 515 builtin_if (scm *e, scm *a)
 516 {
 517   if (builtin_eval (car (e), a) != &scm_f)
 518     return builtin_eval (cadr (e), a);
 519   if (cddr (e) != &scm_nil)
 520     return builtin_eval (caddr (e), a);
 521   return &scm_unspecified;
 522 }
 523
 524 #if BUILTIN_QUASIQUOTE
 525 scm *
 526 eval_quasiquote (scm *e, scm *a)
 527 {
 528   if (e == &scm_nil) return e;
 529   else if (atom_p (e) == &scm_t) return e;
 530   else if (eq_p (car (e), &symbol_unquote) == &scm_t)
 531     return builtin_eval (cadr (e), a);
 532   else if (e->type == PAIR && e->car->type == PAIR
 533            && eq_p (caar (e), &symbol_unquote_splicing) == &scm_t)
 534       return append2 (builtin_eval (cadar (e), a), eval_quasiquote (cdr (e), a));
 535   return cons (eval_quasiquote (car (e), a), eval_quasiquote (cdr (e), a));
 536 }
 537
 538 scm *
 539 eval_quasisyntax (scm *e, scm *a)
 540 {
 541   if (e == &scm_nil) return e;
 542   else if (atom_p (e) == &scm_t) return e;
 543   else if (eq_p (car (e), &symbol_unsyntax) == &scm_t)
 544     return builtin_eval (cadr (e), a);
 545   else if (e->type == PAIR && e->car->type == PAIR
 546            && eq_p (caar (e), &symbol_unsyntax_splicing) == &scm_t)
 547       return append2 (builtin_eval (cadar (e), a), eval_quasisyntax (cdr (e), a));
 548   return cons (eval_quasisyntax (car (e), a), eval_quasisyntax (cdr (e), a));
 549 }
 550
 551 #else
 552 scm*add_unquoters (scm *a){}
 553 scm*add_unsyntaxers (scm *a){}
 554 scm*eval_unsyntax (scm *e, scm *a){}
 555 scm*eval_quasiquote (scm *e, scm *a){}
 556 scm*eval_quasisyntax (scm *e, scm *a){}
 557 #endif // BUILTIN_QUASIQUOTE
 558
 559 //Helpers
 560
 561 scm *
 562 builtin_p (scm *x)
 563 {
 564   return (x->type == FUNCTION0
 565           || x->type == FUNCTION1
 566           || x->type == FUNCTION2
 567           || x->type == FUNCTION3
 568           || x->type == FUNCTIONn)
 569     ? &scm_t : &scm_f;
 570 }
 571
 572 scm *
 573 boolean_p (scm *x)
 574 {
 575   return (x == &scm_t || x == &scm_f) ? &scm_t : &scm_f;
 576 }
 577
 578 scm *
 579 char_p (scm *x)
 580 {
 581   return x->type == CHAR ? &scm_t : &scm_f;
 582 }
 583
 584 scm *
 585 number_p (scm *x)
 586 {
 587   return x->type == NUMBER ? &scm_t : &scm_f;
 588 }
 589
 590 scm *
 591 string_p (scm *x)
 592 {
 593   return x->type == STRING ? &scm_t : &scm_f;
 594 }
 595
 596 scm *
 597 internal_p (scm *x)
 598 {
 599   return x->type == SCM ? &scm_t : &scm_f;
 600 }
 601
 602 scm *
 603 symbol_p (scm *x)
 604 {
 605   return x->type == SYMBOL ? &scm_t : &scm_f;
 606 }
 607
 608 scm *
 609 vector_p (scm *x)
 610 {
 611   return x->type == VECTOR ? &scm_t : &scm_f;
 612 }
 613
 614 scm *
 615 display (scm *x) ///((args . n))
 616 {
 617   scm *e = car (x);
 618   scm *p = cdr (x);
 619   int fd = 1;
 620   if (p->type == PAIR && p->car->type == NUMBER) fd = p->car->value;
 621   FILE *f = fd == 1 ? stdout : stderr;
 622   return display_helper (f, e, false, "", false);
 623 }
 624
 625 scm *
 626 display_ (FILE* f, scm *x) ///((internal))
 627 {
 628   return display_helper (f, x, false, "", false);
 629 }
 630
 631 scm *
 632 call (scm *fn, scm *x)
 633 {
 634   if (fn->type == FUNCTION0)
 635     return fn->function0 ();
 636   if (x->car->type == VALUES)
 637     x = cons (x->car->cdr->car, &scm_nil);
 638   if (fn->type == FUNCTION1)
 639     return fn->function1 (car (x));
 640   if (fn->type == FUNCTION2)
 641     return fn->function2 (car (x), cadr (x));
 642   if (fn->type == FUNCTION3)
 643     return fn->function3 (car (x), cadr (x), caddr (x));
 644   if (fn->type == FUNCTIONn)
 645     return fn->functionn (x);
 646   return &scm_unspecified;
 647 }
 648
 649 scm *
 650 append2 (scm *x, scm *y)
 651 {
 652   if (x == &scm_nil) return y;
 653   assert (x->type == PAIR);
 654   return cons (car (x), append2 (cdr (x), y));
 655 }
 656
 657 scm *
 658 append (scm *x) ///((args . n))
 659  {
 660   if (x == &scm_nil) return &scm_nil;
 661   return append2 (car (x), append (cdr (x)));
 662  }
 663
 664 scm *
 665 make_char (int x)
 666 {
 667   scm *p = (scm*)malloc (sizeof (scm));
 668   p->type = CHAR;
 669   p->value = x;
 670   return p;
 671 }
 672
 673 scm *
 674 make_macro (scm *name, scm *x)
 675 {
 676   scm *p = (scm*)malloc (sizeof (scm));
 677   p->type = MACRO;
 678   p->macro = x;
 679   p->name = name->name;
 680   return p;
 681 }
 682
 683 scm *
 684 make_number (int x)
 685 {
 686   scm *p = (scm*)malloc (sizeof (scm));
 687   p->type = NUMBER;
 688   p->value = x;
 689   return p;
 690 }
 691
 692 scm *
 693 make_string (char const *s)
 694 {
 695   scm *p = (scm*)malloc (sizeof (scm));
 696   p->type = STRING;
 697   p->name = strdup (s);
 698   return p;
 699 }
 700
 701 scm *symbols = 0;
 702
 703 scm *
 704 internal_lookup_symbol (char const *s)
 705 {
 706   scm *x = symbols;
 707   while (x && strcmp (s, x->car->name)) x = x->cdr;
 708   if (x) x = x->car;
 709   return x;
 710 }
 711
 712 scm *
 713 internal_make_symbol (char const *s)
 714 {
 715   scm *x = (scm*)malloc (sizeof (scm));
 716   x->type = SYMBOL;
 717   x->name = strdup (s);
 718   x->value = 0;
 719   symbols = cons (x, symbols);
 720   return x;
 721 }
 722
 723 scm *
 724 make_symbol (char const *s)
 725 {
 726   scm *x = internal_lookup_symbol (s);
 727   return x ? x : internal_make_symbol (s);
 728 }
 729
 730 scm *
 731 make_vector (scm *n)
 732 {
 733   scm *p = (scm*)malloc (sizeof (scm));
 734   p->type = VECTOR;
 735   p->length = n->value;
 736   p->vector = (scm**)malloc (n->value * sizeof (scm*));
 737   for (int i=0; i<n->value; i++) p->vector[i] = &scm_unspecified;
 738   return p;
 739 }
 740
 741 scm *
 742 string (scm *x) ///((args . n))
 743 {
 744   char buf[STRING_MAX] = "";
 745   char *p = buf;
 746   while (x != &scm_nil)
 747     {
 748       scm *s = car (x);
 749       assert (s->type == CHAR);
 750       *p++ = s->value;
 751       x = cdr (x);
 752     }
 753   return make_string (buf);
 754 }
 755
 756 scm *
 757 string_append (scm *x) ///((args . n))
 758 {
 759   char buf[STRING_MAX] = "";
 760
 761   while (x != &scm_nil)
 762     {
 763       scm *s = car (x);
 764       assert (s->type == STRING);
 765       strcat (buf, s->name);
 766       x = cdr (x);
 767     }
 768   return make_string (buf);
 769 }
 770
 771 scm *
 772 list_to_string (scm *x)
 773 {
 774   char buf[STRING_MAX] = "";
 775   char *p = buf;
 776   while (x != &scm_nil)
 777     {
 778       scm *s = car (x);
 779       assert (s->type == CHAR);
 780       *p++ = s->value;
 781       x = cdr (x);
 782     }
 783   *p = 0;
 784   return make_string (buf);
 785 }
 786
 787 scm *
 788 string_length (scm *x)
 789 {
 790   assert (x->type == STRING);
 791   return make_number (strlen (x->name));
 792 }
 793
 794 scm *
 795 string_ref (scm *x, scm *k)
 796 {
 797   assert (x->type == STRING);
 798   assert (k->type == NUMBER);
 799   return make_char (x->name[k->value]);
 800 }
 801
 802 scm *
 803 substring (scm *x) ///((args . n))
 804 {
 805   assert (x->type == PAIR);
 806   assert (x->car->type == STRING);
 807   char const *s = x->car->name;
 808   assert (x->cdr->car->type == NUMBER);
 809   int start = x->cdr->car->value;
 810   int end = strlen (s);
 811   if (x->cdr->cdr->type == PAIR) {
 812     assert (x->cdr->cdr->car->type == NUMBER);
 813     assert (x->cdr->cdr->car->value <= end);
 814     end = x->cdr->cdr->car->value;
 815   }
 816   char buf[STRING_MAX];
 817   strncpy (buf, s+start, end - start);
 818   buf[end-start] = 0;
 819   return make_string (buf);
 820 }
 821
 822 scm *
 823 length (scm *x)
 824 {
 825   int n = 0;
 826   while (x != &scm_nil)
 827     {
 828       n++;
 829       x = cdr (x);
 830     }
 831   return make_number (n);
 832 }
 833
 834 scm *
 835 last_pair (scm *x)
 836 {
 837   //if (x != &scm_nil && cdr (x) != &scm_nil)
 838   //return last_pair (cdr (x));
 839   while (x != &scm_nil && cdr (x) != &scm_nil)
 840     x = cdr (x);
 841   return x;
 842 }
 843
 844 scm *
 845 builtin_list (scm *x) ///((args . n))
 846 {
 847   return x;
 848 }
 849
 850 scm *
 851 values (scm *x) ///((args . n))
 852 {
 853   scm *v = cons (0, x);
 854   v->type = VALUES;
 855   return v;
 856 }
 857
 858 scm *
 859 call_with_values_env (scm *producer, scm *consumer, scm *a)
 860 {
 861   scm *v = apply_env (producer, &scm_nil, a);
 862   if (v->type == VALUES)
 863     v = v->cdr;
 864   return apply_env (consumer, v, a);
 865 }
 866
 867 scm *
 868 vector_length (scm *x)
 869 {
 870   assert (x->type == VECTOR);
 871   return make_number (x->length);
 872 }
 873
 874 scm *
 875 vector_ref (scm *x, scm *i)
 876 {
 877   assert (x->type == VECTOR);
 878   assert (i->value < x->length);
 879   return x->vector[i->value];
 880 }
 881
 882 scm *
 883 vector_set_x (scm *x, scm *i, scm *e)
 884 {
 885   assert (x->type == VECTOR);
 886   assert (i->value < x->length);
 887   x->vector[i->value] = e;
 888   return &scm_unspecified;
 889 }
 890
 891 scm *
 892 lookup (char const *s, scm *a)
 893 {
 894   if (isdigit (*s) || (*s == '-' && isdigit (*(s+1))))
 895     return make_number (atoi (s));
 896
 897   scm *x;
 898   x = internal_lookup_symbol (s);
 899   if (x) return x;
 900
 901   if (*s == '\'') return &symbol_quote;
 902   if (*s == '`') return &symbol_quasiquote;
 903   if (*s == ',' && *(s+1) == '@') return &symbol_unquote_splicing;
 904   if (*s == ',') return &symbol_unquote;
 905
 906   if (*s == '#' && *(s+1) == '\'') return &symbol_syntax;
 907   if (*s == '#' && *(s+1) == '`') return &symbol_quasisyntax;
 908   if (*s == '#' && *(s+1) == ',' && *(s+2) == '@') return &symbol_unsyntax_splicing;
 909   if (*s == '#' && *(s+1) == ',') return &symbol_unsyntax;
 910
 911   if (!strcmp (s, "EOF")) {
 912     fprintf (stderr, "mes: got EOF\n");
 913     return &scm_nil; // `EOF': eval program, which may read stdin
 914   }
 915
 916   return internal_make_symbol (s);
 917 }
 918
 919 scm *
 920 lookup_char (int c, scm *a)
 921 {
 922   char buf[2];
 923   buf[0] = c;
 924   buf[1] = 0;
 925   return lookup (buf, a);
 926 }
 927
 928 char const *
 929 list2str (scm *l)
 930 {
 931   static char buf[STRING_MAX];
 932   char *p = buf;
 933   while (l != &scm_nil) {
 934     scm *c = car (l);
 935     assert (c->type == NUMBER);
 936     *p++ = c->value;
 937     l = cdr (l);
 938   }
 939   *p = 0;
 940   return buf;
 941 }
 942
 943 scm *
 944 list_to_vector (scm *x)
 945 {
 946   temp_number.value = length (x)->value;
 947   scm *v = make_vector (&temp_number);
 948   scm **p = v->vector;
 949   while (x != &scm_nil)
 950     {
 951       *p++ = car (x);
 952       x = cdr (x);
 953     }
 954   return v;
 955 }
 956
 957 scm *
 958 integer_to_char (scm *x)
 959 {
 960   assert (x->type == NUMBER);
 961   return make_char (x->value);
 962 }
 963
 964 scm *
 965 char_to_integer (scm *x)
 966 {
 967   assert (x->type == CHAR);
 968   return make_number (x->value);
 969 }
 970
 971 scm *
 972 number_to_string (scm *x)
 973 {
 974   assert (x->type == NUMBER);
 975   char buf[STRING_MAX];
 976   sprintf (buf,"%d", x->value);
 977   return make_string (buf);
 978 }
 979
 980 scm *
 981 builtin_exit (scm *x)
 982 {
 983   assert (x->type == NUMBER);
 984   exit (x->value);
 985 }
 986
 987 scm *
 988 string_to_symbol (scm *x)
 989 {
 990   assert (x->type == STRING);
 991   return make_symbol (x->name);
 992 }
 993
 994 scm *
 995 symbol_to_string (scm *x)
 996 {
 997   assert (x->type == SYMBOL);
 998   return make_string (x->name);
 999 }
1000
1001 scm *
1002 vector_to_list (scm *v)
1003 {
1004   scm *x = &scm_nil;
1005   for (int i = 0; i < v->length; i++)
1006     x = append2 (x, cons (v->vector[i], &scm_nil));
1007   return x;
1008 }
1009
1010 scm *
1011 newline (scm *p) ///((args . n))
1012 {
1013   int fd = 1;
1014   if (p->type == PAIR && p->car->type == NUMBER) fd = p->car->value;
1015   FILE *f = fd == 1 ? stdout : stderr;
1016   fputs ("\n", f);
1017   return &scm_unspecified;
1018 }
1019
1020 scm *
1021 force_output (scm *p) ///((args . n))
1022 {
1023   int fd = 1;
1024   if (p->type == PAIR && p->car->type == NUMBER) fd = p->car->value;
1025   FILE *f = fd == 1 ? stdout : stderr;
1026   fflush (f);
1027 }
1028
1029 scm *
1030 display_helper (FILE* f, scm *x, bool cont, char const *sep, bool quote)
1031 {
1032   scm *r;
1033   fprintf (f, "%s", sep);
1034   if (x->type == CHAR && x->value == char_nul.value) fprintf (f, "#\\%s", char_nul.name);
1035   else if (x->type == CHAR && x->value == char_backspace.value) fprintf (f, "#\\%s", char_backspace.name);
1036   else if (x->type == CHAR && x->value == char_tab.value) fprintf (f, "#\\%s", char_tab.name);
1037   else if (x->type == CHAR && x->value == char_newline.value) fprintf (f, "#\\%s", char_newline.name);
1038   else if (x->type == CHAR && x->value == char_vt.value) fprintf (f, "#\\%s", char_vt.name);
1039   else if (x->type == CHAR && x->value == char_page.value) fprintf (f, "#\\%s", char_page.name);
1040   else if (x->type == CHAR && x->value == char_return.value) fprintf (f, "#\\%s", char_return.name);
1041   else if (x->type == CHAR && x->value == char_space.value) fprintf (f, "#\\%s", char_space.name);
1042   else if (x->type == CHAR) fprintf (f, "#\\%c", x->value);
1043   else if (x->type == MACRO) {
1044     fprintf (f, "(*macro* ");
1045     display_helper (f, x->macro, cont, sep, quote);
1046     fprintf (f, ")");
1047   }
1048   else if (x->type == NUMBER) fprintf (f, "%d", x->value);
1049   else if (x->type == PAIR) {
1050     if (car (x) == &scm_circular) {
1051       fprintf (f, "(*circ* . #-1#)");
1052       return &scm_unspecified;
1053     }
1054     if (car (x) == &scm_closure) {
1055       fprintf (f, "(*closure* . #-1#)");
1056       return &scm_unspecified;
1057     }
1058     if (car (x) == &scm_quote) {
1059       fprintf (f, "'");
1060       return display_helper (f, car (cdr (x)), cont, "", true);
1061     }
1062     if (!cont) fprintf (f, "(");
1063     display_ (f, car (x));
1064     if (cdr (x)->type == PAIR)
1065       display_helper (f, cdr (x), true, " ", false);
1066     else if (cdr (x) != &scm_nil) {
1067       fprintf (f, " . ");
1068       display_ (f, cdr (x));
1069     }
1070     if (!cont) fprintf (f, ")");
1071   }
1072   else if (x->type == VECTOR) {
1073     fprintf (f, "#(", x->length);
1074     for (int i = 0; i < x->length; i++) {
1075       if (x->vector[i]->type == VECTOR)
1076         fprintf (f, "%s#(...)", i ? " " : "");
1077       else
1078         display_helper (f, x->vector[i], false, i ? " " : "", false);
1079     }
1080     fprintf (f, ")");
1081   }
1082   else if (builtin_p (x) == &scm_t) fprintf (f, "#<procedure %s>", x->name);
1083   else if (atom_p (x) == &scm_t) fprintf (f, "%s", x->name);
1084
1085   return &scm_unspecified;
1086 }
1087
1088 // READ
1089
1090 int
1091 ungetchar (int c)
1092 {
1093   return ungetc (c, stdin);
1094 }
1095
1096 int
1097 peekchar ()
1098 {
1099   int c = getchar ();
1100   ungetchar (c);
1101   return c;
1102 }
1103
1104 scm *
1105 peek_char ()
1106 {
1107   return make_char (peekchar ());
1108 }
1109
1110 scm *
1111 read_char ()
1112 {
1113   return make_char (getchar ());
1114 }
1115
1116 scm *
1117 write_char (scm *x) ///((args . n))
1118 {
1119   scm *c = car (x);
1120   scm *p = cdr (x);
1121   int fd = 1;
1122   if (p->type == PAIR && p->car->type == NUMBER) fd = p->car->value;
1123   FILE *f = fd == 1 ? stdout : stderr;
1124   assert (c->type == NUMBER || c->type == CHAR);
1125   fputc (c->value, f);
1126   return c;
1127 }
1128
1129 scm *
1130 unget_char (scm *c)
1131 {
1132   assert (c->type == NUMBER || c->type == CHAR);
1133   ungetchar (c->value);
1134   return c;
1135 }
1136
1137 int
1138 readcomment (int c)
1139 {
1140   if (c == '\n') return c;
1141   return readcomment (getchar ());
1142 }
1143
1144 int
1145 readblock (int c)
1146 {
1147   if (c == '!' && peekchar () == '#') return getchar ();
1148   return readblock (getchar ());
1149 }
1150
1151 scm *
1152 readword (int c, char *w, scm *a)
1153 {
1154   if (c == EOF && !w) return &scm_nil;
1155   if (c == '\n' && !w) return readword (getchar (), w, a);
1156   if (c == '\n' && *w == '.' && w[1] == 0) return &scm_dot;
1157   if (c == EOF || c == '\n') return lookup (w, a);
1158   if (c == ' ') return readword ('\n', w, a);
1159   if (c == '"' && !w) return readstring ();
1160   if (c == '"') {ungetchar (c); return lookup (w, a);}
1161   if (c == '(' && !w) return readlist (a);
1162   if (c == '(') {ungetchar (c); return lookup (w, a);}
1163   if (c == ')' && !w) {ungetchar (c); return &scm_nil;}
1164   if (c == ')') {ungetchar (c); return lookup (w, a);}
1165   if (c == ',' && peekchar () == '@') {getchar (); return cons (lookup (",@", a),
1166                                                                    cons (readword (getchar (), w, a),
1167                                                                          &scm_nil));}
1168   if ((c == '\''
1169        || c == '`'
1170        || c == ',')
1171       && !w) {return cons (lookup_char (c, a),
1172                                      cons (readword (getchar (), w, a),
1173                                            &scm_nil));}
1174   if (c == '#' && peekchar () == ',' && !w) {
1175     getchar ();
1176     if (peekchar () == '@'){getchar (); return cons (lookup ("#,@", a),
1177                                                      cons (readword (getchar (), w, a),
1178                                                            &scm_nil));}
1179     return cons (lookup ("#,", a), cons (readword (getchar (), w, a), &scm_nil));
1180   }
1181   if (c == '#'
1182      && (peekchar () == '\''
1183          || peekchar () == '`')
1184      && !w) {char buf[3] = "#"; buf[1] = getchar (); return cons (lookup (buf, a),
1185                           cons (readword (getchar (), w, a),
1186                                 &scm_nil));}
1187   if (c == ';') {readcomment (c); return readword ('\n', w, a);}
1188   if (c == '#' && peekchar () == 'x') {getchar (); return read_hex ();}
1189   if (c == '#' && peekchar () == '\\') {getchar (); return read_character ();}
1190   if (c == '#' && !w && peekchar () == '(') {getchar (); return list_to_vector (readlist (a));}
1191   if (c == '#' && peekchar () == '(') {ungetchar (c); return lookup (w, a);}
1192   if (c == '#' && peekchar () == '!') {getchar (); readblock (getchar ()); return readword (getchar (), w, a);}
1193   char buf[STRING_MAX] = {0};
1194   char ch = c;
1195   char *p = w ? w + strlen (w) : buf;
1196   *p = ch;
1197   *(p+1) = 0;
1198   return readword (getchar (), w ? w : buf, a);
1199 }
1200
1201 scm *
1202 read_hex ()
1203 {
1204   int n = 0;
1205   int c = peekchar ();
1206   while ((c >= '0' && c <= '9')
1207          || (c >= 'A' && c <= 'F')
1208          || (c >= 'a' && c <= 'f')) {
1209     n <<= 4;
1210     if (c >= 'a') n += c - 'a' + 10;
1211     else if (c >= 'A') n += c - 'A' + 10;
1212     else n+= c - '0';
1213     getchar ();
1214     c = peekchar ();
1215   }
1216   return make_number (n);
1217 }
1218
1219 scm *
1220 read_character ()
1221 {
1222   int c = getchar ();
1223   if (c >= '0' && c <= '7'
1224       && peekchar () >= '0' && peekchar () <= '7') {
1225     c = c - '0';
1226     while (peekchar () >= '0' && peekchar () <= '7') {
1227       c <<= 3;
1228       c += getchar () - '0';
1229     }
1230   }
1231   else if (c >= 'a' && c <= 'z'
1232       && peekchar () >= 'a' && peekchar () <= 'z') {
1233     char buf[STRING_MAX];
1234     char *p = buf;
1235     *p++ = c;
1236     while (peekchar () >= 'a' && peekchar () <= 'z') {
1237       *p++ = getchar ();
1238     }
1239     *p = 0;
1240     if (!strcmp (buf, char_nul.name)) c = char_nul.value;
1241     else if (!strcmp (buf, char_backspace.name)) c = char_backspace.value;
1242     else if (!strcmp (buf, char_tab.name)) c = char_tab.value;
1243     else if (!strcmp (buf, char_newline.name)) c = char_newline.value;
1244     else if (!strcmp (buf, char_vt.name)) c = char_vt.value;
1245     else if (!strcmp (buf, char_page.name)) c = char_page.value;
1246     else if (!strcmp (buf, char_return.name)) c = char_return.value;
1247     else if (!strcmp (buf, char_space.name)) c = char_space.value;
1248     else {
1249       fprintf (stderr, "char not supported: %s\n", buf);
1250       assert (!"char not supported");
1251     }
1252   }
1253   return make_char (c);
1254 }
1255
1256 scm *
1257 readstring ()
1258 {
1259   char buf[STRING_MAX];
1260   char *p = buf;
1261   int c = getchar ();
1262   while (true) {
1263     if (c == '"') break;
1264     if (c == '\\' && peekchar () == '"') *p++ = getchar ();
1265     else if (c == '\\' && peekchar () == 'n') {getchar (); *p++ = '\n';}
1266     else if (c == EOF) assert (!"EOF in string");
1267     else *p++ = c;
1268     c = getchar ();
1269   }
1270   *p = 0;
1271   return make_string (buf);
1272 }
1273
1274 int
1275 eat_whitespace (int c)
1276 {
1277   while (c == ' ' || c == '\t' || c == '\n') c = getchar ();
1278   if (c == ';') return eat_whitespace (readcomment (c));
1279   if (c == '#' && peekchar () == '!') {getchar (); readblock (getchar ()); return eat_whitespace (getchar ());}
1280   return c;
1281 }
1282
1283 scm *
1284 readlist (scm *a)
1285 {
1286   int c = getchar ();
1287   c = eat_whitespace (c);
1288   if (c == ')') return &scm_nil;
1289   scm *w = readword (c, 0, a);
1290   if (w == &scm_dot)
1291     return car (readlist (a));
1292   return cons (w, readlist (a));
1293 }
1294
1295 scm *
1296 read_env (scm *a)
1297 {
1298   return readword (getchar (), 0, a);
1299 }
1300
1301 scm *
1302 greater_p (scm *x) ///((name . ">") (args . n))
1303 {
1304   int n = INT_MAX;
1305   while (x != &scm_nil)
1306     {
1307       assert (x->car->type == NUMBER);
1308       if (x->car->value >= n) return &scm_f;
1309       n = x->car->value;
1310       x = cdr (x);
1311     }
1312   return &scm_t;
1313 }
1314
1315 scm *
1316 less_p (scm *x) ///((name . "<") (args . n))
1317 {
1318   int n = INT_MIN;
1319   while (x != &scm_nil)
1320     {
1321       assert (x->car->type == NUMBER);
1322       if (x->car->value <= n) return &scm_f;
1323       n = x->car->value;
1324       x = cdr (x);
1325     }
1326   return &scm_t;
1327 }
1328
1329 scm *
1330 is_p (scm *x) ///((name . "=") (args . n))
1331 {
1332   if (x == &scm_nil) return &scm_t;
1333   assert (x->car->type == NUMBER);
1334   int n = x->car->value;
1335   x = cdr (x);
1336   while (x != &scm_nil)
1337     {
1338       if (x->car->value != n) return &scm_f;
1339       x = cdr (x);
1340     }
1341   return &scm_t;
1342 }
1343
1344 scm *
1345 minus (scm *x) ///((name . "-") (args . n))
1346 {
1347   scm *a = car (x);
1348   assert (a->type == NUMBER);
1349   int n = a->value;
1350   x = cdr (x);
1351   if (x == &scm_nil)
1352     n = -n;
1353   while (x != &scm_nil)
1354     {
1355       assert (x->car->type == NUMBER);
1356       n -= x->car->value;
1357       x = cdr (x);
1358     }
1359   return make_number (n);
1360 }
1361
1362 scm *
1363 plus (scm *x) ///((name . "+") (args . n))
1364 {
1365   int n = 0;
1366   while (x != &scm_nil)
1367     {
1368       assert (x->car->type == NUMBER);
1369       n += x->car->value;
1370       x = cdr (x);
1371     }
1372   return make_number (n);
1373 }
1374
1375 scm *
1376 divide (scm *x) ///((name . "/") (args . n))
1377 {
1378   int n = 1;
1379   if (x != &scm_nil) {
1380     assert (x->car->type == NUMBER);
1381     n = x->car->value;
1382     x = cdr (x);
1383   }
1384   while (x != &scm_nil)
1385     {
1386       assert (x->car->type == NUMBER);
1387       n /= x->car->value;
1388       x = cdr (x);
1389     }
1390   return make_number (n);
1391 }
1392
1393 scm *
1394 modulo (scm *a, scm *b)
1395 {
1396   assert (a->type == NUMBER);
1397   assert (b->type == NUMBER);
1398   return make_number (a->value % b->value);
1399 }
1400
1401 scm *
1402 multiply (scm *x) ///((name . "*") (args . n))
1403 {
1404   int n = 1;
1405   while (x != &scm_nil)
1406     {
1407       assert (x->car->type == NUMBER);
1408       n *= x->car->value;
1409       x = cdr (x);
1410     }
1411   return make_number (n);
1412 }
1413
1414 scm *
1415 logior (scm *x) ///((args . n))
1416 {
1417   int n = 0;
1418   while (x != &scm_nil)
1419     {
1420       assert (x->car->type == NUMBER);
1421       n |= x->car->value;
1422       x = cdr (x);
1423     }
1424   return make_number (n);
1425 }
1426
1427 scm *add_environment (scm *a, char const *name, scm *x);
1428
1429 #if BUILTIN_QUASIQUOTE
1430 scm *
1431 add_unquoters (scm *a)
1432 {
1433   a = cons (cons (&symbol_unquote, &scm_unquote), a);
1434   a = cons (cons (&symbol_unquote_splicing, &scm_unquote_splicing), a);
1435   return a;
1436 }
1437
1438 scm *
1439 add_unsyntaxers (scm *a)
1440 {
1441   a = cons (cons (&symbol_unsyntax, &scm_unsyntax), a);
1442   a = cons (cons (&symbol_unsyntax_splicing, &scm_unsyntax_splicing), a);
1443   return a;
1444 }
1445 #endif // BUILTIN_QUASIQUOTE
1446
1447 scm *
1448 add_environment (scm *a, char const *name, scm *x)
1449 {
1450   return cons (cons (make_symbol (name), x), a);
1451 }
1452
1453 scm *
1454 mes_environment () ///((internal))
1455 {
1456   scm *a = &scm_nil;
1457
1458   #include "mes.symbols.i"
1459
1460 #if BOOT
1461   symbols = cons (&scm_label, symbols);
1462   a = cons (cons (&scm_label, &scm_t), a);
1463 #endif
1464
1465   a = cons (cons (&scm_f, &scm_f), a);
1466   a = cons (cons (&scm_nil, &scm_nil), a);
1467   a = cons (cons (&scm_t, &scm_t), a);
1468   a = cons (cons (&scm_unspecified, &scm_unspecified), a);
1469   a = cons (cons (&symbol_begin, &symbol_begin), a);
1470   a = cons (cons (&symbol_quote, &scm_quote), a);
1471   a = cons (cons (&symbol_syntax, &scm_syntax), a);
1472
1473 #include "mes.environment.i"
1474
1475   a = cons (cons (&scm_closure, a), a);
1476   return a;
1477 }
1478
1479 scm *
1480 make_lambda (scm *args, scm *body)
1481 {
1482   return cons (&scm_lambda, cons (args, body));
1483 }
1484
1485 scm *
1486 make_closure (scm *args, scm *body, scm *a)
1487 {
1488   return cons (&scm_closure, cons (cons (&scm_circular, a), cons (args, body)));
1489 }
1490
1491 #if !BOOT
1492 scm *
1493 define (scm *x, scm *a)
1494 {
1495   scm *e;
1496   scm *name = cadr (x);
1497   if (name->type != PAIR)
1498     e = builtin_eval (caddr (x), cons (cons (cadr (x), cadr (x)), a));
1499   else {
1500     name = car (name);
1501     scm *p = pairlis (cadr (x), cadr (x), a);
1502     e = builtin_eval (make_lambda (cdadr (x), cddr (x)), p);
1503   }
1504   if (eq_p (car (x), &symbol_define_macro) == &scm_t)
1505     e = make_macro (name, e);
1506   scm *entry = cons (name, e);
1507   scm *aa = cons (entry, &scm_nil);
1508   set_cdr_x (aa, cdr (a));
1509   set_cdr_x (a, aa);
1510   scm *cl = assq (&scm_closure, a);
1511   set_cdr_x (cl, aa);
1512   return entry;
1513 }
1514 #else // BOOT
1515 scm*define (scm *x, scm *a){}
1516 #endif
1517
1518 scm *
1519 define_macro (scm *x, scm *a)
1520 {
1521 }
1522
1523 scm *
1524 lookup_macro (scm *x, scm *a)
1525 {
1526   if (x->type != SYMBOL) return &scm_f;
1527   scm *m = assq_ref_cache (x, a);
1528   if (macro_p (m) == &scm_t) return m->macro;
1529   return &scm_f;
1530 }
1531
1532 scm *
1533 read_file (scm *e, scm *a)
1534 {
1535   if (e == &scm_nil) return e;
1536 #if DEBUG
1537   scm *x = cons (e, read_file (read_env (a), a));
1538   display_ (stderr, x);
1539 #else
1540   return cons (e, read_file (read_env (a), a));
1541 #endif
1542 }
1543
1544 int
1545 main (int argc, char *argv[])
1546 {
1547   if (argc > 1 && !strcmp (argv[1], "--help")) return puts ("Usage: mes < FILE\n");
1548   if (argc > 1 && !strcmp (argv[1], "--version")) return puts ("Mes 0.0\n");
1549   scm *a = mes_environment ();
1550   display_ (stderr, builtin_eval (cons (&symbol_begin, read_file (read_env (a), a)), a));
1551   fputs ("", stderr);
1552   return 0;
1553 }