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