X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffloat-trap.lisp;h=429c5df87b03b8fa7645e7f37857268a1631d76c;hb=bd4f596b07e3783992e00eae88afdc05ebe7c6a6;hp=0211aa7a0ef1f60ebf28baafed17108624f022be;hpb=8c82cc1e67fe8116431a1d2d4e79005114ff1697;p=sbcl.git

diff --git a/src/code/float-trap.lisp b/src/code/float-trap.lisp
index 0211aa7..429c5df 100644
--- a/src/code/float-trap.lisp
+++ b/src/code/float-trap.lisp
@@ -55,7 +55,7 @@
   (defun (setf floating-point-modes) (new)
     (setf (floating-point-modes) new)))
 
-(defun set-floating-point-modes (&key 
+(defun set-floating-point-modes (&key
                                  (traps nil traps-p)
                                  (rounding-mode nil round-p)
                                  (current-exceptions nil current-x-p)
@@ -89,12 +89,12 @@ preserved. Possible keywords:
    have this feature, and some SBCL ports don't implement it anyway
    -- in such cases the value is always NIL.
 
-:PRECISION (x86 only) 
+:PRECISION (x86 only)
   :24-bit, :53-bit and :64-bit, for the internal precision of the mantissa.
 
 GET-FLOATING-POINT-MODES may be used to find the floating point modes
 currently in effect. SAVE-LISP-AND-DIE preserves the floating point modes
-in effect." 
+in effect."
   (let ((modes (floating-point-modes)))
     (when traps-p
       (setf (ldb float-traps-byte modes) (float-trap-mask traps)))
@@ -126,7 +126,7 @@ in effect."
   "This function returns a list representing the state of the floating
 point modes. The list is in the same format as the &KEY 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)."
@@ -160,7 +160,8 @@ sets the floating point modes to their current values (and thus is a no-op)."
 (defvar *saved-floating-point-modes*
   '(:traps (:overflow #!-netbsd :invalid :divide-by-zero)
     :rounding-mode :nearest :current-exceptions nil
-    :accrued-exceptions nil :fast-mode nil :precision :53-bit))
+    :accrued-exceptions nil :fast-mode nil
+    #!+x86 :precision #!+x86 :53-bit))
 
 (defun float-cold-init-or-reinit ()
   (apply #'set-floating-point-modes *saved-floating-point-modes*))
@@ -174,33 +175,27 @@ sets the floating point modes to their current values (and thus is a no-op)."
   `(not (zerop (logand ,(dpb (float-trap-mask traps) float-traps-byte 0)
                        (floating-point-modes)))))
 
+;;; SIGFPE code to floating-point error
+#!-win32
+(defparameter *sigfpe-code-error-alist*
+  (list (cons sb!unix::fpe-intovf 'floating-point-overflow)
+        (cons sb!unix::fpe-intdiv 'division-by-zero)
+        (cons sb!unix::fpe-fltdiv 'division-by-zero)
+        (cons sb!unix::fpe-fltovf 'floating-point-overflow)
+        (cons sb!unix::fpe-fltund 'floating-point-underflow)
+        (cons sb!unix::fpe-fltres 'floating-point-inexact)
+        (cons sb!unix::fpe-fltinv 'floating-point-invalid-operation)
+        (cons sb!unix::fpe-fltsub 'floating-point-exception)))
+
 ;;; Signal the appropriate condition when we get a floating-point error.
 #!-win32
 (defun sigfpe-handler (signal info context)
-  (declare (ignore signal info))
-  (declare (type system-area-pointer context))
-  (let* ((modes (context-floating-point-modes
-                 (sb!alien:sap-alien context (* os-context-t))))
-         (traps (logand (ldb float-exceptions-byte modes)
-                        (ldb float-traps-byte modes))))
+  (declare (ignore signal context))
+  (declare (type system-area-pointer info))
+  (let ((code (sb!unix::siginfo-code info)))
     (with-interrupts
-      (cond ((not (zerop (logand float-divide-by-zero-trap-bit traps)))
-             (error 'division-by-zero))
-            ((not (zerop (logand float-invalid-trap-bit traps)))
-             (error 'floating-point-invalid-operation))
-            ((not (zerop (logand float-overflow-trap-bit traps)))
-             (error 'floating-point-overflow))
-            ((not (zerop (logand float-underflow-trap-bit traps)))
-             (error 'floating-point-underflow))
-            ((not (zerop (logand float-inexact-trap-bit traps)))
-             (error 'floating-point-inexact))
-            #!+freebsd
-            ((zerop (ldb float-exceptions-byte modes))
-             ;; I can't tell what caused the exception!!
-             (error 'floating-point-exception
-                    :traps (getf (get-floating-point-modes) :traps)))
-            (t
-             (error 'floating-point-exception))))))
+        (error (or (cdr (assoc code *sigfpe-code-error-alist*))
+                   'floating-point-exception)))))
 
 ;;; Execute BODY with the floating point exceptions listed in TRAPS
 ;;; masked (disabled). TRAPS should be a list of possible exceptions