--- a/src/code/exports.lisp
+++ b/src/code/exports.lisp
@@ -1583,7 +1583,8 @@
 	   "FLOAT-DENORMALIZED-P" "FLOAT-INFINITY-P"
 	   "FLOAT-NAN-P" "FLOAT-TRAPPING-NAN-P"
 	   "FLOAT-SIGNALING-NAN-P"
-	   "WITH-FLOAT-TRAPS-MASKED")
+	   "WITH-FLOAT-TRAPS-MASKED"
+	   "WITH-FLOAT-TRAPS-ENABLED")
   ;; More float extensions
   #+double-double
   (:export "LEAST-POSITIVE-NORMALIZED-DOUBLE-DOUBLE-FLOAT"

--- a/src/code/float-trap.lisp
+++ b/src/code/float-trap.lisp
@@ -23,7 +23,8 @@
 )
 (in-package "EXTENSIONS")
 (export '(set-floating-point-modes get-floating-point-modes
-	  with-float-traps-masked))
+	  with-float-traps-masked
+	  with-float-traps-enabled))
 (in-package "VM")
 
 (eval-when (compile load eval)
@@ -406,3 +407,44 @@
 			      #+ppc
 			      ,invalid-mask
 			      #+mips ,(dpb 0 float-exceptions-byte #xffffffff))))))))
+
+(defmacro with-float-traps-enabled (traps &body body)
+  "Execute BODY with the floating point exceptions listed in TRAPS
+  enabled.  TRAPS should be a list of possible exceptions which
+  includes :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID and
+  :DIVIDE-BY-ZERO and on the X86 :DENORMALIZED-OPERAND. The respective
+  accrued exceptions are cleared at the start of the body to support
+  their testing within, and restored on exit."
+  (let ((traps (dpb (float-trap-mask traps) float-traps-byte 0))
+	(exceptions (dpb (float-trap-mask traps) float-sticky-bits 0))
+	(trap-mask (dpb (lognot (float-trap-mask traps))
+			float-traps-byte #xffffffff))
+	(exception-mask (dpb (lognot (vm::float-trap-mask traps))
+			     float-sticky-bits #xffffffff))
+	;; On ppc if we are masking the invalid trap, we need to make
+	;; sure we wipe out the various individual sticky bits
+	;; representing the invalid operation.  Otherwise, if we
+	;; enable the invalid trap later, these sticky bits will cause
+	;; an exception.
+	#+ppc
+	(invalid-mask (if (member :invalid traps)
+			  (dpb 0
+			       (byte 1 31)
+			       (dpb 0 vm::float-invalid-op-2-byte
+				    (dpb 0 vm:float-invalid-op-1-byte #xffffffff)))
+			  #xffffffff))
+	(orig-modes (gensym)))
+    `(let ((,orig-modes (floating-point-modes)))
+      (unwind-protect
+	   (progn
+	     (setf (floating-point-modes)
+		   (logorc2 ,orig-modes ,(logand trap-mask exception-mask)))
+	     ,@body)
+	;; Restore the original traps and exceptions.
+	(setf (floating-point-modes)
+	      (logior (logand ,orig-modes ,(logior traps exceptions))
+		      (logand (floating-point-modes)
+			      ,(logand trap-mask exception-mask)
+			      #+ppc
+			      ,invalid-mask
+			      #+mips ,(dpb 0 float-exceptions-byte #xffffffff))))))))