Implement CHAR-SET->REGEXP.

diff --git a/v7/src/runtime/regexp.scm b/v7/src/runtime/regexp.scm
index d2cc08c0814984ec3eb08c23ec4ee19dbbd34c31..89140933c4cd681cdb783065e3808adf7e23a341 100644 (file)
--- 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))
+\f
+(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 c90f71212a11ddd46d5eaef6719720c73e3d25e7..7d18004d31a396936a7665a30a8fdac739bf421b 100644 (file)
--- 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