diff options
-rw-r--r-- | ice-9/Makefile.am | 2 | ||||
-rw-r--r-- | ice-9/Makefile.in | 2 | ||||
-rw-r--r-- | ice-9/regex.scm | 141 |
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))))))) + |