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

Contents of /src/hemlock/buffer.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (hide 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 ram 1.1 ;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.3 ;;; 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/buffer.lisp,v 1.5 2001/03/13 15:49:51 pw Rel $")
9 ram 1.3 ;;;
10 ram 1.1 ;;; **********************************************************************
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 pw 1.5 (declaim (inline buffer-name buffer-pathname buffer-region))
60 ram 1.1
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 pw 1.5 (declaim (special *buffer-names*))
76 ram 1.1
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 pw 1.5 (declaim (special *mode-names*))
252 ram 1.1
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 pw 1.5 (declaim (inline current-buffer))
319 ram 1.1
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 pw 1.5 (declaim (inline in-recursive-edit))
376 ram 1.1
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 ram 1.2 :bindings (make-hash-table)
492 ram 1.1 :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 ram 1.2 :bindings (make-hash-table)
552 ram 1.1 :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