(FILECREATED "18-JUL-83 13:42:27" {PHYLUM}<LISPCORE>SOURCES>FONT.;24 42764
changes to: (FNS CHARWIDTH FONTCREATE STRINGWIDTH \COERCEFONTDESC)
previous date: "28-APR-83 12:06:12" {PHYLUM}<LISPCORE>SOURCES>FONT.;23)
(* Copyright (c) 1981, 1982, 1983 by Xerox Corporation)
(PRETTYCOMPRINT FONTCOMS)
(RPAQQ FONTCOMS [(* font functions)
(FNS CHARWIDTH CHARWIDTHY DEFAULTFONT FONTASCENT FONTCOPY FONTCREATE FONTDESCENT FONTHEIGHT
FONTP FONTPROP SETFONTDESCRIPTOR STRINGWIDTH CHARCODEP GETCHARBITMAP PUTCHARBITMAP
EDITCHAR \CREATEDISPLAYFONT \FONTFACE \FONTFILENAME \GETFONTDESC \COERCEFONTDESC
\LOOKUPFONT \READDISPLAYFONTFILE \SFMAKEBOLD \SFMAKEITALIC \SFMAKEROTATEDFONT
\SFROTATEFONTCHARACTERS \SFFIXOFFSETSAFTERROTATION)
(INITRECORDS FONTDESCRIPTOR)
(SYSRECORDS FONTDESCRIPTOR)
(INITVARS (\FONTSINCORE)
(\DEFAULTDEVICEFONTS))
(GLOBALVARS FONTDIRECTORIES \DEFAULTDEVICEFONTS)
(EXPORT (MACROS FONTPROP))
(DECLARE: DONTCOPY (EXPORT (RECORDS FONTDESCRIPTOR FONTFACE)
(MACROS FONTASCENT FONTDESCENT FONTHEIGHT \FGETOFFSET \FGETWIDTH
\GETOFFSET \GETWIDTH)))
[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))
(VARS (\FONTFILEEXTENSION (QUOTE STRIKE)))
(ADDVARS (FONTDIRECTORIES {PHYLUM}<ALTOFONTS> {INDIGO}<ALTOFONTS>
{INDIGO}<ALTOFONTS>ORIGINAL>]
(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 (\FONTFILEEXTENSION (QUOTE FONT)))
(ADDVARS (FONTDIRECTORIES >FONTS)))
(DECLARE: EVAL@COMPILE DONTCOPY (MACROS 2BIN \GETLKERN \GETRWIDTH)))
(MACROS \GETFONTDESC)
(LOCALVARS . T)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA FONTCOPY])
(* font functions)
(DEFINEQ
(CHARWIDTH
[LAMBDA (CHARCODE FONT) (* rmk: "18-JUL-83 12:34")
(* gets the width of a character code in a font.)
(PROG (STRM)
(RETURN (\FGETWIDTH [COND
((type? FONTDESCRIPTOR FONT)
(fetch (ARRAYP BASE) of (ffetch \SFWidths of FONT)))
([SETQ STRM (COND
((\DISPLAYSTREAMP FONT)
FONT)
((type? WINDOW FONT)
(fetch (WINDOW DSP) of FONT]
(ffetch (DISPLAYSTREAM \SFWIDTHSCACHE) of STRM))
(T (* I'm not sure why the default is DISPLAY -
rrb 4/21/83)
(fetch (ARRAYP BASE)
of (fetch (FONTDESCRIPTOR \SFWidths)
of (OR (DEFAULTFONT (OR FONT (QUOTE DISPLAY))
NIL T)
(FONTCREATE FONT]
(LOGAND CHARCODE \CHARMASK])
(CHARWIDTHY
[LAMBDA (CHARCODE FONT) (* rmk: "12-MAR-82 23:22")
(* Gets the Y-component of the width of a character code in a font.)
(PROG [(WY (fetch \SFWidthsY of (\GETFONTDESC FONT]
(RETURN (OR (FIXP WY)
(\GETWIDTH WY (LOGAND CHARCODE \CHARMASK])
(DEFAULTFONT
[LAMBDA (DEVICE FONT NOERRORFLG) (* rrb "27-APR-83 12:32")
(* sets and returns the default font for a display
device type which is one of DISPLAY PRESS and TEXT)
(* NOERRORFLG allows this to be used to determine if DEVICE is infact a display device. If NOERRORFLG is NEW the
device will be added if it is not there.)
(PROG (DEVICEBUCKET)
LP (COND
((SETQ DEVICEBUCKET (ASSOC DEVICE \DEFAULTDEVICEFONTS)))
((NULL NOERRORFLG)
(\ILLEGAL.ARG DEVICE)
(GO LP))
[(EQ NOERRORFLG (QUOTE NEW))
(SETQ FONT (\COERCEFONTDESC FONT DEVICE))
(SETQ DEVICEBUCKET (CAR (PUSH \DEFAULTDEVICEFONTS (CONS DEVICE]
(T (RETURN NIL)))
(RETURN (PROG1 (CDR DEVICEBUCKET)
(COND
(FONT (RPLACD DEVICEBUCKET (\COERCEFONTDESC FONT DEVICE])
(FONTASCENT
[LAMBDA (FONTSPEC) (* lmm "19-NOV-82 00:23")
(ffetch \SFAscent of (\GETFONTDESC FONTSPEC])
(FONTCOPY
[LAMBDA FONTSPECS (* rmk: "25-SEP-81 22:27")
(* makes a copy of a font changing the specified fields.)
(PROG [FAMILY FACE SIZE ROTATION DEVICE (OLDFONT (\GETFONTDESC (ARG FONTSPECS 1]
(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))
(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))
(\ILLEGAL.ARG (CAR J]
(T (\ILLEGAL.ARG (ARG FONTSPECS I]
(RETURN (FONTCREATE FAMILY SIZE FACE ROTATION DEVICE])
(FONTCREATE
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE NOERRORFLG) (* rmk: "18-JUL-83 12:32")
(* Cache and fonts.widths traffic in uppercase only.)
(COND
((LISTP FAMILY)
[COND
((EQ (CAR FAMILY)
(QUOTE FONT))
(SETQ FAMILY (CDR FAMILY]
(FONTCREATE (CAR FAMILY)
(CADR FAMILY)
(CADDR FAMILY)
(CADDDR FAMILY)
DEVICE NOERRORFLG))
((type? FONTDESCRIPTOR FAMILY)
FAMILY)
((\DISPLAYSTREAMP FAMILY)
(fetch (DISPLAYSTREAM \SFFONT) of FAMILY))
[(NULL FAMILY)
(DEFAULTFONT (OR DEVICE (QUOTE DISPLAY]
((TYPENAMEP FAMILY (QUOTE WINDOW))
(fetch (DISPLAYSTREAM \SFFONT) of (fetch (WINDOW DSP) of FAMILY)))
(T (PROG (FONTFACE DEV)
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)))
(SETQ DEV (OR DEVICE (QUOTE DISPLAY)))
(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)))
(RETURN (OR (\LOOKUPFONT FAMILY SIZE FONTFACE ROTATION DEV)
(SETFONTDESCRIPTOR FAMILY SIZE FONTFACE ROTATION DEV
(SELECTQ DEV
[DISPLAY (COND
((\CREATEDISPLAYFONT FAMILY SIZE
FONTFACE
ROTATION))
(NOERRORFLG (RETURN NIL))
(T
(* Error here so retry at user's level)
(LISPERROR "FILE NOT FOUND"
(\FONTFILENAME
FAMILY SIZE
(create FONTFACE))
T)
(GO RETRY]
[PRESS (COND
((\CREATEPRESSFONT FAMILY SIZE
FONTFACE ROTATION))
(NOERRORFLG (RETURN NIL))
(T (ERROR "FONT NOT FOUND"
(LIST FAMILY SIZE FONTFACE
ROTATION))
(GO RETRY]
(PROGN (ERROR DEV "- ILLEGAL FONT DEVICE")
(GO RETRY])
(FONTDESCENT
[LAMBDA (FONTSPEC) (* lmm "19-NOV-82 00:24")
(* See comment in FONTASCENT)
(ffetch \SFDescent of (\GETFONTDESC FONTSPEC])
(FONTHEIGHT
[LAMBDA (FONTSPEC)
(ffetch \SFHeight of (\GETFONTDESC FONTSPEC])
(FONTP
[LAMBDA (X) (* rmk: "26-SEP-82 13:54")
(* is X a FONTDESCRIPTOR?)
(COND
((type? FONTDESCRIPTOR X)
X])
(FONTPROP
[LAMBDA (FONT PROP) (* lmm "19-NOV-82 00:29")
(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))
(\ILLEGAL.ARG PROP])
(SETFONTDESCRIPTOR
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE FONT)
(* rmk: "26-SEP-82 13:55")
(* 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))
(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])
(STRINGWIDTH
[LAMBDA (STR FONT FLG RDTBL) (* rmk: "18-JUL-83 12:34")
(* Returns the width of STR according to FONTSPEC.)
(PROG (STRM WIDTHSBASE)
(DECLARE (SPECVARS WIDTHSBASE)) (* Used in \MAPCHARS)
[SETQ WIDTHSBASE (COND
((type? FONTDESCRIPTOR FONT)
(fetch (ARRAYP BASE) of (ffetch \SFWidths of FONT)))
([SETQ STRM (COND
((\DISPLAYSTREAMP FONT)
FONT)
((type? WINDOW FONT)
(fetch (WINDOW DSP) of FONT]
(ffetch (DISPLAYSTREAM \SFWIDTHSCACHE) of STRM))
(T (* I'm not sure why the default is DISPLAY -
rrb 4/21/83)
(fetch (ARRAYP BASE) of (fetch (FONTDESCRIPTOR \SFWidths)
of (OR (DEFAULTFONT (OR FONT (QUOTE DISPLAY))
NIL T)
(FONTCREATE FONT]
(RETURN (SELECTC (NTYPX STR)
[\LITATOM (COND
[FLG (for C (SA ←(fetch READSA of (\GTREADTABLE RDTBL)))
inatom STR sum (COND
((fetch (READCODE ESCQUOTE)
of (\SYNCODE SA C))
(IPLUS (\FGETWIDTH WIDTHSBASE
(CHARCODE %%))
(\FGETWIDTH WIDTHSBASE C)))
(T (\FGETWIDTH WIDTHSBASE C]
(T (for C inatom STR sum (\FGETWIDTH WIDTHSBASE C]
[\STRINGP (COND
[FLG (IPLUS (UNFOLD (\FGETWIDTH WIDTHSBASE (CHARCODE %"))
2)
(for C instring STR
sum (COND
((OR (EQ C (CHARCODE %"))
(EQ C (CHARCODE %%)))
(IPLUS (\FGETWIDTH WIDTHSBASE
(CHARCODE %%))
(\FGETWIDTH WIDTHSBASE C)))
(T (\FGETWIDTH WIDTHSBASE C]
(T (for C instring STR sum (\FGETWIDTH WIDTHSBASE C]
(PROG ((S 0))
(DECLARE (SPECVARS S))
(\MAPCHARS [FUNCTION (LAMBDA (CC)
(add S (\FGETWIDTH WIDTHSBASE CC]
STR FLG RDTBL)
(RETURN S])
(CHARCODEP
[LAMBDA (CHCODE) (* rrb "15-MAR-82 10:25")
(* is CHCODE a legal character code?)
(AND (SMALLP CHCODE)
(IGREATERP CHCODE 0)
(ILESSP CHCODE \MAXCHAR])
(GETCHARBITMAP
[LAMBDA (CHARCODE FONT) (* J.Gibbons "30-Aug-82 15:39")
(* returns a bitmap of the character CHARCODE from the font descriptor FONTDESC.)
(COND
((CHARCODEP CHARCODE))
((OR (STRINGP CHARCODE)
(LITATOM CHARCODE))
(SETQ CHARCODE (CHCON1 CHARCODE)))
(T (\ILLEGAL.ARG CHARCODE)))
(PROG (CBM FONTDESC CWDTH CHGHT)
(OR (TYPENAMEP (SETQ FONTDESC (\GETFONTDESC FONT))
(QUOTE FONTDESCRIPTOR))
(\ILLEGAL.ARG FONT))
[SETQ CBM (BITMAPCREATE (SETQ CWDTH (CHARWIDTH CHARCODE FONTDESC))
(SETQ CHGHT (FONTPROP FONTDESC (QUOTE HEIGHT]
(BITBLT (fetch (FONTDESCRIPTOR CHARACTERBITMAP) of FONTDESC)
(\GETOFFSET (fetch (FONTDESCRIPTOR \SFOffsets) of FONTDESC)
CHARCODE)
0 CBM 0 0 CWDTH CHGHT)
(RETURN CBM])
(PUTCHARBITMAP
[LAMBDA (CHARCODE FONT NEWCHARBITMAP)
(* J.Gibbons "30-Aug-82 15:40")
(* stores the bitmap NEWCHARBITMAP as the character CHARCODE from the font
descriptor FONTDESC.)
(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 CWDTH CHGHT)
(OR (TYPENAMEP (SETQ FONTDESC (\GETFONTDESC FONT))
(QUOTE FONTDESCRIPTOR))
(\ILLEGAL.ARG FONT))
(SETQ CWDTH (CHARWIDTH CHARCODE FONTDESC))
(COND
((NEQ CWDTH (fetch (BITMAP BITMAPWIDTH) of NEWCHARBITMAP))
(ERROR "character width is different from new image width" NEWCHARBITMAP)))
(SETQ CHGHT (FONTPROP FONTDESC (QUOTE HEIGHT)))
(COND
((NEQ CHGHT (fetch (BITMAP BITMAPHEIGHT) of NEWCHARBITMAP))
(ERROR "character height is different from new image height" NEWCHARBITMAP)))
(BITBLT NEWCHARBITMAP 0 0 (fetch (FONTDESCRIPTOR CHARACTERBITMAP) of FONTDESC)
(\GETOFFSET (fetch (FONTDESCRIPTOR \SFOffsets) of FONTDESC)
CHARCODE)
0 CWDTH CHGHT)
(RETURN NEWCHARBITMAP])
(EDITCHAR
[LAMBDA (CHARCODE FONT) (* rrb "24-MAR-82 12:22")
(* calls the bitmap editor on a character of a font)
(PROG ((FONTDESC (\GETFONTDESC FONT)))
(RETURN (PUTCHARBITMAP CHARCODE FONTDESC (EDITBM (GETCHARBITMAP CHARCODE FONTDESC])
(\CREATEDISPLAYFONT
[LAMBDA (FAMILY SIZE FACE ROTATION) (* rrb "28-APR-83 11:51")
(COND
((AND (EQ ROTATION 0)
(\READDISPLAYFONTFILE FAMILY SIZE FACE)))
(T (PROG (XFONT) (* deal with rotation first.)
(RETURN (COND
[(NEQ ROTATION 0)
(OR (MEMB ROTATION (QUOTE (90 270)))
(ERROR "only implemented rotations are 0, 90 and 270." ROTATION))
(COND
((SETQ XFONT (FONTCREATE FAMILY SIZE FACE 0 (QUOTE DISPLAY)
T))
(\SFMAKEROTATEDFONT XFONT ROTATION]
((AND (EQ (fetch WEIGHT of FACE)
(QUOTE BOLD))
(SETQ XFONT (FONTCREATE FAMILY SIZE (create FONTFACE
using FACE WEIGHT ←(QUOTE
MEDIUM))
0
(QUOTE DISPLAY)
T)))
(create FONTDESCRIPTOR using XFONT CHARACTERBITMAP ←(\SFMAKEBOLD XFONT)
FONTFACE ← FACE))
((AND (EQ (fetch SLOPE of FACE)
(QUOTE ITALIC))
(SETQ XFONT (FONTCREATE FAMILY SIZE (create FONTFACE
using FACE SLOPE ←(QUOTE
REGULAR))
0
(QUOTE DISPLAY)
T)))
(create FONTDESCRIPTOR using XFONT CHARACTERBITMAP ←(\SFMAKEITALIC XFONT)
FONTFACE ← FACE])
(\FONTFACE
[LAMBDA (FACE NOERRORFLG) (* rmk: "23-OCT-81 17:21")
(* Takes a variety of user specifications and converts them to a standard
FONTFACE record.)
(PROG NIL
[RETURN (COND
((type? FONTFACE FACE)
FACE)
[(LITATOM FACE)
(OR (U-CASEP FACE)
(SETQ FACE (U-CASE FACE)))
(SELECTQ FACE
((NIL MRR STANDARD)
(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) (* rmk: "19-OCT-81 19:50")
(* returns the name of the file that should contain the character information for
a font.)
(DECLARE (GLOBALVARS \FONTFILEEXTENSION))
(PACKFILENAME (QUOTE NAME)
(PACK* FAMILY SIZE (SELECTQ (fetch WEIGHT of FACE)
(BOLD (QUOTE B))
"")
(SELECTQ (fetch SLOPE of FACE)
(ITALIC (QUOTE I))
""))
(QUOTE EXTENSION)
\FONTFILEEXTENSION])
(\GETFONTDESC
[LAMBDA (SPEC DEVICE NOERRORFLG)
(* J.Gibbons " 5-Dec-82 16:53")
(* Coerces SPEC to a fontdescriptor)
(* \GETFONTDESC HAS MACRO, BUT OLD CALLS STILL EXIST)
(\COERCEFONTDESC SPEC DEVICE NOERRORFLG])
(\COERCEFONTDESC
[LAMBDA (SPEC DEVICE NOERRORFLG) (* rmk: "18-JUL-83 12:32")
(* Coerces SPEC to a fontdescriptor)
(PROG [(FONT (COND
((type? FONTDESCRIPTOR SPEC)
SPEC)
((\DISPLAYSTREAMP SPEC)
(fetch (DISPLAYSTREAM \SFFONT) of SPEC))
[(NULL SPEC)
(DEFAULTFONT (OR DEVICE (QUOTE DISPLAY]
((type? WINDOW SPEC)
(fetch (DISPLAYSTREAM \SFFONT) of (fetch (WINDOW DSP) of SPEC)))
(T
(* Called with T from DSPFONT. There we want to suppress invalid arg errors as well as font not found, so we can
move on to other possible coercions.)
(FONTCREATE SPEC NIL NIL NIL DEVICE NOERRORFLG]
(COND
((AND DEVICE (NOT NOERRORFLG)
(NEQ DEVICE (fetch FONTDEVICE of FONT)))
(ERROR "font descriptor has the wrong device" SPEC)))
(RETURN FONT])
(\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])
(\READDISPLAYFONTFILE
[LAMBDA (FAMILY SIZE FACE) (* rmk: "12-MAR-82 23:14")
(PROG ((FONTFILE (\FONTFILENAME FAMILY SIZE FACE))
FONTDESC OFD)
(SETQ OFD (\GETOFD (SETQ FONTFILE (OPENFILE (OR (FINDFILE FONTFILE T FONTDIRECTORIES)
(RETURN))
(QUOTE INPUT)))
(QUOTE INPUT)))
(SETQ FONTDESC (SELECTQ (SYSTEMTYPE)
(D (\READSTRIKEFONTFILE FAMILY SIZE FACE OFD))
(JERICHO (\READJERICHOFONTFILE FAMILY SIZE FACE OFD))
(SHOULDNT)))
(CLOSEF FONTFILE)
(RETURN FONTDESC])
(\SFMAKEBOLD
[LAMBDA (FONTD) (* J.Gibbons "11-May-81 23:51")
(PROG ((OLDCHARBITMAP (fetch CHARACTERBITMAP of FONTD))
NEWCHARBITMAP
(widths (fetch \SFWidths of FONTD))
(offsets (fetch \SFOffsets of FONTD))
(height (fetch \SFHeight of FONTD))
offset unknownoffset unknownwidth)
(SETQ NEWCHARBITMAP (BITMAPCREATE (fetch BITMAPWIDTH of OLDCHARBITMAP)
(fetch BITMAPHEIGHT of OLDCHARBITMAP)))
(SETQ unknownoffset (\GETOFFSET offsets (ADD1 \MAXCHAR)))
(SETQ unknownwidth (\GETWIDTH widths (ADD1 \MAXCHAR)))
[for i from 0 to \MAXCHAR do (COND
((EQ (SETQ offset (\GETOFFSET offsets i))
unknownoffset))
(T (BITBLT OLDCHARBITMAP offset 0 NEWCHARBITMAP offset 0
(\GETWIDTH widths i)
height
(QUOTE INPUT)
(QUOTE REPLACE))
(BITBLT OLDCHARBITMAP offset 0 NEWCHARBITMAP
(ADD1 offset)
0
(SUB1 (\GETWIDTH widths i))
height
(QUOTE INPUT)
(QUOTE PAINT]
(BITBLT OLDCHARBITMAP unknownoffset 0 NEWCHARBITMAP unknownoffset 0 unknownwidth height
(QUOTE INPUT)
(QUOTE REPLACE))
(RETURN NEWCHARBITMAP])
(\SFMAKEITALIC
[LAMBDA (FONTDESC) (* J.Gibbons "11-May-81 23:53")
(PROG ((OLDBITMAP (fetch CHARACTERBITMAP of FONTDESC))
NEWBITMAP
(widths (fetch \SFWidths of FONTDESC))
(offsets (fetch \SFOffsets of FONTDESC))
(height (fetch \SFHeight of FONTDESC))
(ascent (fetch \SFAscent of FONTDESC))
(descent (fetch \SFDescent of FONTDESC))
offset width unknownoffset unknownwidth n m r xn xx yn yx)
(SETQ NEWBITMAP (BITMAPCREATE (fetch BITMAPWIDTH of OLDBITMAP)
(fetch BITMAPHEIGHT of OLDBITMAP)))
(SETQ unknownoffset (\GETOFFSET offsets (ADD1 \MAXCHAR)))
(SETQ unknownwidth (\GETWIDTH widths (ADD1 \MAXCHAR)))
(SETQ n (IDIFFERENCE 0 (IQUOTIENT (IPLUS descent 3)
4)))
(SETQ m (IQUOTIENT (IPLUS ascent 3)
4))
[for i from 0 to \MAXCHAR do (COND
((EQ (SETQ offset (\GETOFFSET offsets i))
unknownoffset))
(T (SETQ width (\GETWIDTH widths i))
(for j from n to m
do (SETQ r (IPLUS offset width))
(SETQ xn (IMIN r (IMAX (IPLUS offset j)
0)))
(SETQ xx (IMIN r (IMAX (IPLUS r j)
0)))
[SETQ yn (IMAX 0 (IPLUS descent (ITIMES j 4]
[SETQ yx (IMIN height
(IPLUS descent
(IPLUS (ITIMES j 4)
4]
(COND
((AND (IGREATERP xx xn)
(IGREATERP yx yn))
(BITBLT OLDBITMAP offset yn NEWBITMAP xn yn
(IDIFFERENCE xx xn)
(IDIFFERENCE yx yn)
(QUOTE INPUT)
(QUOTE REPLACE]
(BITBLT OLDBITMAP unknownoffset 0 NEWBITMAP unknownoffset 0 unknownwidth height
(QUOTE INPUT)
(QUOTE REPLACE))
(RETURN NEWBITMAP])
(\SFMAKEROTATEDFONT
[LAMBDA (FONTDESC ROTATION) (* rrb "28-APR-83 12:04")
(* takes a fontdecriptor and rotates it.)
(create FONTDESCRIPTOR using FONTDESC CHARACTERBITMAP ←(\SFROTATEFONTCHARACTERS
(fetch (FONTDESCRIPTOR CHARACTERBITMAP) of FONTDESC)
ROTATION)
ROTATION ← ROTATION \SFOffsets ←(\SFFIXOFFSETSAFTERROTATION FONTDESC
ROTATION])
(\SFROTATEFONTCHARACTERS
[LAMBDA (CHARBITMAP ROTATION) (* rrb "28-APR-83 12:01")
(* rotate a bitmap either 90 or 270 for fonts.)
(PROG (NEWMAP (SELECT (EQ ROTATION 90))
HIGHM1 WIDEM1)
[with BITMAP CHARBITMAP (SETQ HIGHM1 (SUB1 BITMAPHEIGHT))
(SETQ WIDEM1 (SUB1 BITMAPWIDTH))
(SETQ NEWMAP (BITMAPCREATE BITMAPHEIGHT BITMAPWIDTH))
(for X from 0 to WIDEM1 do (for Y from 0 to HIGHM1
do (COND
((EQ 1 (BITMAPBIT CHARBITMAP X Y))
(COND
(SELECT (BITMAPBIT NEWMAP (IDIFFERENCE HIGHM1
Y)
X 1))
(T (BITMAPBIT NEWMAP Y (IDIFFERENCE WIDEM1 X)
1]
(RETURN NEWMAP])
(\SFFIXOFFSETSAFTERROTATION
[LAMBDA (FONTDESC ROTATION) (* rrb "28-APR-83 11:31")
(* adjusts offsets in case where rotation turned things
around.)
(COND
((EQ ROTATION 270)
(PROG ((OFFSETS (fetch (FONTDESCRIPTOR \SFOffsets) of FONTDESC))
(WIDTHS (fetch (FONTDESCRIPTOR \SFWidths) of FONTDESC))
(BITMAPHEIGHT (BITMAPWIDTH (fetch (FONTDESCRIPTOR CHARACTERBITMAP) of FONTDESC)))
NEWOFFSETS)
(SETQ NEWOFFSETS (COPYARRAY OFFSETS))
[for CHARCODE from 0 to \MAXCHAR do (SETA NEWOFFSETS CHARCODE
(IDIFFERENCE BITMAPHEIGHT
(IPLUS (ELT OFFSETS CHARCODE)
(ELT WIDTHS CHARCODE]
(* may be some problem with dummy character
representation.)
(RETURN NEWOFFSETS)))
(T (fetch (FONTDESCRIPTOR \SFOffsets) of FONTDESC])
)
(/DECLAREDATATYPE (QUOTE FONTDESCRIPTOR)
(QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD
WORD WORD WORD WORD SIGNEDWORD SIGNEDWORD SIGNEDWORD SIGNEDWORD
(BITS 8)
POINTER POINTER)))
(/DECLAREDATATYPE (QUOTE FONTDESCRIPTOR)
(QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD
WORD WORD WORD WORD SIGNEDWORD SIGNEDWORD SIGNEDWORD SIGNEDWORD
(BITS 8)
POINTER POINTER)))
[ADDTOVAR SYSTEMRECLST
(DATATYPE FONTDESCRIPTOR (FONTDEVICE CHARACTERBITMAP FONTFAMILY FONTSIZE FONTFACE \SFWidths
\SFOffsets \SFWidthsY (FIRSTCHAR WORD)
(LASTCHAR WORD)
(\SFAscent WORD)
(\SFDescent WORD)
(\SFHeight WORD)
(ROTATION WORD)
(FBBOX SIGNEDWORD)
(FBBOY SIGNEDWORD)
(FBBDX SIGNEDWORD)
(FBBDY SIGNEDWORD)
(\SFFACECODE BITS 8)
\SFLKerns \SFRWidths)
(DATATYPE FONTDESCRIPTOR (FONTDEVICE CHARACTERBITMAP FONTFAMILY FONTSIZE
FONTFACE \SFWidths \SFOffsets
\SFWidthsY (FIRSTCHAR WORD)
(LASTCHAR WORD)
(\SFAscent WORD)
(\SFDescent WORD)
(\SFHeight WORD)
(ROTATION WORD)
(\SFMaxRasterWidth SIGNEDWORD)
(\SFTotalRasterWidth SIGNEDWORD)
(\SFMaxCharWidth SIGNEDWORD)
(\SFTotalCharWidth SIGNEDWORD)
(\SFFACECODE BITS 8)
\SFLKerns \SFRWidths)))
]
(RPAQ? \FONTSINCORE )
(RPAQ? \DEFAULTDEVICEFONTS )
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS FONTDIRECTORIES \DEFAULTDEVICEFONTS)
)
(* 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 FONTDESCRIPTOR (FONTDEVICE CHARACTERBITMAP FONTFAMILY FONTSIZE FONTFACE \SFWidths
\SFOffsets \SFWidthsY (FIRSTCHAR WORD)
(LASTCHAR WORD)
(\SFAscent WORD)
(\SFDescent WORD)
(\SFHeight WORD)
(ROTATION WORD)
(FBBOX SIGNEDWORD)
(FBBOY SIGNEDWORD)
(FBBDX SIGNEDWORD)
(FBBDY SIGNEDWORD)
(\SFFACECODE BITS 8)
\SFLKerns \SFRWidths)
(DATATYPE FONTDESCRIPTOR (FONTDEVICE CHARACTERBITMAP FONTFAMILY FONTSIZE
FONTFACE \SFWidths \SFOffsets
\SFWidthsY (FIRSTCHAR WORD)
(LASTCHAR WORD)
(\SFAscent WORD)
(\SFDescent WORD)
(\SFHeight WORD)
(ROTATION WORD)
(\SFMaxRasterWidth SIGNEDWORD)
(\SFTotalRasterWidth SIGNEDWORD)
(\SFMaxCharWidth SIGNEDWORD)
(\SFTotalCharWidth SIGNEDWORD)
(\SFFACECODE BITS 8)
\SFLKerns \SFRWidths)))
(RECORD FONTFACE (WEIGHT SLOPE EXPANSION)
WEIGHT ←(QUOTE MEDIUM)
SLOPE ←(QUOTE REGULAR)
EXPANSION ←(QUOTE REGULAR)
(TYPE? LISTP))
]
(/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)))
(/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)))
(DECLARE: EVAL@COMPILE
(PUTPROPS FONTASCENT MACRO ((FONTSPEC)
(ffetch \SFAscent of (\GETFONTDESC FONTSPEC))))
(PUTPROPS FONTDESCENT MACRO ((FONTSPEC)
(ffetch \SFDescent of (\GETFONTDESC FONTSPEC))))
(PUTPROPS FONTHEIGHT MACRO ((FONTSPEC)
(ffetch \SFHeight of (\GETFONTDESC FONTSPEC))))
(PUTPROPS \FGETOFFSET DMACRO ((BASE INDEX)
(ELT BASE INDEX)))
(PUTPROPS \FGETOFFSET JMACRO [(BASE INDEX)
(.LDB BASE INDEX (CONSTANT (\SSPP 16 16])
(PUTPROPS \FGETWIDTH DMACRO ((BASE INDEX)
(\GETBASE BASE INDEX)))
(PUTPROPS \FGETWIDTH JMACRO [(BASE INDEX)
(.LDB BASE INDEX (CONSTANT (\SSPP 16 0])
(PUTPROPS \GETOFFSET DMACRO ((ARR INDEX)
(ELT ARR INDEX)))
(PUTPROPS \GETOFFSET JMACRO [(ARR INDEX)
(.LDB ARR (ADD1 INDEX)
(CONSTANT (\SSPP 16 16])
(PUTPROPS \GETWIDTH DMACRO ((ARR INDEX)
(\WORDELT ARR INDEX)))
(PUTPROPS \GETWIDTH JMACRO [(ARR INDEX)
(.LDB ARR (ADD1 INDEX)
(CONSTANT (\SSPP 16 0])
)
(* END EXPORTED DEFINITIONS)
)
(* Interlisp-D specific)
(RPAQQ DONLYFONTFNS (\FONTRESETCHARWIDTHS \READSTRIKEFONTFILE))
(DEFINEQ
(\FONTRESETCHARWIDTHS
[LAMBDA (font) (* rmk: "26-OCT-81 21:19")
(* sets the widths array from the offsets array)
(PROG ((mincharcode (fetch FIRSTCHAR of font))
(maxcharcode (fetch LASTCHAR of font))
(offsets (fetch \SFOffsets of font))
(widths (fetch \SFWidths of font))
left right charoffset dummycharoffset dummycharwidth)
(SETQ dummycharoffset (ELT offsets (ADD1 maxcharcode)))
(SETQ dummycharwidth (IDIFFERENCE (ELT offsets (IPLUS maxcharcode 2))
dummycharoffset))
[for charcode from 0 to \MAXCHAR do (COND
((OR (ILESSP charcode mincharcode)
(IGREATERP charcode maxcharcode))
(SETA offsets charcode dummycharoffset)
(SETA widths charcode dummycharwidth))
(T (SETQ left (ELT offsets charcode))
(SETQ right (ELT offsets (ADD1 charcode)))
(COND
((EQ left right)
(SETA offsets charcode dummycharoffset)
(SETA widths charcode dummycharwidth))
(T (SETA widths charcode (IDIFFERENCE right left]
(SETA widths (ADD1 \MAXCHAR)
dummycharwidth)
(SETA offsets (ADD1 \MAXCHAR)
dummycharoffset])
(\READSTRIKEFONTFILE
[LAMBDA (FAMILY SIZE FACE OFD) (* rrb "12-JAN-83 10:12")
(* First check to make sure it is a vanilla strike font, not a strike index.)
(COND
((ZEROP (LOGAND (\WIN OFD)
16384))
(* 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")
(PROG (FONTDESC NUMBCODES RW BITMAP OFFSETS)
(SETQ FONTDESC (create FONTDESCRIPTOR
FONTFAMILY ← FAMILY
FONTSIZE ← SIZE
FONTFACE ← FACE
FONTDEVICE ←(QUOTE DISPLAY)))
(replace FIRSTCHAR of FONTDESC with (\WIN OFD))
(* minimum ascii code)
(replace LASTCHAR of FONTDESC with (\WIN OFD))
(* maximum ascii code)
(\WIN OFD) (* MaxWidth which isn't used by anyone.)
(\WIN OFD) (* number of words in this StrikeBody)
(replace \SFAscent of FONTDESC with (\WIN OFD))
(* ascent in scan lines (=FBBdy+FBBoy))
(replace \SFDescent of FONTDESC with (\WIN OFD))
(* descent in scan-lines (=FBBoy))
(\WIN OFD) (* offset in bits (<0 for kerning, else 0, =FBBox))
(SETQ RW (\WIN OFD))
(* raster width of bitmap)
(replace \SFHeight of FONTDESC with (IPLUS (fetch \SFAscent of FONTDESC)
(fetch \SFDescent of FONTDESC)))
(* height of bitmap)
(SETQ BITMAP (BITMAPCREATE (UNFOLD RW BITSPERWORD)
(fetch \SFHeight of FONTDESC)))
(\BINS OFD (fetch BITMAPBASE of BITMAP)
0
(UNFOLD (ITIMES RW (fetch \SFHeight of FONTDESC))
BYTESPERWORD))
(* read bits into bitmap)
(replace CHARACTERBITMAP of FONTDESC with BITMAP)
(SETQ NUMBCODES (IPLUS (IDIFFERENCE (fetch LASTCHAR of FONTDESC)
(fetch FIRSTCHAR of FONTDESC))
3))
(SETQ OFFSETS (ARRAY (IPLUS \MAXCHAR 3)
(QUOTE SMALLPOSP)
0 0))
(AIN OFFSETS (fetch FIRSTCHAR of FONTDESC)
NUMBCODES OFD)
(replace \SFOffsets of FONTDESC with OFFSETS)
(replace \SFWidths of FONTDESC with (ARRAY (IPLUS \MAXCHAR 3)
(QUOTE SMALLPOSP)
0 0))
(\FONTRESETCHARWIDTHS FONTDESC)
(RETURN FONTDESC])
)
(DECLARE: DONTCOPY DONTEVAL@LOAD EVAL@COMPILEWHEN (NEQ (COMPILEMODE)
(QUOTE D))
(ADDTOVAR DONTCOMPILEFNS \FONTRESETCHARWIDTHS \READSTRIKEFONTFILE)
)
(DECLARE: DONTEVAL@LOAD COPYWHEN (EQ (COMPILEMODE)
(QUOTE D))
(RPAQQ \FONTFILEEXTENSION STRIKE)
(ADDTOVAR FONTDIRECTORIES {PHYLUM}<ALTOFONTS> {INDIGO}<ALTOFONTS> {INDIGO}<ALTOFONTS>ORIGINAL>)
)
(* Interlisp-Jericho specific)
(RPAQQ JONLYFONTFNS (\FONTDESCARRAY \READJERICHOFONTFILE))
(DEFINEQ
(\FONTDESCARRAY
[LAMBDA (LEFTVAL RIGHTVAL) (* rmk: "26-OCT-81 21:20")
(* Creates an array for a FONTDESCRIPTOR field and initializes it.)
(bind (ARR ←(JARRAY (IPLUS \MAXCHAR 2)
(QUOTE BYTE)
32))
for I from 1 to (IPLUS \MAXCHAR 2)
do (.DPB ARR I (CONSTANT (\SSPP 16 16))
LEFTVAL)
(.DPB ARR I (CONSTANT (\SSPP 16 0))
RIGHTVAL)
finally (RETURN ARR])
(\READJERICHOFONTFILE
[LAMBDA (FAMILY SIZE FACE OFD) (* J.Gibbons " 5-Dec-82 16:54")
(PROG (FONTDESC HEIGHT TOTALCHARWIDTH OFFSETSANDWIDTHS LKERNSANDRWIDTHS BITMAP SCRATCHBITMAP
SCRATCHBITMAPBASE)
(SETQ FONTDESC (create FONTDESCRIPTOR
FONTFAMILY ← FAMILY
FONTSIZE ← SIZE
FONTFACE ← FACE
FONTDEVICE ←(QUOTE DISPLAY)))
(RPTQ (BIN OFD)
(BIN OFD)) (* we don't use the font id.)
(replace \SFHeight of FONTDESC with (SETQ HEIGHT (2BIN OFD)))
(replace \SFAscent of FONTDESC with (ADD1 (2BIN OFD)))
(replace \SFDescent of FONTDESC with (IDIFFERENCE HEIGHT (fetch \SFAscent of FONTDESC)))
(2BIN OFD) (* we don't use the column position adjustment.)
(replace \SFMaxRasterWidth of FONTDESC with (2BIN OFD))
(replace \SFTotalRasterWidth of FONTDESC with (2BIN OFD))
(replace \SFMaxCharWidth of FONTDESC with (2BIN OFD))
(replace \SFTotalCharWidth of FONTDESC with (SETQ TOTALCHARWIDTH (2BIN OFD)))
(replace \SFOffsets of FONTDESC with (SETQ OFFSETSANDWIDTHS (\FONTDESCARRAY TOTALCHARWIDTH
0)))
(replace \SFWidths of FONTDESC with OFFSETSANDWIDTHS)
(replace \SFLKerns of FONTDESC with (SETQ LKERNSANDRWIDTHS (\FONTDESCARRAY 0 0)))
(replace \SFRWidths of FONTDESC with LKERNSANDRWIDTHS)
(SETQ SCRATCHBITMAP (BITMAPCREATE (fetch \SFMaxRasterWidth of FONTDESC)
HEIGHT))
(SETQ SCRATCHBITMAPBASE (fetch BITMAPBASE of SCRATCHBITMAP))
(replace CHARACTERBITMAP of FONTDESC with (SETQ BITMAP (BITMAPCREATE TOTALCHARWIDTH HEIGHT))
)
[bind OFFSET←0
(WORDSPERROW ←(fetch BITMAPRASTERWIDTH of SCRATCHBITMAP))
CHARCODE CHARWIDTH LEFTKERN RASTERWIDTH FLG while (EQ (SETQ FLG (BIN OFD))
255)
do (* Get another character.)
(SETQ CHARCODE (BIN OFD))
(SETQ RASTERWIDTH (2BIN OFD))
(SETQ CHARWIDTH (2BIN OFD))
(SETQ LEFTKERN (\SIGNED (2BIN OFD)
16))
(bind TEM←SCRATCHBITMAPBASE for lineIndex from 1 to HEIGHT
do (for byteIndex from 0 to (LRSH (SUB1 RASTERWIDTH)
3)
do (SELECTQ (LOGAND byteIndex 3)
(0 (.DPB TEM (LRSH byteIndex 2)
(CONSTANT (\SSPP 8 24))
(BIN OFD)))
(1 (.DPB TEM (LRSH byteIndex 2)
(CONSTANT (\SSPP 8 16))
(BIN OFD)))
(2 (.DPB TEM (LRSH byteIndex 2)
(CONSTANT (\SSPP 8 8))
(BIN OFD)))
(3 (.DPB TEM (LRSH byteIndex 2)
(CONSTANT (\SSPP 8 0))
(BIN OFD)))
NIL))
(SETQ TEM (.PTRADD TEM WORDSPERROW)))
[COND
((NOT (ZEROP CHARWIDTH))
(.DPB OFFSETSANDWIDTHS (ADD1 CHARCODE)
(CONSTANT (\SSPP 16 16))
OFFSET)
(.DPB OFFSETSANDWIDTHS (ADD1 CHARCODE)
(CONSTANT (\SSPP 16 0))
CHARWIDTH)
(.DPB LKERNSANDRWIDTHS (ADD1 CHARCODE)
(CONSTANT (\SSPP 16 16))
LEFTKERN)
(.DPB LKERNSANDRWIDTHS (ADD1 CHARCODE)
(CONSTANT (\SSPP 16 0))
RASTERWIDTH)
(BITBLT SCRATCHBITMAP 0 0 BITMAP (IDIFFERENCE OFFSET LEFTKERN)
0 RASTERWIDTH HEIGHT (QUOTE INPUT)
(QUOTE REPLACE))
(SETQ OFFSET (IPLUS OFFSET CHARWIDTH]
finally (COND
((ZEROP FLG))
(T (ERROR (FULLNAME OFD)
"has bad font file format"]
(RETURN FONTDESC])
)
(DECLARE: DONTEVAL@LOAD DONTCOPY EVAL@COMPILEWHEN (NEQ (COMPILEMODE)
(QUOTE JERICHO))
(ADDTOVAR DONTCOMPILEFNS \FONTDESCARRAY \READJERICHOFONTFILE)
)
(DECLARE: DONTEVAL@LOAD COPYWHEN (EQ (COMPILEMODE)
(QUOTE JERICHO))
(RPAQQ \FONTFILEEXTENSION FONT)
(ADDTOVAR FONTDIRECTORIES >FONTS)
)
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS 2BIN JMACRO ((FILE)
(LOGOR (LLSH (BIN FILE)
8)
(BIN FILE))))
(PUTPROPS \GETLKERN JMACRO [(ARR INDEX)
(.LDB ARR (ADD1 INDEX)
(CONSTANT (\SSPP 16 16])
(PUTPROPS \GETRWIDTH JMACRO [(ARR INDEX)
(.LDB ARR (ADD1 INDEX)
(CONSTANT (\SSPP 16 0])
)
)
(DECLARE: EVAL@COMPILE
(PUTPROPS \GETFONTDESC DMACRO [X (COND ((CDR X)
(CONS (QUOTE \COERCEFONTDESC)
X))
(T (BQUOTE (\DTEST , (CAR X)
(QUOTE FONTDESCRIPTOR])
(PUTPROPS \GETFONTDESC MACRO (= . \COERCEFONTDESC))
(PUTPROPS \GETFONTDESC JMACRO [X (COND ((CDR X)
(CONS (QUOTE \COERCEFONTDESC)
X))
(T (BQUOTE (\DTEST , (CAR X)
(QUOTE FONTDESCRIPTOR])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA FONTCOPY)
)
(PUTPROPS FONT COPYRIGHT ("Xerox Corporation" 1981 1982 1983))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2291 27700 (CHARWIDTH 2301 . 3239) (CHARWIDTHY 3241 . 3581) (DEFAULTFONT 3583 . 4534) (
FONTASCENT 4536 . 4678) (FONTCOPY 4680 . 6638) (FONTCREATE 6640 . 9014) (FONTDESCENT 9016 . 9229) (
FONTHEIGHT 9231 . 9329) (FONTP 9331 . 9524) (FONTPROP 9526 . 10327) (SETFONTDESCRIPTOR 10329 . 11551)
(STRINGWIDTH 11553 . 13694) (CHARCODEP 13696 . 13928) (GETCHARBITMAP 13930 . 14824) (PUTCHARBITMAP
14826 . 16210) (EDITCHAR 16212 . 16531) (\CREATEDISPLAYFONT 16533 . 17910) (\FONTFACE 17912 . 19276) (
\FONTFILENAME 19278 . 19816) (\GETFONTDESC 19818 . 20160) (\COERCEFONTDESC 20162 . 21157) (\LOOKUPFONT
21159 . 21588) (\READDISPLAYFONTFILE 21590 . 22169) (\SFMAKEBOLD 22171 . 23470) (\SFMAKEITALIC 23472
. 25318) (\SFMAKEROTATEDFONT 25320 . 25824) (\SFROTATEFONTCHARACTERS 25826 . 26649) (
\SFFIXOFFSETSAFTERROTATION 26651 . 27698)) (32716 36742 (\FONTRESETCHARWIDTHS 32726 . 34013) (
\READSTRIKEFONTFILE 34015 . 36740)) (37229 41348 (\FONTDESCARRAY 37239 . 37702) (\READJERICHOFONTFILE
37704 . 41346)))))
STOP