;;; -*- Mode: Common-Lisp; Package: User; Base: 10.; Patch-File: T -*- ;;; Reason: Change the value of the COPY-FROM-PARENT constant to be 0 ;;; rather than 1, so that it agrees with the X11 spec. ;;; 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 10/12/89 15:17:23 by HAGY, ;;; while running on Zwingli from band LOD2 ;;; With SYSTEM 6.20, 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.4, NETWORK-NAMESPACE 6.0, ;;; DISK-IO 6.1, DISK-LABEL 6.0, BASIC-FILE 6.4, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.0, ;;; COMPILER 6.12, TV 6.15, DATALINK 6.0, CHAOSNET 6.1, 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.7, ;;; 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.2, ;;; IMAGEN 6.1, SUGGESTIONS 6.0, MAIL-DAEMON 6.3, MAIL-READER 6.5, TELNET 6.0, VT100 6.0, ;;; NAMESPACE-EDITOR 6.3, PROFILE 6.2, VISIDOC 6.5, TI-CLOS 6.25, CLEH 6.5, IP 3.54, ;;; Experimental CLX 6.4, CLUE 6.23, X11M 6.14, Experimental BUG 11.15, microcode 429, ;;; Band Name: Rel 6.0 + SLE 9/8 #!C ; From file DEFS.LISP#> X11M.SERVER; Hotel: #10R X11#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "X11")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* SYS:COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: X11M.SERVER; DEFS.#" (defconstants (0 Universal-None Any-Property-Type Any-Non-Modifier Any-Key Any-Button All-Temporary The-Current-Time No-Symbol Copy-From-Parent) (1 Parent-Relative Pointer-Root)) )) #!C ; From file WINDOW.LISP#> X11M.SERVER; Hotel: #10R X11#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "X11")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* SYS:COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: X11M.SERVER; WINDOW.#" (defun window-background (window) (loop for back = (window.background-pixmap window) while (eql back Parent-Relative) do (unless (setq window (window.parent window)) (return universal-none)) finally (return back))) )) ;************************************************************************************** ; NOTE: The remainder of this patch only recompiles code that uses Copy-From-Parent. ; No more actual source changes are involved. ;************************************************************************************** #!C ; From file SERVER-DEFS.LISP#> X11M.SERVER; Hotel: #10R X11#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "X11")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* SYS:COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: X11M.SERVER; SERVER-DEFS.#" (defstruct (WINDOW (:include drawable) (:conc-name "WINDOW.") (:print-function print-window-structure) ;; Speed creation of window's #+explorer (:callable-constructors nil) ) visual class ; One of Inherit-From-Parent Input-Output or Input-Only. (parent nil) ;; number of window-locks here and below, or process if tree-locked here (busy-tree 0) ;; window-lock process active here, if any (busy-here nil) (next-sib nil) (prev-sib nil) (first-child nil) (last-child nil) ;; A list of OTHER-CLIENTs. The state indicates which connection and the masks ;; indicate which events are of interest. Other information is stored in the ;; OTHER-CLIENTs structure. (event-masks nil) ;; A collection of all of the masks in event-masks. (all-event-masks 0 :type integer) ;; I'm not sure what to do about this, specifically if this should have the same ;; organization as event-masks or not. (deliverable-events 0 :type integer) (passive-grabs nil :type t) ; :type (or null grab-record) ;; (attributes NIL) ;; window attributes (background-pixmap Universal-None) (background-pixel nil) ; No default specified (border-pixmap Copy-From-Parent) (border-pixel nil) ; No default specified (bit-gravity Forget-Gravity) (win-gravity North-West-Gravity) (backing-planes -1) (backing-pixel 0) (do-not-propagate-mask nil) ; Empty set (override-redirect False) (colormap Copy-From-Parent) (cursor nil :type t) ; :type (or null cursor-record) NIL means use parent's cursor. (backing-Store-Support Store-Not-Useful :type Store-Type) (save-Under-Support false :type bool) (properties nil) ;; Location of the upper left-hand part of the border relative to the ;; root. Note that this is not the absolute location of the window's ;; origin (i.e. the location of the part of the window which can be ;; drawn upon) since this position includes the borders. Use the ;; accessors which follow this defstruct to obtain other absolute ;; coordinate values, such as absolute-inside-x (which is the absolute ;; location of the window's origin). absolute-x-corner absolute-y-corner ;; Location of the upper left-hand part of the border relative to the ;; parent's origin. This is the same as the absolute coordinates if this ;; window is a direct inferior of the root. x y ;; Width and height of the interior part of the window. width height ;; Width of the border. bwidth ;; NIL means that this window and its inferiors are never viewable or visible. ;; T means that this window ans its inferiors can be viewable or visible. (mapped-p nil) (realized-p nil) ;; List of box objects which represent regions on the screen in which ;; parts of this window can appear. The cases are: ;; NIL means that this window is not visible at all. ;; T represents `fully visible'. This is a performance hack. There is no ;; real need to cons up a box just to put the windows dimensions in it. Hopefully ;; this will be the normal case. If it becomes too much of a problem to implement ;; then this special case should be removed. ;; LIST a list of box objects through which the window will be displayed on the screen. ;; This list could also be viewed as an extension to the clipping region list, ;; since the meaning is identical. NIL has the same meaning too, but T does not, ;; hence the caveat about its implementation. (occlusion-stack nil) ;; Clip mask that shows contains 1's where this window's children are not ;; present and 0's where the children are. The origin of this is 0 0, ;; relative to the window's origin. (child-clip-mask nil) ;; The client that created this window. (client nil :type (or null state)) ;;(marked nil :type boolean) ;; Not used; purpose unknown??? - \/\/ (exposures nil) ;; list of newly exposed regions ;; A pixmap for the saved window contents when it is not visible. (backing-store nil) (backing-store-valid nil) (invalid-box nil :type (or null t box)) ;; NIL when screen is up-to-date, t when not, ;; else a box containg the region not updated. ) )) #!C ; From file WINDOW.LISP#> X11M.SERVER; Hotel: #10R X11#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "X11")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* SYS:COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: X11M.SERVER; WINDOW.#" (defun window-border (window) (loop for border = (window.border-pixmap window) while (eql border Copy-From-Parent) do (unless (setq window (window.parent window)) (return universal-none)) finally (return border))) )) #!C ; From file WINDOW-REQUESTS.LISP#> X11M.SERVER; Hotel: #10R X11#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "X11")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* SYS:COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: X11M.SERVER; WINDOW-REQUESTS.#" (defun change-window-attributes (window state value-mask longs index) (server-trace-value-mask value-mask longs index '#( Back-Pixmap Back-Pixel Border-Pixmap Border-Pixel Bit-Gravity Win-Gravity Backing-Store Backing-Planes Backing-Pixel Override-Redirect Save-Under Event-Mask Dont-Propagate Colormap Cursor)) (if (and (eql (window.class window) Input-Only) (logtest value-mask (lognot (logior CW-Win-Gravity CW-Event-Mask CW-Override-Redirect CW-Dont-Propagate CW-Cursor)))) (Bad-Match) ;;ELSE (process-values (value-mask longs index) (val) (((CW-Back-Pixmap (ONEOF PIXMAP Universal-None Parent-Relative) val :errors) (cond ((and (eql val Parent-Relative) (window.parent window) (not (eq (drawable.trait window) (drawable.trait (window.parent window))))) (Bad-Match)) ((and (not (member val '(#,Universal-None #,Parent-Relative))) (not (eq (drawable.trait window) (drawable.trait val)))) (Bad-Match)) ((pixmap-p val) (setf (window-background window) (tile-pixmap val)) nil) ((and (null (window.parent window)) (member val '(#,universal-none #,parent-relative))) ;; Restore the default root background (setf (window-background window) root-background-pixmap)) (t (setf (window-background window) val) nil))) ((CW-Back-Pixel CARD32) ;; We have a background pixel. Create a pixmap ;; that just contains that pixel. (setf (window-background window) (create-pixmap window 1 1 (drawable-depth window) val)) ;; Save the pixel value away too, just in case we need it. (setf (window.background-pixel window) val)) ((CW-Border-Pixmap (ONEOF PIXMAP Copy-From-Parent) val :errors) (cond ((and (eql val Copy-From-Parent) (window.parent window) (not (eq (drawable.trait window) (drawable.trait (window.parent window))))) (Bad-Match)) ((and (not (eql val Copy-From-Parent)) (not (eq (drawable.trait window) (drawable.trait val)))) (Bad-Match)) ((pixmap-p val) (setf (window-border window) (tile-pixmap val)) (draw-borders window) nil) (t (setf (window-border window) val) (draw-borders window) nil))) ((CW-Border-Pixel CARD32 val) ;; We have a border pixel. Create a pixmap that just contains that pixel. (setf (window-border window) (create-pixmap window 1 1 (drawable-depth window) val)) ;; Save the pixel value away too, just in case we need it. (setf (window.border-pixel window) val) (draw-borders window)) ((CW-Bit-Gravity (CARD8 Forget-Gravity North-West-Gravity North-Gravity North-East-Gravity West-Gravity Center-Gravity East-Gravity South-West-Gravity South-Gravity South-East-Gravity Static-Gravity)) (setf (window.bit-gravity window) val)) ((CW-Win-Gravity (CARD8 Unmap-Gravity North-West-Gravity North-Gravity North-East-Gravity West-Gravity Center-Gravity East-Gravity South-West-Gravity South-Gravity South-East-Gravity Static-Gravity)) (setf (window.win-gravity window) val)) ((CW-Backing-Store (CARD8 Store-Not-Useful Store-When-Mapped Store-Always)) (setf (window.backing-store-support window) val)) ((CW-Backing-Planes CARD32) (setf (window.backing-planes window) val)) ((CW-Backing-Pixel CARD32) (setf (window.backing-pixel window) val)) ((CW-Override-Redirect BOOL) (setf (window.override-redirect window) val)) ((CW-Save-Under BOOL) (setf (window.save-under-support window) val)) ((CW-Event-Mask (MASKBITS All-Event-Masks ;; The progn says to evaluate the ;; Event-Mask-Length-Type to read ;; in the proper number of bits. (progn Event-Mask-Length-Type))) ;; I commented the following line out after seeing that the C code only calls ;; EVENT-SELECT-FOR-WINDOW. (twe) ;;(setf (window-event-masks window) val) ;;(server-trace "~%$$IN CHANGE-WINDOW-ATTRIBUTES-EVENT-MASK: value= ~s" ;;(xlib:make-event-keys val)) (EVENT-SELECT-FOR-WINDOW WINDOW STATE VAL) ) ((CW-Dont-Propagate (MASKBITS (if *mit-compatibility* All-Event-Masks All-Device-Event-Masks) ;; The progn says to evaluate the ;; Device-Event-Masks-Length-Type to ;; read in the proper number of bits. (progn Event-Mask-Length-Type))) (setf (window-dont-propagate window) (logand All-Device-Event-Masks val))) ;;This needs to check for visual and generate a ColorMapNotify Event. ((CW-Colormap (ONEOF COLORMAP Copy-From-Parent) val :errors) (LET ((cmap val)) (WHEN (EQL cmap Copy-From-Parent) (IF (AND (window.parent window) (EQ (window.visual window) (window.visual (window.parent window)))) (SETQ cmap (window.colormap (window.parent window))) ;;ELSE (SETQ cmap nil))) (COND ((NOT cmap) (bad-match)) ((NOT (EQ (window.visual (colormap.window cmap)) (window.visual window))) (bad-match)) ((NOT (EQ cmap (window.colormap window))) (Colormap-Notify-Event window cmap T (if (member (window.colormap window) *installed-colormaps*) colormap-installed ;;ELSE colormap-uninstalled)) nil)))) ((CW-Cursor (ONEOF CURSOR Universal-None)) (COND ((EQL val Universal-None) ;;install the new #+comment ;; reference count is not maintained (when (window.cursor window) (Free-Cursor (window.cursor window))) (IF (null (window.parent window)) ;; if the root (progn (SETF (window.cursor window) root-cursor) #+comment ;; reference count is not maintained (INCF (cursor-record.ref-count root-cursor))) ;;ELSE (SETF (window.cursor window) nil))) (t (when val #+comment ;; reference count is not maintained (when (window.cursor window) (Free-Cursor (window.cursor window))) (SETF (window.cursor window) val)))) (Window-Has-New-Cursor window)))))) )) #!C ; From file WINDOW-REQUESTS.LISP#> X11M.SERVER; Hotel: #10R X11#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "X11")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* SYS:COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: X11M.SERVER; WINDOW-REQUESTS.#" (defreq Get-Window-Attributes ((window WINDOW)) (with-window-locked (window) (MULTIPLE-VALUE-BIND (your-mask all-masks) (Event-Mask-for-Client window state) (let ((colormap (loop for win first window then (window.parent win) for colormap = (window.colormap win) unless (OR (eql colormap Copy-From-Parent) (eql colormap Universal-None)) do (return (colormap.id colormap))))) (format-reply (state) :byte (window.backing-store-support window) :long (window.visual window) :word (window.class window) :byte (window.bit-gravity window) :byte (window.win-gravity window) :long (window.backing-planes window) :long (window.backing-pixel window) :byte (window.save-under-support window) :byte (if (member colormap *installed-colormaps*) True False) :byte (COND ((NOT (window.mapped-p window)) Window-Is-Unmapped) ((ancestors-mapped window) Window-Is-Viewable) (t Window-Is-Unviewable)) :byte (window.override-redirect window) :long colormap :long all-masks :long your-mask :word (window-dont-propagate window)))) (server-push state))) )) #!C ; From file WINDOW-REQUESTS.LISP#> X11M.SERVER; Hotel: #10R X11#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "X11")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* SYS:COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: X11M.SERVER; WINDOW-REQUESTS.#" (defreq Create-Window ((depth CARD8) (window NEWID) (parent WINDOW) (x INT16) (y INT16) (width (CARD16 0)) (height (CARD16 0)) (border-width CARD16) (class (CARD16 Inherit-From-Parent Input-Output Input-Only)) (visual CARD32) (value-mask (BITMASK All-Window-Attribute-Masks)) (:long)) (when (eql visual Inherit-From-Parent) (setq visual (window.visual parent))) (when (eql class Inherit-From-Parent) (setq class (window.class parent))) (when (and (zerop depth) (eql class Input-Output)) (setq depth (drawable-depth parent))) (let* ((trait (find depth (screen.traits (drawable-screen parent)) :key #'drawable-trait.depth)) (window-instance nil)) (cond ((and (plusp depth) (null trait)) (Bad-Value depth)) ((AND trait (not (member visual (drawable-trait.visuals trait)))) (Bad-Value visual)) ((AND (eql class Input-Output) (eql (window.class parent) Input-Only)) (Bad-Match)) ((AND (EQL class Input-Only) (or (plusp border-width) (plusp depth))) (bad-match)) ; ((if (eql class Input-Output) ; (eql (window.class parent) Input-Only) ; (or (plusp border-width) (plusp depth))) ; (Bad-Match)) (t (SETQ WINDOW-INSTANCE (MAKE-WINDOW :ID WINDOW :TYPE Draw-Window-Resource-Type :TRAIT (WINDOW.TRAIT PARENT) :CLIP-MASK NIL :VISUAL VISUAL ;; What is this? For now, let's ;; just copy the parent's trait. :CLASS CLASS :PARENT PARENT :ABSOLUTE-X-CORNER (+ (WINDOW.ABSOLUTE-INSIDE-X PARENT) X) :ABSOLUTE-Y-CORNER (+ (WINDOW.ABSOLUTE-INSIDE-Y PARENT) Y) :X X :Y Y :WIDTH WIDTH :HEIGHT HEIGHT :BWIDTH BORDER-WIDTH :CLIENT STATE)) (WITH-TREE-LOCKED (PARENT) ;; Shuffle the first child down to the sibbling for this window and ;; make this window the parent's first child. The idea is to make ;; this window be at the top of the occlusion stack which is defined ;; by the sibbling ordering. Use the following figure to aid in ;; understanding how this is being updated. Assume the worst case of ;; a parent with three children: W1, W2 and W3. We are inserting W ;; into this structure. There are only four components of interest ;; here, with the initial value of a component appearing on the left ;; and if a component changes, the new value appears to the right of ;; the -->. It is left up to the reader to verify that the cases of ;; a parent with no children and 1 child work too. ;; W ;; .-------------. ;; first child | | ;; |-------------| ;; last child | | ;; |-------------| ;; next sib | NIL --> W1 | ;; |-------------| ;; prev sib | NIL --> W3 | ;; `-------------' ;; ;; .-------------. ;; first child | W1 --> W | W1 ;; |-------------| .-------------. ;; last child | W3 | first child | | ;; Parent |-------------| |-------------| ;; next sib | | last child | | ;; |-------------| |-------------| ;; prev sib | | next sib | W2 | ;; `-------------' |-------------| ;; prev sib | W3 --> W | ;; `-------------' ;; ;; ;; W2 ;; .-------------. ;; first child | | ;; |-------------| ;; last child | | ;; |-------------| ;; next sib | W3 | ;; |-------------| ;; prev sib | W1 | ;; `-------------' ;; ;; ;; W3 ;; .-------------. ;; first child | | ;; |-------------| ;; last child | | ;; |-------------| ;; next sib | W1 --> W | ;; |-------------| ;; prev sib | W2 | ;; `-------------' (let ((first-child (or (window.first-child parent) window-instance)) (last-child (or (window.last-child parent) window-instance))) (setf (window.next-sib window-instance) first-child) (setf (window.prev-sib window-instance) last-child) (setf (window.prev-sib first-child) window-instance) (setf (window.next-sib last-child) window-instance) (when (null (window.first-child parent)) ;; The parent previously had no children. This window becomes both ;; the first and last child. (setf (window.last-child parent) window-instance) ;; the window is its own next and previous sibling (setf (window.prev-sib window-instance) window-instance) (setf (window.next-sib window-instance) window-instance)) (setf (window.first-child parent) window-instance))) (STORE-RESOURCE WINDOW WINDOW-INSTANCE) ;; Set up the default attributes. (SETF (WINDOW-BACKGROUND WINDOW-INSTANCE) UNIVERSAL-NONE) (SETF (WINDOW-BORDER WINDOW-INSTANCE) COPY-FROM-PARENT) (SETF (WINDOW.BIT-GRAVITY WINDOW-INSTANCE) FORGET-GRAVITY) (SETF (WINDOW.WIN-GRAVITY WINDOW-INSTANCE) NORTH-WEST-GRAVITY) (SETF (WINDOW.BACKING-STORE-SUPPORT WINDOW-INSTANCE) STORE-NOT-USEFUL) (SETF (WINDOW.BACKING-PLANES WINDOW-INSTANCE) -1) (SETF (WINDOW.BACKING-PIXEL WINDOW-INSTANCE) 0) (SETF (WINDOW.SAVE-UNDER-SUPPORT WINDOW-INSTANCE) FALSE) (SETF (WINDOW-EVENT-MASKS WINDOW-INSTANCE) 0) (SETF (WINDOW.DO-NOT-PROPAGATE-MASK WINDOW-INSTANCE) NIL) (SETF (WINDOW.OVERRIDE-REDIRECT WINDOW-INSTANCE) FALSE) (IF (OR (EQL class Input-Only) (NOT (EQL visual (window.visual window-instance)))) (SETF (window.colormap window-instance) UNIVERSAL-NONE) (SETF (window.colormap window-instance) COPY-FROM-PARENT)) (SETF (WINDOW.CURSOR WINDOW-INSTANCE) nil) ;;(server-trace "~%IN CREATE-WINDOW: value-mask= ~s cw-event-mask= ~s" ;;(xlib:make-event-keys value-mask) (xlib:make-event-keys cw-event-mask)) (WHEN (NOT (LOGTEST VALUE-MASK CW-EVENT-MASK)) ;; The user didn't specify an event mask, we need to initialize this guy to 0. (EVENT-SELECT-FOR-WINDOW WINDOW-INSTANCE STATE 0)) ;; Process the value-mask in change-window-attributes. (CHANGE-WINDOW-ATTRIBUTES WINDOW-INSTANCE STATE VALUE-MASK LONGS LONG-OFFSET) ;??? (Window-Has-New-Cursor window-instance) (Create-Notify-Event window-instance parent x y width height border-width (window.override-redirect window-instance)))) window-instance)) ))