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