cgit.sxemacs.org Git - packages/blob - xemacs-packages/ilisp/ilisp-out.el

   1 ;;; -*- Mode: Emacs-Lisp -*-
   2
   3 ;;; ilisp-out.el --
   4 ;;; ILISP output, including a popper replacement.
   5 ;;;
   6 ;;; This file is part of ILISP.
   7 ;;; Please refer to the file COPYING for copyrights and licensing
   8 ;;; information.
   9 ;;; Please refer to the file ACKNOWLEGDEMENTS for an (incomplete) list
  10 ;;; of present and past contributors.
  11 ;;;
  12 ;;; $Id: ilisp-out.el,v 1.5 2002-06-03 23:37:02 wbd Exp $
  13
  14 ;;; Old history log.
  15 ;;;
  16 ;;; 2000-03-02: Martin Atzmueller: general rewrite to support
  17 ;;; a general interface for multiple different output-frames.
  18
  19
  20 (defvar ilisp-*icon-file* "/pictures/ilisp-icon.bmp")
  21
  22 (defun ilisp-find-ilisp-icon ()
  23   (if (and ilisp-*icon-file*
  24            (file-exists-p (concat ilisp-*directory* ilisp-*icon-file*)))
  25       (concat ilisp-*directory* ilisp-*icon-file*)
  26     t))
  27
  28 (defun ilisp-make-output-frame (name)
  29   (when (and window-system ilisp-*use-frame-for-output*)
  30     (let ((new-frame
  31            (make-frame `((name . ,name)
  32                          (minibuffer . nil)
  33                          (visibility . nil)
  34                          (unsplittable . t)
  35                          (menu-bar-lines . 0)
  36                          ;; Use of icon-type is currently disabled due to a bug
  37                          ;; in at least Emacs 21.1 running on Windows.
  38                          ;; (icon-type . ,(ilisp-find-ilisp-icon))
  39                          )))
  40            )
  41       (when (eq +ilisp-emacs-version-id+ 'xemacs)
  42         (set-frame-properties new-frame '(default-toolbar-visible-p nil
  43                                           default-gutter-visible-p nil
  44                                           menubar-visible-p nil
  45                                           has-modeline-p t))
  46         )
  47       new-frame)))
  48
  49
  50 (defvar ilisp-display-output-function 'ilisp-display-output-default
  51   "The name of a function to display all ilisp output.
  52 The function gets a single argument, a string.")
  53
  54
  55 (defvar ilisp-*last-ilisp-output-sink* nil
  56   "Last buffer displayed.
  57 This is needed for 'ilisp-scroll-output', and 'ilisp-bury-output'")
  58
  59
  60
  61
  62 ;;; ilisp-output-sink --
  63 ;;; Datastructure for a output sink that points to its
  64 ;;; output-{buffers|frames|windows}
  65
  66 (defstruct ilisp-output-sink
  67   (buffer nil)
  68   (frame nil)
  69   (frame-name nil)
  70   (mode nil)
  71   (modeline nil)
  72   (set-modeline-p nil)
  73   (major-mode-def nil)
  74   (window-min-height nil)
  75   (window-max-height nil)
  76   (frame-min-height nil)
  77   (frame-min-width nil))
  78
  79
  80 ;;; general ilisp-output
  81
  82 (defvar ilisp-output-mode nil
  83   "If T, then we are in the ilisp-output minor mode.")
  84
  85 ;; Minor mode (just to get a pretty mode line).
  86
  87 (defvar ilisp-output-mode-line nil)
  88
  89
  90 (make-variable-buffer-local 'ilisp-output-mode)
  91
  92 (or (assq 'ilisp-output-mode minor-mode-alist)
  93     (setq minor-mode-alist
  94           (cons '(ilisp-output-mode ilisp-output-mode-line) minor-mode-alist)))
  95
  96
  97 ;;; ilisp-output
  98 ;;; ilisp-output is the default for all commands
  99
 100 (defvar ilisp-output nil "Output for general ILISP-output")
 101
 102 (setq ilisp-output
 103       (make-ilisp-output-sink
 104        :buffer          " *Output*"
 105        :major-mode-def      'lisp-mode  ; The major mode for the
 106                                         ; typeout window.
 107        :frame nil
 108        ;; Cached frame for ILISP output. If no window system is
 109        ;; 'running' then the value of this is nil.
 110        :frame-name "ILISP Output"
 111        :modeline 'ilisp-output-mode-line
 112        :set-modeline-p t
 113        :mode 'ilisp-output-mode
 114        :window-min-height 2             ; The minimum height of the
 115                                         ; typeout window
 116        :window-max-height 25            ; The maximum height of the
 117                                         ; typeout window
 118        :frame-min-height 5              ; Rows
 119        :frame-min-width 70              ; Columns
 120        ))
 121
 122
 123 ;;; arglist-output
 124
 125 (defvar ilisp-arglist-output nil "Output sink for Arglist messages.")
 126
 127 (if ilisp-*use-frame-for-arglist-output-p*
 128     (progn
 129       ;; if seperate output for arglist enabled, then use it!
 130       (setq ilisp-arglist-output
 131             (make-ilisp-output-sink
 132              :buffer " *Arglist-Output*"
 133              :major-mode-def 'lisp-mode ; The major mode for the
 134                                         ; typeout window.
 135              :frame nil
 136              ;; Cached frame for ILISP output. If no window system is
 137              ;; 'running' then the value of this is nil.
 138              :frame-name "ILISP Arglist Output"
 139              :modeline nil
 140              :set-modeline-p nil
 141              :mode 'ilisp-output-mode
 142              :window-min-height 2       ; The minimum height of the
 143                                         ; typeout window
 144              :window-max-height 25      ; The maximum height of the
 145                                         ; typeout window
 146              :frame-min-height 5        ; Rows
 147              :frame-min-width 70        ; Columns
 148              ))
 149       (defvar ilisp-arglist-output-mode nil
 150         "If T, then we are in the ilisp-arglist-output minor mode.")
 151
 152       (make-variable-buffer-local 'ilisp-arglist-output-mode)
 153
 154       (or (assq 'ilisp-arglist-output-mode minor-mode-alist)
 155           (setq minor-mode-alist
 156                 (cons '(ilisp-arglist-output-mode
 157                         ilisp-arglist-output-mode-line)
 158                        minor-mode-alist))))
 159   ;; Otherwise use default
 160   (setq ilisp-arglist-output ilisp-output))
 161
 162
 163 ;;; ilisp-*command-to-ilisp-output-sink-table* --
 164 ;;; Actually implemented as an a-list.
 165
 166 (defvar ilisp-*command-to-ilisp-output-sink-table* ()
 167   "An association table between 'commands and 'output sinks.
 168 It is used to determine where the output of a 'command' should go.")
 169
 170
 171 ;;; Accessor functions for
 172 ;;; 'ilisp-*command-to-ilisp-output-sink-table*'.
 173
 174 (defun* ilisp-get-sink-for-command (command &optional (default ilisp-output))
 175   (let ((result (assoc* command ilisp-*command-to-ilisp-output-sink-table*
 176                        :test #'eq)))
 177     (if result
 178         (rest result)
 179       default)))
 180
 181
 182 (defun* ilisp-set-sink-for-command (command output-sink)
 183   (setf ilisp-*command-to-ilisp-output-sink-table*
 184         (acons command output-sink
 185                ilisp-*command-to-ilisp-output-sink-table*)))
 186
 187
 188 (ilisp-set-sink-for-command 'arglist-lisp
 189                             ilisp-arglist-output)
 190
 191 (ilisp-set-sink-for-command 'ilisp-arglist-message-lisp-space
 192                             ilisp-arglist-output)
 193
 194
 195 ;;; Output buffer functions.
 196
 197 (defun ilisp-output-buffer (ilisp-output-sink &optional create-p)
 198   "Displays the sink's buffer.
 199 Sets the corresponding modeline if the 'set-modeline-p' slot is T for
 200 sink."
 201   (let ((buffer
 202          (if create-p
 203              (get-buffer-create (ilisp-output-sink-buffer ilisp-output-sink))
 204            (get-buffer (ilisp-output-sink-buffer ilisp-output-sink))))
 205         (modeline (ilisp-output-sink-modeline ilisp-output-sink))
 206         (set-modeline-p (ilisp-output-sink-set-modeline-p ilisp-output-sink))
 207         )
 208     (setq ilisp-*last-ilisp-output-sink* ilisp-output-sink)
 209     ;; save ilisp-output-sink for scrolling and burying
 210     (unless (and (boundp modeline) (symbol-value modeline))
 211       (when set-modeline-p
 212         (setf (symbol-value modeline)
 213               (list (format " %s bury, %s scroll"
 214                             (ilisp-where-is 'ilisp-bury-output)
 215                             (ilisp-where-is 'ilisp-scroll-output))))))
 216     buffer))
 217
 218 (defun ilisp-output-window (ilisp-output-sink)
 219   "Gets the Output-Window for sink's buffer."
 220   (let ((buffer (get-buffer (ilisp-output-sink-buffer ilisp-output-sink))))
 221     (when buffer
 222       (get-buffer-window buffer t))))
 223
 224
 225 ;;; Popper replacement
 226
 227 ;;; ilisp-bury-output --
 228 ;;;
 229 ;;; 19991220 Marco Antoniotti
 230 ;;; Changed the function to take care of the output frame.
 231
 232 (defun* ilisp-bury-output (&optional (pilisp-output-sink nil))
 233   "Delete the typeout window, with sink's buffer, if any"
 234   (interactive)
 235   (let* ((ilisp-output-sink (or pilisp-output-sink
 236                                 ilisp-*last-ilisp-output-sink*))
 237          (buffer (ilisp-output-buffer ilisp-output-sink))
 238          (window (and buffer (get-buffer-window buffer t)))
 239          (frame (ilisp-output-sink-frame ilisp-output-sink)))
 240     (when buffer
 241       (with-current-buffer buffer
 242         (erase-buffer))
 243       (bury-buffer buffer))
 244     (if frame
 245       (when (not (eql this-command
 246                       'ilisp-arglist-message-lisp-space))
 247         (ilisp-delete-message-frame ilisp-output-sink))
 248       (when window
 249         (ilisp-delete-window window)))))
 250
 251
 252 (defun ilisp-delete-window (window)
 253   "Delete a window with minimal redisplay."
 254   (let ((height (window-height window))
 255         (lower-window (ilisp-find-lower-window window)))
 256     (delete-window window)
 257     (when (and lower-window
 258                (not (eq lower-window window)))
 259       (let ((old-window (selected-window)))
 260         (save-excursion
 261           (select-window lower-window)
 262           (set-buffer (window-buffer))
 263           (goto-char (window-start))
 264           (vertical-motion (- height))
 265           (set-window-start lower-window (point)))
 266         (select-window old-window)))))
 267
 268
 269 (defun ilisp-scroll-output (&optional lines)
 270   "Scroll the typeout-window, if any."
 271   (interactive "P")
 272   (let* ((ilisp-output-sink ilisp-*last-ilisp-output-sink*)
 273          (buffer (ilisp-output-buffer ilisp-output-sink))
 274          (window (and buffer (get-buffer-window buffer t)))
 275          (old-window (selected-window)))
 276     (when window
 277       (unwind-protect
 278           (progn
 279             (select-window window)
 280             (set-buffer buffer)
 281             ;; 19990806 Martin Atzmueller
 282             ;; (scroll-up lines)
 283             (let ((scroll-in-place nil))
 284               (scroll-up lines)))
 285         (select-window old-window)))))
 286
 287
 288 (defun ilisp-grow-output (&optional n)
 289   "Grow the typeout window by ARG (default 1) lines."
 290   (interactive "p")
 291   (let* ((buffer (ilisp-output-buffer ilisp-output))
 292          (window (and buffer (get-buffer-window buffer t)))
 293          (old-window (selected-window)))
 294     (when window
 295       (unwind-protect
 296           (progn
 297             (select-window window)
 298             (enlarge-window n))
 299         (when (ilisp-window-live-p old-window)
 300           (select-window old-window))))))
 301
 302
 303 (defun ilisp-trim-blank-lines ()
 304   ;; Delete leading blank lines
 305   (goto-char (point-min))
 306   (when (looking-at "\n+") (replace-match ""))
 307   ;; Delete trailing blank lines
 308   (goto-char (point-max))
 309   (skip-chars-backward "\n")
 310   (when (< (point) (point-max))
 311     (delete-region (1+ (point)) (point-max))))
 312
 313 (defun ilisp-write-string-to-buffer (ilisp-output-sink string)
 314   (let ((buffer (ilisp-output-buffer ilisp-output-sink t)))
 315     (save-excursion
 316       (set-buffer buffer)
 317       (let ((buffer-read-only nil))
 318       ;; Maybe an option to keep the old output?
 319         (erase-buffer))
 320       ;; New: select mode for the output buffer.
 321       (unless (eq major-mode
 322                   (ilisp-output-sink-major-mode-def ilisp-output-sink))
 323         (funcall (ilisp-output-sink-major-mode-def ilisp-output-sink)))
 324       (setf (symbol-value (ilisp-output-sink-mode ilisp-output-sink)) t)
 325       (let ((buffer-read-only nil))
 326       (princ string buffer)
 327       (ilisp-trim-blank-lines)
 328         (goto-char (point-min))))))
 329
 330
 331 (defun ilisp-desired-height (ilisp-output-sink windowp)
 332   (let ((height
 333          (cond ((not windowp)
 334                 (ilisp-needed-buffer-height
 335                  (ilisp-output-sink-buffer ilisp-output-sink)))
 336                (windowp
 337                 (ilisp-needed-window-height
 338                  (get-buffer-window
 339                   (ilisp-output-sink-buffer ilisp-output-sink) t))))))
 340     (max window-min-height
 341          (min (ilisp-output-sink-window-max-height ilisp-output-sink)
 342               (max (ilisp-output-sink-window-min-height ilisp-output-sink)
 343                    height)))))
 344
 345
 346 ;; A first guess at the height needed to display this buffer.
 347 (defun ilisp-needed-buffer-height (buffer)
 348   (save-excursion
 349     (set-buffer buffer)
 350     (1+ (count-lines (point-min) (point-max)))))
 351
 352
 353 ;; The height this window must be to display its entire buffer.
 354 (defun ilisp-needed-window-height (window)
 355   (save-window-excursion
 356     (select-window window)
 357     (save-excursion
 358       (set-buffer (window-buffer))
 359       ;; 19990806 Marti Atzmueller
 360       ;; Changed 2 to 3 just below.
 361       (+ 3 (save-excursion
 362              (goto-char (point-min))
 363              ;; Any upper bound on the height of an emacs window will
 364              ;; do here.  How about 1000.
 365              (vertical-motion 1000))))))
 366
 367
 368 (defun ilisp-shrink-wrap-window (window ilisp-output-sink)
 369   (let ((previously-selected-window (selected-window))
 370         (buffer (window-buffer window)))
 371
 372     (select-window window)
 373     (let* ((current-height (window-height window))
 374            (desired-height (ilisp-desired-height ilisp-output-sink t))
 375            (delta (- desired-height current-height)))
 376       (enlarge-window delta)
 377       (set-buffer buffer)
 378       (goto-char (point-min))
 379
 380       ;; Now repair damage to the window below us, if it still exists.
 381       (let ((lower-window (ilisp-find-lower-window window)))
 382         (when lower-window
 383           (select-window lower-window)
 384           (let ((old-point (point)))
 385             (goto-char (window-start))
 386             (vertical-motion delta)
 387             (set-window-start lower-window (point))
 388             (goto-char old-point)
 389             (when (not (pos-visible-in-window-p old-point))
 390               (recenter 0)))))
 391       ;; If there was no lower window, then we ought to preserve
 392       ;; the start of the window above us, if any.
 393
 394       (when (ilisp-window-live-p previously-selected-window)
 395         (select-window previously-selected-window)))))
 396
 397
 398 ;;; ilisp-shrink-wrap-window-and-frame --
 399 ;;; I need this one to change the also the frame size.
 400
 401 (defun ilisp-shrink-wrap-window-and-frame (window ilisp-output-sink)
 402   (let ((previously-selected-window (selected-window))
 403         (buffer (window-buffer window))
 404         (frame (window-frame window)))
 405     (select-window window)
 406     (let* ((current-height (window-height window))
 407            (desired-height (ilisp-desired-height ilisp-output-sink t))
 408            (delta (- desired-height current-height))
 409            (frame-desired-height
 410             (max (ilisp-output-sink-frame-min-height ilisp-output-sink)
 411                  desired-height)))
 412       (set-buffer buffer)
 413       (goto-char (point-min))
 414
 415       ;; Now repair damage to the window below us, if it still exists.
 416       ;;
 417       ;; 19991220 Marco Antoniotti
 418       ;; This is probably useless, since the '*ilisp-message-frame*'
 419       ;; only has a single window.
 420       (let ((lower-window (ilisp-find-lower-window window)))
 421         (when lower-window
 422           (select-window lower-window)
 423           (let ((old-point (point)))
 424             (goto-char (window-start))
 425             (vertical-motion delta)
 426             (set-window-start lower-window (point))
 427             (goto-char old-point)
 428             (unless (pos-visible-in-window-p old-point)
 429               (recenter 0)))))
 430
 431       ;; If there was no lower window, then we ought to preserve
 432       ;; the start of the window above us, if any.
 433
 434       (when (ilisp-window-live-p previously-selected-window)
 435         (select-window previously-selected-window))
 436
 437       ;; Finally shrink the frame.
 438       (set-frame-size frame
 439                       (ilisp-output-sink-frame-min-width ilisp-output-sink)
 440                       frame-desired-height))))
 441
 442
 443 (defun ilisp-window-live-p (window)
 444   (window-live-p window))
 445
 446 ;;; This old implementation ignores windows in other frames,
 447 ;;; which makes a lot of trouble if the ILISP buffer is shown in
 448 ;;; a single dedicated window in a frame.
 449
 450 ;;(defun ilisp-window-live-p (window)
 451 ;;  (let* ((initial-window (selected-window))
 452 ;;       (win initial-window)
 453 ;;       (found nil))
 454 ;;    (while win
 455 ;;      (cond ((eq window win)
 456 ;;           (setq found t
 457 ;;                 win nil))
 458 ;;          (t
 459 ;;           (setq win (next-window win 'no))
 460 ;;           (if (eq win initial-window)
 461 ;;               (setq win nil)))))
 462 ;;    found))
 463
 464
 465 ;; XEmacs change -- window-edges is gone in 19.12+ so use
 466 ;; next-vertical-window instead.
 467
 468 (defun ilisp-find-lower-window (window)
 469   "Find the window directly below us, if any.
 470 This is probably the window from which enlarge-window would steal lines."
 471   (if (or (not (string-match "XEmacs" emacs-version))
 472           (and (= emacs-major-version 19)
 473                (< emacs-minor-version 12)))
 474       (let* ((bottom (nth 3 (window-edges window)))
 475              (window* nil)
 476              (win window))
 477         (while (not (eq (setq win (next-window win 'no))
 478                         window))
 479           (if (and (= (nth 1 (window-edges win))
 480                       bottom)
 481                    (null window*))
 482               (setq window* win)))
 483         window*)
 484     (next-vertical-window window)))
 485
 486
 487 ;;; ilisp-find-top-left-most-window --
 488 ;;;
 489 ;;; Notes:
 490 ;;; 19980101
 491 ;;; XEmacs change -- There is now a primitive to do this.
 492 ;;;
 493 ;;; 19991219 Marco Antoniotti
 494 ;;; It would seem that also Emacs 20.xx has a built in function for
 495 ;;; doing this (either frame-first-window or frame-top-window at least
 496 ;;; as of 20.4).  However, I leave it as it is just for safety and
 497 ;;; history.  The only changes I make are to make it a DEFUN* with an
 498 ;;; optional parameter and to change the way the local variable
 499 ;;; 'window*' is bound.
 500
 501 (defun* ilisp-find-top-left-most-window (&optional (frame (selected-frame)))
 502   "Return the leftmost topmost window on the current screen."
 503   (if (or (not (string-match "XEmacs" emacs-version))
 504           (and (= emacs-major-version 19)
 505                (< emacs-minor-version 12)))
 506
 507       (frame-first-window frame)
 508       (frame-highest-window frame 0)))
 509
 510
 511 ; (defun* ilisp-find-top-left-most-window (&optional (frame (selected-frame)))
 512 ;   "Return the leftmost topmost window on the current screen."
 513 ;   (if (or (not (string-match "XEmacs" emacs-version))
 514 ;         (and (= emacs-major-version 19)
 515 ;              (< emacs-minor-version 12)))
 516
 517 ;       (let* ((window* (frame-selected-window frame))
 518 ;            ;; (window* (selected-window))
 519 ;            (edges* (window-edges window*))
 520 ;            (win nil)
 521 ;            (edges nil)
 522 ;            (start-window window*))
 523 ;       (message ">>> window* %s %s %s." window* start-window frame)
 524 ;       (while (not (eq (setq win (next-window win 'no))
 525 ;                       start-window))
 526 ;         (message ">>>>>> win %s." win)
 527 ;         (setq edges (window-edges win))
 528 ;         (if (or (< (car (cdr edges)) (car (cdr edges*))) ; top
 529 ;                 (and (= (car (cdr edges)) (car (cdr edges*)))
 530 ;                      (< (car edges) (car edges*)))) ; left
 531 ;             (setq window* win
 532 ;                   edges* edges)))
 533 ;       (message ">>> about to return window*.")
 534 ;       window*)
 535 ;       (frame-highest-window frame 0)))
 536
 537
 538 ;; This causes the typeout window to be created by splitting or using the
 539 ;; top-left-most window on the current screen.  That is different behavior
 540 ;; from the popper, which always split the current window.
 541 (defun ilisp-window-to-use-for-typeout ()
 542   (let ((window (ilisp-find-top-left-most-window)))
 543     (while (window-dedicated-p window)
 544       (setq window (next-window window nil 'visible)))
 545     window))
 546
 547
 548 (defun ilisp-display-buffer-in-typeout-window (ilisp-output-sink)
 549   "Display buffer in a window at the top of the screen."
 550   (let* ((buffer (ilisp-output-sink-buffer ilisp-output-sink))
 551          (window (get-buffer-window buffer t)))
 552
 553     ;; If buffer already has a window, keep it.
 554     (if (null window)
 555         ;; Otherwise, find a window to split.
 556         (let* ((top-window (ilisp-window-to-use-for-typeout))
 557                (new-window nil)
 558                (previously-selected-window (selected-window))
 559                (desired-height (ilisp-desired-height ilisp-output-sink nil)))
 560
 561           ;; The new window is always the lower one.
 562           (select-window top-window)
 563
 564           ;; Always minimize redisplay (except in emacs 18).
 565           (let ((split-window-keep-point nil))
 566             ;; If the top window is not big enough to split, commandeer it
 567             ;; entirely.
 568             (if (> desired-height (- (window-height) window-min-height))
 569                 (setq new-window top-window)
 570               (setq new-window (split-window-vertically desired-height))))
 571
 572           (set-window-buffer top-window buffer)
 573           ;; The height is already correct, unless there was line wrapping.
 574           ;; Account for that here.
 575           (ilisp-shrink-wrap-window top-window ilisp-output-sink)
 576
 577           ;; Restore selected window.
 578           (if (eq previously-selected-window top-window)
 579               (select-window new-window)
 580               (select-window previously-selected-window)))
 581
 582       ;; Simply shrink-wrap an existing window.
 583       (ilisp-shrink-wrap-window window ilisp-output-sink))))
 584
 585
 586 ;;; ilisp-get-message-frame --
 587 ;;;
 588 ;;; 19991219 Marco Antoniotti
 589 ;;; Utility function.  If we get the error it is because the function
 590 ;;; has been called in an improper context.
 591 ;;; This should not really happen, since this function is called only
 592 ;;; within 'ilisp-display-buffer-in-typeout-frame', which is called
 593 ;;; only when a window system is running.
 594
 595 (defun ilisp-get-message-frame (ilisp-output-sink)
 596   (let* ((frame (ilisp-output-sink-frame ilisp-output-sink))
 597          (f (or (and frame (frame-live-p frame) frame)
 598                 (setf (ilisp-output-sink-frame ilisp-output-sink)
 599                       (ilisp-make-output-frame
 600                        (ilisp-output-sink-frame-name ilisp-output-sink))))))
 601     (if f
 602         f
 603       (error "ILISP: cannot build the ILISP output frame."))))
 604
 605 (defun ilisp-delete-message-frame (ilisp-output-sink)
 606   (let ((frame (ilisp-output-sink-frame ilisp-output-sink)))
 607     (when frame
 608       (when (frame-live-p frame)
 609         (delete-frame frame))
 610       (setf (ilisp-output-sink-frame ilisp-output-sink) nil))))
 611
 612 (defun ilisp-display-buffer-in-typeout-area (ilisp-output-sink)
 613   (let ((buffer (ilisp-output-sink-buffer ilisp-output-sink)))
 614     (cond ((and window-system ilisp-*use-frame-for-output*)
 615            (message "See ILISP Message Frame.")
 616            (ilisp-display-buffer-in-typeout-frame ilisp-output-sink))
 617           (t
 618            (message "See above.")
 619            (ilisp-display-buffer-in-typeout-window ilisp-output-sink)))))
 620
 621
 622 (defun ilisp-display-buffer-in-typeout-frame (ilisp-output-sink)
 623   "Display buffer in a special ILISP frame."
 624   (let* ((output-frame (ilisp-get-message-frame ilisp-output-sink))
 625          (buffer (ilisp-output-sink-buffer ilisp-output-sink))
 626          (buffer-window (get-buffer-window buffer))
 627          (previous-output-window (selected-window)))
 628     (if (null buffer-window)
 629         ;; No window is associated to the buffer.
 630         (unwind-protect
 631             (let* ((output-frame-window
 632                     (ilisp-find-top-left-most-window output-frame))
 633                    (desired-height
 634                     (ilisp-desired-height ilisp-output-sink nil)))
 635               (select-window output-frame-window)
 636               (set-window-buffer output-frame-window buffer)
 637               (ilisp-shrink-wrap-window-and-frame output-frame-window
 638                                                   ilisp-output-sink)
 639               (unless (frame-visible-p output-frame)
 640                 (make-frame-visible output-frame))
 641               (raise-frame output-frame))
 642           (progn
 643             (select-window previous-output-window)
 644             (select-frame (window-frame (selected-window)))))
 645       ;; else
 646       (progn
 647         (ilisp-shrink-wrap-window-and-frame buffer-window ilisp-output-sink)
 648         ;; Let's try to display the buffer window in the output frame.
 649         (unless (and (eq (window-frame buffer-window)
 650                          output-frame)
 651                      (not (frame-visible-p output-frame)))
 652           (make-frame-visible output-frame))
 653         (raise-frame output-frame)))))
 654
 655
 656
 657 ;;; lisp-display-output - general output function
 658
 659 (defun lisp-display-output (output)
 660   "Displays OUTPUT in the appropriate place.
 661 This calls the function given by the value of ILISP-DISPLAY-OUTPUT-FUNCTION in
 662 order to do the real work."
 663   (when output
 664     ;; Bugcheck
 665     (unless (stringp output)
 666       (error "ILISP: not a string in lisp-display-output"))
 667
 668     (when (ilisp-value 'comint-errorp t)
 669       (setq output (funcall (ilisp-value 'ilisp-error-filter) output)))
 670     (let ((ilisp-output-sink
 671            (ilisp-get-sink-for-command this-command ilisp-output)))
 672       (funcall ilisp-display-output-function output ilisp-output-sink))))
 673
 674
 675 ;;; Various functions to which to bind ilisp-display-output-function.
 676
 677 ;;; ilisp-display-output-default --
 678 ;;; This function does what ilisp used to do, except that we use the
 679 ;;; new "popper".
 680 ;;;
 681 ;;; Notes:
 682 ;;; 2000-01-22 Martin Atzmueller: force prompt in inferior-lisp-buffer
 683 ;;; after an error.
 684
 685 ;;; 19990806 Martin Atzmueller
 686 ;;; Added check for COMINT-ERRORP.
 687
 688 (defun ilisp-force-output-after-error (ilisp-output-sink)
 689   "Force the ilisp buffer to display the prompt."
 690   "Display output in the ilisp buffer"
 691   (let ((buffer (current-buffer))
 692         (window (selected-window)))
 693     ;; we want _exactly_ one prompt
 694     ;; this means this function has only to be performed once.
 695     ;; so check for ilisp-last-message!
 696     (if ilisp-last-message
 697         (unwind-protect
 698             (progn
 699               (lisp-pop-to-buffer (ilisp-buffer) ilisp-output-sink)
 700               (if (not (eq (current-buffer) buffer))
 701                   (setq ilisp-last-buffer buffer))
 702               (comint-insert
 703                (concat
 704                 (if ilisp-last-message
 705                     (concat ";;; " ilisp-last-message "\n"))
 706                 "\n"
 707                 ilisp-last-prompt))
 708               (setq ilisp-last-message nil))
 709           (if (window-point window)
 710               (progn (select-window window)
 711                      (set-buffer buffer)))))))
 712
 713
 714 (defun ilisp-display-output-default (output ilisp-output-sink)
 715   "Displays 'output' depending on the value of 'lisp-no-popper'.
 716 Dispatch on the value of 'lisp-no-popper':
 717  'lisp-no-popper' = nil:  displays 'output' in a typeout window.
 718  'lisp-no-popper' = t:    displays 'output' in the ilisp buffer
 719  otherwise:               displays one-line 'output' in the echo area,
 720                           multiline output in the ilisp buffer."
 721   (cond ((null lisp-no-popper)
 722          (ilisp-display-output-in-typeout-window output ilisp-output-sink))
 723
 724         ((eq lisp-no-popper t)
 725          (ilisp-display-output-in-lisp-listener output ilisp-output-sink))
 726
 727         (t
 728          (ilisp-display-output-adaptively output ilisp-output-sink)))
 729
 730   (when (or (ilisp-value 'comint-errorp t)
 731             (string-match (ilisp-value 'ilisp-error-regexp t) output))
 732
 733     ;; display error-msg too, if not already in lisp-listener
 734     (unless (eq lisp-no-popper t)
 735       (ilisp-display-output-in-lisp-listener output ilisp-output-sink))
 736     ;; force output, e.g. for <prompt>
 737     (ilisp-force-output-after-error ilisp-output-sink)))
 738
 739
 740 ;; This is the display function I like to use.
 741
 742 ;; Another trick which might be useful is to dispatch on the value
 743 ;; this-command here, to make output from different ilisp commands
 744 ;; go to different places.
 745
 746 (defun ilisp-display-output-adaptively (output ilisp-output-sink)
 747   "Display one-liners in the echo area, others in the typeout window"
 748   (cond ((or (string-match "\n" output)
 749              (> (length output) (window-width (minibuffer-window))))
 750          (ilisp-display-output-in-typeout-window output ilisp-output-sink))
 751         (t
 752          (ilisp-display-output-in-echo-area output ilisp-output-sink))))
 753
 754
 755 (defun ilisp-display-output-in-typeout-window (output ilisp-output-sink)
 756   "Display output in a shrink-wrapped window at the top of the screen."
 757   (let ((old-buffer (current-buffer))
 758         (old-window (selected-window))
 759         (buffer (ilisp-output-buffer ilisp-output-sink t)))
 760     (ilisp-write-string-to-buffer ilisp-output-sink output)
 761     (ilisp-display-buffer-in-typeout-area ilisp-output-sink)
 762
 763     ;; Martin Atzmueller 2000-01-27
 764     ;; this-command trick:
 765     ;; if this-command is ilisp-message-lisp-space, switch back!
 766     (if (and (eql this-command 'ilisp-arglist-message-lisp-space)
 767              ilisp-*arglist-message-switch-back-p*
 768              (not (member (buffer-name old-buffer) special-display-buffer-names)))
 769         (progn
 770           (raise-frame (window-frame old-window))
 771           (switch-to-buffer old-buffer)))))
 772
 773 (defun ilisp-display-output-in-echo-area (output ilisp-output-sink)
 774   "Display output as a message in the echo area."
 775   ;; First clear any existing typeout so as to not confuse the user.
 776   (or (eq (selected-window)
 777           (get-buffer-window (ilisp-output-sink-buffer ilisp-output-sink) t))
 778       (ilisp-bury-output ilisp-output-sink))
 779
 780   ;; v5.7: Patch suggested by hunter@work.nlm.nih.gov (Larry Hunter)
 781   ;; If output contains '%', 'message' loses.
 782   ;; (message (ilisp-quote-%s output))
 783   ;; An alternative here could be '(princ output)', as suggested by
 784   ;; Christopher Hoover <ch@lks.csi.com>
 785   ;; (princ output)
 786
 787   ;; v5.7b: Patch suggested by fujieda@jaist.ac.jp (Kazuhiro Fujieda)
 788   ;; Best one for FSF Emacs 19.2[89].
 789   (message "%s" output))
 790
 791
 792 ;;; ilisp-quote-%s --
 793 ;;; Patch suggested by hunter@work.nlm.nih.gov (Larry Hunter)
 794
 795 (defun ilisp-quote-%s (string)
 796   "Quote all the occurences of ?% in STRING in an ELisp fashion."
 797   (mapconcat '(lambda (char)
 798                 (if (char-equal char ?%)
 799                     "%%"
 800                   (char-to-string char)))
 801              string ""))
 802
 803
 804 (defun ilisp-display-output-in-temp-buffer (output)
 805   (with-output-to-temp-buffer ilisp-output-buffer
 806     (princ output)))
 807
 808
 809 (defun ilisp-display-output-in-lisp-listener (output ilisp-output-sink)
 810   "Display output in the ilisp buffer"
 811   (let ((buffer (current-buffer))
 812         (window (selected-window)))
 813     (unwind-protect
 814         (progn
 815           (lisp-pop-to-buffer (ilisp-buffer) ilisp-output-sink)
 816           (unless (eq (current-buffer) buffer)
 817             (setq ilisp-last-buffer buffer))
 818           (comint-insert
 819            (concat
 820             (when ilisp-last-message
 821               (concat ";;; " ilisp-last-message "\n"))
 822             (comint-remove-whitespace output)
 823             "\n"
 824             ilisp-last-prompt))
 825           (setq ilisp-last-message nil))
 826       (when (window-point window)
 827         (select-window window)
 828         (set-buffer buffer)))))
 829
 830
 831 (defun lisp-pop-to-buffer (pbuffer &optional ilisp-output-sink set-input-focus-p)
 832   "Like pop-to-buffer, but select a screen that buffer was shown in.
 833 ilisp-output-sink is the last ilisp-output-sink visited/active or nil
 834 if this is not relevant."
 835   (let* ((buffer (or pbuffer
 836                      (when ilisp-output-sink
 837                        (ilisp-output-sink-buffer ilisp-output-sink))))
 838          (window (if ilisp-epoch-running
 839                      (epoch::get-buffer-window buffer)
 840                    (get-buffer-window buffer t)))
 841          (frame  (when window (window-frame window))))
 842     (cond ((not window)
 843            (when ilisp-output-sink
 844              (ilisp-bury-output ilisp-output-sink)) ; is this neccessary?
 845            (pop-to-buffer buffer))
 846           (set-input-focus-p
 847            (if (fboundp 'select-frame-set-input-focus)
 848                (select-frame-set-input-focus frame)
 849              (raise-frame frame)
 850              (select-frame frame)
 851              (focus-frame frame))
 852            (select-window window))
 853           (t (when (or (memq (frame-visible-p frame) '(nil icon))
 854                        (when (fboundp 'frame-iconified-p)
 855                          (frame-iconified-p frame)))
 856                (raise-frame frame)
 857                (raise-frame (selected-frame)))
 858              (select-frame frame)
 859              (select-window window)))
 860     (set-buffer buffer)))
 861
 862
 863 (defun switch-to-lisp (eob-p &optional ilisp-only)
 864   "If in an ILISP buffer, switch to the last non-ILISP buffer visited.
 865 Otherwise, switch to the current ILISP buffer.  With argument,
 866 positions cursor at end of buffer.  If you don't want to split
 867 windows, set pop-up-windows to NIL."
 868   (interactive "P")
 869   (if (and (not ilisp-only) ilisp-last-buffer
 870            (memq major-mode ilisp-modes))
 871       (lisp-pop-to-buffer ilisp-last-buffer nil t)
 872     (unless (memq major-mode ilisp-modes)
 873       (setq ilisp-last-buffer (current-buffer)))
 874     (lisp-pop-to-buffer (ilisp-buffer) nil t)
 875     (when eob-p
 876       (goto-char (point-max)))))
 877
 878 ;;; end of file -- ilisp-out.el --