Skip to content
Snippets Groups Projects
Commit 4bf2ce76 authored by dtc's avatar dtc
Browse files

Add a check to the following derive-type optimizers that both results

type derivations have succeeded before returning a values type,
otherwise they can possibly returned a type of (values nil nil) which
causes a compiler error: truncate, ftruncate, floor, ceiling, ffloor,
fceiling.
parent 59b281ce
No related branches found
No related tags found
No related merge requests found
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.75 1998/01/07 23:30:59 dtc Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.76 1998/01/11 07:15:41 dtc Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -1620,13 +1620,13 @@ ...@@ -1620,13 +1620,13 @@
*empty-type*)) *empty-type*))
(defoptimizer (truncate derive-type) ((number divisor)) (defoptimizer (truncate derive-type) ((number divisor))
(make-values-type (let ((quot (two-arg-derive-type number divisor
:required #'truncate-derive-type-quot-aux #'truncate))
(list (rem (two-arg-derive-type number divisor
(two-arg-derive-type number divisor #'truncate-derive-type-rem-aux #'rem)))
#'truncate-derive-type-quot-aux #'truncate) (when (and quot rem)
(two-arg-derive-type number divisor (make-values-type :required (list quot rem)))))
#'truncate-derive-type-rem-aux #'rem))))
(defun ftruncate-derive-type-quot (number-type divisor-type) (defun ftruncate-derive-type-quot (number-type divisor-type)
;; The bounds are the same as for truncate. However, the first ;; The bounds are the same as for truncate. However, the first
...@@ -1647,13 +1647,13 @@ ...@@ -1647,13 +1647,13 @@
*empty-type*)) *empty-type*))
(defoptimizer (ftruncate derive-type) ((number divisor)) (defoptimizer (ftruncate derive-type) ((number divisor))
(make-values-type (let ((quot
:required (two-arg-derive-type number divisor
(list #'ftruncate-derive-type-quot-aux #'ftruncate))
(two-arg-derive-type number divisor (rem (two-arg-derive-type number divisor
#'ftruncate-derive-type-quot-aux #'ftruncate) #'truncate-derive-type-rem-aux #'rem)))
(two-arg-derive-type number divisor (when (and quot rem)
#'truncate-derive-type-rem-aux #'rem)))) (make-values-type :required (list quot rem)))))
(defun %unary-truncate-derive-type-aux (number) (defun %unary-truncate-derive-type-aux (number)
...@@ -1722,12 +1722,14 @@ ...@@ -1722,12 +1722,14 @@
(numeric-type-real-p d)) (numeric-type-real-p d))
(,r-aux n d) (,r-aux n d)
*empty-type*))) *empty-type*)))
(make-values-type (let ((quot (two-arg-derive-type
:required number divisor #'derive-q #',name))
(list (two-arg-derive-type number divisor #'derive-q #',name) (rem (two-arg-derive-type
(two-arg-derive-type number divisor #'derive-r #'mod))))) number divisor #'derive-r #'mod)))
(when (and quot rem)
(make-values-type :required (list quot rem))))))
)))) ))))
(frob-opt floor floor-quotient-bound floor-rem-bound) (frob-opt floor floor-quotient-bound floor-rem-bound)
(frob-opt ceiling ceiling-quotient-bound ceiling-rem-bound)) (frob-opt ceiling ceiling-quotient-bound ceiling-rem-bound))
...@@ -1765,11 +1767,13 @@ ...@@ -1765,11 +1767,13 @@
(numeric-type-real-p d)) (numeric-type-real-p d))
(,r-aux n d) (,r-aux n d)
*empty-type*))) *empty-type*)))
(make-values-type (let ((quot (two-arg-derive-type
:required number divisor #'derive-q #',name))
(list (two-arg-derive-type number divisor #'derive-q #',name) (rem (two-arg-derive-type
(two-arg-derive-type number divisor #'derive-r #'mod))))))))) number divisor #'derive-r #'mod)))
(when (and quot rem)
(make-values-type :required (list quot rem))))))))))
(frob-opt ffloor floor-quotient-bound floor-rem-bound) (frob-opt ffloor floor-quotient-bound floor-rem-bound)
(frob-opt fceiling ceiling-quotient-bound ceiling-rem-bound)) (frob-opt fceiling ceiling-quotient-bound ceiling-rem-bound))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment