source: trunk/j/src/org/armedbear/lisp/signal.lisp @ 9266

Last change on this file since 9266 was 8930, checked in by piso, 16 years ago

SIGNAL: don't rebind *BREAK-ON-SIGNALS* to NIL.

File size: 5.8 KB
Line 
1;;; signal.lisp
2;;;
3;;; Copyright (C) 2003-2005 Peter Graves
4;;; $Id: signal.lisp,v 1.11 2005-04-14 14:53:42 piso Exp $
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., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19
20;;; Adapted from SBCL.
21
22(in-package #:system)
23
24(defvar *maximum-error-depth* 10)
25
26(defvar *current-error-depth* 0)
27
28(defvar *handler-clusters* ())
29
30(defvar *break-on-signals* nil)
31
32(defun signal (datum &rest arguments)
33  (let ((condition (coerce-to-condition datum arguments 'simple-condition 'signal))
34        (*handler-clusters* *handler-clusters*))
35    (when (typep condition *break-on-signals*)
36      (let ((*saved-backtrace* (backtrace-as-list)))
37        (break "~A~%BREAK called because of *BREAK-ON-SIGNALS*" condition)))
38    (loop
39      (unless *handler-clusters*
40        (return))
41      (let ((cluster (pop *handler-clusters*)))
42        (dolist (handler cluster)
43          (when (typep condition (car handler))
44            (funcall (cdr handler) condition)))))
45    (when (typep condition 'serious-condition)
46      (let ((*current-error-depth* (1+ *current-error-depth*)))
47        (cond ((> *current-error-depth* *maximum-error-depth*)
48               (%format t "~%Maximum error depth exceeded (~D nested errors).~%"
49                        *current-error-depth*)
50               (if (fboundp 'internal-debug)
51                   (internal-debug)
52                   (quit)))
53              (t
54               (let ((*saved-backtrace* (backtrace-as-list)))
55                 (invoke-debugger condition))))))
56    nil))
57
58;; COERCE-TO-CONDITION is going to be redefined in clos.lisp, so we define it
59;; in this file after SIGNAL so the call to it in SIGNAL is NOTINLINE. We could
60;; use (DECLAIM (NOTINLINE COERCE-TO-CONDITON)) to achieve the same effect more
61;; reliably if our compiler understood that kind of talk.
62(defun coerce-to-condition (datum arguments default-type fun-name)
63  (cond ((typep datum 'condition)
64         (when arguments
65           (error 'simple-type-error
66                  :datum arguments
67                  :expected-type 'null
68                  :format-control "You may not supply additional arguments when giving ~S to ~S."
69                  :format-arguments (list datum fun-name)))
70         datum)
71        ((symbolp datum)
72         (%make-condition datum arguments))
73        ((or (stringp datum) (functionp datum))
74         (%make-condition default-type
75                          (list :format-control datum
76                                :format-arguments arguments)))
77        (t
78         (error 'simple-type-error
79                :datum datum
80                :expected-type '(or symbol string)
81                :format-control "Bad argument to ~S: ~S."
82                :format-arguments (list fun-name datum)))))
83
84(defmacro handler-bind (bindings &body forms)
85  (dolist (binding bindings)
86    (unless (and (consp binding) (= (length binding) 2))
87      (error "ill-formed handler binding ~S" binding)))
88  `(let ((*handler-clusters*
89          (cons (list ,@(mapcar (lambda (x) `(cons ',(car x) ,(cadr x)))
90                                bindings))
91                *handler-clusters*)))
92     (progn
93       ,@forms)))
94
95(defmacro handler-case (form &rest cases)
96  (let ((no-error-clause (assoc ':no-error cases)))
97    (if no-error-clause
98        (let ((normal-return (make-symbol "normal-return"))
99              (error-return  (make-symbol "error-return")))
100          `(block ,error-return
101             (multiple-value-call (lambda ,@(cdr no-error-clause))
102                                  (block ,normal-return
103                                    (return-from ,error-return
104                                                 (handler-case (return-from ,normal-return ,form)
105                                                   ,@(remove no-error-clause cases)))))))
106        (let ((tag (gensym))
107              (var (gensym))
108              (annotated-cases (mapcar (lambda (case) (cons (gensym) case))
109                                       cases)))
110          `(block ,tag
111             (let ((,var nil))
112               (declare (ignorable ,var))
113               (tagbody
114                (handler-bind
115                  ,(mapcar (lambda (annotated-case)
116                             (list (cadr annotated-case)
117                                   `(lambda (temp)
118                                      ,(if (caddr annotated-case)
119                                           `(setq ,var temp)
120                                           '(declare (ignore temp)))
121                                      (go ,(car annotated-case)))))
122                           annotated-cases)
123                  (return-from ,tag
124                               ,form))
125                ,@(mapcan
126                   (lambda (annotated-case)
127                     (list (car annotated-case)
128                           (let ((body (cdddr annotated-case)))
129                             `(return-from
130                               ,tag
131                               ,(cond ((caddr annotated-case)
132                                       `(let ((,(caaddr annotated-case)
133                                                ,var))
134                                          ,@body))
135                                      (t
136                                       `(locally ,@body)))))))
137                   annotated-cases))))))))
Note: See TracBrowser for help on using the repository browser.