06a8c9a949cb924770a029eea8143d0806e77c4f
[mes.git] / mes.c
1 /*
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 // (setq comment-start "//")
22 // (setq comment-end "")
23 /*
24  * The Maxwell Equations of Software -- John McCarthy page 13
25  * http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
26  */
27
28 #define _GNU_SOURCE
29 #include <assert.h>
30 #include <ctype.h>
31 #include <stdio.h>
32 #include <string.h>
33 #include <stdlib.h>
34 #include <stdbool.h>
35
36 #define DEBUG 0
37
38 #define MACROS 1
39 #define QUASIQUOTE 1
40
41 #ifndef QUOTE_SUGAR
42 #define QUOTE_SUGAR 1
43 #endif
44
45 enum type {CHAR, NUMBER, PAIR, STRING, SYMBOL, VALUES, VECTOR,
46            FUNCTION0, FUNCTION1, FUNCTION2, FUNCTION3, FUNCTIONn};
47 struct scm_t;
48 typedef struct scm_t* (*function0_t) (void);
49 typedef struct scm_t* (*function1_t) (struct scm_t*);
50 typedef struct scm_t* (*function2_t) (struct scm_t*, struct scm_t*);
51 typedef struct scm_t* (*function3_t) (struct scm_t*, struct scm_t*, struct scm_t*);
52 typedef struct scm_t* (*functionn_t) (struct scm_t*);
53
54 typedef struct scm_t {
55   enum type type;
56   union {
57     char *name;
58     struct scm_t* car;
59     int length;
60   };
61   union {
62     int value;
63     function0_t function0;
64     function1_t function1;
65     function2_t function2;
66     function3_t function3;
67     functionn_t functionn;    
68     struct scm_t* cdr;
69     struct scm_t** vector;
70   };
71 } scm;
72
73 #define MES 1
74 #include "mes.h"
75
76 scm *display_helper (scm*, bool, char*, bool);
77 bool
78 symbol_eq (scm *x, char *s)
79 {
80   return x->type == SYMBOL && !strcmp (x->name, s);
81 }
82
83 scm scm_nil = {SYMBOL, "()"};
84 scm scm_dot = {SYMBOL, "."};
85 scm scm_t = {SYMBOL, "#t"};
86 scm scm_f = {SYMBOL, "#f"};
87 scm scm_lambda = {SYMBOL, "lambda"};
88 scm scm_label = {SYMBOL, "label"};
89 scm scm_unspecified = {SYMBOL, "*unspecified*"};
90 scm scm_symbol_cond = {SYMBOL, "cond"};
91 scm scm_symbol_quote = {SYMBOL, "quote"};
92 #if QUASIQUOTE
93 scm scm_symbol_quasiquote = {SYMBOL, "quasiquote"};
94 scm scm_symbol_unquote = {SYMBOL, "unquote"};
95 #endif
96 #if MACROS
97 scm scm_macro = {SYMBOL, "*macro*"};
98 #endif
99
100 scm scm_symbol_EOF = {SYMBOL, "EOF"};
101 scm scm_symbol_EOF2 = {SYMBOL, "EOF2"};
102 scm scm_symbol_call_with_values = {SYMBOL, "call-with-values"};
103 scm scm_symbol_current_module = {SYMBOL, "current-module"};
104 scm scm_symbol_define = {SYMBOL, "define"};
105 scm scm_symbol_define_macro = {SYMBOL, "define-macro"};
106 scm scm_symbol_eval = {SYMBOL, "eval"};
107 scm scm_symbol_loop2 = {SYMBOL, "loop2"};
108 scm scm_symbol_set_x = {SYMBOL, "set!"};
109 scm scm_symbol_values = {SYMBOL, "values"};
110
111 // PRIMITIVES
112
113 scm *
114 atom_p (scm *x)
115 {
116   return x->type == PAIR ? &scm_f : &scm_t;
117 }
118
119 scm *
120 car (scm *x)
121 {
122   assert (x->type == PAIR);
123   return x->car;
124 }
125
126 scm *
127 cdr (scm *x)
128 {
129   assert (x->type == PAIR);
130   return x->cdr;
131 }
132
133 scm *
134 cons (scm *x, scm *y)
135 {
136   scm *p = malloc (sizeof (scm));
137   p->type = PAIR;
138   p->car = x;
139   p->cdr = y;
140   return p;
141 }
142
143 scm *
144 eq_p (scm *x, scm *y)
145 {
146   return (x == y
147           || (x->type == CHAR && y->type == CHAR
148               && x->value == y->value)
149           || (x->type == NUMBER && y->type == NUMBER
150               && x->value == y->value)
151           // FIXME: alist lookup symbols
152           || (atom_p (x) == &scm_t
153               && x->type != CHAR
154               && y->type != CHAR
155               && x->type != NUMBER
156               && y->type != NUMBER
157               && x->type != VECTOR
158               && y->type != VECTOR
159               && atom_p (y) == &scm_t
160               && !strcmp (x->name, y->name)))
161     ? &scm_t : &scm_f;
162 }
163
164 scm *
165 null_p (scm *x)
166 {
167   return eq_p (x, &scm_nil);
168 }
169
170 scm *
171 pair_p (scm *x)
172 {
173   return x->type == PAIR ? &scm_t : &scm_f;
174 }
175
176 scm *
177 set_cdr_x (scm *x, scm *e)
178 {
179   assert (x->type == PAIR);
180   x->cdr = e;
181   return &scm_unspecified;
182 }
183
184 scm *
185 set_x (scm *x, scm *e, scm *a)
186 {
187   return set_cdr_x (assq (x, a), e);
188 }
189
190 scm *
191 set_env_x (scm *x, scm *e, scm *a)
192 {
193   return set_cdr_x (assq (x, a), e);
194 }
195
196 scm *
197 quote (scm *x)
198 {
199   return cons (&scm_symbol_quote, x);
200 }
201
202 #if QUASIQUOTE
203 scm *
204 unquote (scm *x)
205 {
206   return cons (&scm_symbol_unquote, x);
207 }
208
209 scm *
210 quasiquote (scm *x)
211 {
212   return cons (&scm_symbol_quasiquote, x);
213 }
214 #endif
215
216 //Library functions
217
218 // Derived, non-primitives
219 scm *caar (scm *x) {return car (car (x));}
220 scm *cadr (scm *x) {return car (cdr (x));}
221 scm *cdar (scm *x) {return cdr (car (x));}
222 scm *cddr (scm *x) {return cdr (cdr (x));}
223 scm *caadr (scm *x) {return car (car (cdr (x)));}
224 scm *caddr (scm *x) {return car (cdr (cdr (x)));}
225 scm *cdadr (scm *x) {return cdr (car (cdr (x)));}
226 scm *cadar (scm *x) {return car (cdr (car (x)));}
227 scm *cddar (scm *x) {return cdr (cdr (car (x)));}
228 scm *cdddr (scm *x) {return cdr (cdr (cdr (x)));}
229
230 scm *
231 pairlis (scm *x, scm *y, scm *a)
232 {
233 #if DEBUG
234   printf ("pairlis x=");
235   display (x);
236   printf (" y=");
237   display (y);
238   puts ("");
239 #endif
240   if (x == &scm_nil)
241     return a;
242   if (atom_p (x) == &scm_t)
243     return cons (cons (x, y), a);
244   return cons (cons (car (x), car (y)),
245                pairlis (cdr (x), cdr (y), a));
246 }
247
248 scm *
249 assq (scm *x, scm *a)
250 {
251   if (a == &scm_nil) {
252 #if DEBUG
253     printf ("alist miss: %s\n", x->name);
254 #endif
255     return &scm_f;
256   }
257   if (eq_p (caar (a), x) == &scm_t)
258     return car (a);
259   return assq (x, cdr (a));
260 }
261
262 scm *
263 apply_env_ (scm *fn, scm *x, scm *a)
264 {
265 #if DEBUG
266   printf ("apply_env fn=");
267   display (fn);
268   printf (" x=");
269   display (x);
270   puts ("");
271 #endif
272   if (atom_p (fn) != &scm_f)
273     {
274       if (fn == &scm_symbol_current_module) // FIXME
275         return a;
276       if (eq_p (fn, &scm_symbol_call_with_values) == &scm_t)
277         return call (&scm_call_with_values_env, append2 (x, cons (a, &scm_nil)));
278       if (builtin_p (fn) == &scm_t)
279         return call (fn, x);
280       return apply_env (eval (fn,  a), x, a);
281     }
282   else if (car (fn) == &scm_lambda)
283     return begin_env (cddr (fn), pairlis (cadr (fn), x, a));
284   else if (car (fn) == &scm_label)
285     return apply_env (caddr (fn), x, cons (cons (cadr (fn), caddr (fn)), a));
286   return &scm_unspecified;
287 }
288
289 scm *
290 begin_env (scm *body, scm *a)
291 {
292   if (body == &scm_nil) return &scm_unspecified;
293   scm *result = eval (car (body), a);
294   if (cdr (body) == &scm_nil)
295     return result;
296   return begin_env (cdr (body), a);
297 }
298
299 scm *
300 eval_ (scm *e, scm *a)
301 {
302 #if DEBUG
303   printf ("eval e=");
304   display (e);
305   puts ("");
306 #endif
307   if (e->type == CHAR)
308     return e;
309   else if (e->type == NUMBER)
310     return e;
311   else if (e->type == STRING)
312     return e;
313   else if (e->type == VECTOR)
314     return e;
315   else if (atom_p (e) == &scm_t) {
316     scm *y = assq (e, a);
317     if (y == &scm_f) {
318       printf ("eval: no such symbol: %s\n", e->name);
319       exit (1);
320     }
321     return cdr (y);
322   }
323   if (builtin_p (e) == &scm_t)
324     return e;
325   else if (atom_p (car (e)) == &scm_t)
326     {
327 #if MACROS
328       scm *macro;
329 #endif // MACROS
330       if (car (e) == &scm_symbol_quote)
331         return cadr (e);
332       if (car (e) == &scm_lambda)
333         return e;
334       if (car (e) == &scm_symbol_set_x)
335         return set_env_x (cadr (e), eval (caddr (e), a), a);
336 #if QUASIQUOTE
337       else if (car (e) == &scm_symbol_unquote)
338         return eval (cadr (e), a);
339       else if (car (e) == &scm_symbol_quasiquote) {
340 #if DEBUG
341         printf ("cadr e:");
342         display (cadr (e));
343         puts ("");
344         printf ("qq:");
345         display (eval_quasiquote (cadr (e), a));
346         puts ("");
347 #endif // DEBUG
348         return eval_quasiquote (cadr (e), a);
349       }
350 #endif // QUASIQUOTE
351       else if (car (e) == &scm_symbol_cond)
352         return evcon (cdr (e), a);
353 #if MACROS
354       else if ((macro = assq (car (e), cdr (assq (&scm_macro, a)))) != &scm_f)
355         return eval (apply_env_ (cdr (macro), cdr (e), a), a);
356 #endif // MACROS
357       return apply_env (car (e), evlis (cdr (e), a), a);
358     }
359   return apply_env (car (e), evlis (cdr (e), a), a);
360 }
361
362 scm *
363 evcon_ (scm *c, scm *a)
364 {
365 #if DEBUG
366   printf ("evcon_ clause=");
367   display (car (c));
368   puts ("");
369 #endif
370   if (c == &scm_nil) return &scm_unspecified;
371   if (eval (caar (c), a) != &scm_f) {
372 #if DEBUG
373     //if (fn != &scm_display && fn != &scm_call)
374     //if (fn != &scm_call)
375     printf ("#t clause=");
376     display (car (c));
377     printf (" cddar=");
378     display (cddar (c));
379     printf (" nil=%d", cddar (c) == &scm_nil);
380     puts ("");
381 #endif
382     if (cddar (c) == &scm_nil)
383       return eval (cadar (c), a);
384     eval (cadar (c), a);
385     return evcon_ (cons (cons (&scm_t, cddar (c)), &scm_nil), a);
386   }
387   return evcon_ (cdr (c), a);
388 }
389
390 scm *
391 evcon (scm *c, scm *a)
392 {
393 #if DEBUG
394   printf ("\n****evcon=");
395   display (c);
396   puts ("");
397 #endif
398   return evcon_ (c, a);
399 }
400
401 scm *
402 evlis (scm *m, scm *a)
403 {
404 #if DEBUG
405   printf ("evlis m=");
406   display (m);
407   puts ("");
408 #endif
409   if (m == &scm_nil)
410     return &scm_nil;
411   scm *e = eval (car (m), a);
412   return cons (e, evlis (cdr (m), a));
413 }
414
415 //Helpers
416
417 scm *
418 builtin_p (scm *x)
419 {
420   return (x->type == FUNCTION0
421           || x->type == FUNCTION1
422           || x->type == FUNCTION2
423           || x->type == FUNCTION3
424           || x->type == FUNCTIONn)
425     ? &scm_t : &scm_f;
426 }
427
428 scm *
429 char_p (scm *x)
430 {
431   return x->type == CHAR ? &scm_t : &scm_f;
432 }
433
434 scm *
435 number_p (scm *x)
436 {
437   return x->type == NUMBER ? &scm_t : &scm_f;
438 }
439
440 scm *
441 string_p (scm *x)
442 {
443   return x->type == STRING ? &scm_t : &scm_f;
444 }
445
446 scm *
447 symbol_p (scm *x)
448 {
449   //TODO: #f,#t,nil also `symbols' atm
450   return x->type == SYMBOL ? &scm_t : &scm_f;
451 }
452
453 scm *
454 vector_p (scm *x)
455 {
456   return x->type == VECTOR ? &scm_t : &scm_f;
457 }
458
459 scm *
460 display (scm *x)
461 {
462   return display_helper (x, false, "", false);
463 }
464
465 scm *
466 call (scm *fn, scm *x)
467 {
468 #if DEBUG
469   //if (fn != &scm_display && fn != &scm_call)
470   //if (fn != &scm_call)
471   {
472     printf ("\ncall fn=");
473     display (fn);
474     printf (" x=");
475     display (x);
476     puts ("");
477   }
478 #endif
479   if (fn->type == FUNCTION0)
480     return fn->function0 ();
481   if (x->car->type == VALUES)
482     x = cons (x->car->cdr->car, &scm_nil);
483   if (fn->type == FUNCTION1)
484     return fn->function1 (car (x));
485   if (fn->type == FUNCTION2)
486     return fn->function2 (car (x), cadr (x));
487   if (fn->type == FUNCTION3)
488     return fn->function3 (car (x), cadr (x), caddr (x));
489   if (fn->type == FUNCTIONn)
490     return fn->functionn (x);
491   return &scm_unspecified;
492 }
493
494 scm *
495 append2 (scm *x, scm *y)
496 {
497   if (x == &scm_nil) return y;
498   assert (x->type == PAIR);
499   return cons (car (x), append2 (cdr (x), y));
500 }
501
502 scm *
503 append (scm *x/*...*/)
504  {
505   if (x == &scm_nil) return &scm_nil;
506   return append2 (car (x), append (cdr (x)));
507  }
508
509 scm *
510 make_char (int x)
511 {
512   scm *p = malloc (sizeof (scm));
513   p->type = CHAR;
514   p->value = x;
515   return p;
516 }
517
518 scm *
519 make_number (int x)
520 {
521   scm *p = malloc (sizeof (scm));
522   p->type = NUMBER;
523   p->value = x;
524   return p;
525 }
526
527 scm *
528 make_string (char const *s)
529 {
530   scm *p = malloc (sizeof (scm));
531   p->type = STRING;
532   p->name = strdup (s);
533   return p;
534 }
535
536 scm *
537 make_symbol (char const *s)
538 {
539   // TODO: alist lookup symbols
540   scm *p = malloc (sizeof (scm));
541   p->type = SYMBOL;
542   p->name = strdup (s);
543   return p;
544 }
545
546 scm *
547 make_vector (int n)
548 {
549   scm *p = malloc (sizeof (scm));
550   p->type = VECTOR;
551   p->length = n;
552   p->vector = malloc (n * sizeof (scm*));
553   return p;
554 }
555
556 scm *
557 string (scm *x/*...*/)
558 {
559   char buf[256] = "";
560   char *p = buf;
561   while (x != &scm_nil)
562     {
563       scm *s = car (x);
564       assert (s->type == CHAR);
565       *p++ = s->value;
566       x = cdr (x);
567     }
568   return make_string (buf);
569 }
570
571 scm *
572 string_append (scm *x/*...*/)
573 {
574   char buf[256] = "";
575
576   while (x != &scm_nil)
577     {
578       scm *s = car (x);
579       assert (s->type == STRING);
580       strcat (buf, s->name);
581       x = cdr (x);
582     }
583   return make_string (buf);
584 }
585
586 scm *
587 string_length (scm *x)
588 {
589   assert (x->type == STRING);
590   return make_number (strlen (x->name));
591 }
592
593 scm *
594 length (scm *x)
595 {
596   int n = 0;
597   while (x != &scm_nil)
598     {
599       n++;
600       x = cdr (x);
601     }
602   return make_number (n);
603 }
604
605 #if 0
606 scm *
607 builtin_list (scm *x/*...*/) // int
608 {
609   return x;
610 }
611
612 scm *
613 vector (scm *x/*...*/) // int
614 {
615   return list_to_vector (x);
616 }
617 #endif
618
619 scm *
620 values (scm *x/*...*/)
621 {
622   scm *v = cons (0, x);
623   v->type = VALUES;
624   return v;
625 }
626
627 scm *
628 call_with_values_env (scm *producer, scm *consumer, scm *a)
629 {
630   scm *v = apply_env_ (producer, &scm_nil, a);
631   if (v->type == VALUES)
632     v = v->cdr;
633   return apply_env_ (consumer, v, a);
634 }
635
636 scm *
637 vector_length (scm *x)
638 {
639   assert (x->type == VECTOR);
640   return make_number (x->length);
641 }
642
643 scm *
644 vector_ref (scm *x, scm *i)
645 {
646   assert (x->type == VECTOR);
647   assert (i->value < x->length);
648   return x->vector[i->value];
649 }
650
651 scm *
652 vector_set_x (scm *x, scm *i, scm *e)
653 {
654   assert (x->type == VECTOR);
655   assert (i->value < x->length);
656   x->vector[i->value] = e;
657   return &scm_unspecified;
658 }
659
660 scm *
661 lookup (char *x, scm *a)
662 {
663   if (isdigit (*x) || (*x == '-' && isdigit (*(x+1))))
664     return make_number (atoi (x));
665   if (*x == '\'') return &scm_symbol_quote;
666
667   if (!strcmp (x, scm_unspecified.name)) return &scm_unspecified;
668   if (!strcmp (x, scm_symbol_cond.name)) return &scm_symbol_cond;
669   if (!strcmp (x, scm_symbol_quote.name)) return &scm_symbol_quote;
670   if (!strcmp (x, scm_lambda.name)) return &scm_lambda;
671   if (!strcmp (x, scm_label.name)) return &scm_label;
672   if (!strcmp (x, scm_nil.name)) return &scm_nil;
673   if (!strcmp (x, scm_symbol_set_x.name)) return &scm_symbol_set_x;
674
675 #if QUASIQUOTE
676   if (*x == '`') return &scm_symbol_quasiquote;
677   if (*x == ',') return &scm_symbol_unquote;  
678   if (!strcmp (x, scm_symbol_unquote.name)) return &scm_symbol_unquote;
679   if (!strcmp (x, scm_symbol_quasiquote.name)) return &scm_symbol_quasiquote;
680 #endif
681
682   return make_symbol (x);
683 }
684
685 scm *
686 lookup_char (int c, scm *a)
687 {
688   char buf[2];
689   buf[0] = c;
690   buf[1] = 0;
691   return lookup (buf, a);
692 }
693
694 char *
695 list2str (scm *l) // char*
696 {
697   static char buf[256];
698   char *p = buf;
699   while (l != &scm_nil) {
700     scm *c = car (l);
701     assert (c->type == NUMBER);
702     *p++ = c->value;
703     l = cdr (l);
704   }
705   *p = 0;
706   return buf;
707 }
708
709 scm*
710 list_to_vector (scm *x)
711 {
712   int n = length (x)->value;
713   scm *v = make_vector (n);
714   scm **p = v->vector;
715   while (x != &scm_nil)
716     {
717       *p++ = car (x);
718       x = cdr (x);
719     }
720   return v;
721 }
722
723 scm*
724 number_to_string (scm *x)
725 {
726   assert (x->type == NUMBER);
727   char buf[256];
728   sprintf (buf,"%d", x->value);
729   return make_string (buf);
730 }
731
732 scm*
733 string_to_symbol (scm *x)
734 {
735   assert (x->type == STRING);
736   return make_symbol (x->name);
737 }
738
739 scm*
740 symbol_to_string (scm *x)
741 {
742   assert (x->type == SYMBOL);
743   return make_string (x->name);
744 }
745
746 scm*
747 vector_to_list (scm *v)
748 {
749   scm *x = &scm_nil;
750   for (int i = 0; i < v->length; i++)
751     x = append2 (x, cons (v->vector[i], &scm_nil));
752   return x;
753 }
754
755 scm *
756 builtin_lookup (scm *l, scm *a)
757 {
758   return lookup (list2str (l), a);
759 }
760
761 scm *
762 cossa (scm *x, scm *a)
763 {
764   if (a == &scm_nil) return &scm_f;
765   if (eq_p (cdar (a), x) == &scm_t)
766     return car (a);
767   return cossa (x, cdr (a));
768 }
769
770 scm *
771 newline ()
772 {
773   puts ("");
774   return &scm_unspecified;
775 }
776
777 scm *
778 display_helper (scm *x, bool cont, char *sep, bool quote)
779 {
780   scm *r;
781   printf ("%s", sep);
782   if (x->type == CHAR && x->value == 10) printf ("#\\%s", "newline");
783   else if (x->type == CHAR && x->value == 32) printf ("#\\%s", "space");
784   else if (x->type == CHAR) printf ("#\\%c", x->value);
785   else if (x->type == NUMBER) printf ("%d", x->value);
786   else if (x->type == PAIR) {
787 #if QUOTE_SUGAR
788     if (car (x) == &scm_quote) {
789       printf ("'");
790       return display_helper (car (cdr (x)), cont, "", true);
791     }
792 #if QUASIQUOTE
793     if (car (x) == &scm_quasiquote) {
794       printf ("`");
795       return display_helper (car (cdr (x)), cont, "", true);
796     }
797     if (car (x) == &scm_unquote) {
798       printf (",");
799       return display_helper (car (cdr (x)), cont, "", true);
800     }
801 #endif
802 #endif
803     if (!cont) printf ("(");
804     display (car (x));
805     if (cdr (x)->type == PAIR)
806       display_helper (cdr (x), true, " ", false);
807     else if (cdr (x) != &scm_nil) {
808       printf (" . ");
809       display (cdr (x));
810     }
811     if (!cont) printf (")");
812   }
813   else if (x->type == VECTOR) {
814     printf ("#(");
815     for (int i = 0; i < x->length; i++)
816       display_helper (x->vector[i], true, i ? " " : "", false);
817     printf (")");
818   }
819   else if (atom_p (x) == &scm_t) printf ("%s", x->name);
820
821   return &scm_unspecified;
822 }
823
824 // READ
825
826 int
827 ungetchar (int c) //int
828 {
829   return ungetc (c, stdin);
830 }
831
832 int
833 peekchar () //int
834 {
835   int c = getchar ();
836   ungetchar (c);
837   return c;
838 }
839
840 scm*
841 builtin_getchar ()
842 {
843   return make_number (getchar ());
844 }
845
846 scm*
847 builtin_peekchar ()
848 {
849   return make_number (peekchar ());
850 }
851
852 scm*
853 builtin_ungetchar (scm *c)
854 {
855   assert (c->type == NUMBER);
856   ungetchar (c->value);
857   return c;
858 }
859
860 int
861 readcomment (int c)
862 {
863   if (c == '\n') return c;
864   return readcomment (getchar ());
865 }
866
867 int
868 readblock (int c)
869 {
870   if (c == '!' && peekchar () == '#') return getchar ();
871   return readblock (getchar ());
872 }
873
874 scm *
875 readword (int c, char* w, scm *a)
876 {
877   if (c == EOF && !w) return &scm_nil;
878   if (c == '\n' && !w) return readword (getchar (), w, a);
879   if (c == '\n' && *w == '.' && w[1] == 0) return &scm_dot;
880   if (c == EOF || c == '\n') return lookup (w, a);
881   if (c == ' ') return readword ('\n', w, a);
882   if (c == '"' && !w) return readstring ();
883   if (c == '"') {ungetchar (c); return lookup (w, a);}
884   if (c == '(' && !w) return readlist (a);
885   if (c == '(') {ungetchar (c); return lookup (w, a);}
886   if (c == ')' && !w) {ungetchar (c); return &scm_nil;}
887   if (c == ')') {ungetchar (c); return lookup (w, a);}
888   if ((c == '\''
889 #if QUASIQUOTE
890        || c == '`'
891        || c == ','
892 #endif
893        )
894       && !w) {return cons (lookup_char (c, a),
895                                      cons (readword (getchar (), w, a),
896                                            &scm_nil));}
897   if (c == ';') {readcomment (c); return readword ('\n', w, a);}
898   if (c == '#' && peekchar () == '\\') {getchar (); return readchar ();}
899   if (c == '#' && !w && peekchar () == '(') {getchar (); return list_to_vector (readlist (a));}
900   if (c == '#' && peekchar () == '(') {ungetchar (c); return lookup (w, a);}
901   if (c == '#' && peekchar () == '!') {getchar (); readblock (getchar ()); return readword (getchar (), w, a);}
902   char buf[256] = {0};
903   char ch = c;
904   return readword (getchar (), strncat (w ? w : buf, &ch, 1), a);
905 }
906
907 scm *
908 readchar ()
909 {
910   int c = getchar ();
911   if (c >= '0' && c <= '7'
912       && peekchar () >= '0' && peekchar () <= '7') {
913     c = c - '0';
914     while (peekchar () >= '0' && peekchar () <= '7') {
915       c <<= 3;
916       c += getchar () - '0';
917     }
918   }
919   else if (c >= 'a' && c <= 'z'
920       && peekchar () >= 'a' && peekchar () <= 'z') {
921     char buf[256];
922     char *p = buf;
923     *p++ = c;
924     while (peekchar () >= 'a' && peekchar () <= 'z') {
925       *p++ = getchar ();
926     }
927     *p = 0;
928     if (!strcmp (buf, "newline")) c = 10;
929     else if (!strcmp (buf, "space")) c = 32;
930     else {
931       printf ("char not supported: %s", buf);
932       assert (!"char not supported");
933     }
934   }
935   return make_char (c);
936 }
937
938 scm *
939 readstring ()
940 {
941   char buf[256];
942   char *p = buf;
943   int c = getchar ();
944   while (true) {
945     if (c == '"') break;
946     *p++ = c;
947     if (c == '\\' && peekchar () == '"') *p++ = getchar ();
948     if (c == EOF) assert (!"EOF in string");
949     c = getchar ();
950   }
951   *p = 0;
952   return make_string (buf);
953 }
954
955 int
956 eat_whitespace (int c)
957 {
958   while (c == ' ' || c == '\n') c = getchar ();
959   if (c == ';') return eat_whitespace (readcomment (c));
960   if (c == '#' && peekchar () == '!') {getchar (); readblock (getchar ()); return eat_whitespace (getchar ());}
961   return c;
962 }
963
964 scm *
965 readlist (scm *a)
966 {
967   int c = getchar ();
968   c = eat_whitespace (c);
969   if (c == ')') return &scm_nil;
970   scm *w = readword (c, 0, a);
971   if (w == &scm_dot)
972     return car (readlist (a));
973   return cons (w, readlist (a));
974 }
975
976 scm *
977 readenv (scm *a)
978 {
979   return readword (getchar (), 0, a);
980 }
981
982 // Extras to make interesting program
983
984 scm *
985 hello_world ()
986 {
987   puts ("c: hello world");
988   return &scm_unspecified;
989 }
990
991 scm *
992 less_p (scm *a, scm *b)
993 {
994   assert (a->type == NUMBER);
995   assert (b->type == NUMBER);
996   return a->value < b->value ? &scm_t : &scm_f;
997 }
998
999 scm *
1000 minus (scm *x/*...*/)
1001 {
1002   scm *a = car (x);
1003   assert (a->type == NUMBER);
1004   int n = a->value;
1005   x = cdr (x);
1006   if (x == &scm_nil)
1007     n = -n;
1008   while (x != &scm_nil)
1009     {
1010       assert (x->car->type == NUMBER);
1011       n -= x->car->value;
1012       x = cdr (x);
1013     }
1014   return make_number (n);
1015 }
1016
1017 scm *
1018 plus (scm *x/*...*/)
1019 {
1020   int n = 0;
1021   while (x != &scm_nil)
1022     {
1023       assert (x->car->type == NUMBER);
1024       n += x->car->value;
1025       x = cdr (x);
1026     }
1027   return make_number (n);
1028 }
1029
1030 scm *
1031 divide (scm *x/*...*/)
1032 {
1033   int n = 1;
1034   while (x != &scm_nil)
1035     {
1036       assert (x->car->type == NUMBER);
1037       n /= x->car->value;
1038       x = cdr (x);
1039     }
1040   return make_number (n);
1041 }
1042
1043 scm *
1044 multiply (scm *x/*...*/)
1045 {
1046   int n = 1;
1047   while (x != &scm_nil)
1048     {
1049       assert (x->car->type == NUMBER);
1050       n *= x->car->value;
1051       x = cdr (x);
1052     }
1053   return make_number (n);
1054 }
1055
1056 scm *
1057 is_p (scm *a, scm *b)
1058 {
1059   assert (a->type == NUMBER);
1060   assert (b->type == NUMBER);
1061   return a->value == b->value ? &scm_t : &scm_f;
1062 }
1063
1064 #if QUASIQUOTE
1065 scm *
1066 eval_quasiquote (scm *e, scm *a)
1067 {
1068 #if DEBUG
1069   printf ("\nc:eval_quasiquote e=");
1070   display (e);
1071   if (pair_p (e) == &scm_t) {
1072     printf ("\ncar (e)=");
1073     display (car (e));
1074     printf (" atom=");
1075     display (atom_p (car (e)));
1076   }
1077   puts ("");
1078 #endif
1079   if (e == &scm_nil) return e;
1080   else if (atom_p (e) == &scm_t) return e;
1081   else if (atom_p (car (e)) == &scm_t)
1082     return cons (car (e), eval_quasiquote (cdr (e), a));
1083   else if (eq_p (caar (e), &scm_symbol_unquote) == &scm_t)
1084     return cons (eval (cadar (e), a), &scm_nil);
1085   else if (eq_p (caar (e), &scm_symbol_quote) == &scm_t)
1086     return cons (cadar (e), &scm_nil);
1087   else if (eq_p (caar (e), &scm_symbol_quasiquote) == &scm_t)
1088     return cdar (e);
1089   return cons (car (e), eval_quasiquote (cdr (e), a));
1090 }
1091 #endif
1092
1093 scm *
1094 add_environment (scm *a, char *name, scm *x)
1095 {
1096   return cons (cons (make_symbol (name), x), a);
1097 }
1098
1099 scm *
1100 mes_environment ()
1101 {
1102   scm *a = &scm_nil;
1103
1104   a = add_environment (a, "()", &scm_nil);
1105   a = add_environment (a, "#t", &scm_t);
1106   a = add_environment (a, "#f", &scm_f);
1107   a = add_environment (a, "*unspecified*", &scm_unspecified);
1108   a = add_environment (a, "label", &scm_label);
1109   a = add_environment (a, "lambda", &scm_lambda);
1110   a = add_environment (a, "*macro*", &scm_nil);
1111   a = add_environment (a, "*dot*", &scm_dot);
1112   a = add_environment (a, "current-module", &scm_symbol_current_module);
1113
1114   a = add_environment (a, "'", &scm_quote);
1115 #if QUASIQUOTE
1116   a = add_environment (a, ",", &scm_unquote);
1117   a = add_environment (a, "`", &scm_quasiquote);
1118 #endif
1119
1120 #include "environment.i"
1121   
1122   return a;
1123 }
1124
1125 scm *
1126 define_lambda (scm *x)
1127 {
1128   return cons (caadr (x), cons (&scm_lambda, cons (cdadr (x), cddr (x))));
1129 }
1130
1131 scm *
1132 define (scm *x, scm *a)
1133 {
1134   if (atom_p (cadr (x)) != &scm_f)
1135     return cons (cadr (x), eval (caddr (x), a));
1136   return define_lambda (x);
1137 }
1138
1139 scm *
1140 define_macro (scm *x, scm *a)
1141 {
1142 #if DEBUG
1143   printf ("\nc:define_macro a=");
1144   scm *aa =cons (&scm_macro,
1145                cons (define_lambda (x),
1146                      cdr (assq (&scm_macro, a))));
1147   display (aa);
1148   puts ("");
1149 #endif
1150   if (atom_p (cadr (x)) != &scm_f)
1151     return cons (&scm_macro,
1152                  cons (cons (cadr (x), eval (caddr (x), a)),
1153                        cdr (assq (&scm_macro, a))));
1154   return cons (&scm_macro,
1155                cons (define_lambda (x),
1156                      cdr (assq (&scm_macro, a))));
1157 }
1158
1159 scm *
1160 loop (scm *r, scm *e, scm *a)
1161 {
1162 #if 0//DEBUG
1163   printf ("\nc:loop e=");
1164   display (e);
1165   puts ("");
1166 #endif
1167   if (e == &scm_nil)
1168     return r;
1169   else if (eq_p (e, &scm_symbol_EOF) == &scm_t)
1170     return apply_env (cdr (assq (&scm_symbol_loop2, a)),
1171                   cons (&scm_unspecified, cons (&scm_t, cons (a, &scm_nil))), a);
1172   else if (eq_p (e, &scm_symbol_EOF2) == &scm_t)
1173     return r;
1174   else if (atom_p (e) == &scm_t)
1175     return loop (eval (e, a), readenv (a), a);
1176   else if (eq_p (car (e), &scm_symbol_define) == &scm_t)
1177     return loop (&scm_unspecified,
1178                  readenv (a),
1179                  cons (define (e, a), a));
1180   else if (eq_p (car (e), &scm_symbol_define_macro) == &scm_t)
1181     return loop (&scm_unspecified,
1182                  readenv (a),
1183                  cons (define_macro (e, a), a));
1184   else if (eq_p (car (e), &scm_symbol_set_x) == &scm_t)
1185     return loop (set_env_x (cadr (e), eval (caddr (e), a), a), readenv (a), a);
1186   return loop (eval (e, a), readenv (a), a);
1187 }
1188
1189 int
1190 main (int argc, char *argv[])
1191 {
1192   scm *a = mes_environment ();
1193   display (loop (&scm_unspecified, readenv (a), a));
1194   newline ();
1195   return 0;
1196 }
1197
1198 scm *
1199 apply_env (scm *fn, scm *x, scm *a)
1200 {
1201 #if DEBUG
1202   printf ("\nc:apply_env fn=");
1203   display (fn);
1204   printf (" x=");
1205   display (x);
1206   puts ("");
1207 #endif
1208   if (fn == &scm_apply_env_)
1209     return eval_ (x, a);
1210   return apply_env_ (fn, x, a);
1211 }
1212
1213 bool evalling_p = false;
1214
1215 scm *
1216 eval (scm *e, scm *a)
1217 {
1218 #if DEBUG
1219   printf ("\nc:eval e=");
1220   display (e);
1221   puts ("");
1222 #endif
1223
1224   scm *eval__ = assq (&scm_symbol_eval, a);
1225   assert (eval__ != &scm_f);
1226   eval__ = cdr (eval__);
1227   if (builtin_p (eval__) == &scm_t
1228       || evalling_p)
1229     return eval_ (e, a);
1230   evalling_p = true;
1231   scm *r = apply_env (eval__, cons (e, cons (a, &scm_nil)), a);
1232   evalling_p = false;
1233   return r;
1234 }