1 files changed, 59 insertions, 0 deletions
diff --git a/guix/gexp.scm b/guix/gexp.scm
index a657921741..133e0f5679 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -82,6 +82,9 @@
             raw-derivation-file
             raw-derivation-file?
 
+            with-parameters
+            parameterized?
+
             load-path-expression
             gexp-modules
 
@@ -523,6 +526,62 @@ SUFFIX."
                           (base   (expand base lowered output)))
                      (string-append base (string-concatenate suffix)))))))
 
+;; Representation of SRFI-39 parameter settings in the dynamic scope of an
+;; object lowering.
+(define-record-type <parameterized>
+  (parameterized bindings thunk)
+  parameterized?
+  (bindings parameterized-bindings)             ;list of parameter/value pairs
+  (thunk    parameterized-thunk))               ;thunk
+
+(define-syntax-rule (with-parameters ((param value) ...) body ...)
+  "Bind each PARAM to the corresponding VALUE for the extent during which BODY
+is lowered.  Consider this example:
+
+  (with-parameters ((%current-system \"x86_64-linux\"))
+    coreutils)
+
+It returns a <parameterized> object that ensures %CURRENT-SYSTEM is set to
+x86_64-linux when COREUTILS is lowered."
+  (parameterized (list (list param (lambda () value)) ...)
+                 (lambda ()
+                   body ...)))
+
+(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)))
+         ;; Install the PARAMETERS for the dynamic extent of THUNK.
+         (with-fluids* fluids
+           (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))
+                   (target (if (memq %current-target-system parameters)
+                               (%current-target-system)
+                               target)))
+               (lower-object (thunk) system #:target target))))))))
+
+  expander => (lambda (parameterized lowered output)
+                (match (parameterized-bindings parameterized)
+                  (((parameters values) ...)
+                   (let ((fluids (map parameter-fluid parameters))
+                         (thunk  (parameterized-thunk parameterized)))
+                     ;; Install the PARAMETERS for the dynamic extent of THUNK.
+                     (with-fluids* fluids
+                       (map (lambda (thunk) (thunk)) values)
+                       (lambda ()
+                         ;; Delegate to the expander of the wrapped object.
+                         (let* ((base   (thunk))
+                                (expand (lookup-expander base)))
+                           (expand base lowered output)))))))))
+
 
 ;;;
 ;;; Inputs & outputs.