source: branches/event-ide/ccl/cocoa-ide/hemlock/src/buffer.lisp @ 8062

Last change on this file since 8062 was 8062, checked in by gz, 13 years ago

Get rid of the variable "winding" scheme (which used to swap the
current buffer's variable bindings into symbol plists), simplify
variable and mode handing.

Fix a shadow attribute caching bug.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 17.5 KB
Line 
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 (buffer)
96  "Return a copy of the buffer's modeline fields list."
97  (do ((finfos (buffer-%modeline-fields buffer) (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;;;; BUFFER-MAJOR-MODE.
127
128(defmacro with-mode-and-buffer ((name major-p buffer) &body forms)
129  `(let ((mode (get-mode-object ,name)))
130    (setq ,name (mode-object-name mode))
131    (,(if major-p 'unless 'when) (mode-object-major-p mode)
132      (error "~S is not a ~:[Minor~;Major~] Mode." ,name ,major-p))
133    (check-type ,buffer buffer)
134    ,@forms))
135
136;;; BUFFER-MAJOR-MODE  --  Public
137;;;
138;;;
139(defun buffer-major-mode (buffer)
140  "Return the name of Buffer's major mode.  To change tha major mode
141  use Setf."
142  (check-type buffer buffer)
143  (mode-object-name (buffer-major-mode-object buffer)))
144
145;;; %SET-BUFFER-MAJOR-MODE  --  Public
146;;;
147(defun %set-buffer-major-mode (buffer name)
148  "Set the major mode of some buffer to the Name'd mode."
149  (with-mode-and-buffer (name t buffer)
150    (invoke-hook hemlock::buffer-major-mode-hook buffer name)
151    (let ((old-mode (buffer-major-mode-object buffer)))
152      (invoke-hook (%value (mode-object-hook-name old-mode)) buffer nil)
153      (funcall (mode-object-cleanup-function old-mode) buffer))
154    (setf (buffer-major-mode-object buffer) mode)
155    (invalidate-shadow-attributes buffer)
156    (funcall (mode-object-setup-function mode) buffer)
157    (invoke-hook (%value (mode-object-hook-name mode)) buffer t))
158  nil)
159
160
161
162;;;; BUFFER-MINOR-MODE.
163
164;;; BUFFER-MINOR-MODE  --  Public
165;;;
166;;;    Check if the mode-object is in the buffer's mode-list.
167;;;
168(defun buffer-minor-mode (buffer name)
169  "Return true if the minor mode named Name is active in Buffer.
170  A minor mode can be turned on or off with Setf."
171  (with-mode-and-buffer (name nil buffer)
172    (not (null (member mode (buffer-minor-mode-objects buffer))))))
173   
174(declaim (special *mode-names*))
175
176;;; %SET-BUFFER-MINOR-MODE  --  Public
177;;;
178;;;    Activate or deactivate a minor mode, with due respect for
179;;; bindings.
180;;;
181(defun %set-buffer-minor-mode (buffer name new-value)
182  (with-mode-and-buffer (name nil buffer)
183    (let ((objects (buffer-minor-mode-objects buffer)))
184      (unless (if (member mode objects) new-value (not new-value))
185        (invoke-hook hemlock::buffer-minor-mode-hook buffer name new-value)
186        (cond
187         ;; Adding a new mode, insert sorted.
188         (new-value
189          (do ((m objects (cdr m))
190               (prev nil m))
191              ((or (null m)
192                   (< (mode-object-precedence (car m))
193                      (mode-object-precedence mode)))
194               (if prev
195                 (setf (cdr prev) (cons mode m))
196                 (setf (buffer-minor-mode-objects buffer) (setq objects (cons mode m))))))
197          (funcall (mode-object-setup-function mode) buffer)
198          (invoke-hook (%value (mode-object-hook-name mode)) buffer t))
199         (t
200          ;; Removing an active mode.
201          (invoke-hook (%value (mode-object-hook-name mode)) buffer nil)
202          (funcall (mode-object-cleanup-function mode) buffer)
203          (setf (buffer-minor-mode-objects buffer) (delq mode (buffer-minor-mode-objects buffer)))))))
204    new-value))
205
206;;; BUFFER-MODES -- Public
207;;; List of buffer mode names, in precendence order, major mode first.
208;;;
209(defun buffer-modes (buffer)
210  "Return the list of the names of the modes active in a given buffer."
211  (cons (buffer-major-mode buffer)
212        (nreverse (mapcar #'mode-object-name (buffer-minor-mode-objects buffer)))))
213
214
215;;;; CURRENT-BUFFER, CURRENT-POINT, and buffer using setup and cleanup.
216
217(declaim (inline current-buffer))
218
219(defun current-buffer () "Return the current buffer object." *current-buffer*)
220
221(defun current-point ()
222  "Return the Buffer-Point of the current buffer."
223  (buffer-point *current-buffer*))
224
225
226
227(defun current-point-collapsing-selection ()
228  "Return the Buffer-Point of the current buffer, deactivating the
229   region."
230  (let* ((b *current-buffer*)
231         (point (buffer-point b)))
232    ;; Deactivate the region
233    (setf (buffer-region-active b) nil)
234    point))
235
236(defun current-point-extending-selection ()
237  "Return the Buffer-Point of the current buffer, deactivating the
238   region."
239  (let* ((b *current-buffer*)
240         (point (buffer-point b)))
241    ;; If the region is active, keep it active.  Otherwise,
242    ;; establish a new (empty) region at point.
243    (unless (%buffer-current-region-p b)
244      (push-new-buffer-mark point t))
245    point))
246
247(defun current-point-for-insertion ()
248  "Check to see if the current buffer can be modified at its
249  current point; error if not.  If there's a selection in the
250  current buffer, delete it.  Return the current point."
251  (let* ((buffer *current-buffer*)
252         (point (buffer-point buffer)))
253    (check-buffer-modification buffer point)
254    (let* ((region (%buffer-current-region buffer)))
255      (when region
256        (delete-region region))
257      point)))
258
259(defun current-point-for-deletion ()
260  "Check to see if the current buffer can be modified at its
261  current point; error if not.  If there's a selection in the
262  current buffer, delete it and return NIL, else return the
263  current point."
264  (let* ((buffer *current-buffer*)
265         (point (buffer-point buffer)))
266    (check-buffer-modification buffer point)
267    (let* ((region (%buffer-current-region buffer)))
268      (if region
269        (progn
270          (delete-region region)
271          nil)
272        point))))
273
274(defun current-point-unless-selection ()
275  "Check to see if the current buffer can be modified at its
276  current point; error if not.  If there's a selection in the
277  current buffer, return NIL, else return the  current point."
278  (let* ((buffer *current-buffer*)
279         (point (buffer-point buffer)))
280    (check-buffer-modification buffer point)
281    (let* ((region (%buffer-current-region buffer)))
282      (unless region
283        point))))
284
285;;;; WITH-WRITABLE-BUFFER
286
287;;; This list indicates recursive use of WITH-WRITABLE-BUFFER on the same
288;;; buffer.
289;;;
290(defvar *writable-buffers* ())
291
292(defmacro with-writable-buffer ((buffer) &body body)
293  "Executes body in a scope where buffer is writable.  After body executes,
294   this sets the buffer's modified and writable status to nil."
295  (let ((buf (gensym))
296        (no-unwind (gensym)))
297    `(let* ((,buf ,buffer)
298            (,no-unwind (member ,buf *writable-buffers* :test #'eq))
299            (*writable-buffers* (if ,no-unwind
300                                    *writable-buffers*
301                                    (cons ,buf *writable-buffers*))))
302       (unwind-protect
303           (progn
304             (setf (buffer-writable ,buf) t)
305             ,@body)
306         (unless ,no-unwind
307           (setf (buffer-modified ,buf) nil)
308           (setf (buffer-writable ,buf) nil))))))
309
310
311
312;;;; DEFMODE.
313
314(defun defmode (name &key (setup-function #'identity) 
315                     (cleanup-function #'identity) major-p transparent-p
316                     precedence documentation hidden default-command)
317  "Define a new mode, specifying whether it is a major mode, and what the
318   setup and cleanup functions are.  Precedence, which defaults to 0.0, and is
319   any integer or float, determines the order of the minor modes in a buffer.
320   A minor mode having a greater precedence is always considered before a mode
321   with lesser precedence when searching for key-bindings and variable values.
322   If Transparent-p is true, then all key-bindings local to the defined mode
323   are transparent, meaning that they do not shadow other bindings, but rather
324   are executed in addition to them.  Documentation is used as introductory
325   text for mode describing commands."
326  (let ((hook-str (concatenate 'string name " Mode Hook"))
327        (mode (getstring name *mode-names*)))
328    (cond
329     (mode
330      (when (if major-p
331                (not (mode-object-major-p mode))
332                (mode-object-major-p mode))
333        (cerror "Let bad things happen"
334                "Mode ~S is being redefined as a ~:[Minor~;Major~] mode ~
335                where it was ~%~
336                previously a ~:*~:[Major~;Minor~] mode." name major-p))
337      (warn "Mode ~S is being redefined, variables and bindings will ~
338            be preserved." name)
339      (setq name (mode-object-name mode)))
340     (t
341      (defhvar hook-str
342               (concatenate 'string "This is the mode hook variable for "
343               name " Mode."))
344      (setq mode (make-mode-object
345                  :variables (make-string-table)
346                  :bindings (make-hash-table)
347                  :hook-name (getstring hook-str *global-variable-names*)
348                  :hidden hidden))
349      (setf (getstring name *mode-names*) mode)))
350
351    (when (eq precedence :highest)
352      (setq precedence most-positive-double-float))
353    (if precedence
354        (if major-p
355            (error "Precedence ~S is meaningless for a major mode." precedence)
356            (check-type precedence number))
357        (setq precedence 0))
358   
359    (when default-command
360      (setf (mode-object-default-command mode) default-command))
361
362    (setf (mode-object-major-p mode) major-p
363          (mode-object-documentation mode) documentation
364          (mode-object-transparent-p mode) transparent-p
365          (mode-object-precedence mode) precedence
366          (mode-object-setup-function mode) setup-function
367          (mode-object-cleanup-function mode) cleanup-function
368          (mode-object-name mode) name))
369  nil)
370
371(defun mode-major-p (name)
372  "Returns T if Name is the name of a major mode, or NIL if is the name of
373  a minor mode."
374  (mode-object-major-p (get-mode-object name)))
375
376(defun mode-variables (name)
377  "Return the string-table that contains the names of the modes variables."
378  (mode-object-variables (get-mode-object name)))
379
380(defun mode-documentation (name)
381  "Returns the documentation for mode with name."
382  (mode-object-documentation (get-mode-object name)))
383
384
385
386;;;; Making and Deleting buffers.
387
388(defvar *buffer-list* () "A list of all the buffer objects.")
389
390(defvar *current-buffer* ()
391  "Internal variable which might contain the current buffer." )
392
393(defun make-buffer (name &key (modes (value hemlock::default-modes))
394                              (modeline-fields
395                               (value hemlock::default-modeline-fields))
396                              delete-hook)
397  "Creates and returns a buffer with the given Name if a buffer with Name does
398   not already exist, otherwise returns nil.  Modes is a list of mode names,
399   and Modeline-fields is a list of modeline field objects.  Delete-hook is a
400   list of functions that take a buffer as the argument."
401  #+GZ
402  (when (getstring name *buffer-names*)
403    (cerror "Try to delete" "~s already exists" name)
404    (let ((buffer (getstring name *buffer-names*)))
405      (delete-buffer buffer)))
406  (cond ((getstring name *buffer-names*)
407         nil)
408        (t
409         (unless (listp delete-hook)
410           (error ":delete-hook is a list of functions -- ~S." delete-hook))
411         (let* ((region (make-empty-region))
412                (object (getstring "Fundamental" *mode-names*))
413                (buffer (internal-make-buffer
414                         :%name name
415                         :%region region
416                         :major-mode-object object
417                         :bindings (make-hash-table)
418                         :point (copy-mark (region-end region))
419                         :delete-hook delete-hook
420                         :variables (make-string-table))))
421           (set-buffer-modeline-fields buffer modeline-fields)
422           (setf (line-%buffer (mark-line (region-start region))) buffer)
423           (push buffer *buffer-list*)
424           (setf (getstring name *buffer-names*) buffer)
425           (unless (equalp modes '("Fundamental"))
426             (setf (buffer-major-mode buffer) (car modes))
427             (dolist (m (cdr modes))
428               (setf (buffer-minor-mode buffer m) t)))
429           (invoke-hook hemlock::make-buffer-hook buffer)
430           buffer))))
431
432(defun delete-buffer (buffer)
433  "Deletes a buffer.  If buffer is current, an error is signaled."
434  (when (eq buffer *current-buffer*)
435    (error "Cannot delete current buffer ~S." buffer))
436  (invoke-hook (buffer-delete-hook buffer) buffer)
437  (invoke-hook hemlock::delete-buffer-hook buffer)
438  (setq *buffer-list* (delq buffer *buffer-list*))
439  (delete-string (buffer-name buffer) *buffer-names*)
440  nil)
441
442
443
444;;;; Buffer start and end marks.
445
446(defun buffer-start-mark (buffer)
447  "Returns the buffer-region's start mark."
448  (region-start (buffer-region buffer)))
449
450(defun buffer-end-mark (buffer)
451  "Returns the buffer-region's end mark."
452  (region-end (buffer-region buffer)))
453
454
455
456;;;; Setting up initial buffer.
457
458;;; SETUP-INITIAL-BUFFER  --  Internal
459;;;
460;;;    Create the buffer "Main" and the mode "Fundamental".  We make a
461;;; dummy fundamental mode before we make the buffer Main, because
462;;; "make-buffer" wants fundamental to be defined when it is called, and we
463;;; can't make the real fundamental mode until there is a current buffer
464;;; because "defmode" wants to invoke it's mode definition hook.  Also,
465;;; when creating the "Main" buffer, "Default Modeline Fields" is not yet
466;;; defined, so we supply this argument to MAKE-BUFFER as nil.  This is
467;;; fine since firing up the editor in a core must set the "Main" buffer's
468;;; modeline according to this variable in case the user changed it in his
469;;; init file.  After the main buffer is created we then define the real
470;;; fundamental mode and bash it into the buffer.
471;;;
472(defun setup-initial-buffer ()
473  ;; Make it look like the mode is there so make-buffer doesn't die.
474  (setf (getstring "Fundamental" *mode-names*)
475        (make-mode-object :major-p t))
476  ;; Make it look like there is a make-buffer-hook...
477  (setf (get 'hemlock::make-buffer-hook 'hemlock-variable-value)
478        (make-variable-object 'foo))
479  (setq *current-buffer* (make-buffer "Main" :modes '("Fundamental")
480                                      :modeline-fields nil))
481  ;; Make the bogus variable go away...
482  (remf (symbol-plist 'hemlock::make-buffer-hook) 'hemlock-variable-value)
483  ;; Make it go away so defmode doesn't die.
484  (setf (getstring "Fundamental" *mode-names*) nil)
485  (defmode "Fundamental" :major-p t)
486  ;; Bash the real mode object into the buffer.
487  (let ((obj (getstring "Fundamental" *mode-names*)))
488    (setf (buffer-major-mode-object *current-buffer*) obj)))
Note: See TracBrowser for help on using the repository browser.