From cf0b303497763314db7f530a6e2d2010ffe44eac Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 20 Dec 2006 00:57:12 +0000 Subject: [PATCH] 359.2, collects changes svn: r5143 --- collects/compiler/private/known.ss | 8 +- collects/drscheme/syncheck.ss | 4 +- collects/eopl/eopl.ss | 6 +- collects/errortrace/stacktrace.ss | 4 + collects/framework/test.ss | 10 +- collects/frtime/frp-core.ss | 8 +- collects/frtime/graphics-posn-less-unit.ss | 2 +- collects/frtime/mzscheme-core.ss | 1 + collects/graphics/graphics-posn-less-unit.ss | 2 +- collects/lang/htdp-advanced.ss | 1 + collects/lang/htdp-beginner-abbr.ss | 1 + collects/lang/htdp-beginner.ss | 1 + collects/lang/htdp-intermediate-lambda.ss | 1 + collects/lang/htdp-intermediate.ss | 1 + collects/mred/private/lock.ss | 20 +- collects/mred/private/repl.ss | 5 +- collects/mred/private/snipfile.ss | 7 +- collects/mztake/debug-tool.ss | 4 +- collects/r5rs/lang.ss | 2 +- collects/sirmail/folderr.ss | 4 +- collects/sirmail/readr.ss | 5 +- collects/sirmail/sendr.ss | 4 +- collects/skipper/debug-tool.ss | 4 +- collects/slideshow/tool.ss | 3 + collects/slideshow/viewer.ss | 4 +- collects/srfi/1/util.ss | 6 +- collects/syntax/doc.txt | 7 +- collects/syntax/kerncase.ss | 3 +- collects/syntax/primitives.ss | 2 +- collects/syntax/struct.ss | 38 +- collects/syntax/zodiac-unit.ss | 3 + .../tests/framework/framework-test-engine.ss | 10 +- collects/tests/mzscheme/basic.ss | 4 +- collects/tests/mzscheme/prompt.ss | 400 +++++++++++++++++- collects/tests/mzscheme/quiet.ss | 27 +- collects/tests/mzscheme/syntax.ss | 8 +- collects/tests/mzscheme/testing.ss | 34 +- collects/tests/mzscheme/unicode.ss | 1 + collects/tests/utils/mz-testing.ss | 20 +- .../web-server/private/servlet-helpers.ss | 2 +- 40 files changed, 557 insertions(+), 120 deletions(-) diff --git a/collects/compiler/private/known.ss b/collects/compiler/private/known.ss index 6991aff0f2..f9a0bd33ea 100644 --- a/collects/compiler/private/known.ss +++ b/collects/compiler/private/known.ss @@ -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. diff --git a/collects/drscheme/syncheck.ss b/collects/drscheme/syncheck.ss index 64ea481125..35656b72ad 100644 --- a/collects/drscheme/syncheck.ss +++ b/collects/drscheme/syncheck.ss @@ -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)))) diff --git a/collects/eopl/eopl.ss b/collects/eopl/eopl.ss index a63bc2f96b..e980096bfe 100644 --- a/collects/eopl/eopl.ss +++ b/collects/eopl/eopl.ss @@ -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 diff --git a/collects/errortrace/stacktrace.ss b/collects/errortrace/stacktrace.ss index 8884e19d75..e5bc0d5b49 100644 --- a/collects/errortrace/stacktrace.ss +++ b/collects/errortrace/stacktrace.ss @@ -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] diff --git a/collects/framework/test.ss b/collects/framework/test.ss index b72d3a06ef..750bc28062 100644 --- a/collects/framework/test.ss +++ b/collects/framework/test.ss @@ -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))]) diff --git a/collects/frtime/frp-core.ss b/collects/frtime/frp-core.ss index 3e670acf87..f0054ea09c 100644 --- a/collects/frtime/frp-core.ss +++ b/collects/frtime/frp-core.ss @@ -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 diff --git a/collects/frtime/graphics-posn-less-unit.ss b/collects/frtime/graphics-posn-less-unit.ss index 8e3fd84c2f..9d7892c569 100644 --- a/collects/frtime/graphics-posn-less-unit.ss +++ b/collects/frtime/graphics-posn-less-unit.ss @@ -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" diff --git a/collects/frtime/mzscheme-core.ss b/collects/frtime/mzscheme-core.ss index ef81b1556a..6883f8b3e0 100644 --- a/collects/frtime/mzscheme-core.ss +++ b/collects/frtime/mzscheme-core.ss @@ -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) diff --git a/collects/graphics/graphics-posn-less-unit.ss b/collects/graphics/graphics-posn-less-unit.ss index 9c13859c37..42b514063a 100644 --- a/collects/graphics/graphics-posn-less-unit.ss +++ b/collects/graphics/graphics-posn-less-unit.ss @@ -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" diff --git a/collects/lang/htdp-advanced.ss b/collects/lang/htdp-advanced.ss index 812ab03cc1..07ffe4011f 100644 --- a/collects/lang/htdp-advanced.ss +++ b/collects/lang/htdp-advanced.ss @@ -42,6 +42,7 @@ ;; (rename advanced-contract contract) ;; (rename advanced-define-data define-data) #%datum + #%top-interaction empty true false) ;; procedures: diff --git a/collects/lang/htdp-beginner-abbr.ss b/collects/lang/htdp-beginner-abbr.ss index b6dcb36775..dbee72e27d 100644 --- a/collects/lang/htdp-beginner-abbr.ss +++ b/collects/lang/htdp-beginner-abbr.ss @@ -29,6 +29,7 @@ (rename intermediate-unquote-splicing unquote-splicing) (rename beginner-module-begin #%module-begin) #%datum + #%top-interaction empty true false) ;; procedures: diff --git a/collects/lang/htdp-beginner.ss b/collects/lang/htdp-beginner.ss index bc79ebf245..188b418e18 100644 --- a/collects/lang/htdp-beginner.ss +++ b/collects/lang/htdp-beginner.ss @@ -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") diff --git a/collects/lang/htdp-intermediate-lambda.ss b/collects/lang/htdp-intermediate-lambda.ss index 143e9efb7d..0d0ead4cb7 100644 --- a/collects/lang/htdp-intermediate-lambda.ss +++ b/collects/lang/htdp-intermediate-lambda.ss @@ -31,6 +31,7 @@ ;; (rename intermediate-contract contract) ;; (rename intermediate-define-data define-data) #%datum + #%top-interaction empty true false) ;; procedures: diff --git a/collects/lang/htdp-intermediate.ss b/collects/lang/htdp-intermediate.ss index 99525549a6..79a44845ca 100644 --- a/collects/lang/htdp-intermediate.ss +++ b/collects/lang/htdp-intermediate.ss @@ -32,6 +32,7 @@ ;; (rename intermediate-contract contract) ;; (rename intermediate-define-data define-data) #%datum + #%top-interaction empty true false) ;; procedures: diff --git a/collects/mred/private/lock.ss b/collects/mred/private/lock.ss index e63d9aff5a..594563cabe 100644 --- a/collects/mred/private/lock.ss +++ b/collects/mred/private/lock.ss @@ -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) diff --git a/collects/mred/private/repl.ss b/collects/mred/private/repl.ss index a75a1252df..96aaea9ebd 100644 --- a/collects/mred/private/repl.ss +++ b/collects/mred/private/repl.ss @@ -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) diff --git a/collects/mred/private/snipfile.ss b/collects/mred/private/snipfile.ss index 76de33485a..ca13f08408 100644 --- a/collects/mred/private/snipfile.ss +++ b/collects/mred/private/snipfile.ss @@ -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))))) diff --git a/collects/mztake/debug-tool.ss b/collects/mztake/debug-tool.ss index af699406c3..ac022d4950 100644 --- a/collects/mztake/debug-tool.ss +++ b/collects/mztake/debug-tool.ss @@ -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)] diff --git a/collects/r5rs/lang.ss b/collects/r5rs/lang.ss index 17009c284e..1b0f83d302 100644 --- a/collects/r5rs/lang.ss +++ b/collects/r5rs/lang.ss @@ -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)) diff --git a/collects/sirmail/folderr.ss b/collects/sirmail/folderr.ss index 73623ceb2a..8cba727eb4 100644 --- a/collects/sirmail/folderr.ss +++ b/collects/sirmail/folderr.ss @@ -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)) diff --git a/collects/sirmail/readr.ss b/collects/sirmail/readr.ss index 0d6e648373..fcf92ddca3 100644 --- a/collects/sirmail/readr.ss +++ b/collects/sirmail/readr.ss @@ -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) diff --git a/collects/sirmail/sendr.ss b/collects/sirmail/sendr.ss index 2aa5fc719b..5aa2948329 100644 --- a/collects/sirmail/sendr.ss +++ b/collects/sirmail/sendr.ss @@ -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) diff --git a/collects/skipper/debug-tool.ss b/collects/skipper/debug-tool.ss index 15811a5300..44896acc97 100644 --- a/collects/skipper/debug-tool.ss +++ b/collects/skipper/debug-tool.ss @@ -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)] diff --git a/collects/slideshow/tool.ss b/collects/slideshow/tool.ss index fa8b07671d..420c0666e4 100644 --- a/collects/slideshow/tool.ss +++ b/collects/slideshow/tool.ss @@ -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])) diff --git a/collects/slideshow/viewer.ss b/collects/slideshow/viewer.ss index dd3484acab..9d31075813 100644 --- a/collects/slideshow/viewer.ss +++ b/collects/slideshow/viewer.ss @@ -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 diff --git a/collects/srfi/1/util.ss b/collects/srfi/1/util.ss index e7be2bdbac..1e1a490037 100644 --- a/collects/srfi/1/util.ss +++ b/collects/srfi/1/util.ss @@ -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) diff --git a/collects/syntax/doc.txt b/collects/syntax/doc.txt index d1a2989d33..6f2b83b2ef 100644 --- a/collects/syntax/doc.txt +++ b/collects/syntax/doc.txt @@ -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 diff --git a/collects/syntax/kerncase.ss b/collects/syntax/kerncase.ss index ea663a6b67..47ecb02b2e 100644 --- a/collects/syntax/kerncase.ss +++ b/collects/syntax/kerncase.ss @@ -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 diff --git a/collects/syntax/primitives.ss b/collects/syntax/primitives.ss index a7be3548de..122ca7f053 100644 --- a/collects/syntax/primitives.ss +++ b/collects/syntax/primitives.ss @@ -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 diff --git a/collects/syntax/struct.ss b/collects/syntax/struct.ss index 59872556fe..f5843a03e3 100644 --- a/collects/syntax/struct.ss +++ b/collects/syntax/struct.ss @@ -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 diff --git a/collects/syntax/zodiac-unit.ss b/collects/syntax/zodiac-unit.ss index f8b5e3dcda..8827171b00 100644 --- a/collects/syntax/zodiac-unit.ss +++ b/collects/syntax/zodiac-unit.ss @@ -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 diff --git a/collects/tests/framework/framework-test-engine.ss b/collects/tests/framework/framework-test-engine.ss index 371db41e31..c09732f0a8 100644 --- a/collects/tests/framework/framework-test-engine.ss +++ b/collects/tests/framework/framework-test-engine.ss @@ -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))) diff --git a/collects/tests/mzscheme/basic.ss b/collects/tests/mzscheme/basic.ss index 5d04571a49..ded6b08e1f 100644 --- a/collects/tests/mzscheme/basic.ss +++ b/collects/tests/mzscheme/basic.ss @@ -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) diff --git a/collects/tests/mzscheme/prompt.ss b/collects/tests/mzscheme/prompt.ss index 0edb47b3c1..8a2576b0db 100644 --- a/collects/tests/mzscheme/prompt.ss +++ b/collects/tests/mzscheme/prompt.ss @@ -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) diff --git a/collects/tests/mzscheme/quiet.ss b/collects/tests/mzscheme/quiet.ss index 8986e5a2e4..616b5b19f8 100644 --- a/collects/tests/mzscheme/quiet.ss +++ b/collects/tests/mzscheme/quiet.ss @@ -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)) diff --git a/collects/tests/mzscheme/syntax.ss b/collects/tests/mzscheme/syntax.ss index 48f3910345..33cfac9e43 100644 --- a/collects/tests/mzscheme/syntax.ss +++ b/collects/tests/mzscheme/syntax.ss @@ -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)) diff --git a/collects/tests/mzscheme/testing.ss b/collects/tests/mzscheme/testing.ss index cc6e1842b7..6f4724fe62 100644 --- a/collects/tests/mzscheme/testing.ss +++ b/collects/tests/mzscheme/testing.ss @@ -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 diff --git a/collects/tests/mzscheme/unicode.ss b/collects/tests/mzscheme/unicode.ss index c811f45bcf..d9de98c850 100644 --- a/collects/tests/mzscheme/unicode.ss +++ b/collects/tests/mzscheme/unicode.ss @@ -1430,6 +1430,7 @@ #\u000C #\u000D #\u0020 + #\u0085 #\u00A0 #\u1680 #\u2000 diff --git a/collects/tests/utils/mz-testing.ss b/collects/tests/utils/mz-testing.ss index 45bba873e6..211e718896 100644 --- a/collects/tests/utils/mz-testing.ss +++ b/collects/tests/utils/mz-testing.ss @@ -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 diff --git a/collects/web-server/private/servlet-helpers.ss b/collects/web-server/private/servlet-helpers.ss index 4730000021..f1cb515035 100644 --- a/collects/web-server/private/servlet-helpers.ss +++ b/collects/web-server/private/servlet-helpers.ss @@ -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"))