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