From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 19 Dec 1994 21:07:34 +0000 (+0000)
Subject: Add code to handle OS/2 hardware exceptions.
X-Git-Tag: 20090517-FFI~6857
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=db702397e24c56c4f7285e2f8a92595132c65755;p=mit-scheme.git

Add code to handle OS/2 hardware exceptions.
---

diff --git a/v7/src/runtime/uerror.scm b/v7/src/runtime/uerror.scm
index e73638919..745b49e46 100644
--- a/v7/src/runtime/uerror.scm
+++ b/v7/src/runtime/uerror.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: uerror.scm,v 14.41 1994/10/10 21:29:53 cph Exp $
+$Id: uerror.scm,v 14.42 1994/12/19 21:07:34 cph Exp $
 
 Copyright (c) 1988-94 Massachusetts Institute of Technology
 
@@ -889,9 +889,9 @@ MIT in each case. |#
     (lambda (continuation)
       (let ((frame (continuation/first-subproblem continuation)))
 	(if (apply-frame? frame)
-	     (signal continuation
-		     (apply-frame/operator frame)
-		     (apply-frame/operands frame)))))))
+	    (signal continuation
+		    (apply-frame/operator frame)
+		    (apply-frame/operands frame)))))))
 
 (define-error-handler 'WRITE-INTO-PURE-SPACE
   (lambda (continuation)
@@ -986,23 +986,43 @@ MIT in each case. |#
 	     (condition-signaller condition-type:hardware-trap '(NAME CODE))))
 	(lambda (name)
 	  (call-with-current-continuation
-	   (lambda (continuation)
+	   (lambda (k)
 	     (if (not name)
-		 (signal-user-microcode-reset continuation)
-		 (let ((code
-			(let ((frame
-			       (continuation/first-subproblem continuation)))
-			  (and (hardware-trap-frame? frame)
-			       (hardware-trap-frame/code frame)))))
-		   (if (string=? "SIGFPE" name)
-		       ((case (and (string? code)
-				   (normalize-trap-code-name code))
-			  ((UNDERFLOW) signal-floating-point-underflow)
-			  ((OVERFLOW) signal-floating-point-overflow)
-			  ((DIVIDE-BY-ZERO) signal-divide-by-zero)
-			  (else signal-arithmetic-error))
-			continuation false '())
-		       (signal-hardware-trap continuation name code)))))))))
+		 (signal-user-microcode-reset k)
+		 (case microcode-id/operating-system
+		   ((OS/2)
+		    (cond ((string=? "XCPT_FLOAT_UNDERFLOW" name)
+			   (signal-floating-point-underflow k #f '()))
+			  ((or (string=? "XCPT_FLOAT_OVERFLOW" name)
+			       (string=? "XCPT_INTEGER_OVERFLOW" name))
+			   (signal-floating-point-overflow k #f '()))
+			  ((or (string=? "XCPT_FLOAT_DIVIDE_BY_ZERO" name)
+			       (string=? "XCPT_INTEGER_DIVIDE_BY_ZERO" name))
+			   (signal-divide-by-zero k #f '()))
+			  ((or (string=? "XCPT_FLOAT_DENORMAL_OPERAND" name)
+			       (string=? "XCPT_FLOAT_INEXACT_RESULT" name)
+			       (string=? "XCPT_FLOAT_INVALID_OPERATION" name)
+			       (string=? "XCPT_FLOAT_STACK_CHECK" name)
+			       (string=? "XCPT_B1NPX_ERRATA_02" name))
+			   (signal-arithmetic-error k #f '()))
+			  (else
+			   (signal-hardware-trap k name #f))))
+		   (else
+		    (let ((code
+			   (let ((frame (continuation/first-subproblem k)))
+			     (and (hardware-trap-frame? frame)
+				  (hardware-trap-frame/code frame)))))
+		      (if (string=? "SIGFPE" name)
+			  ((case (and (string? code)
+				      (normalize-trap-code-name code))
+			     ((UNDERFLOW) signal-floating-point-underflow)
+			     ((OVERFLOW) signal-floating-point-overflow)
+			     ((DIVIDE-BY-ZERO) signal-divide-by-zero)
+			     (else signal-arithmetic-error))
+			   k false '())
+			  (signal-hardware-trap k
+						name
+						code)))))))))))
 
 ;;; end INITIALIZE-PACKAGE!.
 )
\ No newline at end of file