;;; -*- Mode: Common-Lisp; Package: User; Base: 10.; Patch-File: T -*- ;;; Written 06/13/90 11:48:36 by MARKY, ;;; Reason: Prevent a menu created by w:menu-choose that is :pop-up nil ;;; and :permanent nil from hanging around forever. ;;; while running on TIGUE from band LOD2 ;;; With SYSTEM 6.31, VIRTUAL-MEMORY 6.3, EH 6.6, MAKE-SYSTEM 6.2, MICRONET 6.0, LOCAL-FILE 6.2, ;;; BASIC-PATHNAME 6.4, NETWORK-SUPPORT-COLD 6.2, BASIC-NAMESPACE 6.7, NETWORK-NAMESPACE 6.1, ;;; DISK-IO 6.2, DISK-LABEL 6.0, BASIC-FILE 6.10, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.1, ;;; COMPILER 6.14, TV 6.24, DATALINK 6.0, CHAOSNET 6.5, GC 6.3, MEMORY-AUX 6.0, NVRAM 6.2, ;;; SYSLOG 6.2, STREAMER-TAPE 6.5, UCL 6.0, INPUT-EDITOR 6.0, METER 6.1, ZWEI 6.13, ;;; DEBUG-TOOLS 6.4, NETWORK-SUPPORT 6.1, NETWORK-SERVICE 6.2, DATALINK-DISPLAYS 6.0, ;;; FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.3, MAC-PRINTER-TYPES 6.1, PRINTER-TYPES 6.2, ;;; IMAGEN 6.1, SUGGESTIONS 6.1, MAIL-DAEMON 6.6, MAIL-READER 6.7, TELNET 6.1, VT100 6.0, ;;; NAMESPACE-EDITOR 6.4, PROFILE 6.2, VISIDOC 6.7, TI-CLOS 6.42, CLEH 6.5, IP 3.60, ;;; Experimental CLX 6.9, CLUE 6.86, MMON 6.2, Experimental SST-WINDOWS 1.0, Experimental SNRL 14.0, ;;; Experimental GRAPHICS-WINDOW 81.0, Experimental GRAPHICAL-SORT 3.0, Experimental VIEWS 9.0, ;;; Experimental W-VIEWS 4.0, Experimental SPREADSHEET 30.0, Experimental W-SPREADSHEET 4.0, ;;; Experimental GRAPH 4.0, Experimental W-GRAPH 3.0, microcode 430, Band Name: 6-nsnrl-view-mmon-3/12/90 #!C ; From file MENU.LISP#> WINDOW; Hotel: #10R W#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "W")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: WINDOW; MENU.#" ;;; Prevent a menu created by w:menu-choose that is :pop-up nil :permanent nil from ;;; being left on the superior's inferior list when in fact no code can get at the menu ;;; to do anything with it! (DEFUN MENU-CHOOSE (ALIST &KEY (ABORT-ON-DEEXPOSE NIL) (COLUMNS NIL) (COMMAND-MENU NIL) (DEFAULT-ITEM NIL) (DYNAMIC NIL) (GEOMETRY NIL) (HIGHLIGHTED-ITEMS NIL) (HIGHLIGHTING NIL) (IO-BUFFER NIL) (ITEM-ALIGNMENT :LEFT) (LABEL NIL) (MENU-MARGIN-CHOICES NIL) (MULTICOLUMN NIL) (NEAR-MODE '(:MOUSE)) (PERMANENT NIL) (POP-UP T) (SORT NIL) (foreground-color tv:*default-menu-foreground*) (background-color tv:*default-menu-background*) (label-color tv:*default-menu-label-foreground*) (label-background tv:*default-menu-label-background*) (SCROLLING-P T SCROLLING-P-SUPPLIED) (SUPERIOR MOUSE-SHEET) &AUX (OSW SELECTED-WINDOW)) "Let user choose an element of ALIST with a menu. This is an `easy-to-use' function which interfaces with the MENU flavor. From here the caller can specify the often-used features of menus. Letting all optional parameters default causes a `pop-up' menu to be created which will disappear when the user moves the mouse away. Specifying other values for the optional parameters allows the caller to create different kinds of menus. ALIST an ITEM-LIST for a menu. For multi-column menus this will be the column-spec-list instead. For dynamic menus this will be a form to be evaluated. ABORT-ON-DEEXPOSE when specified as T, if the menu becomes deexposed then the `abort' option will be `clicked on'. If there is an `abort' margin choice then that will be used; otherwise the `abort' in the ALIST, if any will be used. COMMAND-MENU when specified as T causes menu selections to be placed into an I/O buffer as a blip. Default is NIL. COLUMNS when specified is the number of columns in the menu. Default is NIL which means that the number of columns is determined from the geometry. DEFAULT-ITEM an item that is EQ to an element of ALIST; the mouse will be positioned initially over that item. Or it can be NIL. DYNAMIC when specified as T allows the menu ALIST to be dynamically updated. Defaults to NIL. The ALIST is a form whose value can change. After the change, the :update-item-list method must be called to cause the menu to be updated. GEOMETRY when specified indicates the layout and dimensions of the menu. Defaults to NIL, which means that the layout is determined from the number of items present, or the dimensions of the superior if there are too many items. HIGHLIGHTED-ITEMS allows one to specify items which are initially highlighted. HIGHLIGHTING when specified as T causes a selection to be highlighted, allows one to select more than one item. Defaults to NIL. IO-BUFFER the I/O buffer for command menus. ITEM-ALIGNMENT Specifies the alignment of items within a column. Can be one of :LEFT, :CENTER or :RIGHT. Defaults to :LEFT. LABEL the label of the menu, if not specified this is NIL. MENU-MARGIN-CHOICES Margin choices to allow one to terminate a selection. Defaults to NIL. MULTICOLUMN when specified as T causes the ALIST to be interpreted as a column-spec-list to generate a multi-column menu. Defaults to NIL. NEAR-MODE specifies how to decide where to put the menu; see EXPOSE-WINDOW-NEAR. Defaults to (:MOUSE). PERMANENT when specified as T makes the menu `permanent'. Defaults to NIL which makes the menu `temporary'. POP-UP when specified as T the menu will be deexposed when the mouse moves out of it. Defaults to T. SCROLLING-P when specified as NIL this will disable scrolling for the menu. Defaults to T. SORT when specified this indicates the manner in which the menu items should be ordered. Allowable values are :ASCENDING :DESCENDING, predicate (:ASCENDING key) (:DESCENDING key) (predicate key). Where `predicate' and `key' are as required by the sort function. As a shorthand, the user may specify T instead of :ASCENDING. Defaults to NIL which does not change the ordering of the menu items. Note that sorting the alist is a destructive operation. SUPERIOR The menu is made an inferior this. If the user chooses an item, the values are: 1) the value computed from that item, and 2) the item itself (an element of ALIST). Otherwise, NIL is returned." ;; Perform validity checking here. The idea is to catch some menu combinations which may not ;; make sense. ;; In order to make a selection from a highlighting menu it must have margin choices, be a ;; command menu or a permanent menu. If it has margin choices, then one can select one of ;; them to make the selection. If it is a command menu then when one selects an item the blip ;; will be placed into the I/O buffer. If it is permanent then the user is probably ;; specifically calling the method to find out which items were selected (i.e. ;; :HIGHLIGHTED-ITEMS or :HIGHLIGHTED-VALUES). (ASSERT (IF (OR HIGHLIGHTING HIGHLIGHTED-ITEMS) (OR MENU-MARGIN-CHOICES COMMAND-MENU PERMANENT) T) (HIGHLIGHTING HIGHLIGHTED-ITEMS MENU-MARGIN-CHOICES COMMAND-MENU PERMANENT) "A highlighting menu must have some way of completing a selection. No manner is specified.") (ASSERT (NOT (AND MULTICOLUMN DYNAMIC)) ;; may 7-29-88 () "Both MULTICOLUMN and DYNAMIC can not be specified.") ;; Currently when a dynamic sends the :UPDATE-ITEM-LIST method it causes the window to become ;; temporarily deexposed, causing a pop-up window to stay deexposed. This is probably a bug, ;; but the old code worked this way too. The best solution is to fix it (which is not a ;; trivial task. It probably has something to do with mouse ownership changing.). ;;(ASSERT (IF (AND DYNAMIC POP-UP) NIL T) ;; (DYNAMIC POP-UP) ;; "A dynamic menu currently can not also be a pop-up menu.") (ASSERT (IF (AND MULTICOLUMN COLUMNS) (PROGN (IF (= (LENGTH ALIST) COLUMNS) T NIL)) T) (COLUMNS) "Number of columns specified in :COLUMNS does not match the number of columns in the item list.") ;; If the user specifies a command menu then it must also have an io buffer, otherwise there is not ;; place to put the chosen item blip. (ASSERT (IF COMMAND-MENU IO-BUFFER T) (COMMAND-MENU IO-BUFFER) "A command menu must have an I/O buffer.") ;; We don't bother to check to see if the user specified HIGHLIGHTED-ITEMS but not ;; HIGHLIGHTING. The init method for MENU corrects this error for us. ;; A permanent menu with margin choices sounds kind of silly, but we might as well allow it. (ASSERT (IF (AND POP-UP PERMANENT) NIL T) (POP-UP PERMANENT) "A menu cannot be both permanent and pop-up.") ;; The following code is somewhat contorted. The idea is that if ;; menu code doesn't execute all the way to the end there must have ;; been some kind of error. In this case, the resource is cleared ;; so that is will not affect a subsequent execution. (LET (MENU ; The MENU resource MENU-CHOOSE-WAS-ABORTED ; T when the user aborts, NIL otherwise VALUE-CHOSEN ; Value chosen by user, or NIL LAST-ITEM) ; Last item chosen by user, or NIL (UNWIND-PROTECT (PROGN (SETQ MENU (ALLOCATE-RESOURCE 'MENU :SUPERIOR SUPERIOR :ABORT-ON-DEEXPOSE ABORT-ON-DEEXPOSE :COLUMNS COLUMNS :COMMAND-MENU COMMAND-MENU :DYNAMIC DYNAMIC :GEOMETRY GEOMETRY :HIGHLIGHTING HIGHLIGHTING :IO-BUFFER IO-BUFFER :ITEM-ALIGNMENT ITEM-ALIGNMENT :ITEM-LIST-POINTER (IF DYNAMIC ALIST NIL) :MENU-MARGIN-CHOICES MENU-MARGIN-CHOICES :MULTICOLUMN MULTICOLUMN :PERMANENT PERMANENT :POP-UP POP-UP :SCROLLING-P SCROLLING-P :SORT SORT)) (SETQ MENU-CHOOSE-WAS-ABORTED MENU) (SEND MENU :SET-HIGHLIGHTED-ITEMS HIGHLIGHTED-ITEMS) (DELAYING-COMPUTE-GEOMETRY (SEND MENU :SET-LABEL LABEL)) (IF MULTICOLUMN (SEND MENU :SET-COLUMN-SPEC-LIST ALIST) ;;ELSE (IF (NOT DYNAMIC) (SEND MENU :SET-ITEM-LIST ALIST) ;;;; HACK ALERT ;;;; ------ this is not the no-op it seems ;;;; some instance variables and the geometry need ;;;; to be reset after label processing ------ (send menu :set-item-list (send menu :item-list)))) (SEND MENU :SET-LAST-ITEM DEFAULT-ITEM) (CLEAR-INPUT MENU) (WHEN (NULL SCROLLING-P-SUPPLIED) ;; If the user didn't say anything about scrolling then only turn on scrolling when ;; there isn't enough room to display all of the items. (SEND MENU :DECIDE-IF-SCROLLING-NECESSARY)) (IF (color-system-p menu) (progn (SEND menu :set-foreground-color foreground-color) (SEND menu :set-background-color background-color) (send menu :set-label-color label-color) (send menu :set-label-background label-background) ) ) (EXPOSE-WINDOW-NEAR MENU NEAR-MODE) (AND DEFAULT-ITEM (NOT (MEMBER (CAR NEAR-MODE) '(:MOUSE :POINT) :TEST #'EQ)) (MULTIPLE-VALUE-BIND (X Y) (SEND MENU :ITEM-CURSORPOS DEFAULT-ITEM) (AND X Y (SEND MENU :SET-MOUSE-POSITION (+ X (SHEET-INSIDE-LEFT MENU)) (+ Y (SHEET-INSIDE-TOP MENU)))))) (SETQ VALUE-CHOSEN (SEND MENU :CHOOSE) LAST-ITEM (SEND MENU :LAST-ITEM)) (SETQ MENU-CHOOSE-WAS-ABORTED NIL)) ;; MAY 06/13/90 Added (WHEN (AND menu (ZEROP (sheet-menu-pop-up menu)) (ZEROP (sheet-menu-permanent menu))) ;; Neither the (menu :execute) or (menu :after :handle-mouse) ;; deactivated the menu so do it now. (SEND menu :deactivate)) (AND OSW (SEND OSW :SELECT NIL)) (WHEN MENU (DEALLOCATE-RESOURCE 'MENU MENU)) (WHEN MENU-CHOOSE-WAS-ABORTED (CLEAR-RESOURCE 'MENU MENU))) (VALUES VALUE-CHOSEN LAST-ITEM))) ))