source: trunk/lisp/lmio1/fntcnv.lisp @ 253

Last change on this file since 253 was 253, checked in by rjs, 3 years ago

Update.

File size: 37.4 KB
Line 
1;;;-*-Mode:LISP; Package:FED-*-
2
3;The functions in this file
4;are used to convert between the various formats for fonts as used on the LISP
5;Machine.  There are currently three formats supported:
6;       KST format is used for communication with the PDP-10.
7;       FD (or Font Descriptor) Format is used as a machine resident format
8;               which is easily manipulated.  The format consists of a 200
9;               element array with a leader.  The elements of this array are
10;               themselves two dimensional arrays which contain the actual
11;               pixel values for the character.
12;       FONT (or internal) Format is the format actually used by the tv display
13;               routines.  The format is fairly complicated and its direct
14;               use is not recommended when a conversion to FD format would
15;               be better.
16;       AL format is used for ALTO fonts.
17
18;First some helping functions:
19
20;Maximum raster width of an FD format font
21(DEFUN MAX-RASTER-WIDTH (FONT-DESCRIPTOR &AUX (GUESS 0) TEMP)
22       (DO ((CHAR-CODE 0 (1+ CHAR-CODE)))
23           (( CHAR-CODE 200) GUESS)
24           (COND ((SETQ TEMP (AR-1 FONT-DESCRIPTOR CHAR-CODE))
25                  (SETQ GUESS (MAX GUESS (ARRAY-DIMENSION-N 2 TEMP)))))))
26
27;Maximum raster height of an FD format font
28(DEFUN MAX-RASTER-HEIGHT (FONT-DESCRIPTOR &AUX (GUESS 0) TEMP)
29       (DO ((CHAR-CODE 0 (1+ CHAR-CODE)))
30           (( CHAR-CODE 200) GUESS)
31           (COND ((SETQ TEMP (AR-1 FONT-DESCRIPTOR CHAR-CODE))
32                  (SETQ GUESS (MAX GUESS (ARRAY-DIMENSION-N 1 TEMP)))))))
33
34;;; Memoizing version of FONT-INTO-FONT-DESCRIPTOR
35;;; that wants a font name (symbol in FONTS:) rather than the font itself.
36;;; The FONT-DESCRIPTOR property of the symbol holds the descriptor.
37;;; The FONT-DESCRIBED property holds the font itself which the descriptor matches.
38;;; If anyone changes the font, we can see that the old descriptor is no good.
39(defun font-name-font-descriptor (fontname &aux fd)
40    (setq fd (get fontname 'font-descriptor))
41    (cond ((and fd (eq (get fontname 'font-described) (symeval fontname))))
42          (t (setq fd (font-into-font-descriptor (symeval fontname)))
43             (putprop fontname (symeval fontname) 'font-described)
44             (putprop fontname fd 'font-descriptor)))
45    fd)
46
47;;; Set a font given a font descriptor.  Keep the descriptor around.
48;;; Forward the old definition of the font to the new one.
49(defun font-name-set-font-and-descriptor (fontname font-descriptor)
50    (let ((oldfont (and (boundp fontname) (symeval fontname))))
51      (set fontname (font-descriptor-into-font font-descriptor))
52      (and oldfont (structure-forward oldfont (symeval fontname)))
53      (putprop fontname font-descriptor 'font-descriptor)
54      (putprop fontname (symeval fontname) 'font-described)
55      font-descriptor))
56
57;Store a character in a font.  Given a font and corresponding FD, both are
58;updated by storing a given CD for a given character code.
59;If the CD can be stored into the existing font, that is done.
60;Otherwise, a new font is made from the updated FD and the old font forwarded to it.
61(defun font-name-store-cd (fontname cd char-code &aux font)
62    (let ((width (array-dimension-n 2 cd))
63          (height (array-dimension-n 1 cd))
64          tem fd)
65      (setq fd (font-name-font-descriptor fontname))
66      (as-1 cd fd char-code)
67      (and (= char-code #/ )
68           (setf (fd-space-width fd) (cd-char-width cd)))
69      (cond ((or (not (boundp fontname))
70                 (null (setq font (symeval fontname)))
71                 (> width
72                    (cond ((setq tem (font-indexing-table font))
73                           (* (font-raster-width font)
74                              (- (ar-1 tem (1+ char-code))
75                                 (ar-1 tem char-code))))
76                          (t (font-raster-width font))))
77                 (> height (font-raster-height font)))
78             (font-name-set-font-and-descriptor fontname fd))
79            (t (store-cd-in-font cd font char-code nil)))))
80
81;Functions for referring to specified pixels of characters in an internal format font.
82
83;ROW and COL are measured from top/left as usual.  An alternative would be:
84;       COL is measured from the left, with Kerning hacked.
85;       ROW is positive above the baseline and negative below.
86;  (SETQ ROW (- (FONT-BASELINE FONT) ROW))
87;  (AND (SETQ TEM (FONT-LEFT-KERN-TABLE FONT))
88;       (SETQ COL (+ COL (AR-1 TEM CHAR))))
89;However it looks like this would cause more trouble than it would save.
90;Attempts to reference outside of the raster return 0, or barf if storing.
91;Conceivably it might be good to not barf at attempts to store 0 out of bounds?
92
93(DEFUN FONT-GET-PIXEL (FONT CHAR ROW COL &AUX TEM (NEXTCHAR (1+ CHAR)))
94  (COND ((OR (< ROW 0)
95             (>= ROW (FONT-RASTER-HEIGHT FONT))
96             (< COL 0)
97             (COND ((SETQ TEM (FONT-INDEXING-TABLE FONT))
98                    (SETQ CHAR (+ (AR-1 TEM CHAR) (// COL (FONT-RASTER-WIDTH FONT))))
99                    (SETQ COL (\ COL (FONT-RASTER-WIDTH FONT)))
100                    (>= CHAR (AR-1 TEM NEXTCHAR)))
101                   ((>= COL (FONT-RASTER-WIDTH FONT)))))
102         0)  ;out of bounds, return 0
103        (T
104         (DO ((FONT FONT (FONT-NEXT-PLANE FONT))
105              (PIXEL 0)
106              (PLANENUM 0 (1+ PLANENUM)))
107             ((NULL FONT) PIXEL)
108           (SETQ PIXEL
109                 (+ PIXEL (LSH (AR-1 FONT
110                                     (+ (* 32. (+ (* (FONT-WORDS-PER-CHAR FONT) CHAR)
111                                                  (// ROW (FONT-RASTERS-PER-WORD FONT))))
112                                        (+ (* (FONT-RASTER-WIDTH FONT)
113                                              (\ ROW (FONT-RASTERS-PER-WORD FONT)))
114                                           COL)))
115                               PLANENUM)))))))
116
117(DEFUN FONT-SET-PIXEL (PIXEL FONT CHAR ROW COL &AUX TEM (NEXTCHAR (1+ CHAR)))
118  (COND ((OR (< ROW 0)
119             (>= ROW (FONT-RASTER-HEIGHT FONT))
120             (< COL 0)
121             (COND ((SETQ TEM (FONT-INDEXING-TABLE FONT))
122                    (SETQ CHAR (+ (AR-1 TEM CHAR) (// COL (FONT-RASTER-WIDTH FONT))))
123                    (SETQ COL (\ COL (FONT-RASTER-WIDTH FONT)))
124                    (>= CHAR (AR-1 TEM NEXTCHAR)))
125                   ((>= COL (FONT-RASTER-WIDTH FONT)))))
126         (FERROR NIL "Store of ~C in ~S at ~O,~O out of character bounds" CHAR FONT ROW COL))
127        (T
128         (DO ((FONT FONT (FONT-NEXT-PLANE FONT))
129              (BIT PIXEL (LSH BIT -1)))
130             ((NULL FONT) PIXEL)
131             (AS-1 BIT FONT
132                   (+ (* 32. (+ (* (FONT-WORDS-PER-CHAR FONT) CHAR)
133                                (// ROW (FONT-RASTERS-PER-WORD FONT))))
134                      (+ (* (FONT-RASTER-WIDTH FONT)
135                            (\ ROW (FONT-RASTERS-PER-WORD FONT)))
136                         COL)))))))
137
138;This function takes an FD format font and creates an internal format
139;       font from it.  All of the hairy formats of the stored font
140;       are taken care of by this function so the user doesn't have
141;       to worry about them.
142
143(DEFUN FONT-DESCRIPTOR-INTO-FONT (FONT-DESCRIPTOR
144           &OPTIONAL (NBR-PLANES-OUT NIL)
145           &AUX (FONT-OUT NIL)
146                (COL-INCR (COND ((FD-DOUBLE-WIDTH-P FONT-DESCRIPTOR) 2)
147                                (T 1)))
148                (SPACE-WIDTH (OR (FD-SPACE-WIDTH FONT-DESCRIPTOR) 0))
149                (WIDTH (// SPACE-WIDTH COL-INCR))
150                (HEIGHT (FD-LINE-SPACING FONT-DESCRIPTOR))
151                (BASELINE (FD-BASELINE FONT-DESCRIPTOR))
152                (RASTER-WIDTH (// (+ (MAX-RASTER-WIDTH FONT-DESCRIPTOR)
153                                     (1- COL-INCR))
154                                  COL-INCR))
155                (RASTER-HEIGHT (MAX-RASTER-HEIGHT FONT-DESCRIPTOR))
156                (RASTERS-PER-WORD (// 32. (MIN 32. RASTER-WIDTH)))
157                (WORDS-PER-RASTER-ELEMENT (1+ (// (1- RASTER-HEIGHT) RASTERS-PER-WORD)))
158                (TOTAL-RASTER-ELEMENTS 200)
159                (BLINKER-WIDTH (// (FD-BLINKER-WIDTH FONT-DESCRIPTOR) COL-INCR))
160                (BLINKER-HEIGHT (FD-BLINKER-HEIGHT FONT-DESCRIPTOR))
161                (INDEXING-TABLE NIL)
162                (CHARS-EXIST-TABLE (MAKE-ARRAY NIL ART-1B 200))
163                TEMP                                    ;General temporary
164                )
165
166;Set up NBR-PLANES-OUT if defaulted
167       (COND ((NULL NBR-PLANES-OUT)
168              (SETQ NBR-PLANES-OUT COL-INCR)))
169
170;Create INDEXING-TABLE if needed
171       (COND ((> RASTER-WIDTH 32.)
172                (SETQ INDEXING-TABLE (MAKE-ARRAY NIL 'ART-16B 201))
173                (AS-1 0 INDEXING-TABLE 0)
174                (DO ((CHAR-CODE 0 (1+ CHAR-CODE)))
175                    (( CHAR-CODE 200) (SETQ TOTAL-RASTER-ELEMENTS (AR-1 INDEXING-TABLE 200)))
176                    (SETQ TEMP (AR-1 FONT-DESCRIPTOR CHAR-CODE))
177                    (AS-1 (+ (AR-1 INDEXING-TABLE CHAR-CODE)
178                             (COND ((NULL TEMP) 0)
179                                   (T (// (+ (ARRAY-DIMENSION-N 2 TEMP) 31.) 32.))))
180                          INDEXING-TABLE (1+ CHAR-CODE)))
181                (SETQ RASTER-WIDTH 32.)))
182
183;set up all the planes of the font
184       (DO ((I NBR-PLANES-OUT (1- I)))
185           ((ZEROP I))
186
187;Make up a (one-plane) font and make it's next plane be the last one we made
188           (SETQ TEMP (TV:MAKE-FONT MAKE-ARRAY (NIL 'ART-1B
189                                                    (* TOTAL-RASTER-ELEMENTS
190                                                       WORDS-PER-RASTER-ELEMENT 32.))))
191           (SETF (FONT-NEXT-PLANE TEMP) FONT-OUT)
192           (SETQ FONT-OUT TEMP)
193
194;Now set all the other fields in the leader
195           (SETF (FONT-NAME FONT-OUT) (FD-NAME FONT-DESCRIPTOR))
196           (SETF (FONT-CHAR-WIDTH FONT-OUT) WIDTH)
197           (SETF (FONT-CHAR-HEIGHT FONT-OUT) HEIGHT)
198           (SETF (FONT-RASTER-WIDTH FONT-OUT) RASTER-WIDTH)
199           (SETF (FONT-RASTER-HEIGHT FONT-OUT) RASTER-HEIGHT)
200           (SETF (FONT-RASTERS-PER-WORD FONT-OUT) RASTERS-PER-WORD)
201           (SETF (FONT-WORDS-PER-CHAR FONT-OUT) WORDS-PER-RASTER-ELEMENT)
202           (SETF (FONT-BASELINE FONT-OUT) BASELINE)
203           (SETF (FONT-BLINKER-WIDTH FONT-OUT) BLINKER-WIDTH)
204           (SETF (FONT-BLINKER-HEIGHT FONT-OUT) BLINKER-HEIGHT)
205           (SETF (FONT-NAME FONT-OUT) (FD-NAME FONT-DESCRIPTOR))
206           (SETF (FONT-CHARS-EXIST-TABLE FONT-OUT) CHARS-EXIST-TABLE)
207           (SETF (FONT-INDEXING-TABLE FONT-OUT) INDEXING-TABLE))
208       (DO ((CHAR-CODE 0 (1+ CHAR-CODE))) (( CHAR-CODE 200))
209           (SETQ TEMP (AR-1 FONT-DESCRIPTOR CHAR-CODE))
210           (COND (TEMP
211                  (STORE-CD-IN-FONT TEMP FONT-OUT CHAR-CODE
212                                    (FD-DOUBLE-WIDTH-P FONT-DESCRIPTOR)))))
213       FONT-OUT)
214
215;Store the data in CD into character number CHAR-CODE of FONT.
216;It is assumed that the dimensions of the CD fit within the raster dimensions of the font.
217;This is not recommended for users to call.
218(DEFUN STORE-CD-IN-FONT (CD FONT CHAR-CODE &OPTIONAL (DOUBLE-WIDTH-P NIL) &AUX
219                            (WIDTH (ARRAY-DIMENSION-N 2 CD))
220                            (HEIGHT (ARRAY-DIMENSION-N 1 CD))
221                            (FONT-HEIGHT (FONT-RASTER-HEIGHT FONT))
222                            (FONT-WIDTH (FONT-RASTER-WIDTH FONT))
223                            PIXEL
224                            (COL-INCR (COND (DOUBLE-WIDTH-P 2) (T 1))))
225    ;; Update the font's char-width-table, creating one if necessary.
226    (LET ((CW (// (+ (CD-CHAR-WIDTH CD)
227                     (1- COL-INCR))
228                  COL-INCR))
229          (FCW (FONT-CHAR-WIDTH FONT))
230          (FCWT (FONT-CHAR-WIDTH-TABLE FONT)))
231        (COND (FCWT
232               (AS-1 CW FCWT CHAR-CODE))
233              ((NOT (= CW FCW))
234               (SETF (FONT-CHAR-WIDTH-TABLE FONT)
235                     (SETQ FCWT (MAKE-ARRAY NIL ART-8B '(200))))
236               (AND DOUBLE-WIDTH-P
237                    (SETF (FONT-CHAR-WIDTH-TABLE (FONT-NEXT-PLANE FONT))
238                          FCWT))
239               (DO I 0 (1+ I) (= I 200)
240                  (AS-1 FCW FCWT I))
241               (AS-1 CW FCWT CHAR-CODE)))
242        (AND (= CHAR-CODE #/ )
243             (SETF (FONT-CHAR-WIDTH FONT) CW)))
244    ;; Update the font's left-kern table, creating one if necessary.
245    (LET ((CK (CD-CHAR-LEFT-KERN CD))
246          (FCKT (FONT-LEFT-KERN-TABLE FONT)))
247        (COND (FCKT (AS-1 CK FCKT CHAR-CODE))
248              ((NOT (ZEROP CK))
249               (SETF (FONT-LEFT-KERN-TABLE FONT)        ;MUST BE ART-32B BECAUSE LEFT-KERN
250                     (SETQ FCKT (MAKE-ARRAY NIL ART-32B '(200))))  ;CAN BE NEGATIVE
251               (AND DOUBLE-WIDTH-P
252                    (SETF (FONT-LEFT-KERN-TABLE (FONT-NEXT-PLANE FONT))
253                          FCKT))
254               (AS-1 CK FCKT CHAR-CODE))))
255    ;; Tell the font this char exists.
256    (ERRSET (AS-1 1 (FONT-CHARS-EXIST-TABLE FONT) CHAR-CODE) NIL)
257    ;; In wide fonts, the raster width depends on the character, and is a multiple of 32.
258    (COND ((FONT-INDEXING-TABLE FONT)
259           (SETQ FONT-WIDTH (* (// (+ (ARRAY-DIMENSION-N 2 CD) 31.) 32.) 32.))))
260    ;; Now copy the data.
261    (DO ((ROW 0 (1+ ROW)))
262        (( ROW FONT-HEIGHT))
263        (DO ((COL 0 (+ COL COL-INCR))
264             (PIXEL-COL 0 (1+ PIXEL-COL)))
265            (( PIXEL-COL FONT-WIDTH))
266            (SETQ PIXEL (COND ((OR (>= COL WIDTH) (>= ROW HEIGHT)) 0)
267                              (DOUBLE-WIDTH-P
268                               (+ (COND ((>= (1+ COL) WIDTH) 0)
269                                        (T (AR-2 CD ROW (1+ COL))))
270                                  (* 2 (AR-2 CD ROW COL))))
271                              (T (AR-2 CD ROW COL))))
272            (FONT-SET-PIXEL PIXEL FONT CHAR-CODE
273                            ROW PIXEL-COL))))
274
275;Create an FD format font from an internal format font
276
277(DEFUN FONT-INTO-FONT-DESCRIPTOR (FONT &OPTIONAL (DBL-WIDTH-P NIL)
278                   &AUX (FONT-DESCRIPTOR (MAKE-FONT-DESCRIPTOR))
279                        (LINE-SPACING (FONT-CHAR-HEIGHT FONT))
280                        (RASTER-HEIGHT (FONT-RASTER-HEIGHT FONT))
281                        (BASELINE (FONT-BASELINE FONT))
282                        (BLINKER-HEIGHT (FONT-BLINKER-HEIGHT FONT))
283                        (BLINKER-WIDTH (FONT-BLINKER-WIDTH FONT))
284                        (SPACE-WIDTH (FONT-CHAR-WIDTH FONT))
285                        FONT-CHARS-EXIST-TABLE
286                        TEMP RASTER-WIDTH CHARACTER-WIDTH LEFT-KERN PIXEL
287                        )
288       (ERRSET (SETQ FONT-CHARS-EXIST-TABLE (FONT-CHARS-EXIST-TABLE FONT)) NIL)
289       (SETF (FD-NAME FONT-DESCRIPTOR) (FONT-NAME FONT))
290       (SETF (FD-LINE-SPACING FONT-DESCRIPTOR) LINE-SPACING)
291       (SETF (FD-BASELINE FONT-DESCRIPTOR)BASELINE)
292       (SETF (FD-BLINKER-HEIGHT FONT-DESCRIPTOR) BLINKER-HEIGHT)
293       (SETF (FD-BLINKER-WIDTH FONT-DESCRIPTOR) BLINKER-WIDTH)
294       (SETF (FD-SPACE-WIDTH FONT-DESCRIPTOR) SPACE-WIDTH)
295       (SETF (FD-DOUBLE-WIDTH-P FONT-DESCRIPTOR) DBL-WIDTH-P)
296       (DO ((CHAR-CODE 0 (1+ CHAR-CODE)))
297           (( CHAR-CODE 200))
298           (AND FONT-CHARS-EXIST-TABLE
299                (ZEROP (AR-1 FONT-CHARS-EXIST-TABLE CHAR-CODE))
300                (GO SKIP-CHAR))
301           (SETQ CHARACTER-WIDTH (COND ((SETQ TEMP (FONT-CHAR-WIDTH-TABLE FONT))
302                                        (AR-1 TEMP CHAR-CODE))
303                                       (T (FONT-CHAR-WIDTH FONT))))
304           (SETQ RASTER-WIDTH
305                 (FONT-CHAR-MIN-RASTER-WIDTH FONT CHAR-CODE))
306           (SETQ LEFT-KERN (COND ((SETQ TEMP (FONT-LEFT-KERN-TABLE FONT))
307                                  (AR-1 TEMP CHAR-CODE))
308                                 (T 0)))
309           (SETQ TEMP (MAKE-CHAR-DESCRIPTOR
310                               MAKE-ARRAY (NIL 'ART-4B (LIST RASTER-HEIGHT RASTER-WIDTH))
311                               CD-CHAR-WIDTH CHARACTER-WIDTH
312                               CD-CHAR-LEFT-KERN LEFT-KERN))
313           (AS-1 TEMP FONT-DESCRIPTOR CHAR-CODE)
314           (COND (DBL-WIDTH-P (DO ((ROW 0 (1+ ROW)))
315                                  (( ROW RASTER-HEIGHT))
316                                  (DO ((COLI 0 (1+ COLI))
317                                       (COL 0 (+ 2 COL)))
318                                      (( COL RASTER-WIDTH))
319                                      (SETQ PIXEL (FONT-GET-PIXEL FONT CHAR-CODE ROW COLI))
320                                      (AS-2 PIXEL TEMP ROW COL)
321                                      (AS-2 (LSH PIXEL -1) TEMP ROW (1+ COL)))))
322                 (T (DO ((ROW 0 (1+ ROW)))
323                        (( ROW RASTER-HEIGHT))
324                        (DO ((COL 0 (1+ COL)))
325                            (( COL RASTER-WIDTH))
326                            (AS-2 (FONT-GET-PIXEL FONT CHAR-CODE ROW COL)
327                                  TEMP ROW COL)))))
328           SKIP-CHAR)
329       FONT-DESCRIPTOR)
330
331;; Read in a kst file and make and return a FONT-DESCRIPTOR,
332;; which is an alternate convenient representation for a font.
333(defun read-kst-into-font-descriptor (filename &optional fontname &aux stream fd)
334  (setq filename (fs:file-parse-name filename nil t ':kst))
335  (or fontname (setq fontname (funcall filename ':name)))
336  (and (stringp fontname) (setq fontname (intern fontname "FONTS")))
337  (setq stream (open filename '(:fixnum :in :byte-size 9.)))
338  (setq fd (make-font-descriptor fd-name fontname))
339  ;; Discard KSTID.
340  (dotimes (i 4) (funcall stream ':tyi))
341  ;; Discard column position adjust until I find out what it means.
342  (or (zerop (funcall stream ':tyi))
343      (ferror nil
344              "Nonzero column-position-adjust in font ~A -- what does that mean?"
345              fontname))
346  (setf (fd-space-width fd) 0)                  ;Just in case no space character.
347  (setf (fd-baseline fd) (funcall stream ':tyi))
348  (setf (fd-line-spacing fd) (read-kst-halfword stream))
349  (setf (fd-blinker-height fd)
350        (fd-line-spacing fd))
351  (setf (fd-name fd) fontname)
352  (let (kern char-code raster-width char-width byte-list byte-list-head cd tem
353             (line-height (fd-line-spacing fd)))
354    (do () ((= (logand (read-kst-halfword stream) (read-kst-halfword stream)) -1))
355      (setq kern (read-kst-halfword stream))
356      (setq char-code (read-kst-halfword stream))
357      (setq raster-width (read-kst-halfword stream))
358      (setq char-width (read-kst-halfword stream))
359      (setq cd (make-char-descriptor
360                 make-array (nil art-1b (list line-height raster-width))))
361      (setf (cd-char-width cd) char-width)
362      (setf (cd-char-left-kern cd) kern)
363      (as-1 cd fd char-code)
364      (and (= char-code #/ )
365           (setf (fd-space-width fd) char-width))
366      ;; read in the bits of the character
367      (setq byte-list nil
368            byte-list-head (list nil nil nil nil))
369      (dotimes (vpos line-height)
370        ;; Read in the next row.
371        (dotimes (hpos raster-width)
372          ;; If byte is exhausted, get next byte into (car byte-list)
373          (cond ((zerop (\ hpos 8))
374                 (setq byte-list (read-kst-bytes stream byte-list byte-list-head))))
375          (setq tem (logand 1 (lsh (car byte-list) (- (\ hpos 8)))))
376          (as-2 tem cd vpos hpos)))))
377  (setf (fd-fill-pointer fd) 200)
378  ;; Set width of blinker and space fields from the space character.
379  (setf (fd-blinker-width fd)
380        (fd-space-width fd))
381  (funcall stream ':close)
382  fd)
383
384;; Read in a kst file and define a font.
385;; The font name defaults from the file name.
386(defun read-kst-into-font (filename &optional fontname
387                                    &aux stream font chars-exist-table
388                                    raster-width raster-height
389                                    rasters-per-word words-per-char)
390    (setq filename (fs:file-parse-name filename nil t ':kst))
391    (or fontname (setq fontname (funcall filename ':name)))
392    (and (stringp fontname) (setq fontname (intern fontname "FONTS")))
393    ;; Read file once to determine font parameters.
394    (multiple-value (raster-width raster-height)
395                    (read-kst-max-raster-width filename))
396    ;; If this is a hairy wide font, then instead of writing it directly
397    ;; make a font-descriptor and turn it into a font.
398    (cond ((> raster-width 32.)
399           (font-name-set-font-and-descriptor
400               fontname
401               (read-kst-into-font-descriptor filename fontname))
402           fontname)
403          (t
404           (setq rasters-per-word (// 32. raster-width))
405           (setq words-per-char (// (+ raster-height rasters-per-word -1) rasters-per-word))
406           ;; Now that we know the parameters, allocate the font.
407           (setq font (tv:make-font make-array (nil art-1b (* words-per-char 32. 200))))
408           (setf (font-rasters-per-word font) rasters-per-word)
409           (setf (font-words-per-char font) words-per-char)
410           (setf (font-raster-width font) raster-width)
411           (setf (font-raster-height font) raster-height)
412           (setf (font-char-height font) raster-height)
413           (setf (font-blinker-height font) raster-height)
414           (setf (font-name font) fontname)
415           (setq chars-exist-table (make-array nil art-1b 200))
416           (setf (font-chars-exist-table font) chars-exist-table)
417           ;; Now actually read in the data of the font.
418           (setq stream (open filename '(:fixnum :in :byte-size 9.)))
419           ;; Discard KSTID.
420           (dotimes (i 4) (funcall stream ':tyi))
421           ;; Discard column position adjust until I find out what it means.
422           (or (zerop (funcall stream ':tyi))
423               (ferror nil
424                       "Nonzero column-position-adjust in font ~A -- what does that mean?"
425                       fontname))
426           (setf (font-baseline font) (funcall stream ':tyi))
427           ;; Discard line height (already determined).
428           (read-kst-halfword stream)
429           (let (kern char-code char-width char-raster-width
430                      byte-list byte-list-head tem bit-pos word-pos
431                      (line-height raster-height))
432               (do () ((= (logand (read-kst-halfword stream) (read-kst-halfword stream)) -1))
433                   (setq kern (read-kst-halfword stream))
434                   (setq char-code (read-kst-halfword stream))
435                   ;; While all chars have the same raster width in the lisp machine font,
436                   ;; we need the raster width stored in the kst file to read the kst file.
437                   (setq char-raster-width (read-kst-halfword stream))
438                   (setq char-width (read-kst-halfword stream))
439                   (as-1 1 chars-exist-table char-code)
440                   ;; Now store the char width and left kern, creating the tables if nec.
441                   (cond ((null (font-char-width font))
442                          (setf (font-char-width font) char-width))
443                         ((font-char-width-table font)
444                          (as-1 char-width (font-char-width-table font) char-code))
445                         ((= char-width (font-char-width font)))
446                         (t (setf (font-char-width-table font)
447                                  (make-array nil art-16b 200))
448                            (as-1 char-width (font-char-width-table font) char-code)))
449                   (and (= char-code #/ )
450                        (setf (font-char-width font) char-width))
451                   (cond ((not (zerop kern))
452                          (or (font-left-kern-table font)
453                              (setf (font-left-kern-table font)
454                                    ;; Use art-32b so can hold both signs.
455                                    (make-array nil art-32b 200)))
456                          (as-1 kern (font-left-kern-table font) char-code)))
457                   ;; read in the bits of the character
458                   (setq byte-list nil
459                         byte-list-head (list nil nil nil nil))
460                   (setq word-pos (* char-code words-per-char)
461                         bit-pos 0)
462                   (dotimes (vpos line-height)
463                      ;; Find next row in font - advance to word boundary if nec.
464                      (and (> (+ bit-pos raster-width) 32.)
465                           (setq bit-pos 0 word-pos (1+ word-pos)))
466                      ;; Read in that row.
467                      (dotimes (hpos char-raster-width)
468                         ;; If byte is exhausted, get next byte into (car byte-list)
469                         (cond ((zerop (\ hpos 8))
470                                (setq byte-list (read-kst-bytes stream byte-list byte-list-head))))
471                         (setq tem (logand 1 (lsh (car byte-list) (- (\ hpos 8)))))
472                         (as-1 tem font (+ (lsh word-pos 5) bit-pos hpos)))
473                      ;; Advance past this row in the font.
474                      (setq bit-pos (+ bit-pos raster-width)))
475                   ))
476           ;; Set width of blinker and space fields from the space character.
477           (setf (font-blinker-width font)
478                 (font-char-width font))
479           (set fontname font)
480           (putprop fontname filename 'kst-file)
481           (funcall stream ':close)
482           fontname)))
483
484;; Scan a kst file and return two values which are the
485;; raster width and raster height needed in a TV format font to contain that font.
486(defun read-kst-max-raster-width (filename &aux stream
487                                                raster-height (raster-width 0)
488                                                char-raster-width)
489  (setq stream (open (fs:file-parse-name filename nil t ':kst) '(:fixnum :in :byte-size 9.)))
490  ;; Discard KSTID.
491  (dotimes (i 4) (funcall stream ':tyi))
492  ;; Discard column-position-adjust
493  (funcall stream ':tyi)
494  ;; Discard baseline.
495  (funcall stream ':tyi)
496  ;; Remember font line height as raster height.
497  (setq raster-height (read-kst-halfword stream))
498  ;; Keep maxing raster widths of characters into raster-width
499  (setq raster-width 0)
500  (do () ((= (logand (read-kst-halfword stream) (read-kst-halfword stream)) -1))
501    ;; Ignore char's left kern.
502    (read-kst-halfword stream)
503    ;; Ignore its character code.
504    (read-kst-halfword stream)
505    ;; Max in its raster width
506    (setq char-raster-width (read-kst-halfword stream))
507    (setq raster-width (max raster-width char-raster-width))
508    ;; Ignore its character width.
509    (read-kst-halfword stream)
510    ;; Skip the bits of the character
511    (prog ((bytes (* raster-height (// (+ char-raster-width 7) 8))))
512          (setq bytes (* 4 (// (+ bytes 3) 4)))
513          (dotimes (i bytes)
514            (funcall stream ':tyi))))
515  (funcall stream ':close)
516  (prog () (return raster-width raster-height)))
517
518;; Fetch the next 8-bit byte where stream is a 9-bit byte stream.
519;; byte-list-head should be a list of 4 things we can clobber.
520;; byte-list is a tail of it.
521;; We advance it, and if it is empty we fill byte-list-head
522;; with four more 8-bit bytes and return that.
523;; The car of our value is the next byte.
524;; Save the value for the byte-list arg next time.
525(defun read-kst-bytes (stream byte-list byte-list-head)
526    (or (cdr byte-list)
527        ;; Exhausted the word - read another.
528        (let ((hwd1 (read-kst-halfword stream))
529              (hwd2 (read-kst-halfword stream)))
530             (setq byte-list byte-list-head)
531             ;; Turn it into 4 8-bit bytes in byte-list.
532             (rplaca byte-list (ldb 1210 hwd1))
533             (rplaca (cdr byte-list) (ldb 0210 hwd1))
534             (rplaca (cddr byte-list)
535                     (+ (lsh (ldb 0002 hwd1) 6)
536                        (ldb 1406 hwd2)))
537             (rplaca (cdddr byte-list) (ldb 0410 hwd2))
538             byte-list)))
539
540;; Read two 9-bit bytes from stream, make an 18-bit halfword,
541;; and sign-extend it.
542(defun read-kst-halfword (stream &aux hwd)
543    (setq hwd (+ (* (funcall stream ':tyi) 1000)
544                 (funcall stream ':tyi)))
545    (cond ((bit-test hwd 400000)
546           (logior hwd -400000))
547          (t hwd)))
548
549;; It would be good to check for chars that are all zero and
550;; flush them, and also to compute the actual needed raster width and use it.
551(defun write-font-into-kst (fontname &optional filename &aux stream font)
552  (and (stringp fontname) (setq fontname (intern fontname "FONTS")))
553  (setq filename (fs:file-parse-name filename nil t ':kst))
554  (setq font (symeval fontname))
555  (cond ((font-indexing-table font)
556         (let ((fd (font-name-font-descriptor fontname)))
557           (write-font-descriptor-into-kst fd filename)))
558        (t
559         (and (> (font-raster-height font)
560                 (font-char-height font))
561              (format t "Warning: font raster height exceeds line height"))
562         (setq stream (open filename '(:fixnum :out :byte-size 9.)))
563         ;; Write KSTID as 0.
564         (dotimes (i 4) (funcall stream ':tyo 0))
565         ;; Write column position adjust as 0.
566         (funcall stream ':tyo 0)
567         ;; Write baseline and height into second header word.
568         (funcall stream ':tyo (font-baseline font))
569         (write-kst-halfword stream (font-char-height font))
570         ;; Then write out all the characters.
571         (let (kern-table char-width-table chars-exist-table
572                          word-pos bit-pos byte-count byte
573                          char-raster-width byte-list byte-list-head)
574           (setq kern-table (font-left-kern-table font)
575                 char-width-table (font-char-width-table font))
576           (errset (setq chars-exist-table (font-chars-exist-table font)) nil)
577           (dotimes (char-code 200)
578             (and chars-exist-table
579                  (zerop (ar-1 chars-exist-table char-code))
580                  (go skip-char))
581             ;; Each char must start with a word containing a 1.
582             (write-kst-halfword stream 0)
583             (write-kst-halfword stream 1)
584             ;; left kern and char code fill the next word.
585             (write-kst-halfword stream
586                                 (or (and kern-table (ar-1 kern-table char-code)) 0))
587             (write-kst-halfword stream char-code)
588             ;; Raster width and char width are the next word.
589             (setq char-raster-width (max 1 (font-char-min-raster-width font char-code)))
590             (write-kst-halfword stream char-raster-width)
591             (write-kst-halfword stream
592                                 (cond (char-width-table (or (ar-1 char-width-table char-code) 0))
593                                       (t (font-char-width font))))
594             ;; Write out the bits of the character
595             ;; Word-pos and bit-pos are used to point at a bit in the font.
596             (setq word-pos (* (font-words-per-char font) char-code))
597             (setq bit-pos 0 byte-count 0)
598             ;; Byte-list and its head are used to accumulate 4 bytes
599             ;; and then output them at once as a word.
600             ;; This is needed because the stream wants 9-bit bytes.
601             (setq byte-list-head (list nil nil nil nil))
602             (setq byte-list byte-list-head)
603             (dotimes (vpos (font-char-height font))
604               ;; Prepare to extract next row of char from font.
605               (and (> (+ bit-pos (font-raster-width font)) 32.)
606                    (setq word-pos (1+ word-pos) bit-pos 0))
607               (setq byte 0)
608               ;; Get the row a bit at a time and fill up 8-bit bytes.
609               ;; Output the bytes when full.  Output the excess at the end.
610               ;; Count the bytes output with byte-count
611               (dotimes (hpos char-raster-width)
612                 (cond ((and (= (\ hpos 8) 0) (not (zerop hpos)))
613                        (setq byte-count (1+ byte-count))
614                        (setq byte-list
615                              (write-kst-byte stream byte byte-list byte-list-head))
616                        (setq byte 0)))
617                 (or ( vpos (font-raster-height font))
618                     (setq byte (+ byte (lsh (ar-1 font
619                                                   (+ (* 32. word-pos) hpos bit-pos))
620                                             (\ hpos 8))))))
621               (setq byte-count (1+ byte-count))
622               (setq byte-list (write-kst-byte stream byte byte-list byte-list-head))
623               (setq bit-pos (+ bit-pos (font-raster-width font))))
624             ;; Pad to a word boundary.
625             (do () ((zerop (\ byte-count 4)))
626               (setq byte-list (write-kst-byte stream 0 byte-list byte-list-head))
627               (setq byte-count (1+ byte-count)))
628             skip-char)
629           ;; Mark end of file with two -1 words.
630           (dotimes (i 8)
631             (funcall stream ':tyo -1)))
632         (close stream))))
633
634(defun write-font-descriptor-into-kst (fd filename &aux stream)
635    (setq stream (open (fs:file-parse-name filename nil t ':kst)
636                       '(:fixnum :out :byte-size 9.)))
637    ;; Write KSTID as 0.
638    (dotimes (i 4) (funcall stream ':tyo 0))
639    ;; Write column position adjust as 0.
640    (funcall stream ':tyo 0)
641    ;; Write baseline and height into second header word.
642    (funcall stream ':tyo (fd-baseline fd))
643    (write-kst-halfword stream (fd-line-spacing fd))
644    ;; Then write out all the characters.
645    (let (cd char-height byte-count byte byte-list byte-list-head)
646       (dotimes (char-code 200)
647          (cond ((and (setq cd (ar-1 fd char-code))
648                      ;; Wide fonts without chars-exist-tables can have 0-width chars.
649                      (or (not (zerop (array-dimension-n 2 cd)))
650                          (not (zerop (cd-char-width cd)))))
651            ;; Each char must start with a word containing a 1.
652            (write-kst-halfword stream 0)
653            (write-kst-halfword stream 1)
654            ;; left kern and char code fill the next word.
655            (write-kst-halfword stream (cd-char-left-kern cd))
656            (write-kst-halfword stream char-code)
657            ;; Raster width and char width are the next word.
658            (write-kst-halfword stream (array-dimension-n 2 cd))
659            (write-kst-halfword stream (cd-char-width cd))
660            ;; Write out the bits of the character
661            ;; Byte-list and its head are used to accumulate 4 bytes
662            ;; and then output them at once as a word.
663            ;; This is needed because the stream wants 9-bit bytes.
664            (setq byte-list-head (list nil nil nil nil))
665            (setq byte-list byte-list-head)
666            (setq byte-count 0)
667            (setq char-height (array-dimension-n 1 cd))
668            (and (> char-height (fd-line-spacing fd))
669                 (ferror nil "Character ~C height exceeds font line height in KST file"
670                         char-code))
671            (dotimes (vpos (fd-line-spacing fd))
672               ;; Prepare to extract next row of char from font.
673               (setq byte 0)
674               ;; Get the row a bit at a time and fill up 8-bit bytes.
675               ;; Output the bytes when full.  Output the excess at the end.
676               ;; Count the bytes output with byte-count
677               (dotimes (hpos (array-dimension-n 2 cd))
678                   (cond ((and (= (\ hpos 8) 0) (not (zerop hpos)))
679                          (setq byte-count (1+ byte-count))
680                          (setq byte-list
681                                (write-kst-byte stream byte byte-list byte-list-head))
682                          (setq byte 0)))
683                   (or ( vpos char-height)
684                       (setq byte (+ byte (lsh (ar-2 cd vpos hpos) (\ hpos 8))))))
685               (setq byte-count (1+ byte-count))
686               (setq byte-list (write-kst-byte stream byte byte-list byte-list-head)))
687            ;; Pad to a word boundary.
688            (do () ((zerop (\ byte-count 4)))
689               (setq byte-list (write-kst-byte stream 0 byte-list byte-list-head))
690               (setq byte-count (1+ byte-count))))))
691       ;; Mark end of file with two -1 words.
692       (dotimes (i 8)
693            (funcall stream ':tyo -1)))
694    (close stream))
695
696;; Write an 8-bit byte to the kst file.  We pack 4 bytes per word.
697;; The stream is assumed to want 9-bit bytes.
698;; Byte-list-head should be a list of length 4 we can clobber.
699;; byte-list should initially be the same thing;  we return a new value to set it to.
700(defun write-kst-byte (stream byte byte-list byte-list-head)
701    (rplaca byte-list byte)
702    (pop byte-list)
703    (cond ((null byte-list)
704           (setq byte-list byte-list-head)
705           (write-kst-halfword stream
706                  (+ (lsh (first byte-list) 10.)
707                     (lsh (second byte-list) 2.)
708                     (ldb 0602 (third byte-list))))
709           (write-kst-halfword stream
710                  (+ (lsh (ldb 0006 (third byte-list)) 12.)
711                     (lsh (fourth byte-list) 4)))))
712    byte-list)
713
714(defun write-kst-halfword (stream halfword)
715    (funcall stream ':tyo (ldb 1111 halfword))
716    (funcall stream ':tyo (ldb 0011 halfword)))
717
718;; Compute the smallest raster width needed to store the specified char
719;; as defined by the specified font.
720;; low-level means we are looking at one sub-character in a wide font.
721(defun font-char-min-raster-width (font char-code &optional low-level
722                                        &aux bit-pos word-pos tem
723                                        min-raster-width f-raster-width raster-height)
724    (cond ((and (not low-level)
725                (setq tem (font-indexing-table font)))
726           ;; If it's a wide font, go by the number of vertical stripes,
727           ;; but also see how wide the rightmost stripe really needs to be.
728           (max 0
729                (+ (* 32. (- (ar-1 tem (1+ char-code)) (ar-1 tem char-code)))
730                   -32.
731                   (font-char-min-raster-width font (1- (ar-1 tem (1+ char-code))) t))))
732          (t (setq word-pos (* char-code (font-words-per-char font))
733                   bit-pos 0
734                   min-raster-width 0
735                   f-raster-width (font-raster-width font)
736                   raster-height (font-raster-height font))
737             (dotimes (vpos raster-height)
738                 (and (> (+ bit-pos f-raster-width) 32.)
739                      (setq bit-pos 0 word-pos (1+ word-pos)))
740                 (do ((hpos 0 (1+ hpos)) (index (+ bit-pos (lsh word-pos 5)) (1+ index)))
741                     ((= hpos f-raster-width))
742                    (or (zerop (ar-1 font index))
743                        (setq min-raster-width (max (1+ hpos) min-raster-width))))
744                 (setq bit-pos (+ f-raster-width bit-pos)))
745             min-raster-width)))
746
747;; ALTO .AL format
748;; Load an ALTO font file into a font, the easy way, via a font descriptor
749(DEFUN READ-AL-INTO-FONT (FILENAME &OPTIONAL FONTNAME)
750  (SETQ FILENAME (FS:FILE-PARSE-NAME FILENAME NIL T ':AL))
751  (OR FONTNAME (SETQ FONTNAME (FUNCALL FILENAME ':NAME)))
752  (AND (STRINGP FONTNAME) (SETQ FONTNAME (INTERN FONTNAME "FONTS")))
753  (FONT-NAME-SET-FONT-AND-DESCRIPTOR FONTNAME
754                                     (READ-AL-INTO-FONT-DESCRIPTOR FILENAME FONTNAME))
755  (SYMEVAL FONTNAME))
756
757;; Load an ALTO font file into a font descriptor
758(DEFUN READ-AL-INTO-FONT-DESCRIPTOR (FILENAME &OPTIONAL FONTNAME
759                                              &AUX FD STREAM ARRAY LINE-HEIGHT)
760  (SETQ FILENAME (FS:FILE-PARSE-NAME FILENAME NIL T ':AL))
761  (OR FONTNAME (SETQ FONTNAME (FUNCALL FILENAME ':NAME)))
762  (AND (STRINGP FONTNAME) (SETQ FONTNAME (INTERN FONTNAME "FONTS")))
763  (SETQ FD (MAKE-FONT-DESCRIPTOR FD-NAME FONTNAME))
764  (SETF (FD-NAME FD) FONTNAME)
765  (SETQ STREAM (OPEN FILENAME '(:IN :FIXNUM)))
766  (UNWIND-PROTECT
767   (PROGN
768    (SETQ LINE-HEIGHT (FUNCALL STREAM ':TYI))
769    (SETF (FD-LINE-SPACING FD) LINE-HEIGHT)
770    (SETF (FD-BLINKER-HEIGHT FD) LINE-HEIGHT)
771    (LET ((BASELINE-AND-MAX-WIDTH (FUNCALL STREAM ':TYI)))
772      (SETF (FD-BASELINE FD) (LDB 1007 BASELINE-AND-MAX-WIDTH))
773      (SETF (FD-SPACE-WIDTH FD) (LDB 0010 BASELINE-AND-MAX-WIDTH)))
774    (SETQ ARRAY (MAKE-ARRAY NIL 'ART-16B 1000. NIL '(0)))
775    (DO CH (FUNCALL STREAM ':TYI) (FUNCALL STREAM ':TYI) (NULL CH)
776      (ARRAY-PUSH-EXTEND ARRAY CH)))
777   (FUNCALL STREAM ':CLOSE))
778  (DO ((CH 0 (1+ CH))
779       (CD)
780       (CHAR-WIDTH))
781      (( CH 200))
782    (SETQ CHAR-WIDTH 0)
783    (DO ((IDX CH)
784         (XW))
785        (NIL)
786      (SETQ IDX (+ IDX (AREF ARRAY IDX)))
787      (SETQ XW (AREF ARRAY IDX))
788      (IF (ZEROP (PROG1 (LOGAND XW 1) (SETQ XW (// XW 2))))
789          (SETQ CHAR-WIDTH (+ CHAR-WIDTH 16.)
790                IDX XW)
791          (SETQ CHAR-WIDTH (+ CHAR-WIDTH XW))
792          (RETURN)))
793    (SETQ CD (MAKE-CHAR-DESCRIPTOR MAKE-ARRAY (NIL ART-1B (LIST LINE-HEIGHT CHAR-WIDTH))))
794    (SETF (CD-CHAR-WIDTH CD) CHAR-WIDTH)
795    (AND (= CH #\SP) (SETF (FD-SPACE-WIDTH FD) CHAR-WIDTH))
796    (SETF (CD-CHAR-LEFT-KERN CD) 0)
797    (ASET CD FD CH)
798    (READ-AL-INTO-FONT-DESCRIPTOR-1 CD ARRAY CH 0))
799  (SETF (FD-FILL-POINTER FD) 200)
800  ;; Set width of blinker and space fields from the space character.
801  (SETF (FD-BLINKER-WIDTH FD) (FD-SPACE-WIDTH FD))
802  FD)
803
804;;;IDX is the address of the character-pointer
805(DEFUN READ-AL-INTO-FONT-DESCRIPTOR-1 (CD ARRAY IDX XOFF &AUX XW HD-AND-XH)
806  (SETQ IDX (+ IDX (AREF ARRAY IDX)))
807  (SETQ XW (AREF ARRAY IDX)
808        HD-AND-XH (AREF ARRAY (1+ IDX)))
809  (DO ((I (- IDX (LDB 0010 HD-AND-XH)) (1+ I))
810       (Y (LDB 1010 HD-AND-XH) (1+ Y)))
811      ((= I IDX))
812    (DO ((BITS (AREF ARRAY I) (LSH BITS 1))
813         (X XOFF (1+ X)))
814        ((ZEROP BITS))
815      (AND (BIT-TEST 100000 BITS)
816           (ASET 1 CD Y X))))
817  (OR (BIT-TEST 1 XW)
818      (READ-AL-INTO-FONT-DESCRIPTOR-1 CD ARRAY (// XW 2) (+ XOFF 16.))))
819
820(DEFUN THICKEN-FONT-DESCRIPTOR (FD &OPTIONAL NEW-NAME &AUX LEN NFD)
821  (OR NEW-NAME (SETQ NEW-NAME (INTERN (STRING-APPEND (FD-NAME FD) #/B) "FONTS")))
822  (SETQ LEN (ARRAY-LENGTH FD)
823        NFD (MAKE-FONT-DESCRIPTOR MAKE-ARRAY (NIL ART-Q LEN)
824                                  FD-NAME NEW-NAME
825                                  FD-LINE-SPACING (FD-LINE-SPACING FD)
826                                  FD-BASELINE (FD-BASELINE FD)
827                                  FD-BLINKER-HEIGHT (FD-BLINKER-HEIGHT FD)
828                                  FD-BLINKER-WIDTH (FD-BLINKER-WIDTH FD)
829                                  FD-SPACE-WIDTH (FD-SPACE-WIDTH FD)))
830  (DO ((I 0 (1+ I))
831       (CD) (NCD))
832      (( I LEN))
833    (AND (SETQ CD (AREF FD I))
834         (LET ((WIDTH (ARRAY-DIMENSION-N 2 CD))
835               (HEIGHT (ARRAY-DIMENSION-N 1 CD)))
836           (SETQ NCD (MAKE-CHAR-DESCRIPTOR MAKE-ARRAY (NIL ART-4B (LIST HEIGHT (1+ WIDTH)))
837                                           CD-CHAR-WIDTH (1+ (CD-CHAR-WIDTH CD))
838                                           CD-CHAR-LEFT-KERN (CD-CHAR-LEFT-KERN CD)))
839           (COPY-ARRAY-CONTENTS CD NCD)
840           (DOTIMES (J HEIGHT)
841             (DOTIMES (I WIDTH)
842               (ASET (LOGIOR (AREF CD J I) (AREF NCD J (1+ I))) NCD J (1+ I))))
843           (ASET NCD NFD I))))
844  NFD)
845
846(DEFUN THICKEN-FONT (FONT-SYMBOL &AUX FD NFD NFS NFNT)
847  (SETQ FD (FONT-NAME-FONT-DESCRIPTOR FONT-SYMBOL))
848  (SETQ NFD (THICKEN-FONT-DESCRIPTOR FD))
849  (SETQ NFS (FD-NAME NFD))
850  (SETQ NFNT (FONT-DESCRIPTOR-INTO-FONT NFD))
851  (SET NFS NFNT)
852  (PUTPROP NFS NFD 'FONT-DESCRIPTOR)
853  (PUTPROP NFS NFNT 'FONT-DESCRIBED)
854  NFS)
Note: See TracBrowser for help on using the repository browser.