1 (in-package :m68k-assembler
)
5 (defun pseudo-op-p (string)
6 (or (get-pseudo-op string
) (eql (get-symbol-type string
) 'macro
)))
8 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
9 (let ((asm-pseudo-op-table (make-hash-table :test
'equalp
)))
10 (dolist (x `(("SECTION"
11 ,(lambda (label op operands modifier
)
12 (declare (ignore op modifier
))
13 (handle-label-normally label
)
14 (assert (and (eql (caar operands
) 'absolute
)
15 (eql (caadar operands
) 'symbol
)))
16 (assert (= (length operands
) 1))
17 (let ((section (intern (string-upcase
18 (cadar (cdar operands
)))
19 (find-package "M68K-ASSEMBLER"))))
20 (setf *current-section
* (cdr (assoc section
*sections
*)))
21 (assert *current-section
*))))
22 ("XDEF" ,#'define-global
)
23 ("GLOBAL" ,#'define-global
)
24 ("XREF" ,#'define-extern
)
25 ("EXTERN" ,#'define-extern
)
26 ("ORG" ,(lambda (label op operands modifier
)
27 (declare (ignore label op modifier
))
28 (assert (eql (car (first operands
)) 'absolute
))
29 (assert (= (length operands
) 1))
30 (setf *program-counter
* (absolute-value (first operands
)))))
33 ,(lambda (label op operands modifier
)
34 (declare (ignore op modifier
))
35 (assert (= (length operands
) 1))
36 (handle-label-normally label
)
37 (nested-lexing (extract-string-from-tree (first operands
)))))
39 ,(lambda (label op operands modifier
)
40 (declare (ignore op modifier
))
41 (assert (= (length operands
) 1))
42 (handle-label-normally label
)
43 (with-open-file (stream (extract-string-from-tree
46 :element-type
'unsigned-byte
)
47 (copy-stream-contents stream
48 (section-object-stream
50 (incf *program-counter
* (file-position stream
)))))
52 ("ALIGN" ,(lambda (label op operands modifier
)
53 (declare (ignore op modifier
))
54 (assert (= (length operands
) 1))
55 (handle-label-normally label
)
56 (let ((align (absolute-value (first operands
))))
58 ((zerop (mod *program-counter
* align
)))
60 ("EVEN" ,(lambda (label op operands modifier
)
61 (declare (ignore op modifier operands
))
62 (handle-label-normally label
)
63 (unless (evenp *program-counter
*)
65 ;; offsetalign -- offset+(PC+align-1)&~(align-1)
67 ("CNOP" ,(lambda (label op operands modifier
)
68 (declare (ignore op modifier
))
69 (handle-label-normally label
)
70 (let ((offset (absolute-value (first operands
)))
71 (align (absolute-value (second operands
))))
73 ((zerop (mod (- *program-counter
* offset
) align
)))
76 ("MACRO" ,#'start-macro
)
80 ,(lambda (label op operands modifier
)
81 (declare (ignore label op modifier
))
82 (assert (not *defining-rept-p
*))
83 (assert (= (length operands
) 1))
84 (setf *macro-buffer
* (list (absolute-value (first operands
)))
85 *defining-rept-p
* t
)))
87 ,(lambda (label op operands modifier
)
88 (declare (ignore label op operands modifier
))
89 (assert *defining-rept-p
*)
90 (setf *macro-buffer
* (nreverse *macro-buffer
*)
91 *defining-rept-p
* nil
)
92 (dotimes (i (pop *macro-buffer
*))
93 (dolist (x *macro-buffer
*)
97 ,(lambda (label op operands modifier
)
99 (handle-label-normally label
)
100 (unless modifier
(setf modifier
'word
))
102 (let ((data (absolute-value x modifier
))
103 (length (modifier-size-in-bits modifier
)))
105 (push (make-backpatch-item `((,length
(absolute-value ,data
,modifier
)))
109 ;; The behavior here is that if we're asked to DC
110 ;; some constant larger than the length we output
111 ;; it in length chunks. This might be undesired
112 ;; behavior for some modifiers although it's
113 ;; almost certainly desired behavior for bytes.
114 ;; Maybe some heuristics and warnings should go
115 ;; here or at least a flag to enable/disable this
117 (when (minusp data
) ; XXX this is totally broken!
118 (setf data
(+ (ash 1 length
) data
)))
119 (do ((total (if (<= 0 data
1) 1 (ceiling (log data
2)
123 (output-data (ldb (byte length
(* (1- total
) length
))
127 ,(lambda (label op operands modifier
)
128 (declare (ignore op
))
129 (handle-label-normally label
)
130 (unless modifier
(setf modifier
'word
))
131 (assert (eql (car (first operands
)) 'absolute
))
132 (assert (= (length operands
) 1))
133 (let ((data (absolute-value (first operands
) modifier
))
134 (length (modifier-size-in-bits modifier
)))
135 (unless (integerp data
)
136 (error "~A: Need to be able to resolve DS immediately."
138 (output-data 0 (* data length
)))))
139 ;; ("DCB") ; constant block -- numbervalue
141 ("EQU" ,#'define-equate
)
142 ("=" ,#'define-equate
)
143 ;; EQUR (register equate)
145 ;; Conditional compilation.
146 ;; XXX What other conditions are there?
148 ,(lambda (label op operands modifier
)
149 (declare (ignore label op modifier
))
150 (assert (not *defining-conditional-compilation-p
*))
151 (assert (= (length operands
) 1))
152 (setf *macro-buffer
* (list (zerop (absolute-value (first operands
))))
153 *defining-conditional-compilation-p
* t
)))
155 ,(lambda (label op operands modifier
)
156 (declare (ignore label op modifier
))
157 (assert (not *defining-conditional-compilation-p
*))
158 (assert (= (length operands
) 1))
159 (setf *macro-buffer
* (list (/= 0 (absolute-value (first operands
))))
160 *defining-conditional-compilation-p
* t
)))
162 ,(lambda (label op operands modifier
)
163 (declare (ignore label op operands modifier
))
164 (assert *defining-conditional-compilation-p
*)
165 (setf *macro-buffer
* (nreverse *macro-buffer
*)
166 *defining-conditional-compilation-p
* nil
)
167 (when (pop *macro-buffer
*)
168 (dolist (x *macro-buffer
*)
171 ;; ("END") ; early end of source.
173 (setf (gethash (first x
) asm-pseudo-op-table
) (second x
)))
174 (defun get-pseudo-op (name)
175 (gethash name asm-pseudo-op-table
))))