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