build-system/asdf: Pass the system name as an argument to the builder.

* guix/build-system/asdf.scm (asdf-build): Use the user-defined system name,
or calculate it from the package's full name.
[builder]: Pass the value along to the build procedure.
(package-with-build-system): Remove #:asd-system-name from source packages'
arguments.
* guix/build/asdf-build-system.scm: Adjust accordingly.
* guix/build/lisp-utils.scm (remove-lisp-from-name): Delete variable.

3 files changed, 32 insertions, 31 deletions

diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm
index 4afc6ef1a7..553bbe4825 100644
--- a/guix/build-system/asdf.scm
+++ b/guix/build-system/asdf.scm
@@ -22,6 +22,9 @@
   #:use-module (guix packages)
   #:use-module (guix derivations)
   #:use-module (guix search-paths)
+  #:use-module ((guix build utils)
+                #:select ((package-name->name+version
+                           . hyphen-separated-name->name+version)))
   #:use-module (guix build-system)
   #:use-module (guix build-system gnu)
   #:use-module (ice-9 match)
@@ -196,7 +199,7 @@ set up using CL source package conventions."
        (define base-arguments
          (if target-is-source?
              (strip-keyword-arguments
-              '(#:tests? #:asd-file #:lisp)
+              '(#:tests? #:asd-file #:lisp #:asd-system-name)
               (package-arguments pkg))
              (package-arguments pkg)))
 
@@ -262,6 +265,7 @@ set up using CL source package conventions."
                   #:key source outputs
                   (tests? #t)
                   (asd-file #f)
+                  (asd-system-name #f)
                   (phases '(@ (guix build asdf-build-system)
                               %standard-phases))
                   (search-paths '())
@@ -270,6 +274,13 @@ 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.
+
     (define builder
       `(begin
          (use-modules ,@modules)
@@ -284,6 +295,7 @@ set up using CL source package conventions."
                                    ((source) source)
                                    (source source))
                        #:asd-file ,asd-file
+                       #:asd-system-name ,system-name
                        #:system ,system
                        #:tests? ,tests?
                        #:phases ,phases
diff --git a/guix/build/asdf-build-system.scm b/guix/build/asdf-build-system.scm
index 4305a86af9..20116a4883 100644
--- a/guix/build/asdf-build-system.scm
+++ b/guix/build/asdf-build-system.scm
@@ -49,13 +49,6 @@
 (define %system-install-prefix
   (string-append %source-install-prefix "/systems"))
 
-(define (output-path->package-name path)
-  (package-name->name+version (strip-store-file-name path)))
-
-(define (outputs->name outputs)
-  (output-path->package-name
-   (assoc-ref outputs "out")))
-
 (define (lisp-source-directory output name)
   (string-append output (%lisp-source-install-prefix) "/" name))
 
@@ -101,31 +94,32 @@ valid."
 
 (define* (install #:key outputs #:allow-other-keys)
   "Copy and symlink all the source files."
-  (copy-files-to-output (assoc-ref outputs "out") (outputs->name outputs)))
+  (define output (assoc-ref outputs "out"))
+  (copy-files-to-output output
+                        (package-name->name+version
+                         (strip-store-file-name output))))
 
-(define* (copy-source #:key outputs #:allow-other-keys)
+(define* (copy-source #:key outputs asd-system-name #:allow-other-keys)
   "Copy the source to the library output."
   (let* ((out (library-output outputs))
-         (name (remove-lisp-from-name (output-path->package-name out)))
          (install-path (string-append out %source-install-prefix)))
-    (copy-files-to-output out name)
+    (copy-files-to-output out asd-system-name)
     ;; Hide the files from asdf
     (with-directory-excursion install-path
       (rename-file "source" (string-append (%lisp-type) "-source"))
       (delete-file-recursively "systems")))
   #t)
 
-(define* (build #:key outputs inputs asd-file
+(define* (build #:key outputs inputs asd-file asd-system-name
                 #:allow-other-keys)
   "Compile the system."
   (let* ((out (library-output outputs))
-         (name (remove-lisp-from-name (output-path->package-name out)))
-         (source-path (lisp-source-directory out name))
+         (source-path (lisp-source-directory out asd-system-name))
          (translations (wrap-output-translations
                         `(,(output-translation source-path
                                                out))))
          (asd-file (and=> asd-file
-                          (cut source-asd-file out name <>))))
+                          (cut source-asd-file out asd-system-name <>))))
 
     (setenv "ASDF_OUTPUT_TRANSLATIONS"
             (replace-escaped-macros (format #f "~S" translations)))
@@ -137,7 +131,7 @@ valid."
 
     (setenv "HOME" out) ; ecl's asdf sometimes wants to create $HOME/.cache
 
-    (compile-system name asd-file)
+    (compile-system asd-system-name asd-file)
 
     ;; As above, ecl will sometimes create this even though it doesn't use it
 
@@ -146,32 +140,31 @@ valid."
         (delete-file-recursively cache-directory))))
   #t)
 
-(define* (check #:key tests? outputs inputs asd-file
+(define* (check #:key tests? outputs inputs asd-file asd-system-name
                 #:allow-other-keys)
   "Test the system."
-  (let* ((name (remove-lisp-from-name (outputs->name outputs)))
-         (out (library-output outputs))
+  (let* ((out (library-output outputs))
          (asd-file (and=> asd-file
-                          (cut source-asd-file out name <>))))
+                          (cut source-asd-file out asd-system-name <>))))
     (if tests?
-        (test-system name asd-file)
+        (test-system asd-system-name 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))
-                ((full-name version) (package-name->name+version
-                                      (strip-store-file-name out)))
-                ((name) (remove-lisp-from-name full-name))
+                ((_ version) (package-name->name+version
+                              (strip-store-file-name out)))
                 ((new-asd-file) (string-append (library-directory out)
-                                               "/" name ".asd")))
+                                               "/" asd-system-name ".asd")))
 
     (make-asd-file new-asd-file
-                   #:system name
+                   #:system asd-system-name
                    #:version version
                    #:inputs inputs
                    #:system-asd-file asd-file))
diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm
index 148357bf0e..2d730570a1 100644
--- a/guix/build/lisp-utils.scm
+++ b/guix/build/lisp-utils.scm
@@ -36,7 +36,6 @@
             generate-executable-for-system
             %bundle-install-prefix
             bundle-asd-file
-            remove-lisp-from-name
             wrap-output-translations
             prepend-to-source-registry
             build-program
@@ -66,9 +65,6 @@
 (define (%bundle-install-prefix)
   (string-append %source-install-prefix "/" (%lisp-type) "-bundle-systems"))
 
-(define (remove-lisp-from-name name lisp)
-  (string-drop name (1+ (string-length lisp))))
-
 (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."