suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
dcffbe1d8b
racket/s/exceptions.ss
dyb 7e4ed70f72 minor relop-length and assertion-violationf improvements 
- zero?, fxzero?, positive?, fxpositive?, etc., now go through
  (a suitably modified) relop-length so that, for example,
  (zero? (length x)) results in the same code as (null? x).  added
  correctness tests for these and all of the other predicates that
  go through relop-length.
    cpnanopass.ss, 5_2.ms
- assertion-violationf and friends now show the who, message, and
  irritants in the original call when who or message is found not to
  be of the right type.
    exceptions.ss

original commit: 9cdc8733cbde4046fd404eefbca6433aabebcef9
2019-04-19 20:22:09 -07:00

737 lines
28 KiB
Scheme
Raw Blame History

"exceptions.ss"
;;; 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
|#
(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))))
)
Reference in New Issue View Git Blame Copy Permalink