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