suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

359.2, collects changes

Browse Source 
svn: r5143
This commit is contained in:
Matthew Flatt 2006-12-20 00:57:12 +00:00
parent 2274cc9f65
commit cf0b303497
40 changed files with 557 additions and 120 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/compiler/private/known.ss
View File

@ -82,14 +82,14 @@
;; Some prims call given procedures directly, some install procedures
;; to be called later, and some call previously installed procedures.
;; We care abot the installers and callers.
;; We care about the installers and callers.
(define prims-that-induce-procedure-calls
'(apply map for-each andmap ormap make-promise
dynamic-wind thread call-in-nested-thread
make-object call-with-values time-apply
call-with-output-file call-with-input-file
with-output-to-file with-input-from-file
exit-handler current-eval current-exception-handler
exit-handler current-eval initial-exception-handler
current-prompt-read current-load
call-with-escape-continuation call-with-current-continuation
current-print port-display-handler port-write-handler
@ -97,7 +97,9 @@
error-display-handler error-escape-handler
port-read-handler error-value->string-handler
call/ec call/cc hash-table-get
hash-table-map hash-table-for-each make-input-port make-output-port))
hash-table-map hash-table-for-each make-input-port make-output-port
call-with-composable-continuation
call-with-continuation-prompt))
;; The valueable? predicate is used to determine how many variables
;; are reliably set in a mutually-recursive binding context.

4
collects/drscheme/syncheck.ss
View File

@ -1035,8 +1035,8 @@ If the namespace does not, they are colored the unbound color.
(semaphore-post error-display-semaphore)))
(error-print-source-location #f) ; need to build code to render error first
(current-exception-handler
(let ([oh (current-exception-handler)])
(uncaught-exception-handler
(let ([oh (uncaught-exception-handler)])
(λ (exn)
(uncaught-exception-raised)
(oh exn))))

6
collects/eopl/eopl.ss
View File

@ -85,8 +85,8 @@
(namespace-set-variable-value! 'eopl:error-stop #f #t)
(define (install-eopl-exception-handler)
(current-exception-handler
(let ([eh (current-exception-handler)]
(uncaught-exception-handler
(let ([eh (uncaught-exception-handler)]
[orig-namespace (current-namespace)])
(lambda (x)
(let ([v (with-handlers ([void (lambda (x) #f)])
@ -181,7 +181,7 @@
;; We have to include the following MzScheme-isms to do anything,
;; but they're not legal R5RS names, anyway.
#%app #%datum #%top
#%app #%datum #%top #%top-interaction
(rename synrule-in-stx-module-begin #%module-begin))
(define-syntax synrule-in-stx-module-begin

4
collects/errortrace/stacktrace.ss
View File

@ -411,6 +411,10 @@
(certify
mb
(rebuild mb (map cons bodys bodyl)))))))))]
[(#%expression e)
top?
(certify expr #`(#%expression #,(annotate (syntax e) trans?)))]
;; No way to wrap
[(require i ...) expr]

10
collects/framework/test.ss
View File

@ -156,11 +156,11 @@
(install-timer (run-interval) return)
(unless (is-exn?)
(begin-action)
(parameterize ([current-exception-handler
(λ (exn)
(end-action-with-error exn)
((error-escape-handler)))])
(thunk))
(call-with-exception-handler
(λ (exn)
(end-action-with-error exn)
((error-escape-handler)))
thunk)
(end-action)))]
[return (λ () (semaphore-post sem))])

8
collects/frtime/frp-core.ss
View File

@ -183,7 +183,7 @@
(add1 (apply max 0 (append (map safe-signal-depth producers)
(map safe-signal-depth cust-sigs))))
ccm
(parameterize ([current-exception-handler
(parameterize ([uncaught-exception-handler
(lambda (exn) (exn-handler exn))]
[extra-cont-marks ccm])
(current-parameterization))
@ -209,7 +209,7 @@
(add1 (apply max 0 (append (map safe-signal-depth producers)
(map safe-signal-depth cust-sigs))))
ccm
(parameterize ([current-exception-handler
(parameterize ([uncaught-exception-handler
(lambda (exn) (exn-handler exn))]
[extra-cont-marks ccm])
(current-parameterization))
@ -270,7 +270,7 @@
(add1 (apply max 0 (append (map safe-signal-depth args)
(map safe-signal-depth cust-sigs))))
ccm
(parameterize ([current-exception-handler
(parameterize ([uncaught-exception-handler
(lambda (exn) (exn-handler exn))]
[extra-cont-marks ccm])
(current-parameterization))
@ -757,7 +757,7 @@
(undef cur-beh)
#;(kill-signal cur-beh)))
(outer))])
(set! exn-handler (current-exception-handler))
;; (set! exn-handler (current-exception-handler)) <-- FIXME!
(let inner ()
;; process external messages until there is an internal update

2
collects/frtime/graphics-posn-less-unit.ss
View File

@ -978,7 +978,7 @@
(lambda (name show?)
(unless sixlib-eventspace
(set! sixlib-eventspace
(parameterize ([current-exception-handler
(parameterize ([uncaught-exception-handler
(lambda (x)
((error-display-handler)
(format "internal error in graphics library: ~a"

1
collects/frtime/mzscheme-core.ss
View File

@ -404,6 +404,7 @@
#%datum
#%plain-module-begin
#%module-begin
#%top-interaction
(rename frp:if if)
(rename frp:lambda lambda)
(rename frp:case-lambda case-lambda)

2
collects/graphics/graphics-posn-less-unit.ss
View File

@ -1165,7 +1165,7 @@
(lambda (name show?)
(unless sixlib-eventspace
(set! sixlib-eventspace
(parameterize ([current-exception-handler
(parameterize ([uncaught-exception-handler
(lambda (x)
((error-display-handler)
(format "internal error in graphics library: ~a"

1
collects/lang/htdp-advanced.ss
View File

@ -42,6 +42,7 @@
;; (rename advanced-contract contract)
;; (rename advanced-define-data define-data)
#%datum
#%top-interaction
empty true false)
;; procedures:

1
collects/lang/htdp-beginner-abbr.ss
View File

@ -29,6 +29,7 @@
(rename intermediate-unquote-splicing unquote-splicing)
(rename beginner-module-begin #%module-begin)
#%datum
#%top-interaction
empty true false)
;; procedures:

1
collects/lang/htdp-beginner.ss
View File

@ -28,6 +28,7 @@
; (rename beginner-contract contract)
; (rename beginner-define-data define-data)
#%datum
#%top-interaction
empty true false)
(require-for-syntax "private/firstorder.ss")

1
collects/lang/htdp-intermediate-lambda.ss
View File

@ -31,6 +31,7 @@
;; (rename intermediate-contract contract)
;; (rename intermediate-define-data define-data)
#%datum
#%top-interaction
empty true false)
;; procedures:

1
collects/lang/htdp-intermediate.ss
View File

@ -32,6 +32,7 @@
;; (rename intermediate-contract contract)
;; (rename intermediate-define-data define-data)
#%datum
#%top-interaction
empty true false)
;; procedures:

20
collects/mred/private/lock.ss
View File

@ -50,16 +50,16 @@
(lambda ()
(set! old-paramz (current-parameterization))
(set! old-break-paramz (current-break-parameterization))
(parameterize ([error-value->string-handler entered-err-string-handler]
[current-exception-handler
(lambda (exn)
;; Get out of atomic region before letting
;; an exception handler work
(k (lambda () (raise exn))))])
(parameterize-break #f
(call-with-values
f
(lambda args (lambda () (apply values args)))))))
(parameterize ([error-value->string-handler entered-err-string-handler])
(with-handlers ([void (lambda (exn)
;; Get out of atomic region before letting
;; an exception handler work
(k (lambda () (raise exn))))])
(parameterize-break
#f
(call-with-values
f
(lambda args (lambda () (apply values args))))))))
(lambda ()
(set! monitor-owner #f)
(semaphore-post monitor-sema)

5
collects/mred/private/repl.ss
View File

@ -120,7 +120,10 @@
void
(lambda ()
(call-with-values
(lambda () (eval (read (open-input-string expr-str))))
(lambda () (call-with-continuation-prompt
(lambda () (eval (cons
'#%top-interaction
(read (open-input-string expr-str)))))))
(lambda results
(for-each
(lambda (v)

7
collects/mred/private/snipfile.ss
View File

@ -208,7 +208,12 @@
(let ([exp (read-syntax src in-port)])
(if (eof-object? exp)
(apply values last-time-values)
(call-with-values (lambda () (eval exp))
(call-with-values (lambda () (call-with-continuation-prompt
(lambda () (eval
(datum->syntax-object
#f
(cons '#%top-interaction exp)
exp)))))
(lambda x (loop x)))))))))
(lambda ()
(close-input-port in-port)))))

4
collects/mztake/debug-tool.ss
View File

@ -515,7 +515,7 @@
(lambda ()
;(print-struct #t)
(let ([self (current-thread)]
[oeh (current-exception-handler)]
[oeh (uncaught-exception-handler)]
[err-hndlr (error-display-handler)])
(error-display-handler
(lambda (msg exn)
@ -546,7 +546,7 @@
(let* ([debug-marks (continuation-mark-set->list ccm debug-key)])
(apply values
(send (get-tab) suspend oeh (cons top-mark debug-marks) (cons 'exit-break vals))))])))
(current-exception-handler
(uncaught-exception-handler
(lambda (exn)
(if (and (exn:break? exn) (send (get-tab) suspend-on-break?))
(let ([marks (exn-continuation-marks exn)]

2
collects/r5rs/lang.ss
View File

@ -87,7 +87,7 @@
;; We have to include the following MzScheme-isms to do anything,
;; but they're not legal R5RS names, anyway.
#%app #%datum #%top
#%app #%datum #%top #%top-interaction
(rename synrule-in-stx-module-begin #%module-begin)
(rename require #%require)
(rename provide #%provide))

4
collects/sirmail/folderr.ss
View File

@ -462,11 +462,9 @@
(send top-list set-mailbox-name (ROOT-MAILBOX-FOR-LIST))
(update-gui (read-mailbox-folder))
(initial-exception-handler
(uncaught-exception-handler
(lambda (x)
(show-error x frame)
((error-escape-handler))))
(current-exception-handler
(initial-exception-handler))
frame))

5
collects/sirmail/readr.ss
View File

@ -83,14 +83,11 @@
'(app)))
(show-pref-dialog))))
(initial-exception-handler
(uncaught-exception-handler
(lambda (x)
(show-error x)
((error-escape-handler))))
(current-exception-handler
(initial-exception-handler))
;; Install std bindings global for file dialog, etc.
(let ([km (make-object keymap%)])
(add-text-keymap-functions km)

4
collects/sirmail/sendr.ss
View File

@ -700,12 +700,10 @@
(send mailer-frame show #t)
(initial-exception-handler
(uncaught-exception-handler
(lambda (x)
(show-error x mailer-frame)
((error-escape-handler))))
(current-exception-handler
(initial-exception-handler))
mailer-frame)

4
collects/skipper/debug-tool.ss
View File

@ -568,7 +568,7 @@
(run-in-evaluation-thread
(lambda ()
(let ([self (current-thread)]
[oeh (current-exception-handler)]
[oeh (uncaught-exception-handler)]
[err-hndlr (error-display-handler)])
(error-display-handler
(lambda (msg exn)
@ -589,7 +589,7 @@
(lambda (ccm kind info)
(let* ([debug-marks (continuation-mark-set->list ccm debug-key)])
(send parent suspend oeh (cons info debug-marks) kind)))))
(current-exception-handler
(uncaught-exception-handler
(lambda (exn)
(if (and (exn:break? exn) (send parent suspend-on-break?))
(let ([marks (exn-continuation-marks exn)]

3
collects/slideshow/tool.ss
View File

@ -831,6 +831,9 @@ pict snip :
(with-syntax ([(rewritten-expr ...) (map (lambda (x) (add-send-over (rewrite-expr x) x 1))
(syntax->list (syntax (expr ...))))])
(syntax/cert stx (#%app rewritten-expr ...)))]
[(#%expression e)
(with-syntax ([e (add-send-over (rewrite-expr #'x) #'x 1)])
(syntax/cert stx (#%expression e)))]
[(#%datum . datum) stx]
[(#%top . variable) stx]))

4
collects/slideshow/viewer.ss
View File

@ -1149,8 +1149,8 @@
(when config:printing?
(do-print)))
(let ([eh (current-exception-handler)])
(current-exception-handler
(let ([eh (uncaught-exception-handler)])
(uncaught-exception-handler
(lambda (exn)
(send f show #f)
(when f-both

6
collects/srfi/1/util.ss
View File

@ -67,7 +67,7 @@
;; Return (map cdr lists).
;; However, if any element of LISTS is empty, just abort and return '().
(define (%cdrs lists)
(call-with-current-continuation
(call-with-escape-continuation
(lambda (abort)
(let recur ((lists lists))
(if (pair? lists)
@ -85,7 +85,7 @@
;; However, if any of the lists is empty, just abort and return [() ()].
(define (%cars+cdrs lists)
(call-with-current-continuation
(call-with-escape-continuation
(lambda (abort)
(let recur ((lists lists))
(if (pair? lists)
@ -99,7 +99,7 @@
;; Like %CARS+CDRS, but we pass in a final elt tacked onto the end of the
;; cars list. What a hack.
(define (%cars+cdrs+ lists cars-final)
(call-with-current-continuation
(call-with-escape-continuation
(lambda (abort)
(let recur ((lists lists))
(if (pair? lists)

7
collects/syntax/doc.txt
View File

@ -189,7 +189,8 @@ _struct.ss_: generating the same names as `define-struct'
> (generate-struct-declaration orig-stx name-id super-id-or-false
field-id-list current-context
make-make-struct-type)
make-make-struct-type
[omit-sel? omit-set?])
This procedure implements the core of a `define-struct' expansion.
@ -198,7 +199,9 @@ _struct.ss_: generating the same names as `define-struct'
`super-id-or-false', and `field-id-list' arguments provide the main
parameters. The `current-context' argument is normally the result of
`syntax-local-context'. The `orig-stx' argument is used for syntax
errors.
errors. The optional `omit-sel?' and `omit-set?' arguments default
to #f; a #t value suppresses definitions of field selectors or
mutators, respectively.
The `make-struct-type' procedure is called to generate the
expression to actually create the struct type. Its arguments are

3
collects/syntax/kerncase.ss
View File

@ -16,7 +16,7 @@
let-values letrec-values
begin begin0 set!
with-continuation-mark
if #%app
if #%app #%expression
define-values define-syntaxes define-values-for-syntax
module #%plain-module-begin require provide
require-for-syntax require-for-template
@ -54,6 +54,7 @@
quote
letrec-syntaxes+values
with-continuation-mark
#%expression
#%app
#%top
#%datum

2
collects/syntax/primitives.ss
View File

@ -9,7 +9,7 @@
make-object call-with-values time-apply
call-with-output-file call-with-input-file
with-output-to-file with-input-from-file
exit-handler current-eval current-exception-handler
exit-handler current-eval initial-exception-handler
current-prompt-read current-load
call-with-escape-continuation call-with-current-continuation
current-print port-display-handler port-write-handler

38
collects/syntax/struct.ss
View File

@ -303,24 +303,26 @@
#`(make-struct-field-mutator mutate #,n '#,(car field-names))
(loop (cdr field-names) (add1 n))))))))
(define (generate-struct-declaration orig-stx
name super-id field-names
context
make-make-struct-type)
(let ([defined-names (build-struct-names name field-names #f #f name)])
(let-values ([(super-info stx-info) (get-stx-info orig-stx super-id defined-names)])
(let ([result
#`(begin
(define-values
#,defined-names
#,(make-core make-make-struct-type orig-stx defined-names super-info name field-names))
(define-syntaxes (#,name)
#,stx-info))])
(if super-id
(syntax-property result
'disappeared-use
(syntax-local-introduce super-id))
result)))))
(define generate-struct-declaration
(opt-lambda (orig-stx
name super-id field-names
context
make-make-struct-type
[no-sel? #f] [no-set? #f])
(let ([defined-names (build-struct-names name field-names no-sel? no-set? name)])
(let-values ([(super-info stx-info) (get-stx-info orig-stx super-id defined-names)])
(let ([result
#`(begin
(define-values
#,defined-names
#,(make-core make-make-struct-type orig-stx defined-names super-info name field-names))
(define-syntaxes (#,name)
#,stx-info))])
(if super-id
(syntax-property result
'disappeared-use
(syntax-local-introduce super-id))
result))))))
(provide/contract
[build-struct-names

3
collects/syntax/zodiac-unit.ss
View File

@ -522,6 +522,9 @@
(lambda (arg)
(loop arg env trans?))
(syntax->list (syntax (arg ...)))))]
[(#%expression e)
(loop (syntax e) env trans?)]
[_else
(error 'syntax->zodiac

10
collects/tests/framework/framework-test-engine.ss
View File

@ -63,13 +63,17 @@
[port (current-output-port)])
(event-dispatch-handler
(lambda (evt)
(parameterize ([current-exception-handler
(let ([oe (current-exception-handler)])
(parameterize ([uncaught-exception-handler
(let ([oe (uncaught-exception-handler)])
(lambda (exn)
(protect
(lambda ()
(set! errs (cons exn errs))))
(oe exn)))])
(od evt)))))
(call-with-exception-handler
(lambda (exn)
((uncaught-exception-handler) exn))
(lambda ()
(od evt)))))))
(yield (make-semaphore 0)))

4
collects/tests/mzscheme/basic.ss
View File

@ -1574,12 +1574,14 @@
(test '((10 11 12) (13 . 14) (10 11 12) (13 . 14))
ra-b-a-b r10-11-12 r13.14)
(test 10 call/cc (lambda (k) (k 10)))
(test '((enter exit enter exit)
(exit enter exit enter)
(enter exit enter exit)
(exit enter exit enter))
ra-b-a-b
(lambda () (ra-b-a-b (lambda () 'enter) (lambda () 'exit)))
(lambda () (ra-b-a-b (lambda () 'enter) (lambda () 'exit)))
(lambda () (ra-b-a-b (lambda () 'exit) (lambda () 'enter))))
(test '(enter exit enter exit)

400
collects/tests/mzscheme/prompt.ss
View File

@ -199,6 +199,29 @@
(test-breaks-ok)
;; Abort to a prompt in a d-w post that is deeper than a
;; prompt with the same tag at the continuation-jump site:
(test 0
values
(let ([p1 (make-continuation-prompt-tag)]
[p2 (make-continuation-prompt-tag)])
(let/cc k
(call-with-continuation-prompt
(lambda ()
(call-with-continuation-prompt
(lambda ()
(dynamic-wind
void
(lambda ()
(call-with-continuation-prompt
(lambda ()
(k 0))
p2))
(lambda ()
(abort-current-continuation p1 (lambda () 0)))))
p1))
p2))))
;; ----------------------------------------
;; Continuations
@ -470,10 +493,21 @@
;; ----------------------------------------
;; Composable continuations
(err/rt-test (call-with-composable-continuation
(lambda (x) x))
(err/rt-test (call-with-continuation-barrier
;; When the test is not run in a REPL but is run in the
;; main thread, then it should fail without the barrier,
;; too. But we don't have enough control over the test
;; environment to assume that.
(lambda ()
(call-with-composable-continuation
(lambda (x) x))))
exn:fail:contract:continuation?)
(err/rt-test (call-with-composable-continuation
(lambda (x) x)
(make-continuation-prompt-tag 'px))
exn:fail:contract?)
(let ([k (call-with-continuation-prompt
(lambda ()
(call-with-composable-continuation
@ -804,6 +838,7 @@
p2))
(lambda () (out 'post1))))
p1))
(printf "here ~a\n" count)
(set! count (add1 count))
(unless (= count 3)
(call-with-continuation-prompt
@ -812,6 +847,8 @@
p2))
(test '(post2 post2 post1 post2 pre2 pre1) values l))
(printf "into post from escape\n")
;; Jump into post from an escape, rather than
;; from a result continuation
(let ([l null]
@ -1069,6 +1106,7 @@
(k (lambda () (k3 (lambda () (esc)))))))))))))])
(jump-in (lambda (f) (f (lambda () 10))) 10 88)
(jump-in (lambda (f) (let/cc esc (f (lambda () (esc 20))))) 20 99)
(printf "here\n")
(jump-in (lambda (f)
(let ([p1 (make-continuation-prompt-tag)])
(call-with-continuation-prompt
@ -1296,6 +1334,342 @@
(test-breaks-ok)
;; ----------------------------------------
;; Some repeats, but ensure a continuation prompt
;; and check d-w interaction.
(let ([output null])
(call-with-continuation-prompt
(lambda ()
(dynamic-wind
(lambda () (set! output (cons 'in output)))
(lambda ()
(let ([finished #f])
(define (go)
(let ([p1 (make-continuation-prompt-tag)]
[counter 10])
(let ([k (call-with-continuation-prompt
(lambda ()
((call/cc (lambda (k) (lambda () k))
p1)))
p1)])
(let ([k2 (list
(call-with-continuation-prompt
(lambda ()
(k (lambda ()
((let/cc k (lambda () k))))))
p1))])
(current-milliseconds)
(if (procedure? (car k2))
((car k2) (lambda ()
(if (zero? counter)
10
(begin
(set! counter (sub1 counter))
((let/cc k (lambda () k)))))))
(values '(10) values k2))
(set! finished 'finished)))))
(go)))
(lambda () (set! output (cons 'out output)))))
(default-continuation-prompt-tag)
void)
(test '(out in) values output))
(let ([output null])
(call-with-continuation-prompt
(lambda ()
(dynamic-wind
(lambda () (set! output (cons 'in output)))
(lambda ()
(let ([p1 (make-continuation-prompt-tag)])
(let/cc esc
(let ([k
(call-with-continuation-prompt
(lambda ()
((call-with-composable-continuation
(lambda (k)
(lambda () k))
p1)))
p1)])
(/ (k (lambda () (esc 0))))))))
(lambda () (set! output (cons 'out output)))))
(default-continuation-prompt-tag)
void)
(test '(out in) values output))
;;----------------------------------------
;; tests invoking delimited captures in dynamic-wind pre- and post-thunks
;; Arrange for a post-thunk to remove a target
;; for an escape:
(err/rt-test
(let ([p1 (make-continuation-prompt-tag 'p1)]
[exit-k #f])
(let ([x (let/ec esc
(call-with-continuation-prompt
(lambda ()
(dynamic-wind
(lambda () (void))
(lambda () (esc 'done))
(lambda ()
((call/cc
(lambda (k)
(set! exit-k k)
(lambda () 10))
p1))
(printf "post\n"))))
p1))])
(call-with-continuation-barrier
(lambda ()
(call-with-continuation-prompt
(lambda ()
(exit-k (lambda () 'hi)))
p1)))))
exn:fail:contract:continuation?)
;; Same thing, but escape via prompt:
(err/rt-test
(let ([p1 (make-continuation-prompt-tag 'p1)]
[p2 (make-continuation-prompt-tag 'p2)]
[output null]
[exit-k #f])
(let ([x (call-with-continuation-prompt
(lambda ()
(call-with-continuation-prompt
(lambda ()
(dynamic-wind
(lambda () (void))
(lambda () (abort-current-continuation p2 1 2 3))
(lambda ()
((call/cc
(lambda (k)
(set! exit-k k)
(lambda () 10))
p1))
(set! output (cons 'post output)))))
p1))
p2
void)])
(call-with-continuation-barrier
(lambda ()
(call-with-continuation-prompt
(lambda ()
(exit-k (lambda () 'hi)))
p1)))))
exn:fail:contract?)
;; Arrange for a barrier to interfere with a continuation
;; jump after dynamic-winds are already being processed:
(let ([p1 (make-continuation-prompt-tag 'p1)]
[output null]
[exit-k #f])
(let ([go
(lambda (launch)
(let ([k (let/cc esc
(call-with-continuation-prompt
(lambda ()
(dynamic-wind
(lambda () (void))
(lambda ()
(with-handlers ([void (lambda (exn)
(test #f "should not be used!" #t))])
(launch esc)))
(lambda ()
((call/cc
(lambda (k)
(set! exit-k k)
(lambda () 10))
p1))
(set! output (cons 'post output)))))
p1))])
(call-with-continuation-barrier
(lambda ()
(call-with-continuation-prompt
(lambda ()
(exit-k (lambda () 'hi)))
p1)))))])
(err/rt-test
(go (lambda (esc) (esc 'middle)))
exn:fail:contract:continuation?)
(test '(post post) values output)
(let ([meta (call-with-continuation-prompt
(lambda ()
((call-with-composable-continuation
(lambda (k) (lambda () k))))))])
(err/rt-test
(go (lambda (esc)
(meta
(lambda () (esc 'ok)))))
exn:fail:contract:continuation?))
(test '(post post post post) values output)))
;; Similar, but more checking of dropped d-ws:
(let ([p1 (make-continuation-prompt-tag 'p1)]
[output null]
[exit-k #f]
[done? #f])
;; Capture a continuation w.r.t. the default prompt tag:
(call/cc
(lambda (esc)
(dynamic-wind
(lambda () (void))
(lambda ()
;; Set a prompt for tag p1:
(call-with-continuation-prompt
(lambda ()
(dynamic-wind
(lambda () (void))
;; inside d-w, jump out:
(lambda () (esc 'done))
(lambda ()
;; As we jump out, capture a continuation
;; w.r.t. p1:
((call/cc
(lambda (k)
(set! exit-k k)
(lambda () 10))
p1))
(set! output (cons 'inner output)))))
p1))
(lambda ()
;; This post thunk is not in the
;; delimited continuation captured
;; via tag p1:
(set! output (cons 'outer output))))))
(unless done?
(set! done? #t)
;; Now invoke the delimited continuation, which must
;; somehow continue the jump to `esc':
(call-with-continuation-prompt
(lambda ()
(exit-k (lambda () 10)))
p1))
(test '(inner outer inner) values output))
;; Again, more checking of output
(let ([p1 (make-continuation-prompt-tag 'p1)]
[p2 (make-continuation-prompt-tag 'p2)]
[output null]
[exit-k #f])
;; Set up a prompt tp jump to:
(call-with-continuation-prompt
(lambda ()
(dynamic-wind
(lambda () (void))
(lambda ()
;; Set a prompt for tag p1:
(call-with-continuation-prompt
(lambda ()
(dynamic-wind
(lambda () (void))
;; inside d-w, jump out:
(lambda () (abort-current-continuation
p2
"done"))
(lambda ()
;; As we jump out, capture a continuation
;; w.r.t. p1:
((call/cc
(lambda (k)
(set! exit-k k)
(lambda () 10))
p1))
(set! output (cons 'inner output)))))
p1))
(lambda ()
;; This post thunk is not in the
;; delimited continuation captured
;; via tag p1:
(set! output (cons 'outer output)))))
p2
(lambda (v)
(set! output (cons 'orig output))))
;; Now call, redirecting the escape to here:
(call-with-continuation-prompt
(lambda ()
(call-with-continuation-prompt
(lambda ()
(exit-k (lambda () 10)))
p1))
p2
(lambda (v)
(set! output (cons 'new output))))
(test '(new inner orig outer inner) values output))
;; abort past a tag
(test 10
values
(let ([p1 (make-continuation-prompt-tag)]
[p2 (make-continuation-prompt-tag)])
(call-with-continuation-prompt
(lambda ()
(call/cc
(lambda (k)
(call-with-continuation-prompt
(lambda ()
(k 10))
p2))
p1))
p1)))
;; Check that a prompt is not somehow tied to its original
;; barrier, so that jumps are not allowed when they should
;; be:
(test 0
values
(let ([p1 (make-continuation-prompt-tag 'p1)]
[p2 (make-continuation-prompt-tag 'p2)])
(let ([k (call-with-continuation-prompt
(lambda ()
(call-with-continuation-prompt
(lambda ()
((call-with-current-continuation
(lambda (k) (lambda () k))
p2)))
p1))
p2)])
(call-with-continuation-barrier
(lambda ()
(call-with-continuation-barrier
(lambda ()
(let ([k1
(call-with-continuation-prompt
(lambda ()
(k
(lambda ()
;; prompt for p1 has been restored
(call/cc (lambda (k1) k1) p1))))
p2)])
(call-with-continuation-prompt
(lambda ()
(k1 0))
p1)))))))))
(test 12
values
(let ([p1 (make-continuation-prompt-tag 'p1)])
(let ([k (call-with-continuation-barrier
(lambda ()
(call-with-continuation-prompt
(lambda ()
((call-with-current-continuation
(lambda (k) (lambda () k))
p1)))
p1)))])
(call-with-continuation-barrier
(lambda ()
(call-with-continuation-barrier
(lambda ()
(call-with-continuation-barrier
(lambda ()
(call-with-continuation-prompt
(lambda ()
(let/cc w
(call-with-continuation-prompt
(lambda ()
(k (lambda () (w 12))))
p1)))))))))))))
;; ----------------------------------------
;; Try long chain of composable continuations
@ -1343,7 +1717,7 @@
(k (lambda () 17)))
(test #t procedure? once-k)
(test k values 17)
(err/rt-test (call-with-continuation-prompt
(err/rt-test (call-with-continuation-barrier
(lambda ()
(once-k 18)))
exn:fail:contract:continuation?))
@ -1364,4 +1738,24 @@
;; ----------------------------------------
(unless (namespace-variable-value 'running-prompt-tests-in-thread? #f (lambda () #f))
;; Run the whole thing in a thread with no prompts around evaluation.
;; This tests the special case of the implicit prompt at the start
;; of a thread.
(thread-wait
(thread
(lambda ()
(namespace-set-variable-value! 'running-prompt-tests-in-thread? #t)
(let ([p (open-input-file (build-path
(or (current-load-relative-directory)
(current-directory))
"prompt.ss"))])
(let loop ()
(let ([r (read-syntax (object-name p) p)])
(unless (eof-object? r)
(eval r)
(loop)))))))))
;; ----------------------------------------
(report-errs)

27
collects/tests/mzscheme/quiet.ss
View File

@ -9,9 +9,10 @@
(lambda ()
(let ([err (current-error-port)]
[exit (exit-handler)]
[errh (current-exception-handler)]
[errh (uncaught-exception-handler)]
[esch (error-escape-handler)]
[cust (current-custodian)])
[cust (current-custodian)]
[orig-thread (current-thread)])
(namespace-set-variable-value! 'real-error-port err)
;; we're loading this for the first time:
;; -- make real errors show
@ -19,12 +20,10 @@
;; handler is overridden to avoid running off, so use the first to
;; save the data and the second to show it)
(let ([last-error #f])
(current-exception-handler (lambda (e) (set! last-error e) (errh e)))
(error-escape-handler
(lambda ()
(fprintf err "ERROR: ~a\n"
(if (exn? last-error) (exn-message last-error) last-error))
(exit 2))))
(uncaught-exception-handler (lambda (e)
(when (eq? (current-thread) orig-thread)
(set! last-error e))
(errh e))))
;; -- set up a timeout
(thread (lambda ()
(sleep 600)
@ -37,6 +36,14 @@
(let ([p (make-output-port
'quiet always-evt (lambda (str s e nonblock? breakable?) (- e s))
void)])
(parameterize ([current-output-port p] [current-error-port p])
(load-relative quiet-load))
(call-with-continuation-prompt
(lambda ()
(parameterize ([current-output-port p] [current-error-port p])
(load-relative quiet-load)))
(default-continuation-prompt-tag)
(lambda ()
(when last-error
(fprintf err "ERROR: ~a\n"
(if (exn? last-error) (exn-message last-error) last-error))
(exit 2))))
(report-errs #t))

8
collects/tests/mzscheme/syntax.ss
View File

@ -922,14 +922,14 @@
(test 5 'parameterize (parameterize () 5))
(test 6 'parameterize (parameterize ([error-print-width 10]) 6))
(test 7 'parameterize (parameterize ([error-print-width 10]
[current-exception-handler void])
7))
[uncaught-exception-handler void])
7))
(define oepw (error-print-width))
(error-test #'(parameterize ([error-print-width 777]) (error 'bad)) exn:fail?)
(test oepw 'parameterize (error-print-width))
(error-test #'(parameterize ([error-print-width 777]
[current-output-port (current-error-port)])
(error 'bad))
[current-output-port (current-error-port)])
(error 'bad))
exn:fail?)
(error-test #'(parameterize ([error-print-width 'a]) 10))

34
collects/tests/mzscheme/testing.ss
View File

@ -120,11 +120,7 @@ transcript.
(flush-output)
(call/ec (lambda (escape)
(let* ([old-esc-handler (error-escape-handler)]
[old-handler (current-exception-handler)]
[orig-err-port (current-error-port)]
[test-handler
(lambda ()
(escape #t))]
[test-exn-handler
(lambda (e)
(when (and exn? (not (exn? e)))
@ -148,22 +144,30 @@ transcript.
(record-error (list e (cons 'exn-elem sel) expr)))))))
exn-table)
(old-handler e))])
((error-display-handler)
(if (exn? e)
(exn-message e)
(format "misc. exn: ~s" e))
e)
(escape #t))])
(dynamic-wind
(lambda ()
(current-error-port (current-output-port))
(current-exception-handler test-exn-handler)
(error-escape-handler test-handler))
(current-error-port (current-output-port)))
(lambda ()
(let ([v (call-with-values th list)])
(write (cons 'values v))
(display " BUT EXPECTED ERROR")
(record-error (list v 'Error expr))
(newline)
#f))
(call-with-continuation-prompt
(lambda ()
(call-with-exception-handler
test-exn-handler
(lambda ()
(let ([v (call-with-values th list)])
(write (cons 'values v))
(display " BUT EXPECTED ERROR")
(record-error (list v 'Error expr))
(newline)
#f))))))
(lambda ()
(current-error-port orig-err-port)
(current-exception-handler old-handler)
(error-escape-handler old-esc-handler))))))]))
(defvar error-test

1
collects/tests/mzscheme/unicode.ss
View File

@ -1430,6 +1430,7 @@
#\u000C
#\u000D
#\u0020
#\u0085
#\u00A0
#\u1680
#\u2000

20
collects/tests/utils/mz-testing.ss
View File

@ -116,7 +116,6 @@
(display " =e=> ")
(call/ec (lambda (escape)
(let* ([old-esc-handler (error-escape-handler)]
[old-handler (current-exception-handler)]
[orig-err-port (current-error-port)]
[test-handler
(lambda ()
@ -144,22 +143,23 @@
(record-error (list e (cons 'exn-elem sel) expr)))))))
exn-table)
(old-handler e))])
(test-handler))])
(dynamic-wind
(lambda ()
(current-error-port (current-output-port))
(current-exception-handler test-exn-handler)
(error-escape-handler test-handler))
(lambda ()
(let ([v (th)])
(write v)
(display " BUT EXPECTED ERROR")
(record-error (list v 'Error expr))
(newline)
#f))
(call-with-exception-handler
test-exn-handler
(lambda ()
(let ([v (th)])
(write v)
(display " BUT EXPECTED ERROR")
(record-error (list v 'Error expr))
(newline)
#f))))
(lambda ()
(current-error-port orig-err-port)
(current-exception-handler old-handler)
(error-escape-handler old-esc-handler))))))]))
(define error-test

2
collects/web-server/private/servlet-helpers.ss
View File

@ -86,7 +86,7 @@
; to report exceptions that occur later to the browser
; this must be called at the begining of a servlet
(define (report-errors-to-browser send/finish-or-back)
(current-exception-handler
(uncaught-exception-handler
(lambda (exn)
(send/finish-or-back
`(html (head (title "Servlet Error"))