(FILECREATED " 6-Jul-85 22:19:24" {ERIS}<LISPCORE>SOURCES>FONT.;72 95395
changes to: (FNS \STRINGWIDTH.GENERIC)
previous date: "14-Jun-85 11:36:12" {ERIS}<LISPCORE>SOURCES>FONT.;71)
(* Copyright (c) 1981, 1982, 1983, 1984, 1985 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
\SEARCHDISPLAYFONTFILES \FONTFACE \FONTFILENAME \FONTINFOFROMFILENAME \GETFONTDESC
\COERCEFONTDESC \LOOKUPFONT \LOOKUPFONTSINCORE \READDISPLAYFONTFILE \SFMAKEBOLD
\SFMAKEITALIC \SFMAKEROTATEDFONT \SFROTATEFONTCHARACTERS \SFFIXOFFSETSAFTERROTATION)
(INITRECORDS FONTCLASS FONTDESCRIPTOR CHARSETINFO)
(SYSRECORDS FONTCLASS FONTDESCRIPTOR CHARSETINFO)
(INITVARS (\FONTSINCORE)
(\DEFAULTDEVICEFONTS)
(\UNITWIDTHSVECTOR))
(GLOBALVARS DISPLAYFONTDIRECTORIES \DEFAULTDEVICEFONTS \UNITWIDTHSVECTOR)
(P (\UNITWIDTHSVECTOR))
(EXPORT (MACROS FONTPROP))
(DECLARE: DONTCOPY (EXPORT (RECORDS FONTCLASS FONTDESCRIPTOR FONTFACE CHARSETINFO)
(MACROS FONTASCENT FONTDESCENT FONTHEIGHT \FGETOFFSET \FGETWIDTH
\GETOFFSET \GETWIDTH \FGETCHARWIDTH \FGETIMAGEWIDTH
\GETCHARSETINFO)))
(COMS (* NS Character specific code)
(FNS \CREATECHARSET)
(GLOBALVARS DISPLAYFONTCOERCIONS MISSINGDISPLAYFONTCOERCIONS CHARSETERRORFLG)
(INITVARS (DISPLAYFONTCOERCIONS NIL)
[MISSINGDISPLAYFONTCOERCIONS (QUOTE (((GACHA)
(MODERN))
((MODERN)
(CLASSIC))
((TIMESROMAN)
(CLASSIC))
((HELVETICA)
(MODERN]
(CHARSETERRORFLG NIL)))
[COMS (* Interlisp-D specific)
(FNS * DONLYFONTFNS)
[DECLARE: DONTCOPY DONTEVAL@LOAD EVAL@COMPILEWHEN (NEQ (COMPILEMODE)
(QUOTE D))
(ADDVARS * (LIST (CONS (QUOTE DONTCOMPILEFNS)
DONLYFONTFNS]
(DECLARE: DONTEVAL@LOAD COPYWHEN (EQ (COMPILEMODE)
(QUOTE D))
(INITVARS (DISPLAYFONTEXTENSIONS (QUOTE DISPLAYFONT))
(DISPLAYFONTDIRECTORIES (QUOTE ({ERIS}<LISPCORE>FONTS>
{ERIS}<LISP>FONTS>]
(COMS (* Interlisp-Jericho specific)
(FNS * JONLYFONTFNS)
[DECLARE: DONTEVAL@LOAD DONTCOPY EVAL@COMPILEWHEN (NEQ (COMPILEMODE)
(QUOTE JERICHO))
(ADDVARS * (LIST (CONS (QUOTE DONTCOMPILEFNS)
JONLYFONTFNS]
(DECLARE: DONTEVAL@LOAD COPYWHEN (EQ (COMPILEMODE)
(QUOTE JERICHO))
(VARS (DISPLAYFONTEXTENSIONS (QUOTE FONT)))
(ADDVARS (DISPLAYFONTDIRECTORIES >FONTS)))
(DECLARE: EVAL@COMPILE DONTCOPY (MACROS 2BIN \GETLKERN \GETRWIDTH)))
(MACROS \GETFONTDESC)
(LOCALVARS . T)
(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) (* rmk: " 4-Apr-85 14:49")
(* 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)))
(OR (FIXP WY)
(\FGETWIDTH WY (\CHAR8CODE CHARCODE]
((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]
(OR (FIXP WY)
(\FGETWIDTH WY (\CHAR8CODE CHARCODE])
(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: " 6-Jul-85 22:07")
(* Returns the width of STR with SPACEWIDTH for the
width of spaces. RDTBL has already been coerced, so no
FLG is needed)
(DECLARE (SPECVARS FONT SPACEWIDTH)) (* Used in \MAPCHARS)
(LET ((CSVECTOR (ffetch FONTCHARSETVECTOR of FONT)))
(DECLARE (SPECVARS CSVECTOR))
(SELECTC (NTYPX STR)
[\LITATOM (COND
[RDTBL (for C inatom STR
bind (SA ←(fetch READSA of RDTBL))
(FIRSTFLG ← T)
(PCTWIDTH ←(\FGETCHARWIDTH FONT (CHARCODE %%)
CSVECTOR))
SYN CSET WIDTHSBASE
sum [COND
((NEQ CSET (\CHARSET C))
(SETQ CSET (\CHARSET C))
(SETQ WIDTHSBASE (ffetch (CHARSETINFO WIDTHS)
of (\GETCHARSETINFO CSET FONT
CSVECTOR]
(PROG1 [IPLUS (COND
((AND (fetch (READCODE ESCQUOTE)
of (SETQ SYN (\SYNCODE SA C)))
(OR FIRSTFLG (fetch (READCODE
INNERESCQUOTE)
of SYN)))
PCTWIDTH)
(T 0))
(COND
((EQ C (CHARCODE SPACE))
SPACEWIDTH)
(T (\FGETWIDTH WIDTHSBASE (\CHAR8CODE C]
(SETQ FIRSTFLG NIL]
(T (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 CSVECTOR]
(COND
((EQ C (CHARCODE SPACE))
SPACEWIDTH)
(T (\FGETWIDTH WIDTHSBASE (\CHAR8CODE C]
[\STRINGP (COND
[RDTBL (IPLUS (UNFOLD (\FGETCHARWIDTH FONT (CHARCODE %")
CSVECTOR)
2)
(for C instring STR bind (PCTWIDTH ←(\FGETCHARWIDTH
FONT
(CHARCODE %%)
CSVECTOR))
WIDTHSBASE CSET
sum [if (NEQ CSET (\CHARSET C))
then (SETQ CSET (\CHARSET C))
(SETQ WIDTHSBASE
(ffetch (CHARSETINFO WIDTHS)
of (\GETCHARSETINFO CSET FONT CSVECTOR]
(SELCHARQ C
(SPACE SPACEWIDTH)
[(%" %%)
(IPLUS PCTWIDTH (\FGETWIDTH WIDTHSBASE
(\CHAR8CODE
C]
(\FGETWIDTH WIDTHSBASE (\CHAR8CODE C]
(T (for C WIDTHSBASE CSET instring STR
sum [COND
((NEQ CSET (\CHARSET C))
(SETQ CSET (\CHARSET C))
(SETQ WIDTHSBASE (ffetch (CHARSETINFO WIDTHS)
of (\GETCHARSETINFO CSET FONT CSVECTOR]
(COND
((EQ C (CHARCODE SPACE))
SPACEWIDTH)
(T (\FGETWIDTH WIDTHSBASE (\CHAR8CODE C]
(LET ((S 0)
WIDTHSBASE CSET)
(DECLARE (SPECVARS S CSET WIDTHSBASE))
(\MAPCHARS [FUNCTION (LAMBDA (CC)
(add S (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 CSVECTOR))
)
(\FGETWIDTH WIDTHSBASE (\CHAR8CODE CC]
STR RDTBL RDTBL)
S])
)
(* 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) (* rmk: "20-Sep-84 10:38")
(* 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 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)
(LITATOM (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 "18-Oct-84 16:35")
(* 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 (CONS (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 (* jds "14-Dec-84 07:23")
(* makes a copy of a font changing the specified
fields.)
(PROG [NOERROR FAMILY FACE SIZE ROTATION DEVICE
(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 FONTFAMILY of OLDFONT))
(SETQ SIZE (fetch FONTSIZE of OLDFONT))
(SETQ FACE (fetch FONTFACE of OLDFONT))
(SETQ ROTATION (fetch ROTATION of OLDFONT))
(SETQ DEVICE (fetch FONTDEVICE of OLDFONT))
[for I VAL from 2 by 2 to FONTSPECS
do [SETQ VAL (COND
((NEQ 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)))
(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))
)
(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) (* rmk: "18-Feb-85 10:01")
(* Cache and fonts.widths traffic in uppercase only.)
(DECLARE (GLOBALVARS IMAGESTREAMTYPES))
(PROG [FONTX (DEV (COND
((type? STREAM DEVICE)
(fetch IMFONTCREATE of (fetch IMAGEOPS of DEVICE)))
(DEVICE)
(T (QUOTE DISPLAY]
(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))
([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)
(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))
(OR (ffetch FONTIMAGEWIDTHS of FONTX)
(freplace FONTIMAGEWIDTHS of FONTX
with (ffetch \SFWidths of FONTX)))
(* We should probably force all device implementations
to obey these conventions, then remove these generic
updates)
(freplace 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 (ffetch IMFONTCREATE of (ffetch 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)
(ffetch \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) (* rmk: "27-Nov-84 18:16")
(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)))
(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) (* rmk: "16-Feb-85 10:54")
(* 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 (if [AND FACE (NOT (EQUAL FACE (QUOTE (MEDIUM REGULAR REGULAR]
then (PACK* (NTHCHAR (CAR FACE)
1)
(NTHCHAR (CADR FACE)
1)
(NTHCHAR (CADDR FACE)
1] (* Don't return device, or any trailing defaults)
(RETURN (CONS (CAR SPEC)
(CONS (CADR SPEC)
(if (AND (CADDDR SPEC)
(NEQ 0 (CADDDR SPEC)))
then (LIST (OR FACE (QUOTE MRR))
(CADDDR SPEC))
elseif FACE
then (CONS FACE])
(SETFONTDESCRIPTOR
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE FONT) (* rmk: "23-AUG-83 23:03")
(* 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 (\GETFONTDESC FONT DEVICE]
(SETQ FACE (\FONTFACE FACE))
(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) (* JonL " 7-NOV-83 16:32")
(* is CHCODE a legal character code?)
(AND (SMALLP CHCODE)
(IGEQ CHCODE 0)
(ILEQ CHCODE \MAXCHAR])
(GETCHARBITMAP
[LAMBDA (CHARCODE FONT) (* lmm "17-Aug-84 22:01")
(* 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))
(SETQ CHARCODE (CHCON1 CHARCODE)))
(T (\ILLEGAL.ARG CHARCODE)))
(PROG (CBM (FONTDESC (\GETFONTDESC FONT))
CWDTH CHGHT)
[SETQ CBM (BITMAPCREATE (SETQ CWDTH (CHARWIDTH CHARCODE FONTDESC))
(SETQ CHGHT (FONTPROP FONTDESC (QUOTE HEIGHT]
(BITBLT (fetch (FONTDESCRIPTOR CHARACTERBITMAP) of FONTDESC)
(\GETOFFSET (fetch (FONTDESCRIPTOR \SFOffsets) of FONTDESC)
CHARCODE)
0 CBM 0 0 CWDTH CHGHT)
(RETURN CBM])
(PUTCHARBITMAP
[LAMBDA (CHARCODE FONT NEWCHARBITMAP NEWCHARDESCENT) (* rmk: " 4-Apr-85 15:15")
(* 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
((OR (CHARCODEP CHARCODE)
(EQ CHARCODE 256)))
((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)))
(OFFSETS (fetch \SFOffsets of FONTDESC))
(WIDTHS (fetch \SFWidths of FONTDESC))
(FONTBITMAP (fetch (FONTDESCRIPTOR CHARACTERBITMAP) of FONTDESC))
(OFWIDTH (fetch (BITMAP BITMAPWIDTH) of FONTBITMAP))
(NDESCENT (OR NEWCHARDESCENT CDESC))
TEMPBITMAP NWIDTH DW NHEIGHT)
[COND
([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))
(* 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.)
(replace (FONTDESCRIPTOR CHARACTERBITMAP) of FONTDESC with TEMPBITMAP)
(* Save the new bitmap, in case there are no further
problems)
(replace \SFDescent of FONTDESC with (IMAX NDESCENT CDESC))
(* And the new height and descent.)
(replace \SFHeight of FONTDESC with NHEIGHT)
(replace \SFAscent of FONTDESC with (IDIFFERENCE NHEIGHT (IMAX NDESCENT CDESC]
(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 (fetch (BITMAP BITMAPWIDTH) of NEWCHARBITMAP)
CWDTH)) (* Difference in character widths)
(SETQ TEMPBITMAP (BITMAPCREATE (IPLUS OFWIDTH DW)
CHGHT))
(BITBLT FONTBITMAP 0 0 TEMPBITMAP 0 0 (\GETOFFSET OFFSETS CHARCODE)
CHGHT) (* Copy that part of the old bitmap that's to the left
of the new character)
(BITBLT NEWCHARBITMAP 0 0 TEMPBITMAP (\GETOFFSET OFFSETS CHARCODE)
0 NWIDTH CHGHT) (* Insert the new character in its place)
(BITBLT FONTBITMAP (IPLUS (\GETOFFSET OFFSETS CHARCODE)
CWDTH)
0 TEMPBITMAP (IPLUS (\GETOFFSET OFFSETS CHARCODE)
NWIDTH)
0
(ADD1 (IDIFFERENCE OFWIDTH (IPLUS (\GETOFFSET OFFSETS CHARCODE)
CWDTH)))
CHGHT)
(SETA WIDTHS CHARCODE NWIDTH) (* The new character's correct width)
[for I from (ADD1 CHARCODE) to (fetch (FONTDESCRIPTOR LASTCHAR) of FONTDESC)
do (* Run thru the offsets of later characters, adjusting
them for the changed width of this character)
(SETA OFFSETS I (IPLUS DW (ELT OFFSETS I]
(replace (FONTDESCRIPTOR CHARACTERBITMAP) of FONTDESC with TEMPBITMAP))
(T (BITBLT NEWCHARBITMAP 0 0 FONTBITMAP (\GETOFFSET (fetch (FONTDESCRIPTOR \SFOffsets)
of FONTDESC)
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) (* jds "30-Apr-85 14:35")
(* 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.)
(DECLARE (GLOBALVARS DISPLAYFONTCOERCIONS MISSINGDISPLAYFONTCOERCIONS))
(COND
((for TRANSL in DISPLAYFONTCOERCIONS bind NEWFONT USERFONT REALFONT
when [AND (SETQ USERFONT (CAR TRANSL))
(EQ FAMILY (CAR USERFONT))
(OR (NOT (CADR USERFONT))
(EQ SIZE (CADR USERFONT)))
(OR (NOT (CADDR USERFONT))
(EQ CHARSET (CADDR USERFONT)))
(SETQ REALFONT (CADR TRANSL))
(SETQ NEWFONT (\CREATEDISPLAYFONT (OR (CAR REALFONT)
FAMILY)
(OR (CADR REALFONT)
SIZE)
FACE ROTATION DEVICE (OR (CADDR REALFONT)
CHARSET]
do (replace FONTFAMILY of NEWFONT with FAMILY)
(replace FONTSIZE of NEWFONT with SIZE)
(RETURN NEWFONT)))
((AND (EQ ROTATION 0)
(\READDISPLAYFONTFILE FAMILY SIZE FACE CHARSET)))
(T (PROG (XFONT XLATEDFAM) (* deal with rotation first.)
(RETURN (COND
[(NEQ ROTATION 0)
(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))
(\SFMAKEROTATEDFONT XFONT ROTATION]
((AND (EQ (fetch WEIGHT of FACE)
(QUOTE BOLD))
(SETQ XFONT (FONTCREATE FAMILY SIZE (create FONTFACE
using FACE WEIGHT ←(QUOTE
MEDIUM))
0
(QUOTE DISPLAY)
T)))
(create FONTDESCRIPTOR using XFONT CHARACTERBITMAP ←(\SFMAKEBOLD XFONT)
FONTFACE ← FACE FONTCHARSETVECTOR ←(
\ALLOCBLOCK (ADD1 \MAXCHARSET)
T)))
((AND (EQ (fetch SLOPE of FACE)
(QUOTE ITALIC))
(SETQ XFONT (FONTCREATE FAMILY SIZE (create FONTFACE
using FACE SLOPE ←(QUOTE
REGULAR))
0
(QUOTE DISPLAY)
T)))
(create FONTDESCRIPTOR using XFONT CHARACTERBITMAP ←(\SFMAKEITALIC XFONT)
FONTFACE ← FACE FONTCHARSETVECTOR ←(
\ALLOCBLOCK (ADD1 \MAXCHARSET)
T)))
((for TRANSL in MISSINGDISPLAYFONTCOERCIONS bind NEWFONT USERFONT REALFONT
when [AND (SETQ USERFONT (CAR TRANSL))
(EQ FAMILY (CAR USERFONT))
(OR (NOT (CADR USERFONT))
(EQ SIZE (CADR USERFONT)))
(OR (NOT (CADDR USERFONT))
(EQ CHARSET (CADDR USERFONT)))
(SETQ REALFONT (CADR TRANSL))
(SETQ NEWFONT (\CREATEDISPLAYFONT (OR (CAR REALFONT)
FAMILY)
(OR (CADR REALFONT)
SIZE)
FACE ROTATION DEVICE
(OR (CADDR REALFONT)
CHARSET]
do (SETQ NEWFONT
(create FONTDESCRIPTOR
using NEWFONT FONTFAMILY ← FAMILY FONTSIZE ← SIZE
FONTCHARSETVECTOR ←(\ALLOCBLOCK (ADD1 \MAXCHARSET)
T)))
(RETURN NEWFONT)))
((AND (SETQ XLATEDFAM (SELECTQ FAMILY
(TIMESROMAN (QUOTE CLASSIC))
(HELVETICA (QUOTE MODERN))
(GACHA (QUOTE TERMINAL))
(LOGO (QUOTE LOGOTYPE))
NIL))
(SETQ XFONT (\CREATEDISPLAYFONT XLATEDFAM SIZE FACE 0 (QUOTE DISPLAY)
CHARSET)))
(create FONTDESCRIPTOR using XFONT FONTFAMILY ← FAMILY FONTDEVICESPEC ←(
LIST XLATEDFAM SIZE FACE ROTATION
(QUOTE DISPLAY))
FONTCHARSETVECTOR ←(\ALLOCBLOCK (ADD1
\MAXCHARSET)
T])
(\SEARCHDISPLAYFONTFILES
[LAMBDA (FAMILY SIZE FACE ROTATION) (* rrb "26-Sep-84 18:48")
(* * 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 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)
(SETQ FONTSFOUND (CONS THISFONT FONTSFOUND]
finally (RETURN FONTSFOUND)))
(SHOULDNT])
(\FONTFACE
[LAMBDA (FACE NOERRORFLG) (* mjs "17-Feb-85 16:37")
(* Takes a variety of user specifications and converts
them to a standard FONTFACE record.)
(* the atom NNN is interpreted the same as NIL or MRR
to cover up a bug described in AR 3025, the FONTNNN
bug)
(PROG NIL
[RETURN (COND
((type? FONTFACE FACE)
FACE)
[(LITATOM FACE)
(OR (U-CASEP FACE)
(SETQ FACE (U-CASE FACE)))
(SELECTQ FACE
((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]
(T (GO ERROR]
ERROR
(COND
(NOERRORFLG (RETURN NIL))
(T (\ILLEGAL.ARG FACE])
(\FONTFILENAME
[LAMBDA (FAMILY SIZE FACE EXTENSION CHARACTERSET) (* jds "30-Apr-85 14:41")
(* Returns the name of the file that should contain the
display raster information for a display font)
(PACKFILENAME (QUOTE NAME)
[SELECTQ EXTENSION
[(DISPLAYFONT AC WD)
(PACK* FAMILY SIZE (SELECTQ (fetch WEIGHT of FACE)
(BOLD (QUOTE -B))
"")
(SELECTQ (fetch SLOPE of FACE)
(ITALIC (QUOTE -I))
"")
(COND
((FIXP CHARACTERSET)
(RESETLST (RESETSAVE PRXFLG T)
(RESETSAVE (RADIX 8))
(CONCAT "-C" CHARACTERSET)))
(CHARACTERSET (CONCAT "-C" CHARACTERSET))
(T "-C0"]
(PACK* FAMILY SIZE (SELECTQ (fetch WEIGHT of FACE)
(BOLD (QUOTE B))
"")
(SELECTQ (fetch SLOPE of FACE)
(ITALIC (QUOTE I))
"")
(COND
((FIXP CHARACTERSET)
(RESETLST (RESETSAVE PRXFLG T)
(RESETSAVE (RADIX 8))
(CONCAT "C" CHARACTERSET)))
(CHARACTERSET (CONCAT "C" CHARACTERSET))
(T ""]
(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 DEVICE NOERRORFLG) (* jds "14-Jun-85 11:35")
(* Coerces SPEC to a fontdescriptor.
Go back thru FONTCREATE for various coercions in order
to make sure that the cache gets set up)
(* Maybe all callers guarantee proper device?)
(PROG (FONT)
[COND
((type? FONTDESCRIPTOR SPEC)
(SETQ FONT SPEC))
[(type? FONTCLASS SPEC) (* If we're coercing a FONTCLASS, go searching for the
component corresponding to this device.)
[SETQ DEVICE (COND
((NULL DEVICE) (* Default is display)
(QUOTE DISPLAY))
((STREAMP DEVICE) (* If it's a stream, use what KIND of stream)
(IMAGESTREAMTYPE DEVICE))
((LITATOM DEVICE) (* Otherwise just the name itself)
DEVICE)
(T (\ILLEGAL.ARG DEVICE]
[SETQ FONT (SELECTQ DEVICE
(DISPLAY (ffetch (FONTCLASS DISPLAYFD) of SPEC))
(INTERPRESS (ffetch (FONTCLASS INTERPRESSFD) of SPEC))
(PRESS (ffetch (FONTCLASS PRESSFD) of SPEC))
(PROGN (* Other device; try searching the ALIST for it)
(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 defaultfont, but don't cache in this
particular font descriptor)
(COND
[(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 DEVICE NOERRORFLG]
((SETQ FONT (FONTCREATE FONT NIL NIL NIL DEVICE NOERRORFLG))
(* Might get NIL if NOERRORFLG)
(SETFONTCLASSCOMPONENT SPEC DEVICE FONT]
((NULL SPEC)
(RETURN (\COERCEFONTDESC DEFAULTFONT DEVICE 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 DEVICE NOERRORFLG]
(* Here if arg was a fontdescriptor or imagestream)
(RETURN (COND
((NULL DEVICE) (* NIL device doesn't default to display if a
fully-specified font was found)
FONT)
([OR (EQ DEVICE (ffetch FONTDEVICE of FONT))
(AND (type? STREAM DEVICE)
(EQ (ffetch IMFONTCREATE of (ffetch IMAGEOPS of DEVICE))
(ffetch FONTDEVICE of FONT]
FONT)
(T (* Here if doesn't match or if DEVICE is not explicitly
a stream. Presumably, FONTCOPY contains the slow
stream-coercion code.)
(FONTCOPY FONT (QUOTE DEVICE)
DEVICE
(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 CHARSET) (* rmk: " 9-Apr-85 13:45")
(DECLARE (GLOBALVARS DISPLAYFONTEXTENSIONS DISPLAYFONTDIRECTORIES))
(BIND FONTFILE FONTDESC 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 FONTDESC (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.)
(COND
(FONTDESC (replace FONTSCALE of FONTDESC with 1)
(RETURN FONTDESC])
(\SFMAKEBOLD
[LAMBDA (FONTD) (* J.Gibbons "11-May-81 23:51")
(PROG ((OLDCHARBITMAP (fetch CHARACTERBITMAP of FONTD))
NEWCHARBITMAP
(widths (fetch \SFWidths of FONTD))
(offsets (fetch \SFOffsets of FONTD))
(height (fetch \SFHeight of FONTD))
offset unknownoffset unknownwidth)
(SETQ NEWCHARBITMAP (BITMAPCREATE (fetch BITMAPWIDTH of OLDCHARBITMAP)
(fetch BITMAPHEIGHT of OLDCHARBITMAP)))
(SETQ unknownoffset (\GETOFFSET offsets (ADD1 \MAXCHAR)))
(SETQ unknownwidth (\GETWIDTH widths (ADD1 \MAXCHAR)))
[for i from 0 to \MAXCHAR do (COND
((EQ (SETQ offset (\GETOFFSET offsets i))
unknownoffset))
(T (BITBLT OLDCHARBITMAP offset 0 NEWCHARBITMAP offset 0
(\GETWIDTH widths i)
height
(QUOTE INPUT)
(QUOTE REPLACE))
(BITBLT OLDCHARBITMAP offset 0 NEWCHARBITMAP
(ADD1 offset)
0
(SUB1 (\GETWIDTH widths i))
height
(QUOTE INPUT)
(QUOTE PAINT]
(BITBLT OLDCHARBITMAP unknownoffset 0 NEWCHARBITMAP unknownoffset 0 unknownwidth height
(QUOTE INPUT)
(QUOTE REPLACE))
(RETURN NEWCHARBITMAP])
(\SFMAKEITALIC
[LAMBDA (FONTDESC) (* J.Gibbons "11-May-81 23:53")
(PROG ((OLDBITMAP (fetch CHARACTERBITMAP of FONTDESC))
NEWBITMAP
(widths (fetch \SFWidths of FONTDESC))
(offsets (fetch \SFOffsets of FONTDESC))
(height (fetch \SFHeight of FONTDESC))
(ascent (fetch \SFAscent of FONTDESC))
(descent (fetch \SFDescent of FONTDESC))
offset width unknownoffset unknownwidth n m r xn xx yn yx)
(SETQ NEWBITMAP (BITMAPCREATE (fetch BITMAPWIDTH of OLDBITMAP)
(fetch BITMAPHEIGHT of OLDBITMAP)))
(SETQ unknownoffset (\GETOFFSET offsets (ADD1 \MAXCHAR)))
(SETQ unknownwidth (\GETWIDTH widths (ADD1 \MAXCHAR)))
(SETQ n (IDIFFERENCE 0 (IQUOTIENT (IPLUS descent 3)
4)))
(SETQ m (IQUOTIENT (IPLUS ascent 3)
4))
[for i from 0 to \MAXCHAR do (COND
((EQ (SETQ offset (\GETOFFSET offsets i))
unknownoffset))
(T (SETQ width (\GETWIDTH 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 NEWBITMAP])
(\SFMAKEROTATEDFONT
[LAMBDA (FONTDESC ROTATION) (* jds "23-May-85 08:55")
(* takes a fontdecriptor and rotates it.)
(create FONTDESCRIPTOR using FONTDESC CHARACTERBITMAP ←(\SFROTATEFONTCHARACTERS
(fetch (FONTDESCRIPTOR CHARACTERBITMAP) of FONTDESC)
ROTATION)
ROTATION ← ROTATION \SFOffsets ←(\SFFIXOFFSETSAFTERROTATION FONTDESC
ROTATION)
FONTCHARSETVECTOR ←(\ALLOCBLOCK (ADD1 \MAXCHARSET)
T])
(\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) (* rrb "28-APR-83 11:31")
(* adjusts offsets in case where rotation turned things
around.)
(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])
)
(/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)
(CHARACTERBITMAP POINTER)
(FONTFAMILY POINTER)
(FONTSIZE POINTER)
(FONTFACE POINTER)
(\SFWidths POINTER)
(\SFOffsets POINTER)
(\SFWidthsY POINTER)
(FIRSTCHAR WORD)
(LASTCHAR 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)
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
[PUTPROPS FONTPROP MACRO (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)
(CHARACTERBITMAP POINTER) (* Bitmap containing the character images, indexed by
\SFOffsets)
(FONTFAMILY POINTER)
(FONTSIZE POINTER)
(FONTFACE POINTER)
(\SFWidths POINTER)
(* 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.)
(\SFOffsets POINTER) (* Offset of each character into the image bitmap;
X value of left edge)
(\SFWidthsY POINTER)
(FIRSTCHAR WORD) (* Charcode of the first character that exists in the
font)
(LASTCHAR WORD) (* 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)
(FONTEXTRAFIELD2 POINTER))
FONTCHARSETVECTOR ←(\ALLOCBLOCK (ADD1 \MAXCHARSET)
T))
(RECORD FONTFACE (WEIGHT SLOPE EXPANSION)
WEIGHT ←(QUOTE MEDIUM)
SLOPE ←(QUOTE REGULAR)
EXPANSION ←(QUOTE REGULAR)
(TYPE? LISTP))
(DATATYPE CHARSETINFO (WIDTHS OFFSETS IMAGEWIDTHS CHARSETBITMAP YWIDTHS (CHARSETASCENT WORD)
(CHARSETDESCENT WORD)))
]
(/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]
[PROGN (PUTPROPS \FGETOFFSET DMACRO ((BASE INDEX)
(ELT BASE INDEX)))
(PUTPROPS \FGETOFFSET JMACRO ((BASE INDEX)
(.LDB BASE INDEX (CONSTANT (\SSPP 16 16]
[PROGN (PUTPROPS \FGETWIDTH DMACRO ((BASE INDEX)
(\GETBASE BASE INDEX)))
(PUTPROPS \FGETWIDTH JMACRO ((BASE INDEX)
(.LDB BASE INDEX (CONSTANT (\SSPP 16 0]
[PROGN (PUTPROPS \GETOFFSET DMACRO ((ARR INDEX)
(ELT ARR INDEX)))
(PUTPROPS \GETOFFSET JMACRO ((ARR INDEX)
(.LDB ARR (ADD1 INDEX)
(CONSTANT (\SSPP 16 16]
[PROGN (PUTPROPS \GETWIDTH DMACRO ((ARR INDEX)
(\WORDELT ARR INDEX)))
(PUTPROPS \GETWIDTH JMACRO ((ARR INDEX)
(.LDB ARR (ADD1 INDEX)
(CONSTANT (\SSPP 16 0]
[PUTPROPS \FGETCHARWIDTH MACRO (OPENLAMBDA (FONT CHARCODE CSVECTOR)
(\FGETWIDTH (ffetch (CHARSETINFO WIDTHS)
of
(\GETCHARSETINFO (\CHARSET CHARCODE)
FONT CSVECTOR))
(\CHAR8CODE CHARCODE]
[PUTPROPS \FGETIMAGEWIDTH MACRO (OPENLAMBDA (FONT CHARCODE CSVECTOR)
(\FGETWIDTH (ffetch (CHARSETINFO IMAGEWIDTHS)
of
(\GETCHARSETINFO (\CHARSET CHARCODE)
FONT CSVECTOR))
(\CHAR8CODE CHARCODE]
[PUTPROPS \GETCHARSETINFO MACRO ((CHARSET FONT CHARSETVECTOR)
(OR (\GETBASEPTR (OR CHARSETVECTOR (ffetch FONTCHARSETVECTOR of FONT))
(UNFOLD CHARSET 2))
(\CREATECHARSET CHARSET FONT]
)
(* END EXPORTED DEFINITIONS)
)
(* NS Character specific code)
(DEFINEQ
(\CREATECHARSET
[LAMBDA (CHARSET FONT) (* jds "22-Apr-85 17:20")
(* Creates and returns the CHARSETINFO for charset
CHARSET in font FONT, installing it in fonts
FONTCHARSETVECTOR)
(AND (IGREATERP CHARSET \MAXCHARSET)
(\ILLEGAL.ARG CHARSET))
(PROG (NEWFONT CREATEFN)
[COND
((EQ CHARSET 0) (* If charset is to be 0, we've filled in the fields in
FONT already when it was created.)
(SETQ NEWFONT FONT))
(T (* For other charsets, create a font descriptor of info
for that charset, and use it to fill things in.)
[SETQ CREATEFN (SELECTQ (FONTPROP FONT (QUOTE DEVICE))
(DISPLAY (FUNCTION \CREATEDISPLAYFONT))
(PRESS (FUNCTION \CREATEPRESSFONT))
(INTERPRESS (FUNCTION \CREATESTARFONT))
(CADR (ASSOC (QUOTE CREATECHARSET)
(CDR (ASSOC (FONTPROP FONT (QUOTE DEVICE))
IMAGESTREAMTYPES]
(SETQ NEWFONT (APPLY CREATEFN (APPEND (FONTPROP FONT (QUOTE DEVICESPEC))
(LIST CHARSET]
[COND
(NEWFONT (* The font exists, everything is OK))
(CHARSETERRORFLG (* The specific character set didn't exist, and the
user wants an error.)
(ERROR "FONT NOT FOUND" FONT CHARSET))
(T (* Create a fake bitmap and set of widths, showing only
the black rectangle.)
(RETURN (\RPLPTR (ffetch FONTCHARSETVECTOR of FONT)
(UNFOLD CHARSET 2)
(create CHARSETINFO
WIDTHS ←(ffetch (ARRAYP BASE)
of (ARRAY 256 (QUOTE SMALLP)
[ELT (fetch \SFWidths of FONT)
(SUB1 (ARRAYSIZE (fetch \SFWidths
of FONT]
0))
OFFSETS ←(AND (fetch \SFOffsets of FONT)
(ffetch (ARRAYP BASE)
of (ARRAY 256 (QUOTE SMALLP)
(ELT (fetch \SFOffsets
of FONT)
256)
0)))
IMAGEWIDTHS ←(ffetch (ARRAYP BASE)
of (ffetch \SFWidths of FONT))
CHARSETBITMAP ←(ffetch CHARACTERBITMAP of FONT)
YWIDTHS ← 0
CHARSETASCENT ←(ffetch \SFAscent of FONT)
CHARSETDESCENT ←(ffetch \SFDescent of FONT]
(replace \SFAscent of FONT with (IMAX (fetch \SFAscent of FONT)
(ffetch \SFAscent of NEWFONT)))
(replace \SFDescent of FONT with (IMAX (fetch \SFDescent of FONT)
(ffetch \SFDescent of NEWFONT)))
(replace \SFHeight of FONT with (IMAX (fetch \SFHeight of FONT)
(ffetch \SFHeight of NEWFONT)))
(RETURN (\RPLPTR (ffetch FONTCHARSETVECTOR of FONT)
(UNFOLD CHARSET 2)
(create CHARSETINFO
WIDTHS ←(ffetch (ARRAYP BASE) of (ffetch \SFWidths of NEWFONT))
OFFSETS ←(AND (ffetch \SFOffsets of NEWFONT)
(ffetch (ARRAYP BASE) of (ffetch \SFOffsets
of NEWFONT)))
IMAGEWIDTHS ←(ffetch (ARRAYP BASE) of (ffetch \SFWidths
of NEWFONT))
CHARSETBITMAP ←(ffetch CHARACTERBITMAP of NEWFONT)
YWIDTHS ←[AND (ffetch \SFWidthsY of NEWFONT)
(OR (FIXP (ffetch \SFWidthsY of NEWFONT))
(ffetch (ARRAYP BASE)
of (ffetch \SFWidthsY of NEWFONT]
CHARSETASCENT ←(ffetch \SFAscent of NEWFONT)
CHARSETDESCENT ←(ffetch \SFDescent of NEWFONT])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS DISPLAYFONTCOERCIONS MISSINGDISPLAYFONTCOERCIONS CHARSETERRORFLG)
)
(RPAQ? DISPLAYFONTCOERCIONS NIL)
(RPAQ? MISSINGDISPLAYFONTCOERCIONS [QUOTE (((GACHA)
(MODERN))
((MODERN)
(CLASSIC))
((TIMESROMAN)
(CLASSIC))
((HELVETICA)
(MODERN])
(RPAQ? CHARSETERRORFLG NIL)
(* Interlisp-D specific)
(RPAQQ DONLYFONTFNS (\FONTRESETCHARWIDTHS \READSTRIKEFONTFILE))
(DEFINEQ
(\FONTRESETCHARWIDTHS
[LAMBDA (font) (* rmk: "26-OCT-81 21:19")
(* sets the widths array from the offsets array)
(PROG ((mincharcode (fetch FIRSTCHAR of font))
(maxcharcode (fetch LASTCHAR of font))
(offsets (fetch \SFOffsets of font))
(widths (fetch \SFWidths of font))
left right charoffset dummycharoffset dummycharwidth)
(SETQ dummycharoffset (ELT offsets (ADD1 maxcharcode)))
(SETQ dummycharwidth (IDIFFERENCE (ELT offsets (IPLUS maxcharcode 2))
dummycharoffset))
[for charcode from 0 to \MAXCHAR do (COND
((OR (ILESSP charcode mincharcode)
(IGREATERP charcode maxcharcode))
(SETA offsets charcode dummycharoffset)
(SETA widths charcode dummycharwidth))
(T (SETQ left (ELT offsets charcode))
(SETQ right (ELT offsets (ADD1 charcode)))
(COND
((EQ left right)
(SETA offsets charcode dummycharoffset)
(SETA widths charcode dummycharwidth))
(T (SETA widths charcode (IDIFFERENCE right left]
(SETA widths (ADD1 \MAXCHAR)
dummycharwidth)
(SETA offsets (ADD1 \MAXCHAR)
dummycharoffset])
(\READSTRIKEFONTFILE
[LAMBDA (STRM FAMILY SIZE FACE) (* rmk: "11-Sep-84 10:44")
(* STRM has already been determined to be a vanilla
strike-format file.)
(COND
((NEQ 2 (GETFILEPTR STRM))
(SETFILEPTR STRM 2)))
(PROG (FONTDESC NUMBCODES RW BITMAP OFFSETS)
(SETQ FONTDESC (create FONTDESCRIPTOR
FONTFAMILY ← FAMILY
FONTSIZE ← SIZE
FONTFACE ← FACE
FONTDEVICE ←(QUOTE DISPLAY)))
(replace FIRSTCHAR of FONTDESC with (\WIN STRM)) (* minimum ascii code)
(replace LASTCHAR of FONTDESC with (\WIN STRM)) (* maximum ascii code)
(\WIN STRM) (* MaxWidth which isn't used by anyone.)
(\WIN STRM) (* number of words in this StrikeBody)
(replace \SFAscent of FONTDESC with (\WIN STRM)) (* ascent in scan lines (=FBBdy+FBBoy))
(replace \SFDescent of FONTDESC 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)
(replace \SFHeight of FONTDESC with (IPLUS (fetch \SFAscent of FONTDESC)
(fetch \SFDescent of FONTDESC)))
(* height of bitmap)
(SETQ BITMAP (BITMAPCREATE (UNFOLD RW BITSPERWORD)
(fetch \SFHeight of FONTDESC)))
(\BINS STRM (fetch BITMAPBASE of BITMAP)
0
(UNFOLD (ITIMES RW (fetch \SFHeight of FONTDESC))
BYTESPERWORD)) (* read bits into bitmap)
(replace CHARACTERBITMAP of FONTDESC with BITMAP)
(SETQ NUMBCODES (IPLUS (IDIFFERENCE (fetch LASTCHAR of FONTDESC)
(fetch FIRSTCHAR of FONTDESC))
3))
(SETQ OFFSETS (ARRAY (IPLUS \MAXCHAR 3)
(QUOTE SMALLPOSP)
0 0))
(AIN OFFSETS (fetch FIRSTCHAR of FONTDESC)
NUMBCODES STRM)
(replace \SFOffsets of FONTDESC with OFFSETS)
(replace \SFWidths of FONTDESC with (ARRAY (IPLUS \MAXCHAR 3)
(QUOTE SMALLPOSP)
0 0))
(\FONTRESETCHARWIDTHS FONTDESC)
(RETURN FONTDESC])
)
(DECLARE: DONTCOPY DONTEVAL@LOAD EVAL@COMPILEWHEN (NEQ (COMPILEMODE)
(QUOTE D))
(ADDTOVAR DONTCOMPILEFNS \FONTRESETCHARWIDTHS \READSTRIKEFONTFILE)
)
(DECLARE: DONTEVAL@LOAD COPYWHEN (EQ (COMPILEMODE)
(QUOTE D))
(RPAQ? DISPLAYFONTEXTENSIONS (QUOTE DISPLAYFONT))
(RPAQ? DISPLAYFONTDIRECTORIES (QUOTE ({ERIS}<LISPCORE>FONTS> {ERIS}<LISP>FONTS>)))
)
(* Interlisp-Jericho specific)
(RPAQQ JONLYFONTFNS (\FONTDESCARRAY \READJERICHOFONTFILE))
(DEFINEQ
(\FONTDESCARRAY
[LAMBDA (LEFTVAL RIGHTVAL) (* rmk: "26-OCT-81 21:20")
(* Creates an array for a FONTDESCRIPTOR field and
initializes it.)
(bind (ARR ←(JARRAY (IPLUS \MAXCHAR 2)
(QUOTE BYTE)
32))
for I from 1 to (IPLUS \MAXCHAR 2)
do (.DPB ARR I (CONSTANT (\SSPP 16 16))
LEFTVAL)
(.DPB ARR I (CONSTANT (\SSPP 16 0))
RIGHTVAL)
finally (RETURN ARR])
(\READJERICHOFONTFILE
[LAMBDA (FAMILY SIZE FACE OFD) (* J.Gibbons " 5-Dec-82 16:54")
(PROG (FONTDESC HEIGHT TOTALCHARWIDTH OFFSETSANDWIDTHS LKERNSANDRWIDTHS BITMAP SCRATCHBITMAP
SCRATCHBITMAPBASE)
(SETQ FONTDESC (create FONTDESCRIPTOR
FONTFAMILY ← FAMILY
FONTSIZE ← SIZE
FONTFACE ← FACE
FONTDEVICE ←(QUOTE DISPLAY)))
(RPTQ (BIN OFD)
(BIN OFD)) (* we don't use the font id.)
(replace \SFHeight of FONTDESC with (SETQ HEIGHT (2BIN OFD)))
(replace \SFAscent of FONTDESC with (ADD1 (2BIN OFD)))
(replace \SFDescent of FONTDESC with (IDIFFERENCE HEIGHT (fetch \SFAscent of FONTDESC)))
(2BIN OFD) (* we don't use the column position adjustment.)
(replace \SFMaxRasterWidth of FONTDESC with (2BIN OFD))
(replace \SFTotalRasterWidth of FONTDESC with (2BIN OFD))
(replace \SFMaxCharWidth of FONTDESC with (2BIN OFD))
(replace \SFTotalCharWidth of FONTDESC with (SETQ TOTALCHARWIDTH (2BIN OFD)))
(replace \SFOffsets of FONTDESC with (SETQ OFFSETSANDWIDTHS (\FONTDESCARRAY TOTALCHARWIDTH
0)))
(replace \SFWidths of FONTDESC with OFFSETSANDWIDTHS)
(replace \SFLKerns of FONTDESC with (SETQ LKERNSANDRWIDTHS (\FONTDESCARRAY 0 0)))
(replace \SFRWidths of FONTDESC with LKERNSANDRWIDTHS)
(SETQ SCRATCHBITMAP (BITMAPCREATE (fetch \SFMaxRasterWidth of FONTDESC)
HEIGHT))
(SETQ SCRATCHBITMAPBASE (fetch BITMAPBASE of SCRATCHBITMAP))
(replace CHARACTERBITMAP of FONTDESC with (SETQ BITMAP (BITMAPCREATE TOTALCHARWIDTH HEIGHT))
)
[bind OFFSET←0
(WORDSPERROW ←(fetch BITMAPRASTERWIDTH of SCRATCHBITMAP))
CHARCODE CHARWIDTH LEFTKERN RASTERWIDTH FLG while (EQ (SETQ FLG (BIN OFD))
255)
do (* Get another character.)
(SETQ CHARCODE (BIN OFD))
(SETQ RASTERWIDTH (2BIN OFD))
(SETQ CHARWIDTH (2BIN OFD))
(SETQ LEFTKERN (\SIGNED (2BIN OFD)
16))
(bind TEM←SCRATCHBITMAPBASE for lineIndex from 1 to HEIGHT
do (for byteIndex from 0 to (LRSH (SUB1 RASTERWIDTH)
3)
do (SELECTQ (LOGAND byteIndex 3)
(0 (.DPB TEM (LRSH byteIndex 2)
(CONSTANT (\SSPP 8 24))
(BIN OFD)))
(1 (.DPB TEM (LRSH byteIndex 2)
(CONSTANT (\SSPP 8 16))
(BIN OFD)))
(2 (.DPB TEM (LRSH byteIndex 2)
(CONSTANT (\SSPP 8 8))
(BIN OFD)))
(3 (.DPB TEM (LRSH byteIndex 2)
(CONSTANT (\SSPP 8 0))
(BIN OFD)))
NIL))
(SETQ TEM (.PTRADD TEM WORDSPERROW)))
[COND
((NOT (ZEROP CHARWIDTH))
(.DPB OFFSETSANDWIDTHS (ADD1 CHARCODE)
(CONSTANT (\SSPP 16 16))
OFFSET)
(.DPB OFFSETSANDWIDTHS (ADD1 CHARCODE)
(CONSTANT (\SSPP 16 0))
CHARWIDTH)
(.DPB LKERNSANDRWIDTHS (ADD1 CHARCODE)
(CONSTANT (\SSPP 16 16))
LEFTKERN)
(.DPB LKERNSANDRWIDTHS (ADD1 CHARCODE)
(CONSTANT (\SSPP 16 0))
RASTERWIDTH)
(BITBLT SCRATCHBITMAP 0 0 BITMAP (IDIFFERENCE OFFSET LEFTKERN)
0 RASTERWIDTH HEIGHT (QUOTE INPUT)
(QUOTE REPLACE))
(SETQ OFFSET (IPLUS OFFSET CHARWIDTH]
finally (COND
((ZEROP FLG))
(T (ERROR (FULLNAME OFD)
"has bad font file format"]
(RETURN FONTDESC])
)
(DECLARE: DONTEVAL@LOAD DONTCOPY EVAL@COMPILEWHEN (NEQ (COMPILEMODE)
(QUOTE JERICHO))
(ADDTOVAR DONTCOMPILEFNS \FONTDESCARRAY \READJERICHOFONTFILE)
)
(DECLARE: DONTEVAL@LOAD COPYWHEN (EQ (COMPILEMODE)
(QUOTE JERICHO))
(RPAQQ DISPLAYFONTEXTENSIONS FONT)
(ADDTOVAR DISPLAYFONTDIRECTORIES >FONTS)
)
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: EVAL@COMPILE
[PUTPROPS 2BIN JMACRO ((FILE)
(LOGOR (LLSH (BIN FILE)
8)
(BIN FILE]
[PUTPROPS \GETLKERN JMACRO ((ARR INDEX)
(.LDB ARR (ADD1 INDEX)
(CONSTANT (\SSPP 16 16]
[PUTPROPS \GETRWIDTH JMACRO ((ARR INDEX)
(.LDB ARR (ADD1 INDEX)
(CONSTANT (\SSPP 16 0]
)
)
(DECLARE: EVAL@COMPILE
[PROGN [PUTPROPS \GETFONTDESC DMACRO (X (COND ((CDR X)
(CONS (QUOTE \COERCEFONTDESC)
X))
(T (BQUOTE (\DTEST , (CAR X)
(QUOTE FONTDESCRIPTOR]
(PUTPROPS \GETFONTDESC MACRO (= . \COERCEFONTDESC))
(PUTPROPS \GETFONTDESC JMACRO (X (COND ((CDR X)
(CONS (QUOTE \COERCEFONTDESC)
X))
(T (BQUOTE (\DTEST , (CAR X)
(QUOTE FONTDESCRIPTOR]
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA FONTCOPY)
)
(PUTPROPS FONT COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3428 10371 (CHARWIDTH 3438 . 4066) (CHARWIDTHY 4068 . 5028) (STRINGWIDTH 5030 . 5884) (
\CHARWIDTH.DISPLAY 5886 . 6291) (\STRINGWIDTH.DISPLAY 6293 . 6752) (\STRINGWIDTH.GENERIC 6754 . 10369)
) (10552 15751 (DEFAULTFONT 10562 . 11807) (FONTCLASS 11809 . 13618) (FONTCLASSUNPARSE 13620 . 14436)
(FONTCLASSCOMPONENT 14438 . 14931) (SETFONTCLASSCOMPONENT 14933 . 15749)) (15752 70426 (FONTASCENT
15762 . 15930) (FONTCOPY 15932 . 18753) (FONTCREATE 18755 . 24030) (FONTSAVAILABLE 24032 . 27799) (
FONTDESCENT 27801 . 28066) (FONTFILEFORMAT 28068 . 29598) (FONTHEIGHT 29600 . 29698) (FONTP 29700 .
29986) (FONTPROP 29988 . 32632) (FONTUNPARSE 32634 . 34272) (SETFONTDESCRIPTOR 34274 . 35755) (
CHARCODEP 35757 . 36051) (GETCHARBITMAP 36053 . 37138) (PUTCHARBITMAP 37140 . 42004) (EDITCHAR 42006
. 42393) (\AVGCHARWIDTH 42395 . 42969) (\STREAMCHARWIDTH 42971 . 45709) (\UNITWIDTHSVECTOR 45711 .
46053) (\CREATEDISPLAYFONT 46055 . 50435) (\SEARCHDISPLAYFONTFILES 50437 . 51909) (\FONTFACE 51911 .
53697) (\FONTFILENAME 53699 . 55051) (\FONTINFOFROMFILENAME 55053 . 56771) (\GETFONTDESC 56773 . 57158
) (\COERCEFONTDESC 57160 . 61142) (\LOOKUPFONT 61144 . 61629) (\LOOKUPFONTSINCORE 61631 . 62854) (
\READDISPLAYFONTFILE 62856 . 64352) (\SFMAKEBOLD 64354 . 65767) (\SFMAKEITALIC 65769 . 67841) (
\SFMAKEROTATEDFONT 67843 . 68423) (\SFROTATEFONTCHARACTERS 68425 . 69324) (\SFFIXOFFSETSAFTERROTATION
69326 . 70424)) (80116 84215 (\CREATECHARSET 80126 . 84213)) (84700 88929 (\FONTRESETCHARWIDTHS 84710
. 86165) (\READSTRIKEFONTFILE 86167 . 88927)) (89418 93990 (\FONTDESCARRAY 89428 . 89984) (
\READJERICHOFONTFILE 89986 . 93988)))))
STOP