Syntax10.Scn.FntSyntax14b.Scn.Fnt Syntax10i.Scn.FntMarkElemsAlloc!IStampElemsAlloc25 May 97qInfoElemsAllocVSyntax10.Scn.Fnt`=IStampElemsAlloc25 May 97"Title": HeapInspector "Author": Martin Rammerstorfer (MR) "Abstract": Displays the Oberon heap as a bitmap showing allocated and free blocks. Blocks of a specified type are displayed in a special colour. Statistics about the types of all objects on the heap and about the number of objects are provided. "Keywords": Heap, inspecting data at run time, typed memory "Version": 1 "From": 28.06.96 15:14:03 "Until":  "Changes": no changes "Hints":HpVersionElemsAllocBeg#Syntax10.Scn.FntWindows PowerMacWindowsWindows PowerMac#Syntax10.Scn.FntAA<== Click here to change version of HeapInspector (now: PowerMac) @pVersionElemsAllocEndSyntax12b.Scn.Fnt`PopupElemsAllocStart HeapInspector<Syntax10.Scn.FntSyntax10b.Scn.Fnt HeapInspector.HeapMap ^Syntax10b.Scn.Fnt."HeapInspector-Documentation#Syntax10.Scn.FntEdit.Open HeapInspector.Text ~Qp#Syntax10.Scn.FntWindows PowerMacWindowsWindows PowerMacZSyntax12b.Scn.FntWP4PopupElemsAllocHeapInspectorSyntax10.Scn.FntSyntax10b.Scn.Fnt     HeapInspector.HeapMap ^ ~ HeapInspector.HeapMarkObjects ^ ~ HeapInspector.HeapUpdate HeapInspector.Close HeapInspViewers.Modules HeapInspViewers.ObjectsByModule HeapInspViewers.ObjectsByType HeapInspViewers.ModuleReachableTypes ^~ HeapInspViewers.Imports HeapInspViewers.ModuleHierarchy HeapInspViewers.TypeHierarchy HeapInspector.Show Moduleless HeapInspector.Status HeapInspector.UpdateModules HeapInspector.TestUnloadModules ^~ HeapInspViewers.Help Documentation ~ HeapInspViewers.Help Code ~HeapInspector*Syntax10.Scn.FntSyntax10b.Scn.Fnt      HeapInspector.HeapMap ^ ~ HeapInspector.HeapMarkObjects ^ ~ HeapInspector.HeapUpdate HeapInspector.Close HeapInspViewers.Modules HeapInspViewers.ObjectsByModule HeapInspViewers.ObjectsByType HeapInspViewers.ModuleReachableTypes ^~ HeapInspViewers.Imports HeapInspViewers.ModuleHierarchy HeapInspViewers.TypeHierarchy HeapInspTracer.Trace ^~ HeapInspector.Show Moduleless HeapInspector.Status HeapInspector.UpdateModules HeapInspector.TestUnloadModules ^~ HeapInspViewers.Help Documentation ~ HeapInspViewers.Help Code ~pgp#Syntax10.Scn.FntWindows PowerMacWindowsWindows PowerMac>Syntax10b.Scn.FntQ@ PopupElemsAllocCompile<Syntax10.Scn.FntSyntax10b.Scn.Fnt^lFolds.Compile Platform.Mod/s Inspector.Mod/s HeapInspDescs.Mod/s HeapInspector.Mod/s HeapInspViewers.Mod/s ~m Free Modules<Syntax10.Scn.Fnt Syntax10b.Scn.Fnt@KSystem.Free HeapInspViewers HeapInspector HeapInspDescs Inspector Platform~ P AsciiCoder.CodeFiles#Syntax10.Scn.FntAsciiCoder.CodeFiles % HeapInspViewers.Mod HeapInspector.Mod HeapInspDescs.Mod Inspector.Mod Platform.Mod HeapInspector.Menu.Text HeapInspector.Text HeapInspector.Tool ~g@ Edit Files of HeapInspectorSyntax10.Scn.Fnt Syntax10b.Scn.Fnt        Edit.Open HeapInspector.Mod Edit.Open HeapInspViewers.Mod Edit.Open HeapInspDescs.Mod Edit.Open Inspector.Mod Edit.Open Platform.Mod Edit.Open HeapInspector.Menu.Text Edit.Open HeapInspector.Text Edit.Open HeapInspector.Tool   <`=P4Compile<Syntax10.Scn.FntSyntax10b.Scn.FntsFolds.Compile Platform.Mod/s Inspector.Mod/s HeapInspDescs.Mod/s HeapInspector.Mod/s HeapInspViewers.Mod/s HeapInspTracer.Mod/s ~^@ P4Free Modules<Syntax10.Scn.Fnt Syntax10b.Scn.FntOZSystem.Free HeapInspViewers HeapInspector HeapInspDescs Inspector HeapInspTracer Platform~ P4AsciiCoder.CodeFiles#Syntax10.Scn.FntAsciiCoder.CodeFiles % HeapInspViewers.Mod HeapInspector.Mod HeapInspDescs.Mod Inspector.Mod HeapInspTracer.Mod Platform.Mod HeapInspector.Menu.Text HeapInspector.Text HeapInspector.Tool ~<P4Edit Files of HeapInspectorSyntax10.Scn.Fnt Syntax10b.Scn.Fnt         Edit.Open HeapInspector.Mod Edit.Open HeapInspViewers.Mod Edit.Open HeapInspDescs.Mod Edit.Open Inspector.Mod Edit.Open HeapInspTracer.Mod Edit.Open Platform.Mod Edit.Open HeapInspector.Menu.Text Edit.Open HeapInspector.Text Edit.Open HeapInspector.Toolp8FoldElemsNew#Syntax10.Scn.Fnt S := SYSTEM, System, Kernel, Types, Ref, MenuViewers, TextFrames, Texts, Oberon, Display, PElems, Input, In, PopupElems, Fonts, Viewers, Out, Bitmaps, Modules, FoldElems, Strings, X := Platform, Inspector, Descs := HeapInspDescs, MW := MsgWindows;88QSyntax10.Scn.FntSyntax10b.Scn.Fnt T R HeapInspector = "Heap - Inspector"; Authors = "Author: Martin Rammerstorfer"; Version = "Version: 1.00 (Beta-version)"; Project = "A project at the SSW-Institute (JKU-Linz)"; Stars = "*****************************"; B = X.B; BlockSize* = B; MM = 1; MR = 0; ML = 2; MapMinHeight = 16; MapMaxHeightDiff = 50; SelPatternLength = 100; arrayBit = X.arrayBit; markBit = X.markBit; TAB = 09X; LN = 13; ESC = 27; red = 1; darkred = 7; green = 2; darkgreen = 8; blue = 3; darkblue = 9; magenta = 4; yellow = 5; lightblue = 10; darkcyan = 11; NrOfColors = 5; MaxMarked = NrOfColors; black = 15; white = 0; grey0 = 12; grey1 = 13; grey2 = 14; invert = -2; (* object = 0; *)other = X.TObj; free = X.TFree; array = X.TArrP; typeDesc = X.TTypDesc; sysBlock = X.TSysBl; this = 10; module = 11; trace = 12; onlyAnchored = 13; None = 0; NotFound* = -1; NotDef = -1; Error = -1; Illegal = -1; TraceOK = 0; TraceNIL = 1; ModNotFound = 2; VarNotFound = 3; IndexOverflow = 4; ModuleSelected = 5; NotAPointer = 6; NoValidVar = 7; OnlyAnchoredByOK = 8; Changed = 9; CurUp = ''; CurLeft = ''; CurDown = ''; CurRight = ''; PageUp = ''; PageDown = ''; PagePos1 = ''; PageEnd = ''; 88 Syntax10.Scn.Fnt8FoldElemsNew#Syntax10.Scn.Fnt,, ElemDesc = RECORD (PElems.ElemDesc) END ; 8M8#Syntax10.Scn.Fnt mod: ARRAY 32 OF CHAR; type: ARRAY 32 OF CHAR; nrOfObjs, size, maxSize, totalSize, maxLevel, minLevel: LONGINT; derived: BOOLEAN; END; 8I8#Syntax10.Scn.Fnt)) Blockm4Set = RECORD tag: SET; END ; 88#Syntax10.Scn.Fnt objs, size: LONGINT; END; 8S8Syntax10.Scn.FntSyntax10i.Scn.Fnt%5/:$:+ MG;D!='= col3, col2: INTEGER; (* Coloring of objects on the heap *) redrawPic: BOOLEAN; (* Should the whole frame redrawn at next update ? *) picMaxHeight, picWidth, picHeight: LONGINT; (* Sizes of bitmaps *) mapMaxHeight: LONGINT; (* Max size of bitmap (corresponding to Display.Height) *) pointW, pointH: INTEGER; (* Size of a block in the bitmaps *) peAll, peNotMarked, peMarked, peReach, peSelect: Elem; (* Pointer to pictureelems *) pMarked, pReach, pSelect, pRemain: Map; (* Heapmap as an array of SET *) drwAll, drwNotMarked, drwMarked, drwReach, drwSelect, drwFreeze: BOOLEAN; (* Draw picture on/off *) reachedFrom: BOOLEAN; (* Modes of VisHeapReach: object reaches (F) / object is reached (T) *) reachedFMod: BOOLEAN; (* Print modules which reaches the object with a pointer *) reachedFVar: BOOLEAN; (* Print global variables which reaches the object with a pointer *) onlyMarked: BOOLEAN; (* Show only marked objects *) remaining: BOOLEAN; (* Show only remaining objects *) objSizes: BOOLEAN; (* Shows a textual statisic of sizes from existing objects *) defBlockCol, defBlockShow: BOOLEAN; (* Shows typedescriptors, array- and sysblocks (colorized) *) END; 88QSyntax10.Scn.FntbSyntax10i.Scn.Fnt%v'+ cAll, cMark, cReach, cSel: StatCountDesc; cModLess, cArr, cSys, cType, cFree: StatCountDesc; (* Statistics of different objects *) frag, all, avail: LONGINT; objSizes: ARRAY 20 OF LONGINT; t: ARRAY MaxMarked OF TypeNDesc; nrOfTypeN: INTEGER; (* Selected types for colorized draw *) END; 88QSyntax10.Scn.FntSyntax10i.Scn.Fnt"1"* pattern: ARRAY SelPatternLength OF CHAR; mod, type: ARRAY 34 OF CHAR; pos: LONGINT; kind: INTEGER; traceResult, lastTResult: INTEGER; traceAdr, lastTAdr: LONGINT; (* Result of tracing a variable *) traceResName: ARRAY SelPatternLength OF CHAR; (* Error-string from last trace *) END; 88#Syntax10.Scn.Fnt!! width, height: INTEGER; END; 88QSyntax10.Scn.FntOSyntax10b.Scn.Fnt P w*: Texts.Writer; (*oldVwr: Viewers.Viewer;*) parc2: TextFrames.Parc; cmdStore-, cmdSClose- (*, cmdDocu-*): PopupElems.Elem; hItxt: Texts.Text; menuViewer: MenuViewers.Viewer; END; 8 Elem = POINTER TO ElemDesc;  TypeNDesc = RECORD  Map = POINTER TO ARRAY OF SET; Blockm4SetPtr = POINTER TO Blockm4Set;  StatCountDesc = RECORD  MapDesc = RECORD  StatisticDesc = RECORD  SelectDesc = RECORD  SplashWindow = RECORD  TextDesc = RECORD  8Z8Syntax10.Scn.FntSyntax10b.Scn.Fnt Syntax10i.Scn.Fnt3  ./%?- mods-: Descs.ModDesc; types-: Descs.TypeInfoDesc; t-: TextDesc; (* Data for text and viewer dependent operations *) printHex-: BOOLEAN; (* TRUE => print addresses, ... hexadecimal *) zoomStart, zoomEnd: LONGINT; (* Blocknumber where heapmap begins and ends *) unloadModDesc: BOOLEAN; reachName, reachType, reachModule: ARRAY 32 OF CHAR; reachPtr: Kernel.Block; sel: SelectDesc; v: MapDesc; s: StatisticDesc; oldHandler: Display.Handler; (* Old handling-routine for viewer *) splash: SplashWindow; visHSSavePtr, visHSSavePtrR: LONGINT; (* Used in VisHeapSelected - SelectOnlyAnchoredBy to save a pointer, because of Garbage-Collector, saving onto stack not possible *) index: LONGINT; menuBuffer: Texts.Buffer; 8d8cSyntax10.Scn.FntSyntax10i.Scn.Fnt Syntax10b.Scn.Fnt : (* Forward declarations *) PROCEDURE ^HeapUpdate*; PROCEDURE ^SetPtrReach (p: Kernel.Block); PROCEDURE ^VisHeapReachable (); PROCEDURE ^Handler (f: Display.Frame; VAR m: Display.FrameMsg); PROCEDURE ^MoveMap (val: LONGINT; relative, center: BOOLEAN); PROCEDURE ^ElemHandler (e: Texts.Elem; VAR m: Texts.ElemMsg); 8r8 Syntax10.Scn.FntSyntax10i.Scn.FntMarkElemsAlloc'!! 8FoldElemsNew#Syntax10.Scn.Fnt BEGIN sel.pattern := ""; sel.mod := ""; sel.type := ""; sel.pos := 0; sel.kind := NotDef; sel.traceResult := Changed; sel.lastTResult := Changed; sel.lastTAdr := S.VAL (LONGINT, NIL); sel.traceAdr := sel.lastTAdr END Reset; 8"kKv8#Syntax10.Scn.Fnthh VAR i: INTEGER; BEGIN FOR i := 0 TO LEN(s.objSizes) - 1 DO s.objSizes [i] := 0 END END InitBlockInfo; 8"kK!98#Syntax10.Scn.Fnt VAR b, i: LONGINT; BEGIN b := 32; i := 0; WHILE b < size DO b := b * 2; INC (i) END; IF i < LEN (s.objSizes) THEN INC (s.objSizes [i]) END END UpdateBlockInfo; 8"©f8QSyntax10.Scn.FntSyntax10i.Scn.FntJ VAR i: INTEGER; BEGIN s.cAll.objs := 0; s.cAll.size := 0; s.cMark.objs := 0; s.cMark.size := 0; s.cReach.objs := 0; s.cReach.size := 0; s.cSel.objs := 0; s.cSel.size := 0; s.cModLess.objs := 0; s.cModLess.size := 0; s.cArr.objs := 0; s.cArr.size := 0; s.cSys.objs := 0; s.cSys.size := 0; s.cType.objs := 0; s.cType.size := 0; s.cFree.objs := 0; s.cFree.size := 0; s.frag := 0; s.avail := 0; s.all := 0; IF selTypes THEN (* Reset selected names *) FOR i := 0 TO MaxMarked - 1 DO s.t [i].mod := ""; s.t [i].type := ""; s.t [i].derived := FALSE END; s.nrOfTypeN := 0 END; FOR i := 0 TO MaxMarked - 1 DO (* Reset statistic-values *) s.t [i].nrOfObjs := 0; s.t [i].totalSize := 0; s.t [i].size := NotDef; s.t [i].maxSize := NotDef; s.t [i].minLevel := NotDef; s.t [i].maxLevel := NotDef END; s.InitBlockInfo () END Reset; 8j 8#Syntax10.Scn.Fnt&& BEGIN v.redrawPic := TRUE; v.picMaxHeight := 220; v.peAll := NIL; v.peNotMarked := NIL; v.peMarked := NIL; v.peReach := NIL; v.peSelect := NIL; v.pMarked := NIL; v.pReach := NIL; v.pSelect := NIL; v.pRemain := NIL; v.drwAll := TRUE; v.drwMarked := FALSE; v.drwNotMarked := FALSE; v.drwReach := FALSE; v.drwSelect := FALSE; v.drwFreeze := FALSE; v.reachedFrom := FALSE; v.reachedFMod := FALSE; v.reachedFMod := FALSE; v.onlyMarked := FALSE; v.remaining := FALSE; v.objSizes := FALSE; v.defBlockCol := FALSE; v.defBlockShow := TRUE END Reset; 8HM k8#Syntax10.Scn.Fntss VAR j: LONGINT; BEGIN IF map # NIL THEN FOR j := 0 TO LEN (map^) - 1 DO map [j] := {} END END; END ClearMap; 85|8#Syntax10.Scn.Fntbb BEGIN v.ClearMap (v.pMarked); v.ClearMap (v.pReach); v.ClearMap (v.pSelect) END ClearAllMaps; 8!>8#Syntax10.Scn.Fnt VAR handle: Texts.Handler; BEGIN IF set THEN handle := ElemHandler ELSE handle := PElems.Handler END; IF v.peAll # NIL THEN v.peAll.handle := handle END; IF v.peNotMarked # NIL THEN v.peNotMarked.handle := handle END; IF v.peMarked # NIL THEN v.peMarked.handle := handle END; IF v.peReach # NIL THEN v.peReach.handle := handle END; IF v.peSelect # NIL THEN v.peSelect.handle := handle END END PicHandlerSet; 8 (* Procedures for reset and set of data *) PROCEDURE (VAR sel: SelectDesc) Reset ();  PROCEDURE (VAR s: StatisticDesc) InitBlockInfo ();  PROCEDURE (VAR s: StatisticDesc) UpdateBlockInfo (size: LONGINT);  PROCEDURE (VAR s: StatisticDesc) Reset (selTypes: BOOLEAN);  PROCEDURE (VAR v: MapDesc) Reset ();  PROCEDURE (VAR v: MapDesc) ClearMap (VAR map: Map);  PROCEDURE (VAR v: MapDesc) ClearAllMaps ();  PROCEDURE (VAR v: MapDesc) PicHandlerSet (set: BOOLEAN);  Syntax10m.Scn.Fnt88y Syntax10.Scn.FntSyntax10i.Scn.FntMarkElemsAlloc9 +J8FoldElemsNew#Syntax10.Scn.Fnt VAR i, mPos, blockEnd, sizeR, hSize: LONGINT; BEGIN blockEnd := pos + sizeB; hSize := X.GetHeapSize (); IF (blockEnd > 0) & (pos < hSize DIV B) THEN mPos := pos; IF blockEnd > hSize DIV B THEN blockEnd := hSize DIV B END; IF mPos <= 0 THEN sizeR := pos + sizeB; mPos := 0 ELSE sizeR := sizeB END; i := 0; WHILE (i < sizeR) & ((pos + i) < blockEnd) DO EXCL (smap [(mPos + i) DIV 32], (mPos + i) MOD 32); INC (i) END END END MapAllDelete; 8 +I8#Syntax10.Scn.Fnt   VAR i, mPos, blockEnd, sizeR, hSize: LONGINT; BEGIN blockEnd := pos + sizeB; hSize := X.GetHeapSize (); IF (blockEnd > 0) & (pos < hSize DIV B) THEN mPos := pos; IF blockEnd > hSize DIV B THEN blockEnd := hSize DIV B END; IF mPos <= 0 THEN sizeR := pos + sizeB; mPos := 0 ELSE sizeR := sizeB END; i := 0; WHILE (i < sizeR) & ((pos + i) < blockEnd) & (((mPos + i) MOD 32) IN smap [(mPos + i) DIV 32]) DO INC (i) END; IF (i < sizeR) & ((pos + i) < blockEnd) THEN kind := free END END END MapAllCheck; 8 +G8#Syntax10.Scn.Fnt VAR i, mPos, blockEnd, sizeR, hSize: LONGINT; BEGIN hSize := X.GetHeapSize (); blockEnd := pos + sizeB; IF (blockEnd > 0) & (pos < hSize DIV B) THEN mPos := pos; IF blockEnd > hSize DIV B THEN blockEnd := hSize DIV B END; IF mPos <= 0 THEN sizeR := pos + sizeB; mPos := 0 ELSE sizeR := sizeB END; i := 0; WHILE (i < sizeR) & ((pos + i) < blockEnd) DO INCL (smap [(mPos + i) DIV 32], (mPos + i) MOD 32); INC (i) END END END MapAllSet; 8 +D)8#Syntax10.Scn.Fnt VAR i, mPos, blockEnd, sizeR: LONGINT; BEGIN blockEnd := pos + sizeB; IF (blockEnd > zoomStart) & (pos < zoomEnd) THEN mPos := pos - zoomStart; IF blockEnd > zoomEnd THEN blockEnd := zoomEnd END; IF mPos <= 0 THEN sizeR := pos + sizeB - zoomStart; mPos := 0 ELSE sizeR := sizeB END; i := 0; WHILE (i < sizeR) & ((pos + i) < blockEnd) DO INCL (smap [(mPos + i) DIV 32], (mPos + i) MOD 32); INC (i) END END END MapSet; 8 J-+5/8CSyntax10.Scn.FntjSyntax10b.Scn.Fnt VAR mPos, sizeR, blockEnd, i: LONGINT; setArrTag: SET; setArr: Blockm4SetPtr; BEGIN IF smap = NIL THEN RETURN END; blockEnd := pos + sizeB; IF (blockEnd > zoomStart) & (pos < zoomEnd) THEN mPos := pos - zoomStart; IF blockEnd > zoomEnd THEN blockEnd := zoomEnd END; IF mPos <= 0 THEN sizeR := pos + sizeB - zoomStart; mPos := 0 ELSE sizeR := sizeB END; setArr := S.VAL (Blockm4SetPtr, S.VAL (LONGINT, smap) - 4); setArrTag := setArr.tag; EXCL (setArr.tag, markBit); i := 0; WHILE (i < sizeR) & ((pos + i) < blockEnd) DO INCL (smap [(mPos + i) DIV 32], (mPos + i) MOD 32); INC (i) END; setArr.tag := setArrTag END END MapSetMark;8 (* Procedures for storing specified blocks on a set-array *) PROCEDURE MapAllDelete (VAR smap: Map; VAR kind: INTEGER; VAR sizeB, pos: LONGINT);  PROCEDURE MapAllCheck (VAR smap: Map; VAR kind: INTEGER; VAR sizeB, pos: LONGINT);  PROCEDURE MapAllSet (VAR smap: Map; VAR kind: INTEGER; VAR sizeB, pos: LONGINT);  PROCEDURE MapSet (VAR smap: Map; VAR kind: INTEGER; VAR sizeB, pos: LONGINT);  PROCEDURE MapSetMark (VAR smap: Map; VAR sizeB, pos: LONGINT);  A markbit doesn't matter  (88vSyntax10.Scn.FntSyntax10i.Scn.FntMarkElemsAlloc! O 8FoldElemsNew#Syntax10.Scn.Fnt BEGIN RETURN ((ORD (ch) >= ORD ('A')) & (ORD (ch) <= ORD ('Z'))) OR ((ORD (ch) >= ORD ('a')) & (ORD (ch) <= ORD ('z'))) OR ((ORD (ch) >= ORD ('0')) & (ORD (ch) <= ORD ('9'))) OR (ch = '.') OR (ch = '[') OR (ch = ']') END IsNameChar; 8 {kK8#Syntax10.Scn.Fnt.. BEGIN Texts.WriteString (t.w, s) END String; 8 {kK*8#Syntax10.Scn.FntMM BEGIN Texts.WriteString (t.w, s); Texts.WriteInt (t.w, l, 0) END StringInt; 8 {kK+E8#Syntax10.Scn.Fnt BEGIN Texts.WriteString (t.w, s); IF printHex THEN Texts.WriteHex (t.w, l); Texts.Write (t.w, 'H') ELSE Texts.WriteInt (t.w, l, 0) END END StringAInt; 8 {kK8#Syntax10.Scn.FntEE BEGIN Texts.WriteString (t.w, s); Texts.WriteLn (t.w) END StringLn; 8 {kK 8#Syntax10.Scn.Fnt// BEGIN Out.String (s); Out.Ln END OutStringLn; 8 |kK8#Syntax10.Scn.Fnt'' BEGIN Texts.Write (t.w, TAB) END Tab; 8 }kK8#Syntax10.Scn.Fnt++ BEGIN Texts.WriteInt (t.w, l, 0) END Int; 8 {kKg8#Syntax10.Scn.Fntww BEGIN IF printHex THEN Texts.WriteHex (t.w, l); Texts.Write (t.w, 'H') ELSE Texts.WriteInt (t.w, l, 0) END END AInt; 8 ~kK8#Syntax10.Scn.Fnt## BEGIN Texts.WriteLn (t.w) END Ln; 8 kK8#Syntax10.Scn.Fnt%% BEGIN Texts.Write (t.w, ch) END Ch; 8  8#Syntax10.Scn.Fnt88 BEGIN Texts.SetFont (t.w, Fonts.Default) END TDefault; 8 t8#Syntax10.Scn.FntHH BEGIN Texts.SetFont (t.w, Fonts.This ("Syntax10b.Scn.Fnt")) END TBold; 8 t 8#Syntax10.Scn.FntMM BEGIN Texts.SetFont (t.w, Fonts.This ("Courier10b.Scn.Fnt")) END TCourierB; 8 kK8#Syntax10.Scn.Fnt// BEGIN Texts.Append (txt, t.w.buf) END Append; 8 {kK8#Syntax10.Scn.Fnt-- BEGIN Texts.SetColor (t.w, c) END SetColor; 8 V$8#Syntax10.Scn.Fnt   VAR c: SHORTINT; BEGIN CASE bc OF Illegal: c := white | this: IF bright = 0 THEN c := blue ELSE c := darkblue END | this + 1: IF bright = 0 THEN c := green ELSE c := darkgreen END | array, this + 2: IF bright = 0 THEN c := red ELSE c := darkred END | typeDesc, this + 3: IF bright = 0 THEN c := magenta ELSE c := yellow END | sysBlock, this + 4: IF bright = 0 THEN c := lightblue ELSE c := darkcyan END | free: c := grey0 ELSE c := grey1 + SHORT (bright) END; Texts.SetColor (t.w, c) END SetTextColor; 8 48#Syntax10.Scn.Fnt VAR c: INTEGER; BEGIN CASE bc OF Illegal: c := white | this: IF bright = 0 THEN c := blue ELSE c := darkblue END | this + 1: IF bright = 0 THEN c := green ELSE c := darkgreen END | array, this + 2: IF bright = 0 THEN c := red ELSE c := darkred END | typeDesc, this + 3: IF bright = 0 THEN c := magenta ELSE c := yellow END | sysBlock, this + 4: IF bright = 0 THEN c := lightblue ELSE c := darkcyan END | free: c := grey0 ELSE c := grey1 + bright END; picture.pic.SetColorIdx (c) END SetBlockColor; 8  !A8#Syntax10.Scn.Fnt VAR fold: FoldElems.Elem; BEGIN NEW (fold); fold.visible := TRUE; NEW (fold.hidden); Texts.OpenBuf (fold.hidden); fold.W := FoldElems.elemW; fold.H := FoldElems.elemH; fold.handle := FoldElems.FoldHandler; IF collapsed THEN IF left THEN fold.mode := FoldElems.colLeft ELSE fold.mode := FoldElems.colRight END ELSIF left THEN fold.mode := FoldElems.expLeft ELSE fold.mode := FoldElems.expRight END; Texts.WriteElem (t.w, fold); Append (txt); IF switch THEN FoldElems.Switch (fold) END END InsertFolds; 8  P=8#Syntax10.Scn.Fnt VAR c: PopupElems.Elem; copy: Texts.CopyMsg; BEGIN cmds.handle (cmds, copy); c := copy.e (PopupElems.Elem); Texts.WriteElem (t.w, c); Texts.Insert (menu.text, menu.text.len, t.w.buf) END InsertPopup; 8 +?48#Syntax10.Scn.Fnt!! VAR cmds: PopupElems.Elem; BEGIN NEW (cmds); COPY (name, cmds.name); cmds.small := TRUE; cmds.menu := TextFrames.Text (""); cmds.handle := PopupElems.Handle; Texts.Delete (cmds.menu, 0, cmds.menu.len); Append (cmds.menu); PopupElems.MeasureMenu (cmds); RETURN cmds END CreatePopup; 8 kK8J8BSyntax10.Scn.FntSyntax8i.Scn.FntWu VAR menuF, mainF: TextFrames.Frame; x, y: INTEGER; BEGIN txt := TextFrames.Text(""); menuF := TextFrames.NewMenu (title, ""); InsertPopup (t.cmdSClose, menuF); InsertPopup (t.cmdStore, menuF); mainF := TextFrames.NewText(txt, 0); Oberon.AllocateUserViewer(Oberon.Mouse.X, x, y); t.menuViewer := MenuViewers.New(menuF, mainF, TextFrames.menuH, x, y) END OpenViewer; 8 R2Pm8BSyntax10.Scn.FntSyntax8i.Scn.FntR VAR menuF, mainF: TextFrames.Frame; x, y: INTEGER; BEGIN txt := TextFrames.Text (""); IF menu = "" THEN menuF := TextFrames.NewMenu (title, "^HeapInspector.Menu.Text"); NEW (menuBuffer); Texts.OpenBuf (menuBuffer); Texts.Save (menuF.text, 16, 16 + 40, menuBuffer) ELSE menuF := TextFrames.NewMenu (title, menu) END; mainF := TextFrames.NewText (txt, 0); Oberon.AllocateUserViewer (Oberon.Mouse.X, x, y); t.menuViewer := MenuViewers.New (menuF, mainF, TextFrames.menuH, x, y); oldHandler := t.menuViewer.dsc.next.handle; t.menuViewer.dsc.next.handle := Handler END OpenMainViewer; 8 H8CSyntax10.Scn.FntWSyntax10b.Scn.FntK VAR r: Texts.Reader; pos: LONGINT; lastPicElem: Elem; BEGIN IF t.hItxt = NIL THEN RETURN END; pos := 0; lastPicElem := NIL; IF v.drwAll THEN lastPicElem := v.peAll END; IF v.drwNotMarked THEN lastPicElem := v.peNotMarked END; IF v.drwMarked THEN lastPicElem := v.peMarked END; IF v.drwReach THEN lastPicElem := v.peReach END; IF v.drwSelect THEN lastPicElem := v.peSelect END; Texts.OpenReader (r, t.hItxt, 0); REPEAT Texts.ReadElem (r); IF r.elem = lastPicElem THEN pos := Texts.Pos (r) END UNTIL r.eot; IF (lastPicElem = NIL) OR (pos = 0) THEN v.redrawPic := TRUE END; IF v.redrawPic THEN pos := 0 END; Texts.Delete (t.hItxt, pos, Texts.Pos (r)) END DeleteText; 8p (* Procedures for text operations *) PROCEDURE IsNameChar (ch: CHAR): BOOLEAN;  PROCEDURE String (s: ARRAY OF CHAR);  PROCEDURE StringInt (s: ARRAY OF CHAR; l: LONGINT);  PROCEDURE StringAInt (s: ARRAY OF CHAR; l: LONGINT);  PROCEDURE StringLn (s: ARRAY OF CHAR);  PROCEDURE OutStringLn (s: ARRAY OF CHAR);  PROCEDURE Tab;  PROCEDURE Int (l: LONGINT);  PROCEDURE AInt (l: LONGINT);  PROCEDURE Ln;  PROCEDURE Ch (ch: CHAR);  PROCEDURE TDefault;  PROCEDURE TBold;  PROCEDURE TCourierB;  PROCEDURE Append (txt: Texts.Text);  PROCEDURE SetColor (c: SHORTINT);  PROCEDURE SetTextColor (bc, bright: INTEGER);  PROCEDURE SetBlockColor (bc, bright: INTEGER; picture: Elem);  PROCEDURE InsertFolds (txt: Texts.Text; left, collapsed, switch: BOOLEAN);  PROCEDURE InsertPopup (cmds: PopupElems.Elem; menu: TextFrames.Frame);  PROCEDURE CreatePopup (name: ARRAY OF CHAR): PopupElems.Elem;  PROCEDURE OpenViewer (title: ARRAY OF CHAR; VAR txt: Texts.Text);  PROCEDURE OpenMainViewer (title: ARRAY OF CHAR; VAR txt:Texts.Text; menu: ARRAY OF CHAR);  PROCEDURE DeleteText ();  8\8Syntax10.Scn.FntSyntax10i.Scn.FntMarkElemsAlloc5 USyntax10b.Scn.FntZ8FoldElemsNew#Syntax10.Scn.Fnt BEGIN Out.String ("HeapInspector counts "); Out.Int (mods.cnt, 0); Out.String (" loaded module(s)."); Out.Ln END ModulesChanged; 8 v8#Syntax10.Scn.FntPP BEGIN IF mods.CheckUpdate (types) THEN ModulesChanged END END CheckModUpdate; 8 C8#Syntax10.Scn.Fnt!! VAR i: LONGINT; update: BOOLEAN; mod: X.Module; BEGIN IF mods.e = NIL THEN IF mods.Register (types) THEN ModulesChanged () END ELSE mod := X.GetModules (); i := 0; WHILE (i < mods.cnt) & (S.VAL (X.Module, mods.e [i].mod) = mod) DO mod := mod.next; INC (i) END; update := (i # mods.cnt) OR (mod # NIL); Out.String ("The loaded modules have "); IF ~update THEN Out.String ("not ") END; Out.String ("changed since last update."); Out.Ln; IF update & mods.Register (types) THEN ModulesChanged () END END END UpdateModules; @8 (* Procedures for module / type descriptor operations *) PROCEDURE ModulesChanged*;  PROCEDURE CheckModUpdate*;  PROCEDURE UpdateModules*;  Checks the loaded modules, if there is a change in module-list  #88(Syntax10.Scn.FntSyntax10i.Scn.FntMarkElemsAlloc, W#8FoldElemsNew#Syntax10.Scn.Fnt VAR adr: LONGINT; BEGIN adr := (x - 1) DIV v.pointW + (y DIV v.pointH) * (v.picWidth DIV v.pointW) + zoomStart + 1; IF adr >= zoomEnd THEN RETURN (zoomEnd - 1) * B ELSE RETURN adr * B END; END PicToAdr;  8 8Syntax10.Scn.Fntr8FoldElemsNew#Syntax10.Scn.Fntllsize, pAdr: LONGINT; ptr: S.PTR; iterator, kind: INTEGER; p, end: X.Blockm4Ptr; tdesc: X.Tag; gc: BOOLEAN;8=8jSyntax10.Scn.FntSyntax10i.Scn.FntMSyntax10b.Scn.Fnt *Zptr := S.VAL (S.PTR, S.VAL (LONGINT, p) + 4); kind := X.GetObjType (ptr, tdesc, size); size := S.VAL (LONGINT, S.VAL (SET, size + B-1) - S.VAL (SET, B-1)); (* Rounds up to MOD 32 = 0*) INC (pAdr, size); IF adr <= pAdr THEN Kernel.GCenabled := gc; RETURN ptr (* Return found element *) END; INC (S.VAL (LONGINT, p), size)Syntax10i.Scn.Fnt*8=$ VAR  BEGIN pAdr := 0; iterator := 0; gc := Kernel.GCenabled; Kernel.GCenabled := FALSE; WHILE X.GetNextMemBlock (p, end, iterator (* = Number of heap *) ) DO WHILE p # end DO  Search start - address of specified elem  END END; Kernel.GCenabled := gc; RETURN ptr; END Find; 88 [4$8#Syntax10.Scn.Fnt VAR h, zStart, zEnd: LONGINT; BEGIN zEnd := PicToAdr (x2, y2) DIV B; zStart := PicToAdr (x, y) DIV B; IF zStart > zEnd THEN h := zStart; zStart := zEnd; zEnd := h END; zEnd := zoomStart + (zEnd - zoomStart + v.picWidth DIV v.pointW - 1) DIV (v.picWidth DIV v.pointW) * (v.picWidth DIV v.pointW) - 1; zStart := zoomStart + (zStart - zoomStart) DIV (v.picWidth DIV v.pointW) * (v.picWidth DIV v.pointW); IF (zEnd - zStart) < (v.picWidth DIV v.pointW - 1) THEN zEnd := zStart + v.picWidth DIV v.pointW - 1 END; h := zEnd - (X.GetHeapSize () DIV B); IF h > 0 THEN DEC (zEnd, h); DEC (zStart, h) END; zoomStart := zStart; zoomEnd := zEnd; v.redrawPic := TRUE; HeapUpdate END SelectZoom; ,8 $i38`Syntax10.Scn.Fntx8FoldElemsNew#Syntax10.Scn.Fnt BEGIN IF pict # NIL THEN pict.pic.ReplConst (0, lineS, pict.pic.width - 1, nLines, Display.invert); IF update THEN pict.pic.Update (NIL, 0, 0 (*lineS*), pict.pic.width - 1, pict.pic.height) END END END InvertRegion; 8 VAR xchg, zStart, zEnd, zBStart, zBEnd: LONGINT; nLines, lineS, lineE: INTEGER; PROCEDURE InvertRegion (pict: Elem);  BEGIN zEnd := PicToAdr (x2, y2); zStart := PicToAdr (x, y); zBEnd := zEnd DIV B; zBStart := zStart DIV B; IF zBStart > zBEnd THEN xchg := zBStart; zBStart := zBEnd; zBEnd := xchg END; lineS := SHORT ((zBStart - zoomStart) * v.pointW DIV v.picWidth * v.pointH); lineE := SHORT ((zBEnd - zoomStart + v.picWidth DIV v.pointW) * v.pointW DIV v.picWidth * v.pointH); IF lineE < 0 THEN lineE := 0 END; IF lineE >= (v.picHeight * v.pointH) THEN lineE := SHORT (v.picHeight * v.pointH) END; nLines := lineE - lineS; InvertRegion (v.peAll); InvertRegion (v.peMarked); InvertRegion (v.peNotMarked); InvertRegion (v.peReach); InvertRegion (v.peSelect); END ShowZoom; 8 kK38}Syntax10.Scn.Fnt08FoldElemsNew#Syntax10.Scn.Fntx, y, x2, y2,lastX, lastY: INTEGER; p: S.PTR; elemPos: LONGINT; keysum, keys: SET; zoom, zoomed, firstInv, keyPressed: BOOLEAN; loc: TextFrames.Location; e1: PElems.Elem;8L8#Syntax10.Scn.Fnt BEGIN x := x - loc.x; y := y - loc.y; IF x < 0 THEN x := 0 ELSIF x >= v.picWidth THEN x := SHORT (v.picWidth - 1) END; IF y < 0 THEN y := 0 ELSIF y >= v.picHeight THEN y := SHORT (v.picHeight - 1) END END PicPosCorrection; 8.18#Syntax10.Scn.Fnt VAR adr, size, i: LONGINT; ptr: S.PTR; tdesc: X.Tag; type: Types.Type; BEGIN adr := PicToAdr (x, y); ptr := Find (adr); TCourierB; AInt (X.AddressRelToAbs (adr)); String (" ("); AInt (adr); Ch (')'); FOR i := t.w.buf.len TO 20 DO Ch (' ') END; IF keysum = {ML, MM} THEN IF v.drwReach THEN String ("ReFrom ") ELSE String ("Show ") END ELSIF keysum = {MM} THEN String ("Select ") ELSIF keysum = {MM, MR} THEN String ("ZoomIn ") ELSE String ("Cancel ") END; TBold; CASE X.GetObjType (ptr, tdesc, size) OF other: type := X.TypeOf (ptr); IF type.module # NIL THEN String (type.module.name) END; Ch ('.'); String (type.name) | sysBlock: String ("Sysblock/Array") | typeDesc: String ("Typedescriptor "); type := S.VAL (Types.Type, tdesc); IF type.module # NIL THEN String (type.module.name) END; Ch ('.'); String (type.name) | free: String ("Free block") | array: String ("ArrayWithPointer") ELSE String ("Error") END; String (" - "); Int (size); String (" bytes."); TDefault; Texts.Delete (t.menuViewer.dsc (TextFrames.Frame).text, 16, 150); Texts.Append (t.menuViewer.dsc (TextFrames.Frame).text, t.w.buf) END PrintAddressType; 8"Syntax10b.Scn.Fntj8Syntax10.Scn.Fntd8FoldElemsNew#Syntax10.Scn.Fntzz Input.Mouse (keys, x2, y2); keyPressed := (keys - keysum) # {}; keysum := keysum + keys; zoomed := zoom; zoom := keysum = {MM, MR}; Oberon.DrawCursor (Oberon.Mouse, Oberon.Arrow, x2, y2); PicPosCorrection (x2, y2, loc); IF (lastY # y2) OR (lastX # x2) OR keyPressed THEN PrintAddressType (x2, y2) END; IF (~zoom) & zoomed THEN ShowZoom (x, y, lastX, lastY, TRUE) END; IF zoom & ((lastY # y2) OR (zoom # zoomed)) THEN IF ~firstInv THEN ShowZoom (x, y, lastX, lastY, FALSE) ELSE firstInv := FALSE END; ShowZoom (x, y, x2, y2, TRUE) END; lastX := x2; lastY := y2Syntax10i.Scn.Fnt8G8#Syntax10.Scn.Fnt IF ~v.drwFreeze THEN v.reachedFrom := FALSE END; p := Find (PicToAdr (x2, y2)); SetPtrReach (S.VAL (Kernel.Block, p)); Inspector.InspectPointer (p); IF v.reachedFMod OR v.reachedFVar THEN VisHeapReachable () END385z8#Syntax10.Scn.Fntdd v.reachedFrom := TRUE; p := Find (PicToAdr (x, y)); SetPtrReach (S.VAL (Kernel.Block, p))8 IF m.keys = {MM} THEN zoom := FALSE; lastX := -1; lastY := -1; keysum := {MM}; Input.Mouse(keys, x, y); elemPos := TextFrames.Pos (m.frame (TextFrames.Frame), x, y); TextFrames.LocatePos (m.frame (TextFrames.Frame), elemPos, loc); PicPosCorrection (x, y, loc); Texts.Delete (t.menuViewer.dsc(TextFrames.Frame).text, 16, 30); PrintAddressType (x, y); firstInv := TRUE; REPEAT  Read mouse-moves and -keys  UNTIL keys = {}; IF (~firstInv) & zoom THEN ShowZoom (x, y, lastX, lastY, TRUE) END; Texts.Delete (t.menuViewer.dsc(TextFrames.Frame).text, 16, 150); Texts.Copy (menuBuffer, t.w.buf); Append (t.menuViewer.dsc(TextFrames.Frame).text); IF zoom THEN SelectZoom (x, y, x2, y2) ELSIF keysum = {MM} THEN  Select object ("reach") and open Inspector-viewer  ELSIF (keysum = {ML, MM}) & (~v.drwFreeze) THEN  Select "reached from"  END ENDSyntax10i.Scn.Fnt8 2   VAR  PROCEDURE PicPosCorrection (VAR x, y: INTEGER; loc: TextFrames.Location);  PROCEDURE PrintAddressType (x, y: INTEGER);  BEGIN WITH e: Elem DO WITH m: TextFrames.TrackMsg DO  Handle mouse events  (* | m: Texts.IdentifyMsg DO m.mod := "PElems"; m.proc := "Alloc"*) | m: TextFrames.FocusMsg DO | m: Texts.CopyMsg DO IF m.e = NIL THEN NEW (e1); m.e := e1 ELSE e1 := m.e(PElems.Elem) END; PElems.Handler(e, m) ELSE PElems.Handler (e, m) END ELSE END END ElemHandler; 8 /h58 Syntax10.Scn.FntlR8FoldElemsNew#Syntax10.Scn.Fnt WITH m: Oberon.InputMsg DO IF (m.id = Oberon.track) & (m.keys # {}) THEN Oberon.PassFocus (Viewers.This (f.X, f.Y)); IF ((m.keys = {ML}) OR (m.keys = {MR})) & (m.X > TextFrames.barW) THEN m.keys := {MM} END ELSIF m.id = Oberon.consume THEN redraw := TRUE; CASE m.ch OF CurUp: MoveMap (((zoomEnd - zoomStart) DIV 5 DIV (v.picWidth DIV v.pointW)) * (v.picWidth DIV v.pointW), TRUE, TRUE) | CurDown: MoveMap (-((zoomEnd - zoomStart) DIV 5 DIV (v.picWidth DIV v.pointW)) * (v.picWidth DIV v.pointW), TRUE, TRUE) | CurLeft: MoveMap (-v.picWidth DIV v.pointW DIV 10, TRUE, TRUE) | CurRight: MoveMap (v.picWidth DIV v.pointW DIV 10, TRUE, TRUE) | PageUp: MoveMap (((zoomEnd - zoomStart) DIV (v.picWidth DIV v.pointW)) * (v.picWidth DIV v.pointW), TRUE, TRUE) | PageDown: MoveMap (-((zoomEnd - zoomStart) DIV (v.picWidth DIV v.pointW)) * (v.picWidth DIV v.pointW), TRUE, TRUE) | PagePos1: MoveMap (0, FALSE, TRUE) | PageEnd: MoveMap (X.GetHeapSize () DIV B - 1, FALSE, TRUE) ELSE redraw := FALSE END END ENDSyntax10i.Scn.Fnt,8P VAR redraw: BOOLEAN; BEGIN redraw := FALSE; WITH f: TextFrames.Frame DO IF m IS MenuViewers.ModifyMsg THEN WITH m: MenuViewers.ModifyMsg DO IF v.picWidth # ((f.W - TextFrames.barW - 16) DIV 8 * 8) THEN v.picWidth := (f.W - TextFrames.barW - 16) DIV 8 * 8; v.redrawPic := TRUE; redraw := TRUE END END ELSIF m IS Oberon.InputMsg THEN  Handle key-events, setfocus by mouse-event  END END; oldHandler (f, m); IF redraw THEN HeapUpdate () END END Handler; 8J (* Procedures for event-handling (selection) *) PROCEDURE PicToAdr (x, y: LONGINT): LONGINT;  Picture coordinates to address  PROCEDURE Find (adr: LONGINT): S.PTR;  Searches the starting address of an object on the heap  PROCEDURE SelectZoom (x, y, x2, y2: INTEGER);  Sets mouse-selection to zoomstart and -end  PROCEDURE ShowZoom (x, y, x2, y2: INTEGER; update: BOOLEAN);  Inverts selection  PROCEDURE ElemHandler (e: Texts.Elem; VAR m: Texts.ElemMsg);  Messages for heapmap  PROCEDURE Handler (f: Display.Frame; VAR m: Display.FrameMsg);  Messages for the viewer  +887Syntax10.Scn.FntSyntax10i.Scn.FntMarkElemsAlloc7 ,Syntax10b.Scn.Fnt8FoldElemsNew#Syntax10.Scn.FntBB BEGIN Kernel.afterQ.Remove (HeapUpdate) END GCInspectHeapClose; 8 ,|8#Syntax10.Scn.Fntbb BEGIN Kernel.afterQ.Remove (HeapUpdate); Kernel.afterQ.Add (HeapUpdate) END GCInspectHeapOpen; 8 kK68#Syntax10.Scn.Fnt VAR on: ARRAY 32 OF CHAR; BEGIN In.Open; In.Name(on); IF on = "On" THEN Kernel.GCenabled := TRUE ELSIF on = "Off" THEN Kernel.GCenabled := FALSE END END GCOnOff; 8 |,18#Syntax10.Scn.Fnt VAR onoff: ARRAY 32 OF CHAR; BEGIN In.Open; In.Name (onoff); IF onoff = "On" THEN GCInspectHeapOpen ELSIF onoff = "Off" THEN GCInspectHeapClose END END UpdateAfterGC; 8 (* Commands for setting the modes for Garbage-Collector *) PROCEDURE GCInspectHeapClose*;  PROCEDURE GCInspectHeapOpen*;  PROCEDURE GCOnOff*;  PROCEDURE UpdateAfterGC*;  88=Syntax10.Scn.FntSyntax10i.Scn.FntMarkElemsAllocH x38FoldElemsNewSyntax10.Scn.FntSyntax10i.Scn.Fnt.8FoldElemsNew#Syntax10.Scn.Fnt** IF val > 0 THEN IF (zoomEnd + val) > (X.GetHeapSize () DIV B) THEN val := (X.GetHeapSize () DIV B) - zoomEnd END; INC (zoomStart, val); INC (zoomEnd, val) ELSE val := -val; IF (zoomStart - val) < 0 THEN val := zoomStart END; DEC (zoomStart, val); DEC (zoomEnd, val) END'88#Syntax10.Scn.Fnt'' hSize := zoomEnd - zoomStart; IF val < (hSize DIV 2) THEN zoomStart := 0; zoomEnd := zoomStart + hSize ELSIF val > ((X.GetHeapSize () DIV B) - hSize DIV 2) THEN zoomEnd := (X.GetHeapSize () DIV B) - 1; zoomStart := zoomEnd - hSize ELSE IF ((v.picHeight DIV v.pointH) MOD 2) = 0 THEN zoomStart := val - hSize DIV 2 - (v.picWidth DIV (v.pointW * 2)); zoomEnd := zoomStart + hSize; IF zoomStart < 0 THEN INC (zoomEnd, -zoomStart); zoomStart := 0 END ELSE zoomStart := val - hSize DIV 2; zoomEnd := zoomStart + hSize END ENDI8t8#Syntax10.Scn.Fntjj hSize := zoomEnd - zoomStart; zoomStart := val; IF zoomStart < 0 THEN zoomStart := 0 ELSIF zoomStart >= (X.GetHeapSize () DIV B - 4) THEN zoomStart := X.GetHeapSize () DIV B - 4; v.redrawPic := TRUE END; zoomEnd := zoomStart + hSize; IF zoomEnd >= (X.GetHeapSize () DIV B) THEN zoomEnd := X.GetHeapSize () DIV B; v.redrawPic := TRUE ENDJ8; (* val is address in blocks *) VAR hSize: LONGINT; BEGIN IF relative THEN  Move map relative to current position  ELSIF center THEN  Set map to absolute position (position is in the middle of the picture)  ELSE  Set map to absolute position (Heapmap starts with the specified address)  END END MoveMap; 8 kKP8_Syntax10.Scn.Fnt8FoldElemsNew#Syntax10.Scn.Fnt IF len > (picture.pic.width DIV v.pointW - x) THEN w := picture.pic.width DIV v.pointW - x ELSE w := SHORT (len) END; IF kind # invert THEN picture.pic.ReplConst (x * v.pointW, y * v.pointH, w * v.pointW, v.pointH, Display.replace) ELSE picture.pic.ReplConst (x * v.pointW, y * v.pointH, w * v.pointW, v.pointH, Display.invert) END; INC(x, w); IF x >= (picture.pic.width DIV v.pointW) THEN x := 0; INC (y) END; len := len - w Syntax10i.Scn.Fnt8 VAR w: INTEGER; BEGIN INC (pos, len); IF (pos > zoomStart) & ((pos - len) <= zoomEnd) THEN IF (pos - zoomStart) < len THEN len := pos - zoomStart END; IF (zoomEnd - pos) < 0 THEN len := zoomEnd - pos + len + 1 END; IF kind # other THEN IF kind # invert THEN SetBlockColor (kind, v.col2, picture); v.col2 := (v.col2 + 1) MOD 2 END ELSE SetBlockColor (kind, v.col3, picture); v.col3 := (v.col3 + 1) MOD 3 END; WHILE len > 0 DO  Draw a block  END END END DrawBlock; 8 z8cSyntax10.Scn.FntSyntax10b.Scn.FntSyntax10i.Scn.Fnt^ VAR type: Types.Type; tdesc: X.Tag; size: LONGINT; typeDesc: Inspector.TypeDescS; kind: INTEGER; BEGIN IF v.drwFreeze OR (p = NIL) THEN RETURN END; reachPtr := p; kind := X.GetObjType (p, tdesc, size); IF (kind = X.TArrP) OR (kind = X.TObj) THEN type := X.TypeOf (reachPtr); COPY (type.name, reachType); COPY (type.module.name, reachModule); END; CASE kind OF X.TArrP: reachName := "array of record (pointer) " | X.TObj: reachName := "record " | X.TTypDesc: reachName := "typedescriptor "; typeDesc := S.VAL (Inspector.TypeDescS, S.VAL (LONGINT, tdesc) - 4); COPY (typeDesc.name, reachType); COPY (typeDesc.mdesc.name, reachModule) | X.TSysBl: reachName := "sysblock or array "; reachType := ""; reachModule := "" | X.TFree: reachPtr := NIL; reachName := "free block"; reachType := ""; reachModule := "" (* free block *) ELSE HALT (99) END; IF v.drwReach & (reachPtr # NIL) THEN HeapUpdate END END SetPtrReach; 8 E8Syntax10.Scn.FntD8FoldElemsNew#Syntax10.Scn.Fnt VAR ii: INTEGER; BEGIN ii := 0; IF writeBack # 0X THEN name [0] := writeBack; INC (ii) END; REPEAT In.Char (name [ii]); done := (name [ii] # '~') & In.Done UNTIL ((name [ii] # ' ') & (name [ii] # TAB) & (ORD (name [ii]) # LN)) OR (~done); INC (ii); WHILE done & ((ii = 0) OR ((name [ii - 1] # '*') & (name [ii - 1] # ' ') & (name [ii - 1] # TAB) & (ORD (name [ii - 1]) # LN) & (ii < (MaxChars - 3)))) DO In.Char (name [ii]); done := (name [ii] # '~') & In.Done; INC (ii) END; IF ii = 0 THEN name [0] := 0X ELSE IF name [ii - 1] = '*' THEN writeBack := '*' ELSE writeBack := 0X END; name [ii - 1] := 0X END END ReadName; 8x CONST MaxChars = 70; VAR i, j, k: INTEGER; name: ARRAY MaxChars OF CHAR; writeBack: CHAR; done: BOOLEAN; PROCEDURE ReadName (VAR name: ARRAY OF CHAR);  BEGIN In.Open; IF In.Next () = In.int THEN In.LongInt (v.picMaxHeight); IF v.picMaxHeight < MapMinHeight THEN v.picMaxHeight := MapMinHeight END; IF v.picMaxHeight > v.mapMaxHeight THEN v.picMaxHeight := v.mapMaxHeight END END; Out.String ("Marking module(s):"); writeBack := 0X; done := TRUE; FOR i := 0 TO MaxMarked - 1 DO s.t [i].mod := ""; s.t [i].type := ""; s.t [i].derived := FALSE END; k := 0; REPEAT ReadName (name); i := 0; WHILE (name [i] # 0X) & (name [i] # ".") DO INC(i) END; IF name [i] # 0X THEN name [i] := 0X; INC(i); j := 0; WHILE (name [i] # 0X) & (j < 31) DO s.t [k].type [j] := name [i]; INC(j); INC(i) END; s.t [k].type [j] := 0X ELSE s.t [k].type := "" END; i := 0; WHILE (name [i] # 0X) & (i < 31) DO s.t [k].mod [i] := name [i]; INC (i) END; s.t [k].mod [i] := 0X; IF (k > 0) & (s.t [k].mod [0] # 0X) THEN Out.Char (','); Out.Ln END; Out.Char (' '); Out.String (name); IF s.t [k].type [0] # 0X THEN Out.Char ('.'); Out.String (s.t [k].type) END; IF writeBack = '*' THEN s.t [k].derived := TRUE; Out.String (" and derived"); writeBack := 0X END; INC (k) UNTIL ~In.Done OR ~done OR (s.t [k - 1].mod = "") OR (k >= MaxMarked); IF (k > 0) & (s.t [k - 1].mod [0] = 0X) THEN s.nrOfTypeN := k - 1 ELSE s.nrOfTypeN := k END; IF s.nrOfTypeN = 0 THEN Out.String ("No modules specified.") END; Out.Ln END ReadMarkNames; 8: (* For miscellaneous use: MoveMap, DrawBlock, SetPtrReach, ReadMarkNames *) PROCEDURE MoveMap (val: LONGINT; relative, center: BOOLEAN);  PROCEDURE DrawBlock (len, pos: LONGINT; kind: INTEGER; picture: Elem; VAR x, y: INTEGER);  PROCEDURE SetPtrReach (p: Kernel.Block);  PROCEDURE ReadMarkNames ();  .8@8'Syntax10.Scn.FntSyntax10i.Scn.FntMarkElemsAllocK   8FoldElemsNewSyntax10.Scn.FntSyntax10i.Scn.Fnt?f8FoldElemsNew#Syntax10.Scn.Fntxxp, end: X.Blockm4Ptr; tag, tdesc: X.Tag; isMarked: BOOLEAN; size, size2, sizeB, pos: LONGINT; kind, iterator: INTEGER;8{X8JSyntax10.Scn.Fnt (8FoldElemsNew#Syntax10.Scn.Fnt IF ~isMarked THEN INC (s.cMark.size, size2); INC (s.cMark.objs); ELSE MapSetMark (v.pMarked, sizeB, pos) END; p.tag := S.VAL (X.Tag, S.VAL (SET, tag) - {markBit}) Syntax10i.Scn.Fnt8;_ tag := p.tag; isMarked := markBit IN S.VAL (SET, tag); kind := X.GetObjType (S.VAL (S.PTR, S.VAL (LONGINT, p) + 4), tdesc, size2); size := S.VAL (LONGINT, S.VAL (SET, size2 + B - 1) - S.VAL (SET, B - 1)); sizeB := size DIV B; IF kind # free THEN  Register marked objects  END; INC (S.VAL (LONGINT, p), size); INC (pos, sizeB) %8#  (* Do not call this procedure before calling VisHeapSelected *) VAR  BEGIN pos := 0; iterator := 0; WHILE X.GetNextMemBlock (p, end, iterator (* = Number of heap *) ) DO WHILE p # end DO  Register marked objects on the heap  END END END VisualizeHeapMarked; (8 k_#8Syntax10.Scn.Fnt88FoldElemsNew#Syntax10.Scn.Fntp, end: X.Blockm4Ptr; tdesc: X.Tag; type: Types.Type; pos, mPos, size, size2, sizeB, moduleIndex: LONGINT; x, y, xL, yL, kind, hCol2, hCol3, h, iterator: INTEGER;8FT8Syntax10.Scn.Fnt$8FoldElemsNew#Syntax10.Scn.FntWHILE (level > 0) & (~((type2.module.name = s.t [i].mod) & ((s.t [i].type = "") OR (type2.name = s.t [i].type)))) DO DEC (level); type2 := Types.BaseOf (type, level) ENDSyntax10i.Scn.FntI8n8#Syntax10.Scn.Fntkind := i; INC (s.t [i].nrOfObjs); INC (s.t [i].totalSize, size); IF s.t [i].size = NotDef THEN s.t [i].size := size; s.t [i].maxSize := size ELSIF s.t [i].size >= size THEN s.t [i].size := size ELSIF s.t [i].maxSize < size THEN s.t [i].maxSize := size END; IF s.t [i].minLevel = NotDef THEN s.t [i].minLevel := level2; s.t [i].maxLevel := level2 ELSIF s.t [i].minLevel >= level2 THEN s.t [i].minLevel := level2 ELSIF s.t [i].maxLevel < level2 THEN s.t [i].maxLevel := level2 END-8) VAR kind, i, level, level2: INTEGER; type2: Types.Type; BEGIN kind := NotFound; FOR i := 0 TO s.nrOfTypeN - 1 DO level2 := Types.LevelOf (type); level := level2; type2 := type; IF s.t [i].derived & (type2.name # "") & (type2.module.name # "") THEN  Check object if it is a derived object from the specified types to mark  END; IF (type2.module.name = s.t [i].mod) & ((s.t [i].type = "") OR (type2.name = s.t [i].type)) THEN  Count number and size of the object to mark  END END; RETURN kind END CheckName; 87n8#Syntax10.Scn.Fntpp BEGIN IF doUpdate THEN picture.pic.Update (NIL, 0, 0, picture.pic.width, picture.pic.height) END END Update; 8 8/Syntax10.Scn.FntSyntax10i.Scn.Fnt?G,;8FoldElemsNewmSyntax10.Scn.Fnt8FoldElemsNew#Syntax10.Scn.Fnt CASE kind OF array: IF s.nrOfTypeN >= 3 THEN kind := other END | typeDesc: IF s.nrOfTypeN >= 4 THEN kind := other END | sysBlock: IF s.nrOfTypeN >= 5 THEN kind := other END ELSE ENDSyntax10i.Scn.Fnt8h8#Syntax10.Scn.Fntvv mPos := pos - zoomStart; IF mPos < 0 THEN mPos := 0 END; IF v.drwMarked THEN xL := x; yL := y; v.col3 := hCol3; v.col2 := hCol2; IF (mPos MOD 32) IN v.pMarked [mPos DIV 32] THEN DrawBlock (sizeB, pos, kind, v.peMarked, xL, yL) ELSE DrawBlock (sizeB, pos, free, v.peMarked, xL, yL) END END; IF v.drwNotMarked THEN xL := x; yL := y; v.col3 := hCol3; v.col2 := hCol2; IF (mPos MOD 32) IN v.pMarked [mPos DIV 32] THEN DrawBlock (sizeB, pos, free, v.peNotMarked, xL, yL) ELSE DrawBlock (sizeB, pos, kind, v.peNotMarked, xL, yL) END END 88#Syntax10.Scn.Fnt66 mPos := pos - zoomStart; IF mPos < 0 THEN mPos := 0 END; xL := x; yL := y; v.col3 := hCol3; v.col2 := hCol2; IF (mPos MOD 32) IN v.pReach [mPos DIV 32] THEN DrawBlock (sizeB, pos, kind, v.peReach, xL, yL) ELSE DrawBlock (sizeB, pos, free, v.peReach, xL, yL) END 88#Syntax10.Scn.Fnt99 mPos := pos - zoomStart; IF mPos < 0 THEN mPos := 0 END; xL := x; yL := y; v.col3 := hCol3; v.col2 := hCol2; IF (mPos MOD 32) IN v.pSelect [mPos DIV 32] THEN DrawBlock (sizeB, pos, kind, v.peSelect, xL, yL) ELSE DrawBlock (sizeB, pos, free, v.peSelect, xL, yL) END  8 IF kind # free THEN INC (s.frag, size - size2); INC (s.all, size); IF v.remaining THEN MapAllSet (v.pRemain, kind, sizeB, pos) ELSIF v.pRemain # NIL THEN MapAllCheck (v.pRemain, kind, sizeB, pos) END ELSIF v.pRemain # NIL THEN MapAllDelete (v.pRemain, kind, sizeB, pos) END; IF kind = other THEN type := Types.TypeOf (S.VAL (S.PTR, S.VAL (LONGINT, p) + 4)); IF X.AddressInHeap (S.VAL (LONGINT, type)) THEN moduleIndex := types.Update (type, mods); IF ~mods.UpdateElem (type, size2, moduleIndex) THEN kind := Illegal; INC (s.cModLess.size, size2); INC (s.cModLess.objs) ELSE h := CheckName (type, size2); IF h = NotFound THEN IF v.onlyMarked THEN kind := free END ELSE kind := this + h END END END ELSIF v.onlyMarked THEN kind := free ELSIF kind # free THEN IF (~v.defBlockShow) & (kind # other) THEN kind := free ELSIF ~v.defBlockCol THEN kind := other ELSE  Colorize default blocks  END END; IF kind # free THEN INC (s.cAll.size, size) END; s.UpdateBlockInfo (size); hCol3 := v.col3; hCol2 := v.col2; IF t.hItxt # NIL THEN IF ((pos + sizeB) > zoomStart) & (pos < zoomEnd) THEN IF v.drwMarked OR v.drwNotMarked THEN  Draw (not) collectable  END; IF v.drwReach THEN  Draw reachable  END; IF v.drwSelect THEN  Draw selected  END END; IF v.drwAll THEN xL := x; yL := y; v.col3 := hCol3; v.col2 := hCol2; DrawBlock (sizeB, pos, kind, v.peAll, xL, yL) END END; x := xL; y := yL;#8Jkind := X.GetObjType (S.VAL (S.PTR, S.VAL (LONGINT, p) + 4), tdesc, size2); CASE kind OF array: INC (s.cArr.objs); INC (s.cArr.size, size2) (* Array with pointer *) | other: (* No error *) | typeDesc: INC (s.cType.objs); INC (s.cType.size, size2) (* Typedescriptor *) | sysBlock: INC (s.cSys.objs); INC (s.cSys.size, size2) (* Sysblock or arrayblock without pointer *) | free: INC (s.cFree.objs); INC (s.cFree.size, size2) (* Free block *) ELSE HALT (99) END; size := S.VAL (LONGINT, S.VAL (SET, size2 + B-1) - S.VAL (SET, B-1)); sizeB := size DIV B;  Update statistics and draw blocks  INC (S.VAL (LONGINT, p), size); INC (pos, sizeB); INC (s.cAll.objs)Syntax10i.Scn.Fnt:8$,8#Syntax10.Scn.Fnt Update (v.drwAll, v.peAll); Update (v.drwMarked, v.peMarked); Update (v.drwNotMarked, v.peNotMarked); Update (v.drwReach, v.peReach); Update (v.drwSelect, v.peSelect) 8/ VAR  PROCEDURE CheckName (VAR type: Types.Type; size: LONGINT): INTEGER;  PROCEDURE Update (doUpdate: BOOLEAN; picture: Elem);  BEGIN pos := 0; x := 0; y := 0; v.col3 := 0; v.col2 := 0; types.Clear (); iterator := 0; WHILE X.GetNextMemBlock (p, end, iterator (* = Number of heap *) ) DO WHILE p # end DO  search, identify, count and print all blocks on the heap  END END; IF t.hItxt # NIL THEN  Update all pictures  END; v.remaining := FALSE END VisualizeHeap; 8 =s=8Syntax10.Scn.FntSyntax10i.Scn.Fnt?z8FoldElemsNew#Syntax10.Scn.Fnt mods.Chain () =8 (* Do not call this procedure before calling VisHeapSelected *) BEGIN IF unloadModDesc THEN mods.Unchain () END; Descs.MarkObjects (); VisualizeHeapMarked (); IF unloadModDesc THEN  Insert moduledescriptors into modulelist in the right order  END END MarkCollectable; 48 W8"Syntax10.Scn.Fnt!Syntax10i.Scn.Fnt8FoldElemsNew#Syntax10.Scn.Fnt   VAR r: X.Blockm4Ptr; isMarked: BOOLEAN; BEGIN r := S.VAL (X.Blockm4Ptr, S.VAL (LONGINT, reachPtr) - 4); Kernel.Mark (reach); isMarked := markBit IN S.VAL (SET, r.tag); IF unmark OR isMarked THEN Descs.UnmarkAll () END; RETURN isMarked END CheckReach; 8U8#Syntax10.Scn.FntFF VAR objReached, lastUnm: BOOLEAN; i: INTEGER; ptr, pTab: LONGINT; mod: X.Module; BEGIN objReached := FALSE; mod := S.VAL (X.Module, reach); lastUnm := TRUE; FOR i := 0 TO X.GetNoOfPtrsInMod (mod) - 1 DO S.GET (X.GetPtrInMod (mod, i), ptr); lastUnm := FALSE; IF (S.VAL (Kernel.Block, ptr) # NIL) & CheckReach (S.VAL (Kernel.Block, ptr), FALSE) & (i < (MaxPointersInModule * 32)) THEN INCL (pInMod [i DIV 32], i MOD 32); objReached := TRUE; lastUnm := TRUE END END; IF ~lastUnm THEN Descs.UnmarkAll () END; RETURN objReached END CheckReachMod; 8i8Syntax10.Scn.Fntn8FoldElemsNew#Syntax10.Scn.Fntppp, end: X.Blockm4Ptr; tag, notmarked, tdesc: X.Tag; isMarked: BOOLEAN; kind, iterator: INTEGER; pos: LONGINT;8 VAR  BEGIN Kernel.Mark (reachPtr); pos := 0; iterator := 0; WHILE X.GetNextMemBlock (p, end, iterator (* = Number of heap *) ) DO WHILE p # end DO tag := p.tag; isMarked := markBit IN S.VAL (SET, tag); kind := X.GetObjType (S.VAL (S.PTR, S.VAL (LONGINT, p) + 4), tdesc, size2); size := S.VAL (LONGINT, S.VAL (SET, size2 + B - 1) - S.VAL (SET, B - 1)); sizeB := size DIV B; IF (kind # free) & isMarked THEN INC (s.cReach.size, size2); INC (s.cReach.objs); MapSetMark (v.pReach, sizeB, pos); p.tag := S.VAL (X.Tag, S.VAL (SET, tag) - {markBit}) END; INC (S.VAL (LONGINT, p), size); INC (pos, sizeB) END END END Reach; 88Syntax10.Scn.Fnt8FoldElemsNew#Syntax10.Scn.Fnttdesc, recT: X.Tag; i, j, l, cnt, pos, rDepth, adr, ptr: LONGINT; m: X.Module; ch: CHAR; first: BOOLEAN; objReached: PointersInMod; k: INTEGER; r: ARRAY MaxRecordDepth OF Ref.Rider; type: Types.Type;88 Syntax10.Scn.FntO8FoldElemsNew#Syntax10.Scn.Fnt IF cnt # 0 THEN Out.Char (',') END; IF (cnt MOD 4) = 0 THEN Out.Ln; Out.Char (TAB) ELSE Out.Char (' ') END; Out.String (m.name)Syntax10i.Scn.Fnt8 8 Syntax10.Scn.Fnt8FoldElemsNew-Syntax10.Scn.Fnt8FoldElemsNew@Syntax10.Scn.Fnt8FoldElemsNewQSyntax10.Scn.Fnt(Syntax10i.Scn.Fnt)% type := r [rDepth].Type (); (* Zoom in only if record has pointers *) S.GET (S.VAL (LONGINT, type) + 8, recT); IF recT.ptrOffs # -4 THEN r [rDepth].Zoom (r [rDepth + 1]); INC (rDepth) ELSE r [rDepth].Next () (* No pointers in type *) ENDSyntax10i.Scn.Fnt!818#Syntax10.Scn.Fnt r [rDepth].Zoom (r [rDepth + 1]); INC (rDepth); IF (r [rDepth].form # Ref.Pointer) & (r [rDepth].form # Ref.Record) & (r [rDepth].form # Ref.Array) THEN DEC (rDepth); r [rDepth].Next () END 8 WHILE (r [rDepth].mode # Ref.End) & (r [rDepth].form # Ref.Pointer) DO IF rDepth < MaxRecordDepth THEN IF r [rDepth].form = Ref.Record THEN  Zoom into records with pointers  ELSIF r [rDepth].form = Ref.Array THEN  Zoom into arrays with pointers  ELSE r [rDepth].Next () END ELSE r [rDepth].Next () END END; WHILE (r [rDepth].mode = Ref.End) & (rDepth # 0) DO DEC (rDepth); r [rDepth].Next ENDSyntax10i.Scn.Fnt088#Syntax10.Scn.Fnt>> IF ~first THEN Out.String (", ") ELSE first := FALSE END; Out.String (r [0].name); FOR l := 1 TO rDepth DO IF r [l].mode = Ref.Elem THEN Out.String (" ["); Out.Int (r [l].idx, 0); Out.Char ("]") ELSE Out.Char ('.'); Out.String (r [l].name) END END%8=G REPEAT  Search next pointer or end of global variables  UNTIL (r [rDepth].mode = Ref.End) OR (r [rDepth].form = Ref.Pointer); IF r [rDepth].mode # Ref.End THEN S.GET (r [rDepth].Adr (), adr); k := 0; S.GET (X.GetPtrInMod (m, k), ptr); WHILE (k < (X.GetNoOfPtrsInMod (m) - 1)) & (ptr # adr) DO INC (k); S.GET (X.GetPtrInMod (m, k), ptr) END; IF (k < X.GetNoOfPtrsInMod (m)) & ((k MOD 32) IN objReached [k DIV 32]) THEN  Print pointers which anchore object  END; r [rDepth].Next END; INC (j) Syntax10i.Scn.FntQ8f Out.Ln; Out.Char (TAB); Out.String (m.name); Out.String (" {"); Ref.OpenVars (m.name, r [0]); rDepth := 0; j := 0; first := TRUE; WHILE (j < MaxPointersInModule * 32) & ((r [rDepth].mode # Ref.End) OR (rDepth > 0)) DO  Search and print pointer-variables which anchores indirect the specified object  END; Out.Char ('}')<8  FOR j := 0 TO MaxPointersInModule - 1 DO objReached [j] := {} END; IF CheckReachMod (S.VAL (Kernel.Block, mods.e [i].mod), objReached) THEN pos := X.AddressAbsToRel (mods.e [i].mod) DIV B; S.GET (mods.e [i].mod - 4, tdesc); size := tdesc^.size + 4; size := S.VAL (LONGINT, S.VAL (SET, size + B-1) - S.VAL (SET, B-1)); sizeB := size DIV B; INC (s.cReach.size, size2); INC (s.cReach.objs); MapSetMark (v.pReach, sizeB, pos); m := S.VAL (X.Module, mods.e [i].mod); IF ~v.reachedFVar THEN  Print modulenames  ELSE  Print modules and pointers which reach the selected object  END; INC (cnt) END Syntax10i.Scn.Fnt.8B VAR  BEGIN ASSERT (mods.ClearMarks () # Error); cnt := 0; pos := 0; ch := reachName [0]; reachName [0] := CAP (reachName [0]); Out.String (reachName); reachName [0] := ch; IF reachModule # "" THEN Out.String (reachModule); Out.Char ('.'); Out.String (reachType); Out.Char (' ') END; Out.String ("reachable from module(s):"); cnt := 0; FOR i := 0 TO mods.cnt - 1 DO  Search for modules reaching specified object  END; IF cnt = 0 THEN Out.Ln; Out.String ("Object is not reachable from any module") END; Out.Char ('.'); Out.Ln END ModReachedFrom; 88Syntax10.Scn.FntH8FoldElemsNew#Syntax10.Scn.Fntp, end: X.Blockm4Ptr; tdesc: X.Tag; lastTime, hBSize: LONGINT; withPtr, abort: BOOLEAN; ch: CHAR; picElem: Elem; x, y, yh, iterator, kind: INTEGER;8i8$Syntax10i.Scn.Fnt.. Run through heap and register marked objects 8 VAR  BEGIN abort := FALSE; hBSize := X.GetHeapSize () DIV B; x := 0; y := 0; lastTime := 0; Out.String ("Press ESC to abort "); pos := 0; IF v.peAll # NIL THEN picElem := v.peAll ELSE picElem := v.peReach END; ASSERT (picElem # NIL); iterator := 0; WHILE X.GetNextMemBlock (p, end, iterator (* = Number of heap *) ) DO WHILE (p # end) & (~abort) DO  kind := X.GetObjType (S.VAL (S.PTR, S.VAL (LONGINT, p) + 4), tdesc, size2); withPtr := (kind = array) OR (kind = other); size := S.VAL (LONGINT, S.VAL (SET, size2 + B-1) - S.VAL (SET, B-1)); sizeB := size DIV B; WHILE lastTime < pos * 1024 DIV hBSize DO INC (lastTime); WHILE (Input.Available () # 0) DO Input.Read (ch); IF ORD (ch) = ESC THEN abort := TRUE END END; IF lastTime MOD 10 = 0 THEN Descs.UnmarkAll (); yh := y; DrawBlock (hBSize * 10 DIV 1024, pos, invert, picElem, x, y); picElem.pic.Update (NIL, 0, yh * v.pointH, picElem.pic.width, (y - yh) * v.pointH); IF lastTime MOD 50 = 0 THEN Out.Char ('.') END END END; IF withPtr THEN IF CheckReach (S.VAL (Kernel.Block, S.VAL (LONGINT, p) + 4), FALSE) THEN INC (s.cReach.size, size2); INC (s.cReach.objs); MapSetMark (v.pReach, sizeB, pos) END END; INC (S.VAL(LONGINT, p), size); INC (pos, sizeB)  END END; Descs.UnmarkAll (); IF abort THEN OutStringLn (" aborted.") ELSE pos := X.GetHeapSize () DIV B; OutStringLn (" completed.") END END ReachedFrom; 8v CONST MaxPointersInModule = 16 (* 16 * 32 = 512 *); MaxRecordDepth = 16; TYPE PointersInMod = ARRAY MaxPointersInModule OF SET; VAR size, size2, sizeB, pos: LONGINT; PROCEDURE CheckReach (reach: Kernel.Block; unmark: BOOLEAN): BOOLEAN;  PROCEDURE CheckReachMod (reach: Kernel.Block; VAR pInMod: PointersInMod): BOOLEAN;  PROCEDURE Reach ();  PROCEDURE ModReachedFrom ();  PROCEDURE ReachedFrom ();  BEGIN IF reachPtr # NIL THEN IF v.drwReach THEN IF v.reachedFrom THEN ReachedFrom () ELSE Reach () END END; IF v.reachedFMod OR v.reachedFVar THEN ModReachedFrom () END END END VisHeapReachable; 78 W89Syntax10.Scn.FntR8FoldElemsNew#Syntax10.Scn.Fnt VAR blocks, i: LONGINT; BEGIN blocks := S.VAL (LONGINT, S.VAL (SET, s.cSel.size + B-1) - S.VAL (SET, B-1)) DIV B; IF pos < 0 THEN DEC (blocks, -pos); pos := 0 END; IF (zoomStart + blocks + pos) >= zoomEnd THEN DEC (blocks, zoomStart + blocks + pos - zoomEnd) END; FOR i := 0 TO blocks - 1 DO INCL (v.pSelect [(pos + i) DIV 32], (pos + i) MOD 32) END END SetBlockSelection; 8G8Syntax10.Scn.Fntb^8FoldElemsNew#Syntax10.Scn.Fnt IF (sel.type = "") OR (types.elems [i].type.name = sel.type) THEN INC (s.cSel.objs); typeS := S.VAL (X.Tag, types.elems [i].type); INC (s.cSel.size, typeS.size + 4); blocks := S.VAL (LONGINT, S.VAL (SET, (typeS.size + 4) + B-1) - S.VAL (SET, B-1)) DIV B; pos := X.AddressAbsToRel (S.VAL (LONGINT, types.elems [i].type)) DIV B - zoomStart - 1; IF pos < 0 THEN DEC (blocks, -pos); pos := 0 END; IF (zoomStart + blocks + pos) >= zoomEnd THEN DEC (blocks, zoomStart + blocks + pos - zoomEnd) END; FOR j := 0 TO blocks - 1 DO INCL (v.pSelect [(pos + j) DIV 32], (pos + j) MOD 32) END END Syntax10i.Scn.Fnt(8 VAR i, j, beg, end, pos, blocks: LONGINT; typeS: X.Tag; BEGIN s.cSel.size := 0; s.cSel.objs := 0; IF sel.mod # "" THEN pos := mods.Find (sel.mod); IF pos # NotFound THEN beg := mods.e [pos].typePos; end := beg + mods.e [pos].objTypes ELSE beg := 0; end := 0 END ELSE beg := 0; end := types.count END; FOR i := beg TO end - 1 DO  Register the specified typedescriptors  END END SelectTypedesc; 8!J8#Syntax10.Scn.Fnt VAR pos, blocks, i: LONGINT; BEGIN pos := mods.Find (sel.mod); IF pos # NotFound THEN s.cSel.objs := 1; s.cSel.size := SIZE (X.ModuleDesc) + 4; blocks := S.VAL (LONGINT, S.VAL (SET, SIZE (X.ModuleDesc) + B+3) - S.VAL (SET, B-1)) DIV B; SetBlockSelection (X.AddressAbsToRel (mods.e [pos].mod) DIV B - zoomStart - 1); IF pos < 0 THEN DEC (blocks, -pos); pos := 0 END; IF (zoomStart + blocks + pos) >= zoomEnd THEN DEC (blocks, zoomStart + blocks + pos - zoomEnd) END; FOR i := 0 TO blocks - 1 DO INCL (v.pSelect [(pos + i) DIV 32], (pos + i) MOD 32) END ELSE s.cSel.objs := 0; s.cSel.size := 0 END END SelectModuleDesc; 868zSyntax10.Scn.Fnt%8FoldElemsNew#Syntax10.Scn.Fntr: Ref.Rider; name: ARRAY SelPatternLength OF CHAR; info, valInt, kind: INTEGER; end: BOOLEAN; val, arrPos, pointerAdr, i, oldPos, size: LONGINT; pointer: S.PTR; valS: SHORTINT; p: X.Blockm4Ptr; tdesc: X.Tag;838CSyntax10.Scn.FntSyntax10i.Scn.Fnt VAR ch: CHAR; BEGIN i := 0; ch := sel.pattern [pos]; IF ch # '[' THEN info := Field; IF ch = '.' THEN INC (pos) END ELSE info := Index; INC (pos) END; ch := sel.pattern [pos]; WHILE (ch # '.') & (ch # '[') & (ch # ']') & (ch # 0X) DO name [i] := ch; INC (i); INC (pos); ch := sel.pattern [pos] END; name [i] := 0X; IF ch = ']' THEN INC (pos) END; IF sel.pattern [pos] = 0X THEN RETURN TRUE END; (* End of trace *) RETURN FALSE END GetName;Syntax10i.Scn.Fnt+8 8<Syntax10.Scn.FntSyntax10b.Scn.Fnt i := 0; WHILE (ORD (name [i]) >= ORD ('0')) & (ORD (name [i]) <= ORD ('9')) DO val := val * 10 + ORD (name [i]) - ORD ('0'); INC (i) END; type := Number; RETURN val88<Syntax10.Scn.FntSyntax10b.Scn.Fnt sel.traceResult := ModuleSelected; COPY (sel.pattern, sel.traceResName); COPY (sel.pattern, sel.mod); SelectModuleDesc (); type := NoType; RETURN NoValue/88:Syntax10.Scn.FntsSyntax10i.Scn.Fnt' ^8FoldElemsNew Syntax10.Scn.FntN8FoldElemsNewSyntax10.Scn.Fnt!Syntax10b.Scn.Fnt >q8FoldElemsNewCSyntax10.Scn.Fnt8Syntax10b.Scn.FntM sel.traceResult := NoValidVar; type := NoType; RETURN NoValue Syntax10i.Scn.Fnt8i8<Syntax10.Scn.FntSyntax10b.Scn.Fnt COPY (sel.pattern, sel.traceResName); sel.traceResName [pos] := 0X; sel.traceAdr := arrPos; sel.traceResult := IndexOverflow; type := NoType; RETURN NoValue81]8#Syntax10.Scn.Fnt type := Pointer; sel.traceResult := TraceOK; r.ReadPtr (pointer) ELSIF r.form = Ref.Record THEN r.Zoom (r) 8P pos := oldPos; arrPos := SelectTrace (type); IF (type # Number) OR (arrPos = NoValue) THEN  Index is not a number  END; IF (arrPos >= 0) & (arrPos < r.len) & (r.mode = Ref.Elem) THEN r.SetTo (arrPos) ELSE  Index of array overflow  END; IF r.form = Ref.Pointer THEN  Array of pointer  ENDSyntax10i.Scn.FntH8~8Syntax10.Scn.Fnte8FoldElemsNewCSyntax10.Scn.FntSyntax10b.Scn.Fnt COPY (sel.pattern, sel.traceResName); sel.traceResName [pos] := 0X; sel.traceResult := VarNotFound; type := NoType; RETURN NoValue Syntax10i.Scn.Fnt#8+#68#Syntax10.Scn.Fnt r.ReadPtr (pointer); type := Pointer; sel.traceResult := TraceOK; IF pointer = NIL THEN end := TRUE; ELSIF ~end THEN r.Zoom (r) END8XSyntax10b.Scn.Fnt W a  +8<Syntax10.Scn.FntSyntax10b.Scn.Fnt COPY (sel.pattern, sel.traceResName); sel.traceResName [pos] := 0X; sel.traceResult := NoValidVar; type := NoType; RETURN NoValue-8  WHILE (r.mode # Ref.End) & (r.name # name) DO r.Next () END; IF r.mode = Ref.End THEN  Variable-name not found in record  END; pointerAdr := r.base + r.off; (* Access to Hiddenbase (r.base) *) CASE r.form OF Ref.Record, Ref.Array, Ref.DynArr: r.Zoom (r); sel.traceResult := NotAPointer | Ref.Pointer:  Pointer found  | Ref.Int: r.ReadInt (valInt); type := Number; sel.traceResult := NotAPointer; RETURN valInt | Ref.LInt: r.ReadLInt (val); type := Number; sel.traceResult := NotAPointer; RETURN val | Ref.SInt: r.ReadSInt (valS); type := Number; sel.traceResult := NotAPointer; RETURN valS ELSE  Variable is not a number, record or pointer  END@8! oldPos := pos; end := GetName (info); IF info = Index THEN  Get index-value (recursive call) and trace into array (not yet tested)  ELSIF name # "" THEN  Trace into record (select ident of record with specified name)  ELSE end := TRUE END8.8USyntax10i.Scn.FntSyntax10.Scn.FntZSyntax10b.Scn.Fnt~(* Module not found *) COPY (name, sel.traceResName); sel.traceResult := ModNotFound; type := NoType; RETURN NoValue88USyntax10i.Scn.Fnt.Syntax10.Scn.FntXSyntax10b.Scn.Fnt(* Module not found in internal module-list *) COPY (name, sel.traceResName); sel.traceResult := ModNotFound; type := NoType; RETURN NoValue*8? info := Field; IF mods.Find (name) # NotFound THEN Ref.OpenVars (name, r); IF r.mode # Ref.End THEN (* Global variables of module opened *) REPEAT  Trace variable (recursively)  UNTIL end ELSE  Module not found by Ref  END ELSE  Module not found in internal module-list  END18m8#Syntax10.Scn.Fntqq kind := X.GetObjType (pointer, tdesc, size); (* p := S.VAL (X.Blockm4Ptr, S.VAL (LONGINT, S.VAL (SET, pointer) - {markBit, arrayBit}) - 4); *) s.cSel.size := size; s.cSel.objs := 1; SetBlockSelection (X.AddressAbsToRel (S.VAL (LONGINT, pointer)) DIV B - zoomStart - 1); sel.traceAdr := S.VAL (LONGINT, pointer); COPY (sel.pattern, sel.traceResName)8 8\Syntax10.Scn.FntSyntax10i.Scn.FntnSyntax10b.Scn.Fnt (* pointer = NIL *) COPY (sel.pattern, sel.traceResName); sel.traceResName [pos] := 0X; sel.traceResult := TraceNIL; RETURN NoValue+85 CONST Field = 0; Index = 1; VAR  PROCEDURE GetName (VAR info: INTEGER): BOOLEAN;  info: Index/Field / Ret-val: end of trace  BEGIN val := 0; pointer := NIL; pointerAdr := 0; sel.traceResult := TraceOK; end := GetName (info); IF (ORD (name [0]) >= ORD ('0')) & (ORD (name [0]) <= ORD ('9')) THEN  number specified  ELSIF end THEN  Only a module-name specified -> Select module  ELSE  Modulename and variable-name specified -> trace  END; IF sel.traceResult = NotAPointer THEN COPY (sel.pattern, sel.traceResName) ELSIF type = Pointer THEN IF pointer # NIL THEN  Set selection (for bitmap)  ELSE  Trace not possible because of NIL-pointer  END END; RETURN pointerAdr END SelectTrace; 828 Syntax10.Scn.Fnt(8FoldElemsNewUSyntax10.Scn.Fnt?8FoldElemsNew#Syntax10.Scn.FntisMarked: BOOLEAN; kind, iterator: INTEGER; p, end: X.Blockm4Ptr; size, size2, sizeB, sizeR, pos, mPos, blockEnd, i: LONGINT; tag, notmarked, tdesc: X.Tag;88Syntax10.Scn.Fnt&Syntax10i.Scn.Fnt;!!8FoldElemsNewCSyntax10.Scn.FntSyntax10i.Scn.Fnt  mPos := pos - zoomStart; IF blockEnd > zoomEnd THEN blockEnd := zoomEnd END; IF mPos <= 0 THEN sizeR := pos + sizeB - zoomStart; mPos := 0 ELSE sizeR := sizeB END; IF ~((mPos MOD 32) IN v.pMarked [mPos DIV 32]) THEN (* -> PROC MapSet not useable *) INC (s.cSel.size, size2); INC (s.cSel.objs); i := 0; WHILE (i < sizeR) & ((pos + i) < blockEnd) DO INCL (v.pSelect [(mPos + i) DIV 32], (mPos + i) MOD 32); INC (i) END END 8a tag := p^.tag; IF ~(markBit IN S.VAL (SET, tag)) THEN notmarked := tag; isMarked := FALSE; ELSE notmarked := S.VAL (X.Tag, S.VAL (SET, tag) - {markBit}); isMarked := TRUE END; tdesc := S.VAL (X.Tag, S.VAL (SET, notmarked) - {arrayBit}); IF notmarked # tdesc THEN (* array block with pointer *) size := p^.lastElemToMark + tdesc^.size - S.VAL(LONGINT, p); kind := array ELSE size := tdesc^.size + 4; IF S.VAL (LONGINT, notmarked) = S.ADR (p^.tag) + 4 THEN (*Typedesc,Freebl,Sysbl,array*) IF p^.m4 # -4 THEN kind := free ELSE kind := other (*Typedescriptor,Sysblock,array*) END ELSE kind := other END END; size2 := size; size := S.VAL(LONGINT, S.VAL(SET, size + B-1)-S.VAL(SET, B-1)); sizeB := size DIV B; IF (kind # free) & isMarked THEN blockEnd := pos + sizeB; IF (blockEnd > zoomStart) & (pos < zoomEnd) THEN  Update Set-Array  END; p^.tag := notmarked END; INC(S.VAL(LONGINT, p), size); INC (pos, sizeB) Syntax10i.Scn.Fnt=8- VAR  BEGIN s.cSel.size := 0; s.cSel.objs := 0; Kernel.Mark (ptr); pos := 0; mPos := 0; iterator := 0; WHILE X.GetNextMemBlock (p, end, iterator (* = Number of heap *) ) DO WHILE p # end DO  Search only from ptr reached objects and unmark all objects  END END END Reach; 8DSyntax10i.Scn.FntSyntax10b.Scn.Fnt$-+?"'L4/2M PROCEDURE Reach (ptr: Kernel.Block);  BEGIN IF (pPos = S.VAL (LONGINT, NIL)) OR (pPos = NoValue) THEN (* Not found *) RETURN END; S.GET (pPos, visHSSavePtr); (* Save selected pointer *) IF S.VAL (S.PTR, visHSSavePtr) = NIL THEN RETURN END; sel.traceResult := OnlyAnchoredByOK; visHSSavePtrR := S.VAL (LONGINT, reachPtr); reachPtr := NIL; (* Save and reset reach-pointer *) S.PUT (pPos, S.VAL (LONGINT, NIL)); (* Reset selected pointer *) MarkCollectable (); (* v.pMarked contains all objects which are reachable from other pointers *) S.PUT (pPos, visHSSavePtr); (* Restore selected pointer *) reachPtr := S.VAL (Kernel.Block, visHSSavePtrR); (* Restore reach-pointer *) Reach (S.VAL (Kernel.Block, visHSSavePtr)); (* Reachable from sel. ptr minus marked objects *) v.ClearMap (v.pMarked) (* v.pMarked is cleared because of a possible use from VisualizeHeapMarked *) END SelectOnlyAnchoredBy; 8V8Syntax10.Scn.Fnth8FoldElemsNew#Syntax10.Scn.Fntvvpos, patLen, size, size2, sizeB, i: LONGINT; ch: CHAR; tdesc: X.Tag; p, end: X.Blockm4Ptr; kind, iterator: INTEGER;8m8#Syntax10.Scn.Fntqq kind := X.GetObjType (S.VAL (S.PTR, S.VAL (LONGINT, p) + 4), tdesc, size2); size := S.VAL (LONGINT, S.VAL (SET, size2 + B - 1) - S.VAL (SET, B - 1)); sizeB := size DIV B; IF (kind = other) & (size2 >= (sel.pos + patLen)) THEN i := 0; S.GET (S.VAL (LONGINT, p) + 4 + sel.pos, ch); WHILE (i <= patLen) & (sel.pattern [i] = ch) DO INC (i); S.GET (S.VAL (LONGINT, p) + 4 + sel.pos + i, ch) END; IF i > patLen THEN INC (s.cSel.size, size2); INC (s.cSel.objs); MapSet (v.pSelect, kind, sizeB, pos); END END; INC(S.VAL(LONGINT, p), size); INC (pos, sizeB) 8 VAR  BEGIN pos := 0; patLen := 0; iterator := 0; WHILE (patLen < 99) & (sel.pattern [patLen] # 0X) DO INC (patLen) END; WHILE X.GetNextMemBlock (p, end, iterator (* = Number of heap *) ) DO WHILE p # end DO  END END END SelectObjects; Syntax10i.Scn.FntB86 CONST NoValue = -1; NoType = NoValue; Pointer = 1; Number = 2; VAR pPos, pos: LONGINT; type: INTEGER; PROCEDURE SetBlockSelection (pos: LONGINT);  PROCEDURE SelectTypedesc ();  PROCEDURE SelectModuleDesc ();  PROCEDURE SelectTrace (VAR type: INTEGER): LONGINT;  PROCEDURE SelectOnlyAnchoredBy (pPos: LONGINT);  PROCEDURE SelectObjects ();  Show all objects with a specified string at a specified position  BEGIN CASE sel.kind OF typeDesc: SelectTypedesc () | module: SelectModuleDesc () | trace: pos := 0; pPos := SelectTrace (type); | onlyAnchored: pos := 0; pPos := SelectTrace (type); IF type = Pointer THEN SelectOnlyAnchoredBy (pPos) END | other: SelectObjects () ELSE END END VisHeapSelected; =8 b281Syntax10.Scn.Fnt?<8FoldElemsNewSyntax10.Scn.FntSyntax10i.Scn.Fnt8FoldElemsNew$Syntax10i.Scn.FntLn; StringInt ("Heapmap starts at Address (rel.): ", Kernel.heapAdr + (zoomStart + 1) * B); StringInt (" (", (zoomStart + 1) * B); Ch (')'); StringInt (" [Min (rel.): ", Kernel.heapAdr + B); StringInt (" (", B); StringLn (")]"); StringInt ("Heapmap ends at Address (rel.): ", Kernel.heapAdr + zoomEnd *B + B - 1); StringInt (" (", zoomEnd * B + B - 1); Ch (')'); StringInt (" [Max (rel.): ", Kernel.heapAdr + Kernel.heapSize + B - 1); StringInt (" (", Kernel.heapSize + B - 1); StringLn (")]"); '8*' VAR iterator: INTEGER; first, end: X.Blockm4Ptr; BEGIN Ln; iterator := 0; StringAInt ("Heapmap from rel. address ", (zoomStart + 1) * B); StringAInt (" to ", zoomEnd * B - 1); StringAInt (" / allowed from ", B); StringAInt (" to ", X.GetHeapSize () - 1); Ch (' '); InsertFolds (t.hItxt, TRUE, FALSE, FALSE); Ln; StringAInt ("Heapmap from abs. addresses ", X.AddressRelToAbs ((zoomStart + 1) * B)); StringAInt (" to ", X.AddressRelToAbs (zoomEnd * B - 1)); WHILE X.GetNextMemBlock (first, end, iterator) DO Ln; StringAInt (" abs. addresses allowed from ", S.VAL (LONGINT, first) + B + 4); StringAInt (" to ", S.VAL (LONGINT, end) + 3) END; InsertFolds (t.hItxt, FALSE, FALSE, TRUE); Ln; (* Old version (only for Windows Oberon) *) Append (t.hItxt); END PrintAddresses; 88_Syntax10.Scn.FntuSyntax10i.Scn.Fnt$Ci VAR zoomVal, heightCorr: LONGINT; i: INTEGER; BEGIN IF zoomEnd <= zoomStart THEN zoomEnd := zoomStart + 1 END; (* zoomEnd greater than zoomStart *) heightCorr := 100 * v.picMaxHeight DIV ((X.GetHeapSize () DIV B) DIV v.picWidth); IF (zoomEnd - zoomStart) DIV v.picWidth > v.picMaxHeight THEN zoomEnd := zoomStart + (zoomEnd - zoomStart) * heightCorr DIV 100 END; zoomVal := (X.GetHeapSize () DIV B) * heightCorr DIV 100 DIV (zoomEnd - zoomStart); v.pointW := 1; v.pointH := 1; i := 0; WHILE (i < 3) & (zoomVal >= 2) DO (* Max 3 times zoomed in x and y-direction (zoomfactor max = 64) *) IF zoomVal >= 2 THEN v.pointH := v.pointH * 2; zoomVal := zoomVal DIV 2 END; IF zoomVal >= 2 THEN v.pointW := v.pointW * 2; zoomVal := zoomVal DIV 2 END; INC (i) END; v.picHeight := SHORT(((zoomEnd - zoomStart) * v.pointW) DIV v.picWidth * v.pointH) + v.pointH (*big enough for displaying a map for the heap, each 32 bytes block is represented by one pixel(field).*) END ResizePictures; 8#g8#Syntax10.Scn.Fntww BEGIN StringInt ("Heapsize: ", X.GetHeapSize () DIV 1024); String (" kB"); StringInt (", bytes allocated: ", X.GetHeapSize () - s.avail); StringInt (", available (largest): ", s.avail); StringInt (" (", Kernel.LargestAvailable ()); StringLn (")"); Int (s.cAll.objs); StringInt (" blocks on the heap (", s.cAll.size); StringLn (" bytes)."); END PrintHeapStatistic; Syntax10i.Scn.Fnt18-8#Syntax10.Scn.Fnt VAR col, red, green, blue: INTEGER; BEGIN NEW (picture); picture.handle := ElemHandler; NEW (picture.pic); picture.pic.Init (SHORT (v.picWidth), SHORT (v.picHeight), 4); IF picture.pic.depth = 0 THEN HALT (99) END; IF (picture.pic.width # v.picWidth) OR (picture.pic.height # v.picHeight) THEN HALT (98) END; FOR col := 0 TO 15 DO Display.GetColor (col, red, green, blue); picture.pic.SetPalette (col, red, green, blue) END; Texts.WriteElem (t.w, picture); Append (t.hItxt) END InitPicture; 08j8Syntax10.Scn.Fnt,8FoldElemsNew#Syntax10.Scn.Fnt BEGIN IF drw THEN Ln; StringLn (str); InitPicture (elem); NEW (m, (zoomEnd - zoomStart) DIV B + 2) ELSIF ~o THEN elem := NIL; m := NIL END; END Redraw; 8y8#Syntax10.Scn.Fntee IF mods.CountUnload () # 0 THEN Ln; String ("Unloaded Modules: "); i := 0; FOR j := 0 TO mods.cnt - 1 DO IF mods.e [j].specUnload THEN IF mods.e [j].unloadParents THEN Ch ('*') END; IF i # 0 THEN String (", ") END; mod := S.VAL (X.Module, mods.e [j].mod); String (mod.name); INC (i) END END END;Syntax10i.Scn.Fnt8] VAR i: INTEGER; j: LONGINT; mod: X.Module; PROCEDURE Redraw (str: ARRAY OF CHAR; drw, o: BOOLEAN; VAR elem: Elem; VAR m: Map);  BEGIN IF v.redrawPic THEN ResizePictures (); IF v.drwAll THEN InitPicture (v.peAll) ELSE v.peAll := NIL END; IF v.drwMarked OR v.drwNotMarked THEN  Print test-unloaded modules  Redraw ("Collectable blocks:", v.drwNotMarked, FALSE, v.peNotMarked, v.pMarked); Redraw ("Not collectable blocks:", v.drwMarked, v.drwNotMarked, v.peMarked, v.pMarked) END; IF v.drwReach THEN Redraw ("Reachable blocks from selected block:", v.drwReach, FALSE, v.peReach, v.pReach) ELSE Redraw ("Blocks reaching selected block:", v.drwReach, FALSE, v.peReach, v.pReach) END; Redraw ("Selected blocks:", v.drwSelect, FALSE, v.peSelect, v.pSelect); IF v.drwSelect & (v.pMarked = NIL )THEN NEW (v.pMarked, (zoomEnd - zoomStart) DIV 32 + 2) END END END RedrawPictures; 88#Syntax10.Scn.Fnt(( VAR i: INTEGER; BEGIN FOR i := 0 TO s.nrOfTypeN - 1 DO SetTextColor (this + i, 1); Ch ('#'); SetTextColor (this + i, 0); Ch ('#'); Int (s.t [i].nrOfObjs); IF s.t [i].type = "" THEN String (" object(s) from module "); String (s.t [i].mod) ELSE String (" object(s) of type "); String (s.t [i].mod); Ch("."); String (s.t [i].type) END; IF s.t [i].derived THEN String (" and derived") END; IF s.t [i].nrOfObjs # 0 THEN IF s.t [i].derived OR (s.t [i].type = "") THEN StringInt (" with sizes from ", s.t [i].size); StringInt (" up to ", s.t [i].maxSize); ELSE StringInt (" with a size of ", s.t [i].size) END; String (" bytes;"); Ln; Tab; Tab; StringInt ("Total size: ", s.t [i].totalSize); String (" bytes;"); IF s.t [i].derived OR (s.t [i].type = "") THEN StringInt (" Level(s) of derivation (min/max): ", s.t [i].minLevel); Ch ('/'); Int (s.t [i].maxLevel) ELSE StringInt (" Level of derivation: ", s.t [i].minLevel) END END; Ch (';'); Ln END; SetColor (black); Ln END PrintMarked; 88_Syntax10.Scn.FntSyntax10i.Scn.Fnt BEGIN StringInt ("Number of free blocks: ", s.cFree.objs); StringInt (" / Size: ", s.cFree.size); Ln; IF (s.nrOfTypeN < 3 (* Arrays with pointers *)) & v.defBlockCol THEN SetTextColor (array, 1); Ch ('#'); SetTextColor (array, 0); Ch ('#') END; StringInt ("Number of arrays with pointer: ", s.cArr.objs); StringInt (" / Size: ", s.cArr.size); Ln; IF (s.nrOfTypeN < 4 (* Typedescriptors *)) & v.defBlockCol THEN SetTextColor (typeDesc, 1); Ch ('#'); SetTextColor (typeDesc, 0); Ch ('#') END; StringInt ("Number of typedescriptors: ", s.cType.objs); StringInt (" / Size: ", s.cType.size); Ln; IF (s.nrOfTypeN < 5 (* SysBlocks *)) & v.defBlockCol THEN SetTextColor (sysBlock, 1); Ch ('#'); SetTextColor (sysBlock, 0); Ch ('#') END; StringInt ("Number of sysblocks and arrays without pointer: ", s.cSys.objs); StringInt (" / Size: ", s.cSys.size); SetColor (black); Ln; Ln END PrintDefBlock; 8!8#Syntax10.Scn.Fnt VAR b: LONGINT; parc: TextFrames.Parc; i: INTEGER; copy: Texts.CopyMsg; BEGIN t.parc2.handle (t.parc2, copy); parc := copy.e (TextFrames.Parc); parc.nofTabs := 3; parc.tab [0] := 1200000; parc.tab [1] := 2400000; parc.tab [2] := 3600000; Texts.WriteElem (t.w, parc); StringLn ("Object sizes:"); b := B; FOR i := 1 TO LEN (s.objSizes) DO StringInt ("Up to ", b); StringInt (": ", s.objSizes [i - 1]); Tab; IF i MOD 4 = 0 THEN Ln END ; b := b * 2 END; Ln END PrintObjSizeStat; 88CSyntax10.Scn.FntSyntax10b.Scn.FntM BEGIN IF (sel.traceResult # Changed) & (sel.traceResult = sel.lastTResult) & (sel.traceAdr = sel.lastTAdr) THEN RETURN END; sel.lastTResult := sel.traceResult; sel.lastTAdr := sel.traceAdr; CASE sel.traceResult OF TraceOK: Out.Char ('"');Out.String (sel.traceResName); Out.Char ('"'); Out.Ln; Out.String ("traced to an object at "); Out.Int (sel.traceAdr, 0); Out.String (" ("); Out.Int (X.AddressAbsToRel (sel.traceAdr), 0); Out.String (").") | TraceNIL: Out.String ('Trace of "'); Out.String (sel.traceResName); Out.String ('" = NIL.') | ModNotFound: Out.String ('Trace error: Module "'); Out.String (sel.traceResName); Out.String ('" not found.') | VarNotFound: Out.String ('Trace error: Name "'); Out.String (sel.traceResName); Out.String ('" not found.') | IndexOverflow: Out.String ("Index ("); Out.Int (sel.traceAdr, 0); Out.String (') overflow "'); Out.String (sel.traceResName); Out.String ('".') | NotAPointer: Out.String ('Trace error: "'); Out.String (sel.traceResName); Out.String ('" is not a pointer.') | OnlyAnchoredByOK: Out.String ('Only anchored by "'); Out.String (sel.pattern); Out.String ('" shown.') | NoValidVar: Out.String ('Variable "'); Out.String (sel.traceResName); Out.String ('" has not a valid type.') | ModuleSelected: Out.String ("Module "); Out.String (sel.traceResName); Out.String (" selected.") ELSE Out.String ("Unknown trace error.") END; Out.Ln END PrintTraceMsg; 8398/Syntax10.Scn.Fnt,Syntax10i.Scn.Fnt50;/6b8FoldElemsNew#Syntax10.Scn.Fnt|| Ln; Int (s.cModLess.objs); StringInt (" moduleless object(s) with a size of ", s.cModLess.size); String (" bytes.") -8.R8#Syntax10.Scn.Fnt Ln; Ln; StringInt ("There are ", s.cMark.objs); StringInt (" objects with a size of ", s.cMark.size); String (" bytes to collect.") .88#Syntax10.Scn.Fnt Ln; Ln; IF reachName = "" THEN String ("No block selected.") ELSE StringInt ("There are ", s.cReach.objs); StringInt (" objects with a size of ", s.cReach.size); StringLn (" bytes"); String (" reachable from a object of type "); String (reachName); IF reachModule # "" THEN String (reachModule); Ch ('.'); String (reachType) END; Ln; adr := S.VAL (LONGINT, reachPtr); StringAInt (" at address (rel.): ", adr); StringAInt (" (", X.AddressAbsToRel (adr)); String (").") END D80h8#Syntax10.Scn.Fntvv Ln; Ln; StringInt ("There are ", s.cSel.objs); StringInt (" objects with a size of ", s.cSel.size); StringLn (" bytes"); Tab; CASE sel.kind OF other: String ("selected object(s) with string ") | typeDesc: String ("selected typedescriptor(s): ") | module: String ("selected module(s) ") | trace: String ("trace of ") | onlyAnchored: String ("only anchored by ") END; Ch ('"'); String (sel.pattern); Ch ('"'); CASE sel.kind OF other: StringInt (" at position ", sel.pos); Ch (' ') | onlyAnchored: String (" (Only objects shown on the map are counted)") ELSE END; Ch ('.') /8 PrintHeapStatistic (); PrintMarked (); (* Print marked modules / types in the right color *) IF v.defBlockShow THEN PrintDefBlock () END; (* Prints sys-, freeblks, arrays and typedescs colorized *) IF v.objSizes THEN PrintObjSizeStat () END; (* Print a statistic of sizes from existing objects *) StringInt ("Internal fragmentation causes a loss of ", s.frag); String (" bytes ("); IF s.all > 0 THEN Texts.WriteRealFix (t.w, s.frag / s.all * 100.0, 4, 2); String (" %).") ELSE String ("No objects counted).") END; IF s.cModLess.objs # 0 THEN  Print number and size of moduleless objects  END; IF v.drwMarked OR v.drwNotMarked THEN  Print number and size of collectable objects  END; IF v.drwReach THEN  Print number and size of objects, reachable from the specified obj  END; IF v.drwSelect & (sel.kind # None) THEN  Print number and size of the selected objects  END; Append (t.hItxt) %8 VAR adr: LONGINT; gc: BOOLEAN; PROCEDURE PrintAddresses ();  PROCEDURE ResizePictures ();  PROCEDURE PrintHeapStatistic ();  Statistics about heapsize and number of objects  PROCEDURE InitPicture (VAR picture: Elem);  Creates new pictures and sets the elem-handler  PROCEDURE RedrawPictures ();  PROCEDURE PrintMarked ();  PROCEDURE PrintDefBlock ();  PROCEDURE PrintObjSizeStat ();  PROCEDURE PrintTraceMsg ();  BEGIN IF t.hItxt # NIL THEN RedrawPictures (); (* Redraw pictureelems *) v.ClearAllMaps (); PrintAddresses () END; IF mods.CheckUpdate (types) THEN ModulesChanged () END; s.Reset (FALSE); mods.CntReset (); gc := Kernel.GCenabled; Kernel.GCenabled := FALSE; (* Disable Garbage-Collector *) IF v.drwSelect THEN VisHeapSelected END; IF v.drwReach OR v.reachedFMod OR v.reachedFVar THEN VisHeapReachable END; IF v.drwNotMarked OR v.drwMarked THEN MarkCollectable (); VisualizeHeap () ELSE VisualizeHeap () END; Kernel.GCenabled := gc; (* Restore Garbage-Collector *) IF v.drwSelect & ((sel.kind = trace) OR (sel.kind = onlyAnchored)) THEN PrintTraceMsg () END; s.avail := Kernel.Available(); IF t.hItxt # NIL THEN  Heapmap-viewer opened -> Print text  END; v.redrawPic := FALSE (* Maps redrawn -> reset *) END HeapDraw;  8 (* Procedures for visualizing the objects on the heap on different criteria *) PROCEDURE VisualizeHeapMarked ();  Get (by GC) marked objects on the heap  PROCEDURE VisualizeHeap ();  Draw heapmaps  PROCEDURE MarkCollectable ();  Marking objects which are collected by next GC-run  PROCEDURE VisHeapReachable ();  Show reachable objects (reachable, reached from, ...)  PROCEDURE VisHeapSelected ();  Show selected object, moduledescriptor, typedescriptor, ...  PROCEDURE HeapDraw ();  Textual statistics of the heap  #8 8DSyntax10.Scn.FntSyntax10i.Scn.FntMarkElemsAllocI kKSyntax10b.Scn.Fnt8FoldElemsNew#Syntax10.Scn.Fnt22 BEGIN IF t.hItxt # NIL THEN v.PicHandlerSet (FALSE); t.menuViewer.dsc.next.handle := oldHandler END; ReadMarkNames (); OpenMainViewer ("HeapInspector", t.hItxt, ""); v.picWidth := ((t.menuViewer.W - TextFrames.barW - 16) DIV 8) * 8; v.redrawPic := TRUE; HeapDraw (); GCInspectHeapOpen END HeapMap; E8 kK 8#Syntax10.Scn.Fnt44 BEGIN DeleteText (); HeapDraw () END HeapUpdate; +8 kKx8#Syntax10.Scn.Fntff BEGIN ReadMarkNames (); IF t.hItxt # NIL THEN DeleteText () END; HeapDraw () END HeapMarkObjects; 78 `8Syntax10.Scn.Fntq.8FoldElemsNew#Syntax10.Scn.Fnt VAR thisCh: CHAR; BEGIN thisCh := nextCh; WHILE (thisCh = 0X) OR (thisCh = ' ') OR (thisCh = TAB) OR (thisCh = CHR (LN)) OR (thisCh = '*') DO In.Char (thisCh) END; IF thisCh # '~' THEN In.Char (nextCh) ELSE nextCh := '~' END; eoName := (nextCh = '*') OR (nextCh = ' ') OR (nextCh = TAB) OR (~In.Done) OR (nextCh = CHR (LN)) OR (nextCh = 0X) OR (nextCh = '~') OR (thisCh = '~'); RETURN thisCh END ReadNext;8b8#Syntax10.Scn.Fnt|| VAR i: INTEGER; BEGIN IF ~In.Done THEN modName := ""; RETURN END; i := 0; eoName := FALSE; modName [i] := ReadNext (); INC (i); IF modName [i - 1] # '~' THEN WHILE In.Done & (~eoName) & (i < 31) DO modName [i] := ReadNext (); IF modName [i] = '~' THEN modName [i] := 0X END; INC (i) END ELSE DEC (i) END; modName [i] := 0X END ReadModuleName;8i VAR modName: ARRAY 36 OF CHAR; n: LONGINT; nextCh: CHAR; eoName, endIn: BOOLEAN; PROCEDURE ReadNext (): CHAR;  PROCEDURE ReadModuleName ();  BEGIN nextCh := 0X; endIn := FALSE; mods.ResetUnload (); In.Open; HeapUpdate (); ReadModuleName (); IF modName = "" THEN OutStringLn ("No module will be test-unloaded."); unloadModDesc := FALSE ELSE OutStringLn ("Test-unloading module(s):"); WHILE ~endIn DO n := mods.Find (modName); IF n = NotFound THEN Out.String ("unknown module "); Out.String (modName); Out.Char ('.'); Out.Ln ELSE Out.String (modName); mods.SetUnload (n, nextCh = '*'); IF nextCh = '*' THEN Out.Char ('*') END END; ReadModuleName (); endIn := (nextCh = '~') OR (modName = ""); IF ~endIn THEN Out.String (", ") ELSE Out.Ln END END; mods.UpdateImports (); Out.Int (mods.CountUnload (), 0); OutStringLn (" modules will be unloaded."); v.drwNotMarked := TRUE; unloadModDesc := TRUE END; v.redrawPic := TRUE; HeapUpdate END TestUnloadModules; *8 =}|8#Syntax10.Scn.Fntbb BEGIN t.hItxt := NIL; v.PicHandlerSet (FALSE); GCInspectHeapClose (); System.Close END Quit; 8 =}8#Syntax10.Scn.Fnt BEGIN Texts.Delete (t.menuViewer.dsc(TextFrames.Frame).text, 16, 26); Texts.Copy (menuBuffer, t.w.buf); Append (t.menuViewer.dsc(TextFrames.Frame).text); v.PicHandlerSet (TRUE) END Cancel; 8 =} 8#Syntax10.Scn.Fnt"" BEGIN Out.String ("Unloading all modules from HeapInspector."); Out.Ln; Modules.Free ("HeapInspViewers", FALSE); Modules.Free ("HeapInspector", FALSE); Modules.Free ("HeapInspDescs", FALSE); Modules.Free ("Inspector", FALSE); Modules.Free ("Platform", FALSE); Quit END FreeModules; 8 #8CSyntax10.Scn.FntNSyntax10b.Scn.FntG BEGIN IF Oberon.Par.vwr = t.menuViewer THEN v.PicHandlerSet (FALSE); Texts.Delete (t.menuViewer.dsc(TextFrames.Frame).text, 16, 26); String ("HeapInspector.FreeModules"); TBold; InsertPopup (CreatePopup ("Unload HeapInspector and Quit"), t.menuViewer.dsc (TextFrames.Frame)); TDefault; String ("HeapInspector.Quit"); InsertPopup (CreatePopup ("Quit HeapInspector"), t.menuViewer.dsc(TextFrames.Frame)); String ("HeapInspector.Cancel"); InsertPopup (CreatePopup ("Cancel"), t.menuViewer.dsc(TextFrames.Frame)); Append (t.menuViewer.dsc(TextFrames.Frame).text); RETURN END; System.Close; IF t.hItxt = NIL THEN FreeModules END END Close; %8 A8#Syntax10.Scn.Fnt BEGIN Out.Ln; Out.String ("Goodbye and thank you for using the HeapInspector."); Out.Ln; v.PicHandlerSet (FALSE); GCInspectHeapClose () END TermHandler; (8 8#Syntax10.Scn.Fnt&& BEGIN TermHandler () END FinHandler; 18 (* Commands for update and marking objects and for test unloading modules *) PROCEDURE HeapMap*;  Open a HeapInspector-viewer and mark objects of the specified types  PROCEDURE HeapUpdate*;  Update of all heapmaps, but no new viewer  PROCEDURE HeapMarkObjects*;  Mark objects of the specified types (opens no viewer)  PROCEDURE TestUnloadModules*;  Virtual unloading of one or more modules  PROCEDURE Quit*;  PROCEDURE Cancel*;  PROCEDURE FreeModules*;  PROCEDURE Close*;  Close Viewer and quit HeapInspector  PROCEDURE TermHandler ();  Quit HeapInspector by unloading module  PROCEDURE FinHandler (o: S.PTR);  Quit by deleting module (GC deletes moduledesc)  8 8&<Syntax10.Scn.FntSyntax10i.Scn.FntMarkElemsAlloc@ "ESyntax10b.Scn.Fnt^8FoldElemsNew#Syntax10.Scn.Fnt VAR zoom, len, len2, diff: LONGINT; BEGIN In.Open; IF In.Next () # In.int THEN zoomStart := 0; zoomEnd := X.GetHeapSize () DIV B ELSE In.LongInt (zoom); IF zoom > -80 THEN IF zoom > 200 THEN zoom := 200 END; len := zoomEnd - zoomStart; len2 := (len * (100 + zoom)) DIV 100; IF len2 < (v.picWidth DIV v.pointW) THEN len2 := v.picWidth DIV v.pointW - 1 END; diff := (len2 - len) DIV 2; DEC (zoomStart, diff); INC (zoomEnd, diff); IF zoomStart < 0 THEN zoomStart := 0 END; IF zoomEnd > (X.GetHeapSize () DIV B) THEN zoomEnd := X.GetHeapSize () DIV B END END END; v.redrawPic := TRUE; HeapUpdate END ZoomOut;  8 ?8#Syntax10.Scn.FntPP VAR name: ARRAY 60 OF CHAR; unknown, redraw: BOOLEAN; BEGIN In.Open (); unknown := FALSE; IF In.Next () = In.name THEN REPEAT In.Name (name); redraw := TRUE; IF name = "Map" THEN v.drwAll := ~v.drwAll ELSIF name = "Collectable" THEN v.drwNotMarked := ~v.drwNotMarked ELSIF name = "NotCollectable" THEN v.drwMarked := ~v.drwMarked ELSIF name = "Reachable" THEN v.drwReach := (~v.drwReach) OR v.reachedFrom; v.reachedFrom := FALSE; redraw := ~v.drwFreeze OR redraw ELSIF name = "ReachedFrom" THEN v.reachedFrom := ~v.reachedFrom; v.drwReach := v.reachedFrom; redraw := ~v.drwFreeze OR redraw ELSIF name = "ReachedFromModules" THEN v.reachedFMod := ~v.reachedFMod ELSIF name = "ReachedFromVariables" THEN v.reachedFVar := ~v.reachedFVar ELSIF name = "MarkedOnly" THEN v.onlyMarked := ~v.onlyMarked ELSIF name = "FreezeMap" THEN v.drwFreeze := ~v.drwFreeze ELSIF name = "ObjectSizes" THEN v.objSizes := ~v.objSizes ELSIF name = "ColorizedDefaultBlocks" THEN v.defBlockCol := ~v.defBlockCol ELSIF name = "DefaultBlocks" THEN v.defBlockShow := ~v.defBlockShow ELSIF name = "AddressesHexDec" THEN printHex := ~printHex ELSE unknown := TRUE END; v.redrawPic := v.redrawPic OR redraw UNTIL ((~In.Done) & (In.Next () # In.name)) OR unknown END; IF v.redrawPic THEN HeapUpdate () END END Show; 8 !~8Syntax10.Scn.FntYf8FoldElemsNewCSyntax10.Scn.FntSyntax10i.Scn.Fnt)aX VAR i, j: INTEGER; BEGIN i := 0; sel.kind := mode; IF mode = other THEN In.String (sel.pattern); In.LongInt (sel.pos); IF sel.pos < 0 THEN sel.pos := 0 END ELSE In.Name (sel.pattern); (* Read typedescriptor- and modulename *) WHILE (i < 32) & (sel.pattern [i] # '.') & (sel.pattern [i] # 0X) DO sel.mod [i] := sel.pattern [i]; INC (i) END; sel.mod [i] := 0X; j := 0; IF sel.pattern [i] = '.' THEN INC (i) END; WHILE (j < 32) & (sel.pattern [i] # 0X) DO sel.type [j] := sel.pattern [i]; INC (i); INC (j) END; sel.type [j] := 0X END END SelectRead;8'j8#Syntax10.Scn.Fnttt VAR i: INTEGER; ch: CHAR; BEGIN i := 0; sel.kind := mode; In.Char (ch); WHILE ((ch = ' ') OR (ch = TAB)) & In.Done DO In.Char (ch) END; WHILE IsNameChar (ch) & In.Done DO sel.pattern [i] := ch; In.Char (ch); INC (i); WHILE ((ch = ' ') OR (ch = TAB)) & In.Done DO In.Char (ch) END END; sel.pattern [i] := 0X; sel.traceResult := Changed END TraceRead;8N VAR name: ARRAY 60 OF CHAR; drwSelOld: BOOLEAN; PROCEDURE SelectRead (mode: INTEGER);  PROCEDURE TraceRead (mode: INTEGER);  BEGIN In.Open (); drwSelOld := v.drwSelect; v.drwSelect := TRUE; sel.kind := None; IF In.Next () = In.name THEN In.Name (name); IF name = "Object" THEN SelectRead (other) ELSIF name = "Typedescriptor" THEN SelectRead (typeDesc) ELSIF name = "Module" THEN SelectRead (module) ELSIF name = "Trace" THEN TraceRead (trace) ELSIF name = "OnlyAnchoredBy" THEN TraceRead (onlyAnchored) ELSIF name = "Off" THEN v.drwSelect := FALSE ELSIF name = "ShowCommands" THEN v.drwSelect := FALSE; OutStringLn ('Object "String" [Position] ~'); OutStringLn ("Typedescriptor [Modulename].[Typename] ~"); OutStringLn ("Module Modulename ~"); OutStringLn ("OnlyAnchoredBy Module.Varname{.Varname} ~"); OutStringLn ("Trace Module.Varname{.Varname} ~") END; v.redrawPic := ~drwSelOld OR ~v.drwSelect END; HeapUpdate END Select; &8 .Z68#Syntax10.Scn.Fnt VAR cmd: ARRAY 10 OF CHAR; BEGIN In.Open; IF In.Next () = In.int THEN In.LongInt (index); Out.String ("Setting index to "); Out.Int (index, 0); Out.Char ('.'); Out.Ln ELSIF In.Next () = In.name THEN In.Name (cmd); IF cmd = "Show" THEN Out.String ("Index = "); Out.Int (index, 0); Out.Char ('.'); Out.Ln ELSIF cmd = "Next" THEN INC (index); HeapUpdate ELSIF cmd = "Previous" THEN DEC (index); HeapUpdate ELSIF cmd = "Reset" THEN index := 0; HeapUpdate ELSIF cmd = "Using" THEN Out.String ("Use index for addressing an array with HeapInspector.Select:"); Out.Ln; Out.String ('Module.Type{.Type}"[HeapInspector.index]"{.Type}'); Out.Ln END END END Index; G8 !8#Syntax10.Scn.Fnt$$ VAR name: ARRAY 16 OF CHAR; BEGIN In.Open (); IF In.Next () = In.name THEN In.Name (name); IF name = "On" THEN NEW (v.pRemain, X.GetHeapSize () DIV B DIV 32 + 2); v.remaining := TRUE ELSIF name = "Off" THEN v.pRemain := NIL; v.remaining := FALSE END END; HeapUpdate END Remain; *8 tZ8CSyntax10.Scn.FntSyntax10i.Scn.Fnt0$ VAR name: ARRAY 34 OF CHAR; val: LONGINT; BEGIN In.Open (); val := ((zoomEnd - zoomStart) DIV 4 DIV (v.picWidth DIV v.pointW)) * (v.picWidth DIV v.pointW); IF val <= 0 THEN val := v.picWidth DIV v.pointW END; IF In.Next () = In.name THEN In.Name (name); IF (name = "Up") OR (name = "Down") OR (name = "Left") OR (name = "Right") THEN IF In.Next () = In.int THEN In.LongInt (val); IF (name [0] = 'U') OR (name [0] = 'D') THEN val := val * v.picWidth DIV v.pointW; IF name [0] = 'D' THEN val := -val END ELSIF name [0] = 'L' THEN val := - val END ELSIF (name [0] = 'U') OR (name [0] = 'D') THEN val := ((zoomEnd - zoomStart) DIV 4 DIV (v.picWidth DIV v.pointW)) * (v.picWidth DIV v.pointW); IF name [0] = 'D' THEN val := -val END ELSE val := v.picWidth DIV v.pointW DIV 10; IF name [0] = 'L' THEN val := -val END END; MoveMap (val, TRUE, TRUE); (* Move map relative into specified direction *) HeapUpdate END END END Move; 8 * `8#Syntax10.Scn.Fnt~~ CONST Name = Illegal - 1; VAR val: LONGINT; name: ARRAY 34 OF CHAR; BEGIN In.Open (); IF In.Next () = In.name THEN In.Name (name); val := Name ELSIF In.Next () = In.int THEN In.LongInt (val) ELSE val := Illegal END; IF val = Name THEN IF name = "Bottom" THEN val := 0 ELSIF name = "Top" THEN val := X.GetHeapSize () DIV B ELSIF name = "Center" THEN val := X.GetHeapSize () DIV (2 * B) ELSE val := Illegal END END; IF val # Illegal THEN IF (val < 0) OR (val > X.GetHeapSize ()) THEN val := X.AddressAbsToRel (val) DIV B ELSE val := val DIV B END; MoveMap (val, FALSE, TRUE); HeapUpdate END END SetMapTo; ,8 } 8#Syntax10.Scn.Fnt VAR val: LONGINT; BEGIN In.Open (); IF In.Next () = In.int THEN In.LongInt (val); IF (val < 0) OR (val > X.GetHeapSize ()) THEN val := X.AddressAbsToRel (val) DIV B - 1 ELSE val := val DIV B - 1 END; MoveMap (val, FALSE, FALSE); HeapUpdate END END StartMapAt; 38pVersionElemsAllocBeg#Syntax10.Scn.FntWindows PowerMacWindowsWindows PowerMac  NN8 Syntax10.Scn.Fntr8FoldElemsNew#Syntax10.Scn.Fntll BEGIN String (str); IF sw THEN String ("On") ELSE String ("Off") END; TDefault; Ln END PrintOnOff; 8W8#Syntax10.Scn.FntKK Tab; StringInt ("Height / width of a picture: ", v.picHeight); StringInt (" / ", v.picWidth); StringLn (" pixel(s)"); Tab; StringInt ("Max. height of a picture: ", v.picMaxHeight); StringLn (" pixel(s)"); Tab; StringInt ("Height / width of a single block: ", v.pointH); StringInt (" / ", v.pointW); StringLn (" pixel(s)"); Ln;Syntax10i.Scn.Fnt$88#Syntax10.Scn.Fnt// Tab; PrintOnOff ("Reached from Objects: ", v.reachedFrom); Tab; PrintOnOff ("Reached from Modules: ", v.reachedFMod); Tab; PrintOnOff ("Reached from Variables: ", v.reachedFVar); Tab; String ("Reach selection: "); IF v.drwFreeze THEN Ch ('F') ELSE String ("Not f") END; String ("reezed"); Ln; Ln;8>8#Syntax10.Scn.FntQQ CASE sel.kind OF typeDesc: String ("Typedescriptor(s): "); IF sel.mod = "" THEN Ch ('*') ELSE String (sel.mod) END; Ch ('.'); IF sel.type = "" THEN Ch ('*') ELSE String (sel.type) END; Ch ('.') | module: String ("Moduledescriptor: "); String (sel.mod); Ch ('.') | trace: String ('Trace-pattern: "'); String (sel.pattern); String ('".') | onlyAnchored: String ('Only anchored by "'); String (sel.pattern); String ('".') | other: String ('Object-pattern: "'); String (sel.pattern); StringInt ('" at position: ' , sel.pos); Ch ('.') ELSE String ("No selection.") END; Ln; Ln;818WSyntax10.Scn.Fnt8FoldElemsNew#Syntax10.Scn.Fnt Ln; Tab; Int (i + 1); String (". "); String (s.t [i].mod); IF s.t [i].type # "" THEN Ch ('.'); String (s.t [i].type) END; IF s.t [i].derived THEN String (" and derived") END; Ch ('.') Syntax10i.Scn.Fnt28R# IF v.onlyMarked THEN String (" Only marked objects shown.") ELSE String (" Marked and not marked objects shown.") END; FOR i := 0 TO s.nrOfTypeN - 1 DO  Print marked Object(s) (types, modules, derived)  END; IF s.nrOfTypeN = 0 THEN Ln; String (" No objects selected.") END; Ln; Ln;858#Syntax10.Scn.FntPP String (" is"); IF ~v.objSizes THEN String (" not") END; StringLn (" shown.");%8/8#Syntax10.Scn.Fnt String (" (typedescriptors, sysblocks, arrayblocks) are"); IF ~v.defBlockShow THEN String (" not") END; IF v.defBlockCol & v.defBlockShow THEN String (" colorized.") ELSE String (" shown.") END; Ln; Ln;*8b8#Syntax10.Scn.FntSS IF mods.e [i].unload THEN IF first THEN String ("On"); IF ~(v.drwMarked OR v.drwNotMarked) THEN String (", but not shown") END; TDefault; Ln; Tab; first := FALSE ELSIF (cnt MOD 5) = 4 THEN Ch (','); Ln; Tab ELSE String (", ") END; mod := S.VAL (X.Module, mods.e [i].mod); String (mod.name); INC (cnt) END (8M VAR txt: Texts.Text; i, cnt: LONGINT; first: BOOLEAN; mod: X.Module; PROCEDURE PrintOnOff (str: ARRAY OF CHAR; sw: BOOLEAN);  BEGIN OpenViewer ("Status", txt); TBold; String ("Showed pictures:"); TDefault; Ln;  Show picture data (Picture, block)  TBold; PrintOnOff ("Picture All: ", v.drwAll); Ln; TBold; PrintOnOff ("Picture Collectable: ", v.drwNotMarked); Ln; TBold; PrintOnOff ("Picture Not collectable: ", v.drwMarked); Ln; TBold; PrintOnOff ("Picture Reached: ", v.drwReach);  TBold; PrintOnOff ("Picture Selected: ", v.drwSelect); Tab;  TBold; String ("Marked Object(s):"); TDefault;  TBold; String ("Object-size-statistic"); TDefault;  Show statistic data of object-sizes  TBold; String ("Default objects"); TDefault;  Show selected default-object visualizing  TBold; String ("Testunload modules: "); first := TRUE; cnt := 0; FOR i := 0 TO mods.cnt - 1 DO  Show a list of all test-unloaded modules  END; IF first THEN String ("Off"); TDefault END; Append (txt) END Status; +8pVersionElemsAllocEndG8Syntax10.Scn.FntSyntax10i.Scn.Fnt MarkElemsAllocrکJ 8FoldElemsNew#Syntax10.Scn.Fnt VAR str: ARRAY 50 OF CHAR; fnt: Fonts.Font; xh, yh: INTEGER; BEGIN fnt := Fonts.This ("Syntax14.Scn.Fnt"); str := Authors; xh := x; yh := y; m.GetAlignPos (xh, yh, w, h, MW.AlignMiddle, MW.AlignBottom, str, fnt); m.WritePos (xh, yh + 80, black, str, fnt); str := Version; xh := x; yh := y; m.GetAlignPos (xh, yh, w, h, MW.AlignMiddle, MW.AlignBottom, str, fnt); m.WritePos (xh, yh + 50, black, str, fnt); str := Project; xh := x; yh := y; m.GetAlignPos (xh, yh, w, h, MW.AlignMiddle, MW.AlignBottom, str, fnt); m.WritePos (xh, yh + 20, black, str, fnt); str := Stars; xh := x; yh := y; m.GetAlignPos (xh, yh, w, h, MW.AlignMiddle, MW.AlignTop, str, fnt); m.WritePos (xh, yh, black, str, fnt) END DrawSplashFirst; 8 ѩI8#Syntax10.Scn.Fnt++ VAR str: ARRAY 50 OF CHAR; fnt: Fonts.Font; xh, yh, col: INTEGER; BEGIN fnt := Fonts.This ("Syntax14.Scn.Fnt"); str := Stars; xh := x; yh := y; m.GetAlignPos (xh, yh, w, h, MW.AlignMiddle, MW.AlignTop, str, fnt); m.WritePos (xh, yh, SHORT ((absNr DIV 64) MOD 16), str, fnt) END DrawSplashIdle; 8 8#Syntax10.Scn.Fnt<< VAR txt: Texts.Text; mw: MW.MsgWin; BEGIN NEW (mw); txt := NIL; IF ~mw.OpenMsg ("HeapInspector", txt, time) THEN Ln; String ("HeapInspector by Martin Rammerstorfer (MR)"); Append (Oberon.Log) ELSE mw.SetOwnPrint (splash.width, splash.height, DrawSplashFirst, DrawSplashIdle); mw.Show () END; END Splash; 8 (* Draw splash screen *) PROCEDURE DrawSplashFirst (m: MW.InfoWin; x, y, w, h: INTEGER; absNr, nr: LONGINT);  PROCEDURE DrawSplashIdle (m: MW.InfoWin; x, y, w, h: INTEGER; absNr, nr: LONGINT);  PROCEDURE Splash (time: LONGINT);  8 8#Syntax10.Scn.Fnt BEGIN Splash (-1) END Info; 8 ~G 8#Syntax10.Scn.Fnt VAR name: ARRAY 30 OF CHAR; BEGIN In.Open (); IF In.Next () = In.name THEN In.Name (name); IF name = "Double" THEN v.picMaxHeight := v.picMaxHeight * 2; IF v.picMaxHeight > (Display.Height - 50) THEN v.picMaxHeight := Display.Height - 50 END; v.redrawPic := TRUE; HeapUpdate ELSIF name = "Half" THEN v.picMaxHeight := v.picMaxHeight DIV 2; IF v.picMaxHeight < 16 THEN v.picMaxHeight := 16 END; v.redrawPic := TRUE; HeapUpdate END END END ResizeMap; 8 (* Commands for changing and showing the status of HeapInspector *) PROCEDURE ZoomOut*;  Set zooming  PROCEDURE Show*;  Show maps, objects, ...  PROCEDURE Select*;  Select objects by a specified string  PROCEDURE Index*;  For use with HeapInspector.Select (as index in tracing into an array)  PROCEDURE Remain*;  Select objects which remains on the heap  PROCEDURE Move*;  Move heapmap  PROCEDURE SetMapTo*;  Set center of heapmap to specified address  PROCEDURE StartMapAt*;  Set the start of the heapmap to specified address  PROCEDURE Status*;  Show the internal status of HeapInspector   Draw splash screen  PROCEDURE Info*;  PROCEDURE ResizeMap*;  Resize heapmap-elem-height  08 kK8Syntax10.Scn.Fnt8FoldElemsNew#Syntax10.Scn.Fnt VAR copy: Texts.CopyMsg; BEGIN TextFrames.defParc.handle(TextFrames.defParc, copy); t.parc2 := copy.e (TextFrames.Parc); t.parc2.nofTabs := 2; t.parc2.tab [0] := 1944000; t.parc2.tab [1] := 3204000 END SetParcs; 88Syntax10.Scn.Fnt 8FoldElemsNew#Syntax10.Scn.Fnt;;String ("Edit.Store"); t.cmdStore := CreatePopup ("Store");Syntax10i.Scn.Fnt8p8#Syntax10.Scn.Fntnn(* StringLn ("HeapInspector.Help Documentation ~"); StringLn ("HeapInspector.Help DocuOfCode ~"); StringLn ("HeapInspector.Help Mouse ~"); StringLn ("HeapInspector.Help Keyboard ~"); StringLn ("HeapInspector.Help Authors ~"); StringLn ("HeapInspector.Help Code ~"); StringLn ("HeapInspector.Help Menu ~"); StringLn ("HeapInspector.Help Menu Close ~"); StringLn ("HeapInspector.Help Menu HeapInspector~"); StringLn ("HeapInspector.Help Menu GC ~"); StringLn ("HeapInspector.Help Menu Info ~"); StringLn ("HeapInspector.Help Menu Map ~"); StringLn ("HeapInspector.Help Menu Show ~"); StringLn ("HeapInspector.Help Menu Modules ~"); StringLn (" HeapInspector.Help Menu Store ~"); StringLn ("HeapInspector.Help Menu Help ~"); StringLn ("HeapInspector.Help Menu Commands (EBNF) ~"); String ("HeapInspector.Help Examples ~"); t.cmdDocu := CreatePopup ("Help");*)88#Syntax10.Scn.Fnt==String ("System.Close"); t.cmdSClose := CreatePopup ("Close") 8U BEGIN  Store   Help (Documentation)   Info - Menu  END SetMenuPopups; 81 PROCEDURE SetParcs ();  PROCEDURE SetMenuPopups ();  BEGIN X.InstallTermHandler (TermHandler, FinHandler, Modules.ThisMod ("HeapInspector")); Texts.OpenWriter (t.w); SetParcs (); SetMenuPopups (); mods.Init (); zoomStart := 0; zoomEnd := X.GetHeapSize () DIV B; unloadModDesc := FALSE; reachName [0] := 0X; reachType [0] := 0X; reachModule [0] := 0X; s.Reset (TRUE); v.Reset (); types.Reset (); sel.Reset (); v.mapMaxHeight := Display.Height - MapMaxHeightDiff; splash.width := 380; splash.height := 130; Splash (3000); index := 0 END Init; A8MODULE HeapInspector; (* HeapInspector by MR, 28 Jun 96 -   *) (*<== Click here to change version of HeapInspector (now: Windows)*)        IMPORT  CONST  TYPE  VAR   Forward declarations   Procedures for reset and set of data   Procedures for storing specified blocks on a set-array   Procedures for text operations   Procedures for module / type descriptor operations   Procedures for event-handling (selection)   Commands for setting the modes for Garbage-Collector   For miscellaneous use: MoveMap, DrawBlock, SetPtrReach, ReadMarkNames   Procedures for visualizing the objects on the heap on different criteria   Commands for update and marking objects   Commands for changing and showing the status of HeapInspector  PROCEDURE Init;  initializes menuitems, parcs, termination handler and variables  BEGIN Init END HeapInspector. (* Trace HeapInspector.types.elems[HeapInspector.index].type ~ Trace Directories.DirTab[HeapInspector.index]~ *)