operands.lisp

   1 ;;;;------------------------------------------------------------------
   2 ;;;;
   3 ;;;;    Copyright (C) 20012000, 2002-2005,
   4 ;;;;    Department of Computer Science, University of Tromso, Norway
   5 ;;;;
   6 ;;;; Filename:      operands.lisp
   7 ;;;; Description:   Operand representation.
   8 ;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
   9 ;;;; Created at:    Wed Feb 16 14:02:57 2000
  10 ;;;; Distribution:  See the accompanying file COPYING.
  11 ;;;;
  12 ;;;; $Id: operands.lisp,v 1.6 2005/08/13 20:31:51 ffjeld Exp $
  13 ;;;;
  14 ;;;;------------------------------------------------------------------
  15
  16 (in-package #:ia-x86)
  17
  18 ;;; ----------------------------------------------------------------
  19 ;;;                         Operand types
  20 ;;; ----------------------------------------------------------------
  21
  22 ;;; Operand types are identified by symbols
  23
  24 (defmacro def-operand-types (&rest ot-specs)
  25   (list* 'cl:eval-when '(:load-toplevel)
  26          (loop for (sym . properties) in ot-specs
  27              append
  28                `((setf ,@(loop for (p v) in properties
  29                              appending `((cl:get ',sym ',p) ,v)))
  30                  (import ',sym :ia-x86-instr)))))
  31
  32 (defun operand-type-property (sym p)
  33   (get sym p))
  34
  35 (def-operand-types
  36     (immediate (immediate t))
  37     (displacement (immediate nil))
  38     (imm32 (immediate t)
  39            (bit-size 32)
  40            (signed nil))
  41     (imm16 (immediate t)
  42            (bit-size 16)
  43            (signed nil))
  44   (imm8  (immediate t)
  45          (bit-size 8)
  46          (signed nil))
  47   (simm32 (immediate t)
  48           (bit-size 32)
  49           (signed t))
  50   (simm16 (immediate t)
  51           (bit-size 16)
  52           (signed t))
  53   (simm8  (immediate t)
  54           (bit-size 8)
  55           (signed t))
  56   (imm16-8 (immediate t)
  57            (bit-size 16))
  58   (imm8-0 (immediate t)
  59           (bit-size 8))
  60   (r32 (bit-size 32))
  61   (r16 (bit-size 16))
  62   (r8  (bit-size 8))
  63   (+r32 (bit-size 32))
  64   (+r16 (bit-size 16))
  65   (+r8  (bit-size 8))
  66   (m (bit-size 32))                     ; memory poiner
  67   (m64 (bit-size 64))
  68   (mm (bit-size 64))                    ; mmx register
  69   (mm/m64 (immediate nil))
  70   (mm/m32 (immediate nil))
  71   (xmm (bit-size 128))                  ; simd register
  72   (xmm/m128) (xmm/m64) (xmm/m32)
  73   (moffs8  (immediate nil)
  74            (bit-size 8)
  75            (signed nil))
  76   (moffs16 (immediate nil)
  77            (bit-size 16)
  78            (signed nil))
  79   (moffs32 (immediate nil)
  80            (bit-size 32)
  81            (signed nil))
  82   (al      (immediate nil)
  83            (bit-size 8))
  84   (ah      (immediate nil)
  85            (bit-size 8))
  86   (ax      (immediate nil)
  87            (bit-size 16))
  88   (eax     (immediate nil)
  89            (bit-size 32))
  90   (ebx     (immediate nil)
  91            (bit-size 32))
  92   (dx      (immediate nil)
  93            (bit-size 16))
  94   (edx     (immediate nil)
  95            (bit-size 32))
  96   (cr0) (cr2) (cr3) (cr4)
  97   (dr0) (dr1) (dr2) (dr3)
  98   (dr4) (dr5) (dr6) (dr7)
  99   (ptr16-16 (immediate nil))
 100   (ptr16-32 (immediate nil))
 101   (m16-16 (immediate nil))
 102   (m16-32 (immediate nil))
 103   (m32real (immediate nil))
 104   (m64real (immediate nil))
 105   (m80real (immediate nil))
 106   (m16int (immediate nil))
 107   (m32int (immediate nil))
 108   (m64int (immediate nil)))
 109
 110 ;;; ----------------------------------------------------------------
 111 ;;;                     Operand Class
 112 ;;; ----------------------------------------------------------------
 113
 114 (defclass operand () ())
 115
 116 (defclass concrete-operand (operand) ()
 117           (:documentation "Operands that correspond directly
 118 to one of the x86 operand adressing modes."))
 119
 120 (defclass abstract-operand (operand) ()
 121           (:documentation "Operands that are not concrete, for example
 122 symbolic references. Abstract operands need to be resolved to concrete
 123 operands at encoding-time."))
 124
 125 (defmethod print-object ((obj concrete-operand) stream)
 126   (format stream "~A" (operand-listform obj))
 127   obj)
 128
 129 (defmethod print-object ((obj abstract-operand) stream)
 130   (format stream "~A" (operand-listform obj))
 131   obj)
 132
 133 ;;; ----------------------------------------------------------------
 134 ;;;                        Abstract operands
 135 ;;; ----------------------------------------------------------------
 136
 137 (defun abstract-operand-to-offset (operand template instr env)
 138   (sign-extend (mod (- (operand-resolve-to-number operand env)
 139                        (assemble-env-current-pc env)
 140                        (template-instr-and-prefix-length template instr env))
 141                     #x100000000)
 142                4))
 143
 144 (defclass operand-label (abstract-operand)
 145   ((label
 146     :type symbol
 147     :initarg label
 148     :accessor operand-label)
 149    (user-size
 150     :initarg user-size
 151     :reader operand-user-size
 152     :initform nil)))
 153
 154 (defmethod operand-user-size ((operand t)) nil)
 155
 156 (defmethod operand-listform ((operand operand-label))
 157   (list* 'quote
 158          (operand-label operand)
 159          (operand-user-size operand)))
 160
 161 (defmethod operand-resolve-to-number ((operand operand-label) env)
 162   (assert (not (null env)) ()
 163     "Resolving ~A requires an assemble-environment." operand)
 164   (symtab-lookup-label (assemble-env-symtab env)
 165                        (operand-label operand)))
 166
 167 (defclass calculated-operand (abstract-operand)
 168   ((sub-operands
 169     :initarg :sub-operands
 170     :accessor sub-operands)
 171    (calculation
 172     :initarg :calculation
 173     :reader operand-calculation)
 174    (user-size
 175     :initarg user-size
 176     :reader operand-user-size
 177     :initform nil)))
 178
 179 (defmethod operand-resolve-to-number ((operand calculated-operand) env)
 180   (assert (not (null env)) ()
 181     "Resolving ~A requires an assemble-environment." operand)
 182   (apply (operand-calculation operand)
 183          (mapcar #'operand-resolve-to-number
 184                  (sub-operands operand)
 185                  (let ((x (cons env nil)))
 186                    (setf (cdr x) x))))) ; make circular one-list.
 187
 188 (defclass operand-number (abstract-operand)
 189   ((number
 190     :type integer
 191     :initarg number
 192     :reader operand-number)))
 193
 194 (defmethod operand-listform ((operand operand-number))
 195   (list* 'quote
 196          (operand-number operand)))
 197
 198 (defmethod operand-resolve-to-number ((operand operand-number) env)
 199   (declare (ignore env))
 200   (operand-number operand))
 201
 202 ;;; ----------------------------------------------------------------
 203 ;;;     Concrete operands (modelling the "real world" x86 CPU)
 204 ;;; ----------------------------------------------------------------
 205
 206 ;;; ----------------------------------------------------------------
 207 ;;;                          Immediate
 208 ;;; ----------------------------------------------------------------
 209
 210 (defclass operand-immediate (concrete-operand)
 211   ((value
 212     :initarg value
 213     :accessor operand-value)))
 214
 215 (defmethod operand-listform ((obj operand-immediate))
 216   (operand-value obj))
 217
 218 (defmethod print-object ((obj operand-immediate) stream)
 219   (if (and (not *print-readably*)
 220            *print-pretty*)
 221       (progn
 222         (format stream "~A" (slot-value obj 'value))
 223         obj)
 224     (call-next-method obj stream)))
 225
 226 ;;; ----------------------------------------------------------------
 227 ;;;                      Register
 228 ;;; ----------------------------------------------------------------
 229
 230 (defclass operand-register (concrete-operand)
 231   ((register
 232     :initarg register
 233     :accessor operand-register)))
 234
 235 (defmethod operand-listform ((obj operand-register))
 236   (operand-register obj))
 237
 238 (defmethod print-object ((obj operand-register) stream)
 239   (if (and (not *print-readably*)
 240            *print-pretty*)
 241       (progn (format stream "%~A" (slot-value obj 'register))
 242              obj)
 243     (call-next-method obj stream)))
 244
 245 ;;; ----------------------------------------------------------------
 246 ;;;                        Memory operands
 247 ;;; ----------------------------------------------------------------
 248
 249 (defclass operand-memory (concrete-operand)
 250   (referenced-size))
 251
 252 ;;; ----------------------------------------------------------------
 253 ;;;                        Absolute Pointer
 254 ;;; ----------------------------------------------------------------
 255
 256 (defclass operand-direct (operand-memory)
 257   ((address :accessor operand-address
 258             :initarg address)
 259    (segment :accessor operand-segment
 260             :initform nil
 261             :initarg segment)))
 262
 263 (defmethod operand-listform ((obj operand-direct))
 264   (if (null (operand-segment obj))
 265       (list (operand-address obj))
 266     (list (operand-segment obj)
 267           (operand-address obj))))
 268
 269 (defmethod print-object ((obj operand-direct) stream)
 270   (if (not *print-readably*)
 271       (progn
 272         (format stream "[~@[~A:~]~A]"
 273                 (operand-segment obj)
 274                 (operand-address obj))
 275         obj)
 276     (call-next-method obj stream)))
 277
 278 ;;; ----------------------------------------------------------------
 279 ;;;                     PC-Relative Pointer
 280 ;;; ----------------------------------------------------------------
 281
 282 (defclass operand-rel-pointer (operand-memory)
 283   ((offset
 284     :accessor operand-offset
 285     :initarg offset)))
 286
 287 (defmethod operand-listform ((obj operand-rel-pointer))
 288   (list :pc+ (operand-offset obj)))
 289
 290 (defmethod print-object ((obj operand-rel-pointer) stream)
 291   (if (not *print-readably*)
 292       (progn
 293         (format stream "%PC+~A" (slot-value obj 'offset))
 294         obj)
 295     (call-next-method obj stream)))
 296
 297 ;;; ----------------------------------------------------------------
 298 ;;;                  Register-Relative pointer
 299 ;;; ----------------------------------------------------------------
 300
 301 (defclass operand-indirect-register (operand-memory)
 302   ((register
 303     :accessor operand-register
 304     :initarg register)
 305    (register2
 306     :initform nil
 307     :accessor operand-register2
 308     :initarg register2)
 309    (offset
 310     :accessor operand-offset
 311     :initarg offset
 312     :initform 0)
 313    (scale
 314     :type (integer 0 8)                 ; scale for register (not register2)
 315     :initarg scale
 316     :accessor operand-scale
 317     :initform 1)))
 318
 319 (defmethod operand-listform ((obj operand-indirect-register))
 320   (with-slots (offset register scale register2)
 321       obj
 322     (append (unless (and (integerp offset) (zerop offset))
 323               (list offset))
 324             (if (= 1 scale)
 325                 (list register)
 326               (list (list register scale)))
 327             (when register2
 328               (list register2)))))
 329
 330 (defmethod print-object ((obj operand-indirect-register) stream)
 331   (if (not *print-readably*)
 332       (with-slots (offset register2 register scale) obj
 333         (format stream "[~@[~A+~]~@[%~A+~]%~A~@[*~D~]]"
 334                 (unless (and (integerp offset) (zerop offset))
 335                   offset)
 336                 register2
 337                 register
 338                 (when (> scale 1)
 339                   scale))
 340         obj)
 341     (call-next-method obj stream)))
 342
 343 (defun resolve-indirect-register (operand env)
 344   (with-slots (register register2 offset scale) operand
 345     (etypecase offset
 346       (integer
 347        operand)
 348       (symbol
 349        (make-instance 'operand-indirect-register
 350          'offset (symtab-lookup-label (assemble-env-symtab env) offset)
 351          'register register
 352          'register2 register2
 353          'scale scale))
 354       (list
 355        (make-instance 'operand-indirect-register
 356          'offset (apply (car offset)
 357                         (mapcar #'(lambda (o)
 358                                     (etypecase o
 359                                       (integer o)
 360                                       (symbol
 361                                        (symtab-lookup-label (assemble-env-symtab env) o))))
 362                                 (cdr offset)))
 363          'register register
 364          'register2 register2
 365          'scale scale)))))
 366
 367 (defun resolve-direct (operand env)
 368   (with-slots (address segment) operand
 369     (if (not (symbolp address))
 370         operand
 371       (make-instance 'operand-direct
 372         'address (symtab-lookup-label (assemble-env-symtab env) address)
 373         'segment segment))))
 374
 375 ;;; ----------------------------------------------------------------
 376 ;;;             Definition of specialized operand classes
 377 ;;; ----------------------------------------------------------------
 378
 379 (defvar *operand-classes* (make-hash-table :test #'equal))
 380 (defvar *operand-encoding-by-type* (make-hash-table :test #'eq))
 381
 382 (defmacro def-operand-class ((operand-encoding operand-types
 383                               &optional (reg-set (first operand-types)))
 384                              (base-operand-class) slots)
 385   (let ((name (intern (format nil "~A~S~{-~S~}" ; the name isn't really important
 386                               (symbol-name '#:operand-)
 387                               operand-encoding operand-types))))
 388     `(progn
 389        (assert (subtypep (find-class ',base-operand-class)
 390                          (find-class 'operand))
 391            ()
 392          "Base operand-class ~A is not an OPERAND class." ',base-operand-class)
 393        (defclass ,name (,base-operand-class) ,slots)
 394        (defmethod operand-class-register-set ((operand-encoding (eql (find-class ',name))))
 395          (values ',reg-set))
 396        (defmethod operand-class-encoding ((operand-encoding (eql (find-class ',name))))
 397          (values ',operand-encoding))
 398        (defmethod operand-class-base-class ((operand-class (eql (find-class ',name))))
 399          (values (find-class ',base-operand-class)))
 400        ,@(loop for ot in operand-types
 401              appending
 402                `((setf (gethash (cons ',operand-encoding ',ot) *operand-classes*)
 403                    (find-class ',name))
 404                  (pushnew ',operand-encoding
 405                           (gethash ',ot *operand-encoding-by-type*)))))))
 406
 407 (eval-when (:compile-toplevel :load-toplevel :execute)
 408   (defparameter +operand-types-indirect-modrm+
 409       '(r/m8 r/m16 r/m32 m m64
 410         mm/m64 mm/m32
 411         xmm/m128 xmm/m64 xmm/m32
 412         m32real m64real m80real
 413         m16int m32int m64int
 414         m16-16 m16-32)
 415     "This set of operand-types are pointers which are encoded the same way,
 416 but differ in only in what they point to."))
 417
 418 (defmacro def-operand-class-imodrm ((operand-encoding
 419                                      &optional (reg-set nil))
 420                                     (base-operand-class) slots)
 421   `(def-operand-class (,operand-encoding ,+operand-types-indirect-modrm+ ,reg-set)
 422        (,base-operand-class) ,slots))
 423
 424
 425 (defun find-operand-class (operand-encoding operand-type &key (errorp t))
 426   "Locate the operand class that encodes <operand-type> into <operand-encoding>."
 427   (let ((oc (gethash (cons operand-encoding operand-type) *operand-classes*)))
 428     (unless (or oc (not errorp))
 429       (error "couldn't find operand-class for (~A ~A)." operand-encoding operand-type))
 430     (values oc)))
 431
 432 (defun find-operand-type-encodings (operand-type)
 433   (gethash operand-type *operand-encoding-by-type*))
 434
 435 (defmethod operand-decode (operand (encoding (eql nil)) instr-symbolic)
 436   "Fallback when no operand-encoding was specified."
 437   (if (operand-class-encoding (class-of operand))
 438       (operand-decode operand (operand-class-encoding (class-of operand)) instr-symbolic)
 439     (call-next-method operand encoding instr-symbolic)))
 440
 441
 442 ;;; ----------------------------------------------------------------
 443 ;;;                     Operand unification
 444 ;;; ----------------------------------------------------------------
 445
 446 (defgeneric operand-and-encoding-unifies-p (operand encoding operand-type)
 447   (:documentation "This predicate determines if an operand instance may
 448 be encoded in a particular encoding and operand-type."))
 449
 450 (defmethod operand-and-encoding-unifies-p (operand encoding operand-type)
 451   "If no specialized method exists, the operand and encoding don't unify."
 452   (declare (ignore operand encoding operand-type))
 453   (values nil))
 454
 455 (defun operand-unifies-with (operand operand-type)
 456   "Return a list of all encodings this operand unifies with."
 457   (loop for encoding in (find-operand-type-encodings operand-type)
 458       when (operand-and-encoding-unifies-p operand encoding operand-type)
 459       collect encoding))
 460
 461
 462
 463 (defgeneric operand-and-encoding-unify (operand encoding operand-type template instr env)
 464   (:documentation "If OPERAND cannot be encoded in ENCODING and
 465 OPERAND-TYPE, NIL is returned. Otherwise, a concretized OPERAND
 466 is returned (if OPERAND is concrete, the same operand is typically
 467 returned."))
 468
 469 (defmethod operand-and-encoding-unify (operand encoding operand-type template instr env)
 470   "If no specialized method exists, the operand and encoding don't unify."
 471   (declare (ignore operand encoding operand-type template instr env))
 472   (values nil))
 473
 474 ;;; ----------------------------------------------------------------
 475 ;;;                  General, plain operand classes
 476 ;;; ----------------------------------------------------------------
 477
 478 ;;; Displacement
 479
 480 (def-operand-class (plain-displacement (displacement)) (operand-direct) ())
 481
 482 (defmethod operand-and-encoding-unify ((operand operand-direct)
 483                                        (encoding (eql 'plain-displacement))
 484                                        operand-type
 485                                        template instr
 486                                        env)
 487   (declare (ignore operand-type instr))
 488   (let ((resolved-operand (resolve-direct operand env)))
 489     (with-slots (address segment)
 490         resolved-operand
 491       (and (null segment)
 492            (<= 0 address (expt 2 (* 8 (template-instr-displacement-numo template))))
 493            resolved-operand))))
 494
 495 (defmethod operand-decode ((operand operand-direct)
 496                            (encoding (eql 'plain-displacement))
 497                            instr-symbolic)
 498   (setf (operand-address operand)
 499     (slot-value instr-symbolic 'displacement))
 500   (values operand))
 501
 502 (defmethod operand-encode ((operand operand-direct)
 503                            (encoding (eql 'plain-displacement))
 504                            operand-type
 505                            instr-symbolic)
 506   (declare (ignore operand-type))
 507   (setf (slot-value instr-symbolic 'displacement)
 508     (operand-address operand))
 509   (values instr-symbolic '(displacement)))
 510
 511 ;;; Immediate
 512
 513 ;;;(def-operand-class (plain-immediate (immediate)) (operand-immediate) ())
 514 ;;;
 515 ;;;(defmethod operand-and-encoding-unify ((operand operand-immediate)
 516 ;;;                                    (encoding (eql 'plain-immediate))
 517 ;;;                                    operand-type
 518 ;;;                                    template instr
 519 ;;;                                    env)
 520 ;;;  (declare (ignore operand-type instr env))
 521 ;;;  (with-slots (value)
 522 ;;;      operand
 523 ;;;    (and (<= 0 value (expt 2 (* 8 (template-instr-immediate-numo template))))
 524 ;;;      operand)))
 525 ;;;
 526 ;;;(defmethod operand-decode ((operand operand-immediate)
 527 ;;;                        (encoding (eql 'plain-immediate))
 528 ;;;                        instr-symbolic)
 529 ;;;  (setf (operand-value operand)
 530 ;;;    (slot-value instr-symbolic 'immediate))
 531 ;;;  (values operand))
 532 ;;;
 533 ;;;(defmethod operand-encode ((operand operand-immediate)
 534 ;;;                        (encoding (eql 'plain-immediate))
 535 ;;;                        operand-type
 536 ;;;                        instr-symbolic)
 537 ;;;  (declare (ignore operand-type))
 538 ;;;  (setf (slot-value instr-symbolic 'immediate)
 539 ;;;    (operand-value operand))
 540 ;;;  (values instr-symbolic '(immediate)))
 541
 542
 543 ;;; ----------------------------------------------------------------
 544 ;;;                  Specialized operand classes
 545 ;;; ----------------------------------------------------------------
 546
 547
 548 ;;; Direct register operands encoded in the REG of MODR/M.
 549
 550 (def-operand-class (register-reg (r8)) (operand-register) ())
 551 (def-operand-class (register-reg (r16)) (operand-register) ())
 552 (def-operand-class (register-reg (r32)) (operand-register) ())
 553 (def-operand-class (register-reg (sreg)) (operand-register) ())
 554 (def-operand-class (register-reg (mm)) (operand-register) ()) ; MMX
 555 (def-operand-class (register-reg (xmm)) (operand-register) ()) ; SIMD
 556
 557 (defmethod operand-and-encoding-unify ((operand operand-register)
 558                                        (encoding (eql 'register-reg))
 559                                        operand-type
 560                                        template instr
 561                                        env)
 562   (declare (ignore template instr env))
 563   (and (decode-set (find-register-encode-set operand-type)
 564                    (slot-value operand 'register)
 565                    :errorp nil)
 566        operand))
 567
 568 (defmethod operand-decode ((operand operand-register)
 569                            (encoding (eql 'register-reg))
 570                            instr-symbolic)
 571   (setf (operand-register operand)
 572     (decode-set (find-register-decode-set (operand-class-register-set (class-of operand)))
 573                 (slot-value instr-symbolic 'reg)))
 574   (assert (not (null (operand-register operand)))
 575       ((operand-register operand))
 576     "Unable to decode operand value ~A from set ~A"
 577     (slot-value instr-symbolic 'reg)
 578     (find-register-decode-set (operand-class-register-set (class-of operand))))
 579   (values operand))
 580
 581 (defmethod operand-encode ((operand operand-register)
 582                            (encoding (eql 'register-reg))
 583                            operand-type
 584                            instr-symbolic)
 585   (setf (slot-value instr-symbolic 'reg)
 586     (decode-set (find-register-encode-set operand-type)
 587                 (operand-register operand)))
 588   (values instr-symbolic '(reg)))
 589
 590
 591 ;;; Direct register operands encoded in the R/M of of MODR/M.
 592
 593 (def-operand-class (register-r/m (r/m8)) (operand-register) ())
 594 (def-operand-class (register-r/m (r/m16)) (operand-register) ())
 595 (def-operand-class (register-r/m (r/m32)) (operand-register) ())
 596 (def-operand-class (register-r/m (mm/m64)) (operand-register) ()) ; MMX
 597 (def-operand-class (register-r/m (xmm/m128 xmm/m64 xmm/m32)) (operand-register) ()) ; SIMD
 598
 599 (defmethod operand-and-encoding-unify ((operand operand-register)
 600                                        (encoding (eql 'register-r/m))
 601                                        operand-type
 602                                        template instr
 603                                        env)
 604   (declare (ignore template instr env))
 605   (and (decode-set (find-register-encode-set operand-type)
 606                    (slot-value operand 'register)
 607                    :errorp nil)
 608        operand))
 609
 610 (defmethod operand-decode ((operand operand-register)
 611                            (encoding (eql 'register-r/m))
 612                            instr-symbolic)
 613   (assert (= #b11 (slot-value instr-symbolic 'mod)))
 614   (setf (operand-register operand)
 615     (decode-set (find-register-decode-set (operand-class-register-set (class-of operand)))
 616                 (slot-value instr-symbolic 'r/m)))
 617   (values operand))
 618
 619 (defmethod operand-encode ((operand operand-register)
 620                            (encoding (eql 'register-r/m))
 621                            operand-type
 622                            instr-symbolic)
 623   (with-slots (mod r/m)
 624       instr-symbolic
 625     (setf mod #b11
 626           r/m (decode-set (find-register-encode-set operand-type)
 627                           (slot-value operand 'register))))
 628   (values instr-symbolic '(mod r/m)))
 629
 630
 631 ;;; Indirect register operand encoded in R/M,
 632 ;;; with Mod=00 and R/M /= {#b100, #b101}
 633
 634 (def-operand-class-imodrm (indirect-register-mod00) (operand-indirect-register) ())
 635
 636 (defmethod operand-and-encoding-unify ((operand operand-indirect-register)
 637                                        (encoding (eql 'indirect-register-mod00))
 638                                        operand-type
 639                                        template instr
 640                                        env)
 641   (declare (ignore template instr))
 642   (let ((resolved-operand (resolve-indirect-register operand env)))
 643     (with-slots (offset register register2 scale)
 644         resolved-operand
 645       (and (member operand-type +operand-types-indirect-modrm+)
 646            (zerop offset)
 647            (not register2)
 648            (= 1 scale)
 649            (member register '(eax ecx edx ebx esi edi))
 650            resolved-operand))))
 651
 652 (defmethod operand-decode ((operand operand-indirect-register)
 653                            (encoding (eql 'indirect-register-mod00))
 654                            instr-symbolic)
 655   (assert (= #b00 (slot-value instr-symbolic 'mod)))
 656   (assert (/= #b100 #b101 (slot-value instr-symbolic 'r/m)))
 657   (with-slots (register register2 offset scale)
 658       operand
 659     (setf register (decode-set (find-register-decode-set 'r/m32-00)
 660                                (slot-value instr-symbolic 'r/m))
 661           register2 nil
 662           offset 0
 663           scale 1))
 664   (values operand))
 665
 666 (defmethod operand-encode ((operand operand-indirect-register)
 667                            (encoding (eql 'indirect-register-mod00))
 668                            operand-type
 669                            instr-symbolic)
 670   (declare (ignore operand-type))
 671   (with-slots (mod r/m)
 672       instr-symbolic
 673     (setf mod #b00
 674           r/m (decode-set (find-register-encode-set 'r/m32-00)
 675                           (slot-value operand 'register))))
 676   (values instr-symbolic '(mod r/m)))
 677
 678
 679 ;;; Indirect register with MOD=#b00, R/M=#b100 in ModR/M
 680 ;;; and neither index=#b100 nor base=#b101 in SIB.
 681
 682 (def-operand-class-imodrm (indirect-register-00-sib) (operand-indirect-register) ())
 683
 684 (defmethod operand-and-encoding-unify ((operand operand-indirect-register)
 685                                        (encoding (eql 'indirect-register-00-sib))
 686                                        operand-type
 687                                        template instr
 688                                        env)
 689   (declare (ignore template instr))
 690   (let ((resolved-operand (resolve-indirect-register operand env)))
 691     (with-slots (register register2 offset scale)
 692         resolved-operand
 693       (and (member operand-type +operand-types-indirect-modrm+)
 694            (zerop offset)
 695            (member register '(eax ecx edx ebx ebp esi edi))
 696            (member register2 '(eax ecx edx ebx esp esi edi))
 697            (member scale '(1 2 4 8))
 698            resolved-operand))))
 699
 700 (defmethod operand-decode ((operand operand-indirect-register)
 701                            (encoding (eql 'indirect-register-00-sib))
 702                            instr-symbolic)
 703   (assert (= #b00 (slot-value instr-symbolic 'mod)))
 704   (assert (= #b100 (slot-value instr-symbolic 'r/m)))
 705   (assert (/= #b100 (slot-value instr-symbolic 'index)))
 706   (assert (/= #b101 (slot-value instr-symbolic 'base)))
 707   (with-slots (register register2 offset scale)
 708       operand
 709     (setf register2 (decode-set (find-register-decode-set 'sib-base-00)
 710                                (slot-value instr-symbolic 'base))
 711           register (decode-set (find-register-decode-set 'sib-index)
 712                                 (slot-value instr-symbolic 'index))
 713           scale (expt 2 (slot-value instr-symbolic 'scale))
 714           offset 0))
 715   (values operand))
 716 (defmethod operand-encode ((operand operand-indirect-register)
 717                            (encoding (eql 'indirect-register-00-sib))
 718                            operand-type
 719                            instr-symbolic)
 720   (declare (ignore operand-type))
 721   (with-slots (mod r/m base index scale)
 722       instr-symbolic
 723     (setf mod #b00
 724           r/m #b100
 725           base (decode-set (find-register-encode-set 'sib-base-00)
 726                            (slot-value operand 'register2))
 727           index (decode-set (find-register-encode-set 'sib-index)
 728                             (slot-value operand 'register))
 729           scale (cdr (assoc (slot-value operand 'scale)
 730                             '((0 . 0) (1 . 0) (2 . 1) (4 . 2) (8 . 3))))))
 731   (values instr-symbolic '(base index scale)))
 732
 733 ;;; Indirect register with MOD=#b00, R/M=#b100 in ModR/M
 734 ;;; and base=#b101 and index/=#b100 in SIB.
 735
 736 (def-operand-class-imodrm (indirect-register-00-sib-base5) (operand-indirect-register) ())
 737
 738 (defmethod operand-and-encoding-unify ((operand operand-indirect-register)
 739                                        (encoding (eql 'indirect-register-00-sib-base5))
 740                                        operand-type
 741                                        template instr
 742                                        env)
 743   (declare (ignore template instr))
 744   (assert (member operand-type +operand-types-indirect-modrm+))
 745   (let ((resolved-operand (resolve-indirect-register operand env)))
 746     (with-slots (register register2 scale)
 747         resolved-operand
 748       (and (not register2)
 749            (member register '(eax ecx edx ebx ebp esi edi))
 750            (member scale '(1 2 4 8))
 751            resolved-operand))))
 752
 753 (defmethod operand-decode ((operand operand-indirect-register)
 754                            (encoding (eql 'indirect-register-00-sib-base5))
 755                            instr-symbolic)
 756   (assert (= #b00 (slot-value instr-symbolic 'mod)))
 757   (assert (= #b100 (slot-value instr-symbolic 'r/m)))
 758   (assert (= #b101 (slot-value instr-symbolic 'base)))
 759   (assert (/= #b100 (slot-value instr-symbolic 'index)))
 760   (with-slots (register register2 offset scale)
 761       operand
 762     (setf register (decode-set (find-register-decode-set 'sib-index)
 763                                (slot-value instr-symbolic 'index))
 764           register2 nil
 765           offset (realpart (slot-value instr-symbolic 'displacement))
 766           scale (expt 2 (slot-value instr-symbolic 'scale))))
 767   (values operand))
 768 (defmethod operand-encode ((operand operand-indirect-register)
 769                            (encoding (eql 'indirect-register-00-sib-base5))
 770                            operand-type
 771                            instr-symbolic)
 772   (declare (ignore operand-type))
 773   (with-slots (mod r/m base index scale displacement)
 774       instr-symbolic
 775     (setf mod #b00
 776           r/m #b100
 777           base #b101
 778           index (decode-set (find-register-encode-set 'sib-index)
 779                             (slot-value operand 'register))
 780           scale (1- (integer-length (slot-value operand 'scale)))
 781           displacement (realpart (slot-value operand 'offset))))
 782   (values instr-symbolic '(mod r/m base index scale)))
 783
 784
 785 ;;; Indirect register with MOD=#b00, R/M=#b100 in ModR/M
 786 ;;; and base/=#b101 and index=#b100 in SIB.
 787
 788 (def-operand-class-imodrm (indirect-register-00-sib-index4) (operand-indirect-register) ())
 789
 790 (defmethod operand-and-encoding-unify ((operand operand-indirect-register)
 791                                        (encoding (eql 'indirect-register-00-sib-index4))
 792                                        operand-type
 793                                        template instr
 794                                        env)
 795   (declare (ignore template instr))
 796   (assert (member operand-type +operand-types-indirect-modrm+))
 797   (let ((resolved-operand (resolve-indirect-register operand env)))
 798     (with-slots (register register2 offset scale)
 799         resolved-operand
 800       (and register
 801            (zerop offset)
 802            (null register2)
 803            (= 1 scale)
 804            (member register '(eax ecx edx ebx esp esi edi))
 805            resolved-operand))))
 806
 807 (defmethod operand-decode ((operand operand-indirect-register)
 808                            (encoding (eql 'indirect-register-00-sib-index4))
 809                            instr-symbolic)
 810   (assert (= #b00 (slot-value instr-symbolic 'mod)))
 811   (assert (= #b100 (slot-value instr-symbolic 'r/m)))
 812   (assert (= #b100 (slot-value instr-symbolic 'index)))
 813   (assert (/= #b101 (slot-value instr-symbolic 'base)))
 814   (with-slots (register offset scale)
 815       operand
 816     (setf register (decode-set (find-register-decode-set 'sib-base-00)
 817                                (slot-value instr-symbolic 'base))
 818           offset 0
 819           scale 1))
 820   (values operand))
 821
 822 (defmethod operand-encode ((operand operand-indirect-register)
 823                            (encoding (eql 'indirect-register-00-sib-index4))
 824                            operand-type
 825                            instr-symbolic)
 826   (declare (ignore operand-type))
 827   (with-slots (mod r/m index base scale)
 828       instr-symbolic
 829     (setf mod #b00
 830           r/m #b100
 831           index #b100
 832           base (decode-set (find-register-encode-set 'sib-base-00)
 833                            (slot-value operand 'register))
 834           scale 0))
 835   (values instr-symbolic '(mod r/m index base scale)))
 836
 837
 838 ;;; Indirect pointer with MOD=#b00, R/M=#b100 in ModR/M
 839 ;;; and base=#b101 and index=#b100 in SIB.
 840
 841 (def-operand-class-imodrm (indirect-pointer-00-sib-index4-base5) (operand-direct) ())
 842
 843 (defmethod operand-and-encoding-unify ((operand operand-direct)
 844                                        (encoding (eql 'indirect-pointer-00-sib-index4-base5))
 845                                        operand-type
 846                                        template instr
 847                                        env)
 848   (declare (ignore template instr))
 849   (let ((resolved-operand (resolve-direct operand env)))
 850     (assert (member operand-type +operand-types-indirect-modrm+))
 851     (and (null (slot-value resolved-operand 'segment))
 852          resolved-operand)))
 853
 854 (defmethod operand-decode ((operand operand-direct)
 855                            (encoding (eql 'indirect-pointer-00-sib-index4-base5))
 856                            instr-symbolic)
 857   (assert (= #b00 (slot-value instr-symbolic 'mod)))
 858   (assert (= #b100 (slot-value instr-symbolic 'r/m)))
 859   (assert (= #b101 (slot-value instr-symbolic 'base)))
 860   (assert (= #b100 (slot-value instr-symbolic 'index)))
 861   (setf (slot-value operand 'address)
 862     (realpart (slot-value instr-symbolic 'displacement)))
 863   (values operand))
 864
 865 (defmethod operand-encode ((operand operand-direct)
 866                            (encoding (eql 'indirect-pointer-00-sib-index4-base5))
 867                            operand-type
 868                            instr-symbolic)
 869   (declare (ignore operand-type))
 870   (with-slots (mod r/m base index scale displacement)
 871       instr-symbolic
 872     (setf mod #b00
 873           r/m #b100
 874           base #b101
 875           index #b100
 876           scale 0 ; don't care
 877           displacement (slot-value operand 'address)))
 878   (values instr-symbolic '(mod r/m base index displacement)))
 879
 880 ;;; Indirect pointer with MOD=#b00, R/M=#b101 in ModR/M
 881
 882 (def-operand-class-imodrm (indirect-pointer-00) (operand-direct) ())
 883
 884 (defmethod operand-and-encoding-unify ((operand operand-direct)
 885                                        (encoding (eql 'indirect-pointer-00))
 886                                        operand-type
 887                                        template instr
 888                                        env)
 889   (declare (ignore template instr))
 890   (assert (member operand-type +operand-types-indirect-modrm+))
 891   (let ((resolved-operand (resolve-direct operand env)))
 892     (and (null (slot-value resolved-operand 'segment))
 893          resolved-operand)))
 894
 895 (defmethod operand-decode ((operand operand-direct)
 896                            (encoding (eql 'indirect-pointer-00))
 897                            instr-symbolic)
 898   (assert (= #b00 (slot-value instr-symbolic 'mod)))
 899   (assert (= #b101 (slot-value instr-symbolic 'r/m)))
 900   (setf (slot-value operand 'address)
 901     (realpart (slot-value instr-symbolic 'displacement)))
 902   (values operand))
 903
 904 (defmethod operand-encode ((operand operand-direct)
 905                            (encoding (eql 'indirect-pointer-00))
 906                            operand-type
 907                            instr-symbolic)
 908   (declare (ignore operand-type))
 909   (with-slots (mod r/m displacement)
 910       instr-symbolic
 911     (setf mod #b00
 912           r/m #b101
 913           displacement (realpart (slot-value operand 'address))))
 914   (values instr-symbolic '(mod r/m displacement)))
 915
 916
 917 ;;; Indirect register with MOD=#b01, R/M/=#b100 in ModR/M.
 918
 919 (def-operand-class-imodrm (indirect-register-01) (operand-indirect-register) ())
 920
 921 (defmethod operand-and-encoding-unify ((operand operand-indirect-register)
 922                                        (encoding (eql 'indirect-register-01))
 923                                        operand-type
 924                                        template instr
 925                                        env)
 926   (declare (ignore template instr))
 927   (assert (member operand-type +operand-types-indirect-modrm+))
 928   (let ((resolved-operand (resolve-indirect-register operand env)))
 929     (with-slots (register register2 offset scale)
 930         resolved-operand
 931       (and (= 1 scale)
 932            (member register '(eax ecx edx ebx ebp esi edi))
 933            (not register2)
 934            (<= -128 offset 127)
 935            resolved-operand))))
 936
 937 (defmethod operand-decode ((operand operand-indirect-register)
 938                            (encoding (eql 'indirect-register-01))
 939                            instr-symbolic)
 940   (assert (= #b01 (slot-value instr-symbolic 'mod)))
 941   (assert (/= #b100 (slot-value instr-symbolic 'r/m)))
 942   (with-slots (mod r/m displacement)
 943       instr-symbolic
 944     (with-slots (register offset)
 945         operand
 946       (setf register (decode-set (find-register-decode-set 'r/m32-01)
 947                                  r/m)
 948             offset (realpart displacement))))
 949   (values operand))
 950
 951 (defmethod operand-encode ((operand operand-indirect-register)
 952                            (encoding (eql 'indirect-register-01))
 953                            operand-type
 954                            instr-symbolic)
 955   (declare (ignore operand-type))
 956   (with-slots (mod r/m displacement)
 957       instr-symbolic
 958     (setf mod #b01
 959           r/m (decode-set (find-register-encode-set 'r/m32-01)
 960                           (slot-value operand 'register))
 961           displacement (realpart (slot-value operand 'offset))))
 962   (values instr-symbolic '(mod r/m displacement)))
 963
 964 ;;; Indirect register with MOD=#b01, R/M=#b100 in ModR/M,
 965 ;;; index/=#b100 in SIB.
 966
 967 (def-operand-class-imodrm (indirect-register-01-sib) (operand-indirect-register) ())
 968
 969 (defmethod operand-and-encoding-unify ((operand operand-indirect-register)
 970                                        (encoding (eql 'indirect-register-01-sib))
 971                                        operand-type
 972                                        template instr
 973                                        env)
 974   (declare (ignore template instr))
 975   (assert (member operand-type +operand-types-indirect-modrm+))
 976   (let ((resolved-operand (resolve-indirect-register operand env)))
 977     (with-slots (register register2 offset scale)
 978         resolved-operand
 979       (cond
 980        ((and (member register '(eax ecx edx ebx ebp esi edi))
 981              (member register2 '(eax ecx edx ebx esp ebp esi edi))
 982              (member scale '(1 2 4 8) :test #'=)
 983              (<= -128 offset 127))
 984         resolved-operand)
 985        ((and (member register2 '(eax ecx edx ebx ebp esi edi))
 986              (member register '(eax ecx edx ebx esp ebp esi edi))
 987              (= scale 1)
 988              (<= -128 offset 127))
 989         ;; exchange register and register2
 990         (make-instance 'operand-indirect-register
 991           'offset offset
 992           'register register2
 993           'register2 register
 994           'scale 1))
 995        (t nil)))))
 996
 997 (defmethod operand-decode ((operand operand-indirect-register)
 998                            (encoding (eql 'indirect-register-01-sib))
 999                            instr-symbolic)
1000   (assert (= #b01 (slot-value instr-symbolic 'mod)))
1001   (assert (= #b100 (slot-value instr-symbolic 'r/m)))
1002   (assert (/= #b100 (slot-value instr-symbolic 'index)))
1003   (with-slots (register register2 scale offset)
1004       operand
1005     (setf register (decode-set (find-register-decode-set 'sib-index)
1006                                (slot-value instr-symbolic 'index))
1007           scale (expt 2 (slot-value instr-symbolic 'scale))
1008           register2 (decode-set (find-register-decode-set 'sib-base)
1009                                 (slot-value instr-symbolic 'base))
1010           offset (realpart (slot-value instr-symbolic 'displacement)))) ; disp8
1011   (values operand))
1012
1013
1014 (defmethod operand-encode ((operand operand-indirect-register)
1015                            (encoding (eql 'indirect-register-01-sib))
1016                            operand-type
1017                            instr-symbolic)
1018   (declare (ignore operand-type))
1019   (with-slots (mod r/m scale index base displacement)
1020       instr-symbolic
1021     (setf mod #b01
1022           r/m #b100
1023           index (decode-set (find-register-encode-set 'sib-index)
1024                             (slot-value operand 'register))
1025           scale (1- (integer-length (slot-value operand 'scale)))
1026           base (decode-set (find-register-encode-set 'sib-base)
1027                            (slot-value operand 'register2))
1028           displacement (slot-value operand 'offset)))
1029   (values instr-symbolic '(mod r/m scale index base displacement)))
1030
1031
1032 ;;; Indirect register with MOD=#b01, R/M=#b100 in ModR/M,
1033 ;;; index=#b100 in SIB.
1034
1035 (def-operand-class-imodrm (indirect-register-01-sib-index4) (operand-indirect-register) ())
1036
1037 (defmethod operand-and-encoding-unify ((operand operand-indirect-register)
1038                                        (encoding (eql 'indirect-register-01-sib-index4))
1039                                        operand-type
1040                                        template instr
1041                                        env)
1042   (declare (ignore template instr))
1043   (assert (member operand-type +operand-types-indirect-modrm+))
1044   (let ((resolved-operand (resolve-indirect-register operand env)))
1045     (with-slots (register register2 offset scale)
1046         resolved-operand
1047       (and (member register '(eax ecx edx ebx esp ebp esi edi))
1048            (not register2)
1049            (<= -128 offset 127)
1050            (= 1 scale)
1051            resolved-operand))))
1052
1053 (defmethod operand-decode ((operand operand-indirect-register)
1054                            (encoding (eql 'indirect-register-01-sib-index4))
1055                            instr-symbolic)
1056   (assert (= #b01 (slot-value instr-symbolic 'mod)))
1057   (assert (= #b100 (slot-value instr-symbolic 'r/m)))
1058   (assert (= #b100 (slot-value instr-symbolic 'index)))
1059   (with-slots (register offset scale)
1060       operand
1061     (setf register (decode-set (find-register-decode-set 'sib-base)
1062                                (slot-value instr-symbolic 'base))
1063           offset (realpart (slot-value instr-symbolic 'displacement))
1064           scale 1))
1065   (values operand))
1066
1067 (defmethod operand-encode ((operand operand-indirect-register)
1068                            (encoding (eql 'indirect-register-01-sib-index4))
1069                            operand-type
1070                            instr-symbolic)
1071   (declare (ignore operand-type))
1072   (with-slots (mod r/m index base scale displacement)
1073       instr-symbolic
1074     (setf mod #b01
1075           r/m #b100
1076           index #b100
1077           base (decode-set (find-register-encode-set 'sib-base)
1078                            (slot-value operand 'register))
1079           scale 0                       ; don't care
1080           displacement (slot-value operand 'offset)))
1081   (values instr-symbolic '(mod r/m index base scale displacement)))
1082
1083
1084 ;;; Indirect register with MOD=#b10, R/M/=#b100 in ModR/M.
1085
1086 (def-operand-class-imodrm (indirect-register-10) (operand-indirect-register) ())
1087
1088 (defmethod operand-and-encoding-unify ((operand operand-indirect-register)
1089                                        (encoding (eql 'indirect-register-10))
1090                                        operand-type
1091                                        template instr
1092                                        env)
1093   (declare (ignore template instr))
1094   (assert (member operand-type +operand-types-indirect-modrm+))
1095   (let ((resolved-operand (resolve-indirect-register operand env)))
1096     (with-slots (register register2 offset scale)
1097         resolved-operand
1098       (and (= 1 scale)
1099            (member register '(eax ecx edx ebx ebp esi edi))
1100            (not register2)
1101            (<= #x-80000000 offset #xffffffff)
1102            resolved-operand))))
1103
1104 (defmethod operand-decode ((operand operand-indirect-register)
1105                            (encoding (eql 'indirect-register-10))
1106                            instr-symbolic)
1107   (assert (= #b10 (slot-value instr-symbolic 'mod)))
1108   (assert (/= #b100 (slot-value instr-symbolic 'r/m)))
1109   (with-slots (mod r/m displacement)
1110       instr-symbolic
1111     (with-slots (register offset)
1112         operand
1113       (setf register (decode-set (find-register-decode-set 'r/m32-01)
1114                                  r/m)
1115             offset (realpart displacement))))
1116   (values operand))
1117 (defmethod operand-encode ((operand operand-indirect-register)
1118                            (encoding (eql 'indirect-register-10))
1119                            operand-type
1120                            instr-symbolic)
1121   (declare (ignore operand-type))
1122   (with-slots (mod r/m displacement)
1123       instr-symbolic
1124     (setf mod #b10
1125           r/m (decode-set (find-register-encode-set 'r/m32-01)
1126                           (slot-value operand 'register))
1127           displacement (realpart (slot-value operand 'offset))))
1128   (values instr-symbolic '(mod r/m displacement)))
1129
1130 ;;; Indirect register with MOD=#b10, R/M=#b100 in ModR/M,
1131 ;;; index/=#b100 in SIB.
1132
1133 (def-operand-class-imodrm (indirect-register-10-sib) (operand-indirect-register) ())
1134
1135 (defmethod operand-and-encoding-unify ((operand operand-indirect-register)
1136                                        (encoding (eql 'indirect-register-10-sib))
1137                                        operand-type
1138                                        template instr
1139                                        env)
1140   (declare (ignore template instr))
1141   (assert (member operand-type +operand-types-indirect-modrm+))
1142   (let ((resolved-operand (resolve-indirect-register operand env)))
1143     (with-slots (register register2 offset scale)
1144         resolved-operand
1145       (and (member register '(eax ecx edx ebx ebp esi edi))
1146            (member register2 '(eax ecx edx ebx esp ebp esi edi))
1147            (member scale '(1 2 4 8))
1148            (<= #x-80000000 offset #xffffffff)
1149            resolved-operand))))
1150
1151 (defmethod operand-decode ((operand operand-indirect-register)
1152                            (encoding (eql 'indirect-register-10-sib))
1153                            instr-symbolic)
1154   (assert (= #b10 (slot-value instr-symbolic 'mod)))
1155   (assert (= #b100 (slot-value instr-symbolic 'r/m)))
1156   (assert (/= #b100 (slot-value instr-symbolic 'index)))
1157   (with-slots (register register2 scale offset)
1158       operand
1159     (setf register (decode-set (find-register-decode-set 'sib-index)
1160                                (slot-value instr-symbolic 'index))
1161           scale (expt 2 (slot-value instr-symbolic 'scale))
1162           register2 (decode-set (find-register-decode-set 'sib-base)
1163                                 (slot-value instr-symbolic 'base))
1164           offset (realpart (slot-value instr-symbolic 'displacement)))) ; disp8
1165   (values operand))
1166
1167
1168 (defmethod operand-encode ((operand operand-indirect-register)
1169                            (encoding (eql 'indirect-register-10-sib))
1170                            operand-type
1171                            instr-symbolic)
1172   (declare (ignore operand-type))
1173   (with-slots (mod r/m scale index base displacement)
1174       instr-symbolic
1175     (setf mod #b10
1176           r/m #b100
1177           index (decode-set (find-register-encode-set 'sib-index)
1178                             (slot-value operand 'register))
1179           scale (1- (integer-length (slot-value operand 'scale)))
1180           base (decode-set (find-register-encode-set 'sib-base)
1181                            (slot-value operand 'register2))
1182           displacement (slot-value operand 'offset)))
1183   (values instr-symbolic '(mod r/m scale index base displacement)))
1184
1185 ;;; Indirect register with MOD=#b10, R/M=#b100 in ModR/M,
1186 ;;; index=#b100 in SIB.
1187
1188 (def-operand-class-imodrm (indirect-register-10-sib-index4) (operand-indirect-register) ())
1189
1190 (defmethod operand-and-encoding-unify ((operand operand-indirect-register)
1191                                        (encoding (eql 'indirect-register-10-sib-index4))
1192                                        operand-type
1193                                        template instr
1194                                        env)
1195   (declare (ignore template instr))
1196   (assert (member operand-type +operand-types-indirect-modrm+))
1197   (let ((resolved-operand (resolve-indirect-register operand env)))
1198     (with-slots (register register2 offset scale)
1199         resolved-operand
1200       (and (member register '(eax ecx edx ebx esp ebp esi edi))
1201            (not register2)
1202            (<= #x-80000000 offset #xffffffff)
1203            (= 1 scale)
1204            resolved-operand))))
1205
1206 (defmethod operand-decode ((operand operand-indirect-register)
1207                            (encoding (eql 'indirect-register-10-sib-index4))
1208                            instr-symbolic)
1209   (assert (= #b10 (slot-value instr-symbolic 'mod)))
1210   (assert (= #b100 (slot-value instr-symbolic 'r/m)))
1211   (assert (= #b100 (slot-value instr-symbolic 'index)))
1212   (with-slots (register offset scale)
1213       operand
1214     (setf register (decode-set (find-register-decode-set 'sib-base)
1215                                (slot-value instr-symbolic 'base))
1216           offset (realpart (slot-value instr-symbolic 'displacement))
1217           scale 1))
1218   (values operand))
1219
1220 (defmethod operand-encode ((operand operand-indirect-register)
1221                            (encoding (eql 'indirect-register-10-sib-index4))
1222                            operand-type
1223                            instr-symbolic)
1224   (declare (ignore operand-type))
1225   (with-slots (mod r/m index base scale displacement)
1226       instr-symbolic
1227     (setf mod #b10
1228           r/m #b100
1229           index #b100
1230           base (decode-set (find-register-encode-set 'sib-base)
1231                            (slot-value operand 'register))
1232           scale 0                       ; don't care
1233           displacement (slot-value operand 'offset)))
1234   (values instr-symbolic '(mod r/m index base scale displacement)))
1235
1236 ;;; Indirect 16-bit register with MOD=#b00, R/M/=#b110 in ModR/M,
1237
1238 (def-operand-class-imodrm (16bit-indirect-register-mod00) (operand-indirect-register) ())
1239
1240 (defmethod operand-and-encoding-unify ((operand operand-indirect-register)
1241                                        (encoding (eql '16bit-indirect-register-mod00))
1242                                        operand-type
1243                                        template instr
1244                                        env)
1245   (declare (ignore template instr))
1246   (assert (member operand-type +operand-types-indirect-modrm+))
1247   (let ((resolved-operand (resolve-indirect-register operand env)))
1248     (with-slots (register register2 offset scale)
1249         resolved-operand
1250       (and (= offset 0)
1251            (= scale 1)
1252            (if register2
1253                (and (member register '(bx bp))
1254                     (member register2 '(si di)))
1255              (member register '(si di bx)))
1256            resolved-operand))))
1257
1258 (defmethod operand-decode ((operand operand-indirect-register)
1259                            (encoding (eql '16bit-indirect-register-mod00))
1260                            instr-symbolic)
1261   (assert (= #b00 (slot-value instr-symbolic 'mod)))
1262   (assert (/= #b110 (slot-value instr-symbolic 'r/m)))
1263   (with-slots (register register2 offset scale)
1264       operand
1265     (destructuring-bind (r1 . r2)
1266         (decode-set (find-register-decode-set 'r/m-16bit)
1267                     (slot-value instr-symbolic 'r/m))
1268       (setf register r1
1269             register2 r2
1270             offset 0
1271             scale 1)))
1272   (values operand))
1273
1274 (defmethod operand-encode ((operand operand-indirect-register)
1275                            (encoding (eql '16bit-indirect-register-mod00))
1276                            operand-type
1277                            instr-symbolic)
1278   (declare (ignore operand-type))
1279   (with-slots (mod r/m)
1280       instr-symbolic
1281     (setf mod #b00
1282           r/m (decode-set (find-register-encode-set 'r/m-16bit)
1283                           (cons (slot-value operand 'register)
1284                                 (slot-value operand 'register2)))))
1285   (values instr-symbolic '(mod r/m)))
1286
1287 ;;; Indirect 16bit pointer with MOD=#b00, R/M=#b110 in ModR/M.
1288
1289 (def-operand-class-imodrm (16bit-indirect-pointer) (operand-direct) ())
1290
1291 (defmethod operand-and-encoding-unify ((operand operand-direct)
1292                                        (encoding (eql '16bit-indirect-pointer))
1293                                        operand-type
1294                                        template instr
1295                                        env)
1296   (declare (ignore template instr))
1297   (assert (member operand-type +operand-types-indirect-modrm+))
1298   (let ((resolved-operand (resolve-direct operand env)))
1299     (with-slots (address segment)
1300         resolved-operand
1301       (and (null segment)
1302            (<= 0 address #xffff)
1303            resolved-operand))))
1304
1305 (defmethod operand-decode ((operand operand-direct)
1306                            (encoding (eql '16bit-indirect-pointer))
1307                            instr-symbolic)
1308   (assert (= #b00 (slot-value instr-symbolic 'mod)))
1309   (assert (= #b110 (slot-value instr-symbolic 'r/m)))
1310   (with-slots (address)
1311       operand
1312     (setf address (realpart (slot-value instr-symbolic 'displacement))))
1313   (values operand))
1314
1315 (defmethod operand-encode ((operand operand-direct)
1316                            (encoding (eql '16bit-indirect-pointer))
1317                            operand-type
1318                            instr-symbolic)
1319   (declare (ignore operand-type))
1320   (with-slots (mod r/m displacement)
1321       instr-symbolic
1322     (setf mod #b00
1323           r/m #b110
1324           displacement (slot-value operand 'address)))
1325   (values instr-symbolic '(mod r/m displacement)))
1326
1327 ;;; Indirect 16-bit register with MOD=#b01 in ModR/M.
1328
1329 (def-operand-class-imodrm (16bit-indirect-register-mod01) (operand-indirect-register) ())
1330
1331 (defmethod operand-and-encoding-unify ((operand operand-indirect-register)
1332                                        (encoding (eql '16bit-indirect-register-mod01))
1333                                        operand-type
1334                                        template instr
1335                                        env)
1336   (declare (ignore template instr))
1337   (assert (member operand-type +operand-types-indirect-modrm+))
1338   (let ((resolved-operand (resolve-indirect-register operand env)))
1339     (with-slots (register register2 offset scale)
1340         resolved-operand
1341       (and (= scale 1)
1342            (<= -128 offset 127)
1343            (if register2
1344                (and (member register '(bx bp))
1345                     (member register2 '(si di)))
1346              (member register '(si di bp bx)))
1347            resolved-operand))))
1348
1349 (defmethod operand-decode ((operand operand-indirect-register)
1350                            (encoding (eql '16bit-indirect-register-mod01))
1351                            instr-symbolic)
1352   (assert (= #b01 (slot-value instr-symbolic 'mod)))
1353   (with-slots (register register2 offset scale)
1354       operand
1355     (destructuring-bind (r1 . r2)
1356         (decode-set (find-register-decode-set 'r/m-16bit)
1357                     (slot-value instr-symbolic 'r/m))
1358       (setf register r1
1359             register2 r2
1360             offset (sign-extend (realpart (slot-value instr-symbolic 'displacement)) 1)
1361             scale 1)))
1362   (values operand))
1363
1364 (defmethod operand-encode ((operand operand-indirect-register)
1365                            (encoding (eql '16bit-indirect-register-mod01))
1366                            operand-type
1367                            instr-symbolic)
1368   (declare (ignore operand-type))
1369   (with-slots (mod r/m displacement)
1370       instr-symbolic
1371     (setf mod #b01
1372           r/m (decode-set (find-register-encode-set 'r/m-16bit)
1373                           (cons (slot-value operand 'register)
1374                                 (slot-value operand 'register2)))
1375           displacement (slot-value operand 'offset)))
1376   (values instr-symbolic '(mod r/m displacement)))
1377
1378 ;;; Indirect 16-bit register with MOD=#b10 in ModR/M.
1379
1380 (def-operand-class-imodrm (16bit-indirect-register-mod10) (operand-indirect-register) ())
1381
1382 (defmethod operand-and-encoding-unify ((operand operand-indirect-register)
1383                                        (encoding (eql '16bit-indirect-register-mod10))
1384                                        operand-type
1385                                        template instr
1386                                        env)
1387   (declare (ignore template instr))
1388   (assert (member operand-type +operand-types-indirect-modrm+))
1389   (let ((resolved-operand (resolve-indirect-register operand env)))
1390     (with-slots (register register2 offset scale)
1391         resolved-operand
1392       (and (= scale 1)
1393            (<= 0 offset #xffff)
1394            (if register2
1395                (and (member register '(bx bp))
1396                     (member register2 '(si di)))
1397              (member register '(si di bp bx)))
1398            resolved-operand))))
1399
1400 (defmethod operand-decode ((operand operand-indirect-register)
1401                            (encoding (eql '16bit-indirect-register-mod10))
1402                            instr-symbolic)
1403   (assert (= #b10 (slot-value instr-symbolic 'mod)))
1404   (with-slots (register register2 offset scale)
1405       operand
1406     (destructuring-bind (r1 . r2)
1407         (decode-set (find-register-decode-set 'r/m-16bit)
1408                     (slot-value instr-symbolic 'r/m))
1409       (setf register r1
1410             register2 r2
1411             offset (realpart (slot-value instr-symbolic 'displacement))
1412             scale 1)))
1413   (values operand))
1414
1415 (defmethod operand-encode ((operand operand-indirect-register)
1416                            (encoding (eql '16bit-indirect-register-mod10))
1417                            operand-type
1418                            instr-symbolic)
1419   (declare (ignore operand-type))
1420   (assert (<= 0 (slot-value operand 'offset) #xffff))
1421   (with-slots (mod r/m displacement)
1422       instr-symbolic
1423     (setf mod #b10
1424           r/m (decode-set (find-register-encode-set 'r/m-16bit)
1425                           (cons (slot-value operand 'register)
1426                                 (slot-value operand 'register2)))
1427           displacement (slot-value operand 'offset)))
1428   (values instr-symbolic '(mod r/m displacement)))
1429
1430 ;;; Absolute pointer encoded in the moffs operand-type
1431
1432 (def-operand-class (abs-pointer-moffs (moffs8 moffs16 moffs32))
1433     (operand-direct) ())
1434
1435 (defmethod operand-and-encoding-unify ((operand operand-direct)
1436                                        (encoding (eql 'abs-pointer-moffs))
1437                                        operand-type
1438                                        template instr
1439                                        env)
1440   (declare (ignore template instr))
1441   (let ((resolved-operand (resolve-direct operand env)))
1442     (with-slots (address)
1443         resolved-operand
1444       (and
1445        (ecase operand-type
1446          (moffs8  (<= 0 address #xff))
1447          (moffs16 (<= 0 address #xffff))
1448          (moffs32 (<= 0 address #xffffffff)))
1449        resolved-operand))))
1450
1451 (defmethod operand-decode ((operand operand-direct)
1452                            (encoding (eql 'abs-pointer-moffs))
1453                            instr-symbolic)
1454   (with-slots (address)
1455       operand
1456     (setf address (realpart (slot-value instr-symbolic 'displacement))))
1457   (values operand))
1458
1459 (defmethod operand-encode ((operand operand-direct)
1460                            (encoding (eql 'abs-pointer-moffs))
1461                            operand-type
1462                            instr-symbolic)
1463   (declare (ignore operand-type))
1464   (with-slots (displacement)
1465       instr-symbolic
1466     (setf displacement (slot-value operand 'address)))
1467   (values instr-symbolic '(displacement)))
1468
1469 ;;; Register constants (no encoding)
1470
1471 (eval-when (:compile-toplevel :load-toplevel :execute)
1472   (defparameter +constant-register-operands+
1473       '(al ah ax eax
1474         bl bh bx ebx
1475         dl dh dx edx
1476         cl ch cx ecx
1477         cs ds es fs gs ss
1478         cr0 cr2 cr3 cr4
1479         dr0 dr1 dr2 dr3 dr4 dr5 dr6 dr7)))
1480
1481 (defmacro def-many-constant-registers (cr-list)
1482   (cons 'cl:progn
1483         (loop for cr in (symbol-value cr-list)
1484             collect `(def-operand-class (register-constant (,cr)) (operand-register) ()))))
1485
1486 (def-many-constant-registers +constant-register-operands+)
1487
1488 (defmethod operand-and-encoding-unify ((operand operand-register)
1489                                        (encoding (eql 'register-constant))
1490                                        operand-type
1491                                        template instr
1492                                        env)
1493   (declare (ignore template instr env))
1494   (assert (member operand-type +constant-register-operands+))
1495   (and (eq operand-type
1496            (slot-value operand 'register))
1497        operand))
1498
1499 (defmethod operand-decode ((operand operand-register)
1500                            (encoding (eql 'register-constant))
1501                            instr-symbolic)
1502   (declare (ignore instr-symbolic))
1503   (with-slots (register)
1504       operand
1505     (setf register (operand-class-register-set (class-of operand))))
1506   (values operand))
1507
1508 (defmethod operand-encode ((operand operand-register)
1509                            (encoding (eql 'register-constant))
1510                            operand-type
1511                            instr-symbolic)
1512   (declare (ignore operand-type))
1513   (values instr-symbolic '()))
1514
1515
1516 ;;; Immediate constants (no encoding)
1517
1518 (def-operand-class (register-constant (1)) (operand-immediate) ())
1519
1520 (defmethod operand-and-encoding-unify ((operand operand-immediate)
1521                                        (encoding (eql 'register-constant))
1522                                        operand-type
1523                                        template instr
1524                                        env)
1525   (declare (ignore template instr env))
1526   (and (= operand-type
1527           (slot-value operand 'value))
1528    operand))
1529
1530 (defmethod operand-decode ((operand operand-immediate)
1531                            (encoding (eql 'register-constant))
1532                            instr-symbolic)
1533   (declare (ignore instr-symbolic))
1534   (with-slots (value)
1535       operand
1536     (setf value (operand-class-register-set (class-of operand))))
1537   (values operand))
1538
1539 (defmethod operand-encode ((operand operand-immediate)
1540                            (encoding (eql 'register-constant))
1541                            operand-type
1542                            instr-symbolic)
1543   (declare (ignore operand-type))
1544   (values instr-symbolic '()))
1545
1546
1547 ;;; Register encoded in the opcode (plus-format).
1548
1549 (def-operand-class (register-plus (+r8)) (operand-register) ())
1550 (def-operand-class (register-plus (+r16)) (operand-register) ())
1551 (def-operand-class (register-plus (+r32)) (operand-register) ())
1552
1553 (defmethod operand-and-encoding-unify ((operand operand-register)
1554                                        (encoding (eql 'register-plus))
1555                                        operand-type
1556                                        template instr
1557                                        env)
1558   (declare (ignore template instr env))
1559   (with-slots (register)
1560       operand
1561     (and (ecase operand-type
1562            ((+r8) (member register '(al cl dl bl ah ch dh bh)))
1563            ((+r16) (member register '(ax cx dx bx sp bp si di)))
1564            ((+r32) (member register '(eax ecx edx ebx esp ebp esi edi))))
1565          operand)))
1566
1567 (defmethod operand-decode ((operand operand-register)
1568                            (encoding (eql 'register-plus))
1569                            instr-symbolic)
1570   (with-slots (register)
1571       operand
1572     (setf register
1573       (decode-set (find-register-decode-set (operand-class-register-set (class-of operand)))
1574                   (ldb (byte 3 0)
1575                        (slot-value instr-symbolic 'opcode)))))
1576   (values operand))
1577
1578 (defmethod operand-encode ((operand operand-register)
1579                            (encoding (eql 'register-plus))
1580                            operand-type
1581                            instr-symbolic)
1582   (with-slots (opcode)
1583       instr-symbolic
1584     (setf (ldb (byte 3 0) opcode)
1585       (decode-set (find-register-encode-set operand-type)
1586                   (slot-value operand 'register))))
1587   (values instr-symbolic '(opcode)))
1588
1589
1590 ;;; Immediate values
1591
1592 (def-operand-class (immediate (imm8 simm8 imm16 simm32 imm32)) (operand-immediate) ())
1593
1594 (defmethod operand-and-encoding-unify ((operand operand-immediate)
1595                                        (encoding (eql 'immediate))
1596                                        operand-type
1597                                        template instr
1598                                        env)
1599   (declare (ignore template instr env))
1600   (with-slots (value)
1601       operand
1602     (and (ecase operand-type
1603            (simm8 (<= #x-80 value #x7f))
1604            (imm8  (<= 0 value #xff))
1605            (imm16 (<= 0 value #xffff))
1606            (simm32 (<= #x-80000000 value #xffffffff))
1607            (imm32 (<= 0 value #xffffffff)))
1608          operand)))
1609
1610 (defmethod operand-and-encoding-unify ((operand abstract-operand)
1611                                        (encoding (eql 'immediate))
1612                                        operand-type
1613                                        template instr
1614                                        env)
1615   (operand-and-encoding-unify (make-instance 'operand-immediate
1616                                 'value (operand-resolve-to-number operand env))
1617                               encoding operand-type
1618                               template instr env))
1619
1620 (defmethod operand-decode ((operand operand-immediate)
1621                            (encoding (eql 'immediate))
1622                            instr-symbolic)
1623   (with-slots (value)
1624       operand
1625     (setf value (sign-extend (realpart (slot-value instr-symbolic 'immediate))
1626                              (imagpart (slot-value instr-symbolic 'immediate)))))
1627   (values operand))
1628
1629 (defmethod operand-encode ((operand operand-immediate)
1630                            (encoding (eql 'immediate))
1631                            operand-type
1632                            instr-symbolic)
1633   (declare (ignore operand-type))
1634   (unless (instr-symbolic-reg instr-symbolic)
1635     (setf (instr-symbolic-reg instr-symbolic) 0)) ; don't care)
1636   (with-slots (immediate)
1637       instr-symbolic
1638     (setf immediate (slot-value operand 'value)))
1639   (values instr-symbolic '(immediate)))
1640
1641 ;;; PC-relative addresses
1642
1643 (def-operand-class (pc-relative (rel8 rel16 rel32)) (operand-rel-pointer) ())
1644
1645 (defmethod operand-and-encoding-unify ((operand operand-rel-pointer)
1646                                        (encoding (eql 'pc-relative))
1647                                        operand-type
1648                                        template instr
1649                                        env)
1650   (declare (ignore template instr env))
1651   (with-slots (offset)
1652       operand
1653     (and (ecase operand-type
1654            ((rel8)  (<= #x-80 offset #x7f))
1655            ((rel16) (<= #x-8000 offset #x7fff))
1656            ((rel32) (<= #x-80000000 offset #x7fffffff)))
1657          operand)))
1658
1659 (defmethod operand-and-encoding-unify ((operand abstract-operand)
1660                                        (encoding (eql 'pc-relative))
1661                                        operand-type
1662                                        template instr
1663                                        env)
1664   (ecase operand-type
1665     ((rel8 rel32)
1666      (operand-and-encoding-unify (make-instance 'operand-rel-pointer
1667                                    'offset (abstract-operand-to-offset operand
1668                                                                        template
1669                                                                        instr
1670                                                                        env))
1671                                  encoding operand-type
1672                                  template instr env))
1673     ((rel16)
1674      ;; rel16 operands cause EIP to be masked with #x0000ffff
1675      (and (<= 0 (operand-resolve-to-number operand env) #x0000ffff)
1676           (operand-and-encoding-unify (make-instance 'operand-rel-pointer
1677                                         'offset (abstract-operand-to-offset operand
1678                                                                             template
1679                                                                             instr
1680                                                                             env))
1681                                       encoding operand-type
1682                                       template instr env)))))
1683
1684 (defmethod operand-decode ((operand operand-rel-pointer)
1685                            (encoding (eql 'pc-relative))
1686                            instr-symbolic)
1687   (with-slots (offset)
1688       operand
1689     (setf offset
1690       (realpart (slot-value instr-symbolic 'displacement))))
1691   (values operand))
1692
1693 (defmethod operand-encode ((operand operand-rel-pointer)
1694                            (encoding (eql 'pc-relative))
1695                            operand-type
1696                            instr-symbolic)
1697   (declare (ignore operand-type))
1698   (with-slots (displacement)
1699       instr-symbolic
1700     (setf displacement
1701       (slot-value operand 'offset)))
1702   (values instr-symbolic '(displacement)))
1703
1704 ;;; 32-bit Segmented addresses
1705
1706 (def-operand-class (ptr16-32 (ptr16-32)) (operand-direct) ())
1707
1708 (defmethod operand-and-encoding-unify ((operand operand-direct)
1709                                        (encoding (eql 'ptr16-32))
1710                                        operand-type
1711                                        template instr
1712                                        env)
1713   (declare (ignore template instr))
1714   (assert (eq operand-type 'ptr16-32))
1715   (let ((resolved-operand (resolve-direct operand env)))
1716     (with-slots (address segment)
1717         resolved-operand
1718       (and address
1719            (<= 0 address #xffffffff)
1720            segment
1721            (<= 0 segment #xffff)
1722            resolved-operand))))
1723
1724 (defmethod operand-decode ((operand operand-direct)
1725                            (encoding (eql 'ptr16-32))
1726                            instr-symbolic)
1727   (with-slots (address segment)
1728       operand
1729     (setf
1730         address (ldb (byte 32 0) (realpart (instr-symbolic-displacement instr-symbolic)))
1731         segment (ldb (byte 16 32) (realpart (instr-symbolic-displacement instr-symbolic)))))
1732   (values operand))
1733
1734 (defmethod operand-encode ((operand operand-direct)
1735                            (encoding (eql 'ptr16-32))
1736                            operand-type
1737                            instr-symbolic)
1738   (declare (ignore operand-type))
1739   (with-slots (displacement)
1740       instr-symbolic
1741     (setf
1742         (ldb (byte 32 0) displacement) (slot-value operand 'address)
1743         (ldb (byte 16 32) displacement) (slot-value operand 'segment)))
1744   (values instr-symbolic '(displacement)))
1745
1746 ;;; 16-bit Segmented addresses
1747
1748 (def-operand-class (ptr16-16 (ptr16-16)) (operand-direct) ())
1749
1750 (defmethod operand-and-encoding-unify ((operand operand-direct)
1751                                        (encoding (eql 'ptr16-16))
1752                                        operand-type
1753                                        template instr
1754                                        env)
1755   (declare (ignore template instr))
1756   (assert (eq operand-type 'ptr16-16))
1757   (let ((resolved-operand (resolve-direct operand env)))
1758     (with-slots (address segment)
1759         resolved-operand
1760       (and address
1761            (<= 0 address #xffff)
1762            segment
1763            (<= 0 segment #xffff)
1764            resolved-operand))))
1765
1766 (defmethod operand-decode ((operand operand-direct)
1767                            (encoding (eql 'ptr16-16))
1768                            instr-symbolic)
1769   (with-slots (address segment)
1770       operand
1771     (setf
1772         address (ldb (byte 16 0) (realpart (instr-symbolic-displacement instr-symbolic)))
1773         segment (ldb (byte 16 16) (realpart (instr-symbolic-displacement instr-symbolic)))))
1774   (values operand))
1775
1776 (defmethod operand-encode ((operand operand-direct)
1777                            (encoding (eql 'ptr16-16))
1778                            operand-type
1779                            instr-symbolic)
1780   (declare (ignore operand-type))
1781   (with-slots (displacement)
1782       instr-symbolic
1783     (setf displacement 0
1784           (ldb (byte 16 0) displacement) (slot-value operand 'address)
1785           (ldb (byte 16 16) displacement) (slot-value operand 'segment)))
1786   (values instr-symbolic '(displacement)))
1787
1788 ;;; Two immediate operands (for ENTER)
1789
1790 (def-operand-class (imm16-8 (imm16-8)) (operand-immediate) ())
1791
1792 (defmethod operand-and-encoding-unify ((operand operand-immediate)
1793                                        (encoding (eql 'imm16-8))
1794                                        operand-type
1795                                        template instr
1796                                        env)
1797   (declare (ignore template instr env))
1798   (assert (eq operand-type 'imm16-8))
1799   (with-slots (value)
1800       operand
1801     (and (<= 0 value #xffff)
1802          operand)))
1803
1804 (defmethod operand-decode ((operand operand-immediate)
1805                            (encoding (eql 'imm16-8))
1806                            instr-symbolic)
1807   (with-slots (value)
1808       operand
1809     (setf value (ldb (byte 16 0)
1810                      (realpart (slot-value instr-symbolic 'immediate)))))
1811   (values operand))
1812
1813 (defmethod operand-encode ((operand operand-immediate)
1814                            (encoding (eql 'imm16-8))
1815                            operand-type
1816                            instr-symbolic)
1817   (assert (eq operand-type 'imm16-8)
1818       (operand-type))
1819   (unless (instr-symbolic-immediate instr-symbolic)
1820     (setf (slot-value instr-symbolic 'immediate) 0))
1821   (with-slots (immediate)
1822       instr-symbolic
1823     (setf (ldb (byte 16 0) immediate)
1824       (slot-value operand 'value)))
1825   (values instr-symbolic '(immediate)))
1826
1827
1828 ;;; Two immediate operands (for ENTER)
1829
1830 (def-operand-class (imm8-0 (imm8-0)) (operand-immediate) ())
1831
1832 (defmethod operand-and-encoding-unify ((operand operand-immediate)
1833                                        (encoding (eql 'imm8-0))
1834                                        operand-type
1835                                        template instr
1836                                        env)
1837   (declare (ignore template instr env))
1838   (assert (eq operand-type 'imm8-0))
1839   (with-slots (value)
1840       operand
1841     (and (<= 0 value #x7f)
1842          operand)))
1843
1844 (defmethod operand-decode ((operand operand-immediate)
1845                            (encoding (eql 'imm8-0))
1846                            instr-symbolic)
1847   (with-slots (value)
1848       operand
1849     (setf value (ldb (byte 8 16)
1850                      (realpart (slot-value instr-symbolic 'immediate)))))
1851   (values operand))
1852
1853 (defmethod operand-encode ((operand operand-immediate)
1854                            (encoding (eql 'imm8-0))
1855                            operand-type
1856                            instr-symbolic)
1857   (assert (eq operand-type 'imm8-0)
1858       (operand-type))
1859   (unless (instr-symbolic-immediate instr-symbolic)
1860     (setf (slot-value instr-symbolic 'immediate) 0))
1861   (with-slots (immediate)
1862       instr-symbolic
1863     (setf (ldb (byte 8 16) immediate)
1864       (slot-value operand 'value)))
1865   (values instr-symbolic '(immediate)))
1866
1867
1868