Changeset 11633


Ignore:
Timestamp:
02/06/09 20:51:34 (12 years ago)
Author:
ehuelsmann
Message:

Clean up DERIVE-TYPE-{MIN,MAX,ASH} using the new DERIVE-TYPE-NUMERIC-OP infrastructure.
This eliminates the need for WHEN-ARGS-INTEGER (sorry, Ville)...

File:
1 edited

Legend:

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

    r11632 r11633  
    62076207  (list 'INTEGER 0 '*))
    62086208
    6209 (defmacro when-args-integer (args typenames decls &body body)
    6210   "Checks types of the args provided, if all args are
    6211 integer, splits them into high/low bytes and invokes the body.
    6212 
    6213 args contains the arguments for which the type check is done.
    6214 typenames contains names of variables to which the type, low byte
    6215 and high byte of the provided arg is stored, to be used in
    6216 the body.
    6217 decls contains declarations used in the body, similar to let.
    6218 body is the body to invoke. "
    6219   (labels ((build-let-when (body args typenames)
    6220      (when args
    6221        (let ((type (third typenames))
    6222        (low (second typenames))
    6223        (high (first typenames)))
    6224          (setf body
    6225          `(let ((,type (derive-compiler-type ,(first args))))
    6226       (when (integer-type-p ,type)
    6227         (let ((,low (integer-type-low ,type))
    6228         (,high (integer-type-high ,type)))
    6229           ,body)))))
    6230        (let ((tmpbody
    6231         (build-let-when body (cdr args) (cdddr typenames))))
    6232          (if tmpbody
    6233        tmpbody
    6234        body)))))
    6235     (build-let-when
    6236      `(let (,@decls) ,@body)
    6237      (reverse args) (reverse typenames))))
    6238 
    62396209
    62406210(defmacro define-int-bounds-derivation (name (low1 high1 low2 high2)
     
    62466216             (declare (ignorable ,low1 ,high1 ,low2 ,high2))
    62476217             ,@body)))
    6248 
    62496218
    62506219(defun derive-integer-type (op type1 type2)
     
    62806249     (double-float integer double-float)
    62816250     (double-float single-float double-float))
     6251    ((ash)
     6252     (integer integer ,#'derive-integer-type))
    62826253    ((min max)
    62836254     (integer integer ,#'derive-integer-type)
     
    63866357(declaim (ftype (function (t) t) derive-type-max))
    63876358(defun derive-type-max (form)
    6388   (dolist (arg (cdr form) (make-compiler-type 'FIXNUM))
    6389     (unless (fixnum-type-p (derive-compiler-type arg))
    6390       (return t))))
     6359  (let ((op (car form))
     6360        (args (cdr form)))
     6361    (flet ((combine (x y)
     6362             (derive-type-numeric-op op x y)))
     6363      (reduce #'combine (cdr args)
     6364              :initial-value (car args)))))
    63916365
    63926366(defknown derive-type-min (t) t)
    63936367(defun derive-type-min (form)
    6394   (let ((args (cdr form))
    6395         (result-type t))
    6396     (when (= (length form) 3)
    6397       (when-args-integer
    6398        ((%car args) (%cadr args))
    6399        (type1 low1 high1 type2 low2 high2)
    6400        (low high)
    6401        (setf low (if (and low1 low2)
    6402          (min low1 low2)
    6403          nil)
    6404        high (if (and high1 high2)
    6405           (min high1 high2)
    6406           nil))
    6407        (setf result-type (%make-integer-type low high))))
    6408     result-type))
     6368  (let ((op (car form))
     6369        (args (cdr form)))
     6370    (flet ((combine (x y)
     6371             (derive-type-numeric-op op x y)))
     6372      (reduce #'combine (cdr args)
     6373              :initial-value (car args)))))
    64096374
    64106375;; read-char &optional input-stream eof-error-p eof-value recursive-p => char
     
    64156380      t))
    64166381
     6382
     6383(define-int-bounds-derivation ash (low1 high1 low2 high2)
     6384  (when (and low1 high1 low2 high2)
     6385    (cond
     6386      ((and (>= low1 0) (>= high1 0) (>= low2 0) (>= high2 0))
     6387       ;; Everything is non-negative.
     6388       (values (ash low1 low2)
     6389               (unless (<= 64 high2)
     6390                 (ash high1 high2))))
     6391      ((and (>= low1 0) (>= high1 0) (<= low2 0) (<= high2 0))
     6392       ;; Negative (or zero) second argument.
     6393       (values (ash low1 low2)
     6394               (ash high1 high2))))))
     6395
    64176396;; ash integer count => shifted-integer
    64186397(defknown derive-type-ash (t) t)
    64196398(defun derive-type-ash (form)
    6420   (let* ((args (cdr form))
    6421          (arg1 (first args))
    6422          (arg2 (second args))
    6423          (result-type 'INTEGER))
    6424     (when-args-integer
    6425      (arg1 arg2)
    6426      (type1 low1 high1 type2 low2 high2)
    6427      ()
    6428      (when (and low1 high1 low2 high2)
    6429        (cond ((fixnum-constant-value type2)
    6430         (setf arg2 (fixnum-constant-value type2))
    6431         (cond ((<= -64 arg2 64)
    6432          (setf result-type
    6433          (list 'INTEGER (ash low1 arg2) (ash high1 arg2))))
    6434         ((minusp arg2)
    6435          (setf result-type
    6436          (list 'INTEGER
    6437          (if (minusp low1) -1 0)
    6438          (if (minusp high1) -1 0))))))
    6439        ((and (>= low1 0) (>= high1 0) (>= low2 0) (>= high2 0))
    6440         ;; Everything is non-negative.
    6441         (setf result-type (list 'INTEGER
    6442               (ash low1 low2)
    6443                                       (if (<= 64 high2)
    6444                                           '* (ash high1 high2)))))
    6445        ((and (>= low1 0) (>= high1 0) (<= low2 0) (<= high2 0))
    6446         ;; Negative (or zero) second argument.
    6447         (setf result-type (list 'INTEGER
    6448               (ash low1 low2)
    6449               (ash high1 high2)))))))
    6450     (make-compiler-type result-type)))
     6399  (derive-type-numeric-op (car form)
     6400                          (derive-compiler-type (cadr form))
     6401                          (derive-compiler-type (caddr form))))
    64516402
    64526403(defknown derive-type (t) t)
Note: See TracChangeset for help on using the changeset viewer.