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