src/mes.c

   1 /* -*-comment-start: "//";comment-end:""-*-
   2  * Mes --- Maxwell Equations of Software
   3  * Copyright © 2016,2017,2018 Jan (janneke) 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 #include <stdio.h>
  22 #include <assert.h>
  23 #include <stdlib.h>
  24 #include <string.h>
  25 #include <mlibc.h>
  26
  27 //#define MES_MINI 1
  28 #if _POSIX_SOURCE
  29 int ARENA_SIZE = 300000000; // 32b: 4GiB, 64b: 8 GiB
  30 #else
  31 int ARENA_SIZE = 200000; // 32b: 2MiB, 64b: 4 MiB
  32 #endif
  33 int MAX_ARENA_SIZE = 300000000;
  34
  35 int JAM_SIZE = 20000;
  36 int GC_SAFETY = 2000;
  37
  38 char *g_arena = 0;
  39 typedef int SCM;
  40
  41 int g_debug = 0;
  42 int g_free = 0;
  43
  44 SCM g_continuations = 0;
  45 SCM g_symbols = 0;
  46 SCM g_stack = 0;
  47 // a/env
  48 SCM r0 = 0;
  49 // param 1
  50 SCM r1 = 0;
  51 // save 2+load/dump
  52 SCM r2 = 0;
  53 // continuation
  54 SCM r3 = 0;
  55 // macro
  56 SCM g_macros = 1; // cell_nil
  57
  58
  59 enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TREF, TSPECIAL, TSTRING, TSYMBOL, TVALUES, TVARIABLE, TVECTOR, TBROKEN_HEART};
  60
  61 #if !_POSIX_SOURCE
  62 struct scm {
  63   enum type_t type;
  64   SCM car;
  65   SCM cdr;
  66 };
  67 struct function {
  68   int (*function) (void);
  69   int arity;
  70   char *name;
  71 };
  72 #else
  73 typedef SCM (*function0_t) (void);
  74 typedef SCM (*function1_t) (SCM);
  75 typedef SCM (*function2_t) (SCM, SCM);
  76 typedef SCM (*function3_t) (SCM, SCM, SCM);
  77 typedef SCM (*functionn_t) (SCM);
  78 struct function {
  79   union {
  80     function0_t function0;
  81     function1_t function1;
  82     function2_t function2;
  83     function3_t function3;
  84     functionn_t functionn;
  85   };
  86   int arity;
  87   char const *name;
  88 };
  89 struct scm {
  90   enum type_t type;
  91   union {
  92     char const* name;
  93     SCM car;
  94     SCM ref;
  95     SCM string;
  96     SCM variable;
  97     int length;
  98   };
  99   union {
 100     int value;
 101     int function;
 102     SCM cdr;
 103     SCM closure;
 104     SCM continuation;
 105     SCM macro;
 106     SCM vector;
 107     int hits;
 108   };
 109 };
 110 #endif
 111
 112 #if __MESC__
 113 //FIXME
 114 char *foobar = 0;
 115 struct scm *g_cells = foobar;
 116 struct scm *g_news = foobar;
 117 #else
 118 struct scm *g_cells = 0;
 119 struct scm *g_news = 0;
 120 #endif
 121
 122 struct scm scm_nil = {TSPECIAL, "()",0};
 123 struct scm scm_f = {TSPECIAL, "#f",0};
 124 struct scm scm_t = {TSPECIAL, "#t",0};
 125 struct scm scm_dot = {TSPECIAL, ".",0};
 126 struct scm scm_arrow = {TSPECIAL, "=>",0};
 127 struct scm scm_undefined = {TSPECIAL, "*undefined*",0};
 128 struct scm scm_unspecified = {TSPECIAL, "*unspecified*",0};
 129 struct scm scm_closure = {TSPECIAL, "*closure*",0};
 130 struct scm scm_circular = {TSPECIAL, "*circular*",0};
 131 struct scm scm_begin = {TSPECIAL, "*begin*",0};
 132
 133 struct scm scm_symbol_dot = {TSYMBOL, "*dot*",0};
 134 struct scm scm_symbol_lambda = {TSYMBOL, "lambda",0};
 135 struct scm scm_symbol_begin = {TSYMBOL, "begin",0};
 136 struct scm scm_symbol_if = {TSYMBOL, "if",0};
 137 struct scm scm_symbol_quote = {TSYMBOL, "quote",0};
 138 struct scm scm_symbol_define = {TSYMBOL, "define",0};
 139 struct scm scm_symbol_define_macro = {TSYMBOL, "define-macro",0};
 140
 141 struct scm scm_symbol_quasiquote = {TSYMBOL, "quasiquote", 0};
 142 struct scm scm_symbol_unquote = {TSYMBOL, "unquote", 0};
 143 struct scm scm_symbol_unquote_splicing = {TSYMBOL, "unquote-splicing", 0};
 144 struct scm scm_symbol_syntax = {TSYMBOL, "syntax",0};
 145 struct scm scm_symbol_quasisyntax = {TSYMBOL, "quasisyntax", 0};
 146 struct scm scm_symbol_unsyntax = {TSYMBOL, "unsyntax", 0};
 147 struct scm scm_symbol_unsyntax_splicing = {TSYMBOL, "unsyntax-splicing", 0};
 148
 149 struct scm scm_symbol_set_x = {TSYMBOL, "set!",0};
 150
 151 struct scm scm_symbol_sc_expand = {TSYMBOL, "sc-expand",0};
 152 struct scm scm_symbol_macro_expand = {TSYMBOL, "macro-expand",0};
 153 struct scm scm_symbol_portable_macro_expand = {TSYMBOL, "portable-macro-expand",0};
 154 struct scm scm_symbol_sc_expander_alist = {TSYMBOL, "*sc-expander-alist*",0};
 155
 156 struct scm scm_symbol_call_with_values = {TSYMBOL, "call-with-values",0};
 157 struct scm scm_call_with_current_continuation = {TSPECIAL, "*call/cc*",0};
 158 struct scm scm_symbol_call_with_current_continuation = {TSYMBOL, "call-with-current-continuation",0};
 159 struct scm scm_symbol_current_module = {TSYMBOL, "current-module",0};
 160 struct scm scm_symbol_primitive_load = {TSYMBOL, "primitive-load",0};
 161 struct scm scm_symbol_read_input_file = {TSYMBOL, "read-input-file",0};
 162 struct scm scm_symbol_write = {TSYMBOL, "write",0};
 163 struct scm scm_symbol_display = {TSYMBOL, "display",0};
 164
 165 struct scm scm_symbol_throw = {TSYMBOL, "throw",0};
 166 struct scm scm_symbol_not_a_number = {TSYMBOL, "not-a-number",0};
 167 struct scm scm_symbol_not_a_pair = {TSYMBOL, "not-a-pair",0};
 168 struct scm scm_symbol_system_error = {TSYMBOL, "system-error",0};
 169 struct scm scm_symbol_wrong_number_of_args = {TSYMBOL, "wrong-number-of-args",0};
 170 struct scm scm_symbol_wrong_type_arg = {TSYMBOL, "wrong-type-arg",0};
 171 struct scm scm_symbol_unbound_variable = {TSYMBOL, "unbound-variable",0};
 172
 173 struct scm scm_symbol_argv = {TSYMBOL, "%argv",0};
 174 struct scm scm_symbol_mes_prefix = {TSYMBOL, "%prefix",0};
 175 struct scm scm_symbol_mes_version = {TSYMBOL, "%version",0};
 176
 177 struct scm scm_symbol_car = {TSYMBOL, "car",0};
 178 struct scm scm_symbol_cdr = {TSYMBOL, "cdr",0};
 179 struct scm scm_symbol_pmatch_car = {TSYMBOL, "pmatch-car",0};
 180 struct scm scm_symbol_pmatch_cdr = {TSYMBOL, "pmatch-cdr",0};
 181
 182 struct scm scm_vm_evlis = {TSPECIAL, "*vm-evlis*",0};
 183 struct scm scm_vm_evlis2 = {TSPECIAL, "*vm-evlis2*",0};
 184 struct scm scm_vm_evlis3 = {TSPECIAL, "*vm-evlis3*",0};
 185 struct scm scm_vm_apply = {TSPECIAL, "core:apply",0};
 186 struct scm scm_vm_apply2 = {TSPECIAL, "*vm-apply2*",0};
 187 struct scm scm_vm_eval = {TSPECIAL, "core:eval",0};
 188
 189 struct scm scm_vm_eval_pmatch_car = {TSPECIAL, "*vm-eval-pmatch-car*",0};
 190 struct scm scm_vm_eval_pmatch_cdr = {TSPECIAL, "*vm-eval-pmatch-cdr*",0};
 191 struct scm scm_vm_eval_define = {TSPECIAL, "*vm-eval-define*",0};
 192
 193 struct scm scm_vm_eval_set_x = {TSPECIAL, "*vm-eval-set!*",0};
 194 struct scm scm_vm_eval_macro_expand_eval = {TSPECIAL, "*vm:eval-macro-expand-eval*",0};
 195 struct scm scm_vm_eval_macro_expand_expand = {TSPECIAL, "*vm:eval-macro-expand-expand*",0};
 196 struct scm scm_vm_eval_check_func = {TSPECIAL, "*vm-eval-check-func*",0};
 197 struct scm scm_vm_eval2 = {TSPECIAL, "*vm-eval2*",0};
 198 struct scm scm_vm_macro_expand = {TSPECIAL, "core:macro-expand",0};
 199 struct scm scm_vm_macro_expand_define = {TSPECIAL, "*vm:core:macro-expand-define*",0};
 200 struct scm scm_vm_macro_expand_define_macro = {TSPECIAL, "*vm:core:macro-expand-define-macro*",0};
 201 struct scm scm_vm_macro_expand_lambda = {TSPECIAL, "*vm:core:macro-expand-lambda*",0};
 202 struct scm scm_vm_macro_expand_set_x = {TSPECIAL, "*vm:core:macro-expand-set!*",0};
 203 struct scm scm_vm_begin_expand_primitive_load = {TSPECIAL, "*vm:core:begin-expand-primitive-load*",0};
 204 struct scm scm_vm_begin_primitive_load = {TSPECIAL, "*vm:core:begin-primitive-load*",0};
 205 struct scm scm_vm_macro_expand_car = {TSPECIAL, "*vm:core:macro-expand-car*",0};
 206 struct scm scm_vm_macro_expand_cdr = {TSPECIAL, "*vm:macro-expand-cdr*",0};
 207 struct scm scm_vm_begin_expand = {TSPECIAL, "core:eval-expand",0};
 208 struct scm scm_vm_begin_expand_eval = {TSPECIAL, "*vm:begin-expand-eval*",0};
 209 struct scm scm_vm_begin_expand_macro = {TSPECIAL, "*vm:begin-expand-macro*",0};
 210 struct scm scm_vm_begin = {TSPECIAL, "*vm-begin*",0};
 211 struct scm scm_vm_begin_read_input_file = {TSPECIAL, "*vm-begin-read-input-file*",0};
 212 struct scm scm_vm_begin_eval = {TSPECIAL, "*vm:begin-eval*",0};
 213 struct scm scm_vm_if = {TSPECIAL, "*vm-if*",0};
 214 struct scm scm_vm_if_expr = {TSPECIAL, "*vm-if-expr*",0};
 215 struct scm scm_vm_call_with_values2 = {TSPECIAL, "*vm-call-with-values2*",0};
 216 struct scm scm_vm_call_with_current_continuation2 = {TSPECIAL, "*vm-call-with-current-continuation2*",0};
 217 struct scm scm_vm_return = {TSPECIAL, "*vm-return*",0};
 218
 219 struct scm scm_symbol_gnuc = {TSYMBOL, "%gnuc",0};
 220 struct scm scm_symbol_mesc = {TSYMBOL, "%mesc",0};
 221
 222 struct scm scm_test = {TSYMBOL, "test",0};
 223
 224 #if !_POSIX_SOURCE
 225 #include "mes.mes.symbols.h"
 226 #else
 227 #include "mes.symbols.h"
 228 #endif
 229
 230 struct function g_functions[200];
 231 int g_function = 0;
 232
 233 #if !__GNUC__ || !_POSIX_SOURCE
 234 #include "gc.mes.h"
 235 #include "lib.mes.h"
 236 #include "math.mes.h"
 237 #include "mes.mes.h"
 238 #include "posix.mes.h"
 239 #include "reader.mes.h"
 240 #include "vector.mes.h"
 241 #else
 242 #include "gc.h"
 243 #include "lib.h"
 244 #include "math.h"
 245 #include "mes.h"
 246 #include "posix.h"
 247 #include "reader.h"
 248 #include "vector.h"
 249 #endif
 250
 251 #define TYPE(x) g_cells[x].type
 252 #define CAR(x) g_cells[x].car
 253 #define CDR(x) g_cells[x].cdr
 254
 255 #define NTYPE(x) g_news[x].type
 256 #define NCAR(x) g_news[x].car
 257 #define NCDR(x) g_news[x].cdr
 258
 259 #if !_POSIX_SOURCE
 260 #define LENGTH(x) g_cells[x].car
 261 #define REF(x) g_cells[x].car
 262 #define STRING(x) g_cells[x].car
 263 #define VARIABLE(x) g_cells[x].car
 264
 265 #define CLOSURE(x) g_cells[x].cdr
 266 #define CONTINUATION(x) g_cells[x].cdr
 267
 268 #define FUNCTION(x) g_functions[g_cells[x].cdr]
 269 #define FUNCTION0(x) g_functions[g_cells[x].cdr].function
 270 #define MACRO(x) g_cells[x].cdr
 271 #define VALUE(x) g_cells[x].cdr
 272 #define VECTOR(x) g_cells[x].cdr
 273
 274 #define NLENGTH(x) g_news[x].car
 275
 276 #define NVALUE(x) g_news[x].cdr
 277 #define NVECTOR(x) g_news[x].cdr
 278
 279 #else
 280 #define CONTINUATION(x) g_cells[x].cdr
 281 #define HITS(x) g_cells[x].hits
 282 #define LENGTH(x) g_cells[x].length
 283 #define NAME(x) g_cells[x].name
 284 #define STRING(x) g_cells[x].string
 285 #define VARIABLE(x) g_cells[x].variable
 286
 287 #define CLOSURE(x) g_cells[x].closure
 288 #define MACRO(x) g_cells[x].macro
 289 #define REF(x) g_cells[x].ref
 290 #define VALUE(x) g_cells[x].value
 291 #define VECTOR(x) g_cells[x].vector
 292 #define FUNCTION(x) g_functions[g_cells[x].function]
 293 #define FUNCTION0(x) g_functions[g_cells[x].function].function0
 294
 295 #define NLENGTH(x) g_news[x].length
 296
 297 #define NVALUE(x) g_news[x].value
 298 #define NVECTOR(x) g_news[x].vector
 299 #endif
 300
 301 #define MAKE_CHAR(n) make_cell__ (TCHAR, 0, n)
 302 #define MAKE_CONTINUATION(n) make_cell__ (TCONTINUATION, n, g_stack)
 303 #define MAKE_NUMBER(n) make_cell__ (TNUMBER, 0, n)
 304 #define MAKE_REF(n) make_cell__ (TREF, n, 0)
 305 #define MAKE_STRING(x) make_cell__ (TSTRING, x, 0)
 306 #define MAKE_KEYWORD(x) make_cell__ (TKEYWORD, x, 0)
 307 #define MAKE_MACRO(name, x) make_cell__ (TMACRO, STRING (name), x)
 308
 309 #define CAAR(x) CAR (CAR (x))
 310 #define CADR(x) CAR (CDR (x))
 311 #define CDAR(x) CDR (CAR (x))
 312 #define CDDR(x) CDR (CDR (x))
 313 #define CADAR(x) CAR (CDR (CAR (x)))
 314 #define CADDR(x) CAR (CDR (CDR (x)))
 315 #define CDADAR(x) CAR (CDR (CAR (CDR (x))))
 316
 317 SCM
 318 alloc (int n)
 319 {
 320   SCM x = g_free;
 321   g_free += n;
 322   return x;
 323 }
 324
 325 SCM
 326 make_cell__ (int type, SCM car, SCM cdr)
 327 {
 328   SCM x = alloc (1);
 329   TYPE (x) = type;
 330   CAR (x) = car;
 331   CDR (x) = cdr;
 332   return x;
 333 }
 334
 335 SCM
 336 make_cell_ (SCM type, SCM car, SCM cdr)
 337 {
 338   assert (TYPE (type) == TNUMBER);
 339   int t = VALUE (type);
 340   if (t == TCHAR || t == TNUMBER)
 341     return make_cell__ (t, car ? CAR (car) : 0, cdr ? CDR (cdr) : 0);
 342   return make_cell__ (t, car, cdr);
 343 }
 344
 345 SCM
 346 make_symbol_ (SCM s) ///((internal))
 347 {
 348   SCM x = make_cell__ (TSYMBOL, s, 0);
 349   g_symbols = cons (x, g_symbols);
 350   return x;
 351 }
 352
 353 SCM
 354 list_of_char_equal_p (SCM a, SCM b) ///((internal))
 355 {
 356   while (a != cell_nil && b != cell_nil && VALUE (CAR (a)) == VALUE (CAR (b)))
 357     {
 358       assert (TYPE (CAR (a)) == TCHAR);
 359       assert (TYPE (CAR (b)) == TCHAR);
 360       a = CDR (a);
 361       b = CDR (b);
 362     }
 363   return (a == cell_nil && b == cell_nil) ? cell_t : cell_f;
 364 }
 365
 366 SCM
 367 lookup_symbol_ (SCM s)
 368 {
 369   SCM x = g_symbols;
 370   while (x)
 371     {
 372       if (list_of_char_equal_p (STRING (CAR (x)), s) == cell_t)
 373         break;
 374       x = CDR (x);
 375     }
 376   if (x)
 377     x = CAR (x);
 378   if (!x)
 379     x = make_symbol_ (s);
 380   return x;
 381 }
 382
 383 SCM
 384 type_ (SCM x)
 385 {
 386   return MAKE_NUMBER (TYPE (x));
 387 }
 388
 389 SCM
 390 car_ (SCM x)
 391 {
 392   return (TYPE (x) != TCONTINUATION
 393           && (TYPE (CAR (x)) == TPAIR // FIXME: this is weird
 394               || TYPE (CAR (x)) == TREF
 395               || TYPE (CAR (x)) == TSPECIAL
 396               || TYPE (CAR (x)) == TSYMBOL
 397               || TYPE (CAR (x)) == TSTRING)) ? CAR (x) : MAKE_NUMBER (CAR (x));
 398 }
 399
 400 SCM
 401 cdr_ (SCM x)
 402 {
 403   return (TYPE (x) != TCHAR
 404           && TYPE (x) != TNUMBER
 405           && (TYPE (CDR (x)) == TPAIR
 406               || TYPE (CDR (x)) == TREF
 407               || TYPE (CDR (x)) == TSPECIAL
 408               || TYPE (CDR (x)) == TSYMBOL
 409               || TYPE (CDR (x)) == TSTRING)) ? CDR (x) : MAKE_NUMBER (CDR (x));
 410 }
 411
 412 SCM
 413 arity_ (SCM x)
 414 {
 415   assert (TYPE (x) == TFUNCTION);
 416   return MAKE_NUMBER (FUNCTION (x).arity);
 417 }
 418
 419 SCM
 420 cons (SCM x, SCM y)
 421 {
 422   return make_cell__ (TPAIR, x, y);
 423 }
 424
 425 SCM
 426 car (SCM x)
 427 {
 428 #if !__MESC_MES__
 429   if (TYPE (x) != TPAIR)
 430     error (cell_symbol_not_a_pair, cons (x, cell_symbol_car));
 431 #endif
 432   return CAR (x);
 433 }
 434
 435 SCM
 436 cdr (SCM x)
 437 {
 438 #if !__MESC_MES__
 439   if (TYPE (x) != TPAIR)
 440     error (cell_symbol_not_a_pair, cons (x, cell_symbol_cdr));
 441 #endif
 442   return CDR (x);
 443 }
 444
 445 SCM
 446 list (SCM x) ///((arity . n))
 447 {
 448   return x;
 449 }
 450
 451 SCM
 452 null_p (SCM x)
 453 {
 454   return x == cell_nil ? cell_t : cell_f;
 455 }
 456
 457 SCM
 458 eq_p (SCM x, SCM y)
 459 {
 460   return (x == y
 461           || ((TYPE (x) == TKEYWORD && TYPE (y) == TKEYWORD
 462                && STRING (x) == STRING (y)))
 463           || (TYPE (x) == TCHAR && TYPE (y) == TCHAR
 464               && VALUE (x) == VALUE (y))
 465           || (TYPE (x) == TNUMBER && TYPE (y) == TNUMBER
 466               && VALUE (x) == VALUE (y)))
 467     ? cell_t : cell_f;
 468 }
 469
 470 SCM
 471 values (SCM x) ///((arity . n))
 472 {
 473   SCM v = cons (0, x);
 474   TYPE (v) = TVALUES;
 475   return v;
 476 }
 477
 478 SCM
 479 acons (SCM key, SCM value, SCM alist)
 480 {
 481   return cons (cons (key, value), alist);
 482 }
 483
 484 int
 485 length__ (SCM x)
 486 {
 487   int n = 0;
 488   while (x != cell_nil)
 489     {
 490       n++;
 491       if (TYPE (x) != TPAIR)
 492         return -1;
 493       x = CDR (x);
 494     }
 495   return n;
 496 }
 497
 498 SCM
 499 length (SCM x)
 500 {
 501   return MAKE_NUMBER (length__ (x));
 502 }
 503
 504 SCM apply (SCM, SCM, SCM);
 505
 506 SCM
 507 error (SCM key, SCM x)
 508 {
 509 #if !__MESC_MES__
 510   SCM throw;
 511   if ((throw = assq_ref_env (cell_symbol_throw, r0)) != cell_undefined)
 512     return apply (throw, cons (key, cons (x, cell_nil)), r0);
 513 #endif
 514   display_error_ (key);
 515   eputs (": ");
 516   write_error_ (x);
 517   eputs ("\n");
 518   exit (1);
 519 }
 520
 521 SCM
 522 string_to_list (char const* s, int i)
 523 {
 524   SCM p = cell_nil;
 525   while (i--)
 526     p = cons (MAKE_CHAR (s[i]), p);
 527   return p;
 528 }
 529
 530 SCM
 531 cstring_to_list (char const* s)
 532 {
 533   return string_to_list (s, strlen (s));
 534 }
 535
 536 // \f extra lib
 537 SCM
 538 assert_defined (SCM x, SCM e) ///((internal))
 539 {
 540   if (e == cell_undefined)
 541     return error (cell_symbol_unbound_variable, x);
 542   return e;
 543 }
 544
 545 SCM
 546 check_formals (SCM f, SCM formals, SCM args) ///((internal))
 547 {
 548   int flen = (TYPE (formals) == TNUMBER) ? VALUE (formals) : VALUE (length (formals));
 549   int alen = VALUE (length (args));
 550   if (alen != flen && alen != -1 && flen != -1)
 551     {
 552       char *s = "apply: wrong number of arguments; expected: ";
 553       eputs (s);
 554       eputs (itoa (flen));
 555       eputs (", got: ");
 556       eputs (itoa (alen));
 557       eputs ("\n");
 558       write_error_ (f);
 559       SCM e = MAKE_STRING (cstring_to_list (s));
 560       return error (cell_symbol_wrong_number_of_args, cons (e, f));
 561     }
 562   return cell_unspecified;
 563 }
 564
 565 SCM
 566 check_apply (SCM f, SCM e) ///((internal))
 567 {
 568   char* type = 0;
 569   if (f == cell_f || f == cell_t)
 570     type = "bool";
 571   if (f == cell_nil)
 572     type = "nil";
 573   if (f == cell_unspecified)
 574     type = "*unspecified*";
 575   if (f == cell_undefined)
 576     type = "*undefined*";
 577   if (TYPE (f) == TCHAR)
 578     type = "char";
 579   if (TYPE (f) == TNUMBER)
 580     type = "number";
 581   if (TYPE (f) == TSTRING)
 582     type = "string";
 583   if (TYPE (f) == TBROKEN_HEART)
 584     type = "<3";
 585
 586   if (type)
 587     {
 588       char *s = "cannot apply: ";
 589       eputs (s);
 590       eputs (type);
 591       eputs ("[");
 592       write_error_ (e);
 593       eputs ("]\n");
 594       SCM e = MAKE_STRING (cstring_to_list (s));
 595       return error (cell_symbol_wrong_type_arg, cons (e, f));
 596     }
 597   return cell_unspecified;
 598 }
 599
 600 SCM
 601 gc_push_frame () ///((internal))
 602 {
 603   SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cell_nil))));
 604   g_stack = cons (frame, g_stack);
 605   return g_stack;
 606 }
 607
 608 SCM
 609 append2 (SCM x, SCM y)
 610 {
 611   if (x == cell_nil)
 612     return y;
 613   if (TYPE (x) != TPAIR)
 614     error (cell_symbol_not_a_pair, cons (x, cell_append2));
 615   SCM r = cell_nil;
 616   while (x != cell_nil)
 617     {
 618       r = cons (CAR (x), r);
 619       x = CDR (x);
 620     }
 621   return reverse_x_ (r, y);
 622 }
 623
 624 SCM
 625 append_reverse (SCM x, SCM y)
 626 {
 627   if (x == cell_nil)
 628     return y;
 629   if (TYPE (x) != TPAIR)
 630     error (cell_symbol_not_a_pair, cons (x, cell_append_reverse));
 631   while (x != cell_nil)
 632     {
 633       y = cons (CAR (x), y);
 634       x = CDR (x);
 635     }
 636   return y;
 637 }
 638
 639 SCM
 640 reverse_x_ (SCM x, SCM t)
 641 {
 642   if (TYPE (x) != TPAIR)
 643     error (cell_symbol_not_a_pair, cons (x, cell_reverse_x_));
 644   SCM r = t;
 645   while (x != cell_nil)
 646     {
 647       t = CDR (x);
 648       CDR (x) = r;
 649       r = x;
 650       x = t;
 651     }
 652   return r;
 653 }
 654
 655 SCM
 656 pairlis (SCM x, SCM y, SCM a)
 657 {
 658   if (x == cell_nil)
 659     return a;
 660   if (TYPE (x) != TPAIR)
 661     return cons (cons (x, y), a);
 662   return cons (cons (car (x), car (y)),
 663                pairlis (cdr (x), cdr (y), a));
 664 }
 665
 666 SCM
 667 call (SCM fn, SCM x)
 668 {
 669   if ((FUNCTION (fn).arity > 0 || FUNCTION (fn).arity == -1)
 670       && x != cell_nil && TYPE (CAR (x)) == TVALUES)
 671     x = cons (CADAR (x), CDR (x));
 672   if ((FUNCTION (fn).arity > 1 || FUNCTION (fn).arity == -1)
 673       && x != cell_nil && TYPE (CDR (x)) == TPAIR && TYPE (CADR (x)) == TVALUES)
 674     x = cons (CAR (x), cons (CDADAR (x), CDR (x)));
 675   switch (FUNCTION (fn).arity)
 676     {
 677 #if __MESC__ || !_POSIX_SOURCE
 678     case 0: return (FUNCTION (fn).function) ();
 679     case 1: return ((SCM(*)(SCM))(FUNCTION (fn).function)) (CAR (x));
 680     case 2: return ((SCM(*)(SCM,SCM))(FUNCTION (fn).function)) (CAR (x), CADR (x));
 681     case 3: return ((SCM(*)(SCM,SCM,SCM))(FUNCTION (fn).function)) (CAR (x), CADR (x), CAR (CDDR (x)));
 682     case -1: return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);
 683     default: return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);
 684 #else
 685     case 0: return FUNCTION (fn).function0 ();
 686     case 1: return FUNCTION (fn).function1 (CAR (x));
 687     case 2: return FUNCTION (fn).function2 (CAR (x), CADR (x));
 688     case 3: return FUNCTION (fn).function3 (CAR (x), CADR (x), CAR (CDDR (x)));
 689     case -1: return FUNCTION (fn).functionn (x);
 690 #endif
 691     }
 692
 693   return cell_unspecified;
 694 }
 695
 696 SCM
 697 assq (SCM x, SCM a)
 698 {
 699   switch (TYPE (x))
 700     {
 701     case TCHAR:
 702     case TNUMBER:
 703       {
 704         SCM v = VALUE (x);
 705         while (a != cell_nil && v != VALUE (CAAR (a)))
 706           a = CDR (a);
 707         break;
 708       }
 709     case TKEYWORD:
 710       {
 711         SCM v = STRING (x);
 712         while (a != cell_nil && v != STRING (CAAR (a)))
 713           a = CDR (a);
 714         break;
 715       }
 716       // case TSYMBOL:
 717       // case TSPECIAL:
 718     default:
 719       while (a != cell_nil && x != CAAR (a))
 720         a = CDR (a);
 721     }
 722   return a != cell_nil ? CAR (a) : cell_f;
 723 }
 724
 725 SCM
 726 assq_ref_env (SCM x, SCM a)
 727 {
 728   x = assq (x, a);
 729   if (x == cell_f)
 730     return cell_undefined;
 731   return CDR (x);
 732 }
 733
 734 SCM
 735 set_car_x (SCM x, SCM e)
 736 {
 737   if (TYPE (x) != TPAIR)
 738     error (cell_symbol_not_a_pair, cons (x, cell_set_car_x));
 739   CAR (x) = e;
 740   return cell_unspecified;
 741 }
 742
 743 SCM
 744 set_cdr_x (SCM x, SCM e)
 745 {
 746   if (TYPE (x) != TPAIR)
 747     error (cell_symbol_not_a_pair, cons (x, cell_set_cdr_x));
 748   CDR (x) = e;
 749   return cell_unspecified;
 750 }
 751
 752 SCM
 753 set_env_x (SCM x, SCM e, SCM a)
 754 {
 755   SCM p;
 756   if (TYPE (x) == TVARIABLE)
 757     p = VARIABLE (x);
 758   else
 759     p = assert_defined (x, assq (x, a));
 760   if (TYPE (p) != TPAIR)
 761     error (cell_symbol_not_a_pair, cons (p, x));
 762   return set_cdr_x (p, e);
 763 }
 764
 765 SCM
 766 call_lambda (SCM e, SCM x, SCM aa, SCM a) ///((internal))
 767 {
 768   SCM cl = cons (cons (cell_closure, x), x);
 769   r1 = e;
 770   r0 = cl;
 771   return cell_unspecified;
 772 }
 773
 774 SCM
 775 make_closure_ (SCM args, SCM body, SCM a) ///((internal))
 776 {
 777   return make_cell__ (TCLOSURE, 0, cons (cons (cell_circular, a), cons (args, body)));
 778 }
 779
 780 SCM
 781 make_variable_ (SCM var) ///((internal))
 782 {
 783   return make_cell__ (TVARIABLE, var, 0);
 784 }
 785
 786 SCM
 787 lookup_macro_ (SCM x, SCM a) ///((internal))
 788 {
 789   if (TYPE (x) != TSYMBOL)
 790     return cell_f;
 791   SCM m = assq (x, a);
 792   if (m != cell_f)
 793     return MACRO (CDR (m));
 794   return cell_f;
 795 }
 796
 797 SCM
 798 push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal))
 799 {
 800   SCM x = r3;
 801   r3 = c;
 802   r2 = p2;
 803   gc_push_frame ();
 804   r1 = p1;
 805   r0 = a;
 806   r3 = x;
 807   return cell_unspecified;
 808 }
 809
 810 SCM
 811 gc_peek_frame () ///((internal))
 812 {
 813   SCM frame = CAR (g_stack);
 814   r1 = CAR (frame);
 815   r2 = CADR (frame);
 816   r3 = CAR (CDDR (frame));
 817   r0 = CADR (CDDR (frame));
 818   return frame;
 819 }
 820
 821 SCM
 822 gc_pop_frame () ///((internal))
 823 {
 824   SCM frame = gc_peek_frame (g_stack);
 825   g_stack = CDR (g_stack);
 826   return frame;
 827 }
 828
 829 char const* string_to_cstring (SCM s);
 830
 831 SCM
 832 add_formals (SCM formals, SCM x)
 833 {
 834   while (TYPE (x) == TPAIR)
 835     {
 836       formals = cons (CAR (x), formals);
 837       x = CDR (x);
 838     }
 839   if (TYPE (x) == TSYMBOL)
 840     formals = cons (x, formals);
 841   return formals;
 842 }
 843
 844 int
 845 formal_p (SCM x, SCM formals) /// ((internal))
 846 {
 847   if (TYPE (formals) == TSYMBOL)
 848     {
 849       if (x == formals)
 850         return x;
 851       else return cell_f;
 852     }
 853   while (TYPE (formals) == TPAIR && CAR (formals) != x)
 854     formals = CDR (formals);
 855   if (TYPE (formals) == TSYMBOL)
 856     return formals == x;
 857   return TYPE (formals) == TPAIR;
 858 }
 859
 860 SCM
 861 expand_variable_ (SCM x, SCM formals, int top_p) ///((internal))
 862 {
 863   while (TYPE (x) == TPAIR)
 864     {
 865       if (TYPE (CAR (x)) == TPAIR)
 866         {
 867           if (CAAR (x) == cell_symbol_lambda)
 868             {
 869               SCM f = CAR (CDAR (x));
 870               formals = add_formals (formals, f);
 871             }
 872           else if (CAAR (x) == cell_symbol_define
 873                    || CAAR (x) == cell_symbol_define_macro)
 874             {
 875               SCM f = CAR (CDAR (x));
 876               formals = add_formals (formals, f);
 877             }
 878           if (CAAR (x) != cell_symbol_quote)
 879             expand_variable_ (CAR (x), formals, 0);
 880         }
 881       else
 882         {
 883           if (CAR (x) == cell_symbol_lambda)
 884             {
 885               SCM f = CADR (x);
 886               formals = add_formals (formals, f);
 887               x = CDR (x);
 888             }
 889           else if (CAR (x) == cell_symbol_define
 890                    || CAR (x) == cell_symbol_define_macro)
 891             {
 892               SCM f = CADR (x);
 893               if (top_p && TYPE (f) == TPAIR)
 894                 f = CDR (f);
 895               formals = add_formals (formals, f);
 896               x = CDR (x);
 897             }
 898           else if (CAR (x) == cell_symbol_quote)
 899             return cell_unspecified;
 900           else if (TYPE (CAR (x)) == TSYMBOL
 901                    && CAR (x) != cell_begin
 902                    && CAR (x) != cell_symbol_begin
 903                    && CAR (x) != cell_symbol_current_module
 904                    && CAR (x) != cell_symbol_primitive_load
 905                    && CAR (x) != cell_symbol_if // HMM
 906                    && !formal_p (CAR (x), formals))
 907             {
 908               SCM v = assq (CAR (x), r0);
 909               if (v != cell_f)
 910                 CAR (x) = make_variable_ (v);
 911             }
 912         }
 913       x = CDR (x);
 914       top_p = 0;
 915     }
 916   return cell_unspecified;
 917 }
 918
 919 SCM
 920 expand_variable (SCM x, SCM formals) ///((internal))
 921 {
 922   return expand_variable_ (x, formals, 1);
 923 }
 924
 925 SCM
 926 eval_apply ()
 927 {
 928   SCM aa;
 929   SCM args;
 930   SCM body;
 931   SCM cl;
 932   SCM entry;
 933   SCM expanders;
 934   SCM formals;
 935   SCM input;
 936   SCM name;
 937   SCM macro;
 938   SCM p;
 939   SCM program;
 940   SCM sc_expand;
 941   SCM x;
 942   int global_p;
 943   int macro_p;
 944
 945  eval_apply:
 946   switch (r3)
 947     {
 948     case cell_vm_evlis: goto evlis;
 949     case cell_vm_evlis2: goto evlis2;
 950     case cell_vm_evlis3: goto evlis3;
 951     case cell_vm_apply: goto apply;
 952     case cell_vm_apply2: goto apply2;
 953     case cell_vm_eval: goto eval;
 954     case cell_vm_eval_pmatch_car: goto eval_pmatch_car;
 955     case cell_vm_eval_pmatch_cdr: goto eval_pmatch_cdr;
 956     case cell_vm_eval_define: goto eval_define;
 957     case cell_vm_eval_set_x: goto eval_set_x;
 958     case cell_vm_eval_macro_expand_eval: goto eval_macro_expand_eval;
 959     case cell_vm_eval_macro_expand_expand: goto eval_macro_expand_expand;
 960     case cell_vm_eval_check_func: goto eval_check_func;
 961     case cell_vm_eval2: goto eval2;
 962     case cell_vm_macro_expand: goto macro_expand;
 963     case cell_vm_macro_expand_define: goto macro_expand_define;
 964     case cell_vm_macro_expand_define_macro: goto macro_expand_define_macro;
 965     case cell_vm_macro_expand_lambda: goto macro_expand_lambda;
 966     case cell_vm_macro_expand_set_x: goto macro_expand_set_x;
 967     case cell_vm_macro_expand_car: goto macro_expand_car;
 968     case cell_vm_macro_expand_cdr: goto macro_expand_cdr;
 969     case cell_vm_begin: goto begin;
 970     case cell_vm_begin_eval: goto begin_eval;
 971     case cell_vm_begin_primitive_load: goto begin_primitive_load;
 972     case cell_vm_begin_expand: goto begin_expand;
 973     case cell_vm_begin_expand_eval: goto begin_expand_eval;
 974     case cell_vm_begin_expand_macro: goto begin_expand_macro;
 975     case cell_vm_begin_expand_primitive_load: goto begin_expand_primitive_load;
 976     case cell_vm_if: goto vm_if;
 977     case cell_vm_if_expr: goto if_expr;
 978     case cell_vm_call_with_current_continuation2: goto call_with_current_continuation2;
 979     case cell_vm_call_with_values2: goto call_with_values2;
 980     case cell_vm_return: goto vm_return;
 981     case cell_unspecified: return r1;
 982     default:
 983       assert (0);
 984     }
 985
 986  evlis:
 987   if (r1 == cell_nil)
 988     goto vm_return;
 989   if (TYPE (r1) != TPAIR)
 990     goto eval;
 991   push_cc (CAR (r1), r1, r0, cell_vm_evlis2);
 992   goto eval;
 993  evlis2:
 994   push_cc (CDR (r2), r1, r0, cell_vm_evlis3);
 995   goto evlis;
 996  evlis3:
 997   r1 = cons (r2, r1);
 998   goto vm_return;
 999
1000  apply:
1001   switch (TYPE (CAR (r1)))
1002     {
1003     case TFUNCTION:
1004       {
1005         check_formals (CAR (r1), MAKE_NUMBER (FUNCTION (CAR (r1)).arity), CDR (r1));
1006         r1 = call (CAR (r1), CDR (r1)); /// FIXME: move into eval_apply
1007         goto vm_return;
1008       }
1009     case TCLOSURE:
1010       {
1011         cl = CLOSURE (CAR (r1));
1012         body = CDDR (cl);
1013         formals = CADR (cl);
1014         args = CDR (r1);
1015         aa = CDAR (cl);
1016         aa = CDR (aa);
1017         check_formals (CAR (r1), formals, CDR (r1));
1018         p = pairlis (formals, args, aa);
1019         call_lambda (body, p, aa, r0);
1020         goto begin;
1021       }
1022     case TCONTINUATION:
1023       {
1024         x = r1;
1025         g_stack = CONTINUATION (CAR (r1));
1026         gc_pop_frame ();
1027         r1 = CADR (x);
1028         goto eval_apply;
1029       }
1030     case TSPECIAL:
1031       {
1032         switch (CAR (r1))
1033           {
1034           case cell_vm_apply:
1035             {
1036               push_cc (cons (CADR (r1), CADDR (r1)), r1, r0, cell_vm_return);
1037               goto apply;
1038             }
1039           case cell_vm_eval:
1040             {
1041               push_cc (CADR (r1), r1, CADDR (r1), cell_vm_return);
1042               goto eval;
1043             }
1044           case cell_vm_begin_expand:
1045             {
1046               push_cc (cons (CADR (r1), cell_nil), r1, CADDR (r1), cell_vm_return);
1047               goto begin_expand;
1048             }
1049           case cell_call_with_current_continuation:
1050             {
1051               r1 = CDR (r1);
1052               goto call_with_current_continuation;
1053             }
1054           default: check_apply (cell_f, CAR (r1));
1055           }
1056       }
1057     case TSYMBOL:
1058       {
1059         if (CAR (r1) == cell_symbol_call_with_values)
1060           {
1061             r1 = CDR (r1);
1062             goto call_with_values;
1063           }
1064         if (CAR (r1) == cell_symbol_current_module)
1065           {
1066             r1 = r0;
1067             goto vm_return;
1068           }
1069         break;
1070       }
1071     case TPAIR:
1072       {
1073         switch (CAAR (r1))
1074           {
1075           case cell_symbol_lambda:
1076             {
1077               formals = CADR (CAR (r1));
1078               args = CDR (r1);
1079               body = CDDR (CAR (r1));
1080               p = pairlis (formals, CDR (r1), r0);
1081               check_formals (r1, formals, args);
1082               call_lambda (body, p, p, r0);
1083               goto begin;
1084             }
1085           }
1086       }
1087     }
1088   push_cc (CAR (r1), r1, r0, cell_vm_apply2);
1089   goto eval;
1090  apply2:
1091   check_apply (r1, CAR (r2));
1092   r1 = cons (r1, CDR (r2));
1093   goto apply;
1094
1095  eval:
1096   switch (TYPE (r1))
1097     {
1098     case TPAIR:
1099       {
1100         switch (CAR (r1))
1101           {
1102           case cell_symbol_pmatch_car:
1103             {
1104               push_cc (CADR (r1), r1, r0, cell_vm_eval_pmatch_car);
1105               goto eval;
1106             eval_pmatch_car:
1107               x = r1;
1108               gc_pop_frame ();
1109               r1 = CAR (x);
1110               goto eval_apply;
1111             }
1112           case cell_symbol_pmatch_cdr:
1113             {
1114               push_cc (CADR (r1), r1, r0, cell_vm_eval_pmatch_cdr);
1115               goto eval;
1116             eval_pmatch_cdr:
1117               x = r1;
1118               gc_pop_frame ();
1119               r1 = CDR (x);
1120               goto eval_apply;
1121             }
1122           case cell_symbol_quote:
1123             {
1124               x = r1;
1125               gc_pop_frame ();
1126               r1 = CADR (x);
1127               goto eval_apply;
1128             }
1129           case cell_symbol_begin:
1130             goto begin;
1131           case cell_symbol_lambda:
1132             {
1133               r1 = make_closure_ (CADR (r1), CDDR (r1), r0);
1134               goto vm_return;
1135             }
1136           case cell_symbol_if:
1137             {
1138               r1=CDR (r1);
1139               goto vm_if;
1140             }
1141           case cell_symbol_set_x:
1142             {
1143               push_cc (CAR (CDDR (r1)), r1, r0, cell_vm_eval_set_x);
1144               goto eval;
1145             eval_set_x:
1146               r1 = set_env_x (CADR (r2), r1, r0);
1147               goto vm_return;
1148             }
1149           case cell_vm_macro_expand:
1150             {
1151               push_cc (CADR (r1), r1, r0, cell_vm_eval_macro_expand_eval);
1152               goto eval;
1153             eval_macro_expand_eval:
1154               push_cc (r1, r2, r0, cell_vm_eval_macro_expand_expand);
1155               goto macro_expand;
1156             eval_macro_expand_expand:
1157               goto vm_return;
1158             }
1159           default:
1160             {
1161               if (TYPE (r1) == TPAIR
1162                   && (CAR (r1) == cell_symbol_define
1163                       || CAR (r1) == cell_symbol_define_macro))
1164                 {
1165                   global_p = CAAR (r0) != cell_closure;
1166                   macro_p = CAR (r1) == cell_symbol_define_macro;
1167                   if (global_p)
1168                     {
1169                       name = CADR (r1);
1170                       if (TYPE (CADR (r1)) == TPAIR)
1171                         name = CAR (name);
1172                       if (macro_p)
1173                         {
1174                           entry = assq (name, g_macros);
1175                           if (entry == cell_f)
1176                             {
1177                               entry = cons (name, cell_f);
1178                               g_macros = cons (entry, g_macros);
1179                             }
1180                         }
1181                       else
1182                         {
1183                           entry = assq (name, r0);
1184                           if (entry == cell_f)
1185                             {
1186                               entry = cons (name, cell_f);
1187                               aa = cons (entry, cell_nil);
1188                               set_cdr_x (aa, cdr (r0));
1189                               set_cdr_x (r0, aa);
1190                             }
1191                         }
1192                     }
1193                   r2 = r1;
1194                   if (TYPE (CADR (r1)) != TPAIR)
1195                     {
1196                       push_cc (CAR (CDDR (r1)), r2, cons (cons (CADR (r1), CADR (r1)), r0), cell_vm_eval_define);
1197                       goto eval;
1198                     }
1199                   else
1200                     {
1201                       p = pairlis (CADR (r1), CADR (r1), r0);
1202                       formals = CDR (CADR (r1));
1203                       body = CDDR (r1);
1204
1205                       if (macro_p || global_p)
1206                         expand_variable (body, formals);
1207                       r1 = cons (cell_symbol_lambda, cons (formals, body));
1208                       push_cc (r1, r2, p, cell_vm_eval_define);
1209                       goto eval;
1210                     }
1211                 eval_define:;
1212                   name = CADR (r2);
1213                   if (TYPE (CADR (r2)) == TPAIR)
1214                     name = CAR (name);
1215                   if (macro_p)
1216                     {
1217                       entry = assq (name, g_macros);
1218                       r1 = MAKE_MACRO (name, r1);
1219                       set_cdr_x (entry, r1);
1220                     }
1221                   else if (global_p)
1222                     {
1223                       entry = assq (name, r0);
1224                       set_cdr_x (entry, r1);
1225                     }
1226                   else
1227                     {
1228                       entry = cons (name, r1);
1229                       aa = cons (entry, cell_nil);
1230                       set_cdr_x (aa, cdr (r0));
1231                       set_cdr_x (r0, aa);
1232                       cl = assq (cell_closure, r0);
1233                       set_cdr_x (cl, aa);
1234                     }
1235                   r1 = cell_unspecified;
1236                   goto vm_return;
1237                 }
1238               push_cc (CAR (r1), r1, r0, cell_vm_eval_check_func);
1239               gc_check ();
1240               goto eval;
1241             eval_check_func:
1242               push_cc (CDR (r2), r2, r0, cell_vm_eval2);
1243               goto evlis;
1244             eval2:
1245               r1 = cons (CAR (r2), r1);
1246               goto apply;
1247             }
1248           }
1249       }
1250     case TSYMBOL:
1251       {
1252         if (r1 == cell_symbol_current_module)
1253           goto vm_return;
1254         if (r1 == cell_symbol_begin) // FIXME
1255           {
1256             r1 = cell_begin;
1257             goto vm_return;
1258           }
1259         r1 = assert_defined (r1, assq_ref_env (r1, r0));
1260         goto vm_return;
1261       }
1262     case TVARIABLE:
1263       {
1264         r1 = CDR (VARIABLE (r1));
1265         goto vm_return;
1266       }
1267     case TBROKEN_HEART:
1268       {
1269         error (cell_symbol_system_error,  r1);
1270       }
1271     default: goto vm_return;
1272     }
1273
1274  macro_expand:
1275   {
1276     macro;
1277     expanders;
1278
1279     if (TYPE (r1) != TPAIR || CAR (r1) == cell_symbol_quote)
1280       goto vm_return;
1281
1282     if (CAR (r1) == cell_symbol_lambda)
1283       {
1284         push_cc (CDDR (r1), r1, r0, cell_vm_macro_expand_lambda);
1285         goto macro_expand;
1286       macro_expand_lambda:
1287         CDDR (r2) = r1;
1288         r1 = r2;
1289         goto vm_return;
1290       }
1291
1292     if (TYPE (r1) == TPAIR
1293         && (macro = lookup_macro_ (CAR (r1), g_macros)) != cell_f)
1294       {
1295         r1 = cons (macro, CDR (r1));
1296         push_cc (r1, cell_nil, r0, cell_vm_macro_expand);
1297         goto apply;
1298       }
1299
1300     if (CAR (r1) == cell_symbol_define
1301         || CAR (r1) == cell_symbol_define_macro)
1302       {
1303         push_cc (CDDR (r1), r1, r0, cell_vm_macro_expand_define);
1304         goto macro_expand;
1305       macro_expand_define:
1306         CDDR (r2) = r1;
1307         r1 = r2;
1308         if (CAR (r1) == cell_symbol_define_macro)
1309           {
1310             push_cc (r1, r1, r0, cell_vm_macro_expand_define_macro);
1311             goto eval;
1312           macro_expand_define_macro:
1313             r1 = r2;
1314           }
1315         goto vm_return;
1316       }
1317
1318     if (CAR (r1) == cell_symbol_set_x)
1319       {
1320         push_cc (CDDR (r1), r1, r0, cell_vm_macro_expand_set_x);
1321         goto macro_expand;
1322       macro_expand_set_x:
1323         CDDR (r2) = r1;
1324         r1 = r2;
1325         goto vm_return;
1326       }
1327
1328     if (TYPE (r1) == TPAIR
1329         && TYPE (CAR (r1)) == TSYMBOL
1330         && CAR (r1) != cell_symbol_begin
1331         && ((macro = assq (cell_symbol_portable_macro_expand, g_macros)) != cell_f)
1332         && ((expanders = assq_ref_env (cell_symbol_sc_expander_alist, r0)) != cell_undefined)
1333         && ((macro = assq (CAR (r1), expanders)) != cell_f))
1334       {
1335         sc_expand = assq_ref_env (cell_symbol_macro_expand, r0);
1336         r2 = r1;
1337         if (sc_expand != cell_undefined && sc_expand != cell_f)
1338           {
1339             r1 = cons (sc_expand, cons (r1, cell_nil));
1340             goto apply;
1341           }
1342       }
1343
1344     push_cc (CAR (r1), r1, r0, cell_vm_macro_expand_car);
1345     goto macro_expand;
1346
1347   macro_expand_car:
1348     CAR (r2) = r1;
1349     r1 = r2;
1350     if (CDR (r1) == cell_nil)
1351       goto vm_return;
1352
1353     push_cc (CDR (r1), r1, r0, cell_vm_macro_expand_cdr);
1354     goto macro_expand;
1355
1356   macro_expand_cdr:
1357     CDR (r2) = r1;
1358     r1 = r2;
1359
1360     goto vm_return;
1361   }
1362
1363  begin:
1364   x = cell_unspecified;
1365   while (r1 != cell_nil)
1366     {
1367       gc_check ();
1368       if (TYPE (r1) == TPAIR)
1369         {
1370           if (CAAR (r1) == cell_symbol_primitive_load)
1371             {
1372               program = cons (CAR (r1), cell_nil);
1373               push_cc (program, r1, r0, cell_vm_begin_primitive_load);
1374               goto begin_expand;
1375             begin_primitive_load:
1376               CAR (r2) = r1;
1377               r1 = r2;
1378             }
1379         }
1380
1381       if (TYPE (r1) == TPAIR && TYPE (CAR (r1)) == TPAIR)
1382         {
1383           if (CAAR (r1) == cell_symbol_begin)
1384             r1 = append2 (CDAR (r1), CDR (r1));
1385         }
1386       if (CDR (r1) == cell_nil)
1387         {
1388           r1 = CAR (r1);
1389           goto eval;
1390         }
1391       push_cc (CAR (r1), r1, r0, cell_vm_begin_eval);
1392       goto eval;
1393     begin_eval:
1394       x = r1;
1395       r1 = CDR (r2);
1396     }
1397   r1 = x;
1398   goto vm_return;
1399
1400
1401  begin_expand:
1402   x = cell_unspecified;
1403   while (r1 != cell_nil)
1404     {
1405       gc_check ();
1406
1407       if (TYPE (r1) == TPAIR)
1408         {
1409           if (TYPE (CAR (r1)) == TPAIR && CAAR (r1) == cell_symbol_begin)
1410             r1 = append2 (CDAR (r1), CDR (r1));
1411           if (CAAR (r1) == cell_symbol_primitive_load)
1412             {
1413               push_cc (CADR (CAR (r1)), r1, r0, cell_vm_begin_expand_primitive_load);
1414               goto eval; // FIXME: expand too?!
1415             begin_expand_primitive_load:
1416               if (TYPE (r1) == TNUMBER && VALUE (r1) == 0)
1417                 ;
1418               else if (TYPE (r1) == TSTRING)
1419                 input = set_current_input_port (open_input_file (r1));
1420               else
1421                 assert (0);
1422
1423               push_cc (input, r2, r0, cell_vm_return);
1424               x = read_input_file_env (r0);
1425               gc_pop_frame ();
1426               input = r1;
1427               r1 = x;
1428               set_current_input_port (input);
1429               r1 = cons (cell_symbol_begin, r1);
1430               CAR (r2) = r1;
1431               r1 = r2;
1432               continue;
1433             }
1434         }
1435
1436       push_cc (CAR (r1), r1, r0, cell_vm_begin_expand_macro);
1437       goto macro_expand;
1438     begin_expand_macro:
1439       if (r1 != CAR (r2))
1440         {
1441           CAR (r2) = r1;
1442           r1 = r2;
1443           continue;
1444         }
1445       r1 = r2;
1446       expand_variable (CAR (r1), cell_nil);
1447       push_cc (CAR (r1), r1, r0, cell_vm_begin_expand_eval);
1448       goto eval;
1449     begin_expand_eval:
1450       x = r1;
1451       r1 = CDR (r2);
1452     }
1453   r1 = x;
1454   goto vm_return;
1455
1456  vm_if:
1457   push_cc (CAR (r1), r1, r0, cell_vm_if_expr);
1458   goto eval;
1459  if_expr:
1460   x = r1;
1461   r1 = r2;
1462   if (x != cell_f)
1463     {
1464       r1 = CADR (r1);
1465       goto eval;
1466     }
1467   if (CDDR (r1) != cell_nil)
1468     {
1469       r1 = CAR (CDDR (r1));
1470       goto eval;
1471     }
1472   r1 = cell_unspecified;
1473   goto vm_return;
1474
1475  call_with_current_continuation:
1476   gc_push_frame ();
1477   x = MAKE_CONTINUATION (g_continuations++);
1478   gc_pop_frame ();
1479   push_cc (cons (CAR (r1), cons (x, cell_nil)), x, r0, cell_vm_call_with_current_continuation2);
1480   goto apply;
1481  call_with_current_continuation2:
1482   CONTINUATION (r2) = g_stack;
1483   goto vm_return;
1484
1485  call_with_values:
1486   push_cc (cons (CAR (r1), cell_nil), r1, r0, cell_vm_call_with_values2);
1487   goto apply;
1488  call_with_values2:
1489   if (TYPE (r1) == TVALUES)
1490     r1 = CDR (r1);
1491   r1 = cons (CADR (r2), r1);
1492   goto apply;
1493
1494  vm_return:
1495   x = r1;
1496   gc_pop_frame ();
1497   r1 = x;
1498   goto eval_apply;
1499 }
1500
1501 SCM
1502 apply (SCM f, SCM x, SCM a) ///((internal))
1503 {
1504   push_cc (cons (f, x), cell_unspecified, r0, cell_unspecified);
1505   r3 = cell_vm_apply;
1506   return eval_apply ();
1507 }
1508
1509 SCM
1510 mes_g_stack (SCM a) ///((internal))
1511 {
1512   r0 = a;
1513   r1 = MAKE_CHAR (0);
1514   r2 = MAKE_CHAR (0);
1515   r3 = MAKE_CHAR (0);
1516   g_stack = cons (cell_nil, cell_nil);
1517   return r0;
1518 }
1519
1520 //\f Environment setup
1521
1522 #include "posix.c"
1523 #include "math.c"
1524 #include "lib.c"
1525
1526 //\f Jam Collector
1527 SCM g_symbol_max;
1528
1529 SCM
1530 gc_init_cells () ///((internal))
1531 {
1532   g_cells = (struct scm *)malloc ((ARENA_SIZE+JAM_SIZE)*sizeof (struct scm));
1533   TYPE (0) = TVECTOR;
1534   LENGTH (0) = 1000;
1535   VECTOR (0) = 0;
1536   g_cells++;
1537   TYPE (0) = TCHAR;
1538   VALUE (0) = 'c';
1539   return 0;
1540 }
1541
1542 SCM
1543 mes_symbols () ///((internal))
1544 {
1545   gc_init_cells ();
1546
1547 #if MES_MINI
1548
1549 g_free++;
1550 g_cells[cell_nil] = scm_nil;
1551
1552 g_free++;
1553 g_cells[cell_f] = scm_f;
1554
1555 g_free++;
1556 g_cells[cell_t] = scm_t;
1557
1558 g_free++;
1559 g_cells[cell_dot] = scm_dot;
1560
1561 g_free++;
1562 g_cells[cell_arrow] = scm_arrow;
1563
1564 g_free++;
1565 g_cells[cell_undefined] = scm_undefined;
1566
1567 g_free++;
1568 g_cells[cell_unspecified] = scm_unspecified;
1569
1570 g_free++;
1571 g_cells[cell_closure] = scm_closure;
1572
1573 g_free++;
1574 g_cells[cell_circular] = scm_circular;
1575
1576 g_free++;
1577 g_cells[cell_begin] = scm_begin;
1578
1579 g_free++;
1580 g_cells[cell_symbol_dot] = scm_symbol_dot;
1581
1582 g_free++;
1583 g_cells[cell_symbol_lambda] = scm_symbol_lambda;
1584
1585 g_free++;
1586 g_cells[cell_symbol_begin] = scm_symbol_begin;
1587
1588 g_free++;
1589 g_cells[cell_symbol_if] = scm_symbol_if;
1590
1591 g_free++;
1592 g_cells[cell_symbol_quote] = scm_symbol_quote;
1593
1594 g_free++;
1595 g_cells[cell_symbol_define] = scm_symbol_define;
1596
1597 g_free++;
1598 g_cells[cell_symbol_define_macro] = scm_symbol_define_macro;
1599
1600 g_free++;
1601 g_cells[cell_symbol_quasiquote] = scm_symbol_quasiquote;
1602
1603 g_free++;
1604 g_cells[cell_symbol_unquote] = scm_symbol_unquote;
1605
1606 g_free++;
1607 g_cells[cell_symbol_unquote_splicing] = scm_symbol_unquote_splicing;
1608
1609
1610 ////// for GC
1611 g_free++;
1612 g_cells[cell_symbol_syntax] = scm_symbol_syntax;
1613
1614 g_free++;
1615 g_cells[cell_symbol_quasisyntax] = scm_symbol_quasisyntax;
1616
1617 g_free++;
1618 g_cells[cell_symbol_unsyntax] = scm_symbol_unsyntax;
1619
1620 g_free++;
1621 g_cells[cell_symbol_unsyntax_splicing] = scm_symbol_unsyntax_splicing;
1622
1623 g_free++;
1624 g_cells[cell_symbol_set_x] = scm_symbol_set_x;
1625
1626 g_free++;
1627 g_cells[cell_symbol_sc_expand] = scm_symbol_sc_expand;
1628
1629 g_free++;
1630 g_cells[cell_symbol_macro_expand] = scm_symbol_macro_expand;
1631
1632 g_free++;
1633 g_cells[cell_symbol_portable_macro_expand] = scm_symbol_portable_macro_expand;
1634
1635 g_free++;
1636 g_cells[cell_symbol_sc_expander_alist] = scm_symbol_sc_expander_alist;
1637
1638 g_free++;
1639 g_cells[cell_symbol_call_with_values] = scm_symbol_call_with_values;
1640
1641 g_free++;
1642 g_cells[cell_call_with_current_continuation] = scm_call_with_current_continuation;
1643
1644 g_free++;
1645 g_cells[cell_symbol_call_with_current_continuation] = scm_symbol_call_with_current_continuation;
1646
1647 g_free++;
1648 g_cells[cell_symbol_current_module] = scm_symbol_current_module;
1649
1650 g_free++;
1651 g_cells[cell_symbol_primitive_load] = scm_symbol_primitive_load;
1652
1653 g_free++;
1654 g_cells[cell_symbol_read_input_file] = scm_symbol_read_input_file;
1655
1656 g_free++;
1657 g_cells[cell_symbol_write] = scm_symbol_write;
1658
1659 g_free++;
1660 g_cells[cell_symbol_display] = scm_symbol_display;
1661
1662 g_free++;
1663 g_cells[cell_symbol_throw] = scm_symbol_throw;
1664
1665 g_free++;
1666 g_cells[cell_symbol_not_a_number] = scm_symbol_not_a_number;
1667
1668 g_free++;
1669 g_cells[cell_symbol_not_a_pair] = scm_symbol_not_a_pair;
1670
1671 g_free++;
1672 g_cells[cell_symbol_system_error] = scm_symbol_system_error;
1673
1674 g_free++;
1675 g_cells[cell_symbol_wrong_number_of_args] = scm_symbol_wrong_number_of_args;
1676
1677 g_free++;
1678 g_cells[cell_symbol_wrong_type_arg] = scm_symbol_wrong_type_arg;
1679
1680 g_free++;
1681 g_cells[cell_symbol_unbound_variable] = scm_symbol_unbound_variable;
1682
1683 g_free++;
1684 g_cells[cell_symbol_argv] = scm_symbol_argv;
1685
1686 g_free++;
1687 g_cells[cell_symbol_mes_prefix] = scm_symbol_mes_prefix;
1688
1689 g_free++;
1690 g_cells[cell_symbol_mes_version] = scm_symbol_mes_version;
1691
1692 g_free++;
1693 g_cells[cell_symbol_car] = scm_symbol_car;
1694
1695 g_free++;
1696 g_cells[cell_symbol_cdr] = scm_symbol_cdr;
1697
1698 g_free++;
1699 g_cells[cell_symbol_pmatch_car] = scm_symbol_pmatch_car;
1700
1701 g_free++;
1702 g_cells[cell_symbol_pmatch_cdr] = scm_symbol_pmatch_cdr;
1703
1704 g_free++;
1705 g_cells[cell_vm_evlis] = scm_vm_evlis;
1706
1707 g_free++;
1708 g_cells[cell_vm_evlis2] = scm_vm_evlis2;
1709
1710 g_free++;
1711 g_cells[cell_vm_evlis3] = scm_vm_evlis3;
1712
1713 g_free++;
1714 g_cells[cell_vm_apply] = scm_vm_apply;
1715
1716 g_free++;
1717 g_cells[cell_vm_apply2] = scm_vm_apply2;
1718
1719 g_free++;
1720 g_cells[cell_vm_eval] = scm_vm_eval;
1721
1722 g_free++;
1723 g_cells[cell_vm_eval_pmatch_car] = scm_vm_eval_pmatch_car;
1724
1725 g_free++;
1726 g_cells[cell_vm_eval_pmatch_cdr] = scm_vm_eval_pmatch_cdr;
1727
1728 g_free++;
1729 g_cells[cell_vm_eval_define] = scm_vm_eval_define;
1730
1731 g_free++;
1732 g_cells[cell_vm_eval_set_x] = scm_vm_eval_set_x;
1733
1734 g_free++;
1735 g_cells[cell_vm_eval_macro_expand_eval] = scm_vm_eval_macro_expand_eval;
1736
1737 g_free++;
1738 g_cells[cell_vm_eval_macro_expand_expand] = scm_vm_eval_macro_expand_expand;
1739
1740 g_free++;
1741 g_cells[cell_vm_eval_check_func] = scm_vm_eval_check_func;
1742
1743 g_free++;
1744 g_cells[cell_vm_eval2] = scm_vm_eval2;
1745
1746 g_free++;
1747 g_cells[cell_vm_macro_expand] = scm_vm_macro_expand;
1748
1749 g_free++;
1750 g_cells[cell_vm_macro_expand_define] = scm_vm_macro_expand_define;
1751
1752 g_free++;
1753 g_cells[cell_vm_macro_expand_define_macro] = scm_vm_macro_expand_define_macro;
1754
1755 g_free++;
1756 g_cells[cell_vm_macro_expand_lambda] = scm_vm_macro_expand_lambda;
1757
1758 g_free++;
1759 g_cells[cell_vm_macro_expand_set_x] = scm_vm_macro_expand_set_x;
1760
1761 g_free++;
1762 g_cells[cell_vm_begin_expand_primitive_load] = scm_vm_begin_expand_primitive_load;
1763
1764 g_free++;
1765 g_cells[cell_vm_begin_primitive_load] = scm_vm_begin_primitive_load;
1766
1767 g_free++;
1768 g_cells[cell_vm_macro_expand_car] = scm_vm_macro_expand_car;
1769
1770 g_free++;
1771 g_cells[cell_vm_macro_expand_cdr] = scm_vm_macro_expand_cdr;
1772
1773 g_free++;
1774 g_cells[cell_vm_begin_expand] = scm_vm_begin_expand;
1775
1776 g_free++;
1777 g_cells[cell_vm_begin_expand_eval] = scm_vm_begin_expand_eval;
1778
1779 g_free++;
1780 g_cells[cell_vm_begin_expand_macro] = scm_vm_begin_expand_macro;
1781
1782 g_free++;
1783 g_cells[cell_vm_begin] = scm_vm_begin;
1784
1785 g_free++;
1786 g_cells[cell_vm_begin_read_input_file] = scm_vm_begin_read_input_file;
1787
1788 g_free++;
1789 g_cells[cell_vm_begin_eval] = scm_vm_begin_eval;
1790
1791 g_free++;
1792 g_cells[cell_vm_if] = scm_vm_if;
1793
1794 g_free++;
1795 g_cells[cell_vm_if_expr] = scm_vm_if_expr;
1796
1797 g_free++;
1798 g_cells[cell_vm_call_with_values2] = scm_vm_call_with_values2;
1799
1800 g_free++;
1801 g_cells[cell_vm_call_with_current_continuation2] = scm_vm_call_with_current_continuation2;
1802
1803 g_free++;
1804 g_cells[cell_vm_return] = scm_vm_return;
1805
1806 g_free++;
1807 g_cells[cell_symbol_gnuc] = scm_symbol_gnuc;
1808
1809 g_free++;
1810 g_cells[cell_symbol_mesc] = scm_symbol_mesc;
1811
1812 g_free++;
1813 g_cells[cell_test] = scm_test;
1814 ////////////
1815
1816
1817
1818
1819
1820 #elif !_POSIX_SOURCE
1821 #include "mes.mes.symbols.i"
1822 #else
1823 #include "mes.symbols.i"
1824 #endif
1825
1826   g_symbol_max = g_free++;
1827   g_symbols = 0;
1828   for (int i=1; i<g_symbol_max; i++)
1829     g_symbols = cons (i, g_symbols);
1830
1831   SCM a = cell_nil;
1832
1833 #if MES_MINI
1834
1835 g_cells[cell_nil].car = cstring_to_list (scm_nil.car);
1836 g_cells[cell_f].car = cstring_to_list (scm_f.car);
1837 g_cells[cell_t].car = cstring_to_list (scm_t.car);
1838 g_cells[cell_dot].car = cstring_to_list (scm_dot.car);
1839 g_cells[cell_arrow].car = cstring_to_list (scm_arrow.car);
1840 g_cells[cell_undefined].car = cstring_to_list (scm_undefined.car);
1841 g_cells[cell_unspecified].car = cstring_to_list (scm_unspecified.car);
1842 g_cells[cell_closure].car = cstring_to_list (scm_closure.car);
1843 g_cells[cell_circular].car = cstring_to_list (scm_circular.car);
1844 g_cells[cell_begin].car = cstring_to_list (scm_begin.car);
1845 g_cells[cell_symbol_dot].car = cstring_to_list (scm_symbol_dot.car);
1846 g_cells[cell_symbol_lambda].car = cstring_to_list (scm_symbol_lambda.car);
1847 g_cells[cell_symbol_begin].car = cstring_to_list (scm_symbol_begin.car);
1848 g_cells[cell_symbol_if].car = cstring_to_list (scm_symbol_if.car);
1849 g_cells[cell_symbol_quote].car = cstring_to_list (scm_symbol_quote.car);
1850 g_cells[cell_symbol_define].car = cstring_to_list (scm_symbol_define.car);
1851 g_cells[cell_symbol_define_macro].car = cstring_to_list (scm_symbol_define_macro.car);
1852 g_cells[cell_symbol_quasiquote].car = cstring_to_list (scm_symbol_quasiquote.car);
1853 g_cells[cell_symbol_unquote].car = cstring_to_list (scm_symbol_unquote.car);
1854 g_cells[cell_symbol_unquote_splicing].car = cstring_to_list (scm_symbol_unquote_splicing.car);
1855
1856
1857 //// FOR GC
1858 g_cells[cell_symbol_syntax].car = cstring_to_list (scm_symbol_syntax.name);
1859 g_cells[cell_symbol_quasisyntax].car = cstring_to_list (scm_symbol_quasisyntax.name);
1860 g_cells[cell_symbol_unsyntax].car = cstring_to_list (scm_symbol_unsyntax.name);
1861 g_cells[cell_symbol_unsyntax_splicing].car = cstring_to_list (scm_symbol_unsyntax_splicing.name);
1862 g_cells[cell_symbol_set_x].car = cstring_to_list (scm_symbol_set_x.name);
1863 g_cells[cell_symbol_sc_expand].car = cstring_to_list (scm_symbol_sc_expand.name);
1864 g_cells[cell_symbol_macro_expand].car = cstring_to_list (scm_symbol_macro_expand.name);
1865 g_cells[cell_symbol_portable_macro_expand].car = cstring_to_list (scm_symbol_portable_macro_expand.name);
1866 g_cells[cell_symbol_sc_expander_alist].car = cstring_to_list (scm_symbol_sc_expander_alist.name);
1867 g_cells[cell_symbol_call_with_values].car = cstring_to_list (scm_symbol_call_with_values.name);
1868 g_cells[cell_call_with_current_continuation].car = cstring_to_list (scm_call_with_current_continuation.name);
1869 g_cells[cell_symbol_call_with_current_continuation].car = cstring_to_list (scm_symbol_call_with_current_continuation.name);
1870 g_cells[cell_symbol_current_module].car = cstring_to_list (scm_symbol_current_module.name);
1871 g_cells[cell_symbol_primitive_load].car = cstring_to_list (scm_symbol_primitive_load.name);
1872 g_cells[cell_symbol_read_input_file].car = cstring_to_list (scm_symbol_read_input_file.name);
1873 g_cells[cell_symbol_write].car = cstring_to_list (scm_symbol_write.name);
1874 g_cells[cell_symbol_display].car = cstring_to_list (scm_symbol_display.name);
1875 g_cells[cell_symbol_throw].car = cstring_to_list (scm_symbol_throw.name);
1876 g_cells[cell_symbol_not_a_number].car = cstring_to_list (scm_symbol_not_a_number.name);
1877 g_cells[cell_symbol_not_a_pair].car = cstring_to_list (scm_symbol_not_a_pair.name);
1878 g_cells[cell_symbol_system_error].car = cstring_to_list (scm_symbol_system_error.name);
1879 g_cells[cell_symbol_wrong_number_of_args].car = cstring_to_list (scm_symbol_wrong_number_of_args.name);
1880 g_cells[cell_symbol_wrong_type_arg].car = cstring_to_list (scm_symbol_wrong_type_arg.name);
1881 g_cells[cell_symbol_unbound_variable].car = cstring_to_list (scm_symbol_unbound_variable.name);
1882 g_cells[cell_symbol_argv].car = cstring_to_list (scm_symbol_argv.name);
1883 g_cells[cell_symbol_mes_prefix].car = cstring_to_list (scm_symbol_mes_prefix.name);
1884 g_cells[cell_symbol_mes_version].car = cstring_to_list (scm_symbol_mes_version.name);
1885 g_cells[cell_symbol_car].car = cstring_to_list (scm_symbol_car.name);
1886 g_cells[cell_symbol_cdr].car = cstring_to_list (scm_symbol_cdr.name);
1887 g_cells[cell_symbol_pmatch_car].car = cstring_to_list (scm_symbol_pmatch_car.name);
1888 g_cells[cell_symbol_pmatch_cdr].car = cstring_to_list (scm_symbol_pmatch_cdr.name);
1889
1890 g_cells[cell_vm_evlis].car = cstring_to_list ("*vm*");
1891 g_cells[cell_vm_evlis2].car = g_cells[cell_vm_evlis].car;
1892 g_cells[cell_vm_evlis3].car = g_cells[cell_vm_evlis].car;
1893 g_cells[cell_vm_apply].car = g_cells[cell_vm_evlis].car;
1894 g_cells[cell_vm_apply2].car = g_cells[cell_vm_evlis].car;
1895 g_cells[cell_vm_eval].car = g_cells[cell_vm_evlis].car;
1896 g_cells[cell_vm_eval_pmatch_car].car = g_cells[cell_vm_evlis].car;
1897 g_cells[cell_vm_eval_pmatch_cdr].car = g_cells[cell_vm_evlis].car;
1898 g_cells[cell_vm_eval_define].car = g_cells[cell_vm_evlis].car;
1899 g_cells[cell_vm_eval_set_x].car = g_cells[cell_vm_evlis].car;
1900 g_cells[cell_vm_eval_macro_expand_eval].car = g_cells[cell_vm_evlis].car;
1901 g_cells[cell_vm_eval_macro_expand_expand].car = g_cells[cell_vm_evlis].car;
1902 g_cells[cell_vm_eval_check_func].car = g_cells[cell_vm_evlis].car;
1903 g_cells[cell_vm_eval2].car = g_cells[cell_vm_evlis].car;
1904 g_cells[cell_vm_macro_expand].car = g_cells[cell_vm_evlis].car;
1905 g_cells[cell_vm_macro_expand_define].car = g_cells[cell_vm_evlis].car;
1906 g_cells[cell_vm_macro_expand_define_macro].car = g_cells[cell_vm_evlis].car;
1907 g_cells[cell_vm_macro_expand_lambda].car = g_cells[cell_vm_evlis].car;
1908 g_cells[cell_vm_macro_expand_set_x].car = g_cells[cell_vm_evlis].car;
1909 g_cells[cell_vm_begin_expand_primitive_load].car = g_cells[cell_vm_evlis].car;
1910 g_cells[cell_vm_begin_primitive_load].car = g_cells[cell_vm_evlis].car;
1911 g_cells[cell_vm_macro_expand_car].car = g_cells[cell_vm_evlis].car;
1912 g_cells[cell_vm_macro_expand_cdr].car = g_cells[cell_vm_evlis].car;
1913 g_cells[cell_vm_begin_expand].car = g_cells[cell_vm_evlis].car;
1914 g_cells[cell_vm_begin_expand_eval].car = g_cells[cell_vm_evlis].car;
1915 g_cells[cell_vm_begin_expand_macro].car = g_cells[cell_vm_evlis].car;
1916 g_cells[cell_vm_begin].car = g_cells[cell_vm_evlis].car;
1917 g_cells[cell_vm_begin_read_input_file].car = g_cells[cell_vm_evlis].car;
1918 g_cells[cell_vm_begin_eval].car = g_cells[cell_vm_evlis].car;
1919 g_cells[cell_vm_if].car = g_cells[cell_vm_evlis].car;
1920 g_cells[cell_vm_if_expr].car = g_cells[cell_vm_evlis].car;
1921 g_cells[cell_vm_call_with_values2].car = g_cells[cell_vm_evlis].car;
1922 g_cells[cell_vm_call_with_current_continuation2].car = g_cells[cell_vm_evlis].car;
1923 g_cells[cell_vm_return].car = g_cells[cell_vm_evlis].car;
1924
1925 g_cells[cell_symbol_gnuc].car = cstring_to_list (scm_symbol_gnuc.name);
1926 g_cells[cell_symbol_mesc].car = cstring_to_list (scm_symbol_mesc.name);
1927 g_cells[cell_test].car = cstring_to_list (scm_test.name);
1928 ////////////////// gc
1929
1930 #elif !_POSIX_SOURCE
1931 #include "mes.mes.symbol-names.i"
1932 #else
1933 #include "mes.symbol-names.i"
1934 #endif
1935
1936 #if !MES_MINI
1937   a = acons (cell_symbol_call_with_values, cell_symbol_call_with_values, a);
1938   a = acons (cell_symbol_current_module, cell_symbol_current_module, a);
1939   a = acons (cell_symbol_call_with_current_continuation, cell_call_with_current_continuation, a);
1940
1941   a = acons (cell_symbol_mes_version, MAKE_STRING (cstring_to_list (VERSION)), a);
1942   a = acons (cell_symbol_mes_prefix, MAKE_STRING (cstring_to_list (PREFIX)), a);
1943
1944 #if __GNUC__
1945   a = acons (cell_symbol_gnuc, cell_t, a);
1946   a = acons (cell_symbol_mesc, cell_f, a);
1947 #else
1948   a = acons (cell_symbol_gnuc, cell_f, a);
1949   a = acons (cell_symbol_mesc, cell_t, a);
1950 #endif
1951 #endif // !MES_MINI
1952   a = acons (cell_closure, a, a);
1953
1954   return a;
1955 }
1956
1957 SCM
1958 mes_environment () ///((internal))
1959 {
1960   SCM a = mes_symbols ();
1961   return mes_g_stack (a);
1962 }
1963
1964 SCM
1965 mes_builtins (SCM a) ///((internal))
1966 {
1967 #if MES_MINI
1968
1969 // GCC
1970 //mes
1971 scm_cons.function = g_function;
1972 g_functions[g_function++] = fun_cons;
1973 cell_cons = g_free++;
1974 g_cells[cell_cons] = scm_cons;
1975
1976 scm_car.function = g_function;
1977 g_functions[g_function++] = fun_car;
1978 cell_car = g_free++;
1979 g_cells[cell_car] = scm_car;
1980
1981 scm_cdr.function = g_function;
1982 g_functions[g_function++] = fun_cdr;
1983 cell_cdr = g_free++;
1984 g_cells[cell_cdr] = scm_cdr;
1985
1986 scm_list.function = g_function;
1987 g_functions[g_function++] = fun_list;
1988 cell_list = g_free++;
1989 g_cells[cell_list] = scm_list;
1990
1991 scm_null_p.function = g_function;
1992 g_functions[g_function++] = fun_null_p;
1993 cell_null_p = g_free++;
1994 g_cells[cell_null_p] = scm_null_p;
1995
1996 scm_eq_p.function = g_function;
1997 g_functions[g_function++] = fun_eq_p;
1998 cell_eq_p = g_free++;
1999 g_cells[cell_eq_p] = scm_eq_p;
2000
2001 //math
2002 scm_minus.function = g_function;
2003 g_functions[g_function++] = fun_minus;
2004 cell_minus = g_free++;
2005 g_cells[cell_minus] = scm_minus;
2006
2007 scm_plus.function = g_function;
2008 g_functions[g_function++] = fun_plus;
2009 cell_plus = g_free++;
2010 g_cells[cell_plus] = scm_plus;
2011
2012 //lib
2013 scm_display_.function = g_function;
2014 g_functions[g_function++] = fun_display_;
2015 cell_display_ = g_free++;
2016 g_cells[cell_display_] = scm_display_;
2017
2018 scm_display_error_.function = g_function;
2019 g_functions[g_function++] = fun_display_error_;
2020 cell_display_error_ = g_free++;
2021 g_cells[cell_display_error_] = scm_display_error_;
2022
2023
2024
2025 //mes.environment
2026 scm_cons.string = cstring_to_list (fun_cons.name);
2027 g_cells[cell_cons].string = MAKE_STRING (scm_cons.string);
2028 a = acons (lookup_symbol_ (scm_cons.string), cell_cons, a);
2029
2030 scm_car.string = cstring_to_list (fun_car.name);
2031 g_cells[cell_car].string = MAKE_STRING (scm_car.string);
2032 a = acons (lookup_symbol_ (scm_car.string), cell_car, a);
2033
2034 scm_cdr.string = cstring_to_list (fun_cdr.name);
2035 g_cells[cell_cdr].string = MAKE_STRING (scm_cdr.string);
2036 a = acons (lookup_symbol_ (scm_cdr.string), cell_cdr, a);
2037
2038 scm_list.string = cstring_to_list (fun_list.name);
2039 g_cells[cell_list].string = MAKE_STRING (scm_list.string);
2040 a = acons (lookup_symbol_ (scm_list.string), cell_list, a);
2041
2042 scm_null_p.string = cstring_to_list (fun_null_p.name);
2043 g_cells[cell_null_p].string = MAKE_STRING (scm_null_p.string);
2044 a = acons (lookup_symbol_ (scm_null_p.string), cell_null_p, a);
2045
2046 scm_eq_p.string = cstring_to_list (fun_eq_p.name);
2047 g_cells[cell_eq_p].string = MAKE_STRING (scm_eq_p.string);
2048 a = acons (lookup_symbol_ (scm_eq_p.string), cell_eq_p, a);
2049
2050 //math.environment
2051  scm_minus.string = cstring_to_list (fun_minus.name);
2052 g_cells[cell_minus].string = MAKE_STRING (scm_minus.string);
2053 a = acons (lookup_symbol_ (scm_minus.string), cell_minus, a);
2054
2055 scm_plus.string = cstring_to_list (fun_plus.name);
2056 g_cells[cell_plus].string = MAKE_STRING (scm_plus.string);
2057 a = acons (lookup_symbol_ (scm_plus.string), cell_plus, a);
2058
2059 //lib.environment
2060 scm_display_.string = cstring_to_list (fun_display_.name);
2061 g_cells[cell_display_].string = MAKE_STRING (scm_display_.string);
2062 a = acons (lookup_symbol_ (scm_display_.string), cell_display_, a);
2063
2064 scm_display_error_.string = cstring_to_list (fun_display_error_.name);
2065 g_cells[cell_display_error_].string = MAKE_STRING (scm_display_error_.string);
2066 a = acons (lookup_symbol_ (scm_display_error_.string), cell_display_error_, a);
2067
2068
2069 // MESC/MES
2070 //mes
2071 // scm_cons.cdr = g_function;
2072 // g_functions[g_function++] = fun_cons;
2073 // cell_cons = g_free++;
2074 // g_cells[cell_cons] = scm_cons;
2075
2076 // scm_car.cdr = g_function;
2077 // g_functions[g_function++] = fun_car;
2078 // cell_car = g_free++;
2079 // g_cells[cell_car] = scm_car;
2080
2081 // scm_cdr.cdr = g_function;
2082 // g_functions[g_function++] = fun_cdr;
2083 // cell_cdr = g_free++;
2084 // g_cells[cell_cdr] = scm_cdr;
2085
2086 // scm_list.cdr = g_function;
2087 // g_functions[g_function++] = fun_list;
2088 // cell_list = g_free++;
2089 // g_cells[cell_list] = scm_list;
2090
2091 // scm_null_p.cdr = g_function;
2092 // g_functions[g_function++] = fun_null_p;
2093 // cell_null_p = g_free++;
2094 // g_cells[cell_null_p] = scm_null_p;
2095
2096 // scm_eq_p.cdr = g_function;
2097 // g_functions[g_function++] = fun_eq_p;
2098 // cell_eq_p = g_free++;
2099 // g_cells[cell_eq_p] = scm_eq_p;
2100
2101 //lib
2102 // scm_display_.cdr = g_function;
2103 // g_functions[g_function++] = fun_display_;
2104 // cell_display_ = g_free++;
2105 // g_cells[cell_display_] = scm_display_;
2106
2107 // scm_display_error_.cdr = g_function;
2108 // g_functions[g_function++] = fun_display_error_;
2109 // cell_display_error_ = g_free++;
2110 // g_cells[cell_display_error_] = scm_display_error_;
2111
2112
2113
2114 #elif !__GNUC__ || !_POSIX_SOURCE
2115 #include "mes.mes.i"
2116
2117   // Do not sort: Order of these includes define builtins
2118 #include "posix.mes.i"
2119 #include "math.mes.i"
2120 #include "lib.mes.i"
2121 #include "vector.mes.i"
2122 #include "gc.mes.i"
2123 #include "reader.mes.i"
2124
2125 #include "gc.mes.environment.i"
2126 #include "lib.mes.environment.i"
2127 #include "math.mes.environment.i"
2128 #include "mes.mes.environment.i"
2129 #include "posix.mes.environment.i"
2130 #include "reader.mes.environment.i"
2131 #include "vector.mes.environment.i"
2132 #else
2133 #include "mes.i"
2134
2135   // Do not sort: Order of these includes define builtins
2136 #include "posix.i"
2137 #include "math.i"
2138 #include "lib.i"
2139 #include "vector.i"
2140 #include "gc.i"
2141 #include "reader.i"
2142
2143 #include "gc.environment.i"
2144 #include "lib.environment.i"
2145 #include "math.environment.i"
2146 #include "mes.environment.i"
2147 #include "posix.environment.i"
2148 #include "reader.environment.i"
2149 #include "vector.environment.i"
2150 #endif
2151
2152   if (g_debug > 3)
2153     {
2154       fputs ("functions: ", STDERR);
2155       fputs (itoa (g_function), STDERR);
2156       fputs ("\n", STDERR);
2157       for (int i = 0; i < g_function; i++)
2158         {
2159           fputs ("[", STDERR);
2160           fputs (itoa (i), STDERR);
2161           fputs ("]: ", STDERR);
2162           fputs (g_functions[i].name, STDERR);
2163           fputs ("\n", STDERR);
2164         }
2165       fputs ("\n", STDERR);
2166     }
2167
2168   return a;
2169 }
2170
2171 SCM read_input_file_env (SCM);
2172
2173 SCM
2174 load_env (SCM a) ///((internal))
2175 {
2176   r0 = a;
2177   g_stdin = -1;
2178   char boot[128];
2179   char buf[128];
2180   if (getenv ("MES_BOOT"))
2181     strcpy (boot, getenv ("MES_BOOT"));
2182   else
2183     strcpy (boot, "boot-0.scm");
2184   if (getenv ("MES_PREFIX"))
2185     {
2186       strcpy (buf, getenv ("MES_PREFIX"));
2187       strcpy (buf + strlen (buf), "/module");
2188       strcpy (buf + strlen (buf), "/mes/");
2189       strcpy (buf + strlen (buf), boot);
2190       if (getenv ("MES_DEBUG"))
2191         {
2192           eputs ("MES_PREFIX reading boot-0:");
2193           eputs (buf);
2194           eputs ("\n");
2195         }
2196       g_stdin = open (buf, O_RDONLY);
2197     }
2198   if (g_stdin < 0)
2199     {
2200       char const *prefix = MODULEDIR "mes/";
2201       strcpy (buf, prefix);
2202       strcpy (buf + strlen (buf), boot);
2203       if (getenv ("MES_DEBUG"))
2204         {
2205           eputs ("MODULEDIR reading boot-0:");
2206           eputs (buf);
2207           eputs ("\n");
2208         }
2209       g_stdin = open (buf, O_RDONLY);
2210     }
2211   if (g_stdin < 0)
2212     {
2213       strcpy (buf, "module/mes/");
2214       strcpy (buf + strlen (buf), boot);
2215       if (getenv ("MES_DEBUG"))
2216         {
2217           eputs (". reading boot-0:");
2218           eputs (buf);
2219           eputs ("\n");
2220         }
2221       g_stdin = open (buf, O_RDONLY);
2222     }
2223   if (g_stdin < 0)
2224     {
2225       if (getenv ("MES_DEBUG"))
2226         {
2227           eputs (". reading boot-0:");
2228           eputs (boot);
2229           eputs ("\n");
2230         }
2231       g_stdin = open (boot, O_RDONLY);
2232     }
2233   if (g_stdin < 0)
2234     {
2235       eputs ("mes: boot failed: no such file: ");
2236       eputs (boot);
2237       eputs ("\n");
2238       exit (1);
2239     }
2240
2241   if (!g_function)
2242     r0 = mes_builtins (r0);
2243   r2 = read_input_file_env (r0);
2244   g_stdin = STDIN;
2245   return r2;
2246 }
2247
2248 SCM
2249 bload_env (SCM a) ///((internal))
2250 {
2251 #if !_POSIX_SOURCE
2252   char *mo = "mes/read-0-32.mo";
2253   g_stdin = open ("module/mes/boot-0.32-mo", O_RDONLY);
2254   char *read0 = MODULEDIR "mes/boot-0.32-mo";
2255   g_stdin = g_stdin >= 0 ? g_stdin : open (read0, O_RDONLY);
2256 #else
2257   char *mo ="mes/boot-0.mo";
2258   g_stdin = open ("module/mes/boot-0.mo", O_RDONLY);
2259   g_stdin = g_stdin >= 0 ? g_stdin : open (MODULEDIR "mes/boot-0.mo", O_RDONLY);
2260 #endif
2261
2262   if (g_stdin < 0)
2263     {
2264       eputs ("no such file: ");
2265       eputs (mo);
2266       eputs ("\n");
2267       return 1;
2268     }
2269   assert (getchar () == 'M');
2270   assert (getchar () == 'E');
2271   assert (getchar () == 'S');
2272
2273   if (g_debug)
2274     eputs ("*GOT MES*\n");
2275   g_stack = getchar () << 8;
2276   g_stack += getchar ();
2277
2278   char *p = (char*)g_cells;
2279   int c = getchar ();
2280   while (c != EOF)
2281     {
2282       *p++ = c;
2283       c = getchar ();
2284     }
2285   g_free = (p-(char*)g_cells) / sizeof (struct scm);
2286   gc_peek_frame ();
2287   g_symbols = r1;
2288   g_stdin = STDIN;
2289   r0 = mes_builtins (r0);
2290
2291 #if __GNUC__
2292   set_env_x (cell_symbol_gnuc, cell_t, r0);
2293   set_env_x (cell_symbol_mesc, cell_f, r0);
2294 #else
2295   set_env_x (cell_symbol_gnuc, cell_f, r0);
2296   set_env_x (cell_symbol_mesc, cell_t, r0);
2297 #endif
2298
2299   if (g_debug > 3)
2300     {
2301       eputs ("symbols: ");
2302       SCM s = g_symbols;
2303       while (s && s != cell_nil)
2304         {
2305           display_error_ (CAR (s));
2306           eputs (" ");
2307           s = CDR (s);
2308         }
2309       eputs ("\n");
2310       eputs ("functions: ");
2311       eputs (itoa (g_function));
2312       eputs ("\n");
2313       for (int i = 0; i < g_function; i++)
2314         {
2315           eputs ("[");
2316           eputs (itoa (i));
2317           eputs ("]: ");
2318           eputs (g_functions[i].name);
2319           eputs ("\n");
2320         }
2321     }
2322   return r2;
2323 }
2324
2325 #include "vector.c"
2326 #include "gc.c"
2327 #include "reader.c"
2328
2329 int
2330 main (int argc, char *argv[])
2331 {
2332   char *p;
2333   if (p = getenv ("MES_DEBUG"))
2334     g_debug = atoi (p);
2335   if (g_debug)
2336     {
2337       eputs (";;; MODULEDIR=");
2338       eputs (MODULEDIR);
2339       eputs ("\n");
2340     }
2341   if (p = getenv ("MES_MAX_ARENA"))
2342     MAX_ARENA_SIZE = atoi (p);
2343   if (p = getenv ("MES_ARENA"))
2344     ARENA_SIZE = atoi (p);
2345   JAM_SIZE = ARENA_SIZE / 10;
2346   if (p = getenv ("MES_JAM"))
2347     JAM_SIZE = atoi (p);
2348   GC_SAFETY = ARENA_SIZE / 100;
2349   if (p = getenv ("MES_SAFETY"))
2350     GC_SAFETY = atoi (p);
2351   g_stdin = STDIN;
2352   g_stdout = STDOUT;
2353   r0 = mes_environment ();
2354
2355   SCM program = (argc > 1 && !strcmp (argv[1], "--load"))
2356     ? bload_env (r0) : load_env (r0);
2357   if (argc > 1 && !strcmp (argv[1], "--dump"))
2358     return dump ();
2359
2360 #if !MES_MINI
2361   SCM lst = cell_nil;
2362   for (int i=argc-1; i>=0; i--)
2363     lst = cons (MAKE_STRING (cstring_to_list (argv[i])), lst);
2364   r0 = acons (cell_symbol_argv, lst, r0); // FIXME
2365   r0 = acons (cell_symbol_argv, lst, r0);
2366 #endif
2367   push_cc (r2, cell_unspecified, r0, cell_unspecified);
2368
2369   if (g_debug > 2)
2370     {
2371       eputs ("\ngc stats: [");
2372       eputs (itoa (g_free));
2373       eputs ("]\n");
2374     }
2375   if (g_debug > 3)
2376     {
2377       eputs ("program: ");
2378       write_error_ (r1);
2379       eputs ("\n");
2380     }
2381   if (g_debug > 3)
2382     {
2383       eputs ("symbols: ");
2384       write_error_ (g_symbols);
2385       eputs ("\n");
2386     }
2387   r3 = cell_vm_begin_expand;
2388   r1 = eval_apply ();
2389   if (g_debug)
2390     {
2391       write_error_ (r1);
2392       eputs ("\n");
2393     }
2394   if (g_debug)
2395     {
2396       eputs ("\ngc stats: [");
2397       eputs (itoa (g_free));
2398       MAX_ARENA_SIZE = 0;
2399       gc (g_stack);
2400       eputs (" => ");
2401       eputs (itoa (g_free));
2402       eputs ("]\n");
2403     }
2404   return 0;
2405 }