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