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.
This commit is contained in:
parent
58bb833365
commit
b49caaa2b7
|
@ -1277,23 +1277,27 @@ to (see 'graft-derivation'.)"
|
||||||
|
|
||||||
(define native-grafts
|
(define native-grafts
|
||||||
(let ((->graft (input-graft store system)))
|
(let ((->graft (input-graft store system)))
|
||||||
(fold-bag-dependencies (lambda (package grafts)
|
(parameterize ((%current-system system)
|
||||||
(match (->graft package)
|
(%current-target-system #f))
|
||||||
(#f grafts)
|
(fold-bag-dependencies (lambda (package grafts)
|
||||||
(graft (cons graft grafts))))
|
(match (->graft package)
|
||||||
'()
|
(#f grafts)
|
||||||
bag)))
|
(graft (cons graft grafts))))
|
||||||
|
'()
|
||||||
|
bag))))
|
||||||
|
|
||||||
(define target-grafts
|
(define target-grafts
|
||||||
(if target
|
(if target
|
||||||
(let ((->graft (input-cross-graft store target system)))
|
(let ((->graft (input-cross-graft store target system)))
|
||||||
(fold-bag-dependencies (lambda (package grafts)
|
(parameterize ((%current-system system)
|
||||||
(match (->graft package)
|
(%current-target-system target))
|
||||||
(#f grafts)
|
(fold-bag-dependencies (lambda (package grafts)
|
||||||
(graft (cons graft grafts))))
|
(match (->graft package)
|
||||||
'()
|
(#f grafts)
|
||||||
bag
|
(graft (cons graft grafts))))
|
||||||
#:native? #f))
|
'()
|
||||||
|
bag
|
||||||
|
#:native? #f)))
|
||||||
'()))
|
'()))
|
||||||
|
|
||||||
;; We can end up with several identical grafts if we stumble upon packages
|
;; We can end up with several identical grafts if we stumble upon packages
|
||||||
|
|
|
@ -1006,6 +1006,39 @@
|
||||||
(assoc-ref (bag-build-inputs bag) "libc")
|
(assoc-ref (bag-build-inputs bag) "libc")
|
||||||
(assoc-ref (bag-build-inputs bag) "coreutils"))))
|
(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"
|
(test-equal "package->bag, cross-compilation"
|
||||||
`(,(%current-system) "foo86-hurd"
|
`(,(%current-system) "foo86-hurd"
|
||||||
(,(package-source gnu-make))
|
(,(package-source gnu-make))
|
||||||
|
|
Loading…
Reference in New Issue