;;;===========================================================================
;;;
;;; project:    robot
;;; file:       controller.lisp
;;; author:     Andrew Smith
;;; created:    2006-01-13
;;; updated:    2006-08-14
;;; language:   Common Lisp (CLISP)
;;; licence:    GPL version 2
;;;
;;; Copyright 2006, Andrew Smith <http://asmith.id.au>
;;;
;;; NOTES
;;;
;;; PIC microcontroller serial programmer and assembler.
;;; Requires serial PIC programmer hardware as per David Tait's design.
;;;
;;;
;;;---------------------------------------------------------------------------
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published
;;; by the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;;
;;;
;;;---------------------------------------------------------------------------

(load "source/serial")

(defpackage "CONTROLLER" (:use "CL" "SERIAL"))

(in-package controller)



;;; GENERAL PURPOSE FUNCTIONS ================================================


;;; busy wait for a 'precise' amount of time

(defun wait-for-microseconds
  (microseconds &optional (start-time (get-internal-real-time)))
  (do
    ((finish-time (+ start-time microseconds)))
    ((> (get-internal-real-time) finish-time))))


;;; split a list into groups of at most the given size
;;; from "On Lisp" by Paul Graham, page 47

(defun group-items (items group-size)
  (when (zerop group-size) (error "zero length group"))
  (labels ((make-groups (items groups)
             (let ((remainder (nthcdr group-size items)))
               (if (consp remainder)
                 (make-groups remainder (cons (subseq items 0 group-size) groups))
                 (nreverse (cons items groups))))))
    (when items (make-groups items nil))))


;;; evaluate a test and report an error if it fails

(defun verify (test &rest message) (unless test (apply #'error message)))
(defun reject (test &rest message) (when test (apply #'error message)))


;;; define constants

(defmacro dc (start &rest constants)
  (let ((counter (gensym)))
    `(let ((,counter ,start))
       ,@(mapcan #'(lambda (constant)
                     (if constant
                       (let ((name (if (consp constant) (first constant) constant))
                             (size (if (consp constant) (second constant) 1)))
                         `((defconstant ,name ,counter)
                           (incf ,counter ,size)))
                       `((incf ,counter))))
                 constants))))



;;; MICROCONTROLLER INSTRUCTIONS =============================================


(defconstant *pic16-instructions*
  '((#x0700 #x3F00 addwf (f d) (1) (c dc z) "Add W and f")
    (#x0500 #x3F00 andwf (f d) (1) (z) "AND W with f")
    (#x0180 #x3F80 clrf (f) (1) (z) "Clear f")
    (#x0100 #x3F80 clrw nil (1) (z) "Clear W")
    (#x0900 #x3F00 comf (f d) (1) (z) "Complement f")
    (#x0300 #x3F00 decf (f d) (1) (z) "Decrement f")
    (#x0B00 #x3F00 decfsz (f d) (1 2) nil "Decrement f, Skip if 0")
    (#x0A00 #x3F00 incf (f d) (1) (z) "Increment f")
    (#x0F00 #x3F00 incfsz (f d) (1 2) nil "Increment f, Skip if 0")
    (#x0400 #x3F00 iorwf (f d) (1) (z) "Inclusive OR W with f")
    (#x0800 #x3F00 movf (f d) (1) (z) "Move f")
    (#x0080 #x3F80 movwf (f) (1) nil "Move W to f")
    (#x0000 #x3F9F nop nil (1) nil "No Operation")
    (#x0D00 #x3F00 rlf (f d) (1) (c) "Rotate Left f through Carry")
    (#x0C00 #x3F00 rrf (f d) (1) (c) "Rotate Right f through Carry")
    (#x0200 #x3F00 subwf (f d) (1) (c dc z) "Subtract W from f")
    (#x0E00 #x3F00 swapf (f d) (1) nil "Swap nibbles in f")
    (#x0600 #x3F00 xorwf (f d) (1) (z) "Exclusive OR W with f")
    (#x1000 #x3C00 bcf (f b) (1) nil "Bit Clear f")
    (#x1400 #x3C00 bsf (f b) (1) nil "Bit Set f")
    (#x1800 #x3C00 btfsc (f b) (1 2) nil "Bit Test f, Skip if Clear")
    (#x1C00 #x3C00 btfss (f b) (1 2) nil "Bit Test f, Skip if Set")
    (#x3E00 #x3E00 addlw (k) (1) (c dc z) "Add literal and W")
    (#x3900 #x3F00 andlw (k) (1) (z) "AND literal with W")
    (#x2000 #x3800 call (a) (2) nil "Call subroutine")
    (#x0064 #x3FFF clrwdt nil (1) (to pd) "Clear Watchdog Timer")
    (#x2800 #x3800 goto (a) (2) nil "Go to address")
    (#x3800 #x3F00 iorlw (k) (1) (z) "Inclusive OR literal with W")
    (#x3000 #x3C00 movlw (k) (1) nil "Move literal to W")
    (#x0009 #x3FFF retfie nil (2) nil "Return from interrupt")
    (#x3400 #x3C00 retlw (k) (2) nil "Return with literal in W")
    (#x0008 #x3FFF return nil (2) nil "Return from Subroutine")
    (#x0063 #x3FFF sleep nil (1) (to pd) "Go into standby mode")
    (#x3C00 #x3E00 sublw (k) (1) (c dc z) "Subtract W from literal")
    (#x3A00 #x3F00 xorlw (k) (1) (z) "Exclusive OR literal with W")))


(defconstant *pic18-instructions*
  '((#x2400 #xFC00 addwf (f d a) (1) (c dc z ov n) "Add W and f")
    (#x2000 #xFC00 addwfc (f d a) (1) (c dc z ov n) "Add W and Carry bit to f")
    (#x1400 #xFC00 andwf (f d a) (1) (z n) "AND W and f")
    (#x6A00 #xFE00 clrf (f a) (1) (z) "Clear f")
    (#x1C00 #xFC00 comf (f d a) (1) (z n) "Complement f")
    (#x6200 #xFE00 cpfseq (f a) (1 2 3) nil "Compare f with W, skip =")
    (#x6400 #xFE00 cpfsgt (f a) (1 2 3) nil "Compare f with W, skip >")
    (#x6000 #xFE00 cpfslt (f a) (1 2 3) nil "Compare f with W, skip <")
    (#x0400 #xFC00 decf (f d a) (1) (c dc z ov n) "Decrement f")
    (#x2C00 #xFC00 decfsz (f d a) (1 2 3) nil "Decrement f, skip if 0")
    (#x4C00 #xFC00 dcfsnz (f d a) (1 2 3) nil "Decrement f, skip if not 0")
    (#x2800 #xFC00 incf (f d a) (1) (c dc z ov n) "Increment f")
    (#x3C00 #xFC00 incfsz (f d a) (1 2 3) nil "Increment f, skip if 0")
    (#x4800 #xFC00 infsnz (f d a) (1 2 3) nil "Increment f, skip if not 0")
    (#x1000 #xFC00 iorwf (f d a) (1) (z n) "Inclusive OR W with f")
    (#x5000 #xFC00 movf (f d a) (1) (z n) "Move f")
    (#xC000 #xF000 movff (fs fd) (2) nil "Move fs to 1st word, fd to 2nd word")
    (#x6E00 #xFE00 movwf (f a) (1) nil "Move W to f")
    (#x0200 #xFE00 mulwf (f a) (1) nil "Multiply W with f")
    (#x6C00 #xFE00 negf (f a) (1) (c dc z ov n) "Negate f")
    (#x3400 #xFC00 rlcf (f d a) (1) (c z n) "Rotate left f through carry")
    (#x4400 #xFC00 rlncf (f d a) (1) (z n) "Rotate left f (no carry)")
    (#x3000 #xFC00 rrcf (f d a) (1) (c z n) "Rotate right f through carry")
    (#x4000 #xFC00 rrncf (f d a) (1) (z n) "Rotate right f (no carry)")
    (#x6800 #xFE00 setf (f a) (1) nil "Set f")
    (#x5400 #xFC00 subfwb (f d a) (1) (c dc z ov n) "Subtract f from W with borrow")
    (#x5C00 #xFC00 subwf (f d a) (1) (c dc z ov n) "Subtract W from f")
    (#x5800 #xFC00 subwfb (f d a) (1) (c dc z ov n) "Subtract W from f with borrow")
    (#x3800 #xFC00 swapf (f d a) (1) nil "Swap nibbles in f")
    (#x6600 #xFE00 tstfsz (f a) (1 2 3) nil "Test f, skip if 0")
    (#x1800 #xFC00 xorwf (f d a) (1) (z n) "Exclusive OR W with f")
    (#x9000 #xF000 bcf (f b a) (1) nil "Bit clear f")
    (#x8000 #xF000 bsf (f b a) (1) nil "Bit set f")
    (#xB000 #xF000 btfsc (f b a) (1 2 3) nil "Bit test f, skip if clear")
    (#xA000 #xF000 btfss (f b a) (1 2 3) nil "Bit test f, skip if set")
    (#x7000 #xF000 btg (f b a) (1) nil "Bit toggle f")
    (#xE200 #xFF00 bc (n) (1 2) nil "Branch if carry")
    (#xE600 #xFF00 bn (n) (1 2) nil "Branch if negative")
    (#xE300 #xFF00 bnc (n) (1 2) nil "Branch if not carry")
    (#xE700 #xFF00 bnn (n) (1 2) nil "Branch if not negative")
    (#xE500 #xFF00 bnov (n) (1 2) nil "Branch if not overflow")
    (#xE100 #xFF00 bnz (n) (2) nil "Branch if not zero")
    (#xE400 #xFF00 bov (n) (1 2) nil "Branch if overflow")
    (#xD000 #xF800 bra (n) (1 2) nil "Branch unconditionally")
    (#xE000 #xFF00 bz (n) (1 2) nil "Branch if zero")
    (#xEC00 #xFE00 call (n s) (2) nil "Call subroutine 1st word")
    (#x0004 #xFFFF clrwdt nil (1) (to pd) "Clear watchdog timer")
    (#x0007 #xFFFF daw nil (1) (c) "Decimal adjust register")
    (#xEF00 #xFF00 goto (n) (2) nil "Goto address 1st word")
    (#x0000 #xFFFF nop nil (1) nil "No operation")
    (#x0006 #xFFFF pop nil (1) nil "Pop top of return stack")
    (#x0005 #xFFFF push nil (1) nil "Push top of return stack")
    (#xD800 #xF800 rcall (n) (2) nil "Relative call")
    (#x00FF #xFFFF reset nil (1) nil "Software device RESET")
    (#x0010 #xFFFE retfie (s) (2) (gie gieh peie giel) "Return from interrupt enable")
    (#x0C00 #xFF00 retlw (k) (2) nil "Return with literal in W")
    (#x0012 #xFFFE return (s) (2) nil "Return from subroutine")
    (#x0003 #xFFFF sleep nil (1) (to pd) "Go into standby mode")
    (#x0F00 #xFF00 addlw (k) (1) (c dc z ov n) "Add literal and W")
    (#x0B00 #xFF00 andlw (k) (1) (z n) "AND literal with W")
    (#x0900 #xFF00 iorlw (k) (1) (z n) "Inclusive OR literal with W")
    (#xEE00 #xFFC0 lfsr (f k) (2) nil "Move literal")
    (#x0100 #xFFF0 movlb (k) (1) nil "Move literal to BSR<3:0>")
    (#x0E00 #xFF00 movlw (k) (1) nil "Move literal to W")
    (#x0D00 #xFF00 mullw (k) (1) nil "Multiply literal with W")
    (#x0C00 #xFF00 retlw (k) (2) nil "Return with literal in W")
    (#x0800 #xFF00 sublw (k) (1) (c dc z ov n) "Subtract W from literal")
    (#x0A00 #xFF00 xorlw (k) (1) (z n) "Exclusive OR literal with W")
    (#x0008 #xFFFF tblrd* nil (2) nil "Table Read")
    (#x0009 #xFFFF tblrd*+ nil (2) nil "Table Read with post-increment")
    (#x000A #xFFFF tblrd*- nil (2) nil "Table Read with post-decrement")
    (#x000B #xFFFF tblrd+* nil (2) nil "Table Read with pre-increment")
    (#x000C #xFFFF tblwt* nil (2) nil "Table Write")
    (#x000D #xFFFF tblwt*+ nil (2) nil "Table Write with post-increment")
    (#x000E #xFFFF tblwt*- nil (2) nil "Table Write with post-decrement")
    (#x000F #xFFFF tblwt+* nil (2) nil "Table Write with pre-increment")
    (#xF000 #xF000 nil nil nil nil "second word")))



;;; MICROCONTROLLER REGISTERS ================================================


(defconstant
  *pic16f84-registers*
  '(;; bank 0
    (indf "contents of register addressed by fsr")
    (tmr0 "8-bit real-time clock/counter")
    (pcl "low order 8-bits of program counter")
    (status
      (c "carry/borrow bit")
      (dc "digit carry/borrow bit")
      (z "zero bit")
      (pd "power-down bit")
      (to "time-out bit")
      (rp0 "register bank select bit for direct addressing")
      (rp1 "register bank select bit for direct addressing")
      (irp "register bank select bit for indirect addressing"))
    (fsr "indirect data memory address pointer 0")
    porta
    portb
    nil
    (eedata "eeprom data register")
    (eeadr "eeprom address register")
    (pclath "write buffer for upper 5 bits of program counter")
    (intcon
      (rbif "RB port change interrupt flag bit")
      (intf "RB0/INT interrupt flag bit")
      (toif "TMR0 overflow interrupt flag bit")
      (rbie "RB port change interrupt enable bit")
      (inte "RB0/INT interrupt enable bit")
      (toie "TMR0 overflow interrupt enable bit")
      (eeie "EE write complete interrupt enable bit")
      (gie "global interrupt enable bit"))
    (gpr "general purpose registers")
    ;; bank 1
    #x80
    nil
    (option-reg
      (ps0 "prescaler rate select bit")
      (ps1 "prescaler rate select bit")
      (ps2 "prescaler rate select bit")
      (psa "prescaler assignment bit")
      (tose "timer 0 source edge select bit")
      (tocs "timer 0 clock source select bit")
      (intedg "interrupt edge select bit")
      (rbpu "port B pull-up enable bit"))
    nil
    nil
    nil
    (trisa "port A data direction register")
    (trisb "port B data direction register")
    nil
    (eecon1
      (erd "read control bit")
      (ewr "write control bit")
      (wren "EEPROM write enable bit")
      (wrerr "EEPROM error flag bit")
      (eeif "EEPROM write operation interrupt flag bit"))
    (eecon2 "EEPROM control register 2")))


(defconstant
  *pic16f88-registers*
  '(;; bank 0
    (indf "contents of register addressed by fsr")
    (tmr0 "8-bit real-time clock/counter")
    (pcl "low order 8-bits of program counter")
    (status
      (c "carry/borrow bit")
      (dc "digit carry/borrow bit")
      (z "zero bit")
      (pd "power-down bit")
      (to "time-out bit")
      (rp0 "register bank select bit for direct addressing")
      (rp1 "register bank select bit for direct addressing")
      (irp "register bank select bit for indirect addressing"))
    (fsr "indirect data memory address pointer 0")
    porta
    portb
    nil
    nil
    nil
    (pclath "write buffer for upper 5 bits of program counter")
    (intcon
      (rbif "RB port change interrupt flag bit")
      (int0if "RB0/INT interrupt flag bit")
      (tmr0if "TMR0 overflow interrupt flag bit")
      (rbie "RB port change interrupt enable bit")
      (int0ie "RB0/INT interrupt enable bit")
      (tmr0ie "TMR0 overflow interrupt enable bit")
      (peie "EE write complete interrupt enable bit")
      (gie "global interrupt enable bit"))
    (pir1
      (tmr1if "")
      (tmr2if "")
      (ccp1if "")
      (sspif "")
      (txif "")
      (rcif "")
      (adif "")
      nil)
    (pir2
      nil
      nil
      nil
      nil
      (eeif "")
      nil
      (cmif "")
      (osfif ""))
    (tmr1l "holding register for least significant byte of timer 1")
    (tmr1h "holding register for most significant byte of timer 1")
    (t1con
      (tmr1on "")
      (tmr1cs "")
      (t1sync "")
      (t1oscen "")
      (t1ckps0 "")
      (t1ckps1 "")
      (t1run "")
      nil)
    (tmr2 "timer 2 module register")
    (t2con
      (t2ckps0 "")
      (t2ckps1 "")
      (tmr2on "")
      (toutps0 "")
      (toutps1 "")
      (toutps2 "")
      (toutps3 "")
      nil)
    (sspbuf "synchronous serial port receive buffer / transmit register")
    (sspcon
      (sspm0 "")
      (sspm1 "")
      (sspm2 "")
      (sspm3 "")
      (ckp "")
      (sspen "")
      (sspov "")
      (wcol ""))
    (ccpr1l "least significant byte of capture / compare / PWM register 1")
    (ccpr1h "most significant byte of capture / compare / PWM register 1")
    (ccp1con
      (ccp1m0 "")
      (ccp1m1 "")
      (ccp1m2 "")
      (ccp1m3 "")
      (ccp1y "")
      (ccp1x "")
      nil
      nil)
    (rcsta
      (rx9d "")
      (oerr "")
      (ferr "")
      (adden "")
      (cren "")
      (sren "")
      (rx9 "")
      (spen ""))
    (txreg "AUSART transmit data register")
    (rcreg "AUSART receive data register")
    nil
    nil
    nil
    (adresh "A/D result register high byte")
    (adcon0
      (adon "")
      nil
      (go-done "")
      (chs0 "")
      (chs1 "")
      (chs2 "")
      (adcs0 "")
      (adcs1 ""))
    (gpr "general purpose registers")
    ;; bank 1
    #x80
    nil ;indf
    (option-reg
      (ps0 "prescaler rate select bit")
      (ps1 "prescaler rate select bit")
      (ps2 "prescaler rate select bit")
      (psa "prescaler assignment bit")
      (tose "timer 0 source edge select bit")
      (tocs "timer 0 clock source select bit")
      (intedg "interrupt edge select bit")
      (rbpu "port B pull-up enable bit"))
    nil ;pcl
    nil ;status
    nil ;fsr
    (trisa "port A data direction register")
    (trisb "port B data direction register")
    nil
    nil
    nil
    nil ;pclath
    nil ;intcon
    (pie1
      (tmr1ie "")
      (tmr2ie "")
      (ccp1ie "")
      (sspie "")
      (txie "")
      (rcie "")
      (adie "")
      nil)
    (pie2
      nil
      nil
      nil
      nil
      (eeie "")
      nil
      (cmie "")
      (osfie ""))
    (pcon
      (bor "")
      (por ""))
    (osccon
      (scs0 "")
      (scs1 "")
      (iofs "")
      (osts "")
      (ircf0 "")
      (ircf1 "")
      (ircf2 "")
      nil)
    (osctune
      (tun0 "")
      (tun1 "")
      (tun2 "")
      (tun3 "")
      (tun4 "")
      (tun5 ""))
    nil
    (pr2 "timer 2 period register")
    (sspadd "synchronous serial port (i2c mode) address register")
    (sspstat
      (bf "")
      (ua "")
      (rw "")
      (s "")
      (p "")
      (da "")
      (cke "")
      (smp ""))
    nil
    nil
    nil
    (txsta
      (tx9d "")
      (trmt "")
      (brgh "")
      nil
      (sync "")
      (txen "")
      (tx9 "")
      (csrc ""))
    (spbrg "baud rate generator register")
    nil
    (ansel
      (ans0 "")
      (ans1 "")
      (ans2 "")
      (ans3 "")
      (ans4 "")
      (ans5 "")
      (ans6 ""))
    (cmcon
      (cm0 "")
      (cm1 "")
      (cm2 "")
      (cis "")
      (c1inv "")
      (c2inv "")
      (c1out "")
      (c2out ""))
    (cvrcon
      (cvr0 "")
      (cvr1 "")
      (cvr2 "")
      (cvr3 "")
      nil
      (cvrr "")
      (cvroe "")
      (cvren ""))
    (adresl "A/D result register low byte")
    (adcon1
      nil
      nil
      nil
      nil
      (vcfg0 "")
      (vcfg1 "")
      (adcs2 "")
      (adfm ""))
    (gpr1 "general purpose registers bank 1")
    ;; bank 2
    #x100
    nil ;indf
    nil ;tmr0
    nil ;pcl
    nil ;status
    nil ;fsr
    (wdtcon
      (swdten "")
      (wdtps0 "")
      (wdtps1 "")
      (wdtps2 "")
      (wdtps3 ""))
    nil ;portb
    nil
    nil
    nil
    nil ;pclath
    nil ;intcon
    (eedata "EEPROM/Flash data register low byte")
    (eeadr "EEPROM/Flash address register low byte")
    (eedath "EEPROM/Flash data register high byte")
    (eeadrh "EEPROM/Flash address register high byte")
    (gpr2 "general purpose registers bank 2")
    ;; bank 3
    #x180
    nil ;indf
    nil ;option-reg
    nil ;pcl
    nil ;status
    nil ;fsr
    nil
    nil ;trisb
    nil
    nil
    nil
    nil ;pclath
    nil ;intcon
    (eecon1
      (rd "read control bit")
      (wr "write control bit")
      (wren "EEPROM write enable bit")
      (wrerr "EEPROM error flag bit")
      (free "")
      nil
      nil
      (eepgd ""))
    (eecon2 "EEPROM control register 2")
    nil ;reserved
    nil ;reserved
    (gpr3 "general purpose registers bank 3")))



;;; MICROCONTROLLER CLASSES ==================================================


(defclass controller ()
  ((part-number :accessor part-number :initarg :part-number)
   (port :accessor port :initarg :port :initform (make-instance 'serial-port))
   (configuration :accessor configuration :initarg :configuration)
   (config-size :accessor config-size :initarg :config-size)
   (program-size :accessor program-size :initarg :program-size)
   (memory-size :accessor memory-size :initarg :memory-size)
   (eeprom-size :accessor eeprom-size :initarg :eeprom-size)
   (stack-size :accessor stack-size :initarg :stack-size :initform 8)
   (program-count :accessor program-count :initarg :program-count :initform 0)
   (register-count :accessor register-count :initarg :register-count :initform 0)
   (label-list :accessor label-list :initform nil)
   (registers :accessor registers :initarg :registers :initform nil)
   (variables :accessor variables :initarg :variables :initform nil)
   (eeprom-data :accessor eeprom-data :initarg :eeprom-data :initform nil)
   (source-code :accessor source-code :initarg :source-code :initform nil)
   (object-code :accessor object-code :initform nil)
   (instructions :accessor instructions :initarg :instructions :initform nil)
   (buffer-size :accessor buffer-size :initarg :buffer-size :initform nil)))

(defclass instruction ()
  ((opcode :accessor opcode :initarg :opcode)
   (mask :accessor mask :initarg :mask)
   (mnemonic :accessor mnemonic :initarg :mnemonic)
   (operands :accessor operands :initarg :operands)
   (cycles :accessor cycles :initarg :cycles)
   (flags :accessor flags :initarg :flags)
   (description :accessor description :initarg :description)
   (controller :accessor controller :initarg :controller)))

(defclass register ()
  ((label :accessor label :initarg :label)
   (description :accessor description :initarg :description :initform nil)
   (address :accessor address :initarg :address)
   (bytes :accessor bytes :initarg :bytes :initform 1)
   (bits-count :accessor bits-count :initarg :bits-count :initform 0)
   (bits :accessor bits :initarg :bits :initform nil)
   (controller :accessor controller :initarg :controller)))

(defclass bits ()
  ((label :accessor label :initarg :label)
   (description :accessor description :initarg :description :initform nil)
   (offset :accessor offset :initarg :offset)
   (range :accessor range :initarg :range :initform 1)
   (register :accessor register :initarg :register)))


;;; DEVICE DEFINITIONS -------------------------------------------------------

;;; pic16f84

(defclass pic16f84 (controller)
  ((part-number :initform "pic16f84")
   (program-size :initform 1024)
   (memory-size :initform 68)
   (eeprom-size :initform 64)
   (config-size :initform 8)
   (configuration :initform #x3FF2)
   (instructions :initform *pic16-instructions*)
   (registers :initform *pic16f84-registers*)))


;;; pic16f88

(defclass pic16f88 (controller)
  ((part-number :initform "pic16f88")
   (program-size :initform 4096)
   (memory-size :initform 368)
   (eeprom-size :initform 256)
   (config-size :initform 9)
   (configuration :initform '(#x3F63 #x0000))
   (instructions :initform *pic16-instructions*)
   (registers :initform *pic16f88-registers*)
   (buffer-size :initform #x68)))


;;; PRINT METHODS -------------------------------------------------------------

(defmethod print-object ((instruction instruction) ostream)
  (prin1 (list (class-name (class-of instruction))
               :opcode (opcode instruction)
               :mask (mask instruction)
               :mnemonic (mnemonic instruction)
               :operands (operands instruction)
               :cycles (cycles instruction)
               :flags (flags instruction)
               :description (description instruction))
         ostream)
  instruction)

(defmethod print-object ((bits bits) ostream)
  (prin1 (list (class-name (class-of bits))
               :label (label bits)
               :description (description bits)
               :offset (offset bits)
               :range (range bits))
         ostream)
  bits)

(defmethod print-object ((register register) ostream)
  (prin1 (list (class-name (class-of register))
               :label (label register)
               :description (description register)
               :address (address register)
               :bytes (bytes register)
               :bits-count (bits-count register)
               :bits (mapcar #'label (bits register)))
         ostream)
  register)

(defmethod print-object ((controller controller) ostream)
  (prin1 (list (class-name (class-of controller))
               :part-number (part-number controller)
               :program-size (program-size controller)
               :memory-size (memory-size controller)
               :eeprom-size (eeprom-size controller)
               :registers (mapcar #'label (registers controller))
               :instructions (mapcar #'mnemonic (instructions controller)))
         ostream)
  controller)


;;; ASSEMBLER METHODS --------------------------------------------------------

(defmethod offset ((offset integer)) offset)
(defmethod address ((address integer)) address)


;;; initialise instruction

(defmethod make-instruction ((controller controller) (definition list))
  (destructuring-bind
    (opcode mask mnemonic operands cycles flags description) definition
    (push (make-instance 'instruction
                         :opcode opcode
                         :mask mask
                         :mnemonic mnemonic
                         :operands operands
                         :cycles cycles
                         :flags flags
                         :description description
                         :controller controller)
          (instructions controller))))


;;; initialise bits

(defmethod make-bits ((register register) (bits bits))
  (push bits (bits register))
  (incf (bits-count register) (range bits)))

(defmethod make-bits ((register register) (filler null))
  (incf (bits-count register)))

(defmethod make-bits ((register register) (offset integer))
  (setf (bits-count register) offset))

(defmethod make-bits ((register register) (comment string)))

(defmethod make-bits ((register register) (label symbol))
  (let* ((offset (bits-count register))
         (bits (make-instance 'bits
                              :register register
                              :label label
                              :offset offset)))
    (make-bits register bits)))

(defmethod make-bits ((register register) (definition list))
  (let* ((label (find-if #'symbolp definition))
         (range (find-if #'integerp definition))
         (offset (bits-count register))
         (description (find-if #'stringp definition))
         (bits (make-instance 'bits
                              :register register
                              :label label
                              :offset offset
                              :range (or range 1)
                              :description description)))
    (make-bits register bits)))


;;; initialise registers

(defmethod make-register ((controller controller) (register register))
  (push register (registers controller))
  (incf (register-count controller) (bytes register)))

(defmethod make-register ((controller controller) (address integer))
  (setf (register-count controller) address))

(defmethod make-register ((controller controller) (filler null))
  (incf (register-count controller)))

(defmethod make-register ((controller controller) (comment string)))

(defmethod make-register ((controller controller) (label symbol))
  (let ((register (make-instance 'register
                                 :controller controller
                                 :label label
                                 :address (register-count controller))))
    (make-register controller register)))

(defmethod make-register ((controller controller) (definitions list))
  (let* ((label (find-if #'symbolp definitions))
         (address (register-count controller))
         (bytes (find-if #'integerp definitions))
         (description (find-if #'stringp definitions))
         (register (make-instance 'register
                                  :controller controller
                                  :label label
                                  :address address
                                  :bytes (or bytes 1)
                                  :description description)))
    (dolist (definition (rest definitions))
      (make-bits register definition))
    (make-register controller register)))


;;; first pass methods

(defmethod first-pass ((controller controller) (origin integer))
  (let ((program-count (program-count controller))
        (program-size (program-size controller)))
    (verify (>= origin program-count)
            "Attempt to set origin ~A before code ~A."
            origin program-count)
    (verify (< origin program-size)
            "Attempt to set origin ~A past end of program space ~A."
            origin program-size)
    (setf (program-count controller) origin)))

(defmethod first-pass ((controller controller) (label symbol))
  (let ((pair (assoc label (label-list controller))))
    (verify (null pair)
            "Label ~A is already defined with value ~A."
            label (rest pair))
    (push (cons label (program-count controller)) (label-list controller))))

(defmethod first-pass ((controller controller) (line list))
  (incf (program-count controller))
  (verify (< (program-count controller) (program-size controller))
          "Program is too large for program space."))


;;; second pass methods

;;; evaluate an address field

(defmethod get-address ((controller controller) (address integer))
  (verify (<= 0 address (program-size controller))
          "address ~A is out of range ~A"
          address (program-size controller))
  address)

(defmethod get-address ((controller controller) (label symbol))
  (or (rest (assoc label (label-list controller)))
      (error "label ~A not defined" label)))


;;; evaluate a register field

(defmethod get-register ((controller controller) (address integer))
  (or (find address (registers controller) :key #'address)
      (verify (<= 0 address (memory-size controller))
              "register ~A is out of range ~A"
              address (memory-size controller))
      address))

(defmethod get-register ((controller controller) (label symbol))
  (or (find label (registers controller) :key #'label)
      (error "register ~A not defined" label)))


;;; evaluate a bit field

(defmethod get-bits ((register t) (offset integer))
  (verify (<= 0 offset 7) "bits ~A is out of range 0 to 7" offset) offset)

(defmethod get-bits ((register register) (label symbol))
  (or (find label (bits register) :key #'label)
      (error "bits ~A not defined in register ~A" label (label register))))


;;; evaluate a constant

(defmethod get-constant ((controller controller) (value integer))
  (verify (<= 0 value 255)
          "constant ~A is out of range 255" value)
  value)

(defmethod get-constant ((controller controller) (label symbol))
  (let ((register (find label (registers controller) :key #'label)))
    (logand #xFF (or (when register (address register))
                     (rest (assoc label (label-list controller)))
                     (error "~A is undefined" label)))))


;;; evaluate an operand

(defmethod operand
  ((controller controller) (operand (eql 'a)) address &optional notused)
  (declare (ignore notused))
  (get-address controller address))

(defmethod operand
  ((controller controller) (operand (eql 'b)) register &optional bits)
  (* 128 (offset (get-bits (get-register controller register) bits))))

(defmethod operand
  ((controller controller) (operand (eql 'd)) register &optional direction)
  (declare (ignore register))
  (or (case direction (w 0) (f #x80))
      (error "invalid direction ~A" direction)))

(defmethod operand
  ((controller controller) (operand (eql 'f)) register &optional argument)
  (declare (ignore argument))
  (logand (address (get-register controller register)) #x7F))

(defmethod operand
  ((controller controller) (operand (eql 'k)) argument &optional notused)
  (declare (ignore notused))
  (get-constant controller argument))


;;; second pass advance the origin with null padding

(defmethod second-pass ((controller controller) (origin integer))
  (dotimes (x (- origin (program-count controller)))
    (push nil (object-code controller)))
  (setf (program-count controller) origin))


;;; second pass skip a symbol

(defmethod second-pass ((controller controller) (label symbol)))


;;; second pass assemble an instruction

(defmethod second-pass ((controller controller) (line list))
  (destructuring-bind (mnemonic &optional operand1 operand2) line
    (let* ((instruction (find mnemonic (instructions controller) :key #'mnemonic))
           (opcode (opcode instruction))
           (operands (operands instruction)))
      (verify (eq (length (rest line)) (length operands))
              "~A has wrong number of operands." line)
      (push (apply #'logior opcode
                   (mapcar
                     #'(lambda (operand)
                         (operand controller operand operand1 operand2))
                     operands))
            (object-code controller))
      (incf (program-count controller)))))


;;; finalise a controller instance by defining variables and assembling code

(defmethod initialize-instance :after ((controller controller) &rest initargs)
  (declare (ignore initargs))
  (let ((registers (registers controller))
        (instructions (instructions controller)))

    (setf (registers controller) nil
          (instructions controller) nil)
    (dolist (register registers)
      (make-register controller register))
    (dolist (instruction instructions)
      (make-instruction controller instruction))
    (setf (register-count controller)
          (address (find 'gpr (registers controller) :key #'label)))

    (dolist (variable (variables controller))
      (make-register controller variable))
    (setf (program-count controller) 0)
    (dolist (line (source-code controller))
      (first-pass controller line))
    (setf (program-count controller) 0)
    (dolist (line (source-code controller))
      (second-pass controller line))
    (setf (object-code controller)
          (nreverse (object-code controller)))))



;;; MICROCONTROLLER HARDWARE PROGRAMMER ======================================


;;; HARDWARE PROGRAMMER DEFINITIONS ------------------------------------------

(defconstant *command-load-configuration* 0)
(defconstant *command-phase-one* 1)
(defconstant *command-load-program-memory* 2)
(defconstant *command-load-data-memory* 3)
(defconstant *command-read-program-memory* 4)
(defconstant *command-read-data-memory* 5)
(defconstant *command-increment-address* 6)
(defconstant *command-phase-two* 7)
(defconstant *command-begin-programming* 8)
(defconstant *command-erase-program-memory* 9)
(defconstant *command-erase-data-memory* 11)
(defconstant *command-end-writing* 23)
(defconstant *command-begin-writing* 24)
(defconstant *command-chip-erase* 31)

(defconstant *half-bit-delay* 10)
(defconstant *short-delay* 20000)
(defconstant *long-delay* 50000)


;;; HARDWARE PROGRAMMER FUNCTIONS --------------------------------------------

;;; serial port bits

(defmacro clock-low () `(set-rts nil))
(defmacro clock-high () `(set-rts t))

(defmacro data-low () `(set-dtr nil))
(defmacro data-high () `(set-dtr t))
(defmacro data-off () `(set-dtr t))

(defmacro program-low () `(set-txd nil))
(defmacro program-high () `(set-txd t))

(defmacro get-data () `(not (get-cts)))


;;; cycle the clock

(defun send-clock ()
  (clock-high)
  (wait-for-microseconds *half-bit-delay*)
  (clock-low)
  (wait-for-microseconds *half-bit-delay*))


;;; clock out one bit

(defun output-bit (value)
  (if value
    (data-high)
    (data-low))
  (send-clock))


;;; clock in one bit

(defun input-bit ()
  (send-clock)
  (get-data))


;;; enter programming mode

(defun start-programming ()
  (program-low)
  (clock-low)
  (data-low)
  (wait-for-microseconds *long-delay*)
  (program-high))


;;; leave programming mode

(defun stop-programming ()
  (program-low)
  (clock-high)
  (data-high)
  (wait-for-microseconds *long-delay*))


;;; clock out a 6-bit command

(defun put-command (command)
  (dotimes (x 6)
    (output-bit (logbitp x command)))
  (wait-for-microseconds *short-delay*))


;;; clock out a 14-bit data word

(defun put-word (word)
  (output-bit nil)
  (dotimes (x 14)
    (output-bit (logbitp x word)))
  (output-bit nil)
  (wait-for-microseconds *short-delay*))


;;; send a command and a data word

(defun put-command-word (command word)
  (put-command command)
  (put-word word))


;;; clock in a 14-bit data word

(defun get-word ()
  (let ((data 0) start-bit stop-bit)
    (data-off)
    (setf start-bit (input-bit))
    (dotimes (x 14)
      (when (input-bit) (incf data (expt 2 x))))
    (setf stop-bit (input-bit))
    (wait-for-microseconds *short-delay*)
    (verify (and start-bit stop-bit)
            "Hardware framing error.")
    data))


;;; send a command and get a data word in response

(defun get-command-word (command)
  (put-command command)
  (get-word))


;;; verify a 14-bit word

(defun verify-word (command word &optional (mask #x3FFF))
  (let ((data (get-command-word command)))
    (verify (eq (logand data mask) (logand word mask))
            "Received ~14,'0B but expected ~14,'0B." data word)))


;;; HARDWARE PROGRAMMER METHODS ----------------------------------------------


;;; program and verify a 14-bit program word

(defmethod update-program-memory ((controller pic16f84) code)
  (unless (eq (get-command-word *command-read-program-memory*) code)
    (format t "~%burning program ~14,'0B" code)
    (put-command-word *command-load-program-memory* code)
    (put-command *command-begin-programming*)
    (verify-word *command-read-program-memory* code))
  (put-command *command-increment-address*))


;;; program and verify a 14-bit data word

(defmethod update-data-memory ((controller pic16f84) data mask kind)
  (unless (eq (logand (get-command-word *command-read-data-memory*) mask)
              (logand data mask))
    (format t "~%burning ~A ~14,'0B" kind data)
    (put-command-word *command-load-data-memory* data)
    (put-command *command-begin-programming*)
    (verify-word *command-read-data-memory* data mask))
  (put-command *command-increment-address*))


;;; initialise microcontroller

(defmethod initialise ((controller pic16f84))
  (let ((*descriptor* (descriptor (port controller))))
    (declare (special *descriptor*))
    (start-programming)
    (put-command-word *command-load-configuration* (configuration controller))
    (dotimes (x 7)
      (put-command *command-increment-address*))
    (put-command *command-phase-one*)
    (put-command *command-phase-two*)
    (put-command *command-begin-programming*)
    (put-command *command-phase-one*)
    (put-command *command-phase-two*)
    (stop-programming)))

(defmethod initialise ((controller pic16f88))
  (let ((*descriptor* (descriptor (port controller))))
    (declare (special *descriptor*))
    (start-programming)
    (put-command-word *command-load-configuration* #x3FFF)
    (put-command *command-chip-erase*)
    (stop-programming)))


;;; configure microcontroller

(defmethod configure ((controller pic16f84))
  (let ((*descriptor* (descriptor (port controller)))
        (configuration (configuration controller)))
    (declare (special *descriptor*))
    (start-programming)
    (put-command-word *command-load-configuration* configuration)
    (dotimes (x 4)
      (update-data-memory controller #x3F80 #x007F "identification"))
    (dotimes (x 3)
      (put-command *command-increment-address*))
    (update-data-memory controller configuration #x3FFF "configuration")
    (stop-programming)))

(defmethod configure ((controller pic16f88))
  (let ((*descriptor* (descriptor (port controller)))
        (configuration (configuration controller)))
    (declare (special *descriptor*))
    (start-programming)
    (put-command-word *command-load-configuration* #x3FFF)
    (dotimes (x 7)
      (put-command *command-increment-address*))
    (dolist (configuration-word configuration)
      (put-command-word *command-load-data-memory* configuration-word)
      (put-command *command-begin-writing*)
      (wait-for-microseconds 2000)
      (put-command *command-end-writing*)
      (put-command *command-increment-address*))
    (stop-programming)))


;;; read configuration

(defmethod read-configuration ((controller controller))
  (let ((*descriptor* (descriptor (port controller)))
        (configuration nil))
    (declare (special *descriptor*))
    (start-programming)
    (put-command-word *command-load-configuration* #x3FFF)
    (dotimes (x (config-size controller))
      (push (get-command-word *command-read-program-memory*) configuration)
      (put-command *command-increment-address*))
    (stop-programming)
    (nreverse configuration)))


;;; read program memory

(defmethod read-program-memory ((controller controller) size)
  (let ((*descriptor* (descriptor (port controller)))
        (program-memory nil))
    (declare (special *descriptor*))
    (start-programming)
    (dotimes (x size)
      (push (get-command-word *command-read-program-memory*) program-memory)
      (put-command *command-increment-address*))
    (stop-programming)
    (nreverse program-memory)))


;;; read data memory

(defmethod read-data-memory ((controller controller) &optional (mask #xFF))
  (let ((*descriptor* (descriptor (port controller)))
        (data-memory nil))
    (declare (special *descriptor*))
    (start-programming)
    (dotimes (x (eeprom-size controller))
      (push (logand mask (get-command-word *command-read-data-memory*))
            data-memory)
      (put-command *command-increment-address*))
    (stop-programming)
    (nreverse data-memory)))


;;; load program memory

(defmethod load-program-memory ((controller pic16f84))
  (let ((*descriptor* (descriptor (port controller)))
        (object-code (object-code controller)))
    (declare (special *descriptor*))
    (format t "~%loading and verifying program ~S" object-code)
    (start-programming)
    (dolist (word object-code)
      (if word
        (update-program-memory controller word)
        (put-command *command-increment-address*)))
    (stop-programming)))

(defmethod load-program-memory ((controller pic16f88))
  (let ((*descriptor* (descriptor (port controller)))
        (object-code (group-items (group-items (object-code controller) 4) 8)))
    (declare (special *descriptor*))
    (format t "~%loading and verifying program ~S" object-code)
    (start-programming)
    (dolist (row object-code)
      (dolist (four row)
        (let ((four (subseq (concatenate 'list four '(nil nil nil)) 0 4)))
          (when (first four)
            (put-command-word *command-load-program-memory* (first four)))
          (dolist (word (rest four))
            (put-command *command-increment-address*)
            (when word
              (put-command-word *command-load-program-memory* word))))
        (put-command *command-begin-writing*)
        (wait-for-microseconds 2000)
        (put-command *command-end-writing*)
        (put-command *command-increment-address*)))
    (stop-programming)))


;;; load data memory

(defmethod load-data-memory ((controller pic16f84))
  (let ((*descriptor* (descriptor (port controller)))
        (eeprom-data (eeprom-data controller)))
    (declare (special *descriptor*))
    (format t "~%loading and verifying data ~S" eeprom-data)
    (verify (<= (length eeprom-data) (eeprom-size controller))
            "Too much eeprom data.")
    (start-programming)
    (dolist (word eeprom-data)
      (if word
        (update-data-memory controller word #x00FF "data")
        (put-command *command-increment-address*)))
    (stop-programming)))


;;; erase program memory

(defmethod erase-program-memory ((controller pic16f84))
  (let ((*descriptor* (descriptor (port controller))))
    (declare (special *descriptor*))
    (start-programming)
    (put-command-word *command-load-program-memory* #x3FFF)
    (put-command *command-phase-one*)
    (put-command *command-phase-two*)
    (put-command *command-begin-programming*)
    (put-command *command-phase-one*)
    (put-command *command-phase-two*)
    (stop-programming)))

(defmethod erase-program-memory ((controller pic16f88))
  (let ((*descriptor* (descriptor (port controller))))
    (declare (special *descriptor*))
    (start-programming)
    (put-command *command-erase-program-memory*)
    (put-command *command-begin-programming*)
    (stop-programming)))


;;; erase data memory

(defmethod erase-data-memory ((controller pic16f84))
  (let ((*descriptor* (descriptor (port controller))))
    (declare (special *descriptor*))
    (start-programming)
    (put-command-word *command-load-data-memory* #x3FFF)
    (put-command *command-phase-one*)
    (put-command *command-phase-two*)
    (put-command *command-begin-programming*)
    (put-command *command-phase-one*)
    (put-command *command-phase-two*)
    (stop-programming)))

(defmethod erase-data-memory ((controller pic16f88))
  (let ((*descriptor* (descriptor (port controller))))
    (declare (special *descriptor*))
    (start-programming)
    (put-command *command-erase-data-memory*)
    (put-command *command-begin-programming*)
    (stop-programming)))



;;; MICROCONTROLLER SOFTWARE PROGRAMMER ======================================


;;; SOFTWARE PROGRAMMER DEFINITIONS ------------------------------------------


;;; special characters

(defconstant *stx* #x0F)
(defconstant *etx* #x04)
(defconstant *dle* #x05)


;;; structures

(defconstant *words-per-row* 32)
(defconstant *words-per-block* 4)
(defconstant *blocks-per-row* (floor *words-per-row* *words-per-block*))
(defconstant *bytes-per-word* 2)

(defconstant *command-overhead* 5)

(defconstant *padding* (loop for i from 1 to (1- *words-per-row*) collect nil))


;;; commands

(defconstant *read-version* 0)
(defconstant *read-program* 1)
(defconstant *write-program* 2)
(defconstant *erase-program* 3)
(defconstant *read-memory* 4)
(defconstant *write-memory* 5)
(defconstant *read-configuration* 6)
(defconstant *write-configuration* 7)
(defconstant *run-program* 8)


;;; SOFTWARE PROGRAMMER FUNCTIONS --------------------------------------------


;;; calculate the checksum of a list of numbers

(defun checksum (data)
  (mod (- 256 (mod (reduce #'+ data) 256)) 256))


;;; encode data as a byte stuffed packet with header and checksum

(defun encode-packet (data)
  (let* ((checksum (checksum data))
         (escaped (mapcan #'(lambda (value)
                              (if (member value (list *stx* *etx* *dle*))
                                (list *dle* value)
                                (list value)))
                          (concatenate 'list data (list checksum)))))
    (concatenate 'list (list *stx* *stx*) escaped (list *etx*))))


;;; decode a byte packet with a header and checksum

(defun decode-packet (packet)
  (when (and (eql *stx* (first packet))
             (eql *stx* (second packet))
             (eql *etx* (first (last packet))))
    (let ((packet (subseq packet 2 (1- (length packet))))
          (result nil))
      (loop
        (when (eql *dle* (first packet))
          (setf packet (rest packet)))
        (when (null (rest packet))
          (if (eql (first packet) (checksum result))
            (return (nreverse result))
            (error "received bad packet ~S" (nreverse result))))
        (push (first packet) result)
        (setf packet (rest packet))))))


;;; transmit a byte packet

(defun transmit-packet (data)
  (let ((packet (encode-packet data)))
    (when (some #'(lambda (datum) (> datum 255)) packet)
      (error "cannot transmit some values in ~S" packet))
    (dolist (datum packet)
      (transmit-byte datum))))


;;; receive a byte packet

(defun receive-packet (message &optional (timeout 1000000))
  (let ((result nil)
        (datum nil))
    (loop
      (setf datum (receive-byte timeout))
      (when (null datum)
        (return (or (decode-packet (nreverse result))
                    (error "~A failed" message))))
      (setf timeout 100000)
      (push datum result))))


;;; convert a list of bytes in lsb-msb order into words

(defun bytes-to-words (data)
  (mapcar #'(lambda (pair)
              (+ (* 256 (second pair)) (first pair)))
          (group-items data *bytes-per-word*)))


;;; convert a list of words into bytes in lsb-msb order

(defun words-to-bytes (data)
  (mapcan #'(lambda (word)
              (list (mod word 256) (floor word 256)))
          data))


;;; SOFTWARE PROGRAMMER METHODS ----------------------------------------------


;;; verify arguments that refer to data memory

(defmethod verify-memory ((controller controller) message address count)
  (let* ((eeprom-size (eeprom-size controller))
         (bytes-per-page (- (buffer-size controller) *command-overhead* 1)))
    (verify (>= eeprom-size (+ address count))
            "attempt to ~A past end of memory (~S ~S)" message address count)
    (verify (>= bytes-per-page count)
            "attempt to ~A too much memory (~S ~S)" message address count)))


;;; verify arguments that refer to program memory

(defmethod verify-program ((controller controller) message address count words)
  (let* ((program-size (program-size controller))
         (bytes-per-page (- (buffer-size controller) *command-overhead* 1))
         (words-per-page (floor bytes-per-page *bytes-per-word*)))
    (verify (>= program-size (+ address count))
            "attempt to ~A past end of program (~S ~S)" message address count)
    (verify (>= words-per-page count)
            "attempt to ~A too much program (~S ~S)" message address count)
    (verify (or (equal message "read") (>= address 256))
            "attempt to ~A bootloader (~S ~S)" message address count)
    (verify (zerop (mod address words))
            "must ~A program on a ~S word boundary" message words)
    (verify (zerop (mod count words))
            "must ~A program in multiples of ~S words" message words)))


;;; transmit a command to the controller and receive the response
;;; discard any noise data left in the buffer

(defmethod access-controller
  ((controller pic16f88) command message &optional count address data)
  (let ((*descriptor* (descriptor (port controller))))
    (declare (special *descriptor*))
    (loop while (receive-byte 100000))
    (transmit-packet
      (concatenate 'list
                   (list command)
                   (when count (list count))
                   (when address (list (mod address 256) (floor address 256) 0))
                   data))
    (when count
      (let ((response (receive-packet message)))
        (unless (eql command (first response))
          (error "~A response does not match"))
        response))))


;;; read firmware version

(defmethod read-version ((controller pic16f88))
  (access-controller controller
    *read-version* "read version" 2))


;;; read data memory (1 byte resolution)

(defmethod read-memory ((controller pic16f88) address count)
  (verify-memory controller "read" address count)
  (subseq (access-controller controller
            *read-memory* "read data memory" count address)
          *command-overhead*))


;;; write data memory (1 byte resolution)

(defmethod write-memory ((controller pic16f88) address data)
  (verify-memory controller "write" address (length data))
  (access-controller controller
    *write-memory* "write data memory" (length data) address data))


;;; erase data memory (1 byte resolution)

(defmethod erase-memory ((controller pic16f88) address count)
  (verify-memory controller "erase" address count)
  (access-controller controller
    *write-memory* "erase data memory" count address
    (loop for value from 1 to count collect #xFF)))


;;; read program memory (1 word resolution)

(defmethod read-program ((controller pic16f88) address count)
  (verify-program controller "read" address count 1)
  (bytes-to-words
    (subseq
      (access-controller controller
        *read-program* "read program" count address)
      *command-overhead*)))


;;; write program memory (4 word resolution)

(defmethod write-program ((controller pic16f88) address data)
  (verify-program controller "write" address (length data) *words-per-block*)
  (access-controller controller
    *write-program* "write program"
    (floor (length data) *words-per-block*) address
    (words-to-bytes data)))


;;; erase program memory (32 word resolution)

(defmethod erase-program ((controller pic16f88) address count)
  (verify-program controller "erase" address count *words-per-row*)
  (access-controller controller
    *erase-program* "erase program" (floor count *words-per-row*) address))


;;; start user program

(defmethod run-program ((controller pic16f88))
  (access-controller
    controller *run-program* "run program"))


;;; perform an optimised write and verify of one row of program memory

(defmethod update-program-row ((controller pic16f88) address new-data)
  (let ((old-data (read-program controller address *words-per-row*)))
    (unless (equal old-data new-data)
      (unless (every #'(lambda (new-word old-word)
                         (eql new-word (logand new-word old-word)))
                     new-data old-data)
        (format t "erasing row ~4,'0X~%" address)
        (erase-program controller address *words-per-row*))
      (format t "writing row ~4,'0X~%" address)
      (write-program controller address new-data)
      (verify (equal new-data (read-program controller address *words-per-row*))
              "failed to update program row"))))


;;; perform an optimised update of program memory

(defmethod update-program ((controller pic16f88) new-data)
  (when new-data
    (setf new-data (concatenate 'list new-data *padding*))
    (let ((start (position-if #'identity new-data))
          (finish (length new-data)))
      (decf start (mod start *words-per-row*))
      (decf finish (mod finish *words-per-row*))
      (setf new-data (mapcar #'(lambda (word)
                                 (or word #x3FFF))
                             (subseq new-data start finish)))
      (dolist (row (group-items new-data *words-per-row*))
        (update-program-row controller start row)
        (incf start *words-per-row*)))))



;;;===========================================================================