6502-opcodes.lisp at 249f79f3120c6dae275a48801884374b8a1f5f4d from jaoswald's cl-comfy-6502

jaoswald / cl-comfy-6502

Description:	Baker's COMFY compiler for the 6502 ported to Common Lisp edit
Homepage:	http://josephoswald.nfshost.com/comfy/summary.html edit
Public Clone URL:	git://github.com/jaoswald/cl-comfy-6502.git Give this clone URL to anyone. `git clone git://github.com/jaoswald/cl-comfy-6502.git`
Your Clone URL:	git@github.com:jaoswald/cl-comfy-6502.git Use this clone URL yourself. `git clone git@github.com:jaoswald/cl-comfy-6502.git`

Silence move macro

Joseph Oswald (author)

Tue Jun 10 14:03:17 -0700 2008

commit 249f79f3120c6dae275a48801884374b8a1f5f4d
tree 86c4b4f83ee0f17b497840efc7f308fd22f86ef2
parent fb6c51f99ea8a9f1adb300823af469231b45e800

cl-comfy-6502 / 6502-opcodes.lisp

100644 405 lines (343 sloc) 13.184 kb

raw blame history

;;;; -*- mode: Lisp; Package: ("6502" "CL"); Syntax: ANSI-Common-Lisp; -*-
;;;;
;;;; 6502-opcodes.lisp
;;;
;;;
 
;;; basic operations on 6502 machine instructions.
 
;;; representation for Common Lisp
;;; a 'symbolic opcode' is (opcode address-mode)
;;; such as ('BCS 'BRANCH-RELATIVE)
 
;;; error conditions
 
(cl:defpackage "6502" 
	       (:use "CL")
	       (:export "6502-ERROR" "BAD-ADDRESS-MODE" "BAD-OPCODE"
			"OPCODE" "ADDRESS-MODE" "SYMBOLIC-OPCODE"
			"MAKE-SYMBOLIC-OPCODE" "OPCODE-TO-BYTE"
			"ADC" "AND" "ASL" 
			"BCC" "BCS" "BEQ" "BIT" "BMI" "BNE" "BPL" "BRK" "BVC" "BVS"
			"CLC" "CLD" "CLI" "CLV" "CMP" "CPX" "CPY" 
			"DEC" "DEX" "DEY"
			"EOR" 
			"INC" "INX" "INY"
			"JMP" "JSR"
			"LDA" "LDX" "LDY" "LSR"
			"NOP"
			"ORA"
			"PHA" "PHP" "PLA" "PLP"
			"ROL" "ROR" "RTI" "RTS"
			"SBC" "SEC" "SED" "SEI" "STA" "STX" "STY"
			"TAX" "TAY" "TSX" "TXA" "TXS" "TYA"))
 
(in-package "6502")
 
; (defgeneric address-mode (object)) 
; (defgeneric (setf address-mode) (value object))
 
; Genera 8.3 will otherwise define these as Flavor accessors in define-condition,
; causing a conflict when defclass symbolic-opcode later defines them as
; CLOS generic functions
 
 
(define-condition 6502-error (error) ())
 
(define-condition bad-address-mode (6502-error) 
  ((mnemonic :reader error-mnemonic :initarg :mnemonic)
   (address-mode :reader error-address-mode :initarg :address-mode))
  (:report (lambda (condition stream)
	     (format stream "~A does not support ~A address mode."
		     (error-mnemonic condition)
		     (error-address-mode condition)))))
 
(define-condition bad-opcode (6502-error) 
  ((mnemonic :reader error-mnemonic :initarg :mnemonic))
  (:report (lambda (condition stream)
	     (format stream "~A is not a valid 6502 mnemonic"
		     (error-mnemonic condition)))))
 
 
;;; 6502 machine code primitives
 
(defclass symbolic-opcode ()
  ((address-mode :initarg :address-mode :accessor address-mode)
   (opcode :initarg :opcode :accessor opcode)))
 
(defun make-symbolic-opcode (opcode address-mode)
  (unless (member address-mode
		  '(nil :BRANCH-RELATIVE :IMMEDIATE :ACCUMULATOR
			:IMPLIED :ABSOLUTE :ABSOLUTE-INDIRECT
			:ZERO-PAGE
			:ZERO-PAGE-X :ABSOLUTE-X :ZERO-PAGE-Y
			:ZP-X-INDIRECT :ZP-INDIRECT-Y :ABSOLUTE-Y))
    (error 'bad-address-mode :mnemonic opcode 
	   :address-mode address-mode))
  (make-instance 'symbolic-opcode :opcode opcode :address-mode address-mode))
 
(defparameter *opcode-print-mode* :DEFAULT)
 
(defmethod print-object ((obj symbolic-opcode) stream)
  (case *opcode-print-mode*
    (:DEFAULT (print-unreadable-object (obj stream)
		(case (address-mode obj)
		  ((:BRANCH-RELATIVE :IMPLIED) (format stream "~A" (opcode obj)))
		  (t (format stream "~A ~A" (opcode obj) (address-mode obj))))))
    (t (format stream obj))))
 
(defvar +branch-opcodes+ '(BCS BCC BEQ BNE BVS BVC BMI BPL))
 
(setf (get 'BCS 'opcode) 176)
(setf (get 'BCC 'opcode) 144)
(setf (get 'BEQ 'opcode) 240)
(setf (get 'BNE 'opcode) 208)
(setf (get 'BVS 'opcode) 112)
(setf (get 'BVC 'opcode) 80)
(setf (get 'BMI 'opcode) 48)
(setf (get 'BPL 'opcode) 16)
 
 
(defun branch-opcode-to-byte (symbolic-opcode)
  (let ((op (opcode symbolic-opcode))
	(am (address-mode symbolic-opcode)))
    (unless (or (null am) (eq am :BRANCH-RELATIVE))
      (error 'bad-address-mode :mnemonic op :address-mode am))
    (if (member op +branch-opcodes+)
	(get op 'opcode)
	(error 'bad-opcode :mnemonic op))))
 
(defvar +implied-opcodes+ '(NOP BRK PHP PHA PLA PLP CLC SEC CLI SEI CLD SED CLV
				INX INY DEX DEY RTS RTI TXA TAX TYA TAY TXS TSX))
 
(setf (get 'BRK 'opcode) 0)
(setf (get 'NOP 'opcode) 234)
(setf (get 'PHP 'opcode) 8)
(setf (get 'PLP 'opcode) 40)
(setf (get 'PHA 'opcode) 72)
(setf (get 'PLA 'opcode) 104)
(setf (get 'CLC 'opcode) 24)
(setf (get 'SEC 'opcode) 56)
(setf (get 'CLV 'opcode) 184)
(setf (get 'CLI 'opcode) 88)
(setf (get 'SEI 'opcode) 120)
(setf (get 'CLD 'opcode) 216)
(setf (get 'SED 'opcode) 248)
(setf (get 'DEX 'opcode) 202)
(setf (get 'DEY 'opcode) 136)
(setf (get 'INX 'opcode) 232)
(setf (get 'INY 'opcode) 200)
(setf (get 'RTS 'opcode) 96)
(setf (get 'RTI 'opcode) 64)
(setf (get 'TAX 'opcode) 170)
(setf (get 'TXA 'opcode) 138)
(setf (get 'TAY 'opcode) 168)
(setf (get 'TYA 'opcode) 152)
(setf (get 'TXS 'opcode) 154)
(setf (get 'TSX 'opcode) 186)
 
(defun implied-opcode-to-byte (symbolic-opcode)
  (let ((op (opcode symbolic-opcode))
	(am (address-mode symbolic-opcode)))
    (unless (or (null am) (eq am :IMPLIED))
      (error 'bad-address-mode :mnemonic op :address-mode am))
    (if (member op +implied-opcodes+)
	(get op 'opcode)
	(error 'bad-opcode :mnemonic op))))
  
;;; "accumulator" instructions
;;; accumulator is an implied argument, allows 
;;; immediate, absolute, absolute,x, absolute,y
;;; zero-page, zero-page,x
;;; (zero-page,x) (zero-page),y 
;;;
;;; special case: STA immediate is invalid (acts as a NOP)
 
(defvar +accumulator-opcodes+ '(ORA AND EOR ADC STA LDA CMP SBC))
 
;; "basic" opcode for accumulator is ABSOLUTE
 
(setf (get 'STA 'opcode) 141)
(setf (get 'LDA 'opcode) 173)
(setf (get 'ORA 'opcode) 13)
(setf (get 'ADC 'opcode) 109)
(setf (get 'SBC 'opcode) 237)
(setf (get 'EOR 'opcode) 77)
(setf (get 'CMP 'opcode) 205)
(setf (get 'AND 'opcode) 45)
 
(defun accumulator-opcode-to-byte (symbolic-opcode)
  (let ((op (opcode symbolic-opcode))
	(am (address-mode symbolic-opcode)))
    (unless (member op +accumulator-opcodes+)
      (error 'bad-opcode :mnemonic op))
    (unless am
      (error 'bad-address-mode :mnemonic op :address-mode am))
    (let ((skel (get op 'opcode)))
      (unless skel (error "Missing 6502:OPCODE property on %s" op))
      (cond 
	((eq am :IMMEDIATE)
	 (when (eq op 'STA)
	   (error 'bad-address-mode :mnemonic op :address-mode am))
	 (- skel 4))
	((eq am :ABSOLUTE)      skel)
	((eq am :ABSOLUTE-X)    (+ skel 16))
	((eq am :ABSOLUTE-Y)    (+ skel 12))
	((eq am :ZERO-PAGE)     (- skel 8))
	((eq am :ZERO-PAGE-X)   (+ skel 8))
	((eq am :ZP-X-INDIRECT) (- skel 12))
	((eq am :ZP-INDIRECT-Y) (+ skel 4))
	(t (error 'bad-address-mode :mnemonic op :address-mode am))))))
 
 
;; shift/rotate opcodes
;; can act on accumulator *or* memory
;; accumulator, absolute, absolute-x, zero-page, zero-page-x
;; for convenience, probably should not require explicit ACCUMULATOR
;; address mode, but will for now
 
(defvar +shift/rotate-opcodes+ '(ASL LSR ROL ROR))
 
;; "base" opcode is absolute
 
(setf (get 'ASL 'opcode) 14)
(setf (get 'LSR 'opcode) 78)
(setf (get 'ROL 'opcode) 46)
(setf (get 'ROR 'opcode) 110)
 
(defun shift/rotate-opcode-to-byte (symbolic-opcode)
  (let ((op (opcode symbolic-opcode))
	(am (address-mode symbolic-opcode)))
    (unless (member op +shift/rotate-opcodes+)
      (error 'bad-opcode :mnemonic op))
    (unless am
      (error 'bad-address-mode :mnemonic op :address-mode am))
    (let ((skel (get op 'opcode)))
      (unless skel (error "Missing OPCODE property on %s" op))
      (cond 
	((eq am :ABSOLUTE)      skel)
	((eq am :ACCUMULATOR)   (- skel 4))
	((eq am :ABSOLUTE-X)    (+ skel 16))
	((eq am :ZERO-PAGE)     (- skel 8))
	((eq am :ZERO-PAGE-X)   (+ skel 8))
	(t (error 'bad-address-mode :mnemonic op :address-mode am))))))
 
 
;; inc/dec opcodes
;; can act only on memory
;; absolute, absolute-x, zero-page, zero-page-x
;; for convenience, probably should not require explicit ACCUMULATOR
;; address mode, but will for now
 
(defvar +inc/dec-opcodes+ '(INC DEC))
 
;; "base" opcode is absolute
 
(setf (get 'INC 'opcode) 238)
(setf (get 'DEC 'opcode) 206)
 
(defun inc/dec-opcode-to-byte (symbolic-opcode)
  (let ((op (opcode symbolic-opcode))
	(am (address-mode symbolic-opcode)))
    (unless (member op +inc/dec-opcodes+)
      (error 'bad-opcode :mnemonic op))
    (unless am
      (error 'bad-address-mode :mnemonic op :address-mode am))
    (let ((skel (get op 'opcode)))
      (unless skel (error "Missing OPCODE property on %s" op))
      (cond 
	((eq am :ABSOLUTE)      skel)
	((eq am :ABSOLUTE-X)    (+ skel 16))
	((eq am :ZERO-PAGE)     (- skel 8))
	((eq am :ZERO-PAGE-X)   (+ skel 8))
	(t (error 'bad-address-mode :mnemonic op :address-mode am))))))
 
(setf (get 'BIT 'opcode) 44)
 
;; BIT only zero-page, absolute
 
(defun bit-opcode-to-byte (symbolic-opcode)
  (let ((op (opcode symbolic-opcode))
	(am (address-mode symbolic-opcode)))
    (unless (eq op 'BIT)
      (error 'bad-opcode :mnemonic op))
    (unless am
      (error 'bad-address-mode :mnemonic op :address-mode am))
    (let ((skel (get op 'opcode)))
      (unless skel (error "Missing OPCODE property on %s" op))
      (cond 
	((eq am :ABSOLUTE)      skel)
	((eq am :ZERO-PAGE)     (- skel 8))
	(t (error 'bad-address-mode :mnemonic op :address-mode am))))))
 
 
;;; JMP only absolute, indirect
 
(setf (get 'JMP 'opcode) 76)
 
(defun jmp-opcode-to-byte (symbolic-opcode)
  (let ((op (opcode symbolic-opcode))
	(am (address-mode symbolic-opcode)))
    (unless (eq op 'JMP)
      (error 'bad-opcode :mnemonic op))
    (unless am
      (error 'bad-address-mode :mnemonic op :address-mode am))
    (let ((skel (get op 'opcode)))
      (unless skel (error "Missing OPCODE property on %s" op))
      (cond 
	((eq am :ABSOLUTE)          skel)
	((eq am :ABSOLUTE-INDIRECT) (+ skel 32))
	(t (error 'bad-address-mode :mnemonic op :address-mode am))))))
 
;;; JSR only absolute
 
(setf (get 'JSR 'opcode) 32)
 
(defun jsr-opcode-to-byte (symbolic-opcode)
  (let ((op (opcode symbolic-opcode))
	(am (address-mode symbolic-opcode)))
    (unless (eq op 'JSR)
      (error 'bad-opcode :mnemonic op))
    (unless am
      (error 'bad-address-mode :mnemonic op :address-mode am))
    (let ((skel (get op 'opcode)))
      (unless skel (error "Missing OPCODE property on %s" op))
      (cond 
	((eq am :ABSOLUTE)          skel)
	(t (error 'bad-address-mode :mnemonic op :address-mode am))))))
 
;;; index register opcodes
;; cpx, cpy, stx, sty, ldx, ldy
 
(defvar +compare-index-opcodes+ '(CPX CPY))
 
(setf (get 'CPX 'opcode) 236)
(setf (get 'CPY 'opcode) 204)
 
(defun compare-index-opcode-to-byte (symbolic-opcode)
  (let ((op (opcode symbolic-opcode))
	(am (address-mode symbolic-opcode)))
    (unless (member op +compare-index-opcodes+)
      (error 'bad-opcode :mnemonic op))
    (unless am
      (error 'bad-address-mode :mnemonic op :address-mode am))
    (let ((skel (get op 'opcode)))
      (unless skel (error "Missing OPCODE property on %s" op))
      (cond 
	((eq am :ABSOLUTE)  skel)
	((eq am :IMMEDIATE) (- skel 12))
	((eq am :ZERO-PAGE) (- skel 8))
	(t (error 'bad-address-mode :mnemonic op :address-mode am))))))
 
(defvar +store-index-opcodes+ '(STX STY))
 
(setf (get 'STX 'opcode) 142)
(setf (get 'STY 'opcode) 140)
 
(defun store-index-opcode-to-byte (symbolic-opcode)
  (let ((op (opcode symbolic-opcode))
	(am (address-mode symbolic-opcode)))
    (unless (member op +store-index-opcodes+)
      (error 'bad-opcode :mnemonic op))
    (unless am
      (error 'bad-address-mode :mnemonic op :address-mode am))
    (let ((skel (get op 'opcode)))
      (unless skel (error "Missing OPCODE property on %s" op))
      (cond 
	((eq am :ABSOLUTE)  skel)
	((eq am :ZERO-PAGE) (- skel 8))
	((or (and (eq op 'STX) (eq am :ZERO-PAGE-Y))
	     (and (eq op 'STY) (eq am :ZERO-PAGE-X)))
	 (+ skel 8))
	(t (error 'bad-address-mode :mnemonic op :address-mode am))))))
 
(defvar +load-index-opcodes+ '(LDX LDY))
 
(setf (get 'LDX 'opcode) 174)
(setf (get 'LDY 'opcode) 172)
 
(defun load-index-opcode-to-byte (symbolic-opcode)
  (let ((op (opcode symbolic-opcode))
	(am (address-mode symbolic-opcode)))
    (unless (member op +load-index-opcodes+)
      (error 'bad-opcode :mnemonic op))
    (unless am
      (error 'bad-address-mode :mnemonic op :address-mode am))
    (let ((skel (get op 'opcode)))
      (unless skel (error "Missing OPCODE property on %s" op))
      (cond 
	((eq am :ABSOLUTE)   skel)
	((eq am :IMMEDIATE)  (- skel 12))
	((eq am :ZERO-PAGE)  (- skel 8))
	((or (and (eq op 'LDX) (eq am :ABSOLUTE-Y))
	     (and (eq op 'LDY) (eq am :ABSOLUTE-X)))
	 (+ skel 16))
	((or (and (eq op 'LDX) (eq am :ZERO-PAGE-Y))
	     (and (eq op 'LDY) (eq am :ZERO-PAGE-X)))
	 (+ skel 8))
	(t (error 'bad-address-mode :mnemonic op :address-mode am))))))
 
(defun opcode-to-byte (symbolic-opcode)
  (let ((op (opcode symbolic-opcode)))
    (cond 
      ((member op +branch-opcodes+)
       (branch-opcode-to-byte symbolic-opcode))
      ((member op +implied-opcodes+)
       (implied-opcode-to-byte symbolic-opcode))
      ((member op +accumulator-opcodes+)
       (accumulator-opcode-to-byte symbolic-opcode))
      ((member op +shift/rotate-opcodes+)
       (shift/rotate-opcode-to-byte symbolic-opcode))
      ((member op +inc/dec-opcodes+)
       (inc/dec-opcode-to-byte symbolic-opcode))
      ((member op +compare-index-opcodes+)
       (compare-index-opcode-to-byte symbolic-opcode))
      ((member op +load-index-opcodes+)
       (load-index-opcode-to-byte symbolic-opcode))
      ((member op +store-index-opcodes+)
       (store-index-opcode-to-byte symbolic-opcode))
      ((eq op 'BIT)
       (bit-opcode-to-byte symbolic-opcode))
      ((eq op 'JMP)
       (jmp-opcode-to-byte symbolic-opcode))
      ((eq op 'JSR)
       (jsr-opcode-to-byte symbolic-opcode))
      (t (error 'bad-opcode :mnemonic symbolic-opcode)))))