Changeset 177
- Timestamp:
- Jan 3, 2004, 11:39:01 AM (21 years ago)
- File:
-
- 1 edited
-
trunk/ccl/level-1/ppc-error-signal.lisp (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
trunk/ccl/level-1/ppc-error-signal.lisp
r85 r177 22 22 23 23 (defcallback 24 %err-disp 25 (:address xp :unsigned-fullword fn-reg :unsigned-fullword pc-or-index :signed-fullword errnum :unsigned-fullword rb :signed-fullword continuable) 26 (let ((fn (unless (eql fn-reg 0) (xp-gpr-lisp xp fn-reg))) 27 (err-fn (if (eql continuable 0) '%err-disp-internal '%kernel-restart-internal))) 28 (if (eql errnum ppc32::error-stack-overflow) 29 (handle-stack-overflow xp fn rb) 30 (with-xp-stack-frames (xp fn frame-ptr) ; execute body with dummy stack frame(s) 31 (with-error-reentry-detection 32 (let* ((rb-value (xp-gpr-lisp xp rb)) 33 (res 34 (cond ((< errnum 0) 35 (%err-disp-internal errnum nil frame-ptr)) 36 ((logtest errnum ppc32::error-type-error) 37 (funcall err-fn 38 #.(car (rassoc 'type-error *kernel-simple-error-classes*)) 39 (list rb-value (logand errnum 63)) 40 frame-ptr)) 41 ((eql errnum ppc32::error-udf) 42 (funcall err-fn $xfunbnd (list rb-value) frame-ptr)) 43 ((eql errnum ppc32::error-throw-tag-missing) 44 (%error (make-condition 'cant-throw-error 45 :tag rb-value) 46 nil frame-ptr)) 47 ((eql errnum ppc32::error-cant-call) 48 (%error (make-condition 'type-error 49 :datum rb-value 50 :expected-type '(or symbol function) 51 :format-control 52 "~S is not of type ~S, and can't be FUNCALLed or APPLYed") 53 nil frame-ptr)) 54 ((eql errnum ppc32::error-udf-call) 55 (return-from %err-disp 56 (handle-udf-call xp frame-ptr))) 57 ((eql errnum ppc32::error-alloc-failed) 58 (%error (make-condition 59 'simple-storage-condition 60 :format-control (%rsc-string $xmemfull)) 61 nil frame-ptr)) 62 ((eql errnum ppc32::error-memory-full) 63 (%error (make-condition 64 'simple-storage-condition 65 :format-control (%rsc-string $xnomem)) 66 nil frame-ptr)) 67 ((or (eql errnum ppc32::error-fpu-exception-double) 68 (eql errnum ppc32::error-fpu-exception-single)) 69 (let* ((code-vector (and fn (uvref fn 0))) 70 (instr (if code-vector 71 (uvref code-vector pc-or-index) 72 (%get-long (%int-to-ptr pc-or-index))))) 73 (let* ((minor (ldb (byte 5 1) instr)) 74 (fra (ldb (byte 5 16) instr)) 75 (frb (ldb (byte 5 11) instr)) 76 (frc (ldb (byte 5 6) instr))) 77 (declare (fixnum minor fra frb frc)) 78 (if (= minor 12) ; FRSP 79 (%err-disp-internal $xcoerce (list (xp-double-float xp frc) 'short-float) frame-ptr) 80 (flet ((coerce-to-op-type (double-arg) 81 (if (eql errnum ppc32::error-fpu-exception-double) 82 double-arg 83 (handler-case (coerce double-arg 'short-float) 84 (error (c) (declare (ignore c)) double-arg))))) 85 (multiple-value-bind (status control) (xp-fpscr-info xp) 86 (%error (make-condition (fp-condition-from-fpscr status control) 87 :operation (fp-minor-opcode-operation minor) 88 :operands (list (coerce-to-op-type 89 (xp-double-float xp fra)) 90 (if (= minor 25) 91 (coerce-to-op-type 92 (xp-double-float xp frc)) 93 (coerce-to-op-type 94 (xp-double-float xp frb))))) 95 nil 96 frame-ptr))))))) 97 ((eql errnum ppc32::error-excised-function-call) 98 (%error "~s: code has been excised." (list (xp-gpr-lisp xp ppc32::nfn)) frame-ptr)) 99 ((eql errnum ppc32::error-too-many-values) 100 (%err-disp-internal $xtoomanyvalues (list rb-value) frame-ptr)) 101 (t (%error "Unknown error #~d with arg: ~d" (list errnum rb-value) frame-ptr))))) 102 (setf (xp-gpr-lisp xp rb) res) ; munge register for continuation 103 )))))) 24 %xerr-disp 25 (:address xp :unsigned-fullword fn-reg :unsigned-fullword pc-or-index :signed-fullword errnum :unsigned-fullword rb :signed-fullword continuable) 26 (block %err-disp 27 (let ((fn (unless (eql fn-reg 0) (xp-gpr-lisp xp fn-reg))) 28 (err-fn (if (eql continuable 0) '%err-disp-internal '%kernel-restart-internal))) 29 (if (eql errnum ppc32::error-stack-overflow) 30 (handle-stack-overflow xp fn rb) 31 (with-xp-stack-frames (xp fn frame-ptr) ; execute body with dummy stack frame(s) 32 (with-error-reentry-detection 33 (let* ((rb-value (xp-gpr-lisp xp rb)) 34 (res 35 (cond ((< errnum 0) 36 (%err-disp-internal errnum nil frame-ptr)) 37 ((logtest errnum ppc32::error-type-error) 38 (funcall err-fn 39 #.(car (rassoc 'type-error *kernel-simple-error-classes*)) 40 (list rb-value (logand errnum 63)) 41 frame-ptr)) 42 ((eql errnum ppc32::error-udf) 43 (funcall err-fn $xfunbnd (list rb-value) frame-ptr)) 44 ((eql errnum ppc32::error-throw-tag-missing) 45 (%error (make-condition 'cant-throw-error 46 :tag rb-value) 47 nil frame-ptr)) 48 ((eql errnum ppc32::error-cant-call) 49 (%error (make-condition 'type-error 50 :datum rb-value 51 :expected-type '(or symbol function) 52 :format-control 53 "~S is not of type ~S, and can't be FUNCALLed or APPLYed") 54 nil frame-ptr)) 55 ((eql errnum ppc32::error-udf-call) 56 (return-from %err-disp 57 (handle-udf-call xp frame-ptr))) 58 ((eql errnum ppc32::error-alloc-failed) 59 (%error (make-condition 60 'simple-storage-condition 61 :format-control (%rsc-string $xmemfull)) 62 nil frame-ptr)) 63 ((eql errnum ppc32::error-memory-full) 64 (%error (make-condition 65 'simple-storage-condition 66 :format-control (%rsc-string $xnomem)) 67 nil frame-ptr)) 68 ((or (eql errnum ppc32::error-fpu-exception-double) 69 (eql errnum ppc32::error-fpu-exception-single)) 70 (let* ((code-vector (and fn (uvref fn 0))) 71 (instr (if code-vector 72 (uvref code-vector pc-or-index) 73 (%get-long (%int-to-ptr pc-or-index))))) 74 (let* ((minor (ldb (byte 5 1) instr)) 75 (fra (ldb (byte 5 16) instr)) 76 (frb (ldb (byte 5 11) instr)) 77 (frc (ldb (byte 5 6) instr))) 78 (declare (fixnum minor fra frb frc)) 79 (if (= minor 12) ; FRSP 80 (%err-disp-internal $xcoerce (list (xp-double-float xp frc) 'short-float) frame-ptr) 81 (flet ((coerce-to-op-type (double-arg) 82 (if (eql errnum ppc32::error-fpu-exception-double) 83 double-arg 84 (handler-case (coerce double-arg 'short-float) 85 (error (c) (declare (ignore c)) double-arg))))) 86 (multiple-value-bind (status control) (xp-fpscr-info xp) 87 (%error (make-condition (fp-condition-from-fpscr status control) 88 :operation (fp-minor-opcode-operation minor) 89 :operands (list (coerce-to-op-type 90 (xp-double-float xp fra)) 91 (if (= minor 25) 92 (coerce-to-op-type 93 (xp-double-float xp frc)) 94 (coerce-to-op-type 95 (xp-double-float xp frb))))) 96 nil 97 frame-ptr))))))) 98 ((eql errnum ppc32::error-excised-function-call) 99 (%error "~s: code has been excised." (list (xp-gpr-lisp xp ppc32::nfn)) frame-ptr)) 100 ((eql errnum ppc32::error-too-many-values) 101 (%err-disp-internal $xtoomanyvalues (list rb-value) frame-ptr)) 102 (t (%error "Unknown error #~d with arg: ~d" (list errnum rb-value) frame-ptr))))) 103 (setf (xp-gpr-lisp xp rb) res) ; munge register for continuation 104 ))))))) 104 105 105 106
Note:
See TracChangeset
for help on using the changeset viewer.
