summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2020-06-06 21:37:47 +0200
committerLudovic Courtès <ludo@gnu.org>2020-06-06 23:28:48 +0200
commitb49caaa2b7f624c3395c8e872638282bcc420502 (patch)
tree8507bbf825fb3dabc155f5f526e63cd39397fcbb
parent58bb833365db4e8934a386497d5b00a063cfd27d (diff)
packages: Make 'bag-grafts' insensitive to '%current-target-system'.
Fixes <https://bugs.gnu.org/41713>. Reported by Mathieu Othacehe. * guix/packages.scm (bag-grafts): Wrap 'fold-bag-dependencies' calls in 'parameterize'. * tests/packages.scm ("package->bag, sensitivity to %current-target-system"): New test.
-rw-r--r--guix/packages.scm30
-rw-r--r--tests/packages.scm33
2 files changed, 50 insertions, 13 deletions
diff --git a/guix/packages.scm b/guix/packages.scm
index 3d9988d836..0ccd31a7a9 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1277,23 +1277,27 @@ to (see 'graft-derivation'.)"
(define native-grafts
(let ((->graft (input-graft store system)))
- (fold-bag-dependencies (lambda (package grafts)
- (match (->graft package)
- (#f grafts)
- (graft (cons graft grafts))))
- '()
- bag)))
+ (parameterize ((%current-system system)
+ (%current-target-system #f))
+ (fold-bag-dependencies (lambda (package grafts)
+ (match (->graft package)
+ (#f grafts)
+ (graft (cons graft grafts))))
+ '()
+ bag))))
(define target-grafts
(if target
(let ((->graft (input-cross-graft store target system)))
- (fold-bag-dependencies (lambda (package grafts)
- (match (->graft package)
- (#f grafts)
- (graft (cons graft grafts))))
- '()
- bag
- #:native? #f))
+ (parameterize ((%current-system system)
+ (%current-target-system target))
+ (fold-bag-dependencies (lambda (package grafts)
+ (match (->graft package)
+ (#f grafts)
+ (graft (cons graft grafts))))
+ '()
+ bag
+ #:native? #f)))
'()))
;; We can end up with several identical grafts if we stumble upon packages
diff --git a/tests/packages.scm b/tests/packages.scm
index d8f0d677a3..72e87dbfb7 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -1006,6 +1006,39 @@
(assoc-ref (bag-build-inputs bag) "libc")
(assoc-ref (bag-build-inputs bag) "coreutils"))))
+(test-assert "package->bag, sensitivity to %current-target-system"
+ ;; https://bugs.gnu.org/41713
+ (let* ((lower (lambda* (name #:key system target inputs native-inputs
+ #:allow-other-keys)
+ (and (not target)
+ (bag (name name) (system system) (target target)
+ (build-inputs native-inputs)
+ (host-inputs inputs)
+ (build (lambda* (store name inputs
+ #:key system target
+ #:allow-other-keys)
+ (build-expression->derivation
+ store "foo" '(mkdir %output))))))))
+ (bs (build-system
+ (name 'build-system-without-cross-compilation)
+ (description "Does not support cross compilation.")
+ (lower lower)))
+ (dep (dummy-package "dep" (build-system bs)))
+ (pkg (dummy-package "example"
+ (native-inputs `(("dep" ,dep)))))
+ (do-not-build (lambda (continue store lst . _) lst)))
+ (equal? (with-build-handler do-not-build
+ (parameterize ((%current-target-system "powerpc64le-linux-gnu")
+ (%graft? #t))
+ (package-cross-derivation %store pkg
+ (%current-target-system)
+ #:graft? #t)))
+ (with-build-handler do-not-build
+ (package-cross-derivation %store
+ (package (inherit pkg))
+ "powerpc64le-linux-gnu"
+ #:graft? #t)))))
+
(test-equal "package->bag, cross-compilation"
`(,(%current-system) "foo86-hurd"
(,(package-source gnu-make))