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