From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 12 Apr 2000 02:36:23 +0000 (+0000)
Subject: Implement CHAR-SET->REGEXP.
X-Git-Tag: 20090517-FFI~4047
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=06ab2542e3adcbcdc1cd9ad07cc73b6689ec2614;p=mit-scheme.git

Implement CHAR-SET->REGEXP.
---

diff --git a/v7/src/runtime/regexp.scm b/v7/src/runtime/regexp.scm
index d2cc08c08..89140933c 100644
--- a/v7/src/runtime/regexp.scm
+++ b/v7/src/runtime/regexp.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: regexp.scm,v 1.7 2000/03/21 21:23:38 cph Exp $
+;;; $Id: regexp.scm,v 1.8 2000/04/12 02:36:23 cph Exp $
 ;;;
 ;;; Copyright (c) 1986, 1989-1999 Massachusetts Institute of Technology
 ;;;
@@ -71,19 +71,6 @@
 		  thunk
 		  (lambda () (set-re-registers! registers*)))))
 
-(define (regexp-group . alternatives)
-  (let ((alternatives
-	 (list-transform-positive alternatives identity-procedure)))
-    (if (null? alternatives)
-	"\\(\\)"
-	(apply string-append
-	       (cons "\\("
-		     (let loop ((alternatives alternatives))
-		       (cons (car alternatives)
-			     (if (null? (cdr alternatives))
-				 (list "\\)")
-				 (cons "\\|" (loop (cdr alternatives)))))))))))
-
 (define (re-match-extract string regs i)
   (substring string
 	     (re-match-start-index i regs)
@@ -134,4 +121,77 @@
   (make-string-operation re-substring-search-forward))
 
 (define re-string-search-backward
-  (make-string-operation re-substring-search-backward))
\ No newline at end of file
+  (make-string-operation re-substring-search-backward))
+
+(define (regexp-group . alternatives)
+  (let ((alternatives
+	 (list-transform-positive alternatives identity-procedure)))
+    (if (null? alternatives)
+	"\\(\\)"
+	(apply string-append
+	       (cons "\\("
+		     (let loop ((alternatives alternatives))
+		       (cons (car alternatives)
+			     (if (null? (cdr alternatives))
+				 (list "\\)")
+				 (cons "\\|" (loop (cdr alternatives)))))))))))
+
+(define (char-set->regexp char-set)
+  (let ((chars (char-set-members char-set)))
+    (if (and (pair? chars)
+	     (memv (car chars) '(#\^ #\- #\]))
+	     (null? (cdr chars)))
+	(string #\\ char)
+	(let ((ranges
+	       (let outer ((chars chars) (ranges '()))
+		 (if (pair? chars)
+		     (let ((start (car chars)))
+		       (let inner ((chars (cdr chars)) (end (car chars)))
+			 (if (and (pair? chars)
+				  (fix:= (fix:+ (char->integer end) 1)
+					 (char->integer (car chars))))
+			     (inner (cdr chars) (car chars))
+			     (outer
+			      chars
+			      (let ((accum
+				     (lambda (start end ranges)
+				       (cons (if (and (char=? start end)
+						      (not (char=? #\- start)))
+						 start
+						 (cons start end))
+					     ranges))))
+				(if (and (not (char=? start end))
+					 (or (char=? #\] start)
+					     (char=? #\] end)))
+				    (if (char=? #\] start)
+					(cons #\] (accum #\^ end ranges))
+					(accum start #\\ (cons #\] ranges)))
+				    (accum start end ranges)))))))
+		     (reverse! ranges)))))
+	  (let ((ranges
+		 (if (memv #\] ranges)
+		     (cons #\] (delv! #\] ranges))
+		     ranges)))
+	    (let ((n
+		   (let loop ((ranges ranges) (n 2))
+		     (if (pair? ranges)
+			 (loop (cdr ranges)
+			       (fix:+ n (if (pair? (car ranges)) 3 1)))
+			 n))))
+	      (let ((s (make-string n)))
+		(string-set! s 0 #\[)
+		(let loop ((ranges ranges) (i 1))
+		  (if (pair? ranges)
+		      (loop (cdr ranges)
+			    (let ((range (car ranges)))
+			      (if (pair? range)
+				  (begin
+				    (string-set! s i (car range))
+				    (string-set! s (fix:+ i 1) #\-)
+				    (string-set! s (fix:+ i 2) (cdr range))
+				    (fix:+ i 3))
+				  (begin
+				    (string-set! s i range)
+				    (fix:+ i 1)))))
+		      (string-set! s i #\])))
+		s)))))))
\ No newline at end of file
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index c90f71212..7d18004d3 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.344 2000/04/11 15:19:18 cph Exp $
+$Id: runtime.pkg,v 14.345 2000/04/12 02:36:13 cph Exp $
 
 Copyright (c) 1988-2000 Massachusetts Institute of Technology
 
@@ -3564,6 +3564,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     (else))
   (parent ())
   (export ()
+	  char-set->regexp
 	  guarantee-re-register
 	  guarantee-re-registers
 	  preserving-re-registers