eval: disarm lambda.
[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 <stdarg.h>
32 #include <stdio.h>
33 #include <string.h>
34 #include <stdlib.h>
35 #include <stdbool.h>
36
37 #define DEBUG 0
38
39 #define MACROS 1
40 #define QUASIQUOTE 1
41
42 #ifndef QUOTE_SUGAR
43 #define QUOTE_SUGAR 1
44 #endif
45
46 enum type {ATOM, NUMBER, PAIR, FUNCTION0, FUNCTION1, FUNCTION2, FUNCTION3};
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
53 typedef struct scm_t {
54   enum type type;
55   union {
56     char *name;
57     struct scm_t* car;
58   };
59   union {
60     int value;
61     function0_t function0;
62     function1_t function1;
63     function2_t function2;
64     function3_t function3;
65     struct scm_t* cdr;
66   };
67 } scm;
68
69 scm scm_nil = {ATOM, "()"};
70 scm scm_dot = {ATOM, "."};
71 scm scm_t = {ATOM, "#t"};
72 scm scm_f = {ATOM, "#f"};
73 scm scm_lambda = {ATOM, "lambda"};
74 scm scm_label = {ATOM, "label"};
75 scm scm_unspecified = {ATOM, "*unspecified*"};
76 scm scm_symbol_cond = {ATOM, "cond"};
77 scm scm_symbol_quote = {ATOM, "quote"};
78 #if QUASIQUOTE
79 scm scm_symbol_quasiquote = {ATOM, "quasiquote"};
80 scm scm_symbol_unquote = {ATOM, "unquote"};
81 #endif
82 #if MACROS
83 scm scm_macro = {ATOM, "*macro*"};
84 #endif
85 scm scm_symbol_current_module = {ATOM, "current-module"};
86
87 // PRIMITIVES
88
89 scm *
90 atom_p (scm *x)
91 {
92   return x->type == PAIR ? &scm_f : &scm_t;
93 }
94 scm scm_atom = {FUNCTION1, .name="atom", .function1 = &atom_p};
95
96 scm *
97 car (scm *x)
98 {
99   assert (x->type == PAIR);
100   return x->car;
101 }
102
103 scm *
104 cdr (scm *x)
105 {
106   assert (x->type == PAIR);
107   return x->cdr;
108 }
109
110 scm *
111 cons (scm *x, scm *y)
112 {
113   scm *p = malloc (sizeof (scm));
114   p->type = PAIR;
115   p->car = x;
116   p->cdr = y;
117   return p;
118 }
119
120 scm *
121 eq_p (scm *x, scm *y)
122 {
123   return (x == y
124           || (x->type == NUMBER && y->type == NUMBER
125               && x->value == y->value)
126           // FIXME: alist lookup symbols
127           || (atom_p (x) == &scm_t
128               && x->type != NUMBER
129               && y->type != NUMBER
130               && atom_p (y) == &scm_t
131               && !strcmp (x->name, y->name)))
132     ? &scm_t : &scm_f;
133 }
134
135 scm *
136 null_p (scm *x)
137 {
138   return eq_p (x, &scm_nil);
139 }
140
141 scm *
142 pair_p (scm *x)
143 {
144   return x->type == PAIR ? &scm_t : &scm_f;
145 }
146
147 scm *eval (scm*, scm*);
148
149 scm *display (scm*);
150
151 scm scm_quote;
152 scm *
153 quote (scm *x)
154 {
155   return cons (&scm_quote, x);
156 }
157
158 #if QUASIQUOTE
159 scm scm_unquote;
160 scm *
161 unquote (scm *x)
162 {
163   return cons (&scm_unquote, x);
164 }
165
166 scm scm_quasiquote;
167 scm *
168 quasiquote (scm *x)
169 {
170   return cons (&scm_quasiquote, x);
171 }
172
173 scm *eval_quasiquote (scm *, scm *);
174
175 #endif
176
177 //Library functions
178 scm scm_read;
179
180
181 // Derived, non-primitives
182 scm *caar (scm *x) {return car (car (x));}
183 scm *cadr (scm *x) {return car (cdr (x));}
184 scm *cdar (scm *x) {return cdr (car (x));}
185 scm *cddr (scm *x) {return cdr (cdr (x));}
186 scm *caadr (scm *x) {return car (car (cdr (x)));}
187 scm *caddr (scm *x) {return car (cdr (cdr (x)));}
188 scm *cdadr (scm *x) {return cdr (car (cdr (x)));}
189 scm *cadar (scm *x) {return car (cdr (car (x)));}
190 scm *cddar (scm *x) {return cdr (cdr (car (x)));}
191 scm *cdddr (scm *x) {return cdr (cdr (cdr (x)));}
192 scm scm_caar  = {FUNCTION1, .name="caar ", .function1 = &caar };
193 scm scm_cadr  = {FUNCTION1, .name="cadr ", .function1 = &cadr };
194 scm scm_cdar  = {FUNCTION1, .name="cdar ", .function1 = &cdar };
195 scm scm_cddr  = {FUNCTION1, .name="cddr ", .function1 = &cddr };
196 scm scm_caadr = {FUNCTION1, .name="caadr", .function1 = &caadr};
197 scm scm_caddr = {FUNCTION1, .name="caddr", .function1 = &caddr};
198 scm scm_cdadr = {FUNCTION1, .name="cdadr", .function1 = &cdadr};
199 scm scm_cadar = {FUNCTION1, .name="cadar", .function1 = &cadar};
200 scm scm_cddar = {FUNCTION1, .name="cddar", .function1 = &cddar};
201 scm scm_cdddr = {FUNCTION1, .name="cdddr", .function1 = &cdddr};
202
203 scm *
204 list (scm *x, ...)
205 {
206   va_list args;
207   scm *lst = &scm_nil;
208
209   va_start (args, x);
210   while (x != &scm_unspecified)
211     {
212       lst = cons (x, lst);
213       x = va_arg (args, scm*);
214     }
215   va_end (args);
216   return lst;
217 }
218
219 scm* make_atom (char const *);
220
221 scm *
222 pairlis (scm *x, scm *y, scm *a)
223 {
224 #if DEBUG
225   printf ("pairlis x=");
226   display (x);
227   printf (" y=");
228   display (y);
229   puts ("");
230 #endif
231   if (x == &scm_nil)
232     return a;
233   if (atom_p (x) == &scm_t)
234     return cons (cons (x, y), a);
235   return cons (cons (car (x), car (y)),
236                pairlis (cdr (x), cdr (y), a));
237 }
238 scm scm_pairlis = {FUNCTION3, .name="pairlis", .function3 = &pairlis};
239
240 scm *
241 assoc (scm *x, scm *a)
242 {
243   if (a == &scm_nil) {
244 #if DEBUG
245     printf ("alist miss: %s\n", x->name);
246 #endif
247     return &scm_f;
248   }
249   if (eq_p (caar (a), x) == &scm_t)
250     return car (a);
251   return assoc (x, cdr (a));
252 }
253 scm scm_assoc = {FUNCTION2, .name="assoc", .function2 = &assoc};
254
255 scm *apply (scm*, scm*, scm*);
256 scm *eval_ (scm*, scm*);
257 scm *apply_ (scm*, scm*, scm*);
258
259 scm *
260 eval_quote (scm *fn, scm *x)
261 {
262   return apply (fn, x, &scm_nil);
263 }
264
265 scm *builtin_p (scm*);
266 scm *call (scm *, scm*);
267 scm *display (scm*);
268 scm *newline ();
269
270 scm *
271 apply_ (scm *fn, scm *x, scm *a)
272 {
273 #if DEBUG
274   printf ("apply fn=");
275   display (fn);
276   printf (" x=");
277   display (x);
278   puts ("");
279 #endif
280   if (atom_p (fn) != &scm_f)
281     {
282       if (fn == &scm_symbol_current_module) // FIXME
283         return a;
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     scm *body = cddr (fn);
290     scm *ca = cadr (fn);
291     scm *ax = pairlis (cadr (fn), x, a);
292     scm *result = eval (car (body), ax);
293     if (cdr (body) == &scm_nil)
294       return result;
295     return apply (cons (car (fn), cons (cadr (fn), cdddr (fn))), x, ax);
296   }
297   else if (car (fn) == &scm_label)
298     return apply (caddr (fn), x, cons (cons (cadr (fn), caddr (fn)), a));
299   return &scm_unspecified;
300 }
301
302 scm *evcon (scm*, scm*);
303 scm *evlis (scm*, scm*);
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 == NUMBER)
314     return e;
315   else if (atom_p (e) == &scm_t) {
316     scm *y = assoc (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 QUASIQUOTE
335       else if (car (e) == &scm_symbol_unquote)
336         return eval (cadr (e), a);
337       else if (car (e) == &scm_symbol_quasiquote) {
338 #if DEBUG
339         printf ("cadr e:");
340         display (cadr (e));
341         puts ("");
342         printf ("qq:");
343         display (eval_quasiquote (cadr (e), a));
344         puts ("");
345 #endif // DEBUG
346         return eval_quasiquote (cadr (e), a);
347       }
348 #endif // QUASIQUOTE
349       else if (car (e) == &scm_symbol_cond)
350         return evcon (cdr (e), a);
351 #if MACROS
352       else if ((macro = assoc (car (e), cdr (assoc (&scm_macro, a)))) != &scm_f)
353         return eval (apply_ (cdr (macro), cdr (e), a), a);
354 #endif // MACROS
355       return apply (car (e), evlis (cdr (e), a), a);
356     }
357   return apply (car (e), evlis (cdr (e), a), a);
358 }
359
360 scm *
361 evcon_ (scm *c, scm *a)
362 {
363 #if DEBUG
364   printf ("evcon_ clause=");
365   display (car (c));
366   puts ("");
367 #endif
368   if (eval (caar (c), a) != &scm_f) {
369 #if DEBUG
370     //if (fn != &scm_display && fn != &scm_call)
371     //if (fn != &scm_call)
372     printf ("#t clause=");
373     display (car (c));
374     printf (" cddar=");
375     display (cddar (c));
376     printf (" nil=%d", cddar (c) == &scm_nil);
377     puts ("");
378 #endif
379     if (cddar (c) == &scm_nil)
380       return eval (cadar (c), a);
381     eval (cadar (c), a);
382     return evcon_ (cons (cons (&scm_t, cddar (c)), &scm_nil), a);
383   }
384   return evcon_ (cdr (c), a);
385 }
386
387 scm *
388 evcon (scm *c, scm *a)
389 {
390 #if DEBUG
391   printf ("\n****evcon=");
392   display (c);
393   puts ("");
394 #endif
395   return evcon_ (c, a);
396 }
397
398 scm scm_evcon = {FUNCTION2, .name="evcon", .function2 = &evcon};
399
400 scm *
401 evlis (scm *m, scm *a)
402 {
403 #if DEBUG
404   printf ("evlis m=");
405   display (m);
406   puts ("");
407 #endif
408   if (m == &scm_nil)
409     return &scm_nil;
410   scm *e = eval (car (m), a);
411   return cons (e, evlis (cdr (m), a));
412 }
413 scm scm_evlis = {FUNCTION2, .name="evlis", .function2 = &evlis};
414
415
416 //Primitives
417 scm scm_car = {FUNCTION1, "car", .function1 = &car};
418 scm scm_cdr = {FUNCTION1, "cdr", .function1 = &cdr};
419 scm scm_cons = {FUNCTION2, "cons", .function2 = &cons};
420 scm scm_cond = {FUNCTION2, "cond", .function2 = &evcon};
421 scm scm_eq_p = {FUNCTION2, "eq", .function2 = &eq_p};
422 scm scm_null_p = {FUNCTION1, "null", .function1 = &null_p};
423 scm scm_pair_p = {FUNCTION1, "pair", .function1 = &pair_p};
424 scm scm_quote = {FUNCTION1, "quote", .function1 = &quote};
425
426 #if QUASIQUOTE
427 scm scm_unquote = {FUNCTION1, "unquote", .function1 = &unquote};
428 scm scm_quasiquote = {FUNCTION1, "quasiquote", .function1 = &quasiquote};
429 #endif
430
431 scm scm_eval = {FUNCTION2, .name="eval", .function2 = &eval};
432 scm scm_apply = {FUNCTION3, .name="apply", .function3 = &apply};
433
434 scm scm_apply_ = {FUNCTION3, .name="c:apply", .function3 = &apply_};
435 scm scm_eval_ = {FUNCTION2, .name="c:eval", .function2 = &eval_};
436
437 //Helpers
438
439 scm *
440 builtin_p (scm *x)
441 {
442   return (x->type == FUNCTION0
443           || x->type == FUNCTION1
444           || x->type == FUNCTION2
445           || x->type == FUNCTION3)
446     ? &scm_t : &scm_f;
447 }
448 scm scm_builtin_p = {FUNCTION1, .name="builtin", .function1 = &builtin_p};
449
450 scm *
451 number_p (scm *x)
452 {
453   return x->type == NUMBER ? &scm_t : &scm_f;
454 }
455 scm scm_number_p = {FUNCTION1, .name="number", .function1 = &number_p};
456
457 scm *display_helper (scm*, bool, char*, bool);
458
459 scm *
460 display (scm *x)
461 {
462   return display_helper (x, false, "", false);
463 }
464 scm scm_display = {FUNCTION1, .name="display", .function1 = &display};
465
466 scm *call (scm*, scm*);
467 scm scm_call = {FUNCTION2, .name="call", .function2 = &call};
468
469 scm *
470 call (scm *fn, scm *x)
471 {
472 #if DEBUG
473   //if (fn != &scm_display && fn != &scm_call)
474   //if (fn != &scm_call)
475   {
476     printf ("\ncall fn=");
477     display (fn);
478     printf (" x=");
479     display (x);
480     puts ("");
481   }
482 #endif
483   if (fn->type == FUNCTION0)
484     return fn->function0 ();
485   if (fn->type == FUNCTION1)
486     return fn->function1 (car (x));
487   if (fn->type == FUNCTION2)
488     return fn->function2 (car (x), cadr (x));
489   if (fn->type == FUNCTION3)
490     return fn->function3 (car (x), cadr (x), caddr (x));
491   return &scm_unspecified;
492 }
493
494 scm *
495 append (scm *x, scm *y)
496 {
497   if (x == &scm_nil) return y;
498   assert (x->type == PAIR);
499    return cons (car (x), append (cdr (x), y));
500 }
501 scm scm_append = {FUNCTION2, .name="append", .function2 = &append};
502
503
504 scm *
505 make_atom (char const *s)
506 {
507   // TODO: alist lookup symbols
508   scm *p = malloc (sizeof (scm));
509   p->type = ATOM;
510   p->name = strdup (s);
511   return p;
512 }
513
514 scm *
515 make_number (int x)
516 {
517   scm *p = malloc (sizeof (scm));
518   p->type = NUMBER;
519   p->value = x;
520   return p;
521 }
522
523 scm *
524 lookup (char *x, scm *a)
525 {
526   if (isdigit (*x) || (*x == '-' && isdigit (*(x+1))))
527     return make_number (atoi (x));
528   if (*x == '\'') return &scm_symbol_quote;
529
530   if (!strcmp (x, scm_symbol_cond.name)) return &scm_symbol_cond;
531   if (!strcmp (x, scm_symbol_quote.name)) return &scm_symbol_quote;
532   if (!strcmp (x, scm_lambda.name)) return &scm_lambda;
533   if (!strcmp (x, scm_label.name)) return &scm_label;
534   if (!strcmp (x, scm_nil.name)) return &scm_nil;
535
536 #if QUASIQUOTE
537   if (*x == '`') return &scm_symbol_quasiquote;
538   if (*x == ',') return &scm_symbol_unquote;  
539   if (!strcmp (x, scm_symbol_unquote.name)) return &scm_symbol_unquote;
540   if (!strcmp (x, scm_symbol_quasiquote.name)) return &scm_symbol_quasiquote;
541 #endif
542
543   return make_atom (x);
544 }
545
546 scm *
547 lookup_char (int c, scm *a)
548 {
549   char buf[2];
550   buf[0] = c;
551   buf[1] = 0;
552   return lookup (buf, a);
553 }
554
555 char *
556 list2str (scm *l)
557 {
558   static char buf[256];
559   char *p = buf;
560   while (l != &scm_nil) {
561     scm *c = car (l);
562     assert (c->type == NUMBER);
563     *p++ = c->value;
564     l = cdr (l);
565   }
566   *p = 0;
567   return buf;
568 }
569
570 scm *
571 builtin_lookup (scm *l, scm *a)
572 {
573   return lookup (list2str (l), a);
574 }
575 scm scm_lookup = {FUNCTION2, .name="lookup", .function2 = &builtin_lookup};
576
577 scm *
578 cossa (scm *x, scm *a)
579 {
580   if (a == &scm_nil) return &scm_f;
581   if (eq_p (cdar (a), x) == &scm_t)
582     return car (a);
583   return cossa (x, cdr (a));
584 }
585
586 scm *
587 newline ()
588 {
589   puts ("");
590   return &scm_unspecified;
591 }
592 scm scm_newline = {FUNCTION0, .name="newline", .function0 = &newline};
593
594 scm *
595 display_helper (scm *x, bool cont, char *sep, bool quote)
596 {
597   scm *r;
598   printf ("%s", sep);
599   if (x->type == NUMBER) printf ("%d", x->value);
600   else if (x->type == PAIR) {
601 #if QUOTE_SUGAR
602     if (car (x) == &scm_quote) {
603       printf ("'");
604       return display_helper (car (cdr (x)), cont, "", true);
605     }
606 #if QUASIQUOTE
607     if (car (x) == &scm_symbol_quasiquote
608         || car (x) == &scm_quasiquote) {
609       printf ("`");
610       return display_helper (car (cdr (x)), cont, "", true);
611     }
612     if (car (x) == &scm_symbol_unquote
613         || car (x) == &scm_unquote) {
614       printf (",");
615       return display_helper (car (cdr (x)), cont, "", true);
616     }
617 #endif
618 #endif
619     if (!cont) printf ("(");
620     display (car (x));
621     if (cdr (x)->type == PAIR)
622       display_helper (cdr (x), true, " ", false);
623     else if (cdr (x) != &scm_nil) {
624       printf (" . ");
625       display (cdr (x));
626     }
627     if (!cont) printf (")");
628   }
629   else if (atom_p (x) == &scm_t) printf ("%s", x->name);
630
631   return &scm_unspecified;
632 }
633
634 // READ
635
636 int
637 ungetchar (int c)
638 {
639   return ungetc (c, stdin);
640 }
641
642 int
643 peekchar ()
644 {
645   int c = getchar ();
646   ungetchar (c);
647   return c;
648 }
649
650 scm*
651 builtin_getchar ()
652 {
653   return make_number (getchar ());
654 }
655 scm scm_getchar = {FUNCTION0, .name="getchar", .function0 = &builtin_getchar};
656
657 scm*
658 builtin_peekchar ()
659 {
660   return make_number (peekchar ());
661 }
662 scm scm_peekchar = {FUNCTION0, .name="peekchar", .function0 = &builtin_peekchar};
663
664 scm*
665 builtin_ungetchar (scm* c)
666 {
667   assert (c->type == NUMBER);
668   ungetchar (c->value);
669   return c;
670 }
671 scm scm_ungetchar = {FUNCTION1, .name="ungetchar", .function1 = &builtin_ungetchar};
672
673 int
674 readcomment (int c)
675 {
676   if (c == '\n') return c;
677   return readcomment (getchar ());
678 }
679
680 int
681 readblock (int c)
682 {
683   if (c == '!' && peekchar () == '#') return getchar ();
684   return readblock (getchar ());
685 }
686
687 scm *readlis (scm *a);
688
689 scm *
690 readword (int c, char* w, scm *a)
691 {
692   if (c == EOF && !w) return &scm_nil;
693   if (c == '\n' && !w) return readword (getchar (), w, a);
694   if (c == '\n' && *w == '.' && w[1] == 0) return &scm_dot;
695   if (c == EOF || c == '\n') return lookup (w, a);
696   if (c == ' ') return readword ('\n', w, a);
697   if (c == '(' && !w) return readlis (a);
698   if (c == '(') {ungetchar (c); return lookup (w, a);}
699   if (c == ')' && !w) {ungetchar (c); return &scm_nil;}
700   if (c == ')') {ungetchar (c); return lookup (w, a);}
701   if ((c == '\''
702 #if QUASIQUOTE
703        || c == '`'
704        || c == ','
705 #endif
706        )
707       && !w) {return cons (lookup_char (c, a),
708                                      cons (readword (getchar (), w, a),
709                                            &scm_nil));}
710   if (c == ';') {readcomment (c); return readword ('\n', w, a);}
711   if (c == '#' && peekchar () == '!') {getchar (); readblock (getchar ()); return readword (getchar (), w, a);}
712   char buf[256] = {0};
713   char ch = c;
714   return readword (getchar (), strncat (w ? w : buf, &ch, 1), a);
715 }
716
717 int
718 eat_whitespace (int c)
719 {
720   while (c == ' ' || c == '\n') c = getchar ();
721   if (c == ';') return eat_whitespace (readcomment (c));
722   if (c == '#' && peekchar () == '!') {getchar (); readblock (getchar ()); return eat_whitespace (getchar ());}
723   return c;
724 }
725
726 scm *
727 readlis (scm *a)
728 {
729   int c = getchar ();
730   c = eat_whitespace (c);
731   if (c == ')') return &scm_nil;
732   scm *w = readword (c, 0, a);
733   if (w == &scm_dot)
734     return car (readlis (a));
735   return cons (w, readlis (a));
736 }
737
738 scm *
739 readenv (scm *a)
740 {
741   return readword (getchar (), 0, a);
742 }
743 scm scm_readenv = {FUNCTION1, .name="readenv", .function1 = &readenv};
744
745 // Extras to make interesting program
746
747 scm *
748 hello_world ()
749 {
750   puts ("c: hello world");
751   return &scm_unspecified;
752 }
753 scm scm_hello_world = {FUNCTION0, .name="hello-world", .function0 = &hello_world};
754
755
756 scm *
757 less_p (scm *a, scm *b)
758 {
759   assert (a->type == NUMBER);
760   assert (b->type == NUMBER);
761   return a->value < b->value ? &scm_t : &scm_f;
762 }
763
764 scm *
765 minus (scm *a, scm *b)
766 {
767 #if DEBUG
768   printf ("\nminus a=");
769   display (a);
770   printf (" b=");
771   display (b);
772   puts ("");
773 #endif
774   assert (a->type == NUMBER);
775   assert (b->type == NUMBER);
776   //return make_number (a->value - b->value);
777   scm *r = make_number (a->value - b->value);
778 #if DEBUG
779   printf ("  ==> ");
780   display (r);
781   puts ("");
782 #endif
783   return r;
784 }
785
786 scm scm_less_p = {FUNCTION2, .name="<", .function2 = &less_p};
787 scm scm_minus = {FUNCTION2, .name="-", .function2 = &minus};
788
789 #if QUASIQUOTE
790 scm *
791 eval_quasiquote (scm *e, scm *a)
792 {
793 #if DEBUG
794   printf ("\nc:eval_quasiquote e=");
795   display (e);
796   if (pair_p (e) == &scm_t) {
797     printf ("\ncar (e)=");
798     display (car (e));
799     printf (" atom=");
800     display (atom_p (car (e)));
801   }
802   puts ("");
803 #endif
804   if (e == &scm_nil) return e;
805   else if (atom_p (e) == &scm_t) return e;
806   else if (atom_p (car (e)) == &scm_t)
807     return cons (car (e), eval_quasiquote (cdr (e), a));
808   else if (eq_p (caar (e), &scm_symbol_unquote) == &scm_t)
809     return cons (eval (cadar (e), a), &scm_nil);
810   else if (eq_p (caar (e), &scm_symbol_quote) == &scm_t)
811     return cons (cadar (e), &scm_nil);
812   else if (eq_p (caar (e), &scm_symbol_quasiquote) == &scm_t)
813     return cdar (e);
814   return cons (car (e), eval_quasiquote (cdr (e), a));
815 }
816 scm scm_eval_quasiquote = {FUNCTION2, .name="c:eval-quasiquote", .function2 = &eval_quasiquote};
817 #endif
818
819 scm *
820 add_environment (scm *a, char *name, scm* x)
821 {
822   return cons (cons (make_atom (name), x), a);
823 }
824
825 scm *
826 initial_environment ()
827 {
828   scm *a = &scm_nil;
829
830   a = add_environment (a, "()", &scm_nil);
831   a = add_environment (a, "#t", &scm_t);
832   a = add_environment (a, "#f", &scm_f);
833   a = add_environment (a, "*unspecified*", &scm_unspecified);
834
835   a = add_environment (a, "label", &scm_label);
836   a = add_environment (a, "lambda", &scm_lambda);
837
838   a = add_environment (a, "atom", &scm_atom);
839   a = add_environment (a, "car", &scm_car);
840   a = add_environment (a, "cdr", &scm_cdr);
841   a = add_environment (a, "cons", &scm_cons);
842   a = add_environment (a, "cond", &scm_cond);
843   a = add_environment (a, "eq", &scm_eq_p);
844
845   a = add_environment (a, "null", &scm_null_p);
846   a = add_environment (a, "pair", &scm_pair_p);
847   a = add_environment (a, "quote", &scm_quote);
848   a = add_environment (a, "'", &scm_quote);
849
850 #if QUASIQUOTE
851   a = add_environment (a, "quasiquote", &scm_quasiquote);
852   a = add_environment (a, "unquote", &scm_unquote);
853   a = add_environment (a, ",", &scm_unquote);
854   a = add_environment (a, "`", &scm_quasiquote);
855   a = add_environment (a, "eval-quasiquote", &scm_eval_quasiquote);
856 #endif
857
858   a = add_environment (a, "evlis", &scm_evlis);
859   a = add_environment (a, "evcon", &scm_evcon);
860   a = add_environment (a, "pairlis", &scm_pairlis);
861   a = add_environment (a, "assoc", &scm_assoc);
862
863   a = add_environment (a, "c:eval", &scm_eval_);
864   a = add_environment (a, "c:apply", &scm_apply_);
865   a = add_environment (a, "eval", &scm_eval);
866   a = add_environment (a, "apply", &scm_apply);
867
868   a = add_environment (a, "getchar", &scm_getchar);
869   a = add_environment (a, "peekchar", &scm_peekchar);
870   a = add_environment (a, "ungetchar", &scm_ungetchar);
871   a = add_environment (a, "lookup", &scm_lookup);
872
873   a = add_environment (a, "readenv", &scm_readenv);
874   a = add_environment (a, "display", &scm_display);
875   a = add_environment (a, "newline", &scm_newline);
876
877   a = add_environment (a, "builtin", &scm_builtin_p);
878   a = add_environment (a, "number", &scm_number_p);
879   a = add_environment (a, "call", &scm_call);
880
881
882   a = add_environment (a, "hello-world", &scm_hello_world);
883   a = add_environment (a, "<", &scm_less_p);
884   a = add_environment (a, "-", &scm_minus);
885
886   // DERIVED
887   a = add_environment (a, "caar", &scm_caar);
888   a = add_environment (a, "cadr", &scm_cadr);
889   a = add_environment (a, "cdar", &scm_cdar);
890   a = add_environment (a, "cddr", &scm_cddr);
891   a = add_environment (a, "caadr", &scm_caadr);
892   a = add_environment (a, "caddr", &scm_caddr);
893   a = add_environment (a, "cdadr", &scm_cdadr);
894   a = add_environment (a, "cadar", &scm_cadar);
895   a = add_environment (a, "cddar", &scm_cddar);
896   a = add_environment (a, "cdddr", &scm_cdddr);
897
898   a = add_environment (a, "append", &scm_append);
899
900   //
901   a = add_environment (a, "*macro*", &scm_nil);
902   a = add_environment (a, "*dot*", &scm_dot);
903   a = add_environment (a, "current-module", &scm_symbol_current_module);
904   
905   return a;
906 }
907
908 scm *
909 define_lambda (scm *x)
910 {
911   return cons (caadr (x), cons (&scm_lambda, cons (cdadr (x), cddr (x))));
912 }
913
914 scm *
915 define (scm *x, scm *a)
916 {
917   if (atom_p (cadr (x)) != &scm_f)
918     return cons (cadr (x), eval (caddr (x), a));
919   return define_lambda (x);
920 }
921
922 scm *
923 define_macro (scm *x, scm *a)
924 {
925 #if DEBUG
926   printf ("\nc:define_macro a=");
927   scm *aa =cons (&scm_macro,
928                cons (define_lambda (x),
929                      cdr (assoc (&scm_macro, a))));
930   display (aa);
931   puts ("");
932 #endif
933   return cons (&scm_macro,
934                cons (define_lambda (x),
935                      cdr (assoc (&scm_macro, a))));
936 }
937
938 scm *
939 loop (scm *r, scm *e, scm *a)
940 {
941 #if 0//DEBUG
942   printf ("\nc:loop e=");
943   display (e);
944   puts ("");
945 #endif
946   if (e == &scm_nil)
947     return r;
948   else if (eq_p (e, make_atom ("EOF")) == &scm_t)
949     return apply (cdr (assoc (make_atom ("loop2"), a)),
950                   cons (&scm_unspecified, cons (&scm_t, cons (a, &scm_nil))), a);
951   else if (eq_p (e, make_atom ("EOF2")) == &scm_t)
952     return r;
953   else if (atom_p (e) == &scm_t)
954     return loop (eval (e, a), readenv (a), a);
955   else if (eq_p (car (e), make_atom ("define")) == &scm_t)
956     return loop (&scm_unspecified,
957                  readenv (a),
958                  cons (define (e, a), a));
959   else if (eq_p (car (e), make_atom ("define-macro")) == &scm_t)
960     return loop (&scm_unspecified,
961                  readenv (a),
962                  cons (define_macro (e, a), a));
963   return loop (eval (e, a), readenv (a), a);
964 }
965
966 int
967 main (int argc, char *argv[])
968 {
969   scm *a = initial_environment ();
970   display (loop (&scm_unspecified, readenv (a), a));
971   newline ();
972   return 0;
973 }
974
975 scm *
976 apply (scm* fn, scm *x, scm *a)
977 {
978 #if DEBUG
979   printf ("\nc:apply fn=");
980   display (fn);
981   printf (" x=");
982   display (x);
983   puts ("");
984 #endif
985   if (fn == &scm_apply_)
986     return eval_ (x, a);
987   return apply_ (fn, x, a);
988 }
989
990 bool evalling_p = false;
991
992 scm *
993 eval (scm *e, scm *a)
994 {
995 #if DEBUG
996   printf ("\nc:eval e=");
997   display (e);
998   puts ("");
999 #endif
1000
1001   scm *eval__ = assoc (make_atom ("eval"), a);
1002   assert (eval__ != &scm_f);
1003   eval__ = cdr (eval__);
1004   if (builtin_p (eval__) == &scm_t
1005       || evalling_p)
1006     return eval_ (e, a);
1007   evalling_p = true;
1008   scm *r = apply (eval__, cons (e, cons (a, &scm_nil)), a);
1009   evalling_p = false;
1010   return r;
1011 }