-
-
Notifications
You must be signed in to change notification settings - Fork 24
/
Copy pathPRESSFROMNS
1395 lines (1227 loc) · 80.3 KB
/
PRESSFROMNS
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED " 9-Mar-88 15:54:25" {IVY}<HOGG>LISP>MEDLEY>PRESSFROMNS.;13 81335
changes to%: (VARS PRESSFROMNSCOMS)
(FNS \CREATECHARSET.PRESS \CREATECHARSETZERO.PRESS \CREATEPRESSFONT \COERCEFONT)
(RECORDS PRESSDATA)
previous date%: " 4-Mar-88 12:52:46" {IVY}<HOGG>LISP>MEDLEY>PRESSFROMNS.;9)
(* "
Copyright (c) 1986, 1988 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT PRESSFROMNSCOMS)
(RPAQQ PRESSFROMNSCOMS [(* This file uses CONSTANTS defined in PRESS, so it is necessary to
LOADFROM PRESS before changing this file.)
(FNS \SMASHPRESSFONTS)
(FNS GETCHARPRESSTRANSLATION PRESS.NSARRAY PUTCHARPRESSTRANSLATION)
(FNS \DSPFONT.PRESS \DSPSPACEFACTOR.PRESS \ENTITYSTART.PRESS
\SETSPACE.PRESS \STARTPAGE.PRESS \PRESS.COERCEFONT
\DSPFONT.PRESSFONT SETUPFONTS.PRESS)
(FNS \CREATEPRESSFONT \CREATECHARSET.PRESS \CREATECHARSETZERO.PRESS)
(FNS \PRESSCURVE2)
(COMS (* Generic utility for coercing fonts, could be used by other
devices)
(FNS \COERCEFONT))
(ALISTS (FONTCOERCIONS PRESS)
(MISSINGFONTCOERCIONS PRESS))
(GLOBALVARS FONTCOERCIONS MISSINGFONTCOERCIONS)
(FNS \STRINGWIDTH.PRESS \CHARWIDTH.PRESS \OUTCHARFN.PRESS)
(* * new declaration for PRESSDATA)
(DECLARE%: DONTCOPY (RECORDS PRESSDATA))
(INITRECORDS PRESSDATA)
(* * NSTOASCIITRANSLATIONS is a list with elements of the form
(charset translationArrayName)
%, where translationArrayName is bound to a translation array for
charset which contains (fontFamily charcode)
lists)
(FNS \NSTOASCIIARRAY \NSTOASCIITRANSLATION)
(GLOBALVARS NSTOASCIITRANSLATIONS PRESSFONTFAMILIES)
[INITVARS (PRESSFONTFAMILIES '((GACHA)
(TIMESROMAN)
(HELVETICA)
(SYMBOL)
(MATH)
(HIPPO)
(CYRILLIC)
(NEWVEC)
(SNEWVEC)
(HNEWVEC)
(VNEWVEC]
(INITVARS (NSTOASCIITRANSLATIONS))
(ADDVARS (NSTOASCIITRANSLATIONS (0 ASCIIFROM0ARRAY)
(38 ASCIIFROM38ARRAY)
(39 ASCIIFROM39ARRAY)
(239 ASCIIFROM239ARRAY)))
(UGLYVARS ASCIIFROM0ARRAY ASCIIFROM38ARRAY ASCIIFROM39ARRAY
ASCIIFROM239ARRAY)
(P (\SMASHPRESSFONTS))
(DECLARE%: DONTCOPY (CONSTANTS (unknownCharTranslation
'(MATH 59])
(* This file uses CONSTANTS defined in PRESS, so it is necessary to LOADFROM PRESS before changing
this file.)
(DEFINEQ
(\SMASHPRESSFONTS
[LAMBDA NIL (* ; "Edited 29-Feb-88 10:21 by thh:")
(* ;; "Executed after all patchfns have been loaded, coerces existing Koto press fonts into NS-type press fonts")
(for F in (FONTSAVAILABLE '* '* '* '* 'PRESS) do (\CREATECHARSET 0 (FONTCREATE F])
)
(DEFINEQ
(GETCHARPRESSTRANSLATION
[LAMBDA (CHARCODE FONT) (* thh%: "28-Feb-86 12:03")
(* returns the Press translation for a character in a font)
(COND
((OR (CHARCODEP CHARCODE)
(EQ CHARCODE 256))
(* bitmap for char 256 is what gets printed if char not found)
)
((OR (STRINGP CHARCODE)
(LITATOM CHARCODE))
(SETQ CHARCODE (CHCON1 CHARCODE)))
(T (\ILLEGAL.ARG CHARCODE)))
(LET [TR CSINFO (FONTDESC (\GETFONTDESC FONT 'PRESS]
(* fetch the csinfo for the character set of this character.)
(SETQ CSINFO (\GETCHARSETINFO (\CHARSET CHARCODE)
FONTDESC))
(SETQ TR (\GETBASEPTR (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO)
(UNFOLD (\CHAR8CODE CHARCODE)
2))) (* Return a copy)
(LIST (CAR TR)
(CDR TR])
(PRESS.NSARRAY
[LAMBDA (CHARSET FAMILY ASCIIARRAY) (* thh%: "28-Feb-86 12:08")
(* using info in ASCIIARRAY or ASCIITONSTRANSLATIONS, creates an array of
(pressFont charcode) lists)
(LET* ((min (TIMES 256 CHARSET))
(max (PLUS min 255))
(array (ARRAY 256 NIL NIL 0)))
[for item in (COND
[ASCIIARRAY `((%, FAMILY ASCIIARRAY]
(T ASCIITONSTRANSLATIONS)) bind asciiArray
do
(* * item is of the form (PressFont TranslationArray NSFont))
(SETQ asciiArray (EVAL (CADR item)))
(COND
(asciiArray (for i from 0 to 255
do (SETA array (REMAINDER (ELT asciiArray i)
256)
(LIST (CAR item)
i))
when (AND (LEQ min (ELT asciiArray i))
(LEQ (ELT asciiArray i)
max]
array])
(PUTCHARPRESSTRANSLATION
[LAMBDA (CHARCODE FONT NEWTRANSLATION) (* ; "Edited 29-Feb-88 10:28 by thh:")
(* ;
"Changes the Press translation for a character in a font")
(COND
((CHARCODEP CHARCODE))
((OR (STRINGP CHARCODE)
(LITATOM CHARCODE))
(SETQ CHARCODE (CHCON1 CHARCODE)))
(T (\ILLEGAL.ARG CHARCODE)))
(PROG* ((FONTDESC (\GETFONTDESC FONT 'PRESS))
(CSINFO (\GETCHARSETINFO (\CHARSET CHARCODE)
FONTDESC))
(CHAR8CODE (\CHAR8CODE CHARCODE))
(TR (\NSTOASCIITRANSLATION NEWTRANSLATION NIL FONTDESC)))
(UNINTERRUPTABLY
(\RPLPTR (ffetch (CHARSETINFO CHARSETBITMAP) of CSINFO)
(UNFOLD CHAR8CODE 2)
TR)
(\PUTBASE (ffetch (CHARSETINFO WIDTHS) of CSINFO)
CHAR8CODE
(\FGETCHARWIDTH (CAR TR)
(CDR TR)))
[change (ffetch CHARSETASCENT of CSINFO)
(MAX DATUM (ffetch \SFAscent of (CAR TR]
[change (ffetch CHARSETDESCENT of CSINFO)
(MAX DATUM (ffetch \SFDescent of (CAR TR]
[freplace \SFHeight of FONTDESC
with (PLUS (change (ffetch \SFAscent of FONTDESC)
(MAX DATUM (ffetch CHARSETASCENT of CSINFO)))
(change (ffetch \SFDescent of FONTDESC)
(MAX DATUM (ffetch CHARSETDESCENT of CSINFO])
(RETURN NEWTRANSLATION])
)
(DEFINEQ
(\DSPFONT.PRESS
[LAMBDA (PRSTREAM FONT) (* rmk%: "25-Feb-86 11:05")
(* * The DSPFONT method for PRESS-type image streams --
change the stream's current logical font to FONT;
the device font changes only when we print a character)
(PROG (OLDFONT FDENTRY (PRDATA (ffetch IMAGEDATA of PRSTREAM)))
(SETQ OLDFONT (ffetch PRLOGICALFONT of PRDATA))
(COND
([OR (NULL FONT)
(EQ OLDFONT (SETQ FONT (OR (\GETFONTDESC FONT 'PRESS T)
(FONTCOPY OLDFONT FONT]
(RETURN OLDFONT)))
(freplace PRLOGICALFONT of PRDATA with FONT)
(freplace PRLOGICALCHARSET of PRDATA with NIL)
[\SETSPACE.PRESS PRSTREAM (FIXR (TIMES (ffetch PRSPACEFACTOR of PRDATA)
(\FGETCHARWIDTH FONT (CHARCODE SPACE]
[freplace PRLINEFEED of PRDATA with (IDIFFERENCE (CONSTANT (IMINUS
MicasPerPoint
))
(FONTPROP FONT 'HEIGHT]
(\FIXLINELENGTH.PRESS PRSTREAM)
(RETURN OLDFONT])
(\DSPSPACEFACTOR.PRESS
[LAMBDA (STREAM FACTOR) (* rmk%: "24-Feb-86 09:49")
(LET ((PRDATA (ffetch IMAGEDATA of STREAM)))
(PROG1 (ffetch PRSPACEFACTOR of PRDATA)
(COND
(FACTOR (SHOW.PRESS STREAM)
(freplace PRSPACEFACTOR of PRDATA with FACTOR)
(\SETSPACE.PRESS STREAM (FIXR (TIMES FACTOR
(\FGETCHARWIDTH (ffetch
PRLOGICALFONT
of PRDATA)
(CHARCODE SPACE])
(\ENTITYSTART.PRESS
[LAMBDA (PRSTREAM) (* thh%: "10-Dec-86 08:33")
(PROG ((PRDATA (fetch IMAGEDATA of PRSTREAM)))
(freplace PRSPACEWIDTH of PRDATA with NIL)
(* This really should be the spacewidth of the current font.
But then, if we switch fonts to one whose space*spacefactor comes out the
same, we won't know to put out a setspace command.
So when we actually set up the first font in this entity, we will end up
putting out an explicit setspace (even if the space factor is 1))
(freplace PRFONT of PRDATA with NIL)
(freplace PRLOGICALFONT of PRDATA with NIL)
(* We set the font to NIL, knowing that the current font can be recoverd from
the PRCURRFDE. This font will be set in the press file before the first show,
if no explicit dspfont intervenes. Note, however, that up until the first
dspfont, the widthscache still corresponds to what was the PRLOGICALFONT)
(freplace DLSTARTBYTE of PRDATA with (\GETFILEPTR PRSTREAM))
(freplace ELSTARTBYTE of PRDATA with (\GETFILEPTR (fetch ELSTREAM
of PRDATA)))
(freplace STARTCHARBYTE of PRDATA with (\GETFILEPTR PRSTREAM))
(* Entity starts with position at 0,0 so must re-establish current position
(?))
(SETXY.PRESS PRSTREAM (fetch PRXPOS of PRDATA)
(fetch PRYPOS of PRDATA])
(\SETSPACE.PRESS
[LAMBDA (PRSTREAM S) (* rmk%: "31-Mar-86 16:08")
(PROG (ELSTREAM (PRDATA (fetch IMAGEDATA of PRSTREAM)))
(AND (EQ S (ffetch PRSPACEWIDTH of PRDATA))
(RETURN))
(SHOW.PRESS PRSTREAM)
(SETQ ELSTREAM (fetch ELSTREAM of (fetch IMAGEDATA of PRSTREAM)))
(if (ILEQ S 2047)
then (\WOUT ELSTREAM (IPLUS (LLSH SetSpaceXShortCode 8)
S))
else (\BOUT ELSTREAM SetSpaceXCode)
(\WOUT ELSTREAM S))
(freplace PRSPACEWIDTH of PRDATA with S])
(\STARTPAGE.PRESS
[LAMBDA (PRSTREAM) (* rmk%: "25-Feb-86 11:36")
(* Should be called only when no previous page is open)
(PROG (CFONT HFONT SPACEFACTOR (PRDATA (ffetch IMAGEDATA of PRSTREAM)))
(SETQ CFONT (ffetch PRLOGICALFONT of PRDATA))
(* Save current font so that \ENTITYSTART.PRESS can make PRLOGICALFONT be
NIL, indicating that there is no actual font at the beginning of a page)
(\ENTITYSTART.PRESS PRSTREAM)
[COND
((ffetch PRHEADING of PRDATA)
(SETQ SPACEFACTOR (ffetch PRSPACEFACTOR of PRDATA))
(freplace PRSPACEFACTOR of PRDATA with 1)
(SETQ HFONT (ffetch PRHEADINGFONT of PRDATA))
(\DSPFONT.PRESS PRSTREAM HFONT) (* Set up heading font)
[SETXY.PRESS PRSTREAM (ffetch PRLEFT of PRDATA)
(IDIFFERENCE (ffetch PRTOP of PRDATA)
(FONTPROP HFONT 'ASCENT]
(PRIN3 (ffetch PRHEADING of PRDATA)
PRSTREAM) (* Skip an inch before page number)
(SHOW.PRESS PRSTREAM)
(SETX.PRESS PRSTREAM (IPLUS MICASPERINCH (ffetch PRXPOS of PRDATA)))
(PRIN3 "Page " PRSTREAM)
(PRIN3 (add (ffetch PRPAGENUM of PRDATA)
1)
PRSTREAM)
(NEWLINE.PRESS PRSTREAM) (* Skip 2 lines)
(NEWLINE.PRESS PRSTREAM)
(freplace PRSPACEFACTOR of PRDATA with SPACEFACTOR))
(T (SETXY.PRESS PRSTREAM (ffetch PRLEFT of PRDATA)
(IDIFFERENCE (ffetch PRTOP of PRDATA)
(FONTPROP CFONT 'ASCENT]
(* Now we set the font to our (previous) current font)
(\DSPFONT.PRESS PRSTREAM CFONT])
(\PRESS.COERCEFONT
[LAMBDA (FONT FAMILY) (* rmk%: "25-Mar-86 15:44")
(* coerces FONT to be new FAMILY FAMILY, and caches result on
\PRESS.COERCEDFONTS)
(DECLARE (GLOBALVARS \PRESS.COERCEDFONTS))
(COND
[[OR (NOT FAMILY)
(EQ FAMILY (FONTPROP FONT 'FAMILY]
(* Don't call FONTCOPY if it's the same font.
This avoids circularity thru AVGCHARWIDTH and CHARWIDTH before the font has
been stored in \FONTSINCORE.)
(COND
((EQ 'PRESS (FONTPROP FONT 'DEVICE)) (* How could it not be PRESS? Ask
Tad.)
FONT)
(T (FONTCOPY FONT 'DEVICE 'PRESS]
((OR (FONTP FAMILY)
(LISTP FAMILY)) (* FAMILY is a font specification)
(FONTCOPY FAMILY 'DEVICE 'PRESS))
[(FONTP (CADR (ASSOC FONT (CDR (ASSOC FAMILY \PRESS.COERCEDFONTS]
(T (LET [(pressFont (OR (FONTCOPY FONT 'FAMILY FAMILY 'DEVICE 'PRESS 'NOERROR T)
(FONTCOPY FONT 'FAMILY FAMILY 'FACE 'STANDARD 'DEVICE 'PRESS]
(push [CDR (OR (ASSOC FAMILY \PRESS.COERCEDFONTS)
(CAR (push \PRESS.COERCEDFONTS (CONS FAMILY]
(LIST FONT pressFont))
pressFont])
(\DSPFONT.PRESSFONT
[LAMBDA (PRSTREAM PRFONT) (* thh%: "16-Jun-86 10:50")
(* Changes the Pressfiles device
font)
(PROG (FDENTRY LFONT OLDFONT (PRDATA (ffetch IMAGEDATA of PRSTREAM)))
(SETQ OLDFONT (ffetch PRFONT of PRDATA))
(SHOW.PRESS PRSTREAM)
(SETQ FDENTRY (\DEFINEFONT.PRESS PRSTREAM PRFONT))
(COND
((NEQ (ffetch FONTSET# of FDENTRY)
(ffetch FONTSET# of (ffetch PRCURRFDE of PRDATA)))
(* Swtich font sets)
(* must save and restore current logical font since \ENTITYSTART.PRESS makes
it NIL)
(SETQ LFONT (ffetch PRLOGICALFONT of PRDATA))
(\ENTITYEND.PRESS PRSTREAM)
(\ENTITYSTART.PRESS PRSTREAM)
(\DSPFONT.PRESS PRSTREAM LFONT)))
(freplace PRCURRFDE of PRDATA with FDENTRY)
(freplace PRFONT of PRDATA with PRFONT)
(\BOUT (ffetch ELSTREAM of PRDATA)
(LOGOR FontCode (ffetch FONT# of FDENTRY)))
(RETURN OLDFONT])
(SETUPFONTS.PRESS
[LAMBDA (PRSTREAM FONTS) (* thh%: "10-Dec-86 08:43")
(* creates fonts in the initial fontset.
and sets heading font. Leaves PRFONT as NIL.
This means that \DSPFONT.PRESS of the heading font will establish that as the
current font when the first page opens.)
(* since FONTS are logical, not device, fonts, they are not added to the
fontset here)
(for F FLG inside (OR FONTS DEFAULTFONT)
do (SETQ F (FONTCREATE F NIL NIL NIL 'PRESS))
(COND
(FLG NIL)
(T (\DSPFONT.PRESS PRSTREAM F)
(* Install first font as current logical font and heading font.)
(\ENTITYEND.PRESS PRSTREAM)
(replace PRHEADINGFONT of (fetch IMAGEDATA of PRSTREAM)
with F)
(SETQ FLG T])
)
(DEFINEQ
(\CREATEPRESSFONT
[LAMBDA (FAMILY PSIZE FACE ROTATION DEVICE) (* ; "Edited 9-Mar-88 15:54 by thh:")
(* ;; "Widths array is fully allocated, with zeroes for characters with no information. An array is not allocated for fixed WidthsY. DEVICE is PRESS or INTERPRESS")
(DECLARE (GLOBALVARS PRESSFONTWIDTHSFILES))
(RESETLST (* ;
"RESETLST to make sure the fontfiles get closed")
(PROG ((FD (create FONTDESCRIPTOR
FONTDEVICE _ DEVICE
FONTFAMILY _ FAMILY
FONTSIZE _ PSIZE
FONTFACE _ FACE
\SFFACECODE _ (\FACECODE FACE)
ROTATION _ ROTATION
FONTSCALE _ (CONSTANT (FQUOTIENT 2540 72))
\SFHeight _ 0
\SFAscent _ 0
\SFDescent _ 0)))
(OR (\GETCHARSETINFO 0 FD T)
(RETURN NIL))
(RETURN FD])
(\CREATECHARSET.PRESS
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC)
(* ; "Edited 9-Mar-88 15:19 by thh:")
(* ;;; "determines widths and translations to print the charset with Press fonts. Note that we get widths from widths of font translated to, which should be original press values because translations are always to press fonts.")
(* ;;; "NOTE: This code makes fonts that translate to themselves circular, and also gives fonts high reference counts. The translations should not be circular.")
(DECLARE (GLOBALVARS PRESSFONTFAMILIES))
(PROG ((CSETTRANSLATIONARRAY (\NSTOASCIIARRAY CHARSET))
CSINFO widths (translationArray (ARRAY 256 NIL NIL 0))
(ascent 0)
(descent 0)
CSETZEROTRANSLATIONS)
(* ;; "Determine translations for this charset")
[COND
[(ZEROP CHARSET)
(* ;; "set up charsetinfo -- includes any coercions to known press fonts")
(SETQ CSINFO (\CREATECHARSETZERO.PRESS FAMILY SIZE FACE ROTATION DEVICE FONTDESC))
(OR CSINFO (RETURN NIL)) (* ;
"unable to coerce to a press font")
(* ;; "get translations for charset-0")
(COND
[(SETQ CSETZEROTRANSLATIONS (ASSOC (FONTPROP FONTDESC 'FAMILY)
PRESSFONTFAMILIES))
(* ; "use identity transformation")
(for i from 0 to 255 do (SETA translationArray i (CONS FONTDESC i))
) (* ;
"except for font-specific non-identities")
(for X in (CDR CSETZEROTRANSLATIONS)
do (SETA translationArray (CAR X)
(\NSTOASCIITRANSLATION (CADR X)
FAMILY FONTDESC]
(T
(* ;; "Not a press font: assume NS font which will be translated into a press font")
(for i from 0 to 255
do (SETA translationArray i
(\NSTOASCIITRANSLATION
(COND
((AND CSETTRANSLATIONARRAY (ELT CSETTRANSLATIONARRAY i)))
(T (LIST (OR FAMILY (FONTPROP FONTDESC 'FAMILY))
i)))
FAMILY FONTDESC]
(T
(* ;; "CHARSET not zero, assume NS codes")
(for i from 0 to 255 do (SETA translationArray i
(\NSTOASCIITRANSLATION
(AND CSETTRANSLATIONARRAY
(ELT CSETTRANSLATIONARRAY i))
FAMILY FONTDESC]
(* ;; "Set the widths array and install the translations in the CHARSETINFO")
(OR CSINFO (SETQ CSINFO (create CHARSETINFO)))
(SETQ widths (fetch (CHARSETINFO WIDTHS) of CSINFO))
(for i from 0 to 255 bind translation pressFont newAscent newDescent
do (SETQ translation (ELT translationArray i))
(SETQ pressFont (CAR translation))
[COND
((AND (ZEROP CHARSET)
(EQ pressFont FONTDESC)) (* ;
"this is charset-0 font translating to itself, use widths already defined")
(\FSETWIDTH widths i (\FGETWIDTH widths (CDR translation)))
(SETQ newAscent (fetch (CHARSETINFO CHARSETASCENT) of CSINFO))
(SETQ newDescent (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO)))
(T (\FSETWIDTH widths i (\FGETCHARWIDTH pressFont (CDR translation)))
(SETQ newAscent (ffetch (FONTDESCRIPTOR \SFAscent) of pressFont))
(SETQ newDescent (ffetch (FONTDESCRIPTOR \SFDescent) of pressFont]
(SETQ ascent (MAX ascent newAscent))
(SETQ descent (MAX descent newDescent)))
(replace (CHARSETINFO CHARSETBITMAP) of CSINFO with (ffetch (ARRAYP BASE)
of translationArray)
)
(replace (CHARSETINFO CHARSETASCENT) of CSINFO with ascent)
(replace (CHARSETINFO CHARSETDESCENT) of CSINFO with descent)
(RETURN CSINFO])
(\CREATECHARSETZERO.PRESS
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE FD) (* ; "Edited 9-Mar-88 15:27 by thh:")
(* ;;;
"creates CSINFO for charset 0 of press fonts from info in widths file (without translations).")
(DECLARE (GLOBALVARS PRESSFONTWIDTHSFILES FONTCOERCIONS MISSINGFONTCOERCIONS))
(RESETLST (* ;
"RESETLST to make sure the fontfiles get closed")
(PROG* (WSTRM STRMCACHE FIXEDFLAGS RELFLAG FIRSTCHAR LASTCHAR TEM WIDTHSY WIDTHS
(PRESSMICASIZE (IQUOTIENT (ITIMES SIZE 2540)
72))
(NSMICASIZE (FIXR (FQUOTIENT (ITIMES SIZE 2540)
72)))
(FACECODE (\FACECODE FACE))
(CSINFO (create CHARSETINFO))
CHARSETHEIGHT FOO FBBOX)
(* ;;; "Go look for the fonts.widths file that has this font's info in it.")
(OR [bind XLATEDNAME NEWFAMILY NEWNSMICASIZE NEWFACECODE for F inside
PRESSFONTWIDTHSFILES
when (INFILEP F)
first (SETQ XLATEDNAME (\COERCEFONT FAMILY SIZE FACE ROTATION
'PRESS FONTCOERCIONS))
[COND
(XLATEDNAME (SETQ NEWFAMILY (CAR XLATEDNAME))
(SETQ NEWNSMICASIZE (FIXR (FQUOTIENT (ITIMES (CADR
XLATEDNAME
)
2540)
72)))
(SETQ NEWFACECODE (\FACECODE (CADDR XLATEDNAME]
do (* ;
"Look thru the candidate PRESSFONTWIDTHSFILES for a file that has a description for this font.")
[COND
[(SETQ WSTRM (\GETSTREAM F 'INPUT T))
(COND
((RANDACCESSP WSTRM)
(RESETSAVE NIL (LIST 'SETFILEPTR WSTRM (GETFILEPTR WSTRM)))
(SETFILEPTR WSTRM 0]
(T (RESETSAVE (SETQ WSTRM (OPENSTREAM F 'INPUT 'OLD 8))
'(PROGN (CLOSEF? OLDVALUE]
[OR (RANDACCESSP WSTRM)
(COPYBYTES WSTRM (SETQ WSTRM (OPENSTREAM '{NODIRCORE} 'BOTH
'NEW]
(push STRMCACHE WSTRM) (* ; "Save for coercions below")
(COND
((SETQ RELFLAG (\POSITIONFONTFILE WSTRM (OR NEWNSMICASIZE
NSMICASIZE)
FIRSTCHAR LASTCHAR (OR NEWFAMILY FAMILY)
(OR NEWFACECODE FACECODE)))
(* ;
"OK, we found this font described in this file.")
(COND
(XLATEDNAME (replace FONTDEVICESPEC of FD with
XLATEDNAME)
(SETQ NSMICASIZE NEWNSMICASIZE)))
(RETURN T]
[bind XLATEDNAME NEWFAMILY NEWNSMICASIZE NEWFACECODE XLATEDNAMES
first (SETQ STRMCACHE (DREVERSE STRMCACHE))
while (SETQ XLATEDNAME (\COERCEFONT FAMILY SIZE FACE ROTATION
'PRESS MISSINGFONTCOERCIONS XLATEDNAMES))
thereis (push XLATEDNAMES XLATEDNAME)
(for old WSTRM in STRMCACHE
first (SETQ NEWFAMILY (CAR XLATEDNAME))
(SETQ NEWNSMICASIZE (FIXR (FQUOTIENT (ITIMES (CADR XLATEDNAME
)
2540)
72)))
(SETQ NEWFACECODE (\FACECODE (CADDR XLATEDNAME)))
do (* ;
"Now try coercing the family name")
(* ;; "We know the file was left open and is randaccessp from the previous loop, which must have run off the end of the file list")
(SETFILEPTR WSTRM 0)
(COND
((SETQ RELFLAG (\POSITIONFONTFILE WSTRM NEWNSMICASIZE
FIRSTCHAR LASTCHAR NEWFAMILY
NEWFACECODE))
(replace FONTDEVICESPEC of FD with XLATEDNAME
)
(SETQ NSMICASIZE NEWNSMICASIZE)
(RETURN T]
(RETURN NIL))
(* ;;; "Having found the font-widths file, now read the width info from it.")
(SETQ RELFLAG (ZEROP RELFLAG)) (* ;
"Actually, \POSITIONFONTFILE returns zero if the font metrics are size-relative and must be scaled.")
(SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
(SETFILEPTR WSTRM (UNFOLD (\FIXPIN WSTRM)
BYTESPERWORD))
(* ;; "Read the location of the WD segment for this font (we're in the directory part of the file now), and go there.")
(SETQ FBBOX (SIGNED (\WIN WSTRM)
BITSPERWORD)) (* ;
"replace (FONTDESCRIPTOR FBBOX) of FD with (SIGNED (\WIN WSTRM) BITSPERWORD)")
(* ;
"Get the max bounding width for the font")
(replace (CHARSETINFO CHARSETDESCENT) of CSINFO
with (IMINUS (SIGNED (\WIN WSTRM)
BITSPERWORD))) (* ; "Descent is -FBBOY")
(SETQ FOO (\WIN WSTRM)) (* ;
"replace (FONTDESCRIPTOR FBBDX) of FD with (SIGNED (\WIN WSTRM) BITSPERWORD)")
(* ; "And the standard kern value (?)")
(SETQ CHARSETHEIGHT (SIGNED (\WIN WSTRM)
BITSPERWORD)) (* ;
"replace \SFHeight of FD with (SIGNED (\WIN WSTRM) BITSPERWORD)")
(* ; "Height is FBBDY")
[COND
(RELFLAG (* ;
"Dimensions are relative, must be scaled")
(* ;; "replace (FONTDESCRIPTOR FBBOX) of FD with (IQUOTIENT (ITIMES (fetch (FONTDESCRIPTOR FBBOX) of FD) NSMICASIZE) 1000)")
(replace (CHARSETINFO CHARSETDESCENT) of CSINFO
with (IQUOTIENT (ITIMES (fetch (CHARSETINFO CHARSETDESCENT)
of CSINFO)
NSMICASIZE)
1000))
(* ;; "replace (FONTDESCRIPTOR FBBDX) of FD with (IQUOTIENT (ITIMES (fetch (FONTDESCRIPTOR FBBDX) of FD) NSMICASIZE) 1000)")
(SETQ CHARSETHEIGHT (IQUOTIENT (ITIMES CHARSETHEIGHT NSMICASIZE)
1000]
(replace (CHARSETINFO CHARSETASCENT) of CSINFO
with (IDIFFERENCE CHARSETHEIGHT (fetch CHARSETDESCENT of CSINFO)))
(SETQ FIXEDFLAGS (LRSH (\BIN WSTRM)
6)) (* ; "The fixed flags")
(\BIN WSTRM) (* ; "Skip the spares")
[COND
((EQ 2 (LOGAND FIXEDFLAGS 2)) (* ; "This font is fixed width.")
(SETQ TEM (\WIN WSTRM)) (* ;
"Read the fixed width for this font")
[COND
((AND RELFLAG (NOT (ZEROP TEM))) (* ;
"If it's size relative, scale it.")
(SETQ TEM (IQUOTIENT (ITIMES TEM NSMICASIZE)
1000]
(for I from FIRSTCHAR to LASTCHAR
do (* ;
"Fill in the char widths table with the width.")
(\FSETWIDTH WIDTHS I TEM)))
(T (* ;
"Variable width font, so we have to read widths.")
(* ;
"AIN WIDTHS FIRSTCHAR (ADD1 (IDIFFERENCE LASTCHAR FIRSTCHAR)) WSTRM")
(for I from FIRSTCHAR to LASTCHAR
do (\FSETWIDTH WIDTHS I noInfoCode))
(\BINS (\GETOFD WSTRM 'INPUT)
WIDTHS
(UNFOLD FIRSTCHAR BYTESPERWORD)
(UNFOLD (ADD1 (IDIFFERENCE LASTCHAR FIRSTCHAR))
BYTESPERWORD)) (* ; "Read the X widths.")
(for I from FIRSTCHAR to LASTCHAR
when (EQ noInfoCode (\FGETWIDTH WIDTHS I))
do (* ;
"For chars that have no width info, let width be zero.")
(\FSETWIDTH WIDTHS I 0))
(COND
(RELFLAG (* ;
"If the widths are size-relative, scale them.")
(for I from FIRSTCHAR to LASTCHAR
do (\FSETWIDTH WIDTHS I (IQUOTIENT (ITIMES (\FGETWIDTH
WIDTHS I)
NSMICASIZE)
1000]
[COND
[(EQ 1 (LOGAND FIXEDFLAGS 1))
(COND
((ILESSP (GETFILEPTR WSTRM)
(GETEOFPTR WSTRM))
(SETQ WIDTHSY (\WIN WSTRM)))
(T (* ;
"STAR FONT FILES LIKE TO LEAVE OFF THE Y WIDTH.")
(SETQ WIDTHSY 0))) (* ;
"The fixed width-Y for this font; the width-Y field is a single integer in the FD")
(replace (CHARSETINFO YWIDTHS) of CSINFO
with (COND
((AND RELFLAG (NOT (ZEROP WIDTHSY)))
(IQUOTIENT (ITIMES WIDTHSY NSMICASIZE)
1000))
(T WIDTHSY]
(T (* ;
"Variable Y-width font. Fill it in as above")
(SETQ WIDTHSY (replace (CHARSETINFO YWIDTHS) of CSINFO with
(
\CREATECSINFOELEMENT
)))
(for I from FIRSTCHAR to LASTCHAR
do (\FSETWIDTH WIDTHSY I noInfoCode))
(\BINS (\GETOFD WSTRM 'INPUT)
WIDTHSY
(UNFOLD FIRSTCHAR BYTESPERWORD)
(UNFOLD (ADD1 (IDIFFERENCE LASTCHAR FIRSTCHAR))
BYTESPERWORD)) (* ; "Read the Y widths")
(for I from FIRSTCHAR to LASTCHAR
when (EQ noInfoCode (\FGETWIDTH WIDTHSY I))
do (* ;
"Let any characters with no width info be zero height")
(\FSETWIDTH WIDTHSY I 0))
(COND
(RELFLAG (* ;
"If the widths are size-relative, scale them.")
(for I from FIRSTCHAR to LASTCHAR
do (\FSETWIDTH WIDTHSY I (IQUOTIENT (ITIMES (\FGETWIDTH
WIDTHSY I)
NSMICASIZE)
1000]
(RETURN CSINFO])
)
(DEFINEQ
(\PRESSCURVE2
[LAMBDA (PRSTREAM SPLINE DASHING BRUSHFONT) (* thh%: "16-Jun-86 10:53")
(* Given a spline curve and a font, draw the lines to PRSTREAM)
(RESETLST (RESETSAVE NIL (LIST '\DSPFONT.PRESSFONT PRSTREAM (\DSPFONT.PRESSFONT PRSTREAM
BRUSHFONT)))
[PROG ((PRDATA (fetch IMAGEDATA of PRSTREAM)))
(COND
((IGREATERP (IDIFFERENCE (GETFILEPTR (fetch ELSTREAM of PRDATA))
(fetch ELSTARTBYTE of PRDATA))
25000)
(\ENTITYEND.PRESS PRSTREAM) (* Hack to prevent mysterious
overflow in length of entities)
(\ENTITYSTART.PRESS PRSTREAM]
(\BOUT (fetch ELSTREAM of (fetch IMAGEDATA of PRSTREAM))
ResetSpaceCode)
(* because the space code shouldn't be interpreted specially when we are
drawing in the vector font)
(PROG ((XPOLY (create POLYNOMIAL))
(X'POLY (create POLYNOMIAL))
(YPOLY (create POLYNOMIAL))
(Y'POLY (create POLYNOMIAL))
(X (fetch (SPLINE SPLINEX) of SPLINE))
(Y (fetch (SPLINE SPLINEY) of SPLINE))
(X' (fetch (SPLINE SPLINEDX) of SPLINE))
(Y' (fetch (SPLINE SPLINEDY) of SPLINE))
(X'' (fetch (SPLINE SPLINEDDX) of SPLINE))
(Y'' (fetch (SPLINE SPLINEDDY) of SPLINE))
(X''' (fetch (SPLINE SPLINEDDDX) of SPLINE))
(Y''' (fetch (SPLINE SPLINEDDDY) of SPLINE))
(%#KNOTS (fetch %#KNOTS of SPLINE))
(X0 (ELT (fetch (SPLINE SPLINEX) of SPLINE)
1))
(Y0 (ELT (fetch (SPLINE SPLINEY) of SPLINE)
1))
IX IY DX DY XT YT X'T Y'T NEWXT NEWYT XDIFF YDIFF XWALLDT YWALLDT DUPLICATEKNOT
EXTRANEOUS TT NEWT DELTA DASHON DASHLST DASHCNT HALFVECWIDTH PUTDX EXTRADX PUTDY
EXTRADY)
(SETQ HALFVECWIDTH (FONTPROP BRUSHFONT 'SIZE))
(* Half the width of the brush, in dots.
Used to help decide when the line we're drawing goes off-paper.)
(SETQ DASHON T)
(* These are initialized outside the prog-bindings cause the compiler can't
hack so many initialized variables)
(SETQ DASHLST DASHING)
(SETQ DASHCNT (CAR DASHING))
(SETXY.PRESS PRSTREAM (FIXR (FTIMES X0 MicasPerScan))
(FIXR (FTIMES Y0 MicasPerScan))) (* Move to the first knot on the
curve)
(replace VECMOVINGRIGHT of (fetch IMAGEDATA of PRSTREAM)
with T) (* Start by assuming we're moving in
increasing X (since the vector fonts
only have strokes that work in that
direction))
(replace VECWASDISPLAYING of (fetch IMAGEDATA of PRSTREAM)
with (AND (GEQ X0 0)
(GEQ Y0 0)))
(replace VECSEGCHARS of (fetch IMAGEDATA of PRSTREAM) with
NIL)
(replace VECCURX of (fetch IMAGEDATA of PRSTREAM) with X0)
(* And set the current X and Y positions, denominated in dover spots)
(replace VECCURY of (fetch IMAGEDATA of PRSTREAM) with Y0)
(* Set up initial values in vec
variables, perform SetX/SetY.)
(SETQ TT 0.0)
(SETQ DELTA 16)
(SETQ IX (FIXR X0))
(SETQ IY (FIXR Y0))
[for KNOT# from 1 to (SUB1 %#KNOTS)
do (LOADPOLY XPOLY X'POLY (ELT X''' KNOT#)
(ELT X'' KNOT#)
(ELT X' KNOT#)
(ELT X KNOT#))
(* Set up the polynomials that describe X and X' over this segment)
(LOADPOLY YPOLY Y'POLY (ELT Y''' KNOT#)
(ELT Y'' KNOT#)
(ELT Y' KNOT#)
(ELT Y KNOT#))
(* Set up the polynomials that describe Y and Y' over this segment)
(SETQ XT (POLYEVAL TT XPOLY 3)) (* XT _ X (t) --Evaluate the next
point)
(SETQ YT (POLYEVAL TT YPOLY 3)) (* YT _ Y (t))
(COND
[(NOT (IEQP KNOT# (SUB1 %#KNOTS)))
(* This isn't the last knot. Check to see if the next knot in line is a
duplicated knot.)
(SETQ DUPLICATEKNOT (AND (EQP (ELT X (ADD1 KNOT#))
(ELT X (IPLUS KNOT# 2)))
(EQP (ELT Y (ADD1 KNOT#))
(ELT Y (IPLUS KNOT# 2]
(T (SETQ DUPLICATEKNOT NIL)))
[until (GEQ TT 1.0)
do
(* Run the parameter, TT, from 0.0 up to |1.0.|
That moves the X and Y locations smoothly from this knot to the next one.)
(SETQ X'T (POLYEVAL TT X'POLY 2))
(* X'T _ X' (t))
(SETQ Y'T (POLYEVAL TT Y'POLY 2))
(* Y'T _ Y' (t))
(COND
((EQP X'T 0.0)
(* Never let X' really get to 0.0 -- things become ill-conditioned there.)
(SETQ X'T 5.0E-4)))
(COND
((EQP Y'T 0.0) (* Likewise Y'.)
(SETQ Y'T 5.0E-4)))
[COND
((FGTP X'T 0.0)
(* If X' is positive, we'll try moving in the +X direction)
(SETQ DX DELTA))
(T (* If not, we'll try the -X
direction.)
(SETQ DX (IMINUS DELTA]
[COND
((FGTP Y'T 0.0)
(* Likewise, if Y' is positive, try moving by DELTA in the +Y direction)
(SETQ DY DELTA))
(T (SETQ DY (IMINUS DELTA]
(SETQ XWALLDT (FQUOTIENT (FDIFFERENCE (IPLUS IX DX)
XT)
X'T))
(* Compute a dT, based on moving by DELTA in X.)
(SETQ YWALLDT (FQUOTIENT (FDIFFERENCE (IPLUS IY DY)
YT)
Y'T))
(* And a dT based on moving by DELTA in Y.)
[COND
((FLESSP XWALLDT YWALLDT)
(* Use the smaller of the two dT's. In this case, dT for X was smaller, so
compute a new DY as depending on DX.)
(SETQ NEWT (FPLUS TT XWALLDT))
(SETQ DY (IDIFFERENCE (FIXR (FPLUS YT (FTIMES XWALLDT Y'T)))
IY)))
(T
(* Changing Y gave the smaller dT. Compute a new DX, as though it depended on
DY.)
(SETQ NEWT (FPLUS TT YWALLDT))
(SETQ DX (IDIFFERENCE (FIXR (FPLUS XT (FTIMES YWALLDT X'T)))
IX]
(SETQ PUTDX DX)
(SETQ EXTRADX 0)
(SETQ PUTDY DY)
(SETQ EXTRADY 0)
[COND
((IGREATERP DX 16)
(SETQ PUTDX 16)
(SETQ EXTRADX (IDIFFERENCE DX 16]
[COND
((IGREATERP -16 DX)
(SETQ PUTDX -16)
(SETQ EXTRADX (IPLUS DX 16]
[COND
((IGREATERP DY 16)
(SETQ PUTDY 16)
(SETQ EXTRADY (IDIFFERENCE DY 16]
[COND
((IGREATERP -16 DY)
(SETQ PUTDY -16)
(SETQ EXTRADY (IPLUS DY 16]
(COND
([AND (FGTP NEWT 1.0)
(OR DUPLICATEKNOT (EQ KNOT# (SUB1 %#KNOTS]
(SETQ NEWT 1.0)))
(SETQ NEWXT (POLYEVAL NEWT XPOLY 3))
(* New XT _ X (new t))
(SETQ NEWYT (POLYEVAL NEWT YPOLY 3))
(* New YT _ Y (new t))
(SETQ XDIFF (ABS (FDIFFERENCE (IPLUS IX DX)
NEWXT)))
(SETQ YDIFF (ABS (FDIFFERENCE (IPLUS IY DY)
NEWYT)))
(COND
((AND (IGREATERP DELTA 1)
(OR (FGTP XDIFF 1.0)
(FGTP YDIFF 1.0)))
(* If we're more than a dover spot off where we'd expect to be because of the
size of DELTA--and if there's room to make DELTA smaller--then try
DELTA_DELTA/2)
(SETQ DELTA (LRSH DELTA 1)))
(T
(* No, this estimate is close enough. Put out a vector segment based on it,
and move to the new TT.)
(\VECPUT PRSTREAM PUTDX PUTDY HALFVECWIDTH)
(* Print out a stroke using the
vector font.)
(COND
((OR (NEQ EXTRADX 0)
(NEQ EXTRADY 0))
(* If, actually, it was too big for one stroke, use another.)
(\VECPUT PRSTREAM EXTRADX EXTRADY HALFVECWIDTH)))
(SETQ IX (IPLUS IX DX))
(* Our new current location, in
Dover spots)
(SETQ IY (IPLUS IY DY))
(SETQ TT NEWT) (* Set TT to its new value)
(SETQ XT NEWXT)
(* And set the new floating-point values for X
(t) and Y (t)%.)
(SETQ YT NEWYT)
(COND
((AND (ILESSP DELTA 16)
(OR (FLESSP XDIFF 0.5)
(FLESSP YDIFF 0.5)))
(* If we were especially close, try making DELTA larger for the next go
round.)
(SETQ DELTA (LLSH DELTA 1]
(SETQ TT (FDIFFERENCE TT 1.0))
(* Having moved past a knot, back the value of the parameter TT back down.
However, don't set it to 0.0--let's try to keep the line going from where it
got to in passing the last knot.)
(COND
(DUPLICATEKNOT
(* This next knot is a duplicate. Skip over it, and start from the following
knot. This will avoid odd problems trying to go nowhere while obeying the
constraints of X' and Y' at that knot--since it's a duplicate, X' and Y' are
discontinuous there.)
(add KNOT# 1]
(\ENDVECRUN PRSTREAM HALFVECWIDTH])
)
(* Generic utility for coercing fonts, could be used by other devices)
(DEFINEQ
(\COERCEFONT
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE COERCELIST BUTNOT CREATEFLG)
(* ; "Edited 9-Mar-88 12:58 by thh:")
(* ;; "Returns a font name that the requested font specification coerces to according to COERCELIST. If CREATEFLG is T, only returns name-lists for which a font descriptor has been created. BUTNOT can be a list of font-specs which are not an acceptable coercion--e.g. a previous one that failed, so we want to keep looking beyond that one.")
(* ;;; "NOSLUG? means don't create an empty (slug) csinfo if the charset is not found, just return NIL (probably only useful for display fonts)")
(* ;; "COERCELIST is an alist of font coercions indexed by device, with the value for each device being a list of the form ((user-font real-font) (user-font real-font) ...) --- Each user-font is either simply a family name, or a list of FAMILY, and optionally SIZE, and FACE, in standard font-name order. Any of these can be NIL, meaning that any requested value matches. In addition, the SIZE can be either a specific number, or a constraint of the form (< n) or (> n), which matches requested sizes that are less than or greater than the constraint size n. --- The real-font is a similar family-name or list, except that a NIL field here means that the requested parameter is simply carried over. Also, no size constraints, only explicit sizes, are allowed. (e.g., (GACHA) or (GACHA (< 10)) or (GACHA 10))")
(for TRANSL in (CDR (ASSOC DEVICE COERCELIST)) bind NEWCSINFO USERSPEC REALSPEC
FAMCONSTRAINT SIZECONSTRAINT
FACECONSTRAINT NEWFONTNAME
when (AND (SETQ USERSPEC (CAR TRANSL))
(OR [NULL (SETQ FAMCONSTRAINT (COND
((LISTP USERSPEC)
(pop USERSPEC))
(T (PROG1 USERSPEC (SETQ USERSPEC NIL]
(EQ FAMILY FAMCONSTRAINT))
(OR (NOT (SETQ SIZECONSTRAINT (pop USERSPEC)))
(EQ SIZE SIZECONSTRAINT)
(AND (LISTP SIZECONSTRAINT)
(SELECTQ (CAR SIZECONSTRAINT)
(< (LESSP SIZE (CADR SIZECONSTRAINT)))
(> (GREATERP SIZE (CADR SIZECONSTRAINT)))
NIL)))
(OR (NOT (SETQ FACECONSTRAINT (pop USERSPEC)))
(EQUAL FACE FACECONSTRAINT))
(SETQ REALSPEC (CADR TRANSL))
(SETQ NEWFONTNAME (LIST (OR [COND
((LISTP REALSPEC)
(pop REALSPEC))
(T (PROG1 REALSPEC (SETQ REALSPEC NIL]
FAMILY)
(OR (pop REALSPEC)
SIZE)
(\FONTFACE (OR (pop REALSPEC)
FACE))
ROTATION DEVICE))
(NOT (for EXCLUDE in BUTNOT thereis (EQUAL EXCLUDE NEWFONTNAME)))
(OR (NULL CREATEFLG)
(FONTCREATE NEWFONTNAME NIL NIL NIL NIL T))) do (RETURN NEWFONTNAME])
)