* regex.scm: New file.

* Makefile.am (subpkgdata_DATA): Add regex.scm.
* Makefile.in: Regenerated.

diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am
index ab1090a..bbd77d1 100644 (file)
--- a/ice-9/Makefile.am
+++ b/ice-9/Makefile.am
@@ -4,7 +4,7 @@ AUTOMAKE_OPTIONS = foreign
 
 subpkgdatadir = $(pkgdatadir)/$(VERSION)/ice-9
 subpkgdata_DATA = boot-9.scm debug.scm expect.scm hcons.scm lineio.scm \
-mapping.scm poe.scm slib.scm tags.scm threads.scm r4rs.scm
+mapping.scm poe.scm regex.scm slib.scm tags.scm threads.scm r4rs.scm
 ETAGS_ARGS = $(subpkgdata_DATA)
 
 ## test.scm is not currently installed.

diff --git a/ice-9/Makefile.in b/ice-9/Makefile.in
index b644011..928a24f 100644 (file)
--- a/ice-9/Makefile.in
+++ b/ice-9/Makefile.in
@@ -79,7 +79,7 @@ AUTOMAKE_OPTIONS = foreign
 
 subpkgdatadir = $(pkgdatadir)/$(VERSION)/ice-9
 subpkgdata_DATA = boot-9.scm debug.scm expect.scm hcons.scm lineio.scm \
-mapping.scm poe.scm slib.scm tags.scm threads.scm r4rs.scm
+mapping.scm poe.scm regex.scm slib.scm tags.scm threads.scm r4rs.scm
 ETAGS_ARGS = $(subpkgdata_DATA)
 
 EXTRA_DIST = $(subpkgdata_DATA) test.scm

diff --git a/ice-9/regex.scm b/ice-9/regex.scm
new file mode 100644 (file)
index 0000000..58e2c9c
--- /dev/null
+++ b/ice-9/regex.scm
@@ -0,0 +1,141 @@
+;;;;   Copyright (C) 1997 Free Software Foundation, Inc.
+;;;; 
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;; 
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;; GNU General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING.  If not, write to
+;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;;; 
+\f
+;;;; POSIX regex support functions.
+
+;;; FIXME:
+;;;   It is not clear what should happen if a `match' function
+;;;   is passed a `match number' which is out of bounds for the
+;;;   regexp match: return #f, or throw an error?  These routines
+;;;   throw an out-of-range error.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; These procedures are not defined in SCSH, but I found them useful.
+
+(define (match:count match)
+  (- (vector-length match) 1))
+
+(define (match:string match)
+  (vector-ref match 0))
+
+(define (match:prefix match)
+  (make-shared-substring (match:string match)
+                        0
+                        (match:start match 0)))
+
+(define (match:suffix match)
+  (make-shared-substring (match:string match)
+                        (match:end match 0)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; SCSH compatibility routines.
+
+(define (regexp-match? match)
+  (and (vector? match)
+       (string? (vector-ref match 0))
+       (let loop ((i 1))
+        (cond ((>= i (vector-length match)) #t)
+              ((and (pair? (vector-ref match i))
+                    (integer? (car (vector-ref match i)))
+                    (integer? (cdr (vector-ref match i))))
+               (loop (+ 1 i)))
+              (else #f)))))
+
+(define (regexp-quote regexp)
+  (call-with-output-string
+   (lambda (p)
+     (let loop ((i 0))
+       (and (< i (string-length regexp))
+           (begin
+             (case (string-ref regexp i)
+               ((#\* #\. #\( #\) #\+ #\? #\\ #\^ #\$ #\{ #\})
+                (write-char #\\ p)))
+             (write-char (string-ref regexp i) p)
+             (loop (1+ i))))))))
+
+(define (match:start match . args)
+  (let* ((matchnum (if (pair? args)
+                      (+ 1 (car args))
+                      1))
+        (start (car (vector-ref match matchnum))))
+    (if (= start -1) #f start)))
+
+(define (match:end match . args)
+  (let* ((matchnum (if (pair? args)
+                      (+ 1 (car args))
+                      1))
+        (end (cdr (vector-ref match matchnum))))
+    (if (= end -1) #f end)))
+
+(define (match:substring match . args)
+  (let* ((matchnum (if (pair? args)
+                      (car args)
+                      0))
+        (start (match:start match matchnum))
+        (end   (match:end match matchnum)))
+    (and start end (make-shared-substring (match:string match)
+                                         start
+                                         end))))
+
+(define (string-match pattern str . args)
+  (let ((rx (make-regexp pattern))
+       (start (if (pair? args) (car args) 0)))
+    (regexp-exec rx str start)))
+
+(define (regexp-substitute port match . items)
+  ;; If `port' is #f, send output to a string.
+  (if (not port)
+      (call-with-output-string
+       (lambda (p)
+        (apply regexp-substitute p match items)))
+
+      ;; Otherwise, process each substitution argument in `items'.
+      (for-each (lambda (obj)
+                 (cond ((string? obj)   (display obj port))
+                       ((integer? obj)  (display (match:substring match obj) port))
+                       ((eq? 'pre obj)  (display (match:prefix match) port))
+                       ((eq? 'post obj) (display (match:suffix match) port))
+                       (else (error 'wrong-type-arg obj))))
+               items)))
+
+(define (regexp-substitute/global port regexp string . items)
+  ;; If `port' is #f, send output to a string.
+  (if (not port)
+      (call-with-output-string
+       (lambda (p)
+        (apply regexp-substitute/global p regexp string items)))
+
+      ;; Otherwise, compile the regexp and match it against the
+      ;; string, looping if 'post is encountered in `items'.
+      (let ((rx (make-regexp regexp)))
+       (let next-match ((str string))
+         (let ((match (regexp-exec rx str)))
+           (if (not match)
+               (display str port)
+
+               ;; Process all of the items for this match.
+               (for-each
+                (lambda (obj)
+                  (cond
+                   ((string? obj)    (display obj port))
+                   ((integer? obj)   (display (match:substring match obj) port))
+                   ((procedure? obj) (display (obj match) port))
+                   ((eq? 'pre obj)   (display (match:prefix match) port))
+                   ((eq? 'post obj)  (next-match (match:suffix match)))
+                   (else (error 'wrong-type-arg obj))))
+                items)))))))
+