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