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