summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2018-04-19 12:33:25 -0400
committerLudovic Courtès <ludo@gnu.org>2019-01-22 23:04:05 +0100
commitc2dcff41c2e47f5f978f467864d5ed7829939884 (patch)
tree2830b58567dd6a9a03fb40dfafef75eea491b1ef /guix
parentc498aaaf110cd7f6950ea47e637725e0513655d4 (diff)
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 <mhw@netris.org>
Diffstat (limited to 'guix')
-rw-r--r--guix/records.scm20
1 files changed, 20 insertions, 0 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