summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--ice-9/Makefile.am2
-rw-r--r--ice-9/Makefile.in2
-rw-r--r--ice-9/regex.scm141
3 files changed, 143 insertions, 2 deletions
diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am
index ab1090aac..bbd77d190 100644
--- 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 b644011f7..928a24f22 100644
--- 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
index 000000000..58e2c9c58
--- /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.
+;;;;
+
+;;;; 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)))))))
+