10e9472760391f7942f2606b9dc155369e6a7fcf
[mes.git] / mes.c
1 /* -*-comment-start: "//";comment-end:""-*-
2  * Mes --- Maxwell Equations of Software
3  * Copyright © 2016 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 #include <assert.h>
23 #include <ctype.h>
24 #include <limits.h>
25 #include <stdio.h>
26 #include <string.h>
27 #include <stdlib.h>
28 #include <stdbool.h>
29
30 #define DEBUG 0
31 #define QUASIQUOTE 1
32 //#define QUASISYNTAX 0
33
34 #define GC 1
35 #define MES_FULL 1
36 #define MES_MINI 0 // 1 for gc-2a.test, gc-3.test
37
38 #if MES_FULL
39 int ARENA_SIZE = 300000000; // need this much for tests/match.scm
40 //int ARENA_SIZE = 30000000; // need this much for tests/record.scm
41 //int ARENA_SIZE = 500000; // enough for tests/scm.test
42 //int ARENA_SIZE = 60000; // enough for tests/base.test
43 int GC_SAFETY = 10000;
44 int GC_FREE = 20000;
45 #else
46 // just enough for empty environment and tests/gc-2.test.
47 //int ARENA_SIZE = 7500; // gc-3.test, gc-2a.test
48 //int ARENA_SIZE = 10000; // gc-2a.test
49 int ARENA_SIZE = 18000; // gc-2.test -->KRAK
50 //int ARENA_SIZE = 23000; // gc-2.test OK
51 int GC_SAFETY = 1000;
52 int GC_FREE = 1000;
53 #endif
54
55 enum type {CHAR, FUNCTION, MACRO, NUMBER, PAIR, SCM, STRING, SYMBOL, REF, VALUES, VECTOR, BROKEN_HEART};
56 typedef struct scm_t* (*function0_t) (void);
57 typedef struct scm_t* (*function1_t) (struct scm_t*);
58 typedef struct scm_t* (*function2_t) (struct scm_t*, struct scm_t*);
59 typedef struct scm_t* (*function3_t) (struct scm_t*, struct scm_t*, struct scm_t*);
60 typedef struct scm_t* (*functionn_t) (struct scm_t*);
61 typedef struct function_t {
62   union {
63     function0_t function0;
64     function1_t function1;
65     function2_t function2;
66     function3_t function3;
67     functionn_t functionn;
68   };
69   int arity;
70 } function;
71 struct scm_t;
72 typedef struct scm_t {
73   enum type type;
74   union {
75     char const *name;
76     struct scm_t* string;
77     struct scm_t* car;
78     struct scm_t* ref;
79     int length;
80   };
81   union {
82     int value;
83     function* function;
84     struct scm_t* cdr;
85     struct scm_t* macro;
86     struct scm_t* vector;
87     int hits;
88   };
89 } scm;
90
91 #include "define.environment.h"
92 #include "lib.environment.h"
93 #include "math.environment.h"
94 #include "mes.environment.h"
95 #include "posix.environment.h"
96 #include "quasiquote.environment.h"
97 #include "string.environment.h"
98 #include "type.environment.h"
99
100 scm *display_ (FILE* f, scm *x);
101 scm *display_helper (FILE*, scm*, bool, char const*, bool);
102
103 scm *symbols = 0;
104 scm *stack = 0;
105 scm *r0 = 0; // a/env
106 scm *r1 = 0; // param 1
107 scm *r2 = 0; // param 2
108 scm *r3 = 0; // param 3
109
110 scm scm_nil = {SCM, "()"};
111 scm scm_dot = {SCM, "."};
112 scm scm_f = {SCM, "#f"};
113 scm scm_t = {SCM, "#t"};
114 scm scm_undefined = {SCM, "*undefined*"};
115 scm scm_unspecified = {SCM, "*unspecified*"};
116 scm scm_closure = {SCM, "*closure*"};
117 scm scm_circular = {SCM, "*circular*"};
118 #if BOOT
119 scm scm_label = {
120   SCM, "label"};
121 #endif
122 scm scm_begin = {SCM, "*begin*"};
123
124 scm symbol_lambda = {SYMBOL, "lambda"};
125 scm symbol_begin = {SYMBOL, "begin"};
126 scm symbol_if = {SYMBOL, "if"};
127 scm symbol_define = {SYMBOL, "define"};
128 scm symbol_define_macro = {SCM, "define-macro"};
129 scm symbol_set_x = {SYMBOL, "set!"};
130
131 scm symbol_quote = {SYMBOL, "quote"};
132 scm symbol_quasiquote = {SYMBOL, "quasiquote"};
133 scm symbol_unquote = {SYMBOL, "unquote"};
134 scm symbol_unquote_splicing = {SYMBOL, "unquote-splicing"};
135
136 scm symbol_sc_expand = {SYMBOL, "sc-expand"};
137 scm symbol_expand_macro = {SYMBOL, "expand-macro"};
138 scm symbol_sc_expander_alist = {SYMBOL, "*sc-expander-alist*"};
139 scm symbol_noexpand = {SYMBOL, "noexpand"};
140 scm symbol_syntax = {SYMBOL, "syntax"};
141 scm symbol_quasisyntax = {SYMBOL, "quasisyntax"};
142 scm symbol_unsyntax = {SYMBOL, "unsyntax"};
143 scm symbol_unsyntax_splicing = {SYMBOL, "unsyntax-splicing"};
144
145 scm symbol_call_with_values = {SYMBOL, "call-with-values"};
146 scm symbol_current_module = {SYMBOL, "current-module"};
147 scm symbol_primitive_load = {SYMBOL, "primitive-load"};
148
149 scm char_nul = {CHAR, .name="nul", .value=0};
150 scm char_backspace = {CHAR, .name="backspace", .value=8};
151 scm char_tab = {CHAR, .name="tab", .value=9};
152 scm char_newline = {CHAR, .name="newline", .value=10};
153 scm char_vt = {CHAR, .name="vt", .value=11};
154 scm char_page = {CHAR, .name="page", .value=12};
155 scm char_return = {CHAR, .name="return", .value=13};
156 scm char_space = {CHAR, .name="space", .value=32};
157
158 // PRIMITIVES
159
160 scm *
161 car (scm *x)
162 {
163   assert (x->type == PAIR);
164   return x->car;
165 }
166
167 scm *
168 cdr (scm *x)
169 {
170   assert (x->type == PAIR);
171   return x->cdr;
172 }
173
174 scm g_free = {NUMBER, .value=0};
175 scm *g_cells;
176 scm *g_news;
177
178 scm *
179 alloc (int n)
180 {
181 #if GC
182   assert (g_free.value + n < ARENA_SIZE);
183   scm* x = &g_cells[g_free.value];
184   g_free.value += n;
185   return x;
186 #else
187   return (scm*)malloc(n*sizeof (scm));
188 #endif
189 }
190
191 scm *
192 gc_alloc (int n)
193 {
194   assert (g_free.value + n < ARENA_SIZE);
195   scm* x = &g_cells[g_free.value];
196   g_free.value += n;
197   return x;
198 }
199
200 scm *
201 gc (scm *a)
202 {
203   fprintf (stderr, "***gc[%d]...", g_free.value);
204   g_free.value = 0;
205   scm *new = gc_copy (stack);
206   gc_copy (symbols);
207   return gc_loop (new);
208 }
209
210 scm *
211 gc_loop (scm *scan)
212 {
213   while (scan - g_news < g_free.value)
214     {
215       if (scan->type == MACRO
216           || scan->type == PAIR
217           || scan->type == REF
218           || (scan->type == SCM && scan->car->type == PAIR)
219           || (scan->type == STRING && scan->car->type == PAIR)
220           || (scan->type == SYMBOL && scan->car->type == PAIR))
221         {
222           scm *car = gc_copy (scan->car);
223           gc_relocate_car (scan, car);
224         }
225       if ((scan->type == MACRO
226            || scan->type == PAIR)
227           && scan->cdr) // allow for 0 terminated list of symbols
228         {
229           scm *cdr = gc_copy (scan->cdr);
230           gc_relocate_cdr (scan, cdr);
231         }
232       scan++;
233     }
234   return gc_flip ();
235 }
236
237 scm *
238 gc_copy (scm *old)
239 {
240   if (old->type == BROKEN_HEART) return old->car;
241   if (old->type == FUNCTION) return old;
242   if (old->type == SCM) return old;
243   if (old < g_cells && old < g_news) return old;
244   scm *new = &g_news[g_free.value++];
245   *new = *old;
246   if (new->type == VECTOR)
247     for (int i=0; i<old->length; i++)
248       *(new+i+1) = old->vector[i];
249   old->type = BROKEN_HEART;
250   old->car = new;
251   return new;
252 }
253
254 scm *
255 gc_relocate_car (scm *new, scm *car)
256 {
257   new->car = car;
258   return &scm_unspecified;
259 }
260
261 scm *
262 gc_relocate_cdr (scm *new, scm *cdr)
263 {
264   new->cdr = cdr;
265   return &scm_unspecified;
266 }
267
268 scm *
269 gc_flip ()
270 {
271   scm *cells = g_cells;
272   g_cells = g_news;
273   g_news = cells;
274   (g_cells-1)->vector = g_news;
275   (g_news-1)->vector = g_cells;
276
277   fprintf (stderr, " => jam[%d]\n", g_free.value);
278   // Reduce arena size to quickly get multiple GC's.
279   // Startup memory footprint is relatively high because of builtin
280   // function names
281   //ARENA_SIZE = g_free.value + GC_FREE + GC_SAFETY;
282   // fprintf (stderr, "ARENA SIZE => %d\n", ARENA_SIZE - GC_SAFETY);
283   symbols = &g_cells[1];
284   return &g_cells[0];
285 }
286
287 scm *
288 gc_bump ()
289 {
290   g_cells += g_free.value;
291   g_news += g_free.value;
292   ARENA_SIZE -= g_free.value;
293   g_free.value = 0;
294   return &scm_unspecified;
295 }
296
297 scm *
298 gc_show ()
299 {
300   fprintf (stderr, "cells: ");
301   display_ (stderr, g_cells-1);
302   fprintf (stderr, "\n");
303   fprintf (stderr, "news: ");
304   display_ (stderr, g_news-1);
305   fprintf (stderr, "\n");
306   return &scm_unspecified;
307 }
308
309 scm *
310 gc_make_cell (scm *type, scm *car, scm *cdr)
311 {
312   scm *x = gc_alloc (1);
313   assert (type->type == NUMBER);
314   x->type = type->value;
315   if (type->value == CHAR || type->value == NUMBER) {
316     if (car) x->car = car->car;
317     if (cdr) x->cdr = cdr->cdr;
318   } else {
319     x->car = car;
320     x->cdr = cdr;
321   }
322   return x;
323 }
324
325 scm *
326 gc_make_vector (scm *n)
327 {
328   scm t = {NUMBER, .value=VECTOR};
329   scm *v = gc_alloc (n->value);
330   scm *x = gc_make_cell (&t, (scm*)(long)n->value, v);
331   for (int i=0; i<n->value; i++) x->vector[i] = *vector_entry (&scm_unspecified);
332   return x;
333 }
334
335 scm *
336 make_cell (scm *type, scm *car, scm *cdr)
337 {
338   scm *x = alloc (1);
339   assert (type->type == NUMBER);
340   x->type = type->value;
341   if (type->value == CHAR || type->value == NUMBER) {
342     if (car) x->car = car->car;
343     if (cdr) x->cdr = cdr->cdr;
344   } else {
345     x->car = car;
346     x->cdr = cdr;
347   }
348   return x;
349 }
350
351 scm *
352 cons (scm *x, scm *y)
353 {
354   scm t = {NUMBER, .value=PAIR};
355   return make_cell (&t, x, y);
356 }
357
358 scm *
359 eq_p (scm *x, scm *y)
360 {
361   return (x == y
362           || (x->type == CHAR && y->type == CHAR
363               && x->value == y->value)
364           || (x->type == NUMBER && y->type == NUMBER
365               && x->value == y->value))
366     ? &scm_t : &scm_f;
367 }
368
369 scm *
370 set_car_x (scm *x, scm *e)
371 {
372   assert (x->type == PAIR);
373   x->car = e;
374   return &scm_unspecified;
375 }
376
377 scm *
378 set_cdr_x (scm *x, scm *e)
379 {
380   assert (x->type == PAIR);
381   cache_invalidate (x->cdr);
382   x->cdr = e;
383   return &scm_unspecified;
384 }
385
386 scm *
387 set_env_x (scm *x, scm *e, scm *a)
388 {
389   cache_invalidate (x);
390   scm *p = assert_defined (x, assq (x, a));
391   return set_cdr_x (p, e);
392 }
393
394 scm *
395 quote (scm *x)
396 {
397   return cons (&symbol_quote, x);
398 }
399
400 scm *
401 quasiquote (scm *x)
402 {
403   return cons (&symbol_quasiquote, x);
404 }
405
406 scm *
407 quasisyntax (scm *x)
408 {
409   return cons (&symbol_quasisyntax, x);
410 }
411
412 scm *
413 pairlis (scm *x, scm *y, scm *a)
414 {
415   if (x == &scm_nil)
416     return a;
417   if (pair_p (x) == &scm_f)
418     return cons (cons (x, y), a);
419   return cons (cons (car (x), car (y)),
420                pairlis (cdr (x), cdr (y), a));
421 }
422
423 scm *
424 assq (scm *x, scm *a)
425 {
426   while (a != &scm_nil && eq_p (x, a->car->car) == &scm_f)
427     {
428       if (a->type == BROKEN_HEART || a->car->type == BROKEN_HEART)
429         fprintf (stderr, "oops, broken heart\n");
430       a = a->cdr;
431     }
432   return a != &scm_nil ? a->car : &scm_f;
433 }
434
435 #define ENV_CACHE 1
436 #define CACHE_SIZE 30
437 #define ENV_HEAD 15
438
439 #if !ENV_CACHE
440 scm *
441 assq_ref_cache (scm *x, scm *a)
442 {
443   x = assq (x, a);
444   if (x == &scm_f) return &scm_undefined;
445   return x->cdr;
446 }
447 scm*cache_invalidate (scm*x){}
448 scm*cache_invalidate_range (scm*p,scm*a){}
449 scm*cache_save (scm*p){}
450 scm*cache_lookup (scm*x){}
451
452 #else // ENV_CACHE
453
454 scm *env_cache_cars[CACHE_SIZE];
455 scm *env_cache_cdrs[CACHE_SIZE];
456 int cache_threshold = 0;
457 scm *
458 cache_save (scm *p)
459 {
460   int n = p->car->hits;
461   if (n < cache_threshold) return &scm_unspecified;
462   int j = -1;
463   for (int i=0; i < CACHE_SIZE; i++) {
464     if (!env_cache_cars[i]) {
465       j = i;
466       break;
467     }
468     if (env_cache_cars[i] == p->car) return &scm_unspecified;
469     if (n > env_cache_cars[i]->hits) {
470       n = env_cache_cars[i]->hits;
471       j = i;
472     }
473   }
474   if (j >= 0) {
475     cache_threshold = p->car->hits;
476     env_cache_cars[j] = p->car;
477     env_cache_cdrs[j] = p->cdr;
478   }
479   return &scm_unspecified;
480 }
481
482 scm *
483 cache_lookup (scm *x)
484 {
485   for (int i=0; i < CACHE_SIZE; i++) {
486     if (!env_cache_cars[i]) break;
487     if (env_cache_cars[i] == x) return env_cache_cdrs[i];
488   }
489   return &scm_undefined;
490 }
491
492 scm *
493 cache_invalidate (scm *x)
494 {
495   for (int i=0; i < CACHE_SIZE; i++) {
496     if (env_cache_cars[i] == x) {
497       env_cache_cars[i] = 0;
498       break;
499     }
500   }
501   return &scm_unspecified;
502 }
503
504 scm *
505 cache_invalidate_range (scm *p, scm *a)
506 {
507   do {
508     cache_invalidate (p->car->car);
509     p = p->cdr;
510   } while (p != a);
511   return &scm_unspecified;
512 }
513
514 scm *
515 assq_ref_cache (scm *x, scm *a)
516 {
517   x->hits++;
518   scm *c = cache_lookup (x);
519   if (c != &scm_undefined) return c;
520   int i = 0;
521   while (a != &scm_nil && x != a->car->car) {i++;a = a->cdr;}
522   if (a == &scm_nil) return &scm_undefined;
523   if (i>ENV_HEAD) cache_save (a->car);
524   return a->car->cdr;
525 }
526 #endif // ENV_CACHE
527
528 scm *
529 assert_defined (scm *x, scm *e)
530 {
531   if (e == &scm_undefined)
532     {
533       fprintf (stderr, "eval: unbound variable:");
534       display_ (stderr, x);
535       fprintf (stderr, "\n");
536       assert (!"unbound variable");
537     }
538   return e;
539 }
540
541 scm *
542 vm_call (function0_t f, scm *p1, scm *p2, scm *a)
543 {
544   scm *frame = cons (r1, cons (r2, cons (r3, cons (r0, &scm_nil))));
545   stack = cons (frame, stack);
546   r1 = p1;
547   r2 = p2;
548   r0 = a;
549   //if (f == vm_expand_macro_env && g_free.value + GC_SAFETY > ARENA_SIZE)
550   if (g_free.value + GC_SAFETY > ARENA_SIZE)
551     {
552       frame = cons (r1, cons (r2, cons (r3, cons (r0, &scm_nil))));
553       stack = cons (frame, stack);
554       scm *x = gc (stack);
555       *stack = *x;
556       frame = car (stack);      
557       stack = cdr (stack);
558       r1 = car (frame);
559       r2 = cadr (frame);
560       r3 = caddr (frame);
561       r0 = cadddr (frame);
562     }
563
564   scm *r = f ();
565   frame = car (stack);
566   stack = cdr (stack);
567   r1 = car (frame);
568   r2 = cadr (frame);
569   r3 = caddr (frame);
570   r0 = cadddr (frame);
571   return r; 
572 }
573
574 scm *
575 evlis_env (scm *m, scm *a)
576 {
577   return vm_call (vm_evlis_env, m, &scm_undefined, a);
578 }
579
580 scm *
581 apply_env (scm *fn, scm *x, scm *a)
582 {
583   return vm_call (vm_apply_env, fn, x, a);
584 }
585
586 scm *
587 eval_env (scm *e, scm *a)
588 {
589   return vm_call (vm_eval_env, e, &scm_undefined, a);
590 }
591
592 scm *
593 expand_macro_env (scm *e, scm *a)
594 {
595   return vm_call (vm_expand_macro_env, e, &scm_undefined, a);
596 }
597
598 scm *
599 begin_env (scm *e, scm *a)
600 {
601   return vm_call (vm_begin_env, e, &scm_undefined, a);
602 }
603
604 scm *
605 if_env (scm *e, scm *a)
606 {
607   return vm_call (vm_if_env, e, &scm_undefined, a);
608 }
609
610 scm *
611 call_lambda (scm *e, scm *x, scm* aa, scm *a) ///((internal))
612 {
613   scm *cl = cons (cons (&scm_closure, x), x);
614   r1 = e;
615   r0 = cl;
616   r2 = a;
617   r3 = aa;
618   cache_invalidate_range (r0, r3->cdr);
619   scm *r = vm_call_lambda ();
620   cache_invalidate_range (r0, r3->cdr);
621   return r;
622 }
623
624 scm *
625 vm_evlis_env ()
626 {
627   if (r1 == &scm_nil) return &scm_nil;
628   if (r1->type != PAIR) return eval_env (r1, r0);
629   r2 = eval_env (car (r1), r0);
630   r1 = evlis_env (cdr (r1), r0);
631   return cons (r2, r1);
632 }
633
634 scm *
635 vm_call_lambda ()
636 {
637   return vm_call (vm_begin_env, r1, &scm_undefined, r0);
638 }
639
640 scm *
641 vm_apply_env ()
642 {
643   if (r1->type != PAIR)
644     {
645       if (r1->type == FUNCTION) return call (r1, r2);
646       if (r1 == &symbol_call_with_values)
647         return call (&scm_call_with_values_env, append2 (r2, cons (r0, &scm_nil)));
648       if (r1 == &symbol_current_module) return r0;
649     }
650   else if (r1->car == &symbol_lambda) {
651     scm *args = cadr (r1);
652     scm *body = cddr (r1);
653     scm *p = pairlis (args, r2, r0);
654     return call_lambda (body, p, p, r0);
655     // r2 = p;
656     // cache_invalidate_range (r2, r0->cdr);
657     // scm *r = begin_env (cddr (r1), cons (cons (&scm_closure, p), p));
658     // cache_invalidate_range (r2, r0->cdr);
659     // return r;
660   }
661   else if (r1->car == &scm_closure) {
662     scm *args = caddr (r1);
663     scm *body = cdddr (r1);
664     scm *aa = cdadr (r1);
665     aa = cdr (aa);
666     scm *p = pairlis (args, r2, aa);
667     return call_lambda (body, p, aa, r0);
668     // r2 = p;
669     // r3 = aa;
670     // cache_invalidate_range (r2, r3->cdr);
671     // scm *r = begin_env (body, cons (cons (&scm_closure, p), p));
672     // cache_invalidate_range (r2, r3->cdr);
673     // return r;
674   }
675 #if BOOT
676   else if (r1->car == &scm_label)
677     return apply_env (caddr (r1), r2, cons (cons (cadr (r1), caddr (r1)), r0));
678 #endif
679   scm *e = eval_env (r1, r0);
680   char const* type = 0;
681   if (e == &scm_f || e == &scm_t) type = "bool";
682   if (e->type == CHAR) type = "char";
683   if (e->type == NUMBER) type = "number";
684   if (e->type == STRING) type = "string";
685   if (e == &scm_unspecified) type = "*unspecified*";
686   if (e == &scm_undefined) type =  "*undefined*";
687   if (type)
688     {
689       fprintf (stderr, "cannot apply: %s: ", type);
690       display_ (stderr, e);
691       fprintf (stderr, " [");
692       display_ (stderr, r1);
693       fprintf (stderr, "]\n");
694       assert (!"cannot apply");
695     }
696   return apply_env (e, r2, r0);
697 }
698
699 scm*cstring_to_list (char const* s);
700
701 scm *
702 vm_eval_env ()
703 {
704   switch (r1->type)
705     {
706     case PAIR:
707       {
708         if (r1->car == &symbol_quote)
709           return cadr (r1);
710 #if QUASISYNTAX
711         if (r1->car == &symbol_syntax)
712           return r1;
713 #endif
714         if (r1->car == &symbol_begin)
715           return begin_env (r1, r0);
716         if (r1->car == &symbol_lambda)
717           return make_closure (cadr (r1), cddr (r1), assq (&scm_closure, r0));
718         if (r1->car == &scm_closure)
719           return r1;
720         if (r1->car == &symbol_if)
721           return if_env (cdr (r1), r0);
722 #if !BOOT
723         if (r1->car == &symbol_define)
724           return define_env (r1, r0);
725         if (r1->car == &symbol_define_macro)
726           return define_env (r1, r0);
727         if (r1->car == &symbol_primitive_load)
728           return load_env (r0);
729 #else
730         if (r1->car == &symbol_define) {
731         fprintf (stderr, "C DEFINE: ");
732         display_ (stderr,
733                   r1->cdr->car->type == SYMBOL
734                   ? r1->cdr->car->string
735                   : r1->cdr->car->car->string);
736         fprintf (stderr, "\n");
737       }
738       assert (r1->car != &symbol_define);
739       assert (r1->car != &symbol_define_macro);
740 #endif
741 #if 1 //!BOOT
742       if (r1->car == &symbol_set_x)
743         return set_env_x (cadr (r1), eval_env (caddr (r1), r0), r0);
744 #else
745       assert (r1->car != &symbol_set_x);
746 #endif
747 #if QUASIQUOTE
748       if (r1->car == &symbol_unquote)
749         return eval_env (cadr (r1), r0);
750       if (r1->car == &symbol_quasiquote)
751         return eval_quasiquote (cadr (r1), add_unquoters (r0));
752 #endif //QUASIQUOTE
753 #if QUASISYNTAX
754       if (r1->car == &symbol_unsyntax)
755         return eval_env (cadr (r1), r0);
756       if (r1->car == &symbol_quasisyntax)
757         return eval_quasisyntax (cadr (r1), add_unsyntaxers (r0));
758 #endif //QUASISYNTAX
759       scm *x = expand_macro_env (r1, r0);
760       if (x != r1)
761           return eval_env (x, r0);
762       scm *m = evlis_env (r1->cdr, r0);
763       return apply_env (r1->car, m, r0);
764       }
765     case SYMBOL: return assert_defined (r1, assq_ref_cache (r1, r0));
766     default: return r1;
767     }
768 }
769
770 scm *
771 vm_expand_macro_env ()
772 {
773   if (car (r1)->type == STRING && string_to_symbol (car (r1)) == &symbol_noexpand)
774     return cadr (r1);
775
776   scm *macro;
777   scm *expanders;
778   if (r1->type == PAIR
779       && (macro = lookup_macro (r1->car, r0)) != &scm_f)
780     return apply_env (macro, r1->cdr, r0);
781   else if (r1->type == PAIR
782     && car (r1)->type == SYMBOL
783     && ((expanders = assq_ref_cache (&symbol_sc_expander_alist, r0)) != &scm_undefined)
784     && ((macro = assq (car (r1), expanders)) != &scm_f))
785     {
786       scm *sc_expand = assq_ref_cache (&symbol_expand_macro, r0);
787       if (sc_expand != &scm_undefined && sc_expand != &scm_f)
788         r1 = apply_env (sc_expand, cons (r1, &scm_nil), r0);
789     }
790   return r1;
791 }
792
793 scm *
794 vm_begin_env ()
795 {
796   scm *r = &scm_unspecified;
797   while (r1 != &scm_nil) {
798     if (car (r1)->type == PAIR && caar (r1) == &symbol_begin)
799       r1 = append2 (cdar (r1), cdr (r1));
800     r = eval_env (r1->car, r0);
801     r1 = r1->cdr;
802   }
803   return r;
804 }
805
806 scm *
807 vm_if_env ()
808 {
809   scm *x = eval_env (car (r1), r0);
810   if (x != &scm_f)
811     return eval_env (cadr (r1), r0);
812   if (cddr (r1) != &scm_nil)
813     return eval_env (caddr (r1), r0);
814   return &scm_unspecified;
815 }
816
817 //Helpers
818
819 scm *
820 display (scm *x) ///((arity . n))
821 {
822   scm *e = car (x);
823   scm *p = cdr (x);
824   int fd = 1;
825   if (p->type == PAIR && p->car->type == NUMBER) fd = p->car->hits;
826   FILE *f = fd == 1 ? stdout : stderr;
827   return display_helper (f, e, false, "", false);
828 }
829
830 scm *
831 display_ (FILE* f, scm *x)
832 {
833   return display_helper (f, x, false, "", false);
834 }
835
836 scm *
837 call (scm *fn, scm *x)
838 {
839   if ((fn->function->arity > 0 || fn->function->arity == -1)
840       && x != &scm_nil && car (x)->type == VALUES)
841     x = cons (x->car->cdr->car, x->cdr);
842   if ((fn->function->arity > 1 || fn->function->arity == -1)
843       && x != &scm_nil && x->cdr->car->type == VALUES)
844     x = cons (x->car, cons (x->cdr->car->cdr->car, x->cdr));
845   switch (fn->function->arity)
846     {
847     case 0: return fn->function->function0 ();
848     case 1: return fn->function->function1 (car (x)); 
849     case 2: return fn->function->function2 (car (x), cadr (x));
850     case 3: return fn->function->function3 (car (x), cadr (x), caddr (x)); 
851     case -1: return fn->function->functionn (x);
852     }
853   return &scm_unspecified;
854 }
855
856 scm *
857 append2 (scm *x, scm *y)
858 {
859   if (x == &scm_nil) return y;
860   assert (x->type == PAIR);
861   return cons (car (x), append2 (cdr (x), y));
862 }
863
864 scm *
865 append (scm *x) ///((arity . n))
866  {
867   if (x == &scm_nil) return &scm_nil;
868   return append2 (car (x), append (cdr (x)));
869  }
870
871 scm *
872 make_char (int x)
873 {
874   scm t = {NUMBER, .value=CHAR};
875   scm n = {NUMBER, .value=x};  
876   return make_cell (&t, &n, &n);
877 }
878
879 scm *
880 make_macro (scm *name, scm *x)
881 {
882   scm t = {NUMBER, .value=MACRO};
883   return make_cell (&t, name->string, x);
884 }
885
886 scm *
887 make_number (int x)
888 {
889   scm t = {NUMBER, .value=NUMBER};
890   scm n = {NUMBER, .value=x};  
891   return make_cell (&t, &n, &n);
892 }
893
894 scm *
895 make_ref (scm *x)
896 {
897   scm t = {NUMBER, .value=REF};
898   return make_cell (&t, x, x);
899 }
900
901 scm *
902 make_string (scm *x)
903 {
904   scm t = {NUMBER, .value=STRING};
905   return make_cell (&t, x, 0);
906 }
907
908 scm *
909 cstring_to_list (char const* s)
910 {
911   scm *p = &scm_nil;
912   while (s && *s)
913     p = append2 (p, cons (make_char (*s++), &scm_nil));
914   return p;
915 }
916
917 scm *
918 list_of_char_equal_p (scm *a, scm *b)
919 {
920   while (a != &scm_nil && b != &scm_nil && a->car->value == b->car->value) {
921     assert (a->car->type == CHAR);
922     assert (b->car->type == CHAR);
923     a = a->cdr;
924     b = b->cdr;
925   }
926   return (a == &scm_nil && b == &scm_nil) ? &scm_t : &scm_f;
927 }
928
929 scm *
930 internal_lookup_symbol (scm *s)
931 {
932   scm *x = symbols;
933   while (x) {
934     // .string and .name is the same field; .name is used as a handy
935     // static field initializer.  A string can only be mistaken for a
936     // cell with type == PAIR for the one character long, zero-padded
937     // #\etx.
938     if (x->car->string->type != PAIR)
939       x->car->string = cstring_to_list (x->car->name);
940     if (list_of_char_equal_p (x->car->string, s) == &scm_t) break;
941     x = x->cdr;
942   }
943   if (x) x = x->car;
944   return x;
945 }
946
947 scm *
948 internal_make_symbol (scm *s)
949 {
950   scm t = {NUMBER, .value=SYMBOL};
951   scm *x = make_cell (&t, s, 0);
952   symbols = cons (x, symbols);
953   return x;
954 }
955
956 scm *
957 make_symbol (scm *s)
958 {
959   scm *x = internal_lookup_symbol (s);
960   return x ? x : internal_make_symbol (s);
961 }
962
963 scm *
964 make_vector (scm *n)
965 {
966   scm t = {NUMBER, .value=VECTOR};
967   scm *v = alloc (n->value);
968   scm *x = make_cell (&t, (scm*)(long)n->value, v);
969   for (int i=0; i<n->value; i++) x->vector[i] = *vector_entry (&scm_unspecified);
970   return x;
971 }
972
973 scm *
974 values (scm *x) ///((arity . n))
975 {
976   scm *v = cons (0, x);
977   v->type = VALUES;
978   return v;
979 }
980
981 scm *
982 call_with_values_env (scm *producer, scm *consumer, scm *a)
983 {
984   scm *v = apply_env (producer, &scm_nil, a);
985   if (v->type == VALUES)
986     v = v->cdr;
987   return apply_env (consumer, v, a);
988 }
989
990 scm *
991 vector_length (scm *x)
992 {
993   assert (x->type == VECTOR);
994   return make_number (x->length);
995 }
996
997 scm *
998 vector_ref (scm *x, scm *i)
999 {
1000   assert (x->type == VECTOR);
1001   assert (i->value < x->length);
1002   scm *e = &x->vector[i->value];
1003   if (e->type == REF) e = e->ref;
1004   if (e->type == CHAR) e = make_char (e->value);
1005   if (e->type == NUMBER) e = make_number (e->value);
1006   return e;
1007 }
1008
1009 scm *
1010 vector_entry (scm *x) {
1011   if (x->type == PAIR || x->type == SCM || x->type == STRING || x->type == SYMBOL || x->type == VECTOR) x = make_ref (x);
1012   return x;
1013 }
1014
1015 scm *
1016 vector_set_x (scm *x, scm *i, scm *e)
1017 {
1018   assert (x->type == VECTOR);
1019   assert (i->value < x->length);
1020   x->vector[i->value] = *vector_entry (e);
1021   return &scm_unspecified;
1022 }
1023
1024 scm *
1025 lookup (scm *s, scm *a)
1026 {
1027   if (isdigit (s->car->value) || (s->car->value == '-' && s->cdr != &scm_nil)) {
1028     scm *p = s;
1029     int sign = 1;
1030     if (s->car->value == '-') {
1031       sign = -1;
1032       p = s->cdr;
1033     }
1034     int n = 0;
1035     while (p != &scm_nil && isdigit (p->car->value)) {
1036       n *= 10;
1037       n += p->car->value - '0';
1038       p = p->cdr;
1039     }
1040     if (p == &scm_nil) return make_number (n * sign);
1041   }
1042   
1043   scm *x = internal_lookup_symbol (s);
1044   if (x) return x;
1045
1046   if (s->cdr == &scm_nil) {
1047     if (s->car->value == '\'') return &symbol_quote;
1048     if (s->car->value == '`') return &symbol_quasiquote;
1049     if (s->car->value == ',') return &symbol_unquote;
1050   }
1051   else if (s->cdr->cdr == &scm_nil) {
1052     if (s->car->value == ',' && s->cdr->car->value == '@') return &symbol_unquote_splicing;
1053     if (s->car->value == '#' && s->cdr->car->value == '\'') return &symbol_syntax;
1054     if (s->car->value == '#' && s->cdr->car->value == '`') return &symbol_quasisyntax;
1055     if (s->car->value == '#' && s->cdr->car->value == ',') return &symbol_unsyntax;
1056   }
1057   else if (s->cdr->cdr->cdr == &scm_nil) {
1058     if (s->car->value == '#' && s->cdr->car->value == ',' && s->cdr->cdr->car->value == '@') return &symbol_unsyntax_splicing;
1059     if (s->car->value == 'E' && s->cdr->car->value == 'O' && s->cdr->cdr->car->value == 'F') {
1060       fprintf (stderr, "mes: got EOF\n");
1061       return &scm_nil; // `EOF': eval program, which may read stdin
1062     }
1063   }
1064
1065   return internal_make_symbol (s);
1066 }
1067
1068 scm *
1069 lookup_char (int c, scm *a)
1070 {
1071   return lookup (cons (make_char (c), &scm_nil), a);
1072 }
1073
1074 scm *
1075 list_to_vector (scm *x)
1076 {
1077   scm n = {NUMBER, .value=length (x)->value};
1078   scm *v = make_vector (&n);
1079   scm *p = v->vector;
1080   while (x != &scm_nil)
1081     {
1082       *p++ = *vector_entry (car (x));
1083       x = cdr (x);
1084     }
1085   return v;
1086 }
1087
1088 scm *
1089 newline (scm *p) ///((arity . n))
1090 {
1091   int fd = 1;
1092   if (p->type == PAIR && p->car->type == NUMBER) fd = p->car->value;
1093   FILE *f = fd == 1 ? stdout : stderr;
1094   fputs ("\n", f);
1095   return &scm_unspecified;
1096 }
1097
1098 scm *
1099 force_output (scm *p) ///((arity . n))
1100 {
1101   int fd = 1;
1102   if (p->type == PAIR && p->car->type == NUMBER) fd = p->car->value;
1103   FILE *f = fd == 1 ? stdout : stderr;
1104   fflush (f);
1105 }
1106
1107 scm *
1108 display_helper (FILE* f, scm *x, bool cont, char const *sep, bool quote)
1109 {
1110   scm *r;
1111   fprintf (f, "%s", sep);
1112   switch (x->type)
1113     {
1114     case CHAR:
1115       {
1116         char const *name = 0;
1117         if (x->value == char_nul.value) name = char_nul.name;
1118         else if (x->value == char_backspace.value) name = char_backspace.name;
1119         else if (x->value == char_tab.value) name = char_tab.name;
1120         else if (x->value == char_newline.value) name = char_newline.name;
1121         else if (x->value == char_vt.value) name = char_vt.name;
1122         else if (x->value == char_page.value) name = char_page.name;
1123         else if (x->value == char_return.value) name = char_return.name;
1124         else if (x->value == char_space.value) name = char_space.name;
1125         if (name) fprintf (f, "#\\%s", name);
1126         else fprintf (f, "#\\%c", x->value);
1127         break;
1128       }
1129     case MACRO:
1130       fprintf (f, "(*macro* ");
1131       display_helper (f, x->macro, cont, sep, quote);
1132       fprintf (f, ")");
1133       break;
1134     case NUMBER: fprintf (f, "%d", x->value); break;
1135     case PAIR:
1136       {
1137         if (car (x) == &scm_circular) {
1138           fprintf (f, "(*circ* . #-1#)");
1139           return &scm_unspecified;
1140         }
1141         if (car (x) == &scm_closure) {
1142           fprintf (f, "(*closure* . #-1#)");
1143           return &scm_unspecified;
1144         }
1145         if (car (x) == &scm_quote) {
1146           fprintf (f, "'");
1147           return display_helper (f, car (cdr (x)), cont, "", true);
1148         }
1149         if (!cont) fprintf (f, "(");
1150         display_ (f, car (x));
1151         if (cdr (x) && cdr (x)->type == PAIR)
1152           display_helper (f, cdr (x), true, " ", false);
1153         else if (cdr (x) != &scm_nil) {
1154           fprintf (f, " . ");
1155           display_ (f, cdr (x));
1156         }
1157         if (!cont) fprintf (f, ")");
1158         break;
1159       }
1160     case VECTOR:
1161       {
1162         fprintf (f, "#(", x->length);
1163         for (int i = 0; i < x->length; i++) {
1164           if (x->vector[i].type == VECTOR
1165               || (x->vector[i].type == REF
1166                   && x->vector[i].ref->type == VECTOR))
1167             fprintf (f, "%s#(...)", i ? " " : "");
1168           else
1169             display_helper (f, &x->vector[i], false, i ? " " : "", false);
1170         }
1171         fprintf (f, ")");
1172         break;
1173       }
1174     case REF: display_helper (f, x->ref, cont, "", true); break;
1175     case FUNCTION: fprintf (f, "#<procedure %s>", x->name); ;break;
1176     case BROKEN_HEART: fprintf (f, "<3"); break;
1177     default:
1178       if (x->string)
1179         {
1180           scm *p = x->string;
1181           assert (p);
1182           while (p != &scm_nil) {
1183             assert (p->car->type == CHAR);
1184             fputc (p->car->value, f);
1185             p = p->cdr;
1186           }
1187         }
1188       else if (x->type != PAIR && x->name) fprintf (f, "%s", x->name);
1189     }
1190   return &scm_unspecified;
1191 }
1192
1193 // READ
1194
1195 FILE *g_stdin;
1196 int
1197 getchar ()
1198 {
1199   return getc (g_stdin);
1200 }
1201
1202 int
1203 ungetchar (int c)
1204 {
1205   return ungetc (c, g_stdin);
1206 }
1207
1208 int
1209 peekchar ()
1210 {
1211   int c = getchar ();
1212   ungetchar (c);
1213   return c;
1214 }
1215
1216 scm *
1217 peek_char ()
1218 {
1219   return make_char (peekchar ());
1220 }
1221
1222 scm *
1223 read_char ()
1224 {
1225   return make_char (getchar ());
1226 }
1227
1228 scm *
1229 write_char (scm *x) ///((arity . n))
1230 {
1231   scm *c = car (x);
1232   scm *p = cdr (x);
1233   int fd = 1;
1234   if (p->type == PAIR && p->car->type == NUMBER) fd = p->car->value;
1235   FILE *f = fd == 1 ? stdout : stderr;
1236   assert (c->type == NUMBER || c->type == CHAR);
1237   fputc (c->value, f);
1238   return c;
1239 }
1240
1241 scm *
1242 unget_char (scm *c)
1243 {
1244   assert (c->type == NUMBER || c->type == CHAR);
1245   ungetchar (c->value);
1246   return c;
1247 }
1248
1249 int
1250 readcomment (int c)
1251 {
1252   if (c == '\n') return c;
1253   return readcomment (getchar ());
1254 }
1255
1256 int
1257 readblock (int c)
1258 {
1259   if (c == '!' && peekchar () == '#') return getchar ();
1260   return readblock (getchar ());
1261 }
1262
1263 scm *
1264 readword (int c, scm *w, scm *a)
1265 {
1266   if (c == EOF && w == &scm_nil) return &scm_nil;
1267   if (c == '\n' && w == &scm_nil) return readword (getchar (), w, a);
1268   if (c == '\n' && w->car->value == '.' && w->cdr == &scm_nil) return &scm_dot;
1269   if (c == EOF || c == '\n') return lookup (w, a);
1270   if (c == ' ') return readword ('\n', w, a);
1271   if (c == '"' && w == &scm_nil) return readstring ();
1272   if (c == '"') {ungetchar (c); return lookup (w, a);}
1273   if (c == '(' && w == &scm_nil) return readlist (a);
1274   if (c == '(') {ungetchar (c); return lookup (w, a);}
1275   if (c == ')' && w == &scm_nil) {ungetchar (c); return &scm_nil;}
1276   if (c == ')') {ungetchar (c); return lookup (w, a);}
1277   if (c == ',' && peekchar () == '@') {getchar (); return cons (lookup (symbol_unquote_splicing.string, a),
1278                                                                    cons (readword (getchar (), w, a),
1279                                                                          &scm_nil));}
1280   if ((c == '\''
1281        || c == '`'
1282        || c == ',')
1283       && w == &scm_nil) {return cons (lookup_char (c, a),
1284                                      cons (readword (getchar (), w, a),
1285                                            &scm_nil));}
1286   if (c == '#' && peekchar () == ',' && w == &scm_nil) {
1287     getchar ();
1288     if (peekchar () == '@'){getchar (); return cons (lookup (symbol_unsyntax_splicing.string, a),
1289                                                      cons (readword (getchar (), w, a),
1290                                                            &scm_nil));}
1291     return cons (lookup (symbol_unsyntax.string, a), cons (readword (getchar (), w, a), &scm_nil));
1292   }
1293   if (c == '#' && (peekchar () == '\'' || peekchar () == '`') && w == &scm_nil) {
1294     c = getchar ();
1295     return cons (lookup (cons (make_char ('#'), cons (make_char (c), &scm_nil)), a),
1296                  cons (readword (getchar (), w, a), &scm_nil));}
1297   if (c == ';') {readcomment (c); return readword ('\n', w, a);}
1298   if (c == '#' && peekchar () == 'x') {getchar (); return read_hex ();}
1299   if (c == '#' && peekchar () == '\\') {getchar (); return read_character ();}
1300   if (c == '#' && w == &scm_nil && peekchar () == '(') {getchar (); return list_to_vector (readlist (a));}
1301   if (c == '#' && peekchar () == '(') {ungetchar (c); return lookup (w, a);}
1302   if (c == '#' && peekchar () == '!') {getchar (); readblock (getchar ()); return readword (getchar (), w, a);}
1303   return readword (getchar (), append2 (w, cons (make_char (c), &scm_nil)), a);
1304 }
1305
1306 scm *
1307 read_hex ()
1308 {
1309   int n = 0;
1310   int c = peekchar ();
1311   while ((c >= '0' && c <= '9')
1312          || (c >= 'A' && c <= 'F')
1313          || (c >= 'a' && c <= 'f')) {
1314     n <<= 4;
1315     if (c >= 'a') n += c - 'a' + 10;
1316     else if (c >= 'A') n += c - 'A' + 10;
1317     else n+= c - '0';
1318     getchar ();
1319     c = peekchar ();
1320   }
1321   return make_number (n);
1322 }
1323
1324 scm *
1325 read_character ()
1326 {
1327   int c = getchar ();
1328   if (c >= '0' && c <= '7'
1329       && peekchar () >= '0' && peekchar () <= '7') {
1330     c = c - '0';
1331     while (peekchar () >= '0' && peekchar () <= '7') {
1332       c <<= 3;
1333       c += getchar () - '0';
1334     }
1335   }
1336   else if (c >= 'a' && c <= 'z'
1337       && peekchar () >= 'a' && peekchar () <= 'z') {
1338     char buf[10];
1339     char *p = buf;
1340     *p++ = c;
1341     while (peekchar () >= 'a' && peekchar () <= 'z') {
1342       *p++ = getchar ();
1343     }
1344     *p = 0;
1345     if (!strcmp (buf, char_nul.name)) c = char_nul.value;
1346     else if (!strcmp (buf, char_backspace.name)) c = char_backspace.value;
1347     else if (!strcmp (buf, char_tab.name)) c = char_tab.value;
1348     else if (!strcmp (buf, char_newline.name)) c = char_newline.value;
1349     else if (!strcmp (buf, char_vt.name)) c = char_vt.value;
1350     else if (!strcmp (buf, char_page.name)) c = char_page.value;
1351     else if (!strcmp (buf, char_return.name)) c = char_return.value;
1352     else if (!strcmp (buf, char_space.name)) c = char_space.value;
1353     else {
1354       fprintf (stderr, "char not supported: %s\n", buf);
1355       assert (!"char not supported");
1356     }
1357   }
1358   return make_char (c);
1359 }
1360
1361 scm *
1362 append_char (scm *x, int i)
1363 {
1364   return append2 (x, cons (make_char (i), &scm_nil));
1365 }
1366
1367 scm *
1368 readstring ()
1369 {
1370   scm *p = &scm_nil;
1371   int c = getchar ();
1372   while (true) {
1373     if (c == '"') break;
1374     if (c == '\\' && peekchar () == '"') p = append_char (p, getchar ());
1375     else if (c == '\\' && peekchar () == 'n') {getchar (); p = append_char (p, '\n');}
1376     else if (c == EOF) assert (!"EOF in string");
1377     else p = append_char (p, c);
1378     c = getchar ();
1379   }
1380   return make_string (p);
1381 }
1382
1383 int
1384 eat_whitespace (int c)
1385 {
1386   while (c == ' ' || c == '\t' || c == '\n') c = getchar ();
1387   if (c == ';') return eat_whitespace (readcomment (c));
1388   if (c == '#' && peekchar () == '!') {getchar (); readblock (getchar ()); return eat_whitespace (getchar ());}
1389   return c;
1390 }
1391
1392 scm *
1393 readlist (scm *a)
1394 {
1395   int c = getchar ();
1396   c = eat_whitespace (c);
1397   if (c == ')') return &scm_nil;
1398   scm *w = readword (c, &scm_nil, a);
1399   if (w == &scm_dot)
1400     return car (readlist (a));
1401   return cons (w, readlist (a));
1402 }
1403
1404 scm *
1405 read_env (scm *a)
1406 {
1407   return readword (getchar (), &scm_nil, a);
1408 }
1409
1410 scm *
1411 acons (scm *key, scm *value, scm *alist)
1412 {
1413   return cons (cons (key, value), alist);
1414 }
1415
1416 scm *
1417 add_environment (scm *a, char const *name, scm *x)
1418 {
1419   return acons (make_symbol (cstring_to_list (name)), x, a);
1420 }
1421
1422 scm *
1423 mes_environment () ///((internal))
1424 {
1425   scm *a = &scm_nil;
1426
1427   // setup GC
1428   g_cells = (scm*)malloc (ARENA_SIZE*sizeof(scm));
1429   g_news = (scm*)malloc (ARENA_SIZE*sizeof(scm));
1430   g_cells[0].type = VECTOR;
1431   g_cells[0].length = ARENA_SIZE - 1;
1432   g_cells[0].vector = &g_cells[1];
1433   g_news[0].type = VECTOR;
1434   g_news[0].length = ARENA_SIZE - 1;
1435   g_news[0].vector = &g_news[1];
1436
1437   g_cells++;
1438   g_news++;
1439   // a = add_environment (a, "%free", &g_free); hihi, gets <3 moved
1440   // a = add_environment (a, "%the-cells", g_cells);
1441   // a = add_environment (a, "%new-cells", g_news);
1442
1443   #include "mes.symbols.i"
1444
1445 #if BOOT
1446   symbols = cons (&scm_label, symbols);
1447   a = cons (cons (&scm_label, &scm_t), a);
1448 #endif
1449   a = cons (cons (&symbol_begin, &scm_begin), a);
1450
1451 #if MES_FULL
1452 #include "posix.environment.i"
1453 #include "string.environment.i"
1454 #include "math.environment.i"
1455 #include "lib.environment.i"
1456 #include "mes.environment.i"
1457 //#include "quasiquote.environment.i"
1458 #include "define.environment.i"
1459 #include "type.environment.i"
1460 #else
1461    a = add_environment (a, "cons", &scm_cons);
1462    a = add_environment (a, "eq?", &scm_eq_p);
1463    a = add_environment (a, "display", &scm_display);
1464    a = add_environment (a, "newline", &scm_newline);
1465
1466 #if !MES_MINI
1467    a = add_environment (a, "*", &scm_multiply);
1468    a = add_environment (a, "list", &scm_list);
1469    //
1470    a = add_environment (a, "car", &scm_car);
1471    a = add_environment (a, "cdr", &scm_cdr);
1472    a = add_environment (a, "+", &scm_plus);
1473    a = add_environment (a, "quote", &scm_quote);
1474    a = add_environment (a, "null?", &scm_null_p);
1475    a = add_environment (a, "=", &scm_is_p);
1476
1477    // a = add_environment (a, "gc", &scm_gc);
1478    // a = add_environment (a, "apply-env", &scm_apply_env);
1479    // a = add_environment (a, "eval-env", &scm_eval_env);
1480    // a = add_environment (a, "cadr", &scm_cadr);
1481 #endif
1482 #endif
1483
1484   a = add_environment (a, "sc-expand", &scm_f);
1485
1486   a = cons (cons (&scm_closure, a), a);
1487
1488   internal_lookup_symbol (&scm_nil);
1489
1490   gc_bump (); // secure the .string of builtins, scm and symbols
1491   r0 = a;
1492   r1 = make_char (0);
1493   r2 = make_char (0);
1494   r3 = make_char (0);
1495   stack = cons (&scm_nil, &scm_nil);
1496
1497   return a;
1498 }
1499
1500 scm *
1501 make_lambda (scm *args, scm *body)
1502 {
1503   return cons (&symbol_lambda, cons (args, body));
1504 }
1505
1506 scm *
1507 make_closure (scm *args, scm *body, scm *a)
1508 {
1509   return cons (&scm_closure, cons (cons (&scm_circular, a), cons (args, body)));
1510 }
1511
1512 scm *
1513 lookup_macro (scm *x, scm *a)
1514 {
1515   if (x->type != SYMBOL) return &scm_f;
1516   scm *m = assq_ref_cache (x, a);
1517   if (macro_p (m) == &scm_t) return m->macro;
1518   return &scm_f;
1519 }
1520
1521 scm *
1522 read_input_file_env (scm *e, scm *a)
1523 {
1524   if (e == &scm_nil) return e;
1525   return cons (e, read_input_file_env (read_env (a), a));
1526 }
1527
1528 scm *
1529 load_env (scm *a)
1530 {
1531   return begin_env (read_input_file_env (read_env (a), a), a);
1532 }
1533
1534 #include "type.c"
1535 #include "define.c"
1536 #include "lib.c"
1537 #include "math.c"
1538 #include "posix.c"
1539 #include "quasiquote.c"
1540 #include "string.c"
1541
1542 int
1543 main (int argc, char *argv[])
1544 {
1545   if (argc > 1 && !strcmp (argv[1], "--help")) return puts ("Usage: mes < FILE\n");
1546   if (argc > 1 && !strcmp (argv[1], "--version")) return puts ("Mes 0.2\n");
1547   g_stdin = stdin;
1548   scm *a = mes_environment ();
1549   display_ (stderr, load_env (a));
1550   fputs ("", stderr);
1551   fprintf (stderr, "\nstats: [%d]\n", g_free.value);
1552   return 0;
1553 }