(FILECREATED "24-Nov-84 17:06:15" {ERIS}<LISPNEW>SOURCES>PRESSFONTPATCH.;1 8081 )
(* Copyright (c) 1984 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT PRESSFONTPATCHCOMS)
(RPAQQ PRESSFONTPATCHCOMS ((FNS \CREATEPRESSFONT)))
(DEFINEQ
(\CREATEPRESSFONT
[LAMBDA (FAMILY PSIZE FACE ROTATION DEVICE) (* rmk: "24-Nov-84 17:04")
(* 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 (WSTRM XLATEDFAM FIXEDFLAGS RELFLAG FIRSTCHAR LASTCHAR TEM WIDTHSY
(WIDTHS (ARRAY (ADD1 \MAXCHAR)
(QUOTE SMALLPOSP)
0 0))
(PRESSMICASIZE (IQUOTIENT (ITIMES PSIZE 2540)
72))
(NSMICASIZE (FIXR (FQUOTIENT (ITIMES PSIZE 2540)
72)))
(FD (create FONTDESCRIPTOR
FONTDEVICE ← DEVICE
FONTFAMILY ← FAMILY
FONTSIZE ← PSIZE
FONTFACE ← FACE
\SFFACECODE ←(\FACECODE FACE)
ROTATION ← ROTATION)))
(* The PRESS world and the NS world disagree on whether to truncate or round when converting from points to micas.
Hence the different values PRESSMICASIZE and NSMICASIZE.)
(OR [for F inside PRESSFONTWIDTHSFILES when (INFILEP F)
do (* Look thru the candidate PRESSFONTWIDTHSFILES for a
file that has a description for this font.)
[COND
((SETQ WSTRM (\GETSTREAM F (QUOTE INPUT)
T))
(RESETSAVE NIL (LIST (QUOTE SETFILEPTR)
WSTRM
(GETFILEPTR WSTRM)))
(SETFILEPTR WSTRM 0))
(T (RESETSAVE (SETQ WSTRM (OPENSTREAM F (QUOTE INPUT)
(QUOTE OLD)
8))
(QUOTE (PROGN (CLOSEF? OLDVALUE]
(COND
((SETQ RELFLAG (\FINDFONT FD WSTRM PRESSMICASIZE NSMICASIZE))
(* OK, we found this font described in this file.)
(RETURN T]
[AND (SETQ XLATEDFAM (SELECTQ FAMILY
(MODERN (QUOTE HELVETICA))
(CLASSIC (QUOTE TIMESROMAN))
(LOGOTYPE (QUOTE LOGO))
(TERMINAL (QUOTE GACHA))
NIL))
(for F inside PRESSFONTWIDTHSFILES
first (replace FONTFAMILY of FD with XLATEDFAM) when (INFILEP F)
do (* Now try coercing the family name)
(* We know the file was left open on the previous loop)
(SETQ WSTRM (\GETSTREAM F (QUOTE INPUT)
T))
(COND
((SETQ RELFLAG (\FINDFONT FD WSTRM PRESSMICASIZE NSMICASIZE))
(replace FONTDEVICESPEC of FD
with (LIST XLATEDFAM PSIZE FACE ROTATION DEVICE))
(replace FONTFAMILY of FD with FAMILY)
(RETURN T]
[AND (SETQ XLATEDFAM (SELECTQ FAMILY
(MODERN (QUOTE FRUTIGER))
(CLASSIC (QUOTE CENTURY))
NIL))
(for F inside PRESSFONTWIDTHSFILES
first (replace FONTFAMILY of FD with XLATEDFAM) when (INFILEP F)
do (SETQ WSTRM (\GETSTREAM F (QUOTE INPUT)
T))
(COND
((SETQ RELFLAG (\FINDFONT FD WSTRM PRESSMICASIZE NSMICASIZE))
(replace FONTDEVICESPEC of FD
with (LIST XLATEDFAM PSIZE FACE ROTATION DEVICE))
(replace FONTFAMILY of FD with FAMILY)
(RETURN T]
(RETURN NIL))
(SETQ RELFLAG (ZEROP RELFLAG)) (* Actually, \FINDFONT returns zero if the font metrics
are size-relative and must be scaled.)
(SETFILEPTR WSTRM (LLSH (\FIXPIN WSTRM)
1)) (* Locate the segment)
(replace FBBOX of FD with (SIGNED (\WIN WSTRM)
BITSPERWORD))
(replace \SFDescent of FD with (IMINUS (SIGNED (\WIN WSTRM)
BITSPERWORD)))
(* Descent is -FBBOY)
(replace FBBDX of FD with (SIGNED (\WIN WSTRM)
BITSPERWORD))
(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)
PRESSMICASIZE)
1000))
(replace \SFDescent of FD with (IQUOTIENT (ITIMES (fetch \SFDescent
of FD)
PRESSMICASIZE)
1000))
(replace FBBDX of FD with (IQUOTIENT (ITIMES (fetch FBBDX
of FD)
PRESSMICASIZE)
1000))
(replace \SFHeight of FD with (IQUOTIENT (ITIMES (fetch \SFHeight
of FD)
PRESSMICASIZE)
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))
(SETQ TEM (\WIN WSTRM)) (* The fixed width for this font)
[COND
((AND RELFLAG (NOT (ZEROP TEM)))
(SETQ TEM (IQUOTIENT (ITIMES TEM PRESSMICASIZE)
1000]
(for I from FIRSTCHAR to LASTCHAR do (SETA WIDTHS I TEM)))
(T (AIN WIDTHS FIRSTCHAR (ADD1 (IDIFFERENCE LASTCHAR FIRSTCHAR))
WSTRM)
(for I from FIRSTCHAR to LASTCHAR when (EQ noInfoCode (ELT WIDTHS I))
do (SETA WIDTHS I 0))
(COND
(RELFLAG (for I from FIRSTCHAR to LASTCHAR
do (SETA WIDTHS I (IQUOTIENT (ITIMES (ELT WIDTHS I)
PRESSMICASIZE)
1000]
[COND
[(EQ 1 (LOGAND FIXEDFLAGS 1))
(SETQ WIDTHSY (\WIN WSTRM)) (* 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 PRESSMICASIZE)
1000))
(T WIDTHSY]
(T (replace \SFWidthsY of FD with (SETQ WIDTHSY (ARRAY (ADD1 \MAXCHAR)
(QUOTE SMALLPOSP)
0 0)))
(AIN WIDTHSY FIRSTCHAR (ADD1 (IDIFFERENCE LASTCHAR FIRSTCHAR))
WSTRM)
(for I from FIRSTCHAR to LASTCHAR when (EQ noInfoCode (ELT WIDTHSY I))
do (SETA WIDTHSY I 0))
(COND
(RELFLAG (for I from FIRSTCHAR to LASTCHAR
do (SETA WIDTHSY I (IQUOTIENT (ITIMES (ELT WIDTHSY I)
PRESSMICASIZE)
1000]
(RETURN FD])
)
(PUTPROPS PRESSFONTPATCH COPYRIGHT ("Xerox Corporation" 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (252 7996 (\CREATEPRESSFONT 262 . 7994)))))
STOP