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