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

Fixes <https://bugs.gnu.org/36813>.
Reported by Jakob L. Kreuze <zerodaysfordays.sdf.org@sdf.org>.

* 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.
This commit is contained in:
Ludovic Courtès 2019-07-26 23:48:03 +02:00
parent 2cc5ec7f0d
commit 2e8cabb8d6
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
3 changed files with 38 additions and 7 deletions

View File

@ -7439,7 +7439,8 @@ This is the declarative counterpart of @code{gexp->derivation}.
@end deffn @end deffn
@deffn {Monadic Procedure} gexp->script @var{name} @var{exp} @ @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 Return an executable script @var{name} that runs @var{exp} using
@var{guile}, with @var{exp}'s imported modules in its search path. @var{guile}, with @var{exp}'s imported modules in its search path.
Look up @var{exp}'s modules in @var{module-path}. Look up @var{exp}'s modules in @var{module-path}.

View File

@ -427,7 +427,9 @@ This is the declarative counterpart of 'gexp->script'."
(($ <program-file> name gexp guile module-path) (($ <program-file> name gexp guile module-path)
(gexp->script name gexp (gexp->script name gexp
#:module-path module-path #:module-path module-path
#:guile (or guile (default-guile)))))) #:guile (or guile (default-guile))
#:system system
#:target target))))
(define-record-type <scheme-file> (define-record-type <scheme-file>
(%scheme-file name gexp splice?) (%scheme-file name gexp splice?)
@ -1512,7 +1514,7 @@ TARGET, a GNU triplet."
'guile-2.2)) 'guile-2.2))
(define* (load-path-expression modules #:optional (path %load-path) (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 "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 '%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." 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 (with-monad %store-monad
(return #f)) (return #f))
(mlet %store-monad ((modules (imported-modules modules (mlet %store-monad ((modules (imported-modules modules
#:module-path path)) #:module-path path
#:system system))
(compiled (compiled-modules modules (compiled (compiled-modules modules
#:extensions extensions #:extensions extensions
#:module-path path))) #:module-path path
#:system system
#:target target)))
(return (gexp (eval-when (expand load eval) (return (gexp (eval-when (expand load eval)
(set! %load-path (set! %load-path
(cons (ungexp modules) (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 (define* (gexp->script name exp
#:key (guile (default-guile)) #: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 "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." imported modules in its search path. Look up EXP's modules in MODULE-PATH."
(mlet %store-monad ((set-load-path (mlet %store-monad ((set-load-path
(load-path-expression (gexp-modules exp) (load-path-expression (gexp-modules exp)
module-path module-path
#:extensions #:extensions
(gexp-extensions exp)))) (gexp-extensions exp)
#:system system
#:target target)))
(gexp->derivation name (gexp->derivation name
(gexp (gexp
(call-with-output-file (ungexp output) (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) (write '(ungexp exp) port)
(chmod port #o555)))) (chmod port #o555))))
#:system system
#:target target
#:module-path module-path))) #:module-path module-path)))
(define* (gexp->file name exp #:key (define* (gexp->file name exp #:key

View File

@ -1104,6 +1104,25 @@
(return (and (zero? (close-pipe pipe)) (return (and (zero? (close-pipe pipe))
(= 42 (string->number str))))))))) (= 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" (test-assertm "scheme-file"
(let* ((text (plain-file "foo" "Hello, world!")) (let* ((text (plain-file "foo" "Hello, world!"))
(scheme (scheme-file "bar" #~(list "foo" #$text)))) (scheme (scheme-file "bar" #~(list "foo" #$text))))