summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
Diffstat (limited to 'module')
-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
3 files changed, 44 insertions, 38 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 '())))