From d3d337d2d8f7152cb9ff3724f1cf240ce5ea5be2 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sun, 5 Oct 2014 16:32:25 +0200
Subject: build-system: Bags record their system and target.

* guix/build-system.scm (<bag>)[system, target]: New fields.
  (make-bag): Add #:system parameter and pass it to LOWER.
* gnu/packages/bootstrap.scm (make-raw-bag): Initialize 'system' field.
* guix/build-system/cmake.scm (lower): Likewise.
* guix/build-system/perl.scm (lower): Likewise.
* guix/build-system/python.scm (lower): Likewise.
* guix/build-system/ruby.scm (lower): Likewise.
* guix/build-system/trivial.scm (lower): Likewise.
* guix/build-system/gnu.scm (lower): Initialize 'system' and 'target'
  fields.
* guix/packages.scm (bag->derivation, bag->cross-derivation): New
  procedures.
  (package-derivation, package-cross-derivation): Use 'bag->derivation'.
* tests/packages.scm ("search paths"): Initialize 'system' and 'target'
  fields.
  ("package->bag", "package->bag, cross-compilation", "bag->derivation",
  "bag->derivation, cross-compilation"): New tests.
---
 tests/packages.scm | 36 +++++++++++++++++++++++++++++++++++-
 1 file changed, 35 insertions(+), 1 deletion(-)

(limited to 'tests')

diff --git a/tests/packages.scm b/tests/packages.scm
index 6deb21c331..2a87f3f15d 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -281,9 +281,11 @@
          (s (build-system
              (name 'raw)
              (description "Raw build system with direct store access")
-             (lower (lambda* (name #:key source inputs #:allow-other-keys)
+             (lower (lambda* (name #:key source inputs system target
+                                   #:allow-other-keys)
                       (bag
                         (name name)
+                        (system system) (target target)
                         (build-inputs inputs)
                         (build
                          (lambda* (store name inputs
@@ -339,6 +341,38 @@
       (package-cross-derivation %store p "mips64el-linux-gnu")
       #f)))
 
+(test-equal "package->bag"
+  `("foo86-hurd" #f (,(package-source gnu-make))
+    (,(canonical-package glibc)) (,(canonical-package coreutils)))
+  (let ((bag (package->bag gnu-make "foo86-hurd")))
+    (list (bag-system bag) (bag-target bag)
+          (assoc-ref (bag-build-inputs bag) "source")
+          (assoc-ref (bag-build-inputs bag) "libc")
+          (assoc-ref (bag-build-inputs bag) "coreutils"))))
+
+(test-equal "package->bag, cross-compilation"
+  `(,(%current-system) "foo86-hurd"
+    (,(package-source gnu-make))
+    (,(canonical-package glibc)) (,(canonical-package coreutils)))
+  (let ((bag (package->bag gnu-make (%current-system) "foo86-hurd")))
+    (list (bag-system bag) (bag-target bag)
+          (assoc-ref (bag-build-inputs bag) "source")
+          (assoc-ref (bag-build-inputs bag) "libc")
+          (assoc-ref (bag-build-inputs bag) "coreutils"))))
+
+(test-assert "bag->derivation"
+  (let ((bag (package->bag gnu-make))
+        (drv (package-derivation %store gnu-make)))
+    (parameterize ((%current-system "foox86-hurd")) ;should have no effect
+      (equal? drv (bag->derivation %store bag)))))
+
+(test-assert "bag->derivation, cross-compilation"
+  (let ((bag (package->bag gnu-make (%current-system) "mips64el-linux-gnu"))
+        (drv (package-cross-derivation %store gnu-make "mips64el-linux-gnu")))
+    (parameterize ((%current-system "foox86-hurd") ;should have no effect
+                   (%current-target-system "foo64-linux-gnu"))
+      (equal? drv (bag->derivation %store bag)))))
+
 (unless (false-if-exception (getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV))
   (test-skip 1))
 (test-assert "GNU Make, bootstrap"
-- 
cgit 1.4.1