#| -*-Scheme-*-

$Id: dassm3.scm,v 4.11 2003/02/14 18:28:02 cph Exp $

Copyright (c) 1987, 1988, 1989, 1990, 1999 Massachusetts Institute of Technology

This file is part of MIT/GNU Scheme.

MIT/GNU Scheme 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.

MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
USA.

|#

;;;; 68000 Disassembler: Internals

(declare (usual-integrations))

(define opcode-dispatch
  (vector (lambda ()
	    ((vector-ref bit-manipulation/MOVEP/immediate-dispatch
			 (extract *ir 8 12))))
	  (lambda () %MOVE-byte)
	  (lambda () %MOVE-long)
	  (lambda () %MOVE-word)
	  (lambda ()
	    ((vector-ref miscellaneous-dispatch (extract *ir 8 12))))
	  (lambda ()
	    (if (= (extract *ir 6 8) #b11)
		(if (= (extract *ir 3 6) #b001)
		    %DBcc
		    %Scc)
		(if (= (extract *ir 8 9) #b0)
		    %ADDQ
		    %SUBQ)))
	  (lambda () %Bcc/%BSR)
	  (lambda ()
	    (if (= (extract *ir 8 9) #b0)
		%MOVEQ
		undefined-instruction))
	  (lambda ()
	    (let ((size (extract *ir 6 8)))
	      (cond ((= size #b00)
		     (if (= (extract *ir 4 6) #b00)
			 %SBCD
			 %OR))
		    ((= size #b11) %DIV)
		    (else %OR))))
	  (lambda ()
	    (if (= (extract *ir 6 8) #b11)
		%SUBA
		(if (and (= (extract *ir 8 9) #b1)
			 (= (extract *ir 4 6) #b00))
		    %SUBX
		    %SUB)))
	  undefined
	  (lambda ()
	    (if (= (extract *ir 6 8) #b11)
		%CMPA
		(if (= (extract *ir 8 9) 0)
		    %CMP
		    (if (= (extract *ir 3 6) #b001)
			%CMPM
			%EOR))))
	  (lambda ()
	    (let ((size (extract *ir 6 8)))
	      (cond ((= size #b00)
		     (if (= (extract *ir 4 6) #b00)
			 %ABCD
			 %AND))
		    ((= size #b01)
		     (if (= (extract *ir 4 6) #b00)
			 %EXG
			 %AND))
		    ((= size #b10)
		     (if (= (extract *ir 3 6) #b001)
			 %EXGM
			 %AND))
		    (else %MUL))))
	  (lambda ()
	    (if (= (extract *ir 6 8) #b11)
		%ADDA
		(if (and (= (extract *ir 8 9) #b1)
			 (= (extract *ir 4 6) #b00))
		    %ADDX
		    %ADD)))
	  (lambda () shift/rotate/bitop)
	  (lambda () coprocessor)))

;;;; Operations

(define bit-manipulation/MOVEP/immediate-dispatch
  (let ((ORI (lambda () %ORI))
	(ANDI (lambda () %ANDI))
	(SUBI (lambda () %SUBI))
	(ADDI (lambda () %ADDI))
	(EORI (lambda () %EORI))
	(CMPI (lambda () %CMPI))
	(dynamic-bit/MOVEP
	 (lambda ()
	   (if (= (extract *ir 3 6) 1)
	       %MOVEP
	       dynamic-bit)))
	(static-bit (lambda () static-bit)))
    (vector ORI
	    dynamic-bit/MOVEP
	    ANDI
	    dynamic-bit/MOVEP
	    SUBI
	    dynamic-bit/MOVEP
	    ADDI
	    dynamic-bit/MOVEP
	    static-bit
	    dynamic-bit/MOVEP
	    EORI
	    dynamic-bit/MOVEP
	    CMPI
	    dynamic-bit/MOVEP
	    undefined
	    dynamic-bit/MOVEP)))

(define (dynamic-bit)
  `(,(decode-bit (extract *ir 6 8))
    ,(make-data-register 'D (extract *ir 9 12))
    ,(decode-ea-d&a)))

(define (static-bit)
  (let ((ea (decode-ea-d&a)))
    `(,(decode-bit (extract *ir 6 8))
      (& ,(fetch-immediate 'B))
      ,ea)))

(define (%MOVEP)
  `(MOVEP ,(decode-wl (extract *ir 6 7))
	  ,@(let ((data-register (extract *ir 9 12))
		  (address-register (extract *ir 0 3))
		  (offset (bit-string->signed-integer (get-word))))
	      (if (zero? (extract *ir 7 8))
		  `(,(make-address-offset address-register offset)
		    ,(make-data-register 'D data-register))
		  `(,(make-data-register 'D data-register)
		    ,(make-address-offset address-register offset))))))


(define ((logical-immediate keyword))
  (let ((size (decode-bwl (extract *ir 6 8))))
    (cond ((null? size)
	   (undefined-instruction))
	  ((= (extract *ir 0 6) #b111100)
	   (if (eq? size 'L)
	       (undefined-instruction)
	       `(,keyword ,size (& ,(fetch-immediate size)) (SR))))
	  (else
	   (let ((immediate (fetch-immediate size)))
	     `(,keyword ,size (& ,immediate) ,(decode-ea-d&a)))))))

(define %ORI (logical-immediate 'ORI))
(define %ANDI (logical-immediate 'ANDI))
(define %EORI (logical-immediate 'EORI))

(define ((arithmetic-immediate keyword))
  (let ((size (decode-bwl (extract *ir 6 8))))
    (if (null? size)
	(undefined-instruction)
	(let ((immediate (fetch-immediate size)))
	  `(,keyword ,size (& ,immediate) ,(decode-ea-d&a))))))

(define %SUBI (arithmetic-immediate 'SUBI))
(define %ADDI (arithmetic-immediate 'ADDI))
(define %CMPI (arithmetic-immediate 'CMPI))

(define ((%MOVE size))
  (let ((sea (decode-ea-b=>-A size)))
    (let ((dea (decode-ea-MOVE-destination size)))
      `(MOVE ,size ,sea ,dea))))

(define %MOVE-byte (%MOVE 'B))
(define %MOVE-word (%MOVE 'W))
(define %MOVE-long (%MOVE 'L))

(define miscellaneous-dispatch
  (let ((NEGX/MOVE<-SR
	 (lambda ()
	   (if (= (extract *ir 6 8) #b11) %MOVE<-SR %NEGX)))
	(CLR (lambda () %CLR))
	(NEG/MOVE->CCR
	 (lambda ()
	   (if (= (extract *ir 6 8) #b11) %MOVE->CCR %NEG)))
	(NOT/MOVE->SR
	 (lambda ()
	   (if (= (extract *ir 6 8) #b11) %MOVE->SR %NOT)))
	(NBCD/PEA/SWAP/MOVEM-registers->ea/EXT
	 (lambda ()
	   (if (= (extract *ir 7 8) 0)
	       (if (= (extract *ir 6 7) 0)
		   %NBCD
		   (if (= (extract *ir 3 6) 0)
		       %SWAP
		       %PEA))
	       (if (= (extract *ir 3 6) 0)
		   %EXT
		   %MOVEM-registers->ea))))
	(TST/TAS/illegal
	 (lambda ()
	   (if (not (= (extract *ir 6 8) #b11))
	       %TST
	       (if (not (= (extract *ir 0 6) #b111100))
		   %TAS
		   %ILLEGAL))))
	(MULL/DIVL/MOVEM-ea->registers
	 (lambda ()
	   (case (extract *ir 6 8)
	     ((#b00) %MULL)
	     ((#b01) %DIVL)
	     ((#b11) %MOVEM-ea->registers)
	     (else undefined-instruction))))
	(all-the-rest
	 (lambda ()
	   ((vector-ref all-the-rest-dispatch (extract *ir 6 8)))))
	(CHK/LEA
	 (lambda ()
	   ((vector-ref CHK/LEA-dispatch (extract *ir 6 8))))))
    (vector NEGX/MOVE<-SR
	    CHK/LEA
	    CLR
	    CHK/LEA
	    NEG/MOVE->CCR
	    CHK/LEA
	    NOT/MOVE->SR
	    CHK/LEA
	    NBCD/PEA/SWAP/MOVEM-registers->ea/EXT
	    CHK/LEA
	    TST/TAS/illegal
	    CHK/LEA
	    MULL/DIVL/MOVEM-ea->registers
	    CHK/LEA
	    all-the-rest
	    CHK/LEA)))

(define all-the-rest-dispatch
  (vector undefined
	  (lambda () ((vector-ref all-the-rest-1-dispatch (extract *ir 3 6))))
	  (lambda () %JSR)
	  (lambda () %JMP)))

(define all-the-rest-1-dispatch
  (vector (lambda () %TRAP)
	  (lambda () %TRAP)
	  (lambda () %LINK)
	  (lambda () %UNLK)
	  (lambda () %MOVE->USP)
	  (lambda () %MOVE<-USP)
	  (lambda ()
	    (let ((register (extract *ir 0 3)))
	      (if (= register #b100)
		  undefined-instruction
		  (lambda ()
		    `(,(vector-ref #(RESET NOP STOP RTE () RTS TRAPV RTR)
				   register))))))
	  undefined))

(define ((single-ea-d&a keyword))
  `(,keyword ,(decode-bwl (extract *ir 6 8))
	     ,(decode-ea-d&a)))

(define %NEGX (single-ea-d&a 'NEGX))
(define %CLR (single-ea-d&a 'CLR))
(define %NEG (single-ea-d&a 'NEG))
(define %NOT (single-ea-d&a 'NOT))
(define %TST (single-ea-d&a 'TST))


(define (%MOVE<-SR)
  `(MOVE W (SR) ,(decode-ea-d&a)))

(define (%MOVE->CCR)
  `(MOVE W ,(decode-ea-d 'W) (CCR)))

(define (%MOVE->SR)
  `(MOVE W ,(decode-ea-d 'W) (SR)))

(define (%NBCD)
  `(NBCD ,(decode-ea-d&a)))

(define (%SWAP)
  `(SWAP ,(make-data-register 'D (extract *ir 0 3))))

(define (%PEA)
  `(PEA ,(decode-ea-c)))

(define (%EXT)
  `(EXT ,(decode-wl (extract *ir 6 7))
	,(make-data-register 'D (extract *ir 0 3))))

(define (%TAS)
  `(TAS B ,(decode-ea-d&a)))

(define (%ILLEGAL)
  '(ILLEGAL))

(define (%TRAP)
  `(TRAP (& ,(extract *ir 0 4))))

(define (%LINK)
  `(LINK ,(make-address-register 'A (extract *ir 0 3))))

(define (%UNLK)
  `(UNLK ,(make-address-register 'A (extract *ir 0 3))))

(define (%MOVE->USP)
  `(MOVE L ,(make-address-register 'A (extract *ir 0 3)) (USP)))

(define (%MOVE<-USP)
  `(MOVE L (USP) ,(make-address-register 'A (extract *ir 0 3))))

(define (%JSR)
  `(JSR ,(decode-ea-c)))

(define (%JMP)
  `(JMP ,(decode-ea-c)))

(define (%MOVEM-registers->ea)
  (let ((mode (extract *ir 3 6))
	(size (decode-wl (extract *ir 6 7))))
    (if (= mode 4)
	`(MOVEM ,size
		,(decode-@-aregister-list (get-word))
		(make-address-register '@-A (extract *ir 0 3)))
	(let ((ea (decode-ea-c)))
	  `(MOVEM ,size
		  ,(decode-c@a+register-list (get-word))
		  ,ea)))))

(define (%MOVEM-ea->registers)
  (let ((mode (extract *ir 3 6))
	(size (decode-wl (extract *ir 6 7))))
    (let ((ea (if (= mode #b011)
		  (make-address-register '@A+ (extract *ir 0 3))
		  (decode-ea-c&a size))))
      `(MOVEM ,size ,ea ,(decode-c@a+register-list (get-word))))))

(define (decode-@-aregister-list word)
  (define (loop n registers)
    (if (null? registers)
	'()
	(if (zero? (bit-string-ref word n))
	    (loop (1+ n) (cdr registers))
	    (cons (car registers)
		  (loop (1+ n) (cdr registers))))))
  (loop 0 '(A7 A6 A5 A4 A3 A2 A1 A0 D7 D6 D5 D4 D3 D2 D1 D0)))

(define (decode-c@a+register-list word)
  (define (loop n registers)
    (if (null? registers)
	'()
	(if (zero? (bit-string-ref word n))
	    (loop (1+ n) (cdr registers))
	    (cons (car registers)
		  (loop (1+ n) (cdr registers))))))
  (loop 0 '(D0 D1 D2 D3 D4 D5 D6 D7 A0 A1 A2 A3 A4 A5 A6 A7)))

(define CHK/LEA-dispatch
  (vector undefined
	  undefined
	  (lambda () %CHK)
	  (lambda () %LEA)))

(define (%CHK)
  `(CHK ,(decode-ea-d 'W)
	,(make-data-register 'D (extract *ir 9 12))))

(define (%LEA)
  `(LEA ,(decode-ea-c)
	,(make-address-register 'A (extract *ir 9 12))))

(define (%Scc)
  `(S ,(decode-cc (extract *ir 8 12))
      ,(decode-ea-d&a)))

(define (%DBcc)
  `(DB ,(decode-cc (extract *ir 8 12))
       ,(make-data-register 'D (extract *ir 0 3))
       ,(make-pc-relative (lambda () (fetch-immediate 'W)))))

(define (%Bcc/%BSR)
  (let ((cc (decode-cc (extract *ir 8 12)))
	(displacement (extract+ *ir 0 8)))
    ((access append ())
     (cond ((eq? cc 'T) '(BRA))
	   ((eq? cc 'F) '(BSR))
	   (else `(B , cc)))
     (cond ((= displacement 0)
	    `(W ,(make-pc-relative (lambda () (fetch-immediate 'W)))))
	   ((= displacement -1)
	    `(L ,(make-pc-relative (lambda () (fetch-immediate 'L)))))
	   (else
	    `(B ,(make-pc-relative (lambda () displacement))))))))

(define (%MOVEQ)
  `(MOVEQ (& ,(extract+ *ir 0 8))
	  ,(make-data-register 'D (extract *ir 9 12))))

(define ((logical keyword))
  (let ((size (decode-bwl (extract *ir 6 8)))
	(register (extract *ir 9 12)))
    (if (= (extract *ir 8 9) #b0)
	`(,keyword ,size
		   ,(decode-ea-d size)
		   ,(make-data-register 'D register))
	`(,keyword ,size
		   ,(make-data-register 'D register)
		   ,(decode-ea-m&a)))))

(define %OR (logical 'OR))
(define %AND (logical 'AND))

(define (%EOR)
  `(EOR ,(decode-bwl (extract *ir 6 8))
	,(make-data-register 'D (extract *ir 9 12))
	,(decode-ea-d&a)))

(define ((binary keyword))
  (let ((size (decode-bwl (extract *ir 6 8)))
	(register (extract *ir 9 12)))
    (if (= (extract *ir 8 9) #b0)
	`(,keyword ,size
		   ,(decode-ea-b=>-A size)
		   ,(make-data-register 'D register))
	`(,keyword ,size
		   ,(make-data-register 'D register)
		   ,(decode-ea-m&a)))))

(define %ADD (binary 'ADD))
(define %SUB (binary 'SUB))

(define (%CMP)
  (let ((size (decode-bwl (extract *ir 6 8))))
    `(CMP ,size
	  ,(decode-ea-b=>-A size)
	  ,(make-data-register 'D (extract *ir 9 12)))))

(define ((binary-address keyword))
  (let ((size (decode-wl (extract *ir 8 9))))
    `(,keyword ,size
	       ,(decode-ea-all size)
	       ,(make-address-register 'A (extract *ir 9 12)))))

(define %ADDA (binary-address 'ADD))
(define %SUBA (binary-address 'SUB))
(define %CMPA (binary-address 'CMP))

(define ((binary-extended keyword))
  (define (receiver mode maker)
    `(,keyword ,(decode-bwl (extract *ir 6 8))
	       ,(maker mode (extract *ir 0 3))
	       ,(maker mode (extract *ir 9 12))))
  (if (= (extract *ir 3 4) #b0) 
      (receiver 'D make-data-register)
      (receiver '@-A make-address-register)))

(define %ADDX (binary-extended 'ADDX))
(define %SUBX (binary-extended 'SUBX))

(define (%CMPM)
  `(CMPM ,(decode-bwl (extract *ir 6 8))
	 ,(make-address-register '@A+ (extract *ir 0 3))
	 ,(make-address-register '@A+ (extract *ir 9 12))))

(define ((binary-quick keyword))
  (let ((size (decode-bwl (extract *ir 6 8))))
    `(,keyword ,size
	       (& ,(let ((n (extract *ir 9 12)))
		     (if (zero? n) 8 n)))
	       ,(decode-ea-a&<b=>-A> size))))

(define %ADDQ (binary-quick 'ADDQ))
(define %SUBQ (binary-quick 'SUBQ))

(define ((decimal keyword))
  (define (receiver mode maker)
    `(,keyword ,(maker mode (extract *ir 0 3))
	       ,(maker mode (extract *ir 9 12))))
  (if (= (extract *ir 3 4) #b0)
      (receiver 'D make-data-register)
      (receiver '@A- make-address-register)))

(define %ABCD (decimal 'ABCD))
(define %SBCD (decimal 'SBCD))

(define ((%MUL/%DIV keyword))
  `(,keyword ,(decode-us (extract *ir 8 9))
	     W
	     ,(decode-ea-d 'W)
	     ,(make-data-register 'D (extract *ir 9 12))))

(define %MUL (%MUL/%DIV 'MUL))
(define %DIV (%MUL/%DIV 'DIV))

(define ((%MULL/%DIVL force-short? keyword1 keyword2))
  (let ((next (get-word)))
    (let ((dr (extract next 0 3))
	  (dq (extract next 12 15)))
      (cond ((= (extract next 10 11) #b1)
	     `(,keyword1 ,(decode-us (extract next 11 12))
			 L
			 ,(decode-ea-d 'L)
			 ,(make-data-register 'D dr)
			 ,(make-data-register 'D dq)))
	    ((or force-short? (= dr dq))
	     `(,keyword1 ,(decode-us (extract next 11 12))
			 L
			 ,(decode-ea-d 'L)
			 ,(make-data-register 'D dq)))
	    (else
	     `(,keyword2 ,(decode-us (extract next 11 12))
			 L
			 ,(decode-ea-d 'L)
			 ,(make-data-register 'D dr)
			 ,(make-data-register 'D dq)))))))

(define %MULL (%MULL/%DIVL true 'MUL 'MULL))
(define %DIVL (%MULL/%DIVL false 'DIV 'DIVL))

(define (%EXG)
  (let ((mode (if (= (extract *ir 3 4) #b0) 'D 'A)))
    `(EXG (,mode ,(extract *ir 0 3))
	  (,mode ,(extract *ir 9 12)))))

(define (%EXGM)
  `(EXG ,(make-address-register 'A (extract *ir 0 3))
	,(make-data-register 'D (extract *ir 9 12))))

(define (shift/rotate/bitop)
  (if (= #b11 (extract *ir 6 8))
      (bit-extract)
      (shift-rotate)))

(define (shift-rotate)
  (let ((size (decode-bwl (extract *ir 6 8)))
	(direction (decode-rl (extract *ir 8 9))))
    (if (null? size)
	`(,(decode-shift-type (extract *ir 9 11))
	  ,direction
	  ,(decode-ea-m&a))
	`(,(decode-shift-type (extract *ir 3 5))
	  ,direction
	  ,size
	  ,(if (= (extract *ir 5 6) #b0)
	       `(& ,(let ((n (extract *ir 9 12)))
		      (if (zero? n) 8 n)))
	       `,(make-data-register 'D (extract *ir 9 12)))
	  ,(make-data-register 'D (extract *ir 0 3))))))

(define (bit-extract)
  (let* ((opcode (decode-bf (extract *ir 8 11)))
	 (extension (get-word))
	 (source (decode-ea-m&d)))
    (let ((target (if (memq opcode '(BFEXTS BFEXTU BFFFO BFINS))
		      `(,(make-data-register 'D
					     (extract extension 12 15)))
		      '()))
	  (offset (if (= #b0 (extract extension 11 12))
		      `(& ,(extract extension 6 11))
		      (make-data-register 'D (extract extension 6 9))))
	  (width (if (= #b0 (extract extension 5 6))
		     `(& ,(extract extension 0 5))
		     (make-data-register 'D (extract extension 0 3)))))
      `(,opcode ,source ,offset ,width ,@target))))

;;;
;;; COPROCESSOR
;;;

(define (coprocessor)
  (if (= (coprocessor-id) floating-point-coprocessor-id)
      (floating-point-coprocessor)
      (undefined-instruction)))

;;;
;;; FLOATING POINT INSTRUCTIONS
;;;

(define floating-point-coprocessor-id #b001)

(define (coprocessor-id)
  (extract *ir 9 12))

(define (floating-point-coprocessor)
  (let* ((op-class-indicator (extract *ir 6 9))
	 (opcode (extract (peek-word) 0 7)))
    (cond ((and (= op-class-indicator #b000)
		(= opcode #b0000000))
	   (let ((ext (get-word)))
	     (let ((keyword (get-fmove-keyword *ir ext)))
	       (if (null? keyword)
		   (undefined-instruction)
		   (case keyword
		     (FMOVE-TO-FP
		      (decode-ordinary-floating-instruction 'FMOVE ext))
		     (FMOVE-FROM-FP
		      (let ((dst-fmt (floating-specifier->mnemonic
				      (extract ext 10 13)))
			    (src-reg (extract ext 7 10)))
			(if (eq? dst-fmt 'P)
			    '(FMOVE packed decimal)
			    `(FMOVE ,dst-fmt
				    (FP ,src-reg)
				    ,(decode-ea-d 'L)))))
		     (FMOVE-FPcr
		      (let ((reg
			     (cdr (assoc (extract ext 10 13) 
					 '((#b001 . FPIAR)
					   (#b010 . FPSR)
					   (#b100 . FPCR))))))
			(if (= (extract ext 13 14) 1)
			    `(FMOVE ,reg ,(decode-ea-d 'L))
			    `(FMOVE ,(decode-ea-d 'L) ,reg))))
		     (FMOVECR
		      `(FMOVECR X (& ,(extract ext 0 7))
				(FP ,(extract ext 7 10))))
		     (FMOVEM-FPn
		      '(FMOVEM to FP-s))
		     (FMOVEM-FPcr
		      '(FMOVEM to CR-s)))))))
	  ((= op-class-indicator #b000)
	   (let ((ext (get-word))
		 (opcode-name (floating-opcode->mnemonic opcode)))
	     (decode-ordinary-floating-instruction opcode-name ext)))
	  ((= (extract *ir 7 9) #b01)
	   (let ((float-cc (decode-float-cc (extract *ir 0 6)))
		 (size (extract *ir 6 7)))
	     ((access append ())
	      `(FB ,float-cc)
	      (if (= size 0)
		  `(W ,(make-pc-relative (lambda () (fetch-immediate 'W))))
		  `(L ,(make-pc-relative (lambda () (fetch-immediate 'L))))))))
	  (else
	   (undefined-instruction)))))

(define (decode-ordinary-floating-instruction opcode-name ext)
  (let ((src-spec (extract ext 10 13))
	(rm (extract ext 14 15))
	(dst-reg (extract ext 7 10)))
    (if (= rm 1)
	`(,opcode-name
	  ,(floating-specifier->mnemonic src-spec)
	  ,(decode-ea-d 'L)
	  (FP ,dst-reg))
	`(,opcode-name (FP ,src-spec) (FP ,dst-reg)))))

(define (floating-opcode->mnemonic n)
  (let ((entry (assoc n 
		      '((#b0011000 . FABS)
			(#b0011100 . FACOS)
			(#b0100010 . FADD)
			(#b0001100 . FASIN)
			(#b0001010 . FATAN)
			(#b0001101 . FATANH)
			(#b0111000 . FCMP)
			(#b0011101 . FCOS)
			(#b0011001 . FCOSH)
			(#b0100000 . FDIV)
			(#b0010000 . FETOX)
			(#b0001000 . FETOXM1)
			(#b0011110 . FGETEXP)
			(#b0011111 . FGETMAN)
			(#b0000001 . FINT)
			(#b0000011 . FINTRZ)
			(#b0010101 . FLOG10)
			(#b0010110 . FLOG2)
			(#b0010100 . FLOGN)
			(#b0000110 . FLOGNP1)
			(#b0100001 . FMOD)
			(#b0100011 . FMUL)
			(#b0011010 . FNEG)
			(#b0100101 . FREM)
			(#b0100110 . FSCALE)
			(#b0100100 . FSGLDIV)
			(#b0100111 . FSGLMUL)
			(#b0001110 . FSIN)
			(#b0000010 . FSINH)
			(#b0000100 . FSQRT)
			(#b0101000 . FSUB)
			(#b0001111 . FTAN)
			(#b0001001 . FTANH)
			(#b0010010 . FTENTOX)
			(#b0111010 . FTST)
			(#b0010001 . FTWOTOX)))))
    (and entry
	 (cdr entry))))

(define (floating-specifier->mnemonic n)
  (let ((entry (assoc n 
		      '((0 . L)
			(1 . S)
			(2 . X)
			(3 . P)
			(4 . W)
			(5 . D)
			(6 . B)))))
    (and entry
	 (cdr entry))))

(define (decode-float-cc bits)
  (cdr (or (assv bits
		 '((1 . EQ) (14 . NE)
		   (2 . GT) (13 . NGT)
		   (3 . GE) (12 . NGE)
		   (4 . LT) (11 . NLT)
		   (5 . LE) (10 . NLE)
		   (6 . GL) (9 . NGL)
		   (4 . MI) (3 . PL)
		   (7 . GLE) (8 . NGLE)
		   (0 . F) (15 . T)))
      (error "DECODE-FLOAT-CC: Unrecognized floating point condition code"
	     bits))))

(define (match-bits? high low pattern-list)
  (let high-loop ((i 15) (l pattern-list))
    (cond ((< i 0)
	   (let low-loop ((i 15) (l l))
	     (cond ((< i 0) #t)
		   ((or (eq? (car l) '?)
			(eq? (if (bit-string-ref low i) 1 0)
			     (car l)))
		    (low-loop (-1+ i) (cdr l)))
		   (else
		    #f))))
	  ((or (eq? (car l) '?)
	       (eq? (if (bit-string-ref high i) 1 0)
		    (car l)))
	   (high-loop (-1+ i) (cdr l)))
	  (else #f))))

(define (get-fmove-keyword high low)
  (let loop ((l fmove-patterns))
    (cond ((null? l) '())
	  ((match-bits? high low (caar l))
	   (cdar l))
	  (else
	   (loop (cdr l))))))

(define fmove-patterns
  '(((1 1 1 1 0 0 1 0 0 0 ? ? ? ? ? ?
      0 ? 0 ? ? ? ? ? ? 0 0 0 0 0 0 0) . FMOVE-TO-FP)
    ((1 1 1 1 0 0 1 0 0 0 ? ? ? ? ? ?
      0 1 1 ? ? ? ? ? ? ? ? ? ? ? ? ?) . FMOVE-FROM-FP)
    ((1 1 1 1 0 0 1 0 0 0 ? ? ? ? ? ?
      1 0 ? ? ? ? 0 0 0 0 0 0 0 0 0 0) . FMOVE-FPcr)
    ((1 1 1 1 0 0 1 0 0 0 0 0 0 0 0 0
      0 1 0 1 1 1 ? ? ? ? ? ? ? ? ? ?) . FMOVECR)
    ((1 1 1 1 0 0 1 0 0 0 ? ? ? ? ? ?
      1 1 ? ? ? ? 0 0 0 ? ? ? ? ? ? ?) . FMOVEM-FPn)
    ((1 1 1 1 0 0 1 0 0 0 ? ? ? ? ? ?
      1 0 ? ? ? ? 0 0 0 0 0 0 0 0 0 0) . FMOVEM-FPcr)))

;;;; Bit String Manipulation

(define (fetch-immediate size)
  (cond ((eq? size 'B) (extract+ (get-word) 0 8))
	((eq? size 'W) (bit-string->signed-integer (get-word)))
	((eq? size 'L) (bit-string->signed-integer (get-longword)))
	(else (error "Unknown size" 'FETCH-IMMEDIATE size))))

(define (make-fetcher size-in-bits)
  (let ((size-in-bytes (quotient size-in-bits 8)))
    (lambda ()
      (let ((word (read-bits *current-offset size-in-bits)))
	(set! *current-offset (+ *current-offset size-in-bytes))
	word))))

(define get-word (make-fetcher 16))
(define get-longword (make-fetcher 32))

(define (make-peeker size-in-bits)
  (lambda ()
    (read-bits *current-offset size-in-bits)))

(define peek-word (make-peeker 16))
(define peek-longword (make-peeker 32))

(declare (integrate-operator extract extract+))

(define (extract bit-string start end)
  (declare (integrate bit-string start end))
  (bit-string->unsigned-integer (bit-substring bit-string start end)))

(define (extract+ bit-string start end)
  (declare (integrate bit-string start end))
  (bit-string->signed-integer (bit-substring bit-string start end)))

;;; Symbolic representation of bit strings

(define ((symbol-decoder symbols) index)
  (vector-ref symbols index))

(define decode-bwl (symbol-decoder #(B W L ())))
(define decode-wl  (symbol-decoder #(W L)))
(define decode-rl  (symbol-decoder #(R L)))
(define decode-us  (symbol-decoder #(U S)))
(define decode-da  (symbol-decoder #(D A)))
(define decode-cc
  (symbol-decoder #(T F HI LS CC CS NE EQ VC VS PL MI GE LT GT LE)))
(define decode-bit (symbol-decoder #(BTST BCHG BCLR BSET)))
(define decode-shift-type (symbol-decoder #(AS LS ROX RO)))
(define decode-ze  (symbol-decoder #(E Z)))

(define decode-bf
  (symbol-decoder #(BFTST BFEXTU BFCHG BFEXTS BFCLR BFFFO BFSET BFINS)))

(define (decode-scale scale)
  (vector-ref '#(1 2 4 8) scale))

;;;; Effective Addressing

(define (decode-ea-<D> register size)
  size					; ignored
  (make-data-register 'D register))

(define (decode-ea-<A> register size)
  size					; ignored
  (make-address-register 'A register))

(define (decode-ea-<b=>-A> register size)
  size					; ignored
  (if (memq size '(W L))
      (make-address-register 'A register)
      (undefined-instruction)))

(define (decode-ea-<@A> register size)
  size					; ignored
  (make-address-register '@A register))

(define (decode-ea-<@A+> register size)
  size					; ignored
  (make-address-register '@A+ register))

(define (decode-ea-<@-A> register size)
  size					; ignored
  (make-address-register '@-A register))

(define (decode-ea-<@AO> register size)
  size					; ignored
  (make-address-offset register
		       (bit-string->signed-integer (get-word))))

(define (decode-ea-<W> size)
  size					; ignored
  `(W ,(bit-string->signed-integer (get-word))))

(define (decode-ea-<L> size)
  size					; ignored
  `(L ,(bit-string->signed-integer (get-longword))))

(define (decode-ea-<@PCO> size)
  size					; ignored
  (make-pc-relative (lambda () (bit-string->signed-integer (get-word)))))

(define (decode-ea-<&> size)
  (cond ((eq? size 'B) `(& ,(extract+ (get-word) 0 8)))
	((eq? size 'W) `(& ,(bit-string->signed-integer (get-word))))
	((eq? size 'L) `(& ,(bit-string->signed-integer (get-longword))))
	(else (error "Unknown size" 'DECODE-EA-<&> size))))

;;;; Extended 68020 effective addresses

(define (decode-ea-<@AOX> register size)
  size					; ignored
  (decode-ea-extension
   (lambda (d/a xr w/l scale brs irs bd od operation)
     (cond ((eq? (cadr bd) 'B)
	    (if (= scale 1)
		;; This is the only possibility on a 68000/68010
		`(,@(make-address-register '@AOX register) ,(car bd)
							   ,d/a
							   ,xr
							   ,w/l)
		`(,@(make-address-register '@AOXS register) ,(car bd)
							    (,d/a ,xr)
							    ,w/l
							    ,scale)))
	   ((and (eq? d/a 'D) (eq? w/l 'L) (= scale 1)
		 (eq? brs 'Z) (eq? irs 'E)
		 (eq? (cadr od) 'N) (false? operation)
		 (memq (cadr bd) '(N W)))
	    (if (eq? (cadr bd) 'N)
		(make-data-register '@D xr)
		`(,@(make-data-register '@DO xr) ,(car bd))))
	   (else
	    `(,@(make-address-register '@AOF register) ,brs ,bd ,operation
						       ((,d/a ,xr) ,w/l ,scale)
						       ,irs ,od))))))

(define (decode-ea-<@PCOX> size)
  size					; ignored
  (let ((base-offset *current-offset))
    (decode-ea-extension
     (lambda (d/a xr w/l scale brs irs bd od operation)
       (cond ((eq? (cadr bd) 'B)
	      (if (= scale 1)
		  ;; This is the only possibility on a 68000/68010
		  `(@PCOX ,(car bd) ,d/a ,xr ,w/l)
		  `(@PCOXS ,(car bd) (,d/a ,xr) ,w/l ,scale)))
	     ((and (eq? brs 'E) (eq? irs 'Z) (false? operation)
		   (not (eq? (cadr bd) 'N)) (eq? (cadr od) 'N))
	      (offset->pc-relative (car bd) base-offset))
	     (else
	      `(@PCOF ,brs ,bd ,operation
		      ((,d/a ,xr) ,w/l ,scale)
		      ,irs ,od)))))))

(define (decode-ea-extension receiver)
  (let ((extension (get-word)))
    (let ((d/a (decode-da (extract extension 15 16)))
	  (xr (extract extension 12 15))
	  (w/l (decode-wl (extract extension 11 12)))
	  (scale (decode-scale (extract extension 9 11))))
      (if (not (bit-string-ref extension 8))
	  (receiver d/a xr w/l scale 'E 'E
		    `(,(extract+ extension 0 8) B)
		    '(0 N)
		    #F)
	  (let ((brs (decode-ze (extract extension 7 8)))
		(irs (decode-ze (extract extension 6 7)))
		(i/is (extract extension 0 3))
		(bd (case (extract extension 4 6)
		      ((1) '(0 N))
		      ((2) `(,(fetch-immediate 'W) W))
		      ((3) `(,(fetch-immediate 'L) L))
		      (else
		       #| (error "decode-ea-extension: bad bd-size"
		                 (extract extension 4 6)) |#
		       (undefined-instruction)))))
	    (receiver d/a xr w/l scale brs irs bd
		      (case (if (> i/is 3) (- i/is 4) i/is)
			((0 1) '(0 N))
			((2) `(,(fetch-immediate 'W) W))
			((3) `(,(fetch-immediate 'L) L))
			(else
			 #| (error "decode-ea-extension: bad i/is" i/is) |#
			 (undefined-instruction)))
		      (cond ((zero? i/is) #F)
			    ((> i/is 3) 'POST)
			    (else 'PRE))))))))

(define make-ea-dispatch
  (let ()
    (define (kernel dispatch mode-7)
      (vector-set! dispatch 7
		   (lambda (register size)
		     ((vector-ref mode-7 register) size)))
      (lambda (mode register size)
	((vector-ref dispatch mode) register size)))

    (lambda (d a @a @a+ @-a @ao @aox w l @pco @pcox &)
      (kernel (vector d a @a @a+ @-a @ao @aox '())
	      (vector w l @pco @pcox &
		      decode-ea-mode-7-undefined
		      decode-ea-mode-7-undefined
		      decode-ea-mode-7-undefined)))))

(define (decode-ea-with-size d a @a @a+ @-a @ao @aox w l @pco @pcox &)
  (let ((kernel (make-ea-dispatch d a @a @a+ @-a @ao @aox w l @pco @pcox &)))
    (lambda (size)
      (kernel (extract *ir 3 6)
	      (extract *ir 0 3)
	      size))))

(define (decode-ea-w/o-size d a @a @a+ @-a @ao @aox w l @pco @pcox &)
  (let ((kernel (make-ea-dispatch d a @a @a+ @-a @ao @aox w l @pco @pcox &)))
    (lambda ()
      (kernel (extract *ir 3 6)
	      (extract *ir 0 3)
	      '()))))

(define (decode-ea-undefined register size)
  register size				; ignored
  (undefined-instruction))

(define (decode-ea-mode-7-undefined size)
  size					; ignored
  (undefined-instruction))

(define decode-ea-d
  (decode-ea-with-size decode-ea-<D>
		       decode-ea-undefined
		       decode-ea-<@A>
		       decode-ea-<@A+>
		       decode-ea-<@-A>
		       decode-ea-<@AO>
		       decode-ea-<@AOX>
		       decode-ea-<W>
		       decode-ea-<L>
		       decode-ea-<@PCO>
		       decode-ea-<@PCOX>
		       decode-ea-<&>))

(define decode-ea-m&d
  (decode-ea-w/o-size decode-ea-<D>
		      decode-ea-undefined
		      decode-ea-<@A>
		      decode-ea-undefined
		      decode-ea-undefined
		      decode-ea-<@AO>
		      decode-ea-<@AOX>
		      decode-ea-<W>
		      decode-ea-<L>
		      decode-ea-<@PCO>
		      decode-ea-<@PCOX>
		      decode-ea-undefined))

(define decode-ea-c
  (decode-ea-w/o-size decode-ea-undefined
		      decode-ea-undefined
		      decode-ea-<@A>
		      decode-ea-undefined
		      decode-ea-undefined
		      decode-ea-<@AO>
		      decode-ea-<@AOX>
		      decode-ea-<W>
		      decode-ea-<L>
		      decode-ea-<@PCO>
		      decode-ea-<@PCOX>
		      decode-ea-mode-7-undefined))

(define decode-ea-d&a
  (decode-ea-w/o-size decode-ea-<D>
		      decode-ea-undefined
		      decode-ea-<@A>
		      decode-ea-<@A+>
		      decode-ea-<@-A>
		      decode-ea-<@AO>
		      decode-ea-<@AOX>
		      decode-ea-<W>
		      decode-ea-<L>
		      decode-ea-mode-7-undefined
		      decode-ea-mode-7-undefined
		      decode-ea-mode-7-undefined))

(define decode-ea-c&a
  (decode-ea-with-size decode-ea-undefined
		       decode-ea-undefined
		       decode-ea-<@A>
		       decode-ea-undefined
		       decode-ea-undefined
		       decode-ea-<@AO>
		       decode-ea-<@AOX>
		       decode-ea-<W>
		       decode-ea-<L>
		       decode-ea-mode-7-undefined
		       decode-ea-mode-7-undefined
		       decode-ea-mode-7-undefined))

(define decode-ea-m&a
  (decode-ea-w/o-size decode-ea-undefined
		      decode-ea-undefined
		      decode-ea-<@A>
		      decode-ea-<@A+>
		      decode-ea-<@-A>
		      decode-ea-<@AO>
		      decode-ea-<@AOX>
		      decode-ea-<W>
		      decode-ea-<L>
		      decode-ea-mode-7-undefined
		      decode-ea-mode-7-undefined
		      decode-ea-mode-7-undefined))

(define decode-ea-all
  (decode-ea-with-size decode-ea-<D>
		       decode-ea-<A>
		       decode-ea-<@A>
		       decode-ea-<@A+>
		       decode-ea-<@-A>
		       decode-ea-<@AO>
		       decode-ea-<@AOX>
		       decode-ea-<W>
		       decode-ea-<L>
		       decode-ea-<@PCO>
		       decode-ea-<@PCOX>
		       decode-ea-<&>))

(define decode-ea-b=>-A
  (decode-ea-with-size decode-ea-<D>
		       decode-ea-<b=>-A>
		       decode-ea-<@A>
		       decode-ea-<@A+>
		       decode-ea-<@-A>
		       decode-ea-<@AO>
		       decode-ea-<@AOX>
		       decode-ea-<W>
		       decode-ea-<L>
		       decode-ea-<@PCO>
		       decode-ea-<@PCOX>
		       decode-ea-<&>))

(define decode-ea-a&<b=>-A>
  (decode-ea-with-size decode-ea-<D>
		       decode-ea-<b=>-A>
		       decode-ea-<@A>
		       decode-ea-<@A+>
		       decode-ea-<@-A>
		       decode-ea-<@AO>
		       decode-ea-<@AOX>
		       decode-ea-<W>
		       decode-ea-<L>
		       decode-ea-mode-7-undefined
		       decode-ea-mode-7-undefined
		       decode-ea-mode-7-undefined))

(define decode-ea-MOVE-destination
  (let ((kernel (make-ea-dispatch decode-ea-<D>
				  decode-ea-<A>
				  decode-ea-<@A>
				  decode-ea-<@A+>
				  decode-ea-<@-A>
				  decode-ea-<@AO>
				  decode-ea-<@AOX>
				  decode-ea-<W>
				  decode-ea-<L>
				  decode-ea-mode-7-undefined
				  decode-ea-mode-7-undefined
				  decode-ea-mode-7-undefined)))
    (lambda (size)
      (kernel (extract *ir 6 9)
	      (extract *ir 9 12)
	      size))))