(FILECREATED "30-Oct-84 14:45:15" {ERIS}<LISPNEW>SOURCES>READSTARPATCH.;3 10029
changes to: (FNS \CREATESTARFONT \FINDFONT)
(VARS READSTARPATCHCOMS)
previous date: "30-Oct-84 11:19:58" {ERIS}<LISPNEW>SOURCES>READSTARPATCH.;1)
(* Copyright (c) 1984 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT READSTARPATCHCOMS)
(RPAQQ READSTARPATCHCOMS ((FNS \CREATESTARFONT \FINDFONT)))
(DEFINEQ
(\CREATESTARFONT
[LAMBDA (FAMILY PSIZE FACE ROTATION DEVICE CHARSET) (* jds "30-Oct-84 12:22")
(* 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]
(SETFILEPTR WSTRM 0)
(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 (LLSH (\FIXPIN WSTRM)
1))
(* Read the location of the WD segment for this font (we're in the directory part of the file now), and go there.)
(replace 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 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 FBBOX of FD with (IQUOTIENT (ITIMES (fetch FBBOX
of FD)
NSMICASIZE)
1000))
(replace \SFDescent of FD with (IQUOTIENT (ITIMES (fetch \SFDescent
of FD)
NSMICASIZE)
1000))
(replace FBBDX of FD with (IQUOTIENT (ITIMES (fetch 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])
(\FINDFONT
[LAMBDA (FD WSTRM PRESSMICASIZE NSMICASIZE DONTCHECK) (* jds "30-Oct-84 14:29")
(* Finds the widths information for the specified FAMILY, FACECODE, MSIZE, and ROTATION. The FIRSTCHAR and LASTCHAR
of the font are filled in, since we have to read past those to check the size. If successful, returns the size found
in the widths file, with zero indicating that dimensions in the widths file are relative, leaving the file pointing
just after the Rotation word of the font. -
If DONTCHECK, then assumes that this file contains exactly the right face and family, without checking -
Returns NIL if the font is not found)
(bind TYPE LENGTH SIZE FAMILYCODE (ROTATION ←(fetch ROTATION of FD))
(FACECODE ←(\FACECODE (fetch FONTFACE of FD)))
(NEXT ← 0) first (OR (SETQ FAMILYCODE (\FAMILYCODE (OR DONTCHECK (fetch FONTFAMILY
of FD))
WSTRM))
(RETURN NIL))
do (SETQ TYPE (\BIN WSTRM))
(SETQ LENGTH (\BIN WSTRM))
(add NEXT (LLSH (IPLUS LENGTH (LLSH (LOGAND TYPE 15)
8))
1))
(SELECTQ (LRSH TYPE 4)
[4 (COND
((OR (AND (EQ FAMILYCODE (\BIN WSTRM))
(EQ FACECODE (\BIN WSTRM)))
DONTCHECK) (* This is the right family/face
(DONTCHECK must come last, so the file reads get done.)
)
(replace FIRSTCHAR of FD with (\BIN WSTRM))
(replace LASTCHAR of FD with (\BIN WSTRM))
(COND
((AND (OR (ZEROP (SETQ SIZE (\WIN WSTRM)))
(EQ PRESSMICASIZE SIZE)
(EQ NSMICASIZE SIZE))
(EQ ROTATION (\WIN WSTRM)))
(replace \SFFACECODE of FD with FACECODE)
(RETURN SIZE]
(0 (RETURN NIL))
NIL)
(SETFILEPTR WSTRM NEXT])
)
(PUTPROPS READSTARPATCH COPYRIGHT ("Xerox Corporation" 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (423 9945 (\CREATESTARFONT 433 . 7945) (\FINDFONT 7947 . 9943)))))
STOP