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

Contents of /src/hemlock/rompsite.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17 - (hide 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 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 emarsden 1.17 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/rompsite.lisp,v 1.17 2003/05/05 16:13:59 emarsden Rel $")
9 ram 1.4 ;;;
10 ram 1.1 ;;; **********************************************************************
11     ;;;
12 emarsden 1.16 ;;; "Site dependent" stuff for the Hemlock editor
13 ram 1.1 ;;;
14 pmai 1.15
15     ;;; If we were compiled with CLX support, we require it at runtime
16     #+clx
17     (require :clx)
18 ram 1.1
19 ram 1.4 ;;; Stuff to set up the packages Hemlock uses.
20     ;;;
21 ram 1.7 (unless (find-package "HEMLOCK-INTERNALS")
22     (make-package "HEMLOCK-INTERNALS"
23     :nicknames '("HI")
24     :use '("LISP" "EXTENSIONS" "SYSTEM")))
25 ram 1.4 ;;;
26 ram 1.7 (unless (find-package "HEMLOCK")
27     (make-package "HEMLOCK"
28     :nicknames '("ED")
29     :use '("LISP" "HEMLOCK-INTERNALS" "EXTENSIONS" "SYSTEM")))
30 ram 1.4 ;;;
31 ram 1.1 (in-package "SYSTEM")
32 ram 1.4 (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 ram 1.1
38 ram 1.2 (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 ram 1.1 ;;
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 ram 1.2 ;;; *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 ram 1.1 ;;;
73 pw 1.13 (declaim (special *key-event-history*))
74 ram 1.1
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 ram 1.4 :value "library:hemlock11.cursor")
120 ram 1.1 (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 ram 1.5 :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 ram 1.1 (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 ram 1.2 (setf *key-event-history* (make-ring 60))
153 ram 1.1 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 ram 1.4 ;;; 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 ram 1.1 ;;;
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 ram 1.4 (let ((pathname (merge-pathnames pathname default-directory)))
171     (if (directoryp pathname)
172     pathname
173     (pathname (concatenate 'simple-string
174     (namestring pathname)
175     "/")))))
176 ram 1.1
177     (defun directoryp (pathname)
178 ram 1.4 "Returns whether pathname names a directory, that is whether it has no
179     name and no type components."
180 ram 1.1 (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 ram 1.4 #+clx
199     (eval-when (compile load eval)
200     (defconstant group-interesting-xevents
201     '(:structure-notify)))
202     #+clx
203 ram 1.3 (defconstant group-interesting-xevents-mask
204     (apply #'xlib:make-event-mask group-interesting-xevents))
205 ram 1.1
206 ram 1.4 #+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 ram 1.3 (defconstant child-interesting-xevents-mask
213     (apply #'xlib:make-event-mask child-interesting-xevents))
214    
215 ram 1.4 #+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 ram 1.1 (defconstant random-typeout-xevents-mask
222 ram 1.3 (apply #'xlib:make-event-mask random-typeout-xevents))
223 ram 1.1
224 ram 1.4
225     #+clx
226 pw 1.13 (declaim (special ed::*open-paren-highlight-font*
227     ed::*active-region-highlight-font*))
228 ram 1.1
229 ram 1.4 #+clx
230     (defparameter lisp-fonts-pathnames '("library:fonts/"))
231 ram 1.1
232 pw 1.13 (declaim (special *editor-input* *real-editor-input*))
233 ram 1.1
234 pw 1.13 (declaim (special *editor-input* *real-editor-input*))
235 ram 1.2
236 ram 1.1 ;;; 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 ram 1.4 #-clx (declare (ignore display))
243 ram 1.1 (setf *editor-windowed-input* nil)
244 ram 1.4 (cond #+clx
245     (display
246 ram 1.1 (setf *editor-windowed-input* (ext:open-clx-display display))
247 ram 1.2 (setf *editor-input* (make-windowed-editor-input))
248 ram 1.5 (setup-font-family *editor-windowed-input*))
249 ram 1.1 (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 ram 1.2 (setf *editor-input* (make-tty-editor-input 0))))
256 ram 1.1 (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 pw 1.13 (declaim (declaration values))
263     (declaim (special *default-font-family*))
264 ram 1.1
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 ram 1.4 #+clx
269 ram 1.1 (defconstant font-map-size 16
270     "The number of possible fonts in a font-map.")
271 ram 1.9 #-clx
272     (defconstant font-map-size 16)
273 ram 1.1
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 ram 1.4 #+clx
281 ram 1.5 (defun setup-font-family (display)
282 ram 1.1 (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 ram 1.5 (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 ram 1.1 (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 ram 1.5 (variable-value 'ed::open-paren-highlighting-font)
303 ram 1.1 font-family-map
304     ed::*open-paren-highlight-font*)
305     (setup-one-font display
306 ram 1.5 (variable-value 'ed::active-region-highlighting-font)
307 ram 1.1 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 ram 1.4 #+clx
318 ram 1.1 (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 ram 1.4 (unix:unix-write 1 *editor-bell* 0 1)))
338 ram 1.1
339 pw 1.13 (declaim (special *current-window*))
340 ram 1.1
341     ;;; BITMAP-BEEP is used in Hemlock for beeping when running under windowed
342     ;;; input.
343     ;;;
344 ram 1.4 #+clx
345     (defun bitmap-beep (device stream)
346 ram 1.1 (declare (ignore stream))
347 ram 1.4 (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 ram 1.1
367 ram 1.4 #+clx
368 pw 1.13 (declaim (special *foreground-background-xor*))
369 ram 1.1
370 ram 1.4 #+clx
371 ram 1.1 (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 ram 1.4 (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 ram 1.1 (xlib:display-force-output display)
395 ram 1.4 (sleep 0.1)
396     (zot)
397 ram 1.1 (xlib:display-force-output display)))))
398    
399 ram 1.4 #+clx
400 ram 1.1 (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 ram 1.4 (sleep 0.1)
413 ram 1.1 (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 ram 1.4 (funcall (device-beep device) device stream)))
420 ram 1.1
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 dtc 1.11 (lisp::make-lisp-stream :in #'in-hemlock-standard-input-read))
467 ram 1.1
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 ram 1.4 #+clx
483 ram 1.1 (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 pw 1.13 (declaim (special *echo-area-window*))
496 ram 1.1
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 ram 1.4 #+clx
501 ram 1.1 (defun default-hemlock-window-mngt (display on)
502 ram 1.3 (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 ram 1.2 (clear-editor-input *editor-input*)
509 ram 1.3 (setf (xlib:window-priority xparent) :above))
510     (t (setf (xlib:window-priority echo-xparent) :below)
511     (setf (xlib:window-priority xparent) :below))))
512 ram 1.1 (xlib:display-force-output display))
513    
514 ram 1.4 (defvar *hemlock-window-mngt* nil;#'default-hemlock-window-mngt
515 ram 1.1 "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 ram 1.2 ;;;; Line Wrap Char.
528 ram 1.1
529 ram 1.2 (defvar *line-wrap-char* #\!
530     "The character to be displayed to indicate wrapped lines.")
531 ram 1.1
532 ram 1.2
533     ;;;; Current terminal character translation.
534 ram 1.1
535 ram 1.4 (defvar termcap-file "/etc/termcap")
536 ram 1.1
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 ram 1.2 (unless (or (zerop time) (listen-editor-input *editor-input*))
649 ram 1.1 (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 ram 1.2 (when (listen-editor-input *editor-input*)
660     (return))
661 ram 1.1 (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 ram 1.2 (cond ((listen-editor-input *editor-input*))
688 ram 1.1 (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 ram 1.4 #+clx
699 ram 1.1 (defun bitmap-show-mark (window x y time)
700 ram 1.2 (cond ((listen-editor-input *editor-input*))
701 ram 1.1 (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 ram 1.4 "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 ram 1.1
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 ram 1.4 (not (eq (kernel:%function-name (kernel:%closure-function fun))
765     sym)))
766 ram 1.1 (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 ram 1.4 #+clx
783 pw 1.13 (declaim (special *default-foreground-pixel* *default-background-pixel*))
784 ram 1.1
785 ram 1.4 #+clx
786 ram 1.1 (defvar *hemlock-cursor* nil "Holds cursor for Hemlock windows.")
787    
788     ;;; DEFINE-WINDOW-CURSOR in shoved on the "Make Window Hook".
789     ;;;
790 ram 1.4 #+clx
791 ram 1.1 (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 ram 1.4 #+clx
798 ram 1.1 (defvar *cursor-foreground-color* nil)
799 ram 1.4 #+clx
800 ram 1.1 (defvar *cursor-background-color* nil)
801 ram 1.4 #+clx
802 ram 1.1 (defun make-white-color () (xlib:make-color :red 1.0 :green 1.0 :blue 1.0))
803 ram 1.4 #+clx
804 ram 1.1 (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 ram 1.4 #+clx
811 ram 1.1 (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 ram 1.4 #+clx
829 ram 1.1 (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 ram 1.4 #+clx
846 ram 1.1 (defparameter hemlock-grey-bitmap-data
847     '(#*10 #*01))
848    
849 ram 1.4 #+clx
850 ram 1.1 (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 ram 1.4 #+clx
873 ram 1.1 (defun store-cut-string (display string)
874     (check-type string simple-string)
875     (setf (xlib:cut-buffer display) string))
876    
877 ram 1.4 #+clx
878 ram 1.1 (defun fetch-cut-string (display)
879     (xlib:cut-buffer display))
880    
881    
882     ;;; Window naming ...
883     ;;;
884 ram 1.4 #+clx
885 ram 1.1 (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 ram 1.4 #+clx
891 ram 1.1 (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 ram 1.4 (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 ram 1.1
929     (defun editor-tty-listen (stream)
930 ram 1.4 (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 ram 1.1
936     (defvar old-flags)
937    
938     (defvar old-tchars)
939    
940 dtc 1.12 #-glibc2
941 ram 1.1 (defvar old-ltchars)
942    
943 pmai 1.14 #+(or hpux irix bsd glibc2)
944 ram 1.4 (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 ram 1.1 (defun setup-input ()
952     (let ((fd *editor-file-descriptor*))
953 ram 1.4 (when (unix:unix-isatty 0)
954 pmai 1.14 #+(or hpux irix bsd glibc2)
955 ram 1.4 (alien:with-alien ((tios (alien:struct unix:termios)))
956 ram 1.1 (multiple-value-bind
957     (val err)
958 ram 1.4 (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 pw 1.10 (logand (alien:slot tios 'unix:c-oflag)
984 pmai 1.14 (lognot #-bsd unix:tty-ocrnl
985     #+bsd unix:tty-onlcr)))
986 ram 1.4 (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 ram 1.1 (multiple-value-bind
997     (val err)
998 ram 1.4 (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 pmai 1.14 #-(or hpux irix bsd glibc2)
1003 ram 1.4 (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 pmai 1.14 (logand #-(or hpux irix bsd glibc2) (logior flags unix:tty-cbreak)
1014 ram 1.4 (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 pmai 1.14 #-(or hpux irix bsd glibc2)
1023 ram 1.4 (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 ram 1.1 (if *editor-windowed-input* -1 28))
1039 ram 1.4 (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 ram 1.1 (multiple-value-bind
1045     (val err)
1046 ram 1.4 (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 dtc 1.12 #-(or glibc2 irix)
1053 ram 1.4 (alien:with-alien ((tc (alien:struct unix:ltchars)))
1054 ram 1.1 (multiple-value-bind
1055     (val err)
1056 ram 1.4 (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 ram 1.1 (multiple-value-bind
1074     (val err)
1075 ram 1.4 (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 ram 1.1
1080     (defun reset-input ()
1081 ram 1.4 (when (unix:unix-isatty 0)
1082     (let ((fd *editor-file-descriptor*))
1083 pmai 1.14 #+(or hpux irix bsd glibc2)
1084 ram 1.4 (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 pmai 1.14 #-(or hpux irix bsd glibc2)
1121 ram 1.4 (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 ram 1.1 (multiple-value-bind
1131     (val err)
1132 ram 1.4 (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 pmai 1.14 #-(or hpux irix bsd glibc2)
1137 ram 1.4 (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 dtc 1.12 #-glibc2
1154 ram 1.4 (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 ram 1.1
1171     (defun pause-hemlock ()
1172     "Pause hemlock and pop out to the Unix Shell."
1173 ram 1.4 (system:without-hemlock
1174     (unix:unix-kill (unix:unix-getpid) :sigstop))
1175 ram 1.1 T)
1176 emarsden 1.17
1177    
1178     (provide :hemlock)

  ViewVC Help
Powered by ViewVC 1.1.5