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.

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

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

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