mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 20:00:19 +02:00
Code Activity

prompt, abort -> call-with-prompt, abort-to-prompt

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2010-03-09 22:24:25 +01:00
parent a6cd355510
commit 8fc43b12c7
4 changed files with 75 additions and 93 deletions
Download patch file Download diff file Expand all files Collapse all files

26
module/ice-9/boot-9.scm
View file

@ -48,11 +48,15 @@
;; Define delimited continuation operators, and implement catch and throw in ;; Define delimited continuation operators, and implement catch and throw in
;; terms of them. ;; terms of them.
(define (prompt tag thunk handler) (define (default-prompt-tag)
(@prompt tag (thunk) handler)) (fluid-ref %default-prompt-tag))
(define (abort tag . args) (define (make-prompt-tag . stem)
(@abort tag args)) (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 ;; Define catch and with-throw-handler, using some common helper routines and a
@ -92,7 +96,7 @@
(let ((prev (exception-handler))) (let ((prev (exception-handler)))
(lambda (thrown-k . args) (lambda (thrown-k . args)
(if (or (eq? thrown-k catch-k) (eqv? catch-k #t)) (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))))) (apply prev thrown-k args)))))
(define (custom-throw-handler prompt-tag catch-k pre) (define (custom-throw-handler prompt-tag catch-k pre)
@ -105,7 +109,7 @@
(apply pre thrown-k args)) (apply pre thrown-k args))
;; fall through ;; fall through
(if prompt-tag (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))))
(apply prev thrown-k args))))) (apply prev thrown-k args)))))
@ -150,8 +154,9 @@ non-locally, that exit determines the continuation."
(scm-error "catch" 'wrong-type-arg (scm-error "catch" 'wrong-type-arg
"Wrong type argument in position ~a: ~a" "Wrong type argument in position ~a: ~a"
(list 1 k) (list k))) (list 1 k) (list k)))
(let ((tag (gensym))) (let ((tag (make-prompt-tag "catch")))
(prompt tag (call-with-prompt
tag
(lambda () (lambda ()
(with-fluids (with-fluids
((%exception-handler ((%exception-handler
@ -1024,8 +1029,9 @@ If there is no handler at all, Guile prints an error and then exits."
(define %stacks (make-fluid)) (define %stacks (make-fluid))
(define (%start-stack tag thunk) (define (%start-stack tag thunk)
(let ((prompt-tag (gensym))) (let ((prompt-tag (make-prompt-tag "start-stack")))
(prompt prompt-tag (call-with-prompt
prompt-tag
(lambda () (lambda ()
(with-fluids ((%stacks (acons tag prompt-tag (with-fluids ((%stacks (acons tag prompt-tag
(or (fluid-ref %stacks) '())))) (or (fluid-ref %stacks) '()))))

14
module/ice-9/control.scm
View file

@ -19,20 +19,20 @@
;;; Code: ;;; Code:
(define-module (ice-9 control) (define-module (ice-9 control)
#:re-export (prompt abort) #:re-export (call-with-prompt abort-to-prompt
#:export (% control)) default-prompt-tag make-prompt-tag)
#:export (% abort))
;; the same as abort. (define (abort . args)
(define (control tag . args) (apply abort-to-prompt (default-prompt-tag) args))
(apply abort tag args))
(define-syntax % (define-syntax %
(syntax-rules () (syntax-rules ()
((_ expr handler) ((_ expr handler)
(prompt (fluid-ref %default-prompt-tag) (call-with-prompt (default-prompt-tag)
(lambda () expr) (lambda () expr)
handler)) handler))
((_ tag expr handler) ((_ tag expr handler)
(prompt tag (call-with-prompt tag
(lambda () expr) (lambda () expr)
handler)))) handler))))

6
module/language/tree-il/primitives.scm
View file

@ -63,7 +63,7 @@
fluid-ref fluid-set! 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! struct? struct-vtable make-struct struct-ref struct-set!
@ -454,7 +454,7 @@
(else #f))) (else #f)))
(hashq-set! *primitive-expand-table* (hashq-set! *primitive-expand-table*
'prompt 'call-with-prompt
(case-lambda (case-lambda
((src tag thunk handler) ((src tag thunk handler)
;; Sigh. Until the inliner does its job, manually inline ;; Sigh. Until the inliner does its job, manually inline
@ -482,7 +482,7 @@
(make-abort src tag '() tail-args)) (make-abort src tag '() tail-args))
(else #f))) (else #f)))
(hashq-set! *primitive-expand-table* (hashq-set! *primitive-expand-table*
'abort 'abort-to-prompt
(case-lambda (case-lambda
((src tag . args) ((src tag . args)
(make-abort src tag args (make-const #f '()))) (make-abort src tag args (make-const #f '())))

84
test-suite/tests/control.test
View file

@ -23,9 +23,6 @@
#:use-module (test-suite lib)) #: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, ;; 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 ;; so it avoids reifying the continuation. Since that's a slightly different
;; codepath, we test them both. ;; codepath, we test them both.
@ -34,17 +31,15 @@
(equal? '() (equal? '()
(call-with-values (call-with-values
(lambda () (lambda ()
(% default-tag (% (values)
(values)
(lambda (k . args) (lambda (k . args)
(error "unexpected exit" args)))) (error "unexpected exit" args))))
list))) list)))
(pass-if "no values, abnormal exit" (pass-if "no values, abnormal exit"
(equal? '() (equal? '()
(% default-tag (% (begin
(begin (abort)
(abort default-tag)
(error "unexpected exit")) (error "unexpected exit"))
(lambda (k . args) (lambda (k . args)
args)))) args))))
@ -53,17 +48,15 @@
(equal? '(foo) (equal? '(foo)
(call-with-values (call-with-values
(lambda () (lambda ()
(% default-tag (% 'foo
'foo
(lambda (k . args) (lambda (k . args)
(error "unexpected exit" args)))) (error "unexpected exit" args))))
list))) list)))
(pass-if "single value, abnormal exit" (pass-if "single value, abnormal exit"
(equal? '(foo) (equal? '(foo)
(% default-tag (% (begin
(begin (abort 'foo)
(abort default-tag 'foo)
(error "unexpected exit")) (error "unexpected exit"))
(lambda (k . args) (lambda (k . args)
args)))) args))))
@ -72,17 +65,15 @@
(equal? '(foo bar baz) (equal? '(foo bar baz)
(call-with-values (call-with-values
(lambda () (lambda ()
(% default-tag (% (values 'foo 'bar 'baz)
(values 'foo 'bar 'baz)
(lambda (k . args) (lambda (k . args)
(error "unexpected exit" args)))) (error "unexpected exit" args))))
list))) list)))
(pass-if "multiple values, abnormal exit" (pass-if "multiple values, abnormal exit"
(equal? '(foo bar baz) (equal? '(foo bar baz)
(% default-tag (% (begin
(begin (abort 'foo 'bar 'baz)
(abort default-tag 'foo 'bar 'baz)
(error "unexpected exit")) (error "unexpected exit"))
(lambda (k . args) (lambda (k . args)
args))))) args)))))
@ -93,8 +84,7 @@
(equal? '() (equal? '()
(call-with-values (call-with-values
(lambda () (lambda ()
(% default-tag (% (values)
(values)
(lambda (k . args) (lambda (k . args)
(error "unexpected exit" k args)))) (error "unexpected exit" k args))))
list))) list)))
@ -102,9 +92,8 @@
(pass-if "no values, abnormal exit" (pass-if "no values, abnormal exit"
(equal? '() (equal? '()
(cdr (cdr
(% default-tag (% (begin
(begin (abort)
(abort default-tag)
(error "unexpected exit")) (error "unexpected exit"))
(lambda args (lambda args
args))))) args)))))
@ -113,8 +102,7 @@
(equal? '(foo) (equal? '(foo)
(call-with-values (call-with-values
(lambda () (lambda ()
(% default-tag (% 'foo
'foo
(lambda (k . args) (lambda (k . args)
(error "unexpected exit" k args)))) (error "unexpected exit" k args))))
list))) list)))
@ -122,9 +110,8 @@
(pass-if "single value, abnormal exit" (pass-if "single value, abnormal exit"
(equal? '(foo) (equal? '(foo)
(cdr (cdr
(% default-tag (% (begin
(begin (abort 'foo)
(abort default-tag 'foo)
(error "unexpected exit")) (error "unexpected exit"))
(lambda args (lambda args
args))))) args)))))
@ -133,8 +120,7 @@
(equal? '(foo bar baz) (equal? '(foo bar baz)
(call-with-values (call-with-values
(lambda () (lambda ()
(% default-tag (% (values 'foo 'bar 'baz)
(values 'foo 'bar 'baz)
(lambda (k . args) (lambda (k . args)
(error "unexpected exit" k args)))) (error "unexpected exit" k args))))
list))) list)))
@ -142,9 +128,8 @@
(pass-if "multiple values, abnormal exit" (pass-if "multiple values, abnormal exit"
(equal? '(foo bar baz) (equal? '(foo bar baz)
(cdr (cdr
(% default-tag (% (begin
(begin (abort 'foo 'bar 'baz)
(abort default-tag 'foo 'bar 'baz)
(error "unexpected exit")) (error "unexpected exit"))
(lambda args (lambda args
args)))))) args))))))
@ -152,37 +137,32 @@
;; The variants check different cases in the compiler. ;; The variants check different cases in the compiler.
(with-test-prefix "restarting partial continuations" (with-test-prefix "restarting partial continuations"
(pass-if "in side-effect position" (pass-if "in side-effect position"
(let ((k (% default-tag (let ((k (% (begin (abort) 'foo)
(begin (abort default-tag) 'foo)
(lambda (k) k)))) (lambda (k) k))))
(eq? (k) (eq? (k)
'foo))) 'foo)))
(pass-if "passing values to side-effect abort" (pass-if "passing values to side-effect abort"
(let ((k (% default-tag (let ((k (% (begin (abort) 'foo)
(begin (abort default-tag) 'foo)
(lambda (k) k)))) (lambda (k) k))))
(eq? (k 'qux 'baz 'hello) (eq? (k 'qux 'baz 'hello)
'foo))) 'foo)))
(pass-if "called for one value" (pass-if "called for one value"
(let ((k (% default-tag (let ((k (% (+ (abort) 3)
(+ (abort default-tag) 3)
(lambda (k) k)))) (lambda (k) k))))
(eqv? (k 39) (eqv? (k 39)
42))) 42)))
(pass-if "called for multiple values" (pass-if "called for multiple values"
(let ((k (% default-tag (let ((k (% (let-values (((a b . c) (abort)))
(let-values (((a b . c) (abort default-tag)))
(list a b c)) (list a b c))
(lambda (k) k)))) (lambda (k) k))))
(equal? (k 1 2 3 4) (equal? (k 1 2 3 4)
'(1 2 (3 4))))) '(1 2 (3 4)))))
(pass-if "in tail position" (pass-if "in tail position"
(let ((k (% default-tag (let ((k (% (abort)
(abort default-tag)
(lambda (k) k)))) (lambda (k) k))))
(eq? (k 'xyzzy) (eq? (k 'xyzzy)
'xyzzy)))) 'xyzzy))))
@ -192,20 +172,17 @@
(with-test-prefix "suspend/resume with fluids" (with-test-prefix "suspend/resume with fluids"
(pass-if "normal" (pass-if "normal"
(zero? (% default-tag (zero? (% (fluid-ref fl)
(fluid-ref fl)
error))) error)))
(pass-if "with-fluids normal" (pass-if "with-fluids normal"
(equal? (% default-tag (equal? (% (with-fluids ((fl (1+ (fluid-ref fl))))
(with-fluids ((fl (1+ (fluid-ref fl))))
(fluid-ref fl)) (fluid-ref fl))
error) error)
1)) 1))
(pass-if "normal (post)" (pass-if "normal (post)"
(zero? (fluid-ref fl))) (zero? (fluid-ref fl)))
(pass-if "with-fluids and fluid-set!" (pass-if "with-fluids and fluid-set!"
(equal? (% default-tag (equal? (% (with-fluids ((fl (1+ (fluid-ref fl))))
(with-fluids ((fl (1+ (fluid-ref fl))))
(fluid-set! fl (1+ (fluid-ref fl))) (fluid-set! fl (1+ (fluid-ref fl)))
(fluid-ref fl)) (fluid-ref fl))
error) error)
@ -223,9 +200,8 @@
(fluid-ref fl)) (fluid-ref fl))
0)) 0))
(let ((k (% default-tag (let ((k (% (with-fluids ((fl (1+ (fluid-ref fl))))
(with-fluids ((fl (1+ (fluid-ref fl)))) (abort)
(abort default-tag)
(fluid-ref fl)) (fluid-ref fl))
(lambda (k) k)))) (lambda (k) k))))
(pass-if "pre" (pass-if "pre"
@ -240,8 +216,8 @@
(let ((k (% 'a (let ((k (% 'a
(% 'b (% 'b
(begin (begin
(abort 'a) (abort-to-prompt 'a)
(abort 'b #t)) (abort-to-prompt 'b #t))
(lambda (k x) x)) (lambda (k x) x))
(lambda (k) k)))) (lambda (k) k))))
(k)))) (k))))