/[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.5 by wlott, Wed Jun 6 20:56:52 1990 UTC revision 1.6 by wlott, Sat Jun 9 00:55:37 1990 UTC
# Line 382  Line 382 
382    
383    
384  #+new-compiler  #+new-compiler
385    (defvar *finding-name* nil)
386    
387    #+new-compiler
388    (defun find-interrupted-name ()
389      (if *finding-name*
390          "<error finding name>"
391          (handler-case
392              (let ((*finding-name* t))
393                (do ((frame (di:top-frame) (di:frame-down frame)))
394                    ((or (null frame)
395                         (di::frame-escaped frame))
396                     (if frame
397                         (di:debug-function-name
398                          (di:frame-debug-function frame))
399                         "<error finding name>"))))
400            (error () "<error finding name>")
401            (di:debug-condition () "<error finding name>"))))
402    
403    
404    #+new-compiler
405  (defun internal-error (signal code scp)  (defun internal-error (signal code scp)
406    (declare (ignore signal code))    (declare (ignore signal code))
407    (alien-bind ((sc (make-alien 'mach:sigcontext    (alien-bind ((sc (make-alien 'mach:sigcontext
# Line 390  Line 410 
410                     mach:sigcontext                     mach:sigcontext
411                     t)                     t)
412                 (regs (mach:sigcontext-regs (alien-value sc)) mach:int-array t))                 (regs (mach:sigcontext-regs (alien-value sc)) mach:int-array t))
413      (let* ((pc (int-sap (+ (alien-access      (let* ((pc (sap+ (alien-access
414                              (mach:sigcontext-pc                        (mach:sigcontext-pc
415                               (alien-value sc)))                         (alien-value sc)))
416                             (if (logbitp 31                       (if (logbitp 31
417                                          (alien-access                                    (alien-access
418                                           (mach:sigcontext-cause                                     (mach:sigcontext-cause
419                                            (alien-value sc))))                                      (alien-value sc))))
420                                 4                           4
421                                 0))))                           0)))
422             (bad-inst (sap-ref-32 pc 0))             #+nil (bad-inst (sap-ref-32 pc 0))
423             (number (sap-ref-8 pc 4))             (number (sap-ref-8 pc 4))
424             (info (svref *internal-errors* number))             (info (svref *internal-errors* number))
425             (args nil))             (args nil))
# Line 410  Line 430 
430                  (alien-access (mach:int-array-ref (alien-value regs)                  (alien-access (mach:int-array-ref (alien-value regs)
431                                                    (sap-ref-8 ptr 0))))                                                    (sap-ref-8 ptr 0))))
432                 args)))                 args)))
433        (error "~A [~D]:~{ ~S~}"        (error 'simple-error
434               (if info (error-info-description info) "Unknown error")               :format-string "~A [~D]:~{ ~S~}"
435               number               :format-arguments (list (if info
436               (nreverse args)))))                                           (error-info-description info)
437                                             "Unknown error")
438                                         number
439                                         (nreverse args))
440                 :function-name (find-interrupted-name)))))

Legend:
Removed from v.1.5  
changed lines
  Added in v.1.6

  ViewVC Help
Powered by ViewVC 1.1.5