2 (in-package :m68k-assembler
)
6 (defun assemble (input-name &key
(object-name "mr-ed.o")
8 "Assembles a source file named by INPUT-NAME, to an object file
11 OBJECT-FORMAT can currently only be :AOUT for relocatable a.out object
14 (setf ;; create backpatch list
16 ;; init macro variables
17 *defining-macro-p
* nil
*defining-rept-p
* nil
21 ;; open file and start processing
22 (with-lexer (input-name)
23 (with-sections ('text
'data
'bss
)
24 (setf *current-section
* (cdr (assoc 'text
*sections
*)))
25 (process-current-file)
26 ;; Prior to backpatching, record section lengths, because
27 ;; temporary-files aren't really file streams the way CL would
28 ;; like them to be, so we can't just FILE-LENGTH them.
29 (let ((lengths (mapcar (lambda (x)
31 (section-length (cdr x
))))
33 (backpatch *backpatch-list
*)
35 (:aout
(finalize-object-file object-name lengths
)))))))
39 (defun process-current-file ()
42 ;; we strip individual token position information here, which
43 ;; might suck for superfine debugging/warning precision, but
44 ;; we really don't need all that clutter.
45 (multiple-value-bind (line *source-position
*)
46 (unclutter-line (parse #'next-token
))
47 (assert (eq (pop line
) 'line
) ()
48 "Some internal parse tree is messed up.")
50 (using-section (*current-section
*)
51 ;; if we're in a macro or repeat, just accumulate this
52 ;; line. otherwise, process it.
53 (cond ((or *defining-macro-p
* *defining-rept-p
*)
54 (if (and (eq (operation-type-of-line line
) 'pseudo-op
)
55 (string-equal (opcode-of-line line
)
56 (if *defining-macro-p
*
59 (push line
*macro-buffer
*)))
60 (t (process-line line
))))))
63 (defun operation-type-of-line (line)
64 (awhen (cadr (find 'operation line
:key
#'car
)) (car it
)))
66 (defun opcode-of-line (line)
67 (awhen (cadr (find 'operation line
:key
#'car
)) (caadr it
)))
69 (defun process-line (line)
70 (let ((label (find 'label line
:key
#'car
))
71 (operation (cadr (find 'operation line
:key
#'car
)))
72 (operands (mapcar #'simplify-operand
73 (extract-operands line
))))
74 (cond ((eq (operation-type-of-line line
) 'opcode
)
75 (assemble-opcode label operation operands
))
76 ((eq (operation-type-of-line line
) 'pseudo-op
)
77 (assemble-pseudo-op label operation operands
))
79 (handle-label-normally label
)))))
81 (defun handle-label-normally (label)
83 (let ((name (extract-string-from-tree label
)))
84 (when (not (local-label-name-p name
))
85 (setf *last-label
* name
))
86 ;; If the type is nil, the symbol isn't present.
87 (cond ((null (get-symbol-type name
))
88 (add-to-symbol-table name
*program-counter
*))
89 ;; If the value is nil, it was probably declared as a
90 ;; global before it was actually defined. Patch value,
92 ((null (get-symbol-value name
))
93 (let ((sym (get-asm-symbol name
)))
94 (assert (not (eq (asm-symbol-type sym
) 'extern
))
95 (name) "Trying to set a value for an EXTERN symbol!")
96 (setf (asm-symbol-value sym
) *program-counter
*
97 (asm-symbol-type sym
) (section-name *current-section
*)
98 (asm-symbol-debug-info sym
) *source-position
*)))
99 ;; Otherwise, it's a redefinition and I won't stand for it.
100 (t (warn "~A: tried to redefine label ~A -- ignoring."
101 *source-position
* name
))))))
103 (defun assemble-opcode (label operation operands
)
104 (let ((opcode (caadr operation
))
105 (modifier (cadadr operation
)))
106 (handle-label-normally label
)
107 (aif (find-matching-entry opcode operands modifier
)
108 (let ((*defining-relocations-p
* t
))
109 (multiple-value-bind (data len
)
110 (generate-code (second it
) operands modifier
)
112 (push (make-backpatch-item data len
) *backpatch-list
*)
113 (setf data
#x4E714E71
)) ; Output NOP if all else fails.
114 (output-data data len
)))
115 (error "~S: no matching opcode for ~A!" *source-position
*
119 (defun assemble-pseudo-op (label operation operands
)
120 (let ((opcode (caadr operation
))
121 (modifier (cadadr operation
)))
122 (let ((*defining-relocations-p
* t
))
123 (acond ((get-pseudo-op opcode
)
125 (funcall it label opcode operands modifier
)))
126 ((eql (get-symbol-type opcode
) 'macro
)
127 (execute-macro opcode operands modifier
))
128 (t (error "~&~S: bad pseudo-op ~A!"
129 *source-position
* opcode
))))))
132 (defun output-data (data length
)
133 "Outputs DATA in big-endian order to the currently active temporary
134 object file and updates the program counter. Returns the address to
135 which the data assembled."
136 #+nil
(unless (zerop (mod length
8))
137 (setf length
(ash (ceiling (/ length
8)) 3)))
138 (when (eq (section-name *current-section
*) 'text
)
139 (unless (zerop (mod length
16))
140 (format t
"~&~A: ~A" *source-position
* length
)))
141 (incf *program-counter
* (ash length -
3))
142 (funcall (section-output-fn *current-section
*)
143 *object-stream
* data length
))
148 ;; Devpac macros -- when we see a macro start, collect until the ENDM,
149 ;; so we can expand ourselves.
155 (defun define-equate (label op operands modifier
)
156 (declare (ignore op modifier
))
158 (error "~A: EQU always needs a label." *source-position
*))
159 (assert (= (length operands
) 1))
160 (let ((*defining-relocations-p
* nil
))
161 (add-to-symbol-table label
(absolute-value (first operands
))
164 (defun execute-macro (name operands modifier
)
165 (labels ((sub (match &rest registers
)
166 (declare (ignore registers
))
167 (acase (char match
1)
168 (#\
@ (format nil
"_~D"
169 (asm-macro-count (get-symbol-value name
))))
170 (#\
0 (case modifier
(byte ".B") (long ".L") (t ".W")))
171 (t (nth (digit-to-int it
36) operands
))))
176 (cl-ppcre:regex-replace-all
"\\\\[0-9A-Za-z@]" tree
#'sub
178 (cons (mapcar #'seek
+destroy tree
))
181 (dolist (x (asm-macro-body (get-symbol-value name
)))
182 (process-line (seek+destroy x
)))
183 (incf (asm-macro-count (get-symbol-value name
)))))
185 (defun start-macro (label op operands modifier
)
186 (declare (ignore op operands modifier
))
187 ;; if *defining-macro-p* is already set cry foul.
188 (assert (not *defining-macro-p
*))
190 ;; otherwise clear out *macro-buffer*.
191 (setf *macro-buffer
* (list (second label
))
192 *defining-macro-p
* t
))
194 (defun end-macro (label op operands modifier
)
195 (declare (ignore label op operands modifier
))
196 (assert *defining-macro-p
*)
197 (setf *macro-buffer
* (nreverse *macro-buffer
*)
198 *defining-macro-p
* nil
)
199 (add-to-symbol-table (first *macro-buffer
*)
200 (make-asm-macro :body
(cdr *macro-buffer
*))
206 ;; backpatch structure
216 (defun make-backpatch-item (data length
)
217 (make-backpatch :template data
:length length
218 :program-counter
*program-counter
*
219 :section
*current-section
*
220 :file-position
(file-position
221 (section-object-stream *current-section
*))
222 :last-label
*last-label
*
223 :source-position
*source-position
*))
225 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
226 (defmacro with-backpatch
((item) &body body
)
227 `(let ((*program-counter
* (backpatch-program-counter ,item
))
228 (*current-section
* (backpatch-section ,item
))
229 (*last-label
* (backpatch-last-label ,item
))
230 (*source-position
* (backpatch-source-position ,item
))
231 (*object-stream
* (section-object-stream (backpatch-section ,item
))))
234 (defun backpatch (backpatch-list)
235 ;; go through backpatch list, try to make all patches
236 (dolist (x backpatch-list
)
237 (using-section ((backpatch-section x
))
239 (let ((*defining-relocations-p
* t
))
240 (multiple-value-bind (data len
)
241 (generate-code (backpatch-template x
) nil nil
)
243 (error "~A: Failed to backpatch @ ~A: ~S."
244 *source-position
* *program-counter
* data
))
245 (assert (= len
(backpatch-length x
)))
246 (assert (file-position (section-object-stream *current-section
*)
247 (backpatch-file-position x
)))
248 (output-data data len
)))))))
254 (defstruct relocation
259 ;; only one of symbol or segment can be selected at a time, so the
260 ;; symbol field provides both functions.
263 (defun relocation-segment (r) (relocation-symbol r
))
264 (defun (setf relocation-segment
) (v r
) (setf (relocation-segment r
) v
))
267 (defun figure-out-reloc (symbol pc
)
268 (let* ((sym (get-asm-symbol symbol
))
269 (extern-p (eq (asm-symbol-type sym
) 'extern
)))
270 (make-relocation :address pc
:extern-p extern-p
272 (asm-symbol-name sym
)
273 (asm-symbol-type sym
)))))
275 (defun check-reloc-consistency (reloc-a reloc-b
)
276 (assert (every (lambda (fn)
277 (eql (funcall fn reloc-a
)
278 (funcall fn reloc-b
)))
279 (list #'relocation-address
280 ;; XXX relocation-size
282 #'relocation-extern-p
))))
284 (defun add-relocation (symbol)
285 (when (and *defining-relocations-p
*
286 (not (eq (get-symbol-type symbol
) 'absolute
)))
287 (let ((reloc (figure-out-reloc symbol
*program-counter
*)))
288 (sif (gethash *program-counter
* *relocation-table
*)
289 (check-reloc-consistency reloc it
)
292 (defun pc-relativise-relocation ()
293 "If there's a relocation at this PC, mark it PC-relative."
294 (swhen (gethash *program-counter
* *relocation-table
*)
295 ;; If the symbol is not extern and segment is same as current
296 ;; section, then delete from relocation table (no need to relocate
297 ;; same-section relative references within the same file).
298 (if (or (relocation-extern-p it
)
299 (not (eq (relocation-segment it
)
300 (section-name *current-section
*))))
301 (setf (relocation-pc-relative-p it
) t
)
302 (remhash *program-counter
* *relocation-table
*))))
304 (defun fix-relocation-size (size)
305 (swhen (gethash *program-counter
* *relocation-table
*)
306 (setf (relocation-size it
) size
)))
309 ;;;; HELPER FUNCTIONS
311 (defun extract-string-from-tree (tree)
312 "Return the first string we come to in TREE."
313 (tree-find-if #'stringp tree
))
315 (defun resolve-expression (expression)
316 "Try and get a numerical value from this expression. Returns the
317 further simplified expression, which will be an atom if everything was
319 (flet ((bin-op (sym fn
)
320 (assert (= (length expression
) 3))
321 (let ((a (resolve-expression (second expression
)))
322 (b (resolve-expression (third expression
))))
323 (if (and (integerp a
) (integerp b
))
326 (if (atom expression
)
329 (string (string->int expression
))
330 (t (error "Unknown expression atom: ~A" expression
)))
331 (case (car expression
)
333 (- (if (= (length expression
) 2)
334 (let ((v (resolve-expression (second expression
))))
335 (if (integerp v
) (- v
) expression
))
339 (& (bin-op '& #'logand
))
340 (or (bin-op 'or
#'logior
))
341 (^
(bin-op '^
#'logxor
))
342 (<< (bin-op '<< #'ash
))
343 (>> (bin-op '>> #'(lambda (n count
) (ash n
(- count
)))))
344 (~
(let ((v (resolve-expression (second expression
))))
348 (symbol (acond ((get-symbol-value expression
)
349 (add-relocation expression
)
352 ;;; XXX if we got a constant, it's a bug. That should have
353 ;;; been picked out at the AST stage.
354 (constant (resolve-expression (second expression
)))
358 ;;;; EOF assembler.lisp