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