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,8 +154,9 @@ 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
+      (let ((tag (make-prompt-tag "catch")))
+        (call-with-prompt
+         tag
          (lambda ()
            (with-fluids
                ((%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 (%start-stack tag thunk)
-  (let ((prompt-tag (gensym)))
-    (prompt prompt-tag
+  (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) '()))))

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)
+     (call-with-prompt (default-prompt-tag)
                        (lambda () expr)
                        handler))
     ((_ tag expr handler)
-     (prompt tag
+     (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 '())))

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