source: trunk/source/cocoa-ide/hemlock/src/buffer.lisp @ 12564

Last change on this file since 12564 was 12564, checked in by gz, 11 years ago

Make buffers keep track of their lines in a vector, use that for a better implementation of move-to-absolute-position

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 21.4 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, ensuring that
238   the region's active."
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-selection-start ()
248  "Return the Buffer-Point of the current buffer, ensuring that
249   the region's active.  If the region was active but the
250   buffer's SELECTION-SET-BY-COMMAND flag is false, ensure that
251   point precedes mark by exchanging their positions if necessary."
252  (let* ((b *current-buffer*)
253         (point (buffer-point b)))
254    ;; If the region is active, keep it active.  Otherwise,
255    ;; establish a new (empty) region at point.
256    (if (%buffer-current-region-p b)
257      (unless (buffer-selection-set-by-command b)
258        (let* ((mark (current-mark)))
259          (if (mark< mark point)
260            (with-mark ((temp point))
261              (move-mark point mark)
262              (move-mark mark temp)))))
263      (push-new-buffer-mark point t))
264    point))
265
266(defun current-point-for-selection-end ()
267  "Return the Buffer-Point of the current buffer, ensuring that
268   the region's active.  If the region was active but the
269   buffer's SELECTION-SET-BY-COMMAND flag is false, ensure that
270   point follows mark by exchanging their positions if necessary."
271  (let* ((b *current-buffer*)
272         (point (buffer-point b)))
273    ;; If the region is active, keep it active.  Otherwise,
274    ;; establish a new (empty) region at point.
275    (if (%buffer-current-region-p b)
276      (unless (buffer-selection-set-by-command b)
277        (let* ((mark (current-mark)))
278          (if (mark> mark point)
279            (with-mark ((temp point))
280              (move-mark point mark)
281              (move-mark mark temp)))))
282      (push-new-buffer-mark point t))
283    point))
284 
285
286
287(defun current-point-for-insertion ()
288  "Check to see if the current buffer can be modified at its
289  current point; error if not.  If there's a selection in the
290  current buffer, delete it.  Return the current point."
291  (let* ((buffer *current-buffer*)
292         (point (buffer-point buffer)))
293    (check-buffer-modification buffer point)
294    (let* ((region (%buffer-current-region buffer)))
295      (when region
296        (delete-region region))
297      point)))
298
299(defun current-point-for-deletion ()
300  "Check to see if the current buffer can be modified at its
301  current point; error if not.  If there's a selection in the
302  current buffer, delete it and return NIL, else return the
303  current point."
304  (let* ((buffer *current-buffer*)
305         (point (buffer-point buffer)))
306    (check-buffer-modification buffer point)
307    (let* ((region (%buffer-current-region buffer)))
308      (if region
309        (progn
310          (delete-region region)
311          nil)
312        point))))
313
314(defun current-point-unless-selection ()
315  "Check to see if the current buffer can be modified at its
316  current point; error if not.  If there's a selection in the
317  current buffer, return NIL, else return the  current point."
318  (let* ((buffer *current-buffer*)
319         (point (buffer-point buffer)))
320    (check-buffer-modification buffer point)
321    (let* ((region (%buffer-current-region buffer)))
322      (unless region
323        point))))
324
325;;;; WITH-WRITABLE-BUFFER
326
327;;; This list indicates recursive use of WITH-WRITABLE-BUFFER on the same
328;;; buffer.
329;;;
330(defvar *writable-buffers* ())
331
332(defmacro with-writable-buffer ((buffer) &body body)
333  "Executes body in a scope where buffer is writable.  After body executes,
334   this sets the buffer's modified and writable status to nil."
335  (let ((buf (gensym))
336        (no-unwind (gensym)))
337    `(let* ((,buf ,buffer)
338            (,no-unwind (member ,buf *writable-buffers* :test #'eq))
339            (*writable-buffers* (if ,no-unwind
340                                    *writable-buffers*
341                                    (cons ,buf *writable-buffers*))))
342       (unwind-protect
343           (progn
344             (setf (buffer-writable ,buf) t)
345             ,@body)
346         (unless ,no-unwind
347           (setf (buffer-modified ,buf) nil)
348           (setf (buffer-writable ,buf) nil))))))
349
350
351
352;;;; DEFMODE.
353
354(defun defmode (name &key (setup-function #'identity) 
355                     (cleanup-function #'identity) major-p transparent-p
356                     precedence documentation hidden default-command)
357  "Define a new mode, specifying whether it is a major mode, and what the
358   setup and cleanup functions are.  Precedence, which defaults to 0.0, and is
359   any integer or float, determines the order of the minor modes in a buffer.
360   A minor mode having a greater precedence is always considered before a mode
361   with lesser precedence when searching for key-bindings and variable values.
362   If Transparent-p is true, then all key-bindings local to the defined mode
363   are transparent, meaning that they do not shadow other bindings, but rather
364   are executed in addition to them.  Documentation is used as introductory
365   text for mode describing commands."
366  (let ((hook-str (concatenate 'string name " Mode Hook"))
367        (mode (getstring name *mode-names*)))
368    (cond
369     (mode
370      (when (if major-p
371                (not (mode-object-major-p mode))
372                (mode-object-major-p mode))
373        (cerror "Let bad things happen"
374                "Mode ~S is being redefined as a ~:[Minor~;Major~] mode ~
375                where it was ~%~
376                previously a ~:*~:[Major~;Minor~] mode." name major-p))
377      (warn "Mode ~S is being redefined, variables and bindings will ~
378            be preserved." name)
379      (setq name (mode-object-name mode)))
380     (t
381      (defhvar hook-str
382               (concatenate 'string "This is the mode hook variable for "
383               name " Mode."))
384      (setq mode (make-mode-object
385                  :variables (make-string-table)
386                  :bindings (make-hash-table)
387                  :hook-name (getstring hook-str *global-variable-names*)
388                  :hidden hidden))
389      (setf (getstring name *mode-names*) mode)))
390
391    (when (eq precedence :highest)
392      (setq precedence most-positive-double-float))
393    (if precedence
394        (if major-p
395            (error "Precedence ~S is meaningless for a major mode." precedence)
396            (check-type precedence number))
397        (setq precedence 0))
398   
399    (when default-command
400      (setf (mode-object-default-command mode) default-command))
401
402    (setf (mode-object-major-p mode) major-p
403          (mode-object-documentation mode) documentation
404          (mode-object-transparent-p mode) transparent-p
405          (mode-object-precedence mode) precedence
406          (mode-object-setup-function mode) setup-function
407          (mode-object-cleanup-function mode) cleanup-function
408          (mode-object-name mode) name))
409  nil)
410
411(defun mode-major-p (name)
412  "Returns T if Name is the name of a major mode, or NIL if is the name of
413  a minor mode."
414  (mode-object-major-p (get-mode-object name)))
415
416(defun mode-variables (name)
417  "Return the string-table that contains the names of the modes variables."
418  (mode-object-variables (get-mode-object name)))
419
420(defun mode-documentation (name)
421  "Returns the documentation for mode with name."
422  (mode-object-documentation (get-mode-object name)))
423
424
425
426;;;; Making and Deleting buffers.
427
428(defvar *buffer-list* () "A list of all the buffer objects.")
429
430(defvar *current-buffer* ()
431  "Internal variable which might contain the current buffer." )
432
433(defun all-buffers ()
434  "List of all buffers"
435  (remove-if #'echo-buffer-p *buffer-list*))
436
437(ccl:defloadvar *echo-area-counter* 0)
438
439(defun make-echo-buffer ()
440  (let* ((name (loop as name = (format nil "Echo Area ~d" (incf *echo-area-counter*))
441                  until (null (getstring name *buffer-names*))
442                  finally (return name)))
443         (buffer (internal-make-echo-buffer
444                  :%name name
445                  :major-mode-object (getstring "Echo Area" *mode-names*))))
446    (initialize-buffer buffer)))
447
448(defun make-buffer (name &key (modes (value hemlock::default-modes))
449                              (modeline-fields (value hemlock::default-modeline-fields))
450                              delete-hook)
451  "Creates and returns a buffer with the given Name if a buffer with Name does
452   not already exist, otherwise returns nil.  Modes is a list of mode names,
453   and Modeline-fields is a list of modeline field objects.  Delete-hook is a
454   list of functions that take a buffer as the argument."
455  (when (getstring name *buffer-names*)
456    (cerror "Try to delete" "~s already exists" name)
457    (let ((buffer (getstring name *buffer-names*)))
458      (delete-buffer buffer)))
459  (cond ((getstring name *buffer-names*)
460         nil)
461        (t
462         (unless (listp delete-hook)
463           (error ":delete-hook is a list of functions -- ~S." delete-hook))
464         (let* ((buffer (internal-make-buffer
465                         :%name name
466                         :major-mode-object (getstring "Fundamental" *mode-names*)
467                         :delete-hook delete-hook)))
468           (initialize-buffer buffer :modeline-fields modeline-fields :modes modes)))))
469
470(defun initialize-buffer (buffer &key modeline-fields modes)
471  (setf (buffer-bindings buffer) (make-hash-table))
472  (setf (buffer-variables buffer) (make-string-table))
473  (let ((region (make-empty-region)))
474    (setf (line-%buffer (mark-line (region-start region))) buffer)
475    (setf (buffer-%region buffer) region)
476    (setf (buffer-point buffer) (copy-mark (region-end region))))
477  (setf (getstring (buffer-%name buffer) *buffer-names*) buffer)
478  (push buffer *buffer-list*)
479  (set-buffer-modeline-fields buffer modeline-fields)
480  (when modes
481    (unless (equalp modes '("Fundamental"))
482      (setf (buffer-major-mode buffer) (car modes))
483      (dolist (m (cdr modes))
484        (setf (buffer-minor-mode buffer m) t))))
485  (invoke-hook hemlock::make-buffer-hook buffer)
486  buffer)
487
488(defun delete-buffer (buffer)
489  "Deletes a buffer.  If buffer is current, an error is signaled."
490  (when (eq buffer *current-buffer*)
491    (error "Cannot delete current buffer ~S." buffer))
492  (when (buffer-document buffer)
493    (error "Cannot delete displayed buffer ~S." buffer))
494  (invoke-hook (buffer-delete-hook buffer) buffer)
495  (invoke-hook hemlock::delete-buffer-hook buffer)
496  (setq *buffer-list* (delq buffer *buffer-list*))
497  (delete-string (buffer-name buffer) *buffer-names*)
498  nil)
499
500(defun buffer-lines (buffer)
501  (let ((lines (buffer-%lines buffer)))
502    (when (eql (fill-pointer lines) 0)
503      (loop for origin = 0 then (+ origin (buffer-line-length l) 1)
504            for l = (mark-line (region-start (buffer-%region buffer))) then (line-next l) while l
505            do (setf (line-origin l) origin)
506            do (vector-push-extend l lines)))
507    lines))
508
509;; This will return the last line if posn is out of range (or first line if it's negative)
510(defun buffer-line-at-absolute-position (buffer posn)
511  (declare (optimize (speed 3) (safety 0)))
512  (let* ((lines (buffer-lines (ccl:require-type buffer 'buffer)))
513         (posn (ccl:require-type posn 'fixnum))
514         (vec (ccl::array-data-and-offset lines))
515         (start 0)
516         (end (fill-pointer lines)))
517    (declare (fixnum start end posn))
518    (loop
519      (let* ((middle (ash (the fixnum (+ start end)) -1))
520             (line (svref vec middle)))
521        (declare (fixnum middle))
522        (when (= middle start)
523          (return line))
524        (if (< posn (the fixnum (line-origin line)))
525          (setq end middle)
526          (setq start middle))))))
527
528;; Called whenever change a line's next or previous pointer.  Don't update immediately
529;; so don't thrash when inserting multiple lines.
530(declaim (inline invalidate-buffer-lines))
531(defun invalidate-buffer-lines (buffer)
532  (setf (fill-pointer (buffer-%lines buffer)) 0))
533
534;;;; Buffer start and end marks.
535
536(defun buffer-start-mark (buffer)
537  "Returns the buffer-region's start mark."
538  (region-start (buffer-region buffer)))
539
540(defun buffer-end-mark (buffer)
541  "Returns the buffer-region's end mark."
542  (region-end (buffer-region buffer)))
543
544
545
546;;;; Setting up initial buffer.
547
548;;; SETUP-INITIAL-BUFFER  --  Internal
549;;;
550;;;    Create the buffer "Main" and the mode "Fundamental".  We make a
551;;; dummy fundamental mode before we make the buffer Main, because
552;;; "make-buffer" wants fundamental to be defined when it is called, and we
553;;; can't make the real fundamental mode until there is a current buffer
554;;; because "defmode" wants to invoke its mode definition hook.  Also,
555;;; when creating the "Main" buffer, "Default Modeline Fields" is not yet
556;;; defined, so we supply this argument to MAKE-BUFFER as nil.  This is
557;;; fine since firing up the editor in a core must set the "Main" buffer's
558;;; modeline according to this variable in case the user changed it in his
559;;; init file.  After the main buffer is created we then define the real
560;;; fundamental mode and bash it into the buffer.
561;;;
562(defun setup-initial-buffer ()
563  ;; Make it look like the mode is there so make-buffer doesn't die.
564  (setf (getstring "Fundamental" *mode-names*)
565        (make-mode-object :major-p t))
566  ;; Make it look like there is a make-buffer-hook...
567  (setf (get 'hemlock::make-buffer-hook 'hemlock-variable-value)
568        (make-variable-object 'foo))
569  (setq *current-buffer* (make-buffer "Main" :modes '("Fundamental")
570                                      :modeline-fields nil))
571  ;; Make the bogus variable go away...
572  (remf (symbol-plist 'hemlock::make-buffer-hook) 'hemlock-variable-value)
573  ;; Make it go away so defmode doesn't die.
574  (setf (getstring "Fundamental" *mode-names*) nil)
575  (defmode "Fundamental" :major-p t)
576  ;; Bash the real mode object into the buffer.
577  (let ((obj (getstring "Fundamental" *mode-names*)))
578    (setf (buffer-major-mode-object *current-buffer*) obj)))
Note: See TracBrowser for help on using the repository browser.