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