X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffloat-trap.lisp;h=c2e44e584f1431069df588f45865db866511fda3;hb=6c4d4d984b1af6b2a73568cec3ab9c8795cff2da;hp=39293abca100a32018ece11e97324c5e2dd1f512;hpb=0b3ec4b1d978b887db175b7b3bada8e727683e15;p=sbcl.git

diff --git a/src/code/float-trap.lisp b/src/code/float-trap.lisp
index 39293ab..c2e44e5 100644
--- a/src/code/float-trap.lisp
+++ b/src/code/float-trap.lisp
@@ -33,15 +33,21 @@
 ;;; Return a mask with all the specified float trap bits set.
 (defun float-trap-mask (names)
   (reduce #'logior
-	  (mapcar #'(lambda (x)
-		      (or (cdr (assoc x *float-trap-alist*))
-			  (error "unknown float trap kind: ~S" x)))
+	  (mapcar (lambda (x)
+		    (or (cdr (assoc x *float-trap-alist*))
+			(error "unknown float trap kind: ~S" x)))
 		  names)))
 ) ; EVAL-WHEN
 
-;;; interpreter stubs
-(defun floating-point-modes () (floating-point-modes))
-(defun (setf floating-point-modes) (new) (setf (floating-point-modes) new))
+;;; interpreter stubs for floating point modes get/setters for the
+;;; alpha have been removed to alpha-vm.lisp, as they are implemented
+;;; in C rather than as VOPs.
+#!-alpha
+(progn
+  (defun floating-point-modes () 
+    (floating-point-modes))
+  (defun (setf floating-point-modes) (new) 
+    (setf (floating-point-modes) new)))
 
 ;;; This function sets options controlling the floating-point
 ;;; hardware. If a keyword is not supplied, then the current value is
@@ -49,13 +55,13 @@
 ;;; :TRAPS
 ;;;    A list of the exception conditions that should cause traps.
 ;;;    Possible exceptions are :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID,
-;;;    :DIVIDE-BY-ZERO, and on the X86 :DENORMALIZED-OPERAND. Initially
-;;;    all traps except :INEXACT are enabled.
+;;;    :DIVIDE-BY-ZERO, and on the X86 :DENORMALIZED-OPERAND.
 ;;;
 ;;;: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.
+;;;    :ZERO.  Setting this away from :NEAREST is liable to upset SBCL's
+;;;    maths routines which depend on it.
 ;;;
 ;;;:CURRENT-EXCEPTIONS
 ;;;:ACCRUED-EXCEPTIONS
@@ -64,11 +70,14 @@
 ;;;
 ;;;: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.
+;;;    conformance or debuggability may be impaired. Some machines don't
+;;;    have this feature, and some SBCL ports don't implement it anyway
+;;;    -- in such cases the value is always NIL.
 ;;;
 ;;; GET-FLOATING-POINT-MODES may be used to find the floating point modes
-;;; currently in effect.
+;;; currently in effect.    See cold-init.lisp for the list of initially
+;;; enabled traps
+
 (defun set-floating-point-modes (&key (traps nil traps-p)
 				      (rounding-mode nil round-p)
 				      (current-exceptions nil current-x-p)
@@ -105,9 +114,9 @@
   (flet ((exc-keys (bits)
 	   (macrolet ((frob ()
 			`(collect ((res))
-			   ,@(mapcar #'(lambda (x)
-					 `(when (logtest bits ,(cdr x))
-					    (res ',(car x))))
+			   ,@(mapcar (lambda (x)
+				       `(when (logtest bits ,(cdr x))
+					  (res ',(car x))))
 				     *float-trap-alist*)
 			   (res))))
 	     (frob))))
@@ -127,17 +136,8 @@
 
 ;;; Signal the appropriate condition when we get a floating-point error.
 (defun sigfpe-handler (signal info context)
-  (declare (ignore signal info))
+  (declare (ignore signal info context))
   (declare (type system-area-pointer context))
-  ;; FIXME: The find-the-detailed-problem code below went stale with
-  ;; the big switchover to POSIX signal handling and signal contexts
-  ;; which are opaque at the Lisp level ca. sbcl-0.6.7. It needs to be
-  ;; revived, which will require writing a C-level os-dependent
-  ;; function to extract floating point modes, and a Lisp-level
-  ;; DEF-ALIEN-ROUTINE to get to the C-level os-dependent function.
-  ;; Meanwhile we just say "something went wrong".
-  (error 'floating-point-exception)
-  #|
   (let* ((modes (context-floating-point-modes
 		 (sb!alien:sap-alien context (* os-context-t))))
 	 (traps (logand (ldb float-exceptions-byte modes)
@@ -158,9 +158,7 @@
 	   (error 'floating-point-exception
 		  :traps (getf (get-floating-point-modes) :traps)))
 	  (t
-	   (error "SIGFPE with no exceptions currently enabled?"))))
-  |#
-  )
+	   (error 'floating-point-exception)))))
 
 ;;; Execute BODY with the floating point exceptions listed in TRAPS
 ;;; masked (disabled). TRAPS should be a list of possible exceptions
@@ -173,16 +171,17 @@
 	(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 (sb!vm::float-trap-mask traps))
-			     float-sticky-bits #xffffffff)))
-    `(let ((orig-modes (floating-point-modes)))
+	(exception-mask (dpb (lognot (float-trap-mask traps))
+			     float-sticky-bits #xffffffff))
+        (orig-modes (gensym)))
+    `(let ((,orig-modes (floating-point-modes)))
       (unwind-protect
 	   (progn
 	     (setf (floating-point-modes)
-		   (logand orig-modes ,(logand trap-mask exception-mask)))
+		   (logand ,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))
+	      (logior (logand ,orig-modes ,(logior traps exceptions))
 		      (logand (floating-point-modes)
 			      ,(logand trap-mask exception-mask))))))))