2021-04-26 07:53:20 -04:00
|
|
|
|
#| -*-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
|
|
|
|
|
|
2021-04-26 07:57:47 -04:00
|
|
|
|
|
2021-04-26 07:53:20 -04:00
|
|
|
|
|
|
|
|
|
;;;; 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))
|
2021-04-26 07:57:47 -04:00
|
|
|
|
0))))
|