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