(FILECREATED "18-Mar-86 19:36:42" {ERIS}<LISPCORE>SOURCES>FONT.;94 151106
changes to: (FNS CHARWIDTHY)
previous date: "28-Feb-86 14:55:24" {ERIS}<LISPCORE>SOURCES>FONT.;93)
(* Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT FONTCOMS)
(RPAQQ FONTCOMS
[(* font functions)
(FNS CHARWIDTH CHARWIDTHY STRINGWIDTH \CHARWIDTH.DISPLAY \STRINGWIDTH.DISPLAY
\STRINGWIDTH.GENERIC)
(* Until we pin down the exact interface)
(P (MOVD (QUOTE FONTCLASSCOMPONENT)
(QUOTE FONTCOMPONENT))
(MOVD (QUOTE SETFONTCLASSCOMPONENT)
(QUOTE SETFONTCOMPONENT)))
(FNS DEFAULTFONT FONTCLASS FONTCLASSUNPARSE FONTCLASSCOMPONENT SETFONTCLASSCOMPONENT)
(FNS FONTASCENT FONTCOPY FONTCREATE FONTSAVAILABLE FONTDESCENT FONTFILEFORMAT FONTHEIGHT
FONTP FONTPROP FONTUNPARSE SETFONTDESCRIPTOR CHARCODEP GETCHARBITMAP PUTCHARBITMAP
EDITCHAR \AVGCHARWIDTH \STREAMCHARWIDTH \UNITWIDTHSVECTOR \CREATEDISPLAYFONT
\CREATECHARSET.DISPLAY \BUILDSLUGCSINFO \SEARCHDISPLAYFONTFILES \FONTFACE \FONTFILENAME
\FONTINFOFROMFILENAME \GETFONTDESC \COERCEFONTDESC \LOOKUPFONT \LOOKUPFONTSINCORE
\READDISPLAYFONTFILE \SFMAKEBOLD \SFMAKEITALIC \SFMAKEROTATEDFONT \SFROTATECSINFO
\SFROTATEFONTCHARACTERS \SFFIXOFFSETSAFTERROTATION \SFROTATECSINFOOFFSETS \SFMAKECOLOR)
(INITRECORDS FONTCLASS FONTDESCRIPTOR CHARSETINFO)
(SYSRECORDS FONTCLASS FONTDESCRIPTOR CHARSETINFO)
(INITVARS (\FONTSINCORE)
(\DEFAULTDEVICEFONTS)
(\UNITWIDTHSVECTOR))
(GLOBALVARS DISPLAYFONTDIRECTORIES \DEFAULTDEVICEFONTS \UNITWIDTHSVECTOR)
(P (\UNITWIDTHSVECTOR))
(CONSTANTS (NORUNCODE 255))
(EXPORT (MACROS FONTPROP))
[DECLARE: DONTCOPY
(EXPORT (RECORDS FONTCLASS FONTDESCRIPTOR FONTFACE CHARSETINFO)
(MACROS FONTASCENT FONTDESCENT FONTHEIGHT \FGETOFFSET \FSETOFFSET \FGETWIDTH
\FSETWIDTH \FGETCHARWIDTH \FGETIMAGEWIDTH \FSETIMAGEWIDTH
\GETCHARSETINFO \CREATECSINFOELEMENT \CREATEFONTCHARSETVECTOR)
(CONSTANTS (\MAXNSCHAR 65535]
(COMS (* NS Character specific code)
(FNS \CREATECHARSET)
(GLOBALVARS DISPLAYFONTCOERCIONS MISSINGDISPLAYFONTCOERCIONS CHARSETERRORFLG)
(INITVARS (DISPLAYFONTCOERCIONS NIL)
[MISSINGDISPLAYFONTCOERCIONS (QUOTE (((GACHA)
(TERMINAL))
((MODERN)
(CLASSIC))
((TIMESROMAN)
(CLASSIC))
((HELVETICA)
(MODERN]
(CHARSETERRORFLG NIL)
(\DEFAULTCHARSET 0)))
[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]
(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) (* edited:
"18-Mar-86 19:30")
(* Gets the Y-component
of the width of a character
code in a font.)
(OR (\CHARCODEP CHARCODE)
(\ILLEGAL.ARG CHARCODE))
(LET (TEMP WY)
(COND
((type? FONTDESCRIPTOR FONT)
(SETQ WY (ffetch (CHARSETINFO YWIDTHS) of (\GETCHARSETINFO (\CHARSET CHARCODE)
FONT)))
(COND
((FIXP WY))
(WY (\FGETWIDTH WY (\CHAR8CODE CHARCODE)))
(T 0)))
((type? STREAM (SETQ TEMP (\OUTSTREAMARG FONT T))) (* NIL font goes thru
here--primary output file)
(IMAGEOP (QUOTE IMCHARWIDTHY)
TEMP TEMP CHARCODE))
(T [SETQ WY (ffetch (CHARSETINFO YWIDTHS) of (\GETCHARSETINFO (\CHARSET CHARCODE)
(FONTCREATE FONT]
(COND
((FIXP WY))
(WY (\FGETWIDTH WY (\CHAR8CODE CHARCODE)))
(T 0])
(STRINGWIDTH
(LAMBDA (STR FONT FLG RDTBL) (* rmk: "12-Apr-85 09:45")
(* Returns the width of STR according to FONT)
(LET (TEMP) (* Used in \MAPCHARS)
(COND
((type? FONTDESCRIPTOR FONT)
(\STRINGWIDTH.GENERIC STR FONT (AND FLG (\GTREADTABLE RDTBL))
(\FGETCHARWIDTH FONT (CHARCODE SPACE))))
((SETQ TEMP (\OUTSTREAMARG FONT T)) (* NIL font goes thru here--primary output file)
(IMAGEOP (QUOTE IMSTRINGWIDTH)
TEMP TEMP STR (AND FLG (\GTREADTABLE RDTBL))))
(T (SETQ TEMP (FONTCREATE FONT))
(\STRINGWIDTH.GENERIC STR TEMP (AND FLG (\GTREADTABLE RDTBL))
(\FGETCHARWIDTH TEMP (CHARCODE SPACE))))))))
(\CHARWIDTH.DISPLAY
(LAMBDA (STREAM CHARCODE) (* rmk: "12-Apr-85 09:42")
(* gets the width of a character code in a display
stream. Need to fix up for spacefactor.)
(\FGETCHARWIDTH (ffetch (\DISPLAYDATA DDFONT) of (ffetch IMAGEDATA of STREAM))
CHARCODE)))
(\STRINGWIDTH.DISPLAY
(LAMBDA (STREAM STR RDTBL) (* rmk: " 4-Apr-85 14:03")
(* Returns the width of for the current
font/spacefactor in STREAM.)
(LET ((DD (ffetch IMAGEDATA of STREAM)))
(\STRINGWIDTH.GENERIC STR (ffetch (\DISPLAYDATA DDFONT) of DD)
RDTBL
(ffetch DDSPACEWIDTH of DD)))))
(\STRINGWIDTH.GENERIC
[LAMBDA (STR FONT RDTBL SPACEWIDTH) (* jds
"28-Feb-86 14:41")
(* 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
(COND
((EQ STR (QUOTE %.)) (* Period alone is
treated specially,
since it's always
escaped.)
(IPLUS (\FGETCHARWIDTH FONT (CHARCODE %%)
CSVECTOR)
(\FGETCHARWIDTH FONT (CHARCODE %.)
CSVECTOR)))
(T (* Otherwise, just
run thru the atom,
totalling character
widths.)
(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)
(SETQ FL FONTLIST)
(SETQ FC (create FONTCLASS
FONTCLASSNAME ← NAME
PRETTYFONT# ←(OR (FIXP (pop FL))
1)
DISPLAYFD ←(AND (SETQ F (pop FL))
(FONTCREATE F NIL NIL NIL (QUOTE DISPLAY)))
PRESSFD ←(pop FL)
INTERPRESSFD ←(pop FL)
OTHERFDS ←(for FSPEC in FL
collect (OR (AND (LISTP FSPEC)
(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 "24-Jan-86 11:58")
(* Given a font class, unparse it to a form that might
be reparsable)
(APPEND (LIST (fetch (FONTCLASS FONTCLASSNAME) of FONTCLASS)
(fetch (FONTCLASS PRETTYFONT#) of FONTCLASS)
(FONTUNPARSE (ffetch (FONTCLASS DISPLAYFD) of FONTCLASS))
(FONTUNPARSE (ffetch (FONTCLASS PRESSFD) of FONTCLASS))
(FONTUNPARSE (ffetch (FONTCLASS INTERPRESSFD) of FONTCLASS)))
(for X in (fetch (FONTCLASS OTHERFDS) of FONTCLASS)
collect (LIST (CAR X)
(FONTUNPARSE (CDR X)))))))
(FONTCLASSCOMPONENT
(LAMBDA (FONTCLASS DEVICE FONT NOERRORFLG) (* rmk: "14-Sep-84 19:34")
(PROG1 (FONTCREATE FONTCLASS NIL NIL NIL DEVICE NOERRORFLG)
(* This works its way down to \COERCEFONTDESC, where
it needs to be done quickly)
(AND FONT (SETQ FONT (FONTCREATE FONT NIL NIL NIL DEVICE NOERRORFLG))
(SETFONTCLASSCOMPONENT FONTCLASS DEVICE FONT)))))
(SETFONTCLASSCOMPONENT
(LAMBDA (FONTCLASS DEVICE FONT) (* rmk: "14-Sep-84 23:09")
(PROG ((NEWFONT (FONTCREATE FONT NIL NIL NIL DEVICE)))
(* replaces will barf if FONTCLASS is not a fontclass)
(SELECTQ DEVICE
((NIL DISPLAY)
(replace (FONTCLASS DISPLAYFD) of FONTCLASS with NEWFONT))
(INTERPRESS (replace (FONTCLASS INTERPRESSFD) of FONTCLASS with
NEWFONT))
(PRESS (replace (FONTCLASS PRESSFD) of FONTCLASS with NEWFONT))
(RPLACD (OR (ASSOC DEVICE (fetch (FONTCLASS OTHERFDS) of FONTCLASS)
)
(CAR (push (fetch (FONTCLASS OTHERFDS) of FONTCLASS)
(CONS DEVICE))))
NEWFONT))
(RETURN NEWFONT))))
)
(DEFINEQ
(FONTASCENT
(LAMBDA (FONTSPEC) (* lmm "19-NOV-82 00:23")
(ffetch \SFAscent of (\GETFONTDESC FONTSPEC))))
(FONTCOPY
(LAMBDA FONTSPECS (* gbn: "25-Jan-86 17:45")
(* makes a copy of a font changing the specified
fields.)
(PROG (NOERROR FAMILY FACE SIZE ROTATION DEVICE OLDFONT)
(SETQ OLDFONT (\GETFONTDESC (ARG FONTSPECS 1)
(AND (type? FONTCLASS (ARG FONTSPECS 1))
(COND
((AND (EQ FONTSPECS 2)
(LISTP (ARG FONTSPECS 2)))
(LISTGET (ARG FONTSPECS 2)
(QUOTE DEVICE)))
(T (for I from 2 by 2 to FONTSPECS
do (COND
((AND (NEQ I FONTSPECS)
(EQ (ARG FONTSPECS I)
(QUOTE DEVICE)))
(RETURN (ARG FONTSPECS
(ADD1 I))))))))
)))
(SETQ FAMILY (fetch (FONTDESCRIPTOR FONTFAMILY) of OLDFONT))
(SETQ SIZE (fetch (FONTDESCRIPTOR FONTSIZE) of OLDFONT))
(SETQ FACE (fetch (FONTDESCRIPTOR FONTFACE) of OLDFONT))
(SETQ ROTATION (fetch (FONTDESCRIPTOR ROTATION) of OLDFONT))
(SETQ DEVICE (fetch (FONTDESCRIPTOR FONTDEVICE) of OLDFONT))
(for I VAL from 2 by 2 to FONTSPECS
do (SETQ VAL (COND
((NOT (EQ I FONTSPECS))
(ARG FONTSPECS (ADD1 I)))))
(SELECTQ (ARG FONTSPECS I)
(FAMILY (SETQ FAMILY VAL))
(SIZE (SETQ SIZE VAL))
(FACE (SETQ FACE (\FONTFACE VAL)))
(WEIGHT (SETQ FACE (create FONTFACE using FACE WEIGHT ← VAL)))
(SLOPE (SETQ FACE (create FONTFACE using FACE SLOPE ← VAL)))
(EXPANSION (SETQ FACE (create FONTFACE using FACE EXPANSION ←
VAL)))
(BACKCOLOR (SETQ FACE (create FONTFACE using FACE BACKCOLOR ←
VAL)))
(FORECOLOR (SETQ FACE (create FONTFACE using FACE FORECOLOR ←
VAL)))
(ROTATION (SETQ ROTATION VAL))
(DEVICE (SETQ DEVICE VAL))
(NOERROR (SETQ NOERROR VAL))
(COND
((AND (EQ I 2)
(EQ FONTSPECS 2)
(LISTP (ARG FONTSPECS 2)))
(for J on (ARG FONTSPECS 2) by (CDDR J)
do (SETQ VAL (CADR J))
(SELECTQ (CAR J)
(FAMILY (SETQ FAMILY VAL))
(SIZE (SETQ SIZE VAL))
(FACE (SETQ FACE (\FONTFACE VAL)))
(WEIGHT (SETQ FACE
(create FONTFACE
using FACE WEIGHT ← VAL)))
(SLOPE (SETQ FACE
(create FONTFACE
using FACE SLOPE ← VAL)))
(EXPANSION (SETQ FACE
(create FONTFACE
using FACE EXPANSION ← VAL)))
(BACKCOLOR (SETQ FACE
(create FONTFACE
using FACE BACKCOLOR ← VAL)))
(FORECOLOR (SETQ FACE
(create FONTFACE
using FACE FORECOLOR ← VAL)))
(ROTATION (SETQ ROTATION VAL))
(DEVICE (SETQ DEVICE VAL))
(NOERROR (SETQ NOERROR VAL))
(\ILLEGAL.ARG (CAR J)))))
(T (\ILLEGAL.ARG (ARG FONTSPECS I))))))
(RETURN (FONTCREATE FAMILY SIZE FACE ROTATION DEVICE NOERROR)))))
(FONTCREATE
(LAMBDA (FAMILY SIZE FACE ROTATION DEVICE NOERRORFLG CHARSET)
(* gbn: "25-Jan-86 17:53")
(* * Create a font descriptor for the specified font. If NOERRORFLG, return NIL if the font doesn't exist;
otherwise cause an error.)
(* Cache and fonts.widths traffic in uppercase only.)
(* character set is optional and defaults to
\DEFAULTCHARSET (0 in our world))
(DECLARE (GLOBALVARS IMAGESTREAMTYPES))
(PROG (FONTX (DEV (COND
((type? STREAM DEVICE)
(fetch (IMAGEOPS IMFONTCREATE) of (fetch (STREAM IMAGEOPS)
of DEVICE)))
(DEVICE)
(T (QUOTE DISPLAY))))
(CHSET (OR CHARSET \DEFAULTCHARSET)))
(RETURN (COND
((LISTP FAMILY)
(SELECTQ (CAR FAMILY)
(FONT (SETQ FONTX (CDR FAMILY)))
(CLASS (COND
((LITATOM (CADR FAMILY))
(* litatom class name)
(RETURN (FONTCLASS (CADR FAMILY)
(CDDR FAMILY)
DEV)))
(T (* Allows for a font named CLASS--distinguished cause
its size is not a litatom)
(SETQ FONTX FAMILY))))
(SETQ FONTX FAMILY))
(FONTCREATE (CAR FONTX)
(OR (CADR FONTX)
SIZE)
(OR (CADDR FONTX)
FACE)
(OR (CADDDR FONTX)
ROTATION)
(OR (CADR (CDDDR FONTX))
DEV)
NOERRORFLG CHSET))
((SETQ FONTX (COND
((type? FONTDESCRIPTOR FAMILY)
FAMILY)
((NULL FAMILY)
(DEFAULTFONT DEV))
((type? FONTCLASS FAMILY)
(* We know that this won't attempt a cyclic fontcreate in \COERCEFONTDESC, because we are passing a known class.
Unless NOERROFLG, an error will be caused on the actual device font if it can't be found.)
(\COERCEFONTDESC FAMILY DEV NOERRORFLG))
((OR (IMAGESTREAMP FAMILY)
(type? WINDOW FAMILY))
(DSPFONT NIL FAMILY)))) (* FAMILY was a spec for a font descriptor, use it and
extend it by the other args.)
(COND
((OR SIZE FACE ROTATION DEVICE)
(FONTCREATE (FONTPROP FONTX (QUOTE FAMILY))
(OR SIZE (FONTPROP FONTX (QUOTE SIZE)))
(OR FACE (FONTPROP FONTX (QUOTE FACE)))
(OR ROTATION (FONTPROP FONTX (QUOTE ROTATION)))
(OR DEVICE (FONTPROP FONTX (QUOTE DEVICE)))
NOERRORFLG))
(T FONTX)))
(T (PROG (FONTFACE TEMPDEV)
RETRY
(OR (LITATOM FAMILY)
(COND
(NOERRORFLG (RETURN))
(T (LISPERROR "ARG NOT LITATOM" FAMILY T))))
(OR (AND (FIXP SIZE)
(IGREATERP SIZE 0))
(COND
(NOERRORFLG (RETURN NIL))
(T (\ILLEGAL.ARG SIZE))))
(SETQ FONTFACE (OR (\FONTFACE FACE NOERRORFLG DEV)
(RETURN NIL)))
(OR (U-CASEP FAMILY)
(SETQ FAMILY (U-CASE FAMILY)))
(COND
((NULL ROTATION)
(SETQ ROTATION 0))
((AND (FIXP ROTATION)
(IGEQ ROTATION 0)))
(NOERRORFLG (RETURN NIL))
(T (\ILLEGAL.ARG ROTATION)))
NEWDEV
(RETURN (COND
((\LOOKUPFONT FAMILY SIZE FONTFACE ROTATION DEV))
((SETQ FONTX (ASSOC (QUOTE FONTCREATE)
(CDR (ASSOC DEV
IMAGESTREAMTYPES))))
(* We found the device, but maybe didn't find the
font. We know not to try to coerce the device into a
stream, though.)
(COND
((SETQ FONTX
(APPLY* (OR (CADR FONTX)
(FUNCTION NILL))
FAMILY SIZE FONTFACE ROTATION DEV
CHSET))
(* default creation case. Use fontcreate method from
device, build a fontdescriptor and use
setfontdescriptor to install it.)
(* OBSOLETEd by the CHARSETINFO code
(OR (ffetch FONTIMAGEWIDTHS of FONTX)
(freplace FONTIMAGEWIDTHS of FONTX with
(ffetch \SFWidths of FONTX))))
(* * the widths fields in the fontdescriptor are obsolete, and shoudln't be updated here.)
(* We should probably force all device implementations
to obey these conventions, then remove these generic
updates)
(replace (FONTDESCRIPTOR FONTAVGCHARWIDTH)
of FONTX with (\AVGCHARWIDTH FONTX))
(SETFONTDESCRIPTOR FAMILY SIZE FONTFACE
ROTATION DEV FONTX))
(T (GO NOTFOUND))))
((AND (NULL TEMPDEV)
(SETQ TEMPDEV (\GETSTREAM DEVICE
(QUOTE OUTPUT)
T)))
(* Here only if we haven't recognized the device. This could be slow for litatoms, but unless NOERROR, we are
heading for an error anyway. But for things like windows, it will be reasonably fast. We don't do this above cause
the recognized litatom case is common.)
(* Don't change DEV to NIL, so it is meaningful in
error message)
(SETQ DEV (fetch (IMAGEOPS IMFONTCREATE)
of (fetch (STREAM IMAGEOPS)
of TEMPDEV)))
(GO NEWDEV))
(T (GO NOTFOUND))))
NOTFOUND
(COND
(NOERRORFLG (RETURN NIL))
(T (ERROR "FONT NOT FOUND" (LIST FAMILY SIZE FONTFACE
ROTATION DEV))
(GO RETRY))))))))))
(FONTSAVAILABLE
(LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHECKFILESTOO?)
(* rrb " 7-Nov-84 15:41")
(* * returns a list of the fonts fitting a description that are available. FAMILY SIZE FACE or ROTATION can be *
which means get them all. if LOADEDONLYFLG is non-NIL, only fonts in core will be considered.)
(DECLARE (GLOBALVARS IMAGESTREAMTYPES))
(PROG (FONTX DEV)
(SETQ DEV (COND
((type? STREAM DEVICE)
(COND
((LISTP (SETQ DEV (IMAGESTREAMTYPE DEVICE)))
(CAR DEV))
(T DEV)))
(DEVICE)
(T (QUOTE DISPLAY))))
(RETURN
(COND
((LISTP FAMILY)
(COND
((EQ (CAR FAMILY)
(QUOTE FONT))
(SETQ FONTX (CDR FAMILY)))
(T (SETQ FONTX FAMILY)))
(FONTSAVAILABLE (CAR FONTX)
(OR (CADR FONTX)
SIZE)
(OR (CADDR FONTX)
FACE)
(OR (CADDDR FONTX)
ROTATION)
DEV CHECKFILESTOO?))
((SETQ FONTX (COND
((type? FONTDESCRIPTOR FAMILY)
FAMILY)
((NULL FAMILY)
(DEFAULTFONT DEV))
((type? FONTCLASS FAMILY)
(* We know that this won't attempt a cyclic fontcreate in \COERCEFONTDESC, because we are passing a known class.
Unless NOERROFLG, an error will be caused on the actual device font if it can't be found.)
(* I don't know what to do in this case- rrb.)
(\COERCEFONTDESC FAMILY DEV T))
((OR (IMAGESTREAMP FAMILY)
(type? WINDOW FAMILY))
(DSPFONT NIL FAMILY)))) (* FAMILY was a spec for a font descriptor, use it and
extend it by the other args.)
(FONTSAVAILABLE (FONTPROP FONTX (QUOTE FAMILY))
(OR SIZE (FONTPROP FONTX (QUOTE SIZE)))
(OR FACE (FONTPROP FONTX (QUOTE FACE)))
(OR ROTATION (FONTPROP FONTX (QUOTE ROTATION)))
(OR DEVICE (FONTPROP FONTX (QUOTE DEVICE)))
CHECKFILESTOO?))
(T (PROG ((FONTFACE FACE))
RETRY
(OR (LITATOM FAMILY)
(LISPERROR "ARG NOT LITATOM" FAMILY T))
(OR (AND (FIXP SIZE)
(IGREATERP SIZE 0))
(EQ SIZE (QUOTE *))
(\ILLEGAL.ARG SIZE))
(OR (EQ FONTFACE (QUOTE *))
(SETQ FONTFACE (OR (\FONTFACE FACE T)
(RETURN NIL))))
(OR (U-CASEP FAMILY)
(SETQ FAMILY (U-CASE FAMILY)))
(COND
((NULL ROTATION)
(SETQ ROTATION 0))
((AND (FIXP ROTATION)
(IGEQ ROTATION 0)))
((EQ ROTATION (QUOTE *)))
(T (\ILLEGAL.ARG ROTATION)))
(RETURN (UNION
(\LOOKUPFONTSINCORE FAMILY SIZE FONTFACE ROTATION DEV)
(COND
((NOT CHECKFILESTOO?)
NIL)
((EQ DEV (QUOTE *))
(* map thru all the devices.)
(for EXTANTDEV in IMAGESTREAMTYPES
join (APPLY* (OR (CADR (ASSOC (QUOTE
FONTSAVAILABLE)
(CDR
EXTANTDEV)))
(FUNCTION NILL))
FAMILY SIZE FONTFACE ROTATION
(CAR EXTANTDEV))))
(T (* apply the device font lookup function.)
(APPLY* (OR (CADR (ASSOC (QUOTE FONTSAVAILABLE)
(CDR (ASSOC DEV
IMAGESTREAMTYPES))))
(FUNCTION NILL))
FAMILY SIZE FONTFACE ROTATION DEV))))))))))))
(FONTDESCENT
(LAMBDA (FONTSPEC) (* lmm "19-NOV-82 00:24")
(* See comment in FONTASCENT)
(ffetch \SFDescent of (\GETFONTDESC FONTSPEC))))
(FONTFILEFORMAT
(LAMBDA (STRM LEAVEOPEN) (* rmk: "11-Sep-84 17:16")
(* Returns the font format of STRM)
(OR (OPENP STRM (QUOTE INPUT))
(SETQ STRM (OPENSTREAM STRM (QUOTE INPUT)
(QUOTE OLD))))
(PROG1 (SELECTC (\WIN STRM)
((LIST (LLSH 1 15)
(LOGOR (LLSH 1 15)
(LLSH 1 13)))
(* If high bit of type is on, then must be strike. If 2nd bit is on, must be strike-index, and we punt.
We don't care about the 3rd bit)
(* first word has high bits (onebit index fixed). Onebit means "new-style font", index is 0 for simple strike, 1
for index, and fixed is if all chars have max width. Lisp doesn't care about "fixed")
(QUOTE STRIKE))
((LOGOR (LLSH 16 8)
12) (* This is the length of a standard index header.
Other files could also have this value, but it's a
pretty good discriminator)
(* Skip to byte 25; do it with BINS so works for non-randaccessp devices. This skips the standard name header, then
look for type 3 in the following header)
(FRPTQ 22 (\BIN STRM)) (* (SETFILEPTR STRM 25))
(AND (EQ 3 (LRSH (\BIN STRM)
4))
(QUOTE AC)))
NIL)
(OR LEAVEOPEN (CLOSEF STRM)))))
(FONTHEIGHT
(LAMBDA (FONTSPEC) (* kbr: " 9-Jan-86 18:29")
(fetch (FONTDESCRIPTOR \SFHeight) of (\GETFONTDESC FONTSPEC))))
(FONTP
(LAMBDA (X) (* rmk: "13-Sep-84 09:04")
(* is X a FONTDESCRIPTOR?)
(COND
((OR (type? FONTDESCRIPTOR X)
(type? FONTCLASS X))
X))))
(FONTPROP
(LAMBDA (FONT PROP) (* kbr: "13-May-85 22:36")
(SETQ FONT (\GETFONTDESC FONT))
(SELECTQ PROP
(HEIGHT (ffetch \SFHeight of FONT))
(ASCENT (ffetch \SFAscent of FONT))
(DESCENT (ffetch \SFDescent of FONT))
(FAMILY (ffetch FONTFAMILY of FONT))
(SIZE (ffetch FONTSIZE of FONT))
(FACE (COPY (ffetch FONTFACE of FONT)))
(WEIGHT (ffetch WEIGHT of (ffetch FONTFACE of FONT)))
(SLOPE (ffetch SLOPE of (ffetch FONTFACE of FONT)))
(EXPANSION (ffetch EXPANSION of (ffetch FONTFACE of FONT)))
(FORECOLOR (ffetch FORECOLOR of (ffetch FONTFACE of FONT)))
(BACKCOLOR (ffetch BACKCOLOR of (ffetch FONTFACE of FONT)))
(ROTATION (ffetch ROTATION of FONT))
(DEVICE (ffetch FONTDEVICE of FONT))
(SPEC (LIST (ffetch FONTFAMILY of FONT)
(ffetch FONTSIZE of FONT)
(COPY (ffetch FONTFACE of FONT))
(ffetch ROTATION of FONT)
(ffetch FONTDEVICE of FONT)))
(DEVICESPEC (* DEVICE fields are for communicating coercions to the
particular printing device)
(COND
((ffetch FONTDEVICESPEC of FONT)
(COPY (ffetch FONTDEVICESPEC of FONT)))
(T (FONTPROP FONT (QUOTE SPEC)))))
(DEVICEFACE (COPY (COND
((ffetch FONTDEVICESPEC of FONT)
(CADDR (ffetch FONTDEVICESPEC of FONT)))
(T (ffetch FONTFACE of FONT)))))
(DEVICESLOPE (fetch SLOPE of (COND
((ffetch FONTDEVICESPEC of FONT)
(CADDR (ffetch FONTDEVICESPEC of FONT)))
(T (ffetch FONTFACE of FONT)))))
(DEVICEWEIGHT (fetch WEIGHT of (COND
((ffetch FONTDEVICESPEC of FONT)
(CADDR (ffetch FONTDEVICESPEC of FONT)))
(T (ffetch FONTFACE of FONT)))))
(DEVICEEXPANSION (fetch EXPANSION of (COND
((ffetch FONTDEVICESPEC of FONT)
(CADDR (ffetch FONTDEVICESPEC of FONT)))
(T (ffetch FONTFACE of FONT)))))
(DEVICESIZE (COND
((ffetch FONTDEVICESPEC of FONT)
(CADR (ffetch FONTDEVICESPEC of FONT)))
(T (ffetch FONTSIZE of FONT))))
(DEVICEFAMILY (COND
((ffetch FONTDEVICESPEC of FONT)
(CAR (ffetch FONTDEVICESPEC of FONT)))
(T (ffetch FONTFAMILY of FONT))))
(SCALE (ffetch FONTSCALE of FONT))
(\ILLEGAL.ARG PROP))))
(FONTUNPARSE
(LAMBDA (FONT) (* kbr:
"25-Feb-86 19:40")
(* Produces a minimal
specification of the
font or fontclass
specification, for
dumping by Tedit,
imageobjects.)
(PROG (FACE SPEC)
(SETQ SPEC (COND
((type? FONTDESCRIPTOR FONT)
(FONTPROP FONT (QUOTE SPEC)))
((type? FONTCLASS FONT)
(RETURN (CONS (QUOTE CLASS)
(FONTCLASSUNPARSE FONT))))
(T (* Could be a
non-instantiated
specification in a
fontclass, just use it
as the spec without
creating the font.)
FONT)))
(OR SPEC (RETURN))
(SETQ FACE (CADDR SPEC)) (* FACE and rotation
can be NIL for a
non-fontdescriptor
fontclass component)
(SETQ FACE (COND
((OR (NULL FACE)
(EQUAL FACE (QUOTE (MEDIUM REGULAR REGULAR))))
NIL)
((LITATOM FACE)
FACE)
((LISTP FACE)
(PACK (LIST* (NTHCHAR (fetch (FONTFACE WEIGHT) of FACE)
1)
(NTHCHAR (fetch (FONTFACE SLOPE) of FACE)
1)
(NTHCHAR (fetch (FONTFACE EXPANSION) of FACE)
1)
(COND
((fetch (FONTFACE COLOR) of FACE)
(LIST "-" (fetch (FONTFACE BACKCOLOR) of FACE)
"-"
(fetch (FONTFACE FORECOLOR) of FACE)))))))
(T (SHOULDNT)))) (* Don't return
device, or any trailing
defaults)
(RETURN (CONS (CAR SPEC)
(CONS (CADR SPEC)
(COND
((AND (CADDDR SPEC)
(NOT (EQ 0 (CADDDR SPEC))))
(LIST (OR FACE (QUOTE MRR))
(CADDDR SPEC)))
(FACE (CONS FACE)))))))))
(SETFONTDESCRIPTOR
(LAMBDA (FAMILY SIZE FACE ROTATION DEVICE FONT) (* kbr: "22-May-85 21:33")
(* saves a font descriptor under a
family/size/face/rotation/device key so that it will be
retreived by FONTCREATE. This is a user entry.)
(DECLARE (GLOBALVARS \FONTSINCORE))
(OR DEVICE (SETQQ DEVICE DISPLAY))
(COND
((NULL FONT) (* NIL is used to clobber existing font so that next
use will reread it.)
NIL)
(T (SETQ FONT (\COERCEFONTDESC FONT DEVICE))))
(SETQ FACE (\FONTFACE FACE NIL DEVICE))
(OR ROTATION (SETQ ROTATION 0))
(PROG ((X (OR (FASSOC FAMILY \FONTSINCORE)
(CAR (push \FONTSINCORE (LIST FAMILY))))))
(SETQ X (OR (FASSOC SIZE (CDR X))
(CAR (push (CDR X)
(LIST SIZE)))))
(SETQ X (OR (SASSOC FACE (CDR X))
(CAR (push (CDR X)
(LIST FACE))))) (* SASSOC cause FACE is listp)
(SETQ X (OR (FASSOC ROTATION (CDR X))
(CAR (push (CDR X)
(LIST ROTATION)))))
(SETQ X (OR (FASSOC DEVICE (CDR X))
(CAR (push (CDR X)
(LIST DEVICE)))))
(RPLACD X FONT)
(RETURN FONT))))
(CHARCODEP
(LAMBDA (CHCODE) (* gbn "22-Jul-85 16:35")
(* is CHCODE a legal character code?)
(AND (SMALLP CHCODE)
(IGEQ CHCODE 0)
(ILEQ CHCODE \MAXNSCHAR))))
(GETCHARBITMAP
(LAMBDA (CHARCODE FONT) (* gbn: "25-Jan-86 17:57")
(* 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 (fetch (CHARSETINFO WIDTHS)
of CSINFO)
(\CHAR8CODE CHARCODE)))
(SETQ CHGHT (FONTPROP FONTDESC (QUOTE HEIGHT)))
(fetch (BITMAP BITMAPBITSPERPIXEL)
of (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO))))
(BITBLT (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO)
(\FGETOFFSET (fetch (CHARSETINFO OFFSETS) of CSINFO)
(\CHAR8CODE CHARCODE))
0 CBM 0 0 CWDTH CHGHT)
(RETURN CBM))))
(PUTCHARBITMAP
[LAMBDA (CHARCODE FONT NEWCHARBITMAP NEWCHARDESCENT) (* gbn
"21-Feb-86 16:24")
(* stores the bitmap NEWCHARBITMAP as the character CHARCODE from the
font descriptor FONTDESC. If NEWCHARDESCENT is specified, it is the
descent of the new bitmap, and things may be moved to accomodate it.)
(OR (TYPENAMEP NEWCHARBITMAP (QUOTE BITMAP))
(\ILLEGAL.ARG NEWCHARBITMAP))
(COND
((CHARCODEP CHARCODE))
((OR (STRINGP CHARCODE)
(LITATOM CHARCODE))
(SETQ CHARCODE (CHCON1 CHARCODE)))
(T (\ILLEGAL.ARG CHARCODE)))
(PROG*((FONTDESC (\GETFONTDESC FONT))
(CWDTH (CHARWIDTH CHARCODE FONTDESC))
(CHGHT (FONTPROP FONTDESC (QUOTE HEIGHT)))
(CDESC (FONTPROP FONTDESC (QUOTE DESCENT)))
(CASC (FONTPROP FONTDESC (QUOTE ASCENT)))
(CSINFO (\GETCHARSETINFO (\CHARSET CHARCODE)
FONTDESC))
(OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
(WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
(FONTBITMAP (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO))
(OFWIDTH (fetch (BITMAP BITMAPWIDTH) of FONTBITMAP))
(NDESCENT (OR NEWCHARDESCENT CDESC))
TEMPBITMAP NWIDTH DW NHEIGHT CHAROFFSET (BITSPERPIXEL (fetch (BITMAP
BITMAPBITSPERPIXEL
) of
FONTBITMAP
)))
[COND
((EQ (\FGETOFFSET OFFSETS (\CHAR8CODE CHARCODE))
(\FGETOFFSET OFFSETS 255))
(* * changing the bitmap for a character which formerly pointed at the
slug character. Allocate a new bitmap character bitmap for this.)
(SETQ NWIDTH (fetch (BITMAP BITMAPWIDTH) of NEWCHARBITMAP))
(* Difference in
character widths)
(SETQ NHEIGHT (IMAX (fetch (BITMAP BITMAPHEIGHT) of NEWCHARBITMAP)
(IPLUS CASC NDESCENT))) (* Allow for a new
descent along with the
newimage for this
formerly slug character)
(SETQ TEMPBITMAP (BITMAPCREATE (IPLUS OFWIDTH NWIDTH)
NHEIGHT BITSPERPIXEL))
(SETQ CHAROFFSET OFWIDTH)
(BITBLT FONTBITMAP 0 0 TEMPBITMAP 0 (IMAX 0 (IDIFFERENCE NDESCENT CDESC))
OFWIDTH CHGHT) (* copy the old
bitmap into the temp)
(BITBLT NEWCHARBITMAP 0 0 TEMPBITMAP CHAROFFSET 0 NWIDTH CHGHT) (* Insert the new
character at the end)
(UNINTERRUPTABLY
(\FSETWIDTH WIDTHS (\CHAR8CODE CHARCODE)
NWIDTH) (* The new
character's correct
width)
(\FSETOFFSET OFFSETS (\CHAR8CODE CHARCODE)
CHAROFFSET)
(replace (CHARSETINFO CHARSETBITMAP) of CSINFO with TEMPBITMAP)
(if (ILESSP CHGHT NHEIGHT)
then (* update the font
descriptor to reflect
the height/descent
changes)
(replace (FONTDESCRIPTOR \SFDescent) of FONTDESC
with (IMAX NDESCENT CDESC))
(replace (FONTDESCRIPTOR \SFHeight) of FONTDESC with NHEIGHT)
(replace (FONTDESCRIPTOR \SFAscent) of FONTDESC
with (IDIFFERENCE NHEIGHT (IMAX NDESCENT CDESC)))
(replace (CHARSETINFO CHARSETDESCENT) of CSINFO
with (fetch (FONTDESCRIPTOR \SFDescent) of FONTDESC))
(replace (CHARSETINFO CHARSETASCENT) of CSINFO
with (fetch (FONTDESCRIPTOR \SFAscent) of FONTDESC))))
(RETURN NEWCHARBITMAP))
([ILESSP CHGHT (SETQ NHEIGHT (IMAX (fetch (BITMAP BITMAPHEIGHT) of NEWCHARBITMAP)
(IPLUS CASC NDESCENT]
(* * The new character is TALLER than the existing bitmap.
Make a larger bitmap.)
(SETQ TEMPBITMAP (BITMAPCREATE OFWIDTH NHEIGHT BITSPERPIXEL)) (* Make the new
bitmap)
(BITBLT FONTBITMAP 0 0 TEMPBITMAP 0 (IMAX 0 (IDIFFERENCE NDESCENT CDESC)))
(* Copy the existing
bitmap into it,
adjusting for a larger
descent in the new
character (if there is
one))
(SETQ CHGHT NHEIGHT) (* Remember the new
height for later use)
(SETQ FONTBITMAP TEMPBITMAP) (* And forget that we
made this change.)
(UNINTERRUPTABLY
(replace (CHARSETINFO CHARSETBITMAP) of CSINFO with TEMPBITMAP)
(* Save the new
bitmap, in case there
are no further problems)
(replace (FONTDESCRIPTOR \SFDescent) of FONTDESC with (IMAX NDESCENT CDESC))
(* And the new height
and descent.)
(replace (FONTDESCRIPTOR \SFHeight) of FONTDESC with NHEIGHT)
(replace (FONTDESCRIPTOR \SFAscent) of FONTDESC with (IDIFFERENCE
NHEIGHT
(IMAX NDESCENT CDESC))
)
(replace (CHARSETINFO CHARSETDESCENT) of CSINFO with (fetch (
FONTDESCRIPTOR
\SFDescent)
of FONTDESC))
(replace (CHARSETINFO CHARSETASCENT) of CSINFO with (fetch (
FONTDESCRIPTOR
\SFAscent)
of FONTDESC)))]
(COND
((NEQ CWDTH (SETQ NWIDTH (fetch (BITMAP BITMAPWIDTH) of NEWCHARBITMAP)))
(* The bitmaps differ
in width; create a new
bitmap with things at
the right places, then
update widths and
offsets.)
(SETQ DW (IDIFFERENCE NWIDTH CWDTH)) (* Difference in
character widths)
(SETQ TEMPBITMAP (BITMAPCREATE (IPLUS OFWIDTH DW)
CHGHT BITSPERPIXEL))
(BITBLT FONTBITMAP 0 0 TEMPBITMAP 0 0 (SETQ CHAROFFSET (\FGETOFFSET OFFSETS (\CHAR8CODE
CHARCODE)))
CHGHT) (* Copy that part of
the old bitmap that's
to the left of the new
character)
(BITBLT NEWCHARBITMAP 0 0 TEMPBITMAP CHAROFFSET 0 NWIDTH CHGHT) (* Insert the new
character in its place)
(BITBLT FONTBITMAP (IPLUS CHAROFFSET CWDTH)
0 TEMPBITMAP (IPLUS CHAROFFSET NWIDTH)
0
(ADD1 (IDIFFERENCE OFWIDTH (IPLUS CHAROFFSET CWDTH)))
CHGHT)
(UNINTERRUPTABLY
(\FSETWIDTH WIDTHS (\CHAR8CODE CHARCODE)
NWIDTH) (* The new
character's correct
width)
[for I from (ADD1 (\CHAR8CODE CHARCODE)) to \MAXCHAR
do (* Run thru the
offsets of later
characters, adjusting
them for the changed
width of this character)
(\FSETOFFSET OFFSETS I (IPLUS DW (\FGETOFFSET OFFSETS I]
(replace (CHARSETINFO CHARSETBITMAP) of CSINFO with TEMPBITMAP)))
(T (BITBLT NEWCHARBITMAP 0 0 FONTBITMAP (\FGETOFFSET OFFSETS (\CHAR8CODE CHARCODE))
0 CWDTH CHGHT)))
(RETURN NEWCHARBITMAP])
(EDITCHAR
(LAMBDA (CHARCODE FONT) (* rrb "24-MAR-82 12:22")
(* calls the bitmap editor on a character of a font)
(PROG ((FONTDESC (\GETFONTDESC FONT)))
(RETURN (PUTCHARBITMAP CHARCODE FONTDESC (EDITBM (GETCHARBITMAP CHARCODE FONTDESC)
))))))
(\AVGCHARWIDTH
(LAMBDA (FONT) (* rmk: "27-Nov-84 18:40")
(* Returns the average width of a character, to be
used in units-to-characters approximations, as in
fixing the linelength)
(PROG ((W (CHARWIDTH (CHARCODE A)
FONT)))
(RETURN (COND
((NEQ 0 W)
W)
((NEQ 0 (SETQ W (FIXR (FTIMES .6 (FONTPROP FONT (QUOTE HEIGHT)))))
)
W)
(T 1))))))
(\STREAMCHARWIDTH
(LAMBDA (CHARCODE STREAM TTBL) (* JonL " 8-NOV-83 03:31")
(* Returns the width that the printed representation of CHARCODE would occupy if printed on STREAM, allowing for
the various escape sequences. Used by \ECHOCHAR)
(SETQ CHARCODE (LOGAND CHARCODE \CHARMASK))
((LAMBDA (WIDTHSVECTOR)
(* Note in following that if the DDWIDTHSCACHE exists and has a 0 entry for some character, that may someday mean
that the character's glyph simply isn't loaded; e.g., it may want #↑A)
(SETQ WIDTHSVECTOR (OR (AND (DISPLAYSTREAMP STREAM)
(SETQ WIDTHSVECTOR (ffetch IMAGEDATA of STREAM))
(ffetch DDWIDTHSCACHE of WIDTHSVECTOR))
\UNITWIDTHSVECTOR))
(SELECTC (fetch CCECHO of (\SYNCODE (fetch (TERMTABLEP TERMSA)
of (OR (TERMTABLEP TTBL)
\PRIMTERMTABLE))
CHARCODE))
(INDICATE.CCE ((LAMBDA (CC)
(IPLUS (if (IGEQ CHARCODE (CHARCODE #↑@))
then (* A META charcode -- implies that the 8th bit is
non-zero)
(SETQ CC (LOADBYTE CHARCODE 0 7))
(\FGETWIDTH WIDTHSVECTOR (CHARCODE #))
else 0)
(if (ILESSP CC (CHARCODE SPACE))
then (* A CONTROL charcode)
(add CC (CONSTANT (LLSH 1 6)))
(\FGETWIDTH WIDTHSVECTOR (CHARCODE ↑))
else 0)
(\FGETWIDTH WIDTHSVECTOR CC)))
CHARCODE))
(SIMULATE.CCE (SELCHARQ CHARCODE
((EOL CR LF BELL)
NIL)
(ESCAPE (\FGETWIDTH WIDTHSVECTOR (CHARCODE $)))
(TAB (PROG ((SPACEWIDTH (\FGETWIDTH WIDTHSVECTOR
(CHARCODE SPACE))
)
(NEWXPOSITON (DSPXPOSITION NIL STREAM))
TABWIDTH)
(SETQ TABWIDTH (UNFOLD SPACEWIDTH 8))
(add NEWXPOSITON
(SETQ TABWIDTH
(IDIFFERENCE
TABWIDTH
(IMOD (IDIFFERENCE
NEWXPOSITON
(DSPLEFTMARGIN
NIL STREAM))
TABWIDTH))))
(RETURN (if (IGREATERP NEWXPOSITON
(
DSPRIGHTMARGIN
NIL STREAM))
then
(* tab was past rightmargin, force cr.)
NIL
else TABWIDTH))))
(\FGETWIDTH WIDTHSVECTOR CHARCODE)))
(REAL.CCE (SELECTC CHARCODE
((CHARCODE (EOL CR LF))
NIL)
(ERASECHARCODE NIL)
(\FGETWIDTH WIDTHSVECTOR CHARCODE)))
(IGNORE.CCE 0)
(SHOULDNT))))))
(\UNITWIDTHSVECTOR
(LAMBDA NIL (* JonL " 7-NOV-83 19:23")
(SETQ \UNITWIDTHSVECTOR (\ALLOCBLOCK (UNFOLD (IPLUS \MAXCHAR 3)
WORDSPERCELL)))
(for I from 0 to (IPLUS \MAXCHAR 2) do (\PUTBASE \UNITWIDTHSVECTOR I 1))
\UNITWIDTHSVECTOR))
(\CREATEDISPLAYFONT
(LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* gbn: "25-Jan-86 18:02")
(PROG ((FONTDESC (create FONTDESCRIPTOR
FONTDEVICE ← DEVICE
FONTFAMILY ← FAMILY
FONTSIZE ← SIZE
FONTFACE ← FACE
\SFAscent ← 0
\SFDescent ← 0
\SFHeight ← 0
ROTATION ← ROTATION
FONTDEVICESPEC ← (LIST FAMILY SIZE FACE ROTATION DEVICE))))
(RETURN (COND
((\GETCHARSETINFO CHARSET FONTDESC T)
FONTDESC)
(T NIL))))))
(\CREATECHARSET.DISPLAY
(LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC NOSLUG?) (* kbr:
" 6-Feb-86 18:15")
(* * the b/w font is built first, then colorification happens at the
outside. Should become its own device.
Also, check if DISPLAYFONTCOERCIONS has ever been documented.
same for MISSINGDISPLAYFONTCOERCIONS. Should all happen in one place.)
(* * tries to build the csinfo required for CHARSET.
Does the necessary coercions.)
(* * NOSLUG? means don't create an empty
(slug) csinfo if the charset is not found, just return NIL)
(DECLARE (GLOBALVARS DISPLAYFONTCOERCIONS MISSINGDISPLAYFONTCOERCIONS))
(* DISPLAYFONTCOERCIONS is a list of font coercions, in the form
((user-font real-font) (user-font real-font) ...)%.
Each user-font is a list of FAMILY, and optionally SIZE and CHARSET,
(e.g., (GACHA) or (GACHA 10) or (GACHA 10 143)), and each real-font is a
similar list.)
(PROG (XCSINFO)
(SETQ XCSINFO (COND
((PROGN (* Just recursively call
ourselves to handle
entries in
DISPLAYFONTCOERCIONS)
(for TRANSL in DISPLAYFONTCOERCIONS bind NEWCSINFO USRFONT
REALFONT
when (AND (SETQ USRFONT (CAR TRANSL))
(EQ FAMILY (CAR USRFONT))
(OR (NOT (CADR USRFONT))
(EQ SIZE (CADR USRFONT)))
(OR (NOT (CADDR USRFONT))
(EQ CHARSET (CADDR USRFONT)))
(SETQ REALFONT (CADR TRANSL))
(SETQ NEWCSINFO (\CREATECHARSET.DISPLAY
(OR (CAR REALFONT)
FAMILY)
(OR (CADR REALFONT)
SIZE)
FACE ROTATION DEVICE
(OR (CADDR REALFONT)
CHARSET)
FONTDESC NOSLUG?)))
do (RETURN NEWCSINFO))))
((AND (EQ ROTATION 0) (* If it is available,
this will force the
appropriate file to be
read to fill in the
charset entry)
(\READDISPLAYFONTFILE FAMILY SIZE FACE ROTATION (QUOTE DISPLAY)
CHARSET)))
(T
(* * if we get here, the font is not directly available, either it needs
to be rotated, boldified, or italicised "by hand")
(PROG (NEWFONT XFONT XLATEDFAM CSINFO)
(RETURN (COND
((NEQ ROTATION 0)
(* to make a rotated font (even if it is bold or whatnot), recursively
call fontcreate to get the unrotated font
(maybe bold, etc), then call \SFMAKEROTATEDFONT on the csinfo.)
(OR (MEMB ROTATION (QUOTE (90 270)))
(ERROR
"only implemented rotations are 0, 90 and 270."
ROTATION))
(COND
((SETQ XFONT (FONTCREATE FAMILY SIZE FACE 0
(QUOTE DISPLAY)
T CHARSET))
(* actually call FONTCREATE here, rather than \CREATEDISPLAYFONT or
\CREATECHARSET.DISPLAY, so that the vanilla font that is built in this
process will be cached and not repeated.)
(COND
((SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T
))
(\SFROTATECSINFO CSINFO ROTATION))
(T NIL)))))
((AND (EQ (fetch (FONTFACE WEIGHT) of FACE)
(QUOTE BOLD))
(SETQ XFONT
(FONTCREATE FAMILY SIZE
(create FONTFACE using FACE WEIGHT ←(
QUOTE
MEDIUM
))
0
(QUOTE DISPLAY)
T CHARSET))) (* if we want a bold
font, and the medium
weight font is
available, build the
medium weight version
then call \SFMAKEBOLD on
the csinfo)
(COND
((SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T))
(\SFMAKEBOLD CSINFO))
(T NIL)))
((AND (EQ (fetch (FONTFACE SLOPE) of FACE)
(QUOTE ITALIC))
(SETQ XFONT
(FONTCREATE FAMILY SIZE
(create FONTFACE using FACE SLOPE ←(
QUOTE
REGULAR
))
0
(QUOTE DISPLAY)
T CHARSET)))
(COND
((SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T))
(\SFMAKEITALIC CSINFO))
(T NIL)))
((for TRANSL in MISSINGDISPLAYFONTCOERCIONS
bind NEWCSINFO USRFONT REALFONT
when (AND (SETQ USRFONT (CAR TRANSL))
(EQ FAMILY (CAR USRFONT))
(OR (NOT (CADR USRFONT))
(EQ SIZE (CADR USRFONT)))
(OR (NOT (CADDR USRFONT))
(EQ CHARSET (CADDR USRFONT)))
(SETQ REALFONT (CADR TRANSL))
(SETQ NEWCSINFO
(\CREATECHARSET.DISPLAY
(OR (CAR REALFONT)
FAMILY)
(OR (CADR REALFONT)
SIZE)
FACE ROTATION DEVICE
(OR (CADDR REALFONT)
CHARSET)
FONTDESC NOSLUG?)))
do (RETURN NEWCSINFO)))
((NOT NOSLUG?)
(\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR
FONTAVGCHARWIDTH)
of FONTDESC)
(FONTPROP FONTDESC (QUOTE ASCENT))
(FONTPROP FONTDESC (QUOTE DESCENT))
(FONTPROP FONTDESC (QUOTE DEVICE))))))))))
(COND
((FMEMB DEVICE \COLORDISPLAYSTREAMTYPES)
(SETQ XCSINFO (\SFMAKECOLOR XCSINFO (OR (fetch (FONTFACE BACKCOLOR) of FACE)
0)
(OR (fetch (FONTFACE FORECOLOR) of FACE)
(MAXIMUMCOLOR (\DISPLAYSTREAMTYPEBPP DEVICE)))
(\DISPLAYSTREAMTYPEBPP DEVICE)))))
(RETURN XCSINFO))))
(\BUILDSLUGCSINFO
(LAMBDA (WIDTH ASCENT DESCENT DEVICE) (* edited: "10-Dec-85 14:59")
(* * builds a csinfo which contains only the slug (black rectangle) character)
(PROG ((CSINFO (create CHARSETINFO
CHARSETASCENT ← ASCENT
CHARSETDESCENT ← DESCENT
IMAGEWIDTHS ← (\CREATECSINFOELEMENT)))
WIDTHS OFFSETS BITMAP IMAGEWIDTHS)
(SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
(for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I WIDTH))
(SETQ IMAGEWIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
(for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I WIDTH))
(SELECTQ DEVICE
(INTERPRESS (* don't need offsets in INTERPRESS fonts)
NIL)
(PROGN (replace (CHARSETINFO OFFSETS) of CSINFO with (SETQ OFFSETS
(
\CREATECSINFOELEMENT)))
(for I from 0 to \MAXTHINCHAR do (\FSETOFFSET OFFSETS I 0))
(replace (CHARSETINFO CHARSETBITMAP) of CSINFO
with (SETQ BITMAP (BITMAPCREATE WIDTH (IPLUS ASCENT
DESCENT))))
(BLTSHADE BLACKSHADE BITMAP 1 NIL (SUB1 WIDTH))))
(RETURN CSINFO))))
(\SEARCHDISPLAYFONTFILES
(LAMBDA (FAMILY SIZE FACE ROTATION) (* rrb "15-Oct-85 18:47")
(* * returns a list of the fonts that can be read in for the display device. Rotation is ignored because it is
assumed that all devices support 0 90 and 270)
(DECLARE (GLOBALVARS DISPLAYFONTEXTENSIONS DISPLAYFONTDIRECTORIES))
(SELECTQ (SYSTEMTYPE)
(J
(* OLD J code from \READDISPLAYFONT (PROG ((FONTFILE (\FONTFILENAME FAMILY SIZE FACE)) FONTDESC STRM)
(COND ((SETQ STRM (AND FONTDIRECTORIES (FINDFILE FONTFILE T FONTDIRECTORIES))) (SETQ STRM (OPENSTREAM FONTFILE
(QUOTE INPUT))) (SETQ FONTDESC (\READJERICHOFONTFILE FAMILY SIZE FACE STRM)) (CLOSEF STRM)))
(RETURN FONTDESC)))
NIL)
(D (for E FILENAMEPATTERN FONTSFOUND THISFONT THISFACE inside
DISPLAYFONTEXTENSIONS
do (SETQ FILENAMEPATTERN (\FONTFILENAME FAMILY SIZE FACE E))
(for DIR inside DISPLAYFONTDIRECTORIES
do (for FONTFILE in (DIRECTORY (PACKFILENAME (QUOTE
DIRECTORY)
DIR
(QUOTE BODY)
FILENAMEPATTERN))
do (OR (MEMBER (SETQ THISFONT (\FONTINFOFROMFILENAME
FONTFILE
(QUOTE DISPLAY)))
FONTSFOUND)
(COND
((AND (OR (EQ FACE (QUOTE *))
(EQUAL FACE (SETQ THISFACE
(CADDR THISFONT)))
(AND (OR (EQ (CAR FACE)
(QUOTE *))
(EQ (CAR FACE)
(CAR THISFACE)))
(OR (EQ (CADR FACE)
(QUOTE *))
(EQ (CADR FACE)
(CADR THISFACE)))
(OR (EQ (CADR FACE)
(QUOTE *))
(EQ (CADR FACE)
(CADR THISFACE)))
))
(OR (EQ FAMILY (QUOTE *))
(EQ FAMILY (CAR THISFONT))
(STRPOS "*" FAMILY)))
(* make sure the face, size, and family really match. Family name match allows anything if the family has a * in
it. This is wrong but better than what was there before which let in anything with the right beginning.)
(SETQ FONTSFOUND (CONS THISFONT FONTSFOUND))))
)))
finally (RETURN FONTSFOUND)))
(SHOULDNT))))
(\FONTFACE
(LAMBDA (FACE NOERRORFLG DEV) (* kbr:
" 6-Feb-86 18:22")
(* Takes a variety of
user specifications and
converts them to a
standard FONTFACE
record.)
(* b/w fontfaces are
extended by an optional
"-backcolor-forecolor")
(* the atom NNN is
interpreted the same as
NIL or MRR to cover up a
bug described in AR
3025, the FONTNNN bug)
(PROG (BWFACE POS OLDPOS BITSPERPIXEL BACKCOLOR FORECOLOR ANSWER) (* First get a FONTFACE
ANSWER. *)
(SETQ ANSWER (COND
((type? FONTFACE FACE)
FACE)
((LITATOM FACE)
(OR (U-CASEP FACE)
(SETQ FACE (U-CASE FACE)))
(SETQ POS (STRPOS "-" FACE))
(COND
(POS (SETQ BWFACE (SUBATOM FACE 1 (SUB1 POS))))
(T (SETQ BWFACE FACE)))
(SETQ ANSWER (SELECTQ BWFACE
((NIL MRR STANDARD NNN)
(CONSTANT (create FONTFACE)))
((ITALIC MIR)
(CONSTANT (create FONTFACE
SLOPE ←(QUOTE ITALIC))))
((BOLD BRR)
(CONSTANT (create FONTFACE
WEIGHT ←(QUOTE BOLD))))
((BOLDITALIC BIR)
(CONSTANT (create FONTFACE
WEIGHT ←(QUOTE BOLD)
SLOPE ←(QUOTE ITALIC))))
(create FONTFACE
WEIGHT ←(SELCHARQ (NTHCHARCODE FACE 1)
(M (QUOTE MEDIUM))
(B (QUOTE BOLD))
(L (QUOTE LIGHT))
(GO ERROR))
SLOPE ←(SELCHARQ (NTHCHARCODE FACE 2)
(R (QUOTE REGULAR))
(I (QUOTE ITALIC))
(GO ERROR))
EXPANSION ←(SELCHARQ (NTHCHARCODE FACE 3)
(R (QUOTE REGULAR))
(C (QUOTE COMPRESSED))
(E (QUOTE EXPANDED))
(GO ERROR)))))
(COND
(POS (* Color FONTFACE.
*)
(SETQ OLDPOS POS)
(SETQ POS (STRPOS "-" FACE (ADD1 OLDPOS)))
(COND
((NULL POS)
(GO ERROR)))
(SETQ BITSPERPIXEL (\DISPLAYSTREAMTYPEBPP DEV))
(SETQ BACKCOLOR (COLORNUMBERP (SUBATOM FACE (ADD1 OLDPOS)
(SUB1 POS))
BITSPERPIXEL))
(SETQ OLDPOS POS)
(SETQ FORECOLOR (COLORNUMBERP (SUBATOM FACE (ADD1 OLDPOS)
-1)
BITSPERPIXEL)) (* COPY ANSWER to avoid
smashing constants.
*)
(SETQ ANSWER (COPY ANSWER))
(replace (FONTFACE BACKCOLOR) of ANSWER with BACKCOLOR)
(replace (FONTFACE FORECOLOR) of ANSWER with FORECOLOR)))
ANSWER)
(T (GO ERROR)))) (* Coerce on or off
COLOR. *)
(SETQ ANSWER (COND
((AND (NOT (FMEMB DEV \COLORDISPLAYSTREAMTYPES))
(fetch (FONTFACE COLOR) of ANSWER))
(SETQ ANSWER (COPY ANSWER))
(replace (FONTFACE COLOR) of ANSWER with NIL)
ANSWER)
((AND (FMEMB DEV \COLORDISPLAYSTREAMTYPES)
(NULL (fetch (FONTFACE COLOR) of ANSWER)))
(SETQ FACE (COPY FACE))
(replace (FONTFACE BACKCOLOR) of ANSWER with 0)
(replace (FONTFACE FORECOLOR) of ANSWER with (MAXIMUMCOLOR (
\DISPLAYSTREAMTYPEBPP
DEV)))
ANSWER)
(T ANSWER)))
(RETURN ANSWER)
ERROR
(COND
(NOERRORFLG (RETURN NIL))
(T (\ILLEGAL.ARG FACE))))))
(\FONTFILENAME
(LAMBDA (FAMILY SIZE FACE EXTENSION CHARSET) (* gbn "14-Jan-86 14:56")
(* Returns the name of the file that should contain
the display raster information for a display font)
(PACKFILENAME (QUOTE NAME)
(SELECTQ EXTENSION
(STRIKE (PACK* FAMILY SIZE
(COND
((EQ FACE (QUOTE *))
(QUOTE *))
(T (CONCAT (SELECTQ (fetch WEIGHT
of FACE)
(BOLD (QUOTE B))
(* (QUOTE *))
"")
(SELECTQ (fetch SLOPE
of FACE)
(ITALIC (QUOTE I))
(* (QUOTE *))
""))))
(COND
((OR (NULL CHARSET)
(ZEROP CHARSET))
"")
(T (* this will never exist, but return a file name
different from the charset 0 filename)
(CONCAT "C" CHARSET)))))
(PROGN (* DISPLAYFONT AC WD and the default case)
(PACK* FAMILY SIZE
(COND
((EQ FACE (QUOTE *))
(QUOTE *))
(T (CONCAT (SELECTQ (fetch WEIGHT
of FACE)
(BOLD (QUOTE -B))
(*
(* handle the case of face being say
(* REGULAR REGULAR))
(QUOTE *))
"")
(SELECTQ (fetch SLOPE
of FACE)
(ITALIC (QUOTE -I))
(* (QUOTE *))
""))))
(COND
((FIXP CHARSET)
(RESETLST (RESETSAVE PRXFLG T)
(RESETSAVE (RADIX 8))
(CONCAT "-C" CHARSET)))
(CHARSET (CONCAT "-C" CHARSET))
(T "-C0")))))
(QUOTE EXTENSION)
EXTENSION)))
(\FONTINFOFROMFILENAME
(LAMBDA (FONTFILE DEVICE) (* rrb " 7-Nov-84 15:56")
(* returns a list of the family size face rotation
device of the font stored in the file name FONTFILE.)
(PROG ((FILENAMELIST (UNPACKFILENAME FONTFILE))
SIZEBEG SIZEND NAME FAMILY SIZE)
(SETQ NAME (LISTGET FILENAMELIST (QUOTE NAME)))
(* find where the name and size are.)
(SETQ SIZEBEG (for CH# from 1 when (NUMBERP (NTHCHAR NAME CH#))
do (RETURN CH#)))
(SETQ FAMILY (MKATOM (SUBSTRING NAME 1 (SUB1 SIZEBEG))))
(SETQ SIZEND (for CH# from SIZEBEG when (NOT (NUMBERP (NTHCHAR NAME CH#)))
do (RETURN CH#)))
(SETQ SIZE (MKATOM (SUBSTRING NAME SIZEBEG (SUB1 SIZEND))))
(RETURN (LIST FAMILY SIZE (SELECTQ (LISTGET FILENAMELIST (QUOTE EXTENSION))
((DISPLAYFONT AC WD)
(LIST (COND
((STRPOS "-B" NAME SIZEND NIL T)
(QUOTE BOLD))
(T (QUOTE MEDIUM)))
(COND
((STRPOS "-I" NAME SIZEND NIL)
(QUOTE ITALIC))
(T (QUOTE REGULAR)))
(QUOTE REGULAR)))
(LIST (COND
((STRPOS "B" NAME SIZEND NIL T)
(QUOTE BOLD))
(T (QUOTE MEDIUM)))
(COND
((STRPOS "I" NAME SIZEND NIL)
(QUOTE ITALIC))
(T (QUOTE REGULAR)))
(QUOTE REGULAR)))
0 DEVICE)))))
(\GETFONTDESC
(LAMBDA (SPEC DEVICE NOERRORFLG) (* J.Gibbons " 5-Dec-82 16:53")
(* Coerces SPEC to a fontdescriptor)
(* \GETFONTDESC HAS MACRO, BUT OLD CALLS STILL EXIST)
(\COERCEFONTDESC SPEC DEVICE NOERRORFLG)))
(\COERCEFONTDESC
(LAMBDA (SPEC STREAM NOERRORFLG) (* kbr:
" 6-Feb-86 17:55")
(* Coerces SPEC to a fontdescriptor appropriate for STREAM.
Go back thru FONTCREATE for various coercions in order to make sure that
the cache gets set up)
(PROG (FONT DEVICE)
(COND
((type? FONTDESCRIPTOR SPEC)
(SETQ FONT SPEC))
((type? FONTCLASS SPEC)
(SETQ DEVICE (COND
((NULL STREAM) (* Default is display)
(* * COULDN'T THIS BRANCH BE INTENDED TO MEAN 4DISPLAY, 8DISPLAY,
24DISPLAY? PEOPLE PROBABLY SHOULDN'T BE CALLING \COERCEFONTDESC WITH
STREAM = NIL. *)
(QUOTE DISPLAY))
((IMAGESTREAMP STREAM)
(IMAGESTREAMTYPE STREAM))
(STREAM STREAM)
(T (* I don't think this
case should be allowed.
*)
(QUOTE DISPLAY))))
(SETQ FONT (SELECTQ DEVICE
(DISPLAY (fetch (FONTCLASS DISPLAYFD) of SPEC))
(INTERPRESS (fetch (FONTCLASS INTERPRESSFD) of SPEC))
(PRESS (fetch (FONTCLASS PRESSFD) of SPEC))
(CDR (ASSOC DEVICE (fetch (FONTCLASS OTHERFDS) of SPEC)))))
(RETURN (COND
((type? FONTDESCRIPTOR FONT) (* We don't always
create FD's for devices
before they are needed,
so do it now and save
result)
FONT)
((NULL FONT) (* NIL means create FONT
but don't cache.
*)
(COND
((AND (FMEMB DEVICE \DISPLAYSTREAMTYPES)
(SETQ FONT (\COERCEFONTDESC SPEC (QUOTE DISPLAY)
NOERRORFLG))
(SETQ FONT (FONTCOPY FONT (QUOTE DEVICE)
STREAM
(QUOTE NOERROR)
NOERRORFLG))) (* Coerce existing black
& white font to color
font, but don't cache.
*)
FONT)
((EQ SPEC DEFAULTFONT) (* Break cycles with NIL
in the defaultfont)
(COND
(NOERRORFLG NIL)
((EQ DEVICE (QUOTE DISPLAY)) (* Function DEFAULTFONT
guarantees system
integrity)
(DEFAULTFONT (QUOTE DISPLAY)))
(T (ERROR (CONCAT DEVICE " component for DEFAULTFONT undefined")))))
(T (FONTCREATE DEFAULTFONT NIL NIL NIL STREAM NOERRORFLG))))
((SETQ FONT (FONTCREATE FONT NIL NIL NIL STREAM NOERRORFLG))
(* Might get NIL if
NOERRORFLG)
(SETFONTCLASSCOMPONENT SPEC DEVICE FONT)))))
((NULL SPEC)
(RETURN (\COERCEFONTDESC DEFAULTFONT STREAM NOERRORFLG)))
((OR (IMAGESTREAMP SPEC)
(type? WINDOW SPEC))
(SETQ FONT (DSPFONT NIL SPEC)))
(T
(* If called with NOERRORFLG=T (e.g. from DSPFONT) we want to suppress
invalid arg errors as well as font not found, so we can move on to other
possible coercions.)
(RETURN (FONTCREATE SPEC NIL NIL NIL STREAM NOERRORFLG))))(* Here if arg was a
fontdescriptor or
imagestream)
(RETURN (COND
((NULL STREAM) (* NIL device doesn't
default to display if a
fully-specified font was
found)
FONT)
((OR (EQ STREAM (fetch (FONTDESCRIPTOR FONTDEVICE) of FONT))
(AND (type? STREAM STREAM)
(EQ (fetch (IMAGEOPS IMFONTCREATE) of (fetch (STREAM IMAGEOPS)
of STREAM))
(fetch (FONTDESCRIPTOR FONTDEVICE) of FONT))))
FONT)
(T (* Here if doesn't match
or if DEVICE is not
explicitly a stream.)
(FONTCOPY FONT (QUOTE DEVICE)
STREAM
(QUOTE NOERROR)
NOERRORFLG)))))))
(\LOOKUPFONT
(LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* rmk: "25-SEP-81 22:42")
(* looks up a font in the internal cache.
SASSOC for listp FACE)
(DECLARE (GLOBALVARS \FONTSINCORE))
(CDR (FASSOC DEVICE (CDR (FASSOC ROTATION
(CDR (SASSOC FACE
(CDR (FASSOC SIZE
(CDR (FASSOC
FAMILY
\FONTSINCORE)))))
)))))))
(\LOOKUPFONTSINCORE
(LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* rrb "25-Sep-84 12:10")
(* * returns a list of the fonts that are available in core. * is used to match anything.)
(DECLARE (GLOBALVARS \FONTSINCORE))
(for FAMBUCKET in \FONTSINCORE when (OR (EQ FAMILY (QUOTE *))
(EQ FAMILY (CAR FAMBUCKET)))
join (for SIZEBUCKET in (CDR FAMBUCKET) when (OR (EQ SIZE (QUOTE *))
(EQ SIZE (CAR SIZEBUCKET)))
join (for FACEBUCKET in (CDR SIZEBUCKET) when (OR (EQ FACE
(QUOTE *))
(EQUAL FACE
(CAR
FACEBUCKET)))
join (for ROTBUCKET in (CDR FACEBUCKET)
when (OR (EQ ROTATION (QUOTE *))
(EQ ROTATION (CAR ROTBUCKET)))
join (for DEVBUCKET in (CDR ROTBUCKET)
when (OR (EQ DEVICE (QUOTE *))
(EQ DEVICE (CAR DEVBUCKET)))
collect (LIST (CAR FAMBUCKET)
(CAR SIZEBUCKET)
(CAR FACEBUCKET)
(CAR ROTBUCKET)
(CAR DEVBUCKET)))))))))
(\READDISPLAYFONTFILE
(LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* gbn " 6-Aug-85 20:17")
(DECLARE (GLOBALVARS DISPLAYFONTEXTENSIONS DISPLAYFONTDIRECTORIES))
(bind FONTFILE CSINFO STRM for EXT inside DISPLAYFONTEXTENSIONS
when (SETQ FONTFILE (FINDFILE (\FONTFILENAME FAMILY SIZE FACE EXT CHARSET)
T DISPLAYFONTDIRECTORIES))
do (SETQ STRM (OPENSTREAM FONTFILE (QUOTE INPUT)))
(RESETLST (SETQ CSINFO (SELECTQ (FONTFILEFORMAT STRM T)
(STRIKE (RESETSAVE NIL
(LIST
(FUNCTION CLOSEF)
STRM))
(\READSTRIKEFONTFILE STRM FAMILY SIZE
FACE))
(AC (* CLOSEF is guaranteed inside \READACFONTFILE,
against the possibility that we have to copy to make
randaccessp)
(\READACFONTFILE STRM FAMILY SIZE FACE))
(PROG1 (CLOSEF STRM)
(SHOULDNT)
(* This would get done by RESETSAVE if AC's were read
sequentially and we could factor the RESETSAVE)
))))
(* If not a recognizable format, I guess we should keep looking for another possible extension, altho it would also
be nice to tell the user that he has a bogus file.)
(RETURN CSINFO))))
(\SFMAKEBOLD
(LAMBDA (CSINFO) (* gbn "25-Jul-85 04:52")
(PROG* ((OLDCHARBITMAP (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO))
(WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
(OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
(HEIGHT (IPLUS (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)
(fetch (CHARSETINFO CHARSETDESCENT) of CSINFO)))
NEWCHARBITMAP OFFSET UNKNOWNOFFSET UNKNOWNWIDTH)
(SETQ NEWCHARBITMAP (BITMAPCREATE (fetch BITMAPWIDTH of OLDCHARBITMAP)
(fetch BITMAPHEIGHT of OLDCHARBITMAP)))
(SETQ UNKNOWNOFFSET (\FGETOFFSET OFFSETS (ADD1 \MAXCHAR)))
(SETQ UNKNOWNWIDTH (\FGETWIDTH WIDTHS (ADD1 \MAXCHAR)))
(for I from 0 to \MAXCHAR do (COND
((EQ (SETQ OFFSET (\FGETOFFSET OFFSETS I))
UNKNOWNOFFSET)
(* if this is the magic charcode with the slug image
(charcode 256) then leave it alone)
NIL)
(T (* overlap two blts to produce bold effect)
(BITBLT OLDCHARBITMAP OFFSET 0 NEWCHARBITMAP
OFFSET 0 (\FGETWIDTH WIDTHS I)
HEIGHT
(QUOTE INPUT)
(QUOTE REPLACE))
(BITBLT OLDCHARBITMAP OFFSET 0 NEWCHARBITMAP
(ADD1 OFFSET)
0
(SUB1 (\FGETWIDTH WIDTHS I))
HEIGHT
(QUOTE INPUT)
(QUOTE PAINT)))))
(* fill in the slug for the magic charcode)
(BITBLT OLDCHARBITMAP UNKNOWNOFFSET 0 NEWCHARBITMAP UNKNOWNOFFSET 0 UNKNOWNWIDTH HEIGHT
(QUOTE INPUT)
(QUOTE REPLACE))
(RETURN (create CHARSETINFO using CSINFO CHARSETBITMAP ← NEWCHARBITMAP)))))
(\SFMAKEITALIC
(LAMBDA (CSINFO) (* gbn "18-Sep-85 17:57")
(PROG ((WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
(OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
(ASCENT (fetch (CHARSETINFO CHARSETASCENT) of CSINFO))
(DESCENT (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO))
(OLDBITMAP (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO))
HEIGHT OFFSET NEWBITMAP WIDTH UNKNOWNOFFSET UNKNOWNWIDTH N M R XN XX YN YX)
(SETQ HEIGHT (IPLUS ASCENT DESCENT))
(SETQ NEWBITMAP (BITMAPCREATE (fetch BITMAPWIDTH of OLDBITMAP)
(fetch BITMAPHEIGHT of OLDBITMAP)))
(SETQ UNKNOWNOFFSET (\FGETOFFSET OFFSETS (ADD1 \MAXTHINCHAR)))
(SETQ UNKNOWNWIDTH (\FGETWIDTH WIDTHS (ADD1 \MAXTHINCHAR)))
(SETQ N (IDIFFERENCE 0 (IQUOTIENT (IPLUS DESCENT 3)
4)))
(SETQ M (IQUOTIENT (IPLUS ASCENT 3)
4))
(for I from 0 to \MAXTHINCHAR
do (COND
((EQ (SETQ OFFSET (\FGETOFFSET OFFSETS I))
UNKNOWNOFFSET) (* if this is the magic charcode with the slug image
(charcode 256) then leave it alone)
NIL)
(T (SETQ WIDTH (\FGETWIDTH WIDTHS I))
(for J from N to M
do (SETQ R (IPLUS OFFSET WIDTH))
(SETQ XN (IMIN R (IMAX (IPLUS OFFSET J)
0)))
(SETQ XX (IMIN R (IMAX (IPLUS R J)
0)))
(SETQ YN (IMAX 0 (IPLUS DESCENT (ITIMES J 4))))
(SETQ YX (IMIN HEIGHT (IPLUS DESCENT (IPLUS (ITIMES J 4)
4))))
(COND
((AND (IGREATERP XX XN)
(IGREATERP YX YN))
(BITBLT OLDBITMAP OFFSET YN NEWBITMAP XN YN (IDIFFERENCE
XX XN)
(IDIFFERENCE YX YN)
(QUOTE INPUT)
(QUOTE REPLACE))))))))
(BITBLT OLDBITMAP UNKNOWNOFFSET 0 NEWBITMAP UNKNOWNOFFSET 0 UNKNOWNWIDTH HEIGHT
(QUOTE INPUT)
(QUOTE REPLACE))
(RETURN (create CHARSETINFO using CSINFO CHARSETBITMAP ← NEWBITMAP)))))
(\SFMAKEROTATEDFONT
(LAMBDA (FONTDESC ROTATION) (* jds " 4-Jan-86 05:13")
(* takes a fontdecriptor and rotates it.)
(* 1/5/86 JDS. Masterscope claims nobody calls this.
Let's find out....)
(HELP "ROTATED fonts need to be fixed for NS Chars & New FONTDESCRIPTOR fields")
(* (create FONTDESCRIPTOR using FONTDESC (SETQ CHARACTERBITMAP (\SFROTATEFONTCHARACTERS (fetch
(FONTDESCRIPTOR CHARACTERBITMAP) of FONTDESC) ROTATION)) (SETQ ROTATION ROTATION) (SETQ \SFOffsets
(\SFFIXOFFSETSAFTERROTATION FONTDESC ROTATION)) (SETQ FONTCHARSETVECTOR (\ALLOCBLOCK (ADD1 \MAXCHARSET) T))))
))
(\SFROTATECSINFO
(LAMBDA (CSINFO ROTATION) (* gbn "15-Sep-85 14:38")
(* takes a CHARSETINFO and rotates it and produces a
rotated equivalent one.)
(create CHARSETINFO using CSINFO CHARSETBITMAP ← (\SFROTATEFONTCHARACTERS
(fetch (CHARSETINFO CHARSETBITMAP) of CSINFO)
ROTATION)
OFFSETS ← (\SFROTATECSINFOOFFSETS CSINFO ROTATION))))
(\SFROTATEFONTCHARACTERS
(LAMBDA (CHARBITMAP ROTATION) (* rrb "28-APR-83 12:01")
(* rotate a bitmap either 90 or 270 for fonts.)
(PROG (NEWMAP (SELECT (EQ ROTATION 90))
HIGHM1 WIDEM1)
(with BITMAP CHARBITMAP (SETQ HIGHM1 (SUB1 BITMAPHEIGHT))
(SETQ WIDEM1 (SUB1 BITMAPWIDTH))
(SETQ NEWMAP (BITMAPCREATE BITMAPHEIGHT BITMAPWIDTH))
(for X from 0 to WIDEM1 do (for Y from 0 to HIGHM1
do (COND
((EQ 1 (BITMAPBIT CHARBITMAP X Y)
)
(COND
(SELECT (BITMAPBIT
NEWMAP
(IDIFFERENCE
HIGHM1 Y)
X 1))
(T (BITMAPBIT NEWMAP Y
(IDIFFERENCE
WIDEM1 X)
1))))))))
(RETURN NEWMAP))))
(\SFFIXOFFSETSAFTERROTATION
(LAMBDA (FONTDESC ROTATION) (* jds " 4-Jan-86 05:15")
(* adjusts offsets in case where rotation turned
things around.)
(HELP "NEED TO UPDATE THIS FN TO NSCHARS & NEW FONT FIELDS")
(* (COND ((EQ ROTATION 270) (PROG ((OFFSETS (fetch (FONTDESCRIPTOR \SFOffsets) of FONTDESC))
(WIDTHS (fetch (FONTDESCRIPTOR \SFWidths) of FONTDESC)) (BITMAPHEIGHT (BITMAPWIDTH (fetch (FONTDESCRIPTOR
CHARACTERBITMAP) of FONTDESC))) NEWOFFSETS) (SETQ NEWOFFSETS (COPYARRAY OFFSETS)) (for CHARCODE from 0 to \MAXCHAR
do (SETA NEWOFFSETS CHARCODE (IDIFFERENCE BITMAPHEIGHT (IPLUS (ELT OFFSETS CHARCODE) (ELT WIDTHS CHARCODE)))))
(* may be some problem with dummy character representation.) (RETURN NEWOFFSETS))) (T (fetch
(FONTDESCRIPTOR \SFOffsets) of FONTDESC))))
))
(\SFROTATECSINFOOFFSETS
(LAMBDA (CSINFO ROTATION) (* gbn "15-Sep-85 14:36")
(* adjusts offsets in case where rotation turned
things around.)
(COND
((EQ ROTATION 270)
(PROG ((OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
(WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
(BITMAPHEIGHT (BITMAPWIDTH (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO)))
NEWOFFSETS)
(SETQ NEWOFFSETS (\CREATECSINFOELEMENT))
(for CHARCODE from 0 to \MAXCHAR do (\FSETOFFSET NEWOFFSETS CHARCODE
(IDIFFERENCE
BITMAPHEIGHT
(IPLUS (\FGETOFFSET
OFFSETS
CHARCODE)
(\FGETWIDTH
WIDTHS CHARCODE)
))))
(* may be some problem with dummy character
representation.)
(RETURN NEWOFFSETS)))
(T (fetch (CHARSETINFO OFFSETS) of CSINFO)))))
(\SFMAKECOLOR
(LAMBDA (BWCSINFO BACKCOLOR FORECOLOR BITSPERPIXEL) (* kbr:
" 6-Feb-86 18:17")
(* makes a csinfo that
has a character bitmap
that is colorized.)
(PROG (CHARACTERBITMAP COLORCSINFO)
(COND
((IMAGESTREAMP BITSPERPIXEL)
(OR BACKCOLOR (SETQ BACKCOLOR (DSPBACKCOLOR NIL BITSPERPIXEL)))
(OR FORECOLOR (SETQ FORECOLOR (DSPCOLOR NIL BITSPERPIXEL)))
(SETQ BITSPERPIXEL (IMAGESTREAMTYPE BITSPERPIXEL))))
(SETQ BITSPERPIXEL (COND
((NUMBERP BITSPERPIXEL)
BITSPERPIXEL)
(T (\DISPLAYSTREAMTYPEBPP BITSPERPIXEL))))
(SETQ BACKCOLOR (COLORNUMBERP BACKCOLOR BITSPERPIXEL))
(SETQ FORECOLOR (COLORNUMBERP FORECOLOR BITSPERPIXEL))
(SETQ CHARACTERBITMAP (COLORIZEBITMAP (fetch (CHARSETINFO CHARSETBITMAP) of BWCSINFO)
BACKCOLOR FORECOLOR BITSPERPIXEL))
(SETQ COLORCSINFO (create CHARSETINFO using BWCSINFO CHARSETBITMAP ← CHARACTERBITMAP))
(RETURN COLORCSINFO))))
)
(/DECLAREDATATYPE (QUOTE FONTCLASS)
(QUOTE (BYTE POINTER POINTER POINTER POINTER POINTER))
(QUOTE ((FONTCLASS 0 (BITS . 7))
(FONTCLASS 0 POINTER)
(FONTCLASS 2 POINTER)
(FONTCLASS 4 POINTER)
(FONTCLASS 6 POINTER)
(FONTCLASS 8 POINTER)))
(QUOTE 10))
(/DECLAREDATATYPE (QUOTE FONTDESCRIPTOR)
(QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD
WORD WORD SIGNEDWORD SIGNEDWORD SIGNEDWORD SIGNEDWORD (BITS 8)
POINTER POINTER POINTER POINTER POINTER WORD POINTER POINTER POINTER))
(QUOTE ((FONTDESCRIPTOR 0 POINTER)
(FONTDESCRIPTOR 2 POINTER)
(FONTDESCRIPTOR 4 POINTER)
(FONTDESCRIPTOR 6 POINTER)
(FONTDESCRIPTOR 8 POINTER)
(FONTDESCRIPTOR 10 POINTER)
(FONTDESCRIPTOR 12 POINTER)
(FONTDESCRIPTOR 14 POINTER)
(FONTDESCRIPTOR 16 (BITS . 15))
(FONTDESCRIPTOR 17 (BITS . 15))
(FONTDESCRIPTOR 18 (BITS . 15))
(FONTDESCRIPTOR 19 (BITS . 15))
(FONTDESCRIPTOR 20 (BITS . 15))
(FONTDESCRIPTOR 21 (BITS . 15))
(FONTDESCRIPTOR 22 (SIGNEDBITS . 15))
(FONTDESCRIPTOR 23 (SIGNEDBITS . 15))
(FONTDESCRIPTOR 24 (SIGNEDBITS . 15))
(FONTDESCRIPTOR 25 (SIGNEDBITS . 15))
(FONTDESCRIPTOR 14 (BITS . 7))
(FONTDESCRIPTOR 26 POINTER)
(FONTDESCRIPTOR 28 POINTER)
(FONTDESCRIPTOR 30 POINTER)
(FONTDESCRIPTOR 32 POINTER)
(FONTDESCRIPTOR 34 POINTER)
(FONTDESCRIPTOR 36 (BITS . 15))
(FONTDESCRIPTOR 38 POINTER)
(FONTDESCRIPTOR 40 POINTER)
(FONTDESCRIPTOR 42 POINTER)))
(QUOTE 44))
(/DECLAREDATATYPE (QUOTE CHARSETINFO)
(QUOTE (POINTER POINTER POINTER POINTER POINTER WORD WORD))
[QUOTE ((CHARSETINFO 0 POINTER)
(CHARSETINFO 2 POINTER)
(CHARSETINFO 4 POINTER)
(CHARSETINFO 6 POINTER)
(CHARSETINFO 8 POINTER)
(CHARSETINFO 10 (BITS . 15))
(CHARSETINFO 11 (BITS . 15]
(QUOTE 12))
[ADDTOVAR SYSTEMRECLST
(DATATYPE FONTCLASS ((PRETTYFONT# BYTE)
DISPLAYFD PRESSFD INTERPRESSFD OTHERFDS FONTCLASSNAME))
(DATATYPE FONTDESCRIPTOR ((FONTDEVICE POINTER)
(\SFObsolete1 POINTER)
(FONTFAMILY POINTER)
(FONTSIZE POINTER)
(FONTFACE POINTER)
(\SFObsolete2 POINTER)
(\SFObsolete3 POINTER)
(\SFObsolete4 POINTER)
(\SFObsolete5 WORD)
(\SFObsolete6 WORD)
(\SFAscent WORD)
(\SFDescent WORD)
(\SFHeight WORD)
(ROTATION WORD)
(FBBOX SIGNEDWORD)
(FBBOY SIGNEDWORD)
(FBBDX SIGNEDWORD)
(FBBDY SIGNEDWORD)
(\SFFACECODE BITS 8)
(\SFLKerns POINTER)
(\SFRWidths POINTER)
(FONTDEVICESPEC POINTER)
(OTHERDEVICEFONTPROPS POINTER)
(FONTSCALE POINTER)
(FONTAVGCHARWIDTH WORD)
(FONTIMAGEWIDTHS POINTER)
(FONTCHARSETVECTOR POINTER)
(FONTEXTRAFIELD2 POINTER)))
(DATATYPE CHARSETINFO (WIDTHS OFFSETS IMAGEWIDTHS CHARSETBITMAP YWIDTHS (CHARSETASCENT WORD)
(CHARSETDESCENT WORD)))
]
(RPAQ? \FONTSINCORE )
(RPAQ? \DEFAULTDEVICEFONTS )
(RPAQ? \UNITWIDTHSVECTOR )
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS DISPLAYFONTDIRECTORIES \DEFAULTDEVICEFONTS \UNITWIDTHSVECTOR)
)
(\UNITWIDTHSVECTOR)
(DECLARE: EVAL@COMPILE
(RPAQQ NORUNCODE 255)
(CONSTANTS (NORUNCODE 255))
)
(* FOLLOWING DEFINITIONS EXPORTED)
(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)
(\SFObsolete1 POINTER) (* WAS
CHARACTERBITMAP)
(* Bitmap containing
the character images,
indexed by \SFOffsets)
(FONTFAMILY POINTER)
(FONTSIZE POINTER)
(FONTFACE POINTER)
(\SFObsolete2 POINTER) (* Was \SFWidths)
(* The advance-width of each character, an array indexed by charcode.
Usually the same as the imagewidth, but can differ for accents, kerns
kerns. This is what should be used for stringwidth calculations.)
(\SFObsolete3 POINTER) (* WAS \SFOffsets)
(* Offset of each
character into the
image bitmap;
X value of left edge)
(\SFObsolete4 POINTER) (* Was \SFWidthsY)
(\SFObsolete5 WORD) (* WAS FIRSTCHAR)
(* Charcode of the
first character that
exists in the font)
(\SFObsolete6 WORD) (* WAS LASTCHAR)
(* Charcode of the
last character that
exists in the font)
(\SFAscent WORD)
(\SFDescent WORD)
(\SFHeight WORD)
(ROTATION WORD)
(FBBOX SIGNEDWORD)
(FBBOY SIGNEDWORD)
(FBBDX SIGNEDWORD)
(FBBDY SIGNEDWORD)
(\SFFACECODE BITS 8)
(\SFLKerns POINTER)
(\SFRWidths POINTER)
(FONTDEVICESPEC POINTER) (* Holds the spec by
which the font is known
to the printing device,
if coercion has been
done)
(OTHERDEVICEFONTPROPS POINTER) (* For individual
devices to hang special
information)
(FONTSCALE POINTER)
(FONTAVGCHARWIDTH WORD) (* Set in FONTCREATE,
used to fix up the
linelength when DSPFONT
is called)
(FONTIMAGEWIDTHS POINTER) (* This is the image
width, as opposed to
the advanced width;
initial hack for
accents, kerning.
Fields is referenced by
FONTCREATE.)
(FONTCHARSETVECTOR POINTER)
(* A 256-pointer block, with one pointer per "character set" --each
group of 256 character codes. Each pointer is either NIL if there's no
info for that charset, or is a CHARSETINFO, containing widths, char
bitmap, etc for the characters in that charset.)
(FONTEXTRAFIELD2 POINTER))
FONTCHARSETVECTOR ←(\CREATEFONTCHARSETVECTOR))
(RECORD FONTFACE (WEIGHT SLOPE EXPANSION)
[ACCESSFNS ((COLOR (CDDDR DATUM)
(RPLACD (CDDR DATUM)
NEWVALUE))
(BACKCOLOR [COND
((CDDDR DATUM)
(CAR (CDDDR DATUM]
(PROGN [COND
((NULL (CDDDR DATUM))
(RPLACD (CDDR DATUM)
(LIST NIL NIL]
(RPLACA (CDDDR DATUM)
NEWVALUE)))
(FORECOLOR [COND
((CDDDR DATUM)
(CADR (CDDDR DATUM]
(PROGN [COND
((NULL (CDDDR DATUM))
(RPLACD (CDDR DATUM)
(LIST NIL NIL]
(RPLACA (CDR (CDDDR DATUM))
NEWVALUE]
WEIGHT ←(QUOTE MEDIUM)
SLOPE ←(QUOTE REGULAR)
EXPANSION ←(QUOTE REGULAR)
(TYPE? LISTP))
(DATATYPE CHARSETINFO (WIDTHS
(* The advance-width of each character, an array indexed by charcode.
Usually the same as the imagewidth, but can differ for accents, kerns
kerns. This is what should be used for stringwidth calculations.)
OFFSETS (* Offset of each
character into the
image bitmap;
X value of left edge)
IMAGEWIDTHS (* imagewidths is not
automagically allocated
since it is not always
needed)
CHARSETBITMAP (* Bitmap containing
the character images,
indexed by OFFSETS)
YWIDTHS
(CHARSETASCENT WORD) (* Max ascent for all
characters in this
CHARSET)
(CHARSETDESCENT WORD) (* Max descent for
all characters in this
CHARSET)
)
WIDTHS ←(\CREATECSINFOELEMENT)
OFFSETS ←(\CREATECSINFOELEMENT))
]
(/DECLAREDATATYPE (QUOTE FONTCLASS)
(QUOTE (BYTE POINTER POINTER POINTER POINTER POINTER))
(QUOTE ((FONTCLASS 0 (BITS . 7))
(FONTCLASS 0 POINTER)
(FONTCLASS 2 POINTER)
(FONTCLASS 4 POINTER)
(FONTCLASS 6 POINTER)
(FONTCLASS 8 POINTER)))
(QUOTE 10))
(/DECLAREDATATYPE (QUOTE FONTDESCRIPTOR)
(QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD
WORD WORD SIGNEDWORD SIGNEDWORD SIGNEDWORD SIGNEDWORD (BITS 8)
POINTER POINTER POINTER POINTER POINTER WORD POINTER POINTER POINTER))
(QUOTE ((FONTDESCRIPTOR 0 POINTER)
(FONTDESCRIPTOR 2 POINTER)
(FONTDESCRIPTOR 4 POINTER)
(FONTDESCRIPTOR 6 POINTER)
(FONTDESCRIPTOR 8 POINTER)
(FONTDESCRIPTOR 10 POINTER)
(FONTDESCRIPTOR 12 POINTER)
(FONTDESCRIPTOR 14 POINTER)
(FONTDESCRIPTOR 16 (BITS . 15))
(FONTDESCRIPTOR 17 (BITS . 15))
(FONTDESCRIPTOR 18 (BITS . 15))
(FONTDESCRIPTOR 19 (BITS . 15))
(FONTDESCRIPTOR 20 (BITS . 15))
(FONTDESCRIPTOR 21 (BITS . 15))
(FONTDESCRIPTOR 22 (SIGNEDBITS . 15))
(FONTDESCRIPTOR 23 (SIGNEDBITS . 15))
(FONTDESCRIPTOR 24 (SIGNEDBITS . 15))
(FONTDESCRIPTOR 25 (SIGNEDBITS . 15))
(FONTDESCRIPTOR 14 (BITS . 7))
(FONTDESCRIPTOR 26 POINTER)
(FONTDESCRIPTOR 28 POINTER)
(FONTDESCRIPTOR 30 POINTER)
(FONTDESCRIPTOR 32 POINTER)
(FONTDESCRIPTOR 34 POINTER)
(FONTDESCRIPTOR 36 (BITS . 15))
(FONTDESCRIPTOR 38 POINTER)
(FONTDESCRIPTOR 40 POINTER)
(FONTDESCRIPTOR 42 POINTER)))
(QUOTE 44))
(/DECLAREDATATYPE (QUOTE CHARSETINFO)
(QUOTE (POINTER POINTER POINTER POINTER POINTER WORD WORD))
[QUOTE ((CHARSETINFO 0 POINTER)
(CHARSETINFO 2 POINTER)
(CHARSETINFO 4 POINTER)
(CHARSETINFO 6 POINTER)
(CHARSETINFO 8 POINTER)
(CHARSETINFO 10 (BITS . 15))
(CHARSETINFO 11 (BITS . 15]
(QUOTE 12))
(DECLARE: EVAL@COMPILE
[PUTPROPS FONTASCENT MACRO ((FONTSPEC)
(ffetch \SFAscent of (\GETFONTDESC FONTSPEC]
[PUTPROPS FONTDESCENT MACRO ((FONTSPEC)
(ffetch \SFDescent of (\GETFONTDESC FONTSPEC]
[PUTPROPS FONTHEIGHT MACRO ((FONTSPEC)
(ffetch \SFHeight of (\GETFONTDESC FONTSPEC]
(PUTPROPS \FGETOFFSET DMACRO ((OFFSETSBLOCK CHAR8CODE)
(\GETBASE OFFSETSBLOCK CHAR8CODE)))
(PUTPROPS \FSETOFFSET DMACRO ((OFFSETSBLOCK CHAR8CODE OFFSET)
(\PUTBASE OFFSETSBLOCK CHAR8CODE OFFSET)))
(PUTPROPS \FGETWIDTH DMACRO ((WIDTHSBLOCK CHAR8CODE)
(\GETBASE WIDTHSBLOCK CHAR8CODE)))
(PUTPROPS \FSETWIDTH DMACRO ((WIDTHSBLOCK INDEX WIDTH)
(\PUTBASE WIDTHSBLOCK INDEX WIDTH)))
[PUTPROPS \FGETCHARWIDTH MACRO (OPENLAMBDA (FONTDESC CHARCODE)
(\FGETWIDTH (ffetch (CHARSETINFO WIDTHS)
of
(\GETCHARSETINFO (\CHARSET CHARCODE)
FONTDESC))
(\CHAR8CODE CHARCODE]
(PUTPROPS \FGETIMAGEWIDTH MACRO ((IMAGEWIDTHSBLOCK CHAR8CODE)
(\GETBASE IMAGEWIDTHSBLOCK CHAR8CODE)))
(PUTPROPS \FSETIMAGEWIDTH DMACRO ((WIDTHSBLOCK INDEX WIDTH)
(\PUTBASE WIDTHSBLOCK INDEX WIDTH)))
[PUTPROPS \GETCHARSETINFO MACRO ((CHARSET FONTDESC NOSLUG?)
(* * fetches the charsetinfo for charset CHARSET in fontdescriptor
FONTDESC. If NIL, then creates the required charset.)
(* * NOSLUG? means don't create an empty (slug)
csinfo if the charset is not found, just return NIL)
(OR (\GETBASEPTR (ffetch FONTCHARSETVECTOR of FONTDESC)
(UNFOLD CHARSET 2))
(\CREATECHARSET CHARSET FONTDESC NOSLUG?]
[PUTPROPS \CREATECSINFOELEMENT MACRO (NIL (\ALLOCBLOCK (FOLDHI (IPLUS \MAXTHINCHAR 3)
WORDSPERCELL]
(PUTPROPS \CREATEFONTCHARSETVECTOR MACRO (NIL (* Allocates a block for the character set records)
(\ALLOCBLOCK (ADD1 \MAXCHARSET)
T)))
)
(DECLARE: EVAL@COMPILE
(RPAQQ \MAXNSCHAR 65535)
(CONSTANTS (\MAXNSCHAR 65535))
)
(* END EXPORTED DEFINITIONS)
)
(* NS Character specific code)
(DEFINEQ
(\CREATECHARSET
(LAMBDA (CHARSET FONT NOSLUG?) (* kbr:
" 6-Feb-86 18:24")
(* Creates and returns
the CHARSETINFO for
charset CHARSET in
fontdesc FONT,
installing it in fonts
FONTCHARSETVECTOR)
(* NOSLUG? means don't
create an empty
(slug) csinfo if the
charset is not found,
just return NIL)
(AND (IGREATERP CHARSET \MAXCHARSET)
(\ILLEGAL.ARG CHARSET))
(PROG (CSINFO CREATEFN) (* For other charsets,
create a font descriptor
of info for that
charset, and use it to
fill things in.)
(COND
((OR (AND (IGEQ CHARSET 1)
(ILEQ CHARSET 32))
(AND (IGEQ CHARSET 127)
(ILEQ CHARSET 160))) (* this is an illegal NS
character set
(reserved for control
codes) so just return a
slug (unless NOSLUG? is
T))
(COND
(NOSLUG? (RETURN NIL))
(T (SETQ CSINFO (\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR FONTAVGCHARWIDTH)
of FONT)
(FONTPROP FONT (QUOTE ASCENT))
(FONTPROP FONT (QUOTE DESCENT))
(FONTPROP FONT (QUOTE DEVICE)))))))
(T (SETQ CREATEFN (COND
((FMEMB (FONTPROP FONT (QUOTE DEVICE))
\DISPLAYSTREAMTYPES)
(FUNCTION \CREATECHARSET.DISPLAY))
(T (CADR (ASSOC (QUOTE CREATECHARSET)
(CDR (ASSOC (FONTPROP FONT (QUOTE DEVICE))
IMAGESTREAMTYPES)))))))
(COND
((NOT (SETQ CSINFO (APPLY CREATEFN (APPEND (FONTPROP FONT (QUOTE DEVICESPEC))
(LIST CHARSET FONT NOSLUG?)))))
(* the create method
returned NIL.
so if NOSLUG? return NIL
else build a slug
charsetinfo)
(RETURN (COND
(NOSLUG? (* the caller just wants
NIL back to signal that
nothing was found)
NIL)
(T (\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR FONTAVGCHARWIDTH)
of FONT)
(FONTPROP FONT (QUOTE ASCENT))
(FONTPROP FONT (QUOTE HEIGHT))
(FONTPROP FONT (QUOTE DEVICE))))))))
(replace \SFAscent of FONT with (IMAX (fetch \SFAscent of FONT)
(fetch CHARSETASCENT of CSINFO)))
(replace \SFDescent of FONT with (IMAX (fetch \SFDescent of FONT)
(ffetch CHARSETDESCENT of CSINFO)))
(replace \SFHeight of FONT with (IMAX (fetch \SFHeight of FONT)
(IPLUS (fetch CHARSETASCENT of CSINFO)
(ffetch CHARSETDESCENT of CSINFO))))))
(RETURN (\SETCHARSETINFO (ffetch FONTCHARSETVECTOR of FONT)
CHARSET CSINFO)))))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS DISPLAYFONTCOERCIONS MISSINGDISPLAYFONTCOERCIONS CHARSETERRORFLG)
)
(RPAQ? DISPLAYFONTCOERCIONS NIL)
(RPAQ? MISSINGDISPLAYFONTCOERCIONS [QUOTE (((GACHA)
(TERMINAL))
((MODERN)
(CLASSIC))
((TIMESROMAN)
(CLASSIC))
((HELVETICA)
(MODERN])
(RPAQ? CHARSETERRORFLG NIL)
(RPAQ? \DEFAULTCHARSET 0)
(* Interlisp-D specific)
(RPAQQ DONLYFONTFNS (\FONTRESETCHARWIDTHS \READSTRIKEFONTFILE))
(DEFINEQ
(\FONTRESETCHARWIDTHS
(LAMBDA (CSINFO FIRSTCHAR LASTCHAR) (* AJB " 6-Dec-85 14:42")
(* sets the widths array from the offsets array)
(PROG ((mincharcode FIRSTCHAR)
(maxcharcode LASTCHAR)
(offsets (fetch (CHARSETINFO OFFSETS) of CSINFO))
(widths (fetch (CHARSETINFO WIDTHS) of CSINFO))
left right charoffset dummycharoffset dummycharwidth)
(SETQ dummycharoffset (\FGETOFFSET offsets (ADD1 maxcharcode)))
(SETQ dummycharwidth (IDIFFERENCE (\FGETOFFSET offsets (IPLUS maxcharcode 2))
dummycharoffset))
(for charcode from 0 to \MAXCHAR do (COND
((OR (ILESSP charcode mincharcode)
(IGREATERP charcode maxcharcode))
(\FSETOFFSET offsets charcode
dummycharoffset)
(\FSETWIDTH widths charcode
dummycharwidth))
(T (SETQ left (\FGETWIDTH offsets
charcode))
(SETQ right (\FGETWIDTH offsets
(ADD1
charcode)))
(COND
((EQ left right)
(\FSETOFFSET offsets charcode
dummycharoffset)
(\FSETWIDTH widths charcode
dummycharwidth))
(T (\FSETWIDTH widths charcode
(IDIFFERENCE right
left)))))
))
(\FSETWIDTH widths (ADD1 \MAXCHAR)
dummycharwidth)
(\FSETOFFSET offsets (ADD1 \MAXCHAR)
dummycharoffset))))
(\READSTRIKEFONTFILE
(LAMBDA (STRM FAMILY SIZE FACE) (* AJB " 6-Dec-85 14:53")
(* STRM has already been determined to be a vanilla
strike-format file.)
(* returns a charsetinfo)
(COND
((NEQ 2 (GETFILEPTR STRM))
(SETFILEPTR STRM 2)))
(PROG (CSINFO NUMBCODES RW BITMAP OFFSETS FIRSTCHAR LASTCHAR HEIGHT WIDTHS)
(SETQ CSINFO (create CHARSETINFO))
(SETQ FIRSTCHAR (\WIN STRM)) (* minimum ascii code)
(SETQ LASTCHAR (\WIN STRM)) (* maximum ascii code)
(\WIN STRM) (* MaxWidth which isn't used by anyone.)
(\WIN STRM) (* number of words in this StrikeBody)
(replace (CHARSETINFO CHARSETASCENT) of CSINFO with (\WIN STRM))
(* ascent in scan lines (=FBBdy+FBBoy))
(replace (CHARSETINFO CHARSETDESCENT) of CSINFO with (\WIN STRM))
(* descent in scan-lines (=FBBoy))
(\WIN STRM) (* offset in bits (<0 for kerning, else 0, =FBBox))
(SETQ RW (\WIN STRM)) (* raster width of bitmap)
(* height of bitmap)
(SETQ HEIGHT (IPLUS (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)
(fetch (CHARSETINFO CHARSETDESCENT) of CSINFO)))
(SETQ BITMAP (BITMAPCREATE (UNFOLD RW BITSPERWORD)
HEIGHT))
(\BINS STRM (fetch BITMAPBASE of BITMAP)
0
(UNFOLD (ITIMES RW HEIGHT)
BYTESPERWORD)) (* read bits into bitmap)
(replace (CHARSETINFO CHARSETBITMAP) of CSINFO with BITMAP)
(SETQ NUMBCODES (IPLUS (IDIFFERENCE LASTCHAR FIRSTCHAR)
3)) (* SETQ OFFSETS (ARRAY (IPLUS \MAXCHAR 3)
(QUOTE SMALLPOSP) 0 0))
(SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
(* initialise the offsets to 0)
(for I from 0 to (IPLUS \MAXTHINCHAR 2) do (\FSETOFFSET OFFSETS I 0))
(* AIN OFFSETS FIRSTCHAR NUMBCODES STRM)
(for I from FIRSTCHAR as J from 1 to NUMBCODES do (\FSETOFFSET OFFSETS I
(\WIN STRM)))
(SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
(for I from 0 to (IPLUS \MAXTHINCHAR 2) do (\FSETWIDTH WIDTHS I 0))
(* replace WIDTHS of (CHARSETINFO CSINFO) with
(ARRAY (IPLUS \MAXCHAR 3) (QUOTE SMALLPOSP) 0 0))
(\FONTRESETCHARWIDTHS CSINFO FIRSTCHAR LASTCHAR)
(replace (CHARSETINFO IMAGEWIDTHS) of CSINFO with (fetch (CHARSETINFO WIDTHS)
of CSINFO))
(RETURN CSINFO))))
)
(DECLARE: 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) (* jds " 4-Jan-86 05:10")
(* * None of this code has been updated to NS chars. It uses obsolete fields to ensure obsolete assumptions.
It should be razed! gbn)
(HELP "JERICHO no longer supported.")
(* (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
[PUTPROPS \FGETCHARIMAGEWIDTH MACRO (OPENLAMBDA (FONT CHARCODE)
(\FGETWIDTH (ffetch (CHARSETINFO IMAGEWIDTHS)
of
(\GETCHARSETINFO (\CHARSET CHARCODE)
FONT))
(\CHAR8CODE CHARCODE]
(PROGN [PUTPROPS \GETFONTDESC DMACRO (X (COND ((CDR X)
(CONS (QUOTE \COERCEFONTDESC)
X))
(T (BQUOTE (\DTEST (\, (CAR X))
(QUOTE FONTDESCRIPTOR]
(PUTPROPS \GETFONTDESC MACRO (= . \COERCEFONTDESC)))
(PUTPROPS \SETCHARSETINFO MACRO ((CHARSETVECTOR CHARSET CSINFO)
(\RPLPTR CHARSETVECTOR (UNFOLD CHARSET 2)
CSINFO)))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA FONTCOPY)
)
(PUTPROPS FONT COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (4951 17953 (CHARWIDTH 4961 . 5633) (CHARWIDTHY 5635 . 7178) (STRINGWIDTH 7180 . 8074) (
\CHARWIDTH.DISPLAY 8076 . 8482) (\STRINGWIDTH.DISPLAY 8484 . 8955) (\STRINGWIDTH.GENERIC 8957 . 17951)
) (18134 24547 (DEFAULTFONT 18144 . 19394) (FONTCLASS 19396 . 22310) (FONTCLASSUNPARSE 22312 . 23133)
(FONTCLASSCOMPONENT 23135 . 23636) (SETFONTCLASSCOMPONENT 23638 . 24545)) (24548 114297 (FONTASCENT
24558 . 24728) (FONTCOPY 24730 . 28261) (FONTCREATE 28263 . 34652) (FONTSAVAILABLE 34654 . 38551) (
FONTDESCENT 38553 . 38820) (FONTFILEFORMAT 38822 . 40323) (FONTHEIGHT 40325 . 40512) (FONTP 40514 .
40804) (FONTPROP 40806 . 43642) (FONTUNPARSE 43644 . 47524) (SETFONTDESCRIPTOR 47526 . 49043) (
CHARCODEP 49045 . 49346) (GETCHARBITMAP 49348 . 50843) (PUTCHARBITMAP 50845 . 62709) (EDITCHAR 62711
. 63108) (\AVGCHARWIDTH 63110 . 63684) (\STREAMCHARWIDTH 63686 . 66505) (\UNITWIDTHSVECTOR 66507 .
66853) (\CREATEDISPLAYFONT 66855 . 67365) (\CREATECHARSET.DISPLAY 67367 . 78977) (\BUILDSLUGCSINFO
78979 . 80304) (\SEARCHDISPLAYFONTFILES 80306 . 82826) (\FONTFACE 82828 . 89992) (\FONTFILENAME 89994
. 92017) (\FONTINFOFROMFILENAME 92019 . 93805) (\GETFONTDESC 93807 . 94193) (\COERCEFONTDESC 94195 .
100847) (\LOOKUPFONT 100849 . 101395) (\LOOKUPFONTSINCORE 101397 . 102682) (\READDISPLAYFONTFILE
102684 . 104132) (\SFMAKEBOLD 104134 . 106153) (\SFMAKEITALIC 106155 . 108445) (\SFMAKEROTATEDFONT
108447 . 109255) (\SFROTATECSINFO 109257 . 109762) (\SFROTATEFONTCHARACTERS 109764 . 110735) (
\SFFIXOFFSETSAFTERROTATION 110737 . 111701) (\SFROTATECSINFOOFFSETS 111703 . 112853) (\SFMAKECOLOR
112855 . 114295)) (133778 139356 (\CREATECHARSET 133788 . 139354)) (140147 145101 (
\FONTRESETCHARWIDTHS 140157 . 141768) (\READSTRIKEFONTFILE 141770 . 145099)) (145579 149394 (
\FONTDESCARRAY 145589 . 146160) (\READJERICHOFONTFILE 146162 . 149392)))))
STOP