05/11: records: Detect duplicate field initializers.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit c2dcff41c2e47f5f978f467864d5ed7829939884
Author: Ludovic Courtès <address@hidden>
Date:   Thu Apr 19 12:33:25 2018 -0400

    records: Detect duplicate field initializers.
    
    * guix/records.scm (report-duplicate-field-specifier): New procedure.
    (make-syntactic-constructor): Call it.
    * tests/records.scm ("define-record-type* & duplicate initializers"):
    New test.
    
    Co-authored-by: Mark H Weaver <address@hidden>
---
 guix/records.scm  | 20 ++++++++++++++++++++
 tests/records.scm | 26 +++++++++++++++++++++++++-
 2 files changed, 45 insertions(+), 1 deletion(-)

diff --git a/guix/records.scm b/guix/records.scm
index 98f3c8f..6b3c25c 100644
--- a/guix/records.scm
+++ b/guix/records.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès 
<address@hidden>
+;;; Copyright © 2018 Mark H Weaver <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -52,6 +53,22 @@
       ((weird _ ...)                              ;weird!
        (syntax-violation name "invalid field specifier" #'weird)))))
 
+(define (report-duplicate-field-specifier name ctor)
+  "Report the first duplicate identifier among the bindings in CTOR."
+  (syntax-case ctor ()
+    ((_ bindings ...)
+     (let loop ((bindings #'(bindings ...))
+                (seen   '()))
+       (syntax-case bindings ()
+         (((field value) rest ...)
+          (not (memq (syntax->datum #'field) seen))
+          (loop #'(rest ...) (cons (syntax->datum #'field) seen)))
+         ((duplicate rest ...)
+          (syntax-violation name "duplicate field initializer"
+                            #'duplicate))
+         (()
+          #t))))))
+
 (eval-when (expand load eval)
   ;; The procedures below are needed both at run time and at expansion time.
 
@@ -169,6 +186,9 @@ of TYPE matches the expansion-time ABI."
                           #'(field (... ...)))
                     (wrap-field-value f (field-default-value f))))
 
+              ;; Pass S to make sure source location info is preserved.
+              (report-duplicate-field-specifier 'name s)
+
               (let ((fields (append fields (map car default-values))))
                 (cond ((lset= eq? fields '(expected ...))
                        #`(let* #,(field-bindings
diff --git a/tests/records.scm b/tests/records.scm
index 09ada70..d9469a7 100644
--- a/tests/records.scm
+++ b/tests/records.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018 Ludovic Courtès 
<address@hidden>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019 Ludovic Courtès 
<address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -288,6 +288,30 @@
       (and (string-match "extra.*initializer.*baz" message)
            (eq? proc 'foo)))))
 
+(test-assert "define-record-type* & duplicate initializers"
+  (let ((exp '(begin
+                (define-record-type* <foo> foo make-foo
+                  foo?
+                  (bar foo-bar (default 42)))
+
+                (foo (bar 1)
+                     (bar 2))))
+        (loc         (current-source-location)))  ;keep this alignment!
+    (catch 'syntax-error
+      (lambda ()
+        (eval exp (test-module))
+        #f)
+      (lambda (key proc message location form . args)
+        (and (string-match "duplicate.*initializer" message)
+             (eq? proc 'foo)
+
+             ;; Make sure the location is that of the field specifier.
+             (lset= equal?
+                    (pk 'expected-loc
+                        `((line . ,(- (assq-ref loc 'line) 1))
+                          ,@(alist-delete 'line loc)))
+                    (pk 'actual-loc location)))))))
+
 (test-assert "ABI checks"
   (let ((module (test-module)))
     (eval '(begin