From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 20 Sep 2009 04:40:44 +0000 (-0700)
Subject: Fix some bugs in regsexp.
X-Git-Tag: 20100708-Gtk~329
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=0a8fcbd47ae3b6a23701b4f7741c27fee30c9d7a;p=mit-scheme.git

Fix some bugs in regsexp.
---

diff --git a/src/runtime/regsexp.scm b/src/runtime/regsexp.scm
index 7c8c941fb..e6896e4f7 100644
--- a/src/runtime/regsexp.scm
+++ b/src/runtime/regsexp.scm
@@ -57,25 +57,19 @@ USA.
 
 (define (%compile-char-set items)
   (scalar-values->alphabet
-   (map (lambda (item)
-	  (cond ((or (unicode-scalar-value? item)
-		     (and (pair? item)
-			  (pair? (cdr item))
-			  (null? (cddr item))
-			  (unicode-scalar-value? (car item))
-			  (unicode-scalar-value? (cadr item))
-			  (< (car item) (cadr item))))
-		 (list item))
-		((unicode-char? item)
-		 (list (char->integer item)))
-		((alphabet? item)
-		 (alphabet->scalar-values item))
-		((string? item)
-		 (map char->integer (string->list item)))
-		(else
-		 (error:wrong-type-argument item "char-set item"
-					    'COMPILE-REGSEXP))))
-	items)))
+   (append-map (lambda (item)
+		 (cond ((well-formed-scalar-value-range? item)
+			(list item))
+		       ((unicode-char? item)
+			(list (char->integer item)))
+		       ((alphabet? item)
+			(alphabet->scalar-values item))
+		       ((string? item)
+			(map char->integer (string->list item)))
+		       (else
+			(error:wrong-type-argument item "char-set item"
+						   'COMPILE-REGSEXP))))
+	       items)))
 
 (define (%compile-group-key key)
   (if (not (or (fix:fixnum? key)
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 774e9664e..02c2b7f1e 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4973,6 +4973,7 @@ USA.
 	  error:not-utf32-string
 	  error:not-utf8-string
 	  error:not-well-formed-scalar-value-list
+	  error:not-well-formed-scalar-value-range
 	  error:not-wide-string
 	  for-all-chars-in-string?
 	  for-any-char-in-string?
@@ -4990,6 +4991,7 @@ USA.
 	  guarantee-utf32-string
 	  guarantee-utf8-string
 	  guarantee-well-formed-scalar-value-list
+	  guarantee-well-formed-scalar-value-range
 	  guarantee-wide-string
 	  guarantee-wide-string-index
 	  guarantee-wide-substring
@@ -5054,6 +5056,7 @@ USA.
 	  utf8-string-valid?
 	  utf8-string?
 	  well-formed-scalar-value-list?
+	  well-formed-scalar-value-range?
 	  wide-string
 	  wide-string->string
 	  wide-string-index?
diff --git a/src/runtime/unicode.scm b/src/runtime/unicode.scm
index 6764160a2..fffd5adc5 100644
--- a/src/runtime/unicode.scm
+++ b/src/runtime/unicode.scm
@@ -244,9 +244,9 @@ Not used at the moment.
 		       (else #t))))))))
 
 (define (well-formed-scalar-value-list? items)
-  (list-of-type? items well-formed-item?))
+  (list-of-type? items well-formed-scalar-value-range?))
 
-(define (well-formed-item? item)
+(define (well-formed-scalar-value-range? item)
   (if (pair? item)
       (and (unicode-scalar-value? (car item))
 	   (unicode-scalar-value? (cdr item))
@@ -254,6 +254,7 @@ Not used at the moment.
       (unicode-scalar-value? item)))
 
 (define-guarantee well-formed-scalar-value-list "a Unicode scalar-value list")
+(define-guarantee well-formed-scalar-value-range "a Unicode scalar-value range")
 
 (define (scalar-values->alphabet items)
   (guarantee-well-formed-scalar-value-list items 'SCALAR-VALUES->ALPHABET)