/[cmucl]/src/hemlock/overwrite.lisp
ViewVC logotype

Contents of /src/hemlock/overwrite.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (hide annotations)
Wed Aug 25 02:10:08 1993 UTC (20 years, 7 months ago) by ram
Branch: MAIN
Changes since 1.3: +2 -2 lines
Fix compiler warnings.
1 ram 1.1 ;;; -*- Log: hemlock.log; Package: Hemlock -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.3 ;;; 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     ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7     ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8     ;;;
9     (ext:file-comment
10 ram 1.4 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/overwrite.lisp,v 1.4 1993/08/25 02:10:08 ram Exp $")
11 ram 1.3 ;;;
12 ram 1.1 ;;; **********************************************************************
13     ;;;
14     ;;; Written by Bill Chiles.
15     ;;;
16    
17 ram 1.4 (in-package "HEMLOCK")
18 ram 1.1
19    
20     (defmode "Overwrite")
21    
22    
23     (defcommand "Overwrite Mode" (p)
24     "Printing characters overwrite characters instead of pushing them to the right.
25     A positive argument turns Overwrite mode on, while zero or a negative
26     argument turns it off. With no arguments, it is toggled. Use C-Q to
27     insert characters normally."
28     "Determine if in Overwrite mode or not and set the mode accordingly."
29     (setf (buffer-minor-mode (current-buffer) "Overwrite")
30     (if p
31     (plusp p)
32     (not (buffer-minor-mode (current-buffer) "Overwrite")))))
33    
34    
35     (defcommand "Self Overwrite" (p)
36     "Replace the next character with the last character typed,
37     but insert at end of line. With prefix argument, do it that many times."
38     "Implements ``Self Overwrite'', calling this function is not meaningful."
39 ram 1.2 (let ((char (ext:key-event-char *last-key-event-typed*))
40 ram 1.1 (point (current-point)))
41     (unless char (editor-error "Can't insert that character."))
42     (do ((n (or p 1) (1- n)))
43     ((zerop n))
44     (case (next-character point)
45     (#\tab
46     (let ((col1 (mark-column point))
47     (col2 (mark-column (mark-after point))))
48     (if (= (- col2 col1) 1)
49     (setf (previous-character point) char)
50     (insert-character (mark-before point) char))))
51     ((#\newline nil) (insert-character point char))
52     (t (setf (next-character point) char)
53     (mark-after point))))))
54    
55    
56     (defcommand "Overwrite Delete Previous Character" (p)
57     "Replaces previous character with space, but tabs and newlines are deleted.
58     With prefix argument, do it that many times."
59     "Replaces previous character with space, but tabs and newlines are deleted."
60     (do ((point (current-point))
61     (n (or p 1) (1- n)))
62     ((zerop n))
63     (case (previous-character point)
64     ((#\newline #\tab) (delete-characters point -1))
65     ((nil) (editor-error))
66     (t (setf (previous-character point) #\space)
67     (mark-before point)))))

  ViewVC Help
Powered by ViewVC 1.1.5