diff options
| -rw-r--r-- | guix/records.scm | 19 | ||||
| -rw-r--r-- | tests/records.scm | 20 |
2 files changed, 39 insertions, 0 deletions
diff --git a/guix/records.scm b/guix/records.scm index bf746d3b5d9..52d03f73942 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -24,6 +24,7 @@ #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) + #:autoload (system syntax) (syntax-local-binding) #:export (define-record-type* this-record @@ -206,6 +207,23 @@ of TYPE matches the expansion-time ABI." index (loop rest (+ 1 index)))))))) + (define (check-shadowing identifier) + ;; Warn if IDENTIFIER shadows a local binding. + ;; Note: not using (guix diagnostics) to remain independent of + ;; other Guix modules. + (when (eq? 'lexical (syntax-local-binding identifier)) + (format (current-warning-port) + "~a: inherited field binding '~a' of \ +record type '~a' shadows local variable~%" + (match (syntax-source identifier) + (#f "<unknown-location>") + (lst (format #f "~a:~a:~a" + (assq-ref lst 'filename) + (and=> (assq-ref lst 'line) 1+) + (assq-ref lst 'column)))) + (syntax->datum identifier) + (syntax->datum #'type)))) + (define* (wrap-field-value f value #:optional parent) ;; Wrap VALUE, the value of field F, such that its sanitizer is ;; called and its properties (thunked, delayed) honored. When @@ -222,6 +240,7 @@ of TYPE matches the expansion-time ABI." #`((struct-ref #,parent #,(field-index f)) #,this-identifier))) + (check-shadowing f) #`(lambda (x) (syntax-parameterize ((#,this-identifier (lambda (s) diff --git a/tests/records.scm b/tests/records.scm index 9c071334d50..57a21d2effc 100644 --- a/tests/records.scm +++ b/tests/records.scm @@ -302,6 +302,26 @@ => (,(foo-bar child) ,(foo-baz child)))))) +(test-assert "define-record-type* & inherited value shadowing" + (let ((exp '(begin + (define-record-type* <foo> foo make-foo + foo? + (bar foo-bar) + (baz foo-baz (thunked))) + + (let ((x (foo (bar 1) (baz 2))) + (baz 123)) + ;; Below, the 'baz' binding for the inherited field value + ;; shadows the 'baz' above, which should trigger a warning. + (foo (inherit x) + (baz (* baz 2))))))) + (string-contains + (call-with-output-string + (lambda (port) + (parameterize ((current-warning-port port)) + (eval exp (test-module))))) + "shadows local variable"))) + (test-assert "define-record-type* & delayed" (begin (define-record-type* <foo> foo make-foo |