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

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

Various:

Implement prompt-for-key, the last of the prompting suite of functions.

Keep last-command around, not just last-key-event, though ended up not using it.

Stop using pty's for listener input, as they wedge the cocoa thread when the
listener is busy. Use a specialized stream using direct queues, as for output.

With above change, no longer use pty's at all, so stop loading PTY module.

Rearrange recursive setup so view activation happens outside of modifying-buffer-storage.

Fix so with-buffer-bindings doesn't get confused if already wound (can't wait
til I get rid of this whole winding thing!)

make c-n/c-p with numarg at least move to end of range when not enough lines.

API tweaks:

Get rid of *invoke-hook* since not usable in current setup anyway.
Make last-key-event-typed read-only.
Move cocoa-specific part of keysym-defs to cocoa-editor.lisp
Move everything out of hemock-ext, make hemlock-ext be strictly the external support API.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 20.6 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 (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))))
Note: See TracBrowser for help on using the repository browser.