source: tags/pre_1_0_pre_hash_modifications/ccl/hemlock/src/buffer.lisp @ 2475

Last change on this file since 2475 was 2475, checked in by anonymous, 14 years ago

This commit was manufactured by cvs2svn to create tag
'pre_1_0_pre_hash_modifications'.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 23.0 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    (invoke-hook hemlock::buffer-modified-hook buffer sense)
45    (if sense
46      (setf (buffer-modified-tick buffer) (tick))
47      (setf (buffer-unmodified-tick buffer) (tick)))
48    (unless (eq was-modified (buffer-modified buffer))
49      (queue-buffer-change buffer)))
50  (let* ((document (buffer-document buffer)))
51    (if document (set-document-modified document sense)))
52  sense)
53
54
55(declaim (inline buffer-name buffer-pathname buffer-region))
56
57(defun buffer-region (buffer)
58  "Return the region which contains Buffer's text."
59  (buffer-%region buffer))
60
61(defun %set-buffer-region (buffer new-region)
62  (let ((old (buffer-region buffer)))
63    (delete-region old)
64    (ninsert-region (region-start old) new-region)
65    old))
66
67(defun buffer-name (buffer)
68  "Return Buffer's string name."
69  (buffer-%name buffer))
70
71(declaim (special *buffer-names*))
72
73(defun %set-buffer-name (buffer name)
74  (multiple-value-bind (entry foundp) (getstring name *buffer-names*)
75    (cond ((or (not foundp) (eq entry buffer))
76           (invoke-hook hemlock::buffer-name-hook buffer name)
77           (delete-string (buffer-%name buffer) *buffer-names*)
78           (setf (getstring name *buffer-names*) buffer)
79           (setf (buffer-%name buffer) name))
80          (t (error "Cannot rename buffer ~S to ~S.  Name already in use."
81                    buffer name)))))
82
83(defun buffer-pathname (buffer)
84  "Return a pathname for the file in Buffer.  This is the truename
85  of the file as of the last time it was read or written."
86  (buffer-%pathname buffer))
87
88
89(defun %set-buffer-pathname (buffer pathname)
90  (invoke-hook hemlock::buffer-pathname-hook buffer pathname)
91  (setf (buffer-%pathname buffer) pathname))
92
93(defun buffer-modeline-fields (window)
94  "Return a copy of the buffer's modeline fields list."
95  (do ((finfos (buffer-%modeline-fields window) (cdr finfos))
96       (result () (cons (ml-field-info-field (car finfos)) result)))
97      ((null finfos) (nreverse result))))
98
99(defun %set-buffer-modeline-fields (buffer fields)
100  (check-type fields list)
101  (check-type buffer buffer "a Hemlock buffer")
102  (sub-set-buffer-modeline-fields buffer fields)
103  (dolist (w (buffer-windows buffer))
104    (update-modeline-fields buffer w)))
105
106(defun sub-set-buffer-modeline-fields (buffer modeline-fields)
107  (unless (every #'modeline-field-p modeline-fields)
108    (error "Fields must be a list of modeline-field objects."))
109  (setf (buffer-%modeline-fields buffer)
110        (do ((fields modeline-fields (cdr fields))
111             (res nil (cons (make-ml-field-info (car fields))
112                            res)))
113            ((null fields) (nreverse res)))))
114
115(defun buffer-modeline-field-p (buffer field)
116  "If field, a modeline-field or the name of one, is in buffer's list of
117   modeline-fields, it is returned; otherwise, nil."
118  (let ((finfo (internal-buffer-modeline-field-p buffer field)))
119    (if finfo (ml-field-info-field finfo))))
120
121(defun internal-buffer-modeline-field-p (buffer field)
122  (let ((fields (buffer-%modeline-fields buffer)))
123    (if (modeline-field-p field)
124        (find field fields :test #'eq :key #'ml-field-info-field)
125        (find field fields
126              :key #'(lambda (f)
127                       (modeline-field-name (ml-field-info-field f)))))))
128
129
130
131;;;; Variable binding -- winding and unwinding.
132
133(eval-when (:compile-toplevel :execute)
134
135(defmacro unbind-variable-bindings (bindings)
136  `(do ((binding ,bindings (binding-across binding)))
137       ((null binding))
138     (setf (car (binding-cons binding))
139           (variable-object-down (binding-object binding)))))
140
141(defmacro bind-variable-bindings (bindings)
142  `(do ((binding ,bindings (binding-across binding)))
143       ((null binding))
144     (let ((cons (binding-cons binding))
145           (object (binding-object binding)))
146       (setf (variable-object-down object) (car cons)
147             (car cons) object))))
148
149) ;eval-when
150
151;;; UNWIND-BINDINGS  --  Internal
152;;;
153;;;    Unwind buffer variable bindings and all mode bindings up to and
154;;; including mode.  Return a list of the modes unwound in reverse order.
155;;; (buffer-mode-objects *current-buffer*) is clobbered.  If "mode" is NIL
156;;; unwind all bindings.
157;;;
158(defun unwind-bindings (mode)
159  (unbind-variable-bindings (buffer-var-values *current-buffer*))
160  (do ((curmode (buffer-mode-objects *current-buffer*))
161       (unwound ()) cw)
162      (())
163    (setf cw curmode  curmode (cdr curmode)  (cdr cw) unwound  unwound cw)
164    (unbind-variable-bindings (mode-object-var-values (car unwound)))
165    (when (or (null curmode) (eq (car unwound) mode))
166      (setf (buffer-mode-objects *current-buffer*) curmode)
167      (return unwound))))
168
169;;; WIND-BINDINGS  --  Internal
170;;;
171;;;    Add "modes" to the mode bindings currently in effect.
172;;;
173(defun wind-bindings (modes)
174  (do ((curmode (buffer-mode-objects *current-buffer*)) cw)
175      ((null modes) (setf (buffer-mode-objects *current-buffer*) curmode))
176    (bind-variable-bindings (mode-object-var-values (car modes)))
177    (setf cw modes  modes (cdr modes)  (cdr cw) curmode  curmode cw))
178  (bind-variable-bindings (buffer-var-values *current-buffer*)))
179
180
181
182;;;; BUFFER-MAJOR-MODE.
183
184(eval-when (:compile-toplevel :execute)
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) ;eval-when
193
194;;; BUFFER-MAJOR-MODE  --  Public
195;;;
196;;;    The major mode is the first on the list, so just return that.
197;;;
198(defun buffer-major-mode (buffer)
199  "Return the name of Buffer's major mode.  To change tha major mode
200  use Setf."
201  (check-type buffer buffer)
202  (car (buffer-modes buffer)))
203
204;;; %SET-BUFFER-MAJOR-MODE  --  Public
205;;;
206;;;    Unwind all modes in effect and add the major mode specified.
207;;;Note that BUFFER-MODE-OBJECTS is in order of invocation in buffers
208;;;other than the current buffer, and in the reverse order in the
209;;;current buffer.
210;;;
211(defun %set-buffer-major-mode (buffer name)
212  "Set the major mode of some buffer to the Name'd mode."
213  (with-mode-and-buffer (name t buffer)
214    (invoke-hook hemlock::buffer-major-mode-hook buffer name)
215    (cond
216     ((eq buffer *current-buffer*)
217      (let ((old-mode (car (last (buffer-mode-objects buffer)))))
218        (invoke-hook (%value (mode-object-hook-name old-mode)) buffer nil)
219        (funcall (mode-object-cleanup-function old-mode) buffer)
220        (swap-char-attributes old-mode)
221        (wind-bindings (cons mode (cdr (unwind-bindings old-mode))))
222        (swap-char-attributes mode)))
223     (t
224      (let ((old-mode (car (buffer-mode-objects buffer))))
225        (invoke-hook (%value (mode-object-hook-name old-mode)) buffer nil)
226        (funcall (mode-object-cleanup-function old-mode) buffer))
227      (setf (car (buffer-mode-objects buffer)) mode)))
228    (setf (car (buffer-modes buffer)) name)
229    (funcall (mode-object-setup-function mode) buffer)
230    (invoke-hook (%value (mode-object-hook-name mode)) buffer t))
231  nil)
232
233
234
235;;;; BUFFER-MINOR-MODE.
236
237;;; BUFFER-MINOR-MODE  --  Public
238;;;
239;;;    Check if the mode-object is in the buffer's mode-list.
240;;;
241(defun buffer-minor-mode (buffer name)
242  "Return true if the minor mode named Name is active in Buffer.
243  A minor mode can be turned on or off with Setf."
244  (with-mode-and-buffer (name nil buffer)
245    (not (null (member mode (buffer-mode-objects buffer))))))
246   
247(declaim (special *mode-names*))
248
249;;; %SET-BUFFER-MINOR-MODE  --  Public
250;;;
251;;;    Activate or deactivate a minor mode, with due respect for
252;;; bindings.
253;;;
254(defun %set-buffer-minor-mode (buffer name new-value)
255  (let ((objects (buffer-mode-objects buffer)))   
256    (with-mode-and-buffer (name nil buffer)
257      (invoke-hook hemlock::buffer-minor-mode-hook buffer name new-value)
258      (cond
259       ;; Already there or not there, nothing to do.
260       ((if (member mode (buffer-mode-objects buffer)) new-value (not new-value)))
261       ;; Adding a new mode.
262       (new-value
263        (cond
264         ((eq buffer *current-buffer*)
265          ;;
266          ;; Unwind bindings having higher precedence, cons on the new
267          ;; mode and then wind them back on again.
268          (do ((m objects (cdr m))
269               (prev nil (car m)))
270              ((or (null (cdr m))
271                   (< (mode-object-precedence (car m))
272                      (mode-object-precedence mode)))
273               (wind-bindings
274                (cons mode (if prev
275                               (unwind-bindings prev)
276                               (unbind-variable-bindings
277                                (buffer-var-values *current-buffer*))))))))
278         (t
279          (do ((m (cdr objects) (cdr m))
280               (prev objects m))
281              ((or (null m)
282                   (>= (mode-object-precedence (car m))
283                       (mode-object-precedence mode)))
284               (setf (cdr prev) (cons mode m))))))
285        ;;
286        ;; Add the mode name.
287        (let ((bm (buffer-modes buffer)))
288          (setf (cdr bm)
289                (merge 'list (cdr bm) (list name) #'<  :key
290                       #'(lambda (x)
291                           (mode-object-precedence (getstring x *mode-names*))))))
292
293        (funcall (mode-object-setup-function mode) buffer)
294        (invoke-hook (%value (mode-object-hook-name mode)) buffer t))
295       (t
296        ;; Removing an active mode.
297        (invoke-hook (%value (mode-object-hook-name mode)) buffer nil)
298        (funcall (mode-object-cleanup-function mode) buffer)
299        ;; In the current buffer, unwind buffer and any mode bindings on top
300        ;; pop off the mode and wind the rest back on.
301        (cond ((eq buffer *current-buffer*)
302               (wind-bindings (cdr (unwind-bindings mode))))
303              (t
304               (setf (buffer-mode-objects buffer)
305                     (delq mode (buffer-mode-objects buffer)))))
306        ;; We always use the same string, so we can delq it (How Tense!)
307        (setf (buffer-modes buffer) (delq name (buffer-modes buffer))))))
308  new-value))
309
310
311
312;;;; CURRENT-BUFFER, CURRENT-POINT, and buffer using setup and cleanup.
313
314(declaim (inline current-buffer))
315
316(defun current-buffer () "Return the current buffer object." *current-buffer*)
317
318(defun current-point ()
319  "Return the Buffer-Point of the current buffer."
320  (buffer-point *current-buffer*))
321
322;;; %SET-CURRENT-BUFFER  --  Internal
323;;;
324;;;    Undo previous buffer and mode specific variables and character
325;;;attributes and set up the new ones.  Set *current-buffer*.
326;;;
327(defun %set-current-buffer (buffer)
328  (let ((old-buffer *current-buffer*))
329    (check-type buffer buffer)
330    (invoke-hook hemlock::set-buffer-hook buffer)
331    ;; Undo old bindings.
332    (setf (buffer-mode-objects *current-buffer*)
333          (unwind-bindings nil))
334    (swap-char-attributes (car (buffer-mode-objects *current-buffer*)))
335    (setq *current-buffer* buffer)
336    (swap-char-attributes (car (buffer-mode-objects *current-buffer*)))
337    ;; Make new bindings.
338    (wind-bindings (shiftf (buffer-mode-objects *current-buffer*) nil))
339    (invoke-hook hemlock::after-set-buffer-hook old-buffer))
340  buffer)
341
342;;; USE-BUFFER-SET-UP  --  Internal
343;;;
344;;;    This function is called by the use-buffer macro to wind on the
345;;; new buffer's variable and key bindings and character attributes.
346;;;
347(defun use-buffer-set-up (old-buffer)
348  (unless (eq old-buffer *current-buffer*)
349    ;; Let new char attributes overlay old ones.
350    (swap-char-attributes (car (buffer-mode-objects *current-buffer*)))
351    ;; Wind on bindings of new current buffer.
352    (wind-bindings (shiftf (buffer-mode-objects *current-buffer*) nil))))
353
354;;; USE-BUFFER-CLEAN-UP  --  Internal
355;;;
356;;;    This function is called by use-buffer to clean up after it is done.
357;;;
358(defun use-buffer-clean-up (old-buffer)
359  (unless (eq old-buffer *current-buffer*)
360    ;; When we leave, unwind the bindings,
361    (setf (buffer-mode-objects *current-buffer*) (unwind-bindings nil))
362    ;; Restore the character attributes,
363    (swap-char-attributes (car (buffer-mode-objects *current-buffer*)))))
364
365
366
367;;;; Recursive editing.
368
369(defvar *in-a-recursive-edit* nil "True if we are in a recursive edit.")
370
371(declaim (inline in-recursive-edit))
372
373(defun in-recursive-edit ()
374  "Returns whether the calling point is dynamically within a recursive edit
375   context."
376  *in-a-recursive-edit*)
377
378;;; RECURSIVE-EDIT  --  Public
379;;;
380;;;    Call the command interpreter recursively, winding on new state as
381;;; necessary.
382;;;
383(defun recursive-edit (&optional (handle-abort t))
384  "Call the command interpreter recursively.  If Handle-Abort is true
385  then an abort caused by a control-g or a lisp error does not cause
386  the recursive edit to be aborted."
387  (invoke-hook hemlock::enter-recursive-edit-hook)
388  (multiple-value-bind (flag args)
389                       (let ((*in-a-recursive-edit* t)
390                             (doc (buffer-document *current-buffer*)))
391                         (catch 'leave-recursive-edit
392                           (unwind-protect
393                                (progn
394                                  (when doc (document-end-editing doc))
395                                  (if handle-abort
396                                    (loop (catch 'editor-top-level-catcher
397                                            (%command-loop)))
398                                    (%command-loop)))
399                             (when doc (document-begin-editing doc)))))
400                             
401    (case flag
402      (:abort (apply #'editor-error args))
403      (:exit (values-list args))
404      (t (error "Bad thing ~S thrown out of recursive edit." flag)))))
405
406;;; EXIT-RECURSIVE-EDIT is intended to be called within the dynamic context
407;;; of RECURSIVE-EDIT, causing return from that function with values returned
408;;; as multiple values.  When not in a recursive edit, signal an error.
409;;;
410(defun exit-recursive-edit (&optional values)
411  "Exit from a recursive edit.  Values is a list of things which are
412   to be the return values from Recursive-Edit."
413  (unless *in-a-recursive-edit*
414    (error "Not in a recursive edit!"))
415  (invoke-hook hemlock::exit-recursive-edit-hook values)
416  (throw 'leave-recursive-edit (values :exit values)))
417
418;;; ABORT-RECURSIVE-EDIT is intended to be called within the dynamic context
419;;; of RECURSIVE-EDIT, causing EDITOR-ERROR to be called on args.  When not
420;;; in a recursive edit, signal an error.
421;;;
422(defun abort-recursive-edit (&rest args)
423  "Abort a recursive edit, causing an Editor-Error with the args given in
424   the calling context."
425  (unless *in-a-recursive-edit* 
426    (error "Not in a recursive edit!"))
427  (invoke-hook hemlock::abort-recursive-edit-hook args)
428  (throw 'leave-recursive-edit (values :abort args)))
429
430
431
432;;;; WITH-WRITABLE-BUFFER
433
434;;; This list indicates recursive use of WITH-WRITABLE-BUFFER on the same
435;;; buffer.
436;;;
437(defvar *writable-buffers* ())
438
439(defmacro with-writable-buffer ((buffer) &body body)
440  "Executes body in a scope where buffer is writable.  After body executes,
441   this sets the buffer's modified and writable status to nil."
442  (let ((buf (gensym))
443        (no-unwind (gensym)))
444    `(let* ((,buf ,buffer)
445            (,no-unwind (member ,buf *writable-buffers* :test #'eq))
446            (*writable-buffers* (if ,no-unwind
447                                    *writable-buffers*
448                                    (cons ,buf *writable-buffers*))))
449       (unwind-protect
450           (progn
451             (setf (buffer-writable ,buf) t)
452             ,@body)
453         (unless ,no-unwind
454           (setf (buffer-modified ,buf) nil)
455           (setf (buffer-writable ,buf) nil))))))
456
457
458
459;;;; DEFMODE.
460
461(defun defmode (name &key (setup-function #'identity) 
462                     (cleanup-function #'identity) major-p transparent-p
463                     precedence documentation hidden)
464  "Define a new mode, specifying whether it is a major mode, and what the
465   setup and cleanup functions are.  Precedence, which defaults to 0.0, and is
466   any integer or float, determines the order of the minor modes in a buffer.
467   A minor mode having a greater precedence is always considered before a mode
468   with lesser precedence when searching for key-bindings and variable values.
469   If Transparent-p is true, then all key-bindings local to the defined mode
470   are transparent, meaning that they do not shadow other bindings, but rather
471   are executed in addition to them.  Documentation is used as introductory
472   text for mode describing commands."
473  (let ((hook-str (concatenate 'string name " Mode Hook"))
474        (mode (getstring name *mode-names*)))
475    (cond
476     (mode
477      (when (if major-p
478                (not (mode-object-major-p mode))
479                (mode-object-major-p mode))
480        (cerror "Let bad things happen"
481                "Mode ~S is being redefined as a ~:[Minor~;Major~] mode ~
482                where it was ~%~
483                previously a ~:*~:[Major~;Minor~] mode." name major-p))
484      (warn "Mode ~S is being redefined, variables and bindings will ~
485            be preserved." name)
486      (setq name (mode-object-name mode)))
487     (t
488      (defhvar hook-str
489               (concatenate 'string "This is the mode hook variable for "
490               name " Mode."))
491      (setq mode (make-mode-object
492                  :variables (make-string-table)
493                  :bindings (make-hash-table)
494                  :hook-name (getstring hook-str *global-variable-names*)
495                  :hidden hidden))
496      (setf (getstring name *mode-names*) mode)))
497
498    (if precedence
499        (if major-p
500            (error "Precedence ~S is meaningless for a major mode." precedence)
501            (check-type precedence number))
502        (setq precedence 0))
503   
504    (setf (mode-object-major-p mode) major-p
505          (mode-object-documentation mode) documentation
506          (mode-object-transparent-p mode) transparent-p
507          (mode-object-precedence mode) precedence
508          (mode-object-setup-function mode) setup-function
509          (mode-object-cleanup-function mode) cleanup-function
510          (mode-object-name mode) name))
511  nil)
512
513(defun mode-major-p (name)
514  "Returns T if Name is the name of a major mode, or NIL if is the name of
515  a minor mode."
516  (mode-object-major-p (get-mode-object name)))
517
518(defun mode-variables (name)
519  "Return the string-table that contains the names of the modes variables."
520  (mode-object-variables (get-mode-object name)))
521
522(defun mode-documentation (name)
523  "Returns the documentation for mode with name."
524  (mode-object-documentation (get-mode-object name)))
525
526
527
528;;;; Making and Deleting buffers.
529
530(defvar *buffer-list* () "A list of all the buffer objects.")
531
532(defvar *current-buffer* ()
533  "Internal variable which might contain the current buffer." )
534
535(defun make-buffer (name &key (modes (value hemlock::default-modes))
536                              (modeline-fields
537                               (value hemlock::default-modeline-fields))
538                              delete-hook)
539  "Creates and returns a buffer with the given Name if a buffer with Name does
540   not already exist, otherwise returns nil.  Modes is a list of mode names,
541   and Modeline-fields is a list of modeline field objects.  Delete-hook is a
542   list of functions that take a buffer as the argument."
543  (cond ((getstring name *buffer-names*) nil)
544        (t
545         (unless (listp delete-hook)
546           (error ":delete-hook is a list of functions -- ~S." delete-hook))
547         (let* ((region (make-empty-region))
548                (object (getstring "Fundamental" *mode-names*))
549                (buffer (internal-make-buffer
550                         :%name name
551                         :%region region
552                         :modes (list (mode-object-name object))
553                         :mode-objects (list object)
554                         :bindings (make-hash-table)
555                         :point (copy-mark (region-end region))
556                         :display-start (copy-mark (region-start region))
557                         :delete-hook delete-hook
558                         :variables (make-string-table))))
559           (sub-set-buffer-modeline-fields buffer modeline-fields)
560           (setf (line-%buffer (mark-line (region-start region))) buffer)
561           (push buffer *buffer-list*)
562           (setf (getstring name *buffer-names*) buffer)
563           (unless (equalp modes '("Fundamental"))
564             (setf (buffer-major-mode buffer) (car modes))
565             (dolist (m (cdr modes))
566               (setf (buffer-minor-mode buffer m) t)))
567           (invoke-hook hemlock::make-buffer-hook buffer)
568           buffer))))
569
570(defun delete-buffer (buffer)
571  "Deletes a buffer.  If buffer is current, or if it is displayed in any
572   windows, an error is signaled."
573  (when (eq buffer *current-buffer*)
574    (error "Cannot delete current buffer ~S." buffer))
575  (when (buffer-windows buffer)
576    (error "Cannot delete buffer ~S, which is displayed in ~R window~:P."
577           buffer (length (buffer-windows buffer))))
578  (invoke-hook (buffer-delete-hook buffer) buffer)
579  (invoke-hook hemlock::delete-buffer-hook buffer)
580  (setq *buffer-list* (delq buffer *buffer-list*))
581  (delete-string (buffer-name buffer) *buffer-names*)
582  nil)
583
584
585
586;;;; Buffer start and end marks.
587
588(defun buffer-start-mark (buffer)
589  "Returns the buffer-region's start mark."
590  (region-start (buffer-region buffer)))
591
592(defun buffer-end-mark (buffer)
593  "Returns the buffer-region's end mark."
594  (region-end (buffer-region buffer)))
595
596
597
598;;;; Setting up initial buffer.
599
600;;; SETUP-INITIAL-BUFFER  --  Internal
601;;;
602;;;    Create the buffer "Main" and the mode "Fundamental".  We make a
603;;; dummy fundamental mode before we make the buffer Main, because
604;;; "make-buffer" wants fundamental to be defined when it is called, and we
605;;; can't make the real fundamental mode until there is a current buffer
606;;; because "defmode" wants to invoke it's mode definition hook.  Also,
607;;; when creating the "Main" buffer, "Default Modeline Fields" is not yet
608;;; defined, so we supply this argument to MAKE-BUFFER as nil.  This is
609;;; fine since firing up the editor in a core must set the "Main" buffer's
610;;; modeline according to this variable in case the user changed it in his
611;;; init file.  After the main buffer is created we then define the real
612;;; fundamental mode and bash it into the buffer.
613;;;
614(defun setup-initial-buffer ()
615  ;; Make it look like the mode is there so make-buffer doesn't die.
616  (setf (getstring "Fundamental" *mode-names*)
617        (make-mode-object :major-p t))
618  ;; Make it look like there is a make-buffer-hook...
619  (setf (get 'hemlock::make-buffer-hook 'hemlock-variable-value)
620        (make-variable-object "foo" "bar"))
621  (setq *current-buffer* (make-buffer "Main" :modes '("Fundamental")
622                                      :modeline-fields nil))
623  ;; Make the bogus variable go away...
624  (remf (symbol-plist 'hemlock::make-buffer-hook) 'hemlock-variable-value)
625  ;; Make it go away so defmode doesn't die.
626  (setf (getstring "Fundamental" *mode-names*) nil)
627  (defmode "Fundamental" :major-p t)
628  ;; Bash the real mode object into the buffer.
629  (let ((obj (getstring "Fundamental" *mode-names*)))
630    (setf (car (buffer-mode-objects *current-buffer*)) obj
631          (car (buffer-modes *current-buffer*)) (mode-object-name obj))))
Note: See TracBrowser for help on using the repository browser.