🚀 go-pugleaf

>>  * Has anyone got the code for the documented(!)
>>  function X11:COMPILE-X11-FONT (appendix B of "SLE X
>>  Window System Programmer's Reference"), which is said
>>  to make a font usable by X11M out of a BDF file.  The
>>  stuff in jwz's archive just makes a screen font,
>>  without the necessary X11 font info.

A quick grep revealed that this function is in
x11:x11m.utilities;font-compiler.lisp




Rice;

;-------------------------------------------------------------------------------

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

#|

This program allows one to read in characters from X11 font files and convert
them to Explorer font objects.  The font files are located in the directory
tilde:/lagoon.u1/X11-beta.1/fonts/bdf/.  This program reads the font
information in a manner similar to the fc program in
tilde:/lagoon.u1/X11-beta.1/fonts/compiler/fc.c.

To run the program, call the function read-font, and pass a pathname for the
font file.  The read-font function returns the symbol whose value is the font
object.  These symbols are prefixed with `X11-' to distinguish them from
Explorer fonts which may have the same name.

|#

;;; Change history:
;;;
;;;  Date      Author	Description
;;; -------------------------------------------------------------------------------------
;;; 12/06/88    LGO	Ensure font name is all caps.
;;; 11/14/88    LGO	Get font height and baseline from ascent and descent when FontBoundingBox is bad.
;;; 11/09/88    LGO	Get font height and baseline from the FontBoundingBox.
;;;			These font attributes cannot be derived from ascent and descent.
;;; 11/08/88    LGO	Correctly skip characters with negative encoding
;;; 11/08/88    LGO	Correctly left-justify font bitmaps
;;; 11/08/88    LGO	Gather font properties correctly.
;;; 11/08/88    LGO	Adjust FED:FD-SPACE-WIDTH and FED:FD-BLINKER-WIDTH for fixed width fonts
;;; 10/27/88    TWE	Changed the inner data collection loop index start-row to never
;;;			start below the index of 0.
;;;  9/14/88	LGO	Use Y-RESOLUTION instead of explorer pixel-resolution
;;;			when computing character sizes.
;;;  9/13/88	LGO	Fix READ-A-LINE to work on unix files
;;;  9/13/88	LGO	Add compile-x11-font function which dumps x11-font-info
;;;			in the same file as the font.
;;;  9/13/88	LGO	Set char-width to x-width instead of bounding-box-width
;;;  9/13/88	LGO	Pad the top of char bitmaps to make the baselines line up.

;;; The prefix for font pathnames and font objects is the same.
(DEFCONSTANT X-FONT-OBJECT-PREFIX "X11-")

(DEFCONSTANT GOLDEN-RATIO (/ (1+ (SQRT 5)) 2))

(DEFCONSTANT MAX-ENCODING (EXPT 2 16)
  "Largest number of characters in a font that can be supported")

(DEFCONSTANT VERSION-STRING "STARTFONT 2.1")

(DEFCONSTANT X-FONT-OBJECT-PREFIX "X11-")

(DEFPARAMETER LINE-NUMBER 0
   "Number of the line read from a font file.  Used for error reporting.")

;;; Simpler version of the read-from-string function, which more easily handles
;;; keywords.  This version is less general than the read-from-string function,
;;; but sufices here.
(DEFUN READ-FROM-STRING-FIX (STRING &KEY (START 0))
  (READ-FROM-STRING STRING T NIL :START START))
                        
;;; The following defparameters are located here instead of being inside of a LET in read-font
;;; because release 2.1 doesn't allow one to put a large number of locals inside of a function.

;;; Data line read from the font file.
(DEFPARAMETER LINE NIL)

;;; Determines the name of the font.  This may be a filename, which means
;;; that the font name needs to be extracted.
(DEFPARAMETER FAMILY NIL)

;;; Resolution of the font in the X direction.
(DEFPARAMETER X-RESOLUTION NIL)

;;; Resolution of the font in the Y direction.
(DEFPARAMETER Y-RESOLUTION NIL)

;;; Symbol which is the font's name.  Has the X11- prefix.
(DEFPARAMETER FONT-SYMBOL NIL)

;;; The number of glyphs in this font.
(DEFPARAMETER NUMBER-CHARACTERS NIL)

;;; The lowest character in the font.
(DEFPARAMETER LOWEST-ENCODING  MOST-POSITIVE-FIXNUM)

;;; The highest character in the font.
(DEFPARAMETER LARGEST-ENCODING  0)

;;; The next 4 deal with 2-D fonts.
(DEFPARAMETER FI.FIRST-ROW      MOST-POSITIVE-FIXNUM)
(DEFPARAMETER FI.LAST-ROW       0)
(DEFPARAMETER FI.CH-FIRST       MOST-POSITIVE-FIXNUM)
(DEFPARAMETER FI.CH-LAST        0)

(DEFPARAMETER REAL-PROPERTY-COUNTER 0
  "Number of properties for this font.")

(DEFPARAMETER PROPERTIES NIL)

;;; Total font height
(defparameter font-height	nil)

;;; Font baseline
(defparameter font-baseline	nil)
(defparameter font-y		nil)

;;; Maximum length of ascenders for the font.
(DEFPARAMETER FONT-ASCENT       NIL)

;;; Maximum length of descenders for the font.
(DEFPARAMETER FONT-DESCENT      NIL)

;;; Maximums and minimums for components of x-char-info.
(DEFPARAMETER MAX-LEFT-SIDE-BEARING  NIL)
(DEFPARAMETER MAX-RIGHT-SIDE-BEARING NIL)
(DEFPARAMETER MAX-CHARACTER-WIDTH    NIL)
(DEFPARAMETER MAX-FONT-ASCENT        NIL)
(DEFPARAMETER MAX-FONT-DESCENT       NIL)
(DEFPARAMETER MIN-LEFT-SIDE-BEARING  NIL)
(DEFPARAMETER MIN-RIGHT-SIDE-BEARING NIL)
(DEFPARAMETER MIN-CHARACTER-WIDTH    NIL)
(DEFPARAMETER MIN-FONT-ASCENT        NIL)
(DEFPARAMETER MIN-FONT-DESCENT       NIL)

;;; Default character property for the font.
(DEFPARAMETER DEFAULT-CHARACTER NIL)

(DEFPARAMETER ALL-CHARS-EXIST NIL)

(DEFPARAMETER CONSTANT-METRICS NIL)

;;; Point size for the font.
(DEFPARAMETER POINT-SIZE        NIL)

;;; Family name property of the font.  Not used for anything yet.
(DEFPARAMETER FAMILY-NAME       NIL)

;;; Resolution property of the font.  I'm not sure how this differs from
;;; the values of x-resolution and y-resolution, which are supposed to
;;; have the same value (i.e. X resolution = Y resolution).
(DEFPARAMETER RESOLUTION        NIL)

;;; Height of the font.
(DEFPARAMETER X-HEIGHT          NIL)

;;; Weight property of the font.
(DEFPARAMETER WEIGHT            NIL)

;;; Quad width property of the font.
(DEFPARAMETER QUAD-WIDTH        NIL)

;;; The FED font descriptor
(defparameter font-desc		nil)

(DEFUN READ-FONT (PATHNAME &AUX (x11-metrics (make-array 256)))
  "Read an X11 bdf font file and generate Explorer font object.
PATHNAME is the pathname where the .bdf information exists.
X11 font descriptor informations is put on the :X11-FONT-INFO
 roperty of the font name symbol."
  (WITH-OPEN-FILE (FONT-STREAM PATHNAME :DIRECTION :INPUT)
    (SETQ ALL-CHARS-EXIST  T
	  X-HEIGHT	   NIL
	  FONT-HEIGHT	   NIL
	  FONT-ASCENT      NIL
	  FONT-DESCENT     NIL
	  LARGEST-ENCODING 0;;; Maximum length of ascenders for the font.
	  LINE-NUMBER      0
	  LOWEST-ENCODING  MOST-POSITIVE-FIXNUM
	  MAX-CHARACTER-WIDTH    0
	  MAX-FONT-ASCENT        0
	  MAX-FONT-DESCENT       0
	  MAX-LEFT-SIDE-BEARING  0
	  MAX-RIGHT-SIDE-BEARING 0
	  MIN-CHARACTER-WIDTH    MOST-POSITIVE-FIXNUM
	  MIN-FONT-ASCENT        MOST-POSITIVE-FIXNUM
	  MIN-FONT-DESCENT       MOST-POSITIVE-FIXNUM
	  MIN-LEFT-SIDE-BEARING  MOST-POSITIVE-FIXNUM
	  MIN-RIGHT-SIDE-BEARING MOST-POSITIVE-FIXNUM
	  PROPERTIES             NIL)
    ;; The validate-string function compares the first few characters of LINE
    ;; to those characters in STRING.  If they are not the same (case doesn't count)
    ;; then an error message is generated.
    (FLET ((VALIDATE-STRING (STRING &OPTIONAL MESSAGE)
			    (IF (NOT (STRING-EQUAL (SETQ LINE (READ-A-LINE FONT-STREAM))
						   STRING
						   :end1 (LENGTH STRING)))
				(FERROR NIL "Missing font ~A on line ~D, got ~A instead."
					(OR MESSAGE (STRING-TRIM " " STRING))
					LINE-NUMBER LINE)
			      ;;ELSE
			      (nsubstring LINE (LENGTH STRING)))))
      ;; Parse the header stuff for the font.
      (VALIDATE-STRING VERSION-STRING "file, or incorrect version")
      (SETQ FAMILY (VALIDATE-STRING "FONT " "family line"))
      ;; Form a font name from the family string.  The family can be one of
      ;; several things: a simple string, a simple filename with an
      ;; extension, or a fully specified pathname with an optional extension.
      ;; It is assumed that the characters of the filename component of a
      ;; pathname contain only alphabetic, numeric, - or _ characters.
      (SETQ FONT-SYMBOL (INTERN
			  (CONCATENATE
			    'SIMPLE-STRING "X11-"
			    ;; make the font name the same as the file name.  This
			    ;; makes it much easier to deal with fonts, since
			    ;; X uses the file system to locate fonts.
			    (string-upcase (PATHNAME-NAME FONT-STREAM)))
			  'FONTS))
      ;; Read in the point size, x resolution and y resolution.
      (LET ((RESOLUTIONS-STRING (VALIDATE-STRING "SIZE " "size line")))
	(MULTIPLE-VALUE-BIND (VALUE X-RESOLUTION-POSITION)
	    (READ-FROM-STRING-FIX RESOLUTIONS-STRING)
	  (SETQ POINT-SIZE VALUE)
	  (MULTIPLE-VALUE-BIND (VALUE Y-RESOLUTION-POSITION)
	      (READ-FROM-STRING-FIX RESOLUTIONS-STRING :START X-RESOLUTION-POSITION)
	    (SETQ X-RESOLUTION VALUE
		  Y-RESOLUTION (READ-FROM-STRING-FIX RESOLUTIONS-STRING
						     :START Y-RESOLUTION-POSITION))))
	(WHEN (NOT (= X-RESOLUTION Y-RESOLUTION))
	  (FERROR NIL "X and Y resolution must be equal, but are ~D and ~D"
		  X-RESOLUTION Y-RESOLUTION)))
      
      (let ((BOUNDING-BOX-STRING (VALIDATE-STRING "FONTBOUNDINGBOX ")))
	(MULTIPLE-VALUE-BIND (VALUE HEIGHT-POSITION)
	    (READ-FROM-STRING BOUNDING-BOX-STRING)
	  value ;; Ignore font bounding-box width
	  (MULTIPLE-VALUE-BIND (VALUE LEFT-POSITION)
	      (READ-FROM-STRING-FIX BOUNDING-BOX-STRING :START HEIGHT-POSITION)
	    (SETQ font-height VALUE)
	    (MULTIPLE-VALUE-BIND (VALUE BOTTOM-POSITION)
		(READ-FROM-STRING-FIX BOUNDING-BOX-STRING :START LEFT-POSITION)
	      value ;; Ignore font bounding-box X
	      (SETQ value (READ-FROM-STRING-FIX
			    BOUNDING-BOX-STRING
			    :START BOTTOM-POSITION))
	      (setq font-y (- value))))))

      (SETQ REAL-PROPERTY-COUNTER 0)
      ;; Read in the properties of the font.
      (LOOP WITH NUMBER-OF-PROPERTIES = (READ-FROM-STRING (VALIDATE-STRING "STARTPROPERTIES "
									   "properties"))
	    FOR PROPERTY-COUNTER FROM 1 BY 1
	    WHILE (>= NUMBER-OF-PROPERTIES PROPERTY-COUNTER)
	    FOR LINE = (READ-A-LINE FONT-STREAM)
	    DO (MULTIPLE-VALUE-BIND (NAME VALUE-INDEX)
		   (let ((*package* *keyword-package*))
		     (READ-FROM-STRING LINE))
		 (LET ((VALUE (READ-FROM-STRING-FIX LINE :START VALUE-INDEX)))
		   (unless (numberp value)
		     (setq value (intern (string value) 'keyword)))
		   (case name ;; These properties are used, and DON'T go on the property list
		     (:font_ascent  (setq font-ascent value))
		     (:font_descent (setq font-descent value))
		     (:default_char (setq default-character value))
		     (otherwise
		      (setq properties (list* name value properties))
		      (incf real-property-counter)
		      (case name ;; These properties are used and DO go on the property list
			(:point_size   (setq point-size value))
			#+comment ;; what is this property anyway??? - LGO
			(:x_height     (setq x-height value))))))))
      (VALIDATE-STRING "ENDPROPERTIES" "terminator for font properties")
      (WHEN (OR (NULL FONT-ASCENT) (NULL FONT-DESCENT))
	(FERROR NIL "Must have FONT_ASCENT and FONT_DESCENT properties"))

      ;; We shouldn't have to do this, but some fonts have incorrect fontboundingbox
      ;; specifications (probably because bdftosnf donesn't use it)
      (setq font-height (max font-height (+ font-ascent font-descent))
	    font-baseline (- font-height (max font-y font-descent)))
      
      (SETQ NUMBER-CHARACTERS (READ-FROM-STRING (VALIDATE-STRING "CHARS " "character count")))
      (unless x-height
	(setq x-height
	      (if (and font-ascent font-descent)
		  (+ font-ascent font-descent)
		(ROUND (*
			 POINT-SIZE
			 ;; Convert points to inches
			 (/ 1 72.27)
			 ;; Convert inches to pixels
			 Y-RESOLUTION)))))
      (unless FONT-ASCENT
	(setq font-ascent
	      (if font-descent
		  (- font-height font-descent)
		   ;; Assume that the ascender covers about 80% of a character.
		(* FONT-HEIGHT 0.8))))
      (setq font-desc 
	    (FED:MAKE-FONT-DESCRIPTOR
	      :MAKE-ARRAY (:LENGTH (MAX NUMBER-CHARACTERS 256.))
	      FED:FD-FILL-POINTER (MAX NUMBER-CHARACTERS 256.)
	      FED:FD-NAME FONT-SYMBOL
	      FED:FD-SPACE-WIDTH (ROUND (*
					  ;; Convert height to width
					  (/ POINT-SIZE GOLDEN-RATIO)
					  ;; Convert points to inches
					  (/ 1 72.27)
					  ;; Convert inches to pixels
					  Y-RESOLUTION))
	      FED:FD-LINE-SPACING (+ FONT-ASCENT FONT-DESCENT)
	      FED:FD-BASELINE FONT-BASELINE
	      FED:FD-BLINKER-WIDTH (ROUND (*
					    ;; Convert height to width
					    (/ POINT-SIZE GOLDEN-RATIO)
					    ;; Convert points to inches
					    (/ 1 72.27)
					    ;; Convert inches to pixels
					    Y-RESOLUTION))
	      FED:FD-BLINKER-HEIGHT FONT-HEIGHT))
      ;; Loop through each character in this font.
      (LOOP WITH BOUNDING-BOX-WIDTH  = NIL
	    WITH BOUNDING-BOX-HEIGHT = NIL
	    WITH BOUNDING-BOX-LEFT   = NIL
	    WITH BOUNDING-BOX-BOTTOM = NIL
	    FOR CHARACTER-COUNTER FROM 0 BELOW NUMBER-CHARACTERS
	    ;;                                                    1234567890
	    WHILE (string= (SETQ LINE (READ-A-LINE FONT-STREAM)) "STARTCHAR " :end1 10)
	    FOR CHARACTER-NAME = (SUBSEQ LINE 10)
	    FOR LAST-ENCODING = NIL THEN ENCODING
	    FOR ENCODING = (LET ((ENCODING (VALIDATE-STRING "encoding ")))
			     (MULTIPLE-VALUE-BIND (VALUE END-POSITION)
				 (READ-FROM-STRING ENCODING)
			       (WHEN (AND (NOT (= END-POSITION (LENGTH ENCODING)))
					  (= VALUE -1))
				 ;; We have two values.  Get the second one since the
				 ;; first one looks kind of trashy (I don't know what
				 ;; the real meaning is behind the -1 value).
				 (SETQ VALUE (READ-FROM-STRING-FIX ENCODING
								   :START END-POSITION)))
			       (WHEN (= VALUE -1)
				 #+comment
				 (FORMAT T "~%Character ~A with encoding = -1 ignored at line ~D"
					 CHARACTER-NAME LINE-NUMBER)
				 (LOOP FOR LINE = (READ-A-LINE FONT-STREAM)
				       UNTIL (EQUAL LINE "ENDCHAR")))
			       (WHEN (> VALUE MAX-ENCODING)
				 (FERROR NIL "Character `~A' has encoding(=~D) ~
                                                   which is too large"
					 CHARACTER-NAME VALUE))
			       (SETQ LARGEST-ENCODING (MAX VALUE LARGEST-ENCODING))
			       VALUE))
	    unless (minusp encoding) do
	    ;; The following three things are unused, but are calculated in
	    ;; the C program, so we do this here in case we need them later.
	    (let* ((CHARACTER-ROW (LOGAND (ASH ENCODING -8) #xFF))
		   (CHARACTER-COLUMN (LET ((COLUMN (LOGAND ENCODING #xFF)))
				       (SETQ FI.FIRST-ROW (MIN FI.FIRST-ROW CHARACTER-ROW)
					     FI.LAST-ROW  (MAX FI.LAST-ROW  CHARACTER-ROW)
					     FI.CH-FIRST  (MIN FI.CH-FIRST  COLUMN)
					     FI.CH-LAST   (MAX FI.CH-LAST   COLUMN))
				       COLUMN))
		   (SWIDTH (VALIDATE-STRING "SWIDTH "))
		   ;; X component of width
		   (X-WIDTH (READ-FROM-STRING (VALIDATE-STRING "DWIDTH ")))
		   (BOUNDING-BOX-STRING (VALIDATE-STRING "BBX" "bounding box"))
		   (ATTRIBUTES 0))
	      swidth character-column ;; not used
	      ;; Decode the components of the bounding box.
	      (MULTIPLE-VALUE-BIND (VALUE HEIGHT-POSITION)
		  (READ-FROM-STRING BOUNDING-BOX-STRING)
		(SETQ BOUNDING-BOX-WIDTH VALUE)
		(MULTIPLE-VALUE-BIND (VALUE LEFT-POSITION)
		    (READ-FROM-STRING-FIX BOUNDING-BOX-STRING :START HEIGHT-POSITION)
		  (SETQ BOUNDING-BOX-HEIGHT VALUE)
		  (MULTIPLE-VALUE-BIND (VALUE BOTTOM-POSITION)
		      (READ-FROM-STRING-FIX BOUNDING-BOX-STRING :START LEFT-POSITION)
		    (SETQ BOUNDING-BOX-LEFT VALUE
			  BOUNDING-BOX-BOTTOM (READ-FROM-STRING-FIX
						BOUNDING-BOX-STRING
						:START BOTTOM-POSITION)))))
	      (WHEN (OR (ZEROP BOUNDING-BOX-WIDTH) (ZEROP BOUNDING-BOX-HEIGHT))
		;; The character has zero size.  Make sure that the left and
		;; bottom dimensions don't affect the minimum/maximum
		;; calculations.
		(SETQ BOUNDING-BOX-WIDTH  0
		      BOUNDING-BOX-HEIGHT 0
		      BOUNDING-BOX-LEFT   MIN-LEFT-SIDE-BEARING
		      BOUNDING-BOX-BOTTOM (- MIN-FONT-DESCENT)))
	      (SETQ LINE (READ-A-LINE FONT-STREAM))
	      ;;                                      12345678901
	      (WHEN (STRING-EQUAL (SUBSEQ LINE 0 11) "ATTRIBUTES ")
		;; The attributes line is optional.
		(SETQ ATTRIBUTES (READ-FROM-STRING-FIX
				   (CONCATENATE 'SIMPLE-STRING "#\x" LINE)
				   :START 11))
		(SETQ LINE (READ-A-LINE FONT-STREAM)))
	      (SETQ LOWEST-ENCODING (MIN LOWEST-ENCODING ENCODING))
	      ;; Write information out regarding this character.
	      (setf (aref x11-metrics encoding)
		    (X11:MAKE-X-CHAR-INFO
		      :LEFT-SIDE-BEARING BOUNDING-BOX-LEFT
		      :RIGHT-SIDE-BEARING (+ BOUNDING-BOX-LEFT BOUNDING-BOX-WIDTH)
		      :CHARACTER-WIDTH X-WIDTH
		      :ASCENT (+ BOUNDING-BOX-HEIGHT BOUNDING-BOX-BOTTOM)
		      :DESCENT (- BOUNDING-BOX-BOTTOM)
		      :ATTRIBUTES ATTRIBUTES))
	      (SETQ MAX-LEFT-SIDE-BEARING  (MAX MAX-LEFT-SIDE-BEARING BOUNDING-BOX-LEFT)
		    MAX-RIGHT-SIDE-BEARING (MAX MAX-RIGHT-SIDE-BEARING
						(+ BOUNDING-BOX-LEFT BOUNDING-BOX-WIDTH))
		    MAX-CHARACTER-WIDTH    (MAX MAX-CHARACTER-WIDTH X-WIDTH)
		    MAX-FONT-ASCENT        (MAX MAX-FONT-ASCENT
						(+ BOUNDING-BOX-HEIGHT BOUNDING-BOX-BOTTOM))
		    MAX-FONT-DESCENT       (MAX MAX-FONT-DESCENT (- BOUNDING-BOX-BOTTOM))
		    MIN-LEFT-SIDE-BEARING  (MIN MIN-LEFT-SIDE-BEARING BOUNDING-BOX-LEFT)
		    MIN-RIGHT-SIDE-BEARING (MIN MIN-RIGHT-SIDE-BEARING
						(+ BOUNDING-BOX-LEFT BOUNDING-BOX-WIDTH))
		    MIN-CHARACTER-WIDTH    (MIN MIN-CHARACTER-WIDTH X-WIDTH)
		    MIN-FONT-ASCENT        (MIN MIN-FONT-ASCENT
						(+ BOUNDING-BOX-HEIGHT BOUNDING-BOX-BOTTOM))
		    MIN-FONT-DESCENT       (MIN MIN-FONT-DESCENT (- BOUNDING-BOX-BOTTOM)))
	      
	      ;; Can't use validate-string here because the attributes line
	      ;; is optional.
	      (WHEN (NOT (STRING-EQUAL LINE "BITMAP"))
		(FERROR NIL "Missing font bitmap on line ~D, got ~A instead."
			LINE LINE-NUMBER))
	      ;; Loop collecting each row of the character.
	      (LOOP with start-row = (- font-baseline (+ BOUNDING-BOX-HEIGHT BOUNDING-BOX-BOTTOM))
		    #+comment
		    (min (max (- font-ascent (+ BOUNDING-BOX-HEIGHT BOUNDING-BOX-BOTTOM))
					       0)
					  (1- font-height))	; These min/maxes are a kludge... do better someday
		    WITH CHAR-DESC = (FED:MAKE-CHAR-DESCRIPTOR
				       :MAKE-ARRAY (:element-type 'BIT
								  :LENGTH (LIST font-height
										BOUNDING-BOX-WIDTH))
				       FED:CD-CHAR-WIDTH X-WIDTH
				       FED:CD-CHAR-LEFT-KERN 0)
		    FOR ROW FROM start-row ;;(+ start-row fudge)
		    FOR RAW-DATA = (READ-A-LINE FONT-STREAM)
		    WHILE (NOT (EQUAL RAW-DATA "ENDCHAR"))
		    ;; Loop through all of the bits of this row.
		    ;; The data comes in left justified, so we need
		    ;; to shift it to make it right justified.
		    DO (LOOP with DATA = (parse-integer raw-data :radix 16.)
			     WITH SHIFTED-DATA = (ASH DATA
						      (- BOUNDING-BOX-WIDTH
							 (* 4 (LENGTH RAW-DATA))))
			     FOR COLUMN FROM (1- BOUNDING-BOX-WIDTH) DOWNTO 0
			     DO (PROGN
				  (SETF (AREF CHAR-DESC ROW COLUMN) (LOGAND SHIFTED-DATA 1))
				  (SETQ SHIFTED-DATA (ASH SHIFTED-DATA -1))))
		    FINALLY (SETF (AREF FONT-DESC ENCODING) CHAR-DESC))))
      (progn ;; WHEN OUTPUT-PATHNAME
	(SETQ CONSTANT-METRICS
	      (AND (= MIN-LEFT-SIDE-BEARING MAX-LEFT-SIDE-BEARING)
		       (= MIN-RIGHT-SIDE-BEARING MAX-RIGHT-SIDE-BEARING)
		       (= MIN-CHARACTER-WIDTH MAX-CHARACTER-WIDTH)
		       (= MIN-FONT-ASCENT MAX-FONT-ASCENT)
		       (= MIN-FONT-DESCENT MAX-FONT-DESCENT)))
	
	;; Ensure correct space and blinker width for constant-metric fonts
	(when constant-metrics
	  (setf (FED:FD-SPACE-WIDTH font-desc) max-character-width
		(FED:FD-BLINKER-WIDTH font-desc) max-character-width))

	;; Adjust the size of the font to only have those characters it defines.
	(SETF (FILL-POINTER FONT-DESC) (1+ LARGEST-ENCODING))
	(ADJUST-ARRAY FONT-DESC   (1+ LARGEST-ENCODING))
	(FED:FONT-NAME-SET-FONT-AND-DESCRIPTOR
	  FONT-SYMBOL
	  FONT-DESC)

	;; Canonicalize metrics vector
	(unless constant-metrics
	  (loop with metrics = (make-array (1+ (- largest-encoding lowest-encoding)))
		for i from lowest-encoding to largest-encoding
		for j upfrom 0
		do (setf (aref metrics j) (aref x11-metrics i))
		finally (setq x11-metrics metrics)))

	;; Calculate all-chars-exists
	(setq all-chars-exist t)
	(dotimes (i (1+ (- largest-encoding lowest-encoding)))
	  (unless (aref x11-metrics i)
	    (return (setq all-chars-exist nil))))

	;; Setup the font-info-record
	(setf (get font-symbol :x11-font-info)
	      (X11:MAKE-FONT-INFO-RECORD
		:VERSION VERSION-STRING
		:ALL-EXIST ALL-CHARS-EXIST
		:DRAW-DIRECTION X11:LEFT-TO-RIGHT-FONT
		:NO-OVERLAP 0			; HUH?
		:CONSTANT-METRICS (if constant-metrics 1 0)
		:TERMINAL-FONT (IF (AND CONSTANT-METRICS
					(ZEROP MAX-LEFT-SIDE-BEARING))
				   1 0)
		:LINEAR T
		:FIRST-COL LOWEST-ENCODING
		:LAST-COL  LARGEST-ENCODING
		:FIRST-ROW 0
		:LAST-ROW 0
		:N-PROPS REAL-PROPERTY-COUNTER
		:PROPERTIES PROPERTIES
		:LEN-STRINGS 0			; WHAT IS THIS?
		;; Try a bunch of default characters, starting with `?' and ending with
		;; the first character in the font.
		:CH-DEFAULT (LOOP FOR CHAR IN `(#\? #\! #\@ #\# #\$ #\% #\& ,LOWEST-ENCODING)
				  WHEN (PLUSP (AREF (W:FONT-CHARS-EXIST-TABLE
						      (symbol-value FONT-SYMBOL))
						    (CHAR-INT CHAR)))
				  RETURN (CHAR-INT CHAR))
		:FONT-DESCENT FONT-DESCENT
		:FONT-ASCENT  FONT-ASCENT
		:MIN-BOUNDS (X11:MAKE-X-CHAR-INFO
			      :LEFT-SIDE-BEARING  MIN-LEFT-SIDE-BEARING
			      :RIGHT-SIDE-BEARING MIN-RIGHT-SIDE-BEARING
			      :CHARACTER-WIDTH MIN-CHARACTER-WIDTH
			      :ASCENT  MIN-FONT-ASCENT
			      :DESCENT MIN-FONT-DESCENT
			      :ATTRIBUTES 0)
		:MAX-BOUNDS (X11:MAKE-X-CHAR-INFO
			      :LEFT-SIDE-BEARING  MAX-LEFT-SIDE-BEARING
			      :RIGHT-SIDE-BEARING MAX-RIGHT-SIDE-BEARING
			      :CHARACTER-WIDTH MAX-CHARACTER-WIDTH
			      :ASCENT  MAX-FONT-ASCENT
			      :DESCENT MAX-FONT-DESCENT
			      :ATTRIBUTES 0)
		:PIX-DEPTH 1
		:GLYPH-SETS NUMBER-CHARACTERS
		:VERSION2 VERSION-STRING
		;; Metrics NIL when constant
		:metrics (and (not constant-metrics) x11-metrics))))))
  FONT-SYMBOL)

(DEFUN READ-A-LINE (STREAM)
  "Reads a line from a font file."
  ;; Loop through each line read, skipping over special case lines.
  (LOOP FOR STRING = (MAKE-ARRAY 20 :ELEMENT-TYPE :STRING-CHAR :FILL-POINTER 0)
	with char do
	;; Skip newline and formfeed
	(loop while (or (CHAR= (setq char (read-char stream))
			       '#.(INT-CHAR (LOGAND (CHAR-INT #\NEWLINE) #O177)))
			(CHAR= CHAR #\NEWLINE)
			(char= char #\linefeed)))
	;; Read into string until a newline or formfeed
	(LOOP DO (VECTOR-PUSH-EXTEND CHAR STRING)
	         (setq CHAR (READ-CHAR STREAM))
		 UNTIL (or (CHAR= CHAR '#.(INT-CHAR (LOGAND (CHAR-INT #\NEWLINE) #O177)))
			   (CHAR= CHAR #\NEWLINE)
			   (char= char #\linefeed)))
        ;; Skip over comment, empty and dot lines.
        WHILE (OR (STRING-EQUAL (SUBSEQ STRING 0 7) "COMMENT")  ; For apl-s25 font
                  (ZEROP (LENGTH STRING))       ; For cartoon font in crturz.bdf
                  (STRING-EQUAL STRING (STRING #\CENTER-DOT)))  ; For cursor font
        FINALLY (RETURN STRING)))

(defun compile-x11-font (bdf-pathname &optional (xld-pathname ""))
  (let ((font-symbol (read-font bdf-pathname)))
    (setq bdf-pathname (parse-namestring bdf-pathname))
    (compiler:DUMP-FORMS-TO-FILE
      (merge-pathnames (string-downcase
			 (CONCATENATE 'SIMPLE-STRING X-FONT-OBJECT-PREFIX
				      (PATHNAME-NAME bdf-pathname)
				      "." (string (si::local-binary-file-type))))
		       xld-pathname)
      ;; Take font-symbol from the file name, to allow aliasing
      `((setq ,font-symbol ',(symbol-value font-symbol))
	(setf (get ',font-symbol :x11-font-info) ',(get font-symbol :x11-font-info))
	(let ((symbol (and si:fdefine-file-pathname
			   (intern (string-upcase (pathname-name si:fdefine-file-pathname)) 'fonts))))
	  (when symbol
	    (setf (symbol-value symbol) ,font-symbol)
	    (setf (get symbol :x11-font-info) (get ',font-symbol :x11-font-info)))))
      `(:FONT-SYMBOL ,FONT-SYMBOL :PACKAGE :USER))))

(defun update-all-x-fonts (from to)
  (let ((files (directory (make-pathname :defaults from :type "BDF" :name :wild))))
    (dolist (file files)
      (format t "~%~a " (pathname-name file))
      ;; Skip 16b fonts (not handled yet)
      (unless (member (pathname-name file) '("K14")
		      :test #'string-equal)
	(princ
	  (compile-x11-font file to))))))

#|
(update-all-x-fonts "stroke:/u1/XV11R3/fonts/bdf/" "tan:/u1/oren/fonts/")
;; Andrew fonts
(let ((fudge -1)) ;; The .bdf files in this directory are incorrect, so compensate
  (update-all-x-fonts "tan:/u1/oren/andyfont/" "tan:/u1/oren/fonts/"))
(update-all-x-fonts "tan:/u1/oren/andysrc/" "tan:/u1/oren/fonts/")

(update-all-x-fonts "stroke:/u1/XV11R3/fonts/bdf/75dpi/" "tan:/u1/oren/fonts/")
(update-all-x-fonts "stroke:/u1/XV11R3/fonts/bdf/misc/" "tan:/u1/oren/fonts/")

|#

#|
(update-all-x-fonts "x11m:fonts.100dpi;" "x11m:fonts.100dpi;")
(update-all-x-fonts "x11m:fonts.75dpi;" "x11m:fonts.75dpi;")
(update-all-x-fonts "x11m:fonts.misc;" "x11m:fonts.misc;")
(update-all-x-fonts "x11m:fonts.rel2;" "x11m:fonts.rel2;")
|#