aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMathieu Othacehe <m.othacehe@gmail.com>2020-03-06 10:06:54 +0100
committerMathieu Othacehe <m.othacehe@gmail.com>2020-03-08 20:28:31 +0100
commit9a2f99f42fdd19ac379ac85be2a8c2a34a345aa5 (patch)
tree7453d86ffe9231b7b6937b80cd38684155d35f8b
parent5d52d10661635ece0db9ffb89ab57f5f937221aa (diff)
downloadguix-9a2f99f42fdd19ac379ac85be2a8c2a34a345aa5.tar
guix-9a2f99f42fdd19ac379ac85be2a8c2a34a345aa5.tar.gz
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.
-rw-r--r--guix/gexp.scm91
-rw-r--r--tests/gexp.scm50
2 files changed, 103 insertions, 38 deletions
diff --git a/guix/gexp.scm b/guix/gexp.scm
index c4f4e80209..a657921741 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -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
@@ -1597,16 +1601,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)
@@ -1640,7 +1647,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.
@@ -1651,36 +1658,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
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 7c8985d846..9e38816c3d 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -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: