Implement any-duplicates?.

diff --git a/src/runtime/list.scm b/src/runtime/list.scm
index 8ba44ebcc273b22a0263e5843ee8825a20dc6b00..dfd9d06e5c7e714f9899514c4f0bebc6103741b0 100644 (file)
--- 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))))))))
 \f
 ;;;; Membership lists
 

diff --git a/src/runtime/record.scm b/src/runtime/record.scm
index 25f4006f2cfd413ecd7f771e2262b0f61fbc281f..8f4701f0f2fcf8a2d8588d521d837d71f58e2388 100644 (file)
--- 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 a819582fa8dd26143a8a653212d266e7e7e4797d..c6f3bc0c842b332f38bb44974060d663ae7a602e 100644 (file)
--- 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 3ec7f9eaed4454a8ea9eb378d9d874f740cde30d..a7912463252330f5b425cd0f1a699343919d0ce9 100644 (file)
--- 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))