;;; -*- Mode: LISP; Package: Zwei; Patch-file:T; Base: 8. -*- ;;; Base 8 because of all the zwei functions. ;;; **************************************************************** ;;; ;;; John L. Shelton ;;;ing implementation details are ;;; available on a confidential, non-disclosure basis only. These ;;; materials, including this file in particular, are trade secrets ;;; of Computer * Thought Corporation. ;;; ;;; (c) Copyright 1982 and 1983, Computer * Thought Corporation. ;;; All Rights Reserved. ;;; ;;; Reference materials: ;;; Foderaro and Sklower, The FRANZ LISP Manual, September 1981. ;;; Weinreb and Moon, LISP MACHINE MANUAL, Symbolics, July 1981. ;;; Charniak et al., 1980. Artificial Intelligence Programming. ;;; Miller, 1982. The C*T Ada Tutor: Guide to the Implementation. ;;; The following code assumes familiarity with these materials. ;;; This file contains code to enable the Ada-Mode Editor to have a ;;;menu at the top. (:ct_load ':tr18) ;Should find these on (:ct_load ':tr18b) ;Vax. (eval-when (compile load eval) (:ct_load ':unflashy)) ;;; The menu of things at the top of the editor. These are in standard ;;; menu format. In ADA MODE, we define more of them. This particular ;;; menu should be handy for anyone to use. (declare (special *editor-menu-description*)) (setq *editor-menu-description* '(("Prev Screen" :eval (com-previous-screen) :font fonts:tr18 :documentation "Move to the previous screen in this buffer") ("Go to Top" :eval (com-goto-beginning) :font fonts:tr18 :documentation "Move cursor to the beginning of the buffer.") ("Cursor Motion" :eval (com-move-menu) :font fonts:tr18 :documentation "A menu of ways to move the cursor") ("Buffer Cmds" :eval (com-buffer-menu) :font fonts:tr18 :documentation "Choose from a menu of buffer commands.") ("Expert Cmds" :eval (com-advanced-menu) :font fonts:tr18 :documentation "A menu of advanced editor commands.") ("Next Screen" :eval (com-next-screen) :font fonts:tr18 :documentation "Move to the next screen in this buffer.") ("Go to Bottom" :eval (com-goto-end) :font fonts:tr18 :documentation "Move cursor to the end of the buffer.") ("Cut & Paste" :eval (com-kill-menu) :font fonts:tr18 :documentation "Menu of ways to delete and retrieve text.") ("File Cmds" :eval (com-file-menu) :font fonts:tr18 :documentation "A menu of file operations like Find and Save." ) ("HELP" :eval (com-help-menu) :font fonts:tr18b ;Note HELP in :documentation "A menu of help facilities."))) ;different font. ;;; This is the height of the command menu for the editor. Don't fool with ;;; it, please. This is automatically updated whenever you install a top ;;; command menu. (defvar *editor-command-menu-height* 0) ;;; This special will override turning off :scroll-bar if you like. (defvar *scroll-bar-force-on* nil) ;;; Send this to THE zmacs frame; it will install the top menu for you. ;;; Creates the command menu, and makes it an inferior of the zmacs frame. ;;; The input buffers are made to be the same. After menu creation, updates ;;; the editor-command-menu-height. Deletes any previous command menu ;;; inferiors of this zmacs frame. Finally, sends 'set-edges messages to all ;;; buffer-inferiors of this frame. Note that there are TWO SETS of inferiors, ;;; in window-list and o-w-list. I am not sure why these are different, but ;;; in some circumstances, they are. Btw, window list is a list of window ;;; objects that are not true windows. You have to do (window-sheet window) ;;; to get the normal real live window. (defmethod (zmacs-frame :install-top-menu) (&aux f-left f-top f-right f-bottom) (let* ((window-list (send self ':n-editor-windows (length *zmacs-buffer-name-alist*))) (o-w-list (loop for win in (send self ':inferiors) unless (or (typep win 'tv:command-menu-pane) (typep win 'zwei:zmacs-mode-line-window)) collect win)) (menu (tv:make-window 'tv:command-menu-pane ':item-list *editor-menu-description* ':superior self ':geometry `(0. nil ,(- (tv:sheet-width mode-line-window) 2.) nil nil nil) ':io-buffer tv:io-buffer ':expose-p t))) ;; Find out the height of the newly created command menu. (multiple-value-bind (nil ecmh) (send menu ':size) (setq *editor-command-menu-height* ecmh)) ;; Don't allow user to keep scroll bar forced on. Make him deliberately ;; force it on again. (setq *scroll-bar-force-on* nil) ;; We were getting LOTS of command menus hanging around. This will ;; clean them up. (loop for inf in tv:inferiors do (if (typep inf 'tv:command-menu-pane) (setq tv:inferiors (delq inf tv:inferiors)))) (setq tv:inferiors (cons menu tv:inferiors)) ;add menu as inferior (multiple-value (f-left f-top f-right f-bottom) ;Find new size of editor (send self ':inside-edges-without-mode-line-window)) ;windows. (tv:delaying-screen-management (loop for window in window-list ;; Tell each window its new size. do (send (window-sheet window) ':set-edges f-left f-top f-right f-bottom)) (loop for window in o-w-list do (send window ':set-edges f-left f-top f-right f-bottom)) ))) (defmethod (zmacs-frame :remove-top-menu) (&aux f-left f-top f-right f-bottom) (let ((window-list (send self ':n-editor-windows (length *zmacs-buffer-name-alist*))) (o-w-list (loop for win in (send self ':inferiors) unless (or (typep win 'tv:command-menu-pane) (typep win 'zwei:zmacs-mode-line-window)) collect win))) (setq *editor-command-menu-height* 0) (loop for inf in tv:inferiors do (if (typep inf 'tv:command-menu-pane) (setq tv:inferiors (delq inf tv:inferiors)))) (multiple-value (f-left f-top f-right f-bottom) ;Find new size of editor (send self ':inside-edges-without-mode-line-window)) ;windows. (tv:delaying-screen-management (loop for window in window-list ;; Tell each window its new size. do (send (window-sheet window) ':set-edges f-left f-top f-right f-bottom)) (loop for window in o-w-list do (send window ':set-edges f-left f-top f-right f-bottom))))) ;;; This command actually INSTALLS the menu at the top of the editor screen. (defcom com-make-top-command-menu "Install command menu at top of screen. This command installs a command menu at the top of the screen. It may contain as many items as desired. It is displayed from the value of *editor-menu-description*. If you change this value, you will need to run this command again." () (let ((cur-win (window-sheet *window*))) (send (send (window-sheet *window*) ':superior) ':install-top-menu) (send cur-win ':select)) dis-all) ;;; Removes any top command menu. (defcom com-remove-top-command-menu "Removes top command menu." () (let ((cur-win (window-sheet *window*))) (send (send (window-sheet *window*) ':superior) ':remove-top-menu) (send cur-win ':select)) dis-all) (defmethod (zmacs-window-pane :scroll-bar-p) () (or (not (top-menu-active-p self)) *scroll-bar-force-on*)) ;;; This command will force the scroll bar back on, even if you have ;;; a top command menu. (defcom com-force-scroll-bar-on "Forces the scroll bar on. When you have a top command menu displayed, the scroll bar is normally turned off. This command will turn it back on." () (setq *scroll-bar-force-on* t) dis-none) ;;; This command will stop forcing the scroll bar, allowing it to ;;; behave based on the command menu. (defcom com-stop-forcing-scroll-bar "Stops forcing the scroll bar. If you have a top command menu displayed, the scroll bar will be turned off. When the top command menu goes away, you will get the scroll bar." () (setq *scroll-bar-force-on* nil) dis-none) ;;; A redefined function. This computes the size of editor windows. The ;;; quantity is designed to interface well with the size of the menu. (defmethod (zwei-frame :inside-edges-without-mode-line-window) () (values (tv:sheet-inside-left) (+ (tv:sheet-inside-top) 0. *editor-command-menu-height*) (tv:sheet-inside-right) (- (tv:sheet-inside-bottom) (tv:sheet-height mode-line-window)))) ;;; This function redefined from zmacs sources. It is used by the top level ;;; loop to process characters. We had to modify it to accept (:menu ....) ;;; blips. (defselect (process-special-command unknown-special-command) (redisplay () ;the window is presumably on our list of windows and will get redisplayed ;in the normal course of events when buffered input had been processed. nil) (must-redisplay (&rest args) (apply #'must-redisplay args) nil) (must-redisplay-interval (interval &rest args) (lexpr-funcall #'must-redisplay-other-windows interval nil args) nil) (select-window (window) (prog1 (neq window *window*) (make-window-current window))) (configuration-changed () (and (not (window-exposed-p *window*)) (dolist (w *window-list*) (and (window-exposed-p w) (make-window-current w nil)))) nil) (scroll (window nlines type) (if (eq type ':relative) (recenter-window-relative window nlines) (recenter-window window ':start (forward-line (interval-first-bp (window-interval window)) nlines t))) t) ;; Our addition to handle menu blips. Note that this assumes the third item ;; in the menu item is the thing to eval. Since WE defined the menu, this is ok. (:menu (&rest ch) (eval (cadr (memq ':eval (first ch)))) t) (:mouse (window ch *mouse-x* *mouse-y*) (decf *mouse-x* (tv:sheet-inside-left (window-sheet window))) (decf *mouse-y* (tv:sheet-inside-top (window-sheet window))) (and (memq ':record (funcall standard-input ':which-operations)) (funcall standard-input ':record ch)) (if (and (neq window *window*) ( ch #\mouse-3-1)) ;given in another window, (let ((*comtab* (if (eq *window* *mini-buffer-window*) *standard-comtab* *comtab*)) (*last-command-type* nil) ;dont confuse mouse mark thing, and *current-command-type* (*window* window) (*interval* (window-interval window))) ;temporarily act there (mini-buffer) (process-command-char ch)) (process-command-char ch)) t) ((:typeout-execute :execute) (function &rest args) (not (apply function args)))) ;;; This function had to be redefined to know about the command menu, and to ;;; not do anything nasty to it. (defmethod (zmacs-frame :update-labels) () (if ( (length tv:exposed-inferiors) 3) (dolist (w tv:exposed-inferiors) (or (eq w mode-line-window) (typep w 'tv:command-menu-pane) (funcall w ':delayed-set-label (funcall (window-interval (funcall w ':zwei-window)) ':name)))) (dolist (w tv:exposed-inferiors) (or (eq w mode-line-window) (typep w 'tv:command-menu-pane) (funcall w ':set-label nil))))) ;;; This had to be redefined to know about the command-menu, and not ;;; do anything nasty to it. (defmethod (zmacs-frame :n-editor-windows) (n &aux list) (do ((l tv:inferiors (cdr l)) (i 0 (1+ i))) ((or (null l) ( i n))) (or (eq (car l) mode-line-window) (typep (car l) 'tv:command-menu-pane) (push (funcall (car l) ':zwei-window) list))) (dotimes (i (- n (length list))) (push (funcall-self ':create-window 'zmacs-window-pane) list)) list) ;;; this function had to be redefined. (defmethod (zmacs-frame :two-editor-windows) (&optional pref &aux ws) (setq ws (sort (copylist tv:inferiors) ;make sure get two contiguous #'(lambda (w-1 w-2) (< (if (tv:sheet-exposed-p w-1) (tv:sheet-y-offset w-1) 177777) (if (tv:sheet-exposed-p w-2) (tv:sheet-y-offset w-2) 177777))))) (loop for window in ws ;splice out the command if (typep window 'tv:command-menu-pane) ;menu, if there is one. do (setq ws (delq window ws))) (and pref (let ((l (memq pref ws))) (if (loop for w in (cdr l) thereis (and (tv:sheet-exposed-p w) (neq w mode-line-window))) (setq ws l) (setq ws (loop for l on ws when (eq (cadr l) pref) return l finally (return ws)))))) (do ((l ws (cdr l)) (window) (top-window) (bottom-window)) ((null l) (values (funcall top-window ':zwei-window) (funcall-self ':create-window 'zmacs-window-pane))) (cond ((eq (setq window (car l)) mode-line-window)) ((null top-window) (setq top-window window)) (t (setq bottom-window window) (and (tv:sheet-exposed-p bottom-window) (< (tv:sheet-y-offset bottom-window) (tv:sheet-y-offset top-window)) (psetq top-window bottom-window bottom-window top-window)) (return (funcall top-window ':zwei-window) (funcall bottom-window ':zwei-window)))))) ;;; **************************************************************** ;;; MENU FUNCTIONs ;;; **************************************************************** ;;; Here are the functions called by the menu at the top of the screen. ;;; Of course, some of the functions mentioned there already exist. ;;; Those that put up new menus, though, are here. (defcom com-move-menu "A menu of motion commands. Pops up a menu of cursor moving commands." () (eval (tv:menu-choose '(("Beginning of buffer" :value (com-goto-beginning) :font fonts:tr18 :documentation "Move cursor to beginning of buffer") ("End of buffer" :value (com-goto-end) :font fonts:tr18 :documentation "Move cursor to end of buffer") ("Beginning of line" :value (com-beginning-of-line) :font fonts:tr18 :documentation "Move cursor to beginning of line") ("End of line" :value (com-end-of-line) :font fonts:tr18 :documentation "Move cursor to end of current line.") ("Previous Paragraph" :value (com-backward-paragraph) :font fonts:tr18 :documentation "Move backwards one paragraph.") ("Forward Paragraph" :value (com-forward-paragraph) :font fonts:tr18 :documentation "Move forward one paragraph") ("Previous Page" :value (com-previous-page) :font fonts:tr18 :documentation "Move to previous character in document") ("Next Page" :value (com-next-page) :font fonts:tr18 :documentation "Move to next character in document.")))) (must-redisplay *window* dis-all)) (defcom com-kill-menu "A menu of cut and paste operations." () (eval (tv:menu-choose '(("Kill Line" :value (com-kill-line) :font fonts:tr18 :documentation "Kill to end of current line, or kill current blank line") ("Kill Sentence Forward" :value (com-kill-sentence) :font fonts:tr18 :documentation "Kill to end of current sentence") ("Kill Sentence Backward" :value (com-backward-kill-sentence) :font fonts:tr18 :documentation "Kill to beginning of current sentence") ("Kill Region" :value (com-kill-region) :font fonts:tr18 :documentation "Kill currently selected region") ("" :no-select t) ("Copy Region to Kill Buffer" :value (com-save-region) :font fonts:tr18 :documentation "Place copy of current region in Kill Buffer for later retrieval") ("Append Next Kill" :value (com-append-next-kill) :font fonts:tr18 :documentation "Make next killing operation append to most recent previous kill") ("" :no-select t) ("Retrieve Killed Text" :value (com-yank) :font fonts:tr18 :documentation "Yank back recently killed text into buffer at cursor") ("Correct Yank, get previous yank" :value (com-yank-pop) :font fonts:tr18 :documentation "Kill just-yanked text, replace with older yanked text.")))) (must-redisplay *window* dis-all)) (defcom com-file-menu "A menu of file operations." () (eval (tv:menu-choose '(("Save file" :value (com-save-file) :font fonts:tr18 :documentation "Writes the current file to disk file") ("Write file to new name" :value (com-write-file) :font fonts:tr18 :documentation "Select a new name for current file, then write to disk") ("Find file" :value (com-find-file) :font fonts:tr18 :documentation "Locate disk file, place copy in new buffer with same name.") ("List Buffers" :value (com-list-buffers) :font fonts:tr18 :documentation "List all buffers in editor, allow picking with mouse.") ("List Directory" :value (com-list-files) :font fonts:tr18 :documentation "List all files in a directory/; pick file to find with mouse")))) (must-redisplay *window* dis-all)) ;;; This was changed from the original definition. It buries the current window ;;; (which is the pop-up display window) after selecting a buffer. ;(defun typeout-make-buffer-current (buffer) ; (cond ((not (memq buffer *zmacs-buffer-list*)) ; (barf "that buffer has been killed, you may not select it.")) ; ((neq *interval* (window-interval *mini-buffer-window*)) ; (make-buffer-current buffer) ; (send (tv:window-under-mouse) ':bury) ; (send (window-sheet *window*) ':select)) ; (*read-buffer-kludge* ; (*throw 'return-from-command-loop buffer)) ; (t ; (send standard-input ':untyi *last-command-char*) ; (*throw 'top-level t)))) ; DON'T NEED THIS LOSSAGE ANYMORE!.. ;;; (defcom com-advanced-menu "A menu of advanced commands." () (eval (tv:menu-choose '(("Display font" :value (com-display-font) :font fonts:tr18 :documentation "Asks for name of font, then displays all characters in that font") ("I can't think of many others" :no-select t)))) (must-redisplay *window* dis-all)) (defcom com-help-menu "A menu of help" () (eval (tv:menu-choose '(("Apropos" :value (com-apropos) :font fonts:tr18 :documentation "Find editor commands containing substring") ("Describe" :value (com-describe-command) :font fonts:tr18 :documentation "Display full documentation for a command.") ("Undo" :value (com-undo) :font fonts:tr18 :documentation "Possibly undoes last command, after asking.") ("Last 60 commands" :value (com-what-lossage) :font fonts:tr18 :documentation "Displays last 60 keystrokes")))) ) (defcom com-buffer-menu "A menu of buffer operations." () (eval (tv:menu-choose '(("Swap buffers" :value (com-select-previous-buffer) :font fonts:tr18 :documentation "Select the previously selected bufffer.") ("List Buffers" :value (com-list-buffers) :font fonts:tr18 :documentation "List all buffers, allow selection with mouse.") ("Kill or Save Buffers" :value (com-kill-or-save-buffers) :font fonts:tr18 :documentation "A menu of buffers. Choose to kill or save them") ("Revert Buffer" :value (com-revert-buffer) :font fonts:tr18 :documentation "Re-read buffer from disk buffer.")))) (must-redisplay *window* dis-all)) (defun beep-and-discard (ignore elt) (beep) (values elt t)) (defvar *beeping-io-buffer* (tv:make-io-buffer 10 #'beep-and-discard)) (defmacro with-command-menu-disabled (&body body) `(let* ((com-menu (loop for inferior in (send (send (window-sheet *window*) ':superior) ':inferiors) if (typep inferior 'tv:command-menu-pane) return inferior)) (orig-io-buffer (send com-menu ':io-buffer))) (unwind-protect (progn (send com-menu ':set-io-buffer *beeping-io-buffer*) ,@body) (send com-menu ':set-io-buffer orig-io-buffer)))) ;;; Now, install this command permanently as a M-X command. (set-comtab *standard-comtab* () (make-command-alist '(com-make-top-command-menu))) (set-comtab *standard-comtab* () (make-command-alist '(com-remove-top-command-menu))) (set-comtab *standard-comtab* () (make-command-alist '(com-force-scroll-bar-on))) (set-comtab *standard-comtab* () (make-command-alist '(com-stop-forcing-scroll-bar))) ;;; I don't know what is going on here, but this is somehow telling some windows ;;; to set their edges out of bounds. I inserted a MAX in here to try to fix it. ;;; GROSS GROSS KLUDGE!! ;;; Code from sys:zwei;screen lisp > ;;; (DEFMETHOD (ZWEI-FRAME :AFTER :CHANGE-OF-SIZE-OR-MARGINS) (&REST IGNORE &AUX OLD-INSIDE-WIDTH OLD-INSIDE-HEIGHT NEW-INSIDE-LEFT NEW-INSIDE-TOP NEW-INSIDE-RIGHT NEW-INSIDE-BOTTOM NEW-INSIDE-WIDTH NEW-INSIDE-HEIGHT) (DECLARE (SPECIAL OLD-EXPOSED-INFERIORS OLD-INSIDE-LEFT OLD-INSIDE-TOP OLD-INSIDE-RIGHT OLD-INSIDE-BOTTOM)) (SETQ OLD-INSIDE-WIDTH (- OLD-INSIDE-RIGHT OLD-INSIDE-LEFT) OLD-INSIDE-HEIGHT (- OLD-INSIDE-BOTTOM OLD-INSIDE-TOP)) (MULTIPLE-VALUE (NEW-INSIDE-LEFT NEW-INSIDE-TOP NEW-INSIDE-RIGHT NEW-INSIDE-BOTTOM) (FUNCALL-SELF ':INSIDE-EDGES-WITHOUT-MODE-LINE-WINDOW)) (SETQ NEW-INSIDE-WIDTH (- NEW-INSIDE-RIGHT NEW-INSIDE-LEFT) NEW-INSIDE-HEIGHT (- NEW-INSIDE-BOTTOM NEW-INSIDE-TOP)) (TV:WITH-SHEET-DEEXPOSED (SELF) (DO ((WL (COPYLIST TV:INFERIORS) (CDR WL)) (WINDOW) (OLD-LEFT) (OLD-TOP) (OLD-RIGHT) (OLD-BOTTOM) (NEW-LEFT) (NEW-TOP) (NEW-RIGHT) (NEW-BOTTOM)) ((NULL WL)) (SETQ WINDOW (CAR WL)) (MULTIPLE-VALUE (OLD-LEFT OLD-TOP OLD-RIGHT OLD-BOTTOM) (FUNCALL WINDOW ':EDGES)) (IF (EQ WINDOW MODE-LINE-WINDOW) (SETQ NEW-LEFT NEW-INSIDE-LEFT NEW-TOP NEW-INSIDE-BOTTOM NEW-RIGHT NEW-INSIDE-RIGHT NEW-BOTTOM (+ NEW-INSIDE-BOTTOM (- OLD-BOTTOM OLD-TOP))) (SETQ NEW-LEFT (IF (= OLD-LEFT OLD-INSIDE-LEFT) NEW-INSIDE-LEFT (// (* OLD-LEFT NEW-INSIDE-WIDTH) OLD-INSIDE-WIDTH)) NEW-TOP (max 1 (IF (= OLD-TOP OLD-INSIDE-TOP) NEW-INSIDE-TOP (// (* OLD-TOP NEW-INSIDE-HEIGHT) OLD-INSIDE-HEIGHT))) NEW-RIGHT (IF (= OLD-RIGHT OLD-INSIDE-RIGHT) NEW-INSIDE-RIGHT (// (* OLD-RIGHT NEW-INSIDE-WIDTH) OLD-INSIDE-WIDTH)) NEW-BOTTOM (IF (= OLD-BOTTOM OLD-INSIDE-BOTTOM) NEW-INSIDE-BOTTOM (// (* OLD-BOTTOM NEW-INSIDE-HEIGHT) OLD-INSIDE-HEIGHT)))) (FUNCALL WINDOW ':SET-EDGES NEW-LEFT NEW-TOP NEW-RIGHT NEW-BOTTOM) (AND (MEMQ WINDOW OLD-EXPOSED-INFERIORS) (FUNCALL WINDOW ':EXPOSE)))))