Changeset 11544


Ignore:
Timestamp:
01/04/09 22:16:29 (12 years ago)
Author:
ehuelsmann
Message:

Add bounds checking and prepare for support for 'wide' instruction prefix.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

    r11543 r11544  
    157157  (declare (optimize speed))
    158158  (declare (type (unsigned-byte 16) n))
     159  (when (not (<= 0 n 65535))
     160    (error "u2 argument ~A out of 65k range." n))
    159161  (list (logand (ash n -8) #xff)
    160162        (logand n #xff)))
     163
     164(defknown s1 (fixnum) fixnum)
     165(defun s1 (n)
     166  (declare (optimize speed))
     167  (declare (type (signed-byte 8) n))
     168  (when (not (<= -128 n 127))
     169    (error "s2 argument ~A out of 16-bit signed range." n))
     170  (if (< n 0)
     171      (1+ (logxor (- n) #xFF))
     172      n))
     173
     174
     175(defknown s2 (fixnum) cons)
     176(defun s2 (n)
     177  (declare (optimize speed))
     178  (declare (type (signed-byte 16) n))
     179  (when (not (<= -32768 n 32767))
     180    (error "s2 argument ~A out of 16-bit signed range." n))
     181  (u2 (if (< n 0) (1+ (logxor (- n) #xFFFF))
     182          n)))
    161183
    162184(defconstant +java-string+ "Ljava/lang/String;")
     
    202224(defconstant +lisp-stream-class+ "org/armedbear/lisp/Stream")
    203225
    204 (defstruct (instruction (:constructor make-instruction (opcode args)))
     226(defstruct (instruction (:constructor %make-instruction (opcode args)))
    205227  (opcode 0 :type (integer 0 255))
    206228  args
    207229  stack
    208   depth)
     230  depth
     231  wide)
     232
     233(defun make-instruction (opcode args)
     234  (let ((inst (apply #'%make-instruction
     235                     (list opcode
     236                           (remove :wide-prefix args)))))
     237    (when (memq :wide-prefix args)
     238      (setf (inst-wide inst) t))
     239    inst))
    209240
    210241(defun print-instruction (instruction)
     
    10281059           (inst 16 (logand n #xff))) ; BIPUSH
    10291060          (t ; SIPUSH
    1030            (inst 17 (u2 n))))))
     1061           (inst 17 (s2 n))))))
    10311062
    10321063;; invokevirtual, invokespecial, invokestatic class-name method-name descriptor
     
    10751106         (register (first args))
    10761107         (n (second args)))
    1077     (inst 132 (list register (logand n #xff)))))
     1108    (when (not (<= -128 n 127))
     1109      (error "IINC argument ~A out of bounds." n))
     1110    (inst 132 (list register (s1 n)))))
    10781111
    10791112(defknown resolve-instruction (t) t)
     
    14911524            (let* ((label (car (instruction-args instruction)))
    14921525                   (offset (- (the (unsigned-byte 16) (symbol-value (the symbol label))) index)))
    1493               (setf (instruction-args instruction) (u2 offset))))
     1526              (setf (instruction-args instruction) (s2 offset))))
    14941527          (unless (= (instruction-opcode instruction) 202) ; LABEL
    14951528            (incf index (opcode-size (instruction-opcode instruction)))))))
Note: See TracChangeset for help on using the changeset viewer.