NodeStyleExtraImpl.mesa
Copyright © 1985 by Xerox Corporation. All rights reserved.
Written by Bill Paxton, January 1981
Paxton, June 3, 1983 3:35 pm
Maxwell, January 6, 1983 10:05 am
Russ Atkinson, March 7, 1985 3:37:01 am PST
Paul Rovner, August 10, 1983 4:43 pm
Plass, March 1, 1985 4:34:45 pm PST
Doug Wyatt, March 5, 1985 10:51:57 am PST
DIRECTORY
Ascii,
Atom,
Convert,
TJaMBasic,
TJaMOps,
TJaMVM,
MessageWindow,
NameSymbolTable,
NodeProps,
NodeStyle,
NodeStyleExtra,
NodeStyleObject,
NodeStyleStart,
Process,
Rope,
TextLooks,
UserProfile;
NodeStyleExtraImpl: MONITOR
IMPORTS Ascii, Atom, Convert, TJaMOps, TJaMVM, Process, Rope, MessageWindow, NodeProps, NodeStyle, NodeStyleExtra, NameSymbolTable
EXPORTS NodeStyle, NodeStyleExtra, NodeStyleObject, NodeStyleStart
= BEGIN OPEN NodeStyle, NodeStyleExtra;
-- Styles, StyleNames, and Frames
FrameInfo: TYPE = REF FrameInfoBody;
FrameInfoBody: TYPE = RECORD [ frame: Frame, style: Ref, rest: FrameInfo ];
defaultStyleRope: Rope.Text;
defaultStyleName: PUBLIC Name;
defaultStylesForExtensions: PUBLIC LIST OF ExtObjPair;
SetDefaultStyle: PUBLIC SAFE PROC [name: Rope.ROPE] = TRUSTED {
defaultStyleRope ← Rope.Flatten[name];
defaultStyleName ← ForceLower[MakeName[
LOOPHOLE[defaultStyleRope, REF READONLY TEXT]]];
defaultStyle.name[style] ← defaultStyleName;
FlushCaches[];
};
SetExtensionStyles: PUBLIC SAFE PROC [value: LIST OF Rope.ROPE] = TRUSTED {
ForceRopeLower: PROC [r: Rope.ROPE] RETURNS [Rope.ROPE] = TRUSTED {
ForceCharLower: SAFE PROC [old: CHAR] RETURNS [new: CHAR] = TRUSTED {
RETURN [Ascii.Lower[old]] };
RETURN [Rope.Translate[base: r, translator: ForceCharLower]] };
defaultStylesForExtensions ← NIL;
UNTIL value=NIL OR value.rest=NIL DO
ext: ATOM ← Atom.MakeAtom[ForceRopeLower[value.first]]; -- the extension
styleObject: NameSymbolTable.Object ←
NameSymbolTable.MakeObject[LOOPHOLE[Rope.Flatten[
Rope.Cat["\"", ForceRopeLower[value.rest.first], "\" style"]]]];
defaultStylesForExtensions ← CONS[[ext, styleObject], defaultStylesForExtensions];
value ← value.rest.rest;
ENDLOOP;
FlushCaches[];
};
GetFrame: PUBLIC SAFE PROC [style: Ref, styleName: Name, kind: OfStyle]
RETURNS [frame: Frame] = TRUSTED {
-- 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 one bombs during load
found: BOOL;
AllocFrame: ENTRY PROC [name: Name, kind: OfStyle] = {
ENABLE UNWIND => NULL;
allocFrameCalls ← allocFrameCalls+1;
IF name # NameSymbolTable.nullName 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 ← TJaMOps.NewFrame[]; frameAlloc ← frameAlloc+1;
TJaMOps.Begin[frame,sysdict];
TJaMOps.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 # NameSymbolTable.nullName THEN {
-- get the proper style dictionary on the frame dictionary stack
styleNameObj: Object;
done: BOOL ← FALSE;
[found,styleNameObj] ← TJaMOps.TryToLoad[frame,NameToObject[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] ← TJaMOps.TryToLoad[frame,NameToObject[styleKindName]];
IF found AND TypeCheckName[kindNameObj]=kindNames[kind] THEN
done ← TRUE }; -- already there
IF ~done THEN -- get rid of top dictionary
WHILE TJaMOps.TopDict[frame.dictstk] # styledict DO
TJaMOps.End[frame]; ENDLOOP };
IF ~done THEN TJaMOps.Begin[frame,GetStyleDict[frame,styleName,kind]] }
ELSE WHILE TJaMOps.TopDict[frame.dictstk] # styledict DO TJaMOps.End[frame]; ENDLOOP;
SaveStyleInfo[];
};
-- info about active frames
frame1, frame2, frame3, frame4: Frame ← NIL;
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;
frameList: FrameInfo;
debugFlag: BOOL ← TRUE;
debugStyle: Ref;
StyleForFrame: PUBLIC SAFE PROC [frame: Frame] RETURNS [style: Ref] = TRUSTED {
GetIt: ENTRY PROC RETURNS [s: Ref] = INLINE {
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 ← Create[];
RETURN [debugStyle] };
ERROR };
RETURN [style];
};
-- info about free frames
freeFrame1, freeFrame2, freeFrame3, freeFrame4: Frame ← NIL;
styleName1, styleName2, styleName3, styleName4: Name ← NameSymbolTable.nullName;
styleKind1, styleKind2, styleKind3, styleKind4: OfStyle ← screen;
FreeFrame: PUBLIC ENTRY SAFE PROC [frame: Frame, name: Name, kind: OfStyle] = TRUSTED {
-- 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 ← name; styleKind1 ← kind }
ELSE IF freeFrame2 = NIL THEN {
freeFrame2 ← frame; styleName2 ← name; styleKind2 ← kind }
ELSE IF freeFrame3 = NIL THEN {
freeFrame3 ← frame; styleName3 ← name; styleKind3 ← kind }
ELSE IF freeFrame4 = NIL THEN {
freeFrame4 ← frame; styleName4 ← name; styleKind4 ← kind }
ELSE { frameFree ← frameFree+1; TJaMOps.FreeFrame[frame] }; -- really free 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;
};
-- Local styles
number: INT ← 0;
ReadSpecsProc: SAFE PROC
[name: ATOM, specs: Rope.ROPE] RETURNS [value: REF] = TRUSTED {
GenLocalName: ENTRY PROC RETURNS [gen: Rope.ROPE] = {
number ← number + 1;
gen ← Rope.Concat["LocalStyle-", Convert.RopeFromInt[number]];
};
localStyle: LocalStyle ← NEW[LocalStyleRec];
localStyleName: Rope.ROPE = GenLocalName[];
localStyle.name ← NameSymbolTable.MakeNameFromRope[localStyleName];
localStyle.def ← specs;
[] ← DefineStyle[localStyle.name, specs];
RETURN [localStyle];
};
WriteSpecsProc: SAFE PROC
[name: ATOM, value: REF] RETURNS [specs: Rope.ROPE] = TRUSTED {
localStyle: LocalStyle ← NARROW[value];
RETURN [IF localStyle=NIL THEN NIL ELSE localStyle.def];
};
CopyInfoProc: SAFE PROC [name: ATOM, value: REF] RETURNS [new: REF] =
TRUSTED { RETURN [value] };
-- Load style procedures
LoadStyle: PUBLIC SAFE PROC [name: Name] RETURNS [ok: BOOL] = TRUSTED {
frame: Frame ← GetFrame[NIL,NameSymbolTable.nullName,screen];
[] ← GetStyleDict[frame,name,screen];
FreeFrame[frame,NameSymbolTable.nullName,screen];
RETURN [TRUE];
};
DefineStyle: PUBLIC SAFE PROC
[name: Name, def: Rope.ROPE] RETURNS [ok: BOOL] = TRUSTED {
frame: Frame ← GetFrame[NIL,NameSymbolTable.nullName,screen];
IF def=NIL THEN BadStyleFile[frame,name]
ELSE [] ← GetStyleDict[frame,name,screen,def];
FreeFrame[frame,NameSymbolTable.nullName,screen];
RETURN [TRUE];
};
ReloadStyle: PUBLIC SAFE PROC [name: Name] RETURNS [ok: BOOL] = TRUSTED {
frame: Frame ← GetFrame[NIL,NameSymbolTable.nullName,screen];
name ← ForceLower[name];
ok ← RunStyle[frame,name];
IF ~ok THEN BadStyleFile[frame,name];
FreeFrame[frame,NameSymbolTable.nullName,screen ];
};
GetStyleDict: PROC [frame: Frame, name: Name, kind: OfStyle, def: Rope.ROPE ← NIL]
RETURNS [d: dict Object] = {
found, ok: BOOL;
name ← ForceLower[name];
[d, found] ← CheckStyleDict[name,kind];
IF found THEN RETURN;
ok ← IF def # NIL THEN RunStyleString[frame,name,def] ELSE RunStyle[frame,name];
IF ok THEN [d,found] ← CheckStyleDict[name,kind];
IF ~found THEN {
BadStyleFile[frame,name];
[d, found] ← CheckStyleDict[name,kind];
};
};
BadStyleFile: PROC [frame: Frame, name: Name] = {
-- fake it so looks as if had a file saying BeginStyle (default) AttachStyle EndStyle
{
ENABLE {
WhatStyle => { styleName ← name; RESUME };
StartOfStyle => RESUME;
EndOfStyle => RESUME;
};
BeginStyleOp[frame];
IF name # defaultStyleName THEN {
PushName[frame,defaultStyleName]; AttachStyleOp[frame];
};
EndStyleOp[frame];
};
Process.Detach[FORK BadStyleMessage[name]];
PushName[frame,name];
PushText[frame,"style was bad."L];
StyleError[frame,2];
};
BadStyleMessage: PROC [name: Name] = {
-- need to fork this so to avoid monitor deadlock in viewers
MessageWindow.Append[NameSymbolTable.RopeFromName[name],TRUE];
MessageWindow.Append[".style could not be loaded."];
};
CreateStyleDict: PROC RETURNS [d: dict Object] = { -- creates dict for style
RETURN [TJaMOps.Dict[50]];
};
EnterStyleDict: PROC [name: Name, d: Object, kind: OfStyle] = INLINE {
TJaMOps.Put[stylesDicts[kind],NameToObject[name],d];
};
CheckStyleDict: PROC [name: Name, kind: OfStyle] RETURNS [d: dict Object, found: BOOL] = {
obj: Object;
[found,obj] ← TJaMOps.TryToGet[stylesDicts[kind],NameToObject[name]];
IF found THEN d ← TypeCheckDict[obj];
};
RunStyle: PROC [frame: Frame, name: Name] RETURNS [ok: BOOL] = {
txt: REF TEXT ← NEW[TEXT[64]];
ext: STRING = ".style";
txtlen: NAT;
hasExt, started, finished: BOOL ← FALSE;
NameSymbolTable.FromName[name,txt];
txtlen ← txt.length;
FOR i:NAT IN [0..txtlen) DO -- see if has an extension already
IF txt[i] = '. THEN { hasExt ← TRUE; EXIT }; ENDLOOP;
FOR i:NAT IN [0..ext.length) DO txt[txtlen+i] ← ext[i]; ENDLOOP;
txt.length ← txtlen+ext.length;
PushText[frame,LOOPHOLE[txt,LONG STRING]];
TJaMOps.Put[attachmentsDict, NameToObject[name], TJaMOps.Array[0]];
TJaMOps.Execute[frame, run !
WhatStyle => { styleName ← name; RESUME };
StartOfStyle => { started ← TRUE; RESUME };
EndOfStyle => { finished ← TRUE; RESUME };
];
RETURN [started AND finished];
};
RunStyleString: PROC [frame: Frame, name: Name, def: Rope.ROPE]
RETURNS [ok: BOOL] = {
started, finished: BOOL ← FALSE;
TJaMOps.Put[attachmentsDict, NameToObject[name], TJaMOps.Array[0]];
TJaMOps.Execute[frame,
CVX[TJaMOps.MakeString[LOOPHOLE[Rope.Flatten[def],LONG STRING]]] !
WhatStyle => { styleName ← name; RESUME };
StartOfStyle => { started ← TRUE; RESUME };
EndOfStyle => { finished ← TRUE; RESUME };
];
RETURN [started AND finished];
};
-- Registered commands
styleDictName: Name = MakeName["##styleDictName"];
styleKindName: Name = MakeName["##styleKindName"];
StartOfStyle: SIGNAL = CODE; -- raised to indicate start of loading style
EndOfStyle: SIGNAL = CODE; -- raised to indicate successful loading
WhatStyle: SIGNAL RETURNS [styleName: Name] = CODE; -- raised to find name of style being loaded
ForceLower: PROC [n: Name] RETURNS [Name] = { OPEN TJaMBasic;
nameObj: Object = NameToObject[n];
name: name Object = WITH x:nameObj SELECT FROM name => x, ENDCASE => ERROR;
str: string Object = TJaMOps.NameToString[name];
force: PROC [c: CHAR] RETURNS [stop: BOOL] = {
string[i] ← IF c IN ['A..'Z] THEN c-'A+'a ELSE c;
i ← i+1;
RETURN [FALSE] };
string: STRING ← [100];
i: CARDINAL ← 0;
TJaMOps.StringForAll[str, force];
string.length ← i;
RETURN [TypeCheckName[TJaMOps.MakeName[string,name.tag]]];
};
BeginStyleOp: PROC [frame: Frame] = {
name: Name ← ForceLower[SIGNAL WhatStyle]; -- get style name from RunStyle
screenDict, printDict, baseDict: dict Object;
ResetDict: PROC [dict: dict Object] = { TJaMOps.ClrDict[dict]; TJaMOps.DetachAll[dict] };
MakeDict: PROC [kind: OfStyle] RETURNS [dict: dict Object] = {
dict ← CreateStyleDict[]; EnterStyleDict[name,dict,kind] };
InitDict: PROC [dict: dict Object, kind: OfStyle] = {
TJaMOps.Put[baseDict,NameToObject[styleRuleDictNames[kind]],TJaMOps.Dict[50]];
-- create rule name dict in baseDict
TJaMOps.Put[dict,NameToObject[styleKindName],NameToObject[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];
FlushCaches[] }
ELSE {
baseDict ← MakeDict[base];
screenDict ← MakeDict[screen];
printDict ← MakeDict[print] };
InitDict[baseDict,base]; InitDict[screenDict,screen]; InitDict[printDict,print];
TJaMOps.AttachDict[screenDict,baseDict];
TJaMOps.AttachDict[printDict,baseDict];
TJaMOps.Put[baseDict,NameToObject[styleDictNames[screen]],screenDict];
TJaMOps.Put[baseDict,NameToObject[styleDictNames[print]],printDict];
TJaMOps.Put[baseDict,NameToObject[styleDictNames[base]],baseDict];
TJaMOps.Put[baseDict,NameToObject[styleDictName],NameToObject[name]];
TJaMOps.Begin[frame,baseDict];
PushObject[frame,baseDict]; -- leave this around for EndStyleOp
SIGNAL StartOfStyle; -- caught by RunStyle
};
StyleName: PROC [frame: Frame] = { -- expects style dictionary on op stack
PushObject[frame,TJaMOps.Load[frame,NameToObject[styleDictName]]]
};
EndStyleOp: PROC [frame: Frame] = {
d1, d2: dict Object;
d1 ← TJaMOps.TopDict[frame.dictstk]; -- the current dictionary
d2 ← TJaMOps.PopDict[frame.opstk]; -- pushed by StyleOp
IF d1 # d2 THEN {
PushText[frame,"mismatched Style and EndStyle commands"L];
StyleError[frame,1] }
ELSE { -- change attachments so look in own basicDict before any attached dicts
name: Name ← SIGNAL WhatStyle;
screenDict: dict Object = CheckStyleDict[name,screen].d;
printDict: dict Object = CheckStyleDict[name,print].d;
TJaMOps.DetachDict[screenDict,d1];
TJaMOps.DetachDict[printDict,d1];
TJaMOps.AttachDict[screenDict,d1];
TJaMOps.AttachDict[printDict,d1];
TJaMOps.End[frame] };
SIGNAL EndOfStyle; -- caught by RunStyle
};
styleRuleDictNames: REF ARRAY OfStyle OF Name = NEW[ARRAY OfStyle OF Name];
styleDictNames: REF ARRAY OfStyle OF Name = NEW[ARRAY OfStyle OF Name];
StyleRuleOp: PROC [frame: Frame] = { DefineStyleRule[frame,base] };
PrintRuleOp: PROC [frame: Frame] = { DefineStyleRule[frame,print] };
ScreenRuleOp: PROC [frame: Frame] = { DefineStyleRule[frame,screen] };
DefineStyleRule: PROC [frame: Frame, kind: OfStyle] = {
expects <name> <comment> <definition> on op stack
definition: Object ← PopObject[frame];
comment: Object ← PopObject[frame];
STKname: Name ← PopName[frame];
name: Name ← ForceLower[STKname];
nameObj: Object ← NameToObject[name];
dict: dict Object ← LoadStyleDict[frame,kind];
WITH x:definition SELECT FROM
array => TJaMOps.ABind[x,bindingDict];
ENDCASE; -- def may be a string
TJaMOps.Put[dict,nameObj,CVX[definition]]; -- save the definition
IF name#STKname THEN TJaMOps.Put[dict,NameToObject[STKname],CVX[definition]];
TJaMOps.Put[LoadStyleRuleDict[frame,kind],nameObj,comment]; -- save the comment in the rule name dict
};
LoadStyleDict: PROC [frame: Frame, kind: OfStyle] RETURNS [dict Object] = {
RETURN [TypeCheckDict[TJaMOps.Load[frame,NameToObject[styleDictNames[kind]]]]];
};
LoadStyleRuleDict: PROC [frame: Frame, kind: OfStyle] RETURNS [dict Object] = {
RETURN [TypeCheckDict[TJaMOps.Load[frame,NameToObject[styleRuleDictNames[kind]]]]];
};
OpenStyle: PROC [frame: Frame, kind: OfStyle] = {
name: Name ← PopName[frame];
IF ~LoadStyle[name] THEN RETURN;
WHILE TJaMOps.TopDict[frame.dictstk] # sysdict DO TJaMOps.End[frame]; ENDLOOP;
TJaMOps.Begin[frame,styledict];
TJaMOps.Begin[frame,GetStyleDict[frame,name,kind]];
};
OpenPrintStyleOp: PROC [frame: Frame] = { -- expects style name on op stack
OpenStyle[frame, print];
};
OpenScreenStyleOp: PROC [frame: Frame] = { -- expects style name on op stack
OpenStyle[frame, screen];
};
ResetTestStyle: PROC [frame: Frame] = {
IF debugStyle=NIL THEN debugStyle ← Create[];
debugStyle^ ← defaultStyle^;
};
StyleRuleDict: PROC [frame: Frame] = { GetRuleDict[frame,base] };
PrintRuleDict: PROC [frame: Frame] = { GetRuleDict[frame,print] };
ScreenRuleDict: PROC [frame: Frame] = { GetRuleDict[frame,screen] };
GetRuleDict: PROC [frame: Frame, kind: OfStyle] = {
PushName[frame,styleRuleDictNames[kind]];
TJaMOps.Execute[frame,get];
};
ForEachAttachedStyle: PUBLIC SAFE PROC [
dictName: Name, proc: PROC [attached: Name] RETURNS [stop: BOOL]] = TRUSTED {
val: Object;
array: array Object;
found: BOOL;
dictName ← ForceLower[dictName];
[found,val] ← TJaMOps.TryToGet[attachmentsDict, NameToObject[dictName]];
IF ~found THEN RETURN;
WITH val:val SELECT FROM
array => array ← val;
ENDCASE => ERROR;
FOR i: CARDINAL IN [0..array.length) DO
ob: Object ← TJaMVM.GetElem[array,i];
IF proc[TypeCheckName[ob]] THEN RETURN;
ENDLOOP;
};
AttachStyleOp: PROC [frame: Frame] = { -- expects opstk to contain style name
name: Name ← ForceLower[PopName[frame]];
found: BOOL;
printDict, screenDict: dict Object;
array: array Object;
styleName: Name ← SIGNAL WhatStyle;
val: Object;
[printDict,found] ← CheckStyleDict[name,print];
IF ~found THEN {
IF RunStyle[frame,name] THEN [printDict,found] ← CheckStyleDict[name,print];
IF ~found THEN {
BadStyleFile[frame,name];
RETURN }};
[screenDict,found] ← CheckStyleDict[name,screen];
IF ~found THEN ERROR;
TJaMOps.AttachDict[LoadStyleDict[frame,screen],screenDict];
TJaMOps.AttachDict[LoadStyleDict[frame,print],printDict];
[found,val] ← TJaMOps.TryToGet[attachmentsDict, NameToObject[styleName]];
IF ~found THEN array ← TJaMOps.Array[1] -- this is the first attachment
ELSE { -- add new item to the array
WITH val:val SELECT FROM
array => array ← val;
ENDCASE => ERROR;
array ← TJaMOps.ACopy[array,1] };
TJaMOps.APut[array,array.length-1,NameToObject[name]];
TJaMOps.Put[attachmentsDict, NameToObject[styleName], array];
};
ClearTabStopsOp: PROC [frame: Frame] = {
ref: Ref ← StyleForFrame[frame];
ref.tabStops ← NIL; ref.numTabStops ← 0;
};
-- support procs
PushText: PUBLIC SAFE PROC [frame: Frame, txt: LONG STRING] = TRUSTED {
TJaMOps.Push[frame.opstk,TJaMOps.MakeString[txt]];
};
PushObject: PUBLIC SAFE PROC [frame: Frame, ob: Object] = TRUSTED {
TJaMOps.Push[frame.opstk,ob];
};
PopObject: PUBLIC SAFE PROC [frame: Frame] RETURNS [Object] = TRUSTED {
RETURN[TJaMOps.Pop[frame.opstk]];
};
PushName: PUBLIC SAFE PROC [frame: Frame, name: Name] = TRUSTED {
TJaMOps.Push[frame.opstk,NameToObject[name]];
};
stringToNameCount: LONG INTEGER ← 0; -- for debugging
PopName: PUBLIC SAFE PROC [frame: Frame] RETURNS [Name] = TRUSTED {
obj: Object ← TJaMOps.Pop[frame.opstk];
WITH x:obj SELECT FROM
name => RETURN [LOOPHOLE[x.id]];
string => {
nameObj: name Object ← TJaMOps.StringToName[x];
stringToNameCount ← stringToNameCount+1;
RETURN [LOOPHOLE[nameObj.id]] };
ENDCASE => {
PushText[frame," -- found where expected a name"L];
PushObject[frame,obj];
StyleError[frame,2] };
ERROR;
};
TryToPopReal: PUBLIC SAFE PROC [frame: Frame] RETURNS [value: Real, ok: BOOL] = TRUSTED {
obj: Object;
IF frame.opstk.head = NIL THEN RETURN [0.0, FALSE];
obj ← TJaMOps.Top[frame.opstk];
WITH x:obj SELECT FROM
integer => { [] ← PopObject[frame]; RETURN [x.ivalue, TRUE] };
real => { [] ← PopObject[frame]; RETURN [x.rvalue, TRUE] };
ENDCASE => RETURN [0.0, FALSE];
};
TryToPopString: PUBLIC SAFE PROC [frame: Frame]
RETURNS [string: string TJaMBasic.Object, ok: BOOL] = TRUSTED {
obj: Object;
IF frame.opstk.head = NIL THEN { ok ← FALSE; RETURN };
obj ← TJaMOps.Top[frame.opstk];
WITH x:obj SELECT FROM
name => { [] ← PopObject[frame]; RETURN [TJaMOps.NameToString[x], TRUE] };
string => { [] ← PopObject[frame]; RETURN [x, TRUE] };
ENDCASE => ok ← FALSE;
};
TryToPopName: PUBLIC SAFE PROC [frame: Frame] RETURNS [name: Name, ok: BOOL] = TRUSTED {
obj: Object;
IF frame.opstk.head = NIL THEN RETURN [NameSymbolTable.nullName,FALSE];
obj ← TJaMOps.Top[frame.opstk];
WITH x:obj SELECT FROM
name => { [] ← PopObject[frame]; RETURN [LOOPHOLE[x.id],TRUE] };
string => {
nameObj: name Object ← TJaMOps.StringToName[x];
stringToNameCount ← stringToNameCount+1;
[] ← PopObject[frame];
RETURN [LOOPHOLE[nameObj.id],TRUE] };
ENDCASE => RETURN [NameSymbolTable.nullName,FALSE];
};
TypeCheckName: PUBLIC SAFE PROC [obj: Object] RETURNS [Name] = TRUSTED {
WITH x:obj SELECT FROM
name => RETURN [LOOPHOLE[x.id]];
string => {
nameObj: name Object ← TJaMOps.StringToName[x];
stringToNameCount ← stringToNameCount+1;
RETURN [LOOPHOLE[nameObj.id]] };
ENDCASE;
ERROR;
};
TypeCheckDict: PUBLIC SAFE PROC
[obj: Object] RETURNS [dict Object] = TRUSTED {
WITH x:obj SELECT FROM
dict => RETURN [x];
ENDCASE;
ERROR;
};
TypeCheckCommand: PUBLIC SAFE PROC
[obj: Object] RETURNS [command Object] = TRUSTED {
WITH x:obj SELECT FROM
command => RETURN [x];
ENDCASE;
ERROR;
};
-- Initialization
StyleCommand: PUBLIC SAFE PROC
[frame: Frame, text: REF READONLY TEXT, proc: PROC [Frame]]
RETURNS [name: Name]= TRUSTED {
name ← MakeName[text];
TJaMOps.RegisterExplicit[frame,LOOPHOLE[text,LONG STRING],proc];
-- add it to the binding dictionary
TJaMOps.Put[bindingDict,NameToObject[name],
CVX[TJaMOps.Load[frame,NameToObject[name]]]];
};
StyleLiteral: PUBLIC SAFE PROC
[frame: Frame, text: REF READONLY TEXT] RETURNS [name: Name] = TRUSTED {
name ← MakeName[text];
-- add it to the binding dictionary
TJaMOps.Put[bindingDict,NameToObject[name],CVLit[NameToObject[name]]];
-- add it to the current dictionary
TJaMOps.Def[frame,NameToObject[name],CVLit[NameToObject[name]]];
};
InitDict: PROC [txt: REF READONLY TEXT, size: CARDINAL ← 100]
RETURNS [name: Name, dictionary: dict Object] = {
found: BOOL;
d: Object;
name ← MakeName[txt];
[found,d] ← TJaMOps.TryToGet[sysdict,NameToObject[name]];
IF found THEN dictionary ← TypeCheckDict[d]
ELSE {
dictionary ← TJaMOps.Dict[size];
TJaMOps.Put[sysdict,NameToObject[name],dictionary];
}
};
bindingDictName, attachmentsDictName, styledictName: Name;
bindingDict, attachmentsDict: dict Object;
stylesDictsNames: REF ARRAY OfStyle OF Name ← NEW[ARRAY OfStyle OF Name];
stylesDictNames: REF ARRAY OfStyle OF Name ← NEW[ARRAY OfStyle OF Name];
stylesDicts: REF ARRAY OfStyle OF dict Object ← NEW[ARRAY OfStyle OF dict Object];
InitStylesDict: PROC = {
[stylesDictsNames[base], stylesDicts[base]] ← InitDict["TiogaBaseStylesDictionary"];
[stylesDictsNames[print], stylesDicts[print]] ← InitDict["TiogaPrintStylesDictionary"];
[stylesDictsNames[screen], stylesDicts[screen]] ← InitDict["TiogaScreenStylesDictionary"];
};
InitBindingDict: PROC = {
[bindingDictName, bindingDict] ← InitDict["TiogaBindingDictionary",200];
};
InitAttachmentsDict: PROC = {
[attachmentsDictName, attachmentsDict] ← InitDict["TiogaAttachedStylesDictionary"];
};
InitStyleDict: PROC = {
[styledictName, styledict] ← InitDict["TiogaStylesDictionary"];
TJaMOps.AttachDict[styledict,userdict];
};
RegCom: PROC [frame: Frame, txt: REF READONLY TEXT, proc: PROC[Frame]]
RETURNS [c: command Object] = {
TJaMOps.RegisterExplicit[frame,LOOPHOLE[txt,LONG STRING],proc];
c ← GetCommand[frame,MakeName[txt]];
};
sysdict, userdict, styledict: PUBLIC dict Object;
styleerror: PUBLIC Name;
GetCommand: PUBLIC SAFE PROC [frame: Frame, name: Name]
RETURNS [command Object] = TRUSTED {
flag: BOOL;
obj: Object;
[flag,obj] ← TJaMOps.TryToLoad[frame,NameToObject[name]];
IF ~flag THEN ERROR;
RETURN [TypeCheckCommand[obj]];
};
GetObject: PROC [frame: Frame, name: Name] RETURNS [ob: Object] = {
RETURN [TJaMOps.Load[frame,NameToObject[name]]];
};
ReportStyleError: PROC [frame: Frame] = {
num: CARDINAL ← TJaMOps.PopCardinal[frame.opstk];
string: string TJaMBasic.Object;
ok: BOOL;
MessageWindow.Clear[];
IF executingName # NameSymbolTable.nullName THEN {
PushText[frame,"style rule. "L];
PushName[frame,executingName];
PushText[frame,"Error in"L];
num ← num+3;
};
UNTIL num=0 DO
GetChar: SAFE PROC RETURNS [c: CHAR] = TRUSTED
{ c ← TJaMVM.GetChar[string, i]; i ← i+1 };
i: CARDINAL;
[string, ok] ← TryToPopString[frame];
IF ~ok THEN EXIT;
i ← 0;
MessageWindow.Append[Rope.FromProc[string.length, GetChar]];
num ← num-1;
IF num # 0 THEN MessageWindow.Append[" "];
ENDLOOP;
};
RunFile: PROC [frame: Frame, name: Name, dictname: LONG STRING]
RETURNS [BOOL] = {
known: BOOL;
[known,] ← TJaMOps.TryToLoad[frame,NameToObject[name]];
IF known THEN RETURN [FALSE];
PushText[frame,dictname];
TJaMOps.Execute[frame,run];
RETURN [TRUE];
};
load, get, run: PUBLIC command Object;
kindNames: REF ARRAY OfStyle OF Name ← NEW[ARRAY OfStyle OF Name];
startCount: CARDINAL ← 0;
StartExtra: PUBLIC SAFE PROC = TRUSTED {
frame, frame1, frame2, frame3, frame4: Frame ← NIL;
topDictName: Name;
IF (startCount ← startCount+1)>1 THEN RETURN;
frame ← TJaMOps.defaultFrame;
get ← GetCommand[frame,MakeName[".get"]];
run ← GetCommand[frame,MakeName[".run"]];
load ← GetCommand[frame,MakeName[".load"]];
sysdict ← TypeCheckDict[GetObject[frame,MakeName[".sysdict"]]];
-- check if have done (start.jam) .run
IF ~RunFile[frame,MakeName["user"],"start.jam"] THEN
TJaMOps.Execute[frame,CVX[NameToObject[MakeName[".start"]]]];
userdict ← TJaMOps.TopDict[frame.dictstk];
InitStyleDict[];
TJaMOps.End[frame]; -- replace userdict by styledict for rest of startup
TJaMOps.Begin[frame,styledict];
topDictName ← MakeName["topDictName"];
TJaMOps.Put[sysdict,NameToObject[topDictName],NameToObject[MakeName[".sysdict"]]];
TJaMOps.Put[userdict,NameToObject[topDictName],NameToObject[MakeName["userdict"]]];
TJaMOps.Put[styledict,NameToObject[topDictName],
NameToObject[MakeName["TiogaStylesDictionary"]]];
styleerror ← MakeName["StyleError"];
kindNames[screen] ← MakeName["screen"];
kindNames[print] ← MakeName["print"];
kindNames[base] ← MakeName["base"];
styleRuleDictNames[base] ← MakeName["##BaseStyleRuleDictName"];
styleRuleDictNames[screen] ← MakeName["##ScreenStyleRuleDictName"];
styleRuleDictNames[print] ← MakeName["##PrintStyleRuleDictName"];
styleDictNames[base] ← MakeName["##BaseStyleDictName"];
styleDictNames[screen] ← MakeName["##ScreenStyleDictName"];
styleDictNames[print] ← MakeName["##PrintStyleDictName"];
InitStylesDict[]; InitBindingDict[]; InitAttachmentsDict[];
-- check if have done (TiogaUtils.jam) .run
[] ← RunFile[frame,styleerror,"TiogaUtils.jam"];
[] ← RegCom[frame,"ReportStyleError",ReportStyleError];
[] ← RegCom[frame,"StyleName",StyleName];
[] ← RegCom[frame,"StyleRuleDict",StyleRuleDict];
[] ← RegCom[frame,"PrintRuleDict",PrintRuleDict];
[] ← RegCom[frame,"ScreenRuleDict",ScreenRuleDict];
[] ← RegCom[frame,"OpenPrintStyle",OpenPrintStyleOp];
[] ← RegCom[frame,"OpenScreenStyle",OpenScreenStyleOp];
[] ← RegCom[frame,"ResetTestStyle",ResetTestStyle];
[] ← StyleCommand[frame,"BeginStyle",BeginStyleOp];
[] ← StyleCommand[frame,"EndStyle",EndStyleOp];
[] ← StyleCommand[frame,"StyleRule",StyleRuleOp];
[] ← StyleCommand[frame,"PrintRule",PrintRuleOp];
[] ← StyleCommand[frame,"ScreenRule",ScreenRuleOp];
[] ← StyleCommand[frame,"AttachStyle",AttachStyleOp];
-- style commands for tabs
[] ← StyleCommand[frame,"clearTabStops",ClearTabStopsOp];
[] ← StyleCommand[frame,"tabStop",TabStopOp];
[] ← StyleCommand[frame,"defaultTabStops",DefaultTabStopsOp];
[] ← StyleCommand[frame,"tabStopLocations",RelativeTabStopsOp];
-- allocate and free some frames to initialize the cache
frame1 ← GetFrame[NIL, NameSymbolTable.nullName, screen];
frame2 ← GetFrame[NIL, NameSymbolTable.nullName, screen];
frame3 ← GetFrame[NIL, NameSymbolTable.nullName, screen];
frame4 ← GetFrame[NIL, NameSymbolTable.nullName, screen];
FreeFrame[frame1, NameSymbolTable.nullName, screen];
FreeFrame[frame2, NameSymbolTable.nullName, screen];
FreeFrame[frame3, NameSymbolTable.nullName, screen];
FreeFrame[frame4, NameSymbolTable.nullName, screen];
NodeProps.Register[name: $StyleDef,
reader: ReadSpecsProc, writer: WriteSpecsProc, copier: CopyInfoProc];
};
StartExtra[];
END.