home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / float-trap.lisp < prev    next >
Encoding:
Text File  |  1992-05-30  |  6.2 KB  |  176 lines
  1. ;;; -*- Package: VM -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: float-trap.lisp,v 1.6 92/02/14 23:46:17 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;;    This file contains stuff for controlling floating point traps.  It is
  15. ;;; IEEE float specific, but should work for pretty much any FPU where the
  16. ;;; state fits in one word and exceptions are represented by bits being set.
  17. ;;;
  18. ;;; Author: Rob MacLachlan
  19. ;;; 
  20. (in-package "VM")
  21. (export '(current-float-trap floating-point-modes sigfpe-handler))
  22. (in-package "EXTENSIONS")
  23. (export '(set-floating-point-modes get-floating-point-modes))
  24. (in-package "VM")
  25.  
  26. (eval-when (compile load eval)
  27.  
  28. (defconstant float-trap-alist
  29.   (list (cons :underflow float-underflow-trap-bit)
  30.     (cons :overflow float-overflow-trap-bit)
  31.     (cons :inexact float-inexact-trap-bit)
  32.     (cons :invalid float-invalid-trap-bit)
  33.     (cons :divide-by-zero float-divide-by-zero-trap-bit)))
  34.  
  35. ;;; FLOAT-TRAP-MASK  --  Internal
  36. ;;;
  37. ;;;    Return a mask with all the specified float trap bits set.
  38. ;;;
  39. (defun float-trap-mask (names)
  40.   (reduce #'logior
  41.       (mapcar #'(lambda (x)
  42.               (or (cdr (assoc x float-trap-alist))
  43.               (error "Unknown float trap kind: ~S." x)))
  44.           names)))
  45.  
  46. (defconstant rounding-mode-alist
  47.   (list (cons :nearest float-round-to-nearest)
  48.     (cons :zero float-round-to-zero)
  49.     (cons :positive-infinity float-round-to-positive)
  50.     (cons :negative-infinity float-round-to-negative)))
  51.   
  52. ); Eval-When (Compile Load Eval)
  53.  
  54.  
  55. ;;; Interpreter stubs.
  56. ;;;
  57. (defun floating-point-modes () (floating-point-modes))
  58. (defun (setf floating-point-modes) (new) (setf (floating-point-modes) new))
  59.  
  60.  
  61. ;;; SET-FLOATING-POINT-MODES  --  Public
  62. ;;;
  63. (defun set-floating-point-modes (&key (traps nil traps-p)
  64.                       (rounding-mode nil round-p)
  65.                       (current-exceptions nil current-x-p)
  66.                       (accrued-exceptions nil accrued-x-p)
  67.                       (fast-mode nil fast-mode-p))
  68.   "This function sets options controlling the floating-point hardware.  If a
  69.   keyword is not supplied, then the current value is preserved.  Possible
  70.   keywords:
  71.  
  72.    :TRAPS
  73.        A list of the exception conditions that should cause traps.  Possible
  74.        exceptions are :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID and
  75.        :DIVIDE-BY-ZERO.  Initially all traps except :INEXACT are enabled.
  76.  
  77.    :ROUNDING-MODE
  78.        The rounding mode to use when the result is not exact.  Possible values
  79.        are :NEAREST, :POSITIVE-INFINITY, :NEGATIVE-INFINITY and :ZERO.
  80.        Initially, the rounding mode is :NEAREST.
  81.  
  82.    :CURRENT-EXCEPTIONS
  83.    :ACCRUED-EXCEPTIONS
  84.        These arguments allow setting of the exception flags.  The main use is
  85.        setting the accrued exceptions to NIL to clear them.
  86.  
  87.    :FAST-MODE
  88.        Set the hardware's \"fast mode\" flag, if any.  When set, IEEE
  89.        conformance or debuggability may be impaired.  Some machines may not
  90.        have this feature, in which case the value is always NIL.
  91.  
  92.    GET-FLOATING-POINT-MODES may be used to find the floating point modes
  93.    currently in effect."
  94.   (let ((modes (floating-point-modes)))
  95.     (when traps-p
  96.       (setf (ldb float-traps-byte modes) (float-trap-mask traps)))
  97.     (when round-p
  98.       (setf (ldb float-rounding-mode modes)
  99.         (or (cdr (assoc rounding-mode rounding-mode-alist))
  100.         (error "Unknown rounding mode: ~S." rounding-mode))))
  101.     (when current-x-p
  102.       (setf (ldb float-exceptions-byte modes)
  103.         (float-trap-mask current-exceptions)))
  104.     (when accrued-x-p
  105.       (setf (ldb float-sticky-bits modes)
  106.         (float-trap-mask accrued-exceptions)))
  107.     (when fast-mode-p
  108.       (if fast-mode
  109.       (setq modes (logior float-fast-bit modes))
  110.       (setq modes (logand (lognot float-fast-bit) modes))))
  111.     (setf (floating-point-modes) modes))
  112.     
  113.   (values))
  114.  
  115.  
  116. ;;; GET-FLOATING-POINT-MODES  --  Public
  117. ;;;
  118. (defun get-floating-point-modes ()
  119.   "This function returns a list representing the state of the floating point
  120.   modes.  The list is in the same format as the keyword arguments to
  121.   SET-FLOATING-POINT-MODES, i.e. 
  122.       (apply #'set-floating-point-modes (get-floating-point-modes))
  123.  
  124.   sets the floating point modes to their current values (and thus is a no-op)."
  125.   (flet ((exc-keys (bits)
  126.        (macrolet ((frob ()
  127.             `(collect ((res))
  128.                ,@(mapcar #'(lambda (x)
  129.                      `(when (logtest bits ,(cdr x))
  130.                         (res ',(car x))))
  131.                      float-trap-alist)
  132.                (res))))
  133.          (frob))))
  134.     (let ((modes (floating-point-modes))) 
  135.       `(:traps ,(exc-keys (ldb float-traps-byte modes))
  136.     :rounding-mode ,(car (rassoc (ldb float-rounding-mode modes)
  137.                      rounding-mode-alist))
  138.     :current-exceptions ,(exc-keys (ldb float-exceptions-byte modes))
  139.     :accrued-exceptions ,(exc-keys (ldb float-sticky-bits modes))
  140.     :fast-mode ,(logtest float-fast-bit modes)))))
  141.  
  142.   
  143. ;;; CURRENT-FLOAT-TRAP  --  Interface
  144. ;;;
  145. (defmacro current-float-trap (&rest traps)
  146.   "Current-Float-Trap Trap-Name*
  147.   Return true if any of the named traps are currently trapped, false
  148.   otherwise."
  149.   `(not (zerop (logand ,(dpb (float-trap-mask traps) float-traps-byte 0)
  150.                (floating-point-modes)))))
  151.  
  152.  
  153. ;;; SIGFPE-HANDLER  --  Interface
  154. ;;;
  155. ;;;    Signal the appropriate condition when we get a floating-point error.
  156. ;;;
  157. (defun sigfpe-handler (signal code scp)
  158.   (declare (ignore signal code)
  159.        (type system-area-pointer scp))
  160.   (let* ((modes (sigcontext-floating-point-modes
  161.          (alien:sap-alien scp (* unix:sigcontext))))
  162.      (traps (logand (ldb float-exceptions-byte modes)
  163.             (ldb float-traps-byte modes))))
  164.     (cond ((not (zerop (logand float-divide-by-zero-trap-bit traps)))
  165.        (error 'division-by-zero))
  166.       ((not (zerop (logand float-invalid-trap-bit traps)))
  167.        (error 'ext:floating-point-invalid))
  168.       ((not (zerop (logand float-overflow-trap-bit traps)))
  169.        (error 'floating-point-overflow))
  170.       ((not (zerop (logand float-underflow-trap-bit traps)))
  171.        (error 'floating-point-underflow))
  172.       ((not (zerop (logand float-inexact-trap-bit traps)))
  173.        (error 'ext:floating-point-inexact))
  174.       (t
  175.        (error "SIGFPE with no exceptions currently enabled?")))))
  176.