core: Increase MAX_ARENA_SIZE and GC safety.
[mes.git] / scaffold / mini-mes.c
1 /* -*-comment-start: "//";comment-end:""-*-
2  * Mes --- Maxwell Equations of Software
3  * Copyright © 2016,2017 Jan 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 #if __GNUC__
22 #include "mlibc.c"
23 #endif
24 #define assert(x) ((x) ? (void)0 : assert_fail (#x))
25
26 #define MES_MINI 1
27 #define FIXED_PRIMITIVES 1
28
29 #define MES_GC 1
30 #if MES_GC
31 int ARENA_SIZE = 100000;
32 #else
33 int ARENA_SIZE = 1000000000;
34 #endif
35 int MAX_ARENA_SIZE = 40000000;
36 int GC_SAFETY = 10000;
37
38 char *arena = 0;
39
40 typedef int SCM;
41
42 int g_debug = 0;
43 int g_free = 0;
44
45 SCM g_continuations = 0;
46 SCM g_symbols = 0;
47 SCM g_stack = 0;
48 // a/env
49 SCM r0 = 0;
50 // param 1
51 SCM r1 = 0;
52 // save 2+load/dump
53 SCM r2 = 0;
54 // continuation
55 SCM r3 = 0;
56
57 enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TREF, TSPECIAL, TSTRING, TSYMBOL, TVALUES, TVECTOR, TBROKEN_HEART};
58
59 struct scm {
60   enum type_t type;
61   SCM car;
62   SCM cdr;
63 };
64
65 struct function {
66   int (*function) (void);
67   int arity;
68   char *name;
69 };
70
71 //FIXME
72 char *foobar = 0;
73
74 #if __GNUC__
75 struct scm *g_cells = 0;
76 struct scm *g_news = 0;
77 #else
78 struct scm *g_cells = foobar;
79 struct scm *g_news = foobar;
80 #endif
81
82 struct scm scm_nil = {TSPECIAL, "()",0};
83 struct scm scm_f = {TSPECIAL, "#f",0};
84 struct scm scm_t = {TSPECIAL, "#t",0};
85 struct scm scm_dot = {TSPECIAL, ".",0};
86 struct scm scm_arrow = {TSPECIAL, "=>",0};
87 struct scm scm_undefined = {TSPECIAL, "*undefined*",0};
88 struct scm scm_unspecified = {TSPECIAL, "*unspecified*",0};
89 struct scm scm_closure = {TSPECIAL, "*closure*",0};
90 struct scm scm_circular = {TSPECIAL, "*circular*",0};
91 struct scm scm_begin = {TSPECIAL, "*begin*",0};
92
93 struct scm scm_symbol_dot = {TSYMBOL, "*dot*",0};
94 struct scm scm_symbol_lambda = {TSYMBOL, "lambda",0};
95 struct scm scm_symbol_begin = {TSYMBOL, "begin",0};
96 struct scm scm_symbol_if = {TSYMBOL, "if",0};
97 struct scm scm_symbol_quote = {TSYMBOL, "quote",0};
98 struct scm scm_symbol_set_x = {TSYMBOL, "set!",0};
99
100 struct scm scm_symbol_sc_expand = {TSYMBOL, "sc-expand",0};
101 struct scm scm_symbol_macro_expand = {TSYMBOL, "macro-expand",0};
102 struct scm scm_symbol_sc_expander_alist = {TSYMBOL, "*sc-expander-alist*",0};
103
104 struct scm scm_symbol_call_with_values = {TSYMBOL, "call-with-values",0};
105 struct scm scm_call_with_current_continuation = {TSPECIAL, "*call/cc*",0};
106 struct scm scm_symbol_call_with_current_continuation = {TSYMBOL, "call-with-current-continuation",0};
107 struct scm scm_symbol_current_module = {TSYMBOL, "current-module",0};
108 struct scm scm_symbol_primitive_load = {TSYMBOL, "primitive-load",0};
109 struct scm scm_symbol_read_input_file = {TSYMBOL, "read-input-file",0};
110 struct scm scm_symbol_write = {TSYMBOL, "write",0};
111 struct scm scm_symbol_display = {TSYMBOL, "display",0};
112
113 struct scm scm_symbol_throw = {TSYMBOL, "throw",0};
114 struct scm scm_symbol_not_a_pair = {TSYMBOL, "not-a-pair",0};
115 struct scm scm_symbol_system_error = {TSYMBOL, "system-error",0};
116 struct scm scm_symbol_wrong_number_of_args = {TSYMBOL, "wrong-number-of-args",0};
117 struct scm scm_symbol_wrong_type_arg = {TSYMBOL, "wrong-type-arg",0};
118 struct scm scm_symbol_unbound_variable = {TSYMBOL, "unbound-variable",0};
119
120 struct scm scm_symbol_argv = {TSYMBOL, "%argv",0};
121 struct scm scm_symbol_mes_prefix = {TSYMBOL, "%prefix",0};
122 struct scm scm_symbol_mes_version = {TSYMBOL, "%version",0};
123
124 struct scm scm_symbol_car = {TSYMBOL, "car",0};
125 struct scm scm_symbol_cdr = {TSYMBOL, "cdr",0};
126 struct scm scm_symbol_null_p = {TSYMBOL, "null?",0};
127 struct scm scm_symbol_eq_p = {TSYMBOL, "eq?",0};
128 struct scm scm_symbol_cons = {TSYMBOL, "cons",0};
129
130 struct scm scm_vm_evlis = {TSPECIAL, "*vm-evlis*",0};
131 struct scm scm_vm_evlis2 = {TSPECIAL, "*vm-evlis2*",0};
132 struct scm scm_vm_evlis3 = {TSPECIAL, "*vm-evlis3*",0};
133 struct scm scm_vm_apply = {TSPECIAL, "core:apply",0};
134 struct scm scm_vm_apply2 = {TSPECIAL, "*vm-apply2*",0};
135 struct scm scm_vm_eval = {TSPECIAL, "core:eval",0};
136
137 //FIXED_PRIMITIVES
138 struct scm scm_vm_eval_car = {TSPECIAL, "*vm-eval-car*",0};
139 struct scm scm_vm_eval_cdr = {TSPECIAL, "*vm-eval-cdr*",0};
140 struct scm scm_vm_eval_cons = {TSPECIAL, "*vm-eval-cons*",0};
141 struct scm scm_vm_eval_null_p = {TSPECIAL, "*vm-eval-null-p*",0};
142
143 struct scm scm_vm_eval_set_x = {TSPECIAL, "*vm-eval-set!*",0};
144 struct scm scm_vm_eval_macro = {TSPECIAL, "*vm-eval-macro*",0};
145 struct scm scm_vm_eval_check_func = {TSPECIAL, "*vm-eval-check-func*",0};
146 struct scm scm_vm_eval2 = {TSPECIAL, "*vm-eval2*",0};
147 struct scm scm_vm_macro_expand = {TSPECIAL, "core:macro-expand",0};
148 struct scm scm_vm_begin = {TSPECIAL, "*vm-begin*",0};
149 struct scm scm_vm_begin_read_input_file = {TSPECIAL, "*vm-begin-read-input-file*",0};
150 struct scm scm_vm_begin2 = {TSPECIAL, "*vm-begin2*",0};
151 struct scm scm_vm_if = {TSPECIAL, "*vm-if*",0};
152 struct scm scm_vm_if_expr = {TSPECIAL, "*vm-if-expr*",0};
153 struct scm scm_vm_call_with_values2 = {TSPECIAL, "*vm-call-with-values2*",0};
154 struct scm scm_vm_call_with_current_continuation2 = {TSPECIAL, "*vm-call-with-current-continuation2*",0};
155 struct scm scm_vm_return = {TSPECIAL, "*vm-return*",0};
156
157 struct scm scm_symbol_gnuc = {TSYMBOL, "%gnuc",0};
158 struct scm scm_symbol_mesc = {TSYMBOL, "%mesc",0};
159
160 struct scm scm_test = {TSYMBOL, "test",0};
161
162 #include "mini-mes.symbols.h"
163
164 SCM tmp;
165 SCM tmp_num;
166 SCM tmp_num2;
167
168 struct function g_functions[200];
169 int g_function = 0;
170
171 #include "mini-gc.h"
172 // #include "lib.h"
173 // #include "math.h"
174 #include "mini-mes.h"
175 // #include "posix.h"
176 // #include "reader.h"
177 #include "mini-vector.h"
178
179
180 #define TYPE(x) (g_cells[x].type)
181
182 #define CAR(x) g_cells[x].car
183 #define LENGTH(x) g_cells[x].car
184 #define REF(x) g_cells[x].car
185 #define STRING(x) g_cells[x].car
186
187 #define CDR(x) g_cells[x].cdr
188 #define CLOSURE(x) g_cells[x].cdr
189 #define CONTINUATION(x) g_cells[x].cdr
190
191 #define FUNCTION(x) g_functions[g_cells[x].cdr]
192 #define MACRO(x) g_cells[x].cdr
193 #define VALUE(x) g_cells[x].cdr
194 #define VECTOR(x) g_cells[x].cdr
195
196 #define NTYPE(x) g_news[x].type
197
198 #define NCAR(x) g_news[x].car
199 #define NLENGTH(x) g_news[x].car
200
201 #define NCDR(x) g_news[x].cdr
202 #define NVALUE(x) g_news[x].cdr
203 #define NVECTOR(x) g_news[x].cdr
204
205 #define MAKE_CHAR(n) make_cell_ (tmp_num_ (TCHAR), 0, tmp_num2_ (n))
206 #define MAKE_CONTINUATION(n) make_cell_ (tmp_num_ (TCONTINUATION), n, g_stack)
207 #define MAKE_NUMBER(n) make_cell_ (tmp_num_ (TNUMBER), 0, tmp_num2_ (n))
208 #define MAKE_REF(n) make_cell_ (tmp_num_ (TREF), n, 0)
209
210 #define CAAR(x) CAR (CAR (x))
211 #define CADR(x) CAR (CDR (x))
212 #define CDAR(x) CDR (CAR (x))
213 #define CDDR(x) CDR (CDR (x))
214 #define CADAR(x) CAR (CDR (CAR (x)))
215 #define CADDR(x) CAR (CDR (CDR (x)))
216 #define CDADAR(x) CAR (CDR (CAR (CDR (x))))
217
218 #define MAKE_STRING(x) make_cell_ (tmp_num_ (TSTRING), x, 0)
219
220 SCM
221 alloc (int n)
222 {
223   assert (g_free + n < ARENA_SIZE);
224   SCM x = g_free;
225   g_free += n;
226   return x;
227 }
228
229 #define DEBUG 0
230
231 SCM
232 tmp_num_ (int x)
233 {
234   VALUE (tmp_num) = x;
235   return tmp_num;
236 }
237
238 SCM
239 tmp_num2_ (int x)
240 {
241   VALUE (tmp_num2) = x;
242   return tmp_num2;
243 }
244
245 SCM
246 make_cell_ (SCM type, SCM car, SCM cdr)
247 {
248   SCM x = alloc (1);
249   assert (TYPE (type) == TNUMBER);
250   TYPE (x) = VALUE (type);
251   if (VALUE (type) == TCHAR || VALUE (type) == TNUMBER) {
252     if (car) CAR (x) = CAR (car);
253     if (cdr) CDR(x) = CDR(cdr);
254   }
255   else if (VALUE (type) == TFUNCTION) {
256     if (car) CAR (x) = car;
257     if (cdr) CDR(x) = CDR(cdr);
258   }
259   else {
260     CAR (x) = car;
261     CDR(x) = cdr;
262   }
263   return x;
264 }
265
266
267 SCM
268 make_symbol_ (SCM s) ///((internal))
269 {
270   VALUE (tmp_num) = TSYMBOL;
271   SCM x = make_cell_ (tmp_num, s, 0);
272   g_symbols = cons (x, g_symbols);
273   return x;
274 }
275
276 SCM
277 lookup_symbol_ (SCM s)
278 {
279   SCM x = g_symbols;
280   while (x) {
281     //if (list_of_char_equal_p (STRING (car (x)), s) == cell_t) break;
282     if (list_of_char_equal_p (STRING (car (x)), s) == cell_t) goto dun;
283     x = cdr (x);
284   }
285  dun:
286   if (x) x = car (x);
287   if (!x) x = make_symbol_ (s);
288   return x;
289 }
290
291 SCM
292 list_of_char_equal_p (SCM a, SCM b) ///((internal))
293 {
294   while (a != cell_nil && b != cell_nil && VALUE (car (a)) == VALUE (car (b))) {
295     assert (TYPE (car (a)) == TCHAR);
296     assert (TYPE (car (b)) == TCHAR);
297     a = cdr (a);
298     b = cdr (b);
299   }
300   return (a == cell_nil && b == cell_nil) ? cell_t : cell_f;
301 }
302
303 SCM
304 type_ (SCM x)
305 {
306   return MAKE_NUMBER (TYPE (x));
307 }
308
309 SCM
310 car_ (SCM x)
311 {
312   return (TYPE (x) != TCONTINUATION
313           && (TYPE (CAR (x)) == TPAIR // FIXME: this is weird
314               || TYPE (CAR (x)) == TREF
315               || TYPE (CAR (x)) == TSPECIAL
316               || TYPE (CAR (x)) == TSYMBOL
317               || TYPE (CAR (x)) == TSTRING)) ? CAR (x) : MAKE_NUMBER (CAR (x));
318 }
319
320 SCM
321 cdr_ (SCM x)
322 {
323   return (TYPE (CDR (x)) == TPAIR
324           || TYPE (CDR (x)) == TREF
325           || TYPE (CAR (x)) == TSPECIAL
326           || TYPE (CDR (x)) == TSYMBOL
327           || TYPE (CDR (x)) == TSTRING) ? CDR (x) : MAKE_NUMBER (CDR (x));
328 }
329
330 SCM
331 arity_ (SCM x)
332 {
333   assert (TYPE (x) == TFUNCTION);
334   return MAKE_NUMBER (FUNCTION (x).arity);
335 }
336
337 SCM
338 cons (SCM x, SCM y)
339 {
340   VALUE (tmp_num) = TPAIR;
341   return make_cell_ (tmp_num, x, y);
342 }
343
344 SCM
345 car (SCM x)
346 {
347 #if MES_MINI
348   //Nyacc
349   //assert ("!car");
350 #else
351   if (TYPE (x) != TPAIR) error (cell_symbol_not_a_pair, cons (x, cell_symbol_car));
352 #endif
353   return CAR (x);
354 }
355
356 SCM
357 cdr (SCM x)
358 {
359 #if MES_MINI
360   //Nyacc
361   //assert ("!cdr");
362 #else
363   if (TYPE (x) != TPAIR) error (cell_symbol_not_a_pair, cons (x, cell_symbol_cdr));
364 #endif
365   return CDR(x);
366 }
367
368 SCM
369 list (SCM x) ///((arity . n))
370 {
371   return x;
372 }
373
374 SCM
375 null_p (SCM x)
376 {
377   return x == cell_nil ? cell_t : cell_f;
378 }
379
380 SCM
381 eq_p (SCM x, SCM y)
382 {
383   return (x == y
384           || ((TYPE (x) == TKEYWORD && TYPE (y) == TKEYWORD
385                && STRING (x) == STRING (y)))
386           || (TYPE (x) == TCHAR && TYPE (y) == TCHAR
387               && VALUE (x) == VALUE (y))
388           || (TYPE (x) == TNUMBER && TYPE (y) == TNUMBER
389               && VALUE (x) == VALUE (y)))
390     ? cell_t : cell_f;
391 }
392
393 SCM
394 values (SCM x) ///((arity . n))
395 {
396   SCM v = cons (0, x);
397   TYPE (v) = TVALUES;
398   return v;
399 }
400
401 SCM
402 acons (SCM key, SCM value, SCM alist)
403 {
404   return cons (cons (key, value), alist);
405 }
406
407 SCM
408 length (SCM x)
409 {
410   int n = 0;
411   while (x != cell_nil)
412     {
413       n++;
414       if (TYPE (x) != TPAIR) return MAKE_NUMBER (-1);
415       x = cdr (x);
416     }
417   return MAKE_NUMBER (n);
418 }
419
420 SCM
421 error (SCM key, SCM x)
422 {
423   SCM throw;
424   if ((throw = assq_ref_env (cell_symbol_throw, r0)) != cell_undefined)
425     return apply (throw, cons (key, cons (x, cell_nil)), r0);
426   display_error_ (key);
427   eputs (": ");
428   display_ (x);
429   eputs ("\n");
430   assert (0);
431 }
432
433 SCM
434 assert_defined (SCM x, SCM e) ///((internal))
435 {
436   if (e != cell_undefined) return e;
437   // error (cell_symbol_unbound_variable, x);
438   eputs ("unbound variable: ");
439   display_error_ (x);
440   eputs ("\n");
441   exit (33);
442   return e;
443 }
444
445 SCM
446 cstring_to_list (char const* s)
447 {
448   char *x = s;
449   SCM p = cell_nil;
450   int i = strlen (s);
451   while (i--)
452     {
453       p = cons (MAKE_CHAR (s[i]), p);
454       x++;
455     }
456   return p;
457 }
458
459 SCM
460 check_formals (SCM f, SCM formals, SCM args) ///((internal))
461 {
462   int flen = (TYPE (formals) == TNUMBER) ? VALUE (formals) : VALUE (length (formals));
463   int alen = VALUE (length (args));
464   if (alen != flen && alen != -1 && flen != -1)
465     {
466       // FIXME
467       //char buf[1024];
468       char buf = "TODO:check_formals";
469       // sprintf (buf, "apply: wrong number of arguments; expected: %d, got: %d: ", flen, alen);
470       eputs ("apply: wrong number of arguments; expected: ");
471       eputs (itoa (flen));
472       eputs (", got: ");
473       eputs (itoa (alen));
474       eputs ("\n");
475       display_error_ (f);
476       SCM e = MAKE_STRING (cstring_to_list (buf));
477       return error (cell_symbol_wrong_number_of_args, cons (e, f));
478     }
479   return cell_unspecified;
480 }
481
482 SCM
483 check_apply (SCM f, SCM e) ///((internal))
484 {
485   //char const* type = 0;
486   char* type = 0;
487   if (f == cell_f || f == cell_t) type = "bool";
488   if (f == cell_nil) type = "nil";
489   if (f == cell_unspecified) type = "*unspecified*";
490   if (f == cell_undefined) type = "*undefined*";
491   if (TYPE (f) == TCHAR) type = "char";
492   if (TYPE (f) == TNUMBER) type = "number";
493   if (TYPE (f) == TSTRING) type = "string";
494
495   if (type)
496     {
497       //FIXME
498       //char buf[1024];
499       char buf = "TODO:check_apply";
500       // sprintf (buf, "cannot apply: %s:", type);
501       // fprintf (stderr, " [");
502       // display_error_ (e);
503       // fprintf (stderr, "]\n");
504       eputs ("cannot apply: ");
505       eputs (type);
506       eputs ("[");
507       display_error_ (e);
508       eputs ("]\n");
509       SCM e = MAKE_STRING (cstring_to_list (buf));
510       return error (cell_symbol_wrong_type_arg, cons (e, f));
511     }
512   return cell_unspecified;
513 }
514
515 SCM
516 gc_push_frame () ///((internal))
517 {
518   SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cell_nil))));
519   g_stack = cons (frame, g_stack);
520   return g_stack;
521 }
522
523 SCM
524 apply (SCM f, SCM x, SCM a) ///((internal))
525 {
526   push_cc (cons (f, x), cell_unspecified, r0, cell_unspecified);
527   r3 = cell_vm_apply;
528   return eval_apply ();
529 }
530
531 SCM
532 append2 (SCM x, SCM y)
533 {
534   if (x == cell_nil) return y;
535   assert (TYPE (x) == TPAIR);
536   return cons (car (x), append2 (cdr (x), y));
537 }
538
539 SCM
540 pairlis (SCM x, SCM y, SCM a)
541 {
542   if (x == cell_nil)
543     return a;
544   if (TYPE (x) != TPAIR)
545     return cons (cons (x, y), a);
546   return cons (cons (car (x), car (y)),
547                pairlis (cdr (x), cdr (y), a));
548 }
549
550 SCM display_ (SCM);
551
552 SCM
553 call (SCM fn, SCM x)
554 {
555   if ((FUNCTION (fn).arity > 0 || FUNCTION (fn).arity == -1)
556       && x != cell_nil && TYPE (CAR (x)) == TVALUES)
557     x = cons (CADAR (x), CDR (x));
558   if ((FUNCTION (fn).arity > 1 || FUNCTION (fn).arity == -1)
559       && x != cell_nil && TYPE (CDR (x)) == TPAIR && TYPE (CADR (x)) == TVALUES)
560     x = cons (CAR (x), cons (CDADAR (x), CDR (x)));
561   switch (FUNCTION (fn).arity)
562     {
563     case 0: {return (FUNCTION (fn).function) ();}
564     case 1: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (CAR (x));}
565     case 2: {return ((SCM(*)(SCM,SCM))(FUNCTION (fn).function)) (CAR (x), CADR (x));}
566     case 3: {return ((SCM(*)(SCM,SCM,SCM))(FUNCTION (fn).function)) (CAR (x), CADR (x), car (CDDR (x)));}
567     case -1: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);}
568     default: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);}
569     }
570
571   return cell_unspecified;
572 }
573
574 SCM
575 assq (SCM x, SCM a)
576 {
577   //FIXME: eq_p
578   //while (a != cell_nil && eq_p (x, CAAR (a)) == cell_f) a = CDR (a);
579   while (a != cell_nil && x != CAAR (a)) a = CDR (a);
580   return a != cell_nil ? car (a) : cell_f;
581 }
582
583 SCM
584 assq_ref_env (SCM x, SCM a)
585 {
586   x = assq (x, a);
587   if (x == cell_f) return cell_undefined;
588   return cdr (x);
589 }
590
591 SCM
592 set_car_x (SCM x, SCM e)
593 {
594   assert (TYPE (x) == TPAIR);
595   CAR (x) = e;
596   return cell_unspecified;
597 }
598
599 SCM
600 set_cdr_x (SCM x, SCM e)
601 {
602   //if (TYPE (x) != TPAIR) error (cell_symbol_not_a_pair, cons (x, cell_set_cdr_x));
603   CDR (x) = e;
604   return cell_unspecified;
605 }
606
607 SCM
608 set_env_x (SCM x, SCM e, SCM a)
609 {
610   SCM p = assert_defined (x, assq (x, a));
611   //if (TYPE (p) != TPAIR)  error (cell_symbol_not_a_pair, cons (p, x));
612   return set_cdr_x (p, e);
613 }
614
615 SCM
616 call_lambda (SCM e, SCM x, SCM aa, SCM a) ///((internal))
617 {
618   SCM cl = cons (cons (cell_closure, x), x);
619   cl = cons (cons (cell_closure, x), x);
620   r1 = e;
621   r0 = cl;
622   return cell_unspecified;
623 }
624
625 SCM
626 make_closure_ (SCM args, SCM body, SCM a) ///((internal))
627 {
628   return make_cell_ (tmp_num_ (TCLOSURE), cell_f, cons (cons (cell_circular, a), cons (args, body)));
629 }
630
631 SCM
632 lookup_macro_ (SCM x, SCM a) ///((internal))
633 {
634   if (TYPE (x) != TSYMBOL) return cell_f;
635   SCM m = assq_ref_env (x, a);
636  if (TYPE (m) == TMACRO) return MACRO (m);
637   return cell_f;
638 }
639
640 SCM
641 push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal))
642 {
643   SCM x = r3;
644   r3 = c;
645   r2 = p2;
646   gc_push_frame ();
647   r1 = p1;
648   r0 = a;
649   r3 = x;
650   return cell_unspecified;
651 }
652
653 SCM gc_pop_frame (); //((internal))
654
655 SCM
656 eval_apply ()
657 {
658  eval_apply:
659 #if MES_GC
660   if (g_free + GC_SAFETY > ARENA_SIZE)
661     gc_pop_frame (gc (gc_push_frame ()));
662 #endif
663   switch (r3)
664     {
665     case cell_vm_evlis: goto evlis;
666     case cell_vm_evlis2: goto evlis2;
667     case cell_vm_evlis3: goto evlis3;
668     case cell_vm_apply: goto apply;
669     case cell_vm_apply2: goto apply2;
670     case cell_vm_eval: goto eval;
671 #if FIXED_PRIMITIVES
672     case cell_vm_eval_car: goto eval_car;
673     case cell_vm_eval_cdr: goto eval_cdr;
674     case cell_vm_eval_cons: goto eval_cons;
675     case cell_vm_eval_null_p: goto eval_null_p;
676 #endif
677     case cell_vm_eval_set_x: goto eval_set_x;
678     case cell_vm_eval_macro: goto eval_macro;
679     case cell_vm_eval_check_func: goto eval_check_func;
680     case cell_vm_eval2: goto eval2;
681     case cell_vm_macro_expand: goto macro_expand;
682     case cell_vm_begin: goto begin;
683     case cell_vm_begin_read_input_file: goto begin_read_input_file;
684     case cell_vm_begin2: goto begin2;
685     case cell_vm_if: goto vm_if;
686     case cell_vm_if_expr: goto if_expr;
687     case cell_vm_call_with_current_continuation2: goto call_with_current_continuation2;
688     case cell_vm_call_with_values2: goto call_with_values2;
689     case cell_vm_return: goto vm_return;
690     case cell_unspecified: return r1;
691     default: assert (0);
692     }
693
694   SCM x = cell_nil;
695   SCM y = cell_nil;
696  evlis:
697   if (r1 == cell_nil) goto vm_return;
698   if (TYPE (r1) != TPAIR) goto eval;
699   push_cc (car (r1), r1, r0, cell_vm_evlis2);
700   goto eval;
701  evlis2:
702   push_cc (cdr (r2), r1, r0, cell_vm_evlis3);
703   goto evlis;
704  evlis3:
705   r1 = cons (r2, r1);
706   goto vm_return;
707
708  apply:
709   switch (TYPE (car (r1)))
710     {
711     case TFUNCTION: {
712       check_formals (car (r1), MAKE_NUMBER (FUNCTION (car (r1)).arity), cdr (r1));
713       r1 = call (car (r1), cdr (r1)); /// FIXME: move into eval_apply
714       goto vm_return;
715     }
716     case TCLOSURE:
717       {
718         SCM cl = CLOSURE (CAR (r1));
719         SCM formals = CADR (cl);
720         SCM body = CDDR (cl);
721         SCM aa = CDAR (cl);
722         aa = CDR (aa);
723         check_formals (CAR (r1), formals, CDR (r1));
724         SCM p = pairlis (formals, CDR (r1), aa);
725         call_lambda (body, p, aa, r0);
726         goto begin;
727       }
728       case TCONTINUATION:
729         {
730           x = r1;
731           g_stack = CONTINUATION (CAR (r1));
732           gc_pop_frame ();
733           r1 = CADR (x);
734           goto eval_apply;
735         }
736     case TSPECIAL:
737       {
738         switch (car (r1))
739           {
740           case cell_vm_apply:
741             {
742               push_cc (cons (CADR (r1), CADDR (r1)), r1, r0, cell_vm_return);
743               goto apply;
744             }
745           case cell_vm_eval:
746             {
747               push_cc (CADR (r1), r1, CADDR (r1), cell_vm_return);
748               goto eval;
749             }
750           case cell_call_with_current_continuation:
751             {
752               r1 = cdr (r1);
753               goto call_with_current_continuation;
754             }
755           default: check_apply (cell_f, car (r1));
756           }
757       }
758     case TSYMBOL:
759       {
760         if (car (r1) == cell_symbol_call_with_values)
761           {
762             r1 = cdr (r1);
763             goto call_with_values;
764           }
765         if (car (r1) == cell_symbol_current_module)
766           {
767             r1 = r0;
768             goto vm_return;
769           }
770         break;
771       }
772     case TPAIR:
773       {
774         switch (CAAR (r1))
775           {
776           case cell_symbol_lambda:
777             {
778               SCM formals = CADR (car (r1));
779               SCM body = CDDR (car (r1));
780               SCM p = pairlis (formals, cdr (r1), r0);
781               check_formals (r1, formals, cdr (r1));
782               call_lambda (body, p, p, r0);
783               goto begin;
784             }
785           }
786       }
787     }
788   push_cc (car (r1), r1, r0, cell_vm_apply2);
789   goto eval;
790  apply2:
791   check_apply (r1, car (r2));
792   r1 = cons (r1, cdr (r2));
793   goto apply;
794
795  eval:
796   switch (TYPE (r1))
797     {
798     case TPAIR:
799       {
800         switch (car (r1))
801           {
802 #if FIXED_PRIMITIVES
803           case cell_symbol_car:
804             {
805               push_cc (CADR (r1), r1, r0, cell_vm_eval_car); goto eval;
806             eval_car:
807               x = r1; gc_pop_frame (); r1 = car (x); goto eval_apply;
808             }
809           case cell_symbol_cdr:
810             {
811               push_cc (CADR (r1), r1, r0, cell_vm_eval_cdr); goto eval;
812             eval_cdr:
813               x = r1; gc_pop_frame (); r1 = cdr (x); goto eval_apply;
814             }
815           case cell_symbol_cons: {
816             push_cc (CDR (r1), r1, r0, cell_vm_eval_cons); goto evlis;
817             eval_cons:
818             x = r1;
819             gc_pop_frame ();
820             r1 = cons (CAR (x), CADR (x));
821             goto eval_apply;
822           }
823           case cell_symbol_null_p:
824             {
825               push_cc (CADR (r1), r1, r0, cell_vm_eval_null_p);
826               goto eval;
827             eval_null_p:
828               x = r1; gc_pop_frame (); r1 = null_p (x); goto eval_apply;
829             }
830 #endif // FIXED_PRIMITIVES
831           case cell_symbol_quote:
832             {
833               x = r1; gc_pop_frame (); r1 = CADR (x); goto eval_apply;
834             }
835           case cell_symbol_begin: goto begin;
836           case cell_symbol_lambda:
837             {
838               r1 = make_closure_ (CADR (r1), CDDR (r1), assq (cell_closure, r0));
839               goto vm_return;
840             }
841           case cell_symbol_if: {r1=cdr (r1); goto vm_if;}
842           case cell_symbol_set_x:
843             {
844               push_cc (car (CDDR (r1)), r1, r0, cell_vm_eval_set_x);
845               goto eval;
846             eval_set_x:
847               x = r2;
848               r1 = set_env_x (CADR (x), r1, r0);
849               goto vm_return;
850             }
851           case cell_vm_macro_expand:
852             {
853               push_cc (CADR (r1), r1, r0, cell_vm_return);
854               goto macro_expand;
855             }
856           default: {
857             push_cc (r1, r1, r0, cell_vm_eval_macro);
858             goto macro_expand;
859             eval_macro:
860             x = r2;
861             if (r1 != r2)
862               {
863                 if (TYPE (r1) == TPAIR)
864                   {
865                     set_cdr_x (r2, cdr (r1));
866                     set_car_x (r2, car (r1));
867                   }
868                 goto eval;
869               }
870             push_cc (car (r1), r1, r0, cell_vm_eval_check_func); goto eval;
871             eval_check_func:
872             push_cc (CDR (r2), r2, r0, cell_vm_eval2); goto evlis;
873             eval2:
874             r1 = cons (car (r2), r1);
875             goto apply;
876           }
877           }
878       }
879     case TSYMBOL:
880       {
881         r1 = assert_defined (r1, assq_ref_env (r1, r0));
882         goto vm_return;
883       }
884     default: {goto vm_return;}
885     }
886
887   SCM macro;
888   SCM expanders;
889  macro_expand:
890   if (TYPE (r1) == TPAIR
891       && (macro = lookup_macro_ (car (r1), r0)) != cell_f)
892     {
893       r1 = cons (macro, CDR (r1));
894       goto apply;
895     }
896   else if (TYPE (r1) == TPAIR
897            && TYPE (CAR (r1)) == TSYMBOL
898            && ((expanders = assq_ref_env (cell_symbol_sc_expander_alist, r0)) != cell_undefined)
899            && ((macro = assq (CAR (r1), expanders)) != cell_f))
900     {
901       SCM sc_expand = assq_ref_env (cell_symbol_macro_expand, r0);
902       if (sc_expand != cell_undefined && sc_expand != cell_f)
903         {
904           r1 = cons (sc_expand, cons (r1, cell_nil));
905           goto apply;
906         }
907     }
908   goto vm_return;
909  begin:
910   x = cell_unspecified;
911   while (r1 != cell_nil) {
912     if (TYPE (r1) == TPAIR && TYPE (CAR (r1)) == TPAIR)
913       {
914         if (CAAR (r1) == cell_symbol_begin)
915           r1 = append2 (CDAR (r1), cdr (r1));
916         else if (CAAR (r1) == cell_symbol_primitive_load)
917           {
918             push_cc (cons (cell_symbol_read_input_file, cell_nil), r1, r0, cell_vm_begin_read_input_file);
919             goto apply;
920           begin_read_input_file:
921             r1 = append2 (r1, cdr (r2));
922           }
923       }
924     if (CDR (r1) == cell_nil)
925       {
926         r1 = car (r1);
927         goto eval;
928       }
929     push_cc (CAR (r1), r1, r0, cell_vm_begin2);
930     goto eval;
931   begin2:
932     x = r1;
933     r1 = CDR (r2);
934   }
935   r1 = x;
936   goto vm_return;
937
938  vm_if:
939   push_cc (car (r1), r1, r0, cell_vm_if_expr);
940   goto eval;
941  if_expr:
942   x = r1;
943   r1 = r2;
944   if (x != cell_f)
945     {
946       r1 = CADR (r1);
947       goto eval;
948     }
949   if (CDDR (r1) != cell_nil)
950     {
951       r1 = car (CDDR (r1));
952       goto eval;
953     }
954   r1 = cell_unspecified;
955   goto vm_return;
956
957  call_with_current_continuation:
958   gc_push_frame ();
959 #if __GNUC__
960   // FIXME GCC
961   x = MAKE_CONTINUATION (g_continuations++);
962 #else
963   x = MAKE_CONTINUATION (g_continuations);
964   g_continuations++;
965 #endif
966   gc_pop_frame ();
967   push_cc (cons (car (r1), cons (x, cell_nil)), x, r0, cell_vm_call_with_current_continuation2);
968   goto apply;
969  call_with_current_continuation2:
970   CONTINUATION (r2) = g_stack;
971   goto vm_return;
972
973  call_with_values:
974   push_cc (cons (car (r1), cell_nil), r1, r0, cell_vm_call_with_values2);
975   goto apply;
976  call_with_values2:
977   if (TYPE (r1) == TVALUES)
978     r1 = CDR (r1);
979   r1 = cons (CADR (r2), r1);
980   goto apply;
981
982  vm_return:
983   x = r1;
984   gc_pop_frame ();
985   r1 = x;
986   goto eval_apply;
987 }
988
989 SCM
990 gc_peek_frame () ///((internal))
991 {
992   SCM frame = CAR (g_stack);
993   r1 = CAR (frame);
994   r2 = CADR (frame);
995   r3 = CAR (CDDR (frame));
996   r0 = CADR (CDDR (frame));
997   return frame;
998 }
999
1000 SCM
1001 gc_pop_frame () ///((internal))
1002 {
1003   SCM frame = gc_peek_frame (g_stack);
1004   g_stack = cdr (g_stack);
1005   return frame;
1006 }
1007
1008 SCM
1009 mes_g_stack (SCM a) ///((internal))
1010 {
1011   r0 = a;
1012   r1 = MAKE_CHAR (0);
1013   r2 = MAKE_CHAR (0);
1014   r3 = MAKE_CHAR (0);
1015   g_stack = cons (cell_nil, cell_nil);
1016   return r0;
1017 }
1018
1019 //\f Environment setup
1020 SCM
1021 make_tmps (struct scm* cells)
1022 {
1023   tmp = g_free++;
1024   cells[tmp].type = TCHAR;
1025   tmp_num = g_free++;
1026   cells[tmp_num].type = TNUMBER;
1027   tmp_num2 = g_free++;
1028   cells[tmp_num2].type = TNUMBER;
1029   return 0;
1030 }
1031
1032 //\f Posix
1033 int
1034 ungetchar (int c)
1035 {
1036   return ungetc (c, g_stdin);
1037 }
1038
1039 int
1040 peekchar ()
1041 {
1042   int c = getchar ();
1043   ungetchar (c);
1044   return c;
1045 }
1046
1047 SCM
1048 peek_byte ()
1049 {
1050   return MAKE_NUMBER (peekchar ());
1051 }
1052
1053 SCM
1054 read_byte ()
1055 {
1056   return MAKE_NUMBER (getchar ());
1057 }
1058
1059 SCM
1060 unread_byte (SCM i)
1061 {
1062   ungetchar (VALUE (i));
1063   return i;
1064 }
1065
1066 SCM
1067 write_byte (SCM x) ///((arity . n))
1068 {
1069   SCM c = car (x);
1070   SCM p = cdr (x);
1071   int fd = 1;
1072   if (TYPE (p) == TPAIR && TYPE (car (p)) == TNUMBER) fd = VALUE (car (p));
1073   //FILE *f = fd == 1 ? stdout : stderr;
1074 #if __GNUC__
1075   assert (TYPE (c) == TNUMBER || TYPE (c) == TCHAR);
1076 #endif
1077   //  fputc (VALUE (c), f);
1078   char cc = VALUE (c);
1079   write (1, (char*)&cc, fd);
1080   return c;
1081 }
1082
1083 char string_to_cstring_buf[1024];
1084 char const*
1085 string_to_cstring (SCM s)
1086 {
1087   //static char buf[1024];
1088   //char *p = buf;
1089   char *p = string_to_cstring_buf;
1090   s = STRING(s);
1091   while (s != cell_nil)
1092     {
1093       *p++ = VALUE (car (s));
1094       s = cdr (s);
1095     }
1096   *p = 0;
1097   //return buf;
1098   return string_to_cstring_buf;
1099 }
1100
1101 SCM
1102 getenv_ (SCM s) ///((name . "getenv"))
1103 {
1104 #if 0
1105   char *p = getenv (string_to_cstring (s));
1106   return p ? MAKE_STRING (cstring_to_list (p)) : cell_f;
1107 #else
1108   return cell_t;
1109 #endif
1110 }
1111
1112 SCM
1113 open_input_file (SCM file_name)
1114 {
1115   return MAKE_NUMBER (open (string_to_cstring (file_name), O_RDONLY));
1116   // char *s = string_to_cstring (file_name);
1117   // int x = open (s, 0);
1118   // return MAKE_NUMBER (x);
1119 }
1120
1121 SCM
1122 current_input_port ()
1123 {
1124   return MAKE_NUMBER (g_stdin);
1125 }
1126
1127 SCM
1128 set_current_input_port (SCM port)
1129 {
1130   g_stdin = VALUE (port) ? VALUE (port) : STDIN;
1131   return current_input_port ();
1132 }
1133
1134 SCM
1135 force_output (SCM p) ///((arity . n))
1136 {
1137 #if 0
1138   //FIXME
1139   int fd = 1;
1140   if (TYPE (p) == TPAIR && TYPE (car (p)) == TNUMBER) fd = VALUE (car (p));
1141   FILE *f = fd == 1 ? stdout : stderr;
1142   fflush (f);
1143 #endif
1144   return cell_unspecified;
1145 }
1146
1147 //\f Math
1148 SCM
1149 greater_p (SCM x) ///((name . ">") (arity . n))
1150 {
1151   int n = INT_MAX;
1152   while (x != cell_nil)
1153     {
1154       assert (TYPE (car (x)) == TNUMBER);
1155       if (VALUE (car (x)) >= n) return cell_f;
1156       n = VALUE (car (x));
1157       x = cdr (x);
1158     }
1159   return cell_t;
1160 }
1161
1162 SCM
1163 less_p (SCM x) ///((name . "<") (arity . n))
1164 {
1165   int n = INT_MIN;
1166   while (x != cell_nil)
1167     {
1168       assert (TYPE (car (x)) == TNUMBER);
1169       if (VALUE (car (x)) <= n) return cell_f;
1170       n = VALUE (car (x));
1171       x = cdr (x);
1172     }
1173   return cell_t;
1174 }
1175
1176 SCM
1177 is_p (SCM x) ///((name . "=") (arity . n))
1178 {
1179   if (x == cell_nil) return cell_t;
1180   assert (TYPE (car (x)) == TNUMBER);
1181   int n = VALUE (car (x));
1182   x = cdr (x);
1183   while (x != cell_nil)
1184     {
1185       if (VALUE (car (x)) != n) return cell_f;
1186       x = cdr (x);
1187     }
1188   return cell_t;
1189 }
1190
1191 SCM
1192 minus (SCM x) ///((name . "-") (arity . n))
1193 {
1194   SCM a = car (x);
1195   assert (TYPE (a) == TNUMBER);
1196   int n = VALUE (a);
1197   x = cdr (x);
1198   if (x == cell_nil)
1199     n = -n;
1200   while (x != cell_nil)
1201     {
1202       assert (TYPE (car (x)) == TNUMBER);
1203 #if __GNUC__
1204       n -= VALUE (car (x));
1205 #else
1206       n = n - VALUE (car (x));
1207 #endif
1208       x = cdr (x);
1209     }
1210   return MAKE_NUMBER (n);
1211 }
1212
1213 SCM
1214 plus (SCM x) ///((name . "+") (arity . n))
1215 {
1216   int n = 0;
1217   while (x != cell_nil)
1218     {
1219       assert (TYPE (car (x)) == TNUMBER);
1220 #if __GNUC__
1221       n += VALUE (car (x));
1222 #else
1223       n = n + VALUE (car (x));
1224 #endif
1225       x = cdr (x);
1226     }
1227   return MAKE_NUMBER (n);
1228 }
1229
1230 SCM
1231 divide (SCM x) ///((name . "/") (arity . n))
1232 {
1233   int n = 1;
1234   if (x != cell_nil) {
1235     assert (TYPE (car (x)) == TNUMBER);
1236     n = VALUE (car (x));
1237     x = cdr (x);
1238   }
1239   while (x != cell_nil)
1240     {
1241       assert (TYPE (car (x)) == TNUMBER);
1242 #if __GNUC__
1243       n /= VALUE (car (x));
1244 #else
1245       n = n / VALUE (car (x));
1246 #endif
1247       x = cdr (x);
1248     }
1249   return MAKE_NUMBER (n);
1250 }
1251
1252 SCM
1253 modulo (SCM a, SCM b)
1254 {
1255   assert (TYPE (a) == TNUMBER);
1256   assert (TYPE (b) == TNUMBER);
1257   int x = VALUE (a);
1258   while (x < 0) x += VALUE (b);
1259   return MAKE_NUMBER (x % VALUE (b));
1260 }
1261
1262 SCM
1263 multiply (SCM x) ///((name . "*") (arity . n))
1264 {
1265   int n = 1;
1266   while (x != cell_nil)
1267     {
1268       assert (TYPE (car (x)) == TNUMBER);
1269 #if __GNUC__
1270       n *= VALUE (car (x));
1271 #else
1272       n = n * VALUE (car (x));
1273 #endif
1274       x = cdr (x);
1275     }
1276   return MAKE_NUMBER (n);
1277 }
1278
1279 SCM
1280 logior (SCM x) ///((arity . n))
1281 {
1282   int n = 0;
1283   while (x != cell_nil)
1284     {
1285       assert (TYPE (car (x)) == TNUMBER);
1286 #if __GNUC__
1287       n |= VALUE (car (x));
1288 #else
1289       n = n | VALUE (car (x));
1290 #endif
1291       x = cdr (x);
1292     }
1293   return MAKE_NUMBER (n);
1294 }
1295
1296 SCM
1297 ash (SCM n, SCM count)
1298 {
1299   assert (TYPE (n) == TNUMBER);
1300   assert (TYPE (count) == TNUMBER);
1301   int cn = VALUE (n);
1302   int ccount = VALUE (count);
1303   return MAKE_NUMBER ((ccount < 0) ? cn >> -ccount : cn << ccount);
1304 }
1305
1306 //\f Lib [rest of]
1307
1308 int g_depth;
1309
1310 SCM
1311 display_helper (SCM x, int cont, char* sep, int fd)
1312 {
1313   fputs (sep, fd);
1314   if (g_depth == 0) return cell_unspecified;
1315   g_depth = g_depth - 1;
1316   
1317   switch (TYPE (x))
1318     {
1319     case TCHAR:
1320       {
1321         fputs ("#\\", fd);
1322         putc (VALUE (x), fd);
1323         break;
1324       }
1325     case TFUNCTION:
1326       {
1327         fputs ("#<procedure ", fd);
1328         char *p = "?";
1329         if (FUNCTION (x).name != 0)
1330           p = FUNCTION (x).name;
1331         fputs (p, fd);
1332         fputs ("[", fd);
1333         fputs (itoa (CDR (x)), fd);
1334         fputs (",", fd);
1335         fputs (itoa (x), fd);
1336         fputs ("]>", fd);
1337         break;
1338       }
1339     case TMACRO:
1340       {
1341         fputs ("#<macro ", fd);
1342         display_helper (cdr (x), cont, "", fd);
1343         fputs (">", fd);
1344         break;
1345       }
1346     case TNUMBER:
1347       {
1348         fputs (itoa (VALUE (x)), fd);
1349         break;
1350       }
1351     case TPAIR:
1352       {
1353         if (!cont) fputs ("(", fd);
1354         if (x && x != cell_nil) fdisplay_ (CAR (x), fd);
1355         if (CDR (x) && TYPE (CDR (x)) == TPAIR)
1356           display_helper (CDR (x), 1, " ", fd);
1357         else if (CDR (x) && CDR (x) != cell_nil)
1358           {
1359             if (TYPE (CDR (x)) != TPAIR)
1360               fputs (" . ", fd);
1361             fdisplay_ (CDR (x), fd);
1362           }
1363         if (!cont) fputs (")", fd);
1364         break;
1365       }
1366     case TSPECIAL:
1367 #if __NYACC__
1368       // FIXME
1369       //{}
1370       {
1371         SCM t = CAR (x);
1372         while (t && t != cell_nil)
1373           {
1374             putc (VALUE (CAR (t)), fd);
1375             t = CDR (t);
1376           }
1377         break;
1378       }
1379 #endif
1380     case TSTRING:
1381 #if __NYACC__
1382       // FIXME
1383       {
1384         SCM t = CAR (x);
1385         while (t && t != cell_nil)
1386           {
1387             putc (VALUE (CAR (t)), fd);
1388             t = CDR (t);
1389           }
1390         break;
1391       }
1392 #endif
1393     case TSYMBOL:
1394       {
1395         SCM t = CAR (x);
1396         while (t && t != cell_nil)
1397           {
1398             putc (VALUE (CAR (t)), fd);
1399             t = CDR (t);
1400           }
1401         break;
1402       }
1403     default:
1404       {
1405         fputs ("<", fd);
1406         fputs (itoa (TYPE (x)), fd);
1407         fputs (":", fd);
1408         fputs (itoa (x), fd);
1409         fputs (">", fd);
1410         break;
1411       }
1412     }
1413   return 0;
1414 }
1415
1416 SCM
1417 display_ (SCM x)
1418 {
1419   g_depth = 5;
1420   return display_helper (x, 0, "", STDOUT);
1421 }
1422
1423 SCM
1424 display_error_ (SCM x)
1425 {
1426   g_depth = 5;
1427   return display_helper (x, 0, "", STDERR);
1428 }
1429
1430 SCM
1431 fdisplay_ (SCM x, int fd) ///((internal))
1432 {
1433   g_depth = 5;
1434   return display_helper (x, 0, "", fd);
1435 }
1436
1437 SCM
1438 exit_ (SCM x) ///((name . "exit"))
1439 {
1440   assert (TYPE (x) == TNUMBER);
1441   exit (VALUE (x));
1442 }
1443
1444 SCM
1445 append (SCM x) ///((arity . n))
1446 {
1447   if (x == cell_nil) return cell_nil;
1448   if (cdr (x) == cell_nil) return car (x);
1449   return append2 (car (x), append (cdr (x)));
1450 }
1451
1452 SCM
1453 xassq (SCM x, SCM a) ///for speed in core only
1454 {
1455   while (a != cell_nil && x != CDAR (a)) a = CDR (a);
1456   return a != cell_nil ? CAR (a) : cell_f;
1457 }
1458
1459 //\f Jam Collector
1460 SCM g_symbol_max;
1461
1462 SCM
1463 gc_init_cells () ///((internal))
1464 {
1465   //return 0;
1466   //g_cells = (scm *)malloc (ARENA_SIZE);
1467   //int size = ARENA_SIZE * sizeof (struct scm);
1468   int size = ARENA_SIZE * 12;
1469 #if MES_GC
1470   size = size * 2;
1471 #endif
1472 #if __GNUC__
1473   arena = (char*)malloc (size);
1474 #else
1475   char *p = 0;
1476   p = malloc (size);
1477   arena = p;
1478 #endif
1479   g_cells = arena;
1480   return 0;
1481   //g_cells = (scm *)malloc (2*ARENA_SIZE*sizeof(scm));
1482
1483   TYPE (0) = TVECTOR;
1484   LENGTH (0) = 1000;
1485   VECTOR (0) = 0;
1486   g_cells++;
1487   TYPE (0) = TCHAR;
1488   VALUE (0) = 'c';
1489   return 0;
1490 }
1491
1492 SCM
1493 gc_init_news () ///((internal))
1494 {
1495   eputs ("gc_init_news\n");
1496   ///g_news = g_cells-1 + ARENA_SIZE;
1497   //g_news = g_cells + ARENA_SIZE * 12 + GC_SAFETY * 6;
1498   char *p = g_cells;
1499   // g_news = g_cells;
1500   int halfway = ARENA_SIZE * 12;
1501   int safety = GC_SAFETY * 12;
1502   safety = safety / 2;
1503   halfway = halfway + safety;
1504   // g_news = g_news + halfway;
1505   p = p + halfway;
1506   g_news = p;
1507   eputs ("g_cells=");
1508   eputs (itoa (g_cells));
1509   eputs (" size=");
1510   eputs (itoa (halfway));
1511   eputs (" news=");
1512   eputs (itoa (g_news));
1513   eputs (" news - cells=");
1514   char * c = g_cells;
1515   eputs (itoa (p - c));
1516   eputs ("\n");
1517
1518
1519   NTYPE (0) = TVECTOR;
1520   NLENGTH (0) = 1000;
1521   NVECTOR (0) = 0;
1522   g_news++;
1523   NTYPE (0) = TCHAR;
1524   NVALUE (0) = 'n';
1525   return 0;
1526 }
1527
1528 // INIT NEWS
1529
1530 SCM
1531 mes_symbols () ///((internal))
1532 {
1533   gc_init_cells ();
1534 #if MES_GC
1535   gc_init_news ();
1536 #endif
1537
1538   #include "mini-mes.symbols.i"
1539
1540   g_symbol_max = g_free;
1541   make_tmps (g_cells);
1542
1543   g_symbols = 0;
1544   for (int i=1; i<g_symbol_max; i++)
1545     g_symbols = cons (i, g_symbols);
1546
1547   SCM a = cell_nil;
1548
1549   #include "mini-mes.symbol-names.i"
1550
1551   a = acons (cell_symbol_mes_version, MAKE_STRING (cstring_to_list (VERSION)), a);
1552   a = acons (cell_symbol_mes_prefix, MAKE_STRING (cstring_to_list (PREFIX)), a);
1553
1554   a = acons (cell_symbol_dot, cell_dot, a);
1555   a = acons (cell_symbol_begin, cell_begin, a);
1556   a = acons (cell_symbol_call_with_values, cell_symbol_call_with_values, a);
1557   a = acons (cell_symbol_current_module, cell_symbol_current_module, a);
1558   a = acons (cell_symbol_call_with_current_continuation, cell_call_with_current_continuation, a);
1559   a = acons (cell_symbol_sc_expand, cell_f, a);
1560
1561 #if __GNUC__
1562   a = acons (cell_symbol_gnuc, cell_t, a);
1563   a = acons (cell_symbol_mesc, cell_f, a);
1564 #else
1565   a = acons (cell_symbol_gnuc, cell_f, a);
1566   a = acons (cell_symbol_mesc, cell_t, a);
1567 #endif
1568
1569   a = acons (cell_closure, a, a);
1570
1571   return a;
1572 }
1573
1574 SCM
1575 mes_environment () ///((internal))
1576 {
1577   SCM a = 0;
1578   a = mes_symbols ();
1579   a = mes_g_stack (a);
1580   return a;
1581 }
1582
1583 SCM
1584 mes_builtins (SCM a) ///((internal))
1585 {
1586   #include "mini-mes.i"
1587
1588 // Do not sort: Order of these includes define builtins
1589 // #include "lib.i"
1590 // #include "math.i"
1591 // #include "posix.i"
1592 #include "mini-vector.i"
1593 #include "mini-gc.i"
1594 // #include "reader.i"
1595
1596 #include "mini-gc.environment.i"
1597 // #include "lib.environment.i"
1598 // #include "math.environment.i"
1599 #include "mini-mes.environment.i"
1600 // #include "posix.environment.i"
1601 // #include "reader.environment.i"
1602 #include "mini-vector.environment.i"
1603
1604   return a;
1605 }
1606
1607 SCM
1608 bload_env (SCM a) ///((internal))
1609 {
1610   char *mo = "module/mes/read-0-32.mo";
1611   g_stdin = open (mo, 0);
1612   if (g_stdin < 0) {eputs ("no such file: ");eputs (mo);eputs ("\n");return 1;} 
1613   assert (getchar () == 'M');
1614   assert (getchar () == 'E');
1615   assert (getchar () == 'S');
1616   eputs ("*GOT MES*\n");
1617   g_stack = getchar () << 8;
1618   g_stack += getchar ();
1619
1620   char *p = (char*)g_cells;
1621   int c = getchar ();
1622   while (c != -1)
1623     {
1624       *p++ = c;
1625       c = getchar ();
1626     }
1627   g_free = (p-(char*)g_cells) / sizeof (struct scm);
1628   gc_peek_frame ();
1629   g_symbols = r1;
1630   g_stdin = STDIN;
1631   r0 = mes_builtins (r0);
1632
1633 #if __GNUC__
1634   set_env_x (cell_symbol_gnuc, cell_t, r0);
1635   set_env_x (cell_symbol_mesc, cell_f, r0);
1636 #else
1637   set_env_x (cell_symbol_gnuc, cell_f, r0);
1638   set_env_x (cell_symbol_mesc, cell_t, r0);
1639 #endif
1640
1641   if (g_debug)
1642     {
1643       eputs ("symbols: ");
1644       SCM s = g_symbols;
1645       while (s && s != cell_nil) {
1646         display_error_ (CAR (s));
1647         eputs (" ");
1648         s = CDR (s);
1649       }
1650       eputs ("\n");
1651       eputs ("functions: ");
1652       eputs (itoa (g_function));
1653       eputs ("\n");
1654       for (int i = 0; i < g_function; i++)
1655         {
1656           eputs ("[");
1657           eputs (itoa (i));
1658           eputs ("]: ");
1659           eputs (g_functions[i].name);
1660           eputs ("\n");
1661         }
1662       //display_error_ (r0);
1663       //puts ("\n");
1664     }
1665   return r2;
1666 }
1667
1668 // #include "math.c"
1669 // #include "posix.c"
1670 // #include "lib.c"
1671 // #include "reader.c"
1672 #include "vector.c"
1673 #include "gc.c"
1674
1675 int
1676 main (int argc, char *argv[])
1677 {
1678   eputs ("Hello mini-mes!\n");
1679 #if _POSIX_SOURCE
1680   g_debug = getenv ("MES_DEBUG");
1681   eputs ("g_debug=");
1682   eputs (itoa (g_debug));
1683   eputs ("\n");
1684   if (getenv ("MES_ARENA")) ARENA_SIZE = atoi (getenv ("MES_ARENA"));
1685 #endif
1686   g_debug = 1;
1687   if (argc > 1 && !strcmp (argv[1], "--help")) return eputs ("Usage: mes [--dump|--load] < FILE");
1688 #if __GNUC__
1689   if (argc > 1 && !strcmp (argv[1], "--version")) {eputs ("Mes ");return eputs (VERSION);};
1690 #else
1691   if (argc > 1 && !strcmp (argv[1], "--version")) {eputs ("Mes ");return eputs ("0.4");};
1692 #endif
1693   g_stdin = STDIN;
1694
1695   r0 = mes_environment ();
1696   
1697 #if MES_MINI
1698   SCM program = bload_env (r0);
1699 #else  
1700   SCM program = (argc > 1 && !strcmp (argv[1], "--load"))
1701     ? bload_env (r0) : load_env (r0);
1702   if (argc > 1 && !strcmp (argv[1], "--dump")) return dump ();
1703 #endif
1704
1705   SCM lst = cell_nil;
1706   for (int i=argc-1; i>=0; i--) lst = cons (MAKE_STRING (cstring_to_list (argv[i])), lst);
1707   r0 = acons (cell_symbol_argv, lst, r0);
1708   push_cc (r2, cell_unspecified, r0, cell_unspecified);
1709   if (g_debug)
1710     {
1711       eputs ("program: ");
1712       display_error_ (r1);
1713       eputs ("\n");
1714     }
1715   r3 = cell_vm_begin;
1716   r1 = eval_apply ();
1717   display_error_ (r1);
1718   eputs ("\n");
1719
1720 #if !MES_MINI
1721   gc (g_stack);
1722 #endif
1723   if (g_debug)
1724     {
1725       eputs ("\nstats: [");
1726       eputs (itoa (g_free));
1727       eputs ("]\n");
1728     }
1729   return 0;
1730 }
1731
1732 #if __GNUC__
1733 #include "mstart.c"
1734 #endif