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