Merge branch 'master' into staging

8 files changed, 327 insertions, 19 deletions

diff --git a/guix/build/cmake-build-system.scm b/guix/build/cmake-build-system.scm
index 9b1112f2d6..d1ff5071be 100644
--- a/guix/build/cmake-build-system.scm
+++ b/guix/build/cmake-build-system.scm
@@ -67,6 +67,8 @@
                   ,@(if target
                         (list (string-append "-DCMAKE_C_COMPILER="
                                              target "-gcc")
+                              (string-append "-DCMAKE_CXX_COMPILER="
+                                             target "-g++")
                               (if (string-contains target "mingw")
                                   "-DCMAKE_SYSTEM_NAME=Windows"
                                   "-DCMAKE_SYSTEM_NAME=Linux"))
diff --git a/guix/build/compile.scm b/guix/build/compile.scm
index c4dbb6e34c..63f24fa7d4 100644
--- a/guix/build/compile.scm
+++ b/guix/build/compile.scm
@@ -84,9 +84,32 @@
 
 (define (optimization-options file)
   "Return the default set of optimizations options for FILE."
-  (if (string-contains file "gnu/packages/")
-      (optimizations-for-level 1)                 ;build faster
-      (optimizations-for-level 3)))
+  (define (strip-option option lst)
+    (let loop ((lst lst)
+               (result '()))
+      (match lst
+        (()
+         (reverse result))
+        ((kw value rest ...)
+         (if (eq? kw option)
+             (append (reverse result) rest)
+             (loop rest (cons* value kw result)))))))
+
+  (define (override-option option value lst)
+    `(,option ,value ,@(strip-option option lst)))
+
+  (cond ((string-contains file "gnu/packages/")
+         ;; Level 0 is good enough but partial evaluation helps preserve the
+         ;; "macro writer's bill of rights".
+         (override-option #:partial-eval? #t
+                          (optimizations-for-level 0)))
+        ((string-contains file "gnu/services/")
+         ;; '-O2 -Ono-letrectify' compiles about ~20% faster than '-O2' for
+         ;; large files like gnu/services/mail.scm.
+         (override-option #:letrectify? #f
+                          (optimizations-for-level 2)))
+        (else
+         (optimizations-for-level 3))))
 
 (define (scm->go file)
   "Strip the \".scm\" suffix from FILE, and append \".go\"."
diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm
index 219310cf08..26ea59bc25 100644
--- a/guix/build/emacs-build-system.scm
+++ b/guix/build/emacs-build-system.scm
@@ -21,7 +21,7 @@
 
 (define-module (guix build emacs-build-system)
   #:use-module ((guix build gnu-build-system) #:prefix gnu:)
-  #:use-module (guix build utils)
+  #:use-module ((guix build utils) #:hide (delete))
   #:use-module (guix build emacs-utils)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
diff --git a/guix/build/gnu-bootstrap.scm b/guix/build/gnu-bootstrap.scm
new file mode 100644
index 0000000000..1cb9dc5512
--- /dev/null
+++ b/guix/build/gnu-bootstrap.scm
@@ -0,0 +1,114 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2020 Timothy Sample <samplet@ngyro.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+;; Commentary:
+;;
+;; These procedures can be used to adapt the GNU Build System to build
+;; pure Scheme packages targeting the bootstrap Guile.
+;;
+;; Code:
+
+(define-module (guix build gnu-bootstrap)
+  #:use-module (guix build utils)
+  #:use-module (system base compile)
+  #:export (bootstrap-configure
+            bootstrap-build
+            bootstrap-install))
+
+(define (bootstrap-configure version modules scripts)
+  "Create a procedure that configures an early bootstrap package.  The
+procedure will search the MODULES directory and configure all of the
+'.in' files with VERSION.  It will then search the SCRIPTS directory and
+configure all of the '.in' files with the bootstrap Guile and its module
+and object directories."
+  (lambda* (#:key inputs outputs #:allow-other-keys)
+    (let* ((out (assoc-ref outputs "out"))
+           (guile-dir (assoc-ref inputs "guile"))
+           (guile (string-append guile-dir "/bin/guile"))
+           (moddir (string-append out "/share/guile/site/"
+                                  (effective-version)))
+           (godir (string-append out "/lib/guile/"
+                                 (effective-version)
+                                 "/site-ccache")))
+      (for-each (lambda (template)
+                  (format #t "Configuring ~a~%" template)
+                  (let ((target (string-drop-right template 3)))
+                    (copy-file template target)
+                    (substitute* target
+                      (("@VERSION@") version))))
+                (find-files modules
+                            (lambda (fn st)
+                              (string-suffix? ".in" fn))))
+      (for-each (lambda (template)
+                  (format #t "Configuring ~a~%" template)
+                  (let ((target (string-drop-right template 3)))
+                    (copy-file template target)
+                    (substitute* target
+                      (("@GUILE@") guile)
+                      (("@MODDIR@") moddir)
+                      (("@GODIR@") godir))
+                    (chmod target #o755)))
+                (find-files scripts
+                            (lambda (fn st)
+                              (string-suffix? ".in" fn))))
+      #t)))
+
+(define (bootstrap-build modules)
+  "Create a procedure that builds an early bootstrap package.  The
+procedure will search the MODULES directory and compile all of the
+'.scm' files."
+  (lambda _
+    (add-to-load-path (getcwd))
+    (for-each (lambda (scm)
+                (let* ((base (string-drop-right scm 4))
+                       (go (string-append base ".go"))
+                       (dir (dirname scm)))
+                  (format #t "Compiling ~a~%" scm)
+                  (compile-file scm #:output-file go)))
+              (find-files modules "\\.scm$"))
+    #t))
+
+(define (bootstrap-install modules scripts)
+  "Create a procedure that installs an early bootstrap package.  The
+procedure will install all of the '.scm' and '.go' files in the MODULES
+directory, and all the executable files in the SCRIPTS directory."
+  (lambda* (#:key inputs outputs #:allow-other-keys)
+    (let* ((out (assoc-ref outputs "out"))
+           (guile-dir (assoc-ref inputs "guile"))
+           (guile (string-append guile-dir "/bin/guile"))
+           (moddir (string-append out "/share/guile/site/"
+                                  (effective-version)))
+           (godir (string-append out "/lib/guile/"
+                                 (effective-version)
+                                 "/site-ccache")))
+      (for-each (lambda (scm)
+                  (let* ((base (string-drop-right scm 4))
+                         (go (string-append base ".go"))
+                         (dir (dirname scm)))
+                    (format #t "Installing ~a~%" scm)
+                    (install-file scm (string-append moddir "/" dir))
+                    (format #t "Installing ~a~%" go)
+                    (install-file go (string-append godir "/" dir))))
+                (find-files modules "\\.scm$"))
+      (for-each (lambda (script)
+                  (format #t "Installing ~a~%" script)
+                  (install-file script (string-append out "/bin")))
+                (find-files scripts
+                            (lambda (fn st)
+                              (executable-file? fn))))
+      #t)))
diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm
index 4df0bb4904..2e7dff2034 100644
--- a/guix/build/gnu-build-system.scm
+++ b/guix/build/gnu-build-system.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2020 Brendan Tildesley <mail@brendan.scot>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -173,12 +174,16 @@ working directory."
 \"autoreconf\".  Otherwise do nothing."
   ;; Note: Run that right after 'unpack' so that the generated files are
   ;; visible when the 'patch-source-shebangs' phase runs.
-  (if (not (file-exists? "configure"))
+  (define (script-exists? file)
+    (and (file-exists? file)
+         (not (file-is-directory? file))))
+
+  (if (not (script-exists? "configure"))
 
       ;; First try one of the BOOTSTRAP-SCRIPTS.  If none exists, and it's
       ;; clearly an Autoconf-based project, run 'autoreconf'.  Otherwise, do
       ;; nothing (perhaps the user removed or overrode the 'configure' phase.)
-      (let ((script (find file-exists? bootstrap-scripts)))
+      (let ((script (find script-exists? bootstrap-scripts)))
         ;; GNU packages often invoke the 'git-version-gen' script from
         ;; 'configure.ac' so make sure it has a valid shebang.
         (false-if-file-not-found
@@ -186,12 +191,15 @@ working directory."
 
         (if script
             (let ((script (string-append "./" script)))
+              (setenv "NOCONFIGURE" "true")
               (format #t "running '~a'~%" script)
               (if (executable-file? script)
                   (begin
                     (patch-shebang script)
                     (invoke script))
-                  (invoke "sh" script)))
+                  (invoke "sh" script))
+              ;; Let's clean up after ourselves.
+              (unsetenv "NOCONFIGURE"))
             (if (or (file-exists? "configure.ac")
                     (file-exists? "configure.in"))
                 (invoke "autoreconf" "-vif")
diff --git a/guix/build/store-copy.scm b/guix/build/store-copy.scm
index 549aa4f28b..ad551bca98 100644
--- a/guix/build/store-copy.scm
+++ b/guix/build/store-copy.scm
@@ -35,6 +35,7 @@
 
             read-reference-graph
 
+            file-size
             closure-size
             populate-store))
 
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 73b439fb7d..ff008c5b78 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -5,6 +5,7 @@
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2019 Guillaume Le Vaillant <glv@posteo.net>
 ;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu>
+;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -23,6 +24,7 @@
 
 (define-module (guix build syscalls)
   #:use-module (system foreign)
+  #:use-module (system base target)
   #:use-module (rnrs bytevectors)
   #:autoload   (ice-9 binary-ports) (get-bytevector-n)
   #:use-module (srfi srfi-1)
@@ -77,6 +79,8 @@
             fdatasync
             pivot-root
             scandir*
+            getxattr
+            setxattr
 
             fcntl-flock
             lock-file
@@ -194,9 +198,14 @@
      (* (sizeof* type) n))
     ((_ type)
      (let-syntax ((v (lambda (s)
-                       (let ((val (sizeof type)))
-                         (syntax-case s ()
-                           (_ val))))))
+                       ;; When compiling natively, call 'sizeof' at expansion
+                       ;; time; otherwise, emit code to call it at run time.
+                       (syntax-case s ()
+                         (_
+                          (if (= (target-word-size)
+                                 (with-target %host-type target-word-size))
+                              (sizeof type)
+                              #'(sizeof type)))))))
        v))))
 
 (define-syntax alignof*
@@ -208,9 +217,14 @@
      (alignof* type))
     ((_ type)
      (let-syntax ((v (lambda (s)
-                       (let ((val (alignof type)))
-                         (syntax-case s ()
-                           (_ val))))))
+                       ;; When compiling natively, call 'sizeof' at expansion
+                       ;; time; otherwise, emit code to call it at run time.
+                       (syntax-case s ()
+                         (_
+                          (if (= (target-word-size)
+                                 (with-target %host-type target-word-size))
+                              (alignof type)
+                              #'(alignof type)))))))
        v))))
 
 (define-syntax align                             ;as found in (system foreign)
@@ -711,6 +725,49 @@ backend device."
              (list (strerror err))
              (list err))))))
 
+(define getxattr
+  (let ((proc (syscall->procedure ssize_t "getxattr"
+                                  `(* * * ,size_t))))
+    (lambda (file key)
+      "Get the extended attribute value for KEY on FILE."
+      (let-values (((size err)
+                    ;; Get size of VALUE for buffer.
+                    (proc (string->pointer/utf-8 file)
+                          (string->pointer key)
+                          (string->pointer "")
+                          0)))
+        (cond ((< size 0) #f)
+              ((zero? size) "")
+              ;; Get VALUE in buffer of SIZE.  XXX actual size can race.
+              (else (let*-values (((buf) (make-bytevector size))
+                                  ((size err)
+                                   (proc (string->pointer/utf-8 file)
+                                         (string->pointer key)
+                                         (bytevector->pointer buf)
+                                         size)))
+                      (if (>= size 0)
+                          (utf8->string buf)
+                          (throw 'system-error "getxattr" "~S: ~A"
+                                 (list file key (strerror err))
+                                 (list err))))))))))
+
+(define setxattr
+  (let ((proc (syscall->procedure int "setxattr"
+                                  `(* * * ,size_t ,int))))
+    (lambda* (file key value #:optional (flags 0))
+      "Set extended attribute KEY to VALUE on FILE."
+      (let*-values (((bv) (string->utf8 value))
+                    ((ret err)
+                     (proc (string->pointer/utf-8 file)
+                           (string->pointer key)
+                           (bytevector->pointer bv)
+                           (bytevector-length bv)
+                           flags)))
+        (unless (zero? ret)
+          (throw 'system-error "setxattr" "~S: ~A"
+                 (list file key value (strerror err))
+                 (list err)))))))
+
 
 ;;;
 ;;; Random.
@@ -1194,6 +1251,8 @@ bytes."
 ;;;
 
 (define SIOCGIFCONF                               ;from <bits/ioctls.h>
+                                                  ;     <net/if.h>
+                                                  ;     <hurd/ioctl.h>
   (if (string-contains %host-type "linux")
       #x8912                                      ;GNU/Linux
       #xf00801a4))                                ;GNU/Hurd
@@ -1204,23 +1263,23 @@ bytes."
 (define SIOCSIFFLAGS
   (if (string-contains %host-type "linux")
       #x8914                                      ;GNU/Linux
-      -1))                                        ;FIXME: GNU/Hurd?
+      #x84804190))                                ;GNU/Hurd
 (define SIOCGIFADDR
   (if (string-contains %host-type "linux")
       #x8915                                      ;GNU/Linux
-      -1))                                        ;FIXME: GNU/Hurd?
+      #xc08401a1))                                ;GNU/Hurd
 (define SIOCSIFADDR
   (if (string-contains %host-type "linux")
       #x8916                                      ;GNU/Linux
-      -1))                                        ;FIXME: GNU/Hurd?
+      #x8084018c))                                ;GNU/Hurd
 (define SIOCGIFNETMASK
   (if (string-contains %host-type "linux")
       #x891b                                      ;GNU/Linux
-      -1))                                        ;FIXME: GNU/Hurd?
+      #xc08401a5))                                ;GNU/Hurd
 (define SIOCSIFNETMASK
   (if (string-contains %host-type "linux")
       #x891c                                      ;GNU/Linux
-      -1))                                        ;FIXME: GNU/Hurd?
+      #x80840196))                                ;GNU/Hurd
 (define SIOCADDRT
   (if (string-contains %host-type "linux")
       #x890B                                      ;GNU/Linux
diff --git a/guix/build/utils.scm b/guix/build/utils.scm
index b8be73ead4..419c10195b 100644
--- a/guix/build/utils.scm
+++ b/guix/build/utils.scm
@@ -108,6 +108,8 @@
 
             invoke/quiet
 
+            make-desktop-entry-file
+
             locale-category->string))
 
 
@@ -892,7 +894,7 @@ transferred and the continuation of the transfer as a thunk."
     (x x)))
 
 (define patch-shebang
-  (let ((shebang-rx (make-regexp "^[[:blank:]]*([[:graph:]]+)[[:blank:]]*([[:graph:]]*)(.*)$")))
+  (let ((shebang-rx (make-regexp "^[[:blank:]]*(/[[:graph:]]+)[[:blank:]]*([[:graph:]]*)(.*)$")))
     (lambda* (file
               #:optional
               (path (search-path-as-string->list (getenv "PATH")))
@@ -1324,6 +1326,105 @@ not supported."
                     (&wrap-error (program prog)
                                  (type 'no-interpreter-found)))))))))
 
+(define* (make-desktop-entry-file destination #:key
+                                  (type "Application") ; One of "Application", "Link" or "Directory".
+                                  (version "1.1")
+                                  name
+                                  (generic-name name)
+                                  (no-display #f)
+                                  comment
+                                  icon
+                                  (hidden #f)
+                                  only-show-in
+                                  not-show-in
+                                  (d-bus-activatable #f)
+                                  try-exec
+                                  exec
+                                  path
+                                  (terminal #f)
+                                  actions
+                                  mime-type
+                                  (categories "Application")
+                                  implements
+                                  keywords
+                                  (startup-notify #t)
+                                  startup-w-m-class
+                                  #:rest all-args)
+  "Create a desktop entry file at DESTINATION.
+You must specify NAME.
+
+Values can be booleans, numbers, strings or list of strings.
+
+Additionally, locales can be specified with an alist where the key is the
+locale.  The #f key specifies the default.  Example:
+
+  #:name '((#f \"I love Guix\") (\"fr\" \"J'aime Guix\"))
+
+produces
+
+  Name=I love Guix
+  Name[fr]=J'aime Guix
+
+For a complete description of the format, see the specifications at
+https://specifications.freedesktop.org/desktop-entry-spec/desktop-entry-spec-latest.html."
+  (define (escape-semicolon s)
+    (string-join (string-split s #\;) "\\;"))
+  (define* (parse key value #:optional locale)
+    (set! value (match value
+                  (#t "true")
+                  (#f "false")
+                  ((?  number? n) n)
+                  ((?  string? s) (escape-semicolon s))
+                  ((?  list? value)
+                   (catch 'wrong-type-arg
+                     (lambda () (string-join (map escape-semicolon value) ";"))
+                     (lambda args (error "List arguments can only contain strings: ~a" args))))
+                  (_ (error "Value must be a boolean, number, string or list of strings"))))
+    (format #t "~a=~a~%"
+            (if locale
+                (format #f "~a[~a]" key locale)
+                key)
+            value))
+
+  (define key-error-message "This procedure only takes key arguments beside DESTINATION")
+
+  (unless name
+    (error "Missing NAME key argument"))
+  (unless (member #:type all-args)
+    (set! all-args (append (list #:type type) all-args)))
+  (mkdir-p (dirname destination))
+
+  (with-output-to-file destination
+    (lambda ()
+      (format #t "[Desktop Entry]~%")
+      (let loop ((args all-args))
+        (match args
+          (() #t)
+          ((_) (error key-error-message))
+          ((key value . ...)
+           (unless (keyword? key)
+             (error key-error-message))
+           (set! key
+                 (string-join (map string-titlecase
+                                   (string-split (symbol->string
+                                                  (keyword->symbol key))
+                                                 #\-))
+                              ""))
+           (match value
+             (((_ . _) . _)
+              (for-each (lambda (locale-subvalue)
+                          (parse key
+                                 (if (and (list? (cdr locale-subvalue))
+                                          (= 1 (length (cdr locale-subvalue))))
+                                     ;; Support both proper and improper lists for convenience.
+                                     (cadr locale-subvalue)
+                                     (cdr locale-subvalue))
+                                 (car locale-subvalue)))
+                        value))
+             (_
+              (parse key value)))
+           (loop (cddr args))))))))
+
 
 ;;;
 ;;; Locales.