NodeStyleWorks1Impl.mesa
Copyright © 1985, 1986 by Xerox Corporation. All rights reserved.
Rick Beach, November 25, 1985 1:03:07 pm PST
Michael Plass, May 6, 1986 5:29:07 pm PDT
Russ Atkinson (RRA) August 8, 1985 1:09:13 am PDT
Doug Wyatt, September 24, 1986 7:08:06 pm PDT
DIRECTORY
BasicTime USING [GMT, nullGMT],
FS USING [Error, FileInfo],
MessageWindow USING [Append, Blink, Clear],
NodeStyle USING [GetReal, RealParam, SetReal, Style],
NodeStyleFont USING [FontFromStyleParams],
NodeStyleOps USING [Create, defaultStyle, defaultStyleName, FlushCaches, LoadStyle, OfStyle],
NodeStyleValidate USING [],
NodeStyleWorks USING [AddRealProc, ForceLowerName, get, LoadProc, Ops, OpsRec, Param, ParamRec, PercentProc, PopName, RegisterStyleCommand, run, SetNameProc, StoreProc, TryToPopName, TypeCheckDict, TypeCheckName],
PrincOpsUtils USING [],
Process USING [GetCurrent],
RefTab USING [Create, Fetch, Pairs, Ref, Store],
Rope USING [Concat, Equal, FromChar, ROPE],
TextLooks USING [Look, Looks],
TJaM USING [ABind, ACopy, AGet, APut, Array, AtomFromRope, AttachDict, Begin, ClrDict, CommandProc, CountStack, CvX, DetachAll, DetachDict, Dict, DictTop, End, Execute, Frame, Load, NewArray, NewDict, NewFrame, Object, Pop, PopDict, PopReal, Push, PushInt, PushReal, PushRope, Put, Register, RopeFromAtom, Stop, TryToGet, TryToLoad],
UserProfile USING [ListOfTokens];
NodeStyleWorks1Impl: CEDAR MONITOR
IMPORTS FS, MessageWindow, NodeStyle, NodeStyleFont, NodeStyleOps, NodeStyleWorks, Process, RefTab, Rope, TJaM, UserProfile
EXPORTS NodeStyleWorks, NodeStyleValidate
~ BEGIN OPEN NodeStyle, NodeStyleWorks;
Execution Frames for Style Machinery
ROPE: TYPE ~ Rope.ROPE;
Frame: TYPE ~ TJaM.Frame;
OfStyle: TYPE ~ NodeStyleOps.OfStyle;
Object: TYPE ~ TJaM.Object;
FrameInfo: TYPE ~ REF FrameInfoBody;
FrameInfoBody: TYPE ~ RECORD [ frame: Frame, style: Style, rest: FrameInfo ];
GetFrame: PUBLIC PROC [style: Style, styleName: ATOM, kind: OfStyle]
RETURNS
[frame: Frame] ~ {
-- style is the StyleRef you will be using with the frame
-- styleName tells which style dictionary you want
-- will give you default style if requested style bombs during load
found: BOOL;
AllocFrame: ENTRY PROC [name: ATOM, kind: OfStyle] ~ {
ENABLE UNWIND => NULL;
allocFrameCalls ← allocFrameCalls+1;
IF name # NIL THEN {
-- first try to find one that already has the right style
IF name = styleName1 AND kind = styleKind1 AND freeFrame1 # NIL THEN
{ frame ← freeFrame1; freeFrame1 ← NIL; RETURN };
IF name = styleName2 AND kind = styleKind2 AND freeFrame2 # NIL THEN
{ frame ← freeFrame2; freeFrame2 ← NIL; RETURN };
IF name = styleName3 AND kind = styleKind3 AND freeFrame3 # NIL THEN
{ frame ← freeFrame3; freeFrame3 ← NIL; RETURN };
IF name = styleName4 AND kind = styleKind4 AND freeFrame4 # NIL THEN
{ frame ← freeFrame4; freeFrame4 ← NIL; RETURN }};
-- look for any free one
IF freeFrame1 # NIL THEN { frame ← freeFrame1; freeFrame1 ← NIL }
ELSE IF freeFrame2 # NIL THEN { frame ← freeFrame2; freeFrame2 ← NIL }
ELSE IF freeFrame3 # NIL THEN { frame ← freeFrame3; freeFrame3 ← NIL }
ELSE IF freeFrame4 # NIL THEN { frame ← freeFrame4; freeFrame4 ← NIL }
ELSE {
frame ← TJaM.NewFrame[];
frameAlloc ← frameAlloc+1;
TJaM.Begin[frame, styledict];
};
};
SaveStyleInfo: ENTRY PROC ~ {
ENABLE UNWIND => NULL;
IF frame1 = NIL THEN { frame1 ← frame; style1 ← style }
ELSE IF frame2 = NIL THEN { frame2 ← frame; style2 ← style }
ELSE IF frame3 = NIL THEN { frame3 ← frame; style3 ← style }
ELSE IF frame4 = NIL THEN { frame4 ← frame; style4 ← style }
ELSE FOR lst: FrameInfo ← frameList, lst.rest UNTIL lst=NIL DO
IF lst.frame = NIL THEN { lst.frame ← frame; lst.style ← style; EXIT };
REPEAT FINISHED => frameList ← NEW[FrameInfoBody ← [frame, style, frameList]];
ENDLOOP;
};
AllocFrame[styleName, kind]; -- use styleName and kind as hint about which to allocate
IF styleName # NIL THEN {
get the proper style dictionary on the frame dictionary stack
styleNameObj: Object;
done: BOOLFALSE;
[found, styleNameObj] ← TJaM.TryToLoad[frame, styleDictName];
IF found THEN { -- some style dictionary on stack already
IF TypeCheckName[styleNameObj] = styleName THEN { -- still must check kind of style
kindNameObj: Object;
[found, kindNameObj] ← TJaM.TryToLoad[frame, styleKindName];
IF found AND TypeCheckName[kindNameObj] = kindNames[kind] THEN
done ← TRUE;
}; -- already there
IF NOT done THEN -- get rid of top dictionary
WHILE TJaM.DictTop[frame] # styledict DO
TJaM.End[frame]; ENDLOOP;
};
IF NOT done THEN TJaM.Begin[frame, GetStyleDict[frame, styleName, kind]]
}
ELSE WHILE TJaM.DictTop[frame] # styledict DO TJaM.End[frame] ENDLOOP;
SaveStyleInfo[];
};
FreeFrame: PUBLIC ENTRY PROC [frame: Frame, styleName: ATOM, kind: OfStyle] ~ {
name and kind are just a hint about what style dictionary is on the frame stack
ENABLE UNWIND => NULL;
freeFrameCalls ← freeFrameCalls+1;
add it to cache of free frames or really free it if cache full
IF freeFrame1 = NIL THEN {
freeFrame1 ← frame; styleName1 ← styleName; styleKind1 ← kind }
ELSE IF freeFrame2 = NIL THEN {
freeFrame2 ← frame; styleName2 ← styleName; styleKind2 ← kind }
ELSE IF freeFrame3 = NIL THEN {
freeFrame3 ← frame; styleName3 ← styleName; styleKind3 ← kind }
ELSE IF freeFrame4 = NIL THEN {
freeFrame4 ← frame; styleName4 ← styleName; styleKind4 ← kind }
ELSE { frameFree ← frameFree+1; }; -- let garbage collector find it
remove it from active frame info
SELECT frame FROM
frame1 => { frame1 ← NIL; style1 ← NIL };
frame2 => { frame2 ← NIL; style2 ← NIL };
frame3 => { frame3 ← NIL; style3 ← NIL };
frame4 => { frame4 ← NIL; style4 ← NIL };
ENDCASE => FOR lst: FrameInfo ← frameList, lst.rest UNTIL lst=NIL DO
IF lst.frame = frame THEN { lst.frame ← NIL; lst.style ← NIL; EXIT };
ENDLOOP;
};
StyleForFrame: PUBLIC PROC [frame: Frame] RETURNS [style: Style] ~ {
GetIt: ENTRY PROC RETURNS [s: Style] ~ {
ENABLE UNWIND => NULL;
SELECT frame FROM
frame1 => RETURN [style1];
frame2 => RETURN [style2];
frame3 => RETURN [style3];
frame4 => RETURN [style4];
ENDCASE => FOR lst: FrameInfo ← frameList, lst.rest UNTIL lst=NIL DO
IF lst.frame=frame THEN RETURN [lst.style];
ENDLOOP };
IF (style ← GetIt[]) = NIL THEN { -- failed to find the frame
IF debugFlag THEN {
IF debugStyle = NIL THEN debugStyle ← NodeStyleOps.Create[];
RETURN [debugStyle];
};
ERROR;
};
RETURN [style];
};
Style Dictionaries
GetStyleDict: PUBLIC PROC [frame: Frame, styleName: ATOM, kind: OfStyle,
def: ROPENIL]
RETURNS [d: TJaM.Dict] ~ {
found, ok: BOOL;
styleName ← ForceLowerName[styleName];
[d, found] ← CheckStyleDict[styleName, kind];
IF found THEN RETURN;
ok ← IF def # NIL
THEN RunStyleString[frame, styleName, def]
ELSE RunStyle[frame, styleName];
IF ok THEN [d, found] ← CheckStyleDict[styleName, kind];
IF NOT found THEN {
BadStyleFile[frame, styleName];
[d, found] ← CheckStyleDict[styleName, kind];
};
};
BadStyleFile: PUBLIC PROC [frame: Frame, styleName: ATOM] ~ {
fake it so looks as if had a file saying "BeginStyle (default) AttachStyle EndStyle"
{
ENABLE {
WhatStyle => RESUME[styleName];
StartOfStyle => RESUME;
EndOfStyle => RESUME;
};
BeginStyleOp[frame];
IF styleName # NodeStyleOps.defaultStyleName THEN {
TJaM.Push[frame, NodeStyleOps.defaultStyleName];
AttachStyleOp[frame];
};
EndStyleOp[frame];
};
[] ← RefTab.Store[fileForStyle, styleName, NEW [FileIDRep ← []]];
MessageWindow.Append[TJaM.RopeFromAtom[styleName], TRUE];
MessageWindow.Append[".style could not be loaded."];
MessageWindow.Blink[];
TJaM.Push[frame, styleName];
TJaM.PushRope[frame, "style was bad."];
StyleError[frame, 2];
};
CheckStyleDict: PROC [styleName: ATOM, kind: OfStyle]
RETURNS [d: TJaM.Dict, found: BOOL] ~ {
obj: Object;
[found, obj] ← TJaM.TryToGet[stylesDicts[kind], styleName];
IF found THEN d ← TypeCheckDict[obj];
};
CreateStyleDict: PROC RETURNS [d: TJaM.Dict] ~ { -- creates dict for style
RETURN [TJaM.NewDict[50]];
};
EnterStyleDict: PROC [styleName: ATOM, d: Object, kind: OfStyle] ~ {
TJaM.Put[stylesDicts[kind], styleName, d];
};
Style File handling.
Search rule handling
defaultSearch: LIST OF ROPELIST["[]<>Commands>", "[]<>"];
FileID: TYPE ~ REF FileIDRep;
FileIDRep: TYPE ~ RECORD [name: ROPENIL, time: BasicTime.GMT ← BasicTime.nullGMT];
Same: PROC [a, b: FileID] RETURNS [BOOL] ~ {
RETURN [a.time = b.time AND Rope.Equal[a.name, b.name, FALSE]]
};
GetFileID: PROC [shortName: ATOM, extension: ROPE] RETURNS [FileID] ~ {
dirs: LIST OF ROPE ← UserProfile.ListOfTokens["Tioga.StyleSearchRules", defaultSearch];
name: ROPE ~ Rope.Concat[TJaM.RopeFromAtom[shortName], extension];
fileName: ROPENIL;
created: BasicTime.GMT ← BasicTime.nullGMT;
WHILE fileName = NIL AND dirs # NIL DO
[fullFName: fileName, created: created] ← FS.FileInfo[name: name, wDir: dirs.first ! FS.Error => CONTINUE];
dirs ← dirs.rest;
ENDLOOP;
IF fileName = NIL THEN RETURN [NIL];
RETURN [NEW[FileIDRep ← [fileName, created]]];
};
Locking to avoid concurrent changes to internal style representation.
DoLocked: PUBLIC PROC [action: PROC] ~ {
me: UNSAFE PROCESS ~ Process.GetCurrent[];
Lock: ENTRY PROC ~ {
UNTIL styleLockProcess = me OR styleLockCount = 0 DO WAIT styleLockFree ENDLOOP;
styleLockProcess ← me; styleLockCount ← styleLockCount + 1;
};
Unlock: ENTRY PROC ~ {
styleLockCount ← styleLockCount - 1;
IF styleLockCount = 0 THEN {styleLockProcess ← NIL; NOTIFY styleLockFree};
};
Lock[];
action[ ! UNWIND => Unlock[]];
Unlock[];
};
Running styles and validation of style to file correspondence.
ValidateStyles: PUBLIC PROC RETURNS [changed: BOOLFALSE] ~ {
Called from elsewhere in Tioga when something changes that may have changed any style.
Does not attempt to refresh screen.
Locked: PROC ~ {
Action: PROC [key: REF, val: REF] RETURNS [quit: BOOLEAN] ~ {
IF ValidateStyle[NARROW[key]] THEN changed ← TRUE;
RETURN [FALSE]
};
[] ← RefTab.Pairs[fileForStyle, Action];
};
DoLocked[Locked];
};
ValidateStyle: PUBLIC PROC [styleName: ATOM] RETURNS [changed: BOOLFALSE] ~ {
Called from elsewhere in Tioga when something changes that may have changed a style.
Does not attempt to refresh screen.
Locked: PROC ~ {
fileID: FileID ~ GetFileID[styleName, ".style"];
oldFileID: FileID ~ NARROW[RefTab.Fetch[fileForStyle, styleName].val];
IF oldFileID = NIL OR fileID = NIL OR Same[fileID, oldFileID]
THEN changed ← FALSE
ELSE {
frame: Frame ← GetFrame[NIL, NIL, screen];
IF NOT RunStyle[frame, styleName] THEN BadStyleFile[frame, styleName];
FreeFrame[frame, NIL, screen];
changed ← TRUE;
};
};
DoLocked[Locked];
};
RunStyle: PUBLIC PROC [frame: Frame, styleName: ATOM] RETURNS [ok: BOOLFALSE] ~ {
Inner: PROC ~ {
started, finished: BOOLFALSE;
this is probably where the use of working directories for style files needs to be added
fileID: FileID ~ GetFileID[styleName, ".style"];
TJaM.Put[attachmentsDict, styleName, TJaM.NewArray[0]];
IF fileID = NIL THEN {ok ← FALSE; RETURN};
MessageWindow.Append["Using ", runNesting=0];
MessageWindow.Append[fileID.name, FALSE];
MessageWindow.Append[" . . . ", FALSE];
runNesting ← runNesting + 1;
TJaM.PushRope[frame, fileID.name];
TJaM.Execute[frame, run !
WhatStyle => RESUME[styleName];
StartOfStyle => { started ← TRUE; RESUME };
EndOfStyle => { finished ← TRUE; RESUME };
TJaM.Stop => { finished ← FALSE; CONTINUE };
];
runNesting ← runNesting - 1;
ok ← started AND finished;
IF ok THEN MessageWindow.Append["ok ", FALSE];
IF ok THEN [] ← RefTab.Store[fileForStyle, styleName, fileID];
IF ok AND runNesting=0 THEN MessageWindow.Clear[];
};
DoLocked[Inner];
};
RunStyleString: PUBLIC PROC [frame: Frame, styleName: ATOM, def: ROPE]
RETURNS [ok: BOOL] ~ {
started, finished: BOOLFALSE;
TJaM.Put[attachmentsDict, styleName, TJaM.NewArray[0]];
TJaM.Execute[frame, TJaM.CvX[def] !
WhatStyle => { RESUME[styleName] };
StartOfStyle => { started ← TRUE; RESUME };
EndOfStyle => { finished ← TRUE; RESUME };
TJaM.Stop => { finished ← FALSE; CONTINUE };
];
RETURN [started AND finished];
};
styleDictName: ATOM ~ TJaM.AtomFromRope["##styleDictName"];
styleKindName: ATOM ~ TJaM.AtomFromRope["##styleKindName"];
InitDict: PUBLIC PROC [name: ATOM, size: CARDINAL ← 100]
RETURNS [dictionary: TJaM.Dict] ~ {
found: BOOL;
d: Object;
[found, d] ← TJaM.TryToGet[sysdict, name];
IF found THEN dictionary ← TypeCheckDict[d]
ELSE {
dictionary ← TJaM.NewDict[size];
TJaM.Put[sysdict, name, dictionary];
}
};
kindNames: REF ARRAY OfStyle OF ATOMNEW[ARRAY OfStyle OF ATOM ← [
$screen, $print, $base]];
styleRuleDictNames: REF ARRAY OfStyle OF ATOM ~ NEW[ARRAY OfStyle OF ATOM ← [
TJaM.AtomFromRope["##BaseStyleRuleDictName"],
TJaM.AtomFromRope["##ScreenStyleRuleDictName"],
TJaM.AtomFromRope["##PrintStyleRuleDictName"]
]];
styleDictNames: REF ARRAY OfStyle OF ATOM ~ NEW[ARRAY OfStyle OF ATOM ←[
TJaM.AtomFromRope["##BaseStyleDictName"],
TJaM.AtomFromRope["##ScreenStyleDictName"],
TJaM.AtomFromRope["##PrintStyleDictName"]
]];
StartOfStyle: SIGNAL ~ CODE; -- raised to indicate start of loading style
EndOfStyle: SIGNAL ~ CODE; -- raised to indicate successful loading
WhatStyle: SIGNAL RETURNS [ATOM] ~ CODE; -- raised to find name of style being loaded
BeginStyleOp: TJaM.CommandProc ~ {
name: ATOM ← ForceLowerName[SIGNAL WhatStyle]; -- get style name from RunStyle
screenDict, printDict, baseDict: TJaM.Dict;
ResetDict: PROC [dict: TJaM.Dict] ~ {
TJaM.ClrDict[dict];
TJaM.DetachAll[dict];
};
MakeDict: PROC [kind: OfStyle] RETURNS [dict: TJaM.Dict] ~ {
dict ← CreateStyleDict[];
EnterStyleDict[name, dict, kind];
};
SetupDict: PROC [dict: TJaM.Dict, kind: OfStyle] ~ {
TJaM.Put[baseDict, styleRuleDictNames[kind], TJaM.NewDict[50]];
create rule name dict in baseDict
TJaM.Put[dict, styleKindName, kindNames[kind]];
record the style kind
};
found: BOOL;
[baseDict, found] ← CheckStyleDict[name, base]; -- check if reloading
IF found THEN {
ResetDict[baseDict];
[printDict, ] ← CheckStyleDict[name, print];
ResetDict[printDict];
[screenDict, ] ← CheckStyleDict[name, screen];
ResetDict[screenDict];
NodeStyleOps.FlushCaches[] }
ELSE {
baseDict ← MakeDict[base];
screenDict ← MakeDict[screen];
printDict ← MakeDict[print] };
SetupDict[baseDict, base]; SetupDict[screenDict, screen]; SetupDict[printDict, print];
TJaM.AttachDict[screenDict, baseDict];
TJaM.AttachDict[printDict, baseDict];
TJaM.Put[baseDict, styleDictNames[screen], screenDict];
TJaM.Put[baseDict, styleDictNames[print], printDict];
TJaM.Put[baseDict, styleDictNames[base], baseDict];
TJaM.Put[baseDict, styleDictName, name];
TJaM.Begin[frame, baseDict];
TJaM.Push[frame, baseDict]; -- leave this around for EndStyleOp
SIGNAL StartOfStyle; -- caught by RunStyle
};
EndStyleOp: TJaM.CommandProc ~ {
d1, d2: TJaM.Dict;
d1 ← TJaM.DictTop[frame]; -- the current dictionary
d2 ← TJaM.PopDict[frame]; -- pushed by StyleOp
IF d1 # d2 THEN {
TJaM.PushRope[frame, "mismatched Style and EndStyle commands"];
StyleError[frame, 1];
}
ELSE { -- change attachments so look in own basicDict before any attached dicts
name: ATOMSIGNAL WhatStyle;
screenDict: TJaM.Dict ~ CheckStyleDict[name, screen].d;
printDict: TJaM.Dict ~ CheckStyleDict[name, print].d;
TJaM.DetachDict[screenDict, d1];
TJaM.DetachDict[printDict, d1];
TJaM.AttachDict[screenDict, d1];
TJaM.AttachDict[printDict, d1];
TJaM.End[frame];
};
SIGNAL EndOfStyle; -- caught by RunStyle
};
StyleNameOp: TJaM.CommandProc ~ { -- expects style dictionary on op stack
TJaM.Push[frame, TJaM.Load[frame, styleDictName]]
};
StyleRuleOp: TJaM.CommandProc ~ { DefineStyleRule[frame, base] };
PrintRuleOp: TJaM.CommandProc ~ { DefineStyleRule[frame, print] };
ScreenRuleOp: TJaM.CommandProc ~ { DefineStyleRule[frame, screen] };
DefineStyleRule: PROC [frame: Frame, kind: OfStyle] ~ {
expects <name> <comment> <definition> on op stack
definition: Object ← TJaM.Pop[frame];
comment: Object ← TJaM.Pop[frame];
styleRule: ATOM ← PopName[frame];
name: ATOM ← ForceLowerName[styleRule];
dict: TJaM.Dict ← LoadStyleDict[frame, kind];
WITH definition SELECT FROM
x: TJaM.Array => TJaM.ABind[x, bindingDict];
ENDCASE; -- def may be a string
definition ← TJaM.CvX[definition];
TJaM.Put[dict, name, definition]; -- save the definition
IF name # styleRule THEN TJaM.Put[dict, styleRule, definition];
TJaM.Put[LoadStyleRuleDict[frame, kind], name, comment]; -- save the comment in the rule name dict
};
LoadStyleDict: PROC [frame: Frame, kind: OfStyle] RETURNS [TJaM.Dict] ~ {
RETURN [TypeCheckDict[TJaM.Load[frame, styleDictNames[kind]]]];
};
LoadStyleRuleDict: PROC [frame: Frame, kind: OfStyle] RETURNS [TJaM.Dict] ~ {
RETURN [TypeCheckDict[TJaM.Load[frame, styleRuleDictNames[kind]]]];
};
OpenPrintStyleOp: TJaM.CommandProc ~ { -- expects style name on op stack
OpenStyle[frame, print];
};
OpenScreenStyleOp: TJaM.CommandProc ~ { -- expects style name on op stack
OpenStyle[frame, screen];
};
OpenStyle: PROC [frame: Frame, kind: OfStyle] ~ {
name: ATOM ← PopName[frame];
IF NOT NodeStyleOps.LoadStyle[name] THEN RETURN;
WHILE TJaM.DictTop[frame] # sysdict DO TJaM.End[frame]; ENDLOOP;
TJaM.Begin[frame, styledict];
TJaM.Begin[frame, GetStyleDict[frame, name, kind]];
};
ResetTestStyleOp: TJaM.CommandProc ~ {
IF debugStyle=NIL THEN debugStyle ← NodeStyleOps.Create[];
debugStyle^ ← NodeStyleOps.defaultStyle^;
};
StyleRuleDictOp: TJaM.CommandProc ~ { GetRuleDict[frame, base] };
PrintRuleDictOp: TJaM.CommandProc ~ { GetRuleDict[frame, print] };
ScreenRuleDictOp: TJaM.CommandProc ~ { GetRuleDict[frame, screen] };
GetRuleDict: PROC [frame: Frame, kind: OfStyle] ~ {
TJaM.Push[frame, styleRuleDictNames[kind]];
TJaM.Execute[frame, get];
};
AttachStyleOp: TJaM.CommandProc ~ { -- expects opstk to contain style name as a rope
name: ATOM ← ForceLowerName[PopName[frame]];
found: BOOL;
printDict, screenDict: TJaM.Dict;
array: TJaM.Array;
styleName: ATOMSIGNAL WhatStyle;
val: Object;
[printDict, found] ← CheckStyleDict[name, print];
IF NOT found THEN {
IF RunStyle[frame, name] THEN [printDict, found] ← CheckStyleDict[name, print];
IF NOT found THEN {
BadStyleFile[frame, name];
RETURN;
};
};
[screenDict, found] ← CheckStyleDict[name, screen];
IF ~found THEN ERROR;
TJaM.AttachDict[LoadStyleDict[frame, screen], screenDict];
TJaM.AttachDict[LoadStyleDict[frame, print], printDict];
[found, val] ← TJaM.TryToGet[attachmentsDict, styleName];
IF NOT found THEN array ← TJaM.NewArray[1] -- this is the first attachment
ELSE { -- add new item to the array
WITH val SELECT FROM
x: TJaM.Array => array ← x;
ENDCASE => ERROR;
array ← TJaM.ACopy[array, 1];
};
TJaM.APut[array, array.len-1, name];
TJaM.Put[attachmentsDict, styleName, array];
};
ForEachAttachedStyle: PUBLIC PROC [dictName: ATOM, proc: PROC [attached: ATOM]
RETURNS [stop: BOOL]] ~ {
val: Object;
array: TJaM.Array;
found: BOOL;
dictName ← ForceLowerName[dictName];
[found, val] ← TJaM.TryToGet[attachmentsDict, dictName];
IF NOT found THEN RETURN;
WITH val SELECT FROM
x: TJaM.Array => array ← x;
ENDCASE => ERROR;
FOR i: CARDINAL IN [0..array.len) DO
IF proc[TypeCheckName[TJaM.AGet[array, i]]] THEN RETURN;
ENDLOOP;
};
Execute Styles
ExecuteObject: PROC [frame: Frame, object: Object] RETURNS [ok: BOOLTRUE] ~ {
Utility routine; ensures same stack depth after execution; does NOT handle TJaM.Stop
initDepth, finalDepth: INT;
initDepth ← TJaM.CountStack[frame];
TJaM.Execute[frame, object];
finalDepth ← TJaM.CountStack[frame];
IF finalDepth # initDepth THEN {
TJaM.PushRope[frame, "Failed to leave stack at same depth after execution.\n"];
TJaM.Push[frame, object];
StyleError[frame, 2];
ok ← FALSE;
};
};
ExecuteName: PUBLIC PROC [frame: Frame, name: ATOM] RETURNS [ok: BOOL] ~ {
makes sure that same stack depth after execute
oldName: ATOM ← executingName;
[ok, ] ← TJaM.TryToLoad[frame, name];
executingName ← name;
IF ok THEN ok ← ExecuteObject[frame, name ! TJaM.Stop => {ok ← FALSE; CONTINUE}];
executingName ← oldName;
};
ExecuteNameInStyle: PUBLIC PROC [ref: Style, kind: OfStyle, styleRule: ATOM]
RETURNS [ok: BOOL] ~ {
makes sure that same stack depth after execute
styleName: ATOM ← ref.name[style];
frame: Frame ← GetFrame[ref, styleName, kind];
ok ← ExecuteName[frame, styleRule];
FreeFrame[frame, styleName, kind];
frame ← NIL;
ref.font ← NIL;
};
ExecuteObjectInStyle: PUBLIC PROC [ref: Style, kind: OfStyle, object: Object]
RETURNS [ok: BOOLTRUE] ~ {
makes sure that same stack depth after execute
styleName: ATOM ← ref.name[style];
frame: Frame ← GetFrame[ref, styleName, kind];
{
ENABLE TJaM.Stop => GO TO stop;
ok ← ExecuteObject[frame, TJaM.CvX[object]];
EXITS stop => ok ← FALSE;
};
FreeFrame[frame, styleName, kind];
frame ← NIL;
ref.font ← NIL;
};
ExecuteLooksInStyle: PUBLIC PROC [ref: Style, kind: OfStyle, looks: TextLooks.Looks]
RETURNS [ok: BOOLTRUE] ~ {
makes sure that same stack depth after execute
styleName: ATOM ← ref.name[style];
frame: Frame ← GetFrame[ref, styleName, kind];
FOR c: CHAR IN TextLooks.Look DO
IF looks[c] THEN ok ← ExecuteName[frame, lookNames[c]]
ENDLOOP;
FreeFrame[frame, styleName, kind];
frame ← NIL;
ref.font ← NIL;
IF nodeStyleFonts THEN {
ref.font ← NodeStyleFont.FontFromStyleParams[prefix: ref.name[fontPrefix], family: ref.name[fontFamily], face: ref.fontFace, size: GetReal[ref, fontSize], alphabets: ref.fontAlphabets];
};
};
lookNames: REF LookNames ← NEW[LookNames];
LookNames: TYPE ~ ARRAY TextLooks.Look OF ATOM;
InitLookNames: PROC ~ {
names are "look.a", "look.b", "look.c", etc.
FOR c: CHAR IN TextLooks.Look DO
lookNames[c] ← TJaM.AtomFromRope[Rope.Concat["look.", Rope.FromChar[c]]];
ENDLOOP;
};
StyleError: PUBLIC PROC [frame: Frame, num: INTEGER] ~ {
TJaM.PushInt[frame, num];
TJaM.Execute[frame, $StyleError ! TJaM.Stop => CONTINUE];
};
Implementing Style Attribute Operations
DoStyleOp: PUBLIC PROC [frame: Frame, p: Param] ~ {
aName: BOOL;
name: ATOM;
style: Style ← StyleForFrame[frame];
Error: PROC ~ {
TJaM.Push[frame, p.opName];
TJaM.PushRope[frame, "illegal as qualifer for"];
TJaM.Push[frame, name];
StyleError[frame, 3];
};
[name, aName] ← TryToPopName[frame];
IF NOT aName THEN p.ops.Store[frame, p, style] -- e.g., "10 pt leading"
ELSE SELECT name FROM
$the => p.ops.Load[frame, p, style]; -- e.g., "the leading"
$bigger => {
[name, aName] ← TryToPopName[frame];
IF NOT aName THEN p.ops.AddReal[frame, TJaM.PopReal[frame], p, style]
-- e.g., "2 pt bigger leading"
ELSE IF name = $percent THEN p.ops.Percent[frame, 100+TJaM.PopReal[frame], p, style]
-- e.g., "2 percent bigger leading"
ELSE { Error[]; RETURN };
};
$smaller => {
[name, aName] ← TryToPopName[frame];
IF NOT aName THEN p.ops.AddReal[frame, -TJaM.PopReal[frame], p, style]
-- e.g., "2 pt smaller leading"
ELSE IF name = $percent THEN p.ops.Percent[frame, 100-TJaM.PopReal[frame], p, style]
-- e.g., "2 percent smaller leading"
ELSE { Error[]; RETURN };
};
$percent => p.ops.Percent[frame, TJaM.PopReal[frame], p, style];
ENDCASE => p.ops.SetName[frame, name, p, style]; -- e.g., "TimesRoman family"
};
General Error Routines
StoreError: PUBLIC StoreProc ~ {
ob: Object ← TJaM.Pop[frame];
TJaM.Push[frame, p.opName];
TJaM.PushRope[frame, "is not legal as value for"];
TJaM.Push[frame, ob];
StyleError[frame, 3];
};
AddRealError: PUBLIC AddRealProc ~ {
TJaM.Push[frame, p.opName];
TJaM.PushRope[frame, "Numbers are illegal as values for"];
StyleError[frame, 2];
};
PercentError: PUBLIC PercentProc ~ {
TJaM.Push[frame, p.opName];
TJaM.PushRope[frame, "Numbers are illegal as values for"];
StyleError[frame, 2];
};
SetNameError: PUBLIC SetNameProc ~ {
TJaM.Push[frame, p.opName];
TJaM.PushRope[frame, "Only numbers are legal as values for"];
StyleError[frame, 2];
};
Name Parameter Operations
nameOps: PUBLIC Ops ← NEW [OpsRec ←
[LoadNameParam, StoreError, AddRealError, PercentError, SetNameParam]];
LoadNameParam: PUBLIC LoadProc ~ {
x: REF ParamRec.name ~ NARROW[p];
TJaM.Push[frame, style.name[x.param]];
};
SetNameParam: PUBLIC SetNameProc ~ {
x: REF ParamRec.name ~ NARROW[p];
style.name[x.param] ← name;
};
NameError: PUBLIC PROC [frame: Frame, name: ATOM, p: Param] ~ {
TJaM.Push[frame, p.opName];
TJaM.PushRope[frame, "illegal as value for"];
TJaM.Push[frame, name];
StyleError[frame, 3];
};
Real Parameter Operations
realOps: PUBLIC Ops ← NEW [OpsRec ←
[RealOpLoad, RealOpSetReal, RealOpAddReal, RealOpPercent, SetNameError]];
RealOpLoad: PUBLIC LoadProc ~ {
x: REF ParamRec.real ~ NARROW[p];
TJaM.PushReal[frame, GetReal[style, x.param]];
};
RealOpSetReal: PUBLIC StoreProc ~ {
x: REF ParamRec.real ~ NARROW[p];
SetReal[style, x.param, TJaM.PopReal[frame]];
};
RealOpAddReal: PUBLIC AddRealProc ~ {
x: REF ParamRec.real ~ NARROW[p];
SetReal[style, x.param, GetReal[style, x.param]+inc];
};
RealOpPercent: PUBLIC PercentProc ~ {
x: REF ParamRec.real ~ NARROW[p];
SetReal[style, x.param, GetReal[style, x.param]*(percent/100)];
};
Glue Parameter Operations
glueOps: PUBLIC Ops ← NEW [OpsRec ←
[GlueOpLoad, GlueOpSetReal, GlueOpAddReal, GlueOpPercent, SetNameError]];
GlueOpLoad: PUBLIC LoadProc ~ {
Push: PROC [r: RealParam] ~ { TJaM.PushReal[frame, GetReal[style, r]] };
x: REF ParamRec.glue ~ NARROW[p];
Push[x.size]; Push[x.stretch]; Push[x.shrink];
};
GlueOpSetReal: PUBLIC StoreProc ~ {
Pop: PROC [r: RealParam] ~ { SetReal[style, r, TJaM.PopReal[frame]] };
x: REF ParamRec.glue ~ NARROW[p];
Pop[x.shrink]; Pop[x.stretch]; Pop[x.size];
};
GlueOpAddReal: PUBLIC AddRealProc ~ {
Add: PROC [r: RealParam] ~ { SetReal[style, r, GetReal[style, r]+inc] };
x: REF ParamRec.glue ~ NARROW[p];
Add[x.size]; Add[x.stretch]; Add[x.shrink];
};
GlueOpPercent: PUBLIC PercentProc ~ {
Pct: PROC [r: RealParam] ~ { SetReal[style, r, GetReal[style, r]*(percent/100)] };
x: REF ParamRec.glue ~ NARROW[p];
Pct[x.size]; Pct[x.stretch]; Pct[x.shrink];
};
Color Parameter Operations
colorOps: PUBLIC Ops ← NEW [OpsRec ←
[ColorOpLoad, ColorOpSetReal, ColorOpAddReal, ColorOpPercent, SetNameError]];
ColorOpLoad: PUBLIC LoadProc ~ {
Push: PROC [r: RealParam] ~ { TJaM.PushReal[frame, GetReal[style, r]] };
x: REF ParamRec.color ~ NARROW[p];
Push[x.hue]; Push[x.saturation]; Push[x.brightness];
};
ColorOpSetReal: PUBLIC StoreProc ~ {
Pop: PROC [r: RealParam] ~ { SetReal[style, r, TJaM.PopReal[frame]] };
x: REF ParamRec.color ~ NARROW[p];
Pop[x.brightness]; Pop[x.saturation]; Pop[x.hue];
};
ColorOpAddReal: PUBLIC AddRealProc ~ {
Add: PROC [r: RealParam] ~ { SetReal[style, r, GetReal[style, r]+inc] };
x: REF ParamRec.color ~ NARROW[p];
Add[x.hue]; Add[x.saturation]; Add[x.brightness];
};
ColorOpPercent: PUBLIC PercentProc ~ {
Pct: PROC [r: RealParam] ~ { SetReal[style, r, GetReal[style, r]*(percent/100)] };
x: REF ParamRec.color ~ NARROW[p];
Pct[x.hue]; Pct[x.saturation]; Pct[x.brightness];
};
Initialization
RegisterWorks1: PUBLIC PROC [frame: Frame] ~ {
InitLookNames[];
register the various style commands and JaM commands in this module
RegisterStyleCommand[frame, $BeginStyle, BeginStyleOp];
RegisterStyleCommand[frame, $EndStyle, EndStyleOp];
RegisterStyleCommand[frame, $StyleRule, StyleRuleOp];
RegisterStyleCommand[frame, $PrintRule, PrintRuleOp];
RegisterStyleCommand[frame, $ScreenRule, ScreenRuleOp];
RegisterStyleCommand[frame, $AttachStyle, AttachStyleOp];
TJaM.Register[frame, $StyleName, StyleNameOp];
TJaM.Register[frame, $OpenPrintStyle, OpenPrintStyleOp];
TJaM.Register[frame, $OpenScreenStyle, OpenScreenStyleOp];
TJaM.Register[frame, $ResetTestStyle, ResetTestStyleOp];
TJaM.Register[frame, $StyleRuleDict, StyleRuleDictOp];
TJaM.Register[frame, $PrintRuleDict, PrintRuleDictOp];
TJaM.Register[frame, $ScreenRuleDict, ScreenRuleDictOp];
};
END.
Rick Beach, November 25, 1985 1:01:05 pm PST
changes to: RunStyle to force style filenames to be in the root directory