01/06: guix build: Accept multiple '-s' options.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit ea261dea0c581771b4cf297e983f7addc6807051
Author: Ludovic Courtès <address@hidden>
Date:   Fri Apr 19 15:18:20 2019 +0200

    guix build: Accept multiple '-s' options.
    
    * guix/scripts/build.scm (%default-options): Remove 'system'.
    (%options) <--system>: Keep previous occurrences of 'system in RESULT.
    (options->derivations)[system]: Remove.
    [systems, things-to-build]: New variables.
    [compute-derivation]: New procedure.
    Iterate on all of SYSTEMS to compute the derivations of THINGS-TO-BUILD.
    * tests/guix-build.sh: Add test for one and multiple '-s' flags.
    * doc/guix.texi (Additional Build Options): Document this behavior.
---
 doc/guix.texi          |   4 +-
 guix/scripts/build.scm | 107 +++++++++++++++++++++++++++----------------------
 tests/guix-build.sh    |   7 ++++
 3 files changed, 70 insertions(+), 48 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 6b713aa..8c7522f 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -8030,7 +8030,9 @@ The following derivations will be built:
 @item address@hidden
 @itemx -s @var{system}
 Attempt to build for @var{system}---e.g., @code{i686-linux}---instead of
-the system type of the build host.
+the system type of the build host.  The @command{guix build} command allows
+you to repeat this option several times, in which case it builds for all the
+specified systems; other commands ignore extraneous @option{-s} options.
 
 @quotation Note
 The @code{--system} flag is for @emph{native} compilation and must not
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index fc0c0e2..ba143ad 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -635,8 +635,7 @@ options handled by 'set-build-options-from-command-line', 
and listed in
 
 (define %default-options
   ;; Alist of default option values.
-  `((system . ,(%current-system))
-    (build-mode . ,(build-mode normal))
+  `((build-mode . ,(build-mode normal))
     (graft? . #t)
     (substitutes? . #t)
     (build-hook? . #t)
@@ -729,8 +728,7 @@ must be one of 'package', 'all', or 'transitive'~%")
                           rest)))
          (option '(#\s "system") #t #f
                  (lambda (opt name arg result)
-                   (alist-cons 'system arg
-                               (alist-delete 'system result eq?))))
+                   (alist-cons 'system arg result)))
          (option '("target") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'target arg
@@ -811,56 +809,71 @@ build."
        (cut package-cross-derivation <> <> triplet <>))))
 
   (define src    (assoc-ref opts 'source))
-  (define system (assoc-ref opts 'system))
   (define graft? (assoc-ref opts 'graft?))
+  (define systems
+    (match (filter-map (match-lambda
+                         (('system . system) system)
+                         (_ #f))
+                       opts)
+      (()      (list (%current-system)))
+      (systems systems)))
+
+  (define things-to-build
+    (map (cut transform store <>)
+         (options->things-to-build opts)))
+
+  (define (compute-derivation obj system)
+    ;; Compute the derivation of OBJ for SYSTEM.
+    (match obj
+      ((? package? p)
+       (let ((p (or (and graft? (package-replacement p)) p)))
+         (match src
+           (#f
+            (list (package->derivation store p system)))
+           (#t
+            (match (package-source p)
+              (#f
+               (format (current-error-port)
+                       (G_ "~a: warning: \
+package '~a' has no source~%")
+                       (location->string (package-location p))
+                       (package-name p))
+               '())
+              (s
+               (list (package-source-derivation store s)))))
+           (proc
+            (map (cut package-source-derivation store <>)
+                 (proc p))))))
+      ((? derivation? drv)
+       (list drv))
+      ((? procedure? proc)
+       (list (run-with-store store
+               (mbegin %store-monad
+                 (set-guile-for-build (default-guile))
+                 (proc))
+               #:system system)))
+      ((? file-like? obj)
+       (list (run-with-store store
+               (lower-object obj system
+                             #:target (assoc-ref opts 'target))
+               #:system system)))
+      ((? gexp? gexp)
+       (list (run-with-store store
+               (mbegin %store-monad
+                 (set-guile-for-build (default-guile))
+                 (gexp->derivation "gexp" gexp
+                                   #:system system))
+               #:system system)))))
 
   ;; We may get 'unbound-variable' errors while evaluating the 'inputs' fields
   ;; of user packages.  Since 'guix build' is the primary tool for people
   ;; testing new packages, report such errors gracefully.
   (with-unbound-variable-handling
    (parameterize ((%graft? graft?))
-     (append-map (match-lambda
-                   ((? package? p)
-                    (let ((p (or (and graft? (package-replacement p)) p)))
-                      (match src
-                        (#f
-                         (list (package->derivation store p system)))
-                        (#t
-                         (match (package-source p)
-                           (#f
-                            (format (current-error-port)
-                                    (G_ "~a: warning: \
-package '~a' has no source~%")
-                                    (location->string (package-location p))
-                                    (package-name p))
-                            '())
-                           (s
-                            (list (package-source-derivation store s)))))
-                        (proc
-                         (map (cut package-source-derivation store <>)
-                              (proc p))))))
-                   ((? derivation? drv)
-                    (list drv))
-                   ((? procedure? proc)
-                    (list (run-with-store store
-                            (mbegin %store-monad
-                              (set-guile-for-build (default-guile))
-                              (proc))
-                            #:system system)))
-                   ((? file-like? obj)
-                    (list (run-with-store store
-                            (lower-object obj system
-                                          #:target (assoc-ref opts 'target))
-                            #:system system)))
-                   ((? gexp? gexp)
-                    (list (run-with-store store
-                            (mbegin %store-monad
-                              (set-guile-for-build (default-guile))
-                              (gexp->derivation "gexp" gexp
-                                                #:system system))
-                            #:system system))))
-                 (map (cut transform store <>)
-                      (options->things-to-build opts))))))
+     (append-map (lambda (system)
+                   (append-map (cut compute-derivation <> system)
+                               things-to-build))
+                 systems))))
 
 (define (show-build-log store file urls)
   "Show the build log for FILE, falling back to remote logs from URLS if
diff --git a/tests/guix-build.sh b/tests/guix-build.sh
index d479296..63a9fe6 100644
--- a/tests/guix-build.sh
+++ b/tests/guix-build.sh
@@ -44,6 +44,13 @@ guix build -e '(@@ (gnu packages bootstrap) 
%bootstrap-guile)'
      guix build -e '(@@ (gnu packages bootstrap) %bootstrap-guile)';   \
   then exit 1; fi )
 
+# Passing one '-s' flag.
+test `guix build sed -s x86_64-linux -d | wc -l` = 1
+
+# Passing multiple '-s' flags.
+all_systems="-s x86_64-linux -s i686-linux -s armhf-linux -s aarch64-linux"
+test `guix build sed $all_systems -d | sort -u | wc -l` = 4
+
 # Check --sources option with its arguments
 module_dir="t-guix-build-$$"
 mkdir "$module_dir"