278 lines
9.6 KiB
Scheme
278 lines
9.6 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
|
||
;;;
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
||
;;;; Searches
|
||
|
||
;;; **** For the time being all search and match operations are case
|
||
;;; insensitive. This needs to be fixed later. Also, the code has
|
||
;;; been bummed to know that strings are implemented as vectors of
|
||
;;; ASCII, and that char-sets are implemented as vectors of numbers.
|
||
|
||
;;;; Character Search
|
||
|
||
(define (make-find-next-char substring-find-next-char)
|
||
(lambda (start end char)
|
||
(let ((start-line (mark-line start))
|
||
(end-line (mark-line end)))
|
||
(define (loop line)
|
||
(if (eq? line end-line)
|
||
(let ((index
|
||
(substring-find-next-char (line-string line)
|
||
0
|
||
(mark-position end)
|
||
char)))
|
||
(and index (make-mark line index)))
|
||
(or (let ((index
|
||
(substring-find-next-char (line-string line)
|
||
0
|
||
(line-length line)
|
||
char)))
|
||
(and index (make-mark line index)))
|
||
(loop (line-next line)))))
|
||
(cond ((char=? #\newline char)
|
||
(and (not (eq? start-line end-line))
|
||
(make-mark start-line (line-length start-line))))
|
||
((eq? start-line end-line)
|
||
(let ((index
|
||
(substring-find-next-char (line-string start-line)
|
||
(mark-position start)
|
||
(mark-position end)
|
||
char)))
|
||
(and index (make-mark start-line index))))
|
||
(else
|
||
(or (let ((index
|
||
(substring-find-next-char (line-string start-line)
|
||
(mark-position start)
|
||
(line-length start-line)
|
||
char)))
|
||
(and index (make-mark start-line index)))
|
||
(loop (line-next start-line))))))))
|
||
|
||
(define find-next-char
|
||
(make-find-next-char substring-find-next-char-ci))
|
||
|
||
(define (find-next-newline start end)
|
||
(and (not (eq? (mark-line start) (mark-line end)))
|
||
(make-mark (mark-line start) (line-length (mark-line start)))))
|
||
|
||
(define (make-find-previous-char substring-find-previous-char)
|
||
(lambda (start end char)
|
||
;; Here START must come after END in the mark ordering.
|
||
;; The search begins at START and proceeds back until END.
|
||
(let ((start-line (mark-line start))
|
||
(end-line (mark-line end)))
|
||
(define (loop line)
|
||
(if (eq? line end-line)
|
||
(let ((index
|
||
(substring-find-previous-char (line-string line)
|
||
(mark-position end)
|
||
(line-length line)
|
||
char)))
|
||
(and index (make-mark line (1+ index))))
|
||
(let ((index
|
||
(substring-find-previous-char (line-string line)
|
||
0
|
||
(line-length line)
|
||
char)))
|
||
(if index
|
||
(make-mark line (1+ index))
|
||
(loop (line-previous line))))))
|
||
(cond ((char=? #\newline char))
|
||
((eq? start-line end-line)
|
||
(let ((index
|
||
(substring-find-previous-char (line-string start-line)
|
||
(mark-position end)
|
||
(mark-position start)
|
||
char)))
|
||
(and index (make-mark start-line (1+ index)))))
|
||
(else
|
||
(let ((index
|
||
(substring-find-previous-char (line-string start-line)
|
||
0
|
||
(mark-position start)
|
||
char)))
|
||
(if index
|
||
(make-mark start-line (1+ index))
|
||
(loop (line-previous start-line)))))))))
|
||
|
||
(define find-previous-char
|
||
(make-find-previous-char substring-find-previous-char-ci))
|
||
|
||
(define (find-previous-newline start end)
|
||
(and (not (eq? (mark-line start) (mark-line end)))
|
||
(make-mark (mark-line start) 0)))
|
||
|
||
;;;; Character-set Search
|
||
|
||
(define ((char-set-forward-search char-set) start end limit?)
|
||
(or (find-next-char-in-set start end char-set)
|
||
(limit-mark-motion limit? end)))
|
||
|
||
(define ((char-set-backward-search char-set) start end limit?)
|
||
(or (find-previous-char-in-set start end char-set)
|
||
(limit-mark-motion limit? end)))
|
||
|
||
(define (find-next-char-in-set start end char-set)
|
||
(let ((line (mark-line start))
|
||
(position (mark-position start))
|
||
(end-line (mark-line end))
|
||
(char-set-length (string-length char-set)))
|
||
(define (loop line)
|
||
(if (eq? line end-line)
|
||
(let ((index
|
||
(substring-find-next-char-in-set (line-string line)
|
||
0
|
||
(mark-position end)
|
||
char-set)))
|
||
(and index (make-mark line index)))
|
||
(or (let ((index
|
||
(substring-find-next-char-in-set (line-string line)
|
||
0
|
||
(line-length line)
|
||
char-set)))
|
||
(and index (make-mark line index)))
|
||
(loop (line-next line)))))
|
||
(if (eq? line end-line)
|
||
(let ((index
|
||
(substring-find-next-char-in-set (line-string line)
|
||
position
|
||
(mark-position end)
|
||
char-set)))
|
||
(and index (make-mark line index)))
|
||
(or (let ((index
|
||
(substring-find-next-char-in-set (line-string line)
|
||
position
|
||
(line-length line)
|
||
char-set)))
|
||
(and index (make-mark line index)))
|
||
;;; (if (char-set-member? char-set #\Newline)
|
||
(if (substring-find-next-char-in-set char-set 0 char-set-length
|
||
#\newline)
|
||
(make-mark line (line-length line))
|
||
(loop (line-next line)))))))
|
||
|
||
(define (find-previous-char-in-set start end char-set)
|
||
;; Here START must come after END in the mark ordering.
|
||
;; The search begins at START and proceeds back until END.
|
||
(let ((line (mark-line start))
|
||
(position (mark-position start))
|
||
(end-line (mark-line end))
|
||
(char-set-length (string-length char-set)))
|
||
(define (loop line)
|
||
(if (eq? line end-line)
|
||
(let ((index
|
||
(substring-find-previous-char-in-set (line-string line)
|
||
(mark-position end)
|
||
(line-length line)
|
||
char-set)))
|
||
(and index (make-mark line (1+ index))))
|
||
(or (let ((index
|
||
(substring-find-previous-char-in-set (line-string line)
|
||
0
|
||
(line-length line)
|
||
char-set)))
|
||
(and index (make-mark line (1+ index))))
|
||
(loop (line-previous line)))))
|
||
(if (eq? line end-line)
|
||
(let ((index
|
||
(substring-find-previous-char-in-set (line-string line)
|
||
(mark-position end)
|
||
position
|
||
char-set)))
|
||
(and index (make-mark line (1+ index))))
|
||
(or (let ((index
|
||
(substring-find-previous-char-in-set (line-string line)
|
||
0
|
||
position
|
||
char-set)))
|
||
(and index (make-mark line (1+ index))))
|
||
;;; (if (char-set-member? char-set #\Newline)
|
||
(if (substring-find-next-char-in-set char-set 0 char-set-length
|
||
#\newline)
|
||
(make-mark line 0)
|
||
(loop (line-previous line)))))))
|
||
|
||
|
||
;;;; String Search
|
||
|
||
(define (find-next-string start-mark end-mark string)
|
||
(find-next-substring start-mark end-mark
|
||
string 0 (string-length string)))
|
||
|
||
(define (find-next-substring start-mark end-mark
|
||
string start end)
|
||
(if (= start end)
|
||
start-mark
|
||
(let ((start-bound (mark- end-mark (-1+ (- end start)) #!false)))
|
||
(define (find-first mark)
|
||
(let ((first-char (find-next-char mark start-bound
|
||
(string-ref string start))))
|
||
(and first-char
|
||
(if (match-next-substring first-char end-mark
|
||
string start end)
|
||
first-char
|
||
(find-first (mark1+ first-char #!false))))))
|
||
(and start-bound
|
||
(mark< start-mark start-bound)
|
||
(find-first start-mark)))))
|
||
|
||
(define (find-previous-string start-mark end-mark string)
|
||
(find-previous-substring start-mark end-mark
|
||
string 0 (string-length string)))
|
||
|
||
(define (find-previous-substring start-mark end-mark
|
||
string start end)
|
||
(if (= start end)
|
||
start-mark
|
||
(let ((start-bound (mark+ end-mark (-1+ (- end start)) #!false)))
|
||
(define (find-first mark)
|
||
(let ((first-char
|
||
(find-previous-char mark start-bound
|
||
(string-ref string (-1+ end)))))
|
||
(and first-char
|
||
(if (match-previous-substring first-char end-mark
|
||
string start end)
|
||
first-char
|
||
(find-first (mark-1+ first-char #!false))))))
|
||
(and start-bound
|
||
(mark> start-mark start-bound)
|
||
(find-first start-mark)))))
|
||
|