mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
Portably read float and complex literals without special syntax.
* Instead of using a special $ character, just portably modify the XC readtable to do the right thing for floats by installing reader macros for every possible initial character for a float. Special care needs to be taken for #\., since consing dot needs to work. As of the time of this commit, CCL, ECL, and CLISP break without installing a left parenthesis macro that can also communicate with our new dot reader macro, while SBCL and CMU CL do just fine without the additional new left parenthesis character macro. It's unclear to me which behavior is correct, and it may be the case that the standard is underspecified in the situation where a reader macro is installed for dot and then someone tries to read in a dotted list. In any case, installing a left parenthesis reader macro for everybody is a portable solution that is guaranteed to work everywhere. * Also just install a reader macro for #c which constructs target complex numbers instead of writing out the constant construction manually. * This avoids the big hack where we intercepted reading normal number syntax in the reader only for specific versions of SBCL to catch float and complex literals written the normal way and flame. Now we can make sure host float and complex number literals never show up during the build when bootstrapping from *any* host Lisp, by never allowing host float and complex literals to be read in in the first place. * This change uncovered a bug in CCL, whereby it was no longer able to read #:-cache correctly. I've filed a bug for this here https://github.com/Clozure/ccl/issues/489 and worked around the issue by just replacing it with its string name, since it was only used as an argument for SYMBOLICATE. * ECL also needs some help with the radix readers. See comment for bug report.
This commit is contained in:
Charles Zhang
parent
1013909c01
commit
aac931b3de
|
|
@ -1063,18 +1063,18 @@ between the ~A definition and the ~A definition"
|
|||
:translation (complex single-float)
|
||||
:inherits (complex number)
|
||||
:codes (,sb-vm:complex-single-float-widetag)
|
||||
:prototype-form ,(complex $0f0 $0f0))
|
||||
:prototype-form ,(complex 0f0 0f0))
|
||||
(complex-double-float
|
||||
:translation (complex double-float)
|
||||
:inherits (complex number)
|
||||
:codes (,sb-vm:complex-double-float-widetag)
|
||||
:prototype-form ,(complex $0d0 $0d0))
|
||||
:prototype-form ,(complex 0d0 0d0))
|
||||
#+long-float
|
||||
(complex-long-float
|
||||
:translation (complex long-float)
|
||||
:inherits (complex number)
|
||||
:codes (,sb-vm:complex-long-float-widetag)
|
||||
:prototype-form ,(complex $0L0 $0L0))
|
||||
:prototype-form ,(complex 0L0 0L0))
|
||||
#+sb-simd-pack
|
||||
(simd-pack
|
||||
:translation simd-pack
|
||||
|
|
@ -1089,23 +1089,23 @@ between the ~A definition and the ~A definition"
|
|||
;; (%make-simd-pack-256-ub64 42 42 42 42)
|
||||
sb-pcl:+slot-unbound+)
|
||||
(real :translation real :inherits (number) :prototype-form 0)
|
||||
(float :translation float :inherits (real number) :prototype-form $0f0)
|
||||
(float :translation float :inherits (real number) :prototype-form 0f0)
|
||||
(single-float
|
||||
:translation single-float
|
||||
:inherits (float real number)
|
||||
:codes (,sb-vm:single-float-widetag)
|
||||
:prototype-form $0f0)
|
||||
:prototype-form 0f0)
|
||||
(double-float
|
||||
:translation double-float
|
||||
:inherits (float real number)
|
||||
:codes (,sb-vm:double-float-widetag)
|
||||
:prototype-form $0d0)
|
||||
:prototype-form 0d0)
|
||||
#+long-float
|
||||
(long-float
|
||||
:translation long-float
|
||||
:inherits (float real number)
|
||||
:codes (,sb-vm:long-float-widetag)
|
||||
:prototype-form $0L0)
|
||||
:prototype-form 0L0)
|
||||
(rational
|
||||
:translation rational :inherits (real number) :prototype-form 0)
|
||||
(ratio
|
||||
|
|
@ -1307,14 +1307,11 @@ between the ~A definition and the ~A definition"
|
|||
(list* name :predicate predicate :translation translation (cdr x))))
|
||||
*builtin-classoids*)))
|
||||
|
||||
;;; The read interceptor has to be disabled to avoid infinite recursion on CTYPEs
|
||||
(eval-when (:compile-toplevel) (setq sb-cold::*choke-on-host-irrationals* nil))
|
||||
#-sb-xc-host
|
||||
(define-load-time-global *builtin-classoids* nil)
|
||||
#-sb-xc-host
|
||||
(!cold-init-forms
|
||||
(setq *builtin-classoids* '#.(compute-builtin-classoids)))
|
||||
(eval-when (:compile-toplevel) (setq sb-cold::*choke-on-host-irrationals* t))
|
||||
|
||||
;;; See also src/code/type-init.lisp where we finish setting up the
|
||||
;;; translations for built-in types.
|
||||
|
|
|
|||
|
|
@ -112,7 +112,7 @@
|
|||
(imag nil :type real :read-only t))
|
||||
|
||||
(defmethod print-object ((obj complexnum) stream)
|
||||
(write-string "#.(COMPLEX " stream)
|
||||
(write-string "#C( " stream)
|
||||
(prin1 (complexnum-real obj) stream)
|
||||
(write-char #\Space stream)
|
||||
(prin1 (complexnum-imag obj) stream)
|
||||
|
|
@ -122,6 +122,15 @@
|
|||
(declare (ignore env))
|
||||
`(complex ,(complexnum-real obj) ,(complexnum-imag obj)))
|
||||
|
||||
;;; KLUDGE: this is more-or-less copied from sharpm,
|
||||
(defun sb-cold::read-target-complex (stream sub-char numarg)
|
||||
(declare (ignore sub-char numarg))
|
||||
(let ((cnum (read stream t nil t)))
|
||||
(when *read-suppress* (return-from sb-cold::read-target-complex nil))
|
||||
(if (and (listp cnum) (= (length cnum) 2))
|
||||
(complex (car cnum) (cadr cnum))
|
||||
(error "illegal complex number format: #C~S" cnum))))
|
||||
|
||||
(defvar *interned-complex-numbers* (make-hash-table :test #'equal))
|
||||
|
||||
;;; REAL and IMAG are either host integers (therefore EQL-comparable)
|
||||
|
|
|
|||
|
|
@ -45,8 +45,6 @@
|
|||
(single-float (%single-float-rational rational))
|
||||
(double-float (%double-float-rational rational))))
|
||||
|
||||
(defvar *floating-point-number-buffer* (make-array 100 :element-type 'character))
|
||||
|
||||
(defun parse-xfloat-math-file (stream table)
|
||||
;; Ensure that we're reading the correct variant of the file
|
||||
;; in case there is more than one set of floating-point formats.
|
||||
|
|
@ -120,62 +118,51 @@
|
|||
(values-list answer)
|
||||
(multiple-value-call #'record-math-op fun args (progn ,@calculation))))))
|
||||
|
||||
(defun sb-cold::read-target-float (stream char)
|
||||
(let ((buffer *floating-point-number-buffer*)
|
||||
(index -1)
|
||||
string)
|
||||
(loop (setq char (read-char stream))
|
||||
(cond ((or (digit-char-p char)
|
||||
(member char '(#\+ #\- #\. #\D #\E #\F #\L #\S) :test #'char-equal))
|
||||
(setf (aref buffer (incf index)) char))
|
||||
(t
|
||||
(unread-char char stream)
|
||||
(return))))
|
||||
(when *read-suppress*
|
||||
(return-from sb-cold::read-target-float nil))
|
||||
(setf string (subseq buffer 0 (1+ index)))
|
||||
(multiple-value-bind (flonum nchars)
|
||||
(with-memoized-math-op (read-from-string (list *read-default-float-format* string))
|
||||
(let* ((marker-pos
|
||||
(position-if (lambda (x)
|
||||
(member x '(#\E #\S #\F #\D #\L) :test #'char-equal))
|
||||
string))
|
||||
(exp-marker (if (and marker-pos
|
||||
(char-not-equal (char string marker-pos) #\E))
|
||||
(char-upcase (char string marker-pos))
|
||||
(ecase cl:*read-default-float-format*
|
||||
((cl:single-float cl:short-float) #\F)
|
||||
((cl:double-float cl:long-float) #\D))))
|
||||
(significand (if marker-pos (subseq string 0 marker-pos) string))
|
||||
(dot-pos (position #\. significand))
|
||||
(integer (if (eql dot-pos 0) 0 (parse-integer significand :start 0 :end dot-pos)))
|
||||
(fraction (if (and dot-pos (cl:> (length significand) (1+ dot-pos)))
|
||||
(cl:/ (parse-integer significand :start (1+ dot-pos))
|
||||
(cl:expt 10 (cl:- (length significand) (1+ dot-pos))))
|
||||
0))
|
||||
(exponent (if marker-pos
|
||||
(parse-integer string :start (1+ marker-pos))
|
||||
0))
|
||||
(rational (cl:* (if (char= (char string 0) #\-)
|
||||
(cl:- integer fraction)
|
||||
(cl:+ integer fraction))
|
||||
(cl:expt 10 exponent)))
|
||||
(format (ecase exp-marker
|
||||
((#\F #\S) 'single-float)
|
||||
((#\D #\L) 'double-float))))
|
||||
;; Since we are working with rationals, we must special-case
|
||||
;; negative zero (which does not have a natural rational
|
||||
;; representation: explicitly look for -0 string.
|
||||
(if (or (string= significand "-0.0")
|
||||
(string= significand "-.0")
|
||||
(and (or (string= significand "-0") (string= significand "-0."))
|
||||
(or marker-pos (error "~S has integer syntax" string))))
|
||||
(ecase format
|
||||
(single-float (values #.(make-single-float (ash -1 31))
|
||||
(length string)))
|
||||
(double-float (values #.(%make-double-float (ash -1 63))
|
||||
(length string))))
|
||||
(let ((result (flonum-from-rational rational format)))
|
||||
(values result (length string))))))
|
||||
(declare (ignore nchars))
|
||||
flonum)))
|
||||
(defun sb-cold::read-target-float-from-string (string)
|
||||
(when *read-suppress*
|
||||
(return-from sb-cold::read-target-float-from-string nil))
|
||||
(multiple-value-bind (flonum nchars)
|
||||
(with-memoized-math-op (read-from-string (list *read-default-float-format* (copy-seq string)))
|
||||
(let* ((marker-pos
|
||||
(position-if (lambda (x)
|
||||
(member x '(#\E #\S #\F #\D #\L) :test #'char-equal))
|
||||
string))
|
||||
(exp-marker (if (and marker-pos
|
||||
(char-not-equal (char string marker-pos) #\E))
|
||||
(char-upcase (char string marker-pos))
|
||||
(ecase cl:*read-default-float-format*
|
||||
((cl:single-float cl:short-float) #\F)
|
||||
((cl:double-float cl:long-float) #\D))))
|
||||
(significand (if marker-pos (subseq string 0 marker-pos) string))
|
||||
(dot-pos (position #\. significand))
|
||||
(integer (if (eql dot-pos 0) 0 (parse-integer significand :start 0 :end dot-pos)))
|
||||
(fraction (if (and dot-pos (cl:> (length significand) (1+ dot-pos)))
|
||||
(cl:/ (parse-integer significand :start (1+ dot-pos))
|
||||
(cl:expt 10 (cl:- (length significand) (1+ dot-pos))))
|
||||
0))
|
||||
(exponent (if marker-pos
|
||||
(parse-integer string :start (1+ marker-pos))
|
||||
0))
|
||||
(rational (cl:* (if (char= (char string 0) #\-)
|
||||
(cl:- integer fraction)
|
||||
(cl:+ integer fraction))
|
||||
(cl:expt 10 exponent)))
|
||||
(format (ecase exp-marker
|
||||
((#\F #\S) 'single-float)
|
||||
((#\D #\L) 'double-float))))
|
||||
;; Since we are working with rationals, we must special-case
|
||||
;; negative zero (which does not have a natural rational
|
||||
;; representation: explicitly look for -0 string.
|
||||
(if (or (string= significand "-0.0")
|
||||
(string= significand "-.0")
|
||||
(and (or (string= significand "-0") (string= significand "-0."))
|
||||
(or marker-pos (error "~S has integer syntax" string))))
|
||||
(ecase format
|
||||
(single-float (values #.(make-single-float (ash -1 31))
|
||||
(length string)))
|
||||
(double-float (values #.(%make-double-float (ash -1 63))
|
||||
(length string))))
|
||||
(let ((result (flonum-from-rational rational format)))
|
||||
(values result (length string))))))
|
||||
(declare (ignore nchars))
|
||||
flonum))
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@
|
|||
(= (float-sign-bit float) 1))
|
||||
(declaim (inline flonum-minus-zero-p))
|
||||
(defun flonum-minus-zero-p (flonum)
|
||||
(or (eq flonum $-0.0f0) (eq flonum $-0.0d0)))
|
||||
(or (eq flonum -0.0f0) (eq flonum -0.0d0)))
|
||||
|
||||
(defun pick-result-format (&rest args)
|
||||
(flet ((target-num-fmt (num)
|
||||
|
|
@ -75,7 +75,7 @@
|
|||
(error "Can't COERCE ~S ~S" object type))
|
||||
((and (flonum-minus-zero-p object)
|
||||
(member type '(double-float single-float)))
|
||||
(ecase type (single-float $-0.0f0) (double-float $-0.0d0)))
|
||||
(ecase type (single-float -0.0f0) (double-float -0.0d0)))
|
||||
((and (floatp object)
|
||||
(float-infinity-p object))
|
||||
(ecase type
|
||||
|
|
@ -121,7 +121,7 @@
|
|||
(with-memoized-math-op (,name (list number divisor))
|
||||
(if (flonum-minus-zero-p number)
|
||||
(values 0
|
||||
(coerce (if (< divisor 0) 0 $-0.0) type))
|
||||
(coerce (if (< divisor 0) 0 -0.0) type))
|
||||
(multiple-value-bind (q r)
|
||||
(,clname (rational number) (rational divisor))
|
||||
(values q (flonum-from-rational r type))))))))))
|
||||
|
|
@ -149,7 +149,7 @@
|
|||
r
|
||||
(flonum-from-rational r format))))
|
||||
(if (cl:= q 0)
|
||||
(values (coerce (if (cl:= (sgn number) (sgn divisor)) 0 $-0.0)
|
||||
(values (coerce (if (cl:= (sgn number) (sgn divisor)) 0 -0.0)
|
||||
type)
|
||||
remainder)
|
||||
(values (flonum-from-rational q type) remainder))))))))
|
||||
|
|
@ -249,7 +249,7 @@
|
|||
((eql format 'rational) (cl:+ x y))
|
||||
((and (flonum-minus-zero-p x)
|
||||
(flonum-minus-zero-p y))
|
||||
(coerce $-0.0 format))
|
||||
(coerce -0.0 format))
|
||||
(t (flonum-from-rational (cl:+ (rational x) (rational y)) format))))))
|
||||
(if (every #'rationalp args)
|
||||
(apply #'cl:+ args)
|
||||
|
|
@ -268,7 +268,7 @@
|
|||
((eql format 'rational) (cl:- x y))
|
||||
((and (flonum-minus-zero-p x)
|
||||
(and (zerop y) (not (flonum-minus-zero-p y))))
|
||||
(coerce $-0.0 format))
|
||||
(coerce -0.0 format))
|
||||
(t (flonum-from-rational (cl:- (rational x) (rational y)) format))))))
|
||||
(if (every #'rationalp args)
|
||||
(apply #'cl:- args)
|
||||
|
|
@ -292,7 +292,7 @@
|
|||
format))
|
||||
((or (flonum-minus-zero-p x)
|
||||
(flonum-minus-zero-p y))
|
||||
(coerce (if (cl:= (sgn x) (sgn y)) 0 $-0.0) format))
|
||||
(coerce (if (cl:= (sgn x) (sgn y)) 0 -0.0) format))
|
||||
(t (flonum-from-rational (cl:* (rational x) (rational y)) format))))))
|
||||
(if (every #'rationalp args)
|
||||
(apply #'cl:* args)
|
||||
|
|
@ -315,7 +315,7 @@
|
|||
((zerop y)
|
||||
(error "can't represent Inf for (/ x 0)"))
|
||||
((zerop x)
|
||||
(coerce (if (cl:= (sgn x) (sgn y)) 0 $-0.0) format))
|
||||
(coerce (if (cl:= (sgn x) (sgn y)) 0 -0.0) format))
|
||||
(t (flonum-from-rational (cl:/ (rational x) (rational y)) format))))))
|
||||
(if (every #'rationalp args)
|
||||
(apply #'cl:/ args)
|
||||
|
|
@ -352,8 +352,8 @@
|
|||
(defun realpart (x) (if (realp x) x (complexnum-real x)))
|
||||
(defun imagpart (x)
|
||||
(cond ((rationalp x) 0)
|
||||
((single-float-p x) $0f0)
|
||||
((double-float-p x) $0d0)
|
||||
((single-float-p x) 0f0)
|
||||
((double-float-p x) 0d0)
|
||||
(t (complexnum-imag x))))
|
||||
|
||||
(defun sb-vm::sign-extend (x size)
|
||||
|
|
@ -361,7 +361,7 @@
|
|||
|
||||
;;; PI is needed in order to build the cross-compiler mainly so that vm-fndb
|
||||
;;; can define bounds on irrational functions.
|
||||
(defconstant pi $3.14159265358979323846264338327950288419716939937511L0)
|
||||
(defconstant pi 3.14159265358979323846264338327950288419716939937511L0)
|
||||
|
||||
(macrolet ((def (name lambda-list)
|
||||
`(defun ,(intern (string name) "SB-XC") ,lambda-list
|
||||
|
|
@ -387,15 +387,15 @@
|
|||
(with-memoized-math-op (atan (list number1 number2))
|
||||
(error "Unimplemented."))
|
||||
(with-memoized-math-op (atan number1)
|
||||
(if (eql number1 $1.4916681462400417d-154)
|
||||
(if (eql number1 1.4916681462400417d-154)
|
||||
number1
|
||||
(error "Unimplemented.")))))
|
||||
|
||||
(defun cosh (number)
|
||||
(with-memoized-math-op (cosh number)
|
||||
(case number
|
||||
((0 $0f0) $1f0)
|
||||
($0d0 $1d0)
|
||||
((0 0f0) 1f0)
|
||||
(0d0 1d0)
|
||||
(t (error "Unimplemented.")))))
|
||||
|
||||
(defun log (number &optional (base nil base-p))
|
||||
|
|
@ -406,32 +406,32 @@
|
|||
(coerce single-float-negative-infinity format)
|
||||
(case base
|
||||
((nil)
|
||||
(let ((table '((1 . $0f0)
|
||||
(10 . $2.3025851f0)
|
||||
(#x1fffffff . $20.101269f0)
|
||||
(#x20000000 . $20.101269f0)
|
||||
(#x20000001 . $20.101269f0)
|
||||
(#xfffffffffffffff . $41.58883f0)
|
||||
(#x1000000000000000 . $41.58883f0)
|
||||
(#x1000000000000001 . $41.58883f0)
|
||||
(#x3fffffffffffffff . $42.975124f0)
|
||||
(#x4000000000000000 . $42.975124f0)
|
||||
(#x4000000000000001 . $42.975124f0)
|
||||
($0.9999999999999999d0 . $-1.1102230246251565d-16)
|
||||
($1d0 . $0d0)
|
||||
($2d0 . $0.6931471805599453d0)
|
||||
($2.718281828459045d0 . $1d0)
|
||||
($5.36870911d8 . $20.10126823437577d0)
|
||||
($5.36870912d8 . $20.101268236238415d0)
|
||||
($2.147483647d9 . $21.487562596892644d0)
|
||||
($2.147483648d9 . $21.487562597358306d0)
|
||||
($1.152921504606847d18 . $41.58883083359672d0)
|
||||
($4.611686018427388d18 . $42.97512519471661d0)
|
||||
($9.223372036854776d18 . $43.66827237527655d0))))
|
||||
(let ((table '((1 . 0f0)
|
||||
(10 . 2.3025851f0)
|
||||
(#x1fffffff . 20.101269f0)
|
||||
(#x20000000 . 20.101269f0)
|
||||
(#x20000001 . 20.101269f0)
|
||||
(#xfffffffffffffff . 41.58883f0)
|
||||
(#x1000000000000000 . 41.58883f0)
|
||||
(#x1000000000000001 . 41.58883f0)
|
||||
(#x3fffffffffffffff . 42.975124f0)
|
||||
(#x4000000000000000 . 42.975124f0)
|
||||
(#x4000000000000001 . 42.975124f0)
|
||||
(0.9999999999999999d0 . -1.1102230246251565d-16)
|
||||
(1d0 . 0d0)
|
||||
(2d0 . 0.6931471805599453d0)
|
||||
(2.718281828459045d0 . 1d0)
|
||||
(5.36870911d8 . 20.10126823437577d0)
|
||||
(5.36870912d8 . 20.101268236238415d0)
|
||||
(2.147483647d9 . 21.487562596892644d0)
|
||||
(2.147483648d9 . 21.487562597358306d0)
|
||||
(1.152921504606847d18 . 41.58883083359672d0)
|
||||
(4.611686018427388d18 . 42.97512519471661d0)
|
||||
(9.223372036854776d18 . 43.66827237527655d0))))
|
||||
(or (cdr (assoc number table))
|
||||
(error "missing entry for (LOG ~A)" number))))
|
||||
((10 $10f0 $10d0)
|
||||
(let ((table '(($2d0 . $0.3010299956639812d0))))
|
||||
((10 10f0 10d0)
|
||||
(let ((table '((2d0 . 0.3010299956639812d0))))
|
||||
(or (cdr (assoc number table))
|
||||
(error "missing entry for (LOG ~A 10)" number))))
|
||||
(t (error "missing entries for (LOG ~A ~A)" number base)))))))
|
||||
|
|
@ -508,54 +508,54 @@
|
|||
table)))))
|
||||
|
||||
;;; Perform some simple checks
|
||||
(assert (not (eq $-0.0f0 $-0.0d0)))
|
||||
(assert (not (eq single-float-negative-infinity $0f0)))
|
||||
(assert (not (eq -0.0f0 -0.0d0)))
|
||||
(assert (not (eq single-float-negative-infinity 0f0)))
|
||||
(dolist (format '(single-float double-float))
|
||||
(assert (zerop (coerce 0 format)))
|
||||
(assert (zerop (coerce $-0.0 format)))
|
||||
(assert (zerop (coerce -0.0 format)))
|
||||
(assert (float-infinity-p (coerce single-float-positive-infinity format)))
|
||||
(assert (float-infinity-or-nan-p (coerce single-float-positive-infinity format)))
|
||||
(assert (not (float-nan-p (coerce single-float-positive-infinity format))))
|
||||
(assert (float-infinity-p (coerce single-float-negative-infinity format)))
|
||||
(assert (float-infinity-or-nan-p (coerce single-float-negative-infinity format)))
|
||||
(assert (not (float-nan-p (coerce single-float-negative-infinity format))))
|
||||
(assert (eq (coerce $-0.0 format) (coerce $-0.0 format)))
|
||||
(assert (eq (coerce -0.0 format) (coerce -0.0 format)))
|
||||
(assert (eq (coerce single-float-positive-infinity format)
|
||||
(coerce single-float-positive-infinity format)))
|
||||
(assert (eq (coerce single-float-negative-infinity format)
|
||||
(coerce single-float-negative-infinity format)))
|
||||
(assert (eq (sb-xc:+ (coerce $-0.0 format) (coerce 0 format)) (coerce 0 format)))
|
||||
(assert (eq (sb-xc:+ (coerce 0 format) (coerce $-0.0 format)) (coerce 0 format)))
|
||||
(assert (eq (sb-xc:+ (coerce $-0.0 format) (coerce $-0.0 format)) (coerce $-0.0 format)))
|
||||
(assert (eq (sb-xc:- (coerce 0 format)) (coerce $-0.0 format)))
|
||||
(assert (eq (sb-xc:- (coerce $-0.0 format)) (coerce 0 format)))
|
||||
(assert (eq (sb-xc:+ (coerce -0.0 format) (coerce 0 format)) (coerce 0 format)))
|
||||
(assert (eq (sb-xc:+ (coerce 0 format) (coerce -0.0 format)) (coerce 0 format)))
|
||||
(assert (eq (sb-xc:+ (coerce -0.0 format) (coerce -0.0 format)) (coerce -0.0 format)))
|
||||
(assert (eq (sb-xc:- (coerce 0 format)) (coerce -0.0 format)))
|
||||
(assert (eq (sb-xc:- (coerce -0.0 format)) (coerce 0 format)))
|
||||
(assert (eq (coerce single-float-positive-infinity format)
|
||||
(sb-xc:- (coerce single-float-negative-infinity format))))
|
||||
(assert (eq (coerce single-float-negative-infinity format)
|
||||
(sb-xc:- (coerce single-float-positive-infinity format))))
|
||||
(assert (eq (sb-xc:- (coerce 0 format) (coerce 0 format)) (coerce 0 format)))
|
||||
(assert (eq (sb-xc:- (coerce 0 format) (coerce $-0.0 format)) (coerce 0 format)))
|
||||
(assert (eq (sb-xc:- (coerce $-0.0 format) (coerce 0 format)) (coerce $-0.0 format)))
|
||||
(assert (eq (sb-xc:- (coerce $-0.0 format) (coerce $-0.0 format)) (coerce 0 format)))
|
||||
(assert (eq (sb-xc:- (coerce 0 format) (coerce -0.0 format)) (coerce 0 format)))
|
||||
(assert (eq (sb-xc:- (coerce -0.0 format) (coerce 0 format)) (coerce -0.0 format)))
|
||||
(assert (eq (sb-xc:- (coerce -0.0 format) (coerce -0.0 format)) (coerce 0 format)))
|
||||
(assert (eq (sb-xc:* (coerce 0 format) (coerce 0 format)) (coerce 0 format)))
|
||||
(assert (eq (sb-xc:* (coerce $-0.0 format) (coerce 0 format)) (coerce $-0.0 format)))
|
||||
(assert (eq (sb-xc:* (coerce 0 format) (coerce $-0.0 format)) (coerce $-0.0 format)))
|
||||
(assert (eq (sb-xc:* (coerce $-0.0 format) (coerce $-0.0 format)) (coerce 0 format)))
|
||||
(assert (eq (sb-xc:/ (coerce $-0.0 format) (coerce -1 format)) (coerce 0 format)))
|
||||
(assert (eq (sb-xc:/ (coerce $-0.0 format) (coerce 1 format)) (coerce $-0.0 format)))
|
||||
(assert (eq (sb-xc:/ (coerce 0 format) (coerce -1 format)) (coerce $-0.0 format)))
|
||||
(assert (eq (sb-xc:* (coerce -0.0 format) (coerce 0 format)) (coerce -0.0 format)))
|
||||
(assert (eq (sb-xc:* (coerce 0 format) (coerce -0.0 format)) (coerce -0.0 format)))
|
||||
(assert (eq (sb-xc:* (coerce -0.0 format) (coerce -0.0 format)) (coerce 0 format)))
|
||||
(assert (eq (sb-xc:/ (coerce -0.0 format) (coerce -1 format)) (coerce 0 format)))
|
||||
(assert (eq (sb-xc:/ (coerce -0.0 format) (coerce 1 format)) (coerce -0.0 format)))
|
||||
(assert (eq (sb-xc:/ (coerce 0 format) (coerce -1 format)) (coerce -0.0 format)))
|
||||
(assert (eq (sb-xc:/ (coerce 0 format) (coerce 1 format)) (coerce 0 format)))
|
||||
(assert (eq (sb-xc:fceiling -1/2) $-0.0f0))
|
||||
(assert (eq (sb-xc:fceiling (coerce -1/2 format)) (coerce $-0.0 format)))
|
||||
(assert (eq (sb-xc:fceiling -1/2) -0.0f0))
|
||||
(assert (eq (sb-xc:fceiling (coerce -1/2 format)) (coerce -0.0 format)))
|
||||
(assert (eq (sb-xc:ffloor -1/2) (coerce -1 'single-float)))
|
||||
(assert (eq (sb-xc:ffloor (coerce -1/2 format)) (coerce -1 format)))
|
||||
(assert (eq (sb-xc:ftruncate -1/2) $-0.0f0))
|
||||
(assert (eq (sb-xc:ftruncate (coerce -1/2 format)) (coerce $-0.0 format)))
|
||||
(assert (eq (sb-xc:fround -1/2) $-0.0f0))
|
||||
(assert (eq (sb-xc:fround (coerce -1/2 format)) (coerce $-0.0 format)))
|
||||
(assert (equal (multiple-value-list (sb-xc:integer-decode-float $1.0f0))
|
||||
(assert (eq (sb-xc:ftruncate -1/2) -0.0f0))
|
||||
(assert (eq (sb-xc:ftruncate (coerce -1/2 format)) (coerce -0.0 format)))
|
||||
(assert (eq (sb-xc:fround -1/2) -0.0f0))
|
||||
(assert (eq (sb-xc:fround (coerce -1/2 format)) (coerce -0.0 format)))
|
||||
(assert (equal (multiple-value-list (sb-xc:integer-decode-float 1.0f0))
|
||||
'(8388608 -23 1)))
|
||||
(assert (equal (multiple-value-list (sb-xc:integer-decode-float $1.0d0))
|
||||
(assert (equal (multiple-value-list (sb-xc:integer-decode-float 1.0d0))
|
||||
'(4503599627370496 -52 1)))
|
||||
(let ((*break-on-signals* nil))
|
||||
(flet ((assert-not-number (x)
|
||||
|
|
|
|||
|
|
@ -54,7 +54,7 @@
|
|||
(locally ; FIXME compiler should learn to figure that out
|
||||
(declare (type (integer 0 #.internal-seconds-limit) seconds))
|
||||
(seconds-to-internal-time seconds)))
|
||||
((single-float $0.0f0 #.(float safe-internal-seconds-limit $1.0f0))
|
||||
((single-float 0.0f0 #.(float safe-internal-seconds-limit 1.0f0))
|
||||
(seconds-to-internal-time seconds))
|
||||
((and (not single-float) (real 0 #.safe-internal-seconds-limit))
|
||||
(seconds-to-internal-time seconds))))
|
||||
|
|
|
|||
|
|
@ -140,7 +140,7 @@
|
|||
;; How much to grow the hash table by when it fills up. If an index,
|
||||
;; then add that amount. If a floating point number, then multiply
|
||||
;; it by that.
|
||||
(rehash-size nil :type (or index (single-float ($1.0)))
|
||||
(rehash-size nil :type (or index (single-float (1.0)))
|
||||
:read-only t)
|
||||
;; How full the hash table has to get before we rehash
|
||||
;; but only for the initial determination of how many buckets to make.
|
||||
|
|
@ -149,7 +149,7 @@
|
|||
;; table to be X amount larger *and* that you care at about what load factor the
|
||||
;; new table gets rehashed, but no, you don't get to pick both every time.
|
||||
;; (CLHS says that these are all just "hints" and we're free to ignore)
|
||||
(rehash-threshold nil :type (single-float ($0.0) $1.0) :read-only t)
|
||||
(rehash-threshold nil :type (single-float (0.0) 1.0) :read-only t)
|
||||
;; The current number of entries in the table.
|
||||
(%count 0 :type index)
|
||||
;; Index into the Next vector chaining together free slots in the KV
|
||||
|
|
@ -222,7 +222,7 @@
|
|||
(sb-xc:defmacro pack-ht-flags-kind (x) `(ash ,x 4))
|
||||
(defmacro ht-flags-kind (flags) `(ldb (byte 2 4) ,flags))
|
||||
|
||||
(defconstant default-rehash-size $1.5)
|
||||
(defconstant default-rehash-size 1.5)
|
||||
;; Don't raise this number to 8 - if you do it'll increase the memory
|
||||
;; consumption of a default MAKE-HASH-TABLE call by 7% just due to
|
||||
;; padding slots. This is a "perfect" minimal size.
|
||||
|
|
@ -248,7 +248,7 @@
|
|||
;; (without pain) so the expanded code can't use the values.
|
||||
,+min-hash-table-size+
|
||||
,default-rehash-size
|
||||
$1.0)))
|
||||
1.0)))
|
||||
|
||||
;; Our hash-tables store precomputed hashes to speed rehash and to guard
|
||||
;; the call of the general comparator.
|
||||
|
|
|
|||
|
|
@ -225,7 +225,7 @@
|
|||
(type (unsigned-byte 32) x-lo y-lo))
|
||||
;; y==zero: x**0 = 1
|
||||
(when (zerop (logior y-ihi y-lo))
|
||||
(return-from real-expt (coerce $1d0 rtype)))
|
||||
(return-from real-expt (coerce 1d0 rtype)))
|
||||
;; +-NaN return x+y
|
||||
;; FIXME: Hardcoded qNaN/sNaN values are not portable.
|
||||
(when (or (> x-ihi #x7ff00000)
|
||||
|
|
@ -286,7 +286,7 @@
|
|||
(declare (double-float pow))
|
||||
(case yisint
|
||||
(1 ; odd
|
||||
(coerce (* $-1d0 pow) rtype))
|
||||
(coerce (* -1d0 pow) rtype))
|
||||
(2 ; even
|
||||
(coerce pow rtype))
|
||||
(t ; non-integer
|
||||
|
|
@ -372,7 +372,7 @@
|
|||
(defun log2/double-float (x)
|
||||
(declare (type double-float x))
|
||||
(if (float-sign-bit-set-p x)
|
||||
(complex (%log2 (- x)) (sb-xc:/ pi (log $2d0)))
|
||||
(complex (%log2 (- x)) (sb-xc:/ pi (log 2d0)))
|
||||
(%log2 x)))
|
||||
|
||||
(defun log2/nonnegative-ratio (x)
|
||||
|
|
@ -390,7 +390,7 @@
|
|||
(defun log2/rational (x)
|
||||
(declare (type rational x))
|
||||
(if (minusp x)
|
||||
(complex (log2/nonnegative-rational (- x)) (sb-xc:/ pi (log $2d0)))
|
||||
(complex (log2/nonnegative-rational (- x)) (sb-xc:/ pi (log 2d0)))
|
||||
(log2/nonnegative-rational x)))
|
||||
|
||||
(defun log (number &optional (base nil base-p))
|
||||
|
|
@ -400,8 +400,8 @@
|
|||
(cond
|
||||
((zerop base)
|
||||
(if (or (typep number 'double-float) (typep base 'double-float))
|
||||
$0.0d0
|
||||
$0.0f0))
|
||||
0.0d0
|
||||
0.0f0))
|
||||
((and (typep number '(rational 0))
|
||||
(typep base '(rational 0)))
|
||||
(coerce (/ (truly-the double-float (log2/nonnegative-rational number))
|
||||
|
|
@ -418,7 +418,7 @@
|
|||
(/ (log2/double-float number) (log2/rational base)))
|
||||
(t
|
||||
(/ (log number) (log base))))
|
||||
(let ((log2e $1.4426950408889634d0))
|
||||
(let ((log2e 1.4426950408889634d0))
|
||||
(number-dispatch ((number number))
|
||||
(((foreach fixnum bignum))
|
||||
(if (minusp number)
|
||||
|
|
@ -457,12 +457,12 @@
|
|||
(number-dispatch ((number number))
|
||||
(((foreach fixnum bignum ratio))
|
||||
(if (minusp number)
|
||||
(complex $0f0
|
||||
(complex 0f0
|
||||
(coerce (%sqrt (- (coerce number 'double-float))) 'single-float))
|
||||
(coerce (%sqrt (coerce number 'double-float)) 'single-float)))
|
||||
(((foreach single-float double-float))
|
||||
(if (minusp number)
|
||||
(complex (coerce $0.0 '(dispatch-type number))
|
||||
(complex (coerce 0.0 '(dispatch-type number))
|
||||
(coerce (%sqrt (- (coerce number 'double-float)))
|
||||
'(dispatch-type number)))
|
||||
(coerce (%sqrt (coerce number 'double-float))
|
||||
|
|
@ -501,15 +501,15 @@
|
|||
((rational)
|
||||
(if (minusp number)
|
||||
(coerce pi 'single-float)
|
||||
$0.0f0))
|
||||
0.0f0))
|
||||
((single-float)
|
||||
(if (minusp (float-sign number))
|
||||
(coerce pi 'single-float)
|
||||
$0.0f0))
|
||||
0.0f0))
|
||||
((double-float)
|
||||
(if (minusp (float-sign number))
|
||||
(coerce pi 'double-float)
|
||||
$0.0d0))
|
||||
0.0d0))
|
||||
(handle-complex
|
||||
(atan (imagpart number) (realpart number)))))
|
||||
|
||||
|
|
@ -801,7 +801,7 @@
|
|||
((zerop x)
|
||||
;; The answer is negative infinity, but we are supposed to
|
||||
;; signal divide-by-zero, so do the actual division
|
||||
(/ $-1.0d0 x))
|
||||
(/ -1.0d0 x))
|
||||
(t
|
||||
(logb-finite x))))
|
||||
|
||||
|
|
@ -821,8 +821,8 @@
|
|||
;; Convert anything that's not already a DOUBLE-FLOAT (because
|
||||
;; the initial argument was a (COMPLEX DOUBLE-FLOAT) and we
|
||||
;; haven't done anything to lose precision) to a SINGLE-FLOAT.
|
||||
(complex (float x $1f0)
|
||||
(float y $1f0))))
|
||||
(complex (float x 1f0)
|
||||
(float y 1f0))))
|
||||
|
||||
;;; Compute |(x+i*y)/2^k|^2 scaled to avoid over/underflow. The
|
||||
;;; result is r + i*k, where k is an integer.
|
||||
|
|
@ -830,8 +830,8 @@
|
|||
(error "needs work for long float support"))
|
||||
(defun cssqs (z)
|
||||
(declare (muffle-conditions compiler-note))
|
||||
(let ((x (float (realpart z) $1d0))
|
||||
(y (float (imagpart z) $1d0)))
|
||||
(let ((x (float (realpart z) 1d0))
|
||||
(y (float (imagpart z) 1d0)))
|
||||
;; Would this be better handled using an exception handler to
|
||||
;; catch the overflow or underflow signal? For now, we turn all
|
||||
;; traps off and look at the accrued exceptions to see if any
|
||||
|
|
@ -879,12 +879,12 @@
|
|||
(declare (type (or complex rational) z))
|
||||
(multiple-value-bind (rho k)
|
||||
(cssqs z)
|
||||
(declare (type (or (member $0d0) (double-float $0d0)) rho)
|
||||
(declare (type (or (member 0d0) (double-float 0d0)) rho)
|
||||
(type fixnum k))
|
||||
(let ((x (float (realpart z) $1.0d0))
|
||||
(y (float (imagpart z) $1.0d0))
|
||||
(eta $0d0)
|
||||
(nu $0d0))
|
||||
(let ((x (float (realpart z) 1.0d0))
|
||||
(y (float (imagpart z) 1.0d0))
|
||||
(eta 0d0)
|
||||
(nu 0d0))
|
||||
(declare (double-float x y eta nu)
|
||||
;; get maybe-inline functions inlined.
|
||||
(optimize (space 0)))
|
||||
|
|
@ -902,10 +902,10 @@
|
|||
(setf eta rho)
|
||||
(setf nu y)
|
||||
|
||||
(when (/= rho $0d0)
|
||||
(when (/= rho 0d0)
|
||||
(when (not (float-infinity-p nu))
|
||||
(setf nu (/ (/ nu rho) $2d0)))
|
||||
(when (< x $0d0)
|
||||
(setf nu (/ (/ nu rho) 2d0)))
|
||||
(when (< x 0d0)
|
||||
(setf eta (abs nu))
|
||||
(setf nu (float-sign y rho))))
|
||||
(coerce-to-complex-type eta nu z))))
|
||||
|
|
@ -923,12 +923,12 @@
|
|||
;; implementation of log1p.
|
||||
(let ((t0 #-long-float (make-double-float #x3fe6a09e #x667f3bcd)
|
||||
#+long-float (error "(/ (sqrt 2l0) 2)"))
|
||||
(t1 $1.2d0)
|
||||
(t2 $3d0)
|
||||
(t1 1.2d0)
|
||||
(t2 3d0)
|
||||
(ln2 #-long-float (make-double-float #x3fe62e42 #xfefa39ef)
|
||||
#+long-float (error "(log 2l0)"))
|
||||
(x (float (realpart z) $1.0d0))
|
||||
(y (float (imagpart z) $1.0d0)))
|
||||
(x (float (realpart z) 1.0d0))
|
||||
(y (float (imagpart z) 1.0d0)))
|
||||
(multiple-value-bind (rho k)
|
||||
(cssqs z)
|
||||
(declare (optimize (speed 3)))
|
||||
|
|
@ -938,11 +938,11 @@
|
|||
(< t0 beta)
|
||||
(or (<= beta t1)
|
||||
(< rho t2)))
|
||||
(/ (%log1p (+ (* (- beta $1.0d0)
|
||||
(+ beta $1.0d0))
|
||||
(/ (%log1p (+ (* (- beta 1.0d0)
|
||||
(+ beta 1.0d0))
|
||||
(* theta theta)))
|
||||
$2d0)
|
||||
(+ (/ (log rho) $2d0)
|
||||
2d0)
|
||||
(+ (/ (log rho) 2d0)
|
||||
(* k ln2)))
|
||||
(atan y x)
|
||||
z)))))
|
||||
|
|
@ -956,15 +956,15 @@
|
|||
(declare (muffle-conditions compiler-note))
|
||||
(declare (type (or rational complex) z))
|
||||
(let* (;; constants
|
||||
(theta (sb-xc:/ (sb-xc:sqrt most-positive-double-float) $4.0d0))
|
||||
(rho (sb-xc:/ $4.0d0 (sb-xc:sqrt most-positive-double-float)))
|
||||
(half-pi (sb-xc:/ pi $2.0d0))
|
||||
(rp (float (realpart z) $1.0d0))
|
||||
(beta (float-sign rp $1.0d0))
|
||||
(theta (sb-xc:/ (sb-xc:sqrt most-positive-double-float) 4.0d0))
|
||||
(rho (sb-xc:/ 4.0d0 (sb-xc:sqrt most-positive-double-float)))
|
||||
(half-pi (sb-xc:/ pi 2.0d0))
|
||||
(rp (float (realpart z) 1.0d0))
|
||||
(beta (float-sign rp 1.0d0))
|
||||
(x (* beta rp))
|
||||
(y (* beta (- (float (imagpart z) $1.0d0))))
|
||||
(eta $0.0d0)
|
||||
(nu $0.0d0))
|
||||
(y (* beta (- (float (imagpart z) 1.0d0))))
|
||||
(eta 0.0d0)
|
||||
(nu 0.0d0))
|
||||
;; Shouldn't need this declare.
|
||||
(declare (double-float x y))
|
||||
(locally
|
||||
|
|
@ -978,32 +978,32 @@
|
|||
;; that it won't overflow.
|
||||
(setf eta (let* ((x-bigger (> x (abs y)))
|
||||
(r (if x-bigger (/ y x) (/ x y)))
|
||||
(d (+ $1.0d0 (* r r))))
|
||||
(d (+ 1.0d0 (* r r))))
|
||||
(if x-bigger
|
||||
(/ (/ x) d)
|
||||
(/ (/ r y) d)))))
|
||||
((= x $1.0d0)
|
||||
((= x 1.0d0)
|
||||
;; Should this be changed so that if y is zero, eta is set
|
||||
;; to +infinity instead of approx 176? In any case
|
||||
;; tanh(176) is 1.0d0 within working precision.
|
||||
(let ((t1 (+ $4d0 (square y)))
|
||||
(let ((t1 (+ 4d0 (square y)))
|
||||
(t2 (+ (abs y) rho)))
|
||||
(setf eta (log (/ (sqrt (sqrt t1))
|
||||
(sqrt t2))))
|
||||
(setf nu (* $0.5d0
|
||||
(setf nu (* 0.5d0
|
||||
(float-sign y
|
||||
(+ half-pi (atan (* $0.5d0 t2))))))))
|
||||
(+ half-pi (atan (* 0.5d0 t2))))))))
|
||||
(t
|
||||
(let ((t1 (+ (abs y) rho)))
|
||||
;; Normal case using log1p(x) = log(1 + x)
|
||||
(setf eta (* $0.25d0
|
||||
(%log1p (/ (* $4.0d0 x)
|
||||
(+ (square (- $1.0d0 x))
|
||||
(setf eta (* 0.25d0
|
||||
(%log1p (/ (* 4.0d0 x)
|
||||
(+ (square (- 1.0d0 x))
|
||||
(square t1))))))
|
||||
(setf nu (* $0.5d0
|
||||
(atan (* $2.0d0 y)
|
||||
(- (* (- $1.0d0 x)
|
||||
(+ $1.0d0 x))
|
||||
(setf nu (* 0.5d0
|
||||
(atan (* 2.0d0 y)
|
||||
(- (* (- 1.0d0 x)
|
||||
(+ 1.0d0 x))
|
||||
(square t1))))))))
|
||||
(coerce-to-complex-type (* beta eta)
|
||||
(- (* beta nu))
|
||||
|
|
@ -1031,8 +1031,8 @@ prints: 406633CE8FB9F87D = 177.618965018485966
|
|||
(defun complex-tanh (z)
|
||||
(declare (muffle-conditions compiler-note))
|
||||
(declare (type (or rational complex) z))
|
||||
(let ((x (float (realpart z) $1.0d0))
|
||||
(y (float (imagpart z) $1.0d0)))
|
||||
(let ((x (float (realpart z) 1.0d0))
|
||||
(y (float (imagpart z) 1.0d0)))
|
||||
(locally
|
||||
;; space 0 to get maybe-inline functions inlined
|
||||
(declare (optimize (speed 3) (space 0)))
|
||||
|
|
@ -1043,14 +1043,14 @@ prints: 406633CE8FB9F87D = 177.618965018485966
|
|||
(float-sign y) z))
|
||||
(t
|
||||
(let* ((tv (%tan y))
|
||||
(beta (+ $1.0d0 (* tv tv)))
|
||||
(beta (+ 1.0d0 (* tv tv)))
|
||||
(s (sinh x))
|
||||
(rho (sqrt (+ $1.0d0 (* s s)))))
|
||||
(rho (sqrt (+ 1.0d0 (* s s)))))
|
||||
(if (float-infinity-p tv)
|
||||
(coerce-to-complex-type (/ rho s)
|
||||
(/ tv)
|
||||
z)
|
||||
(let ((den (+ $1.0d0 (* beta s s))))
|
||||
(let ((den (+ 1.0d0 (* beta s s))))
|
||||
(coerce-to-complex-type (/ (* beta rho s)
|
||||
den)
|
||||
(/ tv den)
|
||||
|
|
|
|||
|
|
@ -333,8 +333,8 @@
|
|||
(single-float 'round-single))
|
||||
divided :truncate)
|
||||
,(ecase rtype
|
||||
(double-float $-0.0d0)
|
||||
(single-float $-0.0f0)))
|
||||
(double-float -0.0d0)
|
||||
(single-float -0.0f0)))
|
||||
float-div)))))
|
||||
(single-digit-bignum-p (x)
|
||||
#+(or x86-64 x86 ppc64)
|
||||
|
|
@ -554,7 +554,7 @@
|
|||
`(defun ,name (number &optional (divisor 1))
|
||||
,doc
|
||||
(multiple-value-bind (res rem) (,op number divisor)
|
||||
(values (float res (if (floatp rem) rem $1.0)) rem))))
|
||||
(values (float res (if (floatp rem) rem 1.0)) rem))))
|
||||
|
||||
;;; Declare these guys inline to let them get optimized a little.
|
||||
;;; ROUND and FROUND are not declared inline since they seem too
|
||||
|
|
@ -579,7 +579,7 @@
|
|||
(truncate number divisor)
|
||||
(if (and (zerop q) (or (and (minusp number) (not (minusp divisor)))
|
||||
(and (not (minusp number)) (minusp divisor))))
|
||||
(values $-0f0 r)
|
||||
(values -0f0 r)
|
||||
(values (float q) r))))
|
||||
(((foreach single-float double-float #+long-float long-float)
|
||||
(or rational single-float))
|
||||
|
|
@ -638,7 +638,7 @@
|
|||
(round number divisor)
|
||||
(if (and (zerop q) (or (and (minusp number) (not (minusp divisor)))
|
||||
(and (not (minusp number)) (minusp divisor))))
|
||||
(values $-0f0 r)
|
||||
(values -0f0 r)
|
||||
(values (float q) r))))
|
||||
(((foreach single-float double-float #+long-float long-float)
|
||||
(or rational single-float))
|
||||
|
|
@ -688,7 +688,7 @@
|
|||
(,(find-symbol (string mode) :cl) number divisor)
|
||||
(if (and (zerop q) (or (and (minusp number) (not (minusp divisor)))
|
||||
(and (not (minusp number)) (minusp divisor))))
|
||||
(values $-0f0 r)
|
||||
(values -0f0 r)
|
||||
(values (float q) r))))
|
||||
(((foreach single-float double-float)
|
||||
(or rational single-float))
|
||||
|
|
|
|||
|
|
@ -505,16 +505,13 @@ length and have identical components. Other arrays must be EQ to be EQUAL."
|
|||
(t nil)))
|
||||
|
||||
#-sb-show ;; I don't know why these tests crash with #+sb-show
|
||||
(let ((test-cases `(($0.0 $-0.0 t)
|
||||
($0.0 $1.0 nil)
|
||||
;; There is no cross-compiler #C reader macro.
|
||||
;; SB-XC:COMPLEX does not want uncanonical input, i.e. imagpart
|
||||
;; of rational 0 which downgrades the result to just an integer.
|
||||
(1 ,(complex $1.0 $0.0) t)
|
||||
(,(complex 0 1) ,(complex $0.0 $1.0) t)
|
||||
(let ((test-cases '((0.0 -0.0 t)
|
||||
(0.0 1.0 nil)
|
||||
(#c(1 0) #c(1.0 0.0) t)
|
||||
(#c(0 1) #c(0.0 1.0) t)
|
||||
;; 11/10 is unequal to real 1.1 due to roundoff error.
|
||||
;; COMPLEX here is a red herring
|
||||
(,(complex $1.1 $0.0) 11/10 nil)
|
||||
(#c(1.1 0.0) #c(11/10 0) nil)
|
||||
("Hello" "hello" t)
|
||||
("Hello" #(#\h #\E #\l #\l #\o) t)
|
||||
("Hello" "goodbye" nil))))
|
||||
|
|
|
|||
|
|
@ -1585,8 +1585,8 @@ variable: an unreadable object representing the error is printed instead.")
|
|||
(scale (r s m+ m-)
|
||||
(let ((est (truly-the (integer -323 309)
|
||||
(ceiling (- (* (+ e (integer-length (truly-the sb-kernel:double-float-significand f)) -1)
|
||||
(log $2d0 10))
|
||||
$1.0e-10)))))
|
||||
(log 2d0 10))
|
||||
1.0e-10)))))
|
||||
(if (>= est 0)
|
||||
(fixup r (* s (expt10 est)) m+ m- est)
|
||||
(let ((scale (expt10 (- est))))
|
||||
|
|
@ -1757,30 +1757,30 @@ variable: an unreadable object representing the error is printed instead.")
|
|||
(let* ((x (coerce original-x 'long-float)))
|
||||
(multiple-value-bind (sig exponent) (decode-float x)
|
||||
(declare (ignore sig))
|
||||
(if (= x $0.0e0)
|
||||
(values (float $0.0e0 original-x) 1)
|
||||
(if (= x 0.0e0)
|
||||
(values (float 0.0e0 original-x) 1)
|
||||
(let* ((ex (locally (declare (optimize (safety 0)))
|
||||
(the fixnum
|
||||
(round (* exponent
|
||||
#-long-float (log $2d0 10)
|
||||
#-long-float (log 2d0 10)
|
||||
#+long-float
|
||||
(error "(log 2 10) not computed"))))))
|
||||
(x (if (minusp ex)
|
||||
(if (float-denormalized-p x)
|
||||
#-long-float
|
||||
(* x $1.0e16 (expt $10.0e0 (- (- ex) 16)))
|
||||
(* x 1.0e16 (expt 10.0e0 (- (- ex) 16)))
|
||||
#+long-float
|
||||
(* x $1.0e18 (expt $10.0e0 (- (- ex) 18)))
|
||||
(* x $10.0e0 (expt $10.0e0 (- (- ex) 1))))
|
||||
(/ x $10.0e0 (expt $10.0e0 (1- ex))))))
|
||||
(do ((d $10.0e0 (* d $10.0e0))
|
||||
(* x 1.0e18 (expt 10.0e0 (- (- ex) 18)))
|
||||
(* x 10.0e0 (expt 10.0e0 (- (- ex) 1))))
|
||||
(/ x 10.0e0 (expt 10.0e0 (1- ex))))))
|
||||
(do ((d 10.0e0 (* d 10.0e0))
|
||||
(y x (/ x d))
|
||||
(ex ex (1+ ex)))
|
||||
((< y $1.0e0)
|
||||
(do ((m $10.0e0 (* m $10.0e0))
|
||||
((< y 1.0e0)
|
||||
(do ((m 10.0e0 (* m 10.0e0))
|
||||
(z y (* y m))
|
||||
(ex ex (1- ex)))
|
||||
((>= z $0.1e0)
|
||||
((>= z 0.1e0)
|
||||
(values (float z original-x) ex))
|
||||
(declare (long-float m) (integer ex))))
|
||||
(declare (long-float d))))))))
|
||||
|
|
|
|||
|
|
@ -111,7 +111,7 @@
|
|||
(#\2
|
||||
(substs (cons arg 'sequence2))
|
||||
'length2)))
|
||||
(cache-var (symbolicate length-var '#:-cache)))
|
||||
(cache-var (symbolicate length-var "-CACHE")))
|
||||
(new-args arg)
|
||||
(rebindings/eager `(,cache-var nil))
|
||||
(rebindings/lazy
|
||||
|
|
|
|||
|
|
@ -300,7 +300,7 @@ happens. Server returns T if something happened and NIL otherwise. Timeout
|
|||
(decode-internal-time
|
||||
(seconds-to-internal-time *periodic-polling-period*))
|
||||
(if to-sec
|
||||
(loop repeat (/ (+ to-sec (/ to-usec $1e6))
|
||||
(loop repeat (/ (+ to-sec (/ to-usec 1e6))
|
||||
*periodic-polling-period*)
|
||||
thereis (sub-sub-serve-event p-sec p-usec)
|
||||
do (funcall *periodic-polling-function*))
|
||||
|
|
|
|||
|
|
@ -51,8 +51,8 @@
|
|||
(let ((shift (1- new-exp)))
|
||||
(if (< shift (- (1- digits)))
|
||||
(float-sign x ,(case type
|
||||
(single-float $0f0)
|
||||
(double-float $0d0)))
|
||||
(single-float 0f0)
|
||||
(double-float 0d0)))
|
||||
,(case type
|
||||
(single-float '(single-from-bits sign 0 (ash sig shift)))
|
||||
(double-float '(double-from-bits sign 0 (ash sig shift)))))))
|
||||
|
|
|
|||
|
|
@ -687,7 +687,7 @@
|
|||
(float-nan-p number))
|
||||
(prin1 number stream)
|
||||
(multiple-value-bind (num expt) (sb-impl::scale-exponent (abs number))
|
||||
(let* ((k (if (= num $1.0) (1- k) k))
|
||||
(let* ((k (if (= num 1.0) (1- k) k))
|
||||
(expt (- expt k))
|
||||
(estr (decimal-string (abs expt)))
|
||||
(elen (if e (max (length estr) e) (length estr)))
|
||||
|
|
|
|||
|
|
@ -286,7 +286,7 @@ Examples:
|
|||
(defconstant bad-next-value #xfefefefe)
|
||||
;;; This constant is referenced via its name in cold load, so it needs to
|
||||
;;; be evaluable in the host.
|
||||
(defconstant +min-hash-table-rehash-threshold+ #.(sb-xc:float 1/16 $1.0))
|
||||
(defconstant +min-hash-table-rehash-threshold+ #.(sb-xc:float 1/16 1.0))
|
||||
|
||||
;; The GC will set this to 1 if it moves an address-sensitive key. This used
|
||||
;; to be signaled by a bit in the header of the kv vector, but that
|
||||
|
|
@ -471,9 +471,9 @@ Examples:
|
|||
(min size (ash 1 24)))) ; 16M key/value pairs
|
||||
(rehash-size (if (integerp rehash-size)
|
||||
rehash-size
|
||||
(float rehash-size $1.0))) ; always single-float
|
||||
(float rehash-size 1.0))) ; always single-float
|
||||
(rehash-threshold (max #.+min-hash-table-rehash-threshold+
|
||||
(float rehash-threshold $1.0)))) ; always single-float
|
||||
(float rehash-threshold 1.0)))) ; always single-float
|
||||
(%make-hash-table
|
||||
;; compute flags. The stored KIND bits don't matter for a user-supplied hash
|
||||
;; and/or test fun, however we don't want to imply that it is an EQ table
|
||||
|
|
@ -598,7 +598,7 @@ Examples:
|
|||
test test-fun hash-fun
|
||||
+min-hash-table-size+
|
||||
#.default-rehash-size
|
||||
$1.0)))) ; rehash threshold
|
||||
1.0)))) ; rehash threshold
|
||||
|
||||
;;; I guess we might have more than one representation of a table,
|
||||
;;; hence this small wrapper function. But why not for the others?
|
||||
|
|
@ -870,11 +870,11 @@ multiple threads accessing the same hash-table without locking."
|
|||
;; if you specify 1.001 or other float near 1.
|
||||
;; Anyway, chaining supports load factors in excess of 100%
|
||||
(when (eql rehash-size default-rehash-size)
|
||||
(cond ((> full-lf 9/10) ; $.9 is unhappy in cross-float due to inexactness
|
||||
(cond ((> full-lf 9/10) ; .9 is unhappy in cross-float due to inexactness
|
||||
;; If we're going to decrease the size, make sure we definitely
|
||||
;; don't decrease below the old size.
|
||||
(setq new-size (floor pow2ceil 100/85))) ; target LF = 85%
|
||||
((< full-lf 55/100) ; and $.55 is similarly unhappy
|
||||
((< full-lf 55/100) ; and .55 is similarly unhappy
|
||||
(setq new-size (floor pow2ceil 100/65))))) ; target LF = 65%
|
||||
pow2ceil)))
|
||||
(values new-size new-n-buckets)))
|
||||
|
|
@ -2037,7 +2037,7 @@ table itself."
|
|||
`((:test ,#'hash-table-test eql)
|
||||
(:size ,#'hash-table-size ,+min-hash-table-size+)
|
||||
(:rehash-size ,#'hash-table-rehash-size ,default-rehash-size)
|
||||
(:rehash-threshold ,#'hash-table-rehash-threshold $1.0)
|
||||
(:rehash-threshold ,#'hash-table-rehash-threshold 1.0)
|
||||
(:synchronized ,#'hash-table-synchronized-p nil)
|
||||
(:weakness ,#'hash-table-weakness nil)))
|
||||
for value = (funcall accessor hash-table)
|
||||
|
|
|
|||
|
|
@ -90,7 +90,7 @@
|
|||
(do ((n (logior x 1) (+ n 2)))
|
||||
((positive-primep n) n)))
|
||||
|
||||
(defun make-info-storage (n-cells-min &optional (load-factor $.7))
|
||||
(defun make-info-storage (n-cells-min &optional (load-factor .7))
|
||||
;; If you ask for 40 entries at 50% load, you get (PRIMIFY 80) entries.
|
||||
(let* ((n-cells (primify (ceiling n-cells-min load-factor)))
|
||||
(a (make-array (+ +info-keys-offset+ (* 2 n-cells))))
|
||||
|
|
@ -343,7 +343,7 @@
|
|||
(let* ((old-count (info-env-count env))
|
||||
(old-storage (info-env-storage env))
|
||||
;; the new storage begins life at ~50% capacity
|
||||
(new-storage (make-info-storage (ceiling old-count $.5)))
|
||||
(new-storage (make-info-storage (ceiling old-count .5)))
|
||||
(old-capacity (info-storage-capacity old-storage))
|
||||
(new-capacity (info-storage-capacity new-storage)))
|
||||
|
||||
|
|
|
|||
|
|
@ -318,11 +318,11 @@ http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/emt.html
|
|||
;;; with random bits, then subtracting 1.0. This hides the fact that
|
||||
;;; we have a hidden bit.
|
||||
(declaim (inline %random-single-float %random-double-float))
|
||||
(declaim (ftype (function ((single-float ($0f0)) random-state)
|
||||
(single-float $0f0))
|
||||
(declaim (ftype (function ((single-float (0f0)) random-state)
|
||||
(single-float 0f0))
|
||||
%random-single-float))
|
||||
(defun %random-single-float (arg state)
|
||||
(declare (type (single-float ($0f0)) arg)
|
||||
(declare (type (single-float (0f0)) arg)
|
||||
(type random-state state))
|
||||
(loop for candidate of-type single-float
|
||||
= (* arg
|
||||
|
|
@ -330,19 +330,19 @@ http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/emt.html
|
|||
(dpb (ash (random-chunk state)
|
||||
(- sb-vm:single-float-digits n-random-chunk-bits))
|
||||
sb-vm:single-float-significand-byte
|
||||
(single-float-bits $1.0)))
|
||||
$1.0))
|
||||
(single-float-bits 1.0)))
|
||||
1.0))
|
||||
while (#+x86 eql ;; Can't use = due to 80-bit precision
|
||||
#-x86 =
|
||||
candidate arg)
|
||||
finally (return candidate)))
|
||||
(declaim (ftype (function ((double-float ($0d0)) random-state)
|
||||
(double-float $0d0))
|
||||
(declaim (ftype (function ((double-float (0d0)) random-state)
|
||||
(double-float 0d0))
|
||||
%random-double-float))
|
||||
|
||||
#-x86
|
||||
(defun %random-double-float (arg state)
|
||||
(declare (type (double-float ($0d0)) arg)
|
||||
(declare (type (double-float (0d0)) arg)
|
||||
(type random-state state))
|
||||
(loop for candidate of-type double-float
|
||||
= (* arg
|
||||
|
|
@ -350,16 +350,16 @@ http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/emt.html
|
|||
(dpb (ash (random-chunk state)
|
||||
(- sb-vm:double-float-digits n-random-chunk-bits 32))
|
||||
sb-vm:double-float-hi-significand-byte
|
||||
(sb-impl::double-float-high-bits $1d0))
|
||||
(sb-impl::double-float-high-bits 1d0))
|
||||
(random-chunk state))
|
||||
$1d0))
|
||||
1d0))
|
||||
while (= candidate arg)
|
||||
finally (return candidate)))
|
||||
|
||||
;;; using a faster inline VOP
|
||||
#+x86
|
||||
(defun %random-double-float (arg state)
|
||||
(declare (type (double-float ($0d0)) arg)
|
||||
(declare (type (double-float (0d0)) arg)
|
||||
(type random-state state))
|
||||
(let ((state-vector (random-state-state state)))
|
||||
(loop for candidate of-type double-float
|
||||
|
|
@ -369,9 +369,9 @@ http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/emt.html
|
|||
(- sb-vm:double-float-digits n-random-chunk-bits
|
||||
sb-vm:n-word-bits))
|
||||
sb-vm:double-float-hi-significand-byte
|
||||
(sb-impl::double-float-high-bits $1d0))
|
||||
(sb-impl::double-float-high-bits 1d0))
|
||||
(sb-vm::random-mt19937 state-vector))
|
||||
$1d0))
|
||||
1d0))
|
||||
;; Can't use = due to 80-bit precision
|
||||
while (eql candidate arg)
|
||||
finally (return candidate))))
|
||||
|
|
@ -419,12 +419,12 @@ http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/emt.html
|
|||
(cond
|
||||
((and (fixnump arg) (> arg 0))
|
||||
(%random-fixnum arg state))
|
||||
((and (typep arg 'single-float) (> arg $0.0f0))
|
||||
((and (typep arg 'single-float) (> arg 0.0f0))
|
||||
(%random-single-float arg state))
|
||||
((and (typep arg 'double-float) (> arg $0.0d0))
|
||||
((and (typep arg 'double-float) (> arg 0.0d0))
|
||||
(%random-double-float arg state))
|
||||
#+long-float
|
||||
((and (typep arg 'long-float) (> arg $0.0l0))
|
||||
((and (typep arg 'long-float) (> arg 0.0l0))
|
||||
(%random-long-float arg state))
|
||||
((and (bignump arg) (> arg 0))
|
||||
(%random-bignum arg state))
|
||||
|
|
|
|||
|
|
@ -432,17 +432,17 @@
|
|||
(mixf result (logand (%raw-instance-ref/word key i)
|
||||
most-positive-fixnum)))
|
||||
(,(1+index-of 'single-float)
|
||||
,(mix-float '(%raw-instance-ref/single key i) $0f0))
|
||||
,(mix-float '(%raw-instance-ref/single key i) 0f0))
|
||||
(,(1+index-of 'double-float)
|
||||
,(mix-float '(%raw-instance-ref/double key i) $0d0))
|
||||
,(mix-float '(%raw-instance-ref/double key i) 0d0))
|
||||
(,(1+index-of 'sb-kernel:complex-single-float)
|
||||
(let ((cplx (%raw-instance-ref/complex-single key i)))
|
||||
,(mix-float '(realpart cplx) $0f0)
|
||||
,(mix-float '(imagpart cplx) $0f0)))
|
||||
,(mix-float '(realpart cplx) 0f0)
|
||||
,(mix-float '(imagpart cplx) 0f0)))
|
||||
(,(1+index-of 'sb-kernel:complex-double-float)
|
||||
(let ((cplx (%raw-instance-ref/complex-double key i)))
|
||||
,(mix-float '(realpart cplx) $0d0)
|
||||
,(mix-float '(imagpart cplx) $0d0)))))))
|
||||
,(mix-float '(realpart cplx) 0d0)
|
||||
,(mix-float '(imagpart cplx) 0d0)))))))
|
||||
(let* ((layout (%instance-layout key))
|
||||
(result (layout-clos-hash layout)))
|
||||
(declare (type fixnum result))
|
||||
|
|
|
|||
|
|
@ -720,7 +720,7 @@ returns NIL each time."
|
|||
(let ((,time-left (- ,deadline (get-internal-real-time))))
|
||||
(if (plusp ,time-left)
|
||||
(* (coerce ,time-left 'single-float)
|
||||
(sb-xc:/ $1.0f0 internal-time-units-per-second))
|
||||
(sb-xc:/ 1.0f0 internal-time-units-per-second))
|
||||
0)))))
|
||||
,@body))))
|
||||
|
||||
|
|
|
|||
|
|
@ -288,7 +288,7 @@ doing so may interfere with results reported by eg. TIME.")
|
|||
;; Round up so we don't mislead by saying 0.0 seconds of non-GC time...
|
||||
(- (ceiling total-run-time-us 1000) gc-run-time-ms)
|
||||
(if (zerop real-time-ms)
|
||||
$100.0
|
||||
100.0
|
||||
(float (* 100 (/ (round total-run-time-us 1000) real-time-ms))))
|
||||
eval-calls
|
||||
lambdas-converted
|
||||
|
|
|
|||
|
|
@ -185,19 +185,19 @@ means to wait indefinitely.")
|
|||
(values whole-seconds
|
||||
(truly-the (integer 0 #.(expt 10 9))
|
||||
(%unary-truncate (* (- seconds (float whole-seconds seconds))
|
||||
$1f9)))))))
|
||||
1f9)))))))
|
||||
(declare (inline split-float))
|
||||
(typecase seconds
|
||||
((single-float $0f0 #.(float most-positive-fixnum $1f0))
|
||||
((single-float 0f0 #.(float most-positive-fixnum 1f0))
|
||||
(split-float))
|
||||
((double-float $0d0 #.(float most-positive-fixnum $1d0))
|
||||
((double-float 0d0 #.(float most-positive-fixnum 1d0))
|
||||
(split-float))
|
||||
(ratio
|
||||
(split-ratio-for-sleep seconds))
|
||||
(t
|
||||
(multiple-value-bind (sec frac)
|
||||
(truncate seconds)
|
||||
(values sec (truncate frac $1f-9)))))))
|
||||
(values sec (truncate frac 1f-9)))))))
|
||||
|
||||
(declaim (inline %nanosleep))
|
||||
(defun %nanosleep (sec nsec)
|
||||
|
|
|
|||
|
|
@ -2600,23 +2600,23 @@ expansion happened."
|
|||
(rational
|
||||
(cond ((and (floatp thing) (float-infinity-p thing))
|
||||
(return-from coerce-numeric-bound nil))
|
||||
((or (eql thing $-0d0)
|
||||
(eql thing $-0f0))
|
||||
((or (eql thing -0d0)
|
||||
(eql thing -0f0))
|
||||
0)
|
||||
(t
|
||||
(rational thing))))
|
||||
((float single-float)
|
||||
(cond ((or (eql thing $-0d0)
|
||||
(eql thing $-0f0))
|
||||
$0f0)
|
||||
(cond ((or (eql thing -0d0)
|
||||
(eql thing -0f0))
|
||||
0f0)
|
||||
((sb-xc:<= most-negative-single-float thing most-positive-single-float)
|
||||
(coerce thing 'single-float))
|
||||
(t
|
||||
(return-from coerce-numeric-bound nil))))
|
||||
(double-float
|
||||
(cond ((or (eql thing $-0d0)
|
||||
(eql thing $-0f0))
|
||||
$0d0)
|
||||
(cond ((or (eql thing -0d0)
|
||||
(eql thing -0f0))
|
||||
0d0)
|
||||
((sb-xc:<= most-negative-double-float thing most-positive-double-float)
|
||||
(coerce thing 'double-float))
|
||||
(t
|
||||
|
|
@ -2715,10 +2715,10 @@ expansion happened."
|
|||
(setf class 'integer))
|
||||
(flet ((normalize-zero (x)
|
||||
(cond
|
||||
((eql x $-0d0) $0d0)
|
||||
((eql x $-0f0) $0f0)
|
||||
((equal x '($-0d0)) '($0d0))
|
||||
((equal x '($-0f0)) '($0f0))
|
||||
((eql x -0d0) 0d0)
|
||||
((eql x -0f0) 0f0)
|
||||
((equal x '(-0d0)) '(0d0))
|
||||
((equal x '(-0f0)) '(0f0))
|
||||
(t x))))
|
||||
(declare (inline normalize-zero))
|
||||
(new-ctype numeric-type 0 (get-numtype-aspects complexp class format)
|
||||
|
|
|
|||
|
|
@ -40,13 +40,6 @@
|
|||
(when (sb-int:system-package-p (find-package name))
|
||||
(sb-ext:unlock-package package))))
|
||||
|
||||
;;; Restore target floating-point number syntax
|
||||
(defun read-target-float (stream char)
|
||||
(declare (ignore stream char))
|
||||
(values)) ; ignore the $ as if it weren't there
|
||||
(compile 'read-target-float)
|
||||
(set-macro-character #\$ #'read-target-float t)
|
||||
|
||||
(unless (fboundp 'sb-int:!cold-init-forms)
|
||||
(defmacro sb-int:!cold-init-forms (&rest forms) `(progn ,@forms)))
|
||||
|
||||
|
|
|
|||
|
|
@ -299,8 +299,7 @@
|
|||
;;; that much less efficient by always having to use the intercepted function)
|
||||
;;; We're also not handling 1+ or 1- or INCF, DECF.
|
||||
;;; It's unlikely that a host floating-pointer value could sneak through
|
||||
;;; to one of the un-intercepted functions given the prohibition against
|
||||
;;; using floating-point literals and that almost all other functions
|
||||
;;; to one of the un-intercepted functions given that almost all other functions
|
||||
;;; are intercepted. Granted there are some roundabout ways to spell a
|
||||
;;; floating-point number that can not be detected, such as:
|
||||
;;; (* 50 (hash-table-rehash-threshold (make-hash-table)))
|
||||
|
|
|
|||
|
|
@ -821,74 +821,6 @@
|
|||
(funcall *target-compile-file* filename))))
|
||||
(compile 'target-compile-file)
|
||||
|
||||
;;;; Floating-point number reader interceptor
|
||||
|
||||
(defvar *choke-on-host-irrationals* t)
|
||||
;;; FIXME: this gets stuck on forms which contain literal CTYPE objects
|
||||
;;; because of infinite recursion.
|
||||
(defun install-read-interceptor ()
|
||||
;; Intercept READ to catch inadvertent use of host floating-point literals.
|
||||
;; This prevents regressions in the portable float logic and allows passing
|
||||
;; characters to a floating-point library if we so choose.
|
||||
;; Only do this for new enough SBCL.
|
||||
;; DO-INSTANCE-TAGGED-SLOT was defined circa Nov 2014 and VERSION>= was defined
|
||||
;; ca. Nov 2013, but got moved from SB-IMPL or SB-C (inadvertently perhaps).
|
||||
;; It is not critical that this be enabled on all possible build hosts.
|
||||
#+#.(cl:if (cl:and (cl:find-package "SB-C")
|
||||
(cl:find-symbol "SPLIT-VERSION-STRING" "SB-C")
|
||||
(cl:funcall (cl:find-symbol "VERSION>=" "SB-C")
|
||||
(cl:funcall (cl:find-symbol "SPLIT-VERSION-STRING" "SB-C")
|
||||
(cl:lisp-implementation-version))
|
||||
'(1 4 6)))
|
||||
'(and)
|
||||
'(or))
|
||||
(labels ((contains-irrational (x)
|
||||
(typecase x
|
||||
(cons
|
||||
;; Tail-recursion not guaranteed
|
||||
(do ((cons x (cdr cons)))
|
||||
((atom cons)
|
||||
(contains-irrational cons))
|
||||
(let ((car (contains-irrational (car cons))))
|
||||
(when car (return car)))))
|
||||
(simple-vector (find-if #'contains-irrational x))
|
||||
((or cl:complex cl:float) x)
|
||||
;; We use package literals -- see e.g. SANE-PACKAGE - which
|
||||
;; must be treated as opaque, but COMMAs should not be opaque.
|
||||
;; There are also a few uses of "#.(find-layout)".
|
||||
;; However, the target-num objects should also be opaque
|
||||
;; and, testing for those types before the structure is defined
|
||||
;; is not fun. Other than moving the definitions into here
|
||||
;; from cross-early, there's no good way. But 'chill'
|
||||
;; should not define those structures.
|
||||
((and structure-object (not package))
|
||||
(let ((type-name (string (type-of x))))
|
||||
;; This "LAYOUT" refers to *our* object, not host-sb-kernel:layout.
|
||||
(unless (member type-name '("LAYOUT" "SINGLE-FLOAT" "DOUBLE-FLOAT" "COMPLEXNUM")
|
||||
:test #'string=)
|
||||
;(Format t "visit a ~/host-sb-ext:print-symbol-with-prefix/~%" (type-of x))
|
||||
;; This generalizes over any structure. I need it because we
|
||||
;; observe instances of SB-IMPL::COMMA and also HOST-SB-IMPL::COMMA.
|
||||
;; (primordial-extensions get compiled before 'backq' is installed)
|
||||
(sb-kernel:do-instance-tagged-slot (i x)
|
||||
(when (contains-irrational (sb-kernel:%instance-ref x i))
|
||||
(return-from contains-irrational x))))))))
|
||||
(reader-intercept (f &optional stream (errp t) errval recursive)
|
||||
(let* ((form (funcall f stream errp errval recursive))
|
||||
(bad-atom (and (not recursive) ; avoid checking inner forms
|
||||
(not (eq form errval))
|
||||
*choke-on-host-irrationals*
|
||||
(contains-irrational form))))
|
||||
(when bad-atom
|
||||
(setq *choke-on-host-irrationals* nil) ; one shot, otherwise tough to debug
|
||||
(error "Oops! didn't expect to read ~s containing ~s" form bad-atom))
|
||||
form)))
|
||||
(unless (sb-kernel:closurep (symbol-function 'read))
|
||||
(sb-int:encapsulate 'read-preserving-whitespace 'protect #'reader-intercept)
|
||||
(sb-int:encapsulate 'read 'protect #'reader-intercept)
|
||||
(format t "~&; Installed READ interceptor~%"))))
|
||||
(compile 'install-read-interceptor)
|
||||
|
||||
(defvar *math-ops-memoization* (make-hash-table :test 'equal))
|
||||
(defun math-journal-pathname (direction)
|
||||
;; Initialy we read from the file in the source tree, but writeback occurs
|
||||
|
|
@ -914,9 +846,6 @@
|
|||
`(let* ((table *math-ops-memoization*)
|
||||
(memo (cons table (hash-table-count table))))
|
||||
(assert (atom table)) ; prevent nested use of this macro
|
||||
;; Don't intercept READ until just-in-time, so that "chill" doesn't
|
||||
;; annoyingly get the interceptor installed.
|
||||
(install-read-interceptor)
|
||||
(let ((*math-ops-memoization* memo))
|
||||
,@body)
|
||||
(when nil ; *compile-verbose*
|
||||
|
|
|
|||
|
|
@ -87,12 +87,144 @@
|
|||
(defvar *xc-readtable* (copy-readtable))
|
||||
(set-dispatch-macro-character #\# #\+ #'read-targ-feature-expr *xc-readtable*)
|
||||
(set-dispatch-macro-character #\# #\- #'read-targ-feature-expr *xc-readtable*)
|
||||
|
||||
(defvar *consing-dot*)
|
||||
|
||||
(defun read-potential-real-number (stream char)
|
||||
(let ((buffer (load-time-value
|
||||
;; Assume that we don't have any potential number
|
||||
;; tokens that are too long.
|
||||
(make-array 100 :element-type 'character
|
||||
:fill-pointer 0))))
|
||||
(setf (aref buffer 0) char)
|
||||
(setf (fill-pointer buffer) 1)
|
||||
(loop
|
||||
(let ((char (peek-char nil stream nil nil t))
|
||||
(char-skipping-whitespace (peek-char t stream nil nil t)))
|
||||
;; Check for EOF, delimiting whitespace, or terminating macro
|
||||
;; character.
|
||||
(when (or (null char)
|
||||
(not (eql char char-skipping-whitespace))
|
||||
(multiple-value-bind (function non-terminating-p)
|
||||
(get-macro-character char)
|
||||
(and function (not non-terminating-p))))
|
||||
(return))
|
||||
(vector-push (read-char stream t nil t) buffer)))
|
||||
(when (and (eql char #\.) (= (length buffer) 1))
|
||||
(unless (boundp '*consing-dot*)
|
||||
(if *read-suppress*
|
||||
(return-from read-potential-real-number nil)
|
||||
(error ". not inside list.")))
|
||||
(return-from read-potential-real-number *consing-dot*))
|
||||
(when *read-suppress*
|
||||
(return-from read-potential-real-number nil))
|
||||
;; Check using the host reader whether we would get a float
|
||||
;; literal. If so, read in the float in the target format.
|
||||
(let ((*readtable* (load-time-value (copy-readtable nil))))
|
||||
(multiple-value-bind (object position) (read-from-string buffer)
|
||||
;; Assert that we tokenized the same number of characters as
|
||||
;; the reader did with the standard syntax.
|
||||
(assert (= (length buffer) position))
|
||||
(if (cl:floatp object)
|
||||
(funcall 'read-target-float-from-string buffer)
|
||||
object)))))
|
||||
|
||||
(compile 'read-potential-real-number)
|
||||
|
||||
;;; Treat every potential initial character for a base-10 real number
|
||||
;;; as a reader macro.
|
||||
(dolist (char (coerce ".-+0123456789" 'list))
|
||||
(set-macro-character char #'read-potential-real-number t *xc-readtable*))
|
||||
|
||||
(defun read-maybe-nothing (stream)
|
||||
(let* ((char (read-char stream t nil t)) ; not whitespace
|
||||
(function (get-macro-character char)))
|
||||
(cond (function
|
||||
(multiple-value-call (lambda (&rest args)
|
||||
(if (null args)
|
||||
(values nil t)
|
||||
(values (first args) nil)))
|
||||
(funcall function stream char)))
|
||||
(t
|
||||
(unread-char char stream)
|
||||
(read stream t nil t)))))
|
||||
|
||||
(compile 'read-maybe-nothing)
|
||||
|
||||
(defun read-after-dot (stream)
|
||||
(loop
|
||||
(when (eql (peek-char t stream t nil t) #\))
|
||||
(if *read-suppress*
|
||||
(return-from read-after-dot nil)
|
||||
(error "Nothing appears after . in list.")))
|
||||
(multiple-value-bind (object skipped)
|
||||
(read-maybe-nothing stream)
|
||||
(unless skipped
|
||||
(return
|
||||
(loop
|
||||
(cond ((eql (peek-char t stream t nil t) #\))
|
||||
(return object))
|
||||
((and (not (nth-value 1 (read-maybe-nothing stream)))
|
||||
(not *read-suppress*))
|
||||
(error "More than one object follows . in list.")))))))))
|
||||
|
||||
(compile 'read-after-dot)
|
||||
|
||||
(defun read-list (stream ignore)
|
||||
(declare (ignore ignore))
|
||||
(let* ((read-suppress *read-suppress*)
|
||||
(list (list nil))
|
||||
(tail list)
|
||||
(*consing-dot* list))
|
||||
(declare (dynamic-extent list))
|
||||
(loop
|
||||
(when (eq (peek-char t stream t nil t) #\))
|
||||
(read-char stream)
|
||||
(return (cdr list)))
|
||||
(multiple-value-bind (object skipped)
|
||||
(read-maybe-nothing stream)
|
||||
(cond ((eq object *consing-dot*)
|
||||
(when (eq list tail)
|
||||
(unless read-suppress
|
||||
(error "Nothing appears before . in list.")))
|
||||
(rplacd tail (read-after-dot stream)))
|
||||
((and (not skipped) (not read-suppress))
|
||||
(setq tail
|
||||
(cdr (rplacd tail (list object))))))))))
|
||||
|
||||
(compile 'read-list)
|
||||
|
||||
;;; We need to install our own left parenthesis reader macro to make
|
||||
;;; it communicate with the dot reader macro for reading real numbers,
|
||||
;;; since #\. can be used both as an initial float character as well
|
||||
;;; as a consing dot in the standard syntax. Although sbcl (and cmu
|
||||
;;; cl) themselves as a host lisps do not need this for consing dot to
|
||||
;;; work, other implementations do, and it's ambiguous whether this is
|
||||
;;; strictly necessary.
|
||||
(set-macro-character #\( #'read-list nil *xc-readtable*)
|
||||
|
||||
;;; The reader will be defined during compilation. CLISP does not permit assignment
|
||||
;;; of a symbol that currently has no functional definition, so wrap it in lambda.
|
||||
(set-macro-character #\$ (lambda (stream char)
|
||||
(funcall 'read-target-float stream char))
|
||||
t ; non-terminating so that symbols may contain a dollar sign
|
||||
*xc-readtable*)
|
||||
(set-dispatch-macro-character #\# #\c
|
||||
(lambda (stream sub-char numarg)
|
||||
(funcall 'read-target-complex stream sub-char numarg))
|
||||
*xc-readtable*)
|
||||
|
||||
;;; ECL needs a bit of help:
|
||||
;;; https://gitlab.com/embeddable-common-lisp/ecl/-/issues/742
|
||||
#+ecl
|
||||
(macrolet ((frob (char base)
|
||||
`(set-dispatch-macro-character #\# ,char
|
||||
(lambda (stream sub-char numarg)
|
||||
(declare (ignore sub-char))
|
||||
(declare (ignorable numarg))
|
||||
(let ((*read-base* ,base))
|
||||
(read stream t nil t)))
|
||||
*xc-readtable*)))
|
||||
(frob #\r numarg)
|
||||
(frob #\x 16)
|
||||
(frob #\o 8)
|
||||
(frob #\b 2))
|
||||
|
||||
;;;; string checker, for catching non-portability early
|
||||
|
||||
|
|
|
|||
|
|
@ -116,9 +116,6 @@
|
|||
*compile-file-pathname*
|
||||
*load-truename*
|
||||
*load-pathname*
|
||||
;; READ might get altered
|
||||
read
|
||||
read-preserving-whitespace
|
||||
;; These change because CMU CL uses them as internal
|
||||
;; variables:
|
||||
,@'
|
||||
|
|
|
|||
|
|
@ -367,8 +367,8 @@
|
|||
alien-rep-type)
|
||||
'(int-sap 0))
|
||||
((ctypep 0 alien-rep-type) 0)
|
||||
((ctypep $0.0f0 alien-rep-type) $0.0f0)
|
||||
((ctypep $0.0d0 alien-rep-type) $0.0d0)
|
||||
((ctypep 0.0f0 alien-rep-type) 0.0f0)
|
||||
((ctypep 0.0d0 alien-rep-type) 0.0d0)
|
||||
(t
|
||||
(compiler-error
|
||||
"Aliens of type ~S cannot be represented immediately."
|
||||
|
|
|
|||
|
|
@ -442,9 +442,9 @@
|
|||
(:args (x :scs (,sc)))
|
||||
(:arg-types ,ptype (:constant, constant-type)))))
|
||||
(frob single-float-compare-zero single-reg single-float
|
||||
(single-float $-0f0 $0f0))
|
||||
(single-float -0f0 0f0))
|
||||
(frob double-float-compare-zero double-reg double-float
|
||||
(double-float $-0d0 $0d0)))
|
||||
(double-float -0d0 0d0)))
|
||||
|
||||
(macrolet ((frob (translate cond sname dname is-=)
|
||||
`(progn
|
||||
|
|
|
|||
|
|
@ -33,8 +33,8 @@
|
|||
((single-immediate) (single-reg)
|
||||
(double-immediate) (double-reg))
|
||||
(let ((x (tn-value x)))
|
||||
(cond ((or (eql x $0f0)
|
||||
(eql x $0d0))
|
||||
(cond ((or (eql x 0f0)
|
||||
(eql x 0d0))
|
||||
(inst fmov y zr-tn))
|
||||
((encode-fp-immediate x)
|
||||
(inst fmov y x))
|
||||
|
|
@ -409,9 +409,9 @@
|
|||
(:args (x :scs (,sc)))
|
||||
(:arg-types ,ptype (:constant, constant-type)))))
|
||||
(frob single-float-compare-zero single-reg single-float
|
||||
(single-float $-0f0 $0f0))
|
||||
(single-float -0f0 0f0))
|
||||
(frob double-float-compare-zero double-reg double-float
|
||||
(double-float $-0d0 $0d0)))
|
||||
(double-float -0d0 0d0)))
|
||||
|
||||
(macrolet ((frob (translate cond sname dname is-=)
|
||||
`(progn
|
||||
|
|
|
|||
|
|
@ -2268,9 +2268,9 @@
|
|||
`(define-instruction ,name (segment rn rm)
|
||||
(:printer fp-compare ((op ,op)))
|
||||
(:printer fp-compare ((op ,op) (z 1) (type 0))
|
||||
'(:name :tab rn ", " $0f0))
|
||||
'(:name :tab rn ", " 0f0))
|
||||
(:printer fp-compare ((op ,op) (z 1) (type 1))
|
||||
'(:name :tab rn ", " $0d0))
|
||||
'(:name :tab rn ", " 0d0))
|
||||
(:emitter
|
||||
(assert (or (eql rm 0)
|
||||
(eq (tn-sc rn)
|
||||
|
|
|
|||
|
|
@ -120,7 +120,7 @@
|
|||
((any-reg descriptor-reg))
|
||||
(immediate
|
||||
(not (or
|
||||
(eql (tn-value y) $0f0)
|
||||
(eql (tn-value y) 0f0)
|
||||
(and (integerp (tn-value y))
|
||||
(abs-add-sub-immediate-p (fixnumize (tn-value y)))))))
|
||||
(t t))))
|
||||
|
|
@ -131,7 +131,7 @@
|
|||
(let ((value (sc-case y
|
||||
(immediate
|
||||
(let ((value (tn-value y)))
|
||||
(if (eql value $0f0)
|
||||
(if (eql value 0f0)
|
||||
single-float-widetag
|
||||
(fixnumize (tn-value y)))))
|
||||
(t y))))
|
||||
|
|
|
|||
|
|
@ -176,7 +176,7 @@
|
|||
(let ((temp (gensym)))
|
||||
`(let ((,temp (abs float2)))
|
||||
(if (minusp (single-float-bits float)) (- ,temp) ,temp)))
|
||||
'(if (minusp (single-float-bits float)) $-1f0 $1f0))))
|
||||
'(if (minusp (single-float-bits float)) -1f0 1f0))))
|
||||
|
||||
(deftransform float-sign ((float &optional float2)
|
||||
(double-float &optional double-float) *)
|
||||
|
|
@ -188,7 +188,7 @@
|
|||
(let ((temp (gensym)))
|
||||
`(let ((,temp (abs float2)))
|
||||
(if (minusp ,bits) (- ,temp) ,temp)))
|
||||
`(if (minusp ,bits) $-1d0 $1d0))))
|
||||
`(if (minusp ,bits) -1d0 1d0))))
|
||||
|
||||
(deftransform float-sign-bit ((x) (single-float) *)
|
||||
`(logand (ash (single-float-bits x) -31) 1))
|
||||
|
|
@ -220,11 +220,11 @@
|
|||
;;;; DECODE-FLOAT, INTEGER-DECODE-FLOAT, and SCALE-FLOAT
|
||||
|
||||
(defknown decode-single-float (single-float)
|
||||
(values single-float single-float-exponent (member $-1f0 $1f0))
|
||||
(values single-float single-float-exponent (member -1f0 1f0))
|
||||
(movable foldable flushable))
|
||||
|
||||
(defknown decode-double-float (double-float)
|
||||
(values double-float double-float-exponent (member $-1d0 $1d0))
|
||||
(values double-float double-float-exponent (member -1d0 1d0))
|
||||
(movable foldable flushable))
|
||||
|
||||
(defknown integer-decode-single-float (single-float)
|
||||
|
|
@ -310,13 +310,13 @@
|
|||
(new-lo nil)
|
||||
(new-hi nil))
|
||||
(when f-hi
|
||||
(if (sb-xc:< (float-sign (type-bound-number f-hi)) $0.0)
|
||||
(if (sb-xc:< (float-sign (type-bound-number f-hi)) 0.0)
|
||||
(when ex-lo
|
||||
(setf new-hi (scale-bound f-hi ex-lo)))
|
||||
(when ex-hi
|
||||
(setf new-hi (scale-bound f-hi ex-hi)))))
|
||||
(when f-lo
|
||||
(if (sb-xc:< (float-sign (type-bound-number f-lo)) $0.0)
|
||||
(if (sb-xc:< (float-sign (type-bound-number f-lo)) 0.0)
|
||||
(when ex-hi
|
||||
(setf new-lo (scale-bound f-lo ex-hi)))
|
||||
(when ex-lo
|
||||
|
|
@ -388,8 +388,8 @@
|
|||
(if (minusp y)
|
||||
'(%negate x)
|
||||
'x)))))
|
||||
(def single-float $1.0 $-1.0)
|
||||
(def double-float $1.0d0 $-1.0d0))
|
||||
(def single-float 1.0 -1.0)
|
||||
(def double-float 1.0d0 -1.0d0))
|
||||
|
||||
;;; Return the reciprocal of X if it can be represented exactly, NIL otherwise.
|
||||
(defun maybe-exact-reciprocal (x)
|
||||
|
|
@ -434,17 +434,17 @@
|
|||
:policy (zerop float-accuracy))
|
||||
'x)))
|
||||
;; No signed zeros, thanks.
|
||||
(def + single-float 0 $0.0)
|
||||
(def - single-float 0 $0.0)
|
||||
(def + double-float 0 $0.0 $0.0d0)
|
||||
(def - double-float 0 $0.0 $0.0d0))
|
||||
(def + single-float 0 0.0)
|
||||
(def - single-float 0 0.0)
|
||||
(def + double-float 0 0.0 0.0d0)
|
||||
(def - double-float 0 0.0 0.0d0))
|
||||
|
||||
;;; On most platforms (+ x x) is faster than (* x 2)
|
||||
(macrolet ((def (type &rest args)
|
||||
`(deftransform * ((x y) (,type (constant-arg (member ,@args))))
|
||||
'(+ x x))))
|
||||
(def single-float 2 $2.0)
|
||||
(def double-float 2 $2.0 $2.0d0))
|
||||
(def single-float 2 2.0)
|
||||
(def double-float 2 2.0 2.0d0))
|
||||
|
||||
;;; Prevent ZEROP, PLUSP, and MINUSP from losing horribly. We can't in
|
||||
;;; general float rational args to comparison, since Common Lisp
|
||||
|
|
@ -519,8 +519,8 @@
|
|||
(deftransform ,name ((x) (single-float) *)
|
||||
#+x86 (cond ((csubtypep (lvar-type x)
|
||||
(specifier-type
|
||||
`(single-float (,(sb-xc:- (expt $2f0 63)))
|
||||
(,(expt $2f0 63)))))
|
||||
`(single-float (,(sb-xc:- (expt 2f0 63)))
|
||||
(,(expt 2f0 63)))))
|
||||
`(coerce (,',prim-quick (coerce x 'double-float))
|
||||
'single-float))
|
||||
(t
|
||||
|
|
@ -533,8 +533,8 @@
|
|||
(deftransform ,name ((x) (double-float) *)
|
||||
#+x86 (cond ((csubtypep (lvar-type x)
|
||||
(specifier-type
|
||||
`(double-float (,(sb-xc:- (expt $2d0 63)))
|
||||
(,(expt $2d0 63)))))
|
||||
`(double-float (,(sb-xc:- (expt 2d0 63)))
|
||||
(,(expt 2d0 63)))))
|
||||
`(,',prim-quick x))
|
||||
(t
|
||||
(compiler-notify
|
||||
|
|
@ -653,8 +653,8 @@
|
|||
(minusp (float-sign arg-lo-val)))
|
||||
(setf arg-lo
|
||||
(typecase arg-lo-val
|
||||
(single-float $0f0)
|
||||
(double-float $0d0)
|
||||
(single-float 0f0)
|
||||
(double-float 0d0)
|
||||
#+long-float
|
||||
(long-float 0l0))
|
||||
arg-lo-val arg-lo))
|
||||
|
|
@ -662,10 +662,10 @@
|
|||
(plusp (float-sign arg-hi-val)))
|
||||
(setf arg-hi
|
||||
(typecase arg-lo-val
|
||||
(single-float $-0f0)
|
||||
(double-float $-0d0)
|
||||
(single-float -0f0)
|
||||
(double-float -0d0)
|
||||
#+long-float
|
||||
(long-float $-0L0))
|
||||
(long-float -0L0))
|
||||
arg-hi-val arg-hi))
|
||||
(flet ((fp-neg-zero-p (f) ; Is F -0.0?
|
||||
(and (floatp f) (zerop f) (float-sign-bit-set-p f)))
|
||||
|
|
@ -771,15 +771,15 @@
|
|||
|
||||
;; These functions are only defined for part of the real line. The
|
||||
;; condition selects the desired part of the line.
|
||||
(frob asin $-1d0 $1d0 (sb-xc:- (sb-xc:/ pi 2)) (sb-xc:/ pi 2))
|
||||
(frob asin -1d0 1d0 (sb-xc:- (sb-xc:/ pi 2)) (sb-xc:/ pi 2))
|
||||
;; Acos is monotonic decreasing, so we need to swap the function
|
||||
;; values at the lower and upper bounds of the input domain.
|
||||
(frob acos $-1d0 $1d0 0 pi :increasingp nil)
|
||||
(frob acosh $1d0 nil nil nil)
|
||||
(frob atanh $-1d0 $1d0 -1 1)
|
||||
(frob acos -1d0 1d0 0 pi :increasingp nil)
|
||||
(frob acosh 1d0 nil nil nil)
|
||||
(frob atanh -1d0 1d0 -1 1)
|
||||
;; Kahan says that (sqrt -0.0) is -0.0, so use a specifier that
|
||||
;; includes -0.0.
|
||||
(frob sqrt $-0.0d0 nil 0 nil))
|
||||
(frob sqrt -0.0d0 nil 0 nil))
|
||||
|
||||
;;; Compute bounds for (expt x y). This should be easy since (expt x
|
||||
;;; y) = (exp (* y (log x))). However, computations done this way
|
||||
|
|
@ -799,7 +799,7 @@
|
|||
|
||||
;;; Handle the case when x >= 1.
|
||||
(defun interval-expt-> (x y)
|
||||
(case (interval-range-info y $0d0)
|
||||
(case (interval-range-info y 0d0)
|
||||
(+
|
||||
;; Y is positive and log X >= 0. The range of exp(y * log(x)) is
|
||||
;; obviously non-negative. We just have to be careful for
|
||||
|
|
@ -827,7 +827,7 @@
|
|||
|
||||
;;; Handle the case when 0 <= x <= 1
|
||||
(defun interval-expt-< (x y)
|
||||
(case (interval-range-info x $0d0)
|
||||
(case (interval-range-info x 0d0)
|
||||
(+
|
||||
;; The case of 0 <= x <= 1 is easy
|
||||
(case (interval-range-info y)
|
||||
|
|
@ -1047,11 +1047,11 @@
|
|||
;;; Note we must assume that a type including 0.0 may also include
|
||||
;;; -0.0 and thus the result may be complex -infinity + i*pi.
|
||||
(defun log-derive-type-aux-1 (x)
|
||||
(elfun-derive-type-simple x #'log $0d0 nil
|
||||
(elfun-derive-type-simple x #'log 0d0 nil
|
||||
;; (log 0) is an error
|
||||
;; and there's nothing between 0 and 1 for integers.
|
||||
(and (integer-type-p x)
|
||||
$0f0)
|
||||
0f0)
|
||||
nil))
|
||||
|
||||
(defun log-derive-type-aux-2 (x y same-arg)
|
||||
|
|
@ -1116,7 +1116,7 @@
|
|||
(t (numeric-type-format arg))))
|
||||
(bound-type (or format 'float)))
|
||||
(cond ((numeric-type-real-p arg)
|
||||
(case (interval-range-info> (numeric-type->interval arg) $0.0)
|
||||
(case (interval-range-info> (numeric-type->interval arg) 0.0)
|
||||
(+
|
||||
;; The number is positive, so the phase is 0.
|
||||
(make-numeric-type :class 'float
|
||||
|
|
@ -1164,10 +1164,10 @@
|
|||
|
||||
(deftransform realpart ((x) (real) * :important nil)
|
||||
'x)
|
||||
(deftransform imagpart ((x) ((and single-float (not (eql $-0f0)))) * :important nil)
|
||||
$0f0)
|
||||
(deftransform imagpart ((x) ((and double-float (not (eql $-0d0)))) * :important nil)
|
||||
$0d0)
|
||||
(deftransform imagpart ((x) ((and single-float (not (eql -0f0)))) * :important nil)
|
||||
0f0)
|
||||
(deftransform imagpart ((x) ((and double-float (not (eql -0d0)))) * :important nil)
|
||||
0d0)
|
||||
|
||||
;;; Make REALPART and IMAGPART return the appropriate types. This
|
||||
;;; should help a lot in optimized code.
|
||||
|
|
@ -1567,7 +1567,7 @@
|
|||
(lambda (arg)
|
||||
;; Derive the bounds if the arg is in [0, pi].
|
||||
(trig-derive-type-aux arg
|
||||
(specifier-type `(float $0d0 ,pi))
|
||||
(specifier-type `(float 0d0 ,pi))
|
||||
#'cos
|
||||
-1 1
|
||||
nil))
|
||||
|
|
@ -1683,9 +1683,9 @@
|
|||
(when (csubtypep x (specifier-type 'rational))
|
||||
(try 0))
|
||||
(when (csubtypep x (specifier-type 'double-float))
|
||||
(try $0d0))
|
||||
(try 0d0))
|
||||
(when (csubtypep x (specifier-type 'single-float))
|
||||
(try $0f0))))))
|
||||
(try 0f0))))))
|
||||
(typecase type
|
||||
(numeric-type (numeric type))
|
||||
(union-type (mapc #'numeric (union-type-types type))))
|
||||
|
|
@ -1834,8 +1834,8 @@
|
|||
(single-float 'round-single))
|
||||
div :truncate)
|
||||
,,(ecase type
|
||||
(double-float $-0.0d0)
|
||||
(single-float $-0.0f0)))
|
||||
(double-float -0.0d0)
|
||||
(single-float -0.0f0)))
|
||||
#-round-float
|
||||
(locally
|
||||
(declare (flushable ,',coerce))
|
||||
|
|
@ -1895,8 +1895,8 @@
|
|||
(single-float 'round-single))
|
||||
div :truncate)
|
||||
,,(ecase type
|
||||
(double-float $-0.0d0)
|
||||
(single-float $-0.0f0)))
|
||||
(double-float -0.0d0)
|
||||
(single-float -0.0f0)))
|
||||
#-round-float
|
||||
(locally
|
||||
(declare (flushable ,',coerce))
|
||||
|
|
@ -1958,44 +1958,44 @@
|
|||
(movable foldable flushable))
|
||||
|
||||
(deftransform %unary-ftruncate ((x) (single-float))
|
||||
`(cond ((or (typep x '(single-float ($-1f0) ($0f0)))
|
||||
(eql x $-0f0))
|
||||
$-0f0)
|
||||
((typep x '(single-float ,(float (- (expt 2 sb-vm:single-float-digits)) $1f0)
|
||||
,(float (1- (expt 2 sb-vm:single-float-digits)) $1f0)))
|
||||
(float (truncate x) $1f0))
|
||||
`(cond ((or (typep x '(single-float (-1f0) (0f0)))
|
||||
(eql x -0f0))
|
||||
-0f0)
|
||||
((typep x '(single-float ,(float (- (expt 2 sb-vm:single-float-digits)) 1f0)
|
||||
,(float (1- (expt 2 sb-vm:single-float-digits)) 1f0)))
|
||||
(float (truncate x) 1f0))
|
||||
(t
|
||||
x)))
|
||||
|
||||
(deftransform %unary-fround ((x) (single-float))
|
||||
`(cond ((or (typep x '(single-float $-0.5f0 ($0f0)))
|
||||
(eql x $-0f0))
|
||||
$-0f0)
|
||||
((typep x '(single-float ,(float (- (expt 2 sb-vm:single-float-digits)) $1f0)
|
||||
,(float (1- (expt 2 sb-vm:single-float-digits)) $1f0)))
|
||||
(float (round x) $1f0))
|
||||
`(cond ((or (typep x '(single-float -0.5f0 (0f0)))
|
||||
(eql x -0f0))
|
||||
-0f0)
|
||||
((typep x '(single-float ,(float (- (expt 2 sb-vm:single-float-digits)) 1f0)
|
||||
,(float (1- (expt 2 sb-vm:single-float-digits)) 1f0)))
|
||||
(float (round x) 1f0))
|
||||
(t
|
||||
x)))
|
||||
|
||||
#+64-bit
|
||||
(progn
|
||||
(deftransform %unary-ftruncate ((x) (double-float))
|
||||
`(cond ((or (typep x '(double-float ($-1d0) ($0d0)))
|
||||
(eql x $-0d0))
|
||||
$-0d0)
|
||||
((typep x '(double-float ,(float (- (expt 2 sb-vm:double-float-digits)) $1d0)
|
||||
,(float (1- (expt 2 sb-vm:double-float-digits)) $1d0)))
|
||||
(float (truncate x) $1d0))
|
||||
`(cond ((or (typep x '(double-float (-1d0) (0d0)))
|
||||
(eql x -0d0))
|
||||
-0d0)
|
||||
((typep x '(double-float ,(float (- (expt 2 sb-vm:double-float-digits)) 1d0)
|
||||
,(float (1- (expt 2 sb-vm:double-float-digits)) 1d0)))
|
||||
(float (truncate x) 1d0))
|
||||
(t
|
||||
x)))
|
||||
|
||||
(deftransform %unary-fround ((x) (double-float))
|
||||
`(cond ((or (typep x '(double-float $-0.5d0 ($0d0)))
|
||||
(eql x $-0d0))
|
||||
$-0d0)
|
||||
((typep x '(double-float ,(float (- (expt 2 sb-vm:double-float-digits)) $1d0)
|
||||
,(float (1- (expt 2 sb-vm:double-float-digits)) $1d0)))
|
||||
(float (round x) $1d0))
|
||||
`(cond ((or (typep x '(double-float -0.5d0 (0d0)))
|
||||
(eql x -0d0))
|
||||
-0d0)
|
||||
((typep x '(double-float ,(float (- (expt 2 sb-vm:double-float-digits)) 1d0)
|
||||
,(float (1- (expt 2 sb-vm:double-float-digits)) 1d0)))
|
||||
(float (round x) 1d0))
|
||||
(t
|
||||
x))))
|
||||
|
||||
|
|
@ -2016,7 +2016,7 @@
|
|||
(type (unsigned-byte 32) low))
|
||||
(cond
|
||||
((= exp sb-vm:double-float-normal-exponent-max) x)
|
||||
((<= biased 0) (* x $0d0))
|
||||
((<= biased 0) (* x 0d0))
|
||||
((>= biased (float-digits x)) x)
|
||||
(t
|
||||
(let ((frac-bits (- (float-digits x) biased)))
|
||||
|
|
@ -2039,15 +2039,15 @@
|
|||
(type (unsigned-byte 32) low))
|
||||
(cond
|
||||
((= exp sb-vm:double-float-normal-exponent-max) x)
|
||||
((<= biased -1) (* x $0d0)) ; [0,0.5)
|
||||
((<= biased -1) (* x 0d0)) ; [0,0.5)
|
||||
((and (= biased 0) (= low 0) (= (ldb sb-vm:double-float-hi-significand-byte high) 0)) ; [0.5,0.5]
|
||||
(* x $0d0))
|
||||
((= biased 0) (float-sign x $1d0)) ; (0.5,1.0)
|
||||
(* x 0d0))
|
||||
((= biased 0) (float-sign x 1d0)) ; (0.5,1.0)
|
||||
((= biased 1) ; [1.0,2.0)
|
||||
(cond
|
||||
((>= (ldb sb-vm:double-float-hi-significand-byte high) (ash 1 19))
|
||||
(float-sign x $2d0))
|
||||
(t (float-sign x $1d0))))
|
||||
(float-sign x 2d0))
|
||||
(t (float-sign x 1d0))))
|
||||
((>= biased (float-digits x)) x)
|
||||
(t
|
||||
;; it's probably possible to do something very contorted
|
||||
|
|
@ -2056,7 +2056,7 @@
|
|||
;; part, the high integer part, and the exponent of the
|
||||
;; double float. But in the interest of getting
|
||||
;; something correct to start with, delegate to ROUND.
|
||||
(float (round x) $1d0))))))
|
||||
(float (round x) 1d0))))))
|
||||
(deftransform %unary-ftruncate ((x) (double-float))
|
||||
`(%unary-ftruncate/double x))
|
||||
(deftransform %unary-fround ((x) (double-float))
|
||||
|
|
|
|||
|
|
@ -320,7 +320,7 @@
|
|||
(movable foldable flushable))
|
||||
|
||||
(defknown (sin cos) (number)
|
||||
(or (float $-1.0 $1.0) (complex float))
|
||||
(or (float -1.0 1.0) (complex float))
|
||||
(movable foldable flushable recursive))
|
||||
|
||||
(defknown atan
|
||||
|
|
@ -360,7 +360,7 @@
|
|||
(defknown unary-truncate (real) (values integer real)
|
||||
(movable foldable flushable no-verify-arg-count))
|
||||
|
||||
(defknown unary-truncate-single-float-to-bignum (single-float) (values bignum (eql $0f0))
|
||||
(defknown unary-truncate-single-float-to-bignum (single-float) (values bignum (eql 0f0))
|
||||
(foldable movable flushable fixed-args)
|
||||
:folder #'truncate)
|
||||
|
||||
|
|
@ -369,7 +369,7 @@
|
|||
(and
|
||||
#+(and 64-bit
|
||||
(not (or riscv ppc64))) ;; they can't survive cold-init
|
||||
(eql $0d0)
|
||||
(eql 0d0)
|
||||
double-float))
|
||||
(foldable movable flushable fixed-args)
|
||||
:folder #'truncate)
|
||||
|
|
@ -431,11 +431,11 @@
|
|||
:derive-type (lambda (call &aux (args (combination-args call))
|
||||
(type (unless (cdr args) (lvar-type (first args)))))
|
||||
(cond ((and type (csubtypep type (specifier-type 'single-float)))
|
||||
(specifier-type '(member $1f0 $-1f0)))
|
||||
(specifier-type '(member 1f0 -1f0)))
|
||||
((and type (csubtypep type (specifier-type 'double-float)))
|
||||
(specifier-type '(member $1d0 $-1d0)))
|
||||
(specifier-type '(member 1d0 -1d0)))
|
||||
(type
|
||||
(specifier-type '(member $1f0 $-1f0 $1d0 $-1d0)))
|
||||
(specifier-type '(member 1f0 -1f0 1d0 -1d0)))
|
||||
(t
|
||||
(specifier-type 'float)))))
|
||||
|
||||
|
|
@ -493,8 +493,8 @@
|
|||
(movable foldable flushable))
|
||||
(defknown deposit-field (integer byte-specifier integer) integer
|
||||
(movable foldable flushable))
|
||||
(defknown random ((or (float ($0.0f0)) (integer 1)) &optional random-state)
|
||||
(or (float $0.0f0) (integer 0))
|
||||
(defknown random ((or (float (0.0f0)) (integer 1)) &optional random-state)
|
||||
(or (float 0.0f0) (integer 0))
|
||||
())
|
||||
(defknown make-random-state (&optional (or random-state (member nil t)))
|
||||
random-state (flushable))
|
||||
|
|
@ -1151,7 +1151,7 @@
|
|||
|
||||
(defknown make-hash-table
|
||||
(&key (:test function-designator) (:size unsigned-byte)
|
||||
(:rehash-size (or (integer 1) (float ($1.0))))
|
||||
(:rehash-size (or (integer 1) (float (1.0))))
|
||||
(:rehash-threshold (real 0 1))
|
||||
(:hash-function (or null function-designator))
|
||||
(:weakness (member nil :key :value :key-and-value :key-or-value))
|
||||
|
|
@ -1171,9 +1171,9 @@
|
|||
(defknown maphash ((function-designator (t t)) hash-table) null (flushable call))
|
||||
(defknown clrhash ((modifying hash-table)) hash-table ())
|
||||
(defknown hash-table-count (hash-table) index (flushable))
|
||||
(defknown hash-table-rehash-size (hash-table) (or index (single-float ($1.0)))
|
||||
(defknown hash-table-rehash-size (hash-table) (or index (single-float (1.0)))
|
||||
(foldable flushable))
|
||||
(defknown hash-table-rehash-threshold (hash-table) (single-float ($0.0) $1.0)
|
||||
(defknown hash-table-rehash-threshold (hash-table) (single-float (0.0) 1.0)
|
||||
(foldable flushable))
|
||||
(defknown hash-table-size (hash-table) index (flushable))
|
||||
(defknown hash-table-test (hash-table) function-designator (foldable flushable))
|
||||
|
|
|
|||
|
|
@ -2076,10 +2076,10 @@ core and return a descriptor to it."
|
|||
|
||||
#+x86
|
||||
(progn
|
||||
(cold-set 'sb-vm::*fp-constant-0d0* (number-to-core $0d0))
|
||||
(cold-set 'sb-vm::*fp-constant-1d0* (number-to-core $1d0))
|
||||
(cold-set 'sb-vm::*fp-constant-0f0* (number-to-core $0f0))
|
||||
(cold-set 'sb-vm::*fp-constant-1f0* (number-to-core $1f0))))
|
||||
(cold-set 'sb-vm::*fp-constant-0d0* (number-to-core 0d0))
|
||||
(cold-set 'sb-vm::*fp-constant-1d0* (number-to-core 1d0))
|
||||
(cold-set 'sb-vm::*fp-constant-0f0* (number-to-core 0f0))
|
||||
(cold-set 'sb-vm::*fp-constant-1f0* (number-to-core 1f0))))
|
||||
|
||||
;;;; functions and fdefinition objects
|
||||
|
||||
|
|
|
|||
|
|
@ -79,8 +79,8 @@
|
|||
#+sb-unicode
|
||||
(character ,(cl:code-char 0) 32 simple-character-string
|
||||
:complex-typecode #.complex-character-string-widetag)
|
||||
(single-float $0.0f0 32 simple-array-single-float)
|
||||
(double-float $0.0d0 64 simple-array-double-float)
|
||||
(single-float 0.0f0 32 simple-array-single-float)
|
||||
(double-float 0.0d0 64 simple-array-double-float)
|
||||
(bit 0 1 simple-bit-vector
|
||||
:complex-typecode #.complex-bit-vector-widetag)
|
||||
;; KLUDGE: The fact that these UNSIGNED-BYTE entries come
|
||||
|
|
@ -125,12 +125,12 @@
|
|||
(fixnum 0 64 simple-array-fixnum :fixnum-p t)
|
||||
#+64-bit
|
||||
((signed-byte 64) 0 64 simple-array-signed-byte-64)
|
||||
((complex single-float) ,(complex $0f0 $0f0) 64
|
||||
((complex single-float) #C(0f0 0f0) 64
|
||||
simple-array-complex-single-float)
|
||||
((complex double-float) ,(complex $0d0 $0d0) 128
|
||||
((complex double-float) #C(0d0 0d0) 128
|
||||
simple-array-complex-double-float)
|
||||
#+long-float
|
||||
((complex long-float) ,(complex $0L0 $0L0) #+x86 192 #+sparc 256
|
||||
((complex long-float) #C(0L0 0L0) #+x86 192 #+sparc 256
|
||||
simple-array-complex-long-float)
|
||||
(t 0 #.n-word-bits simple-vector)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -758,7 +758,7 @@
|
|||
(movable foldable flushable))
|
||||
|
||||
(defknown (%sin %cos %tanh %sin-quick %cos-quick)
|
||||
(double-float) (double-float $-1.0d0 $1.0d0)
|
||||
(double-float) (double-float -1.0d0 1.0d0)
|
||||
(movable foldable flushable))
|
||||
|
||||
(defknown (%asin %atan)
|
||||
|
|
@ -768,23 +768,23 @@
|
|||
(movable foldable flushable))
|
||||
|
||||
(defknown (%acos)
|
||||
(double-float) (double-float $0.0d0 #.(coerce pi 'double-float))
|
||||
(double-float) (double-float 0.0d0 #.(coerce pi 'double-float))
|
||||
(movable foldable flushable))
|
||||
|
||||
(defknown (%cosh)
|
||||
(double-float) (double-float $1.0d0)
|
||||
(double-float) (double-float 1.0d0)
|
||||
(movable foldable flushable))
|
||||
|
||||
(defknown (%acosh %exp %sqrt)
|
||||
(double-float) (double-float $0.0d0)
|
||||
(double-float) (double-float 0.0d0)
|
||||
(movable foldable flushable))
|
||||
|
||||
(defknown %expm1
|
||||
(double-float) (double-float $-1d0)
|
||||
(double-float) (double-float -1d0)
|
||||
(movable foldable flushable))
|
||||
|
||||
(defknown (%hypot)
|
||||
(double-float double-float) (double-float $0d0)
|
||||
(double-float double-float) (double-float 0d0)
|
||||
(movable foldable flushable))
|
||||
|
||||
(defknown (%pow)
|
||||
|
|
|
|||
|
|
@ -1009,7 +1009,7 @@
|
|||
;; Translate primitive type scs into constant scs
|
||||
((= sc sb-vm:descriptor-reg-sc-number)
|
||||
(cond #+(or arm64 x86-64)
|
||||
((eql (tn-value tn) $0f0)
|
||||
((eql (tn-value tn) 0f0)
|
||||
;; Can be loaded using just SINGLE-FLOAT-WIDETAG.
|
||||
(setf (tn-sc tn)
|
||||
(svref *backend-sc-numbers* sb-vm:immediate-sc-number)))
|
||||
|
|
|
|||
|
|
@ -1183,8 +1183,8 @@
|
|||
;; to watch out for positive or negative infinity.
|
||||
(cond ((floatp (type-bound-number x))
|
||||
(if y-low-p
|
||||
(sb-xc:- (float-sign (type-bound-number x) $0.0))
|
||||
(float-sign (type-bound-number x) $0.0)))
|
||||
(sb-xc:- (float-sign (type-bound-number x) 0.0))
|
||||
(float-sign (type-bound-number x) 0.0)))
|
||||
((and integer
|
||||
(not (interval-contains-p 0 top)))
|
||||
'(0))
|
||||
|
|
@ -3726,7 +3726,7 @@
|
|||
(deftransform floor ((number divisor) ((real (0) (1)) (integer (0) *)) * :important nil)
|
||||
`(values 0 number))
|
||||
|
||||
(deftransform truncate ((number divisor) ((and (real (-1) (1)) (not (eql $-0d0)) (not (eql $-0f0)))
|
||||
(deftransform truncate ((number divisor) ((and (real (-1) (1)) (not (eql -0d0)) (not (eql -0f0)))
|
||||
(and integer (not (eql 0))))
|
||||
* :important nil)
|
||||
`(values 0 number))
|
||||
|
|
@ -4303,7 +4303,7 @@
|
|||
((= val -1/2) '(/ (sqrt x)))
|
||||
(t (give-up-ir1-transform)))))
|
||||
|
||||
(deftransform expt ((x y) ((constant-arg (member -1 $-1.0 $-1.0d0)) integer) *)
|
||||
(deftransform expt ((x y) ((constant-arg (member -1 -1.0 -1.0d0)) integer) *)
|
||||
"recode as an ODDP check"
|
||||
(let ((val (lvar-value x)))
|
||||
(if (eql -1 val)
|
||||
|
|
|
|||
|
|
@ -259,7 +259,7 @@
|
|||
(or (and (symbolp val) (not (sb-vm:static-symbol-p val)))
|
||||
(typep val 'layout))))
|
||||
#+(or arm64 x86-64)
|
||||
(not (eql (constant-value constant) $0f0)))
|
||||
(not (eql (constant-value constant) 0f0)))
|
||||
(let ((constants (ir2-component-constants component)))
|
||||
(setf (tn-offset res)
|
||||
(vector-push-extend constant constants))))
|
||||
|
|
|
|||
|
|
@ -471,15 +471,15 @@
|
|||
immediate-sc-number))
|
||||
#+compact-instance-header (layout immediate-sc-number)
|
||||
(single-float
|
||||
(if (eql value $0f0) fp-single-zero-sc-number fp-single-immediate-sc-number))
|
||||
(if (eql value 0f0) fp-single-zero-sc-number fp-single-immediate-sc-number))
|
||||
(double-float
|
||||
(if (eql value $0d0) fp-double-zero-sc-number fp-double-immediate-sc-number))
|
||||
(if (eql value 0d0) fp-double-zero-sc-number fp-double-immediate-sc-number))
|
||||
((complex single-float)
|
||||
(if (eql value (complex $0f0 $0f0))
|
||||
(if (eql value #c(0f0 0f0))
|
||||
fp-complex-single-zero-sc-number
|
||||
fp-complex-single-immediate-sc-number))
|
||||
((complex double-float)
|
||||
(if (eql value (complex $0d0 $0d0))
|
||||
(if (eql value #c(0d0 0d0))
|
||||
fp-complex-double-zero-sc-number
|
||||
fp-complex-double-immediate-sc-number))
|
||||
;; This case has to follow the numeric cases because proxy floating-point numbers
|
||||
|
|
|
|||
|
|
@ -189,9 +189,9 @@
|
|||
((fp-constant) (single-reg double-reg #+long-float long-reg))
|
||||
(let ((value (tn-value x)))
|
||||
(with-empty-tn@fp-top(y)
|
||||
(cond ((or (eql value $0f0) (eql value $0d0) #+long-float (eql value $0l0))
|
||||
(cond ((or (eql value 0f0) (eql value 0d0) #+long-float (eql value 0l0))
|
||||
(inst fldz))
|
||||
((sb-xc:= value $1e0)
|
||||
((sb-xc:= value 1e0)
|
||||
(inst fld1))
|
||||
#+long-float
|
||||
((= value (coerce pi *read-default-float-format*))
|
||||
|
|
@ -449,10 +449,10 @@
|
|||
(:results (y :scs (descriptor-reg)))
|
||||
(:generator 2
|
||||
(ecase (sb-c::constant-value (sb-c::tn-leaf x))
|
||||
($0f0 (load-symbol-value y *fp-constant-0f0*))
|
||||
($1f0 (load-symbol-value y *fp-constant-1f0*))
|
||||
($0d0 (load-symbol-value y *fp-constant-0d0*))
|
||||
($1d0 (load-symbol-value y *fp-constant-1d0*))
|
||||
(0f0 (load-symbol-value y *fp-constant-0f0*))
|
||||
(1f0 (load-symbol-value y *fp-constant-1f0*))
|
||||
(0d0 (load-symbol-value y *fp-constant-0d0*))
|
||||
(1d0 (load-symbol-value y *fp-constant-1d0*))
|
||||
#+long-float
|
||||
(0l0 (load-symbol-value y *fp-constant-0l0*))
|
||||
#+long-float
|
||||
|
|
@ -1524,12 +1524,12 @@
|
|||
(define-vop (=0/single-float float-test)
|
||||
(:translate =)
|
||||
(:args (x :scs (single-reg)))
|
||||
(:arg-types single-float (:constant (single-float $0f0 $0f0)))
|
||||
(:arg-types single-float (:constant (single-float 0f0 0f0)))
|
||||
(:variant #x40))
|
||||
(define-vop (=0/double-float float-test)
|
||||
(:translate =)
|
||||
(:args (x :scs (double-reg)))
|
||||
(:arg-types double-float (:constant (double-float $0d0 $0d0)))
|
||||
(:arg-types double-float (:constant (double-float 0d0 0d0)))
|
||||
(:variant #x40))
|
||||
#+long-float
|
||||
(define-vop (=0/long-float float-test)
|
||||
|
|
@ -1541,12 +1541,12 @@
|
|||
(define-vop (<0/single-float float-test)
|
||||
(:translate <)
|
||||
(:args (x :scs (single-reg)))
|
||||
(:arg-types single-float (:constant (single-float $0f0 $0f0)))
|
||||
(:arg-types single-float (:constant (single-float 0f0 0f0)))
|
||||
(:variant #x01))
|
||||
(define-vop (<0/double-float float-test)
|
||||
(:translate <)
|
||||
(:args (x :scs (double-reg)))
|
||||
(:arg-types double-float (:constant (double-float $0d0 $0d0)))
|
||||
(:arg-types double-float (:constant (double-float 0d0 0d0)))
|
||||
(:variant #x01))
|
||||
#+long-float
|
||||
(define-vop (<0/long-float float-test)
|
||||
|
|
@ -1558,12 +1558,12 @@
|
|||
(define-vop (>0/single-float float-test)
|
||||
(:translate >)
|
||||
(:args (x :scs (single-reg)))
|
||||
(:arg-types single-float (:constant (single-float $0f0 $0f0)))
|
||||
(:arg-types single-float (:constant (single-float 0f0 0f0)))
|
||||
(:variant #x00))
|
||||
(define-vop (>0/double-float float-test)
|
||||
(:translate >)
|
||||
(:args (x :scs (double-reg)))
|
||||
(:arg-types double-float (:constant (double-float $0d0 $0d0)))
|
||||
(:arg-types double-float (:constant (double-float 0d0 0d0)))
|
||||
(:variant #x00))
|
||||
#+long-float
|
||||
(define-vop (>0/long-float float-test)
|
||||
|
|
|
|||
|
|
@ -347,11 +347,11 @@
|
|||
immediate-sc-number))
|
||||
(single-float
|
||||
(case value
|
||||
(($0f0 $1f0) fp-constant-sc-number)
|
||||
((0f0 1f0) fp-constant-sc-number)
|
||||
(t fp-single-immediate-sc-number)))
|
||||
(double-float
|
||||
(case value
|
||||
(($0d0 $1d0) fp-constant-sc-number)
|
||||
((0d0 1d0) fp-constant-sc-number)
|
||||
(t fp-double-immediate-sc-number)))
|
||||
#+long-float
|
||||
(long-float
|
||||
|
|
|
|||
|
|
@ -38,8 +38,8 @@
|
|||
(specifier-type '(and (satisfies foo) fixnum))))
|
||||
(assert (type= (specifier-type '(member 1 2 3))
|
||||
(specifier-type '(member 2 3 1))))
|
||||
(assert (type= (specifier-type '(and (member $1.0 2 3) single-float))
|
||||
(specifier-type '(member $1.0))))
|
||||
(assert (type= (specifier-type '(and (member 1.0 2 3) single-float))
|
||||
(specifier-type '(member 1.0))))
|
||||
|
||||
(assert (typep "hello" '(and array (not (array t)))))
|
||||
(assert (typep "hello" 'string))
|
||||
|
|
@ -266,16 +266,16 @@
|
|||
(assert (type= isect (type-intersection type2 type1 type2)))
|
||||
(assert (type= isect (type-intersection type1 type1 type2 type1)))
|
||||
(assert (type= isect (type-intersection type1 type2 type1 type2))))
|
||||
(assert (csubtypep (specifier-type '(or (single-float $-1.0 $1.0)
|
||||
(single-float $0.1)))
|
||||
(assert (csubtypep (specifier-type '(or (single-float -1.0 1.0)
|
||||
(single-float 0.1)))
|
||||
(specifier-type '(or (real -1 7)
|
||||
(single-float $0.1)
|
||||
(single-float $-1.0 $1.0)))))
|
||||
(single-float 0.1)
|
||||
(single-float -1.0 1.0)))))
|
||||
(assert (not (csubtypep (specifier-type '(or (real -1 7)
|
||||
(single-float $0.1)
|
||||
(single-float $-1.0 $1.0)))
|
||||
(specifier-type '(or (single-float $-1.0 $1.0)
|
||||
(single-float $0.1))))))
|
||||
(single-float 0.1)
|
||||
(single-float -1.0 1.0)))
|
||||
(specifier-type '(or (single-float -1.0 1.0)
|
||||
(single-float 0.1))))))
|
||||
|
||||
(assert (typep #\, 'character))
|
||||
(assert (typep #\@ 'character))
|
||||
|
|
@ -425,9 +425,9 @@
|
|||
|
||||
#+x86-64
|
||||
(progn
|
||||
(assert (= (sb-vm::immediate-constant-sc (complex $0.0f0 $0.0f0))
|
||||
(assert (= (sb-vm::immediate-constant-sc #c(0.0f0 0.0f0))
|
||||
sb-vm::fp-complex-single-zero-sc-number))
|
||||
(assert (= (sb-vm::immediate-constant-sc (complex $0.0d0 $0.0d0))
|
||||
(assert (= (sb-vm::immediate-constant-sc #c(0.0d0 0.0d0))
|
||||
sb-vm::fp-complex-double-zero-sc-number)))
|
||||
|
||||
;;; Unparse a union of (up to) 3 things depending on :sb-unicode as 2 things.
|
||||
|
|
@ -512,7 +512,7 @@
|
|||
(assert (not (sb-int:list-elts-eq '(foo bar) '(foo))))
|
||||
|
||||
(assert (sb-int:list-elements-eql '(a b 1) '(a b 1)))
|
||||
(assert (sb-int:list-elements-eql '($1.0d0 x y) '($1.0d0 x y)))
|
||||
(assert (sb-int:list-elements-eql '(1.0d0 x y) '(1.0d0 x y)))
|
||||
(assert (not (sb-int:list-elements-eql '(foo) '(foo bar))))
|
||||
(assert (not (sb-int:list-elements-eql '(foo bar) '(foo))))
|
||||
|
||||
|
|
@ -524,4 +524,4 @@
|
|||
(assert (sb-kernel::type-enumerable
|
||||
(sb-kernel:specifier-type '(and integer (integer 1 5)))))
|
||||
(assert (sb-kernel::type-enumerable
|
||||
(sb-kernel:specifier-type '(single-float $1.0 $1.0))))
|
||||
(sb-kernel:specifier-type '(single-float 1.0 1.0))))
|
||||
|
|
|
|||
Loading…
Reference in a new issue