fix interaction of `continuation-mark-set-first' and prompts

including a documentation fix

collects/scribblings/reference/cont-marks.scrbl

@@ -108,14 +108,16 @@ elements to indicate the lack of a value.}
 @defproc[(continuation-mark-set-first 
           [mark-set (or/c continuation-mark-set? #f)]
           [key-v any/c]
+          [none-v any/c #f]
           [prompt-tag continuation-prompt-tag? (default-continuation-prompt-tag)])
          any]{
 Returns the first element of the list that would be returned by
 @racket[(continuation-mark-set->list (or mark-set
 (current-continuation-marks prompt-tag)) key-v prompt-tag)], or
-@racket[#f] if the result would be the empty list. Typically, this
+@racket[none-v] if the result would be the empty list. Typically, this
 result can be computed more quickly using
-@racket[continuation-mark-set-first].}
+@racket[continuation-mark-set-first] than using
+@racket[continuation-mark-set->list].}
 
 @defproc[(call-with-immediate-continuation-mark
           [key-v any/c]

collects/tests/racket/contmark.rktl

@@ -793,6 +793,128 @@
     (test (list s #t)
           list s (for/and ([i (in-range 100)]) (go)))))
 
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Test interaction of prompts and `continuation-mark-set-first'
+
+(let ()
+  (define key 'key)
+  (define value 'value)
+  (define pt (make-continuation-prompt-tag))
+
+  (for-each
+   (lambda (thunk)
+     (test #f (lambda (f) (f)) thunk))
+   
+   (list
+    (lambda ()
+      (with-continuation-mark key value
+        (call-with-continuation-prompt
+         (lambda ()
+           (continuation-mark-set-first
+            #f
+            key)))))
+
+    (lambda ()
+      (with-continuation-mark key value
+        (call-with-continuation-prompt
+         (lambda ()
+           (continuation-mark-set-first
+            (current-continuation-marks)
+            key)))))
+
+    (lambda ()
+      (with-continuation-mark key value
+        (call-with-continuation-prompt
+         (lambda ()
+           (continuation-mark-set-first
+            (current-continuation-marks (default-continuation-prompt-tag))
+            key)))))
+
+    (lambda ()
+      (with-continuation-mark key value
+        (call-with-continuation-prompt
+         (lambda ()
+           (continuation-mark-set-first
+            #f
+            key
+            #f
+            (default-continuation-prompt-tag))))))
+
+    (lambda ()
+      (with-continuation-mark key value
+        (call-with-continuation-prompt
+         (lambda ()
+           (continuation-mark-set-first
+            (current-continuation-marks)
+            key
+            #f
+            (default-continuation-prompt-tag))))))
+
+    (lambda ()
+      (with-continuation-mark key value
+        (call-with-continuation-prompt
+         (lambda ()
+           (continuation-mark-set-first
+            (current-continuation-marks)
+            key
+            #f
+            pt))
+         pt)))
+
+    (lambda ()
+      (with-continuation-mark key value
+        (call-with-continuation-prompt
+         (lambda ()
+           (continuation-mark-set-first
+            (current-continuation-marks (default-continuation-prompt-tag))
+            key
+            #f
+            (default-continuation-prompt-tag))))))
+
+    (lambda ()
+      (with-continuation-mark key value
+        (call-with-continuation-prompt
+         (lambda ()
+           (continuation-mark-set-first
+            (current-continuation-marks pt)
+            key
+            #f
+            (default-continuation-prompt-tag)))
+         pt)))))
+
+  (test 'alt 'alt-fail
+        (with-continuation-mark key value
+          (call-with-continuation-prompt
+           (lambda ()
+             (continuation-mark-set-first
+              #f
+              key
+              'alt)))))
+
+  (test value 'no-block
+        (with-continuation-mark key value
+          (call-with-continuation-prompt
+           (lambda ()
+             (continuation-mark-set-first
+              (current-continuation-marks)
+              key
+              #f
+              (default-continuation-prompt-tag)))
+           pt)))
+
+  (test value 'no-block2
+        (call-with-continuation-prompt
+         (lambda ()
+           (with-continuation-mark key value
+             (call-with-continuation-prompt
+              (lambda ()
+                (continuation-mark-set-first
+                 (current-continuation-marks pt)
+                 key
+                 #f
+                 pt)))))
+         pt)))
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (report-errs)

collects/tests/racket/prompt-tests.rktl

@@ -855,11 +855,16 @@
                        (lambda ()
                          (k (lambda () (continuation-mark-set-first #f 'x #f catch-tag))))
                        catch-tag)
-                 (test 8
+                 (test #f
                        call-with-continuation-prompt
                        (lambda ()
                          (k (lambda () (continuation-mark-set-first #f 'y #f catch-tag))))
                        catch-tag)
+                 (test (if (eq? catch-tag (default-continuation-prompt-tag)) #f 8)
+                       call-with-continuation-prompt
+                       (lambda ()
+                         (k (lambda () (continuation-mark-set-first #f 'y #f catch-tag))))
+                       (default-continuation-prompt-tag))
                  (test (if blocked?
                            '(17)
                            '(17 18))

src/racket/src/fun.c

@@ -8125,6 +8125,8 @@ scheme_extract_one_cc_mark_with_meta(Scheme_Object *mark_set, Scheme_Object *key
     while (chain) {
       if (chain->key == key)
 	return chain->val;
+      else if (SAME_OBJ(chain->key, prompt_tag))
+        break;
       else 
 	chain = chain->next;
     }
@@ -8165,6 +8167,8 @@ scheme_extract_one_cc_mark_with_meta(Scheme_Object *mark_set, Scheme_Object *key
           val = seg[pos].val;
           vpos = seg[pos].pos;
           break;
+        } else if (SAME_OBJ(seg[pos].key, prompt_tag)) {
+          break;
         } else {
           cache = seg[pos].cache;
           if (cache && SCHEME_HASHTP(cache))
@@ -8347,7 +8351,8 @@ extract_one_cc_mark(int argc, Scheme_Object *argv[])
     }
   } 
 
-  r = scheme_extract_one_cc_mark_to_tag(SCHEME_TRUEP(argv[0]) ? argv[0] : NULL, argv[1], prompt_tag);
+  r = scheme_extract_one_cc_mark_to_tag(SCHEME_TRUEP(argv[0]) ? argv[0] : NULL, argv[1], 
+                                        prompt_tag ? SCHEME_PTR_VAL(prompt_tag) : NULL);
   if (!r) {
     if (argc > 2)
       r = argv[2];