source: branches/event-ide/ccl/cocoa-ide/hemlock/src/struct.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: 14.3 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;;; Structures and assorted macros for Hemlock.
13;;;
14
15(in-package :hemlock-internals)
16
17
18;;;; Marks.
19
20(defstruct (mark (:print-function %print-hmark)
21                 (:predicate markp)
22                 (:copier nil)
23                 (:constructor internal-make-mark (line charpos %kind)))
24  "A Hemlock mark object.  See Hemlock Command Implementor's Manual for details."
25  line                                  ; pointer to line
26  charpos                               ; character position
27  %kind)                                ; type of mark
28
29(setf (documentation 'markp 'function)
30  "Returns true if its argument is a Hemlock mark object, false otherwise.")
31(setf (documentation 'mark-line 'function)
32  "Returns line that a Hemlock mark points to.")
33(setf (documentation 'mark-charpos 'function)
34  "Returns the character position of a Hemlock mark.
35  A mark's character position is the index within the line of the character
36  following the mark.")
37
38
39(defstruct (font-mark (:print-function
40                       (lambda (s stream d)
41                         (declare (ignore d))
42                         (write-string "#<Hemlock Font-Mark \"" stream)
43                         (%print-before-mark s stream)
44                         (write-string "/\\" stream)
45                         (%print-after-mark s stream)
46                         (write-string "\">" stream)))
47                      (:include mark)
48                      (:copier nil)
49                      (:constructor internal-make-font-mark
50                                    (line charpos %kind font)))
51  font
52  region)
53
54(defmacro fast-font-mark-p (s)
55  `(typep ,s 'font-mark))
56
57
58;;;; Regions, buffers, modeline fields.
59
60;;; The region object:
61;;;
62(defstruct (region (:print-function %print-hregion)
63                   (:predicate regionp)
64                   (:copier nil)
65                   (:constructor internal-make-region (start end)))
66  "A Hemlock region object.  See Hemlock Command Implementor's Manual for details."
67  start                                 ; starting mark
68  end)                                  ; ending mark
69
70(setf (documentation 'regionp 'function)
71  "Returns true if its argument is a Hemlock region object, Nil otherwise.")
72(setf (documentation 'region-end 'function)
73  "Returns the mark that is the end of a Hemlock region.")
74(setf (documentation 'region-start 'function)
75  "Returns the mark that is the start of a Hemlock region.")
76
77(defstruct (font-region (:include region)
78                        (:constructor internal-make-font-region (start end)))
79  node)
80
81;;; The buffer object:
82;;;
83(defstruct (buffer (:constructor internal-make-buffer)
84                   (:print-function %print-hbuffer)
85                   (:copier nil)
86                   (:predicate bufferp))
87  "A Hemlock buffer object.  See Hemlock Command Implementor's Manual for details."
88  %name                       ; name of the buffer (a string)
89  %region                     ; the buffer's region
90  %pathname                   ; associated pathname
91  major-mode-object           ; buffer's major mode mode object
92  minor-mode-objects          ; list of buffer's minor mode objects, reverse precedence order
93  bindings                    ; buffer's command table
94  (shadow-syntax nil)         ; buffer's changes to syntax attributes.
95  point                       ; current position in buffer
96  %mark                       ; a saved buffer position
97  region-active               ; modified-tick when region last activated
98  (%writable t)               ; t => can alter buffer's region
99  (modified-tick -2)          ; The last time the buffer was modified.
100  (unmodified-tick -1)        ; The last time the buffer was unmodified
101  #+clx
102  windows                     ; List of all windows into this buffer.
103  #+clozure ;; should be #+Cocoa
104  document                    ; NSDocument object associated with this buffer
105  var-values                  ; the buffer's local variables
106  variables                   ; string-table of local variables
107  write-date                  ; File-Write-Date for pathname.
108  %modeline-fields            ; List of modeline-field-info's.
109  (delete-hook nil)           ; List of functions to call upon deletion.
110  (line-termination :lf)      ; Line-termination, for the time being
111  process                     ; Maybe a listener
112  (gap-context )              ; The value of *buffer-gap-context*
113                              ; in the thread that can modify the buffer.
114  protected-region            ; (optional) write-protected region
115  (font-regions (ccl::init-dll-header (ccl::make-dll-header)))
116                                        ; a doubly-linked list of font regions.
117  active-font-region                    ; currently active font region
118  )
119
120
121(defstruct (font-region-node (:include ccl::dll-node)
122                             (:constructor make-font-region-node (region)))
123  region)
124
125(setf (documentation 'buffer-point 'function)
126  "Return the mark that is the current focus of attention in a buffer.")
127(setf (documentation 'buffer-variables 'function)
128  "Return the string-table of the variables local to the specifed buffer.")
129(setf (documentation 'buffer-write-date 'function)
130  "Return in universal time format the write date for the file associated
131   with the buffer.  If the pathname is set, then this should probably
132   be as well.  Should be NIL if the date is unknown or there is no file.")
133(setf (documentation 'buffer-delete-hook 'function)
134  "This is the list of buffer specific functions that Hemlock invokes when
135   deleting this buffer.")
136
137
138;;; Modeline fields.
139;;;
140(defstruct (modeline-field (:print-function print-modeline-field)
141                           (:constructor %make-modeline-field
142                                         (%name %function %width)))
143  "This is one item displayed in a Hemlock window's modeline."
144  %name         ; EQL name of this field.
145  %function     ; Function that returns a string for this field.
146  %width)       ; Width to display this field in.
147
148(setf (documentation 'modeline-field-p 'function)
149      "Returns true if its argument is a modeline field object, nil otherwise.")
150
151(defstruct (modeline-field-info (:print-function print-modeline-field-info)
152                                (:conc-name ml-field-info-)
153                                (:constructor make-ml-field-info (field)))
154  field
155  (start nil)
156  (end nil))
157
158
159
160;;;; The mode object.
161
162(defstruct (mode-object (:predicate modep)
163                        (:copier nil)
164                        (:print-function %print-hemlock-mode))
165  name                   ; name of this mode
166  setup-function         ; setup function for this mode
167  cleanup-function       ; Cleanup function for this mode
168  bindings               ; The mode's command table.
169  default-command        ; If non-nil, default command
170  transparent-p          ; Are key-bindings transparent?
171  hook-name              ; The name of the mode hook.
172  major-p                ; Is this a major mode?
173  precedence             ; The precedence for a minor mode.
174  character-attributes   ; Mode local character attributes
175  variables              ; String-table of mode variables
176  var-values             ; Alist for saving mode variables
177  documentation          ; Introductory comments for mode describing commands.
178  hidden                 ; Not listed in modeline fields
179)
180
181(defun %print-hemlock-mode (object stream depth)
182  (declare (ignore depth))
183  (write-string "#<Hemlock Mode \"" stream)
184  (write-string (mode-object-name object) stream)
185  (write-string "\">" stream))
186
187
188
189;;;; Variables.
190
191;;; This holds information about Hemlock variables, and the system stores
192;;; these structures on the property list of the variable's symbolic
193;;; representation under the 'hemlock-variable-value property.
194;;;
195(defstruct (variable-object
196            (:print-function
197             (lambda (object stream depth)
198               (declare (ignore depth))
199               (format stream "#<Hemlock Variable-Object ~S>"
200                       (variable-object-name object))))
201            (:copier nil)
202            (:constructor make-variable-object (symbol-name)))
203  value         ; The value of this variable.
204  hooks         ; The hook list for this variable.
205  documentation ; The documentation.
206  name          ; The string name.
207  symbol-name)  ; The corresponding symbol name.
208
209;;;; Attribute descriptors.
210
211(defstruct (attribute-descriptor
212            (:copier nil)
213            (:print-function %print-attribute-descriptor))
214  "This structure is used internally in Hemlock to describe a character
215  attribute."
216  name
217  keyword
218  documentation
219  (vector #() :type (simple-array * (*)))
220  hooks
221  end-value)
222
223
224
225;;;; Commands.
226
227(defstruct (command (:constructor internal-make-command
228                                  (%name documentation function transparent-p))
229                    (:copier nil)
230                    (:predicate commandp)
231                    (:print-function %print-hcommand))
232  %name                            ;The name of the command
233  documentation                    ;Command documentation string or function
234  function                         ;The function which implements the command
235  transparent-p                    ;If true, this command is transparent
236  %bindings)                       ;Places where command is bound
237
238(setf (documentation 'commandp 'function)
239  "Returns true if its argument is a Hemlock command object, Nil otherwise.")
240(setf (documentation 'command-documentation 'function)
241  "Return the documentation for a Hemlock command, given the command-object.
242  Command documentation may be either a string or a function.  This may
243  be set with Setf.")
244
245
246
247;;;; Random typeout streams.
248
249;;; These streams write to random typeout buffers for WITH-POP-UP-DISPLAY.
250;;;
251
252(defclass random-typeout-stream (#-scl fundamental-character-output-stream
253                                 #+scl character-output-stream)
254  ((mark         :initarg :mark
255                 :initform nil
256                 :accessor random-typeout-stream-mark
257                 :documentation "The buffer point of the associated buffer.")))
258
259(defun make-random-typeout-stream (mark)
260  (make-instance 'random-typeout-stream
261                 :mark mark))
262
263(defmethod print-object ((object random-typeout-stream) stream)
264  (format stream "#<Hemlock Random-Typeout-Stream ~S>"
265          (ignore-errors
266            (buffer-name
267             (mark-buffer (random-typeout-stream-mark object))))))
268
269
270;;;; Some defsetfs:
271
272(defsetf buffer-writable %set-buffer-writable
273  "Sets whether the buffer is writable and invokes the Buffer Writable Hook.")
274(defsetf buffer-name %set-buffer-name
275  "Sets the name of a specified buffer, invoking the Buffer Name Hook.")
276(defsetf buffer-modified %set-buffer-modified
277  "Make a buffer modified or unmodified.")
278(defsetf buffer-pathname %set-buffer-pathname
279  "Sets the pathname of a buffer, invoking the Buffer Pathname Hook.")
280
281(defsetf getstring %set-string-table
282  "Sets the value for a string-table entry, making a new one if necessary.")
283
284(define-setf-expander value (var)
285  "Set the value of a Hemlock variable, calling any hooks."
286  (let ((svar (gensym)))
287    (values
288     ()
289     ()
290     (list svar)
291     `(%set-value ',var ,svar)
292     `(value ,var))))
293
294(defsetf variable-value (name &optional (kind :current) where) (new-value)
295  "Set the value of a Hemlock variable, calling any hooks."
296  `(%set-variable-value ,name ,kind ,where ,new-value))
297
298(defsetf variable-hooks (name &optional (kind :current) where) (new-value)
299  "Set the list of hook functions for a Hemlock variable."
300  `(%set-variable-hooks ,name ,kind ,where ,new-value))
301
302(defsetf variable-documentation (name &optional (kind :current) where) (new-value)
303  "Set a Hemlock variable's documentation."
304  `(%set-variable-documentation ,name ,kind ,where ,new-value))
305
306(defsetf buffer-minor-mode %set-buffer-minor-mode
307  "Turn a buffer minor mode on or off.")
308(defsetf buffer-major-mode %set-buffer-major-mode
309  "Set a buffer's major mode.")
310(defsetf previous-character %set-previous-character
311  "Sets the character to the left of the given Mark.")
312(defsetf next-character %set-next-character
313  "Sets the characters to the right of the given Mark.")
314(defsetf character-attribute %set-character-attribute
315  "Set the value for a character attribute.")
316(defsetf character-attribute-hooks %set-character-attribute-hooks
317  "Set the hook list for a Hemlock character attribute.")
318(defsetf ring-ref %set-ring-ref "Set an element in a ring.")
319(defsetf mark-kind %set-mark-kind "Used to set the kind of a mark.")
320(defsetf buffer-region %set-buffer-region "Set a buffer's region.")
321(defsetf command-name %set-command-name
322  "Change a Hemlock command's name.")
323(defsetf line-string %set-line-string
324  "Replace the contents of a line.")
325(defsetf last-command-type %set-last-command-type
326  "Set the Last-Command-Type for use by the next command.")
327(defsetf logical-key-event-p %set-logical-key-event-p
328  "Change what Logical-Char= returns for the specified arguments.")
329(defsetf window-font %set-window-font
330  "Change the font-object associated with a font-number in a window.")
331(defsetf default-font %set-default-font
332  "Change the font-object associated with a font-number in new windows.")
333
334(defsetf modeline-field-name %set-modeline-field-name
335  "Sets a modeline-field's name.  If one already exists with that name, an
336   error is signaled.")
337
338;;; Shared buffer-gap context, used to communicate between command threads
339;;; and the event thread.  Note that this isn't buffer-specific; in particular,
340;;; OPEN-LINE and friends may not point at a line that belongs to any
341;;; buffer.
342
343(defstruct buffer-gap-context
344  (lock (ccl::make-lock))
345  (left-open-pos 0)
346  (right-open-pos 0)
347  (line-cache-length 200)
348  (open-line nil)
349  (open-chars (make-string 200))
350)
351
352(defun ensure-buffer-gap-context (buffer)
353  (or (buffer-gap-context buffer)
354      (setf (buffer-gap-context buffer) (make-buffer-gap-context))))
355
356(defun buffer-lock (buffer)
357  (buffer-gap-context-lock (ensure-buffer-gap-context buffer)))
358
359(defun current-gap-context ()
360  (unless (boundp '*current-buffer*)
361    (error "Gap context not bound"))
362  (ensure-buffer-gap-context *current-buffer*))
363
364(defun current-line-cache-length ()
365  (buffer-gap-context-line-cache-length (current-gap-context)))
366
367(defun (setf current-line-cache-length) (len)
368  (setf (buffer-gap-context-line-cache-length (current-gap-context)) len))
369
370(defun current-open-line ()
371  (buffer-gap-context-open-line (current-gap-context)))
372
373(defun current-open-line-p (line)
374  (eq line (current-open-line)))
375
376(defun (setf current-open-line) (value)
377  (setf (buffer-gap-context-open-line (current-gap-context)) value))
378
379(defun current-open-chars ()
380  (buffer-gap-context-open-chars (current-gap-context)))
381
382(defun (setf current-open-chars) (value)
383  (setf (buffer-gap-context-open-chars (current-gap-context)) value))
384 
385(defun current-left-open-pos ()
386  (buffer-gap-context-left-open-pos (current-gap-context)))
387
388(defun (setf current-left-open-pos) (value)
389  (setf (buffer-gap-context-left-open-pos (current-gap-context)) value))
390
391(defun current-right-open-pos ()
392  (buffer-gap-context-right-open-pos (current-gap-context)))
393
394(defun (setf current-right-open-pos) (value)
395  (setf (buffer-gap-context-right-open-pos (current-gap-context)) value))
Note: See TracBrowser for help on using the repository browser.