/[gcl]/gcl/lsp/gcl_stack-problem.lsp
ViewVC logotype

Diff of /gcl/lsp/gcl_stack-problem.lsp

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

revision 1.1 by camm, Sun Sep 14 02:30:35 2003 UTC revision 1.2 by camm, Sun Sep 14 02:43:06 2003 UTC
# Line 0  Line 1 
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    

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26