source: branches/event-ide/ccl/cocoa-ide/hemlock/src/rompsite.lisp @ 7993

Last change on this file since 7993 was 7993, checked in by gz, 13 years ago


Implement prompt-for-key, the last of the prompting suite of functions.

Keep last-command around, not just last-key-event, though ended up not using it.

Stop using pty's for listener input, as they wedge the cocoa thread when the
listener is busy. Use a specialized stream using direct queues, as for output.

With above change, no longer use pty's at all, so stop loading PTY module.

Rearrange recursive setup so view activation happens outside of modifying-buffer-storage.

Fix so with-buffer-bindings doesn't get confused if already wound (can't wait
til I get rid of this whole winding thing!)

make c-n/c-p with numarg at least move to end of range when not enough lines.

API tweaks:

Get rid of *invoke-hook* since not usable in current setup anyway.
Make last-key-event-typed read-only.
Move cocoa-specific part of keysym-defs to cocoa-editor.lisp
Move everything out of hemock-ext, make hemlock-ext be strictly the external support API.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 12.5 KB
1;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
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.
9  "$Header$")
11;;; **********************************************************************
13;;; "Site dependent" stuff for the editor while on the IBM RT PC machine.
16(in-package :hi)
18;;;; SITE-INIT.
20;;; *key-event-history* is defined in input.lisp, but it needs to be set in
21;;; SITE-INIT, since MAKE-RING doesn't exist at load time for this file.
23(declaim (special *key-event-history*))
25;;; SITE-INIT  --  Internal
27;;;    This function is called at init time to set up any site stuff.
29(defun site-init ()
30  (defhvar "Beep Border Width"
31    "Width in pixels of the border area inverted by beep."
32    :value 20)
33  (defhvar "Default Window Width"
34    "This is used to make a window when prompting the user.  The value is in
35     characters."
36    :value 80)
37  (defhvar "Default Window Height"
38    "This is used to make a window when prompting the user.  The value is in
39     characters."
40    :value 24)
41  (defhvar "Default Initial Window Width"
42    "This is used when Hemlock first starts up to make its first window.
43     The value is in characters."
44    :value 80)
45  (defhvar "Default Initial Window Height"
46    "This is used when Hemlock first starts up to make its first window.
47     The value is in characters."
48    :value 24)
49  (defhvar "Default Initial Window X"
50    "This is used when Hemlock first starts up to make its first window.
51     The value is in pixels."
52    :value nil)
53  (defhvar "Default Initial Window Y"
54    "This is used when Hemlock first starts up to make its first window.
55     The value is in pixels."
56    :value nil)
57  (defhvar "Bell Style"
58    "This controls what beeps do in Hemlock.  Acceptable values are :border-flash
59     (which is the default), :feep, :border-flash-and-feep, :flash,
60     :flash-and-feep, and NIL (do nothing)."
61    :value :border-flash)
62  (defhvar "Reverse Video"
63    "Paints white on black in window bodies, black on white in modelines."
64    :value nil)
65  (defhvar "Enter Window Hook"
66    "When the mouse enters an editor window, this hook is invoked.  These
67     functions take the Hemlock Window as an argument."
68    :value nil)
69  (defhvar "Exit Window Hook"
70    "When the mouse exits an editor window, this hook is invoked.  These
71     functions take the Hemlock Window as an argument."
72    :value nil)
73  (defhvar "Set Window Autoraise"
74    "When non-nil, setting the current window will automatically raise that
75     window via a function on \"Set Window Hook\".  If the value is :echo-only
76     (the default), then only the echo area window will be raised
77     automatically upon becoming current."
78    :value :echo-only)
79  (defhvar "Default Font"
80    "The string name of the font to be used for Hemlock -- buffer text,
81     modelines, random typeout, etc.  The font is loaded when initializing
82     Hemlock."
83    :value "*-courier-medium-r-normal--*-120-*")
84  (defhvar "Active Region Highlighting Font"
85    "The string name of the font to be used for highlighting active regions.
86     The font is loaded when initializing Hemlock."
87    :value "*-courier-medium-o-normal--*-120-*")
88  (defhvar "Open Paren Highlighting Font"
89    "The string name of the font to be used for highlighting open parens.
90     The font is loaded when initializing Hemlock."
91    :value "*-courier-bold-r-normal--*-120-*")
92  (defhvar "Thumb Bar Meter"
93    "When non-nil (the default), windows will be created to be displayed with
94     a ruler in the bottom border of the window."
95    :value t)
97  (setf *key-event-history* (make-ring 60))
98  nil)
101;;;; Some generally useful file-system functions.
103;;; MERGE-RELATIVE-PATHNAMES takes a pathname that is either absolute or
104;;; relative to default-dir, merging it as appropriate and returning a definite
105;;; directory pathname.
107;;; This function isn't really needed anymore now that merge-pathnames does
108;;; this, but the semantics are slightly different.  So it's easier to just
109;;; keep this around instead of changing all the uses of it.
111(defun merge-relative-pathnames (pathname default-directory)
112  "Merges pathname with default-directory.  If pathname is not absolute, it
113   is assumed to be relative to default-directory.  The result is always a
114   directory."
115  (let ((pathname (merge-pathnames pathname default-directory)))
116    (if (directoryp pathname)
117        pathname
118        (pathname (concatenate 'simple-string
119                               (namestring pathname)
120                               "/")))))
122(defun directoryp (pathname)
123  "Returns whether pathname names a directory, that is whether it has no
124   name and no type components."
125  (not (or (pathname-name pathname) (pathname-type pathname))))
129;;;; I/O specials and initialization
131;;; File descriptor for the terminal.
133(defvar *editor-file-descriptor*)
135(declaim (special *editor-input* *real-editor-input*))
137(declaim (declaration values))
139;;; font-map-size should be defined in font.lisp, but SETUP-FONT-FAMILY would
140;;; assume it to be special, issuing a nasty warning.
142(defconstant font-map-size 32)
147(defvar *beep-function* #'(lambda () (print "BEEP!")))
149(defun beep (&optional (stream *terminal-io*))
150  (funcall *beep-function* stream))
153;;;; Line Wrap Char.
155(defvar *line-wrap-char* #\!
156  "The character to be displayed to indicate wrapped lines.")
159;;;; Event scheduling.
161;;; The time queue provides a ROUGH mechanism for scheduling events to
162;;; occur after a given amount of time has passed, optionally repeating
163;;; using the given time as an interval for rescheduling.  When the input
164;;; loop goes around, it will check the current time and process all events
165;;; that should have happened before or at this time.  The function gets
166;;; called on the number of seconds that have elapsed since it was last
167;;; called.
170;;; editor stream in methods.
172;;; SCHEDULE-EVENT and REMOVE-SCHEDULED-EVENT are exported interfaces.
174(defstruct (tq-event (:print-function print-tq-event)
175                     (:constructor make-tq-event
176                                   (time last-time interval function)))
177  time          ; When the event should happen.
178  last-time     ; When the event was scheduled.
179  interval      ; When non-nil, how often the event should happen.
180  function)     ; What to do.
182(defun print-tq-event (obj stream n)
183  (declare (ignore n))
184  (format stream "#<Tq-Event ~S>" (tq-event-function obj)))
186(defvar *time-queue* nil
187  "This is the time priority queue used in Hemlock input streams for event
188   scheduling.")
190;;; QUEUE-TIME-EVENT inserts event into the time priority queue *time-queue*.
191;;; Event is inserted before the first element that it is less than (which
192;;; means that it gets inserted after elements that are the same).
193;;; *time-queue* is returned.
195(defun queue-time-event (event)
196  (let ((time (tq-event-time event)))
197    (if *time-queue*
198        (if (< time (tq-event-time (car *time-queue*)))
199            (push event *time-queue*)
200            (do ((prev *time-queue* rest)
201                 (rest (cdr *time-queue*) (cdr rest)))
202                ((or (null rest)
203                     (< time (tq-event-time (car rest))))
204                 (push event (cdr prev))
205                 *time-queue*)))
206        (push event *time-queue*))))
208;;; NEXT-SCHEDULED-EVENT-WAIT returns nil or the number of seconds to wait for
209;;; the next event to happen.
211(defun next-scheduled-event-wait ()
212  (if *time-queue*
213      (let ((wait (round (- (tq-event-time (car *time-queue*))
214                            (get-internal-real-time))
215                         internal-time-units-per-second)))
216        (if (plusp wait) wait 0))))
218;;; INVOKE-SCHEDULED-EVENTS invokes all the functions in *time-queue* whose
219;;; time has come.  If we run out of events, or there are none, then we get
220;;; out.  If we popped an event whose time hasn't come, we push it back on the
221;;; queue.  Each function is called on how many seconds, roughly, went by since
222;;; the last time it was called (or scheduled).  If it has an interval, we
223;;; re-queue it.  While invoking the function, bind *time-queue* to nothing in
224;;; case the event function tries to read off *editor-input*.
226(defun invoke-scheduled-events ()
227  (let ((time (get-internal-real-time)))
228    (loop
229      (unless *time-queue* (return))
230      (let* ((event (car *time-queue*))
231             (event-time (tq-event-time event)))
232        (cond ((>= time event-time)
233               (let ((*time-queue* nil))
234                 (funcall (tq-event-function event)
235                          (round (- time (tq-event-last-time event))
236                                 internal-time-units-per-second)))
237               (without-interrupts
238                (let ((interval (tq-event-interval event)))
239                  (when interval
240                    (setf (tq-event-time event) (+ time interval))
241                    (setf (tq-event-last-time event) time)
242                    (pop *time-queue*)
243                    (queue-time-event event)))))
244              (t (return)))))))
246(defun schedule-event (time function &optional (repeat t))
247  "This causes function to be called after time seconds have passed,
248   optionally repeating every time seconds.  This is a rough mechanism
249   since commands can take an arbitrary amount of time to run; the function
250   will be called at the first possible moment after time has elapsed.
251   Function takes the time that has elapsed since the last time it was
252   called (or since it was scheduled for the first invocation)."
253  (let ((now (get-internal-real-time))
254        (itime (* internal-time-units-per-second time)))
255    (queue-time-event (make-tq-event (+ itime now) now (if repeat itime)
256                                     function))))
258(defun remove-scheduled-event (function)
259  "Removes function queued with SCHEDULE-EVENT."
260  (setf *time-queue* (delete function *time-queue* :key #'tq-event-function)))
263;;;; Function description and defined-from.
265;;; FUN-DEFINED-FROM-PATHNAME takes a symbol or function object.  It
266;;; returns a pathname for the file the function was defined in.  If it was
267;;; not defined in some file, then nil is returned.
269(defun fun-defined-from-pathname (function)
270  "Takes a symbol or function and returns the pathname for the file the
271   function was defined in.  If it was not defined in some file, nil is
272   returned."
273  #+CMU
274  (flet ((frob (code)
275           (let ((info (kernel:%code-debug-info code)))
276             (when info
277               (let ((sources (c::debug-info-source info)))
278                 (when sources
279                   (let ((source (car sources)))
280                     (when (eq (c::debug-source-from source) :file)
281                       (c::debug-source-name source)))))))))
282    (typecase function
283      (symbol (fun-defined-from-pathname (fdefinition function)))
284      (kernel:byte-closure
285       (fun-defined-from-pathname (kernel:byte-closure-function function)))
286      (kernel:byte-function
287       (frob (c::byte-function-component function)))
288      (function
289       (frob (kernel:function-code-header (kernel:%function-self function))))
290      (t nil)))
291    #+openmcl
292    (flet ((true-namestring (path) (namestring (truename path))))
293      (typecase function
294        (function (fun-defined-from-pathname (ccl::function-name function)))
295        (symbol (let* ((info (ccl::%source-files function)))
296                  (if (atom info)
297                    (true-namestring info)
298                    (let* ((finfo (assq 'function info)))
299                      (when finfo
300                        (true-namestring
301                         (if (atom finfo)
302                           finfo
303                           (car finfo)))))))))))
306(defvar *editor-describe-stream*
307  #+CMU (system:make-indenting-stream *standard-output*)
308  #-CMU *standard-output*)
310;;; EDITOR-DESCRIBE-FUNCTION has to mess around to get indenting streams to
311;;; work.  These apparently work fine for DESCRIBE, for which they were defined,
312;;; but not in general.  It seems they don't indent initial text, only that
313;;; following a newline, so inside our use of INDENTING-FURTHER, we need some
314;;; form before the WRITE-STRING.  To get this to work, I had to remove the ~%
315;;; from the FORMAT string, and use FRESH-LINE; simply using FRESH-LINE with
316;;; the ~% caused an extra blank line.  Possibly I should not have glommed onto
317;;; this hack whose interface comes from three different packages, but it did
318;;; the right thing ....
320;;; Also, we have set INDENTING-STREAM-STREAM to make sure the indenting stream
321;;; is based on whatever *standard-output* is when we are called.
323(defun editor-describe-function (fun sym)
324  "Calls DESCRIBE on fun.  If fun is compiled, and its original name is not sym,
325   then this also outputs any 'function documentation for sym to
326   *standard-output*."
327  (declare (ignorable sym))
328  (describe fun)
329  (let ((doc (documentation sym 'function)))
330    (when doc
331      (format *standard-output* "~%Function documentation for ~S:~&~%" sym)
332          (write-string doc *standard-output*))))
Note: See TracBrowser for help on using the repository browser.