Copyright (C) 1994, Digital Equipment Corp.
MODULE VBTProvider;
IMPORT RPCVBT, RootVBT, Thread, VBTTuning;
TYPE RemoteRep =
Remote OBJECT
provider: T;
METHODS (*OVERRIDES*)
connect := Connect
END;
TYPE ConnectionRep = RPCVBT.Connection OBJECT
provider: T;
root: Root
METHODS (*OVERRIDES*)
apply := ConnectionApply
END;
TYPE ProviderRep = T OBJECT
conn: RPCVBT.Connection
METHODS (* OVERRIDES *)
apply := ProviderApply
END;
TYPE Root = ProperSplit.T OBJECT
METHODS
init(): RootVBT;
(*OVERRIDES*)
beChild := BeChild;
replace := Replace;
setcage := SetCage;
setcursor := SetCursor;
paint := Paint;
sync := Sync;
readUp := ReadUp;
writeUp := WriteUp;
capture := Capture;
screenOf := ScreenOf;
newShape := NewShape;
acquire := Acquire;
release := Release;
put := Put;
forge := Forge
END;
TYPE ChildRep = RPCVBT.Child OBJECT
ch: RootVBT.Child
METHODS (*OVERRIDES*)
getCursor := ChildGetCursor;
axisOrder := ChildAxisOrder;
read
write
discard
shape
prod := ChildProd;
END;
PROCEDURE ChildProd(
ch: ChildRep;
READONLY ev: RPCVBT.Event;
startMessenger: BOOLEAN) =
BEGIN
DeliverEvent(ch.ch, ev);
IF startMessenger THEN
EVAL Thread.Fork(NEW(MessengerClosure, v := ch.ch))
END
END ChildProd;
TYPE MessengerClosure = Thread.Closure OBJECT
v: RootVBT.Child;
ev: RPCVBT.Event; (* initial event *)
METHODS (*OVERRIDES*)
apply := Messenger
END;
PROCEDURE Messenger(self: MessengerClosure): REFANY =
VAR v := self.v; ur: UpRef := v.upRef; parent := ur.parent;
dead := FALSE; cg: VBT.Cage; batch: Batch.T; seqno: Word.T;
ev := self.ev;
BEGIN
(* Set priority to TPFriends.PriIOLow *)
WHILE DeliverCode(v, ur, ev, cg, batch, seqno) DO
LOOP
TRY
IF batch = NIL THEN
ev := ur.parent.setCageAndGet(cg, seqno)
ELSE
ev := ur.parent.paintAndGet(
SUBARRAY(batch.b^, 0, BatchUtil.GetLength(batch)),
BatchUtil.GetClip(batch), batch.scrollSource,
BatchUtil.GetClipState(batch), cg, seqno)
END;
EXIT
EXCEPT
RPC.CallFailed =>
ev.type := RPCVBT.EventType.Misc;
ev.time := 0;
ev.detail := VBT.NullDetail;
ev.miscType := VBT.Disconnected;
ev.selection := VBT.SelectionOrNil.Nil;
EXIT
| Thread.Alerted => (*skip*)
END
END
END;
RETURN NIL
END Messenger;
VAR resumeLength := VBTTuning.ResumeLength;
PROCEDURE FetchCageAndBatch(
z: VBT.T;
ur: UpRef;
VAR cg: VBT.Cage;
VAR batchP: Batch.T;
VAR seqnoP: UNSIGNED); (* LL.sup = z *)
BEGIN
cg := VBTClass.Cage(z);
batchP := ur.hd;
IF batchP # NIL THEN
ur.hd := batchP.link;
DEC(ur.length);
IF ur.holdPaints AND (ur.length <= resumeLength) THEN
ur.holdPaints := FALSE;
Thread.Broadcast(ur.paintd)
END;
END;
seqnoP := ur.seqno;
ur.seqno := Word.Plus(ur.seqno, 1)
END FetchCageAndBatch;
TYPE UpRef = ProperSplit.Child OBJECT
parent: RPCVBT.Parent;
covered: CARDINAL := 0;
dead := FALSE; (* set when window is deleted. *)
deadc: Thread.Condition;
(* broadcast when window is deleted or ReleasePuts is called. *)
reallydead := FALSE; (* set when window parents are shredded. *)
reallydeadc: Thread.Condition;
(* broadcast when window parents are shredded. *)
seqno: Word.T := 0;
(* next sequence number to be used for painting or setting cage *)
hd, tl: Batch.T := NIL; (* queue of batches to be painted *)
length: INTEGER; (* length of queue *)
paintc: Thread.Condition;
(* signalled when length becomes greater than covered or
dead becomes true. Causes a worker to remove a batch and paint
it. If the expression is still true, the worker signals again,
to get more help. *)
numWorkers := 0;
hasMeterMaid := FALSE;
paintd: Thread.Condition;
(* broadcast when length becomes <= resumeLength and holdPaints *)
holdPaints := FALSE;
(* => some paint thread is waiting for paintd; hence any new
painter that paints should also wait for paintd after
enqueueing its batch *)
holdPuts := FALSE
END;
PROCEDURE BeChild(root: Root; ch: VBT.T) RAISES {} =
VAR ur: UpRef;
BEGIN
IF ch.upRef = NIL THEN
ur := NEW(UpRef);
ch.upRef := ur
ELSE
ur := ch.upRef
END;
ch.parent := root;
ur.ch := ch;
ur.deadc := NEW(Thread.Condition);
ur.reallydeadc := NEW(Thread.Condition);
ur.paintc := NEW(Thread.Condition);
ur.paintd := NEW(Thread.Condition);
END BeChild;
N.B. we do not call ProperSplit.T.beChild, because the children
of a RootVBT can have different screentypes.
PROCEDURE ToRemote(provider: T): Remote =
BEGIN
RETURN NEW(Remote, provider := provider)
END ToRemote;
PROCEDURE FromRemote(r: Remote): T =
BEGIN
TRY
RETURN NEW(ProviderRep, conn := r.connect())
EXCEPT
RPC.CallFailed => RAISE Error("RPC call failure")
END
END FromRemote;
PROCEDURE Connect(rem: RemoteRep): Connection =
BEGIN
RETURN NEW(ConnectionRep, provider := rem.provider,
root := NEW(Root).init())
END Connect;
PROCEDURE ProviderApply(provider: ProviderRep; t: TEXT): VBT.T =
VAR
prnt := NEW(ParentRep).init();
ch := provider.conn.apply(t, prnt);
BEGIN
prnt.ch := ch;
RETURN prnt
END ProviderApply;
PROCEDURE ConnectionApply(
self:ConnectionRep;
txt: TEXT;
prnt: RPCVBT.Parent): RPCVBT.Child
RAISES {VBTProvider.Error} =
BEGIN
LOCK VBT.mu DO
WITH child = RootVBT.NewChild(self.provider.apply(txt)) DO
LOCK child DO
LOCK self.root DO
ProperSplit.Insert(self.root, NIL, child)
END;
VAR ur: UpRef := child.upRef; BEGIN
ur.parent := prnt
END
END;
RETURN NEW(ChildRep, ch := child)
END
END
END ConnectionApply;
TYPE StubT = T OBJECT
rmt: Remote
METHODS (*OVERRIDES*)
apply := StubApply
END
PROCEDURE FromRemote(r: Remote): T =
BEGIN
RETURN NEW(StubT, rmt := r)
END;
PROCEDURE StubApply(
END VBTProvider.