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