NodeStyleOpsImpl.mesa
Copyright Ó 1985, 1986 by Xerox Corporation. All rights reserved.
written by Bill Paxton, January 1981
Paxton, December 21, 1982 9:55 am
Maxwell, January 6, 1983 9:50 am
Russ Atkinson, March 7, 1985 3:29:21 am PST
Michael Plass, November 25, 1987 11:35:30 am PST
Rick Beach, March 27, 1985 10:54:03 am PST
Doug Wyatt, December 16, 1986 5:44:54 pm PST
DIRECTORY
Atom USING [GetPName, MakeAtom],
Checksum USING [ComputeChecksum],
Convert USING [AppendInt, RopeFromInt],
EditNotify USING [AddNotifyProc, Change, ChangeSet],
Imager USING [Error],
ImagerFont USING [Find, Font, Name, Scale],
IO USING [PutFR],
MessageWindow USING [Append],
NodeProps USING [CopyInfoProc, GetProp, Is, Register],
NodeStyle USING [DataEntry, DataList, FontAlphabets, FontFace, GetStyleName, IntegerValue, MaxNestingLevel, RealCode, Ref, SetReal, StyleBody],
NodeStyleFont USING [],
NodeStyleOps USING [ExtObjPair, LocalStyle, LocalStyleRec, OfStyle],
NodeStyleWorks USING [BadStyleFile, ExecuteLooksInStyle, ExecuteNameInStyle, ExecuteObjectInStyle, ForceLowerName, ForceLowerRope, FreeFrame, GetFrame, GetStyleDict, RunStyle, StyleError, StyleParamKey, Where, WhoIsExecuting],
Real USING [Round],
RefText USING [Append, AppendChar, AppendRope, AppendTextRope, ObtainScratch, ReleaseScratch],
Rope USING [Cat, Concat, Equal, Find, FromRefText, Match, ROPE, Size],
TextLooks USING [Looks, noLooks],
TextNode USING [FirstChild, Level, LocNumber, Parent, Ref],
TJaM USING [Frame, NumberRep, Object, Push, PushRope, Stop, TryToLoad],
VFonts USING [DefaultFont];
NodeStyleOpsImpl: CEDAR MONITOR
IMPORTS Atom, Checksum, Convert, EditNotify, Imager, ImagerFont, IO, MessageWindow, NodeProps, NodeStyle, NodeStyleWorks, Real, RefText, Rope, TextNode, TJaM, VFonts
EXPORTS NodeStyleFont, NodeStyleOps
~
BEGIN
OPEN NodeStyle, NodeStyleOps;
ROPE: TYPE ~ Rope.ROPE;
Frame: TYPE ~ TJaM.Frame;
Object: TYPE ~ TJaM.Object;
Font: TYPE ~ ImagerFont.Font;
Style Operations
Create:
PUBLIC
PROC
RETURNS [Ref] ~ {
create a style body
RETURN [NEW[StyleBody]];
};
Copy:
PUBLIC
PROC [dest, source: Ref] ~ {
copy a style body
dest^ ← source^;
};
s1, s2, s3: Ref ← NIL; -- the small cache of style refs
Alloc:
PUBLIC
ENTRY
PROC
RETURNS [s: Ref] ~ {
get from a small cache
ENABLE UNWIND => NULL;
SELECT
TRUE
FROM
s3 # NIL => { s ← s3; s3 ← NIL };
s2 # NIL => { s ← s2; s2 ← NIL };
s1 # NIL => { s ← s1; s1 ← NIL };
ENDCASE => { s ← Create[] };
};
Free:
PUBLIC
ENTRY
PROC [s: Ref] ~ {
don't free more than once or disaster!
ENABLE UNWIND => NULL;
SELECT
TRUE
FROM
s3 # NIL => { s3 ← s };
s2 # NIL => { s2 ← s };
s1 # NIL => { s1 ← s };
ENDCASE => NULL;
};
LoadStyle:
PUBLIC
PROC [name:
ATOM]
RETURNS [ok:
BOOL] ~ {
frame: Frame ← NodeStyleWorks.GetFrame[NIL, NIL, screen];
[] ← NodeStyleWorks.GetStyleDict[frame, name, screen];
NodeStyleWorks.FreeFrame[frame, NIL, screen];
RETURN [TRUE];
};
DefineStyle:
PUBLIC
PROC [name:
ATOM, def:
ROPE]
RETURNS [ok:
BOOL] ~ {
frame: Frame ← NodeStyleWorks.GetFrame[NIL, NIL, screen];
IF def =
NIL
THEN NodeStyleWorks.BadStyleFile[frame, name]
ELSE {
[] ← NodeStyleWorks.GetStyleDict[frame, name, screen, def];
NodeStyleWorks.FreeFrame[frame, NIL, screen];
};
RETURN [TRUE];
};
ReloadStyle:
PUBLIC
PROC [name:
ATOM]
RETURNS [ok:
BOOL] ~ {
ForceLowerName:
PROC [name:
ATOM]
RETURNS [
ATOM] ~ {
RETURN [Atom.MakeAtom[NodeStyleWorks.ForceLowerRope[Atom.GetPName[name]]]];
};
name ← NodeStyleWorks.ForceLowerName[name];
FOR kind: NodeStyleOps.OfStyle
IN NodeStyleOps.OfStyle
DO
frame: Frame ← NodeStyleWorks.GetFrame[NIL, NIL, kind];
ok ← NodeStyleWorks.RunStyle[frame, name];
IF ok THEN NodeStyleWorks.FreeFrame[frame, NIL, kind] ELSE NodeStyleWorks.BadStyleFile[frame, name];
ENDLOOP;
};
Local Styles
defaultStyleName: PUBLIC ATOM;
defaultStylesForExtensions: PUBLIC LIST OF ExtObjPair;
SetDefaultStyle:
PUBLIC
PROC [name:
ROPE] ~ {
defaultStyleName ← Atom.MakeAtom[NodeStyleWorks.ForceLowerRope[name]];
defaultStyle.name[style] ← defaultStyleName;
FlushCaches[];
};
SetExtensionStyles:
PUBLIC
PROC [value:
LIST
OF
ROPE] ~ {
defaultStylesForExtensions ← NIL;
UNTIL value=
NIL
OR value.rest=
NIL
DO
ext: ATOM ← Atom.MakeAtom[NodeStyleWorks.ForceLowerRope[value.first]]; -- the extension
styleObject: Object ← Rope.Cat["\"", NodeStyleWorks.ForceLowerRope[value.rest.first], "\" style"];
defaultStylesForExtensions ← CONS[[ext, styleObject], defaultStylesForExtensions];
value ← value.rest.rest;
ENDLOOP;
FlushCaches[];
};
localStyleNumber: INT ← 0;
ReadSpecs:
PROC [name:
ATOM, specs:
ROPE]
RETURNS [value:
REF] ~ {
GenLocalName:
ENTRY
PROC
RETURNS [gen:
ROPE] ~ {
localStyleNumber ← localStyleNumber + 1;
gen ← Rope.Concat["LocalStyle-", Convert.RopeFromInt[localStyleNumber]];
};
localStyle: LocalStyle ← NEW[LocalStyleRec];
localStyleName: ROPE ~ GenLocalName[];
localStyle.name ← Atom.MakeAtom[localStyleName];
localStyle.def ← specs;
[] ← DefineStyle[localStyle.name, specs];
RETURN [localStyle];
};
WriteSpecs:
PROC [name:
ATOM, value:
REF]
RETURNS [specs:
ROPE] ~ {
localStyle: LocalStyle ← NARROW[value];
RETURN [IF localStyle=NIL THEN NIL ELSE localStyle.def];
};
CopyInfoProc:
PROC [name:
ATOM, value:
REF]
RETURNS [new:
REF] ~ {
RETURN [value] };
Apply Style to Node
defaultStyle: PUBLIC Ref ← NIL;
rootFormatName: ATOM;
defaultFormatName: ATOM;
ApplyAll:
PUBLIC
PROC [ref: Ref, node: TextNode.Ref, kind: OfStyle ← screen] ~ {
[] ← DoApplyAll[ref, node, kind];
};
DoApplyAll:
PROC [ref: Ref, node: TextNode.Ref, kind: OfStyle]
RETURNS [depth:
CARDINAL] ~ {
found: BOOL;
parent: TextNode.Ref;
alt: ATOM;
IF node = NIL THEN { ref^ ← defaultStyle^; RETURN [0] };
[found, depth] ← FindInApplyAllCache[ref, node, kind];
IF found THEN RETURN [depth+1];
parent ← TextNode.Parent[node];
alt ← IF parent=NIL THEN rootFormatName ELSE defaultFormatName;
depth ← DoApplyAll[ref, parent, kind];
ApplyForNode[ref, node, alt, kind];
EnterInApplyAllCache[ref, node, depth];
RETURN [depth+1];
};
ApplyForNode:
PUBLIC
PROC [ref: Ref, node: TextNode.Ref, alt:
ATOM, kind: OfStyle] ~ {
ENABLE NodeStyleWorks.Where => {
loc1: INT ~ TextNode.LocNumber[at: [node, 0], skipCommentNodes: FALSE];
loc2: INT ~ TextNode.LocNumber[at: [node, Rope.Size[node.rope]], skipCommentNodes: FALSE];
msg: ROPE ~ IO.PutFR["%g..%g", [integer[loc1]], [integer[loc2]]];
RESUME[msg];
};
ext: ATOM;
ref.isComment ← IF node # NIL THEN node.comment ELSE FALSE;
ref.print ← (kind = print);
ref.nestingLevel ← MIN[TextNode.Level[node], MaxNestingLevel];
NodeStyleObsolete.EvalFreeVars[ref, node];
IF node.hasstyledef
THEN {
localStyle: LocalStyle ← NARROW[NodeProps.GetProp[node, $StyleDef]];
IF localStyle # NIL THEN ref.name[style] ← localStyle.name;
};
IF node.hasprefix
THEN {
ApplyObject[ref, NodeProps.GetProp[node, $Prefix], kind ! NodeStyleWorks.WhoIsExecuting => {RESUME[$Prefix]}];
}
ELSE
IF ref.nestingLevel=0
-- root node --
AND
-- check for file extension default
(ext ←
NARROW[NodeProps.GetProp[node, $FileExtension]]) #
NIL
THEN
FOR list:
LIST
OF ExtObjPair ← defaultStylesForExtensions, list.rest
UNTIL list =
NIL
DO
IF list.first.fileExtension # ext THEN LOOP;
ApplyObject[ref, list.first.styleObject, kind];
EXIT;
ENDLOOP;
ApplyFormat[ref, node.formatName, alt, kind];
IF node.haspostfix
THEN {
ApplyObject[ref, NodeProps.GetProp[node, $Postfix], kind ! NodeStyleWorks.WhoIsExecuting => {RESUME[$Postfix]}];
};
ApplyAll Cache
ac: REF ApplyCacheRecord ← NEW[ApplyCacheRecord];
ApplyCacheRecord:
TYPE ~
RECORD [
applyCacheDepth: CARDINAL ← 0, -- next free entry
applyCacheResults: REF ApplyCacheResults,
applyCacheNodes: REF ApplyCacheNodes,
applyCacheProbes, applyCacheHits, applyCacheSaves: INT ← 0 ];
applyCacheSize: CARDINAL ~ 8; -- number of levels deep in tree
ApplyCacheNodes: TYPE ~ ARRAY [0..applyCacheSize) OF TextNode.Ref;
ApplyCacheResults: TYPE ~ ARRAY [0..applyCacheSize) OF StyleBody;
InitApplyCacheRecord:
PROC ~ {
ac.applyCacheResults ← NEW[ApplyCacheResults];
ac.applyCacheNodes ← NEW[ApplyCacheNodes];
};
RemoveAllFromApplyAllCache:
PUBLIC
PROC ~ { FlushApplyAllCache[] };
FlushApplyAllCache:
PUBLIC
ENTRY
PROC [init:
BOOL ←
FALSE] ~ {
ENABLE UNWIND => NULL;
ClearApplyAllCache[init];
};
ClearApplyAllCache:
PROC [init:
BOOL] ~ {
nodes: REF ApplyCacheNodes ← ac.applyCacheNodes;
-- when clearing, go all the way to applyCacheSize rather than stopping at ac.applyCacheDepth
FOR i: CARDINAL IN [0..applyCacheSize) DO nodes[i] ← NIL; ENDLOOP;
ac.applyCacheDepth ← 0;
};
RemoveNodeFromApplyAllCache:
PUBLIC
ENTRY
PROC [node: TextNode.Ref] ~ {
ENABLE UNWIND => NULL;
nodes: REF ApplyCacheNodes ← ac.applyCacheNodes;
FOR i:
CARDINAL
IN [0..ac.applyCacheDepth)
DO
IF nodes[i]=node
THEN {
-- clear from here on
FOR j:
CARDINAL
IN [i..applyCacheSize)
DO
nodes[j] ← NIL;
ENDLOOP;
ac.applyCacheDepth ← i; EXIT
};
ENDLOOP;
};
FindInApplyAllCache:
ENTRY
PROC [ref: Ref, node: TextNode.Ref, kind: OfStyle]
RETURNS [found:
BOOL, depth:
CARDINAL] ~ {
ENABLE UNWIND => NULL;
nodes: REF ApplyCacheNodes ← ac.applyCacheNodes;
print: BOOL ~ (kind=print); -- if true, then find result with print true also
ac.applyCacheProbes ← ac.applyCacheProbes+1;
FOR i:
CARDINAL
DECREASING
IN [0..ac.applyCacheDepth)
DO
IF nodes[i]=node
AND print=ac.applyCacheResults[i].print
THEN {
-- found it
ac.applyCacheHits ← ac.applyCacheHits+1;
ac.applyCacheSaves ← ac.applyCacheSaves+i+1;
ref^ ← ac.applyCacheResults[i];
RETURN [TRUE, i]
};
ENDLOOP;
RETURN [FALSE, 0];
};
EnterInApplyAllCache:
ENTRY
PROC [ref: Ref, node: TextNode.Ref, depth:
CARDINAL] ~ {
ENABLE UNWIND => NULL;
nodes: REF ApplyCacheNodes ← ac.applyCacheNodes;
IF depth >= applyCacheSize THEN RETURN;
nodes[depth] ← node;
ac.applyCacheResults[depth] ← ref^;
FOR i: CARDINAL IN [depth+1..applyCacheSize) DO nodes[i] ← NIL; ENDLOOP;
ac.applyCacheDepth ← depth+1;
};
Update ApplyAll Cache due to Editing Operations
Change: TYPE ~ EditNotify.Change;
Notify:
PROC [change:
REF
READONLY Change] ~ {
if change invalidates one node only, remove that node
else clear entire cache
DoNode:
PROC [node: TextNode.Ref] ~ {
IF TextNode.FirstChild[node] # NIL THEN FlushApplyAllCache[]
ELSE RemoveNodeFromApplyAllCache[node]
};
WITH change
SELECT
FROM
x: REF READONLY Change.InsertingNode => IF TextNode.FirstChild[x.new] # NIL THEN FlushApplyAllCache[];
x: REF READONLY Change.MovingNodes => FlushApplyAllCache[];
x:
REF
READONLY Change.NodeNesting => FlushApplyAllCache[];
-- Change.NodeNesting used to do the following, but since changing the nesting can change the bottomLeading, for instance, I made this more conservative. -mfp
x: REF READONLY Change.NodeNesting => IF x.first = x.last -- only changing one node
AND TextNode.FirstChild[x.first] = NIL -- node has no children
THEN SELECT x.change FROM
1 => -- increasing nesting in tree
IF TextNode.Next[x.first] = NIL THEN RemoveNodeFromApplyAllCache[x.first]
ELSE FlushApplyAllCache;
-1 => -- decreasing nesting in tree
RemoveNodeFromApplyAllCache[x.first];
ENDCASE => FlushApplyAllCache
ELSE FlushApplyAllCache;
x: REF READONLY Change.ChangingFormat => DoNode[x.node];
x:
REF
READONLY Change.ChangingProp => {
IF NodeProps.Is[x.propAtom, $Visible] THEN DoNode[x.node];
};
ENDCASE => ERROR; -- not expecting notify for any other kinds of changes
};
Style Rule Cache
warnDefault:
BOOL ←
FALSE;
-- set this to TRUE to see warnings about missing format definitons
ApplyFormat:
PUBLIC
PROC [ref: Ref, name, alt:
ATOM, kind: OfStyle] ~ {
names: REF RuleCacheNames ← rc.ruleCacheNames;
inputs: REF RuleCacheBodies ← rc.ruleCacheInputs;
input: StyleBody;
initloc, loc: CARDINAL;
FindInRuleCache:
ENTRY
PROC
RETURNS [
BOOL] ~ {
ENABLE UNWIND => NULL;
rc.ruleCacheProbes ← rc.ruleCacheProbes+1;
DO
-- search cache
SELECT names[loc]
FROM
name =>
IF inputs[loc] = ref^
THEN {
ref^ ← rc.ruleCacheResults[loc];
rc.ruleCacheHits ← rc.ruleCacheHits+1;
RETURN [TRUE] };
NIL => RETURN [FALSE]; -- this is an unused entry
ENDCASE;
SELECT (loc ← loc+1)
FROM
ruleCacheSize => IF (loc ← 0)=initloc THEN RETURN [FALSE];
initloc => RETURN [FALSE];
ENDCASE;
ENDLOOP;
};
PutInRuleCache:
ENTRY
PROC ~ {
ENABLE UNWIND => NULL;
IF rc.ruleCacheCount = ruleCacheMax THEN ClearRuleCache[];
loc ← initloc;
DO
-- search cache for place to put the entry
SELECT names[loc]
FROM
name => IF inputs[loc] = input THEN RETURN; -- already in cache
NIL => EXIT; -- this is an unused entry
ENDCASE;
SELECT (loc ← loc+1)
FROM
ruleCacheSize => IF (loc ← 0) = initloc THEN ERROR; -- cache full
initloc => ERROR; -- cache full
ENDCASE;
ENDLOOP;
rc.ruleCacheCount ← rc.ruleCacheCount+1;
inputs[loc] ← input;
rc.ruleCacheResults[loc] ← ref^;
names[loc] ← name;
};
IF name = NIL AND (name ← alt) = NIL THEN RETURN;
loc ← initloc ← HashStyle[ref, , name] MOD ruleCacheSize;
IF FindInRuleCache[] THEN RETURN;
input ← ref^; -- save the input value of the record
IF NodeStyleWorks.ExecuteNameInStyle[ref, kind, name]
THEN PutInRuleCache[]
ELSE
IF name # alt
THEN {
ApplyFormat[ref, alt, NIL, kind];
IF warnDefault
THEN {
frame: TJaM.Frame ~ NodeStyleWorks.GetFrame[ref, NodeStyle.GetStyleName[ref], kind];
TJaM.Push[frame, alt];
TJaM.PushRope[frame, "format used instead of"];
TJaM.Push[frame, name];
NodeStyleWorks.StyleError[frame, 3 ! TJaM.Stop => CONTINUE];
NodeStyleWorks.FreeFrame[frame: frame, styleName: NodeStyle.GetStyleName[ref], kind: kind];
};
};
};
rc: REF RuleCacheInfoRecord ← NEW[RuleCacheInfoRecord];
RuleCacheInfoRecord:
TYPE ~
RECORD [
ruleCacheCount: CARDINAL ← 0, -- number of entries currently in use
ruleCacheNames: REF RuleCacheNames,
ruleCacheInputs: REF RuleCacheBodies,
ruleCacheResults: REF RuleCacheBodies,
ruleCacheProbes, ruleCacheHits: INT ← 0
];
ruleCacheSize: CARDINAL ~ 64; -- should be a power of 2
ruleCacheMax: CARDINAL ~ (ruleCacheSize*4)/5; -- don't fill too full
RuleCacheNames: TYPE ~ ARRAY [0..ruleCacheSize) OF ATOM;
RuleCacheBodies: TYPE ~ ARRAY [0..ruleCacheSize) OF StyleBody;
InitRuleCacheInfo:
PROC ~ {
rc.ruleCacheNames ← NEW[RuleCacheNames];
rc.ruleCacheInputs ← NEW[RuleCacheBodies];
rc.ruleCacheResults ← NEW[RuleCacheBodies];
};
FlushRuleCache:
ENTRY
PROC [init:
BOOL ←
FALSE] ~ {
ENABLE UNWIND => NULL;
ClearRuleCache[];
};
ClearRuleCache:
PROC [init:
BOOL ←
FALSE] ~ {
names: REF RuleCacheNames ← rc.ruleCacheNames;
IF NOT init AND rc.ruleCacheCount = 0 THEN RETURN;
rc.ruleCacheCount ← 0;
FOR i: CARDINAL IN [0..ruleCacheSize) DO names[i] ← NIL; ENDLOOP;
};
HashStyle:
PROC [ref: Ref, looks: TextLooks.Looks ← TextLooks.noLooks, anotherRef:
REF ←
NIL]
RETURNS [
CARDINAL] ~
TRUSTED {
Bits: TYPE ~ MACHINE DEPENDENT RECORD [
REF, REF, REF, REF, RealCode, RealCode, RealCode, RealCode, TextLooks.Looks];
bits: Bits ← [ref.name[style], ref.name[fontPrefix], ref.name[fontFamily], anotherRef,
ref.real[fontSize], ref.real[leftIndent], ref.real[leading], 0, looks];
RETURN [Checksum.ComputeChecksum[3145, SIZE[Bits], @bits]];
Looks Cache
ApplyLooks:
PUBLIC
PROC [ref: Ref, looks: TextLooks.Looks, kind: OfStyle] ~ {
lks: REF LooksCacheLooks ← lc.looksCacheLooks;
inputs: REF LooksCacheBodies ← lc.looksCacheInputs;
initloc, loc: CARDINAL;
input: StyleBody;
FindInLooksCache:
ENTRY
PROC
RETURNS [
BOOL] ~ {
ENABLE UNWIND => NULL;
lc.looksCacheProbes ← lc.looksCacheProbes+1;
DO
-- search cache
SELECT lks[loc]
FROM
looks =>
IF inputs[loc] = ref^
THEN {
ref^ ← lc.looksCacheResults[loc];
lc.looksCacheHits ← lc.looksCacheHits+1;
RETURN [TRUE] };
TextLooks.noLooks => RETURN [FALSE]; -- this is an unused entry
ENDCASE;
SELECT (loc ← loc+1)
FROM
looksCacheSize => IF (loc ← 0)=initloc THEN RETURN [FALSE];
initloc => RETURN [FALSE];
ENDCASE;
ENDLOOP;
PutInLooksCache:
ENTRY
PROC ~ {
ENABLE UNWIND => NULL;
IF lc.looksCacheCount = looksCacheMax THEN ClearLooksCache[];
loc ← initloc;
DO
-- search cache
SELECT lks[loc]
FROM
looks => IF inputs[loc] = input THEN RETURN; -- already in cache
TextLooks.noLooks => EXIT; -- this is an unused entry
ENDCASE;
SELECT (loc ← loc+1)
FROM
looksCacheSize => IF (loc ← 0)=initloc THEN ERROR; -- cache full
initloc => ERROR; -- cache full
ENDCASE;
ENDLOOP;
lc.looksCacheResults[loc] ← ref^;
lks[loc] ← looks;
inputs[loc] ← input;
lc.looksCacheCount ← lc.looksCacheCount+1;
};
IF looks = TextLooks.noLooks THEN RETURN;
loc ← initloc ← HashStyle[ref, looks] MOD looksCacheSize;
IF FindInLooksCache[] THEN RETURN;
input ← ref^; -- save the input value of the record
IF NodeStyleWorks.ExecuteLooksInStyle[ref, kind, looks] THEN PutInLooksCache[];
};
lc: REF LooksCacheInfoRecord ← NEW[LooksCacheInfoRecord];
LooksCacheInfoRecord:
TYPE ~
RECORD [
looksCacheCount: CARDINAL ← 0,
looksCacheLooks: REF LooksCacheLooks,
looksCacheInputs: REF LooksCacheBodies,
looksCacheResults: REF LooksCacheBodies,
looksCacheProbes, looksCacheHits: INT ← 0
];
looksCacheSize: CARDINAL ~ 16; -- should be a power of 2
looksCacheMax: CARDINAL ~ (looksCacheSize*4)/5; -- don't fill too full
LooksCacheLooks: TYPE ~ ARRAY [0..looksCacheSize) OF TextLooks.Looks;
LooksCacheBodies: TYPE ~ ARRAY [0..looksCacheSize) OF StyleBody;
InitLooksCacheInfo:
PROC ~ {
lc.looksCacheLooks ← NEW[LooksCacheLooks];
lc.looksCacheInputs ← NEW[LooksCacheBodies];
lc.looksCacheResults ← NEW[LooksCacheBodies];
};
FlushLooksCache:
ENTRY
PROC [init:
BOOL ←
FALSE] ~ {
ENABLE UNWIND => NULL;
ClearLooksCache[];
};
ClearLooksCache:
PROC [init:
BOOL ←
FALSE] ~ {
IF NOT init AND lc.looksCacheCount = 0 THEN RETURN;
lc.looksCacheCount ← 0;
FOR i: CARDINAL IN [0..looksCacheSize) DO lc.looksCacheLooks[i] ← TextLooks.noLooks; ENDLOOP;
};
Object Cache
ApplyObject:
PUBLIC
PROC [ref: Ref, object: Object, kind: OfStyle ← screen] ~ {
objects: REF ObjectCacheObjects ← oc.objectCacheObjects;
inputs: REF ObjectCacheBodies ← oc.objectCacheInputs;
input: StyleBody;
initloc, loc: CARDINAL;
FindInObjectCache:
ENTRY
PROC
RETURNS [
BOOL] ~ {
ENABLE UNWIND => NULL;
oc.objectCacheProbes ← oc.objectCacheProbes+1;
DO
-- search cache
SELECT objects[loc]
FROM
object =>
IF inputs[loc] = ref^
THEN {
ref^ ← oc.objectCacheResults[loc];
oc.objectCacheHits ← oc.objectCacheHits+1;
RETURN [TRUE] };
nullObject => RETURN [FALSE]; -- this is an unused entry
ENDCASE;
SELECT (loc ← loc+1)
FROM
objectCacheSize => IF (loc ← 0)=initloc THEN RETURN [FALSE];
initloc => RETURN [FALSE];
ENDCASE;
ENDLOOP;
};
PutInObjectCache:
ENTRY
PROC ~ {
ENABLE UNWIND => NULL;
IF oc.objectCacheCount = objectCacheMax THEN ClearObjectCache[];
loc ← initloc;
DO
-- search cache for place to put the entry
SELECT objects[loc]
FROM
object => IF inputs[loc] = input THEN RETURN; -- already in cache
nullObject => EXIT; -- this is an unused entry
ENDCASE;
SELECT (loc ← loc+1)
FROM
objectCacheSize => IF (loc ← 0)=initloc THEN ERROR; -- cache full
initloc => ERROR; -- cache full
ENDCASE;
ENDLOOP;
oc.objectCacheCount ← oc.objectCacheCount+1;
inputs[loc] ← input;
oc.objectCacheResults[loc] ← ref^;
objects[loc] ← object;
};
IF object = nullObject THEN RETURN;
loc ← initloc ← HashStyle[ref, , object] MOD objectCacheSize;
IF FindInObjectCache[] THEN RETURN;
input ← ref^; -- save the input value of the record
IF NodeStyleWorks.ExecuteObjectInStyle[ref, kind, object] THEN PutInObjectCache[];
};
oc: REF ObjectCacheInfoRecord ← NEW[ObjectCacheInfoRecord];
ObjectCacheInfoRecord:
TYPE ~
RECORD [
objectCacheCount: CARDINAL,
objectCacheObjects: REF ObjectCacheObjects,
objectCacheInputs: REF ObjectCacheBodies,
objectCacheResults: REF ObjectCacheBodies,
objectCacheProbes, objectCacheHits: INT ← 0
];
objectCacheSize: CARDINAL ~ 16; -- should be a power of 2
objectCacheMax: CARDINAL ~ (objectCacheSize*4)/5; -- don't fill too full
ObjectCacheObjects: TYPE ~ ARRAY [0..objectCacheSize) OF Object;
ObjectCacheBodies: TYPE ~ ARRAY [0..objectCacheSize) OF StyleBody;
nullObject: Object ~ NIL;
InitObjectCacheInfo:
PROC ~ {
oc.objectCacheObjects ← NEW[ObjectCacheObjects];
oc.objectCacheInputs ← NEW[ObjectCacheBodies];
oc.objectCacheResults ← NEW[ObjectCacheBodies];
};
FlushObjectCache:
ENTRY
PROC [init:
BOOL ←
FALSE] ~ {
ENABLE UNWIND => NULL;
ClearObjectCache[];
};
ClearObjectCache:
PROC [init:
BOOL ←
FALSE] ~ {
IF NOT init AND oc.objectCacheCount = 0 THEN RETURN;
oc.objectCacheCount ← 0;
FOR i: CARDINAL IN [0..objectCacheSize) DO oc.objectCacheObjects[i] ← nullObject; ENDLOOP;
};
Flush Caches
FlushCaches:
PUBLIC
ENTRY
PROC ~ {
ENABLE UNWIND => NULL;
ClearCaches[FALSE];
};
ClearCaches:
PROC [init:
BOOL] ~ {
ClearApplyAllCache[init];
ClearRuleCache[init];
ClearLooksCache[init];
ClearObjectCache[init];
};
Style Parameter Extensions
nonNumeric:
PUBLIC
ERROR ~
CODE;
GetStyleParam:
PUBLIC
PROC [s: Ref, name:
ATOM, styleName:
ATOM, kind: OfStyle]
RETURNS [r:
REAL] ~ {
May raise NodeStyleOps.nonNumeric or TJaM.Error[undefkey].
obj: Object ← GetStyleParamObj[s, name, styleName, kind];
WITH obj
SELECT
FROM
x: REF TJaM.NumberRep.int => r ← x.int;
x: REF TJaM.NumberRep.real => r ← x.real;
ENDCASE => ERROR nonNumeric;
RETURN [r];
};
GetStyleParamI:
PUBLIC
PROC [s: Ref, name:
ATOM, styleName:
ATOM, kind: OfStyle]
RETURNS [i:
INTEGER] ~ {
May raise NodeStyleOps.nonNumeric or TJaM.Error[undefkey].
obj: Object ← GetStyleParamObj[s, name, styleName, kind];
WITH obj
SELECT
FROM
x: REF TJaM.NumberRep.int => i ← x.int;
x: REF TJaM.NumberRep.real => i ← NodeStyle.IntegerValue[x.real];
ENDCASE => ERROR nonNumeric;
RETURN [i];
};
GetStyleParamObj:
PUBLIC
PROC [s: Ref, name:
ATOM, styleName:
ATOM, kind: OfStyle]
RETURNS [obj: Object] ~ {
frame: Frame;
key: ATOM ← NodeStyleWorks.StyleParamKey[name];
FOR x: DataList ← s.dataList, x.next
UNTIL x=
NIL
DO
WITH x
SELECT
FROM
xx: REF NodeStyle.DataEntry.object => IF xx.name = key THEN RETURN[xx.object];
ENDCASE;
ENDLOOP;
frame ← NodeStyleWorks.GetFrame[s, styleName, kind];
obj ← TJaM.TryToLoad[frame, key].val;
NodeStyleWorks.FreeFrame[frame, styleName, kind];
RETURN [obj];
};
Miscellaneous
StyleNameForNode:
PUBLIC
PROC [node: TextNode.Ref]
RETURNS [name:
ATOM] ~ {
Does an ApplyAll and then returns the style name
s: Ref ← Alloc[];
ApplyAll[s, node];
name ← GetStyleName[s];
Free[s];
};
Initialization
InitializeDefaultStyle:
PUBLIC
PROC [suggestedStyle:
ROPE] ~ {
changeSet: EditNotify.ChangeSet;
PointsPerInch: REAL ~ 1.0/0.0138370;
register the notify proc that updates the style caches when edits occur
changeSet[ChangingProp] ← TRUE;
changeSet[ChangingFormat] ← TRUE;
changeSet[MovingNodes] ← TRUE;
changeSet[NodeNesting] ← TRUE;
changeSet[InsertingNode] ← TRUE;
EditNotify.AddNotifyProc[Notify, after, high, changeSet];
initialize all the style caches
InitApplyCacheRecord[];
InitRuleCacheInfo[];
InitLooksCacheInfo[];
InitObjectCacheInfo[];
ClearCaches[TRUE];
establish the default styles wired into Tioga
defaultStyle ← Create[];
defaultFormatName ← $default;
rootFormatName ← $root;
provide some basic style attribute values in case no style gets loaded successfully
defaultStyle.name[fontFamily] ← $Helvetica;
SetReal[defaultStyle, fontSize, 10];
SetReal[defaultStyle, leading, 12];
SetReal[defaultStyle, topLeading, 12];
SetReal[defaultStyle, topIndent, 12];
SetReal[defaultStyle, tabStops, 20];
SetReal[defaultStyle, pageWidth, 8.5*PointsPerInch];
SetReal[defaultStyle, pageLength, 11*PointsPerInch];
SetReal[defaultStyle, leftMargin, 1*PointsPerInch];
SetReal[defaultStyle, rightMargin, 1*PointsPerInch];
SetReal[defaultStyle, topMargin, 1*PointsPerInch];
SetReal[defaultStyle, bottomMargin, 1*PointsPerInch];
SetReal[defaultStyle, lineLength, 6.5*PointsPerInch];
SetReal[defaultStyle, underlineThickness, 1];
SetReal[defaultStyle, underlineDescent, 1];
SetReal[defaultStyle, strikeoutThickness, 1];
SetReal[defaultStyle, strikeoutAscent, 4];
register the special handling procedures for the local style property: StyleDef
NodeProps.Register[name: $StyleDef, reader: ReadSpecs, writer: WriteSpecs, copier: CopyInfoProc];
SetDefaultStyle[suggestedStyle];
};
NodeStyleFontImpl
PrefixKind:
TYPE ~
RECORD [
pattern: ROPE,
sizeInName: BOOL,
preScaled: BOOL, -- Having pre-scaled fonts was probably a mistake, but we are sort of stuck, for now.
faceEncoding: FaceEncoding
];
FaceEncoding:
TYPE ~ {boldItalic, bir, bi};
prefixKinds:
LIST
OF PrefixKind ←
LIST[
[pattern: "xerox/tiogafonts/", sizeInName: TRUE, preScaled: TRUE, faceEncoding: bi],
[pattern: "xerox/pressfonts/", sizeInName: FALSE, preScaled: FALSE, faceEncoding: bir],
[pattern: "xerox/altofonts/", sizeInName: TRUE, preScaled: TRUE, faceEncoding: bi],
[pattern: "xerox/xc*/tioga-", sizeInName: TRUE, preScaled: FALSE, faceEncoding: boldItalic],
[pattern: "xerox/xc*/", sizeInName: FALSE, preScaled: FALSE, faceEncoding: boldItalic]
];
AppendFontName:
PROC [text:
REF
TEXT, prefix:
ATOM, family:
ATOM, face: FontFace, size:
REAL, alphabets: FontAlphabets]
RETURNS [new:
REF
TEXT, sizeInName:
BOOL, preScaled:
BOOL] ~ {
fam: ROPE ~ Atom.GetPName[family];
pre: ROPE ← IF prefix#NIL THEN Atom.GetPName[prefix] ELSE NIL;
faceEncoding: FaceEncoding ← boldItalic;
IF Rope.Find[fam, "/"] >= 0
THEN {
text ← RefText.AppendRope[text, fam];
RETURN [text, FALSE, FALSE];
};
IF pre = NIL OR Rope.Size[pre] = 0 THEN pre ← "xerox/tiogafonts/";
sizeInName ← preScaled ← FALSE;
FOR p:
LIST
OF PrefixKind ← prefixKinds, p.rest
UNTIL p=
NIL
DO
IF Rope.Match[p.first.pattern, pre,
FALSE]
THEN {
sizeInName ← p.first.sizeInName;
preScaled ← p.first.preScaled;
faceEncoding ← p.first.faceEncoding;
};
ENDLOOP;
text ← RefText.AppendRope[text, pre];
text ← RefText.AppendRope[text, fam];
SELECT faceEncoding
FROM
boldItalic => {
IF face=Bold OR face=BoldItalic THEN text ← RefText.AppendTextRope[text, "-bold"];
IF face=Italic OR face=BoldItalic THEN text ← RefText.AppendTextRope[text, "-italic"];
IF sizeInName
THEN {
text ← RefText.AppendChar[text, '-];
text ← Convert.AppendInt[text, Real.Round[size]];
};
};
bir => {
IF sizeInName THEN ERROR;
text ← RefText.AppendTextRope[text, SELECT face FROM Bold => "-BRR", Italic => "-MIR", BoldItalic => "-BIR", ENDCASE => "-MRR"];
};
bi => {
IF sizeInName
THEN {
text ← Convert.AppendInt[text, Real.Round[size]];
};
IF face=Bold OR face=BoldItalic THEN text ← RefText.AppendTextRope[text, "B"];
IF face=Italic OR face=BoldItalic THEN text ← RefText.AppendTextRope[text, "I"];
};
ENDCASE => ERROR;
new ← text;
};
FontNameFromStyleParams:
PUBLIC
PROC [prefix:
ATOM, family:
ATOM, face: FontFace, size:
REAL, alphabets: FontAlphabets]
RETURNS [name:
ROPE, scale:
REAL] ~ {
scratch: REF TEXT ~ RefText.ObtainScratch[100];
text: REF TEXT ← scratch;
sizeInName, preScaled: BOOL ← FALSE;
[text, sizeInName, preScaled] ← AppendFontName[text, prefix, family, face, size, alphabets];
name ← Rope.FromRefText[text];
IF preScaled THEN scale ← 1.0 ELSE scale ← size;
RefText.ReleaseScratch[scratch];
};
nTrys: NAT ~ 5;
tryDelta: ARRAY [0..nTrys) OF REAL ← [0, -0.999, 0.999, -1.998, 1.998];
families:
LIST
OF
LIST
OF
ATOM ←
LIST[
LIST[$Tioga, $Laurel, $TimesRoman],
LIST[$TimesRoman, $Classic],
LIST[$Helvetica, $Modern, $TimesRoman],
LIST[$Modern, $Helvetica],
LIST[$Classic, $TimesRoman, $Modern],
LIST[$Gacha, $Helvetica]
];
SubstituteFamilies:
PROC [family:
ATOM]
RETURNS [
LIST
OF
ATOM] ~ {
fam: ROPE ~ Atom.GetPName[family];
FOR f:
LIST
OF
LIST
OF
ATOM ← families, f.rest
UNTIL f=
NIL
DO
k: ATOM ← f.first.first;
IF family = k OR Rope.Equal[fam, Atom.GetPName[k], FALSE] THEN RETURN [f.first];
ENDLOOP;
RETURN [NIL];
};
FontReplacementProc:
PROC [prefix:
ATOM, family:
ATOM, face: FontFace, size:
REAL, alphabets: FontAlphabets]
RETURNS [font: ImagerFont.Font] ←
NIL;
Plug with debugger for experimentation purposes.
horribleHackForTioga10:
BOOL ←
TRUE;
defaultPrintFont: ImagerFont.Font ← NIL;
candidates:
LIST
OF
ROPE ←
LIST[
"xerox/xc1-2-2/modern",
"xerox/pressfonts/helvetica-mrr"
];
GetDefaultFont:
PROC
RETURNS [ImagerFont.Font] ~ {
FOR each:
LIST
OF
ROPE ← candidates, each.rest
WHILE defaultPrintFont =
NIL
DO
Address fault if none of the default candidates were found
defaultPrintFont ← ImagerFont.Find[each.first, substituteQuietly ! Imager.Error => CONTINUE];
ENDLOOP;
RETURN [defaultPrintFont]
};
FontFromStyleParams:
PUBLIC
PROC [prefix:
ATOM, family:
ATOM, face: FontFace, size:
REAL, alphabets: FontAlphabets]
RETURNS [font: ImagerFont.Font ←
NIL] ~ {
didSubstitution: BOOL ← FALSE;
font ← CheckStyleFontCache[prefix, family, face, size, alphabets];
IF font =
NIL
THEN {
IF FontReplacementProc #
NIL
THEN {
font ← FontReplacementProc[prefix, family, face, size, alphabets];
};
IF font =
NIL
THEN {
scratch: REF TEXT ~ RefText.ObtainScratch[100];
text: REF TEXT ← scratch;
sizeInName, preScaled: BOOL ← FALSE;
trialFace: FontFace ← face;
WHILE font =
NIL
DO
This loop tries different faces.
families: LIST OF ATOM ← NIL;
trialFamily: ATOM ← family;
firstFamily: ATOM ← family;
IF horribleHackForTioga10
AND (firstFamily=$tioga
OR firstFamily=$Tioga)
AND (size
NOT
IN [9.5..10.5])
THEN {
trialFamily ← firstFamily ← $TimesRoman;
};
WHILE font =
NIL
AND trialFamily #
NIL
DO
This loop tries different families.
FOR try:
NAT
IN [0..nTrys)
WHILE font =
NIL
DO
This loop tries different sizes of screen fonts.
trialSize: REAL ← size + tryDelta[try];
text.length ← 0;
[text, sizeInName, preScaled] ← AppendFontName[text, prefix, trialFamily, trialFace, trialSize, alphabets];
font ← ImagerFont.Find[Rope.FromRefText[text], noSubstitute ! Imager.Error => CONTINUE];
IF font = NIL THEN didSubstitution ← TRUE;
IF NOT sizeInName THEN EXIT;
ENDLOOP;
IF font =
NIL
THEN {
IF families = NIL THEN families ← SubstituteFamilies[firstFamily];
IF families #
NIL
THEN {
families ← families.rest;
};
trialFamily ← IF families=NIL THEN NIL ELSE families.first;
};
ENDLOOP;
IF trialFace = Regular THEN EXIT;
trialFace ← IF trialFace = BoldItalic THEN Bold ELSE IF trialFace = Bold AND face = BoldItalic THEN Italic ELSE Regular;
ENDLOOP;
IF font =
NIL
THEN {
Last chance!
IF sizeInName
THEN { font ← VFonts.DefaultFont[font]; preScaled ← TRUE } -- Probably not for printing
ELSE { font ← GetDefaultFont[]; preScaled ← FALSE }
};
IF NOT preScaled THEN { font ← ImagerFont.Scale[font, size] };
RefText.ReleaseScratch[scratch];
};
EnterStyleFontCache[[prefix, family, face, size, alphabets, font]];
};
IF didSubstitution
THEN {
text: REF TEXT ← RefText.ObtainScratch[100];
text ← RefText.AppendRope[text, "Substituting font "];
text ← RefText.AppendRope[text, ImagerFont.Name[font]];
text ← RefText.AppendRope[text, " for "];
text ← AppendFontName[text, prefix, family, face, size, alphabets].new;
MessageWindow.Append[Rope.FromRefText[text], TRUE];
RefText.ReleaseScratch[text];
};
};
Style Font Cache
styleFontCacheSize: NAT ← 5;
styleFontCache: LIST OF StyleFontCacheRec ← NIL;
styleFontCacheHits: INT ← 0;
styleFontCacheMisses:
INT ← 0;
StyleFontCacheRec:
TYPE ~
RECORD [prefix:
ATOM, family:
ATOM, face: FontFace, size:
REAL, alphabets: FontAlphabets, font: ImagerFont.Font];
FlushStyleFontCache:
ENTRY
PROC ~ { styleFontCache ←
NIL };
CheckStyleFontCache:
ENTRY
PROC [prefix:
ATOM, family:
ATOM, face: FontFace, size:
REAL, alphabets: FontAlphabets]
RETURNS [ImagerFont.Font] ~ {
prev: LIST OF StyleFontCacheRec ← NIL;
FOR c:
LIST
OF StyleFontCacheRec ← styleFontCache, c.rest
UNTIL c =
NIL
DO
IF c.first.prefix = prefix
AND c.first.family = family
AND c.first.face = face
AND c.first.size = size
AND c.first.alphabets = alphabets
THEN {
IF prev #
NIL
THEN {
Move to front
prev.rest ← c.rest;
c.rest ← styleFontCache;
styleFontCache ← c;
};
styleFontCacheHits ← styleFontCacheHits + 1;
RETURN [c.first.font];
};
prev ← c;
ENDLOOP;
styleFontCacheMisses ← styleFontCacheMisses + 1;
RETURN [NIL]
};
EnterStyleFontCache:
ENTRY
PROC [styleFontCacheRec: StyleFontCacheRec] ~ {
new: LIST OF StyleFontCacheRec ← NIL;
prev: LIST OF StyleFontCacheRec ← NIL;
i: NAT ← 2;
NB: The following code forces a styleFontCache size of >= 2
FOR p:
LIST
OF StyleFontCacheRec ← styleFontCache, p.rest
DO
IF p = NIL THEN {new ← LIST[styleFontCacheRec]; EXIT};
IF i >= styleFontCacheSize
AND p.rest#
NIL
THEN {
new ← p.rest;
p.rest ← NIL;
new.rest ← NIL;
new.first ← styleFontCacheRec;
EXIT;
};
i ← i + 1;
ENDLOOP;
new.rest ← styleFontCache;
styleFontCache ← new;
};
END.