From 7fd25c6f15f74fb6e45fc3f0db21a110267f262c Mon Sep 17 00:00:00 2001
Read hash extensions preserve source location info as source properties
on their result. However, in Guile 3.0.8, that location would be
dismissed, leading 'local-file' to fail to resolve file names relative
Reported by Aleksandr Vityazev <avityazev@posteo.org>.
* guix/gexp.scm <eval-when> [read-syntax-redefined?, read-procedure]
[read-syntax*]: New variables.
[read-ungexp]: Adjust to expect either sexps or syntax objects.
[read-gexp]: Call 'read-procedure'.
* tests/gexp.scm ("local-file, relative file name, within gexp")
("local-file, relative file name, within gexp, compiled"): New tests.
guix/gexp.scm | 50 +++++++++++++++++++++++++++++++++++++++++++++-----
tests/gexp.scm | 27 +++++++++++++++++++++++++++
2 files changed, 72 insertions(+), 5 deletions(-)
Toggle diff (128 lines)
diff --git a/guix/gexp.scm b/guix/gexp.scm
index d23683e2a6..e229c1fc8f 100644
@@ -2176,6 +2176,29 @@ (define log-port
(eval-when (expand load eval)
+ (define-once read-syntax-redefined?
+ ;; Have we already redefined 'read-syntax'? This needs to be done on
+ ;; 3.0.8 only to work around <https://issues.guix.gnu.org/54003>.
+ (or (not (module-variable the-scm-module 'read-syntax))
+ (not (guile-version>? "3.0.7"))))
+ ;; The current read procedure being called: either 'read' or
+ ;; Replacement for 'read-syntax'.
+ (let ((read-syntax (and=> (module-variable the-scm-module 'read-syntax)
+ (parameterize ((read-procedure read-syntax))
+ (apply read-syntax port rest)))))
+ (unless read-syntax-redefined?
+ (set! (@ (guile) read-syntax) read-syntax*)
+ (set! read-syntax-redefined? #t))
(define* (read-ungexp chr port #:optional native?)
"Read an 'ungexp' or 'ungexp-splicing' form from PORT. When NATIVE? is
true, use 'ungexp-native' and 'ungexp-native-splicing' instead."
@@ -2191,22 +2214,39 @@ (define unquote-symbol
- (let ((str (symbol->string symbol)))
+ ;; Depending on whether (read-procedure) is 'read' or 'read-syntax', we
+ ;; might get either sexps or syntax objects. Adjust accordingly.
+ (if (eq? (read-procedure) read)
+ (compose symbol? syntax->datum)))
+ (define symbolic->string
+ (if (eq? (read-procedure) read)
+ (compose symbol->string syntax->datum)))
+ (if (eq? (read-procedure) read)
+ (lambda (_ symbol) symbol)
+ (match ((read-procedure) port)
+ (let ((str (symbolic->string symbol)))
(match (string-index-right str #\:)
`(,unquote-symbol ,symbol))
(let ((name (string->symbol (substring str 0 colon)))
(output (substring str (+ colon 1))))
- `(,unquote-symbol ,name ,output))))))
+ `(,unquote-symbol ,(wrapped-symbol symbol name) ,output))))))
(define (read-gexp chr port)
"Read a 'gexp' form from PORT."
+ `(gexp ,((read-procedure) port)))
(read-hash-extend #\~ read-gexp)
diff --git a/tests/gexp.scm b/tests/gexp.scm
index bcda516623..33c0e4bf8c 100644
@@ -28,6 +28,7 @@ (define-module (test-gexp)
#:use-module (guix tests)
#:use-module ((guix build utils) #:select (with-directory-excursion))
#:use-module ((guix utils) #:select (call-with-temporary-directory))
+ #:use-module ((guix ui) #:select (load*))
#:use-module (gnu packages)
#:use-module (gnu packages base)
#:use-module (gnu packages bootstrap)
@@ -222,6 +223,32 @@ (define defmod 'define-module) ;fool Geiser
(let ((file (local-file (string-copy "../base32.scm"))))
(local-file-absolute-file-name file)))))
+(test-assert "local-file, relative file name, within gexp"
+ (let* ((file (search-path %load-path "guix/base32.scm"))
+ (interned (add-to-store %store "base32.scm" #f "sha256" file)))
+ (equal? `(the file is ,interned)
+ #~(the file is #$(local-file "../guix/base32.scm"))))))
+(test-assert "local-file, relative file name, within gexp, compiled"
+ ;; In Guile 3.0.8, everything read by the #~ and #$ read hash extensions
+ ;; would lack source location info, which in turn would lead
+ ;; (current-source-directory), called by 'local-file', to return #f, thereby
+ ;; breaking 'local-file' resolution. See
+ ;; <https://issues.guix.gnu.org/54003>.
+ (call-with-output-file file
+ (display (string-append "#~(this file is #$(local-file \""
+ (basename file) "\" \"t.scm\"))")
+ (let* ((interned (add-to-store %store "t.scm" #f "sha256" file))
+ (module (make-fresh-user-module)))
+ (module-use! module (resolve-interface '(guix gexp)))
+ (equal? `(this file is ,interned)
+ (gexp->sexp* (load* file module))))))
(test-assertm "local-file, #:select?"
(mlet* %store-monad ((select? -> (lambda (file stat)
base-commit: 791069737c8c51582cc021438dae32eb0fb7b8e0