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