| 1 | ;;; -*- Log: hemlock.log; Package: Hemlock -*-
|
|---|
| 2 | ;;;
|
|---|
| 3 | ;;; **********************************************************************
|
|---|
| 4 | ;;; This code was written as part of the CMU Common Lisp project at
|
|---|
| 5 | ;;; Carnegie Mellon University, and has been placed in the public domain.
|
|---|
| 6 | ;;;
|
|---|
| 7 | #+CMU (ext:file-comment
|
|---|
| 8 | "$Header$")
|
|---|
| 9 | ;;;
|
|---|
| 10 | ;;; **********************************************************************
|
|---|
| 11 | ;;;
|
|---|
| 12 | ;;; Written by Bill Chiles.
|
|---|
| 13 | ;;;
|
|---|
| 14 |
|
|---|
| 15 | (in-package :hemlock)
|
|---|
| 16 |
|
|---|
| 17 |
|
|---|
| 18 | (defmode "Overwrite")
|
|---|
| 19 |
|
|---|
| 20 |
|
|---|
| 21 | (defcommand "Overwrite Mode" (p)
|
|---|
| 22 | "Printing characters overwrite characters instead of pushing them to the right.
|
|---|
| 23 | A positive argument turns Overwrite mode on, while zero or a negative
|
|---|
| 24 | argument turns it off. With no arguments, it is toggled. Use C-Q to
|
|---|
| 25 | insert characters normally."
|
|---|
| 26 | "Determine if in Overwrite mode or not and set the mode accordingly."
|
|---|
| 27 | (setf (buffer-minor-mode (current-buffer) "Overwrite")
|
|---|
| 28 | (if p
|
|---|
| 29 | (plusp p)
|
|---|
| 30 | (not (buffer-minor-mode (current-buffer) "Overwrite")))))
|
|---|
| 31 |
|
|---|
| 32 |
|
|---|
| 33 | (defcommand "Self Overwrite" (p)
|
|---|
| 34 | "Replace the next character with the last character typed,
|
|---|
| 35 | but insert at end of line. With prefix argument, do it that many times."
|
|---|
| 36 | "Implements ``Self Overwrite'', calling this function is not meaningful."
|
|---|
| 37 | (let ((char (hemlock-ext:key-event-char *last-key-event-typed*))
|
|---|
| 38 | (point (current-point)))
|
|---|
| 39 | (unless char (editor-error "Can't insert that character."))
|
|---|
| 40 | (do ((n (or p 1) (1- n)))
|
|---|
| 41 | ((zerop n))
|
|---|
| 42 | (case (next-character point)
|
|---|
| 43 | (#\tab
|
|---|
| 44 | (let ((col1 (mark-column point))
|
|---|
| 45 | (col2 (mark-column (mark-after point))))
|
|---|
| 46 | (if (= (- col2 col1) 1)
|
|---|
| 47 | (setf (previous-character point) char)
|
|---|
| 48 | (insert-character (mark-before point) char))))
|
|---|
| 49 | ((#\newline nil) (insert-character point char))
|
|---|
| 50 | (t (setf (next-character point) char)
|
|---|
| 51 | (mark-after point))))))
|
|---|
| 52 |
|
|---|
| 53 |
|
|---|
| 54 | (defcommand "Overwrite Delete Previous Character" (p)
|
|---|
| 55 | "Replaces previous character with space, but tabs and newlines are deleted.
|
|---|
| 56 | With prefix argument, do it that many times."
|
|---|
| 57 | "Replaces previous character with space, but tabs and newlines are deleted."
|
|---|
| 58 | (do ((point (current-point))
|
|---|
| 59 | (n (or p 1) (1- n)))
|
|---|
| 60 | ((zerop n))
|
|---|
| 61 | (case (previous-character point)
|
|---|
| 62 | ((#\newline #\tab) (delete-characters point -1))
|
|---|
| 63 | ((nil) (editor-error))
|
|---|
| 64 | (t (setf (previous-character point) #\space)
|
|---|
| 65 | (mark-before point)))))
|
|---|
