:low (if lo-float-zero-p
(if (consp lo)
(list (float 0.0 lo-val))
- (float -0.0 lo-val))
+ (float (load-time-value (make-unportable-float :single-float-negative-zero)) lo-val))
lo)
:high (if hi-float-zero-p
(if (consp hi)
- (list (float -0.0 hi-val))
+ (list (float (load-time-value (make-unportable-float :single-float-negative-zero)) hi-val))
(float 0.0 hi-val))
hi))
type))
;;; FIXME: MAKE-CANONICAL-UNION-TYPE and CONVERT-MEMBER-TYPE probably
;;; belong in the kernel's type logic, invoked always, instead of in
-;;; the compiler, invoked only during some type optimizations.
+;;; the compiler, invoked only during some type optimizations. (In
+;;; fact, as of 0.pre8.100 or so they probably are, under
+;;; MAKE-MEMBER-TYPE, so probably this code can be deleted)
;;; Take a list of types and return a canonical type specifier,
;;; combining any MEMBER types together. If both positive and negative
(setf members (union members (member-type-members type)))
(push type misc-types)))
#!+long-float
- (when (null (set-difference '(-0l0 0l0) members))
- (push (specifier-type '(long-float 0l0 0l0)) misc-types)
- (setf members (set-difference members '(-0l0 0l0))))
- (when (null (set-difference '(-0d0 0d0) members))
- (push (specifier-type '(double-float 0d0 0d0)) misc-types)
- (setf members (set-difference members '(-0d0 0d0))))
- (when (null (set-difference '(-0f0 0f0) members))
- (push (specifier-type '(single-float 0f0 0f0)) misc-types)
- (setf members (set-difference members '(-0f0 0f0))))
+ (when (null (set-difference `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0) members))
+ (push (specifier-type '(long-float 0.0l0 0.0l0)) misc-types)
+ (setf members (set-difference members `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0))))
+ (when (null (set-difference `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0) members))
+ (push (specifier-type '(double-float 0.0d0 0.0d0)) misc-types)
+ (setf members (set-difference members `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0))))
+ (when (null (set-difference `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0) members))
+ (push (specifier-type '(single-float 0.0f0 0.0f0)) misc-types)
+ (setf members (set-difference members `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0))))
(if members
(apply #'type-union (make-member-type :members members) misc-types)
(apply #'type-union misc-types))))
(specifier-type 'base-char))
(defoptimizer (values derive-type) ((&rest values))
- (values-specifier-type
- `(values ,@(mapcar (lambda (x)
- (type-specifier (continuation-type x)))
- values))))
+ (make-values-type :required (mapcar #'continuation-type values)))
\f
;;;; byte operations
;;;;
;;; negated test as appropriate. If it is a degenerate one-arg call,
;;; then we transform to code that returns true. Otherwise, we bind
;;; all the arguments and expand into a bunch of IFs.
-(declaim (ftype (function (symbol list boolean) *) multi-compare))
-(defun multi-compare (predicate args not-p)
+(declaim (ftype (function (symbol list boolean t) *) multi-compare))
+(defun multi-compare (predicate args not-p type)
(let ((nargs (length args)))
(cond ((< nargs 1) (values nil t))
- ((= nargs 1) `(progn ,@args t))
+ ((= nargs 1) `(progn (the ,type ,@args) t))
((= nargs 2)
(if not-p
`(if (,predicate ,(first args) ,(second args)) nil t)
`(if (,predicate ,current ,last)
,result nil))))
((zerop i)
- `((lambda ,vars ,result) . ,args)))))))
-
-(define-source-transform = (&rest args) (multi-compare '= args nil))
-(define-source-transform < (&rest args) (multi-compare '< args nil))
-(define-source-transform > (&rest args) (multi-compare '> args nil))
-(define-source-transform <= (&rest args) (multi-compare '> args t))
-(define-source-transform >= (&rest args) (multi-compare '< args t))
-
-(define-source-transform char= (&rest args) (multi-compare 'char= args nil))
-(define-source-transform char< (&rest args) (multi-compare 'char< args nil))
-(define-source-transform char> (&rest args) (multi-compare 'char> args nil))
-(define-source-transform char<= (&rest args) (multi-compare 'char> args t))
-(define-source-transform char>= (&rest args) (multi-compare 'char< args t))
+ `((lambda ,vars (declare (type ,type ,@vars)) ,result)
+ ,@args)))))))
+
+(define-source-transform = (&rest args) (multi-compare '= args nil 'number))
+(define-source-transform < (&rest args) (multi-compare '< args nil 'real))
+(define-source-transform > (&rest args) (multi-compare '> args nil 'real))
+(define-source-transform <= (&rest args) (multi-compare '> args t 'real))
+(define-source-transform >= (&rest args) (multi-compare '< args t 'real))
+
+(define-source-transform char= (&rest args) (multi-compare 'char= args nil
+ 'character))
+(define-source-transform char< (&rest args) (multi-compare 'char< args nil
+ 'character))
+(define-source-transform char> (&rest args) (multi-compare 'char> args nil
+ 'character))
+(define-source-transform char<= (&rest args) (multi-compare 'char> args t
+ 'character))
+(define-source-transform char>= (&rest args) (multi-compare 'char< args t
+ 'character))
(define-source-transform char-equal (&rest args)
- (multi-compare 'char-equal args nil))
+ (multi-compare 'char-equal args nil 'character))
(define-source-transform char-lessp (&rest args)
- (multi-compare 'char-lessp args nil))
+ (multi-compare 'char-lessp args nil 'character))
(define-source-transform char-greaterp (&rest args)
- (multi-compare 'char-greaterp args nil))
+ (multi-compare 'char-greaterp args nil 'character))
(define-source-transform char-not-greaterp (&rest args)
- (multi-compare 'char-greaterp args t))
+ (multi-compare 'char-greaterp args t 'character))
(define-source-transform char-not-lessp (&rest args)
- (multi-compare 'char-lessp args t))
+ (multi-compare 'char-lessp args t 'character))
;;; This function does source transformation of N-arg inequality
;;; functions such as /=. This is similar to MULTI-COMPARE in the <3
;;; arg cases. If there are more than two args, then we expand into
;;; the appropriate n^2 comparisons only when speed is important.
-(declaim (ftype (function (symbol list) *) multi-not-equal))
-(defun multi-not-equal (predicate args)
+(declaim (ftype (function (symbol list t) *) multi-not-equal))
+(defun multi-not-equal (predicate args type)
(let ((nargs (length args)))
(cond ((< nargs 1) (values nil t))
- ((= nargs 1) `(progn ,@args t))
+ ((= nargs 1) `(progn (the ,type ,@args) t))
((= nargs 2)
`(if (,predicate ,(first args) ,(second args)) nil t))
((not (policy *lexenv*
(next (cdr vars) (cdr next))
(result t))
((null next)
- `((lambda ,vars ,result) . ,args))
+ `((lambda ,vars (declare (type ,type ,@vars)) ,result)
+ ,@args))
(let ((v1 (first var)))
(dolist (v2 next)
(setq result `(if (,predicate ,v1 ,v2) nil ,result))))))))))
-(define-source-transform /= (&rest args) (multi-not-equal '= args))
-(define-source-transform char/= (&rest args) (multi-not-equal 'char= args))
+(define-source-transform /= (&rest args)
+ (multi-not-equal '= args 'number))
+(define-source-transform char/= (&rest args)
+ (multi-not-equal 'char= args 'character))
(define-source-transform char-not-equal (&rest args)
- (multi-not-equal 'char-equal args))
-
-;;; FIXME: can go away once bug 194 is fixed and we can use (THE REAL X)
-;;; as God intended
-(defun error-not-a-real (x)
- (error 'simple-type-error
- :datum x
- :expected-type 'real
- :format-control "not a REAL: ~S"
- :format-arguments (list x)))
+ (multi-not-equal 'char-equal args 'character))
;;; Expand MAX and MIN into the obvious comparisons.
(define-source-transform max (arg0 &rest rest)
(error "can't understand type ~S~%" element-type))))))
(cond ((array-type-p array-type)
(get-element-type array-type))
- ((union-type-p array-type)
+ ((union-type-p array-type)
(apply #'type-union
(mapcar #'get-element-type (union-type-types array-type))))
(t
(loop for i of-type index
from (ash current-heap-size -1) downto 1 do
(%heapify i))
- (loop
+ (loop
(when (< current-heap-size 2)
(return))
(rotatef (%elt 1) (%elt current-heap-size))
projects / sbcl.git / blobdiff