* regex.scm: New file.

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

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.

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

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.
+;;;; 
+
+;;;; 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)))))))
+