#| -*-Scheme-*-

$Id: insutl.scm,v 1.14 2008/01/30 20:01:48 cph Exp $

Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
    2006, 2007, 2008 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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
USA.

|#

;;;; 68000 utility procedures

(declare (usual-integrations))

;;;; Effective Addressing

;;; *** NOTE: If this format changes, inerly.scm must also be changed! ***

(define ea-tag
  "Effective-Address")

(define (make-effective-address keyword mode register extension categories)
  (vector ea-tag keyword mode register extension categories))

(define (effective-address? object)
  (and (vector? object)
       (not (zero? (vector-length object)))
       (eq? (vector-ref object 0) ea-tag)))

(define-integrable (ea-keyword ea)
  (vector-ref ea 1))

(define-integrable (ea-mode ea)
  (vector-ref ea 2))

(define-integrable (ea-register ea)
  (vector-ref ea 3))

(define-integrable (ea-extension ea)
  (vector-ref ea 4))

(define-integrable (ea-categories ea)
  (vector-ref ea 5))

(define-integrable (with-ea ea receiver)
  (receiver (ea-keyword ea)
	    (ea-mode ea)
	    (ea-register ea)
	    (ea-extension ea)
	    (ea-categories ea)))

;; For completeness

(define (ea-keyword-early ea)
  (vector-ref ea 1))

(define (ea-mode-early ea)
  (vector-ref ea 2))

(define (ea-register-early ea)
  (vector-ref ea 3))

(define (ea-extension-early ea)
  (vector-ref ea 4))

(define (ea-categories-early ea)
  (vector-ref ea 5))

;;;; Effective Address Extensions

(define-integrable (output-16bit-offset o)
  (EXTENSION-WORD (16 o SIGNED)))

(define-integrable (output-16bit-relative l)
  (EXTENSION-WORD (16 `(- ,l *PC*) SIGNED)))

(define-integrable (output-offset-index-register xtype xr s o)
  (EXTENSION-WORD (1 xtype)
		  (3 xr)
		  (1 s)
		  (3 #b000)
		  (8 o SIGNED)))

(define-integrable (output-relative-index-register xtype xr s l)
  (EXTENSION-WORD (1 xtype)
		  (3 xr)
		  (1 s)
		  (3 #b000)
		  (8 `(- ,l *PC*) SIGNED)))

(define-integrable (output-16bit-address a)
  (EXTENSION-WORD (16 a)))

(define-integrable (output-32bit-address a)
  (EXTENSION-WORD (32 a)))

(define (output-immediate-data immediate-size i)
  (case immediate-size
    ((B)  (EXTENSION-WORD (8 #b00000000) (8 i SIGNED)))
    ((UB) (EXTENSION-WORD (8 #b00000000) (8 i UNSIGNED)))
    ((W)  (EXTENSION-WORD (16 i SIGNED)))
    ((UW) (EXTENSION-WORD (16 i UNSIGNED)))
    ((L)  (EXTENSION-WORD (32 i SIGNED)))
    ((UL) (EXTENSION-WORD (32 i UNSIGNED)))
    (else (error "illegal immediate size" immediate-size))))

;;; Support for 68020 addressing modes

(define-integrable (output-brief-format-extension-word
		    index-register-type index-register
		    index-size factor
		    displacement)
  (EXTENSION-WORD (1 index-register-type)
		  (3 index-register)
		  (1 index-size)
		  (2 factor SCALE-FACTOR)
		  (1 #b0)
		  (8 displacement SIGNED)))

(define (output-full-format-extension-word index-register-type index-register
					   index-size factor
					   base-suppress index-suppress
					   base-displacement-size
					   base-displacement
					   indirection-type
					   outer-displacement-size
					   outer-displacement)
  (let ((output-displacement
	 (lambda (size displacement)
	   (case size
	     ((1) false)
	     ((2) (EXTENSION-WORD (16 displacement SIGNED)))
	     ((3) (EXTENSION-WORD (32 displacement SIGNED)))
	     (else (error "illegal displacement-size" size))))))
    (apply
     optimize-group
     (let loop
	 ((items
	   (list
	    (EXTENSION-WORD
	     (1 index-register-type)
	     (3 index-register)
	     (1 index-size)
	     (2 factor SCALE-FACTOR)
	     (1 #b1)
	     (1 base-suppress)
	     (1 index-suppress)
	     (2 base-displacement-size)
	     (1 #b0)
	     (3 (case indirection-type
		  ((#F) #b000)
		  ((PRE) outer-displacement-size)
		  ((POST) (+ #b100 outer-displacement-size))
		  (else (error "illegal indirection-type" indirection-type)))))
	    (output-displacement base-displacement-size base-displacement)
	    (output-displacement outer-displacement-size outer-displacement))))
       (if (null? items)
	   '()
	   (let ((rest (loop (cdr items))))
	     (if (car items)
		 (cons-syntax (car items) rest)
		 rest)))))))

;;;; Common special cases

(define-integrable (output-@D-indirect register)
  (EXTENSION-WORD (1 #b0)		;index register = data
		  (3 register)
		  (1 #b1)		;index size = longword
		  (2 #b00)		;scale factor = 1
		  (1 #b1)
		  (1 #b1)		;suppress base register
		  (1 #b0)		;don't suppress index register
		  (2 #b01)		;null base displacement
		  (1 #b0)
		  (3 #b000)		;no memory indirection
		  ))

(define (output-@DO-indirect register displacement)
  (EXTENSION-WORD (1 #b0)		;index register = data
		  (3 register)
		  (1 #b1)		;index size = 32 bits
		  (2 #b00)		;scale factor = 1
		  (1 #b1)
		  (1 #b1)		;suppress base register
		  (1 #b0)		;don't suppress index register
		  (2 #b10)		;base displacement size = 16 bits
		  (1 #b0)
		  (3 #b000)		;no memory indirection
		  (16 displacement SIGNED)))

(define (output-32bit-offset offset)
  (EXTENSION-WORD (1 #b0)		;index register = data
		  (3 #b000)		;register number = 0
		  (1 #b0)		;index size = 32 bits
		  (2 #b00)		;scale factor = 1
		  (1 #b1)
		  (1 #b0)		;use base register
		  (1 #b1)		;suppress index register
		  (2 #b11)		;base displacement size = 32 bits
		  (1 #b0)
		  (3 #b000)		;no memory indirection
		  (32 offset SIGNED)))

;;;; Operand Syntaxers.

(define (immediate-words data size)
  (case size
    ((B) (immediate-byte data))
    ((W) (immediate-word data))
    ((L) (immediate-long data))
    ((UB) (immediate-unsigned-byte data))
    ((UW) (immediate-unsigned-word data))
    ((UL) (immediate-unsigned-long data))
    (else (error "Illegal size" size))))

(define (immediate-unsigned-words data size)
  (case size
    ((B UB) (immediate-unsigned-byte data))
    ((W UW) (immediate-unsigned-word data))
    ((L UL) (immediate-unsigned-long data))
    (else (error "Illegal size" size))))

(define-integrable (immediate-byte data)
  `(GROUP ,(make-bit-string 8 0)
	  ,(syntax-evaluation data coerce-8-bit-signed)))

(define-integrable (immediate-unsigned-byte data)
  `(GROUP ,(make-bit-string 8 0)
	  ,(syntax-evaluation data coerce-8-bit-unsigned)))

(define-integrable (immediate-word data)
  (syntax-evaluation data coerce-16-bit-signed))

(define-integrable (immediate-unsigned-word data)
  (syntax-evaluation data coerce-16-bit-unsigned))

(define-integrable (immediate-long data)
  (syntax-evaluation data coerce-32-bit-signed))

(define-integrable (immediate-unsigned-long data)
  (syntax-evaluation data coerce-32-bit-unsigned))

(define-integrable (relative-word address)
  (syntax-evaluation `(- ,address *PC*) coerce-16-bit-signed))

(define-integrable (relative-long address)
  (syntax-evaluation `(- ,address *PC*) coerce-32-bit-signed))

(define-integrable (offset-word data)
  (syntax-evaluation data coerce-16-bit-signed))

(define-integrable (output-bit-string bit-string)
  bit-string)

;;;; Randoms

;; Auxiliary procedure for register list transformers

(define (encode-register-list reg-list encoding)
  (let ((bit-string (make-bit-string 16 #!FALSE)))
    (define (loop regs)
      (if (null? regs)
	  bit-string
	  (let ((place (assq (car regs) encoding)))
	    (if (null? place)
		#F
		(begin
		  (bit-string-set! bit-string (cdr place))
		  (loop (cdr regs)))))))
    (loop reg-list)))
