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
773badcd
Commit
773badcd
authored
28 years ago
by
pw
Browse files
Options
Downloads
Patches
Plain Diff
initial post 1.3.7 merge
parent
824b7e1e
No related branches found
No related tags found
No related merge requests found
Changes
3
Hide whitespace changes
Inline
Side-by-side
Showing
3 changed files
compiler/float-tran.lisp
+81
-41
81 additions, 41 deletions
compiler/float-tran.lisp
compiler/main.lisp
+41
-33
41 additions, 33 deletions
compiler/main.lisp
compiler/srctran.lisp
+202
-119
202 additions, 119 deletions
compiler/srctran.lisp
with
324 additions
and
193 deletions
compiler/float-tran.lisp
+
81
−
41
View file @
773badcd
...
...
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.2
4
1997/0
1/18 14:31:35 ram
Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.2
5
1997/0
2/05 15:41:50 pw
Exp $"
)
;;;
;;; **********************************************************************
;;;
...
...
@@ -237,6 +237,8 @@
(
frob
scale-single-float
)
(
frob
scale-double-float
))
;;; toy@rtp.ericsson.se:
;;;
;;; Defoptimizers for %single-float and %double-float. This makes the
;;; FLOAT function return the correct ranges if the input has some
;;; defined range. Quite useful if we want to convert some time of
...
...
@@ -450,11 +452,27 @@
(
deftransform
name
((
x
y
)
'
(
double-float
double-float
)
rtype
:eval-name
t
:when
:both
)
`
(
,
prim
x
y
))))
#+
nil
(
deftransform
log
((
x
y
)
(
float
float
)
float
)
'
(
/
(
log
x
)
(
log
y
)))
;;; ANSI says log with base zero returns zero.
(
deftransform
log
((
x
y
)
(
float
float
)
float
)
'
(
if
(
zerop
y
)
y
(
/
(
log
x
)
(
log
y
))))
;;; Return the float format of the result of an elementary function.
;;; If the format is NIL (which means type FLOAT), we return NIL. If
;;; the format is 'DOUBLE-FLOAT, we return that. For any other case,
;;; we return 'SINGLE-FLOAT.
(
proclaim
'
(
inline
elfun-format
numeric-type-real-p
))
(
defun
elfun-float-format
(
format
)
(
if
format
(
if
(
eq
format
'double-float
)
'double-float
'single-float
)))
#+
propagate-fun-type
(
progn
;;;; Optimizers for elementary functions
...
...
@@ -487,18 +505,6 @@
(
float
0
x
)))
;;; Return the float format of the result of an elementary function.
;;; If the format is NIL (which means type FLOAT), we return NIL. If
;;; the format is 'DOUBLE-FLOAT, we return that. For any other case,
;;; we return 'SINGLE-FLOAT.
(
proclaim
'
(
inline
elfun-format
numeric-type-real-p
))
(
defun
elfun-float-format
(
format
)
(
if
format
(
if
(
eq
format
'double-float
)
'double-float
'single-float
)))
;;; The number is of type REAL.
(
defun
numeric-type-real-p
(
type
)
...
...
@@ -520,20 +526,40 @@
(
defmacro
elfun-derive-type
(
num
cond
limit-fun
)
(
let
((
type
(
gensym
))
(
lo-lim
(
gensym
))
(
hi-lim
(
gensym
)))
(
hi-lim
(
gensym
))
(
fp-mode
(
gensym
)))
`
(
let
((
,
type
(
continuation-type
,
num
)))
(
when
(
numeric-type-real-p
,
type
)
(
let
((
lo
(
numeric-type-low
,
type
))
(
hi
(
numeric-type-high
,
type
)))
(
when
,
cond
(
multiple-value-bind
(
,
lo-lim
,
hi-lim
)
(
funcall
,
limit-fun
lo
hi
)
(
make-numeric-type
:class
'float
:format
(
elfun-float-format
(
numeric-type-format
,
type
))
:complexp
:real
:low
,
lo-lim
:high
,
hi-lim
))))))))
(
let
((
,
fp-mode
(
get-floating-point-modes
)))
(
unwind-protect
(
progn
;; Disable all traps except for :invalid. We
;; want standard IEEE handling to return the
;; appropriate value which we will handle later.
;; However, for :invalid, there's probably
;; nothing we can do about it. We don't need to
;; do anything else because we don't check any
;; other flags and they get restored later.
(
set-floating-point-modes
:traps
'
(
:invalid
))
;; The call to the limit-fun has (most) traps
;; disabled. It can naively compute the result,
;; but it must call set-bound to make sure any
;; overflow is converted to NIL appropriately.
(
multiple-value-bind
(
,
lo-lim
,
hi-lim
)
(
funcall
,
limit-fun
lo
hi
)
(
make-numeric-type
:class
'float
:format
(
elfun-float-format
(
numeric-type-format
,
type
))
:complexp
:real
:low
,
lo-lim
:high
,
hi-lim
)))
;; Restore the floating-point modes
(
apply
#'
set-floating-point-modes
,
fp-mode
)
))))))))
;;; Handle these monotonic increasing functions whose domain is
;;; possibly part of the real line
...
...
@@ -732,24 +758,38 @@
(
multiple-value-bind
(
lo
hi
)
(
extract-bounds
type
)
(
let*
((
max-bnd
(
max-bound
(
bound-abs
lo
)
(
bound-abs
hi
)))
(
min-bnd
(
min-bound
(
bound-abs
lo
)
(
bound-abs
hi
))))
(
make-numeric-type
:class
'float
:format
(
elfun-float-format
(
numeric-type-format
type
))
:complexp
:real
:low
(
if
(
and
(
bound-<
lo
0
)
(
bound-<
0
hi
))
;; If zero is in the input domain, then the lower
;; bound is cosh(0). Otherwise it's the min of
;; the bounds.
1
(
if
(
symbolp
min-bnd
)
nil
(
set-bound
(
cosh
(
bound-value
min-bnd
))
(
consp
min-bnd
))))
:high
(
if
(
symbolp
max-bnd
)
nil
(
set-bound
(
cosh
(
bound-value
max-bnd
))
(
consp
max-bnd
)))))))))
(
min-bnd
(
min-bound
(
bound-abs
lo
)
(
bound-abs
hi
)))
(
fp-modes
(
get-floating-point-modes
)))
(
unwind-protect
(
progn
;; Disable all traps except for :invalid. We want
;; standard IEEE handling to return the appropriate
;; value which we will handle later. However, for
;; :invalid, there's probably nothing we can do about
;; it. We don't need to do anything else because we
;; don't check any other flags and they get restored
;; later.
(
set-floating-point-modes
:traps
'
(
:invalid
))
(
make-numeric-type
:class
'float
:format
(
elfun-float-format
(
numeric-type-format
type
))
:complexp
:real
:low
(
if
(
and
(
bound-<
lo
0
)
(
bound-<
0
hi
))
;; If zero is in the input domain, then the lower
;; bound is cosh(0). Otherwise it's the min of
;; the bounds.
1
(
if
(
symbolp
min-bnd
)
nil
(
set-bound
(
cosh
(
bound-value
min-bnd
))
(
consp
min-bnd
))))
:high
(
if
(
symbolp
max-bnd
)
nil
(
set-bound
(
cosh
(
bound-value
max-bnd
))
(
consp
max-bnd
)))))
;; Restore the floating-point modes
(
apply
#'
set-floating-point-modes
fp-modes
)))))))
(
defoptimizer
(
phase
derive-type
)
((
num
))
(
let
((
type
(
continuation-type
num
)))
...
...
This diff is collapsed.
Click to expand it.
compiler/main.lisp
+
41
−
33
View file @
773badcd
...
...
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/main.lisp,v 1.10
8
1997/0
1/18 14:31:32 ram
Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/main.lisp,v 1.10
9
1997/0
2/05 15:41:53 pw
Exp $"
)
;;;
;;; **********************************************************************
;;;
...
...
@@ -235,12 +235,20 @@
(
maybe-mumble
"Constraint "
)
(
constraint-propagate
component
))
(
maybe-mumble
"Type "
)
(
generate-type-checks
component
)
(
unless
(
or
(
component-reoptimize
component
)
(
component-reanalyze
component
)
(
component-new-functions
component
)
(
component-reanalyze-functions
component
))
(
return
))
;; Delay the generation of type checks until the type
;; constraints have had time to propagate, else the compiler can
;; confuse itself.
(
unless
(
and
(
or
(
component-reoptimize
component
)
(
component-reanalyze
component
)
(
component-new-functions
component
)
(
component-reanalyze-functions
component
))
(
<
loop-count
(
-
*reoptimize-after-type-check-max*
2
)))
(
generate-type-checks
component
)
(
unless
(
or
(
component-reoptimize
component
)
(
component-reanalyze
component
)
(
component-new-functions
component
)
(
component-reanalyze-functions
component
))
(
return
)))
(
when
(
>=
loop-count
*reoptimize-after-type-check-max*
)
(
maybe-mumble
"[Reoptimize Limit]"
)
(
event
reoptimize-maxed-out
)
...
...
@@ -1541,23 +1549,23 @@
;;; exist.
;;;
(
defun
verify-source-files
(
stuff
)
(
unless
stuff
(
error
"Can't compile with no source files."
))
(
mapcar
#'
(
lambda
(
x
)
(
let
((
x
(
pathname
x
))
)
(
if
(
probe-file
x
)
x
(
let
((
y
(
merge-pathnames
x
(
make-pathname
:type
"lisp"
))))
(
if
(
probe-file
y
)
y
(
let
((
z
(
merge-
pathname
s
x
(
make-pathname
:type
"dylan"
))
))
(
if
(
probe-file
z
)
z
(
tr
uename
y
))))))
))
(
if
(
listp
stuff
)
stuff
(
list
stuff
))))
(
flet
((
try-with-type
(
path
type
error-p
)
(
let
((
new
(
merge-pathnames
path
(
make-pathname
:type
type
:defaults
path
)))
)
(
if
(
probe-file
new
)
new
(
and
error-p
(
truename
new
))))))
(
unless
stuff
(
error
"Can't compile with no source files."
)
)
(
mapcar
#'
(
lambda
(
x
)
(
let
((
x
(
pathname
x
)))
(
cond
((
logical-pathname-p
x
)
(
try-with-type
x
"LISP"
t
))
(
(
probe-file
x
)
x
)
((
try-with-type
x
"lisp"
nil
))
(
(
tr
y-with-type
x
"dylan"
nil
))
((
try-with-type
x
"lisp"
t
)
))))
(
if
(
listp
stuff
)
stuff
(
list
stuff
)))))
;;; COMPILE-FROM-STREAM -- Public
;;;
...
...
@@ -1712,22 +1720,23 @@
(
error-severity
nil
)
(
source
(
verify-source-files
source
))
(
source-info
(
make-file-source-info
source
))
(
default
(
pathname
(
first
source
)))
(
diddle-case
(
logical-pathname-p
(
pathname
default
))))
(
default
(
pathname
(
first
source
))))
(
unwind-protect
(
progn
(
flet
((
frob
(
file
type
)
(
if
(
eq
file
t
)
(
make-pathname
:type
(
lisp::maybe-diddle-case
type
diddle-case
)
:defaults
default
)
(
make-pathname
:type
type
:defaults
(
if
(
logical-pathname-p
default
)
(
translate-logical-pathname
default
)
default
))
(
pathname
file
))))
(
when
output-file
(
setq
output-file-name
(
frob
output-file
(
if
(
eq
*byte-compile*
t
)
(
backend-byte-fasl-file-type
*backend*
)
(
backend-fasl-file-type
*backend*
))))
(
compile-file-pathname
(
first
source
)
:output-file
output-file
:byte-compile
*byte-compile*
))
(
setq
fasl-file
(
open-fasl-file
output-file-name
(
namestring
(
first
source
))
(
eq
*byte-compile*
t
))))
...
...
@@ -1794,7 +1803,6 @@
nil
)
(
not
(
null
error-severity
))
(
if
(
member
error-severity
'
(
:warning
:error
))
t
nil
))))
;;;; COMPILE and UNCOMPILE:
...
...
This diff is collapsed.
Click to expand it.
compiler/srctran.lisp
+
202
−
119
View file @
773badcd
...
...
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.4
6
1997/0
1/18 14:31:30 ram
Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.4
7
1997/0
2/05 15:41:57 pw
Exp $"
)
;;;
;;; **********************************************************************
;;;
...
...
@@ -396,9 +396,12 @@
b
))
(
defun
set-bound
(
val
exclusive
)
(
if
exclusive
`
(
,
val
)
val
))
(
if
(
and
(
floatp
val
)
(
float-infinity-p
val
))
nil
(
if
exclusive
`
(
,
val
)
val
)))
(
defun
bound-<
(
x
y
)
(
cond
((
eq
x
'pos-inf
)
...
...
@@ -775,7 +778,7 @@
nil
))))))))
;; ;; bugged below??
#-propagate-float-type
)
#-
propagate-float-type
(
defoptimizer
(
truncate
derive-type
)
((
number
divisor
))
(
let
((
number-type
(
continuation-type
number
))
(
divisor-type
(
continuation-type
divisor
))
...
...
@@ -797,34 +800,56 @@
#+
propagate-float-type
(
progn
#+
nil
(
defoptimizer
(
truncate
derive-type
)
((
number
divisor
))
(
let
((
number-type
(
continuation-type
number
))
(
divisor-type
(
continuation-type
divisor
))
(
integer
-type
(
specifier-type
'
(
or
integer
real
))))
(
real
-type
(
specifier-type
'
(
or
integer
real
))))
(
if
(
and
(
numeric-type-p
number-type
)
(
csubtypep
number-type
integer
-type
)
(
csubtypep
number-type
real
-type
)
(
numeric-type-p
divisor-type
)
(
csubtypep
divisor-type
integer
-type
))
(
csubtypep
divisor-type
real
-type
))
(
let
((
number-low
(
numeric-type-low
number-type
))
(
number-high
(
numeric-type-high
number-type
))
(
divisor-low
(
numeric-type-low
divisor-type
))
(
divisor-high
(
numeric-type-high
divisor-type
)))
(
setf
number-low
(
if
(
consp
number-low
)
(
car
number-low
)
number-low
))
(
setf
number-high
(
if
(
consp
number-high
)
(
car
number-high
)
number-high
))
(
setf
divisor-low
(
if
(
consp
divisor-low
)
(
car
divisor-low
)
divisor-low
))
(
setf
divisor-high
(
if
(
consp
divisor-high
)
(
car
divisor-high
)
divisor-high
))
(
if
(
csubtypep
number-type
(
specifier-type
'integer
))
(
setf
number-low
(
if
(
consp
number-low
)
(
car
number-low
)
number-low
))
(
setf
number-high
(
if
(
consp
number-high
)
(
car
number-high
)
number-high
))
(
setf
divisor-low
(
if
(
consp
divisor-low
)
(
car
divisor-low
)
divisor-low
))
(
setf
divisor-high
(
if
(
consp
divisor-high
)
(
car
divisor-high
)
divisor-high
))
(
if
(
and
(
csubtypep
number-type
(
specifier-type
'integer
))
(
csubtypep
divisor-type
(
specifier-type
'integer
)))
;; If both the number and the divisor are integers of
;; some type, then both results of truncate are
;; integers. Figure out the appropriate ranges of the
;; results.
(
values-specifier-type
`
(
values
,
(
integer-truncate-derive-type
number-low
number-high
divisor-low
divisor-high
)
,
(
integer-rem-derive-type
number-low
number-high
divisor-low
divisor-high
)))
`
(
values
,
(
integer-truncate-derive-type
number-low
number-high
divisor-low
divisor-high
divisor-type
)
,
(
integer-rem-derive-type
number-low
number-high
divisor-low
divisor-high
)))
;; Otherwise, the first result of truncate is an integer
;; and the second result is a float of some type.
;; Figure out the ranges of the results and their
;; appropriate types.
(
values-specifier-type
`
(
values
,
(
integer-truncate-derive-type
number-low
number-high
divisor-low
divisor-high
)
,
(
real-rem-derive-type
number-low
number-high
divisor-low
divisor-high
)))))
`
(
values
,
(
integer-truncate-derive-type
number-low
number-high
divisor-low
divisor-high
divisor-type
)
,
(
real-rem-derive-type
number-low
number-high
divisor-low
divisor-high
number-type
divisor-type
)))))
*universal-type*
)))
(
defoptimizer
(
%unary-truncate
derive-type
)
((
number
))
...
...
@@ -832,12 +857,19 @@
(
if
(
and
(
numeric-type-p
number-type
)
(
csubtypep
number-type
(
specifier-type
'real
)))
(
let
((
number-low
(
numeric-type-low
number-type
))
(
number-high
(
numeric-type-high
number-type
)))
(
setf
number-low
(
if
(
consp
number-low
)
(
car
number-low
)
number-low
))
(
setf
number-high
(
if
(
consp
number-high
)
(
car
number-high
)
number-high
))
(
values-specifier-type
`
(
values
,
(
integer-truncate-derive-type
number-low
number-high
1
1
)
,
(
real-rem-derive-type
number-low
number-high
1
1
))))
(
number-high
(
numeric-type-high
number-type
))
(
divisor
(
make-numeric-type
:class
'integer
:low
1
:high
1
)))
(
setf
number-low
(
if
(
consp
number-low
)
(
car
number-low
)
number-low
))
(
setf
number-high
(
if
(
consp
number-high
)
(
car
number-high
)
number-high
))
(
specifier-type
`,
(
integer-truncate-derive-type
number-low
number-high
1
1
divisor
)))
*universal-type*
)))
)
...
...
@@ -924,7 +956,7 @@
;; The number we are dividing is unbounded, so we can't tell
;; anything about the result.
'integer
)))))
(
defun
integer-rem-derive-type
(
number-low
number-high
divisor-low
divisor-high
)
(
if
(
and
divisor-low
divisor-high
)
...
...
@@ -957,101 +989,152 @@
#+
propagate-float-type
(
progn
(
defun
integer-truncate-derive-type
(
number-low
number-high
divisor-low
divisor-high
)
(
number-low
number-high
divisor-low
divisor-high
divisor-type
)
;; The result cannot be larger in magnitude than the number, but the sign
;; might change. If we can determine the sign of either the number or
;; the divisor, we can eliminate some of the cases.
(
multiple-value-bind
(
number-sign
number-min
number-max
)
(
numeric-range-info
number-low
number-high
)
(
macrolet
((
maybe*
(
form
)
;; return result of form or * if overflow occurs
`
(
handler-case
,
form
(
arithmetic-error
()
'*
))))
(
multiple-value-bind
(
divisor-sign
divisor-min
divisor-max
)
(
numeric-range-info
divisor-low
divisor-high
)
(
when
(
and
divisor-max
(
zerop
divisor-max
))
;; We've got a problem: guarenteed division by zero.
(
return-from
integer-truncate-derive-type
t
))
(
when
(
zerop
divisor-min
)
;; We'll assume that they arn't going to divide by zero.
(
if
(
integerp
divisor-min
)
(
incf
divisor-min
)
(
incf
divisor-min
(
if
(
typep
divisor-min
'single-float
)
least-positive-normalized-single-float
least-positive-normalized-double-float
))))
(
cond
((
and
number-sign
divisor-sign
)
;; We know the sign of both.
(
if
(
eq
number-sign
divisor-sign
)
;; Same sign, so the result will be positive.
`
(
integer
,
(
if
divisor-max
(
truncate
number-min
divisor-max
)
0
)
,
(
if
number-max
(
truncate
number-max
divisor-min
)
'*
))
;; Different signs, the result will be negative.
`
(
integer
,
(
if
number-max
(
-
(
truncate
number-max
divisor-min
))
'*
)
,
(
if
divisor-max
(
-
(
truncate
number-min
divisor-max
))
0
))))
((
eq
divisor-sign
'+
)
;; The divisor is positive. Therefore, the number will just
;; become closer to zero.
`
(
integer
,
(
if
number-low
(
truncate
number-low
divisor-min
)
'*
)
,
(
if
number-high
(
truncate
number-high
divisor-min
)
'*
)))
((
eq
divisor-sign
'-
)
;; The divisor is negative. Therefore, the absolute value of
;; the number will become closer to zero, but the sign will also
;; change.
`
(
integer
,
(
if
number-high
(
-
(
truncate
number-high
divisor-min
))
'*
)
,
(
if
number-low
(
-
(
truncate
number-low
divisor-min
))
'*
)))
;; The divisor could be either positive or negative.
(
number-max
;; The number we are dividing has a bound. Divide that by the
;; smallest posible divisor.
(
let
((
bound
(
truncate
number-max
divisor-min
)))
`
(
integer
,
(
-
bound
)
,
bound
)))
(
t
;; The number we are dividing is unbounded, so we can't tell
;; anything about the result.
'integer
)))))
(
number-sign
number-min
number-max
)
(
numeric-range-info
number-low
number-high
)
(
multiple-value-bind
(
divisor-sign
divisor-min
divisor-max
)
(
numeric-range-info
divisor-low
divisor-high
)
(
when
(
and
divisor-max
(
zerop
divisor-max
))
;; We've got a problem: guarenteed division by zero.
(
return-from
integer-truncate-derive-type
t
))
(
when
(
zerop
divisor-min
)
;; We'll assume that they aren't going to divide by zero. Set
;; divisor min to be the smallest positive number of the
;; appropriate type. (Does this really make sense for floats?
;; Let's go with it for now.)
(
setf
divisor-min
(
cond
((
csubtypep
divisor-type
(
specifier-type
'integer
))
1
)
((
csubtypep
divisor-type
(
specifier-type
'double-float
))
least-positive-normalized-double-float
)
((
csubtypep
divisor-type
(
specifier-type
'real
))
least-positive-normalized-single-float
)
(
t
(
cerror
"Return INTEGER as result of truncate"
"This should not have happened!"
)
(
return-from
integer-truncate-derive-type
t
)))))
(
cond
((
and
number-sign
divisor-sign
)
;; We know the sign of both.
(
if
(
eq
number-sign
divisor-sign
)
;; Same sign, so the result will be positive.
`
(
integer
,
(
if
divisor-max
(
maybe*
(
truncate
number-min
divisor-max
))
0
)
,
(
if
number-max
(
maybe*
(
truncate
number-max
divisor-min
))
'*
))
;; Different signs, the result will be negative.
`
(
integer
,
(
if
number-max
(
maybe*
(
-
(
truncate
number-max
divisor-min
)))
'*
)
,
(
if
divisor-max
(
maybe*
(
-
(
truncate
number-min
divisor-max
)))
0
))))
((
eq
divisor-sign
'+
)
;; The divisor is positive. Therefore, the number will just
;; become closer to zero.
`
(
integer
,
(
if
number-low
(
maybe*
(
truncate
number-low
divisor-min
))
'*
)
,
(
if
number-high
(
maybe*
(
truncate
number-high
divisor-min
))
'*
)))
((
eq
divisor-sign
'-
)
;; The divisor is negative. Therefore, the absolute value of
;; the number will become closer to zero, but the sign will also
;; change.
`
(
integer
,
(
if
number-high
(
maybe*
(
-
(
truncate
number-high
divisor-min
)))
'*
)
,
(
if
number-low
(
maybe*
(
-
(
truncate
number-low
divisor-min
)))
'*
)))
;; The divisor could be either positive or negative.
(
number-max
;; The number we are dividing has a bound. Divide that by the
;; smallest posible divisor.
(
let
((
bound
(
maybe*
(
truncate
number-max
divisor-min
))))
(
if
(
numberp
bound
)
`
(
integer
,
(
-
bound
)
,
bound
)
`
integer
)))
(
t
;; The number we are dividing is unbounded, so we can't tell
;; anything about the result.
'integer
))))))
;;; This probably needs a lot of reworking to make sure everything is
;;; covered.
(
defun
real-rem-derive-type
(
number-low
number-high
divisor-low
divisor-high
)
(
if
(
and
divisor-low
divisor-high
)
;; We know the range of the divisor, and the remainder must be smaller
;; than the divisor. We can tell the sign of the remainer if we know
;; the sign of the number.
(
let
((
divisor-max
(
float
(
max
(
abs
divisor-low
)
(
abs
divisor-high
)))))
`
(
float
,
(
if
(
or
(
null
number-low
)
(
minusp
number-low
))
(
-
divisor-max
)
0.0
)
,
(
if
(
or
(
null
number-high
)
(
plusp
number-high
))
divisor-max
0.0
)))
;; The divisor is potentially either very positive or very negative.
;; Therefore, the remainer is unbounded, but we might be able to tell
;; something about the sign from the number.
`
(
float
,
(
if
(
and
number-low
(
not
(
minusp
number-low
)))
;; The number we are dividing is positive. Therefore,
;; the remainder must be positive.
0.0
'*
)
,
(
if
(
and
number-high
(
not
(
plusp
number-high
)))
;; The number we are dividing is negative. Therefore,
;; the remainder must be negative.
0.0
'*
))))
(
number-low
number-high
divisor-low
divisor-high
number-type
divisor-type
)
;; First figure out what the type of the result should be.
(
let*
((
result-type
(
cond
((
csubtypep
number-type
(
specifier-type
'integer
))
;; If NUMBER is an integer, the result must be the
;; type of the divisor. A numeric-type-format of nil
;; means either REAL or COMPLEX, but we know at this
;; point the numbers are not complex.
(
or
(
numeric-type-format
divisor-type
)
'real
))
((
csubtypep
divisor-type
(
specifier-type
'integer
))
;; The divisor is an integer, so the result must be
;; the type of the number.
(
or
(
numeric-type-format
number-type
)
'real
))
(
t
;; Hmm, neither are integers, so we take the largest format
(
or
(
float-format-max
(
numeric-type-format
number-type
)
(
numeric-type-format
divisor-type
))
'real
)))))
;; Without the following sexp, RESULT-TYPE can sometimes be NIL!
;; How can that be? The above code looks like it always returns
;; something besides nil!
(
unless
result-type
(
setf
result-type
'real
)
(
cerror
"Use REAL as result type"
"Shouldn't happen! Result type was NIL"
))
(
if
(
and
divisor-low
divisor-high
)
;; We know the range of the divisor, and the remainder must be smaller
;; than the divisor. We can tell the sign of the remainer if we know
;; the sign of the number.
(
let
((
divisor-max
(
float
(
max
(
abs
divisor-low
)
(
abs
divisor-high
)))))
`
(
,
result-type
,
(
coerce
(
if
(
or
(
null
number-low
)
(
minusp
number-low
))
(
-
divisor-max
)
0.0
)
result-type
)
,
(
coerce
(
if
(
or
(
null
number-high
)
(
plusp
number-high
))
divisor-max
0.0
)
result-type
)))
;; The divisor is potentially either very positive or very negative.
;; Therefore, the remainer is unbounded, but we might be able to tell
;; something about the sign from the number.
`
(
,
result-type
,
(
if
(
and
number-low
(
not
(
minusp
number-low
)))
;; The number we are dividing is positive.
;; Therefore, the remainder must be
;; positive.
(
coerce
0.0
result-type
)
'*
)
,
(
if
(
and
number-high
(
not
(
plusp
number-high
)))
;; The number we are dividing is negative.
;; Therefore, the remainder must be
;; negative.
(
coerce
0.0
result-type
)
'*
)))))
)
(
defoptimizer
(
random
derive-type
)
((
bound
&optional
state
))
...
...
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