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

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

Assume 1 special arg for any form starting with "with-". Remove a bunch of
now-redundant defindent's for well-behaved with-xxx forms.

Remove some unteresting #+cmu code, change #+openmcl => #+clozure in a few places.

Make alpha value be optional in gui::color-values-to-nscolor

Remove bindings-gb.lisp (moving the two bindings it contained into
bindings.lisp).

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 11.8 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;;;; SITE-INIT.
19
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.
22;;;
23(declaim (special *key-event-history*))
24
25;;; SITE-INIT  --  Internal
26;;;
27;;;    This function is called at init time to set up any site stuff.
28;;;
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)
96
97  (setf *key-event-history* (make-ring 60))
98  nil)
99
100
101;;;; Some generally useful file-system functions.
102
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.
106;;;
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.
110;;;
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                               "/")))))
121
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))))
126
127
128
129;;;; I/O specials and initialization
130
131;;; File descriptor for the terminal.
132;;;
133(defvar *editor-file-descriptor*)
134
135(declaim (special *editor-input* *real-editor-input*))
136
137(declaim (declaration values))
138
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.
141;;;
142(defconstant font-map-size 32)
143
144
145;;;; HEMLOCK-BEEP.
146
147(defvar *beep-function* #'(lambda () (print "BEEP!")))
148
149(defun beep (&optional (stream *terminal-io*))
150  (funcall *beep-function* stream))
151
152
153;;;; Line Wrap Char.
154
155(defvar *line-wrap-char* #\!
156  "The character to be displayed to indicate wrapped lines.")
157
158
159;;;; Event scheduling.
160
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.
168;;;
169;;; NEXT-SCHEDULED-EVENT-WAIT and INVOKE-SCHEDULED-EVENTS are used in the
170;;; editor stream in methods.
171;;;
172;;; SCHEDULE-EVENT and REMOVE-SCHEDULED-EVENT are exported interfaces.
173
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.
181
182(defun print-tq-event (obj stream n)
183  (declare (ignore n))
184  (format stream "#<Tq-Event ~S>" (tq-event-function obj)))
185
186(defvar *time-queue* nil
187  "This is the time priority queue used in Hemlock input streams for event
188   scheduling.")
189
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.
194;;;
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*))))
207
208;;; NEXT-SCHEDULED-EVENT-WAIT returns nil or the number of seconds to wait for
209;;; the next event to happen.
210;;;
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))))
217
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*.
225;;;
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)))))))
245
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))))
257
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)))
261
262
263;;;; Function description and defined-from.
264
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.
268;;;
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  (flet ((true-namestring (path) (namestring (truename path))))
274    (typecase function
275      (function (fun-defined-from-pathname (ccl:function-name function)))
276      (symbol (let* ((info (ccl::%source-files function)))
277                (if (atom info)
278                  (true-namestring info)
279                  (let* ((finfo (assq 'function info)))
280                    (when finfo
281                      (true-namestring
282                       (if (atom finfo)
283                         finfo
284                         (car finfo)))))))))))
285
286
287(defvar *editor-describe-stream*
288  #+CMU (system:make-indenting-stream *standard-output*)
289  #-CMU *standard-output*)
290
291;;; EDITOR-DESCRIBE-FUNCTION has to mess around to get indenting streams to
292;;; work.  These apparently work fine for DESCRIBE, for which they were defined,
293;;; but not in general.  It seems they don't indent initial text, only that
294;;; following a newline, so inside our use of INDENTING-FURTHER, we need some
295;;; form before the WRITE-STRING.  To get this to work, I had to remove the ~%
296;;; from the FORMAT string, and use FRESH-LINE; simply using FRESH-LINE with
297;;; the ~% caused an extra blank line.  Possibly I should not have glommed onto
298;;; this hack whose interface comes from three different packages, but it did
299;;; the right thing ....
300;;;
301;;; Also, we have set INDENTING-STREAM-STREAM to make sure the indenting stream
302;;; is based on whatever *standard-output* is when we are called.
303;;;
304(defun editor-describe-function (fun sym)
305  "Calls DESCRIBE on fun.  If fun is compiled, and its original name is not sym,
306   then this also outputs any 'function documentation for sym to
307   *standard-output*."
308  (declare (ignorable sym))
309  (describe fun)
310  (let ((doc (documentation sym 'function)))
311    (when doc
312      (format *standard-output* "~%Function documentation for ~S:~&~%" sym)
313          (write-string doc *standard-output*))))
314
Note: See TracBrowser for help on using the repository browser.