src/mes.c

   1 /* -*-comment-start: "//";comment-end:""-*-
   2  * GNU Mes --- Maxwell Equations of Software
   3  * Copyright © 2016,2017,2018,2019 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 "mes/lib.h"
  22 #include "mes/mes.h"
  23
  24 #include <assert.h>
  25 #include <fcntl.h>
  26 #include <stdlib.h>
  27 #include <string.h>
  28 #include <string.h>
  29
  30 char g_datadir[1024];
  31 int g_debug;
  32 char *g_buf;
  33 SCM g_continuations;
  34 SCM g_symbols;
  35 SCM g_symbol_max;
  36
  37 // a/env
  38 SCM r0;
  39 // param 1
  40 SCM r1;
  41 // save 2
  42 SCM r2;
  43 // continuation
  44 SCM r3;
  45 // current-module
  46 SCM m0;
  47 // macro
  48 SCM g_macros;
  49 SCM g_ports;
  50
  51 #if __MESC__
  52 typedef long function0_t;
  53 typedef long function1_t;
  54 typedef long function2_t;
  55 typedef long function3_t;
  56 typedef long functionn_t;
  57 #else // !__MESC__
  58 typedef SCM (*function0_t) (void);
  59 typedef SCM (*function1_t) (SCM);
  60 typedef SCM (*function2_t) (SCM, SCM);
  61 typedef SCM (*function3_t) (SCM, SCM, SCM);
  62 typedef SCM (*functionn_t) (SCM);
  63 #endif // !__MESC__
  64
  65 SCM
  66 alloc (long n)
  67 {
  68   SCM x = g_free;
  69   g_free += n;
  70   if (g_free > ARENA_SIZE)
  71     assert (!"alloc: out of memory");
  72   return x;
  73 }
  74
  75 SCM
  76 make_cell__ (long type, SCM car, SCM cdr)
  77 {
  78   SCM x = alloc (1);
  79   TYPE (x) = type;
  80   CAR (x) = car;
  81   CDR (x) = cdr;
  82   return x;
  83 }
  84
  85 SCM
  86 make_cell_ (SCM type, SCM car, SCM cdr)
  87 {
  88   assert (TYPE (type) == TNUMBER);
  89   long t = VALUE (type);
  90   if (t == TCHAR || t == TNUMBER)
  91     return make_cell__ (t, car ? CAR (car) : 0, cdr ? CDR (cdr) : 0);
  92   return make_cell__ (t, car, cdr);
  93 }
  94
  95 SCM
  96 assoc_string (SCM x, SCM a)     ///((internal))
  97 {
  98   while (a != cell_nil && (TYPE (CAAR (a)) != TSTRING || string_equal_p (x, CAAR (a)) == cell_f))
  99     a = CDR (a);
 100   return a != cell_nil ? CAR (a) : cell_f;
 101 }
 102
 103 SCM
 104 type_ (SCM x)
 105 {
 106   return MAKE_NUMBER (TYPE (x));
 107 }
 108
 109 // SCM
 110 // car_to_cell_ (SCM x)
 111 // {
 112 //   return CAR (x);
 113 // }
 114
 115 // SCM
 116 // cdr_to_cell_ (SCM x)
 117 // {
 118 //   return CDR (x);
 119 // }
 120
 121 // SCM
 122 // car_to_number_ (SCM x)
 123 // {
 124 //   return MAKE_NUMBER (CAR (x));
 125 // }
 126
 127 // SCM
 128 // cdr_to_number_ (SCM x)
 129 // {
 130 //   return MAKE_NUMBER (CDR (x));
 131 // }
 132
 133 SCM
 134 car_ (SCM x)
 135 {
 136   return (TYPE (x) != TCONTINUATION && (TYPE (CAR (x)) == TPAIR // FIXME: this is weird
 137                                         || TYPE (CAR (x)) == TREF
 138                                         || TYPE (CAR (x)) == TSPECIAL
 139                                         || TYPE (CAR (x)) == TSYMBOL
 140                                         || TYPE (CAR (x)) == TSTRING)) ? CAR (x) : MAKE_NUMBER (CAR (x));
 141 }
 142
 143 SCM
 144 cdr_ (SCM x)
 145 {
 146   return (TYPE (x) != TCHAR
 147           && TYPE (x) != TNUMBER
 148           && TYPE (x) != TPORT
 149           && (TYPE (CDR (x)) == TPAIR
 150               || TYPE (CDR (x)) == TREF
 151               || TYPE (CDR (x)) == TSPECIAL
 152               || TYPE (CDR (x)) == TSYMBOL || TYPE (CDR (x)) == TSTRING)) ? CDR (x) : MAKE_NUMBER (CDR (x));
 153 }
 154
 155 SCM
 156 cons (SCM x, SCM y)
 157 {
 158   return make_cell__ (TPAIR, x, y);
 159 }
 160
 161 SCM
 162 car (SCM x)
 163 {
 164 #if !__MESC_MES__
 165   if (TYPE (x) != TPAIR)
 166     error (cell_symbol_not_a_pair, cons (x, cell_symbol_car));
 167 #endif
 168   return CAR (x);
 169 }
 170
 171 SCM
 172 cdr (SCM x)
 173 {
 174 #if !__MESC_MES__
 175   if (TYPE (x) != TPAIR)
 176     error (cell_symbol_not_a_pair, cons (x, cell_symbol_cdr));
 177 #endif
 178   return CDR (x);
 179 }
 180
 181 SCM
 182 list (SCM x)                    ///((arity . n))
 183 {
 184   return x;
 185 }
 186
 187 SCM
 188 null_p (SCM x)
 189 {
 190   return x == cell_nil ? cell_t : cell_f;
 191 }
 192
 193 SCM
 194 eq_p (SCM x, SCM y)
 195 {
 196   return (x == y
 197           || ((TYPE (x) == TKEYWORD && TYPE (y) == TKEYWORD
 198                && string_equal_p (x, y) == cell_t))
 199           || (TYPE (x) == TCHAR && TYPE (y) == TCHAR
 200               && VALUE (x) == VALUE (y))
 201           || (TYPE (x) == TNUMBER && TYPE (y) == TNUMBER && VALUE (x) == VALUE (y))) ? cell_t : cell_f;
 202 }
 203
 204 SCM
 205 values (SCM x)                  ///((arity . n))
 206 {
 207   SCM v = cons (0, x);
 208   TYPE (v) = TVALUES;
 209   return v;
 210 }
 211
 212 SCM
 213 acons (SCM key, SCM value, SCM alist)
 214 {
 215   return cons (cons (key, value), alist);
 216 }
 217
 218 long
 219 length__ (SCM x)                ///((internal))
 220 {
 221   long n = 0;
 222   while (x != cell_nil)
 223     {
 224       n++;
 225       if (TYPE (x) != TPAIR)
 226         return -1;
 227       x = CDR (x);
 228     }
 229   return n;
 230 }
 231
 232 SCM
 233 length (SCM x)
 234 {
 235   return MAKE_NUMBER (length__ (x));
 236 }
 237
 238 SCM
 239 error (SCM key, SCM x)
 240 {
 241 #if !__MESC_MES__
 242   SCM throw;
 243   if ((throw = module_ref (r0, cell_symbol_throw)) != cell_undefined)
 244     return apply (throw, cons (key, cons (x, cell_nil)), r0);
 245 #endif
 246   display_error_ (key);
 247   eputs (": ");
 248   write_error_ (x);
 249   eputs ("\n");
 250   assert (0);
 251   exit (1);
 252 }
 253
 254 // \f extra lib
 255 SCM
 256 assert_defined (SCM x, SCM e)   ///((internal))
 257 {
 258   if (e == cell_undefined)
 259     return error (cell_symbol_unbound_variable, x);
 260   return e;
 261 }
 262
 263 SCM
 264 check_formals (SCM f, SCM formals, SCM args)    ///((internal))
 265 {
 266   long flen = (TYPE (formals) == TNUMBER) ? VALUE (formals) : length__ (formals);
 267   long alen = length__ (args);
 268   if (alen != flen && alen != -1 && flen != -1)
 269     {
 270       char *s = "apply: wrong number of arguments; expected: ";
 271       eputs (s);
 272       eputs (itoa (flen));
 273       eputs (", got: ");
 274       eputs (itoa (alen));
 275       eputs ("\n");
 276       write_error_ (f);
 277       SCM e = MAKE_STRING0 (s);
 278       return error (cell_symbol_wrong_number_of_args, cons (e, f));
 279     }
 280   return cell_unspecified;
 281 }
 282
 283 SCM
 284 check_apply (SCM f, SCM e)      ///((internal))
 285 {
 286   char *type = 0;
 287   if (f == cell_f || f == cell_t)
 288     type = "bool";
 289   if (f == cell_nil)
 290     type = "nil";
 291   if (f == cell_unspecified)
 292     type = "*unspecified*";
 293   if (f == cell_undefined)
 294     type = "*undefined*";
 295   if (TYPE (f) == TCHAR)
 296     type = "char";
 297   if (TYPE (f) == TNUMBER)
 298     type = "number";
 299   if (TYPE (f) == TSTRING)
 300     type = "string";
 301   if (TYPE (f) == TSTRUCT && builtin_p (f) == cell_f)
 302     type = "#<...>";
 303   if (TYPE (f) == TBROKEN_HEART)
 304     type = "<3";
 305
 306   if (type)
 307     {
 308       char *s = "cannot apply: ";
 309       eputs (s);
 310       eputs (type);
 311       eputs ("[");
 312       write_error_ (e);
 313       eputs ("]\n");
 314       SCM e = MAKE_STRING0 (s);
 315       return error (cell_symbol_wrong_type_arg, cons (e, f));
 316     }
 317   return cell_unspecified;
 318 }
 319
 320 SCM
 321 append2 (SCM x, SCM y)
 322 {
 323   if (x == cell_nil)
 324     return y;
 325   if (TYPE (x) != TPAIR)
 326     error (cell_symbol_not_a_pair, cons (x, cstring_to_symbol ("append2")));
 327   SCM r = cell_nil;
 328   while (x != cell_nil)
 329     {
 330       r = cons (CAR (x), r);
 331       x = CDR (x);
 332     }
 333   return reverse_x_ (r, y);
 334 }
 335
 336 SCM
 337 append_reverse (SCM x, SCM y)
 338 {
 339   if (x == cell_nil)
 340     return y;
 341   if (TYPE (x) != TPAIR)
 342     error (cell_symbol_not_a_pair, cons (x, cstring_to_symbol ("append-reverse")));
 343   while (x != cell_nil)
 344     {
 345       y = cons (CAR (x), y);
 346       x = CDR (x);
 347     }
 348   return y;
 349 }
 350
 351 SCM
 352 reverse_x_ (SCM x, SCM t)
 353 {
 354   if (x != cell_nil && TYPE (x) != TPAIR)
 355     error (cell_symbol_not_a_pair, cons (x, cstring_to_symbol ("core:reverse!")));
 356   SCM r = t;
 357   while (x != cell_nil)
 358     {
 359       t = CDR (x);
 360       CDR (x) = r;
 361       r = x;
 362       x = t;
 363     }
 364   return r;
 365 }
 366
 367 SCM
 368 pairlis (SCM x, SCM y, SCM a)
 369 {
 370   if (x == cell_nil)
 371     return a;
 372   if (TYPE (x) != TPAIR)
 373     return cons (cons (x, y), a);
 374   return cons (cons (car (x), car (y)), pairlis (cdr (x), cdr (y), a));
 375 }
 376
 377 SCM
 378 assq (SCM x, SCM a)
 379 {
 380   if (TYPE (a) != TPAIR)
 381     return cell_f;
 382   int t = TYPE (x);
 383   if (t == TSYMBOL || t == TSPECIAL)
 384     while (a != cell_nil && x != CAAR (a))
 385       a = CDR (a);
 386   else if (t == TCHAR || t == TNUMBER)
 387     {
 388       SCM v = VALUE (x);
 389       while (a != cell_nil && v != VALUE (CAAR (a)))
 390         a = CDR (a);
 391     }
 392   else if (t == TKEYWORD)
 393     {
 394       while (a != cell_nil && string_equal_p (x, CAAR (a)) == cell_f)
 395         a = CDR (a);
 396     }
 397   else
 398     /* pointer equality, e.g. on strings. */
 399     while (a != cell_nil && x != CAAR (a))
 400       a = CDR (a);
 401   return a != cell_nil ? CAR (a) : cell_f;
 402 }
 403
 404 SCM
 405 assoc (SCM x, SCM a)
 406 {
 407   if (TYPE (x) == TSTRING)
 408     return assoc_string (x, a);
 409   while (a != cell_nil && equal2_p (x, CAAR (a)) == cell_f)
 410     a = CDR (a);
 411   return a != cell_nil ? CAR (a) : cell_f;
 412 }
 413
 414 SCM
 415 set_car_x (SCM x, SCM e)
 416 {
 417   if (TYPE (x) != TPAIR)
 418     error (cell_symbol_not_a_pair, cons (x, cstring_to_symbol ("set-car!")));
 419   CAR (x) = e;
 420   return cell_unspecified;
 421 }
 422
 423 SCM
 424 set_cdr_x (SCM x, SCM e)
 425 {
 426   if (TYPE (x) != TPAIR)
 427     error (cell_symbol_not_a_pair, cons (x, cstring_to_symbol ("set-cdr!")));
 428   CDR (x) = e;
 429   return cell_unspecified;
 430 }
 431
 432 SCM
 433 set_env_x (SCM x, SCM e, SCM a)
 434 {
 435   SCM p;
 436   if (TYPE (x) == TVARIABLE)
 437     p = VARIABLE (x);
 438   else
 439     p = assert_defined (x, module_variable (a, x));
 440   if (TYPE (p) != TPAIR)
 441     error (cell_symbol_not_a_pair, cons (p, x));
 442   return set_cdr_x (p, e);
 443 }
 444
 445 SCM
 446 call_lambda (SCM e, SCM x, SCM aa, SCM a)       ///((internal))
 447 {
 448   SCM cl = cons (cons (cell_closure, x), x);
 449   r1 = e;
 450   r0 = cl;
 451   return cell_unspecified;
 452 }
 453
 454 SCM
 455 make_closure_ (SCM args, SCM body, SCM a)       ///((internal))
 456 {
 457   return make_cell__ (TCLOSURE, cell_f, cons (cons (cell_circular, a), cons (args, body)));
 458 }
 459
 460 SCM
 461 make_variable_ (SCM var)        ///((internal))
 462 {
 463   return make_cell__ (TVARIABLE, var, 0);
 464 }
 465
 466 SCM
 467 macro_get_handle (SCM name)
 468 {
 469   if (TYPE (name) == TSYMBOL)
 470     return hashq_get_handle (g_macros, name, cell_nil);
 471   return cell_f;
 472 }
 473
 474 SCM
 475 get_macro (SCM name)            ///((internal))
 476 {
 477   SCM m = macro_get_handle (name);
 478   if (m != cell_f)
 479     return MACRO (CDR (m));
 480   return cell_f;
 481 }
 482
 483 SCM
 484 macro_set_x (SCM name, SCM value)       ///((internal))
 485 {
 486   return hashq_set_x (g_macros, name, value);
 487 }
 488
 489 SCM
 490 push_cc (SCM p1, SCM p2, SCM a, SCM c)  ///((internal))
 491 {
 492   SCM x = r3;
 493   r3 = c;
 494   r2 = p2;
 495   gc_push_frame ();
 496   r1 = p1;
 497   r0 = a;
 498   r3 = x;
 499   return cell_unspecified;
 500 }
 501
 502 SCM
 503 add_formals (SCM formals, SCM x)
 504 {
 505   while (TYPE (x) == TPAIR)
 506     {
 507       formals = cons (CAR (x), formals);
 508       x = CDR (x);
 509     }
 510   if (TYPE (x) == TSYMBOL)
 511     formals = cons (x, formals);
 512   return formals;
 513 }
 514
 515 int
 516 formal_p (SCM x, SCM formals)   /// ((internal))
 517 {
 518   if (TYPE (formals) == TSYMBOL)
 519     {
 520       if (x == formals)
 521         return x;
 522       else
 523         return cell_f;
 524     }
 525   while (TYPE (formals) == TPAIR && CAR (formals) != x)
 526     formals = CDR (formals);
 527   if (TYPE (formals) == TSYMBOL)
 528     return formals == x;
 529   return TYPE (formals) == TPAIR;
 530 }
 531
 532 SCM
 533 expand_variable_ (SCM x, SCM formals, int top_p)        ///((internal))
 534 {
 535   while (TYPE (x) == TPAIR)
 536     {
 537       if (TYPE (CAR (x)) == TPAIR)
 538         {
 539           if (CAAR (x) == cell_symbol_lambda)
 540             {
 541               SCM f = CAR (CDAR (x));
 542               formals = add_formals (formals, f);
 543             }
 544           else if (CAAR (x) == cell_symbol_define || CAAR (x) == cell_symbol_define_macro)
 545             {
 546               SCM f = CAR (CDAR (x));
 547               formals = add_formals (formals, f);
 548             }
 549           if (CAAR (x) != cell_symbol_quote)
 550             expand_variable_ (CAR (x), formals, 0);
 551         }
 552       else
 553         {
 554           if (CAR (x) == cell_symbol_lambda)
 555             {
 556               SCM f = CADR (x);
 557               formals = add_formals (formals, f);
 558               x = CDR (x);
 559             }
 560           else if (CAR (x) == cell_symbol_define || CAR (x) == cell_symbol_define_macro)
 561             {
 562               SCM f = CADR (x);
 563               if (top_p && TYPE (f) == TPAIR)
 564                 f = CDR (f);
 565               formals = add_formals (formals, f);
 566               x = CDR (x);
 567             }
 568           else if (CAR (x) == cell_symbol_quote)
 569             return cell_unspecified;
 570           else if (TYPE (CAR (x)) == TSYMBOL
 571                    && CAR (x) != cell_symbol_boot_module
 572                    && CAR (x) != cell_symbol_current_module
 573                    && CAR (x) != cell_symbol_primitive_load && !formal_p (CAR (x), formals))
 574             {
 575               SCM v = module_variable (r0, CAR (x));
 576               if (v != cell_f)
 577                 CAR (x) = make_variable_ (v);
 578             }
 579         }
 580       x = CDR (x);
 581       top_p = 0;
 582     }
 583   return cell_unspecified;
 584 }
 585
 586 SCM
 587 expand_variable (SCM x, SCM formals)    ///((internal))
 588 {
 589   return expand_variable_ (x, formals, 1);
 590 }
 591
 592 SCM
 593 eval_apply ()
 594 {
 595   SCM aa;
 596   SCM args;
 597   SCM body;
 598   SCM cl;
 599   SCM entry;
 600   SCM expanders;
 601   SCM formals;
 602   SCM input;
 603   SCM name;
 604   SCM macro;
 605   SCM p;
 606   SCM program;
 607   SCM sc_expand;
 608   SCM v;
 609   SCM x;
 610   int global_p;
 611   int macro_p;
 612   int t;
 613   long c;
 614
 615 eval_apply:
 616   if (r3 == cell_vm_evlis2)
 617     goto evlis2;
 618   else if (r3 == cell_vm_evlis3)
 619     goto evlis3;
 620   else if (r3 == cell_vm_eval_check_func)
 621     goto eval_check_func;
 622   else if (r3 == cell_vm_eval2)
 623     goto eval2;
 624   else if (r3 == cell_vm_apply2)
 625     goto apply2;
 626   else if (r3 == cell_vm_if_expr)
 627     goto if_expr;
 628   else if (r3 == cell_vm_begin_eval)
 629     goto begin_eval;
 630   else if (r3 == cell_vm_eval_set_x)
 631     goto eval_set_x;
 632   else if (r3 == cell_vm_macro_expand_car)
 633     goto macro_expand_car;
 634   else if (r3 == cell_vm_return)
 635     goto vm_return;
 636   else if (r3 == cell_vm_macro_expand_cdr)
 637     goto macro_expand_cdr;
 638   else if (r3 == cell_vm_eval_define)
 639     goto eval_define;
 640   else if (r3 == cell_vm_macro_expand)
 641     goto macro_expand;
 642   else if (r3 == cell_vm_macro_expand_lambda)
 643     goto macro_expand_lambda;
 644   else if (r3 == cell_vm_eval_pmatch_car)
 645     goto eval_pmatch_car;
 646   else if (r3 == cell_vm_begin_expand_macro)
 647     goto begin_expand_macro;
 648   else if (r3 == cell_vm_macro_expand_define)
 649     goto macro_expand_define;
 650   else if (r3 == cell_vm_begin_expand_eval)
 651     goto begin_expand_eval;
 652   else if (r3 == cell_vm_call_with_current_continuation2)
 653     goto call_with_current_continuation2;
 654   else if (r3 == cell_vm_macro_expand_set_x)
 655     goto macro_expand_set_x;
 656   else if (r3 == cell_vm_eval_pmatch_cdr)
 657     goto eval_pmatch_cdr;
 658   else if (r3 == cell_vm_macro_expand_define_macro)
 659     goto macro_expand_define_macro;
 660   else if (r3 == cell_vm_begin_primitive_load)
 661     goto begin_primitive_load;
 662
 663   else if (r3 == cell_vm_evlis)
 664     goto evlis;
 665   else if (r3 == cell_vm_apply)
 666     goto apply;
 667   else if (r3 == cell_vm_eval)
 668     goto eval;
 669   else if (r3 == cell_vm_eval_macro_expand_eval)
 670     goto eval_macro_expand_eval;
 671   else if (r3 == cell_vm_eval_macro_expand_expand)
 672     goto eval_macro_expand_expand;
 673   else if (r3 == cell_vm_begin)
 674     goto begin;
 675   else if (r3 == cell_vm_begin_expand)
 676     goto begin_expand;
 677   else if (r3 == cell_vm_begin_expand_primitive_load)
 678     goto begin_expand_primitive_load;
 679   else if (r3 == cell_vm_if)
 680     goto vm_if;
 681   else if (r3 == cell_vm_call_with_values2)
 682     goto call_with_values2;
 683   else if (r3 == cell_unspecified)
 684     return r1;
 685   else
 686     error (cell_symbol_system_error, MAKE_STRING0 ("eval/apply unknown continuation"));
 687
 688 evlis:
 689   if (r1 == cell_nil)
 690     goto vm_return;
 691   if (TYPE (r1) != TPAIR)
 692     goto eval;
 693   push_cc (CAR (r1), r1, r0, cell_vm_evlis2);
 694   goto eval;
 695 evlis2:
 696   push_cc (CDR (r2), r1, r0, cell_vm_evlis3);
 697   goto evlis;
 698 evlis3:
 699   r1 = cons (r2, r1);
 700   goto vm_return;
 701
 702 apply:
 703   g_stack_array[g_stack + FRAME_PROCEDURE] = CAR (r1);
 704   t = TYPE (CAR (r1));
 705   if (t == TSTRUCT && builtin_p (CAR (r1)) == cell_t)
 706     {
 707       check_formals (CAR (r1), builtin_arity (CAR (r1)), CDR (r1));
 708       r1 = apply_builtin (CAR (r1), CDR (r1));  /// FIXME: move into eval_apply
 709       goto vm_return;
 710     }
 711   else if (t == TCLOSURE)
 712     {
 713       cl = CLOSURE (CAR (r1));
 714       body = CDDR (cl);
 715       formals = CADR (cl);
 716       args = CDR (r1);
 717       aa = CDAR (cl);
 718       aa = CDR (aa);
 719       check_formals (CAR (r1), formals, CDR (r1));
 720       p = pairlis (formals, args, aa);
 721       call_lambda (body, p, aa, r0);
 722       goto begin;
 723     }
 724   else if (t == TCONTINUATION)
 725     {
 726       v = CONTINUATION (CAR (r1));
 727       if (LENGTH (v))
 728         {
 729           for (t = 0; t < LENGTH (v); t++)
 730             g_stack_array[STACK_SIZE - LENGTH (v) + t] = vector_ref_ (v, t);
 731           g_stack = STACK_SIZE - LENGTH (v);
 732         }
 733       x = r1;
 734       gc_pop_frame ();
 735       r1 = CADR (x);
 736       goto eval_apply;
 737     }
 738   else if (t == TSPECIAL)
 739     {
 740       c = CAR (r1);
 741       if (c == cell_vm_apply)
 742         {
 743           push_cc (cons (CADR (r1), CADDR (r1)), r1, r0, cell_vm_return);
 744           goto apply;
 745         }
 746       else if (c == cell_vm_eval)
 747         {
 748           push_cc (CADR (r1), r1, CADDR (r1), cell_vm_return);
 749           goto eval;
 750         }
 751       else if (c == cell_vm_begin_expand)
 752         {
 753           push_cc (cons (CADR (r1), cell_nil), r1, CADDR (r1), cell_vm_return);
 754           goto begin_expand;
 755         }
 756       else if (c == cell_call_with_current_continuation)
 757         {
 758           r1 = CDR (r1);
 759           goto call_with_current_continuation;
 760         }
 761       else
 762         check_apply (cell_f, CAR (r1));
 763     }
 764   else if (t == TSYMBOL)
 765     {
 766       if (CAR (r1) == cell_symbol_call_with_values)
 767         {
 768           r1 = CDR (r1);
 769           goto call_with_values;
 770         }
 771       if (CAR (r1) == cell_symbol_current_module)
 772         {
 773           r1 = r0;
 774           goto vm_return;
 775         }
 776       if (CAR (r1) == cell_symbol_boot_module)
 777         {
 778           r1 = m0;
 779           goto vm_return;
 780         }
 781     }
 782   else if (t == TPAIR)
 783     {
 784       if (CAAR (r1) == cell_symbol_lambda)
 785         {
 786           formals = CADR (CAR (r1));
 787           args = CDR (r1);
 788           body = CDDR (CAR (r1));
 789           p = pairlis (formals, CDR (r1), r0);
 790           check_formals (r1, formals, args);
 791           call_lambda (body, p, p, r0);
 792           goto begin;
 793         }
 794     }
 795   // write_error_ (CAR (r1));
 796   // eputs ("\n");
 797   push_cc (CAR (r1), r1, r0, cell_vm_apply2);
 798   goto eval;
 799 apply2:
 800   check_apply (r1, CAR (r2));
 801   r1 = cons (r1, CDR (r2));
 802   goto apply;
 803
 804 eval:
 805   t = TYPE (r1);
 806   if (t == TPAIR)
 807     {
 808       c = CAR (r1);
 809       if (c == cell_symbol_pmatch_car)
 810         {
 811           push_cc (CADR (r1), r1, r0, cell_vm_eval_pmatch_car);
 812           goto eval;
 813         eval_pmatch_car:
 814           x = r1;
 815           gc_pop_frame ();
 816           r1 = CAR (x);
 817           goto eval_apply;
 818         }
 819       else if (c == cell_symbol_pmatch_cdr)
 820         {
 821           push_cc (CADR (r1), r1, r0, cell_vm_eval_pmatch_cdr);
 822           goto eval;
 823         eval_pmatch_cdr:
 824           x = r1;
 825           gc_pop_frame ();
 826           r1 = CDR (x);
 827           goto eval_apply;
 828         }
 829       else if (c == cell_symbol_quote)
 830         {
 831           x = r1;
 832           gc_pop_frame ();
 833           r1 = CADR (x);
 834           goto eval_apply;
 835         }
 836       else if (c == cell_symbol_begin)
 837         goto begin;
 838       else if (c == cell_symbol_lambda)
 839         {
 840           r1 = make_closure_ (CADR (r1), CDDR (r1), r0);
 841           goto vm_return;
 842         }
 843       else if (c == cell_symbol_if)
 844         {
 845           r1 = CDR (r1);
 846           goto vm_if;
 847         }
 848       else if (c == cell_symbol_set_x)
 849         {
 850           push_cc (CAR (CDDR (r1)), r1, r0, cell_vm_eval_set_x);
 851           goto eval;
 852         eval_set_x:
 853           r1 = set_env_x (CADR (r2), r1, r0);
 854           goto vm_return;
 855         }
 856       else if (c == cell_vm_macro_expand)
 857         {
 858           push_cc (CADR (r1), r1, r0, cell_vm_eval_macro_expand_eval);
 859           goto eval;
 860         eval_macro_expand_eval:
 861           push_cc (r1, r2, r0, cell_vm_eval_macro_expand_expand);
 862           goto macro_expand;
 863         eval_macro_expand_expand:
 864           goto vm_return;
 865         }
 866       else
 867         {
 868           if (TYPE (r1) == TPAIR && (CAR (r1) == cell_symbol_define || CAR (r1) == cell_symbol_define_macro))
 869             {
 870               global_p = CAAR (r0) != cell_closure;
 871               macro_p = CAR (r1) == cell_symbol_define_macro;
 872               if (global_p)
 873                 {
 874                   name = CADR (r1);
 875                   if (TYPE (CADR (r1)) == TPAIR)
 876                     name = CAR (name);
 877                   if (macro_p)
 878                     {
 879                       entry = assq (name, g_macros);
 880                       if (entry == cell_f)
 881                         macro_set_x (name, cell_f);
 882                     }
 883                   else
 884                     {
 885                       entry = module_variable (r0, name);
 886                       if (entry == cell_f)
 887                         module_define_x (m0, name, cell_f);
 888                     }
 889                 }
 890               r2 = r1;
 891               if (TYPE (CADR (r1)) != TPAIR)
 892                 {
 893                   push_cc (CAR (CDDR (r1)), r2, cons (cons (CADR (r1), CADR (r1)), r0), cell_vm_eval_define);
 894                   goto eval;
 895                 }
 896               else
 897                 {
 898                   p = pairlis (CADR (r1), CADR (r1), r0);
 899                   formals = CDR (CADR (r1));
 900                   body = CDDR (r1);
 901
 902                   if (macro_p || global_p)
 903                     expand_variable (body, formals);
 904                   r1 = cons (cell_symbol_lambda, cons (formals, body));
 905                   push_cc (r1, r2, p, cell_vm_eval_define);
 906                   goto eval;
 907                 }
 908             eval_define:;
 909               name = CADR (r2);
 910               if (TYPE (CADR (r2)) == TPAIR)
 911                 name = CAR (name);
 912               if (macro_p)
 913                 {
 914                   entry = macro_get_handle (name);
 915                   r1 = MAKE_MACRO (name, r1);
 916                   set_cdr_x (entry, r1);
 917                 }
 918               else if (global_p)
 919                 {
 920                   entry = module_variable (r0, name);
 921                   set_cdr_x (entry, r1);
 922                 }
 923               else
 924                 {
 925                   entry = cons (name, r1);
 926                   aa = cons (entry, cell_nil);
 927                   set_cdr_x (aa, cdr (r0));
 928                   set_cdr_x (r0, aa);
 929                   cl = module_variable (r0, cell_closure);
 930                   set_cdr_x (cl, aa);
 931                 }
 932               r1 = cell_unspecified;
 933               goto vm_return;
 934             }
 935           push_cc (CAR (r1), r1, r0, cell_vm_eval_check_func);
 936           gc_check ();
 937           goto eval;
 938         eval_check_func:
 939           push_cc (CDR (r2), r2, r0, cell_vm_eval2);
 940           goto evlis;
 941         eval2:
 942           r1 = cons (CAR (r2), r1);
 943           goto apply;
 944         }
 945     }
 946   else if (t == TSYMBOL)
 947     {
 948       if (r1 == cell_symbol_boot_module)
 949         goto vm_return;
 950       if (r1 == cell_symbol_current_module)
 951         goto vm_return;
 952       if (r1 == cell_symbol_begin)      // FIXME
 953         {
 954           r1 = cell_begin;
 955           goto vm_return;
 956         }
 957       r1 = assert_defined (r1, module_ref (r0, r1));
 958       goto vm_return;
 959     }
 960   else if (t == TVARIABLE)
 961     {
 962       r1 = CDR (VARIABLE (r1));
 963       goto vm_return;
 964     }
 965   else if (t == TBROKEN_HEART)
 966     error (cell_symbol_system_error, r1);
 967   else
 968     goto vm_return;
 969
 970 macro_expand:
 971   {
 972     macro;
 973     expanders;
 974
 975     if (TYPE (r1) != TPAIR || CAR (r1) == cell_symbol_quote)
 976       goto vm_return;
 977
 978     if (CAR (r1) == cell_symbol_lambda)
 979       {
 980         push_cc (CDDR (r1), r1, r0, cell_vm_macro_expand_lambda);
 981         goto macro_expand;
 982       macro_expand_lambda:
 983         CDDR (r2) = r1;
 984         r1 = r2;
 985         goto vm_return;
 986       }
 987
 988     if (TYPE (r1) == TPAIR && (macro = get_macro (CAR (r1))) != cell_f)
 989       {
 990         r1 = cons (macro, CDR (r1));
 991         push_cc (r1, cell_nil, r0, cell_vm_macro_expand);
 992         goto apply;
 993       }
 994
 995     if (CAR (r1) == cell_symbol_define || CAR (r1) == cell_symbol_define_macro)
 996       {
 997         push_cc (CDDR (r1), r1, r0, cell_vm_macro_expand_define);
 998         goto macro_expand;
 999       macro_expand_define:
1000         CDDR (r2) = r1;
1001         r1 = r2;
1002         if (CAR (r1) == cell_symbol_define_macro)
1003           {
1004             push_cc (r1, r1, r0, cell_vm_macro_expand_define_macro);
1005             goto eval;
1006           macro_expand_define_macro:
1007             r1 = r2;
1008           }
1009         goto vm_return;
1010       }
1011
1012     if (CAR (r1) == cell_symbol_set_x)
1013       {
1014         push_cc (CDDR (r1), r1, r0, cell_vm_macro_expand_set_x);
1015         goto macro_expand;
1016       macro_expand_set_x:
1017         CDDR (r2) = r1;
1018         r1 = r2;
1019         goto vm_return;
1020       }
1021
1022     if (TYPE (r1) == TPAIR
1023         && TYPE (CAR (r1)) == TSYMBOL
1024         && CAR (r1) != cell_symbol_begin
1025         && ((macro = macro_get_handle (cell_symbol_portable_macro_expand)) != cell_f)
1026         && ((expanders = module_ref (r0, cell_symbol_sc_expander_alist)) != cell_undefined)
1027         && ((macro = assq (CAR (r1), expanders)) != cell_f))
1028       {
1029         sc_expand = module_ref (r0, cell_symbol_macro_expand);
1030         r2 = r1;
1031         if (sc_expand != cell_undefined && sc_expand != cell_f)
1032           {
1033             r1 = cons (sc_expand, cons (r1, cell_nil));
1034             goto apply;
1035           }
1036       }
1037
1038     push_cc (CAR (r1), r1, r0, cell_vm_macro_expand_car);
1039     goto macro_expand;
1040
1041   macro_expand_car:
1042     CAR (r2) = r1;
1043     r1 = r2;
1044     if (CDR (r1) == cell_nil)
1045       goto vm_return;
1046
1047     push_cc (CDR (r1), r1, r0, cell_vm_macro_expand_cdr);
1048     goto macro_expand;
1049
1050   macro_expand_cdr:
1051     CDR (r2) = r1;
1052     r1 = r2;
1053
1054     goto vm_return;
1055   }
1056
1057 begin:
1058   x = cell_unspecified;
1059   while (r1 != cell_nil)
1060     {
1061       gc_check ();
1062       if (TYPE (r1) == TPAIR)
1063         {
1064           if (CAAR (r1) == cell_symbol_primitive_load)
1065             {
1066               program = cons (CAR (r1), cell_nil);
1067               push_cc (program, r1, r0, cell_vm_begin_primitive_load);
1068               goto begin_expand;
1069             begin_primitive_load:
1070               CAR (r2) = r1;
1071               r1 = r2;
1072             }
1073         }
1074
1075       if (TYPE (r1) == TPAIR && TYPE (CAR (r1)) == TPAIR)
1076         {
1077           if (CAAR (r1) == cell_symbol_begin)
1078             r1 = append2 (CDAR (r1), CDR (r1));
1079         }
1080       if (CDR (r1) == cell_nil)
1081         {
1082           r1 = CAR (r1);
1083           goto eval;
1084         }
1085       push_cc (CAR (r1), r1, r0, cell_vm_begin_eval);
1086       goto eval;
1087     begin_eval:
1088       x = r1;
1089       r1 = CDR (r2);
1090     }
1091   r1 = x;
1092   goto vm_return;
1093
1094
1095 begin_expand:
1096   x = cell_unspecified;
1097   while (r1 != cell_nil)
1098     {
1099       gc_check ();
1100
1101       if (TYPE (r1) == TPAIR)
1102         {
1103           if (TYPE (CAR (r1)) == TPAIR && CAAR (r1) == cell_symbol_begin)
1104             r1 = append2 (CDAR (r1), CDR (r1));
1105           if (CAAR (r1) == cell_symbol_primitive_load)
1106             {
1107               push_cc (CADR (CAR (r1)), r1, r0, cell_vm_begin_expand_primitive_load);
1108               goto eval;        // FIXME: expand too?!
1109             begin_expand_primitive_load:
1110               if (TYPE (r1) == TNUMBER && VALUE (r1) == 0)
1111                 ;
1112               else if (TYPE (r1) == TSTRING)
1113                 input = set_current_input_port (open_input_file (r1));
1114               else if (TYPE (r1) == TPORT)
1115                 input = set_current_input_port (r1);
1116               else
1117                 assert (0);
1118
1119               push_cc (input, r2, r0, cell_vm_return);
1120               x = read_input_file_env (r0);
1121               if (g_debug > 5)
1122                 module_printer (m0);
1123               gc_pop_frame ();
1124               input = r1;
1125               r1 = x;
1126               set_current_input_port (input);
1127               r1 = cons (cell_symbol_begin, r1);
1128               CAR (r2) = r1;
1129               r1 = r2;
1130               continue;
1131             }
1132         }
1133
1134       push_cc (CAR (r1), r1, r0, cell_vm_begin_expand_macro);
1135       goto macro_expand;
1136     begin_expand_macro:
1137       if (r1 != CAR (r2))
1138         {
1139           CAR (r2) = r1;
1140           r1 = r2;
1141           continue;
1142         }
1143       r1 = r2;
1144       expand_variable (CAR (r1), cell_nil);
1145       push_cc (CAR (r1), r1, r0, cell_vm_begin_expand_eval);
1146       goto eval;
1147     begin_expand_eval:
1148       x = r1;
1149       r1 = CDR (r2);
1150     }
1151   r1 = x;
1152   goto vm_return;
1153
1154 vm_if:
1155   push_cc (CAR (r1), r1, r0, cell_vm_if_expr);
1156   goto eval;
1157 if_expr:
1158   x = r1;
1159   r1 = r2;
1160   if (x != cell_f)
1161     {
1162       r1 = CADR (r1);
1163       goto eval;
1164     }
1165   if (CDDR (r1) != cell_nil)
1166     {
1167       r1 = CAR (CDDR (r1));
1168       goto eval;
1169     }
1170   r1 = cell_unspecified;
1171   goto vm_return;
1172
1173 call_with_current_continuation:
1174   gc_push_frame ();
1175   x = MAKE_CONTINUATION (g_continuations++);
1176   v = make_vector__ (STACK_SIZE - g_stack);
1177   for (t = g_stack; t < STACK_SIZE; t++)
1178     vector_set_x_ (v, t - g_stack, g_stack_array[t]);
1179   CONTINUATION (x) = v;
1180   gc_pop_frame ();
1181   push_cc (cons (CAR (r1), cons (x, cell_nil)), x, r0, cell_vm_call_with_current_continuation2);
1182   goto apply;
1183 call_with_current_continuation2:
1184   v = make_vector__ (STACK_SIZE - g_stack);
1185   for (t = g_stack; t < STACK_SIZE; t++)
1186     vector_set_x_ (v, t - g_stack, g_stack_array[t]);
1187   CONTINUATION (r2) = v;
1188   goto vm_return;
1189
1190 call_with_values:
1191   push_cc (cons (CAR (r1), cell_nil), r1, r0, cell_vm_call_with_values2);
1192   goto apply;
1193 call_with_values2:
1194   if (TYPE (r1) == TVALUES)
1195     r1 = CDR (r1);
1196   r1 = cons (CADR (r2), r1);
1197   goto apply;
1198
1199 vm_return:
1200   x = r1;
1201   gc_pop_frame ();
1202   r1 = x;
1203   goto eval_apply;
1204 }
1205
1206 SCM
1207 apply (SCM f, SCM x, SCM a)     ///((internal))
1208 {
1209   push_cc (cons (f, x), cell_unspecified, r0, cell_unspecified);
1210   r3 = cell_vm_apply;
1211   return eval_apply ();
1212 }
1213
1214 SCM
1215 mes_g_stack (SCM a)             ///((internal))
1216 {
1217   //g_stack = g_free + ARENA_SIZE;
1218   g_stack = STACK_SIZE;
1219   r0 = a;
1220   r1 = MAKE_CHAR (0);
1221   r2 = MAKE_CHAR (0);
1222   r3 = MAKE_CHAR (0);
1223   return r0;
1224 }
1225
1226 void
1227 init_symbol (long x, long type, char const *name)
1228 {
1229   TYPE (x) = type;
1230   int length = strlen (name);
1231   SCM string = make_string (name, length);
1232   CAR (x) = length;
1233   CDR (x) = STRING (string);
1234   hash_set_x (g_symbols, string, x);
1235 }
1236
1237 SCM
1238 mes_symbols ()                  ///((internal))
1239 {
1240   g_free = cell_symbol_test + 1;
1241   g_symbol_max = g_free;
1242   g_symbols = make_hash_table_ (500);
1243
1244   init_symbol (cell_nil, TSPECIAL, "()");
1245   init_symbol (cell_f, TSPECIAL, "#f");
1246   init_symbol (cell_t, TSPECIAL, "#t");
1247   init_symbol (cell_dot, TSPECIAL, ".");
1248   init_symbol (cell_arrow, TSPECIAL, "=>");
1249   init_symbol (cell_undefined, TSPECIAL, "*undefined*");
1250   init_symbol (cell_unspecified, TSPECIAL, "*unspecified*");
1251   init_symbol (cell_closure, TSPECIAL, "*closure*");
1252   init_symbol (cell_circular, TSPECIAL, "*circular*");
1253   init_symbol (cell_begin, TSPECIAL, "*begin*");
1254   init_symbol (cell_call_with_current_continuation, TSPECIAL, "*call/cc*");
1255
1256   init_symbol (cell_vm_apply, TSPECIAL, "core:apply");
1257   init_symbol (cell_vm_apply2, TSPECIAL, "*vm-apply2*");
1258   init_symbol (cell_vm_begin, TSPECIAL, "*vm-begin*");
1259   init_symbol (cell_vm_begin_eval, TSPECIAL, "*vm:begin-eval*");
1260   init_symbol (cell_vm_begin_expand, TSPECIAL, "core:eval");
1261   init_symbol (cell_vm_begin_expand_eval, TSPECIAL, "*vm:begin-expand-eval*");
1262   init_symbol (cell_vm_begin_expand_macro, TSPECIAL, "*vm:begin-expand-macro*");
1263   init_symbol (cell_vm_begin_expand_primitive_load, TSPECIAL, "*vm:core:begin-expand-primitive-load*");
1264   init_symbol (cell_vm_begin_primitive_load, TSPECIAL, "*vm:core:begin-primitive-load*");
1265   init_symbol (cell_vm_begin_read_input_file, TSPECIAL, "*vm-begin-read-input-file*");
1266   init_symbol (cell_vm_call_with_current_continuation2, TSPECIAL, "*vm-call-with-current-continuation2*");
1267   init_symbol (cell_vm_call_with_values2, TSPECIAL, "*vm-call-with-values2*");
1268   init_symbol (cell_vm_eval, TSPECIAL, "core:eval-expanded");
1269   init_symbol (cell_vm_eval2, TSPECIAL, "*vm-eval2*");
1270   init_symbol (cell_vm_eval_check_func, TSPECIAL, "*vm-eval-check-func*");
1271   init_symbol (cell_vm_eval_define, TSPECIAL, "*vm-eval-define*");
1272   init_symbol (cell_vm_eval_macro_expand_eval, TSPECIAL, "*vm:eval-macro-expand-eval*");
1273   init_symbol (cell_vm_eval_macro_expand_expand, TSPECIAL, "*vm:eval-macro-expand-expand*");
1274   init_symbol (cell_vm_eval_pmatch_car, TSPECIAL, "*vm-eval-pmatch-car*");
1275   init_symbol (cell_vm_eval_pmatch_cdr, TSPECIAL, "*vm-eval-pmatch-cdr*");
1276   init_symbol (cell_vm_eval_set_x, TSPECIAL, "*vm-eval-set!*");
1277   init_symbol (cell_vm_evlis, TSPECIAL, "*vm-evlis*");
1278   init_symbol (cell_vm_evlis2, TSPECIAL, "*vm-evlis2*");
1279   init_symbol (cell_vm_evlis3, TSPECIAL, "*vm-evlis3*");
1280   init_symbol (cell_vm_if, TSPECIAL, "*vm-if*");
1281   init_symbol (cell_vm_if_expr, TSPECIAL, "*vm-if-expr*");
1282   init_symbol (cell_vm_macro_expand, TSPECIAL, "core:macro-expand");
1283   init_symbol (cell_vm_macro_expand_car, TSPECIAL, "*vm:core:macro-expand-car*");
1284   init_symbol (cell_vm_macro_expand_cdr, TSPECIAL, "*vm:macro-expand-cdr*");
1285   init_symbol (cell_vm_macro_expand_define, TSPECIAL, "*vm:core:macro-expand-define*");
1286   init_symbol (cell_vm_macro_expand_define_macro, TSPECIAL, "*vm:core:macro-expand-define-macro*");
1287   init_symbol (cell_vm_macro_expand_lambda, TSPECIAL, "*vm:core:macro-expand-lambda*");
1288   init_symbol (cell_vm_macro_expand_set_x, TSPECIAL, "*vm:core:macro-expand-set!*");
1289   init_symbol (cell_vm_return, TSPECIAL, "*vm-return*");
1290
1291   init_symbol (cell_symbol_dot, TSYMBOL, "*dot*");
1292   init_symbol (cell_symbol_lambda, TSYMBOL, "lambda");
1293   init_symbol (cell_symbol_begin, TSYMBOL, "begin");
1294   init_symbol (cell_symbol_if, TSYMBOL, "if");
1295   init_symbol (cell_symbol_quote, TSYMBOL, "quote");
1296   init_symbol (cell_symbol_define, TSYMBOL, "define");
1297   init_symbol (cell_symbol_define_macro, TSYMBOL, "define-macro");
1298
1299   init_symbol (cell_symbol_quasiquote, TSYMBOL, "quasiquote");
1300   init_symbol (cell_symbol_unquote, TSYMBOL, "unquote");
1301   init_symbol (cell_symbol_unquote_splicing, TSYMBOL, "unquote-splicing");
1302   init_symbol (cell_symbol_syntax, TSYMBOL, "syntax");
1303   init_symbol (cell_symbol_quasisyntax, TSYMBOL, "quasisyntax");
1304   init_symbol (cell_symbol_unsyntax, TSYMBOL, "unsyntax");
1305   init_symbol (cell_symbol_unsyntax_splicing, TSYMBOL, "unsyntax-splicing");
1306
1307   init_symbol (cell_symbol_set_x, TSYMBOL, "set!");
1308
1309   init_symbol (cell_symbol_sc_expand, TSYMBOL, "sc-expand");
1310   init_symbol (cell_symbol_macro_expand, TSYMBOL, "macro-expand");
1311   init_symbol (cell_symbol_portable_macro_expand, TSYMBOL, "portable-macro-expand");
1312   init_symbol (cell_symbol_sc_expander_alist, TSYMBOL, "*sc-expander-alist*");
1313
1314   init_symbol (cell_symbol_call_with_values, TSYMBOL, "call-with-values");
1315   init_symbol (cell_symbol_call_with_current_continuation, TSYMBOL, "call-with-current-continuation");
1316   init_symbol (cell_symbol_boot_module, TSYMBOL, "boot-module");
1317   init_symbol (cell_symbol_current_module, TSYMBOL, "current-module");
1318   init_symbol (cell_symbol_primitive_load, TSYMBOL, "primitive-load");
1319   init_symbol (cell_symbol_read_input_file, TSYMBOL, "read-input-file");
1320   init_symbol (cell_symbol_write, TSYMBOL, "write");
1321   init_symbol (cell_symbol_display, TSYMBOL, "display");
1322
1323   init_symbol (cell_symbol_car, TSYMBOL, "car");
1324   init_symbol (cell_symbol_cdr, TSYMBOL, "cdr");
1325   init_symbol (cell_symbol_not_a_number, TSYMBOL, "not-a-number");
1326   init_symbol (cell_symbol_not_a_pair, TSYMBOL, "not-a-pair");
1327   init_symbol (cell_symbol_system_error, TSYMBOL, "system-error");
1328   init_symbol (cell_symbol_throw, TSYMBOL, "throw");
1329   init_symbol (cell_symbol_unbound_variable, TSYMBOL, "unbound-variable");
1330   init_symbol (cell_symbol_wrong_number_of_args, TSYMBOL, "wrong-number-of-args");
1331   init_symbol (cell_symbol_wrong_type_arg, TSYMBOL, "wrong-type-arg");
1332
1333   init_symbol (cell_symbol_buckets, TSYMBOL, "buckets");
1334   init_symbol (cell_symbol_builtin, TSYMBOL, "<builtin>");
1335   init_symbol (cell_symbol_frame, TSYMBOL, "<frame>");
1336   init_symbol (cell_symbol_hashq_table, TSYMBOL, "<hashq-table>");
1337   init_symbol (cell_symbol_module, TSYMBOL, "<module>");
1338   init_symbol (cell_symbol_procedure, TSYMBOL, "procedure");
1339   init_symbol (cell_symbol_record_type, TSYMBOL, "<record-type>");
1340   init_symbol (cell_symbol_size, TSYMBOL, "size");
1341   init_symbol (cell_symbol_stack, TSYMBOL, "<stack>");
1342
1343   init_symbol (cell_symbol_argv, TSYMBOL, "%argv");
1344   init_symbol (cell_symbol_mes_datadir, TSYMBOL, "%datadir");
1345   init_symbol (cell_symbol_mes_version, TSYMBOL, "%version");
1346
1347   init_symbol (cell_symbol_internal_time_units_per_second, TSYMBOL, "internal-time-units-per-second");
1348   init_symbol (cell_symbol_compiler, TSYMBOL, "%compiler");
1349   init_symbol (cell_symbol_arch, TSYMBOL, "%arch");
1350
1351   init_symbol (cell_symbol_pmatch_car, TSYMBOL, "pmatch-car");
1352   init_symbol (cell_symbol_pmatch_cdr, TSYMBOL, "pmatch-cdr");
1353
1354   init_symbol (cell_type_bytes, TSYMBOL, "<cell:bytes>");
1355   init_symbol (cell_type_char, TSYMBOL, "<cell:char>");
1356   init_symbol (cell_type_closure, TSYMBOL, "<cell:closure>");
1357   init_symbol (cell_type_continuation, TSYMBOL, "<cell:continuation>");
1358   init_symbol (cell_type_function, TSYMBOL, "<cell:function>");
1359   init_symbol (cell_type_keyword, TSYMBOL, "<cell:keyword>");
1360   init_symbol (cell_type_macro, TSYMBOL, "<cell:macro>");
1361   init_symbol (cell_type_number, TSYMBOL, "<cell:number>");
1362   init_symbol (cell_type_pair, TSYMBOL, "<cell:pair>");
1363   init_symbol (cell_type_port, TSYMBOL, "<cell:port>");
1364   init_symbol (cell_type_ref, TSYMBOL, "<cell:ref>");
1365   init_symbol (cell_type_special, TSYMBOL, "<cell:special>");
1366   init_symbol (cell_type_string, TSYMBOL, "<cell:string>");
1367   init_symbol (cell_type_struct, TSYMBOL, "<cell:struct>");
1368   init_symbol (cell_type_symbol, TSYMBOL, "<cell:symbol>");
1369   init_symbol (cell_type_values, TSYMBOL, "<cell:values>");
1370   init_symbol (cell_type_variable, TSYMBOL, "<cell:variable>");
1371   init_symbol (cell_type_vector, TSYMBOL, "<cell:vector>");
1372   init_symbol (cell_type_broken_heart, TSYMBOL, "<cell:broken-heart>");
1373
1374   init_symbol (cell_symbol_test, TSYMBOL, "%%test");
1375
1376   SCM a = cell_nil;
1377   a = acons (cell_symbol_call_with_values, cell_symbol_call_with_values, a);
1378   a = acons (cell_symbol_boot_module, cell_symbol_boot_module, a);
1379   a = acons (cell_symbol_current_module, cell_symbol_current_module, a);
1380   a = acons (cell_symbol_call_with_current_continuation, cell_call_with_current_continuation, a);
1381
1382   a = acons (cell_symbol_mes_version, MAKE_STRING0 (MES_VERSION), a);
1383   a = acons (cell_symbol_mes_datadir, MAKE_STRING0 (g_datadir), a);
1384
1385   a = acons (cell_type_bytes, MAKE_NUMBER (TBYTES), a);
1386   a = acons (cell_type_char, MAKE_NUMBER (TCHAR), a);
1387   a = acons (cell_type_closure, MAKE_NUMBER (TCLOSURE), a);
1388   a = acons (cell_type_continuation, MAKE_NUMBER (TCONTINUATION), a);
1389   a = acons (cell_type_keyword, MAKE_NUMBER (TKEYWORD), a);
1390   a = acons (cell_type_macro, MAKE_NUMBER (TMACRO), a);
1391   a = acons (cell_type_number, MAKE_NUMBER (TNUMBER), a);
1392   a = acons (cell_type_pair, MAKE_NUMBER (TPAIR), a);
1393   a = acons (cell_type_port, MAKE_NUMBER (TPORT), a);
1394   a = acons (cell_type_ref, MAKE_NUMBER (TREF), a);
1395   a = acons (cell_type_special, MAKE_NUMBER (TSPECIAL), a);
1396   a = acons (cell_type_string, MAKE_NUMBER (TSTRING), a);
1397   a = acons (cell_type_struct, MAKE_NUMBER (TSTRUCT), a);
1398   a = acons (cell_type_symbol, MAKE_NUMBER (TSYMBOL), a);
1399   a = acons (cell_type_values, MAKE_NUMBER (TVALUES), a);
1400   a = acons (cell_type_variable, MAKE_NUMBER (TVARIABLE), a);
1401   a = acons (cell_type_vector, MAKE_NUMBER (TVECTOR), a);
1402   a = acons (cell_type_broken_heart, MAKE_NUMBER (TBROKEN_HEART), a);
1403
1404   a = acons (cell_closure, a, a);
1405
1406   return a;
1407 }
1408
1409 SCM
1410 mes_environment (int argc, char *argv[])
1411 {
1412   SCM a = mes_symbols ();
1413
1414   char *compiler = "gnuc";
1415 #if __MESC__
1416   compiler = "mesc";
1417 #elif __TINYC__
1418   compiler = "tcc";
1419 #endif
1420   a = acons (cell_symbol_compiler, MAKE_STRING0 (compiler), a);
1421
1422   char *arch;
1423 #if __i386__
1424   arch = "x86";
1425 #elif __arm__
1426   arch = "arm";
1427 #elif __x86_64__
1428   arch = "x86_64";
1429 #else
1430 #error arch not supported
1431 #endif
1432   a = acons (cell_symbol_arch, MAKE_STRING0 (arch), a);
1433
1434 #if !MES_MINI
1435   SCM lst = cell_nil;
1436   for (int i = argc - 1; i >= 0; i--)
1437     lst = cons (MAKE_STRING0 (argv[i]), lst);
1438   a = acons (cell_symbol_argv, lst, a);
1439 #endif
1440
1441   return mes_g_stack (a);
1442 }
1443
1444 SCM
1445 init_builtin (SCM builtin_type, char const *name, int arity, SCM (*function) (SCM), SCM a)
1446 {
1447   SCM s = cstring_to_symbol (name);
1448   return acons (s,
1449                 make_builtin (builtin_type, symbol_to_string (s), MAKE_NUMBER (arity),
1450                               MAKE_NUMBER (function)), a);
1451 }
1452
1453 SCM
1454 make_builtin_type ()            ///(internal))
1455 {
1456   SCM record_type = cell_symbol_record_type;
1457   SCM fields = cell_nil;
1458   fields = cons (cstring_to_symbol ("address"), fields);
1459   fields = cons (cstring_to_symbol ("arity"), fields);
1460   fields = cons (cstring_to_symbol ("name"), fields);
1461   fields = cons (fields, cell_nil);
1462   fields = cons (cell_symbol_builtin, fields);
1463   return make_struct (record_type, fields, cell_unspecified);
1464 }
1465
1466 SCM
1467 make_builtin (SCM builtin_type, SCM name, SCM arity, SCM function)
1468 {
1469   SCM values = cell_nil;
1470   values = cons (function, values);
1471   values = cons (arity, values);
1472   values = cons (name, values);
1473   values = cons (cell_symbol_builtin, values);
1474   return make_struct (builtin_type, values, cstring_to_symbol ("builtin-printer"));
1475 }
1476
1477 SCM
1478 builtin_name (SCM builtin)
1479 {
1480   return struct_ref_ (builtin, 3);
1481 }
1482
1483 SCM
1484 builtin_arity (SCM builtin)
1485 {
1486   return struct_ref_ (builtin, 4);
1487 }
1488
1489 #if __MESC__
1490 long
1491 builtin_function (SCM builtin)
1492 {
1493   return VALUE (struct_ref_ (builtin, 5));
1494 }
1495 #else
1496 SCM (*builtin_function (SCM builtin)) (SCM)
1497 {
1498   return (function1_t) VALUE (struct_ref_ (builtin, 5));
1499 }
1500 #endif
1501
1502 SCM
1503 builtin_p (SCM x)
1504 {
1505   return (TYPE (x) == TSTRUCT && struct_ref_ (x, 2) == cell_symbol_builtin) ? cell_t : cell_f;
1506 }
1507
1508 SCM
1509 builtin_printer (SCM builtin)
1510 {
1511   fdputs ("#<procedure ", __stdout);
1512   display_ (builtin_name (builtin));
1513   fdputc (' ', __stdout);
1514   int arity = VALUE (builtin_arity (builtin));
1515   if (arity == -1)
1516     fdputc ('_', __stdout);
1517   else
1518     {
1519       fdputc ('(', __stdout);
1520       for (int i = 0; i < arity; i++)
1521         {
1522           if (i)
1523             fdputc (' ', __stdout);
1524           fdputc ('_', __stdout);
1525         }
1526     }
1527   fdputc ('>', __stdout);
1528 }
1529
1530 SCM
1531 apply_builtin (SCM fn, SCM x)   ///((internal))
1532 {
1533   int arity = VALUE (builtin_arity (fn));
1534   if ((arity > 0 || arity == -1) && x != cell_nil && TYPE (CAR (x)) == TVALUES)
1535     x = cons (CADAR (x), CDR (x));
1536   if ((arity > 1 || arity == -1) && x != cell_nil && TYPE (CDR (x)) == TPAIR && TYPE (CADR (x)) == TVALUES)
1537     x = cons (CAR (x), cons (CDADAR (x), CDR (x)));
1538
1539 #if __M2_PLANET__
1540   FUNCTION fp = builtin_function (fn) if (arity == 0)
1541     return fp ();
1542   else if (arity == 1)
1543     return fp (CAR (x));
1544   else if (arity == 2)
1545     return fp (CAR (x), CADR (x));
1546   else if (arity == 3)
1547     return fp (CAR (x), CADR (x), CAR (CDDR (x)));
1548   else if (arity == -1)
1549     return fp (x);
1550 #else // !__M2_PLANET__
1551   if (arity == 0)
1552     {
1553       //function0_t fp = f->function;
1554       SCM (*fp) (void) = (function0_t) builtin_function (fn);
1555       return fp ();
1556     }
1557   else if (arity == 1)
1558     {
1559       //function1_t fp = f->function;
1560       SCM (*fp) (SCM) = (function1_t) builtin_function (fn);
1561       return fp (CAR (x));
1562     }
1563   else if (arity == 2)
1564     {
1565       //function2_t fp = f->function;
1566       SCM (*fp) (SCM, SCM) = (function2_t) builtin_function (fn);
1567       return fp (CAR (x), CADR (x));
1568     }
1569   else if (arity == 3)
1570     {
1571       //function3_t fp = f->function;
1572       SCM (*fp) (SCM, SCM, SCM) = (function3_t) builtin_function (fn);
1573       return fp (CAR (x), CADR (x), CAR (CDDR (x)));
1574     }
1575   else if (arity == -1)
1576     {
1577       //functionn_t fp = f->function;
1578       SCM (*fp) (SCM) = (function1_t) builtin_function (fn);
1579       return fp (x);
1580     }
1581 #endif //! __M2_PLANET__
1582   return cell_unspecified;
1583 }
1584
1585 SCM
1586 mes_builtins (SCM a)            ///((internal))
1587 {
1588   // TODO minimal: cons, car, cdr, list, null_p, eq_p minus, plus
1589   // display_, display_error_, getenv
1590
1591   SCM builtin_type = make_builtin_type ();
1592
1593   // src/gc.mes
1594   a = init_builtin (builtin_type, "gc-check", 0, (function1_t) & gc_check, a);
1595   a = init_builtin (builtin_type, "gc", 0, (function1_t) & gc, a);
1596   // src/hash.mes
1597   a = init_builtin (builtin_type, "hashq", 2, (function1_t) & hashq, a);
1598   a = init_builtin (builtin_type, "hash", 2, (function1_t) & hash, a);
1599   a = init_builtin (builtin_type, "hashq-get-handle", 3, (function1_t) & hashq_get_handle, a);
1600   a = init_builtin (builtin_type, "hashq-ref", 3, (function1_t) & hashq_ref, a);
1601   a = init_builtin (builtin_type, "hash-ref", 3, (function1_t) & hash_ref, a);
1602   a = init_builtin (builtin_type, "hashq-set!", 3, (function1_t) & hashq_set_x, a);
1603   a = init_builtin (builtin_type, "hash-set!", 3, (function1_t) & hash_set_x, a);
1604   a = init_builtin (builtin_type, "hash-table-printer", 1, (function1_t) & hash_table_printer, a);
1605   a = init_builtin (builtin_type, "make-hash-table", 1, (function1_t) & make_hash_table, a);
1606   // src/lib.mes
1607   a = init_builtin (builtin_type, "core:display", 1, (function1_t) & display_, a);
1608   a = init_builtin (builtin_type, "core:display-error", 1, (function1_t) & display_error_, a);
1609   a = init_builtin (builtin_type, "core:display-port", 2, (function1_t) & display_port_, a);
1610   a = init_builtin (builtin_type, "core:write", 1, (function1_t) & write_, a);
1611   a = init_builtin (builtin_type, "core:write-error", 1, (function1_t) & write_error_, a);
1612   a = init_builtin (builtin_type, "core:write-port", 2, (function1_t) & write_port_, a);
1613   a = init_builtin (builtin_type, "exit", 1, (function1_t) & exit_, a);
1614   a = init_builtin (builtin_type, "frame-printer", 1, (function1_t) & frame_printer, a);
1615   a = init_builtin (builtin_type, "make-stack", -1, (function1_t) & make_stack, a);
1616   a = init_builtin (builtin_type, "stack-length", 1, (function1_t) & stack_length, a);
1617   a = init_builtin (builtin_type, "stack-ref", 2, (function1_t) & stack_ref, a);
1618   a = init_builtin (builtin_type, "xassq", 2, (function1_t) & xassq, a);
1619   a = init_builtin (builtin_type, "memq", 2, (function1_t) & memq, a);
1620   a = init_builtin (builtin_type, "equal2?", 2, (function1_t) & equal2_p, a);
1621   a = init_builtin (builtin_type, "last-pair", 1, (function1_t) & last_pair, a);
1622   a = init_builtin (builtin_type, "pair?", 1, (function1_t) & pair_p, a);
1623   // src/math.mes
1624   a = init_builtin (builtin_type, ">", -1, (function1_t) & greater_p, a);
1625   a = init_builtin (builtin_type, "<", -1, (function1_t) & less_p, a);
1626   a = init_builtin (builtin_type, "=", -1, (function1_t) & is_p, a);
1627   a = init_builtin (builtin_type, "-", -1, (function1_t) & minus, a);
1628   a = init_builtin (builtin_type, "+", -1, (function1_t) & plus, a);
1629   a = init_builtin (builtin_type, "/", -1, (function1_t) & divide, a);
1630   a = init_builtin (builtin_type, "modulo", 2, (function1_t) & modulo, a);
1631   a = init_builtin (builtin_type, "*", -1, (function1_t) & multiply, a);
1632   a = init_builtin (builtin_type, "logand", -1, (function1_t) & logand, a);
1633   a = init_builtin (builtin_type, "logior", -1, (function1_t) & logior, a);
1634   a = init_builtin (builtin_type, "lognot", 1, (function1_t) & lognot, a);
1635   a = init_builtin (builtin_type, "logxor", -1, (function1_t) & logxor, a);
1636   a = init_builtin (builtin_type, "ash", 2, (function1_t) & ash, a);
1637   // src/mes.mes
1638   a = init_builtin (builtin_type, "core:make-cell", 3, (function1_t) & make_cell_, a);
1639   a = init_builtin (builtin_type, "core:type", 1, (function1_t) & type_, a);
1640   a = init_builtin (builtin_type, "core:car", 1, (function1_t) & car_, a);
1641   a = init_builtin (builtin_type, "core:cdr", 1, (function1_t) & cdr_, a);
1642   a = init_builtin (builtin_type, "cons", 2, (function1_t) & cons, a);
1643   a = init_builtin (builtin_type, "car", 1, (function1_t) & car, a);
1644   a = init_builtin (builtin_type, "cdr", 1, (function1_t) & cdr, a);
1645   a = init_builtin (builtin_type, "list", -1, (function1_t) & list, a);
1646   a = init_builtin (builtin_type, "null?", 1, (function1_t) & null_p, a);
1647   a = init_builtin (builtin_type, "eq?", 2, (function1_t) & eq_p, a);
1648   a = init_builtin (builtin_type, "values", -1, (function1_t) & values, a);
1649   a = init_builtin (builtin_type, "acons", 3, (function1_t) & acons, a);
1650   a = init_builtin (builtin_type, "length", 1, (function1_t) & length, a);
1651   a = init_builtin (builtin_type, "error", 2, (function1_t) & error, a);
1652   a = init_builtin (builtin_type, "append2", 2, (function1_t) & append2, a);
1653   a = init_builtin (builtin_type, "append-reverse", 2, (function1_t) & append_reverse, a);
1654   a = init_builtin (builtin_type, "core:reverse!", 2, (function1_t) & reverse_x_, a);
1655   a = init_builtin (builtin_type, "pairlis", 3, (function1_t) & pairlis, a);
1656   a = init_builtin (builtin_type, "assq", 2, (function1_t) & assq, a);
1657   a = init_builtin (builtin_type, "assoc", 2, (function1_t) & assoc, a);
1658   a = init_builtin (builtin_type, "set-car!", 2, (function1_t) & set_car_x, a);
1659   a = init_builtin (builtin_type, "set-cdr!", 2, (function1_t) & set_cdr_x, a);
1660   a = init_builtin (builtin_type, "set-env!", 3, (function1_t) & set_env_x, a);
1661   a = init_builtin (builtin_type, "macro-get-handle", 1, (function1_t) & macro_get_handle, a);
1662   a = init_builtin (builtin_type, "add-formals", 2, (function1_t) & add_formals, a);
1663   a = init_builtin (builtin_type, "eval-apply", 0, (function1_t) & eval_apply, a);
1664   a = init_builtin (builtin_type, "make-builtin-type", 0, (function1_t) & make_builtin_type, a);
1665   a = init_builtin (builtin_type, "make-builtin", 4, (function1_t) & make_builtin, a);
1666   a = init_builtin (builtin_type, "builtin-name", 1, (function1_t) & builtin_name, a);
1667   a = init_builtin (builtin_type, "builtin-arity", 1, (function1_t) & builtin_arity, a);
1668   a = init_builtin (builtin_type, "builtin?", 1, (function1_t) & builtin_p, a);
1669   a = init_builtin (builtin_type, "builtin-printer", 1, (function1_t) & builtin_printer, a);
1670   // src/module.mes
1671   a = init_builtin (builtin_type, "make-module-type", 0, (function1_t) & make_module_type, a);
1672   a = init_builtin (builtin_type, "module-printer", 1, (function1_t) & module_printer, a);
1673   a = init_builtin (builtin_type, "module-variable", 2, (function1_t) & module_variable, a);
1674   a = init_builtin (builtin_type, "module-ref", 2, (function1_t) & module_ref, a);
1675   a = init_builtin (builtin_type, "module-define!", 3, (function1_t) & module_define_x, a);
1676   // src/posix.mes
1677   a = init_builtin (builtin_type, "peek-byte", 0, (function1_t) & peek_byte, a);
1678   a = init_builtin (builtin_type, "read-byte", 0, (function1_t) & read_byte, a);
1679   a = init_builtin (builtin_type, "unread-byte", 1, (function1_t) & unread_byte, a);
1680   a = init_builtin (builtin_type, "peek-char", 0, (function1_t) & peek_char, a);
1681   a = init_builtin (builtin_type, "read-char", -1, (function1_t) & read_char, a);
1682   a = init_builtin (builtin_type, "unread-char", 1, (function1_t) & unread_char, a);
1683   a = init_builtin (builtin_type, "write-char", -1, (function1_t) & write_char, a);
1684   a = init_builtin (builtin_type, "write-byte", -1, (function1_t) & write_byte, a);
1685   a = init_builtin (builtin_type, "getenv", 1, (function1_t) & getenv_, a);
1686   a = init_builtin (builtin_type, "setenv", 2, (function1_t) & setenv_, a);
1687   a = init_builtin (builtin_type, "access?", 2, (function1_t) & access_p, a);
1688   a = init_builtin (builtin_type, "current-input-port", 0, (function1_t) & current_input_port, a);
1689   a = init_builtin (builtin_type, "open-input-file", 1, (function1_t) & open_input_file, a);
1690   a = init_builtin (builtin_type, "open-input-string", 1, (function1_t) & open_input_string, a);
1691   a = init_builtin (builtin_type, "set-current-input-port", 1, (function1_t) & set_current_input_port, a);
1692   a = init_builtin (builtin_type, "current-output-port", 0, (function1_t) & current_output_port, a);
1693   a = init_builtin (builtin_type, "current-error-port", 0, (function1_t) & current_error_port, a);
1694   a = init_builtin (builtin_type, "open-output-file", -1, (function1_t) & open_output_file, a);
1695   a = init_builtin (builtin_type, "set-current-output-port", 1, (function1_t) & set_current_output_port, a);
1696   a = init_builtin (builtin_type, "set-current-error-port", 1, (function1_t) & set_current_error_port, a);
1697   a = init_builtin (builtin_type, "chmod", 2, (function1_t) & chmod_, a);
1698   a = init_builtin (builtin_type, "isatty?", 1, (function1_t) & isatty_p, a);
1699   a = init_builtin (builtin_type, "primitive-fork", 0, (function1_t) & primitive_fork, a);
1700   a = init_builtin (builtin_type, "execl", 2, (function1_t) & execl_, a);
1701   a = init_builtin (builtin_type, "core:waitpid", 2, (function1_t) & waitpid_, a);
1702   a = init_builtin (builtin_type, "current-time", 0, (function1_t) & current_time, a);
1703   a = init_builtin (builtin_type, "gettimeofday", 0, (function1_t) & gettimeofday_, a);
1704   a = init_builtin (builtin_type, "get-internal-run-time", 0, (function1_t) & get_internal_run_time, a);
1705   a = init_builtin (builtin_type, "getcwd", 0, (function1_t) & getcwd_, a);
1706   a = init_builtin (builtin_type, "dup", 1, (function1_t) & dup_, a);
1707   a = init_builtin (builtin_type, "dup2", 2, (function1_t) & dup2_, a);
1708   a = init_builtin (builtin_type, "delete-file", 1, (function1_t) & delete_file, a);
1709   // src/reader.mes
1710   a = init_builtin (builtin_type, "core:read-input-file-env", 2, (function1_t) & read_input_file_env_, a);
1711   a = init_builtin (builtin_type, "read-input-file-env", 1, (function1_t) & read_input_file_env, a);
1712   a = init_builtin (builtin_type, "read-env", 1, (function1_t) & read_env, a);
1713   a = init_builtin (builtin_type, "reader-read-sexp", 3, (function1_t) & reader_read_sexp, a);
1714   a = init_builtin (builtin_type, "reader-read-character", 0, (function1_t) & reader_read_character, a);
1715   a = init_builtin (builtin_type, "reader-read-binary", 0, (function1_t) & reader_read_binary, a);
1716   a = init_builtin (builtin_type, "reader-read-octal", 0, (function1_t) & reader_read_octal, a);
1717   a = init_builtin (builtin_type, "reader-read-hex", 0, (function1_t) & reader_read_hex, a);
1718   a = init_builtin (builtin_type, "reader-read-string", 0, (function1_t) & reader_read_string, a);
1719   // src/strings.mes
1720   a = init_builtin (builtin_type, "string=?", 2, (function1_t) & string_equal_p, a);
1721   a = init_builtin (builtin_type, "symbol->string", 1, (function1_t) & symbol_to_string, a);
1722   a = init_builtin (builtin_type, "symbol->keyword", 1, (function1_t) & symbol_to_keyword, a);
1723   a = init_builtin (builtin_type, "keyword->string", 1, (function1_t) & keyword_to_string, a);
1724   a = init_builtin (builtin_type, "string->symbol", 1, (function1_t) & string_to_symbol, a);
1725   a = init_builtin (builtin_type, "make-symbol", 1, (function1_t) & make_symbol, a);
1726   a = init_builtin (builtin_type, "string->list", 1, (function1_t) & string_to_list, a);
1727   a = init_builtin (builtin_type, "list->string", 1, (function1_t) & list_to_string, a);
1728   a = init_builtin (builtin_type, "read-string", -1, (function1_t) & read_string, a);
1729   a = init_builtin (builtin_type, "string-append", -1, (function1_t) & string_append, a);
1730   a = init_builtin (builtin_type, "string-length", 1, (function1_t) & string_length, a);
1731   a = init_builtin (builtin_type, "string-ref", 2, (function1_t) & string_ref, a);
1732   // src/struct.mes
1733   a = init_builtin (builtin_type, "make-struct", 3, (function1_t) & make_struct, a);
1734   a = init_builtin (builtin_type, "struct-length", 1, (function1_t) & struct_length, a);
1735   a = init_builtin (builtin_type, "struct-ref", 2, (function1_t) & struct_ref, a);
1736   a = init_builtin (builtin_type, "struct-set!", 3, (function1_t) & struct_set_x, a);
1737   // src/vector.mes
1738   a = init_builtin (builtin_type, "core:make-vector", 1, (function1_t) & make_vector_, a);
1739   a = init_builtin (builtin_type, "vector-length", 1, (function1_t) & vector_length, a);
1740   a = init_builtin (builtin_type, "vector-ref", 2, (function1_t) & vector_ref, a);
1741   a = init_builtin (builtin_type, "vector-entry", 1, (function1_t) & vector_entry, a);
1742   a = init_builtin (builtin_type, "vector-set!", 3, (function1_t) & vector_set_x, a);
1743   a = init_builtin (builtin_type, "list->vector", 1, (function1_t) & list_to_vector, a);
1744   a = init_builtin (builtin_type, "vector->list", 1, (function1_t) & vector_to_list, a);
1745
1746   return a;
1747 }
1748
1749 int
1750 try_open_boot (char *file_name, char const *boot, char const *location)
1751 {
1752   strcpy (file_name + strlen (file_name), boot);
1753   if (g_debug > 1)
1754     {
1755       eputs ("mes: reading boot-0 [");
1756       eputs (location);
1757       eputs ("]: ");
1758       eputs (file_name);
1759       eputs ("\n");
1760     }
1761   int fd = mes_open (file_name, O_RDONLY, 0);
1762   if (g_debug && fd > 0)
1763     {
1764       eputs ("mes: read boot-0: ");
1765       eputs (file_name);
1766       eputs ("\n");
1767     }
1768   return fd;
1769 }
1770
1771 void
1772 open_boot ()
1773 {
1774   __stdin = -1;
1775   char boot[1024];
1776   char file_name[1024];
1777   strcpy (g_datadir, ".");
1778   if (g_debug > 1)
1779     {
1780       eputs (";;; pkgdatadir=");
1781       eputs (MES_PKGDATADIR);
1782       eputs ("\n");
1783     }
1784   if (getenv ("MES_BOOT"))
1785     strcpy (boot, getenv ("MES_BOOT"));
1786   else
1787     strcpy (boot, "boot-0.scm");
1788   if (getenv ("MES_PREFIX"))
1789     {
1790       strcpy (g_datadir, getenv ("MES_PREFIX"));
1791       strcpy (file_name, g_datadir);
1792       strcpy (file_name + strlen (file_name), "/module/mes/");
1793       __stdin = try_open_boot (file_name, boot, "MES_PREFIX");
1794       if (__stdin < 0)
1795         {
1796           strcpy (g_datadir, getenv ("MES_PREFIX"));
1797           strcpy (g_datadir + strlen (g_datadir), "/share/mes");
1798           strcpy (file_name, g_datadir);
1799           strcpy (file_name + strlen (file_name), "/module/mes/");
1800           __stdin = try_open_boot (file_name, boot, "MES_PREFIX/share/mes");
1801         }
1802     }
1803   if (__stdin < 0)
1804     {
1805       strcpy (g_datadir, MES_PKGDATADIR);
1806       strcpy (file_name, g_datadir);
1807       strcpy (file_name + strlen (file_name), "/module/mes/");
1808       __stdin = try_open_boot (file_name, boot, "pkgdatadir");
1809     }
1810   if (__stdin < 0)
1811     {
1812       strcpy (g_datadir, "mes");
1813       strcpy (file_name, g_datadir);
1814       strcpy (file_name + strlen (file_name), "/module/mes/");
1815       __stdin = try_open_boot (file_name, boot, "mes");
1816     }
1817   if (__stdin < 0)
1818     {
1819       file_name[0] = 0;
1820       __stdin = try_open_boot (file_name, boot, "<boot>");
1821     }
1822   if (__stdin < 0)
1823     {
1824       eputs ("mes: boot failed: no such file: ");
1825       eputs (boot);
1826       eputs ("\n");
1827       exit (1);
1828     }
1829 }
1830
1831 SCM
1832 read_boot ()                    ///((internal))
1833 {
1834   r2 = read_input_file_env (r0);
1835   __stdin = STDIN;
1836   return r2;
1837 }
1838
1839 void
1840 init ()
1841 {
1842   char *p;
1843   if (p = getenv ("MES_DEBUG"))
1844     g_debug = atoi (p);
1845   open_boot ();
1846   gc_init ();
1847   g_ports = 1;
1848 }
1849
1850 int
1851 main (int argc, char *argv[])
1852 {
1853   init ();
1854
1855   SCM a = mes_environment (argc, argv);
1856   a = mes_builtins (a);
1857   a = init_time (a);
1858   m0 = make_initial_module (a);
1859   g_macros = make_hash_table_ (0);
1860
1861   if (g_debug > 5)
1862     module_printer (m0);
1863
1864   SCM program = read_boot ();
1865   push_cc (r2, cell_unspecified, r0, cell_unspecified);
1866
1867   if (g_debug > 2)
1868     {
1869       eputs ("\ngc stats: [");
1870       eputs (itoa (g_free));
1871       eputs ("]\n");
1872     }
1873   if (g_debug > 3)
1874     {
1875       eputs ("program: ");
1876       write_error_ (r1);
1877       eputs ("\n");
1878     }
1879   r3 = cell_vm_begin_expand;
1880   r1 = eval_apply ();
1881   if (g_debug)
1882     {
1883       write_error_ (r1);
1884       eputs ("\n");
1885     }
1886   if (g_debug)
1887     {
1888       if (g_debug > 5)
1889         module_printer (m0);
1890
1891       eputs ("\ngc stats: [");
1892       eputs (itoa (g_free));
1893       MAX_ARENA_SIZE = 0;
1894
1895       gc (g_stack);
1896       eputs (" => ");
1897       eputs (itoa (g_free));
1898       eputs ("]\n");
1899       eputs ("\n");
1900
1901       if (g_debug > 5)
1902         {
1903           eputs ("ports:");
1904           write_error_ (g_ports);
1905           eputs ("\n");
1906         }
1907       eputs ("\n");
1908
1909
1910     }
1911   return 0;
1912 }