8f9955f8c48a73021c9b5af8444244f37429ac60
[mes.git] / src / mes.c
1 /* -*-comment-start: "//";comment-end:""-*-
2  * Mes --- Maxwell Equations of Software
3  * Copyright © 2016,2017,2018 Jan Nieuwenhuizen <janneke@gnu.org>
4  *
5  * This file is part of Mes.
6  *
7  * 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  * 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
19  */
20
21 #include <stdio.h>
22 #include <assert.h>
23 #include <stdlib.h>
24 #include <string.h>
25 #include <mlibc.h>
26
27 #if MES_C_READER
28 int ARENA_SIZE = 10000000;
29 #else
30 int ARENA_SIZE = 100000;
31 #endif
32 int MAX_ARENA_SIZE = 20000000;
33
34 int GC_SAFETY = 250;
35
36 char *g_arena = 0;
37 typedef int SCM;
38
39 int g_debug = 0;
40 int g_free = 0;
41
42 SCM g_continuations = 0;
43 SCM g_symbols = 0;
44 SCM g_stack = 0;
45 // a/env
46 SCM r0 = 0;
47 // param 1
48 SCM r1 = 0;
49 // save 2+load/dump
50 SCM r2 = 0;
51 // continuation
52 SCM r3 = 0;
53
54 enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TREF, TSPECIAL, TSTRING, TSYMBOL, TVALUES, TVECTOR, TBROKEN_HEART};
55
56 #if !_POSIX_SOURCE
57 struct scm {
58   enum type_t type;
59   SCM car;
60   SCM cdr;
61 };
62 struct function {
63   int (*function) (void);
64   int arity;
65   char *name;
66 };
67 #else
68 typedef SCM (*function0_t) (void);
69 typedef SCM (*function1_t) (SCM);
70 typedef SCM (*function2_t) (SCM, SCM);
71 typedef SCM (*function3_t) (SCM, SCM, SCM);
72 typedef SCM (*functionn_t) (SCM);
73 struct function {
74   union {
75     function0_t function0;
76     function1_t function1;
77     function2_t function2;
78     function3_t function3;
79     functionn_t functionn;
80   };
81   int arity;
82   char const *name;
83 };
84 struct scm {
85   enum type_t type;
86   union {
87     char const* name;
88     SCM string;
89     SCM car;
90     SCM ref;
91     int length;
92   };
93   union {
94     int value;
95     int function;
96     SCM cdr;
97     SCM closure;
98     SCM continuation;
99     SCM macro;
100     SCM vector;
101     int hits;
102   };
103 };
104 #endif
105
106 #if __MESC__
107 //FIXME
108 char *foobar = 0;
109 struct scm *g_cells = foobar;
110 struct scm *g_news = foobar;
111 #else
112 struct scm *g_cells = 0;
113 struct scm *g_news = 0;
114 #endif
115
116 struct scm scm_nil = {TSPECIAL, "()",0};
117 struct scm scm_f = {TSPECIAL, "#f",0};
118 struct scm scm_t = {TSPECIAL, "#t",0};
119 struct scm scm_dot = {TSPECIAL, ".",0};
120 struct scm scm_arrow = {TSPECIAL, "=>",0};
121 struct scm scm_undefined = {TSPECIAL, "*undefined*",0};
122 struct scm scm_unspecified = {TSPECIAL, "*unspecified*",0};
123 struct scm scm_closure = {TSPECIAL, "*closure*",0};
124 struct scm scm_circular = {TSPECIAL, "*circular*",0};
125 struct scm scm_begin = {TSPECIAL, "*begin*",0};
126
127 struct scm scm_symbol_dot = {TSYMBOL, "*dot*",0};
128 struct scm scm_symbol_lambda = {TSYMBOL, "lambda",0};
129 struct scm scm_symbol_begin = {TSYMBOL, "begin",0};
130 struct scm scm_symbol_if = {TSYMBOL, "if",0};
131 struct scm scm_symbol_quote = {TSYMBOL, "quote",0};
132 #if 1 //MES_C_DEFINE // snarfing makes these always needed for linking
133 struct scm scm_symbol_define = {TSYMBOL, "define",0};
134 struct scm scm_symbol_define_macro = {TSYMBOL, "define-macro",0};
135 #endif
136
137 #if 1 //MES_C_READER // snarfing makes these always needed for linking
138 struct scm scm_symbol_quasiquote = {TSYMBOL, "quasiquote", 0};
139 struct scm scm_symbol_unquote = {TSYMBOL, "unquote", 0};
140 struct scm scm_symbol_unquote_splicing = {TSYMBOL, "unquote-splicing", 0};
141 struct scm scm_symbol_syntax = {TSYMBOL, "syntax",0};
142 struct scm scm_symbol_quasisyntax = {TSYMBOL, "quasisyntax", 0};
143 struct scm scm_symbol_unsyntax = {TSYMBOL, "unsyntax", 0};
144 struct scm scm_symbol_unsyntax_splicing = {TSYMBOL, "unsyntax-splicing", 0};
145 #endif // MES_C_READER
146
147 struct scm scm_symbol_set_x = {TSYMBOL, "set!",0};
148
149 struct scm scm_symbol_sc_expand = {TSYMBOL, "sc-expand",0};
150 struct scm scm_symbol_macro_expand = {TSYMBOL, "macro-expand",0};
151 struct scm scm_symbol_sc_expander_alist = {TSYMBOL, "*sc-expander-alist*",0};
152
153 struct scm scm_symbol_call_with_values = {TSYMBOL, "call-with-values",0};
154 struct scm scm_call_with_current_continuation = {TSPECIAL, "*call/cc*",0};
155 struct scm scm_symbol_call_with_current_continuation = {TSYMBOL, "call-with-current-continuation",0};
156 struct scm scm_symbol_current_module = {TSYMBOL, "current-module",0};
157 struct scm scm_symbol_primitive_load = {TSYMBOL, "primitive-load",0};
158 struct scm scm_symbol_read_input_file = {TSYMBOL, "read-input-file",0};
159 struct scm scm_symbol_write = {TSYMBOL, "write",0};
160 struct scm scm_symbol_display = {TSYMBOL, "display",0};
161
162 struct scm scm_symbol_throw = {TSYMBOL, "throw",0};
163 struct scm scm_symbol_not_a_pair = {TSYMBOL, "not-a-pair",0};
164 struct scm scm_symbol_system_error = {TSYMBOL, "system-error",0};
165 struct scm scm_symbol_wrong_number_of_args = {TSYMBOL, "wrong-number-of-args",0};
166 struct scm scm_symbol_wrong_type_arg = {TSYMBOL, "wrong-type-arg",0};
167 struct scm scm_symbol_unbound_variable = {TSYMBOL, "unbound-variable",0};
168
169 struct scm scm_symbol_argv = {TSYMBOL, "%argv",0};
170 struct scm scm_symbol_mes_prefix = {TSYMBOL, "%prefix",0};
171 struct scm scm_symbol_mes_version = {TSYMBOL, "%version",0};
172
173 struct scm scm_symbol_car = {TSYMBOL, "car",0};
174 struct scm scm_symbol_cdr = {TSYMBOL, "cdr",0};
175 struct scm scm_symbol_null_p = {TSYMBOL, "null?",0};
176 struct scm scm_symbol_eq_p = {TSYMBOL, "eq?",0};
177 struct scm scm_symbol_cons = {TSYMBOL, "cons",0};
178
179 struct scm scm_vm_evlis = {TSPECIAL, "*vm-evlis*",0};
180 struct scm scm_vm_evlis2 = {TSPECIAL, "*vm-evlis2*",0};
181 struct scm scm_vm_evlis3 = {TSPECIAL, "*vm-evlis3*",0};
182 struct scm scm_vm_apply = {TSPECIAL, "core:apply",0};
183 struct scm scm_vm_apply2 = {TSPECIAL, "*vm-apply2*",0};
184 struct scm scm_vm_eval = {TSPECIAL, "core:eval",0};
185
186 //MES_FIXED_PRIMITIVES
187 struct scm scm_vm_eval_car = {TSPECIAL, "*vm-eval-car*",0};
188 struct scm scm_vm_eval_cdr = {TSPECIAL, "*vm-eval-cdr*",0};
189 struct scm scm_vm_eval_cons = {TSPECIAL, "*vm-eval-cons*",0};
190 struct scm scm_vm_eval_null_p = {TSPECIAL, "*vm-eval-null-p*",0};
191 #if 1 //MES_C_DEFINE // snarfing makes these always needed for linking
192 struct scm scm_vm_eval_define = {TSPECIAL, "*vm-eval-define*",0};
193 #endif
194
195 struct scm scm_vm_eval_set_x = {TSPECIAL, "*vm-eval-set!*",0};
196 struct scm scm_vm_eval_macro = {TSPECIAL, "*vm-eval-macro*",0};
197 struct scm scm_vm_eval_check_func = {TSPECIAL, "*vm-eval-check-func*",0};
198 struct scm scm_vm_eval2 = {TSPECIAL, "*vm-eval2*",0};
199 struct scm scm_vm_macro_expand = {TSPECIAL, "core:macro-expand",0};
200 struct scm scm_vm_begin = {TSPECIAL, "*vm-begin*",0};
201 struct scm scm_vm_begin_read_input_file = {TSPECIAL, "*vm-begin-read-input-file*",0};
202 struct scm scm_vm_begin2 = {TSPECIAL, "*vm-begin2*",0};
203 struct scm scm_vm_if = {TSPECIAL, "*vm-if*",0};
204 struct scm scm_vm_if_expr = {TSPECIAL, "*vm-if-expr*",0};
205 struct scm scm_vm_call_with_values2 = {TSPECIAL, "*vm-call-with-values2*",0};
206 struct scm scm_vm_call_with_current_continuation2 = {TSPECIAL, "*vm-call-with-current-continuation2*",0};
207 struct scm scm_vm_return = {TSPECIAL, "*vm-return*",0};
208
209 struct scm scm_symbol_gnuc = {TSYMBOL, "%gnuc",0};
210 struct scm scm_symbol_mesc = {TSYMBOL, "%mesc",0};
211 struct scm scm_symbol_c_reader = {TSYMBOL, "%c-reader",0};
212 struct scm scm_symbol_c_define = {TSYMBOL, "%c-define",0};
213
214 struct scm scm_test = {TSYMBOL, "test",0};
215
216 #if !_POSIX_SOURCE
217 #include "mes.mes.symbols.h"
218 #else
219 #include "mes.symbols.h"
220 #endif
221
222 SCM tmp;
223 SCM tmp_num;
224 SCM tmp_num2;
225
226 struct function g_functions[200];
227 int g_function = 0;
228
229 #if !__GNUC__ || !_POSIX_SOURCE
230 #include "gc.mes.h"
231 #include "lib.mes.h"
232 #include "math.mes.h"
233 #include "mes.mes.h"
234 #include "posix.mes.h"
235 #include "reader.mes.h"
236 #include "vector.mes.h"
237 #else
238 #include "gc.h"
239 #include "lib.h"
240 #include "math.h"
241 #include "mes.h"
242 #include "posix.h"
243 #include "reader.h"
244 #include "vector.h"
245 #endif
246
247 #define TYPE(x) g_cells[x].type
248 #define CAR(x) g_cells[x].car
249 #define CDR(x) g_cells[x].cdr
250
251 #define NTYPE(x) g_news[x].type
252 #define NCAR(x) g_news[x].car
253 #define NCDR(x) g_news[x].cdr
254
255 #if !_POSIX_SOURCE
256 #define LENGTH(x) g_cells[x].car
257 #define REF(x) g_cells[x].car
258 #define STRING(x) g_cells[x].car
259
260 #define CLOSURE(x) g_cells[x].cdr
261 #define CONTINUATION(x) g_cells[x].cdr
262
263 #define FUNCTION(x) g_functions[g_cells[x].cdr]
264 #define MACRO(x) g_cells[x].cdr
265 #define VALUE(x) g_cells[x].cdr
266 #define VECTOR(x) g_cells[x].cdr
267
268 #define NLENGTH(x) g_news[x].car
269
270 #define NVALUE(x) g_news[x].cdr
271 #define NVECTOR(x) g_news[x].cdr
272
273 #else
274 #define CONTINUATION(x) g_cells[x].cdr
275 #define HITS(x) g_cells[x].hits
276 #define LENGTH(x) g_cells[x].length
277 #define NAME(x) g_cells[x].name
278 #define STRING(x) g_cells[x].string
279 #define CLOSURE(x) g_cells[x].closure
280 #define MACRO(x) g_cells[x].macro
281 #define REF(x) g_cells[x].ref
282 #define VALUE(x) g_cells[x].value
283 #define VECTOR(x) g_cells[x].vector
284 #define FUNCTION(x) g_functions[g_cells[x].function]
285
286 #define NLENGTH(x) g_news[x].length
287
288 #define NVALUE(x) g_news[x].value
289 #define NVECTOR(x) g_news[x].vector
290 #endif
291
292 #define MAKE_CHAR(n) make_cell_ (tmp_num_ (TCHAR), 0, tmp_num2_ (n))
293 #define MAKE_CONTINUATION(n) make_cell_ (tmp_num_ (TCONTINUATION), n, g_stack)
294 #define MAKE_NUMBER(n) make_cell_ (tmp_num_ (TNUMBER), 0, tmp_num2_ (n))
295 #define MAKE_REF(n) make_cell_ (tmp_num_ (TREF), n, 0)
296 #define MAKE_STRING(x) make_cell_ (tmp_num_ (TSTRING), x, 0)
297 #if MES_C_READER
298 #define MAKE_KEYWORD(x) make_cell_ (tmp_num_ (TKEYWORD), x, 0)
299 #endif
300 #if MES_C_DEFINE
301 #define MAKE_MACRO(name, x) make_cell_ (tmp_num_ (TMACRO), STRING (name), x)
302 #endif
303
304 #define CAAR(x) CAR (CAR (x))
305 #define CADR(x) CAR (CDR (x))
306 #define CDAR(x) CDR (CAR (x))
307 #define CDDR(x) CDR (CDR (x))
308 #define CADAR(x) CAR (CDR (CAR (x)))
309 #define CADDR(x) CAR (CDR (CDR (x)))
310 #define CDADAR(x) CAR (CDR (CAR (CDR (x))))
311
312 SCM
313 alloc (int n)
314 {
315   assert (g_free + n < ARENA_SIZE);
316   SCM x = g_free;
317   g_free += n;
318   return x;
319 }
320
321 SCM
322 tmp_num_ (int x)
323 {
324   VALUE (tmp_num) = x;
325   return tmp_num;
326 }
327
328 SCM
329 tmp_num2_ (int x)
330 {
331   VALUE (tmp_num2) = x;
332   return tmp_num2;
333 }
334
335 SCM
336 make_cell_ (SCM type, SCM car, SCM cdr)
337 {
338   SCM x = alloc (1);
339   assert (TYPE (type) == TNUMBER);
340   TYPE (x) = VALUE (type);
341   if (VALUE (type) == TCHAR || VALUE (type) == TNUMBER) {
342     if (car) CAR (x) = CAR (car);
343     if (cdr) CDR(x) = CDR(cdr);
344   }
345   else if (VALUE (type) == TFUNCTION) {
346     if (car) CAR (x) = car;
347     if (cdr) CDR(x) = CDR(cdr);
348   }
349   else {
350     CAR (x) = car;
351     CDR(x) = cdr;
352   }
353   return x;
354 }
355
356 SCM
357 make_symbol_ (SCM s) ///((internal))
358 {
359   VALUE (tmp_num) = TSYMBOL;
360   SCM x = make_cell_ (tmp_num, s, 0);
361   g_symbols = cons (x, g_symbols);
362   return x;
363 }
364
365 SCM
366 list_of_char_equal_p (SCM a, SCM b) ///((internal))
367 {
368   while (a != cell_nil && b != cell_nil && VALUE (CAR (a)) == VALUE (CAR (b))) {
369     assert (TYPE (CAR (a)) == TCHAR);
370     assert (TYPE (CAR (b)) == TCHAR);
371     a = CDR (a);
372     b = CDR (b);
373   }
374   return (a == cell_nil && b == cell_nil) ? cell_t : cell_f;
375 }
376
377 SCM
378 lookup_symbol_ (SCM s)
379 {
380   SCM x = g_symbols;
381   while (x) {
382     if (list_of_char_equal_p (STRING (CAR (x)), s) == cell_t) break;
383     x = CDR (x);
384   }
385   if (x) x = CAR (x);
386   if (!x) x = make_symbol_ (s);
387   return x;
388 }
389
390 SCM
391 type_ (SCM x)
392 {
393   return MAKE_NUMBER (TYPE (x));
394 }
395
396 SCM
397 car_ (SCM x)
398 {
399   return (TYPE (x) != TCONTINUATION
400           && (TYPE (CAR (x)) == TPAIR // FIXME: this is weird
401               || TYPE (CAR (x)) == TREF
402               || TYPE (CAR (x)) == TSPECIAL
403               || TYPE (CAR (x)) == TSYMBOL
404               || TYPE (CAR (x)) == TSTRING)) ? CAR (x) : MAKE_NUMBER (CAR (x));
405 }
406
407 SCM
408 cdr_ (SCM x)
409 {
410   return (TYPE (CDR (x)) == TPAIR
411           || TYPE (CDR (x)) == TREF
412           || TYPE (CAR (x)) == TSPECIAL
413           || TYPE (CDR (x)) == TSYMBOL
414           || TYPE (CDR (x)) == TSTRING) ? CDR (x) : MAKE_NUMBER (CDR (x));
415 }
416
417 SCM
418 arity_ (SCM x)
419 {
420   assert (TYPE (x) == TFUNCTION);
421   return MAKE_NUMBER (FUNCTION (x).arity);
422 }
423
424 SCM
425 cons (SCM x, SCM y)
426 {
427   VALUE (tmp_num) = TPAIR;
428   return make_cell_ (tmp_num, x, y);
429 }
430
431 SCM
432 car (SCM x)
433 {
434 #if !__MESC_MES__
435   if (TYPE (x) != TPAIR) error (cell_symbol_not_a_pair, cons (x, cell_symbol_car));
436 #endif
437   return CAR (x);
438 }
439
440 SCM
441 cdr (SCM x)
442 {
443 #if !__MESC_MES__
444   if (TYPE (x) != TPAIR) error (cell_symbol_not_a_pair, cons (x, cell_symbol_cdr));
445 #endif
446   return CDR (x);
447 }
448
449 SCM
450 list (SCM x) ///((arity . n))
451 {
452   return x;
453 }
454
455 SCM
456 null_p (SCM x)
457 {
458   return x == cell_nil ? cell_t : cell_f;
459 }
460
461 SCM
462 eq_p (SCM x, SCM y)
463 {
464   return (x == y
465           || ((TYPE (x) == TKEYWORD && TYPE (y) == TKEYWORD
466                && STRING (x) == STRING (y)))
467           || (TYPE (x) == TCHAR && TYPE (y) == TCHAR
468               && VALUE (x) == VALUE (y))
469           || (TYPE (x) == TNUMBER && TYPE (y) == TNUMBER
470               && VALUE (x) == VALUE (y)))
471     ? cell_t : cell_f;
472 }
473
474 SCM
475 values (SCM x) ///((arity . n))
476 {
477   SCM v = cons (0, x);
478   TYPE (v) = TVALUES;
479   return v;
480 }
481
482 SCM
483 acons (SCM key, SCM value, SCM alist)
484 {
485   return cons (cons (key, value), alist);
486 }
487
488 SCM
489 length (SCM x)
490 {
491   int n = 0;
492   while (x != cell_nil)
493     {
494       n++;
495       if (TYPE (x) != TPAIR) return MAKE_NUMBER (-1);
496       x = CDR (x);
497     }
498   return MAKE_NUMBER (n);
499 }
500
501 SCM apply (SCM, SCM, SCM);
502
503 SCM
504 error (SCM key, SCM x)
505 {
506 #if !__MESC_MES__
507   SCM throw;
508   if ((throw = assq_ref_env (cell_symbol_throw, r0)) != cell_undefined)
509     return apply (throw, cons (key, cons (x, cell_nil)), r0);
510 #endif
511   display_error_ (key);
512   eputs (": ");
513   display_error_ (x);
514   eputs ("\n");
515   exit (1);
516 }
517
518 SCM
519 cstring_to_list (char const* s)
520 {
521   SCM p = cell_nil;
522   int i = strlen (s);
523   while (i--)
524     p = cons (MAKE_CHAR (s[i]), p);
525   return p;
526 }
527
528 // \f extra lib
529 SCM
530 assert_defined (SCM x, SCM e) ///((internal))
531 {
532   if (e == cell_undefined) return error (cell_symbol_unbound_variable, x);
533   return e;
534 }
535
536 SCM
537 check_formals (SCM f, SCM formals, SCM args) ///((internal))
538 {
539   int flen = (TYPE (formals) == TNUMBER) ? VALUE (formals) : VALUE (length (formals));
540   int alen = VALUE (length (args));
541   if (alen != flen && alen != -1 && flen != -1)
542     {
543       char *s = "apply: wrong number of arguments; expected: ";
544       eputs (s);
545       eputs (itoa (flen));
546       eputs (", got: ");
547       eputs (itoa (alen));
548       eputs ("\n");
549       display_error_ (f);
550       SCM e = MAKE_STRING (cstring_to_list (s));
551       return error (cell_symbol_wrong_number_of_args, cons (e, f));
552     }
553   return cell_unspecified;
554 }
555
556 SCM
557 check_apply (SCM f, SCM e) ///((internal))
558 {
559   char* type = 0;
560   if (f == cell_f || f == cell_t) type = "bool";
561   if (f == cell_nil) type = "nil";
562   if (f == cell_unspecified) type = "*unspecified*";
563   if (f == cell_undefined) type = "*undefined*";
564   if (TYPE (f) == TCHAR) type = "char";
565   if (TYPE (f) == TNUMBER) type = "number";
566   if (TYPE (f) == TSTRING) type = "string";
567
568   if (type)
569     {
570       char *s = "cannot apply: ";
571       eputs (s);
572       eputs (type);
573       eputs ("[");
574       display_error_ (e);
575       eputs ("]\n");
576       SCM e = MAKE_STRING (cstring_to_list (s));
577       return error (cell_symbol_wrong_type_arg, cons (e, f));
578     }
579   return cell_unspecified;
580 }
581
582 SCM
583 gc_push_frame () ///((internal))
584 {
585   SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cell_nil))));
586   g_stack = cons (frame, g_stack);
587   return g_stack;
588 }
589
590 SCM
591 append2 (SCM x, SCM y)
592 {
593   if (x == cell_nil) return y;
594   assert (TYPE (x) == TPAIR);
595   return cons (car (x), append2 (cdr (x), y));
596 }
597
598 SCM
599 pairlis (SCM x, SCM y, SCM a)
600 {
601   if (x == cell_nil)
602     return a;
603   if (TYPE (x) != TPAIR)
604     return cons (cons (x, y), a);
605   return cons (cons (car (x), car (y)),
606                pairlis (cdr (x), cdr (y), a));
607 }
608
609 SCM
610 call (SCM fn, SCM x)
611 {
612   if ((FUNCTION (fn).arity > 0 || FUNCTION (fn).arity == -1)
613       && x != cell_nil && TYPE (CAR (x)) == TVALUES)
614     x = cons (CADAR (x), CDR (x));
615   if ((FUNCTION (fn).arity > 1 || FUNCTION (fn).arity == -1)
616       && x != cell_nil && TYPE (CDR (x)) == TPAIR && TYPE (CADR (x)) == TVALUES)
617     x = cons (CAR (x), cons (CDADAR (x), CDR (x)));
618   switch (FUNCTION (fn).arity)
619     {
620 #if __MESC__ || !_POSIX_SOURCE
621     case 0: return (FUNCTION (fn).function) ();
622     case 1: return ((SCM(*)(SCM))(FUNCTION (fn).function)) (CAR (x));
623     case 2: return ((SCM(*)(SCM,SCM))(FUNCTION (fn).function)) (CAR (x), CADR (x));
624     case 3: return ((SCM(*)(SCM,SCM,SCM))(FUNCTION (fn).function)) (CAR (x), CADR (x), CAR (CDDR (x)));
625     case -1: return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);
626     default: return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);
627 #else
628     case 0: return FUNCTION (fn).function0 ();
629     case 1: return FUNCTION (fn).function1 (CAR (x));
630     case 2: return FUNCTION (fn).function2 (CAR (x), CADR (x));
631     case 3: return FUNCTION (fn).function3 (CAR (x), CADR (x), CAR (CDDR (x)));
632     case -1: return FUNCTION (fn).functionn (x);
633 #endif
634     }
635
636   return cell_unspecified;
637 }
638
639 SCM
640 assq (SCM x, SCM a)
641 {
642   switch (TYPE (x))
643     {
644     case TCHAR:
645     case TNUMBER:
646       {
647         SCM v = VALUE (x);
648         while (a != cell_nil && v != VALUE (CAAR (a))) a = CDR (a); break;
649       }
650     case TKEYWORD:
651       {
652         SCM v = STRING (x);
653         while (a != cell_nil && v != STRING (CAAR (a))) a = CDR (a); break;
654       }
655     // case TSYMBOL:
656     // case TSPECIAL:
657     default:
658       while (a != cell_nil && x != CAAR (a)) a = CDR (a); break;
659     }
660   return a != cell_nil ? CAR (a) : cell_f;
661 }
662
663 SCM
664 assq_ref_env (SCM x, SCM a)
665 {
666   x = assq (x, a);
667   if (x == cell_f) return cell_undefined;
668   return CDR (x);
669 }
670
671 SCM
672 set_car_x (SCM x, SCM e)
673 {
674   assert (TYPE (x) == TPAIR);
675   CAR (x) = e;
676   return cell_unspecified;
677 }
678
679 SCM
680 set_cdr_x (SCM x, SCM e)
681 {
682   if (TYPE (x) != TPAIR) error (cell_symbol_not_a_pair, cons (x, cell_set_cdr_x));
683   CDR (x) = e;
684   return cell_unspecified;
685 }
686
687 SCM
688 set_env_x (SCM x, SCM e, SCM a)
689 {
690   SCM p = assert_defined (x, assq (x, a));
691   if (TYPE (p) != TPAIR) error (cell_symbol_not_a_pair, cons (p, x));
692   return set_cdr_x (p, e);
693 }
694
695 SCM
696 call_lambda (SCM e, SCM x, SCM aa, SCM a) ///((internal))
697 {
698   SCM cl = cons (cons (cell_closure, x), x);
699   r1 = e;
700   r0 = cl;
701   return cell_unspecified;
702 }
703
704 SCM
705 make_closure_ (SCM args, SCM body, SCM a) ///((internal))
706 {
707   return make_cell_ (tmp_num_ (TCLOSURE), cell_f, cons (cons (cell_circular, a), cons (args, body)));
708 }
709
710 SCM
711 lookup_macro_ (SCM x, SCM a) ///((internal))
712 {
713   if (TYPE (x) != TSYMBOL) return cell_f;
714   SCM m = assq_ref_env (x, a);
715   if (TYPE (m) == TMACRO) return MACRO (m);
716   return cell_f;
717 }
718
719 SCM
720 push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal))
721 {
722   SCM x = r3;
723   r3 = c;
724   r2 = p2;
725   gc_push_frame ();
726   r1 = p1;
727   r0 = a;
728   r3 = x;
729   return cell_unspecified;
730 }
731
732 SCM
733 gc_peek_frame () ///((internal))
734 {
735   SCM frame = CAR (g_stack);
736   r1 = CAR (frame);
737   r2 = CADR (frame);
738   r3 = CAR (CDDR (frame));
739   r0 = CADR (CDDR (frame));
740   return frame;
741 }
742
743 SCM
744 gc_pop_frame () ///((internal))
745 {
746   SCM frame = gc_peek_frame (g_stack);
747   g_stack = CDR (g_stack);
748   return frame;
749 }
750
751 SCM
752 eval_apply ()
753 {
754  eval_apply:
755   gc_check ();
756   switch (r3)
757     {
758     case cell_vm_evlis: goto evlis;
759     case cell_vm_evlis2: goto evlis2;
760     case cell_vm_evlis3: goto evlis3;
761     case cell_vm_apply: goto apply;
762     case cell_vm_apply2: goto apply2;
763     case cell_vm_eval: goto eval;
764 #if MES_FIXED_PRIMITIVES
765     case cell_vm_eval_car: goto eval_car;
766     case cell_vm_eval_cdr: goto eval_cdr;
767     case cell_vm_eval_cons: goto eval_cons;
768     case cell_vm_eval_null_p: goto eval_null_p;
769 #endif
770 #if MES_C_DEFINE
771     case cell_vm_eval_define: goto eval_define;
772 #endif
773     case cell_vm_eval_set_x: goto eval_set_x;
774     case cell_vm_eval_macro: goto eval_macro;
775     case cell_vm_eval_check_func: goto eval_check_func;
776     case cell_vm_eval2: goto eval2;
777     case cell_vm_macro_expand: goto macro_expand;
778     case cell_vm_begin: goto begin;
779     case cell_vm_begin_read_input_file: goto begin_read_input_file;
780     case cell_vm_begin2: goto begin2;
781     case cell_vm_if: goto vm_if;
782     case cell_vm_if_expr: goto if_expr;
783     case cell_vm_call_with_current_continuation2: goto call_with_current_continuation2;
784     case cell_vm_call_with_values2: goto call_with_values2;
785     case cell_vm_return: goto vm_return;
786     case cell_unspecified: return r1;
787     default:
788       assert (0);
789     }
790
791   SCM x = cell_nil;
792  evlis:
793   gc_check ();
794   if (r1 == cell_nil) goto vm_return;
795   if (TYPE (r1) != TPAIR) goto eval;
796   push_cc (CAR (r1), r1, r0, cell_vm_evlis2);
797   goto eval;
798  evlis2:
799   push_cc (CDR (r2), r1, r0, cell_vm_evlis3);
800   goto evlis;
801  evlis3:
802   r1 = cons (r2, r1);
803   goto vm_return;
804
805  apply:
806   gc_check ();
807   switch (TYPE (CAR (r1)))
808     {
809     case TFUNCTION: {
810       check_formals (CAR (r1), MAKE_NUMBER (FUNCTION (CAR (r1)).arity), CDR (r1));
811       r1 = call (CAR (r1), CDR (r1)); /// FIXME: move into eval_apply
812       goto vm_return;
813     }
814     case TCLOSURE:
815       {
816         SCM cl = CLOSURE (CAR (r1));
817         SCM formals = CADR (cl);
818         SCM body = CDDR (cl);
819         SCM aa = CDAR (cl);
820         aa = CDR (aa);
821         check_formals (CAR (r1), formals, CDR (r1));
822         SCM p = pairlis (formals, CDR (r1), aa);
823         call_lambda (body, p, aa, r0);
824         goto begin;
825       }
826       case TCONTINUATION:
827         {
828           x = r1;
829           g_stack = CONTINUATION (CAR (r1));
830           gc_pop_frame ();
831           r1 = CADR (x);
832           goto eval_apply;
833         }
834     case TSPECIAL:
835       {
836         switch (CAR (r1))
837           {
838           case cell_vm_apply:
839             {
840               push_cc (cons (CADR (r1), CADDR (r1)), r1, r0, cell_vm_return);
841               goto apply;
842             }
843           case cell_vm_eval:
844             {
845               push_cc (CADR (r1), r1, CADDR (r1), cell_vm_return);
846               goto eval;
847             }
848           case cell_call_with_current_continuation:
849             {
850               r1 = CDR (r1);
851               goto call_with_current_continuation;
852             }
853           default: check_apply (cell_f, CAR (r1));
854           }
855       }
856     case TSYMBOL:
857       {
858         if (CAR (r1) == cell_symbol_call_with_values)
859           {
860             r1 = CDR (r1);
861             goto call_with_values;
862           }
863         if (CAR (r1) == cell_symbol_current_module)
864           {
865             r1 = r0;
866             goto vm_return;
867           }
868         break;
869       }
870     case TPAIR:
871       {
872         switch (CAAR (r1))
873           {
874           case cell_symbol_lambda:
875             {
876               SCM formals = CADR (CAR (r1));
877               SCM body = CDDR (CAR (r1));
878               SCM p = pairlis (formals, CDR (r1), r0);
879               check_formals (r1, formals, CDR (r1));
880               call_lambda (body, p, p, r0);
881               goto begin;
882             }
883           }
884       }
885     }
886   push_cc (CAR (r1), r1, r0, cell_vm_apply2);
887   goto eval;
888  apply2:
889   check_apply (r1, CAR (r2));
890   r1 = cons (r1, CDR (r2));
891   goto apply;
892
893  eval:
894   gc_check ();
895   switch (TYPE (r1))
896     {
897     case TPAIR:
898       {
899         switch (CAR (r1))
900           {
901 #if MES_FIXED_PRIMITIVES
902           case cell_symbol_car:
903             {
904               push_cc (CADR (r1), r1, r0, cell_vm_eval_car); goto eval;
905             eval_car:
906               x = r1; gc_pop_frame (); r1 = CAR (x); goto eval_apply;
907             }
908           case cell_symbol_cdr:
909             {
910               push_cc (CADR (r1), r1, r0, cell_vm_eval_cdr); goto eval;
911             eval_cdr:
912               x = r1; gc_pop_frame (); r1 = CDR (x); goto eval_apply;
913             }
914           case cell_symbol_cons: {
915             push_cc (CDR (r1), r1, r0, cell_vm_eval_cons); goto evlis;
916             eval_cons:
917             x = r1;
918             gc_pop_frame ();
919             r1 = cons (CAR (x), CADR (x));
920             goto eval_apply;
921           }
922           case cell_symbol_null_p:
923             {
924               push_cc (CADR (r1), r1, r0, cell_vm_eval_null_p);
925               goto eval;
926             eval_null_p:
927               x = r1; gc_pop_frame (); r1 = null_p (x); goto eval_apply;
928             }
929 #endif // MES_FIXED_PRIMITIVES
930           case cell_symbol_quote:
931             {
932               x = r1; gc_pop_frame (); r1 = CADR (x); goto eval_apply;
933             }
934           case cell_symbol_begin: goto begin;
935           case cell_symbol_lambda:
936             {
937               r1 = make_closure_ (CADR (r1), CDDR (r1), assq (cell_closure, r0));
938               goto vm_return;
939             }
940           case cell_symbol_if: {r1=CDR (r1); goto vm_if;}
941           case cell_symbol_set_x:
942             {
943               push_cc (CAR (CDDR (r1)), r1, r0, cell_vm_eval_set_x);
944               goto eval;
945             eval_set_x:
946               x = r2;
947               r1 = set_env_x (CADR (x), r1, r0);
948               goto vm_return;
949             }
950           case cell_vm_macro_expand:
951             {
952               push_cc (CADR (r1), r1, r0, cell_vm_macro_expand);
953               goto eval;
954             }
955           default: {
956             push_cc (r1, r1, r0, cell_vm_eval_macro);
957             goto macro_expand;
958             eval_macro:
959             if (r1 != r2)
960               {
961                 if (TYPE (r1) == TPAIR)
962                   {
963                     set_cdr_x (r2, CDR (r1));
964                     set_car_x (r2, CAR (r1));
965                   }
966                 goto eval;
967               }
968 #if MES_C_DEFINE
969             if (TYPE (r1) == TPAIR
970                 && (CAR (r1) == cell_symbol_define
971                     || CAR (r1) == cell_symbol_define_macro))
972               {
973                 r2 = CADR (r1);
974                 if (TYPE (r2) != TPAIR)
975                   {
976                     push_cc (CAR (CDDR (r1)), r2, cons (cons (CADR (r1), CADR (r1)), r0), cell_vm_eval_define);
977                     goto eval;
978                   }
979                 else
980                   {
981                     r2 = CAR (r2);
982                     SCM p = pairlis (CADR (r1), CADR (r1), r0);
983                     SCM args = CDR (CADR (r1));
984                     SCM body = CDDR (r1);
985                     r1 = cons (cell_symbol_lambda, cons (args, body));
986                     push_cc (r1, r2, p, cell_vm_eval_define);
987                     goto eval;
988                   }
989               eval_define:
990                 if (CAAR (CAAR (g_stack)) == cell_symbol_define_macro
991                     || CAR (CAAR (g_stack)) == cell_symbol_define_macro)
992                   r1 = MAKE_MACRO (r2, r1);
993                 SCM entry = cons (r2, r1);
994                 SCM aa = cons (entry, cell_nil);
995                 set_cdr_x (aa, cdr (r0));
996                 set_cdr_x (r0, aa);
997                 SCM cl = assq (cell_closure, r0);
998                 set_cdr_x (cl, aa);
999                 r1 = entry;
1000                 goto vm_return;
1001               }
1002 #endif // MES_C_DEFINE
1003
1004             push_cc (CAR (r1), r1, r0, cell_vm_eval_check_func); goto eval;
1005             eval_check_func:
1006             push_cc (CDR (r2), r2, r0, cell_vm_eval2); goto evlis;
1007             eval2:
1008             r1 = cons (CAR (r2), r1);
1009             goto apply;
1010           }
1011           }
1012       }
1013     case TSYMBOL:
1014       {
1015         r1 = assert_defined (r1, assq_ref_env (r1, r0));
1016         goto vm_return;
1017       }
1018     default: goto vm_return;
1019     }
1020
1021   SCM macro;
1022   SCM expanders;
1023  macro_expand:
1024   if (TYPE (r1) == TPAIR
1025       && (macro = lookup_macro_ (CAR (r1), r0)) != cell_f)
1026     {
1027       r1 = cons (macro, CDR (r1));
1028       goto apply;
1029     }
1030   else if (TYPE (r1) == TPAIR
1031            && TYPE (CAR (r1)) == TSYMBOL
1032            && ((expanders = assq_ref_env (cell_symbol_sc_expander_alist, r0)) != cell_undefined)
1033            && ((macro = assq (CAR (r1), expanders)) != cell_f))
1034     {
1035       SCM sc_expand = assq_ref_env (cell_symbol_macro_expand, r0);
1036       if (sc_expand != cell_undefined && sc_expand != cell_f)
1037         {
1038           r1 = cons (sc_expand, cons (r1, cell_nil));
1039           goto apply;
1040         }
1041     }
1042   goto vm_return;
1043
1044  begin:
1045   x = cell_unspecified;
1046   while (r1 != cell_nil) {
1047     gc_check ();
1048     if (TYPE (r1) == TPAIR && TYPE (CAR (r1)) == TPAIR)
1049       {
1050         if (CAAR (r1) == cell_symbol_begin)
1051           r1 = append2 (CDAR (r1), CDR (r1));
1052         else if (CAAR (r1) == cell_symbol_primitive_load)
1053           {
1054             push_cc (cons (cell_symbol_read_input_file, cell_nil), r1, r0, cell_vm_begin_read_input_file);
1055             goto apply;
1056           begin_read_input_file:
1057             r1 = append2 (r1, CDR (r2));
1058           }
1059       }
1060     if (CDR (r1) == cell_nil)
1061       {
1062         r1 = CAR (r1);
1063         goto eval;
1064       }
1065     push_cc (CAR (r1), r1, r0, cell_vm_begin2);
1066     goto eval;
1067   begin2:
1068     x = r1;
1069     r1 = CDR (r2);
1070   }
1071   r1 = x;
1072   goto vm_return;
1073
1074  vm_if:
1075   push_cc (CAR (r1), r1, r0, cell_vm_if_expr);
1076   goto eval;
1077  if_expr:
1078   x = r1;
1079   r1 = r2;
1080   if (x != cell_f)
1081     {
1082       r1 = CADR (r1);
1083       goto eval;
1084     }
1085   if (CDDR (r1) != cell_nil)
1086     {
1087       r1 = CAR (CDDR (r1));
1088       goto eval;
1089     }
1090   r1 = cell_unspecified;
1091   goto vm_return;
1092
1093  call_with_current_continuation:
1094   gc_push_frame ();
1095   x = MAKE_CONTINUATION (g_continuations++);
1096   gc_pop_frame ();
1097   push_cc (cons (CAR (r1), cons (x, cell_nil)), x, r0, cell_vm_call_with_current_continuation2);
1098   goto apply;
1099  call_with_current_continuation2:
1100   CONTINUATION (r2) = g_stack;
1101   goto vm_return;
1102
1103  call_with_values:
1104   push_cc (cons (CAR (r1), cell_nil), r1, r0, cell_vm_call_with_values2);
1105   goto apply;
1106  call_with_values2:
1107   if (TYPE (r1) == TVALUES)
1108     r1 = CDR (r1);
1109   r1 = cons (CADR (r2), r1);
1110   goto apply;
1111
1112  vm_return:
1113   x = r1;
1114   gc_pop_frame ();
1115   r1 = x;
1116   goto eval_apply;
1117 }
1118
1119 SCM
1120 apply (SCM f, SCM x, SCM a) ///((internal))
1121 {
1122   push_cc (cons (f, x), cell_unspecified, r0, cell_unspecified);
1123   r3 = cell_vm_apply;
1124   return eval_apply ();
1125 }
1126
1127 SCM
1128 mes_g_stack (SCM a) ///((internal))
1129 {
1130   r0 = a;
1131   r1 = MAKE_CHAR (0);
1132   r2 = MAKE_CHAR (0);
1133   r3 = MAKE_CHAR (0);
1134   g_stack = cons (cell_nil, cell_nil);
1135   return r0;
1136 }
1137
1138 //\f Environment setup
1139
1140 SCM
1141 make_tmps (struct scm* cells)
1142 {
1143   tmp = g_free++;
1144   cells[tmp].type = TCHAR;
1145   tmp_num = g_free++;
1146   cells[tmp_num].type = TNUMBER;
1147   tmp_num2 = g_free++;
1148   cells[tmp_num2].type = TNUMBER;
1149   return 0;
1150 }
1151
1152 #include "posix.c"
1153 #include "math.c"
1154 #include "lib.c"
1155
1156 //\f Jam Collector
1157 SCM g_symbol_max;
1158
1159 SCM
1160 gc_init_cells () ///((internal))
1161 {
1162   g_cells = (struct scm *)malloc (2*ARENA_SIZE*sizeof (struct scm));
1163
1164   TYPE (0) = TVECTOR;
1165   LENGTH (0) = 1000;
1166   VECTOR (0) = 0;
1167 #if __MESC__
1168   g_cells += sizeof (struct scm);
1169 #else
1170   g_cells++;
1171 #endif
1172   TYPE (0) = TCHAR;
1173   VALUE (0) = 'c';
1174   return 0;
1175 }
1176
1177 SCM
1178 gc_init_news () ///((internal))
1179 {
1180 #if __MESC__
1181   char *p = g_cells;
1182   p -= sizeof (struct scm);
1183   p += ARENA_SIZE * sizeof (struct scm);
1184   g_news = p;
1185 #else
1186   g_news = g_cells-1 + ARENA_SIZE;
1187 #endif
1188
1189   NTYPE (0) = TVECTOR;
1190   NLENGTH (0) = 1000;
1191   NVECTOR (0) = 0;
1192 #if __MESC__
1193   g_news += sizeof (struct scm);
1194 #else
1195   g_news++;
1196 #endif
1197   NTYPE (0) = TCHAR;
1198   NVALUE (0) = 'n';
1199   return 0;
1200 }
1201
1202 SCM
1203 mes_symbols () ///((internal))
1204 {
1205   gc_init_cells ();
1206   gc_init_news ();
1207
1208 #if !_POSIX_SOURCE
1209 #include "mes.mes.symbols.i"
1210 #else
1211 #include "mes.symbols.i"
1212 #endif
1213
1214   g_symbol_max = g_free;
1215   make_tmps (g_cells);
1216
1217   g_symbols = 0;
1218   for (int i=1; i<g_symbol_max; i++)
1219     g_symbols = cons (i, g_symbols);
1220
1221   SCM a = cell_nil;
1222
1223 #if !_POSIX_SOURCE
1224 #include "mes.mes.symbol-names.i"
1225 #else
1226 #include "mes.symbol-names.i"
1227 #endif
1228
1229   a = acons (cell_symbol_mes_version, MAKE_STRING (cstring_to_list (VERSION)), a);
1230   a = acons (cell_symbol_mes_prefix, MAKE_STRING (cstring_to_list (PREFIX)), a);
1231
1232   a = acons (cell_symbol_dot, cell_dot, a);
1233   a = acons (cell_symbol_begin, cell_begin, a);
1234   a = acons (cell_symbol_call_with_values, cell_symbol_call_with_values, a);
1235   a = acons (cell_symbol_current_module, cell_symbol_current_module, a);
1236   a = acons (cell_symbol_call_with_current_continuation, cell_call_with_current_continuation, a);
1237   a = acons (cell_symbol_sc_expand, cell_f, a);
1238
1239 #if __GNUC__
1240   a = acons (cell_symbol_gnuc, cell_t, a);
1241   a = acons (cell_symbol_mesc, cell_f, a);
1242 #else
1243   a = acons (cell_symbol_gnuc, cell_f, a);
1244   a = acons (cell_symbol_mesc, cell_t, a);
1245 #endif
1246
1247 #if MES_C_READER
1248   a = acons (cell_symbol_c_reader, cell_t, a);
1249 #else
1250   a = acons (cell_symbol_c_reader, cell_f, a);
1251 #endif
1252
1253 #if MES_C_DEFINE
1254   a = acons (cell_symbol_c_define, cell_t, a);
1255 #else
1256   a = acons (cell_symbol_c_define, cell_f, a);
1257 #endif
1258   a = acons (cell_closure, a, a);
1259
1260   return a;
1261 }
1262
1263 SCM
1264 mes_environment () ///((internal))
1265 {
1266   SCM a = mes_symbols ();
1267   return mes_g_stack (a);
1268 }
1269
1270 SCM
1271 mes_builtins (SCM a) ///((internal))
1272 {
1273 #if !__GNUC__ || !_POSIX_SOURCE
1274 #include "mes.mes.i"
1275
1276 // Do not sort: Order of these includes define builtins
1277 #include "posix.mes.i"
1278 #include "math.mes.i"
1279 #include "lib.mes.i"
1280 #include "vector.mes.i"
1281 #include "gc.mes.i"
1282 #include "reader.mes.i"
1283
1284 #include "gc.mes.environment.i"
1285 #include "lib.mes.environment.i"
1286 #include "math.mes.environment.i"
1287 #include "mes.mes.environment.i"
1288 #include "posix.mes.environment.i"
1289 #include "reader.mes.environment.i"
1290 #include "vector.mes.environment.i"
1291 #else
1292 #include "mes.i"
1293
1294 // Do not sort: Order of these includes define builtins
1295 #include "posix.i"
1296 #include "math.i"
1297 #include "lib.i"
1298 #include "vector.i"
1299 #include "gc.i"
1300 #include "reader.i"
1301
1302 #include "gc.environment.i"
1303 #include "lib.environment.i"
1304 #include "math.environment.i"
1305 #include "mes.environment.i"
1306 #include "posix.environment.i"
1307 #include "reader.environment.i"
1308 #include "vector.environment.i"
1309 #endif
1310
1311   if (g_debug > 1)
1312     {
1313       fputs ("functions: ", STDERR);
1314       fputs (itoa (g_function), STDERR);
1315       fputs ("\n", STDERR);
1316       for (int i = 0; i < g_function; i++)
1317         {
1318           fputs ("[", STDERR);
1319           fputs (itoa (i), STDERR);
1320           fputs ("]: ", STDERR);
1321           fputs (g_functions[i].name, STDERR);
1322           fputs ("\n", STDERR);
1323         }
1324       fputs ("\n", STDERR);
1325     }
1326
1327   return a;
1328 }
1329
1330 SCM read_input_file_env (SCM);
1331
1332 SCM
1333 load_env (SCM a) ///((internal))
1334 {
1335   r0 = a;
1336   g_stdin = -1;
1337   if (getenv ("MES_PREFIX"))
1338     {
1339       char buf[128];
1340       strcpy (buf, getenv ("MES_PREFIX"));
1341       strcpy (buf + strlen (buf), "/module");
1342       strcpy (buf + strlen (buf), "/mes/read-0.mes");
1343       if (getenv ("MES_DEBUG"))
1344         {
1345           eputs ("MES_PREFIX reading read-0:");
1346           eputs (buf);
1347           eputs ("\n");
1348         }
1349       g_stdin = open (buf, O_RDONLY);
1350     }
1351   if (g_stdin < 0)
1352     {
1353       char *read0 = MODULEDIR "mes/read-0.mes";
1354       if (getenv ("MES_DEBUG"))
1355         {
1356           eputs ("MODULEDIR reading read-0:");
1357           eputs (read0);
1358           eputs ("\n");
1359         }
1360       g_stdin = open (read0, O_RDONLY);
1361     }
1362   if (g_stdin < 0)
1363     {
1364       if (getenv ("MES_DEBUG"))
1365         {
1366           eputs (". reading read-0:");
1367           eputs ("module/mes/read-0.mes");
1368           eputs ("\n");
1369         }
1370       g_stdin = open ("module/mes/read-0.mes", O_RDONLY);
1371     }
1372   if (g_stdin < 0)
1373     {
1374       eputs ("boot failed, read-0.mes not found\n");
1375       exit (1);
1376     }
1377
1378   if (!g_function) r0 = mes_builtins (r0);
1379   r2 = read_input_file_env (r0);
1380   g_stdin = STDIN;
1381   return r2;
1382 }
1383
1384 SCM
1385 bload_env (SCM a) ///((internal))
1386 {
1387 #if __MESC__
1388   char *mo = "mes/read-0-32.mo";
1389   g_stdin = open ("module/mes/read-0-32.mo", O_RDONLY);
1390   char *read0 = MODULEDIR "mes/read-0-32.mo";
1391   g_stdin = g_stdin >= 0 ? g_stdin : open (read0, O_RDONLY);
1392 #else
1393   char *mo ="mes/read-0.mo";
1394   g_stdin = open ("module/mes/read-0.mo", O_RDONLY);
1395   g_stdin = g_stdin >= 0 ? g_stdin : open (MODULEDIR "mes/read-0.mo", O_RDONLY);
1396 #endif
1397
1398   if (g_stdin < 0) {eputs ("no such file: ");eputs (mo);eputs ("\n");return 1;} 
1399   assert (getchar () == 'M');
1400   assert (getchar () == 'E');
1401   assert (getchar () == 'S');
1402
1403   if (g_debug) eputs ("*GOT MES*\n");
1404   g_stack = getchar () << 8;
1405   g_stack += getchar ();
1406
1407   char *p = (char*)g_cells;
1408   int c = getchar ();
1409   while (c != EOF)
1410     {
1411       *p++ = c;
1412       c = getchar ();
1413     }
1414   g_free = (p-(char*)g_cells) / sizeof (struct scm);
1415   gc_peek_frame ();
1416   g_symbols = r1;
1417   g_stdin = STDIN;
1418   r0 = mes_builtins (r0);
1419
1420 #if __GNUC__
1421   set_env_x (cell_symbol_gnuc, cell_t, r0);
1422   set_env_x (cell_symbol_mesc, cell_f, r0);
1423 #else
1424   set_env_x (cell_symbol_gnuc, cell_f, r0);
1425   set_env_x (cell_symbol_mesc, cell_t, r0);
1426 #endif
1427
1428   if (g_debug > 1)
1429     {
1430       eputs ("symbols: ");
1431       SCM s = g_symbols;
1432       while (s && s != cell_nil) {
1433         display_error_ (CAR (s));
1434         eputs (" ");
1435         s = CDR (s);
1436       }
1437       eputs ("\n");
1438       eputs ("functions: ");
1439       eputs (itoa (g_function));
1440       eputs ("\n");
1441       for (int i = 0; i < g_function; i++)
1442         {
1443           eputs ("[");
1444           eputs (itoa (i));
1445           eputs ("]: ");
1446           eputs (g_functions[i].name);
1447           eputs ("\n");
1448         }
1449       //display_error_ (r0);
1450       //puts ("\n");
1451     }
1452   return r2;
1453 }
1454
1455 #include "vector.c"
1456 #include "gc.c"
1457 #include "reader.c"
1458
1459 int
1460 main (int argc, char *argv[])
1461 {
1462   char *p;
1463   if (p = getenv ("MES_DEBUG")) g_debug = atoi (p);
1464   if (g_debug) {eputs (";;; MODULEDIR=");eputs (MODULEDIR);eputs ("\n");}
1465   if (p = getenv ("MES_MAX_ARENA")) MAX_ARENA_SIZE = atoi (p);
1466   if (p = getenv ("MES_ARENA")) ARENA_SIZE = atoi (p);
1467   GC_SAFETY = ARENA_SIZE / 400;
1468   if (argc > 1 && !strcmp (argv[1], "--help")) return puts ("Usage: mes [--dump|--load] < FILE\n");
1469   if (argc > 1 && !strcmp (argv[1], "--version")) {puts ("Mes ");puts (VERSION);puts ("\n");return 0;};
1470   g_stdin = STDIN;
1471   g_stdout = STDOUT;
1472   r0 = mes_environment ();
1473
1474   SCM program = (argc > 1 && !strcmp (argv[1], "--load"))
1475     ? bload_env (r0) : load_env (r0);
1476   g_tiny = argc > 2 && !strcmp (argv[2], "--tiny");
1477   if (argc > 1 && !strcmp (argv[1], "--dump")) return dump ();
1478
1479   SCM lst = cell_nil;
1480   for (int i=argc-1; i>=0; i--) lst = cons (MAKE_STRING (cstring_to_list (argv[i])), lst);
1481   r0 = acons (cell_symbol_argv, lst, r0);
1482   push_cc (r2, cell_unspecified, r0, cell_unspecified);
1483   if (g_debug > 1)
1484     {
1485       eputs ("program: ");
1486       display_error_ (r1);
1487       eputs ("\n");
1488     }
1489   r3 = cell_vm_begin;
1490   r1 = eval_apply ();
1491   display_error_ (r1);
1492   eputs ("\n");
1493   gc (g_stack);
1494   if (g_debug)
1495     {
1496       eputs ("\nstats: [");
1497       eputs (itoa (g_free));
1498       eputs ("]\n");
1499     }
1500   return 0;
1501 }