;;;;------------------------------------------------------------------
;;;; 
;;;;    Copyright (C) 2001, 
;;;;    Department of Computer Science, University of Tromsų, Norway.
;;;; 
;;;;    For distribution policy, see the accompanying file COPYING.
;;;; 
;;;; Filename:      picl.lisp
;;;; Description:   Microchip PIC microcontroller assembler.
;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
;;;; Created at:    Sat Mar 31 21:11:25 2001
;;;;                
;;;; $Id: picl.lisp,v 1.4 2001/04/07 23:17:58 frodef Exp $
;;;;                
;;;;------------------------------------------------------------------

(defpackage picl
  (:use common-lisp)
  (:export pic-read))

(in-package picl)

(defun make-component (type byte-spec value)
  (list type byte-spec value))

(defvar *instruction-names* (make-hash-table :test #'eq))

(defmacro defpicl (name operands format documentation)
  (declare (ignore options documentation))
  (labels ((parse-format (bit-spec bit-pos)
	     (etypecase (first bit-spec)
	       (null nil)
	       ((integer 0 1)
		(loop for bit-spec-rest on bit-spec
		    as digit = (first bit-spec-rest)
		    as digit-position upfrom 0
		    while (typep digit '(integer 0 1))
		    sum (ash digit digit-position) into byte
		    finally (return (cons `(make-component 'constant
							   (byte ,(1+ digit-position) ,bit-pos)
							   ,byte)
					  (parse-format bit-spec-rest
							(+ bit-pos digit-position))))))
	       (symbol
		(loop for bit-spec-rest on (rest bit-spec)
		    with type = (first bit-spec)
		    as spec-position upfrom 1
		    while (eq type (first bit-spec-rest))
		    finally (return (cons `(make-component ',type
							   (byte ,spec-position ,bit-pos)
							   nil)
					  (parse-format bit-spec-rest
							(+ bit-pos spec-position)))))))))
    `(setf (gethash (intern ',name '#:keyword) *instruction-names*)
       (list ',operands ,@(reverse (parse-format (reverse format) 0))))))

;;; Byte-oriented file register operations
(defpicl addwf (f d)  (0 0  0 1 1 1  d f f f  f f f f) "Add W and f")
(defpicl andwf (f d)  (0 0  0 1 0 1  d f f f  f f f f) "AND W with f")
(defpicl clrf (f)     (0 0  0 0 0 1  1 f f f  f f f f) "Clear f")
(defpicl clrw ()      (0 0  0 0 0 1  0 x x x  x x x x) "Clear W")
(defpicl comf (f d)   (0 0  1 0 0 1  d f f f  f f f f) "Complement f")
(defpicl decf (f d)   (0 0  0 0 1 1  d f f f  f f f f) "Decrement f")
(defpicl decfsz (f d) (0 0  1 0 1 1  d f f f  f f f f) "Decrement f, Skip if 0")
(defpicl incf (f d)   (0 0  1 0 1 0  d f f f  f f f f) "Increment f")
(defpicl incfsz (f d) (0 0  1 1 1 1  d f f f  f f f f) "Increment f, Skip if 0")
(defpicl iorwf (f d)  (0 0  0 1 0 0  d f f f  f f f f) "Inclusive OR W with f")
(defpicl movf (f d)   (0 0  1 0 0 0  d f f f  f f f f) "Move f")
(defpicl movwf (f)    (0 0  0 0 0 0  1 f f f  f f f f) "Move W to f")
(defpicl nop ()       (0 0  0 0 0 0  0 x x 0  0 0 0 0) "No Operation")
(defpicl rlf (f d)    (0 0  1 1 0 1  d f f f  f f f f) "Rotate Left f through Carry")
(defpicl rrf (f d)    (0 0  1 1 0 0  d f f f  f f f f) "Rotate Right f through Carry")
(defpicl subwf (f d)  (0 0  0 0 1 0  d f f f  f f f f) "Subtract W from f")
(defpicl swapf (f d)  (0 0  1 1 1 0  d f f f  f f f f) "Swap nibbles in f")
(defpicl xorwf (f d)  (0 0  0 1 1 0  d f f f  f f f f) "Exclusive OR W with f")

;;; Bit-oriented file register operations
(defpicl bcf (f b)    (0 1  0 0 b b  b f f f  f f f f) "Bit Clear f")
(defpicl bsf (f b)    (0 1  0 1 b b  b f f f  f f f f) "Bit Set f")
(defpicl btfsc (f b)  (0 1  1 0 b b  b f f f  f f f f) "Bit Test f, Skip if Clear")
(defpicl btfss (f b)  (0 1  1 1 b b  b f f f  f f f f) "Bit Test f, Skip if Set")

;;; Literal and Control Operations
(defpicl addlw (k)    (1 1  1 1 1 x  k k k k  k k k k) "Add literal and W")
(defpicl andlw (k)    (1 1  1 0 0 1  k k k k  k k k k) "AND literal with W")
(defpicl call (k)     (1 0  0 k k k  k k k k  k k k k) "Call subroutine")
(defpicl clrwdt ()    (0 0  0 0 0 0  0 1 1 0  0 1 0 0) "Clear Watchdog Timer")
(defpicl goto (k)     (1 0  1 k k k  k k k k  k k k k) "Go to address")
(defpicl iorlw (k)    (1 1  1 0 0 0  k k k k  k k k k) "Inclusive OR literal with W")
(defpicl movlw (k)    (1 1  0 0 x x  k k k k  k k k k) "Move literal to W")
(defpicl retfie ()    (0 0  0 0 0 0  0 0 0 0  1 0 0 1) "Return from interrupt")
(defpicl retlw (k)    (1 1  0 1 x x  k k k k  k k k k) "Return with literal in W")
(defpicl return ()    (0 0  0 0 0 0  0 0 0 0  1 0 0 0) "Return from Subroutine")
(defpicl sleep ()     (0 0  0 0 0 0  0 1 1 0  0 0 1 1) "Go into standby mode")
(defpicl sublw (k)    (1 1  1 1 0 x  k k k k  k k k k) "Subtract W from literal")
(defpicl xorlw (k)    (1 1  1 0 1 0  k k k k  k k k k) "Exclusive OR literal with W")

(defun make-forward-reference (&key cons instruction pc)
  (list* cons instruction pc))

(defun forward-reference-cons (f) (car f))
(defun forward-reference-instruction (f) (cadr f))
(defun forward-reference-pc (f) (cddr f))

(defun pic-read-instruction (i pc icons env forwards)
  (setf (car icons)
    (loop with (operands-template . format) = (or (gethash (first i) *instruction-names*)
						  (error "Unknown instruction: ~S" i))
	with operands = (rest i)
	for (type byte-spec value) in format
	as operand = (and (position type operands-template)
			  (elt operands (position type operands-template)))
	summing
	  (dpb (ecase type
		 (constant value)
		 (x 0)
		 (d (if (eq operand :w) 0 1))
		 (f (etypecase operand
		      (integer operand)))
		 (k (etypecase operand
		      (integer operand)
		      (symbol (or (gethash operand env)
				  (prog1 0
				    (push (make-forward-reference :cons icons :pc pc :instruction i)
					  (getf forwards operand))))))))
	       byte-spec 0)))
  (values icons env forwards))


(defun pic-read (prg &key (pc 0) (env (make-hash-table :test #'eq)) (forwards (list)))
  "A simple, non-sensical example: (pic-read '((:addlw 3) (:call label) (:addlw 5) label (:sleep))) => (#x3e03 #x2003 #x3e05 #x63)"
  (let (dummy)
    (declare (ignore dummy))
    (loop for p in prg
	as pc upfrom pc
	when (symbolp p)
	do (let ((label-forwards (getf forwards p)))
	     (assert (not (gethash p env)) (p)
	       "Doubly defined label ~A at PC #x~X (value was ~A)." p pc (gethash p env))
	     (setf (gethash p env) pc)
	     ;; resolve forwards..
	     (when label-forwards
	       (dolist (f label-forwards)
		 (multiple-value-setq (dummy env forwards)
		   (pic-read-instruction (forward-reference-instruction f)
					 (forward-reference-pc f)
					 (forward-reference-cons f)
					 env forwards)))
	       (remf forwards p)))
	when (consp p)
	nconc (multiple-value-setq (dummy env forwards)
		(pic-read-instruction p pc (cons nil nil) env forwards))
	finally (assert (null forwards) (forwards)
		  "There were unresolved labels:~{ ~S~}" 
		  (loop for x on forwards by #'cddr collect (car x))))))

(defvar *endian*)

(defun byte-list-split (byte-list from-size to-size &optional (*endian* *endian*))
  "From a BYTE-LIST of bytes sized FROM-SIZE, split each byte into bytes of size TO-SIZE.
   TO-SIZE must divide FROM-SIZE evenly.
   For example, the byte-list (#x12 #x345) split from size 12 to size 4 at :big-endian
   becomes (0 1 2 3 4 5), while at :little-endian the result is (2 1 0 5 4 3)."
  (assert (zerop (rem from-size to-size)))
  (ecase *endian*
    (:little-endian
     (loop for byte in byte-list
	 append (loop for x from 0 below (truncate from-size to-size)
		    collect (ldb (byte to-size (* x to-size)) byte))))
    (:big-endian
     (loop for byte in byte-list
	 append (loop for x from (1- (truncate from-size to-size)) downto 0
		    collect (ldb (byte to-size (* x to-size)) byte))))))								      
(defun byte-list-merge (byte-list from-size to-size &optional (*endian* *endian*))
  "From a BYTE-LIST of bytes sized FROM-SIZE, merge bytes into bytes sized TO-SIZE.
   FROM-SIZE must divide TO-SIZE evenly. For example, the byte-list (#xa #xb #xc #xd)
   merged from size 4 to size 8 at :big-endian becomes (#xab #xcd). For :little-endian,
   the result is (#xba #xdc)."
  (assert (zerop (rem to-size from-size)))
  (let ((factor (truncate to-size from-size)))
    (ecase *endian*
      (:little-endian
       (loop for bytes on byte-list by #'(lambda (x) (nthcdr factor x))
	   collect (loop for n from 0 below factor
		       as sub-byte = (or (nth n bytes) 0)
		       summing (ash sub-byte (* n from-size)))))
      (:big-endian
       (loop for bytes on byte-list by #'(lambda (x) (nthcdr factor x))
	   collect (loop for n from 0 below factor
		       as sub-byte = (or (nth (- factor 1 n) bytes) 0)
		       summing (ash sub-byte (* n from-size))))))))

(defun byte-list-resize (byte-list from-size to-size &optional (*endian* *endian*))
  (let ((gcd (gcd from-size to-size)))
    (byte-list-merge (byte-list-split byte-list from-size gcd *endian*)
		     gcd to-size *endian*)))