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