03/10: gexp: 'program-file' honors the current system and cross-compilation target.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 2e8cabb8d630a8423e2e5a3bf150c1c0310b945d
Author: Ludovic Courtès <address@hidden>
Date:   Fri Jul 26 23:48:03 2019 +0200

    gexp: 'program-file' honors the current system and cross-compilation target.
    
    Fixes <https://bugs.gnu.org/36813>.
    Reported by Jakob L. Kreuze <address@hidden>.
    
    * guix/gexp.scm (program-file-compiler): Pass #:system and #:target to
    'gexp->script'.
    (load-path-expression): Add #:system and #:target and honor them.
    (gexp->script): Likewise.
    * tests/gexp.scm ("program-file #:system"): New test.
    * doc/guix.texi (G-Expressions): Adjust accordingly.
---
 doc/guix.texi  |  3 ++-
 guix/gexp.scm  | 23 +++++++++++++++++------
 tests/gexp.scm | 19 +++++++++++++++++++
 3 files changed, 38 insertions(+), 7 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 96448c2..ccc36a8 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -7439,7 +7439,8 @@ This is the declarative counterpart of 
@code{gexp->derivation}.
 @end deffn
 
 @deffn {Monadic Procedure} gexp->script @var{name} @var{exp} @
-  [#:guile (default-guile)] [#:module-path %load-path]
+  [#:guile (default-guile)] [#:module-path %load-path] @
+  [#:system (%current-system)] [#:target #f]
 Return an executable script @var{name} that runs @var{exp} using
 @var{guile}, with @var{exp}'s imported modules in its search path.
 Look up @var{exp}'s modules in @var{module-path}.
diff --git a/guix/gexp.scm b/guix/gexp.scm
index a83d716..45cd586 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -427,7 +427,9 @@ This is the declarative counterpart of 'gexp->script'."
     (($ <program-file> name gexp guile module-path)
      (gexp->script name gexp
                    #:module-path module-path
-                   #:guile (or guile (default-guile))))))
+                   #:guile (or guile (default-guile))
+                   #:system system
+                   #:target target))))
 
 (define-record-type <scheme-file>
   (%scheme-file name gexp splice?)
@@ -1512,7 +1514,7 @@ TARGET, a GNU triplet."
               'guile-2.2))
 
 (define* (load-path-expression modules #:optional (path %load-path)
-                               #:key (extensions '()))
+                               #:key (extensions '()) system target)
   "Return as a monadic value a gexp that sets '%load-path' and
 '%load-compiled-path' to point to MODULES, a list of module names.  MODULES
 are searched for in PATH.  Return #f when MODULES and EXTENSIONS are empty."
@@ -1520,10 +1522,13 @@ are searched for in PATH.  Return #f when MODULES and 
EXTENSIONS are empty."
       (with-monad %store-monad
         (return #f))
       (mlet %store-monad ((modules  (imported-modules modules
-                                                      #:module-path path))
+                                                      #:module-path path
+                                                      #:system system))
                           (compiled (compiled-modules modules
                                                       #:extensions extensions
-                                                      #:module-path path)))
+                                                      #:module-path path
+                                                      #:system system
+                                                      #:target target)))
         (return (gexp (eval-when (expand load eval)
                         (set! %load-path
                           (cons (ungexp modules)
@@ -1545,14 +1550,18 @@ are searched for in PATH.  Return #f when MODULES and 
EXTENSIONS are empty."
 
 (define* (gexp->script name exp
                        #:key (guile (default-guile))
-                       (module-path %load-path))
+                       (module-path %load-path)
+                       (system (%current-system))
+                       target)
   "Return an executable script NAME that runs EXP using GUILE, with EXP's
 imported modules in its search path.  Look up EXP's modules in MODULE-PATH."
   (mlet %store-monad ((set-load-path
                        (load-path-expression (gexp-modules exp)
                                              module-path
                                              #:extensions
-                                             (gexp-extensions exp))))
+                                             (gexp-extensions exp)
+                                             #:system system
+                                             #:target target)))
     (gexp->derivation name
                       (gexp
                        (call-with-output-file (ungexp output)
@@ -1572,6 +1581,8 @@ imported modules in its search path.  Look up EXP's 
modules in MODULE-PATH."
 
                            (write '(ungexp exp) port)
                            (chmod port #o555))))
+                      #:system system
+                      #:target target
                       #:module-path module-path)))
 
 (define* (gexp->file name exp #:key
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 460afe7..5c013d8 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -1104,6 +1104,25 @@
           (return (and (zero? (close-pipe pipe))
                        (= 42 (string->number str)))))))))
 
+(test-assertm "program-file #:system"
+  (let* ((exp    (with-imported-modules '((guix build utils))
+                   (gexp (begin
+                           (use-modules (guix build utils))
+                           (display "hi!")))))
+         (system (if (string=? (%current-system) "x86_64-linux")
+                     "armhf-linux"
+                     "x86_64-linux"))
+         (file   (program-file "program" exp)))
+    (mlet %store-monad ((drv (lower-object file system)))
+      (return (and (string=? (derivation-system drv) system)
+                   (find (lambda (input)
+                           (let ((drv (pk (derivation-input-derivation 
input))))
+                             (and (string=? (derivation-name drv)
+                                            "module-import-compiled")
+                                  (string=? (derivation-system drv)
+                                            system))))
+                         (derivation-inputs drv)))))))
+
 (test-assertm "scheme-file"
   (let* ((text   (plain-file "foo" "Hello, world!"))
          (scheme (scheme-file "bar" #~(list "foo" #$text))))