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

Contents of /src/hemlock/buffer.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Tue Mar 13 15:49:51 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 ;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
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/buffer.lisp,v 1.5 2001/03/13 15:49:51 pw Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Written by Rob MacLachlan
13 ;;;
14 ;;; This file contains functions for changing modes and buffers.
15 ;;;
16
17 (in-package "HEMLOCK-INTERNALS")
18
19 (export '(buffer-modified buffer-region buffer-name buffer-pathname
20 buffer-major-mode buffer-minor-mode buffer-modeline-fields
21 buffer-modeline-field-p current-buffer current-point
22 in-recursive-edit exit-recursive-edit abort-recursive-edit
23 recursive-edit defmode mode-major-p mode-variables mode-documentation
24 make-buffer delete-buffer with-writable-buffer buffer-start-mark
25 buffer-end-mark *buffer-list*))
26
27
28
29 ;;;; Some buffer structure support.
30
31 (defun buffer-writable (buffer)
32 "Returns whether buffer may be modified."
33 (buffer-%writable buffer))
34
35 (defun %set-buffer-writable (buffer value)
36 (invoke-hook ed::buffer-writable-hook buffer value)
37 (setf (buffer-%writable buffer) value))
38
39 ;;; BUFFER-MODIFIED uses the buffer modification tick which is for redisplay.
40 ;;; We can never set this down to "unmodify" a buffer, so we keep an
41 ;;; unmodification tick. The buffer is modified only if this is less than the
42 ;;; modification tick.
43 ;;;
44 (defun buffer-modified (buffer)
45 "Return T if Buffer has been modified, NIL otherwise. Can be set with Setf."
46 (unless (bufferp buffer) (error "~S is not a buffer." buffer))
47 (> (buffer-modified-tick buffer) (buffer-unmodified-tick buffer)))
48
49 (defun %set-buffer-modified (buffer sense)
50 "If true make the buffer modified, if NIL unmodified."
51 (unless (bufferp buffer) (error "~S is not a buffer." buffer))
52 (invoke-hook ed::buffer-modified-hook buffer sense)
53 (if sense
54 (setf (buffer-modified-tick buffer) (tick))
55 (setf (buffer-unmodified-tick buffer) (tick)))
56 sense)
57
58
59 (declaim (inline buffer-name buffer-pathname buffer-region))
60
61 (defun buffer-region (buffer)
62 "Return the region which contains Buffer's text."
63 (buffer-%region buffer))
64
65 (defun %set-buffer-region (buffer new-region)
66 (let ((old (buffer-region buffer)))
67 (delete-region old)
68 (ninsert-region (region-start old) new-region)
69 old))
70
71 (defun buffer-name (buffer)
72 "Return Buffer's string name."
73 (buffer-%name buffer))
74
75 (declaim (special *buffer-names*))
76
77 (defun %set-buffer-name (buffer name)
78 (multiple-value-bind (entry foundp) (getstring name *buffer-names*)
79 (cond ((or (not foundp) (eq entry buffer))
80 (invoke-hook ed::buffer-name-hook buffer name)
81 (delete-string (buffer-%name buffer) *buffer-names*)
82 (setf (getstring name *buffer-names*) buffer)
83 (setf (buffer-%name buffer) name))
84 (t (error "Cannot rename buffer ~S to ~S. Name already in use."
85 buffer name)))))
86
87 (defun buffer-pathname (buffer)
88 "Return a pathname for the file in Buffer. This is the truename
89 of the file as of the last time it was read or written."
90 (buffer-%pathname buffer))
91
92
93 (defun %set-buffer-pathname (buffer pathname)
94 (invoke-hook ed::buffer-pathname-hook buffer pathname)
95 (setf (buffer-%pathname buffer) pathname))
96
97 (defun buffer-modeline-fields (window)
98 "Return a copy of the buffer's modeline fields list."
99 (do ((finfos (buffer-%modeline-fields window) (cdr finfos))
100 (result () (cons (ml-field-info-field (car finfos)) result)))
101 ((null finfos) (nreverse result))))
102
103 (defun %set-buffer-modeline-fields (buffer fields)
104 (check-type fields list)
105 (check-type buffer buffer "a Hemlock buffer")
106 (sub-set-buffer-modeline-fields buffer fields)
107 (dolist (w (buffer-windows buffer))
108 (update-modeline-fields buffer w)))
109
110 (defun sub-set-buffer-modeline-fields (buffer modeline-fields)
111 (unless (every #'modeline-field-p modeline-fields)
112 (error "Fields must be a list of modeline-field objects."))
113 (setf (buffer-%modeline-fields buffer)
114 (do ((fields modeline-fields (cdr fields))
115 (res nil (cons (make-ml-field-info (car fields))
116 res)))
117 ((null fields) (nreverse res)))))
118
119 (defun buffer-modeline-field-p (buffer field)
120 "If field, a modeline-field or the name of one, is in buffer's list of
121 modeline-fields, it is returned; otherwise, nil."
122 (let ((finfo (internal-buffer-modeline-field-p buffer field)))
123 (if finfo (ml-field-info-field finfo))))
124
125 (defun internal-buffer-modeline-field-p (buffer field)
126 (let ((fields (buffer-%modeline-fields buffer)))
127 (if (modeline-field-p field)
128 (find field fields :test #'eq :key #'ml-field-info-field)
129 (find field fields
130 :key #'(lambda (f)
131 (modeline-field-name (ml-field-info-field f)))))))
132
133
134
135 ;;;; Variable binding -- winding and unwinding.
136
137 (eval-when (compile eval)
138
139 (defmacro unbind-variable-bindings (bindings)
140 `(do ((binding ,bindings (binding-across binding)))
141 ((null binding))
142 (setf (car (binding-cons binding))
143 (variable-object-down (binding-object binding)))))
144
145 (defmacro bind-variable-bindings (bindings)
146 `(do ((binding ,bindings (binding-across binding)))
147 ((null binding))
148 (let ((cons (binding-cons binding))
149 (object (binding-object binding)))
150 (setf (variable-object-down object) (car cons)
151 (car cons) object))))
152
153 ) ;eval-when
154
155 ;;; UNWIND-BINDINGS -- Internal
156 ;;;
157 ;;; Unwind buffer variable bindings and all mode bindings up to and
158 ;;; including mode. Return a list of the modes unwound in reverse order.
159 ;;; (buffer-mode-objects *current-buffer*) is clobbered. If "mode" is NIL
160 ;;; unwind all bindings.
161 ;;;
162 (defun unwind-bindings (mode)
163 (unbind-variable-bindings (buffer-var-values *current-buffer*))
164 (do ((curmode (buffer-mode-objects *current-buffer*))
165 (unwound ()) cw)
166 (())
167 (setf cw curmode curmode (cdr curmode) (cdr cw) unwound unwound cw)
168 (unbind-variable-bindings (mode-object-var-values (car unwound)))
169 (when (or (null curmode) (eq (car unwound) mode))
170 (setf (buffer-mode-objects *current-buffer*) curmode)
171 (return unwound))))
172
173 ;;; WIND-BINDINGS -- Internal
174 ;;;
175 ;;; Add "modes" to the mode bindings currently in effect.
176 ;;;
177 (defun wind-bindings (modes)
178 (do ((curmode (buffer-mode-objects *current-buffer*)) cw)
179 ((null modes) (setf (buffer-mode-objects *current-buffer*) curmode))
180 (bind-variable-bindings (mode-object-var-values (car modes)))
181 (setf cw modes modes (cdr modes) (cdr cw) curmode curmode cw))
182 (bind-variable-bindings (buffer-var-values *current-buffer*)))
183
184
185
186 ;;;; BUFFER-MAJOR-MODE.
187
188 (eval-when (compile eval)
189 (defmacro with-mode-and-buffer ((name major-p buffer) &body forms)
190 `(let ((mode (get-mode-object name)))
191 (setq ,name (mode-object-name mode))
192 (,(if major-p 'unless 'when) (mode-object-major-p mode)
193 (error "~S is not a ~:[Minor~;Major~] Mode." ,name ,major-p))
194 (check-type ,buffer buffer)
195 ,@forms))
196 ) ;eval-when
197
198 ;;; BUFFER-MAJOR-MODE -- Public
199 ;;;
200 ;;; The major mode is the first on the list, so just return that.
201 ;;;
202 (defun buffer-major-mode (buffer)
203 "Return the name of Buffer's major mode. To change tha major mode
204 use Setf."
205 (check-type buffer buffer)
206 (car (buffer-modes buffer)))
207
208 ;;; %SET-BUFFER-MAJOR-MODE -- Public
209 ;;;
210 ;;; Unwind all modes in effect and add the major mode specified.
211 ;;;Note that BUFFER-MODE-OBJECTS is in order of invocation in buffers
212 ;;;other than the current buffer, and in the reverse order in the
213 ;;;current buffer.
214 ;;;
215 (defun %set-buffer-major-mode (buffer name)
216 "Set the major mode of some buffer to the Name'd mode."
217 (with-mode-and-buffer (name t buffer)
218 (invoke-hook ed::buffer-major-mode-hook buffer name)
219 (cond
220 ((eq buffer *current-buffer*)
221 (let ((old-mode (car (last (buffer-mode-objects buffer)))))
222 (invoke-hook (%value (mode-object-hook-name old-mode)) buffer nil)
223 (funcall (mode-object-cleanup-function old-mode) buffer)
224 (swap-char-attributes old-mode)
225 (wind-bindings (cons mode (cdr (unwind-bindings old-mode))))
226 (swap-char-attributes mode)))
227 (t
228 (let ((old-mode (car (buffer-mode-objects buffer))))
229 (invoke-hook (%value (mode-object-hook-name old-mode)) buffer nil)
230 (funcall (mode-object-cleanup-function old-mode) buffer))
231 (setf (car (buffer-mode-objects buffer)) mode)))
232 (setf (car (buffer-modes buffer)) name)
233 (funcall (mode-object-setup-function mode) buffer)
234 (invoke-hook (%value (mode-object-hook-name mode)) buffer t))
235 nil)
236
237
238
239 ;;;; BUFFER-MINOR-MODE.
240
241 ;;; BUFFER-MINOR-MODE -- Public
242 ;;;
243 ;;; Check if the mode-object is in the buffer's mode-list.
244 ;;;
245 (defun buffer-minor-mode (buffer name)
246 "Return true if the minor mode named Name is active in Buffer.
247 A minor mode can be turned on or off with Setf."
248 (with-mode-and-buffer (name nil buffer)
249 (not (null (memq mode (buffer-mode-objects buffer))))))
250
251 (declaim (special *mode-names*))
252
253 ;;; %SET-BUFFER-MINOR-MODE -- Public
254 ;;;
255 ;;; Activate or deactivate a minor mode, with due respect for
256 ;;; bindings.
257 ;;;
258 (defun %set-buffer-minor-mode (buffer name new-value)
259 (let ((objects (buffer-mode-objects buffer)))
260 (with-mode-and-buffer (name nil buffer)
261 (invoke-hook ed::buffer-minor-mode-hook buffer name new-value)
262 (cond
263 ;; Already there or not there, nothing to do.
264 ((if (memq mode (buffer-mode-objects buffer)) new-value (not new-value)))
265 ;; Adding a new mode.
266 (new-value
267 (cond
268 ((eq buffer *current-buffer*)
269 ;;
270 ;; Unwind bindings having higher precedence, cons on the new
271 ;; mode and then wind them back on again.
272 (do ((m objects (cdr m))
273 (prev nil (car m)))
274 ((or (null (cdr m))
275 (< (mode-object-precedence (car m))
276 (mode-object-precedence mode)))
277 (wind-bindings
278 (cons mode (if prev
279 (unwind-bindings prev)
280 (unbind-variable-bindings
281 (buffer-var-values *current-buffer*))))))))
282 (t
283 (do ((m (cdr objects) (cdr m))
284 (prev objects m))
285 ((or (null m)
286 (>= (mode-object-precedence (car m))
287 (mode-object-precedence mode)))
288 (setf (cdr prev) (cons mode m))))))
289 ;;
290 ;; Add the mode name.
291 (let ((bm (buffer-modes buffer)))
292 (setf (cdr bm)
293 (merge 'list (cdr bm) (list name) #'< :key
294 #'(lambda (x)
295 (mode-object-precedence (getstring x *mode-names*))))))
296
297 (funcall (mode-object-setup-function mode) buffer)
298 (invoke-hook (%value (mode-object-hook-name mode)) buffer t))
299 (t
300 ;; Removing an active mode.
301 (invoke-hook (%value (mode-object-hook-name mode)) buffer nil)
302 (funcall (mode-object-cleanup-function mode) buffer)
303 ;; In the current buffer, unwind buffer and any mode bindings on top
304 ;; pop off the mode and wind the rest back on.
305 (cond ((eq buffer *current-buffer*)
306 (wind-bindings (cdr (unwind-bindings mode))))
307 (t
308 (setf (buffer-mode-objects buffer)
309 (delq mode (buffer-mode-objects buffer)))))
310 ;; We always use the same string, so we can delq it (How Tense!)
311 (setf (buffer-modes buffer) (delq name (buffer-modes buffer))))))
312 new-value))
313
314
315
316 ;;;; CURRENT-BUFFER, CURRENT-POINT, and buffer using setup and cleanup.
317
318 (declaim (inline current-buffer))
319
320 (defun current-buffer () "Return the current buffer object." *current-buffer*)
321
322 (defun current-point ()
323 "Return the Buffer-Point of the current buffer."
324 (buffer-point *current-buffer*))
325
326 ;;; %SET-CURRENT-BUFFER -- Internal
327 ;;;
328 ;;; Undo previous buffer and mode specific variables and character
329 ;;;attributes and set up the new ones. Set *current-buffer*.
330 ;;;
331 (defun %set-current-buffer (buffer)
332 (let ((old-buffer *current-buffer*))
333 (check-type buffer buffer)
334 (invoke-hook ed::set-buffer-hook buffer)
335 ;; Undo old bindings.
336 (setf (buffer-mode-objects *current-buffer*)
337 (unwind-bindings nil))
338 (swap-char-attributes (car (buffer-mode-objects *current-buffer*)))
339 (setq *current-buffer* buffer)
340 (swap-char-attributes (car (buffer-mode-objects *current-buffer*)))
341 ;; Make new bindings.
342 (wind-bindings (shiftf (buffer-mode-objects *current-buffer*) nil))
343 (invoke-hook ed::after-set-buffer-hook old-buffer))
344 buffer)
345
346 ;;; USE-BUFFER-SET-UP -- Internal
347 ;;;
348 ;;; This function is called by the use-buffer macro to wind on the
349 ;;; new buffer's variable and key bindings and character attributes.
350 ;;;
351 (defun use-buffer-set-up (old-buffer)
352 (unless (eq old-buffer *current-buffer*)
353 ;; Let new char attributes overlay old ones.
354 (swap-char-attributes (car (buffer-mode-objects *current-buffer*)))
355 ;; Wind on bindings of new current buffer.
356 (wind-bindings (shiftf (buffer-mode-objects *current-buffer*) nil))))
357
358 ;;; USE-BUFFER-CLEAN-UP -- Internal
359 ;;;
360 ;;; This function is called by use-buffer to clean up after it is done.
361 ;;;
362 (defun use-buffer-clean-up (old-buffer)
363 (unless (eq old-buffer *current-buffer*)
364 ;; When we leave, unwind the bindings,
365 (setf (buffer-mode-objects *current-buffer*) (unwind-bindings nil))
366 ;; Restore the character attributes,
367 (swap-char-attributes (car (buffer-mode-objects *current-buffer*)))))
368
369
370
371 ;;;; Recursive editing.
372
373 (defvar *in-a-recursive-edit* nil "True if we are in a recursive edit.")
374
375 (declaim (inline in-recursive-edit))
376
377 (defun in-recursive-edit ()
378 "Returns whether the calling point is dynamically within a recursive edit
379 context."
380 *in-a-recursive-edit*)
381
382 ;;; RECURSIVE-EDIT -- Public
383 ;;;
384 ;;; Call the command interpreter recursively, winding on new state as
385 ;;; necessary.
386 ;;;
387 (defun recursive-edit (&optional (handle-abort t))
388 "Call the command interpreter recursively. If Handle-Abort is true
389 then an abort caused by a control-g or a lisp error does not cause
390 the recursive edit to be aborted."
391 (invoke-hook ed::enter-recursive-edit-hook)
392 (multiple-value-bind (flag args)
393 (let ((*in-a-recursive-edit* t))
394 (catch 'leave-recursive-edit
395 (if handle-abort
396 (loop (catch 'editor-top-level-catcher
397 (%command-loop)))
398 (%command-loop))))
399 (case flag
400 (:abort (apply #'editor-error args))
401 (:exit (values-list args))
402 (t (error "Bad thing ~S thrown out of recursive edit." flag)))))
403
404 ;;; EXIT-RECURSIVE-EDIT is intended to be called within the dynamic context
405 ;;; of RECURSIVE-EDIT, causing return from that function with values returned
406 ;;; as multiple values. When not in a recursive edit, signal an error.
407 ;;;
408 (defun exit-recursive-edit (&optional values)
409 "Exit from a recursive edit. Values is a list of things which are
410 to be the return values from Recursive-Edit."
411 (unless *in-a-recursive-edit*
412 (error "Not in a recursive edit!"))
413 (invoke-hook ed::exit-recursive-edit-hook values)
414 (throw 'leave-recursive-edit (values :exit values)))
415
416 ;;; ABORT-RECURSIVE-EDIT is intended to be called within the dynamic context
417 ;;; of RECURSIVE-EDIT, causing EDITOR-ERROR to be called on args. When not
418 ;;; in a recursive edit, signal an error.
419 ;;;
420 (defun abort-recursive-edit (&rest args)
421 "Abort a recursive edit, causing an Editor-Error with the args given in
422 the calling context."
423 (unless *in-a-recursive-edit*
424 (error "Not in a recursive edit!"))
425 (invoke-hook ed::abort-recursive-edit-hook args)
426 (throw 'leave-recursive-edit (values :abort args)))
427
428
429
430 ;;;; WITH-WRITABLE-BUFFER
431
432 ;;; This list indicates recursive use of WITH-WRITABLE-BUFFER on the same
433 ;;; buffer.
434 ;;;
435 (defvar *writable-buffers* ())
436
437 (defmacro with-writable-buffer ((buffer) &body body)
438 "Executes body in a scope where buffer is writable. After body executes,
439 this sets the buffer's modified and writable status to nil."
440 (let ((buf (gensym))
441 (no-unwind (gensym)))
442 `(let* ((,buf ,buffer)
443 (,no-unwind (member ,buf *writable-buffers* :test #'eq))
444 (*writable-buffers* (if ,no-unwind
445 *writable-buffers*
446 (cons ,buf *writable-buffers*))))
447 (unwind-protect
448 (progn
449 (setf (buffer-writable ,buf) t)
450 ,@body)
451 (unless ,no-unwind
452 (setf (buffer-modified ,buf) nil)
453 (setf (buffer-writable ,buf) nil))))))
454
455
456
457 ;;;; DEFMODE.
458
459 (defun defmode (name &key (setup-function #'identity)
460 (cleanup-function #'identity) major-p transparent-p
461 precedence documentation)
462 "Define a new mode, specifying whether it is a major mode, and what the
463 setup and cleanup functions are. Precedence, which defaults to 0.0, and is
464 any integer or float, determines the order of the minor modes in a buffer.
465 A minor mode having a greater precedence is always considered before a mode
466 with lesser precedence when searching for key-bindings and variable values.
467 If Transparent-p is true, then all key-bindings local to the defined mode
468 are transparent, meaning that they do not shadow other bindings, but rather
469 are executed in addition to them. Documentation is used as introductory
470 text for mode describing commands."
471 (let ((hook-str (concatenate 'string name " Mode Hook"))
472 (mode (getstring name *mode-names*)))
473 (cond
474 (mode
475 (when (if major-p
476 (not (mode-object-major-p mode))
477 (mode-object-major-p mode))
478 (cerror "Let bad things happen"
479 "Mode ~S is being redefined as a ~:[Minor~;Major~] mode ~
480 where it was ~%~
481 previously a ~:*~:[Major~;Minor~] mode." name major-p))
482 (warn "Mode ~S is being redefined, variables and bindings will ~
483 be preserved." name)
484 (setq name (mode-object-name mode)))
485 (t
486 (defhvar hook-str
487 (concatenate 'string "This is the mode hook variable for "
488 name " Mode."))
489 (setq mode (make-mode-object
490 :variables (make-string-table)
491 :bindings (make-hash-table)
492 :hook-name (getstring hook-str *global-variable-names*)))
493 (setf (getstring name *mode-names*) mode)))
494
495 (if precedence
496 (if major-p
497 (error "Precedence ~S is meaningless for a major mode." precedence)
498 (check-type precedence number))
499 (setq precedence 0))
500
501 (setf (mode-object-major-p mode) major-p
502 (mode-object-documentation mode) documentation
503 (mode-object-transparent-p mode) transparent-p
504 (mode-object-precedence mode) precedence
505 (mode-object-setup-function mode) setup-function
506 (mode-object-cleanup-function mode) cleanup-function
507 (mode-object-name mode) name))
508 nil)
509
510 (defun mode-major-p (name)
511 "Returns T if Name is the name of a major mode, or NIL if is the name of
512 a minor mode."
513 (mode-object-major-p (get-mode-object name)))
514
515 (defun mode-variables (name)
516 "Return the string-table that contains the names of the modes variables."
517 (mode-object-variables (get-mode-object name)))
518
519 (defun mode-documentation (name)
520 "Returns the documentation for mode with name."
521 (mode-object-documentation (get-mode-object name)))
522
523
524
525 ;;;; Making and Deleting buffers.
526
527 (defvar *buffer-list* () "A list of all the buffer objects.")
528
529 (defvar *current-buffer* ()
530 "Internal variable which might contain the current buffer." )
531
532 (defun make-buffer (name &key (modes (value ed::default-modes))
533 (modeline-fields
534 (value ed::default-modeline-fields))
535 delete-hook)
536 "Creates and returns a buffer with the given Name if a buffer with Name does
537 not already exist, otherwise returns nil. Modes is a list of mode names,
538 and Modeline-fields is a list of modeline field objects. Delete-hook is a
539 list of functions that take a buffer as the argument."
540 (cond ((getstring name *buffer-names*) nil)
541 (t
542 (unless (listp delete-hook)
543 (error ":delete-hook is a list of functions -- ~S." delete-hook))
544 (let* ((region (make-empty-region))
545 (object (getstring "Fundamental" *mode-names*))
546 (buffer (internal-make-buffer
547 :%name name
548 :%region region
549 :modes (list (mode-object-name object))
550 :mode-objects (list object)
551 :bindings (make-hash-table)
552 :point (copy-mark (region-end region))
553 :display-start (copy-mark (region-start region))
554 :delete-hook delete-hook
555 :variables (make-string-table))))
556 (sub-set-buffer-modeline-fields buffer modeline-fields)
557 (setf (line-%buffer (mark-line (region-start region))) buffer)
558 (push buffer *buffer-list*)
559 (setf (getstring name *buffer-names*) buffer)
560 (unless (equalp modes '("Fundamental"))
561 (setf (buffer-major-mode buffer) (car modes))
562 (dolist (m (cdr modes))
563 (setf (buffer-minor-mode buffer m) t)))
564 (invoke-hook ed::make-buffer-hook buffer)
565 buffer))))
566
567 (defun delete-buffer (buffer)
568 "Deletes a buffer. If buffer is current, or if it is displayed in any
569 windows, an error is signaled."
570 (when (eq buffer *current-buffer*)
571 (error "Cannot delete current buffer ~S." buffer))
572 (when (buffer-windows buffer)
573 (error "Cannot delete buffer ~S, which is displayed in ~R window~:P."
574 buffer (length (buffer-windows buffer))))
575 (invoke-hook (buffer-delete-hook buffer) buffer)
576 (invoke-hook ed::delete-buffer-hook buffer)
577 (setq *buffer-list* (delq buffer *buffer-list*))
578 (delete-string (buffer-name buffer) *buffer-names*)
579 nil)
580
581
582
583 ;;;; Buffer start and end marks.
584
585 (defun buffer-start-mark (buffer)
586 "Returns the buffer-region's start mark."
587 (region-start (buffer-region buffer)))
588
589 (defun buffer-end-mark (buffer)
590 "Returns the buffer-region's end mark."
591 (region-end (buffer-region buffer)))
592
593
594
595 ;;;; Setting up initial buffer.
596
597 ;;; SETUP-INITIAL-BUFFER -- Internal
598 ;;;
599 ;;; Create the buffer "Main" and the mode "Fundamental". We make a
600 ;;; dummy fundamental mode before we make the buffer Main, because
601 ;;; "make-buffer" wants fundamental to be defined when it is called, and we
602 ;;; can't make the real fundamental mode until there is a current buffer
603 ;;; because "defmode" wants to invoke it's mode definition hook. Also,
604 ;;; when creating the "Main" buffer, "Default Modeline Fields" is not yet
605 ;;; defined, so we supply this argument to MAKE-BUFFER as nil. This is
606 ;;; fine since firing up the editor in a core must set the "Main" buffer's
607 ;;; modeline according to this variable in case the user changed it in his
608 ;;; init file. After the main buffer is created we then define the real
609 ;;; fundamental mode and bash it into the buffer.
610 ;;;
611 (defun setup-initial-buffer ()
612 ;; Make it look like the mode is there so make-buffer doesn't die.
613 (setf (getstring "Fundamental" *mode-names*)
614 (make-mode-object :major-p t))
615 ;; Make it look like there is a make-buffer-hook...
616 (setf (get 'ed::make-buffer-hook 'hemlock-variable-value)
617 (make-variable-object "foo" "bar"))
618 (setq *current-buffer* (make-buffer "Main" :modes '("Fundamental")
619 :modeline-fields nil))
620 ;; Make the bogus variable go away...
621 (remf (symbol-plist 'ed::make-buffer-hook) 'hemlock-variable-value)
622 ;; Make it go away so defmode doesn't die.
623 (setf (getstring "Fundamental" *mode-names*) nil)
624 (defmode "Fundamental" :major-p t)
625 ;; Bash the real mode object into the buffer.
626 (let ((obj (getstring "Fundamental" *mode-names*)))
627 (setf (car (buffer-mode-objects *current-buffer*)) obj
628 (car (buffer-modes *current-buffer*)) (mode-object-name obj))))

  ViewVC Help
Powered by ViewVC 1.1.5