NodeStyleWorks2Impl.mesa
Copyright Ó 1985, 1987, 1988, 1991 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
Rick Beach, March 28, 1985 9:56:35 am PST
Michael Plass, November 20, 1987 4:54:00 pm PST
Spreitze, July 9, 1990 4:48 pm PDT
Doug Wyatt, October 22, 1991 4:23 pm PDT
DIRECTORY
Ascii USING [Lower],
Atom USING [GetPName, MakeAtomFromRefText],
IO USING [PutRope, STREAM],
NodeStyle USING [ConsDataListObject, DataEntry, DataList, Ref],
NodeStyleWorks USING [bindingDict, StyleError, StyleForFrame],
ProcessProps USING [GetProp],
RefText USING [AppendRope, ObtainScratch, ReleaseScratch],
Rope USING [ActionType, Cat, Fetch, Length, Map, ROPE, Translate],
RuntimeError USING [UNCAUGHT],
SimpleFeedback USING [Append],
TJaM USING [APut, Array, AtomFromRope, Cmd, CommandProc, CvLit, CvX, Def, Dict, Execute, Frame, Load, NewArray, Object, Pop, PopAtom, PopInt, PopReal, PopRope, Push, PushBool, PushInt, PushReal, PushRope, Put, Register, RopeFromAtom, StackIsEmpty, TopType, TryToLoad];
NodeStyleWorks2Impl: CEDAR MONITOR
IMPORTS Ascii, Atom, IO, NodeStyle, NodeStyleWorks, ProcessProps, RefText, Rope, RuntimeError, SimpleFeedback, TJaM
EXPORTS NodeStyleWorks
~
BEGIN
OPEN NodeStyle, NodeStyleWorks;
WhoIsExecuting: PUBLIC SIGNAL RETURNS [executingName: ATOM ¬ NIL] ~ CODE;
Where:
PUBLIC
SIGNAL
RETURNS [
ROPE ¬
NIL] ~
CODE;
Frame: TYPE ~ TJaM.Frame;
Object: TYPE ~ TJaM.Object;
ROPE: TYPE ~ Rope.ROPE;
Support Procs
GetCommand:
PUBLIC
PROC [frame: Frame, name:
ATOM]
RETURNS [TJaM.Cmd] ~ {
known: BOOL ¬ FALSE;
obj: Object;
[known, obj] ¬ TJaM.TryToLoad[frame, name];
IF NOT known THEN ERROR;
RETURN [TypeCheckCommand[obj]];
};
ForceLowerName:
PUBLIC PROC [n:
ATOM]
RETURNS [
ATOM] ~ {
IF n#
NIL
THEN {
rope: ROPE ~ Atom.GetPName[n];
CheckLower: Rope.ActionType ~ {quit ¬ c IN ['A..'Z]};
IF Rope.Map[base: rope, action: CheckLower]
THEN {
len: NAT ~ Rope.Length[rope];
text: REF TEXT ~ RefText.ObtainScratch[len];
FOR i: NAT IN[0..len) DO text[i] ¬ Ascii.Lower[Rope.Fetch[rope, i]] ENDLOOP;
text.length ¬ len;
n ¬ Atom.MakeAtomFromRefText[text];
RefText.ReleaseScratch[text];
};
};
RETURN [n];
};
ForceLowerRope:
PUBLIC PROC [r:
ROPE]
RETURNS [
ROPE] ~ {
ForceCharLower:
PROC [old:
CHAR]
RETURNS [new:
CHAR] ~ {
RETURN [Ascii.Lower[old]] };
RETURN [Rope.Translate[base: r, translator: ForceCharLower]];
};
PopName:
PUBLIC
PROC [frame: Frame]
RETURNS [name:
ATOM] ~ {
ok: BOOL ¬ TRUE;
obj: Object ¬ NIL;
IF TJaM.StackIsEmpty[frame] THEN ok ¬ FALSE;
IF ok
THEN
SELECT TJaM.TopType[frame]
FROM
atom => RETURN [TJaM.PopAtom[frame]];
rope => RETURN [TJaM.AtomFromRope[TJaM.PopRope[frame]]]
ENDCASE => { ok ¬ FALSE; obj ¬ TJaM.Pop[frame]; };
IF
NOT ok
THEN {
TJaM.Push[frame, obj];
TJaM.PushRope[frame, " -- found where a name was expected."];
StyleError[frame, 2];
};
};
TryToPopName:
PUBLIC
PROC [frame: Frame]
RETURNS [name:
ATOM, ok:
BOOL] ~ {
IF
NOT TJaM.StackIsEmpty[frame]
THEN
SELECT TJaM.TopType[frame]
FROM
atom => RETURN [name: TJaM.PopAtom[frame], ok: TRUE];
rope => RETURN [name: TJaM.AtomFromRope[TJaM.PopRope[frame]], ok: TRUE];
ENDCASE;
RETURN[name: NIL, ok: FALSE];
TryToPopReal:
PUBLIC
PROC [frame: Frame]
RETURNS [value:
REAL, ok:
BOOL] ~ {
IF
NOT TJaM.StackIsEmpty[frame]
THEN
SELECT TJaM.TopType[frame]
FROM
number => RETURN [value: TJaM.PopReal[frame], ok: TRUE];
ENDCASE;
RETURN[value: 0, ok: FALSE];
TryToPopRope:
PUBLIC
PROC [frame: Frame]
RETURNS [rope:
ROPE, ok:
BOOL] ~ {
IF
NOT TJaM.StackIsEmpty[frame]
THEN
SELECT TJaM.TopType[frame]
FROM
atom => RETURN [rope: TJaM.RopeFromAtom[TJaM.PopAtom[frame]], ok: TRUE];
rope => RETURN [rope: TJaM.PopRope[frame], ok: TRUE];
ENDCASE;
RETURN[rope: NIL, ok: FALSE];
TypeCheckName:
PUBLIC
PROC [obj: Object]
RETURNS [
ATOM] ~ {
WITH obj
SELECT
FROM
x: ATOM => RETURN [x];
x: ROPE => RETURN [TJaM.AtomFromRope[x]];
ENDCASE;
ERROR;
};
TypeCheckDict:
PUBLIC
PROC [obj: Object]
RETURNS [TJaM.Dict] ~ {
WITH obj
SELECT
FROM
x: TJaM.Dict => RETURN [x];
ENDCASE;
ERROR;
};
TypeCheckCommand:
PUBLIC
PROC [obj: Object]
RETURNS [TJaM.Cmd] ~ {
WITH obj
SELECT
FROM
x: TJaM.Cmd => RETURN [x];
ENDCASE;
ERROR;
};
Readonly Style Variables
IsCommentOp: TJaM.CommandProc ~ {
style: Ref ¬ StyleForFrame[frame];
TJaM.PushBool[frame, style.isComment];
};
IsPrintOp: TJaM.CommandProc ~ {
style: Ref ¬ StyleForFrame[frame];
TJaM.PushBool[frame, style.kind=print];
};
NestingLevelOp: TJaM.CommandProc ~ {
style: Ref ¬ StyleForFrame[frame];
TJaM.PushInt[frame, style.nestingLevel];
};
StyleParam Implementation
StyleParamOp: TJaM.CommandProc ~ {
called to declare a special style parameter
initialValue: Object ¬ TJaM.Pop[frame]; -- the initial value
name: ATOM ¬ PopName[frame]; -- the parameter name
key: ATOM;
array: TJaM.Array;
[key, array] ¬ SpecialOpArray[name, $SpecialOp];
TJaM.Def[frame, name, TJaM.CvX[array]]; -- store the definition
TJaM.Def[frame, key, initialValue]; -- store the initial value
};
SpecialOpArray:
PUBLIC PROC [name:
ATOM, op: Object]
RETURNS [key:
ATOM, array: TJaM.Array] ~ {
create a 2-element array with (name, objectToExecute)
key ¬ StyleParamKey[name];
array ¬ TJaM.NewArray[2];
TJaM.APut[array, 0, TJaM.CvLit[key]];
TJaM.APut[array, 1, op];
};
StyleParamKey:
PUBLIC
PROC [name:
ATOM]
RETURNS [key:
ATOM] ~ {
create a key which is "!!name" (sort of unique, don't you think)
scratch: REF TEXT ~ RefText.ObtainScratch[50];
text: REF TEXT ¬ scratch;
text ¬ RefText.AppendRope[text, "!!"];
text ¬ RefText.AppendRope[text, Atom.GetPName[name]];
key ¬ Atom.MakeAtomFromRefText[text];
RefText.ReleaseScratch[scratch];
};
SpecialOp: TJaM.CommandProc ~ {
like DoStyleOperation, but for special parameters
aName: BOOL;
name: ATOM;
var: ATOM;
style: Ref ¬ StyleForFrame[frame];
Error:
PROC ~
INLINE {
TJaM.Push[frame, var];
TJaM.PushRope[frame, "has illegal qualifier:"];
TJaM.Push[frame, name];
StyleError[frame, 3];
};
FindObject:
PROC
RETURNS [Object] ~
INLINE {
FOR x: DataList ¬ style.dataList, x.next
UNTIL x=
NIL
DO
WITH x
SELECT
FROM
xx: REF DataEntry.object => IF xx.name = var THEN RETURN [xx.object];
ENDCASE => NULL;
ENDLOOP;
TJaM.Push[frame, var];
TJaM.Execute[frame, load]; -- get the initial value
RETURN [TJaM.Pop[frame]];
};
Store:
PROC [ob: Object] ~
INLINE {
style.dataList ¬ NodeStyle.ConsDataListObject[var, ob, style.dataList];
};
Load: PROC ~ { TJaM.Push[frame, FindObject[]] };
SetReal:
PROC [x:
REAL] ~
INLINE {
TJaM.PushReal[frame, x];
Store[TJaM.Pop[frame]];
};
AddReal:
PROC [inc:
REAL] ~
INLINE {
value: REAL ¬ 0.0;
Load[];
value ¬ TJaM.PopReal[frame];
SetReal[value+inc];
};
SetName:
PROC [n:
ATOM] ~
INLINE {
TJaM.Push[frame, n];
Store[TJaM.Pop[frame]];
};
Percent:
PROC [percent:
REAL] ~
INLINE {
value: REAL ¬ 0.0;
Load[];
value ¬ TJaM.PopReal[frame];
SetReal[(percent*0.01)*value];
};
var ¬ PopName[frame]; -- the name of the special parameter
[name, aName] ¬ TryToPopName[frame];
IF
NOT aName
THEN Store[TJaM.Pop[frame]] --store the object as new value
ELSE {
SELECT name
FROM
$the => Load[];
$bigger => {
[name, aName] ¬ TryToPopName[frame];
IF
NOT aName
THEN AddReal[TJaM.PopReal[frame]]
ELSE IF name = $percent THEN Percent[100+TJaM.PopReal[frame]] ELSE { Error; RETURN };
};
$smaller => {
[name, aName] ¬ TryToPopName[frame];
IF
NOT aName
THEN AddReal[-TJaM.PopReal[frame]]
ELSE IF name = $percent THEN Percent[100-TJaM.PopReal[frame]] ELSE { Error; RETURN };
};
$percent => Percent[TJaM.PopReal[frame]];
ENDCASE => SetName[name];
};
};
RegisterStyleCommand:
PUBLIC
PROC [frame: Frame, name:
ATOM,
proc: TJaM.CommandProc] ~ {
TJaM.Register[frame, name, proc];
-- add it to the binding dictionary
TJaM.Put[bindingDict, name, TJaM.Load[frame, name]];
RegisterStyleLiteral:
PUBLIC
PROC [frame: Frame, name:
ATOM] ~ {
-- add it to the binding dictionary
TJaM.Put[bindingDict, name, name];
-- add it to the current dictionary
TJaM.Def[frame, name, TJaM.CvLit[name]];
};
GetExecutingName:
PROC
RETURNS [executingName:
ATOM] ~
-- must not be INLINE for PrincOps -- {
executingName ¬ SIGNAL WhoIsExecuting[];
};
GetWhere:
PROC
RETURNS [msg:
ROPE] ~
-- must not be INLINE for PrincOps -- {
msg ¬ SIGNAL Where[];
};
ReportStyleErrorOp: TJaM.CommandProc ~ {
num: INT ¬ TJaM.PopInt[frame];
msg1: ROPE ¬ NIL;
msg: ROPE ¬ NIL;
executingName: ATOM ¬ NIL;
where: ROPE ¬ NIL;
executingName ¬ GetExecutingName[ ! RuntimeError.UNCAUGHT => CONTINUE];
where ¬ GetWhere[ ! RuntimeError.UNCAUGHT => CONTINUE];
msg1 ¬ Rope.Cat[
"Style error ",
IF executingName # NIL THEN Rope.Cat["in \"", Atom.GetPName[executingName], "\" rule "] ELSE NIL,
IF where # NIL THEN Rope.Cat["at ", where, " in doc "] ELSE NIL,
"- "
];
UNTIL num=0
DO
m: ROPE;
ok: BOOL;
[m, ok] ¬ TryToPopRope[frame];
IF NOT ok THEN EXIT;
msg ¬ IF msg = NIL THEN m ELSE Rope.Cat[m, " ", msg];
num ¬ num-1;
ENDLOOP;
WITH ProcessProps.GetProp[$StdOut]
SELECT
FROM
errout:
IO.
STREAM => {
IO.PutRope[errout, "\n *** "];
IO.PutRope[errout, msg1];
IO.PutRope[errout, msg];
IO.PutRope[errout, "\n"];
};
ENDCASE => { SimpleFeedback.Append[$Tioga, begin, $Error, msg1]; SimpleFeedback.Append[$Tioga, end, $Error, msg] };
};
load: PUBLIC TJaM.Cmd;
get: PUBLIC TJaM.Cmd;
run: PUBLIC TJaM.Cmd;
RegisterWorks2:
PUBLIC
PROC [frame: Frame] ~ {
register the various style commands and JaM commands in this module
TJaM.Register[frame, $isComment, IsCommentOp];
TJaM.Register[frame, $isPrint, IsPrintOp];
TJaM.Register[frame, $nestingLevel, NestingLevelOp];
TJaM.Register[frame, $StyleParam, StyleParamOp];
TJaM.Register[frame, $SpecialOp, SpecialOp];
TJaM.Register[frame, $ReportStyleError, ReportStyleErrorOp];
END.