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