scaffold/mini-mes.c

   1 /* -*-comment-start: "//";comment-end:""-*-
   2  * Mes --- Maxwell Equations of Software
   3  * Copyright © 2016,2017 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 #if __GNUC__
  22 #include "mlibc.c"
  23 #endif
  24 #define assert(x) ((x) ? (void)0 : assert_fail (#x))
  25
  26 #define MES_MINI 1
  27 #define FIXED_PRIMITIVES 1
  28
  29 #define MES_GC 1
  30 #if MES_GC
  31 int ARENA_SIZE = 100000;
  32 #else
  33 int ARENA_SIZE = 1000000000;
  34 #endif
  35 int MAX_ARENA_SIZE = 40000000;
  36 int GC_SAFETY = 10000;
  37
  38 char *arena = 0;
  39
  40 typedef int SCM;
  41
  42 int g_debug = 0;
  43 int g_free = 0;
  44
  45 SCM g_continuations = 0;
  46 SCM g_symbols = 0;
  47 SCM g_stack = 0;
  48 // a/env
  49 SCM r0 = 0;
  50 // param 1
  51 SCM r1 = 0;
  52 // save 2+load/dump
  53 SCM r2 = 0;
  54 // continuation
  55 SCM r3 = 0;
  56
  57 enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TREF, TSPECIAL, TSTRING, TSYMBOL, TVALUES, TVECTOR, TBROKEN_HEART};
  58
  59 struct scm {
  60   enum type_t type;
  61   SCM car;
  62   SCM cdr;
  63 };
  64
  65 struct function {
  66   int (*function) (void);
  67   int arity;
  68   char *name;
  69 };
  70
  71 //FIXME
  72 char *foobar = 0;
  73
  74 #if __GNUC__
  75 struct scm *g_cells = 0;
  76 struct scm *g_news = 0;
  77 #else
  78 struct scm *g_cells = foobar;
  79 struct scm *g_news = foobar;
  80 #endif
  81
  82 struct scm scm_nil = {TSPECIAL, "()",0};
  83 struct scm scm_f = {TSPECIAL, "#f",0};
  84 struct scm scm_t = {TSPECIAL, "#t",0};
  85 struct scm scm_dot = {TSPECIAL, ".",0};
  86 struct scm scm_arrow = {TSPECIAL, "=>",0};
  87 struct scm scm_undefined = {TSPECIAL, "*undefined*",0};
  88 struct scm scm_unspecified = {TSPECIAL, "*unspecified*",0};
  89 struct scm scm_closure = {TSPECIAL, "*closure*",0};
  90 struct scm scm_circular = {TSPECIAL, "*circular*",0};
  91 struct scm scm_begin = {TSPECIAL, "*begin*",0};
  92
  93 struct scm scm_symbol_dot = {TSYMBOL, "*dot*",0};
  94 struct scm scm_symbol_lambda = {TSYMBOL, "lambda",0};
  95 struct scm scm_symbol_begin = {TSYMBOL, "begin",0};
  96 struct scm scm_symbol_if = {TSYMBOL, "if",0};
  97 struct scm scm_symbol_quote = {TSYMBOL, "quote",0};
  98 struct scm scm_symbol_set_x = {TSYMBOL, "set!",0};
  99
 100 struct scm scm_symbol_sc_expand = {TSYMBOL, "sc-expand",0};
 101 struct scm scm_symbol_macro_expand = {TSYMBOL, "macro-expand",0};
 102 struct scm scm_symbol_sc_expander_alist = {TSYMBOL, "*sc-expander-alist*",0};
 103
 104 struct scm scm_symbol_call_with_values = {TSYMBOL, "call-with-values",0};
 105 struct scm scm_call_with_current_continuation = {TSPECIAL, "*call/cc*",0};
 106 struct scm scm_symbol_call_with_current_continuation = {TSYMBOL, "call-with-current-continuation",0};
 107 struct scm scm_symbol_current_module = {TSYMBOL, "current-module",0};
 108 struct scm scm_symbol_primitive_load = {TSYMBOL, "primitive-load",0};
 109 struct scm scm_symbol_read_input_file = {TSYMBOL, "read-input-file",0};
 110 struct scm scm_symbol_write = {TSYMBOL, "write",0};
 111 struct scm scm_symbol_display = {TSYMBOL, "display",0};
 112
 113 struct scm scm_symbol_throw = {TSYMBOL, "throw",0};
 114 struct scm scm_symbol_not_a_pair = {TSYMBOL, "not-a-pair",0};
 115 struct scm scm_symbol_system_error = {TSYMBOL, "system-error",0};
 116 struct scm scm_symbol_wrong_number_of_args = {TSYMBOL, "wrong-number-of-args",0};
 117 struct scm scm_symbol_wrong_type_arg = {TSYMBOL, "wrong-type-arg",0};
 118 struct scm scm_symbol_unbound_variable = {TSYMBOL, "unbound-variable",0};
 119
 120 struct scm scm_symbol_argv = {TSYMBOL, "%argv",0};
 121 struct scm scm_symbol_mes_prefix = {TSYMBOL, "%prefix",0};
 122 struct scm scm_symbol_mes_version = {TSYMBOL, "%version",0};
 123
 124 struct scm scm_symbol_car = {TSYMBOL, "car",0};
 125 struct scm scm_symbol_cdr = {TSYMBOL, "cdr",0};
 126 struct scm scm_symbol_null_p = {TSYMBOL, "null?",0};
 127 struct scm scm_symbol_eq_p = {TSYMBOL, "eq?",0};
 128 struct scm scm_symbol_cons = {TSYMBOL, "cons",0};
 129
 130 struct scm scm_vm_evlis = {TSPECIAL, "*vm-evlis*",0};
 131 struct scm scm_vm_evlis2 = {TSPECIAL, "*vm-evlis2*",0};
 132 struct scm scm_vm_evlis3 = {TSPECIAL, "*vm-evlis3*",0};
 133 struct scm scm_vm_apply = {TSPECIAL, "core:apply",0};
 134 struct scm scm_vm_apply2 = {TSPECIAL, "*vm-apply2*",0};
 135 struct scm scm_vm_eval = {TSPECIAL, "core:eval",0};
 136
 137 //FIXED_PRIMITIVES
 138 struct scm scm_vm_eval_car = {TSPECIAL, "*vm-eval-car*",0};
 139 struct scm scm_vm_eval_cdr = {TSPECIAL, "*vm-eval-cdr*",0};
 140 struct scm scm_vm_eval_cons = {TSPECIAL, "*vm-eval-cons*",0};
 141 struct scm scm_vm_eval_null_p = {TSPECIAL, "*vm-eval-null-p*",0};
 142
 143 struct scm scm_vm_eval_set_x = {TSPECIAL, "*vm-eval-set!*",0};
 144 struct scm scm_vm_eval_macro = {TSPECIAL, "*vm-eval-macro*",0};
 145 struct scm scm_vm_eval_check_func = {TSPECIAL, "*vm-eval-check-func*",0};
 146 struct scm scm_vm_eval2 = {TSPECIAL, "*vm-eval2*",0};
 147 struct scm scm_vm_macro_expand = {TSPECIAL, "core:macro-expand",0};
 148 struct scm scm_vm_begin = {TSPECIAL, "*vm-begin*",0};
 149 struct scm scm_vm_begin_read_input_file = {TSPECIAL, "*vm-begin-read-input-file*",0};
 150 struct scm scm_vm_begin2 = {TSPECIAL, "*vm-begin2*",0};
 151 struct scm scm_vm_if = {TSPECIAL, "*vm-if*",0};
 152 struct scm scm_vm_if_expr = {TSPECIAL, "*vm-if-expr*",0};
 153 struct scm scm_vm_call_with_values2 = {TSPECIAL, "*vm-call-with-values2*",0};
 154 struct scm scm_vm_call_with_current_continuation2 = {TSPECIAL, "*vm-call-with-current-continuation2*",0};
 155 struct scm scm_vm_return = {TSPECIAL, "*vm-return*",0};
 156
 157 struct scm scm_symbol_gnuc = {TSYMBOL, "%gnuc",0};
 158 struct scm scm_symbol_mesc = {TSYMBOL, "%mesc",0};
 159
 160 struct scm scm_test = {TSYMBOL, "test",0};
 161
 162 #include "mini-mes.symbols.h"
 163
 164 SCM tmp;
 165 SCM tmp_num;
 166 SCM tmp_num2;
 167
 168 struct function g_functions[200];
 169 int g_function = 0;
 170
 171 #include "mini-gc.h"
 172 // #include "lib.h"
 173 // #include "math.h"
 174 #include "mini-mes.h"
 175 // #include "posix.h"
 176 // #include "reader.h"
 177 #include "mini-vector.h"
 178
 179
 180 #define TYPE(x) (g_cells[x].type)
 181
 182 #define CAR(x) g_cells[x].car
 183 #define LENGTH(x) g_cells[x].car
 184 #define REF(x) g_cells[x].car
 185 #define STRING(x) g_cells[x].car
 186
 187 #define CDR(x) g_cells[x].cdr
 188 #define CLOSURE(x) g_cells[x].cdr
 189 #define CONTINUATION(x) g_cells[x].cdr
 190
 191 #define FUNCTION(x) g_functions[g_cells[x].cdr]
 192 #define MACRO(x) g_cells[x].cdr
 193 #define VALUE(x) g_cells[x].cdr
 194 #define VECTOR(x) g_cells[x].cdr
 195
 196 #define NTYPE(x) g_news[x].type
 197
 198 #define NCAR(x) g_news[x].car
 199 #define NLENGTH(x) g_news[x].car
 200
 201 #define NCDR(x) g_news[x].cdr
 202 #define NVALUE(x) g_news[x].cdr
 203 #define NVECTOR(x) g_news[x].cdr
 204
 205 #define MAKE_CHAR(n) make_cell_ (tmp_num_ (TCHAR), 0, tmp_num2_ (n))
 206 #define MAKE_CONTINUATION(n) make_cell_ (tmp_num_ (TCONTINUATION), n, g_stack)
 207 #define MAKE_NUMBER(n) make_cell_ (tmp_num_ (TNUMBER), 0, tmp_num2_ (n))
 208 #define MAKE_REF(n) make_cell_ (tmp_num_ (TREF), n, 0)
 209
 210 #define CAAR(x) CAR (CAR (x))
 211 #define CADR(x) CAR (CDR (x))
 212 #define CDAR(x) CDR (CAR (x))
 213 #define CDDR(x) CDR (CDR (x))
 214 #define CADAR(x) CAR (CDR (CAR (x)))
 215 #define CADDR(x) CAR (CDR (CDR (x)))
 216 #define CDADAR(x) CAR (CDR (CAR (CDR (x))))
 217
 218 #define MAKE_STRING(x) make_cell_ (tmp_num_ (TSTRING), x, 0)
 219
 220 SCM
 221 alloc (int n)
 222 {
 223   assert (g_free + n < ARENA_SIZE);
 224   SCM x = g_free;
 225   g_free += n;
 226   return x;
 227 }
 228
 229 #define DEBUG 0
 230
 231 SCM
 232 tmp_num_ (int x)
 233 {
 234   VALUE (tmp_num) = x;
 235   return tmp_num;
 236 }
 237
 238 SCM
 239 tmp_num2_ (int x)
 240 {
 241   VALUE (tmp_num2) = x;
 242   return tmp_num2;
 243 }
 244
 245 SCM
 246 make_cell_ (SCM type, SCM car, SCM cdr)
 247 {
 248   SCM x = alloc (1);
 249   assert (TYPE (type) == TNUMBER);
 250   TYPE (x) = VALUE (type);
 251   if (VALUE (type) == TCHAR || VALUE (type) == TNUMBER) {
 252     if (car) CAR (x) = CAR (car);
 253     if (cdr) CDR(x) = CDR(cdr);
 254   }
 255   else if (VALUE (type) == TFUNCTION) {
 256     if (car) CAR (x) = car;
 257     if (cdr) CDR(x) = CDR(cdr);
 258   }
 259   else {
 260     CAR (x) = car;
 261     CDR(x) = cdr;
 262   }
 263   return x;
 264 }
 265
 266
 267 SCM
 268 make_symbol_ (SCM s) ///((internal))
 269 {
 270   VALUE (tmp_num) = TSYMBOL;
 271   SCM x = make_cell_ (tmp_num, s, 0);
 272   g_symbols = cons (x, g_symbols);
 273   return x;
 274 }
 275
 276 SCM
 277 lookup_symbol_ (SCM s)
 278 {
 279   SCM x = g_symbols;
 280   while (x) {
 281     //if (list_of_char_equal_p (STRING (car (x)), s) == cell_t) break;
 282     if (list_of_char_equal_p (STRING (car (x)), s) == cell_t) goto dun;
 283     x = cdr (x);
 284   }
 285  dun:
 286   if (x) x = car (x);
 287   if (!x) x = make_symbol_ (s);
 288   return x;
 289 }
 290
 291 SCM
 292 list_of_char_equal_p (SCM a, SCM b) ///((internal))
 293 {
 294   while (a != cell_nil && b != cell_nil && VALUE (car (a)) == VALUE (car (b))) {
 295     assert (TYPE (car (a)) == TCHAR);
 296     assert (TYPE (car (b)) == TCHAR);
 297     a = cdr (a);
 298     b = cdr (b);
 299   }
 300   return (a == cell_nil && b == cell_nil) ? cell_t : cell_f;
 301 }
 302
 303 SCM
 304 type_ (SCM x)
 305 {
 306   return MAKE_NUMBER (TYPE (x));
 307 }
 308
 309 SCM
 310 car_ (SCM x)
 311 {
 312   return (TYPE (x) != TCONTINUATION
 313           && (TYPE (CAR (x)) == TPAIR // FIXME: this is weird
 314               || TYPE (CAR (x)) == TREF
 315               || TYPE (CAR (x)) == TSPECIAL
 316               || TYPE (CAR (x)) == TSYMBOL
 317               || TYPE (CAR (x)) == TSTRING)) ? CAR (x) : MAKE_NUMBER (CAR (x));
 318 }
 319
 320 SCM
 321 cdr_ (SCM x)
 322 {
 323   return (TYPE (CDR (x)) == TPAIR
 324           || TYPE (CDR (x)) == TREF
 325           || TYPE (CAR (x)) == TSPECIAL
 326           || TYPE (CDR (x)) == TSYMBOL
 327           || TYPE (CDR (x)) == TSTRING) ? CDR (x) : MAKE_NUMBER (CDR (x));
 328 }
 329
 330 SCM
 331 arity_ (SCM x)
 332 {
 333   assert (TYPE (x) == TFUNCTION);
 334   return MAKE_NUMBER (FUNCTION (x).arity);
 335 }
 336
 337 SCM
 338 cons (SCM x, SCM y)
 339 {
 340   VALUE (tmp_num) = TPAIR;
 341   return make_cell_ (tmp_num, x, y);
 342 }
 343
 344 SCM
 345 car (SCM x)
 346 {
 347 #if MES_MINI
 348   //Nyacc
 349   //assert ("!car");
 350 #else
 351   if (TYPE (x) != TPAIR) error (cell_symbol_not_a_pair, cons (x, cell_symbol_car));
 352 #endif
 353   return CAR (x);
 354 }
 355
 356 SCM
 357 cdr (SCM x)
 358 {
 359 #if MES_MINI
 360   //Nyacc
 361   //assert ("!cdr");
 362 #else
 363   if (TYPE (x) != TPAIR) error (cell_symbol_not_a_pair, cons (x, cell_symbol_cdr));
 364 #endif
 365   return CDR(x);
 366 }
 367
 368 SCM
 369 list (SCM x) ///((arity . n))
 370 {
 371   return x;
 372 }
 373
 374 SCM
 375 null_p (SCM x)
 376 {
 377   return x == cell_nil ? cell_t : cell_f;
 378 }
 379
 380 SCM
 381 eq_p (SCM x, SCM y)
 382 {
 383   return (x == y
 384           || ((TYPE (x) == TKEYWORD && TYPE (y) == TKEYWORD
 385                && STRING (x) == STRING (y)))
 386           || (TYPE (x) == TCHAR && TYPE (y) == TCHAR
 387               && VALUE (x) == VALUE (y))
 388           || (TYPE (x) == TNUMBER && TYPE (y) == TNUMBER
 389               && VALUE (x) == VALUE (y)))
 390     ? cell_t : cell_f;
 391 }
 392
 393 SCM
 394 values (SCM x) ///((arity . n))
 395 {
 396   SCM v = cons (0, x);
 397   TYPE (v) = TVALUES;
 398   return v;
 399 }
 400
 401 SCM
 402 acons (SCM key, SCM value, SCM alist)
 403 {
 404   return cons (cons (key, value), alist);
 405 }
 406
 407 SCM
 408 length (SCM x)
 409 {
 410   int n = 0;
 411   while (x != cell_nil)
 412     {
 413       n++;
 414       if (TYPE (x) != TPAIR) return MAKE_NUMBER (-1);
 415       x = cdr (x);
 416     }
 417   return MAKE_NUMBER (n);
 418 }
 419
 420 SCM
 421 error (SCM key, SCM x)
 422 {
 423   SCM throw;
 424   if ((throw = assq_ref_env (cell_symbol_throw, r0)) != cell_undefined)
 425     return apply (throw, cons (key, cons (x, cell_nil)), r0);
 426   display_error_ (key);
 427   eputs (": ");
 428   display_ (x);
 429   eputs ("\n");
 430   assert (0);
 431 }
 432
 433 SCM
 434 assert_defined (SCM x, SCM e) ///((internal))
 435 {
 436   if (e != cell_undefined) return e;
 437   // error (cell_symbol_unbound_variable, x);
 438   eputs ("unbound variable: ");
 439   display_error_ (x);
 440   eputs ("\n");
 441   exit (33);
 442   return e;
 443 }
 444
 445 SCM
 446 cstring_to_list (char const* s)
 447 {
 448   char *x = s;
 449   SCM p = cell_nil;
 450   int i = strlen (s);
 451   while (i--)
 452     {
 453       p = cons (MAKE_CHAR (s[i]), p);
 454       x++;
 455     }
 456   return p;
 457 }
 458
 459 SCM
 460 check_formals (SCM f, SCM formals, SCM args) ///((internal))
 461 {
 462   int flen = (TYPE (formals) == TNUMBER) ? VALUE (formals) : VALUE (length (formals));
 463   int alen = VALUE (length (args));
 464   if (alen != flen && alen != -1 && flen != -1)
 465     {
 466       // FIXME
 467       //char buf[1024];
 468       char buf = "TODO:check_formals";
 469       // sprintf (buf, "apply: wrong number of arguments; expected: %d, got: %d: ", flen, alen);
 470       eputs ("apply: wrong number of arguments; expected: ");
 471       eputs (itoa (flen));
 472       eputs (", got: ");
 473       eputs (itoa (alen));
 474       eputs ("\n");
 475       display_error_ (f);
 476       SCM e = MAKE_STRING (cstring_to_list (buf));
 477       return error (cell_symbol_wrong_number_of_args, cons (e, f));
 478     }
 479   return cell_unspecified;
 480 }
 481
 482 SCM
 483 check_apply (SCM f, SCM e) ///((internal))
 484 {
 485   //char const* type = 0;
 486   char* type = 0;
 487   if (f == cell_f || f == cell_t) type = "bool";
 488   if (f == cell_nil) type = "nil";
 489   if (f == cell_unspecified) type = "*unspecified*";
 490   if (f == cell_undefined) type = "*undefined*";
 491   if (TYPE (f) == TCHAR) type = "char";
 492   if (TYPE (f) == TNUMBER) type = "number";
 493   if (TYPE (f) == TSTRING) type = "string";
 494
 495   if (type)
 496     {
 497       //FIXME
 498       //char buf[1024];
 499       char buf = "TODO:check_apply";
 500       // sprintf (buf, "cannot apply: %s:", type);
 501       // fprintf (stderr, " [");
 502       // display_error_ (e);
 503       // fprintf (stderr, "]\n");
 504       eputs ("cannot apply: ");
 505       eputs (type);
 506       eputs ("[");
 507       display_error_ (e);
 508       eputs ("]\n");
 509       SCM e = MAKE_STRING (cstring_to_list (buf));
 510       return error (cell_symbol_wrong_type_arg, cons (e, f));
 511     }
 512   return cell_unspecified;
 513 }
 514
 515 SCM
 516 gc_push_frame () ///((internal))
 517 {
 518   SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cell_nil))));
 519   g_stack = cons (frame, g_stack);
 520   return g_stack;
 521 }
 522
 523 SCM
 524 apply (SCM f, SCM x, SCM a) ///((internal))
 525 {
 526   push_cc (cons (f, x), cell_unspecified, r0, cell_unspecified);
 527   r3 = cell_vm_apply;
 528   return eval_apply ();
 529 }
 530
 531 SCM
 532 append2 (SCM x, SCM y)
 533 {
 534   if (x == cell_nil) return y;
 535   assert (TYPE (x) == TPAIR);
 536   return cons (car (x), append2 (cdr (x), y));
 537 }
 538
 539 SCM
 540 pairlis (SCM x, SCM y, SCM a)
 541 {
 542   if (x == cell_nil)
 543     return a;
 544   if (TYPE (x) != TPAIR)
 545     return cons (cons (x, y), a);
 546   return cons (cons (car (x), car (y)),
 547                pairlis (cdr (x), cdr (y), a));
 548 }
 549
 550 SCM display_ (SCM);
 551
 552 SCM
 553 call (SCM fn, SCM x)
 554 {
 555   if ((FUNCTION (fn).arity > 0 || FUNCTION (fn).arity == -1)
 556       && x != cell_nil && TYPE (CAR (x)) == TVALUES)
 557     x = cons (CADAR (x), CDR (x));
 558   if ((FUNCTION (fn).arity > 1 || FUNCTION (fn).arity == -1)
 559       && x != cell_nil && TYPE (CDR (x)) == TPAIR && TYPE (CADR (x)) == TVALUES)
 560     x = cons (CAR (x), cons (CDADAR (x), CDR (x)));
 561   switch (FUNCTION (fn).arity)
 562     {
 563     case 0: {return (FUNCTION (fn).function) ();}
 564     case 1: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (CAR (x));}
 565     case 2: {return ((SCM(*)(SCM,SCM))(FUNCTION (fn).function)) (CAR (x), CADR (x));}
 566     case 3: {return ((SCM(*)(SCM,SCM,SCM))(FUNCTION (fn).function)) (CAR (x), CADR (x), car (CDDR (x)));}
 567     case -1: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);}
 568     default: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);}
 569     }
 570
 571   return cell_unspecified;
 572 }
 573
 574 SCM
 575 assq (SCM x, SCM a)
 576 {
 577   //FIXME: move into fast-non eq_p-ing assq core:assq?
 578   //while (a != cell_nil && x != CAAR (a)) a = CDR (a);
 579   while (a != cell_nil && eq_p (x, CAAR (a)) == cell_f) a = CDR (a);
 580   return a != cell_nil ? car (a) : cell_f;
 581 }
 582
 583 SCM
 584 assq_ref_env (SCM x, SCM a)
 585 {
 586   x = assq (x, a);
 587   if (x == cell_f) return cell_undefined;
 588   return cdr (x);
 589 }
 590
 591 SCM
 592 set_car_x (SCM x, SCM e)
 593 {
 594   assert (TYPE (x) == TPAIR);
 595   CAR (x) = e;
 596   return cell_unspecified;
 597 }
 598
 599 SCM
 600 set_cdr_x (SCM x, SCM e)
 601 {
 602   //if (TYPE (x) != TPAIR) error (cell_symbol_not_a_pair, cons (x, cell_set_cdr_x));
 603   CDR (x) = e;
 604   return cell_unspecified;
 605 }
 606
 607 SCM
 608 set_env_x (SCM x, SCM e, SCM a)
 609 {
 610   SCM p = assert_defined (x, assq (x, a));
 611   //if (TYPE (p) != TPAIR)  error (cell_symbol_not_a_pair, cons (p, x));
 612   return set_cdr_x (p, e);
 613 }
 614
 615 SCM
 616 call_lambda (SCM e, SCM x, SCM aa, SCM a) ///((internal))
 617 {
 618   SCM cl = cons (cons (cell_closure, x), x);
 619   cl = cons (cons (cell_closure, x), x);
 620   r1 = e;
 621   r0 = cl;
 622   return cell_unspecified;
 623 }
 624
 625 SCM
 626 make_closure_ (SCM args, SCM body, SCM a) ///((internal))
 627 {
 628   return make_cell_ (tmp_num_ (TCLOSURE), cell_f, cons (cons (cell_circular, a), cons (args, body)));
 629 }
 630
 631 SCM
 632 lookup_macro_ (SCM x, SCM a) ///((internal))
 633 {
 634   if (TYPE (x) != TSYMBOL) return cell_f;
 635   SCM m = assq_ref_env (x, a);
 636  if (TYPE (m) == TMACRO) return MACRO (m);
 637   return cell_f;
 638 }
 639
 640 SCM
 641 push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal))
 642 {
 643   SCM x = r3;
 644   r3 = c;
 645   r2 = p2;
 646   gc_push_frame ();
 647   r1 = p1;
 648   r0 = a;
 649   r3 = x;
 650   return cell_unspecified;
 651 }
 652
 653 SCM gc_pop_frame (); //((internal))
 654
 655 SCM
 656 eval_apply ()
 657 {
 658  eval_apply:
 659 #if MES_GC
 660   if (g_free + GC_SAFETY > ARENA_SIZE)
 661     gc_pop_frame (gc (gc_push_frame ()));
 662 #endif
 663   switch (r3)
 664     {
 665     case cell_vm_evlis: goto evlis;
 666     case cell_vm_evlis2: goto evlis2;
 667     case cell_vm_evlis3: goto evlis3;
 668     case cell_vm_apply: goto apply;
 669     case cell_vm_apply2: goto apply2;
 670     case cell_vm_eval: goto eval;
 671 #if FIXED_PRIMITIVES
 672     case cell_vm_eval_car: goto eval_car;
 673     case cell_vm_eval_cdr: goto eval_cdr;
 674     case cell_vm_eval_cons: goto eval_cons;
 675     case cell_vm_eval_null_p: goto eval_null_p;
 676 #endif
 677     case cell_vm_eval_set_x: goto eval_set_x;
 678     case cell_vm_eval_macro: goto eval_macro;
 679     case cell_vm_eval_check_func: goto eval_check_func;
 680     case cell_vm_eval2: goto eval2;
 681     case cell_vm_macro_expand: goto macro_expand;
 682     case cell_vm_begin: goto begin;
 683     case cell_vm_begin_read_input_file: goto begin_read_input_file;
 684     case cell_vm_begin2: goto begin2;
 685     case cell_vm_if: goto vm_if;
 686     case cell_vm_if_expr: goto if_expr;
 687     case cell_vm_call_with_current_continuation2: goto call_with_current_continuation2;
 688     case cell_vm_call_with_values2: goto call_with_values2;
 689     case cell_vm_return: goto vm_return;
 690     case cell_unspecified: return r1;
 691     default: assert (0);
 692     }
 693
 694   SCM x = cell_nil;
 695   SCM y = cell_nil;
 696  evlis:
 697   if (r1 == cell_nil) goto vm_return;
 698   if (TYPE (r1) != TPAIR) goto eval;
 699   push_cc (car (r1), r1, r0, cell_vm_evlis2);
 700   goto eval;
 701  evlis2:
 702   push_cc (cdr (r2), r1, r0, cell_vm_evlis3);
 703   goto evlis;
 704  evlis3:
 705   r1 = cons (r2, r1);
 706   goto vm_return;
 707
 708  apply:
 709   switch (TYPE (car (r1)))
 710     {
 711     case TFUNCTION: {
 712       check_formals (car (r1), MAKE_NUMBER (FUNCTION (car (r1)).arity), cdr (r1));
 713       r1 = call (car (r1), cdr (r1)); /// FIXME: move into eval_apply
 714       goto vm_return;
 715     }
 716     case TCLOSURE:
 717       {
 718         SCM cl = CLOSURE (CAR (r1));
 719         SCM formals = CADR (cl);
 720         SCM body = CDDR (cl);
 721         SCM aa = CDAR (cl);
 722         aa = CDR (aa);
 723         check_formals (CAR (r1), formals, CDR (r1));
 724         SCM p = pairlis (formals, CDR (r1), aa);
 725         call_lambda (body, p, aa, r0);
 726         goto begin;
 727       }
 728       case TCONTINUATION:
 729         {
 730           x = r1;
 731           g_stack = CONTINUATION (CAR (r1));
 732           gc_pop_frame ();
 733           r1 = CADR (x);
 734           goto eval_apply;
 735         }
 736     case TSPECIAL:
 737       {
 738         switch (car (r1))
 739           {
 740           case cell_vm_apply:
 741             {
 742               push_cc (cons (CADR (r1), CADDR (r1)), r1, r0, cell_vm_return);
 743               goto apply;
 744             }
 745           case cell_vm_eval:
 746             {
 747               push_cc (CADR (r1), r1, CADDR (r1), cell_vm_return);
 748               goto eval;
 749             }
 750           case cell_call_with_current_continuation:
 751             {
 752               r1 = cdr (r1);
 753               goto call_with_current_continuation;
 754             }
 755           default: check_apply (cell_f, car (r1));
 756           }
 757       }
 758     case TSYMBOL:
 759       {
 760         if (car (r1) == cell_symbol_call_with_values)
 761           {
 762             r1 = cdr (r1);
 763             goto call_with_values;
 764           }
 765         if (car (r1) == cell_symbol_current_module)
 766           {
 767             r1 = r0;
 768             goto vm_return;
 769           }
 770         break;
 771       }
 772     case TPAIR:
 773       {
 774         switch (CAAR (r1))
 775           {
 776           case cell_symbol_lambda:
 777             {
 778               SCM formals = CADR (car (r1));
 779               SCM body = CDDR (car (r1));
 780               SCM p = pairlis (formals, cdr (r1), r0);
 781               check_formals (r1, formals, cdr (r1));
 782               call_lambda (body, p, p, r0);
 783               goto begin;
 784             }
 785           }
 786       }
 787     }
 788   push_cc (car (r1), r1, r0, cell_vm_apply2);
 789   goto eval;
 790  apply2:
 791   check_apply (r1, car (r2));
 792   r1 = cons (r1, cdr (r2));
 793   goto apply;
 794
 795  eval:
 796   switch (TYPE (r1))
 797     {
 798     case TPAIR:
 799       {
 800         switch (car (r1))
 801           {
 802 #if FIXED_PRIMITIVES
 803           case cell_symbol_car:
 804             {
 805               push_cc (CADR (r1), r1, r0, cell_vm_eval_car); goto eval;
 806             eval_car:
 807               x = r1; gc_pop_frame (); r1 = car (x); goto eval_apply;
 808             }
 809           case cell_symbol_cdr:
 810             {
 811               push_cc (CADR (r1), r1, r0, cell_vm_eval_cdr); goto eval;
 812             eval_cdr:
 813               x = r1; gc_pop_frame (); r1 = cdr (x); goto eval_apply;
 814             }
 815           case cell_symbol_cons: {
 816             push_cc (CDR (r1), r1, r0, cell_vm_eval_cons); goto evlis;
 817             eval_cons:
 818             x = r1;
 819             gc_pop_frame ();
 820             r1 = cons (CAR (x), CADR (x));
 821             goto eval_apply;
 822           }
 823           case cell_symbol_null_p:
 824             {
 825               push_cc (CADR (r1), r1, r0, cell_vm_eval_null_p);
 826               goto eval;
 827             eval_null_p:
 828               x = r1; gc_pop_frame (); r1 = null_p (x); goto eval_apply;
 829             }
 830 #endif // FIXED_PRIMITIVES
 831           case cell_symbol_quote:
 832             {
 833               x = r1; gc_pop_frame (); r1 = CADR (x); goto eval_apply;
 834             }
 835           case cell_symbol_begin: goto begin;
 836           case cell_symbol_lambda:
 837             {
 838               r1 = make_closure_ (CADR (r1), CDDR (r1), assq (cell_closure, r0));
 839               goto vm_return;
 840             }
 841           case cell_symbol_if: {r1=cdr (r1); goto vm_if;}
 842           case cell_symbol_set_x:
 843             {
 844               push_cc (car (CDDR (r1)), r1, r0, cell_vm_eval_set_x);
 845               goto eval;
 846             eval_set_x:
 847               x = r2;
 848               r1 = set_env_x (CADR (x), r1, r0);
 849               goto vm_return;
 850             }
 851           case cell_vm_macro_expand:
 852             {
 853               push_cc (CADR (r1), r1, r0, cell_vm_return);
 854               goto macro_expand;
 855             }
 856           default: {
 857             push_cc (r1, r1, r0, cell_vm_eval_macro);
 858             goto macro_expand;
 859             eval_macro:
 860             x = r2;
 861             if (r1 != r2)
 862               {
 863                 if (TYPE (r1) == TPAIR)
 864                   {
 865                     set_cdr_x (r2, cdr (r1));
 866                     set_car_x (r2, car (r1));
 867                   }
 868                 goto eval;
 869               }
 870             push_cc (car (r1), r1, r0, cell_vm_eval_check_func); goto eval;
 871             eval_check_func:
 872             push_cc (CDR (r2), r2, r0, cell_vm_eval2); goto evlis;
 873             eval2:
 874             r1 = cons (car (r2), r1);
 875             goto apply;
 876           }
 877           }
 878       }
 879     case TSYMBOL:
 880       {
 881         r1 = assert_defined (r1, assq_ref_env (r1, r0));
 882         goto vm_return;
 883       }
 884     default: {goto vm_return;}
 885     }
 886
 887   SCM macro;
 888   SCM expanders;
 889  macro_expand:
 890   if (TYPE (r1) == TPAIR
 891       && (macro = lookup_macro_ (car (r1), r0)) != cell_f)
 892     {
 893       r1 = cons (macro, CDR (r1));
 894       goto apply;
 895     }
 896   else if (TYPE (r1) == TPAIR
 897            && TYPE (CAR (r1)) == TSYMBOL
 898            && ((expanders = assq_ref_env (cell_symbol_sc_expander_alist, r0)) != cell_undefined)
 899            && ((macro = assq (CAR (r1), expanders)) != cell_f))
 900     {
 901       SCM sc_expand = assq_ref_env (cell_symbol_macro_expand, r0);
 902       if (sc_expand != cell_undefined && sc_expand != cell_f)
 903         {
 904           r1 = cons (sc_expand, cons (r1, cell_nil));
 905           goto apply;
 906         }
 907     }
 908   goto vm_return;
 909  begin:
 910   x = cell_unspecified;
 911   while (r1 != cell_nil) {
 912     if (TYPE (r1) == TPAIR && TYPE (CAR (r1)) == TPAIR)
 913       {
 914         if (CAAR (r1) == cell_symbol_begin)
 915           r1 = append2 (CDAR (r1), cdr (r1));
 916         else if (CAAR (r1) == cell_symbol_primitive_load)
 917           {
 918             push_cc (cons (cell_symbol_read_input_file, cell_nil), r1, r0, cell_vm_begin_read_input_file);
 919             goto apply;
 920           begin_read_input_file:
 921             r1 = append2 (r1, cdr (r2));
 922           }
 923       }
 924     if (CDR (r1) == cell_nil)
 925       {
 926         r1 = car (r1);
 927         goto eval;
 928       }
 929     push_cc (CAR (r1), r1, r0, cell_vm_begin2);
 930     goto eval;
 931   begin2:
 932     x = r1;
 933     r1 = CDR (r2);
 934   }
 935   r1 = x;
 936   goto vm_return;
 937
 938  vm_if:
 939   push_cc (car (r1), r1, r0, cell_vm_if_expr);
 940   goto eval;
 941  if_expr:
 942   x = r1;
 943   r1 = r2;
 944   if (x != cell_f)
 945     {
 946       r1 = CADR (r1);
 947       goto eval;
 948     }
 949   if (CDDR (r1) != cell_nil)
 950     {
 951       r1 = car (CDDR (r1));
 952       goto eval;
 953     }
 954   r1 = cell_unspecified;
 955   goto vm_return;
 956
 957  call_with_current_continuation:
 958   gc_push_frame ();
 959   x = MAKE_CONTINUATION (g_continuations++);
 960   gc_pop_frame ();
 961   push_cc (cons (car (r1), cons (x, cell_nil)), x, r0, cell_vm_call_with_current_continuation2);
 962   goto apply;
 963  call_with_current_continuation2:
 964   CONTINUATION (r2) = g_stack;
 965   goto vm_return;
 966
 967  call_with_values:
 968   push_cc (cons (car (r1), cell_nil), r1, r0, cell_vm_call_with_values2);
 969   goto apply;
 970  call_with_values2:
 971   if (TYPE (r1) == TVALUES)
 972     r1 = CDR (r1);
 973   r1 = cons (CADR (r2), r1);
 974   goto apply;
 975
 976  vm_return:
 977   x = r1;
 978   gc_pop_frame ();
 979   r1 = x;
 980   goto eval_apply;
 981 }
 982
 983 SCM
 984 gc_peek_frame () ///((internal))
 985 {
 986   SCM frame = CAR (g_stack);
 987   r1 = CAR (frame);
 988   r2 = CADR (frame);
 989   r3 = CAR (CDDR (frame));
 990   r0 = CADR (CDDR (frame));
 991   return frame;
 992 }
 993
 994 SCM
 995 gc_pop_frame () ///((internal))
 996 {
 997   SCM frame = gc_peek_frame (g_stack);
 998   g_stack = cdr (g_stack);
 999   return frame;
1000 }
1001
1002 SCM
1003 mes_g_stack (SCM a) ///((internal))
1004 {
1005   r0 = a;
1006   r1 = MAKE_CHAR (0);
1007   r2 = MAKE_CHAR (0);
1008   r3 = MAKE_CHAR (0);
1009   g_stack = cons (cell_nil, cell_nil);
1010   return r0;
1011 }
1012
1013 //\f Environment setup
1014 SCM
1015 make_tmps (struct scm* cells)
1016 {
1017   tmp = g_free++;
1018   cells[tmp].type = TCHAR;
1019   tmp_num = g_free++;
1020   cells[tmp_num].type = TNUMBER;
1021   tmp_num2 = g_free++;
1022   cells[tmp_num2].type = TNUMBER;
1023   return 0;
1024 }
1025
1026 //\f Posix
1027 int
1028 ungetchar (int c)
1029 {
1030   return ungetc (c, g_stdin);
1031 }
1032
1033 int
1034 peekchar ()
1035 {
1036   int c = getchar ();
1037   ungetchar (c);
1038   return c;
1039 }
1040
1041 SCM
1042 peek_byte ()
1043 {
1044   return MAKE_NUMBER (peekchar ());
1045 }
1046
1047 SCM
1048 read_byte ()
1049 {
1050   return MAKE_NUMBER (getchar ());
1051 }
1052
1053 SCM
1054 unread_byte (SCM i)
1055 {
1056   ungetchar (VALUE (i));
1057   return i;
1058 }
1059
1060 SCM
1061 write_byte (SCM x) ///((arity . n))
1062 {
1063   SCM c = car (x);
1064   SCM p = cdr (x);
1065   int fd = 1;
1066   if (TYPE (p) == TPAIR && TYPE (car (p)) == TNUMBER) fd = VALUE (car (p));
1067   //FILE *f = fd == 1 ? stdout : stderr;
1068 #if __GNUC__
1069   assert (TYPE (c) == TNUMBER || TYPE (c) == TCHAR);
1070 #endif
1071   //  fputc (VALUE (c), f);
1072   char cc = VALUE (c);
1073   write (1, (char*)&cc, fd);
1074   return c;
1075 }
1076
1077 char string_to_cstring_buf[1024];
1078 char const*
1079 string_to_cstring (SCM s)
1080 {
1081   //static char buf[1024];
1082   //char *p = buf;
1083   char *p = string_to_cstring_buf;
1084   s = STRING(s);
1085   while (s != cell_nil)
1086     {
1087       *p++ = VALUE (car (s));
1088       s = cdr (s);
1089     }
1090   *p = 0;
1091   //return buf;
1092   return string_to_cstring_buf;
1093 }
1094
1095 SCM
1096 getenv_ (SCM s) ///((name . "getenv"))
1097 {
1098 #if 0
1099   char *p = getenv (string_to_cstring (s));
1100   return p ? MAKE_STRING (cstring_to_list (p)) : cell_f;
1101 #else
1102   return cell_t;
1103 #endif
1104 }
1105
1106 SCM
1107 open_input_file (SCM file_name)
1108 {
1109   return MAKE_NUMBER (open (string_to_cstring (file_name), O_RDONLY));
1110   // char *s = string_to_cstring (file_name);
1111   // int x = open (s, 0);
1112   // return MAKE_NUMBER (x);
1113 }
1114
1115 SCM
1116 current_input_port ()
1117 {
1118   return MAKE_NUMBER (g_stdin);
1119 }
1120
1121 SCM
1122 set_current_input_port (SCM port)
1123 {
1124   g_stdin = VALUE (port) ? VALUE (port) : STDIN;
1125   return current_input_port ();
1126 }
1127
1128 SCM
1129 force_output (SCM p) ///((arity . n))
1130 {
1131 #if 0
1132   //FIXME
1133   int fd = 1;
1134   if (TYPE (p) == TPAIR && TYPE (car (p)) == TNUMBER) fd = VALUE (car (p));
1135   FILE *f = fd == 1 ? stdout : stderr;
1136   fflush (f);
1137 #endif
1138   return cell_unspecified;
1139 }
1140
1141 //\f Math
1142 SCM
1143 greater_p (SCM x) ///((name . ">") (arity . n))
1144 {
1145   int n = INT_MAX;
1146   while (x != cell_nil)
1147     {
1148       assert (TYPE (car (x)) == TNUMBER);
1149       if (VALUE (car (x)) >= n) return cell_f;
1150       n = VALUE (car (x));
1151       x = cdr (x);
1152     }
1153   return cell_t;
1154 }
1155
1156 SCM
1157 less_p (SCM x) ///((name . "<") (arity . n))
1158 {
1159   int n = INT_MIN;
1160   while (x != cell_nil)
1161     {
1162       assert (TYPE (car (x)) == TNUMBER);
1163       if (VALUE (car (x)) <= n) return cell_f;
1164       n = VALUE (car (x));
1165       x = cdr (x);
1166     }
1167   return cell_t;
1168 }
1169
1170 SCM
1171 is_p (SCM x) ///((name . "=") (arity . n))
1172 {
1173   if (x == cell_nil) return cell_t;
1174   assert (TYPE (car (x)) == TNUMBER);
1175   int n = VALUE (car (x));
1176   x = cdr (x);
1177   while (x != cell_nil)
1178     {
1179       if (VALUE (car (x)) != n) return cell_f;
1180       x = cdr (x);
1181     }
1182   return cell_t;
1183 }
1184
1185 SCM
1186 minus (SCM x) ///((name . "-") (arity . n))
1187 {
1188   SCM a = car (x);
1189   assert (TYPE (a) == TNUMBER);
1190   int n = VALUE (a);
1191   x = cdr (x);
1192   if (x == cell_nil)
1193     n = -n;
1194   while (x != cell_nil)
1195     {
1196       assert (TYPE (car (x)) == TNUMBER);
1197 #if __GNUC__
1198       n -= VALUE (car (x));
1199 #else
1200       n = n - VALUE (car (x));
1201 #endif
1202       x = cdr (x);
1203     }
1204   return MAKE_NUMBER (n);
1205 }
1206
1207 SCM
1208 plus (SCM x) ///((name . "+") (arity . n))
1209 {
1210   int n = 0;
1211   while (x != cell_nil)
1212     {
1213       assert (TYPE (car (x)) == TNUMBER);
1214 #if __GNUC__
1215       n += VALUE (car (x));
1216 #else
1217       n = n + VALUE (car (x));
1218 #endif
1219       x = cdr (x);
1220     }
1221   return MAKE_NUMBER (n);
1222 }
1223
1224 SCM
1225 divide (SCM x) ///((name . "/") (arity . n))
1226 {
1227   int n = 1;
1228   if (x != cell_nil) {
1229     assert (TYPE (car (x)) == TNUMBER);
1230     n = VALUE (car (x));
1231     x = cdr (x);
1232   }
1233   while (x != cell_nil)
1234     {
1235       assert (TYPE (car (x)) == TNUMBER);
1236 #if __GNUC__
1237       n /= VALUE (car (x));
1238 #else
1239       n = n / VALUE (car (x));
1240 #endif
1241       x = cdr (x);
1242     }
1243   return MAKE_NUMBER (n);
1244 }
1245
1246 SCM
1247 modulo (SCM a, SCM b)
1248 {
1249   assert (TYPE (a) == TNUMBER);
1250   assert (TYPE (b) == TNUMBER);
1251   int x = VALUE (a);
1252   while (x < 0) x += VALUE (b);
1253   return MAKE_NUMBER (x % VALUE (b));
1254 }
1255
1256 SCM
1257 multiply (SCM x) ///((name . "*") (arity . n))
1258 {
1259   int n = 1;
1260   while (x != cell_nil)
1261     {
1262       assert (TYPE (car (x)) == TNUMBER);
1263 #if __GNUC__
1264       n *= VALUE (car (x));
1265 #else
1266       n = n * VALUE (car (x));
1267 #endif
1268       x = cdr (x);
1269     }
1270   return MAKE_NUMBER (n);
1271 }
1272
1273 SCM
1274 logior (SCM x) ///((arity . n))
1275 {
1276   int n = 0;
1277   while (x != cell_nil)
1278     {
1279       assert (TYPE (car (x)) == TNUMBER);
1280 #if __GNUC__
1281       n |= VALUE (car (x));
1282 #else
1283       n = n | VALUE (car (x));
1284 #endif
1285       x = cdr (x);
1286     }
1287   return MAKE_NUMBER (n);
1288 }
1289
1290 SCM
1291 ash (SCM n, SCM count)
1292 {
1293   assert (TYPE (n) == TNUMBER);
1294   assert (TYPE (count) == TNUMBER);
1295   int cn = VALUE (n);
1296   int ccount = VALUE (count);
1297   return MAKE_NUMBER ((ccount < 0) ? cn >> -ccount : cn << ccount);
1298 }
1299
1300 //\f Lib [rest of]
1301
1302 int g_depth;
1303
1304 SCM
1305 display_helper (SCM x, int cont, char* sep, int fd)
1306 {
1307   fputs (sep, fd);
1308   if (g_depth == 0) return cell_unspecified;
1309   g_depth = g_depth - 1;
1310
1311   switch (TYPE (x))
1312     {
1313     case TCHAR:
1314       {
1315         fputs ("#\\", fd);
1316         putc (VALUE (x), fd);
1317         break;
1318       }
1319     case TFUNCTION:
1320       {
1321         fputs ("#<procedure ", fd);
1322         char *p = "?";
1323         if (FUNCTION (x).name != 0)
1324           p = FUNCTION (x).name;
1325         fputs (p, fd);
1326         fputs ("[", fd);
1327         fputs (itoa (CDR (x)), fd);
1328         fputs (",", fd);
1329         fputs (itoa (x), fd);
1330         fputs ("]>", fd);
1331         break;
1332       }
1333     case TMACRO:
1334       {
1335         fputs ("#<macro ", fd);
1336         display_helper (cdr (x), cont, "", fd);
1337         fputs (">", fd);
1338         break;
1339       }
1340     case TNUMBER:
1341       {
1342         fputs (itoa (VALUE (x)), fd);
1343         break;
1344       }
1345     case TPAIR:
1346       {
1347         if (!cont) fputs ("(", fd);
1348         if (x && x != cell_nil) fdisplay_ (CAR (x), fd);
1349         if (CDR (x) && TYPE (CDR (x)) == TPAIR)
1350           display_helper (CDR (x), 1, " ", fd);
1351         else if (CDR (x) && CDR (x) != cell_nil)
1352           {
1353             if (TYPE (CDR (x)) != TPAIR)
1354               fputs (" . ", fd);
1355             fdisplay_ (CDR (x), fd);
1356           }
1357         if (!cont) fputs (")", fd);
1358         break;
1359       }
1360     case TSPECIAL:
1361 #if __NYACC__
1362       // FIXME
1363       //{}
1364       {
1365         SCM t = CAR (x);
1366         while (t && t != cell_nil)
1367           {
1368             putc (VALUE (CAR (t)), fd);
1369             t = CDR (t);
1370           }
1371         break;
1372       }
1373 #endif
1374     case TSTRING:
1375 #if __NYACC__
1376       // FIXME
1377       {
1378         SCM t = CAR (x);
1379         while (t && t != cell_nil)
1380           {
1381             putc (VALUE (CAR (t)), fd);
1382             t = CDR (t);
1383           }
1384         break;
1385       }
1386 #endif
1387     case TSYMBOL:
1388       {
1389         SCM t = CAR (x);
1390         while (t && t != cell_nil)
1391           {
1392             putc (VALUE (CAR (t)), fd);
1393             t = CDR (t);
1394           }
1395         break;
1396       }
1397     default:
1398       {
1399         fputs ("<", fd);
1400         fputs (itoa (TYPE (x)), fd);
1401         fputs (":", fd);
1402         fputs (itoa (x), fd);
1403         fputs (">", fd);
1404         break;
1405       }
1406     }
1407   return 0;
1408 }
1409
1410 SCM
1411 display_ (SCM x)
1412 {
1413   g_depth = 5;
1414   return display_helper (x, 0, "", STDOUT);
1415 }
1416
1417 SCM
1418 display_error_ (SCM x)
1419 {
1420   g_depth = 5;
1421   return display_helper (x, 0, "", STDERR);
1422 }
1423
1424 SCM
1425 fdisplay_ (SCM x, int fd) ///((internal))
1426 {
1427   g_depth = 5;
1428   return display_helper (x, 0, "", fd);
1429 }
1430
1431 SCM
1432 exit_ (SCM x) ///((name . "exit"))
1433 {
1434   assert (TYPE (x) == TNUMBER);
1435   exit (VALUE (x));
1436 }
1437
1438 SCM
1439 xassq (SCM x, SCM a) ///for speed in core only
1440 {
1441   while (a != cell_nil && x != CDAR (a)) a = CDR (a);
1442   return a != cell_nil ? CAR (a) : cell_f;
1443 }
1444
1445 //\f Jam Collector
1446 SCM g_symbol_max;
1447
1448 SCM
1449 gc_init_cells () ///((internal))
1450 {
1451   //return 0;
1452   //g_cells = (scm *)malloc (ARENA_SIZE);
1453   //int size = ARENA_SIZE * sizeof (struct scm);
1454   int size = ARENA_SIZE * 12;
1455 #if MES_GC
1456   size = size * 2;
1457 #endif
1458 #if __GNUC__
1459   arena = (char*)malloc (size);
1460 #else
1461   char *p = 0;
1462   p = malloc (size);
1463   arena = p;
1464 #endif
1465   g_cells = arena;
1466   return 0;
1467   //g_cells = (scm *)malloc (2*ARENA_SIZE*sizeof(scm));
1468
1469   TYPE (0) = TVECTOR;
1470   LENGTH (0) = 1000;
1471   VECTOR (0) = 0;
1472   g_cells++;
1473   TYPE (0) = TCHAR;
1474   VALUE (0) = 'c';
1475   return 0;
1476 }
1477
1478 SCM
1479 gc_init_news () ///((internal))
1480 {
1481   eputs ("gc_init_news\n");
1482   ///g_news = g_cells-1 + ARENA_SIZE;
1483   //g_news = g_cells + ARENA_SIZE * 12 + GC_SAFETY * 6;
1484   char *p = g_cells;
1485   // g_news = g_cells;
1486   int halfway = ARENA_SIZE * 12;
1487   int safety = GC_SAFETY * 12;
1488   safety = safety / 2;
1489   halfway = halfway + safety;
1490   // g_news = g_news + halfway;
1491   p = p + halfway;
1492   g_news = p;
1493   eputs ("g_cells=");
1494   eputs (itoa (g_cells));
1495   eputs (" size=");
1496   eputs (itoa (halfway));
1497   eputs (" news=");
1498   eputs (itoa (g_news));
1499   eputs (" news - cells=");
1500   char * c = g_cells;
1501   eputs (itoa (p - c));
1502   eputs ("\n");
1503
1504
1505   NTYPE (0) = TVECTOR;
1506   NLENGTH (0) = 1000;
1507   NVECTOR (0) = 0;
1508   g_news++;
1509   NTYPE (0) = TCHAR;
1510   NVALUE (0) = 'n';
1511   return 0;
1512 }
1513
1514 // INIT NEWS
1515
1516 SCM
1517 mes_symbols () ///((internal))
1518 {
1519   gc_init_cells ();
1520 #if MES_GC
1521   gc_init_news ();
1522 #endif
1523
1524   #include "mini-mes.symbols.i"
1525
1526   g_symbol_max = g_free;
1527   make_tmps (g_cells);
1528
1529   g_symbols = 0;
1530   for (int i=1; i<g_symbol_max; i++)
1531     g_symbols = cons (i, g_symbols);
1532
1533   SCM a = cell_nil;
1534
1535   #include "mini-mes.symbol-names.i"
1536
1537   a = acons (cell_symbol_mes_version, MAKE_STRING (cstring_to_list (VERSION)), a);
1538   a = acons (cell_symbol_mes_prefix, MAKE_STRING (cstring_to_list (PREFIX)), a);
1539
1540   a = acons (cell_symbol_dot, cell_dot, a);
1541   a = acons (cell_symbol_begin, cell_begin, a);
1542   a = acons (cell_symbol_call_with_values, cell_symbol_call_with_values, a);
1543   a = acons (cell_symbol_current_module, cell_symbol_current_module, a);
1544   a = acons (cell_symbol_call_with_current_continuation, cell_call_with_current_continuation, a);
1545   a = acons (cell_symbol_sc_expand, cell_f, a);
1546
1547 #if __GNUC__
1548   a = acons (cell_symbol_gnuc, cell_t, a);
1549   a = acons (cell_symbol_mesc, cell_f, a);
1550 #else
1551   a = acons (cell_symbol_gnuc, cell_f, a);
1552   a = acons (cell_symbol_mesc, cell_t, a);
1553 #endif
1554
1555   a = acons (cell_closure, a, a);
1556
1557   return a;
1558 }
1559
1560 SCM
1561 mes_environment () ///((internal))
1562 {
1563   SCM a = 0;
1564   a = mes_symbols ();
1565   a = mes_g_stack (a);
1566   return a;
1567 }
1568
1569 SCM
1570 mes_builtins (SCM a) ///((internal))
1571 {
1572   #include "mini-mes.i"
1573
1574 // Do not sort: Order of these includes define builtins
1575 // #include "lib.i"
1576 // #include "math.i"
1577 // #include "posix.i"
1578 #include "mini-vector.i"
1579 #include "mini-gc.i"
1580 // #include "reader.i"
1581
1582 #include "mini-gc.environment.i"
1583 // #include "lib.environment.i"
1584 // #include "math.environment.i"
1585 #include "mini-mes.environment.i"
1586 // #include "posix.environment.i"
1587 // #include "reader.environment.i"
1588 #include "mini-vector.environment.i"
1589
1590   return a;
1591 }
1592
1593 SCM
1594 bload_env (SCM a) ///((internal))
1595 {
1596   char *mo = "module/mes/read-0-32.mo";
1597   g_stdin = open (mo, 0);
1598   if (g_stdin < 0) {eputs ("no such file: ");eputs (mo);eputs ("\n");return 1;}
1599   assert (getchar () == 'M');
1600   assert (getchar () == 'E');
1601   assert (getchar () == 'S');
1602   eputs ("*GOT MES*\n");
1603   g_stack = getchar () << 8;
1604   g_stack += getchar ();
1605
1606   char *p = (char*)g_cells;
1607   int c = getchar ();
1608   while (c != -1)
1609     {
1610       *p++ = c;
1611       c = getchar ();
1612     }
1613   g_free = (p-(char*)g_cells) / sizeof (struct scm);
1614   gc_peek_frame ();
1615   g_symbols = r1;
1616   g_stdin = STDIN;
1617   r0 = mes_builtins (r0);
1618
1619 #if __GNUC__
1620   set_env_x (cell_symbol_gnuc, cell_t, r0);
1621   set_env_x (cell_symbol_mesc, cell_f, r0);
1622 #else
1623   set_env_x (cell_symbol_gnuc, cell_f, r0);
1624   set_env_x (cell_symbol_mesc, cell_t, r0);
1625 #endif
1626
1627   if (g_debug)
1628     {
1629       eputs ("symbols: ");
1630       SCM s = g_symbols;
1631       while (s && s != cell_nil) {
1632         display_error_ (CAR (s));
1633         eputs (" ");
1634         s = CDR (s);
1635       }
1636       eputs ("\n");
1637       eputs ("functions: ");
1638       eputs (itoa (g_function));
1639       eputs ("\n");
1640       for (int i = 0; i < g_function; i++)
1641         {
1642           eputs ("[");
1643           eputs (itoa (i));
1644           eputs ("]: ");
1645           eputs (g_functions[i].name);
1646           eputs ("\n");
1647         }
1648       //display_error_ (r0);
1649       //puts ("\n");
1650     }
1651   return r2;
1652 }
1653
1654 // #include "math.c"
1655 // #include "posix.c"
1656 // #include "lib.c"
1657 // #include "reader.c"
1658 #include "vector.c"
1659 #include "gc.c"
1660
1661 int
1662 main (int argc, char *argv[])
1663 {
1664   eputs ("Hello mini-mes!\n");
1665 #if _POSIX_SOURCE
1666   g_debug = getenv ("MES_DEBUG");
1667   eputs ("g_debug=");
1668   eputs (itoa (g_debug));
1669   eputs ("\n");
1670   if (getenv ("MES_ARENA")) ARENA_SIZE = atoi (getenv ("MES_ARENA"));
1671 #endif
1672   g_debug = 1;
1673   if (argc > 1 && !strcmp (argv[1], "--help")) return eputs ("Usage: mes [--dump|--load] < FILE");
1674 #if __GNUC__
1675   if (argc > 1 && !strcmp (argv[1], "--version")) {eputs ("Mes ");return eputs (VERSION);};
1676 #else
1677   if (argc > 1 && !strcmp (argv[1], "--version")) {eputs ("Mes ");return eputs ("0.4");};
1678 #endif
1679   g_stdin = STDIN;
1680
1681   r0 = mes_environment ();
1682
1683 #if MES_MINI
1684   SCM program = bload_env (r0);
1685 #else
1686   SCM program = (argc > 1 && !strcmp (argv[1], "--load"))
1687     ? bload_env (r0) : load_env (r0);
1688   if (argc > 1 && !strcmp (argv[1], "--dump")) return dump ();
1689 #endif
1690
1691   SCM lst = cell_nil;
1692   for (int i=argc-1; i>=0; i--) lst = cons (MAKE_STRING (cstring_to_list (argv[i])), lst);
1693   r0 = acons (cell_symbol_argv, lst, r0);
1694   push_cc (r2, cell_unspecified, r0, cell_unspecified);
1695   if (g_debug)
1696     {
1697       eputs ("program: ");
1698       display_error_ (r1);
1699       eputs ("\n");
1700     }
1701   r3 = cell_vm_begin;
1702   r1 = eval_apply ();
1703   display_error_ (r1);
1704   eputs ("\n");
1705
1706 #if !MES_MINI
1707   gc (g_stack);
1708 #endif
1709   if (g_debug)
1710     {
1711       eputs ("\nstats: [");
1712       eputs (itoa (g_free));
1713       eputs ("]\n");
1714     }
1715   return 0;
1716 }
1717
1718 #if __GNUC__
1719 #include "mstart.c"
1720 #endif