summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix/records.scm20
-rw-r--r--tests/records.scm26
2 files changed, 45 insertions, 1 deletions
diff --git a/guix/records.scm b/guix/records.scm
index 98f3c8fef0..6b3c25cefa 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 <ludo@gnu.org>
+;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
;;;
;;; 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 09ada70c2d..d9469a78bd 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 <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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