Add PATTERN-CONTAINS-DUPLICATES?

diff --git a/src/compiler/base/pmlook.scm b/src/compiler/base/pmlook.scm
index 15bd2f90dd3d6a834fa017fe6bb2acc2523a4455..0c8d2490295655a3d1f2d98a1d7c6de396869cf5 100644 (file)
--- a/src/compiler/base/pmlook.scm
+++ b/src/compiler/base/pmlook.scm
@@ -85,6 +85,20 @@ USA.
                   vars)))
          (else vars))))
 
+(define (pattern-contains-duplicates? pattern)
+  (not (let loop ((pattern pattern)
+                 (vars '()))
+        (if (pair? pattern)
+            ;; Cheat:  we know pattern variables are pairs
+            (if (eq? (car pattern) pattern-variable-tag)
+                (if (memq (pattern-variable-name pattern) vars)
+                    #f                 ; found a duplicate
+                    (cons (pattern-variable-name pattern) vars))
+                (let ((vars1 (loop (car pattern) vars)))
+                  (and vars1
+                       (loop (cdr pattern) vars1))))
+            vars))))
+
 (define-integrable (make-pattern-variable name)
   (cons pattern-variable-tag name))