(FILECREATED "24-Sep-86 17:49:49" {ERIS}<LISPCORE>SOURCES>FONT.;102 152798
changes to: (VARS FONTCOMS)
previous date: "10-Sep-86 18:15:53" {ERIS}<LISPCORE>SOURCES>FONT.;100)
(* Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT FONTCOMS)
(RPAQQ FONTCOMS
((* font functions)
(FNS CHARWIDTH CHARWIDTHY STRINGWIDTH \CHARWIDTH.DISPLAY \STRINGWIDTH.DISPLAY
\STRINGWIDTH.GENERIC)
(* Until we pin down the exact interface)
(P (MOVD (QUOTE FONTCLASSCOMPONENT)
(QUOTE FONTCOMPONENT))
(MOVD (QUOTE SETFONTCLASSCOMPONENT)
(QUOTE SETFONTCOMPONENT)))
(FNS DEFAULTFONT FONTCLASS FONTCLASSUNPARSE FONTCLASSCOMPONENT SETFONTCLASSCOMPONENT)
(FNS FONTASCENT FONTCOPY FONTCREATE FONTSAVAILABLE FONTDESCENT FONTFILEFORMAT FONTHEIGHT
FONTP FONTPROP FONTUNPARSE SETFONTDESCRIPTOR CHARCODEP GETCHARBITMAP PUTCHARBITMAP
EDITCHAR \AVGCHARWIDTH \STREAMCHARWIDTH \UNITWIDTHSVECTOR \CREATEDISPLAYFONT
\CREATECHARSET.DISPLAY \BUILDSLUGCSINFO \SEARCHDISPLAYFONTFILES \FONTFACE \FONTFILENAME
\FONTINFOFROMFILENAME \GETFONTDESC \COERCEFONTDESC \LOOKUPFONT \LOOKUPFONTSINCORE
\READDISPLAYFONTFILE \SFMAKEBOLD \SFMAKEITALIC \SFMAKEROTATEDFONT \SFROTATECSINFO
\SFROTATEFONTCHARACTERS \SFFIXOFFSETSAFTERROTATION \SFROTATECSINFOOFFSETS \SFMAKECOLOR)
(INITRECORDS FONTCLASS FONTDESCRIPTOR CHARSETINFO)
(SYSRECORDS FONTCLASS FONTDESCRIPTOR CHARSETINFO)
(INITVARS (\FONTSINCORE)
(\DEFAULTDEVICEFONTS)
(\UNITWIDTHSVECTOR))
(GLOBALVARS DISPLAYFONTDIRECTORIES \DEFAULTDEVICEFONTS \UNITWIDTHSVECTOR)
(P (\UNITWIDTHSVECTOR))
(CONSTANTS (NORUNCODE 255))
(EXPORT (OPTIMIZERS FONTPROP))
(DECLARE: DONTCOPY
(EXPORT (RECORDS FONTCLASS FONTDESCRIPTOR FONTFACE CHARSETINFO)
(MACROS FONTASCENT FONTDESCENT FONTHEIGHT \FGETOFFSET \FSETOFFSET \FGETWIDTH
\FSETWIDTH \FGETCHARWIDTH \FGETIMAGEWIDTH \FSETIMAGEWIDTH
\GETCHARSETINFO \CREATECSINFOELEMENT \CREATEFONTCHARSETVECTOR)
(CONSTANTS (\MAXNSCHAR 65535))))
(COMS (* NS Character specific code)
(FNS \CREATECHARSET)
(GLOBALVARS DISPLAYFONTCOERCIONS MISSINGDISPLAYFONTCOERCIONS CHARSETERRORFLG)
(INITVARS (DISPLAYFONTCOERCIONS NIL)
(MISSINGDISPLAYFONTCOERCIONS (QUOTE (((GACHA)
(TERMINAL))
((MODERN)
(CLASSIC))
((TIMESROMAN)
(CLASSIC))
((HELVETICA)
(MODERN)))))
(CHARSETERRORFLG NIL)
(\DEFAULTCHARSET 0)))
(FNS \FONTRESETCHARWIDTHS \READSTRIKEFONTFILE)
(DECLARE: DONTEVAL@LOAD (INITVARS (DISPLAYFONTEXTENSIONS (QUOTE DISPLAYFONT))
(DISPLAYFONTDIRECTORIES (QUOTE ({ERIS}<LISPCORE>FONTS>
{ERIS}<LISP>FONTS>)))))
(MACROS \FGETCHARIMAGEWIDTH \GETFONTDESC \SETCHARSETINFO)
(LOCALVARS . T)
(PROP FILETYPE FONT)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA FONTCOPY)))))
(* font functions)
(DEFINEQ
(CHARWIDTH
[LAMBDA (CHARCODE FONT) (* rmk: "12-Apr-85 09:46")
(* gets the width of a character code
in a font/stream)
(OR (\CHARCODEP CHARCODE)
(\ILLEGAL.ARG CHARCODE))
(LET (TEMP)
(COND
((type? FONTDESCRIPTOR FONT)
(\FGETCHARWIDTH FONT CHARCODE))
((SETQ TEMP (\OUTSTREAMARG FONT T)) (* NIL font goes thru here--primary
output file)
(IMAGEOP (QUOTE IMCHARWIDTH)
TEMP TEMP CHARCODE))
(T (\FGETCHARWIDTH (FONTCREATE FONT)
CHARCODE])
(CHARWIDTHY
[LAMBDA (CHARCODE FONT) (* edited: "18-Mar-86 19:30")
(* Gets the Y-component of the width
of a character code in a font.)
(OR (\CHARCODEP CHARCODE)
(\ILLEGAL.ARG CHARCODE))
(LET (TEMP WY)
(COND
((type? FONTDESCRIPTOR FONT)
(SETQ WY (ffetch (CHARSETINFO YWIDTHS) of (\GETCHARSETINFO (\CHARSET CHARCODE)
FONT)))
(COND
((FIXP WY))
(WY (\FGETWIDTH WY (\CHAR8CODE CHARCODE)))
(T 0)))
((type? STREAM (SETQ TEMP (\OUTSTREAMARG FONT T)))
(* NIL font goes thru here--primary
output file)
(IMAGEOP (QUOTE IMCHARWIDTHY)
TEMP TEMP CHARCODE))
(T [SETQ WY (ffetch (CHARSETINFO YWIDTHS) of (\GETCHARSETINFO (\CHARSET CHARCODE)
(FONTCREATE FONT]
(COND
((FIXP WY))
(WY (\FGETWIDTH WY (\CHAR8CODE CHARCODE)))
(T 0])
(STRINGWIDTH
[LAMBDA (STR FONT FLG RDTBL) (* rmk: "12-Apr-85 09:45")
(* Returns the width of STR according
to FONT)
(LET (TEMP) (* Used in \MAPCHARS)
(COND
[(type? FONTDESCRIPTOR FONT)
(\STRINGWIDTH.GENERIC STR FONT (AND FLG (\GTREADTABLE RDTBL))
(\FGETCHARWIDTH FONT (CHARCODE SPACE]
[(SETQ TEMP (\OUTSTREAMARG FONT T)) (* NIL font goes thru here--primary
output file)
(IMAGEOP (QUOTE IMSTRINGWIDTH)
TEMP TEMP STR (AND FLG (\GTREADTABLE RDTBL]
(T (SETQ TEMP (FONTCREATE FONT))
(\STRINGWIDTH.GENERIC STR TEMP (AND FLG (\GTREADTABLE RDTBL))
(\FGETCHARWIDTH TEMP (CHARCODE SPACE])
(\CHARWIDTH.DISPLAY
[LAMBDA (STREAM CHARCODE) (* rmk: "12-Apr-85 09:42")
(* gets the width of a character code
in a display stream.
Need to fix up for spacefactor.)
(\FGETCHARWIDTH (ffetch (\DISPLAYDATA DDFONT) of (ffetch IMAGEDATA of STREAM))
CHARCODE])
(\STRINGWIDTH.DISPLAY
[LAMBDA (STREAM STR RDTBL) (* rmk: " 4-Apr-85 14:03")
(* Returns the width of for the
current font/spacefactor in STREAM.)
(LET ((DD (ffetch IMAGEDATA of STREAM)))
(\STRINGWIDTH.GENERIC STR (ffetch (\DISPLAYDATA DDFONT) of DD)
RDTBL
(ffetch DDSPACEWIDTH of DD])
(\STRINGWIDTH.GENERIC
[LAMBDA (STR FONT RDTBL SPACEWIDTH) (* bvm: " 4-Aug-86 15:13")
(* * Returns the width of STR with SPACEWIDTH for the width of spaces.
RDTBL has already been coerced, so no FLG is needed)
(* * This is cloned in \STRINGWIDTH.HCPYDISPLAYAUX by straight substitution --
(PUTDEF (QUOTE \STRINGWIDTH.HCPYDISPLAYAUX)
(QUOTE FNS) (SUBLIS (QUOTE ((WIDTHS . IMAGEWIDTHS)
(\FGETWIDTH . \FGETIMAGEWIDTH) (\FGETCHARWIDTH . \FGETCHARIMAGEWIDTH)))
(GETDEF (QUOTE \STRINGWIDTH.GENERIC)))))
(* \MAPPNAME uses WIDTHSBASE CSET
TOTALWIDTH FONT SPACEWIDTH free, so
these become special in bytecompiler)
(PROG NIL
(SELECTC (NTYPX STR)
(\LITATOM [if RDTBL
then (GO SLOW)
else (RETURN (for C WIDTHSBASE CSET inatom STR
sum [COND
((NEQ CSET (\CHARSET C))
(SETQ CSET (\CHARSET C))
(SETQ WIDTHSBASE (ffetch (CHARSETINFO WIDTHS)
of (\GETCHARSETINFO CSET FONT]
(COND
((EQ C (CHARCODE SPACE))
SPACEWIDTH)
(T (\FGETWIDTH WIDTHSBASE (\CHAR8CODE C])
(\STRINGP (RETURN
(LET
((TOTAL 0)
ESC ESCWIDTH WIDTHSBASE CSET)
[COND
(RDTBL (* Count delimiting quotes and
internal escapes)
(SETQ TOTAL (UNFOLD (\FGETCHARWIDTH FONT (CHARCODE %"))
2))
(SETQ ESC (fetch (READTABLEP ESCAPECHAR) of RDTBL))
(SETQ ESCWIDTH (\FGETCHARWIDTH FONT ESC]
[for C instring STR
do [COND
((NEQ (\CHARSET C)
CSET) (* Get the widths vector for this
character set)
(SETQ CSET (\CHARSET C))
(SETQ WIDTHSBASE (ffetch (CHARSETINFO WIDTHS)
of (\GETCHARSETINFO CSET FONT]
(add TOTAL (COND
((EQ C (CHARCODE SPACE))
SPACEWIDTH)
(T (IPLUS (\FGETWIDTH WIDTHSBASE (\CHAR8CODE C))
(COND
((AND RDTBL (OR (EQ C (CHARCODE %"))
(EQ C ESC)))
(* String char must be escaped)
ESCWIDTH)
(T 0]
TOTAL)))
NIL)
SLOW
(* Do the general case here)
(RETURN (LET ((TOTALWIDTH 0)
WIDTHSBASE CSET)
(\MAPPNAME [FUNCTION (LAMBDA (DUMMY CC)
(DECLARE (USEDFREE WIDTHSBASE CSET TOTALWIDTH FONT
SPACEWIDTH))
(add TOTALWIDTH (COND
((EQ CC (CHARCODE SPACE))
SPACEWIDTH)
((EQ CSET (\CHARSET CC))
(\FGETWIDTH WIDTHSBASE (\CHAR8CODE
CC)))
(T (SETQ CSET (\CHARSET CC))
(SETQ WIDTHSBASE
(ffetch (CHARSETINFO WIDTHS)
of (\GETCHARSETINFO CSET FONT
)))
(\FGETWIDTH WIDTHSBASE
(\CHAR8CODE CC]
STR RDTBL RDTBL)
TOTALWIDTH])
)
(* Until we pin down the exact interface)
(MOVD (QUOTE FONTCLASSCOMPONENT)
(QUOTE FONTCOMPONENT))
(MOVD (QUOTE SETFONTCLASSCOMPONENT)
(QUOTE SETFONTCOMPONENT))
(DEFINEQ
(DEFAULTFONT
[LAMBDA (DEVICE FONT NOERRORFLG) (* rmk: "20-Sep-84 11:22")
(* Returns the default font for an image type.
Really only needed to guarantee validity of the display default font for system
critical routines, in case the user has smashed the variable DEFAULTFONT.
Note that SETFONTCOMPONENT and FONTCLASS guarantee that the display component
is either NIL or a fontdescriptor.)
(* If NOERRORFLG is NEW the
fontcomponent is set)
[OR (type? FONTCLASS DEFAULTFONT)
(SETQ DEFAULTFONT (FONTCLASS (QUOTE DEFAULTFONT]
(COND
((AND FONT (EQ NOERRORFLG (QUOTE NEW)))
(SETFONTCLASSCOMPONENT DEFAULTFONT DEVICE FONT))
((\COERCEFONTDESC DEFAULTFONT DEVICE T))
(NOERRORFLG NIL)
((EQ DEVICE (QUOTE DISPLAY))
(* If getting for the display and the font can't be found perhaps cause of
cause of garbage in the display field of the DEFAULTFONTCLASS, then the
system-guaranteed displayfont. Otherwise, cause the error in the re-coercion)
\GUARANTEEDDISPLAYFONT)
((\COERCEFONTDESC DEFAULTFONT DEVICE])
(FONTCLASS
[LAMBDA (NAME FONTLIST CREATEFORDEVICES) (* jds " 9-Sep-86 18:49")
(* This builds D style font classes,
which are datatypes containing entries
for the various known devices.)
(* Don't actually set up the for devices not inside CREATEFORDEVICES on the
theory that any given user presumably doesn't want all the fonts for all the
devices. We wait until he actually asks for the font or the fontmaparray, at
which point we note that the fields don't contain FD's, so we then apply
FONTCREATE. The actual coercion and caching is done inside \COERCEFONTDESC.
However, so as to prevent display crashes, if a display component is specified,
we always do the fontcreate before we stick it in.)
(PROG (F FC FL)
(SETQ FL FONTLIST)
[SETQ FC (create FONTCLASS
FONTCLASSNAME ← NAME
PRETTYFONT# ← (OR (FIXP (pop FL))
1)
DISPLAYFD ← (AND (SETQ F (pop FL))
(FONTCREATE F NIL NIL NIL (QUOTE DISPLAY)))
PRESSFD ← (pop FL)
INTERPRESSFD ← (pop FL)
OTHERFDS ← (for FSPEC in FL collect (OR (AND (LISTP FSPEC)
(ATOM (CAR FSPEC))
(CAR FSPEC))
(ERROR
"illegal font class specification"
(LIST NAME FONTLIST)))
(* Copy the alist entry so it can be
smashed in \COERCEFONTDESC)
(CONS (CAR FSPEC)
(CAR (LISTP (CDR FSPEC]
(for D inside CREATEFORDEVICES do (FONTCREATE FC NIL NIL NIL D))
(RETURN FC])
(FONTCLASSUNPARSE
[LAMBDA (FONTCLASS DEVICE FONT NOERRORFLG) (* jds "24-Jan-86 11:58")
(* Given a font class, unparse it to a
form that might be reparsable)
(APPEND (LIST (fetch (FONTCLASS FONTCLASSNAME) of FONTCLASS)
(fetch (FONTCLASS PRETTYFONT#) of FONTCLASS)
(FONTUNPARSE (ffetch (FONTCLASS DISPLAYFD) of FONTCLASS))
(FONTUNPARSE (ffetch (FONTCLASS PRESSFD) of FONTCLASS))
(FONTUNPARSE (ffetch (FONTCLASS INTERPRESSFD) of FONTCLASS)))
(for X in (fetch (FONTCLASS OTHERFDS) of FONTCLASS)
collect (LIST (CAR X)
(FONTUNPARSE (CDR X])
(FONTCLASSCOMPONENT
[LAMBDA (FONTCLASS DEVICE FONT NOERRORFLG) (* rmk: "14-Sep-84 19:34")
(PROG1 (FONTCREATE FONTCLASS NIL NIL NIL DEVICE NOERRORFLG)
(* This works its way down to
\COERCEFONTDESC, where it needs to be
done quickly)
(AND FONT (SETQ FONT (FONTCREATE FONT NIL NIL NIL DEVICE NOERRORFLG))
(SETFONTCLASSCOMPONENT FONTCLASS DEVICE FONT])
(SETFONTCLASSCOMPONENT
[LAMBDA (FONTCLASS DEVICE FONT) (* rmk: "14-Sep-84 23:09")
(PROG ((NEWFONT (FONTCREATE FONT NIL NIL NIL DEVICE))) (* replaces will barf if FONTCLASS is
not a fontclass)
(SELECTQ DEVICE
((NIL DISPLAY)
(replace (FONTCLASS DISPLAYFD) of FONTCLASS with NEWFONT))
(INTERPRESS (replace (FONTCLASS INTERPRESSFD) of FONTCLASS with NEWFONT))
(PRESS (replace (FONTCLASS PRESSFD) of FONTCLASS with NEWFONT))
(RPLACD [OR (ASSOC DEVICE (fetch (FONTCLASS OTHERFDS) of FONTCLASS))
(CAR (push (fetch (FONTCLASS OTHERFDS) of FONTCLASS)
(CONS DEVICE]
NEWFONT))
(RETURN NEWFONT])
)
(DEFINEQ
(FONTASCENT
[LAMBDA (FONTSPEC) (* lmm "19-NOV-82 00:23")
(ffetch \SFAscent of (\GETFONTDESC FONTSPEC])
(FONTCOPY
[LAMBDA FONTSPECS (* gbn: "25-Jan-86 17:45")
(* makes a copy of a font changing the
specified fields.)
(PROG (NOERROR FAMILY FACE SIZE ROTATION DEVICE OLDFONT)
[SETQ OLDFONT (\GETFONTDESC (ARG FONTSPECS 1)
(AND (type? FONTCLASS (ARG FONTSPECS 1))
(COND
((AND (EQ FONTSPECS 2)
(LISTP (ARG FONTSPECS 2)))
(LISTGET (ARG FONTSPECS 2)
(QUOTE DEVICE)))
(T (for I from 2 by 2 to FONTSPECS
do (COND
((AND (NEQ I FONTSPECS)
(EQ (ARG FONTSPECS I)
(QUOTE DEVICE)))
(RETURN (ARG FONTSPECS (ADD1 I]
(SETQ FAMILY (fetch (FONTDESCRIPTOR FONTFAMILY) of OLDFONT))
(SETQ SIZE (fetch (FONTDESCRIPTOR FONTSIZE) of OLDFONT))
(SETQ FACE (fetch (FONTDESCRIPTOR FONTFACE) of OLDFONT))
(SETQ ROTATION (fetch (FONTDESCRIPTOR ROTATION) of OLDFONT))
(SETQ DEVICE (fetch (FONTDESCRIPTOR FONTDEVICE) of OLDFONT))
[for I VAL from 2 by 2 to FONTSPECS
do [SETQ VAL (COND
((NOT (EQ I FONTSPECS))
(ARG FONTSPECS (ADD1 I]
(SELECTQ (ARG FONTSPECS I)
(FAMILY (SETQ FAMILY VAL))
(SIZE (SETQ SIZE VAL))
(FACE (SETQ FACE (\FONTFACE VAL)))
(WEIGHT (SETQ FACE (create FONTFACE using FACE WEIGHT ← VAL)))
(SLOPE (SETQ FACE (create FONTFACE using FACE SLOPE ← VAL)))
(EXPANSION (SETQ FACE (create FONTFACE using FACE EXPANSION ← VAL)))
(BACKCOLOR (SETQ FACE (create FONTFACE using FACE BACKCOLOR ← VAL)))
(FORECOLOR (SETQ FACE (create FONTFACE using FACE FORECOLOR ← VAL)))
(ROTATION (SETQ ROTATION VAL))
(DEVICE (SETQ DEVICE VAL))
(NOERROR (SETQ NOERROR VAL))
(COND
[(AND (EQ I 2)
(EQ FONTSPECS 2)
(LISTP (ARG FONTSPECS 2)))
(for J on (ARG FONTSPECS 2) by (CDDR J)
do (SETQ VAL (CADR J))
(SELECTQ (CAR J)
(FAMILY (SETQ FAMILY VAL))
(SIZE (SETQ SIZE VAL))
(FACE (SETQ FACE (\FONTFACE VAL)))
(WEIGHT (SETQ FACE (create FONTFACE using FACE WEIGHT ← VAL)))
(SLOPE (SETQ FACE (create FONTFACE using FACE SLOPE ← VAL)))
(EXPANSION (SETQ FACE (create FONTFACE using FACE EXPANSION ← VAL)))
(BACKCOLOR (SETQ FACE (create FONTFACE using FACE BACKCOLOR ← VAL)))
(FORECOLOR (SETQ FACE (create FONTFACE using FACE FORECOLOR ← VAL)))
(ROTATION (SETQ ROTATION VAL))
(DEVICE (SETQ DEVICE VAL))
(NOERROR (SETQ NOERROR VAL))
(\ILLEGAL.ARG (CAR J]
(T (\ILLEGAL.ARG (ARG FONTSPECS I]
(RETURN (FONTCREATE FAMILY SIZE FACE ROTATION DEVICE NOERROR])
(FONTCREATE
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE NOERRORFLG CHARSET)
(* gbn: "25-Jan-86 17:53")
(* * Create a font descriptor for the specified font.
If NOERRORFLG, return NIL if the font doesn't exist;
otherwise cause an error.)
(* Cache and fonts.widths traffic in
uppercase only.)
(* character set is optional and
defaults to \DEFAULTCHARSET
(0 in our world))
(DECLARE (GLOBALVARS IMAGESTREAMTYPES))
(PROG (FONTX [DEV (COND
((type? STREAM DEVICE)
(fetch (IMAGEOPS IMFONTCREATE) of (fetch (STREAM IMAGEOPS) of DEVICE)))
(DEVICE)
(T (QUOTE DISPLAY]
(CHSET (OR CHARSET \DEFAULTCHARSET)))
(RETURN (COND
((LISTP FAMILY)
(SELECTQ (CAR FAMILY)
(FONT (SETQ FONTX (CDR FAMILY)))
(CLASS (COND
((LITATOM (CADR FAMILY)) (* litatom class name)
(RETURN (FONTCLASS (CADR FAMILY)
(CDDR FAMILY)
DEV)))
(T (* Allows for a font named
CLASS--distinguished cause its size is
not a litatom)
(SETQ FONTX FAMILY))))
(SETQ FONTX FAMILY))
(FONTCREATE (CAR FONTX)
(OR (CADR FONTX)
SIZE)
(OR (CADDR FONTX)
FACE)
(OR (CADDDR FONTX)
ROTATION)
(OR (CADR (CDDDR FONTX))
DEV)
NOERRORFLG CHSET))
([SETQ FONTX (COND
((type? FONTDESCRIPTOR FAMILY)
FAMILY)
((NULL FAMILY)
(DEFAULTFONT DEV))
((type? FONTCLASS FAMILY)
(* We know that this won't attempt a cyclic fontcreate in \COERCEFONTDESC,
because we are passing a known class. Unless NOERROFLG, an error will be caused
on the actual device font if it can't be found.)
(\COERCEFONTDESC FAMILY DEV NOERRORFLG))
((OR (IMAGESTREAMP FAMILY)
(type? WINDOW FAMILY))
(DSPFONT NIL FAMILY] (* FAMILY was a spec for a font
descriptor, use it and extend it by
the other args.)
(COND
((OR SIZE FACE ROTATION DEVICE)
(FONTCREATE (FONTPROP FONTX (QUOTE FAMILY))
(OR SIZE (FONTPROP FONTX (QUOTE SIZE)))
(OR FACE (FONTPROP FONTX (QUOTE FACE)))
(OR ROTATION (FONTPROP FONTX (QUOTE ROTATION)))
(OR DEVICE (FONTPROP FONTX (QUOTE DEVICE)))
NOERRORFLG))
(T FONTX)))
(T (PROG (FONTFACE TEMPDEV)
RETRY
[OR (LITATOM FAMILY)
(COND
(NOERRORFLG (RETURN))
(T (LISPERROR "ARG NOT LITATOM" FAMILY T]
[OR (AND (FIXP SIZE)
(IGREATERP SIZE 0))
(COND
(NOERRORFLG (RETURN NIL))
(T (\ILLEGAL.ARG SIZE]
(SETQ FONTFACE (OR (\FONTFACE FACE NOERRORFLG DEV)
(RETURN NIL)))
(OR (U-CASEP FAMILY)
(SETQ FAMILY (U-CASE FAMILY)))
(COND
((NULL ROTATION)
(SETQ ROTATION 0))
((AND (FIXP ROTATION)
(IGEQ ROTATION 0)))
(NOERRORFLG (RETURN NIL))
(T (\ILLEGAL.ARG ROTATION)))
NEWDEV
[RETURN (COND
((\LOOKUPFONT FAMILY SIZE FONTFACE ROTATION DEV))
[[SETQ FONTX (ASSOC (QUOTE FONTCREATE)
(CDR (ASSOC DEV IMAGESTREAMTYPES]
(* We found the device, but maybe
didn't find the font.
We know not to try to coerce the
device into a stream, though.)
(COND
((SETQ FONTX (APPLY* (OR (CADR FONTX)
(FUNCTION NILL))
FAMILY SIZE FONTFACE ROTATION DEV
CHSET))
(* default creation case.
Use fontcreate method from device,
build a fontdescriptor and use
setfontdescriptor to install it.)
(* OBSOLETEd by the CHARSETINFO code
(OR (ffetch FONTIMAGEWIDTHS of FONTX)
(freplace FONTIMAGEWIDTHS of FONTX
with (ffetch \SFWidths of FONTX))))
(* * the widths fields in the fontdescriptor are obsolete, and shoudln't be
updated here.)
(* We should probably force all device
implementations to obey these
conventions, then remove these generic
updates)
(replace (FONTDESCRIPTOR FONTAVGCHARWIDTH) of FONTX
with (\AVGCHARWIDTH FONTX))
(SETFONTDESCRIPTOR FAMILY SIZE FONTFACE ROTATION DEV
FONTX))
(T (GO NOTFOUND]
((AND (NULL TEMPDEV)
(SETQ TEMPDEV (\GETSTREAM DEVICE (QUOTE OUTPUT)
T)))
(* Here only if we haven't recognized the device.
This could be slow for litatoms, but unless NOERROR, we are heading for an
error anyway. But for things like windows, it will be reasonably fast.
We don't do this above cause the recognized litatom case is common.)
(* Don't change DEV to NIL, so it is
meaningful in error message)
(SETQ DEV (fetch (IMAGEOPS IMFONTCREATE)
of (fetch (STREAM IMAGEOPS) of TEMPDEV)))
(GO NEWDEV))
(T (GO NOTFOUND]
NOTFOUND
(COND
(NOERRORFLG (RETURN NIL))
(T (ERROR "FONT NOT FOUND" (LIST FAMILY SIZE FONTFACE ROTATION DEV))
(GO RETRY])
(FONTSAVAILABLE
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHECKFILESTOO?) (* rrb " 7-Nov-84 15:41")
(* * returns a list of the fonts fitting a description that are available.
FAMILY SIZE FACE or ROTATION can be * which means get them all.
if LOADEDONLYFLG is non-NIL, only fonts in core will be considered.)
(DECLARE (GLOBALVARS IMAGESTREAMTYPES))
(PROG (FONTX DEV)
[SETQ DEV (COND
((type? STREAM DEVICE)
(COND
((LISTP (SETQ DEV (IMAGESTREAMTYPE DEVICE)))
(CAR DEV))
(T DEV)))
(DEVICE)
(T (QUOTE DISPLAY]
(RETURN
(COND
((LISTP FAMILY)
(COND
((EQ (CAR FAMILY)
(QUOTE FONT))
(SETQ FONTX (CDR FAMILY)))
(T (SETQ FONTX FAMILY)))
(FONTSAVAILABLE (CAR FONTX)
(OR (CADR FONTX)
SIZE)
(OR (CADDR FONTX)
FACE)
(OR (CADDDR FONTX)
ROTATION)
DEV CHECKFILESTOO?))
([SETQ FONTX (COND
((type? FONTDESCRIPTOR FAMILY)
FAMILY)
((NULL FAMILY)
(DEFAULTFONT DEV))
((type? FONTCLASS FAMILY)
(* We know that this won't attempt a cyclic fontcreate in \COERCEFONTDESC,
because we are passing a known class. Unless NOERROFLG, an error will be caused
on the actual device font if it can't be found.)
(* I don't know what to do in this
case- rrb.)
(\COERCEFONTDESC FAMILY DEV T))
((OR (IMAGESTREAMP FAMILY)
(type? WINDOW FAMILY))
(DSPFONT NIL FAMILY] (* FAMILY was a spec for a font
descriptor, use it and extend it by
the other args.)
(FONTSAVAILABLE (FONTPROP FONTX (QUOTE FAMILY))
(OR SIZE (FONTPROP FONTX (QUOTE SIZE)))
(OR FACE (FONTPROP FONTX (QUOTE FACE)))
(OR ROTATION (FONTPROP FONTX (QUOTE ROTATION)))
(OR DEVICE (FONTPROP FONTX (QUOTE DEVICE)))
CHECKFILESTOO?))
(T (PROG ((FONTFACE FACE))
RETRY
(OR (LITATOM FAMILY)
(LISPERROR "ARG NOT LITATOM" FAMILY T))
(OR (AND (FIXP SIZE)
(IGREATERP SIZE 0))
(EQ SIZE (QUOTE *))
(\ILLEGAL.ARG SIZE))
[OR (EQ FONTFACE (QUOTE *))
(SETQ FONTFACE (OR (\FONTFACE FACE T)
(RETURN NIL]
(OR (U-CASEP FAMILY)
(SETQ FAMILY (U-CASE FAMILY)))
(COND
((NULL ROTATION)
(SETQ ROTATION 0))
((AND (FIXP ROTATION)
(IGEQ ROTATION 0)))
((EQ ROTATION (QUOTE *)))
(T (\ILLEGAL.ARG ROTATION)))
(RETURN (UNION (\LOOKUPFONTSINCORE FAMILY SIZE FONTFACE ROTATION DEV)
(COND
((NOT CHECKFILESTOO?)
NIL)
[(EQ DEV (QUOTE *)) (* map thru all the devices.)
(for EXTANTDEV in IMAGESTREAMTYPES
join (APPLY* (OR (CADR (ASSOC (QUOTE FONTSAVAILABLE)
(CDR EXTANTDEV)))
(FUNCTION NILL))
FAMILY SIZE FONTFACE ROTATION (CAR EXTANTDEV
]
(T (* apply the device font lookup
function.)
(APPLY* (OR [CADR (ASSOC (QUOTE FONTSAVAILABLE)
(CDR (ASSOC DEV IMAGESTREAMTYPES
]
(FUNCTION NILL))
FAMILY SIZE FONTFACE ROTATION DEV])
(FONTDESCENT
[LAMBDA (FONTSPEC) (* lmm "19-NOV-82 00:24")
(* See comment in FONTASCENT)
(ffetch \SFDescent of (\GETFONTDESC FONTSPEC])
(FONTFILEFORMAT
[LAMBDA (STRM LEAVEOPEN) (* rmk: "11-Sep-84 17:16")
(* Returns the font format of STRM)
[OR (OPENP STRM (QUOTE INPUT))
(SETQ STRM (OPENSTREAM STRM (QUOTE INPUT)
(QUOTE OLD]
(PROG1 (SELECTC (\WIN STRM)
((LIST (LLSH 1 15)
(LOGOR (LLSH 1 15)
(LLSH 1 13)))
(* If high bit of type is on, then must be strike.
If 2nd bit is on, must be strike-index, and we punt.
We don't care about the 3rd bit)
(* first word has high bits (onebit index fixed)%.
Onebit means "new-style font" %, index is 0 for simple strike, 1 for index, and
fixed is if all chars have max width. Lisp doesn't care about "fixed")
(QUOTE STRIKE))
((LOGOR (LLSH 16 8)
12) (* This is the length of a standard
index header. Other files could also
have this value, but it's a pretty
good discriminator)
(* Skip to byte 25; do it with BINS so works for non-randaccessp devices.
This skips the standard name header, then look for type 3 in the following
header)
(FRPTQ 22 (\BIN STRM)) (* (SETFILEPTR STRM 25))
(AND (EQ 3 (LRSH (\BIN STRM)
4))
(QUOTE AC)))
NIL)
(OR LEAVEOPEN (CLOSEF STRM])
(FONTHEIGHT
[LAMBDA (FONTSPEC) (* kbr: " 9-Jan-86 18:29")
(fetch (FONTDESCRIPTOR \SFHeight) of (\GETFONTDESC FONTSPEC])
(FONTP
[LAMBDA (X) (* rmk: "13-Sep-84 09:04")
(* is X a FONTDESCRIPTOR?)
(COND
((OR (type? FONTDESCRIPTOR X)
(type? FONTCLASS X))
X])
(FONTPROP
[LAMBDA (FONT PROP) (* kbr: "13-May-85 22:36")
(SETQ FONT (\GETFONTDESC FONT))
(SELECTQ PROP
(HEIGHT (ffetch \SFHeight of FONT))
(ASCENT (ffetch \SFAscent of FONT))
(DESCENT (ffetch \SFDescent of FONT))
(FAMILY (ffetch FONTFAMILY of FONT))
(SIZE (ffetch FONTSIZE of FONT))
(FACE (COPY (ffetch FONTFACE of FONT)))
(WEIGHT (ffetch WEIGHT of (ffetch FONTFACE of FONT)))
(SLOPE (ffetch SLOPE of (ffetch FONTFACE of FONT)))
(EXPANSION (ffetch EXPANSION of (ffetch FONTFACE of FONT)))
(FORECOLOR (ffetch FORECOLOR of (ffetch FONTFACE of FONT)))
(BACKCOLOR (ffetch BACKCOLOR of (ffetch FONTFACE of FONT)))
(ROTATION (ffetch ROTATION of FONT))
(DEVICE (ffetch FONTDEVICE of FONT))
(SPEC (LIST (ffetch FONTFAMILY of FONT)
(ffetch FONTSIZE of FONT)
(COPY (ffetch FONTFACE of FONT))
(ffetch ROTATION of FONT)
(ffetch FONTDEVICE of FONT)))
(DEVICESPEC (* DEVICE fields are for communicating
coercions to the particular printing
device)
[COND
((ffetch FONTDEVICESPEC of FONT)
(COPY (ffetch FONTDEVICESPEC of FONT)))
(T (FONTPROP FONT (QUOTE SPEC])
(DEVICEFACE [COPY (COND
((ffetch FONTDEVICESPEC of FONT)
(CADDR (ffetch FONTDEVICESPEC of FONT)))
(T (ffetch FONTFACE of FONT])
(DEVICESLOPE [fetch SLOPE of (COND
((ffetch FONTDEVICESPEC of FONT)
(CADDR (ffetch FONTDEVICESPEC of FONT)))
(T (ffetch FONTFACE of FONT])
(DEVICEWEIGHT [fetch WEIGHT of (COND
((ffetch FONTDEVICESPEC of FONT)
(CADDR (ffetch FONTDEVICESPEC of FONT)))
(T (ffetch FONTFACE of FONT])
(DEVICEEXPANSION
[fetch EXPANSION of (COND
((ffetch FONTDEVICESPEC of FONT)
(CADDR (ffetch FONTDEVICESPEC of FONT)))
(T (ffetch FONTFACE of FONT])
(DEVICESIZE (COND
((ffetch FONTDEVICESPEC of FONT)
(CADR (ffetch FONTDEVICESPEC of FONT)))
(T (ffetch FONTSIZE of FONT))))
(DEVICEFAMILY (COND
((ffetch FONTDEVICESPEC of FONT)
(CAR (ffetch FONTDEVICESPEC of FONT)))
(T (ffetch FONTFAMILY of FONT))))
(SCALE (ffetch FONTSCALE of FONT))
(\ILLEGAL.ARG PROP])
(FONTUNPARSE
[LAMBDA (FONT) (* kbr: "25-Feb-86 19:40")
(* Produces a minimal specification of
the font or fontclass specification,
for dumping by Tedit, imageobjects.)
(PROG (FACE SPEC)
(SETQ SPEC (COND
((type? FONTDESCRIPTOR FONT)
(FONTPROP FONT (QUOTE SPEC)))
[(type? FONTCLASS FONT)
(RETURN (CONS (QUOTE CLASS)
(FONTCLASSUNPARSE FONT]
(T (* Could be a non-instantiated
specification in a fontclass, just use
it as the spec without creating the
font.)
FONT)))
(OR SPEC (RETURN))
(SETQ FACE (CADDR SPEC)) (* FACE and rotation can be NIL for a
non-fontdescriptor fontclass component)
[SETQ FACE (COND
([OR (NULL FACE)
(EQUAL FACE (QUOTE (MEDIUM REGULAR REGULAR]
NIL)
((LITATOM FACE)
FACE)
[(LISTP FACE)
(PACK (LIST* (NTHCHAR (fetch (FONTFACE WEIGHT) of FACE)
1)
(NTHCHAR (fetch (FONTFACE SLOPE) of FACE)
1)
(NTHCHAR (fetch (FONTFACE EXPANSION) of FACE)
1)
(COND
((fetch (FONTFACE COLOR) of FACE)
(LIST "-" (fetch (FONTFACE BACKCOLOR) of FACE)
"-"
(fetch (FONTFACE FORECOLOR) of FACE]
(T (SHOULDNT] (* Don't return device, or any
trailing defaults)
(RETURN (CONS (CAR SPEC)
(CONS (CADR SPEC)
(COND
([AND (CADDDR SPEC)
(NOT (EQ 0 (CADDDR SPEC]
(LIST (OR FACE (QUOTE MRR))
(CADDDR SPEC)))
(FACE (CONS FACE])
(SETFONTDESCRIPTOR
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE FONT) (* kbr: "22-May-85 21:33")
(* saves a font descriptor under a
family/size/face/rotation/device key
so that it will be retreived by
FONTCREATE. This is a user entry.)
(DECLARE (GLOBALVARS \FONTSINCORE))
(OR DEVICE (SETQQ DEVICE DISPLAY))
[COND
((NULL FONT) (* NIL is used to clobber existing
font so that next use will reread it.)
NIL)
(T (SETQ FONT (\COERCEFONTDESC FONT DEVICE]
(SETQ FACE (\FONTFACE FACE NIL DEVICE))
(OR ROTATION (SETQ ROTATION 0))
(PROG [(X (OR (FASSOC FAMILY \FONTSINCORE)
(CAR (push \FONTSINCORE (LIST FAMILY]
[SETQ X (OR (FASSOC SIZE (CDR X))
(CAR (push (CDR X)
(LIST SIZE]
[SETQ X (OR (SASSOC FACE (CDR X))
(CAR (push (CDR X)
(LIST FACE] (* SASSOC cause FACE is listp)
[SETQ X (OR (FASSOC ROTATION (CDR X))
(CAR (push (CDR X)
(LIST ROTATION]
[SETQ X (OR (FASSOC DEVICE (CDR X))
(CAR (push (CDR X)
(LIST DEVICE]
(RPLACD X FONT)
(RETURN FONT])
(CHARCODEP
[LAMBDA (CHCODE) (* gbn "22-Jul-85 16:35")
(* is CHCODE a legal character code?)
(AND (SMALLP CHCODE)
(IGEQ CHCODE 0)
(ILEQ CHCODE \MAXNSCHAR])
(GETCHARBITMAP
[LAMBDA (CHARCODE FONT) (* jds "10-Sep-86 18:15")
(* returns a bitmap of the character
CHARCODE from the font descriptor
FONTDESC.)
(COND
((OR (CHARCODEP CHARCODE)
(EQ CHARCODE 256)) (* bitmap for char 256 is what gets
printed if char not found)
)
((OR (STRINGP CHARCODE)
(LITATOM CHARCODE)) (* For strings & litatoms, take the
first character)
(SETQ CHARCODE (CHCON1 CHARCODE)))
((TYPEP CHARCODE (QUOTE CL:CHARACTER)) (* For common-lisp CHARACTERs, convert
it to the char code first.)
(SETQ CHARCODE (CHAR-INT CHARCODE)))
(T (\ILLEGAL.ARG CHARCODE)))
(PROG (CBM (FONTDESC (\GETFONTDESC FONT))
CSINFO CWDTH CHGHT) (* fetch the csinfo for the character
set of this character.
Bitmaps and widths must be fetched
from it)
(SETQ CSINFO (\GETCHARSETINFO (\CHARSET CHARCODE)
FONTDESC))
[SETQ CBM (BITMAPCREATE (SETQ CWDTH (\FGETWIDTH (fetch (CHARSETINFO WIDTHS) of CSINFO)
(\CHAR8CODE CHARCODE)))
(SETQ CHGHT (FONTPROP FONTDESC (QUOTE HEIGHT)))
(fetch (BITMAP BITMAPBITSPERPIXEL) of (fetch (CHARSETINFO CHARSETBITMAP)
of CSINFO]
(BITBLT (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO)
(\FGETOFFSET (fetch (CHARSETINFO OFFSETS) of CSINFO)
(\CHAR8CODE CHARCODE))
0 CBM 0 0 CWDTH CHGHT)
(RETURN CBM])
(PUTCHARBITMAP
[LAMBDA (CHARCODE FONT NEWCHARBITMAP NEWCHARDESCENT) (* gbn "21-Feb-86 16:24")
(* stores the bitmap NEWCHARBITMAP as the character CHARCODE from the font
descriptor FONTDESC. If NEWCHARDESCENT is specified, it is the descent of the
new bitmap, and things may be moved to accomodate it.)
(OR (TYPENAMEP NEWCHARBITMAP (QUOTE BITMAP))
(\ILLEGAL.ARG NEWCHARBITMAP))
(COND
((CHARCODEP CHARCODE))
((OR (STRINGP CHARCODE)
(LITATOM CHARCODE))
(SETQ CHARCODE (CHCON1 CHARCODE)))
(T (\ILLEGAL.ARG CHARCODE)))
(PROG* ((FONTDESC (\GETFONTDESC FONT))
(CWDTH (CHARWIDTH CHARCODE FONTDESC))
(CHGHT (FONTPROP FONTDESC (QUOTE HEIGHT)))
(CDESC (FONTPROP FONTDESC (QUOTE DESCENT)))
(CASC (FONTPROP FONTDESC (QUOTE ASCENT)))
(CSINFO (\GETCHARSETINFO (\CHARSET CHARCODE)
FONTDESC))
(OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
(WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
(FONTBITMAP (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO))
(OFWIDTH (fetch (BITMAP BITMAPWIDTH) of FONTBITMAP))
(NDESCENT (OR NEWCHARDESCENT CDESC))
TEMPBITMAP NWIDTH DW NHEIGHT CHAROFFSET (BITSPERPIXEL (fetch (BITMAP BITMAPBITSPERPIXEL)
of FONTBITMAP)))
[COND
((EQ (\FGETOFFSET OFFSETS (\CHAR8CODE CHARCODE))
(\FGETOFFSET OFFSETS 255))
(* * changing the bitmap for a character which formerly pointed at the slug
character. Allocate a new bitmap character bitmap for this.)
(SETQ NWIDTH (fetch (BITMAP BITMAPWIDTH) of NEWCHARBITMAP))
(* Difference in character widths)
(SETQ NHEIGHT (IMAX (fetch (BITMAP BITMAPHEIGHT) of NEWCHARBITMAP)
(IPLUS CASC NDESCENT))) (* Allow for a new descent along with
the newimage for this formerly slug
character)
(SETQ TEMPBITMAP (BITMAPCREATE (IPLUS OFWIDTH NWIDTH)
NHEIGHT BITSPERPIXEL))
(SETQ CHAROFFSET OFWIDTH)
(BITBLT FONTBITMAP 0 0 TEMPBITMAP 0 (IMAX 0 (IDIFFERENCE NDESCENT CDESC))
OFWIDTH CHGHT) (* copy the old bitmap into the temp)
(BITBLT NEWCHARBITMAP 0 0 TEMPBITMAP CHAROFFSET 0 NWIDTH CHGHT)
(* Insert the new character at the end)
(UNINTERRUPTABLY
(\FSETWIDTH WIDTHS (\CHAR8CODE CHARCODE)
NWIDTH) (* The new character's correct width)
(\FSETOFFSET OFFSETS (\CHAR8CODE CHARCODE)
CHAROFFSET)
(replace (CHARSETINFO CHARSETBITMAP) of CSINFO with TEMPBITMAP)
(if (ILESSP CHGHT NHEIGHT)
then (* update the font descriptor to
reflect the height/descent changes)
(replace (FONTDESCRIPTOR \SFDescent) of FONTDESC with (IMAX NDESCENT
CDESC))
(replace (FONTDESCRIPTOR \SFHeight) of FONTDESC with NHEIGHT)
(replace (FONTDESCRIPTOR \SFAscent) of FONTDESC
with (IDIFFERENCE NHEIGHT (IMAX NDESCENT CDESC)))
(replace (CHARSETINFO CHARSETDESCENT) of CSINFO
with (fetch (FONTDESCRIPTOR \SFDescent) of FONTDESC))
(replace (CHARSETINFO CHARSETASCENT) of CSINFO with (fetch (
FONTDESCRIPTOR
\SFAscent)
of FONTDESC))))
(RETURN NEWCHARBITMAP))
([ILESSP CHGHT (SETQ NHEIGHT (IMAX (fetch (BITMAP BITMAPHEIGHT) of NEWCHARBITMAP)
(IPLUS CASC NDESCENT]
(* * The new character is TALLER than the existing bitmap.
Make a larger bitmap.)
(SETQ TEMPBITMAP (BITMAPCREATE OFWIDTH NHEIGHT BITSPERPIXEL))
(* Make the new bitmap)
(BITBLT FONTBITMAP 0 0 TEMPBITMAP 0 (IMAX 0 (IDIFFERENCE NDESCENT CDESC)))
(* Copy the existing bitmap into it,
adjusting for a larger descent in the
new character (if there is one))
(SETQ CHGHT NHEIGHT) (* Remember the new height for later
use)
(SETQ FONTBITMAP TEMPBITMAP) (* And forget that we made this
change.)
(UNINTERRUPTABLY
(replace (CHARSETINFO CHARSETBITMAP) of CSINFO with TEMPBITMAP)
(* Save the new bitmap, in case there
are no further problems)
(replace (FONTDESCRIPTOR \SFDescent) of FONTDESC with (IMAX NDESCENT CDESC))
(* And the new height and descent.)
(replace (FONTDESCRIPTOR \SFHeight) of FONTDESC with NHEIGHT)
(replace (FONTDESCRIPTOR \SFAscent) of FONTDESC with (IDIFFERENCE NHEIGHT
(IMAX NDESCENT CDESC))
)
(replace (CHARSETINFO CHARSETDESCENT) of CSINFO with (fetch (FONTDESCRIPTOR
\SFDescent)
of FONTDESC))
(replace (CHARSETINFO CHARSETASCENT) of CSINFO with (fetch (FONTDESCRIPTOR
\SFAscent)
of FONTDESC)))]
(COND
((NEQ CWDTH (SETQ NWIDTH (fetch (BITMAP BITMAPWIDTH) of NEWCHARBITMAP)))
(* The bitmaps differ in width;
create a new bitmap with things at the
right places, then update widths and
offsets.)
(SETQ DW (IDIFFERENCE NWIDTH CWDTH)) (* Difference in character widths)
(SETQ TEMPBITMAP (BITMAPCREATE (IPLUS OFWIDTH DW)
CHGHT BITSPERPIXEL))
(BITBLT FONTBITMAP 0 0 TEMPBITMAP 0 0 (SETQ CHAROFFSET (\FGETOFFSET OFFSETS
(\CHAR8CODE CHARCODE)))
CHGHT) (* Copy that part of the old bitmap
that's to the left of the new
character)
(BITBLT NEWCHARBITMAP 0 0 TEMPBITMAP CHAROFFSET 0 NWIDTH CHGHT)
(* Insert the new character in its
place)
(BITBLT FONTBITMAP (IPLUS CHAROFFSET CWDTH)
0 TEMPBITMAP (IPLUS CHAROFFSET NWIDTH)
0
(ADD1 (IDIFFERENCE OFWIDTH (IPLUS CHAROFFSET CWDTH)))
CHGHT)
(UNINTERRUPTABLY
(\FSETWIDTH WIDTHS (\CHAR8CODE CHARCODE)
NWIDTH) (* The new character's correct width)
[for I from (ADD1 (\CHAR8CODE CHARCODE)) to \MAXCHAR
do (* Run thru the offsets of later
characters, adjusting them for the
changed width of this character)
(\FSETOFFSET OFFSETS I (IPLUS DW (\FGETOFFSET OFFSETS I]
(replace (CHARSETINFO CHARSETBITMAP) of CSINFO with TEMPBITMAP)))
(T (BITBLT NEWCHARBITMAP 0 0 FONTBITMAP (\FGETOFFSET OFFSETS (\CHAR8CODE CHARCODE))
0 CWDTH CHGHT)))
(RETURN NEWCHARBITMAP])
(EDITCHAR
[LAMBDA (CHARCODE FONT) (* rrb "24-MAR-82 12:22")
(* calls the bitmap editor on a
character of a font)
(PROG ((FONTDESC (\GETFONTDESC FONT)))
(RETURN (PUTCHARBITMAP CHARCODE FONTDESC (EDITBM (GETCHARBITMAP CHARCODE FONTDESC])
(\AVGCHARWIDTH
[LAMBDA (FONT) (* rmk: "27-Nov-84 18:40")
(* Returns the average width of a
character, to be used in
units-to-characters approximations, as
in fixing the linelength)
(PROG ((W (CHARWIDTH (CHARCODE A)
FONT)))
(RETURN (COND
((NEQ 0 W)
W)
([NEQ 0 (SETQ W (FIXR (FTIMES .6 (FONTPROP FONT (QUOTE HEIGHT]
W)
(T 1])
(\STREAMCHARWIDTH
[LAMBDA (CHARCODE STREAM TTBL) (* JonL " 8-NOV-83 03:31")
(* Returns the width that the printed
representation of CHARCODE would
occupy if printed on STREAM, allowing
for the various escape sequences.
Used by \ECHOCHAR)
(SETQ CHARCODE (LOGAND CHARCODE \CHARMASK))
((LAMBDA (WIDTHSVECTOR)
(* Note in following that if the DDWIDTHSCACHE exists and has a 0 entry for
some character, that may someday mean that the character's glyph simply isn't
loaded; e.g., it may want #↑A)
(SETQ WIDTHSVECTOR (OR (AND (DISPLAYSTREAMP STREAM)
(SETQ WIDTHSVECTOR (ffetch IMAGEDATA of STREAM))
(ffetch DDWIDTHSCACHE of WIDTHSVECTOR))
\UNITWIDTHSVECTOR))
(SELECTC (fetch CCECHO of (\SYNCODE (fetch (TERMTABLEP TERMSA) of (OR (TERMTABLEP TTBL)
\PRIMTERMTABLE))
CHARCODE))
(INDICATE.CCE ([LAMBDA (CC)
(IPLUS (if (IGEQ CHARCODE (CHARCODE #↑@))
then (* A META charcode --
implies that the 8th bit is non-zero)
(SETQ CC (LOADBYTE CHARCODE 0 7))
(\FGETWIDTH WIDTHSVECTOR (CHARCODE #))
else 0)
(if (ILESSP CC (CHARCODE SPACE))
then (* A CONTROL charcode)
(add CC (CONSTANT (LLSH 1 6)))
(\FGETWIDTH WIDTHSVECTOR (CHARCODE ↑))
else 0)
(\FGETWIDTH WIDTHSVECTOR CC]
CHARCODE))
(SIMULATE.CCE (SELCHARQ CHARCODE
((EOL CR LF BELL)
NIL)
(ESCAPE (\FGETWIDTH WIDTHSVECTOR (CHARCODE $)))
(TAB (PROG ((SPACEWIDTH (\FGETWIDTH WIDTHSVECTOR (CHARCODE SPACE)))
(NEWXPOSITON (DSPXPOSITION NIL STREAM))
TABWIDTH)
(SETQ TABWIDTH (UNFOLD SPACEWIDTH 8))
[add NEWXPOSITON (SETQ TABWIDTH
(IDIFFERENCE TABWIDTH
(IMOD (IDIFFERENCE NEWXPOSITON
(DSPLEFTMARGIN NIL
STREAM))
TABWIDTH]
(RETURN (if (IGREATERP NEWXPOSITON (DSPRIGHTMARGIN NIL
STREAM))
then (* tab was past rightmargin, force cr.)
NIL
else TABWIDTH))))
(\FGETWIDTH WIDTHSVECTOR CHARCODE)))
(REAL.CCE (SELECTC CHARCODE
((CHARCODE (EOL CR LF))
NIL)
(ERASECHARCODE NIL)
(\FGETWIDTH WIDTHSVECTOR CHARCODE)))
(IGNORE.CCE 0)
(SHOULDNT])
(\UNITWIDTHSVECTOR
[LAMBDA NIL (* JonL " 7-NOV-83 19:23")
(SETQ \UNITWIDTHSVECTOR (\ALLOCBLOCK (UNFOLD (IPLUS \MAXCHAR 3)
WORDSPERCELL)))
(for I from 0 to (IPLUS \MAXCHAR 2) do (\PUTBASE \UNITWIDTHSVECTOR I 1))
\UNITWIDTHSVECTOR])
(\CREATEDISPLAYFONT
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* gbn: "25-Jan-86 18:02")
(PROG [(FONTDESC (create FONTDESCRIPTOR
FONTDEVICE ← DEVICE
FONTFAMILY ← FAMILY
FONTSIZE ← SIZE
FONTFACE ← FACE
\SFAscent ← 0
\SFDescent ← 0
\SFHeight ← 0
ROTATION ← ROTATION
FONTDEVICESPEC ← (LIST FAMILY SIZE FACE ROTATION DEVICE]
(RETURN (COND
((\GETCHARSETINFO CHARSET FONTDESC T)
FONTDESC)
(T NIL])
(\CREATECHARSET.DISPLAY
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC NOSLUG?)
(* kbr: " 6-Feb-86 18:15")
(* * the b/w font is built first, then colorification happens at the outside.
Should become its own device. Also, check if DISPLAYFONTCOERCIONS has ever been
documented. same for MISSINGDISPLAYFONTCOERCIONS.
Should all happen in one place.)
(* * tries to build the csinfo required for CHARSET.
Does the necessary coercions.)
(* * NOSLUG? means don't create an empty
(slug) csinfo if the charset is not found, just return NIL)
(DECLARE (GLOBALVARS DISPLAYFONTCOERCIONS MISSINGDISPLAYFONTCOERCIONS))
(* DISPLAYFONTCOERCIONS is a list of font coercions, in the form
((user-font real-font) (user-font real-font) ...)%.
Each user-font is a list of FAMILY, and optionally SIZE and CHARSET,
(e.g., (GACHA) or (GACHA 10) or (GACHA 10 143))%, and each real-font is a
similar list.)
(PROG (XCSINFO)
[SETQ XCSINFO (COND
[(PROGN (* Just recursively call ourselves to
handle entries in DISPLAYFONTCOERCIONS)
(for TRANSL in DISPLAYFONTCOERCIONS bind NEWCSINFO USRFONT
REALFONT
when (AND (SETQ USRFONT (CAR TRANSL))
(EQ FAMILY (CAR USRFONT))
(OR (NOT (CADR USRFONT))
(EQ SIZE (CADR USRFONT)))
(OR (NOT (CADDR USRFONT))
(EQ CHARSET (CADDR USRFONT)))
(SETQ REALFONT (CADR TRANSL))
(SETQ NEWCSINFO (\CREATECHARSET.DISPLAY
(OR (CAR REALFONT)
FAMILY)
(OR (CADR REALFONT)
SIZE)
FACE ROTATION DEVICE
(OR (CADDR REALFONT)
CHARSET)
FONTDESC NOSLUG?)))
do (RETURN NEWCSINFO]
((AND (EQ ROTATION 0) (* If it is available, this will force
the appropriate file to be read to
fill in the charset entry)
(\READDISPLAYFONTFILE FAMILY SIZE FACE ROTATION (QUOTE DISPLAY)
CHARSET)))
(T
(* * if we get here, the font is not directly available, either it needs to be
rotated, boldified, or italicised "by hand")
(PROG (NEWFONT XFONT XLATEDFAM CSINFO)
(RETURN (COND
[(NEQ ROTATION 0)
(* to make a rotated font (even if it is bold or whatnot)%, recursively call
fontcreate to get the unrotated font (maybe bold, etc)%, then call
\SFMAKEROTATEDFONT on the csinfo.)
(OR (MEMB ROTATION (QUOTE (90 270)))
(ERROR
"only implemented rotations are 0, 90 and 270."
ROTATION))
(COND
((SETQ XFONT (FONTCREATE FAMILY SIZE FACE 0
(QUOTE DISPLAY)
T CHARSET))
(* actually call FONTCREATE here, rather than \CREATEDISPLAYFONT or
\CREATECHARSET.DISPLAY, so that the vanilla font that is built in this process
will be cached and not repeated.)
(COND
((SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T
))
(\SFROTATECSINFO CSINFO ROTATION))
(T NIL]
((AND (EQ (fetch (FONTFACE WEIGHT) of FACE)
(QUOTE BOLD))
(SETQ XFONT
(FONTCREATE FAMILY SIZE
(create FONTFACE using FACE WEIGHT ←
(QUOTE MEDIUM))
0
(QUOTE DISPLAY)
T CHARSET)))
(* if we want a bold font, and the
medium weight font is available, build
the medium weight version then call
\SFMAKEBOLD on the csinfo)
(COND
((SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T))
(\SFMAKEBOLD CSINFO))
(T NIL)))
((AND (EQ (fetch (FONTFACE SLOPE) of FACE)
(QUOTE ITALIC))
(SETQ XFONT
(FONTCREATE FAMILY SIZE
(create FONTFACE using FACE SLOPE ←
(QUOTE REGULAR))
0
(QUOTE DISPLAY)
T CHARSET)))
(COND
((SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T))
(\SFMAKEITALIC CSINFO))
(T NIL)))
((for TRANSL in MISSINGDISPLAYFONTCOERCIONS
bind NEWCSINFO USRFONT REALFONT
when (AND (SETQ USRFONT (CAR TRANSL))
(EQ FAMILY (CAR USRFONT))
(OR (NOT (CADR USRFONT))
(EQ SIZE (CADR USRFONT)))
(OR (NOT (CADDR USRFONT))
(EQ CHARSET (CADDR USRFONT)))
(SETQ REALFONT (CADR TRANSL))
(SETQ NEWCSINFO
(\CREATECHARSET.DISPLAY
(OR (CAR REALFONT)
FAMILY)
(OR (CADR REALFONT)
SIZE)
FACE ROTATION DEVICE
(OR (CADDR REALFONT)
CHARSET)
FONTDESC NOSLUG?)))
do (RETURN NEWCSINFO)))
((NOT NOSLUG?)
(\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR
FONTAVGCHARWIDTH)
of FONTDESC)
(FONTPROP FONTDESC (QUOTE ASCENT))
(FONTPROP FONTDESC (QUOTE DESCENT))
(FONTPROP FONTDESC (QUOTE DEVICE]
[COND
((FMEMB DEVICE \COLORDISPLAYSTREAMTYPES)
(SETQ XCSINFO (\SFMAKECOLOR XCSINFO (OR (fetch (FONTFACE BACKCOLOR) of FACE)
0)
(OR (fetch (FONTFACE FORECOLOR) of FACE)
(MAXIMUMCOLOR (\DISPLAYSTREAMTYPEBPP DEVICE)))
(\DISPLAYSTREAMTYPEBPP DEVICE]
(RETURN XCSINFO])
(\BUILDSLUGCSINFO
[LAMBDA (WIDTH ASCENT DESCENT DEVICE) (* edited: "10-Dec-85 14:59")
(* * builds a csinfo which contains only the slug
(black rectangle) character)
(PROG ((CSINFO (create CHARSETINFO
CHARSETASCENT ← ASCENT
CHARSETDESCENT ← DESCENT
IMAGEWIDTHS ← (\CREATECSINFOELEMENT)))
WIDTHS OFFSETS BITMAP IMAGEWIDTHS)
(SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
(for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I WIDTH))
(SETQ IMAGEWIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
(for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I WIDTH))
[SELECTQ DEVICE
(INTERPRESS (* don't need offsets in INTERPRESS
fonts)
NIL)
(PROGN (replace (CHARSETINFO OFFSETS) of CSINFO with (SETQ OFFSETS (
\CREATECSINFOELEMENT
)))
(for I from 0 to \MAXTHINCHAR do (\FSETOFFSET OFFSETS I 0))
[replace (CHARSETINFO CHARSETBITMAP) of CSINFO with (SETQ BITMAP
(BITMAPCREATE WIDTH
(IPLUS ASCENT
DESCENT]
(BLTSHADE BLACKSHADE BITMAP 1 NIL (SUB1 WIDTH]
(RETURN CSINFO])
(\SEARCHDISPLAYFONTFILES
[LAMBDA (FAMILY SIZE FACE ROTATION) (* rrb "15-Oct-85 18:47")
(* * returns a list of the fonts that can be read in for the display device.
Rotation is ignored because it is assumed that all devices support 0 90 and 270)
(DECLARE (GLOBALVARS DISPLAYFONTEXTENSIONS DISPLAYFONTDIRECTORIES))
(SELECTQ (SYSTEMTYPE)
(J
(* OLD J code from \READDISPLAYFONT (PROG
((FONTFILE (\FONTFILENAME FAMILY SIZE FACE)) FONTDESC STRM)
(COND ((SETQ STRM (AND FONTDIRECTORIES (FINDFILE FONTFILE T FONTDIRECTORIES)))
(SETQ STRM (OPENSTREAM FONTFILE (QUOTE INPUT)))
(SETQ FONTDESC (\READJERICHOFONTFILE FAMILY SIZE FACE STRM))
(CLOSEF STRM))) (RETURN FONTDESC)))
NIL)
(D (for E FILENAMEPATTERN FONTSFOUND THISFONT THISFACE inside DISPLAYFONTEXTENSIONS
do (SETQ FILENAMEPATTERN (\FONTFILENAME FAMILY SIZE FACE E))
[for DIR inside DISPLAYFONTDIRECTORIES
do (for FONTFILE in (DIRECTORY (PACKFILENAME (QUOTE DIRECTORY)
DIR
(QUOTE BODY)
FILENAMEPATTERN))
do (OR (MEMBER (SETQ THISFONT (\FONTINFOFROMFILENAME FONTFILE (QUOTE
DISPLAY
)))
FONTSFOUND)
(COND
((AND [OR (EQ FACE (QUOTE *))
(EQUAL FACE (SETQ THISFACE (CADDR THISFONT)))
(AND (OR (EQ (CAR FACE)
(QUOTE *))
(EQ (CAR FACE)
(CAR THISFACE)))
(OR (EQ (CADR FACE)
(QUOTE *))
(EQ (CADR FACE)
(CADR THISFACE)))
(OR (EQ (CADR FACE)
(QUOTE *))
(EQ (CADR FACE)
(CADR THISFACE]
(OR (EQ FAMILY (QUOTE *))
(EQ FAMILY (CAR THISFONT))
(STRPOS "*" FAMILY)))
(* make sure the face, size, and family really match.
Family name match allows anything if the family has a * in it.
This is wrong but better than what was there before which let in anything with
the right beginning.)
(SETQ FONTSFOUND (CONS THISFONT FONTSFOUND]
finally (RETURN FONTSFOUND)))
(SHOULDNT])
(\FONTFACE
[LAMBDA (FACE NOERRORFLG DEV) (* kbr: " 6-Feb-86 18:22")
(* Takes a variety of user
specifications and converts them to a
standard FONTFACE record.)
(* b/w fontfaces are extended by an
optional "-backcolor-forecolor")
(* the atom NNN is interpreted the
same as NIL or MRR to cover up a bug
described in AR 3025, the FONTNNN bug)
(PROG (BWFACE POS OLDPOS BITSPERPIXEL BACKCOLOR FORECOLOR ANSWER)
(* First get a FONTFACE ANSWER.
*)
[SETQ ANSWER (COND
((type? FONTFACE FACE)
FACE)
((LITATOM FACE)
(OR (U-CASEP FACE)
(SETQ FACE (U-CASE FACE)))
(SETQ POS (STRPOS "-" FACE))
(COND
[POS (SETQ BWFACE (SUBATOM FACE 1 (SUB1 POS]
(T (SETQ BWFACE FACE)))
[SETQ ANSWER (SELECTQ BWFACE
((NIL MRR STANDARD NNN)
(CONSTANT (create FONTFACE)))
((ITALIC MIR)
(CONSTANT (create FONTFACE
SLOPE ← (QUOTE ITALIC))))
((BOLD BRR)
(CONSTANT (create FONTFACE
WEIGHT ← (QUOTE BOLD))))
((BOLDITALIC BIR)
(CONSTANT (create FONTFACE
WEIGHT ← (QUOTE BOLD)
SLOPE ← (QUOTE ITALIC))))
(create FONTFACE
WEIGHT ← (SELCHARQ (NTHCHARCODE FACE 1)
(M (QUOTE MEDIUM))
(B (QUOTE BOLD))
(L (QUOTE LIGHT))
(GO ERROR))
SLOPE ← (SELCHARQ (NTHCHARCODE FACE 2)
(R (QUOTE REGULAR))
(I (QUOTE ITALIC))
(GO ERROR))
EXPANSION ← (SELCHARQ (NTHCHARCODE FACE 3)
(R (QUOTE REGULAR))
(C (QUOTE COMPRESSED))
(E (QUOTE EXPANDED))
(GO ERROR]
(COND
(POS (* Color FONTFACE. *)
(SETQ OLDPOS POS)
(SETQ POS (STRPOS "-" FACE (ADD1 OLDPOS)))
(COND
((NULL POS)
(GO ERROR)))
(SETQ BITSPERPIXEL (\DISPLAYSTREAMTYPEBPP DEV))
(SETQ BACKCOLOR (COLORNUMBERP (SUBATOM FACE (ADD1 OLDPOS)
(SUB1 POS))
BITSPERPIXEL))
(SETQ OLDPOS POS)
(SETQ FORECOLOR (COLORNUMBERP (SUBATOM FACE (ADD1 OLDPOS)
-1)
BITSPERPIXEL))
(* COPY ANSWER to avoid smashing
constants. *)
(SETQ ANSWER (COPY ANSWER))
(replace (FONTFACE BACKCOLOR) of ANSWER with BACKCOLOR)
(replace (FONTFACE FORECOLOR) of ANSWER with FORECOLOR)))
ANSWER)
(T (GO ERROR] (* Coerce on or off COLOR.
*)
(SETQ ANSWER (COND
((AND (NOT (FMEMB DEV \COLORDISPLAYSTREAMTYPES))
(fetch (FONTFACE COLOR) of ANSWER))
(SETQ ANSWER (COPY ANSWER))
(replace (FONTFACE COLOR) of ANSWER with NIL)
ANSWER)
((AND (FMEMB DEV \COLORDISPLAYSTREAMTYPES)
(NULL (fetch (FONTFACE COLOR) of ANSWER)))
(SETQ FACE (COPY FACE))
(replace (FONTFACE BACKCOLOR) of ANSWER with 0)
(replace (FONTFACE FORECOLOR) of ANSWER with (MAXIMUMCOLOR (
\DISPLAYSTREAMTYPEBPP
DEV)))
ANSWER)
(T ANSWER)))
(RETURN ANSWER)
ERROR
(COND
(NOERRORFLG (RETURN NIL))
(T (\ILLEGAL.ARG FACE])
(\FONTFILENAME
[LAMBDA (FAMILY SIZE FACE EXTENSION CHARSET) (* gbn "14-Jan-86 14:56")
(* Returns the name of the file that
should contain the display raster
information for a display font)
(PACKFILENAME (QUOTE NAME)
[SELECTQ EXTENSION
(STRIKE [PACK* FAMILY SIZE [COND
((EQ FACE (QUOTE *))
(QUOTE *))
(T (CONCAT (SELECTQ (fetch WEIGHT of FACE)
(BOLD (QUOTE B))
(* (QUOTE *))
"")
(SELECTQ (fetch SLOPE of FACE)
(ITALIC (QUOTE I))
(* (QUOTE *))
""]
(COND
((OR (NULL CHARSET)
(ZEROP CHARSET))
"")
(T (* this will never exist, but return a
file name different from the charset 0
filename)
(CONCAT "C" CHARSET])
(PROGN (* DISPLAYFONT AC WD and the default
case)
(PACK* FAMILY SIZE [COND
((EQ FACE (QUOTE *))
(QUOTE *))
(T (CONCAT (SELECTQ (fetch WEIGHT of FACE)
(BOLD (QUOTE -B))
(*
(* handle the case of face being say
(* REGULAR REGULAR))
(QUOTE *))
"")
(SELECTQ (fetch SLOPE of FACE)
(ITALIC (QUOTE -I))
(* (QUOTE *))
""]
(COND
((FIXP CHARSET)
(RESETLST (RESETSAVE PRXFLG T)
(RESETSAVE (RADIX 8))
(CONCAT "-C" CHARSET)))
(CHARSET (CONCAT "-C" CHARSET))
(T "-C0"]
(QUOTE EXTENSION)
EXTENSION])
(\FONTINFOFROMFILENAME
[LAMBDA (FONTFILE DEVICE) (* rrb " 7-Nov-84 15:56")
(* returns a list of the family size
face rotation device of the font
stored in the file name FONTFILE.)
(PROG ((FILENAMELIST (UNPACKFILENAME FONTFILE))
SIZEBEG SIZEND NAME FAMILY SIZE)
(SETQ NAME (LISTGET FILENAMELIST (QUOTE NAME))) (* find where the name and size are.)
(SETQ SIZEBEG (for CH# from 1 when (NUMBERP (NTHCHAR NAME CH#)) do (RETURN CH#)))
[SETQ FAMILY (MKATOM (SUBSTRING NAME 1 (SUB1 SIZEBEG]
(SETQ SIZEND (for CH# from SIZEBEG when (NOT (NUMBERP (NTHCHAR NAME CH#)))
do (RETURN CH#)))
[SETQ SIZE (MKATOM (SUBSTRING NAME SIZEBEG (SUB1 SIZEND]
(RETURN (LIST FAMILY SIZE (SELECTQ (LISTGET FILENAMELIST (QUOTE EXTENSION))
((DISPLAYFONT AC WD)
(LIST (COND
((STRPOS "-B" NAME SIZEND NIL T)
(QUOTE BOLD))
(T (QUOTE MEDIUM)))
(COND
((STRPOS "-I" NAME SIZEND NIL)
(QUOTE ITALIC))
(T (QUOTE REGULAR)))
(QUOTE REGULAR)))
(LIST (COND
((STRPOS "B" NAME SIZEND NIL T)
(QUOTE BOLD))
(T (QUOTE MEDIUM)))
(COND
((STRPOS "I" NAME SIZEND NIL)
(QUOTE ITALIC))
(T (QUOTE REGULAR)))
(QUOTE REGULAR)))
0 DEVICE])
(\GETFONTDESC
[LAMBDA (SPEC DEVICE NOERRORFLG) (* J.Gibbons " 5-Dec-82 16:53")
(* Coerces SPEC to a fontdescriptor)
(* \GETFONTDESC HAS MACRO, BUT OLD
CALLS STILL EXIST)
(\COERCEFONTDESC SPEC DEVICE NOERRORFLG])
(\COERCEFONTDESC
[LAMBDA (SPEC STREAM NOERRORFLG) (* kbr: " 6-Feb-86 17:55")
(* Coerces SPEC to a fontdescriptor appropriate for STREAM.
Go back thru FONTCREATE for various coercions in order to make sure that the
cache gets set up)
(PROG (FONT DEVICE)
[COND
((type? FONTDESCRIPTOR SPEC)
(SETQ FONT SPEC))
[(type? FONTCLASS SPEC)
[SETQ DEVICE (COND
((NULL STREAM) (* Default is display)
(* * COULDN'T THIS BRANCH BE INTENDED TO MEAN 4DISPLAY, 8DISPLAY, 24DISPLAY?
PEOPLE PROBABLY SHOULDN'T BE CALLING \COERCEFONTDESC WITH STREAM = NIL.
*)
(QUOTE DISPLAY))
((IMAGESTREAMP STREAM)
(IMAGESTREAMTYPE STREAM))
(STREAM STREAM)
(T (* I don't think this case should be
allowed. *)
(QUOTE DISPLAY]
[SETQ FONT (SELECTQ DEVICE
(DISPLAY (fetch (FONTCLASS DISPLAYFD) of SPEC))
(INTERPRESS (fetch (FONTCLASS INTERPRESSFD) of SPEC))
(PRESS (fetch (FONTCLASS PRESSFD) of SPEC))
(CDR (ASSOC DEVICE (fetch (FONTCLASS OTHERFDS) of SPEC]
(RETURN (COND
((type? FONTDESCRIPTOR FONT) (* We don't always create FD's for
devices before they are needed, so do
it now and save result)
FONT)
[(NULL FONT) (* NIL means create FONT but don't
cache. *)
(COND
((AND (FMEMB DEVICE \DISPLAYSTREAMTYPES)
(SETQ FONT (\COERCEFONTDESC SPEC (QUOTE DISPLAY)
NOERRORFLG))
(SETQ FONT (FONTCOPY FONT (QUOTE DEVICE)
STREAM
(QUOTE NOERROR)
NOERRORFLG)))
(* Coerce existing black & white font
to color font, but don't cache.
*)
FONT)
[(EQ SPEC DEFAULTFONT) (* Break cycles with NIL in the
defaultfont)
(COND
(NOERRORFLG NIL)
((EQ DEVICE (QUOTE DISPLAY))(* Function DEFAULTFONT guarantees
system integrity)
(DEFAULTFONT (QUOTE DISPLAY)))
(T (ERROR (CONCAT DEVICE " component for DEFAULTFONT undefined"]
(T (FONTCREATE DEFAULTFONT NIL NIL NIL STREAM NOERRORFLG]
((SETQ FONT (FONTCREATE FONT NIL NIL NIL STREAM NOERRORFLG))
(* Might get NIL if NOERRORFLG)
(SETFONTCLASSCOMPONENT SPEC DEVICE FONT]
((NULL SPEC)
(RETURN (\COERCEFONTDESC DEFAULTFONT STREAM NOERRORFLG)))
((OR (IMAGESTREAMP SPEC)
(type? WINDOW SPEC))
(SETQ FONT (DSPFONT NIL SPEC)))
(T
(* If called with NOERRORFLG=T (e.g. from DSPFONT) we want to suppress invalid
arg errors as well as font not found, so we can move on to other possible
coercions.)
(RETURN (FONTCREATE SPEC NIL NIL NIL STREAM NOERRORFLG]
(* Here if arg was a fontdescriptor or
imagestream)
(RETURN (COND
((NULL STREAM) (* NIL device doesn't default to
display if a fully-specified font was
found)
FONT)
([OR (EQ STREAM (fetch (FONTDESCRIPTOR FONTDEVICE) of FONT))
(AND (type? STREAM STREAM)
(EQ (fetch (IMAGEOPS IMFONTCREATE) of (fetch (STREAM IMAGEOPS)
of STREAM))
(fetch (FONTDESCRIPTOR FONTDEVICE) of FONT]
FONT)
(T (* Here if doesn't match or if DEVICE
is not explicitly a stream.)
(FONTCOPY FONT (QUOTE DEVICE)
STREAM
(QUOTE NOERROR)
NOERRORFLG])
(\LOOKUPFONT
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* rmk: "25-SEP-81 22:42")
(* looks up a font in the internal
cache. SASSOC for listp FACE)
(DECLARE (GLOBALVARS \FONTSINCORE))
(CDR (FASSOC DEVICE (CDR (FASSOC ROTATION (CDR (SASSOC FACE (CDR (FASSOC SIZE
(CDR (FASSOC FAMILY
\FONTSINCORE])
(\LOOKUPFONTSINCORE
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* rrb "25-Sep-84 12:10")
(* * returns a list of the fonts that are available in core.
* is used to match anything.)
(DECLARE (GLOBALVARS \FONTSINCORE))
(for FAMBUCKET in \FONTSINCORE when (OR (EQ FAMILY (QUOTE *))
(EQ FAMILY (CAR FAMBUCKET)))
join (for SIZEBUCKET in (CDR FAMBUCKET) when (OR (EQ SIZE (QUOTE *))
(EQ SIZE (CAR SIZEBUCKET)))
join (for FACEBUCKET in (CDR SIZEBUCKET) when (OR (EQ FACE (QUOTE *))
(EQUAL FACE (CAR FACEBUCKET)))
join (for ROTBUCKET in (CDR FACEBUCKET)
when (OR (EQ ROTATION (QUOTE *))
(EQ ROTATION (CAR ROTBUCKET)))
join (for DEVBUCKET in (CDR ROTBUCKET)
when (OR (EQ DEVICE (QUOTE *))
(EQ DEVICE (CAR DEVBUCKET)))
collect (LIST (CAR FAMBUCKET)
(CAR SIZEBUCKET)
(CAR FACEBUCKET)
(CAR ROTBUCKET)
(CAR DEVBUCKET])
(\READDISPLAYFONTFILE
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* gbn " 6-Aug-85 20:17")
(DECLARE (GLOBALVARS DISPLAYFONTEXTENSIONS DISPLAYFONTDIRECTORIES))
(bind FONTFILE CSINFO STRM for EXT inside DISPLAYFONTEXTENSIONS
when (SETQ FONTFILE (FINDFILE (\FONTFILENAME FAMILY SIZE FACE EXT CHARSET)
T DISPLAYFONTDIRECTORIES))
do (SETQ STRM (OPENSTREAM FONTFILE (QUOTE INPUT)))
[RESETLST (SETQ CSINFO (SELECTQ (FONTFILEFORMAT STRM T)
(STRIKE (RESETSAVE NIL (LIST (FUNCTION CLOSEF)
STRM))
(\READSTRIKEFONTFILE STRM FAMILY SIZE FACE))
(AC (* CLOSEF is guaranteed inside
\READACFONTFILE, against the
possibility that we have to copy to
make randaccessp)
(\READACFONTFILE STRM FAMILY SIZE FACE))
(PROG1 (CLOSEF STRM)
(SHOULDNT) (* This would get done by RESETSAVE if
AC's were read sequentially and we
could factor the RESETSAVE)
]
(* If not a recognizable format, I guess we should keep looking for another
possible extension, altho it would also be nice to tell the user that he has a
bogus file.)
(RETURN CSINFO])
(\SFMAKEBOLD
[LAMBDA (CSINFO) (* gbn "25-Jul-85 04:52")
(PROG* ((OLDCHARBITMAP (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO))
(WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
(OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
(HEIGHT (IPLUS (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)
(fetch (CHARSETINFO CHARSETDESCENT) of CSINFO)))
NEWCHARBITMAP OFFSET UNKNOWNOFFSET UNKNOWNWIDTH)
(SETQ NEWCHARBITMAP (BITMAPCREATE (fetch BITMAPWIDTH of OLDCHARBITMAP)
(fetch BITMAPHEIGHT of OLDCHARBITMAP)))
(SETQ UNKNOWNOFFSET (\FGETOFFSET OFFSETS (ADD1 \MAXCHAR)))
(SETQ UNKNOWNWIDTH (\FGETWIDTH WIDTHS (ADD1 \MAXCHAR)))
[for I from 0 to \MAXCHAR do (COND
((EQ (SETQ OFFSET (\FGETOFFSET OFFSETS I))
UNKNOWNOFFSET)
(* if this is the magic charcode with
the slug image (charcode 256) then
leave it alone)
NIL)
(T (* overlap two blts to produce bold
effect)
(BITBLT OLDCHARBITMAP OFFSET 0 NEWCHARBITMAP OFFSET 0
(\FGETWIDTH WIDTHS I)
HEIGHT
(QUOTE INPUT)
(QUOTE REPLACE))
(BITBLT OLDCHARBITMAP OFFSET 0 NEWCHARBITMAP
(ADD1 OFFSET)
0
(SUB1 (\FGETWIDTH WIDTHS I))
HEIGHT
(QUOTE INPUT)
(QUOTE PAINT]
(* fill in the slug for the magic
charcode)
(BITBLT OLDCHARBITMAP UNKNOWNOFFSET 0 NEWCHARBITMAP UNKNOWNOFFSET 0 UNKNOWNWIDTH HEIGHT
(QUOTE INPUT)
(QUOTE REPLACE))
(RETURN (create CHARSETINFO using CSINFO CHARSETBITMAP ← NEWCHARBITMAP])
(\SFMAKEITALIC
[LAMBDA (CSINFO) (* gbn "18-Sep-85 17:57")
(PROG ((WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
(OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
(ASCENT (fetch (CHARSETINFO CHARSETASCENT) of CSINFO))
(DESCENT (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO))
(OLDBITMAP (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO))
HEIGHT OFFSET NEWBITMAP WIDTH UNKNOWNOFFSET UNKNOWNWIDTH N M R XN XX YN YX)
(SETQ HEIGHT (IPLUS ASCENT DESCENT))
(SETQ NEWBITMAP (BITMAPCREATE (fetch BITMAPWIDTH of OLDBITMAP)
(fetch BITMAPHEIGHT of OLDBITMAP)))
(SETQ UNKNOWNOFFSET (\FGETOFFSET OFFSETS (ADD1 \MAXTHINCHAR)))
(SETQ UNKNOWNWIDTH (\FGETWIDTH WIDTHS (ADD1 \MAXTHINCHAR)))
(SETQ N (IDIFFERENCE 0 (IQUOTIENT (IPLUS DESCENT 3)
4)))
(SETQ M (IQUOTIENT (IPLUS ASCENT 3)
4))
[for I from 0 to \MAXTHINCHAR
do (COND
((EQ (SETQ OFFSET (\FGETOFFSET OFFSETS I))
UNKNOWNOFFSET) (* if this is the magic charcode with
the slug image (charcode 256) then
leave it alone)
NIL)
(T (SETQ WIDTH (\FGETWIDTH WIDTHS I))
(for J from N to M do (SETQ R (IPLUS OFFSET WIDTH))
(SETQ XN (IMIN R (IMAX (IPLUS OFFSET J)
0)))
(SETQ XX (IMIN R (IMAX (IPLUS R J)
0)))
[SETQ YN (IMAX 0 (IPLUS DESCENT (ITIMES J 4]
[SETQ YX (IMIN HEIGHT (IPLUS DESCENT
(IPLUS (ITIMES J 4)
4]
(COND
((AND (IGREATERP XX XN)
(IGREATERP YX YN))
(BITBLT OLDBITMAP OFFSET YN NEWBITMAP XN YN
(IDIFFERENCE XX XN)
(IDIFFERENCE YX YN)
(QUOTE INPUT)
(QUOTE REPLACE]
(BITBLT OLDBITMAP UNKNOWNOFFSET 0 NEWBITMAP UNKNOWNOFFSET 0 UNKNOWNWIDTH HEIGHT
(QUOTE INPUT)
(QUOTE REPLACE))
(RETURN (create CHARSETINFO using CSINFO CHARSETBITMAP ← NEWBITMAP])
(\SFMAKEROTATEDFONT
[LAMBDA (FONTDESC ROTATION) (* jds " 4-Jan-86 05:13")
(* takes a fontdecriptor and rotates
it.)
(* 1/5/86 JDS. Masterscope claims
nobody calls this. Let's find out....)
(HELP "ROTATED fonts need to be fixed for NS Chars & New FONTDESCRIPTOR fields")
(* (create FONTDESCRIPTOR using FONTDESC
(SETQ CHARACTERBITMAP (\SFROTATEFONTCHARACTERS
(fetch (FONTDESCRIPTOR CHARACTERBITMAP) of FONTDESC) ROTATION))
(SETQ ROTATION ROTATION) (SETQ \SFOffsets
(\SFFIXOFFSETSAFTERROTATION FONTDESC ROTATION))
(SETQ FONTCHARSETVECTOR (\ALLOCBLOCK (ADD1 \MAXCHARSET) T))))
])
(\SFROTATECSINFO
[LAMBDA (CSINFO ROTATION) (* gbn "15-Sep-85 14:38")
(* takes a CHARSETINFO and rotates it
and produces a rotated equivalent one.)
(create CHARSETINFO using CSINFO CHARSETBITMAP ← (\SFROTATEFONTCHARACTERS (fetch (CHARSETINFO
CHARSETBITMAP)
of CSINFO)
ROTATION)
OFFSETS ← (\SFROTATECSINFOOFFSETS CSINFO ROTATION])
(\SFROTATEFONTCHARACTERS
[LAMBDA (CHARBITMAP ROTATION) (* rrb "28-APR-83 12:01")
(* rotate a bitmap either 90 or 270
for fonts.)
(PROG (NEWMAP (SELECT (EQ ROTATION 90))
HIGHM1 WIDEM1)
[with BITMAP CHARBITMAP (SETQ HIGHM1 (SUB1 BITMAPHEIGHT))
(SETQ WIDEM1 (SUB1 BITMAPWIDTH))
(SETQ NEWMAP (BITMAPCREATE BITMAPHEIGHT BITMAPWIDTH))
(for X from 0 to WIDEM1
do (for Y from 0 to HIGHM1 do (COND
((EQ 1 (BITMAPBIT CHARBITMAP X Y))
(COND
(SELECT (BITMAPBIT NEWMAP (IDIFFERENCE HIGHM1
Y)
X 1))
(T (BITMAPBIT NEWMAP Y (IDIFFERENCE WIDEM1 X)
1]
(RETURN NEWMAP])
(\SFFIXOFFSETSAFTERROTATION
[LAMBDA (FONTDESC ROTATION) (* jds " 4-Jan-86 05:15")
(* adjusts offsets in case where
rotation turned things around.)
(HELP "NEED TO UPDATE THIS FN TO NSCHARS & NEW FONT FIELDS")
(* (COND ((EQ ROTATION 270) (PROG ((OFFSETS
(fetch (FONTDESCRIPTOR \SFOffsets) of FONTDESC))
(WIDTHS (fetch (FONTDESCRIPTOR \SFWidths) of FONTDESC))
(BITMAPHEIGHT (BITMAPWIDTH (fetch (FONTDESCRIPTOR CHARACTERBITMAP) of FONTDESC)))
NEWOFFSETS) (SETQ NEWOFFSETS (COPYARRAY OFFSETS))
(for CHARCODE from 0 to \MAXCHAR do (SETA NEWOFFSETS CHARCODE
(IDIFFERENCE BITMAPHEIGHT (IPLUS (ELT OFFSETS CHARCODE)
(ELT WIDTHS CHARCODE))))) (* may be some problem with dummy character
representation.) (RETURN NEWOFFSETS))) (T
(fetch (FONTDESCRIPTOR \SFOffsets) of FONTDESC))))
])
(\SFROTATECSINFOOFFSETS
[LAMBDA (CSINFO ROTATION) (* gbn "15-Sep-85 14:36")
(* adjusts offsets in case where
rotation turned things around.)
(COND
((EQ ROTATION 270)
(PROG ((OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
(WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
(BITMAPHEIGHT (BITMAPWIDTH (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO)))
NEWOFFSETS)
(SETQ NEWOFFSETS (\CREATECSINFOELEMENT))
[for CHARCODE from 0 to \MAXCHAR do (\FSETOFFSET NEWOFFSETS CHARCODE
(IDIFFERENCE BITMAPHEIGHT
(IPLUS (\FGETOFFSET OFFSETS CHARCODE)
(\FGETWIDTH WIDTHS CHARCODE]
(* may be some problem with dummy
character representation.)
(RETURN NEWOFFSETS)))
(T (fetch (CHARSETINFO OFFSETS) of CSINFO])
(\SFMAKECOLOR
[LAMBDA (BWCSINFO BACKCOLOR FORECOLOR BITSPERPIXEL) (* kbr: " 6-Feb-86 18:17")
(* makes a csinfo that has a character
bitmap that is colorized.)
(PROG (CHARACTERBITMAP COLORCSINFO)
[COND
((IMAGESTREAMP BITSPERPIXEL)
(OR BACKCOLOR (SETQ BACKCOLOR (DSPBACKCOLOR NIL BITSPERPIXEL)))
(OR FORECOLOR (SETQ FORECOLOR (DSPCOLOR NIL BITSPERPIXEL)))
(SETQ BITSPERPIXEL (IMAGESTREAMTYPE BITSPERPIXEL]
[SETQ BITSPERPIXEL (COND
((NUMBERP BITSPERPIXEL)
BITSPERPIXEL)
(T (\DISPLAYSTREAMTYPEBPP BITSPERPIXEL]
(SETQ BACKCOLOR (COLORNUMBERP BACKCOLOR BITSPERPIXEL))
(SETQ FORECOLOR (COLORNUMBERP FORECOLOR BITSPERPIXEL))
(SETQ CHARACTERBITMAP (COLORIZEBITMAP (fetch (CHARSETINFO CHARSETBITMAP) of BWCSINFO)
BACKCOLOR FORECOLOR BITSPERPIXEL))
(SETQ COLORCSINFO (create CHARSETINFO using BWCSINFO CHARSETBITMAP ← CHARACTERBITMAP))
(RETURN COLORCSINFO])
)
(/DECLAREDATATYPE (QUOTE FONTCLASS)
(QUOTE (BYTE POINTER POINTER POINTER POINTER POINTER))
(QUOTE ((FONTCLASS 0 (BITS . 7))
(FONTCLASS 0 POINTER)
(FONTCLASS 2 POINTER)
(FONTCLASS 4 POINTER)
(FONTCLASS 6 POINTER)
(FONTCLASS 8 POINTER)))
(QUOTE 10))
(/DECLAREDATATYPE (QUOTE FONTDESCRIPTOR)
(QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD
WORD WORD SIGNEDWORD SIGNEDWORD SIGNEDWORD SIGNEDWORD (BITS 8)
POINTER POINTER POINTER POINTER POINTER WORD POINTER POINTER POINTER))
(QUOTE ((FONTDESCRIPTOR 0 POINTER)
(FONTDESCRIPTOR 2 POINTER)
(FONTDESCRIPTOR 4 POINTER)
(FONTDESCRIPTOR 6 POINTER)
(FONTDESCRIPTOR 8 POINTER)
(FONTDESCRIPTOR 10 POINTER)
(FONTDESCRIPTOR 12 POINTER)
(FONTDESCRIPTOR 14 POINTER)
(FONTDESCRIPTOR 16 (BITS . 15))
(FONTDESCRIPTOR 17 (BITS . 15))
(FONTDESCRIPTOR 18 (BITS . 15))
(FONTDESCRIPTOR 19 (BITS . 15))
(FONTDESCRIPTOR 20 (BITS . 15))
(FONTDESCRIPTOR 21 (BITS . 15))
(FONTDESCRIPTOR 22 (SIGNEDBITS . 15))
(FONTDESCRIPTOR 23 (SIGNEDBITS . 15))
(FONTDESCRIPTOR 24 (SIGNEDBITS . 15))
(FONTDESCRIPTOR 25 (SIGNEDBITS . 15))
(FONTDESCRIPTOR 14 (BITS . 7))
(FONTDESCRIPTOR 26 POINTER)
(FONTDESCRIPTOR 28 POINTER)
(FONTDESCRIPTOR 30 POINTER)
(FONTDESCRIPTOR 32 POINTER)
(FONTDESCRIPTOR 34 POINTER)
(FONTDESCRIPTOR 36 (BITS . 15))
(FONTDESCRIPTOR 38 POINTER)
(FONTDESCRIPTOR 40 POINTER)
(FONTDESCRIPTOR 42 POINTER)))
(QUOTE 44))
(/DECLAREDATATYPE (QUOTE CHARSETINFO)
(QUOTE (POINTER POINTER POINTER POINTER POINTER WORD WORD))
(QUOTE ((CHARSETINFO 0 POINTER)
(CHARSETINFO 2 POINTER)
(CHARSETINFO 4 POINTER)
(CHARSETINFO 6 POINTER)
(CHARSETINFO 8 POINTER)
(CHARSETINFO 10 (BITS . 15))
(CHARSETINFO 11 (BITS . 15))))
(QUOTE 12))
[ADDTOVAR SYSTEMRECLST
(DATATYPE FONTCLASS ((PRETTYFONT# BYTE)
DISPLAYFD PRESSFD INTERPRESSFD OTHERFDS FONTCLASSNAME))
(DATATYPE FONTDESCRIPTOR ((FONTDEVICE POINTER)
(\SFObsolete1 POINTER)
(FONTFAMILY POINTER)
(FONTSIZE POINTER)
(FONTFACE POINTER)
(\SFObsolete2 POINTER)
(\SFObsolete3 POINTER)
(\SFObsolete4 POINTER)
(\SFObsolete5 WORD)
(\SFObsolete6 WORD)
(\SFAscent WORD)
(\SFDescent WORD)
(\SFHeight WORD)
(ROTATION WORD)
(FBBOX SIGNEDWORD)
(FBBOY SIGNEDWORD)
(FBBDX SIGNEDWORD)
(FBBDY SIGNEDWORD)
(\SFFACECODE BITS 8)
(\SFLKerns POINTER)
(\SFRWidths POINTER)
(FONTDEVICESPEC POINTER)
(OTHERDEVICEFONTPROPS POINTER)
(FONTSCALE POINTER)
(FONTAVGCHARWIDTH WORD)
(FONTIMAGEWIDTHS POINTER)
(FONTCHARSETVECTOR POINTER)
(FONTEXTRAFIELD2 POINTER)))
(DATATYPE CHARSETINFO (WIDTHS OFFSETS IMAGEWIDTHS CHARSETBITMAP YWIDTHS (CHARSETASCENT WORD)
(CHARSETDESCENT WORD)))
]
(RPAQ? \FONTSINCORE )
(RPAQ? \DEFAULTDEVICEFONTS )
(RPAQ? \UNITWIDTHSVECTOR )
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS DISPLAYFONTDIRECTORIES \DEFAULTDEVICEFONTS \UNITWIDTHSVECTOR)
)
(\UNITWIDTHSVECTOR)
(DECLARE: EVAL@COMPILE
(RPAQQ NORUNCODE 255)
(CONSTANTS (NORUNCODE 255))
)
(* FOLLOWING DEFINITIONS EXPORTED)
(DEFOPTIMIZER FONTPROP (&REST ARGS) (SELECTQ (AND (EQ (CAADR ARGS)
(QUOTE QUOTE))
(CADADR ARGS))
(ASCENT (LIST (QUOTE FONTASCENT)
(CAR ARGS)))
(DESCENT (LIST (QUOTE FONTDESCENT)
(CAR ARGS)))
(HEIGHT (LIST (QUOTE FONTHEIGHT)
(CAR ARGS)))
(QUOTE IGNOREMACRO)))
(* END EXPORTED DEFINITIONS)
(DECLARE: DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
[DECLARE: EVAL@COMPILE
(DATATYPE FONTCLASS ((PRETTYFONT# BYTE)
DISPLAYFD PRESSFD INTERPRESSFD OTHERFDS FONTCLASSNAME))
(DATATYPE FONTDESCRIPTOR ((FONTDEVICE POINTER)
(\SFObsolete1 POINTER) (* WAS CHARACTERBITMAP)
(* Bitmap containing the character
images, indexed by \SFOffsets)
(FONTFAMILY POINTER)
(FONTSIZE POINTER)
(FONTFACE POINTER)
(\SFObsolete2 POINTER) (* Was \SFWidths)
(* The advance-width of each character, an array indexed by charcode.
Usually the same as the imagewidth, but can differ for accents, kerns kerns.
This is what should be used for stringwidth calculations.)
(\SFObsolete3 POINTER) (* WAS \SFOffsets)
(* Offset of each character into the
image bitmap; X value of left edge)
(\SFObsolete4 POINTER) (* Was \SFWidthsY)
(\SFObsolete5 WORD) (* WAS FIRSTCHAR)
(* Charcode of the first character
that exists in the font)
(\SFObsolete6 WORD) (* WAS LASTCHAR)
(* Charcode of the last character that
exists in the font)
(\SFAscent WORD)
(\SFDescent WORD)
(\SFHeight WORD)
(ROTATION WORD)
(FBBOX SIGNEDWORD)
(FBBOY SIGNEDWORD)
(FBBDX SIGNEDWORD)
(FBBDY SIGNEDWORD)
(\SFFACECODE BITS 8)
(\SFLKerns POINTER)
(\SFRWidths POINTER)
(FONTDEVICESPEC POINTER) (* Holds the spec by which the font is
known to the printing device, if
coercion has been done)
(OTHERDEVICEFONTPROPS POINTER) (* For individual devices to hang
special information)
(FONTSCALE POINTER)
(FONTAVGCHARWIDTH WORD) (* Set in FONTCREATE, used to fix up
the linelength when DSPFONT is called)
(FONTIMAGEWIDTHS POINTER) (* This is the image width, as opposed
to the advanced width;
initial hack for accents, kerning.
Fields is referenced by FONTCREATE.)
(FONTCHARSETVECTOR POINTER)
(* A 256-pointer block, with one pointer per "character set" --each group of
256 character codes. Each pointer is either NIL if there's no info for that
charset, or is a CHARSETINFO, containing widths, char bitmap, etc for the
characters in that charset.)
(FONTEXTRAFIELD2 POINTER))
FONTCHARSETVECTOR ← (\CREATEFONTCHARSETVECTOR))
(RECORD FONTFACE (WEIGHT SLOPE EXPANSION)
(ACCESSFNS ((COLOR (CDDDR DATUM)
(RPLACD (CDDR DATUM)
NEWVALUE))
(BACKCOLOR (COND
((CDDDR DATUM)
(CAR (CDDDR DATUM))))
(PROGN (COND
((NULL (CDDDR DATUM))
(RPLACD (CDDR DATUM)
(LIST NIL NIL))))
(RPLACA (CDDDR DATUM)
NEWVALUE)))
(FORECOLOR (COND
((CDDDR DATUM)
(CADR (CDDDR DATUM))))
(PROGN (COND
((NULL (CDDDR DATUM))
(RPLACD (CDDR DATUM)
(LIST NIL NIL))))
(RPLACA (CDR (CDDDR DATUM))
NEWVALUE)))))
WEIGHT ← (QUOTE MEDIUM)
SLOPE ← (QUOTE REGULAR)
EXPANSION ← (QUOTE REGULAR)
(TYPE? LISTP))
(DATATYPE CHARSETINFO (WIDTHS
(* The advance-width of each character, an array indexed by charcode.
Usually the same as the imagewidth, but can differ for accents, kerns kerns.
This is what should be used for stringwidth calculations.)
OFFSETS (* Offset of each character into the
image bitmap; X value of left edge)
IMAGEWIDTHS (* imagewidths is not automagically
allocated since it is not always
needed)
CHARSETBITMAP (* Bitmap containing the character
images, indexed by OFFSETS)
YWIDTHS
(CHARSETASCENT WORD) (* Max ascent for all characters in
this CHARSET)
(CHARSETDESCENT WORD) (* Max descent for all characters in
this CHARSET)
)
WIDTHS ← (\CREATECSINFOELEMENT)
OFFSETS ← (\CREATECSINFOELEMENT))
]
(/DECLAREDATATYPE (QUOTE FONTCLASS)
(QUOTE (BYTE POINTER POINTER POINTER POINTER POINTER))
(QUOTE ((FONTCLASS 0 (BITS . 7))
(FONTCLASS 0 POINTER)
(FONTCLASS 2 POINTER)
(FONTCLASS 4 POINTER)
(FONTCLASS 6 POINTER)
(FONTCLASS 8 POINTER)))
(QUOTE 10))
(/DECLAREDATATYPE (QUOTE FONTDESCRIPTOR)
(QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD
WORD WORD SIGNEDWORD SIGNEDWORD SIGNEDWORD SIGNEDWORD (BITS 8)
POINTER POINTER POINTER POINTER POINTER WORD POINTER POINTER POINTER))
(QUOTE ((FONTDESCRIPTOR 0 POINTER)
(FONTDESCRIPTOR 2 POINTER)
(FONTDESCRIPTOR 4 POINTER)
(FONTDESCRIPTOR 6 POINTER)
(FONTDESCRIPTOR 8 POINTER)
(FONTDESCRIPTOR 10 POINTER)
(FONTDESCRIPTOR 12 POINTER)
(FONTDESCRIPTOR 14 POINTER)
(FONTDESCRIPTOR 16 (BITS . 15))
(FONTDESCRIPTOR 17 (BITS . 15))
(FONTDESCRIPTOR 18 (BITS . 15))
(FONTDESCRIPTOR 19 (BITS . 15))
(FONTDESCRIPTOR 20 (BITS . 15))
(FONTDESCRIPTOR 21 (BITS . 15))
(FONTDESCRIPTOR 22 (SIGNEDBITS . 15))
(FONTDESCRIPTOR 23 (SIGNEDBITS . 15))
(FONTDESCRIPTOR 24 (SIGNEDBITS . 15))
(FONTDESCRIPTOR 25 (SIGNEDBITS . 15))
(FONTDESCRIPTOR 14 (BITS . 7))
(FONTDESCRIPTOR 26 POINTER)
(FONTDESCRIPTOR 28 POINTER)
(FONTDESCRIPTOR 30 POINTER)
(FONTDESCRIPTOR 32 POINTER)
(FONTDESCRIPTOR 34 POINTER)
(FONTDESCRIPTOR 36 (BITS . 15))
(FONTDESCRIPTOR 38 POINTER)
(FONTDESCRIPTOR 40 POINTER)
(FONTDESCRIPTOR 42 POINTER)))
(QUOTE 44))
(/DECLAREDATATYPE (QUOTE CHARSETINFO)
(QUOTE (POINTER POINTER POINTER POINTER POINTER WORD WORD))
(QUOTE ((CHARSETINFO 0 POINTER)
(CHARSETINFO 2 POINTER)
(CHARSETINFO 4 POINTER)
(CHARSETINFO 6 POINTER)
(CHARSETINFO 8 POINTER)
(CHARSETINFO 10 (BITS . 15))
(CHARSETINFO 11 (BITS . 15))))
(QUOTE 12))
(DECLARE: EVAL@COMPILE
(PUTPROPS FONTASCENT MACRO ((FONTSPEC)
(ffetch \SFAscent of (\GETFONTDESC FONTSPEC))))
(PUTPROPS FONTDESCENT MACRO ((FONTSPEC)
(ffetch \SFDescent of (\GETFONTDESC FONTSPEC))))
(PUTPROPS FONTHEIGHT MACRO ((FONTSPEC)
(ffetch \SFHeight of (\GETFONTDESC FONTSPEC))))
(PUTPROPS \FGETOFFSET DMACRO ((OFFSETSBLOCK CHAR8CODE)
(\GETBASE OFFSETSBLOCK CHAR8CODE)))
(PUTPROPS \FSETOFFSET DMACRO ((OFFSETSBLOCK CHAR8CODE OFFSET)
(\PUTBASE OFFSETSBLOCK CHAR8CODE OFFSET)))
(PUTPROPS \FGETWIDTH DMACRO ((WIDTHSBLOCK CHAR8CODE)
(\GETBASE WIDTHSBLOCK CHAR8CODE)))
(PUTPROPS \FSETWIDTH DMACRO ((WIDTHSBLOCK INDEX WIDTH)
(\PUTBASE WIDTHSBLOCK INDEX WIDTH)))
(PUTPROPS \FGETCHARWIDTH MACRO (OPENLAMBDA (FONTDESC CHARCODE)
(\FGETWIDTH (ffetch (CHARSETINFO WIDTHS)
of
(\GETCHARSETINFO (\CHARSET CHARCODE)
FONTDESC))
(\CHAR8CODE CHARCODE))))
(PUTPROPS \FGETIMAGEWIDTH MACRO ((IMAGEWIDTHSBLOCK CHAR8CODE)
(\GETBASE IMAGEWIDTHSBLOCK CHAR8CODE)))
(PUTPROPS \FSETIMAGEWIDTH DMACRO ((WIDTHSBLOCK INDEX WIDTH)
(\PUTBASE WIDTHSBLOCK INDEX WIDTH)))
(PUTPROPS \GETCHARSETINFO MACRO ((CHARSET FONTDESC NOSLUG?)
(* * fetches the charsetinfo for charset CHARSET in fontdescriptor
FONTDESC. If NIL, then creates the required charset.)
(* * NOSLUG? means don't create an empty (slug)
csinfo if the charset is not found, just return NIL)
(OR (\GETBASEPTR (ffetch FONTCHARSETVECTOR of FONTDESC)
(UNFOLD CHARSET 2))
(\CREATECHARSET CHARSET FONTDESC NOSLUG?))))
(PUTPROPS \CREATECSINFOELEMENT MACRO (NIL (\ALLOCBLOCK (FOLDHI (IPLUS \MAXTHINCHAR 3)
WORDSPERCELL))))
(PUTPROPS \CREATEFONTCHARSETVECTOR MACRO (NIL (* Allocates a block for the character set records)
(\ALLOCBLOCK (ADD1 \MAXCHARSET)
T)))
)
(DECLARE: EVAL@COMPILE
(RPAQQ \MAXNSCHAR 65535)
(CONSTANTS (\MAXNSCHAR 65535))
)
(* END EXPORTED DEFINITIONS)
)
(* NS Character specific code)
(DEFINEQ
(\CREATECHARSET
[LAMBDA (CHARSET FONT NOSLUG?) (* kbr: " 6-Feb-86 18:24")
(* Creates and returns the CHARSETINFO
for charset CHARSET in fontdesc FONT,
installing it in fonts
FONTCHARSETVECTOR)
(* NOSLUG? means don't create an empty
(slug) csinfo if the charset is not
found, just return NIL)
(AND (IGREATERP CHARSET \MAXCHARSET)
(\ILLEGAL.ARG CHARSET))
(PROG (CSINFO CREATEFN) (* For other charsets, create a font
descriptor of info for that charset,
and use it to fill things in.)
[COND
[(OR (AND (IGEQ CHARSET 1)
(ILEQ CHARSET 32))
(AND (IGEQ CHARSET 127)
(ILEQ CHARSET 160))) (* this is an illegal NS character set
(reserved for control codes) so just
return a slug (unless NOSLUG? is T))
(COND
(NOSLUG? (RETURN NIL))
(T (SETQ CSINFO (\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR FONTAVGCHARWIDTH)
of FONT)
(FONTPROP FONT (QUOTE ASCENT))
(FONTPROP FONT (QUOTE DESCENT))
(FONTPROP FONT (QUOTE DEVICE]
(T [SETQ CREATEFN (COND
((FMEMB (FONTPROP FONT (QUOTE DEVICE))
\DISPLAYSTREAMTYPES)
(FUNCTION \CREATECHARSET.DISPLAY))
(T (CADR (ASSOC (QUOTE CREATECHARSET)
(CDR (ASSOC (FONTPROP FONT (QUOTE DEVICE))
IMAGESTREAMTYPES]
[COND
([NOT (SETQ CSINFO (APPLY CREATEFN (APPEND (FONTPROP FONT (QUOTE DEVICESPEC))
(LIST CHARSET FONT NOSLUG?]
(* the create method returned NIL.
so if NOSLUG? return NIL else build a
slug charsetinfo)
(RETURN (COND
(NOSLUG? (* the caller just wants NIL back to
signal that nothing was found)
NIL)
(T (\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR FONTAVGCHARWIDTH)
of FONT)
(FONTPROP FONT (QUOTE ASCENT))
(FONTPROP FONT (QUOTE HEIGHT))
(FONTPROP FONT (QUOTE DEVICE]
(replace \SFAscent of FONT with (IMAX (fetch \SFAscent of FONT)
(fetch CHARSETASCENT of CSINFO)))
(replace \SFDescent of FONT with (IMAX (fetch \SFDescent of FONT)
(ffetch CHARSETDESCENT of CSINFO)))
(replace \SFHeight of FONT with (IMAX (fetch \SFHeight of FONT)
(IPLUS (fetch CHARSETASCENT of CSINFO)
(ffetch CHARSETDESCENT of CSINFO]
(RETURN (\SETCHARSETINFO (ffetch FONTCHARSETVECTOR of FONT)
CHARSET CSINFO])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS DISPLAYFONTCOERCIONS MISSINGDISPLAYFONTCOERCIONS CHARSETERRORFLG)
)
(RPAQ? DISPLAYFONTCOERCIONS NIL)
(RPAQ? MISSINGDISPLAYFONTCOERCIONS (QUOTE (((GACHA)
(TERMINAL))
((MODERN)
(CLASSIC))
((TIMESROMAN)
(CLASSIC))
((HELVETICA)
(MODERN)))))
(RPAQ? CHARSETERRORFLG NIL)
(RPAQ? \DEFAULTCHARSET 0)
(DEFINEQ
(\FONTRESETCHARWIDTHS
[LAMBDA (CSINFO FIRSTCHAR LASTCHAR) (* AJB " 6-Dec-85 14:42")
(* sets the widths array from the
offsets array)
(PROG ((mincharcode FIRSTCHAR)
(maxcharcode LASTCHAR)
(offsets (fetch (CHARSETINFO OFFSETS) of CSINFO))
(widths (fetch (CHARSETINFO WIDTHS) of CSINFO))
left right charoffset dummycharoffset dummycharwidth)
(SETQ dummycharoffset (\FGETOFFSET offsets (ADD1 maxcharcode)))
(SETQ dummycharwidth (IDIFFERENCE (\FGETOFFSET offsets (IPLUS maxcharcode 2))
dummycharoffset))
[for charcode from 0 to \MAXCHAR do (COND
((OR (ILESSP charcode mincharcode)
(IGREATERP charcode maxcharcode))
(\FSETOFFSET offsets charcode dummycharoffset)
(\FSETWIDTH widths charcode dummycharwidth))
(T (SETQ left (\FGETWIDTH offsets charcode))
(SETQ right (\FGETWIDTH offsets (ADD1 charcode)))
(COND
((EQ left right)
(\FSETOFFSET offsets charcode dummycharoffset
)
(\FSETWIDTH widths charcode dummycharwidth))
(T (\FSETWIDTH widths charcode
(IDIFFERENCE right left]
(\FSETWIDTH widths (ADD1 \MAXCHAR)
dummycharwidth)
(\FSETOFFSET offsets (ADD1 \MAXCHAR)
dummycharoffset])
(\READSTRIKEFONTFILE
[LAMBDA (STRM FAMILY SIZE FACE) (* AJB " 6-Dec-85 14:53")
(* STRM has already been determined to
be a vanilla strike-format file.)
(* returns a charsetinfo)
(COND
((NEQ 2 (GETFILEPTR STRM))
(SETFILEPTR STRM 2)))
(PROG (CSINFO NUMBCODES RW BITMAP OFFSETS FIRSTCHAR LASTCHAR HEIGHT WIDTHS)
(SETQ CSINFO (create CHARSETINFO))
(SETQ FIRSTCHAR (\WIN STRM)) (* minimum ascii code)
(SETQ LASTCHAR (\WIN STRM)) (* maximum ascii code)
(\WIN STRM) (* MaxWidth which isn't used by
anyone.)
(\WIN STRM) (* number of words in this StrikeBody)
(replace (CHARSETINFO CHARSETASCENT) of CSINFO with (\WIN STRM))
(* ascent in scan lines
(=FBBdy+FBBoy))
(replace (CHARSETINFO CHARSETDESCENT) of CSINFO with (\WIN STRM))
(* descent in scan-lines
(=FBBoy))
(\WIN STRM) (* offset in bits (<0 for kerning,
else 0, =FBBox))
(SETQ RW (\WIN STRM)) (* raster width of bitmap)
(* height of bitmap)
(SETQ HEIGHT (IPLUS (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)
(fetch (CHARSETINFO CHARSETDESCENT) of CSINFO)))
(SETQ BITMAP (BITMAPCREATE (UNFOLD RW BITSPERWORD)
HEIGHT))
(\BINS STRM (fetch BITMAPBASE of BITMAP)
0
(UNFOLD (ITIMES RW HEIGHT)
BYTESPERWORD)) (* read bits into bitmap)
(replace (CHARSETINFO CHARSETBITMAP) of CSINFO with BITMAP)
(SETQ NUMBCODES (IPLUS (IDIFFERENCE LASTCHAR FIRSTCHAR)
3)) (* SETQ OFFSETS (ARRAY
(IPLUS \MAXCHAR 3) (QUOTE SMALLPOSP) 0
0))
(SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
(* initialise the offsets to 0)
(for I from 0 to (IPLUS \MAXTHINCHAR 2) do (\FSETOFFSET OFFSETS I 0))
(* AIN OFFSETS FIRSTCHAR NUMBCODES
STRM)
(for I from FIRSTCHAR as J from 1 to NUMBCODES do (\FSETOFFSET OFFSETS I (\WIN STRM)))
(SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
(for I from 0 to (IPLUS \MAXTHINCHAR 2) do (\FSETWIDTH WIDTHS I 0))
(* replace WIDTHS of
(CHARSETINFO CSINFO) with
(ARRAY (IPLUS \MAXCHAR 3)
(QUOTE SMALLPOSP) 0 0))
(\FONTRESETCHARWIDTHS CSINFO FIRSTCHAR LASTCHAR)
(replace (CHARSETINFO IMAGEWIDTHS) of CSINFO with (fetch (CHARSETINFO WIDTHS) of CSINFO))
(RETURN CSINFO])
)
(DECLARE: DONTEVAL@LOAD
(RPAQ? DISPLAYFONTEXTENSIONS (QUOTE DISPLAYFONT))
(RPAQ? DISPLAYFONTDIRECTORIES (QUOTE ({ERIS}<LISPCORE>FONTS> {ERIS}<LISP>FONTS>)))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS \FGETCHARIMAGEWIDTH MACRO (OPENLAMBDA (FONT CHARCODE)
(\FGETWIDTH (ffetch (CHARSETINFO IMAGEWIDTHS)
of
(\GETCHARSETINFO (\CHARSET CHARCODE)
FONT))
(\CHAR8CODE CHARCODE))))
(PROGN (PUTPROPS \GETFONTDESC DMACRO (X (COND ((CDR X)
(CONS (QUOTE \COERCEFONTDESC)
X))
(T (BQUOTE (\DTEST (\, (CAR X))
(QUOTE FONTDESCRIPTOR)))))))
(PUTPROPS \GETFONTDESC MACRO (= . \COERCEFONTDESC)))
(PUTPROPS \SETCHARSETINFO MACRO ((CHARSETVECTOR CHARSET CSINFO)
(\RPLPTR CHARSETVECTOR (UNFOLD CHARSET 2)
CSINFO)))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(PUTPROPS FONT FILETYPE COMPILE-FILE)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA FONTCOPY)
)
(PUTPROPS FONT COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3964 13964 (CHARWIDTH 3974 . 4804) (CHARWIDTHY 4806 . 6218) (STRINGWIDTH 6220 . 7273) (
\CHARWIDTH.DISPLAY 7275 . 7803) (\STRINGWIDTH.DISPLAY 7805 . 8338) (\STRINGWIDTH.GENERIC 8340 . 13962)
) (14145 20635 (DEFAULTFONT 14155 . 15542) (FONTCLASS 15544 . 18113) (FONTCLASSUNPARSE 18115 . 19043)
(FONTCLASSCOMPONENT 19045 . 19667) (SETFONTCLASSCOMPONENT 19669 . 20633)) (20636 122366 (FONTASCENT
20646 . 20818) (FONTCOPY 20820 . 24943) (FONTCREATE 24945 . 34548) (FONTSAVAILABLE 34550 . 39971) (
FONTDESCENT 39973 . 40242) (FONTFILEFORMAT 40244 . 42176) (FONTHEIGHT 42178 . 42367) (FONTP 42369 .
42667) (FONTPROP 42669 . 46154) (FONTUNPARSE 46156 . 49207) (SETFONTDESCRIPTOR 49209 . 50936) (
CHARCODEP 50938 . 51235) (GETCHARBITMAP 51237 . 53652) (PUTCHARBITMAP 53654 . 63651) (EDITCHAR 63653
. 64094) (\AVGCHARWIDTH 64096 . 64890) (\STREAMCHARWIDTH 64892 . 69186) (\UNITWIDTHSVECTOR 69188 .
69555) (\CREATEDISPLAYFONT 69557 . 70313) (\CREATECHARSET.DISPLAY 70315 . 80946) (\BUILDSLUGCSINFO
80948 . 82855) (\SEARCHDISPLAYFONTFILES 82857 . 86362) (\FONTFACE 86364 . 93042) (\FONTFILENAME 93044
. 96502) (\FONTINFOFROMFILENAME 96504 . 98934) (\GETFONTDESC 98936 . 99391) (\COERCEFONTDESC 99393 .
105274) (\LOOKUPFONT 105276 . 105910) (\LOOKUPFONTSINCORE 105912 . 107548) (\READDISPLAYFONTFILE
107550 . 109474) (\SFMAKEBOLD 109476 . 112361) (\SFMAKEITALIC 112363 . 115524) (\SFMAKEROTATEDFONT
115526 . 116513) (\SFROTATECSINFO 116515 . 117306) (\SFROTATEFONTCHARACTERS 117308 . 118620) (
\SFFIXOFFSETSAFTERROTATION 118622 . 119732) (\SFROTATECSINFOOFFSETS 119734 . 121083) (\SFMAKECOLOR
121085 . 122364)) (139666 144235 (\CREATECHARSET 139676 . 144233)) (144899 151188 (
\FONTRESETCHARWIDTHS 144909 . 147059) (\READSTRIKEFONTFILE 147061 . 151186)))))
STOP