This repository has been archived on 2022-08-10. You can view files and clone it, but cannot push or open issues or pull requests.
chez-openbsd/s/exceptions.ss
2022-07-29 15:12:07 +02:00

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))))
)
)