Changeset 9384 for branches

Timestamp:

May 6, 2008, 10:42:50 AM (17 years ago)

Author:

R. Matthew Emerson

Message:

%xerr-disp for x8632; probably buggy.

File:

• branches/ia32/level-1/x86-error-signal.lisp (modified) (2 diffs)

branches/ia32/level-1/x86-error-signal.lisp

@@ -60 +60 @@
     (setf (encoded-gpr-lisp xp x8664::arg_z) values
           (encoded-gpr-lisp xp x8664::fn) f)))
-  
+
+#+x8664-target
 (defcallback %xerr-disp (:address xp :address xcf :int)
   (with-error-reentry-detection
@@ -222 +223 @@
           skip))))
 
-
-          
+;;; lots of duplicated code here
+#+x8632-target
+(defcallback %xerr-disp (:address xp :address xcf :int)
+  (with-error-reentry-detection
+      (let* ((frame-ptr (macptr->fixnum xcf))
+             (fn (%get-object xcf x8632::xcf.nominal-function))
+             (op0 (%get-xcf-byte xcf 0))
+             (op1 (%get-xcf-byte xcf 1))
+             (op2 (%get-xcf-byte xcf 2)))
+        (declare (type (unsigned-byte 8) op0 op1 op2))
+        (let* ((skip 2))
+          (if (and (= op0 #xcd)
+                   (>= op1 #x70))
+            (cond ((< op1 #x90)
+                   (setq skip 3)
+                   (setq *error-reentry-count* 0)
+                   (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op1))
+                         (%slot-unbound-trap
+                          (encoded-gpr-lisp xp (ldb (byte 4 4) op2))
+                          (encoded-gpr-lisp xp (ldb (byte 4 0) op2))
+                          frame-ptr)))
+                  ((< op1 #xa0)
+                   ;; #x9x - register X is a symbol.  It's unbound.
+                   (%kernel-restart-internal $xvunbnd
+                                             (list
+                                              (encoded-gpr-lisp
+                                               xp
+                                               (ldb (byte 4 0) op1)))
+                                             frame-ptr))
+                  ((< op1 #xb0)
+                   (%err-disp-internal $xfunbnd
+                                       (list (encoded-gpr-lisp
+                                              xp
+                                              (ldb (byte 4 0) op1)))
+                                       frame-ptr))
+                  ((< op1 #xc0)
+                   (setq skip 3)
+                   (%err-disp-internal 
+                    #.(car (rassoc 'type-error *kernel-simple-error-classes*))
+                    (list (encoded-gpr-lisp
+                           xp
+                           (ldb (byte 4 0) op1))
+                          (logandc2 op2 arch::error-type-error))
+                    frame-ptr))
+                  ((= op1 #xc0)
+                   (%error 'too-few-arguments
+                           (list :nargs (xp-argument-count xp)
+                                 :fn fn)
+                           frame-ptr))
+                  ((= op1 #xc1)
+                   (%error 'too-many-arguments
+                           (list :nargs (xp-argument-count xp)
+                                 :fn fn)
+                           frame-ptr))
+                  ((= op1 #xc2)
+                   (let* ((flags (xp-flags-register xp))
+                          (nargs (xp-argument-count xp))
+                          (carry-bit (logbitp x86::x86-carry-flag-bit flags)))
+                     (if carry-bit
+                       (%error 'too-few-arguments
+                               (list :nargs nargs
+                                     :fn fn)
+                               frame-ptr)
+                       (%error 'too-many-arguments
+                               (list :nargs nargs
+                                     :fn fn)
+                               frame-ptr))))
+                  ((= op1 #xc3)         ;array rank
+                   (%err-disp-internal $XNDIMS
+                                       (list (encoded-gpr-lisp xp (ldb (byte 4 4) op2))
+                                             (encoded-gpr-lisp xp (ldb (byte 4 0) op2)))
+                                       frame-ptr))
+                  ((= op1 #xc6)
+                   (%error (make-condition 'type-error
+                                           :datum (encoded-gpr-lisp xp x8632::temp0)
+                                           :expected-type '(or symbol function)
+                                           :format-control
+                                           "~S is not of type ~S, and can't be FUNCALLed or APPLYed")
+                           nil frame-ptr))
+                  ((= op1 #xc7)
+                   (handle-udf-call xp frame-ptr)
+                   (setq skip 0))
+                  ((or (= op1 #xc8) (= op1 #xcb))
+                   (setq skip 3)
+                   (%error (%rsc-string $xarroob)
+                           (list (encoded-gpr-lisp xp (ldb (byte 4 4) op2))
+                                 (encoded-gpr-lisp xp (ldb (byte 4 0) op2)))
+                           frame-ptr))
+                  ((= op1 #xc9)
+                   (%err-disp-internal $xnotfun
+                                       (list (encoded-gpr-lisp xp x8632::temp0))
+                                       frame-ptr))
+                  ;; #xca = uuo-error-debug-trap
+                  ((= op1 #xcc)
+                   ;; external entry point or foreign variable
+                   (setq skip 3)
+                   (let* ((eep-or-fv (encoded-gpr-lisp xp (ldb (byte 4 4) op2))))
+                     (etypecase eep-or-fv
+                       (external-entry-point
+                        (resolve-eep eep-or-fv)
+                        (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op2))
+                              (eep.address eep-or-fv)))
+                       (foreign-variable
+                        (resolve-foreign-variable eep-or-fv)
+                        (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op2))
+                              (fv.addr eep-or-fv))))))
+                  ((< op1 #xe0)
+                   (setq skip 3)
+                   (if (= op2 x8632::subtag-catch-frame)
+                     (%error (make-condition 'cant-throw-error
+                                             :tag (encoded-gpr-lisp
+                                                   xp
+                                                   (ldb (byte 4 0) op1)))
+                             nil frame-ptr)
+                     (let* ((typename
+                             (cond ((= op2 x8632::tag-fixnum) 'fixnum)
+                                   ((= op2 x8632::subtag-character) 'character)
+                                   ((= op2 x8632::fulltag-cons) 'cons)
+                                   ((= op2 x8632::tag-misc) 'uvector)
+                                   (t (let* ((class (logand op2 x8632::fulltagmask))
+                                             (high5 (ash op2 (- x8632::ntagbits))))
+                                        (cond ((= class x8632::fulltag-nodeheader)
+                                               (svref *nodeheader-types* high5))
+                                              ((= class x8632::fulltag-immheader)
+                                               (svref *immheader-types* high5))
+                                              (t (list 'bogus op2))))))))
+                       (%error (make-condition 'type-error
+                                               :datum (encoded-gpr-lisp
+                                                       xp
+                                                       (ldb (byte 4 0) op1))
+                                               :expected-type typename)
+                               nil
+                               frame-ptr))))
+                  ((< op1 #xf0)
+                   (%error (make-condition 'type-error
+                                           :datum (encoded-gpr-lisp
+                                                   xp
+                                                   (ldb (byte 4 0) op1))
+                                           :expected-type 'list)
+                           nil
+                           frame-ptr))
+                  (t
+                   (%error (make-condition 'type-error
+                                           :datum (encoded-gpr-lisp
+                                                   xp
+                                                   (ldb (byte 4 0) op1))
+                                           :expected-type 'fixnum)
+                           nil
+                           frame-ptr)))
+            (%error "Unknown trap: #x~x~%xp=~s"
+                    (list (list op0 op1 op2) xp)
+                    frame-ptr))
+          skip))))
                  
-                 
-                
-                
-                 
-
-
-
-
-
-                    
-                
-