Commit 7a8c3cb4 authored by ram's avatar ram
Browse files

Change from loop to destructuring-bind, use the real REAL type now that we have

it.
parent 9cb3a53d
......@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.12 1991/11/12 16:07:14 ram Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.13 1992/08/05 00:43:49 ram Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -228,21 +228,20 @@
;;; Derive the result to be float for argument types in the appropriate domain.
;;;
;;;### These should really be REAL, not FLOAT...
(loop for (name type) in
'((asin (float (-1.0) (1.0)))
(acos (float (-1.0) (1.0)))
(acosh (float 1.0))
(atanh (float (-1.0) (1.0)))
(sqrt (float 0.0))) do
(let ((type (specifier-type type)))
(setf (function-info-derive-type (function-info-or-lose name))
#'(lambda (call)
(declare (type combination call))
(when (csubtypep (continuation-type
(first (combination-args call)))
type)
(specifier-type 'float))))))
(dolist (stuff '((asin (real (-1.0) (1.0)))
(acos (real (-1.0) (1.0)))
(acosh (real 1.0))
(atanh (real (-1.0) (1.0)))
(sqrt (real 0.0))))
(destructuring-bind (name type) stuff
(let ((type (specifier-type type)))
(setf (function-info-derive-type (function-info-or-lose name))
#'(lambda (call)
(declare (type combination call))
(when (csubtypep (continuation-type
(first (combination-args call)))
type)
(specifier-type 'float)))))))
;;;; Irrational transforms:
......@@ -256,36 +255,36 @@
(double-float double-float) double-float
(movable foldable flushable))
(loop for (name prim rtype) in
'((exp %exp *)
(log %log float)
(sqrt %sqrt float)
(sin %sin *)
(cos %cos *)
(tan %tan *)
(asin %asin float)
(acos %acos float)
(atan %atan *)
(sinh %sinh *)
(cosh %cosh *)
(tanh %tanh *)
(asinh %asinh *)
(acosh %acosh float)
(atanh %atanh float)) do
(deftransform name ((x) '(single-float) rtype :eval-name t)
`(coerce (,prim (coerce x 'double-float)) 'single-float))
(deftransform name ((x) '(double-float) rtype :eval-name t)
`(,prim x)))
(loop for (name prim rtype) in
'((expt %pow (x y) t)
(atan %atan2 (x y) t)) do
(deftransform name ((x y) '(single-float) rtype :eval-name t)
`(coerce (,prim (coerce x 'double-float)
(coerce y 'double-float))
'single-float))
(deftransform name ((x y) '(double-float) rtype :eval-name t)
`(,prim x y)))
(dolist (stuff '((exp %exp *)
(log %log float)
(sqrt %sqrt float)
(sin %sin *)
(cos %cos *)
(tan %tan *)
(asin %asin float)
(acos %acos float)
(atan %atan *)
(sinh %sinh *)
(cosh %cosh *)
(tanh %tanh *)
(asinh %asinh *)
(acosh %acosh float)
(atanh %atanh float)))
(destructuring-bind (name prim rtype) stuff
(deftransform name ((x) '(single-float) rtype :eval-name t)
`(coerce (,prim (coerce x 'double-float)) 'single-float))
(deftransform name ((x) '(double-float) rtype :eval-name t)
`(,prim x))))
(dolist (stuff '((expt %pow (x y) t)
(atan %atan2 (x y) t)))
(destructuring-bind (name prim rtype) stuff
(deftransform name ((x y) '(single-float) rtype :eval-name t)
`(coerce (,prim (coerce x 'double-float)
(coerce y 'double-float))
'single-float))
(deftransform name ((x y) '(double-float) rtype :eval-name t)
`(,prim x y))))
(deftransform log ((x y) (float float) float)
'(/ (log x) (log y)))
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment