;;; -*- Mode: Common-Lisp; Package: User; Base: 10.; Patch-File: T -*- ;;; Written 05/18/89 13:24:44 by MARKY, ;;; Reason: Changes to make mouse doc and return values in tv:choose-variable-values ;;; work in continuation lines. ;;; while running on MX5 from band NB22 ;;; With SYSTEM 5.19, GC 5.3, VIRTUAL-MEMORY 5.5, MICRONET 5.5, MICRONET-COMM 5.13, ;;; DISK-IO 5.9, BASIC-PATHNAME 5.2, MAC-PATHNAME 5.0, NETWORK-SUPPORT-COLD 5.1, ;;; BASIC-NAMESPACE 5.6, BASIC-FILE 5.3, RPC 5.4, NFS 5.10, EH 5.3, MAKE-SYSTEM 5.2, ;;; MEMORY-AUX 5.1, MACTOOLBOX 1.25, COMPILER 5.1, TV 5.21, NVRAM 5.1, UCL 5.0, INPUT-EDITOR 5.0, ;;; METER 5.0, ZWEI 5.9, DEBUG-TOOLS 5.1, WINDOW-MX 5.28, PRINTER 5.11, MAC-PRINTER-TYPES 5.4, ;;; NETWORK-PATHNAME 5.0, NETWORK-NAMESPACE 5.0, DATALINK 5.7, CHAOSNET 5.6, NETWORK-SUPPORT 5.0, ;;; NETWORK-SERVICE 5.0, DATALINK-DISPLAYS 5.0, NAMESPACE-EDITOR 5.1, IP 3.33, NFS-SERVER 5.3, ;;; PRINTER-TYPES 5.2, IMAGEN 5.1, MAIL-DAEMON 5.1, MAIL-READER 5.3, TELNET 5.1, ;;; VT100 5.0, STREAMER-TAPE 5.6, DECNET 1.45, VISIDOC 5.4, PROFILE 5.1, DISK-LABEL 5.1, ;;; microcode 128, Band Name: microExplorer Network (11/22) ;;; SPR 9676 #!C ; From file CHOICE.LISP#> WINDOW; SYS: #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.#" ;; This was changed incorrectly in patch 4.116 - it is NOT part of a margin region ;; choice box descriptor ( as I thought before ). This makes a continuation line item ;; return the value chosen (correct) instead of the entire item in a list (incorrect) (DEFUN (:PROPERTY MORE-CHOICES CHOOSE-VARIABLE-VALUES-KEYWORD-FUNCTION) (KWD-AND-ARGS) (VALUES (FOURTH KWD-AND-ARGS) NIL (THIRD KWD-AND-ARGS) (FIFTH KWD-AND-ARGS) (sixTH KWD-AND-ARGS))) ;; may 05/18/89 ;; added functionality to allow continuation lines have mouse documentation ;; which was apparently never implemented. (DEFMETHOD (BASIC-CHOOSE-VARIABLE-VALUES :WHO-LINE-DOCUMENTATION-STRING) () (MULTIPLE-VALUE-BIND (WINDOW-X-OFFSET WINDOW-Y-OFFSET) (SHEET-CALCULATE-OFFSETS SELF MOUSE-SHEET) (LET ((X (- MOUSE-X WINDOW-X-OFFSET)) (Y (- MOUSE-Y WINDOW-Y-OFFSET))) (MULTIPLE-VALUE-BIND (VALUE TYPE) (SEND SELF :MOUSE-SENSITIVE-ITEM X Y) (IF TYPE (LET ((ITEM (AREF ITEMS (+ TOP-ITEM (TRUNCATE (- Y (SHEET-INSIDE-TOP)) LINE-HEIGHT))))) ;; If we have a table, get the column of the table that ;; the value part identifies and make that the item here. (IF (AND (CONSP ITEM) (CONSP (CAR ITEM))) (SETQ ITEM (ASSOC (SECOND VALUE) ITEM :TEST #'EQUAL))) (IF (ATOM ITEM) '(:MOUSE-L-1 "input a new value from the keyboard" :MOUSE-R-1 "edit this value") ;;ELSE (PROGN (SETQ ITEM (CDR ITEM)) (AND (OR (STRINGP (CAR ITEM)) (NULL (CAR ITEM))) (SETQ ITEM (CDR ITEM))) ;; may 05/11/89 extract doc string from 'MORE-CHOICES (and (eq (car item) 'more-choices) (setq item (cdadr item))) ;; may 05/11/89 end patch (MULTIPLE-VALUE-BIND (IGNORE RF IGNORE IGNORE IGNORE DOC) (SEND SELF :DECODE-VARIABLE-TYPE (OR ITEM '(:SEXP))) (COND ((STRINGP DOC) DOC) ((CONSP DOC) DOC) ((AND DOC (FUNCALL DOC VALUE))) ((NULL RF) '(:MOUSE-L-1 "change to this value" :MOUSE-R-1 "edit this value")) (T '(:MOUSE-L-1 "input a new value from the keyboard" :MOUSE-R-1 "edit this value"))))))) ;;ELSE (PROGN (MULTIPLE-VALUE-SETQ (VALUE TYPE) (MOUSE-SENSITIVE-ITEM X Y)) (IF (AND VALUE (SYMBOLP (SECOND VALUE))) (DOCUMENTATION (SECOND VALUE)) ;;ELSE DEFAULT-WHO-LINE-DOCUMENTATION))))))) ;;; Had to modify this since MULTIPLE continuation lines were broke (term-Q menu) ;;; in that the mouse doc was not being displayed. The item had (list nil 'more-choices ...) ;;; in it when the code assumed it had (list nil 'more-choices ...). This did ;;; not work on rel3 either. The reason is that ITEM has been set to the (cdr item) ;;; when STR is set - do not confuse ITEM with the contents of the array ITEMS - which ;;; DO have 'more-choices as the 3rd element, if there are any. (DEFMETHOD (BASIC-CHOOSE-VARIABLE-VALUES :PRINT-ITEM) ;; MODIFIED 4/21/86 - KDB (ITEM LINE-NO ITEM-NO &OPTIONAL (EXTRA-WIDTH 0) (TABLE-P NIL) &AUX VAR STR FONTNO CHOICES PF RF K&A GPVF GVVF PVAL CVAL (VSP (SEND SELF :VSP)) CONSTRAINT (COMPLETE-ITEM ITEM)) "Print a single item for choose-variable-values." (DECLARE (SPECIAL ITEM-VALUE-FOR-SET)) LINE-NO ITEM-NO ;ignored (when cvv-debug (send si:cold-load-stream :line-out "Entering :print-item")) (IF (AND (CONSP ITEM) (CONSP (CAR ITEM))) (DO ((SUB-ITEM ITEM (CDR SUB-ITEM))) ((NULL SUB-ITEM)) ;; Call again to handle recursive definitions. (SEND SELF :PRINT-ITEM (FIRST SUB-ITEM) LINE-NO ITEM-NO EXTRA-WIDTH T)) ;;ELSE ;; Parse ITEM into label string, font to print that in, variable, and keyword-&-arguments (PROGN (COND ((STRINGP ITEM) (SETQ STR ITEM FONTNO 0)) ((SYMBOLP ITEM) (SETQ VAR ITEM STR (SYMBOL-NAME VAR) FONTNO 1)) (T (SETQ VAR (CAR ITEM) STR (IF (OR (STRINGP (CADR ITEM)) (NUMBERP (CADR ITEM)) (NULL (CADR ITEM))) ;; may 05/11/89 NOTE: the (null (cadr item) above will allow the next ;; line to cdr the item so that 'MORE-CHOICES is the second not third item ! (CAR (SETQ ITEM (CDR ITEM))) (IF (SYMBOLP VAR) (SYMBOL-NAME VAR) NIL)) FONTNO 1 K&A (CDR ITEM)))) ;; If any label string, print it and a colon. (COND (TABLE-P (SHEET-SET-FONT SELF (AREF FONT-MAP FONTNO)) (SHEET-STRING-OUT SELF " ")) ((EQ (CAR K&A) 'MORE-CHOICES) ;; This is a continuation. Print out some ;; space before these choices. (SHEET-SET-FONT SELF (AREF FONT-MAP FONTNO)) (SHEET-STRING-OUT SELF " ")) (STR (MULTIPLE-VALUE-BIND (START-X START-Y) (SEND SELF :READ-CURSORPOS) (SHEET-SET-FONT SELF (AREF FONT-MAP FONTNO)) (SHEET-STRING-OUT SELF STR) (IF VAR (SHEET-STRING-OUT SELF ": ")) (MULTIPLE-VALUE-BIND (NEW-X NEW-Y) (SEND SELF :READ-CURSORPOS) (WHEN (AND (FIXNUMP VALUE-TAB) (< NEW-X (+ START-X VALUE-TAB))) (MULTIPLE-VALUE-BIND (LEFT-MARGIN ) (SEND SELF :MARGINS) (WHEN (AND VAR (< (1- (FONT-CHAR-WIDTH CURRENT-FONT)) (- (+ START-X VALUE-TAB) NEW-X))) ;;; ASH line-height... centers leader lines. (SEND SELF :BITBLT (sheet-char-aluf self)(- (+ START-X VALUE-TAB) NEW-X) 2 12%-GRAY 0 0 (- NEW-X LEFT-MARGIN) (+ NEW-Y (ASH (- LINE-HEIGHT VSP 1) -1))))) (SEND SELF :SET-CURSORPOS (+ START-X VALUE-TAB) START-Y)))))) ;; If any variable, get its value and decide how to print it. (WHEN VAR ;; change ITEM-VALUE-FOR-SET to a binding instead of setq ;; in choose-variable-values-choice :redisplay is called ;; after an error to display an item that is not the ;; current item; needless to say we don't want ITEM-VALUE-FOR-SET ;; changed. PMH7/26/87 (let ((ITEM-VALUE-FOR-SET (COND ((SYMBOLP VAR) (SYMEVAL-IN-STACK-GROUP VAR STACK-GROUP)) (T (CAR VAR))))) (MULTIPLE-VALUE-SETQ (PF RF CHOICES GPVF GVVF NIL NIL NIL NIL CONSTRAINT) (SEND SELF :DECODE-VARIABLE-TYPE (OR K&A '(:SEXP)))) (COND ((NOT CHOICES) (LET ((LABEL-WIDTH (IF TABLE-P (SEND SELF :STRING-LENGTH STR 0 NIL NIL (AREF FONT-MAP 0)) EXTRA-WIDTH))) (SHEET-SET-FONT SELF (AREF FONT-MAP 2)) (SEND SELF :ITEM1 (CONS ITEM-VALUE-FOR-SET COMPLETE-ITEM) :VARIABLE-CHOICE 'CHOOSE-VARIABLE-VALUES-PRINT-FUNCTION PF ITEM-VALUE-FOR-SET LABEL-WIDTH)) ;;testing for constraints was removed from here since errors ;;couldn't be handled properly PMH 7/25/87 ) (T (when cvv-debug (send si:cold-load-stream :line-out (format nil "in :print-item, pf=~a, rf=~a, choices=~a" pf rf choices))) (LET (LAST-X (CHOICES-LEFT CHOICES) ;; We are changing the font inside of the DO loop, so we ;; need to save it here. (OLD-SHEET-FONT (SHEET-CURRENT-FONT SELF))) ;; Print out the variable's value. (CATCH 'LINE-OVERFLOW (LOOP FOR CHOICE IN CHOICES-LEFT DO (PROGN (SETQ PVAL (IF GPVF (FUNCALL GPVF CHOICE) CHOICE) CVAL (IF GVVF (FUNCALL GVVF CHOICE) CHOICE)) (SHEET-SET-FONT SELF (AREF FONT-MAP (IF (EQUAL CVAL ITEM-VALUE-FOR-SET) 4 3))) (SETQ LAST-X CURSOR-X) (SEND SELF :ITEM1 (CONS CHOICE COMPLETE-ITEM) :VARIABLE-CHOICE 'CHOOSE-VARIABLE-VALUES-PRINT-FUNCTION PF PVAL) (SEND SELF :TYO #\SPACE) ;; Pop one off after we have successfully processed a choice. (POP CHOICES-LEFT)) )) ;; Restore the font to its original value. (SHEET-SET-FONT SELF OLD-SHEET-FONT) ;; If this is a continuation line and not even one choice fits, ;; leave that gigantic choice name on this line. (WHEN (AND (EQ CHOICES-LEFT CHOICES) (EQ (second ITEM) 'MORE-CHOICES)) ;; may 05/18/89 was third (SETQ LAST-X CURSOR-X) (POP CHOICES-LEFT)) ;; If choices don't fit on line, push some into following line. (WHEN CHOICES-LEFT (SHEET-SET-CURSORPOS SELF (- LAST-X LEFT-MARGIN-SIZE) (- CURSOR-Y TOP-MARGIN-SIZE)) (SHEET-CLEAR-EOL SELF) (LET* ((NO-ITEMS (ARRAY-LEADER ITEMS 0)) (NEXT-ITEM (IF (> NO-ITEMS (1+ ITEM-NO)) (AREF ITEMS (1+ ITEM-NO))))) ;; See if we ALREADY made a continuation item for this one. (UNLESS (AND (CONSP NEXT-ITEM) (EQ (THIRD NEXT-ITEM) 'MORE-CHOICES)) ;; If not, make one, and put into it ;; all the choices we could not fit on this line. (VECTOR-PUSH-EXTEND NIL ITEMS) (DO ((I 1 (1+ I)) (LIM (- NO-ITEMS ITEM-NO))) ((= I LIM)) ;; Bubble items up <- I think this is DOWN ;; may 05/18/89 (SETF (AREF ITEMS (1+ (- NO-ITEMS I))) (AREF ITEMS (- NO-ITEMS I)))) (SETF (AREF ITEMS (1+ ITEM-NO)) (LIST VAR () 'MORE-CHOICES (IF (EQ (second ITEM) 'MORE-CHOICES) ;; may 05/18/89 was third (third ITEM) ITEM) ;; may 05/18/89 was fourth CHOICES-LEFT PF GPVF GVVF))))) (WHEN EXTRA-WIDTH (DOTIMES (I EXTRA-WIDTH) (SEND SELF :TYO #\SPACE)))))))))) (when cvv-debug (send si:cold-load-stream :line-out "Leaving :print-item")) ) ))