DIRECTORY
Trc, TrcViewers,
Abutters USING [Create, QuaViewer, vanilla],
Allocator USING [bsiEscape, EHeaderP, ExtendedHeader, NHeaderP, NormalHeader],
AllocatorOps USING [bsiToSize, NewObject, REFToNHP],
Atom USING [GetPName],
Draw2d USING [Line],
Imager USING [DoSaveAll, --MaskVector,-- Rectangle, Scale2T, SetStrokeEnd, SetStrokeJoint, SetStrokeWidth, TranslateT],
IO USING [GetAtom, PutF, STREAM],
PrincOpsUtils USING [LongCopy],
Process USING [Detach, priorityBackground, SetPriority, Yield],
Real USING [RoundC],
RedBlackTree,
RefTab USING [Create, Delete, EachPairAction, GetSize, Pairs, Ref, Store],
Rope USING [Compare, Concat],
RTTypesBasicPrivate USING [MapRefOffsets],
SafeStorage USING [GetReferentType],
TIPUser USING [TIPScreenCoords],
Vector2 USING [VEC],
ViewerClasses USING [DestroyProc, ModifyProc, NotifyProc, PaintProc, SaveProc, Viewer, ViewerClass, ViewerClassRec],
ViewerOps USING [AddProp, CreateViewer, FetchProp, PaintViewer, RegisterViewerClass],
VM USING [WordsForPages];
OPEN Trc;
STREAM: TYPE ~ IO.STREAM;
GetClass: RedBlackTree.GetKey = {
[data: RedBlackTree.UserData] RETURNS [RedBlackTree.Key]
RETURN [NARROW[data, Class].flavor];
};
CompareClasses: RedBlackTree.Compare = {
[k: RedBlackTree.Key, data: RedBlackTree.UserData] RETURNS [Basics.Comparison]
RETURN [Rope.Compare[
s1: Atom.GetPName[NARROW[k, ATOM]],
s2: Atom.GetPName[NARROW[data, Class].flavor],
case: FALSE
]];
};
classes: RedBlackTree.Table ~ RedBlackTree.Create[getKey: GetClass, compare: CompareClasses];
RegisterClass:
PUBLIC PROC [class: Class] ~ {
RedBlackTree.Insert[self: classes, dataToInsert: class, insertKey: class.flavor];
};
EnumerateRegisteredClasses:
PUBLIC PROC [proc: ClassEnumProc] ~ {
EachClass: RedBlackTree.EachNode = {
[data: RedBlackTree.UserData] RETURNS [stop: BOOL ← FALSE]
stop ← proc[NARROW[data]];
};
RedBlackTree.EnumerateIncreasing[self: classes, procToApply: EachClass]
};
classes: RefTab.Ref ~ RefTab.Create[];
RegisterClass: PUBLIC PROC [class: Class] ~ {
[] ← RefTab.Store[x: classes, key: class.flavor, val: class];
};
EnumerateRegisteredClasses: PUBLIC PROC [proc: ClassEnumProc] ~ {
EnumClasses: RefTab.EachPairAction = {
[key: RefTab.Key, val: RefTab.Val] RETURNS [quit: BOOLEAN]
RETURN [proc[NARROW[val, Class]]];
};
[] ← RefTab.Pairs[x: classes, action: EnumClasses];
};
PickleArbitraryTrc:
PUBLIC
PROC [trc:
TRC, stream:
STREAM, indentation:
ROPE ←
NIL] ~ {
IO.PutF[stream: stream, format: "\n%g%g\t", v1: [rope[indentation]], v2: [atom[trc.class.flavor]]];
Trc.Pickle[trc: trc, stream: stream, indentation: Rope.Concat[indentation, "\t"]];
};
DepickleArbitraryTrc:
PUBLIC PROC [stream:
STREAM]
RETURNS [trc:
TRC] ~ {
flavor: ATOM ~ IO.GetAtom[stream: stream];
class: Trc.Class ~ Trc.ClassFromFlavor[flavor: flavor];
trc ← Trc.Depickle[class: class, stream: stream];
};
DefaultBlockFcn:
PUBLIC BlockFcn ~
UNCHECKED {
FOR k:
NAT
IN [0..count)
DO
to[k] ← trc.class.fcn[trc, from[k]];
ENDLOOP;
};
DefaultCopy:
PUBLIC CopyProc = {
[trc: TRC] RETURNS [new: TRC]
new ← NEW[TRCRep ← [class: trc.class, instance: NewRef[trc.instance], listener: NIL]];
};
DefaultPickle: PUBLIC PickleProc ~ {};
DefaultDepickle:
PUBLIC DepickleProc ~ {
RETURN [NEW[TRCRep ← [class: class, instance: NIL]]]
};
DefaultNotify: PUBLIC NotifyProc ~ {};
DefaultBackground: PUBLIC BackgroundProc ~ {};
DefaultControl:
PUBLIC BuildControlViewerProc = {
[trc: TRC, info: ViewerClasses.ViewerRec] RETURNS [viewer: ViewerClasses.Viewer]
viewer ← Abutters.Create[viewerFlavor: Abutters.vanilla, info: info, paint: paint].QuaViewer[];
};
NewRef:
PROC [old:
REF]
RETURNS [new:
REF] ~
TRUSTED {
UsableWords:
UNSAFE
PROC [ref:
REF]
RETURNS [size:
INT] ~
UNCHECKED {
OPEN Allocator;
ExtendedBlockSize:
UNSAFE
PROC [ehp: EHeaderP]
RETURNS [words:
INT ← 0] =
UNCHECKED
INLINE {
SELECT ehp.sizeTag
FROM
words => words ← ehp.extendedSize;
pages => words ← VM.WordsForPages[ehp.extendedSize];
ENDCASE => ERROR;
};
NHPToEHP:
UNSAFE
PROC [nhp: NHeaderP]
RETURNS [EHeaderP] =
INLINE {
RETURN [LOOPHOLE[nhp - (SIZE[ExtendedHeader] - SIZE[NormalHeader]), EHeaderP]];
};
nhp: NHeaderP ~ AllocatorOps.REFToNHP[ref];
IF nhp.blockSizeIndex # Allocator.bsiEscape
THEN RETURN [AllocatorOps.bsiToSize[nhp.blockSizeIndex] - SIZE[NormalHeader]]
ELSE RETURN [ExtendedBlockSize[NHPToEHP[nhp]] - SIZE[ExtendedHeader]];
};
EachContainedRef:
UNSAFE
PROC [offset:
LONG
CARDINAL] ~ {
newP: LONG POINTER = LOOPHOLE[new, LONG POINTER] + offset;
oldP: LONG POINTER TO REF = LOOPHOLE[old, LONG POINTER] + offset;
r:
REF = oldP^;
this ref will be in both newP^ and oldP^
LOOPHOLE[newP,
LONG
POINTER
TO
LONG
POINTER]^ ←
NIL;
NIL the destination to force the following AssignRef to increment the ref
LOOPHOLE[newP,
REF
REF
ANY]^ ← r;
force AssignRef by faking out the compiler
};
IF old=
NIL
THEN
RETURN [
NIL]
ELSE {
count: CARDINAL ~ UsableWords[old];
new ← AllocatorOps.NewObject[type: SafeStorage.GetReferentType[old], size: count];
PrincOpsUtils.LongCopy[from: LOOPHOLE[old], nwords: count, to: LOOPHOLE[new]];
RTTypesBasicPrivate.MapRefOffsets[ref: old, procLeaf: EachContainedRef]; --Copy the contained REFs by hand to maintain proper reference counts
};
};
ClassFromFlavor: PUBLIC PROC [flavor: ATOM] RETURNS [class: Class] ~ {
RETURN [NARROW[RefTab.Fetch[x: classes, key: flavor].val]];
};
ClassFromFlavor:
PUBLIC PROC [flavor:
ATOM]
RETURNS [class: Class] ~ {
RETURN [NARROW[RedBlackTree.Lookup[self: classes, lookupKey: flavor]]];
};
Registration: TYPE ~ RECORD [trc: TRC, listener: Listener];
InstallListener:
PUBLIC PROC [trc:
TRC, listener: Listener]
RETURNS [registration:
REF] ~ {
trc.listener ← CONS[listener, trc.listener];
RETURN [NEW[Registration ← [trc, listener]]];
};
DeinstallListener:
PUBLIC PROC [registration:
REF] ~ {
Blechh!!!
reg: REF Registration ~ NARROW[registration];
new: LIST OF Listener ← NIL;
FOR each:
LIST
OF Listener ← reg.trc.listener, each.rest
UNTIL each=
NIL
DO
IF each.first#reg.listener THEN new ← CONS[each.first, new];
ENDLOOP;
reg.trc.listener ← new;
};
NotifyListeners:
PUBLIC PROC [trc:
TRC, fork:
BOOL ←
FALSE] ~ {
FOR each:
LIST
OF Listener ← trc.listener, each.rest
UNTIL each=
NIL
DO
IF fork
THEN
TRUSTED {
Process.Detach[FORK each.first.proc[trc: trc, listenerData: each.first.listenerData]];
}
ELSE {
each.first.proc[trc: trc, listenerData: each.first.listenerData];
};
ENDLOOP;
};
BuildTable:
PUBLIC PROC [nElements:
NAT, first, delta:
REAL]
RETURNS [table: Table] ~ {
table ← NEW[TableRep[nElements]];
FOR k:
NAT
IN [0..nElements)
DO
table[k] ← first + delta*k;
ENDLOOP;
};
UnsafeTableFromTable:
PUBLIC
PROC [table: Table, start, count:
NAT ← 0]
RETURNS [unsafeTable: UnsafeTable] ~
TRUSTED {
IF count=0 THEN count ← table.n-start;
IF start+count > table.n THEN ERROR;
RETURN [LOOPHOLE[@table[start]]];
};
Display:
TYPE ~
REF DisplayRep;
DisplayRep:
TYPE ~
RECORD [
trc: TRC,
rectangle: Imager.Rectangle,
dx: REAL,
listenerRegistration: REF,
clientData: REF
];
CreateTRCViewer:
PUBLIC PROC [trc:
TRC, rectangle: Rectangle, dx:
REAL, info: ViewerRec, paint:
BOOL ←
TRUE]
RETURNS [viewer: Viewer] ~ {
display: Display ~
NEW[DisplayRep ← [
trc: trc,
rectangle: rectangle,
dx: dx,
clientData: info.data
]];
info.data ← display;
info.scrollable ← info.hscrollable ← FALSE;
IF info.tipTable=NIL THEN info.tipTable ← trc.class.tipTable;
viewer ← ViewerOps.CreateViewer[flavor: $Trc, info: info, paint: paint];
ViewerOps.AddProp[viewer: viewer, prop: $DeferIfCPUAbove, val: Trc.FetchProp[viewer: viewer, prop: $DeferIfCPUAbove]]; --If some ancestor viewer of ours (obviously not a trc viewer itself, has a $DeferIfCPUAbove hanging on it, we want to hang it here, so that at paint time, we don't have to go looking all over for it...
IF trc.class.tipTable#NIL THEN viewer.tipTable ← trc.class.tipTable;
display.listenerRegistration ← InstallListener[trc: trc, listener: [proc: TrcViewerListener, listenerData: viewer]];
IF paint THEN ViewerOps.PaintViewer[viewer: viewer, hint: all];
};
NewTrc:
PUBLIC PROC [viewer: Viewer, trc:
TRC, paint:
BOOL ←
TRUE] ~ {
display: Display ~ NARROW[viewer.data];
Trc.DeinstallListener[display.listenerRegistration];
display.trc ← trc;
display.listenerRegistration ← InstallListener[trc: trc, listener: [proc: TrcViewerListener, listenerData: viewer]];
IF paint THEN ViewerOps.PaintViewer[viewer: viewer, hint: all];
viewer.tipTable ← trc.class.tipTable;
};
InfoFromTRCViewer:
PUBLIC
PROC [viewer: Viewer]
RETURNS [trc:
TRC, rectangle: Rectangle, dx:
REAL, clientData:
REF] ~ {
display: Display ~ NARROW[viewer.data];
RETURN [trc: display.trc, rectangle: display.rectangle, dx: display.dx, clientData: display.clientData]
};
ResetTRCViewer:
PUBLIC
PROC [viewer: Viewer, rectangle: Rectangle, dx:
REAL, clientData:
REF] ~ {
display: Display ~ NARROW[viewer.data];
display^ ← [trc: display.trc, rectangle: rectangle, dx: dx, clientData: clientData];
};
VecFromTIPCoords:
PUBLIC PROC [viewer: Viewer, coords: TIPUser.TIPScreenCoords]
RETURNS [vec: Vector2.
VEC] ~ {
display: Display ~ NARROW[viewer.data];
RETURN [ Vector2.VEC [x: display.rectangle.x+display.rectangle.w*coords.mouseX/viewer.cw, y: display.rectangle.y+display.rectangle.h*coords.mouseY/viewer.ch]];
};
FetchProp:
PUBLIC PROC [viewer: Viewer, prop:
ATOM]
RETURNS [val:
REF
ANY] ~ {
FOR v: Viewer ← viewer, v.parent
UNTIL v=
NIL
DO
val ← ViewerOps.FetchProp[viewer: v, prop: prop];
IF val#
NIL
THEN
WITH val
SELECT
FROM
eval: PropEvaluator => RETURN [eval.proc[viewer, prop, eval.data]];
ENDCASE => RETURN [val];
ENDLOOP;
RETURN [NIL];
};
TrcViewerListener:
ENTRY ListenerProc = {
[trc: TRC, listenerData: REF ANY]
ENABLE UNWIND => NULL;
[] ← RefTab.Store[x: toPaint, key: listenerData, val: NIL];
NOTIFY timeToPaint;
};
toPaint: RefTab.Ref ~ RefTab.Create[];
timeToPaint: CONDITION;
PaintTrcViewers:
ENTRY
PROC ~
TRUSTED {
--A process runs this proc in background
ENABLE UNWIND => NULL;
Process.SetPriority[Process.priorityBackground];
DO
PaintAndRemoveFromTable: RefTab.EachPairAction =
TRUSTED {
[key: RefTab.Key, val: RefTab.Val] RETURNS [quit: BOOLEAN]
Process.Yield[];
[] ← RefTab.Delete[x: toPaint, key: key];
Process.Detach[FORK ViewerOps.PaintViewer[viewer: NARROW[key, Viewer], hint: client]];
ViewerOps.PaintViewer[viewer: NARROW[key, Viewer], hint: client];
RETURN [FALSE];
};
UNTIL RefTab.GetSize[x: toPaint] > 0
DO
WAIT timeToPaint;
ENDLOOP;
[] ← RefTab.Pairs[x: toPaint, action: PaintAndRemoveFromTable];
ENDLOOP;
};
TrcNotify: ViewerClasses.NotifyProc = {
[self: ViewerClasses.Viewer, input: LIST OF REF ANY]
display: Display ~ NARROW[self.data];
display.trc.class.notify[viewer: self, trc: display.trc, input: input];
};
TrcPaint: ViewerClasses.PaintProc = {
[self: ViewerClasses.Viewer, context: Imager.Context, whatChanged: REF ANY, clear: BOOL] RETURNS [quit: BOOL ← FALSE]
PaintBackground:
PROC ~ {
Trc.PaintBackground[trc: display.trc, context: context, rectangle: display.rectangle, whatChanged: whatChanged];
};
display: Display ~ NARROW[self.data];
Imager.Scale2T[context: context, s: [x: self.cw/display.rectangle.w, y: self.ch/display.rectangle.h]];
Imager.TranslateT[context: context, t: [x: display.rectangle.x, y: display.rectangle.y]];
Imager.SetStrokeEnd[context: context, strokeEnd: butt];
Imager.SetStrokeJoint[context: context, strokeJoint: mitered];
Imager.SetStrokeWidth[context: context, strokeWidth: 2*display.rectangle.w/self.cw];
Imager.DoSaveAll[context: context, action: PaintBackground];
Imager.SetStrokeWidth[context: context, strokeWidth: --2*display.rectangle.w/self.cw-- 0.0];
IF whatChanged=
NIL
THEN
TRUSTED {
--Actually paint the trc itself...
nElements: NAT ~ 1+MIN[self.cw, Real.RoundC[display.rectangle.w/display.dx]];
delta: REAL ~ display.rectangle.w/nElements;
from: Table ~ BuildTable[nElements: nElements, first: display.rectangle.x, delta: delta];
to: Table ~ NEW[TableRep[nElements]];
last, this: VEC;
from[nElements-1] ← display.rectangle.x + display.rectangle.w;
ApplyBlockFcn[trc: display.trc, from: UnsafeTableFromTable[from], to: UnsafeTableFromTable[to], count: nElements];
last ← [x: from[0], y: to[0]];
FOR k:
NAT
IN [1..nElements)
DO
Imager.MaskVector[context: context, p1: last, p2: this ← [x: from[k], y: to[k]]];
Draw2d.Line[context: context, vec0: last, vec1: this ← [x: from[k], y: to[k]]];
last ← this;
ENDLOOP;
};
};
TrcModify: ViewerClasses.ModifyProc = {
[self: ViewerClasses.Viewer, change: ViewerClasses.ModifyAction]
Body
};
TrcDestroy: ViewerClasses.DestroyProc = {
[self: ViewerClasses.Viewer]
display: Display ~ NARROW[self.data];
DeinstallListener[registration: display.listenerRegistration];
display.trc ← NIL
};
TrcSave: ViewerClasses.SaveProc = {
[self: ViewerClasses.Viewer, force: BOOL ← FALSE]
Body
};
trcViewerClass: ViewerClasses.ViewerClass ~
NEW[ViewerClasses.ViewerClassRec ← [
flavor: $Trc,
notify: TrcNotify,
paint: TrcPaint,
modify: TrcModify,
destroy: TrcDestroy,
save: TrcSave,
cursor: crossHairsCircle,
icon: private
]];
ViewerOps.RegisterViewerClass[flavor: $Trc, class: trcViewerClass];
TRUSTED {Process.Detach[FORK PaintTrcViewers[]]};