From 9b222abe0349701280d48e4830f98aa07c947517 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Mon, 27 May 2013 23:41:35 +0200
Subject: [PATCH] packages: Raise an error condition a cross builder is needed
 but unavailable.

* guix/packages.scm (&package-cross-build-system-error): New condition type.
  (package-cross-derivation): Raise &package-cross-build-system-error
  when the build system doesn't support cross builds.
* guix/ui.scm (call-with-error-handling): Add
  package-cross-build-system-error? case.
* tests/packages.scm ("package-cross-derivation, no cross builder"): New test.
---
 guix/packages.scm  | 12 +++++++++++-
 guix/ui.scm        |  9 +++++++++
 tests/packages.scm | 11 +++++++++++
 3 files changed, 31 insertions(+), 1 deletion(-)

diff --git a/guix/packages.scm b/guix/packages.scm
index 9d11b468fb..4f8d87e53a 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -83,7 +83,9 @@
             package-error-package
             &package-input-error
             package-input-error?
-            package-error-invalid-input))
+            package-error-invalid-input
+            &package-cross-build-system-error
+            package-cross-build-system-error?))
 
 ;;; Commentary:
 ;;;
@@ -234,6 +236,9 @@ corresponds to the arguments expected by `set-path-environment-variable'."
   package-input-error?
   (input package-error-invalid-input))
 
+(define-condition-type &package-cross-build-system-error &package-error
+  package-cross-build-system-error?)
+
 
 (define (package-full-name package)
   "Return the full name of PACKAGE--i.e., `NAME-VERSION'."
@@ -412,6 +417,11 @@ system identifying string)."
                   (= build-system-cross-builder builder)
                   args inputs propagated-inputs native-inputs self-native-input?
                   outputs)
+               (unless builder
+                 (raise (condition
+                         (&package-cross-build-system-error
+                          (package package)))))
+
                (let* ((inputs     (package-transitive-target-inputs package))
                       (input-drvs (map (cut expand-input
                                             store package <>
diff --git a/guix/ui.scm b/guix/ui.scm
index cf94aa0818..cd47989ca6 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -23,6 +23,7 @@
   #:use-module (guix store)
   #:use-module (guix config)
   #:use-module (guix packages)
+  #:use-module (guix build-system)
   #:use-module (guix derivations)
   #:use-module ((guix licenses) #:select (license? license-name))
   #:use-module (srfi srfi-1)
@@ -152,6 +153,14 @@ General help using GNU software: <http://www.gnu.org/gethelp/>"))
                (leave (_ "~a:~a:~a: package `~a' has an invalid input: ~s~%")
                       file line column
                       (package-full-name package) input)))
+            ((package-cross-build-system-error? c)
+             (let* ((package (package-error-package c))
+                    (loc     (package-location package))
+                    (system  (package-build-system package)))
+               (leave (_ "~a: ~a: build system `~a' does not support cross builds~%")
+                      (location->string loc)
+                      (package-full-name package)
+                      (build-system-name system))))
             ((nix-connection-error? c)
              (leave (_ "failed to connect to `~a': ~a~%")
                     (nix-connection-error-file c)
diff --git a/tests/packages.scm b/tests/packages.scm
index bec9de5b45..a4bb7fbd31 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -30,6 +30,7 @@
   #:use-module (gnu packages bootstrap)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-64)
   #:use-module (rnrs io ports)
   #:use-module (ice-9 match))
@@ -212,6 +213,16 @@
       (and (derivation-path? drv-path)
            (derivation? drv)))))
 
+(test-assert "package-cross-derivation, no cross builder"
+  (let* ((b (build-system (inherit trivial-build-system)
+              (cross-build #f)))
+         (p (package (inherit (dummy-package "p"))
+              (build-system b))))
+    (guard (c ((package-cross-build-system-error? c)
+               (eq? (package-error-package c) p)))
+      (package-cross-derivation %store p "mips64el-linux-gnu")
+      #f)))
+
 (unless (false-if-exception (getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV))
   (test-skip 1))
 (test-assert "GNU Make, bootstrap"