From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 31 May 2010 08:32:12 +0000 (-0700)
Subject: Fix swapped conditional arms in RE-COMPILE-CHAR-SET; then split off
X-Git-Tag: 20100708-Gtk~41
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3fcf803cc5244bc0499440df2bfadd724f338457;p=mit-scheme.git

Fix swapped conditional arms in RE-COMPILE-CHAR-SET; then split off
part of it as RE-CHAR-PATTERN->SCALAR-VALUES.
---

diff --git a/src/runtime/rgxcmp.scm b/src/runtime/rgxcmp.scm
index 6f4caca18..c85dc018d 100644
--- a/src/runtime/rgxcmp.scm
+++ b/src/runtime/rgxcmp.scm
@@ -259,6 +259,14 @@ USA.
 ;;; #\^ must appear anywhere except as the first character in the set.
 
 (define (re-compile-char-set pattern negate?)
+  (receive (scalar-values negate?*)
+      (re-char-pattern->scalar-values pattern)
+    (let ((char-set (scalar-values->char-set scalar-values)))
+      (if (if negate? (not negate?*) negate?*)
+	  (char-set-invert char-set)
+	  char-set))))
+
+(define (re-char-pattern->scalar-values pattern)
   (define (loop pattern scalar-values)
     (if (pair? pattern)
 	(if (and (pair? (cdr pattern))
@@ -274,15 +282,10 @@ USA.
 	scalar-values))
 
   (let ((pattern (string->list pattern)))
-    (receive (pattern negate?)
-	(if (and (pair? pattern)
-		 (char=? (car pattern) #\^))
-	    (values (cdr pattern) (not negate?))
-	    (values pattern negate?))
-      (let ((char-set (scalar-values->char-set (loop pattern '()))))
-	(if negate?
-	    char-set
-	    (char-set-invert char-set))))))
+    (if (and (pair? pattern)
+	     (char=? (car pattern) #\^))
+	(values (loop (cdr pattern) '()) #t)
+	(values (loop pattern '()) #f))))
 
 ;;;; Translation Tables
 
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index d4d6fe6c9..cea35327b 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -5083,6 +5083,7 @@ USA.
 	  compiled-regexp/byte-stream
 	  compiled-regexp/translation-table
 	  condition-type:re-compile-pattern
+	  re-char-pattern->scalar-values
 	  re-compile-char
 	  re-compile-char-set
 	  re-compile-pattern