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