ImagerTypefaceImpl.mesa
Copyright © 1984, 1985 by Xerox Corporation. All rights reserved.
Doug Wyatt, May 27, 1985 1:47:52 pm PDT
Michael Plass, March 6, 1986 1:39:51 pm PST
DIRECTORY
Atom USING [MakeAtomFromRefText],
BasicTime USING [GMT, nullGMT],
Convert USING [AppendCard],
FS USING [ComponentPositions, EnumerateForNames, Error, ErrorDesc, ExpandName, GetInfo, GetName, NameProc, nullOpenFile, Open, OpenFile],
Imager USING [Error],
ImagerTypeface USING [BYTE, CorrectionType, CreateProc, InfoTable, InfoTableRep, Typeface, XChar],
ImagerTypefaceExtras USING [GenericCreator],
ImagerTypefaceExtrasExtras,
IO USING [PutFR1, rope],
RefText USING [AppendRope, ObtainScratch, ReleaseScratch],
Rope USING [Cat, Concat, Equal, FromRefText, Length, ROPE, Substr, Translate, TranslatorType],
SymTab USING [Create, Delete, Fetch, Insert, Pairs, Ref, Store];
ImagerTypefaceImpl: CEDAR MONITOR
IMPORTS Atom, Convert, FS, Imager, IO, RefText, Rope, SymTab
EXPORTS ImagerTypeface, ImagerTypefaceExtras, ImagerTypefaceExtrasExtras
~ BEGIN OPEN ImagerTypeface;
ROPE: TYPE ~ Rope.ROPE;
creators: SymTab.Ref ~ SymTab.Create[mod: 7, case: FALSE];
Creator: TYPE ~ REF CreatorRep;
CreatorRep: TYPE ~ RECORD[extension: ROPE, create: CreateProc];
Register:
PUBLIC
PROC [extension:
ROPE, create: CreateProc] ~ {
creator: Creator ~ NEW[CreatorRep ← [extension: extension, create: create]];
[] ← SymTab.Store[x: creators, key: extension, val: creator];
};
FetchCreator:
PUBLIC
PROC [extension:
ROPE]
RETURNS [CreateProc] ~ {
found: BOOL; val: REF;
[found, val] ← SymTab.Fetch[creators, extension];
IF found
THEN
WITH val
SELECT
FROM
creator: Creator => RETURN[creator.create];
ENDCASE => ERROR -- val is wrong type or NIL
ELSE RETURN[NIL];
};
RopeFromRef:
PROC [x:
REF]
RETURNS [
ROPE] ~ {
WITH x
SELECT
FROM
text: REF TEXT => RETURN[Rope.FromRefText[text]];
text: REF READONLY TEXT => RETURN[Rope.FromRefText[text]];
ENDCASE => RETURN[NARROW[x]];
};
typefaces: SymTab.Ref ~ SymTab.Create[mod: 37, case: FALSE];
FlushTypefaces:
ENTRY
PROC
RETURNS [ok:
BOOL ←
TRUE] ~ {
someKey: ROPE ← NIL;
epa: PROC [key: ROPE, val: REF] RETURNS [quit: BOOL ← TRUE] ~ {someKey ← key};
WHILE SymTab.Pairs[typefaces, epa]
DO
IF NOT SymTab.Delete[typefaces, someKey] THEN RETURN [FALSE];
ENDLOOP;
};
FetchTypeface:
PROC [name:
ROPE]
RETURNS [Typeface] ~ {
found: BOOL; val: REF;
[found, val] ← SymTab.Fetch[typefaces, name];
IF found
THEN
WITH val
SELECT
FROM
typeface: Typeface => RETURN[typeface];
ENDCASE => ERROR -- val is wrong type or NIL
ELSE RETURN[NIL];
};
races: INT ← 0;
GenericCreator: TYPE ~ ImagerTypefaceExtras.GenericCreator;
generics: LIST OF GenericCreator ~ LIST[NIL];
RegisterGenericCreator:
PUBLIC
ENTRY
PROC [genericCreator: GenericCreator] ~ {
priority: INTEGER ~ genericCreator.priority;
prev: LIST OF GenericCreator ← generics;
FOR p:
LIST
OF GenericCreator ← prev.rest, p.rest
UNTIL p =
NIL
OR p.first.priority < priority
DO
IF p.first.priority = priority THEN {p.first ← genericCreator; RETURN};
prev ← p;
ENDLOOP;
prev.rest ← CONS[genericCreator, prev.rest];
};
GetGeneric:
ENTRY
PROC [list:
LIST
OF GenericCreator]
RETURNS [first: GenericCreator ←
NIL, rest:
LIST
OF GenericCreator ←
NIL] ~ {
IF list#NIL THEN {first ← list.first; rest ← list.rest};
};
Create:
PROC [name:
ROPE]
RETURNS [typeface: Typeface] ~ {
current: GenericCreator ← NIL;
rest: LIST OF GenericCreator ← NIL;
[current, rest] ← GetGeneric[generics.rest];
UNTIL current =
NIL
OR current.priority >= 0
DO
IF (typeface ← current.proc[current, name])#NIL THEN RETURN;
[current, rest] ← GetGeneric[rest];
ENDLOOP;
IF (typeface ← NormalCreate[name])#NIL THEN RETURN;
UNTIL current =
NIL
DO
IF (typeface ← current.proc[current, name])#NIL THEN RETURN;
[current, rest] ← GetGeneric[rest];
ENDLOOP;
ERROR Imager.Error[[code: $fontNotFound, explanation: IO.PutFR1["Could not find font \"%g\".", IO.rope[name]]]];
};
NormalCreate:
PROC [name:
ROPE]
RETURNS [typeface: Typeface] ~ {
fontsDir: ROPE ~ "Fonts/";
pattern: ROPE ~ Rope.Cat["///", fontsDir, name, ".*!h"];
file: FS.OpenFile ← FS.nullOpenFile;
created: BasicTime.GMT ← BasicTime.nullGMT;
fullFName: ROPE ← NIL;
cp: FS.ComponentPositions;
nameStart, nameStop: INT ← 0;
fontName, extension: ROPE ← NIL;
convertToSlashes: Rope.TranslatorType ~ { RETURN[IF old='> THEN '/ ELSE old] };
create: CreateProc ← NIL;
nameProc: FS.NameProc ~ { file ← FS.Open[fullFName]; RETURN[continue: FALSE] };
FS.EnumerateForNames[pattern: pattern, proc: nameProc];
IF file=FS.nullOpenFile THEN RETURN [NIL];
[fullFName: fullFName, cp: cp] ← FS.ExpandName[name: FS.GetName[file].fullFName];
created ← FS.GetInfo[file].created;
nameStart ← cp.subDirs.start+Rope.Length[fontsDir];
nameStop ← cp.base.start+cp.base.length;
fontName ← Rope.Translate[base: fullFName, start: nameStart, len: nameStop-nameStart,
translator: convertToSlashes];
IF NOT Rope.Equal[s1: name, s2: fontName, case: FALSE] THEN ERROR Imager.Error[[code: $bug,
explanation: "Typeface file name doesn't match requested name."]];
extension ← Rope.Substr[base: fullFName, start: cp.ext.start, len: cp.ext.length];
create ← FetchCreator[extension];
IF create=NIL THEN ERROR Imager.Error[[code: $fontTypeNotFound,
explanation: Rope.Concat[fullFName, " is a font file of unknown type"]]];
typeface ← create[file];
typeface.name ← fontName;
typeface.created ← created;
RETURN[typeface];
};
Find:
PUBLIC
PROC [name:
ROPE]
RETURNS [Typeface] ~ {
typeface: Typeface ← FetchTypeface[name];
errorDesc: FS.ErrorDesc;
IF typeface=NIL THEN typeface ← Create[name ! FS.Error => { errorDesc ← error; CONTINUE }];
IF typeface=NIL THEN ERROR Imager.Error[[code: $fontFileError,
explanation: errorDesc.explanation]];
IF typeface.info = NIL THEN BuildInfoTable[typeface];
IF NOT SymTab.Insert[typefaces, typeface.name, typeface] THEN races ← races+1;
RETURN[typeface];
};
BuildInfoTable:
PROC[typeface: Typeface] ~ {
info: InfoTable ~ NEW[InfoTableRep ← ALL[[]]];
FOR code:
BYTE
IN
BYTE
DO
char: XChar ~ [set: 0, code: code];
exists: BOOL ~ typeface.class.Contains[typeface, char];
amplified: BOOL ~ typeface.class.Amplified[typeface, char];
correction: CorrectionType ~ typeface.class.Correction[typeface, char];
info[code] ← [exists: exists, amplified: amplified, correction: correction];
ENDLOOP;
typeface.info ← info;
};
DoWithScratchText:
PROC[len:
NAT, action:
PROC[
REF
TEXT]] ~ {
scratch: REF TEXT ~ RefText.ObtainScratch[len];
action[scratch ! UNWIND => RefText.ReleaseScratch[scratch]];
RefText.ReleaseScratch[scratch];
};
MakeNameAtom:
PUBLIC
PROC [name:
ROPE, gmt: BasicTime.
GMT]
RETURNS [atom:
ATOM] ~ {
InnterMakeNameAtom:
PROC[text:
REF
TEXT] ~ {
text ← RefText.AppendRope[to: text, from: name];
FOR i:
NAT
IN[0..text.length)
DO
char: CHAR ~ text[i];
IF char IN['A..'Z] THEN text[i] ← char-'A+'a; -- convert to lower case
ENDLOOP;
IF gmt#BasicTime.nullGMT
THEN {
text ← RefText.AppendRope[to: text, from: "/v"];
text ← Convert.AppendCard[to: text, from: LOOPHOLE[gmt]];
};
atom ← Atom.MakeAtomFromRefText[text];
};
DoWithScratchText[100, InnterMakeNameAtom];
};
END.