diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index f02342679..49127b072 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -48,11 +48,15 @@ ;; Define delimited continuation operators, and implement catch and throw in ;; terms of them. -(define (prompt tag thunk handler) - (@prompt tag (thunk) handler)) -(define (abort tag . args) - (@abort tag args)) +(define (default-prompt-tag) + (fluid-ref %default-prompt-tag)) +(define (make-prompt-tag . stem) + (gensym (if (pair? stem) (car stem) "prompt"))) +(define (call-with-prompt tag thunk handler) + (@prompt tag (thunk) handler)) +(define (abort-to-prompt tag . args) + (@abort tag args)) ;; Define catch and with-throw-handler, using some common helper routines and a @@ -92,7 +96,7 @@ (let ((prev (exception-handler))) (lambda (thrown-k . args) (if (or (eq? thrown-k catch-k) (eqv? catch-k #t)) - (apply abort prompt-tag thrown-k args) + (apply abort-to-prompt prompt-tag thrown-k args) (apply prev thrown-k args))))) (define (custom-throw-handler prompt-tag catch-k pre) @@ -105,7 +109,7 @@ (apply pre thrown-k args)) ;; fall through (if prompt-tag - (apply abort prompt-tag thrown-k args) + (apply abort-to-prompt prompt-tag thrown-k args) (apply prev thrown-k args)))) (apply prev thrown-k args))))) @@ -150,18 +154,19 @@ non-locally, that exit determines the continuation." (scm-error "catch" 'wrong-type-arg "Wrong type argument in position ~a: ~a" (list 1 k) (list k))) - (let ((tag (gensym))) - (prompt tag - (lambda () - (with-fluids - ((%exception-handler - (if (null? pre-unwind-handler) - (default-throw-handler tag k) - (custom-throw-handler tag k - (car pre-unwind-handler))))) - (thunk))) - (lambda (cont k . args) - (apply handler k args)))))) + (let ((tag (make-prompt-tag "catch"))) + (call-with-prompt + tag + (lambda () + (with-fluids + ((%exception-handler + (if (null? pre-unwind-handler) + (default-throw-handler tag k) + (custom-throw-handler tag k + (car pre-unwind-handler))))) + (thunk))) + (lambda (cont k . args) + (apply handler k args)))))) (define! 'with-throw-handler (lambda (k thunk pre-unwind-handler) @@ -1024,13 +1029,14 @@ If there is no handler at all, Guile prints an error and then exits." (define %stacks (make-fluid)) (define (%start-stack tag thunk) - (let ((prompt-tag (gensym))) - (prompt prompt-tag - (lambda () - (with-fluids ((%stacks (acons tag prompt-tag - (or (fluid-ref %stacks) '())))) - (thunk))) - (lambda (k . args) + (let ((prompt-tag (make-prompt-tag "start-stack"))) + (call-with-prompt + prompt-tag + (lambda () + (with-fluids ((%stacks (acons tag prompt-tag + (or (fluid-ref %stacks) '())))) + (thunk))) + (lambda (k . args) (%start-stack tag (lambda () (apply k args))))))) (define-syntax start-stack (syntax-rules () diff --git a/module/ice-9/control.scm b/module/ice-9/control.scm index 482a24e2b..98397a37f 100644 --- a/module/ice-9/control.scm +++ b/module/ice-9/control.scm @@ -19,20 +19,20 @@ ;;; Code: (define-module (ice-9 control) - #:re-export (prompt abort) - #:export (% control)) + #:re-export (call-with-prompt abort-to-prompt + default-prompt-tag make-prompt-tag) + #:export (% abort)) -;; the same as abort. -(define (control tag . args) - (apply abort tag args)) +(define (abort . args) + (apply abort-to-prompt (default-prompt-tag) args)) (define-syntax % (syntax-rules () ((_ expr handler) - (prompt (fluid-ref %default-prompt-tag) - (lambda () expr) - handler)) + (call-with-prompt (default-prompt-tag) + (lambda () expr) + handler)) ((_ tag expr handler) - (prompt tag - (lambda () expr) - handler)))) + (call-with-prompt tag + (lambda () expr) + handler)))) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 43e53f45e..b6953cabe 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -63,7 +63,7 @@ fluid-ref fluid-set! - @prompt prompt @abort abort + @prompt call-with-prompt @abort abort-to-prompt struct? struct-vtable make-struct struct-ref struct-set! @@ -454,7 +454,7 @@ (else #f))) (hashq-set! *primitive-expand-table* - 'prompt + 'call-with-prompt (case-lambda ((src tag thunk handler) ;; Sigh. Until the inliner does its job, manually inline @@ -482,7 +482,7 @@ (make-abort src tag '() tail-args)) (else #f))) (hashq-set! *primitive-expand-table* - 'abort + 'abort-to-prompt (case-lambda ((src tag . args) (make-abort src tag args (make-const #f '()))) diff --git a/test-suite/tests/control.test b/test-suite/tests/control.test index e17b5843c..99379103b 100644 --- a/test-suite/tests/control.test +++ b/test-suite/tests/control.test @@ -23,9 +23,6 @@ #:use-module (test-suite lib)) -(define default-tag (fluid-ref %default-prompt-tag)) - - ;; For these, the compiler should be able to prove that "k" is not referenced, ;; so it avoids reifying the continuation. Since that's a slightly different ;; codepath, we test them both. @@ -34,17 +31,15 @@ (equal? '() (call-with-values (lambda () - (% default-tag - (values) + (% (values) (lambda (k . args) (error "unexpected exit" args)))) list))) (pass-if "no values, abnormal exit" (equal? '() - (% default-tag - (begin - (abort default-tag) + (% (begin + (abort) (error "unexpected exit")) (lambda (k . args) args)))) @@ -53,17 +48,15 @@ (equal? '(foo) (call-with-values (lambda () - (% default-tag - 'foo + (% 'foo (lambda (k . args) (error "unexpected exit" args)))) list))) (pass-if "single value, abnormal exit" (equal? '(foo) - (% default-tag - (begin - (abort default-tag 'foo) + (% (begin + (abort 'foo) (error "unexpected exit")) (lambda (k . args) args)))) @@ -72,17 +65,15 @@ (equal? '(foo bar baz) (call-with-values (lambda () - (% default-tag - (values 'foo 'bar 'baz) + (% (values 'foo 'bar 'baz) (lambda (k . args) (error "unexpected exit" args)))) list))) (pass-if "multiple values, abnormal exit" (equal? '(foo bar baz) - (% default-tag - (begin - (abort default-tag 'foo 'bar 'baz) + (% (begin + (abort 'foo 'bar 'baz) (error "unexpected exit")) (lambda (k . args) args))))) @@ -93,8 +84,7 @@ (equal? '() (call-with-values (lambda () - (% default-tag - (values) + (% (values) (lambda (k . args) (error "unexpected exit" k args)))) list))) @@ -102,9 +92,8 @@ (pass-if "no values, abnormal exit" (equal? '() (cdr - (% default-tag - (begin - (abort default-tag) + (% (begin + (abort) (error "unexpected exit")) (lambda args args))))) @@ -113,8 +102,7 @@ (equal? '(foo) (call-with-values (lambda () - (% default-tag - 'foo + (% 'foo (lambda (k . args) (error "unexpected exit" k args)))) list))) @@ -122,9 +110,8 @@ (pass-if "single value, abnormal exit" (equal? '(foo) (cdr - (% default-tag - (begin - (abort default-tag 'foo) + (% (begin + (abort 'foo) (error "unexpected exit")) (lambda args args))))) @@ -133,8 +120,7 @@ (equal? '(foo bar baz) (call-with-values (lambda () - (% default-tag - (values 'foo 'bar 'baz) + (% (values 'foo 'bar 'baz) (lambda (k . args) (error "unexpected exit" k args)))) list))) @@ -142,9 +128,8 @@ (pass-if "multiple values, abnormal exit" (equal? '(foo bar baz) (cdr - (% default-tag - (begin - (abort default-tag 'foo 'bar 'baz) + (% (begin + (abort 'foo 'bar 'baz) (error "unexpected exit")) (lambda args args)))))) @@ -152,37 +137,32 @@ ;; The variants check different cases in the compiler. (with-test-prefix "restarting partial continuations" (pass-if "in side-effect position" - (let ((k (% default-tag - (begin (abort default-tag) 'foo) + (let ((k (% (begin (abort) 'foo) (lambda (k) k)))) (eq? (k) 'foo))) (pass-if "passing values to side-effect abort" - (let ((k (% default-tag - (begin (abort default-tag) 'foo) + (let ((k (% (begin (abort) 'foo) (lambda (k) k)))) (eq? (k 'qux 'baz 'hello) 'foo))) (pass-if "called for one value" - (let ((k (% default-tag - (+ (abort default-tag) 3) + (let ((k (% (+ (abort) 3) (lambda (k) k)))) (eqv? (k 39) 42))) (pass-if "called for multiple values" - (let ((k (% default-tag - (let-values (((a b . c) (abort default-tag))) + (let ((k (% (let-values (((a b . c) (abort))) (list a b c)) (lambda (k) k)))) (equal? (k 1 2 3 4) '(1 2 (3 4))))) (pass-if "in tail position" - (let ((k (% default-tag - (abort default-tag) + (let ((k (% (abort) (lambda (k) k)))) (eq? (k 'xyzzy) 'xyzzy)))) @@ -192,20 +172,17 @@ (with-test-prefix "suspend/resume with fluids" (pass-if "normal" - (zero? (% default-tag - (fluid-ref fl) + (zero? (% (fluid-ref fl) error))) (pass-if "with-fluids normal" - (equal? (% default-tag - (with-fluids ((fl (1+ (fluid-ref fl)))) + (equal? (% (with-fluids ((fl (1+ (fluid-ref fl)))) (fluid-ref fl)) error) 1)) (pass-if "normal (post)" (zero? (fluid-ref fl))) (pass-if "with-fluids and fluid-set!" - (equal? (% default-tag - (with-fluids ((fl (1+ (fluid-ref fl)))) + (equal? (% (with-fluids ((fl (1+ (fluid-ref fl)))) (fluid-set! fl (1+ (fluid-ref fl))) (fluid-ref fl)) error) @@ -223,9 +200,8 @@ (fluid-ref fl)) 0)) - (let ((k (% default-tag - (with-fluids ((fl (1+ (fluid-ref fl)))) - (abort default-tag) + (let ((k (% (with-fluids ((fl (1+ (fluid-ref fl)))) + (abort) (fluid-ref fl)) (lambda (k) k)))) (pass-if "pre" @@ -240,8 +216,8 @@ (let ((k (% 'a (% 'b (begin - (abort 'a) - (abort 'b #t)) + (abort-to-prompt 'a) + (abort-to-prompt 'b #t)) (lambda (k x) x)) (lambda (k) k)))) (k))))