Revert "core: Display me debuggor CPS+CC."
[mes.git] / 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 #define _GNU_SOURCE
22 #if __GNUC__
23 #define  __NYACC__ 0
24 #define NYACC
25 #define NYACC2
26 #include <assert.h>
27 #include <ctype.h>
28 #include <errno.h>
29 #include <limits.h>
30 #include <stdio.h>
31 #include <string.h>
32 #include <stdlib.h>
33 #include <stdbool.h>
34 #else
35 typedef int bool;
36 #define  __NYACC__ 1
37 #define NYACC nyacc
38 #define NYACC2 nyacc2
39 #endif
40
41 #define DEBUG 0
42 #define FIXED_PRIMITIVES 1
43
44 int ARENA_SIZE = 100000;
45 int MAX_ARENA_SIZE = 20000000;
46 int GC_SAFETY = 100;
47
48 typedef int SCM;
49 enum type_t {CHAR, CLOSURE, CONTINUATION, FUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, STRING, SYMBOL, VALUES, VECTOR, BROKEN_HEART};
50 typedef SCM (*function0_t) (void);
51 typedef SCM (*function1_t) (SCM);
52 typedef SCM (*function2_t) (SCM, SCM);
53 typedef SCM (*function3_t) (SCM, SCM, SCM);
54 typedef SCM (*functionn_t) (SCM);
55 typedef struct function_struct {
56   union {
57     function0_t function0;
58     function1_t function1;
59     function2_t function2;
60     function3_t function3;
61     functionn_t functionn;
62   } NYACC;
63   int arity;
64 } function_t;
65 struct scm;
66 typedef struct scm_struct {
67   enum type_t type;
68   union {
69     char const *name;
70     SCM string;
71     SCM car;
72     SCM ref;
73     int length;
74   } NYACC;
75   union {
76     int value;
77     int function;
78     SCM cdr;
79     SCM closure;
80     SCM continuation;
81     SCM macro;
82     SCM vector;
83     int hits;
84   } NYACC2;
85 } scm;
86
87 scm scm_nil = {SPECIAL, "()"};
88 scm scm_f = {SPECIAL, "#f"};
89 scm scm_t = {SPECIAL, "#t"};
90 scm scm_dot = {SPECIAL, "."};
91 scm scm_arrow = {SPECIAL, "=>"};
92 scm scm_undefined = {SPECIAL, "*undefined*"};
93 scm scm_unspecified = {SPECIAL, "*unspecified*"};
94 scm scm_closure = {SPECIAL, "*closure*"};
95 scm scm_circular = {SPECIAL, "*circular*"};
96 scm scm_begin = {SPECIAL, "*begin*"};
97
98 scm scm_symbol_dot = {SYMBOL, "*dot*"};
99 scm scm_symbol_lambda = {SYMBOL, "lambda"};
100 scm scm_symbol_begin = {SYMBOL, "begin"};
101 scm scm_symbol_if = {SYMBOL, "if"};
102 scm scm_symbol_quote = {SYMBOL, "quote"};
103 scm scm_symbol_set_x = {SYMBOL, "set!"};
104
105 scm scm_symbol_sc_expand = {SYMBOL, "sc-expand"};
106 scm scm_symbol_macro_expand = {SYMBOL, "macro-expand"};
107 scm scm_symbol_sc_expander_alist = {SYMBOL, "*sc-expander-alist*"};
108
109 scm scm_symbol_call_with_values = {SYMBOL, "call-with-values"};
110 scm scm_call_with_current_continuation = {SPECIAL, "*call/cc*"};
111 scm scm_symbol_call_with_current_continuation = {SYMBOL, "call-with-current-continuation"};
112 scm scm_symbol_current_module = {SYMBOL, "current-module"};
113 scm scm_symbol_primitive_load = {SYMBOL, "primitive-load"};
114 scm scm_symbol_read_input_file = {SYMBOL, "read-input-file"};
115 scm scm_symbol_write = {SYMBOL, "write"};
116 scm scm_symbol_display = {SYMBOL, "display"};
117 scm scm_symbol_argv = {SYMBOL, "argv"};
118
119 scm scm_symbol_mes_version = {SYMBOL, "%version"};
120 scm scm_symbol_mes_prefix = {SYMBOL, "%prefix"};
121
122 scm scm_symbol_car = {SYMBOL, "car"};
123 scm scm_symbol_cdr = {SYMBOL, "cdr"};
124 scm scm_symbol_null_p = {SYMBOL, "null?"};
125 scm scm_symbol_eq_p = {SYMBOL, "eq?"};
126 scm scm_symbol_cons = {SYMBOL, "cons"};
127
128 scm scm_vm_evlis = {SPECIAL, "*vm-evlis*"};
129 scm scm_vm_evlis2 = {SPECIAL, "*vm-evlis2*"};
130 scm scm_vm_evlis3 = {SPECIAL, "*vm-evlis3*"};
131 scm scm_vm_apply = {SPECIAL, "core:apply"};
132 scm scm_vm_apply2 = {SPECIAL, "*vm-apply2*"};
133 scm scm_vm_eval = {SPECIAL, "core:eval"};
134
135 #if FIXED_PRIMITIVES
136 scm scm_vm_eval_car = {SPECIAL, "*vm-eval-car*"};
137 scm scm_vm_eval_cdr = {SPECIAL, "*vm-eval-cdr*"};
138 scm scm_vm_eval_cons = {SPECIAL, "*vm-eval-cons*"};
139 scm scm_vm_eval_null_p = {SPECIAL, "*vm-eval-null-p*"};
140 #endif
141
142 scm scm_vm_eval_set_x = {SPECIAL, "*vm-eval-set!*"};
143 scm scm_vm_eval_macro = {SPECIAL, "*vm-eval-macro*"};
144 scm scm_vm_eval2 = {SPECIAL, "*vm-eval2*"};
145 scm scm_vm_macro_expand = {SPECIAL, "core:macro-expand"};
146 scm scm_vm_begin = {SPECIAL, "*vm-begin*"};
147 scm scm_vm_begin_read_input_file = {SPECIAL, "*vm-begin-read-input-file*"};
148 scm scm_vm_begin2 = {SPECIAL, "*vm-begin2*"};
149 scm scm_vm_if = {SPECIAL, "*vm-if*"};
150 scm scm_vm_if_expr = {SPECIAL, "*vm-if-expr*"};
151 scm scm_vm_call_with_values2 = {SPECIAL, "*vm-call-with-values2*"};
152 scm scm_vm_call_with_current_continuation2 = {SPECIAL, "*vm-call-with-current-continuation2*"};
153 scm scm_vm_return = {SPECIAL, "*vm-return*"};
154
155 scm scm_test = {SYMBOL, "test"};
156
157 int g_free = 0;
158 scm *g_cells;
159 scm *g_news = 0;
160
161 #include "mes.symbols.h"
162
163 SCM tmp;
164 SCM tmp_num;
165 SCM tmp_num2;
166
167 function_t functions[200];
168 int g_function = 0;
169
170 SCM g_continuations = 0;
171 SCM g_symbols = 0;
172 SCM g_stack = 0;
173 SCM r0 = 0; // a/env
174 SCM r1 = 0; // param 1
175 SCM r2 = 0; // save 2+load/dump
176 SCM r3 = 0; // continuation
177
178 #include "lib.h"
179 #include "math.h"
180 #include "mes.h"
181 #include "posix.h"
182 #include "reader.h"
183
184 #define CAR(x) g_cells[x].car
185 #define CDR(x) g_cells[x].cdr
186 #define CONTINUATION(x) g_cells[x].cdr
187 #define HITS(x) g_cells[x].hits
188 #define LENGTH(x) g_cells[x].length
189 #define NAME(x) g_cells[x].name
190 #define STRING(x) g_cells[x].string
191 #define TYPE(x) g_cells[x].type
192 #define CLOSURE(x) g_cells[x].closure
193 #define MACRO(x) g_cells[x].macro
194 #define REF(x) g_cells[x].ref
195 #define VALUE(x) g_cells[x].value
196 #define VECTOR(x) g_cells[x].vector
197 #define FUNCTION(x) functions[g_cells[x].function]
198 #define NCAR(x) g_news[x].car
199 #define NTYPE(x) g_news[x].type
200
201 #define CAAR(x) CAR (CAR (x))
202 #define CDAR(x) CDR (CAR (x))
203 #define CAAR(x) CAR (CAR (x))
204 #define CADAR(x) CAR (CDR (CAR (x)))
205 #define CADDR(x) CAR (CDR (CDR (x)))
206 #define CDDDR(x) CDR (CDR (CDR (x)))
207 #define CDADAR(x) CAR (CDR (CAR (CDR (x))))
208 #define CADR(x) CAR (CDR (x))
209
210 #define MAKE_CHAR(n) make_cell (tmp_num_ (CHAR), 0, tmp_num2_ (n))
211 #define MAKE_CONTINUATION(n) make_cell (tmp_num_ (CONTINUATION), n, g_stack)
212 #define MAKE_NUMBER(n) make_cell (tmp_num_ (NUMBER), 0, tmp_num2_ (n))
213 #define MAKE_REF(n) make_cell (tmp_num_ (REF), n, 0)
214 #define MAKE_STRING(x) make_cell (tmp_num_ (STRING), x, 0)
215
216 int error (char const* msg, SCM x);
217 SCM vm_call (function0_t f, SCM p1, SCM a);
218
219 SCM
220 tmp_num_ (int x)
221 {
222   g_cells[tmp_num].value = x;
223   return tmp_num;
224 }
225
226 SCM
227 tmp_num2_ (int x)
228 {
229   g_cells[tmp_num2].value = x;
230   return tmp_num2;
231 }
232
233 SCM
234 alloc (int n)
235 {
236   assert (g_free + n < ARENA_SIZE);
237   SCM x = g_free;
238   g_free += n;
239   return x;
240 }
241
242 SCM
243 make_cell (SCM type, SCM car, SCM cdr)
244 {
245   SCM x = alloc (1);
246   assert (TYPE (type) == NUMBER);
247   TYPE (x) = VALUE (type);
248   if (VALUE (type) == CHAR || VALUE (type) == NUMBER) {
249     if (car) CAR (x) = CAR (car);
250     if (cdr) CDR (x) = CDR (cdr);
251   } else if (VALUE (type) == FUNCTION) {
252     if (car) CAR (x) = car;
253     if (cdr) CDR (x) = CDR (cdr);
254   } else {
255     CAR (x) = car;
256     CDR (x) = cdr;
257   }
258   return x;
259 }
260
261 SCM
262 cons (SCM x, SCM y)
263 {
264   g_cells[tmp_num].value = PAIR;
265   return make_cell (tmp_num, x, y);
266 }
267
268 SCM
269 car (SCM x)
270 {
271   if (TYPE (x) != PAIR) error ("car: not pair: ", x);
272   return CAR (x);
273 }
274
275 SCM
276 cdr (SCM x)
277 {
278   if (TYPE (x) != PAIR) error ("cdr: not pair: ", x);
279   return CDR (x);
280 }
281 SCM
282 eq_p (SCM x, SCM y)
283 {
284   return (x == y
285           || ((TYPE (x) == KEYWORD && TYPE (y) == KEYWORD
286                && STRING (x) == STRING (y)))
287           || (TYPE (x) == CHAR && TYPE (y) == CHAR
288               && VALUE (x) == VALUE (y))
289           || (TYPE (x) == NUMBER && TYPE (y) == NUMBER
290               && VALUE (x) == VALUE (y)))
291     ? cell_t : cell_f;
292 }
293
294 SCM
295 type_ (SCM x)
296 {
297   return MAKE_NUMBER (TYPE (x));
298 }
299
300 SCM
301 car_ (SCM x)
302 {
303   return (TYPE (x) != CONTINUATION
304           && (TYPE (CAR (x)) == PAIR // FIXME: this is weird
305               || TYPE (CAR (x)) == REF
306               || TYPE (CAR (x)) == SPECIAL
307               || TYPE (CAR (x)) == SYMBOL
308               || TYPE (CAR (x)) == STRING)) ? CAR (x) : MAKE_NUMBER (CAR (x));
309 }
310
311 SCM
312 cdr_ (SCM x)
313 {
314   return (TYPE (CDR (x)) == PAIR
315           || TYPE (CDR (x)) == REF
316           || TYPE (CAR (x)) == SPECIAL
317           || TYPE (CDR (x)) == SYMBOL
318           || TYPE (CDR (x)) == STRING) ? CDR (x) : MAKE_NUMBER (CDR (x));
319 }
320
321 SCM
322 set_car_x (SCM x, SCM e)
323 {
324   assert (TYPE (x) == PAIR);
325   CAR (x) = e;
326   return cell_unspecified;
327 }
328
329 SCM
330 set_cdr_x (SCM x, SCM e)
331 {
332   if (TYPE (x) != PAIR) error ("set-cdr!: not pair: ", x);
333   CDR (x) = e;
334   return cell_unspecified;
335 }
336
337 SCM
338 set_env_x (SCM x, SCM e, SCM a)
339 {
340   SCM p = assert_defined (x, assq (x, a));
341   if (TYPE (p) != PAIR) error ("set-env!: not pair: ", x);
342   return set_cdr_x (p, e);
343 }
344
345 SCM
346 pairlis (SCM x, SCM y, SCM a)
347 {
348   if (x == cell_nil)
349     return a;
350   if (TYPE (x) != PAIR)
351     return cons (cons (x, y), a);
352   return cons (cons (car (x), car (y)),
353                pairlis (cdr (x), cdr (y), a));
354 }
355
356 SCM
357 assq (SCM x, SCM a)
358 {
359   while (a != cell_nil && eq_p (x, CAAR (a)) == cell_f) a = CDR (a);
360   return a != cell_nil ? car (a) : cell_f;
361 }
362
363 SCM
364 assq_ref_cache (SCM x, SCM a)
365 {
366   x = assq (x, a);
367   if (x == cell_f) return cell_undefined;
368   return cdr (x);
369 }
370
371 SCM
372 call_lambda (SCM e, SCM x, SCM aa, SCM a) ///((internal))
373 {
374   SCM cl = cons (cons (cell_closure, x), x);
375   r1 = e;
376   r0 = cl;
377   return cell_unspecified;
378 }
379
380 SCM
381 push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal))
382 {
383   SCM x = r3;
384   r3 = c;
385   r2 = p2;
386   gc_push_frame ();
387   r1 = p1;
388   r0 = a;
389   r3 = x;
390   return cell_unspecified;
391 }
392
393 SCM
394 eval_apply ()
395 {
396  eval_apply:
397   if (g_free + GC_SAFETY > ARENA_SIZE)
398     gc_pop_frame (gc (gc_push_frame ()));
399
400   switch (r3)
401     {
402     case cell_vm_evlis: goto evlis;
403     case cell_vm_evlis2: goto evlis2;
404     case cell_vm_evlis3: goto evlis3;
405     case cell_vm_apply: goto apply;
406     case cell_vm_apply2: goto apply2;
407     case cell_vm_eval: goto eval;
408 #if FIXED_PRIMITIVES
409     case cell_vm_eval_car: goto eval_car;
410     case cell_vm_eval_cdr: goto eval_cdr;
411     case cell_vm_eval_cons: goto eval_cons;
412     case cell_vm_eval_null_p: goto eval_null_p;
413 #endif
414     case cell_vm_eval_set_x: goto eval_set_x;
415     case cell_vm_eval_macro: goto eval_macro;
416     case cell_vm_eval2: goto eval2;
417     case cell_vm_macro_expand: goto macro_expand;
418     case cell_vm_begin: goto begin;
419     case cell_vm_begin_read_input_file: goto begin_read_input_file;
420     case cell_vm_begin2: goto begin2;
421     case cell_vm_if: goto vm_if;
422     case cell_vm_if_expr: goto if_expr;
423     case cell_vm_call_with_current_continuation2: goto call_with_current_continuation2;
424     case cell_vm_call_with_values2: goto call_with_values2;
425     case cell_vm_return: goto vm_return;
426     case cell_unspecified: return r1;
427     default:
428       assert (0);
429     }
430
431   SCM x = cell_nil;
432   SCM y = cell_nil;
433  evlis:
434   if (r1 == cell_nil) goto vm_return;
435   if (TYPE (r1) != PAIR) goto eval;
436   push_cc (car (r1), r1, r0, cell_vm_evlis2);
437   goto eval;
438  evlis2:
439   push_cc (cdr (r2), r1, r0, cell_vm_evlis3);
440   goto evlis;
441  evlis3:
442   r1 = cons (r2, r1);
443   goto vm_return;
444
445  apply:
446   switch (TYPE (car (r1)))
447     {
448     case FUNCTION: {
449       check_formals (car (r1), MAKE_NUMBER (FUNCTION (car (r1)).arity), cdr (r1));
450       r1 = call (car (r1), cdr (r1)); /// FIXME: move into eval_apply
451       goto vm_return;
452     }
453     case CLOSURE:
454       {
455         SCM cl = CLOSURE (car (r1));
456         SCM formals = cadr (cl);
457         SCM body = cddr (cl);
458         SCM aa = cdar (cl);
459         aa = cdr (aa);
460         check_formals (car (r1), formals, cdr (r1));
461         SCM p = pairlis (formals, cdr (r1), aa);
462         call_lambda (body, p, aa, r0);
463         goto begin;
464       }
465       case CONTINUATION:
466         {
467           x = r1;
468           g_stack = CONTINUATION (CAR (r1));
469           gc_pop_frame ();
470           r1 = cadr (x);
471           goto eval_apply;
472         }
473     case SPECIAL:
474       {
475         switch (car (r1))
476           {
477           case cell_vm_apply:
478             {
479               push_cc (cons (CADR (r1), CADDR (r1)), r1, r0, cell_vm_return);
480               goto apply;
481             }
482           case cell_vm_eval:
483             {
484               push_cc (CADR (r1), r1, CADDR (r1), cell_vm_return);
485               goto eval;
486             }
487           case cell_call_with_current_continuation:
488             {
489               r1 = cdr (r1);
490               goto call_with_current_continuation;
491             }
492           default: error ("cannot apply special: ", car (r1));
493           }
494       }
495     case SYMBOL:
496       {
497         if (car (r1) == cell_symbol_call_with_values)
498           {
499             r1 = cdr (r1);
500             goto call_with_values;
501           }
502         if (car (r1) == cell_symbol_current_module)
503           {
504             r1 = r0;
505             goto vm_return;
506           }
507         break;
508       }
509     case PAIR:
510       {
511         switch (caar (r1))
512           {
513           case cell_symbol_lambda:
514             {
515               SCM formals = cadr (car (r1));
516               SCM body = cddr (car (r1));
517               SCM p = pairlis (formals, cdr (r1), r0);
518               check_formals (r1, formals, cdr (r1));
519               call_lambda (body, p, p, r0);
520               goto begin;
521             }
522           }
523       }
524     }
525   push_cc (car (r1), r1, r0, cell_vm_apply2);
526   goto eval;
527  apply2:
528   check_apply (r1, car (r2));
529   r1 = cons (r1, cdr (r2));
530   goto apply;
531
532  eval:
533   switch (TYPE (r1))
534     {
535     case PAIR:
536       {
537         switch (car (r1))
538           {
539 #if FIXED_PRIMITIVES
540           case cell_symbol_car:
541             {
542               push_cc (CADR (r1), r1, r0, cell_vm_eval_car); goto eval;
543             eval_car:
544               x = r1; gc_pop_frame (); r1 = car (x); goto eval_apply;
545             }
546           case cell_symbol_cdr:
547             {
548               push_cc (CADR (r1), r1, r0, cell_vm_eval_cdr); goto eval;
549             eval_cdr:
550               x = r1; gc_pop_frame (); r1 = cdr (x); goto eval_apply;
551             }
552           case cell_symbol_cons: {
553             push_cc (CDR (r1), r1, r0, cell_vm_eval_cons); goto evlis;
554             eval_cons:
555             x = r1;
556             gc_pop_frame ();
557             r1 = cons (CAR (x), CADR (x));
558             goto eval_apply;
559           }
560           case cell_symbol_null_p:
561             {
562               push_cc (CADR (r1), r1, r0, cell_vm_eval_null_p);
563               goto eval;
564             eval_null_p:
565               x = r1; gc_pop_frame (); r1 = null_p (x); goto eval_apply;
566             }
567 #endif // FIXED_PRIMITIVES
568           case cell_symbol_quote:
569             {
570               x = r1; gc_pop_frame (); r1 = cadr (x); goto eval_apply;
571             }
572           case cell_symbol_begin: goto begin;
573           case cell_symbol_lambda:
574             {
575               r1 = make_closure (cadr (r1), cddr (r1), assq (cell_closure, r0));
576               goto vm_return;
577             }
578           case cell_symbol_if: {r1=cdr (r1); goto vm_if;}
579           case cell_symbol_set_x:
580             {
581               push_cc (car (cddr (r1)), r1, r0, cell_vm_eval_set_x);
582               goto eval;
583             eval_set_x:
584               x = r2;
585               r1 = set_env_x (cadr (x), r1, r0);
586               goto vm_return;
587             }
588           case cell_vm_macro_expand:
589             {
590               push_cc (cadr (r1), r1, r0, cell_vm_return);
591               goto macro_expand;
592             }
593           default: {
594             push_cc (r1, r1, r0, cell_vm_eval_macro);
595             goto macro_expand;
596             eval_macro:
597             x = r2;
598             if (r1 != r2)
599               {
600                 if (TYPE (r1) == PAIR)
601                   {
602                     set_cdr_x (r2, cdr (r1));
603                     set_car_x (r2, car (r1));
604                   }
605                 goto eval;
606               }
607             push_cc (CDR (r1), r1, r0, cell_vm_eval2); goto evlis;
608             eval2:
609             r1 = cons (car (r2), r1);
610             goto apply;
611           }
612           }
613       }
614     case SYMBOL:
615       {
616         r1 = assert_defined (r1, assq_ref_cache (r1, r0));
617         goto vm_return;
618       }
619     default: goto vm_return;
620     }
621
622   SCM macro;
623   SCM expanders;
624  macro_expand:
625   if (TYPE (r1) == PAIR
626       && (macro = lookup_macro (car (r1), r0)) != cell_f)
627     {
628       r1 = cons (macro, CDR (r1));
629       goto apply;
630     }
631   else if (TYPE (r1) == PAIR
632            && TYPE (CAR (r1)) == SYMBOL
633            && ((expanders = assq_ref_cache (cell_symbol_sc_expander_alist, r0)) != cell_undefined)
634            && ((macro = assq (CAR (r1), expanders)) != cell_f))
635     {
636       SCM sc_expand = assq_ref_cache (cell_symbol_macro_expand, r0);
637       if (sc_expand != cell_undefined && sc_expand != cell_f)
638         {
639           r1 = cons (sc_expand, cons (r1, cell_nil));
640           goto apply;
641         }
642     }
643   goto vm_return;
644
645  begin:
646   x = cell_unspecified;
647   while (r1 != cell_nil) {
648     if (TYPE (r1) == PAIR && TYPE (CAR (r1)) == PAIR)
649       {
650         if (caar (r1) == cell_symbol_begin)
651           r1 = append2 (cdar (r1), cdr (r1));
652         else if (caar (r1) == cell_symbol_primitive_load)
653           {
654             push_cc (cons (cell_symbol_read_input_file, cell_nil), r1, r0, cell_vm_begin_read_input_file);
655             goto apply;
656           begin_read_input_file:
657             r1 = append2 (r1, cdr (r2));
658           }
659       }
660     if (CDR (r1) == cell_nil)
661       {
662         r1 = car (r1);
663         goto eval;
664       }
665     push_cc (CAR (r1), r1, r0, cell_vm_begin2);
666     goto eval;
667   begin2:
668     x = r1;
669     r1 = CDR (r2);
670   }
671   r1 = x;
672   goto vm_return;
673
674  vm_if:
675   push_cc (car (r1), r1, r0, cell_vm_if_expr);
676   goto eval;
677  if_expr:
678   x = r1;
679   r1 = r2;
680   if (x != cell_f)
681     {
682       r1 = cadr (r1);
683       goto eval;
684     }
685   if (cddr (r1) != cell_nil)
686     {
687       r1 = car (cddr (r1));
688       goto eval;
689     }
690   r1 = cell_unspecified;
691   goto vm_return;
692
693  call_with_current_continuation:
694   gc_push_frame ();
695   x = MAKE_CONTINUATION (g_continuations++);
696   gc_pop_frame ();
697   push_cc (cons (car (r1), cons (x, cell_nil)), x, r0, cell_vm_call_with_current_continuation2);
698   goto apply;
699  call_with_current_continuation2:
700   CONTINUATION (r2) = g_stack;
701   goto vm_return;
702
703  call_with_values:
704   push_cc (cons (car (r1), cell_nil), r1, r0, cell_vm_call_with_values2);
705   goto apply;
706  call_with_values2:
707   if (TYPE (r1) == VALUES)
708     r1 = CDR (r1);
709   r1 = cons (cadr (r2), r1);
710   goto apply;
711
712  vm_return:
713   x = r1;
714   gc_pop_frame ();
715   r1 = x;
716   goto eval_apply;
717 }
718
719 SCM
720 call (SCM fn, SCM x)
721 {
722   if ((FUNCTION (fn).arity > 0 || FUNCTION (fn).arity == -1)
723       && x != cell_nil && TYPE (CAR (x)) == VALUES)
724     x = cons (CADAR (x), CDR (x));
725   if ((FUNCTION (fn).arity > 1 || FUNCTION (fn).arity == -1)
726       && x != cell_nil && TYPE (CDR (x)) == PAIR && TYPE (CADR (x)) == VALUES)
727     x = cons (CAR (x), cons (CDADAR (x), CDR (x)));
728   switch (FUNCTION (fn).arity)
729     {
730     case 0: return FUNCTION (fn).function0 ();
731     case 1: return FUNCTION (fn).function1 (car (x));
732     case 2: return FUNCTION (fn).function2 (car (x), cadr (x));
733     case 3: return FUNCTION (fn).function3 (car (x), cadr (x), car (cddr (x)));
734     case -1: return FUNCTION (fn).functionn (x);
735     }
736
737   return cell_unspecified;
738 }
739
740 SCM
741 gc_peek_frame ()
742 {
743   SCM frame = car (g_stack);
744   r1 = car (frame);
745   r2 = cadr (frame);
746   r3 = car (cddr (frame));
747   r0 = cadr (cddr (frame));
748   return frame;
749 }
750
751 SCM
752 gc_pop_frame ()
753 {
754   SCM frame = gc_peek_frame (g_stack);
755   g_stack = cdr (g_stack);
756   return frame;
757 }
758
759 SCM
760 gc_push_frame ()
761 {
762   SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cell_nil))));
763   return g_stack = cons (frame, g_stack);
764 }
765
766 SCM
767 apply (SCM f, SCM x, SCM a) ///((internal))
768 {
769   push_cc (cons (f, x), cell_unspecified, r0, cell_unspecified);
770   r3 = cell_vm_apply;
771   return eval_apply ();
772 }
773
774 SCM
775 append2 (SCM x, SCM y)
776 {
777   if (x == cell_nil) return y;
778   assert (TYPE (x) == PAIR);
779   return cons (car (x), append2 (cdr (x), y));
780 }
781
782 SCM
783 append (SCM x) ///((arity . n))
784  {
785   if (x == cell_nil) return cell_nil;
786   if (cdr (x) == cell_nil) return car (x);
787   return append2 (car (x), append (cdr (x)));
788  }
789
790 SCM
791 cstring_to_list (char const* s)
792 {
793   SCM p = cell_nil;
794   int i = strlen (s);
795   while (i--)
796     p = cons (MAKE_CHAR (s[i]), p);
797   return p;
798 }
799
800 SCM
801 null_p (SCM x)
802 {
803   return x == cell_nil ? cell_t : cell_f;
804 }
805
806 SCM
807 make_symbol_ (SCM s)
808 {
809   g_cells[tmp_num].value = SYMBOL;
810   SCM x = make_cell (tmp_num, s, 0);
811   g_symbols = cons (x, g_symbols);
812   return x;
813 }
814
815 SCM
816 make_symbol (SCM s)
817 {
818   SCM x = lookup_symbol_ (s);
819   return x ? x : make_symbol_ (s);
820 }
821
822 SCM
823 make_vector (SCM n)
824 {
825   int k = VALUE (n);
826   g_cells[tmp_num].value = VECTOR;
827   SCM v = alloc (k);
828   SCM x = make_cell (tmp_num, k, v);
829   for (int i=0; i<k; i++) g_cells[v+i] = g_cells[vector_entry (cell_unspecified)];
830   return x;
831 }
832
833 SCM
834 arity_ (SCM x)
835 {
836   assert (TYPE (x) == FUNCTION);
837   return MAKE_NUMBER (FUNCTION (x).arity);
838 }
839
840 SCM
841 values (SCM x) ///((arity . n))
842 {
843   SCM v = cons (0, x);
844   TYPE (v) = VALUES;
845   return v;
846 }
847
848 SCM
849 vector_length (SCM x)
850 {
851   assert (TYPE (x) == VECTOR);
852   return MAKE_NUMBER (LENGTH (x));
853 }
854
855 SCM
856 vector_ref (SCM x, SCM i)
857 {
858   assert (TYPE (x) == VECTOR);
859   assert (VALUE (i) < LENGTH (x));
860   SCM e = VECTOR (x) + VALUE (i);
861   if (TYPE (e) == REF) e = g_cells[e].ref;
862   if (TYPE (e) == CHAR) e = MAKE_CHAR (VALUE (e));
863   if (TYPE (e) == NUMBER) e = MAKE_NUMBER (VALUE (e));
864   return e;
865 }
866
867 SCM
868 vector_entry (SCM x) {
869   if (TYPE (x) == PAIR || TYPE (x) == SPECIAL || TYPE (x) == STRING || TYPE (x) == SYMBOL || TYPE (x) == VECTOR) x = MAKE_REF (x);
870   return x;
871 }
872
873 SCM
874 vector_set_x (SCM x, SCM i, SCM e)
875 {
876   assert (TYPE (x) == VECTOR);
877   assert (VALUE (i) < LENGTH (x));
878   g_cells[VECTOR (x)+g_cells[i].value] = g_cells[vector_entry (e)];
879   return cell_unspecified;
880 }
881
882 SCM
883 list_to_vector (SCM x)
884 {
885   VALUE (tmp_num) = VALUE (length (x));
886   SCM v = make_vector (tmp_num);
887   SCM p = VECTOR (v);
888   while (x != cell_nil)
889     {
890       g_cells[p++] = g_cells[vector_entry (car (x))];
891       x = cdr (x);
892     }
893   return v;
894 }
895
896 SCM
897 vector_to_list (SCM v)
898 {
899   SCM x = cell_nil;
900   for (int i = 0; i < LENGTH (v); i++) {
901     SCM e = VECTOR (v)+i;
902     if (TYPE (e) == REF) e = g_cells[e].ref;
903     x = append2 (x, cons (e, cell_nil));
904   }
905   return x;
906 }
907
908 void
909 make_tmps (scm* cells)
910 {
911   tmp = g_free++;
912   cells[tmp].type = CHAR;
913   tmp_num = g_free++;
914   cells[tmp_num].type = NUMBER;
915   tmp_num2 = g_free++;
916   cells[tmp_num2].type = NUMBER;
917 }
918
919 //\f Jam Collector
920 SCM g_symbol_max;
921 bool g_debug = false;
922
923 SCM
924 gc_up_arena ()
925 {
926   ARENA_SIZE *= 2;
927   void *p = realloc (g_cells-1, 2*ARENA_SIZE*sizeof(scm));
928   if (!p) error (strerror (errno), MAKE_NUMBER (g_free));
929   g_cells = (scm*)p;
930   g_cells++;
931   gc_init_news ();
932 }
933
934 SCM
935 gc ()
936 {
937   if (g_debug) fprintf (stderr, "***gc[%d]...", g_free);
938   g_free = 1;
939   if (g_cells < g_news && ARENA_SIZE < MAX_ARENA_SIZE) gc_up_arena ();
940   for (int i=g_free; i<g_symbol_max; i++)
941     gc_copy (i);
942   make_tmps (g_news);
943   g_symbols = gc_copy (g_symbols);
944   SCM new = gc_copy (g_stack);
945   if (g_debug) fprintf (stderr, "new=%d\n", new, g_stack);
946   g_stack = new;
947   return gc_loop (1);
948 }
949
950 SCM
951 gc_loop (SCM scan)
952 {
953   while (scan < g_free)
954     {
955       if (NTYPE (scan) == CLOSURE
956           || NTYPE (scan) == CONTINUATION
957           || NTYPE (scan) == FUNCTION
958           || NTYPE (scan) == KEYWORD
959           || NTYPE (scan) == MACRO
960           || NTYPE (scan) == PAIR
961           || NTYPE (scan) == REF
962           || scan == 1 // null
963           || NTYPE (scan) == SPECIAL
964           || NTYPE (scan) == STRING
965           || NTYPE (scan) == SYMBOL)
966         {
967           SCM car = gc_copy (g_news[scan].car);
968           gc_relocate_car (scan, car);
969         }
970       if ((NTYPE (scan) == CLOSURE
971            || NTYPE (scan) == CONTINUATION
972            || NTYPE (scan) == MACRO
973            || NTYPE (scan) == PAIR
974            || NTYPE (scan) == VALUES)
975           && g_news[scan].cdr) // allow for 0 terminated list of symbols
976         {
977           SCM cdr = gc_copy (g_news[scan].cdr);
978           gc_relocate_cdr (scan, cdr);
979         }
980       scan++;
981     }
982   return gc_flip ();
983 }
984
985 SCM
986 gc_copy (SCM old)
987 {
988   if (TYPE (old) == BROKEN_HEART) return g_cells[old].car;
989   SCM new = g_free++;
990   g_news[new] = g_cells[old];
991   if (NTYPE (new) == VECTOR)
992     {
993       g_news[new].vector = g_free;
994       for (int i=0; i<LENGTH (old); i++)
995         g_news[g_free++] = g_cells[VECTOR (old)+i];
996     }
997   g_cells[old].type = BROKEN_HEART;
998   g_cells[old].car = new;
999   return new;
1000 }
1001
1002 SCM
1003 gc_relocate_car (SCM new, SCM car)
1004 {
1005   g_news[new].car = car;
1006   return cell_unspecified;
1007 }
1008
1009 SCM
1010 gc_relocate_cdr (SCM new, SCM cdr)
1011 {
1012   g_news[new].cdr = cdr;
1013   return cell_unspecified;
1014 }
1015
1016 SCM
1017 gc_flip ()
1018 {
1019   scm *cells = g_cells;
1020   g_cells = g_news;
1021   g_news = cells;
1022   if (g_debug) fprintf (stderr, " => jam[%d]\n", g_free);
1023   return g_stack;
1024 }
1025
1026 //\f Environment setup
1027 SCM
1028 acons (SCM key, SCM value, SCM alist)
1029 {
1030   return cons (cons (key, value), alist);
1031 }
1032
1033 SCM
1034 gc_init_cells ()
1035 {
1036   g_cells = (scm *)malloc (2*ARENA_SIZE*sizeof(scm));
1037   g_cells[0].type = VECTOR;
1038   g_cells[0].length = 1000;
1039   g_cells[0].vector = 0;
1040   g_cells++;
1041   g_cells[0].type = CHAR;
1042   g_cells[0].value = 'c';
1043 }
1044
1045 SCM
1046 gc_init_news ()
1047 {
1048   g_news = g_cells-1 + ARENA_SIZE;
1049   g_news[0].type = VECTOR;
1050   g_news[0].length = 1000;
1051   g_news[0].vector = 0;
1052   g_news++;
1053   g_news[0].type = CHAR;
1054   g_news[0].value = 'n';
1055 }
1056
1057 SCM
1058 mes_symbols () ///((internal))
1059 {
1060   gc_init_cells ();
1061   gc_init_news ();
1062
1063 #include "mes.symbols.i"
1064
1065   g_symbol_max = g_free;
1066   make_tmps (g_cells);
1067
1068   g_symbols = 0;
1069   for (int i=1; i<g_symbol_max; i++)
1070     g_symbols = cons (i, g_symbols);
1071
1072   SCM a = cell_nil;
1073
1074 #include "mes.symbol-names.i"
1075
1076   a = acons (cell_symbol_mes_version, MAKE_STRING (cstring_to_list (VERSION)), a);
1077   a = acons (cell_symbol_mes_prefix, MAKE_STRING (cstring_to_list (PREFIX)), a);
1078
1079 #if BOOT
1080   a = acons (cell_symbol_label, cell_t, a);
1081 #endif
1082   a = acons (cell_symbol_dot, cell_dot, a);
1083   a = acons (cell_symbol_begin, cell_begin, a);
1084   a = acons (cell_symbol_call_with_current_continuation, cell_call_with_current_continuation, a);
1085   a = acons (cell_symbol_sc_expand, cell_f, a);
1086   a = acons (cell_closure, a, a);
1087
1088   return a;
1089 }
1090
1091 SCM
1092 mes_builtins (SCM a)
1093 {
1094 #include "mes.i"
1095
1096 #include "lib.i"
1097 #include "math.i"
1098 #include "posix.i"
1099 #include "reader.i"
1100
1101 #include "lib.environment.i"
1102 #include "math.environment.i"
1103 #include "mes.environment.i"
1104 #include "posix.environment.i"
1105 #include "reader.environment.i"
1106
1107   return a;
1108 }
1109
1110 SCM
1111 mes_g_stack (SCM a) ///((internal))
1112 {
1113   r0 = a;
1114   r1 = MAKE_CHAR (0);
1115   r2 = MAKE_CHAR (0);
1116   r3 = MAKE_CHAR (0);
1117   g_stack = cons (cell_nil, cell_nil);
1118   return r0;
1119 }
1120
1121 SCM
1122 mes_environment () ///((internal))
1123 {
1124   SCM a = mes_symbols ();
1125   return mes_g_stack (a);
1126 }
1127
1128 SCM
1129 make_closure (SCM args, SCM body, SCM a)
1130 {
1131   return make_cell (tmp_num_ (CLOSURE), cell_f, cons (cons (cell_circular, a), cons (args, body)));
1132 }
1133
1134 SCM
1135 lookup_macro (SCM x, SCM a)
1136 {
1137   if (TYPE (x) != SYMBOL) return cell_f;
1138   SCM m = assq_ref_cache (x, a);
1139   if (TYPE (m) == MACRO) return MACRO (m);
1140   return cell_f;
1141 }
1142
1143 FILE *g_stdin;
1144 #include "lib.c"
1145 #include "math.c"
1146 #include "posix.c"
1147 #include "reader.c"
1148
1149 int
1150 main (int argc, char *argv[])
1151 {
1152 #if __GNUC__
1153   g_debug = getenv ("MES_DEBUG");
1154 #else
1155 #endif
1156   if (getenv ("MES_ARENA")) ARENA_SIZE = atoi (getenv ("MES_ARENA"));
1157   if (argc > 1 && !strcmp (argv[1], "--help")) return puts ("Usage: mes [--dump|--load] < FILE");
1158   if (argc > 1 && !strcmp (argv[1], "--version")) {puts ("Mes ");puts (VERSION);return 0;};
1159   g_stdin = stdin;
1160   r0 = mes_environment ();
1161
1162   SCM program = (argc > 1 && !strcmp (argv[1], "--load"))
1163     ? bload_env (r0) : load_env (r0);
1164   if (argc > 1 && !strcmp (argv[1], "--dump")) return dump ();
1165
1166   SCM lst = cell_nil;
1167   for (int i=argc; i; i--) lst = cons (MAKE_STRING (cstring_to_list (argv[i-1])), lst);
1168   r0 = acons (cell_symbol_argv, lst, r0);
1169
1170   push_cc (r2, cell_unspecified, r0, cell_unspecified);
1171   r3 = cell_vm_begin;
1172   r1 = eval_apply ();
1173   stderr_ (r1);
1174   fputs ("", stderr);
1175   gc (g_stack);
1176 #if __GNUC__
1177   if (g_debug) fprintf (stderr, "\nstats: [%d]\n", g_free);
1178 #else
1179 #endif
1180   return 0;
1181 }