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