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