Mercurial > hg > xemacs-beta

comparison lisp/eos/sun-eos-common.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 8fc7fe29b841
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;; Copyright (C) 1995, Sun Microsystems
2 ;;
3 ;; Light Weight Editor Integration for Sparcworks.
4 ;; "Era on Sparcworks" (EOS)
5 ;;
6 ;; Author: Eduardo Pelegri-Llopart
7 ;;
8 ;; Please send feedback to eduardo.pelegri-llopart@eng.sun.com
9
10 ;; Common routines for EOS
11
12 (defvar eos::version "1.5.2"
13 "Version of Eos")
14
15 (defvar eos::left-margin-width 5
16 "size of left margin")
17
18 (defvar eos::stop-color "red"
19 "foreground color for stop signs")
20 (defvar eos::solid-arrow-color "purple"
21 "foreground color for solid arrow")
22 (defvar eos::hollow-arrow-color "purple"
23 "foreground color for hollow arrow")
24 (defvar eos::sbrowse-arrow-color "blue"
25 "foreground color for browser glyphs")
26
27 (defun eos::recompute-presentation ()
28 (set-face-foreground 'stop-face eos::stop-color)
29 (set-face-foreground 'solid-arrow-face eos::solid-arrow-color)
30 (set-face-foreground 'hollow-arrow-face eos::hollow-arrow-color)
31 (set-face-foreground 'sbrowse-arrow-face eos::sbrowse-arrow-color)
32 )
33
34 ;;
35
36 (defvar eos::displayed-initial-message nil
37 "Whether we have shown the initial display message")
38
39 (defconst eos::startup-message-lines
40 '("Please send feedback to eos-comments@cs.uiuc.edu."
41 "The latest Eos news are under SPARCworks->News"
42 "See Options->SPARCworks for configuration and Help->SPARCworks for help"
43 ))
44
45 ;; copied from vm
46
47 (defun eos::display-initial-message ()
48 ;; Display initial Eos message - REMOVED
49 )
50
51 (defun eos-old::display-initial-message ()
52 ;; Display initial Eos message
53 (if (not eos::displayed-initial-message)
54 (let ((lines eos::startup-message-lines))
55 (message "Eos %s, Copyright (C) 1995 Sun MicroSystems"
56 eos::version)
57 (setq eos::displayed-initial-message t)
58 (while (and (sit-for 3) lines)
59 (message (car lines))
60 (setq lines (cdr lines))))
61 (message "")))
62
63 ;; misc
64
65 (defun eos::line-at (pos)
66 ;; At what line is POS
67 (save-restriction
68 (widen)
69 (save-excursion
70 (goto-char pos)
71 (beginning-of-line)
72 (1+ (count-lines 1 (point))))))
73
74 ;; frame-specific enabling
75 ;;
76 ;; will maintain at most one frame to debugger, one to sbrowser
77 ;; annotations have a type, either
78 ;;
79 ;; sbrowser
80 ;; debugger-solid-arrow
81 ;; debugger-holow-arrow
82 ;; debugger-stop
83 ;; debugger-visit
84 ;;
85 ;; adding an annotation of type sbrowser will be only on frame sbrowser
86 ;; adding an annotation of type debugger will be only on frame debugger
87 ;;
88 ;; turn off patterns when there is no frame.
89
90
91 ;;;
92 ;;; Common ToolTalk function
93 ;;;
94
95 (defun make-an-observer (op callback)
96 (let ((pattern-desc
97 (list
98 'category 'TT_OBSERVE
99 'scope 'TT_SESSION
100 'class 'TT_NOTICE
101 'op op
102 'callback callback)))
103 (make-tooltalk-pattern pattern-desc)
104 ))
105
106 ;;;
107 ;;; Frame management
108 ;;;
109
110 (defun eos::log (msg)
111 (if (fboundp 'ut-log-text)
112 (ut-log-text "eos version: %s; %s" eos::version msg)))
113
114 (defvar eos::sbrowser-frame nil)
115 (defvar eos::debugger-frame nil)
116
117 (defun eos::update-specifiers (type old-frame new-frame)
118 ;; Change the database for annotations of TYPE, so that OLD-FRAME is
119 ;; now using the alternate specifier, while NEW-FRAME uses the main one
120 (let* ((device-type (device-type (selected-device)))
121 (g (eos::annotation-get-glyph type device-type))
122 (im (and (glyphp g) (glyph-image g)))
123 (new-instantiator (eos::annotation-get-inst type device-type))
124 (alt-instantiator (eos::annotation-get-inst-alt type device-type))
125 )
126 (if (eq device-type 'x)
127 (progn
128 (if (frame-live-p old-frame)
129 (progn
130 (remove-specifier im old-frame)
131 (add-spec-to-specifier im alt-instantiator old-frame)))
132 (if new-frame
133 (progn
134 (add-spec-to-specifier im new-instantiator new-frame)
135 ))))))
136
137
138 (defun eos::select-sbrowser-frame (frame)
139 (require 'eos-toolbar "sun-eos-toolbar")
140 (let ((toolbar (eos::toolbar-position)))
141 (eos::display-initial-message)
142 ;; logging
143 (if frame
144 (eos::log "selected frame for sbrowser")
145 (eos::log "unselected frame for sbrowser"))
146 ;; TT patterns
147 (cond
148 ((and (null eos::sbrowser-frame) frame)
149 (eos::register-sbrowser-patterns))
150 ((and (null frame) eos::sbrowser-frame)
151 (eos::unregister-sbrowser-patterns)))
152 ;; adjust toolbars
153 (if (frame-live-p eos::sbrowser-frame)
154 (remove-specifier toolbar eos::sbrowser-frame))
155 (if (frame-live-p eos::debugger-frame)
156 (remove-specifier toolbar eos::debugger-frame))
157 ;; then add
158 (cond
159 ((and (frame-live-p eos::debugger-frame) (frame-live-p frame)
160 (equal eos::debugger-frame frame))
161 (add-spec-to-specifier toolbar eos::debugger-sbrowser-toolbar frame))
162 ((and (frame-live-p eos::debugger-frame) (frame-live-p frame))
163 (add-spec-to-specifier toolbar eos::sbrowser-toolbar frame)
164 (add-spec-to-specifier toolbar eos::debugger-toolbar eos::debugger-frame))
165 ((frame-live-p frame)
166 (add-spec-to-specifier toolbar eos::sbrowser-toolbar frame))
167 ((frame-live-p eos::debugger-frame)
168 (add-spec-to-specifier toolbar eos::debugger-toolbar eos::debugger-frame))
169 )
170 ;; adjust specifiers for glyphs
171 (eos::update-specifiers 'sbrowser eos::sbrowser-frame frame)
172 (if (frame-live-p eos::sbrowser-frame)
173 (progn
174 (remove-specifier use-left-overflow eos::sbrowser-frame)
175 (remove-specifier left-margin-width eos::sbrowser-frame)))
176 (if (frame-live-p frame)
177 (progn
178 (add-spec-to-specifier use-left-overflow t frame)
179 (add-spec-to-specifier left-margin-width eos::left-margin-width frame)
180 (add-spec-to-specifier left-margin-width 0 (minibuffer-window))))
181 (if (frame-live-p eos::debugger-frame)
182 (progn
183 (add-spec-to-specifier use-left-overflow t eos::debugger-frame)
184 (add-spec-to-specifier left-margin-width eos::left-margin-width eos::debugger-frame)
185 (add-spec-to-specifier left-margin-width 0 (minibuffer-window))))
186 ;;
187 (setq eos::sbrowser-frame frame)
188 (set-menubar-dirty-flag)
189 ))
190
191 (defun eos::select-debugger-frame (frame)
192 (require 'eos-toolbar "sun-eos-toolbar")
193 (let ((toolbar (eos::toolbar-position)))
194 (eos::display-initial-message)
195 (save-excursion
196 (eos::ensure-debugger-buffer)
197 (bury-buffer))
198 ;; logging
199 (if frame
200 (eos::log "selected frame for debugger")
201 (eos::log "unselected frame for debugger"))
202 ;; TT patterns
203 (cond
204 ((and (null eos::debugger-frame) frame)
205 (eos::register-debugger-patterns)
206 (eos::register-visit-file-pattern))
207 ((and (null frame) eos::debugger-frame)
208 (eos::unregister-debugger-patterns)
209 (eos::unregister-visit-file-pattern)))
210 ;; adjust toolbars, remove
211 (if (frame-live-p eos::sbrowser-frame)
212 (remove-specifier toolbar eos::sbrowser-frame))
213 (if (frame-live-p eos::debugger-frame)
214 (remove-specifier toolbar eos::debugger-frame))
215 ;; then add
216 (cond
217 ((and (frame-live-p eos::sbrowser-frame) (frame-live-p frame)
218 (equal eos::sbrowser-frame frame))
219 (add-spec-to-specifier toolbar eos::debugger-sbrowser-toolbar frame))
220 ((and (frame-live-p eos::sbrowser-frame) (frame-live-p frame))
221 (add-spec-to-specifier toolbar eos::debugger-toolbar frame)
222 (add-spec-to-specifier toolbar eos::sbrowser-toolbar eos::sbrowser-frame))
223 ((frame-live-p frame)
224 (add-spec-to-specifier toolbar eos::debugger-toolbar frame))
225 ((frame-live-p eos::sbrowser-frame)
226 (add-spec-to-specifier toolbar eos::sbrowser-toolbar eos::sbrowser-frame))
227 )
228 ;; update glyph specifiers
229 (eos::update-specifiers 'debugger-solid-arrow eos::debugger-frame frame)
230 (eos::update-specifiers 'debugger-hollow-arrow eos::debugger-frame frame)
231 (eos::update-specifiers 'debugger-stop eos::debugger-frame frame)
232 (if (frame-live-p eos::debugger-frame)
233 (progn
234 (remove-specifier use-left-overflow eos::debugger-frame)
235 (remove-specifier left-margin-width eos::debugger-frame)))
236 (if (frame-live-p frame)
237 (progn
238 (add-spec-to-specifier use-left-overflow t frame)
239 (add-spec-to-specifier left-margin-width eos::left-margin-width frame)
240 (add-spec-to-specifier left-margin-width 0 (minibuffer-window))))
241 (if (frame-live-p eos::sbrowser-frame)
242 (progn
243 (add-spec-to-specifier use-left-overflow t eos::sbrowser-frame)
244 (add-spec-to-specifier left-margin-width eos::left-margin-width eos::sbrowser-frame)
245 (add-spec-to-specifier left-margin-width 0 (minibuffer-window))))
246 ;;
247 (setq eos::debugger-frame frame)
248 (set-menubar-dirty-flag)
249 ))
250
251 ;; HERE use file-truename
252
253 (defun eos::select-frame (type)
254 ;; Select a frame; return nil if should skip
255 (cond ((eq type 'sbrowser)
256 (if (frame-live-p eos::sbrowser-frame)
257 eos::sbrowser-frame
258 (message "selecting destroyed frame; will ignore")
259 (eos::select-sbrowser-frame nil)
260 nil))
261 ((or (eq type 'debugger-solid-arrow)
262 (eq type 'debugger-hollow-arrow)
263 (eq type 'debugger-stop)
264 (eq type 'debugger-visit))
265 (if (frame-live-p eos::debugger-frame)
266 eos::debugger-frame
267 (message "selecting destroyed frame; will ignore")
268 (eos::select-debugger-frame nil)
269 nil))
270 (t (selected-frame))))
271
272 (defun eos::select-window (win)
273 ;; Will select a window if it is not showing neither of eos::debugger-buffer or
274 ;; eos::toolbar-buffer"
275 (let ((name (buffer-name (window-buffer win))))
276 (if (and (>= (length name) 4)
277 (equal (substring name 0 4) "*Eos"))
278 nil
279 (select-window win)
280 (throw 'found t)
281 )))
282
283 (defun eos::find-line (file line type)
284 ;; Show FILE at LINE; returns frame or nil if inappropriate
285 ;; if type is nil
286 (if (eos::null-file file)
287 (selected-frame)
288 (let ((sc (eos::select-frame type))
289 (win (selected-window)))
290 (if (null sc)
291 nil
292 (select-frame sc)
293 (if (catch 'found
294 (eos::select-window (selected-window))
295 (walk-windows 'eos::select-window)
296 nil)
297 nil ; do nothing, already there
298 (select-window win)
299 (split-window-vertically)
300 (other-window 1)
301 )
302 (switch-to-buffer (find-file-noselect file t)) ;; no warn!
303 (if (eq (device-type) 'x) (x-disown-selection))
304 (goto-line line)
305 sc
306 ))))
307
308 (defun eos::null-file (file)
309 ;; returns t if FILE is nil or the empty string
310 (or (null file) (equal file "")))
311
312 ;;;
313 ;;; Annotation handling
314 ;;;
315
316 (defun eos::valid-annotation (annotation)
317 ;; returns t if ANNOTATION is an annotation and its buffer exists
318 (and (annotationp annotation)
319 (bufferp (extent-buffer annotation))
320 (buffer-name (extent-buffer annotation)))
321 )
322
323 (defvar eos::annotation-list nil
324 "list of annotations set")
325
326 (defun eos::add-to-annotation-list (ann type)
327 (if (not (eq type 'debugger-stop))
328 (error "not implemented"))
329 (setq eos::annotation-list (cons ann
330 eos::annotation-list))
331 )
332
333 (defun eos::remove-from-annotation-list (ann type)
334 (if (not (eq type 'debugger-stop))
335 (error "not implemented"))
336 (setq eos::annotation-list (delq ann eos::annotation-list))
337 )
338
339 (defun eos::remove-all-from-annotation-list (type)
340 (if (not (eq type 'debugger-stop))
341 (error "not implemented"))
342 (mapcar (function (lambda (annot)
343 (if (extent-live-p annot)
344 (delete-annotation annot))))
345 eos::annotation-list)
346 (setq eos::annotation-list nil))
347
348 (defun eos::add-annotation (type file line uid)
349 (let ((anot nil)
350 (fr (selected-frame))
351 (win (selected-window))
352 )
353 (if (eos::null-file file)
354 (setq anot nil)
355 (if (null (eos::find-line file line type))
356 (error "No frame to select"))
357 (let* ((device-type (device-type (selected-device)))
358 (graphics (eos::annotation-get-glyph type device-type))
359 (face (eos::annotation-get-face type device-type))
360 )
361 (setq anot (make-annotation graphics (point) 'whitespace))
362 (set-annotation-data anot uid)
363 (set-extent-face anot face)
364 (eos::add-to-annotation-list anot type)
365 ))
366 (select-frame fr)
367 (select-window win)
368 anot
369 ))
370
371 (defun eos::compare-uid (extent uid)
372 (and (annotationp extent)
373 (equal (annotation-data extent) uid)
374 extent))
375
376 (defun eos::delete-annotation (type file line uid)
377 ;; ignore file and line, they are here for backward compatibility
378 (let ((anot nil)
379 (alist eos::annotation-list)
380 )
381 (if (not (eq type 'debugger-stop))
382 (error "not implemented"))
383 (while (and alist
384 (not (equal (annotation-data (car alist)) uid)))
385 (setq alist (cdr alist)))
386 (if (null alist)
387 (error "Event UID not found; ignored")
388 (setq anot (car alist))
389 (delete-annotation anot)
390 (eos::remove-from-annotation-list anot type))
391 ))
392
393 ;; probably type should not be given here... (already stored in the annotation-data
394 ;; field) but it is a bit more robust this way.
395
396 (defun eos::make-annotation-visible (annotation file line type)
397 ;; returns nil or moves the ANNOTATION to FILE and LINE; annotation is of TYPE
398 (let ((back nil)
399 (fr (selected-frame))
400 (win (selected-window))
401 )
402 ;; (save-window-excursion
403 (if (not (eos::null-file file))
404 (progn
405 (if (eos::valid-annotation annotation)
406 (detach-extent annotation) ; should operate on annotations
407 )
408 (if (null (eos::find-line file line type))
409 (error "No frame to select"))
410 (let* ((device-type (device-type (selected-device)))
411 (graphics (eos::annotation-get-glyph type device-type))
412 (face (eos::annotation-get-face type device-type))
413 )
414 (if (and (eos::valid-annotation annotation)
415 (extent-detached-p annotation))
416 (progn
417 (setq back (insert-extent annotation (point) (point) t))
418 (set-annotation-glyph back graphics 'whitespace)
419 )
420 (setq back (make-annotation graphics (point) 'whitespace))
421 )
422 (set-annotation-data back type)
423 (set-extent-face back face)
424 )))
425 ;; )
426 (if (not (eq (selected-frame) fr))
427 (select-frame fr))
428 (select-window win)
429 back
430 ))
431
432 (defun eos::make-annotation-invisible (annotation)
433 ;; make this ANNOTATION invisible
434 (if (eos::valid-annotation annotation)
435 (detach-extent annotation) ;; should operate on annotations
436 ))
437
438
439 ;; mapping between annotation types and their screen representations.
440
441 (defvar eos::alist-annotation-glyph nil) ; assoc list of annotation type
442 ; device type, and glyph
443 (defvar eos::alist-annotation-inst nil) ; assoc list of annotation type
444 ; device type, and instantiator
445 (defvar eos::alist-annotation-inst-alt nil) ; alternate assoc list of annotation type
446 ; device type, and instantiator
447
448 (defvar eos::alist-annotation-face nil) ;; assoc list of annotation type,
449 ;; device type and face
450
451 ;; PUBLIC
452
453 ;; TBD! merge both instance lists.
454
455 (defun eos::annotation-set-inst (annotation-type device-type inst inst-alt)
456 "define the instantiator for ANNOTATION-TYPE on DEVICE-TYPE to be
457 INST for the frame enabled for this type and INST-ALT for other frames"
458 (interactive)
459 (setq eos::alist-annotation-inst
460 (cons (cons (cons annotation-type device-type) inst)
461 eos::alist-annotation-inst))
462 (setq eos::alist-annotation-inst-alt
463 (cons (cons (cons annotation-type device-type) inst-alt)
464 eos::alist-annotation-inst-alt)) )
465
466 (defun eos::annotation-set-face (annotation-type device-type face-1 face-2)
467 "define the face for ANNOTATION-TYPE on DEVICE-TYPE to be
468 FACE-1 for the frame enabled for this type and FACE-2 for other frames"
469 (interactive)
470 (setq eos::alist-annotation-face
471 (cons (cons (cons annotation-type device-type) face-1)
472 eos::alist-annotation-face))
473 )
474
475 ;; PRIVATE
476
477 (defun eos::annotation-get-glyph (annotation-type device-type)
478 ;; Get the glyph for ANNOTATION-TYPE on DEVICE-TYPE
479 (interactive)
480 (let ((found (assoc (cons annotation-type device-type)
481 eos::alist-annotation-glyph)))
482 (if found
483 (cdr found)
484 (let ((inst (eos::annotation-get-inst annotation-type device-type))
485 (alt-inst (eos::annotation-get-inst-alt annotation-type device-type))
486 (glyph nil)
487 (frame (selected-frame)))
488 (if (null inst)
489 nil
490 (setq glyph (make-glyph `((global . (nil . ,alt-inst)))))
491 (add-spec-to-specifier (glyph-image glyph) inst frame)
492 (setq eos::alist-annotation-glyph
493 (cons (cons (cons annotation-type device-type) glyph)
494 eos::alist-annotation-glyph))
495 glyph))
496 )))
497
498 (defun eos::annotation-get-inst (annotation-type device-type)
499 ;; Get the primary instantiator for ANNOTATION-TYPE on DEVICE-TYPE
500 (interactive)
501 (let ((found (assoc (cons annotation-type device-type)
502 eos::alist-annotation-inst)))
503 (if found
504 (cdr found)
505 nil)))
506
507 (defun eos::annotation-get-inst-alt (annotation-type device-type)
508 ;; Get the alternate instantiator for ANNOTATION-TYPE on DEVICE-TYPE
509 (interactive)
510 (let ((found (assoc (cons annotation-type device-type)
511 eos::alist-annotation-inst-alt)))
512 (if found
513 (cdr found)
514 nil)))
515
516 (defun eos::annotation-get-face (annotation-type device-type)
517 ;; Get the face for ANNOTATION-TYPE on DEVICE-TYPE
518 (interactive)
519 (let ((found (assoc (cons annotation-type device-type)
520 eos::alist-annotation-face))
521 )
522 (if found
523 (cdr found)
524 nil
525 ))
526 )
527
528
529 (defun eos::common-startup () )
530 ;;
531
532
533 (provide 'eos-common)