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