source: trunk/abcl/src/org/armedbear/lisp/signal.lisp @ 12314

Last change on this file since 12314 was 12314, checked in by ehuelsmann, 11 years ago

Upon OutOfMemoryError? or StackOverflowError?, unwind the stack

to the first enclosing HANDLER-BIND, allowing it to bind a
handler to STORAGE-CONDITION.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 6.5 KB
Line 
1;;; signal.lisp
2;;;
3;;; Copyright (C) 2003-2007 Peter Graves
4;;; $Id: signal.lisp 12314 2009-12-30 22:04:55Z ehuelsmann $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
19;;;
20;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32;;; Adapted from SBCL.
33
34(in-package "SYSTEM")
35
36(export 'coerce-to-condition)
37
38(defvar *maximum-error-depth* 10)
39
40(defvar *current-error-depth* 0)
41
42(defvar *handler-clusters* nil)
43
44(defvar *break-on-signals* nil)
45
46(defun signal (datum &rest arguments)
47  (let ((condition (coerce-to-condition datum arguments 'simple-condition 'signal))
48        (*handler-clusters* *handler-clusters*))
49    (let* ((old-bos *break-on-signals*)
50           (*break-on-signals* nil))
51      (when (typep condition old-bos)
52        (let ((*saved-backtrace* (sys:backtrace)))
53          (break "~A~%BREAK called because of *BREAK-ON-SIGNALS* (now rebound to NIL)."
54                 condition))))
55    (loop
56      (unless *handler-clusters*
57        (return))
58      (let ((cluster (pop *handler-clusters*)))
59        (dolist (handler cluster)
60          (when (typep condition (car handler))
61            (funcall (cdr handler) condition)))))
62    nil))
63
64(defun error (datum &rest arguments)
65  (let ((condition (coerce-to-condition datum arguments 'simple-error 'error)))
66    (signal condition)
67    (let ((*current-error-depth* (1+ *current-error-depth*)))
68      (cond ((> *current-error-depth* *maximum-error-depth*)
69             (%format t "~%Maximum error depth exceeded (~D nested errors).~%"
70                      *current-error-depth*)
71             (if (fboundp 'internal-debug)
72                 (internal-debug)
73                 (quit)))
74            (t
75             (invoke-debugger condition))))))
76
77;; COERCE-TO-CONDITION is redefined in clos.lisp.
78(defun coerce-to-condition (datum arguments default-type fun-name)
79  (cond ((typep datum 'condition)
80         (when arguments
81           (error 'simple-type-error
82                  :datum arguments
83                  :expected-type 'null
84                  :format-control "You may not supply additional arguments when giving ~S to ~S."
85                  :format-arguments (list datum fun-name)))
86         datum)
87        ((symbolp datum)
88         (%make-condition datum arguments))
89        ((or (stringp datum) (functionp datum))
90         (%make-condition default-type
91                          (list :format-control datum
92                                :format-arguments arguments)))
93        (t
94         (error 'simple-type-error
95                :datum datum
96                :expected-type '(or symbol string)
97                :format-control "Bad argument to ~S: ~S."
98                :format-arguments (list fun-name datum)))))
99
100(defmacro handler-bind (bindings &body forms)
101  (dolist (binding bindings)
102    (unless (and (consp binding) (= (length binding) 2))
103      (error "ill-formed handler binding ~S" binding)))
104  `(let ((*handler-clusters*
105          (cons (list ,@(mapcar (lambda (x) `(cons ',(car x) ,(cadr x)))
106                                bindings))
107                *handler-clusters*)))
108     (java:jrun-exception-protected
109      (lambda ()
110        (progn
111          ,@forms)))))
112
113(defmacro handler-case (form &rest cases)
114  (let ((no-error-clause (assoc ':no-error cases)))
115    (if no-error-clause
116        (let ((normal-return (make-symbol "normal-return"))
117              (error-return  (make-symbol "error-return")))
118          `(block ,error-return
119             (multiple-value-call (lambda ,@(cdr no-error-clause))
120                                  (block ,normal-return
121                                    (return-from ,error-return
122                                                 (handler-case (return-from ,normal-return ,form)
123                                                   ,@(remove no-error-clause cases)))))))
124        (let ((tag (gensym))
125              (var (gensym))
126              (annotated-cases (mapcar (lambda (case) (cons (gensym) case))
127                                       cases)))
128          `(block ,tag
129             (let ((,var nil))
130               (declare (ignorable ,var))
131               (tagbody
132                (handler-bind
133                  ,(mapcar (lambda (annotated-case)
134                             (list (cadr annotated-case)
135                                   `(lambda (temp)
136                                      ,(if (caddr annotated-case)
137                                           `(setq ,var temp)
138                                           '(declare (ignore temp)))
139                                      (go ,(car annotated-case)))))
140                           annotated-cases)
141                  (return-from ,tag
142                               ,form))
143                ,@(mapcan
144                   (lambda (annotated-case)
145                     (list (car annotated-case)
146                           (let ((body (cdddr annotated-case)))
147                             `(return-from
148                               ,tag
149                               ,(cond ((caddr annotated-case)
150                                       `(let ((,(caaddr annotated-case)
151                                                ,var))
152                                          ,@body))
153                                      (t
154                                       `(locally ,@body)))))))
155                   annotated-cases))))))))
Note: See TracBrowser for help on using the repository browser.