From: Alexander Shiryaev Date: Fri, 16 Nov 2012 19:54:32 +0000 (+0400) Subject: build-gui modified X-Git-Url: https://deadsoftware.ru/gitweb?a=commitdiff_plain;h=8ff734c4231a517015d929499bdb52bf12ac31ab;p=bbcp.git build-gui modified --- diff --git a/new/Std/Mod/Api.txt b/new/Std/Mod/Api.txt deleted file mode 100644 index d89cc42..0000000 --- a/new/Std/Mod/Api.txt +++ /dev/null @@ -1,229 +0,0 @@ -MODULE StdApi; - - (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/Api.odc *) - (* DO NOT EDIT *) - - IMPORT - Kernel, Views, Files, Dialog, Converters, Windows, Sequencers, Stores, Meta, - Containers, StdDialog, Documents; - - (* Auxiliary procedures *) - - PROCEDURE CheckQualident (VAR str, mod, name: ARRAY OF CHAR); - VAR i, j: INTEGER; ch: CHAR; - BEGIN - i := 0; - REPEAT - ch := str[i]; mod[i] := ch; INC(i) - UNTIL (i = LEN(str)) OR (i = LEN(mod)) OR (ch < "0") OR (ch > "9") & (CAP(ch) < "A") OR (CAP(ch) > "Z"); - IF ch = "." THEN - mod[i - 1] := 0X; j := 0; - REPEAT - ch := str[i]; name[j] := ch; INC(i); INC(j) - UNTIL (i = LEN(str)) OR (j = LEN(name)) OR (ch < "0") OR (ch > "9") & (CAP(ch) < "A") OR (CAP(ch) > "Z"); - IF ch # 0X THEN mod[0] := 0X; name[0] := 0X END - ELSE mod[0] := 0X; name[0] := 0X - END - END CheckQualident; - - PROCEDURE PathToSpec (VAR path: ARRAY OF CHAR; VAR loc: Files.Locator; VAR name: Files.Name); - VAR i, j: INTEGER; ch: CHAR; - BEGIN - i := 0; j := 0; loc := Files.dir.This(""); - WHILE (loc.res = 0) & (i < LEN(path) - 1) & (j < LEN(name) - 1) & (path[i] # 0X) DO - ch := path[i]; INC(i); - IF (j > 0) & ((ch = "/") OR (ch = "\")) THEN - name[j] := 0X; j := 0; - IF name = "*" THEN - IF Dialog.language # "" THEN loc := loc.This(Dialog.language) END - ELSE loc := loc.This(name) - END - ELSE - name[j] := ch; INC(j) - END - END; - IF path[i] = 0X THEN name[j] := 0X - ELSE loc.res := 1; name := "" - END - END PathToSpec; - - PROCEDURE ThisDialog (dialog: ARRAY OF CHAR): Views.View; - VAR fname, submod, sub, mod: Files.Name; canCreate: BOOLEAN; conv: Converters.Converter; - loc: Files.Locator; file: Files.File; v: Views.View; s: Stores.Store; var: Meta.Item; - BEGIN - ASSERT(dialog # "", 20); - v := NIL; file := NIL; canCreate := FALSE; - CheckQualident(dialog, submod, fname); - IF submod # "" THEN (* is qualident *) - Meta.LookupPath(dialog, var); - IF var.obj = Meta.varObj THEN (* variable exists *) - canCreate := TRUE; - Kernel.SplitName(submod, sub, mod); - loc := Files.dir.This(sub); - IF loc # NIL THEN - Kernel.MakeFileName(fname, ""); - loc := loc.This("Rsrc"); - IF loc # NIL THEN file := Files.dir.Old(loc, fname, Files.shared) END; - IF (file = NIL) & (sub = "") THEN - loc := Files.dir.This("System"); ASSERT(loc # NIL, 100); - IF loc # NIL THEN - loc := loc.This("Rsrc"); - IF loc # NIL THEN file := Files.dir.Old(loc, fname, Files.shared) END - END - END - END - END - END; - IF (file = NIL) & ~canCreate THEN (* try file name *) - PathToSpec(dialog, loc, fname); - IF loc.res = 0 THEN - Kernel.MakeFileName(fname, ""); - file := Files.dir.Old(loc, fname, Files.shared) - END - END; - IF file # NIL THEN - Kernel.MakeFileName(fname, ""); - conv := NIL; Converters.Import(loc, fname, conv, s); - IF s # NIL THEN - v := s(Views.View) - END - ELSE Dialog.ShowParamMsg("#System:FileNotFound", dialog, "", "") - END; - RETURN v - END ThisDialog; - - PROCEDURE ThisMask (param: ARRAY OF CHAR): Views.View; - VAR v: Views.View; c: Containers.Controller; - BEGIN - v := ThisDialog(param); - IF v # NIL THEN - WITH v: Containers.View DO - c := v.ThisController(); - IF c # NIL THEN - c.SetOpts(c.opts - {Containers.noFocus} + {Containers.noCaret, Containers.noSelection}) - ELSE Dialog.ShowMsg("#System:NotEditable") - END - ELSE Dialog.ShowMsg("#System:ContainerExpected") - END - END; - RETURN v - END ThisMask; - - (* Interface procedures *) - - PROCEDURE CloseDialog* (OUT closedView: Views.View); - CONST canClose = {Windows.neverDirty, Windows.isTool, Windows.isAux}; - VAR w: Windows.Window; msg: Sequencers.CloseMsg; - BEGIN - closedView := NIL; - w := Windows.dir.First(); - IF w # NIL THEN - IF w.sub THEN - closedView := w.frame.view; - Windows.dir.Close(w); - ELSIF (w.flags * canClose = {}) & w.seq.Dirty() THEN - Dialog.ShowMsg("#System:CannotCloseDirtyWindow") - ELSE - msg.sticky := FALSE; w.seq.Notify(msg); - IF ~msg.sticky THEN closedView := w.frame.view; Windows.dir.Close(w) END - END - END - END CloseDialog; - - PROCEDURE OpenAux* (file, title: ARRAY OF CHAR; OUT v: Views.View); - VAR loc: Files.Locator; name: Files.Name; t: Views.Title; - BEGIN - PathToSpec(file, loc, name); - IF loc.res = 0 THEN - loc.res := 77; v := Views.OldView(loc, name); loc.res := 0; - IF v # NIL THEN t := title$; Views.OpenAux(v, t) - ELSE Dialog.ShowParamMsg("#System:FileNotFound", file, "", "") - END - ELSE Dialog.ShowParamMsg("#System:FileNotFound", file, "", "") - END - END OpenAux; - - PROCEDURE OpenAuxDialog* (file, title: ARRAY OF CHAR; OUT v: Views.View); - VAR t0: Views.Title; done: BOOLEAN; - BEGIN - Dialog.MapString(title, t0); - Windows.SelectByTitle(NIL, {Windows.isAux}, t0, done); - IF ~done THEN - v := ThisMask(file); - IF v # NIL THEN - StdDialog.Open(v, title, NIL, "", NIL, FALSE, TRUE, TRUE, FALSE, TRUE) - END - END - END OpenAuxDialog; - - PROCEDURE OpenBrowser* (file, title: ARRAY OF CHAR; OUT v: Views.View); - VAR loc: Files.Locator; name: Files.Name; t: Views.Title; - c: Containers.Controller; - BEGIN - PathToSpec(file, loc, name); - IF loc.res = 0 THEN - loc.res := 77; v := Views.OldView(loc, name); loc.res := 0; - IF v # NIL THEN - WITH v: Containers.View DO - c := v.ThisController(); - IF c # NIL THEN - c.SetOpts(c.opts - {Containers.noFocus, Containers.noSelection} + {Containers.noCaret}) - END - ELSE - END; - t := title$; - StdDialog.Open(v, t, NIL, "", NIL, FALSE, TRUE, FALSE, TRUE, FALSE) - ELSE Dialog.ShowParamMsg("#System:FileNotFound", file, "", "") - END - ELSE Dialog.ShowParamMsg("#System:FileNotFound", file, "", "") - END - END OpenBrowser; - - PROCEDURE OpenDoc* (file: ARRAY OF CHAR; OUT v: Views.View); - VAR loc: Files.Locator; name: Files.Name; conv: Converters.Converter; - BEGIN - PathToSpec(file, loc, name); - IF loc.res = 0 THEN - conv := NIL; v := Views.Old(Views.dontAsk, loc, name, conv); - IF loc.res = 78 THEN loc := NIL; name := "" END; (* stationery *) - IF v # NIL THEN Views.Open(v, loc, name, conv) - ELSE Dialog.ShowParamMsg("#System:FileNotFound", file, "", "") - END - ELSE Dialog.ShowParamMsg("#System:FileNotFound", file, "", "") - END - END OpenDoc; - - PROCEDURE OpenCopyOf* (file: ARRAY OF CHAR; OUT v: Views.View); - VAR loc: Files.Locator; name: Files.Name; conv: Converters.Converter; - BEGIN - PathToSpec(file, loc, name); - IF loc.res = 0 THEN - conv := NIL; v := Views.Old(Views.dontAsk, loc, name, conv); - IF loc.res = 78 THEN loc := NIL; name := "" END; (* stationary *) - IF v # NIL THEN - IF v.context # NIL THEN - v := Views.CopyOf(v.context(Documents.Context).ThisDoc(), Views.deep); - Stores.InitDomain(v) - ELSE v := Views.CopyOf(v, Views.deep) - END; - Views.Open(v, NIL, "", conv) - ELSE Dialog.ShowParamMsg("#System:FileNotFound", file, "", "") - END - ELSE Dialog.ShowParamMsg("#System:FileNotFound", file, "", "") - END - END OpenCopyOf; - - PROCEDURE OpenToolDialog* (file, title: ARRAY OF CHAR; OUT v: Views.View); - VAR t0: Views.Title; done: BOOLEAN; - BEGIN - Dialog.MapString(title, t0); - Windows.SelectByTitle(NIL, {Windows.isTool}, t0, done); - IF ~done THEN - v := ThisMask(file); - IF v # NIL THEN - StdDialog.Open(v, title, NIL, "", NIL, TRUE, FALSE, TRUE, FALSE, TRUE) - END - END - END OpenToolDialog; - -END StdApi. diff --git a/new/Std/Mod/CFrames.txt b/new/Std/Mod/CFrames.txt deleted file mode 100644 index 7a157db..0000000 --- a/new/Std/Mod/CFrames.txt +++ /dev/null @@ -1,243 +0,0 @@ -MODULE StdCFrames; - - (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/CFrames.odc *) - (* DO NOT EDIT *) - - IMPORT Fonts, Ports, Views, Dates, Dialog; - - CONST lineUp* = 0; lineDown* = 1; pageUp* = 2; pageDown* = 3; - - TYPE - Frame* = POINTER TO ABSTRACT RECORD (Views.Frame) - disabled*, undef*, readOnly*, noRedraw*: BOOLEAN; - font*: Fonts.Font - END; - - PushButton* = POINTER TO ABSTRACT RECORD (Frame) - label*: ARRAY 256 OF CHAR; - default*, cancel*: BOOLEAN; - Do*: PROCEDURE (f: PushButton) - END; - - CheckBox* = POINTER TO ABSTRACT RECORD (Frame) - label*: ARRAY 256 OF CHAR; - Get*: PROCEDURE (f: CheckBox; OUT on: BOOLEAN); - Set*: PROCEDURE (f: CheckBox; on: BOOLEAN) - END; - - RadioButton* = POINTER TO ABSTRACT RECORD (Frame) - label*: ARRAY 256 OF CHAR; - Get*: PROCEDURE (f: RadioButton; OUT on: BOOLEAN); - Set*: PROCEDURE (f: RadioButton; on: BOOLEAN) - END; - - ScrollBar* = POINTER TO ABSTRACT RECORD (Frame) - Track*: PROCEDURE (f: ScrollBar; dir: INTEGER; VAR pos: INTEGER); - Get*: PROCEDURE (f: ScrollBar; OUT size, sect, pos: INTEGER); - Set*: PROCEDURE (f: ScrollBar; pos: INTEGER) - END; - - Field* = POINTER TO ABSTRACT RECORD (Frame) - maxLen*: INTEGER; (* max num of characters in field (w/o 0X) *) - left*, right*, multiLine*, password*: BOOLEAN; - Get*: PROCEDURE (f: Field; OUT string: ARRAY OF CHAR); - Set*: PROCEDURE (f: Field; IN string: ARRAY OF CHAR); - Equal*: PROCEDURE (f: Field; IN s1, s2: ARRAY OF CHAR): BOOLEAN - END; - - UpDownField* = POINTER TO ABSTRACT RECORD (Frame) - min*, max*, inc*: INTEGER; - Get*: PROCEDURE (f: UpDownField; OUT val: INTEGER); - Set*: PROCEDURE (f: UpDownField; val: INTEGER) - END; - - DateField* = POINTER TO ABSTRACT RECORD (Frame) - Get*: PROCEDURE (f: DateField; OUT date: Dates.Date); - Set*: PROCEDURE (f: DateField; IN date: Dates.Date); - GetSel*: PROCEDURE (f: DateField; OUT sel: INTEGER); - SetSel*: PROCEDURE (f: DateField; sel: INTEGER) - END; - - TimeField* = POINTER TO ABSTRACT RECORD (Frame) - Get*: PROCEDURE (f: TimeField; OUT date: Dates.Time); - Set*: PROCEDURE (f: TimeField; IN date: Dates.Time); - GetSel*: PROCEDURE (f: TimeField; OUT sel: INTEGER); - SetSel*: PROCEDURE (f: TimeField; sel: INTEGER) - END; - - ColorField* = POINTER TO ABSTRACT RECORD (Frame) - Get*: PROCEDURE (f: ColorField; OUT col: INTEGER); - Set*: PROCEDURE (f: ColorField; col: INTEGER) - END; - - ListBox* = POINTER TO ABSTRACT RECORD (Frame) - sorted*: BOOLEAN; - Get*: PROCEDURE (f: ListBox; OUT i: INTEGER); - Set*: PROCEDURE (f: ListBox; i: INTEGER); - GetName*: PROCEDURE (f: ListBox; i: INTEGER; VAR name: ARRAY OF CHAR) - END; - - SelectionBox* = POINTER TO ABSTRACT RECORD (Frame) - sorted*: BOOLEAN; - Get*: PROCEDURE (f: SelectionBox; i: INTEGER; OUT in: BOOLEAN); - Incl*: PROCEDURE (f: SelectionBox; from, to: INTEGER); - Excl*: PROCEDURE (f: SelectionBox; from, to: INTEGER); - Set*: PROCEDURE (f: SelectionBox; from, to: INTEGER); - GetName*: PROCEDURE (f: SelectionBox; i: INTEGER; VAR name: ARRAY OF CHAR) - END; - - ComboBox* = POINTER TO ABSTRACT RECORD (Frame) - sorted*: BOOLEAN; - Get*: PROCEDURE (f: ComboBox; OUT string: ARRAY OF CHAR); - Set*: PROCEDURE (f: ComboBox; IN string: ARRAY OF CHAR); - GetName*: PROCEDURE (f: ComboBox; i: INTEGER; VAR name: ARRAY OF CHAR) - END; - - Caption* = POINTER TO ABSTRACT RECORD (Frame) - label*: ARRAY 256 OF CHAR; - left*, right*: BOOLEAN; - END; - - Group* = POINTER TO ABSTRACT RECORD (Frame) - label*: ARRAY 256 OF CHAR - END; - - TreeFrame* = POINTER TO ABSTRACT RECORD (Frame) - sorted*, haslines*, hasbuttons*, atroot*, foldericons*: BOOLEAN; - NofNodes*: PROCEDURE (f: TreeFrame): INTEGER; - Child*: PROCEDURE (f: TreeFrame; node: Dialog.TreeNode): Dialog.TreeNode; - Parent*: PROCEDURE (f: TreeFrame; node: Dialog.TreeNode): Dialog.TreeNode; - Next*: PROCEDURE (f: TreeFrame; node: Dialog.TreeNode): Dialog.TreeNode; - Select*: PROCEDURE (f: TreeFrame; node: Dialog.TreeNode); - Selected*: PROCEDURE (f: TreeFrame): Dialog.TreeNode; - SetExpansion*: PROCEDURE (f: TreeFrame; tn: Dialog.TreeNode; expanded: BOOLEAN) - END; - - Directory* = POINTER TO ABSTRACT RECORD END; - - - VAR - setFocus*: BOOLEAN; - defaultFont*, defaultLightFont*: Fonts.Font; - dir-, stdDir-: Directory; - - - (** Frame **) - - - PROCEDURE (f: Frame) MouseDown* (x, y: INTEGER; buttons: SET), NEW, EMPTY; - PROCEDURE (f: Frame) WheelMove* (x, y: INTEGER; op, nofLines: INTEGER; - VAR done: BOOLEAN), NEW, EMPTY; - PROCEDURE (f: Frame) KeyDown* (ch: CHAR), NEW, EMPTY; - PROCEDURE (f: Frame) Restore* (l, t, r, b: INTEGER), NEW, ABSTRACT; - PROCEDURE (f: Frame) UpdateList*, NEW, EMPTY; - PROCEDURE (f: Frame) Mark* (on, focus: BOOLEAN), NEW, EMPTY; - PROCEDURE (f: Frame) Edit* (op: INTEGER; VAR v: Views.View; VAR w, h: INTEGER; - VAR singleton, clipboard: BOOLEAN), NEW, EMPTY; - PROCEDURE (f: Frame) GetCursor* (x, y: INTEGER; modifiers: SET; VAR cursor: INTEGER), NEW, EMPTY; - - PROCEDURE (f: Frame) Update*, NEW, EXTENSIBLE; - VAR l, t, r, b: INTEGER; root: Views.RootFrame; - BEGIN - l := f.l + f.gx; t := f.t + f.gy; r := f.r + f.gx; b := f.b + f.gy; - root := Views.RootOf(f); - Views.UpdateRoot(root, l, t, r, b, Views.keepFrames); - Views.ValidateRoot(root) - END Update; - - PROCEDURE (f: Frame) DblClickOk* (x, y: INTEGER): BOOLEAN, NEW, EXTENSIBLE; - BEGIN - RETURN TRUE - END DblClickOk; - - - (** Field **) - - PROCEDURE (f: Field) Idle* (), NEW, ABSTRACT; - PROCEDURE (f: Field) Select* (from, to: INTEGER), NEW, ABSTRACT; - PROCEDURE (f: Field) GetSelection* (OUT from, to: INTEGER), NEW, ABSTRACT; - PROCEDURE (f: Field) Length* (): INTEGER, NEW, ABSTRACT; - - PROCEDURE (f: Field) GetCursor* (x, y: INTEGER; modifiers: SET; VAR cursor: INTEGER), EXTENSIBLE; - BEGIN - cursor := Ports.textCursor - END GetCursor; - - - (** UpDownField **) - - PROCEDURE (f: UpDownField) Idle*, NEW, ABSTRACT; - PROCEDURE (f: UpDownField) Select* (from, to: INTEGER), NEW, ABSTRACT; - PROCEDURE (f: UpDownField) GetSelection* (OUT from, to: INTEGER), NEW, ABSTRACT; - - PROCEDURE (f: UpDownField) GetCursor* (x, y: INTEGER; modifiers: SET; - VAR cursor: INTEGER), EXTENSIBLE; - BEGIN - cursor := Ports.textCursor - END GetCursor; - - - (** SelectionBox **) - - PROCEDURE (f: SelectionBox) Select* (from, to: INTEGER), NEW, ABSTRACT; - PROCEDURE (f: SelectionBox) GetSelection* (OUT from, to: INTEGER), NEW, ABSTRACT; - - PROCEDURE (f: SelectionBox) UpdateRange* (op, from, to: INTEGER), NEW, EXTENSIBLE; - BEGIN - f.Update - END UpdateRange; - - - (** ComboBox **) - - PROCEDURE (f: ComboBox) Idle* (), NEW, ABSTRACT; - PROCEDURE (f: ComboBox) Select* (from, to: INTEGER), NEW, ABSTRACT; - PROCEDURE (f: ComboBox) GetSelection* (OUT from, to: INTEGER), NEW, ABSTRACT; - PROCEDURE (f: ComboBox) Length* (): INTEGER, NEW, ABSTRACT; - - (* TreeFrame **) - PROCEDURE (f: TreeFrame) GetSize* (OUT w, h: INTEGER), NEW, ABSTRACT; - - (** Directory **) - - PROCEDURE (d: Directory) GetPushButtonSize* (VAR w, h: INTEGER), NEW, ABSTRACT; - PROCEDURE (d: Directory) GetCheckBoxSize* (VAR w, h: INTEGER), NEW, ABSTRACT; - PROCEDURE (d: Directory) GetRadioButtonSize* (VAR w, h: INTEGER), NEW, ABSTRACT; - PROCEDURE (d: Directory) GetScrollBarSize* (VAR w, h: INTEGER), NEW, ABSTRACT; - PROCEDURE (d: Directory) GetFieldSize* (max: INTEGER; VAR w, h: INTEGER), NEW, ABSTRACT; - PROCEDURE (d: Directory) GetUpDownFieldSize* (max: INTEGER; VAR w, h: INTEGER), NEW, ABSTRACT; - PROCEDURE (d: Directory) GetDateFieldSize* (VAR w, h: INTEGER), NEW, ABSTRACT; - PROCEDURE (d: Directory) GetTimeFieldSize* (VAR w, h: INTEGER), NEW, ABSTRACT; - PROCEDURE (d: Directory) GetColorFieldSize* (VAR w, h: INTEGER), NEW, ABSTRACT; - PROCEDURE (d: Directory) GetListBoxSize* (VAR w, h: INTEGER), NEW, ABSTRACT; - PROCEDURE (d: Directory) GetSelectionBoxSize* (VAR w, h: INTEGER), NEW, ABSTRACT; - PROCEDURE (d: Directory) GetComboBoxSize* (VAR w, h: INTEGER), NEW, ABSTRACT; - PROCEDURE (d: Directory) GetCaptionSize* (VAR w, h: INTEGER), NEW, ABSTRACT; - PROCEDURE (d: Directory) GetGroupSize* (VAR w, h: INTEGER), NEW, ABSTRACT; - PROCEDURE (d: Directory) GetTreeFrameSize* (VAR w, h: INTEGER), NEW, ABSTRACT; - PROCEDURE (d: Directory) NewPushButton* (): PushButton, NEW, ABSTRACT; - PROCEDURE (d: Directory) NewCheckBox* (): CheckBox, NEW, ABSTRACT; - PROCEDURE (d: Directory) NewRadioButton* (): RadioButton, NEW, ABSTRACT; - PROCEDURE (d: Directory) NewScrollBar* (): ScrollBar, NEW, ABSTRACT; - PROCEDURE (d: Directory) NewField* (): Field, NEW, ABSTRACT; - PROCEDURE (d: Directory) NewUpDownField* (): UpDownField, NEW, ABSTRACT; - PROCEDURE (d: Directory) NewDateField* (): DateField, NEW, ABSTRACT; - PROCEDURE (d: Directory) NewTimeField* (): TimeField, NEW, ABSTRACT; - PROCEDURE (d: Directory) NewColorField* (): ColorField, NEW, ABSTRACT; - PROCEDURE (d: Directory) NewListBox* (): ListBox, NEW, ABSTRACT; - PROCEDURE (d: Directory) NewSelectionBox* (): SelectionBox, NEW, ABSTRACT; - PROCEDURE (d: Directory) NewComboBox* (): ComboBox, NEW, ABSTRACT; - PROCEDURE (d: Directory) NewCaption* (): Caption, NEW, ABSTRACT; - PROCEDURE (d: Directory) NewGroup* (): Group, NEW, ABSTRACT; - PROCEDURE (d: Directory) NewTreeFrame* (): TreeFrame, NEW, ABSTRACT; - - - PROCEDURE SetDir* (d: Directory); - BEGIN - ASSERT(d # NIL, 20); dir := d; - IF stdDir = NIL THEN stdDir := d END - END SetDir; - -BEGIN - setFocus := FALSE -END StdCFrames. diff --git a/new/Std/Mod/Clocks.txt b/new/Std/Mod/Clocks.txt deleted file mode 100644 index f7e4917..0000000 --- a/new/Std/Mod/Clocks.txt +++ /dev/null @@ -1,183 +0,0 @@ -MODULE StdClocks; - - (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/Clocks.odc *) - (* DO NOT EDIT *) - - IMPORT - Dates, Math, Domains := Stores, Ports, Stores, Models, Views, Services, Properties, - TextModels; - - CONST - minSize = 25 * Ports.point; niceSize = 42 * Ports.point; - minVersion = 0; maxVersion = 0; - - TYPE - StdView = POINTER TO RECORD (Views.View) - time: Dates.Time - END; - - TickAction = POINTER TO RECORD (Services.Action) END; - - Msg = RECORD (Models.Message) - consumed: BOOLEAN; - time: Dates.Time - END; - - VAR - clockTime: Dates.Time; - action: TickAction; - actionIsAlive: BOOLEAN; - - - PROCEDURE Cos (r, g: INTEGER): INTEGER; - BEGIN - RETURN SHORT(ENTIER(r * Math.Cos(2 * Math.Pi() * g / 60) + 0.5)) - END Cos; - - PROCEDURE Sin (r, g: INTEGER): INTEGER; - BEGIN - RETURN SHORT(ENTIER(r * Math.Sin(2 * Math.Pi() * g / 60) + 0.5)) - END Sin; - - PROCEDURE (a: TickAction) Do; - VAR msg: Msg; time: Dates.Time; - BEGIN - Dates.GetTime(time); - IF clockTime.second = time.second THEN - Services.DoLater(action, Services.Ticks() + Services.resolution DIV 2) - ELSE - clockTime := time; - msg.consumed := FALSE; - msg.time := time; - Views.Omnicast(msg); - IF msg.consumed THEN - Services.DoLater(action, Services.Ticks() + Services.resolution DIV 2) - ELSE - actionIsAlive := FALSE - END - END - END Do; - - - (* View *) - - PROCEDURE DrawTick (f: Views.Frame; m, d0, d1, s, g: INTEGER; c: Ports.Color); - BEGIN - f.DrawLine(m + Sin(d0, g), m - Cos(d0, g), m + Sin(d1, g), m - Cos(d1, g), s, c) - END DrawTick; - - - PROCEDURE (v: StdView) Externalize (VAR wr: Stores.Writer); - BEGIN - v.Externalize^(wr); - wr.WriteVersion(maxVersion); - wr.WriteByte(9) - END Externalize; - - PROCEDURE (v: StdView) Internalize (VAR rd: Stores.Reader); - VAR thisVersion: INTEGER; format: BYTE; - BEGIN - v.Internalize^(rd); - IF ~rd.cancelled THEN - rd.ReadVersion(minVersion, maxVersion, thisVersion); - IF ~rd.cancelled THEN - rd.ReadByte(format); - v.time.second := -1 - END - END - END Internalize; - - PROCEDURE (v: StdView) CopyFromSimpleView (source: Views.View); - BEGIN - WITH source: StdView DO - v.time.second := -1 - END - END CopyFromSimpleView; - - PROCEDURE (v: StdView) Restore (f: Views.Frame; l, t, r, b: INTEGER); - VAR c: Models.Context; a: TextModels.Attributes; color: Ports.Color; - time: Dates.Time; - i, m, d, u, hs, hd1, ms, md1, ss, sd0, sd1, w, h: INTEGER; - BEGIN - IF ~actionIsAlive THEN - actionIsAlive := TRUE; Services.DoLater(action, Services.now) - END; - IF v.time.second = -1 THEN Dates.GetTime(v.time) END; - c := v.context; c.GetSize(w, h); - WITH c: TextModels.Context DO a := c.Attr(); color := a.color - ELSE color := Ports.defaultColor - END; - u := f.unit; - d := h DIV u * u; - IF ~ODD(d DIV u) THEN DEC(d, u) END; - m := (h - u) DIV 2; - IF d >= niceSize - 2 * Ports.point THEN - hs := 3 * u; ms := 3 * u; ss := u; - hd1 := m * 4 DIV 6; md1 := m * 5 DIV 6; sd0 := -(m DIV 6); sd1 := m - 4 * u; - i := 0; WHILE i < 12 DO DrawTick(f, m, m * 11 DIV 12, m, u, i * 5, color); INC(i) END - ELSE - hd1 := m * 2 DIV 4; hs := u; ms := u; ss := u; - md1 := m * 3 DIV 4; sd0 := 0; sd1 := 3 * u - END; - time := v.time; - f.DrawOval(0, 0, d, d, u, color); - DrawTick(f, m, 0, m * 4 DIV 6, hs, time.hour MOD 12 * 5 + time.minute DIV 12, color); - DrawTick(f, m, 0, md1, ms, time.minute, color); - DrawTick(f, m, sd0, sd1, ss, time.second, color) - END Restore; - - PROCEDURE (v: StdView) HandleModelMsg (VAR msg: Models.Message); - VAR w, h: INTEGER; - BEGIN - WITH msg: Msg DO - msg.consumed := TRUE; - IF v.time.second # msg.time.second THEN (* execute only once per view *) - Views.Update(v, Views.keepFrames); - v.time := msg.time - END - ELSE - END - END HandleModelMsg; - - PROCEDURE SizePref (v: StdView; VAR p: Properties.SizePref); - BEGIN - IF (p.w > Views.undefined) & (p.h > Views.undefined) THEN - Properties.ProportionalConstraint(1, 1, p.fixedW, p.fixedH, p.w, p.h); - IF p.w < minSize THEN p.w := minSize; p.h := minSize END - ELSE - p.w := niceSize; p.h := niceSize - END - END SizePref; - - PROCEDURE (v: StdView) HandlePropMsg (VAR msg: Properties.Message); - BEGIN - WITH msg: Properties.Preference DO - WITH msg: Properties.SizePref DO - SizePref(v, msg) - ELSE - END - ELSE - END - END HandlePropMsg; - - - (** allocation **) - - PROCEDURE New* (): Views.View; - VAR v: StdView; - BEGIN - NEW(v); v.time.second := -1; RETURN v - END New; - - PROCEDURE Deposit*; - BEGIN - Views.Deposit(New()) - END Deposit; - - -BEGIN - clockTime.second := -1; - NEW(action); actionIsAlive := FALSE -CLOSE - IF actionIsAlive THEN Services.RemoveAction(action) END -END StdClocks. diff --git a/new/Std/Mod/Cmds.txt b/new/Std/Mod/Cmds.txt deleted file mode 100644 index 76e5ae9..0000000 --- a/new/Std/Mod/Cmds.txt +++ /dev/null @@ -1,1016 +0,0 @@ -MODULE StdCmds; - - (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/Cmds.odc *) - (* DO NOT EDIT *) - - IMPORT - Fonts, Ports, Services, Stores, Sequencers, Models, Views, - Controllers, Containers, Properties, Dialog, Documents, Windows, Strings, - StdDialog, StdApi; - - CONST - illegalSizeKey = "#System:IllegalFontSize"; - defaultAllocator = "TextViews.Deposit; StdCmds.Open"; - - (* wType, hType *) - fix = 0; page = 1; window = 2; - - VAR - size*: RECORD - size*: INTEGER - END; - layout*: RECORD - wType*, hType*: INTEGER; - width*, height*: REAL; - doc: Documents.Document; - u: INTEGER - END; - allocator*: Dialog.String; - - propEra: INTEGER; (* (propEra, props) form cache for StdProps() *) - props: Properties.StdProp; (* valid iff propEra = Props.era *) - - prop: Properties.Property; (* usef for copy/paste properties *) - - (* auxiliary procedures *) - - PROCEDURE StdProp (): Properties.StdProp; - BEGIN - IF propEra # Properties.era THEN - Properties.CollectStdProp(props); - propEra := Properties.era - END; - RETURN props - END StdProp; - - PROCEDURE Append (VAR s: ARRAY OF CHAR; t: ARRAY OF CHAR); - VAR len, i, j: INTEGER; ch: CHAR; - BEGIN - len := LEN(s); - i := 0; WHILE s[i] # 0X DO INC(i) END; - j := 0; REPEAT ch := t[j]; s[i] := ch; INC(j); INC(i) UNTIL (ch = 0X) OR (i = len); - s[len - 1] := 0X - END Append; - - (* standard commands *) - - PROCEDURE OpenAuxDialog* (file, title: ARRAY OF CHAR); - VAR v: Views.View; - BEGIN - StdApi.OpenAuxDialog(file, title, v) - END OpenAuxDialog; - - PROCEDURE OpenToolDialog* (file, title: ARRAY OF CHAR); - VAR v: Views.View; - BEGIN - StdApi.OpenToolDialog(file, title, v) - END OpenToolDialog; - - PROCEDURE OpenDoc* (file: ARRAY OF CHAR); - VAR v: Views.View; - BEGIN - StdApi.OpenDoc(file, v) - END OpenDoc; - - PROCEDURE OpenCopyOf* (file: ARRAY OF CHAR); - VAR v: Views.View; - BEGIN - StdApi.OpenCopyOf(file, v) - END OpenCopyOf; - - PROCEDURE OpenAux* (file, title: ARRAY OF CHAR); - VAR v: Views.View; - BEGIN - StdApi.OpenAux(file, title, v) - END OpenAux; - - PROCEDURE OpenBrowser* (file, title: ARRAY OF CHAR); - VAR v: Views.View; - BEGIN - StdApi.OpenBrowser(file, title, v) - END OpenBrowser; - - PROCEDURE CloseDialog*; - VAR v: Views.View; - BEGIN - StdApi.CloseDialog(v) - END CloseDialog; - - - PROCEDURE Open*; - VAR i: INTEGER; v: Views.View; - BEGIN - i := Views.Available(); - IF i > 0 THEN Views.Fetch(v); Views.OpenView(v) - ELSE Dialog.ShowMsg("#System:DepositExpected") - END - END Open; - - PROCEDURE PasteView*; - VAR i: INTEGER; v: Views.View; - BEGIN - i := Views.Available(); - IF i > 0 THEN - Views.Fetch(v); - Controllers.PasteView(v, Views.undefined, Views.undefined, FALSE) - ELSE Dialog.ShowMsg("#System:DepositExpected") - END - END PasteView; - - (* file menu commands *) - - PROCEDURE New*; - VAR res: INTEGER; - BEGIN - Dialog.Call(allocator, " ", res) - END New; - - - (* edit menu commands *) - - PROCEDURE Undo*; - VAR w: Windows.Window; - BEGIN - w := Windows.dir.Focus(Controllers.frontPath); - IF w # NIL THEN w.seq.Undo END - END Undo; - - PROCEDURE Redo*; - VAR w: Windows.Window; - BEGIN - w := Windows.dir.Focus(Controllers.frontPath); - IF w # NIL THEN w.seq.Redo END - END Redo; - - PROCEDURE CopyProp*; - BEGIN - Properties.CollectProp(prop) - END CopyProp; - - PROCEDURE PasteProp*; - BEGIN - Properties.EmitProp(NIL, prop) - END PasteProp; - - PROCEDURE Clear*; - (** remove the selection of the current focus **) - VAR msg: Controllers.EditMsg; - BEGIN - msg.op := Controllers.cut; msg.view := NIL; - msg.clipboard := FALSE; - Controllers.Forward(msg) - END Clear; - - PROCEDURE SelectAll*; - (** select whole content of current focus **) - VAR msg: Controllers.SelectMsg; - BEGIN - msg.set := TRUE; Controllers.Forward(msg) - END SelectAll; - - PROCEDURE DeselectAll*; - (** select whole content of current focus **) - VAR msg: Controllers.SelectMsg; - BEGIN - msg.set := FALSE; Controllers.Forward(msg) - END DeselectAll; - - PROCEDURE SelectDocument*; - (** select whole document **) - VAR w: Windows.Window; c: Containers.Controller; - BEGIN - w := Windows.dir.Focus(Controllers.path); - IF w # NIL THEN - c := w.doc.ThisController(); - IF (c # NIL) & ~(Containers.noSelection IN c.opts) & (c.Singleton() = NIL) THEN - c.SetSingleton(w.doc.ThisView()) - END - END - END SelectDocument; - - PROCEDURE SelectNextView*; - VAR c: Containers.Controller; v: Views.View; - BEGIN - c := Containers.Focus(); - IF (c # NIL) & ~(Containers.noSelection IN c.opts) THEN - IF c.HasSelection() THEN v := c.Singleton() ELSE v := NIL END; - IF v = NIL THEN - c.GetFirstView(Containers.any, v) - ELSE - c.GetNextView(Containers.any, v); - IF v = NIL THEN c.GetFirstView(Containers.any, v) END - END; - c.SelectAll(FALSE); - IF v # NIL THEN c.SetSingleton(v) END - ELSE Dialog.ShowMsg("#Dev:NoTargetFocusFound") - END - END SelectNextView; - - - (** font menu commands **) - - PROCEDURE Font* (typeface: Fonts.Typeface); - (** set the selection to the given font family **) - VAR p: Properties.StdProp; - BEGIN - NEW(p); p.valid := {Properties.typeface}; p.typeface := typeface; - Properties.EmitProp(NIL, p) - END Font; - - PROCEDURE DefaultFont*; - (** set the selection to the default font family **) - VAR p: Properties.StdProp; - BEGIN - NEW(p); p.valid := {Properties.typeface}; p.typeface := Fonts.default; - Properties.EmitProp(NIL, p) - END DefaultFont; - - - (** attributes menu commands **) - - PROCEDURE Plain*; - (** reset the font attribute "weight" and all font style attributes of the selection **) - VAR p: Properties.StdProp; - BEGIN - NEW(p); p.valid := {Properties.style, Properties.weight}; - p.style.val := {}; p.style.mask := {Fonts.italic, Fonts.underline, Fonts.strikeout}; - p.weight := Fonts.normal; - Properties.EmitProp(NIL, p) - END Plain; - - PROCEDURE Bold*; - (** change the font attribute "weight" in the selection; - if the selection has a homogeneously bold weight: toggle to normal, else force to bold **) - VAR p, p0: Properties.StdProp; - BEGIN - Properties.CollectStdProp(p0); - NEW(p); p.valid := {Properties.weight}; - IF (Properties.weight IN p0.valid) & (p0.weight # Fonts.normal) THEN - p.weight := Fonts.normal - ELSE p.weight := Fonts.bold - END; - Properties.EmitProp(NIL, p) - END Bold; - - PROCEDURE Italic*; - (** change the font style attribute "italic" in the selection; - if the selection is homogeneous wrt this attribute: toggle, else force to italic **) - VAR p, p0: Properties.StdProp; - BEGIN - Properties.CollectStdProp(p0); - NEW(p); p.valid := {Properties.style}; p.style.mask := {Fonts.italic}; - IF (Properties.style IN p0.valid) & (Fonts.italic IN p0.style.val) THEN - p.style.val := {} - ELSE p.style.val := {Fonts.italic} - END; - Properties.EmitProp(NIL, p) - END Italic; - - PROCEDURE Underline*; - (** change the font style attribute "underline" in the selection; - if the selection is homogeneous wrt this attribute: toggle, else force to underline **) - VAR p, p0: Properties.StdProp; - BEGIN - Properties.CollectStdProp(p0); - NEW(p); p.valid := {Properties.style}; p.style.mask := {Fonts.underline}; - IF (Properties.style IN p0.valid) & (Fonts.underline IN p0.style.val) THEN - p.style.val := {} - ELSE p.style.val := {Fonts.underline} - END; - Properties.EmitProp(NIL, p) - END Underline; - - PROCEDURE Strikeout*; - (** change the font style attribute "strikeout" in the selection, - without changing other attributes; - if the selection is homogeneous wrt this attribute: toggle, - else force to strikeout **) - VAR p, p0: Properties.StdProp; - BEGIN - Properties.CollectStdProp(p0); - NEW(p); p.valid := {Properties.style}; p.style.mask := {Fonts.strikeout}; - IF (Properties.style IN p0.valid) & (Fonts.strikeout IN p0.style.val) THEN - p.style.val := {} - ELSE p.style.val := {Fonts.strikeout} - END; - Properties.EmitProp(NIL, p) - END Strikeout; - - PROCEDURE Size* (size: INTEGER); - (** set the selection to the given font size **) - VAR p: Properties.StdProp; - BEGIN - NEW(p); p.valid := {Properties.size}; - p.size := size * Ports.point; - Properties.EmitProp(NIL, p) - END Size; - - PROCEDURE SetSize*; - VAR p: Properties.StdProp; - BEGIN - IF (0 <= size.size) & (size.size < 32768) THEN - NEW(p); p.valid := {Properties.size}; - p.size := size.size * Fonts.point; - Properties.EmitProp(NIL, p) - ELSE - Dialog.ShowMsg(illegalSizeKey) - END - END SetSize; - - PROCEDURE InitSizeDialog*; - VAR p: Properties.StdProp; - BEGIN - Properties.CollectStdProp(p); - IF Properties.size IN p.valid THEN size.size := p.size DIV Fonts.point END - END InitSizeDialog; - - PROCEDURE Color* (color: Ports.Color); - (** set the color attributes of the selection **) - VAR p: Properties.StdProp; - BEGIN - NEW(p); p.valid := {Properties.color}; - p.color.val := color; - Properties.EmitProp(NIL, p) - END Color; - - PROCEDURE UpdateAll*; (* for HostCmds.Toggle *) - VAR w: Windows.Window; pw, ph: INTEGER; dirty: BOOLEAN; msg: Models.UpdateMsg; - BEGIN - w := Windows.dir.First(); - WHILE w # NIL DO - IF ~w.sub THEN - dirty := w.seq.Dirty(); - Models.Domaincast(w.doc.Domain(), msg); - IF ~dirty THEN w.seq.SetDirty(FALSE) END (* not perfect: "undoable dirt" ... *) - END; - w.port.GetSize(pw, ph); - w.Restore(0, 0, pw, ph); - w := Windows.dir.Next(w) - END - END UpdateAll; - - PROCEDURE RestoreAll*; - VAR w: Windows.Window; pw, ph: INTEGER; - BEGIN - w := Windows.dir.First(); - WHILE w # NIL DO - w.port.GetSize(pw, ph); - w.Restore(0, 0, pw, ph); - w := Windows.dir.Next(w) - END - END RestoreAll; - - - (** document layout dialog **) - - PROCEDURE SetLayout*; - VAR opts: SET; l, t, r, b, r0, b0: INTEGER; c: Containers.Controller; script: Stores.Operation; - BEGIN - c := layout.doc.ThisController(); - opts := c.opts - {Documents.pageWidth..Documents.winHeight}; - IF layout.wType = page THEN INCL(opts, Documents.pageWidth) - ELSIF layout.wType = window THEN INCL(opts, Documents.winWidth) - END; - IF layout.hType = page THEN INCL(opts, Documents.pageHeight) - ELSIF layout.hType = window THEN INCL(opts, Documents.winHeight) - END; - layout.doc.PollRect(l, t, r, b); r0 := r; b0 := b; - IF layout.wType = fix THEN r := l + SHORT(ENTIER(layout.width * layout.u)) END; - IF layout.hType = fix THEN b := t + SHORT(ENTIER(layout.height * layout.u)) END; - IF (opts # c.opts) OR (r # r0) OR (b # b0) THEN - Views.BeginScript(layout.doc, "#System:ChangeLayout", script); - c.SetOpts(opts); - layout.doc.SetRect(l, t, r, b); - Views.EndScript(layout.doc, script) - END - END SetLayout; - - PROCEDURE InitLayoutDialog*; - (* guard: WindowGuard *) - VAR w: Windows.Window; c: Containers.Controller; l, t, r, b: INTEGER; - BEGIN - w := Windows.dir.First(); - IF w # NIL THEN - layout.doc := w.doc; - c := w.doc.ThisController(); - IF Documents.pageWidth IN c.opts THEN layout.wType := page - ELSIF Documents.winWidth IN c.opts THEN layout.wType := window - ELSE layout.wType := fix - END; - IF Documents.pageHeight IN c.opts THEN layout.hType := page - ELSIF Documents.winHeight IN c.opts THEN layout.hType := window - ELSE layout.hType := fix - END; - IF Dialog.metricSystem THEN layout.u := Ports.mm * 10 ELSE layout.u := Ports.inch END; - w.doc.PollRect(l, t, r, b); - layout.width := (r - l) DIV (layout.u DIV 100) / 100; - layout.height := (b - t) DIV (layout.u DIV 100) / 100 - END - END InitLayoutDialog; - - PROCEDURE WidthGuard* (VAR par: Dialog.Par); - BEGIN - IF layout.wType # fix THEN par.readOnly := TRUE END - END WidthGuard; - - PROCEDURE HeightGuard* (VAR par: Dialog.Par); - BEGIN - IF layout.hType # fix THEN par.readOnly := TRUE END - END HeightGuard; - - PROCEDURE TypeNotifier* (op, from, to: INTEGER); - VAR w, h, l, t, r, b: INTEGER; d: BOOLEAN; - BEGIN - layout.doc.PollRect(l, t, r, b); - IF layout.wType = page THEN - layout.doc.PollPage(w, h, l, t, r, b, d) - ELSIF layout.wType = window THEN - layout.doc.context.GetSize(w, h); r := w - l - END; - layout.width := (r - l) DIV (layout.u DIV 100) / 100; - layout.doc.PollRect(l, t, r, b); - IF layout.hType = page THEN - layout.doc.PollPage(w, h, l, t, r, b, d) - ELSIF layout.hType = window THEN - layout.doc.context.GetSize(w, h); b := h - t - END; - layout.height := (b - t) DIV (layout.u DIV 100) / 100; - Dialog.Update(layout) - END TypeNotifier; - - - (** window menu command **) - - PROCEDURE NewWindow*; - (** guard ModelViewGuard **) - VAR win: Windows.Window; doc: Documents.Document; v: Views.View; title: Views.Title; - seq: ANYPTR; clean: BOOLEAN; - BEGIN - win := Windows.dir.Focus(Controllers.frontPath); - IF win # NIL THEN - v := win.doc.ThisView(); - IF v.Domain() # NIL THEN seq := v.Domain().GetSequencer() ELSE seq := NIL END; - clean := (seq # NIL) & ~seq(Sequencers.Sequencer).Dirty(); - doc := win.doc.DocCopyOf(v); - (* Stores.InitDomain(doc, v.Domain()); *) - ASSERT(doc.Domain() = v.Domain(), 100); - win.GetTitle(title); - Windows.dir.OpenSubWindow(Windows.dir.New(), doc, win.flags, title); - IF clean THEN seq(Sequencers.Sequencer).SetDirty(FALSE) END - END - END NewWindow; - - (* properties *) - - PROCEDURE GetCmd (name: ARRAY OF CHAR; OUT cmd: ARRAY OF CHAR); - VAR i, j: INTEGER; ch, lch: CHAR; key: ARRAY 256 OF CHAR; - BEGIN - i := 0; ch := name[0]; key[0] := "#"; j := 1; - REPEAT - key[j] := ch; INC(j); lch := ch; INC(i); ch := name[i] - UNTIL (ch = 0X) OR (ch = ".") - OR ((ch >= "A") & (ch <= "Z") OR (ch >= "À") & (ch # "×") & (ch <= "Þ")) - & ((lch < "A") OR (lch > "Z") & (lch < "À") OR (lch = "×") OR (lch > "Þ")); - IF ch = "." THEN - key := "#System:" + name - ELSE - key[j] := ":"; INC(j); key[j] := 0X; j := 0; - WHILE ch # 0X DO name[j] := ch; INC(i); INC(j); ch := name[i] END; - name[j] := 0X; key := key + name - END; - Dialog.MapString(key, cmd); - IF cmd = name THEN cmd := "" END - END GetCmd; - - PROCEDURE SearchCmd (call: BOOLEAN; OUT found: BOOLEAN); - VAR p: Properties.Property; std: BOOLEAN; v: Views.View; cmd: ARRAY 256 OF CHAR; pos, res: INTEGER; - BEGIN - Controllers.SetCurrentPath(Controllers.targetPath); - v := Containers.FocusSingleton(); found := FALSE; - IF v # NIL THEN - Services.GetTypeName(v, cmd); - GetCmd(cmd, cmd); - IF cmd # "" THEN found := TRUE; - IF call THEN Dialog.Call(cmd, "", res) END - END - END; - std := FALSE; - Properties.CollectProp(p); - WHILE p # NIL DO - IF p IS Properties.StdProp THEN std := TRUE - ELSE - Services.GetTypeName(p, cmd); - GetCmd(cmd, cmd); - IF cmd # "" THEN found := TRUE; - IF call THEN Dialog.Call(cmd, "", res) END - ELSE - Services.GetTypeName(p, cmd); - Strings.Find(cmd, "Desc", LEN(cmd$)-4, pos); - IF LEN(cmd$)-4 = pos THEN - cmd[pos] := 0X; GetCmd(cmd, cmd); - IF cmd # "" THEN found := TRUE; - IF call THEN Dialog.Call(cmd, "", res) END - END - END - END - END; - p := p.next - END; - IF std & ~found THEN - Dialog.MapString("#Host:Properties.StdProp", cmd); - IF cmd # "Properties.StdProp" THEN found := TRUE; - IF call THEN Dialog.Call(cmd, "", res) END - END - END; - IF ~found THEN - Dialog.MapString("#System:ShowProp", cmd); - IF cmd # "ShowProp" THEN found := TRUE; - IF call THEN Dialog.Call(cmd, "", res) END - END - END; - Controllers.ResetCurrentPath - END SearchCmd; - - PROCEDURE ShowProp*; - VAR found: BOOLEAN; - BEGIN - SearchCmd(TRUE, found) - END ShowProp; - - PROCEDURE ShowPropGuard* (VAR par: Dialog.Par); - VAR found: BOOLEAN; - BEGIN - SearchCmd(FALSE, found); - IF ~found THEN par.disabled := TRUE END - END ShowPropGuard; - - - (* container commands *) - - PROCEDURE ActFocus (): Containers.Controller; - VAR c: Containers.Controller; v: Views.View; - BEGIN - c := Containers.Focus(); - IF c # NIL THEN - v := c.ThisView(); - IF v IS Documents.Document THEN - v := v(Documents.Document).ThisView(); - IF v IS Containers.View THEN - c := v(Containers.View).ThisController() - ELSE c := NIL - END - END - END; - RETURN c - END ActFocus; - - PROCEDURE ToggleNoFocus*; - VAR c: Containers.Controller; v: Views.View; - BEGIN - c := ActFocus(); - IF c # NIL THEN - v := c.ThisView(); - IF ~((v IS Documents.Document) OR (Containers.noSelection IN c.opts)) THEN - IF Containers.noFocus IN c.opts THEN - c.SetOpts(c.opts - {Containers.noFocus}) - ELSE - c.SetOpts(c.opts + {Containers.noFocus}) - END - END - END - END ToggleNoFocus; - - PROCEDURE OpenAsAuxDialog*; - (** create a new sub-window onto the focus view shown in the top window, mask mode **) - VAR win: Windows.Window; doc: Documents.Document; v, u: Views.View; title: Views.Title; - c: Containers.Controller; - BEGIN - v := Controllers.FocusView(); - IF (v # NIL) & (v IS Containers.View) & ~(v IS Documents.Document) THEN - win := Windows.dir.Focus(Controllers.frontPath); ASSERT(win # NIL, 100); - doc := win.doc.DocCopyOf(v); - u := doc.ThisView(); - c := u(Containers.View).ThisController(); - c.SetOpts(c.opts - {Containers.noFocus} + {Containers.noCaret, Containers.noSelection}); - IF v # win.doc.ThisView() THEN - c := doc.ThisController(); - c.SetOpts(c.opts - {Documents.pageWidth, Documents.pageHeight} - + {Documents.winWidth, Documents.winHeight}) - END; - (* Stores.InitDomain(doc, v.Domain()); already done in DocCopyOf *) - win.GetTitle(title); - Windows.dir.OpenSubWindow(Windows.dir.New(), doc, - {Windows.isAux, Windows.neverDirty, Windows.noResize, Windows.noHScroll, Windows.noVScroll}, - title) - ELSE Dialog.Beep - END - END OpenAsAuxDialog; - - PROCEDURE OpenAsToolDialog*; - (** create a new sub-window onto the focus view shown in the top window, mask mode **) - VAR win: Windows.Window; doc: Documents.Document; v, u: Views.View; title: Views.Title; - c: Containers.Controller; - BEGIN - v := Controllers.FocusView(); - IF (v # NIL) & (v IS Containers.View) & ~(v IS Documents.Document) THEN - win := Windows.dir.Focus(Controllers.frontPath); ASSERT(win # NIL, 100); - doc := win.doc.DocCopyOf(v); - u := doc.ThisView(); - c := u(Containers.View).ThisController(); - c.SetOpts(c.opts - {Containers.noFocus} + {Containers.noCaret, Containers.noSelection}); - IF v # win.doc.ThisView() THEN - c := doc.ThisController(); - c.SetOpts(c.opts - {Documents.pageWidth, Documents.pageHeight} - + {Documents.winWidth, Documents.winHeight}) - END; - (* Stores.InitDomain(doc, v.Domain()); already done in DocCopyOf *) - win.GetTitle(title); - Windows.dir.OpenSubWindow(Windows.dir.New(), doc, - {Windows.isTool, Windows.neverDirty, Windows.noResize, Windows.noHScroll, Windows.noVScroll}, - title) - ELSE Dialog.Beep - END - END OpenAsToolDialog; - - PROCEDURE RecalcFocusSize*; - VAR c: Containers.Controller; v: Views.View; bounds: Properties.BoundsPref; - BEGIN - c := Containers.Focus(); - IF c # NIL THEN - v := c.ThisView(); - bounds.w := Views.undefined; bounds.h := Views.undefined; - Views.HandlePropMsg(v, bounds); - v.context.SetSize(bounds.w, bounds.h) - END - END RecalcFocusSize; - - PROCEDURE RecalcAllSizes*; - VAR w: Windows.Window; - BEGIN - w := Windows.dir.First(); - WHILE w # NIL DO - StdDialog.RecalcView(w.doc.ThisView()); - w := Windows.dir.Next(w) - END - END RecalcAllSizes; - - PROCEDURE SetMode(opts: SET); - VAR - c: Containers.Controller; v: Views.View; - gm: Containers.GetOpts; sm: Containers.SetOpts; - w: Windows.Window; - BEGIN - c := Containers.Focus(); - gm.valid := {}; - IF (c # NIL) & (c.Singleton() # NIL) THEN - v := c.Singleton(); - Views.HandlePropMsg(v, gm); - END; - IF gm.valid = {} THEN - w := Windows.dir.Focus(Controllers.path); - IF (w # NIL) & (w.doc.ThisView() IS Containers.View) THEN v := w.doc.ThisView() ELSE v := NIL END - END; - IF v # NIL THEN - sm.valid := {Containers.noSelection, Containers.noFocus, Containers.noCaret}; - sm.opts := opts; - Views.HandlePropMsg(v, sm); - END; - END SetMode; - - PROCEDURE GetMode(OUT found: BOOLEAN; OUT opts: SET); - VAR c: Containers.Controller; gm: Containers.GetOpts; w: Windows.Window; - BEGIN - c := Containers.Focus(); - gm.valid := {}; - IF (c # NIL) & (c.Singleton() # NIL) THEN - Views.HandlePropMsg(c.Singleton(), gm); - END; - IF gm.valid = {} THEN - w := Windows.dir.Focus(Controllers.path); - IF (w # NIL) & (w.doc.ThisView() IS Containers.View) THEN - Views.HandlePropMsg(w.doc.ThisView(), gm); - END - END; - found := gm.valid # {}; - opts := gm.opts - END GetMode; - - PROCEDURE SetMaskMode*; - (* Guard: SetMaskGuard *) - BEGIN - SetMode({Containers.noSelection, Containers.noCaret}) - END SetMaskMode; - - PROCEDURE SetEditMode*; - (* Guard: SetEditGuard *) - BEGIN - SetMode({}) - END SetEditMode; - - PROCEDURE SetLayoutMode*; - (* Guard: SetLayoutGuard *) - BEGIN - SetMode({Containers.noFocus}) - END SetLayoutMode; - - PROCEDURE SetBrowserMode*; - (* Guard: SetBrowserGuard *) - BEGIN - SetMode({Containers.noCaret}) - END SetBrowserMode; - - - (* standard guards *) - - PROCEDURE ToggleNoFocusGuard* (VAR par: Dialog.Par); - VAR c: Containers.Controller; v: Views.View; - BEGIN - c := ActFocus(); - IF c # NIL THEN - v := c.ThisView(); - IF ~((v IS Documents.Document) OR (Containers.noSelection IN c.opts)) THEN - IF Containers.noFocus IN c.opts THEN par.label := "#System:AllowFocus" - ELSE par.label := "#System:PreventFocus" - END - ELSE par.disabled := TRUE - END - ELSE par.disabled := TRUE - END - END ToggleNoFocusGuard; - - PROCEDURE ReadOnlyGuard* (VAR par: Dialog.Par); - BEGIN - par.readOnly := TRUE - END ReadOnlyGuard; - - PROCEDURE WindowGuard* (VAR par: Dialog.Par); - VAR w: Windows.Window; - BEGIN - w := Windows.dir.First(); - IF w = NIL THEN par.disabled := TRUE END - END WindowGuard; - - PROCEDURE ModelViewGuard* (VAR par: Dialog.Par); - VAR w: Windows.Window; - BEGIN - w := Windows.dir.Focus(Controllers.frontPath); - par.disabled := (w = NIL) OR (w.doc.ThisView().ThisModel() = NIL) - END ModelViewGuard; - - PROCEDURE SetMaskModeGuard* (VAR par: Dialog.Par); - CONST mode = {Containers.noSelection, Containers.noFocus, Containers.noCaret}; - VAR opts: SET; found: BOOLEAN; - BEGIN - GetMode(found, opts); - IF found THEN - par.checked := opts * mode = {Containers.noSelection, Containers.noCaret} - ELSE - par.disabled := TRUE - END - END SetMaskModeGuard; - - PROCEDURE SetEditModeGuard* (VAR par: Dialog.Par); - CONST mode = {Containers.noSelection, Containers.noFocus, Containers.noCaret}; - VAR opts: SET; found: BOOLEAN; - BEGIN - GetMode(found, opts); - IF found THEN - par.checked := opts * mode = {} - ELSE - par.disabled := TRUE - END - END SetEditModeGuard; - - PROCEDURE SetLayoutModeGuard* (VAR par: Dialog.Par); - CONST mode = {Containers.noSelection, Containers.noFocus, Containers.noCaret}; - VAR opts: SET; found: BOOLEAN; - BEGIN - GetMode(found, opts); - IF found THEN - par.checked := opts * mode = {Containers.noFocus} - ELSE - par.disabled := TRUE - END - END SetLayoutModeGuard; - - PROCEDURE SetBrowserModeGuard* (VAR par: Dialog.Par); - CONST mode = {Containers.noSelection, Containers.noFocus, Containers.noCaret}; - VAR opts: SET; found: BOOLEAN; - BEGIN - GetMode(found, opts); - IF found THEN - par.checked := opts * mode = {Containers.noCaret} - ELSE - par.disabled := TRUE - END - END SetBrowserModeGuard; - - PROCEDURE SelectionGuard* (VAR par: Dialog.Par); - VAR ops: Controllers.PollOpsMsg; - BEGIN - Controllers.PollOps(ops); - IF ops.valid * {Controllers.cut, Controllers.copy} = {} THEN par.disabled := TRUE END - END SelectionGuard; - - PROCEDURE SingletonGuard* (VAR par: Dialog.Par); - VAR ops: Controllers.PollOpsMsg; - BEGIN - Controllers.PollOps(ops); - IF ops.singleton = NIL THEN par.disabled := TRUE END - END SingletonGuard; - - PROCEDURE SelectAllGuard* (VAR par: Dialog.Par); - VAR ops: Controllers.PollOpsMsg; - BEGIN - Controllers.PollOps(ops); - IF ~ops.selectable THEN par.disabled := TRUE END - END SelectAllGuard; - - PROCEDURE CaretGuard* (VAR par: Dialog.Par); - VAR ops: Controllers.PollOpsMsg; - BEGIN - Controllers.PollOps(ops); - IF ops.valid * {Controllers.pasteChar .. Controllers.paste} = {} THEN par.disabled := TRUE END - END CaretGuard; - - PROCEDURE PasteCharGuard* (VAR par: Dialog.Par); - VAR ops: Controllers.PollOpsMsg; - BEGIN - Controllers.PollOps(ops); - IF ~(Controllers.pasteChar IN ops.valid) THEN par.disabled := TRUE END - END PasteCharGuard; - - PROCEDURE PasteLCharGuard* (VAR par: Dialog.Par); - VAR ops: Controllers.PollOpsMsg; - BEGIN - Controllers.PollOps(ops); - IF ~(Controllers.pasteChar IN ops.valid) THEN par.disabled := TRUE END - END PasteLCharGuard; - - PROCEDURE PasteViewGuard* (VAR par: Dialog.Par); - VAR ops: Controllers.PollOpsMsg; - BEGIN - Controllers.PollOps(ops); - IF ~(Controllers.paste IN ops.valid) THEN par.disabled := TRUE END - END PasteViewGuard; - - PROCEDURE ContainerGuard* (VAR par: Dialog.Par); - BEGIN - IF Containers.Focus() = NIL THEN par.disabled := TRUE END - END ContainerGuard; - - PROCEDURE UndoGuard* (VAR par: Dialog.Par); - VAR f: Windows.Window; opName: Stores.OpName; - BEGIN - Dialog.MapString("#System:Undo", par.label); - f := Windows.dir.Focus(Controllers.frontPath); - IF (f # NIL) & f.seq.CanUndo() THEN - f.seq.GetUndoName(opName); - Dialog.MapString(opName, opName); - Append(par.label, " "); - Append(par.label, opName) - ELSE - par.disabled := TRUE - END - END UndoGuard; - - PROCEDURE RedoGuard* (VAR par: Dialog.Par); - VAR f: Windows.Window; opName: Stores.OpName; - BEGIN - Dialog.MapString("#System:Redo", par.label); - f := Windows.dir.Focus(Controllers.frontPath); - IF (f # NIL) & f.seq.CanRedo() THEN - f.seq.GetRedoName(opName); - Dialog.MapString(opName, opName); - Append(par.label, " "); - Append(par.label, opName) - ELSE - par.disabled := TRUE - END - END RedoGuard; - - PROCEDURE PlainGuard* (VAR par: Dialog.Par); - VAR props: Properties.StdProp; - BEGIN - props := StdProp(); - IF props.known * {Properties.style, Properties.weight} # {} THEN - par.checked := (Properties.style IN props.valid) - & (props.style.val = {}) & ({Fonts.italic, Fonts.underline, Fonts.strikeout} - props.style.mask = {}) - & (Properties.weight IN props.valid) & (props.weight = Fonts.normal) - ELSE - par.disabled := TRUE - END - END PlainGuard; - - PROCEDURE BoldGuard* (VAR par: Dialog.Par); - VAR props: Properties.StdProp; - BEGIN - props := StdProp(); - IF Properties.weight IN props.known THEN - par.checked := (Properties.weight IN props.valid) & (props.weight = Fonts.bold) - ELSE - par.disabled := TRUE - END - END BoldGuard; - - PROCEDURE ItalicGuard* (VAR par: Dialog.Par); - VAR props: Properties.StdProp; - BEGIN - props := StdProp(); - IF Properties.style IN props.known THEN - par.checked := (Properties.style IN props.valid) & (Fonts.italic IN props.style.val) - ELSE - par.disabled := TRUE - END - END ItalicGuard; - - PROCEDURE UnderlineGuard* (VAR par: Dialog.Par); - VAR props: Properties.StdProp; - BEGIN - props := StdProp(); - IF Properties.style IN props.known THEN - par.checked := (Properties.style IN props.valid) & (Fonts.underline IN props.style.val) - ELSE - par.disabled := TRUE - END - END UnderlineGuard; - - PROCEDURE StrikeoutGuard* (VAR par: Dialog.Par); - VAR props: Properties.StdProp; - BEGIN - props := StdProp(); - IF Properties.style IN props.known THEN - par.checked := (Properties.style IN props.valid) & (Fonts.strikeout IN props.style.val) - ELSE - par.disabled := TRUE - END - END StrikeoutGuard; - - PROCEDURE SizeGuard* (size: INTEGER; VAR par: Dialog.Par); - VAR props: Properties.StdProp; - BEGIN - props := StdProp(); - IF Properties.size IN props.known THEN - par.checked := (Properties.size IN props.valid) & (size = props.size DIV Ports.point) - ELSE - par.disabled := TRUE - END - END SizeGuard; - - PROCEDURE ColorGuard* (color: INTEGER; VAR par: Dialog.Par); - VAR props: Properties.StdProp; - BEGIN - props := StdProp(); - IF Properties.color IN props.known THEN - par.checked := (Properties.color IN props.valid) & (color = props.color.val) - ELSE - par.disabled := TRUE - END - END ColorGuard; - - PROCEDURE DefaultFontGuard* (VAR par: Dialog.Par); - VAR props: Properties.StdProp; - BEGIN - props := StdProp(); - IF Properties.typeface IN props.known THEN - par.checked := (Properties.typeface IN props.valid) & (props.typeface = Fonts.default) - ELSE - par.disabled := TRUE - END - END DefaultFontGuard; - - PROCEDURE TypefaceGuard* (VAR par: Dialog.Par); - VAR props: Properties.StdProp; - BEGIN - props := StdProp(); - IF ~(Properties.typeface IN props.known) THEN par.disabled := TRUE END - END TypefaceGuard; - - - (* standard notifiers *) - - PROCEDURE DefaultOnDoubleClick* (op, from, to: INTEGER); - VAR msg: Controllers.EditMsg; c: Containers.Controller; - BEGIN - IF (op = Dialog.pressed) & (from = 1) THEN - Controllers.SetCurrentPath(Controllers.frontPath); - c := Containers.Focus(); - Controllers.ResetCurrentPath; - IF {Containers.noSelection, Containers.noCaret} - c.opts = {} THEN - msg.op := Controllers.pasteChar; - msg.char := 0DX; msg.modifiers := {}; - Controllers.ForwardVia(Controllers.frontPath, msg) - END - END - END DefaultOnDoubleClick; - - - PROCEDURE Init; - BEGIN - allocator := defaultAllocator; - propEra := -1 - END Init; - -BEGIN - Init -END StdCmds. diff --git a/new/Std/Mod/Coder.txt b/new/Std/Mod/Coder.txt deleted file mode 100644 index 2e25873..0000000 --- a/new/Std/Mod/Coder.txt +++ /dev/null @@ -1,682 +0,0 @@ -MODULE StdCoder; - - (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/Coder.odc *) - (* DO NOT EDIT *) - - IMPORT - Kernel, Files, Converters, Stores, Views, Controllers, Dialog, Documents, Windows, - TextModels, TextViews, TextControllers, TextMappers, - StdCmds; - - CONST - N = 16384; - LineLength = 74; - OldVersion = 0; ThisVersion = 1; - Tag = "StdCoder.Decode"; (* first letter of Tag must not to appear within Tag again *) - Separator = "/"; - View = 1; File = 2; List = 3; - - TYPE - FileList = POINTER TO RECORD - next: FileList; - file: Files.File; - type: Files.Type; - name:Dialog.String - END; - - ParList* = RECORD - list*: Dialog.Selection; - storeAs*: Dialog.String; - files: FileList - END; - - VAR - par*: ParList; - code: ARRAY 64 OF CHAR; - revCode: ARRAY 256 OF BYTE; - table: ARRAY N OF BYTE; - stdDocuType: Files.Type; - - PROCEDURE NofSelections(IN list: Dialog.Selection): INTEGER; - VAR i, n: INTEGER; - BEGIN - i := 0; n := 0; - WHILE i # list.len DO - IF list.In(i) THEN INC(n) END; - INC(i) - END; - RETURN n - END NofSelections; - - PROCEDURE ShowError(n: INTEGER; par: ARRAY OF CHAR); - BEGIN - Dialog.Beep; - CASE n OF - 1: Dialog.ShowParamMsg("#Std:bad characters", par, "", "") - | 2: Dialog.ShowParamMsg("#Std:checksum error", par, "", "") - | 3: Dialog.ShowParamMsg("#Std:incompatible version", par, "", "") - | 4: Dialog.ShowParamMsg("#Std:filing error", par, "", "") - | 5: Dialog.ShowParamMsg("#Std:directory ^0 not found", par, "", "") - | 6: Dialog.ShowParamMsg("#Std:file ^0 not found", par, "", "") - | 7: Dialog.ShowParamMsg("#Std:illegal path", par, "", "") - | 8: Dialog.ShowParamMsg("#Std:no tag", par, "", "") - | 9: Dialog.ShowParamMsg("#Std:disk write protected", par, "", "") - | 10: Dialog.ShowParamMsg("#Std:io error", par, "", "") - END - END ShowError; - - PROCEDURE ShowSizeMsg(x: INTEGER); - VAR i, j: INTEGER; ch: CHAR; s: ARRAY 20 OF CHAR; - BEGIN - ASSERT(x >= 0, 20); - i := 0; - REPEAT s[i] := CHR(ORD("0") + x MOD 10); INC(i); x := x DIV 10 UNTIL x = 0; - s[i] := 0X; - DEC(i); j := 0; - WHILE j < i DO ch := s[j]; s[j] := s[i]; s[i] := ch; INC(j); DEC(i) END; - Dialog.ShowParamStatus("#Std:^0 characters coded", s, "", "") - END ShowSizeMsg; - - PROCEDURE Write(dest: TextModels.Writer; x: INTEGER; VAR n: INTEGER); - BEGIN - dest.WriteChar(code[x]); INC(n); - IF n = LineLength THEN dest.WriteChar(0DX); dest.WriteChar(" "); n := 0 END - END Write; - - PROCEDURE WriteHeader(dest: TextModels.Writer; VAR n: INTEGER; - name: ARRAY OF CHAR; type: BYTE - ); - VAR byte, bit, i: INTEGER; ch: CHAR; tag: ARRAY 16 OF CHAR; - BEGIN - tag := Tag; i := 0; ch := tag[0]; - WHILE ch # 0X DO dest.WriteChar(ch); INC(n); INC(i); ch := tag[i] END; - dest.WriteChar(" "); INC(n); - bit := 0; byte := 0; i := 0; - REPEAT - ch := name[i]; INC(byte, ASH(ORD(ch), bit)); INC(bit, 8); - WHILE bit >= 6 DO Write(dest, byte MOD 64, n); byte := byte DIV 64; DEC(bit, 6) END; - INC(i) - UNTIL ch = 0X; - IF bit # 0 THEN Write(dest, byte, n) END; - Write(dest, ThisVersion, n); Write(dest, type, n) - END WriteHeader; - - PROCEDURE WriteFileType(dest: TextModels.Writer; VAR n: INTEGER; t: Files.Type); - VAR byte, bit, i: INTEGER; ch: CHAR; - BEGIN - IF t = Kernel.docType THEN t := stdDocuType END; - bit := 0; byte := 0; i := 0; dest.WriteChar(" "); - REPEAT - ch := t[i]; INC(byte, ASH(ORD(ch), bit)); INC(bit, 8); - WHILE bit >= 6 DO Write(dest, byte MOD 64, n); byte := byte DIV 64; DEC(bit, 6) END; - INC(i) - UNTIL ch = 0X; - IF bit # 0 THEN Write(dest, byte, n) END - END WriteFileType; - - PROCEDURE WriteFile(dest: TextModels.Writer; VAR n: INTEGER; f: Files.File); - VAR hash, byte, bit, i, j, sum, len: INTEGER; src: Files.Reader; b: BYTE; - BEGIN - len := f.Length(); j := len; i := 6; - WHILE i # 0 DO Write(dest, j MOD 64, n); j := j DIV 64; DEC(i) END; - i := 0; - REPEAT table[i] := 0; INC(i) UNTIL i = N; - hash := 0; bit := 0; byte := 0; sum := 0; src := f.NewReader(NIL); - WHILE len # 0 DO - src.ReadByte(b); DEC(len); - sum := (sum + b MOD 256) MOD (16 * 1024); - IF table[hash] = b THEN INC(bit) (* 0 bit for correct prediction *) - ELSE (* Incorrect prediction -> 1'xxxx'xxxx bits *) - table[hash] := b; INC(byte, ASH(1, bit)); INC(bit); - INC(byte, ASH(b MOD 256, bit)); INC(bit, 8) - END; - WHILE bit >= 6 DO Write(dest, byte MOD 64, n); byte := byte DIV 64; DEC(bit, 6) END; - hash := (16 * hash + b MOD 256) MOD N - END; - IF bit # 0 THEN Write(dest, byte, n) END; - i := 6; - WHILE i # 0 DO Write(dest, sum MOD 64, n); sum := sum DIV 64; DEC(i) END; - IF n # 0 THEN dest.WriteChar(0DX); n := 0 END - END WriteFile; - - PROCEDURE Read(src: TextModels.Reader; VAR x: INTEGER; VAR res: INTEGER); - VAR ch: CHAR; - BEGIN - IF res = 0 THEN - REPEAT src.ReadChar(ch); x := revCode[ORD(ch)] UNTIL (x >= 0) OR src.eot; - IF src.eot THEN res := 1 END - END; - IF res # 0 THEN x := 0 END - END Read; - - PROCEDURE ReadHeader(src: TextModels.Reader; VAR res: INTEGER; - VAR name: ARRAY OF CHAR; VAR type: BYTE - ); - VAR x, bit, i, j: INTEGER; ch: CHAR; tag: ARRAY 16 OF CHAR; - BEGIN - tag := Tag; i := 0; - WHILE ~src.eot & (tag[i] # 0X) DO - src.ReadChar(ch); - IF ch = tag[i] THEN INC(i) ELSIF ch = tag[0] THEN i := 1 ELSE i := 0 END - END; - IF ~src.eot THEN - res := 0; i := 0; bit := 0; x := 0; - REPEAT - WHILE (res = 0) & (bit < 8) DO Read(src, j, res); INC(x, ASH(j, bit)); INC(bit, 6) END; - IF res = 0 THEN - ch := CHR(x MOD 256); x := x DIV 256; DEC(bit, 8); name[i] := ch; INC(i) - END - UNTIL (res # 0) OR (ch = 0X); - Read(src, j, res); - IF res = 0 THEN - IF (j = ThisVersion) OR (j = OldVersion) THEN - Read(src, j, res); type := SHORT(SHORT(j)) - ELSE res := 3 - END - END - ELSE res := 8 - END - END ReadHeader; - - PROCEDURE ReadFileType(src: TextModels.Reader; VAR res: INTEGER; VAR ftype: Files.Type); - VAR x, bit, i, j: INTEGER; ch: CHAR; - BEGIN - res := 0; i := 0; bit := 0; x := 0; - REPEAT - WHILE (res = 0) & (bit < 8) DO Read(src, j, res); INC(x, ASH(j, bit)); INC(bit, 6) END; - IF res = 0 THEN ch := CHR(x MOD 256); x := x DIV 256; DEC(bit, 8); ftype[i] := ch; INC(i) END - UNTIL (res # 0) OR (ch = 0X); - IF ftype = stdDocuType THEN ftype := Kernel.docType END - END ReadFileType; - - PROCEDURE ReadFile(src: TextModels.Reader; VAR res: INTEGER; f: Files.File); - VAR hash, x, bit, i, j, len, sum, s: INTEGER; byte: BYTE; dest: Files.Writer; - BEGIN - res := 0; i := 0; len := 0; - REPEAT Read(src, x, res); len := len + ASH(x, 6 * i); INC(i) UNTIL (res # 0) OR (i = 6); - i := 0; - REPEAT table[i] := 0; INC(i) UNTIL i = N; - bit := 0; hash := 0; sum := 0; dest := f.NewWriter(NIL); - WHILE (res = 0) & (len # 0) DO - IF bit = 0 THEN Read(src, x, res); bit := 6 END; - IF ODD(x) THEN (* Incorrect prediction -> 1'xxxx'xxxx *) - x := x DIV 2; DEC(bit); - WHILE (res = 0) & (bit < 8) DO Read(src, j, res); INC(x, ASH(j, bit)); INC(bit, 6) END; - i := x MOD 256; - IF i > MAX(BYTE) THEN i := i - 256 END; - byte := SHORT(SHORT(i)); x := x DIV 256; DEC(bit, 8); - table[hash] := byte - ELSE byte := table[hash]; x := x DIV 2; DEC(bit) (* correct prediction *) - END; - hash := (16 * hash + byte MOD 256) MOD N; - dest.WriteByte(byte); sum := (sum + byte MOD 256) MOD (16 * 1024); DEC(len) - END; - IF res = 0 THEN - i := 0; s := 0; - REPEAT Read(src, x, res); s := s + ASH(x, 6 * i); INC(i) UNTIL (res # 0) OR (i = 6); - IF (res = 0) & (s # sum) THEN res := 2 END - END - END ReadFile; - - PROCEDURE ShowText (t: TextModels.Model); - VAR l: INTEGER; v: Views.View; wr: TextMappers.Formatter; conv: Converters.Converter; - BEGIN - l := t.Length(); - wr.ConnectTo(t); wr.SetPos(l); wr.WriteString(" --- end of encoding ---"); - ShowSizeMsg(l); - v := TextViews.dir.New(t); - conv := Converters.list; - WHILE (conv # NIL) & (conv.imp # "HostTextConv.ImportText") DO conv := conv.next END; - Views.Open(v, NIL, "", conv); - Views.SetDirty(v) - END ShowText; - - PROCEDURE EncodedView*(v: Views.View): TextModels.Model; - VAR n: INTEGER; f: Files.File; wrs: Stores.Writer; t: TextModels.Model; wr: TextModels.Writer; - BEGIN - f := Files.dir.Temp(); wrs.ConnectTo(f); Views.WriteView(wrs, v); - t := TextModels.dir.New(); wr := t.NewWriter(NIL); - n := 0; WriteHeader(wr, n, "", View); WriteFileType(wr, n, f.type); WriteFile(wr, n, f); - RETURN t - END EncodedView; - - PROCEDURE EncodeDocument*; - VAR v: Views.View; w: Windows.Window; - BEGIN - w := Windows.dir.First(); - IF w # NIL THEN - v := w.doc.OriginalView(); - IF (v.context # NIL) & (v.context IS Documents.Context) THEN - v := v.context(Documents.Context).ThisDoc() - END; - IF v # NIL THEN ShowText(EncodedView(v)) END - END - END EncodeDocument; - - PROCEDURE EncodeFocus*; - VAR v: Views.View; - BEGIN - v := Controllers.FocusView(); - IF v # NIL THEN ShowText(EncodedView(v)) END - END EncodeFocus; - - PROCEDURE EncodeSelection*; - VAR beg, end: INTEGER; t: TextModels.Model; c: TextControllers.Controller; - BEGIN - c := TextControllers.Focus(); - IF (c # NIL) & c.HasSelection() THEN - c.GetSelection(beg, end); - t := TextModels.CloneOf(c.text); t.InsertCopy(0, c.text, beg, end); - ShowText(EncodedView(TextViews.dir.New(t))) - END - END EncodeSelection; - - PROCEDURE EncodeFile*; - VAR n: INTEGER; loc: Files.Locator; name: Files.Name; f: Files.File; - t: TextModels.Model; wr: TextModels.Writer; - BEGIN - Dialog.GetIntSpec("", loc, name); - IF loc # NIL THEN - f := Files.dir.Old(loc, name, TRUE); - IF f # NIL THEN - t := TextModels.dir.New(); wr := t.NewWriter(NIL); - n := 0; WriteHeader(wr, n, name, File); WriteFileType(wr, n, f.type); WriteFile(wr, n, f); - ShowText(t) - END - END - END EncodeFile; - - PROCEDURE GetFile(VAR path: ARRAY OF CHAR; VAR loc: Files.Locator; VAR name: Files.Name); - VAR i, j: INTEGER; ch: CHAR; - BEGIN - i := 0; ch := path[0]; loc := Files.dir.This(""); - WHILE (ch # 0X) & (loc # NIL) DO - j := 0; - WHILE (ch # 0X) & (ch # Separator) DO name[j] := ch; INC(j); INC(i); ch := path[i] END; - name[j] := 0X; - IF ch = Separator THEN loc := loc.This(name); INC(i); ch := path[i] END; - IF loc.res # 0 THEN loc := NIL END - END; - path[i] := 0X - END GetFile; - - PROCEDURE ReadPath(rd: TextModels.Reader; VAR path: ARRAY OF CHAR; VAR len: INTEGER); - VAR i, l: INTEGER; ch: CHAR; - BEGIN - i := 0; l := LEN(path) - 1; - REPEAT rd.ReadChar(ch) UNTIL rd.eot OR (ch > " "); - WHILE ~rd.eot & (ch > " ") & (i < l) DO path[i] := ch; INC(i); rd.ReadChar(ch) END; - path[i] := 0X; len := i - END ReadPath; - - PROCEDURE WriteString(w: Files.Writer; IN str: ARRAY OF CHAR; len: INTEGER); - VAR i: INTEGER; - BEGIN - i := 0; - WHILE i < len DO - IF ORD(str[i]) > MAX(BYTE) THEN w.WriteByte(SHORT(SHORT(ORD(str[i]) - 256))) - ELSE w.WriteByte(SHORT(SHORT(ORD(str[i])))) - END; - INC(i) - END - END WriteString; - - PROCEDURE EncodeFileList*; - TYPE - FileList = POINTER TO RECORD - next: FileList; - f: Files.File - END; - VAR - beg, end, i, j, n: INTEGER; err: BOOLEAN; - files, last: FileList; - list, f: Files.File; w: Files.Writer; loc: Files.Locator; - rd: TextModels.Reader; wr: TextModels.Writer; t: TextModels.Model; - c: TextControllers.Controller; - name: Files.Name; path, next: ARRAY 2048 OF CHAR; - BEGIN - c := TextControllers.Focus(); - IF (c # NIL) & c.HasSelection() THEN c.GetSelection(beg, end); - rd := c.text.NewReader(NIL); rd.SetPos(beg); err := FALSE; - list := Files.dir.Temp(); w := list.NewWriter(NIL); files := NIL; last := NIL; - ReadPath(rd, path, i); - WHILE (path # "") & (rd.Pos() - i < end) & ~err DO - GetFile(path, loc, name); - IF loc # NIL THEN - f := Files.dir.Old(loc, name, TRUE); err := f = NIL; - IF ~err THEN - IF last = NIL THEN NEW(last); files := last ELSE NEW(last.next); last := last.next END; - last.f := f; - ReadPath(rd, next, j); - IF (next = "=>") & (rd.Pos() - j < end) THEN - ReadPath(rd, next, j); - IF next # "" THEN WriteString(w, next, j + 1); ReadPath(rd, next, j) - ELSE err := TRUE - END - ELSE WriteString(w, path, i + 1) - END; - path := next; i := j - END - ELSE err := TRUE - END - END; - IF ~err & (files # NIL) THEN - t := TextModels.dir.New(); wr := t.NewWriter(NIL); - n := 0; WriteHeader(wr, n, "", List); - WriteFileType(wr, n, list.type); WriteFile(wr, n, list); - WHILE files # NIL DO - WriteFileType(wr, n, files.f.type); WriteFile(wr, n, files.f); files := files.next - END; - ShowText(t) - ELSIF err THEN - IF path = "" THEN ShowError(7, path) - ELSIF loc # NIL THEN ShowError(6, path) - ELSE ShowError(5, path) - END - END - END - END EncodeFileList; - - PROCEDURE DecodeView(rd: TextModels.Reader; name: Files.Name); - VAR res: INTEGER; f: Files.File; ftype: Files.Type; rds: Stores.Reader; v: Views.View; - BEGIN - ReadFileType(rd, res, ftype); - IF res = 0 THEN - f := Files.dir.Temp(); ReadFile(rd, res, f); - IF res = 0 THEN - rds.ConnectTo(f); Views.ReadView(rds, v); Views.Open(v, NIL, name, NIL); - Views.SetDirty(v) - ELSE ShowError(res, "") - END - ELSE ShowError(res, "") - END - END DecodeView; - - PROCEDURE DecodeFile(rd: TextModels.Reader; name: Files.Name); - VAR res: INTEGER; ftype: Files.Type; loc: Files.Locator; f: Files.File; - BEGIN - ReadFileType(rd, res, ftype); - IF res = 0 THEN - Dialog.GetExtSpec(name, ftype, loc, name); - IF loc # NIL THEN - f := Files.dir.New(loc, Files.ask); - IF f # NIL THEN - ReadFile(rd, res, f); - IF res = 0 THEN - f.Register(name, ftype, Files.ask, res); - IF res # 0 THEN ShowError(4, "") END - ELSE ShowError(res, "") - END - ELSIF loc.res = 4 THEN ShowError(9, "") - ELSIF loc.res = 5 THEN ShowError(10, "") - END - END - ELSE ShowError(res, "") - END - END DecodeFile; - - PROCEDURE DecodeFileList (rd: TextModels.Reader; VAR files: FileList; VAR len, res: INTEGER); - VAR i, n: INTEGER; b: BYTE; p: FileList; - ftype: Files.Type; f: Files.File; frd: Files.Reader; path: Dialog.String; - BEGIN - ReadFileType(rd, res, ftype); - IF res = 0 THEN - f := Files.dir.Temp(); ReadFile(rd, res, f); - IF res = 0 THEN - files := NIL; p := NIL; n := 0; - frd := f.NewReader(NIL); frd.ReadByte(b); - WHILE ~frd.eof & (res = 0) DO - INC(n); i := 0; - WHILE ~frd.eof & (b # 0) DO path[i] := CHR(b MOD 256); INC(i); frd.ReadByte(b) END; - IF (i > 4) & (path[i - 4] = ".") & (CAP(path[i - 3]) = "O") - & (CAP(path[i - 2]) = "D") & (CAP(path[i - 1]) = "C") - THEN path[i - 4] := 0X - ELSE path[i] := 0X - END; - IF ~frd.eof THEN - IF p = NIL THEN NEW(p); files := p ELSE NEW(p.next); p := p.next END; - p.name := path; - frd.ReadByte(b) - ELSE res := 1 - END - END; - p := files; len := n; - WHILE (res = 0) & (p # NIL) DO - ReadFileType(rd, res, p.type); - IF res = 0 THEN p.file := Files.dir.Temp(); ReadFile(rd, res, p.file) END; - p := p.next - END - END - END - END DecodeFileList; - - PROCEDURE OpenDialog(files: FileList; len: INTEGER); - VAR i: INTEGER; p: FileList; - BEGIN - par.files := files; par.list.SetLen(len); - p := files; i := 0; - WHILE p # NIL DO par.list.SetItem(i, p.name); INC(i); p := p.next END; - par.storeAs := ""; - Dialog.Update(par); Dialog.UpdateList(par.list); - StdCmds.OpenAuxDialog("Std/Rsrc/Coder", "Decode") - END OpenDialog; - - PROCEDURE CloseDialog*; - BEGIN - par.files := NIL; par.list.SetLen(0); par.storeAs := ""; - Dialog.UpdateList(par.list); Dialog.Update(par) - END CloseDialog; - - PROCEDURE Select*(op, from, to: INTEGER); - VAR p: FileList; i: INTEGER; - BEGIN - IF (op = Dialog.included) OR (op = Dialog.excluded) OR (op = Dialog.set) THEN - IF NofSelections(par.list) = 1 THEN - i := 0; p := par.files; - WHILE ~par.list.In(i) DO INC(i); p := p.next END; - par.storeAs := p.name - ELSE par.storeAs := "" - END; - Dialog.Update(par) - END - END Select; - - PROCEDURE CopyFile(from: Files.File; loc: Files.Locator; name: Files.Name; type: Files.Type); - CONST BufSize = 4096; - VAR res, k, l: INTEGER; f: Files.File; r: Files.Reader; w: Files.Writer; - buf: ARRAY BufSize OF BYTE; - BEGIN - f := Files.dir.New(loc, Files.ask); - IF f # NIL THEN - r := from.NewReader(NIL); w := f.NewWriter(NIL); l := from.Length(); - WHILE l # 0 DO - IF l <= BufSize THEN k := l ELSE k := BufSize END; - r.ReadBytes(buf, 0, k); w.WriteBytes(buf, 0, k); - l := l - k - END; - f.Register(name, type, Files.ask, res); - IF res # 0 THEN ShowError(4, "") END - ELSIF loc.res = 4 THEN ShowError(9, "") - ELSIF loc.res = 5 THEN ShowError(10, "") - END - END CopyFile; - - PROCEDURE StoreSelection*; - VAR i, n: INTEGER; p: FileList; loc: Files.Locator; name: Files.Name; - BEGIN - n := NofSelections(par.list); - IF n > 1 THEN - i := 0; p := par.files; - WHILE n # 0 DO - WHILE ~par.list.In(i) DO INC(i); p := p.next END; - GetFile(p.name, loc, name); CopyFile(p.file, loc, name, p.type); - DEC(n); INC(i); p := p.next - END - ELSIF (n = 1) & (par.storeAs # "") THEN - i := 0; p := par.files; - WHILE ~par.list.In(i) DO INC(i); p := p.next END; - GetFile(par.storeAs, loc, name); CopyFile(p.file, loc, name, p.type) - END - END StoreSelection; - - PROCEDURE StoreSelectionGuard*(VAR p: Dialog.Par); - VAR n: INTEGER; - BEGIN - n := NofSelections(par.list); - p.disabled := (n = 0) OR ((n = 1) & (par.storeAs = "")) - END StoreSelectionGuard; - - PROCEDURE StoreSingle*; - VAR i: INTEGER; p: FileList; loc: Files.Locator; name: Files.Name; - BEGIN - IF NofSelections(par.list) = 1 THEN - i := 0; p := par.files; - WHILE ~par.list.In(i) DO INC(i); p := p.next END; - GetFile(p.name, loc, name); - Dialog.GetExtSpec(name, p.type, loc, name); - IF loc # NIL THEN CopyFile(p.file, loc, name, p.type) END - END - END StoreSingle; - - PROCEDURE StoreSingleGuard*(VAR p: Dialog.Par); - BEGIN - p.disabled := NofSelections(par.list) # 1 - END StoreSingleGuard; - - PROCEDURE StoreAllFiles(files: FileList); - VAR loc: Files.Locator; name: Files.Name; - BEGIN - WHILE files # NIL DO - GetFile(files.name, loc, name); CopyFile(files.file, loc, name, files.type); files := files.next - END - END StoreAllFiles; - - PROCEDURE StoreAll*; - BEGIN - StoreAllFiles(par.files) - END StoreAll; - - PROCEDURE DecodeAllFromText*(text: TextModels.Model; beg: INTEGER; ask: BOOLEAN); - VAR res, i: INTEGER; type: BYTE; name: Files.Name; rd: TextModels.Reader; files: FileList; - BEGIN - CloseDialog; - rd := text.NewReader(NIL); rd.SetPos(beg); - ReadHeader(rd, res, name, type); - i := 0; - WHILE name[i] # 0X DO INC(i) END; - IF (i > 4) & (name[i - 4] = ".") & (CAP(name[i - 3]) = "O") - & (CAP(name[i - 2]) = "D") & (CAP(name[i - 1]) = "C") - THEN name[i - 4] := 0X - END; - IF res = 0 THEN - IF type = View THEN DecodeView(rd, name) - ELSIF type = File THEN DecodeFile(rd, name) - ELSIF type = List THEN - DecodeFileList(rd, files, i, res); - IF res = 0 THEN - IF ask THEN OpenDialog(files, i) ELSE StoreAllFiles(files) END - ELSE ShowError(res, "") - END - ELSE ShowError(3, "") - END - ELSE ShowError(res, "") - END - END DecodeAllFromText; - - PROCEDURE Decode*; - VAR beg, end: INTEGER; c: TextControllers.Controller; - BEGIN - CloseDialog; - c := TextControllers.Focus(); - IF c # NIL THEN - IF c.HasSelection() THEN c.GetSelection(beg, end) ELSE beg := 0 END; - DecodeAllFromText(c.text, beg, TRUE) - END - END Decode; - - PROCEDURE ListFiles(rd: TextModels.Reader; VAR wr: TextMappers.Formatter); - VAR i, n, res: INTEGER; b: BYTE; - ftype: Files.Type; f: Files.File; frd: Files.Reader; path: Dialog.String; - BEGIN - ReadFileType(rd, res, ftype); - IF res = 0 THEN - f := Files.dir.Temp(); ReadFile(rd, res, f); - IF res = 0 THEN - n := 0; - frd := f.NewReader(NIL); frd.ReadByte(b); - WHILE ~frd.eof & (res = 0) DO - INC(n); i := 0; - WHILE ~frd.eof & (b # 0) DO path[i] := CHR(b MOD 256); INC(i); frd.ReadByte(b) END; - IF (i > 4) & (path[i - 4] = ".") & (CAP(path[i - 3]) = "O") - & (CAP(path[i - 2]) = "D") & (CAP(path[i - 1]) = "C") - THEN path[i - 4] := 0X - ELSE path[i] := 0X - END; - IF ~frd.eof THEN wr.WriteString(path); wr.WriteLn; frd.ReadByte(b) ELSE res := 1 END - END - ELSE ShowError(res, "") - END - ELSE ShowError(res, "") - END - END ListFiles; - - PROCEDURE ListSingleton(type, name: ARRAY OF CHAR; VAR wr: TextMappers.Formatter); - BEGIN - wr.WriteString(type); - IF name # "" THEN wr.WriteString(": '"); wr.WriteString(name); wr.WriteChar("'") END; - wr.WriteLn - END ListSingleton; - - PROCEDURE EncodedInText*(text: TextModels.Model; beg: INTEGER): TextModels.Model; - VAR res, i: INTEGER; type: BYTE; name: Files.Name; - rd: TextModels.Reader; report: TextModels.Model; wr: TextMappers.Formatter; - BEGIN - report := TextModels.dir.New(); wr.ConnectTo(report); - rd := text.NewReader(NIL); rd.SetPos(beg); - ReadHeader(rd, res, name, type); - i := 0; - WHILE name[i] # 0X DO INC(i) END; - IF (i > 4) & (name[i - 4] = ".") & (CAP(name[i - 3]) = "O") - & (CAP(name[i - 2]) = "D") & (CAP(name[i - 1]) = "C") - THEN name[i - 4] := 0X - END; - IF res = 0 THEN - IF type = View THEN ListSingleton("View", name, wr) - ELSIF type = File THEN ListSingleton("File", name, wr) - ELSIF type = List THEN ListFiles(rd, wr) - ELSE ShowError(3, "") - END - ELSE ShowError(res, "") - END; - RETURN report - END EncodedInText; - - PROCEDURE ListEncodedMaterial*; - VAR beg, end: INTEGER; c: TextControllers.Controller; - BEGIN - c := TextControllers.Focus(); - IF c # NIL THEN - IF c.HasSelection() THEN c.GetSelection(beg, end) ELSE beg := 0 END; - Views.OpenView(TextViews.dir.New(EncodedInText(c.text, beg))) - END - END ListEncodedMaterial; - - PROCEDURE InitCodes; - VAR i: BYTE; j: INTEGER; - BEGIN - j := 0; - WHILE j # 256 DO revCode[j] := -1; INC(j) END; - code[0] := "."; revCode[ORD(".")] := 0; code[1] := ","; revCode[ORD(",")] := 1; - i := 2; j := ORD("0"); - WHILE j <= ORD("9") DO code[i] := CHR(j); revCode[j] := i; INC(i); INC(j) END; - j := ORD("A"); - WHILE j <= ORD("Z") DO code[i] := CHR(j); revCode[j] := i; INC(i); INC(j) END; - j := ORD("a"); - WHILE j <= ORD("z") DO code[i] := CHR(j); revCode[j] := i; INC(i); INC(j) END; - ASSERT(i = 64, 60) - END InitCodes; - -BEGIN - InitCodes; - stdDocuType[0] := 3X; stdDocuType[1] := 3X; stdDocuType[2] := 3X; stdDocuType[3] := 0X -END StdCoder. diff --git a/new/Std/Mod/Debug.txt b/new/Std/Mod/Debug.txt deleted file mode 100644 index 8583d7d..0000000 --- a/new/Std/Mod/Debug.txt +++ /dev/null @@ -1,621 +0,0 @@ -MODULE StdDebug; - - (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/Debug.odc *) - (* DO NOT EDIT *) - - IMPORT SYSTEM, - Kernel, Strings, Fonts, Services, Ports, Views, Properties, Dialog, Containers, StdFolds, - TextModels, TextMappers, TextViews, TextRulers; - - CONST - refViewSize = 9 * Ports.point; - - heap = 1; source = 2; module = 3; modules = 4; (* RefView types *) - - TYPE - Name = Kernel.Name; - - ArrayPtr = POINTER TO RECORD - last, t, first: INTEGER; (* gc header *) - len: ARRAY 16 OF INTEGER (* dynamic array length table *) - END; - - RefView = POINTER TO RefViewDesc; - - RefViewDesc = RECORD - type: SHORTINT; - command: SHORTINT; - back: RefView; - adr: INTEGER; - desc: Kernel.Type; - ptr: ArrayPtr; - name: Name - END; - - Action = POINTER TO RECORD (Services.Action) - text: TextModels.Model - END; - - Cluster = POINTER TO RECORD [untagged] (* must correspond to Kernel.Cluster *) - size: INTEGER; - next: Cluster - END; - - - VAR - out: TextMappers.Formatter; - path: ARRAY 4 OF Ports.Point; - empty: Name; - - - PROCEDURE NewRuler (): TextRulers.Ruler; - CONST mm = Ports.mm; - VAR r: TextRulers.Ruler; - BEGIN - r := TextRulers.dir.New(NIL); - TextRulers.SetRight(r, 140 * mm); - TextRulers.AddTab(r, 4 * mm); TextRulers.AddTab(r, 34 * mm); TextRulers.AddTab(r, 80 * mm); - RETURN r - END NewRuler; - - PROCEDURE OpenViewer (t: TextModels.Model; title: Views.Title; ruler:TextRulers.Ruler); - VAR v: TextViews.View; c: Containers.Controller; - BEGIN - Dialog.MapString(title, title); - v := TextViews.dir.New(t); - v.SetDefaults(ruler, TextViews.dir.defAttr); - c := v.ThisController(); - IF c # NIL THEN - c.SetOpts(c.opts - {Containers.noFocus, Containers.noSelection} + {Containers.noCaret}) - END; - Views.OpenAux(v, title) - END OpenViewer; - - PROCEDURE OpenFold (hidden: ARRAY OF CHAR); - VAR fold: StdFolds.Fold; t: TextModels.Model; w: TextMappers.Formatter; - BEGIN - Dialog.MapString(hidden, hidden); - t := TextModels.dir.New(); - w.ConnectTo(t); w.WriteString(hidden); - fold := StdFolds.dir.New(StdFolds.expanded, "", t); - out.WriteView(fold) - END OpenFold; - - PROCEDURE CloseFold (collaps: BOOLEAN); - VAR fold: StdFolds.Fold; m: TextModels.Model; - BEGIN - fold := StdFolds.dir.New(StdFolds.expanded, "", NIL); - out.WriteView(fold); - IF collaps THEN fold.Flip(); m := out.rider.Base(); out.SetPos(m.Length()) END - END CloseFold; - - PROCEDURE WriteHex (n: INTEGER); - BEGIN - out.WriteIntForm(n, TextMappers.hexadecimal, 9, "0", TextMappers.showBase) - END WriteHex; - - PROCEDURE WriteString (adr, len, base: INTEGER; zterm, unicode: BOOLEAN); - CONST beg = 0; char = 1; code = 2; - VAR ch: CHAR; sc: SHORTCHAR; val, mode: INTEGER; str: ARRAY 16 OF CHAR; - BEGIN - mode := beg; - IF base = 2 THEN SYSTEM.GET(adr, ch); val := ORD(ch) ELSE SYSTEM.GET(adr, sc); val := ORD(sc) END; - IF zterm & (val = 0) THEN out.WriteSString('""') - ELSE - REPEAT - IF (val >= ORD(" ")) & (val < 7FH) OR (val > 0A0H) & (val < 100H) OR unicode & (val >= 100H) THEN - IF mode # char THEN - IF mode = code THEN out.WriteSString(", ") END; - out.WriteChar(22X); mode := char - END; - out.WriteChar(CHR(val)) - ELSE - IF mode = char THEN out.WriteChar(22X) END; - IF mode # beg THEN out.WriteSString(", ") END; - mode := code; Strings.IntToStringForm(val, Strings.hexadecimal, 1, "0", FALSE, str); - IF str[0] > "9" THEN out.WriteChar("0") END; - out.WriteString(str); out.WriteChar("X") - END; - INC(adr, base); DEC(len); - IF base = 2 THEN SYSTEM.GET(adr, ch); val := ORD(ch) ELSE SYSTEM.GET(adr, sc); val := ORD(sc) END - UNTIL (len = 0) OR zterm & (val = 0) - END; - IF mode = char THEN out.WriteChar(22X) END - END WriteString; - - PROCEDURE OutString (s: ARRAY OF CHAR); - VAR str: Dialog.String; - BEGIN - Dialog.MapString(s, str); - out.WriteString(str) - END OutString; - - (* ------------------- variable display ------------------- *) - - PROCEDURE FormOf (t: Kernel.Type): SHORTCHAR; - BEGIN - IF SYSTEM.VAL(INTEGER, t) DIV 256 = 0 THEN - RETURN SHORT(CHR(SYSTEM.VAL(INTEGER, t))) - ELSE - RETURN SHORT(CHR(16 + t.id MOD 4)) - END - END FormOf; - - PROCEDURE LenOf (t: Kernel.Type; ptr: ArrayPtr): INTEGER; - BEGIN - IF t.size # 0 THEN RETURN t.size - ELSIF ptr # NIL THEN RETURN ptr.len[t.id DIV 16 MOD 16 - 1] - ELSE RETURN 0 - END - END LenOf; - - PROCEDURE SizeOf (t: Kernel.Type; ptr: ArrayPtr): INTEGER; - BEGIN - CASE FormOf(t) OF - | 0BX: RETURN 0 - | 1X, 2X, 4X: RETURN 1 - | 3X, 5X: RETURN 2 - | 8X, 0AX: RETURN 8 - | 11X: RETURN t.size - | 12X: RETURN LenOf(t, ptr) * SizeOf(t.base[0], ptr) - ELSE RETURN 4 - END - END SizeOf; - - PROCEDURE WriteName (t: Kernel.Type; ptr: ArrayPtr); - VAR name: Kernel.Name; f: SHORTCHAR; - BEGIN - f := FormOf(t); - CASE f OF - | 0X: OutString("#Dev:Unknown") - | 1X: out.WriteSString("BOOLEAN") - | 2X: out.WriteSString("SHORTCHAR") - | 3X: out.WriteSString("CHAR") - | 4X: out.WriteSString("BYTE") - | 5X: out.WriteSString("SHORTINT") - | 6X: out.WriteSString("INTEGER") - | 7X: out.WriteSString("SHORTREAL") - | 8X: out.WriteSString("REAL") - | 9X: out.WriteSString("SET") - | 0AX: out.WriteSString("LONGINT") - | 0BX: out.WriteSString("ANYREC") - | 0CX: out.WriteSString("ANYPTR") - | 0DX: out.WriteSString("POINTER") - | 0EX: out.WriteSString("PROCEDURE") - | 0FX: out.WriteSString("STRING") - | 10X..13X: - Kernel.GetTypeName(t, name); - IF name = "!" THEN - IF f = 11X THEN out.WriteSString("RECORD") - ELSIF f = 12X THEN out.WriteSString("ARRAY") - ELSE OutString("#Dev:Unknown") - END - ELSIF (t.id DIV 256 # 0) & (t.mod.refcnt >= 0) THEN - out.WriteSString(t.mod.name); out.WriteChar("."); out.WriteSString(name) - ELSIF f = 11X THEN - out.WriteSString(t.mod.name); out.WriteSString(".RECORD") - ELSIF f = 12X THEN - out.WriteSString("ARRAY "); out.WriteInt(LenOf(t, ptr)); t := t.base[0]; - WHILE (FormOf(t) = 12X) & ((t.id DIV 256 = 0) OR (t.mod.refcnt < 0)) DO - out.WriteSString(", "); out.WriteInt(LenOf(t, ptr)); t := t.base[0] - END; - out.WriteSString(" OF "); WriteName(t, ptr) - ELSIF f = 13X THEN - out.WriteSString("POINTER") - ELSE - out.WriteSString("PROCEDURE") - END - | 20X: out.WriteSString("COM.IUnknown") - | 21X: out.WriteSString("COM.GUID") - | 22X: out.WriteSString("COM.RESULT") - ELSE OutString("#Dev:UnknownFormat"); out.WriteInt(ORD(f)) - END - END WriteName; - - PROCEDURE WriteGuid (a: INTEGER); - - PROCEDURE Hex (a: INTEGER); - VAR x: SHORTCHAR; - BEGIN - SYSTEM.GET(a, x); - out.WriteIntForm(ORD(x), TextMappers.hexadecimal, 2, "0", FALSE) - END Hex; - - BEGIN - out.WriteChar("{"); - Hex(a + 3); Hex(a + 2); Hex(a + 1); Hex(a); - out.WriteChar("-"); - Hex(a + 5); Hex(a + 4); - out.WriteChar("-"); - Hex(a + 7); Hex(a + 6); - out.WriteChar("-"); - Hex(a + 8); - Hex(a + 9); - out.WriteChar("-"); - Hex(a + 10); - Hex(a + 11); - Hex(a + 12); - Hex(a + 13); - Hex(a + 14); - Hex(a + 15); - out.WriteChar("}") - END WriteGuid; - - PROCEDURE^ ShowVar (ad, ind: INTEGER; f, c: SHORTCHAR; desc: Kernel.Type; ptr: ArrayPtr; - back: RefView; VAR name, sel: Name); - - PROCEDURE ShowRecord (a, ind: INTEGER; desc: Kernel.Type; back: RefView; VAR sel: Name); - VAR dir: Kernel.Directory; obj: Kernel.Object; name: Kernel.Name; i, j, n: INTEGER; base: Kernel.Type; - BEGIN - WriteName(desc, NIL); out.WriteTab; - IF desc.mod.refcnt >= 0 THEN - OpenFold("#Dev:Fields"); - n := desc.id DIV 16 MOD 16; j := 0; - WHILE j <= n DO - base := desc.base[j]; - IF base # NIL THEN - dir := base.fields; i := 0; - WHILE i < dir.num DO - obj := SYSTEM.VAL(Kernel.Object, SYSTEM.ADR(dir.obj[i])); - Kernel.GetObjName(base.mod, obj, name); - ShowVar(a + obj.offs, ind, FormOf(obj.struct), 1X, obj.struct, NIL, back, name, sel); - INC(i) - END - END; - INC(j) - END; - out.WriteSString(" "); CloseFold((ind > 1) OR (sel # "")) - ELSE - OutString("#Dev:Unloaded") - END - END ShowRecord; - - PROCEDURE ShowArray (a, ind: INTEGER; desc: Kernel.Type; ptr: ArrayPtr; back: RefView; VAR sel: Name); - VAR f: SHORTCHAR; i, n, m, size, len: INTEGER; name: Kernel.Name; eltyp, t: Kernel.Type; - vi: SHORTINT; vs: BYTE; str: Dialog.String; high: BOOLEAN; - BEGIN - WriteName(desc, ptr); out.WriteTab; - len := LenOf(desc, ptr); eltyp := desc.base[0]; f := FormOf(eltyp); size := SizeOf(eltyp, ptr); - IF (f = 2X) OR (f = 3X) THEN (* string *) - n := 0; m := len; high := FALSE; - IF f = 2X THEN - REPEAT SYSTEM.GET(a + n, vs); INC(n) UNTIL (n = 32) OR (n = len) OR (vs = 0); - REPEAT DEC(m); SYSTEM.GET(a + m, vs) UNTIL (m = 0) OR (vs # 0) - ELSE - REPEAT - SYSTEM.GET(a + n * 2, vi); INC(n); - IF vi DIV 256 # 0 THEN high := TRUE END - UNTIL (n = len) OR (vi = 0); - n := MIN(n, 32); - REPEAT DEC(m); SYSTEM.GET(a + m * 2, vi) UNTIL (m = 0) OR (vi # 0) - END; - WriteString(a, n, size, TRUE, TRUE); - INC(m, 2); - IF m > len THEN m := len END; - IF high OR (m > n) THEN - out.WriteSString(" "); OpenFold("..."); - out.WriteLn; - IF high & (n = 32) THEN - WriteString(a, m, size, TRUE, TRUE); - out.WriteLn; out.WriteLn - END; - WriteString(a, m, size, FALSE, FALSE); - IF m < len THEN out.WriteSString(", ..., 0X") END; - out.WriteSString(" "); CloseFold(TRUE) - END - ELSE - t := eltyp; - WHILE FormOf(t) = 12X DO t := t.base[0] END; - IF FormOf(t) # 0X THEN - OpenFold("#Dev:Elements"); - i := 0; - WHILE i < len DO - Strings.IntToString(i, str); - name := "[" + SHORT(str$) + "]"; - ShowVar(a, ind, f, 1X, eltyp, ptr, back, name, sel); - INC(i); INC(a, size) - END; - out.WriteSString(" "); CloseFold(TRUE) - END - END - END ShowArray; - - PROCEDURE ShowProcVar (a: INTEGER); - VAR vli, n, ref: INTEGER; m: Kernel.Module; name: Kernel.Name; - BEGIN - SYSTEM.GET(a, vli); - Kernel.SearchProcVar(vli, m, vli); - IF m = NIL THEN - IF vli = 0 THEN out.WriteSString("NIL") - ELSE WriteHex(vli) - END - ELSE - IF m.refcnt >= 0 THEN - out.WriteSString(m.name); ref := m.refs; - REPEAT Kernel.GetRefProc(ref, n, name) UNTIL (n = 0) OR (vli < n); - IF vli < n THEN out.WriteChar("."); out.WriteSString(name) END - ELSE - OutString("#Dev:ProcInUnloadedMod"); - out.WriteSString(m.name); out.WriteSString(" !!!") - END - END - END ShowProcVar; - - PROCEDURE ShowPointer (a: INTEGER; f: SHORTCHAR; desc: Kernel.Type; back: RefView; VAR sel: Name); - VAR adr, x: INTEGER; ptr: ArrayPtr; c: Cluster; btyp: Kernel.Type; - BEGIN - SYSTEM.GET(a, adr); - IF f = 13X THEN btyp := desc.base[0] ELSE btyp := NIL END; - IF adr = 0 THEN out.WriteSString("NIL") - ELSIF f = 20X THEN - out.WriteChar("["); WriteHex(adr); out.WriteChar("]"); - out.WriteChar(" "); c := SYSTEM.VAL(Cluster, Kernel.Root()); - WHILE (c # NIL) & ((adr < SYSTEM.VAL(INTEGER, c)) OR (adr >= SYSTEM.VAL(INTEGER, c) + c.size)) DO c := c.next END; - IF c # NIL THEN - ptr := SYSTEM.VAL(ArrayPtr, adr) - END - ELSE - IF (f = 13X) OR (f = 0CX) THEN x := adr - 4 ELSE x := adr END; - IF ((adr < -4) OR (adr >= 65536)) & Kernel.IsReadable(x, adr + 16) THEN - out.WriteChar("["); WriteHex(adr); out.WriteChar("]"); - IF (f = 13X) OR (f = 0CX) THEN - out.WriteChar(" "); c := SYSTEM.VAL(Cluster, Kernel.Root()); - WHILE (c # NIL) & ((adr < SYSTEM.VAL(INTEGER, c)) OR (adr >= SYSTEM.VAL(INTEGER, c) + c.size)) DO - c := c.next - END; - IF c # NIL THEN - ptr := SYSTEM.VAL(ArrayPtr, adr); - IF (f = 13X) & (FormOf(btyp) = 12X) THEN (* array *) - adr := SYSTEM.ADR(ptr.len[btyp.id DIV 16 MOD 16]) - END - ELSE OutString("#Dev:IllegalPointer") - END - END - ELSE OutString("#Dev:IllegalAddress"); WriteHex(adr) - END - END - END ShowPointer; - - PROCEDURE ShowSelector (ref: RefView); - VAR b: RefView; n: SHORTINT; a, a0: TextModels.Attributes; - BEGIN - b := ref.back; n := 1; - IF b # NIL THEN - WHILE (b.name = ref.name) & (b.back # NIL) DO INC(n); b := b.back END; - ShowSelector(b); - IF n > 1 THEN out.WriteChar("(") END; - out.WriteChar(".") - END; - out.WriteSString(ref.name); - IF ref.type = heap THEN out.WriteChar("^") END; - IF n > 1 THEN - out.WriteChar(")"); - a0 := out.rider.attr; a := TextModels.NewOffset(a0, 2 * Ports.point); - out.rider.SetAttr(a); - out.WriteInt(n); out.rider.SetAttr(a0) - END - END ShowSelector; - - PROCEDURE ShowVar (ad, ind: INTEGER; f, c: SHORTCHAR; desc: Kernel.Type; ptr: ArrayPtr; back: RefView; - VAR name, sel: Name); - VAR i, j, vli, a: INTEGER; tsel: Name; a0: TextModels.Attributes; - vc: SHORTCHAR; vsi: BYTE; vi: SHORTINT; vr: SHORTREAL; vlr: REAL; vs: SET; - BEGIN - out.WriteLn; out.WriteTab; i := 0; - WHILE i < ind DO out.WriteSString(" "); INC(i) END; - a := ad; i := 0; j := 0; - IF sel # "" THEN - WHILE sel[i] # 0X DO tsel[i] := sel[i]; INC(i) END; - IF (tsel[i-1] # ":") & (name[0] # "[") THEN tsel[i] := "."; INC(i) END - END; - WHILE name[j] # 0X DO tsel[i] := name[j]; INC(i); INC(j) END; - tsel[i] := 0X; - a0 := out.rider.attr; - IF c = 3X THEN (* varpar *) - SYSTEM.GET(ad, a); - out.rider.SetAttr(TextModels.NewStyle(a0, {Fonts.italic})) - END; - IF name[0] # "[" THEN out.WriteChar(".") END; - out.WriteSString(name); - out.rider.SetAttr(a0); out.WriteTab; - IF (c = 3X) & (a >= 0) & (a < 65536) THEN - out.WriteTab; out.WriteSString("NIL VARPAR") - ELSIF f = 11X THEN - Kernel.GetTypeName(desc, name); - IF (c = 3X) & (name[0] # "!") THEN SYSTEM.GET(ad + 4, desc) END; (* dynamic type *) - ShowRecord(a, ind + 1, desc, back, tsel) - ELSIF (c = 3X) & (f = 0BX) THEN (* VAR anyrecord *) - SYSTEM.GET(ad + 4, desc); - ShowRecord(a, ind + 1, desc, back, tsel) - ELSIF f = 12X THEN - IF (desc.size = 0) & (ptr = NIL) THEN SYSTEM.GET(ad, a) END; (* dyn array val par *) - IF ptr = NIL THEN ptr := SYSTEM.VAL(ArrayPtr, ad - 8) END; - ShowArray(a, ind + 1, desc, ptr, back, tsel) - ELSE - IF desc = NIL THEN desc := SYSTEM.VAL(Kernel.Type, ORD(f)) END; - WriteName(desc, NIL); out.WriteTab; - CASE f OF - | 0X: (* SYSTEM.GET(a, vli); WriteHex(vli) *) - | 1X: SYSTEM.GET(a, vc); - IF vc = 0X THEN out.WriteSString("FALSE") - ELSIF vc = 1X THEN out.WriteSString("TRUE") - ELSE OutString("#Dev:Undefined"); out.WriteInt(ORD(vc)) - END - | 2X: WriteString(a, 1, 1, FALSE, FALSE) - | 3X: WriteString(a, 1, 2, FALSE, TRUE); - SYSTEM.GET(a, vi); - IF vi DIV 256 # 0 THEN out.WriteString(" "); WriteString(a, 1, 2, FALSE, FALSE) END - | 4X: SYSTEM.GET(a, vsi); out.WriteInt(vsi) - | 5X: SYSTEM.GET(a, vi); out.WriteInt(vi) - | 6X: SYSTEM.GET(a, vli); out.WriteInt(vli) - | 7X: SYSTEM.GET(a, vr); out.WriteReal(vr) - | 8X: SYSTEM.GET(a, vlr); out.WriteReal(vlr) - | 9X: SYSTEM.GET(a, vs); out.WriteSet(vs) - | 0AX: SYSTEM.GET(a, vli); SYSTEM.GET(a + 4, i); - IF (vli >= 0) & (i = 0) OR (vli < 0) & (i = -1) THEN out.WriteInt(vli) - ELSE out.WriteIntForm(i, TextMappers.hexadecimal, 8, "0", TextMappers.hideBase); WriteHex(vli) - END - | 0CX, 0DX, 13X, 20X: ShowPointer(a, f, desc, back, tsel) - | 0EX, 10X: ShowProcVar(a) - | 0FX: WriteString(a, 256, 1, TRUE, FALSE) - | 21X: WriteGuid(a) - | 22X: SYSTEM.GET(a, vli); WriteHex(vli) - ELSE - END - END - END ShowVar; - - - PROCEDURE ShowStack; - VAR ref, end, i, j, x, a, b, c: INTEGER; m, f: SHORTCHAR; mod: Kernel.Module; name, sel: Kernel.Name; - d: Kernel.Type; - BEGIN - a := Kernel.pc; b := Kernel.fp; c := 100; - REPEAT - mod := Kernel.modList; - WHILE (mod # NIL) & ((a < mod.code) OR (a >= mod.code + mod.csize)) DO mod := mod.next END; - IF mod # NIL THEN - DEC(a, mod.code); - IF mod.refcnt >= 0 THEN - out.WriteChar(" "); out.WriteSString(mod.name); ref := mod.refs; - REPEAT Kernel.GetRefProc(ref, end, name) UNTIL (end = 0) OR (a < end); - IF a < end THEN - out.WriteChar("."); out.WriteSString(name); - sel := mod.name$; i := 0; - WHILE sel[i] # 0X DO INC(i) END; - sel[i] := "."; INC(i); j := 0; - WHILE name[j] # 0X DO sel[i] := name[j]; INC(i); INC(j) END; - sel[i] := ":"; sel[i+1] := 0X; - out.WriteSString(" ["); WriteHex(a); - out.WriteSString("] "); - i := Kernel.SourcePos(mod, 0); - IF name # "$$" THEN - Kernel.GetRefVar(ref, m, f, d, x, name); - WHILE m # 0X DO - IF name[0] # "@" THEN ShowVar(b + x, 0, f, m, d, NIL, NIL, name, sel) END; - Kernel.GetRefVar(ref, m, f, d, x, name) - END - END; - out.WriteLn - ELSE out.WriteSString(".???"); out.WriteLn - END - ELSE - out.WriteChar("("); out.WriteSString(mod.name); - out.WriteSString(") (pc="); WriteHex(a); - out.WriteSString(", fp="); WriteHex(b); out.WriteChar(")"); - out.WriteLn - END - ELSE - out.WriteSString(" (pc="); WriteHex(a); - out.WriteSString(", fp="); WriteHex(b); out.WriteChar(")"); - out.WriteLn - END; - IF (b >= Kernel.fp) & (b < Kernel.stack) THEN - SYSTEM.GET(b+4, a); (* stacked pc *) - SYSTEM.GET(b, b); (* dynamic link *) - DEC(a); DEC(c) - ELSE c := 0 - END - UNTIL c = 0 - END ShowStack; - - PROCEDURE (a: Action) Do; (* delayed trap window open *) - BEGIN - Kernel.SetTrapGuard(TRUE); - OpenViewer(a.text, "#Dev:Trap", NewRuler()); - Kernel.SetTrapGuard(FALSE); - END Do; - - PROCEDURE GetTrapMsg(OUT msg: ARRAY OF CHAR); - VAR ref, end, a: INTEGER; mod: Kernel.Module; name: Kernel.Name; head, tail, errstr: ARRAY 32 OF CHAR; - key: ARRAY 128 OF CHAR; - BEGIN - a := Kernel.pc; mod := Kernel.modList; - WHILE (mod # NIL) & ((a < mod.code) OR (a >= mod.code + mod.csize)) DO mod := mod.next END; - IF mod # NIL THEN - DEC(a, mod.code); ref := mod.refs; - REPEAT Kernel.GetRefProc(ref, end, name) UNTIL (end = 0) OR (a < end); - IF a < end THEN - Kernel.SplitName (mod.name$, head, tail); - IF head = "" THEN head := "System" END; - Strings.IntToString(Kernel.err, errstr); - key := tail + "." + name + "." + errstr; - Dialog.MapString("#" + head + ":" + key, msg); - (* IF key # msg THEN out.WriteString(" " + msg) END; *) - IF key = msg THEN msg := "" END; - END - END - END GetTrapMsg; - - PROCEDURE Trap; - VAR a0: TextModels.Attributes; action: Action; msg: ARRAY 512 OF CHAR; - BEGIN - out.ConnectTo(TextModels.dir.New()); - a0 := out.rider.attr; - out.rider.SetAttr(TextModels.NewWeight(a0, Fonts.bold)); - IF Kernel.err = 129 THEN out.WriteSString("invalid WITH") - ELSIF Kernel.err = 130 THEN out.WriteSString("invalid CASE") - ELSIF Kernel.err = 131 THEN out.WriteSString("function without RETURN") - ELSIF Kernel.err = 132 THEN out.WriteSString("type guard") - ELSIF Kernel.err = 133 THEN out.WriteSString("implied type guard") - ELSIF Kernel.err = 134 THEN out.WriteSString("value out of range") - ELSIF Kernel.err = 135 THEN out.WriteSString("index out of range") - ELSIF Kernel.err = 136 THEN out.WriteSString("string too long") - ELSIF Kernel.err = 137 THEN out.WriteSString("stack overflow") - ELSIF Kernel.err = 138 THEN out.WriteSString("integer overflow") - ELSIF Kernel.err = 139 THEN out.WriteSString("division by zero") - ELSIF Kernel.err = 140 THEN out.WriteSString("infinite real result") - ELSIF Kernel.err = 141 THEN out.WriteSString("real underflow") - ELSIF Kernel.err = 142 THEN out.WriteSString("real overflow") - ELSIF Kernel.err = 143 THEN out.WriteSString("undefined real result") - ELSIF Kernel.err = 144 THEN out.WriteSString("not a number") - ELSIF Kernel.err = 200 THEN out.WriteSString("keyboard interrupt") - ELSIF Kernel.err = 201 THEN - out.WriteSString("NIL dereference") - ELSIF Kernel.err = 202 THEN - out.WriteSString("illegal instruction: "); - out.WriteIntForm(Kernel.val, TextMappers.hexadecimal, 5, "0", TextMappers.showBase) - ELSIF Kernel.err = 203 THEN - IF (Kernel.val >= -4) & (Kernel.val < 65536) THEN out.WriteSString("NIL dereference (read)") - ELSE out.WriteSString("illegal memory read (ad = "); WriteHex(Kernel.val); out.WriteChar(")") - END - ELSIF Kernel.err = 204 THEN - IF (Kernel.val >= -4) & (Kernel.val < 65536) THEN out.WriteSString("NIL dereference (write)") - ELSE out.WriteSString("illegal memory write (ad = "); WriteHex(Kernel.val); out.WriteChar(")") - END - ELSIF Kernel.err = 205 THEN - IF (Kernel.val >= -4) & (Kernel.val < 65536) THEN out.WriteSString("NIL procedure call") - ELSE out.WriteSString("illegal execution (ad = "); WriteHex(Kernel.val); out.WriteChar(")") - END - ELSIF Kernel.err = 257 THEN out.WriteSString("out of memory") - ELSIF Kernel.err = 10001H THEN out.WriteSString("bus error") - ELSIF Kernel.err = 10002H THEN out.WriteSString("address error") - ELSIF Kernel.err = 10007H THEN out.WriteSString("fpu error") - ELSIF Kernel.err < 0 THEN - out.WriteSString("Exception "); out.WriteIntForm(-Kernel.err, TextMappers.hexadecimal, 3, "0", TextMappers.showBase) - ELSE - out.WriteSString("TRAP "); out.WriteInt(Kernel.err); - IF Kernel.err = 126 THEN out.WriteSString(" (not yet implemented)") - ELSIF Kernel.err = 125 THEN out.WriteSString(" (call of obsolete procedure)") - ELSIF Kernel.err >= 100 THEN out.WriteSString(" (invariant violated)") - ELSIF Kernel.err >= 60 THEN out.WriteSString(" (postcondition violated)") - ELSIF Kernel.err >= 20 THEN out.WriteSString(" (precondition violated)") - END - END; - GetTrapMsg(msg); - IF msg # "" THEN out.WriteLn; out.WriteString(msg) END; - out.WriteLn; out.rider.SetAttr(a0); - out.WriteLn; ShowStack; - NEW(action); action.text := out.rider.Base(); - Services.DoLater(action, Services.now); - out.ConnectTo(NIL) - END Trap; - -BEGIN - Kernel.InstallTrapViewer(Trap); - empty := ""; - path[0].x := refViewSize DIV 2; path[0].y := 0; - path[1].x := refViewSize; path[1].y := refViewSize DIV 2; - path[2].x := refViewSize DIV 2; path[2].y := refViewSize; - path[3].x := 0; path[3].y := refViewSize DIV 2; -END StdDebug. diff --git a/new/Std/Mod/Dialog.txt b/new/Std/Mod/Dialog.txt deleted file mode 100644 index 24aecdd..0000000 --- a/new/Std/Mod/Dialog.txt +++ /dev/null @@ -1,297 +0,0 @@ -MODULE StdDialog; - - (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/Dialog.odc *) - (* DO NOT EDIT *) - - IMPORT - Kernel, Meta, Strings, Files, Stores, Models, Sequencers, Views, - Containers, Dialog, Properties, Documents, Converters, Windows; - - - TYPE - Item* = POINTER TO EXTENSIBLE RECORD - next*: Item; - item-, string-, filter-: POINTER TO ARRAY OF CHAR; - shortcut-: ARRAY 8 OF CHAR; - privateFilter-, failed, trapped: BOOLEAN; (* filter call failed, caused a trap *) - res: INTEGER (* result code of failed filter *) - END; - - FilterProcVal = RECORD (Meta.Value) p: Dialog.GuardProc END; - FilterProcPVal = RECORD (Meta.Value) p: PROCEDURE(n: INTEGER; VAR p: Dialog.Par) END; - - ViewHook = POINTER TO RECORD (Views.ViewHook) END; - - - VAR curItem-: Item; (** IN parameter for item filters **) - - - PROCEDURE GetSubLoc* (mod: ARRAY OF CHAR; cat: Files.Name; - OUT loc: Files.Locator; OUT name: Files.Name); - VAR sub: Files.Name; file: Files.File; type: Files.Type; - BEGIN - IF (cat[0] = "S") & (cat[1] = "y") & (cat[2] = "m") THEN type := Kernel.symType - ELSIF (cat[0] = "C") & (cat[1] = "o") & (cat[2] = "d") & (cat[3] = "e") THEN type := Kernel.objType - ELSE type := "" - END; - Kernel.SplitName(mod, sub, name); Kernel.MakeFileName(name, type); - loc := Files.dir.This(sub); file := NIL; - IF loc # NIL THEN - loc := loc.This(cat); - IF sub = "" THEN - IF loc # NIL THEN - file := Files.dir.Old(loc, name, Files.shared); - IF file = NIL THEN loc := NIL END - END; - IF loc = NIL THEN - loc := Files.dir.This("System"); - IF loc # NIL THEN loc := loc.This(cat) END - END - END - END - END GetSubLoc; - - - PROCEDURE Len (VAR str: ARRAY OF CHAR): INTEGER; - VAR i: INTEGER; - BEGIN - i := 0; WHILE str[i] # 0X DO INC(i) END; - RETURN i - END Len; - - PROCEDURE AddItem* (i: Item; item, string, filter, shortcut: ARRAY OF CHAR); - VAR j: INTEGER; ch: CHAR; - BEGIN - ASSERT(i # NIL, 20); - NEW(i.item, Len(item) + 1); - NEW(i.string, Len(string) + 1); - NEW(i.filter, Len(filter) + 1); - ASSERT((i.item # NIL) & (i.string # NIL) & (i.filter # NIL), 100); - i.item^ := item$; - i.string^ := string$; - i.filter^ := filter$; - i.shortcut := shortcut$; - j := 0; ch := filter[0]; WHILE (ch # ".") & (ch # 0X) DO INC(j); ch := filter[j] END; - i.privateFilter := (j > 0) & (ch = 0X); - i.failed := FALSE; i.trapped := FALSE - END AddItem; - - PROCEDURE ClearGuards* (i: Item); - BEGIN - i.failed := FALSE; i.trapped := FALSE - END ClearGuards; - - PROCEDURE GetGuardProc (name: ARRAY OF CHAR; VAR i: Meta.Item; - VAR par: BOOLEAN; VAR n: INTEGER); - VAR j, k: INTEGER; num: ARRAY 32 OF CHAR; - BEGIN - j := 0; - WHILE (name[j] # 0X) & (name[j] # "(") DO INC(j) END; - IF name[j] = "(" THEN - name[j] := 0X; INC(j); k := 0; - WHILE (name[j] # 0X) & (name[j] # ")") DO num[k] := name[j]; INC(j); INC(k) END; - IF (name[j] = ")") & (name[j+1] = 0X) THEN - num[k] := 0X; Strings.StringToInt(num, n, k); - IF k = 0 THEN Meta.LookupPath(name, i); par := TRUE - ELSE Meta.Lookup("", i) - END - ELSE Meta.Lookup("", i) - END - ELSE - Meta.LookupPath(name, i); par := FALSE - END - END GetGuardProc; - - PROCEDURE CheckFilter* (i: Item; VAR failed, ok: BOOLEAN; VAR par: Dialog.Par); - VAR x: Meta.Item; v: FilterProcVal; vp: FilterProcPVal; p: BOOLEAN; n: INTEGER; - BEGIN - IF ~i.failed THEN - curItem := i; - par.disabled := FALSE; par.checked := FALSE; par.label := i.item$; - par.undef := FALSE; par.readOnly := FALSE; - i.failed := TRUE; i.trapped := TRUE; - GetGuardProc(i.filter^, x, p, n); - IF (x.obj = Meta.procObj) OR (x.obj = Meta.varObj) & (x.typ = Meta.procTyp) THEN - IF p THEN - x.GetVal(vp, ok); - IF ok THEN vp.p(n, par) END - ELSE - x.GetVal(v, ok); - IF ok THEN v.p(par) END - END - ELSE ok := FALSE - END; - IF ok THEN i.res := 0 ELSE i.res := 1 END; - i.trapped := FALSE; i.failed := ~ok - END; - failed := i.failed - END CheckFilter; - - PROCEDURE HandleItem* (i: Item); - VAR res: INTEGER; - BEGIN - IF ~i.failed THEN - Views.ClearQueue; res := 0; - Dialog.Call(i.string^, " ", res) - ELSIF (i # NIL) & i.failed THEN - IF i.trapped THEN - Dialog.ShowParamMsg("#System:ItemFilterTrapped", i.string^, i.filter^, "") - ELSE - Dialog.ShowParamMsg("#System:ItemFilterNotFound", i.string^, i.filter^, "") - END - END - END HandleItem; - - PROCEDURE RecalcView* (v: Views.View); - (* recalc size of all subviews of v, then v itself *) - VAR m: Models.Model; v1: Views.View; c: Containers.Controller; - minW, maxW, minH, maxH, w, h, w0, h0: INTEGER; - BEGIN - IF v IS Containers.View THEN - c := v(Containers.View).ThisController(); - IF c # NIL THEN - v1 := NIL; c.GetFirstView(Containers.any, v1); - WHILE v1 # NIL DO - RecalcView(v1); - c.GetNextView(Containers.any, v1) - END - END - END; - IF v.context # NIL THEN - m := v.context.ThisModel(); - IF (m # NIL) & (m IS Containers.Model) THEN - m(Containers.Model).GetEmbeddingLimits(minW, maxW, minH, maxH); - v.context.GetSize(w0, h0); w := w0; h := h0; - Properties.PreferredSize(v, minW, maxW, minH, maxH, w, h, w, h); - IF (w # w0) OR (h # h0) THEN v.context.SetSize(w, h) END - END - END - END RecalcView; - - - PROCEDURE Open* (v: Views.View; title: ARRAY OF CHAR; - loc: Files.Locator; name: Files.Name; conv: Converters.Converter; - asTool, asAux, noResize, allowDuplicates, neverDirty: BOOLEAN); - VAR t: Views.Title; flags, opts: SET; done: BOOLEAN; d: Documents.Document; i: INTEGER; - win: Windows.Window; c: Containers.Controller; seq: ANYPTR; - BEGIN - IF conv = NIL THEN conv := Converters.list END; (* use document converter *) - ASSERT(v # NIL, 20); - flags := {}; done := FALSE; - IF noResize THEN - flags := flags + {Windows.noResize, Windows.noHScroll, Windows.noVScroll} - END; - IF asTool THEN INCL(flags, Windows.isTool) END; - IF asAux THEN INCL(flags, Windows.isAux) END; - IF neverDirty THEN INCL(flags, Windows.neverDirty) END; - i := 0; - WHILE (i < LEN(t) - 1) & (title[i] # 0X) DO t[i] := title[i]; INC(i) END; - t[i] := 0X; - IF ~allowDuplicates THEN - IF ~asTool & ~asAux THEN - IF (loc # NIL) & (name # "") THEN Windows.SelectBySpec(loc, name, conv, done) END - ELSE - IF title # "" THEN Windows.SelectByTitle(v, flags, t, done) END - END - ELSE - INCL(flags, Windows.allowDuplicates) - END; - IF ~done THEN - IF v IS Documents.Document THEN - IF v.context # NIL THEN - d := Documents.dir.New( - Views.CopyOf(v(Documents.Document).ThisView(), Views.shallow), - Views.undefined, Views.undefined) - ELSE - d := v(Documents.Document) - END; - ASSERT(d.context = NIL, 22); - v := d.ThisView(); ASSERT(v # NIL, 23) - ELSIF v.context # NIL THEN - ASSERT(v.context IS Documents.Context, 24); - d := v.context(Documents.Context).ThisDoc(); - IF d.context # NIL THEN - d := Documents.dir.New(Views.CopyOf(v, Views.shallow), Views.undefined, Views.undefined) - END; - ASSERT(d.context = NIL, 25) - (*IF d.Domain() = NIL THEN Stores.InitDomain(d, v.Domain()) END (for views opened via Views.Old *) - ELSE - d := Documents.dir.New(v, Views.undefined, Views.undefined) - END; - IF asTool OR asAux THEN - c := d.ThisController(); - c.SetOpts(c.opts + {Containers.noSelection}) - END; - ASSERT(d.Domain() = v.Domain(), 100); - ASSERT(d.Domain() # NIL, 101); - seq := d.Domain().GetSequencer(); - IF neverDirty & (seq # NIL) THEN - ASSERT(seq IS Sequencers.Sequencer, 26); - seq(Sequencers.Sequencer).SetDirty(FALSE) - END; - IF neverDirty THEN - (* change "fit to page" to "fit to window" in secondary windows *) - c := d.ThisController(); opts := c.opts; - IF Documents.pageWidth IN opts THEN - opts := opts - {Documents.pageWidth} + {Documents.winWidth} - END; - IF Documents.pageHeight IN opts THEN - opts := opts - {Documents.pageHeight} + {Documents.winHeight} - END; - c.SetOpts(opts) - END; - win := Windows.dir.New(); - IF seq # NIL THEN - Windows.dir.OpenSubWindow(win, d, flags, t) - ELSE - Windows.dir.Open(win, d, flags, t, loc, name, conv) - END - END - END Open; - - PROCEDURE (h: ViewHook) Open (v: Views.View; title: ARRAY OF CHAR; - loc: Files.Locator; name: Files.Name; conv: Converters.Converter; - asTool, asAux, noResize, allowDuplicates, neverDirty: BOOLEAN); - BEGIN - Open(v, title, loc, name, conv, asTool, asAux, noResize, allowDuplicates, neverDirty) - END Open; - - PROCEDURE (h: ViewHook) OldView (loc: Files.Locator; name: Files.Name; - VAR conv: Converters.Converter): Views.View; - VAR w: Windows.Window; s: Stores.Store; c: Converters.Converter; - BEGIN - ASSERT(loc # NIL, 20); ASSERT(name # "", 21); - Kernel.MakeFileName(name, ""); s := NIL; - IF loc.res # 77 THEN - w := Windows.dir.First(); c := conv; - IF c = NIL THEN c := Converters.list END; (* use document converter *) - WHILE (w # NIL) & ((w.loc = NIL) OR (w.name = "") OR (w.loc.res = 77) OR - ~Files.dir.SameFile(loc, name, w.loc, w.name) OR (w.conv # c)) DO - w := Windows.dir.Next(w) - END; - IF w # NIL THEN s := w.doc.ThisView() END - END; - IF s = NIL THEN - Converters.Import(loc, name, conv, s); - IF s # NIL THEN RecalcView(s(Views.View)) END - END; - IF s # NIL THEN RETURN s(Views.View) ELSE RETURN NIL END - END OldView; - - PROCEDURE (h: ViewHook) RegisterView (v: Views.View; - loc: Files.Locator; name: Files.Name; conv: Converters.Converter); - BEGIN - ASSERT(v # NIL, 20); ASSERT(loc # NIL, 21); ASSERT(name # "", 22); - Kernel.MakeFileName(name, ""); - Converters.Export(loc, name, conv, v) - END RegisterView; - - PROCEDURE Init; - VAR h: ViewHook; - BEGIN - NEW(h); Views.SetViewHook(h) - END Init; - -BEGIN - Init -END StdDialog. diff --git a/new/Std/Mod/ETHConv.txt b/new/Std/Mod/ETHConv.txt deleted file mode 100644 index 944e019..0000000 --- a/new/Std/Mod/ETHConv.txt +++ /dev/null @@ -1,223 +0,0 @@ -MODULE StdETHConv; - - (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/ETHConv.odc *) - (* DO NOT EDIT *) - - IMPORT - Fonts, Files, Stores, Ports, Views, - TextModels, TextRulers, TextViews, - Stamps := StdStamps, Clocks := StdClocks, StdFolds; - - CONST - V2Tag = -4095; (* 01 F0 *) - V4Tag = 496; (* F0 01 *) - - TYPE - FontDesc = RECORD - typeface: Fonts.Typeface; - size: INTEGER; - style: SET; - weight: INTEGER - END; - - VAR default: Fonts.Font; - - PROCEDURE Split (name: ARRAY OF CHAR; VAR d: FontDesc); - VAR i: INTEGER; ch: CHAR; - BEGIN - i := 0; ch := name[0]; - WHILE (ch < "0") OR (ch >"9") DO - d.typeface[i] := ch; INC(i); ch := name[i] - END; - d.typeface[i] := 0X; - d.size := 0; - WHILE ("0" <= ch) & (ch <= "9") DO - d.size := d.size * 10 + (ORD(ch) - 30H); INC(i); ch := name[i] - END; - CASE ch OF - "b": d.style := {}; d.weight := Fonts.bold - | "i": d.style := {Fonts.italic}; d.weight := Fonts.normal - | "j": d.style := {Fonts.italic}; d.weight := Fonts.bold - | "m": d.style := {}; d.weight := Fonts.bold - ELSE d.style := {}; d.weight := Fonts.normal (* unknown style *) - END - END Split; - - PROCEDURE ThisFont (name: ARRAY OF CHAR): Fonts.Font; - VAR d: FontDesc; - BEGIN - Split(name, d); - IF d.typeface = "Syntax" THEN d.typeface := default.typeface END; - IF d.size = 10 THEN d.size := default.size - ELSE d.size := (d.size - 2) * Ports.point - END; - RETURN Fonts.dir.This(d.typeface, d.size, d.style, d.weight) - END ThisFont; - - PROCEDURE ThisChar (ch: CHAR): CHAR; - BEGIN - CASE ORD(ch) OF - 80H: ch := 0C4X | 81H: ch := 0D6X | 82H: ch := 0DCX - | 83H: ch := 0E4X | 84H: ch := 0F6X | 85H: ch := 0FCX - | 86H: ch := 0E2X | 87H: ch := 0EAX | 88H: ch := 0EEX | 89H: ch := 0F4X | 8AH: ch := 0FBX - | 8BH: ch := 0E0X | 8CH: ch := 0E8X | 8DH: ch := 0ECX | 8EH: ch := 0F2X | 8FH: ch := 0F9X - | 90H: ch := 0E9X - | 91H: ch := 0EBX | 92H: ch := 0EFX - | 93H: ch := 0E7X - | 94H: ch := 0E1X - | 95H: ch := 0F1X - | 9BH: ch := TextModels.hyphen - | 9FH: ch := TextModels.nbspace - | 0ABH: ch := 0DFX - ELSE - ch := 0BFX (* use inverted question mark for unknown character codes *) - END; - RETURN ch - END ThisChar; - - PROCEDURE ^ LoadTextBlock (r: Stores.Reader; t: TextModels.Model); - - PROCEDURE StdFold (VAR r: Stores.Reader): Views.View; - CONST colLeft = 0; colRight = 1; expRight = 2; expLeft = 3; - VAR k: BYTE; state: BOOLEAN; hidden: TextModels.Model; fold: StdFolds.Fold; - BEGIN - r.ReadByte(k); - CASE k MOD 4 OF - | colLeft: state := StdFolds.collapsed - | colRight: state := StdFolds.collapsed - | expRight: state := StdFolds.expanded - | expLeft: state := StdFolds.expanded - END; - IF (k MOD 4 IN {colLeft, expLeft}) & (k < 4) THEN - hidden := TextModels.dir.New(); LoadTextBlock(r, hidden); - ELSE hidden := NIL; - END; - fold := StdFolds.dir.New(state, "", hidden); - RETURN fold; - END StdFold; - - PROCEDURE LoadTextBlock (r: Stores.Reader; t: TextModels.Model); - VAR r0: Stores.Reader; wr: TextModels.Writer; - org, len: INTEGER; en, ano, i, n: BYTE; col, voff, ch: CHAR; tag: INTEGER; - fname: ARRAY 32 OF CHAR; - attr: ARRAY 32 OF TextModels.Attributes; - mod, proc: ARRAY 32 OF ARRAY 32 OF CHAR; - - PROCEDURE ReadNum (VAR n: INTEGER); - VAR s: BYTE; ch: CHAR; y: INTEGER; - BEGIN - s := 0; y := 0; r.ReadXChar(ch); - WHILE ch >= 80X DO - INC(y, ASH(ORD(ch)-128, s)); INC(s, 7); r.ReadXChar(ch) - END; - n := ASH((ORD(ch) + 64) MOD 128 - 64, s) + y - END ReadNum; - - PROCEDURE ReadSet (VAR s: SET); - VAR x: INTEGER; - BEGIN - ReadNum(x); s := BITS(x) - END ReadSet; - - PROCEDURE Elem (VAR r: Stores.Reader; span: INTEGER); - VAR v: Views.View; end, ew, eh, n, indent: INTEGER; eno, version: BYTE; - p: TextRulers.Prop; opts: SET; - BEGIN - r.ReadInt(ew); r.ReadInt(eh); r.ReadByte(eno); - IF eno > en THEN en := eno; r.ReadXString(mod[eno]); r.ReadXString(proc[eno]) END; - end := r.Pos() + span; - IF (mod[eno] = "ParcElems") OR (mod[eno] = "StyleElems") THEN - r.ReadByte(version); - NEW(p); - p.valid := {TextRulers.first .. TextRulers.tabs}; - ReadNum(indent); ReadNum(p.left); - p.first := p.left + indent; - ReadNum(n); p.right := p.left + n; - ReadNum(p.lead); - ReadNum(p.grid); - ReadNum(p.dsc); p.asc := p.grid - p.dsc; - ReadSet(opts); p.opts.val := {}; - IF ~(0 IN opts) THEN p.grid := 1 END; - IF 1 IN opts THEN INCL(p.opts.val, TextRulers.leftAdjust) END; - IF 2 IN opts THEN INCL(p.opts.val, TextRulers.rightAdjust) END; - IF 3 IN opts THEN INCL(p.opts.val, TextRulers.pageBreak) END; - INCL(p.opts.val, TextRulers.rightFixed); - p.opts.mask := {TextRulers.leftAdjust .. TextRulers.pageBreak, TextRulers.rightFixed}; - ReadNum(n); p.tabs.len := n; - i := 0; WHILE i < p.tabs.len DO ReadNum(p.tabs.tab[i].stop); INC(i) END; - v := TextRulers.dir.NewFromProp(p); - wr.WriteView(v, ew, eh) - ELSIF mod[eno] = "StampElems" THEN - v := Stamps.New(); - wr.WriteView(v, ew, eh) - ELSIF mod[eno] = "ClockElems" THEN - v := Clocks.New(); - wr.WriteView(v, ew, eh) - ELSIF mod[eno] = "FoldElems" THEN - v := StdFold(r); - wr.WriteView(v, ew, eh); - END; - r.SetPos(end) - END Elem; - - BEGIN - (* skip inner text tags (legacy from V2) *) - r.ReadXInt(tag); - IF tag # V2Tag THEN r.SetPos(r.Pos()-2) END; - (* load text block *) - org := r.Pos(); r.ReadInt(len); INC(org, len - 2); - r0.ConnectTo(r.rider.Base()); r0.SetPos(org); - wr := t.NewWriter(NIL); wr.SetPos(0); - n := 0; en := 0; r.ReadByte(ano); - WHILE ano # 0 DO - IF ano > n THEN - n := ano; r.ReadXString(fname); - attr[n] := TextModels.NewFont(wr.attr, ThisFont(fname)) - END; - r.ReadXChar(col); r.ReadXChar(voff); r.ReadInt(len); - wr.SetAttr(attr[ano]); - IF len > 0 THEN - WHILE len # 0 DO - r0.ReadXChar(ch); - IF ch >= 80X THEN ch := ThisChar(ch) END; - IF (ch >= " ") OR (ch = TextModels.tab) OR (ch = TextModels.line) THEN - wr.WriteChar(ch) - END; - DEC(len) - END - ELSE - Elem(r, -len); r0.ReadXChar(ch) - END; - r.ReadByte(ano) - END; - r.ReadInt(len); - r.SetPos(r.Pos() + len); - END LoadTextBlock; - - PROCEDURE ImportOberon* (f: Files.File): TextModels.Model; - VAR r: Stores.Reader; t: TextModels.Model; tag: INTEGER; - BEGIN - r.ConnectTo(f); r.SetPos(0); - r.ReadXInt(tag); - IF tag = ORD("o") + 256 * ORD("B") THEN - (* ignore file header of Oberon for Windows and DOSOberon files *) - r.SetPos(34); r.ReadXInt(tag) - END; - ASSERT((tag = V2Tag) OR (tag = V4Tag), 100); - t := TextModels.dir.New(); - LoadTextBlock(r, t); - RETURN t; - END ImportOberon; - - - PROCEDURE ImportETHDoc* (f: Files.File; OUT s: Stores.Store); - VAR t: TextModels.Model; - BEGIN - ASSERT(f # NIL, 20); - t := ImportOberon(f); - IF t # NIL THEN s := TextViews.dir.New(t) END - END ImportETHDoc; - -BEGIN - default := Fonts.dir.Default() -END StdETHConv. diff --git a/new/Std/Mod/Folds.txt b/new/Std/Mod/Folds.txt deleted file mode 100644 index 87b2867..0000000 --- a/new/Std/Mod/Folds.txt +++ /dev/null @@ -1,779 +0,0 @@ -MODULE StdFolds; - - (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/Folds.odc *) - (* DO NOT EDIT *) - - IMPORT - Domains := Stores, Ports, Stores, Containers, Models, Views, Controllers, Fonts, - Properties,Controls, - TextModels, TextViews, TextControllers, TextSetters, - Dialog, Services; - - CONST - expanded* = FALSE; collapsed* = TRUE; - minVersion = 0; currentVersion = 0; - - collapseFoldKey = "#Std:Collapse Fold"; - expandFoldKey = "#Std:Expand Fold"; - zoomInKey = "#Std:Zoom In"; - zoomOutKey = "#Std:Zoom Out"; - expandFoldsKey = "#Std:Expand Folds"; - collapseFoldsKey = "#Std:Collapse Folds"; - insertFoldKey = "#Std:Insert Fold"; - setLabelKey = "#Std:Set Label"; - - - TYPE - Label* = ARRAY 32 OF CHAR; - - Fold* = POINTER TO RECORD (Views.View) - leftSide-: BOOLEAN; - collapsed-: BOOLEAN; - label-: Label; (* valid iff leftSide *) - hidden: TextModels.Model (* valid iff leftSide; NIL if no hidden text *) - END; - - Directory* = POINTER TO ABSTRACT RECORD END; - - StdDirectory = POINTER TO RECORD (Directory) END; - - FlipOp = POINTER TO RECORD (Domains.Operation) - text: TextModels.Model; (* containing text *) - leftpos, rightpos: INTEGER (* position of left and right Fold *) - END; - - SetLabelOp = POINTER TO RECORD (Domains.Operation) - text: TextModels.Model; (* containing text *) - pos: INTEGER; (* position of fold in text *) - oldlabel: Label - END; - - Action = POINTER TO RECORD (Services.Action) END; - - - VAR - dir-, stdDir-: Directory; - - foldData*: RECORD - nested*: BOOLEAN; - all*: BOOLEAN; - findLabel*: Label; - newLabel*: Label - END; - - iconFont: Fonts.Typeface; - leftExp, rightExp, leftColl, rightColl: ARRAY 8 OF SHORTCHAR; - coloredBackg: BOOLEAN; - action: Action; - fingerprint: INTEGER; (* for the property inspector *) - - PROCEDURE (d: Directory) New* (collapsed: BOOLEAN; label: Label; - hiddenText: TextModels.Model): Fold, NEW, ABSTRACT; - - - PROCEDURE GetPair (fold: Fold; VAR l, r: Fold); - VAR c: Models.Context; text: TextModels.Model; rd: TextModels.Reader; v: Views.View; - nest: INTEGER; - BEGIN - c := fold.context; l := NIL; r := NIL; - WITH c: TextModels.Context DO - text := c.ThisModel(); rd := text.NewReader(NIL); - IF fold.leftSide THEN l := fold; - rd.SetPos(c.Pos()+1); nest := 1; - REPEAT rd.ReadView(v); - IF (v # NIL) & (v IS Fold) THEN - IF v(Fold).leftSide THEN INC(nest) ELSE DEC(nest) END - END - UNTIL (v = NIL) OR (nest = 0); - IF v # NIL THEN r := v(Fold) ELSE r := NIL END - ELSE r := fold; - rd.SetPos(c.Pos()); nest := 1; - REPEAT rd.ReadPrevView(v); - IF (v # NIL) & (v IS Fold) THEN - IF ~v(Fold).leftSide THEN INC(nest) ELSE DEC(nest) END - END - UNTIL (v = NIL) OR (nest = 0); - IF v # NIL THEN l := v(Fold) ELSE l := NIL END - END - ELSE (* fold not embedded in a text *) - END; - ASSERT((l = NIL) OR l.leftSide & (l.hidden # NIL), 100); - ASSERT((r = NIL) OR ~r.leftSide & (r.hidden = NIL), 101) - END GetPair; - - PROCEDURE (fold: Fold) HiddenText* (): TextModels.Model, NEW; - VAR l, r: Fold; - BEGIN - IF fold.leftSide THEN RETURN fold.hidden - ELSE GetPair(fold, l, r); - IF l # NIL THEN RETURN l.hidden ELSE RETURN NIL END - END - END HiddenText; - - PROCEDURE (fold: Fold) MatchingFold* (): Fold, NEW; - VAR l, r: Fold; - BEGIN - GetPair(fold, l, r); - IF l # NIL THEN - IF fold = l THEN RETURN r ELSE RETURN l END - ELSE RETURN NIL - END - END MatchingFold; - - PROCEDURE GetIcon (fold: Fold; VAR icon: ARRAY OF SHORTCHAR); - BEGIN - IF fold.leftSide THEN - IF fold.collapsed THEN icon := leftColl$ ELSE icon := leftExp$ END - ELSE - IF fold.collapsed THEN icon := rightColl$ ELSE icon := rightExp$ END - END - END GetIcon; - - PROCEDURE CalcSize (f: Fold; VAR w, h: INTEGER); - VAR icon: ARRAY 8 OF SHORTCHAR; c: Models.Context; a: TextModels.Attributes; font: Fonts.Font; - asc, dsc, fw: INTEGER; - BEGIN - GetIcon(f, icon); - c := f.context; - IF (c # NIL) & (c IS TextModels.Context) THEN - a := c(TextModels.Context).Attr(); - font := Fonts.dir.This(iconFont, a.font.size, {}, Fonts.normal) - ELSE font := Fonts.dir.Default() - END; - w := font.SStringWidth(icon); - font.GetBounds(asc, dsc, fw); - h := asc + dsc - END CalcSize; - - PROCEDURE Update (f: Fold); - VAR w, h: INTEGER; - BEGIN - CalcSize(f, w, h); - f.context.SetSize(w, h); - Views.Update(f, Views.keepFrames) - END Update; - - PROCEDURE FlipPair (l, r: Fold); - VAR text, hidden: TextModels.Model; cl, cr: Models.Context; - lpos, rpos: INTEGER; - BEGIN - IF (l # NIL) & (r # NIL) THEN - ASSERT(l.leftSide, 100); - ASSERT(~r.leftSide, 101); - ASSERT(l.hidden # NIL, 102); - ASSERT(r.hidden = NIL, 103); - cl := l.context; cr := r.context; - text := cl(TextModels.Context).ThisModel(); - lpos := cl(TextModels.Context).Pos() + 1; rpos := cr(TextModels.Context).Pos(); - ASSERT(lpos <= rpos, 104); - hidden := TextModels.CloneOf(text); - hidden.Insert(0, text, lpos, rpos); - text.Insert(lpos, l.hidden, 0, l.hidden.Length()); - l.hidden := hidden; Stores.Join(l, hidden); - l.collapsed := ~l.collapsed; - r.collapsed := l.collapsed; - Update(l); Update(r); - TextControllers.SetCaret(text, lpos) - END - END FlipPair; - - PROCEDURE (op: FlipOp) Do; - VAR rd: TextModels.Reader; left, right: Views.View; - BEGIN - rd := op.text.NewReader(NIL); - rd.SetPos(op.leftpos); rd.ReadView(left); - rd.SetPos(op.rightpos); rd.ReadView(right); - FlipPair(left(Fold), right(Fold)); - op.leftpos := left.context(TextModels.Context).Pos(); - op.rightpos := right.context(TextModels.Context).Pos() - END Do; - - PROCEDURE (op: SetLabelOp) Do; - VAR rd: TextModels.Reader; fold: Views.View; left, right: Fold; lab: Label; - BEGIN - rd := op.text.NewReader(NIL); - rd.SetPos(op.pos); rd.ReadView(fold); - WITH fold: Fold DO - GetPair(fold, left, right); - IF left # NIL THEN - lab := fold.label; left.label := op.oldlabel; op.oldlabel := lab; - right.label := left.label - END - END - END Do; - - PROCEDURE SetProp (fold: Fold; p : Properties.Property); - VAR op: SetLabelOp; left, right: Fold; - BEGIN - WHILE p # NIL DO - WITH p: Controls.Prop DO - IF (Controls.label IN p.valid) & (p.label # fold.label) THEN - GetPair(fold, left, right); - IF left # NIL THEN - NEW(op); op.oldlabel := p.label$; - op.text := fold.context(TextModels.Context).ThisModel(); - op.pos := fold.context(TextModels.Context).Pos(); - Views.Do(fold, setLabelKey, op) - END - END - ELSE - END; - p := p.next - END - END SetProp; - - PROCEDURE (fold: Fold) Flip*, NEW; - VAR op: FlipOp; left, right: Fold; - BEGIN - ASSERT(fold # NIL, 20); - NEW(op); - GetPair(fold, left, right); - IF (left # NIL) & (right # NIL) THEN - op.text := fold.context(TextModels.Context).ThisModel(); - op.leftpos := left.context(TextModels.Context).Pos(); - op.rightpos := right.context(TextModels.Context).Pos(); - Views.BeginModification(Views.clean, fold); - IF ~left.collapsed THEN Views.Do(fold, collapseFoldKey, op) - ELSE Views.Do(fold, expandFoldKey, op) - END; - Views.EndModification(Views.clean, fold) - END - END Flip; - - PROCEDURE ReadNext (rd: TextModels.Reader; VAR fold: Fold); - VAR v: Views.View; - BEGIN - REPEAT rd.ReadView(v) UNTIL rd.eot OR (v IS Fold); - IF ~rd.eot THEN fold := v(Fold) ELSE fold := NIL END - END ReadNext; - - PROCEDURE (fold: Fold) FlipNested*, NEW; - VAR text: TextModels.Model; rd: TextModels.Reader; l, r: Fold; level: INTEGER; - op: Domains.Operation; - BEGIN - ASSERT(fold # NIL, 20); - GetPair(fold, l, r); - IF (l # NIL) & (l.context # NIL) & (l.context IS TextModels.Context) THEN - text := l.context(TextModels.Context).ThisModel(); - Models.BeginModification(Models.clean, text); - rd := text.NewReader(NIL); - rd.SetPos(l.context(TextModels.Context).Pos()); - IF l.collapsed THEN - Models.BeginScript(text, expandFoldsKey, op); - ReadNext(rd, fold); level := 1; - WHILE (fold # NIL) & (level > 0) DO - IF fold.leftSide & fold.collapsed THEN fold.Flip END; - ReadNext(rd, fold); - IF fold.leftSide THEN INC(level) ELSE DEC(level) END - END - ELSE (* l.state = expanded *) - Models.BeginScript(text, collapseFoldsKey, op); - level := 0; - REPEAT ReadNext(rd, fold); - IF fold.leftSide THEN INC(level) ELSE DEC(level) END; - IF (fold # NIL) & ~fold.leftSide & ~fold.collapsed THEN - fold.Flip; - rd.SetPos(fold.context(TextModels.Context).Pos()+1) - END - UNTIL (fold = NIL) OR (level = 0) - END; - Models.EndScript(text, op); - Models.EndModification(Models.clean, text) - END - END FlipNested; - - PROCEDURE (fold: Fold) HandlePropMsg- (VAR msg: Properties.Message); - VAR prop: Controls.Prop; c: Models.Context; a: TextModels.Attributes; asc, w: INTEGER; - BEGIN - WITH msg: Properties.SizePref DO - CalcSize(fold, msg.w, msg.h) - | msg: Properties.ResizePref DO - msg.fixed := TRUE - | msg: Properties.FocusPref DO msg.hotFocus := TRUE - | msg: Properties.PollMsg DO NEW(prop); - prop.known := {Controls.label}; prop.valid := {Controls.label}; prop.readOnly := {}; - prop.label := fold.label$; - msg.prop := prop - | msg: Properties.SetMsg DO SetProp(fold, msg.prop) - | msg: TextSetters.Pref DO c := fold.context; - IF (c # NIL) & (c IS TextModels.Context) THEN - a := c(TextModels.Context).Attr(); - a.font.GetBounds(asc, msg.dsc, w) - END - ELSE - END - END HandlePropMsg; - - PROCEDURE Track (fold: Fold; f: Views.Frame; x, y: INTEGER; buttons: SET; VAR hit: BOOLEAN); - VAR a: TextModels.Attributes; font: Fonts.Font; c: Models.Context; - w, h, asc, dsc, fw: INTEGER; isDown, in, in0: BOOLEAN; modifiers: SET; - BEGIN - c := fold.context; hit := FALSE; - WITH c: TextModels.Context DO - a := c.Attr(); font := a.font; - c.GetSize(w, h); in0 := FALSE; - in := (0 <= x) & (x < w) & (0 <= y) & (y < h); - REPEAT - IF in # in0 THEN - f.MarkRect(0, 0, w, h, Ports.fill, Ports.hilite, FALSE); in0 := in - END; - f.Input(x, y, modifiers, isDown); - in := (0 <= x) & (x < w) & (0 <= y) & (y < h) - UNTIL ~isDown; - IF in0 THEN hit := TRUE; - font.GetBounds(asc, dsc, fw); - f.MarkRect(0, 0, w, asc + dsc, Ports.fill, Ports.hilite, FALSE) - END - ELSE - END - END Track; - - PROCEDURE (fold: Fold) HandleCtrlMsg* (f: Views.Frame; VAR msg: Views.CtrlMessage; - VAR focus: Views.View); - VAR hit: BOOLEAN; pos: INTEGER; l, r: Fold; - context: TextModels.Context; text: TextModels.Model; - BEGIN - WITH msg: Controllers.TrackMsg DO - IF fold.context IS TextModels.Context THEN - Track(fold, f, msg.x, msg.y, msg.modifiers, hit); - IF hit THEN - IF Controllers.modify IN msg.modifiers THEN - fold.FlipNested - ELSE - fold.Flip; - context := fold.context(TextModels.Context); - text := context.ThisModel(); - IF TextViews.FocusText() = text THEN - GetPair(fold, l, r); - pos := context.Pos(); - IF fold = l THEN - TextControllers.SetCaret(text, pos + 1) - ELSE - TextControllers.SetCaret(text, pos) - END; - TextViews.ShowRange(text, pos, pos + 1, TRUE) - END - END - END - END - | msg: Controllers.PollCursorMsg DO - msg.cursor := Ports.refCursor - ELSE - END - END HandleCtrlMsg; - - PROCEDURE (fold: Fold) Restore* (f: Views.Frame; l, t, r, b: INTEGER); - VAR a: TextModels.Attributes; color: Ports.Color; c: Models.Context; font: Fonts.Font; - icon: ARRAY 8 OF SHORTCHAR; w, h: INTEGER; asc, dsc, fw: INTEGER; - BEGIN - GetIcon(fold, icon); c := fold.context; - IF (c # NIL) & (c IS TextModels.Context) THEN - a := fold.context(TextModels.Context).Attr(); - font := Fonts.dir.This(iconFont, a.font.size, {}, Fonts.normal); - color := a.color - ELSE font := Fonts.dir.Default(); color := Ports.black - END; - IF coloredBackg THEN - fold.context.GetSize(w, h); - f.DrawRect(f.l, f.dot, f.r, h-f.dot, Ports.fill, Ports.grey50); - color := Ports.white - END; - font.GetBounds(asc, dsc, fw); - f.DrawSString(0, asc, color, icon, font) - END Restore; - - PROCEDURE (fold: Fold) CopyFromSimpleView- (source: Views.View); - BEGIN - (* fold.CopyFrom^(source); *) - WITH source: Fold DO - ASSERT(source.leftSide = (source.hidden # NIL), 100); - fold.leftSide := source.leftSide; - fold.collapsed := source.collapsed; - fold.label := source.label; - IF source.hidden # NIL THEN - fold.hidden := TextModels.CloneOf(source.hidden); Stores.Join(fold.hidden, fold); - fold.hidden.InsertCopy(0, source.hidden, 0, source.hidden.Length()) - END - END - END CopyFromSimpleView; - - PROCEDURE (fold: Fold) Internalize- (VAR rd: Stores.Reader); - VAR version: INTEGER; store: Stores.Store; xint: INTEGER; - BEGIN - fold.Internalize^(rd); - IF rd.cancelled THEN RETURN END; - rd.ReadVersion(minVersion, currentVersion, version); - IF rd.cancelled THEN RETURN END; - rd.ReadXInt(xint);fold.leftSide := xint = 0; - rd.ReadXInt(xint); fold.collapsed := xint = 0; - rd.ReadXString(fold.label); - rd.ReadStore(store); - IF store # NIL THEN fold.hidden := store(TextModels.Model); Stores.Join(fold.hidden, fold) - ELSE fold.hidden := NIL - END; - fold.leftSide := store # NIL - END Internalize; - - PROCEDURE (fold: Fold) Externalize- (VAR wr: Stores.Writer); - VAR xint: INTEGER; - BEGIN - fold.Externalize^(wr); - wr.WriteVersion(currentVersion); - IF fold.hidden # NIL THEN xint := 0 ELSE xint := 1 END; - wr.WriteXInt(xint); - IF fold.collapsed THEN xint := 0 ELSE xint := 1 END; - wr.WriteXInt(xint); - wr.WriteXString(fold.label); - wr.WriteStore(fold.hidden) - END Externalize; - - (* --------------------- expanding and collapsing in focus text ------------------------ *) - - PROCEDURE ExpandFolds* (text: TextModels.Model; nested: BOOLEAN; IN label: ARRAY OF CHAR); - VAR op: Domains.Operation; fold, l, r: Fold; rd: TextModels.Reader; - BEGIN - ASSERT(text # NIL, 20); - Models.BeginModification(Models.clean, text); - IF nested THEN Models.BeginScript(text, expandFoldsKey, op) - ELSE Models.BeginScript(text, zoomInKey, op) - END; - rd := text.NewReader(NIL); rd.SetPos(0); - ReadNext(rd, fold); - WHILE ~rd.eot DO - IF fold.leftSide & fold.collapsed THEN - IF (label = "") OR (label = fold.label) THEN - fold.Flip; - IF ~nested THEN - GetPair(fold, l, r); - rd.SetPos(r.context(TextModels.Context).Pos()) - END - END - END; - ReadNext(rd, fold) - END; - Models.EndScript(text, op); - Models.EndModification(Models.clean, text) - END ExpandFolds; - - PROCEDURE CollapseFolds* (text: TextModels.Model; nested: BOOLEAN; IN label: ARRAY OF CHAR); - VAR op: Domains.Operation; fold, r, l: Fold; rd: TextModels.Reader; - BEGIN - ASSERT(text # NIL, 20); - Models.BeginModification(Models.clean, text); - IF nested THEN Models.BeginScript(text, collapseFoldsKey, op) - ELSE Models.BeginScript(text, zoomOutKey, op) - END; - rd := text.NewReader(NIL); rd.SetPos(0); - ReadNext(rd, fold); - WHILE ~rd.eot DO - IF ~fold.leftSide & ~fold.collapsed THEN - GetPair(fold, l, r); - IF (label = "") OR (label = l.label) THEN - fold.Flip; - GetPair(l, l, r); - rd.SetPos(r.context(TextModels.Context).Pos()+1); - IF ~nested THEN REPEAT ReadNext(rd, fold) UNTIL rd.eot OR fold.leftSide - ELSE ReadNext(rd, fold) - END - ELSE ReadNext(rd, fold) - END - ELSE ReadNext(rd, fold) - END - END; - Models.EndScript(text, op); - Models.EndModification(Models.clean, text) - END CollapseFolds; - - PROCEDURE ZoomIn*; - VAR text: TextModels.Model; - BEGIN - text := TextViews.FocusText(); - IF text # NIL THEN ExpandFolds(text, FALSE, "") END - END ZoomIn; - - PROCEDURE ZoomOut*; - VAR text: TextModels.Model; - BEGIN - text := TextViews.FocusText(); - IF text # NIL THEN CollapseFolds(text, FALSE, "") END - END ZoomOut; - - PROCEDURE Expand*; - VAR text: TextModels.Model; - BEGIN - text := TextViews.FocusText(); - IF text # NIL THEN ExpandFolds(text, TRUE, "") END - END Expand; - - PROCEDURE Collapse*; - VAR text: TextModels.Model; - BEGIN - text := TextViews.FocusText(); - IF text # NIL THEN CollapseFolds(text, TRUE, "") END - END Collapse; - - (* ---------------------- foldData dialogbox --------------------------- *) - - PROCEDURE FindLabelGuard* (VAR par: Dialog.Par); - BEGIN - par.disabled := (TextViews.Focus() = NIL) OR foldData.all - END FindLabelGuard; - - PROCEDURE SetLabelGuard* ( VAR p : Dialog.Par ); - VAR v: Views.View; - BEGIN - Controllers.SetCurrentPath(Controllers.targetPath); - v := Containers.FocusSingleton(); - p.disabled := (v = NIL) OR ~(v IS Fold) OR ~v(Fold).leftSide; - Controllers.ResetCurrentPath() - END SetLabelGuard; - - PROCEDURE ExpandLabel*; - VAR text: TextModels.Model; - BEGIN - IF foldData.all & (foldData.findLabel # "") THEN - foldData.findLabel := ""; Dialog.Update(foldData) - END; - text := TextViews.FocusText(); - IF text # NIL THEN - IF ~foldData.all THEN ExpandFolds(text, foldData.nested, foldData.findLabel) - ELSE ExpandFolds(text, foldData.nested, "") - END - END - END ExpandLabel; - - PROCEDURE CollapseLabel*; - VAR text: TextModels.Model; - BEGIN - IF foldData.all & (foldData.findLabel # "") THEN - foldData.findLabel := ""; Dialog.Update(foldData) - END; - text := TextViews.FocusText(); - IF text # NIL THEN - IF ~foldData.all THEN CollapseFolds(text, foldData.nested, foldData.findLabel) - ELSE CollapseFolds(text, foldData.nested, "") - END - END - END CollapseLabel; - - PROCEDURE FindFold(first: BOOLEAN); - VAR c : TextControllers.Controller; r: TextModels.Reader; - v : Views.View; pos, i : INTEGER; - BEGIN - c := TextControllers.Focus(); - IF c # NIL THEN - IF first THEN pos := 0 - ELSE - pos := c.CaretPos(); - IF pos = TextControllers.none THEN - c.GetSelection(i, pos); - IF pos = i THEN pos := 0 ELSE INC(pos) END; - pos := MIN(pos, c.text.Length()-1) - END - END; - r := c.text.NewReader(NIL); r.SetPos(pos); - REPEAT r.ReadView(v) - UNTIL r.eot OR ((v IS Fold) & v(Fold).leftSide) & (foldData.all OR (v(Fold).label$ = foldData.findLabel$)); - IF r.eot THEN - c.SetCaret(0); Dialog.Beep - ELSE - pos := r.Pos(); - c.view.ShowRange(pos-1, pos, FALSE); - c.SetSelection(pos-1, pos); - IF LEN(v(Fold).label) > 0 THEN - foldData.newLabel := v(Fold).label - END; - Dialog.Update(foldData) - END - ELSE - Dialog.Beep - END - END FindFold; - - PROCEDURE FindNextFold*; - BEGIN - FindFold(FALSE) - END FindNextFold; - - PROCEDURE FindFirstFold*; - BEGIN - FindFold(TRUE) - END FindFirstFold; - - PROCEDURE SetLabel*; - VAR v: Views.View; - BEGIN - Controllers.SetCurrentPath(Controllers.targetPath); - v := Containers.FocusSingleton(); - IF (v # NIL) & (v IS Fold) & (LEN(foldData.newLabel) > 0) THEN - v(Fold).label := foldData.newLabel - ELSE - Dialog.Beep - END; - Controllers.ResetCurrentPath() - END SetLabel; - - PROCEDURE (a: Action) Do; - VAR v: Views.View; fp: INTEGER; - BEGIN - Controllers.SetCurrentPath(Controllers.targetPath); - v := Containers.FocusSingleton(); - IF (v = NIL) OR ~(v IS Fold) THEN - fingerprint := 0; - foldData.newLabel := "" - ELSE - fp := Services.AdrOf(v); - IF fp # fingerprint THEN - foldData.newLabel := v(Fold).label; - fingerprint := fp; - Dialog.Update(foldData) - END - END; - Controllers.ResetCurrentPath(); - Services.DoLater(action, Services.Ticks() + Services.resolution DIV 2) - END Do; - - (* ------------------------ inserting folds ------------------------ *) - - PROCEDURE Overlaps* (text: TextModels.Model; beg, end: INTEGER): BOOLEAN; - VAR n, level: INTEGER; rd: TextModels.Reader; v: Views.View; - BEGIN - ASSERT(text # NIL, 20); - ASSERT((beg >= 0) & (end <= text.Length()) & (beg <= end), 21); - rd := text.NewReader(NIL); rd.SetPos(beg); - n := 0; level := 0; - REPEAT rd.ReadView(v); - IF ~rd.eot & (rd.Pos() <= end) THEN - WITH v: Fold DO INC(n); - IF v.leftSide THEN INC(level) ELSE DEC(level) END - ELSE - END - END - UNTIL rd.eot OR (level < 0) OR (rd.Pos() >= end); - RETURN (level # 0) OR ODD(n) - END Overlaps; - - PROCEDURE InsertionAttr (text: TextModels.Model; pos: INTEGER): TextModels.Attributes; - VAR rd: TextModels.Reader; ch: CHAR; - BEGIN - rd := text.NewReader(NIL); - rd.SetPos(pos); rd.ReadChar(ch); - RETURN rd.attr - END InsertionAttr; - - PROCEDURE Insert* (text: TextModels.Model; label: Label; beg, end: INTEGER; collapsed: BOOLEAN); - VAR w: TextModels.Writer; fold: Fold; insop: Domains.Operation; a: TextModels.Attributes; - BEGIN - ASSERT(text # NIL, 20); - ASSERT((beg >= 0) & (end <= text.Length()) & (beg <= end), 21); - a := InsertionAttr(text, beg); - w := text.NewWriter(NIL); w.SetPos(beg); - IF a # NIL THEN w.SetAttr(a) END; - NEW(fold); - fold.leftSide := TRUE; fold.collapsed := collapsed; - fold.hidden := TextModels.CloneOf(text); Stores.Join(fold, fold.hidden); - fold.label := label$; - Models.BeginScript(text, insertFoldKey, insop); - w.WriteView(fold, 0, 0); - w.SetPos(end+1); - a := InsertionAttr(text, end+1); - IF a # NIL THEN w.SetAttr(a) END; - NEW(fold); - fold.leftSide := FALSE; fold.collapsed := collapsed; - fold.hidden := NIL; fold.label := ""; - w.WriteView(fold, 0, 0); - Models.EndScript(text, insop) - END Insert; - - PROCEDURE CreateGuard* (VAR par: Dialog.Par); - VAR c: TextControllers.Controller; beg, end: INTEGER; - BEGIN c := TextControllers.Focus(); - IF (c # NIL) & ~(Containers.noCaret IN c.opts) THEN - IF c.HasSelection() THEN c.GetSelection(beg, end); - IF Overlaps(c.text, beg, end) THEN par.disabled := TRUE END - END - ELSE par.disabled := TRUE - END - END CreateGuard; - - PROCEDURE Create* (state: INTEGER); (* menu cmd parameters don't accept Booleans *) - VAR c: TextControllers.Controller; beg, end: INTEGER; collapsed: BOOLEAN; - BEGIN - collapsed := state = 0; - c := TextControllers.Focus(); - IF (c # NIL) & ~(Containers.noCaret IN c.opts) THEN - IF c.HasSelection() THEN c.GetSelection(beg, end); - IF ~Overlaps(c.text, beg, end) THEN Insert(c.text, "", beg, end, collapsed) END - ELSE beg := c.CaretPos(); Insert(c.text, "", beg, beg, collapsed) - END - END - END Create; - - PROCEDURE InitIcons; - VAR font: Fonts.Font; - - PROCEDURE DefaultAppearance; - BEGIN - font := Fonts.dir.Default(); iconFont := font.typeface$; - leftExp := ">"; rightExp := "<"; - leftColl := "=>"; rightColl := "<="; - coloredBackg := TRUE - END DefaultAppearance; - - BEGIN - IF Dialog.platform = Dialog.linux THEN (* Linux *) - DefaultAppearance; - coloredBackg := FALSE - ELSIF Dialog.platform DIV 10 = 1 THEN (* Windows *) - iconFont := "Wingdings"; - font := Fonts.dir.This(iconFont, 10*Fonts.point (*arbitrary*), {}, Fonts.normal); - IF font.IsAlien() THEN DefaultAppearance - ELSE - leftExp[0] := SHORT(CHR(240)); leftExp[1] := 0X; - rightExp[0] := SHORT(CHR(239)); rightExp[1] := 0X; - leftColl[0] := SHORT(CHR(232)); leftColl[1] := 0X; - rightColl[0] := SHORT(CHR(231)); rightColl[1] := 0X; - coloredBackg := FALSE - END - ELSIF Dialog.platform DIV 10 = 2 THEN (* Mac *) - iconFont := "Chicago"; - font := Fonts.dir.This(iconFont, 10*Fonts.point (*arbitrary*), {}, Fonts.normal); - IF font.IsAlien() THEN DefaultAppearance - ELSE - leftExp := ">"; rightExp := "<"; - leftColl := "»"; rightColl := "«"; - coloredBackg := TRUE - END - ELSE - DefaultAppearance - END - END InitIcons; - - PROCEDURE (d: StdDirectory) New (collapsed: BOOLEAN; label: Label; - hiddenText: TextModels.Model): Fold; - VAR fold: Fold; - BEGIN - NEW(fold); fold.leftSide := hiddenText # NIL; fold.collapsed := collapsed; - fold.label := label; fold.hidden := hiddenText; - IF hiddenText # NIL THEN Stores.Join(fold, fold.hidden) END; - RETURN fold - END New; - - PROCEDURE SetDir* (d: Directory); - BEGIN - ASSERT(d # NIL, 20); - dir := d - END SetDir; - - PROCEDURE InitMod; - VAR d: StdDirectory; - BEGIN - foldData.all := TRUE; foldData.nested := FALSE; foldData.findLabel := ""; foldData.newLabel := ""; - NEW(d); dir := d; stdDir := d; - InitIcons; - NEW(action); Services.DoLater(action, Services.now); - END InitMod; - -BEGIN - InitMod -END StdFolds. diff --git a/new/Std/Mod/Headers.txt b/new/Std/Mod/Headers.txt deleted file mode 100644 index c87935c..0000000 --- a/new/Std/Mod/Headers.txt +++ /dev/null @@ -1,436 +0,0 @@ -MODULE StdHeaders; - - (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/Headers.odc *) - (* DO NOT EDIT *) - -(* headers / footers support the following macros: - - &p - replaced by current page number as arabic numeral - &r - replaced by current page number as roman numeral - &R - replaced by current page number as capital roman numeral - &a - replaced by current page number as alphanumeric character - &A - replaced by current page number as capital alphanumeric character - &d - replaced by printing date - &t - replaced by printing time - &&- replaced by & character - &; - specifies split point - &f - filename with path/title - -*) - - IMPORT - Stores, Ports, Models, Views, Properties, Printing, TextModels, Fonts, Dialog, - TextViews, Dates, Windows, Controllers, Containers; - - CONST - minVersion = 0; maxVersion = 2; - mm = Ports.mm; point = Ports.point; - maxWidth = 10000 * mm; - alternate* = 0; number* = 1; head* = 2; foot* = 3; showFoot* = 4; - - TYPE - Banner* = RECORD - left*, right*: ARRAY 128 OF CHAR; - gap*: INTEGER - END; - - NumberInfo* = RECORD - new*: BOOLEAN; - first*: INTEGER - END; - - View = POINTER TO RECORD (Views.View) - alternate: BOOLEAN; (* alternate left/right *) - number: NumberInfo; (* new page number *) - head, foot: Banner; - font: Fonts.Font; - showFoot: BOOLEAN; - END; - - Prop* = POINTER TO RECORD (Properties.Property) - alternate*, showFoot*: BOOLEAN; - number*: NumberInfo; - head*, foot*: Banner - END; - - ChangeFontOp = POINTER TO RECORD (Stores.Operation) - header: View; - font: Fonts.Font - END; - - ChangeAttrOp = POINTER TO RECORD (Stores.Operation) - header: View; - alternate, showFoot: BOOLEAN; - number: NumberInfo; - head, foot: Banner - END; - - VAR - dialog*: RECORD - view: View; - alternate*, showFoot*: BOOLEAN; - number*: NumberInfo; - head*, foot*: Banner; - END; - - PROCEDURE (p: Prop) IntersectWith* (q: Properties.Property; OUT equal: BOOLEAN); - VAR valid: SET; - PROCEDURE Equal(IN b1, b2: Banner): BOOLEAN; - BEGIN - RETURN (b1.left = b2.left) & (b1.right = b2.right) & (b1.gap = b2.gap) - END Equal; - BEGIN - WITH q: Prop DO - valid := p.valid * q.valid; equal := TRUE; - IF p.alternate # q.alternate THEN EXCL(valid, alternate) END; - IF p.showFoot # q.showFoot THEN EXCL(valid, showFoot) END; - IF (p.number.new # q.number.new) OR (p.number.first # q.number.first) THEN EXCL(valid, number) END; - IF ~Equal(p.head, q.head) THEN EXCL(valid, head) END; - IF ~Equal(p.foot, q.foot) THEN EXCL(valid, foot) END; - IF p.valid # valid THEN p.valid := valid; equal := FALSE END - END - END IntersectWith; - - (* SetAttrOp *) - - PROCEDURE (op: ChangeFontOp) Do; - VAR v: View; font: Fonts.Font; asc, dsc, w: INTEGER; c: Models.Context; - BEGIN - v := op.header; - font := op.font; op.font := v.font; v.font := font; - font.GetBounds(asc, dsc, w); - c := v.context; - c.SetSize(maxWidth, asc + dsc + 2*point); - Views.Update(v, Views.keepFrames) - END Do; - - PROCEDURE DoChangeFontOp (v: View; font: Fonts.Font); - VAR op: ChangeFontOp; - BEGIN - IF v.font # font THEN - NEW(op); op.header := v; op.font := font; - Views.Do(v, "#System:SetProp", op) - END - END DoChangeFontOp; - - PROCEDURE (op: ChangeAttrOp) Do; - VAR v: View; alternate, showFoot: BOOLEAN; number: NumberInfo; head, foot: Banner; - BEGIN - v := op.header; - alternate := op.alternate; showFoot := op.showFoot; number := op.number; head := op.head; foot := op.foot; - op.alternate := v.alternate; op.showFoot := v.showFoot; op.number := v.number; op.head := v.head; - op.foot := v.foot; - v.alternate := alternate; v.showFoot := showFoot; v.number := number; v.head := head; v.foot := foot; - Views.Update(v, Views.keepFrames) - END Do; - - PROCEDURE DoChangeAttrOp (v: View; alternate, showFoot: BOOLEAN; number: NumberInfo; - head, foot: Banner); - VAR op: ChangeAttrOp; - BEGIN - NEW(op); op.header := v; op.alternate := alternate; op.showFoot := showFoot; - op.number := number; op.head := head; op.foot := foot; - Views.Do(v, "#Std:HeaderChange", op) - END DoChangeAttrOp; - - PROCEDURE (v: View) CopyFromSimpleView (source: Views.View); - BEGIN - WITH source: View DO - v.alternate := source.alternate; - v.number.new := source.number.new; v.number.first := source.number.first; - v.head := source.head; - v.foot := source.foot; - v.font := source.font; - v.showFoot := source.showFoot - END - END CopyFromSimpleView; - - PROCEDURE (v: View) Externalize (VAR wr: Stores.Writer); - BEGIN - v.Externalize^(wr); - wr.WriteVersion(maxVersion); - wr.WriteString(v.head.left); - wr.WriteString(v.head.right); - wr.WriteInt(v.head.gap); - wr.WriteString(v.foot.left); - wr.WriteString(v.foot.right); - wr.WriteInt(v.foot.gap); - wr.WriteString(v.font.typeface); - wr.WriteInt(v.font.size); - wr.WriteSet(v.font.style); - wr.WriteInt(v.font.weight); - wr.WriteBool(v.alternate); - wr.WriteBool(v.number.new); - wr.WriteInt(v.number.first); - wr.WriteBool(v.showFoot); - END Externalize; - - PROCEDURE (v: View) Internalize (VAR rd: Stores.Reader); - VAR version: INTEGER; typeface: Fonts.Typeface; size: INTEGER; style: SET; weight: INTEGER; - - BEGIN - v.Internalize^(rd); - IF ~rd.cancelled THEN - rd.ReadVersion(minVersion, maxVersion, version); - IF ~rd.cancelled THEN - IF version = 0 THEN - rd.ReadXString(v.head.left); - rd.ReadXString(v.head.right); - v.head.gap := 5*mm; - rd.ReadXString(v.foot.left); - rd.ReadXString(v.foot.right); - v.foot.gap := 5*mm; - rd.ReadXString(typeface); - rd.ReadXInt(size); - v.font := Fonts.dir.This(typeface, size * point, {}, Fonts.normal); - rd.ReadXInt(v.number.first); - rd.ReadBool(v.number.new); - rd.ReadBool(v.alternate) - ELSE - rd.ReadString(v.head.left); - rd.ReadString(v.head.right); - rd.ReadInt(v.head.gap); - rd.ReadString(v.foot.left); - rd.ReadString(v.foot.right); - rd.ReadInt(v.foot.gap); - rd.ReadString(typeface); - rd.ReadInt(size); - rd.ReadSet(style); - rd.ReadInt(weight); - v.font := Fonts.dir.This(typeface, size, style, weight); - rd.ReadBool(v.alternate); - rd.ReadBool(v.number.new); - rd.ReadInt(v.number.first); - IF version = 2 THEN rd.ReadBool(v.showFoot) ELSE v.showFoot := FALSE END - END - END - END - END Internalize; - - PROCEDURE SetProp(v: View; msg: Properties.SetMsg); - VAR p: Properties.Property; - typeface: Fonts.Typeface; size: INTEGER; style: SET; weight: INTEGER; - alt, sf: BOOLEAN; num: NumberInfo; h, f: Banner; - BEGIN - p := msg.prop; - WHILE p # NIL DO - WITH p: Properties.StdProp DO - IF Properties.typeface IN p.valid THEN typeface := p.typeface - ELSE typeface := v.font.typeface - END; - IF Properties.size IN p.valid THEN size := p.size - ELSE size := v.font.size - END; - IF Properties.style IN p.valid THEN style := p.style.val - ELSE style := v.font.style - END; - IF Properties.weight IN p.valid THEN weight := p.weight - ELSE weight := v.font.weight - END; - DoChangeFontOp (v, Fonts.dir.This(typeface, size, style, weight) ); - | p: Prop DO - IF alternate IN p.valid THEN alt := p.alternate ELSE alt := v.alternate END; - IF showFoot IN p.valid THEN sf := p.showFoot ELSE sf := v.showFoot END; - IF number IN p.valid THEN num := p.number ELSE num := v.number END; - IF head IN p.valid THEN h := p.head ELSE h := v.head END; - IF foot IN p.valid THEN f := p.foot ELSE f := v.foot END; - DoChangeAttrOp(v, alt, sf, num, h, f) - ELSE - END; - p := p.next - END - END SetProp; - - PROCEDURE PollProp(v: View; VAR msg: Properties.PollMsg); - VAR sp: Properties.StdProp; p: Prop; - BEGIN - NEW(sp); - sp.known := {Properties.size, Properties.typeface, Properties.style, Properties.weight}; - sp.valid := sp.known; - sp.size := v.font.size; sp.typeface := v.font.typeface; - sp.style.val := v.font.style; sp.style.mask := {Fonts.italic, Fonts.underline, Fonts.strikeout}; - sp.weight := v.font.weight; - Properties.Insert(msg.prop, sp); - NEW(p); - p.known := {alternate, number, head, foot, showFoot}; p.valid := p.known; - p.head := v.head; p.foot := v.foot; - p.alternate := v.alternate; - p.showFoot := v.showFoot; - p.number := v.number; - Properties.Insert(msg.prop, p) - END PollProp; - - PROCEDURE PageMsg(v: View; msg: TextViews.PageMsg); - BEGIN - IF Printing.par # NIL THEN - Dialog.MapString(v.head.left, Printing.par.header.left); - Dialog.MapString(v.head.right, Printing.par.header.right); - Dialog.MapString(v.foot.left, Printing.par.footer.left); - Dialog.MapString(v.foot.right, Printing.par.footer.right); - Printing.par.header.font := v.font; - Printing.par.footer.font := v.font; - Printing.par.page.alternate := v.alternate; - IF v.number.new THEN - Printing.par.page.first := v.number.first - msg.current - END; - Printing.par.header.gap := 5*Ports.mm; - Printing.par.footer.gap := 5*Ports.mm - END - END PageMsg; - - PROCEDURE (v: View) Restore (f: Views.Frame; l, t, r, b: INTEGER); - VAR d, w, h: INTEGER; (*line: Line; *)asc, dsc, x0, x1, y: INTEGER; - win: Windows.Window; title: Views.Title; dec: BOOLEAN; - pw, ph: INTEGER; - date: Dates.Date; time: Dates.Time; pageInfo: Printing.PageInfo; banner: Printing.Banner; - BEGIN - IF Views.IsPrinterFrame(f) THEN (* am drucken *) END; - - v.font.GetBounds(asc, dsc, w); - - win := Windows.dir.First(); - WHILE (win # NIL) & (win.doc.Domain() # v.Domain()) DO win := Windows.dir.Next(win) END; - IF win = NIL THEN title := "(" + Dialog.appName + ")" - ELSE win.GetTitle(title) - END; - d := f.dot; - v.context.GetSize(w, h); - win.doc.PollPage(pw, ph, l, t, r, b, dec); - w := r - l; - - f.DrawRect(0, 0, w, h, Ports.fill, Ports.grey25); - f.DrawRect(0, 0, w, h, 0, Ports.black); - - x0 := d; x1 := w-2*d; y := asc + d; - - Dates.GetDate(date); - Dates.GetTime(time); - pageInfo.alternate := FALSE; - pageInfo.title := title; - banner.font := v.font; - IF v.showFoot THEN - banner.gap := v.foot.gap; - Dialog.MapString(v.foot.left, banner.left); Dialog.MapString(v.foot.right, banner.right) - ELSE - banner.gap := v.head.gap; - Dialog.MapString(v.head.left, banner.left); Dialog.MapString(v.head.right, banner.right) - END; - Printing.PrintBanner(f, pageInfo, banner, date, time, x0, x1, y) - END Restore; - - PROCEDURE (v: View) HandlePropMsg (VAR msg: Properties.Message); - VAR asc, dsc, w: INTEGER; - BEGIN - WITH msg: Properties.SizePref DO - msg.w := maxWidth; - IF msg.h = Views.undefined THEN - v.font.GetBounds(asc, dsc, w); - msg.h := asc + dsc + 2*point - END - | msg: Properties.ResizePref DO - msg.fixed := TRUE - | msg: TextModels.Pref DO - msg.opts := {TextModels.hideable} - | msg: Properties.PollMsg DO - PollProp(v, msg) - | msg: Properties.SetMsg DO - SetProp(v, msg) - | msg: TextViews.PageMsg DO - PageMsg(v, msg) - ELSE - END - END HandlePropMsg; - - PROCEDURE (v: View) HandleCtrlMsg (f: Views.Frame; VAR msg: Controllers.Message; - VAR focus: Views.View); - BEGIN - WITH msg: Properties.EmitMsg DO Views.HandlePropMsg(v, msg.set) - | msg: Properties.CollectMsg DO Views.HandlePropMsg(v, msg.poll) - ELSE - END - END HandleCtrlMsg; - - PROCEDURE New*(p: Prop; f: Fonts.Font): Views.View; - VAR v: View; - BEGIN - NEW(v); - v.head := p.head; - v.foot := p.foot; - v.number := p.number; - v.alternate := p.alternate; - v.font := f; - v.showFoot := FALSE; - RETURN v; - END New; - - PROCEDURE Deposit*; - VAR v: View; - BEGIN - NEW(v); - v.head.left := ""; v.head.right := "&d&;&p"; v.head.gap := 5*mm; - v.foot.left := ""; v.foot.right := ""; v.foot.gap := 5*mm; - v.font := Fonts.dir.Default(); - v.number.first := 1; v.number.new := FALSE; v.alternate := FALSE; v.showFoot := FALSE; - Views.Deposit(v) - END Deposit; - - (* property dialog *) - - PROCEDURE InitDialog*; - VAR p: Properties.Property; - BEGIN - Properties.CollectProp(p); - WHILE p # NIL DO - WITH p: Properties.StdProp DO - | p: Prop DO - dialog.alternate := p.alternate; dialog.showFoot := p.showFoot; - dialog.number := p.number; - dialog.head := p.head; dialog.head.gap := dialog.head.gap DIV point; - dialog.foot := p.foot; dialog.foot.gap := dialog.foot.gap DIV point; - Dialog.Update(dialog) - ELSE - END; - p := p.next - END - END InitDialog; - - PROCEDURE Set*; - VAR p: Prop; - BEGIN - NEW(p); p.valid := {alternate, number, head, foot, showFoot}; - p.alternate := dialog.alternate; p.showFoot := dialog.showFoot; - p.number := dialog.number; - p.head := dialog.head; p.head.gap := p.head.gap * point; - p.foot := dialog.foot; p.foot.gap := p.foot.gap * point; - Properties.EmitProp(NIL, p) - END Set; - - PROCEDURE HeaderGuard* (VAR par: Dialog.Par); - VAR v: Views.View; - BEGIN - v := Containers.FocusSingleton(); - IF (v # NIL) & (v IS View) THEN - par.disabled := FALSE; - IF (dialog.view = NIL) OR (dialog.view # v) THEN - dialog.view := v(View); - InitDialog - END - ELSE - par.disabled := TRUE; - dialog.view := NIL - END - END HeaderGuard; - - PROCEDURE AlternateGuard* (VAR par: Dialog.Par); - BEGIN - HeaderGuard(par); - IF ~par.disabled THEN par.disabled := ~ dialog.alternate END - END AlternateGuard; - - PROCEDURE NewNumberGuard* (VAR par: Dialog.Par); - BEGIN - HeaderGuard(par); - IF ~par.disabled THEN par.disabled := ~ dialog.number.new END - END NewNumberGuard; - -END StdHeaders. diff --git a/new/Std/Mod/Interpreter.txt b/new/Std/Mod/Interpreter.txt deleted file mode 100644 index b619a2c..0000000 --- a/new/Std/Mod/Interpreter.txt +++ /dev/null @@ -1,234 +0,0 @@ -MODULE StdInterpreter; - - (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/Interpreter.odc *) - (* DO NOT EDIT *) - - IMPORT Kernel, Meta, Strings, Views, Dialog; - - TYPE - IntValue = POINTER TO RECORD (Meta.Value) - int: INTEGER; - END; - StrValue = POINTER TO RECORD (Meta.Value) - str: Dialog.String; - END; - CallHook = POINTER TO RECORD (Dialog.CallHook) END; - - - PROCEDURE (hook: CallHook) Call (IN proc, errorMsg: ARRAY OF CHAR; VAR res: INTEGER); - TYPE Ident = ARRAY 32 OF CHAR; - CONST - modNotFound = 10; procNotFound = 11; identExpected = 12; unknownIdent = 13; - depositExpected = 14; noDepositExpected = 15; syntaxError = 16; - lparenExpected = 17; rparenExpected = 18; containerExpected = 19; quoteExpected = 20; - fileNotFound = 21; noController = 22; noDialog = 23; cannotUnload = 24; commaExpected = 25; - incompParList = 26; - CONST - ident = 0; dot = 1; semicolon = 2; eot = 3; lparen = 4; rparen = 5; quote = 6; comma = 7; int = 8; - VAR - i, type: INTEGER; ch: CHAR; id: Ident; x: INTEGER; - par: ARRAY 100 OF POINTER TO Meta.Value; numPar: INTEGER; - - PROCEDURE Concat (a, b: ARRAY OF CHAR; VAR c: ARRAY OF CHAR); - VAR i, j: INTEGER; ch: CHAR; - BEGIN - IF a = " " THEN Dialog.MapString("#System:CommandError", c) ELSE c := a$ END; - i := 0; WHILE c[i] # 0X DO INC(i) END; - c[i] := " "; INC(i); - j := 0; ch := b[0]; WHILE ch # 0X DO c[i] := ch; INC(i); INC(j); ch := b[j] END; - c[i] := 0X - END Concat; - - PROCEDURE Error (n: INTEGER; msg, par0, par1: ARRAY OF CHAR); - VAR e, f: ARRAY 256 OF CHAR; - BEGIN - IF res = 0 THEN - res := n; - IF errorMsg # "" THEN - Dialog.MapString(errorMsg, e); - Dialog.MapParamString(msg, par0, par1, "", f); - Concat(e, f, f); - Dialog.ShowMsg(f) - END - END - END Error; - - PROCEDURE Init (VAR s: ARRAY OF CHAR); - VAR i: INTEGER; - BEGIN - i := 0; WHILE i < LEN(s) DO s[i] := 0X; INC(i) END - END Init; - - PROCEDURE ShowLoaderResult (IN mod: ARRAY OF CHAR); - VAR res: INTEGER; importing, imported, object: ARRAY 256 OF CHAR; - BEGIN - Kernel.GetLoaderResult(res, importing, imported, object); - CASE res OF - | Kernel.fileNotFound: - Error(Kernel.fileNotFound, "#System:CodeFileNotFound", imported, "") - | Kernel.syntaxError: - Error(Kernel.syntaxError, "#System:CorruptedCodeFileFor", imported, "") - | Kernel.objNotFound: - Error(Kernel.objNotFound, "#System:ObjNotFoundImpFrom", imported, importing) - | Kernel.illegalFPrint: - Error(Kernel.illegalFPrint, "#System:ObjInconsImpFrom", imported, importing) - | Kernel.cyclicImport: - Error(Kernel.cyclicImport, "#System:CyclicImpFrom", imported, importing) - | Kernel.noMem: - Error(Kernel.noMem, "#System:NotEnoughMemoryFor", imported, "") - ELSE - Error(res, "#System:CannotLoadModule", mod, "") - END - END ShowLoaderResult; - - PROCEDURE CallProc (IN mod, proc: ARRAY OF CHAR); - VAR i, t: Meta.Item; ok: BOOLEAN; - BEGIN - ok := FALSE; - Meta.Lookup(mod, i); - IF i.obj = Meta.modObj THEN - i.Lookup(proc, i); - IF i.obj = Meta.procObj THEN - i.GetReturnType(t); - IF (t.typ = 0) & (i.NumParam() = numPar) THEN - i.ParamCallVal(par, t, ok) - ELSE ok := FALSE - END; - IF ~ok THEN - Error(incompParList, "#System:IncompatibleParList", mod, proc) - END - ELSE - Error(Kernel.commNotFound, "#System:CommandNotFoundIn", proc, mod) - END - ELSE - ShowLoaderResult(mod) - END - END CallProc; - - PROCEDURE GetCh; - BEGIN - IF i < LEN(proc) THEN ch := proc[i]; INC(i) ELSE ch := 0X END - END GetCh; - - PROCEDURE Scan; - VAR j: INTEGER; num: ARRAY 32 OF CHAR; r: INTEGER; - BEGIN - IF res = 0 THEN - WHILE (ch # 0X) & (ch <= " ") DO GetCh END; - IF ch = 0X THEN - type := eot - ELSIF ch = "." THEN - type := dot; GetCh - ELSIF ch = ";" THEN - type := semicolon; GetCh - ELSIF ch = "(" THEN - type := lparen; GetCh - ELSIF ch = ")" THEN - type := rparen; GetCh - ELSIF ch = "'" THEN - type := quote; GetCh - ELSIF ch = "," THEN - type := comma; GetCh - ELSIF (ch >= "0") & (ch <= "9") OR (ch = "-") THEN - type := int; j := 0; - REPEAT num[j] := ch; INC(j); GetCh UNTIL (ch < "0") OR (ch > "9") & (ch < "A") OR (ch > "H"); - num[j] := 0X; Strings.StringToInt(num, x, r) - ELSIF (ch >= "a") & (ch <= "z") OR (ch >= "A") & (ch <= "Z") OR - (ch >= 0C0X) & (ch # "×") & (ch # "÷") & (ch <= 0FFX) OR (ch = "_") THEN - type := ident; - id[0] := ch; j := 1; GetCh; - WHILE (ch # 0X) & (i < LEN(proc)) & - ((ch >= "a") & (ch <= "z") OR (ch >= "A") & (ch <= "Z") OR - (ch >= 0C0X) & (ch # "×") & (ch # "÷") & (ch <= 0FFX) OR - (ch = "_") OR (ch >= "0") & (ch <= "9")) DO - id[j] := ch; INC(j); GetCh - END; - id[j] := 0X - ELSE Error(syntaxError, "#System:SyntaxError", "", "") - END - END - END Scan; - - PROCEDURE String (VAR s: ARRAY OF CHAR); - VAR j: INTEGER; - BEGIN - IF type = quote THEN - j := 0; - WHILE (ch # 0X) & (ch # "'") & (j < LEN(s) - 1) DO s[j] := ch; INC(j); GetCh END; s[j] := 0X; - IF ch = "'" THEN - GetCh; Scan - ELSE Error(quoteExpected, "#System:QuoteExpected", "", "") - END - ELSE Error(quoteExpected, "#System:QuoteExpected", "", "") - END - END String; - - PROCEDURE ParamList (); - VAR iv: IntValue; sv: StrValue; - BEGIN - numPar := 0; - IF type = lparen THEN Scan; - WHILE (numPar < LEN(par)) & (type # rparen) & (res = 0) DO - IF type = quote THEN - NEW(sv); - String(sv.str); - par[numPar] := sv; - INC(numPar) - ELSIF type = int THEN - NEW(iv); - iv.int := x; Scan; - par[numPar] := iv; - INC(numPar) - ELSE Error(syntaxError, "#System:SyntaxError", "", "") - END; - IF type = comma THEN Scan - ELSIF type # rparen THEN Error(rparenExpected, "#System:RParenExpected", "", "") - END - END; - Scan - END - END ParamList; - - PROCEDURE Command; - VAR left, right: Ident; - BEGIN - (* protect from parasitic anchors on stack *) - Init(left); Init(right); - left := id; Scan; - IF type = dot THEN (* Oberon command *) - Scan; - IF type = ident THEN - right := id; Scan; ParamList(); - CallProc(left, right) - ELSE Error(identExpected, "#System:IdentExpected", "", "") - END - ELSE Error(unknownIdent, "#System:UnknownIdent", id, "") - END - END Command; - - BEGIN - (* protect from parasitic anchors on stack *) - i := 0; type := 0; Init(id); x := 0; - Views.ClearQueue; - res := 0; i := 0; GetCh; - Scan; - IF type = ident THEN - Command; WHILE (type = semicolon) & (res = 0) DO Scan; Command END; - IF type # eot THEN Error(syntaxError, "#System:SyntaxError", "", "") END - ELSE Error(syntaxError, "#System:SyntaxError", "", "") - END; - IF (res = 0) & (Views.Available() > 0) THEN - Error(noDepositExpected, "#System:NoDepositExpected", "", "") - END; - Views.ClearQueue - END Call; - - PROCEDURE Init; - VAR hook: CallHook; - BEGIN - NEW(hook); Dialog.SetCallHook(hook) - END Init; - -BEGIN - Init -END StdInterpreter. diff --git a/new/Std/Mod/Links.txt b/new/Std/Mod/Links.txt deleted file mode 100644 index 7bc3bbc..0000000 --- a/new/Std/Mod/Links.txt +++ /dev/null @@ -1,893 +0,0 @@ -MODULE StdLinks; - - (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/Links.odc *) - - IMPORT Kernel, Services, - Stores, Ports, Fonts, Models, Views, Controllers, Properties, Dialog, Containers, - TextModels, TextMappers, TextViews, TextControllers, TextSetters, TextRulers, - Strings, StdCmds; - - CONST - kind* = 0; cmd* = 1; close* = 2; (* constants for Prop.valid *) - always* = 0; ifShiftDown* = 1; never* = 2; (* constants for close attrubute *) - minLinkVersion = 0; maxLinkVersion = 1; - minTargVersion = 0; maxTargVersion = 0; - - TYPE - Directory* = POINTER TO ABSTRACT RECORD END; - - Link* = POINTER TO RECORD (Views.View) - leftSide-: BOOLEAN; - cmd: POINTER TO ARRAY OF CHAR; - close: INTEGER - END; - - Target* = POINTER TO RECORD (Views.View) - leftSide-: BOOLEAN; - ident: POINTER TO ARRAY OF CHAR - END; - - Prop* = POINTER TO RECORD (Properties.Property) - cmd*: POINTER TO ARRAY OF CHAR; - link-: BOOLEAN; - close*: INTEGER - END; - - ChangeAttrOp = POINTER TO RECORD (Stores.Operation) - v: Views.View; - cmd: POINTER TO ARRAY OF CHAR; - close: INTEGER; - valid: SET - END; - - StdDirectory = POINTER TO RECORD (Directory) END; - - TrapCleaner = POINTER TO RECORD (Kernel.TrapCleaner) END; - - VAR - dir-, stdDir-: Directory; - par-: Link; - iconFont: Fonts.Typeface; - linkLeft, linkRight, targetLeft, targetRight: ARRAY 8 OF SHORTCHAR; - coloredBackg: BOOLEAN; - - cleaner: TrapCleaner; - - dialog*: RECORD - cmd*: ARRAY 512 OF CHAR; - type-: ARRAY 32 OF CHAR; - close*: Dialog.List; - known, valid: SET; - END; - fingerprint: INTEGER; - - (** Cleaner **) - - PROCEDURE (c: TrapCleaner) Cleanup; - BEGIN - par := NIL - END Cleanup; - - (** Properties **) - - PROCEDURE (p: Prop) IntersectWith* (q: Properties.Property; OUT equal: BOOLEAN); - VAR valid: SET; - BEGIN - WITH q: Prop DO - valid := p.valid * q.valid; equal := TRUE; - IF (cmd IN valid) & (p.cmd^ # q.cmd^) THEN EXCL(valid, cmd) END; - IF (kind IN valid) & (p.link # q.link) THEN EXCL(valid, kind) END; - IF (close IN valid) & (p.close # q.close) THEN EXCL (valid, close) END; - IF p.valid # valid THEN p.valid := valid; equal := FALSE END - END - END IntersectWith; - - PROCEDURE (op: ChangeAttrOp) Do; - VAR v: Views.View; s: POINTER TO ARRAY OF CHAR; c: INTEGER; - BEGIN - v := op.v; - WITH - | v: Link DO - IF cmd IN op.valid THEN s := op.cmd; op.cmd := v.cmd; v.cmd := s END; - IF close IN op.valid THEN c := op.close; op.close := v.close; v.close := c END - | v: Target DO - IF cmd IN op.valid THEN s := op.cmd; op.cmd := v.ident; v.ident := s END - END - END Do; - - PROCEDURE DoChangeAttrOp (v: Views.View; s: POINTER TO ARRAY OF CHAR; c: INTEGER; valid: SET); - VAR op: ChangeAttrOp; - BEGIN - NEW(op); op.v := v; op.valid := valid; - IF close IN valid THEN - op.close := c END; - IF cmd IN valid THEN NEW(op.cmd, LEN(s)+1); op.cmd^ := s$ END; - Views.Do(v, "#Std:LinkChange", op) - END DoChangeAttrOp; - - PROCEDURE SetProp(v: Views.View; msg: Properties.SetMsg); - VAR p: Properties.Property; - BEGIN - p := msg.prop; - WHILE p # NIL DO - WITH p: Prop DO - IF (cmd IN p.valid) OR (close IN p.valid) THEN DoChangeAttrOp(v, p.cmd, p.close, p.valid) END - ELSE - END; - p := p.next - END - END SetProp; - - PROCEDURE PollProp(v: Views.View; VAR msg: Properties.PollMsg); - VAR p: Prop; - BEGIN - NEW(p); - WITH v: Link DO - p.known := {kind, cmd, close}; - p.link := TRUE; - p.cmd := v.cmd; - p.close := v.close - | v: Target DO - p.known := {kind, cmd}; - p.link := FALSE; - p.cmd := v.ident - ELSE - END; - p.valid := p.known; - Properties.Insert(msg.prop, p) - END PollProp; - - PROCEDURE InitDialog*; - VAR p: Properties.Property; - BEGIN - dialog.cmd := ""; dialog.type := ""; dialog.close.index := -1; - dialog.known := {}; dialog.valid := {}; - Properties.CollectProp(p); - WHILE p # NIL DO - WITH p: Prop DO - dialog.valid := p.valid; dialog.known := p.known; - IF cmd IN p.valid THEN - dialog.cmd := p.cmd$ - END; - IF kind IN p.valid THEN - IF p.link THEN Dialog.MapString("#Std:Link", dialog.type) - ELSE Dialog.MapString("#Std:Target", dialog.type) - END - END; - IF close IN p.valid THEN - dialog.close.index := p.close - END - ELSE - END; - p := p.next - END; - Dialog.Update(dialog) - END InitDialog; - - PROCEDURE Set*; - VAR p: Prop; - BEGIN - NEW(p); - p.valid := dialog.valid; - IF cmd IN p.valid THEN - NEW(p.cmd, LEN(dialog.cmd) + 1); - p.cmd^ := dialog.cmd$ - END; - p.close := dialog.close.index; - Properties.EmitProp(NIL, p); - fingerprint := 0 (* force actualization of fields *) - END Set; - - PROCEDURE CmdGuard* (VAR par: Dialog.Par); - VAR c: Containers.Controller; v: Views.View; fp: INTEGER; - BEGIN - IF ~(cmd IN dialog.known) THEN par.disabled := TRUE - ELSIF ~(cmd IN dialog.valid) THEN par.undef := TRUE - END; - Controllers.SetCurrentPath(Controllers.targetPath); - fp := 0; - c := Containers.Focus(); - IF c # NIL THEN - c.GetFirstView(Containers.selection, v); - WHILE v # NIL DO fp := fp + Services.AdrOf(v); c.GetNextView(TRUE, v) END - END; - IF fp # fingerprint THEN fingerprint := fp; InitDialog END; - Controllers.ResetCurrentPath() - END CmdGuard; - - PROCEDURE CloseGuard* (VAR par: Dialog.Par); - BEGIN - IF ~(close IN dialog.known) THEN par.disabled := TRUE - ELSIF ~(close IN dialog.valid) THEN par.undef := TRUE - END; - END CloseGuard; - - PROCEDURE Notifier* (idx, op, from, to: INTEGER); - BEGIN - IF op = Dialog.changed THEN INCL(dialog.valid, idx) END - END Notifier; - - PROCEDURE (d: Directory) NewLink* (IN cmd: ARRAY OF CHAR): Link, NEW, ABSTRACT; - PROCEDURE (d: Directory) NewTarget* (IN ident: ARRAY OF CHAR): Target, NEW, ABSTRACT; - - - PROCEDURE InFrame (f: Views.Frame; x, y: INTEGER): BOOLEAN; - BEGIN - RETURN (f.l <= x) & (x < f.r) & (f.t <= y) & (y < f.b) - END InFrame; - - PROCEDURE Mark (f: Views.Frame; show: BOOLEAN); - BEGIN - f.MarkRect(f.l, f.t, f.r, f.b, Ports.fill, Ports.hilite, show) - END Mark; - - PROCEDURE ThisPos (v: TextViews.View; f: Views.Frame; x, y: INTEGER): INTEGER; - (* "corrected" v.ThisPos: does not adjust position when crossing 50% boundary of characters *) - VAR loc: TextViews.Location; pos: INTEGER; - BEGIN - pos := v.ThisPos(f, x, y); v.GetThisLocation(f, pos, loc); - IF (loc.y <= y) & (y < loc.y + loc.asc + loc.dsc) & (x < loc.x) THEN DEC(pos) END; - RETURN pos - END ThisPos; - - PROCEDURE GetLinkPair (this: Link; VAR l, r: Link); - (* POST: BalancedPair(l, r) & (l # r) & (l = this OR r = this) OR (l = r = NIL) *) - VAR t: TextModels.Model; rd: TextModels.Reader; v: Views.View; level: INTEGER; - BEGIN - l := NIL; r := NIL; level := 1; - IF (this.context # NIL) & (this.context IS TextModels.Context) THEN - t := this.context(TextModels.Context).ThisModel(); - rd := t.NewReader(NIL); - IF this.leftSide THEN - rd.SetPos(this.context(TextModels.Context).Pos() + 1); - REPEAT - rd.ReadView(v); - IF (v # NIL) & (v IS Link) THEN - IF v(Link).leftSide THEN INC(level) ELSE DEC(level) END - END - UNTIL (v = NIL) OR (level = 0); - IF v # NIL THEN l := this; r := v(Link) END - ELSE - rd.SetPos(this.context(TextModels.Context).Pos()); - REPEAT - rd.ReadPrevView(v); - IF (v # NIL) & (v IS Link) THEN - IF v(Link).leftSide THEN DEC(level) ELSE INC(level) END - END - UNTIL (v = NIL) OR (level = 0); - IF v # NIL THEN l := v(Link); r := this END - END - END - END GetLinkPair; - - PROCEDURE GetTargetPair (this: Target; VAR l, r: Target); - (* POST: BalancedPair(l, r) & (l # r) & (l = this OR r = this) OR (l = r = NIL) *) - VAR t: TextModels.Model; rd: TextModels.Reader; v: Views.View; level: INTEGER; - BEGIN - l := NIL; r := NIL; level := 1; - IF (this.context # NIL) & (this.context IS TextModels.Context) THEN - t := this.context(TextModels.Context).ThisModel(); - rd := t.NewReader(NIL); - IF this.leftSide THEN - rd.SetPos(this.context(TextModels.Context).Pos() + 1); - REPEAT - rd.ReadView(v); - IF (v # NIL) & (v IS Target) THEN - IF v(Target).leftSide THEN INC(level) ELSE DEC(level) END - END - UNTIL (v = NIL) OR (level = 0); - IF v # NIL THEN l := this; r := v(Target) END - ELSE - rd.SetPos(this.context(TextModels.Context).Pos()); - REPEAT - rd.ReadPrevView(v); - IF (v # NIL) & (v IS Target) THEN - IF v(Target).leftSide THEN DEC(level) ELSE INC(level) END - END - UNTIL (v = NIL) OR (level = 0); - IF v # NIL THEN l := v(Target); r := this END - END - END - END GetTargetPair; - - PROCEDURE GetRange (l, r: Link; VAR beg, end: INTEGER); - BEGIN - beg := l.context(TextModels.Context).Pos(); - end := r.context(TextModels.Context).Pos() + 1 - END GetRange; - - PROCEDURE MarkRange (v: TextViews.View; f: Views.Frame; beg, end: INTEGER; show: BOOLEAN); - VAR b, e: TextViews.Location; r, t: INTEGER; - BEGIN - ASSERT(beg < end, 20); - v.GetThisLocation(f, beg, b); v.GetThisLocation(f, end, e); - IF (b.pos < e.pos) OR (b.pos = e.pos) & (b.x < e.x) THEN - IF b.start # e.start THEN - r := f.r; t := b.y + b.asc + b.dsc; - f.MarkRect(b.x, b.y, r, t, Ports.fill, Ports.hilite, show); - IF t < e.y THEN f.MarkRect(0, t, r, e.y, Ports.fill, Ports.hilite, show) END; - b.x := f.l; b.y := e.y - END; - f.MarkRect(b.x, b.y, e.x, e.y + e.asc + e.dsc, Ports.fill, Ports.hilite, show) - END - END MarkRange; - - PROCEDURE Reveal (left, right: Views.View; str: ARRAY OF CHAR; opname: Stores.OpName); - VAR con: TextModels.Context; t: TextModels.Model; pos: INTEGER; - w: TextMappers.Formatter; op: Stores.Operation; - BEGIN - con := left.context(TextModels.Context); - t := con.ThisModel(); pos := con.Pos(); - w.ConnectTo(t); w.SetPos(pos); - IF con.Attr() # NIL THEN w.rider.SetAttr(con.Attr()) END; - Models.BeginScript(t, opname, op); - t.Delete(pos, pos + 1); - w.WriteChar("<"); - IF str # "" THEN w.WriteString(str) END; - w.WriteChar(">"); - con := right.context(TextModels.Context); - pos := con.Pos(); - w.SetPos(pos); - IF con.Attr() # NIL THEN w.rider.SetAttr(con.Attr()) END; - t.Delete(pos, pos + 1); - w.WriteString("<>"); - Models.EndScript(t, op) - END Reveal; - - PROCEDURE RevealCmd (v: Link); - VAR left, right: Link; - BEGIN GetLinkPair(v, left, right); - IF left # NIL THEN - IF v.cmd # NIL THEN Reveal(left, right, v.cmd^, "#StdLinks:Reveal Link Command") - ELSE Reveal(left, right, "", "#StdLinks:Reveal Link Command") - END - END - END RevealCmd; - - PROCEDURE RevealTarget (targ: Target); - VAR left, right: Target; - BEGIN GetTargetPair(targ, left, right); - IF left # NIL THEN - IF left.ident # NIL THEN Reveal(left, right, left.ident^, "#SdtLinks:Reveal Target Ident") - ELSE Reveal(left, right, "", "#SdtLinks:Reveal Target Ident") - END - END - END RevealTarget; - - PROCEDURE CallCmd (v: Link; close: BOOLEAN); - VAR res: INTEGER; - BEGIN - Kernel.PushTrapCleaner(cleaner); - par := v; - IF v.cmd^ # "" THEN - IF close & (v.close = ifShiftDown) OR (v.close = always) THEN - StdCmds.CloseDialog - END; - Dialog.Call(v.cmd^, "#StdLinks:Link Call Failed", res) - END; - par := NIL; - Kernel.PopTrapCleaner(cleaner) - END CallCmd; - - PROCEDURE TrackSingle (f: Views.Frame; VAR in: BOOLEAN); - VAR x, y: INTEGER; modifiers: SET; in0, isDown: BOOLEAN; - BEGIN - in := FALSE; - REPEAT - f.Input(x, y, modifiers, isDown); - in0 := in; in := InFrame(f, x, y); - IF in # in0 THEN Mark(f, in) END - UNTIL ~isDown; - IF in THEN Mark(f, FALSE) END - END TrackSingle; - - PROCEDURE TrackRange (v: TextViews.View; f: Views.Frame; l, r: Link; x, y: INTEGER; - VAR in: BOOLEAN); - VAR pos, beg, end: INTEGER; modifiers: SET; in0, isDown: BOOLEAN; - BEGIN - in := FALSE; - GetRange(l, r, beg, end); pos := ThisPos(v, f, x, y); - IF (beg <= pos) & (pos < end) THEN - REPEAT - f.Input(x, y, modifiers, isDown); pos := ThisPos(v, f, x, y); - in0 := in; in := (beg <= pos) & (pos < end); - IF in # in0 THEN MarkRange(v, f, beg, end, in) END - UNTIL ~isDown; - IF in THEN - MarkRange(v, f, beg, end, FALSE) - END - END - END TrackRange; - - PROCEDURE Track (v: Link; f: Views.Frame; c: TextControllers.Controller; - x, y: INTEGER; modifiers: SET); - (* PRE: (c # NIL) & (f.view.ThisModel() = v.context.ThisModel()) OR (c = NIL) & (f.view = v) *) - VAR l, r: Link; in: BOOLEAN; - BEGIN - GetLinkPair(v, l, r); - IF l # NIL THEN - IF c # NIL THEN TrackRange(c.view, f, l, r, x, y, in) - ELSE TrackSingle(f, in) - END; - IF in THEN - IF (Controllers.modify IN modifiers) & ((c = NIL) OR ~(Containers.noCaret IN c.opts)) THEN - RevealCmd(l) - ELSE - CallCmd(l, Controllers.extend IN modifiers) - END - END - END - END Track; - - PROCEDURE TrackTarget (targ: Target; f: Views.Frame; modifiers: SET); - VAR in: BOOLEAN; - BEGIN - TrackSingle(f, in); - IF in & (Controllers.modify IN modifiers) THEN RevealTarget(targ) END - END TrackTarget; - - PROCEDURE (v: Link) CopyFromSimpleView- (source: Views.View); - BEGIN - WITH source: Link DO - ASSERT(source.leftSide = (source.cmd # NIL), 100); - v.leftSide := source.leftSide; - v.close := source.close; - IF source.cmd # NIL THEN - NEW(v.cmd, LEN(source.cmd^)); - v.cmd^ := source.cmd^$ - ELSE v.cmd := NIL - END - END - END CopyFromSimpleView; - - PROCEDURE (t: Target) CopyFromSimpleView- (source: Views.View); - BEGIN - WITH source: Target DO - ASSERT(source.leftSide = (source.ident # NIL), 100); - t.leftSide := source.leftSide; - IF source.ident # NIL THEN - NEW(t.ident, LEN(source.ident^)); - t.ident^ := source.ident^$ - ELSE t.ident := NIL - END - END - END CopyFromSimpleView; - - PROCEDURE (v: Link) Internalize- (VAR rd: Stores.Reader); - VAR len: INTEGER; version: INTEGER; pos: INTEGER; - BEGIN - v.Internalize^(rd); - IF rd.cancelled THEN RETURN END; - rd.ReadVersion(minLinkVersion, maxLinkVersion, version); - IF rd.cancelled THEN RETURN END; - rd.ReadBool(v.leftSide); - rd.ReadInt(len); - IF len = 0 THEN v.cmd := NIL - ELSE NEW(v.cmd, len); rd.ReadXString(v.cmd^) - END; - v.leftSide := v.cmd # NIL; - IF v.leftSide THEN - IF version = 1 THEN - rd.ReadInt(v.close) - ELSE - Strings.Find(v.cmd, "StdLinks.ShowTarget", 0, pos); - IF (pos # 0) THEN v.close := ifShiftDown - ELSE v.close := never - END - END - END - END Internalize; - - PROCEDURE (v: Link) Externalize- (VAR wr: Stores.Writer); - VAR pos, version: INTEGER; - BEGIN - v.Externalize^(wr); - IF v.leftSide THEN - Strings.Find(v.cmd, "StdLinks.ShowTarget", 0, pos); - IF (pos = 0) & (v.close = never) OR (v.close = ifShiftDown) THEN version := 0 - ELSE version := 1 - END - ELSE - version := 0 - END; - wr.WriteVersion(version); - wr.WriteBool(v.cmd # NIL); - IF v.cmd = NIL THEN wr.WriteInt(0) - ELSE wr.WriteInt(LEN(v.cmd^)); wr.WriteXString(v.cmd^) - END; - IF version = 1 THEN wr.WriteInt(v.close) END - END Externalize; - - PROCEDURE (t: Target) Internalize- (VAR rd: Stores.Reader); - VAR len: INTEGER; version: INTEGER; - BEGIN - t.Internalize^(rd); - IF rd.cancelled THEN RETURN END; - rd.ReadVersion(minTargVersion, maxTargVersion, version); - IF rd.cancelled THEN RETURN END; - rd.ReadBool(t.leftSide); - rd.ReadInt(len); - IF len = 0 THEN t.ident := NIL - ELSE NEW(t.ident, len); rd.ReadXString(t.ident^) - END; - t.leftSide := t.ident # NIL - END Internalize; - - PROCEDURE (t: Target) Externalize- (VAR wr: Stores.Writer); - BEGIN - t.Externalize^(wr); - wr.WriteVersion(maxTargVersion); - wr.WriteBool(t.ident # NIL); - IF t.ident = NIL THEN wr.WriteInt(0) - ELSE wr.WriteInt(LEN(t.ident^)); wr.WriteXString(t.ident^) - END - END Externalize; - - PROCEDURE RestoreView (v: Views.View; f: Views.Frame; icon: ARRAY OF SHORTCHAR); - VAR c: Models.Context; a: TextModels.Attributes; font: Fonts.Font; color: Ports.Color; - asc, dsc, w: INTEGER; - BEGIN - c := v.context; - IF (c # NIL) & (c IS TextModels.Context) THEN - a := c(TextModels.Context).Attr(); - font := Fonts.dir.This(iconFont, a.font.size, {}, Fonts.normal); - color := a.color - ELSE font := Fonts.dir.Default(); color := Ports.black - END; - IF coloredBackg THEN - f.DrawRect(f.l, f.t, f.r, f.b, Ports.fill, Ports.grey25) END; - font.GetBounds(asc, dsc, w); - f.DrawSString(1*Ports.mm DIV 2, asc, color, icon, font) - END RestoreView; - - PROCEDURE (v: Link) Restore* (f: Views.Frame; l, t, r, b: INTEGER); - BEGIN - IF v.leftSide THEN RestoreView(v, f, linkLeft) - ELSE RestoreView(v, f, linkRight) - END - END Restore; - - PROCEDURE (targ: Target) Restore* (f: Views.Frame; l, t, r, b: INTEGER); - BEGIN - IF targ.leftSide THEN RestoreView(targ, f, targetLeft) - ELSE RestoreView(targ, f, targetRight) - END - END Restore; - - PROCEDURE SizePref (v: Views.View; icon: ARRAY OF SHORTCHAR; VAR msg: Properties.SizePref); - VAR c: Models.Context; a: TextModels.Attributes; font: Fonts.Font; - asc, dsc, w: INTEGER; - BEGIN - c := v.context; - IF (c # NIL) & (c IS TextModels.Context) THEN - a := c(TextModels.Context).Attr(); - font := Fonts.dir.This(iconFont, a.font.size, {}, Fonts.normal) - ELSE - font := Fonts.dir.Default() - END; - msg.w := font.SStringWidth(icon) + 1*Ports.mm; - font.GetBounds(asc, dsc, w); - msg.h := asc + dsc - END SizePref; - - PROCEDURE (v: Link) HandlePropMsg- (VAR msg: Properties.Message); - VAR a: TextModels.Attributes; c: Models.Context; asc, dsc, w: INTEGER; l, r: Link; - BEGIN - WITH msg: Properties.SizePref DO - IF v.leftSide THEN SizePref(v, linkLeft, msg) - ELSE SizePref(v, linkRight, msg) - END - | msg: Properties.FocusPref DO - msg.hotFocus := TRUE - | msg: Properties.ResizePref DO - msg.fixed := TRUE - | msg: TextModels.Pref DO - msg.opts := {TextModels.hideable} - | msg: TextControllers.FilterPref DO - msg.filter := TRUE - | msg: TextSetters.Pref DO c := v.context; - IF (c # NIL) & (c IS TextModels.Context) THEN - a := c(TextModels.Context).Attr(); - a.font.GetBounds(asc, dsc, w); - msg.dsc := dsc - END - | msg: Properties.PollMsg DO - IF v.leftSide THEN PollProp(v, msg) - ELSE - GetLinkPair(v, l, r); - IF l # NIL THEN PollProp(l, msg) END - END - | msg: Properties.SetMsg DO - IF v.leftSide THEN SetProp(v, msg) - ELSE GetLinkPair(v, l, r); SetProp(l, msg) - END - ELSE - END - END HandlePropMsg; - - PROCEDURE (targ: Target) HandlePropMsg- (VAR msg: Properties.Message); - VAR a: TextModels.Attributes; c: Models.Context; asc, dsc, w: INTEGER; l, r: Target; - BEGIN - WITH msg: Properties.SizePref DO - IF targ.leftSide THEN SizePref(targ, targetLeft, msg) - ELSE SizePref(targ, targetRight, msg) - END - | msg: Properties.FocusPref DO - msg.hotFocus := TRUE - | msg: Properties.ResizePref DO - msg.fixed := TRUE - | msg: TextModels.Pref DO - msg.opts := {TextModels.hideable} - | msg: TextSetters.Pref DO c := targ.context; - IF (c # NIL) & (c IS TextModels.Context) THEN - a := c(TextModels.Context).Attr(); - a.font.GetBounds(asc, dsc, w); - msg.dsc := dsc - END - | msg: Properties.PollMsg DO - IF targ.leftSide THEN PollProp(targ, msg) - ELSE - GetTargetPair(targ, l, r); - IF l # NIL THEN PollProp(l, msg) END - END - | msg: Properties.SetMsg DO - IF targ.leftSide THEN SetProp(targ, msg) - ELSE GetTargetPair(targ, l, r); SetProp(l, msg) - END - ELSE - END - END HandlePropMsg; - - PROCEDURE (v: Link) HandleCtrlMsg* (f: Views.Frame; - VAR msg: Controllers.Message; VAR focus: Views.View); - - PROCEDURE isHot(c: TextControllers.Controller; x, y: INTEGER; mod: SET): BOOLEAN; - VAR pos, beg, end: INTEGER; - BEGIN - (* ignore alt, cmd, and middle clicks in edit mode *) - IF ~(Containers.noCaret IN c.opts) & (mod * {17, 27, 28} # {}) THEN RETURN FALSE END; - pos := ThisPos(c.view, f, x, y); - (* ignore clicks in selection *) - c.GetSelection(beg, end); - IF (end > beg) & (pos >= beg) & (pos <= end) THEN RETURN FALSE END; - IF v.leftSide THEN RETURN pos >= v.context(TextModels.Context).Pos() - ELSE RETURN pos < v.context(TextModels.Context).Pos() - END - END isHot; - - BEGIN - WITH msg: Controllers.PollCursorMsg DO - msg.cursor := Ports.refCursor - | msg: TextControllers.FilterPollCursorMsg DO - IF isHot(msg.controller, msg.x, msg.y, {}) THEN - msg.cursor := Ports.refCursor; msg.done := TRUE - END - | msg: Controllers.TrackMsg DO - Track(v, f, NIL, msg.x, msg.y, msg.modifiers) - | msg: TextControllers.FilterTrackMsg DO - IF isHot(msg.controller, msg.x, msg.y, msg.modifiers) THEN - Track(v, f, msg.controller, msg.x, msg.y, msg.modifiers); - msg.done := TRUE - END - ELSE - END - END HandleCtrlMsg; - - PROCEDURE (targ: Target) HandleCtrlMsg* (f: Views.Frame; VAR msg: Controllers.Message; - VAR focus: Views.View); - BEGIN - WITH msg: Controllers.TrackMsg DO TrackTarget(targ, f, msg.modifiers) - ELSE - END - END HandleCtrlMsg; - - PROCEDURE (v: Link) GetCmd* (OUT cmd: ARRAY OF CHAR), NEW; - BEGIN - ASSERT(v.leftSide, 20); - ASSERT(v.cmd # NIL, 100); - cmd := v.cmd$ - END GetCmd; - - PROCEDURE (t: Target) GetIdent* (OUT ident: ARRAY OF CHAR), NEW; - BEGIN - ASSERT(t.leftSide, 20); - ASSERT(t.ident # NIL, 100); - ident := t.ident$ - END GetIdent; - - (* --------------- create commands and menu guards ------------------------ *) - - PROCEDURE GetParam (c: TextControllers.Controller; VAR param: ARRAY OF CHAR; - VAR lbrBeg, lbrEnd, rbrBeg, rbrEnd: INTEGER); - VAR rd: TextModels.Reader; i, beg, end: INTEGER; - ch0, ch1, ch2: CHAR; - BEGIN - param[0] := 0X; - IF (c # NIL) & c.HasSelection() THEN - c.GetSelection(beg, end); - IF end - beg > 4 THEN - rd := c.text.NewReader(NIL); - rd.SetPos(beg); rd.ReadChar(ch0); - rd.SetPos(end-2); rd.ReadChar(ch1); rd.ReadChar(ch2); - IF (ch0 = "<") & (ch1 = "<") & (ch2 = ">") THEN - rd.SetPos(beg+1); rd.ReadChar(ch0); i := 0; - WHILE ~rd.eot & (ch0 # ">") DO - IF i < LEN(param) - 1 THEN param[i] := ch0; INC(i) END; - rd.ReadChar(ch0) - END; - param[i] := 0X; - lbrBeg := beg; lbrEnd := rd.Pos(); - rbrBeg := end -2; rbrEnd := end - END - END - END - END GetParam; - - PROCEDURE CreateGuard* (VAR par: Dialog.Par); - VAR param: ARRAY 512 OF CHAR; lbrBeg, lbrEnd, rbrBeg, rbrEnd: INTEGER; - BEGIN - GetParam(TextControllers.Focus(), param, lbrBeg, lbrEnd, rbrBeg, rbrEnd); - par.disabled := param = "" - END CreateGuard; - - PROCEDURE InsertionAttr (c: TextControllers.Controller; pos: INTEGER): TextModels.Attributes; - VAR rd: TextModels.Reader; r: TextRulers.Ruler; a: TextModels.Attributes; ch: CHAR; - BEGIN - rd := c.text.NewReader(NIL); a := NIL; - rd.SetPos(pos); rd.ReadChar(ch); a := rd.attr; - IF a = NIL THEN c.view.PollDefaults(r, a) END; - RETURN a - END InsertionAttr; - - PROCEDURE CreateLink*; - VAR lbrBeg, lbrEnd, rbrBeg, rbrEnd: INTEGER; - left, right: Link; c: TextControllers.Controller; - cmd: ARRAY 512 OF CHAR; - op: Stores.Operation; - w: TextModels.Writer; a: TextModels.Attributes; - BEGIN - c := TextControllers.Focus(); - GetParam(TextControllers.Focus(), cmd, lbrBeg, lbrEnd, rbrBeg, rbrEnd); - IF cmd # "" THEN - w := c.text.NewWriter(NIL); - Models.BeginScript(c.text, "#StdLinks:Create Link", op); - a := InsertionAttr(c, rbrBeg); - c.text.Delete(rbrBeg, rbrEnd); - right := dir.NewLink(""); - w.SetPos(rbrBeg); - IF a # NIL THEN w.SetAttr(a) END; - w.WriteView(right, 0, 0); - a := InsertionAttr(c, lbrBeg); - c.text.Delete(lbrBeg, lbrEnd); - left := dir.NewLink(cmd); - w.SetPos(lbrBeg); - IF a # NIL THEN w.SetAttr(a) END; - w.WriteView(left, 0, 0); - Models.EndScript(c.text, op) - END - END CreateLink; - - PROCEDURE CreateTarget*; - VAR lbrBeg, lbrEnd, rbrBeg, rbrEnd: INTEGER; - left, right: Target; c: TextControllers.Controller; - ident: ARRAY 512 OF CHAR; - op: Stores.Operation; - w: TextModels.Writer; a: TextModels.Attributes; - BEGIN - c := TextControllers.Focus(); - GetParam(TextControllers.Focus(), ident, lbrBeg, lbrEnd, rbrBeg, rbrEnd); - IF ident # "" THEN - w := c.text.NewWriter(NIL); - Models.BeginScript(c.text, "#StdLinks:Create Target", op); - a := InsertionAttr(c, rbrBeg); - c.text.Delete(rbrBeg, rbrEnd); - right := dir.NewTarget(""); - w.SetPos(rbrBeg); - IF a # NIL THEN w.SetAttr(a) END; - w.WriteView(right, 0, 0); - a := InsertionAttr(c, lbrBeg); - c.text.Delete(lbrBeg, lbrEnd); - left := dir.NewTarget(ident); - w.SetPos(lbrBeg); - IF a # NIL THEN w.SetAttr(a) END; - w.WriteView(left, 0, 0); - Models.EndScript(c.text, op) - END - END CreateTarget; - - PROCEDURE ShowTarget* (IN ident: ARRAY OF CHAR); - VAR c: TextControllers.Controller; rd: TextModels.Reader; - v: Views.View; left, right: Target; beg, end: INTEGER; - BEGIN - c := TextControllers.Focus(); - IF c # NIL THEN - rd := c.text.NewReader(NIL); - REPEAT rd.ReadView(v) - UNTIL rd.eot OR (v # NIL) & (v IS Target) & v(Target).leftSide & (v(Target).ident^ = ident); - IF ~rd.eot THEN - GetTargetPair(v(Target), left, right); - IF (left # NIL) & (right # NIL) THEN - beg := left.context(TextModels.Context).Pos(); - end := right.context(TextModels.Context).Pos() + 1; - c.SetSelection(beg, end); - c.view.SetOrigin(beg, 0) - ELSE - Dialog.ShowParamMsg("target '^0' not found", ident, "", "") - END - ELSE - Dialog.ShowParamMsg("target '^0' not found", ident, "", "") - END - END - END ShowTarget; - - - (* programming interface *) - - PROCEDURE (d: StdDirectory) NewLink (IN cmd: ARRAY OF CHAR): Link; - VAR link: Link; i: INTEGER; - BEGIN - NEW(link); link.leftSide := cmd # ""; - IF link.leftSide THEN - i := 0; WHILE cmd[i] # 0X DO INC(i) END; - NEW(link.cmd, i + 1); link.cmd^ := cmd$ - ELSE - link.cmd := NIL - END; - link.close := ifShiftDown; - RETURN link - END NewLink; - - PROCEDURE (d: StdDirectory) NewTarget (IN ident: ARRAY OF CHAR): Target; - VAR t: Target; i: INTEGER; - BEGIN - NEW(t); t.leftSide := ident # ""; - IF t.leftSide THEN - i := 0; WHILE ident[i] # 0X DO INC(i) END; - NEW(t.ident, i + 1); t.ident^ := ident$ - ELSE - t.ident := NIL - END; - RETURN t - END NewTarget; - - PROCEDURE SetDir* (d: Directory); - BEGIN - ASSERT(d # NIL, 20); - dir := d - END SetDir; - - PROCEDURE Init; - VAR font: Fonts.Font; d: StdDirectory; - - PROCEDURE DefaultAppearance; - BEGIN font := Fonts.dir.Default(); iconFont := font.typeface; - linkLeft := "Link"; linkRight := "~"; - targetLeft := "Targ"; targetRight := "~"; - coloredBackg := TRUE - END DefaultAppearance; - - BEGIN - NEW(d); dir := d; stdDir := d; - IF Dialog.platform DIV 10 = 1 THEN (* Windows *) - iconFont := "Wingdings"; - font := Fonts.dir.This(iconFont, 10*Fonts.point (*arbitrary*), {}, Fonts.normal); - IF font.IsAlien() THEN DefaultAppearance - ELSE - linkLeft[0] := SHORT(CHR(246)); linkLeft[1] := 0X; - linkRight[0] := SHORT(CHR(245)); linkRight[1] := 0X; - targetLeft[0] := SHORT(CHR(164)); targetLeft[1] := 0X; - targetRight[0] := SHORT(CHR(161)); targetRight[1] := 0X; - coloredBackg := FALSE - END - ELSIF Dialog.platform DIV 10 = 2 THEN (* Mac *) - DefaultAppearance - ELSE - DefaultAppearance - END; - NEW(cleaner); - dialog.close.SetResources("#Std:links") - END Init; - -BEGIN - Init -END StdLinks. diff --git a/new/Std/Mod/Loader.txt b/new/Std/Mod/Loader.txt deleted file mode 100644 index f883f21..0000000 --- a/new/Std/Mod/Loader.txt +++ /dev/null @@ -1,336 +0,0 @@ -MODULE StdLoader; - - (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/Loader.odc *) - (* DO NOT EDIT *) - - IMPORT S := SYSTEM, Kernel, Files; - - CONST - done = Kernel.done; - fileNotFound = Kernel.fileNotFound; - syntaxError = Kernel.syntaxError; - objNotFound = Kernel.objNotFound; - illegalFPrint = Kernel.illegalFPrint; - cyclicImport = Kernel.cyclicImport; - noMem = Kernel.noMem; - commNotFound = Kernel.commNotFound; - commSyntaxError = Kernel.commSyntaxError; - descNotFound = -1; - - OFdir = "Code"; - SYSdir = "System"; - initMod = "Init"; - OFtag = 6F4F4346H; - - (* meta interface consts *) - mConst = 1; mTyp = 2; mVar = 3; mProc = 4; mField = 5; - mBool = 1; mChar = 2; mLChar = 3; mSInt = 4; mInt = 5; mLInt = 6; - mReal = 7; mLReal = 8; mSet = 9; mString = 10; mLString = 11; - mRecord = 1; mArray = 2; mPointer = 3; mProctyp = 4; - mInternal = 1; mReadonly = 2; mPrivate = 3; mExported = 4; - - (* fixup types *) - absolute = 100; relative = 101; copy = 102; table = 103; tableend = 104; deref = 105; halfword = 106; - - TYPE - Name = ARRAY 256 OF CHAR; - ModSpec = POINTER TO RECORD - next, link, imp: ModSpec; - name: Name; - file: Files.File; - mod: Kernel.Module; - hs, ms, ds, cs, vs, mad, dad: INTEGER - END; - - Hook = POINTER TO RECORD (Kernel.LoaderHook) END; - - VAR - res-: INTEGER; - importing-, imported-, object-: Name; - inp: Files.Reader; - m: Kernel.Module; - - PROCEDURE Error (r: INTEGER; impd, impg: ModSpec); - BEGIN - res := r; imported := impd.name$; - IF impg # NIL THEN importing := impg.name$ END; - END Error; - - PROCEDURE Append (VAR s: ARRAY OF CHAR; t: ARRAY OF CHAR); - VAR len, i, j: INTEGER; ch: CHAR; - BEGIN - len := LEN(s); - i := 0; WHILE s[i] # 0X DO INC(i) END; - j := 0; REPEAT ch := t[j]; s[i] := ch; INC(j); INC(i) UNTIL (ch = 0X) OR (i = len); - s[len - 1] := 0X - END Append; - - PROCEDURE ThisObjFile (VAR name: ARRAY OF CHAR): Files.File; - VAR f: Files.File; loc: Files.Locator; dir, fname: Files.Name; - BEGIN - Kernel.SplitName(name, dir, fname); - Kernel.MakeFileName(fname, Kernel.objType); - loc := Files.dir.This(dir); loc := loc.This(OFdir); - f := Files.dir.Old(loc, fname, TRUE); - IF (f = NIL) & (dir = "") THEN - loc := Files.dir.This(SYSdir); loc := loc.This(OFdir); - f := Files.dir.Old(loc, fname, TRUE) - END; - RETURN f - END ThisObjFile; - - PROCEDURE RWord (VAR x: INTEGER); - VAR b: BYTE; y: INTEGER; - BEGIN - inp.ReadByte(b); y := b MOD 256; - inp.ReadByte(b); y := y + 100H * (b MOD 256); - inp.ReadByte(b); y := y + 10000H * (b MOD 256); - inp.ReadByte(b); x := y + 1000000H * b - END RWord; - - PROCEDURE RNum (VAR x: INTEGER); - VAR b: BYTE; s, y: INTEGER; - BEGIN - s := 0; y := 0; inp.ReadByte(b); - WHILE b < 0 DO INC(y, ASH(b + 128, s)); INC(s, 7); inp.ReadByte(b) END; - x := ASH((b + 64) MOD 128 - 64, s) + y - END RNum; - - PROCEDURE RName (VAR name: ARRAY OF CHAR); - VAR b: BYTE; i, n: INTEGER; - BEGIN - i := 0; n := LEN(name) - 1; inp.ReadByte(b); - WHILE (i < n) & (b # 0) DO name[i] := CHR(b MOD 256); INC(i); inp.ReadByte(b) END; - WHILE b # 0 DO inp.ReadByte(b) END; - name[i] := 0X - END RName; - - PROCEDURE Fixup (adr: INTEGER; mod: ModSpec); - VAR link, offset, linkadr, t, n, x, low, hi: INTEGER; - BEGIN - RNum(link); - WHILE link # 0 DO - RNum(offset); - WHILE link # 0 DO - IF link > 0 THEN linkadr := mod.mad + mod.ms + link - ELSE link := -link; - IF link < mod.ms THEN linkadr := mod.mad + link - ELSE linkadr := mod.dad + link - mod.ms - END - END; - S.GET(linkadr, x); t := x DIV 1000000H; - n := (x + 800000H) MOD 1000000H - 800000H; - IF t = absolute THEN x := adr + offset - ELSIF t = relative THEN x := adr + offset - linkadr - 4 - ELSIF t = copy THEN S.GET(adr + offset, x) - ELSIF t = table THEN x := adr + n; n := link + 4 - ELSIF t = tableend THEN x := adr + n; n := 0 - ELSIF t = deref THEN S.GET(adr+2, x); INC(x, offset); - ELSIF t = halfword THEN - x := adr + offset; - low := (x + 8000H) MOD 10000H - 8000H; - hi := (x - low) DIV 10000H; - S.GET(linkadr + 4, x); - S.PUT(linkadr + 4, x DIV 10000H * 10000H + low MOD 10000H); - x := x * 10000H + hi MOD 10000H - ELSE Error(syntaxError, mod, NIL) - END; - S.PUT(linkadr, x); link := n - END; - RNum(link) - END - END Fixup; - - PROCEDURE ReadHeader (mod: ModSpec); - VAR n, p: INTEGER; name: Name; imp, last: ModSpec; - BEGIN - mod.file := ThisObjFile(mod.name); - IF (mod.file = NIL) & (mod.link # NIL) THEN (* try closing importing obj file *) - mod.link.file.Close; mod.link.file := NIL; - mod.file := ThisObjFile(mod.name) - END; - IF mod.file # NIL THEN - inp := mod.file.NewReader(inp); - IF inp # NIL THEN - inp.SetPos(0); RWord(n); RWord(p); - IF (n = OFtag) & (p = Kernel.processor) THEN - RWord(mod.hs); RWord(mod.ms); RWord(mod.ds); RWord(mod.cs); RWord(mod.vs); - RNum(n); RName(name); - IF name = mod.name THEN - mod.imp := NIL; last := NIL; - WHILE n > 0 DO - NEW(imp); RName(imp.name); - IF last = NIL THEN mod.imp := imp ELSE last.next := imp END; - last := imp; imp.next := NIL; DEC(n) - END - ELSE Error(fileNotFound, mod, NIL) - END - ELSE Error(syntaxError, mod, NIL) - END - ELSE Error(noMem, mod, NIL) - END - ELSE Error(fileNotFound, mod, NIL) - END - END ReadHeader; - - PROCEDURE ReadModule (mod: ModSpec); - TYPE BlockPtr = POINTER TO ARRAY [1] 1000000H OF BYTE; - VAR imptab, x, fp, ofp, opt, a: INTEGER; - name: Name; dp, mp: BlockPtr; imp: ModSpec; obj: Kernel.Object; in, n: Kernel.Name; - BEGIN - IF mod.file = NIL THEN mod.file := ThisObjFile(mod.name) END; - inp := mod.file.NewReader(inp); - IF inp # NIL THEN - inp.SetPos(mod.hs); - Kernel.AllocModMem(mod.ds, mod.ms + mod.cs + mod.vs, mod.dad, mod.mad); - IF (mod.dad # 0) & (mod.mad # 0) THEN - dp := S.VAL(BlockPtr, mod.dad); mp := S.VAL(BlockPtr, mod.mad); - inp.ReadBytes(mp^, 0, mod.ms); - inp.ReadBytes(dp^, 0, mod.ds); - inp.ReadBytes(mp^, mod.ms, mod.cs); - mod.mod := S.VAL(Kernel.Module, mod.dad); - Fixup(S.ADR(Kernel.NewRec), mod); - Fixup(S.ADR(Kernel.NewArr), mod); - Fixup(mod.mad, mod); - Fixup(mod.dad, mod); - Fixup(mod.mad + mod.ms, mod); - Fixup(mod.mad + mod.ms + mod.cs, mod); - imp := mod.imp; imptab := S.VAL(INTEGER, mod.mod.imports); - WHILE (res = done) & (imp # NIL) DO - RNum(x); - WHILE (res <= done) & (x # 0) DO - RName(name); RNum(fp); opt := 0; - IF imp.mod # NIL THEN - IF name = "" THEN obj := Kernel.ThisDesc(imp.mod, fp) - ELSE n := SHORT(name$); obj := Kernel.ThisObject(imp.mod, n) - END; - IF (obj # NIL) & (obj.id MOD 16 = x) THEN - ofp := obj.fprint; - IF x = mTyp THEN - RNum(opt); - IF ODD(opt) THEN ofp := obj.offs END; - IF (opt > 1) & (obj.id DIV 16 MOD 16 # mExported) THEN - Error(objNotFound, imp, mod); object := name$ - END; - Fixup(S.VAL(INTEGER, obj.struct), mod) - ELSIF x = mVar THEN - Fixup(imp.mod.varBase + obj.offs, mod) - ELSIF x = mProc THEN - Fixup(imp.mod.procBase + obj.offs, mod) - END; - IF ofp # fp THEN Error(illegalFPrint, imp, mod); object := name$ END - ELSIF name # "" THEN - Error(objNotFound, imp, mod); object := name$ - ELSE - Error(descNotFound, imp, mod); (* proceed to find failing named object *) - RNum(opt); Fixup(0, mod) - END - ELSE (* imp is dll *) - IF x IN {mVar, mProc} THEN - in := SHORT(imp.name$); n := SHORT(name$); - a := Kernel.ThisDllObj(x, fp, in, n); - IF a # 0 THEN Fixup(a, mod) - ELSE Error(objNotFound, imp, mod); object := name$ - END - ELSIF x = mTyp THEN - RNum(opt); RNum(x); - IF x # 0 THEN Error(objNotFound, imp, mod); object := name$ END - END - END; - RNum(x) - END; - S.PUT(imptab, imp.mod); INC(imptab, 4); imp := imp.next - END; - IF res # done THEN - Kernel.DeallocModMem(mod.ds, mod.ms + mod.cs + mod.vs, mod.dad, mod.mad); mod.mod := NIL - END - ELSE Error(noMem, mod, NIL) - END - ELSE Error(noMem, mod, NIL) - END; - mod.file.Close; mod.file := NIL - END ReadModule; - - PROCEDURE LoadMod (mod: ModSpec); - VAR i: ModSpec; ok: BOOLEAN; j: INTEGER; n: Kernel.Name; - BEGIN - importing := ""; imported := ""; object := ""; i := mod; - WHILE (i.link # NIL) & (i.link.name # mod.name) DO i := i.link END; - IF i.link = NIL THEN ReadHeader(mod) - ELSE Error(cyclicImport, i, i.link) - END; - i := mod.imp; - WHILE (res = done) & (i # NIL) DO (* get imported module *) - IF i.name = "$$" THEN i.name := "Kernel" END; - IF i.name[0] = "$" THEN (* dll *) - j := 1; - WHILE i.name[j] # 0X DO i.name[j - 1] := i.name[j]; INC(j) END; - i.name[j - 1] := 0X; n := SHORT(i.name$); - Kernel.LoadDll(n, ok); - IF ~ok THEN Error(fileNotFound, i, NIL) END - ELSE - n := SHORT(i.name$); - i.mod := Kernel.ThisLoadedMod(n); (* loaded module *) - IF i.mod = NIL THEN i.link := mod; LoadMod(i) END (* new module *) - END; - i := i.next - END; - IF res = done THEN - n := SHORT(mod.name$); - mod.mod := Kernel.ThisLoadedMod(n); (* guaranties uniqueness *) - IF mod.mod = NIL THEN - ReadModule(mod); - IF res = done THEN - Kernel.RegisterMod(mod.mod); - res := done - END - END - END; - IF res = descNotFound THEN res := objNotFound; object := "" END; - IF object # "" THEN Append(imported, "."); Append(imported, object); object := "" END - END LoadMod; - - PROCEDURE (h: Hook) ThisMod (IN name: ARRAY OF SHORTCHAR): Kernel.Module; - VAR m: Kernel.Module; ms: ModSpec; - BEGIN - res := done; - m := Kernel.ThisLoadedMod(name); - IF m = NIL THEN - NEW(ms); ms.link := NIL; ms.name := name$; - LoadMod(ms); - m := ms.mod; - inp := NIL (* free last file *) - END; - h.res := res; - h.importing := importing$; - h.imported := imported$; - h.object := object$; - RETURN m - END ThisMod; - - PROCEDURE Init; - VAR h: Hook; - BEGIN - NEW(h); Kernel.SetLoaderHook(h) - END Init; - -BEGIN - Init; - m := Kernel.ThisMod("Init"); - IF res # 0 THEN - CASE res OF - | fileNotFound: Append(imported, ": code file not found") - | syntaxError: Append(imported, ": corrupted code file") - | objNotFound: Append(imported, " not found") - | illegalFPrint: Append(imported, ": wrong fingerprint") - | cyclicImport: Append(imported, ": cyclic import") - | noMem: Append(imported, ": not enough memory") - ELSE Append(imported, ": loader error") - END; - IF res IN {objNotFound, illegalFPrint, cyclicImport} THEN - Append(imported, " (imported from "); Append(imported, importing); Append(imported, ")") - END; - Kernel.FatalError(res, imported) - END -END StdLoader. - diff --git a/new/Std/Mod/Log.txt b/new/Std/Mod/Log.txt deleted file mode 100644 index 92b7617..0000000 --- a/new/Std/Mod/Log.txt +++ /dev/null @@ -1,373 +0,0 @@ -MODULE StdLog; - - (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/Log.odc *) - (* DO NOT EDIT *) - - IMPORT - Log, Fonts, Ports, Stores, Models, Views, Dialog, HostDialog, StdDialog, - TextModels, TextMappers, TextRulers, TextViews, TextControllers; - - CONST - (** IntForm base **) - charCode* = TextMappers.charCode; decimal* = TextMappers.decimal; hexadecimal* = TextMappers.hexadecimal; - - (** IntForm showBase **) - hideBase* = TextMappers.hideBase; showBase* = TextMappers.showBase; - - mm = Ports.mm; - - TYPE - ShowHook = POINTER TO RECORD (Dialog.ShowHook) END; - LogHook = POINTER TO RECORD (Log.Hook) END; - - VAR - logAlerts: BOOLEAN; - - text-, buf-: TextModels.Model; - defruler-: TextRulers.Ruler; - dir-: TextViews.Directory; - - out, subOut: TextMappers.Formatter; - - showHook: ShowHook; - - - PROCEDURE Flush; - BEGIN - text.Append(buf); Views.RestoreDomain(text.Domain()) - END Flush; - - PROCEDURE Char* (ch: CHAR); - BEGIN - out.WriteChar(ch); Flush - END Char; - - PROCEDURE Int* (i: LONGINT); - BEGIN - out.WriteChar(" "); out.WriteInt(i); Flush - END Int; - - PROCEDURE Real* (x: REAL); - BEGIN - out.WriteChar(" "); out.WriteReal(x); Flush - END Real; - - PROCEDURE String* (IN str: ARRAY OF CHAR); - BEGIN - out.WriteString(str); Flush - END String; - - PROCEDURE Bool* (x: BOOLEAN); - BEGIN - out.WriteChar(" "); out.WriteBool(x); Flush - END Bool; - - PROCEDURE Set* (x: SET); - BEGIN - out.WriteChar(" "); out.WriteSet(x); Flush - END Set; - - PROCEDURE IntForm* (x: LONGINT; base, minWidth: INTEGER; fillCh: CHAR; showBase: BOOLEAN); - BEGIN - out.WriteIntForm(x, base, minWidth, fillCh, showBase); Flush - END IntForm; - - PROCEDURE RealForm* (x: REAL; precision, minW, expW: INTEGER; fillCh: CHAR); - BEGIN - out.WriteRealForm(x, precision, minW, expW, fillCh); Flush - END RealForm; - - PROCEDURE Tab*; - BEGIN - out.WriteTab; Flush - END Tab; - - PROCEDURE Ln*; - BEGIN - out.WriteLn; Flush; - TextViews.ShowRange(text, text.Length(), text.Length(), TextViews.any) - END Ln; - - PROCEDURE Para*; - BEGIN - out.WritePara; Flush; - TextViews.ShowRange(text, text.Length(), text.Length(), TextViews.any) - END Para; - - PROCEDURE View* (v: Views.View); - BEGIN - out.WriteView(v); Flush - END View; - - PROCEDURE ViewForm* (v: Views.View; w, h: INTEGER); - BEGIN - out.WriteViewForm(v, w, h); Flush - END ViewForm; - - PROCEDURE ParamMsg* (IN msg, p0, p1, p2: ARRAY OF CHAR); - BEGIN - out.WriteParamMsg(msg, p0, p1, p2); Flush - END ParamMsg; - - PROCEDURE Msg* (IN msg: ARRAY OF CHAR); - BEGIN - out.WriteMsg(msg); Flush - END Msg; - - - PROCEDURE^ Open*; - - PROCEDURE (hook: ShowHook) ShowParamMsg (IN s, p0, p1, p2: ARRAY OF CHAR); - BEGIN - IF Dialog.showsStatus THEN - Dialog.ShowParamStatus(s, p0, p1, p2); - IF logAlerts THEN - ParamMsg(s, p0, p1, p2); Ln - END - ELSE - IF logAlerts THEN - Open; - ParamMsg(s, p0, p1, p2); Ln - ELSE - HostDialog.ShowParamMsg(s, p0, p1, p2) - END - END - END ShowParamMsg; - - PROCEDURE (hook: ShowHook) ShowParamStatus (IN s, p0, p1, p2: ARRAY OF CHAR); - BEGIN - HostDialog.ShowParamStatus(s, p0, p1, p2) - END ShowParamStatus; - - - PROCEDURE NewView* (): TextViews.View; - VAR v: TextViews.View; - BEGIN - Flush; - Dialog.SetShowHook(showHook); (* attach alert dialogs *) - v := dir.New(text); - v.SetDefaults(TextRulers.CopyOf(defruler, Views.deep), dir.defAttr); - RETURN v - END NewView; - - PROCEDURE New*; - BEGIN - Views.Deposit(NewView()) - END New; - - - PROCEDURE SetDefaultRuler* (ruler: TextRulers.Ruler); - BEGIN - defruler := ruler - END SetDefaultRuler; - - PROCEDURE SetDir* (d: TextViews.Directory); - BEGIN - ASSERT(d # NIL, 20); dir := d - END SetDir; - - - PROCEDURE Open*; - VAR v: Views.View; pos: INTEGER; - BEGIN - v := NewView(); - StdDialog.Open(v, "#Dev:Log", NIL, "", NIL, FALSE, TRUE, FALSE, FALSE, TRUE); - Views.RestoreDomain(text.Domain()); - pos := text.Length(); - TextViews.ShowRange(text, pos, pos, TextViews.any); - TextControllers.SetCaret(text, pos) - END Open; - - PROCEDURE Clear*; - BEGIN - Models.BeginModification(Models.notUndoable, text); - text.Delete(0, text.Length()); - buf.Delete(0, buf.Length()); - Models.EndModification(Models.notUndoable, text) - END Clear; - - - (* Sub support *) - - PROCEDURE* Guard (o: ANYPTR): BOOLEAN; - BEGIN - RETURN - (o # NIL) & - ~( (o IS TextModels.Model) & (o = text) - OR (o IS Stores.Domain) & (o = text.Domain()) - OR (o IS TextViews.View) & (o(TextViews.View).ThisModel() = text) - ) - END Guard; - - PROCEDURE* ClearBuf; - VAR subBuf: TextModels.Model; - BEGIN - subBuf := subOut.rider.Base(); subBuf.Delete(0, subBuf.Length()) - END ClearBuf; - - PROCEDURE* FlushBuf; - VAR buf: TextModels.Model; - BEGIN - buf := subOut.rider.Base(); - IF buf.Length() > 0 THEN - IF ~Log.synch THEN Open() END; - text.Append(buf) - END - END FlushBuf; - - PROCEDURE* SubFlush; - BEGIN - IF Log.synch THEN - FlushBuf; - IF Log.force THEN Views.RestoreDomain(text.Domain()) END - END; - END SubFlush; - - - - - PROCEDURE (log: LogHook) Guard* (o: ANYPTR): BOOLEAN; - BEGIN RETURN Guard(o) - END Guard; - - PROCEDURE (log: LogHook) ClearBuf*; - BEGIN ClearBuf - END ClearBuf; - - PROCEDURE (log: LogHook) FlushBuf*; - BEGIN FlushBuf - END FlushBuf; - - PROCEDURE (log: LogHook) Beep*; - BEGIN Dialog.Beep - END Beep; - - PROCEDURE (log: LogHook) Char* (ch: CHAR); - BEGIN - subOut.WriteChar(ch); SubFlush - END Char; - - PROCEDURE (log: LogHook) Int* (n: INTEGER); - BEGIN - subOut.WriteChar(" "); subOut.WriteInt(n); SubFlush - END Int; - - PROCEDURE (log: LogHook) Real* (x: REAL); - BEGIN - subOut.WriteChar(" "); subOut.WriteReal(x); SubFlush - END Real; - - PROCEDURE (log: LogHook) String* (IN str: ARRAY OF CHAR); - BEGIN - subOut.WriteString(str); SubFlush - END String; - - PROCEDURE (log: LogHook) Bool* (x: BOOLEAN); - BEGIN - subOut.WriteChar(" "); subOut.WriteBool(x); SubFlush - END Bool; - - PROCEDURE (log: LogHook) Set* (x: SET); - BEGIN - subOut.WriteChar(" "); subOut.WriteSet(x); SubFlush - END Set; - - PROCEDURE (log: LogHook) IntForm* (x: INTEGER; base, minWidth: INTEGER; fillCh: CHAR; showBase: BOOLEAN); - BEGIN - subOut.WriteIntForm(x, base, minWidth, fillCh, showBase); SubFlush - END IntForm; - - PROCEDURE (log: LogHook) RealForm* (x: REAL; precision, minW, expW: INTEGER; fillCh: CHAR); - BEGIN - subOut.WriteRealForm(x, precision, minW, expW, fillCh); SubFlush - END RealForm; - - PROCEDURE (log: LogHook) Tab*; - BEGIN - subOut.WriteTab; SubFlush - END Tab; - - PROCEDURE (log: LogHook) Ln*; - BEGIN - subOut.WriteLn; SubFlush; - IF Log.synch THEN Views.RestoreDomain(text.Domain()) END - END Ln; - - PROCEDURE (log: LogHook) Para*; - BEGIN - subOut.WritePara; SubFlush; - IF Log.synch THEN Views.RestoreDomain(text.Domain()) END - END Para; - - PROCEDURE (log: LogHook) View* (v: ANYPTR); - BEGIN - IF (v # NIL) & (v IS Views.View) THEN - subOut.WriteView(v(Views.View)); SubFlush - END - END View; - - PROCEDURE (log: LogHook) ViewForm* (v: ANYPTR; w, h: INTEGER); - BEGIN - ASSERT(v # NIL, 20); - IF (v # NIL) & (v IS Views.View) THEN - subOut.WriteViewForm(v(Views.View), w, h); SubFlush - END - END ViewForm; - - PROCEDURE (log: LogHook) ParamMsg* (IN s, p0, p1, p2: ARRAY OF CHAR); - VAR msg: ARRAY 256 OF CHAR; i: INTEGER; ch: CHAR; - BEGIN - IF logAlerts THEN - IF Log.synch THEN Open END; - Dialog.MapParamString(s, p0, p1, p2, msg); - i := 0; ch := msg[0]; - WHILE ch # 0X DO - IF ch = TextModels.line THEN subOut.WriteLn - ELSIF ch = TextModels.para THEN subOut.WritePara - ELSIF ch = TextModels.tab THEN subOut.WriteTab - ELSIF ch >= " " THEN subOut.WriteChar(ch) - END; - INC(i); ch := msg[i]; - END; - subOut.WriteLn; SubFlush - ELSE - HostDialog.ShowParamMsg(s, p0, p1, p2) - END - END ParamMsg; - - - PROCEDURE AttachSubLog; - VAR h: LogHook; - BEGIN - subOut.ConnectTo(TextModels.dir.New()); - NEW(h); - Log.SetHook(h); - END AttachSubLog; - - PROCEDURE DetachSubLog; - BEGIN - Log.SetHook(NIL); - END DetachSubLog; - - - PROCEDURE Init; - VAR font: Fonts.Font; p: TextRulers.Prop; x: INTEGER; i: INTEGER; - BEGIN - logAlerts := TRUE; (* logReports := FALSE; *) - - text := TextModels.dir.New(); - buf := TextModels.CloneOf(text); - out.ConnectTo(buf); - - font := TextModels.dir.attr.font; - defruler := TextRulers.dir.New(NIL); - TextRulers.SetRight(defruler, 80*mm); - dir := TextViews.dir; - NEW(showHook) - END Init; - -BEGIN - Init; AttachSubLog -CLOSE - DetachSubLog; -END StdLog. diff --git a/new/Std/Mod/Logos.txt b/new/Std/Mod/Logos.txt deleted file mode 100644 index 7f31e5b..0000000 --- a/new/Std/Mod/Logos.txt +++ /dev/null @@ -1,162 +0,0 @@ -MODULE StdLogos; - - (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/Logos.odc *) - (* DO NOT EDIT *) - - IMPORT Ports, Stores, Views, Controllers, Properties; - - CONST - W = 4; - baseSize = 24 * Ports.point; - - colBase = 00202020H; - - changeColorKey = "#System:ChangeColor"; - - minVersion = 0; maxVersion = 0; - - - TYPE - View = POINTER TO RECORD (Views.View) - c: Ports.Color - END; - - ChangeSizeOp = POINTER TO RECORD (Stores.Operation) - view: View; - size: INTEGER; - END; - - ChangeColorOp = POINTER TO RECORD (Stores.Operation) - view: View; - color: Ports.Color - END; - - (* curve painting *) - - PROCEDURE Paint (f: Views.Frame; size: INTEGER; col, bgnd: Ports.Color); - VAR i, d, s, g, m, a, b, l, l0, rl, rt, rr, rb: INTEGER; c: Ports.Color; - BEGIN - s := size DIV 10; d := size DIV 2; g := d DIV 8; m := size * W DIV 2; - f.DrawOval(0, s * 2, size * W, size, Ports.fill, col); - f.DrawOval(s * W, s * 11 DIV 4, (size - s) * W, size - s * 3 DIV 4, Ports.fill, bgnd); - a := m; b := m + d; c := 7 * colBase; i := 0; - WHILE i < 4 DO - f.DrawOval(a, 0, b, d, Ports.fill, c); - INC(a, g); DEC(b, g); DEC(c, colBase); INC(i) - END; - f.rider.GetRect(rl, rt, rr, rb); - l0 := rl; l := (f.gx + m + d DIV 2) DIV f.unit; - IF l < rr THEN - f.rider.SetRect(l, rt, rr, rb); - a := m; b := m + d; c := 0; i := 0; - WHILE i < 4 DO - f.DrawOval(a, 0, b, d, Ports.fill, c); - INC(a, g); DEC(b, g); INC(c, colBase); INC(i) - END; - f.rider.SetRect(l0, rt, rr, rb) - END - END Paint; - - (* ChangeOp *) - - PROCEDURE (op: ChangeSizeOp) Do; - VAR v: View; size, w: INTEGER; - BEGIN - v := op.view; - size := op.size; v.context.GetSize(w, op.size); v.context.SetSize(size * W, size); - Views.Update(v, Views.keepFrames) - END Do; - - PROCEDURE (op: ChangeColorOp) Do; - VAR v: View; color: Ports.Color; - BEGIN - v := op.view; - color := op.color; op.color := v.c; v.c := color; - Views.Update(v, Views.keepFrames) - END Do; - - (* View *) - - PROCEDURE (v: View) Internalize (VAR rd: Stores.Reader); - VAR thisVersion: INTEGER; - BEGIN - v.Internalize^(rd); IF rd.cancelled THEN RETURN END; - rd.ReadVersion(minVersion, maxVersion, thisVersion); IF rd.cancelled THEN RETURN END; - rd.ReadInt(v.c) - END Internalize; - - PROCEDURE (v: View) Externalize (VAR wr: Stores.Writer); - BEGIN - v.Externalize^(wr); - wr.WriteVersion(maxVersion); - wr.WriteInt(v.c) - END Externalize; - - PROCEDURE (v: View) CopyFromSimpleView (source: Views.View); - BEGIN - WITH source: View DO v.c := source.c END - END CopyFromSimpleView; - - PROCEDURE (v: View) Restore (f: Views.Frame; l, t, r, b: INTEGER); - VAR w, h: INTEGER; bgnd: Ports.Color; g: Views.Frame; - BEGIN - g := f; - REPEAT - g := Views.HostOf(g); - bgnd := Views.transparent; - g.view.GetBackground(bgnd) - UNTIL bgnd # Views.transparent; - v.context.GetSize(w, h); - Paint(f, h, v.c, bgnd) - END Restore; - - PROCEDURE (v: View) HandleCtrlMsg (f: Views.Frame; VAR msg: Controllers.Message; - VAR focus: Views.View); - BEGIN - WITH msg: Properties.CollectMsg DO - Views.HandlePropMsg(v, msg.poll) - | msg: Properties.EmitMsg DO - Views.HandlePropMsg(v, msg.set) - ELSE (* ignore other messages *) - END - END HandleCtrlMsg; - - PROCEDURE (v: View) HandlePropMsg (VAR msg: Properties.Message); - VAR q: Properties.Property; p: Properties.StdProp; - cop: ChangeColorOp; - BEGIN - WITH msg: Properties.SizePref DO - IF (msg.w > Views.undefined) & (msg.h > Views.undefined) THEN - (* constrain proposed size *) - Properties.ProportionalConstraint(W, 1, msg.fixedW, msg.fixedH, msg.w, msg.h) - ELSE - (* return default size *) - msg.w := W * baseSize; msg.h := baseSize - END - | msg: Properties.PollMsg DO - NEW(p); p.known := {Properties.color}; p.valid := p.known; - p.color.val := v.c; - msg.prop := p - | msg: Properties.SetMsg DO - q := msg.prop; - WHILE q # NIL DO - WITH q: Properties.StdProp DO - IF Properties.color IN q.valid THEN - NEW(cop); cop.view := v; cop.color := q.color.val; - Views.Do(v, changeColorKey, cop) - END; - ELSE - END; - q :=q.next - END - ELSE - END - END HandlePropMsg; - - PROCEDURE Deposit*; - VAR v: View; - BEGIN - NEW(v); v.c := Ports.grey50; Views.Deposit(v) - END Deposit; - -END StdLogos. diff --git a/new/Std/Mod/Scrollers.txt b/new/Std/Mod/Scrollers.txt deleted file mode 100644 index 46731aa..0000000 --- a/new/Std/Mod/Scrollers.txt +++ /dev/null @@ -1,853 +0,0 @@ -MODULE StdScrollers; - - (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/Scrollers.odc *) - (* DO NOT EDIT *) - - IMPORT Dialog, Ports, Services, Stores, Models, Views, Properties, Controllers, StdCFrames; - - - CONST - (* properties & options *) - horBar* = 0; verBar* = 1; horHide* = 2; verHide* = 3; width* = 4; height* = 5; showBorder* = 6; savePos* = 7; - - - TYPE - Prop* = POINTER TO RECORD (Properties.Property) - horBar*, verBar*: BOOLEAN; - horHide*, verHide*: BOOLEAN; - width*, height*: INTEGER; - showBorder*: BOOLEAN; - savePos*: BOOLEAN - END; - - ScrollBar = POINTER TO RECORD (Views.View) - v: View; - ver: BOOLEAN - END; - - InnerView = POINTER TO RECORD (Views.View) - v: View - END; - - View = POINTER TO RECORD (Views.View); - view: Views.View; - sbW: INTEGER; - orgX, orgY: INTEGER; - w, h: INTEGER; (* = 0: adapt to container *) - opts: SET; - (* not persistent *) - hor, ver: ScrollBar; - inner: InnerView; - rgap, bgap: INTEGER; (* = 0: no scrollbar *) - border: INTEGER; - update: Action - END; - - Context = POINTER TO RECORD (Models.Context) - v: View; - type: INTEGER - END; - - Action = POINTER TO RECORD (Services.Action) - v: View - END; - - Op = POINTER TO RECORD (Stores.Operation) - v: View; - p: Prop - END; - - SOp = POINTER TO RECORD (Stores.Operation) - v: View; - x, y: INTEGER - END; - - UpdateMsg = RECORD (Views.Message) - changed: BOOLEAN - END; - - - VAR - dialog*: RECORD - horizontal*, vertical*: RECORD - mode*: INTEGER; - adapt*: BOOLEAN; - size*: REAL - END; - showBorder*: BOOLEAN; - savePos*: BOOLEAN; - valid, readOnly: SET - END; - - - (* tools *) - - PROCEDURE CheckPos (v: View; VAR x, y: INTEGER); - VAR w, h: INTEGER; - BEGIN - v.context.GetSize(w, h); - DEC(w, v.rgap + 2 * v.border); - DEC(h, v.bgap + 2 * v.border); - IF x > v.w - w THEN x := v.w - w END; - IF x < 0 THEN x := 0 END; - IF y > v.h - h THEN y := v.h - h END; - IF y < 0 THEN y := 0 END - END CheckPos; - - PROCEDURE InnerFrame (v: View; f: Views.Frame): Views.Frame; - VAR g, h: Views.Frame; - BEGIN - g := Views.ThisFrame(f, v.inner); - IF g = NIL THEN - Views.InstallFrame(f, v.inner, v.border, v.border, 0, TRUE); - g := Views.ThisFrame(f, v.inner) - END; - IF g # NIL THEN - h := Views.ThisFrame(g, v.view); - IF h = NIL THEN - Views.InstallFrame(g, v.view, -v.orgX, -v.orgY, 0, TRUE); - h := Views.ThisFrame(g, v.view) - END - END; - RETURN h - END InnerFrame; - - PROCEDURE Scroll (v: View; dir: INTEGER; ver: BOOLEAN; p: INTEGER; OUT pos: INTEGER); - VAR x, y: INTEGER; last: Stores.Operation; op: SOp; - BEGIN - x := v.orgX; y := v.orgY; - IF ver THEN pos := y ELSE pos := x END; - IF dir = StdCFrames.lineUp THEN - DEC(pos, 10 * Ports.mm) - ELSIF dir = StdCFrames.lineDown THEN - INC(pos, 10 * Ports.mm) - ELSIF dir = StdCFrames.pageUp THEN - DEC(pos, 40 * Ports.mm) - ELSIF dir = StdCFrames.pageDown THEN - INC(pos, 40 * Ports.mm) - ELSIF dir = Controllers.gotoPos THEN - pos := p - END; - IF ver THEN CheckPos(v, x, pos); y := pos - ELSE CheckPos(v, pos, y); x := pos - END; - IF (x # v.orgX) OR (y # v.orgY) THEN - last := Views.LastOp(v); - IF ~(savePos IN v.opts) OR (last # NIL) & (last IS SOp) THEN - v.orgX := x; v.orgY := y; - Views.Update(v.view, Views.keepFrames) - ELSE - NEW(op); op.v := v; op.x := x; op.y := y; - Views.Do(v, "#System:Scrolling", op) - END - END - END Scroll; - - PROCEDURE PollSection (v: View; ver: BOOLEAN; OUT size, sect, pos: INTEGER); - VAR w, h: INTEGER; - BEGIN - v.context.GetSize(w, h); - IF ver THEN size := v.h; sect := h - v.bgap - 2 * v.border; pos := v.orgY - ELSE size := v.w; sect := w - v.rgap - 2 * v.border; pos := v.orgX - END - END PollSection; - - - (* SOp *) - - PROCEDURE (op: SOp) Do; - VAR x, y: INTEGER; - BEGIN - x := op.x; op.x := op.v.orgX; op.v.orgX := x; - y := op.y; op.y := op.v.orgY; op.v.orgY := y; - Views.Update(op.v.view, Views.keepFrames) - END Do; - - - (* properties *) - - PROCEDURE (p: Prop) IntersectWith* (q: Properties.Property; OUT equal: BOOLEAN); - VAR valid: SET; - BEGIN - WITH q: Prop DO - valid := p.valid * q.valid; equal := TRUE; - IF p.horBar # q.horBar THEN EXCL(valid, horBar) END; - IF p.verBar # q.verBar THEN EXCL(valid, verBar) END; - IF p.horHide # q.horHide THEN EXCL(valid, horHide) END; - IF p.verHide # q.verHide THEN EXCL(valid, verHide) END; - IF p.width # q.width THEN EXCL(valid, width) END; - IF p.height # q.height THEN EXCL(valid, height) END; - IF p.showBorder # q.showBorder THEN EXCL(valid, showBorder) END; - IF p.savePos # q.savePos THEN EXCL(valid, savePos) END; - IF p.valid # valid THEN p.valid := valid; equal := FALSE END - END - END IntersectWith; - - PROCEDURE SetProp (v: View; p: Properties.Property); - VAR op: Op; - BEGIN - WITH p: Prop DO - NEW(op); op.v := v; op.p := p; - Views.Do(v, "#System:SetProp", op) - END - END SetProp; - - PROCEDURE PollProp (v: View; OUT prop: Prop); - VAR p: Prop; - BEGIN - NEW(p); - p.valid := {horBar, verBar, horHide, verHide, width, height, showBorder, savePos}; - p.readOnly := {width, height} - v.opts; - p.horBar := horBar IN v.opts; - p.verBar := verBar IN v.opts; - p.horHide := horHide IN v.opts; - p.verHide := verHide IN v.opts; - p.width := v.w; - p.height := v.h; - p.showBorder := showBorder IN v.opts; - p.savePos := savePos IN v.opts; - p.known := p.valid; prop := p - END PollProp; - - - (* Op *) - - PROCEDURE (op: Op) Do; - VAR p: Prop; v: View; valid: SET; - BEGIN - v := op.v; p := op.p; PollProp(v, op.p); op.p.valid := p.valid; - valid := p.valid * ({horBar, verBar, horHide, verHide, showBorder, savePos} + v.opts * {width, height}); - IF horBar IN valid THEN - IF p.horBar THEN INCL(v.opts, horBar) ELSE EXCL(v.opts, horBar) END - END; - IF verBar IN valid THEN - IF p.verBar THEN INCL(v.opts, verBar) ELSE EXCL(v.opts, verBar) END - END; - IF horHide IN valid THEN - IF p.horHide THEN INCL(v.opts, horHide) ELSE EXCL(v.opts, horHide) END - END; - IF verHide IN valid THEN - IF p.verHide THEN INCL(v.opts, verHide) ELSE EXCL(v.opts, verHide) END - END; - IF width IN valid THEN v.w := p.width END; - IF height IN valid THEN v.h := p.height END; - IF showBorder IN valid THEN - IF p.showBorder THEN INCL(v.opts, showBorder); v.border := 2 * Ports.point - ELSE EXCL(v.opts, showBorder); v.border := 0 - END - END; - IF savePos IN valid THEN - IF p.savePos THEN INCL(v.opts, savePos) ELSE EXCL(v.opts, savePos) END - END; - Views.Update(v, Views.rebuildFrames) - END Do; - - - (* Action *) - - PROCEDURE (a: Action) Do; - VAR msg: UpdateMsg; - BEGIN - msg.changed := FALSE; - Views.Broadcast(a.v, msg); - IF msg.changed THEN Views.Update(a.v, Views.keepFrames) - ELSE - Views.Broadcast(a.v.hor, msg); - Views.Broadcast(a.v.ver, msg) - END - END Do; - - - (* ScrollBars *) - - PROCEDURE TrackSB (f: StdCFrames.ScrollBar; dir: INTEGER; VAR pos: INTEGER); - VAR s: ScrollBar; msg: Controllers.ScrollMsg; pmsg: Controllers.PollSectionMsg; host, inner: Views.Frame; - BEGIN - s := f.view(ScrollBar); host := Views.HostOf(f); - msg.focus := FALSE; msg.vertical := s.ver; - msg.op := dir; msg.done := FALSE; - inner := InnerFrame(s.v, host); - IF inner # NIL THEN Views.ForwardCtrlMsg(inner, msg) END; - IF msg.done THEN - pmsg.focus := FALSE; pmsg.vertical := s.ver; - pmsg.valid := FALSE; pmsg.done := FALSE; - inner := InnerFrame(s.v, host); - IF inner # NIL THEN Views.ForwardCtrlMsg(inner, pmsg) END; - IF pmsg.done THEN - pos := pmsg.partPos - END - ELSE - Scroll(s.v, dir, s.ver, 0, pos); - Views.ValidateRoot(Views.RootOf(host)) - END - END TrackSB; - - PROCEDURE SetSB (f: StdCFrames.ScrollBar; pos: INTEGER); - VAR s: ScrollBar; msg: Controllers.ScrollMsg; p: INTEGER; host, inner: Views.Frame; - BEGIN - s := f.view(ScrollBar); host := Views.HostOf(f); - msg.focus := FALSE; msg.vertical := s.ver; - msg.op := Controllers.gotoPos; msg.pos := pos; - msg.done := FALSE; - inner := InnerFrame(s.v, host); - IF inner # NIL THEN Views.ForwardCtrlMsg(inner, msg) END; - IF ~msg.done THEN - Scroll(s.v, Controllers.gotoPos, s.ver, pos, p); - Views.ValidateRoot(Views.RootOf(host)) - END - END SetSB; - - PROCEDURE GetSB (f: StdCFrames.ScrollBar; OUT size, sect, pos: INTEGER); - VAR s: ScrollBar; msg: Controllers.PollSectionMsg; host, inner: Views.Frame; - BEGIN - s := f.view(ScrollBar); host := Views.HostOf(f); - msg.focus := FALSE; msg.vertical := s.ver; - msg.wholeSize := 1; msg.partSize := 0; msg.partPos := 0; - msg.valid := FALSE; msg.done := FALSE; - inner := InnerFrame(s.v, host); - IF inner # NIL THEN Views.ForwardCtrlMsg(inner, msg) END; - IF msg.done THEN - IF msg.valid THEN - size := msg.wholeSize; sect := msg.partSize; pos := msg.partPos - ELSE - size := 1; sect := 1; pos := 0 - END - ELSE - PollSection(s.v, s.ver, size, sect, pos) - END - END GetSB; - - PROCEDURE (s: ScrollBar) GetNewFrame (VAR frame: Views.Frame); - VAR f: StdCFrames.ScrollBar; - BEGIN - f := StdCFrames.dir.NewScrollBar(); - f.disabled := FALSE; f.undef := FALSE; f.readOnly := FALSE; - f.Track := TrackSB; f.Get := GetSB; f.Set := SetSB; - frame := f - END GetNewFrame; - - PROCEDURE (s: ScrollBar) Restore (f: Views.Frame; l, t, r, b: INTEGER); - BEGIN - WITH f: StdCFrames.Frame DO f.Restore(l, t, r, b) END - END Restore; - - PROCEDURE (s: ScrollBar) HandleCtrlMsg (f: Views.Frame; VAR msg: Controllers.Message; - VAR focus: Views.View); - BEGIN - WITH f: StdCFrames.Frame DO - WITH msg: Controllers.PollCursorMsg DO - f.GetCursor(msg.x, msg.y, msg.modifiers, msg.cursor) - | msg: Controllers.TrackMsg DO - f.MouseDown(msg.x, msg.y, msg.modifiers) - ELSE - END - END - END HandleCtrlMsg; - - PROCEDURE (s: ScrollBar) HandleViewMsg (f: Views.Frame; VAR msg: Views.Message); - BEGIN - WITH msg: UpdateMsg DO - WITH f: StdCFrames.Frame DO f.Update() END - ELSE - END - END HandleViewMsg; - - - (* View *) - - PROCEDURE Update (v: View; f: Views.Frame); - VAR msg: Controllers.PollSectionMsg; w, h: INTEGER; depends: BOOLEAN; inner: Views.Frame; - BEGIN - v.bgap := 0; v.rgap := 0; depends := FALSE; - v.context.GetSize(w, h); - DEC(w, 2 * v.border); DEC(h, 2 * v.border); - IF horBar IN v.opts THEN - IF horHide IN v.opts THEN - msg.focus := FALSE; msg.vertical := FALSE; - msg.wholeSize := 1; msg.partSize := 0; msg.partPos := 0; - msg.valid := FALSE; msg.done := FALSE; - inner := InnerFrame(v, f); - IF inner # NIL THEN Views.ForwardCtrlMsg(inner, msg) END; - IF msg.done THEN - IF msg.valid THEN v.bgap := v.sbW END - ELSIF v.w > 0 THEN - IF w < v.w THEN v.bgap := v.sbW - ELSIF w - v.sbW < v.w THEN depends := TRUE - END - END - ELSE v.bgap := v.sbW - END - END; - IF verBar IN v.opts THEN - IF verHide IN v.opts THEN - msg.focus := FALSE; msg.vertical := TRUE; - msg.wholeSize := 1; msg.partSize := 0; msg.partPos := 0; - msg.valid := FALSE; msg.done := FALSE; - inner := InnerFrame(v, f); - IF inner # NIL THEN Views.ForwardCtrlMsg(inner, msg) END; - IF msg.done THEN - IF msg.valid THEN v.rgap := v.sbW END - ELSIF v.h > 0 THEN - IF h - v.bgap < v.h THEN v.rgap := v.sbW END - END - ELSE v.rgap := v.sbW - END - END; - IF depends & (v.rgap > 0) THEN v.bgap := v.sbW END; - CheckPos(v, v.orgX, v.orgY) - END Update; - - PROCEDURE Init (v: View; newView: BOOLEAN); - CONST min = 2 * Ports.mm; max = MAX(INTEGER); default = 50 * Ports.mm; - VAR c: Context; x: INTEGER; msg: Properties.ResizePref; - BEGIN - IF newView THEN - v.opts := v.opts + {horBar, verBar, horHide, verHide}; - StdCFrames.dir.GetScrollBarSize(x, v.sbW); - IF v.view.context # NIL THEN - v.view.context.GetSize(v.w, v.h); - v.view := Views.CopyOf(v.view, Views.shallow) - ELSE - v.w := Views.undefined; v.h := Views.undefined; - Properties.PreferredSize(v.view, min, max, min, max, default, default, v.w, v.h) - END; - msg.fixed := FALSE; - msg.horFitToWin := FALSE; msg.verFitToWin := FALSE; - msg.horFitToPage := FALSE; msg.verFitToPage := FALSE; - Views.HandlePropMsg(v.view, msg); - IF ~msg.fixed THEN - INCL(v.opts, width); INCL(v.opts, height); - IF msg.horFitToWin OR msg.horFitToPage THEN v.w := 0 END; - IF msg.verFitToWin OR msg.verFitToPage THEN v.h := 0 END - END - END; - v.rgap := 0; v.bgap := 0; - IF showBorder IN v.opts THEN v.border := 2 * Ports.point ELSE v.border := 0 END; - NEW(v.inner); v.inner.v := v; - NEW(c); c.v := v; c.type := 3; v.inner.InitContext(c); - NEW(v.hor); v.hor.ver := FALSE; v.hor.v := v; - NEW(c); c.v := v; c.type := 2; v.hor.InitContext(c); - NEW(v.ver); v.ver.ver := TRUE; v.ver.v := v; - NEW(c); c.v := v; c.type := 1; v.ver.InitContext(c); - NEW(v.update); v.update.v := v; - Stores.Join(v, v.view); - Stores.Join(v, v.inner); - Stores.Join(v, v.hor); - Stores.Join(v, v.ver); - Services.DoLater(v.update, Services.now) - END Init; - - PROCEDURE (v: View) Internalize (VAR rd: Stores.Reader); - VAR thisVersion: INTEGER; - BEGIN - v.Internalize^(rd); - IF ~rd.cancelled THEN - rd.ReadVersion(0, 0, thisVersion); - IF ~rd.cancelled THEN - Views.ReadView(rd, v.view); - rd.ReadInt(v.sbW); - rd.ReadInt(v.orgX); - rd.ReadInt(v.orgY); - rd.ReadInt(v.w); - rd.ReadInt(v.h); - rd.ReadSet(v.opts); - Init(v, FALSE) - END - END - END Internalize; - - PROCEDURE (v: View) Externalize (VAR wr: Stores.Writer); - BEGIN - v.Externalize^(wr); - wr.WriteVersion(0); - Views.WriteView(wr, v.view); - wr.WriteInt(v.sbW); - IF savePos IN v.opts THEN - wr.WriteInt(v.orgX); - wr.WriteInt(v.orgY) - ELSE - wr.WriteInt(0); - wr.WriteInt(0) - END; - wr.WriteInt(v.w); - wr.WriteInt(v.h); - wr.WriteSet(v.opts); - END Externalize; - - PROCEDURE (v: View) ThisModel(): Models.Model; - BEGIN - RETURN v.view.ThisModel() - END ThisModel; - - PROCEDURE (v: View) CopyFromModelView (source: Views.View; model: Models.Model); - BEGIN - WITH source: View DO - IF model = NIL THEN v.view := Views.CopyOf(source.view, Views.deep) - ELSE v.view := Views.CopyWithNewModel(source.view, model) - END; - v.sbW := source.sbW; - v.orgX := source.orgX; - v.orgY := source.orgY; - v.w := source.w; - v.h := source.h; - v.opts := source.opts; - END; - Init(v, FALSE) - END CopyFromModelView; - - PROCEDURE (v: View) InitContext (context: Models.Context); - VAR c: Context; - BEGIN - v.InitContext^(context); - IF v.view.context = NIL THEN - NEW(c); c.v := v; c.type := 0; v.view.InitContext(c) - END - END InitContext; - - PROCEDURE (v: View) Neutralize; - BEGIN - v.view.Neutralize - END Neutralize; - - PROCEDURE (v: View) Restore (f: Views.Frame; l, t, r, b: INTEGER); - VAR w, h: INTEGER; - BEGIN - v.context.GetSize(w, h); - IF showBorder IN v.opts THEN - v.border := 2 * f.dot; - f.DrawRect(0, f.dot, w, v.border, Ports.fill, Ports.black); - f.DrawRect(f.dot, 0, v.border, h, Ports.fill, Ports.black); - f.DrawRect(0, h - v.border, w, h - f.dot, Ports.fill, Ports.grey25); - f.DrawRect(w - v.border, 0, w - f.dot, h, Ports.fill, Ports.grey25); - f.DrawRect(0, 0, w, f.dot, Ports.fill, Ports.grey50); - f.DrawRect(0, 0, f.dot, h, Ports.fill, Ports.grey50); - f.DrawRect(0, h - f.dot, w, h, Ports.fill, Ports.white); - f.DrawRect(w - f.dot, 0, w, h, Ports.fill, Ports.white) - END; - Views.InstallFrame(f, v.inner, v.border, v.border, 0, TRUE); - IF v.bgap > 0 THEN Views.InstallFrame(f, v.hor, v.border, h - v.border - v.bgap, 0, FALSE) END; - IF v.rgap > 0 THEN Views.InstallFrame(f, v.ver, w - v.border - v.rgap, v.border, 0, FALSE) END - END Restore; - - PROCEDURE (v: View) HandleCtrlMsg (f: Views.Frame; VAR msg: Controllers.Message; VAR focus: Views.View); - VAR w, h, p, n: INTEGER;smsg: Controllers.ScrollMsg; inner: Views.Frame; - BEGIN - WITH msg: Controllers.WheelMsg DO - smsg.focus := FALSE; smsg.op := msg.op; smsg.pos := 0; smsg.done := FALSE; n := msg.nofLines; - IF (v.rgap > 0) OR (v.bgap > 0) THEN - smsg.vertical := v.rgap > 0; - REPEAT - smsg.done := FALSE; - inner := InnerFrame(v, f); - IF inner # NIL THEN Views.ForwardCtrlMsg(inner, smsg) END; - IF ~smsg.done THEN - Scroll(v, smsg.op, smsg.vertical, 0, p); - Views.ValidateRoot(Views.RootOf(f)) - END; - DEC(n) - UNTIL n <= 0; - msg.done := TRUE - ELSE - focus := v.inner - END - | msg: Controllers.CursorMessage DO - v.context.GetSize(w, h); - IF msg.x > w - v.border - v.rgap THEN - IF msg.y <= h - v.border - v.bgap THEN focus := v.ver END - ELSIF msg.y > h - v.border - v.bgap THEN focus := v.hor - ELSE focus := v.inner - END - | msg: Controllers.PollSectionMsg DO - inner := InnerFrame(v, f); - IF inner # NIL THEN Views.ForwardCtrlMsg(inner, msg) END; - IF ~msg.done THEN - PollSection(v, msg.vertical, msg.wholeSize, msg.partSize, msg.partPos); - msg.valid := msg.partSize < msg.wholeSize; - msg.done := TRUE - END - | msg: Controllers.ScrollMsg DO - inner := InnerFrame(v, f); - IF inner # NIL THEN Views.ForwardCtrlMsg(inner, msg) END; - IF ~msg.done THEN - Scroll(v, msg.op, msg.vertical, msg.pos, p); - Views.ValidateRoot(Views.RootOf(f)); - msg.done := TRUE - END - ELSE focus := v.inner - END; - IF ~(msg IS Controllers.TickMsg) THEN - Services.DoLater(v.update, Services.now) - END - END HandleCtrlMsg; - - PROCEDURE (v: View) HandleViewMsg (f: Views.Frame; VAR msg: Views.Message); - VAR b, r: INTEGER; - BEGIN - WITH msg: UpdateMsg DO - b := v.bgap; r := v.rgap; - Update(v, f); - IF (v.bgap # b) OR (v.rgap # r) THEN msg.changed := TRUE END - ELSE - END - END HandleViewMsg; - - PROCEDURE (v: View) HandlePropMsg (VAR msg: Properties.Message); - VAR w, h: INTEGER; p: Properties.Property; prop: Prop; fv: Views.View; - BEGIN - WITH msg: Properties.FocusPref DO - v.context.GetSize(w, h); - Views.HandlePropMsg(v.view, msg); - IF msg.atLocation THEN - IF (msg.x > w - v.border - v.rgap) & (msg.y > h - v.border - v.bgap) THEN - msg.hotFocus := FALSE; msg.setFocus := FALSE - ELSIF ((msg.x > w - v.border - v.rgap) OR (msg.y > h - v.border - v.bgap)) & ~msg.setFocus THEN - msg.hotFocus := TRUE - END - END - | msg: Properties.SizePref DO - IF (v.w > 0) & (v.h > 0) THEN - IF msg.w = Views.undefined THEN msg.w := 50 * Ports.mm END; - IF msg.h = Views.undefined THEN msg.h := 50 * Ports.mm END - ELSE - IF msg.w > v.rgap THEN DEC(msg.w, v.rgap + 2 * v.border) END; - IF msg.h > v.bgap THEN DEC(msg.h, v.bgap + 2 * v.border) END; - Views.HandlePropMsg(v.view, msg); - IF msg.w > 0 THEN INC(msg.w, v.rgap + 2 * v.border) END; - IF msg.h > 0 THEN INC(msg.h, v.bgap + 2 * v.border) END - END; - IF msg.w < 3 * v.sbW THEN msg.w := 3 * v.sbW END; - IF msg.h < 3 * v.sbW THEN msg.h := 3 * v.sbW END - | msg: Properties.ResizePref DO - Views.HandlePropMsg(v.view, msg); - IF v.w > 0 THEN - msg.fixed := FALSE; - msg.horFitToWin := TRUE; - msg.horFitToPage := FALSE - END; - IF v.h > 0 THEN - msg.fixed := FALSE; - msg.verFitToWin := TRUE; - msg.verFitToPage := FALSE - END - | msg: Properties.BoundsPref DO - Views.HandlePropMsg(v.view, msg); - INC(msg.w, 2 * v.border); - INC(msg.h, 2 * v.border); - IF (horBar IN v.opts) & ~(horHide IN v.opts) THEN INC(msg.w, v.sbW) END; - IF (verBar IN v.opts) & ~(verHide IN v.opts) THEN INC(msg.h, v.sbW) END - | msg: Properties.PollMsg DO - Views.HandlePropMsg(v.view, msg); - PollProp(v, prop); Properties.Insert(msg.prop, prop) - | msg: Properties.SetMsg DO - p := msg.prop; WHILE (p # NIL) & ~(p IS Prop) DO p := p.next END; - IF p # NIL THEN SetProp(v, p) END; - Views.HandlePropMsg(v.view, msg); - | msg: Properties.ControlPref DO - fv := msg.focus; - IF fv = v THEN msg.focus := v.view END; - Views.HandlePropMsg(v.view, msg); - msg.focus := fv - ELSE - Views.HandlePropMsg(v.view, msg); - END; - END HandlePropMsg; - - - (* InnerView *) - - PROCEDURE (v: InnerView) GetBackground (VAR color: Ports.Color); - BEGIN - color := Ports.background - END GetBackground; - - PROCEDURE (v: InnerView) Restore (f: Views.Frame; l, t, r, b: INTEGER); - BEGIN - Views.InstallFrame(f, v.v.view, -v.v.orgX, -v.v.orgY, 0, TRUE) - END Restore; - - PROCEDURE (v: InnerView) HandleCtrlMsg (f: Views.Frame; VAR msg: Controllers.Message; - VAR focus: Views.View); - BEGIN - focus := v.v.view - END HandleCtrlMsg; - - - (* Context *) - - PROCEDURE (c: Context) MakeVisible (l, t, r, b: INTEGER); - VAR w, h, x, y: INTEGER; - BEGIN - IF ~(savePos IN c.v.opts) THEN - c.v.context.GetSize(w, h); - x := c.v.orgX; y := c.v.orgY; - IF c.v.w > 0 THEN - DEC(w, c.v.rgap + 2 * c.v.border); - IF r > x + w - Ports.point THEN x := r - w + Ports.point END; - IF l < x + Ports.point THEN x := l - Ports.point END; - END; - IF c.v.h > 0 THEN - DEC(h, c.v.bgap + 2 * c.v.border); - IF b > y + h - Ports.point THEN y := b - h + Ports.point END; - IF t < y + Ports.point THEN y := t - Ports.point END; - END; - IF (x # c.v.orgX) OR (y # c.v.orgY) THEN - CheckPos(c.v, x, y); c.v.orgX := x; c.v.orgY := y; - Views.Update(c.v.view, Views.keepFrames) - END; - Services.DoLater(c.v.update, Services.now) - END - END MakeVisible; - - PROCEDURE (c: Context) Consider (VAR p: Models.Proposal); - BEGIN - c.v.context.Consider(p) - END Consider; - - PROCEDURE (c: Context) Normalize (): BOOLEAN; - BEGIN - RETURN ~(savePos IN c.v.opts) - END Normalize; - - PROCEDURE (c: Context) GetSize (OUT w, h: INTEGER); - BEGIN - c.v.context.GetSize(w, h); - DEC(w, c.v.rgap + 2 * c.v.border); - DEC(h, c.v.bgap + 2 * c.v.border); - IF c.type = 0 THEN - IF c.v.w > 0 THEN w := c.v.w END; - IF c.v.h > 0 THEN h := c.v.h END - ELSIF c.type = 1 THEN - w := c.v.rgap - ELSIF c.type = 2 THEN - h := c.v.bgap - END - END GetSize; - - PROCEDURE (c: Context) SetSize (w, h: INTEGER); - VAR w0, h0, w1, h1: INTEGER; - BEGIN - ASSERT(c.type = 0, 100); - c.v.context.GetSize(w0, h0); w1 := w0; h1 := h0; - IF c.v.w > 0 THEN c.v.w := w - ELSE w1 := w + c.v.rgap + 2 * c.v.border - END; - IF c.v.h > 0 THEN c.v.h := h - ELSE h1 := h + c.v.bgap + 2 * c.v.border - END; - IF (w1 # w0) OR (h1 # h0) THEN - c.v.context.SetSize(w1, h1) - END - END SetSize; - - PROCEDURE (c: Context) ThisModel (): Models.Model; - BEGIN - RETURN NIL - END ThisModel; - - - (* dialog *) - - PROCEDURE InitDialog*; - VAR p: Properties.Property; u: INTEGER; - BEGIN - Properties.CollectProp(p); - WHILE (p # NIL) & ~(p IS Prop) DO p := p.next END; - IF p # NIL THEN - WITH p: Prop DO - IF Dialog.metricSystem THEN u := Ports.mm DIV 10 ELSE u := Ports.inch DIV 100 END; - dialog.valid := p.valid; - dialog.readOnly := p.readOnly; - IF ~p.horBar THEN dialog.horizontal.mode := 0 - ELSIF p.horHide THEN dialog.horizontal.mode := 1 - ELSE dialog.horizontal.mode := 2 - END; - IF ~p.verBar THEN dialog.vertical.mode := 0 - ELSIF p.verHide THEN dialog.vertical.mode := 1 - ELSE dialog.vertical.mode := 2 - END; - dialog.horizontal.size := p.width DIV u / 100; - dialog.vertical.size := p.height DIV u / 100; - dialog.horizontal.adapt := p.width = 0; - dialog.vertical.adapt := p.height = 0; - dialog.showBorder := p.showBorder; - dialog.savePos := p.savePos - END - END - END InitDialog; - - PROCEDURE Set*; - VAR p: Prop; u: INTEGER; - BEGIN - IF Dialog.metricSystem THEN u := 10 * Ports.mm ELSE u := Ports.inch END; - NEW(p); p.valid := dialog.valid; - p.horBar := dialog.horizontal.mode # 0; - p.verBar := dialog.vertical.mode # 0; - p.horHide := dialog.horizontal.mode = 1; - p.verHide := dialog.vertical.mode = 1; - IF ~dialog.horizontal.adapt THEN p.width := SHORT(ENTIER(dialog.horizontal.size * u)) END; - IF ~dialog.vertical.adapt THEN p.height := SHORT(ENTIER(dialog.vertical.size * u)) END; - p.showBorder := dialog.showBorder; - p.savePos := dialog.savePos; - Properties.EmitProp(NIL, p) - END Set; - - PROCEDURE DialogGuard* (VAR par: Dialog.Par); - VAR p: Properties.Property; - BEGIN - Properties.CollectProp(p); - WHILE (p # NIL) & ~(p IS Prop) DO p := p.next END; - IF p = NIL THEN par.disabled := TRUE END - END DialogGuard; - - PROCEDURE HorAdaptGuard* (VAR par: Dialog.Par); - BEGIN - IF width IN dialog.readOnly THEN par.readOnly := TRUE END - END HorAdaptGuard; - - PROCEDURE VerAdaptGuard* (VAR par: Dialog.Par); - BEGIN - IF height IN dialog.readOnly THEN par.readOnly := TRUE END - END VerAdaptGuard; - - PROCEDURE WidthGuard* (VAR par: Dialog.Par); - BEGIN - IF dialog.horizontal.adapt THEN par.disabled := TRUE - ELSIF width IN dialog.readOnly THEN par.readOnly := TRUE - END - END WidthGuard; - - PROCEDURE HeightGuard* (VAR par: Dialog.Par); - BEGIN - IF dialog.vertical.adapt THEN par.disabled := TRUE - ELSIF height IN dialog.readOnly THEN par.readOnly := TRUE - END - END HeightGuard; - - - (* commands *) - - PROCEDURE AddScroller*; - VAR poll: Controllers.PollOpsMsg; v: View; replace: Controllers.ReplaceViewMsg; - BEGIN - Controllers.PollOps(poll); - IF (poll.singleton # NIL) & ~(poll.singleton IS View) THEN - NEW(v); v.view := poll.singleton; Init(v, TRUE); - replace.old := poll.singleton; replace.new := v; - Controllers.Forward(replace) - ELSE Dialog.Beep - END - END AddScroller; - - PROCEDURE RemoveScroller*; - VAR poll: Controllers.PollOpsMsg; replace: Controllers.ReplaceViewMsg; - BEGIN - Controllers.PollOps(poll); - IF (poll.singleton # NIL) & (poll.singleton IS View) THEN - replace.old := poll.singleton; - replace.new := Views.CopyOf(poll.singleton(View).view, Views.shallow); - Controllers.Forward(replace) - ELSE Dialog.Beep - END - END RemoveScroller; - -END StdScrollers. diff --git a/new/Std/Mod/Stamps.txt b/new/Std/Mod/Stamps.txt deleted file mode 100644 index 50bf0ea..0000000 --- a/new/Std/Mod/Stamps.txt +++ /dev/null @@ -1,436 +0,0 @@ -MODULE StdStamps; - - (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/Stamps.odc *) - (* DO NOT EDIT *) - -(* - StdStamps are used to keep track of document changes, in particular program texts. - StdStamps carry a sequence number and a fingerprint of the document with them. - Each time the document (and therefore its fingerprint) is changed and stored, - the sequence number is incremented. (When determining the fingerprint of the - document, whitespace is ignored, except in string literals.) - - Each StdStamp also keeps track of the history of most recent changes. - For the last maxHistoryEntries sequence numbers, the date and time, - and an optional one-line comment is stored. To avoid too many entries in the history - while working on a module, the most recent history entry is overwritten upon the - generation of a new sequence number if the current date is the same as the date in - the history entry. - -*) - - IMPORT - SYSTEM, (* SYSTEM.ROT only, for fingerprint calculation *) - Strings, Dates, StdCmds, - Ports, Models, Stores, Containers, Properties, Views, Controllers, Fonts, - TextModels, TextSetters, TextMappers, TextViews, TextRulers; - - CONST - setCommentKey = "#Std:Set Comment"; - maxHistoryEntries = 25; - minVersion = 0; origStampVersion = 0; thisVersion = 2; - - TYPE - History = ARRAY maxHistoryEntries OF RECORD - fprint, snr: INTEGER; (* fingerprint, sequence number *) - date: INTEGER; (* days since 1/1/1 *) - time: INTEGER; (* min + 64 * hour *) - comment: POINTER TO ARRAY OF CHAR; (* nil if no comment *) - END; - - StdView = POINTER TO RECORD (Views.View) - (*--snr: LONGINT;*) - nentries: INTEGER; (* number of entries in history *) - history: History; (* newest entry in history[0] *) - cache: ARRAY 64 OF CHAR; - END; - - SetCmtOp = POINTER TO RECORD (Stores.Operation) - stamp: StdView; - oldcomment: POINTER TO ARRAY OF CHAR; - END; - - VAR - comment*: RECORD - s*: ARRAY 64 OF CHAR; - END; - - - PROCEDURE (op: SetCmtOp) Do; - VAR temp: POINTER TO ARRAY OF CHAR; - BEGIN - temp := op.stamp.history[0].comment; - op.stamp.history[0].comment := op.oldcomment; - op.oldcomment := temp; - END Do; - - PROCEDURE Format (v: StdView); - VAR s: ARRAY 64 OF CHAR; d: Dates.Date; t: INTEGER; - BEGIN - t := v.history[0].time; - Dates.DayToDate(v.history[0].date, d); - Dates.DateToString(d, Dates.plainAbbreviated, s); v.cache := s$; - Strings.IntToStringForm(v.history[0].snr, Strings.decimal, 4, "0", FALSE, s); - v.cache := v.cache + " (" + s + ")" - END Format; - - - PROCEDURE FontContext (v: StdView): Fonts.Font; - VAR c: Models.Context; - BEGIN - c := v.context; - IF (c # NIL) & (c IS TextModels.Context) THEN - RETURN c(TextModels.Context).Attr().font; - ELSE - RETURN Fonts.dir.Default() - END; - END FontContext; - - PROCEDURE CalcFP (t: TextModels.Model): INTEGER; - CONST sglQuote = "'"; dblQuote = '"'; - VAR fp: INTEGER; rd: TextModels.Reader; ch, quoteChar: CHAR; - BEGIN - quoteChar := 0X; fp := 0; - rd := t.NewReader(NIL); rd.ReadChar(ch); - WHILE ~rd.eot DO - IF ch = quoteChar THEN quoteChar := 0X; - ELSIF (quoteChar = 0X) & ((ch = dblQuote) OR (ch = sglQuote)) THEN quoteChar := ch; - END; - IF (quoteChar = 0X) & (21X <= ch) & (ch # 8BX) & (ch # 8FX) & (ch # 0A0X) (* not in string literal *) - OR (quoteChar # 0X) & (20X <= ch) (* within string literal *) - THEN - fp := SYSTEM.ROT(fp, 1) + 13 * ORD(ch); - END; - rd.ReadChar(ch); - END; - RETURN fp; - END CalcFP; - - PROCEDURE Update (v: StdView; forcenew: BOOLEAN); - VAR fp: INTEGER; i: INTEGER; ndays: INTEGER; d: Dates.Date; t: Dates.Time; - BEGIN - IF (v.context # NIL) & (v.context IS TextModels.Context) THEN - fp := CalcFP(v.context(TextModels.Context).ThisModel()); - IF (fp # v.history[0].fprint) OR forcenew THEN - Dates.GetDate(d); Dates.GetTime(t); - ndays := Dates.Day(d); - IF (ndays # v.history[0].date) OR forcenew THEN - (* move down entries in history list *) - i := maxHistoryEntries-1; - WHILE i > 0 DO - v.history[i] := v.history[i-1]; - DEC(i); - END; - v.history[0].comment := NIL; - END; - IF v.nentries < maxHistoryEntries THEN INC(v.nentries) END; - INC(v.history[0].snr); - v.history[0].fprint := fp; - v.history[0].date := ndays; - v.history[0].time := t.minute + t.hour*64; - Format(v); - Views.Update(v, Views.keepFrames); - END; - END; - END Update; - - PROCEDURE (v: StdView) Externalize (VAR wr: Stores.Writer); - VAR i, len: INTEGER; - BEGIN - Update(v, FALSE); - v.Externalize^(wr); - wr.WriteVersion(thisVersion); - (*--wr.WriteLInt(v.snr);*) - wr.WriteXInt(v.nentries); - FOR i := 0 TO v.nentries-1 DO - wr.WriteInt(v.history[i].fprint); - wr.WriteInt(v.history[i].snr); - wr.WriteInt(v.history[i].date); - wr.WriteXInt(v.history[i].time); - IF v.history[i].comment # NIL THEN - len := LEN(v.history[i].comment$); - wr.WriteXInt(len); - wr.WriteXString(v.history[i].comment^); - ELSE wr.WriteXInt(0); - END - END; - END Externalize; - - PROCEDURE (v: StdView) Internalize (VAR rd: Stores.Reader); - VAR version: INTEGER; format: BYTE; i, len: INTEGER; - d: Dates.Date; t: Dates.Time; - BEGIN - v.Internalize^(rd); - IF ~rd.cancelled THEN - rd.ReadVersion(minVersion, thisVersion, version); - IF ~rd.cancelled THEN - IF version = origStampVersion THEN (* deal with old StdStamp format *) - (* would like to calculate fingerprint, but hosting model not available at this time *) - v.history[0].fprint := 0; - v.history[0].snr := 1; v.nentries := 1; - rd.ReadXInt(d.year); rd.ReadXInt(d.month); rd.ReadXInt(d.day); - rd.ReadXInt(t.hour); rd.ReadXInt(t.minute); rd.ReadXInt(t.second); - rd.ReadByte(format); (* format not used anymore *) - v.history[0].date := Dates.Day(d); - v.history[0].time := t.minute + t.hour*64; - ELSE - IF version = 1 THEN rd.ReadInt(v.history[0].snr) END; (* red text: to be removed soon *) - rd.ReadXInt(v.nentries); - FOR i := 0 TO v.nentries-1 DO - rd.ReadInt(v.history[i].fprint); - IF version > 1 THEN rd.ReadInt(v.history[i].snr) - ELSIF (* (version = 1) & *) i > 0 THEN v.history[i].snr := v.history[i-1].snr - 1; - END; (* red text: to be removed soon *) - rd.ReadInt(v.history[i].date); - rd.ReadXInt(v.history[i].time); - rd.ReadXInt(len); - IF len > 0 THEN - NEW(v.history[i].comment, len + 1); - rd.ReadXString(v.history[i].comment^); - ELSE v.history[i].comment := NIL; - END - END; - END; - Format(v); - END - END - END Internalize; - - PROCEDURE (v: StdView) CopyFromSimpleView (source: Views.View); - VAR i: INTEGER; - BEGIN - (* v.CopyFrom^(source); *) - WITH source: StdView DO - (*--v.snr := source.snr;*) - v.nentries := source.nentries; - v.history := source.history; - v.cache := source.cache; - FOR i := 0 TO v.nentries - 1 DO - IF source.history[i].comment # NIL THEN - NEW(v.history[i].comment, LEN(source.history[i].comment$) + 1); - v.history[i].comment^ := source.history[i].comment^$; - END - END - END - END CopyFromSimpleView; - - PROCEDURE (v: StdView) Restore (f: Views.Frame; l, t, r, b: INTEGER); - VAR a: TextModels.Attributes; color: Ports.Color; c: Models.Context; font: Fonts.Font; - asc, dsc, fw: INTEGER; - BEGIN - c := v.context; - IF (c # NIL) & (c IS TextModels.Context) THEN - a := v.context(TextModels.Context).Attr(); - font := a.font; - color := a.color; - ELSE font := Fonts.dir.Default(); color := Ports.black; - END; - font.GetBounds(asc, dsc, fw); - f.DrawLine(f.l, asc + f.dot, f.r, asc + f.dot, 1, Ports.grey25 ); - f.DrawString(0, asc, color, v.cache, font); - END Restore; - - PROCEDURE SizePref (v: StdView; VAR p: Properties.SizePref); - VAR font: Fonts.Font; asc, dsc, w: INTEGER; d: Dates.Date; s: ARRAY 64 OF CHAR; - BEGIN - font := FontContext(v); - font.GetBounds(asc, dsc, w); - d.day := 28; d.month := 1; d.year := 2222; p.w := 0; - WHILE d.month <= 12 DO - Dates.DateToString(d, Dates.plainAbbreviated, s); - s := s + " (0000)"; - w := font.StringWidth(s); - IF w > p.w THEN p.w := w END; - INC(d.month) - END; - p.h := asc + dsc; - END SizePref; - - PROCEDURE (v: StdView) HandlePropMsg (VAR msg: Properties.Message); - VAR font: Fonts.Font; asc, w: INTEGER; - BEGIN - WITH msg: Properties.Preference DO - WITH msg: Properties.SizePref DO - SizePref(v, msg) - | msg: Properties.ResizePref DO - msg.fixed := TRUE - | msg: Properties.FocusPref DO - msg.hotFocus := TRUE - | msg: TextSetters.Pref DO - font := FontContext(v); - font.GetBounds(asc, msg.dsc, w); - ELSE - END - ELSE - END - END HandlePropMsg; - - PROCEDURE NewRuler (): TextRulers.Ruler; - CONST mm = Ports.mm; - VAR r: TextRulers.Ruler; - BEGIN - r := TextRulers.dir.New(NIL); - TextRulers.SetRight(r, 140 * mm); - TextRulers.AddTab(r, 15 * mm); TextRulers.AddTab(r, 35 * mm); TextRulers.AddTab(r, 75 * mm); - RETURN r - END NewRuler; - - PROCEDURE ShowHistory (v: StdView); - VAR text: TextModels.Model; f: TextMappers.Formatter; - i: INTEGER; d: Dates.Date; s: ARRAY 64 OF CHAR; - tv: TextViews.View; attr: TextModels.Attributes; - BEGIN - text := TextModels.dir.New(); - f.ConnectTo(text); - attr := f.rider.attr; - f.rider.SetAttr(TextModels.NewStyle(attr, {Fonts.italic})); - f.WriteString("seq nr."); f.WriteTab; - f.WriteString("fingerprint"); f.WriteTab; - f.WriteString("date and time"); f.WriteTab; - f.WriteString("comment"); f.WriteLn; - f.rider.SetAttr(attr); f.WriteLn; - (*--n := v.snr;*) - FOR i := 0 TO v.nentries-1 DO - f.WriteIntForm(v.history[i].snr, 10, 4, "0", FALSE); - (*--DEC(n);*) - f.WriteTab; - f.WriteIntForm(v.history[i].fprint, TextMappers.hexadecimal, 8, "0", FALSE); - f.WriteTab; - Dates.DayToDate(v.history[i].date, d); - Dates.DateToString(d, Dates.plainAbbreviated, s); - f.WriteString(s); - f.WriteString(" "); - f.WriteIntForm(v.history[i].time DIV 64, 10, 2, "0", FALSE); - f.WriteString(":"); - f.WriteIntForm(v.history[i].time MOD 64, 10, 2, "0", FALSE); - IF v.history[i].comment # NIL THEN - f.WriteTab; - f.WriteString( v.history[i].comment^); - END; - f.WriteLn; - END; - tv := TextViews.dir.New(text); - tv.SetDefaults(NewRuler(), TextViews.dir.defAttr); - tv.ThisController().SetOpts({Containers.noFocus, Containers.noCaret}); - Views.OpenAux(tv, "History"); - END ShowHistory; - - PROCEDURE Track (v: StdView; f: Views.Frame; x, y: INTEGER; buttons: SET); - VAR c: Models.Context; w, h: INTEGER; isDown, in, in0: BOOLEAN; m: SET; - BEGIN - c := v.context; c.GetSize(w, h); in0 := FALSE; in := TRUE; - REPEAT - IF in # in0 THEN - f.MarkRect(0, 0, w, h, Ports.fill, Ports.invert, Ports.show); in0 := in - END; - f.Input(x, y, m, isDown); - in := (0 <= x) & (x < w) & (0 <= y) & (y < h) - UNTIL ~isDown; - IF in0 THEN - f.MarkRect(0, 0, w, h, Ports.fill, Ports.invert, Ports.hide); - IF Controllers.modify IN m THEN - IF v.history[0].comment # NIL THEN comment.s := v.history[0].comment^$; - ELSE comment.s := ""; - END; - StdCmds.OpenToolDialog("Std/Rsrc/Stamps", "Comment"); - ELSE ShowHistory(v); - END - END - END Track; - - PROCEDURE (v: StdView) HandleCtrlMsg ( - f: Views.Frame; VAR msg: Controllers.Message; VAR focus: Views.View); - BEGIN - WITH msg: Controllers.TrackMsg DO - Track(v, f, msg.x, msg.y, msg.modifiers) - | msg: Controllers.PollCursorMsg DO - msg.cursor := Ports.refCursor - ELSE - END - END HandleCtrlMsg; - - - (* ------------ programming interface: ---------------------- *) - - PROCEDURE GetFirstInText* (t: TextModels.Model): Views.View; - VAR r: TextModels.Reader; v: Views.View; - BEGIN - IF t # NIL THEN - r := t.NewReader(NIL); - REPEAT r.ReadView(v) UNTIL (v = NIL) OR (v IS StdView); - RETURN v; - ELSE RETURN NIL; - END; - END GetFirstInText; - - PROCEDURE IsStamp* (v: Views.View): BOOLEAN; - BEGIN - RETURN v IS StdView; - END IsStamp; - - PROCEDURE GetInfo* (v: Views.View; VAR snr, historylen: INTEGER); - BEGIN - ASSERT(v IS StdView, 20); - WITH v: StdView DO - snr := v.history[0].snr; historylen := v.nentries; - END - END GetInfo; - - PROCEDURE GetData* (v: Views.View; entryno: INTEGER; - VAR fprint: INTEGER; VAR date: Dates.Date; VAR time: Dates.Time); - BEGIN - ASSERT(v IS StdView, 20); - WITH v: StdView DO - IF entryno <= v.nentries THEN - fprint := v.history[entryno].fprint; - Dates.DayToDate(v.history[entryno].date, date); - time.minute := v.history[entryno].time MOD 64; - time.minute := v.history[entryno].time DIV 64; - time.second := 0; - END - END - END GetData; - - (** Insert new history entry with comment in v. *) - PROCEDURE Stamp* (v: Views.View; comment: ARRAY OF CHAR); - BEGIN - ASSERT(v IS StdView, 20); - WITH v: StdView DO - Update(v, TRUE); - NEW(v.history[0].comment, LEN(comment$) + 1); - v.history[0].comment^ := comment$; - END - END Stamp; - - PROCEDURE New* (): Views.View; - VAR v: StdView; d: Dates.Date; t: Dates.Time; - BEGIN - NEW(v); v.history[0].snr := 0; v.nentries := 0; - v.history[0].fprint := 0; - Dates.GetDate(d); Dates.GetTime(t); - v.history[0].date := Dates.Day(d); - v.history[0].time := t.minute + t.hour*64; - Format(v); - RETURN v; - END New; - - PROCEDURE SetComment*; - VAR v: Views.View; op: SetCmtOp; - BEGIN - v := GetFirstInText(TextViews.FocusText()); - IF v # NIL THEN - WITH v: StdView DO - NEW(op); op.stamp := v; - NEW(op.oldcomment, LEN(comment.s$) + 1); - op.oldcomment^ := comment.s$; - Views.Do(v, setCommentKey, op); - END - END - END SetComment; - - PROCEDURE Deposit*; - BEGIN - Views.Deposit(New()) - END Deposit; - -END StdStamps. diff --git a/new/Std/Mod/ViewSizer.txt b/new/Std/Mod/ViewSizer.txt deleted file mode 100644 index 9d3f6fc..0000000 --- a/new/Std/Mod/ViewSizer.txt +++ /dev/null @@ -1,133 +0,0 @@ -MODULE StdViewSizer; - - (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/ViewSizer.odc *) - (* DO NOT EDIT *) - - IMPORT Services, Ports, Dialog, Views, Containers, Properties; - - CONST width = 1; height = 2; - - VAR - size*: RECORD - typeName-: Dialog.String; - w*, h*: REAL; - proportional*, fixedW, fixedH: BOOLEAN; - unit, scaleW, scaleH, lastChanged: INTEGER; - unitText: ARRAY 6 OF CHAR; - view: Views.View; - container: Containers.Controller - END; - - PROCEDURE ConnectDialog (v: Views.View; c: Containers.Controller); - VAR pref: Properties.ResizePref; - BEGIN - IF (v # NIL) & (v.context # NIL) THEN - IF Dialog.metricSystem THEN size.unit := Ports.mm * 10; size.unitText := "cm" - ELSE size.unit := Ports.inch; size.unitText := "inch" - END; - size.view := v; size.container := c; - Services.GetTypeName(v, size.typeName); - v.context.GetSize(size.scaleW, size.scaleH); - size.w := size.scaleW / size.unit; size.h := size.scaleH / size.unit; - pref.fixed := FALSE; - pref.horFitToPage := FALSE; pref.verFitToPage := FALSE; - pref.horFitToWin := FALSE; pref.verFitToWin := FALSE; - Views.HandlePropMsg(v, pref); - size.fixedW := pref.fixed; - size.fixedH := pref.fixed; - size.proportional := FALSE - ELSE - size.view := NIL; size.container := c; size.typeName := "" - END; - Dialog.Update(size) - END ConnectDialog; - - PROCEDURE SetViewSize*; - BEGIN - IF size.view # NIL THEN - size.view.context.SetSize(SHORT(ENTIER(size.w * size.unit + 0.5)), - SHORT(ENTIER(size.h * size.unit + 0.5))); - IF size.container # NIL THEN size.container.SetSingleton(size.view) END; - ConnectDialog(size.view, size.container) - ELSE Dialog.Beep - END - END SetViewSize; - - PROCEDURE InitDialog*; - VAR v: Views.View; c: Containers.Controller; - BEGIN - c := Containers.Focus(); - IF c # NIL THEN v := c.Singleton() ELSE v := NIL END; - IF (v # size.view) OR (c # size.container) THEN ConnectDialog(v, c) END - END InitDialog; - - PROCEDURE ResetDialog*; - VAR proportional: BOOLEAN; v: Views.View; - BEGIN - proportional := size.proportional; v := size.view; - size.view := NIL; InitDialog; - IF proportional & (v = size.view) THEN size.proportional := TRUE; Dialog.Update(size) END - END ResetDialog; - - PROCEDURE WidthGuard* (VAR par: Dialog.Par); - BEGIN - InitDialog; - par.disabled := size.view = NIL; - par.readOnly := size.fixedW - END WidthGuard; - - PROCEDURE HeightGuard* (VAR par: Dialog.Par); - BEGIN - InitDialog; - par.disabled := size.view = NIL; - par.readOnly := size.fixedH - END HeightGuard; - - PROCEDURE ProportionGuard* (VAR par: Dialog.Par); - BEGIN - par.disabled := (size.view = NIL) OR size.fixedW OR size.fixedH OR (size.scaleW = 0) OR (size.scaleH = 0) - END ProportionGuard; - - PROCEDURE UnitGuard* (VAR par: Dialog.Par); - BEGIN - IF size.view # NIL THEN par.label := size.unitText$ ELSE par.label := "" END - END UnitGuard; - - PROCEDURE AdjustDialogToPref (fixedW, fixedH: BOOLEAN); - VAR w, h: INTEGER; w0, h0: REAL; pref: Properties.SizePref; - BEGIN - w := SHORT(ENTIER(size.w * size.unit + 0.5)); h := SHORT(ENTIER(size.h * size.unit + 0.5)); - IF size.proportional & (w > 0) & (h > 0) & (size.scaleW > 0) & (size.scaleH > 0) THEN - Properties.ProportionalConstraint(size.scaleW, size.scaleH, fixedW, fixedH, w, h) - END; - pref.w := w; pref.h := h; pref.fixedW := fixedW; pref.fixedH := fixedH; - Views.HandlePropMsg(size.view, pref); - IF ~fixedW THEN w0 := pref.w / size.unit ELSE w0 := size.w END; - IF ~fixedH THEN h0 := pref.h / size.unit ELSE h0 := size.h END; - IF (w0 # size.w) OR (h0 # size.h) THEN size.w := w0; size.h := h0; Dialog.Update(size) END - END AdjustDialogToPref; - - PROCEDURE WNotifier* (op, from, to: INTEGER); - BEGIN - IF size.w > 0 THEN AdjustDialogToPref(TRUE, FALSE); size.lastChanged := width - ELSIF size.w # 0 THEN Dialog.Beep - END - END WNotifier; - - PROCEDURE HNotifier* (op, from, to: INTEGER); - BEGIN - IF size.h > 0 THEN AdjustDialogToPref(FALSE, TRUE); size.lastChanged := height - ELSIF size.h # 0 THEN Dialog.Beep - END - END HNotifier; - - PROCEDURE ProportionNotifier* (op, from, to: INTEGER); - BEGIN - IF (op = Dialog.changed) & size.proportional THEN - IF size.lastChanged = width THEN AdjustDialogToPref(TRUE, FALSE) - ELSIF size.lastChanged = height THEN AdjustDialogToPref(FALSE, TRUE) - END - END - END ProportionNotifier; - -END StdViewSizer. diff --git a/new/build-gui b/new/build-gui index c14316b..aa1a4e0 100755 --- a/new/build-gui +++ b/new/build-gui @@ -3,11 +3,12 @@ TARGET=`uname -s` # TARGET=Linux +./clean ./switch-target ${TARGET} Interp ./build ./switch-target ${TARGET} GUI -./run-BlackBox <