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