220 lines
8.1 KiB
Scheme
220 lines
8.1 KiB
Scheme
;;;
|
||
;;; Copyright (c) 1985 Massachusetts Institute of Technology
|
||
;;;
|
||
;;; This material was developed by the Scheme project at the
|
||
;;; Massachusetts Institute of Technology, Department of
|
||
;;; Electrical Engineering and Computer Science. Permission to
|
||
;;; copy this software, to redistribute it, and to use it for any
|
||
;;; purpose is granted, subject to the following restrictions and
|
||
;;; understandings.
|
||
;;;
|
||
;;; 1. Any copy made of this software must include this copyright
|
||
;;; notice in full.
|
||
;;;
|
||
;;; 2. Users of this software agree to make their best efforts (a)
|
||
;;; to return to the MIT Scheme project any improvements or
|
||
;;; extensions that they make, so that these may be included in
|
||
;;; future releases; and (b) to inform MIT of noteworthy uses of
|
||
;;; this software.
|
||
;;;
|
||
;;; 3. All materials developed as a consequence of the use of
|
||
;;; this software shall duly acknowledge such use, in accordance
|
||
;;; with the usual standards of acknowledging credit in academic
|
||
;;; research.
|
||
;;;
|
||
;;; 4. MIT has made no warrantee or representation that the
|
||
;;; operation of this software will be error-free, and MIT is
|
||
;;; under no obligation to provide any services, by way of
|
||
;;; maintenance, update, or otherwise.
|
||
;;;
|
||
;;; 5. In conjunction with products arising from the use of this
|
||
;;; material, there shall be no use of the name of the
|
||
;;; Massachusetts Institute of Technology nor of any adaptation
|
||
;;; thereof in any advertising, promotional, or sales literature
|
||
;;; without prior written consent from MIT in each case.
|
||
;;;
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;;;
|
||
;;; Modified by Texas Instruments Inc 8/15/85
|
||
;;;
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
||
|
||
;;;; String Match
|
||
|
||
(define (match-next-strings start end strings)
|
||
(define (loop strings)
|
||
(and (not (null? strings))
|
||
(or (match-next-string start end (car strings))
|
||
(loop (cdr strings)))))
|
||
(loop strings))
|
||
|
||
(define (match-next-string start end string)
|
||
(match-next-substring start end string 0 (string-length string)))
|
||
|
||
(define (substring-next-newlines string start end)
|
||
(define (loop start)
|
||
(let ((newline (substring-find-next-char string start end #\newline)))
|
||
(if (not newline)
|
||
(list (- end start))
|
||
(cons newline (loop (1+ newline))))))
|
||
(loop start))
|
||
|
||
(define (match-previous-strings start end strings)
|
||
(define (loop strings)
|
||
(and (not (null? strings))
|
||
(or (match-previous-string start end (car strings))
|
||
(loop (cdr strings)))))
|
||
(loop strings))
|
||
|
||
(define (match-previous-string start end string)
|
||
(match-previous-substring start end string 0 (string-length string)))
|
||
|
||
(define (substring-previous-newlines string start end)
|
||
(define (loop end)
|
||
(let ((newline
|
||
(substring-find-previous-char string start end #\newline)))
|
||
(if (not newline)
|
||
(list (- end start))
|
||
(cons (1+ newline) (loop newline)))))
|
||
(loop end))
|
||
|
||
(define (match-next-substring start-mark end-mark string start end)
|
||
(let ((newlines (substring-next-newlines string start end))
|
||
(start-line (mark-line start-mark))
|
||
(start-position (mark-position start-mark))
|
||
(end-line (mark-line end-mark))
|
||
(end-position (mark-position end-mark)))
|
||
(define (match-rest line start newlines)
|
||
(cond ((eq? line end-line)
|
||
(and (null? (cdr newlines))
|
||
(<= (car newlines) end-position)
|
||
(substring-equal-ci? string start end
|
||
(line-string line) 0
|
||
(car newlines))
|
||
(make-mark line (car newlines))))
|
||
((null? (cdr newlines))
|
||
(and (<= (car newlines) (line-length line))
|
||
(substring-equal-ci? string start end
|
||
(line-string line) 0
|
||
(car newlines))
|
||
(make-mark line (car newlines))))
|
||
(else
|
||
(and (substring-equal-ci? string start (car newlines)
|
||
(line-string line) 0
|
||
(line-length line))
|
||
(match-rest (line-next line)
|
||
(1+ (car newlines))
|
||
(cdr newlines))))))
|
||
|
||
(cond ((eq? start-line end-line)
|
||
(and (null? (cdr newlines))
|
||
(let ((end-position* (+ start-position (car newlines))))
|
||
(and (<= end-position* end-position)
|
||
(substring-equal-ci? string start end
|
||
(line-string start-line)
|
||
start-position
|
||
end-position*)
|
||
(make-mark start-line end-position*)))))
|
||
((null? (cdr newlines))
|
||
(let ((end-position* (+ start-position (car newlines))))
|
||
(and (<= end-position* (line-length start-line))
|
||
(substring-equal-ci? string start end
|
||
(line-string start-line)
|
||
start-position
|
||
end-position*)
|
||
(make-mark start-line end-position*))))
|
||
(else
|
||
(and (substring-equal-ci? string start (car newlines)
|
||
(line-string start-line)
|
||
start-position
|
||
(line-length start-line))
|
||
(match-rest (line-next start-line)
|
||
(1+ (car newlines))
|
||
(cdr newlines)))))))
|
||
|
||
(define (match-previous-substring start-mark end-mark string start end)
|
||
;; Here START-MARK must come after END-MARK in the mark ordering.
|
||
;; The match begins at START-MARK and proceeds back until END-MARK.
|
||
(let ((newlines (substring-previous-newlines string start end))
|
||
(start-line (mark-line start-mark))
|
||
(start-position (mark-position start-mark))
|
||
(end-line (mark-line end-mark))
|
||
(end-position (mark-position end-mark)))
|
||
(define (match-rest line end newlines)
|
||
(cond ((eq? line end-line)
|
||
(and (null? (cdr newlines))
|
||
(<= end-position (car newlines))
|
||
(substring-equal-ci? string start end
|
||
(line-string line) (car newlines)
|
||
(line-length line))
|
||
(make-mark line (car newlines))))
|
||
((null? (cdr newlines))
|
||
(and (<= 0 (car newlines))
|
||
(substring-equal-ci? string start end
|
||
(line-string line) (car newlines)
|
||
(line-length line))
|
||
(make-mark line (car newlines))))
|
||
(else
|
||
(and (substring-equal-ci? string (car newlines) end
|
||
(line-string line) 0
|
||
(line-length line))
|
||
(match-rest (line-next line)
|
||
(-1+ (car newlines))
|
||
(cdr newlines))))))
|
||
|
||
(cond ((eq? start-line end-line)
|
||
(and (null? (cdr newlines))
|
||
(let ((end-position* (- start-position (car newlines))))
|
||
(and (<= end-position end-position*)
|
||
(substring-equal-ci? string start end
|
||
(line-string start-line)
|
||
end-position* start-position)
|
||
(make-mark start-line end-position*)))))
|
||
((null? (cdr newlines))
|
||
(let ((end-position* (- start-position (car newlines))))
|
||
(and (<= 0 end-position*)
|
||
(substring-equal-ci? string start end
|
||
(line-string start-line)
|
||
end-position* start-position)
|
||
(make-mark start-line end-position*))))
|
||
(else
|
||
(and (substring-equal-ci? string (car newlines) end
|
||
(line-string start-line) 0
|
||
start-position)
|
||
(match-rest (line-next start-line)
|
||
(-1+ (car newlines))
|
||
(cdr newlines)))))))
|
||
|
||
;;;; Character Match
|
||
|
||
(define (match-next-char start end char)
|
||
(and (mark< start end)
|
||
(let ((line (mark-line start))
|
||
(position (mark-position start)))
|
||
(if (= position (line-length line))
|
||
(and (char=? char #\newline)
|
||
(make-mark (line-next line) 0))
|
||
(and (char=? char (string-ref (line-string line) position))
|
||
(make-mark line (1+ position)))))))
|
||
|
||
(define (match-previous-char start end char)
|
||
(and (mark> start end)
|
||
(let ((line (mark-line start))
|
||
(position (-1+ (mark-position start))))
|
||
(if (negative? position)
|
||
(and (char=? char #\newline)
|
||
(make-mark (line-previous line)
|
||
(line-length (line-previous line))))
|
||
(and (char=? char (string-ref (line-string line) position))
|
||
(make-mark line position))))))
|
||
|
||
(define (match-next-char-in-set start end char-set)
|
||
(and (mark< start end)
|
||
(char-set-member? char-set (mark-right-char start))
|
||
(mark1+ start #!false)))
|
||
|
||
(define (match-previous-char-in-set start end char-set)
|
||
(and (mark> start end)
|
||
(char-set-member? char-set (mark-left-char start))
|
||
(mark-1+ start #!false))) |