From 2fa8fd4af59af0de392352915fa50fc21a4cf98a Mon Sep 17 00:00:00 2001
From: Guillaume Le Vaillant <glv@posteo.net>
Date: Thu, 6 May 2021 10:32:56 +0200
Subject: build-system: asdf: Work around package-name->name+version bug.

This patch modifies how the name of the main Common Lisp system is extracted
from the full Guix package name to work around bug#48225 concerning the
'package-name->name+version' function.

Fixes <https://issues.guix.gnu.org/41437>.

* guix/build-system/asdf.scm (asdf-build): Fix 'systems' function.
* guix/build/asdf-build-system.scm (main-system-name): Fix it.
---
 guix/build-system/asdf.scm       | 18 +++++++++---------
 guix/build/asdf-build-system.scm | 15 ++++++++-------
 2 files changed, 17 insertions(+), 16 deletions(-)

diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm
index 28403a1960..b4e40ee8c2 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, 2020 Guillaume Le Vaillant <glv@posteo.net>
+;;; Copyright © 2019, 2020, 2021 Guillaume Le Vaillant <glv@posteo.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -291,16 +291,16 @@ set up using CL source package conventions."
                   (imported-modules %asdf-build-system-modules)
                   (modules %asdf-build-modules))
 
-    ;; 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.
+          ;; FIXME: Find a more reliable way to get the main system name.
+          (let* ((lisp-prefix (string-append lisp-type "-"))
+                 (package-name (hyphen-separated-name->name+version
+                                (if (string-prefix? lisp-prefix name)
+                                    (string-drop name
+                                                 (string-length lisp-prefix))
+                                    name))))
+            `(quote ,(list package-name)))
           asd-systems))
 
     (define builder
diff --git a/guix/build/asdf-build-system.scm b/guix/build/asdf-build-system.scm
index 6ad855cab2..7f1037c4f9 100644
--- a/guix/build/asdf-build-system.scm
+++ b/guix/build/asdf-build-system.scm
@@ -1,6 +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>
+;;; Copyright © 2020, 2021 Guillaume Le Vaillant <glv@posteo.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -52,12 +52,13 @@
   (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)))
+  ;; FIXME: Find a more reliable way to get the main system name.
+  (let* ((full-name (strip-store-file-name output))
+         (lisp-prefix (string-append (%lisp-type) "-"))
+         (package-name (if (string-prefix? lisp-prefix full-name)
+                           (string-drop full-name (string-length lisp-prefix))
+                           full-name)))
+    (package-name->name+version package-name)))
 
 (define (lisp-source-directory output name)
   (string-append output (%lisp-source-install-prefix) "/" name))
-- 
cgit 1.4.1