Skip to content
Snippets Groups Projects
Commit 41b239ec authored by wlott's avatar wlott
Browse files

Added vm: to all vm specific symbols, 'cause kernel no longers uses vm.

parent 23a610a2
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman (FAHLMAN@CMUC). ;;; Scott Fahlman (FAHLMAN@CMUC).
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float.lisp,v 1.4 1990/10/14 19:07:15 ram Exp $ ;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float.lisp,v 1.5 1990/12/02 13:24:07 wlott Exp $
;;; ;;;
;;; This file contains the definitions of float specific number support ;;; This file contains the definitions of float specific number support
;;; (other than irrational stuff, which is in irrat.) There is code in here ;;; (other than irrational stuff, which is in irrat.) There is code in here
...@@ -46,15 +46,15 @@ ...@@ -46,15 +46,15 @@
(declare (type bit sign) (type (unsigned-byte 24) sig) (declare (type bit sign) (type (unsigned-byte 24) sig)
(type (unsigned-byte 8) exp)) (type (unsigned-byte 8) exp))
(make-single-float (make-single-float
(dpb exp single-float-exponent-byte (dpb exp vm:single-float-exponent-byte
(dpb sig single-float-significand-byte (dpb sig vm:single-float-significand-byte
(if (zerop sign) 0 -1))))) (if (zerop sign) 0 -1)))))
;;; ;;;
(defun double-from-bits (sign exp sig) (defun double-from-bits (sign exp sig)
(declare (type bit sign) (type (unsigned-byte 53) sig) (declare (type bit sign) (type (unsigned-byte 53) sig)
(type (unsigned-byte 11) exp)) (type (unsigned-byte 11) exp))
(make-double-float (dpb exp double-float-exponent-byte (make-double-float (dpb exp vm:double-float-exponent-byte
(dpb (ash sig -32) double-float-significand-byte (dpb (ash sig -32) vm:double-float-significand-byte
(if (zerop sign) 0 -1))) (if (zerop sign) 0 -1)))
(ldb (byte 32 0) sig))) (ldb (byte 32 0) sig)))
...@@ -71,63 +71,63 @@ ...@@ -71,63 +71,63 @@
(defconstant least-negative-long-float least-negative-double-float) (defconstant least-negative-long-float least-negative-double-float)
(defconstant least-positive-normalized-single-float (defconstant least-positive-normalized-single-float
(single-from-bits 0 single-float-normal-exponent-min 0)) (single-from-bits 0 vm:single-float-normal-exponent-min 0))
(defconstant least-positive-normalized-short-float (defconstant least-positive-normalized-short-float
least-positive-normalized-single-float) least-positive-normalized-single-float)
(defconstant least-negative-normalized-single-float (defconstant least-negative-normalized-single-float
(single-from-bits 1 single-float-normal-exponent-min 0)) (single-from-bits 1 vm:single-float-normal-exponent-min 0))
(defconstant least-negative-normalized-short-float (defconstant least-negative-normalized-short-float
least-negative-normalized-single-float) least-negative-normalized-single-float)
(defconstant least-positive-normalized-double-float (defconstant least-positive-normalized-double-float
(double-from-bits 0 double-float-normal-exponent-min 0)) (double-from-bits 0 vm:double-float-normal-exponent-min 0))
(defconstant least-positive-normalized-long-float (defconstant least-positive-normalized-long-float
least-positive-normalized-double-float) least-positive-normalized-double-float)
(defconstant least-negative-normalized-double-float (defconstant least-negative-normalized-double-float
(double-from-bits 1 double-float-normal-exponent-min 0)) (double-from-bits 1 vm:double-float-normal-exponent-min 0))
(defconstant least-negative-normalized-long-float (defconstant least-negative-normalized-long-float
least-negative-normalized-double-float) least-negative-normalized-double-float)
(defconstant most-positive-single-float (defconstant most-positive-single-float
(single-from-bits 0 single-float-normal-exponent-max (single-from-bits 0 vm:single-float-normal-exponent-max
(ldb single-float-significand-byte -1))) (ldb vm:single-float-significand-byte -1)))
(defconstant most-positive-short-float most-positive-single-float) (defconstant most-positive-short-float most-positive-single-float)
(defconstant most-negative-single-float (defconstant most-negative-single-float
(single-from-bits 1 single-float-normal-exponent-max (single-from-bits 1 vm:single-float-normal-exponent-max
(ldb single-float-significand-byte -1))) (ldb vm:single-float-significand-byte -1)))
(defconstant most-negative-short-float most-negative-single-float) (defconstant most-negative-short-float most-negative-single-float)
(defconstant most-positive-double-float (defconstant most-positive-double-float
(double-from-bits 0 double-float-normal-exponent-max (double-from-bits 0 vm:double-float-normal-exponent-max
(ldb double-float-significand-byte -1))) (ldb vm:double-float-significand-byte -1)))
(defconstant most-positive-long-float most-positive-double-float) (defconstant most-positive-long-float most-positive-double-float)
(defconstant most-negative-double-float (defconstant most-negative-double-float
(double-from-bits 1 double-float-normal-exponent-max (double-from-bits 1 vm:double-float-normal-exponent-max
(ldb double-float-significand-byte -1))) (ldb vm:double-float-significand-byte -1)))
(defconstant most-negative-long-float most-negative-double-float) (defconstant most-negative-long-float most-negative-double-float)
(defconstant single-float-positive-infinity (defconstant single-float-positive-infinity
(single-from-bits 0 (1+ single-float-normal-exponent-max) 0)) (single-from-bits 0 (1+ vm:single-float-normal-exponent-max) 0))
(defconstant short-float-positive-infinity single-float-positive-infinity) (defconstant short-float-positive-infinity single-float-positive-infinity)
(defconstant single-float-negative-infinity (defconstant single-float-negative-infinity
(single-from-bits 1 (1+ single-float-normal-exponent-max) 0)) (single-from-bits 1 (1+ vm:single-float-normal-exponent-max) 0))
(defconstant short-float-negative-infinity single-float-negative-infinity) (defconstant short-float-negative-infinity single-float-negative-infinity)
(defconstant double-float-positive-infinity (defconstant double-float-positive-infinity
(double-from-bits 0 (1+ double-float-normal-exponent-max) 0)) (double-from-bits 0 (1+ vm:double-float-normal-exponent-max) 0))
(defconstant long-float-positive-infinity double-float-positive-infinity) (defconstant long-float-positive-infinity double-float-positive-infinity)
(defconstant double-float-negative-infinity (defconstant double-float-negative-infinity
(double-from-bits 1 (1+ double-float-normal-exponent-max) 0)) (double-from-bits 1 (1+ vm:double-float-normal-exponent-max) 0))
(defconstant long-float-negative-infinity double-float-negative-infinity) (defconstant long-float-negative-infinity double-float-negative-infinity)
(defconstant single-float-epsilon (defconstant single-float-epsilon
(single-from-bits 0 (- single-float-bias (1- single-float-digits)) 1)) (single-from-bits 0 (- vm:single-float-bias (1- vm:single-float-digits)) 1))
(defconstant short-float-epsilon single-float-epsilon) (defconstant short-float-epsilon single-float-epsilon)
(defconstant single-float-negative-epsilon (defconstant single-float-negative-epsilon
(single-from-bits 0 (- single-float-bias single-float-digits) 1)) (single-from-bits 0 (- vm:single-float-bias vm:single-float-digits) 1))
(defconstant short-float-negative-epsilon single-float-negative-epsilon) (defconstant short-float-negative-epsilon single-float-negative-epsilon)
(defconstant double-float-epsilon (defconstant double-float-epsilon
(double-from-bits 0 (- double-float-bias (1- double-float-digits)) 1)) (double-from-bits 0 (- vm:double-float-bias (1- vm:double-float-digits)) 1))
(defconstant long-float-epsilon double-float-epsilon) (defconstant long-float-epsilon double-float-epsilon)
(defconstant double-float-negative-epsilon (defconstant double-float-negative-epsilon
(double-from-bits 0 (- double-float-bias double-float-digits) 1)) (double-from-bits 0 (- vm:double-float-bias vm:double-float-digits) 1))
(defconstant long-float-negative-epsilon double-float-negative-epsilon) (defconstant long-float-negative-epsilon double-float-negative-epsilon)
...@@ -142,10 +142,11 @@ ...@@ -142,10 +142,11 @@
"Return true if the float X is denormalized." "Return true if the float X is denormalized."
(number-dispatch ((x float)) (number-dispatch ((x float))
((single-float) ((single-float)
(and (zerop (ldb single-float-exponent-byte (single-float-bits x))) (and (zerop (ldb vm:single-float-exponent-byte (single-float-bits x)))
(not (zerop x)))) (not (zerop x))))
((double-float) ((double-float)
(and (zerop (ldb double-float-exponent-byte (double-float-high-bits x))) (and (zerop (ldb vm:double-float-exponent-byte
(double-float-high-bits x)))
(not (zerop x)))))) (not (zerop x))))))
(macrolet ((frob (name doc single double) (macrolet ((frob (name doc single double)
...@@ -154,34 +155,34 @@ ...@@ -154,34 +155,34 @@
(number-dispatch ((x float)) (number-dispatch ((x float))
((single-float) ((single-float)
(let ((bits (single-float-bits x))) (let ((bits (single-float-bits x)))
(and (> (ldb single-float-exponent-byte bits) (and (> (ldb vm:single-float-exponent-byte bits)
single-float-normal-exponent-max) vm:single-float-normal-exponent-max)
,single))) ,single)))
((double-float) ((double-float)
(let ((hi (double-float-high-bits x)) (let ((hi (double-float-high-bits x))
(lo (double-float-low-bits x))) (lo (double-float-low-bits x)))
(and (> (ldb double-float-exponent-byte hi) (and (> (ldb vm:double-float-exponent-byte hi)
double-float-normal-exponent-max) vm:double-float-normal-exponent-max)
,double))))))) ,double)))))))
(frob float-infinity-p "Return true if the float X is an infinity (+ or -)." (frob float-infinity-p "Return true if the float X is an infinity (+ or -)."
(zerop (ldb single-float-significand-byte bits)) (zerop (ldb vm:single-float-significand-byte bits))
(and (zerop (ldb double-float-significand-byte hi)) (and (zerop (ldb vm:double-float-significand-byte hi))
(zerop lo))) (zerop lo)))
(frob float-nan-p "Return true if the float X is a NaN (Not a Number)." (frob float-nan-p "Return true if the float X is a NaN (Not a Number)."
(not (zerop (ldb single-float-significand-byte bits))) (not (zerop (ldb vm:single-float-significand-byte bits)))
(or (not (zerop (ldb double-float-significand-byte hi))) (or (not (zerop (ldb vm:double-float-significand-byte hi)))
(not (zerop lo)))) (not (zerop lo))))
(frob float-trapping-nan-p (frob float-trapping-nan-p
"Return true if the float X is a trapping NaN (Not a Number)." "Return true if the float X is a trapping NaN (Not a Number)."
(not (zerop (logand (ldb single-float-significand-byte bits) (not (zerop (logand (ldb vm:single-float-significand-byte bits)
single-float-trapping-nan-bit))) vm:single-float-trapping-nan-bit)))
(progn (progn
lo; ignore lo; ignore
(not (zerop (logand (ldb double-float-significand-byte hi) (not (zerop (logand (ldb vm:double-float-significand-byte hi)
double-float-trapping-nan-bit)))))) vm:double-float-trapping-nan-bit))))))
;;; FLOAT-PRECISION -- Public ;;; FLOAT-PRECISION -- Public
...@@ -206,10 +207,10 @@ ...@@ -206,10 +207,10 @@
,digits)))) ,digits))))
(number-dispatch ((f float)) (number-dispatch ((f float))
((single-float) ((single-float)
(frob single-float-digits single-float-bias (frob vm:single-float-digits vm:single-float-bias
integer-decode-single-denorm)) integer-decode-single-denorm))
((double-float) ((double-float)
(frob double-float-digits double-float-bias (frob vm:double-float-digits vm:double-float-bias
integer-decode-double-denorm))))) integer-decode-double-denorm)))))
...@@ -222,8 +223,8 @@ ...@@ -222,8 +223,8 @@
(defun float-format-digits (format) (defun float-format-digits (format)
(ecase format (ecase format
((short-float single-float) single-float-digits) ((short-float single-float) vm:single-float-digits)
((double-float long-float) double-float-digits))) ((double-float long-float) vm:double-float-digits)))
(proclaim '(inline float-digits float-radix)) (proclaim '(inline float-digits float-radix))
...@@ -232,8 +233,8 @@ ...@@ -232,8 +233,8 @@
representation of it's argument. See Common Lisp: The Language representation of it's argument. See Common Lisp: The Language
by Guy Steele for more details." by Guy Steele for more details."
(number-dispatch ((f float)) (number-dispatch ((f float))
((single-float) single-float-digits) ((single-float) vm:single-float-digits)
((double-float) double-float-digits))) ((double-float) vm:double-float-digits)))
(defun float-radix (f) (defun float-radix (f)
"Returns (as an integer) the radix b of its floating-point "Returns (as an integer) the radix b of its floating-point
...@@ -255,17 +256,17 @@ ...@@ -255,17 +256,17 @@
(defun integer-decode-single-denorm (x) (defun integer-decode-single-denorm (x)
(declare (type single-float x)) (declare (type single-float x))
(let* ((bits (single-float-bits (abs x))) (let* ((bits (single-float-bits (abs x)))
(sig (ash (ldb single-float-significand-byte bits) 1)) (sig (ash (ldb vm:single-float-significand-byte bits) 1))
(extra-bias 0)) (extra-bias 0))
(declare (type (unsigned-byte 24) sig) (declare (type (unsigned-byte 24) sig)
(type (integer 0 23) extra-bias)) (type (integer 0 23) extra-bias))
(loop (loop
(unless (zerop (logand sig single-float-hidden-bit)) (unless (zerop (logand sig vm:single-float-hidden-bit))
(return)) (return))
(setq sig (ash sig 1)) (setq sig (ash sig 1))
(incf extra-bias)) (incf extra-bias))
(values sig (values sig
(- (- single-float-bias) single-float-digits extra-bias) (- (- vm:single-float-bias) vm:single-float-digits extra-bias)
(if (minusp (float-sign x)) -1 1)))) (if (minusp (float-sign x)) -1 1))))
...@@ -277,19 +278,19 @@ ...@@ -277,19 +278,19 @@
(defun integer-decode-single-float (x) (defun integer-decode-single-float (x)
(declare (single-float x)) (declare (single-float x))
(let* ((bits (single-float-bits (abs x))) (let* ((bits (single-float-bits (abs x)))
(exp (ldb single-float-exponent-byte bits)) (exp (ldb vm:single-float-exponent-byte bits))
(sig (ldb single-float-significand-byte bits)) (sig (ldb vm:single-float-significand-byte bits))
(sign (if (minusp (float-sign x)) -1 1)) (sign (if (minusp (float-sign x)) -1 1))
(biased (- exp single-float-bias single-float-digits))) (biased (- exp vm:single-float-bias vm:single-float-digits)))
(declare (fixnum biased)) (declare (fixnum biased))
(assert (<= exp single-float-normal-exponent-max) () (assert (<= exp vm:single-float-normal-exponent-max) ()
"Can't decode NAN or infinity: ~S." x) "Can't decode NAN or infinity: ~S." x)
(cond ((and (zerop exp) (zerop sig)) (cond ((and (zerop exp) (zerop sig))
(values 0 biased sign)) (values 0 biased sign))
((< exp single-float-normal-exponent-min) ((< exp vm:single-float-normal-exponent-min)
(integer-decode-single-denorm x)) (integer-decode-single-denorm x))
(t (t
(values (logior sig single-float-hidden-bit) biased sign))))) (values (logior sig vm:single-float-hidden-bit) biased sign)))))
;;; INTEGER-DECODE-DOUBLE-DENORM -- Internal ;;; INTEGER-DECODE-DOUBLE-DENORM -- Internal
...@@ -299,27 +300,27 @@ ...@@ -299,27 +300,27 @@
(defun integer-decode-double-denorm (x) (defun integer-decode-double-denorm (x)
(declare (type double-float x)) (declare (type double-float x))
(let* ((high-bits (double-float-high-bits (abs x))) (let* ((high-bits (double-float-high-bits (abs x)))
(sig-high (ldb double-float-significand-byte high-bits)) (sig-high (ldb vm:double-float-significand-byte high-bits))
(low-bits (double-float-low-bits x)) (low-bits (double-float-low-bits x))
(sign (if (minusp (float-sign x)) -1 1)) (sign (if (minusp (float-sign x)) -1 1))
(biased (- (- double-float-bias) double-float-digits))) (biased (- (- vm:double-float-bias) vm:double-float-digits)))
(if (zerop sig-high) (if (zerop sig-high)
(let ((sig low-bits) (let ((sig low-bits)
(extra-bias (- double-float-digits 33)) (extra-bias (- vm:double-float-digits 33))
(bit (ash 1 31))) (bit (ash 1 31)))
(declare (type (unsigned-byte 32) sig) (fixnum extra-bias)) (declare (type (unsigned-byte 32) sig) (fixnum extra-bias))
(loop (loop
(unless (zerop (logand sig bit)) (return)) (unless (zerop (logand sig bit)) (return))
(setq sig (ash sig 1)) (setq sig (ash sig 1))
(incf extra-bias)) (incf extra-bias))
(values (ash sig (- double-float-digits 32)) (values (ash sig (- vm:double-float-digits 32))
(truly-the fixnum (- biased extra-bias)) (truly-the fixnum (- biased extra-bias))
sign)) sign))
(let ((sig (ash sig-high 1)) (let ((sig (ash sig-high 1))
(extra-bias 0)) (extra-bias 0))
(declare (type (unsigned-byte 32) sig) (fixnum extra-bias)) (declare (type (unsigned-byte 32) sig) (fixnum extra-bias))
(loop (loop
(unless (zerop (logand sig double-float-hidden-bit)) (unless (zerop (logand sig vm:double-float-hidden-bit))
(return)) (return))
(setq sig (ash sig 1)) (setq sig (ash sig 1))
(incf extra-bias)) (incf extra-bias))
...@@ -337,21 +338,21 @@ ...@@ -337,21 +338,21 @@
(let* ((abs (abs x)) (let* ((abs (abs x))
(hi (double-float-high-bits abs)) (hi (double-float-high-bits abs))
(lo (double-float-low-bits abs)) (lo (double-float-low-bits abs))
(exp (ldb double-float-exponent-byte hi)) (exp (ldb vm:double-float-exponent-byte hi))
(sig (ldb double-float-significand-byte hi)) (sig (ldb vm:double-float-significand-byte hi))
(sign (if (minusp (float-sign x)) -1 1)) (sign (if (minusp (float-sign x)) -1 1))
(biased (- exp double-float-bias double-float-digits))) (biased (- exp vm:double-float-bias vm:double-float-digits)))
(declare (fixnum biased)) (declare (fixnum biased))
(assert (<= exp double-float-normal-exponent-max) () (assert (<= exp vm:double-float-normal-exponent-max) ()
"Can't decode NAN or infinity: ~S." x) "Can't decode NAN or infinity: ~S." x)
(cond ((and (zerop exp) (zerop sig) (zerop lo)) (cond ((and (zerop exp) (zerop sig) (zerop lo))
(values 0 biased sign)) (values 0 biased sign))
((< exp double-float-normal-exponent-min) ((< exp vm:double-float-normal-exponent-min)
(integer-decode-double-denorm x)) (integer-decode-double-denorm x))
(t (t
(values (values
(logior (ash (logior (ldb double-float-significand-byte hi) (logior (ash (logior (ldb vm:double-float-significand-byte hi)
double-float-hidden-bit) vm:double-float-hidden-bit)
32) 32)
lo) lo)
biased sign))))) biased sign)))))
...@@ -388,9 +389,9 @@ ...@@ -388,9 +389,9 @@
(multiple-value-bind (sig exp sign) (multiple-value-bind (sig exp sign)
(integer-decode-single-denorm x) (integer-decode-single-denorm x)
(values (make-single-float (values (make-single-float
(dpb sig single-float-significand-byte (dpb sig vm:single-float-significand-byte
(dpb single-float-bias single-float-exponent-byte 0))) (dpb vm:single-float-bias vm:single-float-exponent-byte 0)))
(truly-the fixnum (+ exp single-float-digits)) (truly-the fixnum (+ exp vm:single-float-digits))
(float sign x)))) (float sign x))))
...@@ -402,18 +403,20 @@ ...@@ -402,18 +403,20 @@
(defun decode-single-float (x) (defun decode-single-float (x)
(declare (single-float x)) (declare (single-float x))
(let* ((bits (single-float-bits (abs x))) (let* ((bits (single-float-bits (abs x)))
(exp (ldb single-float-exponent-byte bits)) (exp (ldb vm:single-float-exponent-byte bits))
(sign (float-sign x)) (sign (float-sign x))
(biased (truly-the single-float-exponent (- exp single-float-bias)))) (biased (truly-the single-float-exponent (- exp vm:single-float-bias))))
(assert (<= exp single-float-normal-exponent-max) () (assert (<= exp vm:single-float-normal-exponent-max) ()
"Can't decode NAN or infinity: ~S." x) "Can't decode NAN or infinity: ~S." x)
(cond ((zerop x) (cond ((zerop x)
(values 0.0f0 biased sign)) (values 0.0f0 biased sign))
((< exp single-float-normal-exponent-min) ((< exp vm:single-float-normal-exponent-min)
(decode-single-denorm x)) (decode-single-denorm x))
(t (t
(values (make-single-float (values (make-single-float
(dpb single-float-bias single-float-exponent-byte bits)) (dpb vm:single-float-bias
vm:single-float-exponent-byte
bits))
biased sign))))) biased sign)))))
...@@ -426,11 +429,11 @@ ...@@ -426,11 +429,11 @@
(multiple-value-bind (sig exp sign) (multiple-value-bind (sig exp sign)
(integer-decode-double-denorm x) (integer-decode-double-denorm x)
(values (make-double-float (values (make-double-float
(dpb (logand (ash sig -32) (lognot double-float-hidden-bit)) (dpb (logand (ash sig -32) (lognot vm:double-float-hidden-bit))
double-float-significand-byte vm:double-float-significand-byte
(dpb double-float-bias double-float-exponent-byte 0)) (dpb vm:double-float-bias vm:double-float-exponent-byte 0))
(ldb (byte 32 0) sig)) (ldb (byte 32 0) sig))
(truly-the fixnum (+ exp double-float-digits)) (truly-the fixnum (+ exp vm:double-float-digits))
(float sign x)))) (float sign x))))
...@@ -443,18 +446,18 @@ ...@@ -443,18 +446,18 @@
(let* ((abs (abs x)) (let* ((abs (abs x))
(hi (double-float-high-bits abs)) (hi (double-float-high-bits abs))
(lo (double-float-low-bits abs)) (lo (double-float-low-bits abs))
(exp (ldb double-float-exponent-byte hi)) (exp (ldb vm:double-float-exponent-byte hi))
(sign (float-sign x)) (sign (float-sign x))
(biased (truly-the double-float-exponent (- exp double-float-bias)))) (biased (truly-the double-float-exponent (- exp vm:double-float-bias))))
(assert (<= exp double-float-normal-exponent-max) () (assert (<= exp vm:double-float-normal-exponent-max) ()
"Can't decode NAN or infinity: ~S." x) "Can't decode NAN or infinity: ~S." x)
(cond ((zerop x) (cond ((zerop x)
(values 0.0d0 biased sign)) (values 0.0d0 biased sign))
((< exp double-float-normal-exponent-min) ((< exp vm:double-float-normal-exponent-min)
(decode-double-denorm x)) (decode-double-denorm x))
(t (t
(values (make-double-float (values (make-double-float
(dpb double-float-bias double-float-exponent-byte hi) (dpb vm:double-float-bias vm:double-float-exponent-byte hi)
lo) lo)
biased sign))))) biased sign)))))
...@@ -491,22 +494,22 @@ ...@@ -491,22 +494,22 @@
(let* ((digits (float-digits x)) (let* ((digits (float-digits x))
(new-exp (+ exp old-exp digits (new-exp (+ exp old-exp digits
(etypecase x (etypecase x
(single-float single-float-bias) (single-float vm:single-float-bias)
(double-float double-float-bias)))) (double-float vm:double-float-bias))))
(sign (if (minusp (float-sign x)) 1 0))) (sign (if (minusp (float-sign x)) 1 0)))
(cond (cond
((< new-exp ((< new-exp
(etypecase x (etypecase x
(single-float single-float-normal-exponent-min) (single-float vm:single-float-normal-exponent-min)
(double-float double-float-normal-exponent-min))) (double-float vm:double-float-normal-exponent-min)))
(when (and (not (float-denormalized-p x)) (when (and (not (float-denormalized-p x))
(current-float-trap :inexact)) (vm:current-float-trap :inexact))
(error 'floating-point-inexact :operation 'scale-float (error 'floating-point-inexact :operation 'scale-float
:operands (list x exp))) :operands (list x exp)))
(let ((shift (1- new-exp))) (let ((shift (1- new-exp)))
(cond (cond
((< shift (- (1- digits))) ((< shift (- (1- digits)))
(when (current-float-trap :underflow) (when (vm:current-float-trap :underflow)
(error 'floating-point-underflow :operation 'scale-float (error 'floating-point-underflow :operation 'scale-float
:operands (list x exp))) :operands (list x exp)))
(float-sign x 0.0)) (float-sign x 0.0))
...@@ -533,15 +536,15 @@ ...@@ -533,15 +536,15 @@
x) x)
((float-nan-p x) ((float-nan-p x)
(when (and (float-trapping-nan-p x) (when (and (float-trapping-nan-p x)
(current-float-trap :invalid)) (vm:current-float-trap :invalid))
(error 'floating-point-invalid :operation 'scale-float (error 'floating-point-invalid :operation 'scale-float
:operands (list x exp))) :operands (list x exp)))
x) x)
(t (t
(when (current-float-trap :overflow) (when (vm:current-float-trap :overflow)
(error 'floating-point-overflow :operation 'scale-float (error 'floating-point-overflow :operation 'scale-float
:operands (list x exp))) :operands (list x exp)))
(when (current-float-trap :inexact) (when (vm:current-float-trap :inexact)
(error 'floating-point-inexact :operation 'scale-float (error 'floating-point-inexact :operation 'scale-float
:operands (list x exp))) :operands (list x exp)))
(* (float-sign x) (* (float-sign x)
...@@ -558,35 +561,35 @@ ...@@ -558,35 +561,35 @@
(defun scale-single-float (x exp) (defun scale-single-float (x exp)
(declare (single-float x) (fixnum exp)) (declare (single-float x) (fixnum exp))
(let* ((bits (single-float-bits x)) (let* ((bits (single-float-bits x))
(old-exp (ldb single-float-exponent-byte bits)) (old-exp (ldb vm:single-float-exponent-byte bits))
(new-exp (+ old-exp exp))) (new-exp (+ old-exp exp)))
(cond (cond
((zerop x) x) ((zerop x) x)
((or (< old-exp single-float-normal-exponent-min) ((or (< old-exp vm:single-float-normal-exponent-min)
(< new-exp single-float-normal-exponent-min)) (< new-exp vm:single-float-normal-exponent-min))
(scale-float-maybe-underflow x exp)) (scale-float-maybe-underflow x exp))
((or (> old-exp single-float-normal-exponent-max) ((or (> old-exp vm:single-float-normal-exponent-max)
(> new-exp single-float-normal-exponent-max)) (> new-exp vm:single-float-normal-exponent-max))
(scale-float-maybe-overflow x exp)) (scale-float-maybe-overflow x exp))
(t (t
(make-single-float (dpb new-exp single-float-exponent-byte bits)))))) (make-single-float (dpb new-exp vm:single-float-exponent-byte bits))))))
;;; ;;;
(defun scale-double-float (x exp) (defun scale-double-float (x exp)
(declare (double-float x) (fixnum exp)) (declare (double-float x) (fixnum exp))
(let* ((hi (double-float-high-bits x)) (let* ((hi (double-float-high-bits x))
(lo (double-float-low-bits x)) (lo (double-float-low-bits x))
(old-exp (ldb double-float-exponent-byte hi)) (old-exp (ldb vm:double-float-exponent-byte hi))
(new-exp (+ old-exp exp))) (new-exp (+ old-exp exp)))
(cond (cond
((zerop x) x) ((zerop x) x)
((or (< old-exp double-float-normal-exponent-min) ((or (< old-exp vm:double-float-normal-exponent-min)
(< new-exp double-float-normal-exponent-min)) (< new-exp vm:double-float-normal-exponent-min))
(scale-float-maybe-underflow x exp)) (scale-float-maybe-underflow x exp))
((or (> old-exp double-float-normal-exponent-max) ((or (> old-exp vm:double-float-normal-exponent-max)
(> new-exp double-float-normal-exponent-max)) (> new-exp vm:double-float-normal-exponent-max))
(scale-float-maybe-overflow x exp)) (scale-float-maybe-overflow x exp))
(t (t
(make-double-float (dpb new-exp double-float-exponent-byte hi) (make-double-float (dpb new-exp vm:double-float-exponent-byte hi)
lo))))) lo)))))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment