mes.c: support `.' and add let.
[mes.git] / mes.mes
1 ;; -*-scheme-*-
2 ;; 
3 (define (caar x) (car (car x)))
4 (define (cadr x) (car (cdr x)))
5 (define (cdar x) (cdr (car x)))
6 (define (cddr x) (cdr (cdr x)))
7 (define (caadr x) (car (car (cdr x))))
8 (define (caddr x) (car (cdr (cdr x))))
9 (define (cddar x) (cdr (cdr (car x))))
10 (define (cdadr x) (cdr (car (cdr x))))
11 (define (cadar x) (car (cdr (car x))))
12 (define (cdddr x) (cdr (cdr (cdr x))))
13
14 ;; Page 12
15 (define (pairlis x y a)
16   (debug "pairlis x=~a y=~a a=~a\n" x y a)
17   (cond
18    ((null x) a)
19    (#t (cons (cons (car x) (car y))
20              (pairlis (cdr x) (cdr y) a)))))
21
22 (define (assoc x a)
23   ;;(stderr "assoc x=~a\n" x)
24   (debug "assoc x=~a a=~a\n" x a)
25   (cond
26    ((null a) #f)
27    ((eq (caar a) x) (car a))
28    (#t (assoc x (cdr a)))))
29
30 ;; Page 13
31 (define (eval-quote fn x)
32   (debug "eval-quote fn=~a x=~a" fn x)
33   (apply fn x '()))
34
35 (define (apply fn x a)
36   (debug "apply fn=~a x=~a a=~a\n" fn x a)
37   (cond
38    ((atom fn)
39     (debug "(atom fn)=~a\n" (atom fn))
40     (cond
41      ;; John McCarthy LISP 1.5
42      ;; ((eq fn CAR) (caar x))
43      ;; ((eq fn CDR) (cdar x))
44      ;; ((eq fn CONS) (cons (car x) (cadr x)))
45      ;; ((eq fn ATOM) (atom (car x)))
46      ;; ((eq fn EQ) (eq (car x) (cadr x)))
47      ((builtin fn) (call fn x))
48      (#t (apply (eval fn a) x a))))
49    ;; John McCarthy LISP 1.5
50    ((eq (car fn) 'LAMBDA) (eval (caddr fn) (pairlis (cadr fn) x a)))
51    ((eq (car fn) 'lambda)
52     ;; (CDDR fn) all eval
53     (cond ((null (cdr (cddr fn)))
54            (eval (caddr fn) (pairlis (cadr fn) x a)))
55           (#t
56            (eval (caddr fn) (pairlis (cadr fn) x a))
57            (apply (cons (car fn) (cons (cadr fn) (cdddr fn)))
58                   x
59                   (pairlis (cadr fn) x a)))))
60    ((eq (car fn) 'label) (apply (caddr fn) x (cons (cons (cadr fn)
61                                                          (caddr fn)) a)))))
62
63 (define (eval e a)
64   (debug "eval e=~a a=~a\n" e a)
65   ;;(debug "eval (atom ~a)=~a\n" e (atom e))
66   (cond
67    ;;((and (stderr "NUMBER? ~a ==> ~a\n" e (number e)) #f))
68    ((number e) e)
69    ;; error: extra
70    ((atom e) (cond ((eq (assoc e a) #f)
71                     (stderr "no such symbol: ~a\n" e)
72                     (guile:exit 1))
73                    (#t (cdr (assoc e a)))))
74    ((atom e) (cdr (assoc e a)))
75    ((builtin e) e)
76    ;;((and (stderr "eeee: ~a\n" e) #f))
77    ((atom (car e))
78     (cond
79      ((eq (car e) 'quote) (cadr e))
80      ((eq (car e) 'cond) (evcon (cdr e) a))
81      ;; EXTRA: macro expandszor
82      ;;((and (stderr "2eeee: ~a\n" (cdr (assoc '*macro* a))) #f))
83      (;;;(pair (assoc (car e) (cdr (assoc '*macro* a))))
84       #f
85       ;;(stderr "macro: ~a\n" (assoc (car e) (cdr (assoc '*macro* a))))
86       (stderr "apply: ~a ~a\n"
87               `(cons 'lambda (cdr (cdr
88                                    ,(assoc (car e) (cdr (assoc '*macro* a)))
89                                    )))
90               `(evlis ,(cddr e) a)
91               ;;'(evlist foobar)
92               )
93       (eval (apply
94              `(cons 'lambda (cdr (cdr
95                                   ,(assoc (car e) (cdr (assoc '*macro* a)))
96                                   )))
97              `(evlis ,(cddr e) a)
98              a)
99             a))
100      (#t (apply (car e) (evlis (cdr e) a) a))))
101    (#t (apply (car e) (evlis (cdr e) a) a))))
102
103 (define (evcon c a)
104   (debug "evcon c=~a a=~a\n" c a)
105   (cond
106    ;; single-statement cond
107    ;; ((eval (caar c) a) (eval (cadar c) a))
108    ((eval (caar c) a)
109     (cond ((null (cddar c)) (eval (cadar c) a))
110           (#t (eval (cadar c) a)
111               (evcon
112                (cons (cons #t (cddar c)) '())
113                a))))
114    (#t (evcon (cdr c) a))))
115
116 (define (evlis m a)
117   (debug "evlis m=~a a=~a\n" m a)
118   (cond
119    ((null m) '())
120    (#t (cons (eval (car m) a) (evlis (cdr m) a)))))