From f51c3533e6ca0ecae1d8d9dd40fa7d9a87671508 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Marc=20Nieper-Wi=C3=9Fkirchen?= <marc@nieper-wisskirchen.de>
Date: Sun, 9 Feb 2025 14:55:00 +0100
Subject: [PATCH] Handle the immediate table of marks in `$guard` and
 `$reset-protect` (#911)

---
 mats/4.ms                        | 130 ++++++++++++++++++-------------
 release_notes/release_notes.stex |   7 ++
 s/7.ss                           |  31 ++++----
 s/exceptions.ss                  |  27 ++++---
 4 files changed, 116 insertions(+), 79 deletions(-)

diff --git a/mats/4.ms b/mats/4.ms
index 866639195..c569baea5 100644
--- a/mats/4.ms
+++ b/mats/4.ms
@@ -1,12 +1,12 @@
 ;;; 4.ms
 ;;; Copyright 1984-2017 Cisco Systems, Inc.
-;;; 
+;;;
 ;;; Licensed under the Apache License, Version 2.0 (the "License");
 ;;; you may not use this file except in compliance with the License.
 ;;; You may obtain a copy of the License at
-;;; 
+;;;
 ;;; http://www.apache.org/licenses/LICENSE-2.0
-;;; 
+;;;
 ;;; Unless required by applicable law or agreed to in writing, software
 ;;; distributed under the License is distributed on an "AS IS" BASIS,
 ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
@@ -293,37 +293,37 @@
       (if (eq? x 'a) (set! x 'c))
       (eq? x 'b))
 
-   (equivalent-expansion? 
+   (equivalent-expansion?
      (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
        (expand/optimize '(if (not (not (f x))) e1 e2)))
      '(if (f x) e1 e2))
 
-   (equivalent-expansion? 
+   (equivalent-expansion?
      (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
        (expand/optimize '(if (begin (set! x y) (if (begin (set! z y) (zero? h)) #f #t)) e1 e2)))
      '(begin (set! x y) (if (begin (set! z y) (#2%zero? h)) e2 e1)))
 
-  (equivalent-expansion? 
+  (equivalent-expansion?
      (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
        (expand/optimize '(if (begin (set! x y) (if (begin (set! z y) (zero? h)) #f #f)) e1 e2)))
      '(begin (set! x y) (set! z y) (#2%zero? h) e2))
 
-  (equivalent-expansion? 
+  (equivalent-expansion?
      (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
        (expand/optimize '(if (begin (set! x y) (if (begin (set! z y) (zero? h)) #t #t)) e1 e2)))
      '(begin (set! x y) (set! z y) (#2%zero? h) e1))
-  
-  (equivalent-expansion? 
+
+  (equivalent-expansion?
      (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
        (expand/optimize '(if (begin (set! x y) (if (begin (set! z y) (zero? h)) #t #f)) e1 e2)))
      '(if (begin (set! x y) (set! z y) (#2%zero? h)) e1 e2))
 
-  (equivalent-expansion? 
+  (equivalent-expansion?
      (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
        (expand/optimize '(if (begin (set! x y) (if (begin (set! z y) (zero? h)) (begin (set! l z) #t) (begin (set! l y) #f))) e1 e2)))
      '(begin (set! x y) (if (begin (set! z y) (#2%zero? h)) (begin (set! l z) e1) (begin (set! l y) e2))))
 
-  (equivalent-expansion? 
+  (equivalent-expansion?
      (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
        (expand/optimize '(if (begin (set! x y) (if (begin (set! z y) (zero? h)) (begin (set! l z) #t) (begin (set! l y) #t))) e1 e2)))
      '(begin (set! x y) (if (begin (set! z y) (#2%zero? h)) (set! l z) (set! l y)) e1))
@@ -333,7 +333,7 @@
        (expand/optimize '(if (begin (set! x y) (if (begin (set! z y) (zero? h)) (begin (set! l z) #f) (begin (set! l y) #f))) e1 e2)))
      '(begin (set! x y) (if (begin (set! z y) (#2%zero? h)) (set! l z) (set! l y)) e2))
 
-  (equivalent-expansion? 
+  (equivalent-expansion?
      (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
        (expand/optimize '(if (begin (set! x y) (if (begin (set! z y) (zero? h)) (begin (set! l z) #f) (begin (set! l y) #t))) e1 e2)))
      '(begin (set! x y) (if (begin (set! z y) (#2%zero? h)) (begin (set! l z) e2) (begin (set! l y) e1))))
@@ -1205,7 +1205,7 @@
               (set! next 0)))
         (let ([m next])
           (unless (= m n)
-            (set! next (fx+ next 1)) 
+            (set! next (fx+ next 1))
             (let ([p (list-ref orig-ls m)])
               (unless (eqv? (cdr p) m)
                 (errorf #f "unexpected cdr value (~s instead of ~s)" (cdr p) m))
@@ -1257,48 +1257,48 @@
   ;; avoid creating each list and doing the actual map
   (equivalent-expansion?
     (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
-      (expand/optimize 
-        '(map (lambda (x y z) (apply + x y z)) 
+      (expand/optimize
+        '(map (lambda (x y z) (apply + x y z))
            (list 1 2 3)
            (list 4 5 6)
            (list '(7) '(8) '(9)))))
     '(#2%list 12 15 18))
   (equivalent-expansion?
     (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
-      (expand/optimize 
-        '(map (lambda (x y z) (apply + x y z)) 
+      (expand/optimize
+        '(map (lambda (x y z) (apply + x y z))
            (list 1 2 3)
            (list 4 5 6)
            (list '(7) '(8) '(9)))))
     '(#3%list 12 15 18))
   (equivalent-expansion?
     (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
-      (expand/optimize 
-        '(map (lambda (x y z) (apply + x y z)) 
+      (expand/optimize
+        '(map (lambda (x y z) (apply + x y z))
            '(1 2 3)
            (list 4 5 6)
            (list '(7) '(8) '(9)))))
     '(#2%list 12 15 18))
   (equivalent-expansion?
     (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
-      (expand/optimize 
-        '(map (lambda (x y z) (apply + x y z)) 
+      (expand/optimize
+        '(map (lambda (x y z) (apply + x y z))
            '(1 2 3)
            (list 4 5 6)
            (list '(7) '(8) '(9)))))
     '(#3%list 12 15 18))
   (equivalent-expansion?
     (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
-      (expand/optimize 
-        '(map (lambda (x y z) (apply + x y z)) 
+      (expand/optimize
+        '(map (lambda (x y z) (apply + x y z))
            '(1 2 3)
            '(4 5 6)
            '((7) (8) (9)))))
     '(#2%list 12 15 18))
   (equivalent-expansion?
     (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
-      (expand/optimize 
-        '(map (lambda (x y z) (apply + x y z)) 
+      (expand/optimize
+        '(map (lambda (x y z) (apply + x y z))
            '(1 2 3)
            '(4 5 6)
            '((7) (8) (9)))))
@@ -1430,7 +1430,7 @@
   (equal?
     (fold-left cons '(q) '(a b c))
     '((((q) . a) . b) . c))
-  (eqv? 
+  (eqv?
     (fold-left + 0 '(1 2 3) '(4 5 6))
     21)
   (procedure? (lambda (x) (fold-left x)))
@@ -2125,48 +2125,48 @@
   ;; avoid creating each list and doing the actual for-each
   (equivalent-expansion?
     (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
-      (expand/optimize 
-        '(for-each (lambda (x y z) (display (apply + x y z))) 
+      (expand/optimize
+        '(for-each (lambda (x y z) (display (apply + x y z)))
            (list 1 2 3)
            (list 4 5 6)
            (list '(7) '(8) '(9)))))
     '(begin (#2%display 12) (#2%display 15) (#2%display 18)))
   (equivalent-expansion?
     (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
-      (expand/optimize 
-        '(for-each (lambda (x y z) (display (apply + x y z))) 
+      (expand/optimize
+        '(for-each (lambda (x y z) (display (apply + x y z)))
            (list 1 2 3)
            (list 4 5 6)
            (list '(7) '(8) '(9)))))
     '(begin (#3%display 12) (#3%display 15) (#3%display 18)))
   (equivalent-expansion?
     (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
-      (expand/optimize 
-        '(for-each (lambda (x y z) (display (apply + x y z))) 
+      (expand/optimize
+        '(for-each (lambda (x y z) (display (apply + x y z)))
            '(1 2 3)
            (list 4 5 6)
            (list '(7) '(8) '(9)))))
     '(begin (#2%display 12) (#2%display 15) (#2%display 18)))
   (equivalent-expansion?
     (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
-      (expand/optimize 
-        '(for-each (lambda (x y z) (display (apply + x y z))) 
+      (expand/optimize
+        '(for-each (lambda (x y z) (display (apply + x y z)))
            '(1 2 3)
            (list 4 5 6)
            (list '(7) '(8) '(9)))))
     '(begin (#3%display 12) (#3%display 15) (#3%display 18)))
   (equivalent-expansion?
     (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
-      (expand/optimize 
-        '(for-each (lambda (x y z) (display (apply + x y z))) 
+      (expand/optimize
+        '(for-each (lambda (x y z) (display (apply + x y z)))
            '(1 2 3)
            '(4 5 6)
            '((7) (8) (9)))))
     '(begin (#2%display 12) (#2%display 15) (#2%display 18)))
   (equivalent-expansion?
     (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
-      (expand/optimize 
-        '(for-each (lambda (x y z) (display (apply + x y z))) 
+      (expand/optimize
+        '(for-each (lambda (x y z) (display (apply + x y z)))
            '(1 2 3)
            '(4 5 6)
            '((7) (8) (9)))))
@@ -2684,19 +2684,19 @@
             (l #f))
         'hi)
    (((call/cc call/cc) (lambda (x) x)) #t)
-   (let () 
+   (let ()
      (define f
        (lambda (n)
          (let f ((n n))
-           (or (fx= n 0) 
+           (or (fx= n 0)
                (and (call/cc (lambda (k) k))
                     (f (fx- n 1)))))))
      (f 100000))
-   (let () 
+   (let ()
      (define f
        (lambda (n)
          (let f ((n n))
-           (or (fx= n 0) 
+           (or (fx= n 0)
                (and (call/cc (lambda (k) (k k)))
                     (f (fx- n 1)))))))
      (f 100000))
@@ -2790,7 +2790,7 @@
     (and (eq? (leaf-eq? '(a (b (c))) '((a) b c)) #t)
          (eq? (leaf-eq? '(a (b (c))) '((a) b c d)) #f)))
  )
- 
+
 (mat dynamic-wind
    (let ([x 3])
       (and (eqv? x 3)
@@ -3075,11 +3075,11 @@
         (case-lambda
           [() me]
           [(x) #t]))))
-   (let () 
+   (let ()
      (define f
        (lambda (n)
          (let f ((n n))
-           (or (fx= n 0) 
+           (or (fx= n 0)
                (and (call/cc (lambda (k) (k k)))
                     (f (fx- n 1)))))))
      (f 100000))
@@ -3453,7 +3453,7 @@
   (error? (call-with-yep (lambda () (call-with-yeah* (lambda () ((returns-not-a-procedure)))))))
   (error? (call-with-yep (lambda () (list (call-with-yeah* (lambda () ((returns-not-a-procedure))))))))
   (error? (call-with-yep (lambda () (act-like-list (call-with-yeah* (lambda () ((returns-not-a-procedure))))))))
-  
+
   (equal? '() (if (call-with-yep list)
                   (#%$current-attachments)
                   #f))
@@ -3736,7 +3736,7 @@
        [(marks keys) ($mark-iter->lists (continuation-marks->iterator marks (list->vector keys)))]
        [(marks keys no) ($mark-iter->lists (continuation-marks->iterator marks (list->vector keys) no))]))
     #t)
-  
+
   (equal? '((xv1 yv)) (with-continuation-mark
                           'x 'xv0
                         (with-continuation-mark
@@ -3828,6 +3828,32 @@
                  (with-continuation-mark
                      'other 'no
                    (loop (sub1 depth)))))))))
+
+  (with-continuation-mark
+      'key #t
+    (guard
+        (c [#t (call-with-immediate-continuation-mark 'key values)])
+      (raise #f)))
+
+  (with-continuation-mark
+      'key #t
+    (guard
+        (c [#t (call-with-immediate-continuation-mark 'key values)]
+           [else #f])
+      (raise #f)))
+
+  (equal? 'inner
+    (call/cc
+      (lambda (k)
+        (with-continuation-mark 'key 'outer
+          (with-exception-handler
+              (lambda (c)
+                (k (continuation-marks-first (current-continuation-marks) 'key)))
+            (lambda ()
+              (guard (c [#f #f])
+                (with-continuation-mark 'key 'inner
+                  (raise #f)))))))))
+
   )
 
 (mat call-in-continuation
@@ -3959,7 +3985,7 @@
             (lambda (k)
               (#%$call-in-continuation
                k
-               (lambda () 
+               (lambda ()
                  (#%$call-consuming-continuation-attachment
                   'also-unknown
                   (lambda (v)
@@ -4866,7 +4892,7 @@
    (begin
      (define ephemeron-key car)
      (define ephemeron-value cdr)
-     
+
      (define gdn (make-guardian))
      #t)
 
@@ -4891,7 +4917,7 @@
                                es))
                    (weak-cons k1 (weak-cons k2 wps))
                    (cons k1 saved)))])))
-     
+
      (collect (collect-maximum-generation))
 
      ;; All now waiting to be reported by the guardian
@@ -4934,7 +4960,7 @@
    ;; behavior
    (let ()
      (define (wrapper v) (list 1 2 3 4 5 v))
-     
+
      ;; Create a chain of ephemerons where we have all
      ;; the the ephemerons immediately in a list,
      ;; but we discover the keys one at a time
@@ -5008,7 +5034,7 @@
 
    ;; ----------------------------------------
    ;; Check interaction of mutation and generations
-   
+
    ;; This check disables interrupts so that a garbage collection
    ;; happens only for the explicit `collect` request.
    (with-interrupts-disabled
diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex
index c47bb7d09..66682284f 100644
--- a/release_notes/release_notes.stex
+++ b/release_notes/release_notes.stex
@@ -2812,6 +2812,13 @@ in fasl files does not generally make sense.
 %-----------------------------------------------------------------------------
 \section{Bug Fixes}\label{section:bugfixes}
 
+\subsection{Restore immediate table of marks where \scheme{call-in-continuation} is used (10.2.0)}
+
+Tests have been added that test that the (immediate) table of marks is set
+correctly when expressions are evaluated in the various continuations
+specified by the \scheme{guard} form.  Necessary fixes to uses of
+\scheme{call-in-continuation} have been applied in the implementation.
+
 \subsection{Fix \scheme{fx-/wraparound} with \scheme{0} first argument (10.2.0)}
 
 When \scheme{fx-/wraparound} was called with \scheme{0} as its first
diff --git a/s/7.ss b/s/7.ss
index 0d535a33d..6abe8d9be 100644
--- a/s/7.ss
+++ b/s/7.ss
@@ -621,21 +621,22 @@
   (lambda (body out)
     (call/cc
       (lambda (k)
-        (parameterize ([reset-handler
-                         (lambda ()
-                           (call-in-continuation k
-                             (lambda ()
-                               (out)
-                               ((reset-handler)))))])
-          (with-exception-handler
-              (lambda (c)
-               ; would prefer not to burn bridges even for serious condition
-               ; if the exception is continuable, but we have no way to know
-               ; short of grubbing through the continuation
-                (if (serious-condition? c)
-                    (call-in-continuation k (lambda () (out) (raise c)))
-                    (raise-continuable c)))
-            body))))))
+        (let ([marks (current-continuation-marks)])
+          (parameterize ([reset-handler
+                           (lambda ()
+                             (call-in-continuation k
+                               (lambda ()
+                                 (out)
+                                 ((reset-handler)))))])
+            (with-exception-handler
+                (lambda (c)
+                 ; would prefer not to burn bridges even for serious condition
+                 ; if the exception is continuable, but we have no way to know
+                 ; short of grubbing through the continuation
+                  (if (serious-condition? c)
+                      (call-in-continuation k marks (lambda () (out) (raise c)))
+                      (raise-continuable c)))
+              body)))))))
 
 (define exit-handler)
 (define reset-handler)
diff --git a/s/exceptions.ss b/s/exceptions.ss
index f15b0f4ae..13b616787 100644
--- a/s/exceptions.ss
+++ b/s/exceptions.ss
@@ -265,25 +265,28 @@ TODO:
       (if supply-else?
           (call/cc
             (lambda (kouter)
-              (let ([original-handler-stack ($current-handler-stack)])
+              (let ([original-handler-stack ($current-handler-stack)]
+                    [kouter-marks (current-continuation-marks)])
                 (with-exception-handler
                     (lambda (arg)
                       (call/cc
                         (lambda (kinner)
-                          (call-in-continuation kouter
-                            (lambda ()
-                              (guards arg
-                                (lambda ()
-                                  (call-in-continuation kinner
-                                    (lambda ()
-                                      (parameterize ([$current-handler-stack original-handler-stack])
-                                        (raise-continuable arg)))))))))))
+                          (let ([kinner-marks (current-continuation-marks)])
+                            (call-in-continuation kouter kouter-marks
+                              (lambda ()
+                                (guards arg
+                                  (lambda ()
+                                    (call-in-continuation kinner kinner-marks
+                                      (lambda ()
+                                        (parameterize ([$current-handler-stack original-handler-stack])
+                                          (raise-continuable arg))))))))))))
                   body))))
           (call/cc
             (lambda (k)
-              (with-exception-handler
-                  (lambda (arg) (call-in-continuation k (lambda () (guards arg))))
-                body))))))
+              (let ([marks (current-continuation-marks)])
+                (with-exception-handler
+                    (lambda (arg) (call-in-continuation k marks (lambda () (guards arg))))
+                  body)))))))
 )
 
 (define-syntax guard