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

Last change on this file since 14215 was 14038, checked in by ehuelsmann, 8 years ago

Make the JVM exit with a non-zero (89) value
when we have errors nesting too deep.

Helps Mark write bisect programs :-)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 6.6 KB
Line 
1;;; signal.lisp
2;;;
3;;; Copyright (C) 2003-2007 Peter Graves
4;;; $Id: signal.lisp 14038 2012-08-01 20:49:12Z 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 *debug-io*
70                      "~%Maximum error depth exceeded (~D nested errors) with '~A'.~%"
71                      *current-error-depth* condition)
72             (if (fboundp 'internal-debug)
73                 (internal-debug)
74                 (quit :status 89))) ;; it's a prime and a fibonacci!
75            (t
76             (invoke-debugger condition))))))
77
78;; COERCE-TO-CONDITION is redefined in clos.lisp.
79(defun coerce-to-condition (datum arguments default-type fun-name)
80  (cond ((typep datum 'condition)
81         (when arguments
82           (error 'simple-type-error
83                  :datum arguments
84                  :expected-type 'null
85                  :format-control "You may not supply additional arguments when giving ~S to ~S."
86                  :format-arguments (list datum fun-name)))
87         datum)
88        ((symbolp datum)
89         (%make-condition datum arguments))
90        ((or (stringp datum) (functionp datum))
91         (%make-condition default-type
92                          (list :format-control datum
93                                :format-arguments arguments)))
94        (t
95         (error 'simple-type-error
96                :datum datum
97                :expected-type '(or symbol string)
98                :format-control "Bad argument to ~S: ~S."
99                :format-arguments (list fun-name datum)))))
100
101(defmacro handler-bind (bindings &body forms)
102  (dolist (binding bindings)
103    (unless (and (consp binding) (= (length binding) 2))
104      (error "ill-formed handler binding ~S" binding)))
105  `(let ((*handler-clusters*
106          (cons (list ,@(mapcar (lambda (x) `(cons ',(car x) ,(cadr x)))
107                                bindings))
108                *handler-clusters*)))
109     (java:jrun-exception-protected
110      (lambda ()
111        (progn
112          ,@forms)))))
113
114(defmacro handler-case (form &rest cases)
115  (let ((no-error-clause (assoc ':no-error cases)))
116    (if no-error-clause
117        (let ((normal-return (make-symbol "normal-return"))
118              (error-return  (make-symbol "error-return")))
119          `(block ,error-return
120             (multiple-value-call (lambda ,@(cdr no-error-clause))
121                                  (block ,normal-return
122                                    (return-from ,error-return
123                                                 (handler-case (return-from ,normal-return ,form)
124                                                   ,@(remove no-error-clause cases)))))))
125        (let ((tag (gensym))
126              (var (gensym))
127              (annotated-cases (mapcar (lambda (case) (cons (gensym) case))
128                                       cases)))
129          `(block ,tag
130             (let ((,var nil))
131               (declare (ignorable ,var))
132               (tagbody
133                (handler-bind
134                  ,(mapcar (lambda (annotated-case)
135                             (list (cadr annotated-case)
136                                   `(lambda (temp)
137                                      ,(if (caddr annotated-case)
138                                           `(setq ,var temp)
139                                           '(declare (ignore temp)))
140                                      (go ,(car annotated-case)))))
141                           annotated-cases)
142                  (return-from ,tag
143                               ,form))
144                ,@(mapcan
145                   (lambda (annotated-case)
146                     (list (car annotated-case)
147                           (let ((body (cdddr annotated-case)))
148                             `(return-from
149                               ,tag
150                               ,(cond ((caddr annotated-case)
151                                       `(let ((,(caaddr annotated-case)
152                                                ,var))
153                                          ,@body))
154                                      (t
155                                       `(locally ,@body)))))))
156                   annotated-cases))))))))
Note: See TracBrowser for help on using the repository browser.