DIRECTORY
Buttons USING [Button, ButtonProc, Create, SetDisplayStyle],
MDebugDefs USING [Cmd, CmdIndex, DataRec, DoCommand, Handle, NumberCell],
Commander USING [CommandProc, Handle, Register],
Containers USING [ChildXBound, Create],
Convert USING [CardFromWholeNumberLiteral, Error, RopeFromInt],
IO USING [NUL, SP],
Labels USING [Create],
Menus USING [MouseButton],
MessageWindow USING [Append],
PrincOps USING [],
RESOut USING [cancelAction, Complain],
Rope USING [Concat, Fetch, Length, ROPE],
Rules USING [Create, Rule],
SafeStorage USING [NarrowFault],
STDebugDefs USING [STDebugMisc, STDebugSymbols, STDebugTrees],
VFonts USING [CharWidth],
ViewerClasses USING [Viewer],
ViewerEvents USING [EventProc, RegisterEventProc],
ViewerIO USING [CreateViewerStreams, GetViewerFromStream],
ViewerOps USING [AddProp, DestroyViewer, FetchProp, PaintViewer, SetOpenHeight],
ViewerTools USING [GetContents, GetSelectionContents, MakeNewTextViewer, SetContents, SetSelection];
MDebugInterface:
CEDAR PROGRAM
IMPORTS
Buttons, Commander, Containers, Convert, MDebugDefs, Labels, MessageWindow, RESOut, Rope, Rules, SafeStorage, STDebugDefs, VFonts, ViewerEvents, ViewerIO, ViewerOps, ViewerTools
EXPORTS MDebugDefs =
BEGIN
OPEN MDebugDefs;
entryHeight: CARDINAL = 15; -- how tall to make each line of items
entryVSpace: CARDINAL = 2; -- vertical leading space between lines
entryHSpace: CARDINAL = 5; -- min horizontal space between items in a line
ROPE: TYPE = Rope.ROPE;
PromptRec: TYPE = RECORD [handle: MDebugDefs.Handle, cell: ViewerClasses.Viewer, radix: INT ← 8];
PromptHandle: TYPE = REF PromptRec;
CmdRec: TYPE = RECORD [handle: MDebugDefs.Handle, cmd: MDebugDefs.CmdIndex];
CmdHandle: TYPE = REF CmdRec;
EnumItem: TYPE = RECORD [tag: ROPE, value: UNSPECIFIED];
ERef: TYPE = REF UNSPECIFIED; -- can't figure out how to make generic safely
EnumItemSeqRec: TYPE = RECORD [SEQUENCE count: CARDINAL OF EnumItem];
EnumItemSeq: TYPE = REF EnumItemSeqRec;
EnumRec: TYPE = RECORD [handle: MDebugDefs.Handle, choice: ViewerClasses.Viewer, choices: EnumItemSeq, showing: CARDINAL, eCell: ERef];
EnumHandle: TYPE = REF EnumRec;
MakeTool: Commander.CommandProc =
BEGIN
rule: Rules.Rule;
my: Handle ← NEW[DataRec];
my.en ← VFonts.CharWidth['0]; -- width of 'n was too wide
my.outer ← Containers.Create[[
-- construct the outer container
name: "MDebug commands", -- name displayed in the caption
iconic: FALSE, -- so tool will be open when first created
column: left, -- initially in the left column
guardDestroy: TRUE,
scrollable: FALSE ]]; -- inhibit user from scrolling contents
my.msg ← Labels.Create[ [
name: NIL,
wx: 0, wy: my.height,
wh: 2*entryHeight,
parent: my.outer,
border: FALSE]];
my.height ← my.height + 2*entryHeight + 2; -- interline spacing
Containers.ChildXBound[my.outer, my.msg];
rule ← Rules.Create [[parent: my.outer, wy: my.height, ww: my.outer.cw, wh: 2]];
Containers.ChildXBound[my.outer, rule];
MakeCommands[my];
rule ← Rules.Create [[parent: my.outer, wy: my.height, ww: my.outer.cw, wh: 2]];
Containers.ChildXBound[my.outer, rule];
my.height ← my.height + 2; -- interline spacing
my.charsOnLine ← 0;
ViewerOps.AddProp[my.outer, $cdebugHandle, my];
ViewerOps.SetOpenHeight[viewer: my.outer, clientHeight: my.height];
ViewerOps.PaintViewer[viewer: my.outer, hint: all];
[] ← ViewerEvents.RegisterEventProc[proc: DestroyTool, event: destroy, filter: my.outer];
MakeTypescript[my];
END;
DestroyTool: ViewerEvents.EventProc = {
[viewer: ViewerClasses.Viewer, event: ViewerEvents.ViewerEvent, before: BOOL] RETURNS [abort: BOOL ← FALSE]
IF before
THEN {
h: Handle ← NARROW[ViewerOps.FetchProp[viewer, $cdebugHandle]];
IF h = NIL OR h.outer # viewer THEN RETURN;
h.dying ← TRUE;
ViewerOps.DestroyViewer[h.ts]};
};
-- locations of the various fields
Place: TYPE = RECORD [x, y: CARDINAL];
TreeCol: CARDINAL = 0;
RepCol: CARDINAL = TreeCol + 7;
MTCol: CARDINAL = RepCol + 6;
BodyCol: CARDINAL = MTCol + 9;
LblCol: CARDINAL = BodyCol + 7;
treePlace: Place = [x: TreeCol+0, y: 0];
depthPlace: Place = [x: TreeCol+0, y: 1];
linksPlace: Place = [x: TreeCol+0, y: 2];
stopPlace: Place = [x: TreeCol+0, y: 3];
repPlace: Place = [x: RepCol+0, y: 0];
mdiPlace: Place = [x: MTCol+0, y: 0];
htiPlace: Place = [x: MTCol+4, y: 0];
ctiPlace: Place = [x: MTCol+0, y: 1];
btiPlace: Place = [x: MTCol+4, y: 1];
seiPlace: Place = [x: MTCol+0, y: 2];
nextsePlace: Place = [x: MTCol+4, y: 2];
sourcePlace: Place = [x: MTCol+0, y: 3];
bodyPlace: Place = [x: BodyCol+0, y: 0];
stmtPlace: Place = [x: BodyCol+0, y: 1];
exprPlace: Place = [x: BodyCol+0, y: 2];
gFramesPlace: Place = [x: BodyCol+0, y: 3];
lblPlace: Place = [x: LblCol+0, y: 0];
liiPlace: Place = [x: LblCol+0, y: 1];
MakeCommands:
PROC [handle: Handle] =
BEGIN
cmdy: INT = handle.height + entryVSpace;
maxY: INT ← 0;
MakeCmd:
PROC [at: Place, name:
ROPE, cmd: MDebugDefs.CmdIndex] = {
b: Cmd ← Buttons.Create[
info: [
name: Rope.Concat[name, "!"],
wx: at.x*handle.en,
wy: cmdy + at.y * (entryHeight + entryVSpace),
-- default the width so that it will be computed for us
wh: entryHeight, -- specify rather than defaulting so line is uniform
parent: handle.outer,
border: FALSE],
proc: OtherCmd,
clientData: NEW [CmdRec ← [handle: handle, cmd: cmd]]];
maxY ← MAX[maxY, at.y];
MakeBool:
PROC [at: Place, name:
ROPE, initial:
BOOL]
RETURNS [flag:
REF
BOOL] = {
b: Cmd;
flag ← NEW[BOOL ← initial];
b ← Buttons.Create[
info: [
name: name,
wx: at.x*handle.en,
wy: cmdy + at.y * (entryHeight + entryVSpace),
-- default the width so that it will be computed for us
wh: entryHeight, -- specify rather than defaulting so line is uniform
parent: handle.outer,
border: FALSE],
proc: ToggleBool,
clientData: flag];
Buttons.SetDisplayStyle[
button: b,
style: IF initial THEN $WhiteOnBlack ELSE $BlackOnWhite];
maxY ← MAX[maxY, at.y];
NamedCell:
PROC [at: Place, name:
ROPE, width:
CARDINAL, initial:
ROPE ←
NIL, radix:
INT ← 8]
RETURNS [v: ViewerClasses.Viewer] = {
ph: PromptHandle ← NEW[PromptRec ← [handle: handle, radix: radix, cell: NIL]];
cmdx: INT ← at.x*handle.en;
b: Buttons.Button ← Buttons.Create[
info: [
name: Rope.Concat[name, ": "],
wx: cmdx,
wy: cmdy + at.y * (entryHeight + entryVSpace),
wh: entryHeight,
parent: handle.outer,
border: FALSE],
proc: SimplePrompt,
clientData: ph];
cmdx ← cmdx + b.ww;
v ← ViewerTools.MakeNewTextViewer[
info: [
wx: cmdx,
wy: cmdy + at.y * (entryHeight + entryVSpace) + 1,
ww: width*handle.en + 8,
wh: entryHeight,
parent: handle.outer,
data: initial,
scrollable: FALSE,
border: FALSE]];
ph.cell ← v;
maxY ← MAX[maxY, at.y];
MakeCmd[at: treePlace, name: "Tree", cmd: tree];
handle.showLinks ← MakeBool[at: linksPlace, name: "lnks", initial: FALSE];
handle.cmd.dVal ← NamedCell[at: depthPlace, name: "d", width: 3, initial: "2", radix: 10];
MakeCmd[at: stopPlace, name: "STOP", cmd: stop];
MakeCmd[at: lblPlace, name: "lbl", cmd: lbl];
MakeCmd[at: liiPlace, name: "lii", cmd: lii];
MakeCmd[at: mdiPlace, name: "mt", cmd: mdi];
MakeCmd[at: htiPlace, name: "ht", cmd: hti];
MakeCmd[at: ctiPlace, name: "ct", cmd: cti];
MakeCmd[at: btiPlace, name: "bt", cmd: bti];
MakeCmd[at: seiPlace, name: "se", cmd: sei];
MakeCmd[at: nextsePlace, name: "nx", cmd: nextse];
MakeCmd[at: repPlace, name: "rep", cmd: rep];
MakeCmd[at: bodyPlace, name: "Body", cmd: body];
MakeCmd[at: stmtPlace, name: "Stmt", cmd: stmt];
MakeCmd[at: exprPlace, name: "Expr", cmd: expr];
MakeCmd[at: gFramesPlace, name: "UnCacheFrames", cmd: gFrames];
MakeCmd[at: sourcePlace, name: "Source", cmd: source];
handle.height ← cmdy + (maxY+1) * (entryHeight + entryVSpace)
END;
CellInt:
PUBLIC PROC [handle: Handle, n: NumberCell]
RETURNS [
INT] = {
contents: Rope.ROPE ← ViewerTools.GetContents[n];
RETURN [GetNumber[handle, contents]]};
CellCard:
PUBLIC PROC [handle: Handle, n: NumberCell]
RETURNS [
CARDINAL] = {
contents: Rope.ROPE ← ViewerTools.GetContents[n];
i: INT ← GetNumber[handle, contents];
IF ~ (i
IN [0..
CARDINAL.
LAST])
THEN
RESOut.Complain[h: handle, msg: "number out of range"];
RETURN [CARDINAL[i]]};
GetNumber:
PUBLIC PROC [handle: Handle, contents: Rope.
ROPE]
RETURNS [v:
INT ← 0] = {
ENABLE SafeStorage.NarrowFault => GO TO bad;
neg: BOOL ← FALSE;
first: CARDINAL ← 0;
IF Rope.Length[contents] = 0 THEN RETURN;
FOR i:
CARDINAL
IN [0..
CARDINAL[Rope.Length[contents]])
DO
c: CHAR = Rope.Fetch[contents, i];
SELECT c
FROM
IN [IO.NUL..IO.SP] => NULL;
'- => {neg ← TRUE; first ← i+1; EXIT};
ENDCASE => {first ← i; EXIT};
ENDLOOP;
v ← Convert.CardFromWholeNumberLiteral[contents, first !
Convert.Error => {
SELECT reason
FROM
$empty => RESOut.Complain[h: handle, msg: "number is blank."];
$syntax => RESOut.Complain[h: handle, msg: "number syntax error."];
$overflow => RESOut.Complain[h: handle, msg: "number overflowed."];
ENDCASE; -- above cases won't return (they raise cancelAction)
GO TO bad}];
IF neg THEN v ← -v;
};
MakeTypescript:
PROC [handle: Handle] =
BEGIN
v: ViewerClasses.Viewer;
[handle.in, handle.out] ← ViewerIO.CreateViewerStreams [
name: "MDebug typescript", viewer: NIL, backingFile: NIL, editedStream: FALSE];
handle.ts ← ViewerIO.GetViewerFromStream[handle.out];
ViewerOps.AddProp[handle.ts, $cdebugHandle, handle];
handle.dying ← FALSE;
[] ← ViewerEvents.RegisterEventProc[proc: DestroyTypescript, event: destroy, filter: v];
END;
DestroyTypescript: ViewerEvents.EventProc = {
[viewer: ViewerClasses.Viewer, event: ViewerEvents.ViewerEvent, before: BOOL] RETURNS [abort: BOOL ← FALSE]
h: Handle ← NARROW[ViewerOps.FetchProp[viewer, $cdebugHandle]];
IF before
AND h #
NIL
AND h.ts = viewer
AND ~h.dying
THEN {
MessageWindow.Append[message: "destroy command window instead", clearFirst: TRUE];
RETURN[TRUE]};
};
SetCell:
PRIVATE
PROC [handle: Handle, button: Menus.MouseButton, cell: ViewerClasses.Viewer, radix:
CARDINAL] = {
ENABLE RESOut.cancelAction => GO TO dont;
SELECT button
FROM
blue => ViewerTools.SetSelection[cell];
red, yellow => {
r: ROPE = ViewerTools.GetSelectionContents[];
i: INT = GetNumber[handle, r];
IF button = yellow THEN radix ← 8;
ViewerTools.SetContents[cell, Convert.RopeFromInt[from: i, base: radix, showRadix: TRUE]]};
ENDCASE;
};
SetTextCell:
PRIVATE
PROC [handle: Handle, button: Menus.MouseButton, cell: ViewerClasses.Viewer] = {
ENABLE RESOut.cancelAction => GO TO dont;
SELECT button
FROM
blue => ViewerTools.SetSelection[cell];
red => {
r: ROPE = ViewerTools.GetSelectionContents[];
ViewerTools.SetContents[cell, r]};
ENDCASE;
};
SimplePrompt: Buttons.ButtonProc
= {
ph: PromptHandle ← NARROW[clientData];
IF ph.radix = 0 THEN SetTextCell[ph.handle, mouseButton, ph.cell]
ELSE SetCell[ph.handle, mouseButton, ph.cell, ph.radix];
};
GetSelectionValue:
PUBLIC PROC [handle: Handle]
RETURNS [
UNSPECIFIED] = {
r: ROPE = ViewerTools.GetSelectionContents[];
i: INT = GetNumber[handle, r];
IF ~(i
IN [0..
CARDINAL.
LAST])
THEN
RESOut.Complain[h: handle, msg: "Selected number too large"];
RETURN [CARDINAL[i]]};
GetLongSelectionValue:
PUBLIC PROC [handle: Handle]
RETURNS [
INT] = {
r: ROPE = ViewerTools.GetSelectionContents[];
RETURN [GetNumber[handle, r]]};
OtherCmd: Buttons.ButtonProc
-- [parent: REF ANY, clientData: REF ANY ← NIL, mouseButton: Menus.MouseButton ← red, shift: BOOL ← FALSE, control: BOOL ← FALSE] -- = {
ENABLE RESOut.cancelAction, ABORTED => GO TO dont;
ch: CmdHandle = NARROW[clientData];
IF ch.cmd = stop THEN ch.handle.stopFlag ← TRUE
ELSE
TRUSTED {
ch.handle.stopFlag ← FALSE;
MDebugDefs.DoCommand[ch.handle, ch.cmd, mouseButton]};
};
ToggleBool: Buttons.ButtonProc
= {
switch: REF BOOL ← NARROW [clientData];
switch^ ← ~switch^;
Buttons.SetDisplayStyle[
button: NARROW[parent],
style: IF switch^ THEN $WhiteOnBlack ELSE $BlackOnWhite];
};
TRUSTED {
START STDebugDefs.STDebugMisc;
START STDebugDefs.STDebugTrees;
START STDebugDefs.STDebugSymbols};
Commander.Register[key: "MDebug", proc: MakeTool, doc: "Debugger for mimosa compiler internals"];
END.