Ticket #1336: 0001-Save-current-values-when-leaving-parameterizes.patch

NEWS

@@ -9 +9 @@
 
 - Core libraries:
   - Keywords are more consistently read/written, like symbols (#1332).
+  - SRFI-39: When jumping out of a parameterized dynamic extent,
+    "parameterize" now remember the actual values, so when jumping back
+    in, they are restored (fixes #1336, thanks to Joo ChurlSoo).
+    This was a regression caused by the fix for #1227.
 
 4.11.1
 

chicken-syntax.scm

@@ -309 +309 @@
              (##core#set! ,convert? #f) ) )
            (##core#lambda () ,@body)
            (##core#lambda ()
-            ;; Restore parameters to their original, saved values
-            ,@(map (lambda (p s) `(,p ,s #f #t))
-                   param-aliases saveds) )) ) ) ) ) )))
+             ;; Swap parameters with their original, saved values.
+             ,@(map (lambda (p s t)
+                      `(##core#let ((,t (,p)))
+                         ;; Restore to old value.
+                         (,p ,s #f #t)
+                         ;; Save current value for later re-invocations.
+                         (##core#set! ,s ,t)))
+                    param-aliases saveds temps) )) ) ) ) ) )))
 
 (##sys#extend-macro-environment
  'when '()

tests/library-tests.scm

@@ -587 +587 @@
   (assert (equal? original-error (current-error-port)))
   (assert (equal? original-exception-handler (current-exception-handler))))
 
+;; Re-entering dynamic extent of a parameterize should not reset to
+;; original outer values but remember values when jumping out (another
+;; regression due to #1227, pointed out by Joo ChurlSoo in #1336).
+
+(let ((f (make-parameter 'a))
+      (path '())
+      (g (make-parameter 'g))
+      (c #f))
+  (let ((add (lambda () (set! path (cons (f) path)))))
+    (add)
+    (parameterize ((f 'b)
+                   (g (call-with-current-continuation
+                       (lambda (c0) (set! c c0) 'c))))
+      (add) (f (g)) (add))
+    (f 'd)
+    (add)
+    (if (< (length path) 8)
+        (c 'e)
+        (assert (equal? '(a b c d b e d b e d) (reverse path))))))
+
+(let ((f (make-parameter 'a))
+      (path '())
+      (g (make-parameter 'g))
+      (c #f))
+  (let ((add (lambda () (set! path (cons (f) path)))))
+    (add)
+    (parameterize ((f 'b))
+      (g (call-with-current-continuation (lambda (c0) (set! c c0) 'c)))
+      (add) (f (g)) (add))
+    (f 'd)
+    (add)
+    (if (< (length path) 8)
+        (c 'e)
+        (assert (equal? '(a b c d c e d e e d) (reverse path))))))
+
 ;;; vector and blob limits
 
 (assert-fail (make-blob -1))