434 lines
14 KiB
Scheme
434 lines
14 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.
|
||
|
||
|#
|
||
|
||
;;;; Kill Commands
|
||
|
||
|
||
|
||
;;;; Deletion
|
||
|
||
(define (delete-region mark)
|
||
(if (not mark)
|
||
(editor-error "Delete exceeds buffer bounds"))
|
||
(delete-string mark (current-point)))
|
||
|
||
(define (kill-region mark)
|
||
(if (not mark)
|
||
(editor-error "Kill exceeds buffer bounds"))
|
||
(kill-string mark (current-point)))
|
||
|
||
(define-command delete-region
|
||
"Delete the text between point and mark."
|
||
"*r"
|
||
(lambda (region)
|
||
(region-delete! region)))
|
||
|
||
(define-command delete-backward-char
|
||
"Delete character before point.
|
||
With argument, kills several characters (saving them).
|
||
Negative args kill characters forward."
|
||
"P"
|
||
(lambda (argument)
|
||
(if (not argument)
|
||
(delete-region (mark-1+ (current-point)))
|
||
(kill-region
|
||
(mark- (current-point) (command-argument-value argument))))))
|
||
|
||
(define-command delete-char
|
||
"Delete character after point.
|
||
With argument, kill than many characters (saving them).
|
||
Negative args kill characters backward."
|
||
"P"
|
||
(lambda (argument)
|
||
(if (not argument)
|
||
(delete-region (mark1+ (current-point)))
|
||
(kill-region
|
||
(mark+ (current-point) (command-argument-value argument))))))
|
||
|
||
(define-command kill-line
|
||
"Kill to end of line, or kill an end of line.
|
||
At the end of a line (only blanks following) kill through the newline.
|
||
Otherwise, kill the rest of the line but not the newline.
|
||
With argument (positive or negative), kill specified number of lines.
|
||
An argument of zero means kill to beginning of line, nothing if at beginning.
|
||
Killed text is pushed onto the kill ring for retrieval."
|
||
"P"
|
||
(lambda (argument)
|
||
(let ((argument (command-argument-value argument))
|
||
(point (current-point)))
|
||
(kill-region
|
||
(cond ((not argument)
|
||
(let ((end (line-end point 0)))
|
||
(if (and (region-blank? (make-region point end))
|
||
(not (group-end? end)))
|
||
(mark1+ end)
|
||
end)))
|
||
((positive? argument)
|
||
(and (not (group-end? point))
|
||
(line-start point argument 'LIMIT)))
|
||
((zero? argument)
|
||
(line-start point 0))
|
||
(else
|
||
(and (not (group-start? point))
|
||
(line-start point
|
||
(if (line-start? point)
|
||
argument
|
||
(1+ argument))
|
||
'LIMIT))))))))
|
||
|
||
(define-command backward-delete-char-untabify
|
||
"Delete character before point, turning tabs into spaces.
|
||
Rather than deleting a whole tab, the tab is converted into the
|
||
appropriate number of spaces and then one space is deleted."
|
||
"P"
|
||
(lambda (argument)
|
||
(define (back n)
|
||
(let ((point (current-point)))
|
||
(let ((m1 (mark- point n 'LIMIT)))
|
||
(let ((tab (char-search-backward #\tab point m1)))
|
||
(if (not tab)
|
||
m1
|
||
(begin
|
||
(convert-tab-to-spaces! tab)
|
||
(back n)))))))
|
||
(define (forth n)
|
||
(let ((point (current-point)))
|
||
(let ((m1 (mark+ point n 'LIMIT)))
|
||
(let ((tab (char-search-forward #\tab point m1)))
|
||
(if (not tab)
|
||
m1
|
||
(begin
|
||
(convert-tab-to-spaces! (mark-1+ tab))
|
||
(forth n)))))))
|
||
(let ((argument (command-argument-value argument)))
|
||
(cond ((not argument)
|
||
(let ((point (current-point)))
|
||
(if (char-match-backward #\Tab point)
|
||
(convert-tab-to-spaces! (mark-1+ point))))
|
||
(delete-region (mark-1+ (current-point))))
|
||
((positive? argument)
|
||
(kill-region (back argument)))
|
||
((negative? argument)
|
||
(kill-region (forth (- argument))))))))
|
||
|
||
(define (convert-tab-to-spaces! m1)
|
||
(let ((at-point? (mark= m1 (current-point)))
|
||
(m2 (mark-left-inserting (mark1+ m1))))
|
||
(define (perform-replacement)
|
||
(let ((n (- (mark-column m2) (mark-column m1))))
|
||
(delete-string m1 m2)
|
||
(insert-string (make-string n #\space) m2)))
|
||
(if at-point?
|
||
(let ((start (mark-right-inserting m1)))
|
||
(perform-replacement)
|
||
(set-current-point! start))
|
||
(perform-replacement))))
|
||
|
||
;;;; Killing
|
||
|
||
(define-variable kill-ring-max
|
||
"Maximum length of kill ring before oldest elements are thrown away."
|
||
30
|
||
exact-nonnegative-integer?)
|
||
|
||
(define-variable kill-ring
|
||
"List of killed text sequences."
|
||
'())
|
||
|
||
(define-variable kill-ring-yank-pointer
|
||
"The tail of the kill ring whose car is the last thing yanked."
|
||
'())
|
||
|
||
(define-command kill-region
|
||
"Kill between point and mark.
|
||
The text is deleted but saved in the kill ring.
|
||
The command \\[yank] can retrieve it from there.
|
||
\(If you want to kill and then yank immediately, use \\[copy-region-as-kill].)"
|
||
"*m\nd"
|
||
(lambda (mark point)
|
||
(kill-string mark point)))
|
||
|
||
(define-command copy-region-as-kill
|
||
"Save the region as if killed, but don't kill it."
|
||
"m\nd"
|
||
(lambda (mark point)
|
||
(copy-string mark point)
|
||
(temporary-message "Region saved")))
|
||
|
||
(define-command append-next-kill
|
||
"Cause following command, if kill, to append to previous kill."
|
||
()
|
||
(lambda ()
|
||
(set-command-message! append-next-kill-tag)))
|
||
|
||
(define (kill-string mark #!optional point)
|
||
(let ((point (if (default-object? point) (current-point) point)))
|
||
(kill-ring-save (extract-string mark point) (mark<= point mark) point)
|
||
(delete-string mark point)))
|
||
|
||
(define (copy-string mark #!optional point)
|
||
(let ((point (if (default-object? point) (current-point) point)))
|
||
(kill-ring-save (extract-string mark point) (mark<= point mark) point)))
|
||
|
||
(define (os/interprogram-cut string context)
|
||
;; This dummy is re-assigned by the last display type loaded(!). It
|
||
;; needs to be a display type operation.
|
||
(declare (ignore string context))
|
||
unspecific)
|
||
|
||
(define (os/interprogram-paste point)
|
||
;; This dummy is re-assigned by the last display type loaded(!). It
|
||
;; needs to be a display type operation.
|
||
(declare (ignore point))
|
||
#f)
|
||
|
||
(define (kill-ring-save string forward? context)
|
||
(command-message-receive append-next-kill-tag
|
||
(lambda ()
|
||
(let ((kill-ring (ref-variable kill-ring)))
|
||
(if (null? kill-ring)
|
||
(editor-error "No previous kill"))
|
||
(let ((string
|
||
(if forward?
|
||
(string-append (car kill-ring) string)
|
||
(string-append string (car kill-ring)))))
|
||
(set-car! kill-ring string)
|
||
(set-variable! kill-ring-yank-pointer kill-ring context)
|
||
(os/interprogram-cut string context))))
|
||
(lambda ()
|
||
(kill-ring-save-1 string context)
|
||
(os/interprogram-cut string context)))
|
||
(set-command-message! append-next-kill-tag))
|
||
|
||
(define (kill-ring-save-1 string context)
|
||
(let ((strings
|
||
(let ((kill-ring (ref-variable kill-ring context))
|
||
(kill-ring-max (ref-variable kill-ring-max context)))
|
||
(if (zero? kill-ring-max)
|
||
'()
|
||
(let ((strings (cons string kill-ring)))
|
||
(if (> (length strings) kill-ring-max)
|
||
(set-cdr! (drop strings (- kill-ring-max 1)) '()))
|
||
strings)))))
|
||
(set-variable! kill-ring strings context)
|
||
(set-variable! kill-ring-yank-pointer strings context)))
|
||
|
||
(define append-next-kill-tag
|
||
(list 'APPEND-NEXT-KILL))
|
||
|
||
;;;; Yanking
|
||
|
||
(define-command yank
|
||
"Reinsert the last stretch of killed text.
|
||
More precisely, reinsert the stretch of killed text most recently
|
||
killed OR yanked.
|
||
With just \\[universal-argument] as argument, same but put point in front (and mark at end).
|
||
With argument n, reinsert the nth most recently killed stretch of killed
|
||
text.
|
||
See also the command \\[yank-pop]."
|
||
"*P"
|
||
(lambda (argument)
|
||
(yank (if (command-argument-multiplier-only? argument)
|
||
0
|
||
(- (command-argument-numeric-value argument) 1))
|
||
(command-argument-multiplier-only? argument)
|
||
push-current-mark!)))
|
||
|
||
(define-command yank-pop
|
||
"Replace just-yanked stretch of killed-text with a different stretch.
|
||
This command is allowed only immediately after a \\[yank] or a \\[yank-pop].
|
||
At such a time, the region contains a stretch of reinserted
|
||
previously-killed text. \\[yank-pop] deletes that text and inserts in its
|
||
place a different stretch of killed text.
|
||
|
||
With no argument, the previous kill is inserted.
|
||
With argument n, the n'th previous kill is inserted.
|
||
If n is negative, this is a more recent kill.
|
||
|
||
The sequence of kills wraps around, so that after the oldest one
|
||
comes the newest one."
|
||
"*p"
|
||
(lambda (argument)
|
||
(command-message-receive un-kill-tag
|
||
(lambda () unspecific)
|
||
(lambda () (editor-error "Previous command was not a yank")))
|
||
(yank argument
|
||
(let ((point (current-point))
|
||
(mark (current-mark)))
|
||
(let ((before? (mark< point mark)))
|
||
(delete-string point mark)
|
||
before?))
|
||
set-current-mark!)))
|
||
|
||
(define (yank offset before? set-current-mark!)
|
||
(let* ((point (current-point))
|
||
(start (mark-right-inserting-copy point))
|
||
(end (mark-left-inserting-copy start)))
|
||
(insert-string (let ((paste
|
||
(and (= offset 0) (os/interprogram-paste point))))
|
||
(if (and paste
|
||
(not (string-null? paste))
|
||
(let ((kill-ring (ref-variable kill-ring point)))
|
||
(or (null? kill-ring)
|
||
(not (string=? paste (car kill-ring))))))
|
||
(begin
|
||
(kill-ring-save-1 paste point)
|
||
paste)
|
||
(begin
|
||
((ref-command rotate-yank-pointer) offset)
|
||
(car (ref-variable kill-ring-yank-pointer point)))))
|
||
start)
|
||
(mark-temporary! end)
|
||
(mark-temporary! start)
|
||
(if before?
|
||
(begin (set-current-mark! end) (set-current-point! start))
|
||
(begin (set-current-mark! start) (set-current-point! end))))
|
||
(set-command-message! un-kill-tag))
|
||
|
||
(define un-kill-tag
|
||
"Un-kill")
|
||
|
||
(define-command rotate-yank-pointer
|
||
"Rotate the yanking point in the kill ring."
|
||
"p"
|
||
(lambda (argument)
|
||
(let ((kill-ring (ref-variable kill-ring)))
|
||
(if (null? kill-ring)
|
||
(editor-error "Kill ring is empty"))
|
||
(set-variable!
|
||
kill-ring-yank-pointer
|
||
(drop kill-ring
|
||
(modulo (+ argument
|
||
(let ((kill-ring-yank-pointer
|
||
(ref-variable kill-ring-yank-pointer)))
|
||
(let loop ((l kill-ring) (n 0))
|
||
(cond ((null? l) 0)
|
||
((eq? l kill-ring-yank-pointer) n)
|
||
(else (loop (cdr l) (+ n 1)))))))
|
||
(length kill-ring)))))))
|
||
|
||
;;;; Marks
|
||
|
||
(define-variable mark-ring-maximum
|
||
"The maximum number of marks that are saved on the mark ring.
|
||
This variable is only noticed when a buffer is created, so changing
|
||
it later will not affect existing buffers."
|
||
16)
|
||
|
||
(define-command set-mark-command
|
||
"Sets or pops the mark.
|
||
With no \\[universal-argument]'s, pushes point as the mark.
|
||
With one \\[universal-argument], pops the mark into point.
|
||
With two \\[universal-argument]'s, pops the mark and throws it away."
|
||
"P"
|
||
(lambda (argument)
|
||
(case (and (command-argument-multiplier-only? argument)
|
||
(command-argument-value argument))
|
||
((4) (set-current-point! (pop-current-mark!)))
|
||
((16) (pop-current-mark!))
|
||
(else (push-current-mark! (current-point))))))
|
||
|
||
(define-command mark-beginning-of-buffer
|
||
"Set mark at beginning of buffer."
|
||
()
|
||
(lambda ()
|
||
(push-current-mark! (buffer-start (current-buffer)))))
|
||
|
||
(define-command mark-end-of-buffer
|
||
"Set mark at end of buffer."
|
||
()
|
||
(lambda ()
|
||
(push-current-mark! (buffer-end (current-buffer)))))
|
||
|
||
(define-command mark-whole-buffer
|
||
"Set point at beginning and mark at end of buffer.
|
||
Pushes the old point on the mark first, so two pops restore it.
|
||
With argument, puts point at end and mark at beginning."
|
||
"P"
|
||
(lambda (argument)
|
||
(push-current-mark! (current-point))
|
||
((if (not argument) set-current-region! set-current-region-reversed!)
|
||
(buffer-region (current-buffer)))))
|
||
|
||
(define-command exchange-point-and-mark
|
||
"Exchange positions of point and mark."
|
||
()
|
||
(lambda ()
|
||
(let ((point (current-point))
|
||
(mark (current-mark)))
|
||
(if (not mark) (editor-error "No mark to exchange"))
|
||
(set-current-point! mark)
|
||
(set-current-mark! point))))
|
||
|
||
;;;; Transposition
|
||
|
||
(define-command transpose-chars
|
||
"Transpose the characters before and after the cursor.
|
||
With a positive argument it transposes the characters before and after
|
||
the cursor, moves right, and repeats the specified number of times,
|
||
dragging the character to the left of the cursor right.
|
||
|
||
With a negative argument, it transposes the two characters to the left
|
||
of the cursor, moves between them, and repeats the specified number of
|
||
times, exactly undoing the positive argument form.
|
||
|
||
With a zero argument, it transposes the characters at point and mark.
|
||
|
||
At the end of a line, with no argument, the preceding two characters
|
||
are transposed."
|
||
"p"
|
||
(lambda (argument)
|
||
(cond ((and (= argument 1) (line-end? (current-point)))
|
||
(twiddle-characters (mark-1+ (current-point) 'ERROR)
|
||
(current-point)))
|
||
((positive? argument)
|
||
(twiddle-characters (current-point)
|
||
(mark+ (current-point) argument 'ERROR)))
|
||
((negative? argument)
|
||
(twiddle-characters
|
||
(current-point)
|
||
(mark- (current-point) (1+ (- argument)) 'ERROR)))
|
||
(else
|
||
(let ((m1 (mark-right-inserting (current-point)))
|
||
(m2 (mark-right-inserting (current-mark))))
|
||
(if (not (mark= m1 m2))
|
||
(begin
|
||
(let ((c1 (extract-right-char m1))
|
||
(c2 (extract-right-char m2)))
|
||
(delete-right-char m1)
|
||
(delete-right-char m2)
|
||
(insert-char c2 m1)
|
||
(insert-char c1 m2))
|
||
(set-current-point! m1)
|
||
(set-current-mark! m2))))))))
|
||
|
||
(define (twiddle-characters m1 m2)
|
||
(let ((m* (mark-left-inserting m2)))
|
||
(let ((char (extract-left-char m1)))
|
||
(delete-left-char m1)
|
||
(insert-char char m*))
|
||
(set-current-point! m*)))
|