--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm2.scm,v 1.1 1987/08/07 17:12:40 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; 68000 Disassembler
+
+(declare (usual-integrations))
+\f
+(define ((with-info-to-file type receiver) filename)
+ (let ((filename (->pathname filename)))
+ (let ((block (file->block (pathname-new-type filename "com"))))
+ (fluid-let ((*symbol-table))
+ (setup-table! (pathname-new-type filename "binf"))
+ (call-with-output-file (pathname-new-type filename type)
+ (lambda (port) (receiver block port)))))))
+
+(define (block-code->port! block port)
+ (define (instruction-output-string label? instruction)
+ (let ((string (with-output-to-string
+ (lambda ()
+ (if label? (format "~%~s:" label?))
+ (format "~% ")
+ (display instruction)))))
+ (string-downcase! string)
+ string))
+
+ (let ((last-valid-offset (block-code-ending-offset block)))
+ (let loop ((offset (block-code-starting-offset block)))
+ (disassemble-one-instruction block offset
+ (lambda (new-offset label? instruction)
+ (write-string (instruction-output-string label? instruction) port)
+ (and (<= new-offset last-valid-offset)
+ (loop new-offset)))))))
+
+(define (block-constants->port! block port)
+ (define (constant-output-string label? constant)
+ (with-output-to-string
+ (lambda ()
+ (if label?
+ (format "~%~s:" (string-downcase label?)))
+ (format "~% ~o" constant))))
+
+ (let ((last-valid-index (block-constants-ending-index block)))
+ (let loop ((index (block-constants-starting-index block)))
+ (and (<= index last-valid-index)
+ (let ((offset (block-index->offset index)))
+ (write-string
+ (constant-output-string (lookup-label block offset)
+ (system-vector-ref block index))
+ port)
+ (loop (1+ index)))))))
+\f
+(set! compiler:write-lap-file
+ (with-info-to-file "lap"
+ (lambda (block port)
+ (newline port)
+ (write-string "Executable Code:" port)
+ (newline port)
+ (block-code->port! block port)
+ (newline port)
+ (newline port)
+ (write-string "Constants:" port)
+ (newline port)
+ (block-constants->port! block port))))
+
+(set! compiler:write-constants-file
+ (with-info-to-file "con" block-constants->port!))
+
+(set! disassembly-stream
+ (named-lambda (disassembly-stream start)
+ (disassemble-anything start
+ (lambda (base block offset)
+ (let ((last-valid-offset (block-code-ending-offset block)))
+ (let loop ((offset offset))
+ (disassemble-one-instruction block offset
+ (lambda (new-offset label? instruction)
+ (if (> new-offset last-valid-offset)
+ '()
+ ;; INSTRUCTION-STREAM-CONS
+ (cons (make-instruction offset label? instruction)
+ (delay (loop new-offset))))))))))))
+
+(define (disassemble-anything thing continuation)
+ (cond ((compiled-code-address? thing)
+ (let ((block (compiled-code-address->block thing)))
+ (continuation (primitive-datum block)
+ block
+ (compiled-code-address->offset thing))))
+ ((integer? thing)
+ (continuation 0 0 thing))
+ (else
+ (error "Unknown entry to disassemble" thing))))
+\f
+(define (make-address base offset label?)
+ (or label? offset))
+
+(define *block)
+(define *initial-offset)
+(define *current-offset)
+(define *valid?)
+(define *ir)
+
+(define (disassemble-one-instruction block offset receiver)
+ (define (make-losing-instruction size)
+ (if (eq? size 'W)
+ `(DC W ,(bit-string->unsigned-integer *ir))
+ `(DC L ,(bit-string->unsigned-integer (bit-string-append (get-word)
+ *ir)))))
+
+ (fluid-let ((*block block)
+ (*initial-offset offset)
+ (*current-offset offset)
+ (*valid? true)
+ (*ir))
+ (set! *ir (get-word))
+ (receiver *current-offset
+ (lookup-label block offset)
+ (let ((size (dcw? block offset)))
+ (if size
+ (make-losing-instruction size)
+ (let ((instruction
+ (((vector-ref opcode-dispatch (extract *ir 12 16))))))
+ (if *valid?
+ instruction
+ (make-losing-instruction 'W))))))))
+
+(define (undefined-instruction)
+ ;; This losing assignment removes a 'call/cc'. Too bad.
+ (set! *valid? false)
+ '())
+
+(define (undefined)
+ undefined-instruction)
+\f
+;;;; Compiler specific information
+
+(define data-register-assignments
+ ;; D0 serves multiple functions, not handled now
+ '((7 . REFERENCE-MASK)))
+
+(define address-register-assignments
+ '((4 . FRAME-POINTER)
+ (5 . FREE-POINTER)
+ (6 . REGS-POINTER)
+ (7 . STACK-POINTER)))
+
+(define interpreter-register-assignments
+ (let-syntax ()
+ (define-macro (make-table)
+ (define (make-entries index names)
+ (if (null? names)
+ '()
+ (cons `(,index . (ENTRY ,(car names)))
+ (make-entries (+ index 6) (cdr names)))))
+ `'(;; Interpreter registers
+ (0 . (REG MEMORY-TOP))
+ (4 . (REG STACK-GUARD))
+ (8 . (REG VALUE))
+ (12 . (REG ENVIRONMENT))
+ (16 . (REG TEMPORARY))
+ (20 . (REG INTERPRETER-CALL-RESULT:ENCLOSE))
+ ;; Interpreter entry points
+ ,@(make-entries
+ #x00F0
+ '(apply error wrong-number-of-arguments interrupt-procedure
+ interrupt-continuation lookup-apply lookup access
+ unassigned? unbound? set! define primitive-apply
+ enclose setup-lexpr return-to-interpreter safe-lookup
+ cache-variable reference-trap assignment-trap))
+ ,@(make-entries
+ #x0228
+ '(uuo-link uuo-link-trap cache-reference-apply
+ safe-reference-trap unassigned?-trap
+ cache-variable-multiple uuo-link-multiple))))
+ (make-table)))
+\f
+(define-integrable (lookup-special-register reg table)
+ (assq reg table))
+
+(define-integrable (special-register reg-pair)
+ (cdr reg-pair))
+
+(define ((register-maker table) mode register)
+ (let ((special (and disassembler:symbolize-output?
+ (lookup-special-register register table))))
+ (list mode
+ (if special
+ (special-register special)
+ register))))
+
+(define make-data-register
+ (register-maker data-register-assignments))
+
+(define make-address-register
+ (register-maker address-register-assignments))
+
+(define (make-address-offset register offset)
+ (if (not disassembler:symbolize-output?)
+ `(@AO ,register ,offset)
+ (let ((special
+ (lookup-special-register register address-register-assignments)))
+ (if special
+ (if (eq? (special-register special) 'REGS-POINTER)
+ (let ((interpreter-register
+ (lookup-special-register offset
+ interpreter-register-assignments)))
+ (if interpreter-register
+ (special-register interpreter-register)
+ `(@AO REGS-POINTER ,offset)))
+ `(@AO ,(special-register special) ,offset))
+ `(@AO ,register ,offset)))))
+
+(define (make-pc-relative thunk)
+ ;; Done this way to force order of evaluation
+ (let* ((reference-offset *current-offset)
+ (pco (thunk)))
+ (offset->pc-relative pco reference-offset)))
+
+(define-integrable (offset->pc-relative pco reference-offset)
+ (let ((absolute (+ pco reference-offset)))
+ (if disassembler:symbolize-output?
+ (let ((answ (lookup-label *block absolute)))
+ (if answ
+ `(@PCR ,answ)
+ `(@PCO ,(- pco (- reference-offset *initial-offset)))))
+ `(@PCO ,(- pco (- reference-offset *initial-offset))))))
+\f
+(define *symbol-table)
+
+;; Temporary Kludge
+
+(set! setup-table!
+ (named-lambda (setup-table! filename)
+ (set! *symbol-table
+ (make-binary-searcher (compiler-info-labels (fasload filename))
+ offset/label-info=?
+ offset/label-info<?))
+ *symbol-table))
+
+(define (lookup-label block offset)
+ (and (not (unassigned? *symbol-table))
+ (let ((label (*symbol-table offset)))
+ (and label
+ (label-info-name label)))))
+
+(define (dcw? block offset)
+ (and (not (unassigned? *symbol-table))
+ (let ((label (*symbol-table (+ offset 2))))
+ (and label
+ (label-info-external? label)
+ 'W))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm3.scm,v 1.1 1987/08/07 17:12:59 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; 68000 Disassembler
+
+(declare (usual-integrations))
+\f
+;;; Insides of the disassembler
+
+(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))))
+\f
+ (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)
+ undefined))
+\f
+;;;; 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))))))
+
+\f
+(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 ((ea (decode-ea-d&a)))
+ `(,keyword ,size (& ,(fetch-immediate size)) ,ea))))))
+
+(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 ((ea (decode-ea-d&a)))
+ `(,keyword ,size (& ,(fetch-immediate size)) ,ea)))))
+
+(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))
+\f
+(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))))
+ (MOVEM-ea->registers (lambda () %MOVEM-ea->registers))
+ (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
+ MOVEM-ea->registers
+ CHK/LEA
+ all-the-rest
+ CHK/LEA)))
+\f
+(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))
+
+\f
+(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)))
+\f
+(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))))
+\f
+(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)))
+\f
+(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))))
+\f
+(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))
+ ,(decode-ea-d 'W)
+ ,(make-data-register 'D (extract *ir 9 12))))
+
+(define %MUL (%MUL/%DIV 'MUL))
+(define %DIV (%MUL/%DIV 'DIV))
+
+(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)
+ (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))))))
+\f
+;;;; 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 (bit-string-allocate size-in-bits)))
+ (with-interrupt-mask interrupt-mask-none
+ (lambda (old)
+ (read-bits! (+ (primitive-datum *block) *current-offset) 0 word)))
+ (set! *current-offset (+ *current-offset size-in-bytes))
+ word))))
+
+(define get-word (make-fetcher 16))
+(define get-longword (make-fetcher 32))
+(define-integrable (extract bit-string start end)
+ (bit-string->unsigned-integer (bit-substring bit-string start end)))
+
+(define-integrable (extract+ 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-scale scale)
+ (vector-ref '#(1 2 4 8) scale))
+\f
+;;;; Effective Addressing
+
+(define (decode-ea-<D> register size)
+ (make-data-register 'D register))
+
+(define (decode-ea-<A> register size)
+ (make-address-register 'A register))
+
+(define (decode-ea-<b=>-A> register size)
+ (if (memq size '(W L))
+ (make-address-register 'A register)
+ (undefined-instruction)))
+
+(define (decode-ea-<@A> register size)
+ (make-address-register '@A register))
+
+(define (decode-ea-<@A+> register size)
+ (make-address-register '@A+ register))
+
+(define (decode-ea-<@-A> register size)
+ (make-address-register '@-A register))
+
+(define (decode-ea-<@AO> register size)
+ (make-address-offset register
+ (bit-string->signed-integer (get-word))))
+
+(define (decode-ea-<W> size)
+ `(W ,(bit-string->signed-integer (get-word))))
+
+(define (decode-ea-<L> size)
+ `(L ,(bit-string->signed-integer (get-longword))))
+
+(define (decode-ea-<@PCO> size)
+ (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))))
+\f
+;;;; Extended 68020 effective addresses
+
+(define (decode-ea-<@AOX> register size)
+ (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)
+ (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)))))))
+\f
+(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))))))
+ (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)))
+ (cond ((zero? i/is) #F)
+ ((> i/is 3) 'POST)
+ (else 'PRE))))))))
+\f
+(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)
+ (undefined-instruction))
+
+(define (decode-ea-mode-7-undefined size)
+ (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-<&>))
+\f
+(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))
+\f
+(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-<&>))
+\f
+(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))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff