ia-x86.lisp 3.19 KB
Newer Older
1 2
;;;;------------------------------------------------------------------
;;;; 
3
;;;;    Copyright (C) 200120001999, 2002, 2004,
4
;;;;    Department of Computer Science, University of Tromso, Norway
5 6 7 8 9 10 11
;;;; 
;;;; Filename:      ia-x86.lisp
;;;; Description:   
;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
;;;; Created at:    Fri Dec 17 18:01:26 1999
;;;; Distribution:  See the accompanying file COPYING.
;;;;                
12
;;;; $Id: ia-x86.lisp,v 1.4 2004/09/02 09:01:29 ffjeld Exp $
13 14 15
;;;;                
;;;;------------------------------------------------------------------

16
(in-package #:ia-x86)
17 18 19 20 21 22 23 24 25

;;; ----------------------------------------------------------------
;;;                    Instruction Definition
;;; ----------------------------------------------------------------

(defclass instruction ()
  ((operands
    :type list
    :initform '()
26
    :initarg :operands
27 28 29
    :accessor instruction-operands)
   (prefixes
    :type list
30
    :initarg :prefixes
31 32 33
    :initform '()
    :accessor instruction-prefixes)
   (user-size
34
    :initarg :user-size
35
    :reader instruction-user-size)
36 37 38 39
   (user-finalizer
    :initarg :user-finalizer
    :initform nil
    :reader instruction-finalizer)
40
   (original-datum
41
    :initarg :datum
42 43 44 45 46
    :accessor instruction-original-datum)))

(defmethod print-object ((obj instruction) stream)
  (cond
   (*print-readably*
47
    (format stream "(~@[~W ~]~W~{ ~W~})"
48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112
	    (instruction-prefixes obj)
	    (type-of obj)
	    (instruction-operands obj))
    obj)
   (t (print-unreadable-object (obj stream)
	(format stream "asm ~@[~A ~]~A~{ ~A~}"
		(instruction-prefixes obj)
		(type-of obj)
		(instruction-operands obj))))))



;;; ----------------------------------------------------------------
;;;            Symbolic break-down of encoded instructions
;;; ----------------------------------------------------------------

(defstruct instr-symbolic
  mod reg r/m
  scale index base
  displacement
  immediate
  opcode)

(defmethod print-object ((obj instr-symbolic) stream)
  (if *print-pretty*
      (progn
	(princ "#IS(" stream)
	(dolist (slot '(mod reg r/m scale index base displacement immediate opcode))
	  (when (slot-boundp obj slot)
	    (format stream "(~A: ~A)" slot (slot-value obj slot))))
	(princ ")" stream)
	obj)
    (call-next-method obj stream)))

;;; ----------------------------------------------------------------
;;;   stupid "decoder sets"..
;;; ----------------------------------------------------------------

(defmacro make-decoder-set (&rest decoder-spec)
  (let ((keys (mapcar #'first decoder-spec))
	(vals (mapcar #'second decoder-spec)))
    (list 'quote
	  (mapcar #'cons keys vals))))

(defmacro make-encoder-set (&rest decoder-spec)
  (let ((keys (mapcar #'first decoder-spec))
	(vals (mapcar #'second decoder-spec)))
    (list 'quote
	  (mapcar #'cons  vals keys))))

(defun decode-set (decoder-set index &key (errorp t))
  ;;  (declare (type list decoder))
  (let ((r (cdr (assoc index decoder-set
		       :test #'equal))))
    (when (and (not r) errorp)
      (error "failed to look up ~A:~A in the set ~A"
	     (type-of index)
	     index
	     (mapcar #'(lambda (cons)
			 (format nil "(~A:~A . ~A)"
				 (type-of (car cons))
				 (car cons)
				 (cdr cons)))
		     decoder-set)))
    r))