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