;;; -*- Mode: Common-Lisp; Package: User; Base: 8.; Patch-File: T -*- ;;; Reason: Insure in (tv:sheet :deexpose) that a window with ;;; its temporary-bit-array T is not accessed as an array. ;;; 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 07/20/89 17:48:32 by MARKY, ;;; while running on LIBRA from band LODB ;;; With SYSTEM 6.13, VIRTUAL-MEMORY 6.1, EH 6.4, MAKE-SYSTEM 6.0, MICRONET 6.0, LOCAL-FILE 6.0, ;;; BASIC-PATHNAME 6.1, NETWORK-SUPPORT-COLD 6.0, BASIC-NAMESPACE 6.1, NETWORK-NAMESPACE 6.0, ;;; DISK-IO 6.1, DISK-LABEL 6.0, BASIC-FILE 6.2, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.0, ;;; COMPILER 6.10, TV 6.14, DATALINK 6.0, CHAOSNET 6.0, GC 6.3, MEMORY-AUX 6.0, NVRAM 6.1, ;;; SYSLOG 6.1, STREAMER-TAPE 6.4, UCL 6.0, INPUT-EDITOR 6.0, METER 6.1, ZWEI 6.5, ;;; Experimental DEBUG-TOOLS 6.3, NETWORK-SUPPORT 6.0, NETWORK-SERVICE 6.1, DATALINK-DISPLAYS 6.0, ;;; FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.3, MAC-PRINTER-TYPES 6.1, PRINTER-TYPES 6.1, ;;; IMAGEN 6.0, SUGGESTIONS 6.0, MAIL-DAEMON 6.2, MAIL-READER 6.2, TELNET 6.0, VT100 6.0, ;;; NAMESPACE-EDITOR 6.0, PROFILE 6.1, VISIDOC 6.2, TI-CLOS 6.19, CLEH 6.5, IP 3.47, ;;; Experimental BUG 11.10, Experimental CLX 6.2, CLUE 6.10, X11M 6.1, MMON 7.0, ;;; microcode 429, Band Name: rel6 6/5,mmon,patches ;;; spr 10281. See zmacs patch 6.5, too #!C ; From file SHEET.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; SHEET.#" (DEFMETHOD (SHEET :DEEXPOSE) (&OPTIONAL (SAVE-BITS-P :DEFAULT) SCREEN-BITS-ACTION (REMOVE-FROM-SUPERIOR T)) "Deexpose a sheet (removing it virtually from the physical screen, some bits may remain)" (DELAYING-SCREEN-MANAGEMENT (COND ((AND (EQ SAVE-BITS-P :DEFAULT) (NOT (ZEROP (SHEET-FORCE-SAVE-BITS))) EXPOSED-P) (SETQ SAVE-BITS-P :FORCE) (SETF (SHEET-FORCE-SAVE-BITS) 0))) (LET ((SW SELECTED-WINDOW)) (AND SW (SHEET-ME-OR-MY-KID-P SW SELF) (FUNCALL SW :DESELECT NIL))) (OR SCREEN-BITS-ACTION (SETQ SCREEN-BITS-ACTION :NOOP)) (COND (EXPOSED-P (OR BIT-ARRAY ;; We do not have a bit-array, take our inferiors off screen. (EQ SAVE-BITS-P :FORCE) ;but leave them in EXPOSED-INFERIORS (DOLIST (INFERIOR EXPOSED-INFERIORS) (FUNCALL INFERIOR :DEEXPOSE SAVE-BITS-P :NOOP NIL))) (WITHOUT-INTERRUPTS (WHEN (AND (EQ SAVE-BITS-P :FORCE) (NULL BIT-ARRAY)) ;; We are to force a saving of the SCREEN-ARRAY and ;; there isn't a BIT-ARRAY. We must create a BIT-ARRAY. (SETF BIT-ARRAY (MAKE-ARRAY `(,HEIGHT ,(LOGAND (+ (TRUNCATE (* LOCATIONS-PER-LINE 32.) (SCREEN-BITS-PER-PIXEL (SHEET-GET-SCREEN SELF))) #o37) #o-40)) :TYPE (SHEET-ARRAY-TYPE SELF))) (SETQ OLD-SCREEN-ARRAY NIL) (when (mac-system-p) (send-adjust-bit-array-maybe self))) (PREPARE-SHEET (SELF) (AND SAVE-BITS-P BIT-ARRAY (PROGN (PAGE-IN-PIXEL-ARRAY BIT-ARRAY NIL (LIST WIDTH HEIGHT)) (BITBLT ALU-SETA WIDTH HEIGHT SCREEN-ARRAY 0 0 BIT-ARRAY 0 0) (PAGE-OUT-PIXEL-ARRAY BIT-ARRAY NIL (LIST WIDTH HEIGHT))))) ;; may 07/20/89 Should never happen, but be sure that the temporary-bit-array is not T. SPR 10281 (COND ((arrayp temporary-bit-array) ;;(sheet-temporary-p) ;; may 07/20/89 (page-in-pixel-array temporary-bit-array nil (LIST width height)) ;; CJJ 09/20/88. Make sure all relevant bits are affected... ;; Added for Multiple Monitor (MMON) support. 09/28/88 KJF (LET* ((original-plane-mask plane-mask) (modify-plane-mask-p (AND (NOT (EQL original-plane-mask *default-plane-mask*)) (color-sheet-p self)))) ;; Added unwind-protect - MMON 09/28/88 KJF (UNWIND-PROTECT (PROGN ;; Added for Multiple Monitor (MMON) support. 09/28/88 KJF (WHEN modify-plane-mask-p (SEND self :set-plane-mask (sheet-plane-mask (sheet-get-screen self)))) (BITBLT alu-seta width height temporary-bit-array 0 0 screen-array 0 0)) ;; but always restore the plane-mask... ;; Clean-up form for unwind-protect - MMON 09/28/88 KJF (WHEN modify-plane-mask-p (SEND self :set-plane-mask original-plane-mask)))) (page-out-pixel-array temporary-bit-array nil (LIST width height)) (DOLIST (sheet temporary-windows-locked) (sheet-release-temporary-lock sheet self)) (SETQ temporary-windows-locked nil)) (t (CASE screen-bits-action (:noop) (:clean (prepare-sheet (self) ;; may 7-1-88 added prepare-sheet ;; CJJ 09/20/88. Make sure all relevant bits are affected... ;; Added for Multiple Monitor (MMON) support. 09/28/88 KJF (LET* ((original-plane-mask plane-mask) (modify-plane-mask-p (AND (NOT (EQL original-plane-mask *default-plane-mask*)) (color-sheet-p self)))) ;; Added unwind-protect - MMON 09/28/88 KJF (UNWIND-PROTECT (PROGN ;; Added for Multiple Monitor (MMON) support. 09/28/88 KJF (WHEN modify-plane-mask-p (SEND self :set-plane-mask (sheet-plane-mask (sheet-get-screen self)))) ;;>>> alu-andca changed to erase-aluf (%draw-rectangle width height 0 0 (sheet-erase-aluf self) self)) ;; but always restore the plane-mask... ;; Clean-up form for unwind-protect - MMON 09/28/88 KJF (WHEN modify-plane-mask-p (SEND self :set-plane-mask original-plane-mask)))))) (otherwise (FERROR nil "~S is not a valid bit action" screen-bits-action))))) (SETQ EXPOSED-P NIL) (AND REMOVE-FROM-SUPERIOR SUPERIOR (SETF (SHEET-EXPOSED-INFERIORS SUPERIOR) (DELETE SELF (THE LIST (SHEET-EXPOSED-INFERIORS SUPERIOR)) :TEST #'EQ))) (IF (NULL BIT-ARRAY) (SETQ OLD-SCREEN-ARRAY SCREEN-ARRAY SCREEN-ARRAY NIL) (REDIRECT-ARRAY SCREEN-ARRAY (ARRAY-ELEMENT-TYPE BIT-ARRAY) (ARRAY-DIMENSION BIT-ARRAY 1) (ARRAY-DIMENSION BIT-ARRAY 0) BIT-ARRAY 0)) (when (mac-window-p self) (redirect-drawing-of-window-and-inferiors self)) (SETF (SHEET-OUTPUT-HOLD-FLAG) 1))) (REMOVE-FROM-SUPERIOR (AND SUPERIOR (SETF (SHEET-EXPOSED-INFERIORS SUPERIOR) (DELETE SELF (THE LIST (SHEET-EXPOSED-INFERIORS SUPERIOR)) :TEST #'EQ))))))) ))