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.
405 lines
12 KiB
Scheme
405 lines
12 KiB
Scheme
;;; exceptions.ms
|
|
;;; 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.
|
|
|
|
(mat exceptions
|
|
(begin
|
|
(define ($$capture thunk)
|
|
(with-output-to-string
|
|
(lambda ()
|
|
(call/cc
|
|
(lambda (k)
|
|
(with-exception-handler
|
|
(lambda (x) (printf "default handler: ~s\n" x) (k))
|
|
(lambda () (printf "~s\n" (thunk)))))))))
|
|
(define-syntax $capture
|
|
(syntax-rules ()
|
|
[(_ e1 e2 ...) ($$capture (lambda () e1 e2 ...))]))
|
|
#t)
|
|
(equal?
|
|
($capture 'hello)
|
|
"hello\n")
|
|
(begin
|
|
(define ($ex-test1) (raise 'oops) (printf "finished\n"))
|
|
(define ($ex-test2) (printf "handler returned: ~s\n" (raise-continuable 'oops)) 'done)
|
|
#t)
|
|
(equal?
|
|
($capture (list ($ex-test1)))
|
|
"default handler: oops\n")
|
|
(equal?
|
|
($capture
|
|
(list
|
|
(with-exception-handler
|
|
(lambda (arg) (printf "hello: ~s\n" arg))
|
|
$ex-test1)))
|
|
"hello: oops\ndefault handler: #<condition &non-continuable>\n")
|
|
(equal?
|
|
($capture
|
|
(list
|
|
(with-exception-handler
|
|
(lambda (arg) (raise (list arg)))
|
|
$ex-test1)))
|
|
"default handler: (oops)\n")
|
|
(equal?
|
|
($capture (list ($ex-test2)))
|
|
"default handler: oops\n")
|
|
(equal?
|
|
($capture
|
|
(list
|
|
(with-exception-handler
|
|
(lambda (arg) (printf "hello: ~s\n" arg) 17)
|
|
$ex-test2)))
|
|
"hello: oops\nhandler returned: 17\n(done)\n")
|
|
(equal?
|
|
($capture
|
|
(list
|
|
(with-exception-handler
|
|
(lambda (arg) (raise (list arg)))
|
|
$ex-test2)))
|
|
"default handler: (oops)\n")
|
|
(equal?
|
|
($capture
|
|
(list
|
|
(guard (foo [(null? foo) 'empty]
|
|
[(pair? foo) foo])
|
|
(raise '()))))
|
|
"(empty)\n")
|
|
(equal?
|
|
($capture
|
|
(list
|
|
(guard (foo [(null? foo) 'empty]
|
|
[(pair? foo) foo])
|
|
(raise '(a . b)))))
|
|
"((a . b))\n")
|
|
(equal?
|
|
($capture
|
|
(list
|
|
(guard (foo [(null? foo) 'empty]
|
|
[(pair? foo) foo])
|
|
(raise 'oops))))
|
|
"default handler: oops\n")
|
|
(equal?
|
|
($capture
|
|
(list
|
|
(guard (foo [(null? foo) 'empty]
|
|
[(pair? foo) foo])
|
|
(with-exception-handler
|
|
(lambda (x) (printf "just passing through...\n") (raise x))
|
|
(lambda () (raise '()))))))
|
|
"just passing through...\n(empty)\n")
|
|
(equal?
|
|
($capture
|
|
(list
|
|
(guard (foo [(null? foo) 'empty]
|
|
[(pair? foo) foo])
|
|
(with-exception-handler
|
|
(lambda (x) (printf "just passing through...\n") (raise x))
|
|
(lambda () (raise '(a . b)))))))
|
|
"just passing through...\n((a . b))\n")
|
|
(equal?
|
|
($capture
|
|
(list
|
|
(guard (foo [(null? foo) 'empty]
|
|
[(pair? foo) foo])
|
|
(with-exception-handler
|
|
(lambda (x) (printf "just passing through...\n") (raise x))
|
|
(lambda () (raise 'oops))))))
|
|
"just passing through...\ndefault handler: oops\n")
|
|
(equal?
|
|
($capture
|
|
(list
|
|
(guard (foo [(null? foo) 'empty]
|
|
[(pair? foo) foo]
|
|
[else (raise 'hair)])
|
|
(with-exception-handler
|
|
(lambda (x) (printf "just passing through...\n") (raise x))
|
|
(lambda () (raise '(a . b)))))))
|
|
"just passing through...\n((a . b))\n")
|
|
(equal?
|
|
($capture
|
|
(list
|
|
(guard (foo [(null? foo) 'empty]
|
|
[(pair? foo) foo]
|
|
[else (raise 'hair)])
|
|
(with-exception-handler
|
|
(lambda (x) (printf "just passing through...\n") (raise x))
|
|
(lambda () (raise 'oops))))))
|
|
"just passing through...\ndefault handler: hair\n")
|
|
(equal?
|
|
($capture
|
|
(list
|
|
(call/cc
|
|
(lambda (k)
|
|
(with-exception-handler
|
|
(lambda (arg) (printf "outer handler: ~s\n" arg) (k 'fini))
|
|
(lambda ()
|
|
(guard (foo [(begin (printf "checking null\n") (null? foo)) 'empty]
|
|
[(begin (printf "checking pair\n") (pair? foo)) foo])
|
|
(dynamic-wind
|
|
(lambda () (printf "in\n"))
|
|
(lambda () (raise 'oops))
|
|
(lambda () (printf "out\n"))))))))))
|
|
"in\nout\nchecking null\nchecking pair\nin\nouter handler: oops\nout\n(fini)\n")
|
|
(equal?
|
|
($capture
|
|
(list
|
|
(guard (foo [(null? foo) 'empty]
|
|
[(pair? foo) foo])
|
|
(with-exception-handler
|
|
(lambda (x) (printf "returning...\n"))
|
|
(lambda () (raise-continuable 'oops) 'continuing)))))
|
|
"returning...\n(continuing)\n")
|
|
(equal?
|
|
($capture
|
|
; test to make sure guard reraises with raise-continuable per r6rs errata
|
|
(list
|
|
(with-exception-handler
|
|
(lambda (x) (printf "returning...\n"))
|
|
(lambda ()
|
|
(guard (foo [(null? foo) 'empty]
|
|
[(pair? foo) foo])
|
|
(raise-continuable 'oops)
|
|
'continuing)))))
|
|
"returning...\n(continuing)\n")
|
|
)
|
|
|
|
(mat assert
|
|
(equal?
|
|
(begin (assert #t) "yes")
|
|
"yes")
|
|
(equal?
|
|
(assert (memq 'a '(1 2 a 3 4)))
|
|
'(a 3 4))
|
|
(error? ; assertion failed
|
|
(assert (memq 'b '(1 2 a 3 4))))
|
|
(equal?
|
|
(begin (assert (< 3 4)) "yes")
|
|
"yes")
|
|
(equal?
|
|
(guard (c [#t "yes"])
|
|
(begin (assert #f) "no"))
|
|
"yes")
|
|
(equal?
|
|
(guard (c [#t "yes"])
|
|
(begin (assert (< 4 3)) "no"))
|
|
"yes")
|
|
; make sure pattern variables and ellipses on RHS don't screw us up
|
|
(equal?
|
|
(guard (c [#t "oops"])
|
|
(let-syntax ([q (lambda (x) #t)])
|
|
(assert (q ...))
|
|
"okay"))
|
|
"okay")
|
|
(equal?
|
|
(guard (c [#t "oops"])
|
|
(let-syntax ([q (lambda (x) #f)])
|
|
(assert (q ...))
|
|
"okay"))
|
|
"oops")
|
|
(error? ; assertion failed
|
|
(let-syntax ([q (lambda (x) #f)])
|
|
(assert (q ...))
|
|
"okay"))
|
|
(equal?
|
|
(syntax-case '(a b c) ()
|
|
[(x ...)
|
|
(begin
|
|
(assert (andmap symbol? #'(x ...)))
|
|
#'((x . x) ...))])
|
|
'((a . a) (b . b) (c . c)))
|
|
(error? ; assertion failed
|
|
(syntax-case '(a b 3) ()
|
|
[(x ...)
|
|
(begin
|
|
(assert (andmap symbol? #'(x ...)))
|
|
#'((x . x) ...))]))
|
|
)
|
|
|
|
(mat exceptions-r6rs ; r6rs examples
|
|
(equal?
|
|
($capture
|
|
(guard (con
|
|
((error? con)
|
|
(if (message-condition? con)
|
|
(display (condition-message con))
|
|
(display "an error has occurred"))
|
|
'error)
|
|
((violation? con)
|
|
(if (message-condition? con)
|
|
(display (condition-message con))
|
|
(display "the program has a bug"))
|
|
'violation))
|
|
(raise
|
|
(condition
|
|
(make-error)
|
|
(make-message-condition "I am an error")))))
|
|
"I am an errorerror\n")
|
|
(equal?
|
|
($capture
|
|
(guard (con
|
|
((error? con)
|
|
(if (message-condition? con)
|
|
(display (condition-message con))
|
|
(display "an error has occurred"))
|
|
'error))
|
|
(raise
|
|
(condition
|
|
(make-violation)
|
|
(make-message-condition "I am an error")))))
|
|
"default handler: #<compound condition>\n")
|
|
(equal?
|
|
($capture
|
|
(with-exception-handler
|
|
(lambda (con)
|
|
(cond
|
|
((not (warning? con))
|
|
(raise con))
|
|
((message-condition? con)
|
|
(display (condition-message con)))
|
|
(else
|
|
(display "a warning has been issued")))
|
|
42)
|
|
(lambda ()
|
|
(+ (raise-continuable
|
|
(condition
|
|
(make-warning)
|
|
(make-message-condition
|
|
"should be a number")))
|
|
23))))
|
|
"should be a number65\n")
|
|
)
|
|
|
|
(mat conditions-r6rs ; r6rs examples
|
|
(begin
|
|
(define-record-type ($co-&cond1 $co-make-cond1 $co-real-cond1?)
|
|
(parent &condition)
|
|
(fields (immutable x $co-real-cond1-x)))
|
|
(define $co-cond1?
|
|
(condition-predicate
|
|
(record-type-descriptor $co-&cond1)))
|
|
(define $co-cond1-x
|
|
(condition-accessor
|
|
(record-type-descriptor $co-&cond1)
|
|
$co-real-cond1-x))
|
|
(define $co-foo ($co-make-cond1 'foo))
|
|
#t)
|
|
(condition? $co-foo)
|
|
($co-cond1? $co-foo)
|
|
(eq? ($co-cond1-x $co-foo) 'foo)
|
|
(begin
|
|
(define-record-type ($co-&cond2 $co-make-cond2 $co-real-cond2?)
|
|
(parent &condition)
|
|
(fields
|
|
(immutable y $co-real-cond2-y)))
|
|
(define $co-cond2?
|
|
(condition-predicate
|
|
(record-type-descriptor $co-&cond2)))
|
|
(define $co-cond2-y
|
|
(condition-accessor
|
|
(record-type-descriptor $co-&cond2)
|
|
$co-real-cond2-y))
|
|
(define $co-bar ($co-make-cond2 'bar))
|
|
#t)
|
|
(condition? (condition $co-foo $co-bar))
|
|
($co-cond1? (condition $co-foo $co-bar))
|
|
($co-cond2? (condition $co-foo $co-bar))
|
|
($co-cond1? (condition $co-foo))
|
|
(list?
|
|
(memq
|
|
($co-real-cond1? (condition $co-foo))
|
|
'(#t #f)))
|
|
(not ($co-real-cond1? (condition $co-foo $co-bar)))
|
|
(eq? ($co-cond1-x (condition $co-foo $co-bar)) 'foo)
|
|
(eq? ($co-cond2-y (condition $co-foo $co-bar)) 'bar)
|
|
(equal?
|
|
(simple-conditions (condition $co-foo $co-bar))
|
|
(list $co-foo $co-bar))
|
|
(equal?
|
|
(simple-conditions (condition $co-foo (condition $co-bar)))
|
|
(list $co-foo $co-bar))
|
|
(begin
|
|
(define-condition-type $co-&c &condition $co-make-c $co-c? (x $co-c-x))
|
|
(define-condition-type $co-&c1 $co-&c $co-make-c1 $co-c1? (a $co-c1-a))
|
|
(define-condition-type $co-&c2 $co-&c $co-make-c2 $co-c2? (b $co-c2-b))
|
|
(define $co-v1 ($co-make-c1 "V1" "a1"))
|
|
#t)
|
|
($co-c? $co-v1)
|
|
($co-c1? $co-v1)
|
|
(not ($co-c2? $co-v1))
|
|
(equal? ($co-c-x $co-v1) "V1")
|
|
(equal? ($co-c1-a $co-v1) "a1")
|
|
(begin
|
|
(define $co-v2 ($co-make-c2 "V2" "b2"))
|
|
(define $co-v3 (condition ($co-make-c1 "V3/1" "a3") ($co-make-c2 "V3/2" "b3")))
|
|
(define $co-v4 (condition $co-v1 $co-v2))
|
|
(define $co-v5 (condition $co-v2 $co-v3))
|
|
#t)
|
|
($co-c? $co-v2)
|
|
(not ($co-c1? $co-v2))
|
|
($co-c2? $co-v2)
|
|
(equal? ($co-c-x $co-v2) "V2")
|
|
(equal? ($co-c2-b $co-v2) "b2")
|
|
($co-c? $co-v3)
|
|
($co-c1? $co-v3)
|
|
($co-c2? $co-v3)
|
|
(equal? ($co-c-x $co-v3) "V3/1")
|
|
(equal? ($co-c1-a $co-v3) "a3")
|
|
(equal? ($co-c2-b $co-v3) "b3")
|
|
($co-c? $co-v4)
|
|
($co-c1? $co-v4)
|
|
($co-c2? $co-v4)
|
|
(equal? ($co-c-x $co-v4) "V1")
|
|
(equal? ($co-c1-a $co-v4) "a1")
|
|
(equal? ($co-c2-b $co-v4) "b2")
|
|
($co-c? $co-v5)
|
|
($co-c1? $co-v5)
|
|
($co-c2? $co-v5)
|
|
(equal? ($co-c-x $co-v5) "V2")
|
|
(equal? ($co-c1-a $co-v5) "a3")
|
|
(equal? ($co-c2-b $co-v5) "b2")
|
|
)
|
|
|
|
(mat system-exceptions
|
|
(equal?
|
|
($capture
|
|
; from r6rs
|
|
(guard (con
|
|
((error? con)
|
|
(display "error opening file")
|
|
#f))
|
|
(call-with-input-file "/probably/not/here" read)))
|
|
"error opening file#f\n")
|
|
(guard (c [else (and (assertion-violation? c)
|
|
(not (implementation-restriction-violation? c)))])
|
|
(let ()
|
|
(define-record-type foo (fields x))
|
|
(foo-x 17)))
|
|
)
|
|
|
|
(mat exception-state
|
|
(#%$record? (current-exception-state))
|
|
(not (record? (current-exception-state)))
|
|
(eq?
|
|
(call/cc
|
|
(lambda (k)
|
|
(parameterize ([current-exception-state
|
|
(create-exception-state
|
|
(lambda (x)
|
|
(if (eq? x 'oops)
|
|
(raise 'rats)
|
|
(k x))))])
|
|
(raise 'oops))))
|
|
'rats)
|
|
)
|