evalsym.vlisp
0 ;Mercredi 8 Mai 2002 17:38:48 file : evalsym.vlisp ;
1
2 ; ----- evaluateur partiel [hw];
3 ; adapte du pretty-print de [pg];
4 ; 24.3.02 (hw);
5
6 (setq --x-- careful careful nil)
7
8 (de symeval (exp)
9 (setq activity 'symb)
10 (let ((x exp) (y (interprete exp))) (if (equal x y) x (self y (interprete y)))))
11
12 (de interprete (l ;; al xx)
13 (initializeInterprete)
14 (cond
15 ((null l) (casNil))
16 ((atom l) (casAtom))
17 ((and (eq (car l) quote) (null (cddr l))) (casQuote))
18 ((and (listp (car l)) (eq (caar l) lambda)) (casLambda))
19 (t
20 (initGeneralCase)
21 (let
22 (
23 (x
24 (let ((f (and (litatom (car l)) (get (car l) activity))))
25 (if f (apply f nil) (defaultCase))))) (exitGeneralCase x)))))
26
27 (de casNil nil nil)
28
29 (defmacro casAtom () `(let (val (assoc l al)) (if val (cadr val) l)))
30
31 (defmacro casQuote () '(cadr l))
32
33 (defmacro casLambda ()
34 '(progn
35 (setq
36 l
37 ['let
38 (let ((v (cadar l)) (a (cdr l))) (if (null v) nil [[(nextl v) (nextl a)] . (self v a)]))
39 . (cddar l)])
40 (interprete l)))
41
42 (de initGeneralCase nil nil)
43
44 (de initializeInterprete nil nil)
45
46 (de exitGeneralCase (x) x)
47
48 (defmacro defaultCase ()
49 '(cond
50 ((or (null (get (car l) 'body)) (listp (car l)))
51 [(interprete (nextl l) al) . (mapcar l '(lambda (x) (interprete x al)))])
52 (t
53 (let (largs (mapcar (cdr l) '(lambda (x) (interprete x al))))
54 (let (al1 (redpair (car l) (get (car l) 'vars) largs))
55 (if (eq al1 'no) [(car l) . largs] (interprete (get (car l) 'body) (nconc al1 al))))))))
56
57 (put 'cdr
58 'symb
59 '(lambda ()
60 (let ((x (interprete (cadr l) al)))
61 (cond ((null x) nil) ((equal (car x) 'cons) (caddr x)) (t ['cdr x])))))
62
63 (put '1+
64 'symb
65 '(lambda ()
66 (let ((x (interprete (cadr l) al)))
67 (cond ((numbp x) (1+ x)) ((atom x) ['1+ x]) ((eq (car x) '1-) (cadr x))
68 (t ['1+ x])))))
69
70 (put '1-
71 'symb
72 '(lambda ()
73 (let ((x (interprete (cadr l) al)))
74 (cond ((numbp x) (1- x)) ((atom x) ['1- x]) ((eq (car x) '1+) (cadr x))
75 (t ['1+ x])))))
76
77 (put 'zerop
78 'symb
79 '(lambda ()
80 (let ((x (interprete (cadr l) al)))
81 (cond ((numbp x) (if (zerop x) t nil)) ((atom x) [zerop x]) ((eq (car x) '1+) nil)
82 (t ['zerop x])))))
83
84 (put 'car
85 'symb
86 '(lambda ()
87 (let ((x (interprete (cadr l) al)))
88 (cond ((null x) nil) ((equal (car x) 'cons) (cadr x)) (t ['car x])))))
89
90 (put 'null
91 'symb
92 '(lambda ()
93 (let ((x (interprete (cadr l) al)))
94 (cond ((null x) t) ((and (listp x) (eq (car x) 'cons)) nil) (t ['null x])))))
95
96 (put 'if
97 'symb
98 '(lambda ()
99 (let ((x (interprete (cadr l) al)))
100 (cond ((or (eq x t) (and (listp x) (eq (car x) 'cons))) (interprete (caddr l) al)) ((null x) (interprete (cadr (cddr l)) al))
101 (t ['null . [x . (cddr l)]])))))
102
103 (put 'de 'symb '(lambda () (eval l) (analyse (cadr l)) (cadr l)))
104
105 (de analyse (f ;; x vars body decvars)
106 (setq x (fval f) vars (car x) body (cadr x))
107 (let (e body)
108 (cond
109 ((atom e))
110 ((member (car e) '(car cdr 1-))
111 (if (atom (cadr e))
112 (and (member (cadr e) vars) (or (member (cadr e) decvars) (newl decvars (cadr e))))
113 (self (cadr e))))
114 (t (self (nextl e)) (self e))))
115 (put f 'vars vars)
116 (put f 'body body)
117 (put f 'decvars decvars))
118
119 ; ---------- controleur de deploiement -----------;
120
121 (de redpair (fun vars largs ;; decvars res v l)
122 (setq decvars (get fun 'decvars))
123 (while vars
124 (setq v (nextl vars) l (nextl largs))
125 (if (member v decvars) (and l (neq l 0) (neq (car l) 'cons) (neq (car l) '1+) (exit 'no)))
126 (newl res [v l]))
127 res)
128
129 (de app (x y) (if (null x) y [(car x) . (app (cdr x) y)]))
130
131 (analyse 'app)
132
133 (de rev (x) (if (null x) nil (app (rev (cdr x)) [(car x) . nil])))
134
135 (analyse 'rev)
136
137 (de len (l) (if (null l) 0 (1+ (len (cdr l)))))
138
139 (analyse 'len)
140
141 (de p (x y) (if (zerop x) y (1+ (p (1- x) y))))
142
143 (analyse 'p)
144
145 (de m (x y) (if (zerop x) 0 (p y (1- x) y)))
146
147 (analyse 'm)
148
149 (de loop ()
150 (print "eval sym :")
151 (let (x (read)) (if (null x) 'ok (print (symeval x)) (print "eval sym :") (self (read)))))
152
153 (setq careful --x--)
154
155
Cross Reference
analyse de 105
app de 129
casAtom defmacro 29
casLambda defmacro 33
casQuote defmacro 31
defaultCase defmacro 48
exitGeneralCase de 46
interprete de 12
len de 137
loop de 149
m de 145
p de 141
redpair de 121
rev de 133
symeval de 8
1 --x-- 6 153
2 a 38 38 38
3 activity 9 24
4 al 12 29 51 51 53 55 60 66 73 80 87 93 99 100
5 al1 54 55 55
6 analyse 103 105 131 135 139 143 147
7 app 129 129 131 133
8 body 50 55 105 106 107 116 116
9 casAtom 16 29
10 casLambda 18 33
11 casNil 15 27
12 casQuote 17 31
13 decvars 105 112 112 117 117 121 122 122 125
14 defaultCase 25 48
15 defmacro 29 31 33 48
16 e 107 109 110 111 112 112 112 113 114 114
17 exitGeneralCase 25 46
18 f 24 25 25 105 106 115 116 117
19 fun 121 122
20 initGeneralCase 20 42
21 initializeInterprete 13 44
22 interprete 10 10 12 40 51 51 53 55 60 66 73 80
87 93 99 100
23 l 12 15 16 17 17 18 18 24 24 29 29 31 36 38 38
39 40 50 50 51 51 53 54 54 55 55 60 66 73 80
87 93 99 100 101 103 103 103 121 124 125 125 125 125
126 137 137 137
24 largs 53 54 55 121 124
25 len 137 137 139
26 loop 149
27 m 145 147
28 no 55 125
29 ok 151
30 p 141 141 143 145
31 redpair 54 121
32 res 121 126 127
33 rev 133 133 135
34 symb 9 58 64 71 78 85 91 97 103
35 symeval 8 151
36 v 38 38 38 38 121 124 125 126
37 val 29 29 29
38 vars 54 105 106 112 115 115 121 123 124
39 x 10 10 10 23 25 46 46 51 51 53 53 60 61 61 61
61 66 67 67 67 67 68 73 74 74 74 74 75 80 81
81 81 81 81 82 87 88 88 88 88 93 94 94 94 94
99 100 100 100 101 105 106 106 106 129 129 129 129 133
133 133 133 141 141 141 145 145 145 151 151 151
40 xx 12
41 y 10 10 10 10 129 129 129 141 141 141 145 145 145
;Mercredi 8 Mai 2002 17:38:48 end of file : evalsym.vlisp ;