;;; -*- Mode: Common-Lisp; Package: User; Base: 10.; Patch-File: T -*- ;;; Written 11/29/88 12:58:06 by GRENINGER, ;;; Reason: o Allow (sheet :init) to create a window wider than its superior. ;;; o Make grow-bit-array always create an array of the specified size. ;;; o Rationalize calling sequence, documentation, internal workings, and ;;; callers of grow-bit-array so all agree. ;;; while running on MX23 from band TEST ;;; 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.26, 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.30, 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 96, Band Name: microExplorer Network (11/22) #!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 :init) (init-plist &aux bottom right save-bits (vsp 2) (more-p t) (character-width nil) (character-height nil) (reverse-video-p nil) (integral-p nil) (blinker-p t) (blink-fl 'rectangular-blinker) (deselected-visibility :on)) ;; Process options (doplist ((CAR init-plist) val op) (CASE op ((:left :x) (SETQ x-offset val)) ((:top :y) (SETQ y-offset val)) (:position (SETQ x-offset (FIRST val) y-offset (SECOND val))) (:right (SETQ right val)) (:bottom (SETQ bottom val)) (:size (AND val (SETQ width (FIRST val) height (SECOND val)))) (:edges (AND val (SETQ x-offset (FIRST val) y-offset (SECOND val) right (THIRD val) bottom (FOURTH val) ;; Override any specified height, ;; probably from default plist. height nil width nil)) (UNLESS (> right x-offset) (FERROR nil "Specified edges give width ~s" (- right x-offset))) (UNLESS (> bottom y-offset) (FERROR nil "Specified edges give height ~s" (- bottom y-offset)))) (:character-width (SETQ character-width val)) (:character-height (SETQ character-height val)) (:blinker-p (SETQ blinker-p val)) (:reverse-video-p (SETQ reverse-video-p val)) (:more-p (SETQ more-p val)) (:vsp (SETQ vsp val)) (:blinker-flavor (SETQ blink-fl val)) (:blinker-deselected-visibility (SETQ deselected-visibility val)) (:integral-p (SETQ integral-p val)) (:save-bits (SETQ save-bits val)) (:right-margin-character-flag (SETF (sheet-right-margin-character-flag) val)) (:backspace-not-overprinting-flag (SETF (sheet-backspace-not-overprinting-flag) val)) (:cr-not-newline-flag (SETF (sheet-cr-not-newline-flag) val)) (:truncate-line-out-flag (SETF (sheet-truncate-line-out-flag) val)) ;; Set keypad-enable to 0 if val is either NIL or is 0. Otherwise set to 1. (:keypad-enable (SETF (sheet-keypad-enable) (IF (FIXNUMP val) (IF (= val 0) 0 1) ;;ELSE (IF val 1 0)))) (:tab-nchars (SETF (sheet-tab-nchars) val)) (:deexposed-typein-action (SEND self :set-deexposed-typein-action val)) )) (sheet-deduce-and-set-sizes right bottom vsp integral-p character-width character-height) (COND ((OR (EQ save-bits 't) bit-array) ;; Handle the possibility of creating the window wider than its screen. So ;; long as the window is never activated & exposed, this causes no problems. ;; The w:cache-window requires this capability. 11/28/88 LG (LET* ((our-screen (sheet-get-screen self)) (pixels-per-location (FLOOR 32. (screen-bits-per-pixel our-screen))) (screen-width (* pixels-per-location (sheet-locations-per-line our-screen))) (width-to-use (MAX (* pixels-per-location (CEILING width pixels-per-location)) screen-width)) (locations-per-line-to-use (FLOOR width-to-use pixels-per-location))) (SETF locations-per-line locations-per-line-to-use) (WITH-STACK-LIST (dims height width-to-use) (LET ((array-type (sheet-array-type self))) (SETF bit-array (IF bit-array (grow-bit-array bit-array width height (SECOND dims)) ;; else... (MAKE-ARRAY dims :type array-type))) (SETQ screen-array (MAKE-ARRAY dims :type array-type :displaced-to bit-array :displaced-index-offset 0)))))) ((EQ save-bits :delayed) (SETF (sheet-force-save-bits) 1))) (SETQ more-vpos (AND more-p (sheet-deduce-more-vpos self))) (WHEN superior (UNLESS bit-array (LET ((ARRAY (sheet-superior-screen-array))) (SETQ old-screen-array (MAKE-ARRAY `(,height ,(ARRAY-DIMENSION array 1)) :type (ARRAY-TYPE array) :displaced-to array :displaced-index-offset (+ x-offset (* y-offset (ARRAY-DIMENSION array 1))))) (SETQ locations-per-line (sheet-locations-per-line superior)))) (WHEN blinker-p (APPLY #'make-blinker self blink-fl :follow-p t :deselected-visibility deselected-visibility (AND (CONSP blinker-p) blinker-p)))) (WHEN (mac-system-p) ;; Just mark the window as being a deactivated Mac window. Window id and such ;; will get allocated when it gets activated. Must also add its bit array to the mX's ;; *undisplaced-Mac-window-arrays* list. (SETF window-id t) (remember-bit-array self)) (SETF (sheet-output-hold-flag) 1) ;;;>>> changed char and erase aluf (OR (VARIABLE-BOUNDP char-aluf) (IF (color-system-p self) (SETQ char-aluf alu-transp) (SETQ char-aluf (IF reverse-video-p alu-back alu-transp)) )) (OR (VARIABLE-BOUNDP erase-aluf) (IF (color-system-p self) (SETQ erase-aluf alu-back) (SETQ erase-aluf (IF reverse-video-p alu-transp alu-back)) )) ;;; new code added to support color reverse video: (SETQ color-reverse-video-state reverse-video-p) ;;; now flip the colors if reverse-video is true. NOTE - check the instance variable, not the AUX variable, since the ;;; instance variable is inittable. (WHEN (AND color-reverse-video-state (color-system-p self)) (SEND self :complement-bow-mode) ) ;; Setup the color map based on who and what we are. (UNLESS color-map ;; If one already specified, don't change it. (IF (TYPEP self 'screen) ;; If we're a screen, we have our own copy. ;; Note: Doing a create-color-map here will give screens a color map with the Window System ;; version number, not the System version number (as is for *default-color-map*). See MAP.LISP (SETQ color-map (create-color-map)) ;; or (copy-color-map *default-color-map*)) (IF (NULL superior) ;; If no superior, which may never be the case??, get a copy from somewhere. (SETQ color-map (copy-color-map (OR (AND default-screen (sheet-color-map default-screen)) *default-color-map*))) ;; If our superior is a screen, make a copy of its map for us to use. This is the case for TOP ;; level windows (like the ZMACS frame or the Listener) . (IF (TYPEP (sheet-superior self) 'screen) (SETQ color-map (copy-color-map (sheet-color-map superior))) ;; Otherwise, we always want to get a pointer to our superior's map. (SETQ color-map (sheet-color-map superior)))))) ;; This is how it was being done for Release 3.2. The problem was each TOP level window (like the ZMACS ;; frame or the Listener) was getting a pointer to the screen's (mouse-sheet's) color map instead of a COPY ;; of it. 02/21/88 KJF ;;;;; >>> set up to make a color map on the superior screen, and copy it down to everyone else ;; (UNLESS color-map ;; (if (null superior) ;; (SETQ color-map (copy-color-map (OR (AND tv:mouse-sheet (sheet-color-map tv:mouse-sheet)) ;; *default-color-map*))) ;; ; else ;; (setq color-map (sheet-color-map superior)) ;; ) ;; ) (SEND self :update-time-stamp) self) )) #!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 :change-of-size-or-margins) (&rest options &aux top bottom left right new-height new-width old-x old-y (old-top-margin-size top-margin-size) (old-left-margin-size left-margin-size) delta-top-margin delta-left-margin (integral-p nil) (old-inside-width (sheet-inside-width)) (old-inside-height (sheet-inside-height)) (old-width width) (old-height height)) "Change some sheet parameters." (OR superior (NOT exposed-p) (FERROR nil "Cannot change size or margins of an exposed window with no superior")) (sheet-force-access (self) (erase-margins)) (SETQ old-x (- cursor-x left-margin-size) old-y (- cursor-y top-margin-size)) ;; Process options (doplist (options val op) (CASE op ((:top :y) (SETQ top val)) (:bottom (SETQ bottom val)) ((:left :x) (SETQ left val)) (:right (SETQ right val)) (:width (SETQ new-width val)) (:height (SETQ new-height val)) (:top-margin-size (SETQ top-margin-size val)) (:bottom-margin-size (SETQ bottom-margin-size val)) (:left-margin-size (SETQ left-margin-size val)) (:right-margin-size (SETQ right-margin-size val)) (:integral-p (SETQ integral-p val)) (otherwise (FERROR nil "~S is not a recognized option" op)))) (SETQ x-offset (OR left (IF right (- right (OR new-width width)) ;;ELSE x-offset))) (SETQ y-offset (OR top (IF bottom (- bottom (OR new-height height)) ;;ELSE y-offset))) (SETQ new-width (OR new-width (IF right (- right left) width))) (SETQ new-height (OR new-height (IF bottom (- bottom top) height))) (SETQ width new-width height new-height) ;; We need to deexpose all of our inferiors that won't fit anymore. (DOLIST (i exposed-inferiors) (OR (sheet-within-p i (sheet-inside-left) (sheet-inside-top) (sheet-inside-right) (sheet-inside-bottom)) (FUNCALL i :deexpose))) (WITHOUT-INTERRUPTS (sheet-force-access (self t) (MAPC #'open-blinker blinker-list)) (sheet-deduce-and-set-sizes right bottom (SEND self :vsp) integral-p) (SETQ cursor-x (MIN (+ left-margin-size old-x) (- width right-margin-size char-width))) (SETQ cursor-y (MIN (+ top-margin-size old-y) (- height bottom-margin-size line-height))) (DOLIST (bl blinker-list) (COND ((NULL (blinker-x-pos bl))) ((>= (blinker-x-pos bl) (sheet-inside-right)) (SETF (blinker-x-pos bl) (sheet-inside-left)))) ; Wrap blinker around (COND ((NULL (blinker-y-pos bl))) ((>= (blinker-y-pos bl) (sheet-inside-bottom)) (SETF (blinker-y-pos bl) (sheet-inside-top))))) (WHEN superior ;; A screen will have NIL for superior. 02/15/88 KJF ;; Don't let locations-per-line change without changing sheet's arrays also, if needed. ;; This handles cases of color/monochrome inconsistencies. ;; On microExplorer, locations-per-line may be arbitrary, but arrays will always be ;; the same (1 bit, until color on mExp. is available). So for now, on mExp., we only ;; need to make sure locations-per-line matches superior. 04/22/88 KJF. (IF (mac-window-p self) (SETF locations-per-line (sheet-locations-per-line superior)) ;; If superior is nil, we break. KJF ;; :sheet-legal-for-superior determines if any conversion needs to take place. ;; That is, if one is color and one is monochrome, a conversion may occur. ;; :sheet-legal-for-superior can convert in both directions. It looks at: ;; *convert-color-sheet-to-monochrome* 04/22/88 KJF (SEND self :sheet-legal-for-superior))) (WHEN bit-array ;; Handle the possibility of growing the window wider than its screen. So ;; long as the window is never activated & exposed, this causes no problems. ;; Visidoc requires this capability. 11/11/88 LG (LET* ((our-screen (sheet-get-screen self)) (pixels-per-location (FLOOR 32. (screen-bits-per-pixel our-screen))) (screen-width (* pixels-per-location (sheet-locations-per-line our-screen))) (width-to-use (MAX (* pixels-per-location (CEILING width pixels-per-location)) screen-width)) (locations-per-line-to-use (FLOOR width-to-use pixels-per-location))) (WHEN (> width-to-use screen-width) (SETF locations-per-line locations-per-line-to-use)) (SETQ bit-array (grow-bit-array bit-array width height width-to-use old-height old-width)))) (COND (superior ;;if we have a bit-array, SCREEN-ARRAY indirects to it, else ;; OLD-SCREEN-ARRAY indirects into our superior. (LET ((ARRAY (OR screen-array old-screen-array)) (indirect-to (OR (AND (NOT exposed-p) bit-array) (sheet-superior-screen-array)))) (WHEN (AND array indirect-to) (redirect-array array (ARRAY-ELEMENT-TYPE indirect-to) (ARRAY-DIMENSION indirect-to 1) height indirect-to (IF (AND bit-array (NOT exposed-p)) 0 (+ x-offset (* y-offset (ARRAY-DIMENSION indirect-to 1))))) (IF (OR bit-array exposed-p) (SETQ screen-array array old-screen-array nil) ;;ELSE (SETQ old-screen-array array screen-array nil)) (WHEN (mac-window-p self) (send-adjust-bit-array-maybe self t) (redirect-drawing-of-window-and-inferiors self)) ;; If the size of the top and/or left margin changed, move ;; the inside bits around. (SETQ delta-top-margin (- top-margin-size old-top-margin-size) delta-left-margin (- left-margin-size old-left-margin-size)) (COND ((AND (ZEROP delta-top-margin) (ZEROP delta-left-margin))) ;; Don't BITBLT some other guy's bits!! ((NULL screen-array)) (t ;; This should be BITBLT-WITH-FAST-PAGING, sometimes ;; it is not paged in. (OR exposed-p (page-in-pixel-array bit-array nil (LIST width height))) (BITBLT alu-seta (IF (PLUSP delta-left-margin) (- (sheet-inside-width)) ;;ELSE (sheet-inside-width)) (IF (PLUSP delta-top-margin) (- (sheet-inside-height)) ;;ELSE (sheet-inside-height)) array old-left-margin-size old-top-margin-size array left-margin-size top-margin-size) ;; If margins got smaller, may be space to clear out ;; on bottom and right. (AND (MINUSP delta-left-margin) (BITBLT erase-aluf (- delta-left-margin) (sheet-inside-height) array (+ (sheet-inside-right) delta-left-margin) (sheet-inside-top) array (+ (sheet-inside-right) delta-left-margin) (sheet-inside-top))) (AND (MINUSP delta-top-margin) (BITBLT erase-aluf (sheet-inside-width) (- delta-top-margin) array (sheet-inside-left) (+ (sheet-inside-bottom) delta-top-margin) array (sheet-inside-left) (+ (sheet-inside-bottom) delta-top-margin))))) (sheet-force-access (self) (erase-margins))) (AND temporary-bit-array (NEQ temporary-bit-array t) (SETQ temporary-bit-array (grow-bit-array temporary-bit-array width height width nil nil nil)))))) (SEND self :update-time-stamp) (OR (NOT (= old-inside-width (sheet-inside-width))) (NOT (= old-inside-height (sheet-inside-height)))))) )) #!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 :set-superior) (new-superior &aux active-p) "Make NEW-SUPERIOR the superior of self. Type of sheets are compared to see if they match. That is, if one is color and one is monochrome, then some conversion may take place." (OR (EQ new-superior superior) (delaying-screen-management (AND exposed-p (SEND self :deexpose)) (WITHOUT-INTERRUPTS (COND ((SETQ active-p (MEMBER self (sheet-inferiors superior) :test #'EQ)) ;; Remove us from our old superior's list of inferiors. (SETF (sheet-inferiors superior) (DELETE self (THE list (sheet-inferiors superior)) :test #'EQ)) (FUNCALL superior :order-inferiors) (screen-area-has-changed self))) ;; If moving window from one screen to another, remove window from the screens ;; copy of previously-selected-windows. 04/23/88 KJF ;; Only bother doing this if screen was created in normal way. That is, using ;; tv:make-a-screen or tv:create-color-screen. 04/26/88 KJF (WHEN (explorer-screen-p (sheet-get-screen self)) (UNLESS (EQ (sheet-get-screen new-superior) (sheet-get-screen self)) (remove-from-screens-previously-selected-windows self))) (SETQ superior new-superior) ;; Don't let locations-per-line change without changing sheet's arrays also, if needed. ;; This handles cases of color/monochrome inconsistencies. ;; On microExplorer, locations-per-line may be arbitrary, but arrays will always be ;; the same (1 bit, until color on mExp. is available). So for now, on mExp., we only ;; need to make sure locations-per-line matches new superior. 04/22/88 KJF. (IF (mac-window-p self) (SETF locations-per-line (sheet-locations-per-line new-superior)) ;; :sheet-legal-for-superior determines if any conversion needs to take place. ;; That is, if one is color and one is monochrome, a conversion may occur. ;; :sheet-legal-for-superior can convert in both directions. It looks at: ;; *convert-color-sheet-to-monochrome* 04/22/88 KJF (SEND self :sheet-legal-for-superior)) ;; Old code. :sheet-legal-for-superior will set locations-per-line. ;; If any conversion takes place, all inferiors will be fixed also, thus sometimes, ;; (SHEET-SET-SUPERIOR-PARAMS SELF LOCATIONS-PER-LINE) will be redundant. ;; 04/22/88 KJF ;; LOCATIONS-PER-LINE (SHEET-LOCATIONS-PER-LINE NEW-SUPERIOR)) (sheet-set-superior-params self locations-per-line) (LET* ((pixels-per-location (TRUNCATE 32. (screen-bits-per-pixel (sheet-get-screen self)))) (width-of-array (* pixels-per-location locations-per-line))) (COND (bit-array (SETQ bit-array (grow-bit-array bit-array width-of-array height width)) (redirect-array screen-array (ARRAY-ELEMENT-TYPE screen-array) width-of-array height bit-array 0)) (t (redirect-array old-screen-array (ARRAY-ELEMENT-TYPE old-screen-array) width-of-array height (sheet-superior-screen-array) (+ x-offset (* y-offset width-of-array))))) (WHEN (mac-window-p self) (send-adjust-bit-array-maybe self) (redirect-drawing-of-window-and-inferiors self))) (COND (active-p (sheet-consing (SETF (sheet-inferiors new-superior) (CONS self (COPY-LIST (sheet-inferiors new-superior))))) (FUNCALL new-superior :order-inferiors) (screen-area-has-changed self))) (SEND self :update-time-stamp))))) )) #!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.#" (DEFUN grow-bit-array (array width ; window's width height ; window's height &optional (real-width width) ; width to make the array old-height ; window's old height old-width ; window's old width (contents-matter t)) "Adjust size of ARRAY for a window of size WIDTH, HEIGHT, returning the adjusted array. REAL-WIDTH is the actual width to make the array. OLD-HEIGHT and OLD-WIDTH are the previous size of the window,, CONTENTS-MATTER says preserve the old contents if possible." (IF (AND (EQ height old-height) (EQ width old-width)) array ; only possible from :change-of-size-or-margins ;; else... (LET* ((wwidth (LOGAND #o-40 (+ real-width #o37))) ;Array's new width as even number of words. (narray (MAKE-ARRAY `(,height ,wwidth) ; New physical storage for new-size array. :type (ARRAY-TYPE array))) (awidth (ARRAY-DIMENSION array 1)) ; array width when called. (aheight (ARRAY-DIMENSION array 0)) ; array height when called. (color-system (UNLESS (TYPEP array '(ARRAY bit)) t)) (alu-initialize (IF color-system alu-back alu-setz))) ;; Tell the Mac the new size of this window... (WHEN (AND (mac-system-p) (TYPEP self 'sheet) (EQ array (tv:sheet-bit-array self))) (send-adjust-bit-array-maybe self contents-matter old-width old-height)) ;; Copy the old array's contents in the new array, cleaning up the rightmost and bottom ;; strips of the new array if it's the larger of the two... (WHEN contents-matter (si:page-in-array array) ;; First, copy the largest rectangular area that fits in both arrays... (IF (mac-window-p self) (si-bitblt alu-seta (MIN wwidth awidth) (MIN height aheight) array 0 0 narray 0 0) (BITBLT alu-seta (MIN wwidth awidth) (MIN height aheight) array 0 0 narray 0 0)) ;; Then initialize the portions of the new array not covered by this bitblt... (LET ((amount-new-window-is-wider-than-old (- wwidth awidth))) (WHEN (PLUSP amount-new-window-is-wider-than-old) (IF (mac-window-p self) (si-bitblt alu-initialize amount-new-window-is-wider-than-old height narray awidth 0 narray awidth 0) (BITBLT alu-initialize amount-new-window-is-wider-than-old height narray awidth 0 narray awidth 0)))) (LET ((amount-new-window-is-taller-than-old (- height aheight))) (WHEN (PLUSP amount-new-window-is-taller-than-old) (IF (mac-window-p self) (si-bitblt alu-initialize wwidth amount-new-window-is-taller-than-old narray 0 aheight narray 0 aheight) (BITBLT alu-initialize wwidth amount-new-window-is-taller-th