(FILECREATED "20-Jan-84 10:47:14" {PHYLUM}<LISPCORE>SOURCES>FONT.;37 46901
changes to: (FNS \READDISPLAYFONTFILE)
previous date: " 5-Dec-83 15:06:19" {PHYLUM}<LISPCORE>SOURCES>FONT.;36)
(* Copyright (c) 1981, 1982, 1983, 1984 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 \STREAMCHARWIDTH \UNITWIDTHSVECTOR \CREATEDISPLAYFONT \FONTFACE \FONTFILENAME
\GETFONTDESC \COERCEFONTDESC \LOOKUPFONT \READDISPLAYFONTFILE \SFMAKEBOLD \SFMAKEITALIC
\SFMAKEROTATEDFONT \SFROTATEFONTCHARACTERS \SFFIXOFFSETSAFTERROTATION)
(INITRECORDS FONTDESCRIPTOR)
(SYSRECORDS FONTDESCRIPTOR)
(INITVARS (\FONTSINCORE)
(\DEFAULTDEVICEFONTS)
(\UNITWIDTHSVECTOR))
(GLOBALVARS FONTDIRECTORIES \DEFAULTDEVICEFONTS \UNITWIDTHSVECTOR)
(P (\UNITWIDTHSVECTOR)
(MOVD? (QUOTE NILL)
(QUOTE \ACFONTFILENAME)))
(EXPORT (MACROS FONTPROP))
(DECLARE: DONTCOPY (EXPORT (RECORDS FONTDESCRIPTOR FONTFACE)
(MACROS FONTASCENT FONTDESCENT FONTHEIGHT \FGETOFFSET \FGETWIDTH
\GETOFFSET \GETWIDTH)
(MACROS \FCHARWIDTH))
(* Does anyone really use \FCHARWIDTH -- JonL 11/7/83))
[COMS (* Interlisp-D specific)
(FNS * DONLYFONTFNS)
[DECLARE: DONTCOPY DONTEVAL@LOAD EVAL@COMPILEWHEN (NEQ (COMPILEMODE)
(QUOTE D))
(ADDVARS * (LIST (CONS (QUOTE DONTCOMPILEFNS)
DONLYFONTFNS]
(DECLARE: DONTEVAL@LOAD COPYWHEN (EQ (COMPILEMODE)
(QUOTE D))
(VARS (\FONTFILEEXTENSION (QUOTE STRIKE)))
(ADDVARS (FONTDIRECTORIES {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: "31-AUG-83 16:19")
(* 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 (DISPLAYSTREAMP (\OUTSTREAMARG FONT T)))
(ffetch (\DISPLAYDATA DDWIDTHSCACHE) of (fetch IMAGEDATA
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) (* rmk: "21-SEP-83 16:29")
(* sets and returns the default font for a display
device type which is one of DISPLAY PRESS INTERPRESS 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: "21-SEP-83 17:08")
(* makes a copy of a font changing the specified
fields.)
(PROG [NOERROR 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))
(NOERROR (SETQ NOERROR VAL))
(COND
[(AND (EQ I 2)
(EQ FONTSPECS 2)
(LISTP (ARG FONTSPECS 2)))
(for J on (ARG FONTSPECS 2) by (CDDR J)
do (SETQ VAL (CADR J))
(SELECTQ (CAR J)
(FAMILY (SETQ FAMILY VAL))
(SIZE (SETQ SIZE VAL))
(FACE (SETQ FACE (\FONTFACE VAL)))
(WEIGHT (SETQ FACE (create FONTFACE
using FACE WEIGHT ← VAL)))
(SLOPE (SETQ FACE (create FONTFACE
using FACE SLOPE ← VAL)))
(EXPANSION (SETQ FACE
(create FONTFACE using FACE EXPANSION ← VAL))
)
(ROTATION (SETQ ROTATION VAL))
(DEVICE (SETQ DEVICE VAL))
(NOERROR (SETQ NOERROR VAL))
(\ILLEGAL.ARG (CAR J]
(T (\ILLEGAL.ARG (ARG FONTSPECS I]
(RETURN (FONTCREATE FAMILY SIZE FACE ROTATION DEVICE NOERROR])
(FONTCREATE
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE NOERRORFLG) (* rmk: "22-SEP-83 08: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)
[(NULL FAMILY)
(DEFAULTFONT (OR DEVICE (QUOTE DISPLAY]
((OR (IMAGESTREAMP FAMILY)
(type? WINDOW FAMILY))
(DSPFONT NIL 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
(QUOTE PRESS)))
(NOERRORFLG (RETURN NIL))
(T (ERROR "FONT NOT FOUND"
(LIST FAMILY SIZE FONTFACE
ROTATION))
(GO RETRY]
[INTERPRESS (COND
((\CREATEINTERPRESSFONT
FAMILY SIZE FONTFACE
ROTATION (QUOTE INTERPRESS)))
(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: "23-AUG-83 23:03")
(* saves a font descriptor under a
family/size/face/rotation/device key so that it will be
retreived by FONTCREATE. This is a user entry.)
(DECLARE (GLOBALVARS \FONTSINCORE))
(OR DEVICE (SETQQ DEVICE DISPLAY))
[COND
((NULL FONT) (* NIL is used to clobber existing font so that next use
will reread it.)
NIL)
(T (SETQ FONT (\GETFONTDESC FONT DEVICE]
(SETQ FACE (\FONTFACE FACE))
(OR ROTATION (SETQ ROTATION 0))
(PROG [(X (OR (FASSOC FAMILY \FONTSINCORE)
(CAR (push \FONTSINCORE (LIST FAMILY]
[SETQ X (OR (FASSOC SIZE (CDR X))
(CAR (push (CDR X)
(LIST SIZE]
[SETQ X (OR (SASSOC FACE (CDR X))
(CAR (push (CDR X)
(LIST FACE] (* SASSOC cause FACE is listp)
[SETQ X (OR (FASSOC ROTATION (CDR X))
(CAR (push (CDR X)
(LIST ROTATION]
[SETQ X (OR (FASSOC DEVICE (CDR X))
(CAR (push (CDR X)
(LIST DEVICE]
(RPLACD X FONT)
(RETURN FONT])
(STRINGWIDTH
[LAMBDA (STR FONT FLG RDTBL) (* rmk: "31-AUG-83 16:19")
(* 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 (DISPLAYSTREAMP (\OUTSTREAMARG FONT T)))
(ffetch (\DISPLAYDATA DDWIDTHSCACHE) of (fetch IMAGEDATA 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) (* JonL " 7-NOV-83 16:32")
(* is CHCODE a legal character code?)
(AND (SMALLP CHCODE)
(IGEQ CHCODE 0)
(ILEQ CHCODE \MAXCHAR))))
(GETCHARBITMAP
[LAMBDA (CHARCODE FONT) (* 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])
(\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) (* jds "11-NOV-83 12:50")
(COND
((AND (EQ ROTATION 0)
(\READDISPLAYFONTFILE FAMILY SIZE FACE)))
[(AND (EQ ROTATION 0)
(PROG (FONT (FAM (SELECTQ FAMILY
(MODERN (QUOTE FRUTIGER))
(CLASSIC (QUOTE CENTURY))
(LOGOTYPE (QUOTE LOGO))
NIL)))
(COND
((AND FAM (SETQ FONT (\READDISPLAYFONTFILE FAM SIZE FACE)))
(replace FONTFAMILY of FONT with FAMILY)
(RETURN FONT]
(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) (* rrb " 5-Dec-83 15:02")
(* Coerces SPEC to a fontdescriptor)
(PROG [(FONT (COND
((type? FONTDESCRIPTOR SPEC)
SPEC)
[(NULL SPEC)
(DEFAULTFONT (OR DEVICE (QUOTE DISPLAY]
((OR (IMAGESTREAMP SPEC)
(type? WINDOW SPEC))
(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.)
(FONTCREATE SPEC NIL NIL NIL DEVICE NOERRORFLG]
(RETURN (COND
(FONT (* if there was no font found, return NIL.)
(COND
((AND DEVICE (NEQ DEVICE (fetch FONTDEVICE of FONT)))
(FONTCOPY FONT (QUOTE DEVICE)
DEVICE
(QUOTE NOERROR)
NOERRORFLG))
(T 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) (* jds "20-Jan-84 10:45")
(PROG ((FONTFILE (\FONTFILENAME FAMILY SIZE FACE))
FONTDESC OFD)
[COND
((SETQ OFD (AND FONTDIRECTORIES (FINDFILE FONTFILE T FONTDIRECTORIES)))
(SETQ OFD (\GETOFD (SETQ FONTFILE (OPENFILE OFD (QUOTE INPUT)))
(QUOTE INPUT)))
(SETQ FONTDESC (SELECTQ (SYSTEMTYPE)
(D (\READSTRIKEFONTFILE FAMILY SIZE FACE OFD))
(JERICHO (\READJERICHOFONTFILE FAMILY SIZE FACE OFD))
(SHOULDNT)))
(CLOSEF FONTFILE))
((SETQ OFD (AND STARFONTDIRECTORIES (FINDFILE (SETQ FONTFILE (\ACFONTFILENAME FAMILY SIZE
FACE))
T STARFONTDIRECTORIES)))
(SETQ OFD (\GETOFD (SETQ FONTFILE (OPENFILE OFD (QUOTE INPUT)))
(QUOTE INPUT)))
(SETQ FONTDESC (SELECTQ (SYSTEMTYPE)
(D (\READACFONTFILE OFD FAMILY SIZE FACE))
(SHOULDNT]
(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))
]
(RPAQ? \FONTSINCORE )
(RPAQ? \DEFAULTDEVICEFONTS )
(RPAQ? \UNITWIDTHSVECTOR )
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS FONTDIRECTORIES \DEFAULTDEVICEFONTS \UNITWIDTHSVECTOR)
)
(\UNITWIDTHSVECTOR)
(MOVD? (QUOTE NILL)
(QUOTE \ACFONTFILENAME))
(* 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])
)
(DECLARE: EVAL@COMPILE
(PUTPROPS \FCHARWIDTH MACRO (OPENLAMBDA (CHARCODE FONT)
(\FGETWIDTH (ffetch (ARRAYP BASE)
of (ffetch \SFWidths of FONT))
CHARCODE)))
)
(* END EXPORTED DEFINITIONS)
(* Does anyone really use \FCHARWIDTH -- JonL 11/7/83)
)
(* 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 {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 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2484 32024 (CHARWIDTH 2494 . 3386) (CHARWIDTHY 3388 . 3728) (DEFAULTFONT 3730 . 4709) (
FONTASCENT 4711 . 4853) (FONTCOPY 4855 . 6969) (FONTCREATE 6971 . 9572) (FONTDESCENT 9574 . 9787) (
FONTHEIGHT 9789 . 9887) (FONTP 9889 . 10082) (FONTPROP 10084 . 10885) (SETFONTDESCRIPTOR 10887 . 12192
) (STRINGWIDTH 12194 . 14277) (CHARCODEP 14279 . 14559) (GETCHARBITMAP 14561 . 15455) (PUTCHARBITMAP
15457 . 16841) (EDITCHAR 16843 . 17162) (\STREAMCHARWIDTH 17164 . 19747) (\UNITWIDTHSVECTOR 19749 .
20071) (\CREATEDISPLAYFONT 20073 . 21809) (\FONTFACE 21811 . 23175) (\FONTFILENAME 23177 . 23715) (
\GETFONTDESC 23717 . 24059) (\COERCEFONTDESC 24061 . 25071) (\LOOKUPFONT 25073 . 25502) (
\READDISPLAYFONTFILE 25504 . 26493) (\SFMAKEBOLD 26495 . 27794) (\SFMAKEITALIC 27796 . 29642) (
\SFMAKEROTATEDFONT 29644 . 30148) (\SFROTATEFONTCHARACTERS 30150 . 30973) (\SFFIXOFFSETSAFTERROTATION
30975 . 32022)) (36868 40894 (\FONTRESETCHARWIDTHS 36878 . 38165) (\READSTRIKEFONTFILE 38167 . 40892))
(41361 45480 (\FONTDESCARRAY 41371 . 41834) (\READJERICHOFONTFILE 41836 . 45478)))))
STOP