GNU bug report logs - #76485
[PATCH] gexp: ‘with-parameters’ properly handles ‘%graft?’.

Previous Next

Full log

View this message in rfc822 format

From: Ludovic Courtès <ludo <at> gnu.org>
To: 76485 <at> debbugs.gnu.org
Cc: David Elsing <david.elsing <at> posteo.net>, Ludovic Courtès <ludo <at> gnu.org>, Christopher Baines <guix <at> cbaines.net>, Josselin Poiret <dev <at> jpoiret.xyz>, Ludovic Courtès <ludo <at> gnu.org>, Mathieu Othacehe <othacehe <at> gnu.org>, Simon Tournier <zimon.toutoune <at> gmail.com>, Tobias Geerinckx-Rice <me <at> tobias.gr>
Subject: [bug#76485] [PATCH] gexp: ‘with-parameters’ properly handles ‘%graft?’.
Date: Sat, 22 Feb 2025 15:59:37 +0100

Fixes <https://issues.guix.gnu.org/75879>.

* guix/gexp.scm (mcall-with-parameters): New procedure.
(compile-parameterized): Use it instead of ‘with-fluids’.
* tests/gexp.scm ("with-parameters for %graft?"): New test.

Reported-by: David Elsing <david.elsing <at> posteo.net>
Change-Id: Iddda7ead2aeef24dd989ac37a53fc99b726731b3
---
 guix/gexp.scm  | 31 ++++++++++++++++++++++++-------
 tests/gexp.scm | 20 ++++++++++++++++++++
 2 files changed, 44 insertions(+), 7 deletions(-)

diff --git a/guix/gexp.scm b/guix/gexp.scm
index ad51bc55b78..012a6b2573a 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -728,19 +728,34 @@ (define-syntax-rule (with-parameters ((param value) ...) body ...)
                  (lambda ()
                    body ...)))
 
+(define (mcall-with-parameters parameters values thunk)
+  "Set PARAMETERS to VALUES for the dynamic extent of THUNK, a monadic
+procedure."
+  ;; This is the procedural variant of 'mparameterize'.
+  (define (set-value parameter value)
+    (parameter value))
+
+  ;; XXX: Non-local exits can leave PARAMETERS set to VALUES.
+  (mlet* %store-monad ((old-values
+                        (return (map set-value parameters values)))
+                       (result (thunk)))
+    (mbegin %store-monad
+      (return (map set-value parameters old-values)) ;restore old values
+      (return result))))
+
 (define-gexp-compiler compile-parameterized <parameterized>
   compiler =>
   (lambda (parameterized system target)
     (match (parameterized-bindings parameterized)
       (((parameters values) ...)
-       (let ((fluids (map parameter-fluid parameters))
-             (thunk  (parameterized-thunk parameterized)))
+       (let ((thunk (parameterized-thunk parameterized)))
          ;; Install the PARAMETERS for the dynamic extent of THUNK.
-         (with-fluids* fluids
-           (map (lambda (thunk) (thunk)) values)
+         ;; Special-case '%current-system' and '%current-target-system' to
+         ;; make sure we get the desired effect.
+         (mcall-with-parameters
+             parameters
+             (map (lambda (thunk) (thunk)) values)
            (lambda ()
-             ;; Special-case '%current-system' and '%current-target-system' to
-             ;; make sure we get the desired effect.
              (let ((system (if (memq %current-system parameters)
                                (%current-system)
                                system))
@@ -2350,4 +2365,6 @@ (define* (references-file item #:optional (name "references")
   (read-hash-extend #\$ read-ungexp)
   (read-hash-extend #\+ (cut read-ungexp <> <> #t)))
 
-;;; gexp.scm ends here
+;;; Local Variables:
+;;; eval: (put 'mcall-with-parameters 'scheme-indent-function 2)
+;;; End:
diff --git a/tests/gexp.scm b/tests/gexp.scm
index e870f6cb1b9..2376c70d1ba 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -451,6 +451,26 @@ (define %extension-package
     (return (string=? (derivation-file-name drv)
                       (derivation-file-name result)))))
 
+(test-assertm "with-parameters for %graft?"
+  (mlet* %store-monad ((replacement -> (package
+                                         (inherit %bootstrap-guile)
+                                         (name (string-upcase
+                                                (package-name
+                                                 %bootstrap-guile)))))
+                       (guile -> (package
+                                   (inherit %bootstrap-guile)
+                                   (replacement replacement)))
+                       (drv0   (package->derivation %bootstrap-guile))
+                       (drv1   (package->derivation replacement))
+                       (obj0 -> (with-parameters ((%graft? #f))
+                                  guile))
+                       (obj1 -> (with-parameters ((%graft? #t))
+                                  guile))
+                       (result0 (lower-object obj0))
+                       (result1 (lower-object obj1)))
+    (return (and (eq? drv0 result0)
+                 (eq? drv1 result1)))))
+
 (test-assert "with-parameters + file-append"
   (let* ((system (match (%current-system)
                    ("aarch64-linux" "x86_64-linux")

base-commit: 90aa90eb05429553402e0b5225d23f84742a9286
-- 
2.48.1

Previous Next

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.