summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix/store.scm16
-rw-r--r--tests/store.scm11
2 files changed, 25 insertions, 2 deletions
diff --git a/guix/store.scm b/guix/store.scm
index 3c4d1c0058..8123407816 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -118,6 +118,8 @@
store-lower
run-with-store
%guile-for-build
+ current-system
+ set-current-system
text-file
interned-file
@@ -1040,6 +1042,18 @@ permission bits are kept."
(define set-build-options*
(store-lift set-build-options))
+(define-inlinable (current-system)
+ ;; Consult the %CURRENT-SYSTEM fluid at bind time. This is equivalent to
+ ;; (lift0 %current-system %store-monad), but inlinable, thus avoiding
+ ;; closure allocation in some cases.
+ (lambda (state)
+ (values (%current-system) state)))
+
+(define-inlinable (set-current-system system)
+ ;; Set the %CURRENT-SYSTEM fluid at bind time.
+ (lambda (state)
+ (values (%current-system system) state)))
+
(define %guile-for-build
;; The derivation of the Guile to be used within the build environment,
;; when using 'gexp->derivation' and co.
diff --git a/tests/store.scm b/tests/store.scm
index 394c06bc0f..9d651ce5a9 100644
--- a/tests/store.scm
+++ b/tests/store.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -837,6 +837,15 @@
(file (add %store "foo" "Lowered.")))
(call-with-input-file file get-string-all)))
+(test-equal "current-system"
+ "bar"
+ (parameterize ((%current-system "frob"))
+ (run-with-store %store
+ (mbegin %store-monad
+ (set-current-system "bar")
+ (current-system))
+ #:system "foo")))
+
(test-assert "query-path-info"
(let* ((ref (add-text-to-store %store "ref" "foo"))
(item (add-text-to-store %store "item" "bar" (list ref)))