prt-hw.vlisp
0 ;Mercredi 8 Mai 2002 17:37:51 file : prt-hw.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) (mapc l (lambda (f) (terpri) (pprint f))))
8
9 (de pprint (f ;; x)
10 (status print 3)
11 ; bit 0 : '"' , bit 1 : pas d'espace.;
12 (setq lmargin 0)
13 (setq x (cdr (assoc (ftyp f) '((7 . de) (8 . df) (9 . macro)))))
14 (and x (interprete [x f . (fval f)]))
15 (terpri)
16 (status print 0)
17 f)
18
19 (de interprete (l ;; x xx)
20 (initializeInterprete)
21 (cond
22 ((null l) (casNil))
23 ((atom l) (casAtom l))
24 ((and (eq (car l) quote) (null (cddr l))) (casQuote))
25 ((and (listp (car l)) (eq (caar l) lambda)) (casLambda))
26 (t
27 (initGeneralCase)
28 (let ((f (and (litatom (car l)) (get (car l) 'prettyFtn)))) (if f (apply f nil) (defaultCase)))
29 (exitGeneralCase))))
30
31 (defmacro initializeInterprete () '(status print 3) ; pour les appels externes ;)
32
33 (defmacro casNil () '(princh "()"))
34
35 (defmacro casAtom (l) `(prin1 ,l))
36
37 (defmacro casQuote () '(progn (princh "'") (interprete (cadr l))))
38
39 (defmacro casLambda ()
40 '(progn
41 (setq
42 l
43 ['let
44 (let ((v (cadar l)) (a (cdr l))) (if (null v) nil [[(nextl v) (nextl a)] . (self v a)]))
45 . (cddar l)])
46 (interprete l)))
47
48 (defmacro initGeneralCase () '(progn (setq xx (outpos)) (princh "(")))
49
50 (defmacro exitGeneralCase () '(progn (and l (princh " . ") (princh l)) (princh ")")))
51
52 (defmacro defaultCase () '(progn (t+3) (interprete (nextl l)) (while (listp l) (p-p1)) (t-3)))
53
54 (defmacro p-p1 () '(progn (princh " ") (interprete (nextl l))))
55
56 (defmacro t+3 () '(setq lmargin (+ lmargin 3)))
57
58 (defmacro t-3 () '(setq lmargin (- lmargin 3)))
59
60 (defmacro p-progn (?)
61
62 `(if (and (null (cdr l)) (null ,?))
63 (p-p1)
64 ; un seul argument;
65 (t+3)
66 ; plusieurs;
67 (while (listp l) (if (> lmargin (outpos)) (outpos lmargin) (terpri)) (interprete (nextl l)))
68 (t-3)))
69
70 (defmacro p-cond ()
71 '(progn
72 (t+3)
73 (while (listp l)
74 (terpri)
75 (princh "(")
76 (let (l (nextl l)) (interprete (nextl l)) (if l (p-progn)))
77 (princh ")"))
78 (t-3)))
79
80 (mapc '(progn ; type progn; prog1 and exit or)
81 (lambda (x) (put x 'prettyFtn '(lambda () (interprete (nextl l)) (p-progn)))))
82
83 (mapc '(lambda ; type while; escape if ifn let mapc mapcar while until)
84 (lambda (x) (put x 'prettyFtn '(lambda () (interprete (nextl l)) (p-p1) (p-progn t)))))
85
86 (mapc '(de ; type def; df dm dmc)
87 (lambda (x) (put x 'prettyFtn '(lambda () (interprete (nextl l)) (p-p1) (p-p1) (p-progn t)))))
88
89 (mapc '(cond ; type cond;) (lambda (x) (put x 'prettyFtn '(lambda () (interprete (nextl l)) (p-cond)))))
90
91 (mapc '(selectq ; type selectq;)
92 (lambda (x) (put x 'prettyFtn '(lambda () (interprete (nextl l)) (p-p1) (p-cond)))))
93
94 (setq careful --x--)
95
96
Cross Reference
casAtom defmacro 35
casLambda defmacro 39
casNil defmacro 33
casQuote defmacro 37
defaultCase defmacro 52
exitGeneralCase defmacro 50
initGeneralCase defmacro 48
initializeInterprete defmacro 31
interprete de 19
p-cond defmacro 70
p-p1 defmacro 54
p-progn defmacro 60
pprint de 9
pretty df 7
t+3 defmacro 56
t-3 defmacro 58
1 --x-- 5 94
2 ? 60 62
3 a 44 44 44
4 casAtom 23 35
5 casLambda 25 39
6 casNil 22 33
7 casQuote 24 37
8 defaultCase 28 52
9 defmacro 31 33 35 37 39 48 50 52 54 56 58 60 70
10 exitGeneralCase 29 50
11 f 7 7 9 13 14 14 17 28 28 28
12 initGeneralCase 27 48
13 initializeInterprete 20 31
14 interprete 14 19 37 46 52 54 67 76 81 84 87 89
92
15 l 7 7 19 22 23 23 24 24 25 25 28 28 35 35 37
42 44 44 45 46 50 50 52 52 54 62 67 67 73 76
76 76 76 81 84 87 89 92
16 macro 13
17 p-cond 70 89 92
18 p-p1 52 54 63 84 87 87 92
19 p-progn 60 76 81 84 87
20 pprint 7 9
21 pretty 7
22 prettyFtn 28 81 84 87 89 92
23 t+3 52 56 65 72
24 t-3 52 58 68 78
25 v 44 44 44 44
26 x 9 13 14 14 19 81 81 84 84 87 87 89 89 92 92
27 xx 19 48
;Mercredi 8 Mai 2002 17:37:51 end of file : prt-hw.vlisp ;