From: Joe Marshall <eval.apply@gmail.com>
Date: Wed, 4 Jan 2012 04:33:43 +0000 (-0800)
Subject: Add PATTERN-CONTAINS-DUPLICATES?
X-Git-Tag: release-9.2.0~334^2~36
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b3c74b4c0d7f584c66930f04e4c86734423946d4;p=mit-scheme.git

Add PATTERN-CONTAINS-DUPLICATES?
---

diff --git a/src/compiler/base/pmlook.scm b/src/compiler/base/pmlook.scm
index 15bd2f90d..0c8d24902 100644
--- 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))