symeval.vlisp
0 ;Mercredi 8 Mai 2002 17:39:46 file : symeval.vlisp ;
1
2 ; ------ pretty-print, par [pg];
3 ; transformation en evaluateur 24.3.02 (hw);
4
5 (setq --x-- careful careful nil)
6
7 (df pretty (l) (goPretty) (setq activity 'prettyFtn) (mapc l (lambda (f) (terpri) (pprint f))))
8
9 (de symeval (exp)
10 (goSymEval)
11 (setq activity 'symb)
12 (let ((x exp) (y (interprete exp))) (if (equal x y) x (self y (interprete y)))))
13
14 (de pprint (f ;; x)
15 (status print 3)
16 ; bit 0 : '"' , bit 1 : pas d'espace.;
17 (setq lmargin 0)
18 (setq x (cdr (assoc (ftyp f) '((7 . de) (8 . df) (9 . macro)))))
19 (and x (interprete [x f . (fval f)]))
20 (terpri)
21 (status print 0)
22 f)
23
24 (de interprete (l ;; al xx)
25 (initializeInterprete)
26 (cond
27 ((null l) (casNil))
28 ((atom l) (casAtom))
29 ((and (eq (car l) quote) (null (cddr l))) (casQuote))
30 ((and (listp (car l)) (eq (caar l) lambda)) (casLambda))
31 (t
32 (initGeneralCase)
33 (let
34 (
35 (x
36 (let ((f (and (litatom (car l)) (get (car l) activity))))
37 (if f (apply f nil) (defaultCase))))) (exitGeneralCase x)))))
38
39 (de goSymEval ()
40 ; pour initialiser l'ensemble des fonctionalites;
41 ; pour l'interprete symbolique;
42 (de casNil nil nil)
43 (de casAtom () (let (val (assoc l al)) (if val (cadr val) l)))
44 (de casQuote nil l)
45 (de casLambda ()
46 (setq
47 l
48 ['let
49 (let ((v (cadar l)) (a (cdr l))) (if (null v) nil [[(nextl v) (nextl a)] . (self v a)]))
50 . (cddar l)])
51 (interprete l))
52 (de initGeneralCase nil nil)
53 (de initializeInterprete nil nil)
54 (de exitGeneralCase (x) x)
55 (de defaultCase ()
56 (cond
57 ((or (null (get (car l) 'body)) (listp (car l)))
58 [(interprete (nextl l) al) . (mapcar l '(lambda (x) (interprete x al)))])
59 (t
60 (let (largs (mapcar (cdr l) '(lambda (x) (interprete x al))))
61 (let (al1 (redpair (car l) (get (car l) 'vars) largs))
62 (if (eq al1 'no) [(car l) . largs] (interprete (get (car l) 'body) (nconc al1 al))))))))
63 (put 'cdr
64 'symb
65 '(lambda ()
66 (let ((x (interprete (cadr l) al)))
67 (cond ((null x) nil) ((equal (car x) 'cons) (caddr x)) (t ['cdr x])))))
68 (put 'car
69 'symb
70 '(lambda ()
71 (let ((x (interprete (cadr l) al)))
72 (cond ((null x) nil) ((equal (car x) 'cons) (cadr x)) (t ['car x])))))
73 (put 'null
74 'symb
75 '(lambda ()
76 (let ((x (interprete (cadr l) al)))
77 (cond ((null x) t) ((and (listp x) (eq (car x) 'cons)) nil) (t ['null x])))))
78 (put 'if
79 'symb
80 '(lambda ()
81 (let ((x (interprete (cadr l) al)))
82 (cond ((or (eq x t) (and (listp x) (eq (car x) 'cons))) (interprete (caddr l) al)) ((null x) (interprete (cadr (cddr l)) al))
83 (t ['null . [x . (cddr l)]])))))
84 (put 'de 'symb '(lambda () (eval l) (analyse (cadr l)) (cadr l))))
85
86 (de analyse (f ;; x vars body decvars)
87 (setq x (fval f) vars (car x) body (cadr x))
88 (let (e body)
89 (cond
90 ((atom e))
91 ((member (car e) '(car cdr 1-))
92 (if (atom (cadr e))
93 (and (member (cadr e) vars) (or (member (cadr e) decvars) (newl decvars (cadr e))))
94 (self (cadr e))))
95 (t (self (nextl e)) (self e))))
96 (put f 'vars vars)
97 (put f 'body body)
98 (put f 'decvars decvars))
99
100 ; ---------- controleur de deploiement -----------;
101
102 (de redpair (fun vars largs ;; decvars res v l)
103 (setq decvars (get fun 'decvars))
104 (while vars
105 (setq v (nextl vars) l (nextl largs))
106 (if (member v decvars) (and l (neq l 0) (neq (car l) 'cons) (neq (car l) '1+) (exit 'no)))
107 (newl res [v l]))
108 res)
109
110 (de app (x y) (if (null x) y [(car x) . (app (cdr x) y)]))
111
112 (analyse 'app)
113
114 (de rev (x) (if (null x) nil (app (rev (cdr x)) [(car x) . nil])))
115
116 (analyse 'rev)
117
118 (de goPretty ()
119 ; pour initialiser l'ensemble des fonctionalites;
120 ; pour le pretty-print;
121 (de initializeInterprete () (status print 3) ; pour les appels externes ;)
122 (de casNil () (princh "()"))
123 (de casAtom () (prin1 l))
124 (de casQuote () (princh "'") (interprete (cadr l)))
125 (de casLambda ()
126 (setq
127 l
128 ['let
129 (let ((v (cadar l)) (a (cdr l))) (if (null v) nil [[(nextl v) (nextl a)] . (self v a)]))
130 . (cddar l)])
131 (interprete l))
132 (de initGeneralCase () (setq xx (outpos)) (princh "("))
133 (de exitGeneralCase (x) (and l (princh " . ") (princh l)) (princh ")"))
134 (de defaultCase () (t+3) (interprete (nextl l)) (while (listp l) (p-p1)) (t-3))
135 (defmacro p-p1 () '(progn (princh " ") (interprete (nextl l))))
136 (defmacro t+3 () '(setq lmargin (+ lmargin 3)))
137 (defmacro t-3 () '(setq lmargin (- lmargin 3)))
138 (defmacro p-progn (?)
139
140 `(if (and (null (cdr l)) (null ,?))
141 (p-p1)
142 ; un seul argument;
143 (t+3)
144 ; plusieurs;
145 (while (listp l) (if (> lmargin (outpos)) (outpos lmargin) (terpri)) (interprete (nextl l)))
146 (t-3)))
147 (defmacro p-cond ()
148 '(progn
149 (t+3)
150 (while (listp l)
151 (terpri)
152 (princh "(")
153 (let (l (nextl l)) (interprete (nextl l)) (if l (p-progn)))
154 (princh ")"))
155 (t-3)))
156 (mapc '(progn ; type progn; prog1 and exit or)
157 (lambda (x) (put x 'prettyFtn '(lambda () (interprete (nextl l)) (p-progn)))))
158 (mapc '(lambda ; type while; escape if ifn let mapc mapcar while until)
159 (lambda (x) (put x 'prettyFtn '(lambda () (interprete (nextl l)) (p-p1) (p-progn t)))))
160 (mapc '(de ; type def; df dm dmc)
161 (lambda (x) (put x 'prettyFtn '(lambda () (interprete (nextl l)) (p-p1) (p-p1) (p-progn t)))))
162 (mapc '(cond ; type cond;)
163 (lambda (x) (put x 'prettyFtn '(lambda () (interprete (nextl l)) (p-cond)))))
164 (mapc '(selectq ; type selectq;)
165 (lambda (x) (put x 'prettyFtn '(lambda () (interprete (nextl l)) (p-p1) (p-cond))))))
166
167 (setq careful --x--)
168
169
Cross Reference
analyse de 86
app de 110
casAtom de 123
casAtom de 123
casLambda de 125
casLambda de 125
casNil de 122
casQuote de 124
defaultCase de 134
defaultCase de 134
exitGeneralCase de 133
exitGeneralCase de 133
goPretty de 118
goSymEval de 39
initGeneralCase de 132
initializeInterprete de 121
interprete de 24
p-cond defmacro 147
p-p1 defmacro 135
p-progn defmacro 138
pprint de 14
pretty df 7
redpair de 102
rev de 114
symeval de 9
t+3 defmacro 136
t-3 defmacro 137
1 --x-- 5 167
2 ? 138 140
3 a 49 49 49 129 129 129
4 activity 7 11 36
5 al 24 43 58 58 60 62 66 71 76 81 82
6 al1 61 62 62
7 analyse 84 86 112 116
8 app 110 110 112 114
9 body 57 62 86 87 88 97 97
10 casAtom 28 43 123
11 casLambda 30 45 125
12 casNil 27 42 122
13 casQuote 29 44 124
14 decvars 86 93 93 98 98 102 103 103 106
15 defaultCase 37 55 134
16 defmacro 135 136 137 138 147
17 e 88 90 91 92 93 93 93 94 95 95
18 exitGeneralCase 37 54 133
19 f 7 7 14 18 19 19 22 36 37 37 86 87 96 97 98
20 fun 102 103
21 goPretty 7 118
22 goSymEval 10 39
23 initGeneralCase 32 52 132
24 initializeInterprete 25 53 121
25 interprete 12 12 19 24 51 58 58 60 62 66 71 76
81 82 124 131 134 135 145 153 157 159 161 163 165
26 l 7 7 24 27 28 29 29 30 30 36 36 43 43 44 47
49 49 50 51 57 57 58 58 60 61 61 62 62 66 71
76 81 82 83 84 84 84 102 105 106 106 106 106 107
123 124 127 129 129 130 131 133 133 134 134 135 140 145
145 150 153 153 153 153 157 159 161 163 165
27 largs 60 61 62 102 105
28 macro 18
29 no 62 106
30 p-cond 147 163 165
31 p-p1 134 135 141 159 161 161 165
32 p-progn 138 153 157 159 161
33 pprint 7 14
34 pretty 7
35 prettyFtn 7 157 159 161 163 165
36 redpair 61 102
37 res 102 107 108
38 rev 114 114 116
39 symb 11 64 69 74 79 84
40 symeval 9
41 t+3 134 136 143 149
42 t-3 134 137 146 155
43 v 49 49 49 49 102 105 106 107 129 129 129 129
44 val 43 43 43
45 vars 61 86 87 93 96 96 102 104 105
46 x 12 12 12 14 18 19 19 35 37 54 54 58 58 60 60
66 67 67 67 67 71 72 72 72 72 76 77 77 77 77
81 82 82 82 83 86 87 87 87 110 110 110 110 114
114 114 114 133 157 157 159 159 161 161 163 163 165 165
47 xx 24 132
48 y 12 12 12 12 110 110 110
;Mercredi 8 Mai 2002 17:39:47 end of file : symeval.vlisp ;