diff options
| -rw-r--r-- | guix/gexp.scm | 50 | ||||
| -rw-r--r-- | tests/gexp.scm | 27 |
2 files changed, 72 insertions, 5 deletions
diff --git a/guix/gexp.scm b/guix/gexp.scm index d23683e2a6..e229c1fc8f 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -2176,6 +2176,29 @@ is true, the derivation will not print anything." ;;; (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")))) + + (define read-procedure + ;; The current read procedure being called: either 'read' or + ;; 'read-syntax'. + (make-parameter read)) + + (define read-syntax* + ;; Replacement for 'read-syntax'. + (let ((read-syntax (and=> (module-variable the-scm-module 'read-syntax) + variable-ref))) + (lambda (port . rest) + (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 @@ true, use 'ungexp-native' and 'ungexp-native-splicing' instead." 'ungexp-native 'ungexp)))) - (match (read port) - ((? symbol? symbol) - (let ((str (symbol->string symbol))) + (define symbolic? + ;; 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) + symbol? + (compose symbol? syntax->datum))) + + (define symbolic->string + (if (eq? (read-procedure) read) + symbol->string + (compose symbol->string syntax->datum))) + + (define wrapped-symbol + (if (eq? (read-procedure) read) + (lambda (_ symbol) symbol) + datum->syntax)) + + (match ((read-procedure) port) + ((? symbolic? symbol) + (let ((str (symbolic->string symbol))) (match (string-index-right str #\:) (#f `(,unquote-symbol ,symbol)) (colon (let ((name (string->symbol (substring str 0 colon))) (output (substring str (+ colon 1)))) - `(,unquote-symbol ,name ,output)))))) + `(,unquote-symbol ,(wrapped-symbol symbol name) ,output)))))) (x `(,unquote-symbol ,x)))) (define (read-gexp chr port) "Read a 'gexp' form from PORT." - `(gexp ,(read port))) + `(gexp ,((read-procedure) port))) ;; Extend the reader (read-hash-extend #\~ read-gexp) diff --git a/tests/gexp.scm b/tests/gexp.scm index bcda516623..33c0e4bf8c 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -28,6 +28,7 @@ #: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 @@ (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) + (gexp->sexp* + #~(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>. + (let ((file (tmpnam))) + (call-with-output-file file + (lambda (port) + (display (string-append "#~(this file is #$(local-file \"" + (basename file) "\" \"t.scm\"))") + port))) + + (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) (member (basename file) |