/[cmucl]/src/hemlock/struct.lisp
ViewVC logotype

Contents of /src/hemlock/struct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (hide annotations)
Sun Oct 4 08:27:32 1998 UTC (15 years, 6 months ago) by dtc
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.6: +2 -2 lines
Redefine the terminal speed from an (unsigned-byte 16) to an
(unsigned-byte 24), to support speeds of 115200+.
1 ram 1.1 ;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.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     (ext:file-comment
8 dtc 1.7 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/struct.lisp,v 1.7 1998/10/04 08:27:32 dtc Rel $")
9 ram 1.4 ;;;
10 ram 1.1 ;;; **********************************************************************
11     ;;;
12     ;;; Structures and assorted macros for Hemlock.
13     ;;;
14    
15     (in-package "HEMLOCK-INTERNALS")
16    
17     (export '(mark mark-line mark-charpos markp region region-start region-end
18     regionp buffer bufferp buffer-modes buffer-point buffer-writable
19     buffer-delete-hook buffer-windows buffer-variables buffer-write-date
20     region regionp region-start region-end window windowp window-height
21     window-width window-display-start window-display-end window-point
22 ram 1.4 window-display-recentering commandp command command-function
23     command-documentation modeline-field modeline-field-p))
24 ram 1.1
25    
26     ;;;; Marks.
27    
28     (defstruct (mark (:print-function %print-hmark)
29     (:predicate markp)
30     (:copier nil)
31     (:constructor internal-make-mark (line charpos %kind)))
32     "A Hemlock mark object. See Hemlock Command Implementor's Manual for details."
33     line ; pointer to line
34     charpos ; character position
35     %kind) ; type of mark
36    
37     (setf (documentation 'markp 'function)
38     "Returns true if its argument is a Hemlock mark object, false otherwise.")
39     (setf (documentation 'mark-line 'function)
40     "Returns line that a Hemlock mark points to.")
41     (setf (documentation 'mark-charpos 'function)
42     "Returns the character position of a Hemlock mark.
43     A mark's character position is the index within the line of the character
44     following the mark.")
45    
46     (defstruct (font-mark (:print-function
47     (lambda (s stream d)
48     (declare (ignore d))
49     (write-string "#<Hemlock Font-Mark \"" stream)
50     (%print-before-mark s stream)
51     (write-string "/\\" stream)
52     (%print-after-mark s stream)
53     (write-string "\">" stream)))
54     (:include mark)
55     (:copier nil)
56     (:constructor internal-make-font-mark
57     (line charpos %kind font)))
58     font)
59    
60     (defmacro fast-font-mark-p (s)
61 ram 1.4 `(typep ,s 'font-mark))
62 ram 1.1
63    
64     ;;;; Regions, buffers, modeline fields.
65    
66     ;;; The region object:
67     ;;;
68     (defstruct (region (:print-function %print-hregion)
69     (:predicate regionp)
70     (:copier nil)
71     (:constructor internal-make-region (start end)))
72     "A Hemlock region object. See Hemlock Command Implementor's Manual for details."
73     start ; starting mark
74     end) ; ending mark
75    
76     (setf (documentation 'regionp 'function)
77     "Returns true if its argument is a Hemlock region object, Nil otherwise.")
78     (setf (documentation 'region-end 'function)
79     "Returns the mark that is the end of a Hemlock region.")
80     (setf (documentation 'region-start 'function)
81     "Returns the mark that is the start of a Hemlock region.")
82    
83    
84     ;;; The buffer object:
85     ;;;
86     (defstruct (buffer (:constructor internal-make-buffer)
87     (:print-function %print-hbuffer)
88     (:copier nil)
89     (:predicate bufferp))
90     "A Hemlock buffer object. See Hemlock Command Implementor's Manual for details."
91     %name ; name of the buffer (a string)
92     %region ; the buffer's region
93     %pathname ; associated pathname
94     modes ; list of buffer's mode names
95     mode-objects ; list of buffer's mode objects
96     bindings ; buffer's command table
97     point ; current position in buffer
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     windows ; List of all windows into this buffer.
102     var-values ; the buffer's local variables
103     variables ; string-table of local variables
104     write-date ; File-Write-Date for pathname.
105     display-start ; Window display start when switching to buf.
106     %modeline-fields ; List of modeline-field-info's.
107     (delete-hook nil)) ; List of functions to call upon deletion.
108    
109     (setf (documentation 'buffer-modes 'function)
110     "Return the list of the names of the modes active in a given buffer.")
111     (setf (documentation 'buffer-point 'function)
112     "Return the mark that is the current focus of attention in a buffer.")
113     (setf (documentation 'buffer-windows 'function)
114     "Return the list of windows that are displaying a given buffer.")
115     (setf (documentation 'buffer-variables 'function)
116     "Return the string-table of the variables local to the specifed buffer.")
117     (setf (documentation 'buffer-write-date 'function)
118     "Return in universal time format the write date for the file associated
119     with the buffer. If the pathname is set, then this should probably
120     be as well. Should be NIL if the date is unknown or there is no file.")
121     (setf (documentation 'buffer-delete-hook 'function)
122     "This is the list of buffer specific functions that Hemlock invokes when
123     deleting this buffer.")
124    
125    
126     ;;; Modeline fields.
127     ;;;
128     (defstruct (modeline-field (:print-function print-modeline-field)
129     (:constructor %make-modeline-field
130     (%name %function %width)))
131     "This is one item displayed in a Hemlock window's modeline."
132     %name ; EQL name of this field.
133     %function ; Function that returns a string for this field.
134     %width) ; Width to display this field in.
135    
136     (setf (documentation 'modeline-field-p 'function)
137     "Returns true if its argument is a modeline field object, nil otherwise.")
138    
139     (defstruct (modeline-field-info (:print-function print-modeline-field-info)
140     (:conc-name ml-field-info-)
141     (:constructor make-ml-field-info (field)))
142     field
143     (start nil)
144     (end nil))
145    
146    
147    
148     ;;;; The mode object.
149    
150     (defstruct (mode-object (:predicate modep)
151     (:copier nil)
152     (:print-function %print-hemlock-mode))
153     name ; name of this mode
154     setup-function ; setup function for this mode
155     cleanup-function ; Cleanup function for this mode
156     bindings ; The mode's command table.
157     transparent-p ; Are key-bindings transparent?
158     hook-name ; The name of the mode hook.
159     major-p ; Is this a major mode?
160     precedence ; The precedence for a minor mode.
161     character-attributes ; Mode local character attributes
162     variables ; String-table of mode variables
163     var-values ; Alist for saving mode variables
164     documentation) ; Introductory comments for mode describing commands.
165    
166     (defun %print-hemlock-mode (object stream depth)
167     (declare (ignore depth))
168     (write-string "#<Hemlock Mode \"" stream)
169     (write-string (mode-object-name object) stream)
170     (write-string "\">" stream))
171    
172    
173    
174     ;;;; Variables.
175    
176     ;;; This holds information about Hemlock variables, and the system stores
177     ;;; these structures on the property list of the variable's symbolic
178     ;;; representation under the 'hemlock-variable-value property.
179     ;;;
180     (defstruct (variable-object
181     (:print-function
182     (lambda (object stream depth)
183     (declare (ignore depth))
184     (format stream "#<Hemlock Variable-Object ~S>"
185     (variable-object-name object))))
186     (:copier nil)
187     (:constructor make-variable-object (documentation name)))
188     value ; The value of this variable.
189     hooks ; The hook list for this variable.
190     down ; The variable-object for the previous value.
191     documentation ; The documentation.
192     name) ; The string name.
193    
194    
195    
196     ;;;; Windows, dis-lines, and font-changes.
197    
198     ;;; The window object:
199     ;;;
200     (defstruct (window (:constructor internal-make-window)
201     (:predicate windowp)
202     (:copier nil)
203     (:print-function %print-hwindow))
204     "This structure implements a Hemlock window."
205     tick ; The last time this window was updated.
206     %buffer ; buffer displayed in this window.
207     height ; Height of window in lines.
208     width ; Width of the window in characters.
209     old-start ; The charpos of the first char displayed.
210     first-line ; The head of the list of dis-lines.
211     last-line ; The last dis-line displayed.
212     first-changed ; The first changed dis-line on last update.
213     last-changed ; The last changed dis-line.
214     spare-lines ; The head of the list of unused dis-lines
215     (old-lines 0) ; Slot used by display to keep state info
216     hunk ; The device hunk that displays this window.
217     display-start ; first character position displayed
218     display-end ; last character displayed
219     point ; Where the cursor is in this window.
220     modeline-dis-line ; Dis-line for modeline display.
221     modeline-buffer ; Complete string of all modeline data.
222 ram 1.4 modeline-buffer-len ; Valid chars in modeline-buffer.
223     display-recentering) ; Tells whether redisplay recenters window
224     ; regardless of whether it is current.
225 ram 1.1
226     (setf (documentation 'windowp 'function)
227     "Returns true if its argument is a Hemlock window object, Nil otherwise.")
228     (setf (documentation 'window-height 'function)
229     "Return the height of a Hemlock window in character positions.")
230     (setf (documentation 'window-width 'function)
231     "Return the width of a Hemlock window in character positions.")
232     (setf (documentation 'window-display-start 'function)
233     "Return the mark which points before the first character displayed in
234 ram 1.4 the supplied window.")
235 ram 1.1 (setf (documentation 'window-display-end 'function)
236     "Return the mark which points after the last character displayed in
237 ram 1.4 the supplied window.")
238 ram 1.1 (setf (documentation 'window-point 'function)
239 ram 1.4 "Return the mark that points to where the cursor is displayed in this
240     window. When the window is made current, the Buffer-Point of this window's
241     buffer is moved to this position. While the window is current, redisplay
242     makes this mark point to the same position as the Buffer-Point of its
243     buffer.")
244     (setf (documentation 'window-display-recentering 'function)
245     "This determines whether redisplay recenters window regardless of whether it
246     is current. This is SETF'able.")
247 ram 1.1
248     (defstruct (dis-line (:copier nil)
249     (:constructor nil))
250     chars ; The line-image to be displayed.
251     (length 0 :type fixnum) ; Length of line-image.
252     font-changes) ; Font-Change structures for changes in this line.
253    
254     (defstruct (window-dis-line (:copier nil)
255     (:include dis-line)
256     (:constructor make-window-dis-line (chars))
257     (:conc-name dis-line-))
258     old-chars ; Line-Chars of line displayed.
259     line ; Line displayed.
260     (flags 0 :type fixnum) ; Bit flags indicate line status.
261     (delta 0 :type fixnum) ; # lines moved from previous position.
262     (position 0 :type fixnum) ; Line # to be displayed on.
263     (end 0 :type fixnum)) ; Index after last logical character displayed.
264    
265     (defstruct (font-change (:copier nil)
266     (:constructor make-font-change (next)))
267     x ; X position that change takes effect.
268     font ; Index into font-map of font to use.
269     next ; The next Font-Change on this dis-line.
270     mark) ; Font-Mark responsible for this change.
271    
272    
273    
274     ;;;; Font family.
275    
276     (defstruct font-family
277     map ; Font-map for hunk.
278     height ; Height of char box includung VSP.
279     width ; Width of font.
280     baseline ; Pixels from top of char box added to Y.
281     cursor-width ; Pixel width of cursor.
282     cursor-height ; Pixel height of cursor.
283     cursor-x-offset ; Added to pos of UL corner of char box to get
284     cursor-y-offset) ; UL corner of cursor blotch.
285    
286    
287    
288     ;;;; Attribute descriptors.
289    
290     (defstruct (attribute-descriptor
291     (:copier nil)
292     (:print-function %print-attribute-descriptor))
293     "This structure is used internally in Hemlock to describe a character
294     attribute."
295     name
296     keyword
297     documentation
298     vector
299     hooks
300     end-value)
301    
302    
303    
304     ;;;; Commands.
305    
306     (defstruct (command (:constructor internal-make-command
307     (%name documentation function))
308     (:copier nil)
309     (:predicate commandp)
310     (:print-function %print-hcommand))
311     %name ;The name of the command
312     documentation ;Command documentation string or function
313     function ;The function which implements the command
314     %bindings) ;Places where command is bound
315    
316     (setf (documentation 'commandp 'function)
317     "Returns true if its argument is a Hemlock command object, Nil otherwise.")
318     (setf (documentation 'command-documentation 'function)
319     "Return the documentation for a Hemlock command, given the command-object.
320     Command documentation may be either a string or a function. This may
321     be set with Setf.")
322    
323    
324    
325     ;;;; Random typeout streams.
326    
327     ;;; These streams write to random typeout buffers for WITH-POP-UP-DISPLAY.
328     ;;;
329 dtc 1.6 (defstruct (random-typeout-stream (:include sys:lisp-stream)
330 ram 1.1 (:print-function print-random-typeout-stream)
331     (:constructor
332     make-random-typeout-stream (mark)))
333     mark ; The buffer point of the associated buffer.
334     window ; The hemlock window all this shit is in.
335     more-mark ; The mark that is not displayed when we need to more.
336     no-prompt ; T when we want to exit, still collecting output.
337     (first-more-p t)) ; T until the first time we more. Nil after.
338    
339     (defun print-random-typeout-stream (object stream ignore)
340     (declare (ignore ignore))
341     (format stream "#<Hemlock Random-Typeout-Stream ~S>"
342     (buffer-name
343     (line-buffer (mark-line (random-typeout-stream-mark object))))))
344    
345    
346    
347     ;;;; Redisplay devices.
348    
349     ;;; Devices contain monitor specific redisplay methods referenced by
350     ;;; redisplay independent code.
351     ;;;
352     (defstruct (device (:print-function print-device)
353     (:constructor %make-device))
354     name ; simple-string such as "concept" or "lnz".
355     init ; fun to call whenever going into the editor.
356     ; args: device
357     exit ; fun to call whenever leaving the editor.
358     ; args: device
359     smart-redisplay ; fun to redisplay a window on this device.
360     ; args: window &optional recenterp
361     dumb-redisplay ; fun to redisplay a window on this device.
362     ; args: window &optional recenterp
363     after-redisplay ; args: device
364     ; fun to call at the end of redisplay entry points.
365     clear ; fun to clear the entire display.
366     ; args: device
367     note-read-wait ; fun to somehow note on display that input is expected.
368     ; args: on-or-off
369     put-cursor ; fun to put the cursor at (x,y) or (column,line).
370     ; args: hunk &optional x y
371     show-mark ; fun to display the screens cursor at a certain mark.
372     ; args: window x y time
373     next-window ; funs to return the next and previous window
374     previous-window ; of some window.
375     ; args: window
376     make-window ; fun to make a window on the screen.
377     ; args: device start-mark
378     ; &optional modeline-string modeline-function
379     delete-window ; fun to remove a window from the screen.
380     ; args: window
381     random-typeout-setup ; fun to prepare for random typeout.
382     ; args: device n
383     random-typeout-cleanup; fun to clean up after random typeout.
384     ; args: device degree
385     random-typeout-line-more ; fun to keep line-buffered streams up to date.
386     random-typeout-full-more ; fun to do full-buffered more-prompting.
387     ; args: # of newlines in the object just inserted
388     ; in the buffer.
389     force-output ; if non-nil, fun to force any output possibly buffered.
390     finish-output ; if non-nil, fun to force output and hand until done.
391     ; args: device window
392     beep ; fun to beep or flash the screen.
393     bottom-window-base ; bottom text line of bottom window.
394     hunks) ; list of hunks on the screen.
395    
396     (defun print-device (obj str n)
397     (declare (ignore n))
398     (format str "#<Hemlock Device ~S>" (device-name obj)))
399    
400    
401     (defstruct (bitmap-device #|(:print-function print-device)|#
402     (:include device))
403     display) ; CLX display object.
404    
405    
406     (defstruct (tty-device #|(:print-function print-device)|#
407     (:constructor %make-tty-device)
408     (:include device))
409     dumbp ; t if it does not have line insertion and deletion.
410     lines ; number of lines on device.
411     columns ; number of columns per line.
412     display-string ; fun to display a string of characters at (x,y).
413     ; args: hunk x y string &optional start end
414     standout-init ; fun to put terminal in standout mode.
415     ; args: hunk
416     standout-end ; fun to take terminal out of standout mode.
417     ; args: hunk
418     clear-lines ; fun to clear n lines starting at (x,y).
419     ; args: hunk x y n
420     clear-to-eol ; fun to clear to the end of a line from (x,y).
421     ; args: hunk x y
422     clear-to-eow ; fun to clear to the end of a window from (x,y).
423     ; args: hunk x y
424     open-line ; fun to open a line moving lines below it down.
425     ; args: hunk x y &optional n
426     delete-line ; fun to delete a line moving lines below it up.
427     ; args: hunk x y &optional n
428     insert-string ; fun to insert a string in the middle of a line.
429     ; args: hunk x y string &optional start end
430     delete-char ; fun to delete a character from the middle of a line.
431     ; args: hunk x y &optional n
432     (cursor-x 0) ; column the cursor is in.
433     (cursor-y 0) ; line the cursor is on.
434     standout-init-string ; string to put terminal in standout mode.
435     standout-end-string ; string to take terminal out of standout mode.
436     clear-to-eol-string ; string to cause device to clear to eol at (x,y).
437     clear-string ; string to cause device to clear entire screen.
438     open-line-string ; string to cause device to open a blank line.
439     delete-line-string ; string to cause device to delete a line, moving
440     ; lines below it up.
441     insert-init-string ; string to put terminal in insert mode.
442     insert-char-init-string ; string to prepare terminal for insert-mode character.
443     insert-char-end-string ; string to affect terminal after insert-mode character.
444     insert-end-string ; string to take terminal out of insert mode.
445     delete-init-string ; string to put terminal in delete mode.
446     delete-char-string ; string to delete a character.
447     delete-end-string ; string to take terminal out of delete mode.
448     init-string ; device init string.
449     cm-end-string ; takes device out of cursor motion mode.
450     (cm-x-add-char nil) ; char-code to unconditionally add to x coordinate.
451     (cm-y-add-char nil) ; char-code to unconditionally add to y coordinate.
452     (cm-x-condx-char nil) ; char-code threshold for adding to x coordinate.
453     (cm-y-condx-char nil) ; char-code threshold for adding to y coordinate.
454     (cm-x-condx-add-char nil) ; char-code to conditionally add to x coordinate.
455     (cm-y-condx-add-char nil) ; char-code to conditionally add to y coordinate.
456     cm-string1 ; initial substring of cursor motion string.
457     cm-string2 ; substring of cursor motion string between coordinates.
458     cm-string3 ; substring of cursor motion string after coordinates.
459     cm-one-origin ; non-nil if need to add one to coordinates.
460     cm-reversep ; non-nil if need to reverse coordinates.
461     (cm-x-pad nil) ; nil, 0, 2, or 3 for places to pad.
462     ; 0 sends digit-chars.
463     (cm-y-pad nil) ; nil, 0, 2, or 3 for places to pad.
464     ; 0 sends digit-chars.
465 ram 1.4 screen-image ; vector device-lines long of strings
466 ram 1.1 ; device-columns long.
467 ram 1.4 ;;
468     ;; This terminal's baud rate, or NIL for infinite.
469 dtc 1.7 (speed nil :type (or (unsigned-byte 24) null)))
470 ram 1.1
471    
472 ram 1.3 ;;;; Device screen hunks and window-group.
473 ram 1.1
474 ram 1.3 ;;; Window groups are used to keep track of the old width and height of a group
475     ;;; so that when a configure-notify event is sent, we can determine if the size
476     ;;; of the window actually changed or not.
477     ;;;
478     (defstruct (window-group (:print-function %print-window-group)
479     (:constructor
480     make-window-group (xparent width height)))
481     xparent
482     width
483     height)
484    
485     (defun %print-window-group (object stream depth)
486     (declare (ignore object depth))
487     (format stream "#<Hemlock Window Group>"))
488    
489 ram 1.1 ;;; Device-hunks are used to claim a piece of the screen and for ordering
490     ;;; pieces of the screen. Window motion primitives and splitting/merging
491     ;;; primitives use hunks. Hunks are somewhat of an interface between the
492     ;;; portable and non-portable parts of screen management, between what the
493     ;;; user sees on the screen and how Hemlock internals deal with window
494     ;;; sequencing and creation. Note: the echo area hunk is not hooked into
495     ;;; the ring of other hunks via the next and previous fields.
496     ;;;
497     (defstruct (device-hunk (:print-function %print-device-hunk))
498     "This structure is used internally by Hemlock's screen management system."
499     window ; Window displayed in this hunk.
500     position ; Bottom Y position of hunk.
501     height ; Height of hunk in pixels or lines.
502     next ; Next and previous hunks.
503     previous
504     device) ; Display device hunk is on.
505    
506     (defun %print-device-hunk (object stream depth)
507     (declare (ignore depth))
508     (format stream "#<Hemlock Device-Hunk ~D+~D~@[, ~S~]>"
509     (device-hunk-position object)
510     (device-hunk-height object)
511     (let* ((window (device-hunk-window object))
512     (buffer (if window (window-buffer window))))
513     (if buffer (buffer-name buffer)))))
514    
515    
516     ;;; Bitmap hunks.
517     ;;;
518     ;;; The lock field is no longer used. If events could be handled while we
519     ;;; were in the middle of something with the hunk, then this could be set
520     ;;; for exclusion purposes.
521     ;;;
522     (defstruct (bitmap-hunk #|(:print-function %print-device-hunk)|#
523     (:include device-hunk))
524     width ; Pixel width.
525     char-height ; Height of text body in characters.
526     char-width ; Width in characters.
527     xwindow ; X window for this hunk.
528 ram 1.3 gcontext ; X gcontext for xwindow.
529 ram 1.1 start ; Head of dis-line list (no dummy).
530     end ; Exclusive end, i.e. nil if nil-terminated.
531     modeline-dis-line ; Dis-line for modeline, or NIL if none.
532     modeline-pos ; Position of modeline in pixels.
533     (lock t) ; Something going on, set trashed if we're changed.
534     trashed ; Something bad happened, recompute image.
535     font-family ; Font-family used in this window.
536     input-handler ; Gets hunk, char, x, y when char read.
537     changed-handler ; Gets hunk when size changed.
538 ram 1.3 (thumb-bar-p nil) ; True if we draw a thumb bar in the top border.
539     window-group) ; The window-group to which this hunk belongs.
540 ram 1.1
541    
542     ;;; Terminal hunks.
543     ;;;
544     (defstruct (tty-hunk #|(:print-function %print-device-hunk)|#
545     (:include device-hunk))
546     text-position ; Bottom Y position of text in hunk.
547     text-height) ; Number of lines of text.
548    
549    
550    
551     ;;;; Some defsetfs:
552    
553     (defsetf buffer-writable %set-buffer-writable
554     "Sets whether the buffer is writable and invokes the Buffer Writable Hook.")
555     (defsetf buffer-name %set-buffer-name
556     "Sets the name of a specified buffer, invoking the Buffer Name Hook.")
557     (defsetf buffer-modified %set-buffer-modified
558     "Make a buffer modified or unmodified.")
559     (defsetf buffer-pathname %set-buffer-pathname
560     "Sets the pathname of a buffer, invoking the Buffer Pathname Hook.")
561    
562     (defsetf getstring %set-string-table
563     "Sets the value for a string-table entry, making a new one if necessary.")
564    
565     (defsetf window-buffer %set-window-buffer
566     "Change the buffer a window is mapped to.")
567    
568     (lisp::define-setf-method value (var)
569     "Set the value of a Hemlock variable, calling any hooks."
570     (let ((svar (gensym)))
571     (values
572     ()
573     ()
574     (list svar)
575     `(%set-value ',var ,svar)
576     `(value ,var))))
577    
578     (defsetf variable-value (name &optional (kind :current) where) (new-value)
579     "Set the value of a Hemlock variable, calling any hooks."
580     `(%set-variable-value ,name ,kind ,where ,new-value))
581    
582     (defsetf variable-hooks (name &optional (kind :current) where) (new-value)
583     "Set the list of hook functions for a Hemlock variable."
584     `(%set-variable-hooks ,name ,kind ,where ,new-value))
585    
586     (defsetf variable-documentation (name &optional (kind :current) where) (new-value)
587     "Set a Hemlock variable's documentation."
588     `(%set-variable-documentation ,name ,kind ,where ,new-value))
589    
590     (defsetf buffer-minor-mode %set-buffer-minor-mode
591     "Turn a buffer minor mode on or off.")
592     (defsetf buffer-major-mode %set-buffer-major-mode
593     "Set a buffer's major mode.")
594     (defsetf previous-character %set-previous-character
595     "Sets the character to the left of the given Mark.")
596     (defsetf next-character %set-next-character
597     "Sets the characters to the right of the given Mark.")
598     (defsetf character-attribute %set-character-attribute
599     "Set the value for a character attribute.")
600     (defsetf character-attribute-hooks %set-character-attribute-hooks
601     "Set the hook list for a Hemlock character attribute.")
602     (defsetf ring-ref %set-ring-ref "Set an element in a ring.")
603     (defsetf current-window %set-current-window "Set the current window.")
604     (defsetf current-buffer %set-current-buffer
605     "Set the current buffer, doing necessary stuff.")
606     (defsetf mark-kind %set-mark-kind "Used to set the kind of a mark.")
607     (defsetf buffer-region %set-buffer-region "Set a buffer's region.")
608     (defsetf command-name %set-command-name
609     "Change a Hemlock command's name.")
610     (defsetf line-string %set-line-string
611     "Replace the contents of a line.")
612     (defsetf last-command-type %set-last-command-type
613     "Set the Last-Command-Type for use by the next command.")
614     (defsetf prefix-argument %set-prefix-argument
615     "Set the prefix argument for the next command.")
616 ram 1.2 (defsetf logical-key-event-p %set-logical-key-event-p
617 ram 1.1 "Change what Logical-Char= returns for the specified arguments.")
618     (defsetf window-font %set-window-font
619     "Change the font-object associated with a font-number in a window.")
620     (defsetf default-font %set-default-font
621     "Change the font-object associated with a font-number in new windows.")
622    
623     (defsetf buffer-modeline-fields %set-buffer-modeline-fields
624     "Sets the buffer's list of modeline fields causing all windows into buffer
625     to be updated for the next redisplay.")
626     (defsetf modeline-field-name %set-modeline-field-name
627     "Sets a modeline-field's name. If one already exists with that name, an
628     error is signaled.")
629     (defsetf modeline-field-width %set-modeline-field-width
630     "Sets a modeline-field's width and updates all the fields for all windows
631     in any buffer whose fields list contains the field.")
632     (defsetf modeline-field-function %set-modeline-field-function
633     "Sets a modeline-field's function and updates this field for all windows in
634     any buffer whose fields list contains the field.")

  ViewVC Help
Powered by ViewVC 1.1.5