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