;;; -*- Mode:Common-Lisp; Package:X11; Base:10; Fonts:(MEDFNB HL12B HL12BI) -*-

;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151
;;;
;;; Copyright (C) 1987, Texas Instruments Incorporated. All rights reserved.

;;; Change history:
;;;
;;;  Date       Author	Description
;;; -------------------------------------------------------------------------------------
;;; 03/29/89	WJB	Patch 1.61; Add variable *DEBUG-CLIENT-CONNECTIONS-P*
;;; 03/29/89	WJB	Patch 1.60; changed screen width/height constants to variables.  Added
;;;			INITIALIZE-SCREEN-SIZES to be called during initialization. 
;;; 02/01/89	WJB	Patch 1.4: Added window.exposures slot and deleted usless window.marked slot
;;; 01/19/88    LGO     Change *IMAGE-BYTE-ORDER* to LSB-FIRST
;;; 01/18/88	LGO	Correct the value of *bitmap-format-scanline-unit*
;;; 01/13/89    DKM     Fudged *screen-heights-in-millimeters* so mm height/width match pixel ratio
;;; 12/23/88	LGO	Add the selection structure.
;;; 12/22/88	LGO	Correct the value of *screen-save-unders*
;;; 12/22/88	LGO	Correct the value of *screen-heights-in-millimeters*
;;; 12/19/88	WJB	Removed type specifiers from several slots to avoid compiler warnings.
;;;			Move PIXMAP defresource after GCONTEXT defstruct to avoid compiler warnings
;;; 12/119*/88    LGO     1change deftype for bool from (satisfies to-or-nil) to (member 0 1)*
;;; 12/119*/88    LGO     1Eliminate the window.attributes slot, replacing it with seperate slots for each attribute.*
;;; 12/16/88    LGO     Change *bitmap-format-bit-order* to LSB-FIRST
;;; 12/08/88    LGO     Replace gcontext.rectangle-list with gcontext.clip-rectangle
;;; 12/07/88	LGO	Ensure gcontexts are created with 0,0 pattern and clip origins.
;;; 11/218*/88	LGO	1Fix format-event to enqueue events, rather than write them directly to the client*
;;; 11/23/88	LGO	1Remove kludge in process-values that prevents arguments to maskbits from being evaluated at run-time*
;;; 11/23/88	LGO	Expand make-gcontext 1and make-window *inline
;;; 11/02/88	WJB	Fixed bug in WITH-CURSOR-LOCKED causing permanent server hangs.
;;; 10/25/88	WJB	Change DEFREQ :graphics option to check for window or drawable arg.
;;; 10/18/88	WJB	Add CURSOR-RECORD.LOCK slot.
;;; 10/18/88	WJB	Initialize height and width of pixmap resources to the size requested
;;;			although the array size returned may be larger.
;;; 10/17/88	LGO	Nuke  *FONT-INITIAL-SEARCH-PATH-STRINGS* and
;;;			*FONT-DEFAULT-SEARCH-PATH-STRINGS*
;;; 10/11/88	WJB	Changed order of arguments to perform-graphics and added 
;;;			cursor remove/restore code.
;;; 10/10/88    LGO	Add the xwindow-children loop iteration path
;;; 10/10/88    LGO	Add the xwindow-children1-reverse* loop iteration path
;;;  9/219*/88    1LGO*	1delete resource.lisp, moving add-resource and free-resource here.*
;;;  9/219*/88    1LGO*	1Delete* the *AVAILABLE-HASH-TABLES*1 variable.*
;;;  9/219*/88    1LGO*	1Fix remove-resource to properly maintain resource cache*
;;;  9/27/88    WJB	Fixed FONT-INFO-RECORD struct to allow null METRICS slot.
;;;  9/23/88    LGO	Add server-trace to DEFREQ to make trace more readable.
;;;  9/22/88    LGO	Add DESCRIPTION and PLIST slots to the STATE structure.
;;;  9/20/88    LGO	Remove *keycode-offset* *min-keycode* and *max-keycode*
;;;  9/20/88    LGO	White pixel is #xFFFF, not 1 in make-colormap
;;;  9/14/88    LGO	Make x-Char-Info an art-half-fix array
;;;  9/14/88    LGO	1Rework font data structures to eliminate char-info-record, using x-char-info instead.*
;;;			1Character metrics are now a slot of *Font-Info-record1 and are vector instead of a list.*
;;;  9/12/88    LGO	Rename installed-colormaps to *installed-colormaps*
;;;  9/12/88    LGO	Use floor instead of / to avoid rationals in format-reply
;;;  8/25/88	WJB	Changes to CR-PRIVATE to support new (working) cursor tracking.
;;;  8/24/88    DAN     Added REMOVE-RESOURCE.
;;;  8/12/88    DAN     Made GCONTEXT a RESOURCE.
;;;  7/26/88    DAN	Added *DEFAULT-CURSOR-FONT* for CREATE-ROOT-CURSOR and added
;;;			INV-GCONTEXT slot to FRAME-BUFFER-DESCRIPTOR structure.
;;;1 * 7/13/881   *  DAN	Changed *MONOCHROME-SERVER-TRACE-ENABLED* to default to NIL.
;;;			added new variables to save the string representation of font
;;;			paths.
;;;  7/07/88	WJB	Modified WINDOW and SCREEN defstructs to use :print-function option.
;;;  6/16/881   *  DAN	Changed SIMPLE-RESOURCE-ID-FUNCTION to start with the largest
;;;			available number and decrement for each call.
;;;  6/16/88    WJB	Changes to clean up build procedure.
;;;  6/01/88    TWE	Defined the variable *AVAILABLE-HASH-TABLES* to handle hash
;;;			tables for connections better.
;;;  5/31/88    TWE	Fixed CREATE-INITIAL-SCREEN-CONFIGURATION so that it also creates
;;;			a value for the background attribute for the root window.
;;;  5/27/88    TWE	Fixed defreq to handle multiple byte fields at the beginning of
;;;			the request.
;;;  5/05/88    TWE	Changed PRINT-WINDOW-HIERARCHY to not need an argument.
;;;  4/27/88    TWE	Changed reference to GET-ATOM to use GET-ATOM-ID instead.
;;;			Changed EVENT-VALUE-TRANSFORM to not transform atoms, they are
;;;			already IDs.
;;;  4/26/88    TWE	Changed *SCREEN-HEIGHTS-IN-PIXELS* to use X-SCREEN-HEIGHT instead
;;;			of a hardcoded constant.  Likewise for *SCREEN-WIDTH-IN-PIXELS*.
;;;  4/20/88    KDB	Included the RESOURCE structure in CURSOR-RECORD.
;;;  4/18/88    TWE	Fixed OCCLUSION-STACK-TO-LIST to take into account that the
;;;			window may not be completely within its parent.
;;;  4/13/881   *  DAN	Moved STORE-ATOM and GET-ATOM to ATOM-PROPERTY-REQUESTS file.
;;;			Changed ATOMS slot of GLOBAL-STATE defstruct to be a list.
;;;			Changed ATOM-CHECK to use new GLOBAL-STATE.ATOMS structure.
;;;  4/08/88    TWE	Fixed print-window-hierarchy to use the new meaning of *GLOBALS*.
;;;  4/08/88    TWE	Wrote OCCLUSION-STACK-TO-LIST because I got tired of coding this
;;;			inline.
;;;  4/04/88    TWE	Wrote WINDOW.C-NEXT-SIB to do a WINDOW.NEXT-SIB the C way.
;;;  3/28/88    TWE	Added the MARKED slot to the window structure.
;;;  3/25/88    TWE/DAN	Fixed up the screen and root window initialization.  Fixed
;;;			ROOT-FOR-WINDOW and SCREEN-FOR-WINDOW to be independent of the
;;;			resource hash table.
;;;  3/11/88    DAN	1Fixed *format-reply1 to convert the length field to a count of LONGS instead of BYTES.*
;;;  3/07/88    TWE	Moved some function nearer to the end of the file to get rid of
;;;			some compiler warnings.
;;;  3/04/88    TWE	Added the client-gone slot to STATE.  Fixed up
;;;			EVENT-VALUE-TRANSFORM for FORMAT-EVENT to check the value before
;;;			looking up the ID.  Fixed up FORMAT-EVENT to calculate the length
;;;			properly.
;;;  3/03/88    TWE	Added cursor private data structure.  Set up the 
;;;			frame-buffer-descriptor data structures.
;;;  3/02/88    TWE	Fixed ROOT-FOR-WINDOW to get the root window properly.  Wrote
;;;			SCREEN-FOR-WINDOW to get the screen for a window.
;;;  3/01/88    TWE	Fixed up WINDOW defstruct to not have any unbound slots.
;;;  2/29/88    TWE	Added byte specifier to get client number out of a resource-id.
;;;  2/24/88    TWE	Coded format-event to ship out events.  Extended format-event to
;;;			handle :WINDOW and :BOOLEAN short forms.
;;;  2/22/88    TWE	Put type declarations in the SCREEN-INFO structure.
;;;  2/19/88    TWE	Changed trace code to call the server-trace function instead.
;;;			Also added the ALL-EVENT-MASKS and CLIENT slots to window.  Added
;;;			a function SCREEN-ROOT-WINDOW.  Added fake-id slot to state.
;;;  2/15/88    TWE	Added a screen-info defstruct.  Added cursor slot to window.
;;;  2/11/88    TWE	Added a new slot to the window data structure which is a
;;;			clip-mask for the window's children.
;;;  2/05/88    TWE	Updated comment in the window slot event-masks.
;;;  1/22/88    TWE	Updated comments on clipping and added the function
;;;			print-window-hierarchy.
;;;  1/13/88    TWE	Changed references to tv:initial-lisp-listener to
;;;			*monochrome-server-trace*.
;;;  1/12/88    TWE	Changed print-object to look up the object in the resource, if it
;;;			is given a resource id.
;;; 12/28/87  1   *KDB	1Set max and min-installed-colormap values to 1. Commented out gc and colormap procedures*
;;; 12/21/87    TWE	Added the occlusion-stack slot to the window defstruct.  Moved
;;;			the defstruct to its own file, which deals specifically with
;;;			boxes.
;;; 12/16/87    TWE	Added the function print-object to allow one to see recursive
;;;			structures like windows with children.  Added a slot to window
;;;			for the backing store.
;;; 12/15/87    TWE	Added a save-set slot to the state defstruct.  Hopefully that is
;;;			the correct place to put that information.

(defvar *mit-compatibility* t
  "2There are bugs in the MIT sample server that some client programs depend on.
 When this is T, do things the same as the MIT server, else go by the protocol spec.*")2 *

(defvar *debug-client-connections-p* nil
  "When T, allow network errors to happen instead of catching them.")

;;; place-holder for binding the global-state for a collection of servers
(defvar *globals*)

;;; the request opcode dispatch table for executing a little-endian request
(defvar *little-endian-table* (make-array 256 :initial-element 'illegal-request))

;;; the request opcode dispatch table for executing a big-endian request
(defvar *big-endian-table* (make-array 256 :initial-element 'illegal-request))

;;; place-holder for binding server state (used mostly for errors)
(defvar *state*)

;;; place-holder for binding current major opcode (used for errors)
(defvar *major-opcode*)

;;; place-holder for binding delayed tree unlocking
(defvar *delayed-tree-busies*)

(defparameter *last-Event-Time* (Get-Time-In-Millis)
  "Time (in ms.) of last event")

(defvar *windows-needing-refresh* nil
  "2List of windows needing refresh from backing store*")

(defparameter bell-function 'noisy-bell
  "Function which implements the bell.")

(defenum (Core None)
         :suffix Resource-Class)

(defenum (Draw-Window No-Draw-Window Pixmap Temporary-Bitmap Cursor Font GContext Colormap
                      Fake)
	 :suffix Resource-Type
	 :mask-p t)

;;; define essential X types for use in DEFREQ and PROCESS-VALUES

(defmacro defxtype (name size &optional fixup check)
  `(progn
     (defprop ,name ,size :length)
     (defprop ,name ,fixup :fixup)
     (defprop ,name ,check :check)))


;;; The progn is to "hide" these definition from ZMACS so M-. finds the defstruct
(progn
  (defxtype WINDOW   4 drawable-hash  window-check)
  (defxtype PIXMAP   4 drawable-hash  pixmap-check)
  (defxtype GCONTEXT 4 gcontext-hash  gcontext-check)
  (defxtype COLORMAP 4 resource-hash  colormap-check)
  (defxtype DRAWABLE 4 drawable-hash  drawable-check)
  (defxtype RESOURCE 4 resource-hash  resource-check)
  (defxtype DEVICE   4 nil            device-check))

(defxtype CURSOR   4 resource-hash  cursor-check)
(defxtype FONT     4 resource-hash  font-check)
(defxtype PIXWIN   4 drawable-hash  pixwin-check)
(defxtype FONTABLE 4 resource-hash  fontable-check)
(defxtype NEWID    4 nil            newid-check)
(defxtype KEYBOARD 4 nil            keyboard-check)
(defxtype POINTER  4 nil            pointer-check)
(defxtype ATOM     4 nil            atom-check)
(defxtype INT8     1 sign-extend-8  range-check)
(deftype int8 () '(signed-byte 8))
(defxtype INT16    2 sign-extend-16 range-check)
(deftype int16 () '(signed-byte 16))
(deftype int32 () '(signed-byte 32))
(defxtype CARD8    1 nil            member-check)
(deftype card8 () '(unsigned-byte 8))
(defxtype CARD16   2 nil            member-check)
(deftype card16 () '(unsigned-byte 16))
(defxtype CARD32   4 nil            member-check)
(deftype card32 () '(unsigned-byte 32))
(defxtype BOOL     1 nil            bool-check)
(deftype  BOOL     ()  '(member 0 1))
(defxtype TIMESTAMP 4)
(defxtype ONEOF oneof-length oneof-fixup oneof-check)
(defxtype BITMASK bitmask-length nil bitmask-check)
(defxtype MASKBITS maskbits-length nil maskbits-check)
(defxtype EVENT 32 nil nil)
(defxtype KEYCODE  1 nil keycode-check)
(deftype  keycode () '(integer 8 #.(1- (EXPT 2 8))))


;; snatched from CLX1:*
(proclaim '(inline CARD16->INT16 aref-int16))
(DEFUN CARD16->INT16 (X)
  (DECLARE (TYPE CARD16 X))
  (THE INT16 (IF (LOGBITP 15 X)
		 (THE INT8 (- X #x10000))
		 X)))

(defun AREF-INT16 (A I)
  (CARD16->INT16 (AREF A I)))

(defstruct (resource (:conc-name "RESOURCE."))
  id
  type)                                ; a Resource-Type (defined in this file (go up a few lines))

(defmacro defres-p (&rest names)
  `(progn
     . ,(loop for name in names
	      collect `(defsubst ,(intern (concatenate 'simple-string  "IS-" (symbol-name name) "-P")) (res)
			 (eql (resource.type res)
			      ,(intern (concatenate 'simple-string (symbol-name name) "-RESOURCE-TYPE")))))))

(defres-p Draw-Window No-Draw-Window Pixmap Cursor Font GContext Colormap)

(defstruct (response (:CONC-NAME "RESPONSE."))
  bytes
  words
  longs
  chain)

(defresource response (length) :constructor (cons-response length))

(defsubst alloc-response (&optional (length Response-Length))
  (allocate-resource 'response length))

(defsubst dealloc-response (res)
  (deallocate-resource 'response res #+Symbolics (length (response.bytes res))))

(defresource event () :constructor (cons-response))

(defsubst alloc-event ()
  (allocate-resource 'event))

(defsubst dealloc-event (res)
  (deallocate-resource 'event res))

(defconstant *default-buffer-size* 4096.)

(defconstant *max-reply-length* 52.)

;;; Allocate a disjoint set of resource ids for each connection.  The
;;; structure for resource ids is that the low 18 bits are set asside as
;;; the resource-id-mask.  This is the same for every connection.  The
;;; bits above these are allocated to each connection.  The resource-id
;;; base 0 is reserved for atoms, while the resource-ids above 0 are
;;; associated with particular connections.  The picture looks like the
;;; following.
;;;
;;;  The resource id base/mask for atoms looks like:
;;;
;;;       resource         resource
;;;       id base          id mask
;;;  .-----------------------------------.
;;;  | 00000000000000 111111111111111111 |
;;;  `-----------------------------------'
;;;
;;;  The resource id base/mask for all other resource ids looks like:
;;;
;;;       resource         resource
;;;       id base          id mask
;;;  .-----------------------------------.
;;;  | connection num 111111111111111111 |
;;;  `-----------------------------------'
;;;
;;;  where `connection num' is a connection number.
(defconstant .resource-id-bit-count. 18.
  "2Number of bits available for a resource id mask.*")

(defconstant .resource-id-base-bit-count. (- 32 .resource-id-bit-count.)
  "2Number of bits available for a resource id base.*")

(defconstant *max-clients* (expt 2 .resource-id-base-bit-count.)
  "2Arbitrarily large number of client connections.*")

(defconstant connection-byte-spec (byte .resource-id-base-bit-count. .resource-id-bit-count.)
  "2Byte specifier for the connection number.*")

(defconstant *resource-id-mask* (1- (expt 2 .resource-id-bit-count.)))

(defparameter *connections-list* (make-array *max-clients* :element-type 'bit :initial-element 0)
  "2Bit array for clients.  If it is 1 then the client is supposed to be active.  If it is 0 then
this client number is available for allocation by the server to a client.*")

(defconstant *max-visuals-per-screen* 50.)
(defconstant *max-motion-events* 32.
  "2Maximum number of pointer motion events.*")

(defconstant *image-byte-order* lsb-first)
(defconstant *bitmap-format-bit-order* lsb-first)
(defconstant *bitmap-format-scanline-unit* 32.)
(defconstant *bitmap-format-scanline-pad* 32.)

;; The smallest keycode is restricted by the protocol to be 8, so we need
;; to define an offset since the Explorer defines its smallest keycode to
;; be 1 (the HELP key).
(comment ;1; obsolete - use *
  (defconstant *keycode-offset* 8.)
  (defconstant *min-keycode* (+ *keycode-offset* 1))
  (defconstant *max-keycode* (+ *keycode-offset* 127.))
  )
(defconstant *max-pixmap-formats* 1.)
(defconstant *pixmap-format-depths* '(1))
(defconstant *pixmap-format-bits-per-pixels* '(1))
(defconstant *pixmap-format-scanline-pads* '(32))

;;; The following function allocates a resource id with a connection number of 0.
;;; This is the same resource id mask used for atoms.
(defconstant simple-resource-id-function (eval (let ((resource-id *resource-id-mask* ))
                                                 #'(lambda ()
                                                     (decf resource-id)
                                                     resource-id))))

(defconstant *max-screens* 1)
(defconstant *screen-roots*     `(,(funcall simple-resource-id-function)))
(defconstant *window-roots*     `(,(funcall simple-resource-id-function)))
(defconstant *screen-colormaps* `(,(funcall simple-resource-id-function)))
(defconstant *screen-white-pixels* '(1))
(defconstant *screen-black-pixels* '(0))
(defconstant *screen-input-events* `(,All-Event-Masks))

;;; Note that the screen width/height in millimeters dimensions below
;;; are very monitor dependent.  The person who put these numbers in had
;;; 2 Explorer monitors which have had different values for these two
;;; measures.  The pixel/inch values for these two monitors were 86.87
;;; (horizontal), 90.14 (vertical) and 85.33 (horizontal), 84.04
;;; (vertical).  The measurement for the latter monitor was chosen.
;;; Neither the "Explorer Technical Summary" nor the "Explorer Display
;;; Unit General Description" gave numbers which could be used to
;;; calculate the millimeter measures.  I must assume that these numbers
;;; are expected to vary from one machine to another and may be off by
;;; 10%.  (The previous two measures differed by 2% in the horizontal
;;; direction and 7% in the vertical direction.)
;;; Note: there are 25.4 mm in an inch
;;;  The ratio between the pixel height/width should be very close to that of the heightMM/widthMM.
;;;  Since these numbers aren't precise anyway, the height in millimeters is now fudged so that this 
;;;  ratio is accurate.


(defvar *screen-widths-in-pixels* nil)
(defvar *screen-heights-in-pixels* nil)

(defvar *screen-widths-in-millimeters* nil)
(defvar *screen-heights-in-millimeters* nil)

(defun INITIALIZE-SCREEN-SIZES ()
  ;; These variables must be recalculated at initialization time because
  ;; the screen size *can* change; usually due to a change in the # of mouse documentation lines.
  (multiple-value-bind (width height)
      (initial-screen-size 0)
    (setq *screen-widths-in-pixels* (list width)
	  *screen-heights-in-pixels*  (list height))

    (setq *screen-widths-in-millimeters*
	  (mapcar #'(lambda (n) (round n (/ 85.33 25.4))) *screen-widths-in-pixels*)

	  *screen-heights-in-millimeters*
	  (mapcar #'(lambda (n) (round n (/ 85.00 25.4))) *screen-heights-in-pixels*))))

(defconstant *screen-max-installed-maps* '(1))
(defconstant *screen-min-installed-maps* '(1))

(defconstant *screen-root-visuals* `(,(funcall simple-resource-id-function)))
(defconstant *screen-backing-stores* `(,store-Always))
(defconstant *screen-save-unders* `(,false))
(defconstant *screen-root-depths* '(1))
;;; The following defines the DEPTH data structure (see page 12 of the X/V11
;;; Protocol Encoding document for more details).  The depth contains three
;;; parts, a depth, a count of visualtypes and the visualtypes themselves.
;;; If the count is zero then there are no visualtypes.
;;; NOTE: for the Explorer color system we probably want to support both `normal'
;;; 8-bit color mode and expansion mode.  For this, the third element of a screen
;;; would have the visualtype (as defined on page 12) for the 8-bit color first and
;;; then the visualtype for the expansion mode.  In this way the root's visualtype
;;; is the normal 8-bit color, but we still have access to expansion mode when we
;;; need it.
(defparameter *screen-allowed-depths* '((1 0 NIL)))

(defparameter screen-saver-reset nil)
(defparameter screen-saved nil)

(DEFCONSTANT Extension-Event-Base 64)
(DEFCONSTANT Extension-Base 128)
(DEFPARAMETER Next-extension-event Extension-Event-Base)


(DEFUN ELEMENT-OF-WINDOW (LIST-ARG)
  (LOOP FOR ARG IN LIST-ARG
         DO (WHEN (NOT (TYPEP ARG 'WINDOW))
              (RETURN NIL))
         FINALLY (RETURN T)))

(DEFTYPE LIST-OF-WINDOW ()
  '(AND LIST (SATISFIES ELEMENT-OF-WINDOW)))

(DEFUN ELEMENT-OF-SCREEN (LIST-ARG)
  (LOOP FOR ARG IN LIST-ARG
         DO (WHEN (NOT (TYPEP ARG 'SCREEN))
              (RETURN NIL))
         FINALLY (RETURN T)))

(DEFTYPE LIST-OF-SCREEN ()
  '(AND LIST (SATISFIES ELEMENT-OF-SCREEN)))

(DEFSTRUCT (SCREEN-INFO (:CONC-NAME "SCREEN-INFO."))
  (NUM-SCREENS :UNBOUND :TYPE INTEGER)     ; Number of screens.
  ;; List of all of the screens.
  (SCREENS NIL :TYPE LIST-OF-SCREEN)
  ;; List of all root windows.
  (WINDOWS NIL :TYPE LIST-OF-WINDOW))

(DEFVAR SCREEN-INFO NIL
  "Contains all information about the screens the server knows about.")

(defvar *default-font-name* "2fixed*") ;1; the name of the default font (a configuration option??)*

(defparameter *default-font* nil)   ;1; an instance of the default font*

(defvar *default-cursor-glyph* 0)   ;1; The X_cursor (56 is gumby, 142 is trek)*

;;; alist of (directory directory-alist)
;;; where directory-alist is a list of (font-name file-name)
;;;  from the fonts.dir file in directory1.*
(defvar *font-directory-cache* nil)

;;; Search path for fonts used during initialization.
(DEFPARAMETER *FONT-INITIAL-SEARCH-PATH*
	      `(,(parse-namestring "x11m:fonts.100dpi;*.xld")
		,(parse-namestring "x11m:fonts.75dpi;*.xld")
		,(parse-namestring "x11m:fonts.misc;*.xld")
		,(parse-namestring "x11m:fonts.rel2;*.xld")))


;;; Search path for fonts used when doing font queries.
(DEFPARAMETER *FONT-DEFAULT-SEARCH-PATH* *FONT-INITIAL-SEARCH-PATH*)

(DEFPARAMETER *DEFAULT-CURSOR-FONT* "cursor"
  "This is the default font for the X cursor. It is used by CREATE-ROOT-CURSOR.")

(defstruct (state (:CONC-NAME "STATE.")
		  (:print-function print-state-structure))
  stream
  (swap-p nil)
  ;; Byte specifiers for 16 and 32 bit values.
  ;; These can be used to write multi-byte values without having
  ;; to check the value of swap-p every time.  The first number
  ;; in the name indicates the precision of the value (are you
  ;; asleep yet?) and the second number in the name relates to
  ;; the ordering from the byte buffer.  The bytes with a lower
  ;; number come before those bytes with a higher number.
  (byte-16-1   0 :type integer)
  (byte-16-2   0 :type integer)
  (byte-32-1   0 :type integer)
  (byte-32-2   0 :type integer)
  (byte-32-3   0 :type integer)
  (byte-32-4   0 :type integer)
  ;; Sequence number used to sequence replies together and for
  ;; error reporting purposes.
  (sequence-id 0 :type integer)
  id-base
  (fake-id     0 :type integer)

  ;; One of NIL, :ACTIVIST :SOLOIST or :GRABIST (maybe others too).
  (server-state nil)
  ;; non-NIL indicates that events are not to be sent to this client.
  (client-gone nil :type boolean)
  bytes
  words
  longs
  (events nil)
  ;; Read up on save-sets in the protocol spec.
  (save-set nil)
  response
  (last-drawable nil)		       ;1 Cache*
  (last-drawable-id 0)
  (last-gcontext nil)
  (last-gcontext-id 0)
  (resources nil)
  (description nil)		       ;1 String identifying the client associated with this state*
  (plist nil)
  (process nil)			       ;1 The lisp process this state is running in*
  (flushp nil)			       ;1 non-nil when stream needs flushing*
  )

;;; There is one of these instances for each server screen.  Currently only
;;; one server screen is being allowed, hence only one of these will exist.
;;; If at some future time we want to allow more than one server screen, then
;;; we will have more than one of these too.
(defstruct (global-state (:CONC-NAME "GLOBAL-STATE."))
  ;; count of servers actively processing requests
  (activists     0 :type integer)
  ;; count of servers desiring or possessing sole execution
  (soloists      0 :type integer)
  ;; number of active window lockers who haven't bothered to lock ancestors
  (window-busies 0 :type integer)
  ;; number of active tree lockers
  (tree-busies   0 :type integer)
  (resources (make-hash-table #+Symbolics :ignore-gc #+Symbolics t))
  ;;This is an assoc list of (ATOM ID).
  (atoms ())
  devices
  (states nil))
 
(defstruct (selection (:CONC-NAME "SELECTION."))
	   
  (atom :unbound)				; :type atom
  (last-time-changed :unbound)			; :type time-stamp
  (window nil)					; :type (or null window))
  (client :unbound :type state))

(defvar *current-selections* nil) ;1; List of current selections*

;;; Agrees with C code in server.include;scrnintstr.h.
(defstruct (Visual (:CONC-NAME "VISUAL."))
  (vid                :unbound :type integer)
  (screen             :unbound :type integer)
  (class              :unbound :type integer)
  (red-Mask           :unbound :type unsigned-integer)
  (green-Mask         :unbound :type unsigned-integer)
  (blue-Mask          :unbound :type unsigned-integer)
  (offset-Red         :unbound :type integer)
  (offset-Green       :unbound :type integer)
  (offset-Blue        :unbound :type integer)
  (bits-Per-RGB-Value :unbound :type integer)
  (Colormap-Entries   :unbound :type integer)

  ;; = log2 (ColormapEntries).  This does not imply that the screen has
  ;; this many planes.  It may have more or fewer.
  (nplanes         :unbound :type integer)
  )

;;; Agrees with C code in server.include;scrnintstr.h.
(defstruct (Depth (:CONC-NAME "DEPTH."))
  (depth                     :unbound :type integer)
  (number-Visual-identifiers :unbound :type integer)
  (visual-identifiers        :unbound :type integer)    ; block of visual ids for this depth
  )


;;; Agrees with C code in server.include;scrnintstr.h.
(defstruct (SCREEN (:conc-name "SCREEN.") (:print-function print-screen-structure))
  (my-Number               :unbound :type integer)     ; index of this instance in Screens[]
  (id                      :unbound :type atom)
  (width                   :unbound :type integer)
  (height                  :unbound :type integer)
  (mm-Width                :unbound :type integer)
  (mm-Height               :unbound :type integer)
  traits                               ; Still don't know what this is.
  (num-Depths              :unbound :type integer)
  (allowed-Depths          :unbound :type depth)
  (root-Depth              :unbound :type integer)
  (root-Visual             :unbound :type integer)
  (def-Colormap            :unbound :type integer)
  (min-Installed-Cmaps     :unbound :type integer)
  (max-Installed-Cmaps     :unbound :type integer)
  (backing-Store-Support   Store-Not-Useful :type Store-Type)
  (save-Under-Support      false :type bool)
  (white-Pixel             :unbound :type unsigned-integer)
  (black-Pixel             :unbound :type unsigned-integer)
  (rgf                     :unbound :type unsigned-integer)     ; array of flags; she's -- HUNGARIAN
  (GC-per-Depth            :unbound :type t)	                ;(array gcontext 1)
  ;; Window instance associated with this screen.
  (dev-Private             :unbound)
  (num-Visuals             :unbound :type integer)
  (visuals                 :unbound :type visual)

  ;; Random screen procedures
  (Close-Screen             :unbound :type symbol)      ; index, pScreen
  (Query-Best-Size          :unbound :type symbol)      ; class, pwidth, pheight
  (Save-Screen              :unbound :type symbol)      ; pScreen, on
  (Get-Image                :unbound :type symbol)      ; pDrawable, sx, sy, w, h, format, planemask, pdestbits 
  (Get-Spans                :unbound :type symbol)      ; pDrawable, wMax, ppt, pwidth, nspans
  (Pointer-Non-Interest-Box :unbound :type symbol)      ; pScr, BoxPtr

  ;; Window Procedures
;;;  (Create-Window            :unbound :type symbol)      ; pWin
;;;  (Destroy-Window           :unbound :type symbol)      ; pWin
;;;  (Position-Window          :unbound :type symbol)      ; pWin, x, y
;;;  (Change-Window-Attributes :unbound :type symbol)      ; pWin, mask
;;;  (Realize-Window           :unbound :type symbol)      ; pWin
;;;  (Unrealize-Window         :unbound :type symbol)      ; pWin
;;;  (Validate-Tree            :unbound :type symbol)      ; pParent, pChild, top, anyMarked
;;;  (Window-Exposures         :unbound :type symbol)      ; pWin: WindowPtr, pRegion: RegionPtr

;;;  ;; Pixmap procedures
;;;  (Create-Pixmap            :unbound :type symbol)      ; pScreen, width, height, depth
;;;  (Destroy-Pixmap           :unbound :type symbol)      ; pPixmap

;;;  ;; Font procedures
;;;  (Realize-Font             :unbound :type symbol)      ; pScr, pFont
;;;  (Unrealize-Font           :unbound :type symbol)      ; pScr, pFont

;;;  ;; Cursor Procedures
;;;  (Constrain-Cursor         :unbound :type symbol)      ; pScr, BoxPtr
;;;  (Cursor-Limits            :unbound :type symbol)      ; pScr, pCurs, BoxPtr, BoxPtr
;;;  (Display-Cursor           :unbound :type symbol)      ; pScr, pCurs
;;;  (Realize-Cursor           :unbound :type symbol)      ; pScr, pCurs
;;;  (Unrealize-Cursor         :unbound :type symbol)      ; pScr, pCurs
;;;  (Recolor-Cursor           :unbound :type symbol)      ; pScr, pCurs, displayed
;;;  (Set-Cursor-Position      :unbound :type symbol)      ; pScr, x, y


;;;  ;; THESE GC PROCEDURES go away...
;;;  (create-gc                :unbound :type symbol)      ; pgc

;;;  ;; colormap procedures
;;;  (install-colormap         :unbound :type symbol)      ; pcmap
;;;  (uninstall-colormap       :unbound :type symbol)      ; pcmap
;;;  (list-installed-colormaps :unbound :type symbol)      ; pscreen, pmaps
;;;  (get-static-colormap      :unbound :type symbol)      ; pvisual
;;;  (store-colors             :unbound :type symbol)      ; pmap, ndef, pdef
;;;  (resolve-color            :unbound :type symbol)      ; preg, pgreen, pblue

  ;; Region procedures
;;;  (Region-Create            :unbound :type symbol)      ; rect, size
;;;  (Region-Copy              :unbound :type symbol)      ; dstrgn, srcrgn
;;;  (Region-Destroy           :unbound :type symbol)      ; pRegion
;;;  (Intersect                :unbound :type symbol)      ; newReg, reg1, reg2
;;;  (Union                    :unbound :type symbol)      ; newReg, reg1, reg2
;;;  (Subtract                 :unbound :type symbol)      ; regD, regM, regS
;;;  (Inverse                  :unbound :type symbol)      ; newReg, reg1, invRect
;;;  (Region-Reset             :unbound :type symbol)      ; pRegion, pBox
;;;  (Translate-Region         :unbound :type symbol)      ; pRegion, x, y
;;;  (Rect-In                  :unbound :type symbol)      ; pRegion, pRect
;;;  (Point-In-Region          :unbound :type symbol)      ; pRegion, x, y, pBox
;;;  (Region-Not-Empty         :unbound :type symbol)      ; pRegion: RegionPtr
;;;  (Region-Empty             :unbound :type symbol)      ; pRegion: RegionPtr
;;;  (Region-Extents           :unbound :type symbol)      ; pRegion: RegionPtr
  )

;;; Agrees with C.
(defstruct (x-Char-Info (:CONC-NAME "X-CHAR-INFO."))
  (left-Side-Bearing  0 :type int16)
  (right-Side-Bearing 0 :type int16)
  (character-Width    0 :type int16) ;1; zero when glyph not defined*
  (ascent             0 :type int16)
  (descent            0 :type int16)
  (attributes         0 :type int16)
  )

;1; Merge char-info-record with x-char-info*
(defsubst char-info-record.metrics (info)
  ;1; Info is NIL when char doesn't exist, but then we don't want to look at char-info*
  info)

(defstruct (Font-Info-record (:CONC-NAME "FONT-INFO-RECORD."))
  (version          :unbound :type integer)    ; version stamp 
  (all-Exist        :unbound :type boolean)
  (draw-Direction   :unbound :type font-draw-direction-type)
  (no-Overlap       :unbound :type integer)
  (constant-Metrics :unbound :type integer)
  (terminal-Font    :unbound :type integer)    ; constant metrics && width==bbox.w && no kerning
  (linear           :unbound :type boolean)    ; true if nRows == 0
  (first-Col        :unbound :type integer)    ; min byte2
  (last-Col         :unbound :type integer)    ; max byte2
  (first-Row        :unbound :type integer)
  (last-Row         :unbound :type integer)
  (n-Props          :unbound :type integer)
  (properties       nil      :type sequence)   ; List of all properties with integer values.
  (len-Strings      :unbound :type integer)    ; length in bytes of string table
  (ch-Default       :unbound :type integer)    ; default character (font property)
  (font-Descent     :unbound :type int16)      ; minimum for quality typography (font property)
  (font-Ascent      :unbound :type int16)      ; minimum for quality typography (font property)
  (min-bounds       :unbound :type x-char-info); MIN of glyph metrics over all chars
  (max-bounds       :unbound :type x-char-info); MAX of glyph metrics over all chars
  (pix-Depth        :unbound :type integer)    ; intensity bits per pixel
  (glyph-Sets       :unbound :type integer)    ; number of sets of glyphs, for sub-pixel positioning
  (version2         :unbound :type integer)    ; version stamp double-check
  (metrics	    :unbound :type (or null vector))     ;1 Vector of x-char-info records* or null if constant
 )

(defstruct (DIX-Font-Property (:CONC-NAME "DIX-FONT-PROPERTY."))
  (name    :unbound :type atom)
  (value   :unbound :type integer)              ; assumes ATOM is not larger than INT32
  )


;;; FONT is created at font load time; it is not part of the
;;; font file format
;;; Agrees with C version.
(defstruct (FONT-RECORD (:include resource) (:CONC-NAME "FONT-RECORD."))
  (FI              :unbound :type font-info-record)
  (FP              :unbound :type list)	       ;dix-font-property 
  (CI              :unbound :type vector)1     *  ;1Vector of *x-char-info1 records*
  (Glyphs          :unbound :type string-char)
  (len-pname       :unbound :type integer)
  (pathname        :unbound :type string-char) ; pathname of file from which font was read
  (next            :unbound :type t)	       ; (:type font-record) linked list of opened fonts
  (reference-count :unbound :type integer)     ; free storage when this goes to 0
  (device-Private  :unbound)           	       ; the font 1object*
  )

(defstruct (DRAWABLE-TRAIT (:CONC-NAME "DRAWABLE-TRAIT."))
  depth
  visuals
  screen)

(defstruct (DRAWABLE (:include resource) (:CONC-NAME "DRAWABLE."))
  trait
  clip-mask)

(defsubst DRAWABLE-DEPTH (window)
  (drawable-trait.depth (drawable.trait window)))

(defsubst DRAWABLE-SCREEN (window)
  (drawable-trait.screen (drawable.trait window)))

(defstruct (WINDOW (:include drawable)
		   (:conc-name "WINDOW.")
		   (:print-function print-window-structure)
		   ;1; 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)

;1;*  (attributes NIL)
  ;1; 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)  1NIL* 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)) ;1; NIL when screen is up-to-date, t when not,*
  					  ;1; else a box containg the region not updated.*
  )

(DEFMACRO WINDOW.C-NEXT-SIB (WINDOW)
  "C version of next-sub."
  ;; Assume that window is never the root.  Next-sib on the root doesn't make
  ;; any sense anyway.
  ;; Only evaluate WINDOW once.
  (LET ((WIN (GENSYM)))
    `(LET* ((,WIN ,WINDOW))
       (IF (EQ (WINDOW.LAST-CHILD (WINDOW.PARENT ,WIN)) ,WIN)
           ;; The C version of next-sib returns NULL when WINDOW is the last sibling.
           NIL
           (WINDOW.NEXT-SIB ,WIN)))))

;; Define a loop-path for xwindow-children.
;; Usage: (LOOP FOR child BEING THE XWINDOW-CHILDREN OF parent DO ...
(define-loop-path xwindow-children xwindow-children-path (of)
  window.first-child
  window.last-child
  window.next-sib)

;; Loke xwindow-children, but loops in reverse order (last child first)
;; Usage: (LOOP FOR child BEING THE XWINDOW-CHILDREN-REVERSE OF parent DO ...
(define-loop-path xwindow-children-reverse xwindow-children-path (of)
  window.last-child
  window.first-child
  window.prev-sib)

(defun xwindow-children-path (path-name variable data-type prep-phrases
			      inclusive? allowed-prepositions data)
  (declare (ignore data-type allowed-prepositions))
  (unless (assoc 'of prep-phrases)
    (error "OF missing in ~s iteration path of ~s" path-name variable))
  (when inclusive?
    (error "Inclusive stepping not supported in ~s path of ~s"
	   path-name variable))
  (let* ((last-child (gensym))
	 (parent (gensym))
	 (first (first data))
	 (last (second data))
	 (next (third data)))
    (list  `((,variable nil)	       ;1 bindings*
	     (,last-child nil)
	     (,parent ,(cadar prep-phrases)))
	   `((setq ,last-child (,last ,parent))) ;1; prologue*
	   ;1; steps except the first*
	1     *`(eq ,variable ,last-child)	1      *;1Pre-step endtest*
	     nil		       ;1 steps*
	     nil		       ;1 Post-step-endtest*
	     `(,variable (,next ,variable))  ;1 Pseudo-steps*

	     ;1; first step*
	     `(null ,last-child)       ;1pre-step endtest*
	     nil		       ;1 steps*
	     nil		       ;1 post-step-endtest*
	     `(,variable (,first ,parent) ;1 Pseudo-steps*
	     ))))

(DEFSETF WINDOW.OUTSIDE-HEIGHT WINDOW.SET-OUTSIDE-HEIGHT
         "Treat the outside window height as if it were a slot.")

(DEFMACRO WINDOW.OUTSIDE-HEIGHT (WINDOW)
  `(+ (WINDOW.HEIGHT ,WINDOW) (* 2 (WINDOW.BWIDTH ,WINDOW))))

(DEFMACRO WINDOW.SET-OUTSIDE-HEIGHT (WINDOW VALUE)
  `(SETF (WINDOW.HEIGHT ,WINDOW) (- ,VALUE (* 2 (WINDOW.BWIDTH ,WINDOW)))))


(DEFSETF WINDOW.OUTSIDE-WIDTH WINDOW.SET-OUTSIDE-WIDTH
         "Treat the outside window width as if it were a slot.")

(DEFMACRO WINDOW.OUTSIDE-WIDTH (WINDOW)
  `(+ (WINDOW.WIDTH ,WINDOW) (* 2 (WINDOW.BWIDTH ,WINDOW))))

(DEFMACRO WINDOW.SET-OUTSIDE-WIDTH (WINDOW VALUE)
  `(SETF (WINDOW.WIDTH ,WINDOW) (- ,VALUE (* 2 (WINDOW.BWIDTH ,WINDOW)))))


(DEFSETF WINDOW.INSIDE-X WINDOW.SET-INSIDE-X
         "Treat the inside X window coordinate component as if it were a slot.")

(DEFMACRO WINDOW.INSIDE-X (WINDOW)
  `(+ (WINDOW.X ,WINDOW) (WINDOW.BWIDTH ,WINDOW)))

(DEFMACRO WINDOW.SET-INSIDE-X (WINDOW VALUE)
  `(SETF (WINDOW.X ,WINDOW) (- ,VALUE (WINDOW.BWIDTH ,WINDOW))))


(DEFSETF WINDOW.INSIDE-Y WINDOW.SET-INSIDE-Y
         "Treat the inside Y window coordinate component as if it were a slot.")

(DEFMACRO WINDOW.INSIDE-Y (WINDOW)
  `(+ (WINDOW.Y ,WINDOW) (WINDOW.BWIDTH ,WINDOW)))

(DEFMACRO WINDOW.SET-INSIDE-Y (WINDOW VALUE)
  `(SETF (WINDOW.Y ,WINDOW) (- ,VALUE (WINDOW.BWIDTH ,WINDOW))))


(DEFSETF WINDOW.ABSOLUTE-INSIDE-X WINDOW.SET-ABSOLUTE-INSIDE-X
         "Treat the absolute inside X window coordinate component as if it were a slot.")

(DEFMACRO WINDOW.ABSOLUTE-INSIDE-X (WINDOW)
  `(+ (WINDOW.ABSOLUTE-X-CORNER ,WINDOW) (WINDOW.BWIDTH ,WINDOW)))

(DEFMACRO WINDOW.SET-ABSOLUTE-INSIDE-X (WINDOW VALUE)
  `(SETF (WINDOW.ABSOLUTE-X-CORNER ,WINDOW) (- ,VALUE (WINDOW.BWIDTH ,WINDOW))))


(DEFSETF WINDOW.ABSOLUTE-INSIDE-Y WINDOW.SET-ABSOLUTE-INSIDE-Y
         "Treat the absolute inside Y window coordinate component as if it were a slot.")

(DEFMACRO WINDOW.ABSOLUTE-INSIDE-Y (WINDOW)
  `(+ (WINDOW.ABSOLUTE-Y-CORNER ,WINDOW) (WINDOW.BWIDTH ,WINDOW)))

(DEFMACRO WINDOW.SET-ABSOLUTE-INSIDE-Y (WINDOW VALUE)
  `(SETF (WINDOW.ABSOLUTE-Y-CORNER ,WINDOW) (- ,VALUE (WINDOW.BWIDTH ,WINDOW))))

(defstruct (PIXMAP (:include drawable) (:CONC-NAME "PIXMAP."))
  (lock nil)
  (width  :unbound :type integer)
  (height :unbound :type integer)
  (array  :unbound :type array)
  (tiled-p nil :type boolean))	       ;1 T when pixmap.array is tiled*

(defstruct (POINT (:CONC-NAME "POINT."))
  (x 0 :type integer)
  (y 0 :type integer))


;;; Clipping region.
(defstruct (REGION (:CONC-NAME "REGION."))
  (size      :unbound :type integer)
  (num-Rects :unbound :type integer)
  (rects     :unbound :type box)
  (extents   :unbound :type box)
  )


(defstruct (GC-INTEREST (:CONC-NAME "GC-INTEREST."))
  (Next-GC-Interest     :unbound)      ; :type gc-interest
  (Last-GC-Interest     :unbound :type t)	; :type gc-interest
  (length               :unbound :type integer)
  (owner                :unbound :type ATOM)    ; Extension id of owning extension
  (Value-Interest-Mask  :unbound :type integer)
  (Change-Interest-Mask :unbound :type integer)
  (extension-Private    :unbound :type t)       ; Pointer extension private data.

  ;; Random gcontext functions.
  (Validate-GC          :unbound :type symbol)
  (Change-GC            :unbound :type symbol)
  (Copy-GC-Source       :unbound :type symbol)
  (Copy-GC-Dest         :unbound :type symbol)
  (Destroy-GC           :unbound :type symbol)
  )


(defstruct (GCONTEXT (:include resource) (:CONC-NAME "GCONTEXT.")
		     ;1; Speed creation of gcontext's*
		     #+explorer (:callable-constructors nil))
  trait
  (lock nil)
  (Screen             :unbound :type screen)
  (device-Private     :unbound :type t)        ; private to the device 
  (depth              :unbound :type integer)
  (serial-number      :unbound :type integer)
  (Next-GC-Interest   :unbound :type gc-interest)
  (Last-GC-Interest   :unbound :type gc-interest)
  (alu                :unbound :type integer)
  (plane-mask         :unbound :type integer)
  (foreground-pixel   :unbound :type integer)
  (background-pixel   :unbound :type integer)
  ;; A simple tile which contains only the foreground pixel.  Used by graphics operations.
  (foreground-tile    :unbound :type pixmap)
  (line-Width         :unbound :type integer)
  (line-Style         :unbound :type integer)
  (cap-Style          :unbound :type integer)
  (join-Style         :unbound :type integer)
  (fill-Style         :unbound :type integer)
  (fill-Rule          :unbound :type integer)
  (arc-Mode           :unbound :type integer)
  (tile               :unbound :type (or null pixmap))
  (stipple            :unbound :type (or null pixmap))
  (pattern-Originp    (make-point) :type point)    ; Origin for (tile, stipple).
  (font               :unbound :type (or null font-record))
  (subWindow-Mode     :unbound :type integer)
  (graphics-Exposures :unbound :type boolean)     ; T or NIL
  (clip-p             :unbound :type boolean)     ;1 T when doing clipping, else NIL*
  (clip-Origin        (make-point) :type point)    ; Origin for rectangle-mask

  ;1; the rectangle clipped by the clip-mask, or nil when there's no clipping*
  (clip-rectangle     :unbound :type (or null box))1      *; clipping 1rectangle*.

  (clip-mask          :unbound :type (or null pixmap))

  ;; This will be one of order-UnSorted, order-YSorted, order-YXSorted, order-YXBanded,
  ;; NIL, a pixmap or a region.  We don't use this at all.  Perhaps later it will be
  ;; used if someone wants to write the code to take advantage of this information.
  (client-Clip-Type   :unbound :type (or null integer pixmap region))

  (dash-Offset        :unbound :type integer)
  (num-In-Dash-List   :unbound :type integer)  ; num elements in dash list
  (dash               :unbound :type array)    ; dash pattern

  (state-Changes      0        :type integer)  ; masked with GC
  (last-Win-Org       :unbound :type point)    ; origin of last window
  (mi-Translate       :unbound :type (unsigned-byte 1))        ; should mi things translate?

  ;; Random gcontext functions.
;  (Fill-Spans         :unbound :type symbol)
;  (Set-Spans          :unbound :type symbol)
;  (Put-Image          :unbound :type symbol)
;  (Copy-Area          :unbound :type symbol)
;  (Copy-Plane         :unbound :type symbol)
;  (Poly-Point         :unbound :type symbol)
;  (Polylines          :unbound :type symbol)
;  (Poly-Segment       :unbound :type symbol)
;  (Poly-Rectangle     :unbound :type symbol)
;  (Poly-Arc           :unbound :type symbol)
;  (Fill-Polygon       :unbound :type symbol)
;  (Poly-FillRect      :unbound :type symbol)
;  (Poly-FillArc       :unbound :type symbol)
;  (Poly-Text8         :unbound :type symbol)
;  (Poly-Text16        :unbound :type symbol)
;  (Image-Text8        :unbound :type symbol)
;  (Image-Text16       :unbound :type symbol)
;  (Image-Glyph-Blt    :unbound :type symbol)
;  (Poly-Glyph-Blt     :unbound :type symbol)
;  (Push-Pixels        :unbound :type symbol)
;  (Line-Helper        :unbound :type symbol)
;  (Change-Clip        :unbound :type symbol)
;  (Destroy-Clip       :unbound :type symbol)
  )


(DEFRESOURCE gcontext () :constructor (make-gcontext))

(DEFSUBST alloc-gcontext ()
  (ALLOCATE-RESOURCE 'gcontext))

(DEFSUBST dealloc-gcontext (res)
  (DEALLOCATE-RESOURCE 'gcontext res))

(DEFRESOURCE PIXMAP (DRAWABLE WIDTH HEIGHT DEPTH &OPTIONAL (INITIAL-ELEMENT 0))
  :CONSTRUCTOR (CREATE-PIXMAP DRAWABLE WIDTH HEIGHT DEPTH NIL) ;1; array is initialized by :INITIALIZER*
  ;; Re-use any pixmap that is as large *or* larger than that requested
  :MATCHER (AND (<= HEIGHT (ARRAY-DIMENSION (PIXMAP.ARRAY OBJECT) 0))
		(<= WIDTH (ARRAY-DIMENSION (PIXMAP.ARRAY OBJECT) 1))
		(IF (TYPEP DEPTH 'GCONTEXT)
		    (= (GCONTEXT.DEPTH DEPTH) (ARRAY-ELEMENT-SIZE (PIXMAP.ARRAY OBJECT)))
		  (= DEPTH (ARRAY-ELEMENT-SIZE (PIXMAP.ARRAY OBJECT)))))
  :INITIALIZER (PROGN
		 (when initial-element
		   (ARRAY-INITIALIZE (PIXMAP.ARRAY OBJECT)
				     (LOGAND (1- (EXPT 2 DEPTH)) INITIAL-ELEMENT)))
		 ;; Initialize slots to the value requested, although the array may be larger
		 (SETF (PIXMAP.WIDTH OBJECT) WIDTH)
		 (SETF (PIXMAP.HEIGHT OBJECT) HEIGHT)
		 (IF DRAWABLE
		     (SETF (PIXMAP.TRAIT OBJECT) (DRAWABLE.TRAIT DRAWABLE))
		   (SETF (PIXMAP.TRAIT OBJECT) NIL))
		 (SETF (PIXMAP.CLIP-MASK OBJECT) NIL)))

(defstruct (colormap (:CONSTRUCTOR CREATE-COLORMAP-OBJECT) (:CONC-NAME "COLORMAP.")
                     (:include resource))
  ;; one of Monochrome Gray-Scale Pseudo-Color Direct-Color Static-Color True-Color))
  class
  ;; Colormap entries themselves
  entries
  ;; Window associated with this colormap.
  WINDOW
  SCREEN)


(DEFSTRUCT (COLORMAP-ENTRY (:CONC-NAME "COLORMAP-ENTRY."))
  (red      :UNBOUND :TYPE card16)     ; Pixel value for red
  (green    :UNBOUND :TYPE card16)     ; Pixel value for green
  (blue     :UNBOUND :TYPE card16)     ; Pixel value for blue
  )

(defun make-colormap (&key id WINDOW SCREEN CLASS)
  (let ((colormap (create-colormap-object))  ;(setq  x (make-colormap :id 111))(colmap-type x)
        (entries (make-array 2)))
    (setf (aref entries 0) (make-colormap-entry :red 0 :green 0 :blue 0))   ;1 black*
    (setf (aref entries 1) (make-colormap-entry :red #xFFFF :green #xFFFF :blue #xFFFF))   ;1 white*
    (when id
      (setf (colormap.id colormap) id))
    (WHEN CLASS
      (SETF (COLORMAP.CLASS COLORMAP) CLASS))
    (setf (colormap.type colormap ) Colormap-Resource-Type )
    (SETF (COLORMAP.ENTRIES COLORMAP) ENTRIES)
    (SETF (COLORMAP.WINDOW  COLORMAP) WINDOW)
    (SETF (COLORMAP.SCREEN  COLORMAP) SCREEN)
    colormap))

;1; This is a crock - installed-colormaps should be a slot of the screen structure, not a global - LGO*
(defvar *INSTALLED-COLORMAPS* nil)


;;; CURSOR-PRIVATE data
;;;	SCREEN-BITS	saves the contents of the screen before the cursor
;;;	    	  	was placed in the frame buffer.
;;;	SOURCE	  	a bitmap for placing the foreground pixels down
;;;	SRC-GC	  	a GC for placing the foreground pixels down.
;;;	    	  	Prevalidated for the cursor's screen.
;;;	INV-SOURCE 	a bitmap for placing the background pixels down.
;;;	INV-SRC-GC  	a GC for placing the background pixels down.
;;;	    	  	Also prevalidated for the cursor's screen Pixmap.
;;;	TEMP	  	a temporary pixmap for low-flicker cursor motion --
;;;	    	  	exists to avoid the overhead of creating a pixmap
;;;	    	  	whenever the cursor must be moved.
;;;	FG, BG	  	foreground and background pixels. For a color display,
;;;	    	  	these are allocated once and the rgb values changed
;;;	    	  	when the cursor is recolored.
;;;	SCR-X, SCR-Y	the coordinate on the screen of the upper-left corner
;;;	    	  	of screenBits.
;;;	STATE	  	one of CR-IN, CR-OUT and CR-XING to track whether the
;;;	    	  	cursor is in or out of the frame buffer or is in the
;;;	    	  	process of going from one state to the other.

(DEFENUM (
          CR-IN                        ; Cursor in frame buffer
          CR-OUT                       ; Cursor out of frame buffer
          CR-XING                      ; Cursor in flux
          )
         :TYPE CR-STATE-TYPE)


(DEFSTRUCT (CR-PRIVATE (:CONC-NAME "CR-PRIVATE."))
  ;; Screen before cursor put down.
  (SCREEN-BITS :UNBOUND :TYPE PIXMAP)
  ;; T if screen may have changes since bits saved
  (SCREEN-BITS-INVALID NIL :TYPE T)
  ;; Cursor source (foreground bits).
  (SOURCE-BITS :UNBOUND :TYPE PIXMAP)
  ;; Temp pixmap for forming cursor+screen image
  (TEMP        :UNBOUND :TYPE PIXMAP)
  ;; Foreground/Background colors.
  (FG          :UNBOUND :TYPE INTEGER)
  (BG          :UNBOUND :TYPE INTEGER)
  ;; Offset from orgin of cursor box to orgin of screen save box
  (X-SAVE-OFFSET :UNBOUND :TYPE INTEGER)
  (Y-SAVE-OFFSET :UNBOUND :TYPE INTEGER)
  ;; Screen (X,Y) coordinate of screenBits.
  (SCREEN-X    :UNBOUND :TYPE INTEGER)
  (SCREEN-Y    :UNBOUND :TYPE INTEGER)
  ;; Current state of the cursor.
  (STATE       :UNBOUND :TYPE CR-STATE-TYPE))


;;; FRAME-BUFFER-PRIVATE information
;;;	GC 	  	A GC for realizing cursors.
;;;	MAPPED	  	flag set true by the driver when the frame buffer has
;;;	    	  	been mapped in.
;;;	PARENT	  	set true if the frame buffer is actually an Explorer WS
;;;	    	  	window.
(DEFSTRUCT (FRAME-BUFFER-DESCRIPTOR (:CONC-NAME "FRAME-BUFFER-DESCRIPTOR."))
  (GCONTEXT     :UNBOUND :TYPE GCONTEXT)
  (INV-GCONTEXT :UNBOUND :TYPE GCONTEXT)
  (MAPPED       :UNBOUND :TYPE BOOLEAN)
  (PARENT       :UNBOUND :TYPE BOOLEAN))

(DEFPARAMETER FRAME-BUFFER-DESCRIPTORS :UNBOUND
  "Array of frame-buffer-descriptor, one for each screen.")

(DEFSTRUCT (CURSOR-RECORD (:include resource) (:CONC-NAME "CURSOR-RECORD."))
  (LOCK	       0 :TYPE INTEGER)
  (SOURCE      :UNBOUND :TYPE ARRAY)            ; points to bits
  (MASK        :UNBOUND :TYPE ARRAY)            ; points to bits
  (WIDTH       :UNBOUND :TYPE INTEGER)
  (HEIGHT      :UNBOUND :TYPE INTEGER)
  (XHOT        :UNBOUND :TYPE INTEGER)          ; must be within bitmap 
  (YHOT        :UNBOUND :TYPE INTEGER)          ; must be within bitmap

  ;; Device-independent color.
  (FORE-RED    :UNBOUND :TYPE INTEGER)
  (FORE-GREEN  :UNBOUND :TYPE INTEGER)
  (FORE-BLUE   :UNBOUND :TYPE INTEGER)

  ;; Device-independent color.
  (BACK-RED    :UNBOUND :TYPE INTEGER)
  (BACK-GREEN  :UNBOUND :TYPE INTEGER)
  (BACK-BLUE   :UNBOUND :TYPE INTEGER)

  (REF-COUNT   :UNBOUND :TYPE INTEGER)
  ;; set by pScr->RealizeCursor
  (DEV-PRIVATE nil :TYPE (or null (ARRAY CR-PRIVATE))))


(DEFMACRO WITH-CURSOR-LOCKED ((LOCKER &OPTIONAL NOHANG) &BODY BODY)
  "Lock the cursor.  LOCKER should normally be :SERVER or NIL.
:SERVER means a server is locking the cursor.  Any number of servers may have 
the cursor locked.  NIL means lock out all other processes -- this is used
by the dispatch process.
NOHANG means don't execute BODY if cursor cannot be locked on first attempt."
  
  (CHECK-ARG LOCKER '(OR (NULL LOCKER) (EQ LOCKER :SERVER)) "NIL or :SERVER")
  (COND ((NULL LOCKER)
	 ;; Wait until lock is zero, then set it to -1
	 (LET ((EXECUTE (GENSYM)))
	   `(LET ((,EXECUTE NIL))
	      (UNWIND-PROTECT
		  (PROGN
		    (LOOP
		      UNTIL (OR (INDIVISIBLY
				  (WHEN (ZEROP (CURSOR-RECORD.LOCK CURRENT-CURSOR))
				    (SETQ ,EXECUTE T)
				    (SETF (CURSOR-RECORD.LOCK CURRENT-CURSOR) -1)))
				,NOHANG)
		      DO (PROCESS-WAIT "Cursor Locked"
				       #'(LAMBDA () (ZEROP (CURSOR-RECORD.LOCK CURRENT-CURSOR)))))
		    (WHEN ,EXECUTE
		      . ,BODY))
		(INDIVISIBLY
		  (WHEN ,EXECUTE
		    (SETF (CURSOR-RECORD.LOCK CURRENT-CURSOR) 0)))))))
	(:ELSE
	 ;; Wait until lock is >= 0, then increment it
	 `(UNWIND-PROTECT
	      (PROGN
		(LOOP
		  UNTIL (INDIVISIBLY
			  (AND (>= (CURSOR-RECORD.LOCK CURRENT-CURSOR) 0)
			       (INCF (CURSOR-RECORD.LOCK CURRENT-CURSOR))))
		  DO (PROCESS-WAIT "Cursor Locked"
				   #'(LAMBDA () (>= (CURSOR-RECORD.LOCK CURRENT-CURSOR) 0))))
		. ,BODY)
	    (INDIVISIBLY
	      (DECF (CURSOR-RECORD.LOCK CURRENT-CURSOR)))))))


;;; A resource is a 32 bit quantity.  the upper 12 bits are client id.  
;;; client provides a 19 bit resource id. this is "hashed" by me by
;;; taking the 10 lower bits and xor'ing with the mid 10 bits.
;;;
;;; It is sometimes necessary for the server to create an ID that looks
;;; like it belongs to a client.  This ID, however,  must not be one
;;; the client actually can create, or we have the potential for conflict.
;;; The 20th bit of the ID is resevered for the server's use for this
;;; purpose.  By setting CLIENT_ID(id) to the client, the SERVER_BIT to
;;; 1, and an otherwise unused ID in the low 19 bits, we can create a
;;; resource "owned" by the client.
;;;
;;; The following IDs are currently reserved for siccing on the client:
;;; 1 - allocated color to be freed when the client dies

(DEFUN ADD-RESOURCE (ID VALUE)
  (DECLARE (TYPE INTEGER ID))
  (LET* ((*RESOURCES* (global-state.resources *globals*)))
    (STORE-RESOURCE ID VALUE)))

(DEFUN FREE-RESOURCE (ID DELETE-FUNCTION)
  (LET* ((*RESOURCES* (global-state.resources *globals*))
         (VALUE (GETHASH ID *RESOURCES*)))
    (FUNCALL DELETE-FUNCTION VALUE ID)
    (REMOVE-RESOURCE ID)))

(defun store-resource (resource-id object)
  (setf (gethash resource-id *resources*) object))

(defun remove-resource (resource-id &optional cache)
  (when cache
    (dolist (state (global-state.states *globals*))
      (CASE cache
	(:gcontext (COND ((EQL resource-id (state.last-gcontext-id state))
			  (SETF (state.last-gcontext-id state) 0)
			  (SETF (state.last-gcontext state) nil))))
	(:drawable (COND ((EQL resource-id (state.last-drawable-id state))
			  (SETF (state.last-drawable-id state) 0)
			  (SETF (state.last-drawable state) nil)))))))
  (REMHASH resource-id *resources*))

(defun resource-hash (var &optional cache)
  (if cache
      (let ((id-func (intern (concatenate 'simple-string "STATE.LAST-" (symbol-name cache) "-ID")))
	    (val-func (intern (concatenate 'simple-string  "STATE.LAST-" (symbol-name cache)))))
	`((cond ((eql ,var (,id-func state))
		 (setq ,var (,val-func state)))
		((setq ,var (gethash ,var *resources*))
		 (setf (,id-func state) (resource.id (setf (,val-func state) ,var)))))))
      `((setq ,var (gethash ,var *resources*)))))

;1;;Moved these to ATOM-PROPERTY-REQUESTS.LISP. -Dan*
;;;;;; Use this functions to store/get atoms.
;;;(defun store-atom (atom value)
;;;  (setf (gethash atom (global-state.atoms *globals*)) value))

;;;(defun get-atom (atom)
;;;  (gethash atom (global-state.atoms *globals*)))



(defun drawable-hash (var)
  (resource-hash var :drawable))

(defun gcontext-hash (var)
  (resource-hash var :gcontext))

(defun resource-check (var accessor &optional mask (error 'Bad-Value))
  `((,(if mask
	  `(or (null ,var) (not (logtest (resource.type ,var) ,mask)))
	  `(null ,var))
     ,(if (symbolp error)
	 `(,error ,accessor)
	 error))))

(defun window-check (var accessor)
  (resource-check var accessor
		  (logior Draw-Window-Resource-Type No-Draw-Window-Resource-Type)
		  'Bad-Window))

(defun pixmap-check (var accessor)
  (resource-check var accessor Pixmap-Resource-Type 'Bad-Pixmap))

(defun cursor-check (var accessor)
  (resource-check var accessor Cursor-Resource-Type 'Bad-Cursor))

(defun font-check (var accessor)
  (resource-check var accessor Font-Resource-Type 'Bad-Font))

(defun gcontext-check (var accessor)
  (resource-check var accessor GContext-Resource-Type 'Bad-GContext))

(defun colormap-check (var accessor)
  (resource-check var accessor Colormap-Resource-Type 'Bad-Colormap))

(defun pixwin-check (var accessor)
  (resource-check var accessor
		  (logior Draw-Window-Resource-Type No-Draw-Window-Resource-Type
                          Temporary-Bitmap-Resource-Type
			  Pixmap-Resource-Type)
		  'Bad-Drawable))

(defun drawable-check (var accessor)
  (resource-check var accessor
		  (logior Draw-Window-Resource-Type Temporary-Bitmap-Resource-Type
                          Pixmap-Resource-Type)
		  `(bad-output ,var ,accessor)))

(defun fontable-check (var accessor)
  (resource-check var accessor
		  (logior Font-Resource-Type GContext-Resource-Type)
		  'Bad-Font))

(defun newid-check (var accessor)
  (ignore accessor)
  `(((or (/= (logandc2 ,var *resource-id-mask*) (state.id-base state))
	 (gethash ,var *resources*))
     (Bad-IDChoice ,var))))

(defun device-check (var accessor)
  (ignore accessor)
  `(((not (member ,var (global-state.devices *globals*)))
     (Bad-Value ,var))))

(defun keyboard-check (var accessor)
  (cons `((/= (device-class ,var) ,Keyboard-Device-Class)
	  (Bad-Match))
	(device-check var accessor)))

(defun pointer-check (var accessor)
  (cons `((/= (device-class ,var) ,Pointer-Device-Class)
	  (Bad-Match))
	(device-check var accessor)))

(defun atom-check (var accessor)
  (ignore accessor)
  `(((NULL (get-atom-name ,var))
     (Bad-Atom ,var))))

(defun sign-extend-8 (var &optional low high)
  (ignore low high)
  `((when (logtest ,var #x80)
      (decf ,var #x100))))

(defun sign-extend-16 (var &optional low high)
  (ignore low high)
  `((when (logtest ,var #x8000)
      (decf ,var #x10000))))

(defun range-check (var accessor &optional low high)
  (ignore accessor)
  (when (or low high)
    `((,(cond ((and low high)
	       `(or (< ,var ,low) (> ,var ,high)))
	      (low
	       `(< ,var ,low))
	      (t
	       `(> ,var ,high)))
       (Bad-Value ,var)))))

(defun member-check (var accessor &rest vals)
  (ignore accessor)
  (when vals
    (let ((z (1- (length vals))))
      (setq vals (sort (mapcar #'eval vals) #'<))
      `((,(cond ((and (zerop z)
		      (zerop (first vals)))
		 `(zerop ,var))
		((zerop z)
		 `(< ,var ,(1+ (first vals))))
		((loop for v in vals
		       for i from 0
		       always (eql v i))
		 `(> ,var ,z))
		(t
		 `(not (member ,var ',vals))))
	 (Bad-Value ,var))))))

(DEFUN keycode-check (var accessor)
  (IGNORE accessor)
  `(((OR (< ,var 8) (> ,var 255))
     (bad-value ,var))))

(defun bool-check (var accessor)
  (ignore accessor)
  `(((> ,var 1)
     (Bad-Value ,var))))

(defun oneof-length (type &rest values)
  (ignore values)
  (get type :length))

(defun oneof-fixup (var type &rest values)
  (let ((fixup (get type :fixup)))
    (when fixup
      `((unless ,(if values `(member ,var ',(mapcar #'eval values)) `(zerop ,var))
	  . ,(funcall fixup var))))))

(defun oneof-check (var accessor type &rest values)
  (let ((check (get type :check)))
    (when check
      (loop for (pred . body) in (funcall check var accessor)
	    collect `((and (not ,(if values
				     `(member ,var ',(mapcar #'eval values))
				     `(eql ,var 0)))
			   ,pred)
		      . ,body)))))

(defun bitmask-length (mask &optional type)
  (ignore mask)
  (if type (get type :length) 4))

(defun bitmask-check (var accessor mask &optional type)
  (ignore accessor type)
  `(((if (= length 1)
	 (logtest ,var (1- ,var))
	 (/= length (logcount ,var)))
     (Bad-Length))
    ((logtest ,var ,(lognot (eval mask)))
     (Bad-Value ,var))))

(defun maskbits-length (mask &optional type)
  (ignore mask)
  (if (consp type) (setq type (eval type)))
  (if type (get type :length) 2))

(defun maskbits-check (var accessor mask &optional type)
  (ignore accessor type)
  `(((not (zerop (logandc2 ,var ,mask)))
     (Bad-Value ,var))))

(defun swap-buf-word (length)
  `((rotatef (aref bytes ,(if (zerop length) 'offset `(+ offset ,length)))
	     (aref bytes (+ offset ,(+ length 1))))))

(defun swap-buf-long (length)
  `((rotatef (aref bytes (+ offset ,(+ length 1)))
	     (aref bytes (+ offset ,(+ length 2))))
    (rotatef (aref bytes ,(if (zerop length) 'offset `(+ offset ,length)))
	     (aref bytes (+ offset ,(+ length 3))))))

(defsubst key-to-length (size)
  (getf '(:byte 1 :word 2 :long 4) size))

;1;;*
;1;; DEBUG MACROS*
;1;;*
(DEFUN compiling-function ()
  "2When called from within a macro, returns the name of the function being comiled*"
  (AND (BOUNDP 'compiler:*current-compiland*)
       (compiler:compiland-function-name compiler:*current-compiland*)))

(DEFMACRO server-trace-variable (&rest variables)
  "2Print VARIABLES to DEBUG-IO.*"
  `(server-trace "~%;; From ~a; ~@{~<~%;;~1:; ~@[~a~] ~s~>~^,~2,10t~}."
		 ',(or (compiling-function) 'unknown)
		 ,@(loop for previous first nil then variable
			 for variable in variables
			 unless (or (CONSTANTP variable)
				    (and (consp previous)
					 (eq (car previous) 'quote)))
			 collect (list 'quote variable)
			 collect variable)))

(DEFMACRO server-trace-request (name length type length-arg &rest variables)
  "2Print request trace*"
  `(when *monochrome-server-trace-enabled*
     (server-trace-fast "(REQUEST " (state.sequence-id state) " is " ',name "; "
		   ,@(loop for variable in variables
			   with last = (car (last variables))
			   collect (list 'quote variable)
			   collect variable
			   unless (eq variable last)
			   collect ", "))
     ,(case type
	(:byte
	 `(server-trace-bytes bytes (+ byte-offset ,length) ,length-arg))
	(:word
	 `(server-trace-words words (+ word-offset ,(truncate length 2))
			      (truncate ,length-arg 2)))
	(:long
	 `(server-trace-longs longs (+ long-offset ,(truncate length 4))
			      (truncate ,length-arg 4))))))

;;; Hairy macro for defining a core request.  The request format is
;;; derived from the order and types of arguments.  Takes care of
;;; checking that the request is the correct length, and extracts and
;;; verifies all fixed arguments.  Also defines the byte-swapping
;;; routine for the request.  The first argument is optionally (:SOLO),
;;; to indicate the entire request must execute exclusively, or
;;; (:GRAPHICS), to indicate normal GC+DRAWABLE locking.  The last
;;; argument is optionally of the form (variable &optional multiple),
;;; where variable is one of (:BYTE :WORD :LONG), to indicate that the
;;; request has variable length.  If the variable part must occur in
;;; multiples, then this integer factor can optionally be specified.  If
;;; the variable part must be rounded up from the value of a particular
;;; argument, then the argument name can be specified as the multiple
;;; instead, optionally followed by a further integer multiple.  If the
;;; variable part has variable content, multiple can be specified as a
;;; list of (:BYTE :WORD :LONG).  In the body of the request, LENGTH
;;; will be set to the length of the variable args, expressed in terms
;;; of MULTIPLEs.  <VARIABLE>-OFFSET will be the index in <VARIABLE>S of
;;; the first variable argument.

(defmacro defreq (name (&rest args) &body body)
  (unless body
    (warn "~%WARNING: The body of the ~s request isn't implemented" name))
  (let (solo
	graphics
	variable
	(multiple 1)
	length-arg
	(opcode (intern (concatenate 'simple-string  (symbol-name name) "-OPCODE")))
	swap-name
        ;; Number of bytes that have already been processed.  We start at 1 because
        ;; we have already `processed' the opcode byte.
	(length 1)
	let-args
	fixups
	checks
	swaps
	(byte-uses 0)
	(word-uses 0)
	(long-uses 0))
    (setq name (intern (concatenate 'simple-string (symbol-name name) "-REQUEST")))
    (setq swap-name name)
    (when (or (setq solo     (eq (car (first args)) :solo))
	      (setq graphics (eq (car (first args)) :graphics)))
      (setq args (rest args)))
    (setq variable (car (last args)))
    (cond ((member (first variable) '(:byte :word :long))
	   (setq multiple (or (second variable) 1))
	   (setq args (nbutlast args))
	   (cond ((symbolp multiple)
		  (setq length-arg multiple)
		  (setq multiple (* (or (third variable) 1) (key-to-length (first variable))))
		  (push `((/= length (logandc2 (+ ,(if (= multiple 1)
						       length-arg
						       `(* ,length-arg ,multiple))
						  3)
					       3))
			  (Bad-Length))
			checks)
		  (setq multiple 1))
		 ((consp multiple)
		  (setq length-arg multiple)
		  (setq multiple
			(truncate (loop for piece in length-arg
					sum (key-to-length piece))
				  (key-to-length (first variable))))))
	   (setq variable (car variable))
	   (setq multiple (* multiple (case variable
					(:byte
					  (incf byte-uses)
					  1)
					(:word
					  (incf word-uses)
					  2)
					(:long
					  (incf long-uses)
					  4)))))
	  (t
	   (setq variable nil)))
    (multiple-value-setq (length let-args fixups checks swaps)
      (parse-request-args args byte-uses word-uses long-uses))
    (when variable
      (when (and (> multiple 1) (listp length-arg))
	(push `(setq length (truncate length ,multiple)) fixups))
      (cond ((consp length-arg)
	     (push `(loop for offset from (+ offset ,length) below (+ offset length)
				     by ,multiple
			  do ,@(loop with index = 0
				     for piece in length-arg
				     append (case piece
					      (:word (swap-buf-word index))
					      (:long (swap-buf-long index)))
				     do (incf index (key-to-length piece))))
		   swaps))
	    ((neq variable :byte)
	     (push `(loop for offset from (+ offset ,length) below (+ offset length)
				     by ,(if (eql variable :word) 2 4)
			  do ,@(if (eql variable :word)
				   (swap-buf-word 0)
				   (swap-buf-long 0)))
		   swaps))))
    (when graphics
      (setq body `((perform-graphics (,(car (find-if #'(lambda (type) (or (eq type 'DRAWABLE)
									  (eq type 'WINDOW)))
						     args :key #'second))
				      ,(car (find-if #'(lambda (type) (eq type 'GCONTEXT))
						     args :key #'second)))
		     . ,body))))
    (case variable
      (:byte
	(push `(incf byte-offset ,length) body))
      (:word
	(push `(incf word-offset ,(truncate length 2)) body))
      (:long
	(push `(incf long-offset ,(truncate length 4)) body)))
    (when checks
      (setq body `((cond ,@checks (t . ,body)))))
    (setq body `(let* ,let-args
		  ,@fixups
		  (server-trace-request ,name ,length ,variable
					,(or (and (symbolp length-arg)
						  (not (keywordp length-arg))
						  length-arg)
					     `(* length ,multiple))
					,@(mapcar #'car args)) ;1; DEBUG*
		  . ,body))
    (when solo
      (setq body `(with-solo-control (state) ,body)))
    (when swaps
      (setq swap-name (intern (concatenate 'simple-string "SWAPPED-" (symbol-name name))))
      (setq swaps `((defun ,swap-name (state offset length)
		      (if ,(cond ((and (> multiple 4)
				       (not (logtest multiple (1- multiple))))
				  `(and (>= length ,length)
					(not (logtest (- length ,length) ,(1- multiple)))))
				 ((> multiple 4)
				  `(and (>= length ,length)
					(zerop (mod (- length ,length) ,multiple))))
				 (variable
				  `(>= length ,length))
				 (t
				  `(eql length ,length)))
			  (let ((bytes (state.bytes state)))
			    (declare (sys:array-register bytes))
			    ,@swaps
			    (,name state offset length))
			  (Bad-Length))))))
    `(progn
       (defun ,name (state byte-offset length)
	 ,@(unless let-args '((ignore state byte-offset)))
	 (if ,(cond ((and (> multiple 4)
			  (not (logtest multiple (1- multiple))))
		     `(and (not (minusp (decf length ,length)))
			   (not (logtest length ,(1- multiple)))))
		    ((> multiple 4)
		     `(and (not (minusp (decf length ,length)))
			   (zerop (mod length ,multiple))))
		    (variable
		     `(not (minusp (decf length ,length))))
		    (t
		     `(eql length ,length)))
	     ,body
	     (Bad-Length)))
       (setf (aref *little-endian-table* ,opcode) #',name)
       ,@swaps
       (setf (aref *big-endian-table* ,opcode) #',swap-name))))

(defun parse-request-args (args byte-uses word-uses long-uses
			   &aux (length 1) let-args fixups checks swaps)
  (loop for (arg type) in args
	for first-time first t then nil
	for more-args = nil
	when (consp type)
	do (setq more-args (cdr type))
	(setq type (car type))
	for len = (get type :length)
	unless (numberp len)
	do (setq len (apply len more-args))
	for fixup = (get type :fixup)
	for check = (get type :check)
	for round = (1- (min len 4))
	;; Make sure that this arg starts on a byte/word/long (1, 2 or 4 byte) boundary.
	do (setq length (logandc2 (+ length round) round))
	(push (list arg (case len
			  (1
			   (incf byte-uses)
			   `(aref bytes (+ byte-offset ,length)))
			  (2
			   ;; If the first item is a :WORD then we need to skip over
			   ;; the request length field.
			   (when first-time
			     (incf length 2))
			   (incf word-uses)
			   `(aref words (+ word-offset ,(truncate length 2))))
			  (4
			   (incf long-uses)
			   `(aref longs (+ long-offset ,(truncate length 4))))
			  (t
			   `(+ byte-offset ,length))))
	      let-args)
	(case len
	  (2 (setq swaps (append (swap-buf-word length) swaps)))
	  (4 (setq swaps (append (swap-buf-long length) swaps))))
	(incf length len)
	(when (and (= len 1) first-time)
	  ;; The byte field was just after the opcode field.  We also need to
	  ;; skip over the request-length field, hence the 2.
	  (incf length  2))
	when fixup
	do (setq fixups (append (apply fixup arg more-args) fixups))
	when check
	do (setq checks (append (apply check arg (cadar let-args) more-args)
				checks)))
  ;; Start on the next 4 byte boundary.
  (setq length (logand (+ length 3) #xFFFFC))
  (setq let-args (nreverse let-args))
  (when (plusp long-uses)
    (push '(longs (state.longs state)) let-args)
    (push `(long-offset (truncate byte-offset 4)) let-args))
  (when (plusp word-uses)
    (push '(words (state.words state)) let-args)
    (push `(word-offset (truncate byte-offset 2)) let-args))
  (when (plusp byte-uses)
    (push '(bytes (state.bytes state)) let-args))
  (setq fixups (nreverse fixups))
  (setq checks (nreverse checks))
  (setq swaps (nreverse swaps))
  (values length let-args fixups checks swaps))

;;; Each arm is of the form ((mask type &optional var errors-p) body)
;;; Returns true if an error is generated, otherwise the final-body is executed
;;; and the value of its last form is returned.

(defmacro process-values ((value-mask buf index)
			  (&rest locals)
			  (&rest arms)
			  &body final-body)
  `(let ,locals
     (or ,@(loop with default-var = (car locals)
		 with accessors = `(1 (ldb (byte 8 0) (aref ,buf ,index))
				      2 (ldb (byte 16 0) (aref ,buf ,index))
				      4 (aref ,buf ,index))
		 with incr = `(incf ,index)
		 for ((mask type var errors-p) . body)
		     in (sort arms #'< :key #'(lambda (arm) (eval (caar arm))))
		 unless var
		   do (setq var default-var)
		 for more-args = nil
		 when (consp type)
                   do (setq more-args (cdr type)
			    type (car type))
		 for len = (get type :length)
		 unless (numberp len)
		   do (setq len (apply len more-args))
		 for accessor = (getf accessors len)
		 for fixup = (get type :fixup)
		 when fixup
		   do (setq fixup (nreverse (apply fixup var more-args)))
		 for check = (get type :check)
		 when check
		   do (setq check (nreverse (apply check var accessor more-args)))
		 do (push incr body)
		 unless errors-p
		   do (setq body (append body '(nil)))
		 when check
		   do (setq body `((cond
				     ,@check
				     (t
				      ,@body))))
		 collect `(when (logtest ,value-mask ,mask)
			    (setq ,var ,accessor)
			    ,@fixup
			    . ,body))
	 ,@(when final-body
	     `((progn . ,final-body))))))

;;; The following macro simply does a reply. It does not deal with 32 byte
;;; boundaries but does handle byte swapping.  This one is useful for those
;;; cases where it is known that the reply is > 32 bytes or the components
;;; of the reply may vary in length (e.g. strings).

;;; A string may be one of three types: a sequence of 1 bytes characters (i.e.
;;; a STRING8), a sequence of 2 byte characters (i.e.  a STRING16), or a 1
;;; byte length field followed by a sequence of 1 bytes characters (i.e.  a
;;; STR).  In the first two cases the length field is located elsewhere in
;;; the reply.
(DEFMACRO SIMPLE-REPLY ((STATE &OPTIONAL (INITIAL-INDEX 0)) &body COMPONENTS)
  ;; State really isn't being ignore since it is used by the macros called
  ;; here, but we must make the compiler happy since it only looks at this
  ;; level of macro expansion.
  `(LET ((BYTES (RESPONSE.BYTES (STATE.RESPONSE ,STATE)))
           (OUTPUT-BUFFER-INDEX   ,INITIAL-INDEX))
       ,@(LOOP WITH LENGTH-DETERMINABLE-P = (NUMBERP INITIAL-INDEX)
               WITH DETERMINABLE-BUFFER-INDEX = INITIAL-INDEX
               FOR (KEY VAL) ON COMPONENTS BY #'CDDR
               COLLECTING `(PROGN
                             ;; The following is a code expansion efficiency hack.  The
                             ;; idea is that if we know if the buffer can't be full then
                             ;; we don't bother performing the `buffer full' check.
                             ,(WHEN (OR (NOT LENGTH-DETERMINABLE-P)
                                        (>= DETERMINABLE-BUFFER-INDEX RESPONSE-LENGTH))
                                (IF (AND LENGTH-DETERMINABLE-P
                                         (>= DETERMINABLE-BUFFER-INDEX RESPONSE-LENGTH))
                                    (PROGN
                                      ;; Don't even bother checking since we know
                                      ;; that the buffer is full.
                                      (SETQ DETERMINABLE-BUFFER-INDEX 0)
                                      `(PROGN
                                         (SERVER-STRING-OUT ,STATE BYTES OUTPUT-BUFFER-INDEX)
                                         (SETQ OUTPUT-BUFFER-INDEX 0)))
                                    ;;1ELSE*
                                    `(WHEN (>= OUTPUT-BUFFER-INDEX ,RESPONSE-LENGTH)
                                       (SERVER-STRING-OUT ,STATE BYTES OUTPUT-BUFFER-INDEX)
                                       (SETQ OUTPUT-BUFFER-INDEX 0))))
                             ,(CASE (KEY-TO-LENGTH KEY)
                                (1
                                 (WHEN LENGTH-DETERMINABLE-P
                                   (INCF DETERMINABLE-BUFFER-INDEX))
                                 `(WRITE-8  ,VAL))
                                (2
                                 (WHEN LENGTH-DETERMINABLE-P
                                   ;; Align on a 16 bit boundary and increment for the length
                                   ;; of this item.
                                   (SETQ DETERMINABLE-BUFFER-INDEX
                                         (+ (LOGANDC2 (+ DETERMINABLE-BUFFER-INDEX (1- 2)) (1- 2))
                                            2)))
                                 `(WRITE-16 ,VAL))
                                (4
                                 (WHEN LENGTH-DETERMINABLE-P
                                   ;; Align on a 32 bit boundary and increment for the length
                                   ;; of this item.
                                   (SETQ DETERMINABLE-BUFFER-INDEX
                                         (+ (LOGANDC2 (+ DETERMINABLE-BUFFER-INDEX (1- 4)) (1- 4))
                                            4)))
                                 `(WRITE-32 ,VAL))
                                (OTHERWISE
                                 ;; Most of the strings written will not be constants so it is a
                                 ;; waste of effort to check to see if the string is a constant
                                 ;; and keep on calculating the determinable-buffer-index.
                                 (SETQ LENGTH-DETERMINABLE-P NIL)
                                 (CASE KEY
                                   (:STRING8
                                    ;; The second argument NIL says to not do any
                                    ;; padding to word boundaries after outputting
                                    ;; the string.
                                    `(WRITE-STRING8 ,VAL NIL))
                                   (:STRING16
                                    `(WRITE-STRING16 ,VAL NIL))
                                   (:STR
                                    `(WRITE-STR ,VAL NIL)))))))
       OUTPUT-BUFFER-INDEX))

;;; COMPONENTS is a list of length and value pairs.  The length can be
;;; :byte, :word or :long.  The value comes out of the bytes/words/longs
;;; array in the state buffer.
(defmacro format-response ((state buf &optional mode) &body components)
  (let (
        ;; sets is used to initialize the appropriate byte/word/long array element
        ;; with its intended value.
        sets
	lets
	swaps
	(index 0)
	(bytes 0)
	(words 0)
	(longs 0))
    (loop for (len val) on components by #'cddr
	  do (setq len (key-to-length len))
             ;; Put the index on the proper boundary.
	     (setq index (logandc2 (+ index (1- len)) (1- len)))
	     (case len
	       (1
		 (incf bytes)
		 (push `(setf (aref bytes ,index) ,val) sets))
	       (2
		 (incf words)
		 (push `(setf (aref words ,(truncate index 2)) ,val) sets)
		 (push `(rotatef (aref bytes ,index) (aref bytes ,(1+ index))) swaps))
	       (4
		 (incf longs)
		 (push `(setf (aref longs ,(truncate index 4)) ,val) sets)
		 (push `(rotatef (aref bytes ,(+ index 0)) (aref bytes ,(+ index 3))) swaps)
		 (push `(rotatef (aref bytes ,(+ index 1)) (aref bytes ,(+ index 2))) swaps)))
	     (incf index len))
    (when (plusp longs)
      (push `(longs (response.longs ,buf)) lets))
    (when (plusp words)
      (push `(words (response.words ,buf)) lets))
    (when (plusp (+ bytes words longs))
      (push `(bytes (response.bytes ,buf)) lets))
    `(let ,lets
       ,@(when swaps
	   '((declare (sys:array-register bytes))))
       ,@(nreverse sets)
       ,@(when swaps
	   `((when (state.swap-p ,state)
	       . ,(nreverse swaps))))
       ,@(when (member mode '(:send :push))
	   `((server-string-out ,state
				,(if (plusp (+ bytes words longs))
				     'bytes
				     '(response.bytes buf))
				,(max Response-Length (logandc2 (+ index 3) 3)))))
       ,@(when (eq mode :push)
	   `((server-push ,state))))))

(defmacro format-reply ((state &optional (length 0)) &body components)
  (let ((index 1))
    (setq components
	  (if components
	      (loop for (len val . rest) on components by #'cddr
		    for n = (key-to-length len)
		    do (setq index (logandc2 (+ index (1- n)) (1- n)))
		    when (<= 2 index 4)
		      collect :word and collect `(state.sequence-id ,state)
		      and collect :long and collect length
		      and do (setq index 8)
		    collect len
		    collect val
		    do (incf index n)
                    ;; We do this check twice because of a problem when the only
                    ;; component was :byte.  In that case, the first check failed
                    ;; and no sequence-id information was generated.  This caused
                    ;; the client to fail since it got a zero sequence-id.  By
                    ;; putting this in twice, we are more certain in generating
                    ;; this necessary information.  Note that once we have
                    ;; generated a sequence-id then the predicate is false and we
                    ;; are guaranteed in not generating two of them.
		    when (<= 2 index 4)
		      collect :word and collect `(state.sequence-id ,state)
		      and collect :long and collect length
		      and do (setq index 8)
		    when (and (null rest) (<= index 4))
		      collect :long and collect length)
	      `(:long ,length)))
    (setq index (logandc2 (+ index 3) 3))
    (when (> index Response-Length)
      ;; Set the first long component (the length field) to a count of the number of LONGs.
      (setf (getf components :long) (floor (+ length (- index Response-Length)) 4)))
    `(let ((buf (state.response ,state)))
       (setf (response.chain buf) ,(max index Response-Length))
       (format-response (,state buf :PUSH)
			:byte Reply-Response
			. ,components))))

;;; The following are used to implement short forms for drawables and booleans.
;;; A drawable is always a long and puts out the drawable's ID.  Use the :DRAWABLE
;;; length keyword and pass the drawable instance.
;;; A boolean is always a byte and puts out 1 if non-NIL and 0 if NIL.
(defsubst event-value-transform (size value)
  (or (getf `(:drawable (if ,value (drawable.id ,value) 0)
              :atom    ,value
              :boolean (if ,value 1 0)) size)
      value))

(defsubst event-len-transform (size)
  (or (getf `(:drawable :long   :boolean :byte   :atom :long) size)
      size))

;;; Similar to format-reply except that it doesn't have a length field and puts in
;;; the event type instead of stuffing Reply-Response.
(defmacro format-event ((state event-type &optional (length 0)) &body components)
  (let ((index 0))
    (setq components
	  (if components
	      (loop for (len val . rest) on components by #'cddr
                    for trans-len = (event-len-transform len)
		    for n = (key-to-length trans-len)
                    for trans-value = (event-value-transform len val)
		    do (setq index (logandc2 (+ index (1- n)) (1- n)))
		    when (<= 2 index 4)
		      collect :word and collect `(state.sequence-id ,state)
		      and do (setq index 2)
		    collect trans-len
		    collect trans-value
		    do (incf index n)
                    ;; We do this check twice because of a problem when the only
                    ;; component was :byte.  In that case, the first check failed
                    ;; and no sequence-id information was generated.  This caused
                    ;; the client to fail since it got a zero sequence-id.  By
                    ;; putting this in twice, we are more certain in generating
                    ;; this necessary information.  Note that once we have
                    ;; generated a sequence-id then the predicate is false and we
                    ;; are guaranteed in not generating two of them.
		    when (<= 2 index 4)
		      collect :word and collect `(state.sequence-id ,state)
		      and do (setq index 2))))
    (setq index (logandc2 (+ index 3) 3))
    (when (> index Response-Length)
      (format t "Warning: Event length of ~D is too large.~%" index)
      ;; Set the first long component (the length field).
      (setf (getf components :long) (+ length (- index Response-Length))))
    `(let ((buf (alloc-event)))
       (setf (response.chain buf) ,(max index Response-Length))
       (format-response (,state buf)
			:byte ,event-type
			. ,components)
       (state-enq-event ,state buf))))


;;; HACK ALERT!  This is used by some of the poly line functions, 
;;; though I suspect this parameter should be gotten from somewhere 
;;; other than a special var!
(DEFPARAMETER COLOR NIL)


(defvar ROOT-BACKGROUND-PIXMAP nil)

(defparameter ROOT-BACKGROUND-PIXMAP-ARRAY
	      ;1; Define the default root background pattern*
	      (let ((array (MAKE-ARRAY `(4 32) :ELEMENT-TYPE `(UNSIGNED-BYTE 1)))
		    (j 0))
		(dolist (fill '(#*0001 #*0100 #*0010 #*1000))
		  (loop for h below 32 by 4 doing
		    (dotimes (i 4) (setf (aref array j (+ i h)) (aref fill i))))
		  (incf j))
		array))