diff options
| -rw-r--r-- | guix/packages.scm | 30 | ||||
| -rw-r--r-- | tests/packages.scm | 33 |
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)) |