;;; -*- Mode: Common-Lisp; Package: User; Base: 10.; Patch-File: T -*- ;;; Reason: Change to w:choose-variable-values to prevent hang in "choose" ;;; state. Also change to prevent leaving window on screen in rare situations ;;; (on MX during paging) where w:selected-window changes between calls ;;; to deactivate the CVV and to set the underlying windows selection-substitute. ;;; RESTRICTED RIGHTS LEGEND ;;; ;;; Use, duplication, or disclosure by the Government is subject to ;;; restrictions as set forth in subdivision (c)(1)(ii) of the Rights in ;;; Technical Data and Computer Software clause at 52.227-7013. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909, M/S 2151 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1989 Texas Instruments Incorporated. ;;; All rights reserved. ;;; Written 02/19/90 08:46:01 by MARKY, ;;; while running on LIBRA from band LODB ;;; With SYSTEM 6.29, VIRTUAL-MEMORY 6.2, EH 6.5, MAKE-SYSTEM 6.2, MICRONET 6.0, LOCAL-FILE 6.1, ;;; BASIC-PATHNAME 6.2, NETWORK-SUPPORT-COLD 6.2, BASIC-NAMESPACE 6.6, NETWORK-NAMESPACE 6.0, ;;; DISK-IO 6.1, DISK-LABEL 6.0, BASIC-FILE 6.6, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.0, ;;; COMPILER 6.14, TV 6.23, DATALINK 6.0, CHAOSNET 6.5, GC 6.3, MEMORY-AUX 6.0, NVRAM 6.2, ;;; SYSLOG 6.2, STREAMER-TAPE 6.4, UCL 6.0, INPUT-EDITOR 6.0, METER 6.1, ZWEI 6.12, ;;; DEBUG-TOOLS 6.3, NETWORK-SUPPORT 6.0, 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.3, MAIL-READER 6.6, TELNET 6.0, VT100 6.0, ;;; NAMESPACE-EDITOR 6.4, PROFILE 6.2, VISIDOC 6.5, TI-CLOS 6.37, CLEH 6.5, IP 3.56, ;;; Experimental CLX 6.8, CLUE 6.50, X11M 6.20, Experimental BUG 11.18, MMON 6.2, ;;; Experimental SC 3.0, Experimental CLIO 15.0, Experimental CONFORMANCE-CHECKER 2.0, ;;; Experimental CLIO-TEST 7.0, Experimental SLAP 3.17, MACTOOLBOX 2.0, microcode 429, ;;; Band Name: REL6-mmon-11/15/89 ;;; Fix hang of "choose" process-wait when user clicks on some other window ;;; causeing the other window to get a :mouse-select which will deexpose the CVV. ;;; Also, fix problem in pliant code where clicking on a items in a pane caused ;;; the resulting CVV's to stay exposed even after clicking in the abort box. ;;; #!C ; From file CHOICE.LISP#> WINDOW; MR-X: #10R TV#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "TV")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: WINDOW; CHOICE.#" (DEFUN CHOOSE-VARIABLE-VALUES (VARIABLES &KEY &OPTIONAL (FUNCTION nil) (NEAR-MODE '(:MOUSE)) (LABEL "Choose Variable Values") (WIDTH nil) (EXTRA-WIDTH 10.) (HEIGHT nil) (MARGIN-CHOICES nil) (SUPERIOR nil) (REVERSE-VIDEO-P nil) (VALUE-TAB T) (FORCE-PERMANENT NIL) SELECTED-IO (foreground-color *default-menu-foreground*) (background-color *default-menu-background*) (label-color *default-menu-label-foreground*) (label-background *default-menu-label-background*) &AUX (osw selected-window)) "Invoke a temporary Choose-variable-values window to choose VARIABLES. VARIABLES is a list of elements, each describing one line of the display. These become text-scroll items. Kinds of elements allowed are: string Just displayed. Use as a header or for blank lines IN CONJUNCTION with other items. Should not be used as the only item in a variable list. symbol value is printed, and if the user clicks on it with the mouse a new value is read. dtp-locative like special-variable but value is accessed by car and written by rplaca. list (VAR LABEL TYPE ARGS...). VAR is the variable (symbol or dtp-locative), LABEL if not NIL is a string to print instead of VAR's name, TYPE is a keyword saying what kinds of values are allowed (default :SEXP), and ARGS are args used by the TYPE's parsing functions. Keyword args are: :LABEL Window label (default is `Choose Variable Values') :FUNCTION Function called if user changes anything (default is NIL) :NEAR-MODE Where to appear the window (default is (:MOUSE)) :WIDTH Desired width of window. Default is to set wide enough for items. :EXTRA-WIDTH Amount of extra width to allow for growing items. Default 10 characters. Each of the above widths may be a number of characters or a string. :HEIGHT Desired height of window in pixels. The Default is to set height large enough to accomodate items. At a certain height based on the item sizes, scrolling is activated. This keyword allows you to specify the height large enough to prevent the need to scroll. :MARGIN-CHOICES List of elements. A string is the label for the box which means `exit' (Default is `DO IT'), cons of a string and a form means eval that form if box clicked upon. :SUPERIOR Window to put under, default is the superior of the window it is supposed to be near (if any), or SELECTED-WINDOW (if it is running the CURRENT-PROCESS), or *TERMINAL-IO* (if it is running the CURRENT-PROCESS), or finally MOUSE-SHEET. :REVERSE-VIDEO-P T means display this window reverse-video. :VALUE-TAB T (the default) means to tab values out past choice labels; A fixnum means to tab values to that number of spaces. NIL (or zero) means not to tab. FORCE-PERMANENT T means to make the CVV window a permanent window. Defaults to NIL which will make the CVV window temporary." selected-io ;; Decide what superior to use. First try the superior of the window that we are exposing near, then try ;; SELECTED-WINDOW, then try *TERMINAL-IO*, and last default to MOUSE-SHEET. ;; (unless variables ;; do a sanity check for user who wants for some reason to display a margin choice only... (ferror nil "Variables argument was nil. The variables arg must specify a list of variables")) (WHEN cvv-debug (send si:cold-load-stream :set-cursorpos 0 0)) (UNLESS (TYPEP superior 'sheet) (SETQ SUPERIOR (COND ((EQ (CAR NEAR-MODE) :WINDOW) (SHEET-SUPERIOR (CADR NEAR-MODE))) ((AND (TYPEP osw 'sheet) (EQ si:current-process (SEND osw :send-if-handles :process))) (sheet-get-screen osw (sheet-get-screen osw))) ((AND (TYPEP *terminal-io* 'sheet) (EQ si:current-process (SEND *terminal-io* :send-if-handles :process))) (sheet-get-screen *terminal-io* (sheet-get-screen *terminal-io*))) (t MOUSE-SHEET)))) ;; MARGIN-CHOICES must always contain a "DO IT" box so user can stop choosing. (LOOP FOR L IN MARGIN-CHOICES FINALLY (PUSH W:MARGIN-CHOICE-COMPLETION-STRING MARGIN-CHOICES) DO (IF (OR (STRINGP L) (AND (CONSP L) (STRING-EQUAL W:MARGIN-CHOICE-COMPLETION-STRING (CAR L)))) (RETURN) ;;ELSE (WHEN (OR (ATOM L) (NOT (STRINGP (CAR L)))) (FERROR () "~S garbage in MARGIN-CHOICES" L)))) (SETQ MARGIN-CHOICES (MAPCAR #'(LAMBDA (X &aux doc) (LIST (IF (ATOM X) X (CAR X)) NIL 'CHOOSE-VARIABLE-VALUES-CHOICE-BOX-HANDLER NIL NIL ;; may 9-14-88 added missing doc strings ;; X can be keyword, list or (ugh!) cons - per para 14.2.6.3 & 14.2.1 (IF (SETQ doc (AND (CONSP x) ;; not :keyword (CONSP (CDR x));; not (cons 'a 'b) (getf x :documentation))) :documentation nil) doc ;; end patch may 9-14-88 below is now EIGHTH in/of SIXTH in list (IF (ATOM X) NIL (CADR X)))) MARGIN-CHOICES)) ;; Handle variable sublists too. (DOLIST (ITEM VARIABLES) ;; Make sure all variables are bound, while in caller's environment. (DOLIST (ELEM (IF (AND (CONSP ITEM) (CONSP (CAR ITEM))) ITEM (LIST ITEM))) (IF (CONSP ELEM) (SETQ ELEM (CAR ELEM))) (COND ((EQ (DATA-TYPE ELEM) 'DTP-LOCATIVE) (SETQ ELEM (CAR ELEM))) ; Force compiler ((SYMBOLP ELEM) (SYMBOL-VALUE ELEM)) ((STRINGP ELEM)) ((AND (INTEGERP ELEM) (CONSP ITEM) (CONSP (CAR ITEM)))) (T (FERROR () "~S is a ~S Bad data type for variable" ELEM (DATA-TYPE ELEM)))))) ;; The following code is very contorted. The most recent change (22-MAR-85) was done to cause the CVV ;; resource to be cleared when the user aborts out. Previously, the resource was kept hanging around and ;; caused CVV to look broken when the user would reinvoke it. The fix was to use ALLOCATE-RESOURCE to ;; acquire the CVV resource and have an UNWIND-PROTECT to deallocate the resource. If the user aborts, ;; the resource gets deallocated and then cleared and execution continues. If the user exits normally, the ;; resource gets deallocated only. (LET (WINDOW ; The CVV resource ;; NIL for the ABORT key case, 'EXIT when the user presses the END key, and possibly ;; something else for a different margin choice. (PROCESSED-MESSAGE NIL)) (UNWIND-PROTECT (LET ((current-window (IF (SEND superior :operation-handled-p :set-selection-substitute) superior (OR osw mouse-sheet))) (OLD-SUBSTITUTE (SEND SUPERIOR :SELECTION-SUBSTITUTE))) (SETQ WINDOW (ALLOCATE-RESOURCE 'TEMPORARY-CHOOSE-VARIABLE-VALUES-WINDOW SUPERIOR)) ;; Close your eyes before you read the following form (HACK ALERT!!!). (IF FORCE-PERMANENT (SET-IN-INSTANCE WINDOW 'TEMPORARY-BIT-ARRAY NIL)) (SEND WINDOW :SET-VALUE-TAB VALUE-TAB) (SEND WINDOW :SET-REVERSE-VIDEO-P REVERSE-VIDEO-P) (SEND WINDOW :SETUP VARIABLES LABEL FUNCTION MARGIN-CHOICES (OR WIDTH T) EXTRA-WIDTH) ;; Make sure that we don't try to expose outside of our superior. (SEND window :set-size (MIN (SEND superior :inside-width) (SEND window :width)) (MIN (SEND superior :inside-height) (if height (max height (send window :height)) ;;else (send window :height)))) (when (color-system-p window) (send window :set-foreground-color foreground-color) (send window :set-background-color background-color) (send window :set-label-color label-color) (send window :set-label-background label-background) ) (UNWIND-PROTECT (PROGN (CLEAR-INPUT WINDOW) (DELAYING-SCREEN-MANAGEMENT (EXPOSE-WINDOW-NEAR WINDOW NEAR-MODE) (SEND WINDOW :SELECT) (SEND current-window :send-if-handles :set-selection-substitute window)) (DO () (NIL) ;; Wait for something from the keyboard. (LET ((KBD-INTERCEPTED-CHARACTERS CHOOSE-VARIABLE-VALUES-INTERCEPTED-CHARACTERS)) ;; may 02-14-90 This used to just call #'LISTEN with WINDOW as an arg. ;; Now if we get deexposed because the user clicked on another window, (i.e. inspect-window) ;; then we pretend we were aborted, otherwise the "choose" process hangs! ;; (PROCESS-WAIT "Choose" #'LISTEN WINDOW) (PROCESS-WAIT "Choose" #'(lambda (w processed-msg-locf) (or (LISTEN w) (and (not (send w :exposed-p)) (setf (contents processed-msg-locf) 'abort)))) WINDOW (locf processed-message)) ;; may 02-14-90 Added 2nd arg to lambda (when (eq processed-message 'abort) (return)) ;; may 02-14-90 Added (AND (SETQ PROCESSED-MESSAGE (CHOOSE-VARIABLE-VALUES-PROCESS-MESSAGE WINDOW (READ-ANY WINDOW))) (RETURN))))) (DELAYING-SCREEN-MANAGEMENT ;; may 02/19/90 Swapped order of two forms below. Setting the selection ;; substitute of a deeactivated window caused problems on mx - & does not make sense! (SEND current-window :send-if-handles :set-selection-substitute old-substitute) (SEND WINDOW :DEACTIVATE) (AND OSW (SEND OSW :SELECT NIL))))) (DEALLOCATE-RESOURCE 'temporary-choose-variable-values-window window) (WHEN (EQ PROCESSED-MESSAGE 'ABORT) ;; The user did something funny. Clear the resource so that subsequent CVV calls will still work. ;; The NIL argument to CLEAR-RESOURCE says to not print any warning message. (CLEAR-RESOURCE 'TEMPORARY-CHOOSE-VARIABLE-VALUES-WINDOW WINDOW NIL))) ;; Make sure that pressing the END key is the same as clicking on the DOIT box by ;; executing the same code. Likewise for the pressing the ABORT key and clicking ;; on the ABORT box. By implementing these two keys this way we make it so that ;; the user doesn't have to put in special code to cause these two to be handled ;; like their margin choice companions. Also, if the user did implement the special ;; code as recommended in the release 2 Window System manual then it will still work. (IF (EQ PROCESSED-MESSAGE 'EXIT) (EXECUTE-MARGIN-CHOICE MARGIN-CHOICES W:MARGIN-CHOICE-COMPLETION-STRING #'IGNORE) ;;ELSE (IF (EQ PROCESSED-MESSAGE 'ABORT) (EXECUTE-MARGIN-CHOICE MARGIN-CHOICES W:MARGIN-CHOICE-ABORT-STRING #'(LAMBDA () (SIGNAL-CONDITION EH:*ABORT-OBJECT*))))))) ))