src/mes.c

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