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