You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
738 lines
28 KiB
Scheme
738 lines
28 KiB
Scheme
;;; exceptions.ss
|
|
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
|
;;;
|
|
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
|
;;; you may not use this file except in compliance with the License.
|
|
;;; You may obtain a copy of the License at
|
|
;;;
|
|
;;; http://www.apache.org/licenses/LICENSE-2.0
|
|
;;;
|
|
;;; Unless required by applicable law or agreed to in writing, software
|
|
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
|
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
|
;;; See the License for the specific language governing permissions and
|
|
;;; limitations under the License.
|
|
|
|
#|
|
|
TODO:
|
|
- teach default handler to:
|
|
- squirrel away continuation for debug as &continuation simple condition
|
|
- say something about calling debug (if &continuation is included)
|
|
- teach reset to handle closing of ports, etc., in system error chain
|
|
- wire into existing error-handling mechanisms, or visa versa
|
|
- replace error calls as appropriate with violation calls,
|
|
syntax-violation calls, etc.
|
|
- fix: unbound variables show up as #{b *top*:b}
|
|
(~:s in message is supposed to take care of this but format isn't being called)
|
|
- mats for system violations and errors
|
|
- deal with error? and warning? mats
|
|
|#
|
|
|
|
(begin
|
|
(let ()
|
|
(define (warning-only? c)
|
|
(and (warning? c) (not (serious-condition? c))))
|
|
|
|
(let ()
|
|
(define $display-condition
|
|
(lambda (c op prefix? use-cache?)
|
|
(module (print-source)
|
|
(include "types.ss")
|
|
(define (print-position op prefix src start?)
|
|
(call-with-values
|
|
(lambda () ((current-locate-source-object-source) src start? use-cache?))
|
|
(case-lambda
|
|
[()
|
|
(let ([sfd (source-sfd src)]
|
|
[fp (if start? (source-bfp src) (source-efp src))])
|
|
(fprintf op "~a~a char ~a of ~a" prefix
|
|
(if (eq? start? 'near) "near" "at")
|
|
fp (source-file-descriptor-name sfd)))]
|
|
[(path line char)
|
|
(fprintf op "~a~a line ~a, char ~a of ~a" prefix
|
|
(if (eq? start? 'near) "near" "at")
|
|
line char path)])))
|
|
(define (print-source op prefix c)
|
|
(cond
|
|
[($src-condition? c)
|
|
(let ([src ($src-condition-src c)])
|
|
(when (source? src)
|
|
(print-position op prefix src ($src-condition-start c))))]
|
|
[(source-condition? c)
|
|
(let ([form (source-condition-form c)])
|
|
(parameterize ([print-level 3] [print-length 6])
|
|
(fprintf op "~a~s" prefix (syntax->datum form)))
|
|
(let-values ([(src start?) ($syntax->src form)])
|
|
(when src (print-position op " " src start?))))]
|
|
[(syntax-violation? c)
|
|
(let ([form (syntax-violation-form c)]
|
|
[subform (syntax-violation-subform c)])
|
|
(parameterize ([print-level 3] [print-length 6])
|
|
(if subform
|
|
(fprintf op "~a~s in ~s" prefix (syntax->datum subform) (syntax->datum form))
|
|
(fprintf op "~a~s" prefix (syntax->datum form))))
|
|
(let-values ([(src start?) ($syntax->src subform)])
|
|
(if src
|
|
(print-position op " " src start?)
|
|
(let-values ([(src start?) ($syntax->src form)])
|
|
(when src (print-position op " " src start?))))))])))
|
|
(cond
|
|
[(and (format-condition? c)
|
|
(guard (ignore [#t #f])
|
|
($report-string #f
|
|
(and prefix? (if (warning-only? c) "warning" "exception"))
|
|
(and (who-condition? c) (condition-who c))
|
|
(condition-message c)
|
|
(condition-irritants c)))) =>
|
|
(lambda (s)
|
|
(display s op)
|
|
(print-source op " " c))]
|
|
[(message-condition? c)
|
|
(let ([irritants (if (irritants-condition? c) (condition-irritants c) '())])
|
|
(case (and (list? irritants) (length irritants))
|
|
[(0)
|
|
($report-string op
|
|
(and prefix? (if (warning-only? c) "warning" "exception"))
|
|
(and (who-condition? c) (condition-who c))
|
|
"~a"
|
|
(list (condition-message c)))]
|
|
[(1)
|
|
($report-string op
|
|
(and prefix? (if (warning-only? c) "warning" "exception"))
|
|
(and (who-condition? c) (condition-who c))
|
|
"~a with irritant ~s"
|
|
(list (condition-message c) (car irritants)))]
|
|
[else
|
|
($report-string op
|
|
(and prefix? (if (warning-only? c) "warning" "exception"))
|
|
(and (who-condition? c) (condition-who c))
|
|
"~a with irritants ~s"
|
|
(list (condition-message c) irritants))]))
|
|
(print-source op " " c)]
|
|
[else
|
|
(fprintf op "Exception occurred")
|
|
(cond
|
|
[(condition? c)
|
|
(print-source op " " c)
|
|
(let ([x* (simple-conditions c)])
|
|
(cond
|
|
[(null? x*)
|
|
(fprintf op " with empty condition\n")]
|
|
[else
|
|
(fprintf op " with condition components:")
|
|
(for-each
|
|
(lambda (x i)
|
|
(let ([rtd (#3%record-rtd x)])
|
|
(define (print-field i)
|
|
(if (csv7:record-field-accessible? rtd i)
|
|
(parameterize ([print-level 3] [print-length 6])
|
|
(fprintf op ": ~s" ((csv7:record-field-accessor rtd i) x)))
|
|
(fprintf op ": (inaccessible)")))
|
|
(fprintf op "\n~3d. ~a" i (csv7:record-type-name (#3%record-rtd x)))
|
|
(if (record-type-opaque? rtd)
|
|
(fprintf op " (opaque)")
|
|
(let ([name* (csv7:record-type-field-names rtd)])
|
|
(if (fx= (length name*) 1)
|
|
(print-field 0)
|
|
(for-each
|
|
(lambda (name i)
|
|
(fprintf op "\n ~s" name)
|
|
(print-field i))
|
|
name* (iota (length name*))))))))
|
|
x* (iota (length x*)))]))]
|
|
[else (parameterize ([print-level 3] [print-length 6])
|
|
(fprintf op " with non-condition value ~s" c))])])))
|
|
|
|
(set-who! display-condition
|
|
(case-lambda
|
|
[(c) ($display-condition c (current-output-port) #t #f)]
|
|
[(c op)
|
|
(unless (and (output-port? op) (textual-port? op))
|
|
($oops who "~s is not a textual output port" op))
|
|
($display-condition c op #t #f)]))
|
|
|
|
(set! $make-source-oops
|
|
(lambda (who msg expr)
|
|
#`(assertion-violation '#,who
|
|
#,(call-with-string-output-port
|
|
(lambda (p)
|
|
($display-condition (condition
|
|
(make-syntax-violation expr #f)
|
|
(make-message-condition msg))
|
|
p #f #t)))))))
|
|
|
|
(set! default-exception-handler
|
|
(lambda (c)
|
|
(let ([cep (console-error-port)])
|
|
(with-exception-handler
|
|
(lambda (c)
|
|
(if (i/o-error? c)
|
|
(begin
|
|
(debug-condition c)
|
|
(if (debug-on-exception) (debug))
|
|
(reset))
|
|
(raise-continuable c)))
|
|
(lambda ()
|
|
; only I/O to cep in handler-protected code---not (debug), not (reset).
|
|
(fresh-line cep)
|
|
(display-condition c cep)
|
|
(newline cep)
|
|
(unless (or (warning-only? c) (debug-on-exception) (= ($cafe) 0) (not (interactive?)))
|
|
(display-string "Type (debug) to enter the debugger.\n" cep))
|
|
(flush-output-port cep))))
|
|
(unless (warning-only? c)
|
|
(debug-condition c)
|
|
(if (debug-on-exception) (debug))
|
|
(reset)))))
|
|
|
|
(define debug-on-exception
|
|
(make-parameter #f
|
|
(lambda (x) (and x #t))))
|
|
|
|
(define base-exception-handler
|
|
($make-thread-parameter
|
|
default-exception-handler
|
|
(lambda (p)
|
|
(unless (procedure? p) ($oops 'default-exception-handler "~s is not a procedure" p))
|
|
p)))
|
|
|
|
(let ()
|
|
(define create-exception-stack
|
|
(lambda (p)
|
|
(let ([ls (list p)])
|
|
(set-cdr! ls ls)
|
|
ls)))
|
|
|
|
(define default-handler
|
|
(lambda (x)
|
|
((base-exception-handler) x)))
|
|
|
|
(define-threaded handler-stack (create-exception-stack default-handler))
|
|
|
|
(let ()
|
|
(define-record-type exception-state
|
|
(nongenerative)
|
|
(opaque #t)
|
|
(sealed #t)
|
|
(fields (immutable stack)))
|
|
|
|
(set-who! create-exception-state
|
|
(case-lambda
|
|
[() (make-exception-state (create-exception-stack default-handler))]
|
|
[(p)
|
|
(unless (procedure? p) ($oops who "~s is not a procedure" p))
|
|
(make-exception-state (create-exception-stack p))]))
|
|
|
|
(set-who! current-exception-state
|
|
(case-lambda
|
|
[() (make-exception-state handler-stack)]
|
|
[(x)
|
|
(unless (exception-state? x)
|
|
($oops who "~s is not an exception state" x))
|
|
(set! handler-stack (exception-state-stack x))])))
|
|
|
|
(set-who! with-exception-handler
|
|
(lambda (handler thunk)
|
|
(unless (procedure? handler) ($oops who "~s is not a procedure" handler))
|
|
(unless (procedure? thunk) ($oops who "~s is not a procedure" thunk))
|
|
(fluid-let ([handler-stack (cons handler handler-stack)])
|
|
(thunk))))
|
|
|
|
(set-who! raise
|
|
(lambda (obj)
|
|
(let ([handler (car handler-stack)])
|
|
(fluid-let ([handler-stack (cdr handler-stack)])
|
|
(handler obj)
|
|
(raise (make-non-continuable-violation))))))
|
|
|
|
(set-who! raise-continuable
|
|
(lambda (obj)
|
|
(let ([handler (car handler-stack)])
|
|
(fluid-let ([handler-stack (cdr handler-stack)])
|
|
(handler obj)))))
|
|
|
|
(set-who! $guard
|
|
(lambda (supply-else? guards body)
|
|
(if supply-else?
|
|
((call/cc
|
|
(lambda (kouter)
|
|
(let ([original-handler-stack handler-stack])
|
|
(with-exception-handler
|
|
(lambda (arg)
|
|
((call/cc
|
|
(lambda (kinner)
|
|
(kouter
|
|
(lambda ()
|
|
(guards arg
|
|
(lambda ()
|
|
(kinner
|
|
(lambda ()
|
|
(fluid-let ([handler-stack original-handler-stack])
|
|
(raise-continuable arg))))))))))))
|
|
(lambda ()
|
|
(call-with-values
|
|
body
|
|
(case-lambda
|
|
[(x) (lambda () x)]
|
|
[vals (lambda () (apply values vals))]))))))))
|
|
((call/cc
|
|
(lambda (k)
|
|
(with-exception-handler
|
|
(lambda (arg) (k (lambda () (guards arg))))
|
|
(lambda ()
|
|
(call-with-values
|
|
body
|
|
(case-lambda
|
|
[(x) (lambda () x)]
|
|
[vals (lambda () (apply values vals))]))))))))))
|
|
)
|
|
|
|
(define-syntax guard
|
|
(syntax-rules (else)
|
|
[(_ (var clause ... [else e1 e2 ...]) b1 b2 ...)
|
|
(identifier? #'var)
|
|
($guard #f (lambda (var) (cond clause ... [else e1 e2 ...]))
|
|
(lambda () b1 b2 ...))]
|
|
[(_ (var clause1 clause2 ...) b1 b2 ...)
|
|
(identifier? #'var)
|
|
($guard #t (lambda (var p) (cond clause1 clause2 ... [else (p)]))
|
|
(lambda () b1 b2 ...))]))
|
|
|
|
(let ()
|
|
; redefine here to get local predicate
|
|
(define-record-type (&condition $make-simple-condition $simple-condition?)
|
|
(nongenerative #{&condition oyb459ue1fphfx4-a}))
|
|
|
|
(define-record-type (compound-condition make-compound-condition compound-condition?)
|
|
(nongenerative)
|
|
(sealed #t)
|
|
(fields (immutable components)))
|
|
|
|
(define (check-&condition-subtype! who rtd)
|
|
(unless (record-type-descriptor? rtd)
|
|
($oops who "~s is not a record type descriptor" rtd))
|
|
(unless (let f ([rtd rtd])
|
|
(or (eq? rtd (type-descriptor &condition))
|
|
(let ([rtd (record-type-parent rtd)])
|
|
(and rtd (f rtd)))))
|
|
($oops who "~s does not describe a subtype of &condition" rtd)))
|
|
|
|
(record-writer (type-descriptor &condition)
|
|
(lambda (x p wr)
|
|
(fprintf p "#<condition ~a>" (csv7:record-type-name (#3%record-rtd x)))))
|
|
|
|
(record-writer (type-descriptor compound-condition)
|
|
(lambda (x p wr)
|
|
(fprintf p "#<compound condition>")))
|
|
|
|
(set-who! $compound-condition? compound-condition?)
|
|
(set-who! $compound-condition-components compound-condition-components)
|
|
|
|
(set-who! condition
|
|
(case-lambda
|
|
[(x)
|
|
(unless (or ($simple-condition? x) (compound-condition? x))
|
|
($oops who "~s is not a condition" x))
|
|
x]
|
|
[x*
|
|
(let ([ls (fold-right
|
|
(lambda (x ls)
|
|
(cond
|
|
[($simple-condition? x) (cons x ls)]
|
|
[(compound-condition? x) (append (compound-condition-components x) ls)]
|
|
[else ($oops who "~s is not a condition" x)]))
|
|
'()
|
|
x*)])
|
|
(if (fx= (length ls) 1)
|
|
(car ls)
|
|
(make-compound-condition ls)))]))
|
|
|
|
(set-who! simple-conditions
|
|
(lambda (x)
|
|
(cond
|
|
[($simple-condition? x) (list x)]
|
|
[(compound-condition? x) (compound-condition-components x)]
|
|
[else ($oops who "~s is not a condition" x)])))
|
|
|
|
(set! condition?
|
|
(lambda (x)
|
|
(or ($simple-condition? x) (compound-condition? x))))
|
|
|
|
(set-who! condition-predicate
|
|
(lambda (rtd)
|
|
(check-&condition-subtype! who rtd)
|
|
(let ([p? (lambda (x) (record? x rtd))])
|
|
(lambda (x)
|
|
(or (p? x)
|
|
(and (compound-condition? x)
|
|
(ormap p? (compound-condition-components x))))))))
|
|
|
|
(set-who! condition-accessor
|
|
(lambda (rtd proc)
|
|
(define accessor-error
|
|
(lambda (x rtd)
|
|
($oops 'generated-condition-accessor
|
|
"~s is not a condition of the type represented by ~s"
|
|
x rtd)))
|
|
(check-&condition-subtype! who rtd)
|
|
(rec generated-condition-accessor
|
|
(lambda (x)
|
|
(cond
|
|
[(record? x rtd) (proc x)]
|
|
[(compound-condition? x)
|
|
(let f ([ls (compound-condition-components x)])
|
|
(if (null? ls)
|
|
(accessor-error x rtd)
|
|
(let ([x (car ls)])
|
|
(if (record? x rtd)
|
|
(proc x)
|
|
(f (cdr ls))))))]
|
|
[else (accessor-error x rtd)]))))))
|
|
|
|
(define-syntax define-condition-type
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
[(_ type-name super-type constructor predicate? (field-name accessor) ...)
|
|
(with-syntax ([($accessor ...) (generate-temporaries #'(accessor ...))]
|
|
[msg (format "~~s is not a condition of type ~a" (datum type-name))])
|
|
#'(begin
|
|
(define-record-type (type-name constructor $predicate?)
|
|
(nongenerative)
|
|
(parent super-type)
|
|
(fields (immutable field-name $accessor) ...))
|
|
(define predicate?
|
|
(lambda (x)
|
|
(or ($predicate? x)
|
|
(and ($compound-condition? x)
|
|
(ormap $predicate? ($compound-condition-components x))))))
|
|
(define accessor
|
|
(lambda (x)
|
|
(define accessor-error (lambda (x) ($oops 'accessor msg x)))
|
|
(cond
|
|
[($predicate? x) ($accessor x)]
|
|
[($compound-condition? x)
|
|
(let f ([ls ($compound-condition-components x)])
|
|
(if (null? ls)
|
|
(accessor-error x)
|
|
(let ([x (car ls)])
|
|
(if ($predicate? x)
|
|
($accessor x)
|
|
(f (cdr ls))))))]
|
|
[else (accessor-error x)])))
|
|
...))])))
|
|
|
|
(eval-when (compile)
|
|
(define-syntax define-system-condition-type
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
[(_ type-name super-type uid constructor predicate? (field-name accessor) ...)
|
|
(with-syntax ([($accessor ...) (generate-temporaries #'(accessor ...))]
|
|
[msg (format "~~s is not a condition of type ~a" (datum type-name))])
|
|
#'(begin
|
|
(define-record-type (type-name constructor $predicate?)
|
|
(nongenerative uid)
|
|
(parent super-type)
|
|
(fields (immutable field-name $accessor) ...))
|
|
(define predicate?
|
|
(lambda (x)
|
|
(or ($predicate? x)
|
|
(and ($compound-condition? x)
|
|
(ormap $predicate? ($compound-condition-components x))))))
|
|
(define accessor
|
|
(lambda (x)
|
|
(define accessor-error (lambda (x) ($oops 'accessor msg x)))
|
|
(cond
|
|
[($predicate? x) ($accessor x)]
|
|
[($compound-condition? x)
|
|
(let f ([ls ($compound-condition-components x)])
|
|
(if (null? ls)
|
|
(accessor-error x)
|
|
(let ([x (car ls)])
|
|
(if ($predicate? x)
|
|
($accessor x)
|
|
(f (cdr ls))))))]
|
|
[else (accessor-error x)])))
|
|
...))])))
|
|
)
|
|
|
|
;;; standard condition types
|
|
|
|
;;; taking advantage of body-like semantics of begin to arrange for each
|
|
;;; condition type's compile-time information to be available for use in
|
|
;;; defining its child types, even though the system is compiled with
|
|
;;; (eval-syntax-expanders-when) not including compile.
|
|
(begin
|
|
(let-syntax ([a (syntax-rules ()
|
|
[(_ &condition) ; leave only &condition visible
|
|
(define-record-type (&condition make-simple-condition simple-condition?)
|
|
(nongenerative #{&condition oyb459ue1fphfx4-a}))])])
|
|
(a &condition))
|
|
|
|
(define-system-condition-type &message &condition #{&message bwptyckgidgnsihx-a}
|
|
make-message-condition message-condition?
|
|
(message condition-message))
|
|
|
|
(define-system-condition-type &warning &condition #{&warning bwtai41dgaww3fus-a}
|
|
make-warning warning?)
|
|
|
|
(define-system-condition-type &serious &condition #{&serious bwvzuvr26s58u3l9-a}
|
|
make-serious-condition serious-condition?)
|
|
|
|
(define-system-condition-type &error &serious #{&error bwyo6misxbfkmrdg-a}
|
|
make-error error?)
|
|
|
|
(define-system-condition-type &violation &serious #{&violation bw1eic9intowee4m-a}
|
|
make-violation violation?)
|
|
|
|
(define-system-condition-type &assertion &violation #{&assertion bw33t3z8ebx752vs-a}
|
|
make-assertion-violation assertion-violation?)
|
|
|
|
(define-system-condition-type &irritants &condition #{&irritants bw6s5uqx4t7jxqmy-a}
|
|
make-irritants-condition irritants-condition?
|
|
(irritants condition-irritants))
|
|
|
|
(define-system-condition-type &who &condition #{&who bw9ihlhnvcgvped6-a}
|
|
make-who-condition who-condition?
|
|
(who condition-who))
|
|
|
|
(define-system-condition-type &non-continuable &violation #{&non-continuable bxb7tb8dlup7g15e-a}
|
|
make-non-continuable-violation
|
|
non-continuable-violation?)
|
|
|
|
(define-system-condition-type &implementation-restriction &violation #{&implementation-restriction bxew42y3cczi8pwl-a}
|
|
make-implementation-restriction-violation
|
|
implementation-restriction-violation?)
|
|
|
|
(define-system-condition-type &lexical &violation #{&lexical bxhmgtps2u8u0dns-a}
|
|
make-lexical-violation lexical-violation?)
|
|
|
|
(define-system-condition-type &syntax &violation #{&syntax bxkbskgitdh6r1ey-a}
|
|
make-syntax-violation syntax-violation?
|
|
(form syntax-violation-form)
|
|
(subform syntax-violation-subform))
|
|
|
|
(define-system-condition-type &undefined &violation #{&undefined bxm04a68jvrijo54-a}
|
|
make-undefined-violation undefined-violation?)
|
|
|
|
;;; io conditions
|
|
|
|
(define-system-condition-type &i/o &error #{&i/o bxpqf1xyad0ubcxc-a}
|
|
make-i/o-error i/o-error?)
|
|
|
|
(define-system-condition-type &i/o-read &i/o #{&i/o-read bxsfrson0v9520oj-a}
|
|
make-i/o-read-error i/o-read-error?)
|
|
|
|
(define-system-condition-type &i/o-write &i/o #{&i/o-write bxu43jfdrejhuofp-a}
|
|
make-i/o-write-error i/o-write-error?)
|
|
|
|
(define-system-condition-type &i/o-invalid-position &i/o #{&i/o-invalid-position bxxue953hwstmb6v-a}
|
|
make-i/o-invalid-position-error
|
|
i/o-invalid-position-error?
|
|
(position i/o-error-position))
|
|
|
|
(define-system-condition-type &i/o-filename &i/o #{&i/o-filename bx0jq0ws8e15dzx4-a}
|
|
make-i/o-filename-error i/o-filename-error?
|
|
(filename i/o-error-filename))
|
|
|
|
(define-system-condition-type &i/o-file-protection &i/o-filename #{&i/o-file-protection bx282rniyxbg5npc-a}
|
|
make-i/o-file-protection-error
|
|
i/o-file-protection-error?)
|
|
|
|
(define-system-condition-type &i/o-file-is-read-only &i/o-file-protection #{&i/o-file-is-read-only bx5yeid8pfksxbgj-a}
|
|
make-i/o-file-is-read-only-error
|
|
i/o-file-is-read-only-error?)
|
|
|
|
(define-system-condition-type &i/o-file-already-exists &i/o-filename #{&i/o-file-already-exists bx8np84yfxt4oy7q-a}
|
|
make-i/o-file-already-exists-error
|
|
i/o-file-already-exists-error?)
|
|
|
|
(define-system-condition-type &i/o-file-does-not-exist &i/o-filename #{&i/o-file-does-not-exist bybc1zvn6f3ggmyw-a}
|
|
make-i/o-file-does-not-exist-error
|
|
i/o-file-does-not-exist-error?)
|
|
|
|
(define-system-condition-type &i/o-port &i/o #{&i/o-port byd2dqmdwycr8ap5-a}
|
|
make-i/o-port-error i/o-port-error?
|
|
(pobj i/o-error-port))
|
|
|
|
(define-system-condition-type &i/o-decoding &i/o-port #{&i/o-decoding bygrphc3ngl3zyhc-a}
|
|
make-i/o-decoding-error i/o-decoding-error?)
|
|
|
|
(define-system-condition-type &i/o-encoding &i/o-port #{&i/o-encoding byjg073tdyvfrl8i-a}
|
|
make-i/o-encoding-error i/o-encoding-error?
|
|
(cobj i/o-encoding-error-char))
|
|
|
|
;;; arithmetic conditions
|
|
|
|
(define-system-condition-type &no-infinities &implementation-restriction #{&no-infinities byl6cyui4g4ri9zq-a}
|
|
make-no-infinities-violation
|
|
no-infinities-violation?)
|
|
|
|
(define-system-condition-type &no-nans &implementation-restriction #{&no-nans byovopk8uzd3axqx-a}
|
|
make-no-nans-violation no-nans-violation?)
|
|
|
|
;;; Chez Scheme conditions
|
|
|
|
(define-system-condition-type &source &condition #{&source byrk0gbylhne2lh4-a}
|
|
make-source-condition source-condition?
|
|
(form source-condition-form))
|
|
|
|
(define-system-condition-type $&src &condition #{$&src byul0m8re6e47nnb-a}
|
|
$make-src-condition $src-condition?
|
|
(src $src-condition-src)
|
|
(start $src-condition-start))
|
|
|
|
(define-system-condition-type &format &condition #{&format byxbcdzg5oogzbei-a}
|
|
make-format-condition format-condition?)
|
|
|
|
(define-system-condition-type &continuation &condition #{&continuation dxr8vukkubd1tr8-a}
|
|
make-continuation-condition continuation-condition?
|
|
(k condition-continuation))
|
|
|
|
(define-system-condition-type $&recompile &error #{&recompile eb5ipy47b8hscnlzoga59k-0}
|
|
$make-recompile-condition $recompile-condition?
|
|
(importer-path $recompile-importer-path))
|
|
)
|
|
|
|
(let ()
|
|
(define avcond (make-assertion-violation))
|
|
(define econd (make-error))
|
|
(define wcond (make-warning))
|
|
(define fcond (make-format-condition))
|
|
(define favcond (condition avcond fcond))
|
|
(define fecond (condition econd fcond))
|
|
(define fwcond (condition wcond fcond))
|
|
(define ircond (make-implementation-restriction-violation))
|
|
(define fimpcond (condition ircond fcond))
|
|
(define flexcond (condition (make-lexical-violation) (make-i/o-read-error) fcond))
|
|
(define flexcond/ir (condition ircond (make-lexical-violation) (make-i/o-read-error) fcond))
|
|
|
|
(define (error-help warning? who whoarg message irritants basecond)
|
|
(unless (or (eq? whoarg #f) (string? whoarg) (symbol? whoarg))
|
|
($oops who "invalid who argument ~s (message = ~s, irritants = ~s)" whoarg message irritants))
|
|
(unless (string? message)
|
|
($oops who "invalid message argument ~s (who = ~s, irritants = ~s)" message whoarg irritants))
|
|
(let ([c (if whoarg
|
|
(if irritants
|
|
(condition basecond
|
|
(make-who-condition whoarg)
|
|
(make-message-condition message)
|
|
(make-irritants-condition irritants))
|
|
(condition basecond
|
|
(make-who-condition whoarg)
|
|
(make-message-condition message)))
|
|
(if irritants
|
|
(condition basecond
|
|
(make-message-condition message)
|
|
(make-irritants-condition irritants))
|
|
(condition basecond
|
|
(make-message-condition message))))])
|
|
(if warning?
|
|
(raise-continuable c)
|
|
(call/cc
|
|
(lambda (k)
|
|
(raise (condition c (make-continuation-condition k))))))))
|
|
|
|
(set-who! assertion-violation
|
|
(lambda (whoarg message . irritants)
|
|
(error-help #f who whoarg message irritants avcond)))
|
|
|
|
(set-who! assertion-violationf
|
|
(lambda (whoarg message . irritants)
|
|
(error-help #f who whoarg message irritants favcond)))
|
|
|
|
(set-who! $oops
|
|
(lambda (whoarg message . irritants)
|
|
(error-help #f who whoarg message irritants favcond)))
|
|
|
|
(set-who! $oops/c
|
|
(lambda (whoarg basecond message . irritants)
|
|
(error-help #f who whoarg message irritants
|
|
(condition basecond fcond))))
|
|
|
|
(set-who! $impoops
|
|
(lambda (whoarg message . irritants)
|
|
(error-help #f who whoarg message irritants fimpcond)))
|
|
|
|
(set-who! $record-oops
|
|
(lambda (whoarg nonrec rtd)
|
|
(unless (record-type-descriptor? rtd)
|
|
($oops who "~s is not a record-type descriptor" rtd))
|
|
(when (record? nonrec rtd)
|
|
($oops who "~s actually is of type ~s" nonrec rtd))
|
|
(error-help #f who whoarg "~s is not of type ~s" (list nonrec rtd) favcond)))
|
|
|
|
(set-who! error
|
|
(lambda (whoarg message . irritants)
|
|
(error-help #f who whoarg message irritants econd)))
|
|
|
|
(set-who! errorf
|
|
(lambda (whoarg message . irritants)
|
|
(error-help #f who whoarg message irritants fecond)))
|
|
|
|
(set-who! warning
|
|
(lambda (whoarg message . irritants)
|
|
(error-help #t who whoarg message irritants wcond)))
|
|
|
|
(set-who! warningf
|
|
(lambda (whoarg message . irritants)
|
|
(error-help #t who whoarg message irritants fwcond)))
|
|
|
|
(let ()
|
|
(define (infer-who form)
|
|
(syntax-case form ()
|
|
[id (identifier? #'id) (datum id)]
|
|
[(id . stuff) (identifier? #'id) (datum id)]
|
|
[_ #f]))
|
|
(set-who! syntax-violation
|
|
(case-lambda
|
|
[(whoarg message form)
|
|
(error-help #f who (or whoarg (infer-who form)) message #f
|
|
(condition avcond (make-syntax-violation form #f)))]
|
|
[(whoarg message form subform)
|
|
(error-help #f who (or whoarg (infer-who form)) message #f
|
|
(make-syntax-violation form subform))])))
|
|
|
|
(set-who! syntax-error
|
|
(lambda (form . messages)
|
|
(for-each
|
|
(lambda (m) (unless (string? m) ($oops who "~s is not a string" m)))
|
|
messages)
|
|
(error-help #f who #f
|
|
(if (null? messages) "invalid syntax" (apply string-append messages))
|
|
#f (make-syntax-violation form #f))))
|
|
|
|
(set-who! $undefined-violation
|
|
(lambda (id message)
|
|
(error-help #f who #f message #f
|
|
(condition (make-undefined-violation) (make-syntax-violation id #f)))))
|
|
|
|
(set-who! $lexical-error
|
|
(case-lambda
|
|
[(whoarg msg args port ir?)
|
|
(error-help #f who whoarg msg args
|
|
(condition
|
|
(make-i/o-port-error port)
|
|
(if ir? flexcond/ir flexcond)))]
|
|
[(whoarg msg args port src start? ir?)
|
|
(error-help #f who whoarg msg args
|
|
(condition
|
|
(make-i/o-port-error port)
|
|
(if ir? flexcond/ir flexcond)
|
|
($make-src-condition src start?)))]))
|
|
|
|
(set-who! $source-violation
|
|
(lambda (whoarg src start? msg . args)
|
|
(error-help #f who whoarg msg args
|
|
(if src
|
|
(condition favcond ($make-src-condition src start?))
|
|
favcond))))
|
|
|
|
(set-who! $source-warning
|
|
(lambda (whoarg src start? msg . args)
|
|
(error-help #t who whoarg msg args
|
|
(if src
|
|
(condition fwcond ($make-src-condition src start?))
|
|
fwcond))))
|
|
)
|
|
)
|