/[movitz]/ia-x86/read.lisp
ViewVC logotype

Contents of /ia-x86/read.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (show annotations)
Wed Nov 10 15:36:15 2004 UTC (9 years, 5 months ago) by ffjeld
Branch: MAIN
CVS Tags: HEAD
Changes since 1.7: +2 -2 lines
*** empty log message ***
1 ;;;;------------------------------------------------------------------
2 ;;;;
3 ;;;; Copyright (C) 2000-2004,
4 ;;;; Department of Computer Science, University of Tromso, Norway
5 ;;;;
6 ;;;; Filename: read.lisp
7 ;;;; Description: Functions for reading assembly expressions.
8 ;;;; Author: Frode Vatvedt Fjeld <frodef@acm.org>
9 ;;;; Created at: Mon Jul 31 13:54:27 2000
10 ;;;; Distribution: See the accompanying file COPYING.
11 ;;;;
12 ;;;; $Id: read.lisp,v 1.8 2004/11/10 15:36:15 ffjeld Exp $
13 ;;;;
14 ;;;;------------------------------------------------------------------
15
16 (in-package #:ia-x86)
17
18 ;;; Implements the following assembly syntax:
19 ;;;
20 ;;; program ::= (<sexpr>*)
21 ;;;
22 ;;; sexpr ::= ( <expr> ) | <label> | (% <inline-data> %) | (:include . <program>)
23 ;;; expr ::= <instro> | ( { <prefix> } ) <instro>
24 ;;; instro ::= <instruction> { <operand> }
25 ;;;
26 ;;; operand ::= <concrete> | <abstract>
27 ;;;
28 ;;; concrete ::= <immediate> | <register> | <indirect>
29 ;;; immediate ::= <number>
30 ;;; register ::= eax | ecx | ...
31 ;;; indirect ::= ( iexpr )
32 ;;; iexpr ::= <address>
33 ;;; | (quote <label>)
34 ;;; | <segment> <address>
35 ;;; | pc+ <offset>
36 ;;; | pc <address>
37 ;;; | { (quote <label>) } <offset> <scaled-register> <register>
38 ;;; scaled-register ::= <register> | ( <register> <scale> )
39 ;;; scale ::= 1 | 2 | 4 | 8
40 ;;; address ::= <number>
41 ;;; offset ::= <signed-number>
42 ;;;
43 ;;; abstract ::= (quote <absexpr>)
44 ;;; absexpr ::= <label> | <number> | append-prg
45 ;;; append-prg ::= program
46 ;;;
47 ;;; prefix ::= <segment-override> | (:size <size>)
48 ;;;
49 ;;;
50 ;;; Instructions are recognized by symbol-name, so there should be no
51 ;;; need to worry about packages etc.
52
53 (defparameter +all-registers+
54 '(:eax :ecx :edx :ebx :esp :ebp :esi :edi
55 :ax :cx :dx :bx :sp :bp :si :di
56 :al :cl :dl :bl :ah :ch :dh :bh
57 :cs :ds :es :fs :gs :ss
58 :dr0 :dr1 :dr2 :dr3 :dr4 :dr5 :dr6 :dr7
59 :cr0 :cr2 :cr3 :cr4
60 :mm0 :mm1 :mm2 :mm3 :mm4 :mm5 :mm6 :mm7
61 :xmm0 :xmm1 :xmm2 :xmm3 :xmm4 :xmm5 :xmm6 :xmm7
62 ))
63
64 (defun read-register-symbol (spec)
65 (assert (member spec +all-registers+)
66 (spec)
67 "Expected a register: ~A" spec)
68 (find-symbol (symbol-name spec) '#:ia-x86))
69
70 (defun is-register-p (spec)
71 (and (symbolp spec)
72 (member spec +all-registers+)))
73
74 (defun is-address-p (spec)
75 (typecase spec
76 ((integer 0 *) t)
77 (t nil)))
78
79 (defun is-offset-p (spec)
80 (typecase spec
81 (integer t)
82 (symbol t)
83 (t nil)))
84
85 (defun is-pc-relative-p (iexpr)
86 (and (<= 2 (length iexpr))
87 (symbolp (first iexpr))
88 (string= :pc+ (first iexpr))
89 (is-offset-p (second iexpr))))
90
91 (defun extract-label-ref (expr)
92 "Return NIL if expr is not a label reference, otherwise
93 returns the symbol/label that is referenced."
94 (and (listp expr)
95 (= 2 (length expr))
96 (symbolp (first expr))
97 (string= 'quote (first expr))
98 (symbolp (second expr))
99 (second expr)))
100
101 (defun read-indirect-operand (iexpr)
102 (cond
103 ((and (= 1 (length iexpr)) ; simple direct memory reference
104 (is-address-p (car iexpr)))
105 (make-instance 'operand-direct
106 'address (car iexpr)))
107 ((and (= 1 (length iexpr)) ; abstract simple direct memory reference
108 (extract-label-ref (first iexpr)))
109 (make-instance 'operand-direct
110 'address (extract-label-ref (first iexpr))))
111 ((and (= 2 (length iexpr)) ; segmented indirect address
112 (integerp (first iexpr))
113 (integerp (second iexpr)))
114 (make-instance 'operand-direct
115 'address (second iexpr)
116 'segment (first iexpr)))
117 ((is-pc-relative-p iexpr) ; PC-relative address
118 (make-instance 'operand-rel-pointer
119 'offset (second iexpr)))
120 (t (let (register register2 (offset 0) symbolic-offsets scale) ; indirect register(s)
121 (loop for s in iexpr
122 do (cond
123 ((integerp s) ; an offset
124 (incf offset s))
125 ((and (listp s) ; an abstract offset
126 (= 2 (length s))
127 (symbolp (first s))
128 (string= 'quote (first s))
129 (symbolp (second s)))
130 (push (second s) symbolic-offsets))
131 ((and (is-register-p s) ; register number one
132 (null register))
133 (setf register (read-register-symbol s)))
134 ((and (is-register-p s) ; a register number two
135 (null register2))
136 (setf register2 (read-register-symbol s)))
137 ((and (listp s) ; a scaled register
138 (is-register-p (first s))
139 (integerp (second s))
140 (null register))
141 (setf register (read-register-symbol (first s))
142 scale (second s)))
143 ((and (listp s) ; a scaled register after a non-scaled register
144 (is-register-p (first s))
145 (integerp (second s))
146 (null register2)
147 (symbolp register))
148 (setf register2 register
149 register (read-register-symbol (first s))
150 scale (second s)))
151 (t (error "Can't read indirect operand ~A [~A]" iexpr s))))
152 (make-instance 'operand-indirect-register
153 'register register
154 'register2 register2
155 'offset (if (null symbolic-offsets)
156 offset
157 `(+ ,offset ,@symbolic-offsets))
158 'scale (or scale 1))))))
159
160 (defun read-abstract-operand (spec)
161 (etypecase (first spec)
162 (symbol
163 (assert (not (null (first spec))) (spec)
164 "NIL is an illegal assembly label: ~S" spec)
165 (make-instance 'operand-label
166 'label (first spec)
167 'user-size (second spec)))
168 (list
169 (let ((type (caar spec)) ; (<type> &rest <datum>)
170 (datum (cdar spec)))
171 (ecase type
172 (:sub-program
173 (let* ((options (car datum))
174 (sub-program (cdr datum)))
175 (destructuring-bind (&optional (label (gensym "sub-program-label-")))
176 options
177 (declare (special *programs-to-append*))
178 (pushnew (cons label sub-program) *programs-to-append*
179 :test #'equal)
180 (make-instance 'operand-label
181 'label label))))
182 (:funcall
183 (make-instance 'calculated-operand
184 :calculation (coerce (car datum) 'function)
185 :sub-operands (mapcar #'read-operand (cdr datum)))))))
186 (integer
187 (make-instance 'operand-number
188 'number (first spec)))))
189
190
191 (defun read-operand (spec)
192 (cond
193 ((integerp spec)
194 (make-instance 'operand-immediate
195 'value spec))
196 ((and (symbolp spec)
197 (is-register-p spec))
198 (make-instance 'operand-register
199 'register (read-register-symbol spec)))
200 ((null spec)
201 (error "Operand was NIL."))
202 ((and (listp spec)
203 (symbolp (first spec))
204 (string= 'quote (first spec)))
205 (read-abstract-operand (rest spec)))
206 ((listp spec)
207 (read-indirect-operand spec))
208 (t (error "Can't read operand ~S" spec))))
209
210 (defun read-prefixes (prefix-spec)
211 (loop with user-size = nil with user-finalizer = nil
212 for p in prefix-spec
213 if (symbolp p)
214 collect (let ((ps (find-symbol (symbol-name p) '#:ia-x86)))
215 (if (decode-set +prefix-opcode-map+ ps :errorp nil)
216 ps
217 (error "No such prefix: ~A" p)))
218 into prefixes
219 else do
220 (check-type p list)
221 (ecase (car p)
222 (:size
223 (let ((size (second p)))
224 (check-type size integer)
225 (setf user-size size)))
226 (:finalize ; XXX
227 (let ((finalizer (second p)))
228 (check-type finalizer symbol "a function name")
229 (setf user-finalizer finalizer))))
230 finally (return (values prefixes user-size user-finalizer))))
231
232 (defvar *find-instruction-cache* (make-hash-table :test #'eq))
233
234 (defun read-instruction (sexpr)
235 "Parse a list into an assembly instruction."
236 (let (prefix-list user-size user-finalizer instr-name operand-list)
237 (if (listp (first sexpr))
238 (setf (values prefix-list user-size user-finalizer) (read-prefixes (first sexpr))
239 instr-name (second sexpr)
240 operand-list (nthcdr 2 sexpr))
241 (setf prefix-list nil
242 user-size nil
243 instr-name (first sexpr)
244 operand-list (nthcdr 1 sexpr)))
245 (case instr-name
246 (:align
247 (make-instance 'alignment :type operand-list))
248 ((nil)
249 (mapcar #'read-operand operand-list)
250 nil)
251 (t (make-instance (or (gethash instr-name *find-instruction-cache*)
252 (setf (gethash instr-name *find-instruction-cache*)
253 (multiple-value-bind (instr-symbol instr-symbol-status)
254 (find-symbol (string instr-name) '#:ia-x86-instr)
255 (unless instr-symbol-status
256 (error "No instruction named ~A." (string instr-name)))
257 instr-symbol)))
258 :prefixes prefix-list
259 :user-size user-size
260 :user-finalizer user-finalizer
261 :operands (mapcar #'read-operand operand-list))))))
262
263
264 (defun inline-data-p (expr)
265 (and (listp expr)
266 (symbolp (first expr))
267 (string= '% (first expr))))
268
269 (defun read-proglist (program &rest args)
270 (when program
271 (let ((*programs-to-append* ())
272 (*already-appended* 0))
273 (declare (special *programs-to-append* *already-appended*))
274 (apply #'read-proglist-internal program args))))
275
276 (defun read-proglist-internal (program &key no-warning (do-append-programs t)
277 (append-after-type 'ia-x86-instr::unconditional-branch))
278 "Read a symbolic assembly program (a list with the syntax described in BNF in this file) into
279 a proglist: A list of INSTRUCTION objects."
280 (declare (special *programs-to-append* *already-appended*))
281 (loop for expr in program
282 if (null expr)
283 do (error "Illegal NIL expr in program: ~S" program)
284 else if (or (symbolp expr) (integerp expr))
285 collect expr ; a label, collect it.
286 else if (inline-data-p expr)
287 collect (read-inline-data expr) ; inline data, read it.
288 else if (and (consp expr) (eq :include (car expr)))
289 append (read-proglist (cdr expr)
290 :do-append-programs do-append-programs
291 :no-warning no-warning)
292 else
293 append (let ((i (read-instruction expr))) ; an instruction, read it, possibly append
294 (if (and do-append-programs
295 *programs-to-append*
296 (typep i append-after-type))
297 ;; auto-insert *programs-to-append* here:
298 (let ((sub-programs (reduce #'append
299 (nreverse
300 (subseq *programs-to-append* 0
301 (- (length *programs-to-append*)
302 *already-appended*))))))
303 (setf *already-appended* (length *programs-to-append*))
304 (list* i (read-proglist-internal sub-programs
305 :do-append-programs do-append-programs)))
306 ;; nothing to insert other than i itself..
307 (when i (list i))))
308 finally (assert (= (length *programs-to-append*)
309 *already-appended*) ()
310 "Dangling sub-programs to append: ~S"
311 (nreverse (subseq *programs-to-append*
312 0 (- (length
313 *programs-to-append*)
314 *already-appended*))))))
315
316
317 (defmacro asm (&rest spec)
318 `(instruction-encode (read-instruction ',spec) nil))

  ViewVC Help
Powered by ViewVC 1.1.5