From a5ac56f8830928205ce5424082486d509f898dc7 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Thu, 4 Sep 2025 14:28:42 +0200
Subject: [PATCH] =?UTF-8?q?packages:=20=E2=80=98package-field-location?=
 =?UTF-8?q?=E2=80=99=20returns=20a=20<location>=20for=20atoms.?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Fixes guix/guix#1975.

When using ‘read’, ‘package-field-location’ would not get source location for
atoms such as symbols, typically making it impossible to get the location of
the value of a field list (build-system gnu-build-system).  This fixes that.

* guix/packages.scm (field-value-location): New procedure.
(package-field-location): Use it instead of inline code.
* tests/packages.scm ("package-field-location"): Test the ‘build-system’
field.

Reported-by: Nicolas Graves <ngraves@ngraves.fr>
Change-Id: I98c694bb6f1999fa9ca80e145fa016640067af55
---
 guix/packages.scm  | 53 ++++++++++++++++++++++++++++++++--------------
 tests/packages.scm |  3 +++
 2 files changed, 40 insertions(+), 16 deletions(-)

diff --git a/guix/packages.scm b/guix/packages.scm
index 1d5986c5f422644a579f8d29011044c85c322332..bba281b37433defc1ad3731176d1a2c09a1cb4bd 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -794,6 +794,42 @@ object."
     (name old-name)
     (properties `((superseded . ,p)))))
 
+(define* (field-value-location port field
+                               #:optional (file (port-filename port)))
+  "Return the source location of the value of FIELD as read from PORT, or #f
+if FIELD could not be found."
+  (define (field-value lst field)
+    (syntax-case lst ()
+      (()
+       #f)
+      (((binding value) rest ...)
+       (eq? (syntax->datum #'binding) field)
+       #'value)
+      ((_ rest ...)
+       (field-value #'(rest ...) field))))
+
+  (define (extract inits)
+    (and=> (field-value inits field)
+           (lambda (value)
+             (let ((loc (and=> (syntax-source value)
+                               source-properties->location)))
+               (and loc
+                    ;; Preserve the original file name, which
+                    ;; may be a relative file name.
+                    (set-field loc (location-file) file))))))
+
+  ;; Use 'read-syntax', not 'read', to get location info on all the tokens,
+  ;; including symbols.  Abuse 'syntax-case' for pattern matching on syntax
+  ;; objects.
+  (syntax-case (read-syntax port) ()
+    ((head inits ...)
+     (eq? (syntax->datum #'head) 'package)
+     (extract #'(inits ...)))
+    ((head _ inits ...)
+     (eq? (syntax->datum #'head) 'package/inherit)
+     (extract #'(inits ...)))
+    (x #f)))
+
 (define (package-field-location package field)
   "Return the source code location of the definition of FIELD for PACKAGE, or
 #f if it could not be determined."
@@ -807,22 +843,7 @@ object."
             (call-with-input-file file-found
               (lambda (port)
                 (go-to-location port line column)
-                (match (read port)
-                  ((or ('package inits ...)
-                       ('package/inherit _ inits ...))
-                   (let ((field (assoc field inits)))
-                     (match field
-                       ((_ value)
-                        (let ((loc (and=> (source-properties value)
-                                          source-properties->location)))
-                          (and loc
-                               ;; Preserve the original file name, which may be a
-                               ;; relative file name.
-                               (set-field loc (location-file) file))))
-                       (_
-                        #f))))
-                  (_
-                   #f)))))
+                (field-value-location port field file))))
           (lambda _
             #f)))
        (#f
diff --git a/tests/packages.scm b/tests/packages.scm
index f56c63128d1cc0f9cd529b421b03e3f1a20a5762..78cb67081558b47ba2defe0660eda158f3f2b24a 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -292,6 +292,9 @@
          (member (read-at (package-field-location %bootstrap-guile 'version))
                  (let ((version (package-version %bootstrap-guile)))
                    (list version `(version ,version))))
+         (member (read-at (package-field-location coreutils
+                                                  'build-system))
+                 '(build-system gnu-build-system))
          (not (package-field-location %bootstrap-guile 'does-not-exist)))))
 
 ;; Make sure we don't change the file name to an absolute file name.