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

Contents of /src/hemlock/bufed.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (hide annotations)
Mon Oct 31 04:50:12 1994 UTC (19 years, 5 months ago) by ram
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, RELEASE_18d, 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, RELEASE_18a, RELEASE_18b, RELEASE_18c, 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, RELENG_18, 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.2: +0 -2 lines
Fix headed boilerplate.
1 ram 1.1 ;;; -*- Log: hemlock.log; Package: Hemlock -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.2 ;;; 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/bufed.lisp,v 1.3 1994/10/31 04:50:12 ram Rel $")
9     ;;;
10 ram 1.1 ;;; **********************************************************************
11     ;;;
12     ;;; This file contains Bufed (Buffer Editing) code.
13     ;;;
14    
15     (in-package "HEMLOCK")
16    
17    
18    
19     ;;;; Representation of existing buffers.
20    
21     ;;; This is the array of buffers in the bufed buffer. Each element is a cons,
22     ;;; where the CAR is the buffer, and the CDR indicates whether the buffer
23     ;;; should be deleted (t deleted, nil don't).
24     ;;;
25     (defvar *bufed-buffers* nil)
26     (defvar *bufed-buffers-end* nil)
27     ;;;
28     (defmacro bufed-buffer (x) `(car ,x))
29     (defmacro bufed-buffer-deleted (x) `(cdr ,x))
30     (defmacro make-bufed-buffer (buffer) `(list ,buffer))
31    
32    
33     ;;; This is the bufed buffer if it exists.
34     ;;;
35     (defvar *bufed-buffer* nil)
36    
37     ;;; This is the cleanup method for deleting *bufed-buffer*.
38     ;;;
39     (defun delete-bufed-buffers (buffer)
40     (when (eq buffer *bufed-buffer*)
41     (setf *bufed-buffer* nil)
42     (setf *bufed-buffers* nil)))
43    
44    
45    
46     ;;;; Commands.
47    
48     (defmode "Bufed" :major-p t
49     :documentation
50     "Bufed allows the user to quickly save, goto, delete, etc., his buffers.")
51    
52     (defhvar "Virtual Buffer Deletion"
53     "When set, \"Bufed Delete\" marks a buffer for deletion instead of immediately
54     deleting it."
55     :value t)
56    
57     (defhvar "Bufed Delete Confirm"
58     "When set, \"Bufed\" commands that actually delete buffers ask for
59     confirmation before taking action."
60     :value t)
61    
62     (defcommand "Bufed Delete" (p)
63     "Delete the buffer.
64     Any windows displaying this buffer will display some other buffer."
65     "Delete the buffer indicated by the current line. Any windows displaying this
66     buffer will display some other buffer."
67     (declare (ignore p))
68     (let* ((point (current-point))
69     (buf-info (array-element-from-mark point *bufed-buffers*)))
70     (if (and (not (value virtual-buffer-deletion))
71     (or (not (value bufed-delete-confirm))
72     (prompt-for-y-or-n :prompt "Delete buffer? " :default t
73     :must-exist t :default-string "Y")))
74     (delete-bufed-buffer (bufed-buffer buf-info))
75     (with-writable-buffer (*bufed-buffer*)
76     (setf (bufed-buffer-deleted buf-info) t)
77     (with-mark ((point point))
78     (setf (next-character (line-start point)) #\D))))))
79    
80     (defcommand "Bufed Undelete" (p)
81     "Undelete the buffer.
82     Any windows displaying this buffer will display some other buffer."
83     "Undelete the buffer. Any windows displaying this buffer will display some
84     other buffer."
85     (declare (ignore p))
86     (with-writable-buffer (*bufed-buffer*)
87     (setf (bufed-buffer-deleted (array-element-from-mark
88     (current-point) *bufed-buffers*))
89     nil)
90     (with-mark ((point (current-point)))
91     (setf (next-character (line-start point)) #\space))))
92    
93     (defcommand "Bufed Expunge" (p)
94     "Expunge buffers marked for deletion."
95     "Expunge buffers marked for deletion."
96     (declare (ignore p))
97     (expunge-bufed-buffers))
98    
99     (defcommand "Bufed Quit" (p)
100     "Kill the bufed buffer, expunging any buffer marked for deletion."
101     "Kill the bufed buffer, expunging any buffer marked for deletion."
102     (declare (ignore p))
103     (expunge-bufed-buffers)
104     (when *bufed-buffer* (delete-buffer-if-possible *bufed-buffer*)))
105    
106     ;;; EXPUNGE-BUFED-BUFFERS deletes the marked buffers in the bufed buffer,
107     ;;; signalling an error if the current buffer is not the bufed buffer. This
108     ;;; returns t if it deletes some buffer, otherwise nil. We build a list of
109     ;;; buffers before deleting any because the BUFED-DELETE-HOOK moves elements
110     ;;; around in *bufed-buffers*.
111     ;;;
112     (defun expunge-bufed-buffers ()
113     (unless (eq *bufed-buffer* (current-buffer))
114     (editor-error "Not in the Bufed buffer."))
115     (let (buffers)
116     (dotimes (i *bufed-buffers-end*)
117     (let ((buf-info (svref *bufed-buffers* i)))
118     (when (bufed-buffer-deleted buf-info)
119     (push (bufed-buffer buf-info) buffers))))
120     (if (and buffers
121     (or (not (value bufed-delete-confirm))
122     (prompt-for-y-or-n :prompt "Delete buffers? " :default t
123     :must-exist t :default-string "Y")))
124     (dolist (b buffers t) (delete-bufed-buffer b)))))
125    
126     (defun delete-bufed-buffer (buf)
127     (when (and (buffer-modified buf)
128     (prompt-for-y-or-n :prompt (list "~A is modified. Save it first? "
129     (buffer-name buf))))
130     (save-file-command nil buf))
131     (delete-buffer-if-possible buf))
132    
133    
134     (defcommand "Bufed Goto" (p)
135     "Change to the buffer."
136     "Change to the buffer."
137     (declare (ignore p))
138     (change-to-buffer
139     (bufed-buffer (array-element-from-mark (current-point) *bufed-buffers*))))
140    
141     (defcommand "Bufed Goto and Quit" (p)
142     "Change to the buffer quitting Bufed.
143     This supplies a function for \"Generic Pointer Up\" which is a no-op."
144     "Change to the buffer quitting Bufed."
145     (declare (ignore p))
146     (expunge-bufed-buffers)
147     (point-to-here-command nil)
148     (change-to-buffer
149     (bufed-buffer (array-element-from-pointer-pos *bufed-buffers*
150     "No buffer on that line.")))
151     (when *bufed-buffer* (delete-buffer-if-possible *bufed-buffer*))
152     (supply-generic-pointer-up-function #'(lambda () nil)))
153    
154     (defcommand "Bufed Save File" (p)
155     "Save the buffer."
156     "Save the buffer."
157     (declare (ignore p))
158     (save-file-command
159     nil
160     (bufed-buffer (array-element-from-mark (current-point) *bufed-buffers*))))
161    
162     (defcommand "Bufed" (p)
163     "Creates a list of buffers in a buffer supporting operations such as deletion
164     and selection. If there already is a bufed buffer, just go to it."
165     "Creates a list of buffers in a buffer supporting operations such as deletion
166     and selection. If there already is a bufed buffer, just go to it."
167     (declare (ignore p))
168     (let ((buf (or *bufed-buffer*
169     (make-buffer "Bufed" :modes '("Bufed")
170     :delete-hook (list #'delete-bufed-buffers)))))
171    
172     (unless *bufed-buffer*
173     (setf *bufed-buffer* buf)
174     (setf *bufed-buffers-end*
175     ;; -1 echo, -1 bufed.
176     (- (length (the list *buffer-list*)) 2))
177     (setf *bufed-buffers* (make-array *bufed-buffers-end*))
178     (setf (buffer-writable buf) t)
179     (with-output-to-mark (s (buffer-point buf))
180     (let ((i 0))
181     (do-strings (n b *buffer-names*)
182     (declare (simple-string n))
183     (unless (or (eq b *echo-area-buffer*)
184     (eq b buf))
185     (bufed-write-line b n s)
186     (setf (svref *bufed-buffers* i) (make-bufed-buffer b))
187     (incf i)))))
188     (setf (buffer-writable buf) nil)
189     (setf (buffer-modified buf) nil)
190     (let ((fields (buffer-modeline-fields *bufed-buffer*)))
191     (setf (cdr (last fields))
192     (list (or (modeline-field :bufed-cmds)
193     (make-modeline-field
194     :name :bufed-cmds :width 18
195     :function
196     #'(lambda (buffer window)
197     (declare (ignore buffer window))
198     " Type ? for help.")))))
199     (setf (buffer-modeline-fields *bufed-buffer*) fields))
200     (buffer-start (buffer-point buf)))
201     (change-to-buffer buf)))
202    
203     (defun bufed-write-line (buffer name s
204     &optional (buffer-pathname (buffer-pathname buffer)))
205     (let ((modified (buffer-modified buffer)))
206     (write-string (if modified " *" " ") s)
207     (if buffer-pathname
208     (format s "~A ~A~:[~50T~A~;~]~%"
209     (file-namestring buffer-pathname)
210     (directory-namestring buffer-pathname)
211     (string= (pathname-to-buffer-name buffer-pathname) name)
212     name)
213     (write-line name s))))
214    
215    
216     (defcommand "Bufed Help" (p)
217     "Show this help."
218     "Show this help."
219     (declare (ignore p))
220     (describe-mode-command nil "Bufed"))
221    
222    
223    
224     ;;;; Maintenance hooks.
225    
226     (eval-when (compile eval)
227     (defmacro with-bufed-point ((point buffer &optional pos) &rest body)
228     (let ((pos (or pos (gensym))))
229     `(when (and *bufed-buffers*
230     (not (eq *bufed-buffer* ,buffer))
231     (not (eq *echo-area-buffer* ,buffer)))
232     (let ((,pos (position ,buffer *bufed-buffers* :key #'car
233     :test #'eq :end *bufed-buffers-end*)))
234     (unless ,pos (error "Unknown Bufed buffer."))
235     (let ((,point (buffer-point *bufed-buffer*)))
236     (unless (line-offset (buffer-start ,point) ,pos 0)
237     (error "Bufed buffer not displayed?"))
238     (with-writable-buffer (*bufed-buffer*) ,@body))))))
239     ) ;eval-when
240    
241    
242     (defun bufed-modified-hook (buffer modified)
243     (with-bufed-point (point buffer)
244     (setf (next-character (mark-after point)) (if modified #\* #\space))))
245     ;;;
246     (add-hook buffer-modified-hook 'bufed-modified-hook)
247    
248     (defun bufed-make-hook (buffer)
249     (declare (ignore buffer))
250     (when *bufed-buffer* (delete-buffer-if-possible *bufed-buffer*)))
251     ;;;
252     (add-hook make-buffer-hook 'bufed-make-hook)
253    
254     (defun bufed-delete-hook (buffer)
255     (with-bufed-point (point buffer pos)
256     (with-mark ((temp point :left-inserting))
257     (line-offset temp 1)
258     (delete-region (region point temp)))
259     (let ((len-1 (1- *bufed-buffers-end*)))
260     (replace *bufed-buffers* *bufed-buffers*
261     :start1 pos :end1 len-1
262     :start2 (1+ pos) :end1 *bufed-buffers-end*)
263     (setf (svref *bufed-buffers* len-1) nil)
264     (setf *bufed-buffers-end* len-1))))
265     ;;;
266     (add-hook delete-buffer-hook 'bufed-delete-hook)
267    
268     (defun bufed-name-hook (buffer name)
269     (with-bufed-point (point buffer)
270     (with-mark ((temp point :left-inserting))
271     (line-offset temp 1)
272     (delete-region (region point temp)))
273     (with-output-to-mark (s point)
274     (bufed-write-line buffer name s))))
275     ;;;
276     (add-hook buffer-name-hook 'bufed-name-hook)
277    
278     (defun bufed-pathname-hook (buffer pathname)
279     (with-bufed-point (point buffer)
280     (with-mark ((temp point :left-inserting))
281     (line-offset temp 1)
282     (delete-region (region point temp)))
283     (with-output-to-mark (s point)
284     (bufed-write-line buffer (buffer-name buffer) s pathname))))
285     ;;;
286     (add-hook buffer-pathname-hook 'bufed-pathname-hook)

  ViewVC Help
Powered by ViewVC 1.1.5