;;; -*- Mode:Common-Lisp; Package:X11; Base:10; Syntax:COMMON-LISP; 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.62; Change ESTABLISH-CONNECTION to support *debug-client-connections-p*.
;;; 03/21/89	WJB	Patch 1.53; Add wholine support
;;; 03/15/89	WJB	Patch 1.45; Use with-solo-control during STATE-SHUTDOWN.
;;; 03/09/89	WJB	Patch 1.36; Dont mess w/ unlinked windows in SHUTDOWN-REPARENT-SAVE-SET.
;;; 03/09/89	WJB	Patch 1.35; New function SHUTDOWN-REPARENT-SAVE-SET to implement save-sets.
;;;			Changed state-shutdown to call it before destroying client windows.
;;; 02/13/89    DAN     Patch 1.12;1 *Added call to FREE-GRABS in STATE-SHUTDOWN to get rid
;;;			of grabs1 *associated with a dying client.
;;; 01/16/89	WJB	In SERVER-TOP-LEVEL, check connection status before attempting to close it.
;;; 01/09/88	WJB	Changed order of tests in SERVER-INPUT-WAIT.  Suspected of causing
;;;			error in scheduler.
;;; 12/213*/88	LGO	1Modify state-shutdown and server-reset to maintain the current selections list.*
;;; 12/211*/88	LGO	1Define bad-implementation, for reporting server errors to the client.*
;;; 12/20/88	LGO	Ensure all locks are cleared in serve1r*-reset
;;; 12/12/88	WJB	Moved the killing of server process from STATE-SHUTDOWN to KILL-CLIENT
;;; 12/08/88    DLS	Changed STATE-SHUTDOWN to kill the server process for the state.
;;; 12/08/88    DLS	Changed SHUTDOWN-DESTROY-WINDOWS to check all child windows.
;;; 11/23/88    LGO	1Flush all output to the client at once.  Server-push now sets a flag for server-flush*
;;; 11/15/88    DLS     Added a reset of the saved server reset time for new timestamp calculation.
;;; 11/10/88    DAN     Fixed SHUTDOWN-DESTROY-WINDOWS for null children.
;;; 10/20/88	WJB	Added call to MAYBE-RESTORE-CURSOR in SERVER.
;;; 10/10/88    LGO     Add local and chaos network support.
;;;  9/129*/88    LGO     1Don't reset the server on no *ACTIVISTS1 goes zero, but when no states.*
;;;  9/12/88    LGO     Add request sequence number to server-trace
;;;  9/09/88    LGO     Make server-string-out1 *a function instead of a defsubst
;;;  9/08/88    LGO     1Rewrite *STATE-SEND-EVENTS1, which was endless-looping sometimes*
;;;  9/08/88    LGO     Eliminate extra work in1 server and* server-string-out1 *when server-trace is off
;;;  9/07/88    LGO     Fixed SEND-ERROR to format error reply properly
;;;  9/01/88    DAN     Fixed STATE-SHUTDOWN to delete closed connections from *GLOBALS*.
;;;  7/26/88    DAN	Added call to CREATE-ROOT-CURSOR to PROCESS-CLIENT-CONNECTION.
;;;  7/05/88	WJB	In SERVER-STRING-OUT, check if connection closed before sending 
;;;			to prevent errors during shutdown.
;;;  6/16/88	WJB	Changes to clean up build dependencies.
;;;  6/14/88    TWE	Fixed SERVER-TOP-LEVEL to remove a hack alert.  Added code in
;;;			STATE-SHUTDOWN to deallocate the connection ID.
;;;  6/13/88    TWE	Removed CLRHASH from STATE-SHUTDOWN and added code to remove
;;;			resources specific to the connection.
;;;  6/06/88    DAN	Changed SERVER to enclose the request trace output in ()'s so one
;;;			can tell when the request has been completed.
;;;  6/01/88    TWE	Fixed the server shutdown code by changing the listen and read
;;;			macros.
;;;  5/27/88    TWE	Changed SERVER to output the request name and to separate each 4
;;;			bytes of a request with an extra space.
;;;  5/05/88    TWE	Fixed SHUTDOWN-DESTROY-WINDOWS again.
;;;  5/03/88    TWE	Changed SERVER-RESET to clear out the event queues too.  Put more
;;;			trace code in establish-connection for network errors.
;;;  4/13/88    TWE	Put in a call to SERVER-RESET in SERVER-TOP-LEVEL when no clients
;;;			remain.  Removed the call to INITIALIZE-MONOCHROME-SERVER in
;;;			PROCESS-CLIENT-CONNECTION since we are doing that at system
;;;			creation time.
;;;  4/13/88    DAN	Changed SERVER-RESET to call CLEAR-NON-PREDEFINED-ATOMS.
;;;  4/13/88    TWE	Changed `shutting down server' to `shutting down connection'
;;;			since it is really shutting down only the connection.
;;;  4/12/88    TWE	Commented the version of BAD-ATOM that goes into the error
;;;			handler.  Changed ESTABLISH-CONNECTION to not have it set up the
;;;			predefined atoms.  Moved that call to
;;;			INITIALIZE-MONOCHROME-SERVER.
;;;  4/05/88    TWE	Fixed SERVER-TOP-LEVEL to check for a connection timeout.
;;;  4/04/88    TWE	Fixed SHUTDOWN-DESTROY-WINDOWS to fix the loop termination
;;;			condition.
;;;  3/30/88    TWE	Implemented SHUTDOWN-DESTROY-WINDOWS and put it in the server
;;;			shutdown code.  This will get rid of windows when the server's
;;;			connection is being closed.
;;;  3/29/88    TWE	Changed process-client-connection to set up the window for the
;;;			screen.
;;;  3/25/88    TWE	Moved the screen/root initializations out of the connection setup
;;;			function.
;;;  3/03/88    TWE	Set up the frame-buffer-descriptors.
;;;  3/01/88    TWE	Added a call to EVENT-SELECT-FOR-WINDOW when the root window gets
;;;			created, just like the C code does.
;;;  2/19/88    TWE	Changed trace code to call the server-trace function instead.
;;;  2/15/88    TWE	Added code to set up the screen-info variable.
;;;  2/05/88    TWE	Updated to reflect the new fact that the window's event-masks
;;;			slot is a list of state/mask pairs.
;;;  1/26/88    TWE	Added the occlusion-stack initialization for the root window.
;;;  1/13/88    TWE	Changed references to tv:initial-lisp-listener to
;;;			*monochrome-server-trace*.
;;; 12/18/87    TWE	Initialized the root to have an event mask of 0 instead of NIL.
;;; 04/04/88	LGO	Generalize the network interface to use IP or CHAOS or LOCAL connections1.*
;;; 04/05/88	LGO	Remove generalized network interface, keeping the fix to server-input-wait.
;;; 04/06/88	LGO	Fixed endless loop in server bug

#|

This file contains the definition of the server function.  One can start up the
server by executing the function SERVER-TOP-LEVEL which is defined here.
Also defined here are the I/O primitives needed by the server to communicate
with the client, as well as the data structures which contain this data.

If you understand the code here, then you also understand the workings of the
server at the top level.

|#


(DEFUN GLOBAL-STATE-ADD-SERVER (SERVER-STATE)
  "2I have no idea what this function really is supposed to do, so for now it does very little.*"
  (PUSH SERVER-STATE (GLOBAL-STATE.STATES *GLOBALS*))
  
;;(send (state.stream server-state) :clear-input) ; for non-networked debugging
  )


(defsubst copy-bytes (size from-array from-index to-array to-index)
  #+explorer
  (COPY-ARRAY-PORTION from-array from-index (+ from-index size) to-array to-index (+ to-index size))
  #-explorer
  (sys:vector-bitblt tv:alu-seta size from-array from-index to-array to-index)
  )

;1; This doesn't work for chaos streams - they don't have a :status method...*
(DEFUN SERVER-UP-P (STREAM)
  "Return non-NIL when STREAM is ready, NIL when it is closed."
  (LET ((STATUS (SEND STREAM :STATUS)))
    ;; If the server is in a :CLOSED or :CLOSE-WAIT state then we assume that it
    ;; is not available anymore.
    (AND (NEQ STATUS :CLOSED) (NEQ STATUS :CLOSE-WAIT))))

(DEFVAR *IDLE-X-SERVER-WHOSTATE* "Request or Event")

(DEFSUBST SERVER-INPUT-WAIT (STATE)
  "2Wait around until we have something to read.*"
  (PROCESS-WAIT *IDLE-X-SERVER-WHOSTATE* 
		#'(LAMBDA (STATE)
		    (OR (STATE.EVENTS STATE)
                        ;; Get out if the connection is closed or almost closed.
                        (NOT (SERVER-UP-P (STATE.STREAM STATE)))
			;; Return if data present
			(SEND (STATE.STREAM STATE) :LISTEN)))
		STATE))

(defsubst server-read-input-buffer (state)
  (event-trace "~%before read, up-p=~A" (SERVER-UP-P (STATE.STREAM STATE)))
  (if (server-up-p (state.stream state))
      (send (state.stream state) :read-input-buffer t)
      ;;ELSE
      nil))

(defsubst server-advance-input-buffer (state end)
  (send (state.stream state) :advance-input-buffer end))
 
(defun server-string-out (state string end &optional (start 0))
  (server-trace "~%")
  (server-trace-bytes string start (- end start) "")
  (if (server-up-p (state.stream state))
      (send (state.stream state) :string-out string start end)
    (server-trace "~%*** Output suppressed... connection is closed" )))

;1; Note: This gets called way too much, causing tiny packets to be sent to the client.*
;1; Set a flag for server-flush so the stream isn't flushed until the server blocks on input to the client.*
(defsubst server-push (state)
  ;1; Remember to flush the server output stream*
  (setf (state.flushp state) t))

(defsubst server-flush (state)
  ;1; REALLY flush the server output stream*
  (when (and (state.flushp state)
	     (server-up-p (state.stream state)))
    (setf (state.flushp state) nil)
    (send (state.stream state) :force-output)))

(defsubst server-stream-tyi (stream)
  (send stream :tyi))

(defsubst server-tyi (state)
  (server-stream-tyi (state.stream state)))

(defsubst activate-server (state)
  (unless (state.server-state state)
    (loop for count = (global-state.activists *globals*)
	  until (and (numberp count)
		     (zerop (global-state.soloists *globals*))
		     (indivisibly-when
		       (store-conditional (locf (global-state.activists *globals*))
					  count (1+ count))
		       (setf (state.server-state state) :activist)))
	  do (process-wait "Activate"
	       #'(lambda () (zerop (global-state.soloists *globals*)))))))

(defsubst deactivate-server (state)
  (when (eq (state.server-state state) :activist)
    (atomically 1- (global-state.activists *globals*) (state.server-state state))))

(defsubst activate-solo (state &optional (mode :soloist))
  (unless (state.server-state state)
    (atomically 1+ (global-state.soloists *globals*) (state.server-state state) mode)
    (atomically-lock global-state.activists *globals* "Solo" 0)))

(defsubst deactivate-solo (state &optional (mode :soloist))
  (when (eq (state.server-state state) mode)
    (atomically-unlock global-state.activists *globals* 0)
    (atomically 1- (global-state.soloists *globals*) (state.server-state state))))

(defsubst soloist-pending-p ()
  (and (plusp (global-state.soloists *globals*))
       (neq (global-state.activists *globals*) sys:current-process)))

;1; Used by EVENT-DISPATCHER*
(defmacro going-solo (&body body)
  "2Ensure all servers are idle while inside BODY*"
  `(progn
     (atomically 1+ (global-state.soloists *globals*))
     (atomically-lock global-state.activists *globals* "Solo" 0)
     (unwind-protect
	 (progn ,@body)
       (atomically-unlock global-state.activists *globals* 0)
       (atomically 1- (global-state.soloists *globals*)))))

(defun state-enq-event (state event)
1  ;; equivalent to:
  ;; (without-interrupts
  ;;   (setf (response.chain event) (state.events state)
  ;;         (state.events state) event))  *
  (loop for next = (state.events state)
	do (setf (response.chain event) next)
	until (store-conditional (locf (state.events state)) next event)
	do (process-allow-schedule)))

(defun state-send-events (state &optional push-p)
  (let (head)
    ;1; Disconnect the event-queue from state, so other processes can add more while we're sending these*
    (loop do (setq head (state.events state))
	  until (store-conditional (locf (state.events state)) head nil)
	  do (process-allow-schedule))
    ;1; The first event on the queue is the most recent.*
    ;1; Send events in reverse order (the number of events should be small)*
    (server-trace "~%Sending events to client ~s" state)
    (labels ((send-events (state head)
	       (let ((next (response.chain head))
		     (code (aref (response.bytes head) 0)))
		 (when next
		   (send-events state next))
		 (server-trace "~%~a" (if (< code (length event-vector))
					    (aref event-vector code)
					  "UNKNOWN"))
		 (server-string-out state (response.bytes head) Response-Length)
		 (dealloc-event head))))
      (send-events state head))
    (server-push state)
    (when push-p
      (server-flush state))))

#+comment ;1; nobody calls this - LGO*
(defun state-send-reply (state &optional push-p)
  (without-activation (state)
    (when (state.events state)
      (state-send-events state))
    (server-string-out state (state.response state) (response.chain (state.response state)))
    (server-push state)
    (when push-p
      (server-flush state))))

(defun cons-state (stream swap-p &optional (length *default-buffer-size*))
  (let* ((bytes (make-array length
			    :element-type '(unsigned-byte 8)))
	 (state (make-state :stream stream :swap-p swap-p
			    :bytes bytes
			    :words (make-array (truncate length 2)
					       :element-type '(unsigned-byte 16.)
					       :displaced-to bytes)
			    :longs (make-array (truncate length 4)
					       :element-type '(unsigned-byte 32.)
					       :displaced-to bytes)
                            ;; Set up the byte specifiers to make byte
                            ;; swapping of 16 and 32 bit values easier.
                            :byte-16-1  (if swap-p (byte 8  8) (byte 8  0))
                            :byte-16-2  (if swap-p (byte 8  0) (byte 8  8))
                            :byte-32-1  (if swap-p (byte 8 24) (byte 8  0))
                            :byte-32-2  (if swap-p (byte 8 16) (byte 8  8))
                            :byte-32-3  (if swap-p (byte 8  8) (byte 8 16))
                            :byte-32-4  (if swap-p (byte 8  0) (byte 8 24))
			    :response (alloc-response *max-reply-length*)
			    :process si:current-process)))
    state))

;;; 1IMPLEMENTATION NOTE:*
;;; Note that the construction of bytes, words and longs done here is NOT
;;; portable.  What should be done is to make this be more hidden so that the
;;; underlying implementation can be changed when necessary.  What needs to be
;;; done is to write accessors for these three components so we can encapsulate
;;; all of the implementation dependencies into just those three accessors.
;;; For the Explorer implementation, this displaced array mechanism will work
;;; just fine.  However, for other implementations, this may not work at all.
;;; Even more, Common Lisp says that it is an error to displace one array onto
;;; another array which has a different element type.  This means that, to be
;;; true Common Lisp, we need to not implement this with displaced arrays, and
;;; instead use one array.  This new implementation should have a 16 bit array
;;; as the base.  This will make 16 bit accesses, like is done for poly-graphic
;;; requests, fast with a single access.  For 8 bit accesses, a 16 bit quantity
;;; would be retrieved and the appropriate 8 bit component would be moved or
;;; masked-in to isolate it from the other 8 bit component.  For a 32 bit
;;; quantity, it would be built from 2 16 bit quantities, and most likely would
;;; cons up a 32 bit number (on some implementations, a 32 bit quantity may be
;;; a fixnum, and so it would not cons there).  The following are examples of
;;; the accessors.  The reason that these are examples is that they haven't
;;; been tested enough.

(PROCLAIM '(INLINE WORD-REF BYTE-REF LONG-REF))

(DEFUN WORD-REF (ARRAY INDEX)
  (AREF ARRAY (ASH INDEX -1)))

(DEFUN BYTE-REF (ARRAY INDEX)
  (LET ((ELEMENT (AREF ARRAY (ASH INDEX -1))))
    (IF (EVENP INDEX)
        (LOGAND ELEMENT #xFF)
        ;;1ELSE*
        (LDB (BYTE 8 8) ELEMENT))))

(DEFUN LONG-REF (ARRAY INDEX)
  (LET ((ELEMENT0 (AREF ARRAY (ASH INDEX -1)))
        (ELEMENT1 (AREF ARRAY (1+ (ASH INDEX -1)))))
    (DPB ELEMENT0 (BYTE 16 16) ELEMENT1)))

(DEFUN ROUND-UP-TO-NEAREST (NUMBER ROUND)
  "2Round NUMBER up to the nearest multiple of ROUND.*"
  (LOGAND (- ROUND) (+ (1- ROUND) NUMBER)))

;;; The following macros are special purpose ones designed to make it
;;; a bit easier in interfacing to a buffer.  Each of these depend
;;; upon the symbol STATE being in the environment and the output
;;; macros depend upon the symbol OUTPUT-BUFFER-INDEX being in the
;;; environment to move to the next element, as well as the symbol
;;; BYTES as the byte array into which values are placed.
(DEFMACRO READ-INT16 ()
  `(LET ((SIMPLE-VALUE (DPB (SERVER-TYI STATE) (STATE.BYTE-16-1 STATE)
                            (DPB (SERVER-TYI STATE) (STATE.BYTE-16-2 STATE) 0))))
     (WHEN (LOGBITP 15 SIMPLE-VALUE)
       (SETQ SIMPLE-VALUE (- SIMPLE-VALUE (EXPT 2 16))))
     SIMPLE-VALUE))

(DEFMACRO WRITE-8 (VALUE)
  `(PROGN (SETF (AREF BYTES OUTPUT-BUFFER-INDEX) ,VALUE)
          (INCF OUTPUT-BUFFER-INDEX)))

(DEFMACRO WRITE-16 (VALUE)
  ;; Make sure and only evaluate VALUE once.
  `(LET ((.TEMP-VALUE. ,VALUE))
     ;; Make sure that the buffer index is aligned on a 16 bit boundary.
     (SETQ OUTPUT-BUFFER-INDEX (LOGANDC2 (+ OUTPUT-BUFFER-INDEX (1- 2)) (1- 2)))
     (SETF (AREF BYTES     OUTPUT-BUFFER-INDEX)  (LDB (STATE.BYTE-16-1 STATE) .TEMP-VALUE.))
     (SETF (AREF BYTES (1+ OUTPUT-BUFFER-INDEX)) (LDB (STATE.BYTE-16-2 STATE) .TEMP-VALUE.))
     (INCF OUTPUT-BUFFER-INDEX 2)))

(DEFMACRO WRITE-32 (VALUE)
  ;; Make sure and only evaluate VALUE once.
  `(LET ((.TEMP-VALUE. ,VALUE))
     ;; Make sure that the buffer index is aligned on a 32 bit boundary.
     (SETQ OUTPUT-BUFFER-INDEX (LOGANDC2 (+ OUTPUT-BUFFER-INDEX (1- 4)) (1- 4)))
     (SETF (AREF BYTES      OUTPUT-BUFFER-INDEX)  (LDB (STATE.BYTE-32-1 STATE) .TEMP-VALUE.))
     (SETF (AREF BYTES (+ 1 OUTPUT-BUFFER-INDEX)) (LDB (STATE.BYTE-32-2 STATE) .TEMP-VALUE.))
     (SETF (AREF BYTES (+ 2 OUTPUT-BUFFER-INDEX)) (LDB (STATE.BYTE-32-3 STATE) .TEMP-VALUE.))
     (SETF (AREF BYTES (+ 3 OUTPUT-BUFFER-INDEX)) (LDB (STATE.BYTE-32-4 STATE) .TEMP-VALUE.))
     (INCF OUTPUT-BUFFER-INDEX 4)))

(DEFMACRO WRITE-STRING8 (STRING &OPTIONAL (PAD-P T))
  `(LOOP WITH .TEMP-STRING. = ,STRING
         WITH LENGTH = (LENGTH .TEMP-STRING.)
         FOR INDEX FROM 0 BELOW ,(IF PAD-P `(ROUND-UP-TO-NEAREST LENGTH 4)
                                     ;;1ELSE*
                                     'LENGTH)
         FOR CHAR = (IF (< INDEX LENGTH) (AREF .TEMP-STRING. INDEX) 0)
         DO (PROGN
              (SETF (AREF BYTES OUTPUT-BUFFER-INDEX) CHAR)
              (INCF OUTPUT-BUFFER-INDEX))))

(DEFMACRO WRITE-STR (STRING &OPTIONAL (PAD-P T))
  `(LOOP WITH .TEMP-STRING. = ,STRING
         WITH LENGTH = (LENGTH .TEMP-STRING.)
         INITIALLY (PROGN
                     (SETF (AREF BYTES OUTPUT-BUFFER-INDEX) LENGTH)
                     (INCF OUTPUT-BUFFER-INDEX))
         FOR INDEX FROM 0 BELOW ,(IF PAD-P '(ROUND-UP-TO-NEAREST LENGTH 4)
                                     ;;1ELSE*
                                     'LENGTH)
         FOR CHAR = (IF (< INDEX LENGTH) (AREF .TEMP-STRING. INDEX) 0)
         DO (PROGN
              (SETF (AREF BYTES OUTPUT-BUFFER-INDEX) CHAR)
              (INCF OUTPUT-BUFFER-INDEX))))


;1;;-----------------------------------------------------------------------------*
;1;; Server top-level*

(DEFUN SERVER-TOP-LEVEL ()
  (LET (CONNECTION)
    (UNWIND-PROTECT
        (PROGN
          (SETQ CONNECTION
                (NET:LISTEN-FOR-CONNECTION-ON-MEDIUM
		  :BYTE-STREAM
		  "X11"
		  :STREAM-TYPE :CHARACTER-STREAM
		  :DIRECTION :BIDIRECTIONAL
		  :TIMEOUT (* 60 30) ;1; 30 seconds*
		  :TIMEOUT-AFTER-OPEN NIL
		  :INPUT-BUFFER-SIZE *DEFAULT-BUFFER-SIZE*))
          (WHEN CONNECTION
            ;; Connection didn't time out.
            (ESTABLISH-CONNECTION CONNECTION)))
      ;; Indicate transmission complete and await close completion.
      (WHEN (AND CONNECTION (SERVER-UP-P CONNECTION))
        (SI:SEND CONNECTION :CLOSE))
      (SETQ CONNECTION NIL))
    ;; When thrown out, abort the connection.
    (WHEN (AND CONNECTION (SERVER-UP-P CONNECTION))
      (SI:SEND CONNECTION :ABORT))
    (SERVER-TRACE "~%Connection shut down.~%"))
  (WHEN (NULL (GLOBAL-STATE.STATES *GLOBALS*))
    (SERVER-RESET)))

(DEFUN SERVER-RESET ()
  "2Completely reset the server.*"
  (SERVER-TRACE "~%Server Reset.~%")
  ;; Reset the saved server reset time.
  (setq *time-at-last-server-reset* (get-internal-real-time))
  ;1; Zap the refresh list*
  (setq *windows-needing-refresh* nil)
  ;1; Clear all locks*
  (setf (global-state.activists *globals*) 0
	(global-state.soloists *globals*) 0
	(global-state.window-busies *globals*) 0
	(global-state.tree-busies *globals*) 0
	server-trace-lock nil
	*current-selections* nil)
  ;; Make all connection numbers be available for allocation.
  (LOOP FOR INDEX FROM 0 BELOW (LENGTH *CONNECTIONS-LIST*)
        DO (SETF (AREF *CONNECTIONS-LIST* INDEX) 0))

  ;; Clear the mouse and keyboard event queues.
  (CLEAR-EVENT-QUEUE KEYBOARD-EVENT-QUEUE)
  (CLEAR-EVENT-QUEUE MOUSE-EVENT-QUEUE)

  ;; Need to reset atoms here too.
  (clear-non-predefined-atoms)
  )

(DEFUN PROCESS-CLIENT-CONNECTION (STATE)
  "2Read in the bytes from the client requesting a connection, and reply appropriately.*"
  (LET ((BYTES (STATE.BYTES STATE))
        (SUCCESS 1)
        OUTPUT-BUFFER-INDEX
        MAJOR-VERSION MINOR-VERSION LENGTH-AUTHORIZATION-NAME LENGTH-AUTHORIZATION-DATA
        AUTHORIZATION-NAME AUTHORIZATION-DATA)
    (FLET ()
      ;; First byte is trash.
      (SERVER-TYI STATE)
      (SETQ MAJOR-VERSION (READ-INT16)
            MINOR-VERSION (READ-INT16)
            LENGTH-AUTHORIZATION-NAME (READ-INT16)
            LENGTH-AUTHORIZATION-DATA (READ-INT16)
            AUTHORIZATION-NAME (PROGN
                                 (READ-INT16)     ; Trash
                                 (LOOP WITH STRING = (MAKE-ARRAY 0 :ELEMENT-TYPE :STRING-CHAR
                                                                 :FILL-POINTER 0)
                                       FOR INDEX FROM 0 BELOW (ROUND-UP-TO-NEAREST
                                                                LENGTH-AUTHORIZATION-NAME 4)
                                       FOR CHAR = (SERVER-TYI STATE)
                                       DO (WHEN (< INDEX LENGTH-AUTHORIZATION-NAME)
                                            (VECTOR-PUSH-EXTEND CHAR STRING))
                                       FINALLY (RETURN STRING)))
            AUTHORIZATION-DATA (LOOP WITH STRING = (MAKE-ARRAY 0 :ELEMENT-TYPE :STRING-CHAR
                                                               :FILL-POINTER 0)
                                     FOR INDEX FROM 0 BELOW (ROUND-UP-TO-NEAREST
                                                              LENGTH-AUTHORIZATION-DATA 4)
                                     FOR CHAR = (SERVER-TYI STATE)
                                     DO (WHEN (< INDEX LENGTH-AUTHORIZATION-DATA)
                                          (VECTOR-PUSH-EXTEND CHAR STRING))
                                     FINALLY (RETURN STRING)))
      ;; Note that we have read in all of this data, but we don't do much with it for now.
      ;; Later on we may want to check the authorization name (e.g. a user-id) and the
      ;; authorization data (e.g. a password).
      (WHEN (OR (NOT (= MAJOR-VERSION X-MAJOR-VERSION-NUMBER))
		(NOT (= MINOR-VERSION X-MINOR-VERSION-NUMBER)))
        (SETQ SUCCESS 0))
      (IF (PLUSP SUCCESS)
          ;; Return a success packet to the client, along with
          ;; a description of the screen's capabilities.
          (progn
            (SETF (AREF BYTES 0) 1)    ; Succuss
            (SETQ OUTPUT-BUFFER-INDEX 2)
            (WRITE-16 X-MAJOR-VERSION-NUMBER)
            (WRITE-16 X-MINOR-VERSION-NUMBER)
            (WRITE-16 (+ 8
                         (* 2 *MAX-PIXMAP-FORMATS*)
                         (CEILING VENDOR-STRING-LENGTH 4)
                         (* 18 *MAX-SCREENS*)))
            (WRITE-32 VENDOR-RELEASE-NUMBER)
            ;; Make the id base be based on the connection number.
            (SETF (STATE.ID-BASE STATE) (CONNECTION-NUMBER-TO-ID-MASK
                                          (ALLOCATE-CONNECTION-NUMBER)))
            (WRITE-32 (STATE.ID-BASE STATE))
            (WRITE-32 *RESOURCE-ID-MASK*)
            (WRITE-32 *MAX-MOTION-EVENTS*)
            (WRITE-16 (LENGTH VENDOR-STRING))
            (WRITE-16 *DEFAULT-BUFFER-SIZE*)   ; Maximum request length.
            (WRITE-8 *MAX-SCREENS*)
            (WRITE-8 *MAX-PIXMAP-FORMATS*)
            (WRITE-8 *IMAGE-BYTE-ORDER*)
            (WRITE-8 *BITMAP-FORMAT-BIT-ORDER*)
            (WRITE-8 *BITMAP-FORMAT-SCANLINE-UNIT*)
            (WRITE-8 *BITMAP-FORMAT-SCANLINE-PAD*)
            (WRITE-8 (key-syms-record.min-key-code current-key-syms))
            (WRITE-8 (key-syms-record.max-key-code current-key-syms))
            (WRITE-32 0)               ; Trash
            (WRITE-STRING8 VENDOR-STRING)
            (LOOP FOR PIXMAP-FORMAT-INDEX FROM 1 TO *MAX-PIXMAP-FORMATS*
                  FOR DEPTH IN *PIXMAP-FORMAT-DEPTHS*
                  FOR BITS-PER-PIXEL IN *PIXMAP-FORMAT-BITS-PER-PIXELS*
                  FOR PAD IN *PIXMAP-FORMAT-SCANLINE-PADS*
                  DO (PROGN
                       (WRITE-8 DEPTH)
                       (WRITE-8 BITS-PER-PIXEL)
                       (WRITE-8 PAD)
                       ;; 5 bytes of pad.
                       (LOOP FOR TRASH FROM 1 TO 5
                             DO (WRITE-8 0))))
            (LOOP FOR SCREEN FROM 0 BELOW *MAX-SCREENS*
                  FOR SCREEN-ROOT IN *SCREEN-ROOTS*
                  FOR WINDOW-ROOT IN *WINDOW-ROOTS*
                  FOR WHITE-PIXEL IN *SCREEN-WHITE-PIXELS*
                  FOR BLACK-PIXEL IN *SCREEN-BLACK-PIXELS*
                  FOR INPUT-EVENT IN *SCREEN-INPUT-EVENTS*
                  FOR PIXEL-WIDTH IN *SCREEN-WIDTHS-IN-PIXELS*
                  FOR PIXEL-HEIGHT IN *SCREEN-HEIGHTS-IN-PIXELS*
                  FOR MILLIMETER-WIDTH IN *SCREEN-WIDTHS-IN-MILLIMETERS*
                  FOR MILLIMETER-HEIGHT IN *SCREEN-HEIGHTS-IN-MILLIMETERS*
                  FOR MAX-INSTALLED-MAPS IN *SCREEN-MAX-INSTALLED-MAPS*
                  FOR MIN-INSTALLED-MAPS IN *SCREEN-MIN-INSTALLED-MAPS*
                  FOR ROOT-VISUAL IN *SCREEN-ROOT-VISUALS*
                  FOR BACKING-STORES IN *SCREEN-BACKING-STORES*
                  FOR SAVE-UNDERS IN *SCREEN-SAVE-UNDERS*
                  FOR ROOT-DEPTH IN *SCREEN-ROOT-DEPTHS*
                  FOR (ALLOWED-DEPTH VISUAL-TYPE-COUNT VISUAL-TYPES) IN *SCREEN-ALLOWED-DEPTHS*
                  FOR SCREEN-ROOT-INSTANCE IN (SCREEN-INFO.SCREENS SCREEN-INFO)
                  FOR WINDOW-ROOT-INSTANCE IN (SCREEN-INFO.WINDOWS SCREEN-INFO)
                  DO (PROGN
                       (WRITE-32 WINDOW-ROOT)
                       ;; Note: this is hopefully correct for the multiple-client
                       ;; case.  I think it is. (I leave it as an exercise for the
                       ;; reader to prove this wrong.)   (TWE)
                       (SETF (WINDOW.CLIENT WINDOW-ROOT-INSTANCE) STATE)
                       ;; Be certain to have a place to draw on.
                       (SETF (SCREEN.DEV-PRIVATE SCREEN-ROOT-INSTANCE)
                             (LET ((SERVER-WINDOW (FIND-FREE-X-SERVER-WINDOW)))
                               (WHEN (NULL SERVER-WINDOW)
                                 (SETQ SERVER-WINDOW (MAKE-SERVER-WINDOW)))
                               SERVER-WINDOW))
                       (STORE-RESOURCE SCREEN-ROOT SCREEN-ROOT-INSTANCE)
                       (STORE-RESOURCE WINDOW-ROOT WINDOW-ROOT-INSTANCE)
                       (LET ((*STATE* STATE))
                         (EVENT-SELECT-FOR-WINDOW WINDOW-ROOT-INSTANCE *STATE* 0))
                       (LET ((COLORMAP-INSTANCE (WINDOW.COLORMAP WINDOW-ROOT-INSTANCE)))
                         (STORE-RESOURCE (COLORMAP.ID COLORMAP-INSTANCE) COLORMAP-INSTANCE)
                         (WRITE-32 (COLORMAP.ID COLORMAP-INSTANCE)))
                       (WRITE-32 WHITE-PIXEL)
                       (WRITE-32 BLACK-PIXEL)
                       (WRITE-32 INPUT-EVENT)
                       (WRITE-16 PIXEL-WIDTH)
                       (WRITE-16 PIXEL-HEIGHT)
                       (WRITE-16 MILLIMETER-WIDTH)
                       (WRITE-16 MILLIMETER-HEIGHT)
                       (WRITE-16 MAX-INSTALLED-MAPS)
                       (WRITE-16 MIN-INSTALLED-MAPS)
                       (WRITE-32 ROOT-VISUAL)
                       (WRITE-8 BACKING-STORES)
                       (WRITE-8 SAVE-UNDERS)
                       (WRITE-8 ROOT-DEPTH)
                       (WRITE-8 (LENGTH *SCREEN-ALLOWED-DEPTHS*))
                       (WRITE-8 ALLOWED-DEPTH)
                       (WRITE-8 0)     ; Trash
                       (WRITE-16 (LENGTH VISUAL-TYPES))
                       (WRITE-32 0)    ; Trash
                       (LOOP FOR VISUAL-TYPE IN VISUAL-TYPES
                             DO (PROGN
                                  (STORE-RESOURCE (VISUAL.VID VISUAL-TYPE)   VISUAL-TYPE)
                                  (WRITE-32 (VISUAL.VID                      VISUAL-TYPE))
                                  (WRITE-8  (VISUAL.CLASS                    VISUAL-TYPE))
                                  (WRITE-8  (VISUAL.BITS-PER-RGB-VALUE       VISUAL-TYPE))
                                  (WRITE-16 (LENGTH (VISUAL.COLORMAP-ENTRIES VISUAL-TYPE)))
                                  (WRITE-32 (VISUAL.RED-MASK                 VISUAL-TYPE))
                                  (WRITE-32 (VISUAL.GREEN-MASK               VISUAL-TYPE))
                                  (WRITE-32 (VISUAL.BLUE-MASK                VISUAL-TYPE))
                                  (WRITE-32 0))))) ; Trash
	    ;; Moved to server initialization - \/\/
            ;;(SETQ root-cursor (create-root-cursor *default-cursor-font* 0))
	    )
          ;;1ELSE*
          ;; Return a failure packet to the client.
          (LET ((FAILURE-REASON "Mismatched version number"))
            (SETF (AREF BYTES 0) 0)    ; Failure
            (SETQ OUTPUT-BUFFER-INDEX 2)
            (WRITE-16 X-MAJOR-VERSION-NUMBER)
            (WRITE-16 X-MINOR-VERSION-NUMBER)
            (WRITE-16 (CEILING (LENGTH FAILURE-REASON) 4))
            (WRITE-STRING8 FAILURE-REASON)))
      (SERVER-STRING-OUT STATE BYTES OUTPUT-BUFFER-INDEX)
      (SERVER-PUSH STATE)
      (server-flush state))))

;;; Call establish-connection with a stream object and an instance of the
;;; global-state defstruct.  Create this second argument via a (make-global-state
;;; ...) form.  The operations which need to be supported by the stream are:
;;; :listen :read-input-buffer, :advance-input-buffer, :string-out and
;;; :force-output.
(defun establish-connection (stream)
  (let* (
         ;; Read the `bytes-swapped' mode from the client.
         (MODE (INT-CHAR (SERVER-STREAM-TYI STREAM)))
         STATE
         ;; The B test is for bytes being swapped.
         ;; This tells us which order the client wants bytes sent.
         (swapped (eql (char-code mode) (char-code #\B))))
    (let ((*resources* (global-state.resources *globals*))
	  (*delayed-tree-busies* 0)
	  (*trace-output* *monochrome-server-trace*) ;1; Bind *TRACE-OUTPUT* for debug*
	  (*package* (find-package 'x11)))     ;1; bind *package* for easier debugging*
      (unwind-protect
          (PROGN
            (setq state (cons-state stream swapped))
            ;; I'm not sure that doing the next SETF is correct, but I think so.  (TWE)
            ;; I think it is because the event code needs a hook into *resources*.
            (setf (state.resources state) *resources*)
            (global-state-add-server state)
            (process-client-connection state)
            (condition-case-if (not *debug-client-connections-p*) (condition)
                (server state)
              (sys:network-error
               (server-trace "~%IN ESTABLISH-CONNECTION, Got a network error:~%~a"
			     condition))
              (:NO-ERROR
               (SERVER-TRACE "~%IN ESTABLISH-CONNECTION, Exited SERVER normally.")))
            )
	(finish-tree-delays)
	(case (state.server-state state)
	  (:activist (deactivate-server state))
	  (:soloist  (deactivate-solo   state))
	  (:grabist  (deactivate-solo   state :grabist)))
	(state-shutdown state)))))

(defun server (state)
  (let* ((*state* state)
	 (dispatch (if (state.swap-p state) *big-endian-table* *little-endian-table*))
	 (lo-byte  (if (state.swap-p state) 3 2))
	 (hi-byte  (if (state.swap-p state) 2 3))
	 (buffer (state.bytes state))
	 (buf-size (length buffer))
	 (offset 0)
	 (total  0)
	 (length 4)
	 *major-opcode*)
    (declare (sys:array-register dispatch)
	     (sys:array-register buffer))
    (loop named outer                  ; Until EOF
          do ;1; Get LENGTH bytes into BUFFER starting at index zero*
          (when (and (plusp total) (plusp offset))
            ;; Shuffle the request data down to the front of the buffer.
            (copy-bytes total buffer offset buffer 0)
            (setq offset 0))
          ;;1 Read at least (- LENGTH TOTAL) bytes into BUFFER starting at OFFSET*
          (loop while (< total length)
                do (server-input-wait state)
		(x-wholine-process (state.process state))
		(if (state.events state)
		    (state-send-events state t)
		  (multiple-value-bind (buf start end)
		      (server-read-input-buffer state)
		    (if buf
			(progn
			  (setq end (min end (+ start (- buf-size offset total))))
			  (copy-bytes (- end start) buf start buffer (+ offset total))
			  (incf total (- end start))
			  (server-advance-input-buffer state end))
                      ;;ELSE
                      ;; We got an EOF from the client, indicating a shutdown.
                      (return-from outer nil)))))
          (activate-server state)
          (loop do
                ;; Read the word count from the buffer and convert1 *it to a byte count.
                (setq length (dpb (aref buffer (+ offset hi-byte))
                                  (byte 8 10)
                                  (dpb (aref buffer (+ offset lo-byte))
                                       (byte 8 2)
                                       0)))
                ;; Make sure that (1) there is enough of the request in the buffer.
                ;; (2) we don't have some events that we need to go handle and
                ;; (3) what is this soloist stuff?
                until (or (> length total)
                          (soloist-pending-p))
                ;; Construct a unique sequence-id for this request.  This is
                ;; used for error messages, among other things.
                do
		(when (state.events state)
		  (state-send-events state nil))
		(setf (state.sequence-id state)
		      (ldb (byte 16 0) (1+ (state.sequence-id state))))
                ;; Process the request.
                (setq *major-opcode* (aref buffer offset))
		#+comment ;1; moved to the DEFREQ macro, where more a more detailed printout can be generated*
		(when *monochrome-server-trace-enabled*
		  (server-trace "~%(REQUEST ~d is ~A"
				(state.sequence-id state)
				(FUNCTION-NAME (AREF dispatch *MAJOR-OPCODE*)))
		  (loop for index from 0 below length
			do (PROGN
			     (WHEN (ZEROP (MOD INDEX 4))
			       (SERVER-TRACE " "))
			     (server-trace "~16,3r " (aref buffer (+ index offset))))))
		(when (fboundp 'request-stepper)
		  (funcall 'request-stepper *major-opcode*))
                (funcall (aref dispatch *major-opcode*)
                         state offset length)
                (server-trace ")")
                (incf offset length)
                (when (zerop (decf total length))
                  ;1; Buffer is empty, loop back for more.*
                  (setq length 4)
                  (setq offset 0)
                  (return))
                ;; When the request is larger than the space we have allocated
                ;; for it, we need to enlarge our buffer to handle it.
                finally (when (> length buf-size)
                          (setq buf-size length)
                          (setq buffer (adjust-array buffer buf-size))
                          (setf (state.bytes state) buffer)
                          (setf (state.words state)
                                (adjust-array (state.words state)
                                              (truncate buf-size 2)
                                              :displaced-to buffer))
                          (setf (state.longs state)
                                (adjust-array (state.longs state)
                                              (truncate buf-size 4)
                                              :displaced-to buffer))))

	  (with-cursor-locked (:server)
	    (dolist (window *windows-needing-refresh*)
	      ;1; Cursor should already be removed*
	      (refresh-from-backing-store window))
	    (setq *windows-needing-refresh* nil))
          (finish-tree-delays)
          (deactivate-server state)
	  (maybe-restore-cursor)
	  (server-flush state))))


;;; It is important that this always return true.  We treat an error just like an event
;;; so that we don't have to worry about deactivating the server.  The main server loop
;;; will notice it the next time around.

(defun send-error (error &optional (value 0) (minor-opcode 0))
  ;;(fsignal "Error bad-~a" (aref *error-name-vector* error))
  (let ((buf (alloc-event)))
    (format-response (*state* buf)
		     :byte Error-Response
		     :byte error
		     :word (state.sequence-id *state*)
		     :long value
		     :word minor-opcode
		     :byte *major-opcode*)
    (state-enq-event *state* buf))
  (server-backtrace "~%X-Error Bad-~a code ~d. Value ~s"
		    (aref *error-name-vector* error) error value)
  t)

(defmacro deferrs ((&rest args) &rest names)
  `(progn
     . ,(loop for name in names
	      do (setq name (intern (concatenate 'simple-string "BAD-" (symbol-name name))))
	      collect `(defun ,name ,args (send-error ,name . ,args)))))

(deferrs (value)
	 Value Window Pixmap Atom Cursor Font Drawable Colormap GContext IDChoice)

(deferrs () Request Match Access Alloc Name Length implementation)

;;; If you get a bad match error and you don't know where it is being
;;; generated from, uncomment and compile the following form and you
;;; will get into the error handler (with a backtrace).
;;;(defun bad-idchoice (ignore)
;;;  (format t "~a" (/ user:resources 5))
;;;  (send-error bad-match))

;;; If you get a bad atom error and you don't know where it is being
;;; generated from, uncomment and compile the following form and you
;;; will get into the error handler (with a backtrace).
;;;(defun bad-atom (value)
;;;  (send-error bad-atom value)
;;;  (format t "~a" (/ user:resources 5)))


(defun bad-output (object id)
  (send-error (if (and object (logtest (resource.type object) No-Draw-Window-Resource-Type))
		  Bad-Match
		  Bad-Drawable)
	      id))


(DEFUN STATE-SHUTDOWN (SERVER-STATE)
  (SERVER-TRACE "~%Shutting down connection to ~s." SERVER-STATE)
  (X-WHOLINE-PROCESS (STATE.PROCESS SERVER-STATE) T)
  (WITH-SOLO-CONTROL (SERVER-STATE)
    (SHUTDOWN-REPARENT-SAVE-SET SERVER-STATE)
    (SHUTDOWN-DESTROY-WINDOWS SERVER-STATE)
    ;1; Zap events going to this client*
    (DOLIST (ROOT (SCREEN-INFO.WINDOWS SCREEN-INFO))
      (REMOVE-CLIENTS-EVENTS SERVER-STATE ROOT))
    ;1; Delete this client's selections*
    (SETQ *CURRENT-SELECTIONS*
	  (DELETE SERVER-STATE *CURRENT-SELECTIONS* :KEY #'SELECTION.CLIENT))
    ;1;;Need to get rid of any grabs associated with this connection.*
    (DOLIST (ROOT (SCREEN-INFO.WINDOWS SCREEN-INFO))
      (FREE-GRABS SERVER-STATE ROOT))
    ;1; What we are doing here is to clear out those resources that are associated with this*
    ;1; connection.  We go through all of the entries in the hash table and clear out those*
    ;1; entries that have the ID base associated with this connection.*
    (MAPHASH #'(LAMBDA (KEY IGNORE) 
		 (WHEN (= (LOGAND KEY (LOGNOT *RESOURCE-ID-MASK*))
			  (STATE.ID-BASE SERVER-STATE))
		   ;1; This item was created by this connection, zap it.*
		   (REMHASH KEY (STATE.RESOURCES SERVER-STATE))))
	     (STATE.RESOURCES SERVER-STATE))
    ;; Get rid of the ID base for this connection.
    (DEALLOCATE-CONNECTION-NUMBER (ID-MASK-TO-CONNECTION-NUMBER (STATE.ID-BASE SERVER-STATE)))
    (SETF (GLOBAL-STATE.STATES *GLOBALS*) (DELETE SERVER-STATE (GLOBAL-STATE.STATES *GLOBALS*) 
						  :COUNT 1)))
  (DEACTIVATE-SERVER SERVER-STATE))

(DEFUN SHUTDOWN-REPARENT-SAVE-SET (STATE)
  (LOOP
    FOR SAVE-WINDOW IN (STATE.SAVE-SET STATE)
    FOR DYING-ANCESTOR = NIL
    FOR NEW-PARENT = NIL
    DO
    ;; Ensure window has not been unlinked
    (WHEN (AND (WINDOW.NEXT-SIB SAVE-WINDOW)
	       (WINDOW.PREV-SIB SAVE-WINDOW))
      ;; Find ancestor that belongs to dying client
      (LOOP
	FOR PARENT FIRST (WINDOW.PARENT SAVE-WINDOW) THEN (WINDOW.PARENT PARENT)
	UNTIL (NULL PARENT)
	UNTIL (EQ (WINDOW.CLIENT PARENT) STATE)
	FINALLY (SETQ DYING-ANCESTOR PARENT))
      (WHEN DYING-ANCESTOR
	;; Found ancestor that belongs to client.
	;; Now must find first ancestor that does *not* belong to client (or root window)
	(LOOP
	  WITH PARENT = (WINDOW.PARENT DYING-ANCESTOR) DO
	  (WHEN (OR (NEQ (WINDOW.CLIENT PARENT) STATE)
		    (NULL (WINDOW.PARENT PARENT)))
	    (SETQ NEW-PARENT PARENT)
	    (RETURN))
	  (SETQ PARENT (WINDOW.PARENT PARENT)))
	(WHEN NEW-PARENT
	  ;; Must keep window's absolute X/Y location the same under the new parent
	  (LET ((NEW-RELATIVE-X (- (WINDOW.ABSOLUTE-INSIDE-X SAVE-WINDOW)
				   (WINDOW.ABSOLUTE-INSIDE-X NEW-PARENT)))
		(NEW-RELATIVE-Y (- (WINDOW.ABSOLUTE-INSIDE-Y SAVE-WINDOW)
				   (WINDOW.ABSOLUTE-INSIDE-Y NEW-PARENT))))
	    (REPARENT-WINDOW STATE SAVE-WINDOW NEW-PARENT NEW-RELATIVE-X NEW-RELATIVE-Y))))
      (UNLESS (WINDOW.MAPPED-P SAVE-WINDOW)
	;; Spec states that a window in the save-set gets mapped if it was unmapped, even
	;; if it was not reparented.
	(MAP-WINDOW STATE SAVE-WINDOW)))))


(DEFUN SHUTDOWN-DESTROY-WINDOWS (STATE)
  ;; Go through the window hierarchy destroying windows
  ;; that have been created by this connection.
  ;; NOTE: the destroy-window request will never destroy the root window.
  (LOOP FOR ROOT IN (SCREEN-INFO.WINDOWS SCREEN-INFO)
        DO (shutdown-destroy-windows-1 root state)))

(defun shutdown-destroy-windows-1 (window state)
  ;; If the window has children loop through them to try to destroy.
  (WHEN (WINDOW.FIRST-CHILD window)
    (LOOP WITH LAST-CHILD = (WINDOW.LAST-CHILD window)
	  WITH NEXT-CHILD = NIL
	  FOR CHILD FIRST (WINDOW.FIRST-CHILD window) THEN NEXT-CHILD
	  DO (WHEN child 
	       (SETQ NEXT-CHILD (WINDOW.NEXT-SIB CHILD))
	       (COND ((EQ STATE (WINDOW.CLIENT CHILD))
		      ;; We found a window we created.  Zap it and its children.
		      (DESTROY-WINDOW STATE CHILD)
		      (SETF (WINDOW.CLIENT CHILD) NIL))
		     (T
		      ;; We didn't create this window but check its children.
		      (shutdown-destroy-windows-1 child state)))
	       (WHEN (EQ CHILD LAST-CHILD)
		 (RETURN NIL))))))