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

Last change on this file since 5129 was 5129, checked in by piso, 18 years ago

Initial checkin.

File size: 4.6 KB
Line 
1;;; signal.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: signal.lisp,v 1.1 2003-12-14 17:14:41 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 *handler-clusters* ())
25
26(defvar *break-on-signals* nil)
27
28(defun coerce-to-condition (datum arguments default-type fun-name)
29  (cond ((typep datum 'condition)
30   (when arguments
31           (error 'simple-type-error
32                  :datum arguments
33                  :expected-type 'null
34                  :format-control "you may not supply additional arguments when giving ~S to ~S"
35                  :format-arguments (list datum fun-name)))
36   datum)
37  ((symbolp datum)
38   (%make-condition datum arguments))
39  ((or (stringp datum) (functionp datum))
40   (%make-condition default-type
41                          (list :format-control datum
42                                :format-arguments arguments)))
43  (t
44   (error 'simple-type-error
45    :datum datum
46    :expected-type '(or symbol string)
47    :format-control "bad argument to ~S: ~S"
48    :format-arguments (list fun-name datum)))))
49
50(defun signal (datum &rest arguments)
51  (let ((condition (coerce-to-condition datum arguments 'simple-condition 'signal))
52  (*handler-clusters* *handler-clusters*))
53    (let ((old-bos *break-on-signals*)
54    (*break-on-signals* nil))
55      (when (typep condition old-bos)
56  (break "~A~%BREAK called because of *BREAK-ON-SIGNALS* (now rebound to NIL)."
57         condition)))
58    (loop
59      (unless *handler-clusters*
60  (return))
61      (let ((cluster (pop *handler-clusters*)))
62  (dolist (handler cluster)
63    (when (typep condition (car handler))
64      (funcall (cdr handler) condition)))))
65    (when (typep condition 'error)
66      (setf *saved-backtrace* (backtrace-as-list))
67      (invoke-debugger condition))
68    nil))
69
70(defmacro handler-bind (bindings &body forms)
71  (dolist (binding bindings)
72    (unless (and (consp binding) (= (length binding) 2))
73      (error "ill-formed handler binding ~S" binding)))
74  `(let ((*handler-clusters*
75    (cons (list ,@(mapcar (lambda (x) `(cons ',(car x) ,(cadr x)))
76        bindings))
77    *handler-clusters*)))
78     (progn
79       ,@forms)))
80
81(defmacro handler-case (form &rest cases)
82  (let ((no-error-clause (assoc ':no-error cases)))
83    (if no-error-clause
84  (let ((normal-return (make-symbol "normal-return"))
85        (error-return  (make-symbol "error-return")))
86    `(block ,error-return
87       (multiple-value-call (lambda ,@(cdr no-error-clause))
88                                  (block ,normal-return
89                                    (return-from ,error-return
90                                                 (handler-case (return-from ,normal-return ,form)
91                                                   ,@(remove no-error-clause cases)))))))
92  (let ((tag (gensym))
93        (var (gensym))
94        (annotated-cases (mapcar (lambda (case) (cons (gensym) case))
95               cases)))
96    `(block ,tag
97       (let ((,var nil))
98         (declare (ignorable ,var))
99         (tagbody
100    (handler-bind
101                  ,(mapcar (lambda (annotated-case)
102                             (list (cadr annotated-case)
103                                   `(lambda (temp)
104                                      ,(if (caddr annotated-case)
105                                           `(setq ,var temp)
106                                           '(declare (ignore temp)))
107                                      (go ,(car annotated-case)))))
108                           annotated-cases)
109      (return-from ,tag
110                               ,form))
111    ,@(mapcan
112       (lambda (annotated-case)
113         (list (car annotated-case)
114         (let ((body (cdddr annotated-case)))
115           `(return-from
116                               ,tag
117                               ,(cond ((caddr annotated-case)
118                                       `(let ((,(caaddr annotated-case)
119            ,var))
120                                          ,@body))
121                                      (t
122                                       `(locally ,@body)))))))
123       annotated-cases))))))))
Note: See TracBrowser for help on using the repository browser.