From 09802e9c75d44fe7e8e2618a8596377a5e6e1d32 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 21 Sep 2019 00:02:15 -0700
Subject: [PATCH] Implement any-duplicates?.

---
 src/runtime/list.scm         | 16 ++++++++++++++++
 src/runtime/record.scm       | 10 +---------
 src/runtime/runtime.pkg      |  1 +
 src/runtime/syntax-rules.scm |  5 +----
 4 files changed, 19 insertions(+), 13 deletions(-)

diff --git a/src/runtime/list.scm b/src/runtime/list.scm
index 8ba44ebcc..dfd9d06e5 100644
--- a/src/runtime/list.scm
+++ b/src/runtime/list.scm
@@ -915,6 +915,22 @@ USA.
 
 (define ((list-deletor! predicate) items)
   (remove! predicate items))
+
+(define (any-duplicates? items #!optional = get-key)
+  (let ((= (if (default-object? =) equal? =)))
+    (if (default-object? get-key)
+	(let loop ((items items))
+	  (and (pair? items)
+	       (if (%member (car items) (cdr items) = 'any-duplicates?)
+		   #t
+		   (loop (cdr items)))))
+	(let loop ((items items))
+	  (and (pair? items)
+	       (or (any (let ((key (get-key (car items))))
+			  (lambda (item)
+			    (= key (get-key item))))
+			(cdr items))
+		   (loop (cdr items))))))))
 
 ;;;; Membership lists
 
diff --git a/src/runtime/record.scm b/src/runtime/record.scm
index 25f4006f2..8f4701f0f 100644
--- a/src/runtime/record.scm
+++ b/src/runtime/record.scm
@@ -51,17 +51,9 @@ USA.
 (define (valid-field-specs? object)
   (and (list? object)
        (every field-spec? object)
-       (not (duplicate-fields? object))))
+       (not (any-duplicates? object eq? field-spec-name))))
 (register-predicate! valid-field-specs? 'valid-field-specs '<= list?)
 
-(define (duplicate-fields? field-specs)
-  (and (pair? field-specs)
-       (or (any (let ((name (field-spec-name (car field-specs))))
-		  (lambda (field-spec)
-		    (eq? name (field-spec-name field-spec))))
-		(cdr field-specs))
-	   (duplicate-fields? (cdr field-specs)))))
-
 (define (field-spec? object)
   (or (symbol? object)
       (and (pair? object)
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index a819582fa..c6f3bc0c8 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3033,6 +3033,7 @@ USA.
 	  alist-delete			;SRFI-1
 	  alist-delete!			;SRFI-1
 	  alist?
+	  any-duplicates?
 	  append
 	  append!			;SRFI-1
 	  append-map			;SRFI-1
diff --git a/src/runtime/syntax-rules.scm b/src/runtime/syntax-rules.scm
index 3ec7f9eae..a79124632 100644
--- a/src/runtime/syntax-rules.scm
+++ b/src/runtime/syntax-rules.scm
@@ -41,10 +41,7 @@ USA.
      (syntax-check '(_ (* identifier) * ((identifier . datum) expression)) form)
      (let ((keywords (cadr form))
 	   (clauses (cddr form)))
-       (if (let loop ((keywords keywords))
-	     (and (pair? keywords)
-		  (or (memq (car keywords) (cdr keywords))
-		      (loop (cdr keywords)))))
+       (if (any-duplicates? keywords eq?)
 	   (syntax-error "Keywords list contains duplicates:" keywords))
        (let ((r-form (new-identifier 'form))
 	     (r-rename (new-identifier 'rename))
-- 
2.25.1