build: Uniquify config macros.
[mes.git] / 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 }