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