diff options
Diffstat (limited to 'guix/gexp.scm')
| -rw-r--r-- | guix/gexp.scm | 69 |
1 files changed, 56 insertions, 13 deletions
diff --git a/guix/gexp.scm b/guix/gexp.scm index dfeadbd15d..9fdb7a30be 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -4,7 +4,7 @@ ;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2019, 2020 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> -;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> +;;; Copyright © 2021, 2022 Maxime Devos <maximedevos@telenet.be> ;;; ;;; This file is part of GNU Guix. ;;; @@ -174,12 +174,15 @@ As a result, the S-expression will be approximate if GEXP has references." (map (lambda (reference) (match reference (($ <gexp-input> thing output native) - (if (gexp-like? thing) - (gexp->approximate-sexp thing) - ;; Simply returning 'thing' won't work in some - ;; situations; see 'write-gexp' below. - '(*approximate*))) - (_ '(*approximate*)))) + (cond ((gexp-like? thing) + (gexp->approximate-sexp thing)) + ((not (record? thing)) ; a S-exp + thing) + (#true + ;; Simply returning 'thing' won't work in some + ;; situations; see 'write-gexp' below. + '(*approximate*)))) + (($ <gexp-output>) '(*approximate*)))) (gexp-references gexp)))) (define (write-gexp gexp port) @@ -598,7 +601,7 @@ This is the declarative counterpart of 'gexp->derivation'." (match file (($ <computed-file> name gexp guile options) (mlet %store-monad ((guile (lower-object (or guile (default-guile)) - system #:target target))) + system #:target #f))) (apply gexp->derivation name gexp #:guile-for-build guile #:system system #:target target options))))) @@ -2176,6 +2179,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 +2217,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) |