;;; -*- Mode:Common-Lisp; Package:(GC :size 200); Fonts:(CPTFONT TR12B TR12BI); Base:10; Patch-file:T -*- ;;;******************************************************************************** ;;; GULF Coast patches for main system ;;;******************************************************************************** tv: (DEFUN tv:KBD-SYS-1 (CH &AUX E W SW MAKENEW FLAVOR-OR-WINDOW SW-ALIAS gulf-coast-mode) (SETQ MAKENEW (LDB-TEST %%KBD-CONTROL CH) CH (LDB %%KBD-CHAR CH)) (COND ((OR (= CH (char-int #\?)) (= CH (char-int #\HELP))) (USING-RESOURCE (WINDOW POP-UP-FINGER-WINDOW) (SETF (SHEET-TRUNCATE-LINE-OUT-FLAG WINDOW) 0) (FUNCALL WINDOW ':SET-LABEL "Keyboard system commands") (WINDOW-CALL (WINDOW :DEACTIVATE) (FORMAT WINDOW "Press ~:@C and one of the following characters to create the first ~%~ instance of or select the most recently used window for the corresponding ~%~ program.~2%" #\SYSTEM) (FORMAT WINDOW "Press ~:@C CTRL and one of the following characters to create a new ~%~ window for the corresponding program.~2%" #\SYSTEM) (FORMAT WINDOW "Press ~:@C to do nothing if you pressed ~:@C by accident.~2%" #\RUBOUT #\SYSTEM) (LET ((LIST (SORTCAR (COPY-LIST *SYSTEM-KEYS*) #'ALPHALESSP)) (TEM (char-int #\?))) (DOLIST (X LIST) (OR (CHAR-EQUAL TEM (SETQ TEM (CAR X))) (FORMAT WINDOW "~&~C~8T~A" TEM (CADDR X))))) (FORMAT WINDOW "~2&~A" *REMOVE-TYPEOUT-STANDARD-MESSAGE*) ;; Let kbd process proceed before we TYI. (SETQ KBD-TERMINAL-TIME NIL) (FUNCALL WINDOW ':TYI)))) ((SETQ E (ASSoc CH *SYSTEM-KEYS* :test #'CHAR=)) ;; Find the most recently selected window of the desired type. ;; If it is the same type as the selected window, make that the ;; least recently selected so as to achieve the cycling-through effect. ;; Otherwise the currently selected window becomes the most recently ;; selected as usual, and TERM S will return to it. ;; In any case, we must fake out :MOUSE-SELECT's typeahead action since ;; that has already been properly taken care of and we don't want to snarf ;; any characters already typed after the [SYSTEM] command. (SETQ FLAVOR-OR-WINDOW (COND ((LISTP (SECOND E)) (EVAL (SECOND E))) (T (SECOND E)))) (DELAYING-SCREEN-MANAGEMENT ;Inhibit auto selection (SETQ SW SELECTED-WINDOW) (WHEN SW (SETQ SW-ALIAS (SEND SW ':ALIAS-FOR-SELECTED-WINDOWS))) (setq gulf-coast-mode (let* ((flavor-definition (and (symbolp FLAVOR-OR-WINDOW) (get FLAVOR-OR-WINDOW 'si:flavor))) (type-of-GC-background (and flavor-definition (member 'gc:gulf-coast (si:flavor-depends-on-all flavor-definition))))) (and (not type-of-GC-background) ;;ALL GULF-COAST backgrounds at top level (gc:find-gulf-coast-background tv:selected-window)))) (COND ((TYPEP FLAVOR-OR-WINDOW 'ESSENTIAL-WINDOW) ;; If the *SYSTEM-KEYS* list has a specific window indicated, use that. (AND SW (FUNCALL SW ':DESELECT NIL)) (FUNCALL FLAVOR-OR-WINDOW ':MOUSE-SELECT)) ;; NIL means he already did whatever he wanted. ((NULL FLAVOR-OR-WINDOW) NIL) ((AND (NOT MAKENEW) (SETQ W (FIND-WINDOW-OF-FLAVOR FLAVOR-OR-WINDOW))) ;; Cycle through other windows of this flavor. (WHEN SW ;;restore both last window and last background to previous-selected array (let ((last-background (gc:find-gulf-coast-background sw))) (and last-background (tv:add-to-previously-selected-windows last-background (if (typep (gc:find-gulf-coast-background w) (typep last-background)) ':end)))) (FUNCALL SW ':DESELECT (IF (TYPEP SW-ALIAS FLAVOR-OR-WINDOW) ':END))) ;;if GULF-COAST background where type-out is selected, place GC background at end (if (send w :send-if-handles :gulf-coast-p) (tv:add-to-previously-selected-windows w :at-end)) (FUNCALL W ':MOUSE-SELECT)) ((AND (NOT MAKENEW) SW (TYPEP SW-ALIAS FLAVOR-OR-WINDOW)) ;; There is only one window of this flavor, and this is it. (BEEP)) ((NULL (FOURTH E)) (BEEP)) ;Cannot create ((Not (consp (FOURTH E))) ;; Create a new window of this flavor. ;; We create on the default screen. (AND SW (FUNCALL SW ':DESELECT (IF (TYPEP SW-ALIAS FLAVOR-OR-WINDOW) ':END))) (let ((flavor-type (IF (EQ (FOURTH E) T) FLAVOR-OR-WINDOW (FOURTH E)))) (if gulf-coast-mode (let ((result (gc:create-window-with-mouse FLAVOR-type 'mouse :gulf-coast-background gulf-coast-mode))) (and result (FUNCALL result ':MOUSE-SELECT))) (FUNCALL (MAKE-WINDOW flavor-type ':SUPERIOR DEFAULT-SCREEN) ':MOUSE-SELECT)))) (T (if gulf-coast-mode (let ((default-screen gulf-coast-mode)) (EVAL (FOURTH E))) (EVAL (FOURTH E))))))) ((NOT (= CH (char-int #\RUBOUT))) (BEEP))) (SETQ KBD-TERMINAL-TIME NIL)) tv: (DEFUN FIND-WINDOW-OF-FLAVOR (FLAVOR) "Find a previously selected window whose flavor includes FLAVOR." (DOTIMES (I (ARRAY-LENGTH PREVIOUSLY-SELECTED-WINDOWS)) (LET ((W (AREF PREVIOUSLY-SELECTED-WINDOWS I))) (WHEN W (AND W (TYPEP W FLAVOR) (FUNCALL W ':NAME-FOR-SELECTION) (RETURN W)) (or (send w :send-if-handles :gulf-coast-p) (LET ((WSS (SEND W ':SELECTION-SUBSTITUTE))) (AND WSS (TYPEP WSS FLAVOR) (FUNCALL WSS ':NAME-FOR-SELECTION) (RETURN WSS)))))))) ucl: (DEFMETHOD (BASIC-COMMAND-LOOP :lookup-keys) (key-sequence &AUX command) "Looks through the active command tables looking for a command claiming the keystroke sequence KEY-SEQUENCE. Returns NIL or the found UCL:COMMAND and its command table or a flag :FETCH-MORE-KEYS indicating the user needs to type more keys." (looping-through-command-tables NIL ;;When a ucl:command is found, return it. Otherwise return nil. (WHEN (SETQ command (SEND command-table :lookup-keys key-sequence)) (RETURN command command-table)) (and (null groups) (null group) (when (multiple-value-setq (command command-table) (find-ucl-command-in-hierarchy key-sequence self)) (RETURN command command-table))))) ;;this is a helper function for above ucl: (defun find-ucl-command-in-hierarchy (key-sequence current &aux command command-table) (loop for superior = (send current :send-if-handles :superior) for table = (and superior (send superior :send-if-handles :active-command-tables)) when (null superior) do (return nil) else do (setq current superior) when (and superior table) do (WHEN (multiple-value-setq (command command-table) (send superior :lookup-keys key-sequence)) (RETURN command command-table))))