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