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

Contents of /src/hemlock/rompsite.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17 - (show annotations)
Mon May 5 16:13:59 2003 UTC (10 years, 11 months ago) by emarsden
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-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, 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, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, 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, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, 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, 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, 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, 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, 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, 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.16: +4 -1 lines
  Loading Hemlock causes :hemlock to be provided, so that REQUIRE doesn't
  reload it.
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 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/rompsite.lisp,v 1.17 2003/05/05 16:13:59 emarsden Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; "Site dependent" stuff for the Hemlock editor
13 ;;;
14
15 ;;; If we were compiled with CLX support, we require it at runtime
16 #+clx
17 (require :clx)
18
19 ;;; Stuff to set up the packages Hemlock uses.
20 ;;;
21 (unless (find-package "HEMLOCK-INTERNALS")
22 (make-package "HEMLOCK-INTERNALS"
23 :nicknames '("HI")
24 :use '("LISP" "EXTENSIONS" "SYSTEM")))
25 ;;;
26 (unless (find-package "HEMLOCK")
27 (make-package "HEMLOCK"
28 :nicknames '("ED")
29 :use '("LISP" "HEMLOCK-INTERNALS" "EXTENSIONS" "SYSTEM")))
30 ;;;
31 (in-package "SYSTEM")
32 (export '(without-hemlock %sp-byte-blt %sp-find-character
33 %sp-find-character-with-attribute
34 %sp-reverse-find-character-with-attribute))
35 ;;;
36 (in-package "HI")
37
38 (export '(show-mark editor-sleep *input-transcript* fun-defined-from-pathname
39 editor-describe-function pause-hemlock store-cut-string
40 fetch-cut-string schedule-event remove-scheduled-event
41 enter-window-autoraise directoryp merge-relative-pathnames
42 ;;
43 ;; Export default-font to prevent a name conflict that occurs due to
44 ;; the Hemlock variable "Default Font" defined in SITE-INIT below.
45 ;;
46 default-font))
47
48
49 ;;; SYSTEM:WITHOUT-HEMLOCK -- Public.
50 ;;;
51 ;;; Code:lispinit.lisp uses this for a couple interrupt handlers, and
52 ;;; eval-server.lisp.
53 ;;;
54 (defmacro system:without-hemlock (&body body)
55 "When in the editor and not in the debugger, call the exit method of Hemlock's
56 device, so we can type. Do the same thing on exit but call the init method."
57 `(progn
58 (when (and *in-the-editor* (not debug::*in-the-debugger*))
59 (let ((device (device-hunk-device (window-hunk (current-window)))))
60 (funcall (device-exit device) device)))
61 ,@body
62 (when (and *in-the-editor* (not debug::*in-the-debugger*))
63 (let ((device (device-hunk-device (window-hunk (current-window)))))
64 (funcall (device-init device) device)))))
65
66
67
68 ;;;; SITE-INIT.
69
70 ;;; *key-event-history* is defined in input.lisp, but it needs to be set in
71 ;;; SITE-INIT, since MAKE-RING doesn't exist at load time for this file.
72 ;;;
73 (declaim (special *key-event-history*))
74
75 ;;; SITE-INIT -- Internal
76 ;;;
77 ;;; This function is called at init time to set up any site stuff.
78 ;;;
79 (defun site-init ()
80 (defhvar "Beep Border Width"
81 "Width in pixels of the border area inverted by beep."
82 :value 20)
83 (defhvar "Default Window Width"
84 "This is used to make a window when prompting the user. The value is in
85 characters."
86 :value 80)
87 (defhvar "Default Window Height"
88 "This is used to make a window when prompting the user. The value is in
89 characters."
90 :value 24)
91 (defhvar "Default Initial Window Width"
92 "This is used when Hemlock first starts up to make its first window.
93 The value is in characters."
94 :value 80)
95 (defhvar "Default Initial Window Height"
96 "This is used when Hemlock first starts up to make its first window.
97 The value is in characters."
98 :value 24)
99 (defhvar "Default Initial Window X"
100 "This is used when Hemlock first starts up to make its first window.
101 The value is in pixels."
102 :value nil)
103 (defhvar "Default Initial Window Y"
104 "This is used when Hemlock first starts up to make its first window.
105 The value is in pixels."
106 :value nil)
107 (defhvar "Bell Style"
108 "This controls what beeps do in Hemlock. Acceptable values are :border-flash
109 (which is the default), :feep, :border-flash-and-feep, :flash,
110 :flash-and-feep, and NIL (do nothing)."
111 :value :border-flash)
112 (defhvar "Reverse Video"
113 "Paints white on black in window bodies, black on white in modelines."
114 :value nil
115 :hooks '(reverse-video-hook-fun))
116 (defhvar "Cursor Bitmap File"
117 "File to read to setup cursors for Hemlock windows. The mask is found by
118 merging this name with \".mask\"."
119 :value "library:hemlock11.cursor")
120 (defhvar "Enter Window Hook"
121 "When the mouse enters an editor window, this hook is invoked. These
122 functions take the Hemlock Window as an argument."
123 :value nil)
124 (defhvar "Exit Window Hook"
125 "When the mouse exits an editor window, this hook is invoked. These
126 functions take the Hemlock Window as an argument."
127 :value nil)
128 (defhvar "Set Window Autoraise"
129 "When non-nil, setting the current window will automatically raise that
130 window via a function on \"Set Window Hook\". If the value is :echo-only
131 (the default), then only the echo area window will be raised
132 automatically upon becoming current."
133 :value :echo-only)
134 (defhvar "Default Font"
135 "The string name of the font to be used for Hemlock -- buffer text,
136 modelines, random typeout, etc. The font is loaded when initializing
137 Hemlock."
138 :value "*-courier-medium-r-normal--*-120-*")
139 (defhvar "Active Region Highlighting Font"
140 "The string name of the font to be used for highlighting active regions.
141 The font is loaded when initializing Hemlock."
142 :value "*-courier-medium-o-normal--*-120-*")
143 (defhvar "Open Paren Highlighting Font"
144 "The string name of the font to be used for highlighting open parens.
145 The font is loaded when initializing Hemlock."
146 :value "*-courier-bold-r-normal--*-120-*")
147 (defhvar "Thumb Bar Meter"
148 "When non-nil (the default), windows will be created to be displayed with
149 a ruler in the bottom border of the window."
150 :value t)
151
152 (setf *key-event-history* (make-ring 60))
153 nil)
154
155
156 ;;;; Some generally useful file-system functions.
157
158 ;;; MERGE-RELATIVE-PATHNAMES takes a pathname that is either absolute or
159 ;;; relative to default-dir, merging it as appropriate and returning a definite
160 ;;; directory pathname.
161 ;;;
162 ;;; This function isn't really needed anymore now that merge-pathnames does
163 ;;; this, but the semantics are slightly different. So it's easier to just
164 ;;; keep this around instead of changing all the uses of it.
165 ;;;
166 (defun merge-relative-pathnames (pathname default-directory)
167 "Merges pathname with default-directory. If pathname is not absolute, it
168 is assumed to be relative to default-directory. The result is always a
169 directory."
170 (let ((pathname (merge-pathnames pathname default-directory)))
171 (if (directoryp pathname)
172 pathname
173 (pathname (concatenate 'simple-string
174 (namestring pathname)
175 "/")))))
176
177 (defun directoryp (pathname)
178 "Returns whether pathname names a directory, that is whether it has no
179 name and no type components."
180 (not (or (pathname-name pathname) (pathname-type pathname))))
181
182
183
184 ;;;; I/O specials and initialization
185
186 ;;; File descriptor for the terminal.
187 ;;;
188 (defvar *editor-file-descriptor*)
189
190
191 ;;; This is a hack, so screen can tell how to initialize screen management
192 ;;; without re-opening the display. It is set in INIT-RAW-IO and referenced
193 ;;; in WINDOWED-MONITOR-P.
194 ;;;
195 (defvar *editor-windowed-input* nil)
196
197 ;;; These are used for selecting X events.
198 #+clx
199 (eval-when (compile load eval)
200 (defconstant group-interesting-xevents
201 '(:structure-notify)))
202 #+clx
203 (defconstant group-interesting-xevents-mask
204 (apply #'xlib:make-event-mask group-interesting-xevents))
205
206 #+clx
207 (eval-when (compile load eval)
208 (defconstant child-interesting-xevents
209 '(:key-press :button-press :button-release :structure-notify :exposure
210 :enter-window :leave-window)))
211 #+clx
212 (defconstant child-interesting-xevents-mask
213 (apply #'xlib:make-event-mask child-interesting-xevents))
214
215 #+clx
216 (eval-when (compile load eval)
217 (defconstant random-typeout-xevents
218 '(:key-press :button-press :button-release :enter-window :leave-window
219 :exposure)))
220 #+clx
221 (defconstant random-typeout-xevents-mask
222 (apply #'xlib:make-event-mask random-typeout-xevents))
223
224
225 #+clx
226 (declaim (special ed::*open-paren-highlight-font*
227 ed::*active-region-highlight-font*))
228
229 #+clx
230 (defparameter lisp-fonts-pathnames '("library:fonts/"))
231
232 (declaim (special *editor-input* *real-editor-input*))
233
234 (declaim (special *editor-input* *real-editor-input*))
235
236 ;;; INIT-RAW-IO -- Internal
237 ;;;
238 ;;; This function should be called whenever the editor is entered in a new
239 ;;; lisp. It sets up process specific data structures.
240 ;;;
241 (defun init-raw-io (display)
242 #-clx (declare (ignore display))
243 (setf *editor-windowed-input* nil)
244 (cond #+clx
245 (display
246 (setf *editor-windowed-input* (ext:open-clx-display display))
247 (setf *editor-input* (make-windowed-editor-input))
248 (setup-font-family *editor-windowed-input*))
249 (t ;; The editor's file descriptor is Unix standard input (0).
250 ;; We don't need to affect system:*file-input-handlers* here
251 ;; because the init and exit methods for tty redisplay devices
252 ;; take care of this.
253 ;;
254 (setf *editor-file-descriptor* 0)
255 (setf *editor-input* (make-tty-editor-input 0))))
256 (setf *real-editor-input* *editor-input*)
257 *editor-windowed-input*)
258
259 ;;; Stop flaming from compiler due to CLX macros expanding into illegal
260 ;;; declarations.
261 ;;;
262 (declaim (declaration values))
263 (declaim (special *default-font-family*))
264
265 ;;; font-map-size should be defined in font.lisp, but SETUP-FONT-FAMILY would
266 ;;; assume it to be special, issuing a nasty warning.
267 ;;;
268 #+clx
269 (defconstant font-map-size 16
270 "The number of possible fonts in a font-map.")
271 #-clx
272 (defconstant font-map-size 16)
273
274 ;;; SETUP-FONT-FAMILY sets *default-font-family*, opening the three font names
275 ;;; passed in. The font family structure is filled in from the first argument.
276 ;;; Actually, this ignores default-highlight-font and default-open-paren-font
277 ;;; in lieu of "Active Region Highlighting Font" and "Open Paren Highlighting
278 ;;; Font" when these are defined.
279 ;;;
280 #+clx
281 (defun setup-font-family (display)
282 (let* ((font-family (make-font-family :map (make-array font-map-size
283 :initial-element 0)
284 :cursor-x-offset 0
285 :cursor-y-offset 0))
286 (font-family-map (font-family-map font-family)))
287 (declare (simple-vector font-family-map))
288 (setf *default-font-family* font-family)
289 (let ((font (xlib:open-font display (variable-value 'ed::default-font))))
290 (unless font
291 (error "Cannot open font -- ~S" (variable-value 'ed::default-font)))
292 (fill font-family-map font)
293 (let ((width (xlib:max-char-width font)))
294 (setf (font-family-width font-family) width)
295 (setf (font-family-cursor-width font-family) width))
296 (let* ((baseline (xlib:font-ascent font))
297 (height (+ baseline (xlib:font-descent font))))
298 (setf (font-family-height font-family) height)
299 (setf (font-family-cursor-height font-family) height)
300 (setf (font-family-baseline font-family) baseline)))
301 (setup-one-font display
302 (variable-value 'ed::open-paren-highlighting-font)
303 font-family-map
304 ed::*open-paren-highlight-font*)
305 (setup-one-font display
306 (variable-value 'ed::active-region-highlighting-font)
307 font-family-map
308 ed::*active-region-highlight-font*)))
309
310 ;;; SETUP-ONE-FONT tries to open font-name for display, storing the result in
311 ;;; font-family-map at index. XLIB:OPEN-FONT will return font stuff regardless
312 ;;; if the request is valid or not, so we finish the output to get synch'ed
313 ;;; with the server which will cause any errors to get signaled. At this
314 ;;; level, we want to deal with this error here returning nil if the font
315 ;;; couldn't be opened.
316 ;;;
317 #+clx
318 (defun setup-one-font (display font-name font-family-map index)
319 (handler-case (let ((font (xlib:open-font display (namestring font-name))))
320 (xlib:display-finish-output display)
321 (setf (svref font-family-map index) font))
322 (xlib:name-error ()
323 (warn "Cannot open font -- ~S" font-name)
324 nil)))
325
326
327 ;;;; HEMLOCK-BEEP.
328
329 (defvar *editor-bell* (make-string 1 :initial-element #\bell))
330
331 ;;; TTY-BEEP is used in Hemlock for beeping when running under a terminal.
332 ;;; Send a #\bell to unix standard output.
333 ;;;
334 (defun tty-beep (&optional device stream)
335 (declare (ignore device stream))
336 (when (variable-value 'ed::bell-style)
337 (unix:unix-write 1 *editor-bell* 0 1)))
338
339 (declaim (special *current-window*))
340
341 ;;; BITMAP-BEEP is used in Hemlock for beeping when running under windowed
342 ;;; input.
343 ;;;
344 #+clx
345 (defun bitmap-beep (device stream)
346 (declare (ignore stream))
347 (let ((display (bitmap-device-display device)))
348 (ecase (variable-value 'ed::bell-style)
349 (:border-flash
350 (flash-window-border *current-window*))
351 (:feep
352 (xlib:bell display)
353 (xlib:display-force-output display))
354 (:border-flash-and-feep
355 (xlib:bell display)
356 (xlib:display-force-output display)
357 (flash-window-border *current-window*))
358 (:flash
359 (flash-window *current-window*))
360 (:flash-and-feep
361 (xlib:bell display)
362 (xlib:display-force-output display)
363 (flash-window *current-window*))
364 ((nil) ;Do nothing.
365 ))))
366
367 #+clx
368 (declaim (special *foreground-background-xor*))
369
370 #+clx
371 (defun flash-window-border (window)
372 (let* ((hunk (window-hunk window))
373 (xwin (bitmap-hunk-xwindow hunk))
374 (gcontext (bitmap-hunk-gcontext hunk))
375 (display (bitmap-device-display (device-hunk-device hunk)))
376 (border (variable-value 'ed::beep-border-width))
377 (h (or (bitmap-hunk-modeline-pos hunk) (bitmap-hunk-height hunk)))
378 (top-border (min (ash h -1) border))
379 (w (bitmap-hunk-width hunk))
380 (side-border (min (ash w -1) border))
381 (top-width (max 0 (- w (ash side-border 1))))
382 (right-x (- w side-border))
383 (bottom-y (- h top-border)))
384 (xlib:with-gcontext (gcontext :function xlib::boole-xor
385 :foreground *foreground-background-xor*)
386 (flet ((zot ()
387 (xlib:draw-rectangle xwin gcontext 0 0 side-border h t)
388 (xlib:draw-rectangle xwin gcontext side-border bottom-y
389 top-width top-border t)
390 (xlib:draw-rectangle xwin gcontext right-x 0 side-border h t)
391 (xlib:draw-rectangle xwin gcontext side-border 0
392 top-width top-border t)))
393 (zot)
394 (xlib:display-force-output display)
395 (sleep 0.1)
396 (zot)
397 (xlib:display-force-output display)))))
398
399 #+clx
400 (defun flash-window (window)
401 (let* ((hunk (window-hunk window))
402 (xwin (bitmap-hunk-xwindow hunk))
403 (gcontext (bitmap-hunk-gcontext hunk))
404 (display (bitmap-device-display (device-hunk-device hunk)))
405 (width (bitmap-hunk-width hunk))
406 (height (or (bitmap-hunk-modeline-pos hunk)
407 (bitmap-hunk-height hunk))))
408 (xlib:with-gcontext (gcontext :function xlib::boole-xor
409 :foreground *foreground-background-xor*)
410 (xlib:draw-rectangle xwin gcontext 0 0 width height t)
411 (xlib:display-force-output display)
412 (sleep 0.1)
413 (xlib:draw-rectangle xwin gcontext 0 0 width height t)
414 (xlib:display-force-output display))))
415
416 (defun hemlock-beep (stream)
417 "Using the current window, calls the device's beep function on stream."
418 (let ((device (device-hunk-device (window-hunk (current-window)))))
419 (funcall (device-beep device) device stream)))
420
421
422
423 ;;;; GC messages.
424
425 ;;; HEMLOCK-GC-NOTIFY-BEFORE and HEMLOCK-GC-NOTIFY-AFTER both MESSAGE GC
426 ;;; notifications when Hemlock is not running under X11. It cannot affect
427 ;;; its window's without using its display connection. Since GC can occur
428 ;;; inside CLX request functions, using the same display confuses CLX.
429 ;;;
430
431 (defun hemlock-gc-notify-before (bytes-in-use)
432 (let ((control "~%[GC threshold exceeded with ~:D bytes in use. ~
433 Commencing GC.]~%"))
434 (cond ((not hi::*editor-windowed-input*)
435 (beep)
436 #|(message control bytes-in-use)|#)
437 (t
438 ;; Can't call BEEP since it would use Hemlock's display connection.
439 (lisp::default-beep-function *standard-output*)
440 (format t control bytes-in-use)
441 (finish-output)))))
442
443 (defun hemlock-gc-notify-after (bytes-retained bytes-freed trigger)
444 (let ((control
445 "[GC completed with ~:D bytes retained and ~:D bytes freed.]~%~
446 [GC will next occur when at least ~:D bytes are in use.]~%"))
447 (cond ((not hi::*editor-windowed-input*)
448 (beep)
449 #|(message control bytes-retained bytes-freed)|#)
450 (t
451 ;; Can't call BEEP since it would use Hemlock's display connection.
452 (lisp::default-beep-function *standard-output*)
453 (format t control bytes-retained bytes-freed trigger)
454 (finish-output)))))
455
456
457
458 ;;;; Site-Wrapper-Macro and standard device init/exit functions.
459
460 (defun in-hemlock-standard-input-read (stream &rest ignore)
461 (declare (ignore ignore))
462 (error "You cannot read off this stream while in Hemlock -- ~S"
463 stream))
464
465 (defvar *illegal-read-stream*
466 (lisp::make-lisp-stream :in #'in-hemlock-standard-input-read))
467
468 (defmacro site-wrapper-macro (&body body)
469 `(unwind-protect
470 (progn
471 (when *editor-has-been-entered*
472 (let ((device (device-hunk-device (window-hunk (current-window)))))
473 (funcall (device-init device) device)))
474 (let ((*beep-function* #'hemlock-beep)
475 (*gc-notify-before* #'hemlock-gc-notify-before)
476 (*gc-notify-after* #'hemlock-gc-notify-after)
477 (*standard-input* *illegal-read-stream*)
478 (*query-io* *illegal-read-stream*))
479 (cond ((not *editor-windowed-input*)
480 ,@body)
481 (t
482 #+clx
483 (ext:with-clx-event-handling
484 (*editor-windowed-input* #'ext:object-set-event-handler)
485 ,@body)))))
486 (let ((device (device-hunk-device (window-hunk (current-window)))))
487 (funcall (device-exit device) device))))
488
489 (defun standard-device-init ()
490 (setup-input))
491
492 (defun standard-device-exit ()
493 (reset-input))
494
495 (declaim (special *echo-area-window*))
496
497 ;;; Maybe bury/unbury hemlock window when we go to and from Lisp.
498 ;;; This should do something more sophisticated when we know what that is.
499 ;;;
500 #+clx
501 (defun default-hemlock-window-mngt (display on)
502 (let ((xparent (window-group-xparent
503 (bitmap-hunk-window-group (window-hunk *current-window*))))
504 (echo-xparent (window-group-xparent
505 (bitmap-hunk-window-group
506 (window-hunk *echo-area-window*)))))
507 (cond (on (setf (xlib:window-priority echo-xparent) :above)
508 (clear-editor-input *editor-input*)
509 (setf (xlib:window-priority xparent) :above))
510 (t (setf (xlib:window-priority echo-xparent) :below)
511 (setf (xlib:window-priority xparent) :below))))
512 (xlib:display-force-output display))
513
514 (defvar *hemlock-window-mngt* nil;#'default-hemlock-window-mngt
515 "This function is called by HEMLOCK-WINDOW, passing its arguments. This may
516 be nil.")
517
518 (defun hemlock-window (display on)
519 "Calls *hemlock-window-mngt* on the argument ON when *current-window* is
520 bound. This is called in the device init and exit methods for X bitmap
521 devices."
522 (when (and *hemlock-window-mngt* *current-window*)
523 (funcall *hemlock-window-mngt* display on)))
524
525
526
527 ;;;; Line Wrap Char.
528
529 (defvar *line-wrap-char* #\!
530 "The character to be displayed to indicate wrapped lines.")
531
532
533 ;;;; Current terminal character translation.
534
535 (defvar termcap-file "/etc/termcap")
536
537
538
539 ;;;; Event scheduling.
540
541 ;;; The time queue provides a ROUGH mechanism for scheduling events to
542 ;;; occur after a given amount of time has passed, optionally repeating
543 ;;; using the given time as an interval for rescheduling. When the input
544 ;;; loop goes around, it will check the current time and process all events
545 ;;; that should have happened before or at this time. The function gets
546 ;;; called on the number of seconds that have elapsed since it was last
547 ;;; called.
548 ;;;
549 ;;; NEXT-SCHEDULED-EVENT-WAIT and INVOKE-SCHEDULED-EVENTS are used in the
550 ;;; editor stream in methods.
551 ;;;
552 ;;; SCHEDULE-EVENT and REMOVE-SCHEDULED-EVENT are exported interfaces.
553
554 (defstruct (tq-event (:print-function print-tq-event)
555 (:constructor make-tq-event
556 (time last-time interval function)))
557 time ; When the event should happen.
558 last-time ; When the event was scheduled.
559 interval ; When non-nil, how often the event should happen.
560 function) ; What to do.
561
562 (defun print-tq-event (obj stream n)
563 (declare (ignore n))
564 (format stream "#<Tq-Event ~S>" (tq-event-function obj)))
565
566 (defvar *time-queue* nil
567 "This is the time priority queue used in Hemlock input streams for event
568 scheduling.")
569
570 ;;; QUEUE-TIME-EVENT inserts event into the time priority queue *time-queue*.
571 ;;; Event is inserted before the first element that it is less than (which
572 ;;; means that it gets inserted after elements that are the same).
573 ;;; *time-queue* is returned.
574 ;;;
575 (defun queue-time-event (event)
576 (let ((time (tq-event-time event)))
577 (if *time-queue*
578 (if (< time (tq-event-time (car *time-queue*)))
579 (push event *time-queue*)
580 (do ((prev *time-queue* rest)
581 (rest (cdr *time-queue*) (cdr rest)))
582 ((or (null rest)
583 (< time (tq-event-time (car rest))))
584 (push event (cdr prev))
585 *time-queue*)))
586 (push event *time-queue*))))
587
588 ;;; NEXT-SCHEDULED-EVENT-WAIT returns nil or the number of seconds to wait for
589 ;;; the next event to happen.
590 ;;;
591 (defun next-scheduled-event-wait ()
592 (if *time-queue*
593 (let ((wait (round (- (tq-event-time (car *time-queue*))
594 (get-internal-real-time))
595 internal-time-units-per-second)))
596 (if (plusp wait) wait 0))))
597
598 ;;; INVOKE-SCHEDULED-EVENTS invokes all the functions in *time-queue* whose
599 ;;; time has come. If we run out of events, or there are none, then we get
600 ;;; out. If we popped an event whose time hasn't come, we push it back on the
601 ;;; queue. Each function is called on how many seconds, roughly, went by since
602 ;;; the last time it was called (or scheduled). If it has an interval, we
603 ;;; re-queue it. While invoking the function, bind *time-queue* to nothing in
604 ;;; case the event function tries to read off *editor-input*.
605 ;;;
606 (defun invoke-scheduled-events ()
607 (let ((time (get-internal-real-time)))
608 (loop
609 (unless *time-queue* (return))
610 (let* ((event (car *time-queue*))
611 (event-time (tq-event-time event)))
612 (cond ((>= time event-time)
613 (let ((*time-queue* nil))
614 (funcall (tq-event-function event)
615 (round (- time (tq-event-last-time event))
616 internal-time-units-per-second)))
617 (without-interrupts
618 (let ((interval (tq-event-interval event)))
619 (when interval
620 (setf (tq-event-time event) (+ time interval))
621 (setf (tq-event-last-time event) time)
622 (pop *time-queue*)
623 (queue-time-event event)))))
624 (t (return)))))))
625
626 (defun schedule-event (time function &optional (repeat t))
627 "This causes function to be called after time seconds have passed,
628 optionally repeating every time seconds. This is a rough mechanism
629 since commands can take an arbitrary amount of time to run; the function
630 will be called at the first possible moment after time has elapsed.
631 Function takes the time that has elapsed since the last time it was
632 called (or since it was scheduled for the first invocation)."
633 (let ((now (get-internal-real-time))
634 (itime (* internal-time-units-per-second time)))
635 (queue-time-event (make-tq-event (+ itime now) now (if repeat itime)
636 function))))
637
638 (defun remove-scheduled-event (function)
639 "Removes function queued with SCHEDULE-EVENT."
640 (setf *time-queue* (delete function *time-queue* :key #'tq-event-function)))
641
642
643
644 ;;;; Editor sleeping.
645
646 (defun editor-sleep (time)
647 "Sleep for approximately Time seconds."
648 (unless (or (zerop time) (listen-editor-input *editor-input*))
649 (internal-redisplay)
650 (sleep-for-time time)
651 nil))
652
653 (defun sleep-for-time (time)
654 (let ((nrw-fun (device-note-read-wait
655 (device-hunk-device (window-hunk (current-window)))))
656 (end (+ (get-internal-real-time)
657 (truncate (* time internal-time-units-per-second)))))
658 (loop
659 (when (listen-editor-input *editor-input*)
660 (return))
661 (let ((left (- end (get-internal-real-time))))
662 (unless (plusp left) (return nil))
663 (when nrw-fun (funcall nrw-fun t))
664 (system:serve-event (/ (float left)
665 (float internal-time-units-per-second)))))
666 (when nrw-fun (funcall nrw-fun nil))))
667
668
669
670 ;;;; Showing a mark.
671
672 (defun show-mark (mark window time)
673 "Highlights the position of Mark within Window for Time seconds,
674 possibly by moving the cursor there. If Mark is not displayed within
675 Window return NIL. The wait may be aborted if there is pending input."
676 (let* ((result t))
677 (catch 'redisplay-catcher
678 (redisplay-window window)
679 (setf result
680 (multiple-value-bind (x y) (mark-to-cursorpos mark window)
681 (funcall (device-show-mark
682 (device-hunk-device (window-hunk window)))
683 window x y time))))
684 result))
685
686 (defun tty-show-mark (window x y time)
687 (cond ((listen-editor-input *editor-input*))
688 (x (internal-redisplay)
689 (let* ((hunk (window-hunk window))
690 (device (device-hunk-device hunk)))
691 (funcall (device-put-cursor device) hunk x y)
692 (when (device-force-output device)
693 (funcall (device-force-output device)))
694 (sleep-for-time time))
695 t)
696 (t nil)))
697
698 #+clx
699 (defun bitmap-show-mark (window x y time)
700 (cond ((listen-editor-input *editor-input*))
701 (x (let* ((hunk (window-hunk window))
702 (display (bitmap-device-display (device-hunk-device hunk))))
703 (internal-redisplay)
704 (hunk-show-cursor hunk x y)
705 (drop-cursor)
706 (xlib:display-finish-output display)
707 (sleep-for-time time)
708 (lift-cursor)
709 t))
710 (t nil)))
711
712
713 ;;;; Function description and defined-from.
714
715 ;;; FUN-DEFINED-FROM-PATHNAME takes a symbol or function object. It
716 ;;; returns a pathname for the file the function was defined in. If it was
717 ;;; not defined in some file, then nil is returned.
718 ;;;
719 (defun fun-defined-from-pathname (function)
720 "Takes a symbol or function and returns the pathname for the file the
721 function was defined in. If it was not defined in some file, nil is
722 returned."
723 (flet ((frob (code)
724 (let ((info (kernel:%code-debug-info code)))
725 (when info
726 (let ((sources (c::debug-info-source info)))
727 (when sources
728 (let ((source (car sources)))
729 (when (eq (c::debug-source-from source) :file)
730 (c::debug-source-name source)))))))))
731 (typecase function
732 (symbol (fun-defined-from-pathname (fdefinition function)))
733 (kernel:byte-closure
734 (fun-defined-from-pathname (kernel:byte-closure-function function)))
735 (kernel:byte-function
736 (frob (c::byte-function-component function)))
737 (function
738 (frob (kernel:function-code-header (kernel:%function-self function))))
739 (t nil))))
740
741
742 (defvar *editor-describe-stream*
743 (system:make-indenting-stream *standard-output*))
744
745 ;;; EDITOR-DESCRIBE-FUNCTION has to mess around to get indenting streams to
746 ;;; work. These apparently work fine for DESCRIBE, for which they were defined,
747 ;;; but not in general. It seems they don't indent initial text, only that
748 ;;; following a newline, so inside our use of INDENTING-FURTHER, we need some
749 ;;; form before the WRITE-STRING. To get this to work, I had to remove the ~%
750 ;;; from the FORMAT string, and use FRESH-LINE; simply using FRESH-LINE with
751 ;;; the ~% caused an extra blank line. Possibly I should not have glommed onto
752 ;;; this hack whose interface comes from three different packages, but it did
753 ;;; the right thing ....
754 ;;;
755 ;;; Also, we have set INDENTING-STREAM-STREAM to make sure the indenting stream
756 ;;; is based on whatever *standard-output* is when we are called.
757 ;;;
758 (defun editor-describe-function (fun sym)
759 "Calls DESCRIBE on fun. If fun is compiled, and its original name is not sym,
760 then this also outputs any 'function documentation for sym to
761 *standard-output*."
762 (describe fun)
763 (when (and (compiled-function-p fun)
764 (not (eq (kernel:%function-name (kernel:%closure-function fun))
765 sym)))
766 (let ((doc (documentation sym 'function)))
767 (when doc
768 (format t "~&Function documentation for ~S:" sym)
769 (setf (lisp::indenting-stream-stream *editor-describe-stream*)
770 *standard-output*)
771 (ext:indenting-further *editor-describe-stream* 2
772 (fresh-line *editor-describe-stream*)
773 (write-string doc *editor-describe-stream*))))))
774
775
776
777
778 ;;;; X Stuff.
779 ;;; Setting window cursors ...
780 ;;;
781
782 #+clx
783 (declaim (special *default-foreground-pixel* *default-background-pixel*))
784
785 #+clx
786 (defvar *hemlock-cursor* nil "Holds cursor for Hemlock windows.")
787
788 ;;; DEFINE-WINDOW-CURSOR in shoved on the "Make Window Hook".
789 ;;;
790 #+clx
791 (defun define-window-cursor (window)
792 (setf (xlib:window-cursor (bitmap-hunk-xwindow (window-hunk window)))
793 *hemlock-cursor*))
794
795 ;;; These are set in INIT-BITMAP-SCREEN-MANAGER and REVERSE-VIDEO-HOOK-FUN.
796 ;;;
797 #+clx
798 (defvar *cursor-foreground-color* nil)
799 #+clx
800 (defvar *cursor-background-color* nil)
801 #+clx
802 (defun make-white-color () (xlib:make-color :red 1.0 :green 1.0 :blue 1.0))
803 #+clx
804 (defun make-black-color () (xlib:make-color :red 0.0 :green 0.0 :blue 0.0))
805
806
807 ;;; GET-HEMLOCK-CURSOR is used in INIT-BITMAP-SCREEN-MANAGER to load the
808 ;;; hemlock cursor for DEFINE-WINDOW-CURSOR.
809 ;;;
810 #+clx
811 (defun get-hemlock-cursor (display)
812 (when *hemlock-cursor* (xlib:free-cursor *hemlock-cursor*))
813 (let* ((cursor-file (truename (variable-value 'ed::cursor-bitmap-file)))
814 (mask-file (probe-file (make-pathname :type "mask"
815 :defaults cursor-file)))
816 (root (xlib:screen-root (xlib:display-default-screen display)))
817 (mask-pixmap (if mask-file (get-cursor-pixmap root mask-file))))
818 (multiple-value-bind (cursor-pixmap cursor-x-hot cursor-y-hot)
819 (get-cursor-pixmap root cursor-file)
820 (setf *hemlock-cursor*
821 (xlib:create-cursor :source cursor-pixmap :mask mask-pixmap
822 :x cursor-x-hot :y cursor-y-hot
823 :foreground *cursor-foreground-color*
824 :background *cursor-background-color*))
825 (xlib:free-pixmap cursor-pixmap)
826 (when mask-pixmap (xlib:free-pixmap mask-pixmap)))))
827
828 #+clx
829 (defun get-cursor-pixmap (root pathname)
830 (let* ((image (xlib:read-bitmap-file pathname))
831 (pixmap (xlib:create-pixmap :width 16 :height 16
832 :depth 1 :drawable root))
833 (gc (xlib:create-gcontext
834 :drawable pixmap :function boole-1
835 :foreground *default-foreground-pixel*
836 :background *default-background-pixel*)))
837 (xlib:put-image pixmap gc image :x 0 :y 0 :width 16 :height 16)
838 (xlib:free-gcontext gc)
839 (values pixmap (xlib:image-x-hot image) (xlib:image-y-hot image))))
840
841
842 ;;; Setting up grey borders ...
843 ;;;
844
845 #+clx
846 (defparameter hemlock-grey-bitmap-data
847 '(#*10 #*01))
848
849 #+clx
850 (defun get-hemlock-grey-pixmap (display)
851 (let* ((screen (xlib:display-default-screen display))
852 (depth (xlib:screen-root-depth screen))
853 (root (xlib:screen-root screen))
854 (height (length hemlock-grey-bitmap-data))
855 (width (length (car hemlock-grey-bitmap-data)))
856 (image (apply #'xlib:bitmap-image hemlock-grey-bitmap-data))
857 (pixmap (xlib:create-pixmap :width width :height height
858 :depth depth :drawable root))
859 (gc (xlib:create-gcontext :drawable pixmap
860 :function boole-1
861 :foreground *default-foreground-pixel*
862 :background *default-background-pixel*)))
863 (xlib:put-image pixmap gc image
864 :x 0 :y 0 :width width :height height :bitmap-p t)
865 (xlib:free-gcontext gc)
866 pixmap))
867
868
869 ;;; Cut Buffer manipulation ...
870 ;;;
871
872 #+clx
873 (defun store-cut-string (display string)
874 (check-type string simple-string)
875 (setf (xlib:cut-buffer display) string))
876
877 #+clx
878 (defun fetch-cut-string (display)
879 (xlib:cut-buffer display))
880
881
882 ;;; Window naming ...
883 ;;;
884 #+clx
885 (defun set-window-name-for-buffer-name (buffer new-name)
886 (dolist (ele (buffer-windows buffer))
887 (xlib:set-standard-properties (bitmap-hunk-xwindow (window-hunk ele))
888 :icon-name new-name)))
889
890 #+clx
891 (defun set-window-name-for-window-buffer (window new-buffer)
892 (xlib:set-standard-properties (bitmap-hunk-xwindow (window-hunk window))
893 :icon-name (buffer-name new-buffer)))
894
895
896 ;;;; Some hacks for supporting Hemlock under Mach.
897
898 ;;; WINDOWED-MONITOR-P is used by the reverse video variable's hook function
899 ;;; to determine if it needs to go around fixing all the windows.
900 ;;;
901 (defun windowed-monitor-p ()
902 "This returns whether the monitor is being used with a window system. It
903 returns the console's CLX display structure."
904 *editor-windowed-input*)
905
906 (defun get-terminal-name ()
907 (cdr (assoc :term *environment-list* :test #'eq)))
908
909 (defun get-termcap-env-var ()
910 (cdr (assoc :termcap *environment-list* :test #'eq)))
911
912
913 ;;; GET-EDITOR-TTY-INPUT reads from stream's Unix file descriptor queuing events
914 ;;; in the stream's queue.
915 ;;;
916 (defun get-editor-tty-input (fd)
917 (alien:with-alien ((buf (alien:array c-call:unsigned-char 256)))
918 (multiple-value-bind
919 (len errno)
920 (unix:unix-read fd (alien:alien-sap buf) 256)
921 (declare (type (or null fixnum) len))
922 (unless len
923 (error "Problem with tty input: ~S"
924 (unix:get-unix-error-msg errno)))
925 (dotimes (i len t)
926 (q-event *real-editor-input*
927 (ext:char-key-event (code-char (alien:deref buf i))))))))
928
929 (defun editor-tty-listen (stream)
930 (alien:with-alien ((nc c-call:int))
931 (and (unix:unix-ioctl (tty-editor-input-fd stream)
932 unix::FIONREAD
933 (alien:alien-sap (alien:addr nc)))
934 (> nc 0))))
935
936 (defvar old-flags)
937
938 (defvar old-tchars)
939
940 #-glibc2
941 (defvar old-ltchars)
942
943 #+(or hpux irix bsd glibc2)
944 (progn
945 (defvar old-c-iflag)
946 (defvar old-c-oflag)
947 (defvar old-c-cflag)
948 (defvar old-c-lflag)
949 (defvar old-c-cc))
950
951 (defun setup-input ()
952 (let ((fd *editor-file-descriptor*))
953 (when (unix:unix-isatty 0)
954 #+(or hpux irix bsd glibc2)
955 (alien:with-alien ((tios (alien:struct unix:termios)))
956 (multiple-value-bind
957 (val err)
958 (unix:unix-tcgetattr fd (alien:alien-sap tios))
959 (when (null val)
960 (error "Could not tcgetattr, unix error ~S."
961 (unix:get-unix-error-msg err))))
962 (setf old-c-iflag (alien:slot tios 'unix:c-iflag))
963 (setf old-c-oflag (alien:slot tios 'unix:c-oflag))
964 (setf old-c-cflag (alien:slot tios 'unix:c-cflag))
965 (setf old-c-lflag (alien:slot tios 'unix:c-lflag))
966 (setf old-c-cc
967 (vector (alien:deref (alien:slot tios 'unix:c-cc) unix:vdsusp)
968 (alien:deref (alien:slot tios 'unix:c-cc) unix:veof)
969 (alien:deref (alien:slot tios 'unix:c-cc) unix:vintr)
970 (alien:deref (alien:slot tios 'unix:c-cc) unix:vquit)
971 (alien:deref (alien:slot tios 'unix:c-cc) unix:vstart)
972 (alien:deref (alien:slot tios 'unix:c-cc) unix:vstop)
973 (alien:deref (alien:slot tios 'unix:c-cc) unix:vsusp)
974 (alien:deref (alien:slot tios 'unix:c-cc) unix:vmin)
975 (alien:deref (alien:slot tios 'unix:c-cc) unix:vtime)))
976 (setf (alien:slot tios 'unix:c-lflag)
977 (logand (alien:slot tios 'unix:c-lflag)
978 (lognot (logior unix:tty-echo unix:tty-icanon))))
979 (setf (alien:slot tios 'unix:c-iflag)
980 (logand (alien:slot tios 'unix:c-iflag)
981 (lognot (logior unix:tty-icrnl unix:tty-ixon))))
982 (setf (alien:slot tios 'unix:c-oflag)
983 (logand (alien:slot tios 'unix:c-oflag)
984 (lognot #-bsd unix:tty-ocrnl
985 #+bsd unix:tty-onlcr)))
986 (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vdsusp) #xff)
987 (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:veof) #xff)
988 (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vintr)
989 (if *editor-windowed-input* #xff 28))
990 (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vquit) #xff)
991 (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vstart) #xff)
992 (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vstop) #xff)
993 (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vsusp) #xff)
994 (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vmin) 1)
995 (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vtime) 0)
996 (multiple-value-bind
997 (val err)
998 (unix:unix-tcsetattr fd unix:tcsaflush (alien:alien-sap tios))
999 (when (null val)
1000 (error "Could not tcsetattr, unix error ~S."
1001 (unix:get-unix-error-msg err)))))
1002 #-(or hpux irix bsd glibc2)
1003 (alien:with-alien ((sg (alien:struct unix:sgttyb)))
1004 (multiple-value-bind
1005 (val err)
1006 (unix:unix-ioctl fd unix:TIOCGETP (alien:alien-sap sg))
1007 (unless val
1008 (error "Could not get tty information, unix error ~S."
1009 (unix:get-unix-error-msg err))))
1010 (let ((flags (alien:slot sg 'unix:sg-flags)))
1011 (setq old-flags flags)
1012 (setf (alien:slot sg 'unix:sg-flags)
1013 (logand #-(or hpux irix bsd glibc2) (logior flags unix:tty-cbreak)
1014 (lognot unix:tty-echo)
1015 (lognot unix:tty-crmod)))
1016 (multiple-value-bind
1017 (val err)
1018 (unix:unix-ioctl fd unix:TIOCSETP (alien:alien-sap sg))
1019 (if (null val)
1020 (error "Could not set tty information, unix error ~S."
1021 (unix:get-unix-error-msg err))))))
1022 #-(or hpux irix bsd glibc2)
1023 (alien:with-alien ((tc (alien:struct unix:tchars)))
1024 (multiple-value-bind
1025 (val err)
1026 (unix:unix-ioctl fd unix:TIOCGETC (alien:alien-sap tc))
1027 (unless val
1028 (error "Could not get tty tchars information, unix error ~S."
1029 (unix:get-unix-error-msg err))))
1030 (setq old-tchars
1031 (vector (alien:slot tc 'unix:t-intrc)
1032 (alien:slot tc 'unix:t-quitc)
1033 (alien:slot tc 'unix:t-startc)
1034 (alien:slot tc 'unix:t-stopc)
1035 (alien:slot tc 'unix:t-eofc)
1036 (alien:slot tc 'unix:t-brkc)))
1037 (setf (alien:slot tc 'unix:t-intrc)
1038 (if *editor-windowed-input* -1 28))
1039 (setf (alien:slot tc 'unix:t-quitc) -1)
1040 (setf (alien:slot tc 'unix:t-startc) -1)
1041 (setf (alien:slot tc 'unix:t-stopc) -1)
1042 (setf (alien:slot tc 'unix:t-eofc) -1)
1043 (setf (alien:slot tc 'unix:t-brkc) -1)
1044 (multiple-value-bind
1045 (val err)
1046 (unix:unix-ioctl fd unix:TIOCSETC (alien:alien-sap tc))
1047 (unless val
1048 (error "Failed to set tchars, unix error ~S."
1049 (unix:get-unix-error-msg err)))))
1050
1051 ;; Needed even under HpUx to suppress dsuspc.
1052 #-(or glibc2 irix)
1053 (alien:with-alien ((tc (alien:struct unix:ltchars)))
1054 (multiple-value-bind
1055 (val err)
1056 (unix:unix-ioctl fd unix:TIOCGLTC (alien:alien-sap tc))
1057 (unless val
1058 (error "Could not get tty ltchars information, unix error ~S."
1059 (unix:get-unix-error-msg err))))
1060 (setq old-ltchars
1061 (vector (alien:slot tc 'unix:t-suspc)
1062 (alien:slot tc 'unix:t-dsuspc)
1063 (alien:slot tc 'unix:t-rprntc)
1064 (alien:slot tc 'unix:t-flushc)
1065 (alien:slot tc 'unix:t-werasc)
1066 (alien:slot tc 'unix:t-lnextc)))
1067 (setf (alien:slot tc 'unix:t-suspc) -1)
1068 (setf (alien:slot tc 'unix:t-dsuspc) -1)
1069 (setf (alien:slot tc 'unix:t-rprntc) -1)
1070 (setf (alien:slot tc 'unix:t-flushc) -1)
1071 (setf (alien:slot tc 'unix:t-werasc) -1)
1072 (setf (alien:slot tc 'unix:t-lnextc) -1)
1073 (multiple-value-bind
1074 (val err)
1075 (unix:unix-ioctl fd unix:TIOCSLTC (alien:alien-sap tc))
1076 (unless val
1077 (error "Failed to set ltchars, unix error ~S."
1078 (unix:get-unix-error-msg err))))))))
1079
1080 (defun reset-input ()
1081 (when (unix:unix-isatty 0)
1082 (let ((fd *editor-file-descriptor*))
1083 #+(or hpux irix bsd glibc2)
1084 (when (boundp 'old-c-lflag)
1085 (alien:with-alien ((tios (alien:struct unix:termios)))
1086 (multiple-value-bind
1087 (val err)
1088 (unix:unix-tcgetattr fd (alien:alien-sap tios))
1089 (when (null val)
1090 (error "Could not tcgetattr, unix error ~S."
1091 (unix:get-unix-error-msg err))))
1092 (setf (alien:slot tios 'unix:c-iflag) old-c-iflag)
1093 (setf (alien:slot tios 'unix:c-oflag) old-c-oflag)
1094 (setf (alien:slot tios 'unix:c-cflag) old-c-cflag)
1095 (setf (alien:slot tios 'unix:c-lflag) old-c-lflag)
1096 (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vdsusp)
1097 (svref old-c-cc 0))
1098 (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:veof)
1099 (svref old-c-cc 1))
1100 (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vintr)
1101 (svref old-c-cc 2))
1102 (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vquit)
1103 (svref old-c-cc 3))
1104 (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vstart)
1105 (svref old-c-cc 4))
1106 (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vstop)
1107 (svref old-c-cc 5))
1108 (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vsusp)
1109 (svref old-c-cc 6))
1110 (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vmin)
1111 (svref old-c-cc 7))
1112 (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vtime)
1113 (svref old-c-cc 8))
1114 (multiple-value-bind
1115 (val err)
1116 (unix:unix-tcsetattr fd unix:tcsaflush (alien:alien-sap tios))
1117 (when (null val)
1118 (error "Could not tcsetattr, unix error ~S."
1119 (unix:get-unix-error-msg err))))))
1120 #-(or hpux irix bsd glibc2)
1121 (when (boundp 'old-flags)
1122 (alien:with-alien ((sg (alien:struct unix:sgttyb)))
1123 (multiple-value-bind
1124 (val err)
1125 (unix:unix-ioctl fd unix:TIOCGETP (alien:alien-sap sg))
1126 (unless val
1127 (error "Could not get tty information, unix error ~S."
1128 (unix:get-unix-error-msg err)))
1129 (setf (alien:slot sg 'unix:sg-flags) old-flags)
1130 (multiple-value-bind
1131 (val err)
1132 (unix:unix-ioctl fd unix:TIOCSETP (alien:alien-sap sg))
1133 (unless val
1134 (error "Could not set tty information, unix error ~S."
1135 (unix:get-unix-error-msg err)))))))
1136 #-(or hpux irix bsd glibc2)
1137 (when (and (boundp 'old-tchars)
1138 (simple-vector-p old-tchars)
1139 (eq (length old-tchars) 6))
1140 (alien:with-alien ((tc (alien:struct unix:tchars)))
1141 (setf (alien:slot tc 'unix:t-intrc) (svref old-tchars 0))
1142 (setf (alien:slot tc 'unix:t-quitc) (svref old-tchars 1))
1143 (setf (alien:slot tc 'unix:t-startc) (svref old-tchars 2))
1144 (setf (alien:slot tc 'unix:t-stopc) (svref old-tchars 3))
1145 (setf (alien:slot tc 'unix:t-eofc) (svref old-tchars 4))
1146 (setf (alien:slot tc 'unix:t-brkc) (svref old-tchars 5))
1147 (multiple-value-bind
1148 (val err)
1149 (unix:unix-ioctl fd unix:TIOCSETC (alien:alien-sap tc))
1150 (unless val
1151 (error "Failed to set tchars, unix error ~S."
1152 (unix:get-unix-error-msg err))))))
1153 #-glibc2
1154 (when (and (boundp 'old-ltchars)
1155 (simple-vector-p old-ltchars)
1156 (eq (length old-ltchars) 6))
1157 (alien:with-alien ((tc (alien:struct unix:ltchars)))
1158 (setf (alien:slot tc 'unix:t-suspc) (svref old-ltchars 0))
1159 (setf (alien:slot tc 'unix:t-dsuspc) (svref old-ltchars 1))
1160 (setf (alien:slot tc 'unix:t-rprntc) (svref old-ltchars 2))
1161 (setf (alien:slot tc 'unix:t-flushc) (svref old-ltchars 3))
1162 (setf (alien:slot tc 'unix:t-werasc) (svref old-ltchars 4))
1163 (setf (alien:slot tc 'unix:t-lnextc) (svref old-ltchars 5))
1164 (multiple-value-bind
1165 (val err)
1166 (unix:unix-ioctl fd unix:TIOCSLTC (alien:alien-sap tc))
1167 (unless val
1168 (error "Failed to set ltchars, unix error ~S."
1169 (unix:get-unix-error-msg err)))))))))
1170
1171 (defun pause-hemlock ()
1172 "Pause hemlock and pop out to the Unix Shell."
1173 (system:without-hemlock
1174 (unix:unix-kill (unix:unix-getpid) :sigstop))
1175 T)
1176
1177
1178 (provide :hemlock)

  ViewVC Help
Powered by ViewVC 1.1.5