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