diff options
| -rw-r--r-- | guix/packages.scm | 30 | ||||
| -rw-r--r-- | tests/packages.scm | 36 |
2 files changed, 47 insertions, 19 deletions
diff --git a/guix/packages.scm b/guix/packages.scm index d9eeee15a2..39ab28d807 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -767,23 +767,29 @@ in INPUTS and their transitive propagated inputs." (transitive-inputs inputs))) (define package-transitive-supported-systems - (mlambdaq (package) - "Return the intersection of the systems supported by PACKAGE and those + (let () + (define supported-systems + (mlambda (package system) + (parameterize ((%current-system system)) + (fold (lambda (input systems) + (match input + ((label (? package? package) . _) + (lset-intersection string=? systems + (supported-systems package system))) + (_ + systems))) + (package-supported-systems package) + (bag-direct-inputs (package->bag package)))))) + + (lambda* (package #:optional (system (%current-system))) + "Return the intersection of the systems supported by PACKAGE and those supported by its dependencies." - (fold (lambda (input systems) - (match input - ((label (? package? p) . _) - (lset-intersection - string=? systems (package-transitive-supported-systems p))) - (_ - systems))) - (package-supported-systems package) - (bag-direct-inputs (package->bag package))))) + (supported-systems package system)))) (define* (supported-package? package #:optional (system (%current-system))) "Return true if PACKAGE is supported on SYSTEM--i.e., if PACKAGE and all its dependencies are known to build on SYSTEM." - (member system (package-transitive-supported-systems package))) + (member system (package-transitive-supported-systems package system))) (define (bag-direct-inputs bag) "Same as 'package-direct-inputs', but applied to a bag." diff --git a/tests/packages.scm b/tests/packages.scm index 0478fff237..423c5061aa 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -341,7 +341,6 @@ (build-system gnu-build-system) (supported-systems `("does-not-exist" "foobar" ,@%supported-systems))))) - (invalidate-memoization! package-transitive-supported-systems) (parameterize ((%current-system "armhf-linux")) ; a traditionally-bootstrapped architecture (package-transitive-supported-systems p)))) @@ -354,17 +353,40 @@ (build-system gnu-build-system) (supported-systems `("does-not-exist" "foobar" ,@%supported-systems))))) - (invalidate-memoization! package-transitive-supported-systems) (parameterize ((%current-system "x86_64-linux")) (package-transitive-supported-systems p)))) (test-assert "supported-package?" - (let ((p (dummy-package "foo" - (build-system gnu-build-system) - (supported-systems '("x86_64-linux" "does-not-exist"))))) + (let* ((d (dummy-package "dep" + (build-system trivial-build-system) + (supported-systems '("x86_64-linux")))) + (p (dummy-package "foo" + (build-system gnu-build-system) + (inputs `(("d" ,d))) + (supported-systems '("x86_64-linux" "armhf-linux"))))) + (and (supported-package? p "x86_64-linux") + (not (supported-package? p "i686-linux")) + (not (supported-package? p "armhf-linux"))))) + +(test-assert "supported-package? vs. system-dependent graph" + ;; The inputs of a package can depend on (%current-system). Thus, + ;; 'supported-package?' must make sure that it binds (%current-system) + ;; appropriately before traversing the dependency graph. In the example + ;; below, 'supported-package?' must thus return true for both systems. + (let* ((p0a (dummy-package "foo-arm" + (build-system trivial-build-system) + (supported-systems '("armhf-linux")))) + (p0b (dummy-package "foo-x86_64" + (build-system trivial-build-system) + (supported-systems '("x86_64-linux")))) + (p (dummy-package "bar" + (build-system trivial-build-system) + (inputs + (if (string=? (%current-system) "armhf-linux") + `(("foo" ,p0a)) + `(("foo" ,p0b))))))) (and (supported-package? p "x86_64-linux") - (not (supported-package? p "does-not-exist")) - (not (supported-package? p "i686-linux"))))) + (supported-package? p "armhf-linux")))) (test-skip (if (not %store) 8 0)) |