ice-9/regex.scm

   1 ;;;;    Copyright (C) 1997, 1999, 2001 Free Software Foundation, Inc.
   2 ;;;;
   3 ;;;; This program is free software; you can redistribute it and/or modify
   4 ;;;; it under the terms of the GNU General Public License as published by
   5 ;;;; the Free Software Foundation; either version 2, or (at your option)
   6 ;;;; any later version.
   7 ;;;;
   8 ;;;; This program is distributed in the hope that it will be useful,
   9 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 ;;;; GNU General Public License for more details.
  12 ;;;;
  13 ;;;; You should have received a copy of the GNU General Public License
  14 ;;;; along with this software; see the file COPYING.  If not, write to
  15 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16 ;;;; Boston, MA 02111-1307 USA
  17 ;;;;
  18 ;;;; As a special exception, the Free Software Foundation gives permission
  19 ;;;; for additional uses of the text contained in its release of GUILE.
  20 ;;;;
  21 ;;;; The exception is that, if you link the GUILE library with other files
  22 ;;;; to produce an executable, this does not by itself cause the
  23 ;;;; resulting executable to be covered by the GNU General Public License.
  24 ;;;; Your use of that executable is in no way restricted on account of
  25 ;;;; linking the GUILE library code into it.
  26 ;;;;
  27 ;;;; This exception does not however invalidate any other reasons why
  28 ;;;; the executable file might be covered by the GNU General Public License.
  29 ;;;;
  30 ;;;; This exception applies only to the code released by the
  31 ;;;; Free Software Foundation under the name GUILE.  If you copy
  32 ;;;; code from other Free Software Foundation releases into a copy of
  33 ;;;; GUILE, as the General Public License permits, the exception does
  34 ;;;; not apply to the code that you add in this way.  To avoid misleading
  35 ;;;; anyone as to the status of such modified files, you must delete
  36 ;;;; this exception notice from them.
  37 ;;;;
  38 ;;;; If you write modifications of your own for GUILE, it is your choice
  39 ;;;; whether to permit this exception to apply to your modifications.
  40 ;;;; If you do not wish that, delete this exception notice.
  41 ;;;;
  42
  43 ;;; Commentary:
  44
  45 ;; These procedures are exported:
  46 ;;  (match:count match)
  47 ;;  (match:string match)
  48 ;;  (match:prefix match)
  49 ;;  (match:suffix match)
  50 ;;  (regexp-match? match)
  51 ;;  (regexp-quote string)
  52 ;;  (match:start match . submatch-num)
  53 ;;  (match:end match . submatch-num)
  54 ;;  (match:substring match . submatch-num)
  55 ;;  (string-match pattern str . start)
  56 ;;  (regexp-substitute port match . items)
  57 ;;  (fold-matches regexp string init proc . flags)
  58 ;;  (list-matches regexp string . flags)
  59 ;;  (regexp-substitute/global port regexp string . items)
  60
  61 ;;; Code:
  62 \f
  63 ;;;; POSIX regex support functions.
  64
  65 (define-module (ice-9 regex)
  66   :export (match:count match:string match:prefix match:suffix
  67            regexp-match? regexp-quote match:start match:end match:substring
  68            string-match regexp-substitute fold-matches list-matches
  69            regexp-substitute/global))
  70
  71 ;;; FIXME:
  72 ;;;   It is not clear what should happen if a `match' function
  73 ;;;   is passed a `match number' which is out of bounds for the
  74 ;;;   regexp match: return #f, or throw an error?  These routines
  75 ;;;   throw an out-of-range error.
  76
  77 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  78 ;;;; These procedures are not defined in SCSH, but I found them useful.
  79
  80 (define (match:count match)
  81   (- (vector-length match) 1))
  82
  83 (define (match:string match)
  84   (vector-ref match 0))
  85
  86 (define (match:prefix match)
  87   (substring (match:string match) 0 (match:start match 0)))
  88
  89 (define (match:suffix match)
  90   (substring (match:string match) (match:end match 0)))
  91
  92 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  93 ;;;; SCSH compatibility routines.
  94
  95 (define (regexp-match? match)
  96   (and (vector? match)
  97        (string? (vector-ref match 0))
  98        (let loop ((i 1))
  99          (cond ((>= i (vector-length match)) #t)
 100                ((and (pair? (vector-ref match i))
 101                      (integer? (car (vector-ref match i)))
 102                      (integer? (cdr (vector-ref match i))))
 103                 (loop (+ 1 i)))
 104                (else #f)))))
 105
 106 (define (regexp-quote string)
 107   (call-with-output-string
 108    (lambda (p)
 109      (let loop ((i 0))
 110        (and (< i (string-length string))
 111             (begin
 112               (case (string-ref string i)
 113                 ((#\* #\. #\( #\) #\+ #\? #\\ #\^ #\$ #\{ #\})
 114                  (write-char #\\ p)))
 115               (write-char (string-ref string i) p)
 116               (loop (1+ i))))))))
 117
 118 (define (match:start match . args)
 119   (let* ((matchnum (if (pair? args)
 120                        (+ 1 (car args))
 121                        1))
 122          (start (car (vector-ref match matchnum))))
 123     (if (= start -1) #f start)))
 124
 125 (define (match:end match . args)
 126   (let* ((matchnum (if (pair? args)
 127                        (+ 1 (car args))
 128                        1))
 129          (end (cdr (vector-ref match matchnum))))
 130     (if (= end -1) #f end)))
 131
 132 (define (match:substring match . args)
 133   (let* ((matchnum (if (pair? args)
 134                        (car args)
 135                        0))
 136          (start (match:start match matchnum))
 137          (end   (match:end match matchnum)))
 138     (and start end (substring (match:string match) start end))))
 139
 140 (define (string-match pattern str . args)
 141   (let ((rx (make-regexp pattern))
 142         (start (if (pair? args) (car args) 0)))
 143     (regexp-exec rx str start)))
 144
 145 (define (regexp-substitute port match . items)
 146   ;; If `port' is #f, send output to a string.
 147   (if (not port)
 148       (call-with-output-string
 149        (lambda (p)
 150          (apply regexp-substitute p match items)))
 151
 152       ;; Otherwise, process each substitution argument in `items'.
 153       (for-each (lambda (obj)
 154                   (cond ((string? obj)   (display obj port))
 155                         ((integer? obj)  (display (match:substring match obj) port))
 156                         ((eq? 'pre obj)  (display (match:prefix match) port))
 157                         ((eq? 'post obj) (display (match:suffix match) port))
 158                         (else (error 'wrong-type-arg obj))))
 159                 items)))
 160
 161 ;;; If we call fold-matches, below, with a regexp that can match the
 162 ;;; empty string, it's not obvious what "all the matches" means.  How
 163 ;;; many empty strings are there in the string "a"?  Our answer:
 164 ;;;
 165 ;;;     This function applies PROC to every non-overlapping, maximal
 166 ;;;     match of REGEXP in STRING.
 167 ;;;
 168 ;;; "non-overlapping": There are two non-overlapping matches of "" in
 169 ;;; "a" --- one before the `a', and one after.  There are three
 170 ;;; non-overlapping matches of "q|x*" in "aqb": the empty strings
 171 ;;; before `a' and after `b', and `q'.  The two empty strings before
 172 ;;; and after `q' don't count, because they overlap with the match of
 173 ;;; "q".
 174 ;;;
 175 ;;; "maximal": There are three distinct maximal matches of "x*" in
 176 ;;; "axxxb": one before the `a', one covering `xxx', and one after the
 177 ;;; `b'.  Around or within `xxx', only the match covering all three
 178 ;;; x's counts, because the rest are not maximal.
 179
 180 (define (fold-matches regexp string init proc . flags)
 181   (let ((regexp (if (regexp? regexp) regexp (make-regexp regexp)))
 182         (flags (if (null? flags) 0 flags)))
 183     (let loop ((start 0)
 184                (value init)
 185                (abuts #f))              ; True if start abuts a previous match.
 186       (let ((m (if (> start (string-length string)) #f
 187                    (regexp-exec regexp string start flags))))
 188         (cond
 189          ((not m) value)
 190          ((and (= (match:start m) (match:end m)) abuts)
 191           ;; We matched an empty string, but that would overlap the
 192           ;; match immediately before.  Try again at a position
 193           ;; further to the right.
 194           (loop (+ start 1) value #f))
 195          (else
 196           (loop (match:end m) (proc m value) #t)))))))
 197
 198 (define (list-matches regexp string . flags)
 199   (reverse! (apply fold-matches regexp string '() cons flags)))
 200
 201 (define (regexp-substitute/global port regexp string . items)
 202
 203   ;; If `port' is #f, send output to a string.
 204   (if (not port)
 205       (call-with-output-string
 206        (lambda (p)
 207          (apply regexp-substitute/global p regexp string items)))
 208
 209       ;; Walk the set of non-overlapping, maximal matches.
 210       (let next-match ((matches (list-matches regexp string))
 211                        (start 0))
 212         (if (null? matches)
 213             (display (substring string start) port)
 214             (let ((m (car matches)))
 215
 216               ;; Process all of the items for this match.  Don't use
 217               ;; for-each, because we need to make sure 'post at the
 218               ;; end of the item list is a tail call.
 219               (let next-item ((items items))
 220
 221                 (define (do-item item)
 222                   (cond
 223                    ((string? item)    (display item port))
 224                    ((integer? item)   (display (match:substring m item) port))
 225                    ((procedure? item) (display (item m) port))
 226                    ((eq? item 'pre)
 227                     (display
 228                      (substring string start (match:start m))
 229                      port))
 230                    ((eq? item 'post)
 231                     (next-match (cdr matches) (match:end m)))
 232                    (else (error 'wrong-type-arg item))))
 233
 234                 (if (pair? items)
 235                     (if (null? (cdr items))
 236                         (do-item (car items)) ; This is a tail call.
 237                         (begin
 238                           (do-item (car items)) ; This is not.
 239                           (next-item (cdr items)))))))))))