(FILECREATED "15-Oct-85 18:57:54" {ERIS}<LISPCORE>SOURCES>FONT.;82 104686
changes to: (FNS \FONTFILENAME \SEARCHDISPLAYFONTFILES)
previous date: " 7-Oct-85 16:31:53" {ERIS}<LISPCORE>SOURCES>FONT.;81)
(* 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
\CREATECHARSET.DISPLAY \BUILDSLUGCSINFO \SEARCHDISPLAYFONTFILES \FONTFACE \FONTFILENAME
\FONTINFOFROMFILENAME \GETFONTDESC \COERCEFONTDESC \LOOKUPFONT \LOOKUPFONTSINCORE
\READDISPLAYFONTFILE \SFMAKEBOLD \SFMAKEITALIC \SFMAKEROTATEDFONT \SFROTATECSINFO
\SFROTATEFONTCHARACTERS \SFFIXOFFSETSAFTERROTATION \SFROTATECSINFOOFFSETS)
(INITRECORDS FONTCLASS FONTDESCRIPTOR CHARSETINFO)
(SYSRECORDS FONTCLASS FONTDESCRIPTOR CHARSETINFO)
(INITVARS (\FONTSINCORE)
(\DEFAULTDEVICEFONTS)
(\UNITWIDTHSVECTOR))
(GLOBALVARS DISPLAYFONTDIRECTORIES \DEFAULTDEVICEFONTS \UNITWIDTHSVECTOR)
(P (\UNITWIDTHSVECTOR))
(CONSTANTS (NORUNCODE 255))
(EXPORT (MACROS FONTPROP))
[DECLARE: DONTCOPY (EXPORT (RECORDS FONTCLASS FONTDESCRIPTOR FONTFACE CHARSETINFO)
(MACROS FONTASCENT FONTDESCENT FONTHEIGHT \FGETOFFSET \FSETOFFSET
\FGETWIDTH \FSETWIDTH \FGETCHARWIDTH \FGETIMAGEWIDTH
\FSETIMAGEWIDTH \GETCHARSETINFO \CREATECSINFOELEMENT)
(CONSTANTS (\MAXNSCHAR 65535]
(COMS (* NS Character specific code)
(FNS \CREATECHARSET)
(GLOBALVARS DISPLAYFONTCOERCIONS MISSINGDISPLAYFONTCOERCIONS CHARSETERRORFLG)
(INITVARS (DISPLAYFONTCOERCIONS NIL)
[MISSINGDISPLAYFONTCOERCIONS (QUOTE (((GACHA)
(TERMINAL))
((MODERN)
(CLASSIC))
((TIMESROMAN)
(CLASSIC))
((HELVETICA)
(MODERN]
(CHARSETERRORFLG NIL)
(\DEFAULTCHARSET 0)))
[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 \FGETCHARIMAGEWIDTH \GETFONTDESC \SETCHARSETINFO)
(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) (* gbn " 3-Oct-85 18:39")
(* Returns the width of STR with SPACEWIDTH for the
width of spaces. RDTBL has already been coerced, so no
FLG is needed)
(* * THIS IS CLONED IN \STRINGWIDTH.HCPYDISPLAYAUX, and changes to this fn must also be made there)
(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]
(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]
(COND
((EQ C (CHARCODE SPACE))
SPACEWIDTH)
(T (\FGETWIDTH WIDTHSBASE (\CHAR8CODE C]
[\STRINGP (COND
[RDTBL (IPLUS (UNFOLD (\FGETCHARWIDTH FONT (CHARCODE %"))
2)
(for C instring STR
bind (PCTWIDTH ←(\FGETCHARWIDTH FONT
(CHARCODE
%%)))
WIDTHSBASE CSET
sum [if (NEQ CSET (\CHARSET C))
then (SETQ CSET (\CHARSET C))
(SETQ WIDTHSBASE
(ffetch (CHARSETINFO WIDTHS)
of (\GETCHARSETINFO CSET
FONT]
(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]
(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)))
(\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 CHARSET)
(* gbn "15-Sep-85 13:54")
(* Cache and fonts.widths traffic in uppercase only.)
(* character set is optional and defaults to
\DEFAULTCHARSET (0 in our world))
(DECLARE (GLOBALVARS IMAGESTREAMTYPES))
(PROG (FONTX [DEV (COND
((type? STREAM DEVICE)
(fetch IMFONTCREATE of (fetch IMAGEOPS of DEVICE)))
(DEVICE)
(T (QUOTE DISPLAY]
(CHSET (OR CHARSET \DEFAULTCHARSET)))
(RETURN (COND
((LISTP FAMILY)
(SELECTQ (CAR FAMILY)
(FONT (SETQ FONTX (CDR FAMILY)))
[CLASS (COND
((LITATOM (CADR FAMILY))
(* litatom class name)
(RETURN (FONTCLASS (CADR FAMILY)
(CDDR FAMILY)
DEV)))
(T (* Allows for a font named CLASS--distinguished cause
its size is not a litatom)
(SETQ FONTX FAMILY]
(SETQ FONTX FAMILY))
(FONTCREATE (CAR FONTX)
(OR (CADR FONTX)
SIZE)
(OR (CADDR FONTX)
FACE)
(OR (CADDDR FONTX)
ROTATION)
(OR (CADR (CDDDR FONTX))
DEV)
NOERRORFLG CHSET))
([SETQ FONTX (COND
((type? FONTDESCRIPTOR FAMILY)
FAMILY)
((NULL FAMILY)
(DEFAULTFONT DEV))
((type? FONTCLASS FAMILY)
(* We know that this won't attempt a cyclic fontcreate in \COERCEFONTDESC, because we are passing a known class.
Unless NOERROFLG, an error will be caused on the actual device font if it can't be found.)
(\COERCEFONTDESC FAMILY DEV NOERRORFLG))
((OR (IMAGESTREAMP FAMILY)
(type? WINDOW FAMILY))
(DSPFONT NIL FAMILY] (* FAMILY was a spec for a font descriptor, use it and
extend it by the other args.)
(COND
((OR SIZE FACE ROTATION DEVICE)
(FONTCREATE (FONTPROP FONTX (QUOTE FAMILY))
(OR SIZE (FONTPROP FONTX (QUOTE SIZE)))
(OR FACE (FONTPROP FONTX (QUOTE FACE)))
(OR ROTATION (FONTPROP FONTX (QUOTE ROTATION)))
(OR DEVICE (FONTPROP FONTX (QUOTE DEVICE)))
NOERRORFLG))
(T FONTX)))
(T (PROG (FONTFACE TEMPDEV)
RETRY
[OR (LITATOM FAMILY)
(COND
(NOERRORFLG (RETURN))
(T (LISPERROR "ARG NOT LITATOM" FAMILY T]
[OR (AND (FIXP SIZE)
(IGREATERP SIZE 0))
(COND
(NOERRORFLG (RETURN NIL))
(T (\ILLEGAL.ARG SIZE]
(SETQ FONTFACE (OR (\FONTFACE FACE NOERRORFLG)
(RETURN NIL)))
(OR (U-CASEP FAMILY)
(SETQ FAMILY (U-CASE FAMILY)))
(COND
((NULL ROTATION)
(SETQ ROTATION 0))
((AND (FIXP ROTATION)
(IGEQ ROTATION 0)))
(NOERRORFLG (RETURN NIL))
(T (\ILLEGAL.ARG ROTATION)))
NEWDEV
[RETURN (COND
((\LOOKUPFONT FAMILY SIZE FONTFACE ROTATION DEV))
[[SETQ FONTX (ASSOC (QUOTE FONTCREATE)
(CDR (ASSOC DEV IMAGESTREAMTYPES]
(* We found the device, but maybe didn't find the font.
We know not to try to coerce the device into a stream,
though.)
(COND
((SETQ FONTX (APPLY* (OR (CADR FONTX)
(FUNCTION NILL))
FAMILY SIZE FONTFACE ROTATION DEV
CHSET))
(* default creation case. Use fontcreate method from
device, build a fontdescriptor and use
setfontdescriptor to install it.)
(OR (ffetch FONTIMAGEWIDTHS of FONTX)
(freplace FONTIMAGEWIDTHS of FONTX
with (ffetch \SFWidths of FONTX)))
(* * the widths fields in the fontdescriptor are obsolete, and shoudln't be updated here.)
(* We should probably force all device implementations
to obey these conventions, then remove these generic
updates)
(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) (* gbn "22-Jul-85 16:35")
(* is CHCODE a legal character code?)
(AND (SMALLP CHCODE)
(IGEQ CHCODE 0)
(ILEQ CHCODE \MAXNSCHAR])
(GETCHARBITMAP
[LAMBDA (CHARCODE FONT) (* gbn "31-Jul-85 22:59")
(* 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))
CSINFO CWDTH CHGHT) (* fetch the csinfo for the character set of this
character. Bitmaps and widths must be fetched from it)
(SETQ CSINFO (\GETCHARSETINFO (\CHARSET CHARCODE)
FONTDESC))
[SETQ CBM (BITMAPCREATE (SETQ CWDTH (\FGETWIDTH (ffetch (CHARSETINFO WIDTHS) of CSINFO)
(\CHAR8CODE CHARCODE)))
(SETQ CHGHT (FONTPROP FONTDESC (QUOTE HEIGHT]
(BITBLT (ffetch (CHARSETINFO CHARSETBITMAP) of CSINFO)
(\FGETOFFSET (ffetch (CHARSETINFO OFFSETS) of CSINFO)
(\CHAR8CODE CHARCODE))
0 CBM 0 0 CWDTH CHGHT)
(RETURN CBM])
(PUTCHARBITMAP
[LAMBDA (CHARCODE FONT NEWCHARBITMAP NEWCHARDESCENT) (* gbn "22-Jul-85 22:44")
(* stores the bitmap NEWCHARBITMAP as the character CHARCODE from the font descriptor FONTDESC.
If NEWCHARDESCENT is specified, it is the descent of the new bitmap, and things may be moved to accomodate it.)
(OR (TYPENAMEP NEWCHARBITMAP (QUOTE BITMAP))
(\ILLEGAL.ARG NEWCHARBITMAP))
(COND
((CHARCODEP CHARCODE))
((OR (STRINGP CHARCODE)
(LITATOM CHARCODE))
(SETQ CHARCODE (CHCON1 CHARCODE)))
(T (\ILLEGAL.ARG CHARCODE)))
(PROG* ((FONTDESC (\GETFONTDESC FONT))
(CWDTH (CHARWIDTH CHARCODE FONTDESC))
(CHGHT (FONTPROP FONTDESC (QUOTE HEIGHT)))
(CDESC (FONTPROP FONTDESC (QUOTE DESCENT)))
(CASC (FONTPROP FONTDESC (QUOTE ASCENT)))
(CSINFO (\GETCHARSETINFO (\CHARSET CHARCODE)
FONTDESC))
(OFFSETS (ffetch (CHARSETINFO OFFSETS) of CSINFO))
(WIDTHS (ffetch (CHARSETINFO WIDTHS) of CSINFO))
(FONTBITMAP (ffetch (CHARSETINFO CHARSETBITMAP) of CSINFO))
(OFWIDTH (fetch (BITMAP BITMAPWIDTH) of FONTBITMAP))
(NDESCENT (OR NEWCHARDESCENT CDESC))
TEMPBITMAP NWIDTH DW NHEIGHT CHAROFFSET)
[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 (CHARSETINFO CHARSETBITMAP) of CSINFO 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 NWIDTH CWDTH)) (* Difference in character widths)
(SETQ TEMPBITMAP (BITMAPCREATE (IPLUS OFWIDTH DW)
CHGHT))
(BITBLT FONTBITMAP 0 0 TEMPBITMAP 0 0 (SETQ CHAROFFSET (\FGETOFFSET OFFSETS
(\CHAR8CODE
CHARCODE)))
CHGHT) (* Copy that part of the old bitmap that's to the left
of the new character)
(BITBLT NEWCHARBITMAP 0 0 TEMPBITMAP CHAROFFSET 0 NWIDTH CHGHT)
(* Insert the new character in its place)
(BITBLT FONTBITMAP (IPLUS CHAROFFSET CWDTH)
0 TEMPBITMAP (IPLUS CHAROFFSET NWIDTH)
0
(ADD1 (IDIFFERENCE OFWIDTH (IPLUS CHAROFFSET CWDTH)))
CHGHT)
(\FSETWIDTH WIDTHS (\CHAR8CODE CHARCODE)
NWIDTH) (* The new character's correct width)
[for I from (ADD1 (\CHAR8CODE CHARCODE)) to \MAXCHAR
do (* Run thru the offsets of later characters, adjusting
them for the changed width of this character)
(\FSETOFFSET OFFSETS I (IPLUS DW (\FGETOFFSET OFFSETS I]
(replace (CHARSETINFO CHARSETBITMAP) of CSINFO with TEMPBITMAP))
(T (BITBLT NEWCHARBITMAP 0 0 FONTBITMAP (\FGETOFFSET OFFSETS (\CHAR8CODE CHARCODE))
0 CWDTH CHGHT)))
(RETURN NEWCHARBITMAP])
(EDITCHAR
[LAMBDA (CHARCODE FONT) (* rrb "24-MAR-82 12:22")
(* calls the bitmap editor on a character of a font)
(PROG ((FONTDESC (\GETFONTDESC FONT)))
(RETURN (PUTCHARBITMAP CHARCODE FONTDESC (EDITBM (GETCHARBITMAP CHARCODE FONTDESC])
(\AVGCHARWIDTH
[LAMBDA (FONT) (* rmk: "27-Nov-84 18:40")
(* Returns the average width of a character, to be used
in units-to-characters approximations, as in fixing the
linelength)
(PROG ((W (CHARWIDTH (CHARCODE A)
FONT)))
(RETURN (COND
((NEQ 0 W)
W)
([NEQ 0 (SETQ W (FIXR (FTIMES .6 (FONTPROP FONT (QUOTE HEIGHT]
W)
(T 1])
(\STREAMCHARWIDTH
[LAMBDA (CHARCODE STREAM TTBL) (* JonL " 8-NOV-83 03:31")
(* Returns the width that the printed representation of CHARCODE would occupy if printed on STREAM, allowing for the
various escape sequences. Used by \ECHOCHAR)
(SETQ CHARCODE (LOGAND CHARCODE \CHARMASK))
((LAMBDA (WIDTHSVECTOR)
(* Note in following that if the DDWIDTHSCACHE exists and has a 0 entry for some character, that may someday mean
that the character's glyph simply isn't loaded; e.g., it may want #↑A)
(SETQ WIDTHSVECTOR (OR (AND (DISPLAYSTREAMP STREAM)
(SETQ WIDTHSVECTOR (ffetch IMAGEDATA of STREAM))
(ffetch DDWIDTHSCACHE of WIDTHSVECTOR))
\UNITWIDTHSVECTOR))
(SELECTC (fetch CCECHO of (\SYNCODE (fetch (TERMTABLEP TERMSA) of (OR (TERMTABLEP TTBL)
\PRIMTERMTABLE))
CHARCODE))
(INDICATE.CCE ([LAMBDA (CC)
(IPLUS (if (IGEQ CHARCODE (CHARCODE #↑@))
then (* A META charcode -- implies that the 8th bit is
non-zero)
(SETQ CC (LOADBYTE CHARCODE 0 7))
(\FGETWIDTH WIDTHSVECTOR (CHARCODE #))
else 0)
(if (ILESSP CC (CHARCODE SPACE))
then (* A CONTROL charcode)
(add CC (CONSTANT (LLSH 1 6)))
(\FGETWIDTH WIDTHSVECTOR (CHARCODE ↑))
else 0)
(\FGETWIDTH WIDTHSVECTOR CC]
CHARCODE))
(SIMULATE.CCE (SELCHARQ CHARCODE
((EOL CR LF BELL)
NIL)
(ESCAPE (\FGETWIDTH WIDTHSVECTOR (CHARCODE $)))
[TAB (PROG ((SPACEWIDTH (\FGETWIDTH WIDTHSVECTOR
(CHARCODE SPACE)))
(NEWXPOSITON (DSPXPOSITION NIL STREAM))
TABWIDTH)
(SETQ TABWIDTH (UNFOLD SPACEWIDTH 8))
[add NEWXPOSITON
(SETQ TABWIDTH
(IDIFFERENCE TABWIDTH
(IMOD (IDIFFERENCE
NEWXPOSITON
(DSPLEFTMARGIN NIL
STREAM))
TABWIDTH]
(RETURN (if (IGREATERP NEWXPOSITON
(DSPRIGHTMARGIN NIL STREAM)
)
then
(* tab was past rightmargin, force cr.)
NIL
else TABWIDTH]
(\FGETWIDTH WIDTHSVECTOR CHARCODE)))
(REAL.CCE (SELECTC CHARCODE
((CHARCODE (EOL CR LF))
NIL)
(ERASECHARCODE NIL)
(\FGETWIDTH WIDTHSVECTOR CHARCODE)))
(IGNORE.CCE 0)
(SHOULDNT])
(\UNITWIDTHSVECTOR
[LAMBDA NIL (* JonL " 7-NOV-83 19:23")
(SETQ \UNITWIDTHSVECTOR (\ALLOCBLOCK (UNFOLD (IPLUS \MAXCHAR 3)
WORDSPERCELL)))
(for I from 0 to (IPLUS \MAXCHAR 2) do (\PUTBASE \UNITWIDTHSVECTOR I 1))
\UNITWIDTHSVECTOR])
(\CREATEDISPLAYFONT
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* gbn "26-Sep-85 18:34")
(PROG [(FONTDESC (create FONTDESCRIPTOR
FONTDEVICE ←(QUOTE DISPLAY)
FONTFAMILY ← FAMILY
FONTSIZE ← SIZE
FONTFACE ← FACE
\SFAscent ← 0
\SFDescent ← 0
\SFHeight ← 0
ROTATION ← ROTATION
FONTDEVICESPEC ←(LIST FAMILY SIZE FACE ROTATION (QUOTE DISPLAY]
(RETURN (if (\GETCHARSETINFO CHARSET FONTDESC T)
then FONTDESC
else NIL])
(\CREATECHARSET.DISPLAY
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC NOSLUG?)
(* gbn " 1-Oct-85 17:49")
(* * tries to build the csinfo required for CHARSET. Does the necessary coercions.)
(* * NOSLUG? means don't create an empty (slug) csinfo if the charset is not found, just return NIL)
(DECLARE (GLOBALVARS DISPLAYFONTCOERCIONS MISSINGDISPLAYFONTCOERCIONS))
(* DISPLAYFONTCOERCIONS is a list of font coercions, in the form ((user-font real-font) (user-font real-font) ...).
Each user-font is a list of FAMILY, and optionally SIZE and CHARSET, (e.g., (GACHA) or (GACHA 10) or
(GACHA 10 143)), and each real-font is a similar list.)
(COND
((PROG1 (for TRANSL in DISPLAYFONTCOERCIONS bind NEWCSINFO 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 NEWCSINFO (\CREATECHARSET.DISPLAY (OR (CAR REALFONT)
FAMILY)
(OR (CADR REALFONT)
SIZE)
FACE ROTATION DEVICE
(OR (CADDR REALFONT)
CHARSET)
FONTDESC NOSLUG?)))
do (RETURN NEWCSINFO)) (* Just recursively call ourselves to handle entries
in DISPLAYFONTCOERCIONS)
))
((AND (EQ ROTATION 0) (* If it is available, this will force the appropriate
file to be read to fill in the charset entry)
(\READDISPLAYFONTFILE FAMILY SIZE FACE ROTATION (QUOTE DISPLAY)
CHARSET)))
(T
(* * if we get here, the font is not directly available, either it needs to be rotated, boldified, or italicised
"by hand")
(PROG (NEWFONT XFONT XLATEDFAM CSINFO)
(RETURN (COND
[(NEQ ROTATION 0)
(* to make a rotated font (even if it is bold or whatnot), recursively call fontcreate to get the unrotated font
(maybe bold, etc), then call \SFMAKEROTATEDFONT on the csinfo.)
(OR (MEMB ROTATION (QUOTE (90 270)))
(ERROR "only implemented rotations are 0, 90 and 270."
ROTATION))
(COND
((SETQ XFONT (FONTCREATE FAMILY SIZE FACE 0 (QUOTE DISPLAY)
T CHARSET))
(* actually call FONTCREATE here, rather than \CREATEDISPLAYFONT or \CREATECHARSET.DISPLAY, so that the vanilla
font that is built in this process will be cached and not repeated.)
(if (SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T))
then (\SFROTATECSINFO CSINFO ROTATION)
else NIL]
((AND (EQ (fetch WEIGHT of FACE)
(QUOTE BOLD))
(SETQ XFONT (FONTCREATE FAMILY SIZE
(create FONTFACE
using FACE WEIGHT ←(QUOTE
MEDIUM))
0
(QUOTE DISPLAY)
T CHARSET)))
(* if we want a bold font, and the medium weight font is available, build the medium weight version then call
\SFMAKEBOLD on the csinfo)
(if (SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T))
then (\SFMAKEBOLD CSINFO)
else NIL))
((AND (EQ (fetch SLOPE of FACE)
(QUOTE ITALIC))
(SETQ XFONT (FONTCREATE FAMILY SIZE
(create FONTFACE
using FACE SLOPE ←(QUOTE
REGULAR))
0
(QUOTE DISPLAY)
T CHARSET)))
(if (SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T))
then (\SFMAKEITALIC CSINFO)
else NIL))
((for TRANSL in MISSINGDISPLAYFONTCOERCIONS bind NEWCSINFO
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 NEWCSINFO (\CREATECHARSET.DISPLAY
(OR (CAR REALFONT)
FAMILY)
(OR (CADR REALFONT)
SIZE)
FACE ROTATION DEVICE (OR (CADDR REALFONT)
CHARSET)
FONTDESC NOSLUG?)))
do (RETURN NEWCSINFO)))
((NOT NOSLUG?)
(\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR FONTAVGCHARWIDTH)
of FONTDESC)
(FONTPROP FONTDESC (QUOTE ASCENT))
(FONTPROP FONTDESC (QUOTE DESCENT))
(FONTPROP FONTDESC (QUOTE DEVICE])
(\BUILDSLUGCSINFO
[LAMBDA (WIDTH ASCENT DESCENT DEVICE) (* gbn " 1-Oct-85 17:41")
(* * builds a csinfo which contains only the slug (black rectangle) character)
(PROG ((CSINFO (create CHARSETINFO
CHARSETASCENT ← ASCENT
CHARSETDESCENT ← DESCENT))
WIDTHS OFFSETS BITMAP)
(SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
(for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I WIDTH))
[SELECTQ DEVICE
(INTERPRESS (* don't need offsets in INTERPRESS fonts)
NIL)
(PROGN (replace (CHARSETINFO OFFSETS) of CSINFO with (SETQ OFFSETS
(
\CREATECSINFOELEMENT)))
(for I from 0 to \MAXTHINCHAR do (\FSETOFFSET OFFSETS I 0))
[replace (CHARSETINFO CHARSETBITMAP) of CSINFO
with (SETQ BITMAP (BITMAPCREATE WIDTH (IPLUS ASCENT
DESCENT]
(BLTSHADE BLACKSHADE BITMAP 1 NIL (SUB1 WIDTH]
(RETURN CSINFO])
(\SEARCHDISPLAYFONTFILES
[LAMBDA (FAMILY SIZE FACE ROTATION) (* rrb "15-Oct-85 18:47")
(* * returns a list of the fonts that can be read in for the display device. Rotation is ignored because it is
assumed that all devices support 0 90 and 270)
(DECLARE (GLOBALVARS DISPLAYFONTEXTENSIONS DISPLAYFONTDIRECTORIES))
(SELECTQ (SYSTEMTYPE)
(J
(* OLD J code from \READDISPLAYFONT (PROG ((FONTFILE (\FONTFILENAME FAMILY SIZE FACE)) FONTDESC STRM)
(COND ((SETQ STRM (AND FONTDIRECTORIES (FINDFILE FONTFILE T FONTDIRECTORIES))) (SETQ STRM (OPENSTREAM FONTFILE
(QUOTE INPUT))) (SETQ FONTDESC (\READJERICHOFONTFILE FAMILY SIZE FACE STRM)) (CLOSEF STRM)))
(RETURN FONTDESC)))
NIL)
(D (for E FILENAMEPATTERN FONTSFOUND THISFONT THISFACE inside
DISPLAYFONTEXTENSIONS
do (SETQ FILENAMEPATTERN (\FONTFILENAME FAMILY SIZE FACE E))
[for DIR inside DISPLAYFONTDIRECTORIES
do (for FONTFILE in (DIRECTORY (PACKFILENAME (QUOTE
DIRECTORY)
DIR
(QUOTE BODY)
FILENAMEPATTERN))
do (OR (MEMBER (SETQ THISFONT (\FONTINFOFROMFILENAME
FONTFILE
(QUOTE DISPLAY)))
FONTSFOUND)
(COND
((AND [OR (EQ FACE (QUOTE *))
(EQUAL FACE (SETQ THISFACE
(CADDR THISFONT)))
(AND (OR (EQ (CAR FACE)
(QUOTE *))
(EQ (CAR FACE)
(CAR THISFACE)))
(OR (EQ (CADR FACE)
(QUOTE *))
(EQ (CADR FACE)
(CADR THISFACE)))
(OR (EQ (CADR FACE)
(QUOTE *))
(EQ (CADR FACE)
(CADR THISFACE]
(OR (EQ FAMILY (QUOTE *))
(EQ FAMILY (CAR THISFONT))
(STRPOS "*" FAMILY)))
(* make sure the face, size, and family really match. Family name match allows anything if the family has a * in
it. This is wrong but better than what was there before which let in anything with the right beginning.)
(SETQ FONTSFOUND (CONS THISFONT FONTSFOUND]
finally (RETURN FONTSFOUND)))
(SHOULDNT])
(\FONTFACE
[LAMBDA (FACE NOERRORFLG) (* 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 CHARSET) (* rrb "15-Oct-85 18:19")
(* 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 [COND
((EQ FACE (QUOTE *))
(QUOTE *))
(T (CONCAT (SELECTQ (fetch WEIGHT of FACE)
(BOLD (QUOTE -B))
(*
(* handle the case of face being say
(* REGULAR REGULAR))
(QUOTE *))
"")
(SELECTQ (fetch SLOPE of FACE)
(ITALIC (QUOTE -I))
(* (QUOTE *))
""]
(COND
((FIXP CHARSET)
(RESETLST (RESETSAVE PRXFLG T)
(RESETSAVE (RADIX 8))
(CONCAT "-C" CHARSET)))
(CHARSET (CONCAT "-C" CHARSET))
(T "-C0"]
[STRIKE (PACK* FAMILY SIZE
[COND
((EQ FACE (QUOTE *))
(QUOTE *))
(T (CONCAT (SELECTQ (fetch WEIGHT
of FACE)
(BOLD (QUOTE B))
(* (QUOTE *))
"")
(SELECTQ (fetch SLOPE
of FACE)
(ITALIC (QUOTE I))
(* (QUOTE *))
""]
(COND
((OR (NULL CHARSET)
(ZEROP CHARSET))
"")
(T (* this will never exist, but return a file name
different from the charset 0 filename)
(CONCAT "C" CHARSET]
(PACK* FAMILY SIZE [COND
((EQ FACE (QUOTE *))
(QUOTE *))
(T (CONCAT (SELECTQ (fetch WEIGHT of FACE)
(BOLD (QUOTE B))
(* (QUOTE *))
"")
(SELECTQ (fetch SLOPE of FACE)
(ITALIC (QUOTE I))
(* (QUOTE *))
""]
(COND
((FIXP CHARSET)
(* this no longer makes sense, since I believe a fixp characterset will always be passed in.
When did people pass in non-fixp non-nil charactersets? What did it mean?)
(RESETLST (RESETSAVE PRXFLG T)
(RESETSAVE (RADIX 8))
(CONCAT "C" CHARSET)))
(CHARSET (CONCAT "C" CHARSET))
(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) (* hdj "25-Sep-85 14:49")
(* 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))
((ATOM 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 ROTATION DEVICE CHARSET) (* gbn " 6-Aug-85 20:17")
(DECLARE (GLOBALVARS DISPLAYFONTEXTENSIONS DISPLAYFONTDIRECTORIES))
(bind FONTFILE CSINFO STRM for EXT inside DISPLAYFONTEXTENSIONS
when (SETQ FONTFILE (FINDFILE (\FONTFILENAME FAMILY SIZE FACE EXT CHARSET)
T DISPLAYFONTDIRECTORIES))
do (SETQ STRM (OPENSTREAM FONTFILE (QUOTE INPUT)))
[RESETLST (SETQ CSINFO (SELECTQ (FONTFILEFORMAT STRM T)
(STRIKE (RESETSAVE NIL (LIST (FUNCTION CLOSEF)
STRM))
(\READSTRIKEFONTFILE STRM FAMILY SIZE FACE))
(AC (* CLOSEF is guaranteed inside \READACFONTFILE, against
the possibility that we have to copy to make
randaccessp)
(\READACFONTFILE STRM FAMILY SIZE FACE))
(PROG1 (CLOSEF STRM)
(SHOULDNT)
(* This would get done by RESETSAVE if AC's were read
sequentially and we could factor the RESETSAVE)
]
(* If not a recognizable format, I guess we should keep looking for another possible extension, altho it would also
be nice to tell the user that he has a bogus file.)
(RETURN CSINFO])
(\SFMAKEBOLD
[LAMBDA (CSINFO) (* gbn "25-Jul-85 04:52")
(PROG* ((OLDCHARBITMAP (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO))
(WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
(OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
(HEIGHT (IPLUS (FETCH (CHARSETINFO CHARSETASCENT) OF CSINFO)
(FETCH (CHARSETINFO CHARSETDESCENT) OF CSINFO)))
NEWCHARBITMAP OFFSET UNKNOWNOFFSET UNKNOWNWIDTH)
(SETQ NEWCHARBITMAP (BITMAPCREATE (fetch BITMAPWIDTH of OLDCHARBITMAP)
(fetch BITMAPHEIGHT of OLDCHARBITMAP)))
(SETQ UNKNOWNOFFSET (\FGETOFFSET OFFSETS (ADD1 \MAXCHAR)))
(SETQ UNKNOWNWIDTH (\FGETWIDTH WIDTHS (ADD1 \MAXCHAR)))
[for I from 0 to \MAXCHAR do (COND
((EQ (SETQ OFFSET (\FGETOFFSET OFFSETS I))
UNKNOWNOFFSET)
(* if this is the magic charcode with the slug image
(charcode 256) then leave it alone)
NIL)
(T (* overlap two blts to produce bold effect)
(BITBLT OLDCHARBITMAP OFFSET 0 NEWCHARBITMAP OFFSET 0
(\FGETWIDTH WIDTHS I)
HEIGHT
(QUOTE INPUT)
(QUOTE REPLACE))
(BITBLT OLDCHARBITMAP OFFSET 0 NEWCHARBITMAP
(ADD1 OFFSET)
0
(SUB1 (\FGETWIDTH WIDTHS I))
HEIGHT
(QUOTE INPUT)
(QUOTE PAINT]
(* fill in the slug for the magic charcode)
(BITBLT OLDCHARBITMAP UNKNOWNOFFSET 0 NEWCHARBITMAP UNKNOWNOFFSET 0 UNKNOWNWIDTH HEIGHT
(QUOTE INPUT)
(QUOTE REPLACE))
(RETURN (CREATE CHARSETINFO USING CSINFO CHARSETBITMAP ← NEWCHARBITMAP])
(\SFMAKEITALIC
[LAMBDA (CSINFO) (* gbn "18-Sep-85 17:57")
(PROG ((WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
(OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
(ASCENT (fetch (CHARSETINFO CHARSETASCENT) of CSINFO))
(DESCENT (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO))
(OLDBITMAP (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO))
HEIGHT OFFSET NEWBITMAP WIDTH UNKNOWNOFFSET UNKNOWNWIDTH N M R XN XX YN YX)
(SETQ HEIGHT (IPLUS ASCENT DESCENT))
(SETQ NEWBITMAP (BITMAPCREATE (fetch BITMAPWIDTH of OLDBITMAP)
(fetch BITMAPHEIGHT of OLDBITMAP)))
(SETQ UNKNOWNOFFSET (\FGETOFFSET OFFSETS (ADD1 \MAXTHINCHAR)))
(SETQ UNKNOWNWIDTH (\FGETWIDTH WIDTHS (ADD1 \MAXTHINCHAR)))
(SETQ N (IDIFFERENCE 0 (IQUOTIENT (IPLUS DESCENT 3)
4)))
(SETQ M (IQUOTIENT (IPLUS ASCENT 3)
4))
[for I from 0 to \MAXTHINCHAR
do (COND
((EQ (SETQ OFFSET (\FGETOFFSET OFFSETS I))
UNKNOWNOFFSET) (* if this is the magic charcode with the slug image
(charcode 256) then leave it alone)
NIL)
(T (SETQ WIDTH (\FGETWIDTH WIDTHS I))
(for J from N to M
do (SETQ R (IPLUS OFFSET WIDTH))
(SETQ XN (IMIN R (IMAX (IPLUS OFFSET J)
0)))
(SETQ XX (IMIN R (IMAX (IPLUS R J)
0)))
[SETQ YN (IMAX 0 (IPLUS DESCENT (ITIMES J 4]
[SETQ YX (IMIN HEIGHT (IPLUS DESCENT (IPLUS (ITIMES J 4)
4]
(COND
((AND (IGREATERP XX XN)
(IGREATERP YX YN))
(BITBLT OLDBITMAP OFFSET YN NEWBITMAP XN YN (IDIFFERENCE XX XN)
(IDIFFERENCE YX YN)
(QUOTE INPUT)
(QUOTE REPLACE]
(BITBLT OLDBITMAP UNKNOWNOFFSET 0 NEWBITMAP UNKNOWNOFFSET 0 UNKNOWNWIDTH HEIGHT
(QUOTE INPUT)
(QUOTE REPLACE))
(RETURN (create CHARSETINFO using CSINFO CHARSETBITMAP ← NEWBITMAP])
(\SFMAKEROTATEDFONT
[LAMBDA (FONTDESC ROTATION) (* gbn "15-Sep-85 14:26")
(* 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])
(\SFROTATECSINFO
[LAMBDA (CSINFO ROTATION) (* gbn "15-Sep-85 14:38")
(* takes a CHARSETINFO and rotates it and produces a
rotated equivalent one.)
(create CHARSETINFO using CSINFO CHARSETBITMAP ←(\SFROTATEFONTCHARACTERS (fetch (CHARSETINFO
CHARSETBITMAP)
of CSINFO)
ROTATION)
OFFSETS ←(\SFROTATECSINFOOFFSETS CSINFO ROTATION])
(\SFROTATEFONTCHARACTERS
[LAMBDA (CHARBITMAP ROTATION) (* rrb "28-APR-83 12:01")
(* rotate a bitmap either 90 or 270 for fonts.)
(PROG (NEWMAP (SELECT (EQ ROTATION 90))
HIGHM1 WIDEM1)
[with BITMAP CHARBITMAP (SETQ HIGHM1 (SUB1 BITMAPHEIGHT))
(SETQ WIDEM1 (SUB1 BITMAPWIDTH))
(SETQ NEWMAP (BITMAPCREATE BITMAPHEIGHT BITMAPWIDTH))
(for X from 0 to WIDEM1 do (for Y from 0 to HIGHM1
do (COND
((EQ 1 (BITMAPBIT CHARBITMAP X Y))
(COND
(SELECT (BITMAPBIT NEWMAP (IDIFFERENCE HIGHM1
Y)
X 1))
(T (BITMAPBIT NEWMAP Y (IDIFFERENCE WIDEM1 X)
1]
(RETURN NEWMAP])
(\SFFIXOFFSETSAFTERROTATION
[LAMBDA (FONTDESC ROTATION) (* 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])
(\SFROTATECSINFOOFFSETS
[LAMBDA (CSINFO ROTATION) (* gbn "15-Sep-85 14:36")
(* adjusts offsets in case where rotation turned things
around.)
(COND
((EQ ROTATION 270)
(PROG ((OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
(WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
(BITMAPHEIGHT (BITMAPWIDTH (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO)))
NEWOFFSETS)
(SETQ NEWOFFSETS (\CREATECSINFOELEMENT))
[for CHARCODE from 0 to \MAXCHAR do (\FSETOFFSET NEWOFFSETS CHARCODE
(IDIFFERENCE BITMAPHEIGHT
(IPLUS (\FGETOFFSET
OFFSETS CHARCODE)
(\FGETWIDTH WIDTHS
CHARCODE]
(* may be some problem with dummy character
representation.)
(RETURN NEWOFFSETS)))
(T (fetch (CHARSETINFO OFFSETS) of CSINFO])
)
(/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)
(DECLARE: EVAL@COMPILE
(RPAQQ NORUNCODE 255)
(CONSTANTS (NORUNCODE 255))
)
(* 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 (* imagewidths is not automagically allocated since it
is not always needed)
CHARSETBITMAP YWIDTHS (CHARSETASCENT WORD)
(CHARSETDESCENT WORD))
WIDTHS ←(\CREATECSINFOELEMENT)
OFFSETS ←(\CREATECSINFOELEMENT))
]
(/DECLAREDATATYPE (QUOTE FONTCLASS)
(QUOTE (BYTE POINTER POINTER POINTER POINTER POINTER))
(QUOTE ((FONTCLASS 0 (BITS . 7))
(FONTCLASS 0 POINTER)
(FONTCLASS 2 POINTER)
(FONTCLASS 4 POINTER)
(FONTCLASS 6 POINTER)
(FONTCLASS 8 POINTER)))
(QUOTE 10))
(/DECLAREDATATYPE (QUOTE FONTDESCRIPTOR)
(QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD
WORD WORD WORD WORD SIGNEDWORD SIGNEDWORD SIGNEDWORD SIGNEDWORD
(BITS 8)
POINTER POINTER POINTER POINTER POINTER WORD POINTER POINTER
POINTER))
(QUOTE ((FONTDESCRIPTOR 0 POINTER)
(FONTDESCRIPTOR 2 POINTER)
(FONTDESCRIPTOR 4 POINTER)
(FONTDESCRIPTOR 6 POINTER)
(FONTDESCRIPTOR 8 POINTER)
(FONTDESCRIPTOR 10 POINTER)
(FONTDESCRIPTOR 12 POINTER)
(FONTDESCRIPTOR 14 POINTER)
(FONTDESCRIPTOR 16 (BITS . 15))
(FONTDESCRIPTOR 17 (BITS . 15))
(FONTDESCRIPTOR 18 (BITS . 15))
(FONTDESCRIPTOR 19 (BITS . 15))
(FONTDESCRIPTOR 20 (BITS . 15))
(FONTDESCRIPTOR 21 (BITS . 15))
(FONTDESCRIPTOR 22 (SIGNEDBITS . 15))
(FONTDESCRIPTOR 23 (SIGNEDBITS . 15))
(FONTDESCRIPTOR 24 (SIGNEDBITS . 15))
(FONTDESCRIPTOR 25 (SIGNEDBITS . 15))
(FONTDESCRIPTOR 14 (BITS . 7))
(FONTDESCRIPTOR 26 POINTER)
(FONTDESCRIPTOR 28 POINTER)
(FONTDESCRIPTOR 30 POINTER)
(FONTDESCRIPTOR 32 POINTER)
(FONTDESCRIPTOR 34 POINTER)
(FONTDESCRIPTOR 36 (BITS . 15))
(FONTDESCRIPTOR 38 POINTER)
(FONTDESCRIPTOR 40 POINTER)
(FONTDESCRIPTOR 42 POINTER)))
(QUOTE 44))
(/DECLAREDATATYPE (QUOTE CHARSETINFO)
(QUOTE (POINTER POINTER POINTER POINTER POINTER WORD WORD))
[QUOTE ((CHARSETINFO 0 POINTER)
(CHARSETINFO 2 POINTER)
(CHARSETINFO 4 POINTER)
(CHARSETINFO 6 POINTER)
(CHARSETINFO 8 POINTER)
(CHARSETINFO 10 (BITS . 15))
(CHARSETINFO 11 (BITS . 15]
(QUOTE 12))
(DECLARE: EVAL@COMPILE
[PUTPROPS FONTASCENT MACRO ((FONTSPEC)
(ffetch \SFAscent of (\GETFONTDESC FONTSPEC]
[PUTPROPS FONTDESCENT MACRO ((FONTSPEC)
(ffetch \SFDescent of (\GETFONTDESC FONTSPEC]
[PUTPROPS FONTHEIGHT MACRO ((FONTSPEC)
(ffetch \SFHeight of (\GETFONTDESC FONTSPEC]
(PUTPROPS \FGETOFFSET DMACRO ((OFFSETBLOCK CHAR8CODE)
(\GETBASE OFFSETBLOCK CHAR8CODE)))
(PUTPROPS \FSETOFFSET DMACRO ((OFFSETSBLOCK INDEX OFFSET)
(\PUTBASE OFFSETSBLOCK INDEX OFFSET)))
(PUTPROPS \FGETWIDTH DMACRO ((BASE INDEX)
(\GETBASE BASE INDEX)))
(PUTPROPS \FSETWIDTH DMACRO ((WIDTHSBLOCK INDEX WIDTH)
(\PUTBASE WIDTHSBLOCK INDEX WIDTH)))
[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 \FSETIMAGEWIDTH DMACRO ((WIDTHSBLOCK INDEX WIDTH)
(\PUTBASE WIDTHSBLOCK INDEX WIDTH)))
[PUTPROPS \GETCHARSETINFO MACRO ((CHARSET FONTDESC NOSLUG?)
(* * fetches the charsetinfo for charset CHARSET in fontdescriptor FONTDESC. If NIL, then
creates the required charset.)
(* * NOSLUG? means don't create an empty (slug)
csinfo if the charset is not found, just return NIL)
(OR (\GETBASEPTR (ffetch FONTCHARSETVECTOR of FONTDESC)
(UNFOLD CHARSET 2))
(\CREATECHARSET CHARSET FONTDESC NOSLUG?]
[PUTPROPS \CREATECSINFOELEMENT MACRO (NIL (\ALLOCBLOCK (FOLDHI (IPLUS \MAXTHINCHAR 3)
WORDSPERCELL]
)
(DECLARE: EVAL@COMPILE
(RPAQQ \MAXNSCHAR 65535)
(CONSTANTS (\MAXNSCHAR 65535))
)
(* END EXPORTED DEFINITIONS)
)
(* NS Character specific code)
(DEFINEQ
(\CREATECHARSET
[LAMBDA (CHARSET FONT NOSLUG?) (* gbn " 7-Oct-85 16:31")
(* Creates and returns the CHARSETINFO for charset
CHARSET in fontdesc FONT, installing it in fonts
FONTCHARSETVECTOR)
(* NOSLUG? means don't create an empty
(slug) csinfo if the charset is not found, just return
NIL)
(AND (IGREATERP CHARSET \MAXCHARSET)
(\ILLEGAL.ARG CHARSET))
(PROG (CSINFO CREATEFN) (* For other charsets, create a font descriptor of
info for that charset, and use it to fill things in.)
[if (OR (AND (IGEQ CHARSET 1)
(ILEQ CHARSET 32))
(AND (IGEQ CHARSET 127)
(ILEQ CHARSET 160)))
then (* this is an illegal NS character set
(reserved for control codes) so just return a slug
(unless NOSLUG? is T))
[if NOSLUG?
then (RETURN NIL)
else (SETQ CSINFO (\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR
FONTAVGCHARWIDTH)
of FONT)
(FONTPROP FONT (QUOTE ASCENT))
(FONTPROP FONT (QUOTE DESCENT))
(FONTPROP FONT (QUOTE DEVICE]
else [SETQ CREATEFN (SELECTQ (FONTPROP FONT (QUOTE DEVICE))
(DISPLAY (FUNCTION \CREATECHARSET.DISPLAY))
(CADR (ASSOC (QUOTE CREATECHARSET)
(CDR (ASSOC
(FONTPROP FONT
(QUOTE
DEVICE))
IMAGESTREAMTYPES]
[if [NOT (SETQ CSINFO (APPLY CREATEFN (APPEND (FONTPROP
FONT
(QUOTE DEVICESPEC))
(LIST CHARSET FONT
NOSLUG?]
then (* the create method returned NIL.
so if NOSLUG? return NIL else build a slug
charsetinfo)
(RETURN (if NOSLUG?
then (* the caller just wants NIL back to signal that
nothing was found)
NIL
else (\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR
FONTAVGCHARWIDTH)
of FONT)
(FONTPROP FONT (QUOTE
ASCENT))
(FONTPROP FONT (QUOTE
HEIGHT))
(FONTPROP FONT (QUOTE
DEVICE]
(replace \SFAscent of FONT with (IMAX (fetch \SFAscent of FONT)
(fetch CHARSETASCENT
of CSINFO)))
(replace \SFDescent of FONT with (IMAX (fetch \SFDescent of FONT)
(ffetch CHARSETDESCENT
of CSINFO)))
(replace \SFHeight of FONT with (IMAX (fetch \SFHeight of FONT)
(IPLUS (fetch CHARSETASCENT
of CSINFO)
(ffetch CHARSETDESCENT
of CSINFO]
(RETURN (\SETCHARSETINFO (ffetch FONTCHARSETVECTOR of FONT)
CHARSET CSINFO])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS DISPLAYFONTCOERCIONS MISSINGDISPLAYFONTCOERCIONS CHARSETERRORFLG)
)
(RPAQ? DISPLAYFONTCOERCIONS NIL)
(RPAQ? MISSINGDISPLAYFONTCOERCIONS [QUOTE (((GACHA)
(TERMINAL))
((MODERN)
(CLASSIC))
((TIMESROMAN)
(CLASSIC))
((HELVETICA)
(MODERN])
(RPAQ? CHARSETERRORFLG NIL)
(RPAQ? \DEFAULTCHARSET 0)
(* Interlisp-D specific)
(RPAQQ DONLYFONTFNS (\FONTRESETCHARWIDTHS \READSTRIKEFONTFILE))
(DEFINEQ
(\FONTRESETCHARWIDTHS
[LAMBDA (CSINFO FIRSTCHAR LASTCHAR) (* gbn "31-Jul-85 23:23")
(* sets the widths array from the offsets array)
(PROG ((mincharcode FIRSTCHAR)
(maxcharcode LASTCHAR)
(offsets (fetch OFFSETS of CSINFO))
(widths (fetch WIDTHS of CSINFO))
left right charoffset dummycharoffset dummycharwidth)
(SETQ dummycharoffset (\FGETOFFSET offsets (ADD1 maxcharcode)))
(SETQ dummycharwidth (IDIFFERENCE (\FGETOFFSET offsets (IPLUS maxcharcode 2))
dummycharoffset))
[for charcode from 0 to \MAXCHAR do (COND
((OR (ILESSP charcode mincharcode)
(IGREATERP charcode maxcharcode))
(\FSETOFFSET offsets charcode dummycharoffset)
(\FSETWIDTH widths charcode dummycharwidth))
(T (SETQ left (\FGETWIDTH offsets charcode))
(SETQ right (\FGETWIDTH offsets (ADD1 charcode)))
(COND
((EQ left right)
(\FSETOFFSET offsets charcode dummycharoffset)
(\FSETWIDTH widths charcode dummycharwidth))
(T (\FSETWIDTH widths charcode (IDIFFERENCE
right left]
(\FSETWIDTH widths (ADD1 \MAXCHAR)
dummycharwidth)
(\FSETOFFSET offsets (ADD1 \MAXCHAR)
dummycharoffset])
(\READSTRIKEFONTFILE
[LAMBDA (STRM FAMILY SIZE FACE) (* gbn "31-Jul-85 23:56")
(* STRM has already been determined to be a vanilla
strike-format file.)
(* returns a charsetinfo)
(COND
((NEQ 2 (GETFILEPTR STRM))
(SETFILEPTR STRM 2)))
(PROG (CSINFO NUMBCODES RW BITMAP OFFSETS FIRSTCHAR LASTCHAR HEIGHT WIDTHS)
(SETQ CSINFO (create CHARSETINFO))
(SETQ FIRSTCHAR (\WIN STRM)) (* minimum ascii code)
(SETQ LASTCHAR (\WIN STRM)) (* maximum ascii code)
(\WIN STRM) (* MaxWidth which isn't used by anyone.)
(\WIN STRM) (* number of words in this StrikeBody)
(replace CHARSETASCENT of CSINFO with (\WIN STRM))
(* ascent in scan lines (=FBBdy+FBBoy))
(replace CHARSETDESCENT of CSINFO with (\WIN STRM))
(* descent in scan-lines (=FBBoy))
(\WIN STRM) (* offset in bits (<0 for kerning, else 0, =FBBox))
(SETQ RW (\WIN STRM)) (* raster width of bitmap)
(* height of bitmap)
(SETQ HEIGHT (IPLUS (fetch CHARSETASCENT of CSINFO)
(fetch CHARSETDESCENT of CSINFO)))
(SETQ BITMAP (BITMAPCREATE (UNFOLD RW BITSPERWORD)
HEIGHT))
(\BINS STRM (fetch BITMAPBASE of BITMAP)
0
(UNFOLD (ITIMES RW HEIGHT)
BYTESPERWORD)) (* read bits into bitmap)
(replace CHARSETBITMAP of CSINFO with BITMAP)
(SETQ NUMBCODES (IPLUS (IDIFFERENCE LASTCHAR FIRSTCHAR)
3)) (* SETQ OFFSETS (ARRAY (IPLUS \MAXCHAR 3)
(QUOTE SMALLPOSP) 0 0))
(SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
(* initialise the offsets to 0)
(for I from 0 to (IPLUS \MAXTHINCHAR 2) do (\FSETOFFSET OFFSETS I 0))
(* AIN OFFSETS FIRSTCHAR NUMBCODES STRM)
(for I from FIRSTCHAR as J from 1 to NUMBCODES do (\FSETOFFSET OFFSETS I (\WIN STRM)))
(SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
(for I from 0 to (IPLUS \MAXTHINCHAR 2) do (\FSETWIDTH WIDTHS I 0))
(* replace WIDTHS of CSINFO with
(ARRAY (IPLUS \MAXCHAR 3) (QUOTE SMALLPOSP) 0 0))
(\FONTRESETCHARWIDTHS CSINFO FIRSTCHAR LASTCHAR)
(replace IMAGEWIDTHS of CSINFO with (fetch WIDTHS of CSINFO))
(RETURN CSINFO])
)
(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) (* gbn "15-Sep-85 13:53")
(* * None of this code has been updated to NS chars. It uses obsolete fields to ensure obsolete assumptions.
It should be razed! gbn)
(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
(QUOTE (2BIN -- no MACRO definition))
(QUOTE (\GETLKERN -- no MACRO definition))
(QUOTE (\GETRWIDTH -- no MACRO definition))
)
)
(DECLARE: EVAL@COMPILE
[PUTPROPS \FGETCHARIMAGEWIDTH MACRO (OPENLAMBDA (FONT CHARCODE CSVECTOR)
(\FGETWIDTH (ffetch (CHARSETINFO IMAGEWIDTHS)
of
(\GETCHARSETINFO (\CHARSET
CHARCODE)
FONT CSVECTOR))
(\CHAR8CODE CHARCODE]
(PROGN [PUTPROPS \GETFONTDESC DMACRO (X (COND ((CDR X)
(CONS (QUOTE \COERCEFONTDESC)
X))
(T (BQUOTE (\DTEST , (CAR X)
(QUOTE FONTDESCRIPTOR]
(PUTPROPS \GETFONTDESC MACRO (= . \COERCEFONTDESC)))
(PUTPROPS \SETCHARSETINFO MACRO ((CHARSETVECTOR CHARSET CSINFO)
(\RPLPTR CHARSETVECTOR (UNFOLD CHARSET 2)
CSINFO)))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(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 (3695 10987 (CHARWIDTH 3705 . 4354) (CHARWIDTHY 4356 . 5386) (STRINGWIDTH 5388 . 6269) (
\CHARWIDTH.DISPLAY 6271 . 6676) (\STRINGWIDTH.DISPLAY 6678 . 7146) (\STRINGWIDTH.GENERIC 7148 . 10985)
) (11168 16367 (DEFAULTFONT 11178 . 12423) (FONTCLASS 12425 . 14234) (FONTCLASSUNPARSE 14236 . 15052)
(FONTCLASSCOMPONENT 15054 . 15547) (SETFONTCLASSCOMPONENT 15549 . 16365)) (16368 79019 (FONTASCENT
16378 . 16546) (FONTCOPY 16548 . 19369) (FONTCREATE 19371 . 25268) (FONTSAVAILABLE 25270 . 29037) (
FONTDESCENT 29039 . 29304) (FONTFILEFORMAT 29306 . 30836) (FONTHEIGHT 30838 . 30936) (FONTP 30938 .
31224) (FONTPROP 31226 . 33870) (FONTUNPARSE 33872 . 35510) (SETFONTDESCRIPTOR 35512 . 36993) (
CHARCODEP 36995 . 37290) (GETCHARBITMAP 37292 . 38676) (PUTCHARBITMAP 38678 . 43469) (EDITCHAR 43471
. 43858) (\AVGCHARWIDTH 43860 . 44434) (\STREAMCHARWIDTH 44436 . 47170) (\UNITWIDTHSVECTOR 47172 .
47514) (\CREATEDISPLAYFONT 47516 . 48087) (\CREATECHARSET.DISPLAY 48089 . 53246) (\BUILDSLUGCSINFO
53248 . 54344) (\SEARCHDISPLAYFONTFILES 54346 . 56831) (\FONTFACE 56833 . 58607) (\FONTFILENAME 58609
. 61316) (\FONTINFOFROMFILENAME 61318 . 63036) (\GETFONTDESC 63038 . 63423) (\COERCEFONTDESC 63425 .
67407) (\LOOKUPFONT 67409 . 67894) (\LOOKUPFONTSINCORE 67896 . 69119) (\READDISPLAYFONTFILE 69121 .
70526) (\SFMAKEBOLD 70528 . 72513) (\SFMAKEITALIC 72515 . 74795) (\SFMAKEROTATEDFONT 74797 . 75377) (
\SFROTATECSINFO 75379 . 75907) (\SFROTATEFONTCHARACTERS 75909 . 76808) (\SFFIXOFFSETSAFTERROTATION
76810 . 77908) (\SFROTATECSINFOOFFSETS 77910 . 79017)) (89288 92680 (\CREATECHARSET 89298 . 92678)) (
93212 97993 (\FONTRESETCHARWIDTHS 93222 . 94684) (\READSTRIKEFONTFILE 94686 . 97991)) (98482 103214 (
\FONTDESCARRAY 98492 . 99048) (\READJERICHOFONTFILE 99050 . 103212)))))
STOP