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