Merge branch 'staging'

6 files changed, 170 insertions, 305 deletions

diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm
index 630b99e2bf..28403a1960 100644
--- a/guix/build-system/asdf.scm
+++ b/guix/build-system/asdf.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca>
-;;; Copyright © 2019 Guillaume Le Vaillant <glv@posteo.net>
+;;; Copyright © 2019, 2020 Guillaume Le Vaillant <glv@posteo.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -54,12 +54,14 @@
   ;; Imported build-side modules
   `((guix build asdf-build-system)
     (guix build lisp-utils)
+    (guix build union)
     ,@%gnu-build-system-modules))
 
 (define %asdf-build-modules
   ;; Used (visible) build-side modules
   '((guix build asdf-build-system)
     (guix build utils)
+    (guix build union)
     (guix build lisp-utils)))
 
 (define (default-lisp implementation)
@@ -210,7 +212,7 @@ set up using CL source package conventions."
       (define base-arguments
         (if target-is-source?
             (strip-keyword-arguments
-             '(#:tests? #:asd-file #:lisp #:asd-system-name #:test-asd-file)
+             '(#:tests? #:asd-files #:lisp #:asd-systems #:test-asd-file)
              (package-arguments pkg))
             (package-arguments pkg)))
 
@@ -278,8 +280,8 @@ set up using CL source package conventions."
   (lambda* (store name inputs
                   #:key source outputs
                   (tests? #t)
-                  (asd-file #f)
-                  (asd-system-name #f)
+                  (asd-files ''())
+                  (asd-systems ''())
                   (test-asd-file #f)
                   (phases '(@ (guix build asdf-build-system)
                               %standard-phases))
@@ -289,12 +291,17 @@ set up using CL source package conventions."
                   (imported-modules %asdf-build-system-modules)
                   (modules %asdf-build-modules))
 
-    (define system-name
-      (or asd-system-name
-          (string-drop
-           ;; NAME is the value returned from `package-full-name'.
-           (hyphen-separated-name->name+version name)
-           (1+ (string-length lisp-type))))) ; drop the "<lisp>-" prefix.
+    ;; FIXME: The definition of 'systems' is pretty hacky.
+    ;; Is there a more elegant way to do it?
+    (define systems
+      (if (null? (cadr asd-systems))
+          `(quote
+            ,(list
+              (string-drop
+               ;; NAME is the value returned from `package-full-name'.
+               (hyphen-separated-name->name+version name)
+               (1+ (string-length lisp-type))))) ; drop the "<lisp>-" prefix.
+          asd-systems))
 
     (define builder
       `(begin
@@ -309,8 +316,8 @@ set up using CL source package conventions."
                                     (derivation->output-path source))
                                    ((source) source)
                                    (source source))
-                       #:asd-file ,(or asd-file (string-append system-name ".asd"))
-                       #:asd-system-name ,system-name
+                       #:asd-files ,asd-files
+                       #:asd-systems ,systems
                        #:test-asd-file ,test-asd-file
                        #:system ,system
                        #:tests? ,tests?
diff --git a/guix/build-system/haskell.scm b/guix/build-system/haskell.scm
index 8304e3b222..18a584f782 100644
--- a/guix/build-system/haskell.scm
+++ b/guix/build-system/haskell.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
 ;;; Copyright © 2020 Timothy Sample <samplet@ngyro.com>
+;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -121,7 +122,9 @@ version REVISION."
                         (haddock-flags ''())
                         (tests? #t)
                         (test-target "test")
-                        (parallel-build? #t)
+                        ;; FIXME: Parallel builds lead to indeterministic
+                        ;; results, see <http://issues.guix.gnu.org/43843#3>.
+                        (parallel-build? #f)
                         (configure-flags ''())
                         (extra-directories ''())
                         (phases '(@ (guix build haskell-build-system)
diff --git a/guix/build/asdf-build-system.scm b/guix/build/asdf-build-system.scm
index 25dd031962..6ad855cab2 100644
--- a/guix/build/asdf-build-system.scm
+++ b/guix/build/asdf-build-system.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca>
+;;; Copyright © 2020 Guillaume Le Vaillant <glv@posteo.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -19,6 +20,7 @@
 (define-module (guix build asdf-build-system)
   #:use-module ((guix build gnu-build-system) #:prefix gnu:)
   #:use-module (guix build utils)
+  #:use-module (guix build union)
   #:use-module (guix build lisp-utils)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
@@ -41,14 +43,22 @@
 ;;
 ;; Code:
 
-(define %object-prefix "/lib")
+(define %object-prefix "/lib/common-lisp")
 
 (define (%lisp-source-install-prefix)
-  (string-append %source-install-prefix "/" (%lisp-type) "-source"))
+  (string-append %source-install-prefix "/" (%lisp-type)))
 
 (define %system-install-prefix
   (string-append %source-install-prefix "/systems"))
 
+(define (main-system-name output)
+  (let ((package-name (package-name->name+version
+                       (strip-store-file-name output)))
+        (lisp-prefix (string-append (%lisp-type) "-")))
+    (if (string-prefix? lisp-prefix package-name)
+        (string-drop package-name (string-length lisp-prefix))
+        package-name)))
+
 (define (lisp-source-directory output name)
   (string-append output (%lisp-source-install-prefix) "/" name))
 
@@ -71,6 +81,13 @@ to it's binary output."
 (define (source-asd-file output name asd-file)
   (string-append (lisp-source-directory output name) "/" asd-file))
 
+(define (find-asd-files output name asd-files)
+  (if (null? asd-files)
+      (find-files (lisp-source-directory output name) "\\.asd$")
+      (map (lambda (asd-file)
+             (source-asd-file output name asd-file))
+           asd-files)))
+
 (define (copy-files-to-output out name)
   "Copy all files from the current directory to OUT.  Create an extra link to
 any system-defining files in the source to a convenient location.  This is
@@ -107,9 +124,10 @@ if it's present in the native-inputs."
     (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))
+    (let ((index (string-index pkgname #\-)))
+      (if index
+          (string-drop pkgname (1+ index))
+          pkgname)))
   (define parent
     (match (assoc package-name inputs
                   (lambda (key alist-car)
@@ -125,9 +143,10 @@ if it's present in the native-inputs."
   (define parent-source
     (and parent
          (string-append parent "/share/common-lisp/"
-                        (string-take parent-name
-                                     (string-index parent-name #\-))
-                        "-source")))
+                        (let ((index (string-index parent-name #\-)))
+                          (if index
+                              (string-take parent-name index)
+                              parent-name)))))
 
   (define (first-subdirectory directory) ; From gnu-build-system.
     "Return the file name of the first sub-directory of DIRECTORY."
@@ -146,122 +165,83 @@ if it's present in the native-inputs."
   (with-directory-excursion source-directory
     (copy-files-to-output output package-name)))
 
-(define* (copy-source #:key outputs asd-system-name #:allow-other-keys)
+(define* (copy-source #:key outputs asd-systems #:allow-other-keys)
   "Copy the source to the library output."
   (let* ((out (library-output outputs))
-         (install-path (string-append out %source-install-prefix)))
-    (copy-files-to-output out asd-system-name)
+         (install-path (string-append out %source-install-prefix))
+         (system-name (main-system-name out)))
+    (copy-files-to-output out system-name)
     ;; Hide the files from asdf
     (with-directory-excursion install-path
-      (rename-file "source" (string-append (%lisp-type) "-source"))
+      (rename-file "source" (%lisp-type))
       (delete-file-recursively "systems")))
   #t)
 
-(define* (build #:key outputs inputs asd-file asd-system-name
+(define* (configure #:key inputs #:allow-other-keys)
+  ;; Create a directory having the configuration files for
+  ;; all the dependencies in 'etc/common-lisp/'.
+  (let ((out (string-append (getcwd) "/.cl-union")))
+    (match inputs
+      (((name . directories) ...)
+       (union-build out (filter directory-exists? directories)
+                    #:create-all-directories? #t
+                    #:log-port (%make-void-port "w"))))
+    (setenv "CL_UNION" out)
+    (setenv "XDG_CONFIG_DIRS" (string-append out "/etc")))
+  #t)
+
+(define* (build #:key outputs inputs asd-files asd-systems
                 #:allow-other-keys)
   "Compile the system."
   (let* ((out (library-output outputs))
-         (source-path (lisp-source-directory out asd-system-name))
+         (system-name (main-system-name out))
+         (source-path (string-append out (%lisp-source-install-prefix)))
          (translations (wrap-output-translations
                         `(,(output-translation source-path
                                                out))))
-         (asd-file (source-asd-file out asd-system-name asd-file)))
-
+         (asd-files (find-asd-files out system-name asd-files)))
     (setenv "ASDF_OUTPUT_TRANSLATIONS"
             (replace-escaped-macros (format #f "~S" translations)))
-
     (setenv "HOME" out) ; ecl's asdf sometimes wants to create $HOME/.cache
-
-    (compile-system asd-system-name asd-file)
-
-    ;; As above, ecl will sometimes create this even though it doesn't use it
-
-    (let ((cache-directory (string-append out "/.cache")))
-      (when (directory-exists? cache-directory)
-        (delete-file-recursively cache-directory))))
+    (compile-systems asd-systems asd-files))
   #t)
 
-(define* (check #:key tests? outputs inputs asd-file asd-system-name
+(define* (check #:key tests? outputs inputs asd-files asd-systems
                 test-asd-file
                 #:allow-other-keys)
   "Test the system."
   (let* ((out (library-output outputs))
-         (asd-file (source-asd-file out asd-system-name asd-file))
+         (system-name (main-system-name out))
+         (asd-files (find-asd-files out system-name asd-files))
          (test-asd-file
           (and=> test-asd-file
-                 (cut source-asd-file out asd-system-name <>))))
+                 (cut source-asd-file out system-name <>))))
     (if tests?
-        (test-system asd-system-name asd-file test-asd-file)
+        (test-system (first asd-systems) asd-files test-asd-file)
         (format #t "test suite not run~%")))
   #t)
 
-(define* (create-asd-file #:key outputs
-                          inputs
-                          asd-file
-                          asd-system-name
-                          #:allow-other-keys)
-  "Create a system definition file for the built system."
-  (let*-values (((out) (library-output outputs))
-                ((_ version) (package-name->name+version
-                              (strip-store-file-name out)))
-                ((new-asd-file) (string-append
-                                 (library-directory out)
-                                 "/" (normalize-string asd-system-name)
-                                 ".asd")))
-
-    (make-asd-file new-asd-file
-                   #:system asd-system-name
-                   #:version version
-                   #:inputs inputs
-                   #:system-asd-file asd-file))
-  #t)
-
-(define* (symlink-asd-files #:key outputs #:allow-other-keys)
-  "Create an extra reference to the system in a convenient location."
-  (let* ((out (library-output outputs)))
-    (for-each
-     (lambda (asd-file)
-       (receive (new-asd-file asd-file-directory)
-           (bundle-asd-file out asd-file)
-         (mkdir-p asd-file-directory)
-         (symlink asd-file new-asd-file)
-         ;; Update the source registry for future phases which might want to
-         ;; use the newly compiled system.
-         (prepend-to-source-registry
-          (string-append asd-file-directory "/"))))
-
-     (find-files (string-append out %object-prefix) "\\.asd$")))
-  #t)
+(define* (create-asdf-configuration #:key inputs outputs #:allow-other-keys)
+  "Create the ASDF configuration files for the built systems."
+  (let* ((system-name (main-system-name (assoc-ref outputs "out")))
+         (out (library-output outputs))
+         (conf-dir (string-append out "/etc/common-lisp"))
+         (deps-conf-dir (string-append (getenv "CL_UNION") "/etc/common-lisp"))
+         (source-dir (lisp-source-directory out system-name))
+         (lib-dir (string-append (library-directory out) "/" system-name)))
+    (make-asdf-configuration system-name conf-dir deps-conf-dir
+                             source-dir lib-dir)
+    #t))
 
 (define* (cleanup-files #:key outputs
                         #:allow-other-keys)
   "Remove any compiled files which are not a part of the final bundle."
-  (let ((out (library-output outputs)))
-    (match (%lisp-type)
-      ("sbcl"
-       (for-each
-        (lambda (file)
-          (unless (string-suffix? "--system.fasl" file)
-            (delete-file file)))
-        (find-files out "\\.fasl$")))
-      ("ecl"
-       (for-each delete-file
-                 (append (find-files out "\\.fas$")
-                         (find-files out "\\.o$")))))
-
-    (with-directory-excursion (library-directory out)
-      (for-each
-       (lambda (file)
-         (rename-file file
-                      (string-append "./" (basename file))))
-       (find-files "."))
-      (for-each delete-file-recursively
-                (scandir "."
-                         (lambda (file)
-                           (and
-                            (directory-exists? file)
-                            (string<> "." file)
-                            (string<> ".." file)))))))
+  (let* ((out (library-output outputs))
+         (cache-directory (string-append out "/.cache")))
+    ;; Remove the cache directory in case the lisp implementation wrote
+    ;; something in there when compiling or testing a system.
+    (when (directory-exists? cache-directory)
+      (delete-file-recursively cache-directory)))
   #t)
 
 (define* (strip #:rest args)
@@ -280,15 +260,14 @@ if it's present in the native-inputs."
 (define %standard-phases
   (modify-phases gnu:%standard-phases
     (delete 'bootstrap)
-    (delete 'configure)
-    (delete 'install)
+    (replace 'configure configure)
+    (add-before 'configure 'copy-source copy-source)
     (replace 'build build)
-    (add-before 'build 'copy-source copy-source)
     (replace 'check check)
-    (replace 'strip strip)
-    (add-after 'check 'create-asd-file create-asd-file)
-    (add-after 'create-asd-file 'cleanup cleanup-files)
-    (add-after 'cleanup 'create-symlinks symlink-asd-files)))
+    (add-after 'check 'create-asdf-configuration create-asdf-configuration)
+    (add-after 'create-asdf-configuration 'cleanup cleanup-files)
+    (delete 'install)
+    (replace 'strip strip)))
 
 (define* (asdf-build #:key inputs
                      (phases %standard-phases)
diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm
index a638d0eded..c7beffc6e4 100644
--- a/guix/build/cargo-build-system.scm
+++ b/guix/build/cargo-build-system.scm
@@ -4,6 +4,7 @@
 ;;; 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>
+;;; Copyright © 2020 Marius Bakke <marius@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -148,14 +149,17 @@ directory = '" port)
 
 (define* (build #:key
                 skip-build?
-                features
+                (features '())
                 (cargo-build-flags '("--release"))
                 #:allow-other-keys)
   "Build a given Cargo package."
   (or skip-build?
-      (apply invoke "cargo" "build"
-             "--features" (string-join features)
-             cargo-build-flags)))
+      (apply invoke
+             `("cargo" "build"
+               ,@(if (null? features)
+                     '()
+                     `("--features" ,(string-join features)))
+               ,@cargo-build-flags))))
 
 (define* (check #:key
                 tests?
diff --git a/guix/build/cargo-utils.scm b/guix/build/cargo-utils.scm
index 5ac429a62a..7a3bb4b843 100644
--- a/guix/build/cargo-utils.scm
+++ b/guix/build/cargo-utils.scm
@@ -2,7 +2,7 @@
 ;;; Copyright © 2016 David Craven <david@craven.ch>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2019 Ivan Petkov <ivanppetkov@gmail.com>
-;;; Copyright © 2019 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2019, 2020 Efraim Flashner <efraim@flashner.co.il>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -23,6 +23,7 @@
   #:use-module (guix build utils)
   #:use-module (ice-9 popen)
   #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 threads)
   #:export (generate-checksums
             generate-all-checksums))
 
@@ -70,7 +71,7 @@ the same directory."
         (display "}" port)))))
 
 (define (generate-all-checksums dir-name)
-  (for-each
+  (n-par-for-each (parallel-job-count)
     (lambda (filename)
       (let* ((dir (dirname filename))
              (checksum-file (string-append dir "/.cargo-checksum.json")))
diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm
index f6d9168c48..8a02cb68dd 100644
--- a/guix/build/lisp-utils.scm
+++ b/guix/build/lisp-utils.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca>
+;;; Copyright © 2020 Guillaume Le Vaillant <glv@posteo.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -28,19 +29,17 @@
             %lisp-type
             %source-install-prefix
             lisp-eval-program
-            compile-system
+            compile-systems
             test-system
             replace-escaped-macros
             generate-executable-wrapper-system
             generate-executable-entry-point
             generate-executable-for-system
-            %bundle-install-prefix
-            bundle-asd-file
             wrap-output-translations
             prepend-to-source-registry
             build-program
             build-image
-            make-asd-file
+            make-asdf-configuration
             valid-char-set
             normalize-string
             library-output))
@@ -65,9 +64,6 @@
 ;; link farm for system definition (.asd) files.
 (define %source-install-prefix "/share/common-lisp")
 
-(define (%bundle-install-prefix)
-  (string-append %source-install-prefix "/" (%lisp-type) "-bundle-systems"))
-
 (define (library-output outputs)
   "If a `lib' output exists, build things there. Otherwise use `out'."
   (or (assoc-ref outputs "lib") (assoc-ref outputs "out")))
@@ -81,38 +77,6 @@
   "Replace invalid characters in STR with a hyphen."
   (string-join (string-tokenize str valid-char-set) "-"))
 
-(define (normalize-dependency dependency)
-  "Normalize the name of DEPENDENCY.  Handles dependency definitions of the
-dependency-def form described by
-<https://common-lisp.net/project/asdf/asdf.html#The-defsystem-grammar>.
-Assume that any symbols in DEPENDENCY will be in upper-case."
-  (match dependency
-    ((':VERSION name rest ...)
-     `(:version ,(normalize-string name) ,@rest))
-    ((':FEATURE feature-specification dependency-specification)
-     `(:feature
-       ,feature-specification
-       ,(normalize-dependency dependency-specification)))
-    ((? string? name) (normalize-string name))
-    (require-specification require-specification)))
-
-(define (inputs->asd-file-map inputs)
-  "Produce a hash table of the form (system . asd-file), where system is the
-name of an ASD system, and asd-file is the full path to its definition."
-  (alist->hash-table
-   (filter-map
-    (match-lambda
-      ((_ . path)
-       (let ((prefix (string-append path (%bundle-install-prefix))))
-         (and (directory-exists? prefix)
-              (match (find-files prefix "\\.asd$")
-                ((asd-file)
-                 (cons
-                  (string-drop-right (basename asd-file) 4) ; drop ".asd"
-                  asd-file))
-                (_ #f))))))
-    inputs)))
-
 (define (wrap-output-translations translations)
   `(:output-translations
     ,@translations
@@ -143,70 +107,26 @@ with PROGRAM."
              "--eval" "(quit)"))
     (_ (error "The LISP provided is not supported at this time."))))
 
-(define (asdf-load-all systems)
-  (map (lambda (system)
-         `(asdf:load-system ,system))
-       systems))
-
-(define (compile-system system asd-file)
-  "Use a lisp implementation to compile SYSTEM using asdf.  Load ASD-FILE
-first."
+(define (compile-systems systems asd-files)
+  "Use a lisp implementation to compile the SYSTEMS using asdf.
+Load ASD-FILES first."
   (lisp-eval-program
    `((require :asdf)
-     (asdf:load-asd (truename ,asd-file) :name ,(normalize-string system))
-     (asdf:operate 'asdf:compile-bundle-op ,system))))
-
-(define (system-dependencies system asd-file)
-  "Return the dependencies of SYSTEM, as reported by
-asdf:system-depends-on.  First load the system's ASD-FILE."
-  (define deps-file ".deps.sexp")
-  (define program
-    `((require :asdf)
-      (asdf:load-asd (truename ,asd-file) :name ,(normalize-string system))
-      (with-open-file
-       (stream ,deps-file :direction :output)
-       (format stream
-               "~s~%"
-               (asdf:system-depends-on
-                (asdf:find-system ,system))))))
-
-  (dynamic-wind
-    (lambda _
-      (lisp-eval-program program))
-    (lambda _
-      (call-with-input-file deps-file read))
-    (lambda _
-      (when (file-exists? deps-file)
-        (delete-file deps-file)))))
-
-(define (compiled-system system)
-  (let ((system (basename system))) ; this is how asdf handles slashes
-    (match (%lisp-type)
-      ("sbcl" (string-append system "--system"))
-      (_ system))))
-
-(define* (generate-system-definition system
-                                     #:key version dependencies component?)
-  `(asdf:defsystem
-    ,(normalize-string system)
-    ,@(if component?
-          '(:class asdf/bundle:prebuilt-system)
-          '())
-    :version ,version
-    :depends-on ,dependencies
-    ,@(if component?
-          `(:components ((:compiled-file ,(compiled-system system))))
-          '())
-    ,@(if (string=? "ecl" (%lisp-type))
-          `(:lib ,(string-append system ".a"))
-          '())))
-
-(define (test-system system asd-file test-asd-file)
-  "Use a lisp implementation to test SYSTEM using asdf.  Load ASD-FILE first.
+     ,@(map (lambda (asd-file)
+              `(asdf:load-asd (truename ,asd-file)))
+            asd-files)
+     ,@(map (lambda (system)
+              `(asdf:compile-system ,system))
+            systems))))
+
+(define (test-system system asd-files test-asd-file)
+  "Use a lisp implementation to test SYSTEM using asdf.  Load ASD-FILES first.
 Also load TEST-ASD-FILE if necessary."
   (lisp-eval-program
    `((require :asdf)
-     (asdf:load-asd (truename ,asd-file) :name ,(normalize-string system))
+     ,@(map (lambda (asd-file)
+              `(asdf:load-asd (truename ,asd-file)))
+            asd-files)
      ,@(if test-asd-file
            `((asdf:load-asd (truename ,test-asd-file)))
            ;; Try some likely files.
@@ -237,6 +157,7 @@ created a \"SYSTEM-exec\" system which contains the entry program."
                                        :executable t
                                        :compression t))
           '())
+     (asdf:load-asd (truename ,(string-append system "-exec.asd")))
      (asdf:operate ',type ,(string-append system "-exec")))))
 
 (define (generate-executable-wrapper-system system dependencies)
@@ -271,79 +192,30 @@ ENTRY-PROGRAM for SYSTEM within the current directory."
                       (declare (ignorable arguments))
                       ,@entry-program))))))))
 
-(define (generate-dependency-links registry system)
-  "Creates a program which populates asdf's source registry from REGISTRY, an
-alist of dependency names to corresponding asd files.  This allows the system
-to locate its dependent systems."
-  `(progn
-    (asdf/source-registry:ensure-source-registry)
-    ,@(map (match-lambda
-             ((name . asd-file)
-              `(setf
-                (gethash ,name
-                         asdf/source-registry:*source-registry*)
-                ,(string->symbol "#p")
-                ,asd-file)))
-           registry)))
-
-(define* (make-asd-file asd-file
-                        #:key system version inputs
-                        (system-asd-file #f))
-  "Create an ASD-FILE for SYSTEM@VERSION, appending a program to allow the
-system to find its dependencies, as described by GENERATE-DEPENDENCY-LINKS."
-  (define dependencies
-    (let ((deps
-           (system-dependencies system system-asd-file)))
-      (if (eq? 'NIL deps)
-          '()
-          (map normalize-dependency deps))))
-
-  (define lisp-input-map
-    (inputs->asd-file-map inputs))
-
-  (define dependency-name
-    (match-lambda
-      ((':version name _ ...) name)
-      ((':feature _ dependency-specification)
-       (dependency-name dependency-specification))
-      ((? string? name) name)
-      (_ #f)))
-
-  (define registry
-    (filter-map hash-get-handle
-                (make-list (length dependencies)
-                           lisp-input-map)
-                (map dependency-name dependencies)))
-
-  ;; Ensure directory exists, which might not be the case for an .asd without components.
-  (mkdir-p (dirname asd-file))
-  (call-with-output-file asd-file
-    (lambda (port)
-      (display
-       (replace-escaped-macros
-        (format #f "~y~%~y~%"
-                (generate-system-definition
-                 system
-                 #:version version
-                 #:dependencies dependencies
-                 ;; Some .asd don't have components, and thus they don't generate any .fasl.
-                 #:component? (match (%lisp-type)
-                                ("sbcl" (pair? (find-files (dirname asd-file)
-                                                           "--system\\.fasl$")))
-                                ("ecl" (pair? (find-files (dirname asd-file)
-                                                          "\\.fasb$")))
-                                (_ (error "The LISP provided is not supported at this time."))))
-                (generate-dependency-links registry system)))
-       port))))
-
-(define (bundle-asd-file output-path original-asd-file)
-  "Find the symlinked bundle file for ORIGINAL-ASD-FILE by looking in
-OUTPUT-PATH/share/common-lisp/LISP-bundle-systems/<system>.asd.  Returns two
-values: the asd file itself and the directory in which it resides."
-  (let ((bundle-asd-path (string-append output-path
-                                        (%bundle-install-prefix))))
-    (values (string-append bundle-asd-path "/" (basename original-asd-file))
-            bundle-asd-path)))
+(define (make-asdf-configuration name conf-dir deps-conf-dir source-dir lib-dir)
+  (let ((registry-dir (string-append
+                       conf-dir "/source-registry.conf.d"))
+        (translations-dir (string-append
+                           conf-dir "/asdf-output-translations.conf.d"))
+        (deps-registry-dir (string-append
+                            deps-conf-dir "/source-registry.conf.d"))
+        (deps-translations-dir (string-append
+                                deps-conf-dir
+                                "/asdf-output-translations.conf.d")))
+    (mkdir-p registry-dir)
+    (when (directory-exists? deps-registry-dir)
+      (copy-recursively deps-registry-dir registry-dir))
+    (with-output-to-file (string-append registry-dir "/50-" name ".conf")
+      (lambda _
+        (format #t "~y~%" `(:tree ,source-dir))))
+
+    (mkdir-p translations-dir)
+    (when (directory-exists? deps-translations-dir)
+      (copy-recursively deps-translations-dir translations-dir))
+    (with-output-to-file (string-append translations-dir "/50-" name ".conf")
+      (lambda _
+        (format #t "~y~%" `((,source-dir :**/ :*.*.*)
+                            (,lib-dir :**/ :*.*.*)))))))
 
 (define (replace-escaped-macros string)
   "Replace simple lisp forms that the guile writer escapes, for example by
@@ -368,6 +240,7 @@ will run ENTRY-PROGRAM, a list of Common Lisp expressions in which `arguments'
 has been bound to the command-line arguments which were passed.  Link in any
 asd files from DEPENDENCY-PREFIXES to ensure references to those libraries are
 retained."
+  (setenv "XDG_CONFIG_DIRS" (string-append (library-output outputs) "/etc"))
   (generate-executable program
                        #:dependencies dependencies
                        #:dependency-prefixes dependency-prefixes
@@ -388,6 +261,7 @@ retained."
   "Generate an image, possibly standalone, which contains all DEPENDENCIES,
 placing the result in IMAGE.image.  Link in any asd files from
 DEPENDENCY-PREFIXES to ensure references to those libraries are retained."
+  (setenv "XDG_CONFIG_DIRS" (string-append (library-output outputs) "/etc"))
   (generate-executable image
                        #:dependencies dependencies
                        #:dependency-prefixes dependency-prefixes
@@ -416,20 +290,15 @@ references to those libraries are retained."
     (mkdir-p bin-directory)
     (with-directory-excursion bin-directory
       (generate-executable-wrapper-system name dependencies)
-      (generate-executable-entry-point name entry-program))
-
-    (prepend-to-source-registry
-     (string-append bin-directory "/"))
-
-    (setenv "ASDF_OUTPUT_TRANSLATIONS"
-            (replace-escaped-macros
-             (format
-              #f "~S"
-              (wrap-output-translations
-               `(((,bin-directory :**/ :*.*.*)
-                  (,bin-directory :**/ :*.*.*)))))))
-
-    (generate-executable-for-system type name #:compress? compress?)
+      (generate-executable-entry-point name entry-program)
+      (setenv "ASDF_OUTPUT_TRANSLATIONS"
+              (replace-escaped-macros
+               (format
+                #f "~S"
+                (wrap-output-translations
+                 `(((,bin-directory :**/ :*.*.*)
+                    (,bin-directory :**/ :*.*.*)))))))
+      (generate-executable-for-system type name #:compress? compress?))
 
     (let* ((after-store-prefix-index
             (string-index out-file #\/
@@ -445,9 +314,11 @@ references to those libraries are retained."
             (symlink asd-file
                      (string-append hidden-asd-links
                                     "/" (basename asd-file))))
-          (find-files (string-append path (%bundle-install-prefix))
+          (find-files (string-append path %source-install-prefix "/"
+                                     (%lisp-type))
                       "\\.asd$")))
        dependency-prefixes))
 
     (delete-file (string-append bin-directory "/" name "-exec.asd"))
-    (delete-file (string-append bin-directory "/" name "-exec.lisp"))))
+    (delete-file (string-append bin-directory "/" name "-exec.lisp"))
+    (delete-file (string-append bin-directory "/" name "-exec.fasl"))))