diff options
Diffstat (limited to 'guix/gexp.scm')
| -rw-r--r-- | guix/gexp.scm | 59 |
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. |