(define-source-transform nth (n l) `(car (nthcdr ,n ,l)))
+(define-source-transform last (x) `(sb!impl::last1 ,x))
+(define-source-transform gethash (&rest args)
+ (case (length args)
+ (2 `(sb!impl::gethash2 ,@args))
+ (3 `(sb!impl::gethash3 ,@args))
+ (t (values nil t))))
+(define-source-transform get (&rest args)
+ (case (length args)
+ (2 `(sb!impl::get2 ,@args))
+ (3 `(sb!impl::get3 ,@args))
+ (t (values nil t))))
+
(defvar *default-nthcdr-open-code-limit* 6)
(defvar *extreme-nthcdr-open-code-limit* 20)
(if (and (floatp y)
(float-infinity-p y))
nil
- (set-bound (funcall f (type-bound-number x)) (consp x)))))))
+ (set-bound y (consp x)))))))
;;; Apply a binary operator OP to two bounds X and Y. The result is
;;; NIL if either is NIL. Otherwise bound is computed and the result
;;; is open if either X or Y is open.
;;;
;;; FIXME: only used in this file, not needed in target runtime
+
+;;; ANSI contaigon specifies coercion to floating point if one of the
+;;; arguments is floating point. Here we should check to be sure that
+;;; the other argument is within the bounds of that floating point
+;;; type.
+
+(defmacro safely-binop (op x y)
+ `(cond
+ ((typep ,x 'single-float)
+ (if (or (typep ,y 'single-float)
+ (<= most-negative-single-float ,y most-positive-single-float))
+ (,op ,x ,y)))
+ ((typep ,x 'double-float)
+ (if (or (typep ,y 'double-float)
+ (<= most-negative-double-float ,y most-positive-double-float))
+ (,op ,x ,y)))
+ ((typep ,y 'single-float)
+ (if (<= most-negative-single-float ,x most-positive-single-float)
+ (,op ,x ,y)))
+ ((typep ,y 'double-float)
+ (if (<= most-negative-double-float ,x most-positive-double-float)
+ (,op ,x ,y)))
+ (t (,op ,x ,y))))
+
(defmacro bound-binop (op x y)
`(and ,x ,y
(with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero)
- (set-bound (,op (type-bound-number ,x)
- (type-bound-number ,y))
+ (set-bound (safely-binop ,op (type-bound-number ,x)
+ (type-bound-number ,y))
(or (consp ,x) (consp ,y))))))
+(defun coerce-for-bound (val type)
+ (if (consp val)
+ (list (coerce-for-bound (car val) type))
+ (cond
+ ((subtypep type 'double-float)
+ (if (<= most-negative-double-float val most-positive-double-float)
+ (coerce val type)))
+ ((or (subtypep type 'single-float) (subtypep type 'float))
+ ;; coerce to float returns a single-float
+ (if (<= most-negative-single-float val most-positive-single-float)
+ (coerce val type)))
+ (t (coerce val type)))))
+
+(defun coerce-and-truncate-floats (val type)
+ (when val
+ (if (consp val)
+ (list (coerce-and-truncate-floats (car val) type))
+ (cond
+ ((subtypep type 'double-float)
+ (if (<= most-negative-double-float val most-positive-double-float)
+ (coerce val type)
+ (if (< val most-negative-double-float)
+ most-negative-double-float most-positive-double-float)))
+ ((or (subtypep type 'single-float) (subtypep type 'float))
+ ;; coerce to float returns a single-float
+ (if (<= most-negative-single-float val most-positive-single-float)
+ (coerce val type)
+ (if (< val most-negative-single-float)
+ most-negative-single-float most-positive-single-float)))
+ (t (coerce val type))))))
+
;;; Convert a numeric-type object to an interval object.
(defun numeric-type->interval (x)
(declare (type numeric-type x))
(when (eq (numeric-type-class result-type) 'float)
(setf result (interval-func
#'(lambda (x)
- (coerce x (or (numeric-type-format result-type)
- 'float)))
+ (coerce-for-bound x (or (numeric-type-format result-type)
+ 'float)))
result)))
(make-numeric-type
:class (if (and (eq (numeric-type-class x) 'integer)
(when (eq (numeric-type-class result-type) 'float)
(setf result (interval-func
#'(lambda (x)
- (coerce x (or (numeric-type-format result-type)
- 'float)))
+ (coerce-for-bound x (or (numeric-type-format result-type)
+ 'float)))
result)))
(make-numeric-type
:class (if (and (eq (numeric-type-class x) 'integer)
(when (eq (numeric-type-class result-type) 'float)
(setf result (interval-func
#'(lambda (x)
- (coerce x (or (numeric-type-format result-type)
- 'float)))
+ (coerce-for-bound x (or (numeric-type-format result-type)
+ 'float)))
result)))
(make-numeric-type
:class (if (and (eq (numeric-type-class x) 'integer)
(when (eq (numeric-type-class result-type) 'float)
(setf result (interval-func
#'(lambda (x)
- (coerce x (or (numeric-type-format result-type)
- 'float)))
+ (coerce-for-bound x (or (numeric-type-format result-type)
+ 'float)))
result)))
(make-numeric-type :class (numeric-type-class result-type)
:format (numeric-type-format result-type)
:class class
:format format
:complexp :real
- :low (coerce-numeric-bound (interval-low abs-bnd) bound-type)
- :high (coerce-numeric-bound
+ :low (coerce-and-truncate-floats (interval-low abs-bnd) bound-type)
+ :high (coerce-and-truncate-floats
(interval-high abs-bnd) bound-type))))))
#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(when (member rem-type '(float single-float double-float
#!+long-float long-float))
(setf rem (interval-func #'(lambda (x)
- (coerce x rem-type))
+ (coerce-for-bound x rem-type))
rem)))
(make-numeric-type :class class
:format format
;; Make sure that the limits on the interval have
;; the right type.
(setf rem (interval-func (lambda (x)
- (coerce x result-type))
+ (coerce-for-bound x result-type))
rem)))
(make-numeric-type :class class
:format format
(when (stringp x)
(check-format-args x args 'format)))))
+;;; We disable this transform in the cross-compiler to save memory in
+;;; the target image; most of the uses of FORMAT in the compiler are for
+;;; error messages, and those don't need to be particularly fast.
+#+sb-xc
(deftransform format ((dest control &rest args) (t simple-string &rest t) *
:policy (> speed space))
(unless (constant-lvar-p control)
projects / sbcl.git / blobdiff