/[cmucl]/src/code/interr.lisp
ViewVC logotype

Diff of /src/code/interr.lisp

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

revision 1.21 by ram, Tue Jan 21 23:41:15 1992 UTC revision 1.21.1.1 by wlott, Fri Jan 24 04:31:11 1992 UTC
# Line 110  Line 110 
110      `(%deferr ',name      `(%deferr ',name
111                ,(meta-error-number name)                ,(meta-error-number name)
112                ,description                ,description
               #+new-compiler  
113                #'(lambda (name ,fp ,sigcontext ,sc-offsets)                #'(lambda (name ,fp ,sigcontext ,sc-offsets)
114                    (declare (ignorable name ,fp ,sigcontext ,sc-offsets))                    (declare (ignorable name ,fp ,sigcontext ,sc-offsets))
115                    (macrolet ((set-value (var value)                    (macrolet ((set-value (var value)
# Line 144  Line 143 
143    
144  ) ; Eval-When (Compile Eval)  ) ; Eval-When (Compile Eval)
145    
146  (defun %deferr (name number description #+new-compiler function)  (defun %deferr (name number description function)
147    (when (>= number (length *internal-errors*))    (when (>= number (length *internal-errors*))
148      (setf *internal-errors*      (setf *internal-errors*
149            (replace (make-array (+ number 10) :initial-element nil)            (replace (make-array (+ number 10) :initial-element nil)
# Line 152  Line 151 
151    (setf (svref *internal-errors* number)    (setf (svref *internal-errors* number)
152          (make-error-info :name name          (make-error-info :name name
153                           :description description                           :description description
154                           #+new-compiler :function #+new-compiler function))                           :function function))
155    name)    name)
156    
157    
# Line 682  Line 681 
681  ;;;; internal-error signal handler.  ;;;; internal-error signal handler.
682    
683  (defun internal-error (scp continuable)  (defun internal-error (scp continuable)
684    (declare (ignore continuable))    (declare (type system-area-pointer scp) (ignore continuable))
685    (infinite-error-protect    (infinite-error-protect
686      (alien-bind ((sc (make-alien 'mach:sigcontext     (let ((scp (alien:sap-alien scp (* unix:sigcontext))))
687                                   #.(c-sizeof 'mach:sigcontext)       (multiple-value-bind
688                                   scp)           (error-number arguments)
689                       mach:sigcontext           (vm:internal-error-arguments scp)
690                       t))         (let ((fp (int-sap (vm:sigcontext-register scp vm::cfp-offset)))
691        (multiple-value-bind               (name (find-interrupted-name))
692            (error-number arguments)               (info (and (< -1 error-number (length *internal-errors*))
693            (vm:internal-error-arguments (alien-value sc))                          (svref *internal-errors* error-number))))
694          (let ((fp (int-sap (di::escape-register (alien-value sc)           (cond ((null info)
695                                                  vm::cfp-offset)))                  (error 'simple-error
696                (name (find-interrupted-name))                         :function-name name
697                (info (and (< -1 error-number (length *internal-errors*))                         :format-string
698                           (svref *internal-errors* error-number))))                         "Unknown internal error, ~D?  args=~S"
699            (cond ((null info)                         :format-arguments
700                   (error 'simple-error                         (list error-number
701                          :function-name name                               (mapcar #'(lambda (sc-offset)
702                          :format-string                                           (di::sub-access-debug-var-slot
703                          "Unknown internal error, ~D?  args=~S"                                            fp sc-offset scp))
704                          :format-arguments                                       arguments))))
705                          (list error-number                 ((null (error-info-function info))
706                                (mapcar #'(lambda (sc-offset)                  (error 'simple-error
707                                            (di::sub-access-debug-var-slot                         :function-name name
708                                             fp                         :format-string
709                                             sc-offset                         "Internal error ~D: ~A.  args=~S"
710                                             (alien-value sc)))                         :format-arguments
711                                        arguments))))                         (list error-number
712                  ((null (error-info-function info))                               (error-info-description info)
713                   (error 'simple-error                               (mapcar #'(lambda (sc-offset)
714                          :function-name name                                           (di::sub-access-debug-var-slot
715                          :format-string                                            fp sc-offset scp))
716                          "Internal error ~D: ~A.  args=~S"                                       arguments))))
                         :format-arguments  
                         (list error-number  
                               (error-info-description info)  
                               (mapcar #'(lambda (sc-offset)  
                                           (di::sub-access-debug-var-slot  
                                            fp  
                                            sc-offset  
                                            (alien-value sc)))  
                                       arguments))))  
717                  (t                  (t
718                   (funcall (error-info-function info) name fp sc                   (funcall (error-info-function info) name fp scp
719                            arguments))))))))                            arguments))))))))
720    

Legend:
Removed from v.1.21  
changed lines
  Added in v.1.21.1.1

  ViewVC Help
Powered by ViewVC 1.1.5