/[gcl]/gcl/clcs/gcl_clcs_handler.lisp
ViewVC logotype

Diff of /gcl/clcs/gcl_clcs_handler.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Fri May 6 21:56:54 2005 UTC revision 1.2 by camm, Sat May 7 02:52:28 2005 UTC
# Line 0  Line 1 
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    

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26