source: trunk/ccl/hemlock/src/rompsite.lisp @ 781

Last change on this file since 781 was 781, checked in by gb, 16 years ago

Remove some CLXisms.

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