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