NodeStyleWorksImpl.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
Doug Wyatt, March 5, 1985 10:51:57 am PST
Micheal Plass, March 14, 1985 4:26:04 pm PST
Rick Beach, March 19, 1985 8:22:33 am PST
DIRECTORY
Ascii,
Atom,
Convert,
MessageWindow,
NameSymbolTable,
NodeProps,
NodeStyle,
NodeStyleOps,
NodeStyleWorks,
Process,
Rope,
TextLooks,
TJaMBasic,
TJaMInternal,
TJaMOps,
TJaMVM,
UserProfile;
NodeStyleWorksImpl: CEDAR MONITOR
IMPORTS TJaMOps, TJaMVM, Process, Rope, MessageWindow, NodeStyleOps, NodeStyleWorks, NameSymbolTable
EXPORTS NodeStyleWorks
= BEGIN OPEN NodeStyle, NodeStyleWorks;
Execution Frames for Style Machinery
FrameInfo: TYPE = REF FrameInfoBody;
FrameInfoBody: TYPE = RECORD [ frame: Frame, style: Ref, rest: FrameInfo ];
GetFrame: PUBLIC 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 style bombs during load
found: BOOL;
AllocFrame: ENTRY PROC [name: Name, kind: OfStyle] = TRUSTED {
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 = TRUSTED {
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[];
};
FreeFrame: PUBLIC ENTRY 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;
};
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: Name ← NameSymbolTable.nullName;
styleKind1, styleKind2, styleKind3, styleKind4: OfStyle ← screen;
debugFlag: BOOL ← TRUE;
debugStyle: Ref;
StyleForFrame: PUBLIC PROC [frame: Frame] RETURNS [style: Ref] = TRUSTED {
GetIt: ENTRY PROC RETURNS [s: Ref] = TRUSTED 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 ← NodeStyleOps.Create[];
RETURN [debugStyle] };
ERROR };
RETURN [style];
};
Load style procedures
GetStyleDict: PUBLIC PROC [frame: Frame, name: Name, kind: OfStyle, def: Rope.ROPE ← NIL]
RETURNS [d: dict Object] = {
found, ok: BOOL;
name ← ForceLowerName[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: PUBLIC PROC [frame: Frame, name: Name] = TRUSTED {
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 # NodeStyleOps.defaultStyleName THEN {
PushName[frame, NodeStyleOps.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] = TRUSTED { -- creates dict for style
RETURN [TJaMOps.Dict[50]];
};
EnterStyleDict: PROC [name: Name, d: Object, kind: OfStyle] = TRUSTED INLINE {
TJaMOps.Put[stylesDicts[kind], NameToObject[name], d];
};
CheckStyleDict: PROC [name: Name, kind: OfStyle]
RETURNS [d: dict Object, found: BOOL] = TRUSTED {
obj: Object;
[found, obj] ← TJaMOps.TryToGet[stylesDicts[kind], NameToObject[name]];
IF found THEN d ← TypeCheckDict[obj];
};
RunStyle: PUBLIC PROC [frame: Frame, name: Name] RETURNS [ok: BOOL] = TRUSTED {
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: PUBLIC PROC [frame: Frame, name: Name, def: Rope.ROPE]
RETURNS [ok: BOOL] = TRUSTED {
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];
};
sysdict: PUBLIC dict Object;
userdict: PUBLIC dict Object;
styledict: PUBLIC dict Object;
Style Dictionary Operations
styleDictName: Name = NameSymbolTable.MakeName["##styleDictName"];
styleKindName: Name = NameSymbolTable.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
BeginStyleOp: PROC [frame: Frame] = TRUSTED {
name: Name ← ForceLowerName[SIGNAL WhatStyle]; -- get style name from RunStyle
screenDict, printDict, baseDict: dict Object;
ResetDict: PROC [dict: dict Object] = TRUSTED {
TJaMOps.ClrDict[dict];
TJaMOps.DetachAll[dict];
};
MakeDict: PROC [kind: OfStyle] RETURNS [dict: dict Object] = TRUSTED {
dict ← CreateStyleDict[];
EnterStyleDict[name, dict, kind];
};
InitDict: PROC [dict: dict Object, kind: OfStyle] = TRUSTED {
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];
NodeStyleOps.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
};
StyleNameOp: PROC [frame: Frame] = TRUSTED { -- expects style dictionary on op stack
PushObject[frame, TJaMOps.Load[frame, NameToObject[styleDictName]]]
};
EndStyleOp: PROC [frame: Frame] = TRUSTED {
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] = TRUSTED {
expects <name> <comment> <definition> on op stack
definition: Object ← PopObject[frame];
comment: Object ← PopObject[frame];
STKname: Name ← PopName[frame];
name: Name ← ForceLowerName[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] = TRUSTED {
RETURN [TypeCheckDict[TJaMOps.Load[frame, NameToObject[styleDictNames[kind]]]]];
};
LoadStyleRuleDict: PROC [frame: Frame, kind: OfStyle] RETURNS [dict Object] = TRUSTED {
RETURN [TypeCheckDict[TJaMOps.Load[frame, NameToObject[styleRuleDictNames[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];
};
OpenStyle: PROC [frame: Frame, kind: OfStyle] = TRUSTED {
name: Name ← PopName[frame];
IF NOT NodeStyleOps.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]];
};
ResetTestStyleOp: PROC [frame: Frame] = {
IF debugStyle=NIL THEN debugStyle ← NodeStyleOps.Create[];
debugStyle^ ← NodeStyleOps.defaultStyle^;
};
StyleRuleDictOp: PROC [frame: Frame] = { GetRuleDict[frame, base] };
PrintRuleDictOp: PROC [frame: Frame] = { GetRuleDict[frame, print] };
ScreenRuleDictOp: PROC [frame: Frame] = { GetRuleDict[frame, screen] };
GetRuleDict: PROC [frame: Frame, kind: OfStyle] = TRUSTED {
PushName[frame, styleRuleDictNames[kind]];
TJaMOps.Execute[frame, get];
};
AttachStyleOp: PROC [frame: Frame] = TRUSTED { -- expects opstk to contain style name
name: Name ← ForceLowerName[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];
};
ForEachAttachedStyle: PUBLIC PROC [dictName: Name, proc: PROC [attached: Name]
RETURNS [stop: BOOL]] = TRUSTED {
val: Object;
array: array Object;
found: BOOL;
dictName ← NodeStyleWorks.ForceLowerName[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;
};
Execute Styles
ExecuteName: PUBLIC PROC [frame: Frame, name: Name] RETURNS [ok: BOOL] = TRUSTED {
makes sure that same stack depth after execute
initDepth: CARDINAL ← TJaMOps.CountStack[frame.opstk];
finalDepth: CARDINAL;
nameObj: Object ← NameToObject[name];
[ok, ] ← TJaMOps.TryToLoad[frame, nameObj];
IF ~ok THEN RETURN;
executingName ← name;
TJaMOps.Execute[frame, CVX[nameObj]];
executingName ← NameSymbolTable.nullName;
IF (finalDepth ← TJaMOps.CountStack[frame.opstk]) # initDepth THEN {
PushText[frame, "Failed to leave stack at same depth after execution.\n"L];
PushName[frame, name];
StyleError[frame, 2];
ok ← FALSE;
};
};
ExecuteNameInStyle: PUBLIC PROC [ref: Ref, kind: OfStyle, name: Name]
RETURNS [ok: BOOL] = TRUSTED {
makes sure that same stack depth after execute
styleName: Name ← ref.name[style];
frame: Frame ← GetFrame[ref, styleName, kind];
initDepth: CARDINAL ← TJaMOps.CountStack[frame.opstk];
finalDepth: CARDINAL;
nameObj: Object ← NameToObject[name];
[ok, ] ← TJaMOps.TryToLoad[frame, nameObj];
IF NOT ok THEN RETURN;
executingName ← name;
TJaMOps.Execute[frame, CVX[nameObj]];
executingName ← NameSymbolTable.nullName;
IF (finalDepth ← TJaMOps.CountStack[frame.opstk]) # initDepth THEN {
PushText[frame, "Failed to leave stack at same depth after execution.\n"L];
PushName[frame, name];
StyleError[frame, 2];
ok ← FALSE;
};
FreeFrame[frame, styleName, kind];
frame ← NIL;
};
ExecuteObjectInStyle: PUBLIC PROC [ref: Ref, kind: OfStyle, object: Object]
RETURNS [ok: BOOL] = TRUSTED {
makes sure that same stack depth after execute
styleName: Name ← ref.name[style];
frame: Frame ← GetFrame[ref, styleName, kind];
initDepth: CARDINAL ← TJaMOps.CountStack[frame.opstk];
finalDepth: CARDINAL;
ok ← TRUE;
TJaMOps.Execute[frame, CVX[object]];
IF (finalDepth ← TJaMOps.CountStack[frame.opstk]) # initDepth THEN {
PushObject[frame, object];
PushText[frame, "Failed to leave stack at same depth after execution.\n"L];
StyleError[frame, 2];
ok ← FALSE;
};
FreeFrame[frame, styleName, kind];
frame ← NIL;
};
ExecuteLooksInStyle: PUBLIC PROC [ref: Ref, kind: OfStyle, looks: TextLooks.Looks]
RETURNS [ok: BOOL] = TRUSTED {
makes sure that same stack depth after execute
styleName: Name ← ref.name[style];
frame: Frame ← GetFrame[ref, styleName, kind];
ok ← TRUE;
FOR c: CHAR IN TextLooks.Look DO
IF looks[c] THEN ok ← ExecuteName[frame, lookNames[c]]
ENDLOOP;
FreeFrame[frame, styleName, kind];
frame ← NIL;
};
executingName: PUBLIC Name;
lookNames: REF LookNames ← NEW[LookNames];
LookNames: TYPE = ARRAY TextLooks.Look OF Name;
InitLookNames: PROC = TRUSTED {
names are "look.a", "look.b", "look.c", etc.
txt: STRING ← [6];
txt[0] ← 'l; txt[1] ← txt[2] ← 'o; txt[3] ← 'k; txt[4] ← '.; txt.length ← 6;
FOR c: CHAR IN TextLooks.Look DO
txt[5] ← c;
lookNames[c] ← NameSymbolTable.MakeName[LOOPHOLE[LONG[txt], REF READONLY TEXT]];
ENDLOOP;
};
StyleError: PUBLIC PROC [frame: Frame, num: INTEGER] = TRUSTED {
PushInteger[frame, num];
TJaMOps.Execute[frame, CVX[NameToObject[styleerror]]];
};
Implementing Style Attribute Operations
opsList: PUBLIC LIST OF RECORD[param: Param, op: PROC [frame: Frame]];
Preregister: PUBLIC PROC [param: Param, op: PROC [frame: Frame]] RETURNS [Param] ~ {
opsList ← CONS[[param, op], opsList];
RETURN [param];
};
DoStyleOp: PUBLIC PROC [frame: Frame, p: Param] = {
nameflag: BOOL;
name: Name;
style: Ref ← StyleForFrame[frame];
Error: PROC = {
PushName[frame, NameSymbolTable.MakeName[p.opName]];
PushText[frame, "illegal as qualifer for"L];
PushName[frame, name];
StyleError[frame, 3];
};
[name, nameflag] ← TryToPopName[frame];
IF ~nameflag 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, nameflag] ← TryToPopName[frame];
IF ~nameflag THEN p.ops.AddReal[frame, PopReal[frame], p, style]
-- e.g., "2 pt bigger leading"
ELSE IF name=percent THEN p.ops.Percent[frame, 100+PopReal[frame], p, style]
-- e.g., "2 percent bigger leading"
ELSE { Error; RETURN };
};
smaller => {
[name, nameflag] ← TryToPopName[frame];
IF ~nameflag THEN p.ops.AddReal[frame, -PopReal[frame], p, style]
-- e.g., "2 pt smaller leading"
ELSE IF name=percent THEN p.ops.Percent[frame, 100-PopReal[frame], p, style]
-- e.g., "2 percent smaller leading"
ELSE { Error; RETURN };
};
percent => p.ops.Percent[frame, PopReal[frame], p, style];
ENDCASE => p.ops.SetName[frame, name, p, style]; -- e.g., "TimesRoman family"
};
General Error Routines
StoreError: PUBLIC StoreProc = {
ob: TJaMBasic.Object ← PopObject[frame];
PushName[frame, NameSymbolTable.MakeName[p.opName]];
PushText[frame, "is not legal as value for"L];
PushObject[frame, ob];
StyleError[frame, 3];
};
AddRealError: PUBLIC AddRealProc = {
PushName[frame, NameSymbolTable.MakeName[p.opName]];
PushText[frame, "Numbers are illegal as values for"L];
StyleError[frame, 2];
};
PercentError: PUBLIC PercentProc = {
PushName[frame, NameSymbolTable.MakeName[p.opName]];
PushText[frame, "Numbers are illegal as values for"L];
StyleError[frame, 2];
};
SetNameError: PUBLIC SetNameProc = {
PushName[frame, NameSymbolTable.MakeName[p.opName]];
PushText[frame, "Only numbers are legal as values for"L];
StyleError[frame, 2];
};
Name Parameter Operations
nameOps: PUBLIC Ops ← NEW [OpsRec ←
[LoadNameParam, StoreError, AddRealError, PercentError, SetNameParam]];
LoadNameParam: PUBLIC LoadProc = {
PushName[frame, style.name[NARROW[p, REF ParamRec.name].param]];
};
SetNameParam: PUBLIC SetNameProc = {
style.name[NARROW[p, REF ParamRec.name].param] ← name;
};
NameError: PUBLIC PROC [frame: Frame, name: Name, p: Param] = {
PushName[frame, NameSymbolTable.MakeName[p.opName]];
PushText[frame, "illegal as value for"L];
PushName[frame, name];
StyleError[frame, 3];
};
Real Parameter Operations
realOps: PUBLIC Ops ← NEW [OpsRec ←
[RealOpLoad, RealOpSetReal, RealOpAddReal, RealOpPercent, SetNameError]];
RealOpLoad: PUBLIC LoadProc = {
PushReal[frame, GetReal[style, NARROW[p, REF ParamRec.real].param]]};
RealOpSetReal: PUBLIC StoreProc = {
SetReal[style, NARROW[p, REF ParamRec.real].param, PopReal[frame]]};
RealOpAddReal: PUBLIC AddRealProc = {
x: REF ParamRec.real = NARROW[p];
SetReal[style, x.param, GetReal[style, x.param]+inc]};
RealOpPercent: PUBLIC PercentProc = {
val: REAL ← GetReal[style, NARROW[p, REF ParamRec.real].param];
SetReal[style, NARROW[p, REF ParamRec.real].param, (percent/100)*val];
};
Glue Parameter Operations
glueOps: PUBLIC Ops ← NEW [OpsRec ←
[GlueOpLoad, GlueOpSetReal, GlueOpAddReal, GlueOpPercent, SetNameError]];
GlueOpLoad: PUBLIC LoadProc = {
Get: PROC [param: RealParam] = {
PushReal[frame, GetReal[style, param]] };
x: REF ParamRec.glue = NARROW[p];
Get[x.size]; Get[x.stretch]; Get[x.shrink];
};
GlueOpSetReal: PUBLIC StoreProc = {
Set: PROC [param: RealParam] = {
SetReal[style, param, PopReal[frame]] };
x: REF ParamRec.glue = NARROW[p];
Set[x.shrink]; Set[x.stretch]; Set[x.size];
};
GlueOpAddReal: PUBLIC AddRealProc = {
Add: PROC [param: RealParam] = {
SetReal[style, param, GetReal[style, param]+inc] };
x: REF ParamRec.glue = NARROW[p];
Add[x.size]; Add[x.stretch]; Add[x.shrink];
};
GlueOpPercent: PUBLIC PercentProc = {
Set: PROC [param: RealParam] = {
val: REAL ← GetReal[style, param];
SetReal[style, param, (percent/100)*val];
};
x: REF ParamRec.glue = NARROW[p];
Set[x.size]; Set[x.stretch]; Set[x.shrink];
};
Color Parameter Operations
colorOps: PUBLIC Ops ← NEW [OpsRec ←
[ColorOpLoad, ColorOpSetReal, ColorOpAddReal, ColorOpPercent, SetNameError]];
ColorOpLoad: PUBLIC LoadProc = {
Get: PROC [param: RealParam] = {
PushReal[frame, GetReal[style, param]];
};
x: REF ParamRec.color = NARROW[p];
Get[x.hue]; Get[x.saturation]; Get[x.brightness];
};
ColorOpSetReal: PUBLIC StoreProc = {
Set: PROC [param: RealParam] = {
SetReal[style, param, PopReal[frame]];
};
x: REF ParamRec.color = NARROW[p];
Set[x.brightness]; Set[x.saturation]; Set[x.hue];
};
ColorOpAddReal: PUBLIC AddRealProc = {
Add: PROC [param: RealParam] = {
SetReal[style, param, GetReal[style, param]+inc];
};
x: REF ParamRec.color = NARROW[p];
Add[x.hue]; Add[x.saturation]; Add[x.brightness];
};
ColorOpPercent: PUBLIC PercentProc = {
Set: PROC [param: RealParam] = {
val: REAL ← GetReal[style, param];
SetReal[style, param, (percent/100)*val];
};
x: REF ParamRec.color = NARROW[p];
Set[x.hue]; Set[x.saturation]; Set[x.brightness];
};
END.