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