62a89f0c4043ffdb60a16dfead5045872bc6a0a7
[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 eval_quote (scm *fn, scm *x)
264 {
265   return apply (fn, x, &scm_nil);
266 }
267
268 scm *
269 apply_ (scm *fn, scm *x, scm *a)
270 {
271 #if DEBUG
272   printf ("apply fn=");
273   display (fn);
274   printf (" x=");
275   display (x);
276   puts ("");
277 #endif
278   if (atom_p (fn) != &scm_f)
279     {
280       if (fn == &scm_symbol_current_module) // FIXME
281         return a;
282       if (eq_p (fn, &scm_symbol_call_with_values) == &scm_t)
283         return call (&scm_call_with_values_env, append2 (x, cons (a, &scm_nil)));
284       if (builtin_p (fn) == &scm_t)
285         return call (fn, x);
286       return apply (eval (fn,  a), x, a);
287     }
288   else if (car (fn) == &scm_lambda)
289     return begin_env (cddr (fn), pairlis (cadr (fn), x, a));
290   else if (car (fn) == &scm_label)
291     return apply (caddr (fn), x, cons (cons (cadr (fn), caddr (fn)), a));
292   return &scm_unspecified;
293 }
294
295 scm *
296 begin_env (scm *body, scm *a)
297 {
298   if (body == &scm_nil) return &scm_unspecified;
299   scm *result = eval (car (body), a);
300   if (cdr (body) == &scm_nil)
301     return result;
302   return begin_env (cdr (body), a);
303 }
304
305 scm *
306 eval_ (scm *e, scm *a)
307 {
308 #if DEBUG
309   printf ("eval e=");
310   display (e);
311   puts ("");
312 #endif
313   if (e->type == CHAR)
314     return e;
315   else if (e->type == NUMBER)
316     return e;
317   else if (e->type == STRING)
318     return e;
319   else if (e->type == VECTOR)
320     return e;
321   else if (atom_p (e) == &scm_t) {
322     scm *y = assq (e, a);
323     if (y == &scm_f) {
324       printf ("eval: no such symbol: %s\n", e->name);
325       exit (1);
326     }
327     return cdr (y);
328   }
329   if (builtin_p (e) == &scm_t)
330     return e;
331   else if (atom_p (car (e)) == &scm_t)
332     {
333 #if MACROS
334       scm *macro;
335 #endif // MACROS
336       if (car (e) == &scm_symbol_quote)
337         return cadr (e);
338       if (car (e) == &scm_lambda)
339         return e;
340       if (car (e) == &scm_symbol_set_x)
341         return set_env_x (cadr (e), eval (caddr (e), a), a);
342 #if QUASIQUOTE
343       else if (car (e) == &scm_symbol_unquote)
344         return eval (cadr (e), a);
345       else if (car (e) == &scm_symbol_quasiquote) {
346 #if DEBUG
347         printf ("cadr e:");
348         display (cadr (e));
349         puts ("");
350         printf ("qq:");
351         display (eval_quasiquote (cadr (e), a));
352         puts ("");
353 #endif // DEBUG
354         return eval_quasiquote (cadr (e), a);
355       }
356 #endif // QUASIQUOTE
357       else if (car (e) == &scm_symbol_cond)
358         return evcon (cdr (e), a);
359 #if MACROS
360       else if ((macro = assq (car (e), cdr (assq (&scm_macro, a)))) != &scm_f)
361         return eval (apply_ (cdr (macro), cdr (e), a), a);
362 #endif // MACROS
363       return apply (car (e), evlis (cdr (e), a), a);
364     }
365   return apply (car (e), evlis (cdr (e), a), a);
366 }
367
368 scm *
369 evcon_ (scm *c, scm *a)
370 {
371 #if DEBUG
372   printf ("evcon_ clause=");
373   display (car (c));
374   puts ("");
375 #endif
376   if (c == &scm_nil) return &scm_unspecified;
377   if (eval (caar (c), a) != &scm_f) {
378 #if DEBUG
379     //if (fn != &scm_display && fn != &scm_call)
380     //if (fn != &scm_call)
381     printf ("#t clause=");
382     display (car (c));
383     printf (" cddar=");
384     display (cddar (c));
385     printf (" nil=%d", cddar (c) == &scm_nil);
386     puts ("");
387 #endif
388     if (cddar (c) == &scm_nil)
389       return eval (cadar (c), a);
390     eval (cadar (c), a);
391     return evcon_ (cons (cons (&scm_t, cddar (c)), &scm_nil), a);
392   }
393   return evcon_ (cdr (c), a);
394 }
395
396 scm *
397 evcon (scm *c, scm *a)
398 {
399 #if DEBUG
400   printf ("\n****evcon=");
401   display (c);
402   puts ("");
403 #endif
404   return evcon_ (c, a);
405 }
406
407 scm *
408 evlis (scm *m, scm *a)
409 {
410 #if DEBUG
411   printf ("evlis m=");
412   display (m);
413   puts ("");
414 #endif
415   if (m == &scm_nil)
416     return &scm_nil;
417   scm *e = eval (car (m), a);
418   return cons (e, evlis (cdr (m), a));
419 }
420
421 //Helpers
422
423 scm *
424 builtin_p (scm *x)
425 {
426   return (x->type == FUNCTION0
427           || x->type == FUNCTION1
428           || x->type == FUNCTION2
429           || x->type == FUNCTION3
430           || x->type == FUNCTIONn)
431     ? &scm_t : &scm_f;
432 }
433
434 scm *
435 char_p (scm *x)
436 {
437   return x->type == CHAR ? &scm_t : &scm_f;
438 }
439
440 scm *
441 number_p (scm *x)
442 {
443   return x->type == NUMBER ? &scm_t : &scm_f;
444 }
445
446 scm *
447 string_p (scm *x)
448 {
449   return x->type == STRING ? &scm_t : &scm_f;
450 }
451
452 scm *
453 symbol_p (scm *x)
454 {
455   //TODO: #f,#t,nil also `symbols' atm
456   return x->type == SYMBOL ? &scm_t : &scm_f;
457 }
458
459 scm *
460 vector_p (scm *x)
461 {
462   return x->type == VECTOR ? &scm_t : &scm_f;
463 }
464
465 scm *
466 display (scm *x)
467 {
468   return display_helper (x, false, "", false);
469 }
470
471 scm *
472 call (scm *fn, scm *x)
473 {
474 #if DEBUG
475   //if (fn != &scm_display && fn != &scm_call)
476   //if (fn != &scm_call)
477   {
478     printf ("\ncall fn=");
479     display (fn);
480     printf (" x=");
481     display (x);
482     puts ("");
483   }
484 #endif
485   if (fn->type == FUNCTION0)
486     return fn->function0 ();
487   if (x->car->type == VALUES)
488     x = cons (x->car->cdr->car, &scm_nil);
489   if (fn->type == FUNCTION1)
490     return fn->function1 (car (x));
491   if (fn->type == FUNCTION2)
492     return fn->function2 (car (x), cadr (x));
493   if (fn->type == FUNCTION3)
494     return fn->function3 (car (x), cadr (x), caddr (x));
495   if (fn->type == FUNCTIONn)
496     return fn->functionn (x);
497   return &scm_unspecified;
498 }
499
500 scm *
501 append2 (scm *x, scm *y)
502 {
503   if (x == &scm_nil) return y;
504   assert (x->type == PAIR);
505   return cons (car (x), append2 (cdr (x), y));
506 }
507
508 scm *
509 append (scm *x/*...*/)
510  {
511   if (x == &scm_nil) return &scm_nil;
512   return append2 (car (x), append (cdr (x)));
513  }
514
515 scm *
516 make_char (int x)
517 {
518   scm *p = malloc (sizeof (scm));
519   p->type = CHAR;
520   p->value = x;
521   return p;
522 }
523
524 scm *
525 make_number (int x)
526 {
527   scm *p = malloc (sizeof (scm));
528   p->type = NUMBER;
529   p->value = x;
530   return p;
531 }
532
533 scm *
534 make_string (char const *s)
535 {
536   scm *p = malloc (sizeof (scm));
537   p->type = STRING;
538   p->name = strdup (s);
539   return p;
540 }
541
542 scm *
543 make_symbol (char const *s)
544 {
545   // TODO: alist lookup symbols
546   scm *p = malloc (sizeof (scm));
547   p->type = SYMBOL;
548   p->name = strdup (s);
549   return p;
550 }
551
552 scm *
553 make_vector (int n)
554 {
555   scm *p = malloc (sizeof (scm));
556   p->type = VECTOR;
557   p->length = n;
558   p->vector = malloc (n * sizeof (scm*));
559   return p;
560 }
561
562 scm *
563 string (scm *x/*...*/)
564 {
565   char buf[256] = "";
566   char *p = buf;
567   while (x != &scm_nil)
568     {
569       scm *s = car (x);
570       assert (s->type == CHAR);
571       *p++ = s->value;
572       x = cdr (x);
573     }
574   return make_string (buf);
575 }
576
577 scm *
578 string_append (scm *x/*...*/)
579 {
580   char buf[256] = "";
581
582   while (x != &scm_nil)
583     {
584       scm *s = car (x);
585       assert (s->type == STRING);
586       strcat (buf, s->name);
587       x = cdr (x);
588     }
589   return make_string (buf);
590 }
591
592 scm *
593 string_length (scm *x)
594 {
595   assert (x->type == STRING);
596   return make_number (strlen (x->name));
597 }
598
599 scm *
600 length (scm *x)
601 {
602   int n = 0;
603   while (x != &scm_nil)
604     {
605       n++;
606       x = cdr (x);
607     }
608   return make_number (n);
609 }
610
611 #if 0
612 scm *
613 builtin_list (scm *x/*...*/) // int
614 {
615   return x;
616 }
617
618 scm *
619 vector (scm *x/*...*/) // int
620 {
621   return list_to_vector (x);
622 }
623 #endif
624
625 scm *
626 values (scm *x/*...*/)
627 {
628   scm *v = cons (0, x);
629   v->type = VALUES;
630   return v;
631 }
632
633 scm *
634 call_with_values_env (scm *producer, scm *consumer, scm *a)
635 {
636   scm *v = apply_ (producer, &scm_nil, a);
637   if (v->type == VALUES)
638     v = v->cdr;
639   return apply_ (consumer, v, a);
640 }
641
642 scm *
643 vector_length (scm *x)
644 {
645   assert (x->type == VECTOR);
646   return make_number (x->length);
647 }
648
649 scm *
650 vector_ref (scm *x, scm *i)
651 {
652   assert (x->type == VECTOR);
653   assert (i->value < x->length);
654   return x->vector[i->value];
655 }
656
657 scm *
658 vector_set_x (scm *x, scm *i, scm *e)
659 {
660   assert (x->type == VECTOR);
661   assert (i->value < x->length);
662   x->vector[i->value] = e;
663   return &scm_unspecified;
664 }
665
666 scm *
667 lookup (char *x, scm *a)
668 {
669   if (isdigit (*x) || (*x == '-' && isdigit (*(x+1))))
670     return make_number (atoi (x));
671   if (*x == '\'') return &scm_symbol_quote;
672
673   if (!strcmp (x, scm_unspecified.name)) return &scm_unspecified;
674   if (!strcmp (x, scm_symbol_cond.name)) return &scm_symbol_cond;
675   if (!strcmp (x, scm_symbol_quote.name)) return &scm_symbol_quote;
676   if (!strcmp (x, scm_lambda.name)) return &scm_lambda;
677   if (!strcmp (x, scm_label.name)) return &scm_label;
678   if (!strcmp (x, scm_nil.name)) return &scm_nil;
679   if (!strcmp (x, scm_symbol_set_x.name)) return &scm_symbol_set_x;
680
681 #if QUASIQUOTE
682   if (*x == '`') return &scm_symbol_quasiquote;
683   if (*x == ',') return &scm_symbol_unquote;  
684   if (!strcmp (x, scm_symbol_unquote.name)) return &scm_symbol_unquote;
685   if (!strcmp (x, scm_symbol_quasiquote.name)) return &scm_symbol_quasiquote;
686 #endif
687
688   return make_symbol (x);
689 }
690
691 scm *
692 lookup_char (int c, scm *a)
693 {
694   char buf[2];
695   buf[0] = c;
696   buf[1] = 0;
697   return lookup (buf, a);
698 }
699
700 char *
701 list2str (scm *l) // char*
702 {
703   static char buf[256];
704   char *p = buf;
705   while (l != &scm_nil) {
706     scm *c = car (l);
707     assert (c->type == NUMBER);
708     *p++ = c->value;
709     l = cdr (l);
710   }
711   *p = 0;
712   return buf;
713 }
714
715 scm*
716 list_to_vector (scm *x)
717 {
718   int n = length (x)->value;
719   scm *v = make_vector (n);
720   scm **p = v->vector;
721   while (x != &scm_nil)
722     {
723       *p++ = car (x);
724       x = cdr (x);
725     }
726   return v;
727 }
728
729 scm*
730 number_to_string (scm *x)
731 {
732   assert (x->type == NUMBER);
733   char buf[256];
734   sprintf (buf,"%d", x->value);
735   return make_string (buf);
736 }
737
738 scm*
739 string_to_symbol (scm *x)
740 {
741   assert (x->type == STRING);
742   return make_symbol (x->name);
743 }
744
745 scm*
746 symbol_to_string (scm *x)
747 {
748   assert (x->type == SYMBOL);
749   return make_string (x->name);
750 }
751
752 scm*
753 vector_to_list (scm *v)
754 {
755   scm *x = &scm_nil;
756   for (int i = 0; i < v->length; i++)
757     x = append2 (x, cons (v->vector[i], &scm_nil));
758   return x;
759 }
760
761 scm *
762 builtin_lookup (scm *l, scm *a)
763 {
764   return lookup (list2str (l), a);
765 }
766
767 scm *
768 cossa (scm *x, scm *a)
769 {
770   if (a == &scm_nil) return &scm_f;
771   if (eq_p (cdar (a), x) == &scm_t)
772     return car (a);
773   return cossa (x, cdr (a));
774 }
775
776 scm *
777 newline ()
778 {
779   puts ("");
780   return &scm_unspecified;
781 }
782
783 scm *
784 display_helper (scm *x, bool cont, char *sep, bool quote)
785 {
786   scm *r;
787   printf ("%s", sep);
788   if (x->type == CHAR && x->value == 10) printf ("#\\%s", "newline");
789   else if (x->type == CHAR && x->value == 32) printf ("#\\%s", "space");
790   else if (x->type == CHAR) printf ("#\\%c", x->value);
791   else if (x->type == NUMBER) printf ("%d", x->value);
792   else if (x->type == PAIR) {
793 #if QUOTE_SUGAR
794     if (car (x) == &scm_quote) {
795       printf ("'");
796       return display_helper (car (cdr (x)), cont, "", true);
797     }
798 #if QUASIQUOTE
799     if (car (x) == &scm_quasiquote) {
800       printf ("`");
801       return display_helper (car (cdr (x)), cont, "", true);
802     }
803     if (car (x) == &scm_unquote) {
804       printf (",");
805       return display_helper (car (cdr (x)), cont, "", true);
806     }
807 #endif
808 #endif
809     if (!cont) printf ("(");
810     display (car (x));
811     if (cdr (x)->type == PAIR)
812       display_helper (cdr (x), true, " ", false);
813     else if (cdr (x) != &scm_nil) {
814       printf (" . ");
815       display (cdr (x));
816     }
817     if (!cont) printf (")");
818   }
819   else if (x->type == VECTOR) {
820     printf ("#(");
821     for (int i = 0; i < x->length; i++)
822       display_helper (x->vector[i], true, i ? " " : "", false);
823     printf (")");
824   }
825   else if (atom_p (x) == &scm_t) printf ("%s", x->name);
826
827   return &scm_unspecified;
828 }
829
830 // READ
831
832 int
833 ungetchar (int c) //int
834 {
835   return ungetc (c, stdin);
836 }
837
838 int
839 peekchar () //int
840 {
841   int c = getchar ();
842   ungetchar (c);
843   return c;
844 }
845
846 scm*
847 builtin_getchar ()
848 {
849   return make_number (getchar ());
850 }
851
852 scm*
853 builtin_peekchar ()
854 {
855   return make_number (peekchar ());
856 }
857
858 scm*
859 builtin_ungetchar (scm *c)
860 {
861   assert (c->type == NUMBER);
862   ungetchar (c->value);
863   return c;
864 }
865
866 int
867 readcomment (int c)
868 {
869   if (c == '\n') return c;
870   return readcomment (getchar ());
871 }
872
873 int
874 readblock (int c)
875 {
876   if (c == '!' && peekchar () == '#') return getchar ();
877   return readblock (getchar ());
878 }
879
880 scm *
881 readword (int c, char* w, scm *a)
882 {
883   if (c == EOF && !w) return &scm_nil;
884   if (c == '\n' && !w) return readword (getchar (), w, a);
885   if (c == '\n' && *w == '.' && w[1] == 0) return &scm_dot;
886   if (c == EOF || c == '\n') return lookup (w, a);
887   if (c == ' ') return readword ('\n', w, a);
888   if (c == '"' && !w) return readstring ();
889   if (c == '"') {ungetchar (c); return lookup (w, a);}
890   if (c == '(' && !w) return readlist (a);
891   if (c == '(') {ungetchar (c); return lookup (w, a);}
892   if (c == ')' && !w) {ungetchar (c); return &scm_nil;}
893   if (c == ')') {ungetchar (c); return lookup (w, a);}
894   if ((c == '\''
895 #if QUASIQUOTE
896        || c == '`'
897        || c == ','
898 #endif
899        )
900       && !w) {return cons (lookup_char (c, a),
901                                      cons (readword (getchar (), w, a),
902                                            &scm_nil));}
903   if (c == ';') {readcomment (c); return readword ('\n', w, a);}
904   if (c == '#' && peekchar () == '\\') {getchar (); return readchar ();}
905   if (c == '#' && !w && peekchar () == '(') {getchar (); return list_to_vector (readlist (a));}
906   if (c == '#' && peekchar () == '(') {ungetchar (c); return lookup (w, a);}
907   if (c == '#' && peekchar () == '!') {getchar (); readblock (getchar ()); return readword (getchar (), w, a);}
908   char buf[256] = {0};
909   char ch = c;
910   return readword (getchar (), strncat (w ? w : buf, &ch, 1), a);
911 }
912
913 scm *
914 readchar ()
915 {
916   int c = getchar ();
917   if (c >= '0' && c <= '7'
918       && peekchar () >= '0' && peekchar () <= '7') {
919     c = c - '0';
920     while (peekchar () >= '0' && peekchar () <= '7') {
921       c <<= 3;
922       c += getchar () - '0';
923     }
924   }
925   else if (c >= 'a' && c <= 'z'
926       && peekchar () >= 'a' && peekchar () <= 'z') {
927     char buf[256];
928     char *p = buf;
929     *p++ = c;
930     while (peekchar () >= 'a' && peekchar () <= 'z') {
931       *p++ = getchar ();
932     }
933     *p = 0;
934     if (!strcmp (buf, "newline")) c = 10;
935     else if (!strcmp (buf, "space")) c = 32;
936     else {
937       printf ("char not supported: %s", buf);
938       assert (!"char not supported");
939     }
940   }
941   return make_char (c);
942 }
943
944 scm *
945 readstring ()
946 {
947   char buf[256];
948   char *p = buf;
949   int c = getchar ();
950   while (true) {
951     if (c == '"') break;
952     *p++ = c;
953     if (c == '\\' && peekchar () == '"') *p++ = getchar ();
954     if (c == EOF) assert (!"EOF in string");
955     c = getchar ();
956   }
957   *p = 0;
958   return make_string (buf);
959 }
960
961 int
962 eat_whitespace (int c)
963 {
964   while (c == ' ' || c == '\n') c = getchar ();
965   if (c == ';') return eat_whitespace (readcomment (c));
966   if (c == '#' && peekchar () == '!') {getchar (); readblock (getchar ()); return eat_whitespace (getchar ());}
967   return c;
968 }
969
970 scm *
971 readlist (scm *a)
972 {
973   int c = getchar ();
974   c = eat_whitespace (c);
975   if (c == ')') return &scm_nil;
976   scm *w = readword (c, 0, a);
977   if (w == &scm_dot)
978     return car (readlist (a));
979   return cons (w, readlist (a));
980 }
981
982 scm *
983 readenv (scm *a)
984 {
985   return readword (getchar (), 0, a);
986 }
987
988 // Extras to make interesting program
989
990 scm *
991 hello_world ()
992 {
993   puts ("c: hello world");
994   return &scm_unspecified;
995 }
996
997 scm *
998 less_p (scm *a, scm *b)
999 {
1000   assert (a->type == NUMBER);
1001   assert (b->type == NUMBER);
1002   return a->value < b->value ? &scm_t : &scm_f;
1003 }
1004
1005 scm *
1006 minus (scm *x/*...*/)
1007 {
1008   scm *a = car (x);
1009   assert (a->type == NUMBER);
1010   int n = a->value;
1011   x = cdr (x);
1012   if (x == &scm_nil)
1013     n = -n;
1014   while (x != &scm_nil)
1015     {
1016       assert (x->car->type == NUMBER);
1017       n -= x->car->value;
1018       x = cdr (x);
1019     }
1020   return make_number (n);
1021 }
1022
1023 scm *
1024 plus (scm *x/*...*/)
1025 {
1026   int n = 0;
1027   while (x != &scm_nil)
1028     {
1029       assert (x->car->type == NUMBER);
1030       n += x->car->value;
1031       x = cdr (x);
1032     }
1033   return make_number (n);
1034 }
1035
1036 scm *
1037 divide (scm *x/*...*/)
1038 {
1039   int n = 1;
1040   while (x != &scm_nil)
1041     {
1042       assert (x->car->type == NUMBER);
1043       n /= x->car->value;
1044       x = cdr (x);
1045     }
1046   return make_number (n);
1047 }
1048
1049 scm *
1050 multiply (scm *x/*...*/)
1051 {
1052   int n = 1;
1053   while (x != &scm_nil)
1054     {
1055       assert (x->car->type == NUMBER);
1056       n *= x->car->value;
1057       x = cdr (x);
1058     }
1059   return make_number (n);
1060 }
1061
1062 scm *
1063 is_p (scm *a, scm *b)
1064 {
1065   assert (a->type == NUMBER);
1066   assert (b->type == NUMBER);
1067   return a->value == b->value ? &scm_t : &scm_f;
1068 }
1069
1070 #if QUASIQUOTE
1071 scm *
1072 eval_quasiquote (scm *e, scm *a)
1073 {
1074 #if DEBUG
1075   printf ("\nc:eval_quasiquote e=");
1076   display (e);
1077   if (pair_p (e) == &scm_t) {
1078     printf ("\ncar (e)=");
1079     display (car (e));
1080     printf (" atom=");
1081     display (atom_p (car (e)));
1082   }
1083   puts ("");
1084 #endif
1085   if (e == &scm_nil) return e;
1086   else if (atom_p (e) == &scm_t) return e;
1087   else if (atom_p (car (e)) == &scm_t)
1088     return cons (car (e), eval_quasiquote (cdr (e), a));
1089   else if (eq_p (caar (e), &scm_symbol_unquote) == &scm_t)
1090     return cons (eval (cadar (e), a), &scm_nil);
1091   else if (eq_p (caar (e), &scm_symbol_quote) == &scm_t)
1092     return cons (cadar (e), &scm_nil);
1093   else if (eq_p (caar (e), &scm_symbol_quasiquote) == &scm_t)
1094     return cdar (e);
1095   return cons (car (e), eval_quasiquote (cdr (e), a));
1096 }
1097 #endif
1098
1099 scm *
1100 add_environment (scm *a, char *name, scm *x)
1101 {
1102   return cons (cons (make_symbol (name), x), a);
1103 }
1104
1105 scm *
1106 mes_environment ()
1107 {
1108   scm *a = &scm_nil;
1109
1110   a = add_environment (a, "()", &scm_nil);
1111   a = add_environment (a, "#t", &scm_t);
1112   a = add_environment (a, "#f", &scm_f);
1113   a = add_environment (a, "*unspecified*", &scm_unspecified);
1114   a = add_environment (a, "label", &scm_label);
1115   a = add_environment (a, "lambda", &scm_lambda);
1116   a = add_environment (a, "*macro*", &scm_nil);
1117   a = add_environment (a, "*dot*", &scm_dot);
1118   a = add_environment (a, "current-module", &scm_symbol_current_module);
1119
1120   a = add_environment (a, "'", &scm_quote);
1121 #if QUASIQUOTE
1122   a = add_environment (a, ",", &scm_unquote);
1123   a = add_environment (a, "`", &scm_quasiquote);
1124 #endif
1125
1126 #include "environment.i"
1127   
1128   return a;
1129 }
1130
1131 scm *
1132 define_lambda (scm *x)
1133 {
1134   return cons (caadr (x), cons (&scm_lambda, cons (cdadr (x), cddr (x))));
1135 }
1136
1137 scm *
1138 define (scm *x, scm *a)
1139 {
1140   if (atom_p (cadr (x)) != &scm_f)
1141     return cons (cadr (x), eval (caddr (x), a));
1142   return define_lambda (x);
1143 }
1144
1145 scm *
1146 define_macro (scm *x, scm *a)
1147 {
1148 #if DEBUG
1149   printf ("\nc:define_macro a=");
1150   scm *aa =cons (&scm_macro,
1151                cons (define_lambda (x),
1152                      cdr (assq (&scm_macro, a))));
1153   display (aa);
1154   puts ("");
1155 #endif
1156   if (atom_p (cadr (x)) != &scm_f)
1157     return cons (&scm_macro,
1158                  cons (cons (cadr (x), eval (caddr (x), a)),
1159                        cdr (assq (&scm_macro, a))));
1160   return cons (&scm_macro,
1161                cons (define_lambda (x),
1162                      cdr (assq (&scm_macro, a))));
1163 }
1164
1165 scm *
1166 loop (scm *r, scm *e, scm *a)
1167 {
1168 #if 0//DEBUG
1169   printf ("\nc:loop e=");
1170   display (e);
1171   puts ("");
1172 #endif
1173   if (e == &scm_nil)
1174     return r;
1175   else if (eq_p (e, &scm_symbol_EOF) == &scm_t)
1176     return apply (cdr (assq (&scm_symbol_loop2, a)),
1177                   cons (&scm_unspecified, cons (&scm_t, cons (a, &scm_nil))), a);
1178   else if (eq_p (e, &scm_symbol_EOF2) == &scm_t)
1179     return r;
1180   else if (atom_p (e) == &scm_t)
1181     return loop (eval (e, a), readenv (a), a);
1182   else if (eq_p (car (e), &scm_symbol_define) == &scm_t)
1183     return loop (&scm_unspecified,
1184                  readenv (a),
1185                  cons (define (e, a), a));
1186   else if (eq_p (car (e), &scm_symbol_define_macro) == &scm_t)
1187     return loop (&scm_unspecified,
1188                  readenv (a),
1189                  cons (define_macro (e, a), a));
1190   else if (eq_p (car (e), &scm_symbol_set_x) == &scm_t)
1191     return loop (set_env_x (cadr (e), eval (caddr (e), a), a), readenv (a), a);
1192   return loop (eval (e, a), readenv (a), a);
1193 }
1194
1195 int
1196 main (int argc, char *argv[])
1197 {
1198   scm *a = mes_environment ();
1199   display (loop (&scm_unspecified, readenv (a), a));
1200   newline ();
1201   return 0;
1202 }
1203
1204 scm *
1205 apply (scm *fn, scm *x, scm *a)
1206 {
1207 #if DEBUG
1208   printf ("\nc:apply fn=");
1209   display (fn);
1210   printf (" x=");
1211   display (x);
1212   puts ("");
1213 #endif
1214   if (fn == &scm_apply_)
1215     return eval_ (x, a);
1216   return apply_ (fn, x, a);
1217 }
1218
1219 bool evalling_p = false;
1220
1221 scm *
1222 eval (scm *e, scm *a)
1223 {
1224 #if DEBUG
1225   printf ("\nc:eval e=");
1226   display (e);
1227   puts ("");
1228 #endif
1229
1230   scm *eval__ = assq (&scm_symbol_eval, a);
1231   assert (eval__ != &scm_f);
1232   eval__ = cdr (eval__);
1233   if (builtin_p (eval__) == &scm_t
1234       || evalling_p)
1235     return eval_ (e, a);
1236   evalling_p = true;
1237   scm *r = apply (eval__, cons (e, cons (a, &scm_nil)), a);
1238   evalling_p = false;
1239   return r;
1240 }