(FILECREATED "17-Feb-85 16:38:05" {ERIS}<LISPCORE>SOURCES>FONT.;61 78318
changes to: (FNS \FONTFACE)
previous date: "16-Feb-85 10:59:55" {ERIS}<LISPCORE>SOURCES>FONT.;60)
(* 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)
(SYSRECORDS FONTCLASS FONTDESCRIPTOR)
(INITVARS (\FONTSINCORE)
(\DEFAULTDEVICEFONTS)
(\UNITWIDTHSVECTOR))
(GLOBALVARS DISPLAYFONTDIRECTORIES \DEFAULTDEVICEFONTS \UNITWIDTHSVECTOR)
(P (\UNITWIDTHSVECTOR))
(EXPORT (MACROS FONTPROP))
(DECLARE: DONTCOPY (EXPORT (RECORDS FONTCLASS FONTDESCRIPTOR FONTFACE)
(MACROS FONTASCENT FONTDESCENT FONTHEIGHT \FGETOFFSET \FGETWIDTH
\GETOFFSET \GETWIDTH)
(MACROS \FCHARWIDTH))
(* Does anyone really use \FCHARWIDTH -- JonL 11/7/83))
[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: "13-Sep-84 09:24")
(* gets the width of a character code in a font/stream)
(PROG (TEMP)
(RETURN (COND
((type? FONTDESCRIPTOR FONT)
(\FGETWIDTH (fetch (ARRAYP BASE) of (ffetch \SFWidths of FONT))
(LOGAND CHARCODE \CHARMASK)))
((type? STREAM (SETQ TEMP (\OUTSTREAMARG FONT T)))
(* NIL font goes thru here--primary output file)
(IMAGEOP (QUOTE IMCHARWIDTH)
TEMP TEMP (LOGAND CHARCODE \CHARMASK)))
(T (\FGETWIDTH (ffetch (ARRAYP BASE) of (fetch (FONTDESCRIPTOR \SFWidths)
of (FONTCREATE FONT)))
(LOGAND CHARCODE \CHARMASK])
(CHARWIDTHY
[LAMBDA (CHARCODE FONT) (* rmk: "12-MAR-82 23:22")
(* Gets the Y-component of the width of a character code in a font.)
(PROG [(WY (fetch \SFWidthsY of (\GETFONTDESC FONT]
(RETURN (OR (FIXP WY)
(\GETWIDTH WY (LOGAND CHARCODE \CHARMASK])
(STRINGWIDTH
[LAMBDA (STR FONT FLG RDTBL) (* rmk: "12-Sep-84 11:03")
(* Returns the width of STR according to FONT)
(PROG (TEMP) (* Used in \MAPCHARS)
(RETURN (COND
[(type? FONTDESCRIPTOR FONT)
(\STRINGWIDTH.GENERIC STR (fetch (ARRAYP BASE) of (ffetch \SFWidths
of FONT))
(AND FLG (\GTREADTABLE RDTBL))
(\FGETWIDTH (fetch (ARRAYP BASE)
of (ffetch \SFWidths of FONT))
(CHARCODE SPACE]
[(type? STREAM (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 (ffetch (ARRAYP BASE) of (fetch (FONTDESCRIPTOR \SFWidths)
of (FONTCREATE FONT]
(\STRINGWIDTH.GENERIC STR TEMP (AND FLG (\GTREADTABLE RDTBL))
(\FGETWIDTH TEMP (CHARCODE SPACE])
(\CHARWIDTH.DISPLAY
[LAMBDA (STREAM CHARCODE) (* rmk: "12-Sep-84 11:35")
(* gets the width of a character code in a display
stream. Need to fix up for spacefactor.)
(\FGETWIDTH (ffetch (\DISPLAYDATA DDWIDTHSCACHE) of (ffetch IMAGEDATA of STREAM))
CHARCODE])
(\STRINGWIDTH.DISPLAY
[LAMBDA (STREAM STR RDTBL) (* rmk: "12-Sep-84 11:01")
(* Returns the width of for the current font/spacefactor
in STREAM.)
(PROG (WIDTHSBASE)
(RETURN (\STRINGWIDTH.GENERIC STR (SETQ WIDTHSBASE (ffetch (\DISPLAYDATA DDWIDTHSCACHE)
of (ffetch IMAGEDATA of STREAM)))
RDTBL
(\FGETWIDTH WIDTHSBASE (CHARCODE SPACE])
(\STRINGWIDTH.GENERIC
[LAMBDA (STR WIDTHSBASE RDTBL SPACEWIDTH) (* rmk: "12-Sep-84 10:27")
(* Returns the width of STR with SPACEWIDTH for the width of spaces and WIDTHSBASE used for other characters.
RDTBL has already been coerced, so no FLG is needed)
(DECLARE (SPECVARS WIDTHSBASE SPACEWIDTH)) (* Used in \MAPCHARS)
(SELECTC (NTYPX STR)
[\LITATOM (COND
[RDTBL (for C (SA ←(fetch READSA of RDTBL)) inatom STR
sum (COND
[(fetch (READCODE ESCQUOTE) of (\SYNCODE SA C))
(IPLUS (\FGETWIDTH WIDTHSBASE (CHARCODE %%))
(COND
((EQ C (CHARCODE SPACE))
SPACEWIDTH)
(T (\FGETWIDTH WIDTHSBASE C]
((EQ C (CHARCODE SPACE))
SPACEWIDTH)
(T (\FGETWIDTH WIDTHSBASE C]
(T (for C inatom STR sum (COND
((EQ C (CHARCODE SPACE))
SPACEWIDTH)
(T (\FGETWIDTH WIDTHSBASE C]
[\STRINGP (COND
[RDTBL (IPLUS (UNFOLD (\FGETWIDTH WIDTHSBASE (CHARCODE %"))
2)
(for C instring STR
sum (SELCHARQ C
(SPACE SPACEWIDTH)
((%" %%)
(IPLUS (\FGETWIDTH WIDTHSBASE (CHARCODE
%%))
(\FGETWIDTH WIDTHSBASE C)))
(\FGETWIDTH WIDTHSBASE C]
(T (for C instring STR sum (COND
((EQ C (CHARCODE SPACE))
SPACEWIDTH)
(T (\FGETWIDTH WIDTHSBASE C]
(PROG ((S 0))
(DECLARE (SPECVARS S))
(\MAPCHARS [FUNCTION (LAMBDA (CC)
(add S (COND
((EQ CC (CHARCODE SPACE))
SPACEWIDTH)
(T (\FGETWIDTH WIDTHSBASE CC]
STR RDTBL RDTBL)
(RETURN 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: "16-Feb-85 10:59")
(* 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 (RETURN (FONTCLASS (CADR FAMILY)
(CDDR FAMILY)
DEV)))
(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) (* jds "23-Oct-84 17:49")
(* stores the bitmap NEWCHARBITMAP as the character
CHARCODE from the font descriptor FONTDESC.)
(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 CHGHT OFFSETS WIDTHS FONTBITMAP TEMPBITMAP NWIDTH DW OFWIDTH)
(SETQ CWDTH (CHARWIDTH CHARCODE FONTDESC))
(SETQ WIDTHS (fetch \SFWidths of FONTDESC))
(SETQ OFFSETS (fetch \SFOffsets of FONTDESC))
(SETQ FONTBITMAP (fetch (FONTDESCRIPTOR CHARACTERBITMAP) of FONTDESC))
(SETQ CHGHT (FONTPROP FONTDESC (QUOTE HEIGHT)))
(COND
((NEQ CHGHT (fetch (BITMAP BITMAPHEIGHT) of NEWCHARBITMAP))
(ERROR "character height is different from new image height" NEWCHARBITMAP)))
(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 OFWIDTH (fetch (BITMAP BITMAPWIDTH) of FONTBITMAP))
(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) (* rmk: "18-Dec-84 17:10")
(COND
((AND (EQ ROTATION 0)
(\READDISPLAYFONTFILE FAMILY SIZE FACE)))
(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))
((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))
((AND (SETQ XLATEDFAM (SELECTQ FAMILY
(TIMESROMAN (QUOTE CLASSIC))
(HELVETICA (QUOTE MODERN))
(GACHA (QUOTE TERMINAL))
(LOGO (QUOTE LOGOTYPE))
NIL))
(SETQ XFONT (FONTCREATE XLATEDFAM SIZE FACE 0 (QUOTE DISPLAY)
T)))
(create FONTDESCRIPTOR using XFONT FONTFAMILY ← FAMILY FONTDEVICESPEC ←(
LIST XLATEDFAM SIZE FACE ROTATION
(QUOTE DISPLAY])
(\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) (* rmk: "16-Oct-84 11:56")
(* 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))
"")))
(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) (* rmk: " 7-Dec-84 18:00")
(* 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)
(OR DEVICE (SETQ DEVICE (QUOTE DISPLAY)))
[SETQ FONT (SELECTQ DEVICE
(DISPLAY (ffetch (FONTCLASS DISPLAYFD) of SPEC))
(INTERPRESS (ffetch (FONTCLASS INTERPRESSFD) of SPEC))
(PRESS (ffetch (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 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) (* rmk: "27-Nov-84 18:20")
(DECLARE (GLOBALVARS DISPLAYFONTEXTENSIONS DISPLAYFONTDIRECTORIES))
(SELECTQ (SYSTEMTYPE)
(J (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)))
(replace FONTSCALE of FONTDESC with 1)
(RETURN FONTDESC)))
[D (for E FONTFILE FONTDESC STRM inside DISPLAYFONTEXTENSIONS
when (SETQ FONTFILE (FINDFILE (\FONTFILENAME FAMILY SIZE FACE E)
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)
(* 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]
(SHOULDNT])
(\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) (* rrb "28-APR-83 12:04")
(* takes a fontdecriptor and rotates it.)
(create FONTDESCRIPTOR using FONTDESC CHARACTERBITMAP ←(\SFROTATEFONTCHARACTERS
(fetch (FONTDESCRIPTOR CHARACTERBITMAP) of FONTDESC)
ROTATION)
ROTATION ← ROTATION \SFOffsets ←(\SFFIXOFFSETSAFTERROTATION FONTDESC
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) (* 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)))
(/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)))
[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)
(FONTEXTRAFIELD1 POINTER)
(FONTEXTRAFIELD2 POINTER)))
]
(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.)
(FONTEXTRAFIELD1 POINTER)
(FONTEXTRAFIELD2 POINTER)))
(RECORD FONTFACE (WEIGHT SLOPE EXPANSION)
WEIGHT ←(QUOTE MEDIUM)
SLOPE ←(QUOTE REGULAR)
EXPANSION ←(QUOTE REGULAR)
(TYPE? LISTP))
]
(/DECLAREDATATYPE (QUOTE FONTCLASS)
(QUOTE (BYTE POINTER POINTER POINTER POINTER POINTER)))
(/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)))
(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 ((BASE INDEX)
(ELT BASE INDEX)))
(PUTPROPS \FGETOFFSET JMACRO [(BASE INDEX)
(.LDB BASE INDEX (CONSTANT (\SSPP 16 16])
(PUTPROPS \FGETWIDTH DMACRO ((BASE INDEX)
(\GETBASE BASE INDEX)))
(PUTPROPS \FGETWIDTH JMACRO [(BASE INDEX)
(.LDB BASE INDEX (CONSTANT (\SSPP 16 0])
(PUTPROPS \GETOFFSET DMACRO ((ARR INDEX)
(ELT ARR INDEX)))
(PUTPROPS \GETOFFSET JMACRO [(ARR INDEX)
(.LDB ARR (ADD1 INDEX)
(CONSTANT (\SSPP 16 16])
(PUTPROPS \GETWIDTH DMACRO ((ARR INDEX)
(\WORDELT ARR INDEX)))
(PUTPROPS \GETWIDTH JMACRO [(ARR INDEX)
(.LDB ARR (ADD1 INDEX)
(CONSTANT (\SSPP 16 0])
)
(DECLARE: EVAL@COMPILE
(PUTPROPS \FCHARWIDTH MACRO (OPENLAMBDA (CHARCODE FONT)
(\FGETWIDTH (ffetch (ARRAYP BASE)
of (ffetch \SFWidths of FONT))
CHARCODE)))
)
(* END EXPORTED DEFINITIONS)
)
(* 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
(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 (2975 8043 (CHARWIDTH 2985 . 3851) (CHARWIDTHY 3853 . 4193) (STRINGWIDTH 4195 . 5367) (
\CHARWIDTH.DISPLAY 5369 . 5773) (\STRINGWIDTH.DISPLAY 5775 . 6282) (\STRINGWIDTH.GENERIC 6284 . 8041))
(8224 13423 (DEFAULTFONT 8234 . 9479) (FONTCLASS 9481 . 11290) (FONTCLASSUNPARSE 11292 . 12108) (
FONTCLASSCOMPONENT 12110 . 12603) (SETFONTCLASSCOMPONENT 12605 . 13421)) (13424 62279 (FONTASCENT
13434 . 13576) (FONTCOPY 13578 . 16399) (FONTCREATE 16401 . 21365) (FONTSAVAILABLE 21367 . 25134) (
FONTDESCENT 25136 . 25349) (FONTFILEFORMAT 25351 . 26778) (FONTHEIGHT 26780 . 26878) (FONTP 26880 .
27158) (FONTPROP 27160 . 29804) (FONTUNPARSE 29806 . 31444) (SETFONTDESCRIPTOR 31446 . 32751) (
CHARCODEP 32753 . 33033) (GETCHARBITMAP 33035 . 34049) (PUTCHARBITMAP 34051 . 37415) (EDITCHAR 37417
. 37736) (\AVGCHARWIDTH 37738 . 38312) (\STREAMCHARWIDTH 38314 . 40897) (\UNITWIDTHSVECTOR 40899 .
41221) (\CREATEDISPLAYFONT 41223 . 43196) (\SEARCHDISPLAYFONTFILES 43198 . 44670) (\FONTFACE 44672 .
46458) (\FONTFILENAME 46460 . 47575) (\FONTINFOFROMFILENAME 47577 . 49295) (\GETFONTDESC 49297 . 49639
) (\COERCEFONTDESC 49641 . 53040) (\LOOKUPFONT 53042 . 53471) (\LOOKUPFONTSINCORE 53473 . 54696) (
\READDISPLAYFONTFILE 54698 . 56748) (\SFMAKEBOLD 56750 . 58049) (\SFMAKEITALIC 58051 . 59897) (
\SFMAKEROTATEDFONT 59899 . 60403) (\SFROTATEFONTCHARACTERS 60405 . 61228) (\SFFIXOFFSETSAFTERROTATION
61230 . 62277)) (68313 72274 (\FONTRESETCHARWIDTHS 68323 . 69610) (\READSTRIKEFONTFILE 69612 . 72272))
(72763 76882 (\FONTDESCARRAY 72773 . 73236) (\READJERICHOFONTFILE 73238 . 76880)))))
STOP