rekahsoft
/
guix
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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:
Ludovic Courtès 2020-06-06 21:37:47 +02:00
parent 58bb833365
commit b49caaa2b7
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 50 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
guix/packages.scm
View File

@ -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

33
tests/packages.scm
View File

@ -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))