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