199 lines
6.3 KiB
Scheme
199 lines
6.3 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.
|
||
|
||
|#
|
||
|
||
;;;; Motion within Groups
|
||
|
||
|
||
|
||
;;;; Motion by Characters
|
||
|
||
(define (limit-mark-motion limit? limit)
|
||
(cond ((eq? limit? 'LIMIT) limit)
|
||
((eq? limit? 'BEEP) (editor-beep) limit)
|
||
((eq? limit? 'FAILURE) (editor-failure) limit)
|
||
((eq? limit? 'ERROR) (editor-error))
|
||
((not limit?) false)
|
||
(else (error "Unknown limit type:" limit?))))
|
||
|
||
(define (mark1+ mark #!optional limit?)
|
||
(let ((group (mark-group mark))
|
||
(index (mark-index mark)))
|
||
(if (group-end-index? group index)
|
||
(limit-mark-motion (and (not (default-object? limit?)) limit?)
|
||
(group-end-mark group))
|
||
(make-mark group (fix:+ index 1)))))
|
||
|
||
(define (mark-1+ mark #!optional limit?)
|
||
(let ((group (mark-group mark))
|
||
(index (mark-index mark)))
|
||
(if (group-start-index? group index)
|
||
(limit-mark-motion (and (not (default-object? limit?)) limit?)
|
||
(group-start-mark group))
|
||
(make-mark group (fix:- index 1)))))
|
||
|
||
(define (region-count-chars region)
|
||
(fix:- (region-end-index region) (region-start-index region)))
|
||
|
||
(define mark+)
|
||
(define mark-)
|
||
(let ()
|
||
|
||
(define (%mark+ mark n limit?)
|
||
(let ((group (mark-group mark))
|
||
(new-index (fix:+ (mark-index mark) n)))
|
||
(if (fix:> new-index (group-end-index group))
|
||
(limit-mark-motion limit? (group-end-mark group))
|
||
(make-mark group new-index))))
|
||
|
||
(define (%mark- mark n limit?)
|
||
(let ((group (mark-group mark))
|
||
(new-index (fix:- (mark-index mark) n)))
|
||
(if (fix:< new-index (group-start-index group))
|
||
(limit-mark-motion limit? (group-start-mark group))
|
||
(make-mark group new-index))))
|
||
|
||
(set! mark+
|
||
(named-lambda (mark+ mark n #!optional limit?)
|
||
(let ((limit? (and (not (default-object? limit?)) limit?)))
|
||
(cond ((fix:positive? n) (%mark+ mark n limit?))
|
||
((fix:negative? n) (%mark- mark (fix:- 0 n) limit?))
|
||
(else mark)))))
|
||
|
||
(set! mark-
|
||
(named-lambda (mark- mark n #!optional limit?)
|
||
(let ((limit? (and (not (default-object? limit?)) limit?)))
|
||
(cond ((fix:positive? n) (%mark- mark n limit?))
|
||
((fix:negative? n) (%mark+ mark (fix:- 0 n) limit?))
|
||
(else mark)))))
|
||
|
||
)
|
||
|
||
;;;; Motion by Lines
|
||
|
||
(define (line-start-index group index)
|
||
(let ((limit (group-start-index group)))
|
||
(let ((index (group-find-previous-char group limit index #\newline)))
|
||
(if index
|
||
(fix:+ index 1)
|
||
limit))))
|
||
|
||
(define (line-end-index group index)
|
||
(let ((limit (group-end-index group)))
|
||
(or (group-find-next-char group index limit #\newline)
|
||
limit)))
|
||
|
||
(define (line-start-index? group index)
|
||
(or (group-start-index? group index)
|
||
(char=? (group-left-char group index) #\newline)))
|
||
|
||
(define (line-end-index? group index)
|
||
(or (group-end-index? group index)
|
||
(char=? (group-right-char group index) #\newline)))
|
||
|
||
(define (line-start mark n #!optional limit?)
|
||
(let ((group (mark-group mark))
|
||
(lose
|
||
(lambda (mark)
|
||
(limit-mark-motion (and (not (default-object? limit?)) limit?)
|
||
mark))))
|
||
(if (fix:> n 0)
|
||
(let ((limit (group-end-index group)))
|
||
(let loop ((i (mark-index mark)) (n n))
|
||
(let ((j (group-find-next-char group i limit #\newline)))
|
||
(cond ((not j) (lose (group-end-mark group)))
|
||
((fix:= n 1) (make-mark group (fix:+ j 1)))
|
||
(else (loop (fix:+ j 1) (fix:- n 1)))))))
|
||
(let ((limit (group-start-index group)))
|
||
(let loop ((i (mark-index mark)) (n n))
|
||
(let ((j (group-find-previous-char group limit i #\newline)))
|
||
(cond ((fix:= n 0) (make-mark group (if j (fix:+ j 1) limit)))
|
||
((not j) (lose (group-start-mark group)))
|
||
(else (loop j (fix:+ n 1))))))))))
|
||
|
||
(define (line-end mark n #!optional limit?)
|
||
(let ((group (mark-group mark))
|
||
(lose
|
||
(lambda (mark)
|
||
(limit-mark-motion (and (not (default-object? limit?)) limit?)
|
||
mark))))
|
||
(if (fix:< n 0)
|
||
(let ((limit (group-start-index group)))
|
||
(let loop ((i (mark-index mark)) (n n))
|
||
(let ((j (group-find-previous-char group limit i #\newline)))
|
||
(cond ((not j) (lose (group-start-mark group)))
|
||
((fix:= n -1) (make-mark group j))
|
||
(else (loop j (fix:+ n 1)))))))
|
||
(let ((limit (group-end-index group)))
|
||
(let loop ((i (mark-index mark)) (n n))
|
||
(let ((j (group-find-next-char group i limit #\newline)))
|
||
(cond ((fix:= n 0) (make-mark group (or j limit)))
|
||
((not j) (lose (group-end-mark group)))
|
||
(else (loop (fix:+ j 1) (fix:- n 1))))))))))
|
||
|
||
(define (line-start? mark)
|
||
(line-start-index? (mark-group mark) (mark-index mark)))
|
||
|
||
(define (line-end? mark)
|
||
(line-end-index? (mark-group mark) (mark-index mark)))
|
||
|
||
(define (region-count-lines region)
|
||
(group-count-lines (region-group region)
|
||
(region-start-index region)
|
||
(region-end-index region)))
|
||
|
||
(define (group-count-lines group start end)
|
||
(let loop ((start start) (n 0))
|
||
(cond ((fix:= start end) n)
|
||
((group-find-next-char group start end #\newline)
|
||
=> (lambda (i) (loop (fix:+ i 1) (fix:+ n 1))))
|
||
(else (fix:+ n 1)))))
|
||
|
||
;;;; Motion by Columns
|
||
|
||
(define (mark-column mark)
|
||
(let ((group (mark-group mark))
|
||
(index (mark-index mark)))
|
||
(group-columns group
|
||
(line-start-index group index)
|
||
index
|
||
0
|
||
(group-tab-width group)
|
||
(group-char-image-strings group))))
|
||
|
||
(define (move-to-column mark column)
|
||
(let ((group (mark-group mark))
|
||
(index (mark-index mark)))
|
||
(make-mark
|
||
group
|
||
(vector-ref (group-column->index group
|
||
(line-start-index group index)
|
||
(group-end-index group)
|
||
0
|
||
column
|
||
(group-tab-width group)
|
||
(group-char-image-strings group))
|
||
0))))
|