Merge branch 'master' into core-updates

7 files changed, 93 insertions, 26 deletions

diff --git a/guix/build/asdf-build-system.scm b/guix/build/asdf-build-system.scm
index f3f4b49bcf..25dd031962 100644
--- a/guix/build/asdf-build-system.scm
+++ b/guix/build/asdf-build-system.scm
@@ -85,7 +85,8 @@ valid."
     ;; files before compiling.
     (for-each (lambda (file)
                 (let ((s (lstat file)))
-                  (unless (eq? (stat:type s) 'symlink)
+                  (unless (or (eq? (stat:type s) 'symlink)
+                              (not (access? file W_OK)))
                     (utime file 0 0 0 0))))
               (find-files source #:directories? #t))
     (copy-recursively source target #:keep-mtime? #t)
@@ -97,12 +98,53 @@ valid."
      (find-files target "\\.asd$"))
     #t))
 
-(define* (install #:key outputs #:allow-other-keys)
-  "Copy and symlink all the source files."
+(define* (install #:key inputs outputs #:allow-other-keys)
+  "Copy and symlink all the source files.
+The source files are taken from the corresponding compile package (e.g. SBCL)
+if it's present in the native-inputs."
   (define output (assoc-ref outputs "out"))
-  (copy-files-to-output output
-                        (package-name->name+version
-                         (strip-store-file-name output))))
+  (define package-name
+    (package-name->name+version
+     (strip-store-file-name output)))
+  (define (no-prefix pkgname)
+    (if (string-index pkgname #\-)
+        (string-drop pkgname (1+ (string-index pkgname #\-)))
+        pkgname))
+  (define parent
+    (match (assoc package-name inputs
+                  (lambda (key alist-car)
+                    (let* ((alt-key (no-prefix key))
+                           (alist-car (no-prefix alist-car)))
+                      (or (string=? alist-car key)
+                          (string=? alist-car alt-key)))))
+      (#f #f)
+      (p (cdr p))))
+  (define parent-name
+    (and parent
+         (package-name->name+version (strip-store-file-name parent))))
+  (define parent-source
+    (and parent
+         (string-append parent "/share/common-lisp/"
+                        (string-take parent-name
+                                     (string-index parent-name #\-))
+                        "-source")))
+
+  (define (first-subdirectory directory) ; From gnu-build-system.
+    "Return the file name of the first sub-directory of DIRECTORY."
+    (match (scandir directory
+                    (lambda (file)
+                      (and (not (member file '("." "..")))
+                           (file-is-directory? (string-append directory "/"
+                                                              file)))))
+      ((first . _) first)))
+  (define source-directory
+    (if (and parent-source
+             (file-exists? parent-source))
+        (string-append parent-source "/" (first-subdirectory parent-source))
+        "."))
+
+  (with-directory-excursion source-directory
+    (copy-files-to-output output package-name)))
 
 (define* (copy-source #:key outputs asd-system-name #:allow-other-keys)
   "Copy the source to the library output."
diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm
index 0721989589..95e8dd772a 100644
--- a/guix/build/cargo-build-system.scm
+++ b/guix/build/cargo-build-system.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2019 Ivan Petkov <ivanppetkov@gmail.com>
 ;;; Copyright © 2019, 2020 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -140,11 +141,14 @@ directory = '" port)
 
 (define* (build #:key
                 skip-build?
+                features
                 (cargo-build-flags '("--release"))
                 #:allow-other-keys)
   "Build a given Cargo package."
   (or skip-build?
-      (apply invoke `("cargo" "build" ,@cargo-build-flags))))
+      (apply invoke "cargo" "build"
+             "--features" (string-join features)
+             cargo-build-flags)))
 
 (define* (check #:key
                 tests?
@@ -152,10 +156,10 @@ directory = '" port)
                 #:allow-other-keys)
   "Run tests for a given Cargo package."
   (if tests?
-      (apply invoke `("cargo" "test" ,@cargo-test-flags))
+      (apply invoke "cargo" "test" cargo-test-flags)
       #t))
 
-(define* (install #:key inputs outputs skip-build? #:allow-other-keys)
+(define* (install #:key inputs outputs skip-build? features #:allow-other-keys)
   "Install a given Cargo package."
   (let* ((out (assoc-ref outputs "out")))
     (mkdir-p out)
@@ -168,7 +172,8 @@ directory = '" port)
     ;; otherwise cargo will raise an error.
     (or skip-build?
         (not (has-executable-target?))
-        (invoke "cargo" "install" "--path" "." "--root" out))))
+        (invoke "cargo" "install" "--path" "." "--root" out
+                "--features" (string-join features)))))
 
 (define %standard-phases
   (modify-phases gnu:%standard-phases
diff --git a/guix/build/compile.scm b/guix/build/compile.scm
index 63f24fa7d4..ea7e1d2d03 100644
--- a/guix/build/compile.scm
+++ b/guix/build/compile.scm
@@ -98,7 +98,8 @@
   (define (override-option option value lst)
     `(,option ,value ,@(strip-option option lst)))
 
-  (cond ((string-contains file "gnu/packages/")
+  (cond ((or (string-contains file "gnu/packages/")
+             (string-contains file "gnu/tests/"))
          ;; Level 0 is good enough but partial evaluation helps preserve the
          ;; "macro writer's bill of rights".
          (override-option #:partial-eval? #t
diff --git a/guix/build/go-build-system.scm b/guix/build/go-build-system.scm
index 0d15f978cd..b9cb2bfd7b 100644
--- a/guix/build/go-build-system.scm
+++ b/guix/build/go-build-system.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2017, 2019 Leo Famulari <leo@famulari.name>
 ;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;; Copyright © 2020 Jack Hill <jackhill@jackhill.us>
+;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -214,18 +215,18 @@ unpacking."
                 (_ #f))
               inputs))))
 
-(define* (build #:key import-path #:allow-other-keys)
+(define* (build #:key import-path build-flags #:allow-other-keys)
   "Build the package named by IMPORT-PATH."
   (with-throw-handler
     #t
     (lambda _
-      (invoke "go" "install"
+      (apply invoke "go" "install"
               "-v" ; print the name of packages as they are compiled
               "-x" ; print each command as it is invoked
               ;; Respectively, strip the symbol table and debug
               ;; information, and the DWARF symbol table.
               "-ldflags=-s -w"
-              import-path))
+              `(,@build-flags ,import-path)))
     (lambda (key . args)
       (display (string-append "Building '" import-path "' failed.\n"
                               "Here are the results of `go env`:\n"))
diff --git a/guix/build/linux-module-build-system.scm b/guix/build/linux-module-build-system.scm
index 73d6b101f6..d51d76f94b 100644
--- a/guix/build/linux-module-build-system.scm
+++ b/guix/build/linux-module-build-system.scm
@@ -58,12 +58,13 @@
 
 ;; This block was copied from make-linux-libre--only took the "modules_install"
 ;; part.
-(define* (install #:key inputs native-inputs outputs #:allow-other-keys)
+(define* (install #:key make-flags inputs native-inputs outputs
+                  #:allow-other-keys)
   (let* ((out (assoc-ref outputs "out"))
          (moddir (string-append out "/lib/modules")))
     ;; Install kernel modules
     (mkdir-p moddir)
-    (invoke "make" "-C"
+    (apply invoke "make" "-C"
             (string-append (assoc-ref inputs "linux-module-builder")
                            "/lib/modules/build")
             (string-append "M=" (getcwd))
@@ -76,7 +77,8 @@
             (string-append "INSTALL_PATH=" out)
             (string-append "INSTALL_MOD_PATH=" out)
             "INSTALL_MOD_STRIP=1"
-            "modules_install")))
+            "modules_install"
+            (or make-flags '()))))
 
 (define %standard-phases
   (modify-phases gnu:%standard-phases
@@ -84,7 +86,8 @@
     (replace 'build build)
     (replace 'install install)))
 
-(define* (linux-module-build #:key inputs (phases %standard-phases)
+(define* (linux-module-build #:key inputs
+                             (phases %standard-phases)
                              #:allow-other-keys #:rest args)
   "Build the given package, applying all of PHASES in order, with a Linux
 kernel in attendance."
diff --git a/guix/build/minify-build-system.scm b/guix/build/minify-build-system.scm
index 563def88e9..92158a033f 100644
--- a/guix/build/minify-build-system.scm
+++ b/guix/build/minify-build-system.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -54,8 +55,12 @@
   (let* ((out (assoc-ref outputs "out"))
          (js  (string-append out "/share/javascript/")))
     (mkdir-p js)
-    (for-each (cut install-file <> js)
-              (find-files "guix/build" "\\.min\\.js$")))
+    (for-each
+      (lambda (file)
+        (if (not (zero? (stat:size (stat file))))
+          (install-file file js)
+          (error "File is empty: " file)))
+      (find-files "guix/build" "\\.min\\.js$")))
   #t)
 
 (define %standard-phases
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 8070c5546f..85c1c45f81 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -1218,7 +1218,7 @@ handler if the lock is already held by another process."
   ;; zero.
   16)
 
-(define (set-thread-name name)
+(define (set-thread-name!/linux name)
   "Set the name of the calling thread to NAME.  NAME is truncated to 15
 bytes."
   (let ((ptr (string->pointer name)))
@@ -1231,7 +1231,7 @@ bytes."
                (list (strerror err))
                (list err))))))
 
-(define (thread-name)
+(define (thread-name/linux)
   "Return the name of the calling thread as a string."
   (let ((buf (make-bytevector %max-thread-name-length)))
     (let-values (((ret err)
@@ -1245,6 +1245,16 @@ bytes."
                  (list (strerror err))
                  (list err))))))
 
+(define set-thread-name
+  (if (string-contains %host-type "linux")
+      set-thread-name!/linux
+      (const #f)))
+
+(define thread-name
+  (if (string-contains %host-type "linux")
+      thread-name/linux
+      (const "")))
+
 
 ;;;
 ;;; Network interfaces.
@@ -1404,7 +1414,7 @@ bytevector BV at INDEX."
            (error "unsupported socket address" sockaddr)))))
 
 (define write-socket-address!
-  (if (string-suffix? "linux-gnu" %host-type)
+  (if (string-contains %host-type "linux-gnu")
       write-socket-address!/linux
       write-socket-address!/hurd))
 
@@ -1436,7 +1446,7 @@ bytevector BV at INDEX."
            (vector family)))))
 
 (define read-socket-address
-  (if (string-suffix? "linux-gnu" %host-type)
+  (if (string-contains %host-type "linux-gnu")
       read-socket-address/linux
       read-socket-address/hurd))
 
@@ -2052,8 +2062,8 @@ correspond to a terminal, return the value returned by FALL-BACK."
         ;; would return EINVAL instead in some cases:
         ;; <https://bugs.ruby-lang.org/issues/10494>.
         ;; Furthermore, some FUSE file systems like unionfs return ENOSYS for
-        ;; that ioctl.
-        (if (memv errno (list ENOTTY EINVAL ENOSYS))
+        ;; that ioctl, and bcachefs returns EPERM.
+        (if (memv errno (list ENOTTY EINVAL ENOSYS EPERM))
             (fall-back)
             (apply throw args))))))