common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Change all #!+long-float to #+long-float

Browse source 
For a feature that has not worked since forever ago, this was probably
the biggest offender in terms of lines needing conditionalization.
This commit is contained in:
Douglas Katzman 2019-01-28 16:43:40 -05:00
parent 54265c81a1
commit c270f65ca9
47 changed files with 307 additions and 307 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
src/code/array.lisp
View file

@ -218,7 +218,7 @@
(%integer-vector-widetag-and-n-bits-shift
nil (integer-length (1- (cadr type))))
(ill-type)))
#!+long-float
#+long-float
(long-float
(with-parameters (long-float :intervals t) (low high)
(if (and (not (eq low '*))
@ -257,7 +257,7 @@
((csubtypep ctype (specifier-type '(complex single-float)))
(result
simple-array-complex-single-float-widetag))
#!+long-float
#+long-float
((csubtypep ctype (specifier-type '(complex long-float)))
(result
simple-array-complex-long-float-widetag))
@ -271,7 +271,7 @@
(single-float
(result
simple-array-complex-single-float-widetag))
#!+long-float
#+long-float
(long-float
(result
simple-array-complex-long-float-widetag))
@ -309,7 +309,7 @@
(result simple-array-double-float-widetag))
((csubtypep ctype (specifier-type 'single-float))
(result simple-array-single-float-widetag))
#!+long-float
#+long-float
((csubtypep ctype (specifier-type 'long-float))
(result simple-array-long-float-widetag))
((csubtypep ctype (specifier-type 'complex-double-float))

2
src/code/bignum.lisp
View file

@ -1234,7 +1234,7 @@
(check-exponent len sb-vm:double-float-bias
sb-vm:double-float-normal-exponent-max)
plusp))
#!+long-float
#+long-float
(long-float
(long-float-from-bits
bits

4
src/code/class.lisp
View file

@ -928,7 +928,7 @@ between the ~A definition and the ~A definition"
:inherits (complex number)
:codes (,sb-vm:complex-double-float-widetag)
:prototype-form (complex 42d0 42d0))
#!+long-float
#+long-float
(complex-long-float
:translation (complex long-float)
:inherits (complex number)
@ -961,7 +961,7 @@ between the ~A definition and the ~A definition"
:inherits (float real number)
:codes (,sb-vm:double-float-widetag)
:prototype-form 42d0)
#!+long-float
#+long-float
(long-float
:translation long-float
:inherits (float real number)

4
src/code/coerce.lisp
View file

@ -145,7 +145,7 @@
(unless (typep res output-type-spec)
(coerce-error))
res))
#!+long-float
#+long-float
((csubtypep type (specifier-type 'long-float))
(let ((res (%long-float object)))
(unless (typep res output-type-spec)
@ -165,7 +165,7 @@
((csubtypep type (specifier-type '(complex double-float)))
(complex (%double-float (realpart object))
(%double-float (imagpart object))))
#!+long-float
#+long-float
((csubtypep type (specifier-type '(complex long-float)))
(complex (%long-float (realpart object))
(%long-float (imagpart object))))

16
src/code/debug-int.lisp
View file

@ -2386,14 +2386,14 @@ register."
(escaped-float-value single-float))
(#.sb-vm:double-reg-sc-number
(escaped-float-value double-float))
#!+long-float
#+long-float
(#.sb-vm:long-reg-sc-number
(escaped-float-value long-float))
(#.sb-vm:complex-single-reg-sc-number
(escaped-float-value complex-single-float))
(#.sb-vm:complex-double-reg-sc-number
(escaped-float-value complex-double-float))
#!+long-float
#+long-float
(#.sb-vm:complex-long-reg-sc-number
(escaped-float-value sb-kernel::complex-long-float))
(#.sb-vm:single-stack-sc-number
@ -2402,7 +2402,7 @@ register."
(#.sb-vm:double-stack-sc-number
(with-nfp (nfp)
(sap-ref-double nfp (number-stack-offset))))
#!+long-float
#+long-float
(#.sb-vm:long-stack-sc-number
(with-nfp (nfp)
(sap-ref-long nfp (number-stack-offset))))
@ -2416,7 +2416,7 @@ register."
(complex
(sap-ref-double nfp (number-stack-offset))
(sap-ref-double nfp (number-stack-offset 8)))))
#!+long-float
#+long-float
(#.sb-vm:complex-long-stack-sc-number
(with-nfp (nfp)
(complex
@ -2564,14 +2564,14 @@ register."
(set-escaped-float-value single-float value))
(#.sb-vm:double-reg-sc-number
(set-escaped-float-value double-float value))
#!+long-float
#+long-float
(#.sb-vm:long-reg-sc-number
(set-escaped-float-value long-float value))
(#.sb-vm:complex-single-reg-sc-number
(set-escaped-float-value complex-single-float value))
(#.sb-vm:complex-double-reg-sc-number
(set-escaped-float-value complex-double-float value))
#!+long-float
#+long-float
(#.sb-vm:complex-long-reg-sc-number
(set-escaped-float-value complex-long-float))
(#.sb-vm:single-stack-sc-number
@ -2582,7 +2582,7 @@ register."
(with-nfp (nfp)
(setf (sap-ref-double nfp (number-stack-offset))
(the double-float value))))
#!+long-float
#+long-float
(#.sb-vm:long-stack-sc-number
(with-nfp (nfp)
(setf (sap-ref-long nfp (number-stack-offset))
@ -2611,7 +2611,7 @@ register."
(imagpart (the (complex double-float) value))
#!-(or x86 x86-64)
(the double-float (realpart value)))))
#!+long-float
#+long-float
(#.sb-vm:complex-long-stack-sc-number
(with-nfp (nfp)
(setf (sap-ref-long

2
src/code/defsetfs.lisp
View file

@ -179,7 +179,7 @@
(defsetf sap-ref-lispobj %set-sap-ref-lispobj)
(defsetf sap-ref-single %set-sap-ref-single)
(defsetf sap-ref-double %set-sap-ref-double)
#!+long-float (defsetf sap-ref-long %set-sap-ref-long)
#+long-float (defsetf sap-ref-long %set-sap-ref-long)
(defsetf subseq (sequence start &optional end) (v)
`(progn (replace ,sequence ,v :start1 ,start :end1 ,end) ,v))

4
src/code/early-extensions.lisp
View file

@ -1564,7 +1564,7 @@ to :INTERPRET, an interpreter will be used.")
(typecase x
(single-float (zerop x))
(double-float (zerop x))
#!+long-float
#+long-float
(long-float (zerop x))
(t nil)))
@ -1578,7 +1578,7 @@ to :INTERPRET, an interpreter will be used.")
(if (eql x 0.0d0)
(make-unportable-float :double-float-negative-zero)
0.0d0))
#!+long-float
#+long-float
(long-float
(if (eql x 0.0l0)
(make-unportable-float :long-float-negative-zero)

12
src/code/early-float.lisp
View file

@ -55,12 +55,12 @@
(defconstant least-negative-single-float (single-from-bits 1 0 1))
(defconstant least-negative-short-float (single-from-bits 1 0 1))
(defconstant least-positive-double-float (double-from-bits 0 0 1))
#!-long-float
#-long-float
(defconstant least-positive-long-float (double-from-bits 0 0 1))
#!+(and long-float x86)
(defconstant least-positive-long-float (long-from-bits 0 0 1))
(defconstant least-negative-double-float (double-from-bits 1 0 1))
#!-long-float
#-long-float
(defconstant least-negative-long-float (double-from-bits 1 0 1))
#!+(and long-float x86)
(defconstant least-negative-long-float (long-from-bits 1 0 1))
@ -75,7 +75,7 @@
least-negative-normalized-single-float)
(defconstant least-positive-normalized-double-float
(double-from-bits 0 sb-vm:double-float-normal-exponent-min 0))
#!-long-float
#-long-float
(defconstant least-positive-normalized-long-float
least-positive-normalized-double-float)
#!+(and long-float x86)
@ -84,7 +84,7 @@
(ash sb-vm:long-float-hidden-bit 32)))
(defconstant least-negative-normalized-double-float
(double-from-bits 1 sb-vm:double-float-normal-exponent-min 0))
#!-long-float
#-long-float
(defconstant least-negative-normalized-long-float
least-negative-normalized-double-float)
#!+(and long-float x86)
@ -159,7 +159,7 @@
(defconstant double-float-epsilon
(double-from-bits 0 (- sb-vm:double-float-bias
(1- sb-vm:double-float-digits)) 1))
#!-long-float
#-long-float
(defconstant long-float-epsilon double-float-epsilon)
#!+(and long-float x86)
(defconstant long-float-epsilon
@ -167,7 +167,7 @@
(+ 1 (ash sb-vm:long-float-hidden-bit 32))))
(defconstant double-float-negative-epsilon
(double-from-bits 0 (- sb-vm:double-float-bias sb-vm:double-float-digits) 1))
#!-long-float
#-long-float
(defconstant long-float-negative-epsilon double-float-negative-epsilon)
#!+(and long-float x86)
(defconstant long-float-negative-epsilon

4
src/code/early-raw-slots.lisp
View file

@ -144,12 +144,12 @@
:init-vop 'sb-vm::raw-instance-init/complex-double
:alignment double-float-alignment
:n-words (/ 16 sb-vm:n-word-bytes))
#!+long-float
#+long-float
(make-raw-slot-data :raw-type long-float
:accessor-name '%raw-instance-ref/long
:init-vop 'sb-vm::raw-instance-init/long
:n-words #!+x86 3 #!+sparc 4)
#!+long-float
#+long-float
(make-raw-slot-data :raw-type complex-long-float
:accessor-name '%raw-instance-ref/complex-long
:init-vop 'sb-vm::raw-instance-init/complex-long

4
src/code/early-type.lisp
View file

@ -356,7 +356,7 @@
(return-from make-numeric-type
(if (bounds-unbounded-p low high)
(specifier-type 'float)
(unionize (single-float double-float #!+long-float (error "long-float"))
(unionize (single-float double-float #+long-float (error "long-float"))
(:class 'float :format thing))))))
(multiple-value-bind (low high)
(case class
@ -624,7 +624,7 @@
(etypecase z
(single-float 0)
(double-float 2
#!+long-float (long-float 4)))))
#+long-float (long-float 4)))))
(if (= pass 0)
(setf (ldb (byte 1 (+ pair-idx sign)) presence) 1)
(if (= (ldb (byte 2 pair-idx) presence) #b11)

38
src/code/float.lisp
View file

@ -129,7 +129,7 @@
((double-float)
(frob sb-vm:double-float-digits sb-vm:double-float-bias
integer-decode-double-denorm))
#!+long-float
#+long-float
((long-float)
(frob sb-vm:long-float-digits sb-vm:long-float-bias
integer-decode-long-denorm)))))
@ -142,7 +142,7 @@
(* (if (etypecase float1
(single-float (minusp (single-float-bits float1)))
(double-float (minusp (double-float-high-bits float1)))
#!+long-float
#+long-float
(long-float (minusp (long-float-exp-bits float1))))
(float -1 float1)
(float 1 float1))
@ -151,8 +151,8 @@
(defun float-format-digits (format)
(ecase format
((short-float single-float) sb-vm:single-float-digits)
((double-float #!-long-float long-float) sb-vm:double-float-digits)
#!+long-float
((double-float #-long-float long-float) sb-vm:double-float-digits)
#+long-float
(long-float sb-vm:long-float-digits)))
#!-sb-fluid (declaim (inline float-digits float-radix))
@ -162,7 +162,7 @@
(number-dispatch ((f float))
((single-float) sb-vm:single-float-digits)
((double-float) sb-vm:double-float-digits)
#!+long-float
#+long-float
((long-float) sb-vm:long-float-digits)))
(defun float-radix (x)
@ -357,7 +357,7 @@
(integer-decode-single-float x))
((double-float)
(integer-decode-double-float x))
#!+long-float
#+long-float
((long-float)
(integer-decode-long-float x))))
@ -477,7 +477,7 @@
(decode-single-float f))
((double-float)
(decode-double-float f))
#!+long-float
#+long-float
((long-float)
(decode-long-float f))))
@ -609,7 +609,7 @@
(scale-single-float f ex))
((double-float)
(scale-double-float f ex))
#!+long-float
#+long-float
((long-float)
(scale-long-float f ex))))
@ -622,8 +622,8 @@
(declare (explicit-check))
(if otherp
(number-dispatch ((number real) (other float))
(((foreach rational single-float double-float #!+long-float long-float)
(foreach single-float double-float #!+long-float long-float))
(((foreach rational single-float double-float #+long-float long-float)
(foreach single-float double-float #+long-float long-float))
(coerce number '(dispatch-type other))))
(if (floatp number)
number
@ -632,7 +632,7 @@
(macrolet ((frob (name type)
`(defun ,name (x)
(number-dispatch ((x real))
(((foreach single-float double-float #!+long-float long-float
(((foreach single-float double-float #+long-float long-float
sb-vm:signed-word
,@(and (sb-c::template-translates-arg-p '%double-float 0 'word)
'(word))))
@ -643,7 +643,7 @@
(bignum-to-float x ',type))))))
(frob %single-float single-float)
(frob %double-float double-float)
#!+long-float
#+long-float
(frob %long-float long-float))
;;; Convert a ratio to a float. We avoid any rounding error by doing an
@ -689,7 +689,7 @@
(single-from-bits sign sb-vm:single-float-bias bits))
(double-float
(double-from-bits sign sb-vm:double-float-bias bits))
#!+long-float
#+long-float
(long-float
(long-from-bits sign sb-vm:long-float-bias bits))))))
(loop
@ -781,7 +781,7 @@
(number-dispatch ((number real))
((integer) number)
((ratio) (values (truncate (numerator number) (denominator number))))
(((foreach single-float double-float #!+long-float long-float))
(((foreach single-float double-float #+long-float long-float))
(if (and (<= (float most-negative-fixnum number) number)
(< number (float most-positive-fixnum number)))
(truly-the fixnum (%unary-truncate number))
@ -805,7 +805,7 @@
res)))))))
(def single-float %unary-truncate/single-float)
(def double-float %unary-truncate/double-float)
#!+long-float
#+long-float
(def double-float %unary-truncate/long-float))
;;; Similar to %UNARY-TRUNCATE, but rounds to the nearest integer. If we
@ -818,7 +818,7 @@
(number-dispatch ((number real))
((integer) number)
((ratio) (values (round (numerator number) (denominator number))))
(((foreach single-float double-float #!+long-float long-float))
(((foreach single-float double-float #+long-float long-float))
(if (< (float most-negative-fixnum number)
number
(float most-positive-fixnum number))
@ -841,7 +841,7 @@
(number-dispatch ((number real))
((integer) (float number))
((ratio) (float (truncate (numerator number) (denominator number))))
(((foreach single-float double-float #!+long-float long-float))
(((foreach single-float double-float #+long-float long-float))
(%unary-ftruncate number))))
(defun rational (x)
@ -850,7 +850,7 @@
completely accurate, giving a result that isn't as pretty."
(declare (explicit-check))
(number-dispatch ((x real))
(((foreach single-float double-float #!+long-float long-float))
(((foreach single-float double-float #+long-float long-float))
(multiple-value-bind (bits exp) (integer-decode-float x)
(if (eql bits 0)
0
@ -929,7 +929,7 @@
(= x (float (rationalize x) x))"
(declare (explicit-check))
(number-dispatch ((x real))
(((foreach single-float double-float #!+long-float long-float))
(((foreach single-float double-float #+long-float long-float))
;; This is a fairly straigtforward implementation of the
;; iterative algorithm above.
(multiple-value-bind (frac expo sign)

4
src/code/fop.lisp
View file

@ -347,11 +347,11 @@
(,reader))))))
(define-complex-fop 72 fop-complex-single-float single-float)
(define-complex-fop 73 fop-complex-double-float double-float)
#!+long-float
#+long-float
(define-complex-fop 67 fop-complex-long-float long-float)
(define-float-fop 46 fop-single-float single-float)
(define-float-fop 47 fop-double-float double-float)
#!+long-float
#+long-float
(define-float-fop 52 fop-long-float long-float)))
#!+sb-simd-pack

24
src/code/irrat.lisp
View file

@ -15,8 +15,8 @@
;;;; miscellaneous constants, utility functions, and macros
(defconstant pi
#!+long-float 3.14159265358979323846264338327950288419716939937511l0
#!-long-float 3.14159265358979323846264338327950288419716939937511d0)
#+long-float 3.14159265358979323846264338327950288419716939937511l0
#-long-float 3.14159265358979323846264338327950288419716939937511d0)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun handle-reals (function var)
@ -778,7 +778,7 @@
;;; Create complex number with real part X and imaginary part Y
;;; such that has the same type as Z. If Z has type (complex
;;; rational), the X and Y are coerced to single-float.
#!+long-float (eval-when (:compile-toplevel :load-toplevel :execute)
#+long-float (eval-when (:compile-toplevel :load-toplevel :execute)
(error "needs work for long float support"))
(declaim (inline coerce-to-complex-type))
(defun coerce-to-complex-type (x y z)
@ -794,7 +794,7 @@
;;; Compute |(x+i*y)/2^k|^2 scaled to avoid over/underflow. The
;;; result is r + i*k, where k is an integer.
#!+long-float (eval-when (:compile-toplevel :load-toplevel :execute)
#+long-float (eval-when (:compile-toplevel :load-toplevel :execute)
(error "needs work for long float support"))
(defun cssqs (z)
(declare (muffle-conditions compiler-note))
@ -818,9 +818,9 @@
((let ((threshold
;; (/ least-positive-double-float double-float-epsilon)
(load-time-value
#!-long-float
#-long-float
(make-double-float #x1fffff #xfffffffe)
#!+long-float
#+long-float
(error "(/ least-positive-long-float long-float-epsilon)")))
(traps (ldb sb-vm:float-sticky-bits
(sb-vm:floating-point-modes))))
@ -896,9 +896,9 @@
;; choose them. We'll just assume his choices matches our
;; implementation of log1p.
(let ((t0 (load-time-value
#!-long-float
#-long-float
(make-double-float #x3fe6a09e #x667f3bcd)
#!+long-float
#+long-float
(error "(/ (sqrt 2l0))")))
;; KLUDGE: if repeatable fasls start failing under some weird
;; xc host, this 1.2d0 might be a good place to examine: while
@ -907,9 +907,9 @@
(t1 1.2d0)
(t2 3d0)
(ln2 (load-time-value
#!-long-float
#-long-float
(make-double-float #x3fe62e42 #xfefa39ef)
#!+long-float
#+long-float
(error "(log 2l0)")))
(x (float (realpart z) 1.0d0))
(y (float (imagpart z) 1.0d0)))
@ -1004,9 +1004,9 @@
(declare (optimize (speed 3) (space 0)))
(cond ((> (abs x)
(load-time-value
#!-long-float
#-long-float
(make-double-float #x406633ce #x8fb9f87e)
#!+long-float
#+long-float
(error "(/ (+ (log 2l0) (log most-positive-long-float)) 4l0)")))
(coerce-to-complex-type (float-sign x)
(float-sign y) z))

6
src/code/late-type.lisp
View file

@ -2324,7 +2324,7 @@ used for a COMPLEX component.~:@>"
,(coerced-float-bound high 'single-float t))
(double-float ,(coerced-float-bound low 'double-float nil)
,(coerced-float-bound high 'double-float t))
#!+long-float ,(error "stub: no long float support yet"))))
#+long-float ,(error "stub: no long float support yet"))))
(macrolet ((define-float-format (f) `(!def-bounded-type ,f float ,f)))
(define-float-format single-float)
@ -2503,13 +2503,13 @@ used for a COMPLEX component.~:@>"
((nil)
;; A double-float with any real number is a
;; double-float.
#!-long-float
#-long-float
(if (eq format1 'double-float)
'double-float
nil)
;; A long-float with any real number is a
;; long-float.
#!+long-float
#+long-float
(if (eq format1 'long-float)
'long-float
nil)))

48
src/code/numbers.lisp
View file

@ -48,7 +48,7 @@
;;; our guess for the preferred order in which to do type tests
;;; (cheaper and/or more probable first.)
(defconstant-eqx +type-test-ordering+
'(fixnum single-float double-float integer #!+long-float long-float
'(fixnum single-float double-float integer #+long-float long-float
sb-vm:signed-word word bignum
complex ratio)
#'equal)
@ -179,15 +179,15 @@
(defun float-contagion (op x y &optional (rat-types '(fixnum bignum ratio)))
`(((single-float single-float) (,op ,x ,y))
(((foreach ,@rat-types)
(foreach single-float double-float #!+long-float long-float))
(foreach single-float double-float #+long-float long-float))
(,op (coerce ,x '(dispatch-type ,y)) ,y))
(((foreach single-float double-float #!+long-float long-float)
(((foreach single-float double-float #+long-float long-float)
(foreach ,@rat-types))
(,op ,x (coerce ,y '(dispatch-type ,x))))
#!+long-float
#+long-float
(((foreach single-float double-float long-float) long-float)
(,op (coerce ,x 'long-float) ,y))
#!+long-float
#+long-float
((long-float (foreach single-float double-float))
(,op ,x (coerce ,y 'long-float)))
(((foreach single-float double-float) double-float)
@ -216,7 +216,7 @@
(defun canonical-complex (realpart imagpart)
(if (eql imagpart 0)
realpart
(cond #!+long-float
(cond #+long-float
((and (typep realpart 'long-float)
(typep imagpart 'long-float))
(truly-the (complex long-float) (complex realpart imagpart)))
@ -259,7 +259,7 @@
"Return a complex number with the specified real and imaginary components."
(declare (explicit-check))
(flet ((%%make-complex (realpart imagpart)
(cond #!+long-float
(cond #+long-float
((and (typep realpart 'long-float)
(typep imagpart 'long-float))
(truly-the (complex long-float)
@ -282,7 +282,7 @@
(defun realpart (number)
"Extract the real part of a number."
(etypecase number
#!+long-float
#+long-float
((complex long-float)
(truly-the long-float (realpart number)))
((complex double-float)
@ -297,7 +297,7 @@
(defun imagpart (number)
"Extract the imaginary part of a number."
(etypecase number
#!+long-float
#+long-float
((complex long-float)
(truly-the long-float (imagpart number)))
((complex double-float)
@ -406,7 +406,7 @@
(canonical-complex (,op (realpart x) (realpart y))
(,op (imagpart x) (imagpart y))))
(((foreach bignum fixnum ratio single-float double-float
#!+long-float long-float) complex)
#+long-float long-float) complex)
(complex (,op x (realpart y)) (,op 0 (imagpart y))))
((complex (or rational float))
(complex (,op (realpart x) y) (,op (imagpart x) 0)))
@ -471,7 +471,7 @@
(iy (imagpart y)))
(canonical-complex (- (* rx ry) (* ix iy)) (+ (* rx iy) (* ix ry)))))
(((foreach bignum fixnum ratio single-float double-float
#!+long-float long-float)
#+long-float long-float)
complex)
(complex*real y x))
((complex (or rational float))
@ -575,7 +575,7 @@
(defun %negate (n)
(declare (explicit-check))
(number-dispatch ((n number))
(((foreach fixnum single-float double-float #!+long-float long-float))
(((foreach fixnum single-float double-float #+long-float long-float))
(%negate n))
((bignum)
(negate-bignum n))
@ -616,16 +616,16 @@
((bignum bignum)
(bignum-truncate number divisor))
(((foreach single-float double-float #!+long-float long-float)
(((foreach single-float double-float #+long-float long-float)
(or rational single-float))
(if (eql divisor 1)
(let ((res (%unary-truncate number)))
(values res (- number (coerce res '(dispatch-type number)))))
(truncate-float (dispatch-type number))))
#!+long-float
#+long-float
((long-float (or single-float double-float long-float))
(truncate-float long-float))
#!+long-float
#+long-float
(((foreach double-float single-float) long-float)
(truncate-float long-float))
((double-float (or single-float double-float))
@ -633,7 +633,7 @@
((single-float double-float)
(truncate-float double-float))
(((foreach fixnum bignum ratio)
(foreach single-float double-float #!+long-float long-float))
(foreach single-float double-float #+long-float long-float))
(truncate-float (dispatch-type divisor))))))
(defun %multiply-high (x y)
@ -710,16 +710,16 @@
(multiple-value-bind (q r)
(truncate number divisor)
(values (float q) r)))
(((foreach single-float double-float #!+long-float long-float)
(((foreach single-float double-float #+long-float long-float)
(or rational single-float))
(if (eql divisor 1)
(let ((res (%unary-ftruncate number)))
(values res (- number (coerce res '(dispatch-type number)))))
(ftruncate-float (dispatch-type number))))
#!+long-float
#+long-float
((long-float (or single-float double-float long-float))
(ftruncate-float long-float))
#!+long-float
#+long-float
(((foreach double-float single-float) long-float)
(ftruncate-float long-float))
((double-float (or single-float double-float))
@ -727,7 +727,7 @@
((single-float double-float)
(ftruncate-float double-float))
(((foreach fixnum bignum ratio)
(foreach single-float double-float #!+long-float long-float))
(foreach single-float double-float #+long-float long-float))
(ftruncate-float (dispatch-type divisor))))))
(defun ffloor (number &optional (divisor 1))
@ -865,10 +865,10 @@ the first."
(defun basic-compare (op &key infinite-x-finite-y infinite-y-finite-x)
`(((fixnum fixnum) (,op x y))
((single-float single-float) (,op x y))
#!+long-float
#+long-float
(((foreach single-float double-float long-float) long-float)
(,op (coerce x 'long-float) y))
#!+long-float
#+long-float
((long-float (foreach single-float double-float))
(,op x (coerce y 'long-float)))
((fixnum (foreach single-float double-float))
@ -890,7 +890,7 @@ the first."
(,op (coerce x 'double-float) y))
((double-float single-float)
(,op x (coerce y 'double-float)))
(((foreach single-float double-float #!+long-float long-float) rational)
(((foreach single-float double-float #+long-float long-float) rational)
(if (eql y 0)
(,op x (coerce 0 '(dispatch-type x)))
(if (float-infinity-p x)
@ -961,7 +961,7 @@ the first."
(and (= (realpart x) (realpart y))
(= (imagpart x) (imagpart y))))
(((foreach fixnum bignum ratio single-float double-float
#!+long-float long-float) complex)
#+long-float long-float) complex)
(and (= x (realpart y))
(zerop (imagpart y))))
((complex (or float rational))

4
src/code/pred.lisp
View file

@ -117,7 +117,7 @@
(def-type-predicate-wrapper complexp)
(def-type-predicate-wrapper complex-double-float-p)
(def-type-predicate-wrapper complex-float-p)
#!+long-float (def-type-predicate-wrapper complex-long-float-p)
#+long-float (def-type-predicate-wrapper complex-long-float-p)
(def-type-predicate-wrapper complex-rational-p)
(def-type-predicate-wrapper complex-single-float-p)
;; (COMPLEX-VECTOR-P is not included here since it's awkward to express
@ -304,7 +304,7 @@
(foo
(single-float eql)
(double-float eql)
#!+long-float
#+long-float
(long-float eql)
(bignum
#!-integer-eql-vop (lambda (x y) (zerop (bignum-compare x y)))

18
src/code/print.lisp
View file

@ -1264,7 +1264,7 @@ variable: an unreadable object representing the error is printed instead.")
(- 2 sb-vm:single-float-bias sb-vm:single-float-digits))
(defconstant double-float-min-e
(- 2 sb-vm:double-float-bias sb-vm:double-float-digits))
#!+long-float
#+long-float
(defconstant long-float-min-e
(nth-value 1 (decode-float least-positive-long-float)))
@ -1283,7 +1283,7 @@ variable: an unreadable object representing the error is printed instead.")
(etypecase float
(single-float single-float-min-e)
(double-float double-float-min-e)
#!+long-float
#+long-float
(long-float long-float-min-e))))
(multiple-value-bind (f e)
(integer-decode-float float)
@ -1442,7 +1442,7 @@ variable: an unreadable object representing the error is printed instead.")
(eval-when (:compile-toplevel :execute)
(setf *read-default-float-format*
#!+long-float 'long-float #!-long-float 'double-float))
#+long-float 'long-float #-long-float 'double-float))
(defun scale-exponent (original-x)
(let* ((x (coerce original-x 'long-float)))
(multiple-value-bind (sig exponent) (decode-float x)
@ -1461,15 +1461,15 @@ variable: an unreadable object representing the error is printed instead.")
;; ulp in this value, which is a
;; little unfortunate.)
(load-time-value
#!-long-float
#-long-float
(make-double-float 1070810131 1352628735)
#!+long-float
#+long-float
(error "(log 2 10) not computed")))))))
(x (if (minusp ex)
(if (float-denormalized-p x)
#!-long-float
#-long-float
(* x 1.0e16 (expt 10.0e0 (- (- ex) 16)))
#!+long-float
#+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))))))
@ -1517,9 +1517,9 @@ variable: an unreadable object representing the error is printed instead.")
(cond ((case *read-default-float-format*
((short-float single-float)
(typep x 'single-float))
((double-float #!-long-float long-float)
((double-float #-long-float long-float)
(typep x 'double-float))
#!+long-float
#+long-float
(long-float
(typep x 'long-float)))
(unless (eql exp 0)

2
src/code/reader.lisp
View file

@ -1672,7 +1672,7 @@ extended <package-name>::<form-in-package> syntax."
;; Use the least positive float, because denormalized exponent
;; can be larger than normalized.
(let* ((max-exponent
#!-long-float
#-long-float
(+ sb-vm:double-float-digits sb-vm:double-float-bias))
(number-magnitude (integer-length number))
(divisor-magnitude (1- (integer-length divisor)))

4
src/code/target-format.lisp
View file

@ -642,9 +642,9 @@
(if (case *read-default-float-format*
((short-float single-float)
(typep number 'single-float))
((double-float #!-long-float long-float)
((double-float #-long-float long-float)
(typep number 'double-float))
#!+long-float
#+long-float
(long-float
(typep number 'long-float)))
#\e

4
src/code/target-random.lisp
View file

@ -405,7 +405,7 @@ http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/emt.html
(defun random (arg &optional (state *random-state*))
#!-sb-fluid (declare (inline %random-fixnum
%random-single-float %random-double-float
#!+long-float %random-long-float))
#+long-float %random-long-float))
(declare (explicit-check))
(cond
((and (fixnump arg) (> arg 0))
@ -414,7 +414,7 @@ http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/emt.html
(%random-single-float arg state))
((and (typep arg 'double-float) (> arg 0.0d0))
(%random-double-float arg state))
#!+long-float
#+long-float
((and (typep arg 'long-float) (> arg 0.0l0))
(%random-long-float arg state))
((and (bignump arg) (> arg 0))

6
src/code/target-sxhash.lisp
View file

@ -295,13 +295,13 @@
(integer (sb-bignum:sxhash-bignum x))
(single-float (sxhash x)) ; through DEFTRANSFORM
(double-float (sxhash x)) ; through DEFTRANSFORM
#!+long-float (long-float (error "stub: no LONG-FLOAT"))
#+long-float (long-float (error "stub: no LONG-FLOAT"))
(ratio (let ((result 127810327))
(declare (type fixnum result))
(mixf result (sxhash-number (numerator x)))
(mixf result (sxhash-number (denominator x)))
result))
#!+long-float
#+long-float
((complex long-float)
(hash-complex-float))
((complex double-float)
@ -582,7 +582,7 @@
(etypecase key
(single-float (hash-float single-float key))
(double-float (hash-float double-float key))
#!+long-float
#+long-float
(long-float (error "LONG-FLOAT not currently supported")))))
(rational (if (and (<= most-negative-double-float
key

2
src/code/unportable-float.lisp
View file

@ -32,5 +32,5 @@
(:double-float-negative-zero (make-double-float
(opaque-identity #x-80000000)
(opaque-identity #x00000000)))
#!+long-float
#+long-float
(:long-float-negative-zero (error "write LONG-FLOAT creation form")))))

4
src/compiler/dump.lisp
View file

@ -533,7 +533,7 @@
(declare (double-float x))
(dump-integer-as-n-bytes (double-float-low-bits x) 4 file)
(dump-integer-as-n-bytes (double-float-high-bits x) 4 file)))
#!+long-float
#+long-float
(long-float
(dump-fop 'fop-long-float file)
(dump-long-float x file))))
@ -580,7 +580,7 @@
(dump-complex-single-float (realpart x) (imagpart x) file))
((complex double-float)
(dump-complex-double-float (realpart x) (imagpart x) file))
#!+long-float
#+long-float
((complex long-float)
(dump-fop 'fop-complex-long-float file)
(dump-long-float (realpart x) file)

6
src/compiler/float-tran.lisp
View file

@ -662,7 +662,7 @@
;; the host does not have long floats, then setting *R-D-F-F* to
;; LONG-FLOAT doesn't actually buy us anything. FIXME.
(setf *read-default-float-format*
#!+long-float 'long-float #!-long-float 'double-float))
#+long-float 'long-float #-long-float 'double-float))
;;; Test whether the numeric-type ARG is within the domain specified by
;;; DOMAIN-LOW and DOMAIN-HIGH, consider negative and positive zero to
;;; be distinct.
@ -681,7 +681,7 @@
(typecase arg-lo-val
(single-float 0f0)
(double-float 0d0)
#!+long-float
#+long-float
(long-float 0l0))
arg-lo-val arg-lo))
(when (and arg-hi (zerop arg-hi-val) (floatp arg-hi-val) (consp arg-hi)
@ -690,7 +690,7 @@
(typecase arg-lo-val
(single-float (load-time-value (make-unportable-float :single-float-negative-zero)))
(double-float (load-time-value (make-unportable-float :double-float-negative-zero)))
#!+long-float
#+long-float
(long-float (load-time-value (make-unportable-float :long-float-negative-zero))))
arg-hi-val arg-hi))
(flet ((fp-neg-zero-p (f) ; Is F -0.0?

2
src/compiler/generic/early-objdef.lisp
View file

@ -117,7 +117,7 @@
;;; * BIGNUM + RATIO (+ FIXNUM) = RATIONAL
;;;
;;; * SINGLE-FLOAT + DOUBLE-FLOAT + LONG-FLOAT = FLOAT
;;; But: There's not a snowball's chance that #!+long-float works.
;;; But: There's not a snowball's chance that #+long-float works.
;;; changeset 7646ae obliterated LONG-FLOAT-WIDETAG.
;;;
;;; * RATIONAL + FLOAT = REAL

2
src/compiler/generic/genesis.lisp
View file

@ -848,7 +848,7 @@ core and return a descriptor to it."
sb-vm:ratio-widetag))
((complex single-float) (complex-single-float-to-core number))
((complex double-float) (complex-double-float-to-core number))
#!+long-float
#+long-float
((complex long-float)
(error "~S isn't a cold-loadable number at all!" number))
(complex (number-pair-to-core (number-to-core (realpart number))

4
src/compiler/generic/interr.lisp
View file

@ -118,7 +118,7 @@
ratio
single-float
double-float
#!+long-float long-float
#+long-float long-float
simple-string
fixnum
vector
@ -150,7 +150,7 @@
((complex float) object-not-complex-float)
((complex single-float) object-not-complex-single-float)
((complex double-float) object-not-complex-double-float)
#!+long-float ((complex long-float) object-not-complex-long-float)
#+long-float ((complex long-float) object-not-complex-long-float)
#!+sb-simd-pack simd-pack
#!+sb-simd-pack-256 simd-pack-256
weak-pointer

12
src/compiler/generic/late-type-vops.lisp
View file

@ -94,13 +94,13 @@
(!define-type-vop complexp
(complex-widetag complex-single-float-widetag complex-double-float-widetag
#!+long-float complex-long-float-widetag))
#+long-float complex-long-float-widetag))
(!define-type-vop complex-rational-p (complex-widetag))
(!define-type-vop complex-float-p
(complex-single-float-widetag complex-double-float-widetag
#!+long-float complex-long-float-widetag))
#+long-float complex-long-float-widetag))
(!define-type-vop complex-single-float-p (complex-single-float-widetag))
@ -226,11 +226,11 @@
ratio-widetag
single-float-widetag
double-float-widetag
#!+long-float long-float-widetag
#+long-float long-float-widetag
complex-widetag
complex-single-float-widetag
complex-double-float-widetag
#!+long-float complex-long-float-widetag
#+long-float complex-long-float-widetag
. #.fixnum-lowtags))
(!define-type-vop rationalp
@ -240,14 +240,14 @@
(bignum-widetag . #.fixnum-lowtags))
(!define-type-vop floatp
(single-float-widetag double-float-widetag #!+long-float long-float-widetag))
(single-float-widetag double-float-widetag #+long-float long-float-widetag))
(!define-type-vop realp
(ratio-widetag
bignum-widetag
single-float-widetag
double-float-widetag
#!+long-float long-float-widetag
#+long-float long-float-widetag
. #.fixnum-lowtags))
#!+sb-simd-pack

2
src/compiler/generic/objdef.lisp
View file

@ -73,7 +73,7 @@
#!-64-bit (filler)
(value :c-type "double" :length #.(/ 64 n-word-bits)))
#!+long-float
#+long-float
(!define-primitive-object (long-float :lowtag other-pointer-lowtag
:widetag long-float-widetag)
#!+sparc (filler)

2
src/compiler/generic/vm-array.lisp
View file

@ -129,7 +129,7 @@
simple-array-complex-single-float)
((complex double-float) #C(0.0d0 0.0d0) 128
simple-array-complex-double-float)
#!+long-float
#+long-float
((complex long-float) #C(0.0l0 0.0l0) #!+x86 192 #!+sparc 256
simple-array-complex-long-float)
(t 0 #.n-word-bits simple-vector))))

6
src/compiler/generic/vm-fndb.lisp
View file

@ -18,7 +18,7 @@
(defknown (fixnump bignump ratiop
short-float-p single-float-p double-float-p long-float-p
complex-rational-p complex-float-p complex-single-float-p
complex-double-float-p #!+long-float complex-long-float-p
complex-double-float-p #+long-float complex-long-float-p
complex-vector-p
#!+sb-unicode base-char-p
%standard-char-p %instancep
@ -50,10 +50,10 @@
#!+64-bit
simple-array-signed-byte-64-p
simple-array-single-float-p simple-array-double-float-p
#!+long-float simple-array-long-float-p
#+long-float simple-array-long-float-p
simple-array-complex-single-float-p
simple-array-complex-double-float-p
#!+long-float simple-array-complex-long-float-p
#+long-float simple-array-complex-long-float-p
simple-rank-1-array-*-p
system-area-pointer-p realp
;; #!-64-bit

2
src/compiler/generic/vm-tran.lisp
View file

@ -15,7 +15,7 @@
;;; transform picks whichever predicate was defined last when there
;;; are multiple predicates for equivalent types.
(define-source-transform short-float-p (x) `(single-float-p ,x))
#!-long-float
#-long-float
(define-source-transform long-float-p (x) `(double-float-p ,x))
(define-source-transform compiled-function-p (x)

14
src/compiler/generic/vm-type.lisp
View file

@ -25,15 +25,15 @@
;;; worst-case values for float attributes
(sb-xc:deftype float-exponent ()
#!-long-float 'double-float-exponent
#!+long-float 'long-float-exponent)
#-long-float 'double-float-exponent
#+long-float 'long-float-exponent)
(sb-xc:deftype float-digits ()
#!-long-float `(integer 0 ,sb-vm:double-float-digits)
#!+long-float `(integer 0 ,sb-vm:long-float-digits))
#-long-float `(integer 0 ,sb-vm:double-float-digits)
#+long-float `(integer 0 ,sb-vm:long-float-digits))
(sb-xc:deftype float-radix () '(integer 2 2))
(sb-xc:deftype float-int-exponent ()
#!-long-float 'double-float-int-exponent
#!+long-float 'long-float-int-exponent)
#-long-float 'double-float-int-exponent
#+long-float 'long-float-int-exponent)
;;; a code for BOOLE
(sb-xc:deftype boole-code () '(unsigned-byte 4))
@ -94,7 +94,7 @@
(etypecase x
(single-float 'single-float)
(double-float 'double-float)
#!+long-float (long-float 'long-float)))
#+long-float (long-float 'long-float)))
(declaim (ftype (sfunction (ctype) ctype) %upgraded-array-element-type))
(defun %upgraded-array-element-type (eltype)

6
src/compiler/generic/vm-typetran.lisp
View file

@ -22,7 +22,7 @@
#!+sb-unicode (define-type-predicate character-string-p (vector character))
(define-type-predicate complex-double-float-p (complex double-float))
(define-type-predicate complex-single-float-p (complex single-float))
#!+long-float
#+long-float
(define-type-predicate complex-long-float-p (complex long-float))
;;; (COMPLEX-VECTOR-P isn't here because it's not so much a Lisp-level
;;; type predicate as just a hack to get at the type code so that we
@ -82,14 +82,14 @@
(simple-array single-float (*)))
(define-type-predicate simple-array-double-float-p
(simple-array double-float (*)))
#!+long-float
#+long-float
(define-type-predicate simple-array-long-float-p
(simple-array long-float (*)))
(define-type-predicate simple-array-complex-single-float-p
(simple-array (complex single-float) (*)))
(define-type-predicate simple-array-complex-double-float-p
(simple-array (complex double-float) (*)))
#!+long-float
#+long-float
(define-type-predicate simple-array-complex-long-float-p
(simple-array (complex long-float) (*)))
(define-type-predicate simple-base-string-p simple-base-string)

4
src/compiler/saptran.lisp
View file

@ -175,8 +175,8 @@
(def %set-sap-ref-single t single-float)
(def sap-ref-double)
(def %set-sap-ref-double t double-float)
#!+long-float (def sap-ref-long)
#!+long-float (def %set-sap-ref-long t long-float))
#+long-float (def sap-ref-long)
#+long-float (def %set-sap-ref-long t long-float))
(macrolet ((def (fun args 32-bit 64-bit)
`(deftransform ,fun (,args)

8
src/compiler/sparc/array.lisp
View file

@ -361,7 +361,7 @@
(unless (location= result value)
(move-double-reg result value))))
#!+long-float
#+long-float
(define-vop (data-vector-ref/simple-array-long-float)
(:note "inline array access")
(:translate data-vector-ref)
@ -378,7 +378,7 @@
other-pointer-lowtag))
(load-long-reg value object offset nil)))
#!+long-float
#+long-float
(define-vop (data-vector-set/simple-array-long-float)
(:note "inline array store")
(:translate data-vector-set)
@ -539,7 +539,7 @@
(unless (location= result-imag value-imag)
(move-double-reg result-imag value-imag)))))
#!+long-float
#+long-float
(define-vop (data-vector-ref/simple-array-complex-long-float)
(:note "inline array access")
(:translate data-vector-ref)
@ -560,7 +560,7 @@
(inst add offset (* 4 n-word-bytes))
(load-long-reg imag-tn object offset nil))))
#!+long-float
#+long-float
(define-vop (data-vector-set/simple-array-complex-long-float)
(:note "inline array store")
(:translate data-vector-set)

6
src/compiler/sparc/c-call.lisp
View file

@ -69,7 +69,7 @@
(declare (ignore type state))
(make-wired-tn* 'single-float single-reg-sc-number 0))
#!+long-float
#+long-float
(define-alien-type-method (long-float :result-tn) (type)
(declare (ignore type))
(make-wired-tn* 'long-float long-reg-sc-number 0))
@ -111,7 +111,7 @@
(and (alien-integer-type-p type)
(> (sb-alien::alien-integer-type-bits type) 32)))
arg-types)
#!+long-float (some #'alien-long-float-type-p arg-types)
#+long-float (some #'alien-long-float-type-p arg-types)
(and (alien-integer-type-p result-type)
(> (sb-alien::alien-integer-type-bits result-type) 32)))
(collect ((new-args) (lambda-vars) (new-arg-types))
@ -137,7 +137,7 @@
(new-args `(double-float-low-bits ,arg))
(new-arg-types (parse-alien-type '(signed 32) nil))
(new-arg-types (parse-alien-type '(unsigned 32) nil)))
#!+long-float
#+long-float
((alien-long-float-type-p type)
(new-args `(long-float-exp-bits ,arg))
(new-args `(long-float-high-bits ,arg))

100
src/compiler/sparc/float.lisp
View file

@ -57,7 +57,7 @@
(when restore-offset
(inst sub offset (* 2 n-word-bytes)))))))))
#!+long-float
#+long-float
(define-move-fun (load-long 2) (vop x y)
((long-stack) (long-reg))
(let ((nfp (current-nfp-tn vop))
@ -87,7 +87,7 @@
(when restore-offset
(inst sub offset (* 2 n-word-bytes)))))))))
#!+long-float
#+long-float
(define-move-fun (store-long 2) (vop x y)
((long-reg) (long-stack))
(let ((nfp (current-nfp-tn vop))
@ -147,7 +147,7 @@
(define-move-vop ,vop :move (,sc) (,sc)))))
(frob single-move single-reg :single)
(frob double-move double-reg :double)
#!+long-float
#+long-float
(frob long-move long-reg :long))
@ -179,7 +179,7 @@
single-float-size single-float-widetag single-float-value-slot)
(frob move-from-double double-reg :double
double-float-size double-float-widetag double-float-value-slot)
#!+long-float
#+long-float
(frob move-from-long long-reg :long
long-float-size long-float-widetag long-float-value-slot))
@ -199,7 +199,7 @@
(frob move-to-single single-reg :single single-float-value-slot)
(frob move-to-double double-reg :double double-float-value-slot))
#!+long-float
#+long-float
(define-vop (move-to-long)
(:args (x :scs (descriptor-reg)))
(:results (y :scs (long-reg)))
@ -207,7 +207,7 @@
(:generator 2
(load-long-reg y x (- (* long-float-value-slot n-word-bytes)
other-pointer-lowtag))))
#!+long-float
#+long-float
(define-move-vop move-to-long :move (descriptor-reg) (long-reg))
(macrolet ((frob (name sc stack-sc format)
@ -236,7 +236,7 @@
(frob move-single-float-arg single-reg single-stack :single)
(frob move-double-float-arg double-reg double-stack :double))
#!+long-float
#+long-float
(define-vop (move-long-float-arg)
(:args (x :scs (long-reg) :target y)
(nfp :scs (any-reg) :load-if (not (sc-is y long-reg))))
@ -251,7 +251,7 @@
(let ((offset (* (tn-offset y) n-word-bytes)))
(store-long-reg x nfp offset))))))
;;;
#!+long-float
#+long-float
(define-move-vop move-long-float-arg :move-arg
(long-reg descriptor-reg) (long-reg))
@ -272,11 +272,11 @@
(make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
:offset (+ (tn-offset x) 2)))
#!+long-float
#+long-float
(defun complex-long-reg-real-tn (x)
(make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
:offset (tn-offset x)))
#!+long-float
#+long-float
(defun complex-long-reg-imag-tn (x)
(make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
:offset (+ (tn-offset x) 4)))
@ -320,7 +320,7 @@
(inst stdf imag-tn nfp (+ offset (* 2 n-word-bytes))))))
#!+long-float
#+long-float
(define-move-fun (load-complex-long 5) (vop x y)
((complex-long-stack) (complex-long-reg))
(let ((nfp (current-nfp-tn vop))
@ -330,7 +330,7 @@
(let ((imag-tn (complex-long-reg-imag-tn y)))
(load-long-reg imag-tn nfp (+ offset (* 4 n-word-bytes))))))
#!+long-float
#+long-float
(define-move-fun (store-complex-long 5) (vop x y)
((complex-long-reg) (complex-long-stack))
(let ((nfp (current-nfp-tn vop))
@ -381,7 +381,7 @@
(define-move-vop complex-double-move :move
(complex-double-reg) (complex-double-reg))
#!+long-float
#+long-float
(define-vop (complex-long-move)
(:args (x :scs (complex-long-reg)
:target y :load-if (not (location= x y))))
@ -398,7 +398,7 @@
(y-imag (complex-long-reg-imag-tn y)))
(move-long-reg y-imag x-imag)))))
;;;
#!+long-float
#+long-float
(define-move-vop complex-long-move :move
(complex-long-reg) (complex-long-reg))
@ -446,7 +446,7 @@
(define-move-vop move-from-complex-double :move
(complex-double-reg) (descriptor-reg))
#!+long-float
#+long-float
(define-vop (move-from-complex-long)
(:args (x :scs (complex-long-reg) :to :save))
(:results (y :scs (descriptor-reg)))
@ -464,7 +464,7 @@
n-word-bytes)
other-pointer-lowtag))))))
;;;
#!+long-float
#+long-float
(define-move-vop move-from-complex-long :move
(complex-long-reg) (descriptor-reg))
@ -499,7 +499,7 @@
(define-move-vop move-to-complex-double :move
(descriptor-reg) (complex-double-reg))
#!+long-float
#+long-float
(define-vop (move-to-complex-long)
(:args (x :scs (descriptor-reg)))
(:results (y :scs (complex-long-reg)))
@ -511,7 +511,7 @@
(let ((imag-tn (complex-long-reg-imag-tn y)))
(load-long-reg imag-tn x (- (* complex-long-float-imag-slot n-word-bytes)
other-pointer-lowtag)))))
#!+long-float
#+long-float
(define-move-vop move-to-complex-long :move
(descriptor-reg) (complex-long-reg))
@ -566,7 +566,7 @@
(define-move-vop move-complex-double-float-arg :move-arg
(complex-double-reg descriptor-reg) (complex-double-reg))
#!+long-float
#+long-float
(define-vop (move-complex-long-float-arg)
(:args (x :scs (complex-long-reg) :target y)
(nfp :scs (any-reg) :load-if (not (sc-is y complex-long-reg))))
@ -588,14 +588,14 @@
(store-long-reg real-tn nfp offset))
(let ((imag-tn (complex-long-reg-imag-tn x)))
(store-long-reg imag-tn nfp (+ offset (* 4 n-word-bytes)))))))))
#!+long-float
#+long-float
(define-move-vop move-complex-long-float-arg :move-arg
(complex-long-reg descriptor-reg) (complex-long-reg))
(define-move-vop move-arg :move-arg
(single-reg double-reg #!+long-float long-reg
complex-single-reg complex-double-reg #!+long-float complex-long-reg)
(single-reg double-reg #+long-float long-reg
complex-single-reg complex-double-reg #+long-float complex-long-reg)
(descriptor-reg))
@ -618,7 +618,7 @@
(:result-types ,ptype))))
(frob single-float-op single-reg single-float)
(frob double-float-op double-reg double-float)
#!+long-float
#+long-float
(frob long-float-op long-reg long-float))
(macrolet ((frob (op sinst sname scost dinst dname dcost)
@ -636,7 +636,7 @@
(frob * fmuls */single-float 4 fmuld */double-float 5)
(frob / fdivs //single-float 12 fdivd //double-float 19))
#!+long-float
#+long-float
(macrolet ((frob (op linst lname lcost)
`(define-vop (,lname long-float-op)
(:translate ,op)
@ -725,7 +725,7 @@
(note-this-location vop :internal-error)
(negate-double-reg y x)))
#!+long-float
#+long-float
(define-vop (abs/long-float)
(:args (x :scs (long-reg)))
(:results (y :scs (long-reg)))
@ -754,7 +754,7 @@
:offset (+ i 1 (tn-offset x)))))
(inst fmovs y-odd x-odd)))))))
#!+long-float
#+long-float
(define-vop (%negate/long-float)
(:args (x :scs (long-reg)))
(:results (y :scs (long-reg)))
@ -815,10 +815,10 @@
(:arg-types ,ptype ,ptype))))
(frob single-float-compare single-reg single-float)
(frob double-float-compare double-reg double-float)
#!+long-float
#+long-float
(frob long-float-compare long-reg long-float))
(macrolet ((frob (translate yep nope sname dname #!+long-float lname)
(macrolet ((frob (translate yep nope sname dname #+long-float lname)
`(progn
(define-vop (,sname single-float-compare)
(:translate ,translate)
@ -826,15 +826,15 @@
(define-vop (,dname double-float-compare)
(:translate ,translate)
(:variant :double ,yep ,nope))
#!+long-float
#+long-float
(define-vop (,lname long-float-compare)
(:translate ,translate)
(:variant :long ,yep ,nope)))))
(frob < :l :ge </single-float </double-float #!+long-float </long-float)
(frob > :g :le >/single-float >/double-float #!+long-float >/long-float)
(frob = :eq :ne =/single-float =/double-float #!+long-float =/long-float))
(frob < :l :ge </single-float </double-float #+long-float </long-float)
(frob > :g :le >/single-float >/double-float #+long-float >/long-float)
(frob = :eq :ne =/single-float =/double-float #+long-float =/long-float))
#!+long-float
#+long-float
(deftransform eql ((x y) (long-float long-float))
'(and (= (long-float-low-bits x) (long-float-low-bits y))
(= (long-float-mid-bits x) (long-float-mid-bits y))
@ -875,7 +875,7 @@
(inst ,inst y temp))))))
(frob %single-float/signed %single-float fitos single-reg single-float)
(frob %double-float/signed %double-float fitod double-reg double-float)
#!+long-float
#+long-float
(frob %long-float/signed %long-float fitoq long-reg long-float))
(macrolet ((frob (name translate inst from-sc from-type to-sc to-type)
@ -894,18 +894,18 @@
(inst ,inst y x)))))
(frob %single-float/double-float %single-float fdtos
double-reg double-float single-reg single-float)
#!+long-float
#+long-float
(frob %single-float/long-float %single-float fqtos
long-reg long-float single-reg single-float)
(frob %double-float/single-float %double-float fstod
single-reg single-float double-reg double-float)
#!+long-float
#+long-float
(frob %double-float/long-float %double-float fqtod
long-reg long-float double-reg double-float)
#!+long-float
#+long-float
(frob %long-float/single-float %long-float fstoq
single-reg single-float long-reg long-float)
#!+long-float
#+long-float
(frob %long-float/double-float %long-float fdtoq
double-reg double-float long-reg long-float))
@ -937,7 +937,7 @@
(* (tn-offset stack-temp) n-word-bytes))))))))
(frob %unary-truncate/single-float single-reg single-float fstoi)
(frob %unary-truncate/double-float double-reg double-float fdtoi)
#!+long-float
#+long-float
(frob %unary-truncate/long-float long-reg long-float fqtoi)
;; KLUDGE -- these two forms were protected by #-sun4.
;; (frob %unary-round single-reg single-float fstoir)
@ -1014,7 +1014,7 @@
(inst lddf res (current-nfp-tn vop)
(* (tn-offset temp) n-word-bytes)))))
#!+long-float
#+long-float
(define-vop (make-long-float)
(:args (hi-bits :scs (signed-reg))
(lo1-bits :scs (unsigned-reg))
@ -1125,7 +1125,7 @@
(loadw lo-bits float (1+ double-float-value-slot)
other-pointer-lowtag)))))
#!+long-float
#+long-float
(define-vop (long-float-exp-bits)
(:args (float :scs (long-reg descriptor-reg)
:load-if (not (sc-is float long-stack))))
@ -1153,7 +1153,7 @@
(loadw exp-bits float long-float-value-slot
other-pointer-lowtag)))))
#!+long-float
#+long-float
(define-vop (long-float-high-bits)
(:args (float :scs (long-reg descriptor-reg)
:load-if (not (sc-is float long-stack))))
@ -1181,7 +1181,7 @@
(loadw high-bits float (1+ long-float-value-slot)
other-pointer-lowtag)))))
#!+long-float
#+long-float
(define-vop (long-float-mid-bits)
(:args (float :scs (long-reg descriptor-reg)
:load-if (not (sc-is float long-stack))))
@ -1209,7 +1209,7 @@
(loadw mid-bits float (+ 2 long-float-value-slot)
other-pointer-lowtag)))))
#!+long-float
#+long-float
(define-vop (long-float-low-bits)
(:args (float :scs (long-reg descriptor-reg)
:load-if (not (sc-is float long-stack))))
@ -1345,7 +1345,7 @@
;;;; Special functions.
#!-long-float
#-long-float
(define-vop (fsqrt)
(:args (x :scs (double-reg)))
(:results (y :scs (double-reg)))
@ -1363,7 +1363,7 @@
(note-this-location vop :internal-error)
(inst fsqrtd y x)))
#!+long-float
#+long-float
(define-vop (fsqrt-long)
(:args (x :scs (long-reg)))
(:results (y :scs (long-reg)))
@ -1437,7 +1437,7 @@
(inst stdf real nfp offset))
(inst stdf imag nfp (+ offset (* 2 n-word-bytes))))))))
#!+long-float
#+long-float
(define-vop (make-complex-long-float)
(:translate complex)
(:args (real :scs (long-reg) :target r
@ -1530,7 +1530,7 @@
(:note "complex double float imagpart")
(:variant :imag))
#!+long-float
#+long-float
(define-vop (complex-long-float-value)
(:args (x :scs (complex-long-reg) :target r
:load-if (not (sc-is x complex-long-stack))))
@ -1553,13 +1553,13 @@
(* (+ (ecase slot (:real 0) (:imag 4)) (tn-offset x))
n-word-bytes))))))
#!+long-float
#+long-float
(define-vop (realpart/complex-long-float complex-long-float-value)
(:translate realpart)
(:note "complex long float realpart")
(:variant :real))
#!+long-float
#+long-float
(define-vop (imagpart/complex-long-float complex-long-float-value)
(:translate imagpart)
(:note "complex long float imagpart")

2
src/compiler/sparc/insts.lisp
View file

@ -71,7 +71,7 @@ Otherwise, use the Sparc register names")
(let ((offset (tn-offset loc)))
(aver (zerop (mod offset 2)))
(values (+ offset 32) 2)))
#!+long-float
#+long-float
(long-reg
(let ((offset (tn-offset loc)))
(aver (zerop (mod offset 4)))

2
src/compiler/sparc/sap.lisp
View file

@ -256,7 +256,7 @@
single-reg single-float :single)
(def-system-ref-and-set sap-ref-double %set-sap-ref-double
double-reg double-float :double)
#!+long-float
#+long-float
(def-system-ref-and-set sap-ref-long %set-sap-ref-long
long-reg long-float :long-float)
) ; MACROLET

8
src/compiler/sparc/vm.lisp
View file

@ -154,13 +154,13 @@
(single-stack non-descriptor-stack) ; single-floats
(double-stack non-descriptor-stack
:element-size 2 :alignment 2) ; double floats.
#!+long-float
#+long-float
(long-stack non-descriptor-stack :element-size 4 :alignment 4) ; long floats.
;; complex-single-floats
(complex-single-stack non-descriptor-stack :element-size 2)
;; complex-double-floats.
(complex-double-stack non-descriptor-stack :element-size 4 :alignment 2)
#!+long-float
#+long-float
;; complex-long-floats.
(complex-long-stack non-descriptor-stack :element-size 8 :alignment 4)
@ -223,7 +223,7 @@
:alternate-scs (double-stack))
;; Non-Descriptor double-floats.
#!+long-float
#+long-float
(long-reg float-registers
:locations #.(loop for i from 0 to #!-sparc-64 31 #!+sparc-64 63
by 4 collect i)
@ -250,7 +250,7 @@
:save-p t
:alternate-scs (complex-double-stack))
#!+long-float
#+long-float
(complex-long-reg float-registers
:locations #.(loop for i from 0 to #!-sparc-64 31 #!+sparc-64 63
by 8 collect i)

10
src/compiler/srctran.lisp
View file

@ -1740,14 +1740,14 @@
(values 'integer nil))
(rational
(values 'rational nil))
((or single-float double-float #!+long-float long-float)
((or single-float double-float #+long-float long-float)
(values 'float rem-type))
(float
(values 'float nil))
(real
(values nil nil)))
(when (member rem-type '(float single-float double-float
#!+long-float long-float))
#+long-float long-float))
(setf rem (interval-func #'(lambda (x)
(coerce-for-bound x rem-type))
rem)))
@ -1886,14 +1886,14 @@
(values 'integer nil))
(rational
(values 'rational nil))
((or single-float double-float #!+long-float long-float)
((or single-float double-float #+long-float long-float)
(values 'float result-type))
(float
(values 'float nil))
(real
(values nil nil)))
(when (member result-type '(float single-float double-float
#!+long-float long-float))
#+long-float long-float))
;; Make sure that the limits on the interval have
;; the right type.
(setf rem (interval-func (lambda (x)
@ -4832,7 +4832,7 @@
(specifier-type '(complex single-float)))
(csubtypep result-typeoid
(specifier-type '(complex double-float)))
#!+long-float
#+long-float
(csubtypep result-typeoid
(specifier-type '(complex long-float))))
;; float complex types are never canonicalized.

2
src/compiler/typetran.lisp
View file

@ -1167,7 +1167,7 @@
'x)
((csubtypep tspec (specifier-type 'double-float))
`(the ,tval (%double-float x)))
;; FIXME: #!+long-float (t ,(error "LONG-FLOAT case needed"))
;; FIXME: #+long-float (t ,(error "LONG-FLOAT case needed"))
((csubtypep tspec (specifier-type 'float))
`(the ,tval (%single-float x)))
((csubtypep tspec (specifier-type 'complex))

6
src/compiler/x86/c-call.lisp
View file

@ -37,7 +37,7 @@
sap-stack-sc-number
stack-frame-size)))
#!+long-float
#+long-float
(define-alien-type-method (long-float :arg-tn) (type state)
(declare (ignore type))
(let ((stack-frame-size (arg-state-stack-frame-size state)))
@ -87,7 +87,7 @@
(make-wired-tn* 'system-area-pointer sap-reg-sc-number
(result-reg-offset num-results))))
#!+long-float
#+long-float
(define-alien-type-method (long-float :result-tn) (type state)
(declare (ignore type))
(let ((num-results (result-state-num-results state)))
@ -258,7 +258,7 @@
(let ((ea (ea-for-df-stack fp-temp)))
(inst fstpd ea)
(inst fldd ea)))
#!+long-float
#+long-float
(long-reg ; nothing to do!
)))

164
src/compiler/x86/float.lisp
View file

@ -17,7 +17,7 @@
(ea-for-xf-desc tn single-float-value-slot))
(defun ea-for-df-desc (tn)
(ea-for-xf-desc tn double-float-value-slot))
#!+long-float
#+long-float
(defun ea-for-lf-desc (tn)
(ea-for-xf-desc tn long-float-value-slot))
;; complex floats
@ -29,10 +29,10 @@
(ea-for-xf-desc tn complex-double-float-real-slot))
(defun ea-for-cdf-imag-desc (tn)
(ea-for-xf-desc tn complex-double-float-imag-slot))
#!+long-float
#+long-float
(defun ea-for-clf-real-desc (tn)
(ea-for-xf-desc tn complex-long-float-real-slot))
#!+long-float
#+long-float
(defun ea-for-clf-imag-desc (tn)
(ea-for-xf-desc tn complex-long-float-imag-slot)))
@ -46,7 +46,7 @@
(ea-for-xf-stack tn :single))
(defun ea-for-df-stack (tn)
(ea-for-xf-stack tn :double))
#!+long-float
#+long-float
(defun ea-for-lf-stack (tn)
(ea-for-xf-stack tn :long)))
@ -92,10 +92,10 @@
(ea-for-cxf-stack tn :double :real base))
(defun ea-for-cdf-imag-stack (tn &optional (base ebp-tn))
(ea-for-cxf-stack tn :double :imag base))
#!+long-float
#+long-float
(defun ea-for-clf-real-stack (tn &optional (base ebp-tn))
(ea-for-cxf-stack tn :long :real base))
#!+long-float
#+long-float
(defun ea-for-clf-imag-stack (tn &optional (base ebp-tn))
(ea-for-cxf-stack tn :long :imag base)))
@ -121,7 +121,7 @@
;;; The x86 can't store a long-float to memory without popping the
;;; stack and marking a register as empty, so it is necessary to
;;; restore the register from memory.
#!+long-float
#+long-float
(defun store-long-float (ea)
(inst fstpl ea)
(inst fldl ea))
@ -159,13 +159,13 @@
;; This may not be necessary as ST0 is likely invalid now.
(inst fxch x))))
#!+long-float
#+long-float
(define-move-fun (load-long 2) (vop x y)
((long-stack) (long-reg))
(with-empty-tn@fp-top(y)
(inst fldl (ea-for-lf-stack x))))
#!+long-float
#+long-float
(define-move-fun (store-long 2) (vop x y)
((long-reg) (long-stack))
(cond ((zerop (tn-offset x))
@ -184,28 +184,28 @@
;;; "immediate-constant-sc" in vm.lisp.
(eval-when (:compile-toplevel :execute)
(setf *read-default-float-format*
#!+long-float 'long-float #!-long-float 'double-float))
#+long-float 'long-float #-long-float 'double-float))
(define-move-fun (load-fp-constant 2) (vop x y)
((fp-constant) (single-reg double-reg #!+long-float long-reg))
((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))
((= value 1e0)
(inst fld1))
#!+long-float
#+long-float
((= value (coerce pi *read-default-float-format*))
(inst fldpi))
#!+long-float
#+long-float
((= value (log 10e0 2e0))
(inst fldl2t))
#!+long-float
#+long-float
((= value (log 2.718281828459045235360287471352662e0 2e0))
(inst fldl2e))
#!+long-float
#+long-float
((= value (log 2e0 10e0))
(inst fldlg2))
#!+long-float
#+long-float
((= value (log 2e0 2.718281828459045235360287471352662e0))
(inst fldln2))
(t (warn "ignoring bogus i387 constant ~A" value))))))
@ -239,11 +239,11 @@
(make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
:offset (1+ (tn-offset x))))
#!+long-float
#+long-float
(defun complex-long-reg-real-tn (x)
(make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
:offset (tn-offset x)))
#!+long-float
#+long-float
(defun complex-long-reg-imag-tn (x)
(make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
:offset (1+ (tn-offset x))))
@ -295,7 +295,7 @@
(inst fstd (ea-for-cdf-imag-stack y))
(inst fxch imag-tn)))
#!+long-float
#+long-float
(define-move-fun (load-complex-long 2) (vop x y)
((complex-long-stack) (complex-long-reg))
(let ((real-tn (complex-long-reg-real-tn y)))
@ -305,7 +305,7 @@
(with-empty-tn@fp-top(imag-tn)
(inst fldl (ea-for-clf-imag-stack x)))))
#!+long-float
#+long-float
(define-move-fun (store-complex-long 2) (vop x y)
((complex-long-reg) (complex-long-stack))
(let ((real-tn (complex-long-reg-real-tn x)))
@ -349,11 +349,11 @@
(:results (y :scs (double-reg) :load-if (not (location= x y)))))
(define-move-vop double-move :move (double-reg) (double-reg))
#!+long-float
#+long-float
(define-vop (long-move float-move)
(:args (x :scs (long-reg) :target y :load-if (not (location= x y))))
(:results (y :scs (long-reg) :load-if (not (location= x y)))))
#!+long-float
#+long-float
(define-move-vop long-move :move (long-reg) (long-reg))
;;; complex float register to register moves
@ -395,12 +395,12 @@
(define-move-vop complex-double-move :move
(complex-double-reg) (complex-double-reg))
#!+long-float
#+long-float
(define-vop (complex-long-move complex-float-move)
(:args (x :scs (complex-long-reg)
:target y :load-if (not (location= x y))))
(:results (y :scs (complex-long-reg) :load-if (not (location= x y)))))
#!+long-float
#+long-float
(define-move-vop complex-long-move :move
(complex-long-reg) (complex-long-reg))
@ -430,7 +430,7 @@
(define-move-vop move-from-double :move
(double-reg) (descriptor-reg))
#!+long-float
#+long-float
(define-vop (move-from-long)
(:args (x :scs (long-reg) :to :save))
(:results (y :scs (descriptor-reg)))
@ -440,7 +440,7 @@
(fixed-alloc y long-float-widetag long-float-size node)
(with-tn@fp-top(x)
(store-long-float (ea-for-lf-desc y)))))
#!+long-float
#+long-float
(define-move-vop move-from-long :move
(long-reg) (descriptor-reg))
@ -453,20 +453,20 @@
(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
#+long-float
(0l0 (load-symbol-value y *fp-constant-0l0*))
#!+long-float
#+long-float
(1l0 (load-symbol-value y *fp-constant-1l0*))
#!+long-float
#+long-float
(#.pi (load-symbol-value y *fp-constant-pi*))
#!+long-float
#+long-float
(#.(log 10l0 2l0) (load-symbol-value y *fp-constant-l2t*))
#!+long-float
#+long-float
(#.(log 2.718281828459045235360287471352662L0 2l0)
(load-symbol-value y *fp-constant-l2e*))
#!+long-float
#+long-float
(#.(log 2l0 10l0) (load-symbol-value y *fp-constant-lg2*))
#!+long-float
#+long-float
(#.(log 2l0 2.718281828459045235360287471352662L0)
(load-symbol-value y *fp-constant-ln2*)))))
(define-move-vop move-from-fp-constant :move
@ -491,7 +491,7 @@
(inst fldd (ea-for-df-desc x)))))
(define-move-vop move-to-double :move (descriptor-reg) (double-reg))
#!+long-float
#+long-float
(define-vop (move-to-long)
(:args (x :scs (descriptor-reg)))
(:results (y :scs (long-reg)))
@ -499,7 +499,7 @@
(:generator 2
(with-empty-tn@fp-top(y)
(inst fldl (ea-for-lf-desc x)))))
#!+long-float
#+long-float
(define-move-vop move-to-long :move (descriptor-reg) (long-reg))
;;; Move from complex float to a descriptor reg. allocating a new
@ -536,7 +536,7 @@
(define-move-vop move-from-complex-double :move
(complex-double-reg) (descriptor-reg))
#!+long-float
#+long-float
(define-vop (move-from-complex-long)
(:args (x :scs (complex-long-reg) :to :save))
(:results (y :scs (descriptor-reg)))
@ -550,7 +550,7 @@
(let ((imag-tn (complex-long-reg-imag-tn x)))
(with-tn@fp-top(imag-tn)
(store-long-float (ea-for-clf-imag-desc y))))))
#!+long-float
#+long-float
(define-move-vop move-from-complex-long :move
(complex-long-reg) (descriptor-reg))
@ -567,19 +567,19 @@
,@(ecase format
(:single '((inst fld (ea-for-csf-real-desc x))))
(:double '((inst fldd (ea-for-cdf-real-desc x))))
#!+long-float
#+long-float
(:long '((inst fldl (ea-for-clf-real-desc x)))))))
(let ((imag-tn (complex-double-reg-imag-tn y)))
(with-empty-tn@fp-top(imag-tn)
,@(ecase format
(:single '((inst fld (ea-for-csf-imag-desc x))))
(:double '((inst fldd (ea-for-cdf-imag-desc x))))
#!+long-float
#+long-float
(:long '((inst fldl (ea-for-clf-imag-desc x)))))))))
(define-move-vop ,name :move (descriptor-reg) (,sc)))))
(frob move-to-complex-single complex-single-reg :single)
(frob move-to-complex-double complex-double-reg :double)
#!+long-float
#+long-float
(frob move-to-complex-double complex-long-reg :long))
;;;; the move argument vops
@ -617,7 +617,7 @@
,@(ecase format
(:single '((inst fst ea)))
(:double '((inst fstd ea)))
#!+long-float
#+long-float
(:long '((store-long-float ea))))))
;; Lisp stack
(let ((ea (make-ea
@ -632,13 +632,13 @@
,@(ecase format
(:single '((inst fst ea)))
(:double '((inst fstd ea)))
#!+long-float
#+long-float
(:long '((store-long-float ea)))))))))))
(define-move-vop ,name :move-arg
(,sc descriptor-reg) (,sc)))))
(frob move-single-float-arg single-reg single-stack :single)
(frob move-double-float-arg double-reg double-stack :double)
#!+long-float
#+long-float
(frob move-long-float-arg long-reg long-stack :long))
;;;; complex float MOVE-ARG VOP
@ -679,7 +679,7 @@
(:double
'((inst fstd
(ea-for-cdf-real-stack y fp))))
#!+long-float
#+long-float
(:long
'((store-long-float
(ea-for-clf-real-stack y fp))))))
@ -692,7 +692,7 @@
(:double
'((inst fstd
(ea-for-cdf-real-stack y fp))))
#!+long-float
#+long-float
(:long
'((store-long-float
(ea-for-clf-real-stack y fp)))))
@ -704,7 +704,7 @@
'((inst fst (ea-for-csf-imag-stack y fp))))
(:double
'((inst fstd (ea-for-cdf-imag-stack y fp))))
#!+long-float
#+long-float
(:long
'((store-long-float
(ea-for-clf-imag-stack y fp)))))
@ -715,13 +715,13 @@
complex-single-reg complex-single-stack :single)
(frob move-complex-double-float-arg
complex-double-reg complex-double-stack :double)
#!+long-float
#+long-float
(frob move-complex-long-float-arg
complex-long-reg complex-long-stack :long))
(define-move-vop move-arg :move-arg
(single-reg double-reg #!+long-float long-reg
complex-single-reg complex-double-reg #!+long-float complex-long-reg)
(single-reg double-reg #+long-float long-reg
complex-single-reg complex-double-reg #+long-float complex-long-reg)
(descriptor-reg))
@ -760,7 +760,7 @@
fop fopr sname scost
fopd foprd dname dcost
lname lcost)
#!-long-float (declare (ignore lcost lname))
#-long-float (declare (ignore lcost lname))
`(progn
(define-vop (,sname)
(:translate ,op)
@ -1044,7 +1044,7 @@
(double-stack
(inst fstd (ea-for-df-stack r))))))))
#!+long-float
#+long-float
(define-vop (,lname)
(:translate ,op)
(:args (x :scs (long-reg) :to :eval)
@ -1169,11 +1169,11 @@
(frob abs/single-float fabs abs single-reg single-float)
(frob abs/double-float fabs abs double-reg double-float)
#!+long-float
#+long-float
(frob abs/long-float fabs abs long-reg long-float)
(frob %negate/single-float fchs %negate single-reg single-float)
(frob %negate/double-float fchs %negate double-reg double-float)
#!+long-float
#+long-float
(frob %negate/long-float fchs %negate long-reg long-float))
;;;; comparison
@ -1222,7 +1222,7 @@
(y :scs (double-reg)))
(:arg-types double-float double-float))
#!+long-float
#+long-float
(define-vop (=/long-float =/float)
(:translate =)
(:args (x :scs (long-reg))
@ -1327,7 +1327,7 @@
(inst and ah-tn #x45) ; C3 C2 C0
(inst cmp ah-tn #x01)))))
#!+long-float
#+long-float
(define-vop (<long-float)
(:translate <)
(:args (x :scs (long-reg))
@ -1459,7 +1459,7 @@
(inst fnstsw) ; status word to ax
(inst and ah-tn #x45)))))
#!+long-float
#+long-float
(define-vop (>long-float)
(:translate >)
(:args (x :scs (long-reg))
@ -1531,7 +1531,7 @@
(:args (x :scs (double-reg)))
(:arg-types double-float (:constant (double-float 0d0 0d0)))
(:variant #x40))
#!+long-float
#+long-float
(define-vop (=0/long-float float-test)
(:translate =)
(:args (x :scs (long-reg)))
@ -1548,7 +1548,7 @@
(:args (x :scs (double-reg)))
(:arg-types double-float (:constant (double-float 0d0 0d0)))
(:variant #x01))
#!+long-float
#+long-float
(define-vop (<0/long-float float-test)
(:translate <)
(:args (x :scs (long-reg)))
@ -1565,14 +1565,14 @@
(:args (x :scs (double-reg)))
(:arg-types double-float (:constant (double-float 0d0 0d0)))
(:variant #x00))
#!+long-float
#+long-float
(define-vop (>0/long-float float-test)
(:translate >)
(:args (x :scs (long-reg)))
(:arg-types long-float (:constant (long-float 0l0 0l0)))
(:variant #x00))
#!+long-float
#+long-float
(deftransform eql ((x y) (long-float long-float))
`(and (= (long-float-low-bits x) (long-float-low-bits y))
(= (long-float-high-bits x) (long-float-high-bits y))
@ -1605,7 +1605,7 @@
(inst fild x))))))))
(frob %single-float/signed %single-float single-reg single-float)
(frob %double-float/signed %double-float double-reg double-float)
#!+long-float
#+long-float
(frob %long-float/signed %long-float long-reg long-float))
(macrolet ((frob (name translate to-sc to-type)
@ -1628,7 +1628,7 @@
(inst add esp-tn 8)))))
(frob %single-float/unsigned %single-float single-reg single-float)
(frob %double-float/unsigned %double-float double-reg double-float)
#!+long-float
#+long-float
(frob %long-float/unsigned %long-float long-reg long-float))
(macrolet ((frob (name translate from-sc from-type to-sc to-type
@ -1671,20 +1671,20 @@
(frob %single-float/double-float %single-float double-reg double-float
single-reg single-float
single-stack fst fld)
#!+long-float
#+long-float
(frob %single-float/long-float %single-float long-reg
long-float single-reg single-float
single-stack fst fld)
(frob %double-float/single-float %double-float single-reg single-float
double-reg double-float)
#!+long-float
#+long-float
(frob %double-float/long-float %double-float long-reg long-float
double-reg double-float
double-stack fstd fldd)
#!+long-float
#+long-float
(frob %long-float/single-float %long-float single-reg single-float
long-reg long-float)
#!+long-float
#+long-float
(frob %long-float/double-float %long-float double-reg double-float
long-reg long-float))
@ -1727,11 +1727,11 @@
'((inst fldcw scw)))))))))
(frob %unary-truncate/single-float single-reg single-float nil)
(frob %unary-truncate/double-float double-reg double-float nil)
#!+long-float
#+long-float
(frob %unary-truncate/long-float long-reg long-float nil)
(frob %unary-round single-reg single-float t)
(frob %unary-round double-reg double-float t)
#!+long-float
#+long-float
(frob %unary-round long-reg long-float t))
(macrolet ((frob (trans from-sc from-type round-p)
@ -1774,11 +1774,11 @@
'((inst fldcw scw)))))))
(frob %unary-truncate/single-float single-reg single-float nil)
(frob %unary-truncate/double-float double-reg double-float nil)
#!+long-float
#+long-float
(frob %unary-truncate/long-float long-reg long-float nil)
(frob %unary-round single-reg single-float t)
(frob %unary-round double-reg double-float t)
#!+long-float
#+long-float
(frob %unary-round long-reg long-float t))
(define-vop (make-single-float)
@ -1861,7 +1861,7 @@
(inst fldd (register-inline-constant
:double-float-bits (logior (ash hi 32) lo))))))
#!+long-float
#+long-float
(define-vop (make-long-float)
(:args (exp-bits :scs (signed-reg))
(hi-bits :scs (unsigned-reg))
@ -1960,7 +1960,7 @@
(loadw lo-bits float double-float-value-slot
other-pointer-lowtag)))))
#!+long-float
#+long-float
(define-vop (long-float-exp-bits)
(:args (float :scs (long-reg descriptor-reg)
:load-if (not (sc-is float long-stack))))
@ -1990,7 +1990,7 @@
(make-ea-for-object-slot float (+ 2 long-float-value-slot)
other-pointer-lowtag :word))))))
#!+long-float
#+long-float
(define-vop (long-float-high-bits)
(:args (float :scs (long-reg descriptor-reg)
:load-if (not (sc-is float long-stack))))
@ -2015,7 +2015,7 @@
(loadw hi-bits float (1+ long-float-value-slot)
other-pointer-lowtag)))))
#!+long-float
#+long-float
(define-vop (long-float-low-bits)
(:args (float :scs (long-reg descriptor-reg)
:load-if (not (sc-is float long-stack))))
@ -2093,7 +2093,7 @@
(inst add esp-tn npx-env-size) ; Pop stack.
(move res new)))
#!-long-float
#-long-float
(progn
;;; Let's use some of the 80387 special functions.
@ -3101,7 +3101,7 @@
(t (inst fstd r)))))
) ; PROGN #!-LONG-FLOAT
#!+long-float
#+long-float
(progn
;;; Lets use some of the 80387 special functions.
@ -4167,7 +4167,7 @@
(inst fstd (ea-for-cdf-imag-stack r))
(inst fxch imag)))))
#!+long-float
#+long-float
(define-vop (make-complex-long-float)
(:translate complex)
(:args (real :scs (long-reg) :target r
@ -4220,7 +4220,7 @@
(:policy :fast-safe)
(:generator 3
(cond ((sc-is x complex-single-reg complex-double-reg
#!+long-float complex-long-reg)
#+long-float complex-long-reg)
(let ((value-tn
(make-random-tn :kind :normal
:sc (sc-or-lose 'double-reg)
@ -4258,7 +4258,7 @@
(1 (ea-for-cdf-imag-desc x)))))))
(with-empty-tn@fp-top(r)
(inst fldd ea))))
#!+long-float
#+long-float
((sc-is r long-reg)
(let ((ea (sc-case x
(complex-long-stack
@ -4293,7 +4293,7 @@
(:note "complex float realpart")
(:variant 0))
#!+long-float
#+long-float
(define-vop (realpart/complex-long-float complex-float-value)
(:translate realpart)
(:args (x :scs (complex-long-reg complex-long-stack descriptor-reg)
@ -4324,7 +4324,7 @@
(:note "complex float imagpart")
(:variant 1))
#!+long-float
#+long-float
(define-vop (imagpart/complex-long-float complex-float-value)
(:translate imagpart)
(:args (x :scs (complex-long-reg complex-long-stack descriptor-reg)

10
src/compiler/x86/sap.lisp
View file

@ -408,8 +408,8 @@
(:args (sap :scs (sap-reg))
(offset :scs (signed-reg)))
(:arg-types system-area-pointer signed-num)
(:results (result :scs (#!+long-float long-reg #!-long-float double-reg)))
(:result-types #!+long-float long-float #!-long-float double-float)
(:results (result :scs (#+long-float long-reg #-long-float double-reg)))
(:result-types #+long-float long-float #-long-float double-float)
(:generator 5
(with-empty-tn@fp-top(result)
(inst fldl (make-ea :dword :base sap :index offset)))))
@ -420,13 +420,13 @@
(:args (sap :scs (sap-reg)))
(:arg-types system-area-pointer (:constant (signed-byte 32)))
(:info offset)
(:results (result :scs (#!+long-float long-reg #!-long-float double-reg)))
(:result-types #!+long-float long-float #!-long-float double-float)
(:results (result :scs (#+long-float long-reg #-long-float double-reg)))
(:result-types #+long-float long-float #-long-float double-float)
(:generator 4
(with-empty-tn@fp-top(result)
(inst fldl (make-ea :dword :base sap :disp offset)))))
#!+long-float
#+long-float
(define-vop (%set-sap-ref-long)
(:translate %set-sap-ref-long)
(:policy :fast-safe)

10
src/compiler/x86/vm.lisp
View file

@ -146,11 +146,11 @@
(sap-stack stack) ; System area pointers.
(single-stack stack) ; single-floats
(double-stack stack :element-size 2) ; double-floats.
#!+long-float
#+long-float
(long-stack stack :element-size 3) ; long-floats.
(complex-single-stack stack :element-size 2) ; complex-single-floats
(complex-double-stack stack :element-size 4) ; complex-double-floats
#!+long-float
#+long-float
(complex-long-stack stack :element-size 6) ; complex-long-floats
;;
@ -253,7 +253,7 @@
:alternate-scs (double-stack))
;; non-descriptor LONG-FLOATs
#!+long-float
#+long-float
(long-reg float-registers
:locations (0 1 2 3 4 5 6 7)
:constant-scs (fp-constant)
@ -274,7 +274,7 @@
:save-p t
:alternate-scs (complex-double-stack))
#!+long-float
#+long-float
(complex-long-reg float-registers
:locations (0 2 4 6)
:element-size 2
@ -361,7 +361,7 @@
(case value
((0d0 1d0) fp-constant-sc-number)
(t fp-double-immediate-sc-number)))
#!+long-float
#+long-float
(long-float
(when (or (eql value 0l0) (eql value 1l0)
(eql value pi)