Remove static primitives hack.
[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, 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 = {SYMBOL, "()"};
70 scm scm_dot = {SYMBOL, "."};
71 scm scm_f = {SYMBOL, "#f"};
72 scm scm_t = {SYMBOL, "#t"};
73 scm scm_unspecified = {SYMBOL, "*unspecified*"};
74
75 scm symbol_closure = {SYMBOL, "*closure*"};
76 scm symbol_circ = {SYMBOL, "*circ*"};
77 scm symbol_lambda = {SYMBOL, "lambda"};
78 scm symbol_begin = {SYMBOL, "begin"};
79 scm symbol_if = {SYMBOL, "if"};
80 scm symbol_quote = {SYMBOL, "quote"};
81 scm symbol_quasiquote = {SYMBOL, "quasiquote"};
82 scm symbol_unquote = {SYMBOL, "unquote"};
83 scm symbol_unquote_splicing = {SYMBOL, "unquote-splicing"};
84
85 scm symbol_sc_expand = {SYMBOL, "sc-expand"};
86 scm symbol_syntax = {SYMBOL, "syntax"};
87 scm symbol_quasisyntax = {SYMBOL, "quasisyntax"};
88 scm symbol_unsyntax = {SYMBOL, "unsyntax"};
89 scm symbol_unsyntax_splicing = {SYMBOL, "unsyntax-splicing"};
90
91 scm symbol_call_with_values = {SYMBOL, "call-with-values"};
92 scm symbol_current_module = {SYMBOL, "current-module"};
93 scm symbol_define = {SYMBOL, "define"};
94 scm symbol_define_macro = {SYMBOL, "define-macro"};
95 scm symbol_set_x = {SYMBOL, "set!"};
96
97 scm char_nul = {CHAR, .name="nul", .value=0};
98 scm char_backspace = {CHAR, .name="backspace", .value=8};
99 scm char_tab = {CHAR, .name="tab", .value=9};
100 scm char_newline = {CHAR, .name="newline", .value=10};
101 scm char_vt = {CHAR, .name="vt", .value=11};
102 scm char_page = {CHAR, .name="page", .value=12};
103 scm char_return = {CHAR, .name="return", .value=13};
104 scm char_space = {CHAR, .name="space", .value=32};
105
106 // PRIMITIVES
107
108 #define ATOM_P(x) (x->type == PAIR ? &scm_f : &scm_t)
109 scm *
110 atom_p (scm *x)
111 {
112   return ATOM_P(x);
113 }
114
115 scm *
116 car (scm *x)
117 {
118   assert (x->type == PAIR);
119   return x->car;
120 }
121
122 scm *
123 cdr (scm *x)
124 {
125   assert (x->type == PAIR);
126   return x->cdr;
127 }
128
129 scm *
130 cons (scm *x, scm *y)
131 {
132   scm *p = (scm*)malloc (sizeof (scm));
133   p->type = PAIR;
134   p->car = x;
135   p->cdr = y;
136   return p;
137 }
138
139 #define EQ_P(x, y)\
140   ((x == y                                              \
141     || (x->type == CHAR && y->type == CHAR              \
142         && x->value == y->value)                        \
143     || (x->type == NUMBER && y->type == NUMBER          \
144         && x->value == y->value))                       \
145    ? &scm_t : &scm_f)
146
147 scm *
148 eq_p (scm *x, scm *y)
149 {
150   return EQ_P (x, y);
151 }
152
153 scm *
154 macro_p (scm *x)
155 {
156   return x->type == MACRO ? &scm_t : &scm_f;
157 }
158
159 scm *
160 null_p (scm *x)
161 {
162   return x == &scm_nil ? &scm_t : &scm_f;
163 }
164
165 #define PAIR_P(x) (x->type == PAIR ? &scm_t : &scm_f)
166 scm *
167 pair_p (scm *x)
168 {
169   return PAIR_P(x);
170 }
171
172 scm *
173 set_car_x (scm *x, scm *e)
174 {
175   assert (x->type == PAIR);
176   x->car = e;
177   return &scm_unspecified;
178 }
179
180 scm *
181 set_cdr_x (scm *x, scm *e)
182 {
183   assert (x->type == PAIR);
184   x->cdr = e;
185   return &scm_unspecified;
186 }
187
188 scm *
189 set_x (scm *x, scm *e, scm *a)
190 {
191   return set_cdr_x (assq (x, a), e);
192 }
193
194 scm *
195 set_env_x (scm *x, scm *e, scm *a)
196 {
197   return set_cdr_x (assq (x, a), e);
198 }
199
200 scm *
201 quote (scm *x)
202 {
203   return cons (&symbol_quote, x);
204 }
205
206 scm *
207 quasiquote (scm *x)
208 {
209   return cons (&symbol_quasiquote, x);
210 }
211
212 #if BUILTIN_QUASIQUOTE
213 scm *
214 unquote (scm *x) //int must not add to environment
215 {
216   return cons (&symbol_unquote, x);
217 }
218 scm *unquote (scm *x);
219 scm scm_unquote = {FUNCTION1, .name="unquote", .function1=&unquote};
220
221 scm *
222 unquote_splicing (scm *x) //int must not add to environment
223 {
224   return cons (&symbol_unquote_splicing, x);
225 }
226 scm *unquote_splicing (scm *x);
227 scm scm_unquote_splicing = {FUNCTION1, .name="unquote-splicing", .function1=&unquote_splicing};
228 #endif // BUILTIN_QUASIQUOTE
229 scm *
230 syntax (scm *x)
231 {
232   return cons (&symbol_syntax, x);
233 }
234
235 scm *
236 quasisyntax (scm *x)
237 {
238   return cons (&symbol_quasisyntax, x);
239 }
240
241 scm *
242 unsyntax (scm *x) //int must not add to environment
243 {
244   return cons (&symbol_unsyntax, x);
245 }
246 scm *unsyntax (scm *x);
247 scm scm_unsyntax = {FUNCTION1, .name="unsyntax", .function1=&unsyntax};
248
249 scm *
250 unsyntax_splicing (scm *x) //int must not add to environment
251 {
252   return cons (&symbol_unsyntax_splicing, x);
253 }
254 scm *unsyntax_splicing (scm *x);
255 scm scm_unsyntax_splicing = {FUNCTION1, .name="unsyntax-splicing", .function1=&unsyntax_splicing};
256
257
258 //Library functions
259
260 // Derived, non-primitives
261 scm *caar (scm *x) {return car (car (x));}
262 scm *cadr (scm *x) {return car (cdr (x));}
263 scm *cdar (scm *x) {return cdr (car (x));}
264 scm *cddr (scm *x) {return cdr (cdr (x));}
265 scm *caaar (scm *x) {return car (car (car (x)));}
266 scm *caadr (scm *x) {return car (car (cdr (x)));}
267 scm *caddr (scm *x) {return car (cdr (cdr (x)));}
268 scm *cdadr (scm *x) {return cdr (car (cdr (x)));}
269 scm *cadar (scm *x) {return car (cdr (car (x)));}
270 scm *cddar (scm *x) {return cdr (cdr (car (x)));}
271 scm *cdddr (scm *x) {return cdr (cdr (cdr (x)));}
272
273 scm *
274 pairlis (scm *x, scm *y, scm *a)
275 {
276   if (x == &scm_nil)
277     return a;
278   if (atom_p (x) == &scm_t)
279     return cons (cons (x, y), a);
280   return cons (cons (car (x), car (y)),
281                pairlis (cdr (x), cdr (y), a));
282 }
283
284 scm *
285 assq (scm *x, scm *a)
286 {
287   while (a != &scm_nil && EQ_P (x, a->car->car) == &scm_f) {
288     a = a->cdr;
289   }
290   if (a == &scm_nil) {
291 #if DEBUG
292     printf ("alist miss: %s\n", x->name);
293 #endif
294     return &scm_f;
295   }
296   return a->car;
297 }
298
299 #define BUILTIN_P(x)             \
300   ((x->type == FUNCTION0         \
301     || x->type == FUNCTION1      \
302     || x->type == FUNCTION2      \
303     || x->type == FUNCTION3      \
304     || x->type == FUNCTIONn)     \
305    ? &scm_t : &scm_f)
306
307 scm *
308 evlis (scm *m, scm *a)
309 {
310   if (m == &scm_nil) return &scm_nil;
311   if (m->type != PAIR) return eval_env (m, a);
312   scm *e = eval_env (car (m), a);
313   return cons (e, evlis (cdr (m), a));
314 }
315
316 scm *
317 apply_env (scm *fn, scm *x, scm *a)
318 {
319   if (fn->type != PAIR)
320     {
321       if (fn == &scm_car) return x->car->car;
322       if (fn == &scm_cdr) return x->car->cdr;
323       if (BUILTIN_P (fn) == &scm_t)
324         return call (fn, x);
325       if (eq_p (fn, &symbol_call_with_values) == &scm_t)
326         return call (&scm_call_with_values_env, append2 (x, cons (a, &scm_nil)));
327       if (fn == &symbol_current_module) return a;
328     }
329   else if (fn->car == &symbol_lambda) {
330     scm *p = pairlis (cadr (fn), x, a);
331     return eval_env (cons (&symbol_begin, cddr (fn)), cons (cons (&symbol_closure, p), p));
332   }
333   else if (fn->car == &symbol_closure) {
334     scm *args = caddr (fn);
335     scm *body = cdddr (fn);
336     a = cdadr (fn);
337     a = cdr (a);
338     scm *p = pairlis (args, x, a);
339     return eval_env (cons (&symbol_begin, body), cons (cons (&symbol_closure, p), p));
340   }
341   scm *efn = eval_env (fn, a);
342   if (efn == &scm_f || efn == &scm_t) assert (!"apply bool");
343   if (efn->type == NUMBER) assert (!"apply number");
344   if (efn->type == STRING) assert (!"apply string");  
345   return apply_env (efn, x, a);
346 }
347
348 scm *
349 eval_env (scm *e, scm *a)
350 {
351   if (internal_symbol_p (e) == &scm_t) return e;
352
353   e = expand_macro_env (e, a);
354
355   if (e->type == SYMBOL) {
356     scm *y = assq (e, a);
357     if (y == &scm_f) {
358       fprintf (stderr, "eval: unbound variable: %s\n", e->name);
359       assert (!"unbound variable");
360     }
361     return cdr (y);
362   }
363   else if (e->type != PAIR)
364     return e;
365   else if (e->car->type != PAIR)
366     {
367       if (e->car == &symbol_quote)
368         return cadr (e);
369       if (e->car == &symbol_syntax)
370         return e;
371       if (e->car == &symbol_begin)
372         return eval_begin_env (e, a);
373       if (e->car == &symbol_lambda)
374         return make_closure (cadr (e), cddr (e), assq (&symbol_closure, a));
375       if (e->car == &symbol_closure)
376         return e;
377       if (e->car == &symbol_if)
378         return if_env (cdr (e), a);
379       if (e->car == &symbol_define)
380         return define (e, a);
381       if (e->car == &symbol_define_macro)
382         return define (e, a);
383       if (e->car == &symbol_set_x)
384         return set_env_x (cadr (e), eval_env (caddr (e), a), a);
385 #if BUILTIN_QUASIQUOTE
386       if (e->car == &symbol_unquote)
387         return eval_env (cadr (e), a);
388       if (e->car == &symbol_quasiquote)
389         return eval_quasiquote (cadr (e), add_unquoters (a));
390       if (e->car == &symbol_unsyntax)
391         return eval_env (cadr (e), a);
392       if (e->car == &symbol_quasisyntax)
393         return eval_quasisyntax (cadr (e), add_unsyntaxers (a));
394 #endif //BUILTIN_QUASIQUOTE
395     }
396   return apply_env (e->car, evlis (e->cdr, a), a);
397 }
398
399 scm *
400 expand_macro_env (scm *e, scm *a)
401 {
402   scm *macro;
403   if (e->type == PAIR
404       && (macro = lookup_macro (e->car, a)) != &scm_f)
405     return expand_macro_env (apply_env (macro, e->cdr, a), a);
406   return e;
407 }
408
409 scm *
410 eval_begin_env (scm *e, scm *a)
411 {
412   scm *r = &scm_unspecified;
413   while (e != &scm_nil) {
414     r = eval_env (e->car, a);
415     e = e->cdr;
416   }
417   return r;
418 }
419
420 scm *
421 if_env (scm *e, scm *a)
422 {
423   if (eval_env (car (e), a) != &scm_f)
424     return eval_env (cadr (e), a);
425   if (cddr (e) != &scm_nil)
426     return eval_env (caddr (e), a);
427   return &scm_unspecified;
428 }
429
430 #if BUILTIN_QUASIQUOTE
431 scm *
432 eval_quasiquote (scm *e, scm *a)
433 {
434   if (e == &scm_nil) return e;
435   else if (atom_p (e) == &scm_t) return e;
436   else if (eq_p (car (e), &symbol_unquote) == &scm_t)
437     return eval_env (cadr (e), a);
438   else if (e->type == PAIR && e->car->type == PAIR
439            && eq_p (caar (e), &symbol_unquote_splicing) == &scm_t)
440       return append2 (eval_env (cadar (e), a), eval_quasiquote (cdr (e), a));
441   return cons (eval_quasiquote (car (e), a), eval_quasiquote (cdr (e), a));
442 }
443
444 scm *
445 eval_quasisyntax (scm *e, scm *a)
446 {
447   if (e == &scm_nil) return e;
448   else if (atom_p (e) == &scm_t) return e;
449   else if (eq_p (car (e), &symbol_unsyntax) == &scm_t)
450     return eval_env (cadr (e), a);
451   else if (e->type == PAIR && e->car->type == PAIR
452            && eq_p (caar (e), &symbol_unsyntax_splicing) == &scm_t)
453       return append2 (eval_env (cadar (e), a), eval_quasisyntax (cdr (e), a));
454   return cons (eval_quasisyntax (car (e), a), eval_quasisyntax (cdr (e), a));
455 }
456
457 #else
458 scm*add_unquoters (scm *a){}
459 scm*add_unsyntaxers (scm *a){}
460 scm*eval_unsyntax (scm *e, scm *a){}
461 scm*eval_quasiquote (scm *e, scm *a){}
462 scm*eval_quasisyntax (scm *e, scm *a){}
463 #endif // BUILTIN_QUASIQUOTE
464
465 //Helpers
466
467 scm *
468 builtin_p (scm *x)
469 {
470   return BUILTIN_P(x);
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) == &symbol_circ) {
950       fprintf (f, "(*circ* . #-1#)");
951       return &scm_unspecified;
952     }
953     if (car (x) == &symbol_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 peek_char () //int
997 {
998   int c = getchar ();
999   ungetchar (c);
1000   return c;
1001 }
1002
1003 scm*
1004 builtin_peek_char ()
1005 {
1006   return make_char (peek_char ());
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 builtin_ungetchar (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 == '!' && peek_char () == '#') 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 == ',' && peek_char () == '@') {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 == '#' && peek_char () == ',' && !w) {
1074     getchar ();
1075     if (peek_char () == '@'){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      && (peek_char () == '\''
1082          || peek_char () == '`')
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 == '#' && peek_char () == 'x') {getchar (); return read_hex ();}
1088   if (c == '#' && peek_char () == '\\') {getchar (); return read_character ();}
1089   if (c == '#' && !w && peek_char () == '(') {getchar (); return list_to_vector (readlist (a));}
1090   if (c == '#' && peek_char () == '(') {ungetchar (c); return lookup (w, a);}
1091   if (c == '#' && peek_char () == '!') {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 = peek_char ();
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 = peek_char ();
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       && peek_char () >= '0' && peek_char () <= '7') {
1124     c = c - '0';
1125     while (peek_char () >= '0' && peek_char () <= '7') {
1126       c <<= 3;
1127       c += getchar () - '0';
1128     }
1129   }
1130   else if (c >= 'a' && c <= 'z'
1131       && peek_char () >= 'a' && peek_char () <= 'z') {
1132     char buf[STRING_MAX];
1133     char *p = buf;
1134     *p++ = c;
1135     while (peek_char () >= 'a' && peek_char () <= '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 == '\\' && peek_char () == '"') *p++ = getchar ();
1164     else if (c == '\\' && peek_char () == '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 == '#' && peek_char () == '!') {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 (&symbol_closure, a), a);
1374   return a;
1375 }
1376
1377 scm *
1378 make_lambda (scm *args, scm *body)
1379 {
1380   return cons (&symbol_lambda, cons (args, body));
1381 }
1382
1383 scm *
1384 make_closure (scm *args, scm *body, scm *a)
1385 {
1386   return cons (&symbol_closure, cons (cons (&symbol_circ, 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 = eval_env (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 = eval_env (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 (&symbol_closure, a);
1408   set_cdr_x (cl, aa);
1409   return entry;
1410 }
1411
1412 scm *
1413 lookup_macro (scm *x, scm *a)
1414 {
1415 }
1416 #endif
1417
1418   scm *m = assq (x, a);
1419   if (m != &scm_f && macro_p (cdr (m)) != &scm_f)
1420     return cdr (m)->macro;
1421   return &scm_f;
1422 }
1423
1424 scm *
1425 read_file (scm *e, scm *a)
1426 {
1427   if (e == &scm_nil) return e;
1428   return cons (e, read_file (read_env (a), a));
1429 }
1430
1431 int
1432 main (int argc, char *argv[])
1433 {
1434   if (argc > 1 && !strcmp (argv[1], "--help")) return puts ("Usage: mes < FILE\n");
1435   if (argc > 1 && !strcmp (argv[1], "--version")) return puts ("Mes 0.0\n");
1436   scm *a = mes_environment ();
1437 #if STATIC_PRIMITIVES
1438   mes_primitives ();
1439 #endif
1440   display_ (stderr, eval_env (cons (&symbol_begin, read_file (read_env (a), a)), a));
1441   fputs ("", stderr);
1442   return 0;
1443 }