; ARM Assembler Thumb-2 extensions for M4 and M33 - Version 1 - 18th November 2024
; see http://www.ulisp.com/show?4ZBD
;

; Instruction formats

(defun imm12 (n)
  (cond
   ((zerop (logand n #xffffff00)) n)
   ((and (zerop (logand n #xff00ff00)) (= (ash n -16) (logand n #xff)))
    (logior #x100 (logand (ash n -16) #xff)))
   ((and (zerop (logand n #xff00ff)) (= (ash n -16) (logand n #xff00)))
    (logior #x200 (logand (ash n -24) #xff)))
   ((and (= (logand (ash n -24) #xff) (logand (ash n -16) #xff) (logand (ash n -8) #xff) (logand n #xff)))
    (logior #x300 (logand (ash n -24) #xff)))
   (t
    (let ((s 0))
      (loop
       (unless (zerop (logand n #x80000000)) (return))
       (setq n (ash n 1)) (incf s))
      (unless (zerop (logand n #x00ffffff)) (error "Immediate value can't be represented"))
      (setq s (mod (+ s 8) 32))
      (logior (ash s 7) (logand (ash n -24) #x7f))))))

(defun logic-imm12 (argd argm const op)
  (when (null const) (setq const argm argm argd))
  (let ((s 1)
        (k (imm12 const)))
    (list
     (emit #x41114140 #xf 0 (ash k -11) 0 op s (regno argm))
     (emit #x13480000 0 (logand (ash k -8) #x7) (regno argd) (logand k #xff)))))

(defun cbz-cbnz (op argn label)
  (let* ((rn (regno argn))
         (soff6 (logand (offset label) #x3f))
         (i (ash soff6 -5))
         (immed5 (logand soff6 #x1f)))
    (emit #x61153000 op i 1 immed5 rn)))

(defun condcode (cc)
  (case cc (eq 0) (ne 1) ((cs hs) 2) ((cc lo) 3) (mi 4) (pl 5) (vs 6) (vc 7)
    (hi 8) (ls 9) (ge 10) (lt 11) (gt 12) (le 13) (al 14)))

(defun makemask (xyz fc0)
  (cond
   ((zerop (length xyz)) #b1000)
   (t (logior
       (ash (if (eq (char xyz 0) #\t) fc0 (- 1 fc0)) 3)
       (ash (makemask (subseq xyz 1) fc0) -1)))))

(defun thumb32 (op1 rm ra rd op2 rm2)
  (list 
   (emit #x48400000 #xf op1 rm)
   (emit #x44440000 ra rd op2 rm2)))

; Alphabetical list of mnemonics

(defun $and (argd argm &optional const)
  (cond
   ((and (not (numberp argm)) (null const))
    (reg-reg #x100 argd argm))
   (t (logic-imm12 argd argm const 0))))

(defun $b (arg1 &optional arg2)
  (cond
   (arg2
    (emit #x44800000 13 (condcode arg1) (logand (offset arg2) #xff)))
   (t
    (emit #x41b00000 #xe 0 (logand (offset arg1) #x7ff)))))

(defun $bfc (argd lsb width)
  (let ((rd (regno argd)) (msb (+ lsb width -1)))
    (list 
     (emit #x88000000 #xf3 #x6f)
     (emit #x134215000 0 (ash lsb -2) rd (logand lsb #x3) 0 msb))))

(defun $bic (argd argm &optional const)
  (cond
   ((and (not (numberp argm)) (null const))
    (reg-reg #xe argd argm))
   (t (logic-imm12 argd argm const 1))))

(defun $cbnz (argn label)
  (cbz-cbnz #x2e argn label))

(defun $cbz (argn label)
  (cbz-cbnz #x2c argn label))

(defun $clz (argd argm)
  (let ((rd (regno argd)) (rm (regno argm)))
    (thumb32 #xab rm #xf rd #x8 rm)))

(defun $eor (argd argm &optional const)
  (cond
   ((and (not (numberp argm)) (null const))
    (reg-reg #x101 argd argm))
   (t (logic-imm12 argd argm const 4))))

(defun $it (xyz &optional firstcond)
  (when (null firstcond) (setq firstcond xyz xyz ""))
  (let* ((cc (condcode firstcond))
         (fc0 (logand cc 1)))
    (emit #x84400000 #xbf cc (makemask (string xyz) fc0))))

(defun $mla (argd argn argm arga)
  (let ((rd (regno argd)) (rn (regno argn)) (rm (regno argm)) (ra (regno arga)))
    (thumb32 #xb0 rn ra rd 0 rm)))

(defun $mls (argd argn argm arga)
  (let ((rd (regno argd)) (rn (regno argn)) (rm (regno argm)) (ra (regno arga)))
    (thumb32 #xb0 rn ra rd 1 rm)))

(defun $mov (argd argm)
  (cond
   ((and (numberp argm) (zerop (logand argm #xffffff00)) (<= (regno argd) 7))
    (mov-sub-2-3 2 0 argd argm))
   ((numberp argm)
    (logic-imm12 argd 'r15 argm 2))
   ((or (>= (regno argd) 8) (>= (regno argm) 8))
    (add-mov-4 1 argd argm))
   (t ; Synonym of LSLS Rd, Rm, #0
    (lsl-lsr-0 0 0 argm argd))))

(defun $mvn (argd argm &optional const)
  (cond
   ((and (not (numberp argm)) (null const))
    (reg-reg #x10f argd argm))
   (t (logic-imm12 argd 'r15 argm 3))))

(defun $orr (argd argm &optional const)
  (cond
   ((and (not (numberp argm)) (null const))
    (reg-reg #x10c argd argm))
   (t (logic-imm12 argd argm const 2))))

(defun $rbit (argd argm)
  (let ((rd (regno argd)) (rm (regno argm)))
    (thumb32 #xa9 rm #xf rd #xa rm)))

(defun $sdiv (argd argn &optional argm)
  (unless argm (setq argm argn argn argd))
  (let ((rd (regno argd)) (rn (regno argn)) (rm (regno argm)))
    (thumb32 #xb9 rn #xf rd #xf rm)))

(defun $tst (argd argm &optional const)
  (cond
   ((and (not (numberp argm)) (null const))
    (reg-reg #x108 argd argm))
   (t (logic-imm12 'r15 argd const 0))))

(defun $udiv (argd argn &optional argm)
  (unless argm (setq argm argn argn argd))
  (let ((rd (regno argd)) (rn (regno argn)) (rm (regno argm)))
    (thumb32 #xbb rn #xf rd #xf rm)))