DIRECTORY
Atom USING [GetPName, MakeAtom],
IO USING [PutFR],
NodeStyle USING [GetReal, RealParam, Ref, SetReal],
NodeStyleOps USING [Create, defaultStyleName, FlushCaches, OfStyle],
NodeStyleValidate USING [],
NodeStyleWorks USING [AddRealProc, ForceLowerName, LoadProc, Ops, OpsRec, Param, ParamRec, PercentProc, PopName, RegisterStyleCommand, run, SetNameProc, StoreProc, TryToPopName, TypeCheckDict, TypeCheckName, WhoIsExecuting],
PFS USING [AbsoluteName, Error, FileInfo, nullUniqueID, PATH, PathFromRope, RopeFromPath, UniqueID],
Process USING [GetCurrent],
RefTab USING [Create, Fetch, Pairs, Ref, Store],
Rope USING [Cat, Concat, Equal, FromChar, ROPE],
SimpleFeedback USING [Append, Blink],
Tioga USING [Look, Looks],
TJaM USING [ABind, ACopy, AGet, Any, APut, Array, AtomFromAny, AtomFromRope, AttachDict, Begin, ClrDict, CommandProc, CountStack, CvX, DetachAll, DetachDict, Dict, DictLength, DictTop, End, Execute, ExecuteAtom, Frame, Load, NewArray, NewDict, NewFrame, Object, Pop, PopDict, PopReal, Push, PushInt, PushReal, PushRope, Put, Register, RopeFromAtom, Stop, TryToGet, TryToLoad],
UserProfile USING [ListOfTokens];
Execution Frames for Style Machinery
ROPE: TYPE ~ Rope.ROPE;
Frame: TYPE ~ TJaM.Frame;
OfStyle: TYPE ~ NodeStyleOps.OfStyle;
Object: TYPE ~ TJaM.Object;
defaultFrame: PUBLIC Frame;
FrameInfo: TYPE ~ REF FrameInfoBody;
FrameInfoBody: TYPE ~ RECORD [ frame: Frame, style: Ref, rest: FrameInfo ];
GetFrame:
PUBLIC
PROC [style: Ref, 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] ~
INLINE {
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 ~
INLINE {
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: BOOL ¬ FALSE;
[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;
};
frame1, frame2, frame3, frame4: Frame ¬ NIL; -- small cache of active frames
frameAlloc: INT ¬ 0; -- number of frames allocated from TJaM
frameFree: INT ¬ 0; -- number of frames freed by TJaM
allocFrameCalls: INT ¬ 0; -- number of times called AllocFrame
freeFrameCalls: INT ¬ 0; -- number of times called FreeFrame. should = allocFrameCalls
style1, style2, style3, style4: Ref; -- style bodies associated with active frames 1,2,3,4
frameList: FrameInfo; -- chain of known frames beyond the small cache here
freeFrame1, freeFrame2, freeFrame3, freeFrame4: Frame ¬ NIL;
styleName1, styleName2, styleName3, styleName4: ATOM ¬ NIL;
styleKind1, styleKind2, styleKind3, styleKind4: OfStyle ¬ screen;
debugFlag: BOOL ¬ TRUE;
debugStyle: Ref;
StyleForFrame:
PUBLIC
PROC [frame: Frame]
RETURNS [style: Ref] ~ {
GetIt:
ENTRY
PROC
RETURNS [s: Ref] ~ {
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:
ROPE ¬
NIL]
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 (Cedar) AttachStyle EndStyle"
{
ENABLE {
WhatStyle => RESUME[styleName];
StartOfStyle => RESUME;
EndOfStyle => RESUME;
};
BeginStyleOp[frame, NIL];
IF styleName # NodeStyleOps.defaultStyleName
THEN {
TJaM.Push[frame, NodeStyleOps.defaultStyleName];
AttachStyleOp[frame, NIL];
};
EndStyleOp[frame, NIL];
};
[] ¬ RefTab.Store[fileForStyle, styleName, NEW [FileIDRep ¬ []]];
SimpleFeedback.Append[$Tioga, middle, $Error, " ... "];
SimpleFeedback.Append[$Tioga, middle, $Error, TJaM.RopeFromAtom[styleName]];
SimpleFeedback.Append[$Tioga, end, $Error, ".style could not be loaded. "];
SimpleFeedback.Blink[$Tioga, $Error];
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] ~
INLINE {
-- creates dict for style
RETURN [TJaM.NewDict[50]];
};
EnterStyleDict:
PROC [styleName:
ATOM, d: Object, kind: OfStyle] ~
INLINE {
TJaM.Put[stylesDicts[kind], styleName, d];
};
Style File handling.
Search rule handling
dirStyles: ROPE ~ "/cedar/styles";
defaultSearch:
LIST
OF
ROPE ¬
LIST[dirStyles];
FileID: TYPE ~ REF FileIDRep;
FileIDRep: TYPE ~ RECORD [name: ROPE ¬ NIL, uid: PFS.UniqueID];
Same:
PROC [a, b: FileID]
RETURNS [
BOOL] ~
INLINE {
RETURN [a.uid = b.uid 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];
fileNamePath: PFS.PATH ¬ NIL;
uid: PFS.UniqueID ¬ PFS.nullUniqueID;
WHILE fileNamePath =
NIL
AND dirs #
NIL
DO
[fullFName: fileNamePath, uniqueID: uid] ¬ PFS.FileInfo[name: PFS.AbsoluteName[short: PFS.PathFromRope[name], wDir: PFS.PathFromRope[dirs.first] ] ! PFS.Error => CONTINUE];
dirs ¬ dirs.rest;
ENDLOOP;
IF fileNamePath = NIL THEN RETURN [NIL];
RETURN [NEW[FileIDRep ¬ [PFS.RopeFromPath[fileNamePath], uid]]];
};
Locking to avoid concurrent changes to internal style representation.
styleLockProcess: UNSAFE PROCESS ¬ NIL;
styleLockCount: CARDINAL ¬ 0;
styleLockFree: CONDITION;
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.
fileForStyle: RefTab.Ref ~ RefTab.Create[5];
ValidateStyles:
PUBLIC
PROC
RETURNS [changed:
BOOL ¬
FALSE] ~ {
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:
BOOL ¬
FALSE] ~ {
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];
changed ¬ TRUE;
IF RunStyle[frame, styleName] THEN FreeFrame[frame, NIL, screen] ELSE BadStyleFile[frame, styleName];
};
};
DoLocked[Locked];
};
runNesting: CARDINAL ¬ 0; -- to decide whether to clear message window.
RunStyle:
PUBLIC
PROC [frame: Frame, styleName:
ATOM]
RETURNS [ok:
BOOL ¬
FALSE] ~ {
Inner:
PROC ~ {
started, finished: BOOL ¬ FALSE;
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};
SimpleFeedback.Append[$Tioga, IF runNesting=0 THEN begin ELSE middle, $Progress, "Using "];
SimpleFeedback.Append[$Tioga, middle, $Progress, fileID.name];
SimpleFeedback.Append[$Tioga, middle, $Progress, " . . . "];
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 SimpleFeedback.Append[$Tioga, middle, $Progress, "ok "];
IF ok THEN [] ¬ RefTab.Store[fileForStyle, styleName, fileID];
IF ok AND runNesting=0 THEN SimpleFeedback.Append[$Tioga, end, $Progress, ""];
};
DoLocked[Inner];
};
RunStyleString:
PUBLIC
PROC [frame: Frame, styleName:
ATOM, def:
ROPE]
RETURNS [ok:
BOOL] ~ {
started, finished: BOOL ¬ FALSE;
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];
};
sysdict: PUBLIC TJaM.Dict;
userdict: PUBLIC TJaM.Dict;
styledict: PUBLIC TJaM.Dict;
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];
}
};
bindingDictName: PUBLIC ATOM; -- removed by mfp November 19, 1987
attachmentsDictName: PUBLIC ATOM; -- removed by mfp November 19, 1987
styledictName: PUBLIC ATOM; -- removed by mfp November 19, 1987
bindingDict: PUBLIC TJaM.Dict;
attachmentsDict: PUBLIC TJaM.Dict;
kindNames: REF ARRAY OfStyle OF ATOM ¬ NEW[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"]
]];
stylesDictsNames: PUBLIC REF ARRAY OfStyle OF ATOM ← NEW[ARRAY OfStyle OF ATOM]; -- not used; removed by mfp November 19, 1987
is the following redundant? I think so, so I commented it out. RJB
stylesDictNames: PUBLIC REF ARRAY OfStyle OF ATOM ← NEW[ARRAY OfStyle OF ATOM];
stylesDicts: PUBLIC REF ARRAY OfStyle OF TJaM.Dict ¬ NEW[ARRAY OfStyle OF TJaM.Dict];
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] ~
INLINE {
TJaM.ClrDict[dict];
TJaM.DetachAll[dict];
};
MakeDict:
PROC [kind: OfStyle]
RETURNS [dict: TJaM.Dict] ~
INLINE {
dict ¬ CreateStyleDict[];
EnterStyleDict[name, dict, kind];
};
SetupDict:
PROC [dict: TJaM.Dict, kind: OfStyle] ~
INLINE {
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 ¬ NIL;
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: ATOM ¬ SIGNAL 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] };
PutNew:
PROC [frame: Frame, dict: TJaM.Dict, key:
ATOM, val: TJaM.Any] ~ {
IF RefTab.Fetch[dict.refTab, key].found
THEN {
TJaM.Push[frame, key];
TJaM.PushRope[frame, "is multiply defined"];
TJaM.PushInt[frame, 2];
TJaM.ExecuteAtom[frame, $ReportStyleError];
};
TJaM.Put[dict, key, val]; -- save the definition
};
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];
styleName: ATOM ¬ TJaM.AtomFromAny[TJaM.Load[frame, styleDictName]];
WITH definition
SELECT
FROM
x: TJaM.Array => TJaM.ABind[x, bindingDict];
ENDCASE; -- def may be a string
definition ¬ TJaM.CvX[definition];
PutNew[frame, dict, name, definition]; -- save the definition
IF name # styleRule THEN PutNew[frame, dict, styleRule, definition];
TJaM.Put[dict, Atom.MakeAtom[Rope.Cat[Atom.GetPName[styleName], ".", Atom.GetPName[name]]], definition]; -- save the 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: ATOM ¬ SIGNAL 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 NOT 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: array, expand: 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
scratchDict: TJaM.Dict ¬ NIL;
AllocProtectDict:
ENTRY
PROC
RETURNS [protectDict: TJaM.Dict] ~
INLINE {
ENABLE UNWIND => NULL;
protectDict ¬ scratchDict; scratchDict ¬ NIL;
IF protectDict =
NIL
THEN {
Illegal:
PROC [name:
ROPE, nArgs:
INT] ~ {
ob: TJaM.Any ~ TJaM.CvX[IO.PutFR["(%g command not allowed in style rules) %g StyleError", [rope[name]], [integer[nArgs+1]]]];
TJaM.Put[dict: protectDict, key: Atom.MakeAtom[name], val: ob];
};
protectDict ¬ TJaM.NewDict[];
Illegal[".store", 2];
Illegal["PrintRule", 3];
Illegal["ScreenRule", 3];
Illegal["StyleParam", 2];
Illegal["StyleRule", 3];
};
};
FreeProtectDict:
ENTRY
PROC [protectDict: TJaM.Dict] ~
INLINE {
scratchDict ¬ protectDict;
};
ExecuteObject:
PROC [frame: Frame, object: Object]
RETURNS [ok:
BOOL ¬
TRUE] ~ {
Utility routine; ensures same stack depth after execution; protects against defs; does NOT handle TJaM.Stop
initDepth: CARDINAL ¬ TJaM.CountStack[frame];
finalDepth: CARDINAL ¬ 0;
protectDict: TJaM.Dict ¬ AllocProtectDict[];
beforeSize: INT ~ TJaM.DictLength[protectDict];
TJaM.Begin[frame: frame, dict: protectDict];
TJaM.Execute[frame, object];
finalDepth ¬ TJaM.CountStack[frame];
IF finalDepth # initDepth
THEN {
TJaM.Push[frame, object];
TJaM.PushRope[frame, "Failed to leave stack at same depth after execution."];
StyleError[frame, 2];
ok ¬ FALSE;
};
IF TJaM.DictTop[frame] = protectDict
AND TJaM.DictLength[protectDict] = beforeSize
AND protectDict.attach =
NIL
THEN { TJaM.End[frame]; FreeProtectDict[protectDict] }
ELSE {
IF TJaM.DictTop[frame] = protectDict THEN TJaM.End[frame];
TJaM.Push[frame, object];
TJaM.PushRope[frame, "Illegally modified dictionary."];
StyleError[frame, 2];
ok ¬ FALSE;
};
ExecuteName:
PUBLIC
PROC [frame: Frame, name:
ATOM]
RETURNS [ok:
BOOL ¬
FALSE] ~ {
makes sure that same stack depth after execute
ok ¬ ExecuteObject[frame, name !
TJaM.Stop => {ok ¬ FALSE; CONTINUE};
NodeStyleWorks.WhoIsExecuting => {RESUME[name]};
];
ExecuteNameInStyle:
PUBLIC
PROC [ref: Ref, kind: OfStyle, styleRule:
ATOM]
RETURNS [ok:
BOOL ¬
FALSE] ~ {
makes sure that same stack depth after execute
styleName: ATOM ¬ ref.name[style];
frame: Frame ¬ GetFrame[ref, styleName, kind];
IF
NOT TJaM.TryToLoad[frame, styleRule].found
THEN {
FreeFrame[frame, styleName, kind]; frame ¬ NIL;
RETURN [ok: FALSE];
};
ok ¬ ExecuteName[frame, styleRule];
IF ok THEN FreeFrame[frame, styleName, kind];
frame ¬ NIL;
ExecuteObjectInStyle:
PUBLIC
PROC [ref: Ref, kind: OfStyle, object: Object]
RETURNS [ok:
BOOL ¬
TRUE] ~ {
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;
};
IF ok THEN FreeFrame[frame, styleName, kind];
frame ¬ NIL;
ExecuteLooksInStyle:
PUBLIC
PROC [ref: Ref, kind: OfStyle, looks: Tioga.Looks]
RETURNS [ok:
BOOL ¬
TRUE] ~ {
makes sure that same stack depth after execute
styleName: ATOM ¬ ref.name[style];
frame: Frame ¬ GetFrame[ref, styleName, kind];
FOR c:
CHAR
IN Tioga.Look
DO
IF looks[c] AND TJaM.TryToLoad[frame, lookNames[c]].found THEN ok ¬ ExecuteName[frame, lookNames[c]] AND ok
ENDLOOP;
IF ok THEN FreeFrame[frame, styleName, kind];
frame ¬ NIL;
LookNames: TYPE ~ ARRAY Tioga.Look OF ATOM;
lookNames:
REF LookNames ¬ InitLookNames[];
InitLookNames:
PROC
RETURNS [names:
REF LookNames] ~
--gfi saver--
INLINE {
names are "look.a", "look.b", "look.c", etc.
names ¬ NEW[LookNames];
FOR c:
CHAR
IN Tioga.Look
DO
names[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];
};