gexp: Default to current target.
* guix/gexp.scm (lower-object): Set target argument to 'current by default and look for the current target system at bind time if needed, (gexp->file): ditto, (gexp->script): ditto, (lower-gexp): make sure lowered extensions are not cross-compiled. * tests/gexp.scm: Add cross-compilation test-cases for gexp->script and gexp->file with a target passed explicitely and with a default target.
This commit is contained in:
Mathieu Othacehe
parent
fdae0fa50a
commit
a6bf7a9745
@ -2,7 +2,7 @@
|
||||
;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
|
||||
;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org>
|
||||
;;; Copyright © 2019 Mathieu Othacehe <m.othacehe@gmail.com>
|
||||
;;; Copyright © 2019, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
@ -218,7 +218,7 @@ procedure to expand it; otherwise return #f."
|
||||
|
||||
(define* (lower-object obj
|
||||
#:optional (system (%current-system))
|
||||
#:key target)
|
||||
#:key (target 'current))
|
||||
"Return as a value in %STORE-MONAD the derivation or store item
|
||||
corresponding to OBJ for SYSTEM, cross-compiling for TARGET if TARGET is true.
|
||||
OBJ must be an object that has an associated gexp compiler, such as a
|
||||
@ -228,7 +228,10 @@ OBJ must be an object that has an associated gexp compiler, such as a
|
||||
(raise (condition (&gexp-input-error (input obj)))))
|
||||
(lower
|
||||
;; Cache in STORE the result of lowering OBJ.
|
||||
(mlet %store-monad ((graft? (grafting?)))
|
||||
(mlet %store-monad ((target (if (eq? target 'current)
|
||||
(current-target-system)
|
||||
(return target)))
|
||||
(graft? (grafting?)))
|
||||
(mcached (let ((lower (lookup-compiler obj)))
|
||||
(lower obj system target))
|
||||
obj
|
||||
@ -779,7 +782,8 @@ derivations--e.g., code evaluated for its side effects."
|
||||
(extensions -> (gexp-extensions exp))
|
||||
(exts (mapm %store-monad
|
||||
(lambda (obj)
|
||||
(lower-object obj system))
|
||||
(lower-object obj system
|
||||
#:target #f))
|
||||
extensions))
|
||||
(modules+compiled (imported+compiled-modules
|
||||
%modules system
|
||||
@ -1549,16 +1553,19 @@ are searched for in PATH. Return #f when MODULES and EXTENSIONS are empty."
|
||||
#:key (guile (default-guile))
|
||||
(module-path %load-path)
|
||||
(system (%current-system))
|
||||
target)
|
||||
(target 'current))
|
||||
"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)
|
||||
#:system system
|
||||
#:target target)))
|
||||
(mlet* %store-monad ((target (if (eq? target 'current)
|
||||
(current-target-system)
|
||||
(return target)))
|
||||
(set-load-path
|
||||
(load-path-expression (gexp-modules exp)
|
||||
module-path
|
||||
#:extensions
|
||||
(gexp-extensions exp)
|
||||
#:system system
|
||||
#:target target)))
|
||||
(gexp->derivation name
|
||||
(gexp
|
||||
(call-with-output-file (ungexp output)
|
||||
@ -1592,7 +1599,7 @@ imported modules in its search path. Look up EXP's modules in MODULE-PATH."
|
||||
(module-path %load-path)
|
||||
(splice? #f)
|
||||
(system (%current-system))
|
||||
target)
|
||||
(target 'current))
|
||||
"Return a derivation that builds a file NAME containing EXP. When SPLICE?
|
||||
is true, EXP is considered to be a list of expressions that will be spliced in
|
||||
the resulting file.
|
||||
@ -1603,36 +1610,44 @@ Lookup EXP's modules in MODULE-PATH."
|
||||
(define modules (gexp-modules exp))
|
||||
(define extensions (gexp-extensions exp))
|
||||
|
||||
(if (or (not set-load-path?)
|
||||
(and (null? modules) (null? extensions)))
|
||||
(gexp->derivation name
|
||||
(gexp
|
||||
(call-with-output-file (ungexp output)
|
||||
(lambda (port)
|
||||
(for-each (lambda (exp)
|
||||
(write exp port))
|
||||
'(ungexp (if splice?
|
||||
exp
|
||||
(gexp ((ungexp exp)))))))))
|
||||
#:local-build? #t
|
||||
#:substitutable? #f
|
||||
#:system system
|
||||
#:target target)
|
||||
(mlet %store-monad ((set-load-path
|
||||
(load-path-expression modules module-path
|
||||
#:extensions extensions
|
||||
#:system system
|
||||
#:target target)))
|
||||
(mlet* %store-monad
|
||||
((target (if (eq? target 'current)
|
||||
(current-target-system)
|
||||
(return target)))
|
||||
(no-load-path? -> (or (not set-load-path?)
|
||||
(and (null? modules)
|
||||
(null? extensions))))
|
||||
(set-load-path
|
||||
(load-path-expression modules module-path
|
||||
#:extensions extensions
|
||||
#:system system
|
||||
#:target target)))
|
||||
(if no-load-path?
|
||||
(gexp->derivation name
|
||||
(gexp
|
||||
(call-with-output-file (ungexp output)
|
||||
(lambda (port)
|
||||
(for-each
|
||||
(lambda (exp)
|
||||
(write exp port))
|
||||
'(ungexp (if splice?
|
||||
exp
|
||||
(gexp ((ungexp exp)))))))))
|
||||
#:local-build? #t
|
||||
#:substitutable? #f
|
||||
#:system system
|
||||
#:target target)
|
||||
(gexp->derivation name
|
||||
(gexp
|
||||
(call-with-output-file (ungexp output)
|
||||
(lambda (port)
|
||||
(write '(ungexp set-load-path) port)
|
||||
(for-each (lambda (exp)
|
||||
(write exp port))
|
||||
'(ungexp (if splice?
|
||||
exp
|
||||
(gexp ((ungexp exp)))))))))
|
||||
(for-each
|
||||
(lambda (exp)
|
||||
(write exp port))
|
||||
'(ungexp (if splice?
|
||||
exp
|
||||
(gexp ((ungexp exp)))))))))
|
||||
#:module-path module-path
|
||||
#:local-build? #t
|
||||
#:substitutable? #f
|
||||
|
||||
@ -1331,6 +1331,56 @@
|
||||
'#~(foo #$bar #$baz:out #$(chbouib 42) #$@(list x y z)
|
||||
#+foo #+foo:out #+(chbouib 42) #+@(list x y z)))
|
||||
|
||||
(test-assertm "gexp->file, cross-compilation"
|
||||
(mlet* %store-monad ((target -> "aarch64-linux-gnu")
|
||||
(exp -> (gexp (list (ungexp coreutils))))
|
||||
(xdrv (gexp->file "foo" exp #:target target))
|
||||
(refs (references*
|
||||
(derivation-file-name xdrv)))
|
||||
(xcu (package->cross-derivation coreutils
|
||||
target))
|
||||
(cu (package->derivation coreutils)))
|
||||
(return (and (member (derivation-file-name xcu) refs)
|
||||
(not (member (derivation-file-name cu) refs))))))
|
||||
|
||||
(test-assertm "gexp->file, cross-compilation with default target"
|
||||
(mlet* %store-monad ((target -> "aarch64-linux-gnu")
|
||||
(_ (set-current-target target))
|
||||
(exp -> (gexp (list (ungexp coreutils))))
|
||||
(xdrv (gexp->file "foo" exp))
|
||||
(refs (references*
|
||||
(derivation-file-name xdrv)))
|
||||
(xcu (package->cross-derivation coreutils
|
||||
target))
|
||||
(cu (package->derivation coreutils)))
|
||||
(return (and (member (derivation-file-name xcu) refs)
|
||||
(not (member (derivation-file-name cu) refs))))))
|
||||
|
||||
(test-assertm "gexp->script, cross-compilation"
|
||||
(mlet* %store-monad ((target -> "aarch64-linux-gnu")
|
||||
(exp -> (gexp (list (ungexp coreutils))))
|
||||
(xdrv (gexp->script "foo" exp #:target target))
|
||||
(refs (references*
|
||||
(derivation-file-name xdrv)))
|
||||
(xcu (package->cross-derivation coreutils
|
||||
target))
|
||||
(cu (package->derivation coreutils)))
|
||||
(return (and (member (derivation-file-name xcu) refs)
|
||||
(not (member (derivation-file-name cu) refs))))))
|
||||
|
||||
(test-assertm "gexp->script, cross-compilation with default target"
|
||||
(mlet* %store-monad ((target -> "aarch64-linux-gnu")
|
||||
(_ (set-current-target target))
|
||||
(exp -> (gexp (list (ungexp coreutils))))
|
||||
(xdrv (gexp->script "foo" exp))
|
||||
(refs (references*
|
||||
(derivation-file-name xdrv)))
|
||||
(xcu (package->cross-derivation coreutils
|
||||
target))
|
||||
(cu (package->derivation coreutils)))
|
||||
(return (and (member (derivation-file-name xcu) refs)
|
||||
(not (member (derivation-file-name cu) refs))))))
|
||||
|
||||
(test-end "gexp")
|
||||
|
||||
;; Local Variables:
|
||||
|
||||
Loading…
Reference in New Issue
Block a user