← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to clcs/clcs_handler.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
clcs/clcs_handler.lisp
 
1
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*-
 
2
 
 
3
(IN-PACKAGE "CONDITIONS")
 
4
 
 
5
(DEFVAR *HANDLER-CLUSTERS* NIL)
 
6
 
 
7
(DEFMACRO HANDLER-BIND (BINDINGS &BODY FORMS)
 
8
  (UNLESS (EVERY #'(LAMBDA (X) (AND (LISTP X) (= (LENGTH X) 2))) BINDINGS)
 
9
    (ERROR "Ill-formed handler bindings."))
 
10
  `(LET ((*HANDLER-CLUSTERS* (CONS (LIST ,@(MAPCAR #'(LAMBDA (X) `(CONS ',(CAR X) ,(CADR X)))
 
11
                                                   BINDINGS))
 
12
                                   *HANDLER-CLUSTERS*)))
 
13
     ,@FORMS))
 
14
 
 
15
(DEFVAR *BREAK-ON-SIGNALS* NIL)
 
16
 
 
17
(DEFUN SIGNAL (DATUM &REST ARGUMENTS)
 
18
  (LET ((CONDITION (COERCE-TO-CONDITION DATUM ARGUMENTS 'SIMPLE-CONDITION 'SIGNAL))
 
19
        (*HANDLER-CLUSTERS* *HANDLER-CLUSTERS*))
 
20
    (IF (TYPEP CONDITION *BREAK-ON-SIGNALS*)
 
21
        (BREAK "~A~%Break entered because of *BREAK-ON-SIGNALS*."
 
22
               CONDITION))
 
23
    (LOOP (IF (NOT *HANDLER-CLUSTERS*) (RETURN))
 
24
          (LET ((CLUSTER (POP *HANDLER-CLUSTERS*)))
 
25
            (DOLIST (HANDLER CLUSTER)
 
26
              (WHEN (TYPEP CONDITION (CAR HANDLER))
 
27
                    (FUNCALL (CDR HANDLER) CONDITION)
 
28
                (RETURN NIL) ;?
 
29
                ))))
 
30
    NIL))
 
31
 
 
32
;;; COERCE-TO-CONDITION
 
33
;;;  Internal routine used in ERROR, CERROR, BREAK, and WARN for parsing the
 
34
;;;  hairy argument conventions into a single argument that's directly usable 
 
35
;;;  by all the other routines.
 
36
 
 
37
(DEFUN COERCE-TO-CONDITION (DATUM ARGUMENTS DEFAULT-TYPE FUNCTION-NAME)
 
38
  #+LISPM (SETQ ARGUMENTS (COPY-LIST ARGUMENTS))
 
39
  (COND ((CONDITIONP DATUM)
 
40
         (IF ARGUMENTS
 
41
             (CERROR "Ignore the additional arguments."
 
42
                     'SIMPLE-TYPE-ERROR
 
43
                     :DATUM ARGUMENTS
 
44
                     :EXPECTED-TYPE 'NULL
 
45
                     :FORMAT-STRING "You may not supply additional arguments ~
 
46
                                     when giving ~S to ~S."
 
47
                     :FORMAT-ARGUMENTS (LIST DATUM FUNCTION-NAME)))
 
48
         DATUM)
 
49
        ((OR (SYMBOLP DATUM) (CONDITION-CLASS-P DATUM))
 
50
         (APPLY #'MAKE-CONDITION DATUM ARGUMENTS))       
 
51
        ((STRINGP DATUM)
 
52
         (MAKE-CONDITION DEFAULT-TYPE
 
53
                         :FORMAT-STRING DATUM
 
54
                         :FORMAT-ARGUMENTS ARGUMENTS))
 
55
        (T
 
56
         (ERROR 'SIMPLE-TYPE-ERROR
 
57
                :DATUM DATUM
 
58
                :EXPECTED-TYPE '(OR SYMBOL STRING)
 
59
                :FORMAT-STRING "Bad argument to ~S: ~S"
 
60
                :FORMAT-ARGUMENTS (LIST FUNCTION-NAME DATUM)))))
 
61
 
 
62
(DEFUN ERROR (DATUM &REST ARGUMENTS)
 
63
  (LET ((CONDITION (COERCE-TO-CONDITION DATUM ARGUMENTS 'SIMPLE-ERROR 'ERROR)))
 
64
    (SIGNAL CONDITION)
 
65
    (INVOKE-DEBUGGER CONDITION)))
 
66
 
 
67
(DEFUN CERROR (CONTINUE-STRING DATUM &REST ARGUMENTS)
 
68
  (WITH-SIMPLE-RESTART (CONTINUE "~A" (APPLY #'FORMAT NIL CONTINUE-STRING ARGUMENTS))
 
69
    (APPLY #'ERROR DATUM ARGUMENTS))
 
70
  NIL)
 
71
 
 
72
(DEFUN BREAK (&OPTIONAL (FORMAT-STRING "Break") &REST FORMAT-ARGUMENTS)
 
73
  (WITH-SIMPLE-RESTART (CONTINUE "Return from BREAK.")
 
74
    (INVOKE-DEBUGGER
 
75
      (MAKE-CONDITION 'SIMPLE-CONDITION
 
76
                      :FORMAT-STRING    FORMAT-STRING
 
77
                      :FORMAT-ARGUMENTS FORMAT-ARGUMENTS)))
 
78
  NIL)
 
79
 
 
80
(DEFUN WARN (DATUM &REST ARGUMENTS)
 
81
  (LET ((CONDITION
 
82
          (COERCE-TO-CONDITION DATUM ARGUMENTS 'SIMPLE-WARNING 'WARN)))
 
83
    (CHECK-TYPE CONDITION WARNING "a warning condition")
 
84
    (IF *BREAK-ON-WARNINGS*
 
85
        (BREAK "~A~%Break entered because of *BREAK-ON-WARNINGS*."
 
86
               CONDITION))
 
87
    (RESTART-CASE (SIGNAL CONDITION)
 
88
      (MUFFLE-WARNING ()
 
89
          :REPORT "Skip warning."
 
90
        (RETURN-FROM WARN NIL)))
 
91
    (FORMAT *ERROR-OUTPUT* "~&Warning:~%~A~%" CONDITION)
 
92
    NIL))
 
93
 
 
94
(DEFMACRO HANDLER-CASE (FORM &REST CASES)
 
95
  (LET ((NO-ERROR-CLAUSE (ASSOC ':NO-ERROR CASES)))
 
96
    (IF NO-ERROR-CLAUSE
 
97
        (LET ((NORMAL-RETURN (MAKE-SYMBOL "NORMAL-RETURN"))
 
98
              (ERROR-RETURN  (MAKE-SYMBOL "ERROR-RETURN")))
 
99
          `(BLOCK ,ERROR-RETURN
 
100
             (MULTIPLE-VALUE-CALL #'(LAMBDA ,@(CDR NO-ERROR-CLAUSE))
 
101
               (BLOCK ,NORMAL-RETURN
 
102
                 (RETURN-FROM ,ERROR-RETURN
 
103
                   (HANDLER-CASE (RETURN-FROM ,NORMAL-RETURN ,FORM)
 
104
                     ,@(REMOVE NO-ERROR-CLAUSE CASES)))))))
 
105
        (LET ((TAG (GENSYM))
 
106
              (VAR (GENSYM))
 
107
              (ANNOTATED-CASES (MAPCAR #'(LAMBDA (CASE) (CONS (GENSYM) CASE))
 
108
                                       CASES)))
 
109
          `(BLOCK ,TAG
 
110
             (LET ((,VAR NIL))
 
111
               ,VAR                             ;ignorable
 
112
               (TAGBODY
 
113
                 (HANDLER-BIND ,(MAPCAR #'(LAMBDA (ANNOTATED-CASE)
 
114
                                            (LIST (CADR ANNOTATED-CASE)
 
115
                                                  `#'(LAMBDA (TEMP)
 
116
                                                       ,@(IF (CADDR ANNOTATED-CASE)
 
117
                                                             `((SETQ ,VAR TEMP)))
 
118
                                                       (GO ,(CAR ANNOTATED-CASE)))))
 
119
                                        ANNOTATED-CASES)
 
120
                               (RETURN-FROM ,TAG ,FORM))
 
121
                 ,@(MAPCAN #'(LAMBDA (ANNOTATED-CASE)
 
122
                               (LIST (CAR ANNOTATED-CASE)
 
123
                                     (LET ((BODY (CDDDR ANNOTATED-CASE)))
 
124
                                       `(RETURN-FROM ,TAG
 
125
                                          ,(COND ((CADDR ANNOTATED-CASE)
 
126
                                                  `(LET ((,(CAADDR ANNOTATED-CASE)
 
127
                                                          ,VAR))
 
128
                                                     ,@BODY))
 
129
                                                 ((NOT (CDR BODY))
 
130
                                                  (CAR BODY))
 
131
                                                 (T
 
132
                                                  `(PROGN ,@BODY)))))))
 
133
                           ANNOTATED-CASES))))))))
 
134
 
 
135
(DEFMACRO IGNORE-ERRORS (&REST FORMS)
 
136
  `(HANDLER-CASE (PROGN ,@FORMS)
 
137
     (ERROR (CONDITION) (VALUES NIL CONDITION))))
 
138
 
 
139
;#+pcl
 
140
;(defun conditions::find-class-no-error (object)
 
141
;  (ignore-errors (find-class object)))
 
142