From 51fb9abe845646dcf1b8cb48044c680457525f43 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Sun, 14 Oct 1990 19:06:38 +0000
Subject: [PATCH] Added SIGFPE-HANDLER.

---
 code/float-trap.lisp | 34 ++++++++++++++++++++++++++++++++--
 1 file changed, 32 insertions(+), 2 deletions(-)

diff --git a/code/float-trap.lisp b/code/float-trap.lisp
index 2576e11c6..76084c057 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.1 1990/10/01 17:00:59 ram Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float-trap.lisp,v 1.2 1990/10/14 19:06:38 ram Exp $
 ;;;
 ;;;    This file contains stuff for controlling floating point traps.  It is
 ;;; fairly specific to the MIPS R2010.
@@ -15,7 +15,7 @@
 ;;; Author: Rob MacLachlan
 ;;; 
 (in-package "VM")
-(export '(current-float-trap floating-point-modes))
+(export '(current-float-trap floating-point-modes sigfpe-handler))
 (in-package "EXTENSIONS")
 (export '(set-floating-point-modes))
 (in-package "VM")
@@ -36,6 +36,7 @@
 (defconstant float-rounding-mode (byte 2 0))
 (defconstant float-sticky-bits (byte 5 2))
 (defconstant float-traps-byte (byte 5 7))
+(defconstant float-exceptions-byte (byte 5 12))
 (defconstant float-condition-bit (ash 1 23))
 
 (defconstant float-trap-alist
@@ -87,3 +88,32 @@
   otherwise."
   `(not (zerop (logand ,(dpb (float-trap-mask traps) float-traps-byte 0)
 		       (floating-point-modes)))))
+
+
+;;; SIGFPE-HANDLER  --  Interface
+;;;
+;;;    Signal the appropriate condition when we get a floating-point error.
+;;;
+(defun sigfpe-handler (signal code scp)
+  (declare (ignore signal code))
+  (system:alien-bind ((sc (system:make-alien 'mach:sigcontext
+					     #.(ext:c-sizeof 'mach:sigcontext)
+					     scp)
+			  mach:sigcontext
+			  t))
+    (let ((traps (ldb float-exceptions-byte
+		      (system:alien-access
+		       (mach:sigcontext-fpc_csr
+			(system:alien-value sc))))))
+      (cond ((not (zerop (logand float-divide-by-zero-trap-bit traps)))
+	     (error 'division-by-zero))
+	    ((not (zerop (logand float-invalid-trap-bit traps)))
+	     (error 'ext:floating-point-invalid))
+	    ((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 'ext:floating-point-inexact))
+	    (t
+	     (error "SIGFPE with no current exceptions?"))))))
-- 
GitLab