1(library (core errors)
2    (export raise
3	    raise-continuable
4	    describe-condition
5	    assertion-violation
6	    undefined-violation
7	    lexical-violation
8	    syntax-violation
9	    error
10	    implementation-restriction-violation
11	    undefined/syntax-violation
12	    assertion/syntax-violation
13	    raise-i/o-filename-error
14	    raise-i/o-error
15	    ;;raise-misc-i/o-error-with-port
16	    ;;raise-misc-i/o-error
17	    raise-i/o-read-error
18	    raise-i/o-write-error
19	    raise-i/o-file-protection-error
20	    raise-i/o-file-is-read-only-error
21	    raise-i/o-file-already-exists-error
22	    raise-i/o-file-does-not-exist-error
23	    raise-i/o-invalid-position-error
24	    raise-i/o-decoding-error
25	    raise-i/o-encoding-error)
26    (import (core)
27	    (core base)
28	    (sagittarius)
29	    (sagittarius vm))
30
31(define (%condition-message c)
32  (cond ((not (message-condition? c)) #f)
33	((simple-condition? c) (&message-message c))
34	(else
35	 (let loop ((cp (&compound-condition-components c)))
36	   (cond ((null? cp) #f)
37		 ((%condition-message (car cp)))
38		 (else (loop (cdr cp))))))))
39
40(define (raise-continuable co)
41  (define c (vm-attach-stack-trace co))
42  ((car (current-exception-handlers)) c))
43(define (raise co)
44  (define c (vm-attach-stack-trace co))
45  (let ((eh* (current-exception-handlers)))
46    ;; invoke the first one. if it's the default-exception-handler
47    ;; then it won't return.
48    ((car eh*) c)
49    ;; if it's returned, then pop the invoked handler.
50    (current-exception-handlers (cdr eh*))
51    ;; we use sort of Sagittarius specific here to avoid
52    ;; deeply nested &non-continuable
53    (let ((msg "error in raise: returned from non-continuable"))
54      (if (and (non-continuable-violation? c) (eq? (%condition-message c) msg))
55	  (raise c)
56	  (raise (condition (make-non-continuable-violation)
57			    (make-who-condition 'raise)
58			    (make-message-condition msg)
59			    (make-irritants-condition (list c))))))))
60
61(define undefined-violation
62  (lambda (who . message)
63    (raise
64     (apply condition
65            (filter values
66                    (list (make-undefined-violation)
67                          (and who (make-who-condition who))
68                          (and (pair? message) (make-message-condition (car message)))))))))
69
70(define lexical-violation
71  (lambda (who . message)
72    (raise
73     (apply condition
74            (filter values
75                    (list (make-lexical-violation)
76                          (and who (make-who-condition who))
77                          (and (pair? message) (make-message-condition (car message)))))))))
78
79(define syntax-violation
80  (lambda (who message form . subform)
81    (raise
82     (apply condition
83            (filter values
84                    (list (make-syntax-violation form (and (pair? subform) (car subform)))
85                          (if who
86                              (make-who-condition who)
87                              (cond ((let ((obj form))
88                                       (cond ((identifier? obj) (id-name obj))
89                                             ((and (pair? obj) (identifier? (car obj))) (id-name (car obj)))
90                                             (else #f)))
91                                     => make-who-condition)
92                                    (else #f)))
93                          (make-message-condition message)))))))
94
95(define implementation-restriction-violation
96  (lambda (who message . irritants)
97    (raise
98     (apply condition
99            (filter values
100                    (list (make-implementation-restriction-violation)
101                          (and who (make-who-condition who))
102                          (make-message-condition message)
103                          (and (pair? irritants) (make-irritants-condition irritants))))))))
104
105(define undefined/syntax-violation
106  (lambda (who message form . subform)
107    (raise
108     (apply condition
109            (filter values
110                    (list (make-syntax-violation form (and (pair? subform) (car subform)))
111                          (make-undefined-violation)
112                          (and who (make-who-condition who))
113                          (make-message-condition message)))))))
114
115(define assertion/syntax-violation
116  (lambda (who message form . subform)
117    (raise
118     (apply condition
119            (filter values
120                    (list (make-syntax-violation form (and (pair? subform) (car subform)))
121                          (make-assertion-violation)
122                          (and who (make-who-condition who))
123                          (make-message-condition message)))))))
124(define raise-i/o-filename-error
125  (lambda (who message filename . irritants)
126    (raise
127     (apply condition
128            (filter values
129                    (list (make-i/o-filename-error filename)
130                          (and who (make-who-condition who))
131                          (make-message-condition message)
132                          (and (pair? irritants) (make-irritants-condition irritants))))))))
133
134(define raise-i/o-error
135  (lambda (who message . irritants)
136    (raise
137     (apply condition
138            (filter values
139                    (list (make-i/o-error)
140                          (and who (make-who-condition who))
141                          (make-message-condition message)
142                          (and (pair? irritants) (make-irritants-condition irritants))))))))
143
144
145(define raise-misc-i/o-error-with-port
146  (lambda (constructor who message port . options)
147    (raise
148     (apply condition
149            (filter values
150                    (list (constructor)
151                          (and who (make-who-condition who))
152                          (make-message-condition message)
153                          (and port (make-i/o-port-error port))
154                          (make-irritants-condition (cons* port options))))))))
155
156(define raise-misc-i/o-error
157  (lambda (constructor who message . options)
158    (raise
159     (apply condition
160            (filter values
161                    (list (apply constructor options)
162                          (and who (make-who-condition who))
163                          (make-message-condition message)
164                          (and (pair? options)
165                               (make-irritants-condition options))))))))
166
167(define raise-i/o-read-error
168  (lambda (who message port . irr)
169    (apply raise-misc-i/o-error-with-port
170	   make-i/o-read-error who message port irr)))
171
172(define raise-i/o-write-error
173  (lambda (who message port . irr)
174    (apply raise-misc-i/o-error-with-port
175	   make-i/o-write-error who message port irr)))
176
177(define raise-i/o-file-protection-error
178  (lambda (who message filename)
179    (raise-misc-i/o-error make-i/o-file-protection-error who message filename)))
180
181(define raise-i/o-file-is-read-only-error
182  (lambda (who message port . irr)
183    (apply raise-misc-i/o-error-with-port
184	   make-i/o-file-is-read-only-error who message port irr)))
185
186(define raise-i/o-file-already-exists-error
187  (lambda (who message filename)
188    (raise-misc-i/o-error make-i/o-file-already-exists-error who message filename)))
189
190(define raise-i/o-file-does-not-exist-error
191  (lambda (who message filename)
192    (raise-misc-i/o-error make-i/o-file-does-not-exist-error who message filename)))
193
194(define raise-i/o-invalid-position-error
195  (lambda (who message port position)
196    (raise
197     (apply condition
198	    (filter values
199		    (list (make-i/o-invalid-position-error position)
200			  (make-i/o-port-error port)
201			  (and who (make-who-condition who))
202			  (make-message-condition message)))))))
203
204(define raise-i/o-decoding-error
205  (lambda (who message port)
206    (raise-misc-i/o-error make-i/o-decoding-error who message port)))
207
208(define raise-i/o-encoding-error
209  (lambda (who message port char)
210    (raise-misc-i/o-error make-i/o-encoding-error who message port char)))
211)
212