mes.c: add quotient and modulo.
[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   return make_symbol (x);
742 }
743
744 scm *
745 lookup_char (int c, scm *a)
746 {
747   char buf[2];
748   buf[0] = c;
749   buf[1] = 0;
750   return lookup (buf, a);
751 }
752
753 char *
754 list2str (scm *l) // char*
755 {
756   static char buf[256];
757   char *p = buf;
758   while (l != &scm_nil) {
759     scm *c = car (l);
760     assert (c->type == NUMBER);
761     *p++ = c->value;
762     l = cdr (l);
763   }
764   *p = 0;
765   return buf;
766 }
767
768 scm*
769 list_to_vector (scm *x)
770 {
771   int n = length (x)->value;
772   scm *v = make_vector (n);
773   scm **p = v->vector;
774   while (x != &scm_nil)
775     {
776       *p++ = car (x);
777       x = cdr (x);
778     }
779   return v;
780 }
781
782 scm*
783 integer_to_char (scm *x)
784 {
785   assert (x->type == NUMBER);
786   return make_char (x->value);
787 }
788
789 scm*
790 char_to_integer (scm *x)
791 {
792   assert (x->type == CHAR);
793   return make_number (x->value);
794 }
795
796 scm*
797 number_to_string (scm *x)
798 {
799   assert (x->type == NUMBER);
800   char buf[256];
801   sprintf (buf,"%d", x->value);
802   return make_string (buf);
803 }
804
805 scm*
806 builtin_exit (scm *x)
807 {
808   assert (x->type == NUMBER);
809   exit (x->value);
810 }
811
812 scm*
813 string_to_symbol (scm *x)
814 {
815   assert (x->type == STRING);
816   return make_symbol (x->name);
817 }
818
819 scm*
820 symbol_to_string (scm *x)
821 {
822   assert (x->type == SYMBOL);
823   return make_string (x->name);
824 }
825
826 scm*
827 vector_to_list (scm *v)
828 {
829   scm *x = &scm_nil;
830   for (int i = 0; i < v->length; i++)
831     x = append2 (x, cons (v->vector[i], &scm_nil));
832   return x;
833 }
834
835 scm *
836 newline ()
837 {
838   puts ("");
839   return &scm_unspecified;
840 }
841
842 scm *
843 display_helper (scm *x, bool cont, char *sep, bool quote)
844 {
845   scm *r;
846   printf ("%s", sep);
847   if (x->type == CHAR && x->value == 9) printf ("#\\%s", "tab");
848   else if (x->type == CHAR && x->value == 10) printf ("#\\%s", "newline");
849   else if (x->type == CHAR && x->value == 32) printf ("#\\%s", "space");
850   else if (x->type == CHAR) printf ("#\\%c", x->value);
851   else if (x->type == MACRO) {
852     printf ("(*macro* ");
853     display_helper (x->macro, cont, sep, quote);
854     printf (")");
855   }
856   else if (x->type == NUMBER) printf ("%d", x->value);
857   else if (x->type == PAIR) {
858     if (car (x) == &symbol_circ) {
859       printf ("(*circ* . #-1#)");
860       return &scm_unspecified;
861     }
862     if (car (x) == &symbol_closure) {
863       printf ("(*closure* . #-1#)");
864       return &scm_unspecified;
865     }
866     if (car (x) == &scm_quote) {
867       printf ("'");
868       return display_helper (car (cdr (x)), cont, "", true);
869     }
870     if (car (x) == &scm_quasiquote) {
871       printf ("`");
872       return display_helper (car (cdr (x)), cont, "", true);
873     }
874     if (car (x) == &scm_unquote) {
875       printf (",");
876       return display_helper (car (cdr (x)), cont, "", true);
877     }
878     if (car (x) == &scm_unquote_splicing) {
879       printf (",@");
880       return display_helper (car (cdr (x)), cont, "", true);
881     }
882     if (!cont) printf ("(");
883     display (car (x));
884     if (cdr (x)->type == PAIR)
885       display_helper (cdr (x), true, " ", false);
886     else if (cdr (x) != &scm_nil) {
887       printf (" . ");
888       display (cdr (x));
889     }
890     if (!cont) printf (")");
891   }
892   else if (x->type == VECTOR) {
893     printf ("#(", x->length);
894     for (int i = 0; i < x->length; i++) {
895       if (x->vector[i]->type == VECTOR)
896         printf ("%s#(...)", i ? " " : "");
897       else
898         display_helper (x->vector[i], false, i ? " " : "", false);
899     }
900     printf (")");
901   }
902   else if (atom_p (x) == &scm_t) printf ("%s", x->name);
903
904   return &scm_unspecified;
905 }
906
907 // READ
908
909 int
910 ungetchar (int c) //int
911 {
912   return ungetc (c, stdin);
913 }
914
915 int
916 peekchar () //int
917 {
918   int c = getchar ();
919   ungetchar (c);
920   return c;
921 }
922
923 scm*
924 builtin_getchar ()
925 {
926   return make_number (getchar ());
927 }
928
929 scm*
930 builtin_peekchar ()
931 {
932   return make_number (peekchar ());
933 }
934
935 scm*
936 builtin_ungetchar (scm *c)
937 {
938   assert (c->type == NUMBER);
939   ungetchar (c->value);
940   return c;
941 }
942
943 int
944 readcomment (int c)
945 {
946   if (c == '\n') return c;
947   return readcomment (getchar ());
948 }
949
950 int
951 readblock (int c)
952 {
953   if (c == '!' && peekchar () == '#') return getchar ();
954   return readblock (getchar ());
955 }
956
957 scm *
958 readword (int c, char* w, scm *a)
959 {
960   if (c == EOF && !w) return &scm_nil;
961   if (c == '\n' && !w) return readword (getchar (), w, a);
962   if (c == '\n' && *w == '.' && w[1] == 0) return &scm_dot;
963   if (c == EOF || c == '\n') return lookup (w, a);
964   if (c == ' ') return readword ('\n', w, a);
965   if (c == '"' && !w) return readstring ();
966   if (c == '"') {ungetchar (c); return lookup (w, a);}
967   if (c == '(' && !w) return readlist (a);
968   if (c == '(') {ungetchar (c); return lookup (w, a);}
969   if (c == ')' && !w) {ungetchar (c); return &scm_nil;}
970   if (c == ')') {ungetchar (c); return lookup (w, a);}
971   if (c == ',' && peekchar () == '@') {getchar (); return cons (lookup (",@", a),
972                                                                 cons (readword (getchar (), w, a),
973                                                                       &scm_nil));}
974   if ((c == '\''
975        || c == '`'
976        || c == ',')
977       && !w) {return cons (lookup_char (c, a),
978                                      cons (readword (getchar (), w, a),
979                                            &scm_nil));}
980   if (c == '#' && peekchar () == ',' && !w) {
981     getchar ();
982     if (peekchar () == '@'){getchar (); return cons (lookup ("#,@", a),
983                                                      cons (readword (getchar (), w, a),
984                                                            &scm_nil));}
985     return cons (lookup ("#,", a), cons (readword (getchar (), w, a), &scm_nil));
986   }
987   if (c == '#'
988      && (peekchar () == '\''
989          || peekchar () == '`')
990      && !w) {char buf[3] = "#"; buf[1] = getchar (); return cons (lookup (buf, a),
991                           cons (readword (getchar (), w, a),
992                                 &scm_nil));}
993    if (c == ';') {readcomment (c); return readword ('\n', w, a);}
994   if (c == '#' && peekchar () == '\\') {getchar (); return readchar ();}
995   if (c == '#' && !w && peekchar () == '(') {getchar (); return list_to_vector (readlist (a));}
996   if (c == '#' && peekchar () == '(') {ungetchar (c); return lookup (w, a);}
997   if (c == '#' && peekchar () == '!') {getchar (); readblock (getchar ()); return readword (getchar (), w, a);}
998   char buf[256] = {0};
999   char ch = c;
1000   return readword (getchar (), strncat (w ? w : buf, &ch, 1), a);
1001 }
1002
1003 scm *
1004 readchar ()
1005 {
1006   int c = getchar ();
1007   if (c >= '0' && c <= '7'
1008       && peekchar () >= '0' && peekchar () <= '7') {
1009     c = c - '0';
1010     while (peekchar () >= '0' && peekchar () <= '7') {
1011       c <<= 3;
1012       c += getchar () - '0';
1013     }
1014   }
1015   else if (c >= 'a' && c <= 'z'
1016       && peekchar () >= 'a' && peekchar () <= 'z') {
1017     char buf[256];
1018     char *p = buf;
1019     *p++ = c;
1020     while (peekchar () >= 'a' && peekchar () <= 'z') {
1021       *p++ = getchar ();
1022     }
1023     *p = 0;
1024     if (!strcmp (buf, "tab")) c = 9;
1025     else if (!strcmp (buf, "newline")) c = 10;
1026     else if (!strcmp (buf, "space")) c = 32;
1027     else {
1028       fprintf (stderr, "char not supported: %s\n", buf);
1029       assert (!"char not supported");
1030     }
1031   }
1032   return make_char (c);
1033 }
1034
1035 scm *
1036 readstring ()
1037 {
1038   char buf[256];
1039   char *p = buf;
1040   int c = getchar ();
1041   while (true) {
1042     if (c == '"') break;
1043     *p++ = c;
1044     if (c == '\\' && peekchar () == '"') *p++ = getchar ();
1045     if (c == EOF) assert (!"EOF in string");
1046     c = getchar ();
1047   }
1048   *p = 0;
1049   return make_string (buf);
1050 }
1051
1052 int
1053 eat_whitespace (int c)
1054 {
1055   while (c == ' ' || c == '\t' || c == '\n') c = getchar ();
1056   if (c == ';') return eat_whitespace (readcomment (c));
1057   if (c == '#' && peekchar () == '!') {getchar (); readblock (getchar ()); return eat_whitespace (getchar ());}
1058   return c;
1059 }
1060
1061 scm *
1062 readlist (scm *a)
1063 {
1064   int c = getchar ();
1065   c = eat_whitespace (c);
1066   if (c == ')') return &scm_nil;
1067   scm *w = readword (c, 0, a);
1068   if (w == &scm_dot)
1069     return car (readlist (a));
1070   return cons (w, readlist (a));
1071 }
1072
1073 scm *
1074 readenv (scm *a)
1075 {
1076   return readword (getchar (), 0, a);
1077 }
1078
1079 scm *
1080 greater_p (scm *x/*...*/)
1081 {
1082   int n = INT_MAX;
1083   while (x != &scm_nil)
1084     {
1085       assert (x->car->type == NUMBER);
1086       if (x->car->value >= n) return &scm_f;
1087       n = x->car->value;
1088       x = cdr (x);
1089     }
1090   return &scm_t;
1091 }
1092
1093 scm *
1094 less_p (scm *x/*...*/)
1095 {
1096   int n = INT_MIN;
1097   while (x != &scm_nil)
1098     {
1099       assert (x->car->type == NUMBER);
1100       if (x->car->value <= n) return &scm_f;
1101       n = x->car->value;
1102       x = cdr (x);
1103     }
1104   return &scm_t;
1105 }
1106
1107 scm *
1108 is_p (scm *x/*...*/)
1109 {
1110   if (x == &scm_nil) return &scm_t;
1111   assert (x->car->type == NUMBER);
1112   int n = x->car->value;
1113   x = cdr (x);
1114   while (x != &scm_nil)
1115     {
1116       if (x->car->value != n) return &scm_f;
1117       x = cdr (x);
1118     }
1119   return &scm_t;
1120 }
1121
1122 scm *
1123 minus (scm *x/*...*/)
1124 {
1125   scm *a = car (x);
1126   assert (a->type == NUMBER);
1127   int n = a->value;
1128   x = cdr (x);
1129   if (x == &scm_nil)
1130     n = -n;
1131   while (x != &scm_nil)
1132     {
1133       assert (x->car->type == NUMBER);
1134       n -= x->car->value;
1135       x = cdr (x);
1136     }
1137   return make_number (n);
1138 }
1139
1140 scm *
1141 plus (scm *x/*...*/)
1142 {
1143   int n = 0;
1144   while (x != &scm_nil)
1145     {
1146       assert (x->car->type == NUMBER);
1147       n += x->car->value;
1148       x = cdr (x);
1149     }
1150   return make_number (n);
1151 }
1152
1153 scm *
1154 divide (scm *x/*...*/)
1155 {
1156   int n = 1;
1157   if (x != &scm_nil) {
1158     assert (x->car->type == NUMBER);
1159     n = x->car->value;
1160     x = cdr (x);
1161   }
1162   while (x != &scm_nil)
1163     {
1164       assert (x->car->type == NUMBER);
1165       n /= x->car->value;
1166       x = cdr (x);
1167     }
1168   return make_number (n);
1169 }
1170
1171 scm *
1172 modulo (scm *a, scm *b)
1173 {
1174   assert (a->type == NUMBER);
1175   assert (b->type == NUMBER);
1176   return make_number (a->value % b->value);
1177 }
1178
1179 scm *
1180 multiply (scm *x/*...*/)
1181 {
1182   int n = 1;
1183   while (x != &scm_nil)
1184     {
1185       assert (x->car->type == NUMBER);
1186       n *= x->car->value;
1187       x = cdr (x);
1188     }
1189   return make_number (n);
1190 }
1191
1192 scm *add_environment (scm *a, char *name, scm *x);
1193
1194 scm *
1195 add_unquoters (scm *a)
1196 {
1197   a = add_environment (a, "unquote", &scm_unquote);
1198   a = add_environment (a, "unquote-splicing", &scm_unquote_splicing);
1199   return a;
1200 }
1201
1202 scm *
1203 add_environment (scm *a, char *name, scm *x)
1204 {
1205   return cons (cons (make_symbol (name), x), a);
1206 }
1207
1208 scm *
1209 mes_environment ()
1210 {
1211   scm *a = &scm_nil;
1212
1213   a = cons (cons (&scm_f, &scm_f), a);
1214   a = cons (cons (&scm_nil, &scm_nil), a);
1215   a = cons (cons (&scm_t, &scm_t), a);
1216   a = cons (cons (&scm_unspecified, &scm_unspecified), a);
1217   a = cons (cons (&symbol_begin, &symbol_begin), a);
1218   a = cons (cons (&symbol_quote, &scm_quote), a);
1219   a = cons (cons (&symbol_syntax, &scm_syntax), a);
1220   
1221 #if MES_FULL
1222 #include "environment.i"
1223 #else
1224   a = add_environment (a, "display", &scm_display);
1225   a = add_environment (a, "newline", &scm_newline);
1226 #endif
1227   a = cons (cons (&symbol_closure, a), a);
1228   return a;
1229 }
1230
1231 scm *
1232 make_lambda (scm *args, scm *body)
1233 {
1234   return cons (&symbol_lambda, cons (args, body));
1235 }
1236
1237 scm *
1238 make_closure (scm *args, scm *body, scm *a)
1239 {
1240   return cons (&symbol_closure, cons (cons (&symbol_circ, a), cons (args, body)));
1241 }
1242
1243 scm *
1244 define (scm *x, scm *a)
1245 {
1246   scm *e;
1247   scm *name = cadr (x);
1248   if (name->type != PAIR)
1249     e = eval (caddr (x), cons (cons (cadr (x), cadr (x)), a));
1250   else {
1251     name = car (name);
1252     scm *p = pairlis (cadr (x), cadr (x), a);
1253     e = eval (make_lambda (cdadr (x), cddr (x)), p);
1254   }
1255   if (eq_p (car (x), &symbol_define_macro) == &scm_t)
1256     e = make_macro (e);
1257   scm *entry = cons (name, e);
1258   scm *aa = cons (entry, &scm_nil);
1259   set_cdr_x (aa, cdr (a));
1260   set_cdr_x (a, aa);
1261   scm *cl = assq (&symbol_closure, a);
1262   set_cdr_x (cl, aa);
1263   return entry;
1264 }
1265  
1266 scm *
1267 lookup_macro (scm *x, scm *a)
1268 {
1269   scm *m = assq (x, a);
1270   if (m != &scm_f && macro_p (cdr (m)) != &scm_f)
1271     return cdr (m)->macro;
1272   return &scm_f;
1273 }
1274
1275 scm *
1276 read_file (scm *e, scm *a)
1277 {
1278   if (e == &scm_nil) return e;
1279   return cons (e, read_file (readenv (a), a));
1280 }
1281
1282 int
1283 main (int argc, char *argv[])
1284 {
1285   scm *a = mes_environment ();
1286   display (eval (cons (&symbol_begin, read_file (readenv (a), a)), a));
1287   newline ();
1288   return 0;
1289 }