370 lines
12 KiB
Scheme
370 lines
12 KiB
Scheme
#| -*-Scheme-*-
|
||
|
||
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
|
||
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
|
||
2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
|
||
2017, 2018, 2019, 2020 Massachusetts Institute of Technology
|
||
|
||
This file is part of MIT/GNU Scheme.
|
||
|
||
MIT/GNU Scheme 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 of the License, or (at
|
||
your option) any later version.
|
||
|
||
MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
|
||
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
|
||
USA.
|
||
|
||
|#
|
||
|
||
;;;; Search/Match Primitives
|
||
|
||
|
||
|
||
(define-syntax define-next-char-search
|
||
(sc-macro-transformer
|
||
(lambda (form environment)
|
||
(let ((name (cadr form))
|
||
(find-next (close-syntax (caddr form) environment)))
|
||
`(define (,name group start end char)
|
||
;; Assume (FIX:<= START END)
|
||
(and (not (fix:= start end))
|
||
(cond ((fix:<= end (group-gap-start group))
|
||
(,find-next (group-text group) start end char))
|
||
((fix:<= (group-gap-start group) start)
|
||
(let ((position
|
||
(,find-next
|
||
(group-text group)
|
||
(fix:+ start (group-gap-length group))
|
||
(fix:+ end (group-gap-length group))
|
||
char)))
|
||
(and position
|
||
(fix:- position (group-gap-length group)))))
|
||
((,find-next (group-text group)
|
||
start
|
||
(group-gap-start group)
|
||
char))
|
||
(else
|
||
(let ((position
|
||
(,find-next (group-text group)
|
||
(group-gap-end group)
|
||
(fix:+ end
|
||
(group-gap-length group))
|
||
char)))
|
||
(and position
|
||
(fix:- position
|
||
(group-gap-length group))))))))))))
|
||
|
||
(define-next-char-search group-find-next-char
|
||
substring-find-next-char)
|
||
(define-next-char-search group-find-next-char-ci
|
||
substring-find-next-char-ci)
|
||
(define-next-char-search group-find-next-char-in-set
|
||
substring-find-next-char-in-set)
|
||
|
||
(define-syntax define-prev-char-search
|
||
(sc-macro-transformer
|
||
(lambda (form environment)
|
||
(let ((name (cadr form))
|
||
(find-previous (close-syntax (caddr form) environment)))
|
||
`(define (,name group start end char)
|
||
;; Assume (FIX:<= START END)
|
||
(and (not (fix:= start end))
|
||
(cond ((fix:<= end (group-gap-start group))
|
||
(,find-previous (group-text group) start end char))
|
||
((fix:<= (group-gap-start group) start)
|
||
(let ((position
|
||
(,find-previous
|
||
(group-text group)
|
||
(fix:+ start (group-gap-length group))
|
||
(fix:+ end (group-gap-length group))
|
||
char)))
|
||
(and position
|
||
(fix:- position (group-gap-length group)))))
|
||
((,find-previous (group-text group)
|
||
(group-gap-end group)
|
||
(fix:+ end (group-gap-length group))
|
||
char)
|
||
=> (lambda (position)
|
||
(fix:- position (group-gap-length group))))
|
||
(else
|
||
(,find-previous (group-text group)
|
||
start
|
||
(group-gap-start group)
|
||
char)))))))))
|
||
|
||
(define-prev-char-search group-find-previous-char
|
||
substring-find-previous-char)
|
||
(define-prev-char-search group-find-previous-char-ci
|
||
substring-find-previous-char-ci)
|
||
(define-prev-char-search group-find-previous-char-in-set
|
||
substring-find-previous-char-in-set)
|
||
|
||
(define-integrable (%find-next-newline group start end)
|
||
(group-find-next-char group start end #\newline))
|
||
|
||
(define-integrable (%find-previous-newline group start end)
|
||
;; Note reversal of index arguments here.
|
||
(let ((index (group-find-previous-char group end start #\newline)))
|
||
(and index
|
||
(fix:+ index 1))))
|
||
|
||
(define (group-match-substring-forward group start end
|
||
string string-start string-end)
|
||
(let ((text (group-text group))
|
||
(gap-start (group-gap-start group))
|
||
(gap-length (group-gap-length group)))
|
||
(let ((match
|
||
(lambda (s1 e1 s2)
|
||
(let loop ((i1 s1) (i2 s2))
|
||
(if (or (fix:= i1 e1)
|
||
(fix:= i2 string-end)
|
||
(not (char=? (string-ref text i1)
|
||
(string-ref string i2))))
|
||
i1
|
||
(loop (fix:+ i1 1) (fix:+ i2 1)))))))
|
||
(cond ((fix:<= end gap-start)
|
||
(match start end string-start))
|
||
((fix:<= gap-start start)
|
||
(fix:- (match (fix:+ start gap-length)
|
||
(fix:+ end gap-length)
|
||
string-start)
|
||
gap-length))
|
||
(else
|
||
(let ((index (match start gap-start string-start)))
|
||
(if (fix:= index gap-start)
|
||
(fix:- (match (fix:+ gap-start gap-length)
|
||
(fix:+ end gap-length)
|
||
(fix:+ string-start (fix:- gap-start start)))
|
||
gap-length)
|
||
index)))))))
|
||
|
||
(define (group-match-substring-backward group start end
|
||
string string-start string-end)
|
||
(let ((text (group-text group))
|
||
(gap-start (group-gap-start group))
|
||
(gap-length (group-gap-length group)))
|
||
(let ((match
|
||
(lambda (s1 e1 e2)
|
||
(let loop ((i1 (fix:- e1 1)) (i2 (fix:- e2 1)))
|
||
(cond ((not (char=? (string-ref text i1)
|
||
(string-ref string i2)))
|
||
(fix:+ i1 1))
|
||
((or (fix:= i1 s1) (fix:= i2 string-start))
|
||
i1)
|
||
(else
|
||
(loop (fix:- i1 1) (fix:- i2 1))))))))
|
||
(cond ((or (fix:= start end) (fix:= string-start string-end))
|
||
end)
|
||
((fix:<= end gap-start)
|
||
(match start end string-end))
|
||
((fix:<= gap-start start)
|
||
(fix:- (match (fix:+ start gap-length)
|
||
(fix:+ end gap-length)
|
||
string-end)
|
||
gap-length))
|
||
(else
|
||
(let ((index
|
||
(fix:- (match (fix:+ gap-start gap-length)
|
||
(fix:+ end gap-length)
|
||
string-end)
|
||
gap-length)))
|
||
(if (fix:= index gap-start)
|
||
(match start
|
||
gap-start
|
||
(fix:- string-end (fix:- end gap-start)))
|
||
index)))))))
|
||
|
||
(define (group-match-substring-forward-ci group start end
|
||
string string-start string-end)
|
||
(let ((text (group-text group))
|
||
(gap-start (group-gap-start group))
|
||
(gap-length (group-gap-length group)))
|
||
(let ((match
|
||
(lambda (s1 e1 s2)
|
||
(let loop ((i1 s1) (i2 s2))
|
||
(if (or (fix:= i1 e1)
|
||
(fix:= i2 string-end)
|
||
(not (char-ci=? (string-ref text i1)
|
||
(string-ref string i2))))
|
||
i1
|
||
(loop (fix:+ i1 1) (fix:+ i2 1)))))))
|
||
(cond ((fix:<= end gap-start)
|
||
(match start end string-start))
|
||
((fix:<= gap-start start)
|
||
(fix:- (match (fix:+ start gap-length)
|
||
(fix:+ end gap-length)
|
||
string-start)
|
||
gap-length))
|
||
(else
|
||
(let ((index (match start gap-start string-start)))
|
||
(if (fix:= index gap-start)
|
||
(fix:- (match (fix:+ gap-start gap-length)
|
||
(fix:+ end gap-length)
|
||
(fix:+ string-start (fix:- gap-start start)))
|
||
gap-length)
|
||
index)))))))
|
||
|
||
(define (group-match-substring-backward-ci group start end
|
||
string string-start string-end)
|
||
(let ((text (group-text group))
|
||
(gap-start (group-gap-start group))
|
||
(gap-length (group-gap-length group)))
|
||
(let ((match
|
||
(lambda (s1 e1 e2)
|
||
(let loop ((i1 (fix:- e1 1)) (i2 (fix:- e2 1)))
|
||
(cond ((not (char-ci=? (string-ref text i1)
|
||
(string-ref string i2)))
|
||
(fix:+ i1 1))
|
||
((or (fix:= i1 s1) (fix:= i2 string-start))
|
||
i1)
|
||
(else
|
||
(loop (fix:- i1 1) (fix:- i2 1))))))))
|
||
(cond ((or (fix:= start end) (fix:= string-start string-end))
|
||
end)
|
||
((fix:<= end gap-start)
|
||
(match start end string-end))
|
||
((fix:<= gap-start start)
|
||
(fix:- (match (fix:+ start gap-length)
|
||
(fix:+ end gap-length)
|
||
string-end)
|
||
gap-length))
|
||
(else
|
||
(let ((index
|
||
(fix:- (match (fix:+ gap-start gap-length)
|
||
(fix:+ end gap-length)
|
||
string-end)
|
||
gap-length)))
|
||
(if (fix:= index gap-start)
|
||
(match start
|
||
gap-start
|
||
(fix:- string-end (fix:- end gap-start)))
|
||
index)))))))
|
||
|
||
(define (char-search-forward char start end #!optional case-fold-search)
|
||
(let ((group (mark-group start))
|
||
(start-index (mark-index start))
|
||
(end-index (mark-index end)))
|
||
(if (not (and (eq? group (mark-group end))
|
||
(fix:<= start-index end-index)))
|
||
(error "Marks incorrectly related:" start end))
|
||
(let ((index
|
||
(if (default-case-fold-search case-fold-search start)
|
||
(group-find-next-char-ci group start-index end-index char)
|
||
(group-find-next-char group start-index end-index char))))
|
||
(and index
|
||
(make-mark group (fix:+ index 1))))))
|
||
|
||
(define (char-search-backward char start end #!optional case-fold-search)
|
||
(let ((group (mark-group start))
|
||
(start-index (mark-index start))
|
||
(end-index (mark-index end)))
|
||
(if (not (and (eq? group (mark-group end))
|
||
(fix:>= start-index end-index)))
|
||
(error "Marks incorrectly related:" start end))
|
||
(let ((index
|
||
(if (default-case-fold-search case-fold-search start)
|
||
(group-find-previous-char-ci group end-index start-index char)
|
||
(group-find-previous-char group end-index start-index char))))
|
||
(and index
|
||
(make-mark group index)))))
|
||
|
||
(define (char-match-forward char start #!optional end case-fold-search)
|
||
(and (mark< start (default-end-mark start end))
|
||
(let ((group (mark-group start)))
|
||
(if (default-case-fold-search case-fold-search start)
|
||
(char-ci=? char (group-right-char group (mark-index start)))
|
||
(char=? char (group-right-char group (mark-index start)))))))
|
||
|
||
(define (char-match-backward char end #!optional start case-fold-search)
|
||
(and (mark< (default-start-mark start end) end)
|
||
(let ((group (mark-group end)))
|
||
(if (default-case-fold-search case-fold-search end)
|
||
(char-ci=? char (group-left-char group (mark-index end)))
|
||
(char=? char (group-left-char group (mark-index end)))))))
|
||
|
||
(define (default-start-mark start end)
|
||
(if (default-object? start)
|
||
(group-start end)
|
||
(begin
|
||
(if (not (mark<= start end))
|
||
(error "Marks incorrectly related:" start end))
|
||
start)))
|
||
|
||
(define (default-end-mark start end)
|
||
(if (default-object? end)
|
||
(group-end start)
|
||
(begin
|
||
(if (not (mark<= start end))
|
||
(error "Marks incorrectly related:" start end))
|
||
end)))
|
||
|
||
(define (default-case-fold-search case-fold-search mark)
|
||
(if (default-object? case-fold-search)
|
||
(group-case-fold-search (mark-group mark))
|
||
case-fold-search))
|
||
|
||
(define (skip-chars-forward pattern #!optional start end limit?)
|
||
(let ((start (if (default-object? start) (current-point) start))
|
||
(limit? (if (default-object? limit?) 'limit limit?)))
|
||
(let ((end (default-end-mark start end)))
|
||
(let ((index
|
||
(group-find-next-char-in-set (mark-group start)
|
||
(mark-index start)
|
||
(mark-index end)
|
||
(re-compile-char-set pattern true))))
|
||
(if index
|
||
(make-mark (mark-group start) index)
|
||
(limit-mark-motion limit? end))))))
|
||
|
||
(define (skip-chars-backward pattern #!optional end start limit?)
|
||
(let ((end (if (default-object? end) (current-point) end))
|
||
(limit? (if (default-object? limit?) 'limit limit?)))
|
||
(let ((start (default-start-mark start end)))
|
||
(let ((index
|
||
(group-find-previous-char-in-set (mark-group start)
|
||
(mark-index start)
|
||
(mark-index end)
|
||
(re-compile-char-set pattern
|
||
true))))
|
||
(if index
|
||
(make-mark (mark-group start) (fix:+ index 1))
|
||
(limit-mark-motion limit? start))))))
|
||
|
||
(define (match-forward string start #!optional end case-fold-search)
|
||
(let ((end (default-end-mark start end))
|
||
(group (mark-group start))
|
||
(start-index (mark-index start))
|
||
(length (string-length string)))
|
||
(let ((i (fix:+ start-index length)))
|
||
(and (fix:<= i (mark-index end))
|
||
(fix:= (if (default-case-fold-search case-fold-search start)
|
||
(group-match-substring-forward-ci group start-index i
|
||
string 0 length)
|
||
(group-match-substring-forward group start-index i
|
||
string 0 length))
|
||
i)
|
||
(make-mark group i)))))
|
||
|
||
(define (match-backward string end #!optional start case-fold-search)
|
||
(let ((start (default-start-mark start end))
|
||
(group (mark-group end))
|
||
(end-index (mark-index end))
|
||
(length (string-length string)))
|
||
(let ((i (fix:- end-index length)))
|
||
(and (fix:>= i (mark-index start))
|
||
(fix:= (if (default-case-fold-search case-fold-search start)
|
||
(group-match-substring-backward-ci group i end-index
|
||
string 0 length)
|
||
(group-match-substring-backward group i end-index
|
||
string 0 length))
|
||
i)
|
||
(make-mark group i)))))
|