<> <> <> <<>> 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]; TrcImpl: CEDAR MONITOR IMPORTS Abutters, AllocatorOps, Atom, Draw2d, Imager, IO, PrincOpsUtils, Process, Real, RedBlackTree, RefTab, Rope, RTTypesBasicPrivate, SafeStorage, Trc, ViewerOps, VM EXPORTS Trc, TrcViewers ~ BEGIN 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] }; <> <> <<[] _ RefTab.Store[x: classes, key: class.flavor, val: class];>> <<};>> <> <> <<[key: RefTab.Key, val: RefTab.Val] RETURNS [quit: BOOLEAN]>> <> <<};>> <<[] _ 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^; <> LOOPHOLE[newP, LONG POINTER TO LONG POINTER]^ _ NIL; <> LOOPHOLE[newP, REF REF ANY]^ _ r; <> }; 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[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] ~ { <> 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]; <> 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 <> 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[]]}; END.