mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-29 14:30:34 +02:00
Code Activity

untabify (ice-9 regex)

Browse source 
* module/ice-9/regex.scm: Untabify.
This commit is contained in:
Andy Wingo 2010-07-08 17:13:08 +01:00
parent ab6becd47f
commit bd6fed8e23
1 changed files with 81 additions and 81 deletions
Download patch file Download diff file Expand all files Collapse all files

162
module/ice-9/regex.scm
View file

@ -1,4 +1,4 @@
;;;; Copyright (C) 1997, 1999, 2001, 2004, 2005, 2006, 2008 Free Software Foundation, Inc.
;;;; Copyright (C) 1997, 1999, 2001, 2004, 2005, 2006, 2008, 2010 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@ -38,10 +38,10 @@
;;;; POSIX regex support functions.
(define-module (ice-9 regex)
:export (match:count match:string match:prefix match:suffix
regexp-match? regexp-quote match:start match:end match:substring
string-match regexp-substitute fold-matches list-matches
regexp-substitute/global))
#:export (match:count match:string match:prefix match:suffix
regexp-match? regexp-quote match:start match:end match:substring
string-match regexp-substitute fold-matches list-matches
regexp-substitute/global))
;; References:
;;
@ -76,12 +76,12 @@
(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)))))
(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)))))
;; * . \ ^ $ and [ are special in both regexp/basic and regexp/extended and
;; can be backslash escaped.
@ -102,43 +102,43 @@
(call-with-output-string
(lambda (p)
(string-for-each (lambda (c)
(case c
((#\* #\. #\\ #\^ #\$ #\[)
(write-char #\\ p)
(write-char c p))
((#\( #\) #\+ #\? #\{ #\} #\|)
(write-char #\[ p)
(write-char c p)
(write-char #\] p))
(else
(write-char c p))))
string))))
(case c
((#\* #\. #\\ #\^ #\$ #\[)
(write-char #\\ p)
(write-char c p))
((#\( #\) #\+ #\? #\{ #\} #\|)
(write-char #\[ p)
(write-char c p)
(write-char #\] p))
(else
(write-char c p))))
string))))
(define (match:start match . args)
(let* ((matchnum (if (pair? args)
(+ 1 (car args))
1))
(start (car (vector-ref match matchnum))))
(+ 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))))
(+ 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)))
(car args)
0))
(start (match:start match matchnum))
(end (match:end match matchnum)))
(and start end (substring (match:string match) start end))))
(define (string-match pattern str . args)
(let ((rx (make-regexp pattern))
(start (if (pair? args) (car args) 0)))
(start (if (pair? args) (car args) 0)))
(regexp-exec rx str start)))
(define (regexp-substitute port match . items)
@ -146,22 +146,22 @@
(if (not port)
(call-with-output-string
(lambda (p)
(apply regexp-substitute p match items)))
(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)))
(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)))
;;; If we call fold-matches, below, with a regexp that can match the
;;; empty string, it's not obvious what "all the matches" means. How
;;; many empty strings are there in the string "a"? Our answer:
;;;
;;; This function applies PROC to every non-overlapping, maximal
;;; This function applies PROC to every non-overlapping, maximal
;;; match of REGEXP in STRING.
;;;
;;; "non-overlapping": There are two non-overlapping matches of "" in
@ -178,21 +178,21 @@
(define (fold-matches regexp string init proc . flags)
(let ((regexp (if (regexp? regexp) regexp (make-regexp regexp)))
(flags (if (null? flags) 0 (car flags))))
(flags (if (null? flags) 0 (car flags))))
(let loop ((start 0)
(value init)
(abuts #f)) ; True if start abuts a previous match.
(value init)
(abuts #f)) ; True if start abuts a previous match.
(let ((m (if (> start (string-length string)) #f
(regexp-exec regexp string start flags))))
(cond
((not m) value)
((and (= (match:start m) (match:end m)) abuts)
;; We matched an empty string, but that would overlap the
;; match immediately before. Try again at a position
;; further to the right.
(loop (+ start 1) value #f))
(else
(loop (match:end m) (proc m value) #t)))))))
(regexp-exec regexp string start flags))))
(cond
((not m) value)
((and (= (match:start m) (match:end m)) abuts)
;; We matched an empty string, but that would overlap the
;; match immediately before. Try again at a position
;; further to the right.
(loop (+ start 1) value #f))
(else
(loop (match:end m) (proc m value) #t)))))))
(define (list-matches regexp string . flags)
(reverse! (apply fold-matches regexp string '() cons flags)))
@ -203,36 +203,36 @@
(if (not port)
(call-with-output-string
(lambda (p)
(apply regexp-substitute/global p regexp string items)))
(apply regexp-substitute/global p regexp string items)))
;; Walk the set of non-overlapping, maximal matches.
(let next-match ((matches (list-matches regexp string))
(start 0))
(if (null? matches)
(display (substring string start) port)
(let ((m (car matches)))
(start 0))
(if (null? matches)
(display (substring string start) port)
(let ((m (car matches)))
;; Process all of the items for this match. Don't use
;; for-each, because we need to make sure 'post at the
;; end of the item list is a tail call.
(let next-item ((items items))
;; Process all of the items for this match. Don't use
;; for-each, because we need to make sure 'post at the
;; end of the item list is a tail call.
(let next-item ((items items))
(define (do-item item)
(cond
((string? item) (display item port))
((integer? item) (display (match:substring m item) port))
((procedure? item) (display (item m) port))
((eq? item 'pre)
(display
(substring string start (match:start m))
port))
((eq? item 'post)
(next-match (cdr matches) (match:end m)))
(else (error 'wrong-type-arg item))))
(define (do-item item)
(cond
((string? item) (display item port))
((integer? item) (display (match:substring m item) port))
((procedure? item) (display (item m) port))
((eq? item 'pre)
(display
(substring string start (match:start m))
port))
((eq? item 'post)
(next-match (cdr matches) (match:end m)))
(else (error 'wrong-type-arg item))))
(if (pair? items)
(if (null? (cdr items))
(do-item (car items)) ; This is a tail call.
(begin
(do-item (car items)) ; This is not.
(next-item (cdr items)))))))))))
(if (pair? items)
(if (null? (cdr items))
(do-item (car items)) ; This is a tail call.
(begin
(do-item (car items)) ; This is not.
(next-item (cdr items)))))))))))