(FILECREATED " 3-Dec-84 18:43:33" {ERIS}<LISPNEW>PATCHES>AFONTPATCH.;2 8244
changes to: (FNS \CREATESTARFONT)
previous date: " 3-Dec-84 15:20:20" {ERIS}<LISPNEW>PATCHES>AFONTPATCH.;1)
(* Copyright (c) 1984 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT AFONTPATCHCOMS)
(RPAQQ AFONTPATCHCOMS ((FNS \CREATESTARFONT)))
(DEFINEQ
(\CREATESTARFONT
[LAMBDA (FAMILY PSIZE FACE ROTATION DEVICE CHARSET) (* rmk: " 3-Dec-84 18:28")
(* Build the font descriptor for an Interpress NS font.
If we can't find widths info for that font, return NIL)
(* 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 INTERPRESSFONTDIRECTORIES \ASCIITONS))
(RESETLST (* RESETLST to make sure the fontfiles get closed)
(PROG (WFILE WSTRM FIXEDFLAGS RELFLAG FIRSTCHAR LASTCHAR TEM WIDTHSY
(WIDTHS (ARRAY (ADD1 \MAXCHAR)
(QUOTE SMALLPOSP)
0 0))
(NSMICASIZE (FIXR (FQUOTIENT (ITIMES PSIZE 2540)
72)))
(FD (create FONTDESCRIPTOR
FONTDEVICE ← DEVICE
FONTFAMILY ← FAMILY
FONTSIZE ← PSIZE
FONTFACE ← FACE
\SFFACECODE ←(\FACECODE FACE)
ROTATION ← ROTATION
OTHERDEVICEFONTPROPS ← \ASCIITONS)))
(COND
((SETQ WFILE (FINDFILE (\FONTFILENAME FAMILY PSIZE FACE (QUOTE WD)
CHARSET)
T INTERPRESSFONTDIRECTORIES))
(* Look thru INTERPRESSFONTDIRECTORIES for a .WD file
that describes the font requested.
Only continue if we can find one.)
[RESETSAVE (SETQ WSTRM (OPENSTREAM WFILE (QUOTE INPUT)
(QUOTE OLD)))
(QUOTE (PROGN (CLOSEF? OLDVALUE]
[COND
((RANDACCESSP WSTRM)
(SETFILEPTR WSTRM 0))
(T (COPYBYTES WSTRM (SETQ WSTRM (OPENSTREAM (QUOTE {NODIRCORE})
(QUOTE BOTH)
(QUOTE NEW]
(SETQ RELFLAG (\FINDFONT FD WSTRM NSMICASIZE NIL T))
(* Fill in the widths, and return a flag telling
whether the widths are absolute, or are type-size
relative. 0 => relative)
)
(T (* Can't find a file to describe this font;
return NIL)
(RETURN NIL)))
(SETQ RELFLAG (ZEROP RELFLAG)) (* Convert the flag to a logical value)
(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.)
(replace (FONTDESCRIPTOR FBBOX) of FD with (SIGNED (\WIN WSTRM)
BITSPERWORD))
(* Get the max bounding width for the font)
(replace \SFDescent of FD with (IMINUS (SIGNED (\WIN WSTRM)
BITSPERWORD)))
(* Descent is -FBBOY)
(replace (FONTDESCRIPTOR FBBDX) of FD with (SIGNED (\WIN WSTRM)
BITSPERWORD))
(* And the standard kern value
(?))
(replace \SFHeight of FD with (SIGNED (\WIN WSTRM)
BITSPERWORD))
(* Height is FBBDY)
(replace \SFWidths of FD with WIDTHS)
(SETQ FIRSTCHAR (fetch FIRSTCHAR of FD))
(SETQ LASTCHAR (fetch LASTCHAR of FD))
[COND
(RELFLAG (* Dimensions are relative, must be scaled)
(replace (FONTDESCRIPTOR FBBOX) of FD
with (IQUOTIENT (ITIMES (fetch (FONTDESCRIPTOR FBBOX) of FD)
NSMICASIZE)
1000))
(replace \SFDescent of FD with (IQUOTIENT (ITIMES (fetch \SFDescent
of FD)
NSMICASIZE)
1000))
(replace (FONTDESCRIPTOR FBBDX) of FD
with (IQUOTIENT (ITIMES (fetch (FONTDESCRIPTOR FBBDX) of FD)
NSMICASIZE)
1000))
(replace \SFHeight of FD with (IQUOTIENT (ITIMES (fetch \SFHeight
of FD)
NSMICASIZE)
1000]
(replace \SFAscent of FD with (IDIFFERENCE (fetch \SFHeight of FD)
(fetch \SFDescent of FD)))
(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.)
(SETA WIDTHS I TEM)))
(T (* Variable width font, so we have to read widths.)
(AIN WIDTHS FIRSTCHAR (ADD1 (IDIFFERENCE LASTCHAR FIRSTCHAR))
WSTRM) (* Read the X widths.)
(for I from FIRSTCHAR to LASTCHAR when (EQ noInfoCode (ELT WIDTHS I))
do (* For chars that have no width info, let width be
zero.)
(SETA WIDTHS I 0))
(COND
(RELFLAG (* If the widths are size-relative, scale them.)
(for I from FIRSTCHAR to LASTCHAR
do (SETA WIDTHS I (IQUOTIENT (ITIMES (ELT 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 \SFWidthsY of FD with (COND
((AND RELFLAG (NOT (ZEROP WIDTHSY)))
(IQUOTIENT (ITIMES WIDTHSY NSMICASIZE)
1000))
(T WIDTHSY]
(T (* Variable Y-width font. Fill it in as above)
(replace \SFWidthsY of FD with (SETQ WIDTHSY (ARRAY (ADD1 \MAXCHAR)
(QUOTE SMALLPOSP)
0 0)))
(AIN WIDTHSY FIRSTCHAR (ADD1 (IDIFFERENCE LASTCHAR FIRSTCHAR))
WSTRM) (* Read the Y widths)
(for I from FIRSTCHAR to LASTCHAR when (EQ noInfoCode (ELT WIDTHSY I))
do (* Let any characters with no width info be zero
height)
(SETA WIDTHSY I 0))
(COND
(RELFLAG (* If the widths are size-relative, scale them.)
(for I from FIRSTCHAR to LASTCHAR
do (SETA WIDTHSY I (IQUOTIENT (ITIMES (ELT WIDTHSY I)
NSMICASIZE)
1000]
(RETURN FD])
)
(PUTPROPS AFONTPATCH COPYRIGHT ("Xerox Corporation" 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (361 8163 (\CREATESTARFONT 371 . 8161)))))
STOP