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?")))))