/[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 - (hide 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 ram 1.1 ;;; -*- Package: hemlock; Log: hemlock.log; Mode: Lisp -*-
2 ram 1.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 pw 1.5 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/ed-integrity.lisp,v 1.5 2001/03/13 15:49:52 pw Rel $")
9 ram 1.2 ;;;
10     ;;; **********************************************************************
11     ;;;
12 ram 1.1 ;;; 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 ram 1.3 (in-package "ED")
25 ram 1.1
26    
27 pw 1.5 (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 ram 1.1
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