summaryrefslogtreecommitdiff
path: root/guix/packages.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2013-05-24 22:21:24 +0200
committerLudovic Courtès <ludo@gnu.org>2013-05-24 22:30:58 +0200
commit9c1edabd8b95d698ba995653d465fcb70cd2409b (patch)
tree585fead8a546f2e6d9c9827434b0fb24807241de /guix/packages.scm
parent17bb886ff42afe7caa7b89878a563243239f9698 (diff)
packages: Implement `package-cross-derivation'.
* guix/packages.scm (package-transitive-target-inputs, package-transitive-native-inputs): New procedures. (package-derivation): Parametrize `%current-target-system'. (package-cross-derivation): Implement. * guix/utils.scm (%current-target-system): New variable. * tests/packages.scm ("package-cross-derivation"): New test. * doc/guix.texi (Defining Packages): Document `package-cross-derivation'.
Diffstat (limited to 'guix/packages.scm')
-rw-r--r--guix/packages.scm71
1 files changed, 67 insertions, 4 deletions
diff --git a/guix/packages.scm b/guix/packages.scm
index 242b912d5d..6321a58374 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -69,6 +69,8 @@
package-field-location
package-transitive-inputs
+ package-transitive-target-inputs
+ package-transitive-native-inputs
package-transitive-propagated-inputs
package-source-derivation
package-derivation
@@ -268,6 +270,19 @@ with their propagated inputs, recursively."
(package-inputs package)
(package-propagated-inputs package))))
+(define (package-transitive-target-inputs package)
+ "Return the transitive target inputs of PACKAGE---i.e., its direct inputs
+along with their propagated inputs, recursively. This only includes inputs
+for the target system, and not native inputs."
+ (transitive-inputs (append (package-inputs package)
+ (package-propagated-inputs package))))
+
+(define (package-transitive-native-inputs package)
+ "Return the transitive native inputs of PACKAGE---i.e., its direct inputs
+along with their propagated inputs, recursively. This only includes inputs
+for the host system (\"native inputs\"), and not target inputs."
+ (transitive-inputs (package-native-inputs package)))
+
(define (package-transitive-propagated-inputs package)
"Return the propagated inputs of PACKAGE, and their propagated inputs,
recursively."
@@ -354,7 +369,8 @@ PACKAGE for SYSTEM."
;; Bind %CURRENT-SYSTEM so that thunked field values can refer
;; to it.
- (parameterize ((%current-system system))
+ (parameterize ((%current-system system)
+ (%current-target-system #f))
(match package
(($ <package> name version source (= build-system-builder builder)
args inputs propagated-inputs native-inputs self-native-input?
@@ -380,10 +396,57 @@ PACKAGE for SYSTEM."
#:outputs outputs #:system system
(args))))))))
-(define* (package-cross-derivation store package cross-system
+(define* (package-cross-derivation store package target
#:optional (system (%current-system)))
- ;; TODO
- #f)
+ "Cross-build PACKAGE for TARGET (a GNU triplet) from host SYSTEM (a Guix
+system identifying string)."
+ (cached package (cons system target)
+
+ ;; Bind %CURRENT-SYSTEM so that thunked field values can refer
+ ;; to it.
+ (parameterize ((%current-system system)
+ (%current-target-system target))
+ (match package
+ (($ <package> name version source
+ (= build-system-cross-builder builder)
+ args inputs propagated-inputs native-inputs self-native-input?
+ outputs)
+ (let* ((inputs (package-transitive-target-inputs package))
+ (input-drvs (map (cut expand-input
+ store package <>
+ system target)
+ inputs))
+ (host (append (if self-native-input?
+ `(("self" ,package))
+ '())
+ (package-transitive-native-inputs package)))
+ (host-drvs (map (cut expand-input
+ store package <> system)
+ host))
+ (all (append host inputs))
+ (paths (delete-duplicates
+ (append-map (match-lambda
+ ((_ (? package? p) _ ...)
+ (package-search-paths p))
+ (_ '()))
+ all)))
+ (npaths (delete-duplicates
+ (append-map (match-lambda
+ ((_ (? package? p) _ ...)
+ (package-native-search-paths
+ p))
+ (_ '()))
+ all))))
+
+ (apply builder
+ store (package-full-name package) target
+ (and source
+ (package-source-derivation store source system))
+ input-drvs host-drvs
+ #:search-paths paths
+ #:native-search-paths npaths
+ #:outputs outputs #:system system
+ (args))))))))
(define* (package-output store package output
#:optional (system (%current-system)))