Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
cmucl
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Package Registry
Model registry
Operate
Environments
Terraform modules
Monitor
Incidents
Service Desk
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Carl Shapiro
cmucl
Commits
41b239ec
Commit
41b239ec
authored
34 years ago
by
wlott
Browse files
Options
Downloads
Patches
Plain Diff
Added vm: to all vm specific symbols, 'cause kernel no longers uses vm.
parent
23a610a2
No related branches found
Branches containing commit
No related tags found
Tags containing commit
No related merge requests found
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
code/float.lisp
+107
-104
107 additions, 104 deletions
code/float.lisp
with
107 additions
and
104 deletions
code/float.lisp
+
107
−
104
View file @
41b239ec
...
@@ -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/1
0/14 19:07:15 ram
Exp $
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float.lisp,v 1.
5
1990/1
2/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
)))))
...
...
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment