; AVR Assembler
; see http://www.ulisp.com/show?3IUO
;

; Extract register number
(defun reg (sym)
  (case sym ((xl x) 26) (xh 27) ((yl y) 28) (yh 29) ((zl z) 30) (zh 31)
    (t (read-from-string (subseq (string sym) 1)))))

; Pack arguments into bit fields
(defun emit (bit &rest arg)
  (let ((wd 0))
    (mapc #'(lambda (wth val)
              (unless (zerop (ash val (- wth))) (err "Won't fit"))
              (setq wd (logior (ash wd wth) val)))
          bit arg)
    wd))

; Extract bits
(defun bit (x a &optional (b a))
  (logand (ash x (- b)) (1- (ash 1 (- a b -1)))))

; Errors
(defun err (txt) (format t "(pc=~x) ~a~%" *p* txt))

; Offset
(defun ofs (lbl) (ash (- lbl *p* 2) -1))

; Position
(defun pos (x lst &optional (n 0))
  (cond
   ((null lst) nil)
   ((eq x (car lst)) n)
   (t (pos x (cdr lst) (1+ n)))))

; Shared routines

; immediate

(defun imm (op rd im)
  (emit '(4 4 4 4) op (bit im 7 4) (- (reg rd) 16) (bit im 3 0)))

(defun iw (op rd im)
  (emit '(6 2 2 2 4) #b100101 op (bit im 5 4) (bit (reg rd) 2 1) (bit im 3 0)))

; Direct

(defun d1p (op2 op rd)
  (emit '(5 2 5 4) #b10010 op2 (reg rd) op))

(defun d1 (op rd)
  (d1p 2 op rd))

(defun d1b (op rd bit)
  (emit '(5 2 5 1 3) #b11111 op (reg rd) 0 bit))

(defun d2 (op rd rr)
  (emit '(6 1 5 4) op (bit (reg rr) 4) (reg rd) (bit (reg rr) 3 0)))

(defun lss (op rr k)
  (list
   (emit '(6 1 5 4) #b100100 op (reg rr) 0)
   k))

; I/O registers

(defun io (op rr a)
  (emit '(4 1 2 5 4) #b1011 op (bit a 5 4) (reg rr) (bit a 3 0)))

(defun dio (op adr bit)
  (emit '(6 2 5 3) #b100110 op adr bit)) 

; Jump and call

(defun rcj (op lbl)
  (emit '(3 1 12) #b110 op (logand (ofs lbl) #xFFF)))

; Indirect store and load

(defun s-l (op rr arg)
  (if (or (eq arg 'y) (eq arg 'z))
      (sld op rr arg 0)
    (let ((op2 (case arg (z+ 1) (-z 2) (y+ 9) (-y 10) (x 12) (x+ 13) (-x 14))))
      (emit '(6 1 5 4) #b100100 op (reg rr) op2))))

(defun sld (op rr arg dsp)
  (let ((op2 (case arg (z 0) (y 1))))
    (emit '(2 1 1 2 1 5 1 3) #b10 (bit dsp 5) 0 (bit dsp 4 3) op (reg rr) op2 (bit dsp 2 0))))

; Status register

(defun bsr (op flg)
  (emit '(8 1 3 4) #x94 op flg #x8))

(defun csf (op flg)
  (let ((i (pos flg '(c z n v s h t i))))
    (bsr op i)))

; Alphabetical list of mnemonics

(defun $adc (rd rr)
  (d2 #b000111 rd rr))

(defun $add (rd rr)
  (d2 #b000011 rd rr))

(defun $adiw (rd im)
  (iw #b10 rd im))

(defun $and (rd rr)
  (d2 #b001000 rd rr))

(defun $asr (rd)
  (d1 5 rd))

(defun $bclr (flg)
  (bsr 1 flg))

(defun $bld (rd bit)
  (d1b 0 rd bit))

(defun $br (cc lbl)
  (let ((k (ofs lbl))
        (i (pos cc '(cs eq mi vs lt hs ts ie cc ne pl vc ge hc tc id))))
    (if (<= -64 k +63)
        (emit '(5 1 7 3) #b11110 (bit i 3) (logand k #x7F) (bit i 2 0))
      (err "Branch too big"))))

(defun $bset (flg)
  (bsr 0 flg))

(defun $bst (rd bit)
  (d1b 1 rd bit))

(defun $cbi (adr bit)
  (dio 0 adr bit))

(defun $cl (flg)
  (csf 1 flg))

(defun $clr (rd)
  ($eor rd rd))

(defun $com (rd)
  (d1 0 rd))

(defun $cp (rd rr)
  (d2 #b000101 rd rr))

(defun $cpc (rd rr)
  (d2 #b000001 rd rr))

(defun $cpi (rd im)
  (imm #b0011 rd im))

(defun $cpse (rd rr)
  (d2 #b000100 rd rr))

(defun $dec (rd)
  (d1 10 rd))

(defun $eor (rd rr)
  (d2 #b001001 rd rr))

(defun $in (rd a)
  (io 0 rd a))

(defun $inc (rd)
  (d1 3 rd))

(defun $ld (rd arg)
  (s-l 0 rd arg))

(defun $ldd (rd arg dsp)
  (sld 0 rd arg dsp))

(defun $ldi (rd im)
  (imm #b1110 rd im))

(defun $lds (rd k)
  (lss 0 rd k))

(defun $lsl (rd)
  (d2 #b000010 rd rd))

(defun $lsr (rd)
  (d1 6 rd))

(defun $mov (rd rr)
  (d2 #b001011 rd rr))

(defun $movw (rd rr)
  (emit '(8 4 4) #x01 (bit (reg rd) 4 1) (bit (reg rr) 4 1)))

(defun $mul (rd rr)
  (d2 #b100111 rd rr))

(defun $neg (rd)
  (d1 1 rd))

(defun $nop ()
  0)

(defun $or (rd rr)
  (d2 #b001010 rd rr))

(defun $out (a rr)
  (io 1 rr a))

(defun $pop (rd)
  (d1p 0 #b1111 rd))

(defun $push (rd)
  (d1p 1 #b1111 rd))

(defun $ret ()
  #x9508)

(defun $rcall (lbl)
  (rcj 1 lbl))

(defun $rjmp (lbl)
  (rcj 0 lbl))

(defun $rol (rd)
  (d2 #b000111 rd rd))

(defun $ror (rd)
  (d1 7 rd))

(defun $sbc (rd rr)
  (d2 #b000010 rd rr))

(defun $sbi (adr bit)
  (dio 2 adr bit))

(defun $sbic (adr bit)
  (dio 1 adr bit))

(defun $sbis (adr bit)
  (dio 3 adr bit))

(defun $sbiw (rd im)
  (iw #b11 rd im))

(defun $sbrc (rd bit)
  (d1b 2 rd bit))

(defun $sbrs (rd bit)
  (d1b 3 rd bit))

(defun $se (flg)
  (csf 0 flg))

(defun $ser (rd)
  (imm #b1110 rd #xFF))

(defun $st (arg rs)
  (s-l 1 rs arg))

(defun $std (arg dsp rr)
  (sld 1 rr arg dsp))

(defun $sts (k rr)
  (lss 1 rr k))

(defun $sub (rd rr)
  (d2 #b000110 rd rr))

(defun $subi (rd im)
  (imm #b0101 rd im))

(defun $swap (rd)
  (d1 2 rd))

(defun $tst (rd)
  (d2 #b001000 rd rd))