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