gexp: Add 'ungexp-native' and 'ungexp-native-splicing'.

* guix/gexp.scm (<gexp>)[natives]: New field.
  (write-gexp): Use both 'gexp-references' and
  'gexp-native-references'.
  (gexp->derivation): Use both 'gexp-inputs' and 'gexp-native-inputs',
  and append them.
  (gexp-inputs): Add 'references' parameter and honor it.
  (gexp-native-inputs): New procedure.
  (gexp->sexp)[reference->sexp]: Add 'native?' parameter and honor it.
  Use it, and use 'gexp-native-references'.
  (gexp)[collect-native-escapes]: New procedure.
  [escape->ref]: Handle 'ungexp-native' and 'ungexp-native-splicing'.
  [substitute-ungexp, substitute-ungexp-splicing]: New procedures.
  [substitute-references]: Use them, and handle 'ungexp-native' and
  'ungexp-native-splicing'.
  Adjust generated 'make-gexp' call to provide both normal references
  and native references.
  [read-ungexp]: Support 'ungexp-native' and
  'ungexp-native-splicing'.
  Add reader extension for #+.
* tests/gexp.scm (gexp-native-inputs): New procedure.
  (gexp->sexp*): Add 'target' parameter.
  ("ungexp + ungexp-native",
  "input list + ungexp-native",
  "input list splicing + ungexp-native-splicing",
  "gexp->derivation, ungexp-native",
  "gexp->derivation, ungexp + ungexp-native"): New tests.
  ("sugar"): Add tests for #+ and #+@.
* doc/guix.texi (G-Expressions): Document 'ungexp-native' et al.

4 files changed, 246 insertions, 50 deletions

diff --git a/.dir-locals.el b/.dir-locals.el
index 69c25cbe8f..ce7033757d 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -40,11 +40,12 @@
    (eval . (put 'mlet 'scheme-indent-function 2))
    (eval . (put 'run-with-store 'scheme-indent-function 1))
 
-   ;; Recognize '~' and '$', as used for gexps, as quotation symbols.  This
-   ;; notably allows '(' in Paredit to not insert a space when the preceding
-   ;; symbol is one of these.
+   ;; Recognize '~', '+', and '$', as used for gexps, as quotation symbols.
+   ;; This notably allows '(' in Paredit to not insert a space when the
+   ;; preceding symbol is one of these.
    (eval . (modify-syntax-entry ?~ "'"))
-   (eval . (modify-syntax-entry ?$ "'"))))
+   (eval . (modify-syntax-entry ?$ "'"))
+   (eval . (modify-syntax-entry ?+ "'"))))
  (emacs-lisp-mode . ((indent-tabs-mode . nil)))
  (texinfo-mode    . ((indent-tabs-mode . nil)
                      (fill-column . 72))))
diff --git a/doc/guix.texi b/doc/guix.texi
index 8381b388cc..09ed39213c 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -2160,8 +2160,32 @@ substituted to the reference to the @var{coreutils} package in the
 actual build code, and @var{coreutils} is automatically made an input to
 the derivation.  Likewise, @code{#$output} (equivalent to @code{(ungexp
 output)}) is replaced by a string containing the derivation's output
-directory name.  The syntactic form to construct gexps is summarized
-below.
+directory name.
+
+@cindex cross compilation
+In a cross-compilation context, it is useful to distinguish between
+references to the @emph{native} build of a package---that can run on the
+host---versus references to cross builds of a package.  To that end, the
+@code{#+} plays the same role as @code{#$}, but is a reference to a
+native package build:
+
+@example
+(gexp->derivation "vi"
+   #~(begin
+       (mkdir #$output)
+       (system* (string-append #+coreutils "/bin/ln")
+                "-s"
+                (string-append #$emacs "/bin/emacs")
+                (string-append #$output "/bin/vi")))
+   #:target "mips64el-linux")
+@end example
+
+@noindent
+In the example above, the native build of @var{coreutils} is used, so
+that @command{ln} can actually run on the host; but then the
+cross-compiled build of @var{emacs} is referenced.
+
+The syntactic form to construct gexps is summarized below.
 
 @deffn {Scheme Syntax} #~@var{exp}
 @deffnx {Scheme Syntax} (gexp @var{exp})
@@ -2190,6 +2214,13 @@ This is like the form above, but referring explicitly to the
 @var{package-or-derivation} produces multiple outputs (@pxref{Packages
 with Multiple Outputs}).
 
+@item #+@var{obj}
+@itemx #+@var{obj}:output
+@itemx (ungexp-native @var{obj})
+@itemx (ungexp-native @var{obj} @var{output})
+Same as @code{ungexp}, but produces a reference to the @emph{native}
+build of @var{obj} when used in a cross compilation context.
+
 @item #$output[:@var{output}]
 @itemx (ungexp output [@var{output}])
 Insert a reference to derivation output @var{output}, or to the main
@@ -2202,6 +2233,11 @@ This only makes sense for gexps passed to @code{gexp->derivation}.
 Like the above, but splices the contents of @var{lst} inside the
 containing list.
 
+@item #+@@@var{lst}
+@itemx (ungexp-native-splicing @var{lst})
+Like the above, but refers to native builds of the objects listed in
+@var{lst}.
+
 @end table
 
 G-expressions created by @code{gexp} or @code{#~} are run-time objects
diff --git a/guix/gexp.scm b/guix/gexp.scm
index f54221feab..6d1f328aef 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -41,7 +41,9 @@
 ;;; S-expressions (sexps), with two differences:
 ;;;
 ;;;   1. References (un-quotations) to derivations or packages in a gexp are
-;;;      replaced by the corresponding output file name;
+;;;      replaced by the corresponding output file name; in addition, the
+;;;      'ungexp-native' unquote-like form allows code to explicitly refer to
+;;;      the native code of a given package, in case of cross-compilation;
 ;;;
 ;;;   2. Gexps embed information about the derivations they refer to.
 ;;;
@@ -52,9 +54,10 @@
 
 ;; "G expressions".
 (define-record-type <gexp>
-  (make-gexp references proc)
+  (make-gexp references natives proc)
   gexp?
   (references gexp-references)                    ; ((DRV-OR-PKG OUTPUT) ...)
+  (natives    gexp-native-references)             ; ((DRV-OR-PKG OUTPUT) ...)
   (proc       gexp-proc))                         ; procedure
 
 (define (write-gexp gexp port)
@@ -65,7 +68,10 @@
   ;; doing things like (ungexp-splicing (gexp ())) because GEXP's procedure
   ;; tries to use 'append' on that, which fails with wrong-type-arg.
   (false-if-exception
-   (write (apply (gexp-proc gexp) (gexp-references gexp)) port))
+   (write (apply (gexp-proc gexp)
+                 (append (gexp-references gexp)
+                         (gexp-native-references gexp)))
+          port))
   (format port " ~a>"
           (number->string (object-address gexp) 16)))
 
@@ -134,9 +140,13 @@ The other arguments are as for 'derivation'."
                        (target -> (if (eq? target 'current)
                                       (%current-target-system)
                                       target))
-                       (inputs   (lower-inputs (gexp-inputs exp)
+                       (normals  (lower-inputs (gexp-inputs exp)
                                                #:system system
                                                #:target target))
+                       (natives  (lower-inputs (gexp-native-inputs exp)
+                                               #:system system
+                                               #:target #f))
+                       (inputs -> (append normals natives))
                        (sexp     (gexp->sexp exp
                                              #:system system
                                              #:target target))
@@ -177,8 +187,9 @@ The other arguments are as for 'derivation'."
                     #:references-graphs references-graphs
                     #:local-build? local-build?)))
 
-(define (gexp-inputs exp)
-  "Return the input list for EXP."
+(define* (gexp-inputs exp #:optional (references gexp-references))
+  "Return the input list for EXP, using REFERENCES to get its list of
+references."
   (define (add-reference-inputs ref result)
     (match ref
       (((? derivation?) (? string?))
@@ -188,7 +199,7 @@ The other arguments are as for 'derivation'."
       (((? origin?) (? string?))
        (cons ref result))
       ((? gexp? exp)
-       (append (gexp-inputs exp) result))
+       (append (gexp-inputs exp references) result))
       (((? string? file))
        (if (direct-store-path? file)
            (cons ref result)
@@ -201,7 +212,10 @@ The other arguments are as for 'derivation'."
 
   (fold-right add-reference-inputs
               '()
-              (gexp-references exp)))
+              (references exp)))
+
+(define gexp-native-inputs
+  (cut gexp-inputs <> gexp-native-references))
 
 (define (gexp-outputs exp)
   "Return the outputs referred to by EXP as a list of strings."
@@ -223,7 +237,7 @@ The other arguments are as for 'derivation'."
                      (target (%current-target-system)))
   "Return (monadically) the sexp corresponding to EXP for the given OUTPUT,
 and in the current monad setting (system type, etc.)"
-  (define (reference->sexp ref)
+  (define* (reference->sexp ref #:optional native?)
     (with-monad %store-monad
       (match ref
         (((? derivation? drv) (? string? output))
@@ -232,7 +246,7 @@ and in the current monad setting (system type, etc.)"
          (package-file p
                        #:output output
                        #:system system
-                       #:target target))
+                       #:target (if native? #f target)))
         (((? origin? o) (? string? output))
          (mlet %store-monad ((drv (origin->derivation o)))
            (return (derivation->output-path drv output))))
@@ -242,17 +256,22 @@ and in the current monad setting (system type, etc.)"
          ;; that trick.
          (return `((@ (guile) getenv) ,output)))
         ((? gexp? exp)
-         (gexp->sexp exp #:system system #:target target))
+         (gexp->sexp exp
+                     #:system system
+                     #:target (if native? #f target)))
         (((? string? str))
          (return (if (direct-store-path? str) str ref)))
         ((refs ...)
-         (sequence %store-monad (map reference->sexp refs)))
+         (sequence %store-monad
+                   (map (cut reference->sexp <> native?) refs)))
         (x
          (return x)))))
 
   (mlet %store-monad
       ((args (sequence %store-monad
-                       (map reference->sexp (gexp-references exp)))))
+                       (append (map reference->sexp (gexp-references exp))
+                               (map (cut reference->sexp <> #t)
+                                    (gexp-native-references exp))))))
     (return (apply (gexp-proc exp) args))))
 
 (define (canonicalize-reference ref)
@@ -309,9 +328,28 @@ package/derivation references."
           (_
            result))))
 
+    (define (collect-native-escapes exp)
+      ;; Return all the 'ungexp-native' forms present in EXP.
+      (let loop ((exp    exp)
+                 (result '()))
+        (syntax-case exp (ungexp-native ungexp-native-splicing)
+          ((ungexp-native _)
+           (cons exp result))
+          ((ungexp-native _ _)
+           (cons exp result))
+          ((ungexp-native-splicing _ ...)
+           (cons exp result))
+          ((exp0 exp ...)
+           (let ((result (loop #'exp0 result)))
+             (fold loop result #'(exp ...))))
+          (_
+           result))))
+
     (define (escape->ref exp)
       ;; Turn 'ungexp' form EXP into a "reference".
-      (syntax-case exp (ungexp ungexp-splicing output)
+      (syntax-case exp (ungexp ungexp-splicing
+                        ungexp-native ungexp-native-splicing
+                        output)
         ((ungexp output)
          #'(output-ref "out"))
         ((ungexp output name)
@@ -321,30 +359,49 @@ package/derivation references."
         ((ungexp drv-or-pkg out)
          #'(list drv-or-pkg out))
         ((ungexp-splicing lst)
+         #'lst)
+        ((ungexp-native thing)
+         #'thing)
+        ((ungexp-native drv-or-pkg out)
+         #'(list drv-or-pkg out))
+        ((ungexp-native-splicing lst)
          #'lst)))
 
+    (define (substitute-ungexp exp substs)
+      ;; Given EXP, an 'ungexp' or 'ungexp-native' form, substitute it with
+      ;; the corresponding form in SUBSTS.
+      (match (assoc exp substs)
+        ((_ id)
+         id)
+        (_
+         #'(syntax-error "error: no 'ungexp' substitution"
+                         #'ref))))
+
+    (define (substitute-ungexp-splicing exp substs)
+      (syntax-case exp ()
+        ((exp rest ...)
+         (match (assoc #'exp substs)
+           ((_ id)
+            (with-syntax ((id id))
+              #`(append id
+                        #,(substitute-references #'(rest ...) substs))))
+           (_
+            #'(syntax-error "error: no 'ungexp-splicing' substitution"
+                            #'ref))))))
+
     (define (substitute-references exp substs)
       ;; Return a variant of EXP where all the cars of SUBSTS have been
       ;; replaced by the corresponding cdr.
-      (syntax-case exp (ungexp ungexp-splicing)
+      (syntax-case exp (ungexp ungexp-native
+                        ungexp-splicing ungexp-native-splicing)
         ((ungexp _ ...)
-         (match (assoc exp substs)
-           ((_ id)
-            id)
-           (_
-            #'(syntax-error "error: no 'ungexp' substitution"
-                            #'ref))))
+         (substitute-ungexp exp substs))
+        ((ungexp-native _ ...)
+         (substitute-ungexp exp substs))
         (((ungexp-splicing _ ...) rest ...)
-         (syntax-case exp ()
-           ((exp rest ...)
-            (match (assoc #'exp substs)
-              ((_ id)
-               (with-syntax ((id id))
-                 #`(append id
-                           #,(substitute-references #'(rest ...) substs))))
-              (_
-               #'(syntax-error "error: no 'ungexp-splicing' substitution"
-                               #'ref))))))
+         (substitute-ungexp-splicing exp substs))
+        (((ungexp-native-splicing _ ...) rest ...)
+         (substitute-ungexp-splicing exp substs))
         ((exp0 exp ...)
          #`(cons #,(substitute-references #'exp0 substs)
                  #,(substitute-references #'(exp ...) substs)))
@@ -352,11 +409,15 @@ package/derivation references."
 
     (syntax-case s (ungexp output)
       ((_ exp)
-       (let* ((escapes (delete-duplicates (collect-escapes #'exp)))
+       (let* ((normals (delete-duplicates (collect-escapes #'exp)))
+              (natives (delete-duplicates (collect-native-escapes #'exp)))
+              (escapes (append normals natives))
               (formals (generate-temporaries escapes))
               (sexp    (substitute-references #'exp (zip escapes formals)))
-              (refs    (map escape->ref escapes)))
+              (refs    (map escape->ref normals))
+              (nrefs   (map escape->ref natives)))
          #`(make-gexp (map canonicalize-reference (list #,@refs))
+                      (map canonicalize-reference (list #,@nrefs))
                       (lambda #,formals
                         #,sexp)))))))
 
@@ -409,22 +470,26 @@ its search path."
                          (write '(ungexp exp) port))))
                     #:local-build? #t))
 
-
 
 ;;;
 ;;; Syntactic sugar.
 ;;;
 
 (eval-when (expand load eval)
-  (define (read-ungexp chr port)
-    "Read an 'ungexp' or 'ungexp-splicing' form from PORT."
+  (define* (read-ungexp chr port #:optional native?)
+    "Read an 'ungexp' or 'ungexp-splicing' form from PORT.  When NATIVE? is
+true, use 'ungexp-native' and 'ungexp-native-splicing' instead."
     (define unquote-symbol
       (match (peek-char port)
         (#\@
          (read-char port)
-         'ungexp-splicing)
+         (if native?
+             'ungexp-native-splicing
+             'ungexp-splicing))
         (_
-         'ungexp)))
+         (if native?
+             'ungexp-native
+             'ungexp))))
 
     (match (read port)
       ((? symbol? symbol)
@@ -445,6 +510,7 @@ its search path."
 
   ;; Extend the reader
   (read-hash-extend #\~ read-gexp)
-  (read-hash-extend #\$ read-ungexp))
+  (read-hash-extend #\$ read-ungexp)
+  (read-hash-extend #\+ (cut read-ungexp <> <> #t)))
 
 ;;; gexp.scm ends here
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 9cc7d41547..694bd409bc 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -39,6 +39,7 @@
 
 ;; For white-box testing.
 (define gexp-inputs (@@ (guix gexp) gexp-inputs))
+(define gexp-native-inputs (@@ (guix gexp) gexp-native-inputs))
 (define gexp->sexp  (@@ (guix gexp) gexp->sexp))
 
 (define guile-for-build
@@ -47,10 +48,8 @@
 ;; Make it the default.
 (%guile-for-build guile-for-build)
 
-(define* (gexp->sexp* exp #:optional
-                      (system (%current-system)) target)
+(define* (gexp->sexp* exp #:optional target)
   (run-with-store %store (gexp->sexp exp
-                                     #:system system
                                      #:target target)
                   #:guile-for-build guile-for-build))
 
@@ -137,6 +136,29 @@
                (e3 `(display ,txt)))
            (equal? `(begin ,e0 ,e1 ,e2 ,e3) (gexp->sexp* exp))))))
 
+(test-assert "ungexp + ungexp-native"
+  (let* ((exp    (gexp (list (ungexp-native %bootstrap-guile)
+                             (ungexp coreutils)
+                             (ungexp-native glibc)
+                             (ungexp binutils))))
+         (target "mips64el-linux")
+         (guile  (derivation->output-path
+                  (package-derivation %store %bootstrap-guile)))
+         (cu     (derivation->output-path
+                  (package-cross-derivation %store coreutils target)))
+         (libc   (derivation->output-path
+                  (package-derivation %store glibc)))
+         (bu     (derivation->output-path
+                  (package-cross-derivation %store binutils target))))
+    (and (lset= equal?
+                `((,%bootstrap-guile "out") (,glibc "out"))
+                (gexp-native-inputs exp))
+         (lset= equal?
+                `((,coreutils "out") (,binutils "out"))
+                (gexp-inputs exp))
+         (equal? `(list ,guile ,cu ,libc ,bu)
+                 (gexp->sexp* exp target)))))
+
 (test-assert "input list"
   (let ((exp   (gexp (display
                       '(ungexp (list %bootstrap-guile coreutils)))))
@@ -150,6 +172,28 @@
          (equal? `(display '(,guile ,cu))
                  (gexp->sexp* exp)))))
 
+(test-assert "input list + ungexp-native"
+  (let* ((target "mips64el-linux")
+         (exp   (gexp (display
+                       (cons '(ungexp-native (list %bootstrap-guile coreutils))
+                             '(ungexp (list glibc binutils))))))
+         (guile (derivation->output-path
+                 (package-derivation %store %bootstrap-guile)))
+         (cu    (derivation->output-path
+                 (package-derivation %store coreutils)))
+         (xlibc (derivation->output-path
+                 (package-cross-derivation %store glibc target)))
+         (xbu   (derivation->output-path
+                 (package-cross-derivation %store binutils target))))
+    (and (lset= equal?
+                `((,%bootstrap-guile "out") (,coreutils "out"))
+                (gexp-native-inputs exp))
+         (lset= equal?
+                `((,glibc "out") (,binutils "out"))
+                (gexp-inputs exp))
+         (equal? `(display (cons '(,guile ,cu) '(,xlibc ,xbu)))
+                 (gexp->sexp* exp target)))))
+
 (test-assert "input list splicing"
   (let* ((inputs  (list (list glibc "debug") %bootstrap-guile))
          (outputs (list (derivation->output-path
@@ -164,6 +208,16 @@
          (equal? (gexp->sexp* exp)
                  `(list ,@(cons 5 outputs))))))
 
+(test-assert "input list splicing + ungexp-native-splicing"
+  (let* ((inputs (list (list glibc "debug") %bootstrap-guile))
+         (exp    (gexp (list (ungexp-native-splicing (cons (+ 2 3) inputs))))))
+    (and (lset= equal?
+                `((,glibc "debug") (,%bootstrap-guile "out"))
+                (gexp-native-inputs exp))
+         (null? (gexp-inputs exp))
+         (equal? (gexp->sexp* exp)                ;native
+                 (gexp->sexp* exp "mips64el-linux")))))
+
 (test-assertm "gexp->file"
   (mlet* %store-monad ((exp -> (gexp (display (ungexp %bootstrap-guile))))
                        (guile  (package-file %bootstrap-guile))
@@ -240,6 +294,41 @@
     (return (and (member (derivation-file-name xcu) refs)
                  (not (member (derivation-file-name cu) refs))))))
 
+(test-assertm "gexp->derivation, ungexp-native"
+  (mlet* %store-monad ((target -> "mips64el-linux")
+                       (exp    -> (gexp (list (ungexp-native coreutils)
+                                              (ungexp output))))
+                       (xdrv      (gexp->derivation "foo" exp
+                                                    #:target target))
+                       (drv       (gexp->derivation "foo" exp)))
+    (return (string=? (derivation-file-name drv)
+                      (derivation-file-name xdrv)))))
+
+(test-assertm "gexp->derivation, ungexp + ungexp-native"
+  (mlet* %store-monad ((target -> "mips64el-linux")
+                       (exp    -> (gexp (list (ungexp-native coreutils)
+                                              (ungexp glibc)
+                                              (ungexp output))))
+                       (xdrv      (gexp->derivation "foo" exp
+                                                    #:target target))
+                       (refs      ((store-lift references)
+                                   (derivation-file-name xdrv)))
+                       (xglibc    (package->cross-derivation glibc target))
+                       (cu        (package->derivation coreutils)))
+    (return (and (member (derivation-file-name cu) refs)
+                 (member (derivation-file-name xglibc) refs)))))
+
+(test-assertm "gexp->derivation, ungexp-native + composed gexps"
+  (mlet* %store-monad ((target -> "mips64el-linux")
+                       (exp0   -> (gexp (list 1 2
+                                              (ungexp coreutils))))
+                       (exp    -> (gexp (list 0 (ungexp-native exp0))))
+                       (xdrv      (gexp->derivation "foo" exp
+                                                    #:target target))
+                       (drv       (gexp->derivation "foo" exp)))
+    (return (string=? (derivation-file-name drv)
+                      (derivation-file-name xdrv)))))
+
 (define shebang
   (string-append "#!" (derivation->output-path guile-for-build)
                  "/bin/guile --no-auto-compile"))
@@ -285,8 +374,12 @@
 (test-equal "sugar"
   '(gexp (foo (ungexp bar) (ungexp baz "out")
               (ungexp (chbouib 42))
-              (ungexp-splicing (list x y z))))
-  '#~(foo #$bar #$baz:out #$(chbouib 42) #$@(list x y z)))
+              (ungexp-splicing (list x y z))
+              (ungexp-native foo) (ungexp-native foo "out")
+              (ungexp-native (chbouib 42))
+              (ungexp-native-splicing (list x y z))))
+  '#~(foo #$bar #$baz:out #$(chbouib 42) #$@(list x y z)
+          #+foo #+foo:out #+(chbouib 42) #+@(list x y z)))
 
 (test-end "gexp")