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