From e550ade67b8804b924f995241ae5865af8c7cf19 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Mon, 1 Oct 1990 17:00:59 +0000
Subject: [PATCH] Initial revision

---
 code/float-trap.lisp | 89 ++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 89 insertions(+)
 create mode 100644 code/float-trap.lisp

diff --git a/code/float-trap.lisp b/code/float-trap.lisp
new file mode 100644
index 000000000..2576e11c6
--- /dev/null
+++ b/code/float-trap.lisp
@@ -0,0 +1,89 @@
+;;; -*- Package: VM -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; 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 $
+;;;
+;;;    This file contains stuff for controlling floating point traps.  It is
+;;; fairly specific to the MIPS R2010.
+;;;
+;;; Author: Rob MacLachlan
+;;; 
+(in-package "VM")
+(export '(current-float-trap floating-point-modes))
+(in-package "EXTENSIONS")
+(export '(set-floating-point-modes))
+(in-package "VM")
+
+(eval-when (compile load eval)
+
+(defconstant float-inexact-trap-bit (ash 1 0))
+(defconstant float-underflow-trap-bit (ash 1 1))
+(defconstant float-overflow-trap-bit (ash 1 2))
+(defconstant float-divide-by-zero-trap-bit (ash 1 3))
+(defconstant float-invalid-trap-bit (ash 1 4))
+
+(defconstant float-round-to-nearest 0)
+(defconstant float-round-to-zero 1)
+(defconstant float-round-to-positive 2)
+(defconstant float-round-to-negative 3)
+
+(defconstant float-rounding-mode (byte 2 0))
+(defconstant float-sticky-bits (byte 5 2))
+(defconstant float-traps-byte (byte 5 7))
+(defconstant float-condition-bit (ash 1 23))
+
+(defconstant float-trap-alist
+  (list (cons :underflow float-underflow-trap-bit)
+	(cons :overflow float-overflow-trap-bit)
+	(cons :inexact float-inexact-trap-bit)
+	(cons :invalid float-invalid-trap-bit)
+	(cons :divide-by-zero float-divide-by-zero-trap-bit)))
+
+  
+;;; FLOAT-TRAP-MASK  --  Internal
+;;;
+;;;    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)))
+		  names)))
+  
+); Eval-When (Compile Load Eval)
+
+
+;;; Interpreter stubs.
+;;;
+(defun floating-point-modes () (floating-point-modes))
+(defun (setf floating-point-modes) () (floating-point-modes))
+
+
+;;; SET-FLOATING-POINT-MODES  --  Public
+;;;
+(defun set-floating-point-modes (&key traps)
+  "Set options for the floating point hardware:
+   :Traps
+       A list of the exception conditions that should cause traps.  Possible
+       exceptions are :underflow, :overflow, :inexact, :invalid and
+       :divide-by-zero."
+  (setf (ldb float-traps-byte (floating-point-modes))
+	(float-trap-mask traps))
+  (values))
+
+
+;;; CURRENT-FLOAT-TRAP  --  Interface
+;;;
+(defmacro current-float-trap (&rest traps)
+  "Current-Float-Trap Trap-Name*
+  Return true if any of the named traps are currently trapped, false
+  otherwise."
+  `(not (zerop (logand ,(dpb (float-trap-mask traps) float-traps-byte 0)
+		       (floating-point-modes)))))
-- 
GitLab