mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-19 03:00:25 +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

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

@ -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 ()