FeedbackOpsImpl.mesa
Copyright Ó 1988, 1990 by Xerox Corporation. All rights reserved.
Last edited by Bier on July 12, 1990 2:16 pm PDT
Last tweaked by Mike Spreitzer on July 17, 1990 11:32 am PDT
Contents: Routines that determine where a MsgRouter will send its output.
DIRECTORY Feedback, FeedbackClasses, FeedbackConcreteTypes, FeedbackOps, FeedbackTypes, IO, Labels, MessageWindow, Process, RefTab, Rope, ViewerClasses, ViewerIO, ViewerOps, ViewerPrivate;
FeedbackOpsImpl:
CEDAR
MONITOR
LOCKS script USING script: Script
IMPORTS Feedback, FeedbackClasses, IO, Labels, MessageWindow, Process, RefTab, Rope, ViewerIO, ViewerOps, ViewerPrivate
EXPORTS FeedbackOps = BEGIN OPEN Feedback;
Viewer: TYPE = ViewerClasses.Viewer;
LOR: TYPE ~ LIST OF ROPE;
Typescripts
gTypescripts: RefTab.Ref ← RefTab.Create[]; -- all of the named typescripts that FeedbackOps knows about
Script: TYPE = REF ScriptObj;
ScriptObj:
TYPE =
MONITORED
RECORD [
viewer: Viewer, -- viewer can be NIL, if stream does not belong to a viewer
stream: IO.STREAM,
typescriptName: ATOM,
storing: BOOL,
queueHead, queueTail: FList ← NIL, --list of PutF tasks to do
putter: PROCESS ← NIL, --the process, if any, doing PutFs
change: CONDITION
];
FList: TYPE ~ REF FCons;
FCons:
TYPE ~
RECORD [
rest: FList,
first:
SELECT kind: *
FROM
blink => [],
putf => [format: Rope.ROPE, v1, v2, v3, v4, v5: IO.Value],
putc => [c: CHAR],
ENDCASE];
blinkF: FCons ~ [NIL, blink[]];
CreateNamedTypescript:
PUBLIC
PROC [headerText: Rope.
ROPE, typescriptName:
ATOM, openHeight:
NAT ← 120, storing:
BOOL ←
FALSE]
RETURNS [alreadyExists:
BOOL ←
FALSE, typescript: Viewer] = {
newStream: IO.STREAM;
script: Script ← FindScript[typescriptName];
IF script=
NIL
OR script.viewer=
NIL
OR script.viewer.destroyed
THEN {
typescript ← ViewerOps.CreateViewer[
flavor: $TypeScript,
info: [name: headerText, menu: NIL, data: NIL, iconic: TRUE, column: right, scrollable: TRUE, icon: unInit], paint: FALSE];
ViewerOps.SetOpenHeight[typescript, openHeight];
ViewerOps.OpenIcon[icon: typescript, closeOthers: FALSE, bottom: TRUE, paint: TRUE];
[, newStream] ← ViewerIO.CreateViewerStreams[headerText, typescript, NIL, TRUE];
IF script=
NIL
THEN {
script ← NEW[ScriptObj ← [viewer: typescript, stream: newStream, typescriptName: typescriptName, storing: storing]];
TRUSTED {Process.InitializeCondition[@script.change, Process.MsecToTicks[1D4]]};
[] ← gTypescripts.Store[typescriptName, script];
}
ELSE SetStuff[script, newStream, typescript, storing];
}
ELSE {
-- nothing wrong with the current typescript
alreadyExists ← TRUE;
typescript ← script.viewer};
};
CreateTypescriptFromStream:
PUBLIC
PROC [stream:
IO.
STREAM, typescriptName:
ATOM, storing:
BOOL ←
FALSE]
RETURNS [alreadyExists:
BOOL ←
FALSE, oldStream:
IO.
STREAM ←
NIL] = {
script: Script ← FindScript[typescriptName];
IF script=
NIL
THEN {
newScript: Script ← NEW[ScriptObj ← [viewer: NIL, stream: stream, typescriptName: typescriptName, storing: storing]];
TRUSTED {Process.InitializeCondition[@script.change, Process.MsecToTicks[1D4]]};
[] ← gTypescripts.Store[typescriptName, newScript];
}
ELSE {
alreadyExists ← TRUE; oldStream ← script.stream;
SetStuff[script, stream, NIL, storing];
};
};
FindScript:
PROC [typescriptName:
ATOM]
RETURNS [script: Script ←
NIL] = {
found: BOOL ← FALSE;
val: REF;
[found, val] ← gTypescripts.Fetch[typescriptName];
IF found THEN script ← NARROW[val];
};
GetTypescriptStream:
PUBLIC
PROC [typescriptName:
ATOM]
RETURNS [
IO.
STREAM] = {
script: Script ← FindScript[typescriptName];
IF script = NIL THEN RETURN[NIL];
RETURN[script.stream];
};
GetTypescripts:
PUBLIC
PROC []
RETURNS [names:
LIST
OF
ATOM] = {
AddToList:
PROC [key: RefTab.Key, val: RefTab.Val]
RETURNS [quit:
BOOL ←
FALSE] = {
names ← CONS[NARROW[key, ATOM], names];
};
[] ← gTypescripts.Pairs[AddToList];
};
Our two-headed handlers
FeedbackData: TYPE = REF FeedbackDataObj;
FeedbackDataObj:
TYPE =
RECORD [
lp: RECORD [label: Viewer, blink: BOOL] ← [NIL, FALSE],
tn: ATOM ← NIL,
default: FeedbackData ← NIL,
bounded: BOOL ← TRUE
];
NIL label or tn means to consult default, if any.
messageWindow: PUBLIC Viewer ~ ViewerPrivate.messageWindow;
noLabel: Viewer ~ NEW [ViewerClasses.ViewerRec];
Iv:
PROC [v: Viewer]
RETURNS [Viewer]
~ INLINE {RETURN [IF v=NIL THEN noLabel ELSE v]};
Ov:
PROC [v: Viewer]
RETURNS [Viewer]
~ INLINE {RETURN [IF v=noLabel THEN NIL ELSE v]};
It:
PROC [a:
ATOM]
RETURNS [
ATOM]
~ INLINE {RETURN [IF a=NIL THEN $None ELSE a]};
Ot:
PROC [a:
ATOM]
RETURNS [
ATOM]
~ INLINE {RETURN [IF a=$None THEN NIL ELSE a]};
CreateViewersHandler:
PUBLIC
PROC [typescriptName:
ATOM ← $None, label: Viewer ←
NIL, blink:
BOOL ←
FALSE]
RETURNS [MsgHandler] ~ {
fd: FeedbackData ~ NEW [FeedbackDataObj ← [[Iv[label], blink], typescriptName]];
IF label=NIL THEN label ← noLabel;
RETURN FeedbackClasses.CreateHandler[VPutF, VClearHerald, VBlink, fd]};
IsViewersHandler:
PUBLIC
PROC [mh: MsgHandler]
RETURNS [is:
BOOL, typescriptName:
ATOM ← $None, label: Viewer ←
NIL, blink:
BOOL ←
FALSE] ~ {
WITH FeedbackClasses.GetHandlerData[mh]
SELECT
FROM
fd: FeedbackData => RETURN [TRUE, fd.tn, Ov[fd.lp.label], fd.lp.blink];
ENDCASE => RETURN [FALSE]};
HandleToLabel:
PUBLIC
PROC [vh: MsgHandler, label: Viewer, blink:
BOOL ←
FALSE] ~ {
WITH FeedbackClasses.GetHandlerData[vh]
SELECT
FROM
fd: FeedbackData => fd.lp ← [Iv[label], blink];
ENDCASE => ERROR Problem["not a Viewers handler"]};
HandleToTypescript:
PUBLIC
PROC [vh: MsgHandler, typescriptName:
ATOM ← $None] ~ {
WITH FeedbackClasses.GetHandlerData[vh]
SELECT
FROM
fd: FeedbackData => fd.tn ← typescriptName;
ENDCASE => ERROR Problem["not a Viewers handler"]};
SetFD:
PROC [router: MsgRouter, msgClass: MsgClass, label: Viewer, blink:
BOOL, tn:
ATOM] = {
mh: MsgHandler;
dh: MsgHandler ← GetHandler[router, $Default];
dd: FeedbackData ←
IF dh=
NIL
THEN
NIL
ELSE
WITH FeedbackClasses.GetHandlerData[dh]
SELECT
FROM
x: FeedbackData => x,
ENDCASE => NIL;
IF msgClass=$Every
OR msgClass=$Default
THEN {
e: BOOL ~ msgClass=$Every;
toclear: LIST OF MsgClass ← NIL;
PerDirection:
PROC [msgClass: MsgClass, msgHandler: MsgHandler]
RETURNS [
BOOL] ~ {
WITH FeedbackClasses.GetHandlerData[msgHandler]
SELECT
FROM
x: FeedbackData =>
IF e
THEN {
IF label#NIL THEN x.lp ← [label, blink];
IF tn#NIL THEN x.tn ← tn}
ELSE x.default ← dd;
ENDCASE => IF e THEN toclear ← CONS[msgClass, toclear];
RETURN [FALSE]};
IF dd#
NIL
THEN {
IF label#NIL THEN dd.lp ← [label, blink];
IF tn#NIL THEN dd.tn ← tn}
ELSE {
dd ← NEW [FeedbackDataObj ← [[Iv[label], blink], It[tn]]];
dh ← FeedbackClasses.CreateHandler[VPutF, VClearHerald, VBlink, dd];
[] ← SetHandler[router, $Default, dh]};
IF ScanHandlers[router, PerDirection].stopped THEN ERROR;
SetMultiHandler[router, toclear, NIL];
RETURN};
mh ← GetHandler[router, msgClass];
IF mh#
NIL
THEN
WITH FeedbackClasses.GetHandlerData[mh]
SELECT
FROM
x: FeedbackData => {
IF label#NIL THEN x.lp ← [label, blink];
IF tn#NIL THEN x.tn ← tn;
RETURN};
ENDCASE => NULL;
mh ← FeedbackClasses.CreateHandler[VPutF, VClearHerald, VBlink, NEW [FeedbackDataObj ← [[label, blink], tn, dd]]];
[] ← SetHandler[router, msgClass, mh];
RETURN};
GetFD:
PROC [router: MsgRouter, msgClass: MsgClass]
RETURNS [fd: FeedbackData] = {
mh: MsgHandler ← GetHandler[router, msgClass];
IF mh#
NIL
THEN
WITH FeedbackClasses.GetHandlerData[mh]
SELECT
FROM
x: FeedbackData => RETURN [x];
ENDCASE => NULL;
RETURN [NIL]};
Wiring up a MsgRouter to specific output streams
SetLabel:
PUBLIC
PROC [router: MsgRouter, label: Viewer, blink:
BOOL ←
FALSE, msgClass: MsgClass ← $Every] = {
SetFD[router, msgClass, Iv[label], blink, NIL];
};
SetMultiLabel:
PUBLIC
PROC [router: MsgRouter, label: Viewer, blink:
BOOL ←
FALSE, msgClasses:
LIST
OF
ATOM] = {
FOR list:
LIST
OF
ATOM ← msgClasses, list.rest
UNTIL list =
NIL
DO
SetLabel[router, label, blink, list.first];
ENDLOOP;
};
SetMessageWindow:
PUBLIC
PROC [router: MsgRouter, blink:
BOOL ←
FALSE, msgClass: MsgClass ← $Every] = {
SetFD[router, msgClass, messageWindow, blink, NIL];
};
SetMultiMessageWindow:
PUBLIC
PROC [router: MsgRouter, blink:
BOOL ←
FALSE, msgClasses:
LIST
OF
ATOM] = {
FOR list:
LIST
OF
ATOM ← msgClasses, list.rest
UNTIL list =
NIL
DO
SetMessageWindow[router, blink, list.first];
ENDLOOP;
};
SetTypescript:
PUBLIC
PROC [router: MsgRouter, typescriptName:
ATOM ← $None, msgClass: MsgClass ← $Every] = {
SetFD[router, msgClass, NIL, FALSE, typescriptName];
};
SetMultiTypescript:
PUBLIC
PROC [router: MsgRouter, typescriptName:
ATOM ← $None, msgClasses:
LIST
OF
ATOM] = {
FOR list:
LIST
OF
ATOM ← msgClasses, list.rest
UNTIL list =
NIL
DO
SetTypescript[router, typescriptName, list.first];
ENDLOOP;
};
CreateSimpleRouter:
PUBLIC PROC [label: Viewer, blink:
BOOL ←
FALSE, typescriptName:
ATOM]
RETURNS [router: MsgRouter] = {
router ← CreateRouter[];
SetLabel[router, label, blink, $Every];
SetTypescript[router, typescriptName, $Every];
};
CreateMultiFeedback:
PUBLIC
PROC [label: Viewer, blink:
BOOL ←
FALSE, labelClasses:
LIST
OF
ATOM, typescriptName:
ATOM, typescriptClasses:
LIST
OF
ATOM]
RETURNS [router: MsgRouter] = {
router ← CreateRouter[];
SetMultiLabel[router, label, blink, labelClasses];
SetMultiTypescript[router, typescriptName, typescriptClasses];
};
Queries on routers (mostly for debugging)
GetLabel:
PUBLIC
PROC [router: MsgRouter, msgClass: MsgClass ← $Default]
RETURNS [label: Viewer, blink:
BOOL ←
FALSE] = {
feedback: FeedbackData ~ GetFD[router, msgClass];
IF feedback#NIL THEN RETURN [Ov[feedback.lp.label], feedback.lp.blink];
RETURN [NIL]};
GetTypescriptName:
PUBLIC
PROC [router: MsgRouter, msgClass: MsgClass ← $Default]
RETURNS [typescriptName:
ATOM ← $None] = {
feedback: FeedbackData ~ GetFD[router, msgClass];
IF feedback#NIL THEN RETURN [feedback.tn];
RETURN};
Viewers Output Routines
VPutF:
PROC [mh: MsgHandler, msgType: MsgType, msgClass: MsgClass, format: Rope.
ROPE, v1, v2, v3, v4, v5:
IO.Value ← [null[]] ] ~ {
fd: FeedbackData ~ NARROW[FeedbackClasses.GetHandlerData[mh]];
lfd: FeedbackData ~ IF fd.lp.label#NIL OR fd.default=NIL THEN fd ELSE fd.default;
tfd: FeedbackData ~ IF fd.tn#NIL OR fd.default=NIL THEN fd ELSE fd.default;
lcf: BOOL ~ typeBreaksAt[msgType].begin OR lfd.bounded;
tcf: BOOL ~ typeBreaksAt[msgType].begin OR tfd.bounded;
msg: Rope.ROPE ~ IO.PutFR[format, v1, v2, v3, v4, v5];
IF lfd.lp.label=noLabel OR lfd.lp.label=NIL THEN NULL
ELSE
IF lfd.lp.label=messageWindow
THEN {
MessageWindow.Append[msg, lcf];
IF lfd.lp.blink THEN MessageWindow.Blink[]}
ELSE {
Labels.Set[lfd.lp.label, IF lcf THEN msg ELSE Rope.Concat[NARROW[lfd.lp.label.class.get[lfd.lp.label]], msg]];
IF lfd.lp.blink THEN BlinkLabel[lfd.lp.label]};
IF tfd.tn # $None THEN PutFToTypescript[tfd.tn, IF tcf THEN Rope.Concat["\n", format] ELSE format, v1, v2, v3, v4, v5];
lfd.bounded ← tfd.bounded ← typeBreaksAt[msgType].end;
};
PutFToTypescript:
PROC [typescriptName:
ATOM, format: Rope.
ROPE, v1, v2, v3, v4, v5:
IO.Value ← [null[]] ] ~ {
script: Script ← FindScript[typescriptName];
IF script=NIL THEN RETURN;
IF format.Length[]=1 AND v1=[null[]] THEN Enqueue[script, [NIL, putc[format.Fetch[0]]]]
ELSE Enqueue[script, [NIL, putf[format, v1, v2, v3, v4, v5]]];
RETURN};
Enqueue:
ENTRY
PROC [script: Script, fp: FCons] ~ {
ENABLE UNWIND => NULL;
IF script.stream=NIL AND NOT script.storing THEN RETURN;
{this: FList ~ NEW [FCons ← fp];
IF script.queueHead=
NIL
THEN script.queueHead ← this
ELSE script.queueTail.rest ← this;
script.queueTail ← this;
IF script.stream=NIL THEN NULL
ELSE IF script.putter=NIL THEN TRUSTED {Process.Detach[script.putter ← FORK Putter[script]]}
ELSE NOTIFY script.change;
RETURN}};
Deque: TYPE ~ RECORD [fh: FList, stream: IO.STREAM, sv: Viewer, quit: BOOL];
Dequeue:
ENTRY
PROC [script: Script]
RETURNS [Deque] ~ {
ENABLE UNWIND => NULL;
RETURN InnerDequeue[script]};
InnerDequeue:
INTERNAL
PROC [script: Script]
RETURNS [Deque] ~ {
n: INTEGER ← 2;
UNTIL script.queueHead#
NIL
AND script.stream#
NIL
DO
IF (n ← n.
PRED) < 0
THEN {
script.putter ← NIL;
RETURN [[NIL, NIL, NIL, TRUE]]};
WAIT script.change;
ENDLOOP;
{fh: FList ~ script.queueHead;
script.queueHead ← script.queueHead.rest;
fh.rest ← NIL;
IF script.queueHead=NIL THEN script.queueTail ← NIL;
RETURN [[fh, script.stream, script.viewer, FALSE]]}};
ClearStreamAndRequeue:
ENTRY
PROC [script: Script, bad:
IO.
STREAM, fh: FList] ~ {
ENABLE UNWIND => NULL;
IF fh.rest # NIL THEN ERROR;
IF script.stream=bad THEN script.stream ← NIL;
fh.rest ← script.queueHead;
script.queueHead ← fh;
IF script.queueTail=NIL THEN script.queueTail ← script.queueHead;
RETURN};
SetStuff:
ENTRY
PROC [script: Script, stream:
IO.
STREAM, sv: Viewer, storing:
BOOL] ~ {
script.stream ← stream;
script.viewer ← sv;
script.storing ← storing;
IF script.stream=NIL THEN NULL
ELSE IF script.putter=NIL THEN TRUSTED {Process.Detach[script.putter ← FORK Putter[script]]}
ELSE NOTIFY script.change;
RETURN};
Putter:
PROC [script: Script] ~ {
This routine is forked to avoid deadlock. Deadlock can occur if a client in a paint-proc calls PutFToTypescript while another typescript is trying to paint. This routine will have the paint lock and need to acquire the typescript painting process; the other typescript will have the typescript editRepaintProcess and need to acquire the paint lock. By forking this routine, we allow our client to finish painting and release the paint lock, which then allows the other Typescript to finish painting and release the typescript editRepaintProcess.
Structure contorted to let Cirio see some frame (InnerPut's).
InnerPut[script !UNWIND => script.putter ← NIL];
RETURN};
InnerPut:
PROC [script: Script] ~ {
DO
dq: Deque ~ Dequeue[script];
IF dq.quit THEN RETURN;
InnerInnerPut[script, dq];
ENDLOOP};
InnerInnerPut:
PROC [script: Script, dq: Deque] ~ {
WITH dq.fh
SELECT
FROM
x: REF blink FCons => IF dq.sv#NIL AND NOT dq.sv.destroyed THEN ViewerOps.BlinkViewer[dq.sv];
x:
REF putf FCons => dq.stream.PutF[x.format, x.v1, x.v2, x.v3, x.v4, x.v5
!
IO.Error => {
IF ec#StreamClosed
THEN {
MessageWindow.Append[IO.PutFR["FeedbackImpl: IO Err at ts %g for fmt %g", [atom[script.typescriptName]], [rope[x.format]] ]];
MessageWindow.Blink[];
}
ELSE ClearStreamAndRequeue[script, stream, dq.fh];
CONTINUE;
}];
x:
REF putc FCons => dq.stream.PutChar[x.c
!
IO.Error => {
IF ec#StreamClosed
THEN {
MessageWindow.Append[IO.PutFR["FeedbackImpl: IO Err at ts %g for PutChar", [atom[script.typescriptName]] ]];
MessageWindow.Blink[];
}
ELSE ClearStreamAndRequeue[script, stream, dq.fh];
CONTINUE;
}];
ENDCASE => ERROR;
RETURN};
VClearHerald:
PROC [mh: MsgHandler, msgClass: MsgClass] ~ {
fd: FeedbackData ← NARROW[FeedbackClasses.GetHandlerData[mh]];
IF fd.lp.label=NIL AND fd.default#NIL THEN fd ← fd.default;
IF fd.lp.label=NIL OR fd.lp.label=noLabel THEN NULL
ELSE IF fd.lp.label=messageWindow THEN MessageWindow.Clear[]
ELSE Labels.Set[fd.lp.label, NIL];
RETURN};
VBlink:
PROC [mh: MsgHandler, msgClass: MsgClass] ~ {
fd: FeedbackData ← NARROW[FeedbackClasses.GetHandlerData[mh]];
IF fd.lp.label=NIL AND fd.default#NIL THEN fd ← fd.default;
IF fd.lp.label=
NIL
OR fd.lp.label=noLabel
THEN {
IF fd.tn#$None
THEN {
script: Script ~ FindScript[fd.tn];
IF script#NIL THEN Enqueue[script, blinkF]
}
}
ELSE IF fd.lp.label=messageWindow THEN MessageWindow.Blink[]
ELSE BlinkLabel[fd.lp.label];
RETURN};
BlinkLabel:
PROC [label: Viewer] = {
Labels.SetDisplayStyle[label, $WhiteOnBlack];
Process.Pause[Process.MsecToTicks[150]];
Labels.SetDisplayStyle[label, $BlackOnWhite];
Process.Pause[Process.MsecToTicks[150]];
Labels.SetDisplayStyle[label, $WhiteOnBlack];
Process.Pause[Process.MsecToTicks[150]];
Labels.SetDisplayStyle[label, $BlackOnWhite];
};
END.