diff --git a/code/float-trap.lisp b/code/float-trap.lisp index 1c337dd01ea27eb530c1ae62e4ea0804fca4f171..feed75396d9bbbfd955bd95063a3813a8111557c 100644 --- a/code/float-trap.lisp +++ b/code/float-trap.lisp @@ -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?")))))