/[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.22 by wlott, Fri Feb 14 23:45:02 1992 UTC revision 1.23 by wlott, Tue Mar 10 18:35:38 1992 UTC
# Line 651  Line 651 
651  ;;;  ;;;
652  (defun find-caller-name ()  (defun find-caller-name ()
653    (if *finding-name*    (if *finding-name*
654        "<error finding name>"        (values "<error finding name>" nil)
655        (handler-case        (handler-case
656            (let ((*finding-name* t))            (let* ((*finding-name* t)
657              (di:debug-function-name                   (frame (di:frame-down (di:frame-down (di:top-frame))))
658               (di:frame-debug-function                   (name (di:debug-function-name
659                (di:frame-down (di:frame-down (di:top-frame))))))                          (di:frame-debug-function frame))))
660          (error () "<error finding name>")              (di:flush-frames-above frame)
661          (di:debug-condition () "<error finding name>"))))              (values name frame))
662            (error ()
663              (values "<error finding name>" nil))
664            (di:debug-condition ()
665              (values "<error finding name>" nil)))))
666    
667    
668  (defun find-interrupted-name ()  (defun find-interrupted-name ()
669    (if *finding-name*    (if *finding-name*
670        "<error finding name>"        (values "<error finding name>" nil)
671        (handler-case        (handler-case
672            (let ((*finding-name* t))            (let ((*finding-name* t))
673              (do ((frame (di:top-frame) (di:frame-down frame)))              (do ((frame (di:top-frame) (di:frame-down frame)))
# Line 671  Line 675 
675                       (and (di::compiled-frame-p frame)                       (and (di::compiled-frame-p frame)
676                            (di::compiled-frame-escaped frame)))                            (di::compiled-frame-escaped frame)))
677                   (if (di::compiled-frame-p frame)                   (if (di::compiled-frame-p frame)
678                       (di:debug-function-name                       (values (di:debug-function-name
679                        (di:frame-debug-function frame))                                (di:frame-debug-function frame))
680                       "<error finding name>"))))                               frame)
681          (error () "<error finding name>")                       (values "<error finding name>" nil)))))
682          (di:debug-condition () "<error finding name>"))))          (error ()
683              (values "<error finding name>" nil))
684            (di:debug-condition ()
685              (values "<error finding name>" nil)))))
686    
687    
688  ;;;; internal-error signal handler.  ;;;; internal-error signal handler.
# Line 687  Line 694 
694       (multiple-value-bind       (multiple-value-bind
695           (error-number arguments)           (error-number arguments)
696           (vm:internal-error-arguments scp)           (vm:internal-error-arguments scp)
697         (let ((fp (int-sap (vm:sigcontext-register scp vm::cfp-offset)))         (multiple-value-bind
698               (name (find-interrupted-name))             (name debug:*stack-top-hint*)
699               (info (and (< -1 error-number (length *internal-errors*))             (find-interrupted-name)
700                          (svref *internal-errors* error-number))))           (let ((fp (int-sap (vm:sigcontext-register scp vm::cfp-offset)))
701           (cond ((null info)                 (info (and (< -1 error-number (length *internal-errors*))
702                  (error 'simple-error                            (svref *internal-errors* error-number))))
703                         :function-name name             (cond ((null info)
704                         :format-string                    (error 'simple-error
705                         "Unknown internal error, ~D?  args=~S"                           :function-name name
706                         :format-arguments                           :format-string
707                         (list error-number                           "Unknown internal error, ~D?  args=~S"
708                               (mapcar #'(lambda (sc-offset)                           :format-arguments
709                                           (di::sub-access-debug-var-slot                           (list error-number
710                                            fp sc-offset scp))                                 (mapcar #'(lambda (sc-offset)
711                                       arguments))))                                             (di::sub-access-debug-var-slot
712                 ((null (error-info-function info))                                              fp sc-offset scp))
713                  (error 'simple-error                                         arguments))))
714                         :function-name name                   ((null (error-info-function info))
715                         :format-string                    (error 'simple-error
716                         "Internal error ~D: ~A.  args=~S"                           :function-name name
717                         :format-arguments                           :format-string
718                         (list error-number                           "Internal error ~D: ~A.  args=~S"
719                               (error-info-description info)                           :format-arguments
720                               (mapcar #'(lambda (sc-offset)                           (list error-number
721                                           (di::sub-access-debug-var-slot                                 (error-info-description info)
722                                            fp sc-offset scp))                                 (mapcar #'(lambda (sc-offset)
723                                       arguments))))                                             (di::sub-access-debug-var-slot
724                  (t                                              fp sc-offset scp))
725                   (funcall (error-info-function info) name fp scp                                         arguments))))
726                            arguments))))))))                   (t
727                      (funcall (error-info-function info) name fp scp
728                               arguments)))))))))
729    

Legend:
Removed from v.1.22  
changed lines
  Added in v.1.23

  ViewVC Help
Powered by ViewVC 1.1.5