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