/[cmucl]/src/hemlock/ed-integrity.lisp
ViewVC logotype

Contents of /src/hemlock/ed-integrity.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Tue Mar 13 15:49:52 2001 UTC (13 years, 1 month ago) by pw
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.4: +6 -6 lines
Change toplevel PROCLAIMs to DECLAIMs.
1 ;;; -*- Package: hemlock; Log: hemlock.log; Mode: Lisp -*-
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 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/ed-integrity.lisp,v 1.5 2001/03/13 15:49:52 pw Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This stuff can be used for testing tty redisplay. There are four
13 ;;; commands that, given "Setup Tty Buffer", that test
14 ;;; HI::COMPUTE-TTY-CHANGES: "Two Deletes", "Two Inserts", "One Delete One
15 ;;; Insert", and "One Insert One Delete. Each can be called with an
16 ;;; argument to generate a grand total of eight screen permutations.
17 ;;; "Setup Tty Buffer" numbers the lines of the main window 0 through 19
18 ;;; inclusively.
19 ;;;
20 ;;; "Setup for Debugging" and "Cleanup for Debugging" were helpful in
21 ;;; conjunction with some alternate versions of COMPUTE-TTY-CHANGES and
22 ;;; TTY-SMART-WINDOW-REDISPLAY. When something went wrong with on
23
24 (in-package "ED")
25
26
27 (declaim (special hemlock-internals::*debugging-tty-redisplay*
28 hemlock-internals::*testing-delete-queue*
29 hemlock-internals::*testing-insert-queue*
30 hemlock-internals::*testing-moved*
31 hemlock-internals::*testing-writes*))
32
33
34 (defcommand "Setup Tty Buffer" (p)
35 "Clear buffer and insert numbering strings 0..19."
36 "Clear buffer and insert numbering strings 0..19."
37 (declare (ignore p))
38 (delete-region (buffer-region (current-buffer)))
39 (let ((point (current-point)))
40 (dotimes (i 20)
41 (insert-string point (prin1-to-string i))
42 (insert-character point #\newline))
43 (buffer-start point)))
44
45 (defcommand "Setup for Debugging" (p)
46 "Set *debugging-tty-redisplay* to t, and some other stuff to nil."
47 "Set *debugging-tty-redisplay* to t, and some other stuff to nil."
48 (declare (ignore p))
49 (setf hi::*debugging-tty-redisplay* t)
50 (setf hi::*testing-delete-queue* nil)
51 (setf hi::*testing-insert-queue* nil)
52 (setf hi::*testing-moved* nil)
53 (setf hi::*testing-writes* nil))
54
55 (defcommand "Cleanup for Debugging" (p)
56 "Set *debugging-tty-redisplay* to nil."
57 "Set *debugging-tty-redisplay* to nil."
58 (declare (ignore p))
59 (setf hi::*debugging-tty-redisplay* nil))
60
61 ;;; Given "Setup Tty Buffer", deletes lines numbered 3, 4, 5, 10, 11, 12,
62 ;;; 13, and 14. With argument, 3..7 and 12..14.
63 ;;;
64 (defcommand "Two Deletes" (p)
65 "At line 3, delete 3 lines. At line 3+4, delete 5 lines.
66 With an argument, switch the number deleted."
67 "At line 3, delete 3 lines. At line 3+4, delete 5 lines.
68 With an argument, switch the number deleted."
69 (multiple-value-bind (dnum1 dnum2)
70 (if p (values 5 3) (values 3 5))
71 (let ((point (current-point)))
72 (move-mark point (window-display-start (current-window)))
73 (line-offset point 3)
74 (with-mark ((end point :left-inserting))
75 (line-offset end dnum1)
76 (delete-region (region point end))
77 (line-offset point 4)
78 (line-offset (move-mark end point) dnum2)
79 (delete-region (region point end))))))
80
81
82 ;;; Given "Setup Tty Buffer", opens two blank lines between 2 and 3, and
83 ;;; opens four blank lines between 6 and 7, leaving line numbered 13 at
84 ;;; the bottom. With argument, four lines between 2 and 3, two lines
85 ;;; between 6 and 7, and line 13 at the bottom of the window.
86 ;;;
87 (defcommand "Two Inserts" (p)
88 "At line 3, open 2 lines. At line 3+2+4, open 4 lines.
89 With an argument, switch the number opened."
90 "At line 3, open 2 lines. At line 3+2+4, open 4 lines.
91 With an argument, switch the number opened."
92 (multiple-value-bind (onum1 onum2)
93 (if p (values 4 2) (values 2 4))
94 (let ((point (current-point)))
95 (move-mark point (window-display-start (current-window)))
96 (line-offset point 3)
97 (dotimes (i onum1)
98 (insert-character point #\newline))
99 (line-offset point 4)
100 (dotimes (i onum2)
101 (insert-character point #\newline)))))
102
103
104 ;;; Given "Setup Tty Buffer", deletes lines numbered 3, 4, and 5, and
105 ;;; opens five lines between lines numbered 9 and 10, leaving line numbered
106 ;;; 17 on the bottom. With an argument, deletes lines numbered 3, 4, 5, 6,
107 ;;; and 7, and opens three lines between 11 and 12, creating two blank lines
108 ;;; at the end of the screen.
109 ;;;
110 (defcommand "One Delete One Insert" (p)
111 "At line 3, delete 3 lines. At line 3+4, open 5 lines.
112 With an argument, switch the number of lines affected."
113 "At line 3, delete 3 lines. At line 3+4, open 5 lines.
114 With an argument, switch the number of lines affected."
115 (multiple-value-bind (dnum onum)
116 (if p (values 5 3) (values 3 5))
117 (let ((point (current-point)))
118 (move-mark point (window-display-start (current-window)))
119 (line-offset point 3)
120 (with-mark ((end point :left-inserting))
121 (line-offset end dnum)
122 (delete-region (region point end))
123 (line-offset point 4)
124 (dotimes (i onum)
125 (insert-character point #\newline))))))
126
127 ;;; Given "Setup Tty Buffer", opens three blank lines between lines numbered
128 ;;; 2 and 3, and deletes lines numbered 7, 8, 9, 10, and 11, leaving two
129 ;;; blank lines at the bottom of the window. With an argument, opens five
130 ;;; blank lines between lines numbered 2 and 3, and deletes lines 7, 8, and
131 ;;; 9, leaving line 17 at the bottom of the window.
132 ;;;
133 (defcommand "One Insert One Delete" (p)
134 "At line 3, open 3 lines. At line 3+3+4, delete 5 lines.
135 With an argument, switch the number of lines affected."
136 "At line 3, open 3 lines. At line 3+3+4, delete 5 lines.
137 With an argument, switch the number of lines affected."
138 (multiple-value-bind (onum dnum)
139 (if p (values 5 3) (values 3 5))
140 (let ((point (current-point)))
141 (move-mark point (window-display-start (current-window)))
142 (line-offset point 3)
143 (dotimes (i onum)
144 (insert-character point #\newline))
145 (line-offset point 4)
146 (with-mark ((end point :left-inserting))
147 (line-offset end dnum)
148 (delete-region (region point end))))))
149
150
151 ;;; This could be thrown away, but I'll leave it here. When I was testing
152 ;;; the problem of generating EQ screen image lines due to faulty
153 ;;; COMPUTE-TTY-CHANGES, this was a convenient command to get the editor
154 ;;; back under control.
155 ;;;
156 (defcommand "Fix Screen Image Lines" (p)
157 ""
158 ""
159 (declare (ignore p))
160 (let* ((device (hi::device-hunk-device (hi::window-hunk (current-window))))
161 (lines (hi::tty-device-lines device))
162 (columns (hi::tty-device-columns device))
163 (screen-image (hi::tty-device-screen-image device)))
164 (dotimes (i lines)
165 (setf (svref screen-image i) (hi::make-si-line columns)))))

  ViewVC Help
Powered by ViewVC 1.1.5