;;; -*- Mode:Common-Lisp; Package:X11; Base:10; Fonts:(CPTFONT CPTFONTB CPTFONTBI) -*-

;;;			      RESTRICTED RIGHTS LEGEND

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

#|

This file contains all of the code for requests which deal with fonts.
This includes the requests which perform text output functions.

|#

;;; Change history:
;;;
;;;  Date      Author	Description
;;; -------------------------------------------------------------------------------------
;;; 04/03/89	WJB	Patch 1.68; Revert image/poly-text8/16 to original behavior - the bug
;;;			"fixed" by 1.57 was really in fill-rectangle.
;;; 03/22/89	WJB	Patch 1.57; Fix IMAGE-TEXT requests to properly clear the area drawn to.
;;; 03/16/89	WJB	Patch 1.48; In POLY-TEXT8 fix case where draw-string handles part of
;;;			string but then must switch to using draw-char due to clipping.
;;; 03/09/89	WJB	Patch 1.38; Expand size of character-temp-array to handle *big* fonts.
;;;			In POLY-TEXT8/16; Account for left-side-bearing when copying from temp array.
;;; 03/02/89    DAN     Patch 1.29; Fix POLY-TEXT8 to check for out-of-range or clipped
;;;			characters before it starts looping through calling DRAW-STRING.
;;; 03/02/89	WJB	Changed SET-SERVER-FONT-PATHS to only throw away the font info
;;;			for fonts no longer on the search path.
;;; 02/15/89	WJB	Added SET-SERVER-FONT-PATHS to test if font path really modified.
;;; 01/18/88    LGO	Fix length of last response from list-fonts-with-info
;;; 12/22/88    LGO	Make pattern-match case insensitive.
;;; 12/20/88    LGO	Fix polytext16's use of default character with constant metrics
;;; 12/15/88    LGO	Fix list-fonts-with-info to work with rel3 fonts.
;;; 12/13/88    LGO	Flush the font directory cache in set-font-path
;;; 12/13/88    LGO	Remove assumptions about font name being the same as font symbol
;;; 12/12/88    LGO	Define primitive boxer functions for poly-text8 and poly-text16
;;; 12/07/88    LGO	ensure font symbol is bound in LOAD-FONT-INTERNAL 
;;; 12/06/88    LGO	Offset the position of text by left-side-bearing in poly-text8 and poly-text16
;;; 12/06/88    LGO	Make image-text8 and image-text16 clear the correct rectangle
;;; 12/06/88    LGO	Make query-font return ALL font properties, not just those with predefined atoms
;;; 12/06/88    LGO	Use correct font baseline in poly-text8 and poly-text16
;;; 12/06/88    LGO	Call TEXT-EXTENTS-LOCAL correctly from image-text16
;;; 12/05/88    LGO	Re-write pattern-match-p for correctness and speed
;;; 12/05/88    LGO	Map font names to file names through a fonts.dir file in each font directory
;;; 11/08/88    LGO	Return font properties correctly in query-font
;;; 11/07/88	LGO	Use WITH-DRAWABLE in poly-text8 and poly-text16
;;; 10/18/88	LGO	Fix the pattern matching done by list-fonts and list-fonts-with-info
;;; 10/18/88	LGO	Down-case font-names for unix in list-fonts and list-fonts-with-info
;;; 10/18/88	LGO	Remove duplicate pathnames in set-font-paths
;;; 10/18/88    DAN     HACKED a fix in OPEN-FONT to get rid of .snf extension in font-string.
;;; 10/18/88	LGO	In get-font-directory, only get directory date on lispm's
;;; 10/17/88	LGO	Rewrite SERVER-REPLY-PAD
;;; 10/17/88	LGO	Rewrite SERVER-REPLY-PAD
;;; 10/17/88	LGO	Use *FONT-DEFAULT-SEARCH-PATH* instead of *FONT-DEFAULT-SEARCH-PATH-STRINGS*
;;; 10/10/88	LGO	Bullet-proof LIST-FONTS-WITH-INFO
;;; 10/10/88	LGO	Catch network errors in LOAD-FONT-INTERNAL 1and *get-font-directory 
;;; 10/07/88	LGO	Fix image-text8/16 to pass the correct length to poly-text8/16
;;;  9/29/88	WJB	Fix poly-text8/16 to position character correctly and to work
;;;			at the edges of pixmaps and windows.
;;;  9/30/88    LGO	Ensure poly-text8 and poly-text16 stop at end of request
;;;  9/30/88    LGO	Correct character positioning in poly-text16
;;;  9/26/88    LGO	Fix poly-text8 to use correct alu when drawing on a temporary
;;;  9/26/88    LGO	Fix poly-text8 to handle complex clipping
;;;  9/15/88    LGO	Use %draw-string in poly-text8
;;;  9/14/88    LGO	Eliminate char-info's for fonts with constant metrics
;;;  9/14/88	LGO	Don't load 2 files for every font1 - *file contents have beem merged.
;;;  9/13/88	LGO	Change poly-text8 to draw directly to the screen
;;;  9/12/88	LGO	Fix pathname parsing in SET-FONT-PATH1.*
;;;  9/12/88	LGO	Fix many bugs in MATCHED-FONTS to make it work.
;;;  9/12/88	LGO	Modify PATTERN-TRANSLATE to minimize consing
;;;  9/12/88	LGO	Add get-font-directory to cache font directory lookups
;;;  9/12/88	LGO	Fix QUERY-TEXT-EXTENTS-REQUEST to work when running unswapped
;;;  9/09/88	LGO	Rewrite query-text-extents
;;;  9/09/88	LGO	Fix TEXT-EXTENTS-LOCAL to correctly handle characters not in the font
;;;  9/09/88	LGO	Fix TEXT-EXTENTS-LOCAL to work for fixed-width fonts
;;;  9/08/88	LGO	Rewrite bytes-to-string to minimize consing
;;;  9/01/88	LGO	Remove calls to CLEAR-TEMP-ARRAY
;;;  7/13/88    DAN	Fixed SET-FONT-PATH and GET-FONT-PATH to remember and return the
;;;			string passed by client.
;;;  7/12/88    DAN	Fixed SET-FONT-PATH to parse the pathname using the client's host1.*
;;;  6/07/88    DAN	Fixed image-text8/16 to not invert the alu before calling
;;;			poly-text8/16.
;;;  5/31/88    TWE	Fixed the 4 text drawing functions to handle weird background/
;;;			foreground pixel combinations.
;;;  2/19/88    TWE	Changed trace code to call the server-trace function instead.
;;;  1/27/88    TWE	Fixed up query-font to do a server-push at the end.  Fixed up
;;;			poly-text8 and poly-text16 to handle ALUs properly.
;;;  1/25/88    TWE	Changed LOAD-FONT-INTERNAL to automatically log into the host.
;;;  1/21/88    TWE	Fixed image-text8 and image-text16 to not do anything if there is
;;;			no drawing to be done.  Previously, they cleared the text's
;;;			rectangle.
;;;  1/19/88    TWE	Commented out debug code.
;;;  1/13/88    TWE	Changed references to tv:initial-lisp-listener to
;;;			*monochrome-server-trace*.  Changed POLY-TEXT8 and POLY-TEXT16 to
;;;			handle a new DRAWN-ON-TEMPORARY flag from OBTAIN-DRAWABLE and
;;;			pass it to DRAWING-EPILOGUE.  This eliminates the hack that
;;;			existed before.
;;;  1/05/88    TWE	Removed some debug code.
;;; 12/21/87    TWE	Fixed calls to the function HAVE-DRAWING-TO-DO to pass in the
;;;			drawable so that a mapped-p test can be performed.
;;;  9/14/87    TWE	Initial creation.

;1;; NOTE: There are 3 names associated with a font:*
;1;; * Font-name*  1 *	1There's a fonts.dir file in each font directory *
;1;;*			1which maps font names to font file names.*
;1;;*			1X11 Font names are NOT the same as the font symbol.*
;1;;*
;1;; * Font-symbol *	1interned in the FONTS package, its value is an*
;1;;*			1explorer font object, and it has a :x11-font-info*
;1;;*			1property whose value is an X11 font-info structure.*
;1;;*
;1;; * Font-pathname  The font file name is the same as the font symbol name.*

(DEFUN SERVER-REPLY-PAD (LENGTH STATE)
  "2Pad out to a long boundary.*"
  (server-string-out state '#(0 0 0 0) (logand 3 (- 4 length)))
  (SERVER-PUSH STATE))

(defun load-matched-fonts (max-fonts pattern)
  ;1; Return an alist of list of (font-name font-symbol) that match PATTERN.*
  ;1; loading the font if necessary.*
  (matched-fonts max-fonts pattern
		 #'(lambda (pathname)
		     (condition-case (condition)
			 (let* ((name (string-upcase (pathname-name pathname)))
				(symbol (find-symbol name 'fonts)))
			   (unless (and symbol (boundp symbol))
			     (when (probe-file pathname)
			       ;; Load the font, but don't generate a
			       ;; message saying what was loaded.
			       (server-trace "~%loading font ~a" pathname)
			       (load pathname :verbose nil)
			       (setq symbol (find-symbol name 'fonts))))
			   symbol)
		       ((sys:network-error fs:file-error)
			(server-trace "~%IN LOAD-FONT-INTERNAL, Got a ~a:~%~a"
				      (type-of condition) condition))))))

(defreq Open-Font ((font-id NEWID)
		   (nbytes CARD16)
		   (:byte nbytes))
  (open-font font-id bytes nbytes byte-offset))

(DEFUN OPEN-FONT (FONT-ID NAME-BYTES NAME-BYTE-COUNT OFFSET &OPTIONAL (STORE-RESOURCE T))
;;;          (SERVER-TRACE "~%OPEN-FONT trying to store into font-id ~D"
;;;                  FONT-ID)
  (LET* ((TEMP-STRING (BYTES-TO-STRING NAME-BYTES NAME-BYTE-COUNT OFFSET))
         (bad-stuff-index (SEARCH ".snf" temp-string))
         ;1*HACK* get rid of .snf if stupid client sends it.*
         (font-string (IF bad-stuff-index
                          (SUBSEQ temp-string 0 bad-stuff-index)
                          temp-string))
         FONT-SYMBOL)
    (server-trace " ~a" font-string)
    (setq font-symbol (second (first (LOAD-matched-fonts 1 FONT-STRING))))
    (IF (NULL FONT-SYMBOL)
        (BAD-NAME)
        ;;1ELSE*
        (LET* ((FONT-INFO-RECORD (GET FONT-SYMBOL :X11-FONT-INFO))
               (CHAR-INFOS       (font-info-record.metrics font-info-record))
               (FONT-RECORD      (MAKE-FONT-RECORD
                                    :ID FONT-ID
                                    :TYPE FONT-RESOURCE-TYPE
                                    :FI FONT-INFO-RECORD
                                    :FP (FONT-INFO-RECORD.PROPERTIES FONT-INFO-RECORD)
                                    :CI CHAR-INFOS
                                    :PATHNAME (NAMESTRING (get font-symbol :pathname))
                                    :REFERENCE-COUNT 1
                                    :DEVICE-PRIVATE (symbol-value FONT-SYMBOL))))
;;;          (SERVER-TRACE "~%OPEN-FONT storing into font-id ~D"
;;;                  FONT-ID)
          (WHEN STORE-RESOURCE
            (STORE-RESOURCE FONT-ID FONT-RECORD))
          FONT-RECORD))))

(DEFREQ CLOSE-FONT ((:SOLO)
		    (FONT-ID FONT))
  (REMOVE-RESOURCE FONT-ID)
  )

(DEFREQ LIST-FONTS ((MAX-NAMES CARD16)
		    (NBYTES CARD16)
		    (:BYTE NBYTES))
  (LIST-FONTS STATE MAX-NAMES BYTES NBYTES BYTE-OFFSET)
  )

(DEFUN BYTES-TO-STRING (BYTES LENGTH OFFSET)
  "2Convert BYTES of LENGTH starting at OFFSET to a simple string.*"
  (MAKE-ARRAY length :ELEMENT-TYPE :STRING-CHAR
	      :displaced-to bytes :displaced-index-offset offset)
  #+comment ;1; Yuck!*
  (LOOP WITH STRING = (MAKE-ARRAY 0 :ELEMENT-TYPE :STRING-CHAR :FILL-POINTER 0)
        FOR INDEX FROM OFFSET BELOW (+ OFFSET LENGTH)
        DO (VECTOR-PUSH-EXTEND (AREF BYTES INDEX) STRING)
        FINALLY (RETURN STRING)))

(defun read-font-directory (path)
  (flet ((char-memq (key char)
	  ;; Used as a test function for POSITION
	  (declare (type string-char char))
	  (member char key)))
    (with-open-file (stream path)
      (let ((alist nil)
	    (line (read-line stream)))
	(when (numberp (read-from-string line)) ;1; skip entry count*
	  (setq line (read-line stream)))
	(loop
	  (let* ((end-file (position '(#\tab #\space) line :test #'char-memq))
		 (end-file-name (or (position #\. line :end end-file :from-end t) end-file))
		 (file (subseq line 0 end-file-name))
		 (start-name (position '(#\tab #\space) line :start end-file :test-not #'char-memq))
		 (end-name (position '(#\tab #\space) line :start start-name :test-not #'char-memq :from-end t))
		 (name (subseq line start-name (1+ end-name))))
	    (push (list name file) alist))
	  (unless (setq line (read-line stream nil nil))
	    (return alist)))))))

(defun get-font-directory (directory)
  ;1; Return the list of files in DIRECTORY*
  ;1; Caches the results*
  (let ((cache (assoc directory *font-directory-cache*))
	(path (make-pathname :name "FONTS" :type "DIR" :defaults directory)))
    (unless cache
      (condition-case (condition)
	  (push (setq cache (list directory (read-font-directory path)))
		*font-directory-cache*)
	((fs:file-lookup-error)
	 (push (setq cache (list directory nil)) *font-directory-cache*))
	((sys:network-error fs:file-error)
	 (server-trace "~%IN get-font-directory Got a ~a:~%~a"
		       (type-of condition) condition))))
    (second cache)))

(DEFUN MATCHED-FONTS (MAX-FONTS pattern &optional lambda)
  ;1; Return an alist of list of (font-name font-symbol) that match PATTERN.*
  ;1; LAMBDA is an optional function of one argument, called with each matching font.*
  (server-trace "~%Entering MATCHED-FONTS, pattern ~s" pattern)
  (LET ((LOGOUT-FORM NIL))
    (UNWIND-PROTECT
	(LOOP NAMED OUTER-LOOP
	      WITH FONT-NAME-LIST = NIL
	      WITH FONT-NAME-COUNT = 0
	      FOR PATH IN *FONT-DEFAULT-SEARCH-PATH*
	      FOR OLD-HOST FIRST NIL THEN HOST
	      FOR HOST = (PATHNAME-HOST PATH)
	      do
	      (WHEN (NOT (EQ HOST OLD-HOST))
		;; Logout of the old host before we log into the new one.
		(WHEN LOGOUT-FORM
		  (funcall LOGOUT-FORM))
		(SETQ LOGOUT-FORM (FONT-HOST-LOGIN HOST)))
	      (let* ((DIRECTORY-ALIST (get-font-directory path)))
		(server-trace "~%MATCHED-FONTS, path = ~a " PATH)
		(LOOP FOR (name font) IN DIRECTORY-ALIST
		      DO (WHEN (PATTERN-MATCH-P name PATTERN)
			   (setq font (string-downcase font))
			   (INCF FONT-NAME-COUNT)
			   (server-trace "~%Match ~d is ~a, file ~a" font-name-count name font)
			   (when lambda
			     (setq font (funcall lambda (make-pathname :name (string-upcase font)
								       :type (si:local-binary-file-type)
								       :defaults path))))
			   (when font
			     (PUSH (list name FONT) FONT-NAME-LIST))
			   (WHEN (>= FONT-NAME-COUNT MAX-FONTS)
			     (RETURN-FROM OUTER-LOOP FONT-NAME-LIST)))))
	      FINALLY (RETURN FONT-NAME-LIST))
      ;; Be sure to logout of the font host.
      (WHEN LOGOUT-FORM
	(funcall LOGOUT-FORM)))))

(DEFUN LIST-FONTS (STATE MAX-NAMES PATTERN-BYTES PATTERN-LENGTH OFFSET)
  (LET ((FONT-ALIST (MATCHED-FONTS MAX-NAMES (bytes-to-string PATTERN-BYTES PATTERN-LENGTH OFFSET)))
        (BYTE-COUNT 0))
    ;; Count up the length of the additional data.  This is a 1 byte length
    ;; field plus the font name, up to 8 characters.
    (LOOP FOR (font) IN FONT-alist
          DO (INCF BYTE-COUNT (1+ (LENGTH font))))
    (FORMAT-REPLY (STATE (CEILING BYTE-COUNT 4))
                  :WORD (LENGTH FONT-alist))
    (SERVER-PUSH STATE)
    (LOOP FOR (font) IN FONT-ALIST
          FOR LENGTH = (LENGTH FONT)
          DO (PROGN
               (SERVER-STRING-OUT STATE (vector LENGTH) 1)
               (SERVER-STRING-OUT STATE FONT LENGTH)))
    (SERVER-REPLY-PAD BYTE-COUNT STATE)))

(defreq List-Fonts-With-Info ((max-names CARD16)
			      (nbytes CARD16)
			      (:byte nbytes))
  (LIST-FONTS-WITH-INFO STATE MAX-NAMES BYTES NBYTES BYTE-OFFSET))

(DEFUN LIST-FONTS-WITH-INFO (STATE MAX-NAMES PATTERN-BYTES PATTERN-LENGTH OFFSET)
  (LET* ((FONT-ALIST (load-matched-fonts MAX-NAMES (bytes-to-string PATTERN-BYTES PATTERN-LENGTH OFFSET)))
	 (font-count (length font-alist)))
    (LOOP FOR (font-name FONT-symbol) IN FONT-alist
	  FOR REPLIES-HINT FROM font-count BY -1
	  do
	  (let* ((FONT-INFO-RECORD (GET FONT-SYMBOL :X11-FONT-INFO))
		 (MIN-BOUNDS (CHAR-INFO-RECORD.METRICS
			       (FONT-INFO-RECORD.MIN-BOUNDS   FONT-INFO-RECORD)))
		 (MAX-BOUNDS (CHAR-INFO-RECORD.METRICS
			       (FONT-INFO-RECORD.MAX-BOUNDS   FONT-INFO-RECORD)))
		 (MIN-CHAR (FONT-INFO-RECORD.FIRST-COL      FONT-INFO-RECORD))
		 (MAX-CHAR (FONT-INFO-RECORD.LAST-COL       FONT-INFO-RECORD))
		 (DEFAULT-CHAR (FONT-INFO-RECORD.CH-DEFAULT     FONT-INFO-RECORD))
		 (DRAW-DIRECTION (FONT-INFO-RECORD.DRAW-DIRECTION FONT-INFO-RECORD))
		 (ALL-EXIST (FONT-INFO-RECORD.ALL-EXIST      FONT-INFO-RECORD))
		 (ASCENT (FONT-INFO-RECORD.FONT-ASCENT    FONT-INFO-RECORD))
		 (DESCENT (FONT-INFO-RECORD.FONT-DESCENT   FONT-INFO-RECORD))
		 (N-PROPS (FONT-INFO-RECORD.N-PROPS        FONT-INFO-RECORD))
		 (PROPERTIES (FONT-INFO-RECORD.PROPERTIES     FONT-INFO-RECORD))
		 (index (SIMPLE-REPLY (STATE)
			  :BYTE REPLY-RESPONSE
			  :BYTE (LENGTH FONT-name)
			  :WORD (STATE.SEQUENCE-ID STATE)
			  :LONG (CEILING (+ 28 (* 8 N-PROPS) (LENGTH FONT-name)) 4)
			  :WORD (X-CHAR-INFO.LEFT-SIDE-BEARING  MIN-BOUNDS)
			  :WORD (X-CHAR-INFO.RIGHT-SIDE-BEARING MIN-BOUNDS)
			  :WORD (X-CHAR-INFO.CHARACTER-WIDTH    MIN-BOUNDS)
			  :WORD (X-CHAR-INFO.ASCENT             MIN-BOUNDS)
			  :WORD (X-CHAR-INFO.DESCENT            MIN-BOUNDS)
			  :WORD (X-CHAR-INFO.ATTRIBUTES         MIN-BOUNDS)
			  :LONG 0		; Unused
			  :WORD (X-CHAR-INFO.LEFT-SIDE-BEARING  MAX-BOUNDS)
			  :WORD (X-CHAR-INFO.RIGHT-SIDE-BEARING MAX-BOUNDS)
			  :WORD (X-CHAR-INFO.CHARACTER-WIDTH    MAX-BOUNDS)
			  :WORD (X-CHAR-INFO.ASCENT             MAX-BOUNDS)
			  :WORD (X-CHAR-INFO.DESCENT            MAX-BOUNDS)
			  :WORD (X-CHAR-INFO.ATTRIBUTES         MAX-BOUNDS)
			  :LONG 0		; Unused
			  :WORD MIN-CHAR	;Min-Char-Or-Byte1
			  :WORD MAX-CHAR	;Max-Char-Or-Byte1
			  :WORD DEFAULT-CHAR
			  :WORD N-PROPS
			  :BYTE DRAW-DIRECTION
			  :BYTE 0		;Min-Byte2
			  :BYTE 0		;Max-Byte2
			  :BYTE (IF ALL-EXIST TRUE FALSE)
			  :WORD ASCENT
			  :WORD DESCENT
			  ;; A count of the number remaining.
			  :LONG (1- REPLIES-HINT))))
	    (LOOP FOR (PROPERTY VALUE) ON PROPERTIES BY #'CDDR 
		  FOR ENCODED-PROPERTY = (get-atom-id PROPERTY t)
		  DO
		  (unless (numberp value)
		    (setq value (get-atom-id (string value) t)))
		  (SETQ INDEX (SIMPLE-REPLY (STATE INDEX)
				   :LONG ENCODED-PROPERTY
				   :LONG VALUE)))
	    (SETQ INDEX (SIMPLE-REPLY (STATE INDEX)
			  :STRING8 FONT-name))
	    (SERVER-STRING-OUT STATE (RESPONSE.BYTES (STATE.RESPONSE STATE)) INDEX)
	    (SERVER-REPLY-PAD INDEX STATE)))
    ;; Send last reply in the series.
    (FORMAT-REPLY (STATE 7)
                  :BYTE 0)
    ;; Each reply of this type has at least 60 bytes of data.  The first
    ;; 32 are send out with format-reply and the remaining are sent here.
    (DOTIMES (INDEX 7)
      (SERVER-STRING-OUT STATE "XXXX" 4))
    (SERVER-PUSH STATE)
    ))

(DEFREQ QUERY-FONT ((FONT-OR-GC FONTABLE))
  (QUERY-FONT STATE FONT-OR-GC))

(defconstant zero-char-info (make-x-char-info
			      :left-Side-Bearing  0
			      :right-Side-Bearing 0
			      :character-Width    0
			      :ascent             0
			      :descent            0
			      :attributes          0))


(DEFUN QUERY-FONT (STATE FONT-RECORD)
  (WHEN (TYPEP FONT-RECORD 'GCONTEXT)
    (SETQ FONT-RECORD (GCONTEXT.FONT FONT-RECORD)))
;;;  (SERVER-TRACE "~%QUERY-FONT1 font=~a" (TYPE-OF FONT-RECORD))
  (LET* ((FONT-INFO-RECORD (FONT-RECORD.FI FONT-RECORD))
         (CHAR-INFOS       (FONT-RECORD.CI FONT-RECORD))
         (MIN-BOUNDS       (CHAR-INFO-RECORD.METRICS
                             (FONT-INFO-RECORD.MIN-BOUNDS   FONT-INFO-RECORD)))
         (MAX-BOUNDS       (CHAR-INFO-RECORD.METRICS
                             (FONT-INFO-RECORD.MAX-BOUNDS   FONT-INFO-RECORD)))
         (MIN-CHAR         (FONT-INFO-RECORD.FIRST-COL      FONT-INFO-RECORD))
         (MAX-CHAR         (FONT-INFO-RECORD.LAST-COL       FONT-INFO-RECORD))
         (DEFAULT-CHAR     (FONT-INFO-RECORD.CH-DEFAULT     FONT-INFO-RECORD))
         (DRAW-DIRECTION   (FONT-INFO-RECORD.DRAW-DIRECTION FONT-INFO-RECORD))
         (ALL-EXIST        (FONT-INFO-RECORD.ALL-EXIST      FONT-INFO-RECORD))
         (ASCENT           (FONT-INFO-RECORD.FONT-ASCENT    FONT-INFO-RECORD))
         (DESCENT          (FONT-INFO-RECORD.FONT-DESCENT   FONT-INFO-RECORD))
         (N-PROPS          (FONT-INFO-RECORD.N-PROPS        FONT-INFO-RECORD))
         (PROPERTIES       (FONT-INFO-RECORD.PROPERTIES     FONT-INFO-RECORD))
         INDEX)
;;;    (SERVER-TRACE
;;;            "~%QUERY-FONT3 font=~a, props=~a, REQUEST-LENGTH=~D, n-CHAR-INFOS=~D"
;;;                     (TYPE-OF font-RECORD) properties
;;;                     (CEILING (+ 28 (* 8 N-PROPS) (* 12 (LENGTH CHAR-INFOS))) 4)
;;;                     (LENGTH CHAR-INFOS))

    (SETQ INDEX (SIMPLE-REPLY (STATE)
                              :BYTE REPLY-RESPONSE
                              :WORD (STATE.SEQUENCE-ID STATE)
                              :LONG (CEILING (+ 28 (* 8 N-PROPS) (* 12 (LENGTH CHAR-INFOS))) 4)
                              :WORD (X-CHAR-INFO.LEFT-SIDE-BEARING  MIN-BOUNDS)
                              :WORD (X-CHAR-INFO.RIGHT-SIDE-BEARING MIN-BOUNDS)
                              :WORD (X-CHAR-INFO.CHARACTER-WIDTH    MIN-BOUNDS)
                              :WORD (X-CHAR-INFO.ASCENT             MIN-BOUNDS)
                              :WORD (X-CHAR-INFO.DESCENT            MIN-BOUNDS)
                              :WORD (X-CHAR-INFO.ATTRIBUTES         MIN-BOUNDS)
                              :LONG 0  ; Unused
                              :WORD (X-CHAR-INFO.LEFT-SIDE-BEARING  MAX-BOUNDS)
                              :WORD (X-CHAR-INFO.RIGHT-SIDE-BEARING MAX-BOUNDS)
                              :WORD (X-CHAR-INFO.CHARACTER-WIDTH    MAX-BOUNDS)
                              :WORD (X-CHAR-INFO.ASCENT             MAX-BOUNDS)
                              :WORD (X-CHAR-INFO.DESCENT            MAX-BOUNDS)
                              :WORD (X-CHAR-INFO.ATTRIBUTES         MAX-BOUNDS)
                              :LONG 0  ; Unused
                              :WORD MIN-CHAR   ;Min-Char-Or-Byte1
                              :WORD MAX-CHAR   ;Max-Char-Or-Byte1
                              :WORD DEFAULT-CHAR
                              :WORD N-PROPS
                              :BYTE DRAW-DIRECTION
                              :BYTE 0  ;Min-Byte1
                              :BYTE 0  ;Max-Byte1
                              :BYTE (IF ALL-EXIST TRUE FALSE)
                              :WORD ASCENT
                              :WORD DESCENT
                              :LONG (LENGTH CHAR-INFOS)))
;;;    (SERVER-TRACE "~%QUERY-FONT3.3 length of properties=~d"
;;;            (length properties))
    ;; Send out the properties
    (LOOP FOR (PROPERTY VALUE) ON PROPERTIES BY #'CDDR 
          FOR ENCODED-PROPERTY = (get-atom-id PROPERTY t)
          DO     (SERVER-TRACE "~%QUERY-FONT4 index=~D" INDEX)
	  (unless (numberp value)
	    (setq value (get-atom-id (string value) t)))
          (SETQ INDEX (SIMPLE-REPLY (STATE INDEX)
                                       :LONG ENCODED-PROPERTY
                                       :LONG VALUE)))
    (SERVER-STRING-OUT STATE (RESPONSE.BYTES (STATE.RESPONSE STATE)) INDEX)
    (SERVER-REPLY-PAD INDEX STATE)
;;;    (SERVER-TRACE "~%QUERY-FONT3.6 after pushing properties.")
    (SETQ INDEX 0)
    ;; Send out the CHAR-INFOs.
    (when char-infos
      (LOOP FOR CHAR-INFO being the array-elements of CHAR-INFOS
	    FOR X-CHAR-INFO = (or (CHAR-INFO-RECORD.METRICS CHAR-INFO)
				  zero-char-info)
	    DO					;(SERVER-TRACE "~%QUERY-FONT5 index=~D" INDEX)
	    (SETQ INDEX (SIMPLE-REPLY (STATE INDEX)
			  :WORD (X-CHAR-INFO.LEFT-SIDE-BEARING  X-CHAR-INFO)
			  :WORD (X-CHAR-INFO.RIGHT-SIDE-BEARING X-CHAR-INFO)
			  :WORD (X-CHAR-INFO.CHARACTER-WIDTH    X-CHAR-INFO)
			  :WORD (X-CHAR-INFO.ASCENT             X-CHAR-INFO)
			  :WORD (X-CHAR-INFO.DESCENT            X-CHAR-INFO)
			  :WORD (X-CHAR-INFO.ATTRIBUTES         X-CHAR-INFO)))))
    (SERVER-STRING-OUT STATE (RESPONSE.BYTES (STATE.RESPONSE STATE)) INDEX)
    (SERVER-REPLY-PAD INDEX STATE)))

(DEFREQ SET-FONT-PATH ((NUMBER-STRINGS CARD16)
		       (:BYTE))
  (SET-FONT-PATH BYTES NUMBER-STRINGS BYTE-OFFSET))

(DEFUN SET-FONT-PATH (STRINGS NUMBER-STRINGS OFFSET)
  ;; If no path is given then this means that we revert to our
  ;; initial search path.
  (LET (PATH-LIST)
    (SETQ PATH-LIST
	  (IF (ZEROP NUMBER-STRINGS)
	      *FONT-INITIAL-SEARCH-PATH*
            ;;1ELSE*
            ;; Construct the path from the individual components.
            (LOOP FOR STRING-COUNTER FROM 0 BELOW NUMBER-STRINGS
                  FOR INDEX FIRST OFFSET THEN (+ INDEX LENGTH 1)
                  FOR LENGTH = (AREF STRINGS INDEX)
		  UNTIL (ZEROP LENGTH)
                  FOR PATHNAME-STRING = (BYTES-TO-STRING STRINGS LENGTH (1+ INDEX))
                  ;1; The problem being addressed here is that we have two kinds of*
                  ;1; pathnames: one kind that may have a host and one kind that may*
                  ;1; not have a host. We pass the client's host for the defaults. That*
                  ;1; way *PARSE-NAMESTRING1 will tack it on if it doesn't already have*
                  ;1; a host, but ignore it if it does.*
                  FOR SIMPLE-PATHNAME = (MERGE-PATHNAMES
					  PATHNAME-STRING
					  (MAKE-PATHNAME :HOST (OR (SEND (STATE.STREAM *STATE*)
									 :SEND-IF-HANDLES :FOREIGN-HOST)
								   SI:LOCAL-HOST)))
                  COLLECT (MAKE-PATHNAME
			    :HOST      (PATHNAME-HOST      SIMPLE-PATHNAME)
			    :DEVICE    (PATHNAME-DEVICE    SIMPLE-PATHNAME)
			    :DIRECTORY (PATHNAME-DIRECTORY SIMPLE-PATHNAME)
			    :TYPE :XLD))))
    (SET-SERVER-FONT-PATHS (REMOVE-DUPLICATES PATH-LIST))
    (SERVER-TRACE "~%New path is:")
    (DOLIST (PATH *FONT-DEFAULT-SEARCH-PATH*)
      (SERVER-TRACE "~%   ~a" PATH))
    ))

(DEFUN SET-SERVER-FONT-PATHS (LIST-OF-PATHNAMES &OPTIONAL MAKE-INITIAL-DEFAULT)
  
  (WHEN (MISMATCH LIST-OF-PATHNAMES *FONT-DEFAULT-SEARCH-PATH* :TEST #'FS:PATHNAME-EQUAL)
    ;; Delete members of the cache that are no longer in the search path
    (SETQ *FONT-DEFAULT-SEARCH-PATH* LIST-OF-PATHNAMES)
    (LOOP
      FOR ITEM IN *FONT-DIRECTORY-CACHE*
      FOR PATH = (CAR ITEM)
      UNLESS (MEMBER PATH *FONT-DEFAULT-SEARCH-PATH* :TEST #'FS:PATHNAME-EQUAL)
      DO
      (SETQ *FONT-DIRECTORY-CACHE* (DELETE ITEM *FONT-DIRECTORY-CACHE*)))
    (WHEN MAKE-INITIAL-DEFAULT
      (SETQ *FONT-INITIAL-SEARCH-PATH* LIST-OF-PATHNAMES))
    *FONT-DEFAULT-SEARCH-PATH*))

(DEFREQ GET-FONT-PATH ()
  (GET-FONT-PATH STATE))

(DEFUN GET-FONT-PATH (STATE)
  (LET* ((PATHNAME-STRINGS (loop for pathname in *FONT-DEFAULT-SEARCH-PATH* collect (string pathname)))
         (STRING-LENGTHS (LOOP FOR STRING IN PATHNAME-STRINGS
                               SUMMING (1+ (LENGTH STRING)))))
    (FORMAT-REPLY (STATE (CEILING STRING-LENGTHS 4))
                  :WORD (LENGTH PATHNAME-STRINGS))
    (LOOP FOR STRING IN PATHNAME-STRINGS
          FOR LENGTH = (LENGTH STRING)
          DO (PROGN
               (SERVER-STRING-OUT STATE (vector LENGTH) 1)
               (SERVER-STRING-OUT STATE STRING LENGTH)))
    (SERVER-REPLY-PAD STRING-LENGTHS STATE)))

;;; Implementation note.  The query text extents request is a bit different
;;; from the others in that the length of the request determines the size of
;;; one of its arguments.  Rather than complicate the already complex defreq
;;; macro, the real code is present here.  Note that requests like LIST-FONTS
;;; have their length specified as a separate field.  I don't see why this one
;;; needs to be different.  I suspect that this is really a protocol design
;;; error.
(DEFUN QUERY-TEXT-EXTENTS-REQUEST (STATE BYTE-OFFSET LENGTH)
  (LET* ((BYTES       (STATE.BYTES STATE))
         (LONG-OFFSET (TRUNCATE BYTE-OFFSET 4))
         (LONGS       (STATE.LONGS STATE))
         (WORD-OFFSET (TRUNCATE BYTE-OFFSET 2))
         (WORDS       (STATE.WORDS STATE))
         (ODD-LENGTH  (AREF BYTES (+ BYTE-OFFSET 1)))
         (FGC         (AREF LONGS (+ LONG-OFFSET 1))))
    (SETQ FGC (GETHASH FGC *RESOURCES*))
    (COND ((OR (NULL FGC) (NOT (LOGTEST (RESOURCE.TYPE FGC)
                                        (+ GCONTEXT-RESOURCE-TYPE FONT-RESOURCE-TYPE))))
           (BAD-FONT (AREF LONGS (+ LONG-OFFSET 1))))
          (T
           ;; Note that the LENGTH argument is the length of the request in bytes.
           (LET ((STRING16-LENGTH (- (TRUNCATE (- LENGTH 8) 2)
                                     (IF (= ODD-LENGTH TRUE) 1 0))))
	     (DOTIMES (INDEX STRING16-LENGTH)
	       (ROTATEF (AREF BYTES (+ BYTE-OFFSET INDEX INDEX 8))
			(AREF BYTES (+ BYTE-OFFSET INDEX INDEX 9))))
             (QUERY-TEXT-EXTENTS STATE WORDS STRING16-LENGTH
                                 (+ 4 WORD-OFFSET) FGC))))))

(SETF (AREF *LITTLE-ENDIAN-TABLE* QUERY-TEXT-EXTENTS-OPCODE) #'QUERY-TEXT-EXTENTS-REQUEST)

(DEFUN SWAPPED-QUERY-TEXT-EXTENTS-REQUEST (STATE OFFSET LENGTH)
  (LET ((BYTES (STATE.BYTES STATE)))
    (DECLARE (SYS:ARRAY-REGISTER BYTES))
    ;; Swap the bytes of the font ID.
    (ROTATEF (AREF BYTES (+ OFFSET 4)) (AREF BYTES (+ OFFSET 7)))
    (ROTATEF (AREF BYTES (+ OFFSET 5)) (AREF BYTES (+ OFFSET 6)))
    (QUERY-TEXT-EXTENTS-REQUEST STATE OFFSET LENGTH)))

(SETF (AREF *BIG-ENDIAN-TABLE* QUERY-TEXT-EXTENTS-OPCODE) #'SWAPPED-QUERY-TEXT-EXTENTS-REQUEST)

;;;(defreq Query-Text-Extents ((nchars CARD8)
;;;			    (fgc FONTABLE)
;;;                            (:BYTE))
;;;           ;; Note that the LENGTH argument is the length of the request in bytes.
;;;           (LET ((STRING16-LENGTH (- (TRUNCATE (- LENGTH 8) 2)
;;;                                     (IF (= ODD-LENGTH TRUE) 1 0))))
;;;             (WHEN SWAP-P
;;;               (DOTIMES (INDEX STRING16-LENGTH)
;;;                 (ROTATEF (AREF BYTES (+ BYTE-OFFSET INDEX INDEX 8))
;;;                          (AREF BYTES (+ BYTE-OFFSET INDEX INDEX 9)))))
;;;             (QUERY-TEXT-EXTENTS STATE WORDS STRING16-LENGTH
;;;                                 (+ 4 WORD-OFFSET) FGC)))

;;; Implementation note: much of the following code was taken from clx;text.lisp and modified
;;; appropriately.

(DEFUN QUERY-TEXT-EXTENTS (STATE SEQUENCE SEQUENCE-LENGTH SEQUENCE-OFFSET FONT)
  (LET* ((FONT-INFO-REC (FONT-RECORD.FI FONT))
         (FONT-ASCENT (THE INT16 (FONT-INFO-RECORD.FONT-ASCENT    FONT-INFO-REC)))
         (FONT-DESCENT (THE INT16 (FONT-INFO-RECORD.FONT-DESCENT   FONT-INFO-REC)))
         (FONT-DIRECTION (FONT-INFO-RECORD.DRAW-DIRECTION FONT-INFO-REC)))
    (MULTIPLE-VALUE-bind (Width Ascent Descent Left-bearing Right-bearing)
	(TEXT-EXTENTS-LOCAL FONT SEQUENCE SEQUENCE-OFFSET (+ SEQUENCE-OFFSET SEQUENCE-LENGTH))
      (format-reply (state)
		    :BYTE FONT-DIRECTION
		    :WORD FONT-ASCENT
		    :WORD FONT-DESCENT
		    :WORD ASCENT
		    :WORD DESCENT
		    :LONG WIDTH
		    :LONG LEFT-BEARING
		    :LONG RIGHT-BEARING
		    :LONG 0			; Unused
		    ))))
                        
(DEFUN TEXT-EXTENTS-LOCAL (FONT SEQUENCE START END)
  (DECLARE (TYPE FONT FONT)
	   (TYPE SEQUENCE SEQUENCE)
	   (TYPE INTEGER START END))
  (DECLARE (VALUES WIDTH ASCENT DESCENT OVERALL-LEFT OVERALL-RIGHT))
  (LET* ((CHAR-INFOS (FONT-RECORD.CI FONT))
	 (FONT-INFO  (FONT-RECORD.FI FONT)))
    (DECLARE (TYPE VECTOR CHAR-INFOS)
	     (TYPE FONT-INFO-RECORD FONT-INFO))
    (IF (plusp (font-info-record.constant-metrics font-info))
	;; Fixed width font.
	(LET* ((METRICS (CHAR-INFO-RECORD.METRICS (FONT-INFO-RECORD.MAX-BOUNDS FONT-INFO)))
               (FONT-WIDTH   (X-CHAR-INFO.CHARACTER-WIDTH METRICS))
	       (FONT-ASCENT  (X-CHAR-INFO.ASCENT METRICS))
	       (FONT-DESCENT (X-CHAR-INFO.DESCENT METRICS))
	       (WIDTH (* (- END START) FONT-WIDTH)))
	  (DECLARE (TYPE INT16 FONT-WIDTH FONT-ASCENT FONT-DESCENT)
		   (TYPE INT32 WIDTH))
          (VALUES WIDTH
                  FONT-ASCENT
                  FONT-DESCENT
                  (X-CHAR-INFO.LEFT-SIDE-BEARING METRICS)
                  (+ WIDTH (- FONT-WIDTH) (X-CHAR-INFO.RIGHT-SIDE-BEARING METRICS))))
      ;;ELSE
      ;; Variable-width font
      (LET* ((FIRST-COL (FONT-INFO-RECORD.FIRST-COL FONT-INFO))
             (NUM-COLS (1+ (- (FONT-INFO-RECORD.LAST-COL FONT-INFO) FIRST-COL)))
             (FIRST-ROW (FONT-INFO-RECORD.FIRST-ROW FONT-INFO))
             (LAST-ROW (FONT-INFO-RECORD.LAST-ROW FONT-INFO))
             (NUM-ROWS (1+ (- LAST-ROW FIRST-ROW))))
        (DECLARE (TYPE CARD8 FIRST-COL FIRST-ROW LAST-ROW)
                 (TYPE CARD16 NUM-COLS NUM-ROWS))
        (IF (OR (PLUSP FIRST-ROW) (PLUSP LAST-ROW))
              
            ;; Matrix (16 bit) font
            (MACROLET ((CHAR-INFO-ELT (SEQUENCE ELT)
                         `(LET* ((CHAR (THE CARD16 (AREF ,SEQUENCE ,ELT)))
                                 (ROW (- (ASH CHAR -8) FIRST-ROW))
                                 (COL (- (LOGAND CHAR #xFF) FIRST-COL)))
                            (DECLARE (TYPE CARD16 CHAR)
                                     (TYPE INT16 ROW COL))
                            (if (AND (< -1 ROW NUM-ROWS) (< -1 COL NUM-COLS))
				(+ (* ROW NUM-COLS) COL)
			      -1))))
              ;; Extents.
              (DO ((I START (1+ I))
                   (WIDTH 0)
                   (ASCENT 0)
                   (DESCENT 0)
                   (LEFT #x7FFF)
                   (RIGHT 0))
                  ((>= I END)
                   (VALUES WIDTH ASCENT DESCENT LEFT RIGHT))
                (DECLARE (TYPE INT16 I)
                         (TYPE INT16 ASCENT DESCENT)
                         (TYPE INT32 WIDTH LEFT RIGHT))
		(let ((n (char-info-elt sequence i))
		      char-info)
		  (declare (type fixnum n))
		  (when (and (not (minusp n)) ;; Ignore characters not in the font
			     (setq CHAR-INFO (CHAR-INFO-RECORD.METRICS (AREF CHAR-INFOS N))))
		    (SETQ LEFT    (MIN LEFT  (+ WIDTH (X-CHAR-INFO.LEFT-SIDE-BEARING  CHAR-INFO)))
			  RIGHT   (MAX RIGHT (+ WIDTH (X-CHAR-INFO.RIGHT-SIDE-BEARING CHAR-INFO))))
		    (INCF WIDTH                       (X-CHAR-INFO.CHARACTER-WIDTH    CHAR-INFO))
		    (SETQ ASCENT  (MAX ASCENT         (X-CHAR-INFO.ASCENT             CHAR-INFO))
			  DESCENT (MAX DESCENT        (X-CHAR-INFO.DESCENT            CHAR-INFO)))))))
          ;;1ELSE*
          ;; Non-matrix (8 bit) font.
          ;; The code here is identical to the above, except for the following macro:
          (MACROLET ((CHAR-INFO-ELT (SEQUENCE ELT)
                       `(LET ((COL (- (THE CARD16 (AREF ,SEQUENCE ,ELT)) FIRST-COL)))
                          (DECLARE (TYPE INT16 COL))
                          (if (< -1 COL NUM-COLS)
			      COL
			    -1))))
            ;; Extents.
            (DO ((I START (1+ I))
                 (WIDTH 0)
                 (ASCENT 0)
                 (DESCENT 0)
                 (LEFT #x7FFF)
                 (RIGHT 0))
                ((>= I END)
                 (VALUES WIDTH ASCENT DESCENT LEFT RIGHT))
              (DECLARE (TYPE INT16 I)
                       (TYPE INT16 ASCENT DESCENT)
                       (TYPE INT32 WIDTH LEFT RIGHT))
	      (let ((n (char-info-elt sequence i))
		    char-info)
		(declare (type fixnum n))
		(when (and (not (minusp n)) ;; Ignore characters not in the font
			   (setq CHAR-INFO (CHAR-INFO-RECORD.METRICS (AREF CHAR-INFOS N))))
		    (SETQ LEFT    (MIN LEFT  (+ WIDTH (X-CHAR-INFO.LEFT-SIDE-BEARING  CHAR-INFO)))
			  RIGHT   (MAX RIGHT (+ WIDTH (X-CHAR-INFO.RIGHT-SIDE-BEARING CHAR-INFO))))
		    (INCF WIDTH                       (X-CHAR-INFO.CHARACTER-WIDTH    CHAR-INFO))
		    (SETQ ASCENT  (MAX ASCENT         (X-CHAR-INFO.ASCENT             CHAR-INFO))
			  DESCENT (MAX DESCENT        (X-CHAR-INFO.DESCENT            CHAR-INFO))))))))))))

(DEFCONSTANT FONT-SHIFT-INDICATOR 255.)

(defreq Poly-Text8 ((:graphics)
		    (drawable DRAWABLE)
		    (gc GCONTEXT)
		    (x INT16)
		    (y INT16)
		    (:byte))
  (poly-text8 gc drawable x y length bytes byte-offset))
 

(DEFPARAMETER CHARACTER-TEMP-ARRAY-WIDTH  300)
(DEFPARAMETER CHARACTER-TEMP-ARRAY-HEIGHT 300)
(DEFPARAMETER CHARACTER-TEMP-ARRAY
              (CREATE-PIXMAP-ARRAY CHARACTER-TEMP-ARRAY-WIDTH CHARACTER-TEMP-ARRAY-HEIGHT 1))

(defun poly-text8 (gcontext drawable x y length bytes byte-offset)
;;  (SERVER-TRACE "~%In poly-text8 CLIP-MASK=~A" (GCONTEXT.CLIP-MASK GCONTEXT))
;;;  (SERVER-TRACE "~%In poly-text8 at (~D,~D), data len=~D" x y length)
  (with-drawable (drawable gcontext :clipping-rectangle t
			   :boxer
			   (#'(lambda (box x y gc)
				(setf (box.top box) (- y (tv:font-baseline
							   (font-record.device-private
							     (gcontext.font gc))))
				      (box.bottom box)  (+ y (font-info-record.font-descent
							       (font-record.fi (gcontext.font gc))))
				      (box.left box) x))
			    x y gcontext))
		 (destination-array current-x current-y alu simple-clipping-rectangle)
    (incf current-x x)
    (incf current-y y)
    (setq alu (aref poly-text-gc-mapping-table alu))
    (let* ((font (gcontext.font gcontext))
           char-infos 
           font-info-record
           first-col
           last-col
	   chars-exist-table
           font-device
           default-char
           (last-byte-offset (+ byte-offset length -2))
           delta-x
           string-length
           char
           x-char-info
           char-info-record
	   baseline
           left-side-bearing
           character-width
           ascent
           character-height
	   (clip-right (box.right simple-clipping-rectangle)))
      (macrolet ((update-font (font)
			      `(setq char-infos       (font-record.ci ,font)
				     font-info-record (font-record.fi ,font)
				     font-device      (font-record.device-private ,font)
				     baseline	      (tv:font-baseline font-device)
				     chars-exist-table (w:font-chars-exist-table font-device)
				     first-col        (font-info-record.first-col   font-info-record)
				     last-col         (font-info-record.last-col    font-info-record)
				     char-info-record (font-info-record.max-bounds  font-info-record)
				     default-char     (font-info-record.ch-default  font-info-record))))
        (update-font font)
	(loop
	  (when (>= byte-offset last-byte-offset)
	    (return nil))
	  (if (= (aref bytes byte-offset) font-shift-indicator)
	      ;; We have a new font.
	      (let* ((font-id (+ (ash (+ (ash (+ (ash (AREF BYTES (+ BYTE-OFFSET 1)) 8)
						 (AREF BYTES (+ BYTE-OFFSET 2))) 8)
					 (AREF BYTES (+ BYTE-OFFSET 3))) 8)
				 (AREF BYTES (+ BYTE-OFFSET 4))))
		     (new-font (gethash font-id *resources*)))
		(incf byte-offset 5)
		(if (or (null new-font)
			(not (is-font-p new-font)))
		    (bad-font font-id)
		  ;;1ELSE*
		  (progn
		    (update-font new-font)
		    (setf (gcontext.font gcontext) new-font))))
	    ;;1ELSE*
	    ;; We have a delta with a string.
	    (progn
	      (setq string-length (aref bytes byte-offset)
		    delta-x       (aref bytes (incf byte-offset)))
	      ;; Skip over to the string itself.
	      (incf byte-offset)
	      (incf current-x delta-x)
	      (when *monochrome-server-trace-enabled*
		(server-trace "  Alu ~d ~s" alu (bytes-to-string bytes string-length byte-offset)))
              ;1;Check for out of range or clipped characters first*
              ;1;so draw-string doesn't get bad values.*
              (DO ((index byte-offset (1+ index))
                   (end (+ byte-offset string-length)))
                  ((>= index end))
		(setq char (aref bytes index))
		(when (or (< char first-col)
			  (> char last-col)
			  (zerop (aref chars-exist-table char)))
		  ;1; This character is out of range.  Substitute the default.*
		  (SETF (AREF bytes index) default-char)))
	      (do ((index byte-offset (1+ index))
		   (end (+ byte-offset string-length))
		   new-index)
		  ((or (>= index end)		;1; Exit when past right edge*
		       (> current-x clip-right))	;1; We could check for clipping other edges,*
		   (setq byte-offset end))		;1; But that doesn't happen very often...*
		(setq char (aref bytes index))
;		;; 1A character is out of range, or clipped.*
;		(setq char (aref bytes index))
;		(when (or (< char first-col)
;			  (> char last-col)
;			  (zerop (aref chars-exist-table char)))
;		  ;1; This character is out of range.  Substitute the default.*
;		  (setq char default-char))
		(when char-infos
		  (setq char-info-record (aref CHAR-INFOS (- CHAR FIRST-COL))))
		(setq x-char-info (char-info-record.metrics char-info-record)
		      left-side-bearing (x-char-info.left-side-bearing x-char-info))
		(incf current-x left-side-bearing)
		
		(unless (eql index new-index)	;if true, draw-string already failed once.  go use draw char
		  ;1; Try %draw-string first*
		  (multiple-value-setq (current-x new-index)
		    (draw-string destination-array bytes index end
				 current-x current-y font-device alu))
		  (unless new-index		;1 *if nil, draw-string got it all
		    (return (setq byte-offset end))))
		(if (> new-index index)
		    ;; draw-string handled some of the characters but then gave up.
		    ;; must restart loop at the new index and let draw-char take over.
		    (setq index (1- new-index))
		  ;; ELSE - everything is set up to use draw char
		  (setq character-width   (x-char-info.character-width   x-char-info)
			ascent            (x-char-info.ascent            x-char-info)
			character-height  (+ ascent (x-char-info.descent x-char-info)))		    
		  ;1; What we do for each character is to write it to a temporary*
		  ;1; bit array and then copy it to the to appropriate place on*
		  ;1; the window.*
		  (w:with-clipping-rectangle (0 0 CHARACTER-TEMP-ARRAY-WIDTH CHARACTER-TEMP-ARRAY-height)
		    (draw-char font-device char 0 baseline gx-copy character-temp-array))
		  (copy-array-clipped (- character-width left-side-bearing) character-height
				      simple-clipping-rectangle
				      character-temp-array 0 (- baseline ASCENT)
				      destination-array
				      current-x (- current-y ascent) alu)
		  (incf current-x (- character-width left-side-bearing))))
	      )))))))



(defreq Image-Text8 ((:graphics)
		     (nchars CARD8)
		     (drawable DRAWABLE)
		     (gc GCONTEXT)
		     (x INT16)
		     (y INT16)
		     (:byte nchars))
  (image-text8 gc drawable x y nchars bytes byte-offset))


(DEFUN IMAGE-TEXT8 (GCONTEXT DRAWABLE X Y SEQUENCE-LENGTH SEQUENCE SEQUENCE-OFFSET)
  (WHEN (HAVE-DRAWING-TO-DO DRAWABLE GCONTEXT)
    (LET ((OLD-ALU        (GCONTEXT.ALU        GCONTEXT))
          (OLD-FILL-STYLE (GCONTEXT.FILL-STYLE GCONTEXT))
          (FONT (GCONTEXT.FONT GCONTEXT)))
      (SETF (GCONTEXT.ALU        GCONTEXT)  GX-COPY)
      (SETF (GCONTEXT.FILL-STYLE GCONTEXT) FILL-STYLE-SOLID)
      ;; Create rectangle defined by the bounding box for the text.
      ;; Calculate text extents locally.
      (LET* ((FONT-INFO-REC (FONT-RECORD.FI FONT))
	     (FONT-ASCENT (THE INT16 (FONT-INFO-RECORD.FONT-ASCENT    FONT-INFO-REC)))
	     (FONT-DESCENT (THE INT16 (FONT-INFO-RECORD.FONT-DESCENT   FONT-INFO-REC)))
	     (WIDTH (TEXT-EXTENTS-LOCAL FONT SEQUENCE SEQUENCE-OFFSET (+ SEQUENCE-OFFSET SEQUENCE-LENGTH))))
	(FILL-RECTANGLE DRAWABLE GCONTEXT X (- Y font-Ascent) Width (+ font-Ascent font-Descent)
			(GCONTEXT.BACKGROUND-PIXEL GCONTEXT)))
      ;; Fake out a call to poly-text8 by inserting the length and delta into the
      ;; buffer at the proper places.  Pass in bounding box to clear.
      (SETF (AREF SEQUENCE (- SEQUENCE-OFFSET 1)) 0)
      (SETF (AREF SEQUENCE (- SEQUENCE-OFFSET 2)) SEQUENCE-LENGTH)
      (POLY-TEXT8 GCONTEXT DRAWABLE X Y (+ SEQUENCE-LENGTH 2) SEQUENCE (- SEQUENCE-OFFSET 2))
      (SETF (GCONTEXT.ALU        GCONTEXT) OLD-ALU)
      (SETF (GCONTEXT.FILL-STYLE GCONTEXT) OLD-FILL-STYLE))))


(defreq Poly-Text16 ((:graphics)
		     (drawable DRAWABLE)
		     (gc GCONTEXT)
		     (x INT16)
		     (y INT16)
		     (:byte))
  (poly-text16 gc drawable x y length bytes byte-offset))

(DEFUN POLY-TEXT16 (GCONTEXT DRAWABLE X Y LENGTH BYTES BYTE-OFFSET)
  (with-drawable (drawable gcontext :clipping-rectangle nil
			   :boxer
			   (#'(lambda (box x y gc)
				(setf (box.top box) (- y (tv:font-baseline
							    (font-record.device-private
							      (gcontext.font gc))))
				      (box.bottom box)  (+ y (font-info-record.font-descent
							       (font-record.fi (gcontext.font gc))))
				      (box.left box) x))
			    x y gcontext))
		 (destination-array current-x current-y x-alu simple-clipping-rectangle)
    (server-trace-words bytes byte-offset length)
    (incf current-x x)
    (incf current-y y)
    (LET* (ASCENT
           CHAR
           CHAR-BYTE1
           CHAR-BYTE2
           CHAR-INFO-RECORD
           CHAR-INFOS
           CHARACTER-HEIGHT
           CHARACTER-WIDTH
           DEFAULT-CHAR
           DELTA-X
           FIRST-COL
           FIRST-ROW
	   chars-exist-table
           (FONT (GCONTEXT.FONT GCONTEXT))
           FONT-DEVICE
           FONT-INFO-RECORD
	   baseline
           (last-byte-offset (+ byte-offset length -2))
           LAST-COL
           LAST-ROW
           LEFT-SIDE-BEARING
           LINEAR-FONT-P
           NUM-COLS
           NUM-ROWS
           STRING-LENGTH
           X-CHAR-INFO)
      (macrolet ((UPDATE-FONT (FONT)
			      `(SETQ CHAR-INFOS       (FONT-RECORD.CI ,FONT)
				     FONT-INFO-RECORD (FONT-RECORD.FI ,FONT)
				     FONT-DEVICE      (FONT-RECORD.DEVICE-PRIVATE ,FONT)
				     chars-exist-table (w:font-chars-exist-table font-device)
				     baseline	      (tv:font-baseline font-device)
				     FIRST-COL        (FONT-INFO-RECORD.FIRST-COL   FONT-INFO-RECORD)
				     LAST-COL         (FONT-INFO-RECORD.LAST-COL    FONT-INFO-RECORD)
				     NUM-COLS         (1+ (- LAST-COL FIRST-COL))
				     FIRST-ROW        (FONT-INFO-RECORD.FIRST-ROW   FONT-INFO-RECORD)
				     LAST-ROW         (FONT-INFO-RECORD.LAST-ROW    FONT-INFO-RECORD)
				     NUM-ROWS         (1+ (- LAST-ROW FIRST-ROW))
				     LINEAR-FONT-P    (FONT-INFO-RECORD.LINEAR      FONT-INFO-RECORD)
				     char-info-record (font-info-record.max-bounds  font-info-record)
				     DEFAULT-CHAR     (FONT-INFO-RECORD.CH-DEFAULT  FONT-INFO-RECORD))))
        (UPDATE-FONT FONT)
	(LOOP
	  (WHEN (>= BYTE-OFFSET LAST-BYTE-OFFSET)
	    (RETURN NIL))
	  (IF (= (AREF BYTES BYTE-OFFSET) FONT-SHIFT-INDICATOR)
	      ;; We have a new font.
	      (let* ((FONT-ID (+ (ash (+ (ash (+ (ash (AREF BYTES (+ BYTE-OFFSET 1)) 8)
						 (AREF BYTES (+ BYTE-OFFSET 2))) 8)
					 (AREF BYTES (+ BYTE-OFFSET 3))) 8)
				 (AREF BYTES (+ BYTE-OFFSET 4))))
		     (NEW-FONT (GETHASH FONT-ID *RESOURCES*)))
		(INCF BYTE-OFFSET 5)
		(IF (OR (NULL NEW-FONT)
			(NOT (IS-FONT-P NEW-FONT)))
		    (BAD-FONT FONT-ID)
		  ;;1ELSE*
		  (PROGN
		    (UPDATE-FONT NEW-FONT)
		    (SETF (GCONTEXT.FONT GCONTEXT) NEW-FONT))))
	    ;;1ELSE*
	    ;; We have a delta with a string.
	    (PROGN
	      (SETQ STRING-LENGTH (AREF BYTES BYTE-OFFSET)
		    DELTA-X       (AREF BYTES (1+ BYTE-OFFSET)))
	      ;; Skip over to the string itself.
	      (INCF BYTE-OFFSET 2)
	      (INCF CURRENT-X DELTA-X)
	      ;; What we do for each character is to write it to a temporary
	      ;; bit array and then copy it to the to appropriate place on
	      ;; the window.
	      (server-trace "  String: ")
	      (DOTIMES (INDEX STRING-LENGTH)
		;; Get the two bytes that refer to a font glyph.
		(SETQ CHAR-BYTE1 (AREF BYTES BYTE-OFFSET)
		      CHAR-BYTE2 (AREF BYTES (1+ BYTE-OFFSET)))
		(IF LINEAR-FONT-P
		    ;; The font is linear so we need to combine these two bytes
		    ;; to form a single font glyph index.
		    (PROGN
		      (SETQ CHAR (+ (* CHAR-BYTE1 256) CHAR-BYTE2))
		      (WHEN (OR (< CHAR FIRST-COL)
				(> CHAR LAST-COL))
			;; This character is out of range.  Substitute the default.
			(SETQ CHAR DEFAULT-CHAR)))
		  ;;1ELSE* This is a 2-byte font reference.
		  ;; Scale the bytes to be relative to a 0 origin.
		  (SETQ CHAR-BYTE1 (- CHAR-BYTE1 FIRST-ROW)
			CHAR-BYTE2 (- CHAR-BYTE2 FIRST-COL))
		  ;; If the bytes are in range then compute the index into char-infos
		  ;; otherwise use the default character.
		  (SETQ CHAR (IF (AND (< -1 CHAR-BYTE1 NUM-ROWS) (< -1 CHAR-BYTE2 NUM-COLS))
				 (+ (* CHAR-BYTE1 NUM-COLS) CHAR-BYTE2)
			       DEFAULT-CHAR)))
		(server-trace "~a" (int-char char))
		(WHEN (zerop (aref chars-exist-table char))
		  ;; This character doesn't exist.  Substitute the default.
		  (SETQ CHAR DEFAULT-CHAR))
		(when char-infos
		  (SETQ CHAR-INFO-RECORD (aref CHAR-INFOS (- CHAR FIRST-COL))))
		(SETQ X-CHAR-INFO (CHAR-INFO-RECORD.METRICS CHAR-INFO-RECORD)
		      LEFT-SIDE-BEARING (X-CHAR-INFO.LEFT-SIDE-BEARING X-CHAR-INFO)
		      CHARACTER-WIDTH   (X-CHAR-INFO.CHARACTER-WIDTH   X-CHAR-INFO)
		      ASCENT            (X-CHAR-INFO.ASCENT            X-CHAR-INFO)
		      CHARACTER-HEIGHT  (+ ASCENT (X-CHAR-INFO.DESCENT X-CHAR-INFO)))
		#+comment ;1; No clear needed, because DRAW-CHAR replaces the temp-array contents*
		(CLEAR-TEMP-ARRAY CHARACTER-TEMP-ARRAY)
		(draw-char font-device char 0 baseline gx-copy character-temp-array)
		(COPY-ARRAY-CLIPPED (- CHARACTER-WIDTH LEFT-SIDE-BEARING) CHARACTER-HEIGHT
				    SIMPLE-CLIPPING-RECTANGLE
				    CHARACTER-TEMP-ARRAY 0 (- baseline ASCENT)
				    DESTINATION-ARRAY (+ CURRENT-X LEFT-SIDE-BEARING) (- CURRENT-Y ASCENT)
				    (AREF POLY-TEXT-GC-MAPPING-TABLE X-ALU))
		(INCF CURRENT-X (- CHARACTER-WIDTH LEFT-SIDE-BEARING))
		(INCF BYTE-OFFSET 2)))))))))

(defreq Image-Text16 ((:graphics)
		      (nchars CARD8)
		      (drawable DRAWABLE)
		      (gc GCONTEXT)
		      (x INT16)
		      (y INT16)
		      (:byte nchars 2))
  (image-text16 gc drawable x y (+ nchars nchars) bytes byte-offset words (+ word-offset 8)))

(DEFUN IMAGE-TEXT16 (GCONTEXT DRAWABLE X Y BYTE-LENGTH BYTES BYTE-OFFSET WORDS WORD-OFFSET)
  (WHEN (HAVE-DRAWING-TO-DO DRAWABLE GCONTEXT)
    (LET ((OLD-ALU        (GCONTEXT.ALU        GCONTEXT))
          (OLD-FILL-STYLE (GCONTEXT.FILL-STYLE GCONTEXT))
          (FONT (GCONTEXT.FONT GCONTEXT)))
      (SETF (GCONTEXT.ALU        GCONTEXT) GX-COPY)
      (SETF (GCONTEXT.FILL-STYLE GCONTEXT) FILL-STYLE-SOLID)
      ;; Clear out the rectangle defined by the bounding box for the text.
      ;; Calculate text extents locally.
      (LET ((STRING16-LENGTH (TRUNCATE BYTE-LENGTH 2)))
	(DOTIMES (INDEX STRING16-LENGTH)
	  (ROTATEF (AREF BYTES (+ BYTE-OFFSET INDEX INDEX))
		   (AREF BYTES (+ BYTE-OFFSET INDEX INDEX 1))))
	(LET* ((FONT-INFO-REC (FONT-RECORD.FI FONT))
	       (FONT-ASCENT (THE INT16 (FONT-INFO-RECORD.FONT-ASCENT    FONT-INFO-REC)))
	       (FONT-DESCENT (THE INT16 (FONT-INFO-RECORD.FONT-DESCENT   FONT-INFO-REC)))
	       (WIDTH (TEXT-EXTENTS-LOCAL FONT WORDS WORD-OFFSET (+ WORD-OFFSET STRING16-LENGTH))))
	  ;1; I know rotating twice is slow, but I don't want to write two versions of *TEXT-EXTENTS-LOCAL
	  (DOTIMES (INDEX STRING16-LENGTH)
	    (ROTATEF (AREF BYTES (+ BYTE-OFFSET INDEX INDEX))
		     (AREF BYTES (+ BYTE-OFFSET INDEX INDEX 1))))
	  (FILL-RECTANGLE DRAWABLE GCONTEXT X (- Y font-Ascent) Width (+ font-Ascent font-Descent)
			  (GCONTEXT.BACKGROUND-PIXEL GCONTEXT)))
	;; Fake out a call to poly-text16 by inserting the length and delta into the
	;; buffer at the proper places.  Pass in bounding box to clear.
	(SETF (AREF BYTES (- BYTE-OFFSET 1)) 0)
	(SETF (AREF BYTES (- BYTE-OFFSET 2)) STRING16-LENGTH)
	(POLY-TEXT16 GCONTEXT DRAWABLE X Y (+ BYTE-LENGTH 2) BYTES (- BYTE-OFFSET 2))
	(SETF (GCONTEXT.ALU        GCONTEXT) OLD-ALU)
	(SETF (GCONTEXT.FILL-STYLE GCONTEXT) OLD-FILL-STYLE)))))


;;; The following is a very simple pattern matcher intended for
;;; fonts.  The meta characters in the pattern are `*' and `?'.
;;; The `*' will match any number of characters and the `?' will
;;; match any single character.  This is similar to matching used
;;; for files.

;;; Much of this code was described in chapter 5 of Kernighan and
;;; Plauger's `Software Tools' book.  Refer to that book for more
;;; details on the algorithm.  The primary difference between
;;; these two matchers is with the meta-character *.  In the
;;; Software Tools book, the * character matches zero or more
;;; occurrances of the character (or subpattern) which preceeds
;;; the *.  For X11, the * character matches zero or more
;;; occurrances of any character.

;;; Match zero or more characters.
(DEFCONSTANT MATCH-MANY #\*)
;;; Match a single character.
(DEFCONSTANT MATCH-ONE  #\?)

(defun pattern-match-p (string pattern)
  (a-match string pattern 0 0))

(defun a-match (string pattern string-offset pattern-offset)
  "2Match a PATTERN with a STRING starting at INDEX.
Returns NIL if no match could be made, otherwise non-NIL.*"
  (declare (fixnum string-offset pattern-offset)
           (simple-string string pattern))
;1;*  (pv 'enter string-offset pattern-offset
;1;*      'string (subseq string string-offset) 'pattern (subseq pattern pattern-offset))
  (do ((string-length (length string))
       (pattern-length (length pattern))
       (offset string-offset (1+ offset));1;* below string-length
       (pattern-index pattern-offset (1+ pattern-index)))
      ((or (>= offset string-length)
	   (>= pattern-index pattern-length))
;1;*       (pv 'exit string-offset pattern-offset string-length offset pattern-index
;1;*	   'string (subseq string string-offset) 'pattern (subseq pattern pattern-offset))
       (and (= offset string-length)
	    (= pattern-index pattern-length)))
    (let ((pattern-char (aref pattern pattern-index)))
      (cond ((eql pattern-char match-many)
	     ;; Since the * character matches anything, we will recursively
	     ;; call a-match starting with the end of the string and working
	     ;; backwards until we have a match with the remainder of our
	     ;; pattern.
	     (incf pattern-index)		; Point to the remainder of the pattern.
	     (return
	       (if (= pattern-index pattern-length)
		   t ;1; * at end matches anything*
		 (loop for i from offset below string-length
		       do (when (a-match string pattern i pattern-index)
			    (return t))))))
	    ((eql pattern-char match-one)) ;1; always matches*
	    ((char-equal pattern-char (aref string offset)))
	    (t ;1; else, match failed*
	     (return nil))))))