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