1 ;;; Abstract Syntax Tree-ish tools for m68k-assembler.
3 ;;; Julian Squires / 2005
6 (in-package :m68k-assembler
)
8 ;;;; PARSE TREE MANIPULATORS
10 ;;; XXX Not the most efficient way to get a list of operands, but I am
12 (defun extract-operands (parse-tree)
13 (labels ((inner-fn (parse-tree)
15 (dolist (x parse-tree
)
17 (when (eql (car x
) 'operand
)
19 (when (eql (car x
) 'operands
)
20 (setf list
(append (inner-fn x
) list
)))))
22 (reverse (inner-fn parse-tree
))))
25 (defun simplify-operand (tree)
27 (immediate (simplify-immediate tree
))
28 (register-list (simplify-register-list tree
))
29 (absolute (simplify-absolute tree
))
30 (indirect (simplify-indirect tree
))
33 ;;;; Addressing mode simplifiers.
35 (defun simplify-immediate (tree)
36 (assert (and (eql (car tree
) 'immediate
)
37 (eql (caadr tree
) 'hash
)))
38 (list 'immediate
(simplify-expression (third tree
))))
40 (defun simplify-absolute (tree)
41 (assert (eql (car tree
) 'absolute
))
42 (list 'absolute
(simplify-expression (second tree
))))
44 (defun simplify-indirect (tree)
45 (assert (eql (car tree
) 'indirect
))
47 (displacement-indirect
48 (cond ((= (length (cadr tree
)) 5)
49 (list (caadr tree
) (simplify-expression (second (cadr tree
)))
50 (fourth (cadr tree
))))
51 ((= (length (cadr tree
)) 4)
52 (list (caadr tree
) (third (cadr tree
))))
53 (t (error "Weird parse tree: ~A." tree
))))
55 (cond ((= (length (cadr tree
)) 7)
56 (list (caadr tree
) (simplify-expression (second (cadr tree
)))
57 (fourth (cadr tree
)) (sixth (cadr tree
))))
58 ((= (length (cadr tree
)) 6)
59 (list (caadr tree
) (third (cadr tree
)) (fifth (cadr tree
))))
60 (t (error "Weird parse tree: ~A." tree
))))
61 (postincrement-indirect
62 (list (caadr tree
) (third (cadr tree
))))
63 (predecrement-indirect
64 (list (caadr tree
) (fourth (cadr tree
))))
65 (t (error "Weird indirect: ~A." tree
))))
67 (defun interpolate-registers (start end
)
68 (let ((s (register-idx start
:both-sets t
))
69 (e (register-idx end
:both-sets t
)))
70 (when (> s e
) (psetf s e e s
))
71 (loop for i from s to e
73 ,(cons (car (aref *asm-register-table
* i
)) nil
)))))
75 ;;; XXX could use some work.
76 (defun simplify-register-list (tree)
77 (labels ((simplify (tree)
78 (assert (eql (car tree
) 'register-list
))
79 (cond ((= (length tree
) 2) (list 'register-list
82 (cond ((eql (car (third tree
)) '/)
85 (cdr (simplify (second tree
)))
86 (cdr (simplify (fourth tree
))))))
87 ((eql (car (third tree
)) '-
)
89 (interpolate-registers (second tree
)
91 (t (error "Strange register list."))))
92 (t (error "Strange parse tree.")))))
93 ;; If this is a register list of a single register, return just
95 (let ((v (simplify tree
)))
96 (if (= (length v
) 2) (second v
) v
))))
98 ;;;; Expression simplifiers.
100 ;;; Because we know expressions only contain certain kinds of
101 ;;; elements, we can easily reduce them down to "almost" lisp
103 (defun simplify-operator (tree)
104 (assert (member (first tree
) '(adding-operator multiplying-operator
105 bitwise-operator unary-operator
)))
108 (defun simplify-value (tree)
111 (defun simplify-factor (tree)
112 (cond ((= (length tree
) 2)
113 (let ((v (simplify-value (second tree
))))
114 (if (eql (car v
) 'constant
) (second v
) v
)))
115 ((= (length tree
) 3) (list (simplify-operator (second tree
))
116 (simplify-value (third tree
))))
117 ((= (length tree
) 4) (simplify-expression (third tree
)))
118 (t (error "Strange parse tree."))))
120 (defun simplify-term (tree)
121 (cond ((= (length tree
) 2) (simplify-factor (second tree
)))
123 (list (simplify-operator (third tree
))
124 (simplify-term (second tree
))
125 (simplify-factor (fourth tree
))))
126 (t (error "Strange parse tree."))))
128 (defun simplify-term2 (tree)
129 (cond ((= (length tree
) 2) (simplify-term (second tree
)))
131 (list (simplify-operator (third tree
))
132 (simplify-term2 (second tree
))
133 (simplify-term (fourth tree
))))
134 (t (error "Strange parse tree."))))
136 (defun simplify-expression (tree)
137 (cond ((= (length tree
) 2) (simplify-term2 (second tree
)))
139 (list (simplify-operator (third tree
))
140 (simplify-expression (second tree
))
141 (simplify-term2 (fourth tree
))))
142 (t (error "Strange parse tree."))))
144 ;;;; UNCLUTTER/STRIP-POSITION
146 (defun unclutter-line (tree)
147 "Takes a parse tree, strips the individual token position
148 information, and returns two values -- the uncluttered parse tree, and
149 a single representative item of position information."
150 (let ((position nil
))
151 (labels ((strip (branch)
152 (cond ((atom branch
))
153 ((terminal-p (car branch
))
154 (assert (is-position-info-p (third branch
)))
155 ;; XXX would be nice to improve this "merge" to be
156 ;; a bit more heuristic (watch for merging pos from
157 ;; separate files, for example... !)
158 (when (null position
) (setf position
(third branch
)))
159 (setf (cddr branch
) nil
))
161 (dolist (leaf branch
) (strip leaf
))))))
163 (values tree position
))))