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