Skip to content
Snippets Groups Projects
Commit 26497b49 authored by ram's avatar ram
Browse files

Added GET-FLOATING-POINT-MODES to read the floating point modes.

Added support in SET-FLOATING-POINT-MODES to set all the interesting
state.
Fixed SIGFPE handler to not signal conditions for exceptions that are
not currently trapped (in case the operation had multiple exceptions), some of 
which were not trapped.
parent c86cbfc9
No related branches found
No related tags found
No related merge requests found
......@@ -7,7 +7,7 @@
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float-trap.lisp,v 1.3 1990/12/06 17:38:10 ram Exp $
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float-trap.lisp,v 1.4 1990/12/07 18:00:37 ram Exp $
;;;
;;; This file contains stuff for controlling floating point traps. It is
;;; IEEE float specific, but should work for pretty much any FPU where the
......@@ -18,7 +18,7 @@
(in-package "VM")
(export '(current-float-trap floating-point-modes sigfpe-handler))
(in-package "EXTENSIONS")
(export '(set-floating-point-modes))
(export '(set-floating-point-modes get-floating-point-modes))
(in-package "VM")
(eval-when (compile load eval)
......@@ -30,7 +30,6 @@
(cons :invalid float-invalid-trap-bit)
(cons :divide-by-zero float-divide-by-zero-trap-bit)))
;;; FLOAT-TRAP-MASK -- Internal
;;;
;;; Return a mask with all the specified float trap bits set.
......@@ -41,6 +40,12 @@
(or (cdr (assoc x float-trap-alist))
(error "Unknown float trap kind: ~S." x)))
names)))
(defconstant rounding-mode-alist
(list (cons :nearest float-round-to-nearest)
(cons :zero float-round-to-zero)
(cons :positive-infinity float-round-to-positive)
(cons :negative-infinity float-round-to-negative)))
); Eval-When (Compile Load Eval)
......@@ -53,17 +58,86 @@
;;; SET-FLOATING-POINT-MODES -- Public
;;;
(defun set-floating-point-modes (&key traps)
"Set options for the floating point hardware:
:Traps
(defun set-floating-point-modes (&key (traps nil traps-p)
(rounding-mode nil round-p)
(current-exceptions nil current-x-p)
(accrued-exceptions nil accrued-x-p)
(fast-mode nil fast-mode-p))
"This function sets options controlling the floating-point hardware. If a
keyword is not supplied, then the current value is preserved. Possible
keywords:
:TRAPS
A list of the exception conditions that should cause traps. Possible
exceptions are :underflow, :overflow, :inexact, :invalid and
:divide-by-zero."
(setf (ldb float-traps-byte (floating-point-modes))
(float-trap-mask traps))
exceptions are :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID and
:DIVIDE-BY-ZERO. Initially all traps except :INEXACT are enabled.
:ROUNDING-MODE
The rounding mode to use when the result is not exact. Possible values
are :NEAREST, :POSITIVE-INFINITY, :NEGATIVE-INFINITY and :ZERO.
Initially, the rounding mode is :NEAREST.
:CURRENT-EXCEPTIONS
:ACCRUED-EXCEPTIONS
These arguments allow setting of the exception flags. The main use is
setting the accrued exceptions to NIL to clear them.
:FAST-MODE
Set the hardware's \"fast mode\" flag, if any. When set, IEEE
conformance or debuggability may be impaired. Some machines may not
have this feature, in which case the value is always NIL.
GET-FLOATING-POINT-MODES may be used to find the floating point modes
currently in effect."
(let ((modes (floating-point-modes)))
(when traps-p
(setf (ldb float-traps-byte modes) (float-trap-mask traps)))
(when round-p
(setf (ldb float-rounding-mode modes)
(or (cdr (assoc rounding-mode rounding-mode-alist))
(error "Unknown rounding mode: ~S." rounding-mode))))
(when current-x-p
(setf (ldb float-exceptions-byte modes)
(float-trap-mask current-exceptions)))
(when accrued-x-p
(setf (ldb float-sticky-bits modes)
(float-trap-mask accrued-exceptions)))
(when fast-mode-p
(if fast-mode
(setq modes (logior float-fast-bit modes))
(setq modes (logand (lognot float-fast-bit) modes))))
(setf (floating-point-modes) modes))
(values))
;;; GET-FLOATING-POINT-MODES -- Public
;;;
(defun get-floating-point-modes ()
"This function returns a list representing the state of the floating point
modes. The list is in the same format as the keyword arguments to
SET-FLOATING-POINT-MODES, i.e.
(apply #'set-floating-point-modes (get-floating-point-modes))
sets the floating point modes to their current values (and thus is a no-op)."
(flet ((exc-keys (bits)
(macrolet ((frob ()
`(collect ((res))
,@(mapcar #'(lambda (x)
`(when (logtest bits ,(cdr x))
(res ',(car x))))
float-trap-alist)
(res))))
(frob))))
(let ((modes (floating-point-modes)))
`(:traps ,(exc-keys (ldb float-traps-byte modes))
:rounding-mode ,(car (rassoc (ldb float-rounding-mode modes)
rounding-mode-alist))
:current-exceptions ,(exc-keys (ldb float-exceptions-byte modes))
:accrued-exceptions ,(exc-keys (ldb float-sticky-bits modes))
:fast-mode ,(logtest float-fast-bit modes)))))
;;; CURRENT-FLOAT-TRAP -- Interface
;;;
(defmacro current-float-trap (&rest traps)
......@@ -80,8 +154,9 @@
;;;
(defun sigfpe-handler (signal code scp)
(declare (ignore signal code))
(let ((traps (ldb float-exceptions-byte
(sigcontext-floating-point-modes scp))))
(let* ((modes (sigcontext-floating-point-modes scp))
(traps (logand (ldb float-exceptions-byte modes)
(ldb float-traps-byte modes))))
(cond ((not (zerop (logand float-divide-by-zero-trap-bit traps)))
(error 'division-by-zero))
((not (zerop (logand float-invalid-trap-bit traps)))
......@@ -93,4 +168,4 @@
((not (zerop (logand float-inexact-trap-bit traps)))
(error 'ext:floating-point-inexact))
(t
(error "SIGFPE with no current exceptions?")))))
(error "SIGFPE with no exceptions currently enabled?")))))
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