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