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