/[cmucl]/src/code/pmax-vm.lisp
ViewVC logotype

Diff of /src/code/pmax-vm.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.3 by wlott, Mon Nov 26 15:16:43 1990 UTC revision 1.4 by wlott, Mon Nov 26 18:55:08 1990 UTC
# Line 57  Line 57 
57  ;;; Given the sigcontext, extract the internal error arguments from the  ;;; Given the sigcontext, extract the internal error arguments from the
58  ;;; instruction stream.  ;;; instruction stream.
59  ;;;  ;;;
60  (defun internal-error-arguments (scp)  (defun internal-error-arguments (sc)
61    (alien-bind ((sc (make-alien 'mach:sigcontext    (alien-bind ((sc sc mach:sigcontext t))
62                                 #.(c-sizeof 'mach:sigcontext)      (let ((pc (alien-access (mach:sigcontext-pc (alien-value sc)))))
63                                 scp)        (declare (type system-area-pointer pc))
64                     mach:sigcontext        (when (logbitp 31
65                     t)                       (alien-access (mach:sigcontext-cause (alien-value sc))))
66                 (regs (mach:sigcontext-regs (alien-value sc)) mach:int-array t))          (setf pc (sap+ pc 4)))
67      (let* ((original-pc (alien-access (mach:sigcontext-pc (alien-value sc))))        (when (= (sap-ref-8 pc 4) 255)
68             (pc (sap+ original-pc          (setf pc (sap+ pc 1)))
69                       (+ (if (logbitp 31        (let* ((length (sap-ref-8 pc 4))
70                                       (alien-access               (vector (make-array length :element-type '(unsigned-byte 8))))
71                                        (mach:sigcontext-cause          (declare (type (unsigned-byte 8) length)
72                                         (alien-value sc))))                   (type (simple-array (unsigned-byte 8) (*)) vector))
73                              4          (copy-from-system-area pc (* vm:byte-bits 5)
74                              0)                                 vector (* vm:word-bits
75                          (if (= (sap-ref-8 original-pc 4) 255)                                           vm:vector-data-offset)
76                              1                                 (* length vm:byte-bits))
77                              0))))          (let* ((index 0)
78             (length (sap-ref-8 pc 4))                 (error-number (c::read-var-integer vector index)))
79             (vector (make-array length :element-type '(unsigned-byte 8))))            (collect ((sc-offsets))
80        (copy-from-system-area pc (* vm:byte-bits 5)              (loop
81                               vector (* vm:word-bits                (when (>= index length)
82                                         vm:vector-data-offset)                  (return))
83                               (* length vm:byte-bits))                (sc-offsets (c::read-var-integer vector index)))
84        (let* ((index 0)              (values error-number (sc-offsets))))))))
              (error-number (c::read-var-integer vector index)))  
         (collect ((sc-offsets))  
           (loop  
             (when (>= index length)  
               (return))  
             (sc-offsets (c::read-var-integer vector index)))  
           (values error-number (sc-offsets)))))))  
85    

Legend:
Removed from v.1.3  
changed lines
  Added in v.1.4

  ViewVC Help
Powered by ViewVC 1.1.5