319 lines
10 KiB
Scheme
319 lines
10 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.
|
||
|
||
|#
|
||
|
||
;;;; Textual Entities
|
||
|
||
|
||
|
||
;;;; Motion Primitives
|
||
|
||
;;; This file "defines" various kinds of things like lines, pages,
|
||
;;; words, etc. The "definition" of a FOO entity consists of two
|
||
;;; procedures, FORWARD-FOO and BACKWARD-FOO, each of which takes
|
||
;;; three arguments: [1] a mark to start from, [2] the number of FOOs
|
||
;;; to traverse, and [3] a limit for LIMIT-MARK-MOTION. The value of
|
||
;;; the procedure should be either a mark or #F.
|
||
|
||
;;; If the number is positive, traverse that many FOOs in the given
|
||
;;; direction; if negative, in the opposite direction; and zero means
|
||
;;; don't move. It is assumed that no two FOOs overlap; they may or
|
||
;;; may not touch one another. When moving forward, stop to the right
|
||
;;; of the rightmost edge of the FOO. When moving backward, stop to
|
||
;;; the left of the leftmost edge.
|
||
|
||
;;; MAKE-MOTION-PAIR will generate these two procedures, given the
|
||
;;; simpler primitives to move forward or backward once.
|
||
|
||
(define (make-motion-pair forward-one-thing backward-one-thing receiver)
|
||
(define (forward-thing mark n #!optional limit?)
|
||
(let ((limit? (and (not (default-object? limit?)) limit?)))
|
||
(cond ((positive? n) (%forward-thing mark n limit?))
|
||
((negative? n) (%backward-thing mark (- n) limit?))
|
||
(else mark))))
|
||
|
||
(define (backward-thing mark n #!optional limit?)
|
||
(let ((limit? (and (not (default-object? limit?)) limit?)))
|
||
(cond ((positive? n) (%backward-thing mark n limit?))
|
||
((negative? n) (%forward-thing mark (- n) limit?))
|
||
(else mark))))
|
||
|
||
(define (%forward-thing mark n limit?)
|
||
(let loop ((mark mark) (n n))
|
||
(let ((end (forward-one-thing mark)))
|
||
(cond ((not end) (limit-mark-motion limit? (group-end mark)))
|
||
((= n 1) end)
|
||
(else (loop end (-1+ n)))))))
|
||
|
||
(define (%backward-thing mark n limit?)
|
||
(let loop ((mark mark) (n n))
|
||
(let ((start (backward-one-thing mark)))
|
||
(cond ((not start) (limit-mark-motion limit? (group-start mark)))
|
||
((= n 1) start)
|
||
(else (loop start (-1+ n)))))))
|
||
|
||
(receiver forward-thing backward-thing))
|
||
|
||
;;;; Generic Operations
|
||
|
||
(define (move-thing forward-thing argument limit?)
|
||
(set-current-point! (forward-thing (current-point) argument limit?)))
|
||
|
||
(define (move-thing-saving-point forward-thing argument limit?)
|
||
(push-current-mark! (current-point))
|
||
(move-thing forward-thing argument limit?))
|
||
|
||
(define (mark-thing forward-thing n limit?)
|
||
(push-current-mark! (forward-thing (current-point) n limit?)))
|
||
|
||
(define (kill-thing forward-thing n limit?)
|
||
(kill-region (forward-thing (current-point) n limit?)))
|
||
|
||
(define (transpose-things forward-thing n)
|
||
(cond ((> n 0)
|
||
(do ((i 0 (+ i 1)))
|
||
((= i n))
|
||
(let* ((m4
|
||
(mark-right-inserting-copy
|
||
(forward-thing (current-point) 1 'ERROR)))
|
||
(m2
|
||
(mark-left-inserting-copy (forward-thing m4 -1 'ERROR)))
|
||
(m1
|
||
(mark-left-inserting-copy (forward-thing m2 -1 'ERROR)))
|
||
(m3 (forward-thing m1 1 'ERROR)))
|
||
(set-current-point! m4)
|
||
(insert-string (extract-and-delete-string m1 m3) m4)
|
||
(insert-string (extract-and-delete-string m2 m4) m1)
|
||
(mark-temporary! m1)
|
||
(mark-temporary! m2)
|
||
(mark-temporary! m4))))
|
||
((< n 0)
|
||
(do ((i 0 (- i 1)))
|
||
((= i n))
|
||
(let* ((m2
|
||
(mark-left-inserting-copy
|
||
(forward-thing (current-point) -1 'ERROR)))
|
||
(m1 (mark-left-inserting-copy (forward-thing m2 -1 'ERROR)))
|
||
(m3 (forward-thing m1 1 'ERROR))
|
||
(m4 (mark-right-inserting-copy (forward-thing m2 1 'ERROR))))
|
||
(insert-string (extract-and-delete-string m1 m3) m4)
|
||
(insert-string (extract-and-delete-string m2 m4) m1)
|
||
(set-current-point! m1)
|
||
(mark-temporary! m1)
|
||
(mark-temporary! m2)
|
||
(mark-temporary! m4))))
|
||
(else
|
||
(let ((normalize
|
||
(lambda (m)
|
||
(forward-thing (forward-thing m 1 'ERROR) -1 'ERROR)))
|
||
(exchange
|
||
(lambda (m1 m2 set-m1! set-m2!)
|
||
(let ((m1 (mark-right-inserting-copy m1))
|
||
(m3 (forward-thing m1 1 'ERROR))
|
||
(m2 (mark-left-inserting-copy m2))
|
||
(m4
|
||
(mark-right-inserting-copy
|
||
(forward-thing m2 1 'ERROR))))
|
||
(insert-string (extract-and-delete-string m1 m3) m4)
|
||
(insert-string (extract-and-delete-string m2 m4) m1)
|
||
(set-m1! m4)
|
||
(set-m2! m1)
|
||
(mark-temporary! m1)
|
||
(mark-temporary! m2)
|
||
(mark-temporary! m4)))))
|
||
(let ((m1 (normalize (current-point)))
|
||
(m2 (normalize (current-mark))))
|
||
(cond ((mark< m1 m2)
|
||
(exchange m1 m2 set-current-mark! set-current-point!))
|
||
((mark< m2 m1)
|
||
(exchange m2 m1
|
||
set-current-point! set-current-mark!))))))))
|
||
|
||
;;;; Horizontal Space
|
||
|
||
(define (horizontal-space-region mark)
|
||
(make-region (horizontal-space-start mark)
|
||
(horizontal-space-end mark)))
|
||
|
||
(define (horizontal-space-start mark)
|
||
(skip-chars-backward " \t" mark))
|
||
|
||
(define (horizontal-space-end mark)
|
||
(skip-chars-forward " \t" mark))
|
||
|
||
(define (compute-horizontal-space c1 c2 tab-width)
|
||
;; Compute the number of tabs/spaces required to fill from column C1
|
||
;; to C2 with whitespace.
|
||
(if (< c1 c2)
|
||
(error:bad-range-argument c2 'COMPUTE-HORIZONTAL-SPACE))
|
||
(if tab-width
|
||
(let ((qr1 (integer-divide c1 tab-width))
|
||
(qr2 (integer-divide c2 tab-width)))
|
||
(if (> (integer-divide-quotient qr1) (integer-divide-quotient qr2))
|
||
(values (- (integer-divide-quotient qr1)
|
||
(integer-divide-quotient qr2))
|
||
(integer-divide-remainder qr1))
|
||
(values 0
|
||
(- (integer-divide-remainder qr1)
|
||
(integer-divide-remainder qr2)))))
|
||
(values 0 (- c1 c2))))
|
||
|
||
(define (insert-horizontal-space target-column #!optional point tab-width)
|
||
(let* ((point
|
||
(mark-left-inserting-copy
|
||
(if (default-object? point) (current-point) point)))
|
||
(tab-width
|
||
(if (default-object? tab-width)
|
||
(let ((buffer (mark-buffer point)))
|
||
(and buffer
|
||
(variable-local-value
|
||
buffer
|
||
(ref-variable-object indent-tabs-mode))
|
||
(variable-local-value
|
||
buffer
|
||
(ref-variable-object tab-width))))
|
||
tab-width)))
|
||
(call-with-values
|
||
(lambda ()
|
||
(compute-horizontal-space target-column
|
||
(mark-column point)
|
||
tab-width))
|
||
(lambda (n-tabs n-spaces)
|
||
(insert-chars #\tab n-tabs point)
|
||
(insert-chars #\space n-spaces point)))
|
||
(mark-temporary! point)))
|
||
|
||
(define (delete-horizontal-space #!optional point)
|
||
(let ((point (if (default-object? point) (current-point) point)))
|
||
(delete-string (horizontal-space-start point)
|
||
(horizontal-space-end point))))
|
||
|
||
(define (indent-to target-column #!optional minimum point)
|
||
(let ((minimum (if (default-object? minimum) 0 minimum))
|
||
(point (if (default-object? point) (current-point) point)))
|
||
(insert-horizontal-space (max target-column
|
||
(+ (mark-column point) minimum))
|
||
point)))
|
||
|
||
(define (region-blank? region)
|
||
(not (skip-chars-forward " \t"
|
||
(region-start region)
|
||
(region-end region)
|
||
false)))
|
||
|
||
(define (line-blank? mark)
|
||
(not (skip-chars-forward " \t"
|
||
(line-start mark 0)
|
||
(line-end mark 0)
|
||
false)))
|
||
|
||
(define (find-previous-blank-line mark)
|
||
(let ((start (line-start mark -1)))
|
||
(and start
|
||
(let loop ((mark start))
|
||
(cond ((line-blank? mark) mark)
|
||
((group-start? mark) false)
|
||
(else (loop (line-start mark -1))))))))
|
||
|
||
(define (find-next-blank-line mark)
|
||
(let ((start (line-start mark 1)))
|
||
(and start
|
||
(let loop ((mark start))
|
||
(cond ((line-blank? mark) mark)
|
||
((group-start? mark) false)
|
||
(else (loop (line-start mark 1))))))))
|
||
|
||
(define (find-previous-non-blank-line mark)
|
||
(let ((start (line-start mark -1)))
|
||
(and start
|
||
(let loop ((mark start))
|
||
(cond ((not (line-blank? mark)) mark)
|
||
((group-start? mark) false)
|
||
(else (loop (line-start mark -1))))))))
|
||
|
||
(define (find-next-non-blank-line mark)
|
||
(let ((start (line-start mark 1)))
|
||
(and start
|
||
(let loop ((mark start))
|
||
(cond ((not (line-blank? mark)) mark)
|
||
((group-start? mark) false)
|
||
(else (loop (line-start mark 1))))))))
|
||
|
||
;;;; Indentation
|
||
|
||
(define (maybe-change-indentation indentation #!optional point)
|
||
(let ((point (if (default-object? point) (current-point) point)))
|
||
(if (not (= indentation (mark-indentation point)))
|
||
(change-indentation indentation point))))
|
||
|
||
(define (change-indentation indentation point)
|
||
(change-column indentation (line-start point 0)))
|
||
|
||
(define (current-indentation #!optional point)
|
||
(mark-indentation (if (default-object? point) (current-point) point)))
|
||
|
||
(define (mark-indentation mark)
|
||
(mark-column (indentation-end mark)))
|
||
|
||
(define (indentation-end mark)
|
||
(horizontal-space-end (line-start mark 0)))
|
||
|
||
(define (within-indentation? mark)
|
||
(line-start? (horizontal-space-start mark)))
|
||
|
||
(define (maybe-change-column column #!optional point)
|
||
(let ((point (if (default-object? point) (current-point) point)))
|
||
(if (not (= column (mark-column point)))
|
||
(change-column column point))))
|
||
|
||
(define (change-column column mark)
|
||
(let ((mark (mark-left-inserting-copy mark)))
|
||
(delete-horizontal-space mark)
|
||
(insert-horizontal-space column mark)
|
||
(mark-temporary! mark)))
|
||
|
||
;;;; Lines
|
||
|
||
(define forward-line)
|
||
(define backward-line)
|
||
(let ((%backward-line
|
||
(lambda (mark n limit?)
|
||
(line-start mark
|
||
(if (line-start? mark) (- n) (- 1 n))
|
||
limit?))))
|
||
(set! forward-line
|
||
(lambda (mark n #!optional limit?)
|
||
(let ((limit? (and (not (default-object? limit?)) limit?)))
|
||
(cond ((positive? n) (line-start mark n limit?))
|
||
((negative? n) (%backward-line mark (- n) limit?))
|
||
(else mark)))))
|
||
(set! backward-line
|
||
(lambda (mark n #!optional limit?)
|
||
(let ((limit? (and (not (default-object? limit?)) limit?)))
|
||
(cond ((positive? n) (%backward-line mark n limit?))
|
||
((negative? n) (line-start mark (- n) limit?))
|
||
(else mark)))))
|
||
unspecific)
|