1 |
|
(in-package 'si) |
2 |
|
|
3 |
|
(defvar *old-handler* #'si::universal-error-handler) |
4 |
|
|
5 |
|
(defentry ihs_function_name (object) (object "ihs_function_name")) |
6 |
|
|
7 |
|
|
8 |
|
(defun new-universal-error-handler |
9 |
|
(a b c d e &rest l &aux (i 0) (top (si::ihs-top))) |
10 |
|
(declare (fixnum i top)) |
11 |
|
(if (search "stack overflow" e) |
12 |
|
(progn (format t "~a in ~a" e d) |
13 |
|
(format t "invocation stack:") |
14 |
|
(loop (cond ((or (> i 20) |
15 |
|
(< top 10)) |
16 |
|
(return nil))) |
17 |
|
(setq i (+ i 1)) |
18 |
|
(setq top (- top 1)) |
19 |
|
(format t "< ~s " (ihs_function_name (si::ihs-fun top)))) |
20 |
|
(format t "Jumping to top") |
21 |
|
(throw *quit-tag* nil) |
22 |
|
) |
23 |
|
(apply *old-handler* a b c d e l))) |
24 |
|
|
25 |
|
|
26 |
|
(setf (symbol-function 'si::universal-error-handler) |
27 |
|
#'new-universal-error-handler) |
28 |
|
|
29 |
|
|