summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2010-03-09 22:24:25 +0100
committerAndy Wingo <wingo@pobox.com>2010-03-09 22:24:25 +0100
commit8fc43b12c71789030d9058fea8b6eff5490dec27 (patch)
tree8be9a06a17cf3107875dec709993d0c8df22f5ac
parenta6cd35551023d72703cf05a98e42e9dd6a75d48f (diff)
downloadguile-8fc43b12c71789030d9058fea8b6eff5490dec27.tar.gz
prompt, abort -> call-with-prompt, abort-to-prompt
* module/ice-9/boot-9.scm (default-prompt-tag, make-prompt-tag): New functions. (call-with-prompt, abort-to-prompt): Rename from `prompt' and `abort', respectively. These names are more clear, and allow `prompt' and `abort' to have more convenient, less general bindings. (default-throw-handler, custom-throw-handler, catch, %start-stack): Adapt callers. * module/ice-9/control.scm: Adapt re-export list. (control): Remove binding, until we're sure that it is Sitaram's control. (abort): New binding, aborts to the nearest prompt with the default tag. (%): Use call-with-prompt. * module/language/tree-il/primitives.scm (*primitive-expand-table*): (*interesting-primitive-names*): Adapt for prompt/abort changes. * test-suite/tests/control.test: Take advantage of the defaults for % and abort.
-rw-r--r--module/ice-9/boot-9.scm54
-rw-r--r--module/ice-9/control.scm22
-rw-r--r--module/language/tree-il/primitives.scm6
-rw-r--r--test-suite/tests/control.test84
4 files changed, 74 insertions, 92 deletions
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,13 +48,17 @@
;; Define delimited continuation operators, and implement catch and throw in
;; terms of them.
-(define (prompt tag thunk handler)
+(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 tag . args)
+(define (abort-to-prompt tag . args)
(@abort tag args))
-
;; Define catch and with-throw-handler, using some common helper routines and a
;; shared fluid. Hide the helpers in a lexical contour.
@@ -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))))