[movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp

[Frode Vatvedt Fjeld]

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory common-lisp.net:/tmp/cvs-serv29076

Modified Files:
	interrupt.lisp 
Log Message:
Handle into exception after fixnum addition.

Date: Fri Aug 26 21:40:33 2005
Author: ffjeld

Index: movitz/losp/muerte/interrupt.lisp
diff -u movitz/losp/muerte/interrupt.lisp:1.47 movitz/losp/muerte/interrupt.lisp:1.48
--- movitz/losp/muerte/interrupt.lisp:1.47	Fri Aug 12 22:28:30 2005
+++ movitz/losp/muerte/interrupt.lisp	Fri Aug 26 21:40:32 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Apr  7 01:50:03 2004
 ;;;;                
-;;;; $Id: interrupt.lisp,v 1.47 2005/08/12 20:28:30 ffjeld Exp $
+;;;; $Id: interrupt.lisp,v 1.48 2005/08/26 19:40:32 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -276,9 +276,9 @@
 
 (defun interrupt-default-handler (vector dit-frame)
   (declare (without-check-stack-limit))
-  (macrolet ((dereference (fixnum-address &optional (type :lisp))
+  (macrolet ((dereference (location &optional (type :lisp))
 	       "Dereference the fixnum-address."
-	       `(memref ,fixnum-address 0 :type ,type)))
+	       `(memref ,location 0 :type ,type)))
     (let (($eip (+ dit-frame (dit-frame-index :eip)))
 	  ($eax (+ dit-frame (dit-frame-index :eax)))
 	  ($ebx (+ dit-frame (dit-frame-index :ebx)))
@@ -290,14 +290,24 @@
 	(case vector
 	  (0 (error 'division-by-zero))
 	  (3 (break "Break instruction at ~@Z." $eip))
-	  (4 (if (not (eq (load-global-constant new-unbound-value)
-			  (dereference $eax)))
-		 (error "Primitive overflow assertion failed.")
+	  (4 (cond
+	      ((eq (load-global-constant new-unbound-value)
+		   (dereference $eax))
 	       (let ((name (dereference $ebx)))
 		 (with-simple-restart (new-value "Set the value of ~S." name)
 		   (error 'unbound-variable :name name))
 		 (format *query-io* "~&Enter a value for ~S: " name)
-		 (setf (dereference $eax) (read *query-io*)))))
+		 (setf (dereference $eax) (read *query-io*))))
+	      ((typep (dereference $eax) 'fixnum)
+	       (let ((eax (dereference $eax)))
+		 (setf (dereference $eax)
+		   (if (plusp eax)
+		       (- most-negative-fixnum
+			  1 (- most-positive-fixnum eax))
+		     (+ most-positive-fixnum
+			1 (- eax most-negative-fixnum))))
+		 (warn "Overflow: ~S -> ~S" eax (dereference $eax))))
+	      (t (error "Primitive overflow assertion failed."))))
 	  (6 (error "Illegal instruction at ~@Z." $eip))
 	  (13  (error "General protection error. EIP=~@Z, error-code: #x~X, EAX: ~@Z, EBX: ~@Z, ECX: ~@Z"
 		     $eip