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